15 PRINT"DEDIT must be entered from DIMS.
20 STOP
1000 '
PROGRAM BEGINS HERE
1010 PRINT:PRINT TAB(31);"DEDIT March 20, 1982
1020 DEFINT A-Z
1030 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 7000
1050 '
DIM FOR FORMAT
1060 DIM SQ(NC+1),FM(NC),LFM(NC),F2$(NC),LF2$(NC)
1070 DIM NLL(NC),LNLL(NC),NLC(NC),LNLC(NC)
1080 DIM PU$(NC),LPU$(NC),DLL(NC),LDLL(NC),DLC(NC),LDLC(NC)
1090 DIM FMB(NC),LFMB(NC),FL(NC),LFL(NC),FB(NC),LFB(NC)
1100 GOSUB 7870 ' load default format
1110 IF T=0 THEN T1=N:T2=N:PRINT:PRINT"Here's the last record:":GOTO 2900
1120 '
COMMAND PROCESSOR
ENTER HERE AFTER FINISHING COMMAND
1130 E$="" ' error msg
1140 '
ENTER WITH ERROR
1150 FOR I=1 TO 10:C$(I)="":NEXT ' clear
1160 '
ACCEPT COMMAND
1170 IF E$<>"" THEN PRINT CHR$(7);
1180 PRINT CHR$(13);
1190 IF RS THEN X=22:Y=1:GOSUB 6700
1200 PRINT SPC(79); CHR$(13);
1210 PRINT E$" ";:E$="":PRINT"Edit ";F$;": ";: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 '
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
2180 PI=0
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 '
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 '
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
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
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=22: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<RS) THEN 4160
4060 GOSUB 7430 'cs
4070 RC=0:PG=PG+1
4080 PRINT CHR$(13);'CR
4090 X=TM:GOSUB 6730 ' top margin
4100 IF HL1$<>"" 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 '
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 pg
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
5430 LPRINT LF2$(K);:LP=LP+LEN(LF2$(K))
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 L
FL(K) THEN X$=LEFT$(B$(K),LFL(K)) ELSE X$=B$(K)
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=22: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
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
5800 IF P7 THEN GOSUB 8410'close 2
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
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 '
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<X AND X<123 THEN MID$(Y$,K,1)=CHR$(X-32): GOTO 7140
7130 MID$(Y$,K,1)=MID$(X$,K,1)
7140 NEXT
7150 RETURN
7160 '
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
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 if you don't care "; 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(32);:LINE INPUT"Expression to look for? "; 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$(1)="": RETURN
7670 PRINT:FOR J=0 TO 9
7680 INPUT"Number of field to search - RETURN if you don't care ";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(32);:LINE INPUT"Expression to look for? "; 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 '
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"Number 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
