BGP9C13 ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM ;
;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
;
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/2008 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)="POV: "_$$DATE^BGP9UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$P($$ICDDX^ICDCODE(Z),U,2)="E942.6" S BGPC=BGPC+1,BGPY(BGPC)="POV: "_$$DATE^BGP9UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + E942.6] "_N
.Q
K BGPG S Y="BGPG(",X=P_"^ALL DX V14.8;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)="POV: "_$$DATE^BGP9UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N
;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^ICDCODE(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
.I Y="V14.8"!($$ICD^ATXCHK(I,T,9)),N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER") S BGPC=BGPC+1,BGPY(BGPC)="PROBLEM LIST: "_$$DATE^BGP9UTL($P(^AUPNPROB(X,0),U,8))_" ["_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)="ALLERGY TRACKING: "_$$DATE^BGP9UTL($P(^GMR(120.8,X,0),U,4))_" "_N
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^BGP9UTL($P(^AUPNPREF(N,0),U,3))_" "_$$VAL^XBDIQ1(9000022,X,1101)
..Q
.Q
Q:BGPIND'=2
S X=$$CPTI^BGP9DU(P,BGPD,BGPDDT,+$$CODEN^ICPTCOD("G8029"))
I X S BGPC=BGPC+1,BGPY(BGPC)="CPT code G8029: "_$$DATE^BGP9UTL($P(X,U,2))
S X=$$TRANI^BGP9DU(P,BGPD,BGPDDT,+$$CODEN^ICPTCOD("G8029"))
I X S BGPC=BGPC+1,BGPY(BGPC)="Tran Code G8029: "_$$DATE^BGP9UTL($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^BGP9CU(P,BD,ED,"BGP CMS ARB MEDS","BGP CMS ARB MEDS NDC","BGP CMS ARB MEDS CLASS")
I BGPIND=2 D
.S X=$$CPTI^BGP9DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
.I X S BGPC=BGPC+1,BGPY(BGPC)="CPT code G8027: "_$$DATE^BGP9UTL($P(X,U,2))
.S X=$$TRANI^BGP9DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
.I X S BGPC=BGPC+1,BGPY(BGPC)="Tran Code G8027: "_$$DATE^BGP9UTL($P(X,U,2))
S BD=BGPA
S ED=$$FMADD^XLFDT(BGPD,30)
D GETMEDS^BGP9CU(P,BD,ED,"BGP CMS ARB MEDS","BGP CMS ARB MEDS NDC","BGP CMS ARB MEDS CLASS")
I BGPIND=2 D
.S X=$$CPTI^BGP9DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
.I X S BGPC=BGPC+1,BGPY(BGPC)="CPT code G8027: "_$$DATE^BGP9UTL($P(X,U,2))
.S X=$$TRANI^BGP9DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
.I X S BGPC=BGPC+1,BGPY(BGPC)="Tran Code G8027: "_$$DATE^BGP9UTL($P(X,U,2))
K BGPG
Q
DSCH(H) ;
Q $P($P(^AUPNVINP(H,0),U),".")
BGP9C13 ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM ;
+1 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
+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/2008 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)="POV: "_$$DATE^BGP9UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
+5 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $PIECE($$ICDDX^ICDCODE(Z),U,2)="E942.6"
SET BGPC=BGPC+1
SET BGPY(BGPC)="POV: "_$$DATE^BGP9UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + E942.6] "_N
+6 QUIT
End DoDot:1
+7 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL DX V14.8;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(DFN))_"-"_$$FMTE^XLFDT(BGPD)
SET E=$$START1^APCLDF(X,Y)
+8 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+9 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+10 IF N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER")
SET BGPC=BGPC+1
SET BGPY(BGPC)="POV: "_$$DATE^BGP9UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
End DoDot:1
+11 ;now check problem list for these codes
+12 SET T=""
SET T=$ORDER(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
+13 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+14 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
SET Y=$PIECE($$ICDDX^ICDCODE(I),U,2)
+15 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+16 ;added after discharge date
IF $PIECE(^AUPNPROB(X,0),U,8)>BGPD
QUIT
+17 IF Y="V14.8"!($$ICD^ATXCHK(I,T,9))
IF N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER")
SET BGPC=BGPC+1
SET BGPY(BGPC)="PROBLEM LIST: "_$$DATE^BGP9UTL($PIECE(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
+18 QUIT
End DoDot:1
+19 ;now check allergy tracking
+20 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+21 ;entered after discharge date
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>BGPD
QUIT
+22 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+23 IF N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER")
SET BGPC=BGPC+1
SET BGPY(BGPC)="ALLERGY TRACKING: "_$$DATE^BGP9UTL($PIECE(^GMR(120.8,X,0),U,4))_" "_N
End DoDot:1
+24 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^BGP9UTL($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^BGP9DU(P,BGPD,BGPDDT,+$$CODEN^ICPTCOD("G8029"))
+16 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="CPT code G8029: "_$$DATE^BGP9UTL($PIECE(X,U,2))
+17 SET X=$$TRANI^BGP9DU(P,BGPD,BGPDDT,+$$CODEN^ICPTCOD("G8029"))
+18 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="Tran Code G8029: "_$$DATE^BGP9UTL($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^BGP9CU(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^BGP9DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
+9 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="CPT code G8027: "_$$DATE^BGP9UTL($PIECE(X,U,2))
+10 SET X=$$TRANI^BGP9DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
+11 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="Tran Code G8027: "_$$DATE^BGP9UTL($PIECE(X,U,2))
End DoDot:1
+12 SET BD=BGPA
+13 SET ED=$$FMADD^XLFDT(BGPD,30)
+14 DO GETMEDS^BGP9CU(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^BGP9DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
+17 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="CPT code G8027: "_$$DATE^BGP9UTL($PIECE(X,U,2))
+18 SET X=$$TRANI^BGP9DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
+19 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="Tran Code G8027: "_$$DATE^BGP9UTL($PIECE(X,U,2))
End DoDot:1
+20 KILL BGPG
+21 QUIT
DSCH(H) ;
+1 QUIT $PIECE($PIECE(^AUPNVINP(H,0),U),".")
