BGP1D34 ; IHS/CMI/LAB - measure C ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;
CNTDTAP ;
S (X,Y)="",C=0 F S X=$O(BGPDTAP(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPDTAP(X) Q
.S Y=X
;count
S BGPDTAP=0,X=0 F S X=$O(BGPDTAP(X)) Q:X'=+X S BGPDTAP=BGPDTAP+1
Q
RESET ;RESET WORKING ARRAYS
K BGPDT M BGPDT=BGPADT
K BGPDIP M BGPDIP=BGPADIP
K BGPTET M BGPTET=BGPATET
K BGPPER M BGPPER=BGPAPER
K BGPTD M BGPTD=BGPATD
Q
RESETD ;RESET DUP
S (X,Y)="",C=0 F S X=$O(BGPDT(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPDT(X) Q
.S Y=X
S (X,Y)="",C=0 F S X=$O(BGPDIP(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPDIP(X) Q
.S Y=X
S (X,Y)="",C=0 F S X=$O(BGPTET(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPTET(X) Q
.S Y=X
S (X,Y)="",C=0 F S X=$O(BGPTD(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPTD(X) Q
.S Y=X
S (X,Y)="",C=0 F S X=$O(BGPPER(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPPER(X) Q
.S Y=X
S BGPDT=0,X=0 F S X=$O(BGPDT(X)) Q:X'=+X S BGPDT=BGPDT+1
S BGPTD=0,X=0 F S X=$O(BGPTD(X)) Q:X'=+X S BGPTD=BGPTD+1
S BGPDIP=0,X=0 F S X=$O(BGPDIP(X)) Q:X'=+X S BGPDIP=BGPDIP+1
S BGPTET=0,X=0 F S X=$O(BGPTET(X)) Q:X'=+X S BGPTET=BGPTET+1
S BGPPER=0,X=0 F S X=$O(BGPPER(X)) Q:X'=+X S BGPPER=BGPPER+1
Q
DTAP(P,EDATE) ;EP
K ^TMP($J,"CPT")
K BGPC,BGPG,BGPX
;first gather up all cpt codes that relate in any way to dtap
S ED=9999999-EDATE-1,BD=9999999-$$DOB^AUPNPAT(P),G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V D
..Q:'$D(^AUPNVSIT(V,0))
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
...Q:'$D(^AUPNVCPT(X,0))
...S Y=$P(^AUPNVCPT(X,0),U)
...Q:Y=""
...S Y=$P($$CPT^ICPTCOD(Y),U,2)
...I Y=90700!(Y=90721)!(Y=90723)!(Y=90701)!(Y=90711)!(Y=90720)!(Y=90702)!(Y=90718)!(Y=90719)!(Y=90703)!(Y=90698)!(Y=90715)!(Y=90714)!(Y=90696) S ^TMP($J,"CPT",9999999-$P(ED,"."),Y)=""
..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
...Q:'$D(^AUPNVTC(X,0))
...S Y=$P(^AUPNVTC(X,0),U,7)
...Q:Y=""
...S Y=$P($$CPT^ICPTCOD(Y),U,2)
...I Y=90700!(Y=90721)!(Y=90723)!(Y=90701)!(Y=90711)!(Y=90720)!(Y=90702)!(Y=90718)!(Y=90719)!(Y=90703)!(Y=90698)!(Y=90715)!(Y=90714)!(Y=90696) S ^TMP($J,"CPT",9999999-$P(ED,"."),Y)=""
;now gather up all DTAP immunizations, cpts
K BGPDTAP
S BGPEVTD=0,BGPEVDIP=0,BGPEVPER=0
;get all imms
S C="20^50^106^107^110^1^22^102^115^120^130^132"
D GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
;go through and set into DTAP if 10 days apart
S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPDTAP(X)=""
D CNTDTAP ;if there are 4
I BGPDTAP>3 Q 1_U_"4 Dtap/Dtp" ;had 4 dtap by cvx so code is 1
;now get cpts for dtap or dtp
S D=0 F S D=$O(^TMP($J,"CPT",D)) Q:D'=+D S Y="" F S Y=$O(^TMP($J,"CPT",D,Y)) Q:Y="" D
.I Y=90700!(Y=90721)!(Y=90723)!(Y=90701)!(Y=90711)!(Y=90720)!(Y=90698)!(Y=90715)!(Y=90696) S BGPDTAP(D)=""
D CNTDTAP ;count to see if there are 4
I BGPDTAP>3 Q 1_U_"4 Dtap/Dtp" ;had 4 dtap cvx or cpts so code is 1
DT ;add in dt's
K BGPDT,BGPADT
S C="28"
K BGPX D GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPDT(X)="",BGPADT(X)=""
;add in dt cpts
S D=0 F S D=$O(^TMP($J,"CPT",D)) Q:D'=+D S Y="" F S Y=$O(^TMP($J,"CPT",D,Y)) Q:Y="" D
.I Y=90702 S BGPDT(D)="",BGPADT(D)=""
;are there 3 dt and 1 dtap by cvx and/or cpt?
DT1 ;
;kill off any that are on the same day as the dtaps
S (X,Y)="",C=0 F S X=$O(BGPDT(X)) Q:X'=+X I $D(BGPDTAP(X)) K BGPDT(X)
S (X,Y)="",C=0 F S X=$O(BGPDT(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPDT(X) Q
.S Y=X
S BGPDT=0,X=0 F S X=$O(BGPDT(X)) Q:X'=+X S BGPDT=BGPDT+1
I BGPDT>2,$O(BGPDTAP(0)) Q 1_U_"Dtap and 3 DTs"
TETCVX ;
K BGPTET,BGPATET
S C="35^112"
K BGPX D GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPTET(X)="",BGPATET(X)=""
S D=0 F S D=$O(^TMP($J,"CPT",D)) Q:D'=+D S Y="" F S Y=$O(^TMP($J,"CPT",D,Y)) Q:Y="" D
.I Y=90703 S BGPTET(D)="",BGPATET(D)=""
DIPCVX ;
K BGPDIP,BGPADIP
S D=0 F S D=$O(^TMP($J,"CPT",D)) Q:D'=+D S Y="" F S Y=$O(^TMP($J,"CPT",D,Y)) Q:Y="" D
.I Y=90719 S BGPDIP(D)="",BGPADIP(D)=""
PERCVX ;
K BGPPER,BGPAPER
S C="11"
K BGPX D GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPPER(X)="",BGPAPER(X)=""
TDCVX ;
K BGPTD,BGPATD
S C="9^113"
K BGPX D GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPTD(X)="",BGPATD(X)=""
S D=0 F S D=$O(^TMP($J,"CPT",D)) Q:D'=+D S Y="" F S Y=$O(^TMP($J,"CPT",D,Y)) Q:Y="" D
.I Y=90718!(Y=90714) S BGPTD(D)="",BGPATD(D)=""
S BGPCODE=1 D TEST
I BGPVAL]"" Q BGPVAL
;PV
DTPPV ;
D RESET
K BGPG S %=P_"^ALL DX V06.1;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPDTAP($P(BGPG(X),U))=""
K BGPG S %=P_"^ALL DX V06.2;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPDTAP($P(BGPG(X),U))=""
K BGPG S %=P_"^ALL DX V06.3;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPDTAP($P(BGPG(X),U))=""
K BGPG S %=P_"^ALL PROCEDURE 99.39;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPDTAP($P(BGPG(X),U))=""
D CNTDTAP ;count to see if there are 4
I BGPDTAP>3 Q 2_U_"4 Dtap/Dtp" ; had 4 dtap/cpt/pv/proc
DTPV ;
K BGPG S %=P_"^ALL DX V06.5;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPDT($P(BGPG(X),U))="",BGPADT($P(BGPG(X),U))=""
S (X,Y)="",C=0 F S X=$O(BGPDT(X)) Q:X'=+X I $D(BGPDTAP(X)) K BGPDT(X)
D RESETD
I BGPDT>2,$O(BGPDTAP(0)) Q 2_U_"Dtap and 3 DTs"
D RESET
TETPV ;
K BGPG S %=P_"^ALL DX V03.7;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPTET($P(BGPG(X),U))="",BGPATET($P(BGPG(X),U))=""
K BGPG S %=P_"^ALL PROCEDURE 99.38;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPTET($P(BGPG(X),U))="",BGPATET($P(BGPG(X),U))=""
DIPPV ;
K BGPG S %=P_"^ALL DX V03.5;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPDIP($P(BGPG(X),U))="",BGPADIP($P(BGPG(X),U))=""
K BGPG S %=P_"^ALL PROCEDURE 99.36;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPDIP($P(BGPG(X),U))="",BGPADIP($P(BGPG(X),U))=""
PERPV ;
K BGPG S %=P_"^ALL DX V03.6;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPPER($P(BGPG(X),U))="",BGPAPER($P(BGPG(X),U))=""
K BGPG S %=P_"^ALL PROCEDURE 99.37;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPPER($P(BGPG(X),U))="",BGPAPER($P(BGPG(X),U))=""
TDPV ;
K BGPG S %=P_"^ALL DX V06.5;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPTD($P(BGPG(X),U))="",BGPATD($P(BGPG(X),U))=""
S BGPCODE=2 D TEST
EVIDTET ;
S BGPEVTD=""
;K BGPG S %=P_"^LAST DX 037.;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
;I $D(BGPG(1)) S BGPEVTD=1
;I $$PLCODE^BGP1DU(P,"037.") S BGPEVTD=1
D RESETD
I BGPEVTD,BGPPER>3,BGPDIP>3 Q 4_U_"evid tet, 4 dip, 4 per"
D RESET
EVIDPER ;
S BGPEVPER=""
;K BGPG S %=P_"^LAST DX [BGP PERTUSSIS EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
;I $D(BGPG(1)) S BGPEVPER=1
;I $$PLTAX^BGP1DU(P,"BGP PERTUSSIS EVIDENCE") S BGPEVPER=1
D RESETD
I BGPEVPER,BGPDT>3 Q 4_U_"Evid per 4 dt"
I BGPEVPER,BGPTD>3 Q 4_U_"Evid per 4 td"
I BGPEVPER,BGPTET>3,BGPDIP>3 Q 4_U_"evid per 4 tet 4 dip"
EVIDDIP ;
D RESET
S BGPDIPEV=""
;K BGPG S %=P_"^LAST DX [BGP DIPHTHERIA EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
;I $D(BGPG(1)) S BGPEVDIP=1
;I $$PLTAX^BGP1DU(P,"BGP DIPHTHERIA EVIDENCE") S BGPEVDIP=1
D RESETD
I BGPEVDIP,BGPTD>3,BGPPER>3 Q 4_U_"Evid Dip 4 Tetanus 4 Per"
I BGPEVDIP,BGPTET>3,BGPPER>3 Q 4_U_"Evid Dip 4 Tetanus 4 Per"
I BGPEVDIP,BGPDT>3,BGPPER>3 Q 4_U_"evid dip 4 dt 4 per"
REF ;
;now go to refusals
S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
F BGPIMM=20,50,106,107,110,1,22,102,115,120,130,132 D
.S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
.S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"ref")_" Dtap or DT"
;now check refusals in imm pkg
F BGPIMM=20,50,106,107,110,1,22,102,115,120,130,132 Q:R S R=$$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
I R Q 3_U_" ref Dtap or DT"
;get dt and td refusals and count with 4 Pertussis
S (R,BGPNMI)="" F BGPIMM=9,113 D
.S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
.S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
I R,BGPDTAP>2 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"ref")_" td has 3 DTap"
I R,BGPPER>3 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"ref")_" td has per"
;now check refusals in imm pkg
S R=""
F BGPIMM=9,113 S R=$$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
I R,BGPDTAP>2 Q 3_U_" refused td has 3 DTap"
I R>3,BGPPER>3 Q 3_U_" refused td has per"
S (R,BGPNMI)="" F BGPIMM=28 D
.S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
.S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
I R,BGPDTAP>0 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI dtap",1:"ref dtap")
I R,BGPPER>3 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI dtap",1:"ref dtap")
;now check refusals in imm pkg
S (R,BGPNMI)="" F BGPIMM=28 S R=$$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
I R,BGPDTAP>0 Q 3_U_"ref dtap"
I R,BGPPER>3 Q 3_U_"ref dtap"
;PERTUSIS refusals and count with 4 dt OR TD or Tet & Dip
S (R,BGPNMI)="" F BGPIMM=11 D
.S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
.S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
I R,(BGPDT>3!(BGPTD>3)) Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI dtap",1:"ref dtap")
I R,BGPDIP>3,BGPTET>3 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI dtap",1:"ref dtap")
;now check refusals in imm pkg
S (R,BGPNMI)="" F BGPIMM=11 S R=$$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
I R,(BGPDT>3!(BGPTD>3)) Q 3_U_"ref dtap"
;TETANUS refusals and count with 4 PERTUSSIS AND DIP
S (R,BGPNMI)="" F BGPIMM=35,112 D
.S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
.S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
I R,BGPPER>3,BGPD>3 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI dtap",1:"ref dtap")
;now check refusals in imm pkg
S R="" F BGPIMM=35,112 S R=$$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
I BGPPER>3,BGPD>3,R Q 3_U_"ref dtap"
;now check for contraindication
F BGPZ=20,80,106,107,110,120,130,132 S X=$$ANCONT^BGP1D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"contra - DTaP"
F BGPZ=1,22 S X=$$ANCONT^BGP1D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"contra - DTP"
F BGPZ=115 S X=$$ANCONT^BGP1D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"contra - Tdap"
F BGPZ=28 S X=$$ANCONT^BGP1D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"contra - DT"
F BGPZ=9,113 S X=$$ANCONT^BGP1D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"contra - td"
F BGPZ=35,112 S X=$$ANCONT^BGP1D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"contra - tetanus"
F BGPZ=11 S X=$$ANCONT^BGP1D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"contra - pertussis"
Q ""
TEST ;
;NOW TEST FOR ALL POSSIBLE COMBINATIONS OF HAVING MET INDICATOR
;1 DTAP AND 3 EACH TET,PER,DIP
;kill off any dip or tet on same day as a dtap
S BGPVAL=""
S (X,Y)="",C=0 F S X=$O(BGPDIP(X)) Q:X'=+X I $D(BGPDTAP(X)) K BGPDIP(X)
S (X,Y)="",C=0 F S X=$O(BGPDIP(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPDIP(X) Q
.S Y=X
S (X,Y)="",C=0 F S X=$O(BGPTET(X)) Q:X'=+X I $D(BGPDTAP(X)) K BGPTET(X)
S (X,Y)="",C=0 F S X=$O(BGPTET(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPTET(X) Q
.S Y=X
S BGPDIP=0,X=0 F S X=$O(BGPDIP(X)) Q:X'=+X S BGPDIP=BGPDIP+1
S BGPTET=0,X=0 F S X=$O(BGPTET(X)) Q:X'=+X S BGPTET=BGPTET+1
I BGPTET>2,BGPDIP>1,$O(BGPDTAP(0)) S BGPBAL=BGPCODE_U_"Dtap & 3 TET & 3 DIP" Q
DTPER ;is there 4 DT and 4 pertussis?
D RESET
;delete ones not 10 days apart
S (X,Y)="",C=0 F S X=$O(BGPDT(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPDT(X) Q
.S Y=X
S (X,Y)="",C=0 F S X=$O(BGPPER(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPPER(X) Q
.S Y=X
S BGPDT=0,X=0 F S X=$O(BGPDT(X)) Q:X'=+X S BGPDT=BGPDT+1
S BGPPER=0,X=0 F S X=$O(BGPPER(X)) Q:X'=+X S BGPPER=BGPPER+1
I BGPPER>3,BGPDT>3 S BGPVAL=BGPCODE_U_"3 DT & 3 PER" Q
TDPER ;
D RESET
S (X,Y)="",C=0 F S X=$O(BGPTD(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPTD(X) Q
.S Y=X
S (X,Y)="",C=0 F S X=$O(BGPPER(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPPER(X) Q
.S Y=X
S BGPTD=0,X=0 F S X=$O(BGPTD(X)) Q:X'=+X S BGPTD=BGPTD+1
S BGPPER=0,X=0 F S X=$O(BGPPER(X)) Q:X'=+X S BGPPER=BGPPER+1
I BGPPER>3,BGPTD>3 S BGPVAL=BGPCODE_U_"3 TD & 3 PER" Q
I BGPTD>2,$O(BGPDTAP(0)) S BGPVAL=BGPCODE_U_"Dtap & 3 Td" Q
DIPTETPE ;
D RESET
S (X,Y)="",C=0 F S X=$O(BGPPER(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPPER(X) Q
.S Y=X
S BGPPER=0,X=0 F S X=$O(BGPPER(X)) Q:X'=+X S BGPPER=BGPPER+1
S (X,Y)="",C=0 F S X=$O(BGPDIP(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPDIP(X) Q
.S Y=X
S (X,Y)="",C=0 F S X=$O(BGPTET(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPTET(X) Q
.S Y=X
S BGPDIP=0,X=0 F S X=$O(BGPDIP(X)) Q:X'=+X S BGPDIP=BGPDIP+1
S BGPTET=0,X=0 F S X=$O(BGPTET(X)) Q:X'=+X S BGPTET=BGPTET+1
I BGPPER>3,BGPDIP>3,BGPTET>3 S BGPVAL=BGPCODE_U_"3 EACH DIP,TET,PER" Q
Q
90700 ;;
90721 ;;
90723 ;;
90701 ;;
90711 ;;
90720 ;;
90702 ;;
90718 ;;
90719 ;;
90703 ;;
BGP1D34 ; IHS/CMI/LAB - measure C ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+2 ;
CNTDTAP ;
+1 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPDTAP(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+2 IF C=1
SET Y=X
QUIT
+3 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPDTAP(X)
QUIT
+4 SET Y=X
End DoDot:1
+5 ;count
+6 SET BGPDTAP=0
SET X=0
FOR
SET X=$ORDER(BGPDTAP(X))
IF X'=+X
QUIT
SET BGPDTAP=BGPDTAP+1
+7 QUIT
RESET ;RESET WORKING ARRAYS
+1 KILL BGPDT
MERGE BGPDT=BGPADT
+2 KILL BGPDIP
MERGE BGPDIP=BGPADIP
+3 KILL BGPTET
MERGE BGPTET=BGPATET
+4 KILL BGPPER
MERGE BGPPER=BGPAPER
+5 KILL BGPTD
MERGE BGPTD=BGPATD
+6 QUIT
RESETD ;RESET DUP
+1 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPDT(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+2 IF C=1
SET Y=X
QUIT
+3 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPDT(X)
QUIT
+4 SET Y=X
End DoDot:1
+5 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPDIP(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+6 IF C=1
SET Y=X
QUIT
+7 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPDIP(X)
QUIT
+8 SET Y=X
End DoDot:1
+9 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPTET(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+10 IF C=1
SET Y=X
QUIT
+11 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPTET(X)
QUIT
+12 SET Y=X
End DoDot:1
+13 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPTD(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+14 IF C=1
SET Y=X
QUIT
+15 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPTD(X)
QUIT
+16 SET Y=X
End DoDot:1
+17 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPPER(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+18 IF C=1
SET Y=X
QUIT
+19 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPPER(X)
QUIT
+20 SET Y=X
End DoDot:1
+21 SET BGPDT=0
SET X=0
FOR
SET X=$ORDER(BGPDT(X))
IF X'=+X
QUIT
SET BGPDT=BGPDT+1
+22 SET BGPTD=0
SET X=0
FOR
SET X=$ORDER(BGPTD(X))
IF X'=+X
QUIT
SET BGPTD=BGPTD+1
+23 SET BGPDIP=0
SET X=0
FOR
SET X=$ORDER(BGPDIP(X))
IF X'=+X
QUIT
SET BGPDIP=BGPDIP+1
+24 SET BGPTET=0
SET X=0
FOR
SET X=$ORDER(BGPTET(X))
IF X'=+X
QUIT
SET BGPTET=BGPTET+1
+25 SET BGPPER=0
SET X=0
FOR
SET X=$ORDER(BGPPER(X))
IF X'=+X
QUIT
SET BGPPER=BGPPER+1
+26 QUIT
DTAP(P,EDATE) ;EP
+1 KILL ^TMP($JOB,"CPT")
+2 KILL BGPC,BGPG,BGPX
+3 ;first gather up all cpt codes that relate in any way to dtap
+4 SET ED=9999999-EDATE-1
SET BD=9999999-$$DOB^AUPNPAT(P)
SET G=0
+5 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+6 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+7 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+9 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+10 SET Y=$PIECE(^AUPNVCPT(X,0),U)
+11 IF Y=""
QUIT
+12 SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
+13 IF Y=90700!(Y=90721)!(Y=90723)!(Y=90701)!(Y=90711)!(Y=90720)!(Y=90702)!(Y=90718)!(Y=90719)!(Y=90703)!(Y=90698)!(Y=90715)!(Y=90714)!(Y=90696)
SET ^TMP($JOB,"CPT",9999999-$PIECE(ED,"."),Y)=""
End DoDot:3
+14 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+15 IF '$DATA(^AUPNVTC(X,0))
QUIT
+16 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
+17 IF Y=""
QUIT
+18 SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
+19 IF Y=90700!(Y=90721)!(Y=90723)!(Y=90701)!(Y=90711)!(Y=90720)!(Y=90702)!(Y=90718)!(Y=90719)!(Y=90703)!(Y=90698)!(Y=90715)!(Y=90714)!(Y=90696)
SET ^TMP($JOB,"CPT",9999999-$PIECE(ED,"."),Y)=""
End DoDot:3
End DoDot:2
End DoDot:1
+20 ;now gather up all DTAP immunizations, cpts
+21 KILL BGPDTAP
+22 SET BGPEVTD=0
SET BGPEVDIP=0
SET BGPEVPER=0
+23 ;get all imms
+24 SET C="20^50^106^107^110^1^22^102^115^120^130^132"
+25 DO GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
+26 ;go through and set into DTAP if 10 days apart
+27 SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET BGPDTAP(X)=""
+28 ;if there are 4
DO CNTDTAP
+29 ;had 4 dtap by cvx so code is 1
IF BGPDTAP>3
QUIT 1_U_"4 Dtap/Dtp"
+30 ;now get cpts for dtap or dtp
+31 SET D=0
FOR
SET D=$ORDER(^TMP($JOB,"CPT",D))
IF D'=+D
QUIT
SET Y=""
FOR
SET Y=$ORDER(^TMP($JOB,"CPT",D,Y))
IF Y=""
QUIT
Begin DoDot:1
+32 IF Y=90700!(Y=90721)!(Y=90723)!(Y=90701)!(Y=90711)!(Y=90720)!(Y=90698)!(Y=90715)!(Y=90696)
SET BGPDTAP(D)=""
End DoDot:1
+33 ;count to see if there are 4
DO CNTDTAP
+34 ;had 4 dtap cvx or cpts so code is 1
IF BGPDTAP>3
QUIT 1_U_"4 Dtap/Dtp"
DT ;add in dt's
+1 KILL BGPDT,BGPADT
+2 SET C="28"
+3 KILL BGPX
DO GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
+4 SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET BGPDT(X)=""
SET BGPADT(X)=""
+5 ;add in dt cpts
+6 SET D=0
FOR
SET D=$ORDER(^TMP($JOB,"CPT",D))
IF D'=+D
QUIT
SET Y=""
FOR
SET Y=$ORDER(^TMP($JOB,"CPT",D,Y))
IF Y=""
QUIT
Begin DoDot:1
+7 IF Y=90702
SET BGPDT(D)=""
SET BGPADT(D)=""
End DoDot:1
+8 ;are there 3 dt and 1 dtap by cvx and/or cpt?
DT1 ;
+1 ;kill off any that are on the same day as the dtaps
+2 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPDT(X))
IF X'=+X
QUIT
IF $DATA(BGPDTAP(X))
KILL BGPDT(X)
+3 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPDT(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+4 IF C=1
SET Y=X
QUIT
+5 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPDT(X)
QUIT
+6 SET Y=X
End DoDot:1
+7 SET BGPDT=0
SET X=0
FOR
SET X=$ORDER(BGPDT(X))
IF X'=+X
QUIT
SET BGPDT=BGPDT+1
+8 IF BGPDT>2
IF $ORDER(BGPDTAP(0))
QUIT 1_U_"Dtap and 3 DTs"
TETCVX ;
+1 KILL BGPTET,BGPATET
+2 SET C="35^112"
+3 KILL BGPX
DO GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
+4 SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET BGPTET(X)=""
SET BGPATET(X)=""
+5 SET D=0
FOR
SET D=$ORDER(^TMP($JOB,"CPT",D))
IF D'=+D
QUIT
SET Y=""
FOR
SET Y=$ORDER(^TMP($JOB,"CPT",D,Y))
IF Y=""
QUIT
Begin DoDot:1
+6 IF Y=90703
SET BGPTET(D)=""
SET BGPATET(D)=""
End DoDot:1
DIPCVX ;
+1 KILL BGPDIP,BGPADIP
+2 SET D=0
FOR
SET D=$ORDER(^TMP($JOB,"CPT",D))
IF D'=+D
QUIT
SET Y=""
FOR
SET Y=$ORDER(^TMP($JOB,"CPT",D,Y))
IF Y=""
QUIT
Begin DoDot:1
+3 IF Y=90719
SET BGPDIP(D)=""
SET BGPADIP(D)=""
End DoDot:1
PERCVX ;
+1 KILL BGPPER,BGPAPER
+2 SET C="11"
+3 KILL BGPX
DO GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
+4 SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET BGPPER(X)=""
SET BGPAPER(X)=""
TDCVX ;
+1 KILL BGPTD,BGPATD
+2 SET C="9^113"
+3 KILL BGPX
DO GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
+4 SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET BGPTD(X)=""
SET BGPATD(X)=""
+5 SET D=0
FOR
SET D=$ORDER(^TMP($JOB,"CPT",D))
IF D'=+D
QUIT
SET Y=""
FOR
SET Y=$ORDER(^TMP($JOB,"CPT",D,Y))
IF Y=""
QUIT
Begin DoDot:1
+6 IF Y=90718!(Y=90714)
SET BGPTD(D)=""
SET BGPATD(D)=""
End DoDot:1
+7 SET BGPCODE=1
DO TEST
+8 IF BGPVAL]""
QUIT BGPVAL
+9 ;PV
DTPPV ;
+1 DO RESET
+2 KILL BGPG
SET %=P_"^ALL DX V06.1;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+3 IF $DATA(BGPG(1))
SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPDTAP($PIECE(BGPG(X),U))=""
+4 KILL BGPG
SET %=P_"^ALL DX V06.2;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+5 IF $DATA(BGPG(1))
SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPDTAP($PIECE(BGPG(X),U))=""
+6 KILL BGPG
SET %=P_"^ALL DX V06.3;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+7 IF $DATA(BGPG(1))
SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPDTAP($PIECE(BGPG(X),U))=""
+8 KILL BGPG
SET %=P_"^ALL PROCEDURE 99.39;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+9 IF $DATA(BGPG(1))
SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPDTAP($PIECE(BGPG(X),U))=""
+10 ;count to see if there are 4
DO CNTDTAP
+11 ; had 4 dtap/cpt/pv/proc
IF BGPDTAP>3
QUIT 2_U_"4 Dtap/Dtp"
DTPV ;
+1 KILL BGPG
SET %=P_"^ALL DX V06.5;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+2 IF $DATA(BGPG(1))
SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPDT($PIECE(BGPG(X),U))=""
SET BGPADT($PIECE(BGPG(X),U))=""
+3 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPDT(X))
IF X'=+X
QUIT
IF $DATA(BGPDTAP(X))
KILL BGPDT(X)
+4 DO RESETD
+5 IF BGPDT>2
IF $ORDER(BGPDTAP(0))
QUIT 2_U_"Dtap and 3 DTs"
+6 DO RESET
TETPV ;
+1 KILL BGPG
SET %=P_"^ALL DX V03.7;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+2 IF $DATA(BGPG(1))
SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPTET($PIECE(BGPG(X),U))=""
SET BGPATET($PIECE(BGPG(X),U))=""
+3 KILL BGPG
SET %=P_"^ALL PROCEDURE 99.38;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+4 IF $DATA(BGPG(1))
SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPTET($PIECE(BGPG(X),U))=""
SET BGPATET($PIECE(BGPG(X),U))=""
DIPPV ;
+1 KILL BGPG
SET %=P_"^ALL DX V03.5;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+2 IF $DATA(BGPG(1))
SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPDIP($PIECE(BGPG(X),U))=""
SET BGPADIP($PIECE(BGPG(X),U))=""
+3 KILL BGPG
SET %=P_"^ALL PROCEDURE 99.36;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+4 IF $DATA(BGPG(1))
SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPDIP($PIECE(BGPG(X),U))=""
SET BGPADIP($PIECE(BGPG(X),U))=""
PERPV ;
+1 KILL BGPG
SET %=P_"^ALL DX V03.6;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+2 IF $DATA(BGPG(1))
SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPPER($PIECE(BGPG(X),U))=""
SET BGPAPER($PIECE(BGPG(X),U))=""
+3 KILL BGPG
SET %=P_"^ALL PROCEDURE 99.37;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+4 IF $DATA(BGPG(1))
SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPPER($PIECE(BGPG(X),U))=""
SET BGPAPER($PIECE(BGPG(X),U))=""
TDPV ;
+1 KILL BGPG
SET %=P_"^ALL DX V06.5;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+2 IF $DATA(BGPG(1))
SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPTD($PIECE(BGPG(X),U))=""
SET BGPATD($PIECE(BGPG(X),U))=""
+3 SET BGPCODE=2
DO TEST
EVIDTET ;
+1 SET BGPEVTD=""
+2 ;K BGPG S %=P_"^LAST DX 037.;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
+3 ;I $D(BGPG(1)) S BGPEVTD=1
+4 ;I $$PLCODE^BGP1DU(P,"037.") S BGPEVTD=1
+5 DO RESETD
+6 IF BGPEVTD
IF BGPPER>3
IF BGPDIP>3
QUIT 4_U_"evid tet, 4 dip, 4 per"
+7 DO RESET
EVIDPER ;
+1 SET BGPEVPER=""
+2 ;K BGPG S %=P_"^LAST DX [BGP PERTUSSIS EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
+3 ;I $D(BGPG(1)) S BGPEVPER=1
+4 ;I $$PLTAX^BGP1DU(P,"BGP PERTUSSIS EVIDENCE") S BGPEVPER=1
+5 DO RESETD
+6 IF BGPEVPER
IF BGPDT>3
QUIT 4_U_"Evid per 4 dt"
+7 IF BGPEVPER
IF BGPTD>3
QUIT 4_U_"Evid per 4 td"
+8 IF BGPEVPER
IF BGPTET>3
IF BGPDIP>3
QUIT 4_U_"evid per 4 tet 4 dip"
EVIDDIP ;
+1 DO RESET
+2 SET BGPDIPEV=""
+3 ;K BGPG S %=P_"^LAST DX [BGP DIPHTHERIA EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
+4 ;I $D(BGPG(1)) S BGPEVDIP=1
+5 ;I $$PLTAX^BGP1DU(P,"BGP DIPHTHERIA EVIDENCE") S BGPEVDIP=1
+6 DO RESETD
+7 IF BGPEVDIP
IF BGPTD>3
IF BGPPER>3
QUIT 4_U_"Evid Dip 4 Tetanus 4 Per"
+8 IF BGPEVDIP
IF BGPTET>3
IF BGPPER>3
QUIT 4_U_"Evid Dip 4 Tetanus 4 Per"
+9 IF BGPEVDIP
IF BGPDT>3
IF BGPPER>3
QUIT 4_U_"evid dip 4 dt 4 per"
REF ;
+1 ;now go to refusals
+2 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+3 FOR BGPIMM=20,50,106,107,110,1,22,102,115,120,130,132
Begin DoDot:1
+4 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+5 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
IF $PIECE(^AUPNPREF(Y,0),U,7)="N"
SET BGPNMI=1
SET R=1
End DoDot:1
+6 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"ref")_" Dtap or DT"
+7 ;now check refusals in imm pkg
+8 FOR BGPIMM=20,50,106,107,110,1,22,102,115,120,130,132
IF R
QUIT
SET R=$$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+9 IF R
QUIT 3_U_" ref Dtap or DT"
+10 ;get dt and td refusals and count with 4 Pertussis
+11 SET (R,BGPNMI)=""
FOR BGPIMM=9,113
Begin DoDot:1
+12 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+13 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
IF $PIECE(^AUPNPREF(Y,0),U,7)="N"
SET BGPNMI=1
SET R=1
End DoDot:1
+14 IF R
IF BGPDTAP>2
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"ref")_" td has 3 DTap"
+15 IF R
IF BGPPER>3
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"ref")_" td has per"
+16 ;now check refusals in imm pkg
+17 SET R=""
+18 FOR BGPIMM=9,113
SET R=$$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+19 IF R
IF BGPDTAP>2
QUIT 3_U_" refused td has 3 DTap"
+20 IF R>3
IF BGPPER>3
QUIT 3_U_" refused td has per"
+21 SET (R,BGPNMI)=""
FOR BGPIMM=28
Begin DoDot:1
+22 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+23 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
IF $PIECE(^AUPNPREF(Y,0),U,7)="N"
SET BGPNMI=1
SET R=1
End DoDot:1
+24 IF R
IF BGPDTAP>0
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI dtap",1:"ref dtap")
+25 IF R
IF BGPPER>3
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI dtap",1:"ref dtap")
+26 ;now check refusals in imm pkg
+27 SET (R,BGPNMI)=""
FOR BGPIMM=28
SET R=$$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+28 IF R
IF BGPDTAP>0
QUIT 3_U_"ref dtap"
+29 IF R
IF BGPPER>3
QUIT 3_U_"ref dtap"
+30 ;PERTUSIS refusals and count with 4 dt OR TD or Tet & Dip
+31 SET (R,BGPNMI)=""
FOR BGPIMM=11
Begin DoDot:1
+32 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+33 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
IF $PIECE(^AUPNPREF(Y,0),U,7)="N"
SET BGPNMI=1
SET R=1
End DoDot:1
+34 IF R
IF (BGPDT>3!(BGPTD>3))
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI dtap",1:"ref dtap")
+35 IF R
IF BGPDIP>3
IF BGPTET>3
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI dtap",1:"ref dtap")
+36 ;now check refusals in imm pkg
+37 SET (R,BGPNMI)=""
FOR BGPIMM=11
SET R=$$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+38 IF R
IF (BGPDT>3!(BGPTD>3))
QUIT 3_U_"ref dtap"
+39 ;TETANUS refusals and count with 4 PERTUSSIS AND DIP
+40 SET (R,BGPNMI)=""
FOR BGPIMM=35,112
Begin DoDot:1
+41 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+42 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
IF $PIECE(^AUPNPREF(Y,0),U,7)="N"
SET BGPNMI=1
SET R=1
End DoDot:1
+43 IF R
IF BGPPER>3
IF BGPD>3
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI dtap",1:"ref dtap")
+44 ;now check refusals in imm pkg
+45 SET R=""
FOR BGPIMM=35,112
SET R=$$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+46 IF BGPPER>3
IF BGPD>3
IF R
QUIT 3_U_"ref dtap"
+47 ;now check for contraindication
+48 FOR BGPZ=20,80,106,107,110,120,130,132
SET X=$$ANCONT^BGP1D31(P,BGPZ,EDATE)
IF X]""
QUIT
+49 IF X]""
QUIT 4_U_"contra - DTaP"
+50 FOR BGPZ=1,22
SET X=$$ANCONT^BGP1D31(P,BGPZ,EDATE)
IF X]""
QUIT
+51 IF X]""
QUIT 4_U_"contra - DTP"
+52 FOR BGPZ=115
SET X=$$ANCONT^BGP1D31(P,BGPZ,EDATE)
IF X]""
QUIT
+53 IF X]""
QUIT 4_U_"contra - Tdap"
+54 FOR BGPZ=28
SET X=$$ANCONT^BGP1D31(P,BGPZ,EDATE)
IF X]""
QUIT
+55 IF X]""
QUIT 4_U_"contra - DT"
+56 FOR BGPZ=9,113
SET X=$$ANCONT^BGP1D31(P,BGPZ,EDATE)
IF X]""
QUIT
+57 IF X]""
QUIT 4_U_"contra - td"
+58 FOR BGPZ=35,112
SET X=$$ANCONT^BGP1D31(P,BGPZ,EDATE)
IF X]""
QUIT
+59 IF X]""
QUIT 4_U_"contra - tetanus"
+60 FOR BGPZ=11
SET X=$$ANCONT^BGP1D31(P,BGPZ,EDATE)
IF X]""
QUIT
+61 IF X]""
QUIT 4_U_"contra - pertussis"
+62 QUIT ""
TEST ;
+1 ;NOW TEST FOR ALL POSSIBLE COMBINATIONS OF HAVING MET INDICATOR
+2 ;1 DTAP AND 3 EACH TET,PER,DIP
+3 ;kill off any dip or tet on same day as a dtap
+4 SET BGPVAL=""
+5 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPDIP(X))
IF X'=+X
QUIT
IF $DATA(BGPDTAP(X))
KILL BGPDIP(X)
+6 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPDIP(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+7 IF C=1
SET Y=X
QUIT
+8 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPDIP(X)
QUIT
+9 SET Y=X
End DoDot:1
+10 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPTET(X))
IF X'=+X
QUIT
IF $DATA(BGPDTAP(X))
KILL BGPTET(X)
+11 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPTET(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+12 IF C=1
SET Y=X
QUIT
+13 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPTET(X)
QUIT
+14 SET Y=X
End DoDot:1
+15 SET BGPDIP=0
SET X=0
FOR
SET X=$ORDER(BGPDIP(X))
IF X'=+X
QUIT
SET BGPDIP=BGPDIP+1
+16 SET BGPTET=0
SET X=0
FOR
SET X=$ORDER(BGPTET(X))
IF X'=+X
QUIT
SET BGPTET=BGPTET+1
+17 IF BGPTET>2
IF BGPDIP>1
IF $ORDER(BGPDTAP(0))
SET BGPBAL=BGPCODE_U_"Dtap & 3 TET & 3 DIP"
QUIT
DTPER ;is there 4 DT and 4 pertussis?
+1 DO RESET
+2 ;delete ones not 10 days apart
+3 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPDT(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+4 IF C=1
SET Y=X
QUIT
+5 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPDT(X)
QUIT
+6 SET Y=X
End DoDot:1
+7 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPPER(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+8 IF C=1
SET Y=X
QUIT
+9 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPPER(X)
QUIT
+10 SET Y=X
End DoDot:1
+11 SET BGPDT=0
SET X=0
FOR
SET X=$ORDER(BGPDT(X))
IF X'=+X
QUIT
SET BGPDT=BGPDT+1
+12 SET BGPPER=0
SET X=0
FOR
SET X=$ORDER(BGPPER(X))
IF X'=+X
QUIT
SET BGPPER=BGPPER+1
+13 IF BGPPER>3
IF BGPDT>3
SET BGPVAL=BGPCODE_U_"3 DT & 3 PER"
QUIT
TDPER ;
+1 DO RESET
+2 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPTD(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+3 IF C=1
SET Y=X
QUIT
+4 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPTD(X)
QUIT
+5 SET Y=X
End DoDot:1
+6 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPPER(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+7 IF C=1
SET Y=X
QUIT
+8 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPPER(X)
QUIT
+9 SET Y=X
End DoDot:1
+10 SET BGPTD=0
SET X=0
FOR
SET X=$ORDER(BGPTD(X))
IF X'=+X
QUIT
SET BGPTD=BGPTD+1
+11 SET BGPPER=0
SET X=0
FOR
SET X=$ORDER(BGPPER(X))
IF X'=+X
QUIT
SET BGPPER=BGPPER+1
+12 IF BGPPER>3
IF BGPTD>3
SET BGPVAL=BGPCODE_U_"3 TD & 3 PER"
QUIT
+13 IF BGPTD>2
IF $ORDER(BGPDTAP(0))
SET BGPVAL=BGPCODE_U_"Dtap & 3 Td"
QUIT
DIPTETPE ;
+1 DO RESET
+2 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPPER(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+3 IF C=1
SET Y=X
QUIT
+4 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPPER(X)
QUIT
+5 SET Y=X
End DoDot:1
+6 SET BGPPER=0
SET X=0
FOR
SET X=$ORDER(BGPPER(X))
IF X'=+X
QUIT
SET BGPPER=BGPPER+1
+7 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPDIP(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+8 IF C=1
SET Y=X
QUIT
+9 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPDIP(X)
QUIT
+10 SET Y=X
End DoDot:1
+11 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BGPTET(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+12 IF C=1
SET Y=X
QUIT
+13 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPTET(X)
QUIT
+14 SET Y=X
End DoDot:1
+15 SET BGPDIP=0
SET X=0
FOR
SET X=$ORDER(BGPDIP(X))
IF X'=+X
QUIT
SET BGPDIP=BGPDIP+1
+16 SET BGPTET=0
SET X=0
FOR
SET X=$ORDER(BGPTET(X))
IF X'=+X
QUIT
SET BGPTET=BGPTET+1
+17 IF BGPPER>3
IF BGPDIP>3
IF BGPTET>3
SET BGPVAL=BGPCODE_U_"3 EACH DIP,TET,PER"
QUIT
+18 QUIT
90700 ;;
90721 ;;
90723 ;;
90701 ;;
90711 ;;
90720 ;;
90702 ;;
90718 ;;
90719 ;;
90703 ;;
