PXRMXPR ; SLC/PJH,PKR - Print Reminder Due report. ;05/05/2009
;;2.0;CLINICAL REMINDERS;**4,6,12**;Feb 04, 2005;Build 73
;
; Called/Jobbed after PXRMXSE1
;
START N BMARG,CRITERIA,C1S,C2S,C3S,C1HS,C2HS,C3HS,DONE,FIRST,HEAD
N INDENT,PAGE,MOD,DES,ADES,CDES,RDES,SDES,MISSED,SEP
N PLSTCRIT,PXRMOPT,PXRMFLD,PXRMHDR,PXRMHDRS,PXRMT,PXRMH,VDUZ
N BD,ED,EMPCHK,SD,RD
N PXRMTX
N IOP,POP,XMDUZ,XMQUIET,XMSUB,XMY,%ZIS
;Check for output to p-message. TaskMan will automatically copy
;^TMP("XM-MESS",$J) to the tasked job.
I $D(^TMP("XM-MESS",$J)) D
. S XMQUIET=1
. S XMDUZ=$G(^TMP("XM-MESS",$J,"XMAPHOST","XMINSTR","FROM"))
. I XMDUZ="" S XMDUZ=^TMP("XM-MESS",$J,"XMAPHOST","XMDUZ")
. S XMSUB=^TMP("XM-MESS",$J,"XMAPHOST","XMSUB")
. S VDUZ=""
. F S VDUZ=$O(^TMP("XM-MESS",$J,"XMY",VDUZ)) Q:VDUZ="" S XMY(VDUZ)=""
. I $D(XMY(DUZ)),$D(^TMP("XM-MESS",$J,"XMAPHOST","XMINSTR","SELF BSKT")) S XMY(DUZ,0)=^TMP("XM-MESS",$J,"XMAPHOST","XMINSTR","SELF BSKT")
S IOP=PXRMIOP
I $D(PXRMHFIO) S %ZIS("HFSNAME")=PXRMHFIO
D ^%ZIS
I POP G EXIT
U IO
S PXRMTX="due"
I PXRMREP="D" D
.S EMPCHK=$P($G(^PXRM(800,1,"TRUNCATE EMPLOYEE SSN")),U)
.I EMPCHK="" S EMPCHK="Y"
;
; Format Date Range
I PXRMSEL="L" D
.S BD=$$FMTE^XLFDT(PXRMBDT,"5D")
.S ED=$$FMTE^XLFDT(PXRMEDT,"5D")
; Format due effective date
S SD=$$FMTE^XLFDT(PXRMSDT,"5P")
; Format run date
S RD=$$FMTE^XLFDT(PXRMXST,"5P")
S DONE=0
;
;Delimited report.
S SEP=$S(PXRMTABS="Y":PXRMTABC,1:"")
;
;Setup initial formatting parameters.
S INDENT=3
S BMARG=2,PAGE=0,HEAD=1
;
I +$G(XQY)>0 N XQOPT D OP^XQCHK
S PXRMOPT=$P($G(XQOPT),U,2)
I ($L(PXRMOPT)>0)&(PXRMOPT'["Clinical") S PXRMOPT="Clinical "_PXRMOPT
I PXRMREP="D" D
.S RDES=$P(REMINDER(1),U,2)
.S PXRMOPT=PXRMOPT_" - Detailed Report"
.N IC F IC=0,3,4 S PXRMH(IC)="",PXRMT(IC)=0
.S PXRMH(1)="Date Due Last Done Next Appt"
.S PXRMH(2)="-------- --------- ---------"
.I $G(PXRMINP) D
..S PXRMH(1)="Date Due Last Done Ward/Bed"
..S PXRMH(2)="-------- --------- --------"
.F IC=1,2 S PXRMT(IC)=40
.S ADES="Next Appointment only"
.I PXRMFUT="Y" S ADES="All Future Appointments"
.S SDES="Sorted by Patient Name"
.I PXRMSRT="Y" S SDES="Sorted by Appointment Date"
I PXRMREP="S" D
.S PXRMOPT=PXRMOPT_" - Summary Report"
.S PXRMH(0)="# Patients with Reminders",PXRMT(0)=$S(PXRMPER=0:50,1:20)
.I PXRMPER=1 D
..S PXRMH(1)="Applicable Due %Appl %Due %Done"
..S PXRMH(2)="---------- --- ----- ---- -----"
.I PXRMPER=0 D
..S PXRMH(1)="Applicable Due"
..S PXRMH(2)="---------- ---"
.N IC F IC=1,2 S PXRMT(IC)=$S(PXRMPER=0:50,1:20)
.S PXRMH(3)="Denominator"
.S PXRMH(4)="-----------"
.F IC=3,4 S PXRMT(IC)=0
;
;Print Criteria Page if normal report
S CRITERIA=0 I PXRMTABS="N" S CRITERIA=1
;or delimited report with notemplate
I PXRMTABS="Y",PXRMTMP="" S CRITERIA=1
;
;Build array of locations/providers with no patients selected in
;MISSED.
D NOPATS^PXRMXPR1(.MISSED)
;
;Print either criteria page or summary header
I CRITERIA D G:DONE EXIT
.D PAGE^PXRMXGPR Q:DONE
.D CRIT^PXRMXGPR(10,.PLSTCRIT) Q:DONE
;Header if delimited output from a template
I 'CRITERIA D
.N HDR1,HDR2,HDR3
.S HDR1="",HDR2="",HDR3=""
.I PXRMTMP]"" S HDR1="TITLE:"_$P(PXRMTMP,U,2)_U_"TEMPLATE:"_$P(PXRMTMP,U,3)
.I PXRMTMP="" D
..N PXRMFLD,DES,CDES D LITS^PXRMXPR1 S HDR1=PXRMFLD_U_$G(DES)_U_$G(CDES)
.I PXRMSEL="L" S HDR2="START:"_BD_U_"END:"_ED
.S HDR2=HDR2_U_"RUN:"_RD_"Effective Date:"_SD
.I PXRMFCMB="Y" S HDR3="COMBINED FACILITY"
.I PXRMLCMB="Y" S $P(HDR3,SEP,2)="COMBINED LOCATION"
.I PXRMTCMB="Y" S $P(HDR3,SEP,2)="COMBINED OE/RR TEAMS"
.I PXRMREP="S" D
..N LIT1,LIT2,LIT3
..D LIT^PXRMXD
..I PXRMTOT="I" S $P(HDR3,SEP,3)=$$UP^XLFSTR(LIT1)
..I PXRMTOT="R" S $P(HDR3,SEP,3)=$$UP^XLFSTR(LIT2)
..I PXRMTOT="T" S $P(HDR3,SEP,3)=$$UP^XLFSTR(LIT3)
.S PLSTCRIT(1)=HDR1,PLSTCRIT(2)=HDR2,PLSTCRIT(3)=HDR3
.W !,HDR1,!,HDR2,!,HDR3,!
;
;Kill items marked as found
K ^XTMP(PXRMXTMP,"MARKED AS FOUND")
;
;Setup the final formatting parameters.
S C1HS=INDENT+3
S C1S=0
S C2HS=C1S+2
S C2S=C2HS
S C3HS=C2HS+5
S C3S=C3HS
S HEAD=1
S INDENT=10
;
; Update last run date
I $G(PXRMTMP)'="" D UPD^PXRMXTU
;
; Get report detail from ^XTMP
N DUECNT,PNAM,SUB,DFN,BID,NAM,FAC,MOD,SRT,TOTAL,APPL,FACPNAME,PX,TTOTAL
S TTOTAL=0
; Set subroutine label from report format
S MOD="SUMARY" I PXRMREP="D" S MOD="DETAIL"
;
S FAC=0,PX="PXRM"
F S FAC=$O(^XTMP(PXRMXTMP,PX,FAC)) Q:FAC="" Q:DONE D
.;Get facility name for Location and PCMM team report
.I "TL"[PXRMSEL,PXRMFCMB="N" D
..S FACPNAME=$P(PXRMFACN(FAC),U,1)_" "_$P(PXRMFACN(FAC),U,2)
.;Report from ^XTMP - label MOD is DETAIL/SUMARY
.S (PNAM,SUB,NAM,SRT)=""
.I PXRMSEL="I" S SUB="INDIVIDUAL PATIENTS" D @MOD Q:DONE
.I PXRMSEL'="I" D
..;Sort internal IENs into alpha order
..D XSORT
..F S SRT=$O(^TMP($J,"SORT",SRT)) Q:SRT="" Q:DONE D
...S SUB=$G(^TMP($J,"SORT",SRT)) D @MOD
..I MOD="SUMARY","RT"[PXRMTOT S SUB="TOTAL" D @MOD
;
; Null report if no patients selected
I ('DONE),$O(^XTMP(PXRMXTMP,PX,""))="" D NULL^PXRMXGPR G EXIT
; Report selected patient sample with no patients
I $D(MISSED),PXRMPML=1 D MISSED^PXRMXPR1(0,.MISSED)
;
;Print Patient List
I $G(PATLST)="Y" D FOOTER^PXRMXPR1(.PLSTCRIT)
;
;Print Error message
I $D(^XTMP(PXRMXTMP,"ERROR"))>0!($D(^XTMP(PXRMXTMP,"CNBD"))>0) D ERROR^PXRMXBSY
EXIT ;
D TIMING^PXRMXGUT
D EXIT^PXRMXGUT
;
;Allow the task to be cleaned up upon successful completion.
I $D(ZTQUEUED) S ZTREQ="@"
D EOR^PXRMXGUT
Q
;
;Report by Patient
DETAIL N JJ,VA,DATE,COUNT,DDAT,EMP
N BED,DDUE,DDONE,DNEXT,FDAT1,FDAT2,FDAT3,FNAM,FTXT
S NAM=$G(^XTMP(PXRMXTMP,PX,FAC,SUB)),HEAD=1
S COUNT=$P(NAM,U,2),TOTAL=$P(NAM,U,3),APPL=$P(NAM,U,4),NAM=$P(NAM,U,1)
S DDAT="",JJ=0
; Get list of patients for each appointment date
F S DDAT=$O(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT)) Q:DDAT="" Q:DONE D PAT
; No patients due
I JJ=0 D:'DONE NONE^PXRMXGPR
; Total patients
D:'DONE TOTAL^PXRMXGPR
S TTOTAL=TTOTAL+TOTAL
Q
;
PAT ;Extract and print patient detail
N DNEXT1,NODE,PNUM
F S PNAM=$O(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM)) Q:PNAM="" Q:DONE D
.S JJ=JJ+1
.;Format print line
.S (BID,DNEXT1,FDAT1,FDAT2,FDAT3,DNEXT1)="" I PNAM'["No patients found" D
..S FDAT2="N/A",FDAT3="None"
..S NODE=$G(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM))
..S DDUE=$P(NODE,U,2),DDONE=$P(NODE,U,3),DNEXT=$P(NODE,U,4)
..S BED=$P(NODE,U,5)
..S DFN=$P(NODE,U) S BID=$P($G(PNAM),U,2)
..I PXRMSSN="N" S BID=$E(BID,6,9)
..I PXRMSSN="Y",EMPCHK="Y" D EMP S:EMP BID=$E(BID,6,9)
..S BID="("_BID_")"
..S FDAT1=$$FMTE^XLFDT(DDUE,"5D")
..I DDONE S FDAT2=$$FMTE^XLFDT(DDONE,"5D")
..I BED'="NONE" S FDAT3=$P(NODE,U,5),DNEXT1=$$FMTE^XLFDT(DNEXT,"5D")
..I DNEXT,FDAT3="None" S FDAT3=$$FMTE^XLFDT(DNEXT,"5D")
.;Print
.D CHECK Q:DONE
.;Normal output
.I PXRMTABS="N" D
..S PNUM=JJ#10000
..S PNUM=$$RJ^XLFSTR(PNUM,4)
..W !,PNUM,?5,$E($P($G(PNAM),U),1,33-$L(BID))," ",BID,?40,FDAT1,?52,FDAT2
..I ('$G(PXRMINP)),PXRMFUT'="Y" W ?64,$S(BED'="NONE":BED_" (Inp.)",1:FDAT3)
..I $G(PXRMINP) W ?64,BED
..I DNEXT1'="",PXRMFUT'="Y" W !,?64,DNEXT1
.;Delimited report
.I PXRMTABS="Y" D
..N FNAM
..S FNAM=$P($G(PNAM),U)
..I FNAM'["No patients found" S FNAM=$E(FNAM,1,33-$L(BID))_" "_BID
..I "CES"[PXRMTABC S FNAM=$TR(FNAM,SEP,"_"),FDAT1=$TR(FDAT1,SEP,"_")
..I BED="NONE" S BED=" "
..W !,JJ_SEP_FNAM_SEP_FDAT1_SEP_FDAT2 I $G(PXRMINP) W SEP_BED
..I ('$G(PXRMINP)),PXRMFUT'="Y" W SEP_FDAT3_SEP_BED
.;---
.; Future Appointments
.I PXRMFUT="Y" D
..N CNT,ADAT,ALOC,ATYP,FIRST,NONE
..S CNT=0,NONE=1,FIRST=1
..I '$D(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM)) Q
..F S CNT=$O(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT)) Q:CNT'>0 D
...S ADAT=$P(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U)
...I PXRMDLOC="Y" D
....S ALOC=$P(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U,2)
....S ATYP=$P(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U,3)
...S ADAT=$$FMTE^XLFDT(ADAT,"2P")
...I FIRST D S FIRST=0,NONE=0
....I PXRMTABS="N" W ?64,$S(BED'="NONE":BED_" (Inp.)",1:"")
...D CHECK
...I PXRMDLOC="Y" D
....I PXRMTABS="N" W !,?8,ADAT,?30,$E(ALOC,1,25),?60,$E(ATYP,1,20)
....I PXRMTABS="Y" W SEP_ADAT_SEP_$E(ALOC,1,25)_SEP_$E(ATYP,1,20)
...I PXRMDLOC="N" D
....I PXRMTABS="N" W !,?10,ADAT
....I PXRMTABS="Y" W SEP_ADAT
..I NONE,PXRMTABS="N" W ?64,FDAT3
..I NONE,PXRMTABS="Y" W SEP_FDAT3
..I PXRMTABS="Y" W $S(BED'="NONE":SEP_BED_" (Inp.)",1:"")
..K ^UTILITY("VASD",$J)
Q
;
;Summary by Reminder
SUMARY ;
N JJ,EVAL,DUE,RNAM,RNUM,ITEM,COUNT,FTXT,PAPPL,PDUE,PDONE,PERCENT
S NAM=$G(^XTMP(PXRMXTMP,PX,FAC,SUB)),HEAD=1
S TOTAL=$P(NAM,U,3),COUNT=$P(NAM,U,2),NAM=$P(NAM,U,1)
S RNUM=$O(REMINDER(""),-1)
;Get reminders in alpha order
F JJ=1:1:RNUM D Q:DONE
.S ITEM=$P(REMINDER(JJ),U,1),RNAM=$P(REMINDER(JJ),U,4)
.S:RNAM="" RNAM=$P(REMINDER(JJ),U,2)
.; zero lines will be printed
.S DUE=$G(^XTMP(PXRMXTMP,PX,FAC,SUB,ITEM))
.S EVAL=+$P(DUE,U,1),DUE=+$P(DUE,U,2)
.D SUMP(RNAM,NAM,TOTAL,EVAL,DUE)
D:'DONE TOTAL^PXRMXGPR
I $G(SUB)'="TOTAL",PXRMTOT'="T" S TTOTAL=TTOTAL+TOTAL
I $G(SUB)="TOTAL",PXRMTOT="T" S TTOTAL=TTOTAL+TOTAL
I PXRMCCS="B" D
.N LOC,SUBTOT
.S LOC="" F S LOC=$O(^XTMP(PXRMXCCS,PX,FAC,SUB,LOC)) Q:LOC="" D
..S NAM=$G(^XTMP(PXRMXCCS,PX,FAC,SUB,LOC)),HEAD=1
..S TOTAL=$P(NAM,U,3),COUNT=$P(NAM,U,2),NAM=$P(NAM,U,1)
..S NAM="Clinic Stop "_SUB_" location "_NAM
..S RNUM=$O(REMINDER(""),-1)
..;Get reminders in alpha order
..F JJ=1:1:RNUM D Q:DONE
...S ITEM=$P(REMINDER(JJ),U,1),RNAM=$P(REMINDER(JJ),U,4)
...S:RNAM="" RNAM=$P(REMINDER(JJ),U,2)
...; zero lines will be printed
...S DUE=$G(^XTMP(PXRMXCCS,PX,FAC,SUB,LOC,ITEM))
...S EVAL=+$P(DUE,U,1),DUE=+$P(DUE,U,2)
...D SUMP(RNAM,NAM,TOTAL,EVAL,DUE)
..D:'DONE TOTAL^PXRMXGPR
Q
;
SUMP(RNAM,NAM,TOTAL,EVAL,DUE) ;
;Print
D CHECK Q:DONE
;Normal Report
I PXRMTABS="N" D
.I PXRMPER=1 D
..S PERCENT=$$DOPER^PXRMXGPR(TOTAL,EVAL,DUE)
..S PAPPL=$P(PERCENT,U),PDUE=$P(PERCENT,U,2),PDONE=$P(PERCENT,U,3)
..W !,JJ,?5,RNAM
..W !,?20,$J(EVAL,10),?29,$J(DUE,8),?45,$J(PAPPL,5),?53,$J(PDUE,4),?60,$J(PDONE,5)
.I PXRMPER=0 D
..W !,JJ,?5,RNAM,?50,$J(EVAL,10),?62,$J(DUE,10)
;Condensed Report
I PXRMTABS="Y" D
.I "CES"[PXRMTABC S RNAM=$TR(RNAM,SEP,"_")
.I PXRMPER=1 D
..S PERCENT=$$DOPER^PXRMXGPR(TOTAL,EVAL,DUE)
..S PAPPL=$P(PERCENT,U),PDUE=$P(PERCENT,U,2),PDONE=$P(PERCENT,U,3)
..W !,JJ_SEP_RNAM_SEP_EVAL_SEP_DUE_SEP_$TR(NAM,SEP,"_")_SEP_PAPPL_SEP_PDUE_SEP_PDONE_SEP
.I PXRMPER=0 W !,JJ_SEP_RNAM_SEP_EVAL_SEP_DUE_SEP_$TR(NAM,SEP,"_")_SEP
Q
;
;Check line count before writing line
CHECK I ((PXRMTABS="N")&($Y>(IOSL-BMARG-3)))!(HEAD=1) D COL^PXRMXGPR(1)
Q
;
;Check if employee
EMP N VAEL
D ELIG^VADPT
;Check TYPE (#391) field
I $P($G(VAEL(6)),U,2)="EMPLOYEE" S EMP=1 Q
;Check PATIENT ELIGABILITY (#361) field
N ELIG
S ELIG=0,EMP=0
F S ELIG=$O(VAEL(1,ELIG)) Q:'ELIG D Q:EMP
.I $P($G(VAEL(1,ELIG)),U,2)="EMPLOYEE" S EMP=1
Q
;
;Sort internal numbers into Alpha order
XSORT N SUB,NAM
K ^TMP($J,"SORT")
S SUB=""
F S SUB=$O(^XTMP(PXRMXTMP,PX,FAC,SUB)) Q:SUB="" D
.Q:SUB="TOTAL"
.S NAM=$P(^XTMP(PXRMXTMP,PX,FAC,SUB),U)
.I NAM="" S NAM=SUB
.S ^TMP($J,"SORT",NAM)=SUB
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMXPR 11484 printed Dec 13, 2024@01:50:14 Page 2
PXRMXPR ; SLC/PJH,PKR - Print Reminder Due report. ;05/05/2009
+1 ;;2.0;CLINICAL REMINDERS;**4,6,12**;Feb 04, 2005;Build 73
+2 ;
+3 ; Called/Jobbed after PXRMXSE1
+4 ;
START NEW BMARG,CRITERIA,C1S,C2S,C3S,C1HS,C2HS,C3HS,DONE,FIRST,HEAD
+1 NEW INDENT,PAGE,MOD,DES,ADES,CDES,RDES,SDES,MISSED,SEP
+2 NEW PLSTCRIT,PXRMOPT,PXRMFLD,PXRMHDR,PXRMHDRS,PXRMT,PXRMH,VDUZ
+3 NEW BD,ED,EMPCHK,SD,RD
+4 NEW PXRMTX
+5 NEW IOP,POP,XMDUZ,XMQUIET,XMSUB,XMY,%ZIS
+6 ;Check for output to p-message. TaskMan will automatically copy
+7 ;^TMP("XM-MESS",$J) to the tasked job.
+8 IF $DATA(^TMP("XM-MESS",$JOB))
Begin DoDot:1
+9 SET XMQUIET=1
+10 SET XMDUZ=$GET(^TMP("XM-MESS",$JOB,"XMAPHOST","XMINSTR","FROM"))
+11 IF XMDUZ=""
SET XMDUZ=^TMP("XM-MESS",$JOB,"XMAPHOST","XMDUZ")
+12 SET XMSUB=^TMP("XM-MESS",$JOB,"XMAPHOST","XMSUB")
+13 SET VDUZ=""
+14 FOR
SET VDUZ=$ORDER(^TMP("XM-MESS",$JOB,"XMY",VDUZ))
if VDUZ=""
QUIT
SET XMY(VDUZ)=""
+15 IF $DATA(XMY(DUZ))
IF $DATA(^TMP("XM-MESS",$JOB,"XMAPHOST","XMINSTR","SELF BSKT"))
SET XMY(DUZ,0)=^TMP("XM-MESS",$JOB,"XMAPHOST","XMINSTR","SELF BSKT")
End DoDot:1
+16 SET IOP=PXRMIOP
+17 IF $DATA(PXRMHFIO)
SET %ZIS("HFSNAME")=PXRMHFIO
+18 DO ^%ZIS
+19 IF POP
GOTO EXIT
+20 USE IO
+21 SET PXRMTX="due"
+22 IF PXRMREP="D"
Begin DoDot:1
+23 SET EMPCHK=$PIECE($GET(^PXRM(800,1,"TRUNCATE EMPLOYEE SSN")),U)
+24 IF EMPCHK=""
SET EMPCHK="Y"
End DoDot:1
+25 ;
+26 ; Format Date Range
+27 IF PXRMSEL="L"
Begin DoDot:1
+28 SET BD=$$FMTE^XLFDT(PXRMBDT,"5D")
+29 SET ED=$$FMTE^XLFDT(PXRMEDT,"5D")
End DoDot:1
+30 ; Format due effective date
+31 SET SD=$$FMTE^XLFDT(PXRMSDT,"5P")
+32 ; Format run date
+33 SET RD=$$FMTE^XLFDT(PXRMXST,"5P")
+34 SET DONE=0
+35 ;
+36 ;Delimited report.
+37 SET SEP=$SELECT(PXRMTABS="Y":PXRMTABC,1:"")
+38 ;
+39 ;Setup initial formatting parameters.
+40 SET INDENT=3
+41 SET BMARG=2
SET PAGE=0
SET HEAD=1
+42 ;
+43 IF +$GET(XQY)>0
NEW XQOPT
DO OP^XQCHK
+44 SET PXRMOPT=$PIECE($GET(XQOPT),U,2)
+45 IF ($LENGTH(PXRMOPT)>0)&(PXRMOPT'["Clinical")
SET PXRMOPT="Clinical "_PXRMOPT
+46 IF PXRMREP="D"
Begin DoDot:1
+47 SET RDES=$PIECE(REMINDER(1),U,2)
+48 SET PXRMOPT=PXRMOPT_" - Detailed Report"
+49 NEW IC
FOR IC=0,3,4
SET PXRMH(IC)=""
SET PXRMT(IC)=0
+50 SET PXRMH(1)="Date Due Last Done Next Appt"
+51 SET PXRMH(2)="-------- --------- ---------"
+52 IF $GET(PXRMINP)
Begin DoDot:2
+53 SET PXRMH(1)="Date Due Last Done Ward/Bed"
+54 SET PXRMH(2)="-------- --------- --------"
End DoDot:2
+55 FOR IC=1,2
SET PXRMT(IC)=40
+56 SET ADES="Next Appointment only"
+57 IF PXRMFUT="Y"
SET ADES="All Future Appointments"
+58 SET SDES="Sorted by Patient Name"
+59 IF PXRMSRT="Y"
SET SDES="Sorted by Appointment Date"
End DoDot:1
+60 IF PXRMREP="S"
Begin DoDot:1
+61 SET PXRMOPT=PXRMOPT_" - Summary Report"
+62 SET PXRMH(0)="# Patients with Reminders"
SET PXRMT(0)=$SELECT(PXRMPER=0:50,1:20)
+63 IF PXRMPER=1
Begin DoDot:2
+64 SET PXRMH(1)="Applicable Due %Appl %Due %Done"
+65 SET PXRMH(2)="---------- --- ----- ---- -----"
End DoDot:2
+66 IF PXRMPER=0
Begin DoDot:2
+67 SET PXRMH(1)="Applicable Due"
+68 SET PXRMH(2)="---------- ---"
End DoDot:2
+69 NEW IC
FOR IC=1,2
SET PXRMT(IC)=$SELECT(PXRMPER=0:50,1:20)
+70 SET PXRMH(3)="Denominator"
+71 SET PXRMH(4)="-----------"
+72 FOR IC=3,4
SET PXRMT(IC)=0
End DoDot:1
+73 ;
+74 ;Print Criteria Page if normal report
+75 SET CRITERIA=0
IF PXRMTABS="N"
SET CRITERIA=1
+76 ;or delimited report with notemplate
+77 IF PXRMTABS="Y"
IF PXRMTMP=""
SET CRITERIA=1
+78 ;
+79 ;Build array of locations/providers with no patients selected in
+80 ;MISSED.
+81 DO NOPATS^PXRMXPR1(.MISSED)
+82 ;
+83 ;Print either criteria page or summary header
+84 IF CRITERIA
Begin DoDot:1
+85 DO PAGE^PXRMXGPR
if DONE
QUIT
+86 DO CRIT^PXRMXGPR(10,.PLSTCRIT)
if DONE
QUIT
End DoDot:1
if DONE
GOTO EXIT
+87 ;Header if delimited output from a template
+88 IF 'CRITERIA
Begin DoDot:1
+89 NEW HDR1,HDR2,HDR3
+90 SET HDR1=""
SET HDR2=""
SET HDR3=""
+91 IF PXRMTMP]""
SET HDR1="TITLE:"_$PIECE(PXRMTMP,U,2)_U_"TEMPLATE:"_$PIECE(PXRMTMP,U,3)
+92 IF PXRMTMP=""
Begin DoDot:2
+93 NEW PXRMFLD,DES,CDES
DO LITS^PXRMXPR1
SET HDR1=PXRMFLD_U_$GET(DES)_U_$GET(CDES)
End DoDot:2
+94 IF PXRMSEL="L"
SET HDR2="START:"_BD_U_"END:"_ED
+95 SET HDR2=HDR2_U_"RUN:"_RD_"Effective Date:"_SD
+96 IF PXRMFCMB="Y"
SET HDR3="COMBINED FACILITY"
+97 IF PXRMLCMB="Y"
SET $PIECE(HDR3,SEP,2)="COMBINED LOCATION"
+98 IF PXRMTCMB="Y"
SET $PIECE(HDR3,SEP,2)="COMBINED OE/RR TEAMS"
+99 IF PXRMREP="S"
Begin DoDot:2
+100 NEW LIT1,LIT2,LIT3
+101 DO LIT^PXRMXD
+102 IF PXRMTOT="I"
SET $PIECE(HDR3,SEP,3)=$$UP^XLFSTR(LIT1)
+103 IF PXRMTOT="R"
SET $PIECE(HDR3,SEP,3)=$$UP^XLFSTR(LIT2)
+104 IF PXRMTOT="T"
SET $PIECE(HDR3,SEP,3)=$$UP^XLFSTR(LIT3)
End DoDot:2
+105 SET PLSTCRIT(1)=HDR1
SET PLSTCRIT(2)=HDR2
SET PLSTCRIT(3)=HDR3
+106 WRITE !,HDR1,!,HDR2,!,HDR3,!
End DoDot:1
+107 ;
+108 ;Kill items marked as found
+109 KILL ^XTMP(PXRMXTMP,"MARKED AS FOUND")
+110 ;
+111 ;Setup the final formatting parameters.
+112 SET C1HS=INDENT+3
+113 SET C1S=0
+114 SET C2HS=C1S+2
+115 SET C2S=C2HS
+116 SET C3HS=C2HS+5
+117 SET C3S=C3HS
+118 SET HEAD=1
+119 SET INDENT=10
+120 ;
+121 ; Update last run date
+122 IF $GET(PXRMTMP)'=""
DO UPD^PXRMXTU
+123 ;
+124 ; Get report detail from ^XTMP
+125 NEW DUECNT,PNAM,SUB,DFN,BID,NAM,FAC,MOD,SRT,TOTAL,APPL,FACPNAME,PX,TTOTAL
+126 SET TTOTAL=0
+127 ; Set subroutine label from report format
+128 SET MOD="SUMARY"
IF PXRMREP="D"
SET MOD="DETAIL"
+129 ;
+130 SET FAC=0
SET PX="PXRM"
+131 FOR
SET FAC=$ORDER(^XTMP(PXRMXTMP,PX,FAC))
if FAC=""
QUIT
if DONE
QUIT
Begin DoDot:1
+132 ;Get facility name for Location and PCMM team report
+133 IF "TL"[PXRMSEL
IF PXRMFCMB="N"
Begin DoDot:2
+134 SET FACPNAME=$PIECE(PXRMFACN(FAC),U,1)_" "_$PIECE(PXRMFACN(FAC),U,2)
End DoDot:2
+135 ;Report from ^XTMP - label MOD is DETAIL/SUMARY
+136 SET (PNAM,SUB,NAM,SRT)=""
+137 IF PXRMSEL="I"
SET SUB="INDIVIDUAL PATIENTS"
DO @MOD
if DONE
QUIT
+138 IF PXRMSEL'="I"
Begin DoDot:2
+139 ;Sort internal IENs into alpha order
+140 DO XSORT
+141 FOR
SET SRT=$ORDER(^TMP($JOB,"SORT",SRT))
if SRT=""
QUIT
if DONE
QUIT
Begin DoDot:3
+142 SET SUB=$GET(^TMP($JOB,"SORT",SRT))
DO @MOD
End DoDot:3
+143 IF MOD="SUMARY"
IF "RT"[PXRMTOT
SET SUB="TOTAL"
DO @MOD
End DoDot:2
End DoDot:1
+144 ;
+145 ; Null report if no patients selected
+146 IF ('DONE)
IF $ORDER(^XTMP(PXRMXTMP,PX,""))=""
DO NULL^PXRMXGPR
GOTO EXIT
+147 ; Report selected patient sample with no patients
+148 IF $DATA(MISSED)
IF PXRMPML=1
DO MISSED^PXRMXPR1(0,.MISSED)
+149 ;
+150 ;Print Patient List
+151 IF $GET(PATLST)="Y"
DO FOOTER^PXRMXPR1(.PLSTCRIT)
+152 ;
+153 ;Print Error message
+154 IF $DATA(^XTMP(PXRMXTMP,"ERROR"))>0!($DATA(^XTMP(PXRMXTMP,"CNBD"))>0)
DO ERROR^PXRMXBSY
EXIT ;
+1 DO TIMING^PXRMXGUT
+2 DO EXIT^PXRMXGUT
+3 ;
+4 ;Allow the task to be cleaned up upon successful completion.
+5 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+6 DO EOR^PXRMXGUT
+7 QUIT
+8 ;
+9 ;Report by Patient
DETAIL NEW JJ,VA,DATE,COUNT,DDAT,EMP
+1 NEW BED,DDUE,DDONE,DNEXT,FDAT1,FDAT2,FDAT3,FNAM,FTXT
+2 SET NAM=$GET(^XTMP(PXRMXTMP,PX,FAC,SUB))
SET HEAD=1
+3 SET COUNT=$PIECE(NAM,U,2)
SET TOTAL=$PIECE(NAM,U,3)
SET APPL=$PIECE(NAM,U,4)
SET NAM=$PIECE(NAM,U,1)
+4 SET DDAT=""
SET JJ=0
+5 ; Get list of patients for each appointment date
+6 FOR
SET DDAT=$ORDER(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT))
if DDAT=""
QUIT
if DONE
QUIT
DO PAT
+7 ; No patients due
+8 IF JJ=0
if 'DONE
DO NONE^PXRMXGPR
+9 ; Total patients
+10 if 'DONE
DO TOTAL^PXRMXGPR
+11 SET TTOTAL=TTOTAL+TOTAL
+12 QUIT
+13 ;
PAT ;Extract and print patient detail
+1 NEW DNEXT1,NODE,PNUM
+2 FOR
SET PNAM=$ORDER(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM))
if PNAM=""
QUIT
if DONE
QUIT
Begin DoDot:1
+3 SET JJ=JJ+1
+4 ;Format print line
+5 SET (BID,DNEXT1,FDAT1,FDAT2,FDAT3,DNEXT1)=""
IF PNAM'["No patients found"
Begin DoDot:2
+6 SET FDAT2="N/A"
SET FDAT3="None"
+7 SET NODE=$GET(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM))
+8 SET DDUE=$PIECE(NODE,U,2)
SET DDONE=$PIECE(NODE,U,3)
SET DNEXT=$PIECE(NODE,U,4)
+9 SET BED=$PIECE(NODE,U,5)
+10 SET DFN=$PIECE(NODE,U)
SET BID=$PIECE($GET(PNAM),U,2)
+11 IF PXRMSSN="N"
SET BID=$EXTRACT(BID,6,9)
+12 IF PXRMSSN="Y"
IF EMPCHK="Y"
DO EMP
if EMP
SET BID=$EXTRACT(BID,6,9)
+13 SET BID="("_BID_")"
+14 SET FDAT1=$$FMTE^XLFDT(DDUE,"5D")
+15 IF DDONE
SET FDAT2=$$FMTE^XLFDT(DDONE,"5D")
+16 IF BED'="NONE"
SET FDAT3=$PIECE(NODE,U,5)
SET DNEXT1=$$FMTE^XLFDT(DNEXT,"5D")
+17 IF DNEXT
IF FDAT3="None"
SET FDAT3=$$FMTE^XLFDT(DNEXT,"5D")
End DoDot:2
+18 ;Print
+19 DO CHECK
if DONE
QUIT
+20 ;Normal output
+21 IF PXRMTABS="N"
Begin DoDot:2
+22 SET PNUM=JJ#10000
+23 SET PNUM=$$RJ^XLFSTR(PNUM,4)
+24 WRITE !,PNUM,?5,$EXTRACT($PIECE($GET(PNAM),U),1,33-$LENGTH(BID))," ",BID,?40,FDAT1,?52,FDAT2
+25 IF ('$GET(PXRMINP))
IF PXRMFUT'="Y"
WRITE ?64,$SELECT(BED'="NONE":BED_" (Inp.)",1:FDAT3)
+26 IF $GET(PXRMINP)
WRITE ?64,BED
+27 IF DNEXT1'=""
IF PXRMFUT'="Y"
WRITE !,?64,DNEXT1
End DoDot:2
+28 ;Delimited report
+29 IF PXRMTABS="Y"
Begin DoDot:2
+30 NEW FNAM
+31 SET FNAM=$PIECE($GET(PNAM),U)
+32 IF FNAM'["No patients found"
SET FNAM=$EXTRACT(FNAM,1,33-$LENGTH(BID))_" "_BID
+33 IF "CES"[PXRMTABC
SET FNAM=$TRANSLATE(FNAM,SEP,"_")
SET FDAT1=$TRANSLATE(FDAT1,SEP,"_")
+34 IF BED="NONE"
SET BED=" "
+35 WRITE !,JJ_SEP_FNAM_SEP_FDAT1_SEP_FDAT2
IF $GET(PXRMINP)
WRITE SEP_BED
+36 IF ('$GET(PXRMINP))
IF PXRMFUT'="Y"
WRITE SEP_FDAT3_SEP_BED
End DoDot:2
+37 ;---
+38 ; Future Appointments
+39 IF PXRMFUT="Y"
Begin DoDot:2
+40 NEW CNT,ADAT,ALOC,ATYP,FIRST,NONE
+41 SET CNT=0
SET NONE=1
SET FIRST=1
+42 IF '$DATA(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM))
QUIT
+43 FOR
SET CNT=$ORDER(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT))
if CNT'>0
QUIT
Begin DoDot:3
+44 SET ADAT=$PIECE(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U)
+45 IF PXRMDLOC="Y"
Begin DoDot:4
+46 SET ALOC=$PIECE(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U,2)
+47 SET ATYP=$PIECE(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U,3)
End DoDot:4
+48 SET ADAT=$$FMTE^XLFDT(ADAT,"2P")
+49 IF FIRST
Begin DoDot:4
+50 IF PXRMTABS="N"
WRITE ?64,$SELECT(BED'="NONE":BED_" (Inp.)",1:"")
End DoDot:4
SET FIRST=0
SET NONE=0
+51 DO CHECK
+52 IF PXRMDLOC="Y"
Begin DoDot:4
+53 IF PXRMTABS="N"
WRITE !,?8,ADAT,?30,$EXTRACT(ALOC,1,25),?60,$EXTRACT(ATYP,1,20)
+54 IF PXRMTABS="Y"
WRITE SEP_ADAT_SEP_$EXTRACT(ALOC,1,25)_SEP_$EXTRACT(ATYP,1,20)
End DoDot:4
+55 IF PXRMDLOC="N"
Begin DoDot:4
+56 IF PXRMTABS="N"
WRITE !,?10,ADAT
+57 IF PXRMTABS="Y"
WRITE SEP_ADAT
End DoDot:4
End DoDot:3
+58 IF NONE
IF PXRMTABS="N"
WRITE ?64,FDAT3
+59 IF NONE
IF PXRMTABS="Y"
WRITE SEP_FDAT3
+60 IF PXRMTABS="Y"
WRITE $SELECT(BED'="NONE":SEP_BED_" (Inp.)",1:"")
+61 KILL ^UTILITY("VASD",$JOB)
End DoDot:2
End DoDot:1
+62 QUIT
+63 ;
+64 ;Summary by Reminder
SUMARY ;
+1 NEW JJ,EVAL,DUE,RNAM,RNUM,ITEM,COUNT,FTXT,PAPPL,PDUE,PDONE,PERCENT
+2 SET NAM=$GET(^XTMP(PXRMXTMP,PX,FAC,SUB))
SET HEAD=1
+3 SET TOTAL=$PIECE(NAM,U,3)
SET COUNT=$PIECE(NAM,U,2)
SET NAM=$PIECE(NAM,U,1)
+4 SET RNUM=$ORDER(REMINDER(""),-1)
+5 ;Get reminders in alpha order
+6 FOR JJ=1:1:RNUM
Begin DoDot:1
+7 SET ITEM=$PIECE(REMINDER(JJ),U,1)
SET RNAM=$PIECE(REMINDER(JJ),U,4)
+8 if RNAM=""
SET RNAM=$PIECE(REMINDER(JJ),U,2)
+9 ; zero lines will be printed
+10 SET DUE=$GET(^XTMP(PXRMXTMP,PX,FAC,SUB,ITEM))
+11 SET EVAL=+$PIECE(DUE,U,1)
SET DUE=+$PIECE(DUE,U,2)
+12 DO SUMP(RNAM,NAM,TOTAL,EVAL,DUE)
End DoDot:1
if DONE
QUIT
+13 if 'DONE
DO TOTAL^PXRMXGPR
+14 IF $GET(SUB)'="TOTAL"
IF PXRMTOT'="T"
SET TTOTAL=TTOTAL+TOTAL
+15 IF $GET(SUB)="TOTAL"
IF PXRMTOT="T"
SET TTOTAL=TTOTAL+TOTAL
+16 IF PXRMCCS="B"
Begin DoDot:1
+17 NEW LOC,SUBTOT
+18 SET LOC=""
FOR
SET LOC=$ORDER(^XTMP(PXRMXCCS,PX,FAC,SUB,LOC))
if LOC=""
QUIT
Begin DoDot:2
+19 SET NAM=$GET(^XTMP(PXRMXCCS,PX,FAC,SUB,LOC))
SET HEAD=1
+20 SET TOTAL=$PIECE(NAM,U,3)
SET COUNT=$PIECE(NAM,U,2)
SET NAM=$PIECE(NAM,U,1)
+21 SET NAM="Clinic Stop "_SUB_" location "_NAM
+22 SET RNUM=$ORDER(REMINDER(""),-1)
+23 ;Get reminders in alpha order
+24 FOR JJ=1:1:RNUM
Begin DoDot:3
+25 SET ITEM=$PIECE(REMINDER(JJ),U,1)
SET RNAM=$PIECE(REMINDER(JJ),U,4)
+26 if RNAM=""
SET RNAM=$PIECE(REMINDER(JJ),U,2)
+27 ; zero lines will be printed
+28 SET DUE=$GET(^XTMP(PXRMXCCS,PX,FAC,SUB,LOC,ITEM))
+29 SET EVAL=+$PIECE(DUE,U,1)
SET DUE=+$PIECE(DUE,U,2)
+30 DO SUMP(RNAM,NAM,TOTAL,EVAL,DUE)
End DoDot:3
if DONE
QUIT
+31 if 'DONE
DO TOTAL^PXRMXGPR
End DoDot:2
End DoDot:1
+32 QUIT
+33 ;
SUMP(RNAM,NAM,TOTAL,EVAL,DUE) ;
+1 ;Print
+2 DO CHECK
if DONE
QUIT
+3 ;Normal Report
+4 IF PXRMTABS="N"
Begin DoDot:1
+5 IF PXRMPER=1
Begin DoDot:2
+6 SET PERCENT=$$DOPER^PXRMXGPR(TOTAL,EVAL,DUE)
+7 SET PAPPL=$PIECE(PERCENT,U)
SET PDUE=$PIECE(PERCENT,U,2)
SET PDONE=$PIECE(PERCENT,U,3)
+8 WRITE !,JJ,?5,RNAM
+9 WRITE !,?20,$JUSTIFY(EVAL,10),?29,$JUSTIFY(DUE,8),?45,$JUSTIFY(PAPPL,5),?53,$JUSTIFY(PDUE,4),?60,$JUSTIFY(PDONE,5)
End DoDot:2
+10 IF PXRMPER=0
Begin DoDot:2
+11 WRITE !,JJ,?5,RNAM,?50,$JUSTIFY(EVAL,10),?62,$JUSTIFY(DUE,10)
End DoDot:2
End DoDot:1
+12 ;Condensed Report
+13 IF PXRMTABS="Y"
Begin DoDot:1
+14 IF "CES"[PXRMTABC
SET RNAM=$TRANSLATE(RNAM,SEP,"_")
+15 IF PXRMPER=1
Begin DoDot:2
+16 SET PERCENT=$$DOPER^PXRMXGPR(TOTAL,EVAL,DUE)
+17 SET PAPPL=$PIECE(PERCENT,U)
SET PDUE=$PIECE(PERCENT,U,2)
SET PDONE=$PIECE(PERCENT,U,3)
+18 WRITE !,JJ_SEP_RNAM_SEP_EVAL_SEP_DUE_SEP_$TRANSLATE(NAM,SEP,"_")_SEP_PAPPL_SEP_PDUE_SEP_PDONE_SEP
End DoDot:2
+19 IF PXRMPER=0
WRITE !,JJ_SEP_RNAM_SEP_EVAL_SEP_DUE_SEP_$TRANSLATE(NAM,SEP,"_")_SEP
End DoDot:1
+20 QUIT
+21 ;
+22 ;Check line count before writing line
CHECK IF ((PXRMTABS="N")&($Y>(IOSL-BMARG-3)))!(HEAD=1)
DO COL^PXRMXGPR(1)
+1 QUIT
+2 ;
+3 ;Check if employee
EMP NEW VAEL
+1 DO ELIG^VADPT
+2 ;Check TYPE (#391) field
+3 IF $PIECE($GET(VAEL(6)),U,2)="EMPLOYEE"
SET EMP=1
QUIT
+4 ;Check PATIENT ELIGABILITY (#361) field
+5 NEW ELIG
+6 SET ELIG=0
SET EMP=0
+7 FOR
SET ELIG=$ORDER(VAEL(1,ELIG))
if 'ELIG
QUIT
Begin DoDot:1
+8 IF $PIECE($GET(VAEL(1,ELIG)),U,2)="EMPLOYEE"
SET EMP=1
End DoDot:1
if EMP
QUIT
+9 QUIT
+10 ;
+11 ;Sort internal numbers into Alpha order
XSORT NEW SUB,NAM
+1 KILL ^TMP($JOB,"SORT")
+2 SET SUB=""
+3 FOR
SET SUB=$ORDER(^XTMP(PXRMXTMP,PX,FAC,SUB))
if SUB=""
QUIT
Begin DoDot:1
+4 if SUB="TOTAL"
QUIT
+5 SET NAM=$PIECE(^XTMP(PXRMXTMP,PX,FAC,SUB),U)
+6 IF NAM=""
SET NAM=SUB
+7 SET ^TMP($JOB,"SORT",NAM)=SUB
End DoDot:1
+8 QUIT
+9 ;
