source: qrda/C0Q/branches/ohum/p/C0QPRML.m@ 1704

Last change on this file since 1704 was 1292, checked in by George Lilly, 13 years ago

reorganizing the project for ohum contributions

File size: 11.8 KB
Line 
1C0QPRML ;JJOH/ZAG/GPL - Patient Reminder List ;7/5/11 8:50pm
2 ;;1.0;MU PACKAGE;;;Build 19
3 ;
4 ;2011 Zach Gonzales<zach@linux.com> - Licensed under the terms of the GNU
5 ;General Public License See attached copy of the License.
6 ;
7 ;This program is free software; you can redistribute it and/or modify
8 ;it under the terms of the GNU General Public License as published by
9 ;the Free Software Foundation; either version 2 of the License, or
10 ;(at your option) any later version.
11 ;
12 ;This program is distributed in the hope that it will be useful,
13 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;GNU General Public License for more details.
16 ;
17 ;You should have received a copy of the GNU General Public License along
18 ;with this program; if not, write to the Free Software Foundation, Inc.,
19 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
20 ;
21BUILD ; CALL ALL AND DIS AND BUILD THE GRSLT ARRAY or print or create
22 ; patient lists
23 ;N GRSLT ; ARRAY FOR RESULTS
24 I '$D(C0QSS) S C0QSS=0 ;default don't build spreadsheet array
25 I '$D(C0QPR) S C0QPR=0 ;default don't print out results
26 I '$D(C0QPL) S C0QPL=1 ;default do create patient lists
27 N G1 ; ONE SET OF VALUES - RNF1 FORMAT
28 ; INITIALIZE LISTS
29 ; this is done so that if there are no matching patients, the patient list
30 ; will be zeroed out
31 S C0QLIST("HasDemographics")=""
32 S C0QLIST("Patient")=""
33 S C0QLIST("HasProblem")=""
34 S C0QLIST("HasAllergy")=""
35 S C0QLIST("HasMed")=""
36 S C0QLIST("HasVitalSigns")=""
37 S C0QLIST("HasMedOrders")=""
38 S C0QLIST("HasSmokingStatus")=""
39 D ALL ; all currently admitted patients in the hospital
40 D DIS ; all patients discharged since the reporting period began
41 I C0QSS ZWR GRSLT
42 I C0QPL D ;
43 . D FILE ; FILE THE PATIENT LISTS
44 . D UPDATE^C0QUPDT(.G,8) ; UPDATE THE MU MEASUREMENT SET
45 Q
46 ;
47ALL ;retrieve active inpatients
48 N WARD S WARD=""
49 F D Q:WARD=""
50 . S WARD=$O(^DIC(42,"B",WARD)) ;ward name
51 . Q:WARD=""
52 . N WIEN S WIEN=""
53 . F S WIEN=$O(^DIC(42,"B",WARD,WIEN)) Q:'WIEN D ;wards IEN
54 . . S WARDNAME=$P(^DIC(42,WIEN,0),U,2) ;ward name
55 . . N DFN,RB S DFN=""
56 . . F S DFN=$O(^DPT("CN",WARD,+DFN)) Q:'DFN D ;DFN of patient on ward
57 . . . D DEMO
58 . . . D PROBLEM
59 . . . D ALLERGY
60 . . . D MEDS
61 . . . D SMOKING
62 . . . D VITALS
63 . . . I C0QPR D PRINT
64 . . . I C0QSS D SS
65 . . . I C0QPL D PATLIST
66 Q
67 ;
68DEMO ; patient demographics
69 S PTNAME=$P(^DPT(DFN,0),U) ;patient name
70 S PTDOB=$$FMTE^XLFDT($P($G(^DPT(DFN,0)),U,3)) ;date of birth
71 S PTSEX=$P($G(^DPT(DFN,0)),U,2) ;patient sex
72 D PID^VADPT ;VADPT call to grab PISD based on PT Eligibility
73 S PTHRN=$P($G(VA("PID")),U) ;health record number
74 S PTRLANG=$P($G(^DPT(DFN,256000)),U) ;ptr to language file
75 I $G(PTRLANG)'="" S PTLANG=$P(^DI(.85,PTRLANG,0),U) ;PLS extrnl
76 S RACE=""
77 F D Q:RACE=""
78 . S RACE=$O(^DPT(DFN,.02,"B",RACE)) ;race code IEN
79 . Q:'RACE
80 . S RACEDSC=$P($G(^DIC(10,RACE,0)),U) ;race description
81 S ETHN=""
82 F D Q:ETHN=""
83 . S ETHN=$O(^DPT(DFN,.06,"B",ETHN)) ;ethnicity IEN
84 . Q:'ETHN
85 . S ETHNDSC=$P($G(^DIC(10.2,ETHN,0)),U) ;ethnincity description
86 S RB=$P($G(^DPT(DFN,.101)),U) ;room and bed
87 Q
88 ;
89PROBLEM ; PATIENT PROBLEMS
90 D LIST^ORQQPL(.PROBL,DFN,"A")
91 S PBCNT=""
92 F S PBCNT=$O(PROBL(PBCNT)) Q:PBCNT="" D
93 . S PBDESC=$P(PROBL(PBCNT),U,2) ;problem description
94 K PROBL
95 Q
96 ;
97ALLERGY ; ALLERGY LIST
98 D LIST^ORQQAL(.ALRGYL,DFN)
99 S ALCNT=""
100 F S ALCNT=$O(ALRGYL(ALCNT)) Q:ALCNT="" D
101 . S ALDESC=$P(ALRGYL(ALCNT),U,2) ;allergy description
102 K ALRGYL
103 Q
104 ;
105MEDS ; MEDICATIONS
106 ;
107 I DFN=97 D Q ;
108 . S MDCNT=271
109 K MEDSL
110 D EN^C0CNHIN(.MEDSL,DFN,"MED;") ; GET THE MEDS FROM THE NHIN API
111 ; can't use COVER^ORWPS even though it's fast.. we need to detect
112 ; if the medications are Inpatient to compute the CPOE measure
113 ; we will use the NHINV routines for this purpose
114 ;D COVER^ORWPS(.MEDSL,DFN)
115 S MDCNT="" S HASINP=0
116 F S MDCNT=$O(MEDSL("med",MDCNT)) Q:MDCNT="" D
117 . ;Q:$P(MEDSL(MDCNT),U,4)'="ACTIVE" ;active medications only
118 . Q:MEDSL("med",MDCNT,"status@value")'="active"
119 . ;S MDDESC=$P(MEDSL(MDCNT),U,2) ;medication description
120 . S MDDESC=$G(MEDSL("med",MDCNT,"products.product@name"))
121 . ;S MDITEM=$P($G(MEDSL(MDCNT)),U,3)
122 . S MDITEM=$G(MEDSL("med",MDCNT,"sig")) ; i think this is what meditem is
123 . I MEDSL("med",MDCNT,"vaType@value")="I" S HASINP=1
124 I HASINP D ; THE PATIENT HAS AN INPATIENT MED
125 . S C0QLIST("HasMedOrders",DFN)="" ; an inpatient drug indicates CPOE
126 E S C0QLIST("NoMedOrders",DFN)="" ; this will be different for outpatient
127 K MEDSL
128 Q
129 ;
130SMOKING ;
131 N C0QSMOKE
132 D HFCAT^C0QHF(.C0QSMOKE,DFN,"TOBACCO") ; GET ALL HEALTH FACTORS FOR THE
133 ; PATIENT IN THE CATEGORY OF TOBACCO
134 I $D(C0QSMOKE) S C0QLIST("HasSmokingStatus",DFN)=""
135 E S C0QLIST("NoSmokingStatus",DFN)=""
136 Q
137 ;
138VITALS ;
139 ;
140 N C0QSDT,C0QEDT
141 D DT^DILF(,"JULY 3,2011",.C0QSDT) ; START DATE
142 D DT^DILF(,"T",.C0QEDT) ; END DATE TODAY
143 D VITALS^ORQQVI(.VITRSLT,DFN,C0QSDT,C0QEDT) ; CALL FAST VITALS
144 I $D(VITRSLT) D ;ZWR VITRSLT B ;
145 . I VITRSLT(1)["No vitals found." S C0QLIST("NoVitalSigns",DFN)=""
146 . E S C0QLIST("HasVitalSigns",DFN)=""
147 Q
148 ;
149PRINT ; PRINT TO SCREEN
150
151 I $D(WARD) W !!,WARD_"-"_WARDNAME_" "_RB_": "_PTNAME_"("_PTSEX_") "
152 I $D(EXDTE) D ;
153 . W !,"Discharge Date: ",EXDTE
154 . W !,DFN," ",PTNAME
155 W !,"DOB: ",PTDOB," HRN: ",PTHRN
156 W !,"Language Spoken: ",$G(PTLANG)
157 W !,"Race: ",RACEDSC
158 W !,"Ethnicity: ",$G(ETHNDSC)
159 W !,"Problems: "
160 W !,PBDESC
161 W !,"Allergies: "
162 W !,ALDESC
163 W !,"Medications: "
164 W !
165 Q
166 ;
167SS ; CREATE SPREADSHEET ARRAY
168 S G1("Patient")=DFN
169 I $D(WARD) D ;
170 . S G1("WardName")=WARDNAME
171 . S G1("RoomAndBed")=RB
172 I $D(EXDTE) D ;
173 . S G1("DischargeDate")=EXDTE
174 S G1("PatientName")=PTNAME
175 S G1("Gender")=PTSEX
176 S G1("DateOfBirth")=PTDOB
177 S G1("HealthRecordNumber")=PTHRN
178 S G1("LanguageSpoken")=$G(PTLANG)
179 S G1("Race")=RACEDSC
180 S G1("Ehtnicity")=$G(ETHNDSC)
181 S G1("Problem")=PBDESC
182 I PBDESC["No problems found" S G1("HasProblem")=0
183 E S G1("HasProblem")=1
184 S G1("Allergies")=ALDESC
185 I ALDESC["No Allergy" S G1("HasAllergy")=0
186 E S G1("HasAllergy")=1
187 I $D(MDITEM) D ;
188 . S G1("HasMed")=1
189 E S G1("HasMed")=0
190 S G1("MedDescription")=$G(MDDESC)
191 I $D(MDITEM) W !,"("_MDITEM_")"_MDDESC E W !,MDDESC
192 D RNF1TO2B^C0CRNF("GRSLT","G1")
193 K G1
194 Q ; DON'T WANT TO DO THE NHIN STUFF NOW
195 ;
196PATLIST ; CREATE PATIENT LISTS
197 S C0QLIST("Patient",DFN)="" ; THE PATIENT LIST
198 N DEMOYN S DEMOYN=1
199 I $G(PTSEX)="" S DEMOYN=0
200 I $G(PTDOB)="" S DEMOYN=0
201 I $G(PTHRN)="" S DEMOYN=0
202 I $G(PTLANG)="" S DEMOYN=0
203 I $G(RACEDSC)="" S DEMOYN=0
204 I $G(ETHNDSC)="" S DEMOYN=0
205 I DEMOYN S C0QLIST("HasDemographics",DFN)=""
206 E S C0QLIST("FailedDemographics",DFN)=""
207 ;S G1("Gender")=PTSEX
208 ;S G1("DateOfBirth")=PTDOB
209 ;S G1("HealthRecordNumber")=PTHRN
210 ;S G1("LanguageSpoken")=$G(PTLANG)
211 ;S G1("Race")=RACEDSC
212 ;S G1("Ehtnicity")=$G(ETHNDSC)
213 S G1("Problem")=PBDESC
214 I PBDESC["No problems found" S C0QLIST("NoProblem",DFN)=""
215 E S C0QLIST("HasProblem",DFN)=""
216 ;S G1("Allergies")=ALDESC
217 I ALDESC["No Allergy" S C0QLIST("NoAllergy",DFN)=""
218 E S C0QLIST("HasAllergy",DFN)=""
219 I $D(MDITEM) D ;
220 . S C0QLIST("HasMed",DFN)=""
221 E S G1("NoMed",DFN)=""
222 ;S G1("MedDescription")=$G(MDDESC)
223 Q
224 ;
225NHIN ; SHOW THE NHIN ARRAY FOR THIS PATIENT
226 Q:DFN=137!14
227 D EN^C0CNHIN(.G,DFN,"")
228 ZWR G
229 K G
230 ;
231 QUIT ;end of WARD
232 ;
233 ;
234DIS;
235 N DFN,DTE,EXDTE S DTE=""
236 F D Q:DTE=""
237 . S DTE=$O(^DGPM("B",DTE))
238 . Q:'DTE
239 . Q:DTE<3110703
240 . S EXDTE=$$FMTE^XLFDT(DTE)
241 . N PTFM S PTFM=""
242 . D
243 . . S PTFM=$O(^DGPM("B",DTE,PTFM))
244 . . Q:'PTFM
245 . . S DFN=$P(^DGPM(PTFM,0),U,3)
246 . . D DEMO
247 . . D PROBLEM
248 . . D ALLERGY
249 . . D MEDS
250 . . D SMOKING
251 . . D VITALS
252 . . I C0QPR D PRINT
253 . . I C0QSS D SS
254 . . I C0QPL D PATLIST
255 Q
256 ;
257C0QPLF() Q 1130580001.301 ; FILE NUMBER FOR C0Q PATIENT LIST FILE
258C0QALFN() Q 1130580001.311 ; FILE NUMBER FOR C0Q PATIENT LIST PATIENT SUBFILE
259FILE ; FILE THE PATIENT LISTS TO C0Q PATIENT LIST
260 ;
261 I '$D(C0QLIST) Q ;
262 N LFN S LFN=$$C0QALFN()
263 N ZI,ZN
264 S ZI=""
265 F S ZI=$O(C0QLIST(ZI)) Q:ZI="" D ;
266 . S ZN=$O(^C0Q(301,"CATTR",ZI,""))
267 . I ZN="" D Q ; OOPS
268 . . W !,"ERROR, ATTRIBUTE NOT FOUND IN PATIENT LIST FILE:"_ZI
269 . ;S ZN=$$KLNCR(ZN) ; KILL AND RECREATE RECORD ZN
270 . N C0QNEW,C0QOLD,C0QRSLT
271 . S C0QNEW=$NA(C0QLIST(ZI)) ; THE NEW PATIENT LIST
272 . S C0QOLD=$NA(^C0Q(301,ZN,1,"B")) ; THE OLD PATIENT LIST
273 . D UNITY^C0QSET("C0QRSLT",C0QNEW,C0QOLD) ; FIND WHAT'S NEW
274 . N ZJ,ZK
275 . ; FIRST, DELETE THE OLD ONES - NO LONGER IN THE LIST
276 . K C0QFDA
277 . S ZJ=""
278 . F S ZJ=$O(C0QRSLT(2,ZJ)) Q:ZJ="" D ; MARKED WITH A 2 FROM UNITY
279 . . S ZK=$O(@C0QOLD@(ZJ,"")) ; GET THE IEN OF THE RECORD TO DELETE
280 . . I ZK="" D Q ; OOPS SHOULDN'T HAPPEN
281 . . . W !,"INTERNAL ERROR FINDING A PATIENT TO DELETE"
282 . . . B
283 . . S C0QFDA(LFN,ZK_","_ZN_",",.01)="@"
284 . I $D(C0QFDA) D UPDIE ; PROCESS THE DELETIONS
285 . ; SECOND, PROCESS THE ADDITIONS
286 . K C0QFDA
287 . S ZJ="" S ZK=1
288 . F S ZJ=$O(C0QRSLT(0,ZJ)) Q:ZJ="" D ; PATIENTS TO ADD ARE MARKED WITH 0
289 . . S C0QFDA(LFN,"+"_ZK_","_ZN_",",.01)=ZJ
290 . . S ZK=ZK+1
291 . I $D(C0QFDA) D UPDIE ; PROCESS THE ADDITIONS
292 ;. Q
293 ;. K C0QFDA
294 ;. N ZJ,ZC
295 ;. S ZJ="" S ZC=1
296 ;. F S ZJ=$O(C0QLIST(ZI,ZJ)) Q:ZJ="" D ; FOR EACH PAT IN LIST
297 ;. . S C0QFDA(LFN,"?+"_ZC_","_ZN_",",.01)=ZJ
298 ;. . S ZC=ZC+1
299 ;. D UPDIE
300 ;. W !,"FOUND:"_ZI
301 Q
302 ;
303KLNCR(ZREC) ; KILL AND RECREATE RECORD ZREC IN PATIENT LIST FILE
304 ;
305 N C0QFDA,ZFN,LIST,ATTR
306 S ZFN=$$C0QPLF() ; FILE NUMBER FOR C0Q PATIENT LIST FILE
307 D CLEAN^DILF
308 S LIST=$$GET1^DIQ(ZFN,ZREC_",",.01) ; MEASURE NAME
309 S ATTR=$$GET1^DIQ(ZFN,ZREC_",",999) ; ATTRIBUTE
310 D CLEAN^DILF
311 K ZERR
312 S C0QFDA(ZFN,ZREC_",",.01)="@" ; GET READY TO DELETE THE MEASURE
313 D FILE^DIE(,"C0QFDA","ZERR") ; KILL THE SUBFILE
314 I $D(ZERR) S ZZERR=ZZERR ; ZZERR DOESN'T EXIST, INVOKE THE ERROR TRAP IF TASKED
315 ;. W "ERROR",!
316 ;. ZWR ZERR
317 ;. B
318 K C0QFDA
319 S C0QFDA(ZFN,"+1,",.01)=LIST ; GET READY TO RECREATE THE RECORD
320 S C0QFDA(ZFN,"+1,",999)=ATTR ; ATTRIBUTE
321 D UPDIE ; CREATE THE SUBFILE
322 N ZR ; NEW IEN FOR THE RECORD
323 S ZR=$O(^C0Q(301,"CATTR",ATTR,""))
324 ;
325 Q ZR
326 ;
327UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
328 K ZERR
329 D CLEAN^DILF
330 D UPDATE^DIE("","C0QFDA","","ZERR")
331 I $D(ZERR) S ZZERR=ZZERR ; ZZERR DOESN'T EXIST, INVOKE THE ERROR TRAP IF TASKED
332 ;. W "ERROR",!
333 ;. ZWR ZERR
334 ;. B
335 K C0QFDA
336 Q
337 ;
338 ; WHAT FOLLOWS IS OLD CODE - DELETE WHEN THIS WORKS
339 ;. . N PTNAME S PTNAME=$P(^DPT(DFN,0),U,1)
340 ;. . S PTDOB=$$FMTE^XLFDT($P($G(^DPT(DFN,0)),U,3)) ;date of birth
341 ;. . S PTSEX=$P($G(^DPT(DFN,0)),U,2) ;patient sex
342 ;. . D PID^VADPT ;VADPT call to grab PISD based on PT Eligibility
343 ;. . S PTHRN=$P($G(VA("PID")),U) ;health record number
344 ;. . S PTRLANG=$P($G(^DPT(DFN,256000)),U) ;ptr to language file
345 ;. . I $G(PTRLANG)'="" S PTLANG=$P(^DI(.85,PTRLANG,0),U) ;PLS extrnl
346 ;. . S RACE=""
347 ;. . F D Q:RACE=""
348 ;. . . S RACE=$O(^DPT(DFN,.02,"B",RACE))
349 ;. . . Q:'RACE
350 ;. . . S RACEDSC=$P($G(^DIC(10,RACE,0)),U)
351 ;. . N ETHNDSC
352 ;. . N ETHNDSC S ETHNDSC=""
353 ;. . S ETHN=""
354 ;. . F D Q:ETHN=""
355 ;. . . S ETHN=$O(^DPT(DFN,.06,"B",ETHN))
356 ;. . . Q:'ETHN
357 ;. . . S ETHNDSC=$P($G(^DIC(10.2,ETHN,0)),U)
358 ;. . D LIST^ORQQPL(.PROBL,DFN,"A")
359 ;. . S PBCNT=""
360 ;. . F S PBCNT=$O(PROBL(PBCNT)) Q:PBCNT="" D
361 ;. . . S PBDESC=$P(PROBL(PBCNT),U,2) ;problem description
362 ;. . K PROBL
363 ;. . D LIST^ORQQAL(.ALRGYL,DFN)
364 ;. . S ALCNT=""
365 ;. . F S ALCNT=$O(ALRGYL(ALCNT)) Q:ALCNT="" D
366 ;. . . S ALDESC=$P(ALRGYL(ALCNT),U,2) ;allergy description
367 ;. . K ALRGYL
368 ;. . D COVER^ORWPS(.MEDSL,DFN)
369 ;. . S MDCNT=""
370 ;. . F S MDCNT=$O(MEDSL(MDCNT)) Q:MDCNT="" D
371 ;. . . Q:$P(MEDSL(MDCNT),U,4)'="ACTIVE" ;active medications only
372 ;. . . S MDDESC=$P(MEDSL(MDCNT),U,2) ;medication description
373 ;. . . S MDITEM=$P($G(MEDSL(MDCNT)),U,3)
374 ;. . K MEDSL
375 ;. . W !,"Discharge Date: ",EXDTE
376 ;. . W !,DFN," ",PTNAME
377 ;. . W !,"DOB: ",PTDOB," HRN: ",PTHRN
378 ;. . W !,"Language Spoken: ",$G(PTLANG)
379 ;. . W !,"Race: ",RACEDSC
380 ;. . W !,"Ethnicity: ",ETHNDSC
381 ;. . W !,"Problems: "
382 ;. . W !,PBDESC
383 ;. . W !,"Allergies: "
384 ;. . W !,ALDESC
385 ;. . W !,"Medications: "
386 ;. . I $D(MDITEM) W !,"(",MDITEM,")",MDDESC E W !,MDDESC
387 ;. . W !
388 ;Q
389 ;
390 ;
391 ;
392 ;
393END ;end of C0QPRML;
Note: See TracBrowser for help on using the repository browser.