source: FOIAVistA/trunk/r/DIETETICS-FH/FHPRC14.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 3.7 KB
Line 
1FHPRC14 ; HISC/NCA - Meal Analysis (cont.) ;4/11/95 15:57
2 ;;5.5;DIETETICS;;Jan 28, 2005
3PD ; Store Meal and Production Diet of menu on Local Array
4 F K=0:0 S K=$O(^FHUM(MENU,1,K)) Q:K<1 F K1=0:0 S K1=$O(^FHUM(MENU,1,K,1,K1)) Q:K1<1 S Y=$G(^(K1,0)),M1=$P(Y,"^",2),PD=$P(Y,"^",3) D P1
5 Q
6P1 S $P(M(K),"^",K1)=$S(M1'="":+M1,1:"")_";"_$S(PD'="":+PD,1:"")_"~"_$P($G(^FH(116.2,+PD,0)),"^",2)
7 Q
8SRCH ; Search for Recipes of a Meal for a Production Diet
9 K ^TMP($J,"RECIPES",DAY,MEAL) Q:'M1 S ^TMP($J,"RECIPES",DAY,MEAL,0)=M1_"^"_PD
10 F REC=0:0 S REC=$O(^FH(116.1,M1,"RE",REC)) Q:REC<1 S Y=$G(^(REC,0)) D
11 .F CAT=0:0 S CAT=$O(^FH(116.1,M1,"RE",REC,"R",CAT)) Q:CAT<1 S MCA=$G(^(CAT,0)) D
12 ..S LIST=$P(MCA,"^",2) I LIST[CODE S ^TMP($J,"RECIPES",DAY,MEAL,+Y)=1_"^"_$P($G(^FH(114,+Y,0)),"^",14)
13 ..Q
14 .Q
15 Q
16LIS ; List Recipes in the Meal for a Production Diet
17 I $O(^TMP($J,"RECIPES",DAY,MEAL,0))="" W !!,"No Recipes in this Meal for this Production Diet" Q
18 K N S ANS="" F LL=0:0 S LL=$O(^TMP($J,"RECIPES",DAY,MEAL,LL)) Q:LL<1 S X=$P($G(^FH(114,+LL,0)),"^",1),N(X)=""
19 S CTR=0 W !! S LL="" F S LL=$O(N(LL)) Q:LL="" S CTR=CTR+1 W !,LL I CTR=20 D PAUSE Q:ANS="^" S CTR=0
20 K N Q
21L1 ; List Meals of each day for the Menu
22 S CTR=0,ANS="" F L=0:0 S L=$O(M(L)) Q:L="" S STR=$G(M(L)) W !!,"Day ",L,! S CTR=CTR+1 D L2 I CTR=2 D PAUSE Q:ANS="^" S CTR=0
23 Q
24L2 F LL=1:1:6 S Y=$P(STR,"^",LL) I Y'="" W !,"Meal ",LL,?8,$S($P(Y,"~",2)'="":$P(Y,"~",2),1:""),?12,$S(+Y:$P($G(^FH(116.1,+Y,0)),"^",1),1:"")
25 Q
26OLD ; Get old Recipes and Food Nutrient stored
27 Q:'M1 S ^TMP($J,"RECIPES",DAY,MEAL,0)=M1_"^"_PD
28 F REC=0:0 S REC=$O(^FHUM(MENU,1,DAY,1,MEAL,2,REC)) Q:REC<1 S Y=$G(^(REC,0)),^TMP($J,"RECIPES",DAY,MEAL,+Y)=$P(Y,"^",2)_"^"_$P($G(^FH(114,+Y,0)),"^",14)
29 Q
30PAUSE ; Pause to Scroll
31 R !!,"Press RETURN to Continue ",X:DTIME W @IOF S:'$T!(X["^") ANS="^" Q:ANS="^" I "^"'[X W !,"Enter a RETURN to Continue." G PAUSE
32 Q
33RET ; Retrieve the Stored Menu
34 F K=0:0 S K=$O(^FHUM(MENU,1,K)) Q:K<1 F K1=0:0 S K1=$O(^FHUM(MENU,1,K,1,K1)) Q:K1<1 S L1=$G(^FHUM(MENU,1,K,1,K1,0)) D A1
35 Q
36A1 S M1=$P(L1,"^",2),PD=$P(L1,"^",3) Q:'M1
37 S ^TMP($J,"RECIPES",K,K1,0)=M1_"^"_PD
38 S REC=0
39A2 S REC=$O(^FHUM(MENU,1,K,1,K1,2,REC)) Q:REC<1 S Y=$G(^(REC,0)),NP=$P($G(^FH(114,REC,0)),"^",14) G:'NP A2
40 I '$D(^FHUM(MENU,1,K,1,K1,1,NP,0)) G A2
41 S ^TMP($J,"RECIPES",K,K1,REC)=$P(Y,"^",2)_"^"_NP
42 G A2
43Q1 ; Process Meal Analysis
44 K ^TMP($J,"D"),^TMP($J,"M"),^TMP($J,"R") S DAY=0
45Q2 S DAY=$O(^TMP($J,"RECIPES",DAY)) Q:DAY<1 S M1=0,(D(1),D(2),D(3),D(4),D(5))=""
46Q3 S M1=$O(^TMP($J,"RECIPES",DAY,M1)) I M1<1 S ^TMP($J,"D",DAY,1)=D(1),^(2)=D(2),^(4)=D(4),^(5)=D(5) G Q2
47 S REC=0,(T(1),T(2),T(3),T(4))=""
48ANAL ; Analyze
49 K A S (AMT,PW)=0 F KK=1:1:66 S A(KK)=0
50 S REC=$O(^TMP($J,"RECIPES",DAY,M1,REC)) I REC<1 S ^TMP($J,"M",DAY,M1,1)=T(1),^(2)=T(2),^(4)=T(4) D ADD^FHNU9 G Q3
51 S S1=$G(^TMP($J,"RECIPES",DAY,M1,REC)),SVG=+S1
52 I '$D(^FH(114,REC,0))!('SVG) G ANAL
53 S RNAM=$E($P($G(^FH(114,REC,0)),"^",1),1,18),K1=$P(S1,"^",2) G:'K1 ANAL
54 S AMT=$P($G(^FHNU(K1,0)),"^",4) G:'AMT ANAL S AMT=AMT*SVG,PW=PW+AMT,AMT=AMT/100
55 S Y=$G(^FHNU(K1,1)) F K=1:1:20 S Z1=$P(Y,"^",K) S:Z1="" $P(D(5),"^",K)=1 I Z1 S A(K)=$J(Z1*AMT,0,3),$P(T(1),"^",K)=$P(T(1),"^",K)+A(K)
56 S Y=$G(^FHNU(K1,2)) F K=21:1:38 S Z1=$P(Y,"^",K-20) S:Z1="" $P(D(5),"^",K)=1 I Z1 S A(K)=$J(Z1*AMT,0,3),$P(T(2),"^",K-20)=$P(T(2),"^",K-20)+A(K)
57 S Y=$G(^FHNU(K1,4)) F K=65,66 S Z1=$P(Y,"^",K-56) S:Z1="" $P(D(5),"^",K)=1 I Z1 S A(K)=$J(Z1*AMT,0,3),$P(T(4),"^",K-56)=$P(T(4),"^",K-56)+A(K)
58 S:'$D(^TMP($J,"R",DAY,M1,RNAM,0)) (^(0),^(1),^(2),^(3),^(4))=""
59 S $P(^TMP($J,"R",DAY,M1,RNAM,0),"^",1,2)=SVG_"^"_PW
60 F K=1:1:20 S $P(^TMP($J,"R",DAY,M1,RNAM,1),"^",K)=A(K)
61 F K=21:1:38 S $P(^TMP($J,"R",DAY,M1,RNAM,2),"^",K-20)=A(K)
62 F K=65,66 S $P(^TMP($J,"R",DAY,M1,RNAM,4),"^",K-56)=A(K)
63 G ANAL
Note: See TracBrowser for help on using the repository browser.