BGP9D81 ; IHS/CMI/LAB - measure C ;
;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
;
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:$P(BGPV,U,2)_" on "_$P(BGPV,U,3),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)'="A"
.Q:'$$ICD^ATXCHK(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^ATXCHK(%,T,9) S D=1
.Q:'D
.S G=G+1
.Q
I G>1 Q 1_U_"2 DXs"
Q ""
ASEX(P,EDATE) ;
;2009 - 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)'="A"
.Q:'$$ICD^ATXCHK(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^BGP9UTL($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?
K BGPMEDS1
D GETMEDS^BGP9UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
I '$D(BGPMEDS1) Q ""
S T1=$O(^ATXAX("B","BGP ASTHMA INHALED STEROIDS",0))
S T4=$O(^ATXAX("B","BGP ASTHMA INHALED STEROID NDC",0))
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
.Q:'$D(^AUPNVSIT(V,0))
.S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
.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^BGP9UTL($P($P(^AUPNVSIT(V,0),U),".")) Q ;it is an inhaled steroid that wasn't d/c'ed so 1 dispensing event
Q D
BGP9D81 ; IHS/CMI/LAB - measure C ;
+1 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
+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:$PIECE(BGPV,U,2)_" on "_$PIECE(BGPV,U,3),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)'="A"
QUIT
+11 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+12 IF $PIECE(^AUPNPROB(X,0),U,15)=""
QUIT
+13 IF $PIECE(^AUPNPROB(X,0),U,15)<2
QUIT
+14 SET G=1_U_"PL "_$PIECE(^ICD9(Y,0),U)_"=Pers: "_$PIECE(^AUPNPROB(X,0),U,15)
+15 QUIT
End DoDot:1
+16 IF G
QUIT G
+17 ;I $P($G(^BATREG(P,0)),U,2)'="A" G DXS ;not active on asthma register
+18 SET S=""
+19 SET EDATE1=9999999-EDATE-1
+20 SET D=$ORDER(^AUPNVAST("AS",P,EDATE1))
+21 IF 'D
GOTO DXS
+22 SET LAST=""
SET E=0
FOR
SET E=$ORDER(^AUPNVAST("AS",P,D,E))
IF E'=+E
QUIT
SET LAST=E
+23 IF 'LAST
GOTO DXS
+24 SET S=^AUPNVAST("AS",P,D,LAST)
+25 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^ATXCHK(%,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 ;2009 - 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)'="A"
QUIT
+9 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+10 IF $PIECE(^AUPNPROB(X,0),U,15)'=1
QUIT
+11 SET G=1
+12 QUIT
End DoDot:1
+13 IF G
QUIT G
+14 ;I $P($G(^BATREG(P,0)),U,2)'="A" Q "" ;not active on asthma register
+15 NEW EDATE1,D
+16 SET EDATE1=9999999-EDATE-1
+17 SET D=$ORDER(^AUPNVAST("AS",P,EDATE1))
+18 IF 'D
QUIT ""
+19 ;I D>(9999999-BDATE) Q ""
+20 SET LAST=""
SET E=0
FOR
SET E=$ORDER(^AUPNVAST("AS",P,D,E))
IF E'=+E
QUIT
SET LAST=E
+21 IF 'LAST
QUIT ""
+22 SET S=^AUPNVAST("AS",P,D,LAST)
+23 IF S=1
QUIT 1
+24 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^BGP9UTL($PIECE(BGPG(1),U))_" "_$PIECE(BGPG(1),U,2)
+5 QUIT ""
NDC(A,B) ;
+1 ;a is drug ien
+2 ;b is taxonomy ien
+3 SET BGPNDC=$PIECE($GET(^PSDRUG(A,2)),U,4)
+4 IF BGPNDC]""
IF B
IF $DATA(^ATXAX(B,21,"B",BGPNDC))
QUIT 1
+5 QUIT 0
LEUK(A,B,C) ;
+1 ;a drug ien
+2 ;b tax ien
+3 ;c tax ien for ndc
+4 IF $DATA(^ATXAX(B,21,"B",A))
QUIT 1
+5 IF $$NDC(A,C)
QUIT 1
+6 QUIT ""
INHALED(P,BDATE,EDATE) ;EP - any inhaled steroid?
+1 KILL BGPMEDS1
+2 DO GETMEDS^BGP9UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
+3 IF '$DATA(BGPMEDS1)
QUIT ""
+4 SET T1=$ORDER(^ATXAX("B","BGP ASTHMA INHALED STEROIDS",0))
+5 SET T4=$ORDER(^ATXAX("B","BGP ASTHMA INHALED STEROID NDC",0))
+6 SET (X,G,M,E)=0
SET D=""
FOR
SET X=$ORDER(BGPMEDS1(X))
IF X'=+X!(D]"")
QUIT
SET V=$PIECE(BGPMEDS1(X),U,5)
SET Y=+$PIECE(BGPMEDS1(X),U,4)
Begin DoDot:1
+7 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+8 ;get drug ien
SET Z=$PIECE($GET(^AUPNVMED(Y,0)),U)
+9 ;it is an inhaled steroid that wasn't d/c'ed so 1 dispensing event
IF $DATA(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4))
IF $PIECE(^AUPNVMED(Y,0),U,8)=""
SET D=1_U_$PIECE(^PSDRUG(Z,0),U)_U_$$DATE^BGP9UTL($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
QUIT
End DoDot:1
+10 QUIT D
