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

BGP7D212.m

Go to the documentation of this file. 
  1. BGP7D212 ; IHS/CMI/LAB - measure 6 19 Sep 2014 8:12 AM ;
  1.  ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
  1.  ;
  1. LOINC(A,B) ;EP 
  1.  NEW %
  1.  S %=$P($G(^LAB(95.3,A,9999999)),U,2)
  1.  I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
  1.  S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
  1.  I $D(^ATXAX(B,21,"B",%)) Q 1
  1.  Q ""
  1. STRC ;EP - called from report execution
  1.  I 'BGPDMD1 S BGPSTOP=1 Q  ;only up diabetics
  1.  I BGPAGEB<21 S BGPSTOP=1 Q  ;ONLY 21+
  1.  NEW BGPCVDL
  1.  F X=1:1:7 S Y="BGPD"_X S @Y=""  ;7 denominators
  1.  S (BGPN1,BGPN2,BGPN3)=""  ;2 numerators
  1.  S BGPCVDL=$$CHDLDL(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)  ;CHD OR LDL^CHD^LDL
  1.  I BGPAGEB>20,BGPAGEB<40,'BGPCVDL S BGPSTOP=1 Q  ;21-39 and no cvd/ldl
  1.  I BGPAGEB>75,'BGPCVDL S BGPSTOP=1 Q  ;>75 and no cvd/ldl
  1.  ;DENOM 1
  1.  I BGPDMD2,BGPAGEB>39,BGPAGEB<76 S BGPD1=1  ;active diabetic ages 40-75
  1.  I BGPDMD2,BGPAGEB>20,BGPCVDL S BGPD1=1   ;or active diabetic 21+ w/CVD or LDL =>190
  1.  ;DENOM 2  21-39, active diabetic with CVD or LDL >=190
  1.  I BGPDMD2,BGPAGEB>20,BGPAGEB<40,BGPCVDL S BGPD2=1
  1.  ;DENOM 3 40-75, active diabetic with CVD or LDL =>190
  1.  I BGPDMD2,BGPAGEB>39,BGPAGEB<76,BGPCVDL S BGPD3=1
  1.  ;DENOM 4 76+ with cvd or ldl >=190
  1.  I BGPDMD2,BGPAGEB>75,BGPCVDL S BGPD4=1
  1.  ;DENOM 5 active diabetic 40-75
  1.  I BGPDMD2,BGPAGEB>39,BGPAGEB<76 S BGPD5=1
  1.  ;DENOM 7 UP DM 40-75 or 12+ with cvd/ldl
  1.  I BGPDMD1,BGPAGEB>39,BGPAGEB<76 S BGPD7=1
  1.  I BGPDMD1,BGPAGEB>20,BGPCVDL S BGPD7=1
  1.  I BGPD1 S BGPD6=1
  1.  ;now exclude people
  1.  S (BGPEXL1,BGPEXL2,BGPEXL3,BGPEXL4,BGPEXL5,BGPSTAT,BGPEXL6)=""
  1.  S BGPEXL1=$$STATALG^BGP7D213(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,BGPBDATE,BGPEDATE) I BGPEXL1 S (BGPN2,BGPN3)=1 G ND  ;excl 1
  1.  ;ALCOHOL HEP
  1.  S BGPEXL1=$$ALCHEP(DFN,BGPBDATE,BGPEDATE) I BGPEXL1 S BGPN2=1 G ND
  1.  ;NMI
  1.  S BGPEXL1=$$STATNMI(DFN,BGPBDATE,BGPEDATE) I BGPEXL1 S BGPN2=1 G ND
  1.  ;PREGNANCY
  1.  S BGPEXL2=$$PREG^BGP7D7(DFN,BGPBDATE,BGPEDATE,1,1,1,BGPBDATE,BGPEDATE) I BGPEXL2 S BGPN2=1 G ND   ;V17.1 CMI/LAB ADDED DATES FOR CURRENTLY PREGNANT
  1.  ;cirrhosis of liver
  1.  S BGPEXL6=$$CLIVER^BGP7D213(DFN,BGPPBD,BGPEDATE) I BGPEXL6 S BGPN2=1 G ND
  1.  ;breastfeeding
  1.  S BGPEXL2=$$BF^BGP7D21(DFN,BGPBDATE,BGPEDATE) I BGPEXL2 S BGPN2=1 G ND
  1.  ;PALLIATIVE
  1.  S BGPEXL3=$$LASTDX^BGP7UTL1(DFN,"BGP PALLIATIVE CARE DXS",BGPBDATE,BGPEDATE) I BGPEXL3 S BGPN2=1,BGPEXL3=1_U_$$DATE^BGP7UTL($P(BGPEXL3,U,3))_" Palliative Care" G ND  ;excl 3
  1.  ;ESRD
  1.  S BGPEXL4=$$ESRD^BGP7D211(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) I BGPEXL4 S BGPEXL4=1_U_$$DATE^BGP7UTL($P(BGPEXL4,U,3))_" ESRD" S BGPN2=1 G ND  ;excl 4 ESRD
  1.  ;EXCL 5
  1.  S BGPSTAT=$$STATIN^BGP7D214(DFN,BGPBDATE,BGPEDATE,0)
  1.  S BGPEXL5=$$LASTLDLV(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) I BGPEXL5,'$P(BGPCVDL,U,3),'BGPSTAT S BGPN2=1 G ND   ;excl 5
  1. ND ;
  1.  ;DENOM 6 active diabetic 21+
  1.  I BGPN2,BGPD1 S BGPD6=1
  1.  I BGPN2 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD7)="" ;EXCLUDE EXCLUSIONS FROM DENOMINATORS
  1.  I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7) S BGPSTOP=1 Q  ;not in at least UP denominator
  1.  ;numerator
  1.  I 'BGPN2 S BGPN1=BGPSTAT
  1. 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:"")
  1.  S BGPVALUE=$S(BGPDMD2:"UP,AD",1:"UP")_$S($P(BGPCVDL,U,2):" (CHD)",$P(BGPCVDL,U,3):" (LDL)",1:"")_"|||"
  1.  I BGPN1 S BGPVALUE=BGPVALUE_$P(BGPN1,U,2)
  1.  I BGPEXL1 S BGPVALUE=BGPVALUE_"Exclusion: "_$P(BGPEXL1,U,2)
  1.  I BGPEXL2 S BGPVALUE=BGPVALUE_"Exclusion: "_$P(BGPEXL2,U,2)_" Pregnant/Breastfeeding"
  1.  I BGPEXL3 S BGPVALUE=BGPVALUE_"Exclusion: "_$P(BGPEXL3,U,2)
  1.  I BGPEXL4 S BGPVALUE=BGPVALUE_"Exclusion: "_$P(BGPEXL4,U,2)
  1.  I BGPEXL6 S BGPVALUE=BGPVALUE_"Exclusion: "_$P(BGPEXL6,U,2)_" Cirrhosis"
  1.  I BGPEXL5,BGPN2 S BGPVALUE=BGPVALUE_"Exclusion: "_$P(BGPEXL5,U,2)
  1.  K BGPEXL1,BGPEXL2,BGPEXL3,BGPEXL4,BGPEXL5,BGPCVDL,BGPSTAT,BGPEXL6
  1.  Q
  1. CHDLDL(P,BDATE,EDATE) ;EP - chd or ldl =>190
  1.  NEW RESULT
  1.  S RESULT=""
  1.  I $$CHD(P,BDATE,EDATE,0) S RESULT="1^1"
  1.  K TMP($J,"A")
  1.  I $$LDL190(P,BDATE,EDATE) S $P(RESULT,U,3)=1,$P(RESULT,U,1)=1
  1.  K ^TMP($J,"A")
  1.  Q RESULT
  1. ALCHEP(P,BDATE,EDATE) ;EP
  1.  ;NOW CHECK ALCOHOL HEPATITIS
  1.  NEW BGPG,Y,X,E
  1.  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)
  1.  I $D(BGPG(1)) Q 1_U_$$DATE^BGP7UTL($P(BGPG(1),U,1))_" Alc Hep"
  1.  S X=$$PLTAXID^BGP7DU(P,"BGP ALCOHOL HEPATITIS DXS",BDATE,EDATE)
  1.  I X Q 1_U_"Prob List Alc Hep"
  1.  S X=$$IPLSNOID^BGP7DU(P,"PXRM BGP ACUTE ETOH HEPATITIS",BDATE,EDATE)
  1.  I X Q 1_U_"Prob List Alc Hep"
  1.  Q ""
  1. CHD(P,BDATE,EDATE,MIN) ;EP
  1.  NEW A,B,E,T,X,G,V,Y,%,G,F,BGPG,BGPCNT,T1,BGPALL,T2,T3
  1.  S X=$$CHDPL^BGP7D21A(P,EDATE)
  1.  I X Q 1
  1.  K BGPALL
  1.  S BGPCNT=0
  1.  K ^TMP($J,"A")
  1.  S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
  1.  I '$D(^TMP($J,"A",1)) Q ""
  1.  S T=$O(^ATXAX("B","BGP CHD DXS",0))
  1.  S T1=$O(^ATXAX("B","BGP AMI DXS PAMT",0))
  1.  S T2=$O(^ATXAX("B","BGP IVD DXS",0))
  1.  S T3=$O(^ATXAX("B","BGP TIA DXS",0))
  1.  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
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .Q:'$P(^AUPNVSIT(V,0),U,9)
  1.  .Q:$P(^AUPNVSIT(V,0),U,11)
  1.  .;Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
  1.  .S (D,Y)=0 F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MIN)  I $D(^AUPNVPOV(Y,0)) D
  1.  ..S %=$P(^AUPNVPOV(Y,0),U)
  1.  ..I $$ICD^BGP7UTL2(%,T,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..I $$ICD^BGP7UTL2(%,T1,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..I $$ICD^BGP7UTL2(%,T2,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..I $$ICD^BGP7UTL2(%,T3,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  I BGPCNT>MIN Q 1
  1. CHDP ;NOW CHECK FOR MINPROC
  1.  ;S BGPCNT=0
  1.  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
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .Q:'$P(^AUPNVSIT(V,0),U,9)
  1.  .Q:$P(^AUPNVSIT(V,0),U,11)
  1.  .;Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
  1.  .S T1=$O(^ATXAX("B","BGP PCI DXS",0))
  1.  .S T2=$O(^ATXAX("B","BGP CABG DXS",0))
  1.  .S (D,Y)=0 F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MIN)  I $D(^AUPNVPOV(Y,0)) D
  1.  ..S %=$P(^AUPNVPOV(Y,0),U)
  1.  ..I $$ICD^BGP7UTL2(%,T1,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..I $$ICD^BGP7UTL2(%,T2,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  .I BGPCNT>MIN Q
  1.  .;check for procedure in BGP CABG PROCS
  1.  .S E=$O(^ATXAX("B","BGP CABG PROCS",0))
  1.  .S F=$O(^ATXAX("B","BGP PCI CM PROCS",0))
  1.  .S Y=0 F  S Y=$O(^AUPNVPRC("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MIN)  D
  1.  ..Q:'$D(^AUPNVPRC(Y,0))
  1.  ..I $$ICD^BGP7UTL2($P(^AUPNVPRC(Y,0),U,1),E,0) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..I $$ICD^BGP7UTL2($P(^AUPNVPRC(Y,0),U,1),F,0) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1
  1.  .I BGPCNT>MIN Q
  1.  .;now check cpts
  1.  .S E=$O(^ATXAX("B","BGP CABG CPTS",0))
  1.  .S F=$O(^ATXAX("B","BGP PCI CPTS",0))
  1.  .S G=$O(^ATXAX("B","BGP REVASCULARIZATION CPTS",0))
  1.  .S Y=0 F  S Y=$O(^AUPNVCPT("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MIN)  D
  1.  ..Q:'$D(^AUPNVCPT(Y,0))
  1.  ..I $$ICD^BGP7UTL2($P(^AUPNVCPT(Y,0),U,1),E,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..I $$ICD^BGP7UTL2($P(^AUPNVCPT(Y,0),U,1),F,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..I $$ICD^BGP7UTL2($P(^AUPNVCPT(Y,0),U,1),G,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  .I BGPCNT>MIN Q
  1.  .;now check TRANS
  1.  .S E=$O(^ATXAX("B","BGP CABG CPTS",0))
  1.  .S F=$O(^ATXAX("B","BGP PCI CPTS",0))
  1.  .S G=$O(^ATXAX("B","BGP REVASCULARIZATION CPTS",0))
  1.  .S Y=0 F  S Y=$O(^AUPNVTC("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MIN)  D
  1.  ..Q:'$D(^AUPNVTC(Y,0))
  1.  ..S I=$P(^AUPNVTC(Y,0),U,7)
  1.  ..Q:I=""
  1.  ..I $$ICD^BGP7UTL2(I,E,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..I $$ICD^BGP7UTL2(I,F,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..I $$ICD^BGP7UTL2(I,G,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  .Q
  1.  I BGPCNT>MIN Q 1
  1.  Q ""
  1. LDL190(P,BDATE,EDATE) ;EP ldl >=190?  EVER
  1.  NEW T,A,E,LT,G,X,J,R
  1.  K ^TMP($J,"A")
  1.  S A="^TMP($J,""A"",",%=P_"^ALL LAB;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
  1.  I '$D(^TMP($J,"A",1)) Q ""
  1.  ;now go through all lab tests and see if any are the loinc codes in the taxonomy
  1.  S T=$O(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))
  1.  S LT=$O(^ATXAX("B","BGP LDL LOINC CODES",0))
  1.  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
  1.  .S %=+^AUPNVLAB(I,0),R=$P(^AUPNVLAB(I,0),U,4)
  1.  .I $D(^ATXLAB(T,21,"B",%)),+R>189.999999 S G=1 Q
  1.  .S J=$P($G(^AUPNVLAB(I,11)),U,13)
  1.  .Q:J=""
  1.  .I $$LOINC^BGP7D21(J,LT),+R>189.99999 S G=1
  1.  K ^TMP($J,"A")
  1.  Q G
  1. LASTLDLV(P,BDATE,EDATE) ;EP
  1.  NEW BGPG,BGPT,BGPC,BGPLT,T,B,E,D,L,X,R,G,C,%
  1.  K BGPG,BGPT,BGPC
  1.  S BGPC=0
  1.  ;now get all loinc/taxonomy tests
  1.  S T=$O(^ATXAX("B","BGP LDL LOINC CODES",0))
  1.  S BGPLT=$O(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))
  1.  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
  1.  .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X  D
  1.  ...Q:'$D(^AUPNVLAB(X,0))
  1.  ...Q:$P(^AUPNVLAB(X,0),U,4)=""  ;NO RESULT
  1.  ...Q:'+$P(^AUPNVLAB(X,0),U,4)  ;NON-NUMERIC RESULT
  1.  ...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
  1.  ...Q:'T
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC(J,T)
  1.  ...S R=$P(^AUPNVLAB(X,0),U,4)
  1.  ...I 'R S R=""
  1.  ...S BGPC=BGPC+1,BGPT(BGPC)=$P(^AUPNVLAB(X,0),U,4)_U_(9999999-D)
  1.  ...Q
  1.  I 'BGPC Q ""
  1.  I +BGPT(BGPC)<70 Q 1_U_$$DATE^BGP7UTL($P(BGPT(BGPC),U,2))_" LDL < 70"
  1.  Q ""
  1. STATNMI(P,NMIB,NMIE) ;EP
  1.  ;nmi
  1.  NEW BGPG,X,T,D,Y,N
  1.  S BGPG=""
  1.  S T=$O(^ATXAX("B","BGP PQA STATIN MEDS",0))
  1.  S X=0 F  S X=$O(^AUPNPREF("AA",P,50,X)) Q:X'=+X  D
  1.  .Q:'$D(^ATXAX(T,21,"B",X))  ;not an STATI
  1.  .S D=0 F  S D=$O(^AUPNPREF("AA",P,50,X,D)) Q:D'=+D  D
  1.  ..S Y=9999999-D I Y<NMIB Q
  1.  ..I Y>NMIE Q
  1.  ..S N=0 F  S N=$O(^AUPNPREF("AA",P,50,X,D,N)) Q:N'=+N  D
  1.  ...Q:$P($G(^AUPNPREF(N,0)),U,7)'="N"
  1.  ...S BGPG=1_U_$$DATE^BGP7UTL($P(^AUPNPREF(N,0),U,3))_" Contra NMI "_$$VAL^XBDIQ1(9000022,N,.04)  ;_"   "_"  "_$$VAL^XBDIQ1(9000022,X,1101)
  1.  ..Q
  1.  .Q
  1.  I BGPG Q BGPG
  1.  Q ""