FHADR61 ; HISC/NCA - Nutritive Analysis Average ;12/29/93 13:54
;;5.5;DIETETICS;;Jan 28, 2005
EN1 ; Enter/Edit Nutritive Analysis Average of one wk reg menu
D YR^FHADR1 G:'PRE KIL
S OLD=$P($G(^FH(117.3,PRE,3)),"^",2),Y=OLD X ^DD("DD") S OLD=Y
D1 S %DT="AEPX",%DT("A")="Enter Date Nutritive Analysis was taken: " S:OLD'="" %DT("B")=OLD W ! D ^%DT S:$D(DTOUT) X="^" G KIL:U[X,D1:Y<1 S SDT=+Y
I SDT'<DT W *7,!?29," [Must Start before Today!] " G D1
S YR=$E(SDT,1,3),S1=$E(SDT,4,5),QTR=$S(S1<4:2,S1<7:3,S1<10:4,1:1) S:QTR=1 YR=YR+1
I YR'=$E(PRE,1,3) W *7,!?29," [Date Is Not Within the Fiscal Year!] " G D1
S $P(^FH(117.3,PRE,3),"^",2)=SDT
K DIC,DIE S DIE="^FH(117.3,",DA=PRE,DR="41:46"
D ^DIE K DA,DIC,DIE,DR S OLD=PRE
SET ; Set all three quarters with the Nutritive Analysis Data
F QTR=2:1:4 S PRE=$E(OLD,1,4)_QTR_"00",$P(^FH(117.3,PRE,3),"^",2,8)=$P($G(^FH(117.3,OLD,3)),"^",2,8)
KIL G KILL^XUSCLEAN
EN2 ; Print the Nutritive Analysis Average of one wk reg menu
D HDR
S PRE=FHYR_"0000",X1=""
F L1=PRE:0 S L1=$O(^FH(117.3,L1)) Q:L1<1!($E(L1,1,3)'=$E(PRE,1,3)) S X=$P($G(^FH(117.3,L1,3)),"^",2,8) S:"^^^^^^"'[X X1=X
I X1'="" D
.S DTP=$P(X1,"^",1) D DTP^FH
.W !?100,"Date Taken: ",DTP,!!
.S TIT="Calories^%CHO^%PRO^%FAT^Mg CHOL^Mg Na"
.W ?30 F L2=1:1:6 W $P(TIT,"^",L2)_":",$J($P(X1,"^",L2+1),5)," "
.Q
Q
HDR ; Print Heading for Nutritive Analysis
D:$Y'<(LIN-6) HDR^FHADRPT,HDR2^FHADR3A
W !!!,"Nutritive Analysis 7 Days Average Regular Menu",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHADR61 1500 printed Oct 16, 2024@17:47:25 Page 2
FHADR61 ; HISC/NCA - Nutritive Analysis Average ;12/29/93 13:54
+1 ;;5.5;DIETETICS;;Jan 28, 2005
EN1 ; Enter/Edit Nutritive Analysis Average of one wk reg menu
+1 DO YR^FHADR1
if 'PRE
GOTO KIL
+2 SET OLD=$PIECE($GET(^FH(117.3,PRE,3)),"^",2)
SET Y=OLD
XECUTE ^DD("DD")
SET OLD=Y
D1 SET %DT="AEPX"
SET %DT("A")="Enter Date Nutritive Analysis was taken: "
if OLD'=""
SET %DT("B")=OLD
WRITE !
DO ^%DT
if $DATA(DTOUT)
SET X="^"
if U[X
GOTO KIL
if Y<1
GOTO D1
SET SDT=+Y
+1 IF SDT'<DT
WRITE *7,!?29," [Must Start before Today!] "
GOTO D1
+2 SET YR=$EXTRACT(SDT,1,3)
SET S1=$EXTRACT(SDT,4,5)
SET QTR=$SELECT(S1<4:2,S1<7:3,S1<10:4,1:1)
if QTR=1
SET YR=YR+1
+3 IF YR'=$EXTRACT(PRE,1,3)
WRITE *7,!?29," [Date Is Not Within the Fiscal Year!] "
GOTO D1
+4 SET $PIECE(^FH(117.3,PRE,3),"^",2)=SDT
+5 KILL DIC,DIE
SET DIE="^FH(117.3,"
SET DA=PRE
SET DR="41:46"
+6 DO ^DIE
KILL DA,DIC,DIE,DR
SET OLD=PRE
SET ; Set all three quarters with the Nutritive Analysis Data
+1 FOR QTR=2:1:4
SET PRE=$EXTRACT(OLD,1,4)_QTR_"00"
SET $PIECE(^FH(117.3,PRE,3),"^",2,8)=$PIECE($GET(^FH(117.3,OLD,3)),"^",2,8)
KIL GOTO KILL^XUSCLEAN
EN2 ; Print the Nutritive Analysis Average of one wk reg menu
+1 DO HDR
+2 SET PRE=FHYR_"0000"
SET X1=""
+3 FOR L1=PRE:0
SET L1=$ORDER(^FH(117.3,L1))
if L1<1!($EXTRACT(L1,1,3)'=$EXTRACT(PRE,1,3))
QUIT
SET X=$PIECE($GET(^FH(117.3,L1,3)),"^",2,8)
if "^^^^^^"'[X
SET X1=X
+4 IF X1'=""
Begin DoDot:1
+5 SET DTP=$PIECE(X1,"^",1)
DO DTP^FH
+6 WRITE !?100,"Date Taken: ",DTP,!!
+7 SET TIT="Calories^%CHO^%PRO^%FAT^Mg CHOL^Mg Na"
+8 WRITE ?30
FOR L2=1:1:6
WRITE $PIECE(TIT,"^",L2)_":",$JUSTIFY($PIECE(X1,"^",L2+1),5)," "
+9 QUIT
End DoDot:1
+10 QUIT
HDR ; Print Heading for Nutritive Analysis
+1 if $Y'<(LIN-6)
DO HDR^FHADRPT
DO HDR2^FHADR3A
+2 WRITE !!!,"Nutritive Analysis 7 Days Average Regular Menu",!
+3 QUIT
