Changeset 623 for WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXPR.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXPR.m
r613 r623 1 PXRMXPR ; 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 ; 6 START 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 144 EXIT ; 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 155 DETAIL 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 ; 169 PAT ;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 234 SUMARY 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 259 CHECK I ((PXRMTABS="N")&($Y>(IOSL-BMARG-3)))!(HEAD=1) D COL^PXRMXGPR(1) 260 Q 261 ; 262 ;Check if employee 263 EMP 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 275 XSORT 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 ; 1 PXRMXPR ; 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 ; 6 START 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 144 EXIT ; 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 154 DETAIL 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 ; 168 PAT ;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 233 SUMARY 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 258 CHECK I ((PXRMTABS="N")&($Y>(IOSL-BMARG-3)))!(HEAD=1) D COL^PXRMXGPR(1) 259 Q 260 ; 261 ;Check if employee 262 EMP 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 274 XSORT 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 TracChangeset
for help on using the changeset viewer.
