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

BGP8PC7.m

Go to the documentation of this file. 
  1. BGP8PC7 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018  11:25 AM
  1.  ;;18.1;IHS CLINICAL REPORTING;**1**;MAY 25, 2018;Build 65
  1.  ;
  1. ADZ ;EP
  1.  K BGPSTOP
  1.  S (BGPN1,BGPN2,BGPN3,BGPD1)=0
  1.  S (BGPTDAP,BGPMEN)=""
  1.  ;GET THE PATIENT'S 13th BIRTHDAY
  1.  I 'BGPIPCUP S BGPSTOP=1 Q
  1.  S A=$$YBD(DFN,13)
  1.  I A>BGPEDATE S BGPSTOP=1 Q  ;turned 13 YEARS after end date of report period
  1.  I A<BGPBDATE S BGPSTOP=1 Q  ;turned 13 before report period
  1.  ;
  1.  ;
  1.  S BGPMEN=$$MEN(DFN)
  1.  I $P(BGPMEN,U,1)=2 S BGPSTOP=1 G EXIT  ;contra to meningococcal
  1.  I $P(BGPMEN,U,1)=1 S BGPN1=1
  1.  ;
  1.  S BGPTDAP=$$TDAP(DFN)
  1.  I $P(BGPTDAP,U,1)=2 S BGPSTOP=1,BGPN1=0 G EXIT
  1.  I $P(BGPTDAP,U,1)=1 S BGPN2=1
  1.  ;
  1.  S BGPD1=1
  1.  I BGPN1,BGPN2 S BGPN3=1
  1.  ;
  1.  I BGPN3 S V="" F X="BGPTDAP","BGPMEN" S:V]"" V=V_"; " S V=V_$P(@X,U,2)
  1.  I BGPN3 S V="*** "_V
  1.  I 'BGPN3 S V="" F X="BGPTDAP","BGPMEN" I $P(@X,U,1) S:V]"" V=V_"; " S V=V_$P(@X,U,2)
  1.  I 'BGPN3,V]"" S V="HAS: "_V
  1.  I 'BGPN3 S N="" F X="BGPTDAP","BGPMEN" I '$P(@X,U,1) S:N]"" N=N_"; " S N=N_$E(X,4,8)
  1.  I 'BGPN3 S V=V_" NEEDS: "_N
  1.  S BGPVALUE=""
  1.  S BGPVALUE="IPCUP|||"_V   ;hit denominator
  1. EXIT K BGPDV,BGPDTAP,BGPMEN,V,N,A
  1.  Q
  1. MEN(P) ;
  1.  NEW A11,A13,X,Y,Z,TCVX,TCPT,C,BGPIMMS,D,V,BGPZ
  1.  S TCVX=$O(^ATXAX("B","BGP MENINGOCOCCAL CVX CODES",0))
  1.  S TCPT=$O(^ATXAX("B","BGP CPT MENINGOCOCCAL",0))
  1.  S A13=$$YBD(P,13)
  1.  S A11=$$YBD(P,11)
  1.  S X=0 F  S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNVIMM(X,0))  ;happens
  1.  .S Y=$P(^AUPNVIMM(X,0),U)
  1.  .Q:'Y  ;happens too
  1.  .S I=$P($G(^AUTTIMM(Y,0)),U,3)  ;get HL7/CVX code
  1.  .Q:'$D(^ATXAX(TCVX,21,"B",I))  ;not a DTAP
  1.  .S D=$P($P($G(^AUPNVIMM(X,12)),U,1),".")
  1.  .I D="" S V=$P(^AUPNVIMM(X,0),U,3) I V S D=$P($P($G(^AUPNVSIT(V,0)),U),".")
  1.  .Q:D<A11
  1.  .Q:D>A13
  1.  .S BGPIMMS(D)=Y
  1.  .Q
  1.  ;go through and set into array if 1 days apart
  1.  S X="",Y="",C=0 F  S X=$O(BGPIMMS(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 BGPIMMS(X) Q
  1.  .S Y=X
  1.  ;see if there is 1 of them, if there are quit
  1.  S BGPIMMS=0,X=0 F  S X=$O(BGPIMMS(X)) Q:X'=+X  S BGPIMMS=BGPIMMS+1
  1.  I BGPIMMS>0 Q 1_U_"1 MENINGOCOCCAL"
  1.  ;now get cpts
  1.  S G="",X=0
  1.  F  S X=$O(^AUPNVCPT("AC",P,X)) Q:X=""  D
  1.  .Q:'$D(^AUPNVCPT(X,0))
  1.  .S Y=$P(^AUPNVCPT(X,0),U)
  1.  .Q:'$$ICD^BGP8UTL2(Y,TCPT,1)  ;not a dtap cpt
  1.  .S V=$P(^AUPNVCPT(X,0),U,3) Q:'V
  1.  .S D=$$VD^APCLV(V)
  1.  .Q:D<A11
  1.  .Q:D>A13
  1.  .S BGPIMMS(D)=""
  1.  ;get tran codes
  1.  S X=0 F  S X=$O(^AUPNVTC("AC",P,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNVTC(X,0))
  1.  .S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y
  1.  .Q:'$$ICD^BGP8UTL2(Y,TCPT,1)
  1.  .S V=$P(^AUPNVTC(X,0),U,3) Q:'V
  1.  .S D=$$VD^APCLV(V)
  1.  .Q:D<A11
  1.  .Q:D>A13
  1.  .S BGPIMMS(D)=""
  1.  ;
  1.  ;go through and set into array if 1 days apart
  1.  S X="",Y="",C=0 F  S X=$O(BGPIMMS(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<1 K BGPIMMS(X) Q
  1.  .S Y=X
  1.  ;see if there are 4 of them, if there are quit
  1.  S BGPIMMS=0,X=0 F  S X=$O(BGPIMMS(X)) Q:X'=+X  S BGPIMMS=BGPIMMS+1
  1.  I BGPIMMS>0 Q 1_U_"1 MENINGOCOCCAL"
  1.  ;NOW CHECK FOR CONTRAINDICATION
  1.  ;IMM PKG ANAPHYLACTIS
  1.  S BGPZ=0
  1.  F  S BGPZ=$O(^ATXAX(TCVX,21,"B",BGPZ)) Q:BGPZ=""!(X]"")  D
  1.  .S X=$$ANCONT^BGP8D31(P,BGPZ,A13)
  1.  I X]"" Q 2_U_"CONTRA"
  1.  Q ""
  1. YBD(P,A) ;
  1.  NEW B,M,D,Y
  1.  S B=$$DOB^AUPNPAT(P)  ;DOB
  1.  S M=$E(B,4,5)
  1.  S D=$E(B,6,7)
  1.  S Y=$E(B,1,3),Y=Y+A
  1.  Q Y_M_D
  1. TDAP(P) ;
  1.  NEW A10,A13,X,Y,Z,TCVX,TCPT,C,BGPIMMS,D,V,BGPZ
  1.  S TCVX=$O(^ATXAX("B","BGP IPC TDAP CVX CODES",0))
  1.  S TCPT=$O(^ATXAX("B","BGP CPT TDAP/TD",0))
  1.  S A13=$$YBD(P,13)
  1.  S A10=$$YBD(P,10)
  1.  S X=0 F  S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNVIMM(X,0))  ;happens
  1.  .S Y=$P(^AUPNVIMM(X,0),U)
  1.  .Q:'Y  ;happens too
  1.  .S I=$P($G(^AUTTIMM(Y,0)),U,3)  ;get HL7/CVX code
  1.  .Q:'$D(^ATXAX(TCVX,21,"B",I))  ;not a DTAP
  1.  .S D=$P($P($G(^AUPNVIMM(X,12)),U,1),".")
  1.  .I D="" S V=$P(^AUPNVIMM(X,0),U,3) I V S D=$P($P($G(^AUPNVSIT(V,0)),U),".")
  1.  .Q:D<A10
  1.  .Q:D>A13
  1.  .S BGPIMMS(D)=Y
  1.  .Q
  1.  ;go through and set into array if 1 days apart
  1.  S X="",Y="",C=0 F  S X=$O(BGPIMMS(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 BGPIMMS(X) Q
  1.  .S Y=X
  1.  ;see if there is 1 of them, if there are quit
  1.  S BGPIMMS=0,X=0 F  S X=$O(BGPIMMS(X)) Q:X'=+X  S BGPIMMS=BGPIMMS+1
  1.  I BGPIMMS>0 Q 1_U_"1 TDAP/TD"
  1.  ;TD CVX CODES
  1.  S TCVX=$O(^ATXAX("B","BGP IPC TD CVX CODES",0))
  1.  S TCPT=$O(^ATXAX("B","BGP CPT TDAP/TD",0))
  1.  S X=0 F  S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNVIMM(X,0))  ;happens
  1.  .S Y=$P(^AUPNVIMM(X,0),U)
  1.  .Q:'Y  ;happens too
  1.  .S I=$P($G(^AUTTIMM(Y,0)),U,3)  ;get HL7/CVX code
  1.  .Q:'$D(^ATXAX(TCVX,21,"B",I))  ;not a DTAP
  1.  .S D=$P($P($G(^AUPNVIMM(X,12)),U,1),".")
  1.  .I D="" S V=$P(^AUPNVIMM(X,0),U,3) I V S D=$P($P($G(^AUPNVSIT(V,0)),U),".")
  1.  .Q:D<A10
  1.  .Q:D>A13
  1.  .S BGPIMMS(D)=Y
  1.  .Q
  1.  ;go through and set into array if 1 days apart
  1.  S X="",Y="",C=0 F  S X=$O(BGPIMMS(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 BGPIMMS(X) Q
  1.  .S Y=X
  1.  ;see if there is 1 of them, if there are quit
  1.  S BGPIMMS=0,X=0 F  S X=$O(BGPIMMS(X)) Q:X'=+X  S BGPIMMS=BGPIMMS+1
  1.  I BGPIMMS>0 Q 1_U_"1 TDAP/TD"
  1.  ;now get cpts
  1.  S G="",X=0
  1.  F  S X=$O(^AUPNVCPT("AC",P,X)) Q:X=""  D
  1.  .Q:'$D(^AUPNVCPT(X,0))
  1.  .S Y=$P(^AUPNVCPT(X,0),U)
  1.  .Q:'$$ICD^BGP8UTL2(Y,TCPT,1)  ;not a dtap cpt
  1.  .S V=$P(^AUPNVCPT(X,0),U,3) Q:'V
  1.  .S D=$$VD^APCLV(V)
  1.  .Q:D<A10
  1.  .Q:D>A13
  1.  .S BGPIMMS(D)=""
  1.  ;get tran codes
  1.  S X=0 F  S X=$O(^AUPNVTC("AC",P,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNVTC(X,0))
  1.  .S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y
  1.  .Q:'$$ICD^BGP8UTL2(Y,TCPT,1)
  1.  .S V=$P(^AUPNVTC(X,0),U,3) Q:'V
  1.  .S D=$$VD^APCLV(V)
  1.  .Q:D<A10
  1.  .Q:D>A13
  1.  .S BGPIMMS(D)=""
  1.  ;
  1.  ;go through and set into array if 1 days apart
  1.  S X="",Y="",C=0 F  S X=$O(BGPIMMS(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<1 K BGPIMMS(X) Q
  1.  .S Y=X
  1.  ;see if there are 4 of them, if there are quit
  1.  S BGPIMMS=0,X=0 F  S X=$O(BGPIMMS(X)) Q:X'=+X  S BGPIMMS=BGPIMMS+1
  1.  I BGPIMMS>0 Q 1_U_"1 TDAP/TD"
  1. DIP ;NOW CHECK FOR 1 DIP AND ONE TET
  1.  NEW BGPDIP,BGPTET
  1.  S BGPDIP=$$LASTDX^BGP8UTL1(P,"BGP DIPHTHERIA IZ DXS",A10,A13)
  1.  I 'BGPDIP S E=+$$CODEN^ICPTCOD(90719),BGPDIP=$$CPTI^BGP8DU(P,A10,A13,E)
  1.  I 'BGPDIP G DTAPCON ; NO DIP SO DON'T BOTHER WITH TETANUS
  1. TET ;
  1.  S BGPTET=$$LASTITEM^BGP8DU(P,A10,A13,"IMMUNIZATION","35")
  1.  I 'BGPTET S BGPTET=$$LASTITEM^BGP8DU(P,A10,A13,"IMMUNIZATION","112")
  1.  I 'BGPTET S BGPTET=$$LASTDX^BGP8UTL1(P,"BGP TETANUS TOXOID IZ DXS",A10,A13)
  1.  I 'BGPTET S E=+$$CODEN^ICPTCOD(90703),BGPTET=$$CPTI^BGP8DU(P,A10,A13,E)
  1.  I 'BGPTET G DTAPCON ; NO TET SO DON'T BOTHER WITH TETANUS
  1.  Q 1_U_"1 TDAP/TD"
  1. DTAPCON ;NOW CHECK FOR CONTRAINDICATION
  1.  ;IMM PKG ANAPHYLACTIS
  1.  S BGPZ=0
  1.  S TCVX=$O(^ATXAX("B","BGP IPC TDAP CVX CODES",0))
  1.  F  S BGPZ=$O(^ATXAX(TCVX,21,"B",BGPZ)) Q:BGPZ=""!(X]"")  D
  1.  .S X=$$ANCONT^BGP8D31(P,BGPZ,A13)
  1.  I X]"" Q 2_U_"CONTRA TDAP/TD"
  1.  S BGPZ=0
  1.  S TCVX=$O(^ATXAX("B","BGP IPC TD CVX CODES",0))
  1.  F  S BGPZ=$O(^ATXAX(TCVX,21,"B",BGPZ)) Q:BGPZ=""!(X]"")  D
  1.  .S X=$$ANCONT^BGP8D31(P,BGPZ,A13)
  1.  I X]"" Q 2_U_"CONTRA TDAP/TD"
  1.  F BGPZ=35,112 S X=$$ANCONT^BGP8D31(P,BGPZ,A13) Q:X]""
  1.  I X]"" Q 2_U_"CONTRA TDAP/TD"
  1.  Q ""