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"