- FHASE1A ; HISC/REL/NCA - Encounter Statistics (cont.) ;9/6/94 13:13
- ;;5.5;DIETETICS;;Jan 28, 2005
- Q1 ; Calculate the Encounters
- K ^TMP($J) S X1=SDT\1-.0001,X2=EDT\1+.3
- S TIT=";"_$P(^DD(115.6,10,0),"^",3)
- R1 S X1=$O(^FHEN("AT",X1)) I X1<1!(X1>X2) G P1
- S E1=0
- R2 S E1=$O(^FHEN("AT",X1,E1)) G:E1="" R1
- S Y=$G(^FHEN(E1,0))
- S D1=$P(Y,"^",3),D2=$P(Y,"^",4) G:'D2 R2 I FHX1>0,D1'=FHX1 G R2
- S D6=$P(Y,"^",7),D3=$P(Y,"^",8),D9=$P(Y,"^",9),D5=$P(Y,"^",11) D CNT
- S D2=$P($G(^FH(115.6,D2,0)),"^",1,2) G:"^"[D2 R2
- S Z1=$P(D2,"^",2),D2=$P(D2,"^",1)
- S D8=$F(TIT,";"_Z1_":") G:D8<0 R2
- S:D6="F" D2=D2_"~F"
- S S1=$G(^TMP($J,0,D8,D2)) D UPD S ^TMP($J,0,D8,D2)=S1
- G R2:FHX1<0,R2:'D1 I '$D(^TMP($J,D1)) S NAM=$P(^VA(200,D1,0),"^",1),^TMP($J,$E(NAM,1,30),D1)=""
- S S1=$G(^TMP($J,D1,D8,D2)) D UPD S ^TMP($J,D1,D8,D2)=S1 G:'FHX2 R2
- S (DTP,W1)=$P(Y,"^",2)\1 D DTP^FH I '$D(^TMP($J,D1,D8,D2,W1)) S ^TMP($J,D1,D8,D2,W1)=DTP,^(W1,0)=0
- I '$D(^FHEN(E1,"P")) G R4
- F DFN=0:0 S DFN=$O(^FHEN(E1,"P",DFN)) Q:DFN<1 D R3
- G R2
- R3 S L=^TMP($J,D1,D8,D2,W1,0)+1,^(0)=L
- S ^TMP($J,D1,D8,D2,W1,L)=DFN Q
- R4 S DFN="^"_D5 D R3 G R2
- CNT S C(8)=$P(Y,"^",10),(C(1),C(2),C(3),C(4),C(5),C(6),C(7))=0
- F DFN=0:0 S DFN=$O(^FHEN(E1,"P",DFN)) Q:DFN<1 S X=^(DFN,0) D C1
- S C(7)=C(8)-C(1)-C(2)-C(4)-C(5) S:C(7)<1 C(7)=0
- I D9'="I" S TM=C(1)+C(4)+C(7) I TM S TM=D3/TM,C(3)=TM*C(1),C(6)=TM*C(4),C(3)=$J(C(3),0,1),C(6)=$J(C(6),0,1) Q
- Q
- C1 S Z=$P(X,"^",2) G:Z<1 C2 S Z=$P($G(^SC(+Z,0)),"^",3) G:Z'="W" C2
- S C(1)=C(1)+1,C(2)=C(2)+$P(X,"^",3) S:D9="I" C(3)=C(3)+D3 Q
- C2 S C(4)=C(4)+1,C(5)=C(5)+$P(X,"^",3) S:D9="I" C(6)=C(6)+D3 Q
- UPD S $P(S1,"^",1)=$P(S1,"^",1)+1,$P(S1,"^",2)=$P(S1,"^",2)+D3
- F K=1:1:8 I C(K) S $P(S1,"^",K+2)=$P(S1,"^",K+2)+C(K)
- Q
- P1 S DTP=SDT\1 D DTP^FH S DTE=DTP_" to " S DTP=EDT\1 D DTP^FH S DTE=DTE_DTP,PG=0 D HEAD I FHX1>0 G D0
- S D8="",CT=0 F K=1:1:11 S (I(K),J(K))=0
- F KK=0:0 S D8=$O(^TMP($J,0,D8)) Q:D8="" S CT=CT+1 D:CT'=1 STOT W ! D PR S NX="" F K=0:0 S NX=$O(^TMP($J,0,D8,NX)) Q:NX="" S X1=$P(NX,"~",1)_$S($P(NX,"~",2)="F":" (F)",1:"") Q:X1="" S S1=^TMP($J,0,D8,NX) D PP
- D STOT W ! S X="T O T A L" D TOT W ! Q:FHX1<0 D HEAD
- D0 S NX=":" F K=0:0 S NX=$O(^TMP($J,NX)) Q:NX="" F D1=0:0 S D1=$O(^TMP($J,NX,D1)) Q:D1<1 D P2
- W ! Q
- P2 D:$Y>(IOSL-6) HEAD W !!,NX S D8="",CT=0 F K=1:1:11 S (I(K),J(K))=0
- F L=0:0 S D8=$O(^TMP($J,D1,D8)) Q:D8="" S CT=CT+1 D:CT'=1 STOT W ! D PR S D2="" F L1=0:0 S D2=$O(^TMP($J,D1,D8,D2)) Q:D2="" S S1=^(D2),X1=$P(D2,"~",1)_$S($P(D2,"~",2)="F":" (F)",1:"") D PP I FHX2 D P3
- D STOT W ! S X="TOTAL ENCOUNTERS" D TOT Q
- P3 S DTP=""
- P4 S DTP=$O(^TMP($J,D1,D8,D2,DTP)) Q:DTP="" S S1=^(DTP),W1=0
- P5 S W1=$O(^TMP($J,D1,D8,D2,DTP,W1)) G:W1="" P4 S DFN=^(W1) G:DFN<1 P6
- S Y=$G(^DPT(DFN,0)) G:Y="" P5 D PID^FHDPA
- W !?7,S1,?17,BID,?26,$P(Y,"^",1) G P5
- P6 W !?7,S1,?17,$P(DFN,"^",2) G P5
- PP D:$Y>(IOSL-6) HEAD W !?5,X1,?47,$J($P(S1,"^",1),6,0) S I(1)=I(1)+$P(S1,"^",1),J(1)=J(1)+$P(S1,"^",1)
- F K=1:1:6 S Z=$P(S1,"^",K+2),I(K+2)=I(K+2)+Z,J(K+2)=J(K+2)+Z W $S(K=3!(K=6):$S(Z:$J(Z,8,1),1:$J("",8)),1:$J($S(Z:Z,1:""),6))
- S Z=$P(S1,"^",9),I(9)=I(9)+$S(Z'<1:Z,1:0),J(9)=J(9)+$S(Z'<1:Z,1:0) W ?97,$J($S(Z'<1:Z,1:""),6)
- I Z S Z=$P(S1,"^",2)-$P(S1,"^",5)-$P(S1,"^",8),I(10)=I(10)+$S(Z'<1:Z,1:0),J(10)=J(10)+$S(Z'<1:Z,1:0)
- W $S(Z'<1:$J(Z,8,1),1:$J("",8))
- S Z=$P(S1,"^",10),I(11)=I(11)+Z,J(11)=J(11)+Z W ?113,$J($S(Z'<1:Z,1:""),6)
- I $P(S1,"^",2) W $J($P(S1,"^",2),8,1) S I(2)=I(2)+$P(S1,"^",2),J(2)=J(2)+$P(S1,"^",2)
- Q
- PR S X=$P($E(TIT,D8,999),";",1)
- D:$Y>(IOSL-6) HEAD W !?3,X Q
- STOT W !?5,"Subtotal",?47,$J(J(1),6) F K=1:1:6 W $S(K=3!(K=6):$S(J(K+2):$J(J(K+2),8,1),1:$J("",8)),1:$J($S(J(K+2):J(K+2),1:""),6))
- W ?97,$S(J(9):$J(J(9),6),1:$J("",6)),$S(J(10):$J(J(10),8,1),1:$J("",8))
- W ?113,$S(J(11):$J(J(11),6),1:$J("",6)),$S(J(2):$J(J(2),8,1),1:$J("",8))
- F K=1:1:11 S J(K)=0
- Q
- TOT W !?3,X,?47,$J(I(1),6) F K=1:1:6 W $S(K=3!(K=6):$S(I(K+2):$J(I(K+2),8,1),1:$J("",8)),1:$J($S(I(K+2):I(K+2),1:""),6))
- W ?97,$S(I(9):$J(I(9),6),1:$J("",6)),$S(I(10):$J(I(10),8,1),1:$J("",8))
- W ?113,$S(I(11):$J(I(11),6),1:$J("",6)),$S(I(2):$J(I(2),8,1),1:$J("",8)) Q
- HEAD ;W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 W !?30,"D I E T E T I C E N C O U N T E R S T A T I S T I C S",?120,"Page ",PG
- W @IOF S PG=PG+1 W !?30,"D I E T E T I C E N C O U N T E R S T A T I S T I C S",?120,"Page ",PG
- W !!?(114-$L(DTE)\2),DTE,!?47,"Number Inpatients Outpatients Others Total"
- W !?56,"Pat Col Units Pat Col Units",?98,"Persn Units Persn Units",! Q
- FHASE1A ; HISC/REL/NCA - Encounter Statistics (cont.) ;9/6/94 13:13
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- Q1 ; Calculate the Encounters
- +1 KILL ^TMP($JOB)
- SET X1=SDT\1-.0001
- SET X2=EDT\1+.3
- +2 SET TIT=";"_$PIECE(^DD(115.6,10,0),"^",3)
- R1 SET X1=$ORDER(^FHEN("AT",X1))
- IF X1<1!(X1>X2)
- GOTO P1
- +1 SET E1=0
- R2 SET E1=$ORDER(^FHEN("AT",X1,E1))
- IF E1=""
- GOTO R1
- +1 SET Y=$GET(^FHEN(E1,0))
- +2 SET D1=$PIECE(Y,"^",3)
- SET D2=$PIECE(Y,"^",4)
- IF 'D2
- GOTO R2
- IF FHX1>0
- IF D1'=FHX1
- GOTO R2
- +3 SET D6=$PIECE(Y,"^",7)
- SET D3=$PIECE(Y,"^",8)
- SET D9=$PIECE(Y,"^",9)
- SET D5=$PIECE(Y,"^",11)
- DO CNT
- +4 SET D2=$PIECE($GET(^FH(115.6,D2,0)),"^",1,2)
- IF "^"[D2
- GOTO R2
- +5 SET Z1=$PIECE(D2,"^",2)
- SET D2=$PIECE(D2,"^",1)
- +6 SET D8=$FIND(TIT,";"_Z1_":")
- IF D8<0
- GOTO R2
- +7 IF D6="F"
- SET D2=D2_"~F"
- +8 SET S1=$GET(^TMP($JOB,0,D8,D2))
- DO UPD
- SET ^TMP($JOB,0,D8,D2)=S1
- +9 IF FHX1<0
- GOTO R2
- IF 'D1
- GOTO R2
- IF '$DATA(^TMP($JOB,D1))
- SET NAM=$PIECE(^VA(200,D1,0),"^",1)
- SET ^TMP($JOB,$EXTRACT(NAM,1,30),D1)=""
- +10 SET S1=$GET(^TMP($JOB,D1,D8,D2))
- DO UPD
- SET ^TMP($JOB,D1,D8,D2)=S1
- IF 'FHX2
- GOTO R2
- +11 SET (DTP,W1)=$PIECE(Y,"^",2)\1
- DO DTP^FH
- IF '$DATA(^TMP($JOB,D1,D8,D2,W1))
- SET ^TMP($JOB,D1,D8,D2,W1)=DTP
- SET ^(W1,0)=0
- +12 IF '$DATA(^FHEN(E1,"P"))
- GOTO R4
- +13 FOR DFN=0:0
- SET DFN=$ORDER(^FHEN(E1,"P",DFN))
- IF DFN<1
- QUIT
- DO R3
- +14 GOTO R2
- R3 SET L=^TMP($JOB,D1,D8,D2,W1,0)+1
- SET ^(0)=L
- +1 SET ^TMP($JOB,D1,D8,D2,W1,L)=DFN
- QUIT
- R4 SET DFN="^"_D5
- DO R3
- GOTO R2
- CNT SET C(8)=$PIECE(Y,"^",10)
- SET (C(1),C(2),C(3),C(4),C(5),C(6),C(7))=0
- +1 FOR DFN=0:0
- SET DFN=$ORDER(^FHEN(E1,"P",DFN))
- IF DFN<1
- QUIT
- SET X=^(DFN,0)
- DO C1
- +2 SET C(7)=C(8)-C(1)-C(2)-C(4)-C(5)
- IF C(7)<1
- SET C(7)=0
- +3 IF D9'="I"
- SET TM=C(1)+C(4)+C(7)
- IF TM
- SET TM=D3/TM
- SET C(3)=TM*C(1)
- SET C(6)=TM*C(4)
- SET C(3)=$JUSTIFY(C(3),0,1)
- SET C(6)=$JUSTIFY(C(6),0,1)
- QUIT
- +4 QUIT
- C1 SET Z=$PIECE(X,"^",2)
- IF Z<1
- GOTO C2
- SET Z=$PIECE($GET(^SC(+Z,0)),"^",3)
- IF Z'="W"
- GOTO C2
- +1 SET C(1)=C(1)+1
- SET C(2)=C(2)+$PIECE(X,"^",3)
- IF D9="I"
- SET C(3)=C(3)+D3
- QUIT
- C2 SET C(4)=C(4)+1
- SET C(5)=C(5)+$PIECE(X,"^",3)
- IF D9="I"
- SET C(6)=C(6)+D3
- QUIT
- UPD SET $PIECE(S1,"^",1)=$PIECE(S1,"^",1)+1
- SET $PIECE(S1,"^",2)=$PIECE(S1,"^",2)+D3
- +1 FOR K=1:1:8
- IF C(K)
- SET $PIECE(S1,"^",K+2)=$PIECE(S1,"^",K+2)+C(K)
- +2 QUIT
- P1 SET DTP=SDT\1
- DO DTP^FH
- SET DTE=DTP_" to "
- SET DTP=EDT\1
- DO DTP^FH
- SET DTE=DTE_DTP
- SET PG=0
- DO HEAD
- IF FHX1>0
- GOTO D0
- +1 SET D8=""
- SET CT=0
- FOR K=1:1:11
- SET (I(K),J(K))=0
- +2 FOR KK=0:0
- SET D8=$ORDER(^TMP($JOB,0,D8))
- IF D8=""
- QUIT
- SET CT=CT+1
- IF CT'=1
- DO STOT
- WRITE !
- DO PR
- SET NX=""
- FOR K=0:0
- SET NX=$ORDER(^TMP($JOB,0,D8,NX))
- IF NX=""
- QUIT
- SET X1=$PIECE(NX,"~",1)_$SELECT($PIECE(NX,"~",2)="F":" (F)",1:"")
- IF X1=""
- QUIT
- SET S1=^TMP($JOB,0,D8,NX)
- DO PP
- +3 DO STOT
- WRITE !
- SET X="T O T A L"
- DO TOT
- WRITE !
- IF FHX1<0
- QUIT
- DO HEAD
- D0 SET NX=":"
- FOR K=0:0
- SET NX=$ORDER(^TMP($JOB,NX))
- IF NX=""
- QUIT
- FOR D1=0:0
- SET D1=$ORDER(^TMP($JOB,NX,D1))
- IF D1<1
- QUIT
- DO P2
- +1 WRITE !
- QUIT
- P2 IF $Y>(IOSL-6)
- DO HEAD
- WRITE !!,NX
- SET D8=""
- SET CT=0
- FOR K=1:1:11
- SET (I(K),J(K))=0
- +1 FOR L=0:0
- SET D8=$ORDER(^TMP($JOB,D1,D8))
- IF D8=""
- QUIT
- SET CT=CT+1
- IF CT'=1
- DO STOT
- WRITE !
- DO PR
- SET D2=""
- FOR L1=0:0
- SET D2=$ORDER(^TMP($JOB,D1,D8,D2))
- IF D2=""
- QUIT
- SET S1=^(D2)
- SET X1=$PIECE(D2,"~",1)_$SELECT($PIECE(D2,"~",2)="F":" (F)",1:"")
- DO PP
- IF FHX2
- DO P3
- +2 DO STOT
- WRITE !
- SET X="TOTAL ENCOUNTERS"
- DO TOT
- QUIT
- P3 SET DTP=""
- P4 SET DTP=$ORDER(^TMP($JOB,D1,D8,D2,DTP))
- IF DTP=""
- QUIT
- SET S1=^(DTP)
- SET W1=0
- P5 SET W1=$ORDER(^TMP($JOB,D1,D8,D2,DTP,W1))
- IF W1=""
- GOTO P4
- SET DFN=^(W1)
- IF DFN<1
- GOTO P6
- +1 SET Y=$GET(^DPT(DFN,0))
- IF Y=""
- GOTO P5
- DO PID^FHDPA
- +2 WRITE !?7,S1,?17,BID,?26,$PIECE(Y,"^",1)
- GOTO P5
- P6 WRITE !?7,S1,?17,$PIECE(DFN,"^",2)
- GOTO P5
- PP IF $Y>(IOSL-6)
- DO HEAD
- WRITE !?5,X1,?47,$JUSTIFY($PIECE(S1,"^",1),6,0)
- SET I(1)=I(1)+$PIECE(S1,"^",1)
- SET J(1)=J(1)+$PIECE(S1,"^",1)
- +1 FOR K=1:1:6
- SET Z=$PIECE(S1,"^",K+2)
- SET I(K+2)=I(K+2)+Z
- SET J(K+2)=J(K+2)+Z
- WRITE $SELECT(K=3!(K=6):$SELECT(Z:$JUSTIFY(Z,8,1),1:$JUSTIFY("",8)),1:$JUSTIFY($SELECT(Z:Z,1:""),6))
- +2 SET Z=$PIECE(S1,"^",9)
- SET I(9)=I(9)+$SELECT(Z'<1:Z,1:0)
- SET J(9)=J(9)+$SELECT(Z'<1:Z,1:0)
- WRITE ?97,$JUSTIFY($SELECT(Z'<1:Z,1:""),6)
- +3 IF Z
- SET Z=$PIECE(S1,"^",2)-$PIECE(S1,"^",5)-$PIECE(S1,"^",8)
- SET I(10)=I(10)+$SELECT(Z'<1:Z,1:0)
- SET J(10)=J(10)+$SELECT(Z'<1:Z,1:0)
- +4 WRITE $SELECT(Z'<1:$JUSTIFY(Z,8,1),1:$JUSTIFY("",8))
- +5 SET Z=$PIECE(S1,"^",10)
- SET I(11)=I(11)+Z
- SET J(11)=J(11)+Z
- WRITE ?113,$JUSTIFY($SELECT(Z'<1:Z,1:""),6)
- +6 IF $PIECE(S1,"^",2)
- WRITE $JUSTIFY($PIECE(S1,"^",2),8,1)
- SET I(2)=I(2)+$PIECE(S1,"^",2)
- SET J(2)=J(2)+$PIECE(S1,"^",2)
- +7 QUIT
- PR SET X=$PIECE($EXTRACT(TIT,D8,999),";",1)
- +1 IF $Y>(IOSL-6)
- DO HEAD
- WRITE !?3,X
- QUIT
- STOT WRITE !?5,"Subtotal",?47,$JUSTIFY(J(1),6)
- FOR K=1:1:6
- WRITE $SELECT(K=3!(K=6):$SELECT(J(K+2):$JUSTIFY(J(K+2),8,1),1:$JUSTIFY("",8)),1:$JUSTIFY($SELECT(J(K+2):J(K+2),1:""),6))
- +1 WRITE ?97,$SELECT(J(9):$JUSTIFY(J(9),6),1:$JUSTIFY("",6)),$SELECT(J(10):$JUSTIFY(J(10),8,1),1:$JUSTIFY("",8))
- +2 WRITE ?113,$SELECT(J(11):$JUSTIFY(J(11),6),1:$JUSTIFY("",6)),$SELECT(J(2):$JUSTIFY(J(2),8,1),1:$JUSTIFY("",8))
- +3 FOR K=1:1:11
- SET J(K)=0
- +4 QUIT
- TOT WRITE !?3,X,?47,$JUSTIFY(I(1),6)
- FOR K=1:1:6
- WRITE $SELECT(K=3!(K=6):$SELECT(I(K+2):$JUSTIFY(I(K+2),8,1),1:$JUSTIFY("",8)),1:$JUSTIFY($SELECT(I(K+2):I(K+2),1:""),6))
- +1 WRITE ?97,$SELECT(I(9):$JUSTIFY(I(9),6),1:$JUSTIFY("",6)),$SELECT(I(10):$JUSTIFY(I(10),8,1),1:$JUSTIFY("",8))
- +2 WRITE ?113,$SELECT(I(11):$JUSTIFY(I(11),6),1:$JUSTIFY("",6)),$SELECT(I(2):$JUSTIFY(I(2),8,1),1:$JUSTIFY("",8))
- QUIT
- HEAD ;W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 W !?30,"D I E T E T I C E N C O U N T E R S T A T I S T I C S",?120,"Page ",PG
- +1 WRITE @IOF
- SET PG=PG+1
- WRITE !?30,"D I E T E T I C E N C O U N T E R S T A T I S T I C S",?120,"Page ",PG
- +2 WRITE !!?(114-$LENGTH(DTE)\2),DTE,!?47,"Number Inpatients Outpatients Others Total"
- +3 WRITE !?56,"Pat Col Units Pat Col Units",?98,"Persn Units Persn Units",!
- QUIT
