DIG ;SFISC/GFT SUBTOTALS & SCATTERGRAM ;31MAY2012
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
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(H)
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,DELIM) ;CROSS-TABS
N DIGC,DIGB,DIGPG,DIGCOL,DIGSUB,RUN,DIGTYPE,DIG3,I,LT,L,%T,H,DUOUT
D DIGC S DIGPG=1
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(H) W !! D TAB(4) W $$CAPT(1),!
..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(H)
...W ! D TAB(4) W $$E(Y,1) D TAB(I+7) S X=@NA@(1,Y,H,DIGTYPE) W $$J(X,L) S %T=%T+X
..W !! D TAB(4) W "TOTAL" D TAB(I+7) W $$J(%T,L) D EOP
2 S DIGB=$NA(@NA@(2)) I $D(@DIGB)>9 D ALL2 G END
3 N A,B,C,D,E,NAT ;We had 3 levels of subtotalling, so we build a NAT matrix of TOTALS
S NAT=$NA(^TMP("DIG",$J,0)) K ^TMP("DIG",$J) F A="F","HD","SHD" M ^TMP("DIG",$J,A)=@NA@(A)
S A="" F S A=$O(@NA@(3,A)),B="" Q:A="" F S B=$O(@NA@(3,A,B)),C="" Q:B="" F S C=$O(@NA@(3,A,B,C)),D="" Q:C="" F S D=$O(@NA@(3,A,B,C,D)),E="" Q:D="" F S E=$O(@NA@(3,A,B,C,D,E)) Q:E="" D
.S ^(E)=^(E)+$G(@NAT@(B,C,D,E)) ;SUM OVER ALL OF THEM
F RUN=0:0 S RUN=$O(@NA@("F",RUN)) Q:'RUN F DIGTYPE="S","N" D:$$PAR(NAT,RUN,DIGTYPE) G END:$D(DUOUT)
.F X="DIGCOL","DIGSUB","I","L","LT","C" M DIG3(RUN,DIGTYPE,X)=@X
S DIG3="" F S DIG3=$O(@NA@(3,DIG3)) Q:DIG3="" S DIGB=$NA(@NA@(3,DIG3)) D ALL2 G END:$D(DUOUT)
S NA=$NA(^TMP("DIG",$J)),DIG3="**ALL**",DIGB=NAT D ALL2 ;print grand totals
G END
;
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:$D(DUOUT) ;don't try to sum dates
Q
;
RUN(RUN,DIGTYPE) N %H,%Y,%D,T,C,X,Y,DX,DXS,DYS,DXSC,DYSC,DIGCOL
I $D(DIG3) Q:'$D(DIG3(RUN,DIGTYPE)) F X="DIGSUB","DIGCOL","C","L","LT","I" M @X=DIG3(RUN,DIGTYPE,X)
E Q:'$$PAR(DIGB,RUN,DIGTYPE) ;If 3-level, we have already set up PARameters
D TOP(RUN),SUBTOP
M @DIGB@($C(127)_"EMPTY")=@DIGB@(" EMPTY") K @DIGB@(" EMPTY")
S Y=""
F S Y=$O(@DIGB@(Y)) Q:Y="" D G Q:$D(DUOUT) ;loop writes one output line
.I $Y+2>IOSL D Q:$D(DUOUT) D TOP(RUN),SUBTOP
..D EOP
.N T S X="" W !! D TAB(1) W $$E(Y,2) D TAB(I+5) ;write row caption
.F N=0:1 S X=$O(DIGCOL(X)) Q:X="" S %T=$G(@DIGB@(Y,X,RUN,DIGTYPE)) W $$J(+%T,L) S T=$G(T)+%T,DX(X)=$G(DX(X))+%T
.W $$J(T,LT)
S X=" "_$TR($J("",IOM\2)," ","-") ;THE UNDERLINE
I '$D(DELIM) W !! D TAB(I+5) F N=N:-1 W $E(X,1,L) I N=1 W $E(X,1,LT) Q
W !! D TAB(1) W "TOTALS" D TAB(I+5) S (%T,X)="" F N=0:1 S X=$O(DIGCOL(X)) Q:X="" W $$J(DX(X),L) S %T=%T+DX(X)
W $$J(%T,LT)
EOP ;
W !! I $G(IOST)?1"C".E D
.N DIR,X,Y
.S DIR(0)="E" D ^DIR
Q
;
PAR(DIGB,RUN,DIGTYPE) ;DIGB=NAME OF ARRAY Sets up DIGCOL array, and:
;I=width of left column
;L=width of data columns
;LT=width of TOTAL column
;C=number of data columns
N Y,DY,DX,%,S
K DIGCOL,DIGSUB
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,RUN,DIGTYPE)) S:$L(^(DIGTYPE))>L L=$L(^(DIGTYPE)) D:'$D(DIGCOL(X))
..S C=C+1,DIGCOL(X)="",DX=$$E(X,1),%=0 F Q:DX="" S S=$P(DX," "),DX=$P(DX," ",2,99) I S]"" S %=%+1,DIGSUB(%,X)=S S:$L(S)>L L=$L(S)
I 'C Q 0
S X="" F S X=$O(DIGCOL(X)) Q:X="" F Y=$O(DIGSUB(""),-1):-1:2 I $G(DIGSUB(Y,X))?." " S DIGSUB(Y,X)=$G(DIGSUB(Y-1,X)) K DIGSUB(Y-1,X)
S Y=L*C+I+13
I Y>IOM,'$D(DELIM) U $P W !,"MARGIN WIDTH OF ",IOM," IS TOO SMALL FOR DISPLAY",!,"USE WIDTH OF AT LEAST ",Y H 1 S DUOUT=1 Q 0
S LT=8 F Y=Y+C+1:C+1:IOM S LT=LT+1,L=L+1
I Y+3<IOM S I=I+3
Q 1
;
TOP(H) N X,Y,DC
U IO W:$Y @IOF
S DC=$G(DIGPG) I $D(@NA@("HD")) D
.X ^("HD") W !!
E D
.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,$P(X,U,3)]"" W " OF '",$P(X,U,3),"'"
.S Y=DT X ^DD("DD")
.I $G(DIGPG) S Y=Y_" Page "_DIGPG
.W ?IOM-$L(Y)-1,Y
SHD I $D(@NA@("SHD")) W !,?IOM-$L(^("SHD"))\2,^("SHD")
S:$G(DIGPG) DIGPG=DIGPG+1
Q
;
SUBTOP N Y
I $D(DIG3) W !!?1,$$CAPT(3),": ",$$E(DIG3,3),!
S Y=$$CAPT(2) F X=1:1:$L(Y," ") W !?2,$P(Y," ",X)
S Y=$$CAPT(1) W ?(IOM-I-LT-$L(Y)\2+I+4),Y,!
F Y=1:1 Q:'$D(DIGSUB(Y)) W ! D TAB(I+5) S X="" F S X=$O(DIGCOL(X)) Q:X="" W $$J($G(DIGSUB(Y,X)),L)
;W " " D TAB(I+5) S X="" F S X=$O(DIGCOL(X)) Q:X="" W $$J($$E(X,1),L)
W $$J("TOTAL",LT)
I '$D(DELIM) W ! F Y=1:1:IOM W "-"
Q
;
CAPT(N) N F S N=DIGC(N),F=$P(N,U,5) I F[";""" Q $P(F,"""",2)
Q $P(N,U,3)
;
TAB(N) I $D(DELIM) W:$X DELIM Q
W ?N Q
;
J(VALUE,SPACE) I $D(DELIM) Q $TR(VALUE,DELIM)_DELIM
Q $J(VALUE,SPACE) 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
I XY=2,$A(VALUE)=127 S $E(VALUE)="" ;so length isn't thrown off by non-printing char
Q $TR($$EE,$G(DELIM))
;
EE() N %DT,Y
I $P(DIGC(XY),U,4)["-" S VALUE=-VALUE
I VALUE,DIGC(XY,0)["D" Q $$DATE^DIUTL(VALUE)
I DIGC(XY,0)["O" Q VALUE
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=$$SET^DIQ(+DIGC(XY),Y,VALUE) 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIG 7914 printed Dec 13, 2024@02:48:31 Page 2
DIG ;SFISC/GFT SUBTOTALS & SCATTERGRAM ;31MAY2012
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
+7 WRITE !
IF '$DATA(^DOSV(0,IO(0),2))
WRITE "NO SUB-SUB TOTALS WERE RUN"
QUIT
+8 NEW POP,IOP,ZTSK
if $DATA(^%ZTSK)
SET %ZIS="QM"
DO ^%ZIS
if POP
QUIT
+9 if $DATA(IO("Q"))
GOTO QUE
+10 ;
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(H)
+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,DELIM) ;CROSS-TABS
+1 NEW DIGC,DIGB,DIGPG,DIGCOL,DIGSUB,RUN,DIGTYPE,DIG3,I,LT,L,%T,H,DUOUT
+2 DO DIGC
SET DIGPG=1
1 IF $DATA(@NA@(1))
Begin DoDot:1
+1 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
+2 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))
+3 IF 'I!'L
QUIT
+4 DO TOP(H)
WRITE !!
DO TAB(4)
WRITE $$CAPT(1),!
+5 SET Y=""
SET %T=0
+6 FOR
SET Y=$ORDER(@NA@(1,Y))
if Y=""
QUIT
IF $DATA(^(Y,H,DIGTYPE))
Begin DoDot:3
+7 IF $Y+2>IOSL
DO EOP
if $DATA(DUOUT)
QUIT
DO TOP(H)
+8 WRITE !
DO TAB(4)
WRITE $$E(Y,1)
DO TAB(I+7)
SET X=@NA@(1,Y,H,DIGTYPE)
WRITE $$J(X,L)
SET %T=%T+X
End DoDot:3
if $DATA(DUOUT)
QUIT
+9 WRITE !!
DO TAB(4)
WRITE "TOTAL"
DO TAB(I+7)
WRITE $$J(%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
2 SET DIGB=$NAME(@NA@(2))
IF $DATA(@DIGB)>9
DO ALL2
GOTO END
3 ;We had 3 levels of subtotalling, so we build a NAT matrix of TOTALS
NEW A,B,C,D,E,NAT
+1 SET NAT=$NAME(^TMP("DIG",$JOB,0))
KILL ^TMP("DIG",$JOB)
FOR A="F","HD","SHD"
MERGE ^TMP("DIG",$JOB,A)=@NA@(A)
+2 SET A=""
FOR
SET A=$ORDER(@NA@(3,A))
SET B=""
if A=""
QUIT
FOR
SET B=$ORDER(@NA@(3,A,B))
SET C=""
if B=""
QUIT
FOR
SET C=$ORDER(@NA@(3,A,B,C))
SET D=""
if C=""
QUIT
FOR
SET D=$ORDER(@NA@(3,A,B,C,D))
SET E=""
if D=""
QUIT
FOR
SET E=$ORDER(@NA@(3,A,B,C,D,E))
if E=""
QUIT
Begin DoDot:1
+3 ;SUM OVER ALL OF THEM
SET ^(E)=^(E)+$GET(@NAT@(B,C,D,E))
End DoDot:1
+4 FOR RUN=0:0
SET RUN=$ORDER(@NA@("F",RUN))
if 'RUN
QUIT
FOR DIGTYPE="S","N"
if $$PAR(NAT,RUN,DIGTYPE)
Begin DoDot:1
+5 FOR X="DIGCOL","DIGSUB","I","L","LT","C"
MERGE DIG3(RUN,DIGTYPE,X)=@X
End DoDot:1
if $DATA(DUOUT)
GOTO END
+6 SET DIG3=""
FOR
SET DIG3=$ORDER(@NA@(3,DIG3))
if DIG3=""
QUIT
SET DIGB=$NAME(@NA@(3,DIG3))
DO ALL2
if $DATA(DUOUT)
GOTO END
+7 ;print grand totals
SET NA=$NAME(^TMP("DIG",$JOB))
SET DIG3="**ALL**"
SET DIGB=NAT
DO ALL2
+8 GOTO END
+9 ;
ALL2 ;don't try to sum dates
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)
if $DATA(DUOUT)
QUIT
+1 QUIT
+2 ;
RUN(RUN,DIGTYPE) NEW %H,%Y,%D,T,C,X,Y,DX,DXS,DYS,DXSC,DYSC,DIGCOL
+1 IF $DATA(DIG3)
if '$DATA(DIG3(RUN,DIGTYPE))
QUIT
FOR X="DIGSUB","DIGCOL","C","L","LT","I"
MERGE @X=DIG3(RUN,DIGTYPE,X)
+2 ;If 3-level, we have already set up PARameters
IF '$TEST
if '$$PAR(DIGB,RUN,DIGTYPE)
QUIT
+3 DO TOP(RUN)
DO SUBTOP
+4 MERGE @DIGB@($CHAR(127)_"EMPTY")=@DIGB@(" EMPTY")
KILL @DIGB@(" EMPTY")
+5 SET Y=""
+6 ;loop writes one output line
FOR
SET Y=$ORDER(@DIGB@(Y))
if Y=""
QUIT
Begin DoDot:1
+7 IF $Y+2>IOSL
Begin DoDot:2
+8 DO EOP
End DoDot:2
if $DATA(DUOUT)
QUIT
DO TOP(RUN)
DO SUBTOP
+9 ;write row caption
NEW T
SET X=""
WRITE !!
DO TAB(1)
WRITE $$E(Y,2)
DO TAB(I+5)
+10 FOR N=0:1
SET X=$ORDER(DIGCOL(X))
if X=""
QUIT
SET %T=$GET(@DIGB@(Y,X,RUN,DIGTYPE))
WRITE $$J(+%T,L)
SET T=$GET(T)+%T
SET DX(X)=$GET(DX(X))+%T
+11 WRITE $$J(T,LT)
End DoDot:1
if $DATA(DUOUT)
GOTO Q
+12 ;THE UNDERLINE
SET X=" "_$TRANSLATE($JUSTIFY("",IOM\2)," ","-")
+13 IF '$DATA(DELIM)
WRITE !!
DO TAB(I+5)
FOR N=N:-1
WRITE $EXTRACT(X,1,L)
IF N=1
WRITE $EXTRACT(X,1,LT)
QUIT
+14 WRITE !!
DO TAB(1)
WRITE "TOTALS"
DO TAB(I+5)
SET (%T,X)=""
FOR N=0:1
SET X=$ORDER(DIGCOL(X))
if X=""
QUIT
WRITE $$J(DX(X),L)
SET %T=%T+DX(X)
+15 WRITE $$J(%T,LT)
EOP ;
+1 WRITE !!
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 ;
PAR(DIGB,RUN,DIGTYPE) ;DIGB=NAME OF ARRAY Sets up DIGCOL array, and:
+1 ;I=width of left column
+2 ;L=width of data columns
+3 ;LT=width of TOTAL column
+4 ;C=number of data columns
+5 NEW Y,DY,DX,%,S
+6 KILL DIGCOL,DIGSUB
+7 SET Y=""
SET I=0
SET C=0
SET L=0
+8 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
+9 FOR
SET X=$ORDER(@DIGB@(Y,X))
if X=""
QUIT
IF $DATA(^(X,RUN,DIGTYPE))
if $LENGTH(^(DIGTYPE))>L
SET L=$LENGTH(^(DIGTYPE))
if '$DATA(DIGCOL(X))
Begin DoDot:2
+10 SET C=C+1
SET DIGCOL(X)=""
SET DX=$$E(X,1)
SET %=0
FOR
if DX=""
QUIT
SET S=$PIECE(DX," ")
SET DX=$PIECE(DX," ",2,99)
IF S]""
SET %=%+1
SET DIGSUB(%,X)=S
if $LENGTH(S)>L
SET L=$LENGTH(S)
End DoDot:2
End DoDot:1
+11 IF 'C
QUIT 0
+12 SET X=""
FOR
SET X=$ORDER(DIGCOL(X))
if X=""
QUIT
FOR Y=$ORDER(DIGSUB(""),-1):-1:2
IF $GET(DIGSUB(Y,X))?." "
SET DIGSUB(Y,X)=$GET(DIGSUB(Y-1,X))
KILL DIGSUB(Y-1,X)
+13 SET Y=L*C+I+13
+14 IF Y>IOM
IF '$DATA(DELIM)
USE $PRINCIPAL
WRITE !,"MARGIN WIDTH OF ",IOM," IS TOO SMALL FOR DISPLAY",!,"USE WIDTH OF AT LEAST ",Y
HANG 1
SET DUOUT=1
QUIT 0
+15 SET LT=8
FOR Y=Y+C+1:C+1:IOM
SET LT=LT+1
SET L=L+1
+16 IF Y+3<IOM
SET I=I+3
+17 QUIT 1
+18 ;
TOP(H) NEW X,Y,DC
+1 USE IO
if $Y
WRITE @IOF
+2 SET DC=$GET(DIGPG)
IF $DATA(@NA@("HD"))
Begin DoDot:1
+3 XECUTE ^("HD")
WRITE !!
End DoDot:1
+4 IF '$TEST
Begin DoDot:1
+5 SET X=@NA@("F",H)
+6 WRITE !," ",$ORDER(^DD(+X,0,"NM",0))," FILE: "
+7 WRITE $SELECT(DIGTYPE="N":"COUNTS",1:"SUMS")
+8 IF $PIECE(X,U,2)'=.01
IF $PIECE(X,U,3)]""
WRITE " OF '",$PIECE(X,U,3),"'"
+9 SET Y=DT
XECUTE ^DD("DD")
+10 IF $GET(DIGPG)
SET Y=Y_" Page "_DIGPG
+11 WRITE ?IOM-$LENGTH(Y)-1,Y
End DoDot:1
SHD IF $DATA(@NA@("SHD"))
WRITE !,?IOM-$LENGTH(^("SHD"))\2,^("SHD")
+1 if $GET(DIGPG)
SET DIGPG=DIGPG+1
+2 QUIT
+3 ;
SUBTOP NEW Y
+1 IF $DATA(DIG3)
WRITE !!?1,$$CAPT(3),": ",$$E(DIG3,3),!
+2 SET Y=$$CAPT(2)
FOR X=1:1:$LENGTH(Y," ")
WRITE !?2,$PIECE(Y," ",X)
+3 SET Y=$$CAPT(1)
WRITE ?(IOM-I-LT-$LENGTH(Y)\2+I+4),Y,!
+4 FOR Y=1:1
if '$DATA(DIGSUB(Y))
QUIT
WRITE !
DO TAB(I+5)
SET X=""
FOR
SET X=$ORDER(DIGCOL(X))
if X=""
QUIT
WRITE $$J($GET(DIGSUB(Y,X)),L)
+5 ;W " " D TAB(I+5) S X="" F S X=$O(DIGCOL(X)) Q:X="" W $$J($$E(X,1),L)
+6 WRITE $$J("TOTAL",LT)
+7 IF '$DATA(DELIM)
WRITE !
FOR Y=1:1:IOM
WRITE "-"
+8 QUIT
+9 ;
CAPT(N) NEW F
SET N=DIGC(N)
SET F=$PIECE(N,U,5)
IF F[";"""
QUIT $PIECE(F,"""",2)
+1 QUIT $PIECE(N,U,3)
+2 ;
TAB(N) IF $DATA(DELIM)
if $X
WRITE DELIM
QUIT
+1 WRITE ?N
QUIT
+2 ;
J(VALUE,SPACE) IF $DATA(DELIM)
QUIT $TRANSLATE(VALUE,DELIM)_DELIM
+1 QUIT $JUSTIFY(VALUE,SPACE)
QUIT
+2 ;
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 ;so length isn't thrown off by non-printing char
IF XY=2
IF $ASCII(VALUE)=127
SET $EXTRACT(VALUE)=""
+2 QUIT $TRANSLATE($$EE,$GET(DELIM))
+3 ;
EE() NEW %DT,Y
+1 IF $PIECE(DIGC(XY),U,4)["-"
SET VALUE=-VALUE
+2 IF VALUE
IF DIGC(XY,0)["D"
QUIT $$DATE^DIUTL(VALUE)
+3 IF DIGC(XY,0)["O"
QUIT VALUE
+4 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=$$SET^DIQ(+DIGC(XY),Y,VALUE)
QUIT Y
+5 QUIT VALUE
+6 ;
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
