source: FOIAVistA/trunk/r/DIETETICS-FH/FHDCR11.m@ 761

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

initial load of FOIAVistA 6/30/08 version

File size: 5.6 KB
Line 
1FHDCR11 ; HISC/REL/NCA/RVD - Build Diet Cards (Cont.) ;3/27/96 10:20
2 ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
3 ;patch #5 - added outpatient SO and fix diet pattern for outpatient.
4BLD ; Build Diet Card list for a patient
5 S X1=$G(^FHPT(+FHDFN,"A",+ADM,0)),FHORD=$P(X1,"^",2),SVC=$P(X1,"^",5),SF=$P(X1,"^",7),IS=$P(X1,"^",10),FHD=$P(X1,"^",16),(FHOR,X)=""
6 I FHPAR'="Y" Q:SVC="C"
7 I SVC="C" S:SP'=SP1 SP=SP1 Q:'SP
8 Q:'FHORD S X=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
9 S MPD=$P(X,"^",13),FHOR=$P(X,"^",2,6) Q:"^^^^"[FHOR
10 I IS S IS=$G(^FH(119.4,+IS,0)) S:IS'="" SVC=SVC_"-"_$P(IS,"^",2)_$P(IS,"^",3)
11 S:SF SVC=SVC_" "_"SF"_"("_$S($P($G(^FHPT(FHDFN,"A",ADM,"SF",+SF,0)),"^",34)="Y":"M",1:"I")_")"
12 I UPD D OLD^FHMTK11 I OLD=FHOR S FLG2=0 D EVT^FHDCR2 Q:'FLG2
13 S STR=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,2))
14 S DPAT=$O(^FH(111.1,"AB",FHOR,0))
15 F MEAL="B","N","E" D
16 .K FP(MEAL),MP(MEAL),N2(MEAL) I $P(STR,";",$S(MEAL="B":1,MEAL="N":2,1:3))'="" D DECOD^FHDCR1B
17 .S PD=MPD
18 .I DPAT S PD=$P($G(^FH(111.1,DPAT,0)),"^",7) D
19 ..I $P(STR,";",$S(MEAL="B":1,MEAL="N":2,1:3))="",$O(MP(MEAL,""))="" F X8=0:0 S X8=$O(^FH(111.1,DPAT,MEAL,X8)) Q:X8<1 S Z1=$G(^(X8,0)) D
20 ...S ZZ=$G(^FH(114.1,+Z1,0)),NAM=$P(ZZ,"^",1)
21 ...S K4=$P(ZZ,"^",3),K4=$S('K4:99,K4<10:"0"_K4,1:K4)
22 ...S MP(MEAL,K4_"~"_+Z1_"~"_NAM)=$P(Z1,"^",2) Q
23 ..Q
24 .Q:PD="" S PD=$P($G(^FH(116.2,PD,0)),"^",2) Q:PD=""
25 I NBR=2 D PRT^FHDCR1C K ^TMP($J,"MP"),^TMP($J,0),PP,S,TT S NBR=0
26 Q:PD="" S NBR=NBR+1 D PID^FHDPA
27 S Y0=$P($G(^DPT(DFN,0)),"^",1)_" ("_BID_")"_" "_SVC,N1=0,S(NBR)=0
28 D CUR^FHORD7
29 S N1=N1+1 I $L(Y)<60 S PP(N1,NBR)=Y
30 E S L=$S($L($P(Y,",",1,4))<60:4,1:3) S PP(N1,NBR)=$P(Y,",",1,L),N1=N1+1,PP(N1,NBR)=$E($P(Y,",",L+1,5),2,99)
31 S ^TMP($J,0,NBR)=Y0_"^"_WRDN_"^"_RM
32 I $G(DFN) D ALG^FHCLN S ALG="ALLGS.: "_$S(ALG="":"NONE ON FILE",1:ALG) S J=0 D BRK^FHDCR1B
33 S S(NBR)=S(NBR)+1
34 S ^TMP($J,"MP",S(NBR),NBR)=" Breakfast Noon Evening"
35 K NN F MEAL="B","N","E" D
36 .S X8="" F S X8=$O(MP(MEAL,X8)) Q:X8="" S X1=+$G(MP(MEAL,X8)) D
37 ..;Q:'X1 S Z1=$P(X8,"~",2),QTY=$S(+X1#1>0:$J(+X1,3,1),1:+X1_" ")_" "
38 ..Q:'X1 S Z1=$P(X8,"~",2),PAD=$E(" ",1,5-$L(X1)),QTY=+X1_PAD
39 ..S NN(MEAL,X8)=QTY_$E($P(X8,"~",3),1,15)
40 ..Q
41 .Q
42 K TT,SRT F MEAL="B","N","E" D
43 .S TT(MEAL)=0
44 .S X8="" F S X8=$O(NN(MEAL,X8)) Q:X8="" D
45 ..S TT(MEAL)=TT(MEAL)+1,SRT(TT(MEAL),MEAL)=$G(NN(MEAL,X8)) Q
46 .D SO^FHDCR1B,DISL^FHDCR1B Q
47 F N1=1:1 Q:'$D(SRT(N1)) D
48 .S STR="" F MEAL="B","N","E" D
49 ..I '$D(SRT(N1,MEAL)) S STR=STR_$J("",20) Q
50 ..S STR=STR_SRT(N1,MEAL)
51 ..S:MEAL'="E" STR=STR_$J("",20-$L(SRT(N1,MEAL)))
52 ..Q
53 .S S(NBR)=S(NBR)+1
54 .S ^TMP($J,"MP",S(NBR),NBR)=STR
55 .Q
56 ;
57OUT ;OUTPATIENT data
58 S (SVC,SF,IS)=""
59 I '$D(FHKDAT)!'$G(FHADM) Q
60 S X1=FHKDAT
61 S FHWARD=W1 D LOC
62 S (FHOR,FHORD)=$P(FHKDAT,U,2),FHD=$P(X1,"^",14)
63 I FHPAR'="Y" Q:SVC="C"
64 I SVC="C" S:SP'=SP1 SP=SP1 Q:'SP
65 I FHORD="" S FHORD=$P(FHKDAT,U,7,11)
66 S:$D(^FHPT(FHDFN,0)) IS=$P(^FHPT(FHDFN,0),U,5)
67 I $D(^FHPT(FHDFN,"OP",FHADM,"SF",0)) S SF=$P(^(0),U,3)
68 I IS S IS=$G(^FH(119.4,+IS,0)) S:IS'="" SVC=SVC_"-"_$P(IS,"^",2)_$P(IS,"^",3)
69 I SF,$D(^FHPT(FHDFN,"OP",FHADM,"SF",SF,0)),'$P(^(0),U,32) S SVC=SVC_" "_"SF"_"("_$S($P($G(^FHPT(FHDFN,"OP",FHADM,"SF",SF,0)),"^",34)="Y":"M",1:"I")_")"
70 I UPD D OLD^FHMTK11 I OLD=FHOR S FLG2=0 D EVT^FHDCR2 Q:'FLG2
71 S STR=""
72 S:$G(FHOR) FHOR=FHOR_"^^^^"
73 I FHOR="" S FHOR=$P(FHKDAT,U,7,11)
74 ;
75 S DPAT=$O(^FH(111.1,"AB",FHOR,0))
76 F MEAL="B","N","E" D
77 .Q:FHMEAL'=MEAL
78 .K FP(MEAL),MP(MEAL),N2(MEAL)
79 .S PD=""
80 .S:$G(MPD) PD=MPD
81 .I DPAT S PD=$P($G(^FH(111.1,DPAT,0)),"^",7) D
82 ..F X8=0:0 S X8=$O(^FH(111.1,DPAT,MEAL,X8)) Q:X8<1 S Z1=$G(^(X8,0)) D
83 ...S ZZ=$G(^FH(114.1,+Z1,0)),NAM=$P(ZZ,"^",1)
84 ...S K4=$P(ZZ,"^",3),K4=$S('K4:99,K4<10:"0"_K4,1:K4)
85 ...S MP(MEAL,K4_"~"_+Z1_"~"_NAM)=$P(Z1,"^",2)
86 ..Q
87 .Q:PD="" S PD=$P($G(^FH(116.2,PD,0)),"^",2) Q:PD=""
88 I NBR=2 D PRT^FHDCR1C K ^TMP($J,"MP"),^TMP($J,0),PP,S,TT,SRT S (N1,NBR)=0
89 Q:PD="" S NBR=NBR+1 D PATNAME^FHOMUTL
90 S Y0=FHPTNM_" ("_FHBID_")"_" "_SVC,N1=0,S(NBR)=0,Y="***"
91 I '$G(FHDIET) S FHRNUM=FHKD D DIETPAT^FHOMRR1 S Y=$E(FHDIETP,1,18)
92 S:$G(FHDIET) Y=$P(^FH(111,FHDIET,0),U,7)
93 S N1=N1+1 I $L(Y)<60 S PP(N1,NBR)=Y
94 E S L=$S($L($P(Y,",",1,4))<60:4,1:3) S PP(N1,NBR)=$P(Y,",",1,L),N1=N1+1,PP(N1,NBR)=$E($P(Y,",",L+1,5),2,99)
95 S ^TMP($J,0,NBR)=Y0_"^"_WRDN_"^"_RM_"^^^^"_FHMEAL
96 I $G(DFN) D ALG^FHCLN S ALG="ALLGS.: "_$S(ALG="":"NONE ON FILE",1:ALG) S J=0 D BRK^FHDCR1B
97 S S(NBR)=S(NBR)+1
98 S ^TMP($J,"MP",S(NBR),NBR)=" Breakfast Noon Evening"
99 K NN F MEAL="B","N","E" D
100 .S X8="" F S X8=$O(MP(MEAL,X8)) Q:X8="" S X1=+$G(MP(MEAL,X8)) D
101 ..;Q:'X1 S Z1=$P(X8,"~",2),QTY=$S(+X1#1>0:$J(+X1,3,1),1:+X1_" ")_" "
102 ..Q:'X1 S Z1=$P(X8,"~",2),PAD=$E(" ",1,5-$L(X1)),QTY=+X1_PAD
103 ..S NN(MEAL,X8)=QTY_$E($P(X8,"~",3),1,15)
104 ..Q
105 .Q
106 K TT,SRT F MEAL="B","N","E" D
107 .S TT(MEAL)=0
108 .S X8="" F S X8=$O(NN(MEAL,X8)) Q:X8="" D
109 ..S TT(MEAL)=TT(MEAL)+1,SRT(TT(MEAL),MEAL)=$G(NN(MEAL,X8)) Q
110 .D SOUT^FHDCR1B,DISL^FHDCR1B
111 ;
112 F N1=1:1 Q:'$D(SRT(N1)) D
113 .S STR="" F MEAL="B","N","E" D
114 ..I '$D(SRT(N1,MEAL))!(MEAL'=FHMEAL) S STR=STR_$J("",20) Q
115 ..S STR=STR_SRT(N1,MEAL)
116 ..S:MEAL'="E" STR=STR_$J("",20-$L(SRT(N1,MEAL)))
117 ..Q
118 .S S(NBR)=S(NBR)+1
119 .S ^TMP($J,"MP",S(NBR),NBR)=STR
120 .Q
121 Q
122 ;
123LOC ;get location info
124 I $G(FHWARD),$D(^FH(119.6,FHWARD,0)) S FHWDAT=^FH(119.6,FHWARD,0) D
125 .S FHWT=$P(FHWDAT,U,5)
126 .S FHWC=$P(FHWDAT,U,6)
127 .S FHWD=$P(FHWDAT,U,7)
128 .I $G(FHWT),$D(^FH(119.72,FHWT,0)) S SVC=$P(^FH(119.72,FHWT,0),U,2)
129 .I $G(FHWC),$D(^FH(119.72,FHWC,0)) S SVC=$P(^FH(119.72,FHWC,0),U,2)
130 .I FHRGS="OP" D
131 ..S (FHOR,FHDIET)=$P(FHKDAT,U,2)
132 .I FHRGS="GM" D
133 ..S FHDIET=$P(FHKDAT,U,6)
134 .I FHRGS="SM" D
135 ..S FHDIET=$P(FHKDAT,U,4)
136 .S:$G(FHDIET) MPD=$P(^FH(111,FHDIET,0),U,5)
137 Q
Note: See TracBrowser for help on using the repository browser.