source: WorldVistAEHR/trunk/r/DIETETICS-FH/FHNO6.m@ 1270

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

initial load of WorldVistAEHR
File size: 9.4 KB
RevLine 
[613]1FHNO6 ; HISC/REL/NCA - Supplemental Feeding Costs ;2/13/95 13:32
2 ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
3 ;3/7/06 -P5- added outpatient SFs.
4 W @IOF,!!?27,"SUPPLEMENTAL FEEDING COSTS",!!
5D0 R !!,"Select by S=SUPPLEMENTAL FEEDING SITE or W=WARD: ",XX:DTIME G:'$T!("^"[XX) KIL
6 I XX'?1U!("SW"'[XX) W *7," Enter S or W" G D0
7 I XX="S" S WRD=$O(^FH(119.74,0)) I WRD'<1,$O(^FH(119.74,WRD))<1 G S0
8 I XX="W" S WRD=$O(^FH(119.6,0)) I WRD'<1,$O(^FH(119.6,WRD))<1 G S0
9 I XX="S" G D2
10F1 R !!,"Select WARD (or ALL): ",X:DTIME G:'$T!("^"[X) KIL I X="ALL" S WRD=0
11 E K DIC S DIC="^FH(119.6,",DIC(0)="EQM" D ^DIC G:Y<1 F1 S WRD=+Y
12 G S0
13D2 R !!,"Select SUPPLEMENTAL FEEDING SITE (or ALL): ",X:DTIME G:'$T!("^"[X) KIL I X="ALL" S WRD=0
14 I X'="ALL" K DIC S DIC="^FH(119.74,",DIC(0)="EMQ" D ^DIC G:Y<1 D2 S WRD=+Y
15S0 S X="N" I 'WRD R !!,"SUMMARY only? Y// ",X:DTIME G:'$T!(X="^") KIL S:X="" X="Y" I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Answer YES or NO" G S0
16 S SUM=X?1"Y".E
17L0 W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
18 I $D(IO("Q")) S FHPGM="Q1^FHNO6",FHLST="XX^WRD^SUM" D EN2^FH G KIL
19 U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
20Q1 ; Print Supplemental Feeding Cost Report
21 S (FHSUMHD,FHSUM)=0 D NOW^%DTC S DTP=% D DTP^FH S PTIM=DTP,PG=0 K ^TMP($J)
22 I 'SUM,'WRD S FHSUM=1
23 F KK=0:0 S KK=$O(^FH(119.6,KK)) Q:KK<1 S X0=$G(^(KK,0)) D
24 .I XX="W",WRD,WRD'=KK Q
25 .I XX="S",WRD,$P(X0,"^",9)'=WRD Q
26 .S P0=$P(X0,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0),TNOD=$S(SUM:"0",XX="S":"99~"_$P($G(^FH(119.74,+$P(X0,"^",9),0)),"^",1),1:P0_"~"_$P(X0,"^",1))
27 .F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",KK,FHDFN)) Q:FHDFN<1 S ADM=$G(^FHPT("AW",KK,FHDFN)) I ADM>0 D
28 ..S $P(^TMP($J,"T",TNOD,0),"^",1)=$P($G(^TMP($J,"T",TNOD,0)),"^",1)+1
29 ..I FHSUM S $P(^TMP($J,"FH","GRAND TOTAL",0),"^",1)=$P($G(^TMP($J,"FH","GRAND TOTAL",0)),"^",1)+1
30 ..S (NO,Y)="" I $D(^FHPT(FHDFN,"A",ADM,0)) S NO=$P(^(0),"^",7)
31 ..Q:'NO S Y=$G(^FHPT(FHDFN,"A",ADM,"SF",NO,0))
32 ..S PD=$P(Y,"^",29) S:PD="" PD="D"
33 ..S $P(^TMP($J,"T",TNOD,0),"^",PD'="D"+2)=$P(^TMP($J,"T",TNOD,0),"^",PD'="D"+2)+1
34 ..I FHSUM S $P(^TMP($J,"FH","GRAND TOTAL",0),"^",PD'="D"+2)=$P(^TMP($J,"FH","GRAND TOTAL",0),"^",PD'="D"+2)+1
35 ..F L=5:2:28 S Z=$P(Y,"^",L),Q=$P(Y,"^",L+1) I Z'="" S:'Q Q=1 S:'$D(^TMP($J,"T",TNOD,Z,PD)) ^TMP($J,"T",TNOD,Z,PD)=0 S ^(PD)=^(PD)+Q I FHSUM D
36 ...S:'$D(^TMP($J,"FH","GRAND TOTAL",Z,PD)) ^TMP($J,"FH","GRAND TOTAL",Z,PD)=0 S ^(PD)=^(PD)+Q
37 ..Q
38 .Q
39 ;
40 S NAM="" F S NAM=$O(^FH(118,"B",NAM)) Q:NAM="" F Z=0:0 S Z=$O(^FH(118,"B",NAM,Z)) Q:Z<1 I $O(^(Z,0))="" S REC=$P($G(^FH(118,Z,0)),"^",7),CU=$P($G(^FH(114,+REC,0)),"^",13),^TMP($J,"P",NAM_"~"_Z)=CU
41 S TNOD="" F S TNOD=$O(^TMP($J,"T",TNOD)) Q:TNOD="" D
42 .S FHOUT=0
43 .Q:$O(^TMP($J,"T",TNOD,0))="" D HDR S (T1,T2)=0
44 .S NAM="" F S NAM=$O(^TMP($J,"P",NAM)) Q:NAM="" S CU=^(NAM) D
45 ..S Z=$P(NAM,"~",2) I '$D(^TMP($J,"T",TNOD,Z)) Q
46 ..S A1=$G(^TMP($J,"T",TNOD,Z,"D")),A2=$G(^("T")),T1=A1*CU+T1,T2=A2*CU+T2 D:$Y>(IOSL-8) HDR
47 ..W !,$E($P(NAM,"~",1),1,24),?25,$J(CU,7,3),$J(A1,7),$J(A1*CU,8,2),$J(A2,8),$J(A2*CU,8,2),$J(A1+A2,8),$J(A1+A2*CU,8,2) Q
48 .D:$Y>(IOSL-13) HDR W !!,"Total",?39,$J(T1,8,2),$J(T2,16,2),$J(T1+T2,16,2)
49 .S CTR=$G(^TMP($J,"T",TNOD,0)),WP=$P(CTR,"^",1),WPD=$P(CTR,"^",2),WPT=$P(CTR,"^",3)
50 .W !!,"Cost/Patient:",?32,$J(WP,7),?39,$J(T1/WP,8,2),?47,$J(WP,8),?55,$J(T2/WP,8,2),?63,$J(WP,8),?71,$J(T1+T2/WP,8,2)
51 .W !,"Cost/Recipient:" W:WPD ?32,$J(WPD,7),?39,$J(T1/WPD,8,2) W:WPT ?47,$J(WPT,8),?55,$J(T2/WPT,8,2) W:(WPD+WPT) ?63,$J(WPD+WPT,8),?71,$J(T1+T2/(WPD+WPT),8,2)
52 .W !!,"Recipient %:" W:WPD ?39,$J(WPD/WP*100,8,0) W:WPT ?55,$J(WPT/WP*100,8,0) W:(WPD+WPT) ?71,$J(WPD+WPT/WP*100,8,0) W ! Q
53 I FHSUM D GRD
54 ;
55SFO ;process outpt SFs.
56 K ^TMP($J) S (FHSUM,FHSUMHD)=0
57 S FHDFNSV="",FHOUT=1
58 I 'SUM,'WRD S FHSUM=1
59 F FHI=DT-1:0 S FHI=$O(^FHPT("RM",FHI)) Q:(FHI'>0)!(FHI>DT) F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",FHI,FHDFN)) Q:FHDFN'>0 D
60 .F FHJ=0:0 S FHJ=$O(^FHPT("RM",FHI,FHDFN,FHJ)) Q:FHJ'>0 I ($P($G(^FHPT(FHDFN,"OP",FHJ,0)),U,15)'="C") D
61 ..S FHDA15=$G(^FHPT(FHDFN,"OP",FHJ,0))
62 ..S FHMEAL=$P(FHDA15,U,4),FHLOC=$P(FHDA15,U,3) Q:'$G(FHLOC)
63 ..S FHLOX0=$G(^FH(119.6,FHLOC,0))
64 ..I XX="W",WRD,WRD'=FHLOC Q
65 ..I XX="S",WRD,$P(FHLOX0,"^",9)'=WRD Q
66 ..S P0=$P(FHLOX0,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0),TNOD=$S(SUM:"0",XX="S":"99~"_$P($G(^FH(119.74,+$P(FHLOX0,"^",9),0)),"^",1),1:P0_"~"_$P(FHLOX0,"^",1))
67 ..;I FHDFNSV'=FHDFN S $P(^TMP($J,"T",TNOD,0),"^",1)=$P($G(^TMP($J,"T",TNOD,0)),"^",1)+1
68 ..S $P(^TMP($J,"T",TNOD,0),"^",1)=$P($G(^TMP($J,"T",TNOD,0)),"^",1)+1
69 ..I FHSUM S $P(^TMP($J,"FH","GRAND TOTAL",0),"^",1)=$P($G(^TMP($J,"FH","GRAND TOTAL",0)),"^",1)+1
70 ..S:$D(^FHPT(FHDFN,"OP",FHJ,"SF",0)) FHSF=$P(^FHPT(FHDFN,"OP",FHJ,"SF",0),U,3)
71 ..Q:'$G(FHSF)
72 ..S FHDA15SF=$G(^FHPT(FHDFN,"OP",FHJ,"SF",FHSF,0))
73 ..Q:$P(FHDA15SF,U,32)
74 ..S PD=$P(FHDA15SF,"^",29) S:PD="" PD="D"
75 ..;S $P(^TMP($J,"T",TNOD,0),"^",1)=$P($G(^TMP($J,"T",TNOD,0)),"^",1)+1
76 ..S $P(^TMP($J,"T",TNOD,0),"^",PD'="D"+2)=$P(^TMP($J,"T",TNOD,0),"^",PD'="D"+2)+1
77 ..I FHSUM S $P(^TMP($J,"FH","GRAND TOTAL",0),"^",PD'="D"+2)=$P(^TMP($J,"FH","GRAND TOTAL",0),"^",PD'="D"+2)+1
78 ..F L=5:2:28 S Z=$P(FHDA15SF,"^",L),Q=$P(FHDA15SF,"^",L+1) I Z'="" S:'Q Q=1 S:'$D(^TMP($J,"T",TNOD,Z,PD)) ^TMP($J,"T",TNOD,Z,PD)=0 S ^(PD)=^(PD)+Q I FHSUM D
79 ...S:'$D(^TMP($J,"FH","GRAND TOTAL",Z,PD)) ^TMP($J,"FH","GRAND TOTAL",Z,PD)=0 S ^(PD)=^(PD)+Q
80 ..S FHDFNSV=FHDFN
81 ;
82 S NAM="" F S NAM=$O(^FH(118,"B",NAM)) Q:NAM="" F Z=0:0 S Z=$O(^FH(118,"B",NAM,Z)) Q:Z<1 I $O(^(Z,0))="" S REC=$P($G(^FH(118,Z,0)),"^",7),CU=$P($G(^FH(114,+REC,0)),"^",13),^TMP($J,"P",NAM_"~"_Z)=CU
83 S TNOD="" F S TNOD=$O(^TMP($J,"T",TNOD)) Q:TNOD="" D
84 .Q:$O(^TMP($J,"T",TNOD,0))="" D HDR S (T1,T2)=0
85 .S NAM="" F S NAM=$O(^TMP($J,"P",NAM)) Q:NAM="" S CU=^(NAM) D
86 ..S Z=$P(NAM,"~",2) I '$D(^TMP($J,"T",TNOD,Z)) Q
87 ..S A1=$G(^TMP($J,"T",TNOD,Z,"D")),A2=$G(^("T")),T1=A1*CU+T1,T2=A2*CU+T2 D:$Y>(IOSL-8) HDR
88 ..W !,$E($P(NAM,"~",1),1,24),?25,$J(CU,7,3),$J(A1,7),$J(A1*CU,8,2),$J(A2,8),$J(A2*CU,8,2),$J(A1+A2,8),$J(A1+A2*CU,8,2) Q
89 .D:$Y>(IOSL-13) HDR W !!,"Total",?39,$J(T1,8,2),$J(T2,16,2),$J(T1+T2,16,2)
90 .S CTR=$G(^TMP($J,"T",TNOD,0)),WP=$P(CTR,"^",1),WPD=$P(CTR,"^",2),WPT=$P(CTR,"^",3)
91 .W !!,"SF Cost/Patient Meal:",?32,$J(WP,7),?39,$J(T1/WP,8,2),?47,$J(WP,8),?55,$J(T2/WP,8,2),?63,$J(WP,8),?71,$J(T1+T2/WP,8,2)
92 .W !,"SF Cost/Recipient Meal:" W:WPD ?32,$J(WPD,7),?39,$J(T1/WPD,8,2) W:WPT ?47,$J(WPT,8),?55,$J(T2/WPT,8,2) W:(WPD+WPT) ?63,$J(WPD+WPT,8),?71,$J(T1+T2/(WPD+WPT),8,2)
93 .W !!,"Recipient Meal %:" W:WPD ?39,$J(WPD/WP*100,8,0) W:WPT ?55,$J(WPT/WP*100,8,0) W:(WPD+WPT) ?71,$J(WPD+WPT/WP*100,8,0) W ! Q
94 I FHSUM D OGRD
95 Q
96GRD S NAM="" F S NAM=$O(^FH(118,"B",NAM)) Q:NAM="" F Z=0:0 S Z=$O(^FH(118,"B",NAM,Z)) Q:Z<1 I $O(^(Z,0))="" S REC=$P($G(^FH(118,Z,0)),"^",7),CU=$P($G(^FH(114,+REC,0)),"^",13),^TMP($J,"P",NAM_"~"_Z)=CU
97 S FHSUMHD=1
98 S TNOD="" F S TNOD=$O(^TMP($J,"FH",TNOD)) Q:TNOD="" D
99 .S FHOUT=0
100 .Q:$O(^TMP($J,"FH",TNOD,0))="" D HDR S (T1,T2)=0
101 .S NAM="" F S NAM=$O(^TMP($J,"P",NAM)) Q:NAM="" S CU=^(NAM) D
102 ..S Z=$P(NAM,"~",2) I '$D(^TMP($J,"FH",TNOD,Z)) Q
103 ..S A1=$G(^TMP($J,"FH",TNOD,Z,"D")),A2=$G(^("T")),T1=A1*CU+T1,T2=A2*CU+T2 D:$Y>(IOSL-8) HDR
104 ..W !,$E($P(NAM,"~",1),1,24),?25,$J(CU,7,3),$J(A1,7),$J(A1*CU,8,2),$J(A2,8),$J(A2*CU,8,2),$J(A1+A2,8),$J(A1+A2*CU,8,2) Q
105 .D:$Y>(IOSL-13) HDR W !!,"Grand Total",?39,$J(T1,8,2),$J(T2,16,2),$J(T1+T2,16,2)
106 .S CTR=$G(^TMP($J,"FH",TNOD,0)),WP=$P(CTR,"^",1),WPD=$P(CTR,"^",2),WPT=$P(CTR,"^",3)
107 .W !!,"Cost/Patient:",?32,$J(WP,7),?39,$J(T1/WP,8,2),?47,$J(WP,8),?55,$J(T2/WP,8,2),?63,$J(WP,8),?71,$J(T1+T2/WP,8,2)
108 .W !,"Cost/Recipient:" W:WPD ?32,$J(WPD,7),?39,$J(T1/WPD,8,2) W:WPT ?47,$J(WPT,8),?55,$J(T2/WPT,8,2) W:(WPD+WPT) ?63,$J(WPD+WPT,8),?71,$J(T1+T2/(WPD+WPT),8,2)
109 .W !!,"Recipient %:" W:WPD ?39,$J(WPD/WP*100,8,0) W:WPT ?55,$J(WPT/WP*100,8,0) W:(WPD+WPT) ?71,$J(WPD+WPT/WP*100,8,0) W ! Q
110 Q
111 ;
112OGRD S NAM="" F S NAM=$O(^FH(118,"B",NAM)) Q:NAM="" F Z=0:0 S Z=$O(^FH(118,"B",NAM,Z)) Q:Z<1 I $O(^(Z,0))="" S REC=$P($G(^FH(118,Z,0)),"^",7),CU=$P($G(^FH(114,+REC,0)),"^",13),^TMP($J,"P",NAM_"~"_Z)=CU
113 S FHSUMHD=1
114 S TNOD="" F S TNOD=$O(^TMP($J,"FH",TNOD)) Q:TNOD="" D
115 .Q:$O(^TMP($J,"FH",TNOD,0))="" D HDR S (T1,T2)=0
116 .S NAM="" F S NAM=$O(^TMP($J,"P",NAM)) Q:NAM="" S CU=^(NAM) D
117 ..S Z=$P(NAM,"~",2) I '$D(^TMP($J,"FH",TNOD,Z)) Q
118 ..S A1=$G(^TMP($J,"FH",TNOD,Z,"D")),A2=$G(^("T")),T1=A1*CU+T1,T2=A2*CU+T2 D:$Y>(IOSL-8) HDR
119 ..W !,$E($P(NAM,"~",1),1,24),?25,$J(CU,7,3),$J(A1,7),$J(A1*CU,8,2),$J(A2,8),$J(A2*CU,8,2),$J(A1+A2,8),$J(A1+A2*CU,8,2) Q
120 .D:$Y>(IOSL-13) HDR W !!,"Grand Total",?39,$J(T1,8,2),$J(T2,16,2),$J(T1+T2,16,2)
121 .S CTR=$G(^TMP($J,"FH",TNOD,0)),WP=$P(CTR,"^",1),WPD=$P(CTR,"^",2),WPT=$P(CTR,"^",3)
122 .W !!,"SF Cost/Patient Meal:",?32,$J(WP,7),?39,$J(T1/WP,8,2),?47,$J(WP,8),?55,$J(T2/WP,8,2),?63,$J(WP,8),?71,$J(T1+T2/WP,8,2)
123 .W !,"SF Cost/Recipient Meal:" W:WPD ?32,$J(WPD,7),?39,$J(T1/WPD,8,2) W:WPT ?47,$J(WPT,8),?55,$J(T2/WPT,8,2) W:(WPD+WPT) ?63,$J(WPD+WPT,8),?71,$J(T1+T2/(WPD+WPT),8,2)
124 .W !!,"Recipient Meal %:" W:WPD ?39,$J(WPD/WP*100,8,0) W:WPT ?55,$J(WPT/WP*100,8,0) W:(WPD+WPT) ?71,$J(WPD+WPT/WP*100,8,0) W ! Q
125 Q
126 ;
127HDR ; Print Header
128 W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1
129 W !,PTIM,!!?11,"S U P P L E M E N T A L F E E D I N G C O S T S",?73,"Page ",PG
130 W !!,$S(FHOUT=1:"***OUTPATIENT***",1:"***INPATIENT***")
131 I 'FHSUMHD S Y=$S(SUM:"CONSOLIDATED",1:$P(TNOD,"~",2)) W ?(80-$L(Y)\2),Y
132 I FHSUMHD S Y="GRAND TOTAL" W ?(80-$L(Y)\2),Y
133 W !!?38,"DIETARY",?52,"THERAPEUTIC",?71,"TOTAL",!,"Supplemental Feeding",?28,"Cost Qty Total Qty Total Qty Total",! Q
134KIL K ^TMP($J) G KILL^XUSCLEAN
Note: See TracBrowser for help on using the repository browser.