- DIO3 ;SFISC/GFT - TTLS, SUBTTLS ;22JUN2016
- ;;22.2;VA FileMan;**3**;Jan 05, 2016;Build 17
- ;;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.
- ;GFT;**2,999,1005,1047,1055**;
- ;
- SUB ;
- N TYPE,V ;**CCO/NI This whole subroutine re-written for 'TOTAL', 'SUBTOTAL', 'COUNT', SUBCOUNT', ETC.
- I '$D(DNP) W:$X !
- I 'A F X=1:1:$G(DIONOSUB) W !
- K X
- I $D(^UTILITY($J,"SV",A+1)) F Y="S","N","Q","H","L" S C=Y_"(V)" F V=0:0 S V=$O(@C) Q:V="" I $D(^UTILITY($J,"SV",A+1,V,Y)) S @C=^(Y),^(Y)=$S(Y="H":-99999999,Y="L":99999999,1:0)
- S %X="" F S %X=$O(^UTILITY($J,"T",%X)) Q:%X="" D
- .S Z=^(%X),V=$P(Z,U,2) Q:$D(V(V))
- .S V(V)="",TYPE=$P(Z,U,4)
- U .F I=1:1:6 S DE=$P($T(@I),";",4),Y=DE_"(V)" I $D(@Y)#2 S Y=@Y,C=$P(Z,U,5) D @I
- .I '$D(DNP),$D(X)>9 W ?%X F I=1:1:Z W "-"
- S Z=A I $D(A(A)) F DE="S","N" S I=DE_"(V)" F V=0:0 S V=$O(@I) Q:V="" S Y=@I I '$D(DNP)!Y S:'$D(V(V)) ^(DE)=$G(^UTILITY($J,"SV",A,V,DE))+Y S @I=0,Z=0 X A(A)
- S X=-1 G K:$D(X)<9!Z F I=0:0 S I=$O(X(I)),X=X+1 Q:I=""
- I X+$Y>IOSL X ^UTILITY($J,1)
- EGP F I=0:0 S I=$O(X(I)) Q:I="" W:$X ! D
- .N TITLE
- .S TITLE=$$EZBLD^DIALOG($P($T(@I),";",6))
- .I A>0 S TITLE=$$EZBLD^DIALOG(7098,TITLE)
- .W:'$G(DIONOSUB) TITLE," " S X="" F S X=$O(X(I,X)) Q:X="" W ?X,X(I,X)
- W !
- K K Z,X,V,C Q
- ;
- 1 ;;TOTAL;S;;7090
- I $P(Z,U,6)]"" X $P(Z,U,6,99) S S(V)=Y
- S ^(DE)=$S($S(A:$D(^UTILITY($J,"SV",A,V,DE)),1:$D(^DOSV(0,IO(0),0,V,DE))):^(DE),1:0)+Y
- Q:TYPE["D" Q:TYPE["F"&(Y=0) ;TOTALS FOR DATES AND (USUALLY) FREE-TEXT DON'T MAKE SENSE
- O I C]""!$P(Z,U,3) D ;Q
- .N F,OUTRANSF
- .S F=$G(^DOSV(0,IO(0),"F",I))
- .S OUTRANSF="Q"
- .I $P($G(^DD(+F,+$P(F,U,2),0)),U,2)["O" S OUTRANSF=$G(^(2))
- .X OUTRANSF
- .S @("Y=$J(Y,+Z"_C_")")
- S X(I,%X)=Y
- Q
- 2 ;;COUNT;N;;7089
- S ^(DE)=$S($S(A:$D(^UTILITY($J,"SV",A,V,DE)),1:$D(^DOSV(0,IO(0),0,V,DE))):^(DE),1:0)+Y
- S C=$P(",0",U,C]"") G O
- 3 ;;MEAN;N;;7088
- Q:TYPE["D"!'Y!$L($P(Z,U,6))!'$D(S(V)) Q:TYPE["F"!A&(S(V)=0) S Y=$J(S(V)/Y,0,2) G O
- 4 ;;MINIMUM;L;;7087
- S ^(DE)=$S('$D(^(DE)):Y,^(DE)>Y:Y,1:^(DE)),L(V)=99999999 G M
- 5 ;;MAXIMUM;H;;7086
- S ^(DE)=$S('$D(^(DE)):Y,^(DE)<Y:Y,1:^(DE)),H(V)=-99999999
- M Q:Y[9999999!(N(V)<2) D D:TYPE["D" G O
- 6 ;;DEV.;Q;;7085
- Q:TYPE["D" S ^(DE)=$G(^(DE))+Y,Q(V)=0 Q:N(V)<2 S DE=Y-((S(V)*S(V))/N(V))/(N(V)-1),Y=1+DE/2 Q:DE'>0
- L S %=Y,Y=DE/%+%/2 G L:Y<%,O
- ;
- DT D D:Y W Y Q
- D X ^DD("DD") Q ;**CCO/NI DATE FORMAT
- N W !
- T Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIO3 2593 printed Mar 13, 2025@21:57:19 Page 2
- DIO3 ;SFISC/GFT - TTLS, SUBTTLS ;22JUN2016
- +1 ;;22.2;VA FileMan;**3**;Jan 05, 2016;Build 17
- +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 ;GFT;**2,999,1005,1047,1055**;
- +7 ;
- SUB ;
- +1 ;**CCO/NI This whole subroutine re-written for 'TOTAL', 'SUBTOTAL', 'COUNT', SUBCOUNT', ETC.
- NEW TYPE,V
- +2 IF '$DATA(DNP)
- if $X
- WRITE !
- +3 IF 'A
- FOR X=1:1:$GET(DIONOSUB)
- WRITE !
- +4 KILL X
- +5 IF $DATA(^UTILITY($JOB,"SV",A+1))
- FOR Y="S","N","Q","H","L"
- SET C=Y_"(V)"
- FOR V=0:0
- SET V=$ORDER(@C)
- if V=""
- QUIT
- IF $DATA(^UTILITY($JOB,"SV",A+1,V,Y))
- SET @C=^(Y)
- SET ^(Y)=$SELECT(Y="H":-99999999,Y="L":99999999,1:0)
- +6 SET %X=""
- FOR
- SET %X=$ORDER(^UTILITY($JOB,"T",%X))
- if %X=""
- QUIT
- Begin DoDot:1
- +7 SET Z=^(%X)
- SET V=$PIECE(Z,U,2)
- if $DATA(V(V))
- QUIT
- +8 SET V(V)=""
- SET TYPE=$PIECE(Z,U,4)
- U FOR I=1:1:6
- SET DE=$PIECE($TEXT(@I),";",4)
- SET Y=DE_"(V)"
- IF $DATA(@Y)#2
- SET Y=@Y
- SET C=$PIECE(Z,U,5)
- DO @I
- +1 IF '$DATA(DNP)
- IF $DATA(X)>9
- WRITE ?%X
- FOR I=1:1:Z
- WRITE "-"
- End DoDot:1
- +2 SET Z=A
- IF $DATA(A(A))
- FOR DE="S","N"
- SET I=DE_"(V)"
- FOR V=0:0
- SET V=$ORDER(@I)
- if V=""
- QUIT
- SET Y=@I
- IF '$DATA(DNP)!Y
- if '$DATA(V(V))
- SET ^(DE)=$GET(^UTILITY($JOB,"SV",A,V,DE))+Y
- SET @I=0
- SET Z=0
- XECUTE A(A)
- +3 SET X=-1
- if $DATA(X)<9!Z
- GOTO K
- FOR I=0:0
- SET I=$ORDER(X(I))
- SET X=X+1
- if I=""
- QUIT
- +4 IF X+$Y>IOSL
- XECUTE ^UTILITY($JOB,1)
- EGP FOR I=0:0
- SET I=$ORDER(X(I))
- if I=""
- QUIT
- if $X
- WRITE !
- Begin DoDot:1
- +1 NEW TITLE
- +2 SET TITLE=$$EZBLD^DIALOG($PIECE($TEXT(@I),";",6))
- +3 IF A>0
- SET TITLE=$$EZBLD^DIALOG(7098,TITLE)
- +4 if '$GET(DIONOSUB)
- WRITE TITLE," "
- SET X=""
- FOR
- SET X=$ORDER(X(I,X))
- if X=""
- QUIT
- WRITE ?X,X(I,X)
- End DoDot:1
- +5 WRITE !
- K KILL Z,X,V,C
- QUIT
- +1 ;
- 1 ;;TOTAL;S;;7090
- +1 IF $PIECE(Z,U,6)]""
- XECUTE $PIECE(Z,U,6,99)
- SET S(V)=Y
- +2 SET ^(DE)=$SELECT($SELECT(A:$DATA(^UTILITY($JOB,"SV",A,V,DE)),1:$DATA(^DOSV(0,IO(0),0,V,DE))):^(DE),1:0)+Y
- +3 ;TOTALS FOR DATES AND (USUALLY) FREE-TEXT DON'T MAKE SENSE
- if TYPE["D"
- QUIT
- if TYPE["F"&(Y=0)
- QUIT
- O ;Q
- IF C]""!$PIECE(Z,U,3)
- Begin DoDot:1
- +1 NEW F,OUTRANSF
- +2 SET F=$GET(^DOSV(0,IO(0),"F",I))
- +3 SET OUTRANSF="Q"
- +4 IF $PIECE($GET(^DD(+F,+$PIECE(F,U,2),0)),U,2)["O"
- SET OUTRANSF=$GET(^(2))
- +5 XECUTE OUTRANSF
- +6 SET @("Y=$J(Y,+Z"_C_")")
- End DoDot:1
- +7 SET X(I,%X)=Y
- +8 QUIT
- 2 ;;COUNT;N;;7089
- +1 SET ^(DE)=$SELECT($SELECT(A:$DATA(^UTILITY($JOB,"SV",A,V,DE)),1:$DATA(^DOSV(0,IO(0),0,V,DE))):^(DE),1:0)+Y
- +2 SET C=$PIECE(",0",U,C]"")
- GOTO O
- 3 ;;MEAN;N;;7088
- +1 if TYPE["D"!'Y!$LENGTH($PIECE(Z,U,6))!'$DATA(S(V))
- QUIT
- if TYPE["F"!A&(S(V)=0)
- QUIT
- SET Y=$JUSTIFY(S(V)/Y,0,2)
- GOTO O
- 4 ;;MINIMUM;L;;7087
- +1 SET ^(DE)=$SELECT('$DATA(^(DE)):Y,^(DE)>Y:Y,1:^(DE))
- SET L(V)=99999999
- GOTO M
- 5 ;;MAXIMUM;H;;7086
- +1 SET ^(DE)=$SELECT('$DATA(^(DE)):Y,^(DE)<Y:Y,1:^(DE))
- SET H(V)=-99999999
- M if Y[9999999!(N(V)<2)
- QUIT
- if TYPE["D"
- DO D
- GOTO O
- 6 ;;DEV.;Q;;7085
- +1 if TYPE["D"
- QUIT
- SET ^(DE)=$GET(^(DE))+Y
- SET Q(V)=0
- if N(V)<2
- QUIT
- SET DE=Y-((S(V)*S(V))/N(V))/(N(V)-1)
- SET Y=1+DE/2
- if DE'>0
- QUIT
- L SET %=Y
- SET Y=DE/%+%/2
- if Y<%
- GOTO L
- GOTO O
- +1 ;
- DT if Y
- DO D
- WRITE Y
- QUIT
- D ;**CCO/NI DATE FORMAT
- XECUTE ^DD("DD")
- QUIT
- N WRITE !
- T QUIT
