source: FOIAVistA/trunk/r/DIETETICS-FH/FHPRC10.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.8 KB
Line 
1FHPRC10 ; HISC/NCA - Meal Analysis ;3/6/95 15:41
2 ;;5.5;DIETETICS;;Jan 28, 2005
3 K ^TMP($J)
4GET 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
5ED 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
6 I YN?1"N".E W ! G R3
7E1 ; Enter/Edit Day
8 R !,"Select DAY #: ",DAY:DTIME G:'$T!(DAY["^") KIL
9 I DAY="" S X3=$O(^TMP($J,"RECIPES",0)) G KIL:X3="",R3
10 I DAY'?1N!(DAY<1)!(DAY>7) W *7," Enter a Day # from 1-7" G E1
11E2 ; Enter/Edit Meal #
12 R !,"Select MEAL #: ",MEAL:DTIME G:'$T!(MEAL["^") KIL
13 I MEAL="" S X3=$O(^TMP($J,"RECIPES",0)) G KIL:X3="",E1
14 I MEAL'?1N!(MEAL<1)!(MEAL>6) W *7," Enter a Meal # from 1-6" G E2
15R0 ; Edit Meal File
16 S S1=$G(^TMP($J,"RECIPES",DAY,MEAL,0))
17 K DIC S DIC="^FH(116.1,",DIC(0)="EQM"
18 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
19 I X="@" K ^TMP($J,"RECIPES",DAY,MEAL) W " Meal Deleted" G E2
20 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
21 D ^DIC G:Y<1 R0 S M1=+Y K DIC
22S1 ; Edit Production Diet
23 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
24 S ZZ=M1_"^"_PD I S1=ZZ G:$D(^TMP($J,"RECIPES",DAY,MEAL)) R1
25 S $P(S1,"^",2)=PD
26 D SRCH^FHPRC14
27R1 ; Edit Recipe and Portion
28 K DIC S DIC="^FH(114,",DIC(0)="EQM"
29 R !!,"Select Recipe: ",X:DTIME G KIL:'$T!(X["^"),E2:X=""
30 I X="?" D LIS^FHPRC14 G R1
31 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)
32R2 W !,"Serving Portion: ",+$G(^TMP($J,"RECIPES",DAY,MEAL,REC))_"// " R X:DTIME G:'$T!(X["^") KIL G:X="" R1
33 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
34 S $P(^TMP($J,"RECIPES",DAY,MEAL,REC),"^",1)=X
35 G R1
36R3 ; Select RDA Category
37 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
38 S (AGE,NAM,SEX)=""
39F1 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
40 I $P($G(^DPT(DFN,.35)),"^",1) W *7,!!?5," [ Patient has expired. ]" G KIL
41 S AGE=$E(DT,1,3)-$E(AGE,1,3)-($E(DT,4,7)<$E(AGE,4,7))
42S3 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
43 S SUM=$E(SUM,1),SUM=SUM="N" K M
44 W !!,"The Analysis requires a 132 column printer.",!
45 K IOP,%ZIS S %ZIS("A")="Print on Device: ",%ZIS="MQ" W ! D ^%ZIS K %ZIS,IOP G:POP KIL
46 I $D(IO("Q")) D G KIL
47 .K IO("Q"),ZTUCI,ZTDTH,ZTIO,ZTSAVE
48 .S ZTRTN="^FHPRC11",ZTREQ="@",ZSAVE("ZTREQ")="",ZTDESC=$P($G(XQY0),U,1)
49 .F G="AGE","DAY","MEAL","MNAM","NAM","^TMP($J,","RDA","SEX","SUM" S ZTSAVE(G)=""
50 .D ^%ZTLOAD D ^%ZISC U IO W !,"Request Queued",! K ZTSK Q
51 U IO X ^%ZOSF("BRK") D ^FHPRC11 X ^%ZOSF("NBRK") D ^%ZISC K %ZIS,IOP G KIL
52PAT R !!,"Enter Patient's Name: ",NAM:DTIME G:'$T!("^"[NAM) KIL
53 I NAM["?"!(NAM'?.ANP)!(NAM["^") W *7,!?5,"Enter Patient's Name to be printed on the report." G PAT
54P1 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
55 S SEX=$E(SEX,1)
56P2 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
57 G S3
58KIL ; Kill all Used Variables
59 K ^TMP($J) G KILL^XUSCLEAN
Note: See TracBrowser for help on using the repository browser.