- FHPRC14 ; HISC/NCA - Meal Analysis (cont.) ;4/11/95 15:57
- ;;5.5;DIETETICS;;Jan 28, 2005
- PD ; Store Meal and Production Diet of menu on Local Array
- 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
- Q
- P1 S $P(M(K),"^",K1)=$S(M1'="":+M1,1:"")_";"_$S(PD'="":+PD,1:"")_"~"_$P($G(^FH(116.2,+PD,0)),"^",2)
- Q
- SRCH ; Search for Recipes of a Meal for a Production Diet
- K ^TMP($J,"RECIPES",DAY,MEAL) Q:'M1 S ^TMP($J,"RECIPES",DAY,MEAL,0)=M1_"^"_PD
- F REC=0:0 S REC=$O(^FH(116.1,M1,"RE",REC)) Q:REC<1 S Y=$G(^(REC,0)) D
- .F CAT=0:0 S CAT=$O(^FH(116.1,M1,"RE",REC,"R",CAT)) Q:CAT<1 S MCA=$G(^(CAT,0)) D
- ..S LIST=$P(MCA,"^",2) I LIST[CODE S ^TMP($J,"RECIPES",DAY,MEAL,+Y)=1_"^"_$P($G(^FH(114,+Y,0)),"^",14)
- ..Q
- .Q
- Q
- LIS ; List Recipes in the Meal for a Production Diet
- I $O(^TMP($J,"RECIPES",DAY,MEAL,0))="" W !!,"No Recipes in this Meal for this Production Diet" Q
- 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)=""
- 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
- K N Q
- L1 ; List Meals of each day for the Menu
- 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
- Q
- L2 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:"")
- Q
- OLD ; Get old Recipes and Food Nutrient stored
- Q:'M1 S ^TMP($J,"RECIPES",DAY,MEAL,0)=M1_"^"_PD
- 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)
- Q
- PAUSE ; Pause to Scroll
- 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
- Q
- RET ; Retrieve the Stored Menu
- 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
- Q
- A1 S M1=$P(L1,"^",2),PD=$P(L1,"^",3) Q:'M1
- S ^TMP($J,"RECIPES",K,K1,0)=M1_"^"_PD
- S REC=0
- A2 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
- I '$D(^FHUM(MENU,1,K,1,K1,1,NP,0)) G A2
- S ^TMP($J,"RECIPES",K,K1,REC)=$P(Y,"^",2)_"^"_NP
- G A2
- Q1 ; Process Meal Analysis
- K ^TMP($J,"D"),^TMP($J,"M"),^TMP($J,"R") S DAY=0
- Q2 S DAY=$O(^TMP($J,"RECIPES",DAY)) Q:DAY<1 S M1=0,(D(1),D(2),D(3),D(4),D(5))=""
- Q3 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
- S REC=0,(T(1),T(2),T(3),T(4))=""
- ANAL ; Analyze
- K A S (AMT,PW)=0 F KK=1:1:66 S A(KK)=0
- 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
- S S1=$G(^TMP($J,"RECIPES",DAY,M1,REC)),SVG=+S1
- I '$D(^FH(114,REC,0))!('SVG) G ANAL
- S RNAM=$E($P($G(^FH(114,REC,0)),"^",1),1,18),K1=$P(S1,"^",2) G:'K1 ANAL
- S AMT=$P($G(^FHNU(K1,0)),"^",4) G:'AMT ANAL S AMT=AMT*SVG,PW=PW+AMT,AMT=AMT/100
- 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)
- 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)
- 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)
- S:'$D(^TMP($J,"R",DAY,M1,RNAM,0)) (^(0),^(1),^(2),^(3),^(4))=""
- S $P(^TMP($J,"R",DAY,M1,RNAM,0),"^",1,2)=SVG_"^"_PW
- F K=1:1:20 S $P(^TMP($J,"R",DAY,M1,RNAM,1),"^",K)=A(K)
- F K=21:1:38 S $P(^TMP($J,"R",DAY,M1,RNAM,2),"^",K-20)=A(K)
- F K=65,66 S $P(^TMP($J,"R",DAY,M1,RNAM,4),"^",K-56)=A(K)
- G ANAL
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHPRC14 3858 printed Feb 18, 2025@23:20:38 Page 2
- FHPRC14 ; HISC/NCA - Meal Analysis (cont.) ;4/11/95 15:57
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- PD ; Store Meal and Production Diet of menu on Local Array
- +1 FOR K=0:0
- SET K=$ORDER(^FHUM(MENU,1,K))
- if K<1
- QUIT
- FOR K1=0:0
- SET K1=$ORDER(^FHUM(MENU,1,K,1,K1))
- if K1<1
- QUIT
- SET Y=$GET(^(K1,0))
- SET M1=$PIECE(Y,"^",2)
- SET PD=$PIECE(Y,"^",3)
- DO P1
- +2 QUIT
- P1 SET $PIECE(M(K),"^",K1)=$SELECT(M1'="":+M1,1:"")_";"_$SELECT(PD'="":+PD,1:"")_"~"_$PIECE($GET(^FH(116.2,+PD,0)),"^",2)
- +1 QUIT
- SRCH ; Search for Recipes of a Meal for a Production Diet
- +1 KILL ^TMP($JOB,"RECIPES",DAY,MEAL)
- if 'M1
- QUIT
- SET ^TMP($JOB,"RECIPES",DAY,MEAL,0)=M1_"^"_PD
- +2 FOR REC=0:0
- SET REC=$ORDER(^FH(116.1,M1,"RE",REC))
- if REC<1
- QUIT
- SET Y=$GET(^(REC,0))
- Begin DoDot:1
- +3 FOR CAT=0:0
- SET CAT=$ORDER(^FH(116.1,M1,"RE",REC,"R",CAT))
- if CAT<1
- QUIT
- SET MCA=$GET(^(CAT,0))
- Begin DoDot:2
- +4 SET LIST=$PIECE(MCA,"^",2)
- IF LIST[CODE
- SET ^TMP($JOB,"RECIPES",DAY,MEAL,+Y)=1_"^"_$PIECE($GET(^FH(114,+Y,0)),"^",14)
- +5 QUIT
- End DoDot:2
- +6 QUIT
- End DoDot:1
- +7 QUIT
- LIS ; List Recipes in the Meal for a Production Diet
- +1 IF $ORDER(^TMP($JOB,"RECIPES",DAY,MEAL,0))=""
- WRITE !!,"No Recipes in this Meal for this Production Diet"
- QUIT
- +2 KILL N
- SET ANS=""
- FOR LL=0:0
- SET LL=$ORDER(^TMP($JOB,"RECIPES",DAY,MEAL,LL))
- if LL<1
- QUIT
- SET X=$PIECE($GET(^FH(114,+LL,0)),"^",1)
- SET N(X)=""
- +3 SET CTR=0
- WRITE !!
- SET LL=""
- FOR
- SET LL=$ORDER(N(LL))
- if LL=""
- QUIT
- SET CTR=CTR+1
- WRITE !,LL
- IF CTR=20
- DO PAUSE
- if ANS="^"
- QUIT
- SET CTR=0
- +4 KILL N
- QUIT
- L1 ; List Meals of each day for the Menu
- +1 SET CTR=0
- SET ANS=""
- FOR L=0:0
- SET L=$ORDER(M(L))
- if L=""
- QUIT
- SET STR=$GET(M(L))
- WRITE !!,"Day ",L,!
- SET CTR=CTR+1
- DO L2
- IF CTR=2
- DO PAUSE
- if ANS="^"
- QUIT
- SET CTR=0
- +2 QUIT
- L2 FOR LL=1:1:6
- SET Y=$PIECE(STR,"^",LL)
- IF Y'=""
- WRITE !,"Meal ",LL,?8,$SELECT($PIECE(Y,"~",2)'="":$PIECE(Y,"~",2),1:""),?12,$SELECT(+Y:$PIECE($GET(^FH(116.1,+Y,0)),"^",1),1:"")
- +1 QUIT
- OLD ; Get old Recipes and Food Nutrient stored
- +1 if 'M1
- QUIT
- SET ^TMP($JOB,"RECIPES",DAY,MEAL,0)=M1_"^"_PD
- +2 FOR REC=0:0
- SET REC=$ORDER(^FHUM(MENU,1,DAY,1,MEAL,2,REC))
- if REC<1
- QUIT
- SET Y=$GET(^(REC,0))
- SET ^TMP($JOB,"RECIPES",DAY,MEAL,+Y)=$PIECE(Y,"^",2)_"^"_$PIECE($GET(^FH(114,+Y,0)),"^",14)
- +3 QUIT
- PAUSE ; Pause to Scroll
- +1 READ !!,"Press RETURN to Continue ",X:DTIME
- WRITE @IOF
- if '$TEST!(X["^")
- SET ANS="^"
- if ANS="^"
- QUIT
- IF "^"'[X
- WRITE !,"Enter a RETURN to Continue."
- GOTO PAUSE
- +2 QUIT
- RET ; Retrieve the Stored Menu
- +1 FOR K=0:0
- SET K=$ORDER(^FHUM(MENU,1,K))
- if K<1
- QUIT
- FOR K1=0:0
- SET K1=$ORDER(^FHUM(MENU,1,K,1,K1))
- if K1<1
- QUIT
- SET L1=$GET(^FHUM(MENU,1,K,1,K1,0))
- DO A1
- +2 QUIT
- A1 SET M1=$PIECE(L1,"^",2)
- SET PD=$PIECE(L1,"^",3)
- if 'M1
- QUIT
- +1 SET ^TMP($JOB,"RECIPES",K,K1,0)=M1_"^"_PD
- +2 SET REC=0
- A2 SET REC=$ORDER(^FHUM(MENU,1,K,1,K1,2,REC))
- if REC<1
- QUIT
- SET Y=$GET(^(REC,0))
- SET NP=$PIECE($GET(^FH(114,REC,0)),"^",14)
- if 'NP
- GOTO A2
- +1 IF '$DATA(^FHUM(MENU,1,K,1,K1,1,NP,0))
- GOTO A2
- +2 SET ^TMP($JOB,"RECIPES",K,K1,REC)=$PIECE(Y,"^",2)_"^"_NP
- +3 GOTO A2
- Q1 ; Process Meal Analysis
- +1 KILL ^TMP($JOB,"D"),^TMP($JOB,"M"),^TMP($JOB,"R")
- SET DAY=0
- Q2 SET DAY=$ORDER(^TMP($JOB,"RECIPES",DAY))
- if DAY<1
- QUIT
- SET M1=0
- SET (D(1),D(2),D(3),D(4),D(5))=""
- Q3 SET M1=$ORDER(^TMP($JOB,"RECIPES",DAY,M1))
- IF M1<1
- SET ^TMP($JOB,"D",DAY,1)=D(1)
- SET ^(2)=D(2)
- SET ^(4)=D(4)
- SET ^(5)=D(5)
- GOTO Q2
- +1 SET REC=0
- SET (T(1),T(2),T(3),T(4))=""
- ANAL ; Analyze
- +1 KILL A
- SET (AMT,PW)=0
- FOR KK=1:1:66
- SET A(KK)=0
- +2 SET REC=$ORDER(^TMP($JOB,"RECIPES",DAY,M1,REC))
- IF REC<1
- SET ^TMP($JOB,"M",DAY,M1,1)=T(1)
- SET ^(2)=T(2)
- SET ^(4)=T(4)
- DO ADD^FHNU9
- GOTO Q3
- +3 SET S1=$GET(^TMP($JOB,"RECIPES",DAY,M1,REC))
- SET SVG=+S1
- +4 IF '$DATA(^FH(114,REC,0))!('SVG)
- GOTO ANAL
- +5 SET RNAM=$EXTRACT($PIECE($GET(^FH(114,REC,0)),"^",1),1,18)
- SET K1=$PIECE(S1,"^",2)
- if 'K1
- GOTO ANAL
- +6 SET AMT=$PIECE($GET(^FHNU(K1,0)),"^",4)
- if 'AMT
- GOTO ANAL
- SET AMT=AMT*SVG
- SET PW=PW+AMT
- SET AMT=AMT/100
- +7 SET Y=$GET(^FHNU(K1,1))
- FOR K=1:1:20
- SET Z1=$PIECE(Y,"^",K)
- if Z1=""
- SET $PIECE(D(5),"^",K)=1
- IF Z1
- SET A(K)=$JUSTIFY(Z1*AMT,0,3)
- SET $PIECE(T(1),"^",K)=$PIECE(T(1),"^",K)+A(K)
- +8 SET Y=$GET(^FHNU(K1,2))
- FOR K=21:1:38
- SET Z1=$PIECE(Y,"^",K-20)
- if Z1=""
- SET $PIECE(D(5),"^",K)=1
- IF Z1
- SET A(K)=$JUSTIFY(Z1*AMT,0,3)
- SET $PIECE(T(2),"^",K-20)=$PIECE(T(2),"^",K-20)+A(K)
- +9 SET Y=$GET(^FHNU(K1,4))
- FOR K=65,66
- SET Z1=$PIECE(Y,"^",K-56)
- if Z1=""
- SET $PIECE(D(5),"^",K)=1
- IF Z1
- SET A(K)=$JUSTIFY(Z1*AMT,0,3)
- SET $PIECE(T(4),"^",K-56)=$PIECE(T(4),"^",K-56)+A(K)
- +10 if '$DATA(^TMP($JOB,"R",DAY,M1,RNAM,0))
- SET (^(0),^(1),^(2),^(3),^(4))=""
- +11 SET $PIECE(^TMP($JOB,"R",DAY,M1,RNAM,0),"^",1,2)=SVG_"^"_PW
- +12 FOR K=1:1:20
- SET $PIECE(^TMP($JOB,"R",DAY,M1,RNAM,1),"^",K)=A(K)
- +13 FOR K=21:1:38
- SET $PIECE(^TMP($JOB,"R",DAY,M1,RNAM,2),"^",K-20)=A(K)
- +14 FOR K=65,66
- SET $PIECE(^TMP($JOB,"R",DAY,M1,RNAM,4),"^",K-56)=A(K)
- +15 GOTO ANAL