BGP6D34 ; IHS/CMI/LAB - measure C ;
;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
;
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 ;EP - 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^146"
D GETIMMS^BGP6D32(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^BGP6D32(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^BGP6D32(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^BGP6D32(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^138^139"
K BGPX D GETIMMS^BGP6D32(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^BGP6D341
I BGPVAL]"" Q BGPVAL
;PV
DTPPV ;
D RESET
K BGPG S %=P_"^ALL DX [BGP DTP IZ DXS;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 ;D SETPRC^BGP6UTL1(P,$$DOB^AUPNPAT(P),EDATE,"BGP DTP IZ PROCS",.BGPG)
;I $D(BGPG(1)) S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPDTAP($P(BGPG(1),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 [BGP TD IZ DXS;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 [BGP TETANUS TOXOID IZ DXS;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 ;D SETPRC^BGP6UTL1(P,$$DOB^AUPNPAT(P),EDATE,"BGP TETANUS TOXOID IZ PROCS",.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 [BGP DIPHTHERIA IZ DXS;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 ;D SETPRC^BGP6UTL1(P,$$DOB^AUPNPAT(P),EDATE,"BGP DIPHTHERIA IZ PROCS",.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 [BGP PERTUSSIS IZ DXS;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 ;D SETPRC^BGP6UTL1(P,$$DOB^AUPNPAT(P),EDATE,"BGP PERTUSSIS IZ PROCS",.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 [BGP TD IZ DXS;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^BGP6D341
EVIDTET ;
S BGPEVTD=""
D RESETD
I BGPEVTD,BGPPER>3,BGPDIP>3 Q 4_U_"Evid tet, 4 dip, 4 per"
D RESET
EVIDPER ;
S BGPEVPER=""
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=""
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,146 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) I $P(^AUPNPREF(Y,0),U,7)="N" S BGPNMI=1 S R=1
I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" DTaP/DTP"
;now check Refusals in imm pkg
;F BGPIMM=20,50,106,107,110,1,22,102,115,120,130,132,146 Q:R S R=$$IMMREF^BGP6D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
;I R Q 3_U_" Ref Dtap or DT"
S BGPRBEG=$$FMADD^XLFDT(ED,-365)
S R=$$CPTREFT^BGP6UTL1(P,$$DOB^AUPNPAT(P),EDATE,$O(^ATXAX("B","BGP CPT DTAP/DTP/TDAP",0)),"N")
I R,$P(R,U,3)="N" S BGPNMI=1 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" DTaP/DTP"
;get dt and td Refusals and count with 4 Pertussis
S (R,BGPNMI)="" F BGPIMM=9,113,138,139 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) I $P(^AUPNPREF(Y,0),U,7)="N" S 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"
S (R,BGPNMI)="" F BGPIMM=90714 D
.S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I
.S X=0 F S X=$O(^AUPNPREF("AA",P,81,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,81,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) I $P(^AUPNPREF(Y,0),U,7)="N" S 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^BGP6D32(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) I $P(^AUPNPREF(Y,0),U,7)="N" S 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")
S (R,BGPNMI)="" F BGPIMM=90702 D
.S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I
.S X=0 F S X=$O(^AUPNPREF("AA",P,81,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,81,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) I $P(^AUPNPREF(Y,0),U,7)="N" S 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^BGP6D32(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) I $P(^AUPNPREF(Y,0),U,7)="N" S 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^BGP6D32(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) I $P(^AUPNPREF(Y,0),U,7)="N" S 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")
S (R,BGPNMI)="" F BGPIMM=90703 D
.S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I
.S X=0 F S X=$O(^AUPNPREF("AA",P,81,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,81,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) I $P(^AUPNPREF(Y,0),U,7)="N" S 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^BGP6D32(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,50,106,107,110,120,130,132,146 S X=$$ANCONT^BGP6D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"Contra DTaP"
F BGPZ=1,22 S X=$$ANCONT^BGP6D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"Contra DTP"
F BGPZ=115 S X=$$ANCONT^BGP6D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"Contra Tdap"
F BGPZ=28 S X=$$ANCONT^BGP6D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"Contra DT"
F BGPZ=9,113,138,139 S X=$$ANCONT^BGP6D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"Contra td"
F BGPZ=35,112 S X=$$ANCONT^BGP6D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"Contra tetanus"
F BGPZ=11 S X=$$ANCONT^BGP6D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"Contra pertussis"
Q ""
TEST ;
D TEST^BGP6D341
Q
90700 ;;
90721 ;;
90723 ;;
90701 ;;
90711 ;;
90720 ;;
90702 ;;
90718 ;;
90719 ;;
90703 ;;
BGP6D34 ; IHS/CMI/LAB - measure C ;
+1 ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
+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 ;EP - 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^146"
+25 DO GETIMMS^BGP6D32(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^BGP6D32(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^BGP6D32(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^BGP6D32(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^138^139"
+3 KILL BGPX
DO GETIMMS^BGP6D32(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^BGP6D341
+8 IF BGPVAL]""
QUIT BGPVAL
+9 ;PV
DTPPV ;
+1 DO RESET
+2 KILL BGPG
SET %=P_"^ALL DX [BGP DTP IZ DXS;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 ;D SETPRC^BGP6UTL1(P,$$DOB^AUPNPAT(P),EDATE,"BGP DTP IZ PROCS",.BGPG)
KILL BGPG
+5 ;I $D(BGPG(1)) S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPDTAP($P(BGPG(1),U))=""
+6 ;count to see if there are 4
DO CNTDTAP
+7 ; had 4 dtap/cpt/pv/proc
IF BGPDTAP>3
QUIT 2_U_"4 DTaP/DTP"
DTPV ;
+1 KILL BGPG
SET %=P_"^ALL DX [BGP TD IZ DXS;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 [BGP TETANUS TOXOID IZ DXS;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 ;D SETPRC^BGP6UTL1(P,$$DOB^AUPNPAT(P),EDATE,"BGP TETANUS TOXOID IZ PROCS",.BGPG)
KILL BGPG
+4 ;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 ;
+1 KILL BGPG
SET %=P_"^ALL DX [BGP DIPHTHERIA IZ DXS;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 ;D SETPRC^BGP6UTL1(P,$$DOB^AUPNPAT(P),EDATE,"BGP DIPHTHERIA IZ PROCS",.BGPG)
KILL BGPG
+4 ;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 ;
+1 KILL BGPG
SET %=P_"^ALL DX [BGP PERTUSSIS IZ DXS;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 ;D SETPRC^BGP6UTL1(P,$$DOB^AUPNPAT(P),EDATE,"BGP PERTUSSIS IZ PROCS",.BGPG)
KILL BGPG
+4 ;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 ;
+1 KILL BGPG
SET %=P_"^ALL DX [BGP TD IZ DXS;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^BGP6D341
EVIDTET ;
+1 SET BGPEVTD=""
+2 DO RESETD
+3 IF BGPEVTD
IF BGPPER>3
IF BGPDIP>3
QUIT 4_U_"Evid tet, 4 dip, 4 per"
+4 DO RESET
EVIDPER ;
+1 SET BGPEVPER=""
+2 DO RESETD
+3 IF BGPEVPER
IF BGPDT>3
QUIT 4_U_"Evid per 4 dt"
+4 IF BGPEVPER
IF BGPTD>3
QUIT 4_U_"Evid per 4 td"
+5 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 DO RESETD
+4 IF BGPEVDIP
IF BGPTD>3
IF BGPPER>3
QUIT 4_U_"Evid Dip 4 Tetanus 4 Per"
+5 IF BGPEVDIP
IF BGPTET>3
IF BGPPER>3
QUIT 4_U_"Evid Dip 4 Tetanus 4 Per"
+6 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,146
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/DTP"
+7 ;now check Refusals in imm pkg
+8 ;F BGPIMM=20,50,106,107,110,1,22,102,115,120,130,132,146 Q:R S R=$$IMMREF^BGP6D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+9 ;I R Q 3_U_" Ref Dtap or DT"
+10 SET BGPRBEG=$$FMADD^XLFDT(ED,-365)
+11 SET R=$$CPTREFT^BGP6UTL1(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^ATXAX("B","BGP CPT DTAP/DTP/TDAP",0)),"N")
+12 IF R
IF $PIECE(R,U,3)="N"
SET BGPNMI=1
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" DTaP/DTP"
+13 ;get dt and td Refusals and count with 4 Pertussis
+14 SET (R,BGPNMI)=""
FOR BGPIMM=9,113,138,139
Begin DoDot:1
+15 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+16 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
+17 IF R
IF BGPDTAP>2
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" td has 3 DTaP"
+18 IF R
IF BGPPER>3
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" td has per"
+19 SET (R,BGPNMI)=""
FOR BGPIMM=90714
Begin DoDot:1
+20 SET I=+$$CODEN^ICPTCOD(BGPIMM)
IF 'I
QUIT
+21 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,81,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,81,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
+22 IF R
IF BGPDTAP>2
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" td has 3 DTaP"
+23 IF R
IF BGPPER>3
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" td has per"
+24 ;now check Refusals in imm pkg
+25 SET R=""
+26 ;F BGPIMM=9,113 S R=$$IMMREF^BGP6D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+27 ;I R,BGPDTAP>2 Q 3_U_" Refused td has 3 DTaP"
+28 ;I R>3,BGPPER>3 Q 3_U_" Refused td has per"
+29 SET (R,BGPNMI)=""
FOR BGPIMM=28
Begin DoDot:1
+30 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+31 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
+32 IF R
IF BGPDTAP>0
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI dtap",1:"Ref dtap")
+33 IF R
IF BGPPER>3
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI dtap",1:"Ref dtap")
+34 SET (R,BGPNMI)=""
FOR BGPIMM=90702
Begin DoDot:1
+35 SET I=+$$CODEN^ICPTCOD(BGPIMM)
IF 'I
QUIT
+36 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,81,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,81,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
+37 IF R
IF BGPDTAP>0
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI dtap",1:"Ref dtap")
+38 IF R
IF BGPPER>3
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI dtap",1:"Ref dtap")
+39 ;now check Refusals in imm pkg
+40 ;F BGPIMM=28 S R=$$IMMREF^BGP6D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
SET (R,BGPNMI)=""
+41 ;I R,BGPDTAP>0 Q 3_U_"Ref dtap"
+42 ;I R,BGPPER>3 Q 3_U_"Ref dtap"
+43 ;PERTUSIS Refusals and count with 4 dt OR TD or Tet & Dip
+44 SET (R,BGPNMI)=""
FOR BGPIMM=11
Begin DoDot:1
+45 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+46 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
+47 IF R
IF (BGPDT>3!(BGPTD>3))
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI dtap",1:"Ref dtap")
+48 IF R
IF BGPDIP>3
IF BGPTET>3
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI dtap",1:"Ref dtap")
+49 ;now check Refusals in imm pkg
+50 ;F BGPIMM=11 S R=$$IMMREF^BGP6D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
SET (R,BGPNMI)=""
+51 ;I R,(BGPDT>3!(BGPTD>3)) Q 3_U_"Ref dtap"
+52 ;TETANUS Refusals and count with 4 PERTUSSIS AND DIP
+53 SET (R,BGPNMI)=""
FOR BGPIMM=35,112
Begin DoDot:1
+54 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+55 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
+56 IF R
IF BGPPER>3
IF BGPD>3
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI dtap",1:"Ref dtap")
+57 SET (R,BGPNMI)=""
FOR BGPIMM=90703
Begin DoDot:1
+58 SET I=+$$CODEN^ICPTCOD(BGPIMM)
IF 'I
QUIT
+59 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,81,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,81,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
+60 IF R
IF BGPPER>3
IF BGPD>3
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI dtap",1:"Ref dtap")
+61 ;now check Refusals in imm pkg
+62 ;F BGPIMM=35,112 S R=$$IMMREF^BGP6D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
SET R=""
+63 ;I BGPPER>3,BGPD>3,R Q 3_U_"Ref dtap"
+64 ;now check for Contraindication
+65 FOR BGPZ=20,50,106,107,110,120,130,132,146
SET X=$$ANCONT^BGP6D31(P,BGPZ,EDATE)
IF X]""
QUIT
+66 IF X]""
QUIT 4_U_"Contra DTaP"
+67 FOR BGPZ=1,22
SET X=$$ANCONT^BGP6D31(P,BGPZ,EDATE)
IF X]""
QUIT
+68 IF X]""
QUIT 4_U_"Contra DTP"
+69 FOR BGPZ=115
SET X=$$ANCONT^BGP6D31(P,BGPZ,EDATE)
IF X]""
QUIT
+70 IF X]""
QUIT 4_U_"Contra Tdap"
+71 FOR BGPZ=28
SET X=$$ANCONT^BGP6D31(P,BGPZ,EDATE)
IF X]""
QUIT
+72 IF X]""
QUIT 4_U_"Contra DT"
+73 FOR BGPZ=9,113,138,139
SET X=$$ANCONT^BGP6D31(P,BGPZ,EDATE)
IF X]""
QUIT
+74 IF X]""
QUIT 4_U_"Contra td"
+75 FOR BGPZ=35,112
SET X=$$ANCONT^BGP6D31(P,BGPZ,EDATE)
IF X]""
QUIT
+76 IF X]""
QUIT 4_U_"Contra tetanus"
+77 FOR BGPZ=11
SET X=$$ANCONT^BGP6D31(P,BGPZ,EDATE)
IF X]""
QUIT
+78 IF X]""
QUIT 4_U_"Contra pertussis"
+79 QUIT ""
TEST ;
+1 DO TEST^BGP6D341
+2 QUIT
90700 ;;
90721 ;;
90723 ;;
90701 ;;
90711 ;;
90720 ;;
90702 ;;
90718 ;;
90719 ;;
90703 ;;
