source: WorldVistAEHR/trunk/r/DIETETICS-FH/FHMTK21.m

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

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1FHMTK21 ; HISC/NCA - List Diet Patterns (cont.) ;5/1/95 11:46
2 ;;5.5;DIETETICS;;Jan 28, 2005
3L1 ; List the Diet Pattern(s)
4 K ^TMP($J) D NOW^%DTC S DTP=% D DTP^FH S PG=0,RES="" D HDR
5 I ANS'?1"Y".E S MP=+FHDA,X=$G(^FH(111.1,MP,0)) D L2 G PRT
6 F MP=0:0 S MP=$O(^FH(111.1,MP)) Q:MP<1 S X=$G(^(MP,0)) D L2
7 G PRT
8L2 S PD=$P(X,"^",7) Q:'PD
9 S NAM=$P(X,"^",1),FHPD=$P($G(^FH(116.2,PD,0)),"^",1),NM=$P(X,"^",8),SF=$P($G(^FH(118.1,+NM,0)),"^",1)
10 S P0=$P($G(^FH(116.2,PD,0)),"^",6),P0=$S('P0:99,P0<10:"0"_P0,1:P0)
11 S P0=P0_"~"_FHPD
12 S:'$D(^TMP($J,"FHPD",P0)) ^TMP($J,"FHPD",P0)=PD S M0=NAM
13 S ^TMP($J,"FHO",PD,M0)=MP_"^"_SF
14 F MEAL="B","N","E" D L3
15 F MEAL="BS","NS","ES" D L5
16 F R1=0:0 S R1=$O(^FH(111.1,MP,"RES",R1)) Q:R1<1 S FP=$G(^(R1,0)) D
17 .Q:$P(FP,"^",2)=""
18 .S K1=99_R1,K1=K1_"~"_$E($P($G(^FH(115.2,+FP,0)),"^",1),1,30)
19 .F MEAL="B","N","E" I $P(FP,"^",2)[MEAL S ^TMP($J,"FHFP",MP,MEAL,K1)=""
20 .Q
21 Q
22L3 ; Get Diet pattern in print order
23 S LP=0
24L4 S LP=$O(^FH(111.1,MP,MEAL,LP)) Q:LP<1 S R1=$G(^(LP,0))
25 S K1=$P($G(^FH(114.1,+R1,0)),"^",3)
26 S K1=$S('K1:99,K1<10:"0"_K1,1:K1)
27 S K1=K1_"~"_$E($P($G(^FH(114.1,+R1,0)),"^",1),1,15)
28 S ^TMP($J,"FHMP",MP,MEAL,K1)=$P(R1,"^",2)_"^"_+R1
29 G L4
30L5 ; Get Standing Orders associated with Diet pattern
31 S LP=0
32L6 S LP=$O(^FH(111.1,MP,MEAL,LP)) Q:LP<1 S R1=$G(^(LP,0))
33 S K1=99_LP,K1=K1_"~"_$E($P($G(^FH(118.3,+R1,0)),"^",1),1,30)
34 S ^TMP($J,"FHMP",MP,$E(MEAL,1),K1)=$P(R1,"^",2)_"^"_+R1
35 G L6
36PRT ; Print Diet Pattern
37 S P0="" F S P0=$O(^TMP($J,"FHPD",P0)) Q:P0=""!(RES="^") S PD=+$G(^(P0)),M0="" F S M0=$O(^TMP($J,"FHO",PD,M0)) Q:M0="" S MP=+$G(^(M0)),SF=$P($G(^(M0)),"^",2) D P1,P2 Q:RES="^"
38 Q
39P1 K MM S CTR=0 F MEAL="B","N","E" S N1=0,CTR=CTR+1 D
40 .S NX="" F S NX=$O(^TMP($J,"FHMP",MP,MEAL,NX)) Q:NX="" S QTY=$G(^(NX)) D
41 ..S QTY=$S(QTY="":1,1:+QTY),N1=N1+1
42 ..S PAD=$E(" ",1,4-$L(QTY)),MM(N1,CTR)=PAD_QTY_" "_$E($P(NX,"~",2),1,21)
43 ..;S MM(N1,CTR)=$S(QTY#1>0:$J(QTY,3,1),1:QTY_" ")_" "_$E($P(NX,"~",2),1,21)
44 ..Q
45 .S R1="" F S R1=$O(^TMP($J,"FHFP",MP,MEAL,R1)) Q:R1="" S N1=N1+1,MM(N1,CTR)=$J("",4)_$E($P(R1,"~",2),1,21)
46 .Q
47 Q
48P2 I $Y'<(IOSL-8) D HDR Q:RES="^"
49 W !!,"Production Diet: ",$P(P0,"~",2),!,"Diet Order: ",M0
50 W !,"Associated Supp. Fdgs. Menu: ",$E(SF,1,30),!
51 W ! F N1=1:1 W ! Q:'$D(MM(N1))!(RES="^") F CTR=1:1:3 I $D(MM(N1,CTR)) D Q:RES="^"
52 .I $Y'<(IOSL-6) D HDR Q:RES="^"
53 .W ?$S(CTR=1:0,CTR=2:27,1:54),MM(N1,CTR) Q
54 Q
55HDR D PAUSE Q:RES="^" W:'($E(IOST,1,2)'="C-"&'PG) @IOF
56 S PG=PG+1 W !,DTP,?23,"D I E T P A T T E R N L I S T",?73,"Page ",PG
57 W !,"-------------------------------------------------------------------------------",!
58 W ! F CT=1:1:3 W ?$S(CT=1:8,CT=2:38,1:63),$S(CT=1:"BREAKFAST",CT=2:"NOON",1:"EVENING")
59 W ! Q
60PAUSE ; Check to pause for reading
61 I PG,IOST?1"C-".E R !!,"Press RETURN to continue or ""^"" to exit. ",RES:DTIME S:'$T!(RES["^") RES="^" Q:RES="^" I "^"'[RES W !,"Enter Return or ""^""." G PAUSE
62 Q
Note: See TracBrowser for help on using the repository browser.