source: FOIAVistA/trunk/r/DIETETICS-FH/FHPRF1.m@ 1742

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

initial load of FOIAVistA 6/30/08 version
File size: 7.1 KB
Line 
1FHPRF1 ; HISC/REL/RVD - Calculate Total Forecast ;1/23/98 16:10
2 ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
3 ;
4 ;patch #5 - added screen for cancelled quest meals.
5 ;
6 S %DT="X",X="T" D ^%DT S DT=+Y
7 D DIV^FHOMUTL G:'$D(FHSITE) KIL
8D1 R !!,"Forecast Date: ",X:DTIME G:'$T!("^"[X) KIL S %DT="EX" D ^%DT G KIL:"^"[X,D1:Y<1 S D1=+Y
9 S FHP=$O(^FH(119.71,0)) I FHP'<1,$O(^FH(119.71,FHP))<1 G R1
10R0 R !!,"Select PRODUCTION FACILITY: ",X:DTIME G:'$T!("^"[X) KIL
11 K DIC S DIC="^FH(119.71,",DIC(0)="EMQ" D ^DIC G:Y<1 R0 S FHP=+Y
12R1 W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
13 I $D(IO("Q")) S FHPGM="Q1^FHPRF1",FHLST="D1^FHP^FHSITE^FHSITENM" D EN2^FH G KIL
14 U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
15Q1 ; Process Census Forecast
16 D Q2,Q3
17 ;get outpatient data
18 S FHD1SAV=D1
19 S:'$G(FHSITE) FHSITE=""
20 S:'$D(FHSITENM) FHSITENM="CONSOLIDATED"
21 D GETSM^FHOMRBLD(D1,FHSITE,"","")
22 D GETGM^FHOMRBL1(D1,FHSITE,"","")
23 S D1=D1-.000001
24 D GETRM^FHOMRBLD(D1,FHSITE,"","")
25 D PROSG ;process recurring, special and guest meal from "OP" node
26 S D1=FHD1SAV
27 G ^FHPRF1A
28Q2 ; Calculate Service Point census forecast
29 S X="T",%DT="X" D ^%DT S DT=+Y
30 K ^TMP($J) S X=D1 D DOW^%DTC S DOW=Y+1 D BLD,DAT
31 F W1=0:0 S W1=$O(^TMP($J,"W",W1)) Q:W1<1 D WRD S ^TMP($J,"W",W1)=S1
32 K D,DC S X1=DT,X2=-1 D C^%DTC S D2=X
33 F P0=0:0 S P0=$O(^TMP($J,"S",P0)) Q:P0<1 D ADD S ^TMP($J,P0)=S1
34 Q
35Q3 F P0=0:0 S P0=$O(^TMP($J,P0)) Q:P0<1 S S1=^(P0) D PER S ^TMP($J,P0)=S0
36 F K=0:0 S K=$O(D(K)) Q:K<1 S ^TMP($J,0,K)=D(K)
37 K D,^TMP($J,"W"),^TMP($J,"S") Q
38WRD S (A,B,CT,S1,S2,S3,S4)=0 F K=1:1:9 S Y=$P($G(^DG(41.9,W1,"C",D(K),0)),"^",2) I Y S CT=CT+1,S0=10-K,S1=S1+S0,S2=S0*S0+S2,S3=S3+Y,S4=S0*Y+S4
39 G:'CT W1 I CT=1 S S1=S3 G W1
40 S S0=S1*S1/CT-S2,A=S1*S3/CT-S4/S0,B=S3/CT-(A*S1/CT)
41 S A=$J(A,0,3),B=$J(B,0,2),S1=10*A+B
42W1 S (N1,C2,C3)=0 F K=1:1:7 S Y0=$P($G(^DG(41.9,W1,"C",DC(K),0)),"^",2) I Y0 S N1=N1+1,C2=Y0-S1*(4-N1)+C2,C3=4-N1+C3 Q:N1=3
43 I N1 S C2=C2/C3,S1=S1+C2
44 S S1=$J(S1,0,0) Q
45ADD S (S1,CT)=0 F W1=0:0 S W1=$O(^TMP($J,"S",P0,W1)) Q:W1<1 S Z=^(W1),T0=$G(^TMP($J,"W",W1)),CT=CT+T0,S1=Z*T0/100+S1
46 S S1=$J(S1,0,0)
47 I '$D(^FH(119.72,P0,"C",D1,0)) S ^(0)=D1 I '$D(^FH(119.72,P0,"C",0)) S ^(0)="^119.722DA^^"
48 I D1'<DT S C2=$P(^FH(119.72,P0,"C",D1,0),"^",3),$P(^(0),"^",2,5)=CT_"^"_C2_"^"_S1_"^"_DT
49 Q:'$D(^FH(119.72,P0,"C",DT,0)) S C2=0
50 F W1=0:0 S W1=$O(^TMP($J,"S",P0,W1)) Q:W1<1 S C2=C2+$P($G(^DG(41.9,W1,"C",D2,0)),"^",2)
51 S:C2 $P(^FH(119.72,P0,"C",DT,0),"^",3)=C2 Q
52PER S S0=0 F K=0:0 S K=$O(^FH(119.72,P0,"A",K)) Q:K<1 S Z=$P($G(^(K,0)),"^",DOW+1),Z=$J(Z*S1/100,0,0) I Z S ^TMP($J,P0,K)=Z,S0=S0+Z,D(K)=$G(D(K))+Z
53 Q
54DAT ; Build list of dates
55 K D,DC S X1=D1,X2=-1 D C^%DTC S D2=X
56 F K=1:1:9 S X1=D2,X2=-7 D C^%DTC S D(K)=X,D2=X
57 S D2=D1 F K=1:1:7 S X1=D2,X2=-1 D C^%DTC S DC(K)=X,D2=X
58 Q
59BLD ; Build list of MAS wards and %'s for each Service Point
60 K ^TMP($J,"S"),^TMP($J,"W")
61 F P0=0:0 S P0=$O(^FH(119.72,P0)) Q:P0<1 S X=$G(^(P0,0)) I $P(X,"^",3)=FHP,$G(^FH(119.72,P0,"I"))'="Y" S ^TMP($J,"S",P0)=""
62 ;F K1=0:0 S K1=$O(^FH(119.6,K1)) Q:K1<1 S X=$G(^(K1,0)) D B1
63 F K1=0:0 S K1=$O(^FH(119.6,K1)) Q:K1<1 S X=$G(^(K1,0)) D B1:($P(X,U,8)=FHSITE!(FHSITE=0))
64 Q
65B1 S Z=$P(X,"^",5) I Z,$D(^TMP($J,"S",Z)) S Z1=$P(X,"^",17) S:$P(X,"^",7) Z1=Z1+$P(X,"^",19) S:'Z1 Z1=100 D B2
66 S Z=$P(X,"^",6) I Z,$D(^TMP($J,"S",Z)) S Z1=$P(X,"^",18) S:Z1="" Z1=100 D B2
67 Q
68B2 F L2=0:0 S L2=$O(^FH(119.6,K1,"W",L2)) Q:L2<1 S ZW=+$G(^(L2,0)) I ZW S ^TMP($J,"W",ZW)="",^TMP($J,"S",Z,ZW)=Z1
69 Q
70 ;
71PROSG ;process outpatient data from ^tmp($j global
72 S FHPLNM=""
73 S:$G(FHSITE) FHPLNM=$P($G(^FH(119.73,FHSITE,0)),U,1)
74RECUR ;recurring meals
75 S FHDT=D1+.999999
76 S FHTMPS="^TMP($J,""OP"",""R"")"
77 S FHN="" F S FHN=$O(@FHTMPS@(FHN)) Q:FHN="" S FHI="" F S FHI=$O(@FHTMPS@(FHN,FHI)) Q:FHI="" S FHJ="" F S FHJ=$O(@FHTMPS@(FHN,FHI,FHJ)) Q:FHJ="" D
78 .I (FHPLNM'=""),(FHN'=FHPLNM) Q
79 .F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>FHDT) D
80 ..S (FHPDIET,FHLOC,FHSER,FHDIET)="***"
81 ..S FHIJKDAT=@FHTMPS@(FHN,FHI,FHJ,FHK)
82 ..Q:$P(FHIJKDAT,U,19)="C" ;quit if status is cancelled.
83 ..S FHDIET=$P(FHIJKDAT,U,3),FHDIET=$O(^FH(111,"B",FHDIET,0))
84 ..I $G(FHDIET),$D(^FH(111,FHDIET,0)) S FHPDIET=$P(^FH(111,FHDIET,0),U,5)
85 ..S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
86 ..S:$G(FHLOC) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,5)
87 ..S:'$G(FHSER) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,6)
88 ..S:'$G(FHSER) FHSER=$O(^FH(119.72,0))
89 ..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
90 ..S:$D(^TMP($J,FHSER)) ^TMP($J,FHSER)=^TMP($J,FHSER)+1
91 ..S:'$D(^TMP($J,FHSER)) ^TMP($J,FHSER)=1
92 ..I $D(^TMP($J,FHSER,FHPDIET)) D
93 ...S ^TMP($J,FHSER,FHPDIET)=^TMP($J,FHSER,FHPDIET)+1
94 ..I '$D(^TMP($J,FHSER,FHPDIET)) D
95 ...S ^TMP($J,FHSER,FHPDIET)=1
96 ..I $D(^TMP($J,0,FHPDIET)) S ^TMP($J,0,FHPDIET)=^TMP($J,0,FHPDIET)+1
97 ..I '$D(^TMP($J,0,FHPDIET)) S ^TMP($J,0,FHPDIET)=1
98 ;
99SPEC ;special meals
100 S FHTMPS="^TMP($J,""OP"",""S"")"
101 S FHN="" F S FHN=$O(@FHTMPS@(FHN)) Q:FHN="" S FHI="" F S FHI=$O(@FHTMPS@(FHN,FHI)) Q:FHI="" S FHJ="" F S FHJ=$O(@FHTMPS@(FHN,FHI,FHJ)) Q:FHJ="" D
102 .I (FHPLNM'=""),(FHN'=FHPLNM) Q
103 .F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>FHDT) D
104 ..S (FHPDIET,FHLOC,FHSER,FHDIET)="***"
105 ..S FHIJKDAT=@FHTMPS@(FHN,FHI,FHJ,FHK)
106 ..S FHDIET=$P(FHIJKDAT,U,4),FHDIET=$O(^FH(111,"B",FHDIET,0))
107 ..S:$D(^FH(111,FHDIET,0)) FHPDIET=$P(^FH(111,FHDIET,0),U,5)
108 ..S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
109 ..S:$G(FHLOC) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,5)
110 ..S:'$G(FHSER) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,6)
111 ..S:'$G(FHSER) FHSER=$O(^FH(119.72,0))
112 ..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
113 ..S:$D(^TMP($J,FHSER)) ^TMP($J,FHSER)=^TMP($J,FHSER)+1
114 ..S:'$D(^TMP($J,FHSER)) ^TMP($J,FHSER)=1
115 ..I $D(^TMP($J,FHSER,FHPDIET)) D
116 ...S ^TMP($J,FHSER,FHPDIET)=^TMP($J,FHSER,FHPDIET)+1
117 ..I '$D(^TMP($J,FHSER,FHPDIET)) D
118 ...S ^TMP($J,FHSER,FHPDIET)=1
119 ..I $D(^TMP($J,0,FHPDIET)) S ^TMP($J,0,FHPDIET)=^TMP($J,0,FHPDIET)+1
120 ..I '$D(^TMP($J,0,FHPDIET)) S ^TMP($J,0,FHPDIET)=1
121 ;
122GUEST ;guest meals
123 S FHTMPS="^TMP($J,""OP"",""G"")"
124 S FHN="" F S FHN=$O(@FHTMPS@(FHN)) Q:FHN="" S FHI="" F S FHI=$O(@FHTMPS@(FHN,FHI)) Q:FHI="" S FHJ="" F S FHJ=$O(@FHTMPS@(FHN,FHI,FHJ)) Q:FHJ="" D
125 .I (FHPLNM'=""),(FHN'=FHPLNM) Q
126 .F FHK=0:0 S FHK=$O(@FHTMPS@(FHN,FHI,FHJ,FHK)) Q:(FHK'>0)!(FHK>FHDT) D
127 ..S (FHPDIET,FHLOC,FHSER,FHDIET)="***"
128 ..S FHIJKDAT=@FHTMPS@(FHN,FHI,FHJ,FHK)
129 ..Q:$P(FHIJKDAT,U,7)="C"
130 ..S FHDIET=$P($G(^FH(119.9,1,0)),U,2) ;default diet from 119.9
131 ..S FHDIETN=$P(FHIJKDAT,U,6) ;diet from guest meal
132 ..S:$D(^FH(119.6,"B",FHI)) FHLOC=$O(^FH(119.6,"B",FHI,0))
133 ..S:$G(FHLOC) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,5)
134 ..S:'$G(FHSER) FHSER=$P($G(^FH(119.6,FHLOC,0)),U,6)
135 ..S:'$G(FHSER) FHSER=$O(^FH(119.72,0))
136 ..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
137 ..S:$D(^TMP($J,FHSER)) ^TMP($J,FHSER)=^TMP($J,FHSER)+1
138 ..S:'$D(^TMP($J,FHSER)) ^TMP($J,FHSER)=1
139 ..I $G(FHDIETN),($D(^FH(111,FHDIETN,0))) D
140 ...S FHPDIET=$P(^FH(111,FHDIETN,0),U,5)
141 ..I $D(^TMP($J,FHSER,FHPDIET)) D
142 ...S ^TMP($J,FHSER,FHPDIET)=^TMP($J,FHSER,FHPDIET)+1
143 ..I '$D(^TMP($J,FHSER,FHPDIET)) D
144 ...S ^TMP($J,FHSER,FHPDIET)=1
145 ..I $D(^TMP($J,0,FHPDIET)) S ^TMP($J,0,FHPDIET)=^TMP($J,0,FHPDIET)+1
146 ..I '$D(^TMP($J,0,FHPDIET)) S ^TMP($J,0,FHPDIET)=1
147 Q
148 ;
149KIL K ^TMP($J) G KILL^XUSCLEAN
Note: See TracBrowser for help on using the repository browser.