IMD 1.16: 31/05/2007 20:08:40 FOGCPM.119 --FOGCPM119DCFORM ASCF DCHESHIRASCE DCREATE ASCDEDIT ASC !"#$%&'(DEDIT ASCL)*+,-./012-07-00 86 DGET ASC$34567DGET BAS/89:;<=DIMS ASCM>?@ABCDEFGDLABELS ASC,HIJKLMDLETTERSASC/NOPQRSDNADIN ASCTUVWDPUT ASC"XYZ[\DSORT ASCj]^_`abcdefghijDSTAT ASC9klmnopqrDUNFLAG BAS!stuvwSTRIP ASC xyREAD-ME 103(z{|}~DINSTALLDOCDINSTALLDOCDINSTALLDOCl-CPM119 DOCThis is the disk name. 1000 DEFINT A-Z 1010 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$ 1020 DIM SQ(31),L$(6) 1030 PRINT CHR$(12);:FOR I=1 TO 10:NEXT 'TERM DEP 1040 T1$="1234567890"' 1050 PRINT"DCFORM March 20, 1982 1055 ' by Dan Dugan -- public domain 1060 PRINT"Design your file format on paper first, using forms provided. 1070 PRINT"To change you have to re-enter all data under same file name. 1080 PRINT:PRINT"Position the paper so the printhead is at the upper left corner of the paper. 1090 PRINT"Set the TOF switch. 1100 PRINT:PRINT"Would you like the program to type you a blank form for 1110 PRINT"designing a 24 x 80 screen? (n/y) "; 1120 A$=INPUT$(1):IF A$=CHR$(13) THEN A$="n" 1130 PRINT A$:IF A$="n" THEN 1450 'next form 1140 IF A$="y" THEN 1160 1150 GOTO 1100 1160 ' TYPE SCREEN FORM 1170 ' SET PRINTER 1180 LPRINT CHR$(27);CHR$(31);CHR$(12); ' 11/in 1190 LPRINT CHR$(27);CHR$(30);CHR$(6); ' vert spc 1200 LPRINT CHR$(27);CHR$(137);CHR$(133); ' margin 5 1210 LPRINT CHR$(27);"9";CHR$(13); ' set margin & CR 1220 LPRINT:LPRINT:LPRINT"DIMS CFORM screen design form for file "F$; 1230 LPRINT TAB(48)"Format name:"TAB(67)"Date: 1240 LPRINT:LPRINT SPC(3); 1250 FOR I=1 TO 8 1260 LPRINT SPC(8);STR$(I); 1270 NEXT 1280 LPRINT:LPRINT SPC(3); 1290 T$="1234567890" 1300 FOR I=1 TO 8 1310 LPRINT T$; 1320 NEXT 1330 LPRINT 1340 T$="=========+" 1350 FOR I=1 TO 24 1360 LPRINT USING"## ";I 1370 LPRINT SPC(3); 1380 FOR J=1 TO 8 1390 LPRINT T$; 1400 NEXT 1410 LPRINT 1420 NEXT 1430 LPRINT:LPRINT"(This form is typed 11/in, HMI = 9) 1440 LPRINT CHR$(12) ' FF 1450 PRINT:PRINT "Would you like the program to type you a format specification form? (n/y) "; 1460 A$=INPUT$(1):IF A$=CHR$(13) THEN A$="n" 1470 PRINT A$:IF A$="n" THEN GOTO 2470 ' entry of data 1480 IF A$="y" THEN 1890 1490 GOTO 1450 1500 ' DESCRIPTION OF VARIABLES GENERAL STUFF 1510 DATA"Format file name", FO$ 1520 DATA"Author, date", FFD$ 1530 DATA"Top Margin lines", TM, LTM 1540 DATA"Left Margin spaces", (na), LLM 1550 DATA Width, SW, LW 1560 DATA"Records/screen or page", RS, RP 1570 DATA"Conditional page line", (na), LLP 1580 DATA"120ths of inch per space (10=12/in)", HMI 1590 DATA"48ths of inch per line (8=6/in)", VMI 1600 DATA"(NOT IMPLEMENTED YET) Field separator chars. (use ,'s, 0 at end)",FSC$ 1610 DATA"Screen heading line 1, space at end actuates page no.",HL1$ 1620 DATA"Screen heading line 2", HL2$ 1630 DATA"Screen heading line 3", HL3$ 1640 DATA"Printer heading line 1, ditto page no.",LHL1$ 1650 DATA"Printer heading line 2", LHL2$ 1660 DATA"Printer heading line 3", LHL3$ 1670 DATA"Blank lines after heading (0 or number)", HB, LHB 1680 ' RECORD NUMBER 1690 DATA"Record no. mode (0=off, 1=on)", RM, LRM 1700 DATA"Rec. no. Location Line", RLL, LRLL 1710 DATA"Rec. no. Location Column", RLC, LRLC 1720 DATA"No. blank lines after number", RNB, LRNB 1730 ' SEQUENCE OF FIELDS 1740 DATA"Field no.'s in seq, 0 at end", SQ() 1750 DATA"no. blank lines after record", EB, LEB 1760 ' EACH FIELD 1770 DATA"Field name mode (0/1/2)", FM(), LFM() 1780 DATA"Screen field name (mode 2)", F2$() 1790 DATA"Printer field name (mode 2)", LF2$() 1800 DATA"Name Location Line", NLL(), LNLL() 1810 DATA"Name Location Column", NLC(), LNLC() 1820 DATA"No. blank lines after name", FMB(), LFMB() 1830 DATA"Data Location Line", DLL(), LDLL() 1840 DATA"Data Location Column", DLC(), LDLC() 1850 DATA"Screen numeric PRINT USING string", PU$() 1860 DATA"Printer numeric PRINT USING string", LPU$() 1870 DATA"Field length (0 for random, -1 to skip)", FL(), LFL() 1880 DATA"no. blank lines after field", FB(), LFB() 1890 ' PRINT BLANK FORM 1900 ' SET PRINTER 1910 LPRINT CHR$(27);CHR$(31);CHR$(11); ' 12/in 1920 LPRINT CHR$(27);CHR$(30);CHR$(137); 'vert 6/in 1930 LPRINT CHR$(27);CHR$(137);CHR$(135); 'margin 6 1940 LPRINT CHR$(27);"9";CHR$(13); 'set, CR 1950 T$=STRING$(20,95) 1960 T2$=STRING$(3,95) 1970 RESTORE 1980 GOTO 2080 1990 ' SUBROUTINES 2000 READ A$,B$:RETURN 2010 READ A$,B$,C$:RETURN 2020 LPRINT A$ TAB(40) B$ TAB(46) T2$:RETURN 2030 LPRINT A$ TAB(40) B$ TAB(46) T2$ TAB(53) C$ TAB(61) T2$:RETURN 2040 LPRINT A$ TAB(40) B$ TAB(46) T$:LPRINT:RETURN 2050 GOSUB 2000:GOSUB 2020:RETURN 2060 GOSUB 2010:GOSUB 2030:RETURN 2070 ' BEGIN PRINTING 2080 LPRINT:LPRINT:LPRINT:LPRINT"CFORM for file "F$:LPRINT 2090 LPRINT"DESCRIPTION"TAB(40)"SCREEN"TAB(53)"PRINTER":LPRINT 2100 FOR I=1 TO 2 2110 GOSUB 2000:GOSUB 2040 2120 NEXT 2130 FOR I=1 TO 5:GOSUB 2060:NEXT 2140 LPRINT 2150 LPRINT"The next two items refer to the Diablo only: 2160 FOR I=1 TO 2 2170 GOSUB 2000:LPRINT A$ TAB(53) B$ TAB(61) CHR$(95);CHR$(95);CHR$(95) 2180 NEXT 2190 LPRINT 2200 GOSUB 2000:GOSUB 2040 2210 FOR I=1 TO 3 2220 GOSUB 2000:LPRINT A$+" ("+B$+")": FOR J=1 TO 8:LPRINT T1$;:NEXT:LPRINT:LPRINT:LPRINT 2230 NEXT 2240 FOR I=1 TO 3 2250 GOSUB 2000:LPRINT A$+" ("+B$+")": FOR J=1 TO 9:LPRINT T1$;:NEXT:LPRINT:LPRINT:LPRINT 2260 NEXT 2270 GOSUB 2060:LPRINT 2280 LPRINT TAB(5)"(If Location Line number is 0, then output will scroll. 2290 LPRINT TAB(5)"Use a 'blank line' for CR/LF after last field on line. 2300 LPRINT:LPRINT"Specifications for each record:":LPRINT 2310 FOR I=1 TO 4:GOSUB 2060:NEXT 2320 LPRINT:GOSUB 2000:GOSUB 2040 2330 GOSUB 2060 2340 LPRINT:LPRINT "Specifications for each field in record (fill in names in seq.):" 2350 FOR I=1 TO NC 2360 RESTORE 1760:LPRINT CHR$(12) 2370 LPRINT:LPRINT STRING$(70,"*"):LPRINT 2380 LPRINT"Format instructions for (field name)":LPRINT 2390 GOSUB 2060 2400 LPRINT:FOR J=1 TO 2:GOSUB 2000:GOSUB 2040:NEXT 2410 FOR J=1 TO 5:GOSUB 2060:NEXT 2420 IF I=1 THEN LPRINT:LPRINT"(PRINT USING strings follow MBASIC rules)" 2430 LPRINT:FOR J=1 TO 2:GOSUB 2000:GOSUB 2040:NEXT 2440 FOR J=1 TO 2:GOSUB 2060:NEXT 2450 NEXT 2460 GOTO 1450 2470 ' ENTER DATA 2480 PRINT:PRINT"Do you want to enter data now? (y/n) "; 2490 A$=INPUT$(1):IF A$=CHR$(13) THEN A$="y" 2500 PRINT A$:IF A$="n" THEN 3060 2510 IF A$<>"y" THEN 2480 2520 PRINT:PRINT"ENTER DATA FOR NEW (OR REVISED) FORMAT":PRINT 2530 RESTORE 2540 GOTO 2620 2550 ' subroutines 2560 GOSUB 2000:PRINT A$ TAB(40) B$ TAB(46);:RETURN 'two var 2570 GOSUB 2010:PRINT A$ TAB(40) B$ TAB(46);:RETURN ' with next line makes 3 2580 PRINT TAB(53) C$ TAB(59);:RETURN 2590 GOSUB 2560:LINE INPUT"? ";D$:PRINT#3,D$:RETURN 2600 GOSUB 2570:INPUT;D:GOSUB 2580:INPUT E:PRINT#3,D;E:RETURN 2610 ' BEGIN ENTRY 2620 GOSUB 2560:INPUT D$ ' file name 2630 X$=D$:GOSUB 3170:D$=Y$ ' UCV 2640 OPEN"O",3,DD$(5)+D$+".DFO" 2650 PRINT#3,D$ 2660 GOSUB 2590 'date read back as LINE 2670 FOR I=1 TO 5 2680 GOSUB 2600 2690 NEXT 2700 FOR I=1 TO 2 2710 GOSUB 2000:PRINT A$ TAB(53) B$ TAB(59);:INPUT D 2720 PRINT#3,D 2730 NEXT 2740 GOSUB 2560:LINE INPUT"? ";D$:IF D$="" THEN D$="0" 2750 PRINT#3,D$ 2760 FOR I=1 TO 6 ' heading lines 2770 GOSUB 2000:PRINT A$+" ("+B$+")": FOR J=1 TO 7:PRINT T1$;:NEXT:PRINT"123456789" 2780 LINE INPUT D$:L$(I)=D$: IF I>3 THEN IF D$=";" THEN D$=L$(I-3): PRINT CHR$(13);CHR$(11);D$ 2790 PRINT#3,D$ 2800 NEXT 2810 GOSUB 2600:PRINT 2820 FOR I=1 TO 4:GOSUB 2600:NEXT 2830 GOSUB 2000 ' dummy read 2840 PRINT:PRINT"As many fields as you want may be shown/printed in any order: 2850 PRINT"Enter number of first field to be printed" 2860 INPUT"(enter 0 as 'next' after last field) ";D 2870 PRINT#3,D;:K=1:SQ(K)=D:IF D=0 THEN 2910 ' K saves # fields for below 2880 INPUT"number of next field to be printed ";D 2890 IF D=0 THEN PRINT#3,D:GOTO 2910 ' includes CR 2900 K=K+1:SQ(K)=D:PRINT#3,D;:GOTO 2880 2910 PRINT:GOSUB 2600 2920 FOR I=1 TO K 2930 RESTORE 1760 2940 PRINT:PRINT"Format instructions for field"SQ(I)"- "N$(SQ(I)) 2950 GOSUB 2600 ' mode in D & E 2960 IF D<>2 THEN GOSUB 2000:PRINT#3,:GOTO 2980 2970 GOSUB 2590 2980 IF E<>2 THEN GOSUB 2000:PRINT#3,:GOTO 3000 2990 GOSUB 2590 3000 FOR J=1 TO 5:GOSUB 2600:NEXT 3010 FOR J=1 TO 2:GOSUB 2590:NEXT 3020 FOR J=1 TO 2:GOSUB 2600:NEXT 3030 NEXT 3040 ' FINISH 3050 CLOSE 3:PRINT"Recorded. 3060 PRINT"Do you want to run CFORM again? (n/y) "; 3070 A$=INPUT$(1):IF A$=CHR$(13) THEN A$="n" 3080 PRINT A$:IF A$="n" THEN 3110 3090 IF A$="y" THEN 1100 3100 GOTO 3060 3110 PRINT"Wait while re-loading DEDIT program. 3120 LPRINT CHR$(27);CHR$(31);CHR$(11); ' 12/in 3130 LPRINT CHR$(27);CHR$(30);CHR$(137); ' vert 6/in 3140 LPRINT CHR$(27);CHR$(137);CHR$(133); ' margin 5 3150 LPRINT CHR$(27);"9";CHR$(13); ' set marg & CR 3160 CHAIN DD$(1)+"DEDIT",1000 3170 ' (SUB) UCV 3180 Y$="" 3190 FOR K=1 TO LEN(X$) 3200 Y$=Y$+" " 3210 X=ASC(MID$(X$,K,1)) 3220 IF 962 THEN GOSUB 2000:PRINT#3,:GOTO 2980 2970 GOSUB 2590 2980 IF E<>2 THEN GOSUB 2000:PRINT#3,:GOTO 3000 2990 GOSUB 2590 3000 FOR J=1 TO 5:GOSUB 2600:NEXT 3010 FOR J=1 TO 2:GOSUB 2590:NEXT 3020 FOR J=1 TO 2:GOSUB 26010 ' ******************************** 20 ' * NOTICE * 30 ' * COPYRIGHT (c) 1983 DAN DUGAN * 40 ' ******************************** 50 ' STANDALONE ENTRY 60 PRINT:PRINT "CHESHIR 1.03 November 2, 1983 70 PRINT:PRINT "This program prints 4-up Cheshire labels from a sequential data file. 80 PRINT 90 DEFINT A-Z 100 WIDTH LPRINT 255 105 I=0 110 ' OPEN SOURCE FILE 120 PRINT:INPUT"Name of source file";X$ 130 IF X$="" THEN STOP 140 GOSUB 2430:F2$=Y$ 'ucv 150 IF MID$(F2$,2,1)=":" THEN 170 160 F2$=DD$(5)+F2$ 170 ' TEST FOR EXISTENCE 180 ON ERROR GOTO 210 190 OPEN"I",3,F2$ 200 ON ERROR GOTO 0:GOTO 260 'ok 210 ' LOCAL ERROR TRAP 220 CLOSE 3 230 IF ERR=53 THEN CLOSE 3:PRINT"File not found":RESUME 110 240 IF ERR=64 THEN PRINT"Bad file name, try again.":RESUME 110 250 ON ERROR GOTO 0 260 ' SHOW AND ASK 270 PRINT:PRINT"Here's the first line of "F2$". 280 LINE INPUT#3,T$ 290 PRINT:PRINT T$ 300 CLOSE 3:OPEN"I",3,F2$ 310 PRINT: INPUT"Please enter the total number of fields in the source file: ",NC 320 IF NC=0 THEN CLOSE:STOP 330 DIM B$(NC),L$(4,NC) 340 DIMS=0 'switch for sequential file 350 GOTO 1090 1000 ' DIMS ENTRY 1010 GOSUB 2130 'cs 1020 PRINT:PRINT TAB(16);"CHESHIRE 1.03 October 26, 1983 1030 PRINT"Prints Cheshire labels 4-up 1040 ' by Dan Dugan -- public domain 1050 PRINT 1060 DEFINT A-Z 1070 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$ 1080 DIMS=1 'switch for dims data file 1090 ' INITIALIZATION FOR BOTH MODES 1100 DIM COLPOS(4) 1110 ' COLUMN PRINT POSITIONS 1120 COLPOS(1)=2:COLPOS(2)=43:COLPOS(3)=84:COLPOS(4)=124 1130 ' MAXIMUM FIELD LENGTH 1140 MAXLEN=34 1145 DONE=0 'EOF flag 1150 ' SET-UP LABELS 1160 PRINT:PRINT"Please indicate the form that this list is in: 1170 PRINT:PRINT" 1. Short form, (NAME, N2, ADDR, C-ST, ZIP) 1180 PRINT" 2. Medium form, (LNAM, FNAM, N2, ADDR, C-ST, ZIP) 1190 PRINT" 3. Long form, (LNAM, FNAM, TITL, ORG, ADDR etc.) 1200 PRINT:PRINT"Enter 1, 2 or 3: "; 1210 A$=INPUT$(1): IF A$=CHR$(13) THEN A$="1" 1220 PRINT A$: A=VAL(A$): IF A=0 THEN 1950 1230 IF A<1 OR A>3 THEN 1200 1240 FORM=A-1 1242 PRINT:PRINT"Set up printer:" 1244 PRINT"Print head on perforation. 1245 PRINT"Hit return when ready to print":A$=INPUT$(1) 1250 ' RECORD WORK LOOP 1260 LC=0 ' count 1270 COL=0 ' print column 1280 ' 1290 IF DIMS THEN FOR I=T1 TO T2 ' <==== FOR 1300 COL=COL+1:IF COL>4 THEN COL=1 1302 IF COL=1 THEN 1304 ELSE 1310 1304 FOR J=1 TO 4 1305 FOR K=1 TO 4 1306 L$(J,K)="" 1307 NEXT 1308 NEXT 1310 IF DIMS THEN GOSUB 2280 ELSE GOSUB 2520 ' get rec 1320 IF DIMS=0 THEN 1670 1330 IF ASC(T$)=0 THEN PRINT"0";:GOTO 1920 1340 PRINT"+"; 1350 T1$=T$ ' save it 1360 IF SKIPPARSE=1 THEN 1380 1370 GOSUB 1990 ' parse record string 1380 IF SEARCH=0 THEN 1670 1390 ' SEARCH 1400 IF SEARCH<>2 THEN 1450 1410 ' FIND 1420 IF INSTR(T$,SEARCHWORD$(0))=0 THEN 1920 1430 GOSUB 1990 ' parse 1440 GOTO 1670 1450 ' FIELD SEARCH 1460 J=0 ' check for skips first 1470 IF SKIPWORD$(J)="" THEN 1550 ' try search then 1480 IF LOOKFIELD(J)<>0 THEN 1520 ' look in field 1490 IF INSTR(T1$,SKIPWORD$(J))<>0 THEN 1920 ' whole rec search - skip it 1500 J=J+1 1510 GOTO 1470 1520 IF INSTR(B$(LOOKFIELD(J)),SKIPWORD$(J))<>0 THEN 1920 ' field compare - skip 1530 J=J+1 1540 GOTO 1470 1550 IF SEARCHWORD$(0)="" THEN 1650 ' don't care so print it 1560 J=0: GOTO 1580 ' now search 1570 IF SEARCHWORD$(J)="" THEN 1920 ' hesitate no longer 1580 IF SEARCHFIELD(J)<>0 THEN 1620 ' field 1590 IF INSTR(T1$,SEARCHWORD$(J))<>0 THEN 1650 ' found it 1600 J=J+1 1610 GOTO 1570 1620 IF INSTR(B$(SEARCHFIELD(J)),SEARCHWORD$(J))<>0 THEN 1650 1630 J=J+1 1640 GOTO 1570 1650 ' GET READY TO DO IT 1660 IF SKIPPARSE=1 THEN GOSUB 1990 ' parse 1670 ' PAUSE CONTROLS (TERM DEP IF UPPERCASE ONLY) 1680 GOSUB 2080:IF DIMS=0 THEN 1770 ' exit returns A 1690 IF A=122 THEN 1770 ' z means go on 1700 PRINT I;B$(1);TAB(14);"Ready (SPACE/z/r/n/ESC) >"; 1710 A$=INPUT$(1):A=ASC(A$): IF A=27 THEN IF DIMS THEN CLOSE 3:GOTO 1950 ELSE GOTO 50 1720 PRINT A$:IF A=13 OR A=32 OR A=122 THEN 1770 1730 IF A=114 THEN I=IPREV:GOTO 1310 ' r 1740 IF A=110 THEN 1750 ELSE 1670 ' n or loop 1750 INPUT"Enter number of desired record: ";I:GOTO 1310 1760 GOSUB 2080 ' exit 1770 ' STORE LABEL IN 4-UP ARRAY 1780 IF DIMS THEN IPREV=I ELSE I=I+1 1790 IF FORM=1 THEN GOSUB 2360 ' reformat medium to short form 1800 IF FORM=2 THEN GOSUB 2160 ' reformat long to short form 1810 PRINT "("I")" 1820 LIN=1 1830 FOR J=1 TO 3 1840 IF B$(J)="" THEN 1880 1850 IF LEN(B$(J))>MAXLEN THEN B$(J)=LEFT$(B$(J),MAXLEN) 1860 L$(COL,LIN)=B$(J) 1870 LIN=LIN+1 1880 NEXT J 1890 X=LEN(B$(5))+1 1900 IF LEN(B$(4))>MAXLEN-X THEN B$(4)=LEFT$(B$(4),MAXLEN-X) 1910 L$(COL,LIN)=B$(4)+" "+B$(5) 1920 GOSUB 2080 ' check exit 1930 IF COL=4 THEN GOSUB 2900: IF DONE THEN IF DIMS GOTO 1950 ELSE STOP 'print labels 1940 IF DIMS THEN NEXT I ELSE GOTO 1300 ' END OF RECORD WORK LOOP 1942 FOR J=COL+1 TO 4 1944 FOR K=1 TO 4 1945 L$(J,K)="" 1946 NEXT 1947 NEXT 1948 GOSUB 2900 1950 ' GO HOME TO DIMS 1970 PRINT:PRINT:PRINT TAB(17)"Re-loading DEDIT. 1980 CHAIN DD$(1)+"DEDIT",1000 1990 ' (SUB) PARSE STRING 2000 K=0 2010 M=INSTR(T$,CHR$(126)) ' delimiter 2020 IF M=0 THEN RETURN 2030 K=K+1 2040 B$(K)="" 2050 B$(K)=MID$(T$,1,M-1) 2060 T$=MID$(T$,M+1) 2070 GOTO 2010 2080 ' (SUB) EXIT TEST (TERM DEP) 2090 X$=INKEY$ 'use ESC to escape printing 2100 IF X$<>"" THEN A=ASC(X$) 2110 IF A=27 THEN CLOSE 3:IF DIMS GOTO 1970 ELSE GOTO 110 2120 RETURN 2130 ' (SUB) CLEAR SCREEN (TERM DEP) 2140 PRINT CHR$(26); 2150 RETURN 2160 ' (SUB) LONG FORM LABEL RE-FORMAT 2170 IF B$(1)="" AND B$(2)="" OR B$(3)="" THEN 2260 2180 IF B$(2)="" THEN B$(1)=B$(1)+", "+B$(3): GOTO 2200 2190 B$(1)=B$(2)+" "+B$(1)+", "+B$(3) 2200 IF LEN(B$(1))>39 THEN B$(1)=LEFT$(B$(1),39) 2210 B$(2)=B$(4) 2220 B$(3)=B$(5) 2230 B$(4)=B$(6) 2240 B$(5)=B$(7) 2250 RETURN 2260 IF B$(2)+B$(1)="" THEN B$(1)=B$(3) ELSE IF B$(2)="" THEN B$(1)=B$(1) ELSE B$(1)=B$(2)+" "+B$(1) 2270 GOTO 2200 2280 ' (SUB) GET DIMS RECORD "I" IN T$ 2290 T$="" ' necessary! 2300 ON FT GOTO 2330,2310 2310 GET#1,FT*I+2 ' latter half 2320 T$=LEFT$(R$,127) 2330 GET#1,FT*I+1 ' whole or first half 2340 T$=R$+T$ 2350 RETURN 2360 ' (SUB) MEDIUM FORM RE-FORMAT 2370 IF B$(2)="" THEN 2380 ELSE B$(1)=B$(2)+" "+B$(1) 2380 B$(2)=B$(3) 2390 B$(3)=B$(4) 2400 B$(4)=B$(5) 2410 B$(5)=B$(6) 2420 RETURN 2430 ' (SUB) UCV 2440 Y$="" 2450 FOR K=1 TO LEN(X$) 2460 Y$=Y$+CHR$(32) 2470 X=ASC(MID$(X$,K,1)) 2480 IF 96NC THEN 2600 ELSE 2610 2600 PRINT"Input file line"INREC"defective."CHR$(7) 2610 FOR K=1 TO J 'recover quotes encoded by DPUT.BAS 2630 QUOTE=INSTR(B$(K),CHR$(126)) 2640 IF QUOTE THEN MID$(B$(K),QUOTE,1)=CHR$(34):GOTO 2630 2660 NEXT 2670 RETURN 2680 ' (SUB) PARSE COMMA-DELIM. RECORD T$ -> B$ ARRAY 2690 ' returns J = number of fields found 2700 FOR J=1 TO NC:B$(J)="":NEXT 2710 J=0 2720 ' process loop 2730 J=J+1:IF J=NC THEN 2830 2740 X=INSTR(T$,CHR$(44)) 'comma 2750 IF X=0 THEN 2830 'must be last field 2760 Y=INSTR(T$,CHR$(34)) 'quote 2770 IF Y=0 OR ( Y<>0 AND X126 THEN LPRINT TAB(X);:GOTO 3030 ' Diablo abs. tab limit 3020 LPRINT CHR$(27);CHR$(137);CHR$(X+128); 3030 RETURN 3010 IF X>126 THEN LPRINT TAB(X);:GOTO 3030 ' Dast field 2760 Y=INSTR(T$,CHR$(34)) 'quote 2770 IF Y=0 OR ( Y<>0 AND X2 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"" THEN PRINT CHR$(7); 1180 PRINT CHR$(13); 1190 IF RS THEN X=24:Y=1:GOSUB 6700 1200 PRINT SPC(79); CHR$(13); 1210 PRINT E$" ";:E$="":PRINT"Edit ";F$;": "; 1212 IF RS THEN LINE INPUT;A$: GOTO 1220 1214 LINE INPUT A$ 1220 IF A$="" THEN 1210 1230 ' PARSE COMMAND 1240 A$=A$+" " 1250 J=0 1260 K=INSTR(A$,CHR$(32)) 1265 IF J=10 THEN 1320 1270 J=J+1 1280 IF K=0 THEN 1320 1290 C$(J)=MID$(A$,1,K-1) 1300 A$=MID$(A$,K+1) 1310 GOTO 1260 1320 C$(J)=CHR$(13) 1330 ' 1340 IF LEFT$(C$(1),3)="rep" THEN J=2: GOSUB 1790: GOTO 2580 1345 ' DEFAULTS 1350 A=0:T=2:T1=1:T2=0:C1=0:SEARCH=0:SKIPPARSE=0:P6=0:P7=0:P9=0:PG=1:LPG=1: FLAG=0:FLAG$="" 1360 ' PROCESS WORD MATRIX 1370 J=0 1380 ' LOOP TO HERE TO CHECK NEXT WORD 1390 J=J+1 1400 GOSUB 1790 ' range 1410 IF C$(J)=CHR$(13) THEN 2580 ' do it 1420 C1$=LEFT$(C$(J),3) 1430 ' FINAL COMMANDS 1440 IF C1$="add" THEN T=1: GOTO 2580 1450 IF C1$="fie" THEN GOSUB 2060:GOTO 1120 1460 IF C1$="ins" THEN T=4: GOTO 1390 ' unfinished 1470 IF C1$="don" THEN T=9: GOTO 2580 1490 IF C1$="ren" THEN T=12: GOTO 2580 ' renumber 1500 IF C1$="for" THEN 2170 1505 IF C1$="bac" THEN T=11:GOTO 2580 1506 IF C1$="pro" THEN 8620 1507 IF C1$="got" THEN T=7:B$(0)=C$(J+1):GOTO 2580 'goto 1510 ' RECIRCULATING COMMANDS 1514 IF C1$="cha" THEN T=3:GOTO 1390 1515 IF C1$="del" THEN T=10:GOTO 1390 1520 IF C1$="lis" THEN T=2:GOTO 1390 1530 IF C1$="fin" THEN 1532 ELSE 1540 1532 J=J+1:SEARCH=2:SKIPPARSE=1 1534 X=INSTR(C$(J),CHR$(95)):IF X THEN Y=LEN(C$(J)):GOTO 1535 ELSE 1538 1535 C$(J)=LEFT$(C$(J),X-1)+" "+RIGHT$(C$(J),Y-X) 1536 GOTO 1534 1538 SEARCHWORD$(0)=C$(J):GOTO 1390 1540 IF C1$="sel" THEN SEARCH=1:GOTO 1390 1550 IF C1$="pri" THEN P9=1:GOTO 1390 1560 IF C1$="cop" THEN P7=1:GOTO 1390 'dims out 1570 IF C1$="wri" THEN P6=1:GOTO 1390 ' not implem. 1580 IF C1$="and" THEN GOTO 1390 1590 IF C1$="pag" THEN PG=VAL(C$(J+1)):LPG=PG: J=J+1: GOTO 1390 1600 IF C1$="mar" THEN LLM=VAL(C$(J+1)): J=J+1: GOTO 1390 1610 IF C1$="fla" THEN GOSUB 8550:GOTO 1390 1620 ' TRANSIENT COMMANDS 1630 X$=C$(J): GOSUB 7070: C$(J)=Y$ ' UCV 1640 ON ERROR GOTO 1740 1650 ' open this way to test 1660 OPEN"I",3,DD$(2)+"D"+C$(J)+".BAS" 1670 ' if it's there, close it and chain 1680 CLOSE 3: T$=C$(J):J=J+1 1690 ' GO CHAIN 1700 GOSUB 1790 1705 IF T2=0 THEN T2=N 1710 IF P9 THEN GOSUB 7160 1720 IF SEARCH=1 THEN GOSUB 7460 1725 PRINT:PRINT TAB(19);"Please wait while transient program loads. 1730 CHAIN DD$(2)+"D"+T$,1000 1740 ' NO CHAIN 1750 IF ERR=53 OR ERR=64 THEN 1770 1760 ON ERROR GOTO 0 1770 CLOSE 3: ON ERROR GOTO 7000: E$=C$(J)+"?": RESUME 1140 1780 ' (SUB) GET RANGE 1790 ' TEST WORD 1800 IF C1 THEN RETURN ' range done flag 1810 C3=VAL(C$(J)) 1820 IF C3>0 THEN 1830 ELSE 1850 1830 IF C3>N THEN C3=N 1840 T1=C3: GOTO 1910 1850 IF C$(J)="from" THEN J=J+1: T2=N:GOTO 1790 1860 IF C$(J)="all" THEN T1=1: T2=N: GOTO 2050 1870 IF C$(J)="."THEN T1=T0: GOTO 1910 1880 IF C$(J)="next"THEN T1=T0+1: GOTO 1910 1890 IF C$(J)="to" THEN GOTO 1910 1900 RETURN 1910 ' LOOK FOR 2nd # 1920 J=J+1:IF C$(J)=CHR$(13) THEN 2030 1930 C3=VAL(C$(J)) 1940 IF C3>0 THEN 1950 ELSE 1980 1950 IF C3>N THEN C3=N 1960 T2=C3: IF T1>T2 THEN SWAP T1,T2 1970 GOTO 2050 1980 IF C$(J)="to" THEN 1920 1990 IF C$(J)="." THEN T2=T0: GOTO 2050 2000 IF C$(J)="next" THEN T2=T0+1: GOTO 2050 2010 IF C$(J)="end" THEN T2=N: GOTO 2050 2020 IF C$(J)="last" THEN T2=N:GOTO 2050 2030 IF T2=0 THEN T2=T1:C1=1 ' if only one number 2040 RETURN 2050 J=J+1:C1=1:RETURN 2060 ' (SUB) HIDE FIELDS 2070 PRINT TAB(24)"Here are the fields in "F$:PRINT 2075 FOR I=1 TO NC:C(I)=1:NEXT ' set all to show 2080 GOSUB 7800 2110 FOR I=1 TO NC 2120 PRINT TAB(27)"Show "LEFT$(N$(I),4)"? (y/n) "; 2130 A$=INPUT$(1):IF A$=CHR$(13) THEN A$="y" 2140 PRINT A$:IF A$="n" THEN C(I)=0 2150 NEXT 2160 RETURN 2170 ' FORMAT COMMAND 2190 IF C$(J+1)="0" THEN 2290 2200 IF C$(J+1)=CHR$(13) THEN 2202 ELSE 2210 2202 ' SHOW AVAILABLE FORMATS 2203 PRINT:PRINT"Here are the  available formats:":PRINT 2204 WIDTH 70:FILES DD$(5)+"*.DFO":WIDTH 255:PRINT:PRINT 2205 INPUT"Enter the desired format name or just RETURN: ",X$ 2206 IF X$="" THEN 2290 ELSE GOSUB 7070:GOTO 2220 2210 J=J+1:X$=C$(J):GOSUB 7070 'UCV 2220 FO$=Y$ 2230 ON ERROR GOTO 2260 2240 OPEN"I",3,DD$(5)+FO$+".DFO" 2250 ON ERROR GOTO 7000:GOTO 2330 ' do this if OK 2260 IF ERR=64 OR ERR=53 THEN 2280 2270 ON ERROR GOTO 0 2280 ON ERROR GOTO 7000:E$="Format "+FO$+" not available on this disk.": CLOSE 3:RESUME 1140 2290 ' LOAD FORMAT 0 2300 FO$="0" 2310 GOSUB 7870 'do it 2320 GOTO 1120 2330 ' LOAD FORMAT FILE 2335 ON ERROR GOTO 2572 2340 INPUT#3,FO$ ' filename 2350 LINE INPUT #3,A$ 'dummy for date$ 2360 INPUT#3,TM,LTM,LM,LLM,SW,LW,RS,RP,LS,LLP,HMI,VMI 2370 LINE INPUT#3,A$ 'dummy for FSC$ not implemented yet 2380 LINE INPUT#3,HL1$:LINE INPUT#3,HL2$:LINE INPUT #3,HL3$ 2390 LINE INPUT#3,LHL1$:LINE INPUT#3,LHL2$:LINE INPUT#3,LHL3$ 2400 INPUT#3,HB,LHB,RM,LRM,RLL,LRLL,RLC,LRLC,RNB,LRNB 2410 I=0  2420 I=I+1:IF I>NC+1 THEN 2440 2425 INPUT#3,SQ(I):IF SQ(I)=0 THEN 2440 2427 IF SQ(I)>NC THEN SQ(I)=NC 'limiter 2430 GOTO 2420 2440 INPUT#3,EB,LEB 2450 FOR J=1 TO NC 2460 IF EOF(3) THEN 2570 2470 K=SQ(J) 2480 INPUT#3,FM(K),LFM(K) 2490 LINE INPUT#3,F2$(K):LINE INPUT#3,LF2$(K) 2500 INPUT#3,NLL(K),LNLL(K),NLC(K),LNLC(K),FMB(K),LFMB(K) 2510 INPUT#3,DLL(K),LDLL(K),DLC(K),LDLC(K) 2520 LINE INPUT#3,PU$(K):LINE INPUT#3,LPU$(K) 2530 INPUT #3,FL(K),LFL(K),FB(K),LFB(K) 2540 X=LEN(PU$(K)):IF X THEN FL(K)=X 2550 NEXT 2555 ON ERROR GOTO 7000 2570 CLOSE 3:E$="Format "+FO$+" loaded.":GOTO 1140 2572 ON ERROR GOTO 7000:RESUME 2575 2575 CLOSE 3:E$="Error in loading format.":GOTO 1140 2580 ' EXECUTIVE BRANCH 2590 ' JUNK TRAP 2600 IF P9 AND T=1 THEN E$="Not allowed, try again.":GOTO 1140 2610 IF T2=0 THEN T2=N ' fix 2620 IF N=0 AND NOT (T=1 OR T=9) THEN E$="File is empty.": GOTO 1140 2630 ' SET-UPS 2640 IF P9 THEN GOSUB 7160 2650 IF P7 THEN GOSUB 8020 2660 IF E$<>"" THEN GOTO 1140 2670 IF SEARCH=1 THEN GOSUB 7460 2690 ' 1 2 3 4 5 6 7 8 9 10 11 12 2700 ON T GOTO 2730,2900,2770,1120,1120,1120,2720,1120,2720,2900,2720,2720 2710 GOTO 1120 ' junk trap 2720 ' EXIT TO DIMS 2725 PRINT:PRINT TAB(27)"Waiting while loading DIMS.":CHAIN DD$(1)+"DIMS",1000 2730 ' ADD COMMAND 2740 N1=0 ' start 2750 I=N+1 2760 GOTO 4000 2770 ' SET-UP CHANGE 2780 IF T1=T2 THEN 2810 2790 PRINT:PRINT TAB(20);"Select fields to change? (n/y) ";: A$=INPUT$(1):IF A$=CHR$(13) THEN A$="n" 2800 PRINT A$: IF A$="y" THEN 2830 2810 FOR I=1 TO NC: IF C(I)<>0 THEN C(I)=2 2820 NEXT I: GOTO 2900 ' all 2's 2830 PRINT 2840 FOR I=1 TO NC 2850 IF C(I)=0 THEN 2890 2860 IF C(I)=2 THEN C(I)=1 2870 PRINT TAB(25);"Change "LEFT$(N$(I),4)"? (y/n) ";: A$=INPUT$(1):IF A$=CHR$(13) THEN A$="y" 2880 PRINT A$: IF A$="y" THEN C(I)=2 2890 NEXT I 2900 ' RECORD WORK LOOP 2910 C0=0:RC=0:LRC=0'first time 2930 FOR I=T1 TO T2 ' <-------- FOR 2940 GOSUB 6200 ' get rec 2950 IF ASC(T$)=0 THEN PRINT"0";:GOTO 5770 2960 PRINT"+"; 2970 T1$=T$ ' save it 2980 IF SKIPPARSE THEN 3010 2990 GOSUB 6500 ' parse record string 3000 IF T=0 THEN 4000 3010 IF SEARCH=0 THEN 3310 3020 ' SEARCH 3030 IF SEARCH<>2 THEN 3100 3035 ' FIND 3040 IF INSTR(T1$,SEARCHWORD$(0))=0 THEN 5770 3060 IF P9=0 THEN PRINT CHR$(7); ' found it 3070 GOSUB 6500 ' parse 3080 GOTO 3310 3090 ' LOOK FOR SKIPS 3100 J=0 3110 IF SKIPWORD$(J)="" THEN 3190 ' try search then 3120 IF LOOKFIELD(J) THEN 3160 ' look in field 3130 IF INSTR(T1$,SKIPWORD$(J)) THEN 5770 ' whole rec search 3140 J=J+1 3150 GOTO 3110 3160 IF INSTR(B$(LOOKFIELD(J)),SKIPWORD$(J)) THEN 5770 ' field compare 3165 IF B$(LOOKFIELD(J))="" AND SKIPWORD$(J)="_" THEN 5770 'blank field 3170 J=J+1 3180 GOTO 3110 3185 ' SEARCH 3190 IF SEARCHWORD$(0)="" THEN 3290 ' only when skips are all you want 3200 J=0: GOTO 3220 ' now search 3210 IF SEARCHWORD$(J)="" THEN 5770 ' hesitate no longer 3220 IF SEARCHFIELD(J) THEN 3260 ' field 3230 IF INSTR(T1$,SEARCHWORD$(J)) THEN 3290 ' unparsed search 3240 J=J+1 3250 GOTO 3210 3260 IF INSTR(B$(SEARCHFIELD(J)),SEARCHWORD$(J)) THEN 3290 3265 IF B$(SEARCHFIELD(J))="" AND SEARCHWORD$(J)="_" THEN 3290 3270 J=J+1 3280 GOTO 3210 3290 IF P9=0 THEN PRINT CHR$(7); 'TERM DEP 3300 IF SKIPPARSE THEN GOSUB 6500 ' parse 3310 ' PAUSE 3320 IF C0=0 OR T=3 OR T=10 OR P7 OR P9 THEN 4000 ' when not to pause, C0 is for first time 3330 GOSUB 6100 ' exit 3340 IF A=122 THEN 4000 'z 3350 IF RS THEN IF RC=RS THEN X=24:Y=1:GOSUB 6700 3360 PRINT I"Ready>"; 3370 A$=INPUT$(1):A=ASC(A$) 3372 IF A=27 THEN IF (P6 OR P7) THEN GOSUB 8410:GOTO 1120 ELSE GOTO 1120 3375 PRINT A$:IF A=104 THEN 3400 ELSE 4000 'h 3400 ' PAUSE HELP 3410 PRINT:PRINT TAB(5)"The program is waiting for just one keystroke; 3420 PRINT:PRINT TAB(10)"h will print this message, 3430 PRINT TAB(10)"SPACE will show the next record, 3440 PRINT TAB(10)"z will show the  next record and keep going until you SPACE, 3450 PRINT TAB(10)"ESC will quit the sequence you're in and go to edit command level. 3460 PRINT:GOTO 3330 4000 ' ADD, CHA OR SHOW REC I I=rec #, J=seq #, K=field #, L=rec length C0=not first time, C3=backup flag C(K): 0=skip field, 1=norm, 2=change 4010 T0=I 4020 IF P9 AND T<>10 THEN 5040 4030 ' NEW SCREEN? 4040 C0=1 4050 IF RS=0 OR (RC>0 AND RC"" THEN PRINT HL1$; 4110 IF RIGHT$(HL1$,1)=" " THEN PRINT"PAGE"PG:GOTO 4130 4120 PRINT 4130 IF HL2$<>"" THEN PRINT HL2$ 4140 IF HL3$<>"" THEN PRINT HL3$ 4150 X=HB:GOSUB 6730 4160 ' NEW REC - PRINT #? 4170 L=0:RC=RC+1 4180 IF E$<>"" THEN PRINT CHR$(7);:PRINT:PRINT E$:E$="" 4190 IF RM=0 THEN 4240 4200 PRINT 4210 IF RLL THEN X=RLL:Y=RLC:GOSUB 6700:GOTO 4230 4220 IF RLC THEN PRINT TAB(RLC); 4230 PRINT I;:X=RNB:GOSUB 6730 4240 J=0 4250 ' NEW FIELD 4260 J=J+1:C3=0'backup flag 4270 K=SQ(J) ' current field number (may be in any order) 4280 IF K=0 THEN X=EB:GOSUB 6730:GOTO 5040 ' next function 4290 IF C3=1 AND C(K)=0 THEN 4300 ELSE 4320 ' hidden field 4300 J=J-1:IF J=0 THEN L=0:GOTO 4250 4310 K=SQ(J):L=L-LEN(B$(K))-1:GOTO 4290 4320 IF C(K)=0 OR FL(K)<0 THEN IF T=1 THEN B$(K)="":L=L+1:GOTO 4250 ELSE L=L+LEN(B$(K))+1:GOTO 4250 ' skip fwd 4330 ' RE-ENTER 4340 IF E$<>"" THEN PRINT:PRINT CHR$(7); E$:E$="" 4350 GOSUB 4820 'print name 4360 ' BRANCH 4370 GOSUB 4940 'pos 4380 IF T=3 AND FLAG=K THEN B$(K)=B$(K)+FLAG$ 4390 IF T=1 GOTO 4410 4400 IF T=3 AND C(K)=2 THEN GOSUB 4980:PRINT CHR$(10);:GOSUB 4940 ELSE 4750 4410 ' CURSOR 4420 L1=FT*128-L-NC+J ' L1=avail space in rec 4430 IF FL(K) THEN EFL=FL(K) ELSE EFL=SW-POS(0) ' EFL=avail screen space 4440 IF L1>=EFL THEN 4460 4450 PRINT SPC(L1-1);"<";:GOSUB 4940 ' pos 4460 ' ENTER NEW DATA 4470 IF T=1 AND K=FLAG THEN PRINT FLAG$; 4480 LINE INPUT; T9$:IF T=1 AND FLAG=K THEN T9$=FLAG$+T9$ 4490 ' CONTROL ENTRIES 4500 IF T=3 THEN IF T9$="" OR T9$=";" OR T9$="+" THEN T9$=B$(K):GOTO 4680 ' no cha 4510 IF T=1 AND (T9$=";" OR T9$="+") THEN 4520 ELSE 4540 4520 T9$=B$(K):IF T9$="" THEN T9$=" " 4530 GOSUB 4940:PRINT T9$; 4540 IF T9$="stop" THEN IF T=1 THEN E$=STR$(N1)+" records added.": T0=I-1:GOTO 1140 ELSE 1120 4550 IF RIGHT$(T9$,1)<>CHR$(92) THEN 4590 4560 C3=1:J=J-1:IF J=0 THEN L=0:GOTO 4250 4570 K=SQ(J):L=L-LEN(B$(K))-1:IF FB(K) THEN PRINT 4580 GOTO 4280 4590 IF T9$=" "THEN T9$=""' enter 1 sp to cha to blank 4600 ' STRIP RT. SPC 4610 IF RIGHT$(T9$,1)=CHR$(32) THEN T9$=LEFT$(T9$,LEN(T9$)-1):GOTO 4610 4620 ' NUM CHECK 4630 IF RIGHT$(N$(K),1)<>"n" THEN 4680 4640 FOR I1=1 TO LEN(T9$) 4650 T3=ASC(MID$(T9$,I1,1)) 4660 IF T3<45 OR T3>57 THEN E$="Re-enter; only numbers allowed.": GOTO 4330 4670 NEXT 4680 ' LENGTH CHECK 4690 L=L+LEN(T9$)+1 4700 IF L+NC-J>FT*128 THEN E$="Record too long. Re-enter, shorter.":GOTO 4160 4710 ' SAVE IT 4720 B$(K)=T9$ 4730 ' RE-DISP IN FORM 4740 IF DLL(K) THEN GOSUB 4950:GOTO 4750 ELSE 4770 4750 ' SHOW DATA 4760 GOSUB 4980 ' print dat 4770 ' FINISH FIELD 4780 X=FB(K):GOSUB 6730 4790 GOTO 4250 ' next field 4800 ' SCREEN DONE 4810 GOTO 5040 ' skip subs 4820 ' (SUB) FIELD NAME 4830 IF NLL(K) THEN X=NLL(K):Y=NLC(K):GOSUB 6700:GOTO 4850 4840 IF NLC(K) THEN PRINT TAB(NLC(K)); 4850 ON FM(K) GOTO 4870,4910 ' plain or special 4860 GOTO 4930 'skip if 0 4870 ' NAME MODE 1 4880 IF RIGHT$(N$(K),1)="n" THEN PRINT LEFT$(N$(K),4)" # ";:GOTO 4930 4890 PRINT LEFT$(N$(K),4)" : "; 4900 GOTO 4930 4910 ' NAME MODE 2 4920 PRINT F2$(K); 4930 X=FMB(K):GOSUB 6730:RETURN 4940 ' (SUB) POSITION DATA (TERM DEP -- BACKSPACE) 4950 IF DLL(K) THEN X=DLL(K):Y=DLC(K):GOSUB 6700:GOTO 4970 4960 IF DLC(K) THEN IF POS(I)>DLC(K) THEN PRINT STRING$(POS(I)-DLC(K),8); ELSE PRINT TAB(DLC(K)); 4970 RETURN 4980 ' (SUB) PRINT DATA 4990 IF RIGHT$(N$(K),1)="n" AND PU$(K)<>"&" AND PU$(K)<>"" THEN N1!=VAL(B$(K)):GOTO 5020 5000 IF FL(K) THEN X$=LEFT$(B$(K),FL(K)) ELSE X$=B$(K) 5010 PRINT X$;:GOTO 5030 5020 PRINT USING PU$(K);N1!; 5030 RETURN 5040 ' LPRINT AND WRITE LP=real prnt pos LTM=top marg LPG=pg count RP=rec/pg LRC=rec count LLP=cond. pg LLC=line count 5050 IF T=0 GOTO 5790 5060 IF P9=0 THEN 5580 ' done 5070 ' START PRINTING 5080 IF C0=0 THEN C0=1:LRC=0:LLC=1: IF LPG=1 THEN X=LTM:GOSUB 7310: LPRINT"FILE: "F$ TAB(30)"DATE:"TAB(50)"SELECTION:": LLC=LLC+1:GOTO 5120 ELSE 5120 5090 ' NEW PAGE? 5100 IF (RP AND LRC=RP) OR LLC>LLP THEN GOSUB 7410 ELSE 5190 'FF 5110 ' PRINT HEADING 5120 X=LTM:GOSUB 7310 'CR 5130 IF LHL1$<>"" THEN LPRINT LHL1$; ELSE 5160 5140 IF RIGHT$(LHL1$,1)=CHR$(32) THEN LPRINT"PAGE"LPG:GOTO 5160 5150 LPRINT:LLC=LLC+1 5160 IF LHL2$<>"" THEN LPRINT LHL2$:LLC=LLC+1 5170 IF LHL3$<>"" THEN LPRINT LHL3$:LLC=LLC+1 5180 X=LHB:GOSUB 7310 'CR 5190 ' NEW REC - LPRINT #? 5200 LRC=LRC+1 ' counts recs on p g 5210 IF LRM=0 THEN 5250 5220 IF LRLL THEN X=LRLL:Y=LRLC:GOSUB 7330:GOTO 5240 5230 IF LRLC THEN Y=LRLC:GOSUB 7360 ' tab 5240 C1=LPOS(0):A$=STR$(I):A$=RIGHT$(A$,LEN(A$)-1): LPRINT A$;:LP=LP+LPOS(0)-C1:X=LRNB:GOSUB 7310 ' CR 5250 J=0 5260 ' NEW FIELD 5270 J=J+1 5280 K=SQ(J) 5290 IF K=0 THEN X=LEB:GOSUB 7310:GOTO 5580 ' done ======> 5300 IF (C(K)=0) OR (LFL(K)<0) THEN 5260 'skip 5310 GOSUB 5340 'name 5320 GOSUB 5470:GOSUB 5510 'pos & lprint data 5330 X=LFB(K):GOSUB 7310:GOTO 5270 'next field 5340 ' (SUB) LPRINT FIELD NAME 5350 IF LNLL(K) THEN X=LNLL(K):Y=LNLC(K):GOSUB 7330:GOTO 5370 5360 IF LNLC(K) THEN Y=LNLC(K):GOSUB 7360 ' tab 5370 ON LFM(K) GOTO 5390,5420 5380 GOTO 5450 'skip if 0 5390 ' NAME MODE 1 5400 LPRINT LEFT$(N$(K),4)" : "; 5410 LP=LP+7:GOTO 5450 5420 ' NAME MODE 2 5422 Y=LEN(LF2$(K)):IF LP+Y>LW THEN X=1:GOSUB 7310:LPRINT SPACE$(5);:LP=6 5430 LPRINT LF2$(K);:LP=LP+Y 5440 ' DONE NAME 5450 X=LFMB(K):GOSUB 7310 5460 RETURN 5470 ' (SUB) POSITION LPRINT DATA 5480 IF LDLL(K) THEN X=LDLL(K):Y=LDLC(K):GOSUB 7330:GOTO 5500 5490 IF LDLC(K) THEN Y=LDLC(K):GOSUB 7360 ' tab 5500 RETURN 5510 ' (SUB) LPRINT DATA 5520 C1=LPOS(0) 5530 IF RIGHT$(N$(K),1)="n" AND LPU$(K)<>"&" AND LPU$(K)<>"" THEN N1!=VAL(B$(K)):GOTO 5560 5540 IF LFL(K) THEN X$=LEFT$(B$(K),LFL(K)) ELSE X$=B$(K) 5542 IF LP+LEN(X$)>LW THEN X=1:GOSUB 7310:LPRINT SPACE$(5);:C1=LPOS(0) 5550 LPRINT X$;:GOTO 5570 5560 LPRINT USING LPU$(K);N1!; 5570 LP=LP+LPOS(0)-C1:RETURN 5580 ' DONE LPRINT & WRITE - BRANCH 5590 IF T=10 OR P7<>0 THEN 5600 ELSE 5680 5600 ' COPY & DELETE PAUSE 5610 GOSUB 6100 'exit 5612 IF A=122 THEN 5650 'z 5620 IF RS THEN X=24:Y=1:GOSUB 6700 5622 IF P7 THEN PRINT"Copy "; 5624 IF P7<>0 AND T=10 THEN PRINT"& "; 5626 IF T=10 THEN PRINT"Delete "; 5630 PRINT"this record? n/y/z/esc >";: A$=INPUT$(1):A=ASC(A$):IF A=13 THEN A$="n" 5632 IF A=27 THEN PRINT"ESC":GOTO 5634 ELSE 5640 5634 IF (P6 OR P7) THEN GOSUB 8410 'close output file 5636 GOTO 1120  5640 PRINT A$:IF A$="y" OR A$="z" THEN 5650 ELSE 5770 5650 ' COPY 5660 IF P7 THEN NR=NR+1:GOSUB 6600:PRINT"!"; 5665 ' DELETE 5670 IF T=10 THEN T$=CHR$(0):GOSUB 6300 'change rec to null 5680 ' BRANCH 5685 IF T=3 OR T=1 THEN 5690 ELSE 5770 5690 ' ASSEM NEW/CHANGED REC STR AND PUT TO DISK 5700 T$="" 5710 FOR J=1 TO NC 5730 T$=T$+B$(J)+CHR$(126) 5740 NEXT J 5750 GOSUB 6300:PRINT"*";:GOSUB 6400:PRINT"!" ' put record, dupe 5760 IF T=1 THEN N=N+1:C=1:I=I+1:N1=N1+1:GOTO 4000 5770 ' WIND UP 5780 GOSUB 6100 ' check exit 5790 NEXT I '<=========== END OF RECORD WORK LOOP 5800 IF P7 THEN GOSUB 8410 'close 2 5805 IF P9 THEN GOSUB 7410 'FF 5810 IF T2=N THEN E$="End of file.":GOTO 1140 5820 GOTO 1120 6100 ' (SUB) EXIT TEST returns character value in A 6110 X$=INKEY$ 6120 IF X$<>"" THEN A=ASC(X$) 6130 IF A<>27 THEN RETURN 6140 IF (P6 OR P7) THEN GOSUB 8410 ' put head & close out file 6145 IF P9 THEN GOSUB 7410 'FF 6150 GOTO 1120 6200 ' (SUB) GET RECORD "I" IN T$ 6210 T$="" ' necessary! 6220 ON FT GOTO 6250,6230 6230 GET#1,FT*I+2 ' latter half 6240 T$=LEFT$(R$,127) 6250 GET#1,FT*I+1 ' whole or first half 6260 T$=R$+T$ 6270 RETURN 6300 ' (SUB) WRITE T$ AS RECORD # I 6310 ON FT GOTO 6340,6320 6320 LSET R$=MID$(T$,129) ' latter half 6330 PUT #1,FT*I+2 6340 LSET R$=LEFT$(T$,128) ' first half 6350 PUT #1,FT*I+1 6360 RETURN 6400 ' (SUB) WRITE T$ AS DUPE REC I 6410 ON FT GOTO 6440,6420 6420 LSET S$=MID$(T$,129) 6430 PUT #2,FT*I+2 6440 LSET S$=LEFT$(T$,128) 6450 PUT #2,FT*I+1 6460 RETURN 6500 ' (SUB) PARSE STRING 6510 K=0 6520 J=INSTR(T$,CHR$(126)) ' delimiter 6530 IF J=0 THEN RETURN 6540 K=K+1 6550 B$(K)=MID$(T$,1,J-1) 6560 T$=MID$(T$,J+1) 6570 GOTO 6520 6600 ' (SUB) PUT T1$ AS OUTPUT REC NR 6610 ON FT GOTO 6640,6620 6620 LSET S$=MID$(T1$,129) 6630 PUT#3,FT*NR+2 6640 LSET S$=LEFT$(T1$,128) 6650 PUT#3,FT*NR+1 6660 RETURN 6700 ' (SUB) POSITION CONSOLE CURSOR (TERM DEP) X=line (1 to 24) Y=column (1 to 80) 6710 PRINT CHR$(20);CHR$(X+127);CHR$(Y+127); 'ACT-5A 6720 RETURN 6730 ' (SUB) CR 6740 FOR I1=1 TO X:PRINT:NEXT:RETURN 7000 ' GENERAL ERROR ROUTINES 7005 IF ERR=53 THEN E$="File not found.":RESUME 1140 7010 IF ERR=61 THEN 7040 'disk full 7020 IF ERR=6 THEN 7060 'overflow 7030 ON ERROR GOTO 0 7040 IF (P6 OR P7) THEN E$="Disk full ... fix then repeat last copy command":RESUME 1140 7050 CLOSE:PRINT:PRINT"Disk full .. files forced closed ..": PRINT"N ="N;" .. adds since last 'done' not updated in header ..": PRINT"Hit return for re-open attempt...then do 'done'. ": INPUT A$:T=8:RESUME 2720 7060 PRINT CHR$(7):PRINT"That number was too big! Try again.":PRINT:RESUME NEXT 7070 ' (SUB) UCV 7080 Y$="" 7090 FOR K=1 TO LEN(X$) 7100 Y$=Y$+" " 7110 X=ASC(MID$(X$,K, 1)) 7120 IF 96"y" THEN 1140 7240 WIDTH LPRINT LW+1 'backup to LP process 7250 LPRINT CHR$(27);CHR$(31);CHR$(HMI+129); 7260 LPRINT CHR$(27);CHR$(30);CHR$(VMI+129); 7270 LPRINT CHR$(27);CHR$(137);CHR$(LLM+129); 7280 LPRINT CHR$(27); "9"; CHR$(13); 'esc 9 sets margin, CR 7300 RETURN 7310 ' (SUB) LCR 7320 FOR I1=1 TO X:LPRINT:LP=1:NEXT:LLC=LLC+X:RETURN 'lp=1 stays inside! 7330 ' (SUB) POSITION LPRINT HEAD (DIABLO) 7340 LPRINT CHR$(27);CHR$(11);CHR$(X);CHR$(27);CHR$(137);CHR$(Y+128+LLM); 7350 LLC=X:LP=Y:RETURN 7360 ' (SUB) TAB LPRINT (DIABLO) 7370 IF LP>Y AND RP=0 THEN X=1:GOSUB 7310 ' addl line if too long 7380 Y1=Y+LLM:IF Y1>126 THEN LPRINT SPACE$(Y1-LP+LLM);:GOTO 7400 ' sim tab 7390 LPRINT CHR$(27);CHR$(137);CHR$(Y1+128);  7400 LP=Y:RETURN 7410 ' (SUB) FORM FEED 7420 LPRINT CHR$(12);CHR$(13);:LRC=0:LLC=1:LPG=LPG+1:LP=1:RETURN 7430 ' (SUB) CLEAR SCREEN, HOME CURSOR (TERM DEP) 7440 PRINT CHR$(12); 7450 RETURN 7460 ' (SUB) SETSEARCH 7470 IF T1=T2 THEN RETURN 7480 GOSUB 7430 'cs 7490 X=5:Y=1:GOSUB 6700 7500 SKIPPARSE=1 ' flag 7510 PRINT"Here are the fields in "F$: GOSUB 7800 7520 FOR J=0 TO 9 7530 INPUT"Number of field to search (RETURN for all fields)";A$ 7540 IF A$="" THEN SEARCHFIELD(J)=0: GOTO 7590 7550 A=VAL(A$) 7560 IF A<1 OR A>NC THEN PRINT"NO FIELD"A: GOTO 7530 7570 SEARCHFIELD(J)=A 7580 SKIPPARSE=0 7590 PRINT TAB(13);:LINE INPUT"Expression to look for ( _ for blank)? ";A$ 7600 SEARCHWORD$(J)=A$ 7610 IF A$="" THEN 7630 7620 NEXT J 7630 PRINT: PRINT"Do you want to select records to exclude? (n/y) "; 7640 A$=INPUT$(1):IF A$=CHR$(13) THEN A$="n" 7655 PRINT A$ 7660 IF A$<>"y" THEN SKIPWORD$(0)="": RETURN 7670 PRINT:FOR J=0 TO 9 7680 INPUT"Number of field to search (RETURN for all fields)";A$ 7690 IF A$="" THEN LOOKFIELD(J)=0: GOTO 7740 7700 A=VAL(A$) 7710 IF A<1 OR A>NC THEN PRINT"NO FIELD"A: GOTO 7680 7720 LOOKFIELD(J)=A 7730 SKIPPARSE=0 7740 PRINT TAB(13);:LINE INPUT"Expression to look for ( _ for blank)? ";A$ 7750 SKIPWORD$(J)=A$ 7760 IF A$="" THEN 7780 7770 NEXT J 7780 PRINT 7790 RETURN 7800 ' (SUB) SHOW FIELDS 7810 FOR K=1 TO NC 7820 PRINT TAB(29); 7830 PRINT USING"##";K;:PRINT". "LEFT$(N$(K),4)" "RIGHT$(N$(K),1) 7840 NEXT 7850 PRINT 7860 RETURN 7870 ' (SUB) LOAD DEFAULT FORMAT CONTROLS 7880 PRINT:PRINT TAB(31)"Installing format 0. 7890 FO$="0":FFN$="":FFD$="":TM=0:LTM=4:LM=0:LLM=3:SW=79:LW=95:RS=0:RP=0 7900 LLP=66-LTM-2 7910 HMI=10:VMI=8:FSC$="":HL1$="" 7920 HL2$="" 7930 HL3$="" 7940 LHL1$=F$+" ":LHL2$="":LHL3$="":HB=1:LHB=1 7950 RM=1:LRM=1:RLL=0:LRLL=0:RLC=0:LRLC=0:RNB=1:LRNB=0 7955 EB=0:LEB=2 7960 FOR I=1 TO NC 7970 SQ(I)=I:FM(I)=1:LFM(I)=2:F2$(I)="":LF2$(I)=" - ": NLL(I)=0:LNLL(I)=0:NLC(I)=0:LNLC(I)=0:FMB(I)=0:LFMB(I)=0 7980 PU$(I)="&":LPU$(I)="&":DLL(I)=0:LDLL(I)=0:DLC(I)=8:LDLC(I)=0: FL(I)=0:LFL(I)=0:FB(I)=1:LFB(I)=0 7990 NEXT 8000 SQ(I)=0 8010 RETURN 8020 ' (SUB) OPEN COPY OUTPUT FILE 8030 PRINT:PRINT"Output file name (prefix optional, default "DD$(3)")";: INPUT F2$:IF F2$="" THEN E$="?":GOTO 8360 8040 X$=F2$:GOSUB 7070:F2$=Y$'ucv 8050 IF MID$(F2$,2,1)=":" THEN 8070 8060 F2$=DD$(3)+F2$ 8070 ON ERROR GOTO 8100 8080 OPEN"I",3,F2$+".D"+FT$ 8090 CLOSE 3:ON ERROR GOTO 7000:GOTO 8200'found 8100 CLOSE 3:ON ERROR GOTO 7000 8110 IF ERR=53 THEN RESUME 8160 8120 IF ERR=61 THEN E$="Sorry, disk is full.":RESUME 8360 8130 IF ERR=64 THEN PRINT"Bad file name, try again.":RESUME 8030 8140 IF ERR=67 THEN E$="Directory full.":RESUME 8360 8150 GOTO 7000 8160 ' make new file 8170 PRINT"Opening new file "F2$ 8180 NR=0:GOSUB 8380 8190 GOTO 8360 8200 ' OPEN & LOAD HEADER 8210 GOSUB 8380 8220 T$="" 8230 ON FT GOTO 8260,8240 8240 GET#3,2 8250 T$=LEFT$(S$,127) 8260 GET#3,1 8270 T$=S$+T$ 8280 GOSUB 6500'parse 8290 FOR I=1 TO 31 8300 IF LEFT$(B$(I),4)="stop" GOTO 8320 8310 NEXT 8320 T3=I-1 8330 IF T3<>NC THEN E$="Copy aborted; output file has a different number of columns" +CHR$(13)+CHR$(10):GOTO 8360 8340 IF F2$=DD$(3)+F$ THEN NR=N ELSE NR=VAL(B$(I+1)) 8350 PRINT"File open, NR ="NR 8360 RETURN 8370 ' (SUB) OPEN THE OUTPUT FILE 8380 OPEN"R",3,F2$+".D"+FT$ 8390 FIELD #3,128 AS S$ 8400 RETURN 8410 ' (SUB) CLOSE DIMS OUT FILE 8420 IF F2$=DD$(3)+F$ THEN C=1:N=NR:GOTO 8530 8430 PRINT:PRINT"Closing output file,"NR"records. 8440 PRINT:PRINT"Backup of copied records is not automatic. The 'backup' command 8450 PRINT"must be used on the file you copied to. 8460 T$="" 8470 FOR I=1 TO 31 8480 T$=T$+N$(I)+CHR$(126) 8490 IF LEFT$(N$(I),4)="stop" THEN 8510 8500 NEXT 8510 T1$=T$+STR$(NR)+CHR$(126) 8520 NR=0:GOSUB 6600 8530 CLOSE 3 8540 RETURN 8550 ' (SUB) FLAGSET 8560 PRINT:PRINT"Here are the fields in "F$:PRINT:GOSUB 7800 8570 INPUT"Numb er of field to flag ";A:IF A=0 THEN 8610 8580 IF A>NC THEN PRINT A"???":GOTO 8570 8590 FLAG=A 8600 LINE INPUT"Enter flag; may include blanks: ";FLAG$:IF FLAG$="" THEN 8610 8610 RETURN 8620 ' SHOW TRANSIENT PROGRAMS 8630 PRINT:PRINT"Here are the available transient programs; to use one as a command 8640 PRINT:PRINT"skip the 'D' on the front and the '.BAS'." 8650 PRINT:WIDTH 70:FILES DD$(2)+"D???????.BAS":WIDTH 255:PRINT:PRINT 8660 GOTO 1140  the 'D' on the front and the '.BAS'." 8650 PTHEN C=1:N=NR:GOTO 8530 8430 PRINT:PRINT"Closing output file,"NR"records. 8440 PRINT:PRINT"Backup of copied records is not automatic. The 'backup' command 8450 PRINT"must be used on the file you copied to. 8460 T$="" 8470 FOR I=1 TO 31 8480 T$=T$+N$(I)+CHR$(126) 8490 IF LEFT$(N$(I),4)="stop" THEN 8510 8500 NEXT 8510 T1$=T$+STR$(NR)+CHR$(126) 8520 NR=0:GOSUB 6600 8530 CLOSE 3 8540 RETURN 8550 ' (SUB) FLAGSET 8560 PRINT:PRINT"Here are the fields in "F$:PRINT:GOSUB 7800 8570 INPUT"Numb10 PRINT"This program must be entered via DIMS 20 STOP 1000 GOSUB 1890 'cs 1010 PRINT:PRINT TAB(29);"DGET 1.03 - October 30, 1983 1020 ' by Dan Dugan -- public domain 1030 PRINT 1040 DEFINT A-Z 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 DIM DEST(30),USED(30),B1$(30):INREC=0 1070 ' OPEN SOURCE FILE 1080 PRINT:INPUT"Name of source file";X$ 1085 IF X$="" THEN 1820 1090 GOSUB 1920:F2$=Y$ 'ucv 1100 IF MID$(F2$,2,1)=":" THEN 1120 1110 F2$=DD$(5)+F2$ 1120 ' TEST FOR EXISTENCE 1130 ON ERROR GOTO 1160 1140 OPEN"I",3,F2$ 1150 ON ERROR GOTO 0:GOTO 1200 'ok 1160 CLOSE 3 1170 IF ERR=53 THEN CLOSE 3:PRINT"File not found":RESUME 1070 1180 IF ERR=64 THEN PRINT"Bad file name, try again.":RESUME 1070 1190 ON ERROR GOTO 0 1200 ' ENTER SEQUENCE OF FIELDS 1210 PRINT:PRINT"Here's the first line of "F2$". 1220 LINE INPUT#3,T$ 1230 PRINT:PRINT T$ 1240 CLOSE 3:OPEN"I",3,F2$ 1250 PRINT:PRINT"Would you like to re-assign or skip fields? (n/y) ";:A$=INPUT$(1) 1252 IF A$="y" OR A$="Y" THEN 1260 ELSE FOR I=1 TO NC:DEST(I)=I:NEXT:NF=NC:PRINT:GOTO 1370 1260 PRINT:FOR I=1 TO NC:USED(I)=0:NEXT 1265 PRINT:INPUT"Number of fields in source file";NF:PRINT 1270 FOR I=1 TO NF 1280 PRINT"Destination field of field"I"(enter 0 to ignore)";:INPUT DEST(I) 1290 IF DEST(I)>NC THEN PRINT "This file only has"NC"fields.":GOTO 1280 1300 IF DEST(I)=0 THEN 1330 1310 IF USED(DEST(I)) THEN PRINT"Won't accept putting two fields into one.":GOTO 1280 1320 USED(DEST(I))=1 1330 NEXT 1340 PRINT:PRINT"Is this ok (y/n)? "; 1350 A$=INPUT$(1):PRINT A$ 1360 IF A$<>"y" THEN GOTO 1200 1370 C=1:PRINT 1380 ' READ FILE 1390 GOSUB 1840 'exit 1400 IF EOF(3) THEN 1790 1410 FOR I=1 TO NC:B$(I)="":NEXT:NR=NR+1 1420 LINE INPUT #3,T$ 1430 INREC=INREC+1:GOSUB 2010 'parse into B1$ array j=fields found 1440 IF J<>NF THEN 1450 ELSE 1470 1450 IF P9 THEN PRINT CHR$(7);:LPRINT"Input file line"INREC"defective." 1460 PRINT"Input file line"INREC"defective."CHR$(7) 1470 FOR I=1 TO J 1480 IF DEST(I) THEN 1490 ELSE 1520 1490 QUOTE=INSTR(T$,CHR$(126)) 1500 IF QUOTE THEN MID$(T$,QUOTE,1)=CHR$(34):GOTO 1490 1510 B$(DEST(I))=B1$(I) 1520 NEXT 1530 ' ADD RECORD TO DIMS FILE 1540 T$="" 1550 FOR J=1 TO NC 1560 IF LEN(T$)+LEN(B$(J))+1>FT*128 THEN 1570 ELSE 1590 1570 IF P9 THEN LPRINT "Input line"INREC"too long." 1580 PRINT"Input line"INREC"too long."CHR$(7) 1590 T$=T$+B$(J)+CHR$(126) 1600 NEXT 1610 N=N+1:PRINT N;T$; 1620 GOSUB 1650:PRINT"*";:GOSUB 1720:PRINT"!":C=1 1630 ' LOOP 1640 GOTO 1380 1650 ' (SUB) WRITE T$ AS RECORD # N 1660 ON FT GOTO 1690,1670 1670 LSET R$=MID$(T$,129) 'latter half 1680 PUT #1,FT*N+2 1690 LSET R$=LEFT$(T$,128) 'first half 1700 PUT #1,FT*N+1 1710 RETURN 1720 ' (SUB) WRITE T$ AS DUPE REC N 1730 ON FT GOTO 1760,1740 1740 LSET S$=MID$(T$,129) 1750 PUT #2,FT*N+2 1760 LSET S$=LEFT$(T$,128) 1770 PUT #2,FT*N+1 1780 RETURN 1790 ' FINISH 1800 CLOSE 3 1810 PRINT:PRINT NR"records added. 1820 PRINT:PRINT TAB(32)"Re-loading DEDIT. 1830 CHAIN DD$(1)+"DEDIT",1000 1840 ' EXIT TEST (TERM DEP) 1850 X$=INKEY$:X=0 1860 IF X$<>"" THEN X=ASC(X$) 1870 IF X=27 THEN CLOSE 3:GOTO 1790 'use ESC to escape listing 1880 RETURN 1890 ' CLEAR SCREEN (TERM DEP) 1900 PRINT CHR$(12); 1910 RETURN 1920 ' (SUB) UCV 1930 Y$="" 1940 FOR K=1 TO LEN(X$) 1950 Y$=Y$+CHR$(32) 1960 X=ASC(MID$(X$,K,1)) 1970 IF 96 B1$ ARRAY 2020 ' returns J = number of fields found 2030 FOR J=1 TO NF:B1$(J)="":NEXT 2040 J=0 2050 ' process loop 2060 J=J+1:IF J=NF THEN 2170 2070 X=INSTR(T$,CHR$(44)) 'comma 2080 IF X=0 THEN 2170 'must be last field 2090 Y=INSTR(T$,CHR$(34)) 'quote 2100 IF Y=0 OR ( Y<>0 AND X B1$ ARRAY 2020 ' returns J = number of fields found 2030 FOR J=1 TO NF:B1$(J)="":NEXT 2040 J=0 2050 ' process loop 2060 J=J+1:IF J=NF THEN 2170 2070 X=INSTR(T$,CHR$(44)) 'comma 2080 IF X=0 THEN 2170 'must be last field 2090 Y=INSTR(T$,CHR$(34)) 'quote 2100 IF Y=0 OR ( Y<>0 AND XNC THEN PRINT "This file only has"NC"fields.":GOTO 1280 1300 IF DEST(I)=0 THEN 1330 1310 IF USED(DEST(I)) THEN PRINT"Won't accept putting two fields into one.":GOTO 1280 1320 USED(DEST(I))=1 1330 NEXT 1340 PRINT:PRINT"Is this ok (y/n)? "; 1350 A$=INPUT$(1):PRINT A$ 1360 IF A$<>"y" THEN GOTO 1200 1370 PRINT 1380 ' READ FILE 1390 GOSUB 2410 'exit 1400 IF EOF(3) THEN 2360 1410 FOR I=1 TO NC:B$(I)="":NEXT 1420 LINE INPUT #3,T$ 1430 PRINT"+";:INREC=INREC+1:GOSUB 2580 'parse into B1$ array j=fields found 1440 IF J<>NF THEN 1450 ELSE 1470 1450 IF P9 THEN PRINT CHR$(7);:LPRINT:LPRINT"Input file line"INREC"defective." 1460 PRINT:PRINT"Input file line"INREC"defective."CHR$(7) 1470 FOR I=1 TO J 1480 IF DEST(I) THEN 1490 ELSE 1520 1490 QUOTE=INSTR(T$,CHR$(126)) 1500 IF QUOTE THEN MID$(T$,QUOTE,1)=CHR$(34):GOTO 1490 1510 B$(DEST(I))=B1$(I) 1520 NEXT 1530 ' SEARCH 1540 IF SEARCH<>2 THEN 1590 1550 ' FIND 1560 IF INSTR(T$,SEARCHWORD$(0))=0 THEN 2200 'skip 1580 GOTO 1830 1590 ' FIELD SEARCH 1600 J=0 ' check for skips first 1610 IF SKIPWORD$(J)="" THEN 1700 ' try search then 1620 IF LOOKFIELD(J)<>0 THEN 1660 ' look in field 1630 IF INSTR(T1$,SKIPWORD$(J))<>0 THEN 2200 ' check whole rec - skip it 1640 J=J+1 1650 GOTO 1610 1660 IF INSTR(B$(LOOKFIELD(J)),SKIPWORD$(J))<>0 THEN 2200 ' field compare - skip 1670 IF B$(LOOKFIELD(J))="" AND SKIPWORD$(J)="_" THEN 2200 'blank 1680 J=J+1 1690 GOTO 1610 1700 IF SEARCHWORD$(0)="" THEN 1810 ' don't care so print it 1710 J=0: GOTO 1730 ' now search 1720 IF SEARCHWORD$(J)="" THEN 2200 ' hesitate no longer 1730 IF SEARCHFIELD(J)<>0 THEN 1770 ' field 1740 IF INSTR(T1$,SEARCHWORD$(J))<>0 THEN 1810 ' found it 1750 J=J+1 1760 GOTO 1720 1770 IF INSTR(B$(SEARCHFIELD(J)),SEARCHWORD$(J))<>0 THEN 1810 1780 IF B$(SEARCHFIELD(J))="" AND SEARCHWORD$(J)="_" THEN 1810 1790 J=J+1 1800 GOTO 1720 1810 ' GET READY TO DO IT 1830 ' PAUSE CONTROLS (TERM DEP IF UPPERCASE ONLY) 1840 GOSUB 2410 ' exit returns A 1850 IF A=122 THEN 2100 ' z means go on 1860 PRINT INREC;B$(1);TAB(30);"Ready (SPACE/z/ESC) > "; 1870 A$=INPUT$(1):A=ASC(A$):IF A=27 THEN 2360 ' finish 1880 PRINT A$;:IF A=13 OR A=32 OR A=122 THEN 2100 1890 GOSUB 2410 ' exit 2100 ' ADD RECORD TO DIMS FILE 2110 T$="":NR=NR+1 2120 FOR J=1 TO NC 2130 IF LEN(T$)+LEN(B$(J))+1>FT*128 THEN 2140 ELSE 2160 2140 IF P9 THEN LPRINT "Input line"INREC"too long." 2150 PRINT"Input line"INREC"too long."CHR$(7) 2160 T$=T$+B$(J)+CHR$(126) 2170 NEXT 2180 N=N+1:PRINT INREC"="N:PRINT T$; 2190 GOSUB 2220:PRINT" *";:GOSUB 2290:PRINT"!":C=1 2200 ' LOOP 2210 GOTO 1380 2220 ' (SUB) WRITE T$ AS RECORD # N 2230 ON FT GOTO 2260,2240 2240 LSET R$=MID$(T$,129) 'latter half 2250 PUT #1,FT*N+2 2260 LSET R$=LEFT$(T$,128) 'first half 2270 PUT #1,FT*N+1 2280 RETURN 2290 ' (SUB) WRITE T$ AS DUPE REC N 2300 ON FT GOTO 2330,2310 2310 LSET S$=MID$(T$,129) 2320 PUT #2,FT*N+2 2330 LSET S$=LEFT$(T$,128) 2340 PUT #2,FT*N+1 2350 RETURN 2360 ' FINISH 2370 CLOSE 3 2380 PRINT:PRINT NR"records added. 2390 PRINT:PRINT TAB(32)"Re-loading DEDIT. 2400 CHAIN DD$(1)+"DEDIT",1000 2410 ' EXIT TEST (TERM DEP) 2420 X$=INKEY$ 2430 IF X$<>"" THEN A=ASC(X$) 2440 IF A=27 THEN CLOSE 3:GOTO 2360 'use ESC to escape listing 2450 RETURN 2460 ' CLEAR SCREEN (TERM DEP) 2470 PRINT CHR$(12); 2480 RETURN 2490 ' (SUB) UCV 2500 Y$="" 2510 FOR K=1 TO LEN(X$) 2520 Y$=Y$+CHR$(32) 2530 X=ASC(MID$(X$,K,1)) 2540 IF 96 B1$ ARRAY 2590 ' returns J = number of fields found 2600 FOR J=1 TO NF:B1$(J)="":NEXT 2610 J=0 2620 ' process loop 2630 J=J+1:IF J=NF THEN 2730 2640 X=INSTR(T$,CHR$(44)) 'comma 2650 IF X=0 THEN 2730 'must be last field 2660 Y=INSTR(T$,CHR$(34)) 'quote 2670 IF Y=0 OR ( Y<>0 AND X"" THEN PRINT E$:PRINT 1110 PRINT:PRINT TAB(22)"Here are the data files on this disk: 1120 PRINT:FILES DD$(3)+"*.D?" 1125 WIDTH 255 1130 PRINT:PRINT:PRINT TAB(16);"************* DIMS NO-FILE MENU ************** 1140 PRINT:PRINT TAB(16);"Open any data file shown above ............... 1 1150 PRINT TAB(16);"Install new disks ............................ 2 1160 PRINT 1170 PRINT TAB(16);"Design structure of a new file (DCREATE) ..... 3 1180 PRINT TAB(16);"Change number of disk drives for this session. 4 1190 PRINT 1200 PRINT TAB(16);"Exit DIMS to Basic ........................... 9 1210 PRINT TAB(16);"Exit DIMS to CP/M ............................ 0 1220 PRINT:PRINT TAB(16);STRING$(48,42):PRINT 1230 PRINT TAB(16);: PRINT"To continue enter a number ................... "; 1240 A$=INPUT$(1): IF A$=CHR$(13) THEN A$="1" 1250 PRINT A$ 1255 RESET ' safety for floppies 1260 IF A$="0" THEN SYSTEM 1270 IF A$="1" THEN GOTO 1650 1280 IF A$="2" THEN GOTO 1000 1290 IF A$="3" THEN CHAIN DD$(2)+"DCREATE" 1300 IF A$="4" THEN GOSUB 1330:GOTO 1000 1310 IF A$="9" THEN GOSUB 3420:STOP 1320 GOTO 1230 1330 ' (SUB) ASK # DISKS 1340 PRINT:PRINT TAB(27);:INPUT"Number of disks in system";NDRIVES 1345 PRINT:IF NDRIVES<1 THEN 1000 1350 IF NDRIVES>4 THEN 1340 1360 ' (SUB) INSTALL DISK NAMES 1370 RESTORE 1390 1380 ' DD$(1) (2) (3) (4) (5) ' file groups 1382 ' main trans data dupe misc 1383 ' pgms pgms file file files 1390 DATA 1,"A:","A:","A:","A:","A:" 1400 DATA 2,"A:","B:","A:","B:","B:" 1410 DATA 3,"A:","A:","B:","C:","A:" 1420 DATA 4,"A:","A:","B:","C:","D:" 1430 READ J 1440 FOR K=1 TO 5 1450 READ DD$(K) 1460 NEXT 1470 IF J<>NDRIVES THEN 1430 1480 IF A$<>"4" THEN RETURN 1490 ON NDRIVES GOTO 1500,1510,1540,1580 1500 PRINT"One disk system - all files and programs on A.":GOTO 1630 1510 PRINT"Two disk system: A: = main program and main data files 1520 PRINT TAB(19)"B: = transient programs, backup data files, aux. data files 1530 GOTO 1630 1540 PRINT "Three disk system: A: = main program, transient programs, aux data files 1550 PRINT TAB(21)"B: = main data files 1560 PRINT TAB(21)"C: = backup data files 1570 GOTO 1630 1580 PRINT"Four disk system: A: = main and transient programs 1590 PRINT TAB(20)"B: = main data files 1600 PRINT TAB(20)"C: = backup data files 1610 PRINT TAB(20)"D: = aux. data files 1630 PRINT:PRINT TAB(29)"Hit return to continue.":A$=INPUT$(1) 1640 RETURN 1650 ' LOAD HEADER 1660 GOSUB 3480 ' get name & open up files 1670 GOSUB 3420 'cs 1690 GOSUB 3750 ' get record 1700 GOSUB 1880 'parse into B$'s 1710 FOR I=1 TO 31 1720 N$(I)=B$(I) 'load names 1730 IF LEFT$(N$(I),4)="stop" GOTO 1760 1740 C(I)=1 1750 NEXT I 1760 N=VAL(B$(I+1)) 1770 NC=I-1 ' # cols 1780 PRINT TAB(20)"File "F$" is open. It has"N"records." 1790 ' EXIT TO DEDIT 1795 PRINT:PRINT TAB(24)"Waiting while DEDIT is loading." 1800 CHAIN DD$(1)+"DEDIT",1000 1810 ' (SUB) WRITE T$ AS RECORD # I 1820 ON FT GOTO 1850,1830 1830 LSET R$=MID$(T$,129) ' latter half 1840 PUT #1,FT*I+2 1850 LSET R$=LEFT$(T$,128) ' first half 1860 PUT #1,FT*I+1 1870 RETURN 1880 ' (SUB) PARSE STRING 1890 K=0 1900 J=INSTR(T$,CHR$(126)) ' delimiter 1910 IF J=0 THEN RETURN 1920 K=K+1 1930 B$(K)=MID$(T$,1,J-1) 1940 T$=MID$(T$,J+1) 1950 GOTO 1900 1970 ' (SUB) SAVE HEADERS 1990 PRINT:PRINT TAB(31)"Saving file header":PRINT TAB(39); 2000 T$="" 2010 FOR I=1 TO 31: T$=T$+N$(I)+CHR$(126): T1$=LEFT$(N$(I),4): IF T1$="stop" THEN 2030 2020 NEXT I 2030 T$=T$+STR$(N)+CHR$(126) 'add N at end 2040 I=0 2050 GOSUB 1810 ' put rec 0 2060 PRINT "*"; 2062 NR=0:T1$=T$:GOSUB 3960 'put dupe head 2064 PRINT"!" 2070 RETURN 2100 ' BACKUP makes dupe file 2110 CLOSE 2:KILL DD$(4)+F$+".DD"+FT$ 2120 GOSUB 3720 ' open up .DD on 2 2130 PRINT"Copying main file to dupe file, same numbers.":PRINT 2140 FOR I=0 TO N 2150 IF INKEY$=CHR$(27) THEN PRINT:PRINT:PRINT"Copy aborted.":GOTO 3260 2160 GOSUB 3750: PRINT"+"; ' get record I in T$ 2170 NR=I:T1$=T$:GOSUB 3960:PRINT"*"; ' put record NR 2180 NEXT 2190 PRINT:GOTO 3260 ' to DEDIT 3000 ' RENUMBER COPY MAIN TO DUPE 3010 CLOSE 2:KILL DD$(4)+F$+".DD"+FT$ 3020 GOSUB 3720 ' open 2 3030 PRINT"Copying main file to dupe file, renumbering.":PRINT 3040 NR=0 3050 FOR I=1 TO N 3060 IF INKEY$=CHR$(27) THEN PRINT:PRINT:PRINT"Renumber aborted.":GOTO 3260 3070 GOSUB 3750 ' get rec I in T$ 3080 IF ASC(T$)=0 THEN PRINT"0";:GOTO 3100' skip it 3090 PRINT"+";:NR=NR+1:T1$=T$:GOSUB 3960:PRINT"!"; ' put rec NR 3100 NEXT 3110 GOSUB 4030 ' save header (NR) 3120 ' ERASE MAIN FILE AND COPY DUPE TO MAIN 3130 CLOSE 3140 PRINT:PRINT"The following operation removes space from deleted records: 3150 PRINT: PRINT"Erasing main file. 3160 KILL DD$(3)+F$+".D"+FT$ 3170 PRINT:PRINT:PRINT"Copying dupe to main file.":PRINT 3180 GOSUB 3680 ' open both files 3190 FOR J=1 TO FT*(NR+1) 3200 GET #2,J 3210 PRINT"&"; 3220 LSET R$=S$ 3230 PUT #1,J 3240 PRINT"*"; 3250 NEXT J 3251 N=NR 3252 PRINT:GOSUB 1970 'put header 3255 ' RETURN TO DEDIT 3260 GOTO 1790 3280 ' GENERAL ERROR ROUTINES 3290 IF ERL=1120 AND ERR=53 THEN RESUME 1130 ' if disk empty 3300 IF ERL=1740 AND ERR=9 THEN CLOSE:E$="CAN'T READ HEADER PROPERLY":RESUME 1000 3310 IF ERR=61 THEN PRINT:PRINT"Out of disk space.":PRINT:CLOSE:RESUME 1000 3312 IF ERR=53 THEN E$="FILE NOT FOUND":RESUME 1080 3320 ON ERROR GOTO 0 3330 ' UCV 3340 Y$="" 3350 FOR K=1 TO LEN(X$) 3360 Y$=Y$+" " 3370 X=ASC(MID$(X$,K, 1)) 3380 IF 963 THEN 1100 1130 PL=A-1 1140 GOSUB 1870 ' align labels 1150 ' RECORD WORK LOOP 1160 C2=0 ' first time 1170 LC=0 ' count 1180 ' 1190 FOR I=T1 TO T2 ' <==== FOR 1200 GOSUB 2210 ' get rec 1205 IF ASC(T$)=0 THEN PRINT"0";:GOTO 1720 1210 PRINT"+"; 1220 T1$=T$ ' save it 1230 IF SKIPPARSE=1 THEN 1250 1240 GOSUB 1780 ' parse record string 1250 IF SEARCH=0 THEN 1540 1260 ' SEARCH 1270 IF SEARCH<>2 THEN 1320 1275 ' FIND 1280 IF INSTR(T$,SEARCHWORD$(0))=0 THEN 1720 1300 GOSUB 1780 ' parse 1310 GOTO 1540 1320 ' FIELD SEARCH 1330 J=0 ' check for skips first 1340 IF SKIPWORD$(J)="" THEN 1420 ' try search then 1350 IF LOOKFIELD(J)<>0 THEN 1390 ' look in field 1360 IF INSTR(T1$,SKIPWORD$(J))<>0 THEN 1720 ' whole rec search - skip it 1370 J=J+1 1380 GOTO 1340 1390 IF INSTR(B$(LOOKFIELD(J)),SKIPWORD$(J))<>0 THEN 1720 ' field compare - skip 1395 IF B$(LOOKFIELD(J))="" AND SKIPWORD$(J)="_" THEN 1720 'blank 1400 J=J+1 1410 GOTO 1340 1420 IF SEARCHWORD$(0)="" THEN 1520 ' don't care so print it 1430 J=0: GOTO 1450 ' now search 1440 IF SEARCHWORD$(J)="" THEN 1720 ' hesitate no longer 1450 IF SEARCHFIELD(J)<>0 THEN 1490 ' field 1460 IF INSTR(T1$,SEARCHWORD$(J))<>0 THEN 1520 ' found it 1470 J=J+1 1480 GOTO 1440 1490 IF INSTR(B$(SEARCHFIELD(J)),SEARCHWORD$(J))<>0 THEN 1520 1495 IF B$(SEARCHFIELD(J))="" AND SEARCHWORD$(J)="_" THEN 1520 1500 J=J+1 1510 GOTO 1440 1520 ' GET READY TO DO IT 1530 IF SKIPPARSE=1 THEN GOSUB 1780 ' parse 1540 ' PAUSE CONTROLS (TERM DEP IF UPPERCASE ONLY) 1541 GOSUB 2030 ' exit returns A 1542 IF A=122 THEN 1560 ' z means go on 1543 PRINT I;B$(1);TAB(30);"Ready (SPACE/z/r/n/ESC) >"; 1544 A$=INPUT$(1):A=ASC(A$):IF A=27 THEN CLOSE 3:GOTO 1740 1545 PRINT A$:IF A=13 OR A=32 OR A=122 THEN 1560 1546 IF A=114 THEN I=IPREV:GOTO 1200 ' r 1547 IF A=110 THEN 1548 ELSE 1540 ' n or loop 1548 INPUT"Enter number of desired record: ";I:GOTO 1200 1550 GOSUB 2030 ' exit 1560 ' PRINT LABEL 1562 LC=LC+1:IPREV=I 1570 IF PL=1 THEN GOSUB 2290 ' reformat medium to short form 1575 IF PL=2 THEN GOSUB 2090 ' reformat long to short form 1580 IF P9=0 THEN PRINT 1590 PRINT"("I")" 1600 T3=0 ' counts blank lines 1610 FOR J=1 TO 3 1620 IF B$(J)="" OR B$(J)=" " THEN T3=T3+1: GOTO 1640 1630 IF P9=1 THEN LPRINT B$(J) ELSE PRINT B$(J) 1640 NEXT J 1650 IF P9=1 THEN LPRINT B$(4); ELSE PRINT B$(4); 1660 IF P9=1 THEN IF LPOS(0)<15 THEN LPRINT TAB(15); 1670 IF P9=0 THEN IF POS(0)<15 THEN PRINT TAB(15); 1680 IF P9=1 THEN LPRINT" "B$(5) ELSE PRINT" "B$(5) 1690 FOR J=1 TO T3+2 1700 IF P9=1 THEN LPRINT ELSE PRINT 1710 NEXT J 1720 GOSUB 2030 ' check exit 1730 NEXT I ' END OF RECORD WORK LOOP 1740 ' FINISH 1750 IF P9 THEN LPRINT"count:"LC:FOR J=1 TO 5:LPRINT:NEXT 1760 PRINT:PRINT:PRINT TAB(32)"Re-loading DEDIT. 1770 CHAIN DD$(1)+"DEDIT",1000 1780 ' (SUB) PARSE STRING 1790 K=0 1800 M=INSTR(T$,CHR$(126)) ' delimiter 1810 IF M=0 THEN RETURN 1820 K=K+1 1830 B$(K)="" 1840 B$(K)=MID$(T$,1,M-1) 1850 T$=MID$(T$,M+1) 1860 GOTO 1800 1870 ' (SUB) ALIGN LABELS 1880 PRINT"Print test label? (y/n) "; 1890 A$=INPUT$(1): PRINT A$: IF A$=CHR$(13) THEN A$="y" 1900 IF A$="n" THEN RETURN 1910 IF A$<>"y" THEN 1880 1920 A$(1)="<------- Dan Dugan Sound Design ------>" ' 39 wide 1930 A$(2)="File: "+F$+" Date:" 1940 A$(3)="Selection:" 1950 IF P9 THEN LPRINT A$(1) ELSE PRINT A$(1) 1960 IF P9 THEN LPRINT A$(2) ELSE PRINT A$(2) 1970 IF P9 THEN LPRINT A$(3) ELSE PRINT A$(3) 1980 IF P9 THEN LPRINT A$(1) ELSE PRINT A$(1) 1990 FOR J=1 TO 2 2000 IF P9=1 THEN LPRINT ELSE PRINT 2010 NEXT J 2020 GOTO 1870 2030 ' (SUB) EXIT TEST (TERM DEP) 2040 X$=INKEY$ 2042 IF X$<>"" THEN A=ASC(X$) 2045 IF A=27 THEN CLOSE 3:GOTO 1740 'use ESC to escape listing 2050 RETURN 2060 ' (SUB) CLEAR SCREEN (TERM DEP) 2070 PRINT CHR$(12); 2080 RETURN 2090 ' (SUB) LONG FORM LABEL RE-FORMAT 2100 IF B$(1)="" AND B$(2)="" OR B$(3)="" THEN 2190 2110 IF B$(2)="" THEN B$(1)=B$(1)+", "+B$(3): GOTO 2130 2120 B$(1)=B$(2)+" "+B$(1)+", "+B$(3) 2130 IF LEN(B$(1))>39 THEN B$(1)=LEFT$(B$(1),39) 2140 B$(2)=B$(4) 2150 B$(3)=B$(5) 2160 B$(4)=B$(6) 2170 B$(5)=B$(7) 2180 RETURN 2190 IF B$(2)+B$(1)="" THEN B$(1)=B$(3) ELSE IF B$(2)="" THEN B$(1)=B$(1) ELSE B$(1)=B$(2)+" "+B$(1) 2200 GOTO 2130 2210 ' (SUB) GET RECORD "I" IN T$ 2220 T$="" ' necessary! 2230 ON FT GOTO 2260,2240 2240 GET#1,FT*I+2 ' latter half 2250 T$=LEFT$(R$,127) 2260 GET#1,FT*I+1 ' whole or first half 2270 T$=R$+T$ 2280 RETURN 2290 ' (SUB) MEDIUM FORM RE-FORMAT 2300 B$(1)=B$(2)+" "+B$(1) 2310 B$(2)=B$(3) 2320 B$(3)=B$(4) 2330 B$(4)=B$(5) 2340 B$(5)=B$(6) 2350 RETURN  RE-FORMAT 23=ASC(X$) 2045 IF A=27 THEN CLOSE 3:GOTO 1740 'use ESC to escape listing 2050 RETURN 2060 ' (SUB) CLEAR SCREEN (TERM DEP) 2070 PRINT CHR$(12); 2080 RETURN 2090 ' (SUB) LONG FORM LABEL RE-FORMAT 2100 IF B$(1)="" AND B$(2)="" OR B$(3)="" THEN 2190 2110 IF B$(2)="" THEN B$(1)=B$(1)+", "+B$(3): GOTO 2130 2120 B$(1)=B$(2)+" "+B$(1)+", "+B$(3) 2130 IF LEN(B$(1))>39 THEN B$(1)=LEFT$(B$(1),39) 2140 B$(2)=B$(4) 2150 B$(3)=B$(5) 2160 B$(4)=B$(6) 2170 B$(5)=B$(7) 2180 RETURN 2190 IF 10 PRINT"This program must be entered via DIMS. 20 STOP 1000 GOSUB 1930 'cs 1010 PRINT:PRINT TAB(25);"DLETTERS 1.02 - October 17, 1982 1015 ' by Dan Dugan -- public domain 1020 PRINT:PRINT"In this program you control printing in the same way that 1030 PRINT"you control listing on the screen in DEDIT. The 'pause prompt' 1040 PRINT"Ready> will accept SPACE or RETURN to print, 'z' to print and keep 1050 PRINT"going without pausing, or ESCAPE to abort and return to DEDIT. 1051 PRINT:PRINT"It will also accept two commands special to the letters 1052 PRINT"program. 'r' will cause the previous letter to repeat, and 1053 PRINT"'n' will ask for a record number to start from. 1060 PRINT:PRINT"While printing without pause, hitting the space bar during 1070 PRINT"a letter will cancel the 'z' and cause the program to pause before 1080 PRINT"starting the next letter. 1090 ON ERROR GOTO 1780 1100 DEFINT A-Z 1110 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$ 1130 GOTO 1160 1140 PRINT:PRINT"Wait while editor program is re-loaded 1150 CHAIN DD$(1)+"DEDIT",1000 1160 ' PRINT LETTER SET-UP 1170 INPUT"Enter text file name (use prefix: to identify disk)"; G$ 1180 IF G$="x" OR G$="" THEN 1670 1190 X$=G$: GOSUB 1810 ' UCV 1200 G$=Y$ 1210 OPEN "I",3,G$ ' test 1220 CLOSE 3 1230 ' RECORD WORK LOOP 1240 C2=0 ' first time 1250 ' 1260 FOR I=T1 TO T2 ' <==== FOR 1270 GOSUB 2510 ' get rec 1280 IF ASC(T$)=0 THEN PRINT"0";:GOTO 1640 ELSE PRINT"+"; 1290 T1$=T$ ' save it 1300 IF SKIPPARSE=1 THEN 1320 1310 GOSUB 1690 ' parse record string 1320 IF SEARCH=0 THEN 1620 1330 ' SEARCH 1340 IF SEARCH<>2 THEN 1410 1350 IF INSTR(T$,SEARCHWORD$(0))=0 THEN 1640 1360 ' speed search 1370 LPRINT CHR$(7); ' found it 1380 GOSUB 1690 ' parse 1390 GOTO 1620 1400 ' field search 1410 J=0 ' check for skips first 1420 IF SKIPWORD$(J)="" THEN 1500 ' try search then 1430 IF LOOKFIELD(J)<>0 THEN 1470 ' look in field 1440 IF INSTR(T1$,SKIPWORD$(J))<>0 THEN 1640 1450 J=J+1 1460 GOTO 1420 1470 IF INSTR(B$(LOOKFIELD(J)),SKIPWORD$(J))<>0 THEN 1640 1475 IF B$(LOOKFIELD(J))="" AND SKIPWORD$(J)="_" THEN 1640 1480 J=J+1 1490 GOTO 1420 1500 IF SEARCHWORD$(0)="" THEN 1600 ' don't care so print it 1510 J=0: GOTO 1530 ' now search 1520 IF SEARCHWORD$(J)="" THEN 1640 1530 IF SEARCHFIELD(J)<>0 THEN 1570 ' field 1540 IF INSTR(T1$,SEARCHWORD$(J))<>0 THEN 1600 ' found it 1550 J=J+1 1560 GOTO 1520 1570 IF INSTR(B$(SEARCHFIELD(J)),SEARCHWORD$(J))<>0 THEN 1600 1575 IF B$(SEARCHFIELD(J))="" AND SEARCHWORD$(J)="_" THEN 1600 1580 J=J+1 1590 GOTO 1520 1600 LPRINT CHR$(7); 1610 IF SKIPPARSE=1 THEN GOSUB 1690 ' parse 1620 ' zag to do it 1630 GOTO 1960 1640 ' END OF RECORD WORK LOOP 1650 IPREV=I ' for repeat command 1660 NEXT 1670 ' FINISH 1680 GOTO 1140 ' exit 1690 ' (SUB) PARSE STRING 1700 K=0 1710 J=INSTR(T$,CHR$(126)) ' delimiter 1720 IF J=0 THEN RETURN 1730 K=K+1 1740 B$(K)=MID$(T$,1,J-1) 1750 T$=MID$(T$,J+1) 1760 GOTO 1710 1770 ' ERROR HANDLING 1780 IF ERL=1210 AND ERR=53 THEN CLOSE 3:PRINT"FILE NOT FOUND": RESUME 1160 1790 IF ERL=1210 AND ERR=64 THEN CLOSE 3:PRINT"UNACCEPTABLE FILE NAME": RESUME 1160 1800 ON ERROR GOTO 0 1810 ' (SUB) UCV 1820 Y$="" 1830 FOR J=1 TO LEN(X$) 1840 Y$=Y$+" " 1850 X=ASC(MID$(X$,J, 1)) 1860 IF 96"" THEN X=ASC(X$) 1915 IF X=27 THEN CLOSE 3:GOTO 1670 ' use ESC to escape listing 1920 RETURN 1930 ' (SUB) CLEAR SCREEN (TERM DEP) 1940 PRINT CHR$(12); 1950 RETURN 1960 ' PRINT LETTER (insert above) 1970 ' PAUSE CONTROLS (TERM DEP if uppercase) 1980 GOSUB 1900 ' exit 2000 IF X=122 THEN 2090 ' go on 2010 PRINT I;B$(1);TAB(20);"Ready>"; 2020 A$=INPUT$(1):PRINT A$ 2030 IF A$=CHR$(13) OR A$=CHR$(32) THEN 2090 2040 IF A$="z" THEN 2090 2050 IF A$="r" THEN I=IPREV:GOTO 1270 2060 IF A$="n" THEN 2070 ELSE 2080 2070 INPUT"Enter number of desired record: ";I:GOTO 1270 2080 GOTO 1970 ' loop 2090 ' DO IT 2100 C1=0 'counts data lines 2110 OPEN "I",3,G$ ' open each time to restore 2120 IF P9=0 THEN GOSUB 1930 ' clear screen 2130 IF EOF(3) THEN 2140 ELSE 2180 2140 ' END OF TEXT FILE 2150 IF P9=1 THEN LPRINT CHR$(12); ' form feed 2160 CLOSE 3 2170 GOTO 1640 ' next record 2180 ' GET LINE & TEST 2190 LINE INPUT #3,L$ 2200 IF LEFT$(L$,3)=".da" THEN 2210 ELSE 2450 2210 ' LINE IS DATA LINE 2220 C1=C1+1:IF C1>NC THEN 2130 2230 ON C1 GOTO 2240, 2310, 2340, 2370, 2400, 2430 ' six lines 2240 ' FIRST DATA LINE 2250 IF B$(1)="" AND B$(2)="" THEN 2300 2260 IF B$(1)="" THEN A$=B$(2):GOTO 2300 2270 IF B$(2)="" THEN A$=B$(1):GOTO 2300 2280 A$=B$(2)+CHR$(32)+B$(1) 2290 GOSUB 2480 2300 GOTO 2130 2310 ' DATA LINE 2 2320 IF B$(3)="" THEN 2130 2330 A$=B$(3):GOSUB 2480:GOTO 2130 2340 ' DATA LINE 3 2350 IF B$(4)="" THEN 2130 2360 A$=B$(4):GOSUB 2480:GOTO 2130 2370 ' DATA LINE 4 2380 IF B$(5)="" THEN 2130 2390 A$=B$(5):GOSUB 2480:GOTO 2130 2400 ' DATA LINE 5 2410 A$=B$(6)+CHR$(32)+B$(7) 2420 GOSUB 2480:GOTO 2130 2430 ' DATA LINE 6 2440 A$=B$(10):GOSUB 2480:GOTO 2130 2450 ' PRINT TEXT LINE 2460 IF P9 THEN LPRINT L$ ELSE PRINT L$ 2470 GOTO 2130 2480 ' (SUB) PRINT DATA LINE 2490 IF P9 THEN LPRINT A$ ELSE PRINT A$ 2500 RETURN 2510 ' GET RECORD "I" IN T$ SUB 2520 T$="" ' necessary! 2530 ON FT GOTO 2560,2540 2540 GET#1,FT*I+2 ' latter half 2550 T$=LEFT$(R$,127) 2560 GET#1,FT*I+1 ' whole or first half 2570 T$=R$+T$ 2580 RETURN  2540 GET#1,FT*I+2 ' latter half 2550 T$=LEFT$(R$,127) 2560 GET#1,FT*I+1 ' w=B$(2):GOTO 2300 2270 IF B$(2)="" THEN A$=B$(1):GOTO 2300 2280 A$=B$(2)+CHR$(32)+B$(1) 2290 GOSUB 2480 2300 GOTO 2130 2310 1000 GOSUB 1790 'cs 1010 PRINT:PRINT TAB(27);"NADIN 1.02 - October 9, 1983 1020 ' by Dan Dugan -- public domain 1030 PRINT:PRINT"Inputs from a NAD-like data file to a DIMS 'standard' format mailing list. 1040 PRINT 1050 DEFINT A-Z 1060 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$ 1070 DIM V$(5) 1080 ' OPEN SOURCE FILE 1090 PRINT:INPUT"Name of source file";X$ 1100 GOSUB 1820:F2$=Y$ 'ucv 1110 IF MID$(F2$,2,1)=":" THEN 1130 1120 F2$=DD$(5)+F2$ 1130 ' TEST FOR EXISTENCE 1140 ON ERROR GOTO 1170 1150 OPEN"I",3,F2$ 1160 ON ERROR GOTO 0:GOTO 1210 'ok 1170 CLOSE 3 1180 IF ERR=53 THEN CLOSE 3:PRINT"File not found":RESUME 1080 1190 IF ERR=64 THEN PRINT"Bad file name, try again.":RESUME 1080 1200 ON ERROR GOTO 0 1210 ' READ FILE, PARSE 1220 GOSUB 1740 'exit 1230 IF EOF(3) THEN 1690 1240 FOR I=1 TO NC:B$(I)="":NEXT:NR=NR+1 1250 LINE INPUT #3,L$ 1260 PRINT L$ 1270 L1$=MID$(L$,2,92):STATE$=MID$(L$,97,2):ZIP$=MID$(L$,102,5):NOTE$=MID$(L$,110,13):L$="" 1280 X=INSTR(L1$,"*") 1281 IF X<>0 THEN 1290 1282 X=INSTR(L1$,CHR$(34)) 1283 X$=LEFT$(L1$,X-1):GOSUB 1940:V$(1)=X$:V$(2)="":L1$=MID$(L1$,X+3):GOTO 1320 1290 V$(1)=LEFT$(L1$,X-1):L1$=MID$(L1$,X+1) 1300 X=INSTR(L1$,CHR$(34)) 1310 X$=LEFT$(L1$,X-1):GOSUB 1940:V$(2)=X$:L1$=MID$(L1$,X+3) 1320 X=INSTR(L1$,CHR$(34)) 1330 V$(3)=LEFT$(L1$,X-1):L1$=MID$(L1$,X+3) 1340 X=INSTR(L1$,CHR$(34)) 1350 V$(4)=LEFT$(L1$,X-1) 1360 V$(5)=MID$(L1$,X+3):L1$="" 1370 ' PUT INTO DIMS ARRAY 1380 B$(1)=V$(1) 1390 B$(2)=V$(2) 1400 IF V$(4)="" THEN 1410 ELSE 1430 1410 B$(3)="":B$(4)=V$(3):B$(5)=V$(5)+" "+STATE$:B$(6)=ZIP$ 1420 X$=NOTE$:GOSUB 1910:B$(9)=X$:GOTO 1450 1430 B$(3)=V$(3):B$(4)=V$(4):B$(5)=V$(5)+" "+STATE$:B$(6)=ZIP$ 1440 X$=NOTE$:GOSUB 1910:B$(9)=X$ 1450 ' ADD RECORD TO DIMS FILE 1460 T$="" 1470 FOR J=1 TO NC 1480 IF LEN(T$)+LEN(B$(J))+1>FT*128 THEN PRINT"Record too long." 1490 T$=T$+B$(J)+CHR$(126) 1500 NEXT 1510 N=N+1:PRINT N;T$ 1520 GOSUB 1550:PRINT"*";:GOSUB 1620:PRINT"!":C=1 1530 ' LOOP 1540 GOTO 1210 1550 ' (SUB) WRITE T$ AS RECORD # N 1560 ON FT GOTO 1590,1570 1570 LSET R$=MID$(T$,129) 'latter half 1580 PUT #1,FT*N+2 1590 LSET R$=LEFT$(T$,128) 'first half 1600 PUT #1,FT*N+1 1610 RETURN 1620 ' (SUB) WRITE T$ AS DUPE REC N 1630 ON FT GOTO 1660,1640 1640 LSET S$=MID$(T$,129) 1650 PUT #2,FT*N+2 1660 LSET S$=LEFT$(T$,128) 1670 PUT #2,FT*N+1 1680 RETURN 1690 ' FINISH 1700 CLOSE 3 1710 PRINT:PRINT NR"records added. 1720 PRINT:PRINT TAB(32)"Re-loading DEDIT. 1730 CHAIN DD$(1)+"DEDIT",1000 1740 ' EXIT TEST (TERM DEP) 1750 X$=INKEY$:X=0 1760 IF X$<>"" THEN X=ASC(X$) 1770 IF X=27 THEN CLOSE 3:GOTO 1690 'use ESC to escape listing 1780 RETURN 1790 ' CLEAR SCREEN (TERM DEP) 1800 PRINT CHR$(12); 1810 RETURN 1820 ' (SUB) UCV 1830 Y$="" 1840 FOR K=1 TO LEN(X$) 1850 Y$=Y$+CHR$(32) 1860 X=ASC(MID$(X$,K,1)) 1870 IF 96"" THEN X=ASC(X$) 1770 IF X=27 THEN CLOSE 3:GOTO 1690 'use ESC to escape listing 1780 RETURN 1790 ' CLEAR SCREEN (TERM DEP) 1800 PRINT CHR$(12); 1810 RETURN 1820 ' (SUB) UCV 1830 Y$="" 1840 FOR K=1 TO LEN(X$) 1850 Y$=Y$+CHR$(32) 1860 X=ASC(MID$(X$,K,1)) 10 PRINT"This program must be entered via DIMS. 20 STOP 1000 GOSUB 5840 'cs 1010 PRINT:PRINT TAB(25);"DPUT 1.03 - November 1, 1983 1015 ' by Dan Dugan -- public domain 1020 PRINT 1030 DEFINT A-Z 1040 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 ' OPEN OUTPUT FILE 1070 PRINT:INPUT"Name of destination file";X$ 1080 GOSUB 5950 'ucv 1085 F2$=Y$ 1090 ' DISK NAME 1100 IF MID$(F2$,2,1)=":" THEN 1120 1110 F2$=DD$(5)+F2$ 1120 ' TEST FOR EXISTENCE 1130 ON ERROR GOTO 1160 1140 OPEN"I",3,F2$ 1150 CLOSE 3:ON ERROR GOTO 0 1152 PRINT:PRINT F2$" exists already. Use a different name.":GOTO 1060 1160 CLOSE 3 1170 IF ERR=53 THEN RESUME 1210 'not found 1180 IF ERR=61 THEN PRINT:PRINT"Sorry, disk full.":RESUME 5650 'exit 1190 IF ERR=64 THEN PRINT"Bad file name, try again.":RESUME 1060 1195 IF ERR=67 THEN PRINT:PRINT"Out of directory space.":RESUME 5650 1200 ON ERROR GOTO 0 1210 ' OPEN NEW FILE 1220 OPEN"O",3,F2$ 1230 NR=0 5000 ' RECORD WORK LOOP 5030 ' 5040 FOR I=T1 TO T2 ' <==== FOR 5050 GOSUB 5870 ' get rec 5060 IF ASC(T$)=0 THEN PRINT"0";:GOTO 5630 5070 PRINT"+"; 5075 GOSUB 7000 'strip linefeeds 5080 T1$=T$ ' save it 5090 IF SKIPPARSE=1 THEN 5110 5100 GOSUB 5700 ' parse record string 5110 IF SEARCH=0 THEN 5500 5120 ' SEARCH 5130 IF SEARCH<>2 THEN 5180 5135 ' FIND 5140 IF INSTR(T$,SEARCHWORD$(0))=0 THEN 5630 5160 GOSUB 5700 ' parse 5170 GOTO 5500 5180 ' FIELD SEARCH 5190 J=0 ' check for skips first 5200 IF SKIPWORD$(J)="" THEN 5280 ' try search then 5210 IF LOOKFIELD(J)<>0 THEN 5250 ' look in field 5220 IF INSTR(T1$,SKIPWORD$(J))<>0 THEN 5630 ' whole rec search - skip it 5230 J=J+1 5240 GOTO 5200 5250 IF INSTR(B$(LOOKFIELD(J)),SKIPWORD$(J))<>0 THEN 5630 ' field compare - skip 5255 IF B$(LOOKFIELD(J))="" AND SKIPWORD$(J)="_" THEN 5630 5260 J=J+1 5270 GOTO 5200 5280 IF SEARCHWORD$(0)="" THEN 5380 ' don't care so print it 5290 J=0: GOTO 5310 ' now search 5300 IF SEARCHWORD$(J)="" THEN 5630 ' hesitate no longer 5310 IF SEARCHFIELD(J)<>0 THEN 5350 ' field 5320 IF INSTR(T1$,SEARCHWORD$(J))<>0 THEN 5380 ' found it 5330 J=J+1 5340 GOTO 5300 5350 IF INSTR(B$(SEARCHFIELD(J)),SEARCHWORD$(J))<>0 THEN 5380 5355 IF B$(SEARCHFIELD(J))="" AND SEARCHWORD$(J)="_" THEN 5380 5360 J=J+1 5370 GOTO 5300 5380 ' GET READY TO DO IT 5390 IF SKIPPARSE=1 THEN GOSUB 5700 ' parse 5500 ' DO WORK 5510 PRINT CHR$(40);I;CHR$(41) 5520 FOR J=1 TO NC 5530 IF C(J)=0 THEN 5610 5540 ' Substitute "~" for quote chars. 5550 QUOTE=INSTR(B$(J),CHR$(34)) 5560 IF QUOTE THEN MID$(B$(J),QUOTE,1)=CHR$(126):GOTO 5550 5570 ' Put quotes around strings with commas in 'em 5580 IF INSTR(B$(J),CHR$(44)) THEN B$(J)=CHR$(34)+B$(J)+CHR$(34) 5590 IF J>1 THEN PRINT#3,CHR$(44);:PRINT CHR$(44); 5600 PRINT#3,B$(J);:PRINT B$(J); 5610 NEXT 5620 PRINT#3,:PRINT:NR=NR+1 5630 GOSUB 5790 ' check exit 5640 NEXT I ' END OF RECORD WORK LOOP 5650 ' FINISH 5660 CLOSE 3 5670 PRINT:PRINT NR"records. 5680 PRINT:PRINT TAB(32)"Re-loading DEDIT. 5690 CHAIN DD$(1)+"DEDIT",1000 5700 ' PARSE STRING 5710 K=0 5720 M=INSTR(T$,CHR$(126)) ' delimiter 5730 IF M=0 THEN RETURN 5740 K=K+1 5750 B$(K)="" 5760 B$(K)=MID$(T$,1,M-1) 5770 T$=MID$(T$,M+1) 5780 GOTO 5720 5790 ' (SUB) EXIT TEST 5800 X$=INKEY$:X=0 5810 IF X$<>"" THEN X=ASC(X$) 5820 IF X=27 THEN CLOSE 3:GOTO 5650 'use ESC to escape process 5830 RETURN 5840 ' (SUB) CLEAR SCREEN (TERM DEP) 5850 PRINT CHR$(12); 5860 RETURN 5870 ' (SUB) GET RECORD "I" IN T$ 5880 T$="" ' necessary! 5890 ON FT GOTO 5920,5900 5900 GET#1,FT*I+2 ' latter half 5910 T$=LEFT$(R$,127) 5920 GET#1,FT*I+1 ' whole or first half 5930 T$=R$+T$ 5940 RETURN 5950 ' (SUB) UCV 5960 Y$="" 5970 FOR K=1 TO LEN(X$) 5980 Y$=Y$+CHR$(32) 5990 X=ASC(MID$(X$,K,1)) 6000 IF 96"" THEN X=ASC(X$) 5820 IF X=27 THEN CLOSE 3:GOTO 5650 'use ESC to escape process 5830 RETURN 5840 ' (SUB) CLEAR SCREEN (TERM DEP) 5850 PRINT CHR$(12); 5860 RETURN 5870 ' (SUB) GET RECORD "I" IN T$ 5880 T$="" ' necessary! 5890 ON FT GOTO 5920,5900 5900 GET#1,FT*I+2 ' latter half 5910 T$=LEFT$(R$,127) 5920 GET#1,FT*I+1 ' whole or first half 5930 T$=R$+T$ 5940 RETURN 5950 ' (SUB) UCV 5960 Y$="" 5970 FOR K=1 TO LEN(X$) 5980 Y$=Y$+CHR$(32) 5990 X=ASC(MID$(X$,K,1)) 6000 IF 96NC THEN PRINT"Field"S(I,1)"??? Enter again." GOTO 1280 1310 S(I,2)=0:IF RIGHT$(N$(S(I,1)),1)="n" THEN S(I,2)=1 ELSE S6=0 1320 '(if just one is alpha, do alpha sort) 1330 INPUT"Number of characters in field to use (RETURN for all)";S(I,3) 1332 IF S(I,3) THEN 1334 ELSE 1340 1334 S(I,4)=0:PRINT"Do you want to pad shorter fields to that length? (n/y) "; :A$=INPUT$(1):IF A$=CHR$(13) THEN A$="n" 1335 PRINT A$:IF A$="y" THEN S(I,4)=1 1340 IF S(I,3) THEN 1350 ELSE PRINT"You want to sort on all characters of "; :GOTO 1360 1350 PRINT"You want to sort on the first"S(I,3)"characters of "; 1360 PRINT LEFT$(N$(S(I,1)),4)"? (y/n) ";: A$=INPUT$(1):IF A$=CHR$(13) THEN A$="y" 1370 PRINT A$:IF A$="x" THEN 3400 1380 IF A$<>"y" THEN PRINT"Entry cancelled; ready for key"I"again.":GOTO 1280 1390 IF S(I,3) THEN KLEN=KLEN+S(I,3) ELSE KLEN=KLEN+10:KLENFLAG=1 1400 PRINT 1410 NEXT I 1420 NK=I-1 1430 IF S(1,1)=0 THEN 3400 'quit 1435 GOTO 1480 'skip this because of bug in desc. sort 1440 PRINT:PRINT"Ascending order? (y/n) "; 1450 A$=INPUT$(1): IF A$=CHR$(13) THEN A$="y" 1460 PRINT A$: IF A$="n" THEN S8=1 1470 IF A$="x" THEN 3400 1480 ' OUTPUT SWITCH (P7) 1490 P7=0 1500 PRINT:PRINT"Shall the product of the sort overlay the original file? (y/n) "; 1510 A$=INPUT$(1): IF A$=CHR$(13) THEN A$="y" 1520 PRINT A$:IF A$="x" THEN 3400 1530 IF A$="n" THEN P7=1:GOTO 1600 1540 IF A$<>"y" THEN 1500 1550 ' YES, OVERLAY 1560 IF (T1=1 AND T2=N) OR S9=1 THEN 1630 1570 PRINT:PRINT"NOT ALLOWED - Overlaying part of file on file will erase records 1580 PRINT"outside of range.": PRINT:GOTO 1480 1590 ' NAME OUTPUT FILE 1600 PRINT:INPUT"Name of sort product file (no prefix or suffix) ";F2$ 1610 IF F2$="" THEN 1480 1620 X$=F2$:GOSUB 3920:F2$=Y$ ' ucv 1630 ' SHOW SORT SET-UP 1640 GOSUB 4010 'cs 1650 PRINT"SETUP FOR SORT 1660 PRINT: IF T1=1 AND T2=N THEN PRINT"Sort all records ("N")": GOTO 1710 1670 PRINT"Sorting range of records from"T1"to"T2" 1680 ON S9+1 GOTO 1690,1700 1690 PRINT"The output will be the range of records only.": GOTO 1710 1700 PRINT"The output will be the entire file with the selected range sorted. 1710 PRINT:PRINT"Records will be put in order by examining": PRINT"the contents of the sort key fields." 1720 PRINT:FOR I=1 TO NK 1730 PRINT TAB(29);:PRINT USING"##";I;: PRINT". "LEFT$(N$(S(I,1)),4); 1740 PRINT TAB(40);:IF S(I,3) THEN PRINT S(I,3) ELSE PRINT" all" 1750 NEXT I 1760 PRINT:IF KLENFLAG THEN 1762 ELSE 1766 1762 PRINT"ESTIMATED string space needed for the key array is"KLEN*(T2-T1+1): GOTO 1768 1766 PRINT"String space needed for the key array is"KLEN*(T2-T1+1) 1768 PRINT"and the available space is"FRE(X$)". 1770 PRINT"This program can't tell whether there is enough space on disk " DD$(5)" for tempo- 1780 PRINT"rary storage of the key array. 1790 PRINT:PRINT"The records will be sorted in "; 1800 IF S8=0 THEN PRINT"ascending ";: GOTO 1820 1810 PRINT"descending "; 1820 IF S6=0 THEN PRINT"alphabetical ";: GOTO 1840 1830 PRINT"numerical "; 1840 PRINT"order." 1850 PRINT: PRINT"The output of the sort will "; 1860 IF P7=0 THEN PRINT"overlay the original file.":GOTO 1880 1870 PRINT"create a new DIMS file "F2$" on disk "DD$(4)"." 1880 PRINT:IF P7=0 AND (T1<>1 OR T2<>N) AND S9=0 THEN PRINT"You are aware that this process will erase records? 1885 IF P7 THEN 1890 ELSE 1900 1890 PRINT"The new file "F2$" will replace the safety copy of "F$". 1892 PRINT"You must then use PIP to move "F2$" to another disk, 1894 PRINT"and use the DEDIT 'backup' command on "F$" to re-create a 1896 PRINT"safety copy. 1900 ' FINAL APPROVAL 1910 PRINT:PRINT"Is this exactly what you want? (y/n) "; 1920 A$=INPUT$(1): IF A$=CHR$(13) THEN A$="y" 1930 PRINT A$ 1940 IF A$="x" THEN 3400 1950 IF A$="n" THEN PRINT"Try again.":GOTO 1090 1960 IF A$<>"y" THEN GOTO 1910 1970 GOTO 2110 1980 ' SORT CONTROLS GUIDE 1990 ' S() array holds key orders (field#, num? (1=num), length, pad?) 2000 ' NK = number of keys specified 2010 ' S6 = 0 alpha sort 2020 ' 1 numeric sort 2030 ' S7 = 0 don't rename dupe file 2040 ' 1 rename dupe file as F2$.D 2050 ' S8 = 0 ascending order 2060 ' 1 descending order 2070 ' S9 = 0 output only sorted range of records 2080 ' 1 output records above and below sorted range 2090 ' P7 = 0 overlay main file 2100 ' 1 output to named file 2110 ' PUT KEYS IN TEMP FILE 2120 GOSUB 4010 2130 PRINT"SORTING '"F$"' 2140 PRINT:PRINT"Extracting keys.":PRINT 2150 OPEN"O",3,DD$(5)+"KEYS.$$$" 2160 FOR I=T1 TO T2 2170 GOSUB 4270:GOSUB 4110 ' get record 2180 IF ASC(T$)=0 THEN X$=CHR$(126)+"(del)":GOTO 2320 ' sorts deletes to end 2190 GOSUB 3540 ' parse 2200 X$="" 2210 FOR X=1 TO NK 2220 IF S(X,3) THEN 2230 ELSE X$=X$+B$(S(X,1))+CHR$(32):GOTO 2280 2230 Z$=LEFT$(B$(S(X,1)),S(X,3)) 2240 Y=LEN(Z$) 2250 IF S(X,2)=1 THEN Y$=STRING$(S(X,3)-Y,CHR$(48)): X$=X$+Y$+Z$:GOTO 2280 'pad num field with left 0's 2252 IF S(X,4) THEN 2260 ELSE Y$="":GOTO 2270 2260 Y$=STRING$(S(X,3)-Y,CHR$(32)) 'spaces to pad right 2270 X$=X$+Z$+Y$ 2280 NEXT 2290 IF X$="" THEN X$=CHR$(126):GOTO 2320 ' makes empties go later 2300 IF S6 THEN 2320 2310 GOSUB 3920:X$=Y$ 'ucv 2320 PRINT I,X$ 2330 PRINT#3,X$ 2340 NEXT 2350 CLOSE 3 2360 ' LOAD INDEX AND KEY ARRAYS 2370 PRINT:PRINT"Loading key array:":PRINT 2380 OPEN"I",3,DD$(5)+"KEYS.$$$" 2390 I=T1:J=1:D$(0)=CHR$(0) 2400 IF EOF(3) THEN 2450 2410 LINE INPUT#3,D$(J) 2420 D(J)=I 2430 I=I+1:J=J+1 2440 GOTO 2400 2450 CLOSE 3 2460 KILL DD$(5)+"KEYS.$$$" 2470 ' READY TO SORT ARRAY 2480 PRINT:PRINT"Sorting array.":PRINT 2490 ' from QUICKSORT by Sylvan Rubin DDJ #33 p.42 2500 LND=1:HND=J-1:STP=0 2510 ' PARTITION 2520 GOSUB 4270 'exit 2530 IF LND>=HND THEN 2910 ' pop stack 2540 PRINT CHR$(80);:CTR=INT((LND+HND+1)/2) ' use center for pivot 2550 SWAP D(CTR),D(HND):SWAP D$(CTR),D$(HND) 2560 LO=LND-1:HI=HND 2570 PIV$=D$(HND):GOTO 2600 ' scan-l 2580 ' EXCHANGE 2590 SWAP D(LO),D(HI):SWAP D$(LO),D$(HI) 2600 ' SCAN-L 2610 LO=LO+1:ON S6+1 GOTO 2620,2630 ' alph, num 2620 ON S8+1 GOTO 2640,2650 ' asc, desc 2630 ON S8+1 GOTO 2660,2670 2640 IF D$(LO)PIV$ THEN 2610 ELSE 2680 2660 IF VAL(D$(LO))VAL(PIV$) THEN 2610 ELSE 2680 2680 ' SCAN-H 2690 HI=HI-1:ON S6+1 GOTO 2700,2710 2700 ON S8+1 GOTO 2720,2730 2710 ON S8+1 GOTO 2740,2750 2720 IF D$(HI)>PIV$ THEN 2690 ELSE 2760 2730 IF D$(HI)VAL(PIV$) THEN 2690 ELSE 2760 2750 IF VAL(D$(HI))(HND-LO) THEN 2860 ' stack low 2810 ' STACK HIGH 2820 IF LO+2>HND THEN 2840 2830 STP=STP+1:LST(STP)=LO+1:HST(STP)=HND 2840 ' SHIFT HIGHEND 2850 HND=HI:GOTO 2510 ' partition 2860 ' STACK LOW 2870 IF LND+1>HI THEN 2900 ' shift lowend 2880 STP=STP+1:LST(STP)=LND:HST(STP)=HI 2890 ' SHIFT LOWEND 2900 LND=LO+1:GOTO 2510 ' partition 2910 ' POP STACK 2920 IF STP=0 THEN 2950 ' done 2930 LND=LST(STP):HND=HST(STP) 2940 STP=STP-1:GOTO 2510 ' partition 2950 PRINT:PRINT:PRINT"Array sorted. 2960 ' OUTPUT 2970 NR=0 ' counts number of records in product file 2980 CLOSE 2:KILL DD$(4)+F$+".DD"+FT$:GOSUB 4080 2990 IF S9=0 GOTO 3060 3000 ' COPY BLOCK BELOW T1 3010 IF T1=1 THEN 3060 3020 PRINT:PRINT"Outputting records below range. 3030 FOR I=1 TO T1-1 3040 GOSUB 3430 'output record 3050 NEXT 3060 ' MOVE RECORDS PER INDEX ARRAY 3070 PRINT:PRINT"Now moving records from " DD$(3)" to "DD$(4)" in sorted order per index array.":PRINT 3080 ERASE D$ ' don't need strings 3090 FOR J=1 TO T2-T1+1 3100 I=D(J):GOSUB 3430 3110 NEXT 3120 ' COPY BLOCK ABOVE 3130 IF S9=0 OR T2=N THEN 3180 ' skip block copy 3140 PRINT:PRINT"Outputting records above range 3150 FOR I=T2+1 TO N 3160 GOSUB 3430 ' output 3170 NEXT 3180 ' SAVE HEADER AND TIDY UP 3190 PRINT:PRINT"Saving header;"NR"records 3200 T$="" 3210 I=0 3220 I=I+1 3230 T$=T$+N$(I)+CHR$(126) 3240 IF LEFT$(N$(I),4)="stop" THEN 3260 3250 GOTO 3220 3260 T$=T$+STR$(NR)+CHR$(126) ' NR at end 3270 NR=0 ' for header 3280 GOSUB 3470 ' put it 3290 PRINT"!" 3300 IF P7 THEN 3330 'rename product 3310 GOSUB 3620 ' copy dupe to main 3320 GOTO 3380 3330 ' RENAME OUTPUT FILE 3340 CLOSE 2:NAME DD$(4)+F$+".DD"+FT$ AS DD$(4)+F2$+".D"+FT$:GOSUB 4080 3350 PRINT"Product file "F2$" is now on disk "DD$(4)" (backup erased). 3360 PRINT"After moving product to desired disk, use 'backup' command on "F$ 3370 INPUT"to restore safety copy. Hit RETURN to continue. ";A$ 3380 PRINT:PRINT:PRINT"Sort completed 3390 PRINT CHR$(7); 'beep 3400 ' RETURN TO DEDIT 3410 PRINT:PRINT"Re-loading DEDIT. 3420 CHAIN DD$(1)+"DEDIT",1000 3430 ' (SUB) OUTPUT RECORD "I" 3440 GOSUB 4110:PRINT T$ ' get rec I 3450 GOSUB 4270 ' exit 3460 NR=NR+1 ' # records in prod. file 3470 ' PUT RECORD NR 3480 ON FT GOTO 3510,3490 3490 LSET S$=MID$(T$,129) 3500 PUT #2,FT*NR+2 3510 LSET S$=LEFT$(T$,128) 3520 PUT #2,FT*NR+1 3530 RETURN 3540 ' (SUB) PARSE STRING 3550 K=0 3560 J=INSTR(T$,CHR$(126)) ' delimiter 3570 IF J=0 THEN RETURN 3580 K=K+1 3590 B$(K)=MID$(T$,1,J-1) 3600 T$=MID$(T$,J+1) 3610 GOTO 3560 3620 ' (SUB) ERASE ORIGINAL FILE AND COPY DUP TO ORIG 3630 CLOSE 3640 PRINT 3650 KILL DD$(3)+F$+".D"+FT$ 3660 PRINT"Copying dupe, overlaying original file.":PRINT 3670 GOSUB 4040 ' open both files 3680 FOR J=1 TO FT*(N+1) 3690 GET #2,J 3700 PRINT"&"; 3710 LSET R$=S$ 3720 PUT #1,J 3730 PRINT"*"; 3740 NEXT J 3750 RETURN 3760 ' ERROR HANDLING 3770 IF ERR=61 THEN RESUME 3780 ELSE 3810 3780 PRINT CHR$(7)"Sorry - process halted because there isn't enough disk space 3790 PRINT"for the key file. 3800 INPUT"Hit return to recover.";A$:CLOSE:T=8:CHAIN DD$(1)+"DIMS",1000 3810 IF ERR=7 OR ERR=14 THEN RESUME 3820 ELSE 3850 3820 PRINT CHR$(7)"Sorry - process halted because key array needed more memory 3830 PRINT"than is available. Try again with shorter key specifications. 3840 INPUT"Hit return to try again.";A$:CLOSE 3:GOTO 1090 3850 IF ERR=58 THEN RESUME 3860 ELSE 3910 3860 PRINT"Sorry - file named "F2$" already exists. 3870 INPUT"Enter another name for the output file here: ";X$ 3880 IF X$="" THEN 3870 3890 GOSUB 3920:F2$=Y$ 'ucv 3900 GOTO 3330 3910 ON ERROR GOTO 0 3920 ' (SUB) UCV 3930 Y$="" 3940 FOR J=1 TO LEN(X$) 3950 Y$=Y$+" " 3960 X=ASC(MID$(X$,J,1)) 3970 IF 96CHR$(27) THEN RETURN 4290 PRINT:PRINT"Process paused by ESCAPE from keyboard. 4300 PRINT"Do you want to continue (y,n or x) ? "; 4310 A$=INPUT$(1):IF A$=CHR$(13) THEN A$="y" 4320 PRINT A$:IF A$="x" THEN CLOSE 3:GOTO 3400 4330 IF A$<>"y" THEN CLOSE 3:GOTO 1090 4340 RETURN  A$=CHR$(13) THEN A$="y" 4320 PRINT (SUB) CLEAR SCREEN(TERM DEP) 4020 PRINT CHR$(12) 4030 RETURN 4040 ' (SUB) OPEN UP FILES 4050 CLOSE 4060 OPEN"R",1,DD$(3)+F$+".D"+FT$ 4070 FIELD #1,128 AS R$ 4080 OPEN"R",2,DD$(4)+F$+".DD"+FT$ 4090 FIELD #2,128 AS S$ 4100 RETURN 4110 ' (SUB) GET RECORD "I" IN T$ 4120 T$="" 4130 ON FT GOTO 4160,4140 4140 GET#1,FT*I+2 ' latter half 4150 T$=LEFT$(R$,127) 4160 GET#1,FT*I+1 4170 T$=R$+T$ 4180 RETURN 4190 ' (SUB) SHOW FIELDS 4200 FOR J=1 TO NC 4210 IF C(J)=0 THEN 4240 4220 PRINT TAB(29); 4230 PRINT USING"##";J;:PRINT". "LEFT$(N$(J),4)" "RIGHT$(N$(J),1) 4240 NEXT 4250 PRINT 4260 RETURN 4270 ' (SUB) EXIT TEST 4280 X$=INKEY$ 4282 IF X$<>CHR$(27) THEN RETURN 4290 PRINT:PRINT"Process paused by ESCA5 ' DSTAT by Dan Dugan -- public domain 10 PRINT"This program must be entered from DEDIT.":STOP 1000 DEFINT A-T 1010 DEFSNG U-Z 1015 FF$=CHR$(12) 'depends on your printer 1020 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$ 1040 ON ERROR GOTO 2330 1050 IF N=0 THEN PRINT"File is empty.": GOTO 2210 1060 NX=0 1070 PRINT 1080 GOSUB 2400 ' cs 1090 ' 1100 PRINT"DSTAT 1.02 - October 17, 1982 1110 LINE INPUT"Enter date: ",DATE$ 1115 PRINT:PRINT"Here are the numeric fields in ";F$ 1120 GOSUB 2510 'show fields 1130 INPUT"Number of field to work on (or 0 to quit)";STATFX 1135 IF STATFX=0 THEN 2210 1140 IF STATFX>NC THEN PRINT"FILE HAS"NC"FIELDS": GOTO 1130 1150 IF RIGHT$(N$(STATFX),1)="n" THEN 1180 1160 PRINT"Only numeric fields can be used; enter again." 1170 GOTO 1130 1180 IF STATFX=0 THEN GOTO 2210 ' abort 1190 PRINT:INPUT"Enter cue for missing data, if other than blank: ",MISS$ 1191 IF P9=0 THEN 1200 1192 ' PRINT HEADING 1194 FOR X=1 TO 5:LPRINT:NEXT 1195 LPRINT"DESCRIPTIVE STATISTICS FOR FILE "F$", FIELD "LEFT$(N$(STATFX),4)" "DATE$ 1196 LPRINT 1200 ' RECORD WORK LOOP 1210 ' zero variables here if go-around allowed 1220 ' 1230 FOR I=T1 TO T2 ' <==== FOR 1240 GOSUB 2430 ' get rec 1250 IF ASC(T$)=0 THEN PRINT"0 ";CHR$(13);:GOTO 1760 ELSE PRINT I;CHR$(13); 1260 T1$=T$ ' save it 1270 IF SKIPPARSE=1 THEN 1290 1280 GOSUB 2240 ' parse record string 1290 IF SEARCH=0 THEN 1580 1300 ' SEARCH 1310 IF SEARCH<>2 THEN 1370 1320 ' FIND 1330 IF INSTR(T$,SEARCHWORD$(0))=0 THEN 1760 1340 GOSUB 2240 ' parse 1350 GOTO 1580 1360 ' LOOK FOR SKIPS 1370 J=0 1380 IF SKIPWORD$(J)="" THEN 1460 ' try search then 1390 IF LOOKFIELD(J) THEN 1430 ' look in field 1400 IF INSTR(T1$,SKIPWORD$(J)) THEN 1760 ' whole rec search - skip it 1410 J=J+1 1420 GOTO 1380 1430 IF INSTR(B$(LOOKFIELD(J)),SKIPWORD$(J)) THEN 1760 ' field compare - skip 1435 IF B$(LOOKFIELD(J))="" AND SKIPWORD$(J)="_" THEN 1760 'blank field 1440 J=J+1 1450 GOTO 1380 1460 IF SEARCHWORD$(0)="" THEN 1560 ' don't care so print it 1470 J=0: GOTO 1490 ' now search 1480 IF SEARCHWORD$(J)="" THEN 1760 ' hesitate no longer 1490 IF SEARCHFIELD(J) THEN 1530 ' field 1500 IF INSTR(T1$,SEARCHWORD$(J)) THEN 1560 ' found it 1510 J=J+1 1520 GOTO 1480 1530 IF INSTR(B$(SEARCHFIELD(J)),SEARCHWORD$(J))<>0 THEN 1560 1535 IF B$(SEARCHFIELD(J))="" AND SEARCHWORD$(J)="_" THEN 1560 1540 J=J+1 1550 GOTO 1480 1560 IF SKIPPARSE=1 THEN GOSUB 2240 ' parse 1570 ' MISSING DATA 1580 IF B$(STATFX)=MISS$ THEN 1760 ' skip 1590 ' WORK ON RECORD 1595 GOSUB 2370 ' exit 1600 X=VAL(B$(STATFX)) 1610 IF P9 THEN LPRINT"(";I;")"; 1620 PRINT"("I")"; 1630 IF P9 THEN LPRINT,X 1640 PRINT,X 1650 IF NX=0 THEN XMAX=X:XMIN=X:GOTO 1680 1660 IF X>XMAX THEN XMAX=X 1670 IF X2 THEN 1960 1950 PRINT"Records containing '"SEARCHWORD$(0)"'" 1955 IF P9 THEN LPRINT"Records containing '"SEARCHWORD$(0)"'" 1957 GOTO 2100 1960 PRINT"Subset selection: 1965 IF P9 THEN LPRINT:LPRINT"Subset selection: 1970 IF SEARCHWORD$(0)="" GOTO 2050 1980 PRINT" Selection instructions: 1985 IF P9 THEN LPRINT" Selection instructions: 1990 J=0 2000 PRINT TAB(8);"FIELD NAME";TAB(20)"EXPRESSION 2005 IF P9 THEN LPRINT TAB(8);"FIELD NAME";TAB(20)"EXPRESSION 2010 PRINT TAB(11);LEFT$(N$(SEARCHFIELD(J)),4);TAB(20);SEARCHWORD$(J) 2015 IF P9 THEN LPRINT TAB(11);LEFT$(N$(SEARCHFIELD(J)),4);TAB(20);SEARCHWORD$(J) 2020 J=J+1 2030 IF SEARCHWORD$(J)="" GOTO 2050 2040 GOTO 2010 2050 IF SKIPWORD$(0)="" GOTO 2100 2060 PRINT" Rejection instructions: 2065 IF P9 THEN LPRINT" Rejection instructions: 2070 PRINT TAB(8);"FIELD NAME";TAB(20);"EXPRESSION 2075 IF P9 THEN LPRINT TAB(8)"FIELD NAME"TAB(20)"EXPRESSION 2080 J=0 2090 PRINT TAB(11);LEFT$(N$(LOOKFIELD(J)),4);TAB(20);SKIPWORD$(J) 2095 IF P9 THEN LPRINT TAB(11);LEFT$(N$(LOOKFIELD(J)),4);TAB(20);SKIPWORD$(J) 2097 J=J+1 2098 IF SKIPWORD$(J)<>"" THEN 2090 2100 ' 2110 PRINT"Statistics calculated for field '";LEFT$(N$(STATFX),4);"'" 2115 IF P9 THEN LPRINT:LPRINT"Statistics calculated for field ";LEFT$(N$(STATFX),4) 2120 PRINT:PRINT,"Number",NX 2125 IF P9 THEN LPRINT:LPRINT,"Number",NX 2130 PRINT,"Minimum",XMIN 2135 IF P9 THEN LPRINT,"Minimum",XMIN 2140 PRINT,"Maximum",XMAX 2145 IF P9 THEN LPRINT,"Maximum",XMAX 2150 PRINT,"Range",XMAX-XMIN 2155 IF P9 THEN LPRINT,"Range",XMAX-XMIN 2160 PRINT,"Sum",UX 2165 IF P9 THEN LPRINT,"Sum",UX 2170 PRINT,"Mean",WX 2175 IF P9 THEN LPRINT,"Mean",WX 2180 PRINT,"Standard Dev.",ZSD 2185 IF P9 THEN LPRINT,"Standard Dev.",ZSD 2190 PRINT,"Standard Err.",ZSE 2195 IF P9 THEN LPRINT,"Standard Err.",ZSE 2197 IF P9 THEN LPRINT FF$; 2200 PRINT:INPUT"Hit return to return to editor. ",A$ 2210 ' FINISH 2220 PRINT:PRINT"Re-loading DEDIT program. 2230 CHAIN DD$(1)+"DEDIT",1000 2240 ' (SUB) PARSE STRING 2250 K=0 2260 M=INSTR(T$,CHR$(126)) ' delimiter 2270 IF M=0 THEN RETURN 2280 K=K+1 2290 B$(K)="" 2300 B$(K)=MID$(T$,1,M-1) 2310 T$=MID$(T$,M+1) 2320 GOTO 2260 2330 ' GENERAL ERROR ROUTINES 2340 IF ERR=11 THEN RESUME 2350 ELSE 2360 2350 PRINT:PRINT"Division by zero error in line"ERL:GOTO 2210 2360 ON ERROR GOTO 0 2370 ' (SUB) EXIT TEST (TERM DEP) 2380 X$=INKEY$:IF X$=CHR$(27) THEN 2210 2390 RETURN 2400 ' (SUB) CLEAR SCREEN (TERM DEP) 2410 PRINT CHR$(12); 2420 RETURN 2430 ' (SUB) GET RECORD "I" IN T$ 2440 T$="" ' necessary! 2450 ON FT GOTO 2480,2460 2460 GET#1,FT*I+2 ' latter half 2470 T$=LEFT$(R$,127) 2480 GET#1,FT*I+1 ' whole or first half 2490 T$=R$+T$ 2500 RETURN 2510 ' (SUB) SHOW FIELDS 2515 PRINT 2520 FOR J=1 TO NC 2525 X$=RIGHT$(N$(J),1):IF X$<>"n" THEN 2550 2530 PRINT TAB(29); 2540 PRINT USING"##";J;:PRINT". "LEFT$(N$(J),4)" "RIGHT$(N$(J),1) 2550 NEXT:PRINT 2560 RETURN  2550 2530 PRINT TAB(29); 2540 PRINT USING"##";J;:PRINT". "LEFT$(N$(J),4)" "RIGHT$(N$(J),1) 2270 IF M=0 THEN RETURN 2280 K=K+1 2290 B$(K)="" 2300 B$(K)=MID$(T$,1,M-1) 2310 T$=MID$(T$,M+1) 2320 GOTO 2260 2330 ' GENERAL ERROR ROUTINES 2340 IF ERR=11 THEN RESUME 2350 ELSE 2360 2350 PRINT:PRINT"Division by zero error in line"ERL:GOTO 2210 2360 ON ERROR GOTO 0 2370 ' (SUB) EXIT TEST (TERM DEP) 2380 X$=INKEY$:IF X$=CHR$(27) THEN 2210 2390 RETURN 2400 ' (SUB) CLEAR SCREEN (TERM DEP) 2410 PRINT CHR$(12); 2420 RETURN 2430 ' (SUB) GET RECORD "I" IN T$ 2440 T$="" ' necessary! 2450 ON FT GOTO 2480,2460 2460 GET#1,FT*I+2 ' latter half 2470 T$=LEFT$(R$,127) 2480 GET#1,FT*I+1 ' whole or first half 2490 T$=R$+T$ 2500 RETURN 2510 ' (SUB) SHOW FIELDS 2515 PRINT 2520 FOR J=1 TO NC 2525 X$=RIGHT$(N$(J),1):IF X$<>"n" THEN 2550 2530 PRINT TAB(29); 2540 PRINT USING"##";J;:PRINT". "LEFT$(N$(J),4)" "RIGHT$(N$(J),1)10 PRINT"This program must be entered from DEDIT.":STOP 1000 GOSUB 2060 'cs 1010 PRINT:PRINT TAB(29);"DUNFLAG March 11, 1984 1015 ' by Dan Dugan -- public domain 1020 PRINT 1030 DEFINT A-Z 1040 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 ' SET UP 1065 PRINT"Here are the fields in "F$":" 1070 GOSUB 2290 'show fields 1075 PRINT 1080 INPUT"Number of field to unflag? ",F 1085 IF F=0 THEN 1740 'quit 1090 PRINT:INPUT"String to find and remove";FLAG$ 1100 L=LEN(FLAG$) 1150 ' RECORD WORK LOOP 1160 C2=0 ' first time 1170 LC=0 ' count 1180 ' 1190 FOR I=T1 TO T2 ' <==== FOR 1200 GOSUB 2210 ' get rec 1205 IF ASC(T$)=0 THEN PRINT"0";:GOTO 1720 1210 PRINT"+"; 1220 T1$=T$ ' save it 1230 IF SKIPPARSE=1 THEN 1250 1240 GOSUB 1780 ' parse record string 1250 IF SEARCH=0 THEN 1540 1260 ' SEARCH 1270 IF SEARCH<>2 THEN 1320 1275 ' FIND 1280 IF INSTR(T$,SEARCHWORD$(0))=0 THEN 1720 1300 GOSUB 1780 ' parse 1310 GOTO 1540 1320 ' FIELD SEARCH 1330 J=0 ' check for skips first 1340 IF SKIPWORD$(J)="" THEN 1420 ' try search then 1350 IF LOOKFIELD(J)<>0 THEN 1390 ' look in field 1360 IF INSTR(T1$,SKIPWORD$(J))<>0 THEN 1720 ' whole rec search - skip it 1370 J=J+1 1380 GOTO 1340 1390 IF INSTR(B$(LOOKFIELD(J)),SKIPWORD$(J))<>0 THEN 1720 ' field compare - skip 1400 J=J+1 1410 GOTO 1340 1420 IF SEARCHWORD$(0)="" THEN 1520 ' don't care so print it 1430 J=0: GOTO 1450 ' now search 1440 IF SEARCHWORD$(J)="" THEN 1720 ' hesitate no longer 1450 IF SEARCHFIELD(J)<>0 THEN 1490 ' field 1460 IF INSTR(T1$,SEARCHWORD$(J))<>0 THEN 1520 ' found it 1470 J=J+1 1480 GOTO 1440 1490 IF INSTR(B$(SEARCHFIELD(J)),SEARCHWORD$(J))<>0 THEN 1520 1500 J=J+1 1510 GOTO 1440 1520 ' GET READY TO DO IT 1530 IF SKIPPARSE=1 THEN GOSUB 1780 ' parse 1540 ' PAUSE CONTROLS (TERM DEP IF UPPERCASE ONLY) 1541 GOSUB 2030 ' exit returns A 1542 IF A=122 THEN 1560 ' z means go on 1543 PRINT I;B$(1);TAB(14);"Ready (SPACE/z/r/n/ESC) >"; 1544 A$=INPUT$(1):A=ASC(A$):IF A=27 THEN CLOSE 3:GOTO 1740 1545 PRINT A$:IF A=13 OR A=32 OR A=122 THEN 1560 1546 IF A=114 THEN I=IPREV:GOTO 1200 ' r 1547 IF A=110 THEN 1548 ELSE 1540 ' n or loop 1548 INPUT"Enter number of desired record: ";I:GOTO 1200 1550 GOSUB 2030 ' exit 1560 ' DO IT 1570 TEST=INSTR(B$(F),FLAG$) 1580 IF TEST THEN 1590 ELSE 1720 1590 B$(F)=LEFT$(B$(F),TEST-1)+MID$(B$(F),TEST+L) 1600 ' ASSEM CHANGED REC STR & PUT TO DISK 1610 T$="" 1620 FOR J=1 TO NC 1630 T$=T$+B$(J)+CHR$(126) 1640 NEXT 1650 GOSUB 2350:PRINT"*";:GOSUB 2420:PRINT"!" 1720 GOSUB 2030 ' check exit 1730 NEXT I ' END OF RECORD WORK LOOP 1740 ' FINISH 1760 PRINT:PRINT:PRINT TAB(32)"Re-loading DEDIT. 1770 CHAIN DD$(1)+"DEDIT",1000 1780 ' (SUB) PARSE STRING 1790 K=0 1800 M=INSTR(T$,CHR$(126)) ' delimiter 1810 IF M=0 THEN RETURN 1820 K=K+1 1830 B$(K)="" 1840 B$(K)=MID$(T$,1,M-1) 1850 T$=MID$(T$,M+1) 1860 GOTO 1800 2030 ' (SUB) EXIT TEST (TERM DEP) 2040 X$=INKEY$ 2042 IF X$<>"" THEN A=ASC(X$) 2045 IF A=27 THEN CLOSE 3:GOTO 1740 'use ESC to escape listing 2050 RETURN 2060 ' (SUB) CLEAR SCREEN (TERM DEP) 2070 PRINT CHR$(12); 2080 RETURN 2210 ' (SUB) GET RECORD "I" IN T$ 2220 T$="" ' necessary! 2230 ON FT GOTO 2260,2240 2240 GET#1,FT*I+2 ' latter half 2250 T$=LEFT$(R$,127) 2260 GET#1,FT*I+1 ' whole or first half 2270 T$=R$+T$ 2280 RETURN 2290 ' SHOW FIELDS (SUB) 2300 FOR K=1 TO NC 2310 PRINT TAB(29); 2320 PRINT USING"##";K;:PRINT". "LEFT$(N$(K),4)" "RIGHT$(N$(K),1) 2330 NEXT 2340 RETURN 2350 ' PUT T$ AS RECORD I (SUB) 2360 ON FT GOTO 2390,2370 2370 LSET R$=MID$(T$,129) 'latter half 2380 PUT #1,FT*I+2 2390 LSET R$=LEFT$(T$,128) 2400 PUT #1,FT*I+1 2410 RETURN 2420 ' PUT T$ AS DUPE REC I (SUB) 2430 ON FT GOTO 2460,2440 2440 LSET S$=MID$(T$,129) 2450 PUT #2,FT*I+2 2460 LSET S$=LEFT$(T$,128)  2470 PUT #2,FT*I+1 2480 RETURN FT GOTO 2460,2440 2440 LSET S$=MID$(T$,129) 2450 PUT #2,FT*I+2 2460 LSET S$=LEFT$(T$,128) SC(X$) 2045 IF A=27 THEN CLOSE 3:GOTO 1740 'use ESC to escape listing 2050 RETURN 2060 ' (SUB) CLEAR SCREEN (TERM DEP) 2070 PRINT CHR$(12); 2080 RETURN 2210 ' (SUB) GET RECORD "I" IN T$ 2220 T$="" ' necessary! 2230 ON FT GOTO 2260,2240 2240 GET#1,FT*I+2 ' latter half 2250 T$=LEFT$(R$,127) 2260 GET#1,FT*I+1 ' whole or first half 2270 T$=R$+T$ 2280 RETURN 2290 ' SHOW FIELDS (SUB) 2300 FOR K=1 TO NC 2310 PRINT TAB(29); 2320 PRINT USING"##";K;:PRINT". "LEFT$(N$(K),4)" "RIGHT$(N$(K),1) 2330 NEXT 2340 RETURN 2350 ' PUT T$ AS RECORD I (SUB) 2360 ON FT GOTO 2390,2370 2370 LSET R$=MID$(T$,129) 'latter half 2380 PUT #1,FT*I+2 2390 LSET R$=LEFT$(T$,128) 2400 PUT #1,FT*I+1 2410 RETURN 2420 ' PUT T$ AS DUPE REC I (SUB) 2430 ON FT GOTO 2460,2440 2440 LSET S$=MID$(T$,129) 2450 PUT #2,FT*I+2 2460 LSET S$=LEFT$(T$,128) 10 PRINT"STRIP - March 20, 1982 20 DEFINT A-Z 30 PRINT:INPUT"Enter name of the 'source file': ",F$ 40 X$=F$:GOSUB 350:F$=Y$ 50 PRINT:INPUT"Enter name of the 'destination file': ",F2$ 55 PRINT:PRINT 60 X$=F2$:GOSUB 350:F2$=Y$ 70 ' OPEN FILE AND TEST TO BE SURE IT'S ASCII 80 OPEN"I",1,F$ 90 LINE INPUT#1,L$ 100 IF ASC(LEFT$(L$,1))=255 THEN 110 ELSE 140 110 PRINT"Program is saved in binary form. Load it and save it with 120 PRINT"the 'A' option, then run STRIP again. 130 PRINT:PRINT:END 140 ' START STRIPPING If an apostrophe is found, the rest of the line is cut off, except inside a quoted string. 150 OPEN"O",2,F2$ 160 LENGTH=LEN(L$):QUOTE=0 170 ' CRANK THRU THE LINE CHAR BY CHAR 180 FOR J=1 TO LENGTH 190 A$=MID$(L$,J,1) 200 IF A$=CHR$(34) THEN 210 ELSE 230 210 IF QUOTE=0 THEN QUOTE=1:GOTO 240 220 IF QUOTE=1 THEN QUOTE=0:GOTO 240 230 IF QUOTE=0 AND A$="'" THEN 320 240 NEXT 250 ' PRINT THE LINE 260 PRINT#2,L$ 270 PRINT L$ 280 ' GET THE NEXT LINE  290 IF EOF(1) THEN 292 ELSE 300 292 CLOSE 294 PRINT:PRINT"All done.":PRINT:END 300 LINE INPUT#1, L$ 310 GOTO 160 320 ' TRUNCATE LINE 330 L$=LEFT$(L$,J) 340 GOTO 250 350 ' (SUB) UCV 360 Y$="" 370 FOR K=1 TO LEN(X$) 380 Y$=Y$+" " 390 X=ASC(MID$(X$,K,1)) 400 IF 96 lis o th option ther i show in response to "h". .he DIMS Installation Notes - Release 1.03 - INSTALLATION page #  .cp 9 INSTALLATION BASIC VERSION DIFFERENCES Ther ar tw critica difference betwee Microsof Basic-8 versio 4. an 5.x On i tha th CLEA statemen ha change syntax Thi statemen i use once i th mai men progra DIMS I yo ar instal lin wit 4. us "CLEA 1000 whic set strin space I yo ar usin versio 5.x us "CLEAR,,1000 whic set stack space I 5. strin spac i use dynamically bu th stac spac i determine fro a algorith whic wil resul i DIM crashin wit a "Ou o Memory erro whic wil b puzzlin becaus fre(x wil stil sho plent o memory. Th secon differenc i tha Basic-8 versio ha th comman "INKEY$ whic allow checkin th keyboar withou stopping I yo nee t instal DIM o versio 4.5 yo wil hav t eithe giv u th "z scrollin contro command o writ cod tha look a you hardwar ports Instead of X$=INKEY$ use X=INP(KEYBD.DATA.PORT). MEMORY REQUIREMENT DIM i currentl bein develope o 59K-siz CP/ system actuall 62 Morro har dis system smalle syste ma no hav roo fo al o th fil edito DEDIT whic i big Th progra STRIP.BA i provide an ma b use t remov comment fro DEDIT I wil the fi o 54 system I you syste i smalle an you'r adep a Basic yo coul shrin DEDI b takin ou al th cod relatin t th forma comman an replacin al th complicate positionin cod wit simpl listin i th defaul format I yo stri th comment kee you developmen versio wit th comment in an the stri i fo running s you'l hav th comment t guid yo i makin modifications. .cp 4 MODIFYING THE PROGRAMS FOR YOUR TERMINAL AND PRINTER DIM use th clear-scree an curso positionin function o you terminal Sinc al terminal ar different AL TH DIM PROGRAM MUS B MODIFIE T SUI YOU TERMINAL I th cod (TER DEP wil appea i comment a eac plac wher customizatio i necessary Us you tex edito t searc fo thes spots DEDI use th mos function an there for require th mos work Th supplie transien program don' us curso positionin bu the d us scree clea an keyboar testing AL TH PROGRA SEGMENT MUS B LOADE AN RE-SAVE becaus DIM use CHAI an program store i ASCI forma wil a firs appea t chai bu wil crash soon after with misleading error messages. Whe writin Basic-80 enterin line-fee produce ne lin i th listin whic i no counte a lin b Basic Th combinatio o thes an tab make i possibl t ge lo o clarifyin whit spac int th cod wit ver littl cos i term o characters Whe edi program.AS fil wit WordSta (i "n mode) se extr line inserte an sign o confusio i th righ han column Thi i becaus Basi ha pu linefee followe b carriag return th opposit o th usua sequence i th file WordSta can' edi thi sequence Jus leav thos effect alon whe usin WordSta an al wil b well. Specia problem ca aris i th cas o a upper-cas onl terminal I yo mus us one cop al th progra AN DAT file wit PI usin th [u option The us tex edito t fin al "CHR$( occurrence i th program an chang thos number whic represen lower-cas character (9 t 122 t upper-cas code (subtrac 32). .cp 5 PRINTER Th DIM syste a delivere i writte fo Diabl 161 o 162 printer an use man o it specia contro sequences lik settin vertica an horizonta pitc fo listin i pre-recorde form an hig spee absolut tabbing Us wit othe printer wil requir re-writin thi code Diabl contro sequence star wit ESCAPE whic i CHR$(27) DIM wil allo yo t creat forma specificatio whic use revers scrollin o th printer bu don' d i unles yo hav bidirectiona form tractor. .he DIMS Installation Notes - Release 1.03 - DESCRIPTIONS OF FILES PAGE # .cp 9 DESCRIPTIONS OF FILES PROVIDED *** GROUP 0 - Development *** Kee thes file o you "DIM Development se o disks The ar no needed for working with files under DIMS. READ-ME .103 Release letter DINSTALL.DOC Installation and Operation Manual STRIP .BAS Basic-80 utility for making DEDIT smaller FORMFORM.DW Sourc fil t b copie whe designin screen/printe formats with the aid of WordStar FIELDFOR.DWS Source file to be appended to copies of FORMFORM.DWS *** GROUP 1 - Main Programs *** Th followin Basic-8 program ar provide i ASCI forma fo eas i transmission scanning an editin durin installation THE MUS THE B SAVE I TH BASIC-8 COMPRESSE FORMA WIT NAME.BA T RUN. DIMS .ASC Opening menu program. DEDIT .ASC The file editor program .cp 10 *** GROU - Transien Program *** Al thes excep DCREAT chai fro an retur t th fil editor DEDIT. DCFORM .ASC Command for creating a screen/printer format for a file. DCHESHIR.AS Comman fo printin label 4-acros o wid pape fo Cheshir automati labe applicatio machine Can als b use a stand-alon progra t prin fro comma-delimite data file. DCREATE .ASC Program to create a new file format. Chains from DIMS main menu program. DDO .AS Comman tha display o write t tex fil o note associated with a data file. DGE .AS Comman whic get sequentia fil an add i t DIM file. DHEL .AS Comman whic display screen describin fil edito commands. The screens are stored in the file DHELP.DOC. DLABELS .ASC Command for printing 1-up mailing labels. DLETTERS.ASC Command for printing form letters with file data inserted. DNADI .AS Comman fo inputtin NAD-lik dat fil t DIM "standard" form mailing list file. DPUT .ASC Command which puts a set of records out to a sequential file. DSORT .ASC Command for sorting files. DSTA .AS Comman fo calculatin descriptiv statistic fo dat i numeric field. *** GROUP 3 - Main Data Files *** LONGADDR.D Example data file for long form address lists. STANDADD.D Example data file for standard form address lists. SHORTADD.D Example data file for short form address lists. ARTICLES.D Example data file for magazine articles. MEMBERS .D Example data file for neighborhood association *** GROUP 4 - Backup Data Files *** LONGADDR.DD Example backup data file. (etc.) .DD *** GROUP 5 - Auxiliary Files *** SHORT .DFO Example format control file. SHORT1 .DFO Example format control file. STANDADD.DFO Example format control file. MEMBERS .DFO Example format control file - used for printer listing. MEMBERS .DOC Example of a notes file read and written via "doc" command when editing MEMBERS file. DHELP .DOC Screen texts used by help command. .he DIMS Installation Notes - Release 1.03 - PLACING THE FILES PAGE # .cp 5 PLACING THE FILES ON THE APPROPRIATE DRIVES recommen tha beside th distributio master yo kee se o disk calle "Dim Development whic consist o al th releas file i compresse form th demonstratio files an smal sample o th dat file yo creat fo yourself Us thi se o disk t creat an tes format an an t creat an tes you ow transien utilities The hav set o workin disks whic wil b change i pairs wit jus th DIMS component yo nee an plent o spac fo dat files Wit thre disk us fo everyda progra librar an an  fo data gettin change fo differen set o file (se below). Afte eac progra segmen i checke ove an modifie fo you termi nal sav i i th standar compresse forma wit name.bas The th name.as fil ma b erased Dependin o ho man drive yo have yo mus cop th file provide o th distributio dis t disk o th appropriat drive o you system The chang th initia valu o th variabl NDRIVE nea th beginnin o DIMS.BA t th numbe o drive yo ar using. I yo ar usin har disk commen ou th tw RESE statement nea th to o DIMS.BAS The ar necessar fo changin floppies whic i onl allowe a th no-fil menu .cp 21 I TW DRIV SYSTE .. program ar spli betwee A an B, attemptin t mak balance spac fo dat (.D an backu (.DD files. Drive A: Drive B: MBASIC .COM DCFORM .BAS DIMS .BAS DCHESHIR.BAS DEDIT .BAS DCREATE .BAS LONGADDR.D DDOC .BAS STANDADD.D DGET .BAS SHORTADD.D DHELP .BAS ARTICLES.D DLABELS .BAS MEMBERS .D DLETTERS.BAS DNADIN .BAS DPUT .BAS DSORT .BAS DSTAT .BAS SHORT .DFO SHORT1 .DFO MEMBERS .DFO STANDADD.DFO MEMBERS .DOC DHELP .DOC LONGADDR.DD STANDADD.DD SHORTADD.DD ARTICLES.DD MEMBERS .DD O A OSBORN O SMALL-CAPACIT 2-DRIV SYSTE .. Th minimu neede t buil dat bas i shown T giv th maximu possibl spac fo data MBASIC.CO i store o driv B Th syste i starte fro driv A b typing "b:mbasic dims". On an O-1, you can add 400 data records. Drive A: Drive B: DIMS .BAS MBASIC .COM DEDIT .BAS STANDADD.DD STANDADD.D .cp 22 I THRE DRIV SYSTE .. th progra librar i kep togethe o A an B an C ar save fo larg dat files dat fil ca b a bi a th whole user disk space, and still have 100% backup on the other disk. Drive A: Drive B: Drive C: MBASIC .COM LONGADDR.D LONGADDR.DD DIMS .BAS STANDADD.D STANDADD.DD DEDIT .BAS SHORTADD.D SHORTADD.DD DCFORM .BAS ARTICLES.D ARTICLES.DD DCHESHIR.BAS MEMBERS .D MEMBERS .DD DCREATE .BAS DDOC .BAS DGET .BAS DHELP .BAS DLABELS .BAS  DLETTERS.BAS DNADIN .BAS DPUT .BAS DSORT .BAS DSTAT .BAS SHORT .DFO SHORT1 .DFO STANDADD.DFO MEMBERS .DFO DHELP .DOC MEMBERS .DOC .cp 17 I FOU DRIV SYSTE .. auxiliar file (.DOC .DF an temporar .$$$ are kept on the fourth drive. Drive A: Drive B: Drive C: Drive D: MBASIC .COM LONGADDR.D LONGADDR.DD SHORT .DFO DIMS .BAS STANDADD.D STANDADD.DD SHORT1 .DFO DEDIT .BAS SHORTADD.D SHORTADD.DD STANDADD.DFO DCFORM .BAS ARTICLES. ARTICLES.D MEMBERS .DFO DCHESHIR.BAS MEMBERS .D MEMBERS .DD MEMBERS .DOC DCREATE .BAS DHELP .DOC DDOC .BAS DGET .BAS DHELP .BAS DLABELS .BAS DLETTERS.BAS DNADIN .BAS DPUT .BAS DSORT .BAS DSTAT .BAS .he DIMS Installation Notes - Release 1.03 - OPERATING INSTRUCTIONS PAGE # .pa OPERATING INSTRUCTIONS: MAIN MENU Afte th file hav bee pu o th appropriat drives modifie fo you termina an driv configuration an save i standar compresse forma (ASCI file won' CHAIN) th syste i starte b runnin DIMS Yo shoul ge th no-fil men wit director o th provide tes dat file displayed I yo the hi return yo wil ge men choic no 1 ope file Ente th nam o on o th existin files jus th mai par o th name skippin th extension I ma b i eithe lowe o uppe case. DEDI shoul loa an displa th las recor i th file (I yo ge "BA FIL MOD I 6250 i mean DEDI hasn' bee save i norma compres se format.) Typ "help fo serie o screen explainin th availabl commands A th "paus prompt "Ready> i yo typ "h men o paus option wil appear. Whe yo ar editin fil th onl saf exi i t typ th comman "done (don) Thi wil retur yo t th mai menu Othe choice availabl fro th no-fil men includ rese whic i intende t sho th ne director whe dat disk hav bee changed I DIM ha bee properl installe (tw RESE statement enabled) n har wil com i yo ski thi ste an ope file Ther i als comman fo changin th numbe o disk i th syste fo th curren session Thi i fo emer genc use I i necessar t firs us PI t mov th file aroun t th appropriat drive i yo inten t d this. Th no-fil men include DCREATE th sub-progra tha set u ne fil fro scratch I ask fo th name an choic o size 128-byt record ar jus righ fo mailin list an mos things th 256-byt recor siz i availabl fo record tha nee mor space Yo ar aske t giv th defaul 4-characte nam fo eac field an whethe i i a alphabeti o numeri field Yo ca jus hi RETUR fo alphabetic Everywher  i DIM dialogue jus hittin RETUR give yo th firs choic i th men o options Ente "stop whe al field hav bee defined and after approval the new file will be opened. I yo wan t mak ne fil wit th sam fiel schem a a existin one there' a easie way Jus ope th fil an cop on recor ("cop 1") givin th ne fil name The "done th ol file ope th ne fil an us "change t pu ne dat i th copie record The yo ca star adding. .he DIMS Operating manual - Release 1.03 - DEDIT commands PAGE # .cp 5 FILE EDITING COMMANDS DEDI ha tw prompts "Edi FILENAME: an "Ready>" "Edi FILENAME i th comman level an accept comman line "Ready> i th "paus prompt betwee record i sequenc bein ru thr i respons t comman line Th paus promp "Ready> take single-lette instan com mand SPACE o ESC Hittin th spac ba wil sho th nex record Hittin wil star continuou scrollin unti spac i hi t stop Th ESCAP ke wil alway qui th sequenc an giv yo "Edi FILENAME". "Edi FILENAME take somewha free-for comman line Thi lin i mad u o onl vali comman words Th sequenc ca b prett loose bu afte "final comman everythin els wil b ignore excep fo range- of-record word an numbers lik "fro 1 t 20." I there' recor numbe o pai o recor number anywher i th command line, the command will be done on the specified range of records. Th word "from "to "all "end "next o "last ma b use whe talkin abou recor numbers ". instea o numbe mean us th mos recentl displaye record Al th built-i command ma b shortene t thre letters. For example, all the following are valid commands: add delete from 10 to 20 delete 10 20 print to 75  print select labels change 57 cha . (means change last record shown) 10 20 list from 10 to 20 (same result as "10 20" select copy delete (moves records to another file) "FINAL" COMMANDS Thes command ar normall th las wor i th comman sentence An followin word excep recor number wil b ignored. add Appends records to the end of the file, prompting field by field. In this mode the following commands take effect: "stop" alone in any field quits adding. "\" (backslash) at end of any field skips back 1 field. ";" alone in the field copies data from last record shown. done Closes the file and returns to the no-file menu. got Close th fil an open an name fil o th same disks. fields Allows "hiding" fields you don't want to show. You may un-hide them with the same command. Controls output of 'put.' format 0 Installs default display and print formats. format Installs named format definition for screen and printer. formats Shows available format definition files. backup Makes complete new backup file from main file. Rarely used since backup file is maintained automatically. renumber Renumbers all records sequentially from the top in both main and backup files, closing up holes from deleted records. MISCELLANEOUS COMMANDS The following commands may be given freely anywhere in the command line: change <#> Shows record or records field by field, new data may be entered for each field or the old data may be kept by just hittin RETURN T eras fiel ente jus on space then RETURN Backslas '\ back u t previou field I chang comman include mor tha on record yo wil b give th optio t selec field t change whic speed u th proces o doin somethin lik jus addin zipcode to an existing file. delete <#> Shows record or records and asks approval to erase. list Shows records. Assumed if no other final command is given. find Finds records containing the exact word string. A phrase can be found if underlines_are_used_instead_of_spaces. select Find record containin u t 1 differen word o phrases Space ar OK bu n upper/lowe cas conversio i done I yo hi retur whe aske wha fiel t loo i th wor wil b searche fo i al fields Yo als ca specif u t 1 word o phrase tha wil caus th recor! t b skipped Desig you codin syste t wor wit this print Prints on list device rather than screen in the current format. copy Copies data records and adds them on to the end of another DIMS file. You will be asked for the name. You may create a new file this way or add to an existing one, but the field definitions must be the same. New records have no auto backup. and Permitted for clarity, ignored. page Sets the page number to start the printout with. margin Set th printe margi i yo don' wan th margi tha come wit th for you'r using. flag Combine wit "add o "change t rang o records ask yo fo strin t b adde automaticall t an (one fiel i th record. programs Shows a directory of available "transient commands," i.e. various batch processes than can work on the file. .cp 4 TRANSIENT COMMANDS Transien command ar sub-program whic d batc o wor an the retur yo t DEDIT Wher appropriate the wil tak rang o record an selectio criteri fro th comman line Example "prin selec label 10 t 150." The most commonly used are described here: cform Process for creating format definition files. Complicated. doc A "notepad" where you can read or write notes associated with th dat file Th do fil ca b edite late wit tex editor Usefu fo documentin o th spo code yo inven fo you file. labels Print batc o mailin label (us "prin labels" wit blan field close up Work onl wit thre standar addres fil formats It' no har t modif i neces sary Afte th label ar aligned hi spac t prin on a tim t mak sure The hi t caus continuou printing Hi spac agai t pause ES t abort. letters Print tex fil wit dat fro DIM fil inserted persona salutatio lin o othe dat line ma b include i desired DLETTERS.BA mus b modifie fo eac job I yo hav MailMerg it' easie t us "put t mak sequentia dat fil whic i subse o th DIM data file an us MailMerg wit that. sort Sort th record int ne sequenc i th whol fil o jus rang o th file Ask question fo set-up Alphabeti key ma b truncate and/o blank-fille t specifie length Sort alphabeticall unles al field specifie fo key ar numeric Th sorte produc ma replac th ol fil o mak ne file Limite b memor space to smaller files. stat Computes descriptive statistics for a selected numeric field. put Makes an output file in standard Basic sequential form for further processing with other programs. You may select a range of records in the invoking command line, and selection specifications Hidde field (se "fields" wil b skipped get Add dat fro conventiona Basi sequentia dat fil t th en o th DIM fil fro whic i i called addin record t th end Allow skippin an re-orderin o fields. .cp 5 FILE STYLES I you'r openin u ne mailin lis file it' convenien t us on o thre establishe set o fiel name Loo a th exampl file provided LONGADDR STANDADD an SHORTADD Th transien comman "labels ha cod built-i t dea wit an o thes thre forms Th lon for i use fo governmen o academi wor wher title an organization abound Th standar for i fo genera purposes Th shor for i fo shor file tha won' nee t b sorte int las nam order. T mak special-purpos mailin lis suc a a organizatio whic woul wan membershi statu o othe specia fields imitate on o th thre standar fiel layout fo everythin u t th zi code the desig th layou beyon tha poin t sui th application Thi wa th label progra wil wor wit th file Fo example stud "MEMBERS.DOC, whic explains the fields of "MEMBERS.D." Th ZI fiel i o th numeri typ s i wil rejec un-sortabl mistake lik usin "l fo "1" Pu Europea an Canadia posta code afte th provinc i th C-S field an leav th ZI fiel blank. DESIGNING CODES FOR RECORD SELECTION I cod field ar compatibl designed th limite selection/rejectio logi i DIM ca d quit goo "jo o pullin ou subset Th techniqu tha I'v develope tha work rea wel i t us code mad u o on lower-cas lette an on digit suc a a0 a1 b0 c8 etc An numbe o code ca b jumble i an orde i singl cod field Thi make i eas t ad code t th schem a i develop - yo ca us th "doc comman t not thei meanin whe yo thin the up I thi for o codin i strictl adhere t subse o singl cod ma b pulle ver rapidl usin "find, sinc thi combinatio o lette an digi doesn't occur anywhere else in the fields. For example: print find a2 labels .he DIMS Operating Manual - Release 1.03 - SCREEN & PRINTER FORMATS PAGE # DESIGNING AND CREATING SCREEN & PRINTER FORMATS Yo ca creat formats tha is totall designe way o namin an displayin th dat o th scree an o th printer Ope th exampl fil SHORTAD an tr th sampl format SHOR an SHORT ou o it Yo ca se th name o th format (.DF files availabl b typin th comman "formats. forma i usuall designe fo us wit particula file thoug i th field ar compatibl there' n reaso wh whol famil o file couldn' us th sam one forma specificatio include bot th scree an th printe images Yo ca desig eithe scrollin o screen-oriente forms Th designer o commercia data-entr program (e.g DataStar dBAS II see t b preferrin screen-oriente display thes days wher th scree show yo jus on fil recor a tim displaye i designe form Yo ca desig fixed-positio format fo DIMS prefe scrollin dat entr becaus yo ca orien yoursel t wha yo jus did haven' use fixed-positio forma design an consequentl mus war yo tha thoug provide fo i DIM thi mod hasn' bee full teste an ther ma b bugs. USING CFORM TO CREATE A FORMAT CONTROL FILE Ther ar tw way o creatin th forma specificatio file .DFO Th firs i t giv th comman "cform i DEDIT Th cfor transien allow yo t prin ou lon pape for o whic yo fil ou you desig fo th scree an printe form Scree and/o pag heading ma b mad u t thre line long Thes line wil onl b printe i non-blank Fiel name (prompts ma b omitted th defaul 4-characte fiel nam ma b used o custo nam ma b printe anywhere I positionin name an dat fields i th lin i specifie th ite wil alway b printe a tha line. I th lin i i wil b printe wher eve th curso o printhea wa lef a th en o th previou field Similarly i colum i specifie th dat wil b printe there an i colum i give i wil prin a th colum wher i wa lef b th previou operation Thi allows fo example printin Firstnam Lastname b definin th fiel nam promp fo "Lastname a singl space a lin an colum 0. Tak car whe enterin th dat fro th filled-ou form becaus cfor doesn' bac up I yo mak a erro yo mus star over Ente al th specification an tes i o you dat file Whe you'r debug gin forma design yo ca tak shor cu b usin tex edito progra o th .DF fil tha cfor create fro th specificatio entr dialogue Compar th number o th pape for wit th fil imag t figur ou wher i th forma contro fil yo are Th fil i rea a sequentia fil whe i i use b DIMS s tak grea car t preserv th exac numbe o line an item pe line USING WORDSTAR TO CREATE A FORMAT CONTROL FILE I yo hav WordStar a easiest metho ma b used WordSta fil wit prompt include a non-printin comment i edite t fil i al th desire specifications Th fil i the printe t dis t creat th contro file Star WordStar Typ "n t begi "non-document typ o file an nam th ne fil wit ne name sugges usin th suffix .DWS for this type of file. A th to o th blan ne file typ ^KR an giv th nam "formform.dws" Th loade fil contain complet prompt an instruction fo creatin th forma contro file Whe needed th fil "fieldfor.dws" is also read in. Th fil i printe usin th optio o printin t dis file Th produc file' nam mus hav th extensio .DFO Th .DF fil mus b edite t remov extr blan line fro th end The i ma b trie ou whil editin th DIM file Afte correction ar noted wor o th .DW source file and print it again. .he DIMS Operating Instructions - Release 1.03 - CRASH RECOVERY PAGE # CRASH RECOVERY DIM record ever recor tha yo ente o updat immediatel i tw places th mai an backu dat files Hopefull you syste wil b se u s tha thes ar o differen disks givin protectio agai#ns eve crashed file directory on one disk. Whe dis i ba an yo cras t on o CP/M' crypti "BDO ERROR messages al you dat excep th las recor yo wer enterin i stil good I yo wer i th proces o addin record al th newly-adde record wil b i th fil bu th numbe o record wil no hav bee update i th DIM fil heade record I yo remembe wha th highes recor numbe was ski th nex paragraph. Us CP/M' sta utilit t loo a th dat file Not th numbe o record show i th left-han column I you fil i 128-byt records th numbe o dat record (th numbe yo want i tha numbe minu one I th fil i double-siz records th numbe o dat record i th numbe o CP/ record divide b two the minu one Re-star DIMS Open the file. Not tha DIM stil think tha th fil ha th numbe o record tha i ha whe yo di th las "done. Hi control-C Ente "N=986 (us you ow number) Ente "C=1" Ente "cont the RETUR an se i th fil appear t b norma now D "done." I cras occur whil th sor comman i writin it outpu ove th backu file th backu fil i invalid Us "backup t restor it Shoul th mai o backu fil b lost PI ca b use t cop on o th other an the th CP/ "ren comman t renam th file Th mai an backup data files are identical. .he DIMS Interface and Modification - Release 1.03 - FILE COMPATIBILITY PAGE # INTERFACE AND MODIFICATION FILE COMPATIBILITY DIM file ar ASCI dat i fixed-lengt rando acces blocks an al record ar eithe standar 12 byt lengt o 25 byt lengt dependin o whic wa chose whe th fil wa created Thi ha nothin t d wit you disk bein doubl o singl density MBASI an CP/ pac th re cord o th dis wit n carriag return betwee the an n control- a th end Withi eac recor th field ar jamme sequentiall wit th delimite characte "~ (chr$(126) betwee th field an th left-ove spac fille wit blanks Thi characte ma no b use i data bu comma an quote ma b entere freely Her i a exampl o wha fil recor look lik o th disk: .cp 8 (heade recor - th las ite i th numbe o record i th file.) LNAM,a~FNAM,a~N2 ,a~ADDR,a~C-ST,a~ZIP ,n~PHON,a~CODE,a~NOTE,a~stop0~ 1~ (data record 1) Dugan~Dan~Da Duga Soun Design~29 Napoleo Street Studi E~Sa Francisco CA~94124~(415 821-9776~~DIMS~ Th fil ma b dumpe wit th CP/ "type command o examine an repaire wit E o WordSta versio (versio wil crash i th non- documen mode Christensens' DU.CO utilit ma b use t repai crashe file SuperSor doe no accep DIM file directl becaus i insist o comma-delimite o fixed-lengt fiel files. Th DIM transien program "DPUT an "DGET provid convenien mean fo interfacin t othe programs DPU output standar Basi sequentia fil o comma-delimite records I ca b invoke i comman lin wit rang an selectio command t outpu subse file lik "selec put. DGE doe th exac reverse loadin standar sequentia fil int DIM file an allow stuffin th field i an combinatio o order. Quote an comma ma b use freel i DIM dat fields T mak file compatibl wit othe programs DPU automaticall put quote aroun field containin commas I encode existin quote i th fil int th characte "~" CHR$(126) DGE drop th surroundin quote an convert bac t ". DIM fil ma b re-designe b usin th 'put comman t outpu th dat t temporar file usin DCREAT (mai menu t creat ne DIM fil wit th desire fiel names an usin th 'get comman t stuf th dat bac i i th desire order. .he DIMS Interface and Modification - Release 1.03 - YOUR TRANSIENTS PAGE # .cp 4 WRITING YOUR OWN 'TRANSIENT' PROGRAMS Wha usuall d whe wan t writ ne transien functio i loa "DLABELS.BAS an the replac th workin sectio (usually jus th insid o th "I loop wit ne cod tha doe wha want The sav th fil wit ne name Kee th beginnin excep fo th question an whateve subroutine yo need Remembe tha yo ente transien progra wit th rang o records printin an selectio criteri alread speci fie fro th DEDI comman line. Cautio -- Don' chang th COMMO statement Al DIM program ar entere a lin 100 excep fo th cold-star o DIMS.BAS DEDI automa ticall recognize transien program i they'r o th righ driv an thei name star wit an en wit .BAS. .he DIMS Interface and Modification - Release 1.03 - MODIFICATION PAGE # MODIFICATION GUIDELINES Not tha al GOTO' an GOSUB' poin t remar lines Thi i th opposit o ad$vic commonl heard Th spee penalt fo thi i infinitesmal Th advantage ar firs yo ca se wha GOSU nnn doe b typin "lis nnnn, an secon it' easie t ad lin a th beginnin o th subroutine somethin see t nee t d often. Regardin speed rea somewher tha Basi searche th whol progra fro th star fo th destination o branchin statements an tha it' suppose t b faste i th subroutine ar a th beginnin o th program spen fe hour re-organizin DEDI t tr this an i wasn' wort it th tim fo searchin 10 record wa th same pu th sub bac wher the grew I'v hear tha th sam goe fo variabl storage tha thos tha ar define earlie i th ru ar quicke t use Fo thi reaso th commo loo indexin variable ar include i th COMMO statement thoug mos o the aren' use fo paramete passing .he DIMS Interface and Modification - Release 1.03 - VARIABLES PAGE # DEFINITION OF COMMON VARIABLES B$() Array holds field data of current record C Change flag = 1 when the file has been added to C() Controls display and changing of fields, value 0, 1 or 2 DD$() Array holds drive names for five types of files F$ Current file name FT Current file type, 1 or 2 - determines 128 or 256 byte recs. FT$ Added to extension of file name, blank or 2 I,J,K Loop index variables. Be sure they're free before re-using. LOOKFIELD() - Numbers of fields for which select skips are set N The current number of records in the file N$() Default names for fields, comma, and "a" or "n" for type NC The number of fields in the current file P6 Flag, reserved for "write" function not implemented P7 Flag, = 1 when "copy" in effect P8 Flag, reserved P9 Flag, = 1 when "print" in effect PI Flag, = 1 when printer is assumed ready R$  Disk data string read/written in main data file S S$ Disk data string read/written in backup data file SEARCHFIELD () - Numbers of fields for which select keys have been set SEARCHWORD$() - Key words or phrases for record selection SKIPWORD$() - Key words or phrases for record skipping T Command code, set by some DEDIT commands to control branching T$ Data record string going to or from storage T1 Lowest record number in the batch T2 Highest record number in the batch T1$ Temporary data string X,Y Local parameter passing variables .he DIMS Interface and Modification - Release 1.03 - BUGS PAGE # .CP 5 KNOWN BUGS AND SUGGESTED IMPROVEMENTS Display of non-scrolling forms in DEDIT hasn't been fully debugged. harmles slightl garble displa happen i yo us backslas t tr t bac u fro th firs fiel o record. Th recor selectio logi i rudimentary an coul b improve t includ AND/O an greater/les tha comparisons Thi woul requir adding some common variables and updating all programs in the system. "Undelete woul b eas t implemen b gettin dat fro th backu file Lot o thing coul b adde t DEDI i i weren' s fa already Th "sort comman onl sort i ascendin order Ther i cod writte i th progra fo descendin orde sort bu thi switc ha bee commente ou a i cause a unsolve data-dependen crash. .he DIMS Installation Notes - Release 1.03 - HISTORY PAGE # HISTORY OF DIMS starte wit m S-10 microcompute a th en o 1977 A tha tim ther wa n generalize data-bas managemen progra available studie full-fledge syste writte i Basi calle RIS whic i publishe a boo (b Meldma e al Va Nostran Reinhol Co '78 I wa to comple fo m t understand spu m wheel fo yea unti sa a a fo Scelb Publications PIM -- Persona Informatio Managemen System Thi i complet functionin data-bas manage fo cassette-base computer lik TRS-8 o PET bough i fo $10 type i i an go i t work. T backste fo moment thi progra wa firs publishe a " People' Dat Bas System b Mada Gupt an Bren Lande i 1977 The Scelbi published PIMS by Gupta in 1979. Wit PIM ha workin framewor whic converte t dis random- acces files Afte tha th progra immediatel wen t wor fo m an m clients an jus gre an gre a th pressur o doin rea wor determined rente machin tim t th Sa Francisc Charte Revisio Commissio fo thei mailin lists an mad man improvement t th progra a tha projec grew Th syste o chainin th transien pro gram develope whe th progra go to bi t b al i memor a th sam time hav neve change th variabl names storag forma o defaul listin for%ma fro PIMS I'v pu m larg persona addres list ont DIMS an successfu syste fo storin technica magazin articl citations book Th Heart o Spac Guid T Cosmic Transcenden an Innerspac Musi starte ou a DIM dat file wa transforme (b purpose-buil transient t WordSta whe th dat wa complete the sen t th typesette o CP/ disk als hav part list fo m product an th membershi lis fo m neighborhoo association Al thi activit mad m wan mor real-tim availabilit o m dat bases an i '8 use al m availabl credi t instal Morro M2 har disk DIM run wit satisfyin spee increas o th har disk I '81-8 pre-releas version wer u o tw system i m la an fiv othe CP/ system belongin t friends. DIM versio 1. wa release t th publi domai b Da Duga Soun Desig o Marc 20 1983 m 39t birthday I Apri '8 Ji Ayer mad th whol syste availabl o th bulleti boar o Compute System o Marin. .cp 3 Th progra wa subsequentl release a SIG/ dis #61 I receive rav revie fro Chri Terr i Microsystem, May '83 H sai "I yo can' affor dBAS II ge DIMS. a usin dBAS I also an prefe i fo m financia records stil prefe DIM fo mailin list becaus it' easier for me. Th mos recen growt i DIM ha bee stimulate b mailin lis a keepin fo clien whic ha grow t 750 names Currentl th updat cycl i workin lik this Name ar entere an edite i DIMS T prin labels us "put t writ th dat t sequentia file us SuperSor t sor tha fil b zi codes an prin label wit DCHESHIR.BA readin th sorte sequentia file Th zip-sorte fil i re-sorte t alphabetica b SuperSort Th origina DIM fil i archive t flopp an th har dis fil i erased alphabeti sorte ne DIM fil i mad usin "get fro th sorte sequentia file Th sequentia fil i the erase an listin o th DIM fil i printe a guid fo correction an editin durin th nex cycle. Thi wor require writin DCHESHIR.BAS bullet-proofin DGET.BAS an designin muc bette defaul printe listin format Thes improvement an som genera improvements/fixe compris versio 1.03 bein release i January 1983. 50 names Currentl th updat cycl i workin lik this Name ar entere an edite i DIMS T prin labels us "put t writ th dat t sequentia file us SuperSor t sor tha fil b zi codes an prin label wit DCHESHIR.BA readin th sorte sequentia file Th zip-sorte fil i re-sorte t alphabetica b SuperSort Th origina DIM fil i archive t flopp an th har dis fil i erased alphabeti sorte ne DIM fil i mad usin "get fro th s This is the release date of the disk. READ-ME 103 zDINSTALLDOC INSTALLDOC @INSTALLDOC 6-CPM119 DOC DNADIN .ASC 6F 92 3456 27 DPUT .ASC B6 66 4352 34 DSORT .ASC 7E 85 13568 106 DSTAT .ASC 78 D1 7296 57 DUNFLAG .BAS 0B 4E 4224 33 STRIP .ASC 9B 01 1536 12 READ-ME .103 16 7D 5120 40 DINSTALL.DOC 2E 5A 46592 364  Fog Library Disk FOG-CPM.119 Copyright (1986) by Fog International Computer Users Group to the extent not copyrighted by the original author for the exclusive use and enjoyment of its members. Any reproduction or distribution for profit or personal gain is strictly forbidden. For information, contact FOG, P. O. Box 3474, Daly City, CA. 94015-0474. as part of the description of a file indicates that the program is distributed on a "try first, pay if you like it" basis. If you find the program(s) meet your need, please refer to the author's documentation for information on becoming a registered user. Only by registering and paying for the programs you like and use will the authors of such programs continue development. Often, more complete documentation, additional modules, and new releases are available only to registered users. DISK 1 of 2. Dan's Information Management System. Filename Description -07-00 .86 This is the release date& of the disk. -CPM119 .DOC This is the description of the disk contents. DCFORM .ASC 5CA4 9K ver. 1.03 [Dan's Info System 1 of 37] A database program in MBasic, this is a comprehensive list- management system that can be installed for almost any CP/M system. Custom report formats can easily be designed. DCHESHIR.ASC 49BC 9K ver. 1.03 [Dan's Info System 2 of 37] DCREATE .ASC 4127 4K ver. 1.03 [Dan's Info System 3 of 37] DEDIT .ASC D36D 26K ver. 1.03 [Dan's Info System 4 of 37] DGET .ASC 32F4 5K ver. 1.03 [Dan's Info System 5 of 37] DGET .BAS 7F96 6K ver. 1.03 [Dan's Info System 6 of 37] DIMS .ASC 118C 10K ver. 1.03 [Dan's Info System 7 of 37] DLABELS .ASC D0DF 6K ver. 1.03 [Dan's Info System 8 of 37] DLETTERS.ASC F5CA 6K ver. 1.03 [Dan's Info System 9 of 37] DNADIN .ASC 6F92 4K ver. 1.03 [Dan's Info System 10 of 37] DPUT .ASC B666 5K ver. 1.03 [Dan's Info System 11 of 37] DSORT .ASC 7E85 14K ver. 1.03 [Dan's Info System 12 of 37] DSTAT .ASC 78D1 8K ver. 1.03 [Dan's Info System 13 of 37] DUNFLAG .BAS 0B4E 5K ver. 1.03 [Dan's Info System 14 of 37] STRIP .ASC 9B01 2K ver. 1.03 [Dan's Info System 15 of 37] READ-ME .103 167D 5K ver. 1.03 [Dan's Info System 16 of 37] DINSTALL.DOC 2E5A 46K ver. 1.03 [Dan's Info System 17 of 37] r. 1.03 [Dan's Info System 2 of 37] DCREATE .ASC 4127 4K ver. 1.03 [Dan's Info System 3 of 37] DEDIT .ASC D36D 26K ver'