- FHPRC10 ; HISC/NCA - Meal Analysis ;3/6/95 15:41
- ;;5.5;DIETETICS;;Jan 28, 2005
- K ^TMP($J)
- GET W ! K DIC S DIC="^FHUM(",DIC(0)="AEQMZ",DIC("S")="I $P(^(0),U,5)",DIC("DR")=".01" D ^DIC K DLAYGO G KIL:U[X!$D(DTOUT),GET:Y<1 S MENU=+Y,MNAM="Menu: "_$P(Y,U,2) D RET^FHPRC14
- ED R !!,"Do you wish to EDIT this Menu? NO// ",YN:DTIME G:'$T!(YN["^") KIL S:YN="" YN="N" S X=YN D TR^FH S YN=X I $P("YES",YN,1)'="",$P("NO",YN,1)'="" W *7," Answer YES or NO" G ED
- I YN?1"N".E W ! G R3
- E1 ; Enter/Edit Day
- R !,"Select DAY #: ",DAY:DTIME G:'$T!(DAY["^") KIL
- I DAY="" S X3=$O(^TMP($J,"RECIPES",0)) G KIL:X3="",R3
- I DAY'?1N!(DAY<1)!(DAY>7) W *7," Enter a Day # from 1-7" G E1
- E2 ; Enter/Edit Meal #
- R !,"Select MEAL #: ",MEAL:DTIME G:'$T!(MEAL["^") KIL
- I MEAL="" S X3=$O(^TMP($J,"RECIPES",0)) G KIL:X3="",E1
- I MEAL'?1N!(MEAL<1)!(MEAL>6) W *7," Enter a Meal # from 1-6" G E2
- R0 ; Edit Meal File
- S S1=$G(^TMP($J,"RECIPES",DAY,MEAL,0))
- K DIC S DIC="^FH(116.1,",DIC(0)="EQM"
- W !,"Select Meal: ",$S($P($G(^FH(116.1,+S1,0)),"^",1)'="":$P(^FH(116.1,+S1,0),"^",1)_" // ",1:"") R X:DTIME G:'$T!(X["^") KIL
- I X="@" K ^TMP($J,"RECIPES",DAY,MEAL) W " Meal Deleted" G E2
- I X="" S:S1'="" X=$P($G(^FH(116.1,+S1,0)),"^",1) I S1="" S X3=$O(^TMP($J,"RECIPES",0)) G KIL:X3="",E2
- D ^DIC G:Y<1 R0 S M1=+Y K DIC
- S1 ; Edit Production Diet
- K DIC S DIC="^FH(116.2,",DIC(0)="AEQMZ" S:$P(S1,"^",2) DIC("B")=$P($G(^FH(116.2,+$P(S1,"^",2),0)),"^",1) D ^DIC G KIL:U[X!$D(DTOUT),S1:Y<1 S PD=+Y,CODE=$P(Y(0),"^",2) K DIC
- S ZZ=M1_"^"_PD I S1=ZZ G:$D(^TMP($J,"RECIPES",DAY,MEAL)) R1
- S $P(S1,"^",2)=PD
- D SRCH^FHPRC14
- R1 ; Edit Recipe and Portion
- K DIC S DIC="^FH(114,",DIC(0)="EQM"
- R !!,"Select Recipe: ",X:DTIME G KIL:'$T!(X["^"),E2:X=""
- I X="?" D LIS^FHPRC14 G R1
- D ^DIC G:Y<1 R1 K DIC S REC=+Y S:'$D(^TMP($J,"RECIPES",DAY,MEAL,REC)) ^TMP($J,"RECIPES",DAY,MEAL,REC)=1_"^"_$P($G(^FH(114,REC,0)),"^",14)
- R2 W !,"Serving Portion: ",+$G(^TMP($J,"RECIPES",DAY,MEAL,REC))_"// " R X:DTIME G:'$T!(X["^") KIL G:X="" R1
- I X'?.N.1".".N!(X<0)!(X>9999) W *7,!,"Enter amount of serving portion. Enter 0 to omit recipe;",!,"otherwise enter a number greater than 0 but less than 9999." G R2
- S $P(^TMP($J,"RECIPES",DAY,MEAL,REC),"^",1)=X
- G R1
- R3 ; Select RDA Category
- K DIC S DIC="^FH(112.2,",DIC(0)="AEQM",DIC("A")="Select DRI Category: " W ! D ^DIC G:X[U!$D(DTOUT) KIL S RDA=$S(Y<1:0,1:+Y) K DIC
- S (AGE,NAM,SEX)=""
- F1 S ALL=1 D ^FHDPA G PAT:X="*",S3:X="",KIL:'DFN S NAM=$P(Y(0),U,1),SEX=$P(Y(0),U,2),AGE=$P(Y(0),U,3) G:SEX=""!(AGE="") P1
- I $P($G(^DPT(DFN,.35)),"^",1) W *7,!!?5," [ Patient has expired. ]" G KIL
- S AGE=$E(DT,1,3)-$E(AGE,1,3)-($E(DT,4,7)<$E(AGE,4,7))
- S3 R !!,"Do you wish a detailed analysis? Y// ",SUM:DTIME G:'$T!(SUM["^") KIL S:SUM="" SUM="Y" S X=SUM D TR^FH S SUM=X I $P("YES",SUM,1)'="",$P("NO",SUM,1)'="" W *7,!," Answer YES or NO" G S3
- S SUM=$E(SUM,1),SUM=SUM="N" K M
- W !!,"The Analysis requires a 132 column printer.",!
- K IOP,%ZIS S %ZIS("A")="Print on Device: ",%ZIS="MQ" W ! D ^%ZIS K %ZIS,IOP G:POP KIL
- I $D(IO("Q")) D G KIL
- .K IO("Q"),ZTUCI,ZTDTH,ZTIO,ZTSAVE
- .S ZTRTN="^FHPRC11",ZTREQ="@",ZSAVE("ZTREQ")="",ZTDESC=$P($G(XQY0),U,1)
- .F G="AGE","DAY","MEAL","MNAM","NAM","^TMP($J,","RDA","SEX","SUM" S ZTSAVE(G)=""
- .D ^%ZTLOAD D ^%ZISC U IO W !,"Request Queued",! K ZTSK Q
- U IO X ^%ZOSF("BRK") D ^FHPRC11 X ^%ZOSF("NBRK") D ^%ZISC K %ZIS,IOP G KIL
- PAT R !!,"Enter Patient's Name: ",NAM:DTIME G:'$T!("^"[NAM) KIL
- I NAM["?"!(NAM'?.ANP)!(NAM["^") W *7,!?5,"Enter Patient's Name to be printed on the report." G PAT
- P1 R !,"Sex: ",SEX:DTIME G:'$T!("^"[SEX) KIL S X=SEX D TR^FH S SEX=X I $P("MALE",SEX,1)'="",$P("FEMALE",SEX,1)'="" W *7," Enter M or F" G P1
- S SEX=$E(SEX,1)
- P2 R !,"Age: ",AGE:DTIME G:'$T!("^"[AGE) KIL I AGE'?1N.N!(AGE<6)!(AGE>124) W !?5,"Enter Age in years between 6 and 124" G P2
- G S3
- KIL ; Kill all Used Variables
- K ^TMP($J) G KILL^XUSCLEAN
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHPRC10 3924 printed Feb 18, 2025@23:20:34 Page 2
- FHPRC10 ; HISC/NCA - Meal Analysis ;3/6/95 15:41
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- +2 KILL ^TMP($JOB)
- GET WRITE !
- KILL DIC
- SET DIC="^FHUM("
- SET DIC(0)="AEQMZ"
- SET DIC("S")="I $P(^(0),U,5)"
- SET DIC("DR")=".01"
- DO ^DIC
- KILL DLAYGO
- if U[X!$DATA(DTOUT)
- GOTO KIL
- if Y<1
- GOTO GET
- SET MENU=+Y
- SET MNAM="Menu: "_$PIECE(Y,U,2)
- DO RET^FHPRC14
- ED READ !!,"Do you wish to EDIT this Menu? NO// ",YN:DTIME
- if '$TEST!(YN["^")
- GOTO KIL
- if YN=""
- SET YN="N"
- SET X=YN
- DO TR^FH
- SET YN=X
- IF $PIECE("YES",YN,1)'=""
- IF $PIECE("NO",YN,1)'=""
- WRITE *7," Answer YES or NO"
- GOTO ED
- +1 IF YN?1"N".E
- WRITE !
- GOTO R3
- E1 ; Enter/Edit Day
- +1 READ !,"Select DAY #: ",DAY:DTIME
- if '$TEST!(DAY["^")
- GOTO KIL
- +2 IF DAY=""
- SET X3=$ORDER(^TMP($JOB,"RECIPES",0))
- if X3=""
- GOTO KIL
- GOTO R3
- +3 IF DAY'?1N!(DAY<1)!(DAY>7)
- WRITE *7," Enter a Day # from 1-7"
- GOTO E1
- E2 ; Enter/Edit Meal #
- +1 READ !,"Select MEAL #: ",MEAL:DTIME
- if '$TEST!(MEAL["^")
- GOTO KIL
- +2 IF MEAL=""
- SET X3=$ORDER(^TMP($JOB,"RECIPES",0))
- if X3=""
- GOTO KIL
- GOTO E1
- +3 IF MEAL'?1N!(MEAL<1)!(MEAL>6)
- WRITE *7," Enter a Meal # from 1-6"
- GOTO E2
- R0 ; Edit Meal File
- +1 SET S1=$GET(^TMP($JOB,"RECIPES",DAY,MEAL,0))
- +2 KILL DIC
- SET DIC="^FH(116.1,"
- SET DIC(0)="EQM"
- +3 WRITE !,"Select Meal: ",$SELECT($PIECE($GET(^FH(116.1,+S1,0)),"^",1)'="":$PIECE(^FH(116.1,+S1,0),"^",1)_" // ",1:"")
- READ X:DTIME
- if '$TEST!(X["^")
- GOTO KIL
- +4 IF X="@"
- KILL ^TMP($JOB,"RECIPES",DAY,MEAL)
- WRITE " Meal Deleted"
- GOTO E2
- +5 IF X=""
- if S1'=""
- SET X=$PIECE($GET(^FH(116.1,+S1,0)),"^",1)
- IF S1=""
- SET X3=$ORDER(^TMP($JOB,"RECIPES",0))
- if X3=""
- GOTO KIL
- GOTO E2
- +6 DO ^DIC
- if Y<1
- GOTO R0
- SET M1=+Y
- KILL DIC
- S1 ; Edit Production Diet
- +1 KILL DIC
- SET DIC="^FH(116.2,"
- SET DIC(0)="AEQMZ"
- if $PIECE(S1,"^",2)
- SET DIC("B")=$PIECE($GET(^FH(116.2,+$PIECE(S1,"^",2),0)),"^",1)
- DO ^DIC
- if U[X!$DATA(DTOUT)
- GOTO KIL
- if Y<1
- GOTO S1
- SET PD=+Y
- SET CODE=$PIECE(Y(0),"^",2)
- KILL DIC
- +2 SET ZZ=M1_"^"_PD
- IF S1=ZZ
- if $DATA(^TMP($JOB,"RECIPES",DAY,MEAL))
- GOTO R1
- +3 SET $PIECE(S1,"^",2)=PD
- +4 DO SRCH^FHPRC14
- R1 ; Edit Recipe and Portion
- +1 KILL DIC
- SET DIC="^FH(114,"
- SET DIC(0)="EQM"
- +2 READ !!,"Select Recipe: ",X:DTIME
- if '$TEST!(X["^")
- GOTO KIL
- if X=""
- GOTO E2
- +3 IF X="?"
- DO LIS^FHPRC14
- GOTO R1
- +4 DO ^DIC
- if Y<1
- GOTO R1
- KILL DIC
- SET REC=+Y
- if '$DATA(^TMP($JOB,"RECIPES",DAY,MEAL,REC))
- SET ^TMP($JOB,"RECIPES",DAY,MEAL,REC)=1_"^"_$PIECE($GET(^FH(114,REC,0)),"^",14)
- R2 WRITE !,"Serving Portion: ",+$GET(^TMP($JOB,"RECIPES",DAY,MEAL,REC))_"// "
- READ X:DTIME
- if '$TEST!(X["^")
- GOTO KIL
- if X=""
- GOTO R1
- +1 IF X'?.N.1".".N!(X<0)!(X>9999)
- WRITE *7,!,"Enter amount of serving portion. Enter 0 to omit recipe;",!,"otherwise enter a number greater than 0 but less than 9999."
- GOTO R2
- +2 SET $PIECE(^TMP($JOB,"RECIPES",DAY,MEAL,REC),"^",1)=X
- +3 GOTO R1
- R3 ; Select RDA Category
- +1 KILL DIC
- SET DIC="^FH(112.2,"
- SET DIC(0)="AEQM"
- SET DIC("A")="Select DRI Category: "
- WRITE !
- DO ^DIC
- if X[U!$DATA(DTOUT)
- GOTO KIL
- SET RDA=$SELECT(Y<1:0,1:+Y)
- KILL DIC
- +2 SET (AGE,NAM,SEX)=""
- F1 SET ALL=1
- DO ^FHDPA
- if X="*"
- GOTO PAT
- if X=""
- GOTO S3
- if 'DFN
- GOTO KIL
- SET NAM=$PIECE(Y(0),U,1)
- SET SEX=$PIECE(Y(0),U,2)
- SET AGE=$PIECE(Y(0),U,3)
- if SEX=""!(AGE="")
- GOTO P1
- +1 IF $PIECE($GET(^DPT(DFN,.35)),"^",1)
- WRITE *7,!!?5," [ Patient has expired. ]"
- GOTO KIL
- +2 SET AGE=$EXTRACT(DT,1,3)-$EXTRACT(AGE,1,3)-($EXTRACT(DT,4,7)<$EXTRACT(AGE,4,7))
- S3 READ !!,"Do you wish a detailed analysis? Y// ",SUM:DTIME
- if '$TEST!(SUM["^")
- GOTO KIL
- if SUM=""
- SET SUM="Y"
- SET X=SUM
- DO TR^FH
- SET SUM=X
- IF $PIECE("YES",SUM,1)'=""
- IF $PIECE("NO",SUM,1)'=""
- WRITE *7,!," Answer YES or NO"
- GOTO S3
- +1 SET SUM=$EXTRACT(SUM,1)
- SET SUM=SUM="N"
- KILL M
- +2 WRITE !!,"The Analysis requires a 132 column printer.",!
- +3 KILL IOP,%ZIS
- SET %ZIS("A")="Print on Device: "
- SET %ZIS="MQ"
- WRITE !
- DO ^%ZIS
- KILL %ZIS,IOP
- if POP
- GOTO KIL
- +4 IF $DATA(IO("Q"))
- Begin DoDot:1
- +5 KILL IO("Q"),ZTUCI,ZTDTH,ZTIO,ZTSAVE
- +6 SET ZTRTN="^FHPRC11"
- SET ZTREQ="@"
- SET ZSAVE("ZTREQ")=""
- SET ZTDESC=$PIECE($GET(XQY0),U,1)
- +7 FOR G="AGE","DAY","MEAL","MNAM","NAM","^TMP($J,","RDA","SEX","SUM"
- SET ZTSAVE(G)=""
- +8 DO ^%ZTLOAD
- DO ^%ZISC
- USE IO
- WRITE !,"Request Queued",!
- KILL ZTSK
- QUIT
- End DoDot:1
- GOTO KIL
- +9 USE IO
- XECUTE ^%ZOSF("BRK")
- DO ^FHPRC11
- XECUTE ^%ZOSF("NBRK")
- DO ^%ZISC
- KILL %ZIS,IOP
- GOTO KIL
- PAT READ !!,"Enter Patient's Name: ",NAM:DTIME
- if '$TEST!("^"[NAM)
- GOTO KIL
- +1 IF NAM["?"!(NAM'?.ANP)!(NAM["^")
- WRITE *7,!?5,"Enter Patient's Name to be printed on the report."
- GOTO PAT
- P1 READ !,"Sex: ",SEX:DTIME
- if '$TEST!("^"[SEX)
- GOTO KIL
- SET X=SEX
- DO TR^FH
- SET SEX=X
- IF $PIECE("MALE",SEX,1)'=""
- IF $PIECE("FEMALE",SEX,1)'=""
- WRITE *7," Enter M or F"
- GOTO P1
- +1 SET SEX=$EXTRACT(SEX,1)
- P2 READ !,"Age: ",AGE:DTIME
- if '$TEST!("^"[AGE)
- GOTO KIL
- IF AGE'?1N.N!(AGE<6)!(AGE>124)
- WRITE !?5,"Enter Age in years between 6 and 124"
- GOTO P2
- +1 GOTO S3
- KIL ; Kill all Used Variables
- +1 KILL ^TMP($JOB)
- GOTO KILL^XUSCLEAN