DIL1 ;SFISC/GFT-STATS, NUMBER FIELD, ON-THE-FLY ;24JAN2013
;;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.
;
I $A(W)=34 D Q
.N A9
.S Y="" F A9=0:0 S Y=Y_""""_$P(W,"""",2)_"""",W=$P(W,"""",3,99) Q:$A(W)'=34&($A(W)'=95) S:$A(W)=95 Y=Y_$C(95),W=$P(W,"_",2,99)
.S Y=" W "_Y,DLN=0,X="",DRJ=0 D DE^DIL,W^DILL:W[";" I W[";W" D WR Q
.S %=$L(Y)-5 S:'DLN DLN=% S:DRJ Y=" W ?"_(DG+DLN-%)_Y D DN^DIL0,T^DIL
NUMB S:DN<0 O=999 S X="",DRJ=0 I W?1"0".E D D T^DIL Q
.K DPQ(DP,0)
.S Y="D"_(DIL-DIL0),X=$$LABEL^DIALOGZ(DP,.001)_U_$P($G(^DD(DP,.001,0)),U,2,99) S:X?.P X=$$EZBLD^DIALOG(7099)_"^^^^$L(X)>12" ;**CCO/NI
.I $D(DCL(DP_U_0)) D DE^DIL,STATS Q
.D EN^DILL(DP,.001,1),DE^DIL,DN^DIL0
S DN=$E(W,$L(W)),X=$P(W,";") K DLN I DM,$A(X)=94 S W=F_W G UP^DIL
COMP D D T^DIL Q
.N V,DILDATE,DILCUT
.S DILCUT=0
.I W[";d" S DILDATE="D"
.I X?.E1" W X K Y" S DILCUT=8
.I X?.E1" W X K DIP" S DILCUT=10
.I X?.E1" D DT K DIP" S DILCUT=11,DILDATE="D"
.I X?.E1" D DT K Y" S DILCUT=9,DILDATE="D"
.S X=$E(X,1,$L(X)-DILCUT)_" K DIP K:DN Y"
DITTO .I W[";N" S DCL=DCL+1,X=X_" S X=$$DITTO^DIO2("_DCL_",X)",DITTO(DCL)=""
.S Y=" "_X,X="^^^^"_X,%=DN,DN=-3
.I W[";m" D W D Q
..S X="D "_$E("L",W'[";w"&(W'[";W"))_"^DIWP",V=$F(Y,"D ^DIWP")
..I V S Y=$E(Y,1,V-8)_X_$E(Y,V,999)
..E S Y=" S DICMX="""_X_""""_Y
.I DILCUT S V=$G(DILDATE) D CLC^DILL
.I 'DILCUT D W^DILL
.S:'$D(DLN) DLN=9
.I W[";W" D W S Y=Y_" D ^DIWP" Q
.I "+#&!*"'[% D DE^DIL,DN^DIL0 Q
.S X="^C"_$G(DILDATE)_"^^^"_$E(Y,2,999),W=-1_";"_$P(W,";",2,9),DCL(DP_U_-1)=%
.D DE^DIL,STATS
;
W D DE^DIL,WR^DIL0 S Y=Y_" "_$E(X,5,999) Q
;
WR S D1=" S Y="_$P(Y,"W ",2,999),Y="" D W^DIL0
F D1=D1," S X=Y D ^DIWP" S:$L(Y)+$L(D1)'>250 Y=Y_D1 I $F(Y,D1)-1'=$L(Y) D PX^DIL S Y=D1
D T^DIL Q
;
STATS ;
N TYPE
I DG<10!(DG>900),'$G(DIONOSUB) S DG=10 D DE^DIL I DE'["!" S DE=" W:$X>8 !"_DE ;LEAVE FIRST 8 CHARS ON OUTPUT LINE FOR "SUBTOTAL"
S TYPE=$P(X,U,2),V=DP_U_+W,I=DCL(V),D=+I I D S DSUM="" G E
S (D,DCL)=DCL+1,DCL(V)=D_I
S DXS=$S(I["*":"C",I["#":"S",I["&":"A",I["+":"P",1:1),V=TYPE,%=":Y"_$S(TYPE["C":"'?.""*""",Y["$E":"'?."" """,1:"]""""")
I DXS S DSUM=" S"_%_" N("_D_")=N("_D_")+1",N(D)=0 G E
G @DXS
;
C S CP(D)=""
S S Q(D)=0,L(D)=9999999999,H(D)=-L(D) I $P(TYPE,"I",2) S DLN=+$P(TYPE,"I",2)
P S N(D)=0
A S (S(D),DRJ)=0
S DSUM=",C="_D_" D "_DXS_%
E I TYPE["C" D
.D EN^DILL(DP,+W) S Y=Y_" S Y=X"_DSUM,DXS=$S($D(^DD(DP,+W,9.02)):^(9.02),1:0)
E S DXS=DSUM,Y=" S Y="_Y_DXS,I="",DXS="Y" D EN^DILL(DP,+W)
UTIL K DSUM S ^UTILITY($J,"T",DG)=DLN_U_D_U_DRJ_U_$P(X,U,2)_U_I
D D DN^DIL0 Q
.I DXS?1E Q
.S ^(DG)=^UTILITY($J,"T",DG)_U_DXS,DN=^DD(DP,+W,9.01)
.I '$D(DNP) S V=$L(Y)+$L(DE) S:V<250 Y=DE_Y I V>249 S V=Y,Y=DE D PX^DIL S Y=V
.S DE=X,V=DLN N X,DLN,DNP S X=DE,DLN=V,DNP="" ;'Do Not Print' hidden fields
LOOP .F S DE="",V=$P(DN,";"),W=$P(V,U,2),DN=$P(DN,";",2,99) Q:V="" D:'$D(DCL(V))
..D PX^DIL,XDUY^DIL0,EN^DILL(DP,W,1)
..I $P(X,U,2)'["C" S Y=",X=$G("_DI_C_DU_"))"_$P(",Y=",U,Y'[" S Y=")_Y
..E S Y=Y_" S Y=X"
..S (D,DCL)=DCL+1,S(D)=0,DCL(DP_U_+W)=D,Y=" S C="_D_Y_" D A"
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIL1 3360 printed Oct 16, 2024@18:49:50 Page 2
DIL1 ;SFISC/GFT-STATS, NUMBER FIELD, ON-THE-FLY ;24JAN2013
+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 IF $ASCII(W)=34
Begin DoDot:1
+8 NEW A9
+9 SET Y=""
FOR A9=0:0
SET Y=Y_""""_$PIECE(W,"""",2)_""""
SET W=$PIECE(W,"""",3,99)
if $ASCII(W)'=34&($ASCII(W)'=95)
QUIT
if $ASCII(W)=95
SET Y=Y_$CHAR(95)
SET W=$PIECE(W,"_",2,99)
+10 SET Y=" W "_Y
SET DLN=0
SET X=""
SET DRJ=0
DO DE^DIL
if W[";"
DO W^DILL
IF W[";W"
DO WR
QUIT
+11 SET %=$LENGTH(Y)-5
if 'DLN
SET DLN=%
if DRJ
SET Y=" W ?"_(DG+DLN-%)_Y
DO DN^DIL0
DO T^DIL
End DoDot:1
QUIT
NUMB if DN<0
SET O=999
SET X=""
SET DRJ=0
IF W?1"0".E
Begin DoDot:1
+1 KILL DPQ(DP,0)
+2 ;**CCO/NI
SET Y="D"_(DIL-DIL0)
SET X=$$LABEL^DIALOGZ(DP,.001)_U_$PIECE($GET(^DD(DP,.001,0)),U,2,99)
if X?.P
SET X=$$EZBLD^DIALOG(7099)_"^^^^$L(X)>12"
+3 IF $DATA(DCL(DP_U_0))
DO DE^DIL
DO STATS
QUIT
+4 DO EN^DILL(DP,.001,1)
DO DE^DIL
DO DN^DIL0
End DoDot:1
DO T^DIL
QUIT
+5 SET DN=$EXTRACT(W,$LENGTH(W))
SET X=$PIECE(W,";")
KILL DLN
IF DM
IF $ASCII(X)=94
SET W=F_W
GOTO UP^DIL
COMP Begin DoDot:1
+1 NEW V,DILDATE,DILCUT
+2 SET DILCUT=0
+3 IF W[";d"
SET DILDATE="D"
+4 IF X?.E1" W X K Y"
SET DILCUT=8
+5 IF X?.E1" W X K DIP"
SET DILCUT=10
+6 IF X?.E1" D DT K DIP"
SET DILCUT=11
SET DILDATE="D"
+7 IF X?.E1" D DT K Y"
SET DILCUT=9
SET DILDATE="D"
+8 SET X=$EXTRACT(X,1,$LENGTH(X)-DILCUT)_" K DIP K:DN Y"
DITTO IF W[";N"
SET DCL=DCL+1
SET X=X_" S X=$$DITTO^DIO2("_DCL_",X)"
SET DITTO(DCL)=""
+1 SET Y=" "_X
SET X="^^^^"_X
SET %=DN
SET DN=-3
+2 IF W[";m"
DO W
Begin DoDot:2
+3 SET X="D "_$EXTRACT("L",W'[";w"&(W'[";W"))_"^DIWP"
SET V=$FIND(Y,"D ^DIWP")
+4 IF V
SET Y=$EXTRACT(Y,1,V-8)_X_$EXTRACT(Y,V,999)
+5 IF '$TEST
SET Y=" S DICMX="""_X_""""_Y
End DoDot:2
QUIT
+6 IF DILCUT
SET V=$GET(DILDATE)
DO CLC^DILL
+7 IF 'DILCUT
DO W^DILL
+8 if '$DATA(DLN)
SET DLN=9
+9 IF W[";W"
DO W
SET Y=Y_" D ^DIWP"
QUIT
+10 IF "+#&!*"'[%
DO DE^DIL
DO DN^DIL0
QUIT
+11 SET X="^C"_$GET(DILDATE)_"^^^"_$EXTRACT(Y,2,999)
SET W=-1_";"_$PIECE(W,";",2,9)
SET DCL(DP_U_-1)=%
+12 DO DE^DIL
DO STATS
End DoDot:1
DO T^DIL
QUIT
+13 ;
W DO DE^DIL
DO WR^DIL0
SET Y=Y_" "_$EXTRACT(X,5,999)
QUIT
+1 ;
WR SET D1=" S Y="_$PIECE(Y,"W ",2,999)
SET Y=""
DO W^DIL0
+1 FOR D1=D1," S X=Y D ^DIWP"
if $LENGTH(Y)+$LENGTH(D1)'>250
SET Y=Y_D1
IF $FIND(Y,D1)-1'=$LENGTH(Y)
DO PX^DIL
SET Y=D1
+2 DO T^DIL
QUIT
+3 ;
STATS ;
+1 NEW TYPE
+2 ;LEAVE FIRST 8 CHARS ON OUTPUT LINE FOR "SUBTOTAL"
IF DG<10!(DG>900)
IF '$GET(DIONOSUB)
SET DG=10
DO DE^DIL
IF DE'["!"
SET DE=" W:$X>8 !"_DE
+3 SET TYPE=$PIECE(X,U,2)
SET V=DP_U_+W
SET I=DCL(V)
SET D=+I
IF D
SET DSUM=""
GOTO E
+4 SET (D,DCL)=DCL+1
SET DCL(V)=D_I
+5 SET DXS=$SELECT(I["*":"C",I["#":"S",I["&":"A",I["+":"P",1:1)
SET V=TYPE
SET %=":Y"_$SELECT(TYPE["C":"'?.""*""",Y["$E":"'?."" """,1:"]""""")
+6 IF DXS
SET DSUM=" S"_%_" N("_D_")=N("_D_")+1"
SET N(D)=0
GOTO E
+7 GOTO @DXS
+8 ;
C SET CP(D)=""
S SET Q(D)=0
SET L(D)=9999999999
SET H(D)=-L(D)
IF $PIECE(TYPE,"I",2)
SET DLN=+$PIECE(TYPE,"I",2)
P SET N(D)=0
A SET (S(D),DRJ)=0
+1 SET DSUM=",C="_D_" D "_DXS_%
E IF TYPE["C"
Begin DoDot:1
+1 DO EN^DILL(DP,+W)
SET Y=Y_" S Y=X"_DSUM
SET DXS=$SELECT($DATA(^DD(DP,+W,9.02)):^(9.02),1:0)
End DoDot:1
+2 IF '$TEST
SET DXS=DSUM
SET Y=" S Y="_Y_DXS
SET I=""
SET DXS="Y"
DO EN^DILL(DP,+W)
UTIL KILL DSUM
SET ^UTILITY($JOB,"T",DG)=DLN_U_D_U_DRJ_U_$PIECE(X,U,2)_U_I
+1 Begin DoDot:1
+2 IF DXS?1E
QUIT
+3 SET ^(DG)=^UTILITY($JOB,"T",DG)_U_DXS
SET DN=^DD(DP,+W,9.01)
+4 IF '$DATA(DNP)
SET V=$LENGTH(Y)+$LENGTH(DE)
if V<250
SET Y=DE_Y
IF V>249
SET V=Y
SET Y=DE
DO PX^DIL
SET Y=V
+5 ;'Do Not Print' hidden fields
SET DE=X
SET V=DLN
NEW X,DLN,DNP
SET X=DE
SET DLN=V
SET DNP=""
LOOP FOR
SET DE=""
SET V=$PIECE(DN,";")
SET W=$PIECE(V,U,2)
SET DN=$PIECE(DN,";",2,99)
if V=""
QUIT
if '$DATA(DCL(V))
Begin DoDot:2
+1 DO PX^DIL
DO XDUY^DIL0
DO EN^DILL(DP,W,1)
+2 IF $PIECE(X,U,2)'["C"
SET Y=",X=$G("_DI_C_DU_"))"_$PIECE(",Y=",U,Y'[" S Y=")_Y
+3 IF '$TEST
SET Y=Y_" S Y=X"
+4 SET (D,DCL)=DCL+1
SET S(D)=0
SET DCL(DP_U_+W)=D
SET Y=" S C="_D_Y_" D A"
End DoDot:2
End DoDot:1
DO DN^DIL0
QUIT
