BGP8PC7 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018 11:25 AM
;;18.1;IHS CLINICAL REPORTING;**1**;MAY 25, 2018;Build 65
;
ADZ ;EP
K BGPSTOP
S (BGPN1,BGPN2,BGPN3,BGPD1)=0
S (BGPTDAP,BGPMEN)=""
;GET THE PATIENT'S 13th BIRTHDAY
I 'BGPIPCUP S BGPSTOP=1 Q
S A=$$YBD(DFN,13)
I A>BGPEDATE S BGPSTOP=1 Q ;turned 13 YEARS after end date of report period
I A<BGPBDATE S BGPSTOP=1 Q ;turned 13 before report period
;
;
S BGPMEN=$$MEN(DFN)
I $P(BGPMEN,U,1)=2 S BGPSTOP=1 G EXIT ;contra to meningococcal
I $P(BGPMEN,U,1)=1 S BGPN1=1
;
S BGPTDAP=$$TDAP(DFN)
I $P(BGPTDAP,U,1)=2 S BGPSTOP=1,BGPN1=0 G EXIT
I $P(BGPTDAP,U,1)=1 S BGPN2=1
;
S BGPD1=1
I BGPN1,BGPN2 S BGPN3=1
;
I BGPN3 S V="" F X="BGPTDAP","BGPMEN" S:V]"" V=V_"; " S V=V_$P(@X,U,2)
I BGPN3 S V="*** "_V
I 'BGPN3 S V="" F X="BGPTDAP","BGPMEN" I $P(@X,U,1) S:V]"" V=V_"; " S V=V_$P(@X,U,2)
I 'BGPN3,V]"" S V="HAS: "_V
I 'BGPN3 S N="" F X="BGPTDAP","BGPMEN" I '$P(@X,U,1) S:N]"" N=N_"; " S N=N_$E(X,4,8)
I 'BGPN3 S V=V_" NEEDS: "_N
S BGPVALUE=""
S BGPVALUE="IPCUP|||"_V ;hit denominator
EXIT K BGPDV,BGPDTAP,BGPMEN,V,N,A
Q
MEN(P) ;
NEW A11,A13,X,Y,Z,TCVX,TCPT,C,BGPIMMS,D,V,BGPZ
S TCVX=$O(^ATXAX("B","BGP MENINGOCOCCAL CVX CODES",0))
S TCPT=$O(^ATXAX("B","BGP CPT MENINGOCOCCAL",0))
S A13=$$YBD(P,13)
S A11=$$YBD(P,11)
S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVIMM(X,0)) ;happens
.S Y=$P(^AUPNVIMM(X,0),U)
.Q:'Y ;happens too
.S I=$P($G(^AUTTIMM(Y,0)),U,3) ;get HL7/CVX code
.Q:'$D(^ATXAX(TCVX,21,"B",I)) ;not a DTAP
.S D=$P($P($G(^AUPNVIMM(X,12)),U,1),".")
.I D="" S V=$P(^AUPNVIMM(X,0),U,3) I V S D=$P($P($G(^AUPNVSIT(V,0)),U),".")
.Q:D<A11
.Q:D>A13
.S BGPIMMS(D)=Y
.Q
;go through and set into array if 1 days apart
S X="",Y="",C=0 F S X=$O(BGPIMMS(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPIMMS(X) Q
.S Y=X
;see if there is 1 of them, if there are quit
S BGPIMMS=0,X=0 F S X=$O(BGPIMMS(X)) Q:X'=+X S BGPIMMS=BGPIMMS+1
I BGPIMMS>0 Q 1_U_"1 MENINGOCOCCAL"
;now get cpts
S G="",X=0
F S X=$O(^AUPNVCPT("AC",P,X)) Q:X="" D
.Q:'$D(^AUPNVCPT(X,0))
.S Y=$P(^AUPNVCPT(X,0),U)
.Q:'$$ICD^BGP8UTL2(Y,TCPT,1) ;not a dtap cpt
.S V=$P(^AUPNVCPT(X,0),U,3) Q:'V
.S D=$$VD^APCLV(V)
.Q:D<A11
.Q:D>A13
.S BGPIMMS(D)=""
;get tran codes
S X=0 F S X=$O(^AUPNVTC("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVTC(X,0))
.S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y
.Q:'$$ICD^BGP8UTL2(Y,TCPT,1)
.S V=$P(^AUPNVTC(X,0),U,3) Q:'V
.S D=$$VD^APCLV(V)
.Q:D<A11
.Q:D>A13
.S BGPIMMS(D)=""
;
;go through and set into array if 1 days apart
S X="",Y="",C=0 F S X=$O(BGPIMMS(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<1 K BGPIMMS(X) Q
.S Y=X
;see if there are 4 of them, if there are quit
S BGPIMMS=0,X=0 F S X=$O(BGPIMMS(X)) Q:X'=+X S BGPIMMS=BGPIMMS+1
I BGPIMMS>0 Q 1_U_"1 MENINGOCOCCAL"
;NOW CHECK FOR CONTRAINDICATION
;IMM PKG ANAPHYLACTIS
S BGPZ=0
F S BGPZ=$O(^ATXAX(TCVX,21,"B",BGPZ)) Q:BGPZ=""!(X]"") D
.S X=$$ANCONT^BGP8D31(P,BGPZ,A13)
I X]"" Q 2_U_"CONTRA"
Q ""
YBD(P,A) ;
NEW B,M,D,Y
S B=$$DOB^AUPNPAT(P) ;DOB
S M=$E(B,4,5)
S D=$E(B,6,7)
S Y=$E(B,1,3),Y=Y+A
Q Y_M_D
TDAP(P) ;
NEW A10,A13,X,Y,Z,TCVX,TCPT,C,BGPIMMS,D,V,BGPZ
S TCVX=$O(^ATXAX("B","BGP IPC TDAP CVX CODES",0))
S TCPT=$O(^ATXAX("B","BGP CPT TDAP/TD",0))
S A13=$$YBD(P,13)
S A10=$$YBD(P,10)
S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVIMM(X,0)) ;happens
.S Y=$P(^AUPNVIMM(X,0),U)
.Q:'Y ;happens too
.S I=$P($G(^AUTTIMM(Y,0)),U,3) ;get HL7/CVX code
.Q:'$D(^ATXAX(TCVX,21,"B",I)) ;not a DTAP
.S D=$P($P($G(^AUPNVIMM(X,12)),U,1),".")
.I D="" S V=$P(^AUPNVIMM(X,0),U,3) I V S D=$P($P($G(^AUPNVSIT(V,0)),U),".")
.Q:D<A10
.Q:D>A13
.S BGPIMMS(D)=Y
.Q
;go through and set into array if 1 days apart
S X="",Y="",C=0 F S X=$O(BGPIMMS(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPIMMS(X) Q
.S Y=X
;see if there is 1 of them, if there are quit
S BGPIMMS=0,X=0 F S X=$O(BGPIMMS(X)) Q:X'=+X S BGPIMMS=BGPIMMS+1
I BGPIMMS>0 Q 1_U_"1 TDAP/TD"
;TD CVX CODES
S TCVX=$O(^ATXAX("B","BGP IPC TD CVX CODES",0))
S TCPT=$O(^ATXAX("B","BGP CPT TDAP/TD",0))
S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVIMM(X,0)) ;happens
.S Y=$P(^AUPNVIMM(X,0),U)
.Q:'Y ;happens too
.S I=$P($G(^AUTTIMM(Y,0)),U,3) ;get HL7/CVX code
.Q:'$D(^ATXAX(TCVX,21,"B",I)) ;not a DTAP
.S D=$P($P($G(^AUPNVIMM(X,12)),U,1),".")
.I D="" S V=$P(^AUPNVIMM(X,0),U,3) I V S D=$P($P($G(^AUPNVSIT(V,0)),U),".")
.Q:D<A10
.Q:D>A13
.S BGPIMMS(D)=Y
.Q
;go through and set into array if 1 days apart
S X="",Y="",C=0 F S X=$O(BGPIMMS(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPIMMS(X) Q
.S Y=X
;see if there is 1 of them, if there are quit
S BGPIMMS=0,X=0 F S X=$O(BGPIMMS(X)) Q:X'=+X S BGPIMMS=BGPIMMS+1
I BGPIMMS>0 Q 1_U_"1 TDAP/TD"
;now get cpts
S G="",X=0
F S X=$O(^AUPNVCPT("AC",P,X)) Q:X="" D
.Q:'$D(^AUPNVCPT(X,0))
.S Y=$P(^AUPNVCPT(X,0),U)
.Q:'$$ICD^BGP8UTL2(Y,TCPT,1) ;not a dtap cpt
.S V=$P(^AUPNVCPT(X,0),U,3) Q:'V
.S D=$$VD^APCLV(V)
.Q:D<A10
.Q:D>A13
.S BGPIMMS(D)=""
;get tran codes
S X=0 F S X=$O(^AUPNVTC("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVTC(X,0))
.S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y
.Q:'$$ICD^BGP8UTL2(Y,TCPT,1)
.S V=$P(^AUPNVTC(X,0),U,3) Q:'V
.S D=$$VD^APCLV(V)
.Q:D<A10
.Q:D>A13
.S BGPIMMS(D)=""
;
;go through and set into array if 1 days apart
S X="",Y="",C=0 F S X=$O(BGPIMMS(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<1 K BGPIMMS(X) Q
.S Y=X
;see if there are 4 of them, if there are quit
S BGPIMMS=0,X=0 F S X=$O(BGPIMMS(X)) Q:X'=+X S BGPIMMS=BGPIMMS+1
I BGPIMMS>0 Q 1_U_"1 TDAP/TD"
DIP ;NOW CHECK FOR 1 DIP AND ONE TET
NEW BGPDIP,BGPTET
S BGPDIP=$$LASTDX^BGP8UTL1(P,"BGP DIPHTHERIA IZ DXS",A10,A13)
I 'BGPDIP S E=+$$CODEN^ICPTCOD(90719),BGPDIP=$$CPTI^BGP8DU(P,A10,A13,E)
I 'BGPDIP G DTAPCON ; NO DIP SO DON'T BOTHER WITH TETANUS
TET ;
S BGPTET=$$LASTITEM^BGP8DU(P,A10,A13,"IMMUNIZATION","35")
I 'BGPTET S BGPTET=$$LASTITEM^BGP8DU(P,A10,A13,"IMMUNIZATION","112")
I 'BGPTET S BGPTET=$$LASTDX^BGP8UTL1(P,"BGP TETANUS TOXOID IZ DXS",A10,A13)
I 'BGPTET S E=+$$CODEN^ICPTCOD(90703),BGPTET=$$CPTI^BGP8DU(P,A10,A13,E)
I 'BGPTET G DTAPCON ; NO TET SO DON'T BOTHER WITH TETANUS
Q 1_U_"1 TDAP/TD"
DTAPCON ;NOW CHECK FOR CONTRAINDICATION
;IMM PKG ANAPHYLACTIS
S BGPZ=0
S TCVX=$O(^ATXAX("B","BGP IPC TDAP CVX CODES",0))
F S BGPZ=$O(^ATXAX(TCVX,21,"B",BGPZ)) Q:BGPZ=""!(X]"") D
.S X=$$ANCONT^BGP8D31(P,BGPZ,A13)
I X]"" Q 2_U_"CONTRA TDAP/TD"
S BGPZ=0
S TCVX=$O(^ATXAX("B","BGP IPC TD CVX CODES",0))
F S BGPZ=$O(^ATXAX(TCVX,21,"B",BGPZ)) Q:BGPZ=""!(X]"") D
.S X=$$ANCONT^BGP8D31(P,BGPZ,A13)
I X]"" Q 2_U_"CONTRA TDAP/TD"
F BGPZ=35,112 S X=$$ANCONT^BGP8D31(P,BGPZ,A13) Q:X]""
I X]"" Q 2_U_"CONTRA TDAP/TD"
Q ""
BGP8PC7 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018 11:25 AM
+1 ;;18.1;IHS CLINICAL REPORTING;**1**;MAY 25, 2018;Build 65
+2 ;
ADZ ;EP
+1 KILL BGPSTOP
+2 SET (BGPN1,BGPN2,BGPN3,BGPD1)=0
+3 SET (BGPTDAP,BGPMEN)=""
+4 ;GET THE PATIENT'S 13th BIRTHDAY
+5 IF 'BGPIPCUP
SET BGPSTOP=1
QUIT
+6 SET A=$$YBD(DFN,13)
+7 ;turned 13 YEARS after end date of report period
IF A>BGPEDATE
SET BGPSTOP=1
QUIT
+8 ;turned 13 before report period
IF A<BGPBDATE
SET BGPSTOP=1
QUIT
+9 ;
+10 ;
+11 SET BGPMEN=$$MEN(DFN)
+12 ;contra to meningococcal
IF $PIECE(BGPMEN,U,1)=2
SET BGPSTOP=1
GOTO EXIT
+13 IF $PIECE(BGPMEN,U,1)=1
SET BGPN1=1
+14 ;
+15 SET BGPTDAP=$$TDAP(DFN)
+16 IF $PIECE(BGPTDAP,U,1)=2
SET BGPSTOP=1
SET BGPN1=0
GOTO EXIT
+17 IF $PIECE(BGPTDAP,U,1)=1
SET BGPN2=1
+18 ;
+19 SET BGPD1=1
+20 IF BGPN1
IF BGPN2
SET BGPN3=1
+21 ;
+22 IF BGPN3
SET V=""
FOR X="BGPTDAP","BGPMEN"
IF V]""
SET V=V_"; "
SET V=V_$PIECE(@X,U,2)
+23 IF BGPN3
SET V="*** "_V
+24 IF 'BGPN3
SET V=""
FOR X="BGPTDAP","BGPMEN"
IF $PIECE(@X,U,1)
IF V]""
SET V=V_"; "
SET V=V_$PIECE(@X,U,2)
+25 IF 'BGPN3
IF V]""
SET V="HAS: "_V
+26 IF 'BGPN3
SET N=""
FOR X="BGPTDAP","BGPMEN"
IF '$PIECE(@X,U,1)
IF N]""
SET N=N_"; "
SET N=N_$EXTRACT(X,4,8)
+27 IF 'BGPN3
SET V=V_" NEEDS: "_N
+28 SET BGPVALUE=""
+29 ;hit denominator
SET BGPVALUE="IPCUP|||"_V
EXIT KILL BGPDV,BGPDTAP,BGPMEN,V,N,A
+1 QUIT
MEN(P) ;
+1 NEW A11,A13,X,Y,Z,TCVX,TCPT,C,BGPIMMS,D,V,BGPZ
+2 SET TCVX=$ORDER(^ATXAX("B","BGP MENINGOCOCCAL CVX CODES",0))
+3 SET TCPT=$ORDER(^ATXAX("B","BGP CPT MENINGOCOCCAL",0))
+4 SET A13=$$YBD(P,13)
+5 SET A11=$$YBD(P,11)
+6 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+7 ;happens
IF '$DATA(^AUPNVIMM(X,0))
QUIT
+8 SET Y=$PIECE(^AUPNVIMM(X,0),U)
+9 ;happens too
IF 'Y
QUIT
+10 ;get HL7/CVX code
SET I=$PIECE($GET(^AUTTIMM(Y,0)),U,3)
+11 ;not a DTAP
IF '$DATA(^ATXAX(TCVX,21,"B",I))
QUIT
+12 SET D=$PIECE($PIECE($GET(^AUPNVIMM(X,12)),U,1),".")
+13 IF D=""
SET V=$PIECE(^AUPNVIMM(X,0),U,3)
IF V
SET D=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+14 IF D<A11
QUIT
+15 IF D>A13
QUIT
+16 SET BGPIMMS(D)=Y
+17 QUIT
End DoDot:1
+18 ;go through and set into array if 1 days apart
+19 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPIMMS(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+20 IF C=1
SET Y=X
QUIT
+21 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPIMMS(X)
QUIT
+22 SET Y=X
End DoDot:1
+23 ;see if there is 1 of them, if there are quit
+24 SET BGPIMMS=0
SET X=0
FOR
SET X=$ORDER(BGPIMMS(X))
IF X'=+X
QUIT
SET BGPIMMS=BGPIMMS+1
+25 IF BGPIMMS>0
QUIT 1_U_"1 MENINGOCOCCAL"
+26 ;now get cpts
+27 SET G=""
SET X=0
+28 FOR
SET X=$ORDER(^AUPNVCPT("AC",P,X))
IF X=""
QUIT
Begin DoDot:1
+29 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+30 SET Y=$PIECE(^AUPNVCPT(X,0),U)
+31 ;not a dtap cpt
IF '$$ICD^BGP8UTL2(Y,TCPT,1)
QUIT
+32 SET V=$PIECE(^AUPNVCPT(X,0),U,3)
IF 'V
QUIT
+33 SET D=$$VD^APCLV(V)
+34 IF D<A11
QUIT
+35 IF D>A13
QUIT
+36 SET BGPIMMS(D)=""
End DoDot:1
+37 ;get tran codes
+38 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+39 IF '$DATA(^AUPNVTC(X,0))
QUIT
+40 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
+41 IF '$$ICD^BGP8UTL2(Y,TCPT,1)
QUIT
+42 SET V=$PIECE(^AUPNVTC(X,0),U,3)
IF 'V
QUIT
+43 SET D=$$VD^APCLV(V)
+44 IF D<A11
QUIT
+45 IF D>A13
QUIT
+46 SET BGPIMMS(D)=""
End DoDot:1
+47 ;
+48 ;go through and set into array if 1 days apart
+49 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPIMMS(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+50 IF C=1
SET Y=X
QUIT
+51 IF $$FMDIFF^XLFDT(X,Y)<1
KILL BGPIMMS(X)
QUIT
+52 SET Y=X
End DoDot:1
+53 ;see if there are 4 of them, if there are quit
+54 SET BGPIMMS=0
SET X=0
FOR
SET X=$ORDER(BGPIMMS(X))
IF X'=+X
QUIT
SET BGPIMMS=BGPIMMS+1
+55 IF BGPIMMS>0
QUIT 1_U_"1 MENINGOCOCCAL"
+56 ;NOW CHECK FOR CONTRAINDICATION
+57 ;IMM PKG ANAPHYLACTIS
+58 SET BGPZ=0
+59 FOR
SET BGPZ=$ORDER(^ATXAX(TCVX,21,"B",BGPZ))
IF BGPZ=""!(X]"")
QUIT
Begin DoDot:1
+60 SET X=$$ANCONT^BGP8D31(P,BGPZ,A13)
End DoDot:1
+61 IF X]""
QUIT 2_U_"CONTRA"
+62 QUIT ""
YBD(P,A) ;
+1 NEW B,M,D,Y
+2 ;DOB
SET B=$$DOB^AUPNPAT(P)
+3 SET M=$EXTRACT(B,4,5)
+4 SET D=$EXTRACT(B,6,7)
+5 SET Y=$EXTRACT(B,1,3)
SET Y=Y+A
+6 QUIT Y_M_D
TDAP(P) ;
+1 NEW A10,A13,X,Y,Z,TCVX,TCPT,C,BGPIMMS,D,V,BGPZ
+2 SET TCVX=$ORDER(^ATXAX("B","BGP IPC TDAP CVX CODES",0))
+3 SET TCPT=$ORDER(^ATXAX("B","BGP CPT TDAP/TD",0))
+4 SET A13=$$YBD(P,13)
+5 SET A10=$$YBD(P,10)
+6 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+7 ;happens
IF '$DATA(^AUPNVIMM(X,0))
QUIT
+8 SET Y=$PIECE(^AUPNVIMM(X,0),U)
+9 ;happens too
IF 'Y
QUIT
+10 ;get HL7/CVX code
SET I=$PIECE($GET(^AUTTIMM(Y,0)),U,3)
+11 ;not a DTAP
IF '$DATA(^ATXAX(TCVX,21,"B",I))
QUIT
+12 SET D=$PIECE($PIECE($GET(^AUPNVIMM(X,12)),U,1),".")
+13 IF D=""
SET V=$PIECE(^AUPNVIMM(X,0),U,3)
IF V
SET D=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+14 IF D<A10
QUIT
+15 IF D>A13
QUIT
+16 SET BGPIMMS(D)=Y
+17 QUIT
End DoDot:1
+18 ;go through and set into array if 1 days apart
+19 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPIMMS(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+20 IF C=1
SET Y=X
QUIT
+21 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPIMMS(X)
QUIT
+22 SET Y=X
End DoDot:1
+23 ;see if there is 1 of them, if there are quit
+24 SET BGPIMMS=0
SET X=0
FOR
SET X=$ORDER(BGPIMMS(X))
IF X'=+X
QUIT
SET BGPIMMS=BGPIMMS+1
+25 IF BGPIMMS>0
QUIT 1_U_"1 TDAP/TD"
+26 ;TD CVX CODES
+27 SET TCVX=$ORDER(^ATXAX("B","BGP IPC TD CVX CODES",0))
+28 SET TCPT=$ORDER(^ATXAX("B","BGP CPT TDAP/TD",0))
+29 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+30 ;happens
IF '$DATA(^AUPNVIMM(X,0))
QUIT
+31 SET Y=$PIECE(^AUPNVIMM(X,0),U)
+32 ;happens too
IF 'Y
QUIT
+33 ;get HL7/CVX code
SET I=$PIECE($GET(^AUTTIMM(Y,0)),U,3)
+34 ;not a DTAP
IF '$DATA(^ATXAX(TCVX,21,"B",I))
QUIT
+35 SET D=$PIECE($PIECE($GET(^AUPNVIMM(X,12)),U,1),".")
+36 IF D=""
SET V=$PIECE(^AUPNVIMM(X,0),U,3)
IF V
SET D=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+37 IF D<A10
QUIT
+38 IF D>A13
QUIT
+39 SET BGPIMMS(D)=Y
+40 QUIT
End DoDot:1
+41 ;go through and set into array if 1 days apart
+42 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPIMMS(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+43 IF C=1
SET Y=X
QUIT
+44 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPIMMS(X)
QUIT
+45 SET Y=X
End DoDot:1
+46 ;see if there is 1 of them, if there are quit
+47 SET BGPIMMS=0
SET X=0
FOR
SET X=$ORDER(BGPIMMS(X))
IF X'=+X
QUIT
SET BGPIMMS=BGPIMMS+1
+48 IF BGPIMMS>0
QUIT 1_U_"1 TDAP/TD"
+49 ;now get cpts
+50 SET G=""
SET X=0
+51 FOR
SET X=$ORDER(^AUPNVCPT("AC",P,X))
IF X=""
QUIT
Begin DoDot:1
+52 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+53 SET Y=$PIECE(^AUPNVCPT(X,0),U)
+54 ;not a dtap cpt
IF '$$ICD^BGP8UTL2(Y,TCPT,1)
QUIT
+55 SET V=$PIECE(^AUPNVCPT(X,0),U,3)
IF 'V
QUIT
+56 SET D=$$VD^APCLV(V)
+57 IF D<A10
QUIT
+58 IF D>A13
QUIT
+59 SET BGPIMMS(D)=""
End DoDot:1
+60 ;get tran codes
+61 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+62 IF '$DATA(^AUPNVTC(X,0))
QUIT
+63 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
+64 IF '$$ICD^BGP8UTL2(Y,TCPT,1)
QUIT
+65 SET V=$PIECE(^AUPNVTC(X,0),U,3)
IF 'V
QUIT
+66 SET D=$$VD^APCLV(V)
+67 IF D<A10
QUIT
+68 IF D>A13
QUIT
+69 SET BGPIMMS(D)=""
End DoDot:1
+70 ;
+71 ;go through and set into array if 1 days apart
+72 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPIMMS(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+73 IF C=1
SET Y=X
QUIT
+74 IF $$FMDIFF^XLFDT(X,Y)<1
KILL BGPIMMS(X)
QUIT
+75 SET Y=X
End DoDot:1
+76 ;see if there are 4 of them, if there are quit
+77 SET BGPIMMS=0
SET X=0
FOR
SET X=$ORDER(BGPIMMS(X))
IF X'=+X
QUIT
SET BGPIMMS=BGPIMMS+1
+78 IF BGPIMMS>0
QUIT 1_U_"1 TDAP/TD"
DIP ;NOW CHECK FOR 1 DIP AND ONE TET
+1 NEW BGPDIP,BGPTET
+2 SET BGPDIP=$$LASTDX^BGP8UTL1(P,"BGP DIPHTHERIA IZ DXS",A10,A13)
+3 IF 'BGPDIP
SET E=+$$CODEN^ICPTCOD(90719)
SET BGPDIP=$$CPTI^BGP8DU(P,A10,A13,E)
+4 ; NO DIP SO DON'T BOTHER WITH TETANUS
IF 'BGPDIP
GOTO DTAPCON
TET ;
+1 SET BGPTET=$$LASTITEM^BGP8DU(P,A10,A13,"IMMUNIZATION","35")
+2 IF 'BGPTET
SET BGPTET=$$LASTITEM^BGP8DU(P,A10,A13,"IMMUNIZATION","112")
+3 IF 'BGPTET
SET BGPTET=$$LASTDX^BGP8UTL1(P,"BGP TETANUS TOXOID IZ DXS",A10,A13)
+4 IF 'BGPTET
SET E=+$$CODEN^ICPTCOD(90703)
SET BGPTET=$$CPTI^BGP8DU(P,A10,A13,E)
+5 ; NO TET SO DON'T BOTHER WITH TETANUS
IF 'BGPTET
GOTO DTAPCON
+6 QUIT 1_U_"1 TDAP/TD"
DTAPCON ;NOW CHECK FOR CONTRAINDICATION
+1 ;IMM PKG ANAPHYLACTIS
+2 SET BGPZ=0
+3 SET TCVX=$ORDER(^ATXAX("B","BGP IPC TDAP CVX CODES",0))
+4 FOR
SET BGPZ=$ORDER(^ATXAX(TCVX,21,"B",BGPZ))
IF BGPZ=""!(X]"")
QUIT
Begin DoDot:1
+5 SET X=$$ANCONT^BGP8D31(P,BGPZ,A13)
End DoDot:1
+6 IF X]""
QUIT 2_U_"CONTRA TDAP/TD"
+7 SET BGPZ=0
+8 SET TCVX=$ORDER(^ATXAX("B","BGP IPC TD CVX CODES",0))
+9 FOR
SET BGPZ=$ORDER(^ATXAX(TCVX,21,"B",BGPZ))
IF BGPZ=""!(X]"")
QUIT
Begin DoDot:1
+10 SET X=$$ANCONT^BGP8D31(P,BGPZ,A13)
End DoDot:1
+11 IF X]""
QUIT 2_U_"CONTRA TDAP/TD"
+12 FOR BGPZ=35,112
SET X=$$ANCONT^BGP8D31(P,BGPZ,A13)
IF X]""
QUIT
+13 IF X]""
QUIT 2_U_"CONTRA TDAP/TD"
+14 QUIT ""
