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