Listing of file='IDS2PS25' on disk='vmedia/701-2716B.wvd.zip'
# Sector 934, program filename = 'IDS2PS25'
1000 REM "IDS2PS25" - Release 2.1 - SCREEN/REPORT/BATCH TABLE LOOK-UP/REPLACE
SPEC
1010 IF F6$(17)<"^"THEN SELECT @PART"IDS2SUBM"
: GOSUB 3010
: CONVERT VAL(STR(E$(),78))-31TO STR(E$(),2073,2),(##)
: IF E0$="IDS2sS25"THEN 1030
: GOSUB '32("IDS2sS25")
: GOSUB '36
1030 GOSUB 3020
: STR(F6$(),11,4)=ALL("Y")
: IF STR(E$(),98,1944)<>" "THEN 2500
1040 F=9
1050 F=F+1
: IF F>F0THEN 2500
: IF F<>10THEN 1065
: GOSUB '43(10)
: IF E$=" "THEN GOSUB '45(10,"N")
1065 ON F-19GOTO 2000
1070 GOSUB '34(F)
1080 ON F-8GOTO 3000,1090,,1100,1120,1130,1050,1120,1130,1140,1150,1160
: IF F<21THEN 1050
: IF F<=C0+20THEN 1170
: IF F<=F0THEN 1180
: GOTO 2500
1090 IF E$="Y"THEN 1050
: IF E$<>"N"THEN 1095
: GOSUB '45(11," ")
: GOSUB '45(12," ")
: F=12
: GOTO 1050
1095 GOSUB '35("Must be 'Y' or 'N'")
: GOSUB '45(F," ")
: GOTO 1070
1100 IF E$="Y"OR E$="N"THEN 1050
: GOSUB '35("Must be 'Y' or 'N'")
: GOSUB '45(F," ")
: GOTO 1070
1120 IF E$=" "THEN 1125
: GOSUB 3140
: MAT SEARCHE3$(),=STR(E$,,8)TO F9$STEP 8
: IF F9$>HEX(0000)THEN 1126
: IF E$="LSTFNKEY"AND F=13THEN 1126
: IF VER(E$,"@TSTFLD#")=8OR E$="@SYSBUF0"THEN 1050
: GOSUB '35("Invalid field name")
: GOSUB '45(F," ")
: GOTO 1070
1125 FOR I=FTO F+2
: GOSUB '45(I," ")
: NEXT I
: F=F+2
: GOTO 1080
1126 IF E$<>"LSTFNKEY"THEN 1128
1127 GOSUB '55(F+1,2)
: F=F+1
: GOTO 1130
1128 X=INT(VAL(F9$,2)/8+1)*9-8
: IF VAL(F$(X+5))>143THEN 1127
: GOSUB '43(F+1)
: IF Q=0THEN GOSUB '55(F+1,VAL(F$(X)))
: GOTO 1050
1130 IF Q>0AND Q<80THEN 1135
: GOSUB '35("Must be greater than 0 and less than 80")
: X=INT(VAL(F9$,2)/8+1)*9-8
: IF VAL(F$(X+5))>143THEN Q=2
: ELSE Q=VAL(F$(X))
: GOSUB '55(F,Q)
: GOTO 1070
1135 X=Q
: IF F=14THEN GOSUB '55(F+1,MIN(114,INT(199/X)))
: ELSE GOSUB '55(F+1,MIN(114,INT(215/X)))
: GOTO 1050
1140 GOSUB 3020
: GOTO 1050
1150 IF E$<>" "THEN 1151
: GOSUB '45(F+1," ")
: F=F+1
: GOTO 1050
1151 GOSUB '43(13)
: IF E$=" "THEN 1153
: GOSUB '43(F)
: E$=E$OR ALL(20)
: GOSUB '39(E$,5)
: IF Q<2THEN 1155
: DATA LOAD BA T#P,(A)STR(E4$(),,256)
: IF STR(E4$(),,4)<>HEX(8201D3E3)THEN 1155
: GOTO 1050
1153 GOSUB '35("Test field name must be non-blank ")
: GOSUB '45(F," ")
: F=13
: GOTO 1070
1155 GOSUB '35("Invalid data file name -- please re-enter")
: GOSUB '45(F," ")
: GOTO 1070
1160 IF E$=" "THEN 1162
: GOSUB '43(F-1)
: IF E$>" "THEN 1165
: GOSUB '35("Data file has not been specified")
: GOSUB '45(F," ")
: GOTO 1050
1162 GOSUB '43(F-1)
: IF E$=" "THEN 1050
: GOSUB '35("Required field - you must enter a value")
: GOTO 1070
1165 E$=E$OR ALL(20)
: GOSUB '39(E$,5)
: IF A=0OR Q<2THEN 1155
: MAT REDIM E3$(24)83
: E3$()=" "
: DATA LOAD DA T#5,(A)E3$()
: IF STR(E3$(),10,1)<"5"THEN 1167
: E$=STR(E3$(),82,8)
: GOTO 1165
1167 E3$()=" "
: DATA LOAD DA T#P,(A+8)E3$()
: GOSUB '43(F)
: MAT SEARCHE3$(),=STR(E$,,8)TO F9$STEP 8
: IF F9$>HEX(0000)THEN 1050
: GOSUB '35("Field does not exist in specified data file")
: GOSUB '45(F," ")
: GOTO 1070
1170 IF F=21THEN 1180
: IF E$<>" "THEN 1180
: E$=ALL(80)
: FOR I=FTO 20+C0
: GOSUB '45(I,E$)
: NEXT I
: F=20+C0
: GOTO 1050
1180 $TRAN(E$,HEX(8020))R
: GOSUB '45(F,E$)
: GOTO 1050
2000 GOSUB '43(19)
: IF E$=" "THEN 2010
: GOSUB '43(16)
: IF E$=" "THEN 2010
: GOTO 1070
2010 GOTO 1050
2500 F0$="EXEC = Accept, EDIT = Modify,"
: IF J9=1THEN F0$=F0$&" FN'9 = Delete,"
: F0$=F0$&" FN'31 = Cancel"
: PRINT HEX(0202000F)
: GOSUB '53(F0$)
: GOSUB '34(250)
: IF Q=33THEN 1040
: IF Q=32THEN LOAD T#2,"IDS2PS28"1000,
: IF Q=9AND J9<>0THEN 2560
: PRINT HEX(07);
: GOTO 2500
2560 F6$(14)="N"
: STR(E$(),2042)=" "
: FOR I=1TO 9
: C9$=STR(E$(),82,16)&E$(78)&E$(76)&BIN(I+47)
: Q=0
: IF I=1OR F6$(42+I)="Y"THEN GOSUB '41(E1$(2),C9$,.5)
: F$()=" "
: IF Q<>0THEN GOSUB '42(E1$(2),0)
: NEXT I
: F6$(14)="Y"
: LOAD T#2,"IDS2PS18"1000,
3000 F5$="IDS2PS25"
: LOAD T#2,"IDS2PS96"1000,
3010 MAT REDIM F$(27)83
: DATA LOAD DA T#3,(E4+8)F$()
: MAT REDIM F$(E9)1
: IF C5$<>"S"THEN RETURN
: Q=VAL(C7$)*9-8
: F$(Q)=STR(C7$,3)
: F$(Q+5)=STR(C7$,2)
: RETURN
3020 GOSUB '43(15)
: C0=Q
: GOSUB '43(18)
: C4=Q
: GOSUB '43(14)
: F4=Q
: GOSUB '43(17)
: F5=Q
: PRINT HEX(0202020F)
: PRINT HEX(06);
: FOR I=12TO 16
: PRINT AT(I,0,80);AT(I+6,0,80);
: NEXT I
: IF C4>0AND STR(E$(),111,8)=" "OR C0>0THEN 3050
: Q=0
: RETURN
3050 IF C4>0AND C0>0THEN X=MIN(C4,C0)
: ELSE X=MAX(C4,C0)
: Y=MAX(F4,F5)
: F0=20+(SGN(C0)+SGN(C4))*X
: $TRAN(E$()<127,199>,HEX(8020))R
: $TRAN(E$()<339,215>,HEX(8020))R
3100 IF C0=0THEN 3110
: N=INT(79/(Y+1))
: FOR I=0TO X-1
: C=MOD(I,N)*(Y+1)+1
: R=12+INT(I/N)
: P=I*F4+127
: E2$(21+I)=BIN(F4)&BIN(P*16,2)&BIN(R*8)&BIN(C*2+1)&HEX(70800000)
: GOSUB '37(21+I)
: NEXT I
: IF C4=0THEN STR(E2$(X+20),8,1)=STR(E2$(X+20),8,1)OR BIN(32)
3110 IF C4=0THEN 3120
: N=INT(79/(Y+1))
: FOR I=0TO X-1
: C=MOD(I,N)*(Y+1)+1
: R=18+INT(I/N)
: P=I*F5+339
: E2$(21+I+X*SGN(C0))=BIN(F5)&BIN(P*16,2)&BIN(R*8)&BIN(C*2+1)&HEX(70800000)
: GOSUB '37(21+I+SGN(C0)*X)
: NEXT I
: STR(E2$(X+20+SGN(C0)*X),8,1)=STR(E2$(X+20+SGN(C0)*X),8,1)OR BIN(32)
3120 RETURN
3130 STOP #
3140 MAT REDIM E3$(24)83
: IF C5$="S"THEN I=51
: ELSE I=17
: DATA LOAD DA T#3,(E4+I)E3$()
: MAT REDIM E3$(249)8
: RETURN
3150 STOP #
: ON ERRORE1$,E2$GOTO 3700
3700 DEFFN'31
: E$="IDS2PS25"
: IF E5$<"Y"THEN LOAD T#2,"IDS2PER1"1000,
: STOP "ERROR"