100 '
110 '			 PHONDAT.BAS
120 '		    Last revision 1/10/81
130 '
140 ' Originally written by Bruce Levison-Aug.15,1980
150 '
154 ' Must use the /X option if compiling with BASCOM
156 '
157 ' Warning...this program will not work properly with
158 ' the old data file PHONDAT. This program uses an 80
159 ' character record size.
160 '
169 '09/25/80 Revised to format the data file so that
170 '	      a simple TYPE command from CP/M will produce a header
180 ' 	      and nicely formated table. Also re-wrote the code to
190 ' 	      make it more readable. (BL)
200 '
210 '11/04/80 Changed the record length from 64 to 80 characters to allow
220 '         for a larger comment field. (BL)
221 '
222 '12/20/80 Added an editing funtion. (BL)
223 '
224 '01/10/81 Added the sort funtion. (BL)
225 '
230 ' Define a few things.
240 DEFINT A-Z			'make all numbers integer type
250 WIDTH 255			'unlimited
255 EDFLAG=0			'edit flag
260 CRLF$=CHR$(13)+CHR$(10)	'carriage return,line feed
270 HON$=CHR$(14)		'character highlight on/or a null
280 HOFF$=CHR$(14)+CHR$(15)	'character highlight off/or 2 nulls
289 '
290 ' The following string HDR$ must be exactly 55 characters in
300 ' length. Use spaces to fill out if necessary. Also it starts
310 ' printing in the 6th character position of the line upon output.
320 '     XXXX1XXXXXXXXX2XXXXXXXXX3XXXXXXXXX4XXXXXXXXX5XXXXXXXXX6  Column #
330 HDR$="Phone No.     Name of Party     Baud  Passwd    Comment" '(OUTPUT)
334 '
338 'No more user modifications are necessary.
339 '
340 ' Open and field file for 80 characters per record. The last
350 ' 2 characters are taken up by carriage return,line feed.
360 OPEN "R",1,"PHONDAT",80	'PHONDAT is name of datafile
370 FIELD #1,16 AS NUM$,20 AS NAM$,5 AS MAXBAUD$,11 AS PSWRD$,26 AS COM$,                    2 AS ACRLF$
380 FIELD #1,5 AS WREC$,75 AS DUM$
390 ' If PHONDAT does'nt exist then create and initialize it.
400 IF LOF(1)>0 THEN GOTO 500
410 LSET WREC$=STR$(3)			   'first available data record
420 LSET DUM$=STRING$(71,32)+CRLF$+CRLF$   'clear rest of file buffer + cr/lf
430 PUT #1,1				   'store next available record counter
440 ' Create header for table in record 2.
450 LSET WREC$=HON$			   'turn highlight on
460 ' The following writes the header,turns highlight off,appends spaces,cr/lf
470 LSET DUM$=LEFT$(HDR$,55)+HOFF$+STRING$(16,32)+CRLF$
480 PUT #1,2				   'store header in record 2
490 '
500 ' Start by getting next available record counter.
510 GET #1,1 				   'get next available record counter
520 WREC=VAL(WREC$)			   'change to number
521 '
522 'Get desired user funtion
523 PRINT: PRINT "(A)dd  (E)dit  (S)ort  e(X)it ? ";: Z$=INPUT$(1): PRINT Z$
524 IF (Z$="A" OR Z$="a") THEN 530
525 IF (Z$="E" OR Z$="e") THEN EDFLAG=1: GOTO 1000  'set edit flag
526 IF (Z$="S" OR Z$="s") THEN 1500
527 IF (Z$="X" OR Z$="x") THEN 770
528 PRINT "Enter either A or E or S or X to the question.": GOTO 523
529 '
530 'Take input from console and set into random file buffer.
540 PRINT
550 LINE INPUT "Phone Number: ";Z$: LSET NUM$=Z$: IF EDFLAG THEN 1115
560 LINE INPUT "Operator    : ";Z$: LSET NAM$=Z$: IF EDFLAG THEN 1115
570 LINE INPUT "Max.Baud    : ";Z$
580 WHILE LEN(Z$)<4 : Z$=" "+Z$ : WEND
590 LSET MAXBAUD$=Z$: IF EDFLAG THEN 1115
600 LINE INPUT "Password    : ";Z$: LSET PSWRD$=Z$: IF EDFLAG THEN 1115
610 LINE INPUT "Comment     : ";Z$: LSET COM$=Z$: IF EDFLAG THEN 1115
620 LSET ACRLF$=CRLF$		'cr/lf at end of every record
630 ' Write next available record.
640 PUT #1,WREC
650 ' Increment next available record counter.
660 WREC=WREC+1
670 ' More entries ???
680 PRINT: PRINT "Another ? ";: Z$=INPUT$(1): PRINT Z$
690 IF (ASC(Z$) AND 95)=ASC("Y") THEN 540	'make response upper case
700 ' The following two lines "pear" off any leading spaces from
710 ' the next available record counter before putting it back to disk.
720 ZZ$=STR$(WREC)
730 IF LEFT$(ZZ$,1)=" " THEN ZZ$=MID$(ZZ$,2,6): GOTO 730
740 LSET WREC$=ZZ$	
750 LSET DUM$=STRING$(71,32)+CRLF$+CRLF$
760 PUT #1,1		'put next available record counter back
765 GOTO 523
770 ' Now end
780 CLOSE
790 PRINT
800 PRINT "++Done++"
810 END
999  '
1000 'Edit routine
1002 '
1005 PRINT
1010 LINE INPUT "Which operator to edit ? ";Z$
1020 FOR I=3 TO WREC-1
1030 GET #1,I
1040 IF INSTR(NAM$,Z$)<>0 THEN 1080
1050 NEXT I
1060 PRINT "++Operator not found in any of the records++"
1065 EDFLAG=0		'reset edit flag
1070 GOTO 523
1080 PRINT: PRINT WREC$;DUM$
1090 PRINT "This one to edit ? ";
1100 ZZ$=INPUT$(1):PRINT ZZ$
1110 IF (ASC(ZZ$) AND 95) <> ASC("Y") THEN 1050  'keep searching
1115 PRINT
1120 PRINT "(1) Phone number: ";NUM$
1130 PRINT "(2) Operator    : ";NAM$
1140 PRINT "(3) Max.Baud    : ";MAXBAUD$
1150 PRINT "(4) Password    : ";PSWRD$
1160 PRINT "(5) Comment     : ";COM$
1165 PRINT
1170 PRINT "(6) Done edit"
1180 PRINT
1190 PRINT "Which # to edit ? ";: Z$=INPUT$(1): Z=VAL(Z$): PRINT Z$
1200 PRINT
1205 IF (Z<1 OR Z>6) THEN 1190
1210 ON Z GOTO 550,560,570,600,610,1250
1250 PUT #1,I
1255 EDFLAG=0		'reset edit flag
1260 GOTO 523
1500 '
1510 '			SORT
1520 '
1530 ' MODIFIED FOR USE WITH PHONDAT.BAS
1540 '
1545 ON ERROR GOTO 2500
1550 CLOSE	'make sure
1560 DIM A1$(100),A(100),LO$(2),LA$(2)	'100 names to sort max.
1570 '
1580 '		F1$= filename to be sorted
1590 '		F2$= back-up file after sort
1600 '		F3$= new sorted file
1610 '		 Z= number of characters per record
1620 '		LS= length of sort field
1630 '		 ST= first character of sort field
1640 '
1650 F1$="PHONDAT"
1660 F2$="PHONDAT.BAC"
1670 F3$="PHONDAT.$$$"
1680 Z=80
1690 LS=20
1700 ST=17
1710 '
1720 LE=Z-(ST-1)
1730 OPEN "R",2,F1$,Z
1740 FIELD 2,(ST-1) AS LA$(2),LE AS LA$(1): FIELD 2,5 AS WREC$
1750 GOSUB 1970		: REM LOAD ARRAY WITH KEY & RECORD NO.
1760 '		I=NUMBER OF ELEMENTS TO BE SORTED
1770 '		OTHER VARIABLES USED
1780 '			M,J,K,I1,L,A$,B$
1790 '
1800 I=WREC
1810 M=I
1820 M=INT(M/2)
1830 IF M=0 THEN 2050		: REM FINISHED
1840 J=2 : K=I-M
1850 I1=J
1860 L=I1+M
1870 IF A1$(I1)<A1$(L) THEN 1940
1880 SWAP A1$(I1),A1$(L)
1890 SWAP A(I1),A(L)
1900 PRINT TAB(10);LEFT$(A1$(L),15),A(L)
1910 I1=I1-M
1920 IF I1<2 THEN 1940
1930 GOTO 1860
1940 J=J+1
1950 IF J>K THEN 1820
1960 GOTO 1850
1970 ' INPUT KEY AND RECORD.NO
1980 GET #2,1
1990 WREC=VAL(WREC$)-1
2000 FOR I=3 TO WREC
2010 GET #2,I
2020 A1$(I)=LEFT$(LA$(1),LS) : A(I)=I
2030 NEXT I
2040 RETURN
2050 '
2055 PRINT "Writing sorted file back to disk...";
2060 KILL F3$
2070 OPEN "R",1,F3$,Z: FIELD 1,5 AS WREC1$: FIELD 1,Z AS ZZ$
2080 FIELD 1,(ST-1) AS LO$(2),LE AS LO$(1)
2090 FOR I=3 TO WREC
2100 GET #2,A(I)
2110 LSET LO$(1)=LA$(1) : LSET LO$(2)=LA$(2)
2120 PUT #1,I
2130 NEXT I
2140 FOR I=1 TO 2
2150 GET #2,I
2160 LSET LO$(1)=LA$(1) : LSET LO$(2)=LA$(2)
2170 PUT #1,I
2180 NEXT I
2190 CLOSE 1,2,3
2200 KILL F2$: NAME F1$ AS F2$
2210 NAME F3$ AS F1$
2215 PRINT
2220 GOTO 360
2500 '
2505 '		ERROR TRAP
2510 IF ERR=53 THEN RESUME NEXT
2600 ON ERROR GOTO 0
2610 END
S F1$
2215 PRINT
2220 GOTO 360
2500 '
2505 '		ERROR TRAP
2510 IF ERR=53 THEN RESUME NEXT
2600 ON ERROR GO