BGP4D81.m

BGP4D81 ; IHS/CMI/LAB - measure C ; 17 Oct 2013  8:51 AM

 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114

 ;

IAST1 ;EP

 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12)=0

 I 'BGPACTUP S BGPSTOP=1 Q

 I BGPAGEB<1 S BGPSTOP=1 Q  ;not 1 or older

 S BGPVAL=$$V2ASTH(DFN,BGPBDATE,BGPEDATE) I 'BGPVAL S BGPSTOP=1 Q  ;no asthma visits or persistent in ats

 I BGPACTCL S BGPD1=1

 I BGPACTCL,BGPAGEB>0,BGPAGEB<5 S BGPD2=1

 I BGPACTCL,BGPAGEB>4,BGPAGEB<20 S BGPD3=1

 I BGPACTCL,BGPAGEB>19,BGPAGEB<45 S BGPD4=1

 I BGPACTCL,BGPAGEB>44,BGPAGEB<65 S BGPD5=1

 I BGPACTCL,BGPAGEB>64 S BGPD6=1

 I BGPACTUP S BGPD7=1

 I BGPACTUP,BGPAGEB>0,BGPAGEB<5 S BGPD8=1

 I BGPACTUP,BGPAGEB>4,BGPAGEB<20 S BGPD9=1

 I BGPACTUP,BGPAGEB>19,BGPAGEB<45 S BGPD10=1

 I BGPACTUP,BGPAGEB>44,BGPAGEB<65 S BGPD11=1

 I BGPACTUP,BGPAGEB>64 S BGPD12=1

 S BGPV=$$INHALED(DFN,BGPBDATE,BGPEDATE)

 S BGPN1=+BGPV

 S BGPVALUE="UP"_$S(BGPD1:";AC",1:"")_" "_$P(BGPVAL,U,2)_"|||"_$S($P(BGPV,U)=1:"NUM: "_$P(BGPV,U,3)_" "_$P(BGPV,U,2),1:"")

 K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T

 Q

V2ASTH(P,BDATE,EDATE) ;EP

 I '$G(P) Q ""

 I $$ASEX(P,EDATE) Q ""  ;exclusion

 ;find problem list active for asthma with 2, 3 or 4 in 15th piece

 NEW S,A,B,T,X,G,V,Y,EDATE1

 S G=""

 S T=$O(^ATXAX("B","BGP ASTHMA DXS",0))

 S (X,G)=0 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G)  D

 .Q:$P(^AUPNPROB(X,0),U,8)>EDATE  ;if added to pl after end of time period

 .S Y=$P(^AUPNPROB(X,0),U)

 .Q:$P(^AUPNPROB(X,0),U,12)="D"

 .Q:$P(^AUPNPROB(X,0),U,12)="I"

 .Q:'$$ICD^BGP4UTL2(Y,T,9)

 .Q:$P(^AUPNPROB(X,0),U,15)=""

 .Q:$P(^AUPNPROB(X,0),U,15)<2

 .S G=1_U_"PL "_$P(^ICD9(Y,0),U)_"=Pers: "_$P(^AUPNPROB(X,0),U,15)

 .Q

 I G Q G

 ;I $P($G(^BATREG(P,0)),U,2)'="A" G DXS  ;not active on asthma register

 S S=""

 S EDATE1=9999999-EDATE-1

 S D=$O(^AUPNVAST("AS",P,EDATE1))

 I 'D G DXS

 S LAST="",E=0 F  S E=$O(^AUPNVAST("AS",P,D,E)) Q:E'=+E  S LAST=E

 I 'LAST G DXS

 S S=^AUPNVAST("AS",P,D,LAST)

 I S>1 Q 1_U_"V Asthma=Pers"

DXS I '$D(^AUPNVSIT("AC",P)) Q ""

 K ^TMP($J,"A")

 S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)

 I '$D(^TMP($J,"A",1)) Q ""

 S T=$O(^ATXAX("B","BGP ASTHMA DXS",0))

 I 'T Q ""

 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

 .Q:'$D(^AUPNVSIT(V,0))

 .Q:'$P(^AUPNVSIT(V,0),U,9)

 .Q:$P(^AUPNVSIT(V,0),U,11)

 .Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)

 .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^BGP4UTL2(%,T,9) S D=1

 .Q:'D

 .S G=G+1

 .Q

 I G>1 Q 1_U_"2 DXs"

 Q ""

ASEX(P,EDATE) ;

 ;2014 - exclusion changed to be active problem with intermittent asthma

 ;now check problem list

 NEW T,G,X,Y

 S T=$O(^ATXAX("B","BGP ASTHMA DXS",0))

 S (X,G)=0 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G)  D

 .Q:$P(^AUPNPROB(X,0),U,8)>EDATE  ;if added to pl after end of time period

 .S Y=$P(^AUPNPROB(X,0),U)

 .Q:$P(^AUPNPROB(X,0),U,12)="D"

 .Q:$P(^AUPNPROB(X,0),U,12)="I"

 .Q:'$$ICD^BGP4UTL2(Y,T,9)

 .Q:$P(^AUPNPROB(X,0),U,15)'=1

 .S G=1

 .Q

 I G Q G

 ;I $P($G(^BATREG(P,0)),U,2)'="A" Q ""  ;not active on asthma register

 NEW EDATE1,D

 S EDATE1=9999999-EDATE-1

 S D=$O(^AUPNVAST("AS",P,EDATE1))

 I 'D Q ""

 ;I D>(9999999-BDATE) Q ""

 S LAST="",E=0 F  S E=$O(^AUPNVAST("AS",P,D,E)) Q:E'=+E  S LAST=E

 I 'LAST Q ""

 S S=^AUPNVAST("AS",P,D,LAST)

 I S=1 Q 1

 Q ""

LAST(P,BDATE,EDATE) ;EP last asthma dx

 K BGPG

 S Y="BGPG("

 S X=P_"^LAST DX [BGP ASTHMA DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)

 I $D(BGPG(1)) Q $$DATE^BGP4UTL($P(BGPG(1),U))_" "_$P(BGPG(1),U,2)

 Q ""

NDC(A,B) ;

 ;a is drug ien

 ;b is taxonomy ien

 S BGPNDC=$P($G(^PSDRUG(A,2)),U,4)

 I BGPNDC]"",B,$D(^ATXAX(B,21,"B",BGPNDC)) Q 1

 Q 0

LEUK(A,B,C) ;

 ;a drug ien

 ;b tax ien

 ;c tax ien for ndc

 I $D(^ATXAX(B,21,"B",A)) Q 1

 I $$NDC(A,C) Q 1

 Q ""

INHALED(P,BDATE,EDATE) ;EP - any inhaled steroid?

 NEW BGPMEDS1,T1,T4,X,G,M,E,T,Y,V,Z

 D GETMEDS^BGP4UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)

 I '$D(BGPMEDS1) Q ""

 S T1=$O(^ATXAX("B","BGP PQA ASTHMA INHALE STER MED",0))

 S T4=$O(^ATXAX("B","BGP PQA ASTHMA INHALE STER NDC",0))

 S (X,G,M,E,T)=0,D="" F  S X=$O(BGPMEDS1(X)) Q:X'=+X!(T>1)  S V=$P(BGPMEDS1(X),U,5),Y=+$P(BGPMEDS1(X),U,4) D

 .Q:'$D(^AUPNVSIT(V,0))

 .Q:'$D(^AUPNVMED(Y,0))

 .Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"

 .S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien

 .I $D(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4)),'$$STATDC(Y) D

 ..S T=T+1

 ..I D="" S D=1_U_$$DATE^BGP4UTL($P($P(^AUPNVSIT(V,0),U),"."))_$P(^PSDRUG(Z,0),U) Q  ;it is an inhaled steroid that wasn't d/c'ed so 1 dispensing event

 ..S D=D_", "_$$DATE^BGP4UTL($P($P(^AUPNVSIT(V,0),U),"."))_" "_$P(^PSDRUG(Z,0),U)

 I T<2 Q ""

 Q D

VAPI(A,B) ;EP

 ;a is drug ien

 ;b is taxonomy ien

 NEW Z,Y

 S Z=$$GET1^DIQ(50,A,22,"I")  ;INTERNAL

 I 'Z Q 0

 S Y=$$GET1^DIQ(50.68,Z,6)

 I Y="" Q 0

 I $D(^ATXAX(B,21,"B",Y)) Q 1

 Q 0

STATDC(V) ;EP - is the prescription associated with this V MED discontinued?

 I '$G(V) Q ""

 I '$D(^AUPNVMED(V,0)) Q 0

 NEW P,S,X

 S P=$S($D(^PSRX("APCC",V)):$O(^(V,0)),1:0)

 I 'P Q 0

 S X=$P($G(^PSRX(P,0)),U,15)

 I X=12 Q 1

 I X=13 Q 1

 I X=14 Q 1

 I X=15 Q 1

 S X=$P($G(^PSRX(P,"STA")),U,1)

 I X=12 Q 1

 I X=13 Q 1

 I X=14 Q 1

 I X=15 Q 1

 Q 0

 ;

ASTHTHER ;EP

 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPCON3,BGPD1)=0

 NEW BGPSABA,BGPCON3,BGPASTH1,BGPASTH2,BGPCORT,BGPCICS

 I 'BGPACTCL S BGPSTOP=1 Q

 I BGPAGEB<5 S BGPSTOP=1 Q  ;not 5 or older

 ;I BGPAGEB>50 S BGPSTOP=1 Q  ;over 50

 ;S BGPVAL=$$V2ASTH(DFN,BGPBDATE,BGPEDATE) I 'BGPVAL S BGPSTOP=1 Q  ;no asthma visits or persistent in ats

 I $$EMP^BGP4D22(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) S BGPSTOP=1 Q  ;has dx of emphysema

 I $$COPD^BGP4D22(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) S BGPSTOP=1 Q  ;has copd

 S (BGPASTH1,BGPASTH2)=$$ASSEV^BGP4D22(DFN,BGPEDATE)

 I BGPASTH1="" S BGPASTH1=$$PERASTH^BGP4D22(DFN,$$FMADD^XLFDT(BGPBDATE,-365),BGPBDATE)

 I BGPASTH2="" S BGPASTH2=$$PERASTH^BGP4D22(DFN,BGPBDATE,BGPEDATE)

 I 'BGPASTH1!('BGPASTH2) K ^TMP($J,"A") S BGPSTOP=1 Q  ;not asthma in both time periods

 K ^TMP($J,"A")

 I BGPAGEB<51 S BGPD1=1

 S BGPD2=1  ;ALL 5-50

 I BGPAGEB>4,BGPAGEB<15 S BGPD3=1

 I BGPAGEB>15,BGPAGEB<35 S BGPD4=1

 I BGPAGEB>34,BGPAGEB<65 S BGPD5=1

 I BGPAGEB>64 S BGPD6=1

 S BGPVALUE="AC,"_$P(BGPASTH1,U,2)_" "_$S(BGPASTH1'=BGPASTH2:$P(BGPASTH2,U,2),1:"")_"|||"

 S BGPSABA=$$SABA(DFN,BGPBDATE,BGPEDATE)      ;1 (HAD 4 CANISTERS)^1 (HAD CONTROLLER)^LIST DISPLAY

 K ^TMP($J,"A"),BGPMEDS1

 S BGPVALUE=BGPVALUE_$P(BGPSABA,U,3) I $P(BGPSABA,U,2) S BGPVALUE=BGPVALUE_"; "_$P(BGPSABA,U,4)

 I $P(BGPSABA,U,1) S BGPN1=1

 I $P(BGPSABA,U,1),'$P(BGPSABA,U,2) S BGPN2=1  ;HAD SABA BUT NO CONTROLLER

 ;numerator 3 had 2 OR MORE CONTROLLER THERAPIES

 S BGPCON3=$$CONT(DFN,BGPBDATE,BGPEDATE)

 I $P(BGPCON3,U,1) S BGPN3=1 S:$P(BGPVALUE,"|||",2)]"" BGPVALUE=BGPVALUE_"; " S BGPVALUE=BGPVALUE_"2+ CONT: "_$P(BGPCON3,U,2)

 S BGPCICS=$$INHALED(DFN,BGPBDATE,BGPEDATE)

 I $P(BGPCICS,U,1) S BGPN4=1 S:$P(BGPVALUE,"|||",2)]"" BGPVALUE=BGPVALUE_"; " S BGPVALUE=BGPVALUE_"2+ STEROID: "_$P(BGPCICS,U,2)

 ;denominator 7 had 2 or more laba meds during report period

 S BGPLABA=$$LABA(DFN,BGPBDATE,BGPEDATE)

 I $P(BGPLABA,U,1) D

 .S BGPD7=1 S $P(BGPVALUE,"|||",1)=$P(BGPVALUE,"|||",1)_", LABA"

 .I BGPAGEB>5,BGPAGEB<15 S BGPD8=1

 .I BGPAGEB>15,BGPAGEB<35 S BGPD9=1

 .I BGPAGEB>34,BGPAGEB<65 S BGPD10=1

 .I BGPAGEB>64 S BGPD11=1

 K BGPSABA,BGPVAL

 Q

SABA(P,BDATE,EDATE) ;EP - any SABA?

 K ^TMP($J,"A")

 NEW A,B,E,Z,X,D,V,Y,G,M,T,T1,BGPMEDS1,C,BGPISD,BGPMP,DAYS,LEND,SD,DC,N,S,PER,GAP,Q,V1,V1D,M1,TQ,QG

 K BGPMEDS1

 D GETMEDS^BGP4UTL2(P,BDATE,EDATE,"BGP PQA SABA MEDS","BGP PQA SABA NDC",,,.BGPMEDS1)

 I '$D(BGPMEDS1) Q ""  ; no beta blocker meds

 S BGPISD=""

 S (A,C)=0 F  S A=$O(BGPMEDS1(A)) Q:A'=+A  D

 .S M=$P(BGPMEDS1(A),U,4)  ;IEN OF V MED

 .Q:'$D(^AUPNVMED(M,0))

 .I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" K BGPMEDS1(A) Q

 .I $$STATDC(M) K BGPMEDS1(A) Q  ;d/c'ed BY PROVIDER OR EDIT

 .S Q=$P(^AUPNVMED(M,0),U,6) I 'Q K BGPMEDS1(A) Q  ;no quantity

 ;now go through and see if there are a quantity of 4 in any 90 day period

 S Q=0,G=""

 S X=0 F  S X=$O(BGPMEDS1(X)) Q:X'=+X!(G)  D CHK90

 I 'G Q G

 ;CHECK FOR CONTROLLER BETWEEN SD AND E

 K BGPMEDS1,^TMP($J,"A")

 D GETMEDS^BGP4UTL2(P,SD,E,"BGP PQA CONTROLLER MEDS","BGP PQA CONTROLLER NDC",,,.BGPMEDS1)

 I '$D(BGPMEDS1) Q G  ; no CONTROLLER meds

 S BGPISD=""

 S A=0,C="" F  S A=$O(BGPMEDS1(A)) Q:A'=+A!(C)  D

 .S M=$P(BGPMEDS1(A),U,4)  ;IEN OF V MED

 .Q:'$D(^AUPNVMED(M,0))

 .I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" K BGPMEDS1(A) Q

 .I $$STATDC(M) K BGPMEDS1(A) Q  ;d/c'ed BY PROVIDER OR EDIT

 .S V=$P(BGPMEDS1(A),U,5)

 .S V1D=$$VD^APCLV(V)

 .S C=1_U_"CONT THPY: "_$$DATE^BGP4UTL(V1D)_" "_$$VAL^XBDIQ1(9000010.14,M,.01)

 I 'C Q G

 S $P(G,U,2)=1,$P(G,U,4)=$P(C,U,2)

 K BGPMEDS1,^TMP($J,"A")

 Q G

CANI(D,Q) ;get order unit from drug entry and divide by quantity.

 NEW O

 ;GET ORDER UNITS

 S O=$P($G(^PSDRUG(D,660)),U,5)

 I O="" Q Q

 Q Q/O

CHK90 ;

 ;get date of med and add 90 days

 S G=""

 K T

 S C=0

 S V=$P(BGPMEDS1(X),U,5)

 S SD=$$VD^APCLV(V)  ;start date of med

 S E=$$FMADD^XLFDT(SD,90)  ;add 90 days

 S M=$P(BGPMEDS1(X),U,4)

 S QG=$P(^AUPNVMED(M,0),U,6)  ;# of canisters

 S (TQ,Q)=$$CANI($P(^AUPNVMED(M,0),U,1),QG)

 S C=C+1,T(C)=$$DATE^BGP4UTL(SD)_U_$$VAL^XBDIQ1(9000010.14,M,.01)_U_"("_Q_")"

 S Y=X F  S Y=$O(BGPMEDS1(Y)) Q:Y'=+Y  D

 .S V1=$P(BGPMEDS1(Y),U,5)

 .S V1D=$$VD^APCLV(V1)

 .Q:V1D>E  ;after the 90 days

 .S M1=$P(BGPMEDS1(Y),U,4)

 .S QG=$P(^AUPNVMED(M1,0),U,6)  ;# of canisters

 .S Q=$$CANI($P(^AUPNVMED(M1,0),U,1),QG)

 .S C=C+1,T(C)=$$DATE^BGP4UTL(V1D)_U_$$VAL^XBDIQ1(9000010.14,M1,.01)_U_" ("_Q_")"

 .S TQ=TQ+Q

 Q:TQ<4

 S D=0,Z="" F  S D=$O(T(D)) Q:D'=+D  S Z=Z_$S(Z]"":" ",1:""),Z=Z_$P(T(D),U,1)_" "_$P(T(D),U,2)_$P(T(D),U,3)

 S G=1_U_0_U_"SABA: "_Z_U

 Q

CONT(P,BDATE,EDATE) ;controller meds (at least 2)

 NEW A,C,G,V1D,BGPMEDS1,T

 K BGPMEDS1,^TMP($J,"A")

 D GETMEDS^BGP4UTL2(P,BDATE,EDATE,"BGP PQA CONTROLLER MEDS","BGP PQA CONTROLLER NDC",,,.BGPMEDS1)

 S G=""

 I '$D(BGPMEDS1) Q G  ; no CONTROLLER meds

 S BGPISD=""

 S A=0,C="",T=0 F  S A=$O(BGPMEDS1(A)) Q:A'=+A!(T>1)  D

 .S M=$P(BGPMEDS1(A),U,4)  ;IEN OF V MED

 .Q:'$D(^AUPNVMED(M,0))

 .I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" K BGPMEDS1(A) Q

 .I $$STATDC(M) K BGPMEDS1(A) Q  ;d/c'ed BY PROVIDER OR EDIT

 .S V=$P(BGPMEDS1(A),U,5)

 .S V1D=$$VD^APCLV(V)

 .S T=T+1

 .I C="" S C=1_U_""_$$DATE^BGP4UTL(V1D)_" "_$$VAL^XBDIQ1(9000010.14,M,.01) I 1

 .E  S C=C_", "_$$DATE^BGP4UTL(V1D)_" "_$$VAL^XBDIQ1(9000010.14,M,.01)

 I T>1 Q C

 Q ""

 ;

LABA(P,BDATE,EDATE) ;EP - any inhaled steroid?

 NEW BGPMEDS1,T1,T4,X,G,M,E,T,Y,V,Z

 D GETMEDS^BGP4UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)

 I '$D(BGPMEDS1) Q ""

 S T1=$O(^ATXAX("B","BGP ASTHMA LABA MEDS",0))

 S T4=$O(^ATXAX("B","BGP ASTHMA LABA NDC",0))

 S (X,G,M,E,T)=0,D="" F  S X=$O(BGPMEDS1(X)) Q:X'=+X!(T>1)  S V=$P(BGPMEDS1(X),U,5),Y=+$P(BGPMEDS1(X),U,4) D

 .Q:'$D(^AUPNVSIT(V,0))

 .Q:'$D(^AUPNVMED(Y,0))

 .Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"

 .S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien

 .I $D(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4)),'$$STATDC(Y) D

 ..S T=T+1

 ..I D="" S D=1_U_"LABA: "_$P(^PSDRUG(Z,0),U)_U_$$DATE^BGP4UTL($P($P(^AUPNVSIT(V,0),U),".")) Q  ;it is an inhaled steroid that wasn't d/c'ed so 1 dispensing event

 ..S D=D_", "_$P(^PSDRUG(Z,0),U)_U_$$DATE^BGP4UTL($P($P(^AUPNVSIT(V,0),U),"."))

 I T<2 Q ""

 Q D

BGP4D81   ; IHS/CMI/LAB - measure C ; 17 Oct 2013  8:51 AM

 +1       ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114

 +2       ;

IAST1     ;EP

 +1        SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12)=0

 +2        IF 'BGPACTUP

               SET BGPSTOP=1

               QUIT 

 +3       ;not 1 or older

           IF BGPAGEB<1

               SET BGPSTOP=1

               QUIT 

 +4       ;no asthma visits or persistent in ats

           SET BGPVAL=$$V2ASTH(DFN,BGPBDATE,BGPEDATE)

           IF 'BGPVAL

               SET BGPSTOP=1

               QUIT 

 +5        IF BGPACTCL

               SET BGPD1=1

 +6        IF BGPACTCL

               IF BGPAGEB>0

                   IF BGPAGEB<5

                       SET BGPD2=1

 +7        IF BGPACTCL

               IF BGPAGEB>4

                   IF BGPAGEB<20

                       SET BGPD3=1

 +8        IF BGPACTCL

               IF BGPAGEB>19

                   IF BGPAGEB<45

                       SET BGPD4=1

 +9        IF BGPACTCL

               IF BGPAGEB>44

                   IF BGPAGEB<65

                       SET BGPD5=1

 +10       IF BGPACTCL

               IF BGPAGEB>64

                   SET BGPD6=1

 +11       IF BGPACTUP

               SET BGPD7=1

 +12       IF BGPACTUP

               IF BGPAGEB>0

                   IF BGPAGEB<5

                       SET BGPD8=1

 +13       IF BGPACTUP

               IF BGPAGEB>4

                   IF BGPAGEB<20

                       SET BGPD9=1

 +14       IF BGPACTUP

               IF BGPAGEB>19

                   IF BGPAGEB<45

                       SET BGPD10=1

 +15       IF BGPACTUP

               IF BGPAGEB>44

                   IF BGPAGEB<65

                       SET BGPD11=1

 +16       IF BGPACTUP

               IF BGPAGEB>64

                   SET BGPD12=1

 +17       SET BGPV=$$INHALED(DFN,BGPBDATE,BGPEDATE)

 +18       SET BGPN1=+BGPV

 +19       SET BGPVALUE="UP"_$SELECT(BGPD1:";AC",1:"")_" "_$PIECE(BGPVAL,U,2)_"|||"_$SELECT($PIECE(BGPV,U)=1:"NUM: "_$PIECE(BGPV,U,3)_" "_$PIECE(BGPV,U,2),1:"")

 +20       KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T

 +21       QUIT 

V2ASTH(P,BDATE,EDATE) ;EP

 +1        IF '$GET(P)

               QUIT ""

 +2       ;exclusion

           IF $$ASEX(P,EDATE)

               QUIT ""

 +3       ;find problem list active for asthma with 2, 3 or 4 in 15th piece

 +4        NEW S,A,B,T,X,G,V,Y,EDATE1

 +5        SET G=""

 +6        SET T=$ORDER(^ATXAX("B","BGP ASTHMA DXS",0))

 +7        SET (X,G)=0

           FOR 

               SET X=$ORDER(^AUPNPROB("AC",P,X))

               IF X'=+X!(G)

                   QUIT 

               Begin DoDot:1

 +8       ;if added to pl after end of time period

                   IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE

                       QUIT 

 +9                SET Y=$PIECE(^AUPNPROB(X,0),U)

 +10               IF $PIECE(^AUPNPROB(X,0),U,12)="D"

                       QUIT 

 +11               IF $PIECE(^AUPNPROB(X,0),U,12)="I"

                       QUIT 

 +12               IF '$$ICD^BGP4UTL2(Y,T,9)

                       QUIT 

 +13               IF $PIECE(^AUPNPROB(X,0),U,15)=""

                       QUIT 

 +14               IF $PIECE(^AUPNPROB(X,0),U,15)<2

                       QUIT 

 +15               SET G=1_U_"PL "_$PIECE(^ICD9(Y,0),U)_"=Pers: "_$PIECE(^AUPNPROB(X,0),U,15)

 +16               QUIT 

               End DoDot:1

 +17       IF G

               QUIT G

 +18      ;I $P($G(^BATREG(P,0)),U,2)'="A" G DXS  ;not active on asthma register

 +19       SET S=""

 +20       SET EDATE1=9999999-EDATE-1

 +21       SET D=$ORDER(^AUPNVAST("AS",P,EDATE1))

 +22       IF 'D

               GOTO DXS

 +23       SET LAST=""

           SET E=0

           FOR 

               SET E=$ORDER(^AUPNVAST("AS",P,D,E))

               IF E'=+E

                   QUIT 

               SET LAST=E

 +24       IF 'LAST

               GOTO DXS

 +25       SET S=^AUPNVAST("AS",P,D,LAST)

 +26       IF S>1

               QUIT 1_U_"V Asthma=Pers"

DXS        IF '$DATA(^AUPNVSIT("AC",P))

               QUIT ""

 +1        KILL ^TMP($JOB,"A")

 +2        SET A="^TMP($J,""A"","

           SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)

           SET E=$$START1^APCLDF(B,A)

 +3        IF '$DATA(^TMP($JOB,"A",1))

               QUIT ""

 +4        SET T=$ORDER(^ATXAX("B","BGP ASTHMA DXS",0))

 +5        IF 'T

               QUIT ""

 +6        SET (X,G)=0

           FOR 

               SET X=$ORDER(^TMP($JOB,"A",X))

               IF X'=+X!(G>2)

                   QUIT 

               SET V=$PIECE(^TMP($JOB,"A",X),U,5)

               Begin DoDot:1

 +7                IF '$DATA(^AUPNVSIT(V,0))

                       QUIT 

 +8                IF '$PIECE(^AUPNVSIT(V,0),U,9)

                       QUIT 

 +9                IF $PIECE(^AUPNVSIT(V,0),U,11)

                       QUIT 

 +10               IF "SAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)

                       QUIT 

 +11               SET (D,Y)=0

                   FOR 

                       SET Y=$ORDER(^AUPNVPOV("AD",V,Y))

                       IF Y'=+Y!(D)

                           QUIT 

                       IF $DATA(^AUPNVPOV(Y,0))

                           SET %=$PIECE(^AUPNVPOV(Y,0),U)

                           IF $$ICD^BGP4UTL2(%,T,9)

                               SET D=1

 +12               IF 'D

                       QUIT 

 +13               SET G=G+1

 +14               QUIT 

               End DoDot:1

 +15       IF G>1

               QUIT 1_U_"2 DXs"

 +16       QUIT ""

ASEX(P,EDATE) ;

 +1       ;2014 - exclusion changed to be active problem with intermittent asthma

 +2       ;now check problem list

 +3        NEW T,G,X,Y

 +4        SET T=$ORDER(^ATXAX("B","BGP ASTHMA DXS",0))

 +5        SET (X,G)=0

           FOR 

               SET X=$ORDER(^AUPNPROB("AC",P,X))

               IF X'=+X!(G)

                   QUIT 

               Begin DoDot:1

 +6       ;if added to pl after end of time period

                   IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE

                       QUIT 

 +7                SET Y=$PIECE(^AUPNPROB(X,0),U)

 +8                IF $PIECE(^AUPNPROB(X,0),U,12)="D"

                       QUIT 

 +9                IF $PIECE(^AUPNPROB(X,0),U,12)="I"

                       QUIT 

 +10               IF '$$ICD^BGP4UTL2(Y,T,9)

                       QUIT 

 +11               IF $PIECE(^AUPNPROB(X,0),U,15)'=1

                       QUIT 

 +12               SET G=1

 +13               QUIT 

               End DoDot:1

 +14       IF G

               QUIT G

 +15      ;I $P($G(^BATREG(P,0)),U,2)'="A" Q ""  ;not active on asthma register

 +16       NEW EDATE1,D

 +17       SET EDATE1=9999999-EDATE-1

 +18       SET D=$ORDER(^AUPNVAST("AS",P,EDATE1))

 +19       IF 'D

               QUIT ""

 +20      ;I D>(9999999-BDATE) Q ""

 +21       SET LAST=""

           SET E=0

           FOR 

               SET E=$ORDER(^AUPNVAST("AS",P,D,E))

               IF E'=+E

                   QUIT 

               SET LAST=E

 +22       IF 'LAST

               QUIT ""

 +23       SET S=^AUPNVAST("AS",P,D,LAST)

 +24       IF S=1

               QUIT 1

 +25       QUIT ""

LAST(P,BDATE,EDATE) ;EP last asthma dx

 +1        KILL BGPG

 +2        SET Y="BGPG("

 +3        SET X=P_"^LAST DX [BGP ASTHMA DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)

           SET E=$$START1^APCLDF(X,Y)

 +4        IF $DATA(BGPG(1))

               QUIT $$DATE^BGP4UTL($PIECE(BGPG(1),U))_" "_$PIECE(BGPG(1),U,2)