BPXRMSEO ;IHS/MSC/MGH - Reminder Reports lookup for IHS;31-May-2013 10:57;DU
;;2.0;CLINICAL REMINDERS;**1001**;Feb 04, 2005;Build 21
;
; Called by label from PXRMXSE
;
TMP(DFN,NAM,FACILITY,INP) ;Update ^TMP("PXRMX"
I PXRMFCMB="Y" S FACILITY="COMBINED FACILITIES"
I PXRMLCMB="Y" S NAM="COMBINED LOCATIONS"
S ^TMP("PXRMX",$J,FACILITY,NAM,DFN)=INP
Q
;
;Mark location as found
MARK(IC) ;
S ^XTMP(PXRMXTMP,"MARKED AS FOUND",IC)=""
Q
;
;IHS designated provider selected (PXRMPRV)
IHS N SCDT,LIST,SCERR,SCLIST,II,PCP,NAM,PNAM,OK,BUSY,CNT
N DCLN,DBDOWN,DLAST,DDUE,DDAT,DNEXT,ITEM,LIT,PX,TODAY
S DBDOWN=0
I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
;S SCDT("BEGIN")=9999999-PXRMBDT
;S SCDT("END")=9999999-PXRMEDT
S SCDT("BEGIN")=PXRMSDT,SCDT("END")=PXRMSDT
;Include patient if on any day in range
S SCDT("INCL")=0
S II=""
;Get patient list for each PROVIDER
F S II=$O(PXRMPRV(II)) Q:II="" D
.S PCP=$P(PXRMPRV(II),U),NAM=$P(PXRMPRV(II),U,2)
.;Get patients for practs. roles - excluding assoc clinics
.N SCTEAM D PTPR(PCP)
.I $O(^TMP($J,"PCP",0))="" Q
.;Save in ^TMP in alpha order within team number (internal)
.S CNT=0 F S CNT=$O(^TMP($J,"PCP",CNT)) Q:CNT'>0 D
..S DFN=$P(^TMP($J,"PCP",CNT),U)
..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Collecting pts from Designated Provider list",.BUSY)
..;For detailed provider report get assoc clinic
..I PXRMREP="D" S DCLN=$P(^TMP($J,"PCP",CNT),U,7) I +$G(DCLN)>0 D
...S FACILITY=$$HFAC^PXRMXSL1(DCLN)
...S NAM=$P(^SC(DCLN,0),U)
...S ^XTMP(PXRMXTMP,"HLOC",DCLN)=FACILITY_U_NAM
..I $G(DCLN)'="" S PXRMDCLN(DCLN)=""
..D UPD1(DFN,NAM,"FACILITY",+$G(DCLN))
.D MARK(PCP)
K ^TMP($J,"PCP")
I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
I PXRMREP="D",$D(^TMP($J,"PXRM PATIENT EVAL"))>0 D SDAM301^PXRMXSL2(DT,"",PXRMSEL,PXRMFD,PXRMREP)
Q
;
VISIT(PCP) ;
N CNT,DFN,FOUND,SUB,IEN,PIEN,PROV
S CNT=0,FOUND=0
K ^TMP($J,"BPXRMPIEN")
F S CNT=$O(^TMP($J,"PCP",CNT)) Q:'CNT D
.S SUB="" F S SUB=$O(^AUPNVSIT("AA",CNT,SUB)) Q:SUB=""!(SUB>SCDT("END"))!(FOUND=1) D
..;Loop through the visit file using the start and end dates
..;Find visits for this patient in the date range
..;If there is one there, use this visit number to see if this provider
..;saw the patient, If so include it in the list to evaluate
..S IEN="" F S IEN=$O(^AUPNVSIT("AA",CNT,SUB,IEN)) Q:IEN="" D
...S PIEN="" F S PIEN=$O(^AUPNVPRV("AD",IEN,PIEN)) Q:PIEN="" D
....S PROV=$P($G(^AUPNVPRV(PIEN,0)),U,1)
....I PROV=PCP S ^TMP($J,"BPXRMPIEN",CNT)="" S FOUND=1
Q
;
;
UPD1(DFN,NAM,FACILITY,INP) ;
;Remove test patients.
I 'PXRMTPAT,$$TESTPAT^VADPT(DFN)=1 Q
;Remove patients that are deceased.
I 'PXRMDPAT,$P($G(^DPT(DFN,.35)),U,1)>0 Q
S ^TMP($J,"PXRM PATIENT LIST",DFN)=""
S ^TMP($J,"PXRM PATIENT EVAL",DFN)=""
D TMP(DFN,NAM,FACILITY,INP)
Q
;
;Detailed report
SDET I $G(^XTMP(PXRMXTMP,PX,FACILITY,@SUB))="" D
.S ^XTMP(PXRMXTMP,PX,FACILITY,@SUB)=NAM
;Applicable
N APPL,STATUS S APPL=0,STATUS=""
;Check if due and/or applicable (active reminder for live patient)
I $P($G(^PXD(811.9,ITEM,0)),U,6)'=1 D
.D MAIN^PXRM(DFN,ITEM,0)
.;Quit if nothing returned
.S STATUS=$P($G(^TMP("PXRHM",$J,ITEM,LIT)),U) Q:STATUS=""
.;Exclude dead patients from applicable
.I $G(^XTMP("PXRMDFN"_DFN,"DOD"))'="" Q
.;Add any that aren't N/A, Ignore on N/A or NEVER to applicable total
.I (STATUS'=" ")&(STATUS'["NEVER")&(STATUS'["N/A")&(STATUS'="ERROR") S APPL=1
;
;If DUE NOW save details
I STATUS["DUE NOW" D
.S DDUE=$P($G(^TMP("PXRHM",$J,ITEM,LIT)),U,2)
.S DLAST=$P($G(^TMP("PXRHM",$J,ITEM,LIT)),U,3)
.;Next appointment for location or clinic
.I PXRMSEL="L" D
..I $E(PXRMLCSC,2)'="A" D DNEXT($G(^TMP("PXRMX",$J,FACILITY,NAM,DFN)))
..I $E(PXRMLCSC,2)="A" D DNEXT("")
..S PNAM=$G(^XTMP("PXRMDFN"_DFN,"PATIENT"))
..; Allow for cache being rebuilt for another user
..I PNAM="" S PNAM=" "
.;Next appointment date at any location
.I PXRMSEL'="L" D
..;For detailed provider report get next appoint. for assoc. clinic
..I PXRMREP="D",PXRMSEL="P" S DNEXT="" D:DCLN'="" DNEXT(DCLN) Q
..;Otherwise get next appointment for centre
..D DNEXT("")
.;Sort by next appointment date
.I PXRMSRT="Y" S DDAT=$P(DNEXT,".") S:DDAT="" DDAT="NONE"
.;Patient ward/bed used only for inpatient reports
.N BED,TXT S BED=""
.S TXT=DFN_U_DDUE_U_DLAST_U_DNEXT
.I $G(PXRMINP) D
..S BED=$G(^DPT(DFN,.101)) S:BED="" BED="NONE"
..S TXT=TXT_U_BED
..;Sort by bed
..I PXRMSRT="B" S DDAT=BED
.;Duplicate check for combined report
.I PXRMFCMB="Y",'$$NEW(SUB,DDAT,PNAM) Q
.;Save entry in ^XTMP
.S ^XTMP(PXRMXTMP,PX,FACILITY,@SUB,DDAT,PNAM)=TXT
.;Total of reminders overdue
.N CNT
.S CNT=$P(^XTMP(PXRMXTMP,PX,FACILITY,@SUB),U,2)
.S $P(^XTMP(PXRMXTMP,PX,FACILITY,@SUB),U,2)=CNT+1
;Total of patients checked/applicable
N CNT,NEW
S NEW=1 I PXRMFCMB="Y" S NEW=$$NEWP(SUB,DFN)
I NEW D
.S CNT=$P(^XTMP(PXRMXTMP,PX,FACILITY,@SUB),U,3)
.S $P(^XTMP(PXRMXTMP,PX,FACILITY,@SUB),U,3)=CNT+1
.S CNT=$P(^XTMP(PXRMXTMP,PX,FACILITY,@SUB),U,4)
.S $P(^XTMP(PXRMXTMP,PX,FACILITY,@SUB),U,4)=CNT+APPL
K ^TMP("PXRM",$J),^TMP("PXRHM",$J)
Q
;
;Find next appointment date
DNEXT(IEN) ;
N FOUND
S DNEXT=TODAY,FOUND=0
F S DNEXT=$O(^DPT(DFN,"S",DNEXT)) Q:DNEXT="" D Q:FOUND ; DBIA 1301
.;Ignore cancelled appointments
.I $P($G(^DPT(DFN,"S",DNEXT,0)),U,2)["C" Q
.I (IEN>0),(+$P($G(^DPT(DFN,"S",DNEXT,0)),U)'=IEN) Q
.S FOUND=1
Q
PTPR(BSDPRV) ;Find the lisZTt of this provider's primary care pts
N DFN,NAME,COMM
S DFN=0 F S DFN=$O(^AUPNPAT("AK",+BSDPRV,DFN)) Q:'DFN D
. S NAME=$$GET1^DIQ(2,DFN,.01)
. S ^TMP($J,"PCP",DFN)=DFN_"^"_NAME
Q
;Combined report duplicate check (Summary report)
NEW(SUB,SUB1,SUB2) ;
;Existing entry
I $D(^TMP("PXRMCMB",$J,@SUB,SUB1,SUB2)) Q 0
;New entry
S ^TMP("PXRMCMB",$J,@SUB,SUB1,SUB2)=""
Q 1
;
;Combined report duplicate check (Detail report)
NEWP(SUB,DFN) ;
;Existing entry
I $D(^TMP("PXRMCMB1",$J,@SUB,DFN)) Q 0
;New entry
S ^TMP("PXRMCMB1",$J,@SUB,DFN)=""
Q 1
;
;Combined report duplicate check (Patient totals)
NEWT(FACILITY,DFN) ;
;Existing entry
I $D(^TMP("PXRMCMB2",$J,FACILITY,DFN)) Q 0
;New entry
S ^TMP("PXRMCMB2",$J,FACILITY,DFN)=""
Q 1
BPXRMSEO ;IHS/MSC/MGH - Reminder Reports lookup for IHS;31-May-2013 10:57;DU
+1 ;;2.0;CLINICAL REMINDERS;**1001**;Feb 04, 2005;Build 21
+2 ;
+3 ; Called by label from PXRMXSE
+4 ;
TMP(DFN,NAM,FACILITY,INP) ;Update ^TMP("PXRMX"
+1 IF PXRMFCMB="Y"
SET FACILITY="COMBINED FACILITIES"
+2 IF PXRMLCMB="Y"
SET NAM="COMBINED LOCATIONS"
+3 SET ^TMP("PXRMX",$JOB,FACILITY,NAM,DFN)=INP
+4 QUIT
+5 ;
+6 ;Mark location as found
MARK(IC) ;
+1 SET ^XTMP(PXRMXTMP,"MARKED AS FOUND",IC)=""
+2 QUIT
+3 ;
+4 ;IHS designated provider selected (PXRMPRV)
IHS NEW SCDT,LIST,SCERR,SCLIST,II,PCP,NAM,PNAM,OK,BUSY,CNT
+1 NEW DCLN,DBDOWN,DLAST,DDUE,DDAT,DNEXT,ITEM,LIT,PX,TODAY
+2 SET DBDOWN=0
+3 IF '(PXRMQUE!$DATA(IO("S")))
DO INIT^PXRMXBSY(.BUSY)
+4 ;S SCDT("BEGIN")=9999999-PXRMBDT
+5 ;S SCDT("END")=9999999-PXRMEDT
+6 SET SCDT("BEGIN")=PXRMSDT
SET SCDT("END")=PXRMSDT
+7 ;Include patient if on any day in range
+8 SET SCDT("INCL")=0
+9 SET II=""
+10 ;Get patient list for each PROVIDER
+11 FOR
SET II=$ORDER(PXRMPRV(II))
IF II=""
QUIT
Begin DoDot:1
+12 SET PCP=$PIECE(PXRMPRV(II),U)
SET NAM=$PIECE(PXRMPRV(II),U,2)
+13 ;Get patients for practs. roles - excluding assoc clinics
+14 NEW SCTEAM
DO PTPR(PCP)
+15 IF $ORDER(^TMP($JOB,"PCP",0))=""
QUIT
+16 ;Save in ^TMP in alpha order within team number (internal)
+17 SET CNT=0
FOR
SET CNT=$ORDER(^TMP($JOB,"PCP",CNT))
IF CNT'>0
QUIT
Begin DoDot:2
+18 SET DFN=$PIECE(^TMP($JOB,"PCP",CNT),U)
+19 IF ('(PXRMQUE!$DATA(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0)
DO SPIN^PXRMXBSY("Collecting pts from Designated Provider list",.BUSY)
+20 ;For detailed provider report get assoc clinic
+21 IF PXRMREP="D"
SET DCLN=$PIECE(^TMP($JOB,"PCP",CNT),U,7)
IF +$GET(DCLN)>0
Begin DoDot:3
+22 SET FACILITY=$$HFAC^PXRMXSL1(DCLN)
+23 SET NAM=$PIECE(^SC(DCLN,0),U)
+24 SET ^XTMP(PXRMXTMP,"HLOC",DCLN)=FACILITY_U_NAM
End DoDot:3
+25 IF $GET(DCLN)'=""
SET PXRMDCLN(DCLN)=""
+26 DO UPD1(DFN,NAM,"FACILITY",+$GET(DCLN))
End DoDot:2
+27 DO MARK(PCP)
End DoDot:1
+28 KILL ^TMP($JOB,"PCP")
+29 IF '(PXRMQUE!$DATA(IO("S"))!(PXRMTABS="Y"))
DO DONE^PXRMXBSY("Done")
+30 IF PXRMREP="D"
IF $DATA(^TMP($JOB,"PXRM PATIENT EVAL"))>0
DO SDAM301^PXRMXSL2(DT,"",PXRMSEL,PXRMFD,PXRMREP)
+31 QUIT
+32 ;
VISIT(PCP) ;
+1 NEW CNT,DFN,FOUND,SUB,IEN,PIEN,PROV
+2 SET CNT=0
SET FOUND=0
+3 KILL ^TMP($JOB,"BPXRMPIEN")
+4 FOR
SET CNT=$ORDER(^TMP($JOB,"PCP",CNT))
IF 'CNT
QUIT
Begin DoDot:1
+5 SET SUB=""
FOR
SET SUB=$ORDER(^AUPNVSIT("AA",CNT,SUB))
IF SUB=""!(SUB>SCDT("END"))!(FOUND=1)
QUIT
Begin DoDot:2
+6 ;Loop through the visit file using the start and end dates
+7 ;Find visits for this patient in the date range
+8 ;If there is one there, use this visit number to see if this provider
+9 ;saw the patient, If so include it in the list to evaluate
+10 SET IEN=""
FOR
SET IEN=$ORDER(^AUPNVSIT("AA",CNT,SUB,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+11 SET PIEN=""
FOR
SET PIEN=$ORDER(^AUPNVPRV("AD",IEN,PIEN))
IF PIEN=""
QUIT
Begin DoDot:4
+12 SET PROV=$PIECE($GET(^AUPNVPRV(PIEN,0)),U,1)
+13 IF PROV=PCP
SET ^TMP($JOB,"BPXRMPIEN",CNT)=""
SET FOUND=1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
+16 ;
UPD1(DFN,NAM,FACILITY,INP) ;
+1 ;Remove test patients.
+2 IF 'PXRMTPAT
IF $$TESTPAT^VADPT(DFN)=1
QUIT
+3 ;Remove patients that are deceased.
+4 IF 'PXRMDPAT
IF $PIECE($GET(^DPT(DFN,.35)),U,1)>0
QUIT
+5 SET ^TMP($JOB,"PXRM PATIENT LIST",DFN)=""
+6 SET ^TMP($JOB,"PXRM PATIENT EVAL",DFN)=""
+7 DO TMP(DFN,NAM,FACILITY,INP)
+8 QUIT
+9 ;
+10 ;Detailed report
SDET IF $GET(^XTMP(PXRMXTMP,PX,FACILITY,@SUB))=""
Begin DoDot:1
+1 SET ^XTMP(PXRMXTMP,PX,FACILITY,@SUB)=NAM
End DoDot:1
+2 ;Applicable
+3 NEW APPL,STATUS
SET APPL=0
SET STATUS=""
+4 ;Check if due and/or applicable (active reminder for live patient)
+5 IF $PIECE($GET(^PXD(811.9,ITEM,0)),U,6)'=1
Begin DoDot:1
+6 DO MAIN^PXRM(DFN,ITEM,0)
+7 ;Quit if nothing returned
+8 SET STATUS=$PIECE($GET(^TMP("PXRHM",$JOB,ITEM,LIT)),U)
IF STATUS=""
QUIT
+9 ;Exclude dead patients from applicable
+10 IF $GET(^XTMP("PXRMDFN"_DFN,"DOD"))'=""
QUIT
+11 ;Add any that aren't N/A, Ignore on N/A or NEVER to applicable total
+12 IF (STATUS'=" ")&(STATUS'["NEVER")&(STATUS'["N/A")&(STATUS'="ERROR")
SET APPL=1
End DoDot:1
+13 ;
+14 ;If DUE NOW save details
+15 IF STATUS["DUE NOW"
Begin DoDot:1
+16 SET DDUE=$PIECE($GET(^TMP("PXRHM",$JOB,ITEM,LIT)),U,2)
+17 SET DLAST=$PIECE($GET(^TMP("PXRHM",$JOB,ITEM,LIT)),U,3)
+18 ;Next appointment for location or clinic
+19 IF PXRMSEL="L"
Begin DoDot:2
+20 IF $EXTRACT(PXRMLCSC,2)'="A"
DO DNEXT($GET(^TMP("PXRMX",$JOB,FACILITY,NAM,DFN)))
+21 IF $EXTRACT(PXRMLCSC,2)="A"
DO DNEXT("")
+22 SET PNAM=$GET(^XTMP("PXRMDFN"_DFN,"PATIENT"))
+23 ; Allow for cache being rebuilt for another user
+24 IF PNAM=""
SET PNAM=" "
End DoDot:2
+25 ;Next appointment date at any location
+26 IF PXRMSEL'="L"
Begin DoDot:2
+27 ;For detailed provider report get next appoint. for assoc. clinic
+28 IF PXRMREP="D"
IF PXRMSEL="P"
SET DNEXT=""
IF DCLN'=""
DO DNEXT(DCLN)
QUIT
+29 ;Otherwise get next appointment for centre
+30 DO DNEXT("")
End DoDot:2
+31 ;Sort by next appointment date
+32 IF PXRMSRT="Y"
SET DDAT=$PIECE(DNEXT,".")
IF DDAT=""
SET DDAT="NONE"
+33 ;Patient ward/bed used only for inpatient reports
+34 NEW BED,TXT
SET BED=""
+35 SET TXT=DFN_U_DDUE_U_DLAST_U_DNEXT
+36 IF $GET(PXRMINP)
Begin DoDot:2
+37 SET BED=$GET(^DPT(DFN,.101))
IF BED=""
SET BED="NONE"
+38 SET TXT=TXT_U_BED
+39 ;Sort by bed
+40 IF PXRMSRT="B"
SET DDAT=BED
End DoDot:2
+41 ;Duplicate check for combined report
+42 IF PXRMFCMB="Y"
IF '$$NEW(SUB,DDAT,PNAM)
QUIT
+43 ;Save entry in ^XTMP
+44 SET ^XTMP(PXRMXTMP,PX,FACILITY,@SUB,DDAT,PNAM)=TXT
+45 ;Total of reminders overdue
+46 NEW CNT
+47 SET CNT=$PIECE(^XTMP(PXRMXTMP,PX,FACILITY,@SUB),U,2)
+48 SET $PIECE(^XTMP(PXRMXTMP,PX,FACILITY,@SUB),U,2)=CNT+1
End DoDot:1
+49 ;Total of patients checked/applicable
+50 NEW CNT,NEW
+51 SET NEW=1
IF PXRMFCMB="Y"
SET NEW=$$NEWP(SUB,DFN)
+52 IF NEW
Begin DoDot:1
+53 SET CNT=$PIECE(^XTMP(PXRMXTMP,PX,FACILITY,@SUB),U,3)
+54 SET $PIECE(^XTMP(PXRMXTMP,PX,FACILITY,@SUB),U,3)=CNT+1
+55 SET CNT=$PIECE(^XTMP(PXRMXTMP,PX,FACILITY,@SUB),U,4)
+56 SET $PIECE(^XTMP(PXRMXTMP,PX,FACILITY,@SUB),U,4)=CNT+APPL
End DoDot:1
+57 KILL ^TMP("PXRM",$JOB),^TMP("PXRHM",$JOB)
+58 QUIT
+59 ;
+60 ;Find next appointment date
DNEXT(IEN) ;
+1 NEW FOUND
+2 SET DNEXT=TODAY
SET FOUND=0
+3 ; DBIA 1301
FOR
SET DNEXT=$ORDER(^DPT(DFN,"S",DNEXT))
IF DNEXT=""
QUIT
Begin DoDot:1
+4 ;Ignore cancelled appointments
+5 IF $PIECE($GET(^DPT(DFN,"S",DNEXT,0)),U,2)["C"
QUIT
+6 IF (IEN>0)
IF (+$PIECE($GET(^DPT(DFN,"S",DNEXT,0)),U)'=IEN)
QUIT
+7 SET FOUND=1
End DoDot:1
IF FOUND
QUIT
+8 QUIT
PTPR(BSDPRV) ;Find the lisZTt of this provider's primary care pts
+1 NEW DFN,NAME,COMM
+2 SET DFN=0
FOR
SET DFN=$ORDER(^AUPNPAT("AK",+BSDPRV,DFN))
IF 'DFN
QUIT
Begin DoDot:1
+3 SET NAME=$$GET1^DIQ(2,DFN,.01)
+4 SET ^TMP($JOB,"PCP",DFN)=DFN_"^"_NAME
End DoDot:1
+5 QUIT
+6 ;Combined report duplicate check (Summary report)
NEW(SUB,SUB1,SUB2) ;
+1 ;Existing entry
+2 IF $DATA(^TMP("PXRMCMB",$JOB,@SUB,SUB1,SUB2))
QUIT 0
+3 ;New entry
+4 SET ^TMP("PXRMCMB",$JOB,@SUB,SUB1,SUB2)=""
+5 QUIT 1
+6 ;
+7 ;Combined report duplicate check (Detail report)
NEWP(SUB,DFN) ;
+1 ;Existing entry
+2 IF $DATA(^TMP("PXRMCMB1",$JOB,@SUB,DFN))
QUIT 0
+3 ;New entry
+4 SET ^TMP("PXRMCMB1",$JOB,@SUB,DFN)=""
+5 QUIT 1
+6 ;
+7 ;Combined report duplicate check (Patient totals)
NEWT(FACILITY,DFN) ;
+1 ;Existing entry
+2 IF $DATA(^TMP("PXRMCMB2",$JOB,FACILITY,DFN))
QUIT 0
+3 ;New entry
+4 SET ^TMP("PXRMCMB2",$JOB,FACILITY,DFN)=""
+5 QUIT 1
