- FHREC6 ; HISC/REL/NCA - Recipe Analysis Output ;7/30/93 15:05
- ;;5.5;DIETETICS;;Jan 28, 2005
- K DIC S DIC="^FH(114,",DIC(0)="AEQM" W ! D ^DIC G:Y<1 KIL S REC=+Y
- S L1=$P($G(^FH(114,REC,0)),"^",14)
- I 'L1 W !!,"This Recipe has not been analyzed." G FHREC6
- K DIC S DIC="^FH(112.2,",DIC(0)="AEQM",DIC("A")="Select DRI Category: " W ! D ^DIC G:X["^"!$D(DTOUT) KIL S RDA=$S(Y<1:0,1:+Y) K DIC
- K IOP,%ZIS S %ZIS("A")="Print on Device: ",%ZIS="MQ" W ! D ^%ZIS K %ZIS,IOP G:POP KIL
- I $D(IO("Q")) S FHPGM="Q1^FHREC6",FHLST="L1^RDA^REC" D EN2^FH G FHREC6
- U IO D Q1 D ^%ZISC K %ZIS,IOP G FHREC6
- Q1 ; List Analysis
- S PW=$P($G(^FHNU(L1,0)),"^",4) Q:'PW
- S Y=$G(^FHNU(L1,1)) F K=1:1:20 S Z1=$P(Y,"^",K) I Z1'="" S A(K)=$J(Z1*PW/100,0,3)
- S Y=$G(^FHNU(L1,2)) F K=21:1:38 S Z1=$P(Y,"^",K-20) I Z1'="" S A(K)=$J(Z1*PW/100,0,3)
- S Y=$G(^FHNU(L1,3)) F K=39:1:56 S Z1=$P(Y,"^",K-38) I Z1'="" S A(K)=$J(Z1*PW/100,0,3)
- S Y=$G(^FHNU(L1,4)) F K=57:1:66 S Z1=$P(Y,"^",K-56) I Z1'="" S A(K)=$J(Z1*PW/100,0,3)
- S ZR=$S(RDA:^FH(112.2,RDA,1),1:""),TIT=$P($G(^FH(114,REC,0)),"^",1),ANS=""
- S Z1=4*A(1)+(9*A(2))+(4*A(3)) S:'Z1 Z1=1 F KK=1,3,2 S C(KK)=$J(A(KK)*$S(KK=2:900,1:400)/Z1,4,0)
- K B F KK=1:1:66 S B(KK)=0
- K M,N F KK=0:0 S KK=$O(^FH(114,REC,"R",KK)) Q:KK<1 S Y0=$G(^(KK,0)) D R1
- F KK=0:0 S KK=$O(^FH(114,REC,"I",KK)) Q:KK<1 S Y0=$G(^(KK,0)) I +Y0 S ER="A",NAM=$P($G(^FHING(+Y0,0)),"^",1) I NAM'="" D GET
- W:$E(IOST,1,2)="C-" @IOF W !?25,"--- Recipe Ingredient List ---",!!?(80-$L(TIT)\2),TIT
- W !!,"Number of Portions: ",$P($G(^FH(114,REC,0)),"^",2)
- W !!,"Ingredient",?34,"Amt In Lbs",?46,"Associated Nutrient",!
- S ER="A",CTR=0 D P1 Q:ANS="^"
- K M(ER) S R2="" F KK=0:0 S R2=$O(N(R2)) Q:R2="" S ER=$G(N(R2)) W !!,"Embedded Recipe: ",R2,!!,"Ingredient",?34,"Amt In LBS",?46,"Associated Nutrient",! S CTR=CTR+1 D P1 Q:ANS="^"
- D PSE Q:ANS="^" W @IOF,!?23,"--- Analysis of Recipe Portion ---",!!?(80-$L(TIT)\2),TIT,!!?34,"%",?39,"%",?76,"%",!
- W ?33,"DRI",?37,"Kcal",?75,"DRI",!
- F K=1:1:34 S Y=$T(COM+K^FHNU6),Z1=$P(Y,";",3) D LST
- D PSE Q:ANS="^" F K=35:1:70 S Y=$T(COM+K^FHNU6),Z1=$P(Y,";",3) D LST
- W !!,"Grams/Portion: ",PW D PSE W ! Q
- LST W:K#2 ! Q:'Z1 S T1=$S(K#2:0,1:42)
- W ?T1,$P(Y,";",4)," (",B(Z1),")" I B(Z1) W ?(T1+21),$J(A(Z1),7,$P(Y,";",6))," ",$P(Y,";",5)
- S Z2=$P(Y,";",7) I Z2,ZR'="",$D(A(Z1)) S Z2=A(Z1)/$P(ZR,U,Z2) W ?(T1+33),$J(Z2*100,3,0)
- I $D(C(Z1)) W ?(T1+37),C(Z1)
- Q
- R1 ; Embedded Recipe List
- S R1=+Y0 Q:'R1 S R2=$P($G(^FH(114,R1,0)),"^",1) Q:R2="" S ER=R1 S:'$D(N(R2)) N(R2)=R1
- F LL=0:0 S LL=$O(^FH(114,R1,"I",LL)) Q:LL<1 S Y0=$G(^(LL,0)) I +Y0 S NAM=$P($G(^FHING(+Y0,0)),"^",1) I NAM'="" D GET
- Q
- GET ; Set Ingredient List
- S K1=+$P(Y0,"^",3)
- S:'$D(M(ER,NAM)) M(ER,NAM)=$E($P($G(^FHNU(K1,0)),"^",1),1,33)_"^"_$P(Y0,"^",4)
- S Y=$G(^FHNU(K1,1)) F K=1:1:20 S Z1=$P(Y,"^",K) I Z1'="" S B(K)=B(K)+1
- S Y=$G(^FHNU(K1,2)) F K=21:1:38 S Z1=$P(Y,"^",K-20) I Z1'="" S B(K)=B(K)+1
- S Y=$G(^FHNU(K1,3)) F K=39:1:56 S Z1=$P(Y,"^",K-38) I Z1'="" S B(K)=B(K)+1
- S Y=$G(^FHNU(K1,4)) F K=57:1:66 S Z1=$P(Y,"^",K-56) I Z1'="" S B(K)=B(K)+1
- Q
- P1 S NAM=""
- F LL=0:0 S NAM=$O(M(ER,NAM)) Q:NAM="" D Q:ANS="^"
- .W !,$E(NAM,1,30),?32,$S($P(M(ER,NAM),"^",2):$J($P(M(ER,NAM),"^",2),10,3),1:$J("***",10)),?46,$S($P(M(ER,NAM),"^",1)'="":$P(M(ER,NAM),"^",1),1:"***")
- .S CTR=CTR+1 I CTR>18 D PSE S CTR=0
- .Q
- Q
- PSE I IOST?1"C-".E R !!,"Press RETURN to Continue ",X:DTIME W ! S:'$T!(X["^") ANS="^" Q:ANS="^" I "^"'[X W !,"Enter a RETURN to Continue." G PSE
- Q
- KIL G KILL^XUSCLEAN
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHREC6 3535 printed Mar 13, 2025@20:59:34 Page 2
- FHREC6 ; HISC/REL/NCA - Recipe Analysis Output ;7/30/93 15:05
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- +2 KILL DIC
- SET DIC="^FH(114,"
- SET DIC(0)="AEQM"
- WRITE !
- DO ^DIC
- if Y<1
- GOTO KIL
- SET REC=+Y
- +3 SET L1=$PIECE($GET(^FH(114,REC,0)),"^",14)
- +4 IF 'L1
- WRITE !!,"This Recipe has not been analyzed."
- GOTO FHREC6
- +5 KILL DIC
- SET DIC="^FH(112.2,"
- SET DIC(0)="AEQM"
- SET DIC("A")="Select DRI Category: "
- WRITE !
- DO ^DIC
- if X["^"!$DATA(DTOUT)
- GOTO KIL
- SET RDA=$SELECT(Y<1:0,1:+Y)
- KILL DIC
- +6 KILL IOP,%ZIS
- SET %ZIS("A")="Print on Device: "
- SET %ZIS="MQ"
- WRITE !
- DO ^%ZIS
- KILL %ZIS,IOP
- if POP
- GOTO KIL
- +7 IF $DATA(IO("Q"))
- SET FHPGM="Q1^FHREC6"
- SET FHLST="L1^RDA^REC"
- DO EN2^FH
- GOTO FHREC6
- +8 USE IO
- DO Q1
- DO ^%ZISC
- KILL %ZIS,IOP
- GOTO FHREC6
- Q1 ; List Analysis
- +1 SET PW=$PIECE($GET(^FHNU(L1,0)),"^",4)
- if 'PW
- QUIT
- +2 SET Y=$GET(^FHNU(L1,1))
- FOR K=1:1:20
- SET Z1=$PIECE(Y,"^",K)
- IF Z1'=""
- SET A(K)=$JUSTIFY(Z1*PW/100,0,3)
- +3 SET Y=$GET(^FHNU(L1,2))
- FOR K=21:1:38
- SET Z1=$PIECE(Y,"^",K-20)
- IF Z1'=""
- SET A(K)=$JUSTIFY(Z1*PW/100,0,3)
- +4 SET Y=$GET(^FHNU(L1,3))
- FOR K=39:1:56
- SET Z1=$PIECE(Y,"^",K-38)
- IF Z1'=""
- SET A(K)=$JUSTIFY(Z1*PW/100,0,3)
- +5 SET Y=$GET(^FHNU(L1,4))
- FOR K=57:1:66
- SET Z1=$PIECE(Y,"^",K-56)
- IF Z1'=""
- SET A(K)=$JUSTIFY(Z1*PW/100,0,3)
- +6 SET ZR=$SELECT(RDA:^FH(112.2,RDA,1),1:"")
- SET TIT=$PIECE($GET(^FH(114,REC,0)),"^",1)
- SET ANS=""
- +7 SET Z1=4*A(1)+(9*A(2))+(4*A(3))
- if 'Z1
- SET Z1=1
- FOR KK=1,3,2
- SET C(KK)=$JUSTIFY(A(KK)*$SELECT(KK=2:900,1:400)/Z1,4,0)
- +8 KILL B
- FOR KK=1:1:66
- SET B(KK)=0
- +9 KILL M,N
- FOR KK=0:0
- SET KK=$ORDER(^FH(114,REC,"R",KK))
- if KK<1
- QUIT
- SET Y0=$GET(^(KK,0))
- DO R1
- +10 FOR KK=0:0
- SET KK=$ORDER(^FH(114,REC,"I",KK))
- if KK<1
- QUIT
- SET Y0=$GET(^(KK,0))
- IF +Y0
- SET ER="A"
- SET NAM=$PIECE($GET(^FHING(+Y0,0)),"^",1)
- IF NAM'=""
- DO GET
- +11 if $EXTRACT(IOST,1,2)="C-"
- WRITE @IOF
- WRITE !?25,"--- Recipe Ingredient List ---",!!?(80-$LENGTH(TIT)\2),TIT
- +12 WRITE !!,"Number of Portions: ",$PIECE($GET(^FH(114,REC,0)),"^",2)
- +13 WRITE !!,"Ingredient",?34,"Amt In Lbs",?46,"Associated Nutrient",!
- +14 SET ER="A"
- SET CTR=0
- DO P1
- if ANS="^"
- QUIT
- +15 KILL M(ER)
- SET R2=""
- FOR KK=0:0
- SET R2=$ORDER(N(R2))
- if R2=""
- QUIT
- SET ER=$GET(N(R2))
- WRITE !!,"Embedded Recipe: ",R2,!!,"Ingredient",?34,"Amt In LBS",?46,"Associated Nutrient",!
- SET CTR=CTR+1
- DO P1
- if ANS="^"
- QUIT
- +16 DO PSE
- if ANS="^"
- QUIT
- WRITE @IOF,!?23,"--- Analysis of Recipe Portion ---",!!?(80-$LENGTH(TIT)\2),TIT,!!?34,"%",?39,"%",?76,"%",!
- +17 WRITE ?33,"DRI",?37,"Kcal",?75,"DRI",!
- +18 FOR K=1:1:34
- SET Y=$TEXT(COM+K^FHNU6)
- SET Z1=$PIECE(Y,";",3)
- DO LST
- +19 DO PSE
- if ANS="^"
- QUIT
- FOR K=35:1:70
- SET Y=$TEXT(COM+K^FHNU6)
- SET Z1=$PIECE(Y,";",3)
- DO LST
- +20 WRITE !!,"Grams/Portion: ",PW
- DO PSE
- WRITE !
- QUIT
- LST if K#2
- WRITE !
- if 'Z1
- QUIT
- SET T1=$SELECT(K#2:0,1:42)
- +1 WRITE ?T1,$PIECE(Y,";",4)," (",B(Z1),")"
- IF B(Z1)
- WRITE ?(T1+21),$JUSTIFY(A(Z1),7,$PIECE(Y,";",6))," ",$PIECE(Y,";",5)
- +2 SET Z2=$PIECE(Y,";",7)
- IF Z2
- IF ZR'=""
- IF $DATA(A(Z1))
- SET Z2=A(Z1)/$PIECE(ZR,U,Z2)
- WRITE ?(T1+33),$JUSTIFY(Z2*100,3,0)
- +3 IF $DATA(C(Z1))
- WRITE ?(T1+37),C(Z1)
- +4 QUIT
- R1 ; Embedded Recipe List
- +1 SET R1=+Y0
- if 'R1
- QUIT
- SET R2=$PIECE($GET(^FH(114,R1,0)),"^",1)
- if R2=""
- QUIT
- SET ER=R1
- if '$DATA(N(R2))
- SET N(R2)=R1
- +2 FOR LL=0:0
- SET LL=$ORDER(^FH(114,R1,"I",LL))
- if LL<1
- QUIT
- SET Y0=$GET(^(LL,0))
- IF +Y0
- SET NAM=$PIECE($GET(^FHING(+Y0,0)),"^",1)
- IF NAM'=""
- DO GET
- +3 QUIT
- GET ; Set Ingredient List
- +1 SET K1=+$PIECE(Y0,"^",3)
- +2 if '$DATA(M(ER,NAM))
- SET M(ER,NAM)=$EXTRACT($PIECE($GET(^FHNU(K1,0)),"^",1),1,33)_"^"_$PIECE(Y0,"^",4)
- +3 SET Y=$GET(^FHNU(K1,1))
- FOR K=1:1:20
- SET Z1=$PIECE(Y,"^",K)
- IF Z1'=""
- SET B(K)=B(K)+1
- +4 SET Y=$GET(^FHNU(K1,2))
- FOR K=21:1:38
- SET Z1=$PIECE(Y,"^",K-20)
- IF Z1'=""
- SET B(K)=B(K)+1
- +5 SET Y=$GET(^FHNU(K1,3))
- FOR K=39:1:56
- SET Z1=$PIECE(Y,"^",K-38)
- IF Z1'=""
- SET B(K)=B(K)+1
- +6 SET Y=$GET(^FHNU(K1,4))
- FOR K=57:1:66
- SET Z1=$PIECE(Y,"^",K-56)
- IF Z1'=""
- SET B(K)=B(K)+1
- +7 QUIT
- P1 SET NAM=""
- +1 FOR LL=0:0
- SET NAM=$ORDER(M(ER,NAM))
- if NAM=""
- QUIT
- Begin DoDot:1
- +2 WRITE !,$EXTRACT(NAM,1,30),?32,$SELECT($PIECE(M(ER,NAM),"^",2):$JUSTIFY($PIECE(M(ER,NAM),"^",2),10,3),1:$JUSTIFY("***",10)),?46,$SELECT($PIECE(M(ER,NAM),"^",1)'="":$PIECE(M(ER,NAM),"^",1),1:"***")
- +3 SET CTR=CTR+1
- IF CTR>18
- DO PSE
- SET CTR=0
- +4 QUIT
- End DoDot:1
- if ANS="^"
- QUIT
- +5 QUIT
- PSE IF IOST?1"C-".E
- READ !!,"Press RETURN to Continue ",X:DTIME
- WRITE !
- if '$TEST!(X["^")
- SET ANS="^"
- if ANS="^"
- QUIT
- IF "^"'[X
- WRITE !,"Enter a RETURN to Continue."
- GOTO PSE
- +1 QUIT
- KIL GOTO KILL^XUSCLEAN
