- 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 Feb 18, 2025@23:16:37 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 ;