source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXPR.m@ 619

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

initial load of WorldVistAEHR
File size: 8.9 KB
Line 
1PXRMXPR ; SLC/PJH - Print Reminder Due report. ;11/27/2006
2 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
3 ;
4 ; Called/Jobbed after PXRMXSE1
5 ;
6START N BMARG,CRITERIA,C1S,C2S,C3S,C1HS,C2HS,C3HS,DONE,FIRST,HEAD
7 N INDENT,PAGE,MOD,DES,ADES,CDES,RDES,SDES,MISSED,SEP
8 N PLSTCRIT,PXRMOPT,PXRMFLD,PXRMHDR,PXRMHDRS,PXRMT,PXRMH
9 N BD,ED,EMPCHK,SD,RD
10 N PXRMTX
11 S PXRMTX="due"
12 ;
13 I PXRMREP="D" D
14 .S EMPCHK=$P($G(^PXRM(800,1,"TRUNCATE EMPLOYEE SSN")),U)
15 .I EMPCHK="" S EMPCHK="Y"
16 ;
17 ; Format Date Range
18 I PXRMSEL="L" D
19 .S BD=$$FMTE^XLFDT(PXRMBDT,"5D")
20 .S ED=$$FMTE^XLFDT(PXRMEDT,"5D")
21 ; Format due effective date
22 S SD=$$FMTE^XLFDT(PXRMSDT,"5P")
23 ; Format run date
24 S RD=$$FMTE^XLFDT(PXRMXST,"5P")
25 ;
26 U IO
27 S DONE=0
28 ;
29 ;Delimited report.
30 S SEP=$S(PXRMTABS="Y":PXRMTABC,1:"")
31 ;
32 ;Setup initial formatting parameters.
33 S INDENT=3
34 S BMARG=2,PAGE=0,HEAD=1
35 ;
36 I +$G(XQY)>0 N XQOPT D OP^XQCHK
37 S PXRMOPT=$P($G(XQOPT),U,2)
38 I ($L(PXRMOPT)>0)&(PXRMOPT'["Clinical") S PXRMOPT="Clinical "_PXRMOPT
39 I PXRMREP="D" D
40 .S RDES=$P(REMINDER(1),U,2)
41 .S PXRMOPT=PXRMOPT_" - Detailed Report"
42 .N IC F IC=0,3,4 S PXRMH(IC)="",PXRMT(IC)=0
43 .S PXRMH(1)="Date Due Last Done Next Appt"
44 .S PXRMH(2)="-------- --------- ---------"
45 .I $G(PXRMINP) D
46 ..S PXRMH(1)="Date Due Last Done Ward/Bed"
47 ..S PXRMH(2)="-------- --------- --------"
48 .F IC=1,2 S PXRMT(IC)=40
49 .S ADES="Next Appointment only"
50 .I PXRMFUT="Y" S ADES="All Future Appointments"
51 .S SDES="Sorted by Patient Name"
52 .I PXRMSRT="Y" S SDES="Sorted by Appointment Date"
53 I PXRMREP="S" D
54 .S PXRMOPT=PXRMOPT_" - Summary Report"
55 .S PXRMH(0)="# Patients with Reminders",PXRMT(0)=50
56 .S PXRMH(1)="Applicable Due"
57 .S PXRMH(2)="---------- ---"
58 .N IC F IC=1,2 S PXRMT(IC)=50
59 .S PXRMH(3)="Denominator"
60 .S PXRMH(4)="-----------"
61 .F IC=3,4 S PXRMT(IC)=0
62 ;
63 ;Print Criteria Page if normal report
64 S CRITERIA=0 I PXRMTABS="N" S CRITERIA=1
65 ;or delimited report with notemplate
66 I PXRMTABS="Y",PXRMTMP="" S CRITERIA=1
67 ;
68 ;Build array of locations/providers with no patients selected in
69 ;MISSED.
70 D NOPATS^PXRMXPR1(.MISSED)
71 ;
72 ;Print either criteria page or summary header
73 I CRITERIA D G:DONE EXIT
74 .D PAGE^PXRMXGPR Q:DONE
75 .D CRIT^PXRMXGPR(10,.PLSTCRIT) Q:DONE
76 ;Header if delimited output from a template
77 I 'CRITERIA D
78 .N HDR1,HDR2,HDR3
79 .S HDR1="",HDR2="",HDR3=""
80 .I PXRMTMP]"" S HDR1="TITLE:"_$P(PXRMTMP,U,2)_U_"TEMPLATE:"_$P(PXRMTMP,U,3)
81 .I PXRMTMP="" D
82 ..N PXRMFLD,DES,CDES D LITS^PXRMXPR1 S HDR1=PXRMFLD_U_$G(DES)_U_$G(CDES)
83 .I PXRMSEL="L" S HDR2="START:"_BD_U_"END:"_ED
84 .S HDR2=HDR2_U_"RUN:"_RD_"Effective Date:"_SD
85 .I PXRMFCMB="Y" S HDR3="COMBINED FACILITY"
86 .I PXRMLCMB="Y" S $P(HDR3,SEP,2)="COMBINED LOCATION"
87 .I PXRMTCMB="Y" S $P(HDR3,SEP,2)="COMBINED OE/RR TEAMS"
88 .I PXRMREP="S" D
89 ..N LIT1,LIT2,LIT3
90 ..D LIT^PXRMXD
91 ..I PXRMTOT="I" S $P(HDR3,SEP,3)=$$UP^XLFSTR(LIT1)
92 ..I PXRMTOT="R" S $P(HDR3,SEP,3)=$$UP^XLFSTR(LIT2)
93 ..I PXRMTOT="T" S $P(HDR3,SEP,3)=$$UP^XLFSTR(LIT3)
94 .S PLSTCRIT(1)=HDR1,PLSTCRIT(2)=HDR2,PLSTCRIT(3)=HDR3
95 .W !,HDR1,!,HDR2,!,HDR3,!
96 ;
97 ;Kill items marked as found
98 K ^XTMP(PXRMXTMP,"MARKED AS FOUND")
99 ;
100 ;Setup the final formatting parameters.
101 S C1HS=INDENT+3
102 S C1S=0
103 S C2HS=C1S+2
104 S C2S=C2HS
105 S C3HS=C2HS+5
106 S C3S=C3HS
107 S HEAD=1
108 S INDENT=10
109 ;
110 ; Update last run date
111 I $G(PXRMTMP)'="" D UPD^PXRMXTU
112 ;
113 ; Get report detail from ^XTMP
114 N PNAM,SUB,DFN,BID,NAM,FAC,MOD,SRT,TOTAL,APPL,FACPNAME,PX,TTOTAL
115 S TTOTAL=0
116 ; Set subroutine label from report format
117 S MOD="SUMARY" I PXRMREP="D" S MOD="DETAIL"
118 ;
119 S FAC=0,PX="PXRM"
120 F S FAC=$O(^XTMP(PXRMXTMP,PX,FAC)) Q:FAC="" Q:DONE D
121 .;Get facility name for Location and PCMM team report
122 .I "TL"[PXRMSEL,PXRMFCMB="N" D
123 ..S FACPNAME=$P(PXRMFACN(FAC),U,1)_" "_$P(PXRMFACN(FAC),U,2)
124 .;Report from ^XTMP - label MOD is DETAIL/SUMARY
125 .S (PNAM,SUB,NAM,SRT)=""
126 .I PXRMSEL="I" S SUB="INDIVIDUAL PATIENTS" D @MOD Q:DONE
127 .I PXRMSEL'="I" D
128 ..;Sort internal IENs into alpha order
129 ..D XSORT
130 ..F S SRT=$O(^TMP($J,"SORT",SRT)) Q:SRT="" Q:DONE D
131 ...S SUB=$G(^TMP($J,"SORT",SRT)) D @MOD
132 ..I MOD="SUMARY","RT"[PXRMTOT S SUB="TOTAL" D @MOD
133 ;
134 ; Null report if no patients selected
135 I ('DONE),$O(^XTMP(PXRMXTMP,PX,""))="" D NULL^PXRMXGPR G EXIT
136 ; Report selected patient sample with no patients
137 I $D(MISSED),PXRMPML=1 D MISSED^PXRMXPR1(0,.MISSED)
138 ;
139 ;Print Patient List
140 I $G(PATLST)="Y" D FOOTER^PXRMXPR1(.PLSTCRIT)
141 ;
142 ;Print Error message
143 I $D(^XTMP(PXRMXTMP,"ERROR"))>0!($D(^XTMP(PXRMXTMP,"CNBD"))>0) D ERROR^PXRMXBSY
144EXIT ;
145 D TIMING^PXRMXGUT
146 D EXIT^PXRMXGUT
147 ;
148 ;Allow the task to be cleaned up upon successful completion.
149 I $D(ZTQUEUED) S ZTREQ="@"
150 ;
151 D EOR^PXRMXGUT
152 Q
153 ;
154 ;Report by Patient
155DETAIL N JJ,VA,DATE,COUNT,DDAT,EMP
156 N BED,DDUE,DDONE,DNEXT,FDAT1,FDAT2,FDAT3,FNAM,FTXT
157 S NAM=$G(^XTMP(PXRMXTMP,PX,FAC,SUB)),HEAD=1
158 S COUNT=$P(NAM,U,2),TOTAL=$P(NAM,U,3),APPL=$P(NAM,U,4),NAM=$P(NAM,U,1)
159 S DDAT="",JJ=0
160 ; Get list of patients for each appointment date
161 F S DDAT=$O(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT)) Q:DDAT="" Q:DONE D PAT
162 ; No patients due
163 I JJ=0 D:'DONE NONE^PXRMXGPR
164 ; Total patients
165 D:'DONE TOTAL^PXRMXGPR
166 S TTOTAL=TTOTAL+TOTAL
167 Q
168 ;
169PAT ;Extract and print patient detail
170 N DNEXT1,NODE,PNUM
171 F S PNAM=$O(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM)) Q:PNAM="" Q:DONE D
172 .S JJ=JJ+1
173 .;Format print line
174 .S (BID,DNEXT1,FDAT1,FDAT2,FDAT3,DNEXT1)="" I PNAM'["No patients found" D
175 ..S FDAT2="N/A",FDAT3="None"
176 ..S NODE=$G(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM))
177 ..S DDUE=$P(NODE,U,2),DDONE=$P(NODE,U,3),DNEXT=$P(NODE,U,4)
178 ..S BED=$P(NODE,U,5)
179 ..S DFN=$P(NODE,U) S BID=$P($G(PNAM),U,2)
180 ..I PXRMSSN="N" S BID=$E(BID,6,9)
181 ..I PXRMSSN="Y",EMPCHK="Y" D EMP S:EMP BID=$E(BID,6,9)
182 ..S BID="("_BID_")"
183 ..S FDAT1=$$FMTE^XLFDT(DDUE,"5D")
184 ..I DDONE S FDAT2=$$FMTE^XLFDT(DDONE,"5D")
185 ..I BED'="NONE" S FDAT3=$P(NODE,U,5),DNEXT1=$$FMTE^XLFDT(DNEXT,"5D")
186 ..I DNEXT,FDAT3="None" S FDAT3=$$FMTE^XLFDT(DNEXT,"5D")
187 .;Print
188 .D CHECK Q:DONE
189 .;Normal output
190 .I PXRMTABS="N" D
191 ..S PNUM=JJ#10000
192 ..S PNUM=$$RJ^XLFSTR(PNUM,4)
193 ..W !,PNUM,?5,$E($P($G(PNAM),U),1,33-$L(BID))," ",BID,?40,FDAT1,?52,FDAT2
194 ..I ('$G(PXRMINP)),PXRMFUT'="Y" W ?64,$S(BED'="NONE":BED_" (Inp.)",1:FDAT3)
195 ..I $G(PXRMINP) W ?64,BED
196 ..I DNEXT1'="",PXRMFUT'="Y" W !,?64,DNEXT1
197 .;Delimited report
198 .I PXRMTABS="Y" D
199 ..N FNAM
200 ..S FNAM=$P($G(PNAM),U)
201 ..I FNAM'["No patients found" S FNAM=$E(FNAM,1,33-$L(BID))_" "_BID
202 ..I "CES"[PXRMTABC S FNAM=$TR(FNAM,SEP,"_"),FDAT1=$TR(FDAT1,SEP,"_")
203 ..I BED="NONE" S BED=" "
204 ..W !,JJ_SEP_FNAM_SEP_FDAT1_SEP_FDAT2 I $G(PXRMINP) W SEP_BED
205 ..I ('$G(PXRMINP)),PXRMFUT'="Y" W SEP_FDAT3_SEP_BED
206 .;---
207 .; Future Appointments
208 .I PXRMFUT="Y" D
209 ..N CNT,ADAT,ALOC,ATYP,FIRST,NONE
210 ..S CNT=0,NONE=1,FIRST=1
211 ..I '$D(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM)) Q
212 ..F S CNT=$O(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT)) Q:CNT'>0 D
213 ...S ADAT=$P(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U)
214 ...I PXRMDLOC="Y" D
215 ....S ALOC=$P(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U,2)
216 ....S ATYP=$P(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U,3)
217 ...S ADAT=$$FMTE^XLFDT(ADAT,"2P")
218 ...I FIRST D S FIRST=0,NONE=0
219 ....I PXRMTABS="N" W ?64,$S(BED'="NONE":BED_" (Inp.)",1:"")
220 ...D CHECK
221 ...I PXRMDLOC="Y" D
222 ....I PXRMTABS="N" W !,?8,ADAT,?30,$E(ALOC,1,25),?60,$E(ATYP,1,20)
223 ....I PXRMTABS="Y" W SEP_ADAT_SEP_$E(ALOC,1,25)_SEP_$E(ATYP,1,20)
224 ...I PXRMDLOC="N" D
225 ....I PXRMTABS="N" W !,?10,ADAT
226 ....I PXRMTABS="Y" W SEP_ADAT
227 ..I NONE,PXRMTABS="N" W ?64,FDAT3
228 ..I NONE,PXRMTABS="Y" W SEP_FDAT3
229 ..I PXRMTABS="Y" W $S(BED'="NONE":SEP_BED_" (Inp.)",1:"")
230 ..K ^UTILITY("VASD",$J)
231 Q
232 ;
233 ;Summary by Reminder
234SUMARY N JJ,EVAL,DUE,RNAM,RNUM,ITEM,COUNT,FTXT
235 S NAM=$G(^XTMP(PXRMXTMP,PX,FAC,SUB)),HEAD=1
236 S TOTAL=$P(NAM,U,3),COUNT=$P(NAM,U,2),NAM=$P(NAM,U,1)
237 S RNUM=$O(REMINDER(""),-1)
238 ;Get reminders in alpha order
239 F JJ=1:1:RNUM D Q:DONE
240 .S ITEM=$P(REMINDER(JJ),U,1),RNAM=$P(REMINDER(JJ),U,4)
241 .S:RNAM="" RNAM=$P(REMINDER(JJ),U,2)
242 .; zero lines will be printed
243 .S DUE=$G(^XTMP(PXRMXTMP,PX,FAC,SUB,ITEM))
244 .S EVAL=+$P(DUE,U,1),DUE=+$P(DUE,U,2)
245 .;Print
246 .D CHECK Q:DONE
247 .;Normal Report
248 .I PXRMTABS="N" W !,JJ,?5,RNAM,?48,$J(EVAL,10),?63,$J(DUE,10)
249 .;Condensed Report
250 .I PXRMTABS="Y" D
251 ..I "CES"[PXRMTABC S RNAM=$TR(RNAM,SEP,"_")
252 ..W !,JJ_SEP_RNAM_SEP_EVAL_SEP_DUE_SEP_$TR(NAM,SEP,"_")
253 D:'DONE TOTAL^PXRMXGPR
254 I $G(SUB)'="TOTAL",PXRMTOT'="T" S TTOTAL=TTOTAL+TOTAL
255 I $G(SUB)="TOTAL",PXRMTOT="T" S TTOTAL=TTOTAL+TOTAL
256 Q
257 ;
258 ;Check line count before writing line
259CHECK I ((PXRMTABS="N")&($Y>(IOSL-BMARG-3)))!(HEAD=1) D COL^PXRMXGPR(1)
260 Q
261 ;
262 ;Check if employee
263EMP N VAEL
264 D ELIG^VADPT
265 ;Check TYPE (#391) field
266 I $P($G(VAEL(6)),U,2)="EMPLOYEE" S EMP=1 Q
267 ;Check PATIENT ELIGABILITY (#361) field
268 N ELIG
269 S ELIG=0,EMP=0
270 F S ELIG=$O(VAEL(1,ELIG)) Q:'ELIG D Q:EMP
271 .I $P($G(VAEL(1,ELIG)),U,2)="EMPLOYEE" S EMP=1
272 Q
273 ;
274 ;Sort internal numbers into Alpha order
275XSORT N SUB,NAM
276 K ^TMP($J,"SORT")
277 S SUB=""
278 F S SUB=$O(^XTMP(PXRMXTMP,PX,FAC,SUB)) Q:SUB="" D
279 .Q:SUB="TOTAL"
280 .S NAM=$P(^XTMP(PXRMXTMP,PX,FAC,SUB),U)
281 .I NAM="" S NAM=SUB
282 .S ^TMP($J,"SORT",NAM)=SUB
283 Q
284 ;
Note: See TracBrowser for help on using the repository browser.