source: FOIAVistA/trunk/r/DIETETICS-FH/FHOMRBLD.m@ 1119

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

initial load of FOIAVistA 6/30/08 version

File size: 8.1 KB
Line 
1FHOMRBLD ;Hines OIFO/RVD-OUTPATIENT REPORT UTILITY ;2/03/04 10:05
2 ;;5.5;DIETETICS;;Jan 28, 2005
3 ;
4 ;RVD 2/3/04 - modified for Outpatient Meals
5 ;
6 ;ENTRY POINTS:
7 ; GETRM - get outpatient recurring meals data from starting dt.
8 ; GETSM - get outpatient special meals data from starting dt.
9 ;
10GETRM(FHSDT,FHCOM,FHLOC,FHRDFN) ;get special recurring data.
11 ;input variables:
12 ; FHSDT = starting date
13 ; FHCOM = IEN of communication office, 'ALL' for all.
14 ; = if NULL, considered 'ALL'
15 ; FHLOC = IEN of location, 'ALL' for all.
16 ; = if NULL, considered 'ALL'
17 ; FHRDFN = IEN of NUTRITION PERSON, 'ALL' for all.
18 ; = if NULL, considered 'ALL'
19 ;
20 ;ouput:
21 ; ^TMP($J,"OP","R",COMMUNICATION OFF,NUTRITION LOCATION,PATIENT,DTE)
22 ; = for outpatient recurring meals
23 ;
24 ;contents of ^TMP($J global:
25 ; Piece 1 = patient DFN(IEN in file #115)
26 ; Piece 2 = recurring meals IEN
27 ; Piece 3 = recurring date/time
28 ; Piece 4 = diet
29 ; Piece 5 = meal
30 ; Piece 6 = bagged meal
31 ; Piece 7 = meal plan order number
32 ; Piece 8 = ADDITIONAL ORDER TEXT
33 ; Piece 9 = ADDITIONAL ORDER CLERK
34 ; Piece 10 = ADDITIONAL ORDER DATE AND TIME
35 ; Piece 11 = EARLY/LATE TRAY TIME
36 ; Piece 12 = EARLY/LATE TRAY BAGGED MEAL
37 ; Piece 13 = EARLY/LATE TRAY CLERK
38 ; Piece 14 = EARLY/LATE TRAY ENTRY DATE
39 ; Piece 15 = TUBEFEEDING COMMENT
40 ; Piece 16 = TF TOTAL CC'S
41 ; Piece 17 = TF TOTAL KCALS/DAY
42 ; Piece 18 = SERVICE (T,C,D or combination of 3)
43 ; Piece 19 = Status
44 ;
45 ;error:
46 ; ^TMP($J,"OP","ER") = error message
47 K ^TMP($J,"OP","R")
48 D NEWVAR
49 I '$O(^FHPT("RM",FHSDT)) S ^TMP($J,"OP","ER")="NO RECURRING MEALS FOR THIS DATE RANGE" Q
50 S:FHLOC="" FHLOC="ALL"
51 S:FHCOM="" FHCOM="ALL"
52 S:FHRDFN="" FHRDFN="ALL"
53 F FHSMDT=FHSDT:0 S FHSMDT=$O(^FHPT("RM",FHSMDT)) Q:FHSMDT'>0 D
54 .F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",FHSMDT,FHDFN)) Q:FHDFN'>0 D
55 ..F FHIN=0:0 S FHIN=$O(^FHPT("RM",FHSMDT,FHDFN,FHIN)) Q:FHIN'>0 D
56 ...I $G(FHRDFN),(FHRDFN'=FHDFN) Q ;quit entry is different.
57 ...S (FHLCOMN,FHLCOM,FHLOCN,FHPTNM,FHDIET,FHTCD)=""
58 ...S FHNODE=$G(^FHPT(FHDFN,"OP",FHIN,0))
59 ...S FHD=$P(FHNODE,U,1)
60 ...D PATNAME^FHOMUTL S FHPTNM=$E(FHPTNM,1,18)
61 ...S:'$D(FHPTNM) FHPTNM="***"
62 ...S:FHPTNM="" FHPTNM="***"
63 ...S FHD=$$FMTE^XLFDT(FHSMDT,"P")
64 ...S FHD=$E(FHD,1,12)
65 ...S FHLPT=$P(FHNODE,U,3)
66 ...I $G(FHLOC),FHLOC'=FHLPT Q ;quit if location is not the same
67 ...S:$G(FHLPT) FHLCOM=$P($G(^FH(119.6,FHLPT,0)),U,8)
68 ...I $G(FHCOM),FHCOM'=FHLCOM Q ;quit if not same communication office
69 ...S:$G(FHLCOM) FHLCOMN=$P($G(^FH(119.73,FHLCOM,0)),U,1)
70 ...S:FHLCOMN="" FHLCOMN="***"
71 ...I $G(FHLPT) D
72 ....S FHLOCN=$P($G(^FH(119.6,FHLPT,0)),U,1)
73 ....S:$P($G(^FH(119.6,FHLPT,0)),U,5) FHTCD=FHTCD_"T"
74 ....S:$P($G(^FH(119.6,FHLPT,0)),U,6) FHTCD=FHTCD_"C"
75 ....S:$P($G(^FH(119.6,FHLPT,0)),U,7) FHTCD=FHTCD_"D"
76 ...S:FHLOCN="" FHLOCN="***"
77 ...S FHDPT=$P(FHNODE,U,2) S:FHDPT="" FHDPT=$P(FHNODE,U,7)
78 ...S:FHDPT="" FHDPT=$P(FHNODE,U,8) S:FHDPT="" FHDPT=$P(FHNODE,U,9)
79 ...S:FHDPT="" FHDPT=$P(FHNODE,U,10) S:FHDPT="" FHDPT=$P(FHNODE,U,11)
80 ...S:$G(FHDPT) FHDIET=$P($G(^FH(111,FHDPT,0)),U,1)
81 ...S:FHDIET="" FHDIET="***"
82 ...S FHMEAL=$P(FHNODE,U,4)
83 ...S:FHMEAL="" FHMEAL=$P(FHNODE,U,7)
84 ...S:FHMEAL="" FHMEAL=$P(FHNODE,U,8)
85 ...S:FHMEAL="" FHMEAL=$P(FHNODE,U,9)
86 ...S:FHMEAL="" FHMEAL=$P(FHNODE,U,10)
87 ...S:FHMEAL="" FHMEAL=$P(FHNODE,U,11)
88 ...S FHBAGM=$P(FHNODE,U,5)
89 ...S FHMPO=$P(FHNODE,U,6)
90 ...S FHMPO=$E(FHMPO,1,70)
91 ...S FHSTAT=$P(FHNODE,U,15)
92 ...S (FHADO,FHADOC,FHADODT,FHELT,FHELTB)=""
93 ...S (FHELTC,FHELTED,FHTFC,FHTFTC,FHTFTK)=""
94 ...I $D(^FHPT(FHDFN,"OP",FHIN,1)) D
95 ....S FHEL=$G(^FHPT(FHDFN,"OP",FHIN,1))
96 ....S FHADO=$P(FHEL,U,1)
97 ....S FHADOC=$P(FHEL,U,2)
98 ....I $G(FHADOC),($D(^VA(200,FHADOC,0))) S FHADOC=$P(^VA(200,FHADOC,0),U,1)
99 ....S FHADDT=$P(FHEL,U,3)
100 ...I $D(^FHPT(FHDFN,"OP",FHIN,2)) D
101 ....S FHEL2=$G(^FHPT(FHDFN,"OP",FHIN,2))
102 ....S FHELT=$P(FHEL2,U,1)
103 ....S FHELTB=$P(FHEL2,U,2)
104 ....S FHELTC=$P(FHEL2,U,3)
105 ....S FHELTED=$P(FHEL2,U,4)
106 ...I $D(^FHPT(FHDFN,"OP",FHIN,3)) D
107 ....S FHEL3=$G(^FHPT(FHDFN,"OP",FHIN,3))
108 ....S FHTFC=$P(FHEL3,U,1)
109 ....S FHTFTC=$P(FHEL3,U,2)
110 ....S FHTFTK=$P(FHEL3,U,3)
111 ...S FHDAT=FHDFN_"^"_FHD_"^"_FHDIET_"^"_FHMEAL_"^"_FHBAGM_"^"_FHMPO
112 ...S FHDAT=FHDAT_"^"_FHADO_"^"_FHADOC_"^"_FHADODT_"^"_FHELT_"^"_FHELTB
113 ...S FHDAT=FHDAT_"^"_FHELTC_"^"_FHELTED_"^"_FHTFC_"^"_FHTFTC_"^"_FHTFTK
114 ...S ^TMP($J,"OP","R",FHLCOMN,FHLOCN,FHPTNM,FHSMDT)=FHDAT_"^"_FHTCD_"^"_FHSTAT
115 Q
116 ;
117 ;
118GETSM(FHSDT,FHCOM,FHLOC,FHSDFN) ;get special meals data.
119 ;input variables:
120 ; FHSDT = starting date
121 ; FHCOM = IEN of communication office, 'ALL' for all.
122 ; = if NULL, considered 'ALL'
123 ; FHLOC = IEN of location, 'ALL' for all.
124 ; = if NULL, considered 'ALL'
125 ; FHSDFN = IEN of file #115, 'ALL' for all.
126 ; = if NULL, considered 'ALL'
127 ;
128 ;ouput:
129 ; ^TMP($J,"OP","S",COMMUNICATION OFF,NUTRITION LOCATION,PATIENT,DTE)
130 ; = for outpatient special meals
131 ;
132 ;contents of ^TMP($J global:
133 ; Piece 1 = patient DFN
134 ; Piece 2 = special meal date/time
135 ; Piece 3 = status
136 ; Piece 4 = diet
137 ; Piece 5 = requestor
138 ; Piece 6 = authorizor
139 ; Piece 7 = authorize/deny date/time
140 ; Piece 8 = comment
141 ; Piece 9 = meal
142 ; Piece 10 = early/late tray time
143 ; Piece 11 = early/late tray bagged meal
144 ; Piece 12 = early/late tray clerk
145 ; Piece 13 = SERVICE (T,C,D or combination of 3)
146 ;
147 ;error:
148 ; ^TMP($J,"OP","ER")
149 K ^TMP($J,"OP","S")
150 D NEWVAR
151 S FHSDT=FHSDT-.000001
152 I '$O(^FHPT("SM",FHSDT)) S ^TMP($J,"OP","ER")="NO SPECIAL MEALS FOR THIS DATE RANGE" Q
153 S:FHLOC="" FHLOC="ALL"
154 S:FHCOM="" FHCOM="ALL"
155 S:FHSDFN="" FHSDFN="ALL"
156 S FHS="ACDP"
157 F FHSMDT=FHSDT:0 S FHSMDT=$O(^FHPT("SM",FHSMDT)) Q:FHSMDT'>0 D
158 .F FHDFN=0:0 S FHDFN=$O(^FHPT("SM",FHSMDT,FHDFN)) Q:FHDFN'>0 D
159 ..I $G(FHSDFN),(FHSDFN'=FHDFN) Q
160 ..S (FHLCOMN,FHLCOM,FHLOCN,FHPTNM,FHDIET,FHTCD)=""
161 ..S FHNODE=$G(^FHPT(FHDFN,"SM",FHSMDT,0))
162 ..S FHSTAT=$P(FHNODE,U,2)
163 ..I FHS'[FHSTAT Q
164 ..S FHSTAT=$S(FHSTAT="P":"PENDING",FHSTAT="A":"AUTHORIZED",FHSTAT="D":"DENIED",1:"CANCELLED")
165 ..D PATNAME^FHOMUTL S FHPTNM=$E(FHPTNM,1,18)
166 ..S:FHPTNM="" FHPTNM="***"
167 ..S FHD=$$FMTE^XLFDT(FHSMDT,"P")
168 ..S FHD=$E(FHD,1,12)
169 ..S FHSTAT=$P(FHNODE,U,2)
170 ..S FHLPT=$P(FHNODE,U,3)
171 ..I $G(FHLOC),FHLOC'=FHLPT Q
172 ..S:$G(FHLPT) FHLCOM=$P($G(^FH(119.6,FHLPT,0)),U,8)
173 ..I $G(FHCOM),FHCOM'=FHLCOM Q ;quit if d same communication office
174 ..S:$G(FHLCOM) FHLCOMN=$P($G(^FH(119.73,FHLCOM,0)),U,1)
175 ..S:FHLCOMN="" FHLCOMN="***"
176 ..I $G(FHLPT) D
177 ...S FHLOCN=$P($G(^FH(119.6,FHLPT,0)),U,1)
178 ...S:$P($G(^FH(119.6,FHLPT,0)),U,5) FHTCD=FHTCD_"T"
179 ...S:$P($G(^FH(119.6,FHLPT,0)),U,6) FHTCD=FHTCD_"C"
180 ...S:$P($G(^FH(119.6,FHLPT,0)),U,7) FHTCD=FHTCD_"D"
181 ..S:FHLOCN="" FHLOCN="***"
182 ..S FHDPT=$P(FHNODE,U,4)
183 ..S:$G(FHDPT) FHDIET=$P($G(^FH(111,FHDPT,0)),U,1)
184 ..S:FHDIET="" FHDIET="***"
185 ..S (FHAUTR,FHREQ)=""
186 ..S FHCOMM=$P(FHNODE,U,8)
187 ..S FHMEAL=$P(FHNODE,U,9)
188 ..S FHADDT=$P(FHNODE,U,7)
189 ..S FHAUTR=$P(FHNODE,U,6)
190 ..S FHREQ=$P(FHNODE,U,5)
191 ..S:$L(FHCOMM)>70 FHCOMM=$E(FHCOMM,1,70)
192 ..I $G(FHAUTR),($D(^VA(200,FHAUTR,0))) S FHAUTR=$P(^VA(200,FHAUTR,0),U,1)
193 ..I $G(FHREQ),($D(^VA(200,FHREQ,0))) S FHREQ=$P(^VA(200,FHREQ,0),U,1)
194 ..S (FHELT,FHELBG,FHELC)=""
195 ..I $D(^FHPT(FHDFN,"SM",FHSMDT,1)) D
196 ...S FHEL=$G(^FHPT(FHDFN,"SM",FHSMDT,1))
197 ...S FHELT=$P(FHEL,U,1)
198 ...S FHELBG=$P(FHEL,U,2)
199 ...S FHELC=$P(FHEL,U,3)
200 ..S FHDAT=FHDFN_"^"_FHD_"^"_FHSTAT_"^"_FHDIET_"^"_FHREQ
201 ..S FHDAT=FHDAT_"^"_FHAUTR_"^"_FHADDT_"^"_FHCOMM
202 ..S FHDAT=FHDAT_"^"_FHMEAL_"^"_FHELT_"^"_FHELBG_"^"_FHELC_"^"_FHTCD
203 ..S ^TMP($J,"OP","S",FHLCOMN,FHLOCN,FHPTNM,FHSMDT)=FHDAT
204 Q
205 ;
206NEWVAR ;new all variables.
207 N FHPTNM,FHD,FHDIET,FHMEAL,FHELTT,FHELBG,FHDAT,FHSTAT,FHLPT
208 N FHAGE,FHCH,FHCL,FHDOB,FHGMDT,FHML,FHNODE,FHPCZN,FHSEX,FHSSN,FILE
209 N FHDAT,FHDPT,FHEL,FHLPT,FHS,FHSMDT,FHSTAT,FHNN,FH
210 Q
Note: See TracBrowser for help on using the repository browser.