- XBGL ;IHS/ITSC/DMJ - GLOBAL LISTER [ 03/17/2005 10:46 AM ]
- ;;3.0;IHS/VA UTILITIES;**10**;
- START ;START HERE
- K XB,DIR W ! S $Y=1
- S DIR(0)="FAO^1:80",DIR("A")="Global: ^" D ^DIR K DIR
- I Y=""!(Y="^") W ! K DIR Q
- I Y[",,"!(Y["(,") W *7,!!,"Use '*' for wildcard.",! G START
- I $E(Y,1)'="^" S Y="^"_Y
- I $L(Y,"(")=2,$P(Y,"(",2)']"" S Y=$P(Y,"(",1)
- S (XB("Y"),XB("IN"))=Y
- S XB("RB")=$P(XB("IN"),"(",1)
- I1 ;SET UP INPUT FOR COMPARISON
- I XB("IN")["(" D
- .S (XB("LP"),XB("RP"))=0 F I=1:1:$L(XB("IN")) S:$E(XB("IN"),I)="(" XB("LP")=XB("LP")+1 S:$E(XB("IN"),I)=")" XB("RP")=XB("RP")+1
- .S XB("X")="",XB("Z")=""
- .S XB("IS")=$P(XB("IN"),"(",2,999)
- .I $E(XB("IS"),$L(XB("IS")))=")",XB("LP")=XB("RP") S XB("IS")=$E(XB("IS"),1,$L(XB("IS"))-1)
- .F I=1:1:$L(XB("IS"),",") D
- ..S XB("I"_I)=$P(XB("IS"),",",I) Q:XB("I"_I)=""
- ..S X="ER2",@^%ZOSF("TRAP") I 'XB("I"_I),XB("I"_I)'=0,XB("I"_I)'="*",$E(XB("I"_I),1)'=$C(34) D
- ...I $E(XB("I"_I),$L(XB("I"_I)))=":" S XB("I"_I)=$E(XB("I"_I),1,$L(XB("I"_I))-1),XB("F3")=1
- ...S XB("I"_I)=@XB("I"_I)
- ...I $G(XB("F3")) S XB("I"_I)=XB("I"_I)_":",XB("F3")=0
- ..S $P(XB("X"),",",I)=XB("I"_I),$P(XB("Z"),",",I)=XB("I"_I)
- ..I XB("I"_I)="*" S $P(XB("X"),",",I)="0"
- ..I $E(XB("I"_I),$L(XB("I"_I)))=":" S $P(XB("Z"),",",I)="*",$P(XB("X"),",",I)=$E(XB("I"_I),1,$L(XB("I"_I))-1),XB("I"_I)="*"
- .S XB("IN")=XB("RB")_"("_XB("Z")_$S($E(Y,$L(Y))=")"&(XB("RP")=XB("LP")):")",1:""),XB("I")=$L(XB("Z"),",")
- .S XB("Y")=XB("RB")_"("_XB("X")_")"
- FIRST ;INITIAL ENTRY
- S X="ER1",@^%ZOSF("TRAP")
- I XB("IN")[")",XB("IN")'["*" S XB("F1")=1
- I $D(@XB("Y"))#2 D DISP I $G(XB("OUT")) G START
- LOOP ;LOOP HERE
- S X="ER2",@^%ZOSF("TRAP")
- F S XB("Y")=$Q(@(XB("Y"))) D MATCH Q:$G(XB("F1")) D DISP I $G(XB("OUT")) G START
- G START
- ER1 ;FIRST ERROR CONDITION
- G LOOP
- ER2 ;SECOND ERROR CONDITION
- W *7,!!,"??",! G START
- MATCH ;DECIPHER INPUT
- I XB("Y")="" S XB("F1")=1 Q
- I $P(XB("IN"),"(",2)']"" Q
- S XB("F2")=0
- S XB("SB")=$P(XB("Y"),"(",2),XB("SB")=$E(XB("SB"),1,$L(XB("SB"))-1),XB("S")=$L(XB("SB"),",")
- I $E(XB("IN"),$L(XB("IN")))=")",XB("S")'=XB("I") S XB("F2")=1 Q
- S XB("*")=0 F I=1:1:XB("I") D
- .I XB("I"_I)="*" S XB("*")=XB("*")+1 Q
- .S XB("S"_I)=$P(XB("SB"),",",I)
- .I XB("I"_I)'=XB("S"_I) D
- ..S XB("F2")=1
- ..I 'XB("*") S XB("F1")=1
- ..I XB("IN")'["*" S XB("F1")=1
- Q
- DISP ;OUTPUT
- Q:$G(XB("F2"))
- S XB("=")=@(XB("Y"))
- W !,XB("Y")," = ",XB("=")
- I $Y>20 D
- .S DIR(0)="E" D ^DIR K DIR
- .I 'Y S XB("OUT")=1 Q
- .W @IOF
- Q
- XBGL ;IHS/ITSC/DMJ - GLOBAL LISTER [ 03/17/2005 10:46 AM ]
- +1 ;;3.0;IHS/VA UTILITIES;**10**;
- START ;START HERE
- +1 KILL XB,DIR
- WRITE !
- SET $Y=1
- +2 SET DIR(0)="FAO^1:80"
- SET DIR("A")="Global: ^"
- DO ^DIR
- KILL DIR
- +3 IF Y=""!(Y="^")
- WRITE !
- KILL DIR
- QUIT
- +4 IF Y[",,"!(Y["(,")
- WRITE *7,!!,"Use '*' for wildcard.",!
- GOTO START
- +5 IF $EXTRACT(Y,1)'="^"
- SET Y="^"_Y
- +6 IF $LENGTH(Y,"(")=2
- IF $PIECE(Y,"(",2)']""
- SET Y=$PIECE(Y,"(",1)
- +7 SET (XB("Y"),XB("IN"))=Y
- +8 SET XB("RB")=$PIECE(XB("IN"),"(",1)
- I1 ;SET UP INPUT FOR COMPARISON
- +1 IF XB("IN")["("
- Begin DoDot:1
- +2 SET (XB("LP"),XB("RP"))=0
- FOR I=1:1:$LENGTH(XB("IN"))
- IF $EXTRACT(XB("IN"),I)="("
- SET XB("LP")=XB("LP")+1
- IF $EXTRACT(XB("IN"),I)=")"
- SET XB("RP")=XB("RP")+1
- +3 SET XB("X")=""
- SET XB("Z")=""
- +4 SET XB("IS")=$PIECE(XB("IN"),"(",2,999)
- +5 IF $EXTRACT(XB("IS"),$LENGTH(XB("IS")))=")"
- IF XB("LP")=XB("RP")
- SET XB("IS")=$EXTRACT(XB("IS"),1,$LENGTH(XB("IS"))-1)
- +6 FOR I=1:1:$LENGTH(XB("IS"),",")
- Begin DoDot:2
- +7 SET XB("I"_I)=$PIECE(XB("IS"),",",I)
- IF XB("I"_I)=""
- QUIT
- +8 SET X="ER2"
- SET @^%ZOSF("TRAP")
- IF 'XB("I"_I)
- IF XB("I"_I)'=0
- IF XB("I"_I)'="*"
- IF $EXTRACT(XB("I"_I),1)'=$CHAR(34)
- Begin DoDot:3
- +9 IF $EXTRACT(XB("I"_I),$LENGTH(XB("I"_I)))=":"
- SET XB("I"_I)=$EXTRACT(XB("I"_I),1,$LENGTH(XB("I"_I))-1)
- SET XB("F3")=1
- +10 SET XB("I"_I)=@XB("I"_I)
- +11 IF $GET(XB("F3"))
- SET XB("I"_I)=XB("I"_I)_":"
- SET XB("F3")=0
- End DoDot:3
- +12 SET $PIECE(XB("X"),",",I)=XB("I"_I)
- SET $PIECE(XB("Z"),",",I)=XB("I"_I)
- +13 IF XB("I"_I)="*"
- SET $PIECE(XB("X"),",",I)="0"
- +14 IF $EXTRACT(XB("I"_I),$LENGTH(XB("I"_I)))=":"
- SET $PIECE(XB("Z"),",",I)="*"
- SET $PIECE(XB("X"),",",I)=$EXTRACT(XB("I"_I),1,$LENGTH(XB("I"_I))-1)
- SET XB("I"_I)="*"
- End DoDot:2
- +15 SET XB("IN")=XB("RB")_"("_XB("Z")_$SELECT($EXTRACT(Y,$LENGTH(Y))=")"&(XB("RP")=XB("LP")):")",1:"")
- SET XB("I")=$LENGTH(XB("Z"),",")
- +16 SET XB("Y")=XB("RB")_"("_XB("X")_")"
- End DoDot:1
- FIRST ;INITIAL ENTRY
- +1 SET X="ER1"
- SET @^%ZOSF("TRAP")
- +2 IF XB("IN")[")"
- IF XB("IN")'["*"
- SET XB("F1")=1
- +3 IF $DATA(@XB("Y"))#2
- DO DISP
- IF $GET(XB("OUT"))
- GOTO START
- LOOP ;LOOP HERE
- +1 SET X="ER2"
- SET @^%ZOSF("TRAP")
- +2 FOR
- SET XB("Y")=$QUERY(@(XB("Y")))
- DO MATCH
- IF $GET(XB("F1"))
- QUIT
- DO DISP
- IF $GET(XB("OUT"))
- GOTO START
- +3 GOTO START
- ER1 ;FIRST ERROR CONDITION
- +1 GOTO LOOP
- ER2 ;SECOND ERROR CONDITION
- +1 WRITE *7,!!,"??",!
- GOTO START
- MATCH ;DECIPHER INPUT
- +1 IF XB("Y")=""
- SET XB("F1")=1
- QUIT
- +2 IF $PIECE(XB("IN"),"(",2)']""
- QUIT
- +3 SET XB("F2")=0
- +4 SET XB("SB")=$PIECE(XB("Y"),"(",2)
- SET XB("SB")=$EXTRACT(XB("SB"),1,$LENGTH(XB("SB"))-1)
- SET XB("S")=$LENGTH(XB("SB"),",")
- +5 IF $EXTRACT(XB("IN"),$LENGTH(XB("IN")))=")"
- IF XB("S")'=XB("I")
- SET XB("F2")=1
- QUIT
- +6 SET XB("*")=0
- FOR I=1:1:XB("I")
- Begin DoDot:1
- +7 IF XB("I"_I)="*"
- SET XB("*")=XB("*")+1
- QUIT
- +8 SET XB("S"_I)=$PIECE(XB("SB"),",",I)
- +9 IF XB("I"_I)'=XB("S"_I)
- Begin DoDot:2
- +10 SET XB("F2")=1
- +11 IF 'XB("*")
- SET XB("F1")=1
- +12 IF XB("IN")'["*"
- SET XB("F1")=1
- End DoDot:2
- End DoDot:1
- +13 QUIT
- DISP ;OUTPUT
- +1 IF $GET(XB("F2"))
- QUIT
- +2 SET XB("=")=@(XB("Y"))
- +3 WRITE !,XB("Y")," = ",XB("=")
- +4 IF $Y>20
- Begin DoDot:1
- +5 SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- +6 IF 'Y
- SET XB("OUT")=1
- QUIT
- +7 WRITE @IOF
- End DoDot:1
- +8 QUIT
