source: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXSE1.m@ 636

PXRMXSE1 ; SLC/PJH - Build Patient lists for Reminder Due report; 01/25/2006
 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
 ;
 ; Called/jobbed from PXRMXD
 ;
 ; Input - PXRMSEL,PXRMXTMP
 ;         PXRM*
 ; Output- ^XTMP(PXRMXTMP
 ;
 ;
START ;  
 N LIT,TOTAL,TODAY,ZTSTOP,BUSY
 S DBDOWN=0
 S TOTAL=0,ZTSTOP="",TODAY=$$DT^XLFDT-.0001
 ;
 K ^TMP($J,"PXRM PATIENT LIST"),^TMP($J,"PXRM PATIENT EVAL")
 K ^TMP($J,"PXRM FUTURE APPT"),^TMP($J,"SDAMA301")
 K ^TMP($J),^TMP(PXRMRT,$J),^TMP("PXRMDUP",$J)
 K ^TMP("PXRMCMB",$J),^TMP("PXRMCMB1",$J),^TMP("PXRMCMB2",$J)
 N PXRMRERR
 ;
 I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
 ;
 ;OE/RR team selected (PXRMOTM)
 I PXRMSEL="O" D OERR^PXRMXSL1
 ; 
 ;PCMM team selected (PXRMPCM)
 I PXRMSEL="T" D PCMMT^PXRMXSL1
 ;
 N HLIEN,FACILITY
 ;Location selected (PXRMLCHL,PXRMCGRP)
 I PXRMSEL="L" D  G:ZTSTOP=1 EXIT
 .;Build Clinic List
 .D BHLOC^PXRMXSL1
 .;Prior Visits - build patient list in ^TMP
 .I PXRMFD="P" D VISITS^PXRMXSL2 I DBDOWN=1 Q
 .;Inpatient Admissions and current inpatient locations
 .I PXRMFD="A"!(PXRMFD="C") D INPADM^PXRMXSL1
 .;Future Appointments - build patient list in ^TMP
 .I PXRMFD="F" D APPTS^PXRMXSL2 I DBDOWN=1 Q
 .;End task requested
 .Q:ZTSTOP=1
 ;Update ^XTMP from ^TMP
 I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
 ;
 ;PCMM provider selected (PXRMPRV)
 I PXRMSEL="P" D PCMMP^PXRMXSL1
 ;
 ;Individual Patients selected (PXRMPAT)
 I PXRMSEL="I" D IND^PXRMXSL1
 ;
 ;Patient List selected (PXRMLIST)
 I PXRMSEL="R" D LIST^PXRMXSL1
 ;
 I DBDOWN=1 G EXIT
 S START=$H
 D EVAL^PXRMXEVL("PXRM PATIENT EVAL",.REMINDER)
 D XTMP(START)
 ;
 ;Update patient list
 I PXRMSEL'="I"&(PXRMUSER'="Y")&($G(PXRMLIS1)'="") D
 .;If no patients due delete patient list
 .I +$O(^TMP($J,"PXRMXPAT",""))=0 D  Q
 ..N DA,DIK S DA=PXRMLIS1,DIK="^PXRMXP(810.5," D ^DIK
 .;Otherwise create patient list
 .D UPDLST^PXRMRULE("PXRMXPAT",PXRMLIS1,"","")
 .S $P(^PXRMXP(810.5,PXRMLIS1,0),U,9)=1
 K ^TMP($J,"PXRMXPAT")
 K ^TMP($J),^TMP(PXRMRT,$J),^TMP("PXRMDUP",$J)
 K ^TMP("PXRMCMB",$J),^TMP("PXRMCMB1",$J),^TMP("PXRMCMB2",$J),^TMP("PXRMCMB3",$J)
 K DBDOWN
 ;
DONE ;
 ;Sorting is done.
 I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W ! D DONE^PXRMXBSY("done")
 ;
 ;I PXRMDBUG="Y" D DEBUG("End of evaluation:",PXRMREP,"^XTMP(PXRMXTMP,PX)")
 ;Print the report information.
 I PXRMQUE D  Q
 .;Start the printing that was queued but not scheduled.
 .N DESC,ROUTINE,TASK
 .S ROUTINE="^PXRMXPR"
 .S DESC="Reminder Due Report - print"
 .S TASK=$G(^XTMP(PXRMXTMP,"PRZTSK"))
 .I TASK="" D NOPRZTSK(PXRMXTMP) Q
 .D REQUE^PXRMXQUE(DESC,ROUTINE,TASK)
 .S ZTREQ="@"
 I 'PXRMQUE D ^PXRMXPR
 Q
 ;
AWRITE(REF,LS)     ;This line tag is a copy of AWRITE^PXRMUTIL
 N CNT,DONE,IC,IND,LEN,PROOT,ROOT,START,TEMP
 I REF="" Q
 S PROOT=$P(REF,")",1)
 S TEMP=$NA(@REF)
 S ROOT=$P(TEMP,")",1)
 S REF=$Q(@REF)
 I REF'[ROOT Q
 S DONE=0,CNT=LS
 F IC=0:0 Q:(REF="")!(DONE)  D
 . S START=$F(REF,ROOT)
 . S LEN=$L(REF)
 . S IND=$E(REF,START,LEN)
 . S CNT=CNT+1,^TMP("PXRMXMZ",$J,CNT,0)=PROOT_IND_"="_@REF
 . S REF=$Q(@REF)
 . I REF'[ROOT S DONE=1
 Q
 ;
DEBUG(LOC,TYPE,REF) ;
 N CNT,DDAT,FACILITY,HEADER,PNAM,PX,SUB
 K ^TMP("PXRMXMZ",$J)
 S PX="PXRM"
 I TYPE'="P"&(TYPE'="DEBUG") D  Q
 .D AWRITE(REF,0)
 .D SEND^PXRMMSG("Debug output: "_LOC_" Reminder Report type "_TYPE_" ("_$$NOW^XLFDT_")",DUZ)
 D AWRITE(REF,0)
 S HEADER=LOC_" ("_$$NOW^XLFDT_")"
 D SEND^PXRMMSG("Debug output: "_HEADER,DUZ)
 Q
 ;
ERROR(STATUS,ITEM) ;
 ;Create XTMP entry for Reminders that error out or could not be
 ;determing on evaluation
 N ERRNAME
 S STATUS=$P(STATUS,U)
 S ERRNAME=$P(^PXD(811.9,ITEM,0),U)
 I $D(^XTMP(PXRMXTMP,STATUS,ERRNAME))>0,^XTMP(PXRMXTMP,STATUS,ERRNAME)>0 D
 .S ^XTMP(PXRMXTMP,STATUS,ERRNAME)=^XTMP(PXRMXTMP,STATUS,ERRNAME)+1
 E  S ^XTMP(PXRMXTMP,STATUS,ERRNAME)=1
 Q
 ;
 ;End Task requested
EXIT ;
 S ZTSK=$G(^XTMP(PXRMXTMP,"PRZTSK"))
 I ZTSK>0 D KILL^%ZTLOAD
 D EXIT^PXRMXGUT
 K DBDOWN
 Q
 ;
NOPRZTSK(PXRMXTMP)       ;Could not get PRZTSK send an error message
 N TEXT
 K ^TMP("PXRMXMZ",$J)
 S TEXT(1,0)="The task number for the print job cannot be determined."
 S TEXT(2,0)="The reason is:"
 I '$D(^XTMP(PXRMXTMP)) S TEXT(3,0)=" The ^XTMP(PXRMXTMP) global is not defined."
 I $D(^XTMP(PXRMXTMP)),'$D(^XTMP(PXRMXTMP,"PRZTSK")) S TEXT(3,0)=" ^XTMP(PXRMXTMP,""PRZTSK"") does not exist."
 I $D(^XTMP(PXRMXTMP,"PRZTSK")) S TEXT(3,0)=" ^XMTP(PXRMXTMP,""PRZTSK"") is null."
 S TEXT(4,0)="PXRMXTMP="_PXRMXTMP
 M ^TMP("PXRMXMZ",$J)=TEXT
 D SEND^PXRMMSG("REMINDER REPORT ERROR",DUZ)
 Q
 ;
XTMP(START) ;
 N CNT,CCNT,DDAT,INP,ITEM,LIT,LSSN,MCNBD,MCNBDR,NAME,SUB,STATUS,TEMP,TEMP1
 K ^TMP($J,"PXRM CNBD")
 S CCNT=0,MCNBD=$G(^PXRM(800,1,"MIERR")),MCNBDR=0
 ;I PXRMDBUG="Y" D DEBUG("PATIENT DATA","P","^TMP($J,""PXRM PATIENT EVAL"")")
 S BUSY=0,SUB="NAM",TEMP=0,PX="PXRM"
 N DDAT,DDUE,DEMARR,DFN,DLAST,DNEXT,FACILITY,NAM,PNAM
 S FACILITY="",DDAT="N/A"
 F  S FACILITY=$O(^TMP(PXRMRT,$J,FACILITY)) Q:FACILITY=""  D
 .S NAM=""
 .F  S NAM=$O(^TMP(PXRMRT,$J,FACILITY,NAM)) Q:NAM=""  D
 ..S DFN="" F  S DFN=$O(^TMP(PXRMRT,$J,FACILITY,NAM,DFN)) Q:DFN=""  D
 ...I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D SPIN^PXRMXBSY("Evaluating Reminders",.BUSY)
 ...S INP=$G(^TMP(PXRMRT,$J,FACILITY,NAM,DFN))
 ...S CNT=0 F  S CNT=$O(REMINDER(CNT)) Q:CNT'>0  D
 ....S ITEM=$P(REMINDER(CNT),U,1),LIT=$P(REMINDER(CNT),U,4)
 ....I LIT="" S LIT=$P(REMINDER(CNT),U,2)
 ....S STATUS=$G(^TMP($J,"PXRM PATIENT EVAL",DFN,ITEM))
 ....I STATUS="" Q
 ....I STATUS["ERROR"!(STATUS["CNBD") D
 .....D ERROR(STATUS,ITEM) I STATUS["ERROR"!(MCNBDR=1) Q
 .....I CCNT=0 D  Q
 ......S ^TMP($J,"PXRM CNBD",1,0)=$$RJ^XLFSTR(" ",5)_$$LJ^XLFSTR("PATIENT NAME",30)_$$RJ^XLFSTR("LAST 4",10)
 ......S (TEMP,TEMP1)=""
 ......F X=1:1:30 S TEMP=TEMP_"_"
 ......F X=1:1:6 S TEMP1=TEMP1_"_"
 ......S ^TMP($J,"PXRM CNBD",2,0)=$$RJ^XLFSTR(" ",5)_$$LJ^XLFSTR(TEMP,30)_$$RJ^XLFSTR(TEMP1,10)
 ......S CCNT=2
 .....S CCNT=CCNT+1
 .....I CCNT>MCNBD S MCNBDR=1 Q
 .....S NAME=$P(^DPT(DFN,0),U)
 .....S LSSN=$E($P(^DPT(DFN,0),U,9),6,9)
 .....S ^TMP($J,"PXRM CNBD",CCNT,0)=$$RJ^XLFSTR(" ",5)_$$LJ^XLFSTR(NAME,30)_$$RJ^XLFSTR(LSSN,10)
 ....;Add reminder status to patient list TMP Global
 ....I STATUS["DUE NOW" S ^TMP($J,"PXRMXPAT",DFN,"REM",ITEM)=ITEM_U_STATUS
 ....I PXRMREP="D" D SDET^PXRMXDT1(DFN,STATUS,NAM,FACILITY,INP)
 ....I PXRMREP="S" D SUM^PXRMXDT1(DFN,STATUS,FACILITY,NAM)
 I $D(^TMP($J,"PXRM CNBD"))>0 D DBDOWN^PXRMXDT1("C")
 K ^TMP($J,"PXRM CNBD")
 S END=$H
 I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DETIME^PXRMXSL1(START,END,"Evaluating Reminders")
 ;I PXRMDBUG="Y" D DEBUG("DEBUG PATIENT DATA EVALUATION","DEBUG","^TMP($J,""PXRMDEBUG"")")
 K ^TMP($J,"PXRM PATIENT EVAL")
 Q
 ;