- BGP7D34 ; IHS/CMI/LAB - measure C ;
- ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
- ;
- 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)!(Y=90697) 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)!(Y=90697) 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^BGP7D32(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)!(Y=90697) 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^BGP7D32(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^BGP7D32(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^BGP7D32(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^BGP7D32(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^BGP7D341
- 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^BGP7UTL1(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^BGP7UTL1(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^BGP7UTL1(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^BGP7UTL1(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^BGP7D341
- 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^BGP7D32(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^BGP7UTL1(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^BGP7D32(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^BGP7D32(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^BGP7D32(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^BGP7D32(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^BGP7D31(P,BGPZ,EDATE) Q:X]""
- I X]"" Q 4_U_"Contra DTaP"
- F BGPZ=1,22 S X=$$ANCONT^BGP7D31(P,BGPZ,EDATE) Q:X]""
- I X]"" Q 4_U_"Contra DTP"
- F BGPZ=115 S X=$$ANCONT^BGP7D31(P,BGPZ,EDATE) Q:X]""
- I X]"" Q 4_U_"Contra Tdap"
- F BGPZ=28 S X=$$ANCONT^BGP7D31(P,BGPZ,EDATE) Q:X]""
- I X]"" Q 4_U_"Contra DT"
- F BGPZ=9,113,138,139 S X=$$ANCONT^BGP7D31(P,BGPZ,EDATE) Q:X]""
- I X]"" Q 4_U_"Contra td"
- F BGPZ=35,112 S X=$$ANCONT^BGP7D31(P,BGPZ,EDATE) Q:X]""
- I X]"" Q 4_U_"Contra tetanus"
- F BGPZ=11 S X=$$ANCONT^BGP7D31(P,BGPZ,EDATE) Q:X]""
- I X]"" Q 4_U_"Contra pertussis"
- Q ""
- TEST ;
- D TEST^BGP7D341
- Q
- 90700 ;;
- 90721 ;;
- 90723 ;;
- 90701 ;;
- 90711 ;;
- 90720 ;;
- 90702 ;;
- 90718 ;;
- 90719 ;;
- 90703 ;;
- BGP7D34 ; IHS/CMI/LAB - measure C ;
- +1 ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
- +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)!(Y=90697)
- 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)!(Y=90697)
- 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^BGP7D32(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)!(Y=90697)
- 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^BGP7D32(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^BGP7D32(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^BGP7D32(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^BGP7D32(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^BGP7D341
- +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^BGP7UTL1(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^BGP7UTL1(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^BGP7UTL1(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^BGP7UTL1(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^BGP7D341
- 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^BGP7D32(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^BGP7UTL1(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^BGP7D32(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^BGP7D32(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^BGP7D32(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^BGP7D32(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^BGP7D31(P,BGPZ,EDATE)
- IF X]""
- QUIT
- +66 IF X]""
- QUIT 4_U_"Contra DTaP"
- +67 FOR BGPZ=1,22
- SET X=$$ANCONT^BGP7D31(P,BGPZ,EDATE)
- IF X]""
- QUIT
- +68 IF X]""
- QUIT 4_U_"Contra DTP"
- +69 FOR BGPZ=115
- SET X=$$ANCONT^BGP7D31(P,BGPZ,EDATE)
- IF X]""
- QUIT
- +70 IF X]""
- QUIT 4_U_"Contra Tdap"
- +71 FOR BGPZ=28
- SET X=$$ANCONT^BGP7D31(P,BGPZ,EDATE)
- IF X]""
- QUIT
- +72 IF X]""
- QUIT 4_U_"Contra DT"
- +73 FOR BGPZ=9,113,138,139
- SET X=$$ANCONT^BGP7D31(P,BGPZ,EDATE)
- IF X]""
- QUIT
- +74 IF X]""
- QUIT 4_U_"Contra td"
- +75 FOR BGPZ=35,112
- SET X=$$ANCONT^BGP7D31(P,BGPZ,EDATE)
- IF X]""
- QUIT
- +76 IF X]""
- QUIT 4_U_"Contra tetanus"
- +77 FOR BGPZ=11
- SET X=$$ANCONT^BGP7D31(P,BGPZ,EDATE)
- IF X]""
- QUIT
- +78 IF X]""
- QUIT 4_U_"Contra pertussis"
- +79 QUIT ""
- TEST ;
- +1 DO TEST^BGP7D341
- +2 QUIT
- 90700 ;;
- 90721 ;;
- 90723 ;;
- 90701 ;;
- 90711 ;;
- 90720 ;;
- 90702 ;;
- 90718 ;;
- 90719 ;;
- 90703 ;;