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

BGP2D2.m

Go to the documentation of this file.
  1. BGP2D2 ; IHS/CMI/LAB - measure 1,2,3,4 ;
  1. ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
  1. ;
  1. I1 ;EP - measure 1 general processing
  1. S BGPN1=0
  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^BGP2UTL($P(BGPG(1),U))_" POV "_$P(BGPG(1),U,2)
  1. Q
  1. ;
  1. I3 ;EP
  1. K BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPLHGB,BGPN5,BGPN6,BGPN7,BGPN8
  1. I 'BGPDM1 S BGPSTOP=1 Q ;don't process this measure, pt not diabetic
  1. DMGC ;EP - called from elder care
  1. S BGPLHGB=$$HGBA1C(DFN,BGP365,BGPEDATE)
  1. S BGPN1=$P(BGPLHGB,U)
  1. S BGPN2=$S($P(BGPLHGB,U,2)=2:1,1:0)
  1. S BGPN3=$S($P(BGPLHGB,U,2)=3:1,1:0)
  1. S BGPN4=$S($P(BGPLHGB,U,2)=4:1,1:0)
  1. S BGPN5=$S($P(BGPLHGB,U,2)=5:1,1:0)
  1. S BGPN6=$S($P(BGPLHGB,U,2)=6:1,1:0)
  1. S BGPN7=$S($P(BGPLHGB,U,2)=7:1,1:0)
  1. S BGPN8=0 I BGPN2!(BGPN3) S BGPN8=1
  1. S BGPXPWV=$P(BGPLHGB,U,4)
  1. 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:"")
  1. K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,J,K,G,I,L,T,BGPLHGB
  1. Q
  1. I4 ;EP
  1. S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7)=0
  1. ;BGPN4 AND BGPN5, BGPN6 ARE GPRA DEV 2012
  1. I 'BGPDM1 S BGPSTOP=1 Q ;don't process this measure, pt not diabetic
  1. S BGPVALUE="",BGPVALUD="",BGPBP=""
  1. DMBP ;EP - called from elder care
  1. S BGPVALUE=$$MEANBP(DFN,BGP365,BGPEDATE)
  1. I BGPVALUE="" S BGPBP=$$BPCPT^BGP2D22(DFN,BGPBDATE,BGPEDATE) I BGPBP]"" S BGPN1=1 D G BPX
  1. .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:"")
  1. S BGPN1=$S($P(BGPVALUE,U,2):1,1:0)
  1. S BGPN2=$S($P(BGPVALUE,U,2)=2:1,1:0)
  1. S BGPN3=$S($P(BGPVALUE,U,2)=3:1,1:0)
  1. BPX ;
  1. S BGPVALUD=$$MEANBP(DFN,BGP365,BGPEDATE,1)
  1. I BGPVALUD="" S BGPBP=$$BPCPT^BGP2D22(DFN,BGPBDATE,BGPEDATE,1) I BGPBP]"" S BGPN4=1 D G BPX1
  1. .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:"")
  1. S BGPN4=$S($P(BGPVALUD,U,2):1,1:0)
  1. S BGPN5=$S($P(BGPVALUD,U,2)=2:1,1:0)
  1. S BGPN6=$S($P(BGPVALUD,U,2)=3:1,1:0)
  1. ;S BGPN7=$S($P(BGPVALUD,U,2)=4:1,1:0)
  1. ;I 'BGPN7 S BGPN7=$S($P(BGPVALUD,U,2)=2:1,1:0)
  1. S BGPN7=0 I $P(BGPVALUD,U,2)=2!($P(BGPVALUD,U,2)=4) S BGPN7=1
  1. BPX1 ;
  1. S BGPXPWV=$P(BGPVALUE,U,1),BGPXPWV=$P(BGPXPWV," ",1)
  1. I $P(BGPVALUE,U,2)="" S BGPVALUE=""
  1. I $P(BGPVALUD,U,2)="" S BGPVALUD=""
  1. S BGPVALUE=$S(BGPDMD1:"UP"_$S(BGPDMD2:",AD",1:"")_$S(BGPDMD3:",AAD",1:""),1:"")_"|||"_$P(BGPVALUE,U)
  1. S BGPVALUD="AD"_"|||"_$P(BGPVALUD,U)
  1. K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F
  1. Q
  1. ;
  1. I5 ;EP
  1. K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPVALUE,BGPLD,BGPLDL,BGPTRI,BGPHDL
  1. ;S (BGPTRI,BGPLDL,BGPHDL)=""
  1. S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
  1. I 'BGPDM1 S BGPSTOP=1 Q ;don't process this measure, pt not diabetic
  1. ;S BGPLP=$$LIPID(DFN,BGP365,BGPEDATE) S BGPN1=$P(BGPLP,U)
  1. DMLDL ;EP - called from elder care
  1. S BGPLDL=$$LDL(DFN,BGP365,BGPEDATE)
  1. ;I $P(BGPN1,U)'=1 D
  1. ;.S BGPTRI=$$TRIG(DFN,BGP365,BGPEDATE)
  1. ;.S BGPHDL=$$HDL(DFN,BGP365,BGPEDATE)
  1. ;.I BGPTRI,BGPHDL,+BGPLDL S BGPN1=1
  1. S BGPN2=$P(BGPLDL,U)
  1. D CHKLDL
  1. S BGPXPWV=$P(BGPLDL,U,3)
  1. S BGPVALUE=$S(BGPDMD1:"UP",1:"")_$S(BGPDMD2:",AD",1:"")_$S(BGPDMD3:",AAD",1:"")_"|||"
  1. ;I $P(BGPLP,U) S BGPVALUE=BGPVALUE_$S($P(BGPLP,U):"LP: "_$$DATE^BGP2UTL($P(BGPLP,U,2))_" "_$P(BGPLP,U,3),1:"")
  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))
  1. I $P(BGPVALUE,"|||",2)]"" S BGPVALUE=BGPVALUE_" ; "
  1. I BGPLDL]"" S BGPVALUE=BGPVALUE_"LDL: "_$$DATE^BGP2UTL($P(BGPLDL,U,2))_" "_$P(BGPLDL,U,3)
  1. K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,BGPLDL,BGPHDL,BGPTRI,BGPLP
  1. Q
  1. ;
  1. CHKLDL ;EP
  1. NEW V
  1. I $P(BGPLDL,U,3)]"",$P(BGPLDL,U,3)["3048F" S BGPN3=1,BGPN4=1,$P(BGPLDL,U,3)="CPT 3048F LDL<100" Q
  1. I $P(BGPLDL,U,3)]"",$P(BGPLDL,U,3)["3049F" S BGPN3=1,$P(BGPLDL,U,3)="CPT 3049F LDL <130" Q
  1. I $P(BGPLDL,U,3)]"",$P(BGPLDL,U,3)["CPT" Q
  1. S V=$P(BGPLDL,U,3),V=+V
  1. I 'V Q
  1. I $P(BGPLDL,U,3)]"",$P(BGPLDL,U,3)'>100 S BGPN4=1
  1. I $P(BGPLDL,U,3)]"",$P(BGPLDL,U,3)>100,$P(BGPLDL,U,3)<130 S BGPN5=1
  1. I $P(BGPLDL,U,3)]"",$P(BGPLDL,U,3)<130 S BGPN3=1
  1. Q
  1. HGBA1C(P,BDATE,EDATE) ;EP
  1. K BGPG,BGPT,BGPC
  1. S BGPC=0
  1. ;now get all loinc/taxonomy tests
  1. S T=$O(^ATXAX("B","BGP HGBA1C LOINC CODES",0))
  1. S BGPLT=$O(^ATXLAB("B","DM AUDIT HGB A1C 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 BGPC=BGPC+1,BGPT(D,BGPC)=$P(^AUPNVLAB(X,0),U,4)
  1. ...Q
  1. S %="",E=+$$CODEN^ICPTCOD("3044F"),%=$$CPTI^BGP2DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 3044F"
  1. S %="",E=+$$CODEN^ICPTCOD("3044F"),%=$$TRANI^BGP2DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT/TRAN 3044F"
  1. ; now got though and set return value of done 1 or 0^numerator 2-7^date^value
  1. I '$D(BGPT) D HCPT 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 $$UP^XLFSTR(X)="COMMENT" Q
  1. ..I X="" Q
  1. ..I X["3044F" S G=D_U_X Q
  1. ..I $E(X)[">" S G=D_U_X Q
  1. ..I $E(X)["<" S G=D_U_X Q
  1. ..I $E(X)'=+$E(X) Q
  1. ..S G=D_U_X
  1. I G="" Q 1_"^"_7_"^"_(9999999-$O(BGPT(0)))
  1. I $P(G,U,2)["3044F" Q 1_"^"_6_"^"_(9999999-$P(G,U))_"^"_$P(G,U,2)
  1. I $E($P(G,U,2))=">" Q 1_"^"_2_"^"_(9999999-$P(G,U))_"^"_$P(G,U,2)
  1. I $E($P(G,U,2))="<" Q 1_"^"_6_"^"_(9999999-$P(G,U))_"^"_$P(G,U,2)
  1. I +($P(G,U,2))'<12 Q 1_"^"_2_"^"_(9999999-$P(G,U))_"^"_$P(G,U,2)
  1. I +($P(G,U,2))>9.5 Q 1_"^"_3_"^"_(9999999-$P(G,U))_"^"_$P(G,U,2)
  1. I +($P(G,U,2))'<8 Q 1_"^"_4_"^"_(9999999-$P(G,U))_"^"_$P(G,U,2)
  1. I +($P(G,U,2))'<7 Q 1_"^"_5_"^"_(9999999-$P(G,U))_"^"_$P(G,U,2)
  1. I +($P(G,U,2))=0 Q 1_"^"_7_"^"_(9999999-$P(G,U))_"^"_$P(G,U,2)
  1. Q 1_"^"_6_"^"_(9999999-$P(G,U))_"^"_$P(G,U,2)
  1. ;
  1. HCPT ;
  1. S %=""
  1. S %="",E=+$$CODEN^ICPTCOD(83036),%=$$CPTI^BGP2DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 83036"
  1. S %="",E=+$$CODEN^ICPTCOD(83036),%=$$TRANI^BGP2DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT/TRAN 83036"
  1. S %="",E=+$$CODEN^ICPTCOD(83037),%=$$CPTI^BGP2DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 83037"
  1. S %="",E=+$$CODEN^ICPTCOD(83037),%=$$TRANI^BGP2DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT/TRAN 83037"
  1. S %="",E=+$$CODEN^ICPTCOD("3045F"),%=$$CPTI^BGP2DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 3045F"
  1. S %="",E=+$$CODEN^ICPTCOD("3045F"),%=$$TRANI^BGP2DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT/TRAN 3045F"
  1. S %="",E=+$$CODEN^ICPTCOD("3046F"),%=$$CPTI^BGP2DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 3046F"
  1. S %="",E=+$$CODEN^ICPTCOD("3046F"),%=$$TRANI^BGP2DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT/TRAN 3046F"
  1. S %="",E=+$$CODEN^ICPTCOD("3047F"),%=$$CPTI^BGP2DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 3047F"
  1. S %="",E=+$$CODEN^ICPTCOD("3047F"),%=$$TRANI^BGP2DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT/TRAN 3047F"
  1. I '$D(BGPT) S %="" Q
  1. NEW Z,C
  1. S Z=$O(BGPT(0)),C=$O(BGPT(Z,0))
  1. S %="1^7^"_(9999999-$O(BGPT(0)))_U_BGPT(Z,C)
  1. Q
  1. MEANBP(P,BDATE,EDATE,GDEV) ;EP
  1. NEW X,S,DS
  1. S GDEV=$G(GDEV)
  1. S X=$$BPS(P,BDATE,EDATE,"I",GDEV)
  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. I $G(GDEV) I S<140&(DS<90) Q S_"/"_DS_" CON"_U_4
  1. Q S_"/"_DS_" UNC"_U_3
  1. ;
  1. SYSMEAN(X) ;EP
  1. NEW Y,C,T
  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. Q T\C
  1. ;
  1. DIAMEAN(X) ;EP
  1. NEW C,Y,T
  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. Q T\C
  1. ;
  1. GDEV(V) ;EP
  1. I $P(^AUPNVSIT(V,0),U,7)="H" Q 1
  1. I $P(^AUPNVSIT(V,0),U,7)="I" Q 1
  1. I $P(^AUPNVSIT(V,0),U,7)="S" Q 1
  1. I $P(^AUPNVSIT(V,0),U,7)="O" Q 1
  1. NEW C
  1. S C=$$CLINIC^APCLV(V,"C")
  1. I C=30 Q 1
  1. I C=23 Q 1
  1. I C=44 Q 1
  1. I C="C1" Q 1
  1. I C="D4" Q 1
  1. Q 0
  1. BPS(P,BDATE,EDATE,F,GDEV) ;EP ;
  1. I $G(F)="" S F="E"
  1. NEW BGPGLL,BGPGV,BGPG,A,B,E,Y,V,BGPBP,X,Z
  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 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. .I $G(GDEV) Q:$$GDEV(V)
  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. ..Q:$P($G(^AUPNVMSR(X,2)),U,1) ;entered in error so skip it
  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^BGP2DU(P,BDATE,EDATE,E)
  1. I %]"" Q 1_U_$P(%,U,2)_U_"80061"
  1. S %="",E=+$$CODEN^ICPTCOD(80061),%=$$TRANI^BGP2DU(P,BDATE,EDATE,E)
  1. I %]"" Q 1_U_$P(%,U,2)_U_"80061"
  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^BGP2DU(P,BDATE,EDATE,E)
  1. I %]"" Q 1_U_$P(%,U,2)
  1. S %="",E=+$$CODEN^ICPTCOD(84478),%=$$TRANI^BGP2DU(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^BGP2DU(P,BDATE,EDATE,E)
  1. I %]"" Q 1_U_$P(%,U,2)
  1. S %="",E=+$$CODEN^ICPTCOD(83718),%=$$TRANI^BGP2DU(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,NORES) ;EP
  1. NEW BGPG,BGPT,BGPC,BGPLT,T,B,E,D,L,X,R,G,C,%
  1. K BGPG,BGPT,BGPC
  1. S BGPC=0
  1. S NORES=$G(NORES)
  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. ...I 'R S R=""
  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. 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 X="" Q
  1. ..S G=(9999999-D)_U_X
  1. ..Q
  1. I G="" D ;now get one with no result
  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 X="" Q
  1. ...S G=(9999999-D)_U_X
  1. ..Q
  1. ;
  1. I 'NORES,G]"" Q 1_U_G ;IF WANT A RESULT AND THERE IS ONE QUIT
  1. S %=$$CPT^BGP2DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP LDL CPTS",0)),5)
  1. I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,1),BGPC)="CPT "_$P(%,U,2)
  1. S %=$$TRAN^BGP2DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP LDL CPTS",0)),5)
  1. I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,1),BGPC)="CPT "_$P(%,U,2)
  1. I '$O(BGPT(0)) Q ""
  1. S %=$O(BGPT(0)) S C=$O(BGPT(%,0)) Q 1_"^"_(9999999-%)_"^"_BGPT(%,C)
  1. Q ""
  1. ;
  1. LOINC(A,B) ;EP
  1. NEW %
  1. S %=$P($G(^LAB(95.3,A,9999999)),U,2)
  1. I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
  1. S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
  1. I $D(^ATXAX(B,21,"B",%)) Q 1
  1. Q ""
  1. BPCPT(P,BDATE,EDATE) ;EP
  1. NEW G
  1. S G=$$CPTI^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("3077F"),"",30)
  1. I G Q $$DATE^BGP2UTL($P(G,U,2))_" CPT 3077F SYSTOLIC BP >=140 UNC^3"
  1. S G=$$CPTI^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("3080F"),"",30)
  1. I G Q $$DATE^BGP2UTL($P(G,U,2))_" CPT 3080F DIASTOLIC BP >=90 UNC^3"
  1. Q ""