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

BGP3EL2.m

Go to the documentation of this file. 
  1. BGP3EL2 ; IHS/CMI/LAB - measure 1,2,3,4 17 Jan 2010 6:49 AM ;
  1.  ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
  1.  ;
  1. I1 ;EP - measure 1 general processing
  1.  S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPN1,BGPN1)=0
  1.  S BGPN1=0,BGPVALUE="",BGPD1=0
  1.  I BGPAGEB<55 S BGPSTOP=1 Q
  1.  S BGPD1=1
  1.  I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
  1.  I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
  1.  I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
  1.  I BGPAGEB>84 S BGPD5=1
  1.  K BGPG
  1.  S Y="BGPG("
  1.  S X=DFN_"^LAST DX [SURVEILLANCE DIABETES;DURING "_$$DOB^AUPNPAT(DFN,"E")_"-"_$$FMTE^XLFDT(BGPEDATE) S E=$$START1^APCLDF(X,Y)
  1.  I BGPDM1 S BGPN1=1
  1.  I '$D(BGPG(1)) S BGPVALUE="" Q
  1.  S BGPVALUE="UP|||"_$$DATE^BGP3UTL($P(BGPG(1),U))_" "_$P(BGPG(1),U,2)
  1.  Q
  1.  ;
  1. I2 ;EP
  1.  K BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPLHGB,BGPN5,BGPN6,BGPN7,BGPN8
  1.  S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
  1.  I BGPAGEB<55 S BGPSTOP=1 Q
  1.  I 'BGPDMD2 S BGPSTOP=1 Q  ;don't process this measure, pt not diabetic
  1.  S BGPD1=1
  1.  I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
  1.  I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
  1.  I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
  1.  I BGPAGEB>84 S BGPD5=1
  1.  D DMGC^BGP3D2
  1.  S BGPVALUE="AD|||"_$P(BGPVALUE,"|||",2)
  1.  K BGPXPHV
  1.  Q
  1.  ;
  1. I3 ;EP
  1.  K BGPN1,BGPN2,BGPN3,BGPVALUE,BGPLBP
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
  1.  S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
  1.  I BGPAGEB<55 S BGPSTOP=1 Q
  1.  I 'BGPDMD2 S BGPSTOP=1 Q  ;don't process this measure, pt not diabetic
  1.  S BGPD1=1
  1.  I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
  1.  I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
  1.  I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
  1.  I BGPAGEB>84 S BGPD5=1
  1.  D DMBP^BGP3D2
  1.  S BGPVALUE="AD|||"_$P(BGPVALUE,"|||",2)
  1.  K BGPXPHV
  1.  Q
  1.  ;
  1. I4 ;EP
  1.  K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPVALUE,BGPLD,BGPLDL,BGPTRI,BGPHDL
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
  1.  S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
  1.  I BGPAGEB<55 S BGPSTOP=1 Q
  1.  I 'BGPDMD2 S BGPSTOP=1 Q  ;don't process this measure, pt not diabetic
  1.  S BGPD1=1
  1.  I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
  1.  I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
  1.  I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
  1.  I BGPAGEB>84 S BGPD5=1
  1.  D DMLDL^BGP3D2
  1.  S BGPVALUE="AD|||"_$P(BGPVALUE,"|||",2)
  1.  K BGPXPHV
  1.  Q
  1.  ;
  1. I5 ;EP
  1.  K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPVALUE,BGPLD,BGPLDL,BGPTRI,BGPHDL
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
  1.  S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
  1.  I BGPAGEB<55 S BGPSTOP=1 Q
  1.  I 'BGPDMD2 S BGPSTOP=1 Q  ;don't process this measure, pt not diabetic
  1.  S BGPD1=1
  1.  I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
  1.  I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
  1.  I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
  1.  I BGPAGEB>84 S BGPD5=1
  1.  D DMNA^BGP3D21
  1.  S BGPVALUE="AD|||"_$P(BGPVALUE,"|||",2)
  1.  K BGPXPHV
  1.  Q
  1.  ;
  1.  ;
  1. I6 ;EP
  1.  K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPVALUE,BGPLD,BGPLDL,BGPTRI,BGPHDL
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10)=0
  1.  S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
  1.  I BGPAGEB<55 S BGPSTOP=1 Q
  1.  NEW BGPEYE,BGPBLIND
  1.  S BGPBLIND=""
  1.  I 'BGPDM1 S BGPSTOP=1 Q
  1.  S X=$$LASTDX^BGP3UTL1(DFN,"BGP BILATERAL BLINDNESS DXS",$$DOB^AUPNPAT(DFN),BGPEDATE)
  1.  I 'X S X=$$BLINDPL^BGP3D21A(DFN,BGPEDATE)
  1.  I X S BGPSTOP=1 Q
  1.  I BGPDMD2 S BGPD1=1
  1.  I 'BGPD1 S BGPSTOP=1 Q
  1.  I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
  1.  I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
  1.  I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
  1.  I BGPAGEB>84 S BGPD5=1
  1.  D DMEYE^BGP3D21
  1.  S BGPVALUE="AD|||"_$P(BGPVALUE,"|||",2)
  1.  K ^TMP($J,"A")
  1.  K BGPUP,BGPGFR,BGPX,BGPY,BGPC,BGPG
  1.  K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F
  1.  Q
  1. I7 ;EP
  1.  K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPVALUE,BGPLD,BGPLDL,BGPTRI,BGPHDL
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
  1.  S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
  1.  I BGPAGEB<55 S BGPSTOP=1 Q
  1.  I 'BGPDMD2 S BGPSTOP=1 Q  ;don't process this measure, pt not diabetic
  1.  S BGPD1=1
  1.  I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
  1.  I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
  1.  I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
  1.  I BGPAGEB>84 S BGPD5=1
  1.  S BGPVALUE=$$DENTSRV^BGP3D21(DFN,BGPBDATE,BGPEDATE)
  1.  S BGPN1=0 I $P(BGPVALUE,U)=1 S BGPN1=1
  1.  S BGPN2=0 I $P(BGPVALUE,U)=2 S BGPN2=1
  1.  S BGPVALUE="AD|||"_$$DATE^BGP3UTL($P(BGPVALUE,U,2))_" "_$P(BGPVALUE,U,3)
  1.  K ^TMP($J,"A")
  1.  K BGPUP,BGPGFR,BGPX,BGPY,BGPC,BGPG
  1.  K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F
  1.  Q
  1. I8 ;EP
  1.  K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPVALUE,BGPLD,BGPLDL,BGPTRI,BGPHDL
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
  1.  S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
  1.  I BGPAGEB<55 S BGPSTOP=1 Q
  1.  S BGPD1=1
  1.  I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
  1.  I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
  1.  I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
  1.  I BGPAGEB>84 S BGPD5=1
  1.  S BGPVALUE=$$DENTSRV^BGP3D21(DFN,BGPBDATE,BGPEDATE)
  1.  S BGPN1=0 I $P(BGPVALUE,U)=1 S BGPN1=1
  1.  S BGPN2=0 I $P(BGPVALUE,U)=2 S BGPN2=1
  1.  S BGPVALUE="UP|||"_$$DATE^BGP3UTL($P(BGPVALUE,U,2))_" "_$P(BGPVALUE,U,3)
  1.  K ^TMP($J,"A")
  1.  K BGPUP,BGPGFR,BGPX,BGPY,BGPC,BGPG
  1.  K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F
  1.  Q
  1.  ;
  1. MEANBP(P,BDATE,EDATE) ;EP
  1.  S X=$$BPS(P,BDATE,EDATE,"I")
  1.  S S=$$SYSMEAN(X) I S="" Q ""
  1.  S DS=$$DIAMEAN(X) I DS="" Q ""
  1.  I S<130&(DS<80) Q S_"/"_DS_" CON"_U_2
  1.  Q S_"/"_DS_" UNC"_U_3
  1.  ;
  1. SYSMEAN(X) ;EP
  1.  I X="" Q ""
  1.  S C=0 F Y=1:1:3 I $P(X,";",Y)]"" S C=C+1
  1.  I C<2 Q ""
  1.  S T=0 F Y=1:1:3 S T=$P($P(X,";",Y),"/")+T
  1.  Q $$STRIP^XLFSTR($J((T/C),5,1)," ")
  1.  ;
  1. DIAMEAN(X) ;EP
  1.  I X="" Q ""
  1.  S C=0 F Y=1:1:3 I $P(X,";",Y)]"" S C=C+1
  1.  I C<2 Q ""
  1.  S T=0 F Y=1:1:3 S T=$P($P(X,";",Y),"/",2)+T
  1.  Q $$STRIP^XLFSTR($J((T/C),5,1)," ")
  1.  ;
  1. BPS(P,BDATE,EDATE,F) ;EP ;
  1.  I $G(F)="" S F="E"
  1.  S BGPGLL=0,BGPGV=""
  1.  K BGPG
  1.  K ^TMP($J,"BPV")
  1.  S A="^TMP($J,""BPV"",",B=P_"^LAST 365 VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
  1.  I '$D(^TMP($J,"BPV",1)) Q ""
  1.  ;S X=P_"^LAST 50 MEAS BP;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")
  1.  ;S BGPGL=0 F  S BGPGL=$O(BGPG(BGPGL)) Q:BGPGL'=+BGPGL!(BGPGLL=3)  S BGPGBP=$P($G(BGPG(BGPGL)),U,2) D
  1.  S Y=0 F  S Y=$O(^TMP($J,"BPV",Y)) Q:Y'=+Y!(BGPGLL=3)  D
  1.  .S V=$P(^TMP($J,"BPV",Y),U,5)
  1.  .Q:$$CLINIC^APCLV(V,"C")=30  ;NO ER CLINIC VISITS COUNTED
  1.  .Q:'$D(^AUPNVMSR("AD",V))  ;no measurements to look at
  1.  .;NOW GET ALL BPS ON THIS VISIT
  1.  .S BGPBP=""
  1.  .S X=0 F  S X=$O(^AUPNVMSR("AD",V,X)) Q:X'=+X  D
  1.  ..Q:'$D(^AUPNVMSR(X,0))  ;BAD AD XREF
  1.  ..S T=$P($G(^AUPNVMSR(X,0)),U)
  1.  ..Q:T=""  ;BAD AD XREF
  1.  ..Q:$P($G(^AUTTMSR(T,0)),U)'="BP"  ;not a BP measurement type
  1.  ..S Z=$P(^AUPNVMSR(X,0),U,4)  ;blood pressure value
  1.  ..I BGPBP="" S BGPBP=Z Q
  1.  ..I $P(Z,"/")'>$P(BGPBP,"/") S BGPBP=Z
  1.  .Q:BGPBP=""
  1.  .S BGPGLL=BGPGLL+1
  1.  .I F="E" S $P(BGPGV,";",BGPGLL)=BGPBP_"  "_$$FMTE^XLFDT($P(^TMP($J,"BPV",V),U))
  1.  .I F="I" S $P(BGPGV,";",BGPGLL)=$P(BGPBP," ")
  1.  K ^TMP($J,"BPV")
  1.  Q BGPGV
  1. LIPID(P,BDATE,EDATE) ;EP
  1.  K BGPC
  1.  S BGPC=0
  1.  S %="",E=+$$CODEN^ICPTCOD(80061),%=$$CPTI^BGP3DU(P,BDATE,EDATE,E)
  1.  I %]"" Q 1_U_$P(%,U,2)_U_"80061"
  1.  S %="",E=+$$CODEN^ICPTCOD(80061),%=$$TRANI^BGP3DU(P,BDATE,EDATE,E)
  1.  I %]"" Q 1_U_$P(%,U,2)_U_"80061 TRAN"
  1.  ;now get all loinc/taxonomy tests
  1.  S T=$O(^ATXAX("B","BGP LIPID PROFILE LOINC CODES",0))
  1.  S BGPLT=$O(^ATXLAB("B","DM AUDIT LIPID PROFILE 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)!($P(BGPC,U))  D
  1.  .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!($P(BGPC,U))  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!($P(BGPC,U))  D
  1.  ...Q:'$D(^AUPNVLAB(X,0))
  1.  ...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_(9999999-D)_U_"LAB" Q
  1.  ...Q:'T
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC(J,T)
  1.  ...S BGPC=1_U_(9999999-D)_U_"LOINC"
  1.  ...Q
  1.  Q BGPC
  1.  ;
  1. TRIG(P,BDATE,EDATE) ;EP
  1.  K BGPC
  1.  S BGPC=0
  1.  S %="",E=+$$CODEN^ICPTCOD(84478),%=$$CPTI^BGP3DU(P,BDATE,EDATE,E)
  1.  I %]"" Q 1_U_$P(%,U,2)
  1.  S %="",E=+$$CODEN^ICPTCOD(84478),%=$$TRANI^BGP3DU(P,BDATE,EDATE,E)
  1.  I %]"" Q 1_U_$P(%,U,2)
  1.  ;now get all loinc/taxonomy tests
  1.  S T=$O(^ATXAX("B","BGP TRIGLYCERIDE LOINC CODES",0))
  1.  S BGPLT=$O(^ATXLAB("B","DM AUDIT TRIGLYCERIDE 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!(BGPC)  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC)  D
  1.  ...Q:'$D(^AUPNVLAB(X,0))
  1.  ...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_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.  ...S BGPC=1_U_(9999999-D)
  1.  ...Q
  1.  Q BGPC
  1. HDL(P,BDATE,EDATE) ;EP
  1.  K BGPC
  1.  S BGPC=0
  1.  S %="",E=+$$CODEN^ICPTCOD(83718),%=$$CPTI^BGP3DU(P,BDATE,EDATE,E)
  1.  I %]"" Q 1_U_$P(%,U,2)
  1.  S %="",E=+$$CODEN^ICPTCOD(83718),%=$$TRANI^BGP3DU(P,BDATE,EDATE,E)
  1.  I %]"" Q 1_U_$P(%,U,2)
  1.  ;now get all loinc/taxonomy tests
  1.  S T=$O(^ATXAX("B","BGP HDL LOINC CODES",0))
  1.  S BGPLT=$O(^ATXLAB("B","DM AUDIT HDL 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!(BGPC)  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC)  D
  1.  ...Q:'$D(^AUPNVLAB(X,0))
  1.  ...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_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.  ...S BGPC=1_U_(9999999-D)
  1.  ...Q
  1.  Q BGPC
  1.  ;
  1. LDL(P,BDATE,EDATE) ;EP
  1.  K BGPG,BGPT,BGPC
  1.  S BGPC=0
  1.  S %="",E=+$$CODEN^ICPTCOD(83721),%=$$CPTI^BGP3DU(P,BDATE,EDATE,E)
  1.  I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)=""
  1.  S %="",E=+$$CODEN^ICPTCOD(83721),%=$$TRANI^BGP3DU(P,BDATE,EDATE,E)
  1.  I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)=""
  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)  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.  ...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=BGPC+1,BGPT(D,BGPC)=$P(^AUPNVLAB(X,0),U,4) 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.  ...S BGPC=BGPC+1,BGPT(D,BGPC)=R
  1.  ...Q
  1.  ; now got though and set return value of done 1 or 0^VALUE^date
  1.  I '$D(BGPT) Q ""  ;no tests
  1.  S D=0,G="" F  S D=$O(BGPT(D)) Q:D'=+D!(G]"")  D
  1.  .S C=0 F  S C=$O(BGPT(D,C)) Q:C'=+C!(G]"")  D
  1.  ..S X=BGPT(D,C)
  1.  ..I $E(X)'=+$E(X) Q
  1.  ..S G=(9999999-D)_U_X
  1.  ..Q
  1.  I G="" Q 1_"^"_(9999999-$O(BGPT(0)))
  1.  Q 1_U_G
  1. LOINC(A,B) ;
  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 ""