source: FOIAVistA/tag/r/DIETETICS-FH/FHPRO2.m@ 1219

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

initial load of FOIAVistA 6/30/08 version
File size: 7.6 KB
Line 
1FHPRO2 ; HISC/REL/NCA/RVD - Forecast/Census Calculations ;1/23/98 16:10
2 ;;5.5;DIETETICS;**3**;Jan 28, 2005
3 ;RVD 5/17/05 - as part of AFP project.
4 ;if date is range, save all the value of DOW for every day in fhdodt.
5 S FHD1SAV=D1
6 F FHDTI=1:1 S X1=FHD1SAV,X2=FHDTI-1 D C^%DTC Q:FHDTI'>0!(X>FHDT2) D
7 .D DOW^%DTC S FHDODT(FHDTI)=Y+1,FHDODAY(FHDTI)=X
8 S X=D1 D DOW^%DTC S (FHDOWSV,DOW)=Y+1
9 S DTP=D1\1 D DTP^FH S FHDSTART=DTP,DTP=FHDT2\1 D DTP^FH S FHDTSTOP=DTP
10 S FHSTARTD=$P("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR","^",DOW)
11 S X=FHDT2 D DOW^%DTC S DOW=Y+1
12 S FHSTOPDT=$P("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR","^",DOW)
13 S DOW=FHDOWSV
14 S X1=FHDT2,X2=D1 D ^%DTC S FHNUMDAY=X+1 ;number of days fr start to end
15 D NOW^%DTC S NOW=%,PG=0
16 S FHMLSAV=MEAL
17 D DATE^FHPRO4
18 ;I (MEAL="B")!(MEAL="N")!(MEAL="E") D Q2 D:FHP8["Y" P3^FHPRO7 D AFP^FHPRO6 D:FHP9["Y" AAR^FHPRO7 Q
19 F FHMEAL="B","N","E" S MEAL=FHMEAL D Q2
20 D:FHP8["Y" P3^FHPRO7 D:FHP10["Y" AFP^FHPRO6 D:FHP9["Y" AAR^FHPRO7
21 Q
22Q2 S K3=$F("BNE",MEAL)-1 ;FHX1=$P(FHDA,"^",K3+1) Q:'FHX1
23 Q:'$D(FHMEALAR(MEAL))
24 D CEN:FHP6["C",FOR:FHP6["F",LIS
25 G ^FHPRO3
26FOR ; Calculate for Forecast
27 K ^TMP($J,"FH"),^TMP($J,"FHD") ;F P0=0:0 S P0=$O(M2(P0)) Q:P0<1 S ^TMP($J,"FH",P0)=M2(P0)
28 K D F P0=0:0 S P0=$O(M2(P0)) Q:P0<1 S S1=M2(P0) D PER S ^TMP($J,"FH",P0)=S0
29 F P0=0:0 S P0=$O(^TMP($J,"FH",P0)) Q:P0<1 I $D(^FH(119.72,P0,"B")) D F1
30 F LL=0:0 S LL=$O(D(LL)) Q:LL<1 S ^TMP($J,"FH",0,LL)=D(LL)
31 K D Q
32F1 F LL=0:0 S LL=$O(^FH(119.72,P0,"B",LL)) Q:LL<1 D
33 .F FHDDI=0:0 S FHDDI=$O(FHDODT(FHDDI)) Q:FHDDI'>0 D
34 ..S FHDDIDO=FHDODT(FHDDI)
35 ..S FHPX1=FHDODAY(FHDDI)
36 ..Q:'$D(FHMEALAR(MEAL,FHPX1)) ;meal is not for certain date.
37 ..S Y=$P(^FH(119.72,P0,"B",LL,0),"^",3*FHDDIDO-2+K3)
38 ..I Y>0 S D(LL)=$G(D(LL))+Y,^TMP($J,"FH",P0)=^TMP($J,"FH",P0)+Y,^TMP($J,"FH",P0,LL)=$G(^TMP($J,"FH",P0,LL))+Y
39 ..I Y>0 S:'$D(^TMP($J,"FHD",FHPX1,P0,LL)) ^TMP($J,"FHD",FHPX1,P0,LL)=0 S ^TMP($J,"FHD",FHPX1,P0,LL)=^TMP($J,"FHD",FHPX1,P0,LL)+Y
40 Q
41PER S S0=0 F K=0:0 S K=$O(^FH(119.72,P0,"A",K)) Q:K<1 D
42 .S ^TMP($J,"FH",P0,K)=0,D(K)=0
43 .F FHDDI=0:0 S FHDDI=$O(FHDODT(FHDDI)) Q:FHDDI'>0 D
44 ..S FHDDIDO=FHDODT(FHDDI)
45 ..S FHPX1=FHDODAY(FHDDI)
46 ..S Z=$P(^FH(119.72,P0,"A",K,0),"^",FHDDIDO+1)
47 ..S FHS1=$P(S1,"^",FHDDI)
48 ..S Z=$J(Z*FHS1/100,0,0)
49 ..I Z S ^TMP($J,"FH",P0,K)=^TMP($J,"FH",P0,K)+Z,S0=S0+Z,D(K)=$G(D(K))+Z
50 ..I Z S:'$D(^TMP($J,"FHD",FHPX1,P0,K)) ^TMP($J,"FHD",FHPX1,P0,K)=0 S ^TMP($J,"FHD",FHPX1,P0,K)=^TMP($J,"FHD",FHPX1,P0,K)+Z
51 Q
52LIS ;print listing
53 Q:'$D(FHMEALAR(MEAL))
54 S (FHRETYP,FHW1NM,FHSITENM)=""
55 I $G(FHSITE),$D(^FH(119.73,FHSITE,0)) S FHSITENM=$P(^FH(119.73,FHSITE,0),U,1)
56 S:$G(FHSITE) FHRETYP="Comm Office: "_FHSITENM
57 S:'$G(FHSITE) FHRETYP="Consolidated"
58 I FHSTARTD'=FHSTOPDT D
59 .S TIM=FHSTARTD_"DAY "_FHDSTART_" to "_FHSTOPDT_"DAY "_FHDTSTOP_" "_$P("BREAKFAST^NOON^EVENING","^",K3)
60 .S TIMAFP=FHSTARTD_"DAY "_FHDSTART_" to "_FHSTOPDT_"DAY "_FHDTSTOP
61 I FHSTARTD=FHSTOPDT D
62 .S TIM=FHSTARTD_"DAY "_FHDSTART_" "_$P("BREAKFAST^NOON^EVENING","^",K3)
63 .S TIMAFP=FHSTARTD_"DAY "_FHDSTART
64 ;S:FHSTARTD'=FHSTOPDT TIM=FHSTARTD_"DAY "_FHDSTART_" to "_FHSTOPDT_"DAY "_FHDTSTOP_" "_$P("BREAKFAST^NOON^EVENING","^",K3)
65 ;S:FHSTARTD=FHSTOPDT TIM=FHSTARTD_"DAY "_FHDSTART_" "_$P("BREAKFAST^NOON^EVENING","^",K3)
66 S TIMAFP=TIMAFP_" ( "_FHMEALHE_" )"
67 S DTP=NOW D DTP^FH
68 K S,D,N S L1=38
69 F P0=0:0 S P0=$O(^TMP($J,"FH",P0)) Q:P0="" S X=^FH(119.72,P0,0),N1=$P(X,"^",1),N2=$P(X,"^",2),N3=$P(X,"^",4) S:N3="" N3=$E(N1,1,6) S S(N3,P0)=$J(N3,8)_"^"_N2,L1=L1+14
70 S:L1<80 L1=80
71 S Z=$S(FHP6["F":"F O R E C A S T E D",1:"A C T U A L")_" D I E T C E N S U S"
72 W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1
73 S DTP=NOW D DTP^FH W !,DTP,?(L1-$L(Z)\2),Z,?(L1-7),"Page ",PG
74 W !,FHRETYP
75 S Z=$P(^FH(119.71,FHP,0),"^",1)
76 W !?(L1-$L(Z)\2),Z,!!?(L1-$L(TIM)\2),TIM
77 W !!?(L1-31\2),"P R O D U C T I O N D I E T S",!!?29
78 S X="" F S X=$O(S(X)) Q:X="" F K=0:0 S K=$O(S(X,K)) Q:K="" W $P(S(X,K),"^",1)
79 W " Total" S LN="",$P(LN,"-",L1+1)="" W !,LN,! K LN
80 F P1=0:0 S P1=$O(^FH(116.2,"AP",P1)) Q:P1<1 F K=0:0 S K=$O(^FH(116.2,"AP",P1,K)) Q:K<1 I $D(^TMP($J,"FH",0,K)) D PRO
81 I FHP6["C" W !?3,"N P O",?31 S K=.5 D P1 K NP(.5)
82 I FHP6["C" W !?3,"P A S S",?31 S K=.8 D P1 K NP(.8)
83 I FHP6["C" W !?3,"TF Only",?31 S K=.7 D P1 K NP(.7)
84 I FHP6["C" W !?3,"No Order",?31 S K=.6 D P1 K NP(.6)
85 W !!,"TOTAL MEALS",?31 S TOT=""
86 S X="" F S X=$O(S(X)) Q:X="" F K1=0:0 S K1=$O(S(X,K1)) Q:K1="" D
87 .S Z=$G(^TMP($J,"FH",K1)) S:Z TOT=TOT+Z W $J(Z,6)," "
88 W $J(TOT,7) Q
89 W !!!,"*** Includes other gratuitous/paid meals.",! K S,D,N,P Q
90PRO W !,$P($G(^FH(116.2,K,0)),"^",1),?31
91P1 S (TOT,X)="" F S X=$O(S(X)) Q:X="" F K1=0:0 S K1=$O(S(X,K1)) Q:K1="" D
92 .S Z=$S(K>.9:$G(^TMP($J,"FH",K1,K)),1:$G(NP(K,K1)))
93 .S:Z TOT=TOT+Z W $J(Z,6)," "
94 W $J(TOT,7) Q
95CEN ; Calculate for Census
96 K ^TMP($J,"FH"),^TMP($J,"FHD")
97 S X=D1_"@"_$S(MEAL="B":"7AM",MEAL="N":"11AM",1:"4PM"),%DT="TX" D ^%DT S TIM=Y
98 K D,P F WRD=0:0 S WRD=$O(^FH(119.6,WRD)) Q:WRD<1 S X=^(WRD,0) D
99 .I $G(FHSITE),($P(X,U,8)'=FHSITE) Q
100 .S FHSERFLG=0
101 .S FHSER=$P(X,U,5) S:$G(FHSER) SP(FHSER)="" I $G(FHSER),$D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)=FHP S FHSERFLG=1
102 .S FHSER=$P(X,U,6) S:$G(FHSER) SP(FHSER)="" I $G(FHSER),$D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)=FHP S FHSERFLG=1
103 .Q:'$G(FHSERFLG)
104 .I '$G(FHSITE) D WRD^FHORD9 Q
105 .I $G(FHSITE),$P(X,U,8)=FHSITE D WRD^FHORD9
106 S FHDTOT=0
107 F FHIJ=0:0 S FHIJ=$O(FHMEALAR(MEAL,FHIJ)) Q:FHIJ'>0 D
108 .S FHDTOT=FHDTOT+1
109 .F FHI=0:0 S FHI=$O(P(FHI)) Q:FHI'>0 F FHJ=0:0 S FHJ=$O(P(FHI,FHJ)) Q:FHJ'>0 D
110 ..Q:FHI<1
111 ..S:'$D(^TMP($J,"FHD",FHIJ,FHJ,FHI)) ^TMP($J,"FHD",FHIJ,FHJ,FHI)=0
112 ..S ^TMP($J,"FHD",FHIJ,FHJ,FHI)=^TMP($J,"FHD",FHIJ,FHJ,FHI)+P(FHI,FHJ)
113 ;
114 F FHI=0:0 S FHI=$O(P(FHI)) Q:FHI'>0 F FHJ=0:0 S FHJ=$O(P(FHI,FHJ)) Q:FHJ'>0 D
115 .I P(FHI,FHJ)>0 S P(FHI,FHJ)=P(FHI,FHJ)*FHDTOT
116 ;go proccess outpatient data
117 D OUT^FHPRO3
118 ;
119COMB ;
120 K D,NP,T F LP=0:0 S LP=$O(P(.5,LP)) Q:LP<1 S:'$D(NP(.5,LP)) NP(.5,LP)=0 S NP(.5,LP)=NP(.5,LP)+P(.5,LP) S:'$D(D(LP)) D(LP)=0 S D(LP)=D(LP)+P(.5,LP)
121 K P(.5) F LP=0:0 S LP=$O(P(.7,LP)) Q:LP<1 S:'$D(NP(.7,LP)) NP(.7,LP)=0 S NP(.7,LP)=NP(.7,LP)+P(.7,LP) S:'$D(D(LP)) D(LP)=0 S D(LP)=D(LP)+P(.7,LP)
122 K P(.7) F LL=0:0 S LL=$O(P(.6,LL)) Q:LL<1 S:'$D(NP(.6,LL)) NP(.6,LL)=0 S NP(.6,LL)=NP(.6,LL)+P(.6,LL)
123 K P(.6) F LL=0:0 S LL=$O(P(.8,LL)) Q:LL<1 S:'$D(NP(.8,LL)) NP(.8,LL)=0 S NP(.8,LL)=NP(.8,LL)+P(.8,LL) S:'$D(D(LL)) D(LL)=0 S D(LL)=D(LL)+P(.8,LL)
124 K P(.8) F LL=0:0 S LL=$O(P(LL)) Q:LL<1 F P0=0:0 S P0=$O(P(LL,P0)) Q:P0<1 S:'$D(T(P0)) T(P0)=0 S T(P0)=T(P0)+P(LL,P0)
125 F LP=0:0 S LP=$O(NP(.6,LP)) Q:LP<1 S:$D(T(LP)) NP(.6,LP)=NP(.6,LP)-T(LP)-$G(D(LP)) S:'$D(D(LP)) D(LP)=0 S D(LP)=D(LP)+NP(.6,LP)
126 F P0=0:0 S P0=$O(^FH(119.72,P0)) Q:P0<1 I $P(^(P0,0),"^",3)=FHP I $D(^FH(119.72,P0,"B")) D D0
127 K ^TMP($J,"FH") F LL=0:0 S LL=$O(P(LL)) Q:LL<1 S P(LL,0)=0 F P0=0:0 S P0=$O(P(LL,P0)) Q:P0<1 S ^TMP($J,"FH",P0,LL)=P(LL,P0) S:'$D(D(P0)) D(P0)="" S D(P0)=D(P0)+P(LL,P0),P(LL,0)=P(LL,0)+P(LL,P0)
128 F P0=0:0 S P0=$O(D(P0)) Q:P0<1 S ^TMP($J,"FH",P0)=D(P0)
129 F LL=0:0 S LL=$O(P(LL)) Q:LL<1 I $G(P(LL,0)) S ^TMP($J,"FH",0,LL)=P(LL,0)
130 K P,D Q
131D0 ;
132 I '$D(SP(P0)) Q
133 I $G(^FH(119.72,P0,"I"))="Y" Q
134 ;get all the AO for all dates being asked.
135 F LL=0:0 S LL=$O(^FH(119.72,P0,"B",LL)) Q:LL<1 F FHDOII=0:0 S FHDOII=$O(FHDODAY(FHDOII)) Q:FHDOII'>0 D
136 .S (FHDOD1,X)=FHDODAY(FHDOII) D DOW^%DTC S DOW=Y+1
137 .Q:'$D(FHMEALAR(MEAL,FHDOD1)) ;meal is not for certain date.
138 .S Y=$P(^FH(119.72,P0,"B",LL,0),"^",3*DOW-2+K3) I Y>0 S:'$D(P(LL,P0)) P(LL,P0)=0 S P(LL,P0)=P(LL,P0)+Y
139 .I Y>0 S:'$D(^TMP($J,"FHD",FHDOD1,P0,LL)) ^TMP($J,"FHD",FHDOD1,P0,LL)=0 S ^TMP($J,"FHD",FHDOD1,P0,LL)=^TMP($J,"FHD",FHDOD1,P0,LL)+Y
140 ;F LL=0:0 S LL=$O(^FH(119.72,P0,"B",LL)) Q:LL<1 S Y=$P(^FH(119.72,P0,"B",LL,0),"^",3*DOW-2+K3) I Y>0 S:'$D(P(LL,P0)) P(LL,P0)=0 S P(LL,P0)=P(LL,P0)+Y
141 Q
Note: See TracBrowser for help on using the repository browser.