- 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
