source: WorldVistAEHR/trunk/r/DIETETICS-FH/FHADR81.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.7 KB
Line 
1FHADR81 ; HISC/NCA - Print Dietetic Costs ;11/25/94 14:11
2 ;;5.5;DIETETICS;;Jan 28, 2005
3EN2 ; Print Dietetic Cost
4 K N,PER,T1,TO,TP S (TO,TP,TQ,TQ1,TQ2,TQ3,TQ4)="",TOT=0
5 F I=1:1:5 S T1(I)=""
6 F I=1:1:4 S PER(I)=""
7 F QR=1:1:4 S QTR=QR,PRE=FHYR_"0"_QTR_"00" D Q2^FHADRPT,CALC
8 D PRT K N,PER,T1,TO,TP Q
9CALC ; Calculate the Avg Cost Per Meal and store it in T1(1)
10 Q:'SDT!('EDT)
11 S (BEG,CLOS,ISS,USG)=0
12 S SDT=$E(SDT,1,5)_"00",EDT=$E(EDT,1,5)_"00"
13 S X1=$P($G(^FH(117.2,SDT,0)),"^",2,7) F J=1:1:6 S BEG=BEG+$P(X1,"^",J)
14 S X1=$P($G(^FH(117.2,EDT,0)),"^",14,19) F J=1:1:6 S CLOS=CLOS+$P(X1,"^",J)
15 S SDT=$E(SDT,1,5)-1_"00"
16 F LL=SDT:0 S LL=$O(^FH(117.2,LL)) Q:LL<1!(LL>EDT) S X1=^(LL,0) D
17 .S J1=7
18 .F J=1:1:6 D
19 ..S J1=J1+1
20 ..S ISS=ISS+$P(X1,"^",J1)
21 ..Q
22 .Q
23 S USG=(BEG+ISS)-CLOS
24 S TQ=TQ+1
25 S TOT=$P($G(^FH(117.3,PRE,1)),"^",5)
26 S USG=$S(TOT:USG/TOT,1:"") S:USG TQ1=TQ1+1 S $P(T1(1),"^",QTR)=$P(T1(1),"^",QTR)+USG
27 S $P(T1(1),"^",5)=$P(T1(1),"^",5)+USG
28 ; Calculate the Cost Per Diem
29 S ST=$P($G(^FH(117.3,PRE,"COST",0)),"^",3) Q:ST<1
30 S ST1=$G(^FH(117.3,PRE,"COST",ST,0)) Q:ST1=""
31 F I=1:1:10 S N(I)=""
32 S K=0 F I=1:1:6,8,9 S K=K+1,N(I)=$P(ST1,"^",K)
33 S TOT=$S(TOT:TOT/3,1:"")
34 F M=1:1:6,8,9 S N(M)=$S(TOT:N(M)/TOT,1:"")
35 S N(7)=N(2)-N(3)-N(4)-N(5)-N(6),N(10)=N(1)-N(2)-N(8)-N(9)
36 F M=1:1:10 S N(M)=$J(N(M),0,2)
37 S:N(1) TQ2=TQ2+1
38 S:N(2) TQ3=TQ3+1
39 ; Store data of each 4 Quarters in T1(2)-T1(5) and Total in TO.
40 S K=0 F I=3:1:10 S K=K+1,$P(T1(QTR+1),"^",K)=$S(N(I):N(I),1:"")
41 S $P(T1(QTR+1),"^",9)=$S(N(2):N(2),1:""),$P(T1(QTR+1),"^",10)=$S(N(1):N(1),1:"")
42 F L=1:1:10 S $P(TO,"^",L)=$P(TO,"^",L)+$P(T1(QTR+1),"^",L)
43 ; Calculate and store Percent Cost and after T1 Cost Strg.
44 F I=6:1:10 S $P(PER(QTR),"^",I)=$S(+$P(T1(QTR+1),"^",10)'<1:$P(T1(QTR+1),"^",I)/$P(T1(QTR+1),"^",10)*100,1:"")
45 Q
46PRT ; Print Avg Cost Per Meal, Cost Per Diem, and the YTD
47 S $P(T1(1),"^",5)=$S(TQ1:$P(T1(1),"^",5)/TQ1,1:"")
48 D:$Y'<(LIN-9) HDR^FHADRPT D HD,HDR
49 W ?35 F L=1:1:4 W " ",$S($P(T1(1),"^",L):$J($P(T1(1),"^",L),8,2),1:$J("",8))_$J("",11)
50 W $S($P(T1(1),"^",5):$J($P(T1(1),"^",5),8,2),1:$J("",8))
51 D HDR1
52 F L=6:1:10 S $P(TP,"^",L)=$S(+$P(TO,"^",10)'<1:$P(TO,"^",L)/$P(TO,"^",10)*100,1:"")
53 S K=1
54 S I=2 F TIT="Tech (1019)","Dietitians (1018)","Wageboard (1008)","Clerical (1002)","Other" S TQ4=TQ2 D LOOP
55 S X="Total Personal Cost" S K1=9 D LAST
56 S I=0,K=6 F TIT="Subsistence (2610)","Operating Supp (2660)","All Other" S TQ4=TQ3 D LOOP
57 S X="Total" S K1=10 D LAST
58 Q
59LAST ; Print the Last Line
60 S TQ4=""
61 W !,X,?29 F I=1:1:4 D
62 .S X=$S($P(T1(I+1),"^",K1):$P(T1(I+1),"^",K1),1:"")
63 .S:X TQ4=TQ4+1
64 .W $S(X:$J(X,9,2),1:$J("",9))_" "
65 .W $S($P(PER(I),"^",K1):$J($P(PER(I),"^",K1),8,2),1:$J("",8))_" "
66 .Q
67 W ?110 S X=$S($P(TO,"^",K1):$P(TO,"^",K1),1:""),X=$J($S(TQ4:X/TQ4,1:""),0,2)
68 W $S(X:$J(X,9,2),1:$J("",9))_" "
69 W $S($P(TP,"^",K1):$J($P(TP,"^",K1),8,2),1:$J("",8))
70 Q
71LOOP ; Print title for each row along with the cost of the quarters.
72 W ! W:I ?I W TIT,?29
73 F J=1:1:4 D
74 .S X=$S($P(T1(J+1),"^",K):$P(T1(J+1),"^",K),1:"")
75 .W $S(X:$J(X,9,2),1:$J("",9))_" "
76 .W $S($P(PER(J),"^",K):$J($P(PER(J),"^",K),8,2),1:$J("",8))_" "
77 .Q
78 W ?110 S X=$S($P(TO,"^",K):$P(TO,"^",K),1:""),X=$J($S(TQ4:X/TQ4,1:""),0,2)
79 W $S(X:$J(X,9,2),1:$J("",9))_" "
80 W $S($P(TP,"^",K):$J($P(TP,"^",K),8,2),1:$J("",8))
81 S K=K+1
82 Q
83HD W !!!!,"S E C T I O N V D I E T E T I C C O S T" Q
84HDR ; Print Cost Per Meal Hdg
85 W !!!!,"COST PER MEAL"
86 W ?37,"1st Qtr",?57,"2nd Qtr",?77,"3rd Qtr",?97,"4th Qtr",?120,"YTD"
87 W !!,"Average Cost Per Meal"
88 Q
89HDR1 ; Print Cost Per Diem Hdg
90 D:$Y'<(LIN-15) HDR^FHADRPT,HD
91 W !!!!,"COST PER DIEM"
92 W ?37,"1st Qtr",?57,"2nd Qtr",?77,"3rd Qtr",?97,"4th Qtr",?120,"YTD"
93 W !,?34,"Cost",?41,"% Cost",?54,"Cost",?61,"% Cost",?74,"Cost",?81,"% Cost",?94,"Cost",?101,"% Cost",?112,"Avg Tot",?122,"% Cost"
94 W !,"Personal Services" Q
Note: See TracBrowser for help on using the repository browser.