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"