10 PRINT"This program must be entered via DIMS 20 STOP 1000 GOSUB 2460 'cs 1010 PRINT:PRINT TAB(30);"DGET 1.04 - March 12, 1984 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 2390 1090 GOSUB 2490: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 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