BIDUR ;IHS/CMI/MWR - RETRIEVE PATIENTS.; MAY 10, 2010
;;8.5;IMMUNIZATION;;SEP 01,2011
;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
;; RETRIEVE PATIENTS FOR DUE LISTS & LETTERS.
;
;
;----------
R(BIAG,BIPG,BIFDT,BICC,BICM,BIMMR,BIMMD,BILOT,BIMD,BIORD,BIRDT,BIDED,BIT,BIHCF,BIDPRV,BIERR,BIBEN) ;EP
;---> Retrieve patients according to specs.
;---> Parameters:
; 1 - BIAG (req) Age Range in months or years.
; 2 - BIPG (req) Patient Group Data; see PGRPOUP1^BIOUTPT4 for details.
; 3 - BIFDT (req) Forecast date.
; 4 - BICC (req) Current Community array.
; 5 - BICM (req) Case Manager array.
; 6 - BIMMR (req) Immunizations Received array.
; 7 - BIMMD (req) Immunizations Due array.
; 8 - BILOT (req) Lot Number array.
; 9 - BIMD (req) Minimum Interval days since last letter.
; 10 - BIORD (req) Order of listing.
; 11 - BIRDT (opt) Date Range for Received Imms (form BEGDATE:ENDDATE).
; 12 - BIDED (opt) Include Deceased Patients (0=no, 1=yes).
; 13 - BIT (ret) BIT=Total number of patients stored.
; 14 - BIHCF (req) Health Care Facility array.
; 15 - BIDPRV (req) Designated Provider array.
; 16 - BIERR (ret) Error Code.
; 17 - BIBEN (req) Beneficiary Type array: either BIBEN(1) or BIBEN("ALL").
;
; Removed for v8.1: 8 - BIHCF (req) Health Care Facility array.
;
S BIT=0
K ^TMP("BIDUL",$J)
;---> Reset last record edited index so ^BIPDUE global subscript
;---> doesn't grow too large with each run of the report.
S $P(^BIPDUE(0),U,3)=0
;
;---> Check for required Variables.
I '$D(BIAG) S BIERR=613 Q
I '$D(BIPG) S BIERR=620 Q
I '$G(BIFDT) S BIERR=616 Q
I '$D(BICC) S BIERR=614 Q
I '$D(BICM) S BIERR=615 Q
I '$D(BIDPRV) S BIERR=680 Q
I '$D(BIMMR) S BIERR=652 Q
I '$D(BIMMD) S BIERR=638 Q
I '$D(BIHCF) S BIERR=625 Q
I '$D(BILOT) S BIERR=630 Q
I '$D(BIMD) S BIERR=617 Q
I '$G(BIORD) S BIERR=618 Q
I '$D(BIBEN) S BIERR=662 Q
;
;---> Parse out BIPG. vvv83
N I F I=1,2,4,5,7,8 N @("BIPG"_I) S @("BIPG"_I)=$P(BIPG,U,I)
;
;---> If Patient Group is a Search Template, go store it and quit.
I $P(BIPG1,U)=8 D SEARCH(BIPG8,.BIT,.BIERR) Q
;
;
;---> If list is for DUE, or PAST DUE, or Due for a specific vaccine,
;---> or will display forecast in Additional Info, and
;---> if forecasting has been disabled, do ERROR and quit.
I ((BIPG1[1!(BIPG1[2))!($O(BIMMD(0)))!($D(BINFO(13)))),'$$FORECAS^BIUTL2(DUZ(2)) D Q
.S BIERR=314 Q
;
;---> Calculate the date before which Immunizations Past Due
;---> will be included. BIPG1=Past Due Date cutoff, Fileman format.
D:(BIPG1[2&(BIPG2))
.N X,X1,X2 S X1=BIFDT,X2=-(BIPG2*30)
.D C^%DTC S BIPG2=X
;
N BIAGDB,BIAGDE S (BIAGDB,BIAGDE)=""
D AGEDATE^BIAGE(BIAG,BIFDT,.BIAGDB,.BIAGDE)
I (BIAGDB<0)!('BIAGDE)!(BIAGDB>BIAGDE) S BIERR=676 Q
;
;---> Search the BI PATIENT File, ^BIP( for patients who fit the criteria.
N BIDFN S BIDFN=0
F S BIDFN=$O(^BIP(BIDFN)) Q:'BIDFN D
.D CHKSET(BIDFN,BIPG1,BIPG2,BIPG4,BIPG5,.BIT)
Q
;
;
;----------
CHKSET(BIDFN,BIPG1,BIPG2,BIPG4,BIPG5,BIT) ;EP
;---> Check if this patient fits criteria; if so, set DFN
;---> in ^TMP("BIDUL".
;---> Parameters:
; 1 - BIDFN (req) Patient DFN.
; 2 - BIPG1 (req) Patient Group Number.
; 3 - BIPG2 (opt) If BIPG1=2, then BIPG2=Past Due Date cutoff.
; 4 - BIPG4 (opt) If BIPG1=4, then BIPG4=Inactive Date Range.
; 5 - BIPG5 (opt) If BIPG1=5, then BIPG5=Auto-Activated Date Range.
; 6 - BIT (ret) BIT=Total patients stored.
; NOTE: Other arrays not passed due to length of parameter list.
;
S BIPOP=0 S:'$D(BIT) BIT=0
;
;---> If NOT including Deceased, quit if patient is deceased.
I '$G(BIDED) Q:$$DECEASED^BIUTL1(BIDFN)
;
;---> Quit if Femles Only and this patient is male.
Q:((BIPG1[7)&($$SEX^BIUTL1(BIDFN)'="F"))
;
;---> Check if Patient fits withing Age Range.
N X S X=$$DOB^BIUTL1(BIDFN)
Q:(('X)!(X<BIAGDB)!(X>BIAGDE))
;
;---> Quit if patient does not have an Active HRCN at one or more
;---> of the Health Care Facilities selected. Reactivated vvv83
Q:$$HRCN^BIEXPRT2(BIDFN,.BIHCF)
;
;---> Set local variable for ACTIVE (BIINACT=""), INACTIVE (BIINACT>0).
N BIINACT S BIINACT=$$INACT^BIUTL1(BIDFN)
;
;---> Quit if looking ONLY for INACTIVE and this patient is ACTIVE.
I (BIPG1[4)&(BIPG1'[3) Q:'BIINACT
;
;---> Quit if looking ONLY for INACTIVE, and a Date Made Inactive was
;---> specified, and the patient's Date falls outside of the range.
I (BIPG1[4)&(BIPG1'[3),BIPG4 Q:((BIINACT<$P(BIPG4,":"))!(BIINACT>$P(BIPG4,":",2)))
;
;---> Quit if looking ONLY for ACTIVE and this patient is INACTIVE.
I (BIPG1[3)&(BIPG1'[4) Q:BIINACT
;
;---> Quit if looking ONLY for DUE or PAST DUE, which assumes ACTIVE,
;---> and Inactive is not included, and this patient is Inactive.
I ((BIPG1[1)!(BIPG1[2))&(BIPG1'[4) Q:BIINACT
;
;---> Quit if looking for AUTOMATICALLY ACTIVATED and Patient was not,
;---> or not Auto Activated within the selected date range.
I BIPG1[5 N BIAUTO S BIAUTO=0 D Q:'BIAUTO
.Q:('$$ENTERED^BIUTL1(BIDFN,1))
.N X S X=$$ENTERED^BIUTL1(BIDFN)
.Q:((X<$P(BIPG5,":"))!(X>$P(BIPG5,":",2)))
.S BIAUTO=1
;
;---> Quit if looking for Patients who had Refusals and there are none.
I BIPG1[6 N A D CONTRA^BIUTL11(BIDFN,.A,1) Q:'$O(A(0))
;
;---> Quit if Current Community isn't one of those selected.
Q:$$CURCOM^BIEXPRT2(BIDFN,.BICC)
;
;---> Quit if Case Manager isn't one of those selected.
Q:$$CMGR(BIDFN,.BICM)
;
;---> Quit if Beneficiary Type doesn't match.
Q:$$BENT^BIDUR1(BIDFN,.BIBEN)
;
;---> Quit if Designated Provider isn't one of those selected.
Q:$$DPRV(BIDFN,.BIDPRV)
;
;---> Quit if Patient never received any of the Vaccines selected.
Q:$$IMMR(BIDFN,.BIMMR,$G(BIRDT))
;
;---> Quit if Patient never received any of the Lot#s selected.
Q:$$LOT(BIDFN,.BILOT)
;
;---> Quit if Patient does not have a Chart# at any of
;---> the Health Care Facilities selected. vvv83
Q:$$HRCN^BIEXPRT2(BIDFN,.BIHCF)
;
;---> Quit if Minimum Interval (since last letter) not reached.
N BIQUIT S BIQUIT=0
I BIMD D Q:BIQUIT
.Q:BIPG1=5
.N X,X1,X2
.S X1=DT,X2=+$$LASTLET^BIUTL1(BIDFN)
.I X2 D ^%DTC S:X<BIMD BIQUIT=1
;
;---> If list is for DUE, or PAST DUE, or Due for a specific vaccine,
;---> or will display forecast in Additional Info, then update
;---> the patient's forecast.
D:((BIPG1[1!(BIPG1[2))!($O(BIMMD(0)))!($D(BINFO(13))))
.;---> 4th param=1: Don't retrieve Immserve Profile.
.D UPDATE^BIPATUP(BIDFN,BIFDT,,1)
;
;---> Quit if Patient is not due for a matching Vaccine.
Q:$$IMMD(BIDFN,.BIMMD)
;
;---> Quit if list is for DUE and this patient has no Imms
;---> due on this Forecast Date.
I BIPG1[1 Q:'$D(^BIPDUE("B",BIDFN))
;
;---> Quit if list is for PAST DUE and this patient has
;---> no Immunizations past due as of the Forecast Date.
I BIPG1[2 Q:'$D(^BIPDUE("E",BIDFN))
;
;---> Quit if this patient's earlist Immunization PAST DUE date
;---> is AFTER the Past Due Date.
I BIPG1[2 Q:$O(^BIPDUE("E",BIDFN,0))>BIPG2
;
;---> Quit if Patient is not Past Due for a specific matching Vaccine.
I BIPG1[2 Q:$$IMMPD(BIDFN,.BIMMD,BIPG2)
;
;---> OK, this patient is a keeper! Go store this patient
;---> in the Order specified, then update Patient Total.
D STORE^BIDUR1(BIDFN,BIFDT,BIORD,.BIERR)
Q:$G(BIERR)
S BIT=$G(BIT)+1
Q
;
;
;----------
SEARCH(BITIEN,BIT,BIERR) ;EP
;---> Gather patients from Patient Search Template.
;---> Parameters:
; 1 - BITIEN (req) Template IEN.
; 2 - BIT (ret) Total patients stored.
; 3 - BIERR (ret) Error Code.
;
I '$G(BITIEN) S BIERR=653 Q
I '$D(^DIBT(BITIEN,0)) S BIERR=654 Q
I '$O(^DIBT(BITIEN,1,0)) S BIERR=655 Q
;
;********** PATCH 1, APR 4,2006, IHS/CMI/MWR
;---> Seed Age Range Dates (needed, but not relevant to Search Template).
N BIAGDB,BIAGDE S BIAGDB=0,BIAGDE=9999999
;**********
;
N BIDFN S BIDFN=0,BIPG="3,4,"
F S BIDFN=$O(^DIBT(BITIEN,1,BIDFN)) Q:'BIDFN D
.D CHKSET(BIDFN,BIPG,,,,.BIT)
Q
;
;
;----------
CMGR(BIDFN,BICM) ;EP
;---> Case Manager indicator.
;---> Return 1 if not selecting all Case Managers and if this
;---> patient's Case Manager is not one of the ones selected.
;
Q:'$G(BIDFN) 1
Q:$D(BICM("ALL")) 0
N BIMGR S BIMGR=$$CMGR^BIUTL1(BIDFN)
Q:'BIMGR 1
Q:'$D(BICM(BIMGR)) 1
Q 0
;
;
;----------
DPRV(BIDFN,BIDPRV) ;EP
;---> Designated Provider indicator.
;---> Return 1 if not selecting all Designated Providers and if this
;---> patient's Designated Provider is not one of the ones selected.
;
Q:'$G(BIDFN) 1
Q:$D(BIDPRV("ALL")) 0
N BIX S BIX=$$DPRV^BIUTL1(BIDFN)
Q:'BIX 1
Q:'$D(BIDPRV(BIX)) 1
Q 0
;
;
;----------
IMMR(BIDFN,BIMMR,BIRDT) ;EP
;---> Imm Received indicator.
;---> Return 1 if not selecting all Immunizations Received and if
;---> this patient NEVER received any of the Vaccines selected.
;---> BIHIT=0 includes this patient; BIHIT=1 EXcludes this patient.
;
Q:$G(BIDFN)="" 1
;---> If not restricting vaccines or visit dates, then consider this
;---> patient a hit--include in the list.
S:'$G(BIRDT) BIRDT=""
Q:(($D(BIMMR("ALL")))&('BIRDT)) 0
;
;---> For this Patient retrieve Imm Hx elements IEN vaccine and Fman date;
;---> example: ^I|127|3030821^
N BIHX,BI31,BIDE S BI31=$C(31)_$C(31),BIDE(30)="",BIDE(56)=""
D IMMHX^BIRPC(.BIHX,BIDFN,.BIDE,0) S BIHX=$P(BIHX,BI31)
;
N I,BIIEN,BIDATE,BIHIT
;---> BIHIT=0 this will include the Patient in the list.
;---> So, change BIHIT=0 if a visit meets the criteria.
S BIHIT=1
F I=1:1:($L(BIHX,U)-1) D Q:'BIHIT
.S BIIEN=$P($P(BIHX,U,I),"|",2),BIDATE=$P($P(BIHX,U,I),"|",3)
.;---> If no date restriction and there's a matching Imm, it's a hit (0).
.I 'BIRDT,$D(BIMMR(+BIIEN)) S BIHIT=0 Q
.;---> If there's a matching Imm, or if not restricting to specific vaccines,
.;---> check that visit date is within range.
.I $D(BIMMR(+BIIEN))!$D(BIMMR("ALL")) D
..I (BIDATE'<$P(BIRDT,":"))&(BIDATE'>$P(BIRDT,":",2)) S BIHIT=0 Q
;
;---> Quit, returning result.
Q BIHIT
;
;
;----------
LOT(BIHX,BILOT) ;EP
;---> Lot# indicator.
;---> Return 1 if not selecting all Lot Numbers and if this
;---> patient NEVER received any of the Lot Numbers selected.
;
Q:$D(BILOT("ALL")) 0
Q:$G(BIDFN)="" 0
;
N BIHX,BI31,BIDE S BI31=$C(31)_$C(31),BIDE(32)=""
D IMMHX^BIRPC(.BIHX,BIDFN,.BIDE,0) S BIHX=$P(BIHX,BI31)
;
N I,L S L=""
F I=1:1:($L(BIHX,U)-1) S L=$P($P(BIHX,U,I),"|",2) Q:$D(BILOT(+L))
Q:$D(BILOT(+L)) 0
;
;---> No match.
Q 1
;
;
;----------
IMMD(BIDFN,BIMMD) ;EP
;---> Imm Due indicator.
;---> Return 1 if not selecting all Immunizations Due and if this
;---> patient is NOT DUE for any of the Vaccines selected.
;
Q:'$G(BIDFN) 1
Q:$D(BIMMD("ALL")) 0
;
;---> Look for an Imm Due for any of the selected Vaccines.
N N,Z S N=0,Z=1
F S N=$O(^BIPDUE("B",BIDFN,N)) Q:'N Q:'Z D
.S:$D(BIMMD(+$P($G(^BIPDUE(N,0)),U,2))) Z=0
;
;---> Z=1: No match.
Q Z
;
;
;----------
IMMPD(BIDFN,BIMMD,BIPG2) ;EP
;---> Imm PAST Due indicator.
;---> Return 1 if not selecting all Immunizations Past Due and if this
;---> patient is NOT PAST DUE for any of the Vaccines selected.
;
Q:'$G(BIDFN) 1
Q:$D(BIMMD("ALL")) 0
;
;---> Look for an Imm PAST Due for any of the selected Vaccines. ;Q:$O(^BIPDUE("E",BIDFN,0))>BIPG2
N N,Z S N=0,Z=1
F S N=$O(^BIPDUE("E",BIDFN,N)) Q:'N Q:'Z D
.Q:(N>BIPG2)
.N M S M=0
.F S M=$O(^BIPDUE("E",BIDFN,N,M)) Q:'M D
..S:$D(BIMMD(+$P($G(^BIPDUE(M,0)),U,2))) Z=0
;
;---> Z=1: No match.
Q Z
;
;
;----------
DPTAGE(BIT) ;EP
;*** NOT USED! *** JUST FOR REFERENCE.
;
;---> Using an Age Range, search by VA PATIENT File, ^DPT(,
;---> using DOB xref.
;---> Parameters:
; 1 - BIT (ret) BIT=Total patients stored.
;
;---> Set begin and end dates for search through PATIENT File.
N BIDFN,BIBEGDT,BIENDDT,N
D AGEDATE^BIAGE(BIAG,BIFDT,.BIBEGDT,.BIENDDT)
;
;---> Start 1 day prior to Begin Date and $O into the desired DOB's.
S N=BIBEGDT-1
F S N=$O(^DPT("ADOB",N)) Q:(N>BIENDDT!('N)) D
.S BIDFN=0
.F S BIDFN=$O(^DPT("ADOB",N,BIDFN)) Q:'BIDFN D
..D CHKSET(BIDFN,.BIT)
Q
BIDUR ;IHS/CMI/MWR - RETRIEVE PATIENTS.; MAY 10, 2010
+1 ;;8.5;IMMUNIZATION;;SEP 01,2011
+2 ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
+3 ;; RETRIEVE PATIENTS FOR DUE LISTS & LETTERS.
+4 ;
+5 ;
+6 ;----------
R(BIAG,BIPG,BIFDT,BICC,BICM,BIMMR,BIMMD,BILOT,BIMD,BIORD,BIRDT,BIDED,BIT,BIHCF,BIDPRV,BIERR,BIBEN) ;EP
+1 ;---> Retrieve patients according to specs.
+2 ;---> Parameters:
+3 ; 1 - BIAG (req) Age Range in months or years.
+4 ; 2 - BIPG (req) Patient Group Data; see PGRPOUP1^BIOUTPT4 for details.
+5 ; 3 - BIFDT (req) Forecast date.
+6 ; 4 - BICC (req) Current Community array.
+7 ; 5 - BICM (req) Case Manager array.
+8 ; 6 - BIMMR (req) Immunizations Received array.
+9 ; 7 - BIMMD (req) Immunizations Due array.
+10 ; 8 - BILOT (req) Lot Number array.
+11 ; 9 - BIMD (req) Minimum Interval days since last letter.
+12 ; 10 - BIORD (req) Order of listing.
+13 ; 11 - BIRDT (opt) Date Range for Received Imms (form BEGDATE:ENDDATE).
+14 ; 12 - BIDED (opt) Include Deceased Patients (0=no, 1=yes).
+15 ; 13 - BIT (ret) BIT=Total number of patients stored.
+16 ; 14 - BIHCF (req) Health Care Facility array.
+17 ; 15 - BIDPRV (req) Designated Provider array.
+18 ; 16 - BIERR (ret) Error Code.
+19 ; 17 - BIBEN (req) Beneficiary Type array: either BIBEN(1) or BIBEN("ALL").
+20 ;
+21 ; Removed for v8.1: 8 - BIHCF (req) Health Care Facility array.
+22 ;
+23 SET BIT=0
+24 KILL ^TMP("BIDUL",$JOB)
+25 ;---> Reset last record edited index so ^BIPDUE global subscript
+26 ;---> doesn't grow too large with each run of the report.
+27 SET $PIECE(^BIPDUE(0),U,3)=0
+28 ;
+29 ;---> Check for required Variables.
+30 IF '$DATA(BIAG)
SET BIERR=613
QUIT
+31 IF '$DATA(BIPG)
SET BIERR=620
QUIT
+32 IF '$GET(BIFDT)
SET BIERR=616
QUIT
+33 IF '$DATA(BICC)
SET BIERR=614
QUIT
+34 IF '$DATA(BICM)
SET BIERR=615
QUIT
+35 IF '$DATA(BIDPRV)
SET BIERR=680
QUIT
+36 IF '$DATA(BIMMR)
SET BIERR=652
QUIT
+37 IF '$DATA(BIMMD)
SET BIERR=638
QUIT
+38 IF '$DATA(BIHCF)
SET BIERR=625
QUIT
+39 IF '$DATA(BILOT)
SET BIERR=630
QUIT
+40 IF '$DATA(BIMD)
SET BIERR=617
QUIT
+41 IF '$GET(BIORD)
SET BIERR=618
QUIT
+42 IF '$DATA(BIBEN)
SET BIERR=662
QUIT
+43 ;
+44 ;---> Parse out BIPG. vvv83
+45 NEW I
FOR I=1,2,4,5,7,8
NEW @("BIPG"_I)
SET @("BIPG"_I)=$PIECE(BIPG,U,I)
+46 ;
+47 ;---> If Patient Group is a Search Template, go store it and quit.
+48 IF $PIECE(BIPG1,U)=8
DO SEARCH(BIPG8,.BIT,.BIERR)
QUIT
+49 ;
+50 ;
+51 ;---> If list is for DUE, or PAST DUE, or Due for a specific vaccine,
+52 ;---> or will display forecast in Additional Info, and
+53 ;---> if forecasting has been disabled, do ERROR and quit.
+54 IF ((BIPG1[1!(BIPG1[2))!($ORDER(BIMMD(0)))!($DATA(BINFO(13))))
IF '$$FORECAS^BIUTL2(DUZ(2))
Begin DoDot:1
+55 SET BIERR=314
QUIT
End DoDot:1
QUIT
+56 ;
+57 ;---> Calculate the date before which Immunizations Past Due
+58 ;---> will be included. BIPG1=Past Due Date cutoff, Fileman format.
+59 IF (BIPG1[2&(BIPG2))
Begin DoDot:1
+60 NEW X,X1,X2
SET X1=BIFDT
SET X2=-(BIPG2*30)
+61 DO C^%DTC
SET BIPG2=X
End DoDot:1
+62 ;
+63 NEW BIAGDB,BIAGDE
SET (BIAGDB,BIAGDE)=""
+64 DO AGEDATE^BIAGE(BIAG,BIFDT,.BIAGDB,.BIAGDE)
+65 IF (BIAGDB<0)!('BIAGDE)!(BIAGDB>BIAGDE)
SET BIERR=676
QUIT
+66 ;
+67 ;---> Search the BI PATIENT File, ^BIP( for patients who fit the criteria.
+68 NEW BIDFN
SET BIDFN=0
+69 FOR
SET BIDFN=$ORDER(^BIP(BIDFN))
IF 'BIDFN
QUIT
Begin DoDot:1
+70 DO CHKSET(BIDFN,BIPG1,BIPG2,BIPG4,BIPG5,.BIT)
End DoDot:1
+71 QUIT
+72 ;
+73 ;
+74 ;----------
CHKSET(BIDFN,BIPG1,BIPG2,BIPG4,BIPG5,BIT) ;EP
+1 ;---> Check if this patient fits criteria; if so, set DFN
+2 ;---> in ^TMP("BIDUL".
+3 ;---> Parameters:
+4 ; 1 - BIDFN (req) Patient DFN.
+5 ; 2 - BIPG1 (req) Patient Group Number.
+6 ; 3 - BIPG2 (opt) If BIPG1=2, then BIPG2=Past Due Date cutoff.
+7 ; 4 - BIPG4 (opt) If BIPG1=4, then BIPG4=Inactive Date Range.
+8 ; 5 - BIPG5 (opt) If BIPG1=5, then BIPG5=Auto-Activated Date Range.
+9 ; 6 - BIT (ret) BIT=Total patients stored.
+10 ; NOTE: Other arrays not passed due to length of parameter list.
+11 ;
+12 SET BIPOP=0
IF '$DATA(BIT)
SET BIT=0
+13 ;
+14 ;---> If NOT including Deceased, quit if patient is deceased.
+15 IF '$GET(BIDED)
IF $$DECEASED^BIUTL1(BIDFN)
QUIT
+16 ;
+17 ;---> Quit if Femles Only and this patient is male.
+18 IF ((BIPG1[7)&($$SEX^BIUTL1(BIDFN)'="F"))
QUIT
+19 ;
+20 ;---> Check if Patient fits withing Age Range.
+21 NEW X
SET X=$$DOB^BIUTL1(BIDFN)
+22 IF (('X)!(X<BIAGDB)!(X>BIAGDE))
QUIT
+23 ;
+24 ;---> Quit if patient does not have an Active HRCN at one or more
+25 ;---> of the Health Care Facilities selected. Reactivated vvv83
+26 IF $$HRCN^BIEXPRT2(BIDFN,.BIHCF)
QUIT
+27 ;
+28 ;---> Set local variable for ACTIVE (BIINACT=""), INACTIVE (BIINACT>0).
+29 NEW BIINACT
SET BIINACT=$$INACT^BIUTL1(BIDFN)
+30 ;
+31 ;---> Quit if looking ONLY for INACTIVE and this patient is ACTIVE.
+32 IF (BIPG1[4)&(BIPG1'[3)
IF 'BIINACT
QUIT
+33 ;
+34 ;---> Quit if looking ONLY for INACTIVE, and a Date Made Inactive was
+35 ;---> specified, and the patient's Date falls outside of the range.
+36 IF (BIPG1[4)&(BIPG1'[3)
IF BIPG4
IF ((BIINACT<$PIECE(BIPG4,"
QUIT
+37 ;
+38 ;---> Quit if looking ONLY for ACTIVE and this patient is INACTIVE.
+39 IF (BIPG1[3)&(BIPG1'[4)
IF BIINACT
QUIT
+40 ;
+41 ;---> Quit if looking ONLY for DUE or PAST DUE, which assumes ACTIVE,
+42 ;---> and Inactive is not included, and this patient is Inactive.
+43 IF ((BIPG1[1)!(BIPG1[2))&(BIPG1'[4)
IF BIINACT
QUIT
+44 ;
+45 ;---> Quit if looking for AUTOMATICALLY ACTIVATED and Patient was not,
+46 ;---> or not Auto Activated within the selected date range.
+47 IF BIPG1[5
NEW BIAUTO
SET BIAUTO=0
Begin DoDot:1
+48 IF ('$$ENTERED^BIUTL1(BIDFN,1))
QUIT
+49 NEW X
SET X=$$ENTERED^BIUTL1(BIDFN)
+50 IF ((X<$PIECE(BIPG5,"
QUIT
+51 SET BIAUTO=1
End DoDot:1
IF 'BIAUTO
QUIT
+52 ;
+53 ;---> Quit if looking for Patients who had Refusals and there are none.
+54 IF BIPG1[6
NEW A
DO CONTRA^BIUTL11(BIDFN,.A,1)
IF '$ORDER(A(0))
QUIT
+55 ;
+56 ;---> Quit if Current Community isn't one of those selected.
+57 IF $$CURCOM^BIEXPRT2(BIDFN,.BICC)
QUIT
+58 ;
+59 ;---> Quit if Case Manager isn't one of those selected.
+60 IF $$CMGR(BIDFN,.BICM)
QUIT
+61 ;
+62 ;---> Quit if Beneficiary Type doesn't match.
+63 IF $$BENT^BIDUR1(BIDFN,.BIBEN)
QUIT
+64 ;
+65 ;---> Quit if Designated Provider isn't one of those selected.
+66 IF $$DPRV(BIDFN,.BIDPRV)
QUIT
+67 ;
+68 ;---> Quit if Patient never received any of the Vaccines selected.
+69 IF $$IMMR(BIDFN,.BIMMR,$GET(BIRDT))
QUIT
+70 ;
+71 ;---> Quit if Patient never received any of the Lot#s selected.
+72 IF $$LOT(BIDFN,.BILOT)
QUIT
+73 ;
+74 ;---> Quit if Patient does not have a Chart# at any of
+75 ;---> the Health Care Facilities selected. vvv83
+76 IF $$HRCN^BIEXPRT2(BIDFN,.BIHCF)
QUIT
+77 ;
+78 ;---> Quit if Minimum Interval (since last letter) not reached.
+79 NEW BIQUIT
SET BIQUIT=0
+80 IF BIMD
Begin DoDot:1
+81 IF BIPG1=5
QUIT
+82 NEW X,X1,X2
+83 SET X1=DT
SET X2=+$$LASTLET^BIUTL1(BIDFN)
+84 IF X2
DO ^%DTC
IF X<BIMD
SET BIQUIT=1
End DoDot:1
IF BIQUIT
QUIT
+85 ;
+86 ;---> If list is for DUE, or PAST DUE, or Due for a specific vaccine,
+87 ;---> or will display forecast in Additional Info, then update
+88 ;---> the patient's forecast.
+89 IF ((BIPG1[1!(BIPG1[2))!($ORDER(BIMMD(0)))!($DATA(BINFO(13))))
Begin DoDot:1
+90 ;---> 4th param=1: Don't retrieve Immserve Profile.
+91 DO UPDATE^BIPATUP(BIDFN,BIFDT,,1)
End DoDot:1
+92 ;
+93 ;---> Quit if Patient is not due for a matching Vaccine.
+94 IF $$IMMD(BIDFN,.BIMMD)
QUIT
+95 ;
+96 ;---> Quit if list is for DUE and this patient has no Imms
+97 ;---> due on this Forecast Date.
+98 IF BIPG1[1
IF '$DATA(^BIPDUE("B",BIDFN))
QUIT
+99 ;
+100 ;---> Quit if list is for PAST DUE and this patient has
+101 ;---> no Immunizations past due as of the Forecast Date.
+102 IF BIPG1[2
IF '$DATA(^BIPDUE("E",BIDFN))
QUIT
+103 ;
+104 ;---> Quit if this patient's earlist Immunization PAST DUE date
+105 ;---> is AFTER the Past Due Date.
+106 IF BIPG1[2
IF $ORDER(^BIPDUE("E",BIDFN,0))>BIPG2
QUIT
+107 ;
+108 ;---> Quit if Patient is not Past Due for a specific matching Vaccine.
+109 IF BIPG1[2
IF $$IMMPD(BIDFN,.BIMMD,BIPG2)
QUIT
+110 ;
+111 ;---> OK, this patient is a keeper! Go store this patient
+112 ;---> in the Order specified, then update Patient Total.
+113 DO STORE^BIDUR1(BIDFN,BIFDT,BIORD,.BIERR)
+114 IF $GET(BIERR)
QUIT
+115 SET BIT=$GET(BIT)+1
+116 QUIT
+117 ;
+118 ;
+119 ;----------
SEARCH(BITIEN,BIT,BIERR) ;EP
+1 ;---> Gather patients from Patient Search Template.
+2 ;---> Parameters:
+3 ; 1 - BITIEN (req) Template IEN.
+4 ; 2 - BIT (ret) Total patients stored.
+5 ; 3 - BIERR (ret) Error Code.
+6 ;
+7 IF '$GET(BITIEN)
SET BIERR=653
QUIT
+8 IF '$DATA(^DIBT(BITIEN,0))
SET BIERR=654
QUIT
+9 IF '$ORDER(^DIBT(BITIEN,1,0))
SET BIERR=655
QUIT
+10 ;
+11 ;********** PATCH 1, APR 4,2006, IHS/CMI/MWR
+12 ;---> Seed Age Range Dates (needed, but not relevant to Search Template).
+13 NEW BIAGDB,BIAGDE
SET BIAGDB=0
SET BIAGDE=9999999
+14 ;**********
+15 ;
+16 NEW BIDFN
SET BIDFN=0
SET BIPG="3,4,"
+17 FOR
SET BIDFN=$ORDER(^DIBT(BITIEN,1,BIDFN))
IF 'BIDFN
QUIT
Begin DoDot:1
+18 DO CHKSET(BIDFN,BIPG,,,,.BIT)
End DoDot:1
+19 QUIT
+20 ;
+21 ;
+22 ;----------
CMGR(BIDFN,BICM) ;EP
+1 ;---> Case Manager indicator.
+2 ;---> Return 1 if not selecting all Case Managers and if this
+3 ;---> patient's Case Manager is not one of the ones selected.
+4 ;
+5 IF '$GET(BIDFN)
QUIT 1
+6 IF $DATA(BICM("ALL"))
QUIT 0
+7 NEW BIMGR
SET BIMGR=$$CMGR^BIUTL1(BIDFN)
+8 IF 'BIMGR
QUIT 1
+9 IF '$DATA(BICM(BIMGR))
QUIT 1
+10 QUIT 0
+11 ;
+12 ;
+13 ;----------
DPRV(BIDFN,BIDPRV) ;EP
+1 ;---> Designated Provider indicator.
+2 ;---> Return 1 if not selecting all Designated Providers and if this
+3 ;---> patient's Designated Provider is not one of the ones selected.
+4 ;
+5 IF '$GET(BIDFN)
QUIT 1
+6 IF $DATA(BIDPRV("ALL"))
QUIT 0
+7 NEW BIX
SET BIX=$$DPRV^BIUTL1(BIDFN)
+8 IF 'BIX
QUIT 1
+9 IF '$DATA(BIDPRV(BIX))
QUIT 1
+10 QUIT 0
+11 ;
+12 ;
+13 ;----------
IMMR(BIDFN,BIMMR,BIRDT) ;EP
+1 ;---> Imm Received indicator.
+2 ;---> Return 1 if not selecting all Immunizations Received and if
+3 ;---> this patient NEVER received any of the Vaccines selected.
+4 ;---> BIHIT=0 includes this patient; BIHIT=1 EXcludes this patient.
+5 ;
+6 IF $GET(BIDFN)=""
QUIT 1
+7 ;---> If not restricting vaccines or visit dates, then consider this
+8 ;---> patient a hit--include in the list.
+9 IF '$GET(BIRDT)
SET BIRDT=""
+10 IF (($DATA(BIMMR("ALL")))&('BIRDT))
QUIT 0
+11 ;
+12 ;---> For this Patient retrieve Imm Hx elements IEN vaccine and Fman date;
+13 ;---> example: ^I|127|3030821^
+14 NEW BIHX,BI31,BIDE
SET BI31=$CHAR(31)_$CHAR(31)
SET BIDE(30)=""
SET BIDE(56)=""
+15 DO IMMHX^BIRPC(.BIHX,BIDFN,.BIDE,0)
SET BIHX=$PIECE(BIHX,BI31)
+16 ;
+17 NEW I,BIIEN,BIDATE,BIHIT
+18 ;---> BIHIT=0 this will include the Patient in the list.
+19 ;---> So, change BIHIT=0 if a visit meets the criteria.
+20 SET BIHIT=1
+21 FOR I=1:1:($LENGTH(BIHX,U)-1)
Begin DoDot:1
+22 SET BIIEN=$PIECE($PIECE(BIHX,U,I),"|",2)
SET BIDATE=$PIECE($PIECE(BIHX,U,I),"|",3)
+23 ;---> If no date restriction and there's a matching Imm, it's a hit (0).
+24 IF 'BIRDT
IF $DATA(BIMMR(+BIIEN))
SET BIHIT=0
QUIT
+25 ;---> If there's a matching Imm, or if not restricting to specific vaccines,
+26 ;---> check that visit date is within range.
+27 IF $DATA(BIMMR(+BIIEN))!$DATA(BIMMR("ALL"))
Begin DoDot:2
+28 IF (BIDATE'<$PIECE(BIRDT,":"))&(BIDATE'>$PIECE(BIRDT,":",2))
SET BIHIT=0
QUIT
End DoDot:2
End DoDot:1
IF 'BIHIT
QUIT
+29 ;
+30 ;---> Quit, returning result.
+31 QUIT BIHIT
+32 ;
+33 ;
+34 ;----------
LOT(BIHX,BILOT) ;EP
+1 ;---> Lot# indicator.
+2 ;---> Return 1 if not selecting all Lot Numbers and if this
+3 ;---> patient NEVER received any of the Lot Numbers selected.
+4 ;
+5 IF $DATA(BILOT("ALL"))
QUIT 0
+6 IF $GET(BIDFN)=""
QUIT 0
+7 ;
+8 NEW BIHX,BI31,BIDE
SET BI31=$CHAR(31)_$CHAR(31)
SET BIDE(32)=""
+9 DO IMMHX^BIRPC(.BIHX,BIDFN,.BIDE,0)
SET BIHX=$PIECE(BIHX,BI31)
+10 ;
+11 NEW I,L
SET L=""
+12 FOR I=1:1:($LENGTH(BIHX,U)-1)
SET L=$PIECE($PIECE(BIHX,U,I),"|",2)
IF $DATA(BILOT(+L))
QUIT
+13 IF $DATA(BILOT(+L))
QUIT 0
+14 ;
+15 ;---> No match.
+16 QUIT 1
+17 ;
+18 ;
+19 ;----------
IMMD(BIDFN,BIMMD) ;EP
+1 ;---> Imm Due indicator.
+2 ;---> Return 1 if not selecting all Immunizations Due and if this
+3 ;---> patient is NOT DUE for any of the Vaccines selected.
+4 ;
+5 IF '$GET(BIDFN)
QUIT 1
+6 IF $DATA(BIMMD("ALL"))
QUIT 0
+7 ;
+8 ;---> Look for an Imm Due for any of the selected Vaccines.
+9 NEW N,Z
SET N=0
SET Z=1
+10 FOR
SET N=$ORDER(^BIPDUE("B",BIDFN,N))
IF 'N
QUIT
IF 'Z
QUIT
Begin DoDot:1
+11 IF $DATA(BIMMD(+$PIECE($GET(^BIPDUE(N,0)),U,2)))
SET Z=0
End DoDot:1
+12 ;
+13 ;---> Z=1: No match.
+14 QUIT Z
+15 ;
+16 ;
+17 ;----------
IMMPD(BIDFN,BIMMD,BIPG2) ;EP
+1 ;---> Imm PAST Due indicator.
+2 ;---> Return 1 if not selecting all Immunizations Past Due and if this
+3 ;---> patient is NOT PAST DUE for any of the Vaccines selected.
+4 ;
+5 IF '$GET(BIDFN)
QUIT 1
+6 IF $DATA(BIMMD("ALL"))
QUIT 0
+7 ;
+8 ;---> Look for an Imm PAST Due for any of the selected Vaccines. ;Q:$O(^BIPDUE("E",BIDFN,0))>BIPG2
+9 NEW N,Z
SET N=0
SET Z=1
+10 FOR
SET N=$ORDER(^BIPDUE("E",BIDFN,N))
IF 'N
QUIT
IF 'Z
QUIT
Begin DoDot:1
+11 IF (N>BIPG2)
QUIT
+12 NEW M
SET M=0
+13 FOR
SET M=$ORDER(^BIPDUE("E",BIDFN,N,M))
IF 'M
QUIT
Begin DoDot:2
+14 IF $DATA(BIMMD(+$PIECE($GET(^BIPDUE(M,0)),U,2)))
SET Z=0
End DoDot:2
End DoDot:1
+15 ;
+16 ;---> Z=1: No match.
+17 QUIT Z
+18 ;
+19 ;
+20 ;----------
DPTAGE(BIT) ;EP
+1 ;*** NOT USED! *** JUST FOR REFERENCE.
+2 ;
+3 ;---> Using an Age Range, search by VA PATIENT File, ^DPT(,
+4 ;---> using DOB xref.
+5 ;---> Parameters:
+6 ; 1 - BIT (ret) BIT=Total patients stored.
+7 ;
+8 ;---> Set begin and end dates for search through PATIENT File.
+9 NEW BIDFN,BIBEGDT,BIENDDT,N
+10 DO AGEDATE^BIAGE(BIAG,BIFDT,.BIBEGDT,.BIENDDT)
+11 ;
+12 ;---> Start 1 day prior to Begin Date and $O into the desired DOB's.
+13 SET N=BIBEGDT-1
+14 FOR
SET N=$ORDER(^DPT("ADOB",N))
IF (N>BIENDDT!('N))
QUIT
Begin DoDot:1
+15 SET BIDFN=0
+16 FOR
SET BIDFN=$ORDER(^DPT("ADOB",N,BIDFN))
IF 'BIDFN
QUIT
Begin DoDot:2
+17 DO CHKSET(BIDFN,.BIT)
End DoDot:2
End DoDot:1
+18 QUIT
