home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / DATABASE / DIMS103.ARK / DIMS.ASC < prev    next >
Text File  |  1986-12-07  |  10KB  |  368 lines
  1. 5 '            *****     DIMS   *****
  2. 6 '
  3. 7 '
  4. 10 '                INITIALIZATION
  5.  
  6. 20 DEFINT A-Z
  7. 30 GOSUB 3420 'cs
  8. 40 PRINT:PRINT TAB(29);"DIMS 1.03, January 20, 1984
  9. 45            'ACT-5A TERMINAL
  10. 50 PRINT
  11. 80 '  Dan's Information Management System
  12. 85 '  for Basic-80 and CP/M
  13. 90 '  originates from PIMS written by Madan L. Gupta
  14. 95 '  which comes from A People's Data Base System
  15. 96 '  by Gupta and Brent Lander (1977)
  16. 100 ' re-written by Dan Dugan, 1979, 1980, 1981, 1982, 1983
  17. 110 ' Public Domain - removal of this notice constitutes fraud
  18. 120 ' makes random disk records of 128 or 255 bytes
  19. 130 ' allows 15 or 30 data fields in record
  20. 140 ' makes automatic duplicate file
  21. 150 CLEAR,,1000 ' stack space for MBASIC 5.x
  22. 155 DEFINT A-Z
  23. 160 WIDTH LPRINT 255
  24. 170 ' init vars in this order for speed
  25. 180 I=0:J=0:K=0:X=0:Y=0:T$="":R$="":T1$="":SKIPPARSE=0:T=0:FT=0:SEARCH=0
  26. 190 ' then these for COMMON
  27. 200 C=0:N=0:NC=0:P6=0:P7=0:P8=0:P9=0:PI=0:S=0:T1=0:T2=0:F$="":FT$="":S$=""
  28. 210 DIM DD$(5)
  29. 220 DIM C$(10) ' commands
  30. 230 DIM N$(31), B$(32), C(30) ' 30 names + stop + N
  31. 240 DIM SEARCHWORD$(10), SEARCHFIELD(10), SKIPWORD$(10), LOOKFIELD(10)
  32. 243 NDRIVES=2:GOSUB 1360    ' init disk name strings
  33. 245 PRINT TAB(33);NDRIVES"disk system.
  34. 250 GOTO 1050
  35. 1000 '
  36.  
  37.                 WARM ENTRY
  38.  
  39. 1010 DEFINT A-Z
  40. 1020 GOSUB 3420'cs
  41. 1023 IF C THEN GOSUB 1970    ' save header
  42. 1025 IF T=7 THEN CLOSE:GOTO 1650        ' goto
  43. 1030 IF T=8 THEN 4200        ' reopen
  44. 1033 IF T=9 THEN CLOSE:T=0:GOTO 1050        ' done
  45. 1035 IF T=11 THEN 2100        ' backup
  46. 1040 IF T=12 THEN 3000        ' renumber
  47. 1050 'some not needed but commoned to keep places for speed
  48. 1060 COMMON I,J,K,X,Y,T$,R$,S$,T1$,SKIPPARSE,FT,SEARCH,
  49.     C,N,NC,P6,P7,P8,P9,PI,S,T,T1,T2,C(),B$(),N$(),
  50.     SEARCHWORD$(),SEARCHFIELD(),SKIPWORD$(),LOOKFIELD(),DD$(),F$,FT$
  51. 1070 ON ERROR GOTO 3290
  52. 1080 '
  53.  
  54.  
  55.                 NO-FILE MENU
  56.  
  57. 1100 WIDTH 70 :RESET            'RESET here for floppy system
  58. 1105 IF E$<>"" THEN PRINT E$:PRINT
  59. 1110 PRINT:PRINT TAB(22)"Here are the data files on this disk:
  60. 1120 PRINT:FILES DD$(3)+"*.D?"
  61. 1125 WIDTH 255
  62. 1130 PRINT:PRINT:PRINT TAB(16);"*************  DIMS NO-FILE MENU  **************
  63. 1140 PRINT:PRINT TAB(16);"Open any data file shown above ............... 1
  64. 1150 PRINT TAB(16);"Install new disks ............................ 2
  65. 1160 PRINT
  66. 1170 PRINT TAB(16);"Design structure of a new file (DCREATE) ..... 3
  67. 1180 PRINT TAB(16);"Change number of disk drives for this session. 4
  68. 1190 PRINT
  69. 1200 PRINT TAB(16);"Exit DIMS to Basic ........................... 9
  70. 1210 PRINT TAB(16);"Exit DIMS to CP/M ............................ 0
  71. 1220 PRINT:PRINT TAB(16);STRING$(48,42):PRINT
  72. 1230 PRINT TAB(16);:
  73.     PRINT"To continue enter a number ................... ";
  74. 1240 A$=INPUT$(1): IF A$=CHR$(13) THEN A$="1"
  75. 1250 PRINT A$
  76. 1255 RESET        ' safety for floppies
  77. 1260 IF A$="0" THEN SYSTEM
  78. 1270 IF A$="1" THEN GOTO 1650
  79. 1280 IF A$="2" THEN GOTO 1000
  80. 1290 IF A$="3" THEN CHAIN DD$(2)+"DCREATE"
  81. 1300 IF A$="4" THEN GOSUB 1330:GOTO 1000
  82. 1310 IF A$="9" THEN GOSUB 3420:STOP
  83. 1320 GOTO 1230
  84. 1330 '
  85.                 (SUB) ASK # DISKS
  86.  
  87. 1340 PRINT:PRINT TAB(27);:INPUT"Number of disks in system";NDRIVES
  88. 1345 PRINT:IF NDRIVES<1 THEN 1000
  89. 1350 IF NDRIVES>4 THEN 1340
  90. 1360 '
  91.         (SUB) INSTALL DISK NAMES
  92.  
  93. 1370 RESTORE 1390
  94. 1380 '   DD$(1)  (2)  (3)  (4)  (5) ' file groups
  95. 1382 '     main trans data dupe misc
  96. 1383 '     pgms pgms  file file files
  97. 1390 DATA 1,"A:","A:","A:","A:","A:"
  98. 1400 DATA 2,"A:","B:","A:","B:","B:"
  99. 1410 DATA 3,"A:","A:","B:","C:","A:"
  100. 1420 DATA 4,"A:","A:","B:","C:","D:"
  101. 1430 READ J
  102. 1440 FOR K=1 TO 5
  103. 1450    READ DD$(K)
  104. 1460 NEXT
  105. 1470 IF J<>NDRIVES THEN 1430
  106. 1480 IF A$<>"4" THEN RETURN
  107. 1490 ON NDRIVES GOTO 1500,1510,1540,1580
  108. 1500 PRINT"One disk system - all files and programs on A.":GOTO 1630
  109. 1510 PRINT"Two disk system:  A: = main program and main data files
  110. 1520 PRINT TAB(19)"B: = transient programs, backup data files, aux. data files
  111. 1530 GOTO 1630
  112. 1540 PRINT
  113. "Three disk system:  A: = main program, transient programs, aux data files
  114. 1550 PRINT TAB(21)"B: = main data files
  115. 1560 PRINT TAB(21)"C: = backup data files
  116. 1570 GOTO 1630
  117. 1580 PRINT"Four disk system:  A: = main and transient programs
  118. 1590 PRINT TAB(20)"B: = main data files
  119. 1600 PRINT TAB(20)"C: = backup data files
  120. 1610 PRINT TAB(20)"D: = aux. data files
  121. 1630 PRINT:PRINT TAB(29)"Hit return to continue.":A$=INPUT$(1)
  122. 1640 RETURN
  123. 1650 '
  124.  
  125.  
  126.                 LOAD HEADER
  127.  
  128. 1660 GOSUB 3480 ' get name & open up files
  129. 1670 GOSUB 3420 'cs
  130. 1690 GOSUB 3750 ' get record
  131. 1700 GOSUB 1880 'parse into B$'s
  132. 1710 FOR I=1 TO 31
  133. 1720    N$(I)=B$(I) 'load names
  134. 1730    IF LEFT$(N$(I),4)="stop" GOTO 1760
  135. 1740    C(I)=1
  136. 1750 NEXT I
  137. 1760 N=VAL(B$(I+1))
  138. 1770 NC=I-1 ' # cols
  139. 1780 PRINT TAB(20)"File "F$" is open.  It has"N"records."
  140. 1790 '
  141.  
  142.  
  143.                 EXIT TO DEDIT
  144.  
  145. 1795 PRINT:PRINT TAB(24)"Waiting while DEDIT is loading."
  146. 1800 CHAIN DD$(1)+"DEDIT",1000
  147. 1810 '
  148.  
  149.  
  150.                 (SUB) WRITE T$ AS RECORD # I
  151.  
  152. 1820 ON FT GOTO 1850,1830
  153. 1830 LSET R$=MID$(T$,129) ' latter half
  154. 1840 PUT #1,FT*I+2
  155. 1850 LSET R$=LEFT$(T$,128) ' first half
  156. 1860 PUT #1,FT*I+1
  157. 1870 RETURN
  158. 1880 '
  159.  
  160.  
  161.  
  162.                 (SUB) PARSE STRING
  163.  
  164. 1890 K=0
  165. 1900 J=INSTR(T$,CHR$(126)) ' delimiter
  166. 1910 IF J=0 THEN RETURN
  167. 1920 K=K+1
  168. 1930 B$(K)=MID$(T$,1,J-1)
  169. 1940 T$=MID$(T$,J+1)
  170. 1950 GOTO 1900
  171. 1970 '
  172.  
  173.                 (SUB) SAVE HEADERS
  174.  
  175. 1990 PRINT:PRINT TAB(31)"Saving file header":PRINT TAB(39);
  176. 2000 T$=""
  177. 2010 FOR I=1 TO 31:
  178.     T$=T$+N$(I)+CHR$(126):
  179.     T1$=LEFT$(N$(I),4):
  180.     IF T1$="stop" THEN 2030
  181. 2020 NEXT I
  182. 2030 T$=T$+STR$(N)+CHR$(126) 'add N at end
  183. 2040 I=0
  184. 2050 GOSUB 1810 ' put rec 0
  185. 2060 PRINT "*";
  186. 2062 NR=0:T1$=T$:GOSUB 3960    'put dupe head
  187. 2064 PRINT"!"
  188. 2070 RETURN
  189. 2100 '
  190.  
  191.                 BACKUP makes dupe file
  192.  
  193. 2110 CLOSE 2:KILL DD$(4)+F$+".DD"+FT$
  194. 2120 GOSUB 3720            ' open up .DD on 2
  195. 2130 PRINT"Copying main file to dupe file, same numbers.":PRINT
  196. 2140 FOR I=0 TO N
  197. 2150    IF INKEY$=CHR$(27) THEN PRINT:PRINT:PRINT"Copy aborted.":GOTO 3260
  198. 2160    GOSUB 3750: PRINT"+";    ' get record I in T$
  199. 2170    NR=I:T1$=T$:GOSUB 3960:PRINT"*"; ' put record NR
  200. 2180 NEXT
  201. 2190 PRINT:GOTO 3260            ' to DEDIT
  202. 3000 '
  203.  
  204.  
  205.                 RENUMBER
  206.  
  207.         COPY MAIN TO DUPE
  208.  
  209. 3010 CLOSE 2:KILL DD$(4)+F$+".DD"+FT$
  210. 3020 GOSUB 3720 ' open 2
  211. 3030 PRINT"Copying main file to dupe file, renumbering.":PRINT
  212. 3040 NR=0
  213. 3050 FOR I=1 TO N
  214. 3060    IF INKEY$=CHR$(27) THEN PRINT:PRINT:PRINT"Renumber aborted.":GOTO 3260
  215. 3070    GOSUB 3750 ' get rec I in T$
  216. 3080    IF ASC(T$)=0 THEN PRINT"0";:GOTO 3100' skip it
  217. 3090    PRINT"+";:NR=NR+1:T1$=T$:GOSUB 3960:PRINT"!"; ' put rec NR
  218. 3100 NEXT
  219. 3110 GOSUB 4030 ' save header (NR)
  220. 3120 '
  221.  
  222.         ERASE MAIN FILE AND COPY DUPE TO MAIN
  223.  
  224. 3130 CLOSE
  225. 3140 PRINT:PRINT"The following operation removes space from deleted records:
  226. 3150 PRINT: PRINT"Erasing main file.
  227. 3160 KILL DD$(3)+F$+".D"+FT$
  228. 3170 PRINT:PRINT:PRINT"Copying dupe to main file.":PRINT
  229. 3180 GOSUB 3680 ' open both files
  230. 3190 FOR J=1 TO FT*(NR+1)
  231. 3200    GET #2,J
  232. 3210    PRINT"&";
  233. 3220    LSET R$=S$
  234. 3230    PUT #1,J
  235. 3240    PRINT"*";
  236. 3250 NEXT J
  237. 3251 N=NR
  238. 3252 PRINT:GOSUB 1970            'put header
  239. 3255 '
  240.  
  241.         RETURN TO DEDIT
  242. 3260 GOTO 1790
  243. 3280 '
  244.  
  245.                 GENERAL ERROR ROUTINES
  246.  
  247. 3290 IF ERL=1120 AND ERR=53 THEN RESUME 1130 ' if disk empty
  248. 3300 IF ERL=1740 AND ERR=9
  249.     THEN CLOSE:E$="CAN'T READ HEADER PROPERLY":RESUME 1000
  250. 3310 IF ERR=61 THEN PRINT:PRINT"Out of disk space.":PRINT:CLOSE:RESUME 1000
  251. 3312 IF ERR=53 THEN E$="FILE NOT FOUND":RESUME 1080
  252. 3320 ON ERROR GOTO 0
  253. 3330 '
  254.  
  255.  
  256.                 UCV
  257.  
  258. 3340 Y$=""
  259. 3350 FOR K=1 TO LEN(X$)
  260. 3360    Y$=Y$+" "
  261. 3370    X=ASC(MID$(X$,K, 1))
  262. 3380    IF 96<X AND X<123 THEN MID$(Y$,K,1)=CHR$(X-32): GOTO 3400
  263. 3390    MID$(Y$,K,1)=MID$(X$,K,1)
  264. 3400 NEXT
  265. 3410 RETURN
  266. 3420 '
  267.  
  268.  
  269.                 (SUB) CLEAR SCREEN (TERM DEP)
  270.  
  271. 3430 PRINT CHR$(12);
  272. 3440 RETURN
  273. 3480 '
  274.  
  275.  
  276.                 (SUB) OPEN UP FILES
  277.         GET NAME
  278.  
  279. 3490 F$=""
  280. 3500 C=0 ' clear change flag
  281. 3505 IF T=7 THEN F$=B$(0):T=0:GOTO 3525    ' goto commmand
  282. 3510 PRINT: PRINT TAB(17);: INPUT"Name of the file you want to open"; F$
  283. 3525 IF F$="" THEN 1000
  284. 3530 X$=F$
  285. 3540 GOSUB 3330 ' UCverter
  286. 3550 F$=Y$ ' make UC
  287. 3560 '
  288.  
  289.         TEST NAME, EXTRACT FILE TYPE
  290.  
  291. 3570 CLOSE
  292. 3580 ON ERROR GOTO 3610
  293. 3590 OPEN"I",1,DD$(3)+F$+".D"
  294. 3600 FT=1: FT$=" ": GOTO 3690 ' file is type 1
  295. 3610    IF ERR=64 THEN 3612 ELSE 3620
  296. 3612        E$="BAD FILE NAME":PRINT E$:IF T=7 THEN T=0:RESUME 1000
  297. 3614        RESUME 3480
  298. 3620    IF ERR=53 THEN CLOSE:RESUME 3630'not found
  299. 3630 ON ERROR GOTO 3660
  300. 3640 OPEN"I",1,DD$(3)+F$+".D2"
  301. 3650 FT=2: FT$="2": GOTO 3690 ' file is type 2
  302. 3660    IF ERR=53 THEN 3662 ELSE 3670
  303. 3662        E$="FILE NOT FOUND":PRINT E$:IF T=7 THEN T=0:RESUME 1000
  304. 3664        RESUME 3480
  305. 3670    ON ERROR GOTO 0
  306. 3680 '
  307.  
  308.         OPEN UP FILES FOR REAL
  309.  
  310. 3690 CLOSE:I=0:ON ERROR GOTO 3280
  311. 3700 OPEN "R",1,DD$(3)+F$+".D"+FT$
  312. 3710 FIELD #1,128 AS R$
  313. 3720 OPEN "R",2,DD$(4)+F$+".DD"+FT$
  314. 3730 FIELD #2, 128 AS S$
  315. 3740 RETURN
  316. 3750 '
  317.  
  318.                 (SUB) GET REC. I IN T$
  319.  
  320. 3760 T$=""
  321. 3770 ON FT GOTO 3800,3780
  322. 3780    GET#1,FT*I+2 ' latter half
  323. 3790    T$=LEFT$(R$,127)
  324. 3800    GET#1,FT*I+1 ' whole or first half
  325. 3810    T$=R$+T$
  326. 3820 RETURN
  327. 3830 '
  328.  
  329.                 (SUB) SHOW FIELDS
  330.  
  331. 3840 FOR J=1 TO NC
  332. 3850    IF C(J)=0 THEN 3880
  333. 3860    PRINT TAB(29);
  334. 3870    PRINT USING"##";J;:PRINT".  "LEFT$(N$(J),4)"  "RIGHT$(N$(J),1)
  335. 3880 NEXT
  336. 3890 PRINT
  337. 3900 RETURN
  338. 3960 '
  339.  
  340.                 (SUB) PUT T1$ AS REC NR
  341.  
  342. 3970 ON FT GOTO 4000,3980
  343. 3980    LSET S$=MID$(T1$,129)
  344. 3990    PUT#2,FT*NR+2
  345. 4000    LSET S$=LEFT$(T1$,128)
  346. 4010    PUT#2,FT*NR+1
  347. 4020 RETURN
  348. 4030 '
  349.  
  350.                 (SUB) CLOSE DUPE FILE
  351.  
  352. 4040 IF F2$=F$ THEN C=1:N=NR:GOTO 4130
  353. 4050 PRINT:PRINT:PRINT"Closing dupe file,"NR"records.
  354. 4060 T$=""
  355. 4070 FOR I=1 TO 31
  356. 4080    T$=T$+N$(I)+CHR$(126)
  357. 4090    IF LEFT$(N$(I),4)="stop" THEN 4110
  358. 4100 NEXT
  359. 4110 T1$=T$+STR$(NR)+CHR$(126)
  360. 4120 N1=NR:NR=0:GOSUB 3960:NR=N1
  361. 4130 CLOSE 2
  362. 4140 RETURN
  363. 4200 '
  364.  
  365.                 RE-OPEN AFTER DISK ERR
  366.  
  367. 4210 CLOSE:GOSUB 3700:GOTO 1790
  368.