- BGP2D2 ; IHS/CMI/LAB - measure 1,2,3,4 ;
- ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
- ;
- 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^BGP2UTL($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 BGPXPWV=$P(BGPLHGB,U,4)
- S BGPVALUE=$S(BGPDMD1:"UP",1:"")_$S(BGPDMD2:",AD",1:"")_$S(BGPDMD3:",AAD",1:"")_"||| "_$$DATE^BGP2UTL($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
- S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7)=0
- ;BGPN4 AND BGPN5, BGPN6 ARE GPRA DEV 2012
- I 'BGPDM1 S BGPSTOP=1 Q ;don't process this measure, pt not diabetic
- S BGPVALUE="",BGPVALUD="",BGPBP=""
- DMBP ;EP - called from elder care
- S BGPVALUE=$$MEANBP(DFN,BGP365,BGPEDATE)
- I BGPVALUE="" S BGPBP=$$BPCPT^BGP2D22(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^BGP2D22(DFN,BGPBDATE,BGPEDATE,1) I BGPBP]"" S BGPN4=1 D G BPX1
- .S (BGPN5,BGPN7)=$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)
- ;S BGPN7=$S($P(BGPVALUD,U,2)=4:1,1:0)
- ;I 'BGPN7 S BGPN7=$S($P(BGPVALUD,U,2)=2:1,1:0)
- S BGPN7=0 I $P(BGPVALUD,U,2)=2!($P(BGPVALUD,U,2)=4) S BGPN7=1
- BPX1 ;
- S BGPXPWV=$P(BGPVALUE,U,1),BGPXPWV=$P(BGPXPWV," ",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="AD"_"|||"_$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 BGPXPWV=$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^BGP2UTL($P(BGPLP,U,2))_" "_$P(BGPLP,U,3),1:"")
- ;I '$P(BGPLP,U),BGPTRI,BGPHDL,BGPLDL S BGPVALUE=BGPVALUE_"TRI:"_$$DATE^BGP2UTL($P(BGPTRI,U,2))_" HDL:"_$$DATE^BGP2UTL($P(BGPHDL,U,2))_" LDL:"_$$DATE^BGP2UTL($P(BGPLDL,U,2))
- I $P(BGPVALUE,"|||",2)]"" S BGPVALUE=BGPVALUE_" ; "
- I BGPLDL]"" S BGPVALUE=BGPVALUE_"LDL: "_$$DATE^BGP2UTL($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^BGP2DU(P,BDATE,EDATE,E)
- I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 3044F"
- S %="",E=+$$CODEN^ICPTCOD("3044F"),%=$$TRANI^BGP2DU(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^BGP2DU(P,BDATE,EDATE,E)
- I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 83036"
- S %="",E=+$$CODEN^ICPTCOD(83036),%=$$TRANI^BGP2DU(P,BDATE,EDATE,E)
- I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT/TRAN 83036"
- S %="",E=+$$CODEN^ICPTCOD(83037),%=$$CPTI^BGP2DU(P,BDATE,EDATE,E)
- I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 83037"
- S %="",E=+$$CODEN^ICPTCOD(83037),%=$$TRANI^BGP2DU(P,BDATE,EDATE,E)
- I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT/TRAN 83037"
- S %="",E=+$$CODEN^ICPTCOD("3045F"),%=$$CPTI^BGP2DU(P,BDATE,EDATE,E)
- I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 3045F"
- S %="",E=+$$CODEN^ICPTCOD("3045F"),%=$$TRANI^BGP2DU(P,BDATE,EDATE,E)
- I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT/TRAN 3045F"
- S %="",E=+$$CODEN^ICPTCOD("3046F"),%=$$CPTI^BGP2DU(P,BDATE,EDATE,E)
- I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 3046F"
- S %="",E=+$$CODEN^ICPTCOD("3046F"),%=$$TRANI^BGP2DU(P,BDATE,EDATE,E)
- I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT/TRAN 3046F"
- S %="",E=+$$CODEN^ICPTCOD("3047F"),%=$$CPTI^BGP2DU(P,BDATE,EDATE,E)
- I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 3047F"
- S %="",E=+$$CODEN^ICPTCOD("3047F"),%=$$TRANI^BGP2DU(P,BDATE,EDATE,E)
- I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT/TRAN 3047F"
- I '$D(BGPT) S %="" Q
- NEW Z,C
- S Z=$O(BGPT(0)),C=$O(BGPT(Z,0))
- S %="1^7^"_(9999999-$O(BGPT(0)))_U_BGPT(Z,C)
- 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
- I $G(GDEV) I S<140&(DS<90) Q S_"/"_DS_" CON"_U_4
- 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^BGP2DU(P,BDATE,EDATE,E)
- I %]"" Q 1_U_$P(%,U,2)_U_"80061"
- S %="",E=+$$CODEN^ICPTCOD(80061),%=$$TRANI^BGP2DU(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^BGP2DU(P,BDATE,EDATE,E)
- I %]"" Q 1_U_$P(%,U,2)
- S %="",E=+$$CODEN^ICPTCOD(84478),%=$$TRANI^BGP2DU(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^BGP2DU(P,BDATE,EDATE,E)
- I %]"" Q 1_U_$P(%,U,2)
- S %="",E=+$$CODEN^ICPTCOD(83718),%=$$TRANI^BGP2DU(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^BGP2DU(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^BGP2DU(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^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("3077F"),"",30)
- I G Q $$DATE^BGP2UTL($P(G,U,2))_" CPT 3077F SYSTOLIC BP >=140 UNC^3"
- S G=$$CPTI^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("3080F"),"",30)
- I G Q $$DATE^BGP2UTL($P(G,U,2))_" CPT 3080F DIASTOLIC BP >=90 UNC^3"
- Q ""
- BGP2D2 ; IHS/CMI/LAB - measure 1,2,3,4 ;
- +1 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
- +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^BGP2UTL($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 BGPXPWV=$PIECE(BGPLHGB,U,4)
- +11 SET BGPVALUE=$SELECT(BGPDMD1:"UP",1:"")_$SELECT(BGPDMD2:",AD",1:"")_$SELECT(BGPDMD3:",AAD",1:"")_"||| "_$$DATE^BGP2UTL($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 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7)=0
- +2 ;BGPN4 AND BGPN5, BGPN6 ARE GPRA DEV 2012
- +3 ;don't process this measure, pt not diabetic
- IF 'BGPDM1
- SET BGPSTOP=1
- QUIT
- +4 SET BGPVALUE=""
- SET BGPVALUD=""
- SET BGPBP=""
- DMBP ;EP - called from elder care
- +1 SET BGPVALUE=$$MEANBP(DFN,BGP365,BGPEDATE)
- +2 IF BGPVALUE=""
- SET BGPBP=$$BPCPT^BGP2D22(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^BGP2D22(DFN,BGPBDATE,BGPEDATE,1)
- IF BGPBP]""
- SET BGPN4=1
- Begin DoDot:1
- +3 SET (BGPN5,BGPN7)=$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)
- +7 ;S BGPN7=$S($P(BGPVALUD,U,2)=4:1,1:0)
- +8 ;I 'BGPN7 S BGPN7=$S($P(BGPVALUD,U,2)=2:1,1:0)
- +9 SET BGPN7=0
- IF $PIECE(BGPVALUD,U,2)=2!($PIECE(BGPVALUD,U,2)=4)
- SET BGPN7=1
- BPX1 ;
- +1 SET BGPXPWV=$PIECE(BGPVALUE,U,1)
- SET BGPXPWV=$PIECE(BGPXPWV," ",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="AD"_"|||"_$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 BGPXPWV=$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^BGP2UTL($P(BGPLP,U,2))_" "_$P(BGPLP,U,3),1:"")
- +11 ;I '$P(BGPLP,U),BGPTRI,BGPHDL,BGPLDL S BGPVALUE=BGPVALUE_"TRI:"_$$DATE^BGP2UTL($P(BGPTRI,U,2))_" HDL:"_$$DATE^BGP2UTL($P(BGPHDL,U,2))_" LDL:"_$$DATE^BGP2UTL($P(BGPLDL,U,2))
- +12 IF $PIECE(BGPVALUE,"|||",2)]""
- SET BGPVALUE=BGPVALUE_" ; "
- +13 IF BGPLDL]""
- SET BGPVALUE=BGPVALUE_"LDL: "_$$DATE^BGP2UTL($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^BGP2DU(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^BGP2DU(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^BGP2DU(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^BGP2DU(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^BGP2DU(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^BGP2DU(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^BGP2DU(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^BGP2DU(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^BGP2DU(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^BGP2DU(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^BGP2DU(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^BGP2DU(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 NEW Z,C
- +24 SET Z=$ORDER(BGPT(0))
- SET C=$ORDER(BGPT(Z,0))
- +25 SET %="1^7^"_(9999999-$ORDER(BGPT(0)))_U_BGPT(Z,C)
- +26 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 IF $GET(GDEV)
- IF S<140&(DS<90)
- QUIT S_"/"_DS_" CON"_U_4
- +8 QUIT S_"/"_DS_" UNC"_U_3
- +9 ;
- 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^BGP2DU(P,BDATE,EDATE,E)
- +4 IF %]""
- QUIT 1_U_$PIECE(%,U,2)_U_"80061"
- +5 SET %=""
- SET E=+$$CODEN^ICPTCOD(80061)
- SET %=$$TRANI^BGP2DU(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^BGP2DU(P,BDATE,EDATE,E)
- +4 IF %]""
- QUIT 1_U_$PIECE(%,U,2)
- +5 SET %=""
- SET E=+$$CODEN^ICPTCOD(84478)
- SET %=$$TRANI^BGP2DU(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^BGP2DU(P,BDATE,EDATE,E)
- +4 IF %]""
- QUIT 1_U_$PIECE(%,U,2)
- +5 SET %=""
- SET E=+$$CODEN^ICPTCOD(83718)
- SET %=$$TRANI^BGP2DU(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^BGP2DU(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^BGP2DU(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^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("3077F"),"",30)
- +3 IF G
- QUIT $$DATE^BGP2UTL($PIECE(G,U,2))_" CPT 3077F SYSTOLIC BP >=140 UNC^3"
- +4 SET G=$$CPTI^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("3080F"),"",30)
- +5 IF G
- QUIT $$DATE^BGP2UTL($PIECE(G,U,2))_" CPT 3080F DIASTOLIC BP >=90 UNC^3"
- +6 QUIT ""