BGP6C13 ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM ;
;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
;
ARBALG1 ;EP does patient have an ARB allergy
;get all povs with 995.0-995.3 with ecode of e935.3 up to discharge date
NEW ED,BD,BGPG,X,Y,Z,N
;BGPD is discharge date
S:$G(BGPC)="" BGPC=0 ;cmi/maw 3/19/2010 this was commented out for some reason so it was undef in the next sub routine
S ED=$$FMADD^XLFDT(BGPD,-365)
ARBPOV ;
K BGPG S Y="BGPG(",X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(BGPD) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.S N=$$VAL^XBDIQ1(9000010.07,Y,.04) S N=$$UP^XLFSTR(N)
.I N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER") S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP6UTL($P(BGPG(X),U))_" ADR POV "_$P(BGPG(X),U,2) Q
.S T=$O(^ATXAX("B","BGP ADV EFF ANTIHYPERTEN ARB",0))
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$$ICD^BGP6UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP6UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$$ICD^BGP6UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP6UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$$ICD^BGP6UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP6UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N Q
.Q
K BGPG S Y="BGPG(",X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(DFN))_"-"_$$FMTE^XLFDT(BGPD) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.S N=$$VAL^XBDIQ1(9000010.07,Y,.04),N=$$UP^XLFSTR(N)
.I N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER") S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP6UTL($P(BGPG(X),U))_" ADR POV "_$P(BGPG(X),U,2)
;now check problem list for these codes
S T="",T=$O(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
.S I=$P($G(^AUPNPROB(X,0)),U),Y=$P($$ICDDX^BGP6UTL2(I),U,2)
.S N=$$VAL^XBDIQ1(9000011,X,.05),N=$$UP^XLFSTR(N)
.Q:$P(^AUPNPROB(X,0),U,8)>BGPD ;added after discharge date
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.I $$ICD^BGP6UTL2(I,$O(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP6UTL2(I,T,9)),N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER") S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP6UTL($P(^AUPNPROB(X,0),U,8))_" ADR PROBLEM LIST "_Y_" "_N
.Q
;now check allergy tracking
S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X D
.Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>BGPD ;entered after discharge date
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.I N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER") S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP6UTL($P(^GMR(120.8,X,0),U,4))_" ADR ALLERGY TRACKING"
Q
ARBCON1 ;EP does patient have an ARB allergy
;nmi in refusal file for ARB
S T=$O(^ATXAX("B","BGP CMS ARB MEDS",0))
S Z=$$FMADD^XLFDT(BGPDDT,-365)
S X=0 F S X=$O(^AUPNPREF("AA",P,50,X)) Q:X'=+X D
.Q:'$D(^ATXAX(T,21,"B",X)) ;not an ARB
.S D=0 F S D=$O(^AUPNPREF("AA",P,50,X,D)) Q:D'=+D D
..S Y=9999999-D I Y<Z Q ;documented more than 1 year before discharge
..I Y>BGPDDT Q ;documented after discharge
..S N=0 F S N=$O(^AUPNPREF("AA",P,50,X,D,N)) Q:N'=+N D
...Q:$P($G(^AUPNPREF(N,0)),U,7)'="N"
...S BGPC=BGPC+1,BGPY(BGPC)="NMI ARB: "_$$VAL^XBDIQ1(9000022,N,.04)_" "_$$DATE^BGP6UTL($P(^AUPNPREF(N,0),U,3))_" "_$$VAL^XBDIQ1(9000022,X,1101)
..Q
.Q
Q:BGPIND'=2
S X=$$CPTI^BGP6DU(P,BGPD,BGPDDT,+$$CODEN^ICPTCOD("G8029"))
I X S BGPC=BGPC+1,BGPY(BGPC)="CPT code G8029: "_$$DATE^BGP6UTL($P(X,U,2))
S X=$$TRANI^BGP6DU(P,BGPD,BGPDDT,+$$CODEN^ICPTCOD("G8029"))
I X S BGPC=BGPC+1,BGPY(BGPC)="Tran Code G8029: "_$$DATE^BGP6UTL($P(X,U,2))
Q
ARBRX1 ;EP
;get last aspirin rx before date of adm
NEW BGPG,BGPC,X,Y,Z,E,BD,ED
S BGPC=0
S ED=$$FMADD^XLFDT(BGPA,-1)
S BD=$$FMADD^XLFDT(BGPA,-365)
D GETMEDS^BGP6CU(P,BD,ED,"BGP CMS ARB MEDS","BGP CMS ARB MEDS NDC","BGP CMS ARB MEDS CLASS")
I BGPIND=2 D
.S X=$$CPTI^BGP6DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
.I X S BGPC=BGPC+1,BGPY(BGPC)="CPT code G8027: "_$$DATE^BGP6UTL($P(X,U,2))
.S X=$$TRANI^BGP6DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
.I X S BGPC=BGPC+1,BGPY(BGPC)="Tran Code G8027: "_$$DATE^BGP6UTL($P(X,U,2))
S BD=BGPA
S ED=$$FMADD^XLFDT(BGPD,30)
D GETMEDS^BGP6CU(P,BD,ED,"BGP CMS ARB MEDS","BGP CMS ARB MEDS NDC","BGP CMS ARB MEDS CLASS")
I BGPIND=2 D
.S X=$$CPTI^BGP6DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
.I X S BGPC=BGPC+1,BGPY(BGPC)="CPT code G8027: "_$$DATE^BGP6UTL($P(X,U,2))
.S X=$$TRANI^BGP6DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
.I X S BGPC=BGPC+1,BGPY(BGPC)="Tran Code G8027: "_$$DATE^BGP6UTL($P(X,U,2))
K BGPG
Q
DSCH(H) ;
Q $P($P(^AUPNVINP(H,0),U),".")
ACEICON1(P,BGPD,BGPDDT,BGPV,BGPY) ;EP have an ACEI allergy
NEW ED,BD,BGPG,BGPC,X,Y,Z,N,E
S BGPC=0 K BGPY
S BD=$$FMADD^XLFDT(BGPD,-365)
K BGPG S Y="BGPG(",X=P_"^LAST DX [BGP CMS AORTIC STENOSIS DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(BGPDDT) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) S BGPC=BGPC+1,BGPY(BGPC)="POV: "_$$DATE^BGP6UTL($P(BGPG(1),U))_" ["_$P(BGPG(1),U,2)_"] "_$$VAL^XBDIQ1(9000010.07,+$P(BGPG(1),U,4),.04)
;
;nmi in refusal file for ACEI
S T=$O(^ATXAX("B","BGP CMS ACEI MEDS",0))
S Z=$$FMADD^XLFDT(BGPDDT,-365)
S X=0 F S X=$O(^AUPNPREF("AA",P,50,X)) Q:X'=+X D
.Q:'$D(^ATXAX(T,21,"B",X)) ;not an ACEI
.S D=0 F S D=$O(^AUPNPREF("AA",P,50,X,D)) Q:D'=+D D
..S Y=9999999-D I Y<Z Q ;documented more than 1 year before disc
..I Y>BGPDDT Q ;documented after discharge
..S N=0 F S N=$O(^AUPNPREF("AA",P,50,X,D,N)) Q:N'=+N D
...Q:$P($G(^AUPNPREF(N,0)),U,7)'="N"
...S BGPC=BGPC+1,BGPY(BGPC)="NMI ACEI: "_$$VAL^XBDIQ1(9000022,N,.04)_" "_$$DATE^BGP6UTL($P(^AUPNPREF(N,0),U,3))_" "_$$VAL^XBDIQ1(9000022,X,1101)
..Q
.Q
D ARBCON1
Q
BGP6C13 ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM ;
+1 ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
+2 ;
ARBALG1 ;EP does patient have an ARB allergy
+1 ;get all povs with 995.0-995.3 with ecode of e935.3 up to discharge date
+2 NEW ED,BD,BGPG,X,Y,Z,N
+3 ;BGPD is discharge date
+4 ;cmi/maw 3/19/2010 this was commented out for some reason so it was undef in the next sub routine
IF $GET(BGPC)=""
SET BGPC=0
+5 SET ED=$$FMADD^XLFDT(BGPD,-365)
ARBPOV ;
+1 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(BGPD)
SET E=$$START1^APCLDF(X,Y)
+2 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+3 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+4 IF N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER")
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ADR POV "_$PIECE(BGPG(X),U,2)
QUIT
+5 SET T=$ORDER(^ATXAX("B","BGP ADV EFF ANTIHYPERTEN ARB",0))
+6 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $$ICD^BGP6UTL2(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N
QUIT
+7 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
IF Z]""
IF $$ICD^BGP6UTL2(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N
QUIT
+8 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
IF Z]""
IF $$ICD^BGP6UTL2(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N
QUIT
+9 QUIT
End DoDot:1
+10 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(DFN))_"-"_$$FMTE^XLFDT(BGPD)
SET E=$$START1^APCLDF(X,Y)
+11 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+12 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+13 IF N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER")
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ADR POV "_$PIECE(BGPG(X),U,2)
End DoDot:1
+14 ;now check problem list for these codes
+15 SET T=""
SET T=$ORDER(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
+16 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+17 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
SET Y=$PIECE($$ICDDX^BGP6UTL2(I),U,2)
+18 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+19 ;added after discharge date
IF $PIECE(^AUPNPROB(X,0),U,8)>BGPD
QUIT
+20 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+21 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+22 IF $$ICD^BGP6UTL2(I,$ORDER(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP6UTL2(I,T,9))
IF N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER")
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP6UTL($PIECE(^AUPNPROB(X,0),U,8))_" ADR PROBLEM LIST "_Y_" "_N
+23 QUIT
End DoDot:1
+24 ;now check allergy tracking
+25 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+26 ;entered after discharge date
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>BGPD
QUIT
+27 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+28 IF N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER")
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP6UTL($PIECE(^GMR(120.8,X,0),U,4))_" ADR ALLERGY TRACKING"
End DoDot:1
+29 QUIT
ARBCON1 ;EP does patient have an ARB allergy
+1 ;nmi in refusal file for ARB
+2 SET T=$ORDER(^ATXAX("B","BGP CMS ARB MEDS",0))
+3 SET Z=$$FMADD^XLFDT(BGPDDT,-365)
+4 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,50,X))
IF X'=+X
QUIT
Begin DoDot:1
+5 ;not an ARB
IF '$DATA(^ATXAX(T,21,"B",X))
QUIT
+6 SET D=0
FOR
SET D=$ORDER(^AUPNPREF("AA",P,50,X,D))
IF D'=+D
QUIT
Begin DoDot:2
+7 ;documented more than 1 year before discharge
SET Y=9999999-D
IF Y<Z
QUIT
+8 ;documented after discharge
IF Y>BGPDDT
QUIT
+9 SET N=0
FOR
SET N=$ORDER(^AUPNPREF("AA",P,50,X,D,N))
IF N'=+N
QUIT
Begin DoDot:3
+10 IF $PIECE($GET(^AUPNPREF(N,0)),U,7)'="N"
QUIT
+11 SET BGPC=BGPC+1
SET BGPY(BGPC)="NMI ARB: "_$$VAL^XBDIQ1(9000022,N,.04)_" "_$$DATE^BGP6UTL($PIECE(^AUPNPREF(N,0),U,3))_" "_$$VAL^XBDIQ1(9000022,X,1101)
End DoDot:3
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 IF BGPIND'=2
QUIT
+15 SET X=$$CPTI^BGP6DU(P,BGPD,BGPDDT,+$$CODEN^ICPTCOD("G8029"))
+16 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="CPT code G8029: "_$$DATE^BGP6UTL($PIECE(X,U,2))
+17 SET X=$$TRANI^BGP6DU(P,BGPD,BGPDDT,+$$CODEN^ICPTCOD("G8029"))
+18 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="Tran Code G8029: "_$$DATE^BGP6UTL($PIECE(X,U,2))
+19 QUIT
ARBRX1 ;EP
+1 ;get last aspirin rx before date of adm
+2 NEW BGPG,BGPC,X,Y,Z,E,BD,ED
+3 SET BGPC=0
+4 SET ED=$$FMADD^XLFDT(BGPA,-1)
+5 SET BD=$$FMADD^XLFDT(BGPA,-365)
+6 DO GETMEDS^BGP6CU(P,BD,ED,"BGP CMS ARB MEDS","BGP CMS ARB MEDS NDC","BGP CMS ARB MEDS CLASS")
+7 IF BGPIND=2
Begin DoDot:1
+8 SET X=$$CPTI^BGP6DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
+9 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="CPT code G8027: "_$$DATE^BGP6UTL($PIECE(X,U,2))
+10 SET X=$$TRANI^BGP6DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
+11 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="Tran Code G8027: "_$$DATE^BGP6UTL($PIECE(X,U,2))
End DoDot:1
+12 SET BD=BGPA
+13 SET ED=$$FMADD^XLFDT(BGPD,30)
+14 DO GETMEDS^BGP6CU(P,BD,ED,"BGP CMS ARB MEDS","BGP CMS ARB MEDS NDC","BGP CMS ARB MEDS CLASS")
+15 IF BGPIND=2
Begin DoDot:1
+16 SET X=$$CPTI^BGP6DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
+17 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="CPT code G8027: "_$$DATE^BGP6UTL($PIECE(X,U,2))
+18 SET X=$$TRANI^BGP6DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
+19 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="Tran Code G8027: "_$$DATE^BGP6UTL($PIECE(X,U,2))
End DoDot:1
+20 KILL BGPG
+21 QUIT
DSCH(H) ;
+1 QUIT $PIECE($PIECE(^AUPNVINP(H,0),U),".")
ACEICON1(P,BGPD,BGPDDT,BGPV,BGPY) ;EP have an ACEI allergy
+1 NEW ED,BD,BGPG,BGPC,X,Y,Z,N,E
+2 SET BGPC=0
KILL BGPY
+3 SET BD=$$FMADD^XLFDT(BGPD,-365)
+4 KILL BGPG
SET Y="BGPG("
SET X=P_"^LAST DX [BGP CMS AORTIC STENOSIS DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(BGPDDT)
SET E=$$START1^APCLDF(X,Y)
+5 IF $DATA(BGPG(1))
SET BGPC=BGPC+1
SET BGPY(BGPC)="POV: "_$$DATE^BGP6UTL($PIECE(BGPG(1),U))_" ["_$PIECE(BGPG(1),U,2)_"] "_$$VAL^XBDIQ1(9000010.07,+$PIECE(BGPG(1),U,4),.04)
+6 ;
+7 ;nmi in refusal file for ACEI
+8 SET T=$ORDER(^ATXAX("B","BGP CMS ACEI MEDS",0))
+9 SET Z=$$FMADD^XLFDT(BGPDDT,-365)
+10 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,50,X))
IF X'=+X
QUIT
Begin DoDot:1
+11 ;not an ACEI
IF '$DATA(^ATXAX(T,21,"B",X))
QUIT
+12 SET D=0
FOR
SET D=$ORDER(^AUPNPREF("AA",P,50,X,D))
IF D'=+D
QUIT
Begin DoDot:2
+13 ;documented more than 1 year before disc
SET Y=9999999-D
IF Y<Z
QUIT
+14 ;documented after discharge
IF Y>BGPDDT
QUIT
+15 SET N=0
FOR
SET N=$ORDER(^AUPNPREF("AA",P,50,X,D,N))
IF N'=+N
QUIT
Begin DoDot:3
+16 IF $PIECE($GET(^AUPNPREF(N,0)),U,7)'="N"
QUIT
+17 SET BGPC=BGPC+1
SET BGPY(BGPC)="NMI ACEI: "_$$VAL^XBDIQ1(9000022,N,.04)_" "_$$DATE^BGP6UTL($PIECE(^AUPNPREF(N,0),U,3))_" "_$$VAL^XBDIQ1(9000022,X,1101)
End DoDot:3
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 DO ARBCON1
+21 QUIT
