source: BMXNET_RPMS_dotNET_UTILITIES-BMX/trunk/m/BMXUTL1.m@ 1368

Last change on this file since 1368 was 1209, checked in by Sam Habiel, 13 years ago

BMXMON fix; updated all routines to v 2.31
File size: 8.0 KB
Line 
1BMXUTL1 ; IHS/OIT/HMW - UTIL: PATIENT DEMOGRAPHICS ;
2 ;;2.31;BMX;;Jul 25, 2011
3 ;;Stolen from:* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
4 ;; UTILITY: PATIENT DEMOGRAPHICS.
5 ;
6 ;
7 ;----------
8NAME(DFN,ORDER) ;EP
9 ;---> Return text of Patient Name.
10 ;---> Parameters:
11 ; 1 - DFN (req) Patient's IEN (DFN).
12 ; 2 - ORDER (opt) ""/0=Last,First 2=First Only
13 ; 1=First Last 3=Last Only
14 ;
15 Q:'$G(DFN) "NO PATIENT"
16 Q:'$D(^DPT(DFN,0)) "Unknown"
17 N X S X=$P(^DPT(DFN,0),U)
18 Q:'$G(ORDER) X
19 S X=$$FL(X)
20 Q:ORDER=1 X
21 Q:ORDER=2 $P(X," ")
22 Q:ORDER=3 $P(X," ",2)
23 Q "UNKNOWN ORDER"
24 ;
25 ;
26 ;----------
27FL(X) ;EP
28 ;---> Switch First and Last Names.
29 Q $P($P(X,",",2)," ")_" "_$P(X,",")
30 ;
31 ;
32 ;----------
33DOB(DFN) ;EP
34 ;---> Return Patient's Date of Birth in Fileman format.
35 ;---> Parameters:
36 ; 1 - DFN (req) Patient's IEN (DFN).
37 ;
38 Q:'$G(DFN) "NO PATIENT"
39 Q:'$P($G(^DPT(DFN,0)),U,3) "NOT ENTERED"
40 Q $P(^DPT(DFN,0),U,3)
41 ;
42 ;
43 ;----------
44DOBF(DFN,BMXDT,BMXNOA) ;EP
45 ;---> Date of Birth formatted "09-Sep-1994 (35 Months)"
46 ;---> Parameters:
47 ; 1 - DFN (req) Patient's IEN (DFN).
48 ; 2 - BMXDT (opt) Date on which Age should be calculated.
49 ; 3 - BMXNOA (opt) 1=No age (don't append age).
50 ;
51 N X,Y
52 S X=$$DOB($G(DFN))
53 Q:'X X
54 S X=$$TXDT1^BMXUTL5(X)
55 Q:$G(BMXNOA) X
56 S Y=$$AGEF(DFN,$G(BMXDT))
57 S:Y["DECEASED" Y="DECEASED"
58 S X=X_" ("_Y_")"
59 Q X
60 ;
61 ;
62 ;----------
63AGE(DFN,BMXZ,BMXDT) ;EP
64 ;---> Return Patient's Age.
65 ;---> Parameters:
66 ; 1 - DFN (req) IEN in PATIENT File.
67 ; 2 - BMXZ (opt) BMXZ=1,2,3 1=years, 2=months, 3=days.
68 ; 2 will be assumed if not passed.
69 ; 3 - BMXDT (opt) Date on which Age should be calculated.
70 ;
71 N BMXDOB,X,X1,X2 S:$G(BMXZ)="" BMXZ=2
72 Q:'$G(DFN) "NO PATIENT"
73 S BMXDOB=$$DOB(DFN)
74 Q:'BMXDOB "Unknown"
75 I '$G(BMXDT)&($$DECEASED(DFN)) D Q X
76 .S X="DECEASED: "_$$TXDT1^BMXUTL5(+^DPT(DFN,.35))
77 S:'$G(DT) DT=$$DT^XLFDT
78 S:'$G(BMXDT) BMXDT=DT
79 Q:BMXDT<BMXDOB "NOT BORN"
80 ;
81 ;---> Age in Years.
82 N BMXAGEY,BMXAGEM,BMXD1,BMXD2,BMXM1,BMXM2,BMXY1,BMXY2
83 S BMXM1=$E(BMXDOB,4,7),BMXM2=$E(BMXDT,4,7)
84 S BMXY1=$E(BMXDOB,1,3),BMXY2=$E(BMXDT,1,3)
85 S BMXAGEY=BMXY2-BMXY1 S:BMXM2<BMXM1 BMXAGEY=BMXAGEY-1
86 S:BMXAGEY<1 BMXAGEY="<1"
87 Q:BMXZ=1 BMXAGEY
88 ;
89 ;---> Age in Months.
90 S BMXD1=$E(BMXM1,3,4),BMXM1=$E(BMXM1,1,2)
91 S BMXD2=$E(BMXM2,3,4),BMXM2=$E(BMXM2,1,2)
92 S BMXAGEM=12*BMXAGEY
93 I BMXM2=BMXM1&(BMXD2<BMXD1) S BMXAGEM=BMXAGEM+12
94 I BMXM2>BMXM1 S BMXAGEM=BMXAGEM+BMXM2-BMXM1
95 I BMXM2<BMXM1 S BMXAGEM=BMXAGEM+BMXM2+(12-BMXM1)
96 S:BMXD2<BMXD1 BMXAGEM=BMXAGEM-1
97 Q:BMXZ=2 BMXAGEM
98 ;
99 ;---> Age in Days.
100 S X1=BMXDT,X2=BMXDOB
101 D ^%DTC
102 Q X
103 ;
104 ;
105 ;----------
106AGEF(DFN,BMXDT) ;EP
107 ;---> Age formatted "35 Months" or "23 Years"
108 ;---> Parameters:
109 ; 1 - DFN (req) Patient's IEN (DFN).
110 ; 2 - BMXDT (opt) Date on which Age should be calculated.
111 ;
112 N Y
113 S Y=$$AGE(DFN,2,$G(BMXDT))
114 Q:Y["DECEASED" Y
115 Q:Y["NOT BORN" Y
116 ;
117 ;---> If over 60 months, return years.
118 Q:Y>60 $$AGE(DFN,1,$G(BMXDT))_" years"
119 ;
120 ;---> If under 1 month return days.
121 I Y<1 S Y=$$AGE(DFN,3,$G(BMXDT)) Q Y_$S(Y=1:" day",1:" days")
122 ;
123 ;---> Return months
124 Q Y_$S(Y=1:" month",1:" months")
125 ;
126 ;
127 ;----------
128DECEASED(DFN,BMXDT) ;EP
129 ;---> Return 1 if patient is deceased, 0 if not deceased.
130 ;---> Parameters:
131 ; 1 - DFN (req) Patient's IEN (DFN).
132 ; 2 - BMXDT (opt) If BMXDT=1 return Date of Death (Fileman format).
133 ;
134 Q:'$G(DFN) 0
135 N X S X=+$G(^DPT(DFN,.35))
136 Q:'X 0
137 Q:'$G(BMXDT) 1
138 Q X
139 ;
140 ;
141 ;----------
142SEX(DFN,PRON) ;EP
143 ;---> Return "F" is patient is female, "M" if male.
144 ;---> Parameters:
145 ; 1 - DFN (req) Patient's IEN (DFN).
146 ; 2 - PRON (opt) Pronoun: 1=he/she, 2=him/her,3=his,her
147 ;
148 Q:'$G(DFN) ""
149 Q:'$D(^DPT(DFN,0)) ""
150 N X S X=$P(^DPT(DFN,0),U,2)
151 Q:'$G(PRON) X
152 I PRON=1 Q $S(X="F":"she",1:"he")
153 I PRON=2 Q $S(X="F":"her",1:"him")
154 I PRON=3 Q $S(X="F":"her",1:"his")
155 Q X
156 ;
157 ;
158 ;----------
159SEXW(DFN) ;EP
160 ;---> Return Patient sex: "Female"/"Male".
161 ;---> Parameters:
162 ; 1 - DFN (req) Patient's IEN (DFN).
163 ;
164 Q:$$SEX(DFN)="M" "Male"
165 Q:$$SEX(DFN)="F" "Female"
166 Q "Unknown"
167 ;
168 ;
169 ;----------
170NAMAGE(DFN) ;EP
171 ;---> Return Patient Name concatenated with age.
172 ;---> Parameters:
173 ; 1 - DFN (req) Patient's IEN (DFN).
174 ;
175 Q:'$G(DFN) "NO PATIENT"
176 Q $$NAME(DFN)_" ("_$$AGE(DFN)_"y/o)"
177 ;
178 ;
179 ;----------
180SSN(DFN) ;EP
181 ;---> Return Social Security Number (SSN).
182 ;---> Parameters:
183 ; 1 - DFN (req) Patient's IEN (DFN).
184 N X
185 Q:'$G(DFN) "NO PATIENT"
186 Q:'$D(^DPT(DFN,0)) "Unknown"
187 S X=$P(^DPT(DFN,0),U,9)
188 Q:X']"" "Unknown"
189 Q X
190 ;
191 ;
192 ;----------
193HRCN(DFN,DUZ2,AGD) ;EP
194 ;---> Return IHS Health Record Number.
195 ;---> Parameters:
196 ; 1 - DFN (req) Patient's IEN (DFN).
197 ; 2 - DUZ2 (opt) User's Site/Location IEN. If no DUZ2
198 ; provided, function will look for DUZ(2).
199 ; 3 - AGD (opt) If AGD=1 return HRCN with no dashes.
200 ;
201 ;
202 S:'$G(DUZ2) DUZ2=$G(DUZ(2))
203 Q:'$G(DFN)!('$G(DUZ2)) "Unknown1"
204 Q:'$D(^AUPNPAT(DFN,41,DUZ2,0)) "Unknown2"
205 Q:'+$P(^AUPNPAT(DFN,41,DUZ2,0),"^",2) "Unknown3"
206 N Y S Y=$P(^AUPNPAT(DFN,41,DUZ2,0),"^",2)
207 Q:$G(AGD) Y
208 Q:'+Y Y
209 I $L(Y)=7 D Q Y
210 .S Y=$TR("123-45-67",1234567,Y)
211 S Y=$E("00000",0,6-$L(Y))_Y
212 S Y=$TR("12-34-56",123456,Y)
213 Q Y
214 ;
215 ;
216 ;----------
217PHONE(AGDFN,AGOFF) ;EP
218 ;---> Return patient's home phone number.
219 ;---> Parameters:
220 ; 1 - AGDFN (req) Patient's IEN (DFN).
221 ; 2 - AGOFF (opt) =1 will return Patient's Office Phone.
222 ;
223 Q:'$G(AGDFN) "Error: No DFN"
224 Q $P($G(^DPT(AGDFN,.13)),U,$S($G(AGOFF):2,1:1))
225 ;
226 ;
227 ;----------
228STREET(DFN) ;EP
229 ;---> Return patient's street address.
230 ;---> Parameters:
231 ; 1 - DFN (req) Patient's IEN (DFN).
232 ;
233 Q:'$G(DFN) "No Patient"
234 Q:'$D(^DPT(DFN,.11)) ""
235 Q:$P(^DPT(DFN,.11),U)="" ""
236 Q $P(^DPT(DFN,.11),U)
237 ;
238 ;
239 ;----------
240CITY(DFN) ;EP
241 ;---> Return patient's city.
242 ;---> Parameters:
243 ; 1 - DFN (req) Patient's IEN (DFN).
244 ;
245 Q:'$G(DFN) "No Patient"
246 Q:'$D(^DPT(DFN,.11)) ""
247 Q:$P(^DPT(DFN,.11),U,4)="" ""
248 Q $P(^DPT(DFN,.11),U,4)
249 ;
250 ;
251 ;----------
252STATE(DFN,NOTEXT) ;EP
253 ;---> Return patient's state.
254 ;---> Parameters:
255 ; 1 - DFN (req) Patient's IEN (DFN).
256 ; 2 - NOTEXT (opt) If NOTEXT=1 return only the State IEN.
257 ; If NOTEXT=2 return IEN|Text.
258 ;
259 Q:'$G(DFN) ""
260 N Y S Y=$P($G(^DPT(DFN,.11)),U,5)
261 Q:$G(NOTEXT)=1 Y
262 Q:$G(NOTEXT)=2 Y_"|"_$$GET^BMXG(1,Y)
263 Q $$GET^BMXG(1,Y)
264 ;
265 ;
266 ;----------
267ZIP(DFN) ;EP
268 ;---> Return patient's zipcode.
269 ;---> Parameters:
270 ; 1 - DFN (req) Patient's IEN (DFN).
271 ;
272 Q:'$G(DFN) "No Patient"
273 Q:'$D(^DPT(DFN,.11)) ""
274 Q:$P(^DPT(DFN,.11),U,6)="" ""
275 Q $P(^DPT(DFN,.11),U,6)
276 ;
277 ;
278 ;----------
279CTYSTZ(DFN) ;EP
280 ;---> Return patient's city, state zip.
281 ;---> Parameters:
282 ; 1 - DFN (req) Patient's IEN (DFN).
283 ;
284 Q:'$G(DFN) "No Patient"
285 Q $$CITY(DFN)_", "_$$STATE(DFN)_" "_$$ZIP(DFN)
286 ;
287 ;
288CURCOM(DFN,NOTEXT) ;EP
289 ;---> Return patient's Current Community IEN or Text.
290 ;---> (Item 6 on page 1 of Registration).
291 ;---> Parameters:
292 ; 1 - DFN (req) Patient's IEN (DFN).
293 ; 2 - NOTEXT (opt) If NOTEXT=1 return only the Current Comm IEN.
294 ; If NOTEXT=2 return IEN|Text.
295 ;
296 Q:'$G(DFN) "No Patient"
297 Q:'$D(^AUPNPAT(DFN,11)) "" ;"Unknown1"
298 ;
299 N X,Y,Z
300 S X=^AUPNPAT(DFN,11)
301 ;---> Set Y=Pointer (IEN in ^AUTTCOM, piece 17), Z=Text (piece 18).
302 S Y=$P(X,U,17),Z=$P(X,U,18)
303 ;---> If both Pointer and Text are null, return "Unknown2".
304 Q:('Y&(Z="")) "" ;"Unknown2"
305 ;
306 ;---> If Y is null or a bad pointer, set Y="".
307 I Y<1!('$D(^AUTTCOM(+Y,0))) S Y=""
308 ;
309 ;---> If no valid pointer and if Text (pc 18) exists in the
310 ;---> Community file, then set Y=IEN in ^AUTTCOM(.
311 I Y<1,$D(^AUTTCOM("B",Z)) S Y=$O(^AUTTCOM("B",Z,0))
312 ;
313 Q:'$D(^AUTTCOM(+Y,0)) "" ;"Unknown3"
314 Q:$G(NOTEXT)=1 Y
315 Q:$G(NOTEXT)=2 Y_"|"_$$GET^BMXG(2,Y)
316 Q $$GET^BMXG(2,Y)
317 ;
318 ;
319 ;----------
320PERSON(X,ORDER) ;EP
321 ;---> Return person's name from File #200.
322 ;---> Parameters:
323 ; 1 - X (req) Person's IEN in New Person File #200.
324 ; 2 - ORDER (opt) ""/0=Last,First 1=First Last
325 ;
326 Q:'X "Unknown"
327 Q:'$D(^VA(200,X,0)) "Unknown"
328 N Y S Y=$P(^VA(200,X,0),U)
329 Q:'$G(ORDER) Y
330 Q $$FL(Y)
Note: See TracBrowser for help on using the repository browser.