1 ' 	ELECTRONIC CARD FILE
2 '  BY Joe Wiellette  617-731-3178
3 ' Permission is granted to use, but not to sell,
4 ' these programs.
50 DEFINT S,L,D,I,J,K,T
52 WIDTH 52
55 ON ERROR GOTO 10000
60 '
61 '
62 '    ************  OPERATE ON RECORDS   **********
63 '
64 ' PROGRAM **  OPERATE  ***
68 PRINT CLSCR$
72 RI=1
75 KI=0
80 REM   ****************   OPERATE program for database set ************
81 '  ****  GET CURRENT DATE ***
82 PRINT"ENTER TODAY'S DATE AS MONTH,DAY,YEAR
83 INPUT"(020982 FOR FEB 9, 1982)";DATE$
84 IF LEN(DATE$)<>6 THEN 82
86 GOSUB 3140
90 CDATE=DATE
200 '  ***  OPEN HASH FILE ***
240 IF A(5)=0 THEN 280
250 IH=INT(A(5)/100):JH=A(5)-(IH*100)
252 V$=DRIVE$+A$(1)+"Z"
260 OPEN"R",#3,V$,LENGTH(IH,JH)+4
262 HSHLEN=LENGTH(IH,JH)
270 FIELD#3,LENGTH(IH,JH) AS S1$,2 AS S2$,2 AS S3$
272 '  *****   GET CHOICE  ****
280 PRINT CLSCR$
290 PRINT"1) *** ADD DATA
300 PRINT"2)  CHANGE DATA
310 PRINT"3)  DELETE RECORDS
320 PRINT"4)  VIEW RECORDS
322 PRINT"5)  RE-HASH RECORDS
323 PRINT"6)  RETURN TO MAIN MENU
327 PRINT"9)  END 
330 DEFAULT$="1":ALLOWED$="1234569":GOSUB 5000:IF ALLOWED =0 THEN 280
340 ON Q GOSUB 360,3710,4220,1530,6000
345 IF Q=6 THEN CLOSE:RUN"MENU
346 IF Q=9 THEN END
350 GOTO 280
360 REM ------------------  ENTER DATA TO NEW RECORD ---------------------
370 PRINT CLSCR$;
380 FOR I=1 TO A(2)
390 FOR J=1 TO F(I)
391 IF I=1 AND J=1 THEN 470
400 PRINT REVERSE$;
410 PRINT LABEL$(I,J);
420 PRINT REVERSE.OFF$;
430 PRINT "  ";
440 IF TYPE(I,J)=4 THEN GOSUB 3000
450 IF TYPE(I,J)=1 THEN PRINT"______   AS M,D,Y (020980)
460 IF TYPE(I,J)=2 THEN PRINT"_______"
462 IF TYPE(I,J)=3 THEN PRINT"$____________"
470 NEXT J
490 REM --------------------  INPUT DATA -----------
504 XD=0
520 MM$(I)="A"
530 FOR J=1 TO F(I)
531 IF I=1 AND J=1 THEN MM$(I)=MM$(I)+MKI$(CDATE):GOTO 600
540 XD=XD+1:Y=LEN(LABEL$(I,J))+3
550 GOSUB 3060:REM   SCREEN INPUT AS I$
560 IF LENGTH(I,J)+LEN(LABEL$(I,J))>79 THEN XD=XD+1
570 IF TYPE(I,J)=1 THEN DATE$=I$: GOSUB 3140:MM$(I)=MM$(I)+MKI$(DATE)
580 IF TYPE(I,J)=2 THEN MM$(I)=MM$(I)+MKS$(VAL(I$))
582 IF TYPE(I,J)=3 THEN MM$(I)=MM$(I)+MKD$(VAL(I$))
590 IF TYPE(I,J)=4 THEN MM$(I)=MM$(I)+I$
600 NEXT J
602 PRINT CLSCR$;
630 NEXT I
690 REM ---------------  PRINT AND SAVE FORMATTED DATA --------------
692 FLAGF=1
700 GOSUB 3320
710 GOSUB 3530
712 FLAGF=0
720 PRINT:PRINT
730 PRINT"SHALL WE RECORD THE DATA (*** = Yes)";
732 DEFAULT$="Y":ALLOWED$="YyNn":GOSUB 5000:IF ALLOWED =0 THEN 730
740 IF Q$="Y" THEN 770
750 PRINT:PRINT:PRINT"THEN WE HAD BETTER START OVER
752 FOR W=1 TO 300:NEXT W
760 GOTO 360
770 GET#2,RI
780 IF LEFT$(RECORD$,1)="A" THEN RI=RI+A(2):GOTO 770
790 FOR M=1 TO A(2)
800 LSET RECORD$=MM$(M)
810 PUT#2,RI
820 RI=RI+1
830 NEXT M
900 REM ----- INSTANT ACCESS FILE KEYS
910 XI=((RI+A(2)-1)/A(2))-1
912 IF FLAGR=1 THEN XI=RECORD
930 IF A(5)=0 THEN 1420:REM  no access key
940 I=INT(A(5)/100)
950 J=A(5)-(I*100) :REM  CHANGE N VALUE INTO I,J FIELD VALUES
960 N$=DTA$(I,J)
962 GOSUB 970
964 GOTO 1150
970 LHT=101
980 HASHV=0
990 N=LEN(N$)
991 IF FLAGR=1 THEN PRINT RECORD,N$
1000 B(0)=0:B(1)=0
1010 FOR T=1 TO N
1020 R=INT((T/2-INT(T/2))*2+.05)*SGN(T/2)
1030 A=ASC(MID$(N$,T))
1040 B(R)=B(R)+A
1050 NEXT T
1060 HASHV=(INT((B(0)/256-INT(B(0)/256))*256+.05)*SGN(B(0)/256))+256*(INT((B(1)/256-INT(B(1)/256))*256+.05)*SGN(B(1)/256))
1070 HASHV=INT((HASHV/LHT-INT(HASHV/LHT))*LHT+.05)*SGN(HASHV/LHT)
1072 IF HASHV=0 THEN HASHV=1
1080 RETURN
1150 GET#3,HASHV
1155 S2=CVI(S2$)
1160 IF ASC(LEFT$(S1$,1))> 33 THEN 1250
1170 REM --- FIRST SLOT EMPTY -- FILL IT
1180 LSET S1$=DTA$(I,J)
1190 LSET S2$=MKI$(KI)
1191 LSET S3$=MKI$(XI)
1192 PUT#3,HASHV
1194 IF FLAGR=1 THEN RETURN
1195 A(4)=A(4)+1
1200 GOTO 1420
1250 REM ---- FIRST SLOT FILLED --- IS THERE A POINTER TO NEXT?
1260 IF S2=0 THEN S2=A(4) ELSE 1300
1270 LSET S2$=MKI$(S2)
1280 PUT#3,HASHV
1290 LSET S1$=DTA$(I,J)
1291 LSET S3$=MKI$(XI)
1292 LSET S2$=MKI$(KI)
1294 PUT#3,A(4)
1295 A(4)=A(4)+1
1298 GOTO 1420
1300 REM ---- POINTER IN FIRST SLOT -- GET NEXT
1310 GET#3,S2
1312 S3=S2
1320 S2=CVI(S2$)
1322 IF S2<>0 THEN 1310
1330 LSET S2$=MKI$(A(4))
1332 PUT#3,S3
1340 LSET S1$=DTA$(I,J)
1342 LSET S2$=MKI$(KI)
1344 LSET S3$=MKI$(XI)
1350 PUT#3,A(4)
1360 A(4)=A(4)+1
1420 REM ------ SAVE REVISED HEADER FILE -----
1430 OPEN"O",#1,HEADER$
1432 IF RI>A(6) THEN A(6)=RI
1440 FOR I=1 TO 10:WRITE#1,A$(I),A(I):NEXT I
1450 FOR I=1 TO A(2)
1460 PRINT#1,F(I)
1462 FOR J=1 TO F(I):WRITE#1,TYPE(I,J),LENGTH(I,J),LABEL$(I,J):NEXT J:NEXT I
1470 CLOSE 1
1500 IF FLAGR=1 THEN RETURN
1502 PRINT:PRINT"RECORD # : "((RI+A(2)-1)/A(2))-1
1510 PRINT BELL$"Tap return to continue ";
1512 Q$=INPUT$(1)
1520 RETURN
1530 REM  --------------------  VIEW RECORDS --------------
1540 PRINT CLSCR$
1550 PRINT"1)  Print All
1560 PRINT"2) *** Select by Record #
1570 PRINT"3)  Search
1580 PRINT"4)  Instant access
1582 PRINT"5)  Return to Main List
1590 PRINT
1600 PRINT"WHICH  ";
1602 ALLOWED$="12345":DEFAULT$="2":GOSUB 5000:IF ALLOWED=0 THEN 1540
1606 IF Q=5 THEN RETURN
1610 ON Q GOSUB 1630,1740,1890,2190
1612 GOTO 1540
1620 RETURN
1630 REM ------------------ PRINT ALL ----------------
1640 INPUT"Enter low record number ",LOW
1642 INPUT"enter high record number (zero for highest) ",HIGH
1644 IF LOW<1 THEN 1640
1648 IF HIGH =0 THEN HIGH=A(6)/A(2)-1
1650 FOR IV=LOW TO HIGH
1660 I=IV
1670 FLAGA=1:FLAGD=1
1680 GOSUB 1760
1682 IF FLAGR=1 THEN GOSUB 900:GOTO 1710
1690 PRINT:PRINT:PRINT
1700 PRINT"TAP RETURN FOR NEXT ";
1702 Q$=INPUT$(1)
1710 NEXT IV
1720 FLAGD=0
1722 FLAGR=0
1730 RETURN
1740 REM ----------------  SELECT BY RECORD # ------------
1750 INPUT"Enter Record # (0 TO QUIT)  ",I
1760 RECORD=I
1770 IF I=0 THEN RETURN
1780 I=(RECORD*A(2))-A(2)+1
1790 FOR M=I TO I+A(2)-1
1800 GET#2,M
1810 MM=M-I+1
1820 MM$(MM)=RECORD$
1830 NEXT M
1840 IF FLAGB=1 THEN FLAGB=0:RETURN
1850 GOSUB 3320
1852 IF FLAGR=1 THEN RETURN
1860 GOSUB 3530
1870 IF FLAGA=1 THEN FLAGA=0:RETURN
1880 GOTO 1750
1890 REM ----------------  SEARCH  ---------------------
1900 PRINT CLSCR$;
1910 FOR I=1 TO A(2)
1920 FOR J=1 TO F(I)
1930 N=(I*100)+J
1940 PRINT N TAB(7) LABEL$(I,J)
1950 NEXT J,I
1952 LAST=N
1960 PRINT:INPUT"Enter the search field number ";N
1962 IF N<100 OR N>LAST THEN PRINT"Invalid field choice. Try again":GOTO 1960
1970 II=INT(N/100):JJ=N-(II*100)
1972 INPUT"Enter lowest record number to search ";LOW
1980 PRINT"Enter highest record number
1981 INPUT"   (zero for current last record) ";HIGH:IF HIGH=0 THEN HIGH=A(6)/A(2)-1
1982 PRINT"String searches show records where first
1983 PRINT"   5 characters match"
1990 INPUT"Enter the object of your search  ",SEARCH$
2000 IF LEN(SEARCH$)<5 THEN SEARCH$=SEARCH$+" ":GOTO 2000
2010 IF TYPE(II,JJ)=1 THEN GOSUB 2140
2012 IF TYPE(II,JJ)=4 THEN Q=1:GOTO 2030
2020 INPUT"1) Equal to 2) Greater than 3) Less than  ",Q
2030 FOR IV=LOW TO HIGH
2040 I=IV
2050 FLAGB=1
2060 GOSUB 1760
2070 GOSUB 3320
2080 IF Q=1 AND TYPE(II,JJ)=4 AND LEFT$(DTA$(II,JJ),5)=LEFT$(SEARCH$,5) THEN GOSUB 3530:PRINT:PRINT:GOSUB 10050
2090 IF Q=2 AND TYPE(II,JJ)<4 AND VAL(SEARCH$)<VAL(DTA$(II,JJ)) THEN GOSUB 3530:PRINT:PRINT:GOSUB 10050
2100 IF Q=1 AND TYPE(II,JJ)<4 AND VAL(SEARCH$)=VAL(DTA$(II,JJ)) THEN GOSUB 3530:PRINT:PRINT:GOSUB 10050
2110 IF Q=3 AND TYPE(II,JJ)<4 AND VAL(SEARCH$)>VAL(DTA$(II,JJ)) THEN GOSUB 3530:PRINT:PRINT:GOSUB 10050
2120 NEXT IV
2130 RETURN
2140 REM   DATE DECODE
2150 I$=SEARCH$
2160 GOSUB 3140
2170 SEARCH$=STR$(DATE)
2180 RETURN
2190 REM ---------------  INSTANT ACCESS TO RECORDS --------------
2200 PRINT CLSCR$;
2290 INPUT"Enter the object of your search ",N$
2292 IF LEN(N$)<HSHLEN THEN N$=N$+" ":GOTO 2292
2300 GOSUB 970
2350 GET#3,HASHV
2352 NXVAL=CVI(S2$)
2360 IF S1$=N$ THEN GOSUB 2392
2370 IF CVI(S2$)=0 OR CVI(S2$)=-1 THEN RETURN
2380 GET#3,NXVAL
2382 NXVAL=CVI(S2$)
2390 GOTO 2360
2392 IF CVI(S3$)=0 THEN 2560
2500 GET#2,CVI(S3$)
2510 I=CVI(S3$)
2520 FLAGA=1:FLAGD=1
2530 GOSUB 1760
2550 GOSUB 10050
2560 RETURN
2900 STOP
3000 REM --------------  ROUTINE TO PRINT STRING BLANKS ---------
3010 FOR K=1 TO LENGTH(I,J)
3020 PRINT "_";
3030 NEXT K
3040 PRINT
3050 RETURN
3060 REM -------------- ROUTINE TO PLACE CURSOR AND INPUT------------
3070 PRINT CHR$(27)CHR$(61)CHR$(XD+31)CHR$(Y+31);
3072 IF TYPE(I,J)=3 THEN PRINT"$";
3078 PRINT BELL$;
3080 LINE INPUT I$
3082 IF TYPE(I,J)=4 AND LEN(I$)>LENGTH(I,J) THEN PRINT"Too many characters. Start over.":GOSUB 10050:GOTO 280
3084 IF TYPE(I,J)=1 AND LEN(I$)<>6 THEN PRINT"Incorrect date - try again":GOSUB 10050:GOTO 280
3090 IF TYPE(I,J)=4 THEN 3100 ELSE 3130
3100 IF LEN(I$)=>LENGTH(I,J) THEN 3130
3110 I$=I$+" "
3120 GOTO 3100
3130 RETURN
3140 REM ----------- ROUTINE TO CONVERT DATE TO JULIAN ----------
3150 MONTH=VAL(LEFT$(DATE$,2))
3160 DAY=VAL(MID$(DATE$,3,2))
3170 YEAR=VAL(RIGHT$(DATE$,2))
3180 DATE=INT(30.57*MONTH)+INT(365.25*YEAR-395.25)+DAY
3190 IF(INT(YEAR/4)*4)+1=YEAR THEN DATE=DATE-1
3200 IF MONTH<3 THEN DATE=DATE+1:GOTO 3230
3210 IF INT(YEAR/4)*4=YEAR THEN 3230
3220 DATE=DATE-1
3230 IF DATE>32500 THEN DATE=32500-DATE
3232 RETURN
3240 REM ----------- CONVERT JULIAN TO CALNDAR  ---------------
3242 IF S$="" THEN RETURN
3250 JULIAN=CVI(MID$(S$,LN,LENGTH(F,J)))
3252 IF JULIAN<0 THEN JULIAN=32500-JULIAN
3260 YEAR=INT(JULIAN/365.26)+1
3270 DAY=JULIAN+INT(395.25-365.25*YEAR)
3280 D1=2:IF INT(YEAR/4)*4=YEAR THEN D1=1
3290 IF DAY>91 THEN DAY=DAY+D1
3300 MONTH=INT(DAY/30.57):DAY=DAY-INT(30.57*MONTH)
3310 RETURN
3320 REM -------------  CONVERT RETREIVED RECORD INTO FIELDS ---------------
3330 LN=2
3340 FOR F=1 TO A(2)
3350    S$=MM$(F)
3360    FOR J=1 TO F(F)
3370    ON TYPE(F,J) GOSUB 3430,3470,3490,3510
3380    LN=LN+LENGTH(F,J)
3390    NEXT J
3400 LN=2
3410 NEXT F
3420 RETURN
3430 REM  DATE CONVERT
3440 GOSUB 3240
3450 DTA$(F,J)=STR$(CVI(MID$(S$,LN,LENGTH(F,J))))
3460 RETURN
3470 DTA$(F,J)=STR$(CVS(MID$(S$,LN,LENGTH(F,J))))
3480 RETURN
3490 DTA$(F,J)=STR$(CVD(MID$(S$,LN,LENGTH(F,J))))
3500 RETURN
3510 DTA$(F,J)=MID$(S$,LN,LENGTH(F,J))
3520 RETURN
3530 REM ---------------- PRINT RECORDS ------------
3540 PRINT CLSCR$;
3550 IF FLAGF<>1 THEN PRINT TAB(20)"RECORD # "RECORD
3560 IF FLAGD=1 AND LEFT$(RECORD$,1)<>"A" THEN 3700
3570 FOR I=1 TO A(2)
3580 FOR J=1 TO F(I)
3590 PRINT LABEL$(I,J) TAB(20);
3600 ON TYPE(I,J) GOSUB 3640,3670,3690,3670
3610 NEXT J
3620 NEXT I
3630 RETURN
3640 JULIAN=VAL(DTA$(I,J)):GOSUB 3260
3650 IF VAL(DTA$(I,J))>0 THEN PRINT MONTH;DAY;YEAR ELSE PRINT
3660 RETURN
3670 PRINT DTA$(I,J)
3680 RETURN
3690 PRINT USING DLR$;VAL(DTA$(I,J))
3700 RETURN
3710 REM ----------------  CHANGE DATA  ------------------
3720 INPUT"Enter record # to be changed  ";I
3722 IF I<1 OR I>A(6) THEN 3720
3730 FLAGB=1
3740 GOSUB 1760
3750 GOSUB 3320
3760 PRINT CLSCR$;
3770 PRINT TAB(20)"RECORD #  "RECORD
3780 FOR I=1 TO A(2)
3790 FOR J=1 TO F(I)
3792 N=(100*I)+J
3800 PRINT N"  " LABEL$(I,J) "  ";
3810 ON TYPE(I,J) GOSUB 3850,3870,3890,3870
3820 NEXT J
3830 NEXT I
3832 LAST=N
3840 GOTO 3910
3850 DATE=VAL(DTA$(I,J)):GOSUB 3260:PRINT MONTH" "DAY" "YEAR
3860 RETURN
3870 PRINT DTA$(I,J)
3880 RETURN
3890 PRINT USING DLR$;VAL(DTA$(I,J))
3900 RETURN
3910 PRINT:PRINT
3920 INPUT"Enter field number to be changed  ",N
3921 IF N=A(5) THEN PRINT"Access key field - can't change - delete and re-enter":GOSUB 10050:RETURN
3922 I=INT(N/100)
3923 J=N-(I*100)
3925 IF N<100 OR N>LAST THEN PRINT"Invalid field choice. Try again.":GOTO 3920
3930 PRINT"Enter new data"
3940 GOSUB 3080
3950 IF TYPE(I,J)=1 THEN GOSUB 3140:I$=STR$(DATE)
3960 DTA$(I,J)=I$
3980 FOR I=1 TO A(2)
3982 MM$(I)="A"
3990 FOR J=1 TO F(I)
4000 IF TYPE(I,J)=4 THEN MM$(I)=MM$(I)+DTA$(I,J)
4020 IF TYPE(I,J)=1 THEN MM$(I)=MM$(I)+MKI$(VAL(DTA$(I,J)))
4040 IF TYPE(I,J)=2 THEN MM$(I)=MM$(I)+MKS$(VAL(DTA$(I,J)))
4042 IF TYPE(I,J)=3 THEN MM$(I)=MM$(I)+MKD$(VAL(DTA$(I,J)))
4080 NEXT J
4090 NEXT I
4100 GOSUB 3320
4110 GOSUB 3530
4120 REC=(RECORD*A(2))-A(2)
4130 FOR M=1 TO A(2)
4140 LSET RECORD$=MM$(M)
4150 PUT#2,REC+M
4160 NEXT M
4200 GOSUB 10050
4210 RETURN
4220 REM  --------------   DELETE RECORDS ----------------
4230 PRINT CLSCR$
4240 INPUT"Enter record # to be deleted  ",DEL
4242 IF DEL<1 OR DEL>A(6) THEN 4240
4250 I=DEL
4260 FLAGA=1
4270 GOSUB 1760
4280 PRINT"Delete this one (*** YES) ";
4282 ALLOWED$="YyNn":DEFAULT$="Y":GOSUB 5000:IF ALLOWED=0 THEN 4280
4290 IF Q$="Y" THEN 4300 ELSE 4520
4300 A$=""
4310 I=(DEL*A(2))-A(2)+1
4320 LSET RECORD$=A$
4330 FOR M=I TO I+A(2)-1
4340 PUT#2,M
4350 NEXT M
4360 IF A(5)=0 THEN 4520
4400 N$=DTA$(IH,JH)
4410 GOSUB 970
4420 GET#3,HASHV
4430 IF RECORD=CVI(S3$) THEN 4500
4440 HASHV=CVI(S2$)
4450 GOTO 4420
4500 LSET S3$=MKI$(0)
4502 LSET S1$=""
4510 PUT#3,HASHV
4520 RETURN
5000 '
5010 '		***  ENTER RESPONSE ***
5020 '
5100 PRINT BELL$;
5110 ALLOWED=0
5120 Q$=INPUT$(1)
5130 PRINT Q$
5140 IF Q$="y" THEN Q$="Y"
5150 IF Q$=CHR$(13) THEN Q$=DEFAULT$
5160 Q=VAL(Q$)
5170 FOR L=1 TO LEN(ALLOWED$)
5180 IF MID$(ALLOWED$,L,1)=Q$ THEN ALLOWED=1
5190 NEXT L
5200 RETURN
5210 '
5220 '
6000 REM -----------  RE-HASH RECORDS --------------
6010 PRINT CLSCR$
6020 A(4)=101
6030 INPUT"Enter field name for access ";NAM$
6040 FOR N=1 TO 10
6050 FOR P=1 TO 20
6060 IF LABEL$(N,P)=NAM$ THEN 6090
6070 NEXT P,N
6080 PRINT"Can't find it.  Start again ":GOTO 6030
6090 A(5)=(N*100)+P
6100 INPUT"Enter max # of files ",MAX
6110 Z=0
6120 LSET S1$="":LSET S2$=MKI$(Z):LSET S3$=MKI$(Z)
6130 FOR I=1 TO MAX
6140 PUT#3,I
6150 NEXT I
6160 INPUT"Enter lowest file number for re-hashing ",LOW
6170 INPUT"Enter highest file number for re-hashing (zero for last record) ",HIGH
6180 IF LOW<1 THEN 6160
6190 IF HIGH=0 THEN HIGH=INT(A(6)/A(2))
6200 FLAGR=1
6210 GOSUB 1650
6220 GOSUB 1420
6230 FLAGR=0
6240 RETURN
10000 REM ***********  ERROR HANDLING  **************
10010 IF ERR=53 THEN PRINT"No such file name.":CLOSE:RESUME 90
10020 IF ERR=7 THEN PRINT"I have to reorganize memory by re-starting":CLOSE:GOTO 280
10030 IF ERR=13 THEN PRINT"Incorrect type of input. Start over.":CLOSE:GOTO 290
10040 ON ERROR GOTO 0
10050 REM ------- INPUT TO RETURN -----
10060 PRINT CHR$(7);
10070 PRINT"TAP RETURN TO CONTINUE ";
10080 Q$=INPUT$(1)
10090 IF Q$=CHR$(13) THEN Q$="0"
10100 RETURN
060 PRINT CHR$(7);
