source: qrda/C0Q/trunk/p/C0QPRML.m@ 1224

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

lastest update to C0Q Quality Reporting package
File size: 9.2 KB
RevLine 
[1223]1C0QPRML ;JJOH/ZAG/GPL - Patient Reminder List ;7/5/11 8:50pm
2 ;;1.0;MU PACKAGE;;;Build 13
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 D ALL ; all currently admitted patients in the hospital
29 D DIS ; all patients discharged since the reporting period began
30 I C0QSS ZWR GRSLT
31 I C0QPL D FILE ; FILE THE PATIENT LISTS
32 Q
33 ;
34ALL ;retrieve active inpatients
35 N WARD S WARD=""
36 F D Q:WARD=""
37 . S WARD=$O(^DIC(42,"B",WARD)) ;ward name
38 . Q:WARD=""
39 . N WIEN S WIEN=""
40 . F S WIEN=$O(^DIC(42,"B",WARD,WIEN)) Q:'WIEN D ;wards IEN
41 . . S WARDNAME=$P(^DIC(42,WIEN,0),U,2) ;ward name
42 . . N DFN,RB S DFN=""
43 . . F S DFN=$O(^DPT("CN",WARD,+DFN)) Q:'DFN D ;DFN of patient on ward
44 . . . D DEMO
45 . . . D PROBLEM
46 . . . D ALLERGY
47 . . . D MEDS
48 . . . I C0QPR D PRINT
49 . . . I C0QSS D SS
50 . . . I C0QPL D PATLIST
51 Q
52 ;
53DEMO ; patient demographics
54 S PTNAME=$P(^DPT(DFN,0),U) ;patient name
55 S PTDOB=$$FMTE^XLFDT($P($G(^DPT(DFN,0)),U,3)) ;date of birth
56 S PTSEX=$P($G(^DPT(DFN,0)),U,2) ;patient sex
57 D PID^VADPT ;VADPT call to grab PISD based on PT Eligibility
58 S PTHRN=$P($G(VA("PID")),U) ;health record number
59 S PTRLANG=$P($G(^DPT(DFN,256000)),U) ;ptr to language file
60 I $G(PTRLANG)'="" S PTLANG=$P(^DI(.85,PTRLANG,0),U) ;PLS extrnl
61 S RACE=""
62 F D Q:RACE=""
63 . S RACE=$O(^DPT(DFN,.02,"B",RACE)) ;race code IEN
64 . Q:'RACE
65 . S RACEDSC=$P($G(^DIC(10,RACE,0)),U) ;race description
66 S ETHN=""
67 F D Q:ETHN=""
68 . S ETHN=$O(^DPT(DFN,.06,"B",ETHN)) ;ethnicity IEN
69 . Q:'ETHN
70 . S ETHNDSC=$P($G(^DIC(10.2,ETHN,0)),U) ;ethnincity description
71 S RB=$P(^DPT(DFN,.101),U) ;room and bed
72 Q
73 ;
74PROBLEM ; PATIENT PROBLEMS
75 D LIST^ORQQPL(.PROBL,DFN,"A")
76 S PBCNT=""
77 F S PBCNT=$O(PROBL(PBCNT)) Q:PBCNT="" D
78 . S PBDESC=$P(PROBL(PBCNT),U,2) ;problem description
79 K PROBL
80 Q
81 ;
82ALLERGY ; ALLERGY LIST
83 D LIST^ORQQAL(.ALRGYL,DFN)
84 S ALCNT=""
85 F S ALCNT=$O(ALRGYL(ALCNT)) Q:ALCNT="" D
86 . S ALDESC=$P(ALRGYL(ALCNT),U,2) ;allergy description
87 K ALRGYL
88 Q
89 ;
90MEDS ; MEDICATIONS
91 D COVER^ORWPS(.MEDSL,DFN)
92 S MDCNT=""
93 F S MDCNT=$O(MEDSL(MDCNT)) Q:MDCNT="" D
94 . Q:$P(MEDSL(MDCNT),U,4)'="ACTIVE" ;active medications only
95 . S MDDESC=$P(MEDSL(MDCNT),U,2) ;medication description
96 . S MDITEM=$P($G(MEDSL(MDCNT)),U,3)
97 K MEDSL
98 Q
99 ;
100PRINT ; PRINT TO SCREEN
101
102 I $D(WARD) W !!,WARD_"-"_WARDNAME_" "_RB_": "_PTNAME_"("_PTSEX_") "
103 I $D(EXDTE) D ;
104 . W !,"Discharge Date: ",EXDTE
105 . W !,DFN," ",PTNAME
106 W !,"DOB: ",PTDOB," HRN: ",PTHRN
107 W !,"Language Spoken: ",$G(PTLANG)
108 W !,"Race: ",RACEDSC
109 W !,"Ethnicity: ",$G(ETHNDSC)
110 W !,"Problems: "
111 W !,PBDESC
112 W !,"Allergies: "
113 W !,ALDESC
114 W !,"Medications: "
115 W !
116 Q
117 ;
118SS ; CREATE SPREADSHEET ARRAY
119 S G1("Patient")=DFN
120 I $D(WARD) D ;
121 . S G1("WardName")=WARDNAME
122 . S G1("RoomAndBed")=RB
123 I $D(EXDTE) D ;
124 . S G1("DischargeDate")=EXDTE
125 S G1("PatientName")=PTNAME
126 S G1("Gender")=PTSEX
127 S G1("DateOfBirth")=PTDOB
128 S G1("HealthRecordNumber")=PTHRN
129 S G1("LanguageSpoken")=$G(PTLANG)
130 S G1("Race")=RACEDSC
131 S G1("Ehtnicity")=$G(ETHNDSC)
132 S G1("Problem")=PBDESC
133 I PBDESC["No problems found" S G1("HasProblem")=0
134 E S G1("HasProblem")=1
135 S G1("Allergies")=ALDESC
136 I ALDESC["No Allergy" S G1("HasAllergy")=0
137 E S G1("HasAllergy")=1
138 I $D(MDITEM) D ;
139 . S G1("HasMed")=1
140 E S G1("HasMed")=0
141 S G1("MedDescription")=$G(MDDESC)
142 I $D(MDITEM) W !,"("_MDITEM_")"_MDDESC E W !,MDDESC
143 D RNF1TO2B^C0CRNF("GRSLT","G1")
144 K G1
145 Q ; DON'T WANT TO DO THE NHIN STUFF NOW
146 ;
147PATLIST ; CREATE PATIENT LISTS
148 S C0QLIST("Patient",DFN)="" ; THE PATIENT LIST
149 N DEMOYN S DEMOYN=1
150 I $G(PTSEX)="" S DEMOYN=0
151 I $G(PTDOB)="" S DEMOYN=0
152 I $G(PTHRN)="" S DEMOYN=0
153 I $G(PTLANG)="" S DEMOYN=0
154 I $G(RACEDSC)="" S DEMOYN=0
155 I $G(ETHNDSC)="" S DEMOYN=0
156 I DEMOYN S C0QLIST("HasDemographics",DFN)=""
157 E S C0QLIST("FailedDemographics",DFN)=""
158 ;S G1("Gender")=PTSEX
159 ;S G1("DateOfBirth")=PTDOB
160 ;S G1("HealthRecordNumber")=PTHRN
161 ;S G1("LanguageSpoken")=$G(PTLANG)
162 ;S G1("Race")=RACEDSC
163 ;S G1("Ehtnicity")=$G(ETHNDSC)
164 S G1("Problem")=PBDESC
165 I PBDESC["No problems found" S C0QLIST("NoProblem",DFN)=""
166 E S C0QLIST("HasProblem",DFN)=""
167 ;S G1("Allergies")=ALDESC
168 I ALDESC["No Allergy" S C0QLIST("NoAllergy",DFN)=""
169 E S C0QLIST("HasAllergy",DFN)=""
170 I $D(MDITEM) D ;
171 . S C0QLIST("HasMed",DFN)=""
172 E S G1("NoMed",DFN)=""
173 ;S G1("MedDescription")=$G(MDDESC)
174 Q
175 ;
176NHIN ; SHOW THE NHIN ARRAY FOR THIS PATIENT
177 Q:DFN=137!14
178 D EN^C0CNHIN(.G,DFN,"")
179 ZWR G
180 K G
181 ;
182 QUIT ;end of WARD
183 ;
184 ;
185DIS;
186 N DFN,DTE,EXDTE S DTE=""
187 F D Q:DTE=""
188 . S DTE=$O(^DGPM("B",DTE))
189 . Q:'DTE
190 . Q:DTE<3110703
191 . S EXDTE=$$FMTE^XLFDT(DTE)
192 . N PTFM S PTFM=""
193 . D
194 . . S PTFM=$O(^DGPM("B",DTE,PTFM))
195 . . Q:'PTFM
196 . . S DFN=$P(^DGPM(PTFM,0),U,3)
197 . . D DEMO
198 . . D PROBLEM
199 . . D ALLERGY
200 . . D MEDS
201 . . I C0QPR D PRINT
202 . . I C0QSS D SS
203 . . I C0QPL D PATLIST
204 Q
205 ;
206C0QPLF() Q 1130580001.301 ; FILE NUMBER FOR C0Q PATIENT LIST FILE
207C0QALFN() Q 1130580001.311 ; FILE NUMBER FOR C0Q PATIENT LIST PATIENT SUBFILE
208FILE ; FILE THE PATIENT LISTS TO C0Q PATIENT LIST
209 ;
210 I '$D(C0QLIST) Q ;
211 N LFN S LFN=$$C0QALFN()
212 N ZI,ZN
213 S ZI=""
214 F S ZI=$O(C0QLIST(ZI)) Q:ZI="" D ;
215 . S ZN=$O(^C0Q(301,"CATTR",ZI,""))
216 . I ZN="" D Q ; OOPS
217 . . W !,"ERROR, ATTRIBUTE NOT FOUND IN PATIENT LIST FILE:"_ZI
218 . S ZN=$$KLNCR(ZN) ; KILL AND RECREATE RECORD ZN
219 . K C0QFDA
220 . N ZJ,ZC
221 . S ZJ="" S ZC=1
222 . F S ZJ=$O(C0QLIST(ZI,ZJ)) Q:ZJ="" D ; FOR EACH PAT IN LIST
223 . . S C0QFDA(LFN,"?+"_ZC_","_ZN_",",.01)=ZJ
224 . . S ZC=ZC+1
225 . D UPDIE
226 . W !,"FOUND:"_ZI
227 Q
228 ;
229KLNCR(ZREC) ; KILL AND RECREATE RECORD ZREC IN PATIENT LIST FILE
230 ;
231 N C0QFDA,ZFN,LIST,ATTR
232 S ZFN=$$C0QPLF() ; FILE NUMBER FOR C0Q PATIENT LIST FILE
233 D CLEAN^DILF
234 S LIST=$$GET1^DIQ(ZFN,ZREC_",",.01) ; MEASURE NAME
235 S ATTR=$$GET1^DIQ(ZFN,ZREC_",",999) ; ATTRIBUTE
236 D CLEAN^DILF
237 K ZERR
238 S C0QFDA(ZFN,ZREC_",",.01)="@" ; GET READY TO DELETE THE MEASURE
239 D FILE^DIE(,"C0QFDA","ZERR") ; KILL THE SUBFILE
240 I $D(ZERR) S ZZERR=ZZERR ; ZZERR DOESN'T EXIST, INVOKE THE ERROR TRAP IF TASKED
241 ;. W "ERROR",!
242 ;. ZWR ZERR
243 ;. B
244 K C0QFDA
245 S C0QFDA(ZFN,"+1,",.01)=LIST ; GET READY TO RECREATE THE RECORD
246 S C0QFDA(ZFN,"+1,",999)=ATTR ; ATTRIBUTE
247 D UPDIE ; CREATE THE SUBFILE
248 N ZR ; NEW IEN FOR THE RECORD
249 S ZR=$O(^C0Q(301,"CATTR",ATTR,""))
250 ;
251 Q ZR
252 ;
253UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
254 K ZERR
255 D CLEAN^DILF
256 D UPDATE^DIE("","C0QFDA","","ZERR")
257 I $D(ZERR) S ZZERR=ZZERR ; ZZERR DOESN'T EXIST, INVOKE THE ERROR TRAP IF TASKED
258 ;. W "ERROR",!
259 ;. ZWR ZERR
260 ;. B
261 K C0QFDA
262 Q
263 ;
264 ; WHAT FOLLOWS IS OLD CODE - DELETE WHEN THIS WORKS
265 ;. . N PTNAME S PTNAME=$P(^DPT(DFN,0),U,1)
266 ;. . S PTDOB=$$FMTE^XLFDT($P($G(^DPT(DFN,0)),U,3)) ;date of birth
267 ;. . S PTSEX=$P($G(^DPT(DFN,0)),U,2) ;patient sex
268 ;. . D PID^VADPT ;VADPT call to grab PISD based on PT Eligibility
269 ;. . S PTHRN=$P($G(VA("PID")),U) ;health record number
270 ;. . S PTRLANG=$P($G(^DPT(DFN,256000)),U) ;ptr to language file
271 ;. . I $G(PTRLANG)'="" S PTLANG=$P(^DI(.85,PTRLANG,0),U) ;PLS extrnl
272 ;. . S RACE=""
273 ;. . F D Q:RACE=""
274 ;. . . S RACE=$O(^DPT(DFN,.02,"B",RACE))
275 ;. . . Q:'RACE
276 ;. . . S RACEDSC=$P($G(^DIC(10,RACE,0)),U)
277 ;. . N ETHNDSC
278 ;. . N ETHNDSC S ETHNDSC=""
279 ;. . S ETHN=""
280 ;. . F D Q:ETHN=""
281 ;. . . S ETHN=$O(^DPT(DFN,.06,"B",ETHN))
282 ;. . . Q:'ETHN
283 ;. . . S ETHNDSC=$P($G(^DIC(10.2,ETHN,0)),U)
284 ;. . D LIST^ORQQPL(.PROBL,DFN,"A")
285 ;. . S PBCNT=""
286 ;. . F S PBCNT=$O(PROBL(PBCNT)) Q:PBCNT="" D
287 ;. . . S PBDESC=$P(PROBL(PBCNT),U,2) ;problem description
288 ;. . K PROBL
289 ;. . D LIST^ORQQAL(.ALRGYL,DFN)
290 ;. . S ALCNT=""
291 ;. . F S ALCNT=$O(ALRGYL(ALCNT)) Q:ALCNT="" D
292 ;. . . S ALDESC=$P(ALRGYL(ALCNT),U,2) ;allergy description
293 ;. . K ALRGYL
294 ;. . D COVER^ORWPS(.MEDSL,DFN)
295 ;. . S MDCNT=""
296 ;. . F S MDCNT=$O(MEDSL(MDCNT)) Q:MDCNT="" D
297 ;. . . Q:$P(MEDSL(MDCNT),U,4)'="ACTIVE" ;active medications only
298 ;. . . S MDDESC=$P(MEDSL(MDCNT),U,2) ;medication description
299 ;. . . S MDITEM=$P($G(MEDSL(MDCNT)),U,3)
300 ;. . K MEDSL
301 ;. . W !,"Discharge Date: ",EXDTE
302 ;. . W !,DFN," ",PTNAME
303 ;. . W !,"DOB: ",PTDOB," HRN: ",PTHRN
304 ;. . W !,"Language Spoken: ",$G(PTLANG)
305 ;. . W !,"Race: ",RACEDSC
306 ;. . W !,"Ethnicity: ",ETHNDSC
307 ;. . W !,"Problems: "
308 ;. . W !,PBDESC
309 ;. . W !,"Allergies: "
310 ;. . W !,ALDESC
311 ;. . W !,"Medications: "
312 ;. . I $D(MDITEM) W !,"(",MDITEM,")",MDDESC E W !,MDDESC
313 ;. . W !
314 ;Q
315 ;
316 ;
317 ;
318 ;
319END ;end of C0QPRML;
Note: See TracBrowser for help on using the repository browser.