home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload / ShartewareOverload.cdr / database / dbclinic.zip / DBCLINIC.BAS next >
BASIC Source File  |  1987-02-14  |  20KB  |  641 lines
  1. 1000 'DBCLINIC.BAS IS A UTILITY PROGRAM FOR UPDATING THE FILE HEADER IN .DBF
  2. 1010 'FILES CREATED UNDER DBASEII.  IT ALSO WILL GET A CORRECT RECORD COUNT
  3. 1020 'FOR .DBF OR .TXT FILES AND EVEN A RECORD LENGTH FOR .TXT FILES.  THIS
  4. 1030 'VERSION IS SET UP FOR A 80-COLUMN BY 24-LINE SCREEN AND TO RECOGNIZE 
  5. 1040 'DRIVES A: THRU D: ONLY (SEE LINE 1230.).
  6. 1050 '
  7. 1060 '====================== STANDARD 'TRANSFORM' EQUATES =========================
  8. 1070 '
  9. 1080 DEFINT A-Z: WIDTH 79: WIDTH LPRINT 131
  10. 1090 ZERO=0: ONE=1: TWO=2: THREE=3: FOUR=4: FIVE=5: SIX=6: SEVEN=7: EIGHT=8: NINE=9
  11. 1100 AFFIRM=ONE: NEGATIVE=TWO: DEFAULT=THREE: FALSE=ZERO: TRUE=NOT(FALSE)
  12. 1110 OFFSET=32: FILEERR=53
  13. 1120 BACKSPACE$=CHR$(EIGHT): BELL$=CHR$(SEVEN): CARRIAGERETURN$=CHR$(13)
  14. 1130 COLON$=":": COMMA$=",": DELETEKEY$=CHR$(127): ESCAPEKEY$=CHR$(27)
  15. 1140 LINEFEED$=CHR$(10): NLLSTR$="": ONESPACE$=" ": PERIOD$=".": QUOTE$=CHR$(34)
  16. 1150 SEMICOLON$=";": SPACEBAR$=CHR$(32): TABKEY$=CHR$(NINE)
  17. 1160 DEF FNPR(N)=N>31 AND N<127    'TESTS FOR ALL PRINTABLE ASCII CHARACTERS
  18. 1170 DEF FNAL(N)=N>96 AND N<123    'TESTS FOR LOWER-CASE ASCII CHARACTERS ONLY
  19. 1180 DEF FNAU(N)=N>64 AND N<91    'TESTS FOR UPPER-CASE ASCII CHARACTERS ONLY
  20. 1190 DEF FNNU(N)=N>47 AND N<58    'TESTS FOR NUMERIC ASCII CHARACTERS ONLY
  21. 1200 '
  22. 1210 '
  23. 1220 DIM PART$(TWO),FLD$(32)
  24. 1230 DEF FNDV(N)=N>64 AND N<69    'ASCII CODE RANGE OF ACCEPTABLE DRIVES (A-D)
  25. 1240 CLEARSCREEN$=CHR$(26)          'THIS MAY BE DIFFERENT FOR YOUR TERMINAL
  26. 1250 DBFHEADER=520                'NUMBER OF CHARACTERS (BYTES) IN .DBF HEADER
  27. 1260 PASTENDERR=62: NOFILE=FALSE
  28. 1270 DATEFORM$="mm/dd/yy"
  29. 1280 '
  30. 1290 ON ERROR GOTO 6580
  31. 1300 FOR SCROLL=ONE TO 40: PRINT: NEXT SCROLL
  32. 1310 ' REPEAT    [MAINLINE PROGRAM STARTS HERE]
  33. 1320 ' REPEAT
  34. 1330 PRINT "                        * * * * * * * * * * * * * * *"
  35. 1340 PRINT "                        *    DICK'S DBASE CLINIC    *"
  36. 1350 PRINT "                        *  Version 2.0     9/11/84  *"
  37. 1360 PRINT "                        * * * * * * * * * * * * * * *"
  38. 1370 PRINT: PRINT: PRINT
  39. 1380 PRINT "       Copyright 1984 by Dick Bollinger.  Permission granted for private"
  40. 1390 PRINT "       use only.  Not to be sold in any form for commercial profit."
  41. 1400 PRINT: PRINT: PRINT
  42. 1410 PRINT "                  THIS PROGRAM ACCEPTS ONLY STANDARD DATABASE"
  43. 1420 PRINT "                  (DBF) AND SDF (TXT) FILENAMES CREATED UNDER"
  44. 1430 PRINT "                  ASHTON-TATE'S DBASEII (TM).  ALWAYS ENTER A"
  45. 1440 PRINT "                    COMPLETE FILENAME: (E.G., A:MYFILE.DBF)"
  46. 1450 PRINT: PRINT
  47. 1460 PRINT "            < < AFTER A DISK CHANGE, PRESS RETURN KEY FOR RESET > >"
  48. 1470 PRINT: PRINT
  49. 1480 PRINT "     ENTER FILENAME (DIR=DIRECTORY): ";
  50. 1490 ' REPEAT
  51. 1500 GOSUB 6800
  52. 1510 IF NOT (LEN(DUMMY$)>ONE) THEN 1540
  53. 1520 DRV$=LEFT$(DUMMY$,TWO)
  54. 1530 DRV=ASC(LEFT$(DRV$,ONE))
  55. 1540 ' ENDIF
  56. 1550 IF NOT (DUMMY$=NLLSTR$) THEN 1590
  57. 1560 FILEOK=FALSE
  58. 1570 RESET
  59. 1580 GOTO 1830
  60. 1590 IF NOT (LEFT$(DUMMY$,TWO)="DI") THEN 1640
  61. 1600 FILEOK=FALSE
  62. 1610 GOSUB 5840
  63. 1620 PRINT: PRINT: GOTO 1460
  64. 1630 GOTO 1830
  65. 1640 IF NOT (FNDV(DRV)=FALSE OR MID$(DRV$,TWO,TWO)<>COLON$) THEN 1720
  66. 1650 FILEOK=FALSE
  67. 1660 NASTY$=" Specify Disk Drive! "
  68. 1670 PRINT NASTY$;BELL$;
  69. 1680 ENTRYLEN=LEN(DUMMY$)
  70. 1690 GOSUB 5740
  71. 1700 GOSUB 5790
  72. 1710 GOTO 1830
  73. 1720 IF NOT (RIGHT$(DUMMY$,FOUR)<>".DBF" AND RIGHT$(DUMMY$,FOUR)<>".TXT") THEN 1800
  74. 1730 FILEOK=FALSE
  75. 1740 NASTY$=" Invalid File Type! "
  76. 1750 PRINT NASTY$;BELL$;
  77. 1760 ENTRYLEN=LEN(DUMMY$)
  78. 1770 GOSUB 5740
  79. 1780 GOSUB 5790
  80. 1790 GOTO 1820
  81. 1800 ' ELSE
  82. 1810 FILEOK=TRUE
  83. 1820 ' ENDIF
  84. 1830 ' ENDIF
  85. 1840 IF NOT (FILEOK=TRUE) THEN 1490
  86. 1850 FILETRY$=DUMMY$
  87. 1860 EXT$=RIGHT$(FILETRY$,THREE)
  88. 1870 FILEFOUND=FALSE: NOFILE=FALSE
  89. 1880 OPEN "I",# ONE,FILETRY$
  90. 1890 IF NOT (NOFILE<>TRUE) THEN 1920
  91. 1900 FILEFOUND=TRUE
  92. 1910 GOTO 1970
  93. 1920 ' ELSE
  94. 1930 PRINT: PRINT: PRINT
  95. 1940 PRINT "        * * * ERROR: Data File Entered Was Not Found! - Check Spelling!"
  96. 1950 PRINT BELL$: PRINT: PRINT: PRINT: PRINT
  97. 1960 GOSUB 5740
  98. 1970 ' ENDIF
  99. 1980 CLOSE # ONE
  100. 1990 PRINT CLEARSCREEN$: PRINT
  101. 2000 IF NOT (FILEFOUND=TRUE) THEN 1320
  102. 2010 ' REPEAT
  103. 2020 CLOSE: MODE=ZERO
  104. 2030 PRINT CLEARSCREEN$;"     ";FILETRY$
  105. 2040 PRINT: PRINT: PRINT
  106. 2050 PRINT "                     <  <  <   M A I N   M E N U   >  >  >"
  107. 2060 PRINT: PRINT
  108. 2070 PRINT "          WARD [A]  -  DISPLAY FILE RECORD LENGTH   (DBF OR TXT FILE)"
  109. 2080 PRINT
  110. 2090 PRINT "          WARD [B]  -  DISPLAY FULL FILE STRUCTURE    (DBF FILE ONLY)"
  111. 2100 PRINT
  112. 2110 PRINT "          WARD [C]  -  COUNT # OF RECORDS IN FILE   (DBF OR TXT FILE)"
  113. 2120 PRINT
  114. 2130 PRINT "          WARD [D]  -  DISPLAY/CHANGE RECORD COUNT    (DBF FILE ONLY)"
  115. 2140 PRINT
  116. 2150 PRINT "          WARD [E]  -  DISPLAY/CHANGE ENTRY DATE      (DBF FILE ONLY)"
  117. 2160 PRINT: PRINT
  118. 2170 PRINT "             [F] = SELECT ANOTHER FILENAME      [X] = EXIT TO CP/M"
  119. 2180 PRINT: PRINT
  120. 2190 PRINT "     YOUR CHOICE (A-F,X):  [ ]"; BACKSPACE$; BACKSPACE$;
  121. 2200 VALID=FALSE
  122. 2210 ' REPEAT
  123. 2220 DUMMY$=INKEY$
  124. 2230 IF NOT (LEN(DUMMY$)=ONE) THEN 2600
  125. 2240 IF NOT (FNPR(ASC(DUMMY$))=TRUE) THEN 2590
  126. 2250 J=ASC(DUMMY$)
  127. 2260 IF NOT (FNAL(ASC(DUMMY$))=TRUE) THEN 2280
  128. 2270 DUMMY$=CHR$(J-OFFSET)
  129. 2280 ' ENDIF
  130. 2290 IF NOT (DUMMY$="F") THEN 2330
  131. 2300 NEWFILE=TRUE: VALID=TRUE
  132. 2310 MODE=ZERO: PRINT "F] ";
  133. 2320 GOTO 2580
  134. 2330 IF NOT (DUMMY$="X") THEN 2370
  135. 2340 EXIT=TRUE: VALID=TRUE
  136. 2350 MODE=ZERO: PRINT "X] ";
  137. 2360 GOTO 2570
  138. 2370 ' ELSE
  139. 2380 NEWFILE=FALSE: EXIT=FALSE
  140. 2390 MODE=ASC(DUMMY$)-64
  141. 2400 IF NOT (MODE>FIVE OR MODE<ONE) THEN 2430
  142. 2410 PRINT BELL$;: VALID=FALSE
  143. 2420 GOTO 2560
  144. 2430 IF NOT (EXT$="TXT" AND NOT(MODE=ONE OR MODE=THREE)) THEN 2520
  145. 2440 NASTY$=" Sorry!  'TXT' Files NOT ALLOWED In This WARD! "
  146. 2450 PRINT NASTY$;BELL$;
  147. 2460 ENTRYLEN=ZERO
  148. 2470 GOSUB 5740
  149. 2480 GOSUB 5790
  150. 2490 PRINT " ]";BACKSPACE$;BACKSPACE$;
  151. 2500 VALID=FALSE
  152. 2510 GOTO 2550
  153. 2520 ' ELSE
  154. 2530 VALID=TRUE
  155. 2540 PRINT DUMMY$;"] ";
  156. 2550 ' ENDIF
  157. 2560 ' ENDIF
  158. 2570 ' ENDIF
  159. 2580 ' ENDIF
  160. 2590 ' ENDIF
  161. 2600 ' ENDIF
  162. 2610 IF NOT (VALID=TRUE) THEN 2210
  163. 2620 IF NOT (MODE>ZERO AND MODE<SIX) THEN 5260
  164. 2630 IF NOT (EXT$="DBF") THEN 2730
  165. 2640 OPEN "R",# ONE,FILETRY$,EIGHT
  166. 2650 FIELD # ONE, SIX AS SPACER$, TWO AS RECLEN$
  167. 2660 GET # ONE,ONE
  168. 2670 CLOSE # ONE
  169. 2680 RECLEN=CVI(RECLEN$)
  170. 2690 IF NOT (RECLEN = -ONE) THEN 2710
  171. 2700 RECLEN=ZERO
  172. 2710 ' ENDIF
  173. 2720 GOTO 2880
  174. 2730 ' ELSE
  175. 2740 DUMY1$=NLLSTR$: DUMY2$=DUMY1$: DUMY3$=DUMY2$: DUMY4$=DUMY3$
  176. 2750 OPEN "I",# ONE,FILETRY$
  177. 2760 LINE INPUT # ONE, DUMY1$
  178. 2770 IF NOT (LEN(DUMY1$)=255) THEN 2850
  179. 2780 LINE INPUT # ONE, DUMY2$
  180. 2790 IF NOT (LEN(DUMY2$)=255) THEN 2840
  181. 2800 LINE INPUT # ONE, DUMY3$
  182. 2810 IF NOT (LEN(DUMY3$)=255) THEN 2830
  183. 2820 LINE INPUT # ONE, DUMY4$
  184. 2830 ' ENDIF
  185. 2840 ' ENDIF
  186. 2850 ' ENDIF
  187. 2860 RECLEN=LEN(DUMY1$)+LEN(DUMY2$)+LEN(DUMY3$)+LEN(DUMY4$)
  188. 2870 CLOSE # ONE
  189. 2880 ' ENDIF
  190. 2890 ON MODE GOTO 2900, 3060, 3840, 4480, 4890
  191. 2900 ' WARD-A
  192. 2910 PRINT CLEARSCREEN$
  193. 2920 PRINT: PRINT: PRINT: PRINT: PRINT: PRINT: PRINT: PRINT: PRINT
  194. 2930 PRINT "             RECORD LENGTH OF  ";FILETRY$;"  IS ";RECLEN;" CHARACTERS"
  195. 2940 PRINT
  196. 2950 IF NOT (EXT$="DBF" AND RECLEN<> ZERO) THEN 2980
  197. 2960 PRINT "             (This Total INCLUDES a Single SPACE Record Delimiter)"
  198. 2970 GOTO 3040
  199. 2980 IF NOT (EXT$="TXT" AND RECLEN<>ZERO) THEN 3010
  200. 2990 PRINT "             (This Total DOES NOT Include CR/LF Record Delimiter)"
  201. 3000 GOTO 3030
  202. 3010 ' ELSE
  203. 3020 PRINT
  204. 3030 ' ENDIF
  205. 3040 ' ENDIF
  206. 3050 GOTO 5190
  207. 3060 ' WARD-B
  208. 3070 GOSUB 5320
  209. 3080 CLOSE # ONE
  210. 3090 OPEN "R",# ONE,FILETRY$,THREE
  211. 3100 FIELD # ONE, ONE AS SPACER$, TWO AS FILSIZE$
  212. 3110 GET # ONE,ONE
  213. 3120 FILSIZE=CVI(FILSIZE$)
  214. 3130 CLOSE # ONE
  215. 3140 OPEN "R",# ONE,FILETRY$,EIGHT
  216. 3150 FIELD #ONE,EIGHT AS HDR$
  217. 3160 HDR=ONE
  218. 3170 FOR FLDNO=ONE TO 32
  219. 3180 FOR PARTNO=ONE TO TWO
  220. 3190 HDR=HDR+ONE
  221. 3200 GET #ONE,HDR
  222. 3210 PART$(PARTNO)=HDR$
  223. 3220 NEXT PARTNO
  224. 3230 FLD$(FLDNO)=PART$(ONE)+PART$(TWO)
  225. 3240 NEXT FLDNO
  226. 3250 CLOSE # ONE
  227. 3260 PRINT CLEARSCREEN$
  228. 3270 PRINT TAB(22);"STRUCTURE FOR FILE:  ";FILETRY$
  229. 3280 ARGU=FILSIZE: FMT=FIVE
  230. 3290 GOSUB 6350
  231. 3300 FILSIZE$=ARGU$
  232. 3310 PRINT TAB(22);"NUMBER OF RECORDS:   ";FILSIZE$
  233. 3320 PRINT TAB(22);"DATE OF LAST UPDATE: ";DATE$
  234. 3330 PRINT TAB(22);"PRIMARY USE DATABASE"
  235. 3340 PRINT TAB(22);"FLD       NAME      TYPE WIDTH   DEC"
  236. 3350 FLD=ONE: NOMORE=FALSE
  237. 3360 ' REPEAT
  238. 3370 IF NOT (LEFT$(FLD$(FLD),ONE)<>CHR$(13)) THEN 3690
  239. 3380 IF NOT (FLD=32) THEN 3400
  240. 3390 NOMORE=TRUE
  241. 3400 ' ENDIF
  242. 3410 ARGU=FLD: FMT=THREE
  243. 3420 GOSUB 6350
  244. 3430 FLD1$=ARGU$
  245. 3440 NAM$=LEFT$(FLD$(FLD),10)
  246. 3450 TYP$=MID$(FLD$(FLD),12,ONE)
  247. 3460 WID=ASC(MID$(FLD$(FLD),13,ONE))
  248. 3470 ARGU=WID: FMT=THREE
  249. 3480 GOSUB 6350
  250. 3490 WID$=ARGU$
  251. 3500 DEC=ASC(RIGHT$(FLD$(FLD),ONE))
  252. 3510 IF NOT (DEC>ZERO) THEN 3560
  253. 3520 ARGU=DEC: FMT=THREE
  254. 3530 GOSUB 6350
  255. 3540 DEC$=ARGU$
  256. 3550 GOTO 3580
  257. 3560 ' ELSE
  258. 3570 DEC$=NLLSTR$
  259. 3580 ' ENDIF
  260. 3590 PRINT TAB(22);FLD1$; TAB(30);NAM$; TAB(43);TYP$; TAB(48);WID$; TAB(55);DEC$
  261. 3600 FLD=FLD+ONE
  262. 3610 IF NOT (FLD=13 OR FLD=31) THEN 3670
  263. 3620 PRINT TAB(22);"[more...]";BELL$;
  264. 3630 ' REPEAT
  265. 3640 DMY$=INKEY$
  266. 3650 IF NOT (LEN(DMY$)=ONE) THEN 3630
  267. 3660 PRINT CARRIAGERETURN$;
  268. 3670 ' ENDIF
  269. 3680 GOTO 3710
  270. 3690 ' ELSE
  271. 3700 NOMORE=TRUE
  272. 3710 ' ENDIF
  273. 3720 IF NOT (NOMORE=TRUE) THEN 3360
  274. 3730 IF NOT (FLD>ONE) THEN 3790
  275. 3740 ARGU=RECLEN: FMT=FIVE
  276. 3750 GOSUB 6350
  277. 3760 RECLEN$=ARGU$
  278. 3770 PRINT TAB(22);"** TOTAL **             ";RECLEN$
  279. 3780 GOTO 3820
  280. 3790 ' ELSE
  281. 3800 PRINT
  282. 3810 PRINT "           * * ERROR: File Structure of  ";FILETRY$;"  Is Vacant!!"
  283. 3820 ' ENDIF
  284. 3830 GOTO 5190
  285. 3840 ' WARD-C
  286. 3850 ANSWER=ZERO: DISPLCNT=ZERO
  287. 3860 IF NOT (RECLEN>ZERO) THEN 4320
  288. 3870 IF NOT (EXT$="TXT") THEN 3890
  289. 3880 RECLEN=RECLEN+TWO
  290. 3890 ' ENDIF
  291. 3900 FACTOR#=128/RECLEN
  292. 3910 OPEN "R",# ONE,FILETRY$,128
  293. 3920 FIELD # ONE, 128 AS DUMMY1$
  294. 3930 FILE=ONE
  295. 3940 GOSUB 7060
  296. 3950 IF NOT (ANSWER<32767) THEN 4300
  297. 3960 IF NOT (NORECORDS=FALSE) THEN 4270
  298. 3970 PULLBACK=16
  299. 3980 OKAYREC=ANSWER-PULLBACK
  300. 3990 IF NOT (OKAYREC<=ZERO) THEN 4010
  301. 4000 OKAYREC=ONE
  302. 4010 ' ENDIF
  303. 4020 EOFLOC=ZERO
  304. 4030 WHILE EOFLOC=ZERO AND OKAYREC<=ANSWER
  305. 4040 GET # ONE,OKAYREC
  306. 4050 A$=DUMMY1$
  307. 4060 EOFLOC=INSTR(A$,CHR$(26))
  308. 4070 IF NOT (EOFLOC=ZERO) THEN 4100
  309. 4080 OKAYREC=OKAYREC+ONE
  310. 4090 GOTO 4120
  311. 4100 ' ELSE
  312. 4110 OKAYREC=OKAYREC-ONE
  313. 4120 ' ENDIF
  314. 4130 WEND
  315. 4140 FILENGTH#=(OKAYREC*128)+EOFLOC
  316. 4150 IF NOT (EXT$="DBF") THEN 4180
  317. 4160 DATALEN#=FILENGTH#-DBFHEADER
  318. 4170 GOTO 4200
  319. 4180 ' ELSE
  320. 4190 DATALEN#=FILENGTH#
  321. 4200 ' ENDIF
  322. 4210 RECVALUE#=DATALEN#/RECLEN
  323. 4220 DISPLCNT=CINT(RECVALUE#) 
  324. 4230 IF NOT (EXT$="TXT") THEN 4250
  325. 4240 RECLEN=RECLEN-TWO
  326. 4250 ' ENDIF
  327. 4260 GOTO 4290
  328. 4270 ' ELSE
  329. 4280 DISPLCNT=ZERO
  330. 4290 ' ENDIF
  331. 4300 ' ENDIF
  332. 4310 CLOSE # ONE
  333. 4320 ' ENDIF
  334. 4330 PRINT CLEARSCREEN$
  335. 4340 PRINT: PRINT: PRINT: PRINT: PRINT: PRINT: PRINT: PRINT: PRINT
  336. 4350 IF NOT (DISPLCNT<ONE) THEN 4380
  337. 4360 PRINT "                 THERE ARE >> NO << RECORDS IN ";FILETRY$
  338. 4370 GOTO 4460
  339. 4380 IF NOT (ANSWER=32767) THEN 4430
  340. 4390 RECVALUE#=ANSWER*FACTOR#
  341. 4400 DISPLCNT=CINT(RECVALUE#)
  342. 4410 PRINT "               LIMITED OUT AT ";DISPLCNT;" RECORDS - PROBABLY MORE!!"
  343. 4420 GOTO 4450
  344. 4430 ' ELSE
  345. 4440 PRINT "             FILE  ";FILETRY$;"  CONTAINS ";DISPLCNT;" RECORDS, BY COUNT"
  346. 4450 ' ENDIF
  347. 4460 ' ENDIF
  348. 4470 GOTO 5190
  349. 4480 ' WARD-D
  350. 4490 OPEN "R",# ONE,FILETRY$,THREE
  351. 4500 FIELD # ONE, ONE AS SPACER$, TWO AS FILSIZE$
  352. 4510 GET # ONE,ONE
  353. 4520 FILSIZE=CVI(FILSIZE$)
  354. 4530 PRINT CLEARSCREEN$
  355. 4540 PRINT: PRINT: PRINT: PRINT: PRINT: PRINT
  356. 4550 PRINT "             FILE HEADER OF  ";FILETRY$;"  SHOWS ";FILSIZE;" RECORDS"
  357. 4560 PRINT: PRINT
  358. 4570 PRINT "     ENTER RECORD COUNT CHANGE: ";
  359. 4580 ' REPEAT
  360. 4590 ACCUM=ZERO
  361. 4600 GOSUB 7210
  362. 4610 IF NOT (NUMCOUNT=ZERO) THEN 4680
  363. 4620 NASTY$=" I Must Have A Number!! "
  364. 4630 PRINT NASTY$;BELL$;
  365. 4640 ENTRYLEN=ZERO
  366. 4650 GOSUB 5740
  367. 4660 GOSUB 5790
  368. 4670 GOTO 4790
  369. 4680 IF NOT (VAL(DUMMY$)>32767) THEN 4760
  370. 4690 NASTY$=" Limited to 32,767 Records!! "
  371. 4700 PRINT NASTY$;BELL$;
  372. 4710 ENTRYLEN=LEN(DUMMY$)
  373. 4720 NUMCOUNT=ZERO
  374. 4730 GOSUB 5740
  375. 4740 GOSUB 5790
  376. 4750 GOTO 4780
  377. 4760 ' ELSE
  378. 4770 ACCUM=VAL(DUMMY$)
  379. 4780 ' ENDIF
  380. 4790 ' ENDIF
  381. 4800 IF NOT (NUMCOUNT>ZERO) THEN 4580
  382. 4810 LSET FILSIZE$=MKI$(ACCUM)
  383. 4820 PUT # ONE,ONE
  384. 4830 GET # ONE,ONE
  385. 4840 CLOSE # ONE
  386. 4850 PRINT: PRINT: PRINT
  387. 4860 FILSIZE=CVI(FILSIZE$)
  388. 4870 PRINT "                   FILE HEADER UPDATED TO ";FILSIZE;" RECORDS"
  389. 4880 GOTO 5190
  390. 4890 ' WARD-E
  391. 4900 GOSUB 5320
  392. 4910 PRINT CLEARSCREEN$
  393. 4920 PRINT: PRINT: PRINT: PRINT: PRINT: PRINT
  394. 4930 PRINT "              FILE  ";FILETRY$;"  LAST ENTRY DATE IS:  ";DATE$
  395. 4940 PRINT: PRINT
  396. 4950 PRINT "     ENTER 'LAST ENTRY' DATE CHANGE:  ";DATEFORM$;STRING$(EIGHT,EIGHT);
  397. 4960 ENTRIES=ZERO: DUMMY$=NLLSTR$
  398. 4970 WHILE ENTRIES<>NINE
  399. 4980 GOSUB 5560
  400. 4990 DUMMY$=DUMMY$+DIGITS$
  401. 5000 ENTRIES=ENTRIES+THREE
  402. 5010 PRINT CHR$(12);
  403. 5020 WEND
  404. 5030 IF NOT (DUMMY$="000000") THEN 5060
  405. 5040 DATE$=CHR$(0)+CHR$(0)+CHR$(0)
  406. 5050 GOTO 5110
  407. 5060 ' ELSE
  408. 5070 MON$=CHR$(VAL(LEFT$(DUMMY$,TWO)))
  409. 5080 DAY$=CHR$(VAL(MID$(DUMMY$,THREE,TWO)))
  410. 5090 YEAR$=CHR$(VAL(RIGHT$(DUMMY$,TWO)))
  411. 5100 DATE$=MON$+DAY$+YEAR$
  412. 5110 ' ENDIF
  413. 5120 OPEN "R",# ONE,FILETRY$,SIX
  414. 5130 FIELD # ONE, THREE AS SPACER$, THREE AS FILDATE$
  415. 5140 LSET SPACER$=SPACER1$: LSET FILDATE$=DATE$
  416. 5150 PUT # ONE,ONE: CLOSE # ONE
  417. 5160 GOSUB 5320
  418. 5170 PRINT: PRINT: PRINT
  419. 5180 PRINT "              FILE HEADER UPDATED TO  ";DATE$;"  'LAST ENTRY' DATE"
  420. 5190 ' ENDGOTO
  421. 5200 PRINT: PRINT: PRINT
  422. 5210 PRINT "               <  <  Press Any Key To Return To Main Menu  >  >"
  423. 5220 PRINT
  424. 5230 ' REPEAT
  425. 5240 DUMMY$=INKEY$
  426. 5250 IF NOT (LEN(DUMMY$)=ONE) THEN 5230
  427. 5260 ' ENDIF
  428. 5270 IF NOT (NEWFILE=TRUE OR EXIT=TRUE) THEN 2010
  429. 5280 PRINT CLEARSCREEN$: PRINT
  430. 5290 IF NOT (EXIT=TRUE) THEN 1310
  431. 5300 SYSTEM
  432. 5310 ' [END OF MAINLINE PROGRAM]
  433. 5320 ' GET_FILE_DATE
  434. 5330 OPEN "R",# ONE,FILETRY$,SIX
  435. 5340 FIELD # ONE,THREE AS SPACER$,THREE AS FILDATE$
  436. 5350 GET # ONE, ONE
  437. 5360 SPACER1$=SPACER$: DATE$=FILDATE$: CLOSE # ONE
  438. 5370 IF NOT (DATE$=NLLSTR$) THEN 5400
  439. 5380 DATE$="00/00/00"
  440. 5390 GOTO 5540
  441. 5400 ' ELSE
  442. 5410 MON=ASC(LEFT$(DATE$,ONE))
  443. 5420 DAY=ASC(MID$(DATE$,TWO,ONE))
  444. 5430 YEAR=ASC(RIGHT$(DATE$,ONE))
  445. 5440 ARGU=MON: FMT=TWO
  446. 5450 GOSUB 6350
  447. 5460 MON$=ARGU$+"/"
  448. 5470 ARGU=DAY: FMT=TWO
  449. 5480 GOSUB 6350
  450. 5490 DAY$=ARGU$+"/"
  451. 5500 ARGU=YEAR
  452. 5510 GOSUB 6350
  453. 5520 YEAR$=ARGU$
  454. 5530 DATE$=MON$+DAY$+YEAR$
  455. 5540 ' ENDIF
  456. 5550 RETURN
  457. 5560 ' GET_TWO_DIGITS
  458. 5570 DIGITS$=NLLSTR$: DIGIT$=NLLSTR$
  459. 5580 ' REPEAT
  460. 5590 DIGIT$=INKEY$
  461. 5600 IF NOT (LEN(DIGIT$)=ONE) THEN 5710
  462. 5610 IF NOT (ASC(DIGIT$)>47 AND ASC(DIGIT$)<58) THEN 5650
  463. 5620 DIGITS$=DIGITS$+DIGIT$
  464. 5630 PRINT DIGIT$;
  465. 5640 GOTO 5700
  466. 5650 IF NOT (ASC(DIGIT$)=EIGHT) THEN 5690
  467. 5660 PRINT STRING$(ENTRIES+LEN(DIGITS$),EIGHT);
  468. 5670 PRINT CHR$(24);DATEFORM$;STRING$(EIGHT,EIGHT);
  469. 5680 ENTRIES=ZERO: DUMMY$=NLLSTR$: DIGITS$=NLLSTR$: DIGIT$=NLLSTR$
  470. 5690 ' ENDIF
  471. 5700 ' ENDIF
  472. 5710 ' ENDIF
  473. 5720 IF NOT (LEN(DIGITS$)=TWO) THEN 5580
  474. 5730 RETURN
  475. 5740 ' NASTYTIMER
  476. 5750 FOR TIMER=ONE TO 400
  477. 5760 NOP=ZERO
  478. 5770 NEXT TIMER
  479. 5780 RETURN
  480. 5790 ' NASTYCLEAR
  481. 5800 FOR CLEARING=ONE TO LEN(NASTY$)+ENTRYLEN
  482. 5810 PRINT BACKSPACE$;ONESPACE$;BACKSPACE$;
  483. 5820 NEXT CLEARING
  484. 5830 RETURN
  485. 5840 ' GET_DIRECTORY
  486. 5850 PRINT CLEARSCREEN$: PRINT: PRINT
  487. 5860 PRINT "     WHICH DRIVE?  [ ]";BACKSPACE$;BACKSPACE$;
  488. 5870 DUMMY$=NLLSTR$: OKAY=FALSE
  489. 5880 ' REPEAT
  490. 5890 DUMMY$=INKEY$
  491. 5900 IF NOT (LEN(DUMMY$)=ONE) THEN 6030
  492. 5910 IF NOT (FNPR(ASC(DUMMY$))=TRUE) THEN 6020
  493. 5920 J=ASC(DUMMY$)
  494. 5930 IF NOT (FNAL(J)=TRUE) THEN 5950
  495. 5940 DUMMY$=CHR$(J-OFFSET)
  496. 5950 ' ENDIF
  497. 5960 IF NOT (FNDV(ASC(DUMMY$))=TRUE) THEN 5990
  498. 5970 OKAY=TRUE: PRINT DUMMY$;"] "
  499. 5980 GOTO 6010
  500. 5990 ' ELSE
  501. 6000 PRINT BELL$;
  502. 6010 ' ENDIF
  503. 6020 ' ENDIF
  504. 6030 ' ENDIF
  505. 6040 IF NOT (OKAY=TRUE) THEN 5880
  506. 6050 DRV$=DUMMY$+COLON$
  507. 6060 PRINT: PRINT
  508. 6070 PRINT "     [1] = ALL FILES    [2] = *.DBF FILES ONLY    [3] = *.TXT FILES ONLY"
  509. 6080 PRINT: PRINT
  510. 6090 PRINT "     CHOICE: [ ]";BACKSPACE$;BACKSPACE$;
  511. 6100 DUMMY=ZERO
  512. 6110 ' REPEAT
  513. 6120 DUMMY$=INKEY$
  514. 6130 IF NOT (LEN(DUMMY$)=ONE) THEN 6200
  515. 6140 IF NOT (DUMMY$="1" OR DUMMY$="2" OR DUMMY$="3") THEN 6170
  516. 6150 DUMMY=VAL(DUMMY$)
  517. 6160 GOTO 6190
  518. 6170 ' ELSE
  519. 6180 PRINT BELL$;
  520. 6190 ' ENDIF
  521. 6200 ' ENDIF
  522. 6210 IF NOT (DUMMY>ZERO AND DUMMY<FOUR) THEN 6110
  523. 6220 IF NOT (DUMMY=ONE) THEN 6250
  524. 6230 FIL$=DRV$+"*.*"
  525. 6240 GOTO 6310
  526. 6250 IF NOT (DUMMY=TWO) THEN 6280
  527. 6260 FIL$=DRV$+"*.DBF"
  528. 6270 GOTO 6300
  529. 6280 ' ELSE
  530. 6290 FIL$=DRV$+"*.TXT"
  531. 6300 ' ENDIF
  532. 6310 ' ENDIF
  533. 6320 PRINT CARRIAGERETURN$;"DIRECTORY FOR  ";FIL$;"     ": PRINT
  534. 6330 FILES FIL$: PRINT
  535. 6340 RETURN
  536. 6350 ' FORMAT_DIGITS
  537. 6360 IF NOT (ARGU<10) THEN 6390
  538. 6370 ARGU$=RIGHT$(STR$(ARGU),ONE)
  539. 6380 GOTO 6510
  540. 6390 IF NOT (ARGU<100) THEN 6420
  541. 6400 ARGU$=RIGHT$(STR$(ARGU),TWO)
  542. 6410 GOTO 6510
  543. 6420 IF NOT (ARGU<1000) THEN 6450
  544. 6430 ARGU$=RIGHT$(STR$(ARGU),THREE)
  545. 6440 GOTO 6510
  546. 6450 IF NOT (ARGU<10000) THEN 6480
  547. 6460 ARGU$=RIGHT$(STR$(ARGU),FOUR)
  548. 6470 GOTO 6500
  549. 6480 ' ELSE
  550. 6490 ARGU$=RIGHT$(STR$(ARGU),FIVE)
  551. 6500 ' ENDIF
  552. 6510 ' ENDIF
  553. 6520 IF NOT (FMT<>ZERO) THEN 6560
  554. 6530 PAD$="000000"
  555. 6540 PAD=FMT-LEN(ARGU$)
  556. 6550 ARGU$=LEFT$(PAD$,PAD)+ARGU$
  557. 6560 ' ENDIF
  558. 6570 RETURN
  559. 6580 ' CANT_FIND_FILE
  560. 6590 IF NOT (ERR=FILEERR) THEN 6630
  561. 6600 CLOSE: NOFILE=TRUE
  562. 6610 RESUME NEXT
  563. 6620 GOTO 6790
  564. 6630 IF NOT (ERR=PASTENDERR) THEN 6710
  565. 6640 PRINT CLEARSCREEN$;BELL$
  566. 6650 PRINT: PRINT: PRINT: PRINT: PRINT: PRINT: PRINT: PRINT: PRINT
  567. 6660 PRINT "     * * * ERROR: Database File Is EMPTY Or Contents Invalid - Aborting!!"
  568. 6670 CLOSE: PRINT: PRINT
  569. 6680 GOSUB 5740
  570. 6690 RESUME 1280
  571. 6700 GOTO 6780
  572. 6710 ' ELSE
  573. 6720 PRINT CLEARSCREEN$;BELL$
  574. 6730 PRINT: PRINT: PRINT: PRINT: PRINT: PRINT: PRINT: PRINT: PRINT
  575. 6740 PRINT "      * * * ERROR:  An Unexpected Error Has Occurred - Halting Program!"
  576. 6750 CLOSE: PRINT
  577. 6760 PRINT "                         ERR =";ERR;"  AND   ERL =";ERL: PRINT
  578. 6770 STOP
  579. 6780 ' ENDIF
  580. 6790 ' ENDIF
  581. 6800 ' GETCHARS
  582. 6810 CHARCOUNT=ZERO
  583. 6820 DUMMY$=NLLSTR$ '
  584. 6830 ' REPEAT
  585. 6840 DUMMY1$=INKEY$
  586. 6850 IF NOT (LEN(DUMMY1$)=ONE) THEN 7020
  587. 6860 IF NOT (DUMMY1$=BACKSPACE$ AND CHARCOUNT>ZERO) THEN 6910
  588. 6870 CHARCOUNT=CHARCOUNT-ONE
  589. 6880 DUMMY$=LEFT$(DUMMY$,CHARCOUNT)
  590. 6890 PRINT BACKSPACE$+ONESPACE$+BACKSPACE$;
  591. 6900 GOTO 7010
  592. 6910 IF NOT (FNPR(ASC(DUMMY1$))) THEN 7000
  593. 6930 J=ASC(DUMMY1$)
  594. 6940 IF NOT (FNAL(J)) THEN 6960
  595. 6950 DUMMY1$=CHR$(J-OFFSET)
  596. 6960 ' ENDIF
  597. 6970 DUMMY$=DUMMY$+DUMMY1$
  598. 6980 CHARCOUNT=CHARCOUNT+ONE
  599. 6990 PRINT DUMMY1$;
  600. 7000 ' ENDIF
  601. 7010 ' ENDIF
  602. 7020 ' ENDIF
  603. 7040 IF NOT (DUMMY1$=CARRIAGERETURN$) THEN 6830
  604. 7050 RETURN
  605. 7060 ' GET_LAST_RECORD_NO
  606. 7070 ANSWER=ZERO
  607. 7080 FOR EXPONENT = 14 TO ZERO STEP -ONE
  608. 7090 GET #FILE, ANSWER+(2^EXPONENT)
  609. 7100 IF NOT (NOT (EOF(FILE))) THEN 7120
  610. 7110 ANSWER=ANSWER+(2^EXPONENT)
  611. 7120 ' ENDIF
  612. 7130 NEXT EXPONENT
  613. 7140 IF NOT (ANSWER=ZERO) THEN 7170
  614. 7150 NORECORDS=TRUE
  615. 7160 GOTO 7190
  616. 7170 ' ELSE
  617. 7180 NORECORDS=FALSE
  618. 7190 ' ENDIF
  619. 7200 RETURN
  620. 7210 ' GETNUM
  621. 7220 NUMCOUNT=ZERO
  622. 7230 DUMMY$=NLLSTR$
  623. 7240 ' REPEAT
  624. 7250 DUMMY1$=INKEY$
  625. 7260 IF NOT (LEN(DUMMY1$)=ONE) THEN 7380
  626. 7270 IF NOT (DUMMY1$=BACKSPACE$ AND NUMCOUNT>ZERO) THEN 7320
  627. 7280 NUMCOUNT=NUMCOUNT-ONE
  628. 7290 DUMMY$=LEFT$(DUMMY$,NUMCOUNT)
  629. 7300 PRINT BACKSPACE$;ONESPACE$;BACKSPACE$;
  630. 7310 GOTO 7370
  631. 7320 IF NOT (FNNU(ASC(DUMMY1$))) THEN 7360
  632. 7330 NUMCOUNT=NUMCOUNT+ONE
  633. 7340 DUMMY$=DUMMY$+DUMMY1$
  634. 7350 PRINT DUMMY1$;
  635. 7360 ' ENDIF
  636. 7370 ' ENDIF
  637. 7380 ' ENDIF
  638. 7400 IF NOT (DUMMY1$=CARRIAGERETURN$) THEN 7240
  639. 7410 RETURN
  640. 7420 END
  641. NT DU