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