BGP1C11 ; IHS/CMI/LAB - calc CMS measures 02 Jul 2010 8:31 AM ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;
EN ;EP
K BGPDATA,BGPDATA
LVSD ;
S ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,7,"EF and/or LVSD?")=""
K BGPDATA
D LVSD1(DFN,$$DSCH(BGPVINP),.BGPDATA)
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X D
.S ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,7,"EF and/or LVSD?",X)=BGPDATA(X)
ACEIALG ;
S ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,10,"ACEI or ARB Allergy?")=""
K BGPDATA
D ACEIALG1(DFN,$$DSCH(BGPVINP),.BGPDATA) ;return text of ACEI allergy if found
I $D(BGPDATA) S ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,10,"ACEI or ARB Allergy?")=""
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X D
.S ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,10,"ACEI or ARB Allergy?",X)=BGPDATA(X)
ACEICONT ;
S ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,11,"Other ACEI or ARB Exclusion?")=""
K BGPDATA
D ACEICON1^BGP1C13(DFN,$P($P(BGPVSIT0,U),"."),$$DSCH(BGPVINP),BGPVSIT,.BGPDATA)
I $D(BGPDATA) S ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,11,"Other ACEI or ARB Exclusion?")=""
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X D
.S ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,11,"Other ACEI or ARB Exclusion?",X)=BGPDATA(X)
ACEIRX ;
S ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,12,"ACEI or ARB Rx Status?")=""
K BGPDATA
D ACEIRX1(DFN,$P($P(BGPVSIT0,U),"."),$$DSCH(BGPVINP),.BGPDATA)
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X D
.S ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,12,"ACEI or ARB Rx Status?",X)=BGPDATA(X)
BETAALG ;
S ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,13,"Beta Blocker Allergy?")=""
K BGPDATA
D BETAALG1(DFN,$$DSCH(BGPVINP),.BGPDATA)
I $D(BGPDATA) S ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,13,"Beta Blocker Allergy?")=""
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X D
.S ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,13,"Beta Blocker Allergy?",X)=BGPDATA(X)
BETACONT ;
S ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,15,"Other Beta Blocker Exclusion?")=""
K BGPDATA
D BETACON1(DFN,$P($P(BGPVSIT0,U),"."),$$DSCH(BGPVINP),BGPVSIT,.BGPDATA)
I $D(BGPDATA) S ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,15,"Other Beta Blocker Exclusion?")=""
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X D
.S ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,15,"Other Beta Blocker Exclusion?",X)=BGPDATA(X)
BETARX ;
S ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,16,"Beta Blocker Rx Status:")=""
K BGPDATA
D BETARX1(DFN,$P($P(BGPVSIT0,U),"."),$$DSCH(BGPVINP),.BGPDATA)
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X D
.S ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,16,"Beta Blocker Rx Status:",X)=BGPDATA(X)
D ^BGP1C12
Q
LVSD1(P,BGPD,BGPY) ;
NEW ED,BD,BGPG,BGPC,X,Y,Z,N,I,T
S BGPC=0 K BGPY
LVSDPOV ;
S X=0 F S X=$O(^AUPNVPOV("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVPOV(X,0))
.S I=$P($G(^AUPNVPOV(X,0)),U) Q:'I
.S Y=$P($$ICDDX^ICDCODE(I),U,2)
.S T=$O(^ATXAX("B","BGP CMS LVSD DXS",0))
.Q:'$$ICD^ATXCHK(I,T,9)
.S V=$P(^AUPNVPOV(X,0),U,3)
.S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
.I V>BGPD Q
.S BGPC=BGPC+1,BGPY(BGPC)="POV: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.07,X,.04)
CEFMEAS ;
K BGPG S Y="BGPG(",X=P_"^ALL MEAS CEF;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
.Q:$P($G(^AUPNVMSR(Y,2)),U,1)
.S N=$P(^AUPNVMSR(Y,0),U,4)
.S BGPC=BGPC+1,BGPY(BGPC)="MEASUREMENT CEF: "_$$DATE^BGP1UTL($P(BGPG(X),U))_" value: "_N
.Q
CEFPROC ;
S X=0 F S X=$O(^AUPNVPRC("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVPRC(X,0))
.S I=$P($G(^AUPNVPRC(X,0)),U) Q:'I
.S Y=$P($$ICDOP^ICDCODE(I),U,2)
.S T="",T=$O(^ATXAX("B","BGP CMS EJECTION FRACTION PROC",0))
.I $$ICD^ATXCHK(I,T,0) D
..S V=$P(^AUPNVPRC(X,0),U,3)
..S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
..I V>BGPD Q
..S BGPC=BGPC+1,BGPY(BGPC)="CEF PROCEDURE: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.08,X,.04)
CEFCPT ;
S X=0 F S X=$O(^AUPNVCPT("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVCPT(X,0))
.S I=$P($G(^AUPNVCPT(X,0)),U) Q:'I
.S Y=$P($$CPT^ICPTCOD(I),U,2)
.S T="",T=$O(^ATXAX("B","BGP CMS EJECTION FRACTION CPTS",0))
.I $$ICD^ATXCHK(I,T,1) D
..S V=$P(^AUPNVCPT(X,0),U,3)
..S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
..I V>BGPD Q
..S BGPC=BGPC+1,BGPY(BGPC)="CEF CPT: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$P($$CPT^ICPTCOD(I,V),U,3)
S X=0 F S X=$O(^AUPNVTC("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVTC(X,0))
.S I=$P($G(^AUPNVTC(X,0)),U,7) Q:'I
.S Y=$P($$CPT^ICPTCOD(I),U,2)
.Q:Y=""
.S T="",T=$O(^ATXAX("B","BGP CMS EJECTION FRACTION CPTS",0))
.I $$ICD^ATXCHK(I,T,1) D
..S V=$P(^AUPNVTC(X,0),U,3)
..S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
..I V>BGPD Q
..S BGPC=BGPC+1,BGPY(BGPC)="CEF TRAN CODE: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$P($$CPT^ICPTCOD(I,V),U,3)
Q
ACEIALG1(P,BGPD,BGPY) ;EP
NEW ED,BD,BGPG,BGPC,X,Y,Z,N
S:$G(BGPC)="" BGPC=0
S ED=$$FMADD^XLFDT(BGPD,-365)
ACEIPOV ;
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["ACEI"!(N["ACE I") S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP1UTL($P(BGPG(X),U))_" POV "_$P(BGPG(X),U,2) Q
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$P($$ICDDX^ICDCODE(Z),U,2)="E942.6" S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP1UTL($P(BGPG(X),U))_" ADR POV "_$P(BGPG(X),U,2)_" + E942.6" Q
.S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$P($$ICDDX^ICDCODE(Z),U,2)="E942.6" S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP1UTL($P(BGPG(X),U))_" ADR POV "_$P(BGPG(X),U,2)_" + E942.6" Q
.S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$P($$ICDDX^ICDCODE(Z),U,2)="E942.6" S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP1UTL($P(BGPG(X),U))_" ADR POV "_$P(BGPG(X),U,2)_" + E942.6" Q
.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["ACEI"!(N["ACE I") S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP1UTL($P(BGPG(X),U))_" ADR POV "_$P(BGPG(X),U,2)
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
.I Y="V14.8"!($$ICD^ATXCHK(I,T,9)),N["ACEI"!(N["ACE I") S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP1UTL($P(^AUPNPROB(X,0),U,8))_" ADR Problem List "_Y_" "_N
.Q
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
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.I N["ACEI"!(N["ACE INHIBITOR") S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP1UTL($P(^GMR(120.8,X,0),U,4))_" ADR ALLERGY TRACKING "
D ARBALG1^BGP1C13
Q
ACEIRX1(P,BGPA,BGPD,BGPY) ;EP
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^BGP1CU(P,BD,ED,"BGP CMS ACEI MEDS","BGP CMS ACEI MEDS NDC","BGP CMS ACEI MEDS CLASS")
S BD=BGPA
S ED=$$FMADD^XLFDT(BGPD,30)
D GETMEDS^BGP1CU(P,BD,ED,"BGP CMS ACEI MEDS","BGP CMS ACEI MEDS NDC","BGP CMS ACEI MEDS CLASS")
K BGPG
D ARBRX1^BGP1C13
Q
DSCH(H) ;
Q $P($P(^AUPNVINP(H,0),U),".")
BETAALG1(P,BGPD,BGPY) ;have an ACEI allergy
NEW ED,BD,BGPG,BGPC,X,Y,Z,N
S BGPC=0
S ED=$$FMADD^XLFDT(BGPD,-365)
BETAPOV ;
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["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK") S BGPC=BGPC+1,BGPY(BGPC)="POV: "_$$DATE^BGP1UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$P($$ICDDX^ICDCODE(Z),U,2)="E942.0" S BGPC=BGPC+1,BGPY(BGPC)="POV: "_$$DATE^BGP1UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + E942.0] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$P($$ICDDX^ICDCODE(Z),U,2)="E942.0" S BGPC=BGPC+1,BGPY(BGPC)="POV: "_$$DATE^BGP1UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + E942.0] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$P($$ICDDX^ICDCODE(Z),U,2)="E942.0" S BGPC=BGPC+1,BGPY(BGPC)="POV: "_$$DATE^BGP1UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + E942.0] "_N Q
.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["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK") S BGPC=BGPC+1,BGPY(BGPC)="POV: "_$$DATE^BGP1UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N
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["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK") S BGPC=BGPC+1,BGPY(BGPC)="PROBLEM LIST: "_$$DATE^BGP1UTL($P(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
.Q
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["BETA BLOCK" S BGPC=BGPC+1,BGPY(BGPC)="ALLERGY TRACKING: "_$$DATE^BGP1UTL($P(^GMR(120.8,X,0),U,4))_" "_N
Q
BETABPS1(P,BGPV,BGPY) ;
K BGPY S BGPC=0
S X=0 F S X=$O(^AUPNVMSR("AD",BGPV,X)) Q:X'=+X D
.S Y=$P($G(^AUPNVMSR(X,0)),U)
.Q:'Y
.S Z=$P($G(^AUTTMSR(Y,0)),U)
.Q:Z=""
.Q:Z'="BP"
.Q:$P($G(^AUPNVSMR(X,2)),U,1)
.S N=$P(^AUPNVMSR(X,0),U,4)
.S V=$P(^AUPNVMSR(X,0),U,3)
.S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
.S BGPC=BGPC+1,BGPY(BGPC)="BP: "_N_" "_$$DATE^BGP1UTL(V)
.Q
S Z=0 F S Z=$O(^AUPNVSIT("AD",BGPV,Z)) Q:Z'=+Z D
.S X=0 F S X=$O(^AUPNVMSR("AD",Z,X)) Q:X'=+X D
..S Y=$P($G(^AUPNVMSR(X,0)),U)
..Q:'Y
..S Y=$P($G(^AUTTMSR(Y,0)),U)
..Q:Y=""
..Q:Y'="BP"
..Q:$P($G(^AUPNVMSR(X,2)),U,1)
..S N=$P(^AUPNVMSR(X,0),U,4)
..S V=$P(^AUPNVMSR(X,0),U,3)
..S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
..S BGPC=BGPC+1,BGPY(BGPC)="BP: "_N_" "_$$DATE^BGP1UTL(V)
.Q
Q
BETACON1(P,BGPD,BGPDDT,BGPV,BGPY) ;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)
S T=$O(^ATXAX("B","BGP CMS BRADYCARDIA DXS",0))
S T1=$O(^ATXAX("B","BGP CMS 2/3 HEART BLOCK DXS",0))
S T2=$O(^ATXAX("B","BGP CMS CIRCULATORY SHOCK DXS",0))
S T3=$O(^ATXAX("B","BGP CMS HEART FAILURE DXS",0))
S X=0 F S X=$O(^AUPNVPOV("AD",BGPV,X)) Q:X'=+X D
.Q:'$D(^AUPNVPOV(X,0))
.S I=$P($G(^AUPNVPOV(X,0)),U) Q:'I
.S Y=$P($$ICDDX^ICDCODE(I),U,2)
.S V=$P(^AUPNVPOV(X,0),U,3)
.S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
.I $$ICD^ATXCHK(I,T,9) S BGPC=BGPC+1,BGPY(BGPC)="BRADYCARDIA POV: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.07,X,.04) Q
.I $$ICD^ATXCHK(I,T1,9) S BGPC=BGPC+1,BGPY(BGPC)="2ND OR 3RD DEGREE HEART BLOCK POV: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.07,X,.04) Q
.I $$ICD^ATXCHK(I,T2,9) S BGPC=BGPC+1,BGPY(BGPC)="CIRCULATORY SHOCK POV: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.07,X,.04) Q
.I $$ICD^ATXCHK(I,T3,9) S BGPC=BGPC+1,BGPY(BGPC)="HEART FAILURE POV: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.07,X,.04) Q
.Q
;
S Z=0 F S Z=$O(^AUPNVSIT("AD",BGPV,Z)) Q:Z'=+Z D
.S X=0 F S X=$O(^AUPNVPOV("AD",Z,X)) Q:X'=+X D
..S I=$P($G(^AUPNVPOV(X,0)),U) Q:'I
..S Y=$P($$ICDDX^ICDCODE(I),U,2)
..S V=$P($P($G(^AUPNVSIT(Z,0)),U),".")
..I $$ICD^ATXCHK(I,T,9) S BGPC=BGPC+1,BGPY(BGPC)="BRADYCARDIA POV: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.07,X,.04) Q
..I $$ICD^ATXCHK(I,T1,9) S BGPC=BGPC+1,BGPY(BGPC)="2ND OR 3RD DEGREE HEART BLOCK POV: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.07,X,.04) Q
.Q
;
S T=$O(^ATXAX("B","BGP CMS BETA BLOCKER 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 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 BETA BLOCKER: "_$$VAL^XBDIQ1(9000022,N,.04)_" "_$$DATE^BGP1UTL($P(^AUPNPREF(N,0),U,3))_" "_$$VAL^XBDIQ1(9000022,X,1101)
..Q
.Q
S X=$$CPTI^BGP1DU(P,BGPD,BGPDDT,+$$CODEN^ICPTCOD("G8011"))
I X S BGPC=BGPC+1,BGPY(BGPC)="CPT code G8011: "_$$DATE^BGP1UTL($P(X,U,2))
S X=$$TRANI^BGP1DU(P,BGPD,BGPDDT,+$$CODEN^ICPTCOD("G8011"))
I X S BGPC=BGPC+1,BGPY(BGPC)="TRAN code G8011: "_$$DATE^BGP1UTL($P(X,U,2))
K BGPG
Q
BETARX1(P,BGPA,BGPD,BGPY) ;
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^BGP1CU(P,BD,ED,"BGP CMS BETA BLOCKER MEDS","BGP CMS BETA BLOCKER NDC","BGP CMS BETA BLOCKER CLASS")
S X=$$CPTI^BGP1DU(P,BD,ED,+$$CODEN^ICPTCOD("G8009"))
I X S BGPC=BGPC+1,BGPY(BGPC)="CPT code G8009: "_$$DATE^BGP1UTL($P(X,U,2))
S X=$$TRANI^BGP1DU(P,BD,ED,+$$CODEN^ICPTCOD("G8009"))
I X S BGPC=BGPC+1,BGPY(BGPC)="TRAN code G8009: "_$$DATE^BGP1UTL($P(X,U,2))
K BGPG
S BD=BGPA
S ED=$$FMADD^XLFDT(BGPD,30)
D GETMEDS^BGP1CU(P,BD,ED,"BGP CMS BETA BLOCKER MEDS","BGP CMS BETA BLOCKER NDC","BGP CMS BETA BLOCKER CLASS")
S X=$$CPTI^BGP1DU(P,BD,ED,+$$CODEN^ICPTCOD("G8009"))
I X S BGPC=BGPC+1,BGPY(BGPC)="CPT code G8009: "_$$DATE^BGP1UTL($P(X,U,2))
S X=$$TRANI^BGP1DU(P,BD,ED,+$$CODEN^ICPTCOD("G8009"))
I X S BGPC=BGPC+1,BGPY(BGPC)="TRANBG code G8009: "_$$DATE^BGP1UTL($P(X,U,2))
K BGPG
Q
BGP1C11 ; IHS/CMI/LAB - calc CMS measures 02 Jul 2010 8:31 AM ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+2 ;
EN ;EP
+1 KILL BGPDATA,BGPDATA
LVSD ;
+1 SET ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,7,"EF and/or LVSD?")=""
+2 KILL BGPDATA
+3 DO LVSD1(DFN,$$DSCH(BGPVINP),.BGPDATA)
+4 SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,7,"EF and/or LVSD?",X)=BGPDATA(X)
End DoDot:1
ACEIALG ;
+1 SET ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,10,"ACEI or ARB Allergy?")=""
+2 KILL BGPDATA
+3 ;return text of ACEI allergy if found
DO ACEIALG1(DFN,$$DSCH(BGPVINP),.BGPDATA)
+4 IF $DATA(BGPDATA)
SET ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,10,"ACEI or ARB Allergy?")=""
+5 SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,10,"ACEI or ARB Allergy?",X)=BGPDATA(X)
End DoDot:1
ACEICONT ;
+1 SET ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,11,"Other ACEI or ARB Exclusion?")=""
+2 KILL BGPDATA
+3 DO ACEICON1^BGP1C13(DFN,$PIECE($PIECE(BGPVSIT0,U),"."),$$DSCH(BGPVINP),BGPVSIT,.BGPDATA)
+4 IF $DATA(BGPDATA)
SET ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,11,"Other ACEI or ARB Exclusion?")=""
+5 SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,11,"Other ACEI or ARB Exclusion?",X)=BGPDATA(X)
End DoDot:1
ACEIRX ;
+1 SET ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,12,"ACEI or ARB Rx Status?")=""
+2 KILL BGPDATA
+3 DO ACEIRX1(DFN,$PIECE($PIECE(BGPVSIT0,U),"."),$$DSCH(BGPVINP),.BGPDATA)
+4 SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,12,"ACEI or ARB Rx Status?",X)=BGPDATA(X)
End DoDot:1
BETAALG ;
+1 SET ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,13,"Beta Blocker Allergy?")=""
+2 KILL BGPDATA
+3 DO BETAALG1(DFN,$$DSCH(BGPVINP),.BGPDATA)
+4 IF $DATA(BGPDATA)
SET ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,13,"Beta Blocker Allergy?")=""
+5 SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,13,"Beta Blocker Allergy?",X)=BGPDATA(X)
End DoDot:1
BETACONT ;
+1 SET ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,15,"Other Beta Blocker Exclusion?")=""
+2 KILL BGPDATA
+3 DO BETACON1(DFN,$PIECE($PIECE(BGPVSIT0,U),"."),$$DSCH(BGPVINP),BGPVSIT,.BGPDATA)
+4 IF $DATA(BGPDATA)
SET ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,15,"Other Beta Blocker Exclusion?")=""
+5 SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,15,"Other Beta Blocker Exclusion?",X)=BGPDATA(X)
End DoDot:1
BETARX ;
+1 SET ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,16,"Beta Blocker Rx Status:")=""
+2 KILL BGPDATA
+3 DO BETARX1(DFN,$PIECE($PIECE(BGPVSIT0,U),"."),$$DSCH(BGPVINP),.BGPDATA)
+4 SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET ^XTMP("BGP1C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,16,"Beta Blocker Rx Status:",X)=BGPDATA(X)
End DoDot:1
+6 DO ^BGP1C12
+7 QUIT
LVSD1(P,BGPD,BGPY) ;
+1 NEW ED,BD,BGPG,BGPC,X,Y,Z,N,I,T
+2 SET BGPC=0
KILL BGPY
LVSDPOV ;
+1 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+2 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+3 SET I=$PIECE($GET(^AUPNVPOV(X,0)),U)
IF 'I
QUIT
+4 SET Y=$PIECE($$ICDDX^ICDCODE(I),U,2)
+5 SET T=$ORDER(^ATXAX("B","BGP CMS LVSD DXS",0))
+6 IF '$$ICD^ATXCHK(I,T,9)
QUIT
+7 SET V=$PIECE(^AUPNVPOV(X,0),U,3)
+8 SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+9 IF V>BGPD
QUIT
+10 SET BGPC=BGPC+1
SET BGPY(BGPC)="POV: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.07,X,.04)
End DoDot:1
CEFMEAS ;
+1 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL MEAS CEF;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(DFN))_"-"_$$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 IF $PIECE($GET(^AUPNVMSR(Y,2)),U,1)
QUIT
+4 SET N=$PIECE(^AUPNVMSR(Y,0),U,4)
+5 SET BGPC=BGPC+1
SET BGPY(BGPC)="MEASUREMENT CEF: "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" value: "_N
+6 QUIT
End DoDot:1
CEFPROC ;
+1 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+2 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+3 SET I=$PIECE($GET(^AUPNVPRC(X,0)),U)
IF 'I
QUIT
+4 SET Y=$PIECE($$ICDOP^ICDCODE(I),U,2)
+5 SET T=""
SET T=$ORDER(^ATXAX("B","BGP CMS EJECTION FRACTION PROC",0))
+6 IF $$ICD^ATXCHK(I,T,0)
Begin DoDot:2
+7 SET V=$PIECE(^AUPNVPRC(X,0),U,3)
+8 SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+9 IF V>BGPD
QUIT
+10 SET BGPC=BGPC+1
SET BGPY(BGPC)="CEF PROCEDURE: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.08,X,.04)
End DoDot:2
End DoDot:1
CEFCPT ;
+1 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+2 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+3 SET I=$PIECE($GET(^AUPNVCPT(X,0)),U)
IF 'I
QUIT
+4 SET Y=$PIECE($$CPT^ICPTCOD(I),U,2)
+5 SET T=""
SET T=$ORDER(^ATXAX("B","BGP CMS EJECTION FRACTION CPTS",0))
+6 IF $$ICD^ATXCHK(I,T,1)
Begin DoDot:2
+7 SET V=$PIECE(^AUPNVCPT(X,0),U,3)
+8 SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+9 IF V>BGPD
QUIT
+10 SET BGPC=BGPC+1
SET BGPY(BGPC)="CEF CPT: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$PIECE($$CPT^ICPTCOD(I,V),U,3)
End DoDot:2
End DoDot:1
+11 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+12 IF '$DATA(^AUPNVTC(X,0))
QUIT
+13 SET I=$PIECE($GET(^AUPNVTC(X,0)),U,7)
IF 'I
QUIT
+14 SET Y=$PIECE($$CPT^ICPTCOD(I),U,2)
+15 IF Y=""
QUIT
+16 SET T=""
SET T=$ORDER(^ATXAX("B","BGP CMS EJECTION FRACTION CPTS",0))
+17 IF $$ICD^ATXCHK(I,T,1)
Begin DoDot:2
+18 SET V=$PIECE(^AUPNVTC(X,0),U,3)
+19 SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+20 IF V>BGPD
QUIT
+21 SET BGPC=BGPC+1
SET BGPY(BGPC)="CEF TRAN CODE: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$PIECE($$CPT^ICPTCOD(I,V),U,3)
End DoDot:2
End DoDot:1
+22 QUIT
ACEIALG1(P,BGPD,BGPY) ;EP
+1 NEW ED,BD,BGPG,BGPC,X,Y,Z,N
+2 IF $GET(BGPC)=""
SET BGPC=0
+3 SET ED=$$FMADD^XLFDT(BGPD,-365)
ACEIPOV ;
+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["ACEI"!(N["ACE I")
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" POV "_$PIECE(BGPG(X),U,2)
QUIT
+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)=$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" ADR POV "_$PIECE(BGPG(X),U,2)_" + E942.6"
QUIT
+6 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
IF Z]""
IF $PIECE($$ICDDX^ICDCODE(Z),U,2)="E942.6"
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" ADR POV "_$PIECE(BGPG(X),U,2)_" + E942.6"
QUIT
+7 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
IF Z]""
IF $PIECE($$ICDDX^ICDCODE(Z),U,2)="E942.6"
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" ADR POV "_$PIECE(BGPG(X),U,2)_" + E942.6"
QUIT
+8 QUIT
End DoDot:1
+9 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)
+10 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+11 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+12 IF N["ACEI"!(N["ACE I")
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" ADR POV "_$PIECE(BGPG(X),U,2)
End DoDot:1
+13 SET T=""
SET T=$ORDER(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
+14 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+15 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
SET Y=$PIECE($$ICDDX^ICDCODE(I),U,2)
+16 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+17 IF $PIECE(^AUPNPROB(X,0),U,8)>BGPD
QUIT
+18 IF Y="V14.8"!($$ICD^ATXCHK(I,T,9))
IF N["ACEI"!(N["ACE I")
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP1UTL($PIECE(^AUPNPROB(X,0),U,8))_" ADR Problem List "_Y_" "_N
+19 QUIT
End DoDot:1
+20 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+21 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["ACEI"!(N["ACE INHIBITOR")
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP1UTL($PIECE(^GMR(120.8,X,0),U,4))_" ADR ALLERGY TRACKING "
End DoDot:1
+24 DO ARBALG1^BGP1C13
+25 QUIT
ACEIRX1(P,BGPA,BGPD,BGPY) ;EP
+1 NEW BGPG,BGPC,X,Y,Z,E,BD,ED
+2 SET BGPC=0
+3 SET ED=$$FMADD^XLFDT(BGPA,-1)
+4 SET BD=$$FMADD^XLFDT(BGPA,-365)
+5 DO GETMEDS^BGP1CU(P,BD,ED,"BGP CMS ACEI MEDS","BGP CMS ACEI MEDS NDC","BGP CMS ACEI MEDS CLASS")
+6 SET BD=BGPA
+7 SET ED=$$FMADD^XLFDT(BGPD,30)
+8 DO GETMEDS^BGP1CU(P,BD,ED,"BGP CMS ACEI MEDS","BGP CMS ACEI MEDS NDC","BGP CMS ACEI MEDS CLASS")
+9 KILL BGPG
+10 DO ARBRX1^BGP1C13
+11 QUIT
DSCH(H) ;
+1 QUIT $PIECE($PIECE(^AUPNVINP(H,0),U),".")
BETAALG1(P,BGPD,BGPY) ;have an ACEI allergy
+1 NEW ED,BD,BGPG,BGPC,X,Y,Z,N
+2 SET BGPC=0
+3 SET ED=$$FMADD^XLFDT(BGPD,-365)
BETAPOV ;
+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["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK")
SET BGPC=BGPC+1
SET BGPY(BGPC)="POV: "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
QUIT
+5 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $PIECE($$ICDDX^ICDCODE(Z),U,2)="E942.0"
SET BGPC=BGPC+1
SET BGPY(BGPC)="POV: "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + E942.0] "_N
QUIT
+6 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
IF Z]""
IF $PIECE($$ICDDX^ICDCODE(Z),U,2)="E942.0"
SET BGPC=BGPC+1
SET BGPY(BGPC)="POV: "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + E942.0] "_N
QUIT
+7 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
IF Z]""
IF $PIECE($$ICDDX^ICDCODE(Z),U,2)="E942.0"
SET BGPC=BGPC+1
SET BGPY(BGPC)="POV: "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + E942.0] "_N
QUIT
+8 QUIT
End DoDot:1
+9 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)
+10 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+11 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+12 IF N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK")
SET BGPC=BGPC+1
SET BGPY(BGPC)="POV: "_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
End DoDot:1
+13 SET T=""
SET T=$ORDER(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
+14 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+15 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
SET Y=$PIECE($$ICDDX^ICDCODE(I),U,2)
+16 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+17 ;added after discharge date
IF $PIECE(^AUPNPROB(X,0),U,8)>BGPD
QUIT
+18 IF Y="V14.8"!($$ICD^ATXCHK(I,T,9))
IF N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK")
SET BGPC=BGPC+1
SET BGPY(BGPC)="PROBLEM LIST: "_$$DATE^BGP1UTL($PIECE(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
+19 QUIT
End DoDot:1
+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["BETA BLOCK"
SET BGPC=BGPC+1
SET BGPY(BGPC)="ALLERGY TRACKING: "_$$DATE^BGP1UTL($PIECE(^GMR(120.8,X,0),U,4))_" "_N
End DoDot:1
+24 QUIT
BETABPS1(P,BGPV,BGPY) ;
+1 KILL BGPY
SET BGPC=0
+2 SET X=0
FOR
SET X=$ORDER(^AUPNVMSR("AD",BGPV,X))
IF X'=+X
QUIT
Begin DoDot:1
+3 SET Y=$PIECE($GET(^AUPNVMSR(X,0)),U)
+4 IF 'Y
QUIT
+5 SET Z=$PIECE($GET(^AUTTMSR(Y,0)),U)
+6 IF Z=""
QUIT
+7 IF Z'="BP"
QUIT
+8 IF $PIECE($GET(^AUPNVSMR(X,2)),U,1)
QUIT
+9 SET N=$PIECE(^AUPNVMSR(X,0),U,4)
+10 SET V=$PIECE(^AUPNVMSR(X,0),U,3)
+11 SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+12 SET BGPC=BGPC+1
SET BGPY(BGPC)="BP: "_N_" "_$$DATE^BGP1UTL(V)
+13 QUIT
End DoDot:1
+14 SET Z=0
FOR
SET Z=$ORDER(^AUPNVSIT("AD",BGPV,Z))
IF Z'=+Z
QUIT
Begin DoDot:1
+15 SET X=0
FOR
SET X=$ORDER(^AUPNVMSR("AD",Z,X))
IF X'=+X
QUIT
Begin DoDot:2
+16 SET Y=$PIECE($GET(^AUPNVMSR(X,0)),U)
+17 IF 'Y
QUIT
+18 SET Y=$PIECE($GET(^AUTTMSR(Y,0)),U)
+19 IF Y=""
QUIT
+20 IF Y'="BP"
QUIT
+21 IF $PIECE($GET(^AUPNVMSR(X,2)),U,1)
QUIT
+22 SET N=$PIECE(^AUPNVMSR(X,0),U,4)
+23 SET V=$PIECE(^AUPNVMSR(X,0),U,3)
+24 SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+25 SET BGPC=BGPC+1
SET BGPY(BGPC)="BP: "_N_" "_$$DATE^BGP1UTL(V)
End DoDot:2
+26 QUIT
End DoDot:1
+27 QUIT
BETACON1(P,BGPD,BGPDDT,BGPV,BGPY) ;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 SET T=$ORDER(^ATXAX("B","BGP CMS BRADYCARDIA DXS",0))
+5 SET T1=$ORDER(^ATXAX("B","BGP CMS 2/3 HEART BLOCK DXS",0))
+6 SET T2=$ORDER(^ATXAX("B","BGP CMS CIRCULATORY SHOCK DXS",0))
+7 SET T3=$ORDER(^ATXAX("B","BGP CMS HEART FAILURE DXS",0))
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",BGPV,X))
IF X'=+X
QUIT
Begin DoDot:1
+9 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+10 SET I=$PIECE($GET(^AUPNVPOV(X,0)),U)
IF 'I
QUIT
+11 SET Y=$PIECE($$ICDDX^ICDCODE(I),U,2)
+12 SET V=$PIECE(^AUPNVPOV(X,0),U,3)
+13 SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+14 IF $$ICD^ATXCHK(I,T,9)
SET BGPC=BGPC+1
SET BGPY(BGPC)="BRADYCARDIA POV: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.07,X,.04)
QUIT
+15 IF $$ICD^ATXCHK(I,T1,9)
SET BGPC=BGPC+1
SET BGPY(BGPC)="2ND OR 3RD DEGREE HEART BLOCK POV: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.07,X,.04)
QUIT
+16 IF $$ICD^ATXCHK(I,T2,9)
SET BGPC=BGPC+1
SET BGPY(BGPC)="CIRCULATORY SHOCK POV: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.07,X,.04)
QUIT
+17 IF $$ICD^ATXCHK(I,T3,9)
SET BGPC=BGPC+1
SET BGPY(BGPC)="HEART FAILURE POV: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.07,X,.04)
QUIT
+18 QUIT
End DoDot:1
+19 ;
+20 SET Z=0
FOR
SET Z=$ORDER(^AUPNVSIT("AD",BGPV,Z))
IF Z'=+Z
QUIT
Begin DoDot:1
+21 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",Z,X))
IF X'=+X
QUIT
Begin DoDot:2
+22 SET I=$PIECE($GET(^AUPNVPOV(X,0)),U)
IF 'I
QUIT
+23 SET Y=$PIECE($$ICDDX^ICDCODE(I),U,2)
+24 SET V=$PIECE($PIECE($GET(^AUPNVSIT(Z,0)),U),".")
+25 IF $$ICD^ATXCHK(I,T,9)
SET BGPC=BGPC+1
SET BGPY(BGPC)="BRADYCARDIA POV: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.07,X,.04)
QUIT
+26 IF $$ICD^ATXCHK(I,T1,9)
SET BGPC=BGPC+1
SET BGPY(BGPC)="2ND OR 3RD DEGREE HEART BLOCK POV: "_$$DATE^BGP1UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.07,X,.04)
QUIT
End DoDot:2
+27 QUIT
End DoDot:1
+28 ;
+29 SET T=$ORDER(^ATXAX("B","BGP CMS BETA BLOCKER MEDS",0))
+30 SET Z=$$FMADD^XLFDT(BGPDDT,-365)
+31 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,50,X))
IF X'=+X
QUIT
Begin DoDot:1
+32 ;not an ACEI
IF '$DATA(^ATXAX(T,21,"B",X))
QUIT
+33 SET D=0
FOR
SET D=$ORDER(^AUPNPREF("AA",P,50,X,D))
IF D'=+D
QUIT
Begin DoDot:2
+34 ;documented more than 1 year before discharge
SET Y=9999999-D
IF Y<Z
QUIT
+35 ;documented after discharge
IF Y>BGPDDT
QUIT
+36 SET N=0
FOR
SET N=$ORDER(^AUPNPREF("AA",P,50,X,D,N))
IF N'=+N
QUIT
Begin DoDot:3
+37 IF $PIECE($GET(^AUPNPREF(N,0)),U,7)'="N"
QUIT
+38 SET BGPC=BGPC+1
SET BGPY(BGPC)="NMI BETA BLOCKER: "_$$VAL^XBDIQ1(9000022,N,.04)_" "_$$DATE^BGP1UTL($PIECE(^AUPNPREF(N,0),U,3))_" "_$$VAL^XBDIQ1(9000022,X,1101)
End DoDot:3
+39 QUIT
End DoDot:2
+40 QUIT
End DoDot:1
+41 SET X=$$CPTI^BGP1DU(P,BGPD,BGPDDT,+$$CODEN^ICPTCOD("G8011"))
+42 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="CPT code G8011: "_$$DATE^BGP1UTL($PIECE(X,U,2))
+43 SET X=$$TRANI^BGP1DU(P,BGPD,BGPDDT,+$$CODEN^ICPTCOD("G8011"))
+44 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="TRAN code G8011: "_$$DATE^BGP1UTL($PIECE(X,U,2))
+45 KILL BGPG
+46 QUIT
BETARX1(P,BGPA,BGPD,BGPY) ;
+1 NEW BGPG,BGPC,X,Y,Z,E,BD,ED
+2 SET BGPC=0
+3 SET ED=$$FMADD^XLFDT(BGPA,-1)
+4 SET BD=$$FMADD^XLFDT(BGPA,-365)
+5 DO GETMEDS^BGP1CU(P,BD,ED,"BGP CMS BETA BLOCKER MEDS","BGP CMS BETA BLOCKER NDC","BGP CMS BETA BLOCKER CLASS")
+6 SET X=$$CPTI^BGP1DU(P,BD,ED,+$$CODEN^ICPTCOD("G8009"))
+7 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="CPT code G8009: "_$$DATE^BGP1UTL($PIECE(X,U,2))
+8 SET X=$$TRANI^BGP1DU(P,BD,ED,+$$CODEN^ICPTCOD("G8009"))
+9 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="TRAN code G8009: "_$$DATE^BGP1UTL($PIECE(X,U,2))
+10 KILL BGPG
+11 SET BD=BGPA
+12 SET ED=$$FMADD^XLFDT(BGPD,30)
+13 DO GETMEDS^BGP1CU(P,BD,ED,"BGP CMS BETA BLOCKER MEDS","BGP CMS BETA BLOCKER NDC","BGP CMS BETA BLOCKER CLASS")
+14 SET X=$$CPTI^BGP1DU(P,BD,ED,+$$CODEN^ICPTCOD("G8009"))
+15 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="CPT code G8009: "_$$DATE^BGP1UTL($PIECE(X,U,2))
+16 SET X=$$TRANI^BGP1DU(P,BD,ED,+$$CODEN^ICPTCOD("G8009"))
+17 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="TRANBG code G8009: "_$$DATE^BGP1UTL($PIECE(X,U,2))
+18 KILL BGPG
+19 QUIT
