BGP4C11 ; IHS/CMI/LAB - calc CMS measures 02 Jul 2010 8:31 AM ;
;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
;
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^BGP4UTL2(I),U,2)
.S T=$O(^ATXAX("B","BGP CMS LVSD DXS",0))
.Q:'$$ICD^BGP4UTL2(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^BGP4UTL(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^BGP4UTL($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^BGP4UTL2(I),U,2)
.S T="",T=$O(^ATXAX("B","BGP CMS EJECTION FRACTION PROC",0))
.I $$ICD^BGP4UTL2(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^BGP4UTL(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^BGP4UTL2(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^BGP4UTL(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^BGP4UTL2(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^BGP4UTL(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^BGP4UTL($P(BGPG(X),U))_" ADR POV "_$P(BGPG(X),U,2) Q
.S T=$O(^ATXAX("B","BGP ADV EFF ANTIHYPERTEN AGT",0))
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$$ICD^BGP4UTL2(Z,T,9) S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP4UTL($P(BGPG(X),U))_" ADR POV ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP4UTL2(Z),U,2)_"]" Q
.S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$$ICD^BGP4UTL2(Z,T,9) S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP4UTL($P(BGPG(X),U))_" ADR POV ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP4UTL2(Z),U,2)_"]" Q
.S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$$ICD^BGP4UTL2(Z,T,9) S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP4UTL($P(BGPG(X),U))_" ADR POV ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP4UTL2(Z),U,2)_"]" Q
.Q
S G=""
K BGPG S Y="BGPG(",X=P_"^ALL DX [BGP ADV EFF ANTIHYPER 10;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) S BGPC=BGPC+1,BGPY(BGPC)="ADR POV: "_$$DATE^BGP4UTL($P(BGPG(1),U))_" ["_$P(BGPG(1),U,2)_"]"
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["ACEI"!(N["ACE I") S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP4UTL($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^BGP4UTL2(I),U,2)
.S N=$$VAL^XBDIQ1(9000011,X,.05),N=$$UP^XLFSTR(N)
.Q:$P(^AUPNPROB(X,0),U,8)>BGPD
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.I $$ICD^BGP4UTL2(I,$O(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP4UTL2(I,T,9)),N["ACEI"!(N["ACE I") S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP4UTL($P(^AUPNPROB(X,0),U,8))_" ADR Problem List "_Y_" "_N Q
.I $$ICD^BGP4UTL2(I,$O(^ATXAX("B","BGP ADV EFF ANTIHYPER 10",0)),9) S BGPC=BGPC+1,BGPY(BGPC)="ADR PROBLEM LIST: "_$$DATE^BGP4UTL($P(^AUPNPROB(X,0),U,8))_" ["_Y_"] "
.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^BGP4UTL($P(^GMR(120.8,X,0),U,4))_" ADR ALLERGY TRACKING "
D ARBALG1^BGP4C13
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^BGP4CU(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^BGP4CU(P,BD,ED,"BGP CMS ACEI MEDS","BGP CMS ACEI MEDS NDC","BGP CMS ACEI MEDS CLASS")
K BGPG
D ARBRX1^BGP4C13
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^BGP4UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N Q
.S T=$O(^ATXAX("B","BGP ADV EFF CARD RHYTH",0))
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$$ICD^BGP4UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP4UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP4UTL2(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$$ICD^BGP4UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP4UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP4UTL2(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$$ICD^BGP4UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP4UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP4UTL2(Z),U,2)_"] "_N 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["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK") S BGPC=BGPC+1,BGPY(BGPC)="POV: "_$$DATE^BGP4UTL($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^BGP4UTL2(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^BGP4UTL2(I,$O(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP4UTL2(I,T,9)),N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK") S BGPC=BGPC+1,BGPY(BGPC)="PROBLEM LIST: "_$$DATE^BGP4UTL($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^BGP4UTL($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^BGP4UTL(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^BGP4UTL(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^BGP4UTL2(I),U,2)
.S V=$P(^AUPNVPOV(X,0),U,3)
.S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
.I $$ICD^BGP4UTL2(I,T,9) S BGPC=BGPC+1,BGPY(BGPC)="BRADYCARDIA POV: "_$$DATE^BGP4UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.07,X,.04) Q
.I $$ICD^BGP4UTL2(I,T1,9) S BGPC=BGPC+1,BGPY(BGPC)="2ND OR 3RD DEGREE HEART BLOCK POV: "_$$DATE^BGP4UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.07,X,.04) Q
.I $$ICD^BGP4UTL2(I,T2,9) S BGPC=BGPC+1,BGPY(BGPC)="CIRCULATORY SHOCK POV: "_$$DATE^BGP4UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.07,X,.04) Q
.I $$ICD^BGP4UTL2(I,T3,9) S BGPC=BGPC+1,BGPY(BGPC)="HEART FAILURE POV: "_$$DATE^BGP4UTL(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^BGP4UTL2(I),U,2)
..S V=$P($P($G(^AUPNVSIT(Z,0)),U),".")
..I $$ICD^BGP4UTL2(I,T,9) S BGPC=BGPC+1,BGPY(BGPC)="BRADYCARDIA POV: "_$$DATE^BGP4UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.07,X,.04) Q
..I $$ICD^BGP4UTL2(I,T1,9) S BGPC=BGPC+1,BGPY(BGPC)="2ND OR 3RD DEGREE HEART BLOCK POV: "_$$DATE^BGP4UTL(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^BGP4UTL($P(^AUPNPREF(N,0),U,3))_" "_$$VAL^XBDIQ1(9000022,X,1101)
..Q
.Q
S X=$$CPTI^BGP4DU(P,BGPD,BGPDDT,+$$CODEN^ICPTCOD("G8011"))
I X S BGPC=BGPC+1,BGPY(BGPC)="CPT code G8011: "_$$DATE^BGP4UTL($P(X,U,2))
S X=$$TRANI^BGP4DU(P,BGPD,BGPDDT,+$$CODEN^ICPTCOD("G8011"))
I X S BGPC=BGPC+1,BGPY(BGPC)="TRAN code G8011: "_$$DATE^BGP4UTL($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^BGP4CU(P,BD,ED,"BGP CMS BETA BLOCKER MEDS","BGP CMS BETA BLOCKER NDC","BGP CMS BETA BLOCKER CLASS")
S X=$$CPTI^BGP4DU(P,BD,ED,+$$CODEN^ICPTCOD("G8009"))
I X S BGPC=BGPC+1,BGPY(BGPC)="CPT code G8009: "_$$DATE^BGP4UTL($P(X,U,2))
S X=$$TRANI^BGP4DU(P,BD,ED,+$$CODEN^ICPTCOD("G8009"))
I X S BGPC=BGPC+1,BGPY(BGPC)="TRAN code G8009: "_$$DATE^BGP4UTL($P(X,U,2))
K BGPG
S BD=BGPA
S ED=$$FMADD^XLFDT(BGPD,30)
D GETMEDS^BGP4CU(P,BD,ED,"BGP CMS BETA BLOCKER MEDS","BGP CMS BETA BLOCKER NDC","BGP CMS BETA BLOCKER CLASS")
S X=$$CPTI^BGP4DU(P,BD,ED,+$$CODEN^ICPTCOD("G8009"))
I X S BGPC=BGPC+1,BGPY(BGPC)="CPT code G8009: "_$$DATE^BGP4UTL($P(X,U,2))
S X=$$TRANI^BGP4DU(P,BD,ED,+$$CODEN^ICPTCOD("G8009"))
I X S BGPC=BGPC+1,BGPY(BGPC)="TRANBG code G8009: "_$$DATE^BGP4UTL($P(X,U,2))
K BGPG
Q
BGP4C11 ; IHS/CMI/LAB - calc CMS measures 02 Jul 2010 8:31 AM ;
+1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
+2 ;
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^BGP4UTL2(I),U,2)
+5 SET T=$ORDER(^ATXAX("B","BGP CMS LVSD DXS",0))
+6 IF '$$ICD^BGP4UTL2(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^BGP4UTL(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^BGP4UTL($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^BGP4UTL2(I),U,2)
+5 SET T=""
SET T=$ORDER(^ATXAX("B","BGP CMS EJECTION FRACTION PROC",0))
+6 IF $$ICD^BGP4UTL2(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^BGP4UTL(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^BGP4UTL2(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^BGP4UTL(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^BGP4UTL2(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^BGP4UTL(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^BGP4UTL($PIECE(BGPG(X),U))_" ADR POV "_$PIECE(BGPG(X),U,2)
QUIT
+5 SET T=$ORDER(^ATXAX("B","BGP ADV EFF ANTIHYPERTEN AGT",0))
+6 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $$ICD^BGP4UTL2(Z,T,9)
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP4UTL($PIECE(BGPG(X),U))_" ADR POV ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP4UTL2(Z),U,2)_"]"
QUIT
+7 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
IF Z]""
IF $$ICD^BGP4UTL2(Z,T,9)
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP4UTL($PIECE(BGPG(X),U))_" ADR POV ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP4UTL2(Z),U,2)_"]"
QUIT
+8 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
IF Z]""
IF $$ICD^BGP4UTL2(Z,T,9)
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP4UTL($PIECE(BGPG(X),U))_" ADR POV ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP4UTL2(Z),U,2)_"]"
QUIT
+9 QUIT
End DoDot:1
+10 SET G=""
+11 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL DX [BGP ADV EFF ANTIHYPER 10;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+12 IF $DATA(BGPG(1))
SET BGPC=BGPC+1
SET BGPY(BGPC)="ADR POV: "_$$DATE^BGP4UTL($PIECE(BGPG(1),U))_" ["_$PIECE(BGPG(1),U,2)_"]"
+13 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)
+14 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+15 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+16 IF N["ACEI"!(N["ACE I")
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP4UTL($PIECE(BGPG(X),U))_" ADR POV "_$PIECE(BGPG(X),U,2)
End DoDot:1
+17 SET T=""
SET T=$ORDER(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
+18 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+19 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
SET Y=$PIECE($$ICDDX^BGP4UTL2(I),U,2)
+20 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+21 IF $PIECE(^AUPNPROB(X,0),U,8)>BGPD
QUIT
+22 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+23 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+24 IF $$ICD^BGP4UTL2(I,$ORDER(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP4UTL2(I,T,9))
IF N["ACEI"!(N["ACE I")
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP4UTL($PIECE(^AUPNPROB(X,0),U,8))_" ADR Problem List "_Y_" "_N
QUIT
+25 IF $$ICD^BGP4UTL2(I,$ORDER(^ATXAX("B","BGP ADV EFF ANTIHYPER 10",0)),9)
SET BGPC=BGPC+1
SET BGPY(BGPC)="ADR PROBLEM LIST: "_$$DATE^BGP4UTL($PIECE(^AUPNPROB(X,0),U,8))_" ["_Y_"] "
+26 QUIT
End DoDot:1
+27 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+28 IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>BGPD
QUIT
+29 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+30 IF N["ACEI"!(N["ACE INHIBITOR")
SET BGPC=BGPC+1
SET BGPY(BGPC)=$$DATE^BGP4UTL($PIECE(^GMR(120.8,X,0),U,4))_" ADR ALLERGY TRACKING "
End DoDot:1
+31 DO ARBALG1^BGP4C13
+32 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^BGP4CU(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^BGP4CU(P,BD,ED,"BGP CMS ACEI MEDS","BGP CMS ACEI MEDS NDC","BGP CMS ACEI MEDS CLASS")
+9 KILL BGPG
+10 DO ARBRX1^BGP4C13
+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^BGP4UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
QUIT
+5 SET T=$ORDER(^ATXAX("B","BGP ADV EFF CARD RHYTH",0))
+6 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $$ICD^BGP4UTL2(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP4UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP4UTL2(Z),U,2)_"] "_N
QUIT
+7 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
IF Z]""
IF $$ICD^BGP4UTL2(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP4UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP4UTL2(Z),U,2)_"] "_N
QUIT
+8 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
IF Z]""
IF $$ICD^BGP4UTL2(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP4UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP4UTL2(Z),U,2)_"] "_N
QUIT
End DoDot:1
+9 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)
+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^BGP4UTL($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^BGP4UTL2(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 $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+19 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+20 IF $$ICD^BGP4UTL2(I,$ORDER(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP4UTL2(I,T,9))
IF N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK")
SET BGPC=BGPC+1
SET BGPY(BGPC)="PROBLEM LIST: "_$$DATE^BGP4UTL($PIECE(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
+21 QUIT
End DoDot:1
+22 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+23 ;entered after discharge date
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>BGPD
QUIT
+24 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+25 IF N["BETA BLOCK"
SET BGPC=BGPC+1
SET BGPY(BGPC)="ALLERGY TRACKING: "_$$DATE^BGP4UTL($PIECE(^GMR(120.8,X,0),U,4))_" "_N
End DoDot:1
+26 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^BGP4UTL(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^BGP4UTL(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^BGP4UTL2(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^BGP4UTL2(I,T,9)
SET BGPC=BGPC+1
SET BGPY(BGPC)="BRADYCARDIA POV: "_$$DATE^BGP4UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.07,X,.04)
QUIT
+15 IF $$ICD^BGP4UTL2(I,T1,9)
SET BGPC=BGPC+1
SET BGPY(BGPC)="2ND OR 3RD DEGREE HEART BLOCK POV: "_$$DATE^BGP4UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.07,X,.04)
QUIT
+16 IF $$ICD^BGP4UTL2(I,T2,9)
SET BGPC=BGPC+1
SET BGPY(BGPC)="CIRCULATORY SHOCK POV: "_$$DATE^BGP4UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.07,X,.04)
QUIT
+17 IF $$ICD^BGP4UTL2(I,T3,9)
SET BGPC=BGPC+1
SET BGPY(BGPC)="HEART FAILURE POV: "_$$DATE^BGP4UTL(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^BGP4UTL2(I),U,2)
+24 SET V=$PIECE($PIECE($GET(^AUPNVSIT(Z,0)),U),".")
+25 IF $$ICD^BGP4UTL2(I,T,9)
SET BGPC=BGPC+1
SET BGPY(BGPC)="BRADYCARDIA POV: "_$$DATE^BGP4UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.07,X,.04)
QUIT
+26 IF $$ICD^BGP4UTL2(I,T1,9)
SET BGPC=BGPC+1
SET BGPY(BGPC)="2ND OR 3RD DEGREE HEART BLOCK POV: "_$$DATE^BGP4UTL(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^BGP4UTL($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^BGP4DU(P,BGPD,BGPDDT,+$$CODEN^ICPTCOD("G8011"))
+42 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="CPT code G8011: "_$$DATE^BGP4UTL($PIECE(X,U,2))
+43 SET X=$$TRANI^BGP4DU(P,BGPD,BGPDDT,+$$CODEN^ICPTCOD("G8011"))
+44 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="TRAN code G8011: "_$$DATE^BGP4UTL($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^BGP4CU(P,BD,ED,"BGP CMS BETA BLOCKER MEDS","BGP CMS BETA BLOCKER NDC","BGP CMS BETA BLOCKER CLASS")
+6 SET X=$$CPTI^BGP4DU(P,BD,ED,+$$CODEN^ICPTCOD("G8009"))
+7 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="CPT code G8009: "_$$DATE^BGP4UTL($PIECE(X,U,2))
+8 SET X=$$TRANI^BGP4DU(P,BD,ED,+$$CODEN^ICPTCOD("G8009"))
+9 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="TRAN code G8009: "_$$DATE^BGP4UTL($PIECE(X,U,2))
+10 KILL BGPG
+11 SET BD=BGPA
+12 SET ED=$$FMADD^XLFDT(BGPD,30)
+13 DO GETMEDS^BGP4CU(P,BD,ED,"BGP CMS BETA BLOCKER MEDS","BGP CMS BETA BLOCKER NDC","BGP CMS BETA BLOCKER CLASS")
+14 SET X=$$CPTI^BGP4DU(P,BD,ED,+$$CODEN^ICPTCOD("G8009"))
+15 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="CPT code G8009: "_$$DATE^BGP4UTL($PIECE(X,U,2))
+16 SET X=$$TRANI^BGP4DU(P,BD,ED,+$$CODEN^ICPTCOD("G8009"))
+17 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="TRANBG code G8009: "_$$DATE^BGP4UTL($PIECE(X,U,2))
+18 KILL BGPG
+19 QUIT
