10 ' DCREATE by Dan Dugan -- public domain
900 GOTO 1015
1000 PRINT CHR$(7):PRINT
"To create a new file, you must first 'done' this file and then enter
1005 PRINT"DCREATE from the DIMS main menu.
1010 PRINT:DEFINT A-Z:GOTO 1670 'return to DEDIT
1015 PRINT CHR$(12); 'clear screen (TERM DEP)
1020 PRINT:PRINT"DCREATE March 20, 1982
1030 DEFINT A-Z
1040 ON ERROR GOTO 1950
1050 COMMON I,J,K,X,Y,T$,R$,S$,T1$,SKIPPARSE,FT,SEARCH,
C,N,NC,P6,P7,P8,P9,PI,S,T,T1,T2,C(),B$(),N$(),
SEARCHWORD$(),SEARCHFIELD(),SKIPWORD$(),LOOKFIELD(),DD$(),F$,FT$
1060 PRINT: PRINT"Please define the record size for your new file.
1070 PRINT"You can choose size 1 or size 2. Size 2 uses up twice as much disk
1080 PRINT"space as size 1. Your usable storage per record equals the record
1090 PRINT"size minus the number of fields.
1100 PRINT
1110 PRINT" 1 128 characters per record (bytes)
1120 PRINT" 2 255 characters per record (bytes)
1130 PRINT: INPUT" "; FT 'file type
1140 IF FT=0 THEN FT=1
1150 IF FT=1 THEN FT$=" ": GOTO 1190
1160 IF FT=2 THEN FT$="2": GOTO 1190
1170 IF FT<0 OR FT>2 THEN 1670
1180 GOTO 1060
1190 PRINT: PRINT"Here is a directory of the files currently on the disk...
1200 PRINT: WIDTH 70: FILES DD$(3)+"*.D?": WIDTH 255
1210 PRINT:PRINT:PRINT"Remember, if you create a file name which is the same as one ":
PRINT"that already exists, you will destroy the old file on the disc.":PRINT
1220 PRINT "Now create a new file...";
1230 GOSUB 1800 ' open up files
1240 '
DEFINE FILE STRUCTURE
1250 N=0 'number of records in file
1260 C=1 ' change flag
1270 GOSUB 1770 'cs
1280 PRINT F$
1290 PRINT"Define file structure; enter field name and type:
1300 PRINT"(to finish, enter 'stop')"
1310 FOR I=1 TO 15*FT
1320 PRINT
1330 PRINT"Name (4 char) of field ";:PRINT USING"##";I;
1340 INPUT T$
1350 IF T$="" THEN GOTO 1330
1360 IF T$="stop" THEN 1500
1370 INPUT"Field type (a or n) ";T1$
1380 IF T1$="" THEN T1$="a"
1390 IF T1$<>"a" THEN GOTO 1410
1400 GOTO 1450
1410 IF T1$<>"n" THEN GOTO 1430
1420 GOTO 1450
1430 PRINT"Type must be 'a' or 'n'
1440 GOTO 1370
1450 T$=T$+" "
1460 T$=LEFT$(T$,4) ' chop down to 4 char
1470 T$=T$+","+T1$
1480 N$(I)=T$:C(I)=1
1490 NEXT I
1500 NC=I-1
1510 N$(I)="stop0" ' end cue for many routines
1520 GOSUB 1770 'cs5
1530 PRINT"Structure definition complete."
1540 PRINT: PRINT"Name: "F$; TAB(20); "Type: "FT
1550 PRINT:PRINT"Fields are:"
1560 PRINT
1570 FOR I=1 TO NC
1580 IF LEFT$(N$(I),4)="stop" THEN GOTO 1630
1590 PRINT USING"##"; I;
1600 PRINT ". "; LEFT$(N$(I),4); " "; RIGHT$(N$(I),1)
1610 NEXT I
1620 '
FINISH
1630 PRINT
1640 INPUT"Do you approve? (y/n) ", A$
1650 IF A$="" THEN A$="y"
1660 IF A$<>"y" THEN CLOSE: GOTO 1060
1670 CHAIN DD$(1)+"DEDIT",1000
1680 '
UCV
1690 Y$=""
1700 FOR J=1 TO LEN(X$)
1710 Y$=Y$+" "
1720 X=ASC(MID$(X$,J, 1))
1730 IF 96<X AND X<123 THEN MID$(Y$,J,1)=CHR$(X-32): GOTO 1750
1740 MID$(Y$,J,1)=MID$(X$,J,1)
1750 NEXT J
1760 RETURN
1770 '
CLEAR SCREEN (TERM DEP)
1780 PRINT CHR$(12);
1790 RETURN
1800 '
OPEN UP FILES SUB
GET NAME
1810 F$=""
1820 C=0 ' clear change flag
1830 PRINT: PRINT TAB(13);: INPUT"Name of the file you want to open"; F$
1840 IF F$="" THEN 1830
1850 X$=F$
1860 GOSUB 1680 ' UCverter
1870 F$=Y$ ' make UC
1880 '
OPEN UP FILES FOR REAL
1890 OPEN "R",1,DD$(3)+F$+".D"+FT$
1900 FIELD #1,128 AS R$
1910 OPEN "R",2,DD$(4)+F$+".DD"+FT$
1920 FIELD #2, 128 AS S$
1930 RETURN
1940 '
1950 '
ERROR HANDLING ROUTINES
1960 IF ERR=53 AND ERL=1200 THEN RESUME 1210
1970 IF ERR=64 AND ERL=1890 THEN PRINT"*** Bad file name!":CLOSE:RESUME 1190
1980 IF ERR=61 AND (ERL=1890 OR ERL=1910) THEN CLOSE:RESUME 1190
1990 ON ERROR GOTO 0
