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

BGP3D36.m

Go to the documentation of this file. 
  1. BGP3D36 ; IHS/CMI/LAB - measure C 06 Nov 2009 2:03 PM 28 May 2013 4:23 PM ;
  1.  ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
  1.  ;
  1. MEN(P,EDATE) ;EP
  1.  NEW BGPC,BGPG,BGPX,BGPMENI,C,ED,BD,V,X,Y,BGPZ,B,BGPIMM,R,G
  1.  ;gather up all immunizations, cpts, povs and check for 3 each ten days apart
  1.  K BGPMENI
  1.  ;get all immunizations
  1.  S C="32^108^114^136^147"
  1.  D GETIMMS^BGP3D32(P,EDATE,C,.BGPX)
  1.  ;go through and set into array if 10 days apart
  1.  I $O(BGPX(0)) Q 1_U_"Meningococcal"
  1.  ;now get cpts
  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.  ...S Y=$P(^AUPNVCPT(X,0),U),Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90733!(Y=90734) S BGPMENI(9999999-$P(ED,"."))=""
  1.  ..S X=0 F  S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X  D
  1.  ...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y  S Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90733!(Y=90734) S BGPMENI(9999999-$P(ED,"."))=""
  1.  I $D(BGPMENI) Q 1_U_"Meningococcal"
  1.  ;check for Evidence of desease and Contraindications and if yes, then quit
  1.  F BGPZ=32,108,114,136,147 S X=$$ANCONT^BGP3D31(P,BGPZ,EDATE) Q:X]""
  1.  I X]"" Q 4_U_"Contra Meningococcal"
  1.  ;now go to Refusals
  1.  S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
  1.  F BGPIMM=32,108,114,136,147  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) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
  1.  I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI Meningococcal",1:"Ref Meningococcal")
  1.  F BGPIMM=90733,90734 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) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
  1.  I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI Meningococcal",1:"Ref Meningococcal")
  1.  ;now check Refusals in imm pkg
  1.  F BGPIMM=32,108,114,136,147 S R=$$IMMREF^BGP3D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
  1.  I R Q 3_U_"Ref imm pkg Meningococcal"
  1.  Q ""
  1.  ;
  1. HPV(P,EDATE) ;EP
  1.  NEW BGPC,BGPG,BGPX,BGPHPV,C,X,ED,BD,V,G,R,BGPIMM,Y,Z,B,BGPNMI
  1.  ;gather up all immunizations, cpts, povs and check for 3 each ten days apart
  1.  ;get all immunizations
  1.  S C="62^118^137"
  1.  D GETIMMS^BGP3D32(P,EDATE,C,.BGPX)
  1.  ;go through and set into array if 10 days apart
  1.  S X=0 F  S X=$O(BGPX(X)) Q:X'=+X  S BGPHPV(X)=""
  1.  ;now get cpts
  1.  S ED=9999999-EDATE,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.  ...S Y=$P(^AUPNVCPT(X,0),U) S Z=$P($$CPT^ICPTCOD(Y),U,2) I Z=90649!(Z=90650) S BGPHPV(9999999-$P(ED,"."))=""
  1.  ..S X=0 F  S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X  D
  1.  ...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y  S Z=$P($$CPT^ICPTCOD(Y),U,2) I Z=90649!(Z=90650) S BGPHPV(9999999-$P(ED,"."))=""
  1.  ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
  1.  S X="",Y="",C=0 F  S X=$O(BGPHPV(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 BGPHPV(X) Q
  1.  .S Y=X
  1.  ;now count them and see if there are 4 of them
  1.  S BGPHPV=0,X=0 F  S X=$O(BGPHPV(X)) Q:X'=+X  S BGPHPV=BGPHPV+1
  1.  I BGPHPV>2 Q 1_U_"3 HPV"
  1.  ;check for Evidence of desease and Contraindications and if yes, then quit
  1.  ;now go to Refusals
  1.  S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
  1.  F BGPIMM=62,118,137  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) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
  1.  I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" HPV"
  1.  F BGPIMM=90649,90650 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) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
  1.  I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI HPV",1:"Ref HPV")
  1.  ;now check Refusals in imm pkg
  1.  F BGPIMM=62,118 S R=$$IMMREF^BGP3D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
  1.  I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" HPV"
  1.  F BGPZ=62,118 S X=$$ANCONT^BGP3D31(P,BGPZ,EDATE) Q:X]""
  1.  I X]"" Q 4_U_"Contra HPV"
  1.  Q ""
  1. H1N1 ;EP - called from measure
  1.  NEW BGPMONA,BGPH1N1
  1.  S (BGPN1,BGPN2,BGPN3,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8)=0
  1.  S BGPMONA=$$AGE(DFN,2,BGPBDATE)
  1.  I 'BGPACTCL S BGPSTOP=1 Q  ;must be active clinical
  1.  I BGPMONA>5,BGPMONA<60 S BGPD1=1  ;1st denominator
  1.  I BGPAGEB>4,BGPAGEB<10 S BGPD2=1  ;2nd denominator
  1.  I BGPAGEB>9,BGPAGEB<19 S BGPD3=1
  1.  I BGPAGEB>18,BGPAGEB<25 S BGPD4=1
  1.  I BGPAGEB>24,BGPAGEB<65 S BGPD5=1
  1.  I BGPAGEB>64 S BGPD6=1
  1.  I $$ACTPREG(DFN,BGPEDATE) S BGPD7=1
  1.  S T=($E(BGPBDATE,1,3)-3)_$E(BGPBDATE,4,7)
  1.  I $$HIGHRISK(DFN,T,BGPEDATE,BGPAGEB) S BGPD8=1
  1.  I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8) S BGPSTOP=1 Q  ;pt in ANY denominator so skip this patient
  1.  S BGPH1N1=$$H1N1VAC(DFN,BGPBDATE,BGPEDATE)  ;will be returned as date of 1st H1N1 dose^date of second H1N1 dose
  1.  I $P(BGPH1N1,U) S BGPN1=1
  1.  I $P(BGPH1N1,U,3) S BGPN2=1
  1.  S BGPVALUE="AC"
  1.  I BGPD7 S BGPVALUE=BGPVALUE_";PREG"
  1.  I BGPD8 S BGPVALUE=BGPVALUE_";HIGHRISK"
  1.  S BGPVALUE=BGPVALUE_"|||"
  1.  I BGPN1!(BGPN2) S BGPVALUE=BGPVALUE_$S($P(BGPH1N1,U,1):$$DATE^BGP3UTL($P(BGPH1N1,U,1))_" "_$P(BGPH1N1,U,2),1:"")
  1.  I $P(BGPH1N1,U,3) S BGPVALUE=BGPVALUE_"; "_$$DATE^BGP3UTL($P(BGPH1N1,U,3))_" "_$P(BGPH1N1,U,4)  ;:"2 doses",$P(BGPH1N1,U,1):"1 dose",1:"")_" "_$$DATE^BGP3UTL($P(BGPH1N1,U))_" "_$$DATE^BGP3UTL($P(BGPH1N1,U,2))
  1.  Q
  1. H1N1VAC(P,BDATE,EDATE) ;EP
  1.  I '$G(P) Q ""
  1.  NEW C,X,Y,Z,T,L,M,D,V,ED,BD
  1.  S T=$O(^ATXAX("B","SURVEILLANCE H1N1 CVX CODES",0))
  1.  S C=0,X=0 F  S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X  S Y=$P($G(^AUPNVIMM(X,0)),U) D
  1.  .Q:'Y
  1.  .Q:'$D(^AUTTIMM(Y,0))
  1.  .S Z=$P(^AUTTIMM(Y,0),U,3)
  1.  .Q:'$D(^ATXAX(T,21,"B",Z))
  1.  .S D=$$VD^APCLV($P(^AUPNVIMM(X,0),U,3))
  1.  .Q:D<BDATE
  1.  .Q:D>EDATE
  1.  .S C=C+1,M(D)=$$VAL^XBDIQ1(9000010.11,X,.01)
  1.  .Q
  1.  S T=$O(^ATXAX("B","SURVEILLANCE CPT H1N1",0))
  1.  ;GET ALL CPT CODES AND SET BY DATE
  1.  S ED=(9999999-EDATE),BD=9999999-BDATE
  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.  ..Q:'$D(^AUPNVCPT("AD",V))
  1.  ..S X=0 F  S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X  D
  1.  ...I $$ICD^ATXCHK($P(^AUPNVCPT(X,0),U),T,1) S C=C+1,M($$VD^APCLV(V))=$$VAL^XBDIQ1(9000010.18,X,.01)
  1.  ...Q
  1.  ..Q
  1.  .Q
  1.  I '$D(M) Q ""
  1.  S (X,D,F,S)=""
  1.  F  S D=$O(M(D)) Q:D'=+D  D
  1.  .I F="" S F=D_U_M(D) Q  ;first one
  1.  .I $$FMDIFF^XLFDT(D,F)<21 Q
  1.  .S S=D_U_M(D)
  1.  .Q
  1.  Q F_U_S
  1. AGE(P,BGPZ,BGPDT) ;EP
  1.  ;---> Return Patient's Age.
  1.  ;---> Parameters:
  1.  ;     1 - DFN  (req) IEN in PATIENT File.
  1.  ;     2 - APCLZ  (opt) APCLZ=1,2,3  1=years, 2=months, 3=days.
  1.  ;                               2 will be assumed if not passed.
  1.  ;     3 - APCLDT (opt) Date on which Age should be calculated.
  1.  ;
  1.  N BGPDOB,X,X1,X2  S:$G(APCLZ)="" APCLZ=2
  1.  Q:'$G(P) ""
  1.  I '$D(^DPT(P,0)) Q ""
  1.  S BGPDOB=$P(^DPT(P,0),U,3)
  1.  Q:'BGPDOB ""
  1.  S:'$G(DT) DT=$$DT^XLFDT
  1.  S:'$G(BGPDT) BGPDT=DT
  1.  Q:BGPDT<BGPDOB ""
  1.  ;
  1.  ;---> Age in Years.
  1.  N BGPAGEY,BGPAGEM,BGPD1,BGPD2,BGPM1,BGPM2,BGPY1,BGPY2
  1.  S BGPM1=$E(BGPDOB,4,7),BGPM2=$E(BGPDT,4,7)
  1.  S BGPY1=$E(BGPDOB,1,3),BGPY2=$E(BGPDT,1,3)
  1.  S BGPAGEY=BGPY2-BGPY1 S:BGPM2<BGPM1 BGPAGEY=BGPAGEY-1
  1.  S:BGPAGEY<1 BGPAGEY="<1"
  1.  Q:BGPZ=1 BGPAGEY
  1.  ;
  1.  ;---> Age in Months.
  1.  S BGPD1=$E(BGPM1,3,4),BGPM1=$E(BGPM1,1,2)
  1.  S BGPD2=$E(BGPM2,3,4),BGPM2=$E(BGPM2,1,2)
  1.  S BGPAGEM=12*BGPAGEY
  1.  I BGPM2=BGPM1&(BGPD2<BGPD1) S BGPAGEM=BGPAGEM+12
  1.  I BGPM2>BGPM1 S BGPAGEM=BGPAGEM+BGPM2-BGPM1
  1.  I BGPM2<BGPM1 S BGPAGEM=BGPAGEM+BGPM2+(12-BGPM1)
  1.  S:BGPD2<BGPD1 BGPAGEM=BGPAGEM-1
  1.  Q:BGPZ=2 BGPAGEM
  1.  ;
  1.  ;---> Age in Days.
  1.  S X1=BGPDT,X2=BGPDOB
  1.  D ^%DTC
  1.  Q X
  1.  ;
  1.  ;
  1. ACTPREG(P,ED) ;EP
  1.  I $P(^DPT(P,0),U,2)'="F" Q ""
  1.  NEW T,X,Y,Q,BD,BGPG,LPD,%,G
  1.  S BD=3091001  ;MEASURE IN H1N1 YEAR ONLY ****LORI CHANGE TO 309
  1.  S G=""
  1.  S T=$O(^ATXAX("B","SURVEILLANCE H1N1 PREGNANCY DX",0))
  1.  D ALLV^APCLAPIU(P,BD,ED,"APCL")
  1.  I '$D(APCL) Q ""
  1.  ;now get rid of non-amb, non-H visits, and those whose primary dx is not pregnancy
  1.  NEW APCLJ
  1.  S X=0 F  S X=$O(APCL(X)) Q:X'=+X  D
  1.  .S V=$P(APCL(X),U,5)
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .Q:"AOSHI"'[$P(^AUPNVSIT(V,0),U,7)
  1.  .S (G,Y)=0 F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(G)  D
  1.  ..S Q=$P($G(^AUPNVPOV(Y,0)),U)
  1.  ..Q:Q=""
  1.  ..Q:'$$ICD^ATXCHK(Q,T,9)  ;not in taxonomy
  1.  ..S G=1
  1.  ..S APCLJ(9999999-$P(APCL(X),U,1))=$P(APCL(X),U,1)  ;set by date to eliminate 2 on same day
  1.  .Q
  1.  S LPD=$O(APCLJ(0))  ;get date of latest
  1.  I LPD="" Q ""
  1.  S LPD=9999999-LPD  ;date of prenatal dx, find miscarriage, abortion or delivery between this date and ED
  1.  NEW BGPGF
  1.  S BGPGF=""
  1.  ;check abortion / misc dxs
  1.  K BGPG S X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_LPD_"-"_ED S E=$$START1^APCLDF(X,"APCL(")
  1.  I $D(BGPG) Q ""  ;FOUND SO NOT PREG ANYMORE
  1.  K BGPG S BGPG=$$LASTPRC^BGP3UTL1(P,"BGP ABORTION PROCEDURES",LPD,ED)
  1.  I BGPG Q ""  ;FOUND SO NOT PREG ANYMORE
  1.  ;now check CPTs for Abortion and Miscarriage
  1.  S %=$$LASTCPTT^APCLAPIU(P,LPD,ED,"BGP CPT ABORTION","D")
  1.  I %]"" Q ""
  1.  S %=$$LASTCPTT^APCLAPIU(P,LPD,ED,"BGP CPT MISCARRIAGE","D")
  1.  I %]"" Q ""
  1.  Q 1
  1. HIGHRISK(P,BDATE,EDATE,AGEB) ;
  1.  I AGEB<25 Q ""
  1.  I AGEB>64 Q ""
  1.  ;get all povs that meet definition in past 3 years, remove those on same date and count for 2
  1.  NEW BGPDX,BGPG,CNT
  1.  K BGPG
  1.  S Y="BGPG(",CNT=0
  1.  S X=P_"^ALL DX [BGP H1N1 HIGH RISK;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1.  ;now reorder by date of diagnosis and eliminate all on same date
  1.  I '$D(BGPG) G PROB  ;no diagnoses
  1.  S B=0,X=0 F  S X=$O(BGPG(X)) Q:X'=+X!(CNT=2)  D
  1.  .;get date
  1.  .S D=$P(BGPG(X),U,1)
  1.  .Q:$D(BGPDX(D))
  1.  .S BGPDX(D)="",CNT=CNT+1 I CNT=2 S BGPD=D
  1.  .Q
  1.  I CNT>1 Q 1  ;is high risk
  1. PROB ;
  1.  S T=$O(^ATXAX("B","BGP H1N1 HIGH RISK",0))
  1.  S (X,G)=0 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G)  D
  1.  .Q:$P(^AUPNPROB(X,0),U,12)'="A"
  1.  .Q:$P(^AUPNPROB(X,0),U,8)>EDATE
  1.  .Q:$P(^AUPNPROB(X,0),U,8)<BDATE
  1.  .S Y=$P(^AUPNPROB(X,0),U)
  1.  .Q:'$$ICD^ATXCHK(Y,T,9)
  1.  .S G=$P(^AUPNPROB(X,0),U,8)
  1.  .Q
  1.  Q G