- DIH ;SFISC/GFT-HISTOGRAM ;8:19 AM 28SEP2004
- ;;22.0;VA FileMan;**2,61,144**;Mar 30, 1999;Build 5
- ;Per VHA Directive 2004-038, this routine should not be modified.
- I $O(^DOSV(0,IO(0),0))'>0 W !,$C(7),"NO SUB-COUNTS WERE RUN" Q
- K ZTSK S:$D(^%ZTSK) %ZIS="QM" D ^%ZIS G ENDK:POP,QUE:$D(IO("Q"))
- DQ S J=$I,DN="=$O(^DOSV(0,J," F X=0:1 Q:'$D(^DOSV(0,J,"BY",X+1))
- G END:'X S A=^(1),DD=$P(A,U,3) I $D(^DD(+A,+$P(A,U,2),0)) S DD=^(0)
- S T=$P(DD,U,2),DP=$P(DD,U,3),DF=$S(T["S":1,T["P":2,T["D"!($P(A,U,7)["D"):3,1:0)
- S DMX=DN_X,DX="",F=X
- F S DMX=DMX_",D"_F,DX=DX_"S D"_F_"="""" F X=X:0 S D"_F_DMX_")) Q:D"_F_"="""" "_$P("S X=X+1,DS(X)=0,DD(X)=0,DV(X)="_$E("-",$P(A,U,4)["-")_"D"_X_" ",U,F=X),F=F-1 G F:F
- S DX=DX_"S:$D(^(D1,F,""N"")) DD(X)=DD(X)+^(""N"") S:$D(^(""S"")) DS(X)=DS(X)+^(""S"")"
- I $E(IOST)="C" S DIFF=1
- S F=-1,C="*",DIHIOM=IOM-23,DIHIOSL=IOSL-8 U IO W:$D(DIFF)&($Y) @IOF S DIFF=1
- I S @("F"_DN_"""F"",F))") I 'F G END
- S X=0,T=^(F),DS=1 X DX S DIH=X
- D MAX G I
- ;
- MAX S DMX=0 F N=1:1:DIH S:DD(N)>DMX DMX=DD(N) D LBL:DS=1&DF S DV(N)=$E(DV(N),1,14)
- S X=1 F S=1:1 S X=X*2 Q:DMX'>X
- S D1=DMX+X\X*X F S=D1:-X/2 Q:S'>DMX S D1=S
- S D2=DIHIOM*X/D1
- XX S X=X\2,D2=D2\2 I X>4,$L(X)+7<D2 G XX
- I DMX S S=D1/DIHIOM,D1=D2 F X=1:1:DIH D HD:X=1!'(X-1#DIHIOSL),LN,TR:X=N!'(X#DIHIOSL) I Y=U Q
- SUM Q:$P(T,U,4)["D"!(Y=U) I DS=1 S DS=2 F N=1:1 G:N>DIH MAX S S=DD(N),DD(N)=DS(N),DS(N)=S
- MEAN I DS=2 S DS=3 F N=1:1 S DD(N)=$S(DS(N):DD(N)/DS(N),1:0) G MAX:N=DIH
- Q
- ;
- END W:($E(IOST)'="C")&($Y) @IOF K:$D(ZTSK) ^DOSV(0,IO) D CLOSE^DIO4
- ENDK K ZTSK,DIH,S,A,C,DD,DS,D1,D2,DN,T,DP,F,N,J,POP,DF,X,Y,DX,DMX,DV,DIHIOM,DIHIOSL,DIFF Q
- ;
- LBL I DF=1 S D1=$F(DP,DV(N)_":") S:D1 DV(N)=$P($E(DP,D1,999),";",1) Q
- I DF=2 S DV(N)=$P(@(U_DP_DV(N)_",0)"),U,1) Q
- S DV(N)=$S($E(DV(N),4,5):+$E(DV(N),4,5)_"-",1:"")_$S($E(DV(N),6,7):+$E(DV(N),6,7)_"-",1:"")_(1700+$E(DV(N),1,3)) Q
- ;
- HD U IO W:$Y+N+1>DIHIOSL @IOF W !! D W !! Q
- .N H
- .S H=$P("COUNT^SUM^MEAN",U,DS)_", "
- .I $D(^DD(+T,0)) S Y=+$P(T,U,2) I Y>.01,$D(^(Y,0)) S H=H_$P(^(0),U)_", "
- .S H=H_"BY "_$P(DD,U) W ?IOM-$L(H)-2,H
- LN W ?15-$L(DV(X))-1,DV(X)," |" F Y=1:1:DD(X)/S W C
- W ! Q
- TR W ?15 F Y=0:1:DIHIOM W $E("-+",Y#D1=0+1)
- W ! F Y=1:1:DIHIOM I Y#D1=0 S D2=$J(Y*S,0,0) W ?Y+15-($L(D2)\2),D2
- I IOST?1"C".E W $C(7) R Y:DTIME
- Q
- QUE ;
- S ZTSAVE("^DOSV(0,$I,")=""
- S ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL,ZTRTN="DQ^DIH"
- D ^%ZTLOAD K ZTSK G END
- ;
- DIH ;SFISC/GFT-HISTOGRAM ;8:19 AM 28SEP2004
- +1 ;;22.0;VA FileMan;**2,61,144**;Mar 30, 1999;Build 5
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 IF $ORDER(^DOSV(0,IO(0),0))'>0
- WRITE !,$CHAR(7),"NO SUB-COUNTS WERE RUN"
- QUIT
- +4 KILL ZTSK
- IF $DATA(^%ZTSK)
- SET %ZIS="QM"
- DO ^%ZIS
- IF POP
- GOTO ENDK
- IF $DATA(IO("Q"))
- GOTO QUE
- DQ SET J=$IO
- SET DN="=$O(^DOSV(0,J,"
- FOR X=0:1
- IF '$DATA(^DOSV(0,J,"BY",X+1))
- QUIT
- +1 IF 'X
- GOTO END
- SET A=^(1)
- SET DD=$PIECE(A,U,3)
- IF $DATA(^DD(+A,+$PIECE(A,U,2),0))
- SET DD=^(0)
- +2 SET T=$PIECE(DD,U,2)
- SET DP=$PIECE(DD,U,3)
- SET DF=$SELECT(T["S":1,T["P":2,T["D"!($PIECE(A,U,7)["D"):3,1:0)
- +3 SET DMX=DN_X
- SET DX=""
- SET F=X
- F SET DMX=DMX_",D"_F
- SET DX=DX_"S D"_F_"="""" F X=X:0 S D"_F_DMX_")) Q:D"_F_"="""" "_$PIECE("S X=X+1,DS(X)=0,DD(X)=0,DV(X)="_$EXTRACT("-",$PIECE(A,U,4)["-")_"D"_X_" ",U,F=X)
- SET F=F-1
- IF F
- GOTO F
- +1 SET DX=DX_"S:$D(^(D1,F,""N"")) DD(X)=DD(X)+^(""N"") S:$D(^(""S"")) DS(X)=DS(X)+^(""S"")"
- +2 IF $EXTRACT(IOST)="C"
- SET DIFF=1
- +3 SET F=-1
- SET C="*"
- SET DIHIOM=IOM-23
- SET DIHIOSL=IOSL-8
- USE IO
- IF $DATA(DIFF)&($Y)
- WRITE @IOF
- SET DIFF=1
- I SET @("F"_DN_"""F"",F))")
- IF 'F
- GOTO END
- +1 SET X=0
- SET T=^(F)
- SET DS=1
- XECUTE DX
- SET DIH=X
- +2 DO MAX
- GOTO I
- +3 ;
- MAX SET DMX=0
- FOR N=1:1:DIH
- IF DD(N)>DMX
- SET DMX=DD(N)
- IF DS=1&DF
- DO LBL
- SET DV(N)=$EXTRACT(DV(N),1,14)
- +1 SET X=1
- FOR S=1:1
- SET X=X*2
- IF DMX'>X
- QUIT
- +2 SET D1=DMX+X\X*X
- FOR S=D1:-X/2
- IF S'>DMX
- QUIT
- SET D1=S
- +3 SET D2=DIHIOM*X/D1
- XX SET X=X\2
- SET D2=D2\2
- IF X>4
- IF $LENGTH(X)+7<D2
- GOTO XX
- +1 IF DMX
- SET S=D1/DIHIOM
- SET D1=D2
- FOR X=1:1:DIH
- IF X=1!'(X-1#DIHIOSL)
- DO HD
- DO LN
- IF X=N!'(X#DIHIOSL)
- DO TR
- IF Y=U
- QUIT
- SUM IF $PIECE(T,U,4)["D"!(Y=U)
- QUIT
- IF DS=1
- SET DS=2
- FOR N=1:1
- IF N>DIH
- GOTO MAX
- SET S=DD(N)
- SET DD(N)=DS(N)
- SET DS(N)=S
- MEAN IF DS=2
- SET DS=3
- FOR N=1:1
- SET DD(N)=$SELECT(DS(N):DD(N)/DS(N),1:0)
- IF N=DIH
- GOTO MAX
- +1 QUIT
- +2 ;
- END IF ($EXTRACT(IOST)'="C")&($Y)
- WRITE @IOF
- IF $DATA(ZTSK)
- KILL ^DOSV(0,IO)
- DO CLOSE^DIO4
- ENDK KILL ZTSK,DIH,S,A,C,DD,DS,D1,D2,DN,T,DP,F,N,J,POP,DF,X,Y,DX,DMX,DV,DIHIOM,DIHIOSL,DIFF
- QUIT
- +1 ;
- LBL IF DF=1
- SET D1=$FIND(DP,DV(N)_":")
- IF D1
- SET DV(N)=$PIECE($EXTRACT(DP,D1,999),";",1)
- QUIT
- +1 IF DF=2
- SET DV(N)=$PIECE(@(U_DP_DV(N)_",0)"),U,1)
- QUIT
- +2 SET DV(N)=$SELECT($EXTRACT(DV(N),4,5):+$EXTRACT(DV(N),4,5)_"-",1:"")_$SELECT($EXTRACT(DV(N),6,7):+$EXTRACT(DV(N),6,7)_"-",1:"")_(1700+$EXTRACT(DV(N),1,3))
- QUIT
- +3 ;
- HD USE IO
- IF $Y+N+1>DIHIOSL
- WRITE @IOF
- WRITE !!
- Begin DoDot:1
- +1 NEW H
- +2 SET H=$PIECE("COUNT^SUM^MEAN",U,DS)_", "
- +3 IF $DATA(^DD(+T,0))
- SET Y=+$PIECE(T,U,2)
- IF Y>.01
- IF $DATA(^(Y,0))
- SET H=H_$PIECE(^(0),U)_", "
- +4 SET H=H_"BY "_$PIECE(DD,U)
- WRITE ?IOM-$LENGTH(H)-2,H
- End DoDot:1
- WRITE !!
- QUIT
- LN WRITE ?15-$LENGTH(DV(X))-1,DV(X)," |"
- FOR Y=1:1:DD(X)/S
- WRITE C
- +1 WRITE !
- QUIT
- TR WRITE ?15
- FOR Y=0:1:DIHIOM
- WRITE $EXTRACT("-+",Y#D1=0+1)
- +1 WRITE !
- FOR Y=1:1:DIHIOM
- IF Y#D1=0
- SET D2=$JUSTIFY(Y*S,0,0)
- WRITE ?Y+15-($LENGTH(D2)\2),D2
- +2 IF IOST?1"C".E
- WRITE $CHAR(7)
- READ Y:DTIME
- +3 QUIT
- QUE ;
- +1 SET ZTSAVE("^DOSV(0,$I,")=""
- +2 SET ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL
- SET ZTRTN="DQ^DIH"
- +3 DO ^%ZTLOAD
- KILL ZTSK
- GOTO END
- +4 ;
