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 Sep 23, 2025@19:30:16 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
