DIO3 ;SFISC/GFT-TTLS, SUBTTLS ;09:49 AM 27 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.
SUB ;
N TYPE,V
W:'$D(DNP)&$X ! 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)
F I=0:0 S I=$O(X(I)),X=-1 Q:I="" W:$X ! W $P("SUB",U,A>0),$P($T(@I),";",3)," " F %=0:0 S X=$O(X(I,X)) Q:X="" W ?X,X(I,X)
W !
K K Z,X,V,C Q
;
1 ;;TOTAL;S
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)
O I C]""!$P(Z,U,3) S @("Y=$J(Y,+Z"_C_")")
S X(I,%X)=Y Q
2 ;;COUNT;N
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
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
S ^(DE)=$S('$D(^(DE)):Y,^(DE)>Y:Y,1:^(DE)),L(V)=99999999 G M
5 ;;MAXIMUM;H
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
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 S Y=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" "_$S(Y#100:$J(Y#100\1,2)_",",1:"")_(Y\10000+1700)_$S(Y#1:" "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),1:"")
Q
N W !
T Q
DIO3 ;SFISC/GFT-TTLS, SUBTTLS ;09:49 AM 27 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.
SUB ;
+1 NEW TYPE,V
+2 IF '$DATA(DNP)&$X
WRITE !
KILL X
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)
+3 SET %X=""
FOR
SET %X=$ORDER(^UTILITY($JOB,"T",%X))
IF %X=""
QUIT
Begin DoDot:1
+4 SET Z=^(%X)
SET V=$PIECE(Z,U,2)
IF $DATA(V(V))
QUIT
+5 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)
+5 FOR I=0:0
SET I=$ORDER(X(I))
SET X=-1
IF I=""
QUIT
IF $X
WRITE !
WRITE $PIECE("SUB",U,A>0),$PIECE($TEXT(@I),";",3)," "
FOR %=0:0
SET X=$ORDER(X(I,X))
IF X=""
QUIT
WRITE ?X,X(I,X)
+6 WRITE !
K KILL Z,X,V,C
QUIT
+1 ;
1 ;;TOTAL;S
+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 IF TYPE["D"
QUIT
IF TYPE["F"&(Y=0)
QUIT
O IF C]""!$PIECE(Z,U,3)
SET @("Y=$J(Y,+Z"_C_")")
+1 SET X(I,%X)=Y
QUIT
2 ;;COUNT;N
+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
+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
+1 SET ^(DE)=$SELECT('$DATA(^(DE)):Y,^(DE)>Y:Y,1:^(DE))
SET L(V)=99999999
GOTO M
5 ;;MAXIMUM;H
+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
+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 SET Y=$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$EXTRACT(Y,4,5))_" "_$SELECT(Y#100:$JUSTIFY(Y#100\1,2)_",",1:"")_(Y\10000+1700)_$SELECT(Y#1:" "_$EXTRACT(Y_0,9,10)_":"_$EXTRACT(Y_"000",11,12),1:"")
+1 QUIT
N WRITE !
T QUIT
