source: WorldVistAEHR/trunk/r/DIETETICS-FH/FHSEL4.m@ 701

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

initial load of WorldVistAEHR

File size: 2.7 KB
Line 
1FHSEL4 ; HISC/REL/NCA - Tabulate Food Preferences ;4/27/93 13:09
2 ;;5.5;DIETETICS;;Jan 28, 2005
3 S FHP=$O(^FH(119.73,0)) I FHP'<1,$O(^FH(119.73,FHP))<1 S FHP=0 G R1
4D0 R !!,"Select COMMUNICATION OFFICE (or ALL): ",X:DTIME G:'$T!("^"[X) KIL D:X="all" TR^FH I X="ALL" S FHP=0
5 E K DIC S DIC="^FH(119.73,",DIC(0)="EMQ" D ^DIC G:Y<1 D0 S FHP=+Y
6R1 R !!,"Select MEAL (B,N,E or ALL): ",MEAL:DTIME G:'$T!("^"[MEAL) KIL S X=MEAL D TR^FH S MEAL=X S:$P("ALL",MEAL,1)="" MEAL="A"
7 I "BNEA"'[MEAL!(MEAL'?1U) W *7,!,"Select B for Breakfast, N for Noon, E for Evening or ALL for all meals" G R1
8D1 W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
9 I $D(IO("Q")) S FHPGM="Q1^FHSEL4",FHLST="FHP^MEAL" D EN2^FH G KIL
10 U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
11Q1 D NOW^%DTC S NOW=%,PG=0 K ^TMP($J)
12 F WRD=0:0 S WRD=$O(^FH(119.6,WRD)) Q:WRD<1 S X=^(WRD,0),D2=+$P(X,"^",8) I D2,'FHP!(FHP=D2) S ^TMP($J,"W",D2,WRD)=""
13 F D2=0:0 S D2=$O(^TMP($J,"W",D2)) Q:D2<1 D W0
14 S DTP=NOW\1 D DTP^FH S H1=DTP D SES
15 I MEAL'="A" D Q2 Q
16 F MEAL="B","N","E" D Q2
17 Q
18Q2 K ^TMP($J,"L"),^TMP($J,"D") F Z=0:0 S Z=$O(^TMP($J,"P",MEAL,Z)) Q:Z<1 D C1
19 D HDR I $D(^TMP($J,"L")) S TP="L" W !!?(S1-9\2),"L I K E S",! D L0
20 I $D(^TMP($J,"D")) S TP="D" W !!?(S1-15\2),"D I S L I K E S",! D L0
21 W ! Q
22L0 S X1="" F LL=0:0 S X1=$O(^TMP($J,TP,X1)) Q:X1="" S Z=^(X1) I $D(^TMP($J,"P",MEAL,Z)) D L1
23 Q
24L1 D:$Y>(IOSL-6) HDR S TOT=0 W !,$P(^FH(115.2,Z,0),"^",1)
25 F D2=0:0 S D2=$O(^TMP($J,"P",MEAL,Z,D2)) Q:D2<1 S N1=^(D2) W ?(30+P(D2)),$J(N1,6) S TOT=TOT+N1
26 W ?S2,$J(TOT,7) Q
27SES K N,P S PD="",P0=0,N=0
28 F K=2:11 S P0=$O(^TMP($J,"W",P0)) Q:P0<1 S Y=$E($P(^FH(119.73,P0,0),"^",1),1,9),PD=PD_$J(Y_$E(" ",1,10-$L(Y)\2),9)_" ",P(P0)=K,N=N+1
29 S S2=31+$L(PD),S1=S2+7 Q
30C1 S X=$G(^FH(115.2,Z,0)),TP=$P(X,"^",2)
31 Q:TP="" S ^TMP($J,TP,$P(X,"^",1)_Z)=Z Q
32HDR W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 W !,H1,?(S1-29\2),"M E A L P R E F E R E N C E S",?(S1-6),"Page ",PG
33 S X=$S(MEAL="B":"B R E A K F A S T",MEAL="N":"N O O N",1:"E V E N I N G") W !!?(S1-$L(X)\2),X
34 W !!,"Preference",?32,PD," TOTAL"
35 S LN="",$P(LN,"-",S1+8)="" W !,LN Q
36KIL K ^TMP($J) G KILL^XUSCLEAN
37W0 F WRD=0:0 S WRD=$O(^TMP($J,"W",D2,WRD)) Q:WRD<1 D W2
38 Q
39W2 Q:$O(^FHPT("AW",WRD,0))<1 S WRDN=$P($G(^FH(119.6,WRD,0)),"^",1)
40 F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",WRD,FHDFN)) Q:FHDFN<1 S ADM=^FHPT("AW",WRD,FHDFN) I ADM>0 D W3
41 Q
42W3 Q:'$D(^FHPT(FHDFN,"A",ADM,0))
43 F K=0:0 S K=$O(^FHPT(FHDFN,"P",K)) Q:K<1 S Z=^(K,0),Z2=$P(Z,"^",2),QTY=$P(Z,"^",3),Z=+Z D W4
44 Q
45W4 I MEAL'="A" Q:Z2'[MEAL S:'$D(^TMP($J,"P",MEAL,Z,D2)) ^TMP($J,"P",MEAL,Z,D2)=0 S ^(D2)=^(D2)+$S(QTY:QTY,1:1) Q
46 F LL="B","N","E" I Z2[LL S:'$D(^TMP($J,"P",LL,Z,D2)) ^TMP($J,"P",LL,Z,D2)=0 S ^(D2)=^(D2)+$S(QTY:QTY,1:1)
47 Q
Note: See TracBrowser for help on using the repository browser.