home *** CD-ROM | disk | FTP | other *** search
/ Nibble Magazine / nib23a.dsk / MARCH.1985 / MEDIC.bas next >
BASIC Source File  |  2023-02-26  |  32KB  |  656 lines
  1. 10  REM  *********4.12.85********
  2. 20  REM  *        MEDIC         *
  3. 30  REM  *    BY MARK CRAVEN    *
  4. 40  REM  *  COPYRIGHT (C) 1985  *
  5. 50  REM  *  BY MICROSPARC, INC  *
  6. 60  REM  *  CONCORD, MA. 01742  *
  7. 70  REM  ************************
  8. 80  PRINT  CHR$(21): TEXT : HOME 
  9. 90  ONERR  GOTO 6260: REM  CATCH ALL ERRORS
  10. 100  GOSUB 1280: REM  HEADER
  11. 110 D$ =  CHR$(4)
  12. 120  DIM FL$(15),M$(50,8)
  13. 130 YR$ = "": HOME :V = 10:H = 24: VTAB V: HTAB 1: CALL  -868: PRINT "INPUT YEAR OF INTEREST ";: GOSUB 890
  14. 140  FOR I = 1 TO 2: GET YR$(I): PRINT YR$(I);: GOSUB 920:YR$ = YR$ +YR$(I): NEXT 
  15. 150  GOSUB 900: IF ER = 1  THEN ER = 0: GOTO 130
  16. 160 FL$ = "HEADER" +"." +YR$
  17. 170  GOSUB 5780: REM  READ HEADER--LOAD SCROLLOFF
  18. 180  IF M1 = 0  AND CS = 8  THEN  RETURN 
  19. 190  GOSUB 200: GOTO 290
  20. 200  FOR I = 0 TO 8: READ MU$(0,I): NEXT 
  21. 210  FOR I = 1 TO 8: READ MU$(1,I): NEXT 
  22. 220  FOR I = 1 TO 4: READ MU$(3,I): NEXT 
  23. 230  FOR I = 1 TO 4: READ MU$(5,I): NEXT 
  24. 240  FOR I = 1 TO 2: READ MU$(9,I): NEXT 
  25. 250  FOR I = 1 TO 8: READ H%(I): NEXT 
  26. 260  FOR I = 1 TO 8: READ L%(I): NEXT 
  27. 270  FOR I = 0 TO 2: READ HL$(I): NEXT 
  28. 280  RETURN 
  29. 290 C = 1
  30. 300 HT = 10:V% = 1:HL% = 1:S = 8:M1 = 0:M2 = 0: CALL 54915: REM  S=# OF MENU CHOICES
  31. 310 VS% = 2
  32. 320  GOTO 360
  33. 330  VTAB HL% +V% +OS +OS *(S <10): HTAB HT: PRINT MU$(M1,OS)
  34. 340  VTAB HL% +V% +CS +CS *(S <10): INVERSE : HTAB HT: PRINT MU$(M1,CS): NORMAL 
  35. 350  RETURN 
  36. 360  TEXT : CALL 820:CS = 0: INVERSE : GOSUB 690: GOSUB 720
  37. 370 CS = C: REM  CURRENT SELECTION
  38. 380  FOR M2 = 1 TO S: IF M2 = CS  THEN  INVERSE 
  39. 390  VTAB HL% +VS% *M2 +V%
  40. 400  HTAB HT: PRINT MU$(M1,M2): NORMAL 
  41. 410  NEXT 
  42. 420  VTAB 23: INVERSE : PRINT "<-";: NORMAL : PRINT " ";: INVERSE : PRINT "->";: NORMAL : PRINT " TO SELECT .... ";: INVERSE : PRINT "RETURN";: NORMAL : PRINT " TO EXECUTE."
  43. 430  VTAB 24: HTAB 1: PRINT "UP OR DOWN ARROW KEYS MAY ALSO BE USED";: POKE  -16368,0
  44. 440 K =  PEEK( -16384): IF K <128  THEN 440
  45. 450  POKE  -16368,0:K = K -128: IF K < >8  AND K < >21  AND K < >11  AND K < >10  AND K < >13  THEN 440: REM  ONLY CHOICES
  46. 460 OS = CS
  47. 470  IF K = 8  OR K = 11  THEN CS = CS -1:CS = CS *(CS >0) +S *(CS = 0): GOSUB 330: GOTO 440: REM  UP OR LEFT ARROWS
  48. 480  IF K = 21  OR K = 10  THEN CS = CS +1:CS = CS *(CS < = S) +(CS = S +1): GOSUB 330: GOTO 440: REM  RIGHT ARROW OR DOWN ARROW
  49. 490  IF M1 = 0  THEN  POKE 972,CS
  50. 500  ON M1 GOTO 510,520,530,540,550,560,570,580,590
  51. 510  ON CS GOTO 1520,2500,2740,4530,5110,5470,6140,5690
  52. 520  GOTO 2920
  53. 530  ON CS GOTO 2850,3280,3820,290
  54. 540  GOTO 3490: REM  INDIVIDUAL NAME FOR SEARCH/SORT
  55. 550  ON CS GOTO 4580,4580,4580,290
  56. 560  GOTO 3330: REM  ALL CHOICES BACK TO SEARCH BY FIELD
  57. 570  ON CS GOTO 3480,3600
  58. 580  GOTO 3470: REM  INDIV/FAMILYCHOICE M1=8
  59. 590  ON CS GOTO 4610,4670: REM  M1=9
  60. 600  REM 
  61. 610  REM  **********************
  62. 620  REM  *                    *
  63. 630  REM  *   BEGINNING OF     *
  64. 640  REM  *    SUBROUTINE      *
  65. 650  REM  *     SECTION        *
  66. 660  REM  *                    *
  67. 670  REM  **********************
  68. 680  REM 
  69. 690  VTAB 1: HTAB 20 - LEN(MU$(M1,M2))/2: PRINT MU$(M1,M2);: RETURN 
  70. 700  FOR I = 38 TO 0  STEP  -1: POKE 32,I: POKE 33,40 -I: HOME : NEXT : RETURN 
  71. 710  POKE 32,0: FOR I = 0 TO 39: POKE 33,I +1: HOME : NEXT : RETURN 
  72. 720  NORMAL : VTAB 2: HTAB 14: PRINT "YEAR = 19";YR$: RETURN 
  73. 730  FOR I = 1 TO  LEN(X$)
  74. 740  IF  ASC( MID$ (X$,I,1)) <65  AND  ASC( MID$ (X$,I,1)) < >32  AND  ASC( MID$ (X$,I,1)) < >46  THEN  HTAB 1: VTAB 2 *M2 +3 -2 *(ED% >0): CALL  -868: PRINT "LETTERS ONLY!";: GOSUB 1030:ER = 1: HTAB 1: CALL  -868: HTAB 1:I =  LEN(X$)
  75. 750  NEXT I: RETURN 
  76. 760  IF M2 = 1  AND  LEN(X$) >12  THEN  HTAB 1: VTAB 2 *M2 +3 -2 *(ED% >0): CALL  -868: PRINT "NAME TOO LONG";: GOSUB 1030:ER = 1: HTAB 1: CALL  -868: HTAB 1
  77. 770  RETURN 
  78. 780  VTAB 2 *M2 +3: FOR J = 1 TO 1 +L%(M2): HTAB J: PRINT  CHR$(95);: NEXT : HTAB 1: RETURN 
  79. 790  IF M2 >1  AND  LEN(I$(M2)) >(L%(M2) +1)  THEN  HTAB 1: VTAB 2 *M2 +3 +(ED% * -2): CALL  -868: PRINT "ENTRY TOO LONG";: GOSUB 1030:ER = 1: HTAB 1: CALL  -868: HTAB 1
  80. 800  RETURN 
  81. 810  FOR J = 1 TO  LEN(X$): IF  ASC( MID$ (X$,J,1)) <48  OR  ASC( MID$ (X$,J,1)) >57  THEN  CALL 65338: CALL 65338: VTAB 2 *K +3 -2 *(ED% >0): HTAB H%(K): CALL  -868: PRINT "BAD ENTRY";: GOSUB 1030:ER = 1: HTAB H%(K): CALL  -868:J =  LEN(X$)
  82. 820  NEXT : RETURN 
  83. 830  FOR J = 1 TO  LEN(X$): IF  ASC( MID$ (X$,J,1)) <48  OR  ASC( MID$ (X$,J,1)) >57  THEN  CALL 65338: CALL 65338: VTAB 2 *M2 +3 -2 *(ED% >0): HTAB 1: CALL  -868: PRINT "BAD ENTRY";: GOSUB 1030:ER = 1: HTAB 1: CALL  -868:J =  LEN(X$)
  84. 840  NEXT : RETURN 
  85. 850  FOR J = 1 TO  LEN(X$):Y$ =  MID$ (X$,J,1)
  86. 860  IF  ASC(Y$) <48  AND  ASC(Y$) < >46  OR  ASC(Y$) >57  AND  ASC(Y$) < >46  THEN  HTAB 1: VTAB 2 *M2 +3 -2 *(ED% >0): CALL 65338: CALL  -868: PRINT "ENTRY ERROR!";: GOSUB 1030:ER = 1: HTAB 1: CALL  -868:J =  LEN(X$)
  87. 870  NEXT : RETURN 
  88. 880  VTAB 2 *M2 +3: HTAB 1: PRINT "$ ";: HTAB 3: RETURN 
  89. 890  VTAB V: HTAB H: PRINT "19"; CHR$(95); CHR$(95);: HTAB H +2: RETURN 
  90. 900  FOR J = 1 TO  LEN(YR$): IF  ASC( MID$ (YR$,J,1)) <48  OR  ASC( MID$ (YR$,J,1)) >57  THEN  HTAB H: VTAB V: CALL  -868: PRINT " NUMERALS ONLY !";: GOSUB 1030:ER = 1: HTAB H: CALL  -868:J =  LEN(YR$)
  91. 910  NEXT J: RETURN 
  92. 920  IF  ASC(YR$(I)) <48  OR  ASC(YR$(I)) >57  THEN  CALL 65338: CALL 65338:YR$ = "": POP : GOTO 130
  93. 930  RETURN 
  94. 940 DC% = 0: FOR D = 1 TO  LEN(X$): IF  ASC( MID$ (X$,D,1)) = 46  THEN DC% = DC% +1
  95. 950  NEXT : IF DC% = 0  THEN X$ = X$ +".00": GOTO 1010
  96. 960  IF DC% >1  THEN ER = 1: HTAB 1: VTAB 2 *M2 +3 -2 *(ED% >0): CALL 65338: CALL  -868: PRINT "ENTRY ERROR!";: GOSUB 1030: HTAB 1: CALL  -868: RETURN 
  97. 970 PD = 0: FOR D = 1 TO  LEN(X$): IF  ASC( MID$ (X$,D,1)) = 46  THEN PD = D
  98. 980  NEXT 
  99. 990  IF  LEN(X$) -PD >2  THEN X$ =  LEFT$(X$, LEN(X$) -1): GOTO 990
  100. 1000  IF  LEN(X$) -PD < >2  THEN X$ = X$ +"0": GOTO 1000
  101. 1010  IF M2 < >4  AND  LEN(X$) >7  THEN X$ = "*****"
  102. 1020  RETURN 
  103. 1030  POKE  -16368,0: GET G$: RETURN : REM  ERROR DISPLAYED-CONTINUE
  104. 1040  POKE 33,4: POKE 32,35: POKE 34,22: POKE 35,22: HOME : RETURN : REM  SET INPUT WINDOW FOR DISPLAY
  105. 1050  POKE 32,0: POKE 33,40: POKE 34,0: POKE 35,24: RETURN : REM  FULL WINDOW AGAIN
  106. 1060  VTAB 23: HTAB 1: PRINT "'P'=PRINT  <ESC>=MAIN MENU  <RTN>=CONT";:
  107. 1070  GET X$: POKE  -16368,0
  108. 1080  IF X$ = "P"  THEN  VTAB  PEEK(37) -1: GOSUB 6500: GOTO 1060
  109. 1090  IF X$ =  CHR$(13)  THEN  RETURN 
  110. 1100  IF X$ =  CHR$(27)  THEN M1 = 0:M2 = 0: POP : GOTO 290
  111. 1110  GOTO 1060
  112. 1120  POKE 33,40 -H%(M2): POKE 32,H%(M2) -1: POKE 34,2 *M2 +2: POKE 35,2 *M2 +3
  113. 1130  RETURN 
  114. 1140  IF X$(J) =  CHR$(27)  AND ED% = 1  THEN I$(K) = X$(J): POP :J = 3: POP : GOTO 4140
  115. 1150  IF X$(J) =  CHR$(27)  THEN  POP : POP :M1 = 0:M2 = 0: GOTO 290: REM  CHECK FOR ESC
  116. 1160  IF (X$(J) =  CHR$(13)  OR X$ =  CHR$(27)  OR X$(J) = "/")  AND ED% = 1  THEN I$(K) = X$(J): POP :J = 3: POP : GOTO 4140
  117. 1170  RETURN 
  118. 1180  IF X$(J) =  CHR$(13)  THEN  GOSUB 1200: POP : CALL 65338: CALL 65338: GOTO 1860
  119. 1190  RETURN 
  120. 1200  POKE 35,24: POKE 34,0: POKE 32,0: POKE 33,40: RETURN 
  121. 1210  IF  LEFT$(I$(M2),3) = "END"  THEN M1 = 0:M2 = 0: POP : GOTO 290
  122. 1220  RETURN 
  123. 1230  CALL 857: VTAB 8: FOR I = 1 TO 40: PRINT "*";: NEXT : PRINT : PRINT "NO INFORMATION HAS BEEN ENTERED FOR": PRINT "THIS PERSON YET.  YOU MUST CHOOSE THE"
  124. 1240  HTAB 12: INVERSE : PRINT "<ENTER NEW DATA>": NORMAL : PRINT "OPTION FROM THE MAIN MENU": PRINT : FOR I = 1 TO 40: PRINT "*";: NEXT : POKE  -16368,0: VTAB 20: PRINT "PRESS ANY KEY...";: GET X$: GOTO 290
  125. 1250  REM 
  126. 1260  REM  ** HEADER **
  127. 1270  REM 
  128. 1280  INVERSE : HTAB 1: FOR I = 1 TO 37: PRINT "*";: NEXT 
  129. 1290  PRINT 
  130. 1300  HTAB 1: PRINT "*" TAB( 37)"*"
  131. 1310  HTAB 1: PRINT "*"; SPC( 7);"THE  NIBBLE  MEDIC"; SPC( 10);"*":
  132. 1320  FOR I = 1 TO 5
  133. 1330  HTAB 1: PRINT "*" TAB( 37)"*"
  134. 1340  NEXT I
  135. 1350  HTAB 1: FOR I = 1 TO 37: PRINT "*";: NEXT 
  136. 1360  VTAB 5: HTAB 18: PRINT "BY": VTAB 7: HTAB 12: PRINT "MARK R. CRAVEN": VTAB 9
  137. 1370  NORMAL 
  138. 1380  PRINT :H = 13
  139. 1390  PRINT : HTAB H: INVERSE : PRINT "M";: NORMAL : PRINT "EDICAL": HTAB H: INVERSE : PRINT "E";: NORMAL : PRINT "XPENDITURES"
  140. 1400  HTAB H: INVERSE : PRINT "D";: NORMAL : PRINT "ETAILED": HTAB H: INVERSE : PRINT "I";: NORMAL : PRINT "NFORMATION"
  141. 1410  HTAB H: INVERSE : PRINT "C";: NORMAL : PRINT "OMPILATION"
  142. 1420  VTAB 21: PRINT "* COPYRIGHT 1985 BY MICROSPARC INC. *"
  143. 1430  VTAB 23: PRINT "      PRESS ANY KEY TO BEGIN..";: GET X$: POKE  -16368,0: RETURN 
  144. 1440  REM  *************
  145. 1450  REM  *           *
  146. 1460  REM  * ADD  NEW  *
  147. 1470  REM  *           *
  148. 1480  REM  *   DATA    *
  149. 1490  REM  *           *
  150. 1500  REM  *************
  151. 1510  REM 
  152. 1520 S = 8:M1 = 1:N1% = 0:A$ = "END"
  153. 1530  TEXT : CALL 768: HTAB 1: VTAB 24: INVERSE 
  154. 1540  FOR M2 = 1 TO 8: PRINT MU$(M1,M2): PRINT : NEXT : PRINT : PRINT : PRINT :M2 = 1:M1 = 0: GOSUB 690:M1 = 1: NORMAL : GOSUB 720
  155. 1550  GOTO 1570
  156. 1560  FOR I = 5 TO 8  STEP 3: VTAB 2 *I +3: HTAB H%(I) -1: PRINT "$ ": NEXT 
  157. 1570  FOR M2 = 1 TO S
  158. 1580  IF M2 = 2  THEN A$ = "ESC"
  159. 1590  VTAB 24: HTAB 10: PRINT "ENTER '";: INVERSE : PRINT A$;: NORMAL : PRINT "' TO QUIT";: HTAB 1
  160. 1600 A$ = "END": VTAB 2 *M2 +3: HTAB H%(M2)
  161. 1610 I$(M2) = ""
  162. 1620  ON M2 GOSUB 1720,1860,1720,1720,2040,1720,2040,2040
  163. 1630  NEXT M2
  164. 1640  GOTO 2190
  165. 1650  REM 
  166. 1660  REM  ********************
  167. 1670  REM  *                  *
  168. 1680  REM  *  ALPHA  INPUT    *
  169. 1690  REM  *                  *
  170. 1700  REM  ********************
  171. 1710  REM 
  172. 1720  GOSUB 1120: GOSUB 780
  173. 1730  INPUT "";I$(M2): IF I$(M2) = ""  THEN  GOSUB 1200: GOTO 1720
  174. 1740  IF I$(M2) = "END"  THEN M1 = 0:M2 = 0: GOTO 290
  175. 1750  GOSUB 790: IF ER = 1  THEN ER = 0: GOTO 1720
  176. 1760 X$ = I$(M2): GOSUB 730: GOSUB 760: IF ER = 0  THEN  GOSUB 2270: GOTO 1780: REM  CHECK FOR EXISTING NAME
  177. 1770  IF ER = 1  THEN ER = 0:I$(M2) = "": GOSUB 1200: GOTO 1720
  178. 1780  HTAB 1: VTAB 2 *M2 +3: PRINT  LEFT$(I$(M2),L%(M2) +1);: GOSUB 1200: RETURN 
  179. 1790  REM 
  180. 1800  REM  ****************
  181. 1810  REM  *              *
  182. 1820  REM  *  INPUT DATE  *
  183. 1830  REM  *              *
  184. 1840  REM  ****************
  185. 1850  REM 
  186. 1860 X$ = "": GOSUB 1120: GOSUB 780: HTAB 1: PRINT  CHR$(32);:
  187. 1870 J = 1: GET X$(J): GOSUB 1140:X$ = X$(J): PRINT X$;
  188. 1880  FOR J = 1 TO 3: GET X$(J): GOSUB 1140: PRINT X$(J);:X$ = X$ +X$(J): IF J = 1  OR J = 3  THEN  PRINT "/";:X$ = X$ +"/"
  189. 1890  NEXT : PRINT YR$;:
  190. 1900 I$(M2) = X$ +YR$
  191. 1910  IF ED% = 1  THEN  RETURN : REM  EDIT FLAG
  192. 1920 X$ =  LEFT$(X$,2) + MID$ (X$,4,2)
  193. 1930  IF  VAL( LEFT$(X$,2)) >12  OR  VAL( RIGHT$(X$,2)) >31  THEN 1860
  194. 1940  GOSUB 830
  195. 1950  IF ER = 1  THEN ER = 0: GOTO 1860
  196. 1960  VTAB 7: HTAB 2: PRINT I$(M2);
  197. 1970  GOSUB 1200: RETURN 
  198. 1980  REM 
  199. 1990  REM  *****************
  200. 2000  REM  *               *
  201. 2010  REM  * INPUT NUMBERS *
  202. 2020  REM  *               *
  203. 2030  REM  *****************
  204. 2040  GOSUB 1120: GOSUB 780: IF M2 < >7  THEN  GOSUB 880
  205. 2050  INPUT "";I$(M2)
  206. 2060  GOSUB 1210: REM  "END"?
  207. 2070  IF M2 = 7  THEN 2130: REM  #REFILLS
  208. 2080 X$ = I$(M2): IF X$ = ""  THEN X$ = "0"
  209. 2090  GOSUB 940: GOSUB 2170
  210. 2100  GOSUB 850: GOSUB 2170: REM  CHECK FOR DECIMAL
  211. 2110  GOSUB 970:I$(M2) = X$
  212. 2120  HTAB 1: VTAB 2 *M2 +3: PRINT "$ " +I$(M2);: GOSUB 1200: RETURN 
  213. 2130 X$ = I$(M2): IF X$ = ""  THEN  PRINT :I$(M2) = "12": GOTO 2160
  214. 2140  GOSUB 850: GOSUB 2170
  215. 2150  IF  VAL(I$(M2)) >12  THEN : CALL 65338: GOTO 2040
  216. 2160  HTAB 1: VTAB 2 *M2 +3: PRINT " " +I$(M2);: GOSUB 1200: RETURN 
  217. 2170  IF ER = 1  THEN ER = 0: POP : GOSUB 1200: GOTO 2040
  218. 2180  RETURN 
  219. 2190 N1% = N1% +1
  220. 2200 FL$ = I$(1) +"." +YR$
  221. 2210  FOR I = 1 TO 8
  222. 2220 M$(N1%,I) = I$(I): NEXT 
  223. 2230  PRINT 
  224. 2240  GOSUB 6020
  225. 2250  IF NF% = 1  THEN NF% = 0:N% = N% +1:FL$(N%) = FL$:FL$ = "HEADER" +"." +YR$: GOSUB 5860
  226. 2260  GOTO 1530: REM  ENTER DATA MENU
  227. 2270  IF M2 = 1  THEN V = 5: GOTO 2290
  228. 2280  RETURN 
  229. 2290  IF N% = 0  THEN C = 5: POP : GOTO 300: REM  NO FILES--CREATE ONE
  230. 2300  FOR I = 1 TO N%: IF I$(1) =  LEFT$(FL$(I), LEN(FL$(I)) -3)  THEN PD = I:I = N%: NEXT :I = PD: GOTO 2400
  231. 2310  NEXT : IF M2 = 6  THEN 2350
  232. 2320  IF N% = 9  THEN 2620: REM  TOO MANY FILES
  233. 2330 N1% = 0: REM  RESET VALUE IF NEW FILE NAME
  234. 2340  IF M1 = 1  THEN NF% = 1: RETURN : REM  SET NEW FILE FLAG
  235. 2350  VTAB V: HTAB H%(1): CALL  -868: PRINT "** NAME NOT IN FILE **": CALL 65338: CALL 65338: FOR J = 1 TO 1500: NEXT J: VTAB V: HTAB H%(1)
  236. 2360  IF M2 = 7  THEN ER = 1: RETURN 
  237. 2370  IF M1 = 5  THEN ER = 1: RETURN 
  238. 2380  IF M2 = 6  THEN ER = 1: RETURN 
  239. 2390  GOSUB 780: POP :I$(1) = "": GOTO 1720
  240. 2400  IF M2 < >1  THEN  RETURN 
  241. 2410 FL$ = I$(1) +"." +YR$: GOSUB 5930: RETURN : REM  READ FILE AND CONTINUE INPUT
  242. 2420  RETURN 
  243. 2430  REM 
  244. 2440  REM  ***************
  245. 2450  REM  *             *
  246. 2460  REM  * VIEW FILES  *
  247. 2470  REM  *             *
  248. 2480  REM  ***************
  249. 2490  REM 
  250. 2500  TEXT : CALL 857:M2 = 2: GOSUB 690: GOSUB 720
  251. 2510  IF N% = 0  THEN  CALL 65338: CALL 65338: GOTO 2580
  252. 2520  FOR I = 1 TO N%  STEP 2
  253. 2530  VTAB (22 -N%)/2 +I/2
  254. 2540  PRINT  TAB( 5)I;") "; LEFT$(FL$(I), LEN(FL$(I)) -3); TAB( 26);: IF I <N%  THEN  PRINT I +1;") "; LEFT$(FL$(I +1), LEN(FL$(I +1)) -3)
  255. 2550  NEXT I
  256. 2560  IF CS < >2  THEN  RETURN : REM  OTHER ROUTINES
  257. 2570  GOSUB 1060: GOTO 290
  258. 2580  VTAB 8: FOR I = 1 TO 40: PRINT "*";: NEXT : PRINT : PRINT "NO PATIENT FILES HAVE BEEN CREATED.": PRINT "USE THE <";: INVERSE : PRINT "ENTER NEW DATA";: NORMAL : PRINT "> CHOICE FROM"
  259. 2590  PRINT "THE MAIN MENU": PRINT : FOR I = 1 TO 40: PRINT "*";: NEXT : POKE  -16384,0: VTAB 23: PRINT "PRESS ANY KEY...";: GET X$: GOTO 290
  260. 2600  REM  ** >9 PATIENTS **
  261. 2610  REM 
  262. 2620  TEXT : HOME : VTAB 3: PRINT "* ";: FLASH : PRINT "WARNING";: NORMAL : PRINT "--MAXIMUM # OF PATIENT FILES *"
  263. 2630  VTAB 10: HTAB 1: PRINT "YOU MAY NOT HAVE MORE THAN 9 PATIENTS.": PRINT "YOU MUST USE ANOTHER DISK OR DELETE": PRINT "AN EXISTING PATIENT FILE IF YOU WISH TO": PRINT "CREATE A NEW FILE."
  264. 2640  CALL 65338: CALL 65338
  265. 2650  VTAB 23: HTAB 1: PRINT "PRESS ANY KEY TO RETURN TO MENU...";: GET X$: POKE  -16368,0
  266. 2660  POP : GOTO 290: REM  BACK TO MAIN MENU
  267. 2670  REM 
  268. 2680  REM  ******************
  269. 2690  REM  *                *
  270. 2700  REM  *  SEARCH/SORT   *
  271. 2710  REM  *                *
  272. 2720  REM  ******************
  273. 2730  REM 
  274. 2740  CALL 857:S = 4:M1 = 0:M2 = 3:HL% = 4:V% = 1:HT = 5
  275. 2750  GOSUB 690: GOSUB 720:M1 = 3
  276. 2760  IF N% = 0  THEN 2510: REM  NO FILES
  277. 2770  GOTO 370
  278. 2780  REM 
  279. 2790  REM  *****************
  280. 2800  REM  *               *
  281. 2810  REM  * INDIV. REC'S. *
  282. 2820  REM  *               *
  283. 2830  REM  *****************
  284. 2840  REM 
  285. 2850  CALL 768:RX = 0:MD = 0:SUM = 0
  286. 2860 S = N%:HL% = (20 -2 *N%)/2 -1:HT = 15
  287. 2870 M2 = CS: GOSUB 690: GOSUB 720
  288. 2880 M1 = 2
  289. 2890  GOSUB 2900: GOTO 2940
  290. 2900  FOR I = 1 TO N%:MU$(M1,I) =  LEFT$(FL$(I), LEN(FL$(I)) -3): NEXT 
  291. 2910  GOTO 370
  292. 2920 FL$ = FL$(CS): POKE 34,23: GOSUB 5930: POKE 34,0: IF N1% = 0  THEN 1230: REM  READ FILE--CHECK N1%
  293. 2930  RETURN 
  294. 2940  IF RX% = 1  THEN RX% = 0: RETURN 
  295. 2950  RESTORE : GOSUB 200:M1 = 1
  296. 2960  TEXT : CALL 768: HTAB 1: VTAB 24: INVERSE : FOR M2 = 1 TO 8: PRINT MU$(M1,M2): PRINT : NEXT : PRINT : PRINT : PRINT : PRINT : PRINT 
  297. 2970  NORMAL :J = 1
  298. 2980  FOR I = 1 TO 8: VTAB 2 *I +1: HTAB H%(I): PRINT M$(J,I);: NEXT 
  299. 2990 M1 = 3:M2 = 1: GOSUB 690
  300. 3000  VTAB 20: HTAB 1: PRINT "ENTER # OF RECORD TO VIEW (1-";N1%;"), OR"
  301. 3010  VTAB 21: HTAB 2: INVERSE : PRINT "RTN";: NORMAL : PRINT "=SCROLL  P=PRINT  Q=QUIT  E=EDIT"
  302. 3020 CK = 1: GOSUB 3170
  303. 3030  VTAB 24: HTAB 1:X$ =  STR$(RX): GOSUB 940:RX$ = X$: PRINT "RX=$";RX$;" ";"MD=$";:X$ =  STR$(MD): GOSUB 940:MD$ = X$: PRINT MD$;" ";"TOTAL=$";:X$ =  STR$(SUM): GOSUB 940:SUM$ = X$: PRINT SUM$;: CALL  -868
  304. 3040  VTAB 23: HTAB 1: PRINT "RECORD # ";: INVERSE : PRINT J;: NORMAL : PRINT " OF ";N1%; TAB( 30);: PRINT "INPUT =";: GOSUB 1040: INPUT "";X$
  305. 3050  IF N1% = 0  THEN 290: REM  NO RECORDS--BACK TO MENU
  306. 3060  GOSUB 1050: REM  OPEN WINDOW UP
  307. 3070  IF X$ = "Q"  THEN 2740
  308. 3080  IF X$ = ""  THEN J = J +1: GOTO 3140
  309. 3090  IF X$ = "P"  THEN  GOSUB 6500: HTAB 38
  310. 3100  IF X$ = "E"  THEN 4040
  311. 3110  IF  VAL(X$) < = 0  OR  VAL(X$) >N1%  THEN  VTAB 23: HTAB 1: CALL  -868: HTAB 1: GOTO 3040
  312. 3120 X% =  VAL(X$)
  313. 3130 J = X%
  314. 3140  FOR I = 1 TO 8: VTAB 2 *I +1: HTAB H%(I): CALL  -868: VTAB 2 *I +2: HTAB 1: CALL  -868: NEXT 
  315. 3150  IF J < = N1%  THEN  FOR I = 1 TO 8: VTAB 2 *I +1: HTAB H%(I): PRINT M$(J,I);: NEXT 
  316. 3160  IF ED% = 1  THEN  RETURN 
  317. 3170 RX = 0:MD = 0:SUM = 0: FOR I = 1 TO J
  318. 3180 RX = RX + VAL(M$(I,8)):MD = MD + VAL(M$(I,5)):SUM = RX +MD: NEXT : IF CK = 1  THEN CK = 0: RETURN 
  319. 3190  IF J < = N1%  THEN 3030
  320. 3200  IF J >N1%  THEN J = 1: GOTO 3150
  321. 3210  REM 
  322. 3220  REM  *********************
  323. 3230  REM  *                   *
  324. 3240  REM  * SEARCH DATA FIELD *
  325. 3250  REM  *                   *
  326. 3260  REM  *********************
  327. 3270  REM 
  328. 3280  TEXT : CALL 857:S = 8:M1 = 3:HL% = 1:C = 1:V% = 1:M2 = 2: GOSUB 690: GOSUB 720:M1 = 1
  329. 3290 M1 = 6:HT = 10:J1 = 0: REM  J1=COUNTER FOR SEARCH MATCHES
  330. 3300 J = 0: REM  RECORD COUNTER
  331. 3310  FOR I = 1 TO 8:MU$(M1,I) = MU$(1,I): NEXT 
  332. 3320  GOTO 370
  333. 3330 C1% = CS: REM  CHOICE OF FIELD
  334. 3340  CALL 820:M1 = 0:M2 = 3: GOSUB 690: GOSUB 720
  335. 3350  FOR I = 1 TO 40: PRINT "-";: NEXT 
  336. 3360  VTAB 23: HTAB 5: PRINT "<";: INVERSE : PRINT "RETURN";: NORMAL : PRINT "> FOR SEARCH/SORT MENU"
  337. 3370  VTAB 6: HTAB 1: PRINT "SEARCH FIELD = ";: INVERSE : PRINT MU$(1,C1%): NORMAL 
  338. 3380  VTAB 10: HTAB 1: CALL  -868: INPUT "ENTER STRING/VALUE => ";X$
  339. 3390  IF X$ = ""  THEN 2740
  340. 3400  IF (C1% = 5  OR C1% = 7  OR C1% = 8)  AND  VAL(X$) < = 0  THEN  CALL 65338: GOTO 3380
  341. 3410  REM 
  342. 3420  REM  CHOOSE INDIV OR FAMILY ***
  343. 3430  REM 
  344. 3440  CALL 857:M1 = 3:M2 = 2: GOSUB 690: GOSUB 720
  345. 3450  FOR I = 1 TO 2:MU$(8,I) = MU$(9,I): NEXT 
  346. 3460 M1 = 8:S = 2:V% = 4:HT = 10: GOTO 370
  347. 3470 C2% = CS: RESTORE : GOSUB 200
  348. 3480  IF C2% = 1  THEN  CALL 857:M1 = 3:M2 = 2: GOSUB 690: GOSUB 720:M1 = 4:S = N%:HT = 15:V% = 1: GOTO 2900: REM  GET INDIVIDUAL NAME TO MATCH
  349. 3490 C3% = CS: REM  C3%TH OF N% NAME IN FILE
  350. 3500  IF C2% = 1  THEN E = C3%:B = C3%: REM  1 FILE
  351. 3510  IF C2% = 2  THEN E = N%:B = 1: REM  ALL FILES
  352. 3520 M1 = 1
  353. 3530  CALL 857: VTAB 24: HTAB 1: INVERSE : FOR M2 = 1 TO 8: PRINT MU$(M1,M2): PRINT : NEXT : PRINT : PRINT : PRINT : NORMAL :J = 0
  354. 3540 M1 = 0:M2 = 3: GOSUB 690: GOSUB 720:M1 = 1
  355. 3550  VTAB 2 *C1% +3: HTAB 1: FLASH : PRINT MU$(1,C1%): NORMAL 
  356. 3560  VTAB 3: HTAB 3: PRINT "SEARCH STRING=";: INVERSE : PRINT X$: NORMAL 
  357. 3570  FOR X = B TO E: REM  FILE NAMES
  358. 3580  HTAB 1
  359. 3590 FL$ = FL$(X): POKE 35,0: GOSUB 5930: POKE 35,24: IF N1% = 0  THEN  NEXT X: GOTO 3630: REM  READ FILE
  360. 3600 J = 0: FOR Y = 1 TO N1%
  361. 3610  IF  LEFT$(X$, LEN(X$)) =  LEFT$(M$(Y,C1%), LEN(X$))  THEN J = J +1:J1 = J1 +1: GOSUB 3650
  362. 3620  NEXT Y,X
  363. 3630  IF J1 = 0  THEN  CALL 768: VTAB 10: HTAB 12: PRINT "NO MATCHES FOUND": FOR I = 1 TO 1500: NEXT : GOTO 2740
  364. 3640 HL% = 5: GOTO 2740
  365. 3650  VTAB 23: HTAB 1: CALL  -868: PRINT " SEARCH MATCH #";: INVERSE : PRINT J: NORMAL 
  366. 3660  VTAB 24: HTAB 1: PRINT "TOTAL MATCHES=   ";: HTAB 15: INVERSE : PRINT J1;: NORMAL 
  367. 3670  FOR I = 1 TO 8: VTAB 2 *I +3: HTAB H%(I): CALL  -868: PRINT M$(Y,I): NEXT 
  368. 3680  VTAB 22: HTAB 1: PRINT "'P'= PRINT   'Q'= QUIT   <";: INVERSE : PRINT "RTN";: NORMAL : PRINT "> =NEXT"
  369. 3690  VTAB 23: HTAB 25: PRINT "INPUT ";: GET Y$: POKE  -16368,0:
  370. 3700  IF Y$ =  CHR$(13)  THEN  RETURN 
  371. 3710  IF Y$ = "Q"  THEN  POP : GOTO 2740
  372. 3720  IF Y$ = "P"  THEN  VTAB 22: HTAB 1: CALL  -958: GOSUB 6500: GOTO 3680
  373. 3730  GOTO 3690
  374. 3740  GET X$: GOTO 290
  375. 3750  REM 
  376. 3760  REM  *****************
  377. 3770  REM  *               *
  378. 3780  REM  *  LIST  RX'S   *
  379. 3790  REM  *               *
  380. 3800  REM  *****************
  381. 3810  REM 
  382. 3820 RX% = 1: GOSUB 2850: REM  FLAG FOR THIS ROUTINE
  383. 3830  RESTORE : GOSUB 200:M1 = 1
  384. 3840  VTAB 3: HTAB 12: PRINT "PATIENT IS ";: INVERSE : PRINT  LEFT$(FL$(CS), LEN(FL$(CS)) -3): NORMAL 
  385. 3850  VTAB 4: HTAB 1: PRINT "PRESCRIPTION"; TAB( 20)"DR/CLINIC"; TAB( 34)" DATE "
  386. 3860  FOR I = 1 TO 40: PRINT "-";: NEXT 
  387. 3870  POKE 34,5: HOME 
  388. 3880  IF N1% = 0  THEN  PRINT "NO RECORDS IN FILE": FOR I = 1 TO 2000: NEXT : GOTO 290
  389. 3890  FOR I = 1 TO  INT(N1%/15) +1
  390. 3900  IF N1% < = 15  THEN  FOR J = 1 TO N1%: GOTO 3920
  391. 3910  FOR J = (I -1) *15 +1 TO (I -1) *15 +15
  392. 3920  PRINT  LEFT$(M$(J,6),18); TAB( 20) LEFT$(M$(J,3),12); TAB( 35) LEFT$(M$(J,2),5)
  393. 3930  NEXT J
  394. 3940  GOSUB 1060: REM  PRINT OR CONT.
  395. 3950  NEXT I
  396. 3960  GOTO 2740
  397. 3970  REM 
  398. 3980  REM  *****************
  399. 3990  REM  *               *
  400. 4000  REM  *   EDIT MODE   *
  401. 4010  REM  *               *
  402. 4020  REM  *****************
  403. 4030  REM 
  404. 4040  HTAB 1: VTAB 20: CALL  -958: REM  CLEAR BOTTOM OF SCREEN
  405. 4050 J% = J: REM  TEMP VALUE
  406. 4060 ED% = 1: REM  SET EDIT FLAG
  407. 4070 X$ = ""
  408. 4080  VTAB 23: HTAB 1: PRINT "INPUT NEW   ";: INVERSE : PRINT "RTN";: NORMAL : PRINT "=SKIP  '/'=RE-EDIT PAGE"
  409. 4090  GOSUB 3140: REM  SHOW DATA
  410. 4100  FOR K = 2 TO 8
  411. 4110  VTAB 2 *K +1: HTAB H%(K)
  412. 4120  IF K = 2  THEN  GOSUB 1870:I$(K) = I$(M2): GOTO 4140: REM  INPUT DATE AND ERROR CHECK
  413. 4130  INPUT "";I$(K)
  414. 4140  IF I$(K) =  CHR$(13)  THEN  VTAB 2 *K +1: HTAB H%(K): PRINT M$(J%,K):I$(K) = M$(J%,K)
  415. 4150  IF I$(K) = "/"  THEN  FOR I = 2 TO 8: VTAB 2 *I +2: HTAB 1: CALL  -868: VTAB 2 *I +1: HTAB H%(I): CALL  -868: HTAB H%(I): PRINT M$(J%,I);: NEXT :K = 2: VTAB 2 *K +1: HTAB H%(K): GOTO 4110
  416. 4160 X$ = I$(K): ON K GOSUB 4160,4270,4320,4320,4390,4320,4360,4390
  417. 4170  NEXT 
  418. 4180  FOR X = 2 TO 8: IF M$(J%,X) < >I$(X)  THEN X = 8: NEXT : GOTO 4200
  419. 4190  NEXT : GOTO 4230
  420. 4200  FOR X = 2 TO 8
  421. 4210 M$(J%,X) = I$(X): NEXT 
  422. 4220  GOSUB 6020: REM  WRITE FILE
  423. 4230 J = J%:ED% = 0:M1 = 1: GOTO 2960: REM  CLEAR EDIT FLAG--SET MENU STRINGS
  424. 4240  REM 
  425. 4250  REM  ** CHECK DATE **
  426. 4260  REM 
  427. 4270 X$ = I$(K):X$ =  LEFT$(X$,2) + MID$ (X$,4,2)
  428. 4280  GOSUB 810: IF ER = 1  THEN ER = 0:X$ = "": POP : GOTO 4110
  429. 4290  IF  VAL( LEFT$(X$,2)) >12  OR  VAL( RIGHT$(X$,2)) >31  THEN  POP : GOTO 4110
  430. 4300  RETURN 
  431. 4310  GOSUB 4440: RETURN 
  432. 4320  IF X$ = ""  THEN  GOSUB 4440: RETURN 
  433. 4330 M2 = K: GOSUB 1120: GOSUB 730: GOSUB 790: TEXT : REM  ALPHA CHECKING
  434. 4340  IF ER = 1  THEN ER = 0: POP : GOTO 4110
  435. 4350  RETURN 
  436. 4360  IF X$ = ""  THEN  GOSUB 4440: RETURN 
  437. 4370  FOR I = 0 TO 12: IF X$ =  STR$(I)  THEN I = 12: NEXT : RETURN 
  438. 4380  NEXT : POP : GOTO 4110
  439. 4390  IF X$ = ""  THEN  GOSUB 4440: RETURN 
  440. 4400 M2 = K: GOSUB 1120: GOSUB 940: TEXT : IF ER = 1  THEN ER = 0: GOTO 4430: REM  CHECK NUMBER & DECIMAL
  441. 4410  GOSUB 1120: GOSUB 850: TEXT : IF ER = 1  THEN ER = 0: GOTO 4430
  442. 4420 I$(K) = X$: VTAB 2 *K +1: HTAB H%(K): PRINT I$(K): RETURN 
  443. 4430  POP : GOTO 4110: REM  ONLY IF THERE IS AN ERROR
  444. 4440  VTAB 2 *K +1: HTAB H%(K): PRINT M$(J%,K):I$(K) = M$(J%,K): RETURN 
  445. 4450  REM 
  446. 4460  REM  *****************
  447. 4470  REM  *               *
  448. 4480  REM  *  EXPENDITURE  *
  449. 4490  REM  *     TOTALS    *
  450. 4500  REM  *               *
  451. 4510  REM  *****************
  452. 4520  REM 
  453. 4530  TEXT : CALL 857:M1 = 0:S = 4:M2 = 4:V% = 1:M = 0:N = 0:HT = 10:HL% = 2
  454. 4540 J1 = 0: REM  RECORD COUNTER
  455. 4550  GOSUB 690: GOSUB 720:M2 = 0:CS = 1::M1 = 5
  456. 4560  IF N% = 0  THEN 2510
  457. 4570  GOTO 370
  458. 4580  CALL 768:C1% = CS:S = 2:V% = 6:M1 = 0:M2 = 4: GOSUB 690: GOSUB 720
  459. 4590 M1 = 9:M2 = 0
  460. 4600  GOTO 370
  461. 4610  CALL 768:C2% = CS:M1 = 0:M2 = 4: GOSUB 690: GOSUB 720
  462. 4620 S = N%:HL% = (20 -2 *N%)/2 -1:HT = 15:M2 = 4:V% = 1:M1 = 0:: GOSUB 690: GOSUB 720:M1 = 2: GOSUB 2900
  463. 4630  RESTORE : GOSUB 200:M1 = 1
  464. 4640 C3% = CS: REM  PATIENT NAME BY FILE #
  465. 4650  IF ER = 1  THEN ER = 0: HTAB 1: GOTO 4620
  466. 4660  GOTO 4680
  467. 4670 C2% = CS: REM  ALL FILES  CS=2
  468. 4680  IF C2% = 1  THEN E = C3%:B = C3%: REM  1 FILE
  469. 4690  IF C2% = 2  THEN E = N%:B = 1: REM  ALL FILES
  470. 4700 R1 = 5:R2 = 8
  471. 4710  PRINT 
  472. 4720  CALL 857:M1 = 0:M2 = 4: GOSUB 690: VTAB 2: HTAB 1
  473. 4730  PRINT "PATIENT....DATE......OFFICE....PHARMACY"
  474. 4740  PRINT " NAME                 COST       COST": REM  17 SPACES, THEN 7 SPACES
  475. 4750  FOR I = 1 TO 40: PRINT  CHR$(95);: NEXT : PRINT  CHR$(13): VTAB 6: POKE 34,5: FOR X = B TO E
  476. 4760  REM 
  477. 4770  IF C2% = 1  THEN 4810: REM  DON'T READ FILE AGAIN
  478. 4780 FL$ = FL$(X): POKE 34,23:
  479. 4790  GOSUB 5930: POKE 34,5: REM  READ FILE
  480. 4800  IF N1% = 0  THEN 4900
  481. 4810  PRINT  LEFT$( LEFT$(FL$(X), LEN(FL$(X)) -3),10);
  482. 4820  FOR Y = 1 TO N1%
  483. 4830 M =  VAL(M$(Y,R1)) +M:N =  VAL(M$(Y,R2)) +N
  484. 4840  IF C1% = 1  THEN  PRINT  TAB( 12); LEFT$(M$(Y,2),5); TAB( 39 - LEN(M$(Y,R2)));M$(Y,R2)
  485. 4850  IF C1% = 2  THEN  PRINT  TAB( 12); LEFT$(M$(Y,2),5); TAB( 28 - LEN(M$(Y,R1)));M$(Y,R1)
  486. 4860  IF C1% = 3  THEN  PRINT  TAB( 12); LEFT$(M$(Y,2),5); TAB( 28 - LEN(M$(Y,R1)));M$(Y,R1) TAB( 39 - LEN(M$(Y,R2)));M$(Y,R2)
  487. 4870 J1 = J1 +1: REM  COUNT FOR 15 LINES
  488. 4880  IF J1 = 15  THEN J1 = 0: ON C1% GOSUB 4930,4960,4990
  489. 4890  NEXT Y
  490. 4900  NEXT X
  491. 4910  ON C1% GOSUB 4930,4960,4990
  492. 4920  GOTO 4530
  493. 4930  HTAB 33: PRINT "------"
  494. 4940 X$ =  STR$(N): GOSUB 940: PRINT  TAB( 38 - LEN(X$));"$";X$
  495. 4950  GOSUB 5020: RETURN 
  496. 4960  HTAB 22: PRINT "------"
  497. 4970 X$ =  STR$(M): GOSUB 940: PRINT  TAB( 27 - LEN(X$));"$";X$
  498. 4980  GOSUB 5020: RETURN 
  499. 4990  HTAB 22: PRINT "------"; TAB( 32)"-------"
  500. 5000 X$ =  STR$(M): GOSUB 940: PRINT  TAB( 27 - LEN(X$));"$";X$;:X$ =  STR$(N): GOSUB 940: PRINT  TAB( 38 - LEN(X$));"$";X$
  501. 5010  GOSUB 5020: RETURN 
  502. 5020  GOSUB 1060: HTAB 1: VTAB 6: CALL  -958: VTAB 5: PRINT  CHR$(13);: RETURN 
  503. 5030  GOTO 4530
  504. 5040  REM 
  505. 5050  REM  *******************
  506. 5060  REM  *                 *
  507. 5070  REM  * CREATE NEW FILE *
  508. 5080  REM  *                 *
  509. 5090  REM  *******************
  510. 5100  REM 
  511. 5110  IF N% =  >9  THEN  GOSUB 2620: REM  TOO MANY FILES
  512. 5120  TEXT : CALL 857:M2 = CS: GOSUB 690: GOSUB 720
  513. 5130  VTAB 23: HTAB 1: PRINT "ENTER NAME OF PERSON....";: INVERSE : PRINT " RETURN ";: NORMAL : PRINT " TO QUIT";
  514. 5140  VTAB 24: PRINT " ENTER '";: INVERSE : PRINT "FILES";: NORMAL : PRINT "' FOR CURRENT FILE NAMES";
  515. 5150  POKE 35,20: POKE 34,2
  516. 5160  VTAB 10: HTAB 1:ER = 0: PRINT "ENTER NAME OF NEW FILE => ";: CALL  -868: INPUT "";FL$
  517. 5170  IF  LEFT$(FL$,5) = "FILES"  THEN  GOSUB 5330: GOTO 5160
  518. 5180  IF FL$ = ""  THEN 5310
  519. 5190  FOR I = 1 TO  LEN(FL$): IF ( ASC( MID$ (FL$,I,1)) <65  AND  ASC( MID$ (FL$,I,1)) < >46)  OR  ASC( MID$ (FL$,I,1)) >90  THEN  HTAB 1: VTAB 20: CALL  -868: PRINT "CAPITAL LETTERS ONLY!";: GOSUB 1030:ER = 1: HTAB 1: CALL  -868:I =  LEN(FL$): NEXT : GOTO 5160
  520. 5200  NEXT I
  521. 5210 X$ = FL$:M2 = 1: GOSUB 760: IF ER = 1  THEN 5160
  522. 5220 FL$ = FL$ +"." +YR$
  523. 5230  IF N% <1  THEN 5270
  524. 5240  FOR I = 1 TO N%
  525. 5250  IF FL$(I) = FL$  THEN  CALL 65338: GOSUB 700: VTAB 10: HTAB 6: PRINT "DUPLICATE FILE NAME--RE-ENTER": GOSUB 1030: GOSUB 710:I = N%: NEXT : GOTO 5160
  526. 5260  NEXT I
  527. 5270 N% = N% +1
  528. 5280 FL$(N%) = FL$
  529. 5290 N1% = 0: GOSUB 6020: IF N% = 9  THEN 5310: REM  IF 9 FILES, SAVE HEADER
  530. 5300  GOSUB 700: GOTO 5110
  531. 5310 FL$ = "HEADER" +"." +YR$: GOSUB 5860
  532. 5320  GOTO 290
  533. 5330  IF N% = 0  THEN  RETURN 
  534. 5340  POKE 35,22: VTAB 14: HTAB 1
  535. 5350  FOR J = 1 TO N%  STEP 3
  536. 5360  PRINT  LEFT$(FL$(J), LEN(FL$(J)) -3);
  537. 5370  IF J +1 < = N%  THEN  PRINT  TAB( 14) LEFT$(FL$(J +1), LEN(FL$(J +1)) -3);
  538. 5380  IF J +2 < = N%  THEN  PRINT  TAB( 26) LEFT$(FL$(J +2), LEN(FL$(J +2)) -3)
  539. 5390  NEXT : POKE 35,13: RETURN 
  540. 5400  REM 
  541. 5410  REM  ****************
  542. 5420  REM  *              *
  543. 5430  REM  * DELETE FILE  *
  544. 5440  REM  *              *
  545. 5450  REM  ****************
  546. 5460  REM 
  547. 5470  TEXT : CALL 857:M2 = 6: GOSUB 690: GOSUB 720
  548. 5480  IF N% = 0  THEN 2510: REM  NO FILES
  549. 5490  GOSUB 2520
  550. 5500 V% =  PEEK(37)
  551. 5510  HTAB 1: VTAB 23: PRINT "ENTER FILE NAME TO DELETE--<";: INVERSE : PRINT "RTN";: NORMAL : PRINT "> TO QUIT";: VTAB V% +3
  552. 5520  HTAB 1: PRINT "  FILE NAME ==> ";: CALL  -868: INPUT "";I$
  553. 5530  IF I$ = ""  THEN M1 = 0:M2 = 0: GOTO 290
  554. 5540 V = V% +3:I$(1) = I$: GOSUB 2290
  555. 5550  IF ER = 1  THEN ER = 0: GOTO 5520
  556. 5560  CALL 857: GOSUB 690: GOSUB 720
  557. 5570  VTAB 10: HTAB 1: PRINT "ARE YOU SURE YOU WISH TO DELETE FILE ": PRINT : HTAB 19 - LEN(I$)/2: INVERSE : PRINT I$;: NORMAL : PRINT " ?": PRINT : HTAB 16: PRINT "(Y/N)"
  558. 5580  GET X$: POKE  -16368,0: IF X$ = "Y"  THEN 5600
  559. 5590  GOTO 5470
  560. 5600 FL$ = I$ +"." +YR$: PRINT 
  561. 5610  GOSUB 6100: REM  DELETE FILE
  562. 5620  IF I = N%  THEN 5660
  563. 5630  FOR J = I TO N%
  564. 5640 FL$(J) = FL$(J +1)
  565. 5650  NEXT J
  566. 5660 N% = N% -1
  567. 5670 FL$ = "HEADER" +"." +YR$: GOSUB 5860
  568. 5680 M1 = 0:M2 = 0: GOTO 290
  569. 5690  TEXT : GOSUB 710: VTAB 10: HTAB 18: PRINT "END": END 
  570. 5700  REM 
  571. 5710  REM  ****************
  572. 5720  REM  *              *
  573. 5730  REM  *     DISK     *
  574. 5740  REM  *   ROUTINES   *
  575. 5750  REM  *              *
  576. 5760  REM  ****************
  577. 5770  REM 
  578. 5780  ONERR  GOTO 6310
  579. 5790  PRINT D$;"BLOAD SCROLLOFF": ONERR  GOTO 6260
  580. 5800  PRINT D$;"OPEN ";FL$
  581. 5810  PRINT D$;"READ ";FL$: INPUT N%
  582. 5820  IF N% <1  THEN 5840
  583. 5830  FOR I = 1 TO N%: INPUT FL$(I): NEXT 
  584. 5840  PRINT D$;"CLOSE ";FL$
  585. 5850  RETURN 
  586. 5860  PRINT D$;"OPEN ";FL$
  587. 5870  PRINT D$;"WRITE ";FL$
  588. 5880  PRINT N%
  589. 5890  FOR I = 1 TO N%
  590. 5900  PRINT FL$(I): NEXT 
  591. 5910  PRINT D$;"CLOSE ";FL$
  592. 5920  RETURN 
  593. 5930  PRINT D$;"OPEN ";FL$
  594. 5940  HTAB 1: CALL  -868
  595. 5950  PRINT D$;"READ ";FL$
  596. 5960  INPUT N1%
  597. 5970  IF N1% = 0  THEN 6010
  598. 5980  FOR I = 1 TO N1%
  599. 5990  FOR J = 1 TO 8
  600. 6000  INPUT M$(I,J): NEXT : NEXT 
  601. 6010  PRINT D$;"CLOSE": RETURN 
  602. 6020  PRINT D$;"OPEN ";FL$
  603. 6030  PRINT D$;"WRITE ";FL$
  604. 6040  PRINT N1%
  605. 6050  FOR I = 1 TO N1%
  606. 6060  FOR J = 1 TO 8
  607. 6070  PRINT M$(I,J): NEXT : NEXT 
  608. 6080  PRINT D$;"CLOSE ";FL$
  609. 6090  RETURN 
  610. 6100  PRINT D$;"OPEN ";FL$
  611. 6110  PRINT D$;"CLOSE ";FL$
  612. 6120  PRINT D$;"DELETE ";FL$
  613. 6130  RETURN 
  614. 6140  CALL 913
  615. 6150 M2 = CS: INVERSE : GOSUB 690: GOSUB 720: POKE 34,4: RESTORE : GOSUB 130
  616. 6160  TEXT : CALL 768: GOTO 290
  617. 6170  REM  MAIN MENU MU$(0,M2)
  618. 6180  DATA  " MAIN MENU-NIBBLE MEDIC ","ENTER NEW DATA","VIEW CURRENT PATIENT NAMES","SEARCH/SORT/EDIT RECORDS","EXPENDITURE TOTALS","CREATE NEW PATIENT FILE","DELETE EXISTING PATIENT FILE","CHANGE YEARS","EXIT PROGRAM"
  619. 6190  DATA  "NAME OF PATIENT-","DATE OF TREATMENT (MM/DD)-","DR./CLINIC-","DIAGNOSIS-","COST OF TREATMENT-","PRESCRIPTION-","# OF REFILLS ALLOWED-","COST OF PRESCRIPTION-"
  620. 6200  DATA  "EXAMINE/EDIT INDIVIDUAL RECORDS","SEARCH BY DATA FIELD","LIST PATIENT PRESCRIPTIONS","RETURN TO MAIN MENU"
  621. 6210  DATA  "COST OF PRESCRIPTIONS","OUT-PATIENT COSTS","TOTALS FOR BOTH OF THE ABOVE","RETURN TO MAIN MENU"
  622. 6220  DATA  "FOR A SINGLE PATIENT","FOR EVERY PATIENT"
  623. 6230  DATA  17,28,13,11,19,14,22,22
  624. 6240  DATA     11,5,25,27,7,24,1,6
  625. 6250  DATA  "MAIN MENU--MEDICAL RECORDS"," ADD A RECORD "," EDIT A RECORD"
  626. 6260  CALL  -3288: IF  PEEK(222) = 5  AND  LEFT$(FL$,6) = "HEADER"  THEN 6280
  627. 6270  GOTO 6310
  628. 6280  PRINT D$;"WRITE";FL$: PRINT 0: REM  N%
  629. 6290  PRINT D$;"CLOSE";FL$
  630. 6300  GOTO 160: REM  RE-READ FILE
  631. 6310  CALL  -3288: TEXT : HOME : CALL 65338: CALL 65338: VTAB 8: FOR I = 1 TO 40: PRINT "*";: NEXT : PRINT 
  632. 6320 ER$ = ""
  633. 6330  IF  PEEK(222) = 9  THEN ER$ = " DISK FULL ERROR ": GOTO 6410
  634. 6340  IF  PEEK(222) = 8  THEN ER$ = " INPUT/OUTPUT ERROR-CHECK DRIVE DOOR ": GOTO 6410
  635. 6350  IF  PEEK(222) = 6  THEN ER$ = " BINARY FILE NOT ON DISK ": GOTO 6420
  636. 6360  IF  PEEK(222) = 4  THEN ER$ = " DISK WRITE-PROTECTED ": GOTO 6410
  637. 6370  IF  PEEK(222) = 11  THEN ER$ = " SYNTAX ERROR ": GOTO 6390
  638. 6380 ER$ = "CHECK YOUR MANUAL FOR ERROR CODE": GOTO 6410
  639. 6390  HTAB (40 - LEN(ER$))/2: PRINT ER$: PRINT : PRINT "IN LINE "; PEEK(218) + PEEK(219) *256
  640. 6400  GOTO 6450
  641. 6410  HTAB (40 - LEN(ER$))/2: PRINT ER$: PRINT "ERROR # "; PEEK(222);" IN LINE "; PEEK(218) + PEEK(219) *256: GOTO 6430
  642. 6420  HTAB (40 - LEN(ER$))/2: PRINT ER$: PRINT : VTAB 22: PRINT "FATAL ERROR--CANNOT CONTINUE": END 
  643. 6430  PRINT "PLEASE CORRECT THE CONDITION DESCRIBED": GOTO 6450
  644. 6440  PRINT "ERROR # "; PEEK(222);" IN LINE "; PEEK(218) + PEEK(219) *256
  645. 6450  PRINT : FOR I = 1 TO 40: PRINT "*";: NEXT 
  646. 6460  PRINT : PRINT "PRESS ANY KEY TO CONTINUE";: GET X$: POKE  -16368,0: TEXT : HOME 
  647. 6470  IF M1 = 0  THEN  TEXT : HOME : GOTO 290
  648. 6480 CS =  PEEK(972): GOTO 510: REM  BACK TO LAST CHOICE FROM MENU
  649. 6490  REM  SCREEN DUMP
  650. 6500  GOTO 6520
  651. 6510  FOR F = P TO P +39:A =  PEEK(F):A = A +(A <32) *192:A = A +(A <64) *128:A = A +(A <96) *64:A = A +(A <128) *64:A = A +(A <160) *64: PRINT  CHR$(A);: NEXT F: PRINT : RETURN 
  652. 6520  PRINT : PRINT  CHR$(4)"PR#1": PRINT  CHR$(9)"80N"
  653. 6530  FOR P = 1024 TO 1920  STEP 128: GOSUB 6510: NEXT P
  654. 6540  FOR P = 1064 TO 1960  STEP 128: GOSUB 6510: NEXT P
  655. 6550  FOR P = 1104 TO 2000  STEP 128: GOSUB 6510: NEXT P
  656. 6560  PRINT  CHR$(4)"PR#0": RETURN