source: WorldVistAEHR/trunk/r/DIETETICS-FH/FHADR3A.m@ 623

Last change on this file since 623 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1FHADR3A ; HISC/NCA - Facility Workload ;6/18/93 11:30
2 ;;5.5;DIETETICS;;Jan 28, 2005
3EN2 ; Calculate Inpats Days of Care and Outpats treated in
4 ; Hosp & Sat Clinics
5 K AMS,T1,T2,TD S AMS="" F K=1:1:8 S T1(K)=""
6 F K=1:1:4 S TD(K)=0
7 F QR=1:1:4 S QTR=QR,PRE=FHYR_"0"_QTR_"00" D Q2^FHADRPT D
8 .Q:'SDT!('EDT)
9 .K N S S=0 F K=1:1:24 S N(K)=0
10 .S STR1=""
11 .S D1=SDT\1 F L1=0:0 D Q:X>EDT
12 ..S Y0=$G(^FH(117,D1,0)),Y1=$G(^(1))
13 ..S:Y0'="" S=S+1
14 ..S K=1 F L=1,2,4,5,7,8 S K=K+1,N(L)=$P(Y0,"^",K)
15 ..S K=10 F L=1:3:16 S K=K+1,N(K)=$P(Y1,"^",L)+$P(Y1,"^",L+1)+$P(Y1,"^",L+2)
16 ..S N(3)=N(1)-N(2)*3,N(6)=N(4)-N(5)*3,N(9)=N(7)-N(8)*3
17 ..S N(10)=N(3)+N(6)+N(9)+N(11)+N(12)+N(13)+N(14)+N(15)+N(16)
18 ..S N(22)=N(1)-N(2),N(23)=N(4)-N(5),N(24)=N(7)-N(8)
19 ..S N(17)=N(17)+N(10),N(18)=N(18)+N(22)
20 ..S N(19)=N(19)+N(23),N(20)=N(20)+N(24)
21 ..S X1=D1,X2=1 D C^%DTC
22 ..S D1=X
23 ..Q
24 .S N(21)=N(18)+N(19)+N(20)
25 .S $P(T1(QTR),"^",1)=$P(T1(QTR),"^",1)+N(17)
26 .S $P(T1(QTR),"^",2)=$P(T1(QTR),"^",2)+N(20)
27 .S $P(T1(QTR),"^",3)=$P(T1(QTR),"^",3)+N(19)
28 .S $P(T1(QTR),"^",4)=$P(T1(QTR),"^",4)+N(18)
29 .S $P(T1(QTR),"^",5)=$P(T1(QTR),"^",5)+N(21)
30 .S TD(QTR)=TD(QTR)+S
31 .S $P(^FH(117.3,PRE,1),"^",5)=N(17)
32 .S STR=$G(^FH(117.3,PRE,1))
33 .S $P(T1(5),"^",QTR)=$P(T1(5),"^",QTR)+$P(STR,"^",1)
34 .S $P(T1(5),"^",5)=$P(T1(5),"^",5)+$P(STR,"^",1)
35 .S $P(T1(6),"^",QTR)=$P(T1(6),"^",QTR)+$P(STR,"^",1)
36 .S NUM=$P(STR,"^",3) Q:NUM<1
37 .S CTR=$P($G(^FH(117.3,PRE,"CLIN",0)),"^",4) Q:CTR="" Q:CTR'=NUM
38 .F NUM=0:0 S NUM=$O(^FH(117.3,PRE,"CLIN",NUM)) Q:NUM<1 S STR1=$G(^(NUM,0)) D
39 ..S SAT=$P(STR1,"^",1)
40 ..I SAT'="" S:'$D(T2(SAT)) T2(SAT)=""
41 ..S $P(T2(SAT),"^",QTR)=$P(T2(SAT),"^",QTR)+$P(STR1,"^",2)
42 ..S $P(T2(SAT),"^",5)=$P(T2(SAT),"^",5)+$P(STR1,"^",2)
43 ..S $P(T1(5),"^",5)=$P(T1(5),"^",5)+$P(STR1,"^",2)
44 ..S $P(T1(6),"^",QTR)=$P(T1(6),"^",QTR)+$P(STR1,"^",2)
45 ..Q
46 .Q
47 D HDR1 S (FIN,FTO,YD)=0
48 W !,?15,"Hospital ",?61
49 F I=1:1:4 S X=$P(T1(I),"^",2),X2=0 D COMMA^%DTC W X S FIN=FIN+$P(T1(I),"^",2)
50 S X=FIN,X2=0 D COMMA^%DTC W ?112,X S FTO=FTO+FIN,FIN=0
51 W !,?15,"Nursing Home ",?61
52 F I=1:1:4 S X=$P(T1(I),"^",3),X2=0 D COMMA^%DTC W X S FIN=FIN+$P(T1(I),"^",3)
53 S X=FIN,X2=0 D COMMA^%DTC W ?112,X S FTO=FTO+FIN,FIN=0
54 W !,?15,"Domicillary ",?61
55 F I=1:1:4 S X=$P(T1(I),"^",4),X2=0 D COMMA^%DTC W X S FIN=FIN+$P(T1(I),"^",4)
56 S X=FIN,X2=0 D COMMA^%DTC W ?112,X S FTO=FTO+FIN,FIN=0
57 W !,?15,"Total Inpatient Days ",?61
58 F I=1:1:4 S X=$P(T1(I),"^",5),X2=0 D COMMA^%DTC W X
59 S X=FTO,X2=0 D COMMA^%DTC W ?112,X
60 W !!!,?13,"OUTPATIENTS TREATED",!?15,"Hospital Clinic ",?61
61 F I=1:1:4 S X=$P(T1(5),"^",I),X2=0 D COMMA^%DTC W X S FIN=FIN+$P(T1(5),"^",I)
62 S X=FIN,X2=0 D COMMA^%DTC W ?112,X S FIN=0
63 S (CT,Z)=0 F K=0:0 S Z=$O(T2(Z)) Q:Z="" S CT=CT+1 D
64 .W !,?15,"Satellite Location ",CT," ",Z,?61
65 .F J=1:1:4 S X=$P(T2(Z),"^",J),X2=0 D COMMA^%DTC W X
66 .S X=$P(T2(Z),"^",5),X2=0 D COMMA^%DTC W ?112,X
67 .Q
68 W !,?15,"Total Outpatients Treated ",?61
69 F I=1:1:4 S X=$P(T1(6),"^",I),X2=0 D COMMA^%DTC W X S FIN=FIN+$P(T1(6),"^",I)
70 S X=FIN,X2=0 D COMMA^%DTC W ?112,X S FIN=0
71 D:$Y'<LIN HDR^FHADRPT D HDR2
72 W !!!!?13,"SERVED MEALS SUMMARY",!!?65,"1st Qtr 2nd Qtr 3rd Qtr 4th Qtr Yearly"
73 W !!?15,"Total Served Meals",?61
74 F I=1:1:4 S X=$P(T1(I),"^",1),X2=0 D COMMA^%DTC W X S FIN=FIN+$P(T1(I),"^",1)
75 S X=FIN,X2=0 D COMMA^%DTC W ?112,X
76 W !,?15,"Average Daily Meals",?61 S FIN=0
77 F I=1:1:4 S X=$S(+TD(I)'<1:$P(T1(I),"^",1)/TD(I),1:""),$P(AMS,"^",I)=X,X2=0,FIN=FIN+$P(T1(I),"^",1),YD=YD+TD(I) D COMMA^%DTC W X
78 S X=$S(YD'<1:FIN/YD,1:""),X2=0 D COMMA^%DTC W ?112,X
79 K N,T1,T2,TD Q
80HDR1 ; Print heading for Facility Workload
81 D:$Y'<(LIN-20) HDR^FHADRPT
82 W !!!?13,"S E C T I O N II F A C I L I T Y W O R K L O A D S T A T I S T I C S"
83 W !!!!,?13,"INPATIENT DAYS OF CARE" W ?65,"1st Qtr 2nd Qtr 3rd Qtr 4th Qtr YTD Total" Q
84HDR2 ; Print Heading for Workload Statistics
85 D:$Y'<(LIN-14) HDR^FHADRPT
86 W !!!!!!?13,"S E C T I O N III D I E T E T I C W O R K L O A D S T A T I S T I C S"
87 Q
Note: See TracBrowser for help on using the repository browser.