BGP7D2 ; IHS/CMI/LAB - measure 1,2,3,4 ;
;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
;
I1 ;EP
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^BGP7UTL($P(BGPG(1),U))_" POV "_$P(BGPG(1),U,2)
Q
;
I3 ;EP
K BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPLHGB,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10
;I 'BGPDM1 S BGPSTOP=1 Q
DMGC ;EP - called from elder care
;v17, get new DM denominator for gpra dev
S BGPDMDEV=0
K BGPVALUD
;Active clinical
;2 visits during report period
;2 dm visits ever OR dm on problem list
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10)=0
I BGPACTCL,$$V2^BGP7D1(DFN,BGPBDATE,BGPEDATE),$$DMPVPL^BGP7D211(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE),$$DMFB^BGP7D211(DFN,$$FMADD^XLFDT(BGPBDATE,-1)) S BGPDMDEV=1
I 'BGPDM1,'BGPDMDEV S BGPSTOP=1 Q
S BGPLHGB=$$HGBA1C(DFN,BGPBDATE,BGPEDATE)
S BGPN1=$P(BGPLHGB,U)
I $P(BGPLHGB,U,4)["3046F" S BGPN8=1 G I31
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 ;>9
S BGPN9=0 I BGPN5!(BGPN6) S BGPN9=1
I31 S BGPXPHV=$P(BGPLHGB,U,4)
S BGPVALUE=$S(BGPDMD1:"UP",1:"")_$S(BGPDMD2:",AD",1:"")_$S(BGPDMD3:",AAD",1:"")_"||| " I $P(BGPLHGB,U,3)]"" S BGPVALUE=BGPVALUE_$$DATE^BGP7UTL($P(BGPLHGB,U,3))_$S($P(BGPLHGB,U,4)]"":" A1c: "_$P(BGPLHGB,U,4),1:" A1c: No Result")
I BGPDMDEV S BGPVALUD=$S(BGPDMDEV:"AD(DEV)",1:"")_"||| " I $P(BGPLHGB,U,3)]"" S BGPVALUD=BGPVALUD_$$DATE^BGP7UTL($P(BGPLHGB,U,3))_$S($P(BGPLHGB,U,4)]"":" A1c: "_$P(BGPLHGB,U,4),1:" A1c: No Result")
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,BGPD1,BGPD2)=0
I 'BGPDM1 S BGPSTOP=1 Q
S BGPVALUE="",BGPVALUD="",BGPBP=""
I BGPRTYPE'=5 I BGPDMD2,BGPAGEB<60 S BGPD1=1
I BGPRTYPE'=5 I BGPDMD2,BGPAGEB>59 S BGPD2=1
DMBP ;EP - called from elder care
S BGPVALUE=$$MEANBP(DFN,BGP365,BGPEDATE)
I BGPVALUE="" S BGPBP=$$BPCPT^BGP7D22(DFN,BGPBDATE,BGPEDATE) I BGPBP]"" S BGPN1=1 D G BPX
.S (BGPN2,BGPN4)=$S($P(BGPBP,U)=1:1,1:0),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)
S BGPN4=$S($P(BGPVALUE,U,2)=4:1,1:0)
I BGPN2 S BGPN4=1 ;IF <130/80 THEN ALSO IS <140/90
;
BPX ;
S BGPVALUD=$$MEANBPD(DFN,BGP365,BGPEDATE,1,BGPAGEB)
I BGPVALUD="" S BGPBP=$$BPCPT^BGP7D22(DFN,BGPBDATE,BGPEDATE,1) I BGPBP]"" D G BPX1
.S (BGPN5)=$S($P(BGPBP,U)=1:1,1:0),BGPVALUD=$P(BGPBP,U,2)_" "_$S(BGPN5:"CON",1:"UNC")
I $P(BGPVALUD,U,2)=4 S BGPN5=1
;
BPX1 ;
S BGPXPHV=$P(BGPVALUE,U,1),BGPXPHV=$P(BGPXPHV," ",1)
I $P(BGPVALUE,U,2)="" S BGPVALUE=""
S BGPVALUD="AD|||"_$P(BGPVALUD,U)
S BGPVALUE=$S(BGPDMD1:"UP"_$S(BGPDMD2:",AD",1:"")_$S(BGPDMD3:",AAD",1:""),1:"")_"|||"_$P(BGPVALUE,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 (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
I 'BGPDM1 S BGPSTOP=1 Q
DMLDL ;EP - called from elder
S BGPLDL=$$LDL(DFN,BGP365,BGPEDATE)
;
S BGPN2=$P(BGPLDL,U)
D CHKLDL
S BGPXPHV=$P(BGPLDL,U,3)
S BGPVALUE=$S(BGPDMD1:"UP",1:"")_$S(BGPDMD2:",AD",1:"")_$S(BGPDMD3:",AAD",1:"")_"|||"
;
I $P(BGPVALUE,"|||",2)]"" S BGPVALUE=BGPVALUE_" ; "
I BGPLDL]"" S BGPVALUE=BGPVALUE_"LDL: "_$$DATE^BGP7UTL($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)["G9271" S BGPN3=1,BGPN4=1,$P(BGPLDL,U,3)="CPT G9271 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)'>99 S BGPN4=1
I $P(BGPLDL,U,3)]"",$P(BGPLDL,U,3)>99,$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
NEW BGPG,BGPT,BGPC,T,BGPLT,E,D,B,L,X,J
K BGPG,BGPT
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))) D
....;SET RESULT DATE/TIME 999999 WITH TIME, IF BLANK SET VISIT DATE/TIME WITH IEN
....S %=$$VDTM^APCLV($P(^AUPNVLAB(X,0),U,3))
....S %=(9999999-$P(%,"."))_"."_(9999-$$RZERO^BGP7UTL($P(%,".",2),4)),%=+%
....S BGPC=BGPC+1,BGPT(%,X)=$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 %=$$VDTM^APCLV($P(^AUPNVLAB(X,0),U,3))
...S %=(9999999-$P(%,"."))_"."_+(9999-$$RZERO^BGP7UTL($P(%,".",2),4)),%=+%
...S BGPC=BGPC+1,BGPT(%,X)=$P(^AUPNVLAB(X,0),U,4) Q
...Q
S %="",E=+$$CODEN^ICPTCOD("3044F"),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 3044F"
S %="",E=+$$CODEN^ICPTCOD("3044F"),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT/TRAN 3044F"
S %="",E=+$$CODEN^ICPTCOD("3046F"),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 3046F"
S %="",E=+$$CODEN^ICPTCOD("3046F"),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT/TRAN 3046F"
; now got though and set return value of done 1 or 0^numerator 2-7^date^value
I '$D(BGPT) D HCPT Q %
S D=0,G="" F S D=$O(BGPT(D)) Q:D=""!(G]"") D
.S C=0 F S C=$O(BGPT(D,C)) Q:C="" 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 X["3046F" 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=$P(D,".")_U_X
;1=DONE W/OR W/O RESULT
;2 =>12
;3 >9 & <12
;4 =>8
;5 =>7, <8
;6 <7
I G="" S D=$O(BGPT(0)) S D=$P(D,".") Q 1_"^"_7_"^"_(9999999-D)
I $P(G,U,2)["3044F" Q 1_"^"_6_"^"_(9999999-$P(G,U))_"^"_$P(G,U,2)
I $P(G,U,2)["3046F" Q 1_"^"_3_"^"_(9999999-$P(G,U))_"^"_$P(G,U,2) ;V17.1
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 Q 1_"^"_3_"^"_(9999999-$P(G,U))_"^"_$P(G,U,2) ;V17.1 >9&<12
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^BGP7DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 83036"
S %="",E=+$$CODEN^ICPTCOD(83036),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT/TRAN 83036"
S %="",E=+$$CODEN^ICPTCOD(83037),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 83037"
S %="",E=+$$CODEN^ICPTCOD(83037),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT/TRAN 83037"
S %="",E=+$$CODEN^ICPTCOD("3045F"),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 3045F"
S %="",E=+$$CODEN^ICPTCOD("3045F"),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT/TRAN 3045F"
S %="",E=+$$CODEN^ICPTCOD("3046F"),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 3046F"
S %="",E=+$$CODEN^ICPTCOD("3046F"),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT/TRAN 3046F"
S %="",E=+$$CODEN^ICPTCOD("3047F"),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)="CPT 3047F"
S %="",E=+$$CODEN^ICPTCOD("3047F"),%=$$TRANI^BGP7DU(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
MEANBPD(P,BDATE,EDATE,GDEV,BGPAGEB) ;EP
NEW X,S,DS,A
S GDEV=$G(GDEV)
S BGPAGEB=$G(BGPAGEB)
S X=$$BPS(P,BDATE,EDATE,"I",GDEV)
S S=$$SYSMEAN(X) I S="" Q ""
S DS=$$DIAMEAN(X) I DS="" Q ""
S A=""
I BGPAGEB<60 D Q A
.I S<140&(DS<90) S A=S_"/"_DS_" CON"_U_4 Q
.S A=S_"/"_DS_" UNC"_U_3
I S<150&(DS<90) Q S_"/"_DS_" CON"_U_4
Q S_"/"_DS_" UNC"_U_3
;
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 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<1 Q "" ;1 BP 16.1
S T=0 F Y=1:1:3 S T=$P($P(X,";",Y),"/")+T
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<1 Q "" ;1 BP 16.1
S T=0 F Y=1:1:3 S T=$P($P(X,";",Y),"/",2)+T
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
I C=79 Q 1 ;V17.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
.Q:$$GDEV(V)
.Q:'$D(^AUPNVMSR("AD",V))
.;NOW GET ALL BPS
.S BGPBP=""
.S X=0 F S X=$O(^AUPNVMSR("AD",V,X)) Q:X'=+X D
..Q:'$D(^AUPNVMSR(X,0))
..S T=$P($G(^AUPNVMSR(X,0)),U)
..Q:T=""
..Q:$P($G(^AUTTMSR(T,0)),U)'="BP"
..Q:$P($G(^AUPNVMSR(X,2)),U,1)
..S Z=$P(^AUPNVMSR(X,0),U,4)
..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",Y),U))
.I F="I" S $P(BGPGV,";",BGPGLL)=$P(BGPBP," ")
K ^TMP($J,"BPV")
Q BGPGV
;
TRIG(P,BDATE,EDATE) ;EP
K BGPC
S BGPC=0
S %="",E=+$$CODEN^ICPTCOD(84478),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
I %]"" Q 1_U_$P(%,U,2)
S %="",E=+$$CODEN^ICPTCOD(84478),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
I %]"" Q 1_U_$P(%,U,2)
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
;
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^BGP7DU(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^BGP7DU(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 %=$$LASTDX^BGP7UTL1(P,"BGP LDL DXS",BDATE,EDATE)
I %]"" S BGPC=BGPC+1,BGPT((9999999-$P(%,U,3)),BGPC)="DX "_$P(%,U,2)
I '$O(BGPT(0)) Q ""
S %=$O(BGPT(0)) S C=$O(BGPT(%,0)) Q 1_"^"_(9999999-%)_"^"_$S(BGPT(%,C)]"":BGPT(%,C),1:"LAB NO RESULT")
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^BGP7DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("3077F"),"",30)
I G Q $$DATE^BGP7UTL($P(G,U,2))_" CPT 3077F SYSTOLIC BP >=140 UNC^3"
S G=$$CPTI^BGP7DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("3080F"),"",30)
I G Q $$DATE^BGP7UTL($P(G,U,2))_" CPT 3080F DIASTOLIC BP >=90 UNC^3"
Q ""
BGP7D2 ; IHS/CMI/LAB - measure 1,2,3,4 ;
+1 ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
+2 ;
I1 ;EP
+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^BGP7UTL($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,BGPN9,BGPN10
+2 ;I 'BGPDM1 S BGPSTOP=1 Q
DMGC ;EP - called from elder care
+1 ;v17, get new DM denominator for gpra dev
+2 SET BGPDMDEV=0
+3 KILL BGPVALUD
+4 ;Active clinical
+5 ;2 visits during report period
+6 ;2 dm visits ever OR dm on problem list
+7 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10)=0
+8 IF BGPACTCL
IF $$V2^BGP7D1(DFN,BGPBDATE,BGPEDATE)
IF $$DMPVPL^BGP7D211(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
IF $$DMFB^BGP7D211(DFN,$$FMADD^XLFDT(BGPBDATE,-1))
SET BGPDMDEV=1
+9 IF 'BGPDM1
IF 'BGPDMDEV
SET BGPSTOP=1
QUIT
+10 SET BGPLHGB=$$HGBA1C(DFN,BGPBDATE,BGPEDATE)
+11 SET BGPN1=$PIECE(BGPLHGB,U)
+12 IF $PIECE(BGPLHGB,U,4)["3046F"
SET BGPN8=1
GOTO I31
+13 SET BGPN2=$SELECT($PIECE(BGPLHGB,U,2)=2:1,1:0)
+14 SET BGPN3=$SELECT($PIECE(BGPLHGB,U,2)=3:1,1:0)
+15 SET BGPN4=$SELECT($PIECE(BGPLHGB,U,2)=4:1,1:0)
+16 SET BGPN5=$SELECT($PIECE(BGPLHGB,U,2)=5:1,1:0)
+17 SET BGPN6=$SELECT($PIECE(BGPLHGB,U,2)=6:1,1:0)
+18 SET BGPN7=$SELECT($PIECE(BGPLHGB,U,2)=7:1,1:0)
+19 ;>9
SET BGPN8=0
IF BGPN2!(BGPN3)
SET BGPN8=1
+20 SET BGPN9=0
IF BGPN5!(BGPN6)
SET BGPN9=1
I31 SET BGPXPHV=$PIECE(BGPLHGB,U,4)
+1 SET BGPVALUE=$SELECT(BGPDMD1:"UP",1:"")_$SELECT(BGPDMD2:",AD",1:"")_$SELECT(BGPDMD3:",AAD",1:"")_"||| "
IF $PIECE(BGPLHGB,U,3)]""
SET BGPVALUE=BGPVALUE_$$DATE^BGP7UTL($PIECE(BGPLHGB,U,3))_$SELECT($PIECE(BGPLHGB,U,4)]"":" A1c: "_$PIECE(BGPLHGB,U,4),1:" A1c: No Result")
+2 IF BGPDMDEV
SET BGPVALUD=$SELECT(BGPDMDEV:"AD(DEV)",1:"")_"||| "
IF $PIECE(BGPLHGB,U,3)]""
SET BGPVALUD=BGPVALUD_$$DATE^BGP7UTL($PIECE(BGPLHGB,U,3))_$SELECT($PIECE(BGPLHGB,U,4)]"":" A1c: "_$PIECE(BGPLHGB,U,4),1:" A1c: No Result")
+3 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,J,K,G,I,L,T,BGPLHGB
+4 QUIT
I4 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPD1,BGPD2)=0
+2 IF 'BGPDM1
SET BGPSTOP=1
QUIT
+3 SET BGPVALUE=""
SET BGPVALUD=""
SET BGPBP=""
+4 IF BGPRTYPE'=5
IF BGPDMD2
IF BGPAGEB<60
SET BGPD1=1
+5 IF BGPRTYPE'=5
IF BGPDMD2
IF BGPAGEB>59
SET BGPD2=1
DMBP ;EP - called from elder care
+1 SET BGPVALUE=$$MEANBP(DFN,BGP365,BGPEDATE)
+2 IF BGPVALUE=""
SET BGPBP=$$BPCPT^BGP7D22(DFN,BGPBDATE,BGPEDATE)
IF BGPBP]""
SET BGPN1=1
Begin DoDot:1
+3 SET (BGPN2,BGPN4)=$SELECT($PIECE(BGPBP,U)=1:1,1:0)
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)
+7 SET BGPN4=$SELECT($PIECE(BGPVALUE,U,2)=4:1,1:0)
+8 ;IF <130/80 THEN ALSO IS <140/90
IF BGPN2
SET BGPN4=1
+9 ;
BPX ;
+1 SET BGPVALUD=$$MEANBPD(DFN,BGP365,BGPEDATE,1,BGPAGEB)
+2 IF BGPVALUD=""
SET BGPBP=$$BPCPT^BGP7D22(DFN,BGPBDATE,BGPEDATE,1)
IF BGPBP]""
Begin DoDot:1
+3 SET (BGPN5)=$SELECT($PIECE(BGPBP,U)=1:1,1:0)
SET BGPVALUD=$PIECE(BGPBP,U,2)_" "_$SELECT(BGPN5:"CON",1:"UNC")
End DoDot:1
GOTO BPX1
+4 IF $PIECE(BGPVALUD,U,2)=4
SET BGPN5=1
+5 ;
BPX1 ;
+1 SET BGPXPHV=$PIECE(BGPVALUE,U,1)
SET BGPXPHV=$PIECE(BGPXPHV," ",1)
+2 IF $PIECE(BGPVALUE,U,2)=""
SET BGPVALUE=""
+3 SET BGPVALUD="AD|||"_$PIECE(BGPVALUD,U)
+4 SET BGPVALUE=$SELECT(BGPDMD1:"UP"_$SELECT(BGPDMD2:",AD",1:"")_$SELECT(BGPDMD3:",AAD",1:""),1:"")_"|||"_$PIECE(BGPVALUE,U)
+5 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F
+6 QUIT
+7 ;
I5 ;EP
+1 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPVALUE,BGPLD,BGPLDL,BGPTRI,BGPHDL
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
+3 IF 'BGPDM1
SET BGPSTOP=1
QUIT
DMLDL ;EP - called from elder
+1 SET BGPLDL=$$LDL(DFN,BGP365,BGPEDATE)
+2 ;
+3 SET BGPN2=$PIECE(BGPLDL,U)
+4 DO CHKLDL
+5 SET BGPXPHV=$PIECE(BGPLDL,U,3)
+6 SET BGPVALUE=$SELECT(BGPDMD1:"UP",1:"")_$SELECT(BGPDMD2:",AD",1:"")_$SELECT(BGPDMD3:",AAD",1:"")_"|||"
+7 ;
+8 IF $PIECE(BGPVALUE,"|||",2)]""
SET BGPVALUE=BGPVALUE_" ; "
+9 IF BGPLDL]""
SET BGPVALUE=BGPVALUE_"LDL: "_$$DATE^BGP7UTL($PIECE(BGPLDL,U,2))_" "_$PIECE(BGPLDL,U,3)
+10 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,BGPLDL,BGPHDL,BGPTRI,BGPLP
+11 QUIT
+12 ;
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)["G9271"
SET BGPN3=1
SET BGPN4=1
SET $PIECE(BGPLDL,U,3)="CPT G9271 LDL<100"
QUIT
+4 IF $PIECE(BGPLDL,U,3)]""
IF $PIECE(BGPLDL,U,3)["3049F"
SET BGPN3=1
SET $PIECE(BGPLDL,U,3)="CPT 3049F LDL <130"
QUIT
+5 IF $PIECE(BGPLDL,U,3)]""
IF $PIECE(BGPLDL,U,3)["CPT"
QUIT
+6 SET V=$PIECE(BGPLDL,U,3)
SET V=+V
+7 IF 'V
QUIT
+8 IF $PIECE(BGPLDL,U,3)]""
IF $PIECE(BGPLDL,U,3)'>99
SET BGPN4=1
+9 IF $PIECE(BGPLDL,U,3)]""
IF $PIECE(BGPLDL,U,3)>99
IF $PIECE(BGPLDL,U,3)<130
SET BGPN5=1
+10 IF $PIECE(BGPLDL,U,3)]""
IF $PIECE(BGPLDL,U,3)<130
SET BGPN3=1
+11 QUIT
HGBA1C(P,BDATE,EDATE) ;EP
+1 NEW BGPG,BGPT,BGPC,T,BGPLT,E,D,B,L,X,J
+2 KILL BGPG,BGPT
+3 SET BGPC=0
+4 ;now get all loinc/taxonomy tests
+5 SET T=$ORDER(^ATXAX("B","BGP HGBA1C LOINC CODES",0))
+6 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT HGB A1C TAX",0))
+7 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
+8 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+9 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+10 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+11 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
Begin DoDot:4
+12 ;SET RESULT DATE/TIME 999999 WITH TIME, IF BLANK SET VISIT DATE/TIME WITH IEN
+13 SET %=$$VDTM^APCLV($PIECE(^AUPNVLAB(X,0),U,3))
+14 SET %=(9999999-$PIECE(%,"."))_"."_(9999-$$RZERO^BGP7UTL($PIECE(%,".",2),4))
SET %=+%
+15 SET BGPC=BGPC+1
SET BGPT(%,X)=$PIECE(^AUPNVLAB(X,0),U,4)
QUIT
End DoDot:4
+16 IF 'T
QUIT
+17 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+18 IF '$$LOINC(J,T)
QUIT
+19 SET %=$$VDTM^APCLV($PIECE(^AUPNVLAB(X,0),U,3))
+20 SET %=(9999999-$PIECE(%,"."))_"."_+(9999-$$RZERO^BGP7UTL($PIECE(%,".",2),4))
SET %=+%
+21 SET BGPC=BGPC+1
SET BGPT(%,X)=$PIECE(^AUPNVLAB(X,0),U,4)
QUIT
+22 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+23 SET %=""
SET E=+$$CODEN^ICPTCOD("3044F")
SET %=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
+24 IF %]""
SET BGPC=BGPC+1
SET BGPT(9999999-$PIECE(%,U,2),BGPC)="CPT 3044F"
+25 SET %=""
SET E=+$$CODEN^ICPTCOD("3044F")
SET %=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
+26 IF %]""
SET BGPC=BGPC+1
SET BGPT(9999999-$PIECE(%,U,2),BGPC)="CPT/TRAN 3044F"
+27 SET %=""
SET E=+$$CODEN^ICPTCOD("3046F")
SET %=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
+28 IF %]""
SET BGPC=BGPC+1
SET BGPT(9999999-$PIECE(%,U,2),BGPC)="CPT 3046F"
+29 SET %=""
SET E=+$$CODEN^ICPTCOD("3046F")
SET %=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
+30 IF %]""
SET BGPC=BGPC+1
SET BGPT(9999999-$PIECE(%,U,2),BGPC)="CPT/TRAN 3046F"
+31 ; now got though and set return value of done 1 or 0^numerator 2-7^date^value
+32 IF '$DATA(BGPT)
DO HCPT
QUIT %
+33 SET D=0
SET G=""
FOR
SET D=$ORDER(BGPT(D))
IF D=""!(G]"")
QUIT
Begin DoDot:1
+34 SET C=0
FOR
SET C=$ORDER(BGPT(D,C))
IF C=""
QUIT
Begin DoDot:2
+35 SET X=BGPT(D,C)
+36 IF $$UP^XLFSTR(X)="COMMENT"
QUIT
+37 IF X=""
QUIT
+38 IF X["3044F"
SET G=D_U_X
QUIT
+39 IF X["3046F"
SET G=D_U_X
QUIT
+40 IF $EXTRACT(X)[">"
SET G=D_U_X
QUIT
+41 IF $EXTRACT(X)["<"
SET G=D_U_X
QUIT
+42 IF $EXTRACT(X)'=+$EXTRACT(X)
QUIT
+43 SET G=$PIECE(D,".")_U_X
End DoDot:2
End DoDot:1
+44 ;1=DONE W/OR W/O RESULT
+45 ;2 =>12
+46 ;3 >9 & <12
+47 ;4 =>8
+48 ;5 =>7, <8
+49 ;6 <7
+50 IF G=""
SET D=$ORDER(BGPT(0))
SET D=$PIECE(D,".")
QUIT 1_"^"_7_"^"_(9999999-D)
+51 IF $PIECE(G,U,2)["3044F"
QUIT 1_"^"_6_"^"_(9999999-$PIECE(G,U))_"^"_$PIECE(G,U,2)
+52 ;V17.1
IF $PIECE(G,U,2)["3046F"
QUIT 1_"^"_3_"^"_(9999999-$PIECE(G,U))_"^"_$PIECE(G,U,2)
+53 IF $EXTRACT($PIECE(G,U,2))=">"
QUIT 1_"^"_2_"^"_(9999999-$PIECE(G,U))_"^"_$PIECE(G,U,2)
+54 IF $EXTRACT($PIECE(G,U,2))="<"
QUIT 1_"^"_6_"^"_(9999999-$PIECE(G,U))_"^"_$PIECE(G,U,2)
+55 IF +($PIECE(G,U,2))'<12
QUIT 1_"^"_2_"^"_(9999999-$PIECE(G,U))_"^"_$PIECE(G,U,2)
+56 ;V17.1 >9&<12
IF +($PIECE(G,U,2))>9
QUIT 1_"^"_3_"^"_(9999999-$PIECE(G,U))_"^"_$PIECE(G,U,2)
+57 IF +($PIECE(G,U,2))'<8
QUIT 1_"^"_4_"^"_(9999999-$PIECE(G,U))_"^"_$PIECE(G,U,2)
+58 IF +($PIECE(G,U,2))'<7
QUIT 1_"^"_5_"^"_(9999999-$PIECE(G,U))_"^"_$PIECE(G,U,2)
+59 IF +($PIECE(G,U,2))=0
QUIT 1_"^"_7_"^"_(9999999-$PIECE(G,U))_"^"_$PIECE(G,U,2)
+60 QUIT 1_"^"_6_"^"_(9999999-$PIECE(G,U))_"^"_$PIECE(G,U,2)
+61 ;
HCPT ;
+1 SET %=""
+2 SET %=""
SET E=+$$CODEN^ICPTCOD(83036)
SET %=$$CPTI^BGP7DU(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^BGP7DU(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^BGP7DU(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^BGP7DU(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^BGP7DU(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^BGP7DU(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^BGP7DU(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^BGP7DU(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^BGP7DU(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^BGP7DU(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
MEANBPD(P,BDATE,EDATE,GDEV,BGPAGEB) ;EP
+1 NEW X,S,DS,A
+2 SET GDEV=$GET(GDEV)
+3 SET BGPAGEB=$GET(BGPAGEB)
+4 SET X=$$BPS(P,BDATE,EDATE,"I",GDEV)
+5 SET S=$$SYSMEAN(X)
IF S=""
QUIT ""
+6 SET DS=$$DIAMEAN(X)
IF DS=""
QUIT ""
+7 SET A=""
+8 IF BGPAGEB<60
Begin DoDot:1
+9 IF S<140&(DS<90)
SET A=S_"/"_DS_" CON"_U_4
QUIT
+10 SET A=S_"/"_DS_" UNC"_U_3
End DoDot:1
QUIT A
+11 IF S<150&(DS<90)
QUIT S_"/"_DS_" CON"_U_4
+12 QUIT S_"/"_DS_" UNC"_U_3
+13 ;
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 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 ;1 BP 16.1
IF C<1
QUIT ""
+5 SET T=0
FOR Y=1:1:3
SET T=$PIECE($PIECE(X,";",Y),"/")+T
+6 QUIT T\C
+7 ;
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 ;1 BP 16.1
IF C<1
QUIT ""
+5 SET T=0
FOR Y=1:1:3
SET T=$PIECE($PIECE(X,";",Y),"/",2)+T
+6 QUIT T\C
+7 ;
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 ;V17.1
IF C=79
QUIT 1
+13 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 IF $$CLINIC^APCLV(V,"C")=30
QUIT
+11 IF $$GDEV(V)
QUIT
+12 IF '$DATA(^AUPNVMSR("AD",V))
QUIT
+13 ;NOW GET ALL BPS
+14 SET BGPBP=""
+15 SET X=0
FOR
SET X=$ORDER(^AUPNVMSR("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:2
+16 IF '$DATA(^AUPNVMSR(X,0))
QUIT
+17 SET T=$PIECE($GET(^AUPNVMSR(X,0)),U)
+18 IF T=""
QUIT
+19 IF $PIECE($GET(^AUTTMSR(T,0)),U)'="BP"
QUIT
+20 IF $PIECE($GET(^AUPNVMSR(X,2)),U,1)
QUIT
+21 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",Y),U))
+27 IF F="I"
SET $PIECE(BGPGV,";",BGPGLL)=$PIECE(BGPBP," ")
End DoDot:1
+28 KILL ^TMP($JOB,"BPV")
+29 QUIT BGPGV
+30 ;
TRIG(P,BDATE,EDATE) ;EP
+1 KILL BGPC
+2 SET BGPC=0
+3 SET %=""
SET E=+$$CODEN^ICPTCOD(84478)
SET %=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
+4 IF %]""
QUIT 1_U_$PIECE(%,U,2)
+5 SET %=""
SET E=+$$CODEN^ICPTCOD(84478)
SET %=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
+6 IF %]""
QUIT 1_U_$PIECE(%,U,2)
+7 SET T=$ORDER(^ATXAX("B","BGP TRIGLYCERIDE LOINC CODES",0))
+8 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT TRIGLYCERIDE TAX",0))
+9 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
+10 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC)
QUIT
Begin DoDot:2
+11 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC)
QUIT
Begin DoDot:3
+12 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+13 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
+14 IF 'T
QUIT
+15 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+16 IF '$$LOINC(J,T)
QUIT
+17 SET R=$PIECE(^AUPNVLAB(X,0),U,4)
+18 SET BGPC=1_U_(9999999-D)
+19 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+20 QUIT BGPC
+21 ;
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^BGP7DU(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^BGP7DU(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 SET %=$$LASTDX^BGP7UTL1(P,"BGP LDL DXS",BDATE,EDATE)
+41 IF %]""
SET BGPC=BGPC+1
SET BGPT((9999999-$PIECE(%,U,3)),BGPC)="DX "_$PIECE(%,U,2)
+42 IF '$ORDER(BGPT(0))
QUIT ""
+43 SET %=$ORDER(BGPT(0))
SET C=$ORDER(BGPT(%,0))
QUIT 1_"^"_(9999999-%)_"^"_$SELECT(BGPT(%,C)]"":BGPT(%,C),1:"LAB NO RESULT")
+44 QUIT ""
+45 ;
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^BGP7DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("3077F"),"",30)
+3 IF G
QUIT $$DATE^BGP7UTL($PIECE(G,U,2))_" CPT 3077F SYSTOLIC BP >=140 UNC^3"
+4 SET G=$$CPTI^BGP7DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("3080F"),"",30)
+5 IF G
QUIT $$DATE^BGP7UTL($PIECE(G,U,2))_" CPT 3080F DIASTOLIC BP >=90 UNC^3"
+6 QUIT ""
