home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / cpm / database / dims103.ark / DCREATE.ASC < prev    next >
Encoding:
Text File  |  1986-12-07  |  3.8 KB  |  134 lines
  1. 10 ' DCREATE by Dan Dugan -- public domain
  2. 900 GOTO 1015
  3. 1000 PRINT CHR$(7):PRINT
  4.  
  5.     "To create a new file, you must first 'done' this file and then enter
  6. 1005 PRINT"DCREATE from the DIMS main menu.
  7. 1010 PRINT:DEFINT A-Z:GOTO 1670        'return to DEDIT
  8. 1015 PRINT CHR$(12);            'clear screen (TERM DEP)
  9. 1020 PRINT:PRINT"DCREATE March 20, 1982
  10. 1030 DEFINT A-Z
  11. 1040 ON ERROR GOTO 1950
  12. 1050 COMMON I,J,K,X,Y,T$,R$,S$,T1$,SKIPPARSE,FT,SEARCH,
  13.  
  14.     C,N,NC,P6,P7,P8,P9,PI,S,T,T1,T2,C(),B$(),N$(),
  15.  
  16.     SEARCHWORD$(),SEARCHFIELD(),SKIPWORD$(),LOOKFIELD(),DD$(),F$,FT$
  17. 1060 PRINT: PRINT"Please define the record size for your new file.
  18. 1070 PRINT"You can choose size 1 or size 2.  Size 2 uses up twice as much disk
  19. 1080 PRINT"space as size 1.  Your usable storage per record equals the record
  20. 1090 PRINT"size minus the number of fields.
  21. 1100 PRINT
  22. 1110 PRINT"      1  128 characters per record (bytes)
  23. 1120 PRINT"      2  255 characters per record (bytes)
  24. 1130 PRINT: INPUT"    "; FT        'file type
  25. 1140    IF FT=0 THEN FT=1
  26. 1150    IF FT=1 THEN FT$=" ": GOTO 1190
  27. 1160    IF FT=2 THEN FT$="2": GOTO 1190
  28. 1170    IF FT<0 OR FT>2 THEN 1670
  29. 1180 GOTO 1060
  30. 1190 PRINT: PRINT"Here is a directory of the files currently on the disk...
  31. 1200 PRINT: WIDTH 70: FILES DD$(3)+"*.D?": WIDTH 255
  32. 1210 PRINT:PRINT:PRINT"Remember, if you create a file name which is the same as one ":
  33.  
  34. PRINT"that already exists, you will destroy the old file on the disc.":PRINT
  35. 1220 PRINT "Now create a new file...";
  36. 1230 GOSUB 1800 ' open up files
  37. 1240 '
  38.  
  39.  
  40.                 DEFINE FILE STRUCTURE
  41.  
  42.  
  43. 1250 N=0 'number of records in file
  44. 1260 C=1 ' change flag
  45. 1270 GOSUB 1770        'cs
  46. 1280 PRINT F$
  47. 1290 PRINT"Define file structure;  enter field name and type:
  48. 1300 PRINT"(to finish, enter 'stop')"
  49. 1310 FOR I=1 TO 15*FT
  50. 1320 PRINT
  51. 1330    PRINT"Name (4 char) of field ";:PRINT USING"##";I;
  52. 1340    INPUT T$
  53. 1350    IF T$="" THEN GOTO 1330
  54. 1360    IF T$="stop" THEN 1500
  55. 1370    INPUT"Field type (a or n)      ";T1$
  56. 1380    IF T1$="" THEN T1$="a"
  57. 1390    IF T1$<>"a" THEN GOTO 1410
  58. 1400    GOTO 1450
  59. 1410    IF T1$<>"n" THEN GOTO 1430
  60. 1420    GOTO 1450
  61. 1430    PRINT"Type must be 'a' or 'n'
  62. 1440    GOTO 1370
  63. 1450    T$=T$+"     "
  64. 1460    T$=LEFT$(T$,4) ' chop down to 4 char
  65. 1470    T$=T$+","+T1$
  66. 1480    N$(I)=T$:C(I)=1
  67. 1490 NEXT I
  68. 1500 NC=I-1
  69. 1510 N$(I)="stop0" ' end cue for many routines
  70. 1520 GOSUB 1770 'cs5
  71. 1530 PRINT"Structure definition complete."
  72. 1540 PRINT: PRINT"Name:  "F$; TAB(20); "Type: "FT
  73. 1550 PRINT:PRINT"Fields are:"
  74. 1560 PRINT
  75. 1570 FOR I=1 TO NC
  76. 1580    IF LEFT$(N$(I),4)="stop" THEN GOTO 1630
  77. 1590    PRINT USING"##"; I;
  78. 1600    PRINT ".  "; LEFT$(N$(I),4); " "; RIGHT$(N$(I),1)
  79. 1610 NEXT I
  80. 1620 '
  81.  
  82.  
  83.                 FINISH
  84.  
  85.  
  86. 1630 PRINT
  87. 1640 INPUT"Do you approve?  (y/n) ", A$
  88. 1650 IF A$="" THEN A$="y"
  89. 1660 IF A$<>"y" THEN CLOSE: GOTO 1060
  90. 1670 CHAIN DD$(1)+"DEDIT",1000
  91. 1680 '
  92.  
  93.  
  94.  
  95.                 UCV
  96.  
  97.  
  98. 1690 Y$=""
  99. 1700 FOR J=1 TO LEN(X$)
  100. 1710    Y$=Y$+" "
  101. 1720    X=ASC(MID$(X$,J, 1))
  102. 1730    IF 96<X AND X<123 THEN MID$(Y$,J,1)=CHR$(X-32): GOTO 1750
  103. 1740    MID$(Y$,J,1)=MID$(X$,J,1)
  104. 1750 NEXT J
  105. 1760 RETURN
  106. 1770 '
  107.  
  108.  
  109.  
  110.                 CLEAR SCREEN (TERM DEP)
  111.  
  112.  
  113. 1780 PRINT CHR$(12);
  114. 1790 RETURN
  115. 1800 '
  116.  
  117.  
  118.  
  119.                 OPEN UP FILES SUB
  120.  
  121.                 GET NAME
  122.  
  123.  
  124. 1810 F$=""
  125. 1820 C=0 ' clear change flag
  126. 1830 PRINT: PRINT TAB(13);: INPUT"Name of the file you want to open"; F$
  127. 1840 IF F$="" THEN 1830
  128. 1850 X$=F$
  129. 1860 GOSUB 1680 ' UCverter
  130. 1870 F$=Y$ ' make UC
  131. 1880 '
  132.  
  133.  
  134.                 OPEN UP FILES FOR REAL
  135.  
  136.  
  137. 1890 OPEN "R",1,DD$(3)+F$+".D"+FT$
  138. 1900 FIELD #1,128 AS R$
  139. 1910 OPEN "R",2,DD$(4)+F$+".DD"+FT$
  140. 1920 FIELD #2, 128 AS S$
  141. 1930 RETURN
  142. 1940 '
  143. 1950 '
  144.  
  145.  
  146.                 ERROR HANDLING ROUTINES
  147.  
  148.  
  149. 1960 IF ERR=53 AND ERL=1200 THEN RESUME 1210
  150. 1970 IF ERR=64 AND ERL=1890 THEN PRINT"*** Bad file name!":CLOSE:RESUME 1190
  151. 1980 IF ERR=61 AND (ERL=1890 OR ERL=1910) THEN CLOSE:RESUME 1190
  152. 1990 ON ERROR GOTO 0
  153. *** Bad file name!":CLOSE:RESUM