DIG ;SFISC/GFT-SUBTOTALS & SCATTERGRAM ;28SEP2004
;;22.0;VA FileMan;**2,144**;Mar 30, 1999;Build 5
;Per VHA Directive 2004-038, this routine should not be modified.
W ! I '$D(^DOSV(0,IO(0),2)) W "NO SUB-SUB TOTALS WERE RUN" Q
N POP,IOP,ZTSK S:$D(^%ZTSK) %ZIS="QM" D ^%ZIS Q:POP
G QUE:$D(IO("Q"))
;
DQ N DXMIN,DYMIN,DXMAX,DYMAX,DXI,N,NA,DYI
S NA=$NA(^DOSV(0,IO(0)))
S X=$O(@NA@(2,"")),(DXMIN,DXMAX)=X,(DYMIN,DYMAX)=$O(^(X,"")),X=""
F S X=$O(@NA@(2,X)) Q:X="" S DXMAX=X,Y=$O(^(X,"")),DY=$O(^(""),-1) S:DYMIN>Y DYMIN=Y S:DY>DYMAX DYMAX=DY
I DXMAX-DXMIN*(DYMAX-DYMIN)=0 D STATS(NA) Q
;
;here's the SCATTERGRAM
NUMNUM N DIGPG,DIGTYPE,%H,%T,%Y,%D,B,I,L,H,T,DIGC,X,Y,DX,DY,DXS,DYS,DXSC,DYSC
D DIGC
S H=DYMAX,L=DYMIN,DYS=IOSL-9,N=DYS/6
D S(1)
S DYMIN=B,DYSC=I/6,DYMAX=T,DYI=X
DYI I T-B/DYI*6'>DYS,DYI'<2 S DYI=DYI\2 G DYI
S H=DXMAX,L=DXMIN,DXS=IOM-28,N=DXS/6
D S(2)
S DXMIN=B,DXSC=I/6,DXI=X,DXMAX=T,T=X*DXS/(T-B)
S H=""
LOOP K ^UTILITY($J)
S DIGTYPE="N",H=$O(@NA@("F",H)) G END:'H
D TOP
S (B,DX,DY)="" D G LOOP:X'=U
I2 .S (DX,X)=$O(@NA@(2,DX)) I X="" W !?5,"(TOTAL = "_B_")",! G O
.I DIGC(2,0)["D" D H^%DTC S X=%H
.S X=$J(X-DXMIN/DXSC,0,0)
I3 .S (Y,DY)=$O(@NA@(2,DX,DY)) G I2:Y="" I DIGC(1,0)["D" S C=X,X=Y D H^%DTC S Y=%H,X=C
.I $D(^(DY,H,"N")) S C=^("N"),Y=$J(Y-DYMIN/DYSC,0,0),B=B+C,^(X)=C+$G(^UTILITY($J,Y,X))
.G I3
O .S X=0 D X W !?12,"." D P K Y S L=0 F B=DYMIN:DYI:DYMAX S Y($J(L,0,0))=$$E(B,1),L=DYI*DYS/(DYMAX-DYMIN)+L
.W ".",! F Y=DYS:-1:0 D W !
..I $D(Y(Y)) W ?12-$L(Y(Y)),Y(Y),"+"
..E W ?12,"|"
..S X="" F S X=$O(^UTILITY($J,Y,X)) Q:X="" S I=^(X) W ?X+13,$S(I>9:"*",I:I,1:"")
..W ?DXS+14 I W "+",Y(Y) Q
..W "|"
.W ?13 D P W ! S X=DXI D X W !?22,"X-AXIS: ",$P(DIGC(2),U,3)," Y-AXIS: ",$P(DIGC(1),U,3)
.G EOP
END W:$E(IOST)'="C"&$Y @IOF
K:$D(ZTSK) ^DOSV(0,IO(0))
Q D CLOSE^DIO4
Q
;
X F B=DXMIN+X:DXI*2:DXMAX S Y=$$E(B,2) W ?B-DXMIN\DXSC-($L(Y)\2)+13,Y
Q
;
S(C) I DIGC(C,0)["D" F B="H","L" S X=@B D H^%DTC S @B=%H
S B=H-L,X=1 I B>1 F C=1:1 S X=X*10 Q:B'>X
E S I=1 Q:'B F C=0:-1 Q:X/10'>B S X=X/10
S B=L-X\X*X F I=B:X/10 Q:I'<L S B=I
S T=H+X\X*X F I=T:-X/10 Q:I'>H S T=I
I S I=T-B/X*10 I I>N S X=X*2 G I
S X=X/10,I=T-B/N
Q
;
;
;
STATS(NA) ;
N DIGC,DIGB,DIGPG,RUN,DIGTYPE,DIG3,I,L,%T,H,DUOUT
D DIGC S DIGPG=1
I $D(@NA@(1)) D G Q:$D(DUOUT),END
.F H=0:0 S H=$O(@NA@("F",H)),DIGTYPE="S" Q:'H D:$P(^(H),U,4)'["D" S DIGTYPE="N" D Q:$D(DUOUT)
..S Y="",L=0 F I=0:0 S Y=$O(@NA@(1,Y)) Q:Y="" I $D(^(Y,H,DIGTYPE)) S:$L(^(DIGTYPE))>L L=$L(^(DIGTYPE)) S:$L($$E(Y,1))>I I=$L($$E(Y,1))
..I 'I!'L Q
..D TOP W !!?4,$P(DIGC(1),U,3),!
..S Y="",%T=0
..F S Y=$O(@NA@(1,Y)) Q:Y="" I $D(^(Y,H,DIGTYPE)) D Q:$D(DUOUT)
...I $Y+2>IOSL D EOP Q:$D(DUOUT) D TOP
...W !?4,$$E(Y,1),?I+7 S X=@NA@(1,Y,H,DIGTYPE) W $J(X,L) S %T=%T+X
..W !!?4,"TOTAL",?I+7,$J(%T,L) D EOP
S DIGB=$NA(@NA@(2)) I $D(@DIGB)>9 D ALL2 G END
S DIG3="" F S DIG3=$O(@NA@(3,DIG3)) G END:DIG3=""!$D(DUOUT) S DIGB=$NA(@NA@(3,DIG3)) D ALL2
;
ALL2 F RUN=0:0 S RUN=$O(@NA@("F",RUN)) Q:'RUN F DIGTYPE="S","N" I $P(@NA@("F",RUN),U,4)'["D"!(DIGTYPE="N") D RUN(RUN,DIGTYPE)
Q
;
RUN(H,DIGTYPE) N %H,%Y,%D,T,C,X,Y,DX,DY,DXS,DYS,DXSC,DYSC
S Y="",I=0,C=0,L=0
F S Y=$O(@DIGB@(Y)),X="" Q:Y="" S DY=$$E(Y,2) S:$L(DY)>I I=$L(DY) D
.F S X=$O(@DIGB@(Y,X)) Q:X="" I $D(^(X,H,DIGTYPE)) S:'$D(X(X)) C=C+1 S DX=$$E(X,1) S:$L(DX)>L L=$L(DX) S X(X)=""
;I=width of left column
;L=width of data columns
;C=number of data columns
I 'C Q
S Y=L+2*C+I+13
I Y>IOM U IO(0) W !,"MARGIN WIDTH OF ",IOM," IS TOO SMALL FOR DISPLAY",!,"USE WIDTH OF AT LEAST ",Y Q
S I=I+3,L=IOM-13-I\C ;make columns wide
D TOP,SUBTOP
S Y=""
F S Y=$O(@DIGB@(Y)) Q:Y="" D G Q:$D(DUOUT)
.I $Y+2>IOSL D Q:$D(DUOUT) D TOP,SUBTOP
..N X D EOP
.N T S X="" W !!?4,$$E(Y,2),?I+6
.F N=0:1 S X=$O(X(X)) Q:X="" S %T=$G(@DIGB@(Y,X,H,DIGTYPE)) W $J(+%T,L) S T=$G(T)+%T,DX(X)=$G(DX(X))+%T
.W $J(T,7)
S X=" ----------------------------------------------------"
W !!?I+6 F N=1:1:N W $E(X,1,L)
W $E(X,1,IOM-$X)
W !!," TOTALS",?I+6 S (%T,X)="" F N=0:1 S X=$O(X(X)) Q:X="" W $J(DX(X),L) S %T=%T+DX(X)
W $J(%T,7)
EOP ;
I $G(IOST)?1"C".E D
.N DIR,X,Y
.S DIR(0)="E" D ^DIR
Q
;
TOP N X,Y
U IO W:$Y @IOF
S X=@NA@("F",H)
W !," ",$O(^DD(+X,0,"NM",0))," FILE: "
W $S(DIGTYPE="N":"COUNTS",1:"SUMS")
I $P(X,U,2)'=.01 W " OF '",$P(X,U,3),"'"
S Y=DT X ^DD("DD")
I $G(DIGPG) S Y=Y_" Page "_DIGPG,DIGPG=DIGPG+1
W ?IOM-$L(Y)-1,Y Q
;
SUBTOP N Y
I $D(DIG3) W !!?4,$P(DIGC(3),U,3),": ",$$E(DIG3,3),!
S Y=$P(DIGC(2),U,3) F X=1:1:$L(Y," ") W !?4,$P(Y," ",X)
S Y=$P(DIGC(1),U,3) W ?(IOM-I-$L(Y)\2+I+4),Y,!!
W ?I+6 S X="" F S X=$O(X(X)) Q:X="" W $J($$E(X,1),L)
W " TOTAL"
W ! F Y=1:1:IOM W "-"
Q
;
DIGC N X,C
S (X,C)="" F S X=$O(@NA@("BY",X),-1) Q:'X D
.S C=C+1,DIGC(C)=^(X)
.S DIGC(C,0)=$S($D(^DD(+DIGC(C),+$P(DIGC(C),U,2),0)):$P(^(0),U,2),1:$P(DIGC(C),U,7))
Q
;
E(VALUE,XY) ;2=Y,1=X
N %DT,Y
I $P(DIGC(XY),U,4)["-" S VALUE=-VALUE
I DIGC(XY,0)["O" Q VALUE
I VALUE,DIGC(XY,0)["D" S Y=VALUE D DD^%DT Q Y
I DIGC(XY,0)["S" S Y=$P(DIGC(XY),U,2) S:'Y Y=$P($P(DIGC(XY),U,4),"+""",2) S:Y Y=$$EXTERNAL^DILFD(+DIGC(XY),Y,,VALUE,"%DT(0)") I Y]"" Q Y
Q VALUE
;
P S L=-1,X=0
PP I L<X W "+" S L=L+T
E W "-"
S X=X+1 G PP:X'>DXS Q
;
;
QUE ;
S ZTSAVE("^DOSV(0,$I,")=""
S ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL,ZTRTN="DQ^DIG"
D ^%ZTLOAD K ZTSK G END
DIG ;SFISC/GFT-SUBTOTALS & SCATTERGRAM ;28SEP2004
+1 ;;22.0;VA FileMan;**2,144**;Mar 30, 1999;Build 5
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 WRITE !
IF '$DATA(^DOSV(0,IO(0),2))
WRITE "NO SUB-SUB TOTALS WERE RUN"
QUIT
+4 NEW POP,IOP,ZTSK
IF $DATA(^%ZTSK)
SET %ZIS="QM"
DO ^%ZIS
IF POP
QUIT
+5 IF $DATA(IO("Q"))
GOTO QUE
+6 ;
DQ NEW DXMIN,DYMIN,DXMAX,DYMAX,DXI,N,NA,DYI
+1 SET NA=$NAME(^DOSV(0,IO(0)))
+2 SET X=$ORDER(@NA@(2,""))
SET (DXMIN,DXMAX)=X
SET (DYMIN,DYMAX)=$ORDER(^(X,""))
SET X=""
+3 FOR
SET X=$ORDER(@NA@(2,X))
IF X=""
QUIT
SET DXMAX=X
SET Y=$ORDER(^(X,""))
SET DY=$ORDER(^(""),-1)
IF DYMIN>Y
SET DYMIN=Y
IF DY>DYMAX
SET DYMAX=DY
+4 IF DXMAX-DXMIN*(DYMAX-DYMIN)=0
DO STATS(NA)
QUIT
+5 ;
+6 ;here's the SCATTERGRAM
NUMNUM NEW DIGPG,DIGTYPE,%H,%T,%Y,%D,B,I,L,H,T,DIGC,X,Y,DX,DY,DXS,DYS,DXSC,DYSC
+1 DO DIGC
+2 SET H=DYMAX
SET L=DYMIN
SET DYS=IOSL-9
SET N=DYS/6
+3 DO S(1)
+4 SET DYMIN=B
SET DYSC=I/6
SET DYMAX=T
SET DYI=X
DYI IF T-B/DYI*6'>DYS
IF DYI'<2
SET DYI=DYI\2
GOTO DYI
+1 SET H=DXMAX
SET L=DXMIN
SET DXS=IOM-28
SET N=DXS/6
+2 DO S(2)
+3 SET DXMIN=B
SET DXSC=I/6
SET DXI=X
SET DXMAX=T
SET T=X*DXS/(T-B)
+4 SET H=""
LOOP KILL ^UTILITY($JOB)
+1 SET DIGTYPE="N"
SET H=$ORDER(@NA@("F",H))
IF 'H
GOTO END
+2 DO TOP
+3 SET (B,DX,DY)=""
Begin DoDot:1
I2 SET (DX,X)=$ORDER(@NA@(2,DX))
IF X=""
WRITE !?5,"(TOTAL = "_B_")",!
GOTO O
+1 IF DIGC(2,0)["D"
DO H^%DTC
SET X=%H
+2 SET X=$JUSTIFY(X-DXMIN/DXSC,0,0)
I3 SET (Y,DY)=$ORDER(@NA@(2,DX,DY))
IF Y=""
GOTO I2
IF DIGC(1,0)["D"
SET C=X
SET X=Y
DO H^%DTC
SET Y=%H
SET X=C
+1 IF $DATA(^(DY,H,"N"))
SET C=^("N")
SET Y=$JUSTIFY(Y-DYMIN/DYSC,0,0)
SET B=B+C
SET ^(X)=C+$GET(^UTILITY($JOB,Y,X))
+2 GOTO I3
O SET X=0
DO X
WRITE !?12,"."
DO P
KILL Y
SET L=0
FOR B=DYMIN:DYI:DYMAX
SET Y($JUSTIFY(L,0,0))=$$E(B,1)
SET L=DYI*DYS/(DYMAX-DYMIN)+L
+1 WRITE ".",!
FOR Y=DYS:-1:0
Begin DoDot:2
+2 IF $DATA(Y(Y))
WRITE ?12-$LENGTH(Y(Y)),Y(Y),"+"
+3 IF '$TEST
WRITE ?12,"|"
+4 SET X=""
FOR
SET X=$ORDER(^UTILITY($JOB,Y,X))
IF X=""
QUIT
SET I=^(X)
WRITE ?X+13,$SELECT(I>9:"*",I:I,1:"")
+5 WRITE ?DXS+14
IF $TEST
WRITE "+",Y(Y)
QUIT
+6 WRITE "|"
End DoDot:2
WRITE !
+7 WRITE ?13
DO P
WRITE !
SET X=DXI
DO X
WRITE !?22,"X-AXIS: ",$PIECE(DIGC(2),U,3)," Y-AXIS: ",$PIECE(DIGC(1),U,3)
+8 GOTO EOP
End DoDot:1
IF X'=U
GOTO LOOP
END IF $EXTRACT(IOST)'="C"&$Y
WRITE @IOF
+1 IF $DATA(ZTSK)
KILL ^DOSV(0,IO(0))
Q DO CLOSE^DIO4
+1 QUIT
+2 ;
X FOR B=DXMIN+X:DXI*2:DXMAX
SET Y=$$E(B,2)
WRITE ?B-DXMIN\DXSC-($LENGTH(Y)\2)+13,Y
+1 QUIT
+2 ;
S(C) IF DIGC(C,0)["D"
FOR B="H","L"
SET X=@B
DO H^%DTC
SET @B=%H
+1 SET B=H-L
SET X=1
IF B>1
FOR C=1:1
SET X=X*10
IF B'>X
QUIT
+2 IF '$TEST
SET I=1
IF 'B
QUIT
FOR C=0:-1
IF X/10'>B
QUIT
SET X=X/10
+3 SET B=L-X\X*X
FOR I=B:X/10
IF I'<L
QUIT
SET B=I
+4 SET T=H+X\X*X
FOR I=T:-X/10
IF I'>H
QUIT
SET T=I
I SET I=T-B/X*10
IF I>N
SET X=X*2
GOTO I
+1 SET X=X/10
SET I=T-B/N
+2 QUIT
+3 ;
+4 ;
+5 ;
STATS(NA) ;
+1 NEW DIGC,DIGB,DIGPG,RUN,DIGTYPE,DIG3,I,L,%T,H,DUOUT
+2 DO DIGC
SET DIGPG=1
+3 IF $DATA(@NA@(1))
Begin DoDot:1
+4 FOR H=0:0
SET H=$ORDER(@NA@("F",H))
SET DIGTYPE="S"
IF 'H
QUIT
IF $PIECE(^(H),U,4)'["D"
Begin DoDot:2
+5 SET Y=""
SET L=0
FOR I=0:0
SET Y=$ORDER(@NA@(1,Y))
IF Y=""
QUIT
IF $DATA(^(Y,H,DIGTYPE))
IF $LENGTH(^(DIGTYPE))>L
SET L=$LENGTH(^(DIGTYPE))
IF $LENGTH($$E(Y,1))>I
SET I=$LENGTH($$E(Y,1))
+6 IF 'I!'L
QUIT
+7 DO TOP
WRITE !!?4,$PIECE(DIGC(1),U,3),!
+8 SET Y=""
SET %T=0
+9 FOR
SET Y=$ORDER(@NA@(1,Y))
IF Y=""
QUIT
IF $DATA(^(Y,H,DIGTYPE))
Begin DoDot:3
+10 IF $Y+2>IOSL
DO EOP
IF $DATA(DUOUT)
QUIT
DO TOP
+11 WRITE !?4,$$E(Y,1),?I+7
SET X=@NA@(1,Y,H,DIGTYPE)
WRITE $JUSTIFY(X,L)
SET %T=%T+X
End DoDot:3
IF $DATA(DUOUT)
QUIT
+12 WRITE !!?4,"TOTAL",?I+7,$JUSTIFY(%T,L)
DO EOP
End DoDot:2
SET DIGTYPE="N"
Begin DoDot:2
End DoDot:2
IF $DATA(DUOUT)
QUIT
End DoDot:1
IF $DATA(DUOUT)
GOTO Q
GOTO END
+13 SET DIGB=$NAME(@NA@(2))
IF $DATA(@DIGB)>9
DO ALL2
GOTO END
+14 SET DIG3=""
FOR
SET DIG3=$ORDER(@NA@(3,DIG3))
IF DIG3=""!$DATA(DUOUT)
GOTO END
SET DIGB=$NAME(@NA@(3,DIG3))
DO ALL2
+15 ;
ALL2 FOR RUN=0:0
SET RUN=$ORDER(@NA@("F",RUN))
IF 'RUN
QUIT
FOR DIGTYPE="S","N"
IF $PIECE(@NA@("F",RUN),U,4)'["D"!(DIGTYPE="N")
DO RUN(RUN,DIGTYPE)
+1 QUIT
+2 ;
RUN(H,DIGTYPE) NEW %H,%Y,%D,T,C,X,Y,DX,DY,DXS,DYS,DXSC,DYSC
+1 SET Y=""
SET I=0
SET C=0
SET L=0
+2 FOR
SET Y=$ORDER(@DIGB@(Y))
SET X=""
IF Y=""
QUIT
SET DY=$$E(Y,2)
IF $LENGTH(DY)>I
SET I=$LENGTH(DY)
Begin DoDot:1
+3 FOR
SET X=$ORDER(@DIGB@(Y,X))
IF X=""
QUIT
IF $DATA(^(X,H,DIGTYPE))
IF '$DATA(X(X))
SET C=C+1
SET DX=$$E(X,1)
IF $LENGTH(DX)>L
SET L=$LENGTH(DX)
SET X(X)=""
End DoDot:1
+4 ;I=width of left column
+5 ;L=width of data columns
+6 ;C=number of data columns
+7 IF 'C
QUIT
+8 SET Y=L+2*C+I+13
+9 IF Y>IOM
USE IO(0)
WRITE !,"MARGIN WIDTH OF ",IOM," IS TOO SMALL FOR DISPLAY",!,"USE WIDTH OF AT LEAST ",Y
QUIT
+10 ;make columns wide
SET I=I+3
SET L=IOM-13-I\C
+11 DO TOP
DO SUBTOP
+12 SET Y=""
+13 FOR
SET Y=$ORDER(@DIGB@(Y))
IF Y=""
QUIT
Begin DoDot:1
+14 IF $Y+2>IOSL
Begin DoDot:2
+15 NEW X
DO EOP
End DoDot:2
IF $DATA(DUOUT)
QUIT
DO TOP
DO SUBTOP
+16 NEW T
SET X=""
WRITE !!?4,$$E(Y,2),?I+6
+17 FOR N=0:1
SET X=$ORDER(X(X))
IF X=""
QUIT
SET %T=$GET(@DIGB@(Y,X,H,DIGTYPE))
WRITE $JUSTIFY(+%T,L)
SET T=$GET(T)+%T
SET DX(X)=$GET(DX(X))+%T
+18 WRITE $JUSTIFY(T,7)
End DoDot:1
IF $DATA(DUOUT)
GOTO Q
+19 SET X=" ----------------------------------------------------"
+20 WRITE !!?I+6
FOR N=1:1:N
WRITE $EXTRACT(X,1,L)
+21 WRITE $EXTRACT(X,1,IOM-$X)
+22 WRITE !!," TOTALS",?I+6
SET (%T,X)=""
FOR N=0:1
SET X=$ORDER(X(X))
IF X=""
QUIT
WRITE $JUSTIFY(DX(X),L)
SET %T=%T+DX(X)
+23 WRITE $JUSTIFY(%T,7)
EOP ;
+1 IF $GET(IOST)?1"C".E
Begin DoDot:1
+2 NEW DIR,X,Y
+3 SET DIR(0)="E"
DO ^DIR
End DoDot:1
+4 QUIT
+5 ;
TOP NEW X,Y
+1 USE IO
IF $Y
WRITE @IOF
+2 SET X=@NA@("F",H)
+3 WRITE !," ",$ORDER(^DD(+X,0,"NM",0))," FILE: "
+4 WRITE $SELECT(DIGTYPE="N":"COUNTS",1:"SUMS")
+5 IF $PIECE(X,U,2)'=.01
WRITE " OF '",$PIECE(X,U,3),"'"
+6 SET Y=DT
XECUTE ^DD("DD")
+7 IF $GET(DIGPG)
SET Y=Y_" Page "_DIGPG
SET DIGPG=DIGPG+1
+8 WRITE ?IOM-$LENGTH(Y)-1,Y
QUIT
+9 ;
SUBTOP NEW Y
+1 IF $DATA(DIG3)
WRITE !!?4,$PIECE(DIGC(3),U,3),": ",$$E(DIG3,3),!
+2 SET Y=$PIECE(DIGC(2),U,3)
FOR X=1:1:$LENGTH(Y," ")
WRITE !?4,$PIECE(Y," ",X)
+3 SET Y=$PIECE(DIGC(1),U,3)
WRITE ?(IOM-I-$LENGTH(Y)\2+I+4),Y,!!
+4 WRITE ?I+6
SET X=""
FOR
SET X=$ORDER(X(X))
IF X=""
QUIT
WRITE $JUSTIFY($$E(X,1),L)
+5 WRITE " TOTAL"
+6 WRITE !
FOR Y=1:1:IOM
WRITE "-"
+7 QUIT
+8 ;
DIGC NEW X,C
+1 SET (X,C)=""
FOR
SET X=$ORDER(@NA@("BY",X),-1)
IF 'X
QUIT
Begin DoDot:1
+2 SET C=C+1
SET DIGC(C)=^(X)
+3 SET DIGC(C,0)=$SELECT($DATA(^DD(+DIGC(C),+$PIECE(DIGC(C),U,2),0)):$PIECE(^(0),U,2),1:$PIECE(DIGC(C),U,7))
End DoDot:1
+4 QUIT
+5 ;
E(VALUE,XY) ;2=Y,1=X
+1 NEW %DT,Y
+2 IF $PIECE(DIGC(XY),U,4)["-"
SET VALUE=-VALUE
+3 IF DIGC(XY,0)["O"
QUIT VALUE
+4 IF VALUE
IF DIGC(XY,0)["D"
SET Y=VALUE
DO DD^%DT
QUIT Y
+5 IF DIGC(XY,0)["S"
SET Y=$PIECE(DIGC(XY),U,2)
IF 'Y
SET Y=$PIECE($PIECE(DIGC(XY),U,4),"+""",2)
IF Y
SET Y=$$EXTERNAL^DILFD(+DIGC(XY),Y,,VALUE,"%DT(0)")
IF Y]""
QUIT Y
+6 QUIT VALUE
+7 ;
P SET L=-1
SET X=0
PP IF L<X
WRITE "+"
SET L=L+T
+1 IF '$TEST
WRITE "-"
+2 SET X=X+1
IF X'>DXS
GOTO PP
QUIT
+3 ;
+4 ;
QUE ;
+1 SET ZTSAVE("^DOSV(0,$I,")=""
+2 SET ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL
SET ZTRTN="DQ^DIG"
+3 DO ^%ZTLOAD
KILL ZTSK
GOTO END
