- DIL1 ;SFISC/GFT-STATS, NUMBER FIELD, ON-THE-FLY ;04:27 PM 26 Aug 1999 [ 04/02/2003 8:25 AM ]
- ;;22.0;VA FileMan;**1001**;APR 1, 2003
- ;;22.0;VA FileMan;**2**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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=$G(^DD(DP,.001,0),"NUMBER^^^^$L(X)>12")
- .I $D(DCL(DP_U_0)) D DE^DIL,STATS Q
- .D ^DILL,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"
- .I W[";N" S DCL=DCL+1,X=X_" S Y=X,C="_DCL_" D D S X=Y",DITTO(DCL)=""
- .S Y=" "_X,X="^^^^"_X,%=DN,DN=-3
- .I W[";m" D W D Q
- ..S X="D "_$E("L",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) S DG=10 D DE^DIL I DE'["!" S DE=" W:$X>8 !"_DE
- 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 V^DILL S Y=Y_" S Y=X"_DSUM,DXS=$S($D(^DD(DP,+W,9.02)):^(9.02),1:0) G UTIL
- DILL S DXS=DSUM,Y=" S Y="_Y_DXS,I="",DXS="Y" D V^DILL
- 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,^DILL
- ..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"
- DIL1 ;SFISC/GFT-STATS, NUMBER FIELD, ON-THE-FLY ;04:27 PM 26 Aug 1999 [ 04/02/2003 8:25 AM ]
- +1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
- +2 ;;22.0;VA FileMan;**2**;Mar 30, 1999
- +3 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +4 IF $ASCII(W)=34
- Begin DoDot:1
- +5 NEW A9
- +6 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)
- +7 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
- +8 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 SET Y="D"_(DIL-DIL0)
- SET X=$GET(^DD(DP,.001,0),"NUMBER^^^^$L(X)>12")
- +3 IF $DATA(DCL(DP_U_0))
- DO DE^DIL
- DO STATS
- QUIT
- +4 DO ^DILL
- 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"
- +9 IF W[";N"
- SET DCL=DCL+1
- SET X=X_" S Y=X,C="_DCL_" D D S X=Y"
- SET DITTO(DCL)=""
- +10 SET Y=" "_X
- SET X="^^^^"_X
- SET %=DN
- SET DN=-3
- +11 IF W[";m"
- DO W
- Begin DoDot:2
- +12 SET X="D "_$EXTRACT("L",W'[";w")_"^DIWP"
- SET V=$FIND(Y,"D ^DIWP")
- +13 IF V
- SET Y=$EXTRACT(Y,1,V-8)_X_$EXTRACT(Y,V,999)
- +14 IF '$TEST
- SET Y=" S DICMX="""_X_""""_Y
- End DoDot:2
- QUIT
- +15 IF DILCUT
- SET V=$GET(DILDATE)
- DO CLC^DILL
- +16 IF 'DILCUT
- DO W^DILL
- +17 IF '$DATA(DLN)
- SET DLN=9
- +18 IF W[";W"
- DO W
- SET Y=Y_" D ^DIWP"
- QUIT
- +19 IF "+#&!*"'[%
- DO DE^DIL
- DO DN^DIL0
- QUIT
- +20 SET X="^C"_$GET(DILDATE)_"^^^"_$EXTRACT(Y,2,999)
- SET W=-1_";"_$PIECE(W,";",2,9)
- SET DCL(DP_U_-1)=%
- +21 DO DE^DIL
- DO STATS
- End DoDot:1
- DO T^DIL
- QUIT
- +22 ;
- 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 IF DG<10!(DG>900)
- 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"
- DO V^DILL
- SET Y=Y_" S Y=X"_DSUM
- SET DXS=$SELECT($DATA(^DD(DP,+W,9.02)):^(9.02),1:0)
- GOTO UTIL
- DILL SET DXS=DSUM
- SET Y=" S Y="_Y_DXS
- SET I=""
- SET DXS="Y"
- DO V^DILL
- 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 ^DILL
- +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
