Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP6D212

BGP6D212.m

Go to the documentation of this file.
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