BGP6D212 ; IHS/CMI/LAB - measure 6 19 Sep 2014 8:12 AM ;
;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
;
LOINC(A,B) ;EP
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
STRC ;EP - called from report execution
I 'BGPDMD1 S BGPSTOP=1 Q ;only up diabetics
I BGPAGEB<21 S BGPSTOP=1 Q ;ONLY 21+
NEW BGPCVDL
F X=1:1:7 S Y="BGPD"_X S @Y="" ;7 denominators
S (BGPN1,BGPN2,BGPN3)="" ;2 numerators
S BGPCVDL=$$CHDLDL(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) ;CHD OR LDL^CHD^LDL
I BGPAGEB>20,BGPAGEB<40,'BGPCVDL S BGPSTOP=1 Q ;21-39 and no cvd/ldl
I BGPAGEB>75,'BGPCVDL S BGPSTOP=1 Q ;>75 and no cvd/ldl
;DENOM 1
I BGPDMD2,BGPAGEB>39,BGPAGEB<76 S BGPD1=1 ;active diabetic ages 40-75
I BGPDMD2,BGPAGEB>20,BGPCVDL S BGPD1=1 ;or active diabetic 21+ w/CVD or LDL =>190
;DENOM 2 21-39, active diabetic with CVD or LDL >=190
I BGPDMD2,BGPAGEB>20,BGPAGEB<40,BGPCVDL S BGPD2=1
;DENOM 3 40-75, active diabetic with CVD or LDL =>190
I BGPDMD2,BGPAGEB>39,BGPAGEB<76,BGPCVDL S BGPD3=1
;DENOM 4 76+ with cvd or ldl >=190
I BGPDMD2,BGPAGEB>75,BGPCVDL S BGPD4=1
;DENOM 5 active diabetic 40-75
I BGPDMD2,BGPAGEB>39,BGPAGEB<76 S BGPD5=1
;DENOM 7 UP DM 40-75 or 12+ with cvd/ldl
I BGPDMD1,BGPAGEB>39,BGPAGEB<76 S BGPD7=1
I BGPDMD1,BGPAGEB>20,BGPCVDL S BGPD7=1
I BGPD1 S BGPD6=1
;now exclude people
S (BGPEXL1,BGPEXL2,BGPEXL3,BGPEXL4,BGPEXL5,BGPSTAT,BGPEXL6)=""
S BGPEXL1=$$STATALG(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,BGPBDATE,BGPEDATE) I BGPEXL1 S (BGPN2,BGPN3)=1 G ND ;excl 1
;ALCOHOL HEP
S BGPEXL1=$$ALCHEP(DFN,BGPBDATE,BGPEDATE) I BGPEXL1 S BGPN2=1 G ND
;NMI
S BGPEXL1=$$STATNMI(DFN,BGPBDATE,BGPEDATE) I BGPEXL1 S BGPN2=1 G ND
;PREGNANCY
S BGPEXL2=$$PREG^BGP6D7(DFN,BGPBDATE,BGPEDATE,1,1,1) I BGPEXL2 S BGPN2=1 G ND
;cirrhosis of liver
S BGPEXL6=$$CLIVER^BGP6D213(DFN,BGPPBD,BGPEDATE) I BGPEXL6 S BGPN2=1 G ND
;breastfeeding
S BGPEXL2=$$BF^BGP6D21(DFN,BGPBDATE,BGPEDATE) I BGPEXL2 S BGPN2=1 G ND
;PALLIATIVE
S BGPEXL3=$$LASTDX^BGP6UTL1(DFN,"BGP PALLIATIVE CARE DXS",BGPBDATE,BGPEDATE) I BGPEXL3 S BGPN2=1,BGPEXL3=1_U_$$DATE^BGP6UTL($P(BGPEXL3,U,3))_" Palliative Care" G ND ;excl 3
;ESRD
S BGPEXL4=$$ESRD^BGP6D211(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) I BGPEXL4 S BGPEXL4=1_U_$$DATE^BGP6UTL($P(BGPEXL4,U,3))_" ESRD" S BGPN2=1 G ND ;excl 4 ESRD
;EXCL 5
S BGPSTAT=$$STATIN^BGP6D214(DFN,BGPBDATE,BGPEDATE,0)
S BGPEXL5=$$LASTLDLV(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) I BGPEXL5,'$P(BGPCVDL,U,3),'BGPSTAT S BGPN2=1 G ND ;excl 5
ND ;
;DENOM 6 active diabetic 21+
I BGPN2,BGPD1 S BGPD6=1
I BGPN2 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD7)="" ;EXCLUDE EXCLUSIONS FROM DENOMINATORS
I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7) S BGPSTOP=1 Q ;not in at least UP denominator
;numerator
I 'BGPN2 S BGPN1=BGPSTAT
SETL ;
;S BGPVALUE=$S(BGPD1:"STA.1.1",1:"")_" "_$S(BGPD2:"STA.2.1",1:"")_" "_$S(BGPD3:"STA.3.1",1:"")_" "_$S(BGPD4:"STA.4.1",1:"")_" "_$S(BGPD5:"STA.5.1",1:"")_" "_$S(BGPD6:"STA.6.1",1:"")_" "_$S(BGPD7:"STA.7.1",1:"")
S BGPVALUE=$S(BGPDMD2:"UP,AD",1:"UP")_$S($P(BGPCVDL,U,2):" (CHD)",$P(BGPCVDL,U,3):" (LDL)",1:"")_"|||"
I BGPN1 S BGPVALUE=BGPVALUE_$P(BGPN1,U,2)
I BGPEXL1 S BGPVALUE=BGPVALUE_"Exclusion: "_$P(BGPEXL1,U,2)
I BGPEXL2 S BGPVALUE=BGPVALUE_"Exclusion: "_$P(BGPEXL2,U,2)_" Pregnant/Breastfeeding"
I BGPEXL3 S BGPVALUE=BGPVALUE_"Exclusion: "_$P(BGPEXL3,U,2)
I BGPEXL4 S BGPVALUE=BGPVALUE_"Exclusion: "_$P(BGPEXL4,U,2)
I BGPEXL6 S BGPVALUE=BGPVALUE_"Exclusion: "_$P(BGPEXL6,U,2)_" Cirrhosis"
I BGPEXL5,BGPN2 S BGPVALUE=BGPVALUE_"Exclusion: "_$P(BGPEXL5,U,2)
K BGPEXL1,BGPEXL2,BGPEXL3,BGPEXL4,BGPEXL5,BGPCVDL,BGPSTAT,BGPEXL6
Q
CHDLDL(P,BDATE,EDATE) ;EP - chd or ldl =>190
NEW RESULT
S RESULT=""
I $$CHD(P,BDATE,EDATE,0) S RESULT="1^1"
K TMP($J,"A")
I $$LDL190(P,BDATE,EDATE) S $P(RESULT,U,3)=1,$P(RESULT,U,1)=1
K ^TMP($J,"A")
Q RESULT
ALCHEP(P,BDATE,EDATE) ;EP
;NOW CHECK ALCOHOL HEPATITIS
NEW BGPG,Y,X,E
K BGPG S Y="BGPG(",X=P_"^LAST DX [BGP ALCOHOL HEPATITIS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 1_U_$$DATE^BGP6UTL($P(BGPG(1),U,1))_" Alc Hep"
Q ""
CHD(P,BDATE,EDATE,MIN) ;EP
NEW A,B,E,T,X,G,V,Y,%,G,F,BGPG,BGPCNT,T1,BGPALL,T2,T3
K BGPALL
S BGPCNT=0
K ^TMP($J,"A")
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q ""
S T=$O(^ATXAX("B","BGP CHD DXS",0))
S T1=$O(^ATXAX("B","BGP AMI DXS PAMT",0))
S T2=$O(^ATXAX("B","BGP IVD DXS",0))
S T3=$O(^ATXAX("B","BGP TIA DXS",0))
S (X,G)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(BGPCNT>MIN) S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.;Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
.S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MIN) I $D(^AUPNVPOV(Y,0)) D
..S %=$P(^AUPNVPOV(Y,0),U)
..I $$ICD^BGP6UTL2(%,T,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^BGP6UTL2(%,T1,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^BGP6UTL2(%,T2,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^BGP6UTL2(%,T3,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
I BGPCNT>MIN Q 1
CHDP ;NOW CHECK FOR MINPROC
;S BGPCNT=0
S (X,G)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(BGPCNT>MIN) S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.;Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
.S T1=$O(^ATXAX("B","BGP PCI DXS",0))
.S T2=$O(^ATXAX("B","BGP CABG DXS",0))
.S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MIN) I $D(^AUPNVPOV(Y,0)) D
..S %=$P(^AUPNVPOV(Y,0),U)
..I $$ICD^BGP6UTL2(%,T1,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^BGP6UTL2(%,T2,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
.I BGPCNT>MIN Q
.;check for procedure in BGP CABG PROCS
.S E=$O(^ATXAX("B","BGP CABG PROCS",0))
.S F=$O(^ATXAX("B","BGP PCI CM PROCS",0))
.S Y=0 F S Y=$O(^AUPNVPRC("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MIN) D
..Q:'$D(^AUPNVPRC(Y,0))
..I $$ICD^BGP6UTL2($P(^AUPNVPRC(Y,0),U,1),E,0) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^BGP6UTL2($P(^AUPNVPRC(Y,0),U,1),F,0) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1
.I BGPCNT>MIN Q
.;now check cpts
.S E=$O(^ATXAX("B","BGP CABG CPTS",0))
.S F=$O(^ATXAX("B","BGP PCI CPTS",0))
.S G=$O(^ATXAX("B","BGP REVASCULARIZATION CPTS",0))
.S Y=0 F S Y=$O(^AUPNVCPT("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MIN) D
..Q:'$D(^AUPNVCPT(Y,0))
..I $$ICD^BGP6UTL2($P(^AUPNVCPT(Y,0),U,1),E,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^BGP6UTL2($P(^AUPNVCPT(Y,0),U,1),F,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^BGP6UTL2($P(^AUPNVCPT(Y,0),U,1),G,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
.I BGPCNT>MIN Q
.;now check TRANS
.S E=$O(^ATXAX("B","BGP CABG CPTS",0))
.S F=$O(^ATXAX("B","BGP PCI CPTS",0))
.S G=$O(^ATXAX("B","BGP REVASCULARIZATION CPTS",0))
.S Y=0 F S Y=$O(^AUPNVTC("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MIN) D
..Q:'$D(^AUPNVTC(Y,0))
..S I=$P(^AUPNVTC(Y,0),U,7)
..Q:I=""
..I $$ICD^BGP6UTL2(I,E,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^BGP6UTL2(I,F,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^BGP6UTL2(I,G,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
.Q
I BGPCNT>MIN Q 1
Q ""
LDL190(P,BDATE,EDATE) ;EP ldl >=190? EVER
NEW T,A,E,LT,G,X,J,R
K ^TMP($J,"A")
S A="^TMP($J,""A"",",%=P_"^ALL LAB;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
I '$D(^TMP($J,"A",1)) Q ""
;now go through all lab tests and see if any are the loinc codes in the taxonomy
S T=$O(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))
S LT=$O(^ATXAX("B","BGP LDL LOINC CODES",0))
S (X,G)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G) S I=+$P(^TMP($J,"A",X),U,4) D
.S %=+^AUPNVLAB(I,0),R=$P(^AUPNVLAB(I,0),U,4)
.I $D(^ATXLAB(T,21,"B",%)),+R>189.999999 S G=1 Q
.S J=$P($G(^AUPNVLAB(I,11)),U,13)
.Q:J=""
.I $$LOINC^BGP6D21(J,LT),+R>189.99999 S G=1
K ^TMP($J,"A")
Q G
LASTLDLV(P,BDATE,EDATE) ;EP
NEW BGPG,BGPT,BGPC,BGPLT,T,B,E,D,L,X,R,G,C,%
K BGPG,BGPT,BGPC
S BGPC=0
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP LDL LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL 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)!(BGPC) 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))
...Q:$P(^AUPNVLAB(X,0),U,4)="" ;NO RESULT
...Q:'+$P(^AUPNVLAB(X,0),U,4) ;NON-NUMERIC RESULT
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=BGPC+1,BGPT(BGPC)=$P(^AUPNVLAB(X,0),U,4)_U_(9999999-D) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S R=$P(^AUPNVLAB(X,0),U,4)
...I 'R S R=""
...S BGPC=BGPC+1,BGPT(BGPC)=$P(^AUPNVLAB(X,0),U,4)_U_(9999999-D)
...Q
I 'BGPC Q ""
I +BGPT(BGPC)<70 Q 1_U_$$DATE^BGP6UTL($P(BGPT(BGPC),U,2))_" LDL < 70"
Q ""
STATNMI(P,NMIB,NMIE) ;EP
;nmi
NEW BGPG,X,T,D,Y,N
S BGPG=""
S T=$O(^ATXAX("B","BGP PQA STATIN MEDS",0))
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 STATI
.S D=0 F S D=$O(^AUPNPREF("AA",P,50,X,D)) Q:D'=+D D
..S Y=9999999-D I Y<NMIB Q
..I Y>NMIE Q
..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 BGPG=1_U_$$DATE^BGP6UTL($P(^AUPNPREF(N,0),U,3))_" Contra NMI "_$$VAL^XBDIQ1(9000022,N,.04) ;_" "_" "_$$VAL^XBDIQ1(9000022,X,1101)
..Q
.Q
I BGPG Q BGPG
Q ""
STATALG(P,BDATE,EDATE,RPB,RPE) ;EP
;get all visits and check for ALT/AST tests on 2 consecutive visits
NEW BGPG,BGPY,Y,X,N,Z,BGPC
S BGPC=""
K BGPG,BGPY S Y="BGPG(",X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$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_$$DATE^BGP6UTL($P(BGPG(X),U))_" ADR/Allergy POV "_$P(BGPG(X),U,2)
.S T=$O(^ATXAX("B","BGP ADV EFF CARDIOVASC NEC",0))
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$$ICD^BGP6UTL2(Z,T,9) S BGPC=1_U_$$DATE^BGP1UTL($P(BGPG(X),U))_" ADR/Allergy POV ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$$ICD^BGP6UTL2(Z,T,9) S BGPC=1_U_$$DATE^BGP1UTL($P(BGPG(X),U))_" ADR/Allergy POV ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$$ICD^BGP6UTL2(Z,T,9) S BGPC=1_U_$$DATE^BGP1UTL($P(BGPG(X),U))_" ADR/Allergy POV ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP6UTL2(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(BDATE)_"-"_$$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_$$DATE^BGP6UTL($P(BGPG(X),U))_" ADR/Allergy POV "_$P(BGPG(X),U,2) ;_"]"
I BGPC Q BGPC
;PL
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^BGP6UTL2(I),U,2)
.S N=$$VAL^XBDIQ1(9000011,X,.05),N=$$UP^XLFSTR(N)
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.I $$ICD^BGP6UTL2(I,$O(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP6UTL2(I,T,9)),N["STATIN"!(N["STATINS") S BGPC=1_U_$$DATE^BGP6UTL($P(^AUPNPROB(X,0),U,8))_" ADR/Allergy Problem List "_Y ;_"]"
.Q
I BGPC Q BGPC
;ART
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
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.I N["STATIN" S BGPC=1_U_$$DATE^BGP6UTL($P(^GMR(120.8,X,0),U,4))_" ADR/Allergy Allergy Tracking "_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(RPB)_"-"_$$FMTE^XLFDT(RPE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 1_U_$$DATE^BGP6UTL($P(BGPG(1),U))_" ADR/Allergy POV "_"Myalgia" ;$P(BGPG(1),U,2) ;_"]"
;creatine lab value > 10,000 or 10x uln
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-RPB,E=9999999-RPE 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^BGP6D722(X) S BGPG=1_U_$$DATE^BGP6UTL((9999999-D))_" ADR/Allergy creat kinase of "_$P(^AUPNVLAB(X,0),U,4) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP6D2(J,T)
...I $$RESCK^BGP6D722(X) S BGPG=1_U_$$DATE^BGP6UTL((9999999-D))_" ADR/Allergy creat kinase of "_$P(^AUPNVLAB(X,0),U,4) 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^BGP6D2(J,T),'$$LOINC^BGP6D2(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^BGP6D722(BGPC(X))
.;is next one also bad?
.S Y=$O(BGPC(X))
.Q:Y=""
.I $$RESAL^BGP6D722(BGPC(Y)) S BGPG=1_U_" ADR/Allergy AST/ALT" Q
.Q
I BGPG Q BGPG
Q 0
BGP6D212 ; IHS/CMI/LAB - measure 6 19 Sep 2014 8:12 AM ;
+1 ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
+2 ;
LOINC(A,B) ;EP
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
STRC ;EP - called from report execution
+1 ;only up diabetics
IF 'BGPDMD1
SET BGPSTOP=1
QUIT
+2 ;ONLY 21+
IF BGPAGEB<21
SET BGPSTOP=1
QUIT
+3 NEW BGPCVDL
+4 ;7 denominators
FOR X=1:1:7
SET Y="BGPD"_X
SET @Y=""
+5 ;2 numerators
SET (BGPN1,BGPN2,BGPN3)=""
+6 ;CHD OR LDL^CHD^LDL
SET BGPCVDL=$$CHDLDL(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+7 ;21-39 and no cvd/ldl
IF BGPAGEB>20
IF BGPAGEB<40
IF 'BGPCVDL
SET BGPSTOP=1
QUIT
+8 ;>75 and no cvd/ldl
IF BGPAGEB>75
IF 'BGPCVDL
SET BGPSTOP=1
QUIT
+9 ;DENOM 1
+10 ;active diabetic ages 40-75
IF BGPDMD2
IF BGPAGEB>39
IF BGPAGEB<76
SET BGPD1=1
+11 ;or active diabetic 21+ w/CVD or LDL =>190
IF BGPDMD2
IF BGPAGEB>20
IF BGPCVDL
SET BGPD1=1
+12 ;DENOM 2 21-39, active diabetic with CVD or LDL >=190
+13 IF BGPDMD2
IF BGPAGEB>20
IF BGPAGEB<40
IF BGPCVDL
SET BGPD2=1
+14 ;DENOM 3 40-75, active diabetic with CVD or LDL =>190
+15 IF BGPDMD2
IF BGPAGEB>39
IF BGPAGEB<76
IF BGPCVDL
SET BGPD3=1
+16 ;DENOM 4 76+ with cvd or ldl >=190
+17 IF BGPDMD2
IF BGPAGEB>75
IF BGPCVDL
SET BGPD4=1
+18 ;DENOM 5 active diabetic 40-75
+19 IF BGPDMD2
IF BGPAGEB>39
IF BGPAGEB<76
SET BGPD5=1
+20 ;DENOM 7 UP DM 40-75 or 12+ with cvd/ldl
+21 IF BGPDMD1
IF BGPAGEB>39
IF BGPAGEB<76
SET BGPD7=1
+22 IF BGPDMD1
IF BGPAGEB>20
IF BGPCVDL
SET BGPD7=1
+23 IF BGPD1
SET BGPD6=1
+24 ;now exclude people
+25 SET (BGPEXL1,BGPEXL2,BGPEXL3,BGPEXL4,BGPEXL5,BGPSTAT,BGPEXL6)=""
+26 ;excl 1
SET BGPEXL1=$$STATALG(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,BGPBDATE,BGPEDATE)
IF BGPEXL1
SET (BGPN2,BGPN3)=1
GOTO ND
+27 ;ALCOHOL HEP
+28 SET BGPEXL1=$$ALCHEP(DFN,BGPBDATE,BGPEDATE)
IF BGPEXL1
SET BGPN2=1
GOTO ND
+29 ;NMI
+30 SET BGPEXL1=$$STATNMI(DFN,BGPBDATE,BGPEDATE)
IF BGPEXL1
SET BGPN2=1
GOTO ND
+31 ;PREGNANCY
+32 SET BGPEXL2=$$PREG^BGP6D7(DFN,BGPBDATE,BGPEDATE,1,1,1)
IF BGPEXL2
SET BGPN2=1
GOTO ND
+33 ;cirrhosis of liver
+34 SET BGPEXL6=$$CLIVER^BGP6D213(DFN,BGPPBD,BGPEDATE)
IF BGPEXL6
SET BGPN2=1
GOTO ND
+35 ;breastfeeding
+36 SET BGPEXL2=$$BF^BGP6D21(DFN,BGPBDATE,BGPEDATE)
IF BGPEXL2
SET BGPN2=1
GOTO ND
+37 ;PALLIATIVE
+38 ;excl 3
SET BGPEXL3=$$LASTDX^BGP6UTL1(DFN,"BGP PALLIATIVE CARE DXS",BGPBDATE,BGPEDATE)
IF BGPEXL3
SET BGPN2=1
SET BGPEXL3=1_U_$$DATE^BGP6UTL($PIECE(BGPEXL3,U,3))_" Palliative Care"
GOTO ND
+39 ;ESRD
+40 ;excl 4 ESRD
SET BGPEXL4=$$ESRD^BGP6D211(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
IF BGPEXL4
SET BGPEXL4=1_U_$$DATE^BGP6UTL($PIECE(BGPEXL4,U,3))_" ESRD"
SET BGPN2=1
GOTO ND
+41 ;EXCL 5
+42 SET BGPSTAT=$$STATIN^BGP6D214(DFN,BGPBDATE,BGPEDATE,0)
+43 ;excl 5
SET BGPEXL5=$$LASTLDLV(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
IF BGPEXL5
IF '$PIECE(BGPCVDL,U,3)
IF 'BGPSTAT
SET BGPN2=1
GOTO ND
ND ;
+1 ;DENOM 6 active diabetic 21+
+2 IF BGPN2
IF BGPD1
SET BGPD6=1
+3 ;EXCLUDE EXCLUSIONS FROM DENOMINATORS
IF BGPN2
SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD7)=""
+4 ;not in at least UP denominator
IF '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7)
SET BGPSTOP=1
QUIT
+5 ;numerator
+6 IF 'BGPN2
SET BGPN1=BGPSTAT
SETL ;
+1 ;S BGPVALUE=$S(BGPD1:"STA.1.1",1:"")_" "_$S(BGPD2:"STA.2.1",1:"")_" "_$S(BGPD3:"STA.3.1",1:"")_" "_$S(BGPD4:"STA.4.1",1:"")_" "_$S(BGPD5:"STA.5.1",1:"")_" "_$S(BGPD6:"STA.6.1",1:"")_" "_$S(BGPD7:"STA.7.1",1:"")
+2 SET BGPVALUE=$SELECT(BGPDMD2:"UP,AD",1:"UP")_$SELECT($PIECE(BGPCVDL,U,2):" (CHD)",$PIECE(BGPCVDL,U,3):" (LDL)",1:"")_"|||"
+3 IF BGPN1
SET BGPVALUE=BGPVALUE_$PIECE(BGPN1,U,2)
+4 IF BGPEXL1
SET BGPVALUE=BGPVALUE_"Exclusion: "_$PIECE(BGPEXL1,U,2)
+5 IF BGPEXL2
SET BGPVALUE=BGPVALUE_"Exclusion: "_$PIECE(BGPEXL2,U,2)_" Pregnant/Breastfeeding"
+6 IF BGPEXL3
SET BGPVALUE=BGPVALUE_"Exclusion: "_$PIECE(BGPEXL3,U,2)
+7 IF BGPEXL4
SET BGPVALUE=BGPVALUE_"Exclusion: "_$PIECE(BGPEXL4,U,2)
+8 IF BGPEXL6
SET BGPVALUE=BGPVALUE_"Exclusion: "_$PIECE(BGPEXL6,U,2)_" Cirrhosis"
+9 IF BGPEXL5
IF BGPN2
SET BGPVALUE=BGPVALUE_"Exclusion: "_$PIECE(BGPEXL5,U,2)
+10 KILL BGPEXL1,BGPEXL2,BGPEXL3,BGPEXL4,BGPEXL5,BGPCVDL,BGPSTAT,BGPEXL6
+11 QUIT
CHDLDL(P,BDATE,EDATE) ;EP - chd or ldl =>190
+1 NEW RESULT
+2 SET RESULT=""
+3 IF $$CHD(P,BDATE,EDATE,0)
SET RESULT="1^1"
+4 KILL TMP($JOB,"A")
+5 IF $$LDL190(P,BDATE,EDATE)
SET $PIECE(RESULT,U,3)=1
SET $PIECE(RESULT,U,1)=1
+6 KILL ^TMP($JOB,"A")
+7 QUIT RESULT
ALCHEP(P,BDATE,EDATE) ;EP
+1 ;NOW CHECK ALCOHOL HEPATITIS
+2 NEW BGPG,Y,X,E
+3 KILL BGPG
SET Y="BGPG("
SET X=P_"^LAST DX [BGP ALCOHOL HEPATITIS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 IF $DATA(BGPG(1))
QUIT 1_U_$$DATE^BGP6UTL($PIECE(BGPG(1),U,1))_" Alc Hep"
+5 QUIT ""
CHD(P,BDATE,EDATE,MIN) ;EP
+1 NEW A,B,E,T,X,G,V,Y,%,G,F,BGPG,BGPCNT,T1,BGPALL,T2,T3
+2 KILL BGPALL
+3 SET BGPCNT=0
+4 KILL ^TMP($JOB,"A")
+5 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+6 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+7 SET T=$ORDER(^ATXAX("B","BGP CHD DXS",0))
+8 SET T1=$ORDER(^ATXAX("B","BGP AMI DXS PAMT",0))
+9 SET T2=$ORDER(^ATXAX("B","BGP IVD DXS",0))
+10 SET T3=$ORDER(^ATXAX("B","BGP TIA DXS",0))
+11 SET (X,G)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(BGPCNT>MIN)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+12 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+13 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+14 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+15 ;Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
+16 SET (D,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(BGPCNT>MIN)
QUIT
IF $DATA(^AUPNVPOV(Y,0))
Begin DoDot:2
+17 SET %=$PIECE(^AUPNVPOV(Y,0),U)
+18 IF $$ICD^BGP6UTL2(%,T,9)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+19 IF $$ICD^BGP6UTL2(%,T1,9)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+20 IF $$ICD^BGP6UTL2(%,T2,9)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+21 IF $$ICD^BGP6UTL2(%,T3,9)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
End DoDot:2
End DoDot:1
+22 IF BGPCNT>MIN
QUIT 1
CHDP ;NOW CHECK FOR MINPROC
+1 ;S BGPCNT=0
+2 SET (X,G)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(BGPCNT>MIN)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+3 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+4 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+5 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+6 ;Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
+7 SET T1=$ORDER(^ATXAX("B","BGP PCI DXS",0))
+8 SET T2=$ORDER(^ATXAX("B","BGP CABG DXS",0))
+9 SET (D,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(BGPCNT>MIN)
QUIT
IF $DATA(^AUPNVPOV(Y,0))
Begin DoDot:2
+10 SET %=$PIECE(^AUPNVPOV(Y,0),U)
+11 IF $$ICD^BGP6UTL2(%,T1,9)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+12 IF $$ICD^BGP6UTL2(%,T2,9)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
End DoDot:2
+13 IF BGPCNT>MIN
QUIT
+14 ;check for procedure in BGP CABG PROCS
+15 SET E=$ORDER(^ATXAX("B","BGP CABG PROCS",0))
+16 SET F=$ORDER(^ATXAX("B","BGP PCI CM PROCS",0))
+17 SET Y=0
FOR
SET Y=$ORDER(^AUPNVPRC("AD",V,Y))
IF Y'=+Y!(BGPCNT>MIN)
QUIT
Begin DoDot:2
+18 IF '$DATA(^AUPNVPRC(Y,0))
QUIT
+19 IF $$ICD^BGP6UTL2($PIECE(^AUPNVPRC(Y,0),U,1),E,0)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+20 IF $$ICD^BGP6UTL2($PIECE(^AUPNVPRC(Y,0),U,1),F,0)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
End DoDot:2
+21 IF BGPCNT>MIN
QUIT
+22 ;now check cpts
+23 SET E=$ORDER(^ATXAX("B","BGP CABG CPTS",0))
+24 SET F=$ORDER(^ATXAX("B","BGP PCI CPTS",0))
+25 SET G=$ORDER(^ATXAX("B","BGP REVASCULARIZATION CPTS",0))
+26 SET Y=0
FOR
SET Y=$ORDER(^AUPNVCPT("AD",V,Y))
IF Y'=+Y!(BGPCNT>MIN)
QUIT
Begin DoDot:2
+27 IF '$DATA(^AUPNVCPT(Y,0))
QUIT
+28 IF $$ICD^BGP6UTL2($PIECE(^AUPNVCPT(Y,0),U,1),E,1)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+29 IF $$ICD^BGP6UTL2($PIECE(^AUPNVCPT(Y,0),U,1),F,1)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+30 IF $$ICD^BGP6UTL2($PIECE(^AUPNVCPT(Y,0),U,1),G,1)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
End DoDot:2
+31 IF BGPCNT>MIN
QUIT
+32 ;now check TRANS
+33 SET E=$ORDER(^ATXAX("B","BGP CABG CPTS",0))
+34 SET F=$ORDER(^ATXAX("B","BGP PCI CPTS",0))
+35 SET G=$ORDER(^ATXAX("B","BGP REVASCULARIZATION CPTS",0))
+36 SET Y=0
FOR
SET Y=$ORDER(^AUPNVTC("AD",V,Y))
IF Y'=+Y!(BGPCNT>MIN)
QUIT
Begin DoDot:2
+37 IF '$DATA(^AUPNVTC(Y,0))
QUIT
+38 SET I=$PIECE(^AUPNVTC(Y,0),U,7)
+39 IF I=""
QUIT
+40 IF $$ICD^BGP6UTL2(I,E,1)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+41 IF $$ICD^BGP6UTL2(I,F,1)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+42 IF $$ICD^BGP6UTL2(I,G,1)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
End DoDot:2
+43 QUIT
End DoDot:1
+44 IF BGPCNT>MIN
QUIT 1
+45 QUIT ""
LDL190(P,BDATE,EDATE) ;EP ldl >=190? EVER
+1 NEW T,A,E,LT,G,X,J,R
+2 KILL ^TMP($JOB,"A")
+3 SET A="^TMP($J,""A"","
SET %=P_"^ALL LAB;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+4 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+5 ;now go through all lab tests and see if any are the loinc codes in the taxonomy
+6 SET T=$ORDER(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))
+7 SET LT=$ORDER(^ATXAX("B","BGP LDL LOINC CODES",0))
+8 SET (X,G)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(G)
QUIT
SET I=+$PIECE(^TMP($JOB,"A",X),U,4)
Begin DoDot:1
+9 SET %=+^AUPNVLAB(I,0)
SET R=$PIECE(^AUPNVLAB(I,0),U,4)
+10 IF $DATA(^ATXLAB(T,21,"B",%))
IF +R>189.999999
SET G=1
QUIT
+11 SET J=$PIECE($GET(^AUPNVLAB(I,11)),U,13)
+12 IF J=""
QUIT
+13 IF $$LOINC^BGP6D21(J,LT)
IF +R>189.99999
SET G=1
End DoDot:1
+14 KILL ^TMP($JOB,"A")
+15 QUIT G
LASTLDLV(P,BDATE,EDATE) ;EP
+1 NEW BGPG,BGPT,BGPC,BGPLT,T,B,E,D,L,X,R,G,C,%
+2 KILL BGPG,BGPT,BGPC
+3 SET BGPC=0
+4 ;now get all loinc/taxonomy tests
+5 SET T=$ORDER(^ATXAX("B","BGP LDL LOINC CODES",0))
+6 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))
+7 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)!(BGPC)
QUIT
Begin DoDot:1
+8 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+9 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+10 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+11 ;NO RESULT
IF $PIECE(^AUPNVLAB(X,0),U,4)=""
QUIT
+12 ;NON-NUMERIC RESULT
IF '+$PIECE(^AUPNVLAB(X,0),U,4)
QUIT
+13 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=BGPC+1
SET BGPT(BGPC)=$PIECE(^AUPNVLAB(X,0),U,4)_U_(9999999-D)
QUIT
+14 IF 'T
QUIT
+15 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+16 IF '$$LOINC(J,T)
QUIT
+17 SET R=$PIECE(^AUPNVLAB(X,0),U,4)
+18 IF 'R
SET R=""
+19 SET BGPC=BGPC+1
SET BGPT(BGPC)=$PIECE(^AUPNVLAB(X,0),U,4)_U_(9999999-D)
+20 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+21 IF 'BGPC
QUIT ""
+22 IF +BGPT(BGPC)<70
QUIT 1_U_$$DATE^BGP6UTL($PIECE(BGPT(BGPC),U,2))_" LDL < 70"
+23 QUIT ""
STATNMI(P,NMIB,NMIE) ;EP
+1 ;nmi
+2 NEW BGPG,X,T,D,Y,N
+3 SET BGPG=""
+4 SET T=$ORDER(^ATXAX("B","BGP PQA STATIN MEDS",0))
+5 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,50,X))
IF X'=+X
QUIT
Begin DoDot:1
+6 ;not an STATI
IF '$DATA(^ATXAX(T,21,"B",X))
QUIT
+7 SET D=0
FOR
SET D=$ORDER(^AUPNPREF("AA",P,50,X,D))
IF D'=+D
QUIT
Begin DoDot:2
+8 SET Y=9999999-D
IF Y<NMIB
QUIT
+9 IF Y>NMIE
QUIT
+10 SET N=0
FOR
SET N=$ORDER(^AUPNPREF("AA",P,50,X,D,N))
IF N'=+N
QUIT
Begin DoDot:3
+11 IF $PIECE($GET(^AUPNPREF(N,0)),U,7)'="N"
QUIT
+12 ;_" "_" "_$$VAL^XBDIQ1(9000022,X,1101)
SET BGPG=1_U_$$DATE^BGP6UTL($PIECE(^AUPNPREF(N,0),U,3))_" Contra NMI "_$$VAL^XBDIQ1(9000022,N,.04)
End DoDot:3
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 IF BGPG
QUIT BGPG
+16 QUIT ""
STATALG(P,BDATE,EDATE,RPB,RPE) ;EP
+1 ;get all visits and check for ALT/AST tests on 2 consecutive visits
+2 NEW BGPG,BGPY,Y,X,N,Z,BGPC
+3 SET BGPC=""
+4 KILL BGPG,BGPY
SET Y="BGPG("
SET X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+6 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+7 IF N["STATIN"!(N["STATINS")
SET BGPC=1_U_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ADR/Allergy POV "_$PIECE(BGPG(X),U,2)
+8 SET T=$ORDER(^ATXAX("B","BGP ADV EFF CARDIOVASC NEC",0))
+9 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $$ICD^BGP6UTL2(Z,T,9)
SET BGPC=1_U_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" ADR/Allergy POV ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N
QUIT
+10 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
IF Z]""
IF $$ICD^BGP6UTL2(Z,T,9)
SET BGPC=1_U_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" ADR/Allergy POV ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N
QUIT
+11 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
IF Z]""
IF $$ICD^BGP6UTL2(Z,T,9)
SET BGPC=1_U_$$DATE^BGP1UTL($PIECE(BGPG(X),U))_" ADR/Allergy POV ["_$PIECE(BGPG(X),U,2)_" + "_$PIECE($$ICDDX^BGP6UTL2(Z),U,2)_"] "_N
QUIT
+12 QUIT
End DoDot:1
+13 IF BGPC
QUIT BGPC
+14 KILL BGPG
SET BGPC=0
SET Y="BGPG("
SET X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$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_$$DATE^BGP6UTL($PIECE(BGPG(X),U))_" ADR/Allergy POV "_$PIECE(BGPG(X),U,2)
End DoDot:1
+18 IF BGPC
QUIT BGPC
+19 ;PL
+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^BGP6UTL2(I),U,2)
+24 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+25 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+26 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+27 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+28 ;_"]"
IF $$ICD^BGP6UTL2(I,$ORDER(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP6UTL2(I,T,9))
IF N["STATIN"!(N["STATINS")
SET BGPC=1_U_$$DATE^BGP6UTL($PIECE(^AUPNPROB(X,0),U,8))_" ADR/Allergy Problem List "_Y
+29 QUIT
End DoDot:1
+30 IF BGPC
QUIT BGPC
+31 ;ART
+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 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_$$DATE^BGP6UTL($PIECE(^GMR(120.8,X,0),U,4))_" ADR/Allergy Allergy Tracking "_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(RPB)_"-"_$$FMTE^XLFDT(RPE)
SET E=$$START1^APCLDF(X,Y)
+40 ;$P(BGPG(1),U,2) ;_"]"
IF $DATA(BGPG(1))
QUIT 1_U_$$DATE^BGP6UTL($PIECE(BGPG(1),U))_" ADR/Allergy POV "_"Myalgia"
+41 ;creatine lab value > 10,000 or 10x uln
+42 SET BGPG=""
+43 SET T=$ORDER(^ATXAX("B","BGP CREATINE KINASE LOINC",0))
+44 SET BGPLT=$ORDER(^ATXLAB("B","BGP CREATINE KINASE TAX",0))
+45 SET B=9999999-RPB
SET E=9999999-RPE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!(BGPG)
QUIT
Begin DoDot:1
+46 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+47 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+48 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+49 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
IF $$RESCK^BGP6D722(X)
SET BGPG=1_U_$$DATE^BGP6UTL((9999999-D))_" ADR/Allergy creat kinase of "_$PIECE(^AUPNVLAB(X,0),U,4)
QUIT
+50 IF 'T
QUIT
+51 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+52 IF '$$LOINC^BGP6D2(J,T)
QUIT
+53 IF $$RESCK^BGP6D722(X)
SET BGPG=1_U_$$DATE^BGP6UTL((9999999-D))_" ADR/Allergy creat kinase of "_$PIECE(^AUPNVLAB(X,0),U,4)
QUIT
+54 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+55 IF BGPG
QUIT BGPG
+56 SET T=$ORDER(^ATXAX("B","BGP ALT LOINC",0))
+57 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT ALT TAX",0))
+58 SET T2=$ORDER(^ATXAX("B","BGP AST LOINC",0))
+59 SET BGPLT2=$ORDER(^ATXLAB("B","DM AUDIT AST TAX",0))
+60 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
+61 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+62 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+63 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+64 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
+65 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
+66 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+67 IF '$$LOINC^BGP6D2(J,T)
IF '$$LOINC^BGP6D2(J,T2)
+68 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
+69 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+70 ;are they 2 consecutive
+71 SET BGPG=""
+72 SET X=0
FOR
SET X=$ORDER(BGPC(X))
IF X'=+X!(BGPG)
QUIT
Begin DoDot:1
+73 IF '$$RESAL^BGP6D722(BGPC(X))
QUIT
+74 ;is next one also bad?
+75 SET Y=$ORDER(BGPC(X))
+76 IF Y=""
QUIT
+77 IF $$RESAL^BGP6D722(BGPC(Y))
SET BGPG=1_U_" ADR/Allergy AST/ALT"
QUIT
+78 QUIT
End DoDot:1
+79 IF BGPG
QUIT BGPG
+80 QUIT 0
