image of READY prompt

Wang2200.org

Listing of file='IDS2PBX4' on disk='vmedia/701-2717B.wvd.zip'

# Sector 726, program filename = 'IDS2PBX4'
1000 REM "IDS2PBX4"
1010 COM D$(B)E,D0,C1,W9
   : IF F6$(17)<"^"THEN SELECT @PART"IDS2SUBM"
1028 D$()=ALL(FF)
   : F6$(53)="R"
1034 F5$=STR(E$(),1486,5)
   : E$="ABCDE"
   : E$=STR(E$,,VAL(STR(E$(),151))-48)
   : IF F5$=STR(E$,,LEN(F5$))THEN J0,J3=1
   : ELSE J0,J3=0
1050 IF POS(STR(E$(),449,80)>31)>0OR STR(E$(),1468,18)<>" "THEN J3=0
1066 UNPACK(########)STR(E$(),1729,8)TO E0,C0
   : E0=100/E0
   : F3=-1
   : F4,F6=0
   : D0=LEN(STR(E1$()))/56
1094 MAT REDIM E$(21)83
   : DATA SAVE DA T#2,(Z)E$()
   : MAT REDIM E$(E8)1,E3$(24)83,F$(E9)1
1104 V=C0
   : GOSUB '47
   : C1=L
   : C2=P
   : C3=E
   : C4=B
   : C5=S
   : C6=D
   : E1=T
1124 V=D0
   : GOSUB '47
   : D1=L
   : D2,E2=P
   : D3=E
   : D4=B
   : D5=S
   : D6=D
1144 LIMITS T#D,STR(E1$(V),,8),F7,J9,E2,E2
   : J9=J9-8
1152 J4=C1+C2
   : J5=J4+4
   : J6=D3+4
   : J7=LEN(D$())-J6+1
   : C7,D7=0
   : E3,H=0
   : E2=C1+C2+4
   : E7=INT(249/E2)
1182 MAT REDIM E0$(E7)E2
   : E$()=" "
   : J8=INT(1991/D3)
   : E2$()=ALL(FF)
   : D9=D5/8-1
   : STR(E2$(),1992)=BIN(D9)
   : D8,F2=0
   : E4=0
   : E0$()=ALL(FF)
   : FOR C7=1TO 8*C4+1STEP 8
   : IF POS(STR(E6$(),C7,8)<FF)=0THEN 1238
   : FOR E3=VAL(STR(E6$(),C7),2)TO VAL(STR(E6$(),C7+4),2)STEP 8
   : W=D
   : D=C6
   : IF W<>C6OR H<>E3THEN GOSUB '72(E3,24)
1214 IF E3=VAL(STR(E6$(),C7),2)THEN S=VAL(STR(E6$(),C7+2),2)
   : ELSE S=10
   : IF E3=VAL(STR(E6$(),C7+4),2)THEN W=VAL(STR(E6$(),C7+6),2)
   : ELSE W=VAL(STR(E3$(),4),2)
   : FOR C8=STO WSTEP C3
   : E4=E4+1
   : E0$(E4)=STR(E3$(),C8,J4)&BIN(E3,2)&BIN(C8,2)
   : IF E4=E7THEN GOSUB 1246
   : NEXT C8,E3
   : IF E4>0THEN GOSUB 1246
   : IF D9=0THEN 1238
   : FOR I=VAL(STR(E2$(),1992))TO 0STEP -1
   : GOSUB 1725
   : NEXT I
1238 NEXT C7
   : IF F2>0THEN GOSUB 1725
1240 MAT REDIM E$(21)83
   : DATA LOAD DA T#2,(Z)E$()
   : MAT REDIM E$(E8)1,E3$(24)83,F$(E9)1
   : IF F6>0THEN LOAD T#2,"IDS2PBX5"1000,1994
   : GOTO 1820
1246 IF E4=0THEN RETURN
   : J1=D
   : J2=H
   : FOR F1=1TO E4
   : E6=0
   : ON J3GOTO 1605
   : ON E1GOTO 1270,,,1270
   : E4$()=E0$()
   : GOSUB '67(C0,STR(E0$(F1),C1+1),-1)
   : E0$()=E4$()
   : IF D<>J1OR U<>J2THEN GOSUB '72(U,3*B)
   : GOTO 1280
1270 C=VAL(STR(E0$(F1),C1+3),2)-1
   : IF E1=4THEN C=C+C1+1
   : D=C6
   : H=E3
   : IF D<>J1OR H<>J2THEN GOSUB '72(H,24)
1280 T=E1
   : GOSUB '66(C0,C+1)
   : STR(E$(),,VAL(STR(E1$(V),13),2))=F$()
   : STR(E2$(),1993)=E0$()
1600 E0$()=STR(E2$(),1993)
1605 MAT REDIM E0$(E7)E2
   : ON E6GOTO 1660
   : F6=F6+1
   : ON J0GOTO 1640
   : V=D0
   : GOSUB '51(E$)
   : STR(E4$(),D1+1)=STR(E0$(F1),C1+1)
   : GOTO 1645
1640 IF E1=1OR E1=4THEN E4$()=E0$(F1)
   : ELSE E4$()=STR(E0$(F1),,D1)&STR(E0$(F1),C1+1)
1645 IF E1=4OR E1=1THEN STR(E4$(),D1+1)=E0$(F1)
   : IF F2=J8THEN GOSUB 1725
1660 F4=F4+1
   : X=ROUND((F4*E0,0)
   : IF X=F3THEN 1686
   : F3=X
   : PRINT HEX(06);AT(18,15);
   : PRINTUSING "Selection and/or sorting process is ###% complete",X
1686 ON E6GOTO 1700
   : STR(E2$(),F2*D3+1,D3)=STR(E4$(),,D3-1)&HEX(00)
   : F2=F2+1
1700 NEXT F1
   : IF D=J1AND H=J2THEN 1705
   : D=J1
   : GOSUB '72(J2,24)
1705 E4=0
   : E0$()=ALL(FF)
   : RETURN
1725 MAT REDIM E2$(J8)D3,E$(J8)2,E3$(J8)2
   : MAT SORTE2$()TO E3$(),E$()
   : MAT REDIM E3$(J8)D3
   : MAT MOVE E2$(),E$()TO E3$()
   : MAT REDIM E$(E8)1,E2$(250)9,E3$(24)83
   : IF F7+8>=J9THEN STR(E3$(),1992)=HEX(00)
   : ELSE STR(E3$(),1992)=STR(E2$(),1992)
   : DATA SAVE DA T#D6,(F7,F7)E3$()
   : IF VAL(STR(E2$(),1992))<D9THEN 1785
   : MAT SEARCHD$(),>=STR(E3$(),,D3)TO F9$STEP J6
1770 F5=VAL(F9$,2)
   : MAT COPY -D$()<F5,J7-F5>TO -D$()<F5+J6,J7-F5>
   : STR(D$(),F5,J6)=STR(E3$(),,D3)&BIN(F7-8,2)&BIN(D3+1,2)
1785 E$()=" "
   : F2,H,D=0
   : STR(E2$(),,1991)=ALL(FF)
   : IF VAL(STR(E2$(),1992))=0THEN STR(E2$(),1992,1)=BIN(D9)
   : ELSE STR(E2$(),1992,1)=ADDHEX(FF)
   : IF F7<J9OR X=100THEN RETURN
1820 IF F6>1THEN GOSUB '35("Sort file full.  EXEC to process records found, FN
     '31 to Cancel")
   : ELSE GOSUB '35("No records found meeting selection criteria.  Please canc
     el")
   : E2$(250)=HEX(010000B89F904000)
   : F6$(11)="N"
   : GOSUB '34(250)
   : IF Q=32THEN 1240
   : IF Q<>31THEN 1820
   : COM CLEAR F()
   : $CLOSE#1
1842 SELECT #1<STR(F4$,,3)>
   : HEXPACKE8$(7)FROMSTR(F4$,2,2)
   : MAT REDIM E$(E8)1,F$(E9)1,E0$(249)1,E4$(16)16,E2$(250)9
   : F5$="IDS2PX##"
   : CONVERT R0TO STR(F5$,7,2),(##)
   : SCRATCH T#2,F5$
   : SAVE DC T#2,()F5$1000,1000
   : GOSUB '40(R3$(1))
1850 DEFFN'72(H,W)
   : E4$()=E0$()
   : GOSUB '50(H,W,E9$)
   : MAT REDIM E0$(E7)E2
   : E0$()=E4$()
   : RETURN
   : GOTO 1600
1990 %
1994 GOTO 1994
   : GOTO 1605
3699 ON ERRORE1$,E2$GOTO 3700
3700 DEFFN'31
   : E$="IDS2PBX4"
   : IF E5$<"Y"THEN LOAD T#2,"IDS2PER1"1000,
   : STOP "ERROR"