source: FOIAVistA/trunk/r/DIETETICS-FH/FHORD81.m@ 1800

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

initial load of FOIAVistA 6/30/08 version
File size: 8.4 KB
Line 
1FHORD81 ; HISC/REL/NCA - Diet Order Lists (cont) ;11/30/00 13:55
2 ;;5.5;DIETETICS;**1,5**;Jan 28, 2005;Build 53
3 ;patch 5 - added outpatiet SOs & SFs and outpt room-bed.
4 K C,^TMP("FH",$J) F L=0:0 S L=$O(^FH(118,L)) Q:L<1 I '$D(^FH(118,L,"I")) S C(L)=$P(^(0),"^",1)
5 D NOW^%DTC S NOW=%,DT=NOW\1,X1=DT,X2=-14 D C^%DTC S OLN=+X S X1=NOW,X2=-3 D C^%DTC S OLD=+X
6 S X1=DT,X2=2 D C^%DTC S K3=+X
7 F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1 S X=^(W1,0) D F0
8 S (PG,REC)=0,NXW="" F S NXW=$O(^TMP("FH",$J,NXW)) Q:NXW="" F W1=0:0 S W1=$O(^TMP("FH",$J,NXW,W1)) Q:W1<1 D F2
9 ;
10OUTP ;Outpatient data
11 D GETOUT^FHOMRBL1
12 S (ADM,DTP,FHPTSA,RM,FHLSAV,FHI)=""
13 I SRT="R" D RMS ;sort by room-bed
14 F S FHI=$O(^TMP($J,"FH",FHI)) Q:FHI="" D
15 .S FHJ="" F S FHJ=$O(^TMP($J,"FH",FHI,FHJ)) Q:FHJ="" D
16 ..S FHPTSA=FHJ
17 ..F FHK=0:0 S FHK=$O(^TMP($J,"FH",FHI,FHJ,FHK)) Q:FHK'>0 D
18 ...S FHDAT=""
19 ...S FHL=$O(^TMP($J,"FH",FHI,FHJ,FHK,0))
20 ...I $G(FHL) D REC Q
21 ...D PROC
22 W ! Q
23 ;
24RMS ;SORT BY ROOM-BED
25 M ^TMP($J,"FHR")=^TMP($J,"FH") K ^TMP($J,"FH")
26 F S FHI=$O(^TMP($J,"FHR",FHI)) Q:FHI="" D
27 .S FHJ="" F S FHJ=$O(^TMP($J,"FHR",FHI,FHJ)) Q:FHJ="" D
28 ..S FHPTSA=FHJ
29 ..F FHK=0:0 S FHK=$O(^TMP($J,"FHR",FHI,FHJ,FHK)) Q:FHK'>0 D
30 ...S FHDAT=""
31 ...S FHL=$O(^TMP($J,"FHR",FHI,FHJ,FHK,0))
32 ...I $G(FHL) D RM1 Q
33 ...D RM2
34 K ^TMP($J,"FHR")
35 Q
36RM1 F FHL=0:0 S FHL=$O(^TMP($J,"FHR",FHI,FHJ,FHK,FHL)) Q:FHL'>0 D
37 .S FHDAT=^TMP($J,"FHR",FHI,FHJ,FHK,FHL)
38 .S FHDFN=$P(FHDAT,U,2)
39 .S RM=""
40 .I $G(FHDFN),$D(^FHPT(FHDFN,"OP",FHL,0)) S RM=$P(^(0),U,18)
41 .I $G(RM),$D(^DG(405.4,RM,0)) S RM=$P(^(0),U,1)
42 .S:RM'="" RM=$E(RM,1,12)
43 .S:RM="" RM=" "
44 .S ^TMP($J,"FH",FHI,RM,FHK,FHL)=FHDAT
45 Q
46RM2 S FHDAT=^TMP($J,"FHR",FHI,FHJ,FHK)
47 S FHDFN=$P(FHDAT,U,2)
48 S FHTYP=$P(FHDAT,U,1)
49 S RM=""
50 I $G(FHDFN),FHTYP="GM",$D(^FHPT(FHDFN,"GM",FHK,0)) S RM=$P(^(0),U,11)
51 I $G(FHDFN),FHTYP="SM",$D(^FHPT(FHDFN,"SM",FHK,0)) S RM=$P(^(0),U,13)
52 I $G(RM),$D(^DG(405.4,RM,0)) S RM=$P(^(0),U,1)
53 S:RM'="" RM=$E(RM,1,12)
54 S:RM="" RM=" "
55 S ^TMP($J,"FH",FHI,RM,FHK)=FHDAT
56 Q
57 ;
58PROC ;process/print
59 S FHPLD=0
60 S:FHDAT="" FHDAT=^TMP($J,"FH",FHI,FHJ,FHK)
61 S FHCAT=$P(FHDAT,U,1)
62 S FHDFN=$P(FHDAT,U,2)
63 S FHDIE=$P(FHDAT,U,3)
64 S FHSTA=$P(FHDAT,U,4)
65 S FHMEAL=$P(FHDAT,U,5)
66 S FHLOC=$P(FHDAT,U,6)
67 S FHDAIN=$P(FHDAT,U,7)
68 S (FHSERT,FHSERC,FHSERD,FHSER)=""
69 I $G(FHLOC),$D(^FH(119.6,FHLOC,0)) D
70 .S:$P(^FH(119.6,FHLOC,0),U,5) FHSERT="T"
71 .S:$P(^FH(119.6,FHLOC,0),U,6) FHSERC="C"
72 .S:$P(^FH(119.6,FHLOC,0),U,7) FHSERD="D"
73 .S FHSER=FHSERT_FHSERC_FHSERD
74 I (FHXX="C"),(WRD>0),(WRD'=FHSTA) Q
75 I (FHXX="L"),(WRD>0),(WRD'=FHLOC) Q
76 I (SER'="A"),(FHSER'[SER) Q
77 I FHI'=FHLSAV S FHLSAV=FHI,WRDN=$E(FHI,3,$L(FHI)) D HDR
78 S FHDIET=""
79 D PATNAME^FHOMUTL
80 S RM=""
81 I FHCAT="OP",$D(^FHPT(FHDFN,"OP",FHDAIN,0)) S RM=$P(^(0),U,18)
82 I FHCAT="GM",$D(^FHPT(FHDFN,"GM",FHDAIN,0)) S RM=$P(^(0),U,11)
83 I FHCAT="SM",$D(^FHPT(FHDFN,"SM",FHDAIN,0)) S RM=$P(^(0),U,13)
84 I $G(RM),$D(^DG(405.4,RM,0)) S RM=$P(^DG(405.4,RM,0),U,1)
85 I FHLSAV'=FHI S FHLSAV=FHI D HDR
86 W !!,$E(RM,1,12),?13,$E(FHPTNM,1,24),?38,FHBID,?67,FHSER
87 I $Y>(IOSL-6) D HDR
88 I $D(^FH(111,FHDIE,0)) S FHDIET=$P(^FH(111,FHDIE,0),U,7)
89 S FHTYP=$S(FHCAT="OP":"Recurring",FHCAT="GM":"Guest",FHCAT="SM":"Special",1:"")
90 S DTP=FHK D DTP^FH
91 W !,?14,"Diet Order: ",FHDIET,?40,"Meal: ","(",FHMEAL,")"
92 W !,?14,"Service Type: ",FHTYP,?40,"Date: ",DTP
93 ;S FHDAIN=$O(^FHPT(FHDFN,""_FHCAT_"","B",FHK,0))
94 I $G(FHDAIN),$D(^FHPT(FHDFN,""_FHCAT_"",FHDAIN,"TF")) D OUTF
95 I $G(FHDAIN),FHCAT="OP",$D(^FHPT(FHDFN,"OP",FHDAIN,"SP")) D OSO
96 I $G(FHDAIN),FHCAT="OP",$D(^FHPT(FHDFN,"OP",FHDAIN,"SF")) D OSF
97 S FHPLD=1
98 D:'$G(FHL) ^FHORD83
99 Q
100 ;
101OSO ;process outpt SOs.
102 ;
103 K N F K=0:0 S K=$O(^FHPT(FHDFN,"OP",FHDAIN,"SP",K)) Q:K'>0 S X=^(K,0) Q:$P(X,"^",6) D
104 .S M=$P(X,"^",3),N(M,K)=$P(X,"^",2,4),$P(N(M,K),"^",4,5)=$P(X,"^",8,9)
105 F M="B","N","E" F K=0:0 S K=$O(N(M,K)) Q:K<1 S Z=+N(M,K) I Z D
106 .I ($Y>(IOSL-6)) D HDR,FLNE^FHORD82
107 .S M2=$S(M="B":"Break",M="N":"Noon",1:"Even") S QTY=$P(N(M,K),"^",4)
108 .W !?13,"Stng. Order: ",M2,?38,$S(QTY:QTY,1:1)," ",$P($G(^FH(118.3,Z,0)),"^",1),$S($P(N(M,K),"^",5)'="Y":" (I)",1:"")
109 .S X=$P(N(M,K),"^",3) D DT W ?72,X Q
110 Q
111 ;
112OSF ;process outpt SFs.
113 S NM=$P($G(^FHPT(FHDFN,"OP",FHDAIN,"SF",0)),U,3) Q:'$G(NM)
114 K L,N,M,M1,M2 Q:'NM S Y=^FHPT(FHDFN,"OP",FHDAIN,"SF",NM,0) Q:$P(Y,"^",32)
115 S L=4 F K1=1:1:3 S K=0,N(K1)="" F K2=1:1:4 S Z=$P(Y,U,L+1),Q=$P(Y,U,L+2),L=L+2 I Z'="" S:'Q Q=1 S:N(K1)'="" N(K1)=N(K1)_"; " S N(K1)=N(K1)_Q_" "_$S($D(C(Z)):C(Z),$D(^FH(118,+Z,0)):$P(^(0),"^",1),1:" ")
116 S LST=$P(Y,"^",30)\1,X=LST,P1=0 D DT S:LST<OLN X=X_"*"
117 F K1=1:1:3 I N(K1)'="" W !?13,$P("10AM; 2PM; 8PM",";",K1),?19,$E(N(K1),1,52) I 'P1 S P1=1 W ?72,X
118 Q
119 ;
120REC ;set/get recurring data
121 F FHL=0:0 S FHL=$O(^TMP($J,"FH",FHI,FHJ,FHK,FHL)) Q:FHL'>0 D
122 .S FHDAT=^TMP($J,"FH",FHI,FHJ,FHK,FHL)
123 .D PROC
124 D:$G(FHPLD) ^FHORD83
125 Q
126 ;
127OUTF ;outpatient TF
128 S REC=1
129 S (FHTFPR,FHTFQU,FHTFST,FHTFCOM,FHTFTC,FHTFKD,FHTFCN)=""
130 I $G(FHDAIN),$D(^FHPT(FHDFN,"OP",FHDAIN,3)) D
131 .S FHRDAT3=$G(^FHPT(FHDFN,"OP",FHDAIN,3))
132 .S FHTFCOM=$P(FHRDAT3,U,1)
133 .S FHTFTC=$P(FHRDAT3,U,2)
134 .S FHTFTKD=$P(FHRDAT3,U,3)
135 .S FHTFCN=$P(FHRDAT3,U,5)
136 .S:FHTFCN="C" FHTFCN="Cancelled"
137 F FHTFDA=0:0 S FHTFDA=$O(^FHPT(FHDFN,"OP",FHDAIN,"TF",FHTFDA)) Q:FHTFDA'>0 D
138 .S FHTFDAT=$G(^FHPT(FHDFN,"OP",FHDAIN,"TF",FHTFDA,0))
139 .S FHTFPR=$P(FHTFDAT,U,1)
140 .I $G(FHTFPR),$D(^FH(118.2,FHTFPR,0)) S FHTFPR=$P(^FH(118.2,FHTFPR,0),U,1)
141 .S FHTFST=$P(FHTFDAT,U,2)
142 .S:$G(FHTFST) FHTFST=$S(FHTFST=1:"1/4",FHTFST=2:"1/2",FHTFST=3:"3/4",FHTFST=4:"FULL",1:"")
143 .S FHTFQU=$P(FHTFDAT,U,3)
144 .S FHTFCC=$P(FHTFDAT,U,4)
145 .;I FHAOT'="" S ZZ=" Additional Order: "_FHAOT_" "_FHAOCN_" By: "_FHAOC D LNE^FHORD82
146 .;I FHELTT'="" S ZZ=" Early/Late Tray Time: "_FHELTT_" Bag Meal: "_FHELTBM D LNE^FHOR82
147 .I $Y>(IOSL-6) D LNE^FHORD82
148 .W !,?5,"Tubefeed.:"
149 .S ZZ=FHTFCOM_" TF Total MLs: "_FHTFTC_" TF Total KCALS/Day: "_FHTFTKD_" "_FHTFCN W ZZ
150 .I FHTFPR'="" D
151 ..I $Y>(IOSL-6) D LNE^FHORD82
152 ..W !,?5
153 ..S ZZ="TF Product: "_FHTFPR_" TF Strength: "_FHTFST_" TF Quantity: "_FHTFQU
154 ..W ZZ
155 ..I $Y>(IOSL-6) D LNE^FHORD82
156 ..W !,?5
157 ..S ZZ="TF Product ML/Day: "_FHTFCC_" "_FHTFCN
158 ..W ZZ
159 Q
160F0 ;
161 I $P(X,U,3)="O" Q
162 I FHXX="C" S K1=$P(X,"^",8) I WRD,K1'=WRD Q
163 I FHXX="L" S K1=$P(X,"^",1) I WRD,W1'=WRD Q
164 S K1=$S(FHXX="W":"",K1<1:99,K1<10:"0"_K1,1:K1),P0=$P(X,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0)
165 S WRDN=$P(^FH(119.6,W1,0),"^",1),^TMP("FH",$J,K1_P0_$E(WRDN,1,26),W1)="" Q
166F2 S WRDN=$P(^FH(119.6,W1,0),"^",1)
167 K ^TMP($J) F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN<1 S ADM=^(FHDFN) D RM
168 Q:'$D(^TMP($J)) S NX="" D HDR
169L2 S NX=$O(^TMP($J,NX)) I NX="" W ! Q
170 S FHDFN=""
171L3 ; Get Next Patient data
172 S FHDFN=$O(^TMP($J,NX,FHDFN)) G:FHDFN="" L2 S ADM=^(FHDFN)
173 D PATNAME^FHOMUTL I DFN="" Q
174 G:ADM<1 L3 S Y(0)=^DPT(DFN,0) G:'$D(^DGPM(ADM,0)) L3
175 G:'$D(^FHPT(FHDFN,"A",ADM,0)) L3 S LEN=0 D CUR^FHORD7 S MEAL=Y,X0=^FHPT(FHDFN,"A",ADM,0) S:$L(MEAL)>48 LEN=$L($E(MEAL,1,48),",")
176 I SER'="A",$P(X0,"^",5)'=SER G L3
177 D:$Y>(IOSL-6) HDR S DTP=$P(^DGPM(ADM,0),"^",1) D DTP^FH
178 S RM=$S(SRT="R":NX,$D(^DPT(DFN,.101)):^(.101),1:"") D PID^FHDPA
179 W !!,RM,?13,$E($P(Y(0),"^",1),1,24),?38,BID,?47,DTP
180 S Y=$P(X0,"^",5) I Y'="" W ?67,Y
181 D GET I Y'="" W !?13,"Nut. Status: ",Y S X=+X5 D DT W ?72,X
182 D ALG^FHCLN I ALG'="" W !?13,"Allergies: " S ZZ=ALG D LNE^FHORD82
183 I "NO ORDER"'[MEAL!'$P(X0,"^",4) W !?13,"Diet Order: ",$S(LEN:$P(MEAL,",",1,LEN-1)_",",1:MEAL)
184 I I FHORD S X=$P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",9) D DT W ?72,X D:FHLD'="" NPO W:LEN !?24,$P(MEAL,",",LEN,999) D COM
185 G ^FHORD82
186GET S Y="",X5=$O(^FHPT(FHDFN,"S",0)) Q:X5="" S X5=^(X5,0)
187 Q:$P(X5,"^",1)<$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",1)
188 S Y=$P($G(^FH(115.4,+$P(X5,"^",2),0)),"^",2) Q
189NPO S LST=0 F K1=0:0 S K1=$O(^FHPT(FHDFN,"A",ADM,"AC",K1)) Q:K1<1!(K1>NOW) I $P(^(K1,0),"^",2)=FHORD S LST=K1
190 W:LST<OLD "*" Q
191COM ; List comment if any
192 S COM=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,1)) Q:COM="" I $L(COM)<51 W !?16,COM Q
193 F LEN=51:-1:1 Q:$E(COM,LEN)=" "
194 W !?16,$E(COM,1,LEN-1) S COM=$E(COM,LEN+1,999)
195 W:COM'="" !?19,COM Q
196DT S X=$J(+$E(X,6,7),2)_"-"_$P("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$E(X,4,5)) Q
197RM ;
198 D PATNAME^FHOMUTL I DFN="" Q
199 I SRT="R" S RM=$G(^DPT(DFN,.101))
200 E S RM=$P($G(^DPT(DFN,0)),"^",1)
201 S:RM="" RM=" " S ^TMP($J,RM,FHDFN)=ADM Q
202HDR ;W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1,DTP=NOW D DTP^FH
203 W @IOF S PG=PG+1,DTP=NOW D DTP^FH
204 W !,DTP,?(67-$L(WRDN)\2),WRDN," DIET ORDERS",?72,"Page ",PG
205 I SER'="A" S X=$S(SER="T":"TRAY",SER="C":"CAFETERIA",1:"DINING ROOM")_" Service Only" W !!?(79-$L(X)\2),X
206 W !!,"Room",?13,"Patient",?39,"ID#",?48,"Admission Date",?66,"Svc",?71,"Ord Date" Q
Note: See TracBrowser for help on using the repository browser.