source: FOIAVistA/trunk/r/DIETETICS-FH/FHPRO3.m@ 1538

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

initial load of FOIAVistA 6/30/08 version
File size: 6.2 KB
Line 
1FHPRO3 ; HISC/REL/RVD - Recipe Calculations ;4/14/95 08:05
2 ;;5.5;DIETETICS;**3,5**;Jan 28, 2005;Build 53
3 ;RVD 5/20/05 - as part of AFP project.
4 ;patch #5 -added a screen for cancelled quest meals.
5 K ^TMP($J,"FH","T"),P,T
6 I '$G(FHAFLG) K ^TMP($J,"AFP","T")
7 ;S K3=$F("BNE",MEAL)-1,FHX1=$P(FHDA,"^",K3+1) Q:'FHX1
8 F L1=0:0 S L1=$O(^FH(116.2,L1)) Q:L1<1 S Z=$P($G(^(L1,0)),"^",2) I Z'="" S P(Z)=L1
9 F P0=0:0 S P0=$O(^TMP($J,"FH",P0)) Q:P0<1 S Z=$P($G(^FH(119.72,P0,0)),"^",2) I Z'="" S T(P0)=Z
10 D P1
11 S FHAFLG=1
12 G ^FHPRO4
13P1 F FHI=0:0 S FHI=$O(FHDODAY(FHI)) Q:FHI'>0 S (D1,X1)=FHDODAY(FHI) D FHD,P12
14 K M,P,T,Y,Z,Z1 Q
15P12 S K3=$F("BNE",MEAL)-1,FHX1=$P(FHDA,"^",K3+1) Q:'FHX1
16 Q:'$D(^FH(116.1,FHX1))
17 F M=0:0 S M=$O(^FH(116.1,FHX1,"RE",M)) Q:M<1 S L1=^(M,0),L1=+L1 D P2
18 Q
19P2 S N1=0,X=$G(^FH(114,L1,0)),K4=$P(X,"^",12),K4=$S($D(^FH(114.2,+K4,0)):$P(^(0),"^",3),1:99)
20 ;S MCA=$O(^FH(116.1,FHX1,"RE",M,"R",0)),LL=$S(MCA:+$G(^FH(116.1,FHX1,"RE",M,"R",MCA,0)),1:99)
21 ;S FHPD=$P(LL,"^",2),LL=+LL
22 ;S LL=$S($D(^FH(114.1,+LL,0)):$P(^(0),"^",3),1:99)
23 ;
24 S LL=$P(X,"^",7)
25 I $G(LL) S LL=$S($D(^FH(114.1,+LL,0)):$P(^(0),"^",3),1:99)
26 S K4=$S(K4<1:99,K4<10:"0"_K4,1:K4)_$S(LL<1:99,LL<10:"0"_LL,1:LL)_$E($P(X,"^",1),1,26)
27 F P0=0:0 S P0=$O(^TMP($J,"FHD",D1,P0)) Q:P0<1 D R1 ;I N2 S ^TMP($J,"FH","T",K4,L1,P0)=N2,^TMP($J,"AFP","T",K4,L1,P0)=N2
28 Q:'N1 S:'$G(^TMP($J,"FH","T",K4,L1)) ^TMP($J,"FH","T",K4,L1)=0 S ^(L1)=^(L1)+N1
29 S:'$G(^TMP($J,"AFP","T",K4,L1)) ^TMP($J,"AFP","T",K4,L1)=0 S ^(L1)=^(L1)+N1
30 Q
31R1 S Z1=$P($G(^FH(116.1,FHX1,"RE",M,"D",P0,0)),"^",2),N2=0
32 F CAT=0:0 S CAT=$O(^FH(116.1,FHX1,"RE",M,"R",CAT)) Q:CAT<1 S FHPD=$P($G(^(CAT,0)),"^",2) D
33 .F LL=1:1 S FHX2=$P(FHPD," ",LL) Q:FHX2="" S X=$P(FHX2,";",1) I X'="",$D(P(X)) D P3
34 .Q
35 Q
36P3 S FHPX1=$G(^TMP($J,"FHD",D1,P0,P(X))) Q:'FHPX1
37 S Y=$P(FHX2,";",2) I Y="" S:Z1'="" FHPX1=$J(Z1*FHPX1/100,0,0) G P4
38 D P5 S Y=$P(FHX2,";",3) D:Y'="" P5
39P4 S N1=N1+FHPX1,N2=N2+FHPX1 ;S:FHPX1 ^TMP($J,"FH","T",K4,L1,P0)=FHPX1 Q
40 I FHPX1 S:'$D(^TMP($J,"FH","T",K4,L1,P0)) ^TMP($J,"FH","T",K4,L1,P0)=0 S ^TMP($J,"FH","T",K4,L1,P0)=^TMP($J,"FH","T",K4,L1,P0)+FHPX1
41 Q
42P5 S:$E(Y,1)=T(P0) FHPX1=$J($E(Y,2,99)*FHPX1/100,0,0) Q
43 ;
44FHD ;get FHDA
45 S:$D(FHDA) FHDASV=FHDA
46 D E1^FHPRC1
47 I '$G(FHCY)!'$G(FHDA) S FHDA=FHDASV Q
48 S FHDA=^FH(116,FHCY,"DA",FHDA,0)
49 I $D(^FH(116.3,D1,0)) S X=^(0) F LL=2:1:4 I $P(X,"^",LL) S $P(FHDA,"^",LL)=$P(X,"^",LL)
50 Q
51 ;
52OUT ;process outpatient data
53REC S FHTIM=D1-.000001,FHDT299=FHDT2+.99999
54 F FHIR=FHTIM:0 S FHIR=$O(^FHPT("RM",FHIR)) Q:(FHIR'>0)!(FHIR>(FHDT299)) F FHIDFN=0:0 S FHIDFN=$O(^FHPT("RM",FHIR,FHIDFN)) Q:FHIDFN'>0 D
55 .F FHIEN=0:0 S FHIEN=$O(^FHPT("RM",FHIR,FHIDFN,FHIEN)) Q:FHIEN'>0 D
56 ..S FHPX1=FHIR\1
57 ..S FHREDAT=$G(^FHPT(FHIDFN,"OP",FHIEN,0))
58 ..Q:$P(FHREDAT,U,4)'=MEAL
59 ..Q:$P(FHREDAT,U,15)="C"
60 ..S FHLOC=$P(FHREDAT,U,3) Q:'$G(FHLOC)
61 ..I $G(FHSITE),$P($G(^FH(119.6,FHLOC,0)),U,8)'=FHSITE Q
62 ..S FHRDIET=$P(FHREDAT,U,2) Q:'$G(FHRDIET)
63 ..S FHPDIET=$P($G(^FH(111,FHRDIET,0)),U,5)
64 ..I $G(FHLOC) D
65 ...S FHSER=$P($G(^FH(119.6,FHLOC,0)),U,5) S:$G(FHSER) SP(FHSER)=""
66 ...I '$G(FHSER) S FHSER=$P($G(^FH(119.6,FHLOC,0)),U,6) S:$G(FHSER) SP(FHSER)=""
67 ...I '$G(FHSER) S FHSER=$O(^FH(119.72,0)) S:$G(FHSER) SP(FHSER)=""
68 ..Q:'$G(FHSER)
69 ..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
70 ..S FHDIET=$P($G(^FH(119.9,1,0)),U,2)
71 ..S:'$D(P(FHPDIET,FHSER)) P(FHPDIET,FHSER)=0
72 ..S P(FHPDIET,FHSER)=P(FHPDIET,FHSER)+1
73 ..S:'$D(^TMP($J,"FHD",FHPX1,FHSER,FHPDIET)) ^TMP($J,"FHD",FHPX1,FHSER,FHPDIET)=0
74 ..S ^TMP($J,"FHD",FHPX1,FHSER,FHPDIET)=^TMP($J,"FHD",FHPX1,FHSER,FHPDIET)+1
75 ..S:'$D(P(.6,FHSER)) P(.6,FHSER)=0 S P(.6,FHSER)=P(.6,FHSER)+1
76 ..;if tubefeeding and not cancelled, also count the TF data.
77 ..I $D(^FHPT(FHIDFN,"OP",FHIEN,"TF")) D
78 ...Q:$P(^FHPT(FHIDFN,"OP",FHIEN,3),U,5)="C"
79 ...I '$D(P(.7,FHSER)) S P(.7,FHSER)=1
80 ...E S P(.7,FHSER)=P(.7,FHSER)+1
81 ...S:'$D(P(.6,FHSER)) P(.6,FHSER)=0 S P(.6,FHSER)=P(.6,FHSER)+1
82 ;
83SPEC ;process special meal
84 S FHITIM=D1-.00001
85 F FHI=FHITIM:0 S FHI=$O(^FHPT("SM",FHI)) Q:(FHI'>0)!(FHI>FHDT299) D
86 .F FHJ=0:0 S FHJ=$O(^FHPT("SM",FHI,FHJ)) Q:FHJ'>0 D
87 ..S FHPX1=FHI\1
88 ..S FHNODE=$G(^FHPT(FHJ,"SM",FHI,0))
89 ..S FHSTAT=$P(FHNODE,U,2)
90 ..I FHSTAT'="A",(FHSTAT'="P") Q
91 ..S FHLPT=$P(FHNODE,U,3)
92 ..S FHDIET=$P(FHNODE,U,4)
93 ..S:'$G(FHDIET) FHDIET=$P($G(^FH(119.9,1,0)),U,2)
94 ..I $G(FHDIET),$D(^FH(111,FHDIET,0)) S FHPDIET=$P(^FH(111,FHDIET,0),U,5)
95 ..Q:'$G(FHPDIET)
96 ..I $G(FHSITE) S FHCOM=$P(^FH(119.6,FHLPT,0),U,8) Q:FHSITE'=FHCOM
97 ..S FHSER=""
98 ..I $G(FHLPT) D
99 ...S FHSER=$P($G(^FH(119.6,FHLPT,0)),U,5) S:$G(FHSER) SP(FHSER)=""
100 ...I '$G(FHSER) S FHSER=$P($G(^FH(119.6,FHLPT,0)),U,6) S:$G(FHSER) SP(FHSER)=""
101 ...I '$G(FHSER) S FHSER=$O(^FH(119.72,0)) S:$G(FHSER) SP(FHSER)=""
102 ..Q:FHSER=""
103 ..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
104 ..S FHMEAL=$P(FHNODE,U,9)
105 ..Q:FHMEAL'=MEAL
106 ..S:'$D(P(FHPDIET,FHSER)) P(FHPDIET,FHSER)=0
107 ..S P(FHPDIET,FHSER)=P(FHPDIET,FHSER)+1
108 ..S:'$D(^TMP($J,"FHD",FHPX1,FHSER,FHPDIET)) ^TMP($J,"FHD",FHPX1,FHSER,FHPDIET)=0
109 ..S ^TMP($J,"FHD",FHPX1,FHSER,FHPDIET)=^TMP($J,"FHD",FHPX1,FHSER,FHPDIET)+1
110 ..;S:'$D(P(.6,FHSER)) P(.6,FHSER)=0 S P(.6,FHSER)=P(.6,FHSER)+1
111 ;
112GUEST ;process GUEST meal
113 F FHI=FHITIM:0 S FHI=$O(^FHPT("GM",FHI)) Q:(FHI'>0)!(FHI>FHDT299) D
114 .F FHJ=0:0 S FHJ=$O(^FHPT("GM",FHI,FHJ)) Q:FHJ'>0 D
115 ..S FHPX1=FHI\1
116 ..S FHNODE=$G(^FHPT(FHJ,"GM",FHI,0))
117 ..S FHMEAL=$P(FHNODE,U,3)
118 ..Q:FHMEAL'=MEAL
119 ..Q:$P(FHNODE,U,9)="C"
120 ..S FHLPT=$P(FHNODE,U,5)
121 ..S FHDIET=$P(FHNODE,U,6)
122 ..S:'$G(FHDIET) FHDIET=$P($G(^FH(119.9,1,0)),U,2)
123 ..I $G(FHDIET),$D(^FH(111,FHDIET,0)) S FHPDIET=$P(^FH(111,FHDIET,0),U,5)
124 ..Q:'$G(FHPDIET)
125 ..I $G(FHSITE) S FHCOM=$P(^FH(119.6,FHLPT,0),U,8) Q:FHSITE'=FHCOM
126 ..S FHSER=""
127 ..I $G(FHLPT) D
128 ...S FHSER=$P($G(^FH(119.6,FHLPT,0)),U,5) S:$G(FHSER) SP(FHSER)=""
129 ...I '$G(FHSER) S FHSER=$P($G(^FH(119.6,FHLPT,0)),U,6) S:$G(FHSER) SP(FHSER)=""
130 ...I '$G(FHSER) S FHSER=$O(^FH(119.72,0)) S:$G(FHSER) SP(FHSER)=""
131 ..Q:FHSER=""
132 ..I $D(^FH(119.72,FHSER,0)),$P(^FH(119.72,FHSER,0),U,3)'=FHP Q
133 ..S:'$D(P(FHPDIET,FHSER)) P(FHPDIET,FHSER)=0
134 ..S P(FHPDIET,FHSER)=P(FHPDIET,FHSER)+1
135 ..S:'$D(^TMP($J,"FHD",FHPX1,FHSER,FHPDIET)) ^TMP($J,"FHD",FHPX1,FHSER,FHPDIET)=0
136 ..S ^TMP($J,"FHD",FHPX1,FHSER,FHPDIET)=^TMP($J,"FHD",FHPX1,FHSER,FHPDIET)+1
137 ..;S:'$D(P(.6,FHSER)) P(.6,FHSER)=0 S P(.6,FHSER)=P(.6,FHSER)+1
138 Q
Note: See TracBrowser for help on using the repository browser.