Listing of file='IDS2PBX2' on disk='vmedia/701-2717B.wvd.zip'
# Sector 606, program filename = 'IDS2PBX2' 1000 REM "IDS2PBX2" - Release 2.1 - REPORT/BATCH EXECUTION - SELECT/SORT PART 1 1005 IF F6$(17)<"^"THEN SELECT @PART"IDS2SUBM" : DIM C1$(14)7 : C1$()=ALL(FF) : UNPACK(########)STR(E$(),1729,12)TO C0,C1,C5 : GOSUB '39(STR(F4$,4),4) : DATA LOAD BA T#P,(A+2)STR(F$(),,256) : E0$()=STR(F$(),95,42) : MAT REDIM E0$(14)3,E3$(14)2,F$(14)2 : MAT SORTE0$()TO F$(),E3$() : MAT REDIM F$(14)8 : MAT MOVE E0$(),E3$()TO F$() 1060 MAT REDIM F$(E9)1,E0$(249)1,E3$(24)83 : STR(F$(),113)=" " : CONVERT R0TO F9$,(##) : F5$="@SORT"&F9$&"@" : I=1 1080 IF VER(STR(F$(),I),"3##")=3OR VER(STR(F$(),I),"B##")=3OR VER(STR(F$(),I), "D##")=3THEN 1090 : IF STR(F$(),I)=" "THEN 1165 1085 STR(F$(),I)=STR(F$(),I+8) : GOTO 1080 1090 MAT SEARCHF$(),=STR(F$(),I,3)TO F9$STEP 8 : IF VAL(F9$,2)<IAND F9$>HEX(0000)THEN 1085 : MAT SEARCHE0$(),=STR(F$(),I,3)TO F9$STEP 3 : D=(VAL(F9$,2)+5)/3 : J5=0 : IF D=2THEN 1110 1100 $OPEN 1120,#D : ERRORGOTO 1122 1105 $CLOSE#D 1110 $GIO#D,(0101020112124400,D2$) : ERRORGOTO 1122 1115 IF STR(D2$,8,1)<>HEX(10)THEN 1125 : STR(F$(),I+3,5)="(off)" : GOTO 1155 1120 J5=J5+1 : IF J5<20THEN 1100 1122 STR(F$(),I+3,5)="(off)" : GOTO 1155 1125 LIMITS T#D,F5$,A,B,C,Q : ERRORSTR(F$(),I+3,5)="(err)" : GOTO 1155 1130 C2=D : IF Q=0THEN 1140 : X=B-A+1 : E6$="1" : GOTO 1145 1140 DATA LOAD BA T#D,(0)E4$() : X=VAL(STR(E4$(),5),2)-VAL(STR(E4$(),3),2) : E6$="2" 1145 CONVERT XTO E$,(#####) : Q=X : STR(F$(),I+3,5)=E$ : C1$(I/8+1)=E6$&BIN(65535-Q,2)&STR(F$(),I,3)&BIN(C2) : GOTO 1155 1155 I=I+8 : GOTO 1080 1165 C2,C3,C4=0 : IF E$(1492)<>" "THEN 1195 : FOR I=1TO VAL(E$(1600)) : E$(1485+I)=BIN(I+64) : NEXT I 1195 Z=LEN(STR(E1$(),1))/56 : E1$(Z)=STR(F5$,,8)&" "&STR(E1$(VAL(STR(E1$(C1),10),2)),10,2)&HEX(08)&STR( E1$(C1),13) : STR(E1$(Z),28,15)=ALL(00) : FOR I=1TO 5 : IF E$(1485+I)=" "THEN 1260 : E$=STR(E$(),1602+(VAL(E$(1485+I))-65)*6,6) : L=VAL(STR(E$,3)) : T=INT(MOD(VAL(E$,2),16)/2) : IF C3>0AND T<4THEN T=4 : IF C4>0THEN T=7 : IF T<4THEN C2=C2+L 1245 IF T>3AND T<7THEN C3=C3+L : IF T>6THEN C4=C4+L : STR(E1$(Z),I*3+25,3)=BIN(INT(VAL(E$,2)/16)+E(VAL(E$(VAL(E$(1485+I))+807)) -47)-1,2)&STR(E$,3) 1260 NEXT I : STR(E1$(Z),21,3)=BIN(C2+C3+C4)&BIN(C2)&BIN(C3) : C3=C3+MOD(C2,2) : C4=C4+MOD(C3,4) : T=VAL(STR(E1$(C1),12)) : C2=INT(C2/2)+3*INT(C3/4)+C4 : E$=STR(E$(),1486,5) : P=VAL(STR(E1$(C1),25)) : E8$="ABCDE" : E8$=STR(E8$,,VAL(STR(E$(),151))-48) : IF T>1AND T<>4THEN 1325 : P=VAL(STR(E1$(C1),24)) : ADD(STR(E1$(Z),12,1),01) : IF E$=STR(E8$,,LEN(E$))THEN C2=0 1325 X=C2+P+1 : STR(E1$(Z),24,4)=BIN(C2)&BIN(P)&BIN(X,2) : Y=INT(1991/X) : X=ABS(INT(-C0/Y)) : C6=X : C7=1 : IF E$<>STR(E8$,,LEN(E$))THEN 1380 : C6=VAL(STR(E1$(C1),43),2) : C7=ABS(INT(-C5/Y)) : IF C7=1THEN C6=X 1380 C8=C6*C7*8+2 : STR(E1$(Z),43,7)=BIN(C6,2)&BIN(C7*8)&BIN(C7*8,2)&BIN(Y*C7,2) : CONVERT C8TO STR(E$(),1741,5),(#####) : MAT REDIM E0$(14)2,F$(14)2 : MAT SORTC1$()TO F$(),E0$() : FOR I=1TO 14 : STR(C1$(I),2,2)=XOR ALL(FF) : NEXT I : MAT REDIM F$(14)7 : MAT MOVE C1$(),E0$()TO F$() : MAT REDIM E0$(249)1,F$(E9)1 : IF STR(E$(),857,3)=" "THEN STR(E$(),857,3)=STR(F$(),4) 1435 E$=STR(E$(),857,3) : J0=0 1440 MAT SEARCHF$()<4>,=STR(E$,,3)TO F9$STEP 7 : IF F9$>HEX(0000)AND STR(E$,,3)<HEX(FFFFFF)THEN 1540 : IF J0=0THEN GOSUB 1470 : GOSUB '43(2) : IF STR(E$,,3)<HEX(FFFFFF)THEN 1457 1456 GOSUB '35("No disks are available. EXEC to re-try, FN '31 to cancel") : F6$(11)="N" : GOSUB '34(250) : IF Q=32THEN 1005 : IF Q<>31THEN 1456 : COM CLEAR F() : GOSUB '40(R3$(1)) 1457 GOSUB '35("Invalid disk address. Please choose only from those listed.") : F=1 : GOTO 1590 1470 IF J0=1THEN RETURN : J0=1 : GOSUB '32("IDS2sR13") : PRINT AT(14,13);"Disk device address for select/sort work file is:"; : GOSUB '37(2) : FOR I=17TO 53STEP 18 : PRINT AT(16,I);"Dev Space"; : NEXT I : I=1 : J=4 1490 IF STR(F$(),J,3)=" "OR STR(F$(),J,3)=HEX(FFFFFF)THEN 1510 : GOSUB '45(I/4+5,STR(F$(),J,3)) : PRINT AT(R,C+3); : X=VAL(STR(F$(),J-2),2) : GOSUB '55(I/4+6,X) : I=I+8 : J=J+7 : GOTO 1490 1510 GOSUB '55(3,C8) : E$=E$&" sectors" : IF STR(E$(),1468,18)=" "THEN E$=E$&" are" : ELSE E$=E$&" may be" : E$=E$&" required." : PRINT AT(R,C);E$ : RETURN 1540 Y=VAL(STR(F$(),VAL(F9$,2)+1),2) : IF F$(VAL(F9$,2))="2"OR J0=1THEN 1550 : X,C9=Y : CONVERT XTO STR(E$(),1746,5),(#####) : IF X>=C8THEN 1665 1550 IF J0=0THEN GOSUB 1470 : IF F$(VAL(F9$,2))="2"THEN GOSUB '55(4,0) : ELSE IF F$(VAL(F9$,2))="1"THEN GOSUB '55(4,Y) : IF F$(VAL(F9$,2))="2"THEN STR(E2$(4),5,1)=OR HEX(01) : ELSE IF F$(VAL(F9$,2))="1"THEN STR(E2$(4),5,1)=AND HEX(FE) : PRINT AT(R,C+LEN(E$));HEX(0F);" are allocated." : C9=Q : IF Q>0THEN 1600 : F=3 1585 F=F+1 1590 GOSUB '34(F) : ON FGOTO 1585,1440,1585 1600 GOSUB '43(4) : X=Q : IF X<=YTHEN 1610 : E$=" " : $PACK(F=HEX(1006))E$FROMY : F0$="Too many sectors. Only"&E$&" are available on disk "&STR(E$(),857,3 )&"." : GOSUB '35(F0$) : GOTO 1590 1610 IF X>=C8THEN 1665 : IF X>9AND STR(E$(),1468,18)<>" "THEN 1650 : GOSUB '43(3) : IF STR(E$(),1468,18)<>" "THEN E4$()="10" : E$="At least "&E4$()&" sectors must be allocated." : IF C9>0THEN E$=E$&" Select disk or cancel." : IF C9>0THEN F=2 : GOSUB '35(E$) : GOTO 1590 1650 E$="May not be enough space depending on record selection. EXEC=Accept ED IT=Modify" : GOSUB '63(STR(E$,,16),STR(E$,17),"!") : GOSUB '34(250) : IF Q=32THEN 1665 : IF Q<>33THEN 1650 : F=2 : GOTO 1590 1665 STR(E1$(Z),9,1)=STR(F$(),VAL(F9$,2)+6) : D=VAL(STR(E1$(Z),9)) : F5$="@SORTxx@" : CONVERT R0TO STR(F5$,6,2),(##) : IF C9=0THEN DATA SAVE DC OPEN T#D,(X)F5$ : ELSE DATA LOAD DC OPEN T#D,F5$ : DSKIP #D,X-2S : DATA SAVE DC #D,END : LIMITS T#D,F5$,A,B,C,D : STR(E1$(Z),55)=BIN(A,2) : B=VAL(STR(E1$(Z),43),2)+1 : E=VAL(STR(E1$(Z),27))+4 1715 IF E$(1)="\F2"THEN LOAD T#2,"IDS2PRX0"1000,1994 : LOAD T#2,"IDS2PBX3"1000,1994 1990 LOAD T#2,"IDS2PRX2"1000,1994 : GOTO 1990 1992 DEFFN'68 : RETURN 1994 % 3699 ON ERRORE1$,E2$GOTO 3700 3700 DEFFN'31 : E$="IDS2PBX2" : IF E5$<"Y"THEN LOAD T#2,"IDS2PER1"1000, : STOP "ERROR"