BQIRMIZ ;GDIT/HCSD/ALA-Update IZ Forecaster ; 02 Sep 2015 12:28 PM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
;
;
EN(DFN) ;EP
NEW VALUE,FRN,IMN,BSR,LIDT,TEXT
D IMM(DFN)
I VALUE'="Immunization due" Q
;W !,DFN
S FRN=""
F S FRN=$O(^BIPDUE("B",DFN,FRN)) Q:FRN="" D
. S IMN=$P(^BIPDUE(FRN,0),"^",2)
. S RCDUE=$P(^BIPDUE(FRN,0),"^",4),OVDUE=$P(^(0),"^",5)
. S REMDUE=$S(RCDUE'="":RCDUE,1:OVDUE)
. S BSR=$P(^AUTTIMM(IMN,0),"^",9)
. S NIM=0,LIDT=""
. F S LIDT=$O(^AUPNVIMM("AA",DFN,IMN,LIDT)) Q:LIDT="" S NIM=NIM+1
. S LIDT=$O(^AUPNVIMM("AA",DFN,IMN,LIDT)) I LIDT'="" S REMLAST=9999999-LIDT
. Q S BIEN="" F S BIEN=$O(^BIPDUE("B",DFN,BIEN)) Q:BIEN="" D
.. ; Check for Dose
.. S NAM=$P(^BISERT(BSR,0),"^",3) I $P(^(0),"^",6)=0 Q
.. S QDOSE=$P(^BISERT(BSR,0),"^",4),ADOSE=$P(^BISERT(BSR,0),"^",7)
.. S DOSE=$S(QDOSE>ADOSE:QDOSE,1:ADOSE)
.. I NIM<DOSE D Q
... S NIM=NIM+1,CODE="IM_"_NIM_"-"_NAM
... S RIEN=$O(^BQIPAT(DFN,40,"B",CODE,"")) I RIEN="" D FIL^BQIRMDR
.. ;B
Q
;
IMM(BIDFN) ;EP - Expand immunization reminders
S $P(^BIPDUE(0),U,3)=0
D UPDATE^BIPATUP(BIDFN,DT,.ERROR,1)
;D CHECK^BPXRMIMF(BIDFN,1,DT,.VALUE,.TEXT)
Q
;
NX ;
S BQDFN=0,ERRCNT=0
F S BQDFN=$O(^AUPNPAT(BQDFN)) Q:'BQDFN D
. ; If deceased, don't include
. I $P($G(^DPT(BQDFN,.35)),U,1)'="" Q
. ; If no active HRN, don't include
. I '$$HRN^BQIUL1(BQDFN) Q
. ; If no visit in last 3 years, quit
. I '$$VTHR^BQIUL1(BQDFN) Q
. ; If no visit in last 2 years, quit
. ;I '$$VTWR^BQIUL1(BQDFN) Q
. D EN(BQDFN)
Q
;
PTLS ;EP - Run patient list
;
NEW BIAG,BIPG,BIFDT,BICC,BICM,BIMMR,BIMMD,BILOT,BIMD,BIORD,BIRDT,BIDED,BIT,BIHBIDPRV,BIERR,BIBEN
S BIAG="ALL",BIPG=3,BIFDT=DT,BICC("ALL")="",BIBEN(1)="",BIERR=0,BIHCF("ALL")="",BIHCF($P(^BQI(90508,1,0),"^",1))=""
S BICM("ALL")="",BIMMR("ALL")="",BIMMD("ALL")="",BILOT("ALL")="",BIMD=0,BIDPRV("ALL")=""
S BIORD=1,BIRDT="",BIDED=0,BIT=0
D R^BIDUR(.BIAG,.BIPG,.BIFDT,.BICC,.BICM,.BIMMR,.BIMMD,.BILOT,.BIMD,.BIORD,.BIRDT,.BIDED,.BIT,.BIHCF,.BIDPRV,.BIERR,.BIBEN)
;
S RVDT=""
F S RVDT=$O(^TMP("BIDUL",$J,1,RVDT)) Q:RVDT="" D
. S PTNAM="" F S PTNAM=$O(^TMP("BIDUL",$J,1,RVDT,PTNAM)) Q:PTNAM="" D
.. S BQDFN="" F S BQDFN=$O(^TMP("BIDUL",$J,1,RVDT,PTNAM,BQDFN)) Q:BQDFN="" D IMM(BQDFN)
Q
;
APT ;EP - check appointments
NEW NXDAY,PTN,APTD
S NXDAY=$$FMADD^XLFDT(DT,1)
S PTN=0
F S PTN=$O(^DPT(PTN)) Q:'PTN D
. S APTD=$O(^DPT(PTN,"S",NXDAY)) I APTD="" Q
. I APTD\1'=NXDAY Q
. D FOR(PTN,APTD)
Q
;
FOR(BIDFN,BIFDT) ;EP - Forecaster
NEW BIDUZ2,BIFORCST,BIPDSS
S BIDUZ2=DUZ(2)
D IMMFORC^BIRPC(.BIFORCST,BIDFN,BIFDT,,$G(BIDUZ2),.BIPDSS)
I BIFORCST'["No " S ^XTMP("BQINIGHT",BIDFN)=""
Q
BQIRMIZ ;GDIT/HCSD/ALA-Update IZ Forecaster ; 02 Sep 2015 12:28 PM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 ;
+3 ;
EN(DFN) ;EP
+1 NEW VALUE,FRN,IMN,BSR,LIDT,TEXT
+2 DO IMM(DFN)
+3 IF VALUE'="Immunization due"
QUIT
+4 ;W !,DFN
+5 SET FRN=""
+6 FOR
SET FRN=$ORDER(^BIPDUE("B",DFN,FRN))
IF FRN=""
QUIT
Begin DoDot:1
+7 SET IMN=$PIECE(^BIPDUE(FRN,0),"^",2)
+8 SET RCDUE=$PIECE(^BIPDUE(FRN,0),"^",4)
SET OVDUE=$PIECE(^(0),"^",5)
+9 SET REMDUE=$SELECT(RCDUE'="":RCDUE,1:OVDUE)
+10 SET BSR=$PIECE(^AUTTIMM(IMN,0),"^",9)
+11 SET NIM=0
SET LIDT=""
+12 FOR
SET LIDT=$ORDER(^AUPNVIMM("AA",DFN,IMN,LIDT))
IF LIDT=""
QUIT
SET NIM=NIM+1
+13 SET LIDT=$ORDER(^AUPNVIMM("AA",DFN,IMN,LIDT))
IF LIDT'=""
SET REMLAST=9999999-LIDT
+14 QUIT
SET BIEN=""
FOR
SET BIEN=$ORDER(^BIPDUE("B",DFN,BIEN))
IF BIEN=""
QUIT
Begin DoDot:2
+15 ; Check for Dose
+16 SET NAM=$PIECE(^BISERT(BSR,0),"^",3)
IF $PIECE(^(0),"^",6)=0
QUIT
+17 SET QDOSE=$PIECE(^BISERT(BSR,0),"^",4)
SET ADOSE=$PIECE(^BISERT(BSR,0),"^",7)
+18 SET DOSE=$SELECT(QDOSE>ADOSE:QDOSE,1:ADOSE)
+19 IF NIM<DOSE
Begin DoDot:3
+20 SET NIM=NIM+1
SET CODE="IM_"_NIM_"-"_NAM
+21 SET RIEN=$ORDER(^BQIPAT(DFN,40,"B",CODE,""))
IF RIEN=""
DO FIL^BQIRMDR
End DoDot:3
QUIT
+22 ;B
End DoDot:2
End DoDot:1
+23 QUIT
+24 ;
IMM(BIDFN) ;EP - Expand immunization reminders
+1 SET $PIECE(^BIPDUE(0),U,3)=0
+2 DO UPDATE^BIPATUP(BIDFN,DT,.ERROR,1)
+3 ;D CHECK^BPXRMIMF(BIDFN,1,DT,.VALUE,.TEXT)
+4 QUIT
+5 ;
NX ;
+1 SET BQDFN=0
SET ERRCNT=0
+2 FOR
SET BQDFN=$ORDER(^AUPNPAT(BQDFN))
IF 'BQDFN
QUIT
Begin DoDot:1
+3 ; If deceased, don't include
+4 IF $PIECE($GET(^DPT(BQDFN,.35)),U,1)'=""
QUIT
+5 ; If no active HRN, don't include
+6 IF '$$HRN^BQIUL1(BQDFN)
QUIT
+7 ; If no visit in last 3 years, quit
+8 IF '$$VTHR^BQIUL1(BQDFN)
QUIT
+9 ; If no visit in last 2 years, quit
+10 ;I '$$VTWR^BQIUL1(BQDFN) Q
+11 DO EN(BQDFN)
End DoDot:1
+12 QUIT
+13 ;
PTLS ;EP - Run patient list
+1 ;
+2 NEW BIAG,BIPG,BIFDT,BICC,BICM,BIMMR,BIMMD,BILOT,BIMD,BIORD,BIRDT,BIDED,BIT,BIHBIDPRV,BIERR,BIBEN
+3 SET BIAG="ALL"
SET BIPG=3
SET BIFDT=DT
SET BICC("ALL")=""
SET BIBEN(1)=""
SET BIERR=0
SET BIHCF("ALL")=""
SET BIHCF($PIECE(^BQI(90508,1,0),"^",1))=""
+4 SET BICM("ALL")=""
SET BIMMR("ALL")=""
SET BIMMD("ALL")=""
SET BILOT("ALL")=""
SET BIMD=0
SET BIDPRV("ALL")=""
+5 SET BIORD=1
SET BIRDT=""
SET BIDED=0
SET BIT=0
+6 DO R^BIDUR(.BIAG,.BIPG,.BIFDT,.BICC,.BICM,.BIMMR,.BIMMD,.BILOT,.BIMD,.BIORD,.BIRDT,.BIDED,.BIT,.BIHCF,.BIDPRV,.BIERR,.BIBEN)
+7 ;
+8 SET RVDT=""
+9 FOR
SET RVDT=$ORDER(^TMP("BIDUL",$JOB,1,RVDT))
IF RVDT=""
QUIT
Begin DoDot:1
+10 SET PTNAM=""
FOR
SET PTNAM=$ORDER(^TMP("BIDUL",$JOB,1,RVDT,PTNAM))
IF PTNAM=""
QUIT
Begin DoDot:2
+11 SET BQDFN=""
FOR
SET BQDFN=$ORDER(^TMP("BIDUL",$JOB,1,RVDT,PTNAM,BQDFN))
IF BQDFN=""
QUIT
DO IMM(BQDFN)
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
APT ;EP - check appointments
+1 NEW NXDAY,PTN,APTD
+2 SET NXDAY=$$FMADD^XLFDT(DT,1)
+3 SET PTN=0
+4 FOR
SET PTN=$ORDER(^DPT(PTN))
IF 'PTN
QUIT
Begin DoDot:1
+5 SET APTD=$ORDER(^DPT(PTN,"S",NXDAY))
IF APTD=""
QUIT
+6 IF APTD\1'=NXDAY
QUIT
+7 DO FOR(PTN,APTD)
End DoDot:1
+8 QUIT
+9 ;
FOR(BIDFN,BIFDT) ;EP - Forecaster
+1 NEW BIDUZ2,BIFORCST,BIPDSS
+2 SET BIDUZ2=DUZ(2)
+3 DO IMMFORC^BIRPC(.BIFORCST,BIDFN,BIFDT,,$GET(BIDUZ2),.BIPDSS)
+4 IF BIFORCST'["No "
SET ^XTMP("BQINIGHT",BIDFN)=""
+5 QUIT
