DIL1.m

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 ---DIL1   3360     printed  Mar 13, 2025@21:54                                                                                                                                                                                                           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