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

BGP0D81.m

Go to the documentation of this file. 
  1. BGP0D81 ; IHS/CMI/LAB - measure C ;
  1.  ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
  1.  ;
  1. IAST1 ;EP
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12)=0
  1.  I 'BGPACTUP S BGPSTOP=1 Q
  1.  I BGPAGEB<1 S BGPSTOP=1 Q  ;not 1 or older
  1.  S BGPVAL=$$V2ASTH(DFN,BGPBDATE,BGPEDATE) I 'BGPVAL S BGPSTOP=1 Q  ;no asthma visits or persistent in ats
  1.  I BGPACTCL S BGPD1=1
  1.  I BGPACTCL,BGPAGEB>0,BGPAGEB<5 S BGPD2=1
  1.  I BGPACTCL,BGPAGEB>4,BGPAGEB<20 S BGPD3=1
  1.  I BGPACTCL,BGPAGEB>19,BGPAGEB<45 S BGPD4=1
  1.  I BGPACTCL,BGPAGEB>44,BGPAGEB<65 S BGPD5=1
  1.  I BGPACTCL,BGPAGEB>64 S BGPD6=1
  1.  I BGPACTUP S BGPD7=1
  1.  I BGPACTUP,BGPAGEB>0,BGPAGEB<5 S BGPD8=1
  1.  I BGPACTUP,BGPAGEB>4,BGPAGEB<20 S BGPD9=1
  1.  I BGPACTUP,BGPAGEB>19,BGPAGEB<45 S BGPD10=1
  1.  I BGPACTUP,BGPAGEB>44,BGPAGEB<65 S BGPD11=1
  1.  I BGPACTUP,BGPAGEB>64 S BGPD12=1
  1.  S BGPV=$$INHALED(DFN,BGPBDATE,BGPEDATE)
  1.  S BGPN1=+BGPV
  1.  S BGPVALUE="UP"_$S(BGPD1:";AC",1:"")_" "_$P(BGPVAL,U,2)_"|||"_$S($P(BGPV,U)=1:$P(BGPV,U,2)_" on "_$P(BGPV,U,3),1:"")
  1.  K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
  1.  Q
  1. V2ASTH(P,BDATE,EDATE) ;EP
  1.  I '$G(P) Q ""
  1.  I $$ASEX(P,EDATE) Q ""  ;exclusion
  1.  ;find problem list active for asthma with 2, 3 or 4 in 15th piece
  1.  NEW S,A,B,T,X,G,V,Y,EDATE1
  1.  S G=""
  1.  S T=$O(^ATXAX("B","BGP ASTHMA DXS",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,8)>EDATE  ;if added to pl after end of time period
  1.  .S Y=$P(^AUPNPROB(X,0),U)
  1.  .Q:$P(^AUPNPROB(X,0),U,12)'="A"
  1.  .Q:'$$ICD^ATXCHK(Y,T,9)
  1.  .Q:$P(^AUPNPROB(X,0),U,15)=""
  1.  .Q:$P(^AUPNPROB(X,0),U,15)<2
  1.  .S G=1_U_"PL "_$P(^ICD9(Y,0),U)_"=Pers: "_$P(^AUPNPROB(X,0),U,15)
  1.  .Q
  1.  I G Q G
  1.  ;I $P($G(^BATREG(P,0)),U,2)'="A" G DXS  ;not active on asthma register
  1.  S S=""
  1.  S EDATE1=9999999-EDATE-1
  1.  S D=$O(^AUPNVAST("AS",P,EDATE1))
  1.  I 'D G DXS
  1.  S LAST="",E=0 F  S E=$O(^AUPNVAST("AS",P,D,E)) Q:E'=+E  S LAST=E
  1.  I 'LAST G DXS
  1.  S S=^AUPNVAST("AS",P,D,LAST)
  1.  I S>1 Q 1_U_"V Asthma=Pers"
  1. DXS I '$D(^AUPNVSIT("AC",P)) Q ""
  1.  K ^TMP($J,"A")
  1.  S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
  1.  I '$D(^TMP($J,"A",1)) Q ""
  1.  S T=$O(^ATXAX("B","BGP ASTHMA DXS",0))
  1.  I 'T Q ""
  1.  S (X,G)=0 F  S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G>2)  S V=$P(^TMP($J,"A",X),U,5) D
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .Q:'$P(^AUPNVSIT(V,0),U,9)
  1.  .Q:$P(^AUPNVSIT(V,0),U,11)
  1.  .Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
  1.  .S (D,Y)=0 F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D)  I $D(^AUPNVPOV(Y,0)) S %=$P(^AUPNVPOV(Y,0),U) I $$ICD^ATXCHK(%,T,9) S D=1
  1.  .Q:'D
  1.  .S G=G+1
  1.  .Q
  1.  I G>1 Q 1_U_"2 DXs"
  1.  Q ""
  1. ASEX(P,EDATE) ;
  1.  ;2010 - exclusion changed to be active problem with intermittent asthma
  1.  ;now check problem list
  1.  NEW T,G,X,Y
  1.  S T=$O(^ATXAX("B","BGP ASTHMA DXS",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,8)>EDATE  ;if added to pl after end of time period
  1.  .S Y=$P(^AUPNPROB(X,0),U)
  1.  .Q:$P(^AUPNPROB(X,0),U,12)'="A"
  1.  .Q:'$$ICD^ATXCHK(Y,T,9)
  1.  .Q:$P(^AUPNPROB(X,0),U,15)'=1
  1.  .S G=1
  1.  .Q
  1.  I G Q G
  1.  ;I $P($G(^BATREG(P,0)),U,2)'="A" Q ""  ;not active on asthma register
  1.  NEW EDATE1,D
  1.  S EDATE1=9999999-EDATE-1
  1.  S D=$O(^AUPNVAST("AS",P,EDATE1))
  1.  I 'D Q ""
  1.  ;I D>(9999999-BDATE) Q ""
  1.  S LAST="",E=0 F  S E=$O(^AUPNVAST("AS",P,D,E)) Q:E'=+E  S LAST=E
  1.  I 'LAST Q ""
  1.  S S=^AUPNVAST("AS",P,D,LAST)
  1.  I S=1 Q 1
  1.  Q ""
  1. LAST(P,BDATE,EDATE) ;EP last asthma dx
  1.  K BGPG
  1.  S Y="BGPG("
  1.  S X=P_"^LAST DX [BGP ASTHMA DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1.  I $D(BGPG(1)) Q $$DATE^BGP0UTL($P(BGPG(1),U))_" "_$P(BGPG(1),U,2)
  1.  Q ""
  1. NDC(A,B) ;
  1.  ;a is drug ien
  1.  ;b is taxonomy ien
  1.  S BGPNDC=$P($G(^PSDRUG(A,2)),U,4)
  1.  I BGPNDC]"",B,$D(^ATXAX(B,21,"B",BGPNDC)) Q 1
  1.  Q 0
  1. LEUK(A,B,C) ;
  1.  ;a drug ien
  1.  ;b tax ien
  1.  ;c tax ien for ndc
  1.  I $D(^ATXAX(B,21,"B",A)) Q 1
  1.  I $$NDC(A,C) Q 1
  1.  Q ""
  1. INHALED(P,BDATE,EDATE) ;EP - any inhaled steroid?
  1.  K BGPMEDS1
  1.  D GETMEDS^BGP0UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
  1.  I '$D(BGPMEDS1) Q ""
  1.  S T1=$O(^ATXAX("B","BGP ASTHMA INHALED STEROIDS",0))
  1.  S T4=$O(^ATXAX("B","BGP ASTHMA INHALED STEROID NDC",0))
  1.  S (X,G,M,E)=0,D="" F  S X=$O(BGPMEDS1(X)) Q:X'=+X!(D]"")  S V=$P(BGPMEDS1(X),U,5),Y=+$P(BGPMEDS1(X),U,4) D
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
  1.  .I $D(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4)),$P(^AUPNVMED(Y,0),U,8)="" S D=1_U_$P(^PSDRUG(Z,0),U)_U_$$DATE^BGP0UTL($P($P(^AUPNVSIT(V,0),U),".")) Q  ;it is an inhaled steroid that wasn't d/c'ed so 1 dispensing event
  1.  Q D