FHNU9 ; HISC/REL/NCA - Nutrient Analysis Utilities ;7/29/94 11:54
;;5.5;DIETETICS;;Jan 28, 2005
RDA ; Calculate RDA values
S ZR=^FH(112.2,RDA,1),KK=1
R1 S NODE=$E(NUT,KK) Q:'NODE S ITM=+$E(NUT,KK+1,KK+2) Q:'ITM S SIZ=$E(NUT,KK+3),Q=+$E(NUT,KK+5,KK+6),KK=KK+7 I 'Q S Q=$J("",SIZ) G R2
S Z1=$S(NODE=1:$P(X1,"^",ITM),NODE=2:$P(X2,"^",ITM-20),NODE=3:$P(X3,"^",ITM-38),1:$P(X4,"^",ITM-56))
S Q=$J($S($P(ZR,"^",Q):Z1/$P(ZR,"^",Q)*100,1:""),SIZ,0)
R2 W Q G R1
TOT ; Calculate total nutrient values
K ^TMP($J) S DAY=0
T1 S DAY=$O(^FHUM(MENU,1,DAY)) Q:DAY<1 S MEAL=0,(D(1),D(2),D(3),D(4),D(5))=""
T2 S MEAL=$O(^FHUM(MENU,1,DAY,1,MEAL)) I MEAL<1 S ^TMP($J,"D",DAY,1)=D(1),^(2)=D(2),^(4)=D(4),^(5)=D(5) G T1
S (ITM,NM)=0,(T(1),T(2),T(3),T(4))=""
T3 S ITM=$O(^FHUM(MENU,1,DAY,1,MEAL,1,ITM)) I ITM<1 S ^TMP($J,"M",DAY,MEAL,1)=T(1),^(2)=T(2),^(4)=T(4) D ADD G T2
S X=^FHUM(MENU,1,DAY,1,MEAL,1,ITM,0),Y(0)=^FHNU(+X,0),Y(1)=$G(^(1)),Y(2)=$G(^(2)),Y(4)=$G(^(4))
S AMT=$P(X,"^",2) I TYP="C" S AMT=AMT*$P(Y(0),"^",4)
S MUL=AMT/100 F K=1:1:20 S Z1=$P(Y(1),"^",K) S:Z1="" $P(D(5),"^",K)=1 I Z1 S Z1=$J(Z1*MUL,0,3),$P(Y(1),"^",K)=Z1,$P(T(1),"^",K)=$P(T(1),"^",K)+Z1
F K=1:1:18 S Z1=$P(Y(2),"^",K) S:Z1="" $P(D(5),"^",K+20)=1 I Z1 S Z1=$J(Z1*MUL,0,3),$P(Y(2),"^",K)=Z1,$P(T(2),"^",K)=$P(T(2),"^",K)+Z1
F K=9,10 S Z1=$P(Y(4),"^",K) S:Z1="" $P(D(5),"^",K+56)=1 I Z1 S Z1=$J(Z1*MUL,0,3),$P(Y(4),"^",K)=Z1,$P(T(4),"^",K)=$P(T(4),"^",K)+Z1
S NM=NM+1,^TMP($J,"I",DAY,MEAL,NM,0)=$E($P(^FHNU(+X,0),"^",1),1,15)_"^"_AMT
S ^TMP($J,"I",DAY,MEAL,NM,1)=Y(1),^(2)=Y(2),^(4)=Y(4) G T3
ADD ; Calculate Total Nutrient Values For a Day
F KK=1:1:20 S Z1=$P(T(1),"^",KK) I Z1 S $P(D(1),"^",KK)=$P(D(1),"^",KK)+Z1
F KK=1:1:18 S Z1=$P(T(2),"^",KK) I Z1 S $P(D(2),"^",KK)=$P(D(2),"^",KK)+Z1
F KK=9,10 S Z1=$P(T(4),"^",KK) I Z1 S $P(D(4),"^",KK)=$P(D(4),"^",KK)+Z1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHNU9 1868 printed Apr 09, 2024@21:00:02 Page 2
FHNU9 ; HISC/REL/NCA - Nutrient Analysis Utilities ;7/29/94 11:54
+1 ;;5.5;DIETETICS;;Jan 28, 2005
RDA ; Calculate RDA values
+1 SET ZR=^FH(112.2,RDA,1)
SET KK=1
R1 SET NODE=$EXTRACT(NUT,KK)
if 'NODE
QUIT
SET ITM=+$EXTRACT(NUT,KK+1,KK+2)
if 'ITM
QUIT
SET SIZ=$EXTRACT(NUT,KK+3)
SET Q=+$EXTRACT(NUT,KK+5,KK+6)
SET KK=KK+7
IF 'Q
SET Q=$JUSTIFY("",SIZ)
GOTO R2
+1 SET Z1=$SELECT(NODE=1:$PIECE(X1,"^",ITM),NODE=2:$PIECE(X2,"^",ITM-20),NODE=3:$PIECE(X3,"^",ITM-38),1:$PIECE(X4,"^",ITM-56))
+2 SET Q=$JUSTIFY($SELECT($PIECE(ZR,"^",Q):Z1/$PIECE(ZR,"^",Q)*100,1:""),SIZ,0)
R2 WRITE Q
GOTO R1
TOT ; Calculate total nutrient values
+1 KILL ^TMP($JOB)
SET DAY=0
T1 SET DAY=$ORDER(^FHUM(MENU,1,DAY))
if DAY<1
QUIT
SET MEAL=0
SET (D(1),D(2),D(3),D(4),D(5))=""
T2 SET MEAL=$ORDER(^FHUM(MENU,1,DAY,1,MEAL))
IF MEAL<1
SET ^TMP($JOB,"D",DAY,1)=D(1)
SET ^(2)=D(2)
SET ^(4)=D(4)
SET ^(5)=D(5)
GOTO T1
+1 SET (ITM,NM)=0
SET (T(1),T(2),T(3),T(4))=""
T3 SET ITM=$ORDER(^FHUM(MENU,1,DAY,1,MEAL,1,ITM))
IF ITM<1
SET ^TMP($JOB,"M",DAY,MEAL,1)=T(1)
SET ^(2)=T(2)
SET ^(4)=T(4)
DO ADD
GOTO T2
+1 SET X=^FHUM(MENU,1,DAY,1,MEAL,1,ITM,0)
SET Y(0)=^FHNU(+X,0)
SET Y(1)=$GET(^(1))
SET Y(2)=$GET(^(2))
SET Y(4)=$GET(^(4))
+2 SET AMT=$PIECE(X,"^",2)
IF TYP="C"
SET AMT=AMT*$PIECE(Y(0),"^",4)
+3 SET MUL=AMT/100
FOR K=1:1:20
SET Z1=$PIECE(Y(1),"^",K)
if Z1=""
SET $PIECE(D(5),"^",K)=1
IF Z1
SET Z1=$JUSTIFY(Z1*MUL,0,3)
SET $PIECE(Y(1),"^",K)=Z1
SET $PIECE(T(1),"^",K)=$PIECE(T(1),"^",K)+Z1
+4 FOR K=1:1:18
SET Z1=$PIECE(Y(2),"^",K)
if Z1=""
SET $PIECE(D(5),"^",K+20)=1
IF Z1
SET Z1=$JUSTIFY(Z1*MUL,0,3)
SET $PIECE(Y(2),"^",K)=Z1
SET $PIECE(T(2),"^",K)=$PIECE(T(2),"^",K)+Z1
+5 FOR K=9,10
SET Z1=$PIECE(Y(4),"^",K)
if Z1=""
SET $PIECE(D(5),"^",K+56)=1
IF Z1
SET Z1=$JUSTIFY(Z1*MUL,0,3)
SET $PIECE(Y(4),"^",K)=Z1
SET $PIECE(T(4),"^",K)=$PIECE(T(4),"^",K)+Z1
+6 SET NM=NM+1
SET ^TMP($JOB,"I",DAY,MEAL,NM,0)=$EXTRACT($PIECE(^FHNU(+X,0),"^",1),1,15)_"^"_AMT
+7 SET ^TMP($JOB,"I",DAY,MEAL,NM,1)=Y(1)
SET ^(2)=Y(2)
SET ^(4)=Y(4)
GOTO T3
ADD ; Calculate Total Nutrient Values For a Day
+1 FOR KK=1:1:20
SET Z1=$PIECE(T(1),"^",KK)
IF Z1
SET $PIECE(D(1),"^",KK)=$PIECE(D(1),"^",KK)+Z1
+2 FOR KK=1:1:18
SET Z1=$PIECE(T(2),"^",KK)
IF Z1
SET $PIECE(D(2),"^",KK)=$PIECE(D(2),"^",KK)+Z1
+3 FOR KK=9,10
SET Z1=$PIECE(T(4),"^",KK)
IF Z1
SET $PIECE(D(4),"^",KK)=$PIECE(D(4),"^",KK)+Z1
+4 QUIT
