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