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

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

revised back to 6/30/08 version

File size: 8.8 KB
Line 
1PXRMXPR ; SLC/PJH - Print Reminder Due report. ;01/14/2006
2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
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) 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 EXIT^PXRMXGUT
146 ;
147 ;Allow the task to be cleaned up upon successful completion.
148 I $D(ZTQUEUED) S ZTREQ="@"
149 ;
150 D EOR^PXRMXGUT
151 Q
152 ;
153 ;Report by Patient
154DETAIL N JJ,VA,DATE,COUNT,DDAT,EMP
155 N BED,DDUE,DDONE,DNEXT,FDAT1,FDAT2,FDAT3,FNAM,FTXT
156 S NAM=$G(^XTMP(PXRMXTMP,PX,FAC,SUB)),HEAD=1
157 S COUNT=$P(NAM,U,2),TOTAL=$P(NAM,U,3),APPL=$P(NAM,U,4),NAM=$P(NAM,U,1)
158 S DDAT="",JJ=0
159 ; Get list of patients for each appointment date
160 F S DDAT=$O(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT)) Q:DDAT="" Q:DONE D PAT
161 ; No patients due
162 I JJ=0 D:'DONE NONE^PXRMXGPR
163 ; Total patients
164 D:'DONE TOTAL^PXRMXGPR
165 S TTOTAL=TTOTAL+TOTAL
166 Q
167 ;
168PAT ;Extract and print patient detail
169 N DNEXT1,NODE,PNUM
170 F S PNAM=$O(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM)) Q:PNAM="" Q:DONE D
171 .S JJ=JJ+1
172 .;Format print line
173 .S (BID,DNEXT1,FDAT1,FDAT2,FDAT3,DNEXT1)="" I PNAM'["No patients found" D
174 ..S FDAT2="N/A",FDAT3="None"
175 ..S NODE=$G(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM))
176 ..S DDUE=$P(NODE,U,2),DDONE=$P(NODE,U,3),DNEXT=$P(NODE,U,4)
177 ..S BED=$P(NODE,U,5)
178 ..S DFN=$P(NODE,U) S BID=$P($G(PNAM),U,2)
179 ..I PXRMSSN="N" S BID=$E(BID,6,9)
180 ..I PXRMSSN="Y",EMPCHK="Y" D EMP S:EMP BID=$E(BID,6,9)
181 ..S BID="("_BID_")"
182 ..S FDAT1=$$FMTE^XLFDT(DDUE,"5D")
183 ..I DDONE S FDAT2=$$FMTE^XLFDT(DDONE,"5D")
184 ..I BED'="NONE" S FDAT3=$P(NODE,U,5),DNEXT1=$$FMTE^XLFDT(DNEXT,"5D")
185 ..I DNEXT,FDAT3="None" S FDAT3=$$FMTE^XLFDT(DNEXT,"5D")
186 .;Print
187 .D CHECK Q:DONE
188 .;Normal output
189 .I PXRMTABS="N" D
190 ..S PNUM=JJ#10000
191 ..S PNUM=$$RJ^XLFSTR(PNUM,4)
192 ..W !,PNUM,?5,$E($P($G(PNAM),U),1,33-$L(BID))," ",BID,?40,FDAT1,?52,FDAT2
193 ..I ('$G(PXRMINP)),PXRMFUT'="Y" W ?64,$S(BED'="NONE":BED_" (Inp.)",1:FDAT3)
194 ..I $G(PXRMINP) W ?64,BED
195 ..I DNEXT1'="",PXRMFUT'="Y" W !,?64,DNEXT1
196 .;Delimited report
197 .I PXRMTABS="Y" D
198 ..N FNAM
199 ..S FNAM=$P($G(PNAM),U)
200 ..I FNAM'["No patients found" S FNAM=$E(FNAM,1,33-$L(BID))_" "_BID
201 ..I "CES"[PXRMTABC S FNAM=$TR(FNAM,SEP,"_"),FDAT1=$TR(FDAT1,SEP,"_")
202 ..I BED="NONE" S BED=" "
203 ..W !,JJ_SEP_FNAM_SEP_FDAT1_SEP_FDAT2 I $G(PXRMINP) W SEP_BED
204 ..I ('$G(PXRMINP)),PXRMFUT'="Y" W SEP_FDAT3_SEP_BED
205 .;---
206 .; Future Appointments
207 .I PXRMFUT="Y" D
208 ..N CNT,ADAT,ALOC,ATYP,FIRST,NONE
209 ..S CNT=0,NONE=1,FIRST=1
210 ..I '$D(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM)) Q
211 ..F S CNT=$O(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT)) Q:CNT'>0 D
212 ...S ADAT=$P(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U)
213 ...I PXRMDLOC="Y" D
214 ....S ALOC=$P(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U,2)
215 ....S ATYP=$P(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U,3)
216 ...S ADAT=$$FMTE^XLFDT(ADAT,"2P")
217 ...I FIRST D S FIRST=0,NONE=0
218 ....I PXRMTABS="N" W ?64,$S(BED'="NONE":BED_" (Inp.)",1:"")
219 ...D CHECK
220 ...I PXRMDLOC="Y" D
221 ....I PXRMTABS="N" W !,?8,ADAT,?30,$E(ALOC,1,25),?60,$E(ATYP,1,20)
222 ....I PXRMTABS="Y" W SEP_ADAT_SEP_$E(ALOC,1,25)_SEP_$E(ATYP,1,20)
223 ...I PXRMDLOC="N" D
224 ....I PXRMTABS="N" W !,?10,ADAT
225 ....I PXRMTABS="Y" W SEP_ADAT
226 ..I NONE,PXRMTABS="N" W ?64,FDAT3
227 ..I NONE,PXRMTABS="Y" W SEP_FDAT3
228 ..I PXRMTABS="Y" W $S(BED'="NONE":SEP_BED_" (Inp.)",1:"")
229 ..K ^UTILITY("VASD",$J)
230 Q
231 ;
232 ;Summary by Reminder
233SUMARY N JJ,EVAL,DUE,RNAM,RNUM,ITEM,COUNT,FTXT
234 S NAM=$G(^XTMP(PXRMXTMP,PX,FAC,SUB)),HEAD=1
235 S TOTAL=$P(NAM,U,3),COUNT=$P(NAM,U,2),NAM=$P(NAM,U,1)
236 S RNUM=$O(REMINDER(""),-1)
237 ;Get reminders in alpha order
238 F JJ=1:1:RNUM D Q:DONE
239 .S ITEM=$P(REMINDER(JJ),U,1),RNAM=$P(REMINDER(JJ),U,4)
240 .S:RNAM="" RNAM=$P(REMINDER(JJ),U,2)
241 .; zero lines will be printed
242 .S DUE=$G(^XTMP(PXRMXTMP,PX,FAC,SUB,ITEM))
243 .S EVAL=+$P(DUE,U,1),DUE=+$P(DUE,U,2)
244 .;Print
245 .D CHECK Q:DONE
246 .;Normal Report
247 .I PXRMTABS="N" W !,JJ,?5,RNAM,?48,$J(EVAL,10),?63,$J(DUE,10)
248 .;Condensed Report
249 .I PXRMTABS="Y" D
250 ..I "CES"[PXRMTABC S RNAM=$TR(RNAM,SEP,"_")
251 ..W !,JJ_SEP_RNAM_SEP_EVAL_SEP_DUE_SEP_$TR(NAM,SEP,"_")
252 D:'DONE TOTAL^PXRMXGPR
253 I $G(SUB)'="TOTAL",PXRMTOT'="T" S TTOTAL=TTOTAL+TOTAL
254 I $G(SUB)="TOTAL",PXRMTOT="T" S TTOTAL=TTOTAL+TOTAL
255 Q
256 ;
257 ;Check line count before writing line
258CHECK I ((PXRMTABS="N")&($Y>(IOSL-BMARG-3)))!(HEAD=1) D COL^PXRMXGPR(1)
259 Q
260 ;
261 ;Check if employee
262EMP N VAEL
263 D ELIG^VADPT
264 ;Check TYPE (#391) field
265 I $P($G(VAEL(6)),U,2)="EMPLOYEE" S EMP=1 Q
266 ;Check PATIENT ELIGABILITY (#361) field
267 N ELIG
268 S ELIG=0,EMP=0
269 F S ELIG=$O(VAEL(1,ELIG)) Q:'ELIG D Q:EMP
270 .I $P($G(VAEL(1,ELIG)),U,2)="EMPLOYEE" S EMP=1
271 Q
272 ;
273 ;Sort internal numbers into Alpha order
274XSORT N SUB,NAM
275 K ^TMP($J,"SORT")
276 S SUB=""
277 F S SUB=$O(^XTMP(PXRMXTMP,PX,FAC,SUB)) Q:SUB="" D
278 .Q:SUB="TOTAL"
279 .S NAM=$P(^XTMP(PXRMXTMP,PX,FAC,SUB),U)
280 .I NAM="" S NAM=SUB
281 .S ^TMP($J,"SORT",NAM)=SUB
282 Q
283 ;
Note: See TracBrowser for help on using the repository browser.