BGP1D2 ; IHS/CMI/LAB - measure 1,2,3,4 ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;
I1 ;EP - measure 1 general processing
S BGPN1=0
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^BGP1UTL($P(BGPG(1),U))_" POV "_$P(BGPG(1),U,2)
Q
;
I3 ;EP
K BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPLHGB,BGPN5,BGPN6,BGPN7,BGPN8
I 'BGPDM1 S BGPSTOP=1 Q ;don't process this measure, pt not diabetic
DMGC ;EP - called from elder care
S BGPLHGB=$$HGBA1C(DFN,BGP365,BGPEDATE)
S BGPN1=$P(BGPLHGB,U)
S BGPN2=$S($P(BGPLHGB,U,2)=2:1,1:0)
S BGPN3=$S($P(BGPLHGB,U,2)=3:1,1:0)
S BGPN4=$S($P(BGPLHGB,U,2)=4:1,1:0)
S BGPN5=$S($P(BGPLHGB,U,2)=5:1,1:0)
S BGPN6=$S($P(BGPLHGB,U,2)=6:1,1:0)
S BGPN7=$S($P(BGPLHGB,U,2)=7:1,1:0)
S BGPN8=0 I BGPN2!(BGPN3) S BGPN8=1
S BGPXPBV=$P(BGPLHGB,U,4)
S BGPVALUE=$S(BGPDMD1:"UP",1:"")_$S(BGPDMD2:",AD",1:"")_$S(BGPDMD3:",AAD",1:"")_"||| "_$$DATE^BGP1UTL($P(BGPLHGB,U,3))_$S($P(BGPLHGB,U,4)]"":" A1c: "_$P(BGPLHGB,U,4),1:"")
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,J,K,G,I,L,T,BGPLHGB
Q
I4 ;EP
K BGPN1,BGPN2,BGPN3,BGPVALUE,BGPLBP,BGPN4,BGPN5,BGPN6
;BGPN4 AND BGPN5, BGPN6 ARE GPRA DEV 2011
I 'BGPDM1 S BGPSTOP=1 Q ;don't process this measure, pt not diabetic
DMBP ;EP - called from elder care
S BGPVALUE=$$MEANBP(DFN,BGP365,BGPEDATE)
I BGPVALUE="" S BGPBP=$$BPCPT^BGP1D22(DFN,BGPBDATE,BGPEDATE) I BGPBP]"" S BGPN1=1 D G BPX
.S BGPN2=$P(BGPBP,U),BGPN3=$S('$P(BGPBP,U):1,1:0),BGPVALUE=$P(BGPBP,U,2)_" "_$S(BGPN2:"CON",1:"UNC")_"^"_$S(BGPN2:2,BGPN3:3,1:"")
S BGPN1=$S($P(BGPVALUE,U,2):1,1:0)
S BGPN2=$S($P(BGPVALUE,U,2)=2:1,1:0)
S BGPN3=$S($P(BGPVALUE,U,2)=3:1,1:0)
BPX ;
S BGPVALUD=$$MEANBP(DFN,BGP365,BGPEDATE,1)
I BGPVALUD="" S BGPBP=$$BPCPT^BGP1D22(DFN,BGPBDATE,BGPEDATE,1) I BGPBP]"" S BGPN4=1 D G BPX1
.S BGPN5=$P(BGPBP,U),BGPN6=$S('$P(BGPBP,U):1,1:0),BGPVALUD=$P(BGPBP,U,2)_" "_$S(BGPN5:"CON",1:"UNC")_"^"_$S(BGPN5:2,BGPN6:3,1:"")
S BGPN4=$S($P(BGPVALUD,U,2):1,1:0)
S BGPN5=$S($P(BGPVALUD,U,2)=2:1,1:0)
S BGPN6=$S($P(BGPVALUD,U,2)=3:1,1:0)
BPX1 ;
S BGPXPBV=$P(BGPVALUE,U,1),BGPXPBV=$P(BGPXPBV," ",1)
I $P(BGPVALUE,U,2)="" S BGPVALUE=""
I $P(BGPVALUD,U,2)="" S BGPVALUD=""
S BGPVALUE=$S(BGPDMD1:"UP"_$S(BGPDMD2:",AD",1:"")_$S(BGPDMD3:",AAD",1:""),1:"")_"|||"_$P(BGPVALUE,U)
S BGPVALUD="AAD"_"|||"_$P(BGPVALUD,U)
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F
Q
;
I5 ;EP
K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPVALUE,BGPLD,BGPLDL,BGPTRI,BGPHDL
;S (BGPTRI,BGPLDL,BGPHDL)=""
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
I 'BGPDM1 S BGPSTOP=1 Q ;don't process this measure, pt not diabetic
;S BGPLP=$$LIPID(DFN,BGP365,BGPEDATE) S BGPN1=$P(BGPLP,U)
DMLDL ;EP - called from elder care
S BGPLDL=$$LDL(DFN,BGP365,BGPEDATE)
;I $P(BGPN1,U)'=1 D
;.S BGPTRI=$$TRIG(DFN,BGP365,BGPEDATE)
;.S BGPHDL=$$HDL(DFN,BGP365,BGPEDATE)
;.I BGPTRI,BGPHDL,+BGPLDL S BGPN1=1
S BGPN2=$P(BGPLDL,U)
D CHKLDL
S BGPXPBV=$P(BGPLDL,U,3)
S BGPVALUE=$S(BGPDMD1:"UP",1:"")_$S(BGPDMD2:",AD",1:"")_$S(BGPDMD3:",AAD",1:"")_"|||"
;I $P(BGPLP,U) S BGPVALUE=BGPVALUE_$S($P(BGPLP,U):"LP: "_$$DATE^BGP1UTL($P(BGPLP,U,2))_" "_$P(BGPLP,U,3),1:"")
;I '$P(BGPLP,U),BGPTRI,BGPHDL,BGPLDL S BGPVALUE=BGPVALUE_"TRI:"_$$DATE^BGP1UTL($P(BGPTRI,U,2))_" HDL:"_$$DATE^BGP1UTL($P(BGPHDL,U,2))_" LDL:"_$$DATE^BGP1UTL($P(BGPLDL,U,2))
I $P(BGPVALUE,"|||",2)]"" S BGPVALUE=BGPVALUE_" ; "
I BGPLDL]"" S BGPVALUE=BGPVALUE_"LDL DONE: "_$$DATE^BGP1UTL($P(BGPLDL,U,2))_" "_$P(BGPLDL,U,3)
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,BGPLDL,BGPHDL,BGPTRI,BGPLP
Q
;
CHKLDL ;EP
NEW V
I $P(BGPLDL,U,3)]"",$P(BGPLDL,U,3)["3048F" S BGPN3=1,BGPN4=1,$P(BGPLDL,U,3)="CPT 3048F LDL<100" Q
I $P(BGPLDL,U,3)]"",$P(BGPLDL,U,3)["3049F" S BGPN3=1,$P(BGPLDL,U,3)="CPT 3049F LDL <130" Q
I $P(BGPLDL,U,3)]"",$P(BGPLDL,U,3)["CPT" Q
S V=$P(BGPLDL,U,3),V=+V
I 'V Q
I $P(BGPLDL,U,3)]"",$P(BGPLDL,U,3)'>100 S BGPN4=1
I $P(BGPLDL,U,3)]"",$P(BGPLDL,U,3)>100,$P(BGPLDL,U,3)<130 S BGPN5=1
I $P(BGPLDL,U,3)]"",$P(BGPLDL,U,3)<130 S BGPN3=1
Q
HGBA1C(P,BDATE,EDATE) ;EP
K BGPG,BGPT,BGPC
S BGPC=0
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP HGBA1C LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","DM AUDIT HGB A1C 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 BGPC=BGPC+1,BGPT(D,BGPC)=$P(^AUPNVLAB(X,0),U,4)
...Q
S %="",E=+$$CODEN^ICPTCOD("3044F"),%=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 3044F"
S %="",E=+$$CODEN^ICPTCOD("3044F"),%=$$TRANI^BGP1DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT/TRAN 3044F"
; now got though and set return value of done 1 or 0^numerator 2-7^date^value
I '$D(BGPT) D HCPT 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 $$UP^XLFSTR(X)="COMMENT" Q
..I X="" Q
..I X["3044F" S G=D_U_X Q
..I $E(X)[">" S G=D_U_X Q
..I $E(X)["<" S G=D_U_X Q
..I $E(X)'=+$E(X) Q
..S G=D_U_X
I G="" Q 1_"^"_7_"^"_(9999999-$O(BGPT(0)))
I $P(G,U,2)["3044F" Q 1_"^"_6_"^"_(9999999-$P(G,U))_"^"_$P(G,U,2)
I $E($P(G,U,2))=">" Q 1_"^"_2_"^"_(9999999-$P(G,U))_"^"_$P(G,U,2)
I $E($P(G,U,2))="<" Q 1_"^"_6_"^"_(9999999-$P(G,U))_"^"_$P(G,U,2)
I +($P(G,U,2))'<12 Q 1_"^"_2_"^"_(9999999-$P(G,U))_"^"_$P(G,U,2)
I +($P(G,U,2))>9.5 Q 1_"^"_3_"^"_(9999999-$P(G,U))_"^"_$P(G,U,2)
I +($P(G,U,2))'<8 Q 1_"^"_4_"^"_(9999999-$P(G,U))_"^"_$P(G,U,2)
I +($P(G,U,2))'<7 Q 1_"^"_5_"^"_(9999999-$P(G,U))_"^"_$P(G,U,2)
I +($P(G,U,2))=0 Q 1_"^"_7_"^"_(9999999-$P(G,U))_"^"_$P(G,U,2)
Q 1_"^"_6_"^"_(9999999-$P(G,U))_"^"_$P(G,U,2)
;
HCPT ;
S %=""
S %="",E=+$$CODEN^ICPTCOD(83036),%=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 83036"
S %="",E=+$$CODEN^ICPTCOD(83036),%=$$TRANI^BGP1DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT/TRAN 83036"
S %="",E=+$$CODEN^ICPTCOD(83037),%=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 83037"
S %="",E=+$$CODEN^ICPTCOD(83037),%=$$TRANI^BGP1DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT/TRAN 83037"
S %="",E=+$$CODEN^ICPTCOD("3045F"),%=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 3045F"
S %="",E=+$$CODEN^ICPTCOD("3045F"),%=$$TRANI^BGP1DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT/TRAN 3045F"
S %="",E=+$$CODEN^ICPTCOD("3046F"),%=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 3046F"
S %="",E=+$$CODEN^ICPTCOD("3046F"),%=$$TRANI^BGP1DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT/TRAN 3046F"
S %="",E=+$$CODEN^ICPTCOD("3047F"),%=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 3047F"
S %="",E=+$$CODEN^ICPTCOD("3047F"),%=$$TRANI^BGP1DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT/TRAN 3047F"
I '$D(BGPT) S %="" Q
S %="1^7^"_(9999999-$O(BGPT(0)))
Q
MEANBP(P,BDATE,EDATE,GDEV) ;EP
NEW X,S,DS
S GDEV=$G(GDEV)
S X=$$BPS(P,BDATE,EDATE,"I",GDEV)
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
NEW Y,C,T
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)," ")
Q T\C
;
DIAMEAN(X) ;EP
NEW C,Y,T
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)," ")
Q T\C
;
GDEV(V) ;EP
I $P(^AUPNVSIT(V,0),U,7)="H" Q 1
I $P(^AUPNVSIT(V,0),U,7)="I" Q 1
I $P(^AUPNVSIT(V,0),U,7)="S" Q 1
I $P(^AUPNVSIT(V,0),U,7)="O" Q 1
NEW C
S C=$$CLINIC^APCLV(V,"C")
I C=30 Q 1
I C=23 Q 1
I C=44 Q 1
I C="C1" Q 1
I C="D4" Q 1
Q 0
BPS(P,BDATE,EDATE,F,GDEV) ;EP ;
I $G(F)="" S F="E"
NEW BGPGLL,BGPGV,BGPG,A,B,E,Y,V,BGPBP,X,Z
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 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
.I $G(GDEV) Q:$$GDEV(V)
.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
..Q:$P($G(^AUPNVMSR(X,2)),U,1) ;entered in error so skip it
..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^BGP1DU(P,BDATE,EDATE,E)
I %]"" Q 1_U_$P(%,U,2)_U_"80061"
S %="",E=+$$CODEN^ICPTCOD(80061),%=$$TRANI^BGP1DU(P,BDATE,EDATE,E)
I %]"" Q 1_U_$P(%,U,2)_U_"80061"
;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^BGP1DU(P,BDATE,EDATE,E)
I %]"" Q 1_U_$P(%,U,2)
S %="",E=+$$CODEN^ICPTCOD(84478),%=$$TRANI^BGP1DU(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^BGP1DU(P,BDATE,EDATE,E)
I %]"" Q 1_U_$P(%,U,2)
S %="",E=+$$CODEN^ICPTCOD(83718),%=$$TRANI^BGP1DU(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,NORES) ;EP
NEW BGPG,BGPT,BGPC,BGPLT,T,B,E,D,L,X,R,G,C,%
K BGPG,BGPT,BGPC
S BGPC=0
S NORES=$G(NORES)
;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)
...I 'R S R=""
...S BGPC=BGPC+1,BGPT(D,BGPC)=R
...Q
; now got though and set return value of done 1 or 0^VALUE^date
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 X="" Q
..S G=(9999999-D)_U_X
..Q
I G="" D ;now get one with no result
.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 X="" Q
...S G=(9999999-D)_U_X
..Q
;
I 'NORES,G]"" Q 1_U_G ;IF WANT A RESULT AND THERE IS ONE QUIT
S %=$$CPT^BGP1DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP LDL CPTS",0)),5)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,1),BGPC)="CPT "_$P(%,U,2)
S %=$$TRAN^BGP1DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP LDL CPTS",0)),5)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,1),BGPC)="CPT "_$P(%,U,2)
I '$O(BGPT(0)) Q ""
S %=$O(BGPT(0)) S C=$O(BGPT(%,0)) Q 1_"^"_(9999999-%)_"^"_BGPT(%,C)
Q ""
;
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 ""
BPCPT(P,BDATE,EDATE) ;EP
NEW G
S G=$$CPTI^BGP1DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("3077F"),"",30)
I G Q $$DATE^BGP1UTL($P(G,U,2))_" CPT 3077F SYSTOLIC BP >=140 UNC^3"
S G=$$CPTI^BGP1DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("3080F"),"",30)
I G Q $$DATE^BGP1UTL($P(G,U,2))_" CPT 3080F DIASTOLIC BP >=90 UNC^3"
Q ""
BGP1D2 ; IHS/CMI/LAB - measure 1,2,3,4 ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+2 ;
I1 ;EP - measure 1 general processing
+1 SET BGPN1=0
+2 KILL BGPG
+3 SET Y="BGPG("
+4 SET X=DFN_"^LAST DX [SURVEILLANCE DIABETES;DURING "_$$DOB^AUPNPAT(DFN,"E")_"-"_$$FMTE^XLFDT(BGPEDATE)
SET E=$$START1^APCLDF(X,Y)
+5 IF BGPDM1
SET BGPN1=1
+6 IF '$DATA(BGPG(1))
SET BGPVALUE=""
QUIT
+7 SET BGPVALUE="UP|||"_$$DATE^BGP1UTL($PIECE(BGPG(1),U))_" POV "_$PIECE(BGPG(1),U,2)
+8 QUIT
+9 ;
I3 ;EP
+1 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPLHGB,BGPN5,BGPN6,BGPN7,BGPN8
+2 ;don't process this measure, pt not diabetic
IF 'BGPDM1
SET BGPSTOP=1
QUIT
DMGC ;EP - called from elder care
+1 SET BGPLHGB=$$HGBA1C(DFN,BGP365,BGPEDATE)
+2 SET BGPN1=$PIECE(BGPLHGB,U)
+3 SET BGPN2=$SELECT($PIECE(BGPLHGB,U,2)=2:1,1:0)
+4 SET BGPN3=$SELECT($PIECE(BGPLHGB,U,2)=3:1,1:0)
+5 SET BGPN4=$SELECT($PIECE(BGPLHGB,U,2)=4:1,1:0)
+6 SET BGPN5=$SELECT($PIECE(BGPLHGB,U,2)=5:1,1:0)
+7 SET BGPN6=$SELECT($PIECE(BGPLHGB,U,2)=6:1,1:0)
+8 SET BGPN7=$SELECT($PIECE(BGPLHGB,U,2)=7:1,1:0)
+9 SET BGPN8=0
IF BGPN2!(BGPN3)
SET BGPN8=1
+10 SET BGPXPBV=$PIECE(BGPLHGB,U,4)
+11 SET BGPVALUE=$SELECT(BGPDMD1:"UP",1:"")_$SELECT(BGPDMD2:",AD",1:"")_$SELECT(BGPDMD3:",AAD",1:"")_"||| "_$$DATE^BGP1UTL($PIECE(BGPLHGB,U,3))_$SELECT($PIECE(BGPLHGB,U,4)]"":" A1c: "_$PIECE(BGPLHGB,U,4),1:"")
+12 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,J,K,G,I,L,T,BGPLHGB
+13 QUIT
I4 ;EP
+1 KILL BGPN1,BGPN2,BGPN3,BGPVALUE,BGPLBP,BGPN4,BGPN5,BGPN6
+2 ;BGPN4 AND BGPN5, BGPN6 ARE GPRA DEV 2011
+3 ;don't process this measure, pt not diabetic
IF 'BGPDM1
SET BGPSTOP=1
QUIT
DMBP ;EP - called from elder care
+1 SET BGPVALUE=$$MEANBP(DFN,BGP365,BGPEDATE)
+2 IF BGPVALUE=""
SET BGPBP=$$BPCPT^BGP1D22(DFN,BGPBDATE,BGPEDATE)
IF BGPBP]""
SET BGPN1=1
Begin DoDot:1
+3 SET BGPN2=$PIECE(BGPBP,U)
SET BGPN3=$SELECT('$PIECE(BGPBP,U):1,1:0)
SET BGPVALUE=$PIECE(BGPBP,U,2)_" "_$SELECT(BGPN2:"CON",1:"UNC")_"^"_$SELECT(BGPN2:2,BGPN3:3,1:"")
End DoDot:1
GOTO BPX
+4 SET BGPN1=$SELECT($PIECE(BGPVALUE,U,2):1,1:0)
+5 SET BGPN2=$SELECT($PIECE(BGPVALUE,U,2)=2:1,1:0)
+6 SET BGPN3=$SELECT($PIECE(BGPVALUE,U,2)=3:1,1:0)
BPX ;
+1 SET BGPVALUD=$$MEANBP(DFN,BGP365,BGPEDATE,1)
+2 IF BGPVALUD=""
SET BGPBP=$$BPCPT^BGP1D22(DFN,BGPBDATE,BGPEDATE,1)
IF BGPBP]""
SET BGPN4=1
Begin DoDot:1
+3 SET BGPN5=$PIECE(BGPBP,U)
SET BGPN6=$SELECT('$PIECE(BGPBP,U):1,1:0)
SET BGPVALUD=$PIECE(BGPBP,U,2)_" "_$SELECT(BGPN5:"CON",1:"UNC")_"^"_$SELECT(BGPN5:2,BGPN6:3,1:"")
End DoDot:1
GOTO BPX1
+4 SET BGPN4=$SELECT($PIECE(BGPVALUD,U,2):1,1:0)
+5 SET BGPN5=$SELECT($PIECE(BGPVALUD,U,2)=2:1,1:0)
+6 SET BGPN6=$SELECT($PIECE(BGPVALUD,U,2)=3:1,1:0)
BPX1 ;
+1 SET BGPXPBV=$PIECE(BGPVALUE,U,1)
SET BGPXPBV=$PIECE(BGPXPBV," ",1)
+2 IF $PIECE(BGPVALUE,U,2)=""
SET BGPVALUE=""
+3 IF $PIECE(BGPVALUD,U,2)=""
SET BGPVALUD=""
+4 SET BGPVALUE=$SELECT(BGPDMD1:"UP"_$SELECT(BGPDMD2:",AD",1:"")_$SELECT(BGPDMD3:",AAD",1:""),1:"")_"|||"_$PIECE(BGPVALUE,U)
+5 SET BGPVALUD="AAD"_"|||"_$PIECE(BGPVALUD,U)
+6 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F
+7 QUIT
+8 ;
I5 ;EP
+1 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPVALUE,BGPLD,BGPLDL,BGPTRI,BGPHDL
+2 ;S (BGPTRI,BGPLDL,BGPHDL)=""
+3 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
+4 ;don't process this measure, pt not diabetic
IF 'BGPDM1
SET BGPSTOP=1
QUIT
+5 ;S BGPLP=$$LIPID(DFN,BGP365,BGPEDATE) S BGPN1=$P(BGPLP,U)
DMLDL ;EP - called from elder care
+1 SET BGPLDL=$$LDL(DFN,BGP365,BGPEDATE)
+2 ;I $P(BGPN1,U)'=1 D
+3 ;.S BGPTRI=$$TRIG(DFN,BGP365,BGPEDATE)
+4 ;.S BGPHDL=$$HDL(DFN,BGP365,BGPEDATE)
+5 ;.I BGPTRI,BGPHDL,+BGPLDL S BGPN1=1
+6 SET BGPN2=$PIECE(BGPLDL,U)
+7 DO CHKLDL
+8 SET BGPXPBV=$PIECE(BGPLDL,U,3)
+9 SET BGPVALUE=$SELECT(BGPDMD1:"UP",1:"")_$SELECT(BGPDMD2:",AD",1:"")_$SELECT(BGPDMD3:",AAD",1:"")_"|||"
+10 ;I $P(BGPLP,U) S BGPVALUE=BGPVALUE_$S($P(BGPLP,U):"LP: "_$$DATE^BGP1UTL($P(BGPLP,U,2))_" "_$P(BGPLP,U,3),1:"")
+11 ;I '$P(BGPLP,U),BGPTRI,BGPHDL,BGPLDL S BGPVALUE=BGPVALUE_"TRI:"_$$DATE^BGP1UTL($P(BGPTRI,U,2))_" HDL:"_$$DATE^BGP1UTL($P(BGPHDL,U,2))_" LDL:"_$$DATE^BGP1UTL($P(BGPLDL,U,2))
+12 IF $PIECE(BGPVALUE,"|||",2)]""
SET BGPVALUE=BGPVALUE_" ; "
+13 IF BGPLDL]""
SET BGPVALUE=BGPVALUE_"LDL DONE: "_$$DATE^BGP1UTL($PIECE(BGPLDL,U,2))_" "_$PIECE(BGPLDL,U,3)
+14 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,BGPLDL,BGPHDL,BGPTRI,BGPLP
+15 QUIT
+16 ;
CHKLDL ;EP
+1 NEW V
+2 IF $PIECE(BGPLDL,U,3)]""
IF $PIECE(BGPLDL,U,3)["3048F"
SET BGPN3=1
SET BGPN4=1
SET $PIECE(BGPLDL,U,3)="CPT 3048F LDL<100"
QUIT
+3 IF $PIECE(BGPLDL,U,3)]""
IF $PIECE(BGPLDL,U,3)["3049F"
SET BGPN3=1
SET $PIECE(BGPLDL,U,3)="CPT 3049F LDL <130"
QUIT
+4 IF $PIECE(BGPLDL,U,3)]""
IF $PIECE(BGPLDL,U,3)["CPT"
QUIT
+5 SET V=$PIECE(BGPLDL,U,3)
SET V=+V
+6 IF 'V
QUIT
+7 IF $PIECE(BGPLDL,U,3)]""
IF $PIECE(BGPLDL,U,3)'>100
SET BGPN4=1
+8 IF $PIECE(BGPLDL,U,3)]""
IF $PIECE(BGPLDL,U,3)>100
IF $PIECE(BGPLDL,U,3)<130
SET BGPN5=1
+9 IF $PIECE(BGPLDL,U,3)]""
IF $PIECE(BGPLDL,U,3)<130
SET BGPN3=1
+10 QUIT
HGBA1C(P,BDATE,EDATE) ;EP
+1 KILL BGPG,BGPT,BGPC
+2 SET BGPC=0
+3 ;now get all loinc/taxonomy tests
+4 SET T=$ORDER(^ATXAX("B","BGP HGBA1C LOINC CODES",0))
+5 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT HGB A1C TAX",0))
+6 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
+7 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+9 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+10 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
+11 IF 'T
QUIT
+12 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+13 IF '$$LOINC(J,T)
QUIT
+14 SET BGPC=BGPC+1
SET BGPT(D,BGPC)=$PIECE(^AUPNVLAB(X,0),U,4)
+15 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+16 SET %=""
SET E=+$$CODEN^ICPTCOD("3044F")
SET %=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
+17 IF %]""
SET BGPC=BGPC+1
SET BGPT(9999999-$PIECE(%,U,2),BGPC)="CPT 3044F"
+18 SET %=""
SET E=+$$CODEN^ICPTCOD("3044F")
SET %=$$TRANI^BGP1DU(P,BDATE,EDATE,E)
+19 IF %]""
SET BGPC=BGPC+1
SET BGPT(9999999-$PIECE(%,U,2),BGPC)="CPT/TRAN 3044F"
+20 ; now got though and set return value of done 1 or 0^numerator 2-7^date^value
+21 ;no tests
IF '$DATA(BGPT)
DO HCPT
QUIT %
+22 SET D=0
SET G=""
FOR
SET D=$ORDER(BGPT(D))
IF D'=+D!(G]"")
QUIT
Begin DoDot:1
+23 SET C=0
FOR
SET C=$ORDER(BGPT(D,C))
IF C'=+C!(G]"")
QUIT
Begin DoDot:2
+24 SET X=BGPT(D,C)
+25 IF $$UP^XLFSTR(X)="COMMENT"
QUIT
+26 IF X=""
QUIT
+27 IF X["3044F"
SET G=D_U_X
QUIT
+28 IF $EXTRACT(X)[">"
SET G=D_U_X
QUIT
+29 IF $EXTRACT(X)["<"
SET G=D_U_X
QUIT
+30 IF $EXTRACT(X)'=+$EXTRACT(X)
QUIT
+31 SET G=D_U_X
End DoDot:2
End DoDot:1
+32 IF G=""
QUIT 1_"^"_7_"^"_(9999999-$ORDER(BGPT(0)))
+33 IF $PIECE(G,U,2)["3044F"
QUIT 1_"^"_6_"^"_(9999999-$PIECE(G,U))_"^"_$PIECE(G,U,2)
+34 IF $EXTRACT($PIECE(G,U,2))=">"
QUIT 1_"^"_2_"^"_(9999999-$PIECE(G,U))_"^"_$PIECE(G,U,2)
+35 IF $EXTRACT($PIECE(G,U,2))="<"
QUIT 1_"^"_6_"^"_(9999999-$PIECE(G,U))_"^"_$PIECE(G,U,2)
+36 IF +($PIECE(G,U,2))'<12
QUIT 1_"^"_2_"^"_(9999999-$PIECE(G,U))_"^"_$PIECE(G,U,2)
+37 IF +($PIECE(G,U,2))>9.5
QUIT 1_"^"_3_"^"_(9999999-$PIECE(G,U))_"^"_$PIECE(G,U,2)
+38 IF +($PIECE(G,U,2))'<8
QUIT 1_"^"_4_"^"_(9999999-$PIECE(G,U))_"^"_$PIECE(G,U,2)
+39 IF +($PIECE(G,U,2))'<7
QUIT 1_"^"_5_"^"_(9999999-$PIECE(G,U))_"^"_$PIECE(G,U,2)
+40 IF +($PIECE(G,U,2))=0
QUIT 1_"^"_7_"^"_(9999999-$PIECE(G,U))_"^"_$PIECE(G,U,2)
+41 QUIT 1_"^"_6_"^"_(9999999-$PIECE(G,U))_"^"_$PIECE(G,U,2)
+42 ;
HCPT ;
+1 SET %=""
+2 SET %=""
SET E=+$$CODEN^ICPTCOD(83036)
SET %=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
+3 IF %]""
SET BGPC=BGPC+1
SET BGPT(9999999-$PIECE(%,U,2),BGPC)="CPT 83036"
+4 SET %=""
SET E=+$$CODEN^ICPTCOD(83036)
SET %=$$TRANI^BGP1DU(P,BDATE,EDATE,E)
+5 IF %]""
SET BGPC=BGPC+1
SET BGPT(9999999-$PIECE(%,U,2),BGPC)="CPT/TRAN 83036"
+6 SET %=""
SET E=+$$CODEN^ICPTCOD(83037)
SET %=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
+7 IF %]""
SET BGPC=BGPC+1
SET BGPT(9999999-$PIECE(%,U,2),BGPC)="CPT 83037"
+8 SET %=""
SET E=+$$CODEN^ICPTCOD(83037)
SET %=$$TRANI^BGP1DU(P,BDATE,EDATE,E)
+9 IF %]""
SET BGPC=BGPC+1
SET BGPT(9999999-$PIECE(%,U,2),BGPC)="CPT/TRAN 83037"
+10 SET %=""
SET E=+$$CODEN^ICPTCOD("3045F")
SET %=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
+11 IF %]""
SET BGPC=BGPC+1
SET BGPT(9999999-$PIECE(%,U,2),BGPC)="CPT 3045F"
+12 SET %=""
SET E=+$$CODEN^ICPTCOD("3045F")
SET %=$$TRANI^BGP1DU(P,BDATE,EDATE,E)
+13 IF %]""
SET BGPC=BGPC+1
SET BGPT(9999999-$PIECE(%,U,2),BGPC)="CPT/TRAN 3045F"
+14 SET %=""
SET E=+$$CODEN^ICPTCOD("3046F")
SET %=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
+15 IF %]""
SET BGPC=BGPC+1
SET BGPT(9999999-$PIECE(%,U,2),BGPC)="CPT 3046F"
+16 SET %=""
SET E=+$$CODEN^ICPTCOD("3046F")
SET %=$$TRANI^BGP1DU(P,BDATE,EDATE,E)
+17 IF %]""
SET BGPC=BGPC+1
SET BGPT(9999999-$PIECE(%,U,2),BGPC)="CPT/TRAN 3046F"
+18 SET %=""
SET E=+$$CODEN^ICPTCOD("3047F")
SET %=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
+19 IF %]""
SET BGPC=BGPC+1
SET BGPT(9999999-$PIECE(%,U,2),BGPC)="CPT 3047F"
+20 SET %=""
SET E=+$$CODEN^ICPTCOD("3047F")
SET %=$$TRANI^BGP1DU(P,BDATE,EDATE,E)
+21 IF %]""
SET BGPC=BGPC+1
SET BGPT(9999999-$PIECE(%,U,2),BGPC)="CPT/TRAN 3047F"
+22 IF '$DATA(BGPT)
SET %=""
QUIT
+23 SET %="1^7^"_(9999999-$ORDER(BGPT(0)))
+24 QUIT
MEANBP(P,BDATE,EDATE,GDEV) ;EP
+1 NEW X,S,DS
+2 SET GDEV=$GET(GDEV)
+3 SET X=$$BPS(P,BDATE,EDATE,"I",GDEV)
+4 SET S=$$SYSMEAN(X)
IF S=""
QUIT ""
+5 SET DS=$$DIAMEAN(X)
IF DS=""
QUIT ""
+6 IF S<130&(DS<80)
QUIT S_"/"_DS_" CON"_U_2
+7 QUIT S_"/"_DS_" UNC"_U_3
+8 ;
SYSMEAN(X) ;EP
+1 NEW Y,C,T
+2 IF X=""
QUIT ""
+3 SET C=0
FOR Y=1:1:3
IF $PIECE(X,";",Y)]""
SET C=C+1
+4 IF C<2
QUIT ""
+5 SET T=0
FOR Y=1:1:3
SET T=$PIECE($PIECE(X,";",Y),"/")+T
+6 ;Q $$STRIP^XLFSTR($J((T/C),5,1)," ")
+7 QUIT T\C
+8 ;
DIAMEAN(X) ;EP
+1 NEW C,Y,T
+2 IF X=""
QUIT ""
+3 SET C=0
FOR Y=1:1:3
IF $PIECE(X,";",Y)]""
SET C=C+1
+4 IF C<2
QUIT ""
+5 SET T=0
FOR Y=1:1:3
SET T=$PIECE($PIECE(X,";",Y),"/",2)+T
+6 ;Q $$STRIP^XLFSTR($J((T/C),5,1)," ")
+7 QUIT T\C
+8 ;
GDEV(V) ;EP
+1 IF $PIECE(^AUPNVSIT(V,0),U,7)="H"
QUIT 1
+2 IF $PIECE(^AUPNVSIT(V,0),U,7)="I"
QUIT 1
+3 IF $PIECE(^AUPNVSIT(V,0),U,7)="S"
QUIT 1
+4 IF $PIECE(^AUPNVSIT(V,0),U,7)="O"
QUIT 1
+5 NEW C
+6 SET C=$$CLINIC^APCLV(V,"C")
+7 IF C=30
QUIT 1
+8 IF C=23
QUIT 1
+9 IF C=44
QUIT 1
+10 IF C="C1"
QUIT 1
+11 IF C="D4"
QUIT 1
+12 QUIT 0
BPS(P,BDATE,EDATE,F,GDEV) ;EP ;
+1 IF $GET(F)=""
SET F="E"
+2 NEW BGPGLL,BGPGV,BGPG,A,B,E,Y,V,BGPBP,X,Z
+3 SET BGPGLL=0
SET BGPGV=""
+4 KILL BGPG
+5 KILL ^TMP($JOB,"BPV")
+6 SET A="^TMP($J,""BPV"","
SET B=P_"^LAST 365 VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+7 IF '$DATA(^TMP($JOB,"BPV",1))
QUIT ""
+8 SET Y=0
FOR
SET Y=$ORDER(^TMP($JOB,"BPV",Y))
IF Y'=+Y!(BGPGLL=3)
QUIT
Begin DoDot:1
+9 SET V=$PIECE(^TMP($JOB,"BPV",Y),U,5)
+10 ;NO ER CLINIC VISITS COUNTED
IF $$CLINIC^APCLV(V,"C")=30
QUIT
+11 IF $GET(GDEV)
IF $$GDEV(V)
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 ;entered in error so skip it
IF $PIECE($GET(^AUPNVMSR(X,2)),U,1)
QUIT
+21 ;blood pressure value
SET Z=$PIECE(^AUPNVMSR(X,0),U,4)
+22 IF BGPBP=""
SET BGPBP=Z
QUIT
+23 IF $PIECE(Z,"/")'>$PIECE(BGPBP,"/")
SET BGPBP=Z
End DoDot:2
+24 IF BGPBP=""
QUIT
+25 SET BGPGLL=BGPGLL+1
+26 IF F="E"
SET $PIECE(BGPGV,";",BGPGLL)=BGPBP_" "_$$FMTE^XLFDT($PIECE(^TMP($JOB,"BPV",V),U))
+27 IF F="I"
SET $PIECE(BGPGV,";",BGPGLL)=$PIECE(BGPBP," ")
End DoDot:1
+28 KILL ^TMP($JOB,"BPV")
+29 QUIT BGPGV
LIPID(P,BDATE,EDATE) ;EP
+1 KILL BGPC
+2 SET BGPC=0
+3 SET %=""
SET E=+$$CODEN^ICPTCOD(80061)
SET %=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
+4 IF %]""
QUIT 1_U_$PIECE(%,U,2)_U_"80061"
+5 SET %=""
SET E=+$$CODEN^ICPTCOD(80061)
SET %=$$TRANI^BGP1DU(P,BDATE,EDATE,E)
+6 IF %]""
QUIT 1_U_$PIECE(%,U,2)_U_"80061"
+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^BGP1DU(P,BDATE,EDATE,E)
+4 IF %]""
QUIT 1_U_$PIECE(%,U,2)
+5 SET %=""
SET E=+$$CODEN^ICPTCOD(84478)
SET %=$$TRANI^BGP1DU(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^BGP1DU(P,BDATE,EDATE,E)
+4 IF %]""
QUIT 1_U_$PIECE(%,U,2)
+5 SET %=""
SET E=+$$CODEN^ICPTCOD(83718)
SET %=$$TRANI^BGP1DU(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,NORES) ;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 SET NORES=$GET(NORES)
+5 ;now get all loinc/taxonomy tests
+6 SET T=$ORDER(^ATXAX("B","BGP LDL LOINC CODES",0))
+7 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))
+8 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
+9 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+11 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+12 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
+13 IF 'T
QUIT
+14 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+15 IF '$$LOINC(J,T)
QUIT
+16 SET R=$PIECE(^AUPNVLAB(X,0),U,4)
+17 IF 'R
SET R=""
+18 SET BGPC=BGPC+1
SET BGPT(D,BGPC)=R
+19 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+20 ; now got though and set return value of done 1 or 0^VALUE^date
+21 SET D=0
SET G=""
FOR
SET D=$ORDER(BGPT(D))
IF D'=+D!(G]"")
QUIT
Begin DoDot:1
+22 SET C=0
FOR
SET C=$ORDER(BGPT(D,C))
IF C'=+C!(G]"")
QUIT
Begin DoDot:2
+23 SET X=BGPT(D,C)
+24 IF X=""
QUIT
+25 SET G=(9999999-D)_U_X
+26 QUIT
End DoDot:2
End DoDot:1
+27 ;now get one with no result
IF G=""
Begin DoDot:1
+28 SET D=0
SET G=""
FOR
SET D=$ORDER(BGPT(D))
IF D'=+D!(G]"")
QUIT
Begin DoDot:2
+29 SET C=0
FOR
SET C=$ORDER(BGPT(D,C))
IF C'=+C!(G]"")
QUIT
Begin DoDot:3
+30 SET X=BGPT(D,C)
+31 IF X=""
QUIT
+32 SET G=(9999999-D)_U_X
End DoDot:3
+33 QUIT
End DoDot:2
End DoDot:1
+34 ;
+35 ;IF WANT A RESULT AND THERE IS ONE QUIT
IF 'NORES
IF G]""
QUIT 1_U_G
+36 SET %=$$CPT^BGP1DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP LDL CPTS",0)),5)
+37 IF %]""
SET BGPC=BGPC+1
SET BGPT(9999999-$PIECE(%,U,1),BGPC)="CPT "_$PIECE(%,U,2)
+38 SET %=$$TRAN^BGP1DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP LDL CPTS",0)),5)
+39 IF %]""
SET BGPC=BGPC+1
SET BGPT(9999999-$PIECE(%,U,1),BGPC)="CPT "_$PIECE(%,U,2)
+40 IF '$ORDER(BGPT(0))
QUIT ""
+41 SET %=$ORDER(BGPT(0))
SET C=$ORDER(BGPT(%,0))
QUIT 1_"^"_(9999999-%)_"^"_BGPT(%,C)
+42 QUIT ""
+43 ;
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 ""
BPCPT(P,BDATE,EDATE) ;EP
+1 NEW G
+2 SET G=$$CPTI^BGP1DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("3077F"),"",30)
+3 IF G
QUIT $$DATE^BGP1UTL($PIECE(G,U,2))_" CPT 3077F SYSTOLIC BP >=140 UNC^3"
+4 SET G=$$CPTI^BGP1DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("3080F"),"",30)
+5 IF G
QUIT $$DATE^BGP1UTL($PIECE(G,U,2))_" CPT 3080F DIASTOLIC BP >=90 UNC^3"
+6 QUIT ""
