BIREPL3 ;IHS/CMI/MWR - REPORT, ADULT IMM; OCT 15, 2010
;;8.5;IMMUNIZATION;**12**;MAY 01,2016
;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
;; GATHER DATA FOR ADULT IMMUNIZATION REPORT.
;; PATCH 1: Commented out for ref to ICPT for Code Set versioning. LASTFLU+25
;; PATCH 2: Filter for Active Clinical, using new standard $$ACTCLIN^BIUTL6 call.
;; GETSTATS+60
;; PATCH 3: Set HPV upper limit for males to 21 years of age. GETSTATS+119
;; PATCH 12: Include CVX 133 in Pneumo stats. PNEU+15
;; Add new Composite Measures. GETSTATS+32
;
;
;----------
GETSTATS(BIQDT,BICC,BIHCF,BIBEN,BICPTI,BIUP,BITOTS) ;EP
;---> Produce array for ADULT Immunization Report.
;---> Parameters:
; 1 - BIQDT (req) Quarter Ending Date.
; 2 - BICC (req) Current Community array.
; 3 - BIHCF (req) Health Care Facility array.
; 4 - BIBEN (req) Beneficiary Type array.
; 5 - BICPTI (opt) 1=Include CPT Coded Visits, 0=Ignore CPT (default).
; 6 - BIUP (req) User Population/Group (Registered, Imm, User, Active).
; 7 - BITOTS (ret) Totals delimited by "^":
; Pc Variable
; 1 - BI19=Total over 19
; 2 - BIT19 = Number over 19 w/Tetanus past 10 years.
; 3 - BITDAP = Number over 19 w/Tdap past 10 years.
;
; 4 - BIHPVF = Total number of Females age 19-26
; 5 - BIHPVF1 = Number Females 19-26 w/HPV-1
; 6 - BIHPVF2 = Number Females 19-26 w/HPV-2
; 7 - BIHPVF3 = Number Females 19-26 w/HPV-3
; 8 - BIHPVF = Total number of Males age 19-26
; 9 - BIHPVM1 = Number Males 19-21 w/HPV-1
; 10 - BIHPVM2 = Number Males 19-21 w/HPV-2
; 11 - BIHPVM3 = Number Males 19-21 w/HPV-3
;
; 12 - BI60=Total over 60
; 13 - BIZ60 = Number over 60 w/Zoster ever.
; 14 - BI65=Total over 65
; 15 - BIT65 = Number over 65 w/Tetanus past 10 years.
; 16 - BIP65 = Number over 65 w/Pneumo at or after age 65.
; 17 - BIP65E = Number over 65 w/Pneumo EVER.
;
;********** PATCH 12, v8.5, MAY 01,2016, IHS/CMI/MWR
;---> New Composite Measure Variables.
; 18 - BIC19=Total >19 <60
; 19 - BIC191=Tdap ever
; 20 - BIC192=(Td or Tdap) <10 yrs
; 21 - BIC193=(Tdap ever) AND ((Tdap or Td) <10 yrs)
;
; 22 - BIC60=Total >60 <65
; 23 - BIC601=Tdap ever
; 24 - BIC602=(Td or Tdap) <10 yrs
; 25 - BIC603=Zoster
; 26 - BIC604=(Tdap ever) AND ((Tdap or Td) <10 yrs) AND Zoster
;
; 27 - BIC65=Total >65
; 28 - BIC651=Tdap ever
; 29 - BIC652=(Td or Tdap) <10 yrs
; 30 - BIC653=Zoster
; 31 - BIC654=Pneumo >65 yrs
; 32 - BIC655=(Tdap ever) AND ((Tdap or Td) <10 yrs) AND Zoster AND Pneumo
; 33 - BICUTDD=Overall UTD Denominator
; 34 - BICUTDN-Overall UTD Numerator
;
N BIC19,BIC191,BIC192,BIC193,BIC60,BIC601,BIC602,BIC603,BIC604
S (BIC19,BIC191,BIC192,BIC193,BIC60,BIC601,BIC602,BIC603,BIC604)=0
N BIC65,BIC651,BIC652,BIC653,BIC654,BIC655,BICAGE,BICUTDD,BICUTDN
S (BIC65,BIC651,BIC652,BIC653,BIC654,BIC655,BICUTDD,BICUTDN)=0
;**********
;
N BIADOB,BIADOBE,BI19,BIT19,BITDAP
N BIHPVF,BIHPVF1,BIHPVF2,BIHPVF3,BIHPVM,BIHPVM1,BIHPVM2,BIHPVM3
N BI60,BIZ60
N BI65,BIT65,BIP65,BIP65E
;
S (BI19,BIHPVF,BIHPVM,BI60,BI65,BIP65,BI65E)=0
S:('$D(BICPTI)) BICPTI=0
S:('$G(BIQDT)) BIQDT=$G(DT)
;
;---> Loop through Patient global looking for visits and immunizations.
;---> DOB must be at least 19 years before Quarter Ending Date.
S BIADOB=0,BIADOBE=BIQDT-190000
F S BIADOB=$O(^DPT("ADOB",BIADOB)) Q:(BIADOB>BIADOBE) D
.N BIDFN S BIDFN=0
.F S BIDFN=$O(^DPT("ADOB",BIADOB,BIDFN)) Q:'BIDFN D
..;
..;---> Filter for standard Patient Population parameter.
..Q:'$$PPFILTR^BIREP(BIDFN,.BIHCF,BIQDT,BIUP)
..;
..;---> Get Age in Years for Stats.
..N BIAGE S BIAGE=$$AGE^BIUTL1(BIDFN,1,BIQDT)
..;---> Quit if under age 19 on the Quarter Ending Date.
..Q:BIAGE<19
..;
..;---> Quit if Beneficiary Type doesn't match.
..Q:$$BENT^BIDUR1(BIDFN,.BIBEN)
..;
..;---> Quit if Current Community doesn't match.
..Q:$$CURCOM^BIEXPRT2(BIDFN,.BICC)
..;
..;---> Set patient as Not Due, BIVAL=2
..;---> If patient is due (change below), set BIVAL=1.
..S BIVAL=2
..;
..;---> Set Composite Flags.
..N BIFTD10,BIFTDAP,BIFZO,BIFPNE
..S (BIFTD10,BIFTDAP,BIFZO,BIFPNE)=0
..;
..;---> Set Age totals.
..S BI19=BI19+1 S:BIAGE>59 BI60=BI60+1 S:BIAGE>64 BI65=BI65+1
..;**********
..D
...;---> Set BICAGE=19,60,or 65 for Age categories.
...I BIAGE<60 S BICAGE=19,BIC19=BIC19+1 Q
...I (BIAGE>59)&(BIAGE<65) S BICAGE=60,BIC60=BIC60+1 Q
...I BIAGE>64 S BICAGE=65,BIC65=BIC65+1
...;**********
..;
..;
..;---> TETANUS STATS ******************************
..;---> Check Td/Tdap <10 yrs.
..D
...I $$TD(BIDFN,BICPTI,BIQDT) D Q
....S BIT19=$G(BIT19)+1 S:BIAGE>64 BIT65=$G(BIT65)+1
....;**********
....S BIFTD10=1 D
.....I BICAGE=19 S BIC192=BIC192+1 Q
.....I BICAGE=60 S BIC602=BIC602+1 Q
.....I BICAGE=65 S BIC652=BIC652+1
....;**********
...;---> Patient NO Td/Tdap <10 yrs, is/was due for Tetanus.
...S BIVAL=1
..;
..;
..;---> Tdap Stats.
..;---> If Tdap <10 yrs.
..I $$TD(BIDFN,BICPTI,BIQDT,1) S BITDAP=$G(BITDAP)+1
..;**********
..;---> If Tdap EVER.
..I $$TD(BIDFN,BICPTI,BIQDT,2) D
...S BIFTDAP=1
...I BICAGE=19 S BIC191=BIC191+1 Q
...I BICAGE=60 S BIC601=BIC601+1 Q
...I BICAGE=65 S BIC651=BIC651+1
..;**********
..;---> FLU STATS - *** PREVIOUS CODE SAVED IN ^BIZFLU.
..;
..;
..;---> PNEUMO STATS *******************************^
..D
...N BIPNE65 S BIPNE65=$$PNEU(BIDFN,BIAGE,BICPTI,BIQDT)
...;---> Patient received Pneumo EVER.
...I $P(BIPNE65,U,2) S BIP65E=$G(BIP65E)+1
...;**********
...;---> If patient received Pneumo at or after age 65 *OR* < 5yrs, set flag.
...I ($P(BIPNE65,U))!($P(BIPNE65,U,3)) I BICAGE=65 S BIC654=BIC654+1,BIFPNE=1
...;**********
...;---> If patient received Pneumo at or after age 65, quit: no longer due.
...I $P(BIPNE65,U) S BIP65=$G(BIP65)+1 Q
...;---> If >64 yrs and didn't receive pneumo, patient is due.
...I BIAGE>64 S BIVAL=1
..;
..;
..;---> ZOSTER STATS *********************************
..D
...I $$OZSTER(BIDFN,BICPTI,BIQDT) D Q
....S:BIAGE>59 BIZ60=$G(BIZ60)+1
....;
....;**********
....S BIFZO=1
....I BICAGE=60 S BIC603=BIC603+1 Q
....I BICAGE=65 S BIC653=BIC653+1
...;
...;---> Patient is/was due for Zostervax if 60+ years on QDT.
...;********** v8.5, MAY 15,2011, IHS/CMI/MWR
...;---> Do NOT include patient in Not Current group for zoster.
...;S:BIAGE>59 BIVAL=1
..;
..;
..;---> GPRA COMPOSITE MEASURES ************************
..;
..;---> CompOsite for 19-59yrs:
..;---> if Tdap EVER *AND* Td/Tdap <10yrs, set flag.
..I BICAGE=19,BIFTD10,BIFTDAP S BIC193=BIC193+1
..;
..;---> Composite for 60-64yrs:
..;---> if Tdap EVER *AND* Td/Tdap <10yrs *AND* Zoster, set flag.
..I BICAGE=60,BIFTD10,BIFTDAP,BIFZO S BIC604=BIC604+1
..;
..;---> Compisite for >64yrs:
..;---> if Tdap EVER *AND* Td/Tdap <10yrs *AND* Zoster *and* Pneumo, set flag.
..I BICAGE=65,BIFTD10,BIFTDAP,BIFZO,BIFPNE S BIC655=BIC655+1
..;
..;
..;
..;---> HPV STATS **************************************
..;********** PATCH 3, v8.5, SEP 10,2012, IHS/CMI/MWR
..;---> Change HPV limit to 21 yrs for males.
..;---> HPV Stats (ages 19-26 for females, 19-21 for males).
..N BISECS S BISEX=$$SEX^BIUTL1(BIDFN)
..;I (BIAGE>18)&(BIAGE<27) D
..I (BIAGE>18)&(BIAGE<$S(BISEX="F":27,1:22)) D
...;N BIHPVD,BISEX S BISEX=$$SEX^BIUTL1(BIDFN)
...;S BIHPVD=$$HPV(BIDFN,BICPTI,BIQDT)
...;**********
...;
...N BIHPVD S BIHPVD=$$HPV(BIDFN,BICPTI,BIQDT)
...I BISEX="F" D Q
....S BIHPVF=$G(BIHPVF)+1
....S:BIHPVD>0 BIHPVF1=$G(BIHPVF1)+1
....S:BIHPVD>1 BIHPVF2=$G(BIHPVF2)+1
....S:BIHPVD>2 BIHPVF3=$G(BIHPVF3)+1
...I BISEX="M" D Q
....S BIHPVM=$G(BIHPVM)+1
....S:BIHPVD>0 BIHPVM1=$G(BIHPVM1)+1
....S:BIHPVD>1 BIHPVM2=$G(BIHPVM2)+1
....S:BIHPVD>2 BIHPVM3=$G(BIHPVM3)+1
..;
..;---> Will Set ^TMP("BIDUL",$J,CURCOM,1,HRCN,BIDFN)=$G(BIVAL)
..D STORE^BIDUR1(BIDFN,DT,9,,$G(BIVAL))
..;
..;---> Add refusals, if any.
..N Z D CONTRA^BIUTL11(BIDFN,.Z,1) I $O(Z(0)) S BITMP("REFUSALS",BIDFN)=""
;
;---> Now piece together the totals.
S BITOTS=$G(BI19)_U_$G(BIT19)_U_$G(BITDAP)
S BITOTS=BITOTS_U_$G(BIHPVF)_U_$G(BIHPVF1)_U_$G(BIHPVF2)_U_$G(BIHPVF3)
S BITOTS=BITOTS_U_$G(BIHPVM)_U_$G(BIHPVM1)_U_$G(BIHPVM2)_U_$G(BIHPVM3)
S BITOTS=BITOTS_U_$G(BI60)_U_$G(BIZ60)_U_$G(BI65)_U_$G(BIT65)_U_$G(BIP65)_U_$G(BIP65E)
;
;********** PATCH 12, v8.5, MAY 01,2016, IHS/CMI/MWR
;---> Calculate Overall UTD
S BICUTDD=BIC19+BIC60+BIC65
S BICUTDN=BIC193+BIC604+BIC655
;---> Add new Composite Measure Variables.
S BITOTS=BITOTS_U_$G(BIC19)_U_$G(BIC191)_U_$G(BIC192)_U_$G(BIC193)
S BITOTS=BITOTS_U_$G(BIC60)_U_$G(BIC601)_U_$G(BIC602)_U_$G(BIC603)_U_$G(BIC604)
S BITOTS=BITOTS_U_$G(BIC65)_U_$G(BIC651)_U_$G(BIC652)_U_$G(BIC653)_U_$G(BIC654)
S BITOTS=BITOTS_U_$G(BIC655)_U_$G(BICUTDD)_U_$G(BICUTDN)
Q
;
;
;----------
TD(BIDFN,BICPTI,BIQDT,BITDAP) ;EP
;---> Return 1 if patient received TD during 10 years prior to QDT.
;---> Parameters:
; 1 - BIDFN (req) Patient DFN
; 2 - BICPTI (opt) 1=Include CPT Coded Visits, 0=Ignore CPT.
; 3 - BIQDT (opt) Quarter Ending Date (ignore Visits after this date).
; 4 - BITDAP (opt) 1=Tdap ONLY during 10 years prior to QDT.
; 2=Tdap ONLY and EVER (no prior date restriction).
;
;---> Check V Imms for TD's.
N BICVXS,BIDATE
S BIDATE=0 S:('$G(BIQDT)) BIQDT=$G(DT)
S BITDAP=+$G(BITDAP)
S BICVXS="1,9,20,22,28,50,106,107,110,113,115"
S:BITDAP BICVXS=115
S BIDATE=$$LASTIMM^BIUTL11(BIDFN,BICVXS,BIQDT)
;
;---> So, BIDATE is the latest TD in V Imm (but not after the QDT).
;
;---> Check (if requested) V CPTs for TD's.
D:$G(BICPTI)
.N BICPTS,Y
.S BICPTS="90701,90718,90700,90720,90702,90703,90721,90723"
.S:BITDAP BICPTS=90715
.S Y=$$LASTCPT^BIUTL11(BIDFN,BICPTS,BIQDT)
.S:Y>$G(BIDATE) BIDATE=Y
;
;********** PATCH 12, v8.5, MAY 01,2016, IHS/CMI/MWR
;---> If BITDAP=2, return 1 if Tdap EVER.
I BITDAP=2 Q $S(BIDATE:1,1:0)
;**********
;
;---> Return 0 if last Td was MORE than 10 yrs prior to QDT (or never);
;---> otherwise return 1.
Q $S((BIDATE+100000)<BIQDT:0,1:1)
;
;
;----------
PNEU(BIDFN,BIAGE,BICPTI,BIQDT) ;EP
;---> Return date if patient received Pneumo, concat ^1 if received after 65;
;---> concat a second ^1 if received within the last 5 years.
;---> Parameters:
; 1 - BIDFN (req) Patient DFN
; 2 - BIAGE (req) Patient age in years.
; 3 - BICPTI (opt) 1=Include CPT Coded Visits, 0=Ignore CPT.
; 4 - BIQDT (opt) Quarter Ending Date (ignore Visits after this date)
;
;---> Return 0 if patient is less than 65 yrs old.
Q:(BIAGE<65) 0
;
;---> Check V Imms for PNEU's.
N BICVXS,BIDATE
S BIDATE=0 S:('$G(BIQDT)) BIQDT=$G(DT)
;
;********** PATCH 12, v8.5, MAY 01,2016, IHS/CMI/MWR
;---> Include CVX 133 in Pneumo stats.
;S BICVXS="33,100,109"
S BICVXS="33,100,109,133"
;**********
;
S BIDATE=$$LASTIMM^BIUTL11(BIDFN,BICVXS,BIQDT)
;
;---> So, BIDATE is the latest PNEU in V Imm (but not after the QDT).
;
;---> Check (if requested) V CPTs for FLU's.
D:$G(BICPTI)
.N BICPTS,Y
.S BICPTS="90732,90669"
.S Y=$$LASTCPT^BIUTL11(BIDFN,BICPTS,BIQDT)
.S:Y>$G(BIDATE) BIDATE=Y
;
;---> Patient never received pneumo.
I +BIDATE=0 Q "0^0^0"
;
;---> If patient received pneumo at or after age 65, set BI65=1 (otherwise 0).
N BI65 S BI65=1
I ($$DOB^BIUTL1(BIDFN)+650000)>BIDATE S BI65=0
;
;********** PATCH 12, v8.5, MAY 01,2016, IHS/CMI/MWR
;---> Return 3rd pc: If received within 5 yrs, return 1 (1= <5ys; 0= >5yrs).
N BI5Y S BI5Y=0
I (BIQDT-BIDATE)<50001 S BI5Y=1
;
;---> Return After 65 indicator_^_Date of last Pneumo_^_<5yr indicator.
Q BI65_U_+BIDATE_U_BI5Y
;**********
;
;
;----------
OZSTER(BIDFN,BICPTI,BIQDT) ;EP
;---> NOTE: "O" and "Z" reversed to avoid SACC trigger of $Z violation.
;---> Return 1 if patient ever received Zostavax prior to the QDT.
;---> Parameters:
; 1 - BIDFN (req) Patient DFN
; 2 - BICPTI (opt) 1=Include CPT Coded Visits, 0=Ignore CPT.
; 3 - BIQDT (opt) Quarter Ending Date (ignore Visits after this date).
;
;---> Check V Imms for Zostavax's.
N BICVXS,BIDATE
S BIDATE=0 S:('$G(BIQDT)) BIQDT=$G(DT)
S BICVXS="121"
S BIDATE=$$LASTIMM^BIUTL11(BIDFN,BICVXS,BIQDT)
;
;---> So, BIDATE is the latest Zostavax in V Imm (but not after the QDT).
;
;---> Check (if requested) V CPTs for Zostavax's.
D:$G(BICPTI)
.N BICPTS,Y
.S BICPTS="90736"
.S Y=$$LASTCPT^BIUTL11(BIDFN,BICPTS,BIQDT)
.S:Y>$G(BIDATE) BIDATE=Y
;
;---> Return 0 if patient Never received Zostavax prior to QDT otherwise DATE.
Q +BIDATE
;
;
;----------
HPV(BIDFN,BICPTI,BIQDT) ;EP
;---> Return number of HPV's patient received, concat
;---> Parameters:
; 1 - BIDFN (req) Patient DFN
; 2 - BICPTI (opt) 1=Include CPT Coded Visits, 0=Ignore CPT.
; 3 - BIQDT (opt) Quarter Ending Date (ignore Visits after this date).
;
;---> Check V Imms for FLU's.
N BICVXS,BIDATE,BIDOSES,I,J
S BIDATE=0,BIDOSES=0,J=0
S:('$G(BIQDT)) BIQDT=$G(DT)
S BICVXS="62,118,137"
S BIDATE=$$LASTIMM^BIUTL11(BIDFN,BICVXS,BIQDT,1)
;
F I=1:1:3 I $P(BIDATE,",",I) S J=J+1
S BIDOSES=J
;
;---> Check (if requested) V CPTs for HPV's.
D:$G(BICPTI)
.N BICPTS,J S J=0
.S BICPTS="90649,90650"
.S BIDATE=$$LASTCPT^BIUTL11(BIDFN,BICPTS,BIQDT,1)
.F I=1:1:3 I $P(BIDATE,",",I) S J=J+1
.S BIDOSES=BIDOSES+J
;
Q BIDOSES
BIREPL3 ;IHS/CMI/MWR - REPORT, ADULT IMM; OCT 15, 2010
+1 ;;8.5;IMMUNIZATION;**12**;MAY 01,2016
+2 ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
+3 ;; GATHER DATA FOR ADULT IMMUNIZATION REPORT.
+4 ;; PATCH 1: Commented out for ref to ICPT for Code Set versioning. LASTFLU+25
+5 ;; PATCH 2: Filter for Active Clinical, using new standard $$ACTCLIN^BIUTL6 call.
+6 ;; GETSTATS+60
+7 ;; PATCH 3: Set HPV upper limit for males to 21 years of age. GETSTATS+119
+8 ;; PATCH 12: Include CVX 133 in Pneumo stats. PNEU+15
+9 ;; Add new Composite Measures. GETSTATS+32
+10 ;
+11 ;
+12 ;----------
GETSTATS(BIQDT,BICC,BIHCF,BIBEN,BICPTI,BIUP,BITOTS) ;EP
+1 ;---> Produce array for ADULT Immunization Report.
+2 ;---> Parameters:
+3 ; 1 - BIQDT (req) Quarter Ending Date.
+4 ; 2 - BICC (req) Current Community array.
+5 ; 3 - BIHCF (req) Health Care Facility array.
+6 ; 4 - BIBEN (req) Beneficiary Type array.
+7 ; 5 - BICPTI (opt) 1=Include CPT Coded Visits, 0=Ignore CPT (default).
+8 ; 6 - BIUP (req) User Population/Group (Registered, Imm, User, Active).
+9 ; 7 - BITOTS (ret) Totals delimited by "^":
+10 ; Pc Variable
+11 ; 1 - BI19=Total over 19
+12 ; 2 - BIT19 = Number over 19 w/Tetanus past 10 years.
+13 ; 3 - BITDAP = Number over 19 w/Tdap past 10 years.
+14 ;
+15 ; 4 - BIHPVF = Total number of Females age 19-26
+16 ; 5 - BIHPVF1 = Number Females 19-26 w/HPV-1
+17 ; 6 - BIHPVF2 = Number Females 19-26 w/HPV-2
+18 ; 7 - BIHPVF3 = Number Females 19-26 w/HPV-3
+19 ; 8 - BIHPVF = Total number of Males age 19-26
+20 ; 9 - BIHPVM1 = Number Males 19-21 w/HPV-1
+21 ; 10 - BIHPVM2 = Number Males 19-21 w/HPV-2
+22 ; 11 - BIHPVM3 = Number Males 19-21 w/HPV-3
+23 ;
+24 ; 12 - BI60=Total over 60
+25 ; 13 - BIZ60 = Number over 60 w/Zoster ever.
+26 ; 14 - BI65=Total over 65
+27 ; 15 - BIT65 = Number over 65 w/Tetanus past 10 years.
+28 ; 16 - BIP65 = Number over 65 w/Pneumo at or after age 65.
+29 ; 17 - BIP65E = Number over 65 w/Pneumo EVER.
+30 ;
+31 ;********** PATCH 12, v8.5, MAY 01,2016, IHS/CMI/MWR
+32 ;---> New Composite Measure Variables.
+33 ; 18 - BIC19=Total >19 <60
+34 ; 19 - BIC191=Tdap ever
+35 ; 20 - BIC192=(Td or Tdap) <10 yrs
+36 ; 21 - BIC193=(Tdap ever) AND ((Tdap or Td) <10 yrs)
+37 ;
+38 ; 22 - BIC60=Total >60 <65
+39 ; 23 - BIC601=Tdap ever
+40 ; 24 - BIC602=(Td or Tdap) <10 yrs
+41 ; 25 - BIC603=Zoster
+42 ; 26 - BIC604=(Tdap ever) AND ((Tdap or Td) <10 yrs) AND Zoster
+43 ;
+44 ; 27 - BIC65=Total >65
+45 ; 28 - BIC651=Tdap ever
+46 ; 29 - BIC652=(Td or Tdap) <10 yrs
+47 ; 30 - BIC653=Zoster
+48 ; 31 - BIC654=Pneumo >65 yrs
+49 ; 32 - BIC655=(Tdap ever) AND ((Tdap or Td) <10 yrs) AND Zoster AND Pneumo
+50 ; 33 - BICUTDD=Overall UTD Denominator
+51 ; 34 - BICUTDN-Overall UTD Numerator
+52 ;
+53 NEW BIC19,BIC191,BIC192,BIC193,BIC60,BIC601,BIC602,BIC603,BIC604
+54 SET (BIC19,BIC191,BIC192,BIC193,BIC60,BIC601,BIC602,BIC603,BIC604)=0
+55 NEW BIC65,BIC651,BIC652,BIC653,BIC654,BIC655,BICAGE,BICUTDD,BICUTDN
+56 SET (BIC65,BIC651,BIC652,BIC653,BIC654,BIC655,BICUTDD,BICUTDN)=0
+57 ;**********
+58 ;
+59 NEW BIADOB,BIADOBE,BI19,BIT19,BITDAP
+60 NEW BIHPVF,BIHPVF1,BIHPVF2,BIHPVF3,BIHPVM,BIHPVM1,BIHPVM2,BIHPVM3
+61 NEW BI60,BIZ60
+62 NEW BI65,BIT65,BIP65,BIP65E
+63 ;
+64 SET (BI19,BIHPVF,BIHPVM,BI60,BI65,BIP65,BI65E)=0
+65 IF ('$DATA(BICPTI))
SET BICPTI=0
+66 IF ('$GET(BIQDT))
SET BIQDT=$GET(DT)
+67 ;
+68 ;---> Loop through Patient global looking for visits and immunizations.
+69 ;---> DOB must be at least 19 years before Quarter Ending Date.
+70 SET BIADOB=0
SET BIADOBE=BIQDT-190000
+71 FOR
SET BIADOB=$ORDER(^DPT("ADOB",BIADOB))
IF (BIADOB>BIADOBE)
QUIT
Begin DoDot:1
+72 NEW BIDFN
SET BIDFN=0
+73 FOR
SET BIDFN=$ORDER(^DPT("ADOB",BIADOB,BIDFN))
IF 'BIDFN
QUIT
Begin DoDot:2
+74 ;
+75 ;---> Filter for standard Patient Population parameter.
+76 IF '$$PPFILTR^BIREP(BIDFN,.BIHCF,BIQDT,BIUP)
QUIT
+77 ;
+78 ;---> Get Age in Years for Stats.
+79 NEW BIAGE
SET BIAGE=$$AGE^BIUTL1(BIDFN,1,BIQDT)
+80 ;---> Quit if under age 19 on the Quarter Ending Date.
+81 IF BIAGE<19
QUIT
+82 ;
+83 ;---> Quit if Beneficiary Type doesn't match.
+84 IF $$BENT^BIDUR1(BIDFN,.BIBEN)
QUIT
+85 ;
+86 ;---> Quit if Current Community doesn't match.
+87 IF $$CURCOM^BIEXPRT2(BIDFN,.BICC)
QUIT
+88 ;
+89 ;---> Set patient as Not Due, BIVAL=2
+90 ;---> If patient is due (change below), set BIVAL=1.
+91 SET BIVAL=2
+92 ;
+93 ;---> Set Composite Flags.
+94 NEW BIFTD10,BIFTDAP,BIFZO,BIFPNE
+95 SET (BIFTD10,BIFTDAP,BIFZO,BIFPNE)=0
+96 ;
+97 ;---> Set Age totals.
+98 SET BI19=BI19+1
IF BIAGE>59
SET BI60=BI60+1
IF BIAGE>64
SET BI65=BI65+1
+99 ;**********
+100 Begin DoDot:3
+101 ;---> Set BICAGE=19,60,or 65 for Age categories.
+102 IF BIAGE<60
SET BICAGE=19
SET BIC19=BIC19+1
QUIT
+103 IF (BIAGE>59)&(BIAGE<65)
SET BICAGE=60
SET BIC60=BIC60+1
QUIT
+104 IF BIAGE>64
SET BICAGE=65
SET BIC65=BIC65+1
+105 ;**********
End DoDot:3
+106 ;
+107 ;
+108 ;---> TETANUS STATS ******************************
+109 ;---> Check Td/Tdap <10 yrs.
+110 Begin DoDot:3
+111 IF $$TD(BIDFN,BICPTI,BIQDT)
Begin DoDot:4
+112 SET BIT19=$GET(BIT19)+1
IF BIAGE>64
SET BIT65=$GET(BIT65)+1
+113 ;**********
+114 SET BIFTD10=1
Begin DoDot:5
+115 IF BICAGE=19
SET BIC192=BIC192+1
QUIT
+116 IF BICAGE=60
SET BIC602=BIC602+1
QUIT
+117 IF BICAGE=65
SET BIC652=BIC652+1
End DoDot:5
+118 ;**********
End DoDot:4
QUIT
+119 ;---> Patient NO Td/Tdap <10 yrs, is/was due for Tetanus.
+120 SET BIVAL=1
End DoDot:3
+121 ;
+122 ;
+123 ;---> Tdap Stats.
+124 ;---> If Tdap <10 yrs.
+125 IF $$TD(BIDFN,BICPTI,BIQDT,1)
SET BITDAP=$GET(BITDAP)+1
+126 ;**********
+127 ;---> If Tdap EVER.
+128 IF $$TD(BIDFN,BICPTI,BIQDT,2)
Begin DoDot:3
+129 SET BIFTDAP=1
+130 IF BICAGE=19
SET BIC191=BIC191+1
QUIT
+131 IF BICAGE=60
SET BIC601=BIC601+1
QUIT
+132 IF BICAGE=65
SET BIC651=BIC651+1
End DoDot:3
+133 ;**********
+134 ;---> FLU STATS - *** PREVIOUS CODE SAVED IN ^BIZFLU.
+135 ;
+136 ;
+137 ;---> PNEUMO STATS *******************************^
+138 Begin DoDot:3
+139 NEW BIPNE65
SET BIPNE65=$$PNEU(BIDFN,BIAGE,BICPTI,BIQDT)
+140 ;---> Patient received Pneumo EVER.
+141 IF $PIECE(BIPNE65,U,2)
SET BIP65E=$GET(BIP65E)+1
+142 ;**********
+143 ;---> If patient received Pneumo at or after age 65 *OR* < 5yrs, set flag.
+144 IF ($PIECE(BIPNE65,U))!($PIECE(BIPNE65,U,3))
IF BICAGE=65
SET BIC654=BIC654+1
SET BIFPNE=1
+145 ;**********
+146 ;---> If patient received Pneumo at or after age 65, quit: no longer due.
+147 IF $PIECE(BIPNE65,U)
SET BIP65=$GET(BIP65)+1
QUIT
+148 ;---> If >64 yrs and didn't receive pneumo, patient is due.
+149 IF BIAGE>64
SET BIVAL=1
End DoDot:3
+150 ;
+151 ;
+152 ;---> ZOSTER STATS *********************************
+153 Begin DoDot:3
+154 IF $$OZSTER(BIDFN,BICPTI,BIQDT)
Begin DoDot:4
+155 IF BIAGE>59
SET BIZ60=$GET(BIZ60)+1
+156 ;
+157 ;**********
+158 SET BIFZO=1
+159 IF BICAGE=60
SET BIC603=BIC603+1
QUIT
+160 IF BICAGE=65
SET BIC653=BIC653+1
End DoDot:4
QUIT
+161 ;
+162 ;---> Patient is/was due for Zostervax if 60+ years on QDT.
+163 ;********** v8.5, MAY 15,2011, IHS/CMI/MWR
+164 ;---> Do NOT include patient in Not Current group for zoster.
+165 ;S:BIAGE>59 BIVAL=1
End DoDot:3
+166 ;
+167 ;
+168 ;---> GPRA COMPOSITE MEASURES ************************
+169 ;
+170 ;---> CompOsite for 19-59yrs:
+171 ;---> if Tdap EVER *AND* Td/Tdap <10yrs, set flag.
+172 IF BICAGE=19
IF BIFTD10
IF BIFTDAP
SET BIC193=BIC193+1
+173 ;
+174 ;---> Composite for 60-64yrs:
+175 ;---> if Tdap EVER *AND* Td/Tdap <10yrs *AND* Zoster, set flag.
+176 IF BICAGE=60
IF BIFTD10
IF BIFTDAP
IF BIFZO
SET BIC604=BIC604+1
+177 ;
+178 ;---> Compisite for >64yrs:
+179 ;---> if Tdap EVER *AND* Td/Tdap <10yrs *AND* Zoster *and* Pneumo, set flag.
+180 IF BICAGE=65
IF BIFTD10
IF BIFTDAP
IF BIFZO
IF BIFPNE
SET BIC655=BIC655+1
+181 ;
+182 ;
+183 ;
+184 ;---> HPV STATS **************************************
+185 ;********** PATCH 3, v8.5, SEP 10,2012, IHS/CMI/MWR
+186 ;---> Change HPV limit to 21 yrs for males.
+187 ;---> HPV Stats (ages 19-26 for females, 19-21 for males).
+188 NEW BISECS
SET BISEX=$$SEX^BIUTL1(BIDFN)
+189 ;I (BIAGE>18)&(BIAGE<27) D
+190 IF (BIAGE>18)&(BIAGE<$SELECT(BISEX="F":27,1:22))
Begin DoDot:3
+191 ;N BIHPVD,BISEX S BISEX=$$SEX^BIUTL1(BIDFN)
+192 ;S BIHPVD=$$HPV(BIDFN,BICPTI,BIQDT)
+193 ;**********
+194 ;
+195 NEW BIHPVD
SET BIHPVD=$$HPV(BIDFN,BICPTI,BIQDT)
+196 IF BISEX="F"
Begin DoDot:4
+197 SET BIHPVF=$GET(BIHPVF)+1
+198 IF BIHPVD>0
SET BIHPVF1=$GET(BIHPVF1)+1
+199 IF BIHPVD>1
SET BIHPVF2=$GET(BIHPVF2)+1
+200 IF BIHPVD>2
SET BIHPVF3=$GET(BIHPVF3)+1
End DoDot:4
QUIT
+201 IF BISEX="M"
Begin DoDot:4
+202 SET BIHPVM=$GET(BIHPVM)+1
+203 IF BIHPVD>0
SET BIHPVM1=$GET(BIHPVM1)+1
+204 IF BIHPVD>1
SET BIHPVM2=$GET(BIHPVM2)+1
+205 IF BIHPVD>2
SET BIHPVM3=$GET(BIHPVM3)+1
End DoDot:4
QUIT
End DoDot:3
+206 ;
+207 ;---> Will Set ^TMP("BIDUL",$J,CURCOM,1,HRCN,BIDFN)=$G(BIVAL)
+208 DO STORE^BIDUR1(BIDFN,DT,9,,$GET(BIVAL))
+209 ;
+210 ;---> Add refusals, if any.
+211 NEW Z
DO CONTRA^BIUTL11(BIDFN,.Z,1)
IF $ORDER(Z(0))
SET BITMP("REFUSALS",BIDFN)=""
End DoDot:2
End DoDot:1
+212 ;
+213 ;---> Now piece together the totals.
+214 SET BITOTS=$GET(BI19)_U_$GET(BIT19)_U_$GET(BITDAP)
+215 SET BITOTS=BITOTS_U_$GET(BIHPVF)_U_$GET(BIHPVF1)_U_$GET(BIHPVF2)_U_$GET(BIHPVF3)
+216 SET BITOTS=BITOTS_U_$GET(BIHPVM)_U_$GET(BIHPVM1)_U_$GET(BIHPVM2)_U_$GET(BIHPVM3)
+217 SET BITOTS=BITOTS_U_$GET(BI60)_U_$GET(BIZ60)_U_$GET(BI65)_U_$GET(BIT65)_U_$GET(BIP65)_U_$GET(BIP65E)
+218 ;
+219 ;********** PATCH 12, v8.5, MAY 01,2016, IHS/CMI/MWR
+220 ;---> Calculate Overall UTD
+221 SET BICUTDD=BIC19+BIC60+BIC65
+222 SET BICUTDN=BIC193+BIC604+BIC655
+223 ;---> Add new Composite Measure Variables.
+224 SET BITOTS=BITOTS_U_$GET(BIC19)_U_$GET(BIC191)_U_$GET(BIC192)_U_$GET(BIC193)
+225 SET BITOTS=BITOTS_U_$GET(BIC60)_U_$GET(BIC601)_U_$GET(BIC602)_U_$GET(BIC603)_U_$GET(BIC604)
+226 SET BITOTS=BITOTS_U_$GET(BIC65)_U_$GET(BIC651)_U_$GET(BIC652)_U_$GET(BIC653)_U_$GET(BIC654)
+227 SET BITOTS=BITOTS_U_$GET(BIC655)_U_$GET(BICUTDD)_U_$GET(BICUTDN)
+228 QUIT
+229 ;
+230 ;
+231 ;----------
TD(BIDFN,BICPTI,BIQDT,BITDAP) ;EP
+1 ;---> Return 1 if patient received TD during 10 years prior to QDT.
+2 ;---> Parameters:
+3 ; 1 - BIDFN (req) Patient DFN
+4 ; 2 - BICPTI (opt) 1=Include CPT Coded Visits, 0=Ignore CPT.
+5 ; 3 - BIQDT (opt) Quarter Ending Date (ignore Visits after this date).
+6 ; 4 - BITDAP (opt) 1=Tdap ONLY during 10 years prior to QDT.
+7 ; 2=Tdap ONLY and EVER (no prior date restriction).
+8 ;
+9 ;---> Check V Imms for TD's.
+10 NEW BICVXS,BIDATE
+11 SET BIDATE=0
IF ('$GET(BIQDT))
SET BIQDT=$GET(DT)
+12 SET BITDAP=+$GET(BITDAP)
+13 SET BICVXS="1,9,20,22,28,50,106,107,110,113,115"
+14 IF BITDAP
SET BICVXS=115
+15 SET BIDATE=$$LASTIMM^BIUTL11(BIDFN,BICVXS,BIQDT)
+16 ;
+17 ;---> So, BIDATE is the latest TD in V Imm (but not after the QDT).
+18 ;
+19 ;---> Check (if requested) V CPTs for TD's.
+20 IF $GET(BICPTI)
Begin DoDot:1
+21 NEW BICPTS,Y
+22 SET BICPTS="90701,90718,90700,90720,90702,90703,90721,90723"
+23 IF BITDAP
SET BICPTS=90715
+24 SET Y=$$LASTCPT^BIUTL11(BIDFN,BICPTS,BIQDT)
+25 IF Y>$GET(BIDATE)
SET BIDATE=Y
End DoDot:1
+26 ;
+27 ;********** PATCH 12, v8.5, MAY 01,2016, IHS/CMI/MWR
+28 ;---> If BITDAP=2, return 1 if Tdap EVER.
+29 IF BITDAP=2
QUIT $SELECT(BIDATE:1,1:0)
+30 ;**********
+31 ;
+32 ;---> Return 0 if last Td was MORE than 10 yrs prior to QDT (or never);
+33 ;---> otherwise return 1.
+34 QUIT $SELECT((BIDATE+100000)<BIQDT:0,1:1)
+35 ;
+36 ;
+37 ;----------
PNEU(BIDFN,BIAGE,BICPTI,BIQDT) ;EP
+1 ;---> Return date if patient received Pneumo, concat ^1 if received after 65;
+2 ;---> concat a second ^1 if received within the last 5 years.
+3 ;---> Parameters:
+4 ; 1 - BIDFN (req) Patient DFN
+5 ; 2 - BIAGE (req) Patient age in years.
+6 ; 3 - BICPTI (opt) 1=Include CPT Coded Visits, 0=Ignore CPT.
+7 ; 4 - BIQDT (opt) Quarter Ending Date (ignore Visits after this date)
+8 ;
+9 ;---> Return 0 if patient is less than 65 yrs old.
+10 IF (BIAGE<65)
QUIT 0
+11 ;
+12 ;---> Check V Imms for PNEU's.
+13 NEW BICVXS,BIDATE
+14 SET BIDATE=0
IF ('$GET(BIQDT))
SET BIQDT=$GET(DT)
+15 ;
+16 ;********** PATCH 12, v8.5, MAY 01,2016, IHS/CMI/MWR
+17 ;---> Include CVX 133 in Pneumo stats.
+18 ;S BICVXS="33,100,109"
+19 SET BICVXS="33,100,109,133"
+20 ;**********
+21 ;
+22 SET BIDATE=$$LASTIMM^BIUTL11(BIDFN,BICVXS,BIQDT)
+23 ;
+24 ;---> So, BIDATE is the latest PNEU in V Imm (but not after the QDT).
+25 ;
+26 ;---> Check (if requested) V CPTs for FLU's.
+27 IF $GET(BICPTI)
Begin DoDot:1
+28 NEW BICPTS,Y
+29 SET BICPTS="90732,90669"
+30 SET Y=$$LASTCPT^BIUTL11(BIDFN,BICPTS,BIQDT)
+31 IF Y>$GET(BIDATE)
SET BIDATE=Y
End DoDot:1
+32 ;
+33 ;---> Patient never received pneumo.
+34 IF +BIDATE=0
QUIT "0^0^0"
+35 ;
+36 ;---> If patient received pneumo at or after age 65, set BI65=1 (otherwise 0).
+37 NEW BI65
SET BI65=1
+38 IF ($$DOB^BIUTL1(BIDFN)+650000)>BIDATE
SET BI65=0
+39 ;
+40 ;********** PATCH 12, v8.5, MAY 01,2016, IHS/CMI/MWR
+41 ;---> Return 3rd pc: If received within 5 yrs, return 1 (1= <5ys; 0= >5yrs).
+42 NEW BI5Y
SET BI5Y=0
+43 IF (BIQDT-BIDATE)<50001
SET BI5Y=1
+44 ;
+45 ;---> Return After 65 indicator_^_Date of last Pneumo_^_<5yr indicator.
+46 QUIT BI65_U_+BIDATE_U_BI5Y
+47 ;**********
+48 ;
+49 ;
+50 ;----------
OZSTER(BIDFN,BICPTI,BIQDT) ;EP
+1 ;---> NOTE: "O" and "Z" reversed to avoid SACC trigger of $Z violation.
+2 ;---> Return 1 if patient ever received Zostavax prior to the QDT.
+3 ;---> Parameters:
+4 ; 1 - BIDFN (req) Patient DFN
+5 ; 2 - BICPTI (opt) 1=Include CPT Coded Visits, 0=Ignore CPT.
+6 ; 3 - BIQDT (opt) Quarter Ending Date (ignore Visits after this date).
+7 ;
+8 ;---> Check V Imms for Zostavax's.
+9 NEW BICVXS,BIDATE
+10 SET BIDATE=0
IF ('$GET(BIQDT))
SET BIQDT=$GET(DT)
+11 SET BICVXS="121"
+12 SET BIDATE=$$LASTIMM^BIUTL11(BIDFN,BICVXS,BIQDT)
+13 ;
+14 ;---> So, BIDATE is the latest Zostavax in V Imm (but not after the QDT).
+15 ;
+16 ;---> Check (if requested) V CPTs for Zostavax's.
+17 IF $GET(BICPTI)
Begin DoDot:1
+18 NEW BICPTS,Y
+19 SET BICPTS="90736"
+20 SET Y=$$LASTCPT^BIUTL11(BIDFN,BICPTS,BIQDT)
+21 IF Y>$GET(BIDATE)
SET BIDATE=Y
End DoDot:1
+22 ;
+23 ;---> Return 0 if patient Never received Zostavax prior to QDT otherwise DATE.
+24 QUIT +BIDATE
+25 ;
+26 ;
+27 ;----------
HPV(BIDFN,BICPTI,BIQDT) ;EP
+1 ;---> Return number of HPV's patient received, concat
+2 ;---> Parameters:
+3 ; 1 - BIDFN (req) Patient DFN
+4 ; 2 - BICPTI (opt) 1=Include CPT Coded Visits, 0=Ignore CPT.
+5 ; 3 - BIQDT (opt) Quarter Ending Date (ignore Visits after this date).
+6 ;
+7 ;---> Check V Imms for FLU's.
+8 NEW BICVXS,BIDATE,BIDOSES,I,J
+9 SET BIDATE=0
SET BIDOSES=0
SET J=0
+10 IF ('$GET(BIQDT))
SET BIQDT=$GET(DT)
+11 SET BICVXS="62,118,137"
+12 SET BIDATE=$$LASTIMM^BIUTL11(BIDFN,BICVXS,BIQDT,1)
+13 ;
+14 FOR I=1:1:3
IF $PIECE(BIDATE,",",I)
SET J=J+1
+15 SET BIDOSES=J
+16 ;
+17 ;---> Check (if requested) V CPTs for HPV's.
+18 IF $GET(BICPTI)
Begin DoDot:1
+19 NEW BICPTS,J
SET J=0
+20 SET BICPTS="90649,90650"
+21 SET BIDATE=$$LASTCPT^BIUTL11(BIDFN,BICPTS,BIQDT,1)
+22 FOR I=1:1:3
IF $PIECE(BIDATE,",",I)
SET J=J+1
+23 SET BIDOSES=BIDOSES+J
End DoDot:1
+24 ;
+25 QUIT BIDOSES
