Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP7D34

BGP7D34.m

Go to the documentation of this file.
  1. BGP7D34 ; IHS/CMI/LAB - measure C ;
  1. ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
  1. ;
  1. CNTDTAP ;
  1. S (X,Y)="",C=0 F S X=$O(BGPDTAP(X)) Q:X'=+X S C=C+1 D
  1. .I C=1 S Y=X Q
  1. .I $$FMDIFF^XLFDT(X,Y)<11 K BGPDTAP(X) Q
  1. .S Y=X
  1. ;count
  1. S BGPDTAP=0,X=0 F S X=$O(BGPDTAP(X)) Q:X'=+X S BGPDTAP=BGPDTAP+1
  1. Q
  1. RESET ;EP - RESET WORKING ARRAYS
  1. K BGPDT M BGPDT=BGPADT
  1. K BGPDIP M BGPDIP=BGPADIP
  1. K BGPTET M BGPTET=BGPATET
  1. K BGPPER M BGPPER=BGPAPER
  1. K BGPTD M BGPTD=BGPATD
  1. Q
  1. RESETD ;RESET DUP
  1. S (X,Y)="",C=0 F S X=$O(BGPDT(X)) Q:X'=+X S C=C+1 D
  1. .I C=1 S Y=X Q
  1. .I $$FMDIFF^XLFDT(X,Y)<11 K BGPDT(X) Q
  1. .S Y=X
  1. S (X,Y)="",C=0 F S X=$O(BGPDIP(X)) Q:X'=+X S C=C+1 D
  1. .I C=1 S Y=X Q
  1. .I $$FMDIFF^XLFDT(X,Y)<11 K BGPDIP(X) Q
  1. .S Y=X
  1. S (X,Y)="",C=0 F S X=$O(BGPTET(X)) Q:X'=+X S C=C+1 D
  1. .I C=1 S Y=X Q
  1. .I $$FMDIFF^XLFDT(X,Y)<11 K BGPTET(X) Q
  1. .S Y=X
  1. S (X,Y)="",C=0 F S X=$O(BGPTD(X)) Q:X'=+X S C=C+1 D
  1. .I C=1 S Y=X Q
  1. .I $$FMDIFF^XLFDT(X,Y)<11 K BGPTD(X) Q
  1. .S Y=X
  1. S (X,Y)="",C=0 F S X=$O(BGPPER(X)) Q:X'=+X S C=C+1 D
  1. .I C=1 S Y=X Q
  1. .I $$FMDIFF^XLFDT(X,Y)<11 K BGPPER(X) Q
  1. .S Y=X
  1. S BGPDT=0,X=0 F S X=$O(BGPDT(X)) Q:X'=+X S BGPDT=BGPDT+1
  1. S BGPTD=0,X=0 F S X=$O(BGPTD(X)) Q:X'=+X S BGPTD=BGPTD+1
  1. S BGPDIP=0,X=0 F S X=$O(BGPDIP(X)) Q:X'=+X S BGPDIP=BGPDIP+1
  1. S BGPTET=0,X=0 F S X=$O(BGPTET(X)) Q:X'=+X S BGPTET=BGPTET+1
  1. S BGPPER=0,X=0 F S X=$O(BGPPER(X)) Q:X'=+X S BGPPER=BGPPER+1
  1. Q
  1. DTAP(P,EDATE) ;EP
  1. K ^TMP($J,"CPT")
  1. K BGPC,BGPG,BGPX
  1. ;first gather up all cpt codes that relate in any way to dtap
  1. S ED=9999999-EDATE-1,BD=9999999-$$DOB^AUPNPAT(P),G=0
  1. F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD) D
  1. .S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V D
  1. ..Q:'$D(^AUPNVSIT(V,0))
  1. ..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
  1. ...Q:'$D(^AUPNVCPT(X,0))
  1. ...S Y=$P(^AUPNVCPT(X,0),U)
  1. ...Q:Y=""
  1. ...S Y=$P($$CPT^ICPTCOD(Y),U,2)
  1. ...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)=""
  1. ..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
  1. ...Q:'$D(^AUPNVTC(X,0))
  1. ...S Y=$P(^AUPNVTC(X,0),U,7)
  1. ...Q:Y=""
  1. ...S Y=$P($$CPT^ICPTCOD(Y),U,2)
  1. ...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)=""
  1. ;now gather up all DTAP immunizations, cpts
  1. K BGPDTAP
  1. S BGPEVTD=0,BGPEVDIP=0,BGPEVPER=0
  1. ;get all imms
  1. S C="20^50^106^107^110^1^22^102^115^120^130^132^146"
  1. D GETIMMS^BGP7D32(P,EDATE,C,.BGPX)
  1. ;go through and set into DTAP if 10 days apart
  1. S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPDTAP(X)=""
  1. D CNTDTAP ;if there are 4
  1. I BGPDTAP>3 Q 1_U_"4 DTaP/DTP" ;had 4 dtap by cvx so code is 1
  1. ;now get cpts for dtap or dtp
  1. 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
  1. .I Y=90700!(Y=90721)!(Y=90723)!(Y=90701)!(Y=90711)!(Y=90720)!(Y=90698)!(Y=90715)!(Y=90696)!(Y=90697) S BGPDTAP(D)=""
  1. D CNTDTAP ;count to see if there are 4
  1. I BGPDTAP>3 Q 1_U_"4 DTaP/DTP" ;had 4 dtap cvx or cpts so code is 1
  1. DT ;add in dt's
  1. K BGPDT,BGPADT
  1. S C="28"
  1. K BGPX D GETIMMS^BGP7D32(P,EDATE,C,.BGPX)
  1. S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPDT(X)="",BGPADT(X)=""
  1. ;add in dt cpts
  1. 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
  1. .I Y=90702 S BGPDT(D)="",BGPADT(D)=""
  1. ;are there 3 dt and 1 dtap by cvx and/or cpt?
  1. DT1 ;
  1. ;kill off any that are on the same day as the dtaps
  1. S (X,Y)="",C=0 F S X=$O(BGPDT(X)) Q:X'=+X I $D(BGPDTAP(X)) K BGPDT(X)
  1. S (X,Y)="",C=0 F S X=$O(BGPDT(X)) Q:X'=+X S C=C+1 D
  1. .I C=1 S Y=X Q
  1. .I $$FMDIFF^XLFDT(X,Y)<11 K BGPDT(X) Q
  1. .S Y=X
  1. S BGPDT=0,X=0 F S X=$O(BGPDT(X)) Q:X'=+X S BGPDT=BGPDT+1
  1. I BGPDT>2,$O(BGPDTAP(0)) Q 1_U_"Dtap and 3 DTs"
  1. TETCVX ;
  1. K BGPTET,BGPATET
  1. S C="35^112"
  1. K BGPX D GETIMMS^BGP7D32(P,EDATE,C,.BGPX)
  1. S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPTET(X)="",BGPATET(X)=""
  1. 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
  1. .I Y=90703 S BGPTET(D)="",BGPATET(D)=""
  1. DIPCVX ;
  1. K BGPDIP,BGPADIP
  1. 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
  1. .I Y=90719 S BGPDIP(D)="",BGPADIP(D)=""
  1. PERCVX ;
  1. K BGPPER,BGPAPER
  1. S C="11"
  1. K BGPX D GETIMMS^BGP7D32(P,EDATE,C,.BGPX)
  1. S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPPER(X)="",BGPAPER(X)=""
  1. TDCVX ;
  1. K BGPTD,BGPATD
  1. S C="9^113^138^139"
  1. K BGPX D GETIMMS^BGP7D32(P,EDATE,C,.BGPX)
  1. S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPTD(X)="",BGPATD(X)=""
  1. 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
  1. .I Y=90718!(Y=90714) S BGPTD(D)="",BGPATD(D)=""
  1. S BGPCODE=1 D TEST^BGP7D341
  1. I BGPVAL]"" Q BGPVAL
  1. ;PV
  1. DTPPV ;
  1. D RESET
  1. K BGPG S %=P_"^ALL DX [BGP DTP IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1. I $D(BGPG(1)) S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPDTAP($P(BGPG(X),U))=""
  1. K BGPG ;D SETPRC^BGP7UTL1(P,$$DOB^AUPNPAT(P),EDATE,"BGP DTP IZ PROCS",.BGPG)
  1. ;I $D(BGPG(1)) S X=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPDTAP($P(BGPG(1),U))=""
  1. D CNTDTAP ;count to see if there are 4
  1. I BGPDTAP>3 Q 2_U_"4 DTaP/DTP" ; had 4 dtap/cpt/pv/proc
  1. DTPV ;
  1. K BGPG S %=P_"^ALL DX [BGP TD IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1. 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))=""
  1. S (X,Y)="",C=0 F S X=$O(BGPDT(X)) Q:X'=+X I $D(BGPDTAP(X)) K BGPDT(X)
  1. D RESETD
  1. I BGPDT>2,$O(BGPDTAP(0)) Q 2_U_"Dtap and 3 DTs"
  1. D RESET
  1. TETPV ;
  1. K BGPG S %=P_"^ALL DX [BGP TETANUS TOXOID IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1. 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))=""
  1. K BGPG ;D SETPRC^BGP7UTL1(P,$$DOB^AUPNPAT(P),EDATE,"BGP TETANUS TOXOID IZ PROCS",.BGPG)
  1. ;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))=""
  1. DIPPV ;
  1. K BGPG S %=P_"^ALL DX [BGP DIPHTHERIA IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1. 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))=""
  1. K BGPG ;D SETPRC^BGP7UTL1(P,$$DOB^AUPNPAT(P),EDATE,"BGP DIPHTHERIA IZ PROCS",.BGPG)
  1. ;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))=""
  1. PERPV ;
  1. K BGPG S %=P_"^ALL DX [BGP PERTUSSIS IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1. 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))=""
  1. K BGPG ;D SETPRC^BGP7UTL1(P,$$DOB^AUPNPAT(P),EDATE,"BGP PERTUSSIS IZ PROCS",.BGPG)
  1. ;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))=""
  1. TDPV ;
  1. K BGPG S %=P_"^ALL DX [BGP TD IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1. 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))=""
  1. S BGPCODE=2 D TEST^BGP7D341
  1. EVIDTET ;
  1. S BGPEVTD=""
  1. D RESETD
  1. I BGPEVTD,BGPPER>3,BGPDIP>3 Q 4_U_"Evid tet, 4 dip, 4 per"
  1. D RESET
  1. EVIDPER ;
  1. S BGPEVPER=""
  1. D RESETD
  1. I BGPEVPER,BGPDT>3 Q 4_U_"Evid per 4 dt"
  1. I BGPEVPER,BGPTD>3 Q 4_U_"Evid per 4 td"
  1. I BGPEVPER,BGPTET>3,BGPDIP>3 Q 4_U_"Evid per 4 tet 4 dip"
  1. EVIDDIP ;
  1. D RESET
  1. S BGPDIPEV=""
  1. D RESETD
  1. I BGPEVDIP,BGPTD>3,BGPPER>3 Q 4_U_"Evid Dip 4 Tetanus 4 Per"
  1. I BGPEVDIP,BGPTET>3,BGPPER>3 Q 4_U_"Evid Dip 4 Tetanus 4 Per"
  1. I BGPEVDIP,BGPDT>3,BGPPER>3 Q 4_U_"Evid dip 4 dt 4 per"
  1. REF ;
  1. ;now go to Refusals
  1. S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
  1. F BGPIMM=20,50,106,107,110,1,22,102,115,120,130,132,146 D
  1. .S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
  1. .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
  1. I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" DTaP/DTP"
  1. ;now check Refusals in imm pkg
  1. ;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
  1. ;I R Q 3_U_" Ref Dtap or DT"
  1. S BGPRBEG=$$FMADD^XLFDT(ED,-365)
  1. S R=$$CPTREFT^BGP7UTL1(P,$$DOB^AUPNPAT(P),EDATE,$O(^ATXAX("B","BGP CPT DTAP/DTP/TDAP",0)),"N")
  1. I R,$P(R,U,3)="N" S BGPNMI=1 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" DTaP/DTP"
  1. ;get dt and td Refusals and count with 4 Pertussis
  1. S (R,BGPNMI)="" F BGPIMM=9,113,138,139 D
  1. .S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
  1. .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
  1. I R,BGPDTAP>2 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" td has 3 DTaP"
  1. I R,BGPPER>3 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" td has per"
  1. S (R,BGPNMI)="" F BGPIMM=90714 D
  1. .S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I
  1. .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
  1. I R,BGPDTAP>2 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" td has 3 DTaP"
  1. I R,BGPPER>3 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" td has per"
  1. ;now check Refusals in imm pkg
  1. S R=""
  1. ;F BGPIMM=9,113 S R=$$IMMREF^BGP7D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
  1. ;I R,BGPDTAP>2 Q 3_U_" Refused td has 3 DTaP"
  1. ;I R>3,BGPPER>3 Q 3_U_" Refused td has per"
  1. S (R,BGPNMI)="" F BGPIMM=28 D
  1. .S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
  1. .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
  1. I R,BGPDTAP>0 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI dtap",1:"Ref dtap")
  1. I R,BGPPER>3 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI dtap",1:"Ref dtap")
  1. S (R,BGPNMI)="" F BGPIMM=90702 D
  1. .S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I
  1. .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
  1. I R,BGPDTAP>0 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI dtap",1:"Ref dtap")
  1. I R,BGPPER>3 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI dtap",1:"Ref dtap")
  1. ;now check Refusals in imm pkg
  1. S (R,BGPNMI)="" ;F BGPIMM=28 S R=$$IMMREF^BGP7D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
  1. ;I R,BGPDTAP>0 Q 3_U_"Ref dtap"
  1. ;I R,BGPPER>3 Q 3_U_"Ref dtap"
  1. ;PERTUSIS Refusals and count with 4 dt OR TD or Tet & Dip
  1. S (R,BGPNMI)="" F BGPIMM=11 D
  1. .S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
  1. .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
  1. I R,(BGPDT>3!(BGPTD>3)) Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI dtap",1:"Ref dtap")
  1. I R,BGPDIP>3,BGPTET>3 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI dtap",1:"Ref dtap")
  1. ;now check Refusals in imm pkg
  1. S (R,BGPNMI)="" ;F BGPIMM=11 S R=$$IMMREF^BGP7D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
  1. ;I R,(BGPDT>3!(BGPTD>3)) Q 3_U_"Ref dtap"
  1. ;TETANUS Refusals and count with 4 PERTUSSIS AND DIP
  1. S (R,BGPNMI)="" F BGPIMM=35,112 D
  1. .S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
  1. .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
  1. I R,BGPPER>3,BGPD>3 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI dtap",1:"Ref dtap")
  1. S (R,BGPNMI)="" F BGPIMM=90703 D
  1. .S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I
  1. .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
  1. I R,BGPPER>3,BGPD>3 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI dtap",1:"Ref dtap")
  1. ;now check Refusals in imm pkg
  1. S R="" ;F BGPIMM=35,112 S R=$$IMMREF^BGP7D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
  1. ;I BGPPER>3,BGPD>3,R Q 3_U_"Ref dtap"
  1. ;now check for Contraindication
  1. F BGPZ=20,50,106,107,110,120,130,132,146 S X=$$ANCONT^BGP7D31(P,BGPZ,EDATE) Q:X]""
  1. I X]"" Q 4_U_"Contra DTaP"
  1. F BGPZ=1,22 S X=$$ANCONT^BGP7D31(P,BGPZ,EDATE) Q:X]""
  1. I X]"" Q 4_U_"Contra DTP"
  1. F BGPZ=115 S X=$$ANCONT^BGP7D31(P,BGPZ,EDATE) Q:X]""
  1. I X]"" Q 4_U_"Contra Tdap"
  1. F BGPZ=28 S X=$$ANCONT^BGP7D31(P,BGPZ,EDATE) Q:X]""
  1. I X]"" Q 4_U_"Contra DT"
  1. F BGPZ=9,113,138,139 S X=$$ANCONT^BGP7D31(P,BGPZ,EDATE) Q:X]""
  1. I X]"" Q 4_U_"Contra td"
  1. F BGPZ=35,112 S X=$$ANCONT^BGP7D31(P,BGPZ,EDATE) Q:X]""
  1. I X]"" Q 4_U_"Contra tetanus"
  1. F BGPZ=11 S X=$$ANCONT^BGP7D31(P,BGPZ,EDATE) Q:X]""
  1. I X]"" Q 4_U_"Contra pertussis"
  1. Q ""
  1. TEST ;
  1. D TEST^BGP7D341
  1. Q
  1. 90700 ;;
  1. 90721 ;;
  1. 90723 ;;
  1. 90701 ;;
  1. 90711 ;;
  1. 90720 ;;
  1. 90702 ;;
  1. 90718 ;;
  1. 90719 ;;
  1. 90703 ;;