Listing of file='IDS2PPG0' on disk='vmedia/701-2725B.wvd.zip'
# Sector 223, program filename = 'IDS2PPG0'
1000 REM "IDS2PPG0" - Release 2.1 - INTERACTIVE PROGRAM CANNED MODULE CHECK
1005 E6$=F6$(17)AND HEX(02)
: IF E6$=HEX(00)THEN LOAD T#2,"IDS2SUB8"3701,3899BEG 1010
1010 IF F6$(17)<"^"THEN SELECT @PART"IDS2SUBM"
: DIM C(5)
: GOSUB '32("IDS2sP03")
: F9=0
: GOSUB '37(1)
: GOSUB '37(2)
: GOSUB '45(22,F6$)
: ON VAL(F6$)GOTO ,,1080,1090,1100
: GOSUB '45(3,"Add/change/delete")
: GOTO 1110
1080 GOSUB '45(3,"Add a record only")
: GOTO 1110
1090 GOSUB '45(3,"Random inquiry")
: GOTO 1110
1100 GOSUB '45(3,"Sequential inquiry")
1110 GOSUB '37(4)
: GOSUB '37(5)
: GOSUB '37(13)
: GOSUB '37(14)
: GOSUB '43(13)
: E$=E$OR ALL(20)
: GOSUB '39(E$,5)
: MAT REDIM E3$(6)83
: DATA LOAD DA T#P,(A)E3$()
: FOR I=0TO 4
: GOSUB '45(I+15,STR(E3$(),I*17+108,8))
: IF E$<>" "THEN F6=I
: STR(E$(),I*2+645,2)=STR(E3$(),I*17+121)
: NEXT I
: GOSUB '43(4)
: GOSUB '39(E$,3)
: MAT REDIM E3$(24)83
: DATA LOAD DA T#P,(A)E3$()
: X=VAL(STR(E3$(),137))
1280 Y=VAL(STR(E3$(),138))
: Z=VAL(STR(E3$(),135))
: STR(E$(),641,4)=BIN(P)&BIN(A+8,2)&BIN(X)
: IF Z>0THEN 1320
: F9=1
: GOTO 1710
1320 F$()=ALL(00)
: E3$()=" "
: MAT REDIM F$(X)83,E3$(Y)83
: DATA LOAD DA T#P,(A+8)F$(),E3$()
: MAT REDIM F$(Z)9,E3$(Z)8
: GOSUB '45(6,E3$(1))
: F5=Z+1
: FOR I=ZTO 1STEP -1
: IF INT(VAL(STR(F$(I),4))/8)=23AND INT(VAL(STR(F$(I),5))/2)=79THEN F5=I
: NEXT I
: STR(E$(),635,6)=HEX(0100)&HEX(00)&HEX(00)&BIN(F5)&HEX(00)
: E$(656)=BIN(MAX(F5,Z))
1440 IF F5>ZTHEN GOSUB '45(12,"@ACCEPT?")
: ELSE GOSUB '45(12,E3$(F5))
: I=-1
1470 I=I+1
: GOSUB '43(I+15)
: IF E$>" "THEN MAT SEARCHE3$(),=STR(E$,,8)TO F9$STEP 8
: IF F9$>HEX(0000)OR E$=" "THEN 1512
: F9=3
: GOTO 1710
1512 IF E$=" "AND E$(637)=HEX(FF)THEN E$(637)=BIN(I-1)
: IF E$=" "THEN C(I+1)=999
: ELSE C(I+1)=(7+VAL(F9$,2))/8
: IF E$<>" "THEN E$(655)=BIN(I)
: IF E$>" "AND C(I+1)>VAL(E$(637))THEN E$(637)=BIN(C(I+1))
: IF I<4THEN 1470
: FOR I=0TO VAL(E$(655))
: F4=MIN(C())
: FOR J=1TO 5
: IF C(J)<>F4THEN 1540
: GOSUB '43(J+14)
: GOSUB '45(I+7,E$)
: C(J)=999
1540 NEXT J,I
: F1=0
: FOR I=0TO VAL(STR(E1$(2),43),2)-1
: DATA LOAD BA T#2,(VAL(STR(E1$(2),55),2)+I*VAL(STR(E1$(2),46),2))E4$()
: F1=F1+VAL(STR(E4$(),9),2)
: NEXT I
: F2=(I+1)*VAL(STR(E1$(2),48),2)
: GOSUB '55(20,100*F1/F2)
: GOSUB '55(21,F2-F1)
: I=5
1630 I=I+1
: GOSUB '43(I)
: IF E$=" "THEN 1690
: C1$=STR(E$(),53,8)&E$
: GOSUB '60(E1$(2),C1$)
: IF STR(E6$(),,16)=C1$THEN F7=I
1690 IF I<12AND F7=0THEN 1630
: F9=5*SGN(F7)
1710 MAT REDIM E3$(24)83,F$(E9)1
1720 ON F9GOTO 1740,1750,1760,1770,1780
: E$="Touch EXEC to accept,"
: GOTO 1790
1740 E$="Not enough fields."
: GOTO 1790
1750 E$="No keyable fields."
: GOTO 1790
1760 E$="Key fields don't match."
: GOTO 1790
1770 E$="Invalid last field."
: GOTO 1790
1780 GOSUB '43(F7)
: E$="Edits exist for "&HEX(22)&E4$()&HEX(222E)
1790 E$=E$&" EDIT for screen, FN'31 to cancel"
: IF F9>0THEN GOSUB '35(E$)
: ELSE GOSUB '53(E$)
: F6$(11)="N"
: GOSUB '34(250)
: F6$(11)="Y"
: IF Q=31THEN LOAD T#2,"IDS2PP01"1000,
: F5$="IDS2PPG1"
: IF Q=32AND F9=0THEN LOAD T#2,F5$1000,
: IF Q<>33THEN 1720
: R3$()="IDS2MS01"
: E6$=HEX(01)
: E$(),E9$(2)=STR(E$(),53,8)
: LOAD T#2,"IDS2PS01"1000,
3699 ON ERRORE1$,E2$GOTO 3700
3700 DEFFN'31
: E$="IDS2PPG0"
: IF E5$<"Y"THEN LOAD T#2,"IDS2PER1"1000,
: STOP "ERROR"