Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXRMXPR

PXRMXPR.m

Go to the documentation of this file.
  1. PXRMXPR ; SLC/PJH,PKR - Print Reminder Due report. ;05/05/2009
  1. ;;2.0;CLINICAL REMINDERS;**4,6,12**;Feb 04, 2005;Build 73
  1. ;
  1. ; Called/Jobbed after PXRMXSE1
  1. ;
  1. START N BMARG,CRITERIA,C1S,C2S,C3S,C1HS,C2HS,C3HS,DONE,FIRST,HEAD
  1. N INDENT,PAGE,MOD,DES,ADES,CDES,RDES,SDES,MISSED,SEP
  1. N PLSTCRIT,PXRMOPT,PXRMFLD,PXRMHDR,PXRMHDRS,PXRMT,PXRMH,VDUZ
  1. N BD,ED,EMPCHK,SD,RD
  1. N PXRMTX
  1. N IOP,POP,XMDUZ,XMQUIET,XMSUB,XMY,%ZIS
  1. ;Check for output to p-message. TaskMan will automatically copy
  1. ;^TMP("XM-MESS",$J) to the tasked job.
  1. I $D(^TMP("XM-MESS",$J)) D
  1. . S XMQUIET=1
  1. . S XMDUZ=$G(^TMP("XM-MESS",$J,"XMAPHOST","XMINSTR","FROM"))
  1. . I XMDUZ="" S XMDUZ=^TMP("XM-MESS",$J,"XMAPHOST","XMDUZ")
  1. . S XMSUB=^TMP("XM-MESS",$J,"XMAPHOST","XMSUB")
  1. . S VDUZ=""
  1. . F S VDUZ=$O(^TMP("XM-MESS",$J,"XMY",VDUZ)) Q:VDUZ="" S XMY(VDUZ)=""
  1. . 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")
  1. S IOP=PXRMIOP
  1. I $D(PXRMHFIO) S %ZIS("HFSNAME")=PXRMHFIO
  1. D ^%ZIS
  1. I POP G EXIT
  1. U IO
  1. S PXRMTX="due"
  1. I PXRMREP="D" D
  1. .S EMPCHK=$P($G(^PXRM(800,1,"TRUNCATE EMPLOYEE SSN")),U)
  1. .I EMPCHK="" S EMPCHK="Y"
  1. ;
  1. ; Format Date Range
  1. I PXRMSEL="L" D
  1. .S BD=$$FMTE^XLFDT(PXRMBDT,"5D")
  1. .S ED=$$FMTE^XLFDT(PXRMEDT,"5D")
  1. ; Format due effective date
  1. S SD=$$FMTE^XLFDT(PXRMSDT,"5P")
  1. ; Format run date
  1. S RD=$$FMTE^XLFDT(PXRMXST,"5P")
  1. S DONE=0
  1. ;
  1. ;Delimited report.
  1. S SEP=$S(PXRMTABS="Y":PXRMTABC,1:"")
  1. ;
  1. ;Setup initial formatting parameters.
  1. S INDENT=3
  1. S BMARG=2,PAGE=0,HEAD=1
  1. ;
  1. I +$G(XQY)>0 N XQOPT D OP^XQCHK
  1. S PXRMOPT=$P($G(XQOPT),U,2)
  1. I ($L(PXRMOPT)>0)&(PXRMOPT'["Clinical") S PXRMOPT="Clinical "_PXRMOPT
  1. I PXRMREP="D" D
  1. .S RDES=$P(REMINDER(1),U,2)
  1. .S PXRMOPT=PXRMOPT_" - Detailed Report"
  1. .N IC F IC=0,3,4 S PXRMH(IC)="",PXRMT(IC)=0
  1. .S PXRMH(1)="Date Due Last Done Next Appt"
  1. .S PXRMH(2)="-------- --------- ---------"
  1. .I $G(PXRMINP) D
  1. ..S PXRMH(1)="Date Due Last Done Ward/Bed"
  1. ..S PXRMH(2)="-------- --------- --------"
  1. .F IC=1,2 S PXRMT(IC)=40
  1. .S ADES="Next Appointment only"
  1. .I PXRMFUT="Y" S ADES="All Future Appointments"
  1. .S SDES="Sorted by Patient Name"
  1. .I PXRMSRT="Y" S SDES="Sorted by Appointment Date"
  1. I PXRMREP="S" D
  1. .S PXRMOPT=PXRMOPT_" - Summary Report"
  1. .S PXRMH(0)="# Patients with Reminders",PXRMT(0)=$S(PXRMPER=0:50,1:20)
  1. .I PXRMPER=1 D
  1. ..S PXRMH(1)="Applicable Due %Appl %Due %Done"
  1. ..S PXRMH(2)="---------- --- ----- ---- -----"
  1. .I PXRMPER=0 D
  1. ..S PXRMH(1)="Applicable Due"
  1. ..S PXRMH(2)="---------- ---"
  1. .N IC F IC=1,2 S PXRMT(IC)=$S(PXRMPER=0:50,1:20)
  1. .S PXRMH(3)="Denominator"
  1. .S PXRMH(4)="-----------"
  1. .F IC=3,4 S PXRMT(IC)=0
  1. ;
  1. ;Print Criteria Page if normal report
  1. S CRITERIA=0 I PXRMTABS="N" S CRITERIA=1
  1. ;or delimited report with notemplate
  1. I PXRMTABS="Y",PXRMTMP="" S CRITERIA=1
  1. ;
  1. ;Build array of locations/providers with no patients selected in
  1. ;MISSED.
  1. D NOPATS^PXRMXPR1(.MISSED)
  1. ;
  1. ;Print either criteria page or summary header
  1. I CRITERIA D G:DONE EXIT
  1. .D PAGE^PXRMXGPR Q:DONE
  1. .D CRIT^PXRMXGPR(10,.PLSTCRIT) Q:DONE
  1. ;Header if delimited output from a template
  1. I 'CRITERIA D
  1. .N HDR1,HDR2,HDR3
  1. .S HDR1="",HDR2="",HDR3=""
  1. .I PXRMTMP]"" S HDR1="TITLE:"_$P(PXRMTMP,U,2)_U_"TEMPLATE:"_$P(PXRMTMP,U,3)
  1. .I PXRMTMP="" D
  1. ..N PXRMFLD,DES,CDES D LITS^PXRMXPR1 S HDR1=PXRMFLD_U_$G(DES)_U_$G(CDES)
  1. .I PXRMSEL="L" S HDR2="START:"_BD_U_"END:"_ED
  1. .S HDR2=HDR2_U_"RUN:"_RD_"Effective Date:"_SD
  1. .I PXRMFCMB="Y" S HDR3="COMBINED FACILITY"
  1. .I PXRMLCMB="Y" S $P(HDR3,SEP,2)="COMBINED LOCATION"
  1. .I PXRMTCMB="Y" S $P(HDR3,SEP,2)="COMBINED OE/RR TEAMS"
  1. .I PXRMREP="S" D
  1. ..N LIT1,LIT2,LIT3
  1. ..D LIT^PXRMXD
  1. ..I PXRMTOT="I" S $P(HDR3,SEP,3)=$$UP^XLFSTR(LIT1)
  1. ..I PXRMTOT="R" S $P(HDR3,SEP,3)=$$UP^XLFSTR(LIT2)
  1. ..I PXRMTOT="T" S $P(HDR3,SEP,3)=$$UP^XLFSTR(LIT3)
  1. .S PLSTCRIT(1)=HDR1,PLSTCRIT(2)=HDR2,PLSTCRIT(3)=HDR3
  1. .W !,HDR1,!,HDR2,!,HDR3,!
  1. ;
  1. ;Kill items marked as found
  1. K ^XTMP(PXRMXTMP,"MARKED AS FOUND")
  1. ;
  1. ;Setup the final formatting parameters.
  1. S C1HS=INDENT+3
  1. S C1S=0
  1. S C2HS=C1S+2
  1. S C2S=C2HS
  1. S C3HS=C2HS+5
  1. S C3S=C3HS
  1. S HEAD=1
  1. S INDENT=10
  1. ;
  1. ; Update last run date
  1. I $G(PXRMTMP)'="" D UPD^PXRMXTU
  1. ;
  1. ; Get report detail from ^XTMP
  1. N DUECNT,PNAM,SUB,DFN,BID,NAM,FAC,MOD,SRT,TOTAL,APPL,FACPNAME,PX,TTOTAL
  1. S TTOTAL=0
  1. ; Set subroutine label from report format
  1. S MOD="SUMARY" I PXRMREP="D" S MOD="DETAIL"
  1. ;
  1. S FAC=0,PX="PXRM"
  1. F S FAC=$O(^XTMP(PXRMXTMP,PX,FAC)) Q:FAC="" Q:DONE D
  1. .;Get facility name for Location and PCMM team report
  1. .I "TL"[PXRMSEL,PXRMFCMB="N" D
  1. ..S FACPNAME=$P(PXRMFACN(FAC),U,1)_" "_$P(PXRMFACN(FAC),U,2)
  1. .;Report from ^XTMP - label MOD is DETAIL/SUMARY
  1. .S (PNAM,SUB,NAM,SRT)=""
  1. .I PXRMSEL="I" S SUB="INDIVIDUAL PATIENTS" D @MOD Q:DONE
  1. .I PXRMSEL'="I" D
  1. ..;Sort internal IENs into alpha order
  1. ..D XSORT
  1. ..F S SRT=$O(^TMP($J,"SORT",SRT)) Q:SRT="" Q:DONE D
  1. ...S SUB=$G(^TMP($J,"SORT",SRT)) D @MOD
  1. ..I MOD="SUMARY","RT"[PXRMTOT S SUB="TOTAL" D @MOD
  1. ;
  1. ; Null report if no patients selected
  1. I ('DONE),$O(^XTMP(PXRMXTMP,PX,""))="" D NULL^PXRMXGPR G EXIT
  1. ; Report selected patient sample with no patients
  1. I $D(MISSED),PXRMPML=1 D MISSED^PXRMXPR1(0,.MISSED)
  1. ;
  1. ;Print Patient List
  1. I $G(PATLST)="Y" D FOOTER^PXRMXPR1(.PLSTCRIT)
  1. ;
  1. ;Print Error message
  1. I $D(^XTMP(PXRMXTMP,"ERROR"))>0!($D(^XTMP(PXRMXTMP,"CNBD"))>0) D ERROR^PXRMXBSY
  1. EXIT ;
  1. D TIMING^PXRMXGUT
  1. D EXIT^PXRMXGUT
  1. ;
  1. ;Allow the task to be cleaned up upon successful completion.
  1. I $D(ZTQUEUED) S ZTREQ="@"
  1. D EOR^PXRMXGUT
  1. Q
  1. ;
  1. ;Report by Patient
  1. DETAIL N JJ,VA,DATE,COUNT,DDAT,EMP
  1. N BED,DDUE,DDONE,DNEXT,FDAT1,FDAT2,FDAT3,FNAM,FTXT
  1. S NAM=$G(^XTMP(PXRMXTMP,PX,FAC,SUB)),HEAD=1
  1. S COUNT=$P(NAM,U,2),TOTAL=$P(NAM,U,3),APPL=$P(NAM,U,4),NAM=$P(NAM,U,1)
  1. S DDAT="",JJ=0
  1. ; Get list of patients for each appointment date
  1. F S DDAT=$O(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT)) Q:DDAT="" Q:DONE D PAT
  1. ; No patients due
  1. I JJ=0 D:'DONE NONE^PXRMXGPR
  1. ; Total patients
  1. D:'DONE TOTAL^PXRMXGPR
  1. S TTOTAL=TTOTAL+TOTAL
  1. Q
  1. ;
  1. PAT ;Extract and print patient detail
  1. N DNEXT1,NODE,PNUM
  1. F S PNAM=$O(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM)) Q:PNAM="" Q:DONE D
  1. .S JJ=JJ+1
  1. .;Format print line
  1. .S (BID,DNEXT1,FDAT1,FDAT2,FDAT3,DNEXT1)="" I PNAM'["No patients found" D
  1. ..S FDAT2="N/A",FDAT3="None"
  1. ..S NODE=$G(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM))
  1. ..S DDUE=$P(NODE,U,2),DDONE=$P(NODE,U,3),DNEXT=$P(NODE,U,4)
  1. ..S BED=$P(NODE,U,5)
  1. ..S DFN=$P(NODE,U) S BID=$P($G(PNAM),U,2)
  1. ..I PXRMSSN="N" S BID=$E(BID,6,9)
  1. ..I PXRMSSN="Y",EMPCHK="Y" D EMP S:EMP BID=$E(BID,6,9)
  1. ..S BID="("_BID_")"
  1. ..S FDAT1=$$FMTE^XLFDT(DDUE,"5D")
  1. ..I DDONE S FDAT2=$$FMTE^XLFDT(DDONE,"5D")
  1. ..I BED'="NONE" S FDAT3=$P(NODE,U,5),DNEXT1=$$FMTE^XLFDT(DNEXT,"5D")
  1. ..I DNEXT,FDAT3="None" S FDAT3=$$FMTE^XLFDT(DNEXT,"5D")
  1. .;Print
  1. .D CHECK Q:DONE
  1. .;Normal output
  1. .I PXRMTABS="N" D
  1. ..S PNUM=JJ#10000
  1. ..S PNUM=$$RJ^XLFSTR(PNUM,4)
  1. ..W !,PNUM,?5,$E($P($G(PNAM),U),1,33-$L(BID))," ",BID,?40,FDAT1,?52,FDAT2
  1. ..I ('$G(PXRMINP)),PXRMFUT'="Y" W ?64,$S(BED'="NONE":BED_" (Inp.)",1:FDAT3)
  1. ..I $G(PXRMINP) W ?64,BED
  1. ..I DNEXT1'="",PXRMFUT'="Y" W !,?64,DNEXT1
  1. .;Delimited report
  1. .I PXRMTABS="Y" D
  1. ..N FNAM
  1. ..S FNAM=$P($G(PNAM),U)
  1. ..I FNAM'["No patients found" S FNAM=$E(FNAM,1,33-$L(BID))_" "_BID
  1. ..I "CES"[PXRMTABC S FNAM=$TR(FNAM,SEP,"_"),FDAT1=$TR(FDAT1,SEP,"_")
  1. ..I BED="NONE" S BED=" "
  1. ..W !,JJ_SEP_FNAM_SEP_FDAT1_SEP_FDAT2 I $G(PXRMINP) W SEP_BED
  1. ..I ('$G(PXRMINP)),PXRMFUT'="Y" W SEP_FDAT3_SEP_BED
  1. .;---
  1. .; Future Appointments
  1. .I PXRMFUT="Y" D
  1. ..N CNT,ADAT,ALOC,ATYP,FIRST,NONE
  1. ..S CNT=0,NONE=1,FIRST=1
  1. ..I '$D(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM)) Q
  1. ..F S CNT=$O(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT)) Q:CNT'>0 D
  1. ...S ADAT=$P(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U)
  1. ...I PXRMDLOC="Y" D
  1. ....S ALOC=$P(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U,2)
  1. ....S ATYP=$P(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U,3)
  1. ...S ADAT=$$FMTE^XLFDT(ADAT,"2P")
  1. ...I FIRST D S FIRST=0,NONE=0
  1. ....I PXRMTABS="N" W ?64,$S(BED'="NONE":BED_" (Inp.)",1:"")
  1. ...D CHECK
  1. ...I PXRMDLOC="Y" D
  1. ....I PXRMTABS="N" W !,?8,ADAT,?30,$E(ALOC,1,25),?60,$E(ATYP,1,20)
  1. ....I PXRMTABS="Y" W SEP_ADAT_SEP_$E(ALOC,1,25)_SEP_$E(ATYP,1,20)
  1. ...I PXRMDLOC="N" D
  1. ....I PXRMTABS="N" W !,?10,ADAT
  1. ....I PXRMTABS="Y" W SEP_ADAT
  1. ..I NONE,PXRMTABS="N" W ?64,FDAT3
  1. ..I NONE,PXRMTABS="Y" W SEP_FDAT3
  1. ..I PXRMTABS="Y" W $S(BED'="NONE":SEP_BED_" (Inp.)",1:"")
  1. ..K ^UTILITY("VASD",$J)
  1. Q
  1. ;
  1. ;Summary by Reminder
  1. SUMARY ;
  1. N JJ,EVAL,DUE,RNAM,RNUM,ITEM,COUNT,FTXT,PAPPL,PDUE,PDONE,PERCENT
  1. S NAM=$G(^XTMP(PXRMXTMP,PX,FAC,SUB)),HEAD=1
  1. S TOTAL=$P(NAM,U,3),COUNT=$P(NAM,U,2),NAM=$P(NAM,U,1)
  1. S RNUM=$O(REMINDER(""),-1)
  1. ;Get reminders in alpha order
  1. F JJ=1:1:RNUM D Q:DONE
  1. .S ITEM=$P(REMINDER(JJ),U,1),RNAM=$P(REMINDER(JJ),U,4)
  1. .S:RNAM="" RNAM=$P(REMINDER(JJ),U,2)
  1. .; zero lines will be printed
  1. .S DUE=$G(^XTMP(PXRMXTMP,PX,FAC,SUB,ITEM))
  1. .S EVAL=+$P(DUE,U,1),DUE=+$P(DUE,U,2)
  1. .D SUMP(RNAM,NAM,TOTAL,EVAL,DUE)
  1. D:'DONE TOTAL^PXRMXGPR
  1. I $G(SUB)'="TOTAL",PXRMTOT'="T" S TTOTAL=TTOTAL+TOTAL
  1. I $G(SUB)="TOTAL",PXRMTOT="T" S TTOTAL=TTOTAL+TOTAL
  1. I PXRMCCS="B" D
  1. .N LOC,SUBTOT
  1. .S LOC="" F S LOC=$O(^XTMP(PXRMXCCS,PX,FAC,SUB,LOC)) Q:LOC="" D
  1. ..S NAM=$G(^XTMP(PXRMXCCS,PX,FAC,SUB,LOC)),HEAD=1
  1. ..S TOTAL=$P(NAM,U,3),COUNT=$P(NAM,U,2),NAM=$P(NAM,U,1)
  1. ..S NAM="Clinic Stop "_SUB_" location "_NAM
  1. ..S RNUM=$O(REMINDER(""),-1)
  1. ..;Get reminders in alpha order
  1. ..F JJ=1:1:RNUM D Q:DONE
  1. ...S ITEM=$P(REMINDER(JJ),U,1),RNAM=$P(REMINDER(JJ),U,4)
  1. ...S:RNAM="" RNAM=$P(REMINDER(JJ),U,2)
  1. ...; zero lines will be printed
  1. ...S DUE=$G(^XTMP(PXRMXCCS,PX,FAC,SUB,LOC,ITEM))
  1. ...S EVAL=+$P(DUE,U,1),DUE=+$P(DUE,U,2)
  1. ...D SUMP(RNAM,NAM,TOTAL,EVAL,DUE)
  1. ..D:'DONE TOTAL^PXRMXGPR
  1. Q
  1. ;
  1. SUMP(RNAM,NAM,TOTAL,EVAL,DUE) ;
  1. ;Print
  1. D CHECK Q:DONE
  1. ;Normal Report
  1. I PXRMTABS="N" D
  1. .I PXRMPER=1 D
  1. ..S PERCENT=$$DOPER^PXRMXGPR(TOTAL,EVAL,DUE)
  1. ..S PAPPL=$P(PERCENT,U),PDUE=$P(PERCENT,U,2),PDONE=$P(PERCENT,U,3)
  1. ..W !,JJ,?5,RNAM
  1. ..W !,?20,$J(EVAL,10),?29,$J(DUE,8),?45,$J(PAPPL,5),?53,$J(PDUE,4),?60,$J(PDONE,5)
  1. .I PXRMPER=0 D
  1. ..W !,JJ,?5,RNAM,?50,$J(EVAL,10),?62,$J(DUE,10)
  1. ;Condensed Report
  1. I PXRMTABS="Y" D
  1. .I "CES"[PXRMTABC S RNAM=$TR(RNAM,SEP,"_")
  1. .I PXRMPER=1 D
  1. ..S PERCENT=$$DOPER^PXRMXGPR(TOTAL,EVAL,DUE)
  1. ..S PAPPL=$P(PERCENT,U),PDUE=$P(PERCENT,U,2),PDONE=$P(PERCENT,U,3)
  1. ..W !,JJ_SEP_RNAM_SEP_EVAL_SEP_DUE_SEP_$TR(NAM,SEP,"_")_SEP_PAPPL_SEP_PDUE_SEP_PDONE_SEP
  1. .I PXRMPER=0 W !,JJ_SEP_RNAM_SEP_EVAL_SEP_DUE_SEP_$TR(NAM,SEP,"_")_SEP
  1. Q
  1. ;
  1. ;Check line count before writing line
  1. CHECK I ((PXRMTABS="N")&($Y>(IOSL-BMARG-3)))!(HEAD=1) D COL^PXRMXGPR(1)
  1. Q
  1. ;
  1. ;Check if employee
  1. EMP N VAEL
  1. D ELIG^VADPT
  1. ;Check TYPE (#391) field
  1. I $P($G(VAEL(6)),U,2)="EMPLOYEE" S EMP=1 Q
  1. ;Check PATIENT ELIGABILITY (#361) field
  1. N ELIG
  1. S ELIG=0,EMP=0
  1. F S ELIG=$O(VAEL(1,ELIG)) Q:'ELIG D Q:EMP
  1. .I $P($G(VAEL(1,ELIG)),U,2)="EMPLOYEE" S EMP=1
  1. Q
  1. ;
  1. ;Sort internal numbers into Alpha order
  1. XSORT N SUB,NAM
  1. K ^TMP($J,"SORT")
  1. S SUB=""
  1. F S SUB=$O(^XTMP(PXRMXTMP,PX,FAC,SUB)) Q:SUB="" D
  1. .Q:SUB="TOTAL"
  1. .S NAM=$P(^XTMP(PXRMXTMP,PX,FAC,SUB),U)
  1. .I NAM="" S NAM=SUB
  1. .S ^TMP($J,"SORT",NAM)=SUB
  1. Q
  1. ;