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
