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

PXRMXDT1.m

Go to the documentation of this file. 
  1. PXRMXDT1 ;SLC/PJH - Build Patient list SUBROUTINES ;05/13/2011
  1.  ;;2.0;CLINICAL REMINDERS;**4,6,12,17,18**;Feb 04, 2005;Build 152
  1.  ;
  1.  ; Called by label from PXRMXSEO,PXRMXSE
  1.  ;
  1.  ;Combined report duplicate check (Summary report)
  1. NEW(SUB,SUB1,SUB2) ;
  1.  ;Existing entry
  1.  I $D(^TMP("PXRMCMB",$J,SUB,SUB1,SUB2)) Q 0
  1.  ;New entry
  1.  S ^TMP("PXRMCMB",$J,SUB,SUB1,SUB2)=""
  1.  Q 1
  1.  ;
  1.  ;Individual patient report duplicate patient check
  1. NEWIP(DFN) ;
  1.  ;Existing entry
  1.  I $D(^TMP("PXRMCMB3",$J,DFN)) Q 0
  1.  ;New entry
  1.  S ^TMP("PXRMCMB3",$J,DFN)=""
  1.  Q 1
  1.  ;Combined report duplicate check (Detail report)
  1. NEWP(SUB,DFN) ;
  1.  ;Existing entry
  1.  I $D(^TMP("PXRMCMB1",$J,SUB,DFN)) Q 0
  1.  ;New entry
  1.  S ^TMP("PXRMCMB1",$J,SUB,DFN)=""
  1.  Q 1
  1.  ;
  1.  ;Combined report duplicate check (Patient totals)
  1. NEWT(FACILITY,DFN) ;
  1.  ;Existing entry
  1.  I $D(^TMP("PXRMCMB2",$J,FACILITY,DFN)) Q 0
  1.  ;New entry
  1.  S ^TMP("PXRMCMB2",$J,FACILITY,DFN)=""
  1.  Q 1
  1.  ;
  1. NEWCS(FACILITY,NAM,DFN,REM) ;
  1.  I $D(^TMP("PXRMCMB4",$J,FACILITY,NAM,DFN,REM)) Q 0
  1.  S ^TMP("PXRMCMB4",$J,FACILITY,NAM,DFN,REM)=""
  1.  Q 1
  1.  ;
  1.  ;Detailed report
  1. SDET(DFN,STATUS,NAM,FACILITY,INP) ;
  1.  I $G(^XTMP(PXRMXTMP,PX,FACILITY,NAM))="" D
  1.  .S ^XTMP(PXRMXTMP,PX,FACILITY,NAM)=NAM
  1.  ;Applicable
  1.  S DDAT="N/A"
  1.  N APPL,FAPPTDT,DEFARR,DLAST,DNEXT,DNEXT1,FIEV,PNAM,PXRMDATE,BID,TMPSUB
  1.  S APPL=0,FAPPTDT=0
  1.  ;Add any that aren't N/A, Ignore on N/A or NEVER to applicable total
  1.  I ($P(STATUS,U)'="")&(STATUS'["NEVER")&(STATUS'["N/A")&(STATUS'["ERROR")&(STATUS'["CNBD") S APPL=1
  1.  ;If DUE NOW save details
  1.  I $G(STATUS)'["DUE NOW" S PNAM=" "
  1.  I $G(STATUS)["DUE NOW" D
  1.  .N BED
  1.  .S DDUE=$P($G(STATUS),U,2)
  1.  .S DLAST=$P($G(STATUS),U,3)
  1.  .;Demographics
  1.  .S PNAM=$P($G(^DPT(DFN,0)),U),BID=$P($G(^DPT(DFN,0)),U,9)
  1.  .I PNAM="" S PNAM=" "
  1.  .E  S PNAM=PNAM_U_BID
  1.  .;Next appointment for location or clinic
  1.  .;For detailed provider report get next appoint. for assoc. clinic
  1.  .S DNEXT=""
  1.  .I PXRMSEL="L"!(PXRMSEL="P") S TMPSUB="PXRM FUTURE APPT"
  1.  .E  S TMPSUB="SDAMA301"
  1.  .I PXRMFCMB="Y",PXRMLCMB="Y",$D(^TMP($J,TMPSUB,DFN))>0 D
  1.  ..N APPTCNT,LOC
  1.  ..S LOC=0,APPTCNT=0
  1.  ..F  S LOC=$O(^TMP($J,TMPSUB,DFN,LOC)) Q:(LOC'>0)!(APPTCNT=1)  D
  1.  ...S DNEXT=$O(^TMP($J,TMPSUB,DFN,LOC,"")) I +DNEXT>0 S APPTCNT=1 Q
  1.  .S DNEXT=$O(^TMP($J,TMPSUB,DFN,$G(INP),""))
  1.  .I PXRMFCMB="N",PXRMLCMB="Y" D
  1.  ..S DNEXT1=$O(^TMP($J,"PXRM FACILITY FUTURE APPT",DFN,FACILITY,"")) Q:DNEXT1'>0
  1.  ..I +DNEXT=0!(DNEXT>DNEXT1) S DNEXT=DNEXT1
  1.  .S BED=$G(^DPT(DFN,.101)) S:BED="" BED="NONE"
  1.  .;Sort by next appointment date
  1.  .I PXRMSRT="Y" S DDAT=$P(DNEXT,".") S:DDAT="" DDAT="NONE"
  1.  .;Patient ward/bed used only for inpatient reports
  1.  .I PXRMFUT="Y" S DNEXT=""
  1.  .N TXT
  1.  .S TXT=DFN_U_DDUE_U_DLAST_U_$G(DNEXT)_$S($G(BED)'="":U_BED,1:"")
  1.  .I $G(BED)'="",BED'="NONE" S DDAT=BED
  1.  .N BED
  1.  .S BED=""
  1.  .I $G(PXRMINP) D
  1.  ..S BED=$G(^DPT(DFN,.101)) S:BED="" BED="NONE"
  1.  ..S TXT=TXT_U_BED
  1.  ..;Sort by bed
  1.  ..I PXRMSRT="B" S DDAT=BED
  1.  .;Duplicate check for combined report
  1.  .I PXRMFCMB="Y",'$$NEW(NAM,DDAT,PNAM) Q
  1.  .;Save entry in ^XTMP
  1.  .S ^XTMP(PXRMXTMP,PX,FACILITY,NAM,DDAT,PNAM)=TXT
  1.  .;Total of reminders overdue
  1.  .N CNT
  1.  .S CNT=$P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,2)
  1.  .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,2)=CNT+1
  1.  ;Total of patients checked/applicable
  1.  N CNT,NEW
  1.  S NEW=1 I PXRMFCMB="Y" S NEW=$$NEWP(NAM,DFN)
  1.  I NEW=1 D
  1.  .S CNT=$P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,3)
  1.  .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,3)=CNT+1
  1.  .S CNT=$P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,4)
  1.  .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,4)=CNT+APPL
  1.  I PXRMFUT="Y"&($G(STATUS)["DUE NOW") D
  1.  .N APPTARY,APPTDT,CIEN,CNT,NODE,SUB
  1.  .S SUB="" I $D(^TMP($J,"PXRM FUTURE APPT",DFN))>0 S SUB="PXRM FUTURE APPT"
  1.  .I SUB="",$D(^TMP($J,"SDAMA301",DFN))>0 S SUB="SDAMA301"
  1.  .I SUB="" Q
  1.  .S CNT=0
  1.  .S CIEN=0 F  S CIEN=$O(^TMP($J,SUB,DFN,CIEN)) Q:CIEN'>0  D
  1.  ..S APPTDT=0
  1.  ..F  S APPTDT=$O(^TMP($J,SUB,DFN,CIEN,APPTDT)) Q:APPTDT'>0  D
  1.  ...S NODE=$G(^TMP($J,SUB,DFN,CIEN,APPTDT))
  1.  ...S APPTARY(APPTDT)=APPTDT_U_$P($P(NODE,U,2),";",2)_U_$P($P(NODE,U,22),";",2)
  1.  .S APPTDT=0 F  S APPTDT=$O(APPTARY(APPTDT)) Q:APPTDT'>0  S CNT=CNT+1,^XTMP(PXRMXTMP,PX,FACILITY,NAM,DDAT,PNAM,CNT,0)=APPTARY(APPTDT)
  1.  Q
  1.  ;
  1. SUM(DFN,STATUS,FACILITY,NAM,LOC) ;
  1.  N ADDCNT,DUE,EVAL
  1.  S (DUE,EVAL)=0
  1.  ;Add dues to totals of reminders due and reminders applicable
  1.  I STATUS["DUE NOW" D
  1.  .S DUE=1,EVAL=1
  1.  ;Add any that aren't N/A, Ignore on N/A,ERROR or NEVER to applicable total
  1.  S STATUS=$P(STATUS,U)
  1.  I (STATUS'=" ")&(STATUS'["NEVER")&(STATUS'="N/A")&(STATUS'["ERROR")&(STATUS'["CNBD") S EVAL=1
  1.  ;Update XTMP - Total of reminders due
  1.  I "IR"[PXRMTOT D
  1.  .S ADDCNT=0
  1.  .;Combined facility duplicate check
  1.  .I PXRMCCS'="B" S ADDCNT=1
  1.  .I ADDCNT=0,PXRMCCS="B",$$NEWCS(FACILITY,NAM,DFN,ITEM)=1 S ADDCNT=1
  1.  .I PXRMFCMB="Y",'$$NEW(NAM,DFN,ITEM) S ADDCNT=0
  1.  .I ADDCNT=1 D
  1.  ..N CNT
  1.  ..S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,NAM,ITEM)),U,1)
  1.  ..S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM,ITEM),U,1)=CNT+EVAL
  1.  ..;Total of reminders evaluated
  1.  ..S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,NAM,ITEM)),U,2)
  1.  ..S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM,ITEM),U,2)=CNT+DUE
  1.  .I PXRMCCS="B" D
  1.  ..N CNT
  1.  ..S CNT=$P($G(^XTMP(PXRMXCCS,PX,FACILITY,NAM,LOC,ITEM)),U,1)
  1.  ..S $P(^XTMP(PXRMXCCS,PX,FACILITY,NAM,LOC,ITEM),U,1)=CNT+EVAL
  1.  ..;Total of reminders evaluated
  1.  ..S CNT=$P($G(^XTMP(PXRMXCCS,PX,FACILITY,NAM,LOC,ITEM)),U,2)
  1.  ..S $P(^XTMP(PXRMXCCS,PX,FACILITY,NAM,LOC,ITEM),U,2)=CNT+DUE
  1.  ;
  1.  ;Totals
  1.  I "RT"[PXRMTOT D
  1.  .;Check for duplicate patient at FACILITY level
  1.  .I $D(^TMP("PXRMDUP",$J,FACILITY,DFN,ITEM)) Q
  1.  .;Set duplicate check
  1.  .S ^TMP("PXRMDUP",$J,FACILITY,DFN,ITEM)=""
  1.  .I $G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL"))="" D
  1.  ..S ^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL")="TOTAL"
  1.  .N CNT
  1.  .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL",ITEM)),U,1)
  1.  .S $P(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL",ITEM),U,1)=CNT+EVAL
  1.  .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL",ITEM)),U,2)
  1.  .S $P(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL",ITEM),U,2)=CNT+DUE
  1.  ;
  1.  ;Total of patients
  1.  I "IR"[PXRMTOT D
  1.  .S ADDCNT=1
  1.  .I PXRMSEL="I",$$NEWIP(DFN)<1 S ADDCNT=0
  1.  .I PXRMLCMB="Y",ADDCNT=1,$$NEWP(@SUB,DFN)=0 S ADDCNT=0
  1.  .I ADDCNT=1,$$NEW(FACILITY,@SUB,DFN)=0 S ADDCNT=0
  1.  .I ADDCNT=1 D
  1.  ..N CNT
  1.  ..I $G(^XTMP(PXRMXTMP,PX,FACILITY,@SUB))="" S ^XTMP(PXRMXTMP,PX,FACILITY,@SUB)=NAM
  1.  ..S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,@SUB)),U,3)
  1.  ..S $P(^XTMP(PXRMXTMP,PX,FACILITY,@SUB),U,3)=CNT+1
  1.  .I PXRMCCS="B" D
  1.  ..N CNT
  1.  ..I $G(^XTMP(PXRMXCCS,PX,FACILITY,@SUB,LOC))="" S ^XTMP(PXRMXCCS,PX,FACILITY,@SUB,LOC)=LOC
  1.  ..S CNT=$P($G(^XTMP(PXRMXCCS,PX,FACILITY,@SUB,LOC)),U,3)
  1.  ..S $P(^XTMP(PXRMXCCS,PX,FACILITY,@SUB,LOC),U,3)=CNT+1
  1.  ;
  1.  ;Total reports
  1.  I "TR"[PXRMTOT D
  1.  .I '$$NEWT(FACILITY,DFN) Q
  1.  .I $G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL"))="" D
  1.  ..S ^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL")=NAM
  1.  .N CNT
  1.  .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL")),U,3)
  1.  .S $P(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL"),U,3)=CNT+1
  1.  Q
  1.  ;
  1. ERRMSG(TYPE) ;
  1.  N CNT,CNT1,STR,SUBJECT,NLINES,OUTPUT,TO
  1.  K ^TMP("PXRMXMZ",$J)
  1.  S NLINES=0,CNT=0,CNT1=2
  1.  I TYPE="C" D  Q
  1.  .M ^TMP("PXRMXMZ",$J)=^TMP($J,"PXRM CNBD")
  1.  .S SUBJECT="REMINDER REPORTS CNBD PATIENT LIST ("_$$FMTE^XLFDT($$NOW^XLFDT)_")"
  1.  .S TO(DUZ)=""
  1.  .D SEND^PXRMMSG("PXRMXMZ",SUBJECT,.TO,DUZ)
  1.  ;Build the error message
  1.  I $G(TITLE)'="" S STR(1)="The Reminders Due Report "_$G(TITLE)_" requested by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT($G(PXRMXST))_" was cancelled for the following reason(s):"
  1.  I $G(TITLE)="" S STR(1)="The Reminders Due Report requested by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT($G(PXRMXST))_" was cancelled for the following reason(s):"
  1.  F  S CNT=$O(DBERR(CNT)) Q:CNT'>0  S STR(CNT1)="\\"_DBERR(CNT),CNT1=CNT1+1
  1.  I 'PXRMQUE D
  1.  .D FORMAT^PXRMTEXT(1,80,2,.STR,.NLINES,.OUTPUT)
  1.  .F CNT=1:1:NLINES W !,OUTPUT(CNT)
  1.  I PXRMQUE D
  1.  .S CNT=0
  1.  .F  S CNT=$O(STR(CNT)) Q:CNT=""  S ^TMP("PXRMXMZ",$J,CNT,0)=STR(CNT)
  1.  .S SUBJECT="Cancelled Reminders Due Report ("_$$FMTE^XLFDT($$NOW^XLFDT)_")"
  1.  .S TO(DUZ)=""
  1.  .D SEND^PXRMMSG("PXRMXMZ",SUBJECT,.TO,DUZ)
  1.  .S ZTSTOP=1
  1.  Q