BGP3ALG1 ; IHS/CMI/LAB - measure AHR.A ;
;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
;
;
BETA ;EP - BETA BLOCKER CONTRAINDICATION/NMI REFUSAL
I $G(P)="" Q ""
S EDATE=$G(EDATE)
I EDATE="" S EDATE=DT
NEW BGPC,BGPG,BGPY,Y,E,X,N,Z,T
;get all povs with 995.0-995.3 with ecode of e935.3
S BGPC=0
BETAPOV ;
K BGPG,BGPY S Y="BGPG(",X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) 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^BGP3UTL($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^ATXCHK(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP3UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^ICDCODE(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$$ICD^ATXCHK(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP3UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^ICDCODE(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$$ICD^ATXCHK(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP3UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^ICDCODE(Z),U,2)_"] "_N Q
.Q
I BGPC>0 Q 1_U_BGPY(BGPC)
K BGPG S BGPC=0 S Y="BGPG(",X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) 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^BGP3UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N
I BGPC>0 Q 1_U_BGPY(BGPC)
;now check problem list
S BGPC=0
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)>EDATE
.I $$ICD^ATXCHK(I,$O(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^ATXCHK(I,T,9)),N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK") S BGPC=BGPC+1,BGPY(BGPC)="PROBLEM LIST: "_$$DATE^BGP3UTL($P(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
.Q
I BGPC>0 Q 1_U_BGPY(BGPC)
;now check allergy
S BGPC=0
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),".")>EDATE ;entered after end 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^BGP3UTL($P(^GMR(120.8,X,0),U,4))_" "_N
I BGPC>0 Q 1_U_BGPY(BGPC)
Q ""
;
ASA ;EP does patient have an aspirin allergy documented
;get all povs with 995.0-995.3 with ecode of e935.3 up to EDATE
I $G(P)="" Q ""
S EDATE=$G(EDATE)
I EDATE="" S EDATE=DT
NEW BGPG,G,X,N,Z,Y,T,I,E
K BGPG
S G=""
S X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X!(G) D
.S Y=+$P(BGPG(X),U,4)
.S N=$$VAL^XBDIQ1(9000010.07,Y,.04),N=$$UP^XLFSTR(N)
.I N["ASPIRIN"!(N["ASA") S G=1_U_$$DATE^BGP3UTL($P(BGPG(X),U))_" POV code "_$$VAL^XBDIQ1(9000010.07,Y,.01)_" "_N Q
.S T=$O(^ATXAX("B","BGP ADV EFF SALICYLATES",0))
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$$ICD^ATXCHK(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP3UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^ICDCODE(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$$ICD^ATXCHK(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP3UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^ICDCODE(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$$ICD^ATXCHK(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP3UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^ICDCODE(Z),U,2)_"] "_N Q
.Q
I G Q G ;found pov with ecode or narrative
K BGPG S Y="BGPG(",X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(BGPG(X)) Q:X'=+X!(G) D
.S Y=+$P(BGPG(X),U,4)
.S N=$$VAL^XBDIQ1(9000010.07,Y,.04),N=$$UP^XLFSTR(N)
.I N["ASPIRIN"!(N["ASA") S G=1_U_$$DATE^BGP3UTL($P(BGPG(X),U))_" POV code "_$$VAL^XBDIQ1(9000010.07,Y,.01)_" "_N
.Q
I G Q G
;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!(G) 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)>EDATE ;added after EDATE
.I $$ICD^ATXCHK(I,$O(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^ATXCHK(I,T,9)),N["ASPIRIN"!(N["ASA") S G=1_U_$$DATE^BGP3UTL($P(^AUPNPROB(X,0),U,8))_" Problem List code "_$$VAL^XBDIQ1(9000011,X,.01)_" "_N
.Q
I G Q G
;now check allergy tracking
S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X!(G) D
.Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>EDATE ;entered after EDATE
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.I N["ASPIRIN" S G=1_U_$$DATE^BGP3UTL($P($P($G(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking: "_N
Q G
;
;
ACEI ;EP - ACE ALLERGY
I $G(P)="" Q ""
S EDATE=$G(EDATE)
I EDATE="" S EDATE=DT
NEW ED,BD,BGPG,G,X,Y,Z,N,T,E,I
S G=""
K BGPG S Y="BGPG(",X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) 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 G=1_U_"POV: "_$$DATE^BGP3UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N Q
.S T=$O(^ATXAX("B","BGP ADV EFF ANTIHYPERTEN AGT",0))
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$$ICD^ATXCHK(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP3UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^ICDCODE(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$$ICD^ATXCHK(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP3UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^ICDCODE(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$$ICD^ATXCHK(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP3UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^ICDCODE(Z),U,2)_"] "_N Q
.Q
I G Q G
K BGPG S Y="BGPG(",X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) 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 G=1_U_"POV: "_$$DATE^BGP3UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N
I G Q G
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)>EDATE ;added after discharge date
.I $$ICD^ATXCHK(I,$O(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^ATXCHK(I,T,9)),N["ACEI"!(N["ACE I") S G=1_U_"PROBLEM LIST: "_$$DATE^BGP3UTL($P(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
.Q
I G Q G
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),".")>EDATE ;entered after discharge date
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.I N["ACEI"!(N["ACE INHIBITOR") S G=1_U_"ALLERGY TRACKING: "_$$DATE^BGP3UTL($P(^GMR(120.8,X,0),U,4))_" "_N
I G Q G
Q ""
ARB ;EP - ARB ALLERGIES
I $G(P)="" Q ""
S EDATE=$G(EDATE)
I EDATE="" S EDATE=DT
NEW ED,BD,BGPG,G,X,Y,Z,N,T,E,I,D,B
S G=""
K BGPG S Y="BGPG(",X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) 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 G=1_U_"POV: "_$$DATE^BGP3UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N Q
.S T=$O(^ATXAX("B","BGP ADV EFF ANTIHYPERTEN AGT",0))
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$$ICD^ATXCHK(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP3UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^ICDCODE(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$$ICD^ATXCHK(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP3UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^ICDCODE(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$$ICD^ATXCHK(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP3UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^ICDCODE(Z),U,2)_"] "_N Q
.Q
I G Q G
K BGPG S Y="BGPG(",X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) 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 G=1_U_"POV: "_$$DATE^BGP3UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N
I G Q G
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)>EDATE ;added after discharge date
.I $$ICD^ATXCHK(I,$O(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^ATXCHK(I,T,9)),N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER") S G=1_U_"PROBLEM LIST: "_$$DATE^BGP3UTL($P(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
.Q
I G Q G
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),".")>EDATE ;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 G=1_U_"ALLERGY TRACKING: "_$$DATE^BGP3UTL($P(^GMR(120.8,X,0),U,4))_" "_N
Q G
;
STATIN ;EP
I $G(P)="" Q ""
S EDATE=$G(EDATE)
I EDATE="" S EDATE=DT
I $G(BDATE)="" S BDATE=$$DOB^AUPNPAT(P)
NEW BGPC,BGPG,BGPY,Y,X,E,N,T,I,BGPLT,D,B,L,T2,BGPLT2
S BGPC=""
K BGPG,BGPY S Y="BGPG(",X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) 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["STATIN"!(N["STATINS") S BGPC=1_U_"Alg Statin POV: "_$$DATE^BGP3UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N Q
.S T=$O(^ATXAX("B","BGP ADV EFF CARDIOVASC NEC",0))
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$$ICD^ATXCHK(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP3UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^ICDCODE(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$$ICD^ATXCHK(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP3UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^ICDCODE(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$$ICD^ATXCHK(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP3UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^ICDCODE(Z),U,2)_"] "_N Q
.Q
I BGPC Q BGPC
K BGPG S BGPC=0 S Y="BGPG(",X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) 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["STATIN"!(N["STATINS") S BGPC=1_U_"alg statin POV: "_$$DATE^BGP3UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N
I BGPC Q BGPC
;now check problem list for these codes
S BGPC=0
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)>EDATE ;added after discharge date
.I $$ICD^ATXCHK(I,$O(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^ATXCHK(I,T,9)),N["STATIN"!(N["STATINS") S BGPC=1_U_"alg statin PROBLEM LIST: "_$$DATE^BGP3UTL($P(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
.Q
I BGPC Q BGPC
;now check allergy tracking
S BGPC=0
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),".")>EDATE ;entered after discharge date
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.I N["STATIN" S BGPC=1_U_" alg statin ALLERGY TRACKING: "_$$DATE^BGP3UTL($P(^GMR(120.8,X,0),U,4))_" "_N
I BGPC Q BGPC
;now go into the report period items
K BGPG S Y="BGPG(",X=P_"^LAST DX [BGP MYOPATHY/MYALGIA;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 1_U_"Statin allergy POV: "_$$DATE^BGP3UTL($P(BGPG(1),U))_" ["_$P(BGPG(1),U,2)_"] "_$$VAL^XBDIQ1(9000010.07,+$P(BGPG(1),U,4),.04)
;creatine lab value > 10,000 or 10x uln
;now get all loinc/taxonomy tests
S BGPG=""
S T=$O(^ATXAX("B","BGP CREATINE KINASE LOINC",0))
S BGPLT=$O(^ATXLAB("B","BGP CREATINE KINASE TAX",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(BGPG) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) I $$RESCK(X) S BGPG=1_U_"adr statin creat kinase of "_$P(^AUPNVLAB(X,0),U,4)_" on "_$$DATE^BGP3UTL((9999999-D)) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP3D2(J,T)
...I $$RESCK(X) S BGPG=1_U_"adr statin creat kinase of "_$P(^AUPNVLAB(X,0),U,4)_" on "_$$DATE^BGP3UTL((9999999-D)) Q
...Q
I BGPG Q BGPG
S T=$O(^ATXAX("B","BGP ALT LOINC",0))
S BGPLT=$O(^ATXLAB("B","DM AUDIT ALT TAX",0))
S T2=$O(^ATXAX("B","BGP AST LOINC",0))
S BGPLT2=$O(^ATXLAB("B","DM AUDIT AST TAX",0))
S B=9999999-$$FMADD^XLFDT(EDATE,-365),E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(BGPG) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=BGPC+1,BGPC((9999999-D))=X_U_$P(^AUPNVLAB(X,0),U,4)_U_$P($G(^AUPNVLAB(X,11)),U,5) Q
...I BGPLT2,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT2,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=BGPC+1,BGPC((9999999-D))=X_U_$P(^AUPNVLAB(X,0),U,4)_U_$P($G(^AUPNVLAB(X,11)),U,5) Q
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...I '$$LOINC^BGP3D2(J,T),'$$LOINC^BGP3D2(J,T2)
...S BGPC=BGPC+1,BGPC((9999999-D))=X_U_$P(^AUPNVLAB(X,0),U,4)_U_$P($G(^AUPNVLAB(X,11)),U,5) Q
...Q
;are they 2 consecutive
S BGPG=""
S X=0 F S X=$O(BGPC(X)) Q:X'=+X!(BGPG) D
.Q:'$$RESAL(BGPC(X))
.;is next one also bad?
.S Y=$O(BGPC(X))
.Q:Y="" ;no next one
.I $$RESAL(BGPC(Y)) S BGPG=1_U_"adr Statin - AST/ALT" Q
.Q
I BGPG Q BGPG
Q ""
;
RESAL(Y) ;
NEW V,ULN
S V=+$P(Y,U,2),ULN=$P(Y,U,3)
I ULN="" Q "" ;no upper limit so can't check
I V>(ULN*3) Q 1
Q ""
RESCK(Y) ;
NEW V,ULN
S V=+$P(^AUPNVLAB(X,0),U,4)
I V>10000 Q 1
S ULN=$P($G(^AUPNVLAB(X,11)),U,5)
I ULN="" Q 0 ;no upper limit, can't check
I V>(ULN*10) Q 1
Q 0
BGP3ALG1 ; IHS/CMI/LAB - measure AHR.A ;
+1 ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
+2 ;
+3 ;
BETA ;EP - BETA BLOCKER CONTRAINDICATION/NMI REFUSAL
+1 IF $GET(P)=""
QUIT ""
+2 SET EDATE=$GET(EDATE)
+3 IF EDATE=""
SET EDATE=DT
+4 NEW BGPC,BGPG,BGPY,Y,E,X,N,Z,T
+5 ;get all povs with 995.0-995.3 with ecode of e935.3
+6 SET BGPC=0
BETAPOV ;
+1 KILL BGPG,BGPY
SET Y="BGPG("
SET X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
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^BGP3UTL($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^ATXCHK(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP3UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^ICDCODE(Z),U,2)_"] "_N
QUIT
+7 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
IF Z]""
IF $$ICD^ATXCHK(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP3UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^ICDCODE(Z),U,2)_"] "_N
QUIT
+8 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
IF Z]""
IF $$ICD^ATXCHK(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP3UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^ICDCODE(Z),U,2)_"] "_N
QUIT
+9 QUIT
End DoDot:1
+10 IF BGPC>0
QUIT 1_U_BGPY(BGPC)
+11 KILL BGPG
SET BGPC=0
SET Y="BGPG("
SET X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+12 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+13 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+14 IF N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK")
SET BGPC=BGPC+1
SET BGPY(BGPC)="POV: "_$$DATE^BGP3UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
End DoDot:1
+15 IF BGPC>0
QUIT 1_U_BGPY(BGPC)
+16 ;now check problem list
+17 SET BGPC=0
+18 SET T=""
SET T=$ORDER(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
+19 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+20 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
SET Y=$PIECE($$ICDDX^ICDCODE(I),U,2)
+21 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+22 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+23 IF $$ICD^ATXCHK(I,$ORDER(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^ATXCHK(I,T,9))
IF N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK")
SET BGPC=BGPC+1
SET BGPY(BGPC)="PROBLEM LIST: "_$$DATE^BGP3UTL($PIECE(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
+24 QUIT
End DoDot:1
+25 IF BGPC>0
QUIT 1_U_BGPY(BGPC)
+26 ;now check allergy
+27 SET BGPC=0
+28 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+29 ;entered after end date
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>EDATE
QUIT
+30 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+31 IF N["BETA BLOCK"
SET BGPC=BGPC+1
SET BGPY(BGPC)="ALLERGY TRACKING: "_$$DATE^BGP3UTL($PIECE(^GMR(120.8,X,0),U,4))_" "_N
End DoDot:1
+32 IF BGPC>0
QUIT 1_U_BGPY(BGPC)
+33 QUIT ""
+34 ;
ASA ;EP does patient have an aspirin allergy documented
+1 ;get all povs with 995.0-995.3 with ecode of e935.3 up to EDATE
+2 IF $GET(P)=""
QUIT ""
+3 SET EDATE=$GET(EDATE)
+4 IF EDATE=""
SET EDATE=DT
+5 NEW BGPG,G,X,N,Z,Y,T,I,E
+6 KILL BGPG
+7 SET G=""
+8 SET X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,"BGPG(")
+9 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+10 SET Y=+$PIECE(BGPG(X),U,4)
+11 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+12 IF N["ASPIRIN"!(N["ASA")
SET G=1_U_$$DATE^BGP3UTL($PIECE(BGPG(X),U))_" POV code "_$$VAL^XBDIQ1(9000010.07,Y,.01)_" "_N
QUIT
+13 SET T=$ORDER(^ATXAX("B","BGP ADV EFF SALICYLATES",0))
+14 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $$ICD^ATXCHK(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP3UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^ICDCODE(Z),U,2)_"] "_N
QUIT
+15 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
IF Z]""
IF $$ICD^ATXCHK(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP3UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^ICDCODE(Z),U,2)_"] "_N
QUIT
+16 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
IF Z]""
IF $$ICD^ATXCHK(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP3UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^ICDCODE(Z),U,2)_"] "_N
QUIT
+17 QUIT
End DoDot:1
+18 ;found pov with ecode or narrative
IF G
QUIT G
+19 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+20 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+21 SET Y=+$PIECE(BGPG(X),U,4)
+22 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+23 IF N["ASPIRIN"!(N["ASA")
SET G=1_U_$$DATE^BGP3UTL($PIECE(BGPG(X),U))_" POV code "_$$VAL^XBDIQ1(9000010.07,Y,.01)_" "_N
+24 QUIT
End DoDot:1
+25 IF G
QUIT G
+26 ;now check problem list for these codes
+27 SET T=""
SET T=$ORDER(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
+28 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+29 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
SET Y=$PIECE($$ICDDX^ICDCODE(I),U,2)
+30 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+31 ;added after EDATE
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+32 IF $$ICD^ATXCHK(I,$ORDER(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^ATXCHK(I,T,9))
IF N["ASPIRIN"!(N["ASA")
SET G=1_U_$$DATE^BGP3UTL($PIECE(^AUPNPROB(X,0),U,8))_" Problem List code "_$$VAL^XBDIQ1(9000011,X,.01)_" "_N
+33 QUIT
End DoDot:1
+34 IF G
QUIT G
+35 ;now check allergy tracking
+36 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+37 ;entered after EDATE
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>EDATE
QUIT
+38 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+39 IF N["ASPIRIN"
SET G=1_U_$$DATE^BGP3UTL($PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking: "_N
End DoDot:1
+40 QUIT G
+41 ;
+42 ;
ACEI ;EP - ACE ALLERGY
+1 IF $GET(P)=""
QUIT ""
+2 SET EDATE=$GET(EDATE)
+3 IF EDATE=""
SET EDATE=DT
+4 NEW ED,BD,BGPG,G,X,Y,Z,N,T,E,I
+5 SET G=""
+6 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(EDATE)
SET E=$$START1^APCLDF(X,Y)
+7 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+8 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+9 IF N["ACEI"!(N["ACE I")
SET G=1_U_"POV: "_$$DATE^BGP3UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
QUIT
+10 SET T=$ORDER(^ATXAX("B","BGP ADV EFF ANTIHYPERTEN AGT",0))
+11 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $$ICD^ATXCHK(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP3UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^ICDCODE(Z),U,2)_"] "_N
QUIT
+12 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
IF Z]""
IF $$ICD^ATXCHK(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP3UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^ICDCODE(Z),U,2)_"] "_N
QUIT
+13 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
IF Z]""
IF $$ICD^ATXCHK(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP3UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^ICDCODE(Z),U,2)_"] "_N
QUIT
+14 QUIT
End DoDot:1
+15 IF G
QUIT G
+16 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+17 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+18 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+19 IF N["ACEI"!(N["ACE I")
SET G=1_U_"POV: "_$$DATE^BGP3UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
End DoDot:1
+20 IF G
QUIT G
+21 SET T=""
SET T=$ORDER(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
+22 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+23 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
SET Y=$PIECE($$ICDDX^ICDCODE(I),U,2)
+24 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+25 ;added after discharge date
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+26 IF $$ICD^ATXCHK(I,$ORDER(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^ATXCHK(I,T,9))
IF N["ACEI"!(N["ACE I")
SET G=1_U_"PROBLEM LIST: "_$$DATE^BGP3UTL($PIECE(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
+27 QUIT
End DoDot:1
+28 IF G
QUIT G
+29 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+30 ;entered after discharge date
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>EDATE
QUIT
+31 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+32 IF N["ACEI"!(N["ACE INHIBITOR")
SET G=1_U_"ALLERGY TRACKING: "_$$DATE^BGP3UTL($PIECE(^GMR(120.8,X,0),U,4))_" "_N
End DoDot:1
+33 IF G
QUIT G
+34 QUIT ""
ARB ;EP - ARB ALLERGIES
+1 IF $GET(P)=""
QUIT ""
+2 SET EDATE=$GET(EDATE)
+3 IF EDATE=""
SET EDATE=DT
+4 NEW ED,BD,BGPG,G,X,Y,Z,N,T,E,I,D,B
+5 SET G=""
+6 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(EDATE)
SET E=$$START1^APCLDF(X,Y)
+7 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+8 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+9 IF N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER")
SET G=1_U_"POV: "_$$DATE^BGP3UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
QUIT
+10 SET T=$ORDER(^ATXAX("B","BGP ADV EFF ANTIHYPERTEN AGT",0))
+11 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $$ICD^ATXCHK(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP3UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^ICDCODE(Z),U,2)_"] "_N
QUIT
+12 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
IF Z]""
IF $$ICD^ATXCHK(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP3UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^ICDCODE(Z),U,2)_"] "_N
QUIT
+13 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
IF Z]""
IF $$ICD^ATXCHK(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP3UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^ICDCODE(Z),U,2)_"] "_N
QUIT
+14 QUIT
End DoDot:1
+15 IF G
QUIT G
+16 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+17 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+18 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+19 IF N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER")
SET G=1_U_"POV: "_$$DATE^BGP3UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
End DoDot:1
+20 IF G
QUIT G
+21 SET T=""
SET T=$ORDER(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
+22 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+23 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
SET Y=$PIECE($$ICDDX^ICDCODE(I),U,2)
+24 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+25 ;added after discharge date
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+26 IF $$ICD^ATXCHK(I,$ORDER(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^ATXCHK(I,T,9))
IF N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER")
SET G=1_U_"PROBLEM LIST: "_$$DATE^BGP3UTL($PIECE(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
+27 QUIT
End DoDot:1
+28 IF G
QUIT G
+29 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+30 ;entered after discharge date
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>EDATE
QUIT
+31 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+32 IF N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER")
SET G=1_U_"ALLERGY TRACKING: "_$$DATE^BGP3UTL($PIECE(^GMR(120.8,X,0),U,4))_" "_N
End DoDot:1
+33 QUIT G
+34 ;
STATIN ;EP
+1 IF $GET(P)=""
QUIT ""
+2 SET EDATE=$GET(EDATE)
+3 IF EDATE=""
SET EDATE=DT
+4 IF $GET(BDATE)=""
SET BDATE=$$DOB^AUPNPAT(P)
+5 NEW BGPC,BGPG,BGPY,Y,X,E,N,T,I,BGPLT,D,B,L,T2,BGPLT2
+6 SET BGPC=""
+7 KILL BGPG,BGPY
SET Y="BGPG("
SET X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
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["STATIN"!(N["STATINS")
SET BGPC=1_U_"Alg Statin POV: "_$$DATE^BGP3UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
QUIT
+11 SET T=$ORDER(^ATXAX("B","BGP ADV EFF CARDIOVASC NEC",0))
+12 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $$ICD^ATXCHK(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP3UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^ICDCODE(Z),U,2)_"] "_N
QUIT
+13 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
IF Z]""
IF $$ICD^ATXCHK(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP3UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^ICDCODE(Z),U,2)_"] "_N
QUIT
+14 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
IF Z]""
IF $$ICD^ATXCHK(Z,T,9)
SET G=1_U_"POV: "_$$DATE^BGP3UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^ICDCODE(Z),U,2)_"] "_N
QUIT
+15 QUIT
End DoDot:1
+16 IF BGPC
QUIT BGPC
+17 KILL BGPG
SET BGPC=0
SET Y="BGPG("
SET X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+18 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+19 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+20 IF N["STATIN"!(N["STATINS")
SET BGPC=1_U_"alg statin POV: "_$$DATE^BGP3UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
End DoDot:1
+21 IF BGPC
QUIT BGPC
+22 ;now check problem list for these codes
+23 SET BGPC=0
+24 SET T=""
SET T=$ORDER(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
+25 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+26 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
SET Y=$PIECE($$ICDDX^ICDCODE(I),U,2)
+27 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+28 ;added after discharge date
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+29 IF $$ICD^ATXCHK(I,$ORDER(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^ATXCHK(I,T,9))
IF N["STATIN"!(N["STATINS")
SET BGPC=1_U_"alg statin PROBLEM LIST: "_$$DATE^BGP3UTL($PIECE(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
+30 QUIT
End DoDot:1
+31 IF BGPC
QUIT BGPC
+32 ;now check allergy tracking
+33 SET BGPC=0
+34 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+35 ;entered after discharge date
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>EDATE
QUIT
+36 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+37 IF N["STATIN"
SET BGPC=1_U_" alg statin ALLERGY TRACKING: "_$$DATE^BGP3UTL($PIECE(^GMR(120.8,X,0),U,4))_" "_N
End DoDot:1
+38 IF BGPC
QUIT BGPC
+39 ;now go into the report period items
+40 KILL BGPG
SET Y="BGPG("
SET X=P_"^LAST DX [BGP MYOPATHY/MYALGIA;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+41 IF $DATA(BGPG(1))
QUIT 1_U_"Statin allergy POV: "_$$DATE^BGP3UTL($PIECE(BGPG(1),U))_" ["_$PIECE(BGPG(1),U,2)_"] "_$$VAL^XBDIQ1(9000010.07,+$PIECE(BGPG(1),U,4),.04)
+42 ;creatine lab value > 10,000 or 10x uln
+43 ;now get all loinc/taxonomy tests
+44 SET BGPG=""
+45 SET T=$ORDER(^ATXAX("B","BGP CREATINE KINASE LOINC",0))
+46 SET BGPLT=$ORDER(^ATXLAB("B","BGP CREATINE KINASE TAX",0))
+47 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!(BGPG)
QUIT
Begin DoDot:1
+48 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+49 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+50 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+51 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
IF $$RESCK(X)
SET BGPG=1_U_"adr statin creat kinase of "_$PIECE(^AUPNVLAB(X,0),U,4)_" on "_$$DATE^BGP3UTL((9999999-D))
QUIT
+52 IF 'T
QUIT
+53 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+54 IF '$$LOINC^BGP3D2(J,T)
QUIT
+55 IF $$RESCK(X)
SET BGPG=1_U_"adr statin creat kinase of "_$PIECE(^AUPNVLAB(X,0),U,4)_" on "_$$DATE^BGP3UTL((9999999-D))
QUIT
+56 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+57 IF BGPG
QUIT BGPG
+58 SET T=$ORDER(^ATXAX("B","BGP ALT LOINC",0))
+59 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT ALT TAX",0))
+60 SET T2=$ORDER(^ATXAX("B","BGP AST LOINC",0))
+61 SET BGPLT2=$ORDER(^ATXLAB("B","DM AUDIT AST TAX",0))
+62 SET B=9999999-$$FMADD^XLFDT(EDATE,-365)
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!(BGPG)
QUIT
Begin DoDot:1
+63 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+64 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+65 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+66 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=BGPC+1
SET BGPC((9999999-D))=X_U_$PIECE(^AUPNVLAB(X,0),U,4)_U_$PIECE($GET(^AUPNVLAB(X,11)),U,5)
QUIT
+67 IF BGPLT2
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT2,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=BGPC+1
SET BGPC((9999999-D))=X_U_$PIECE(^AUPNVLAB(X,0),U,4)_U_$PIECE($GET(^AUPNVLAB(X,11)),U,5)
QUIT
+68 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+69 IF '$$LOINC^BGP3D2(J,T)
IF '$$LOINC^BGP3D2(J,T2)
+70 SET BGPC=BGPC+1
SET BGPC((9999999-D))=X_U_$PIECE(^AUPNVLAB(X,0),U,4)_U_$PIECE($GET(^AUPNVLAB(X,11)),U,5)
QUIT
+71 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+72 ;are they 2 consecutive
+73 SET BGPG=""
+74 SET X=0
FOR
SET X=$ORDER(BGPC(X))
IF X'=+X!(BGPG)
QUIT
Begin DoDot:1
+75 IF '$$RESAL(BGPC(X))
QUIT
+76 ;is next one also bad?
+77 SET Y=$ORDER(BGPC(X))
+78 ;no next one
IF Y=""
QUIT
+79 IF $$RESAL(BGPC(Y))
SET BGPG=1_U_"adr Statin - AST/ALT"
QUIT
+80 QUIT
End DoDot:1
+81 IF BGPG
QUIT BGPG
+82 QUIT ""
+83 ;
RESAL(Y) ;
+1 NEW V,ULN
+2 SET V=+$PIECE(Y,U,2)
SET ULN=$PIECE(Y,U,3)
+3 ;no upper limit so can't check
IF ULN=""
QUIT ""
+4 IF V>(ULN*3)
QUIT 1
+5 QUIT ""
RESCK(Y) ;
+1 NEW V,ULN
+2 SET V=+$PIECE(^AUPNVLAB(X,0),U,4)
+3 IF V>10000
QUIT 1
+4 SET ULN=$PIECE($GET(^AUPNVLAB(X,11)),U,5)
+5 ;no upper limit, can't check
IF ULN=""
QUIT 0
+6 IF V>(ULN*10)
QUIT 1
+7 QUIT 0
