BGP4D41 ; IHS/CMI/LAB - measure 3 ;
;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
;
;IHS/CMI/LAB - patch 1 7-7-03 added HDL and Triglyceride check to 30-1
; - fixed IMM Refusal check for null reason
I0302A ;EP
S BGPHTN="",BGPIHD=""
I BGPAGEB<22 S BGPSTOP=1 Q
I 'BGPACTCL S BGPSTOP=1 Q ;must be active clinical
;S BGPIHD=$$IHDCCVD^BGP4D729(DFN,BGPBDATE,BGPEDATE)
S BGPCHD=0
S BGPCHD=$$CHD^BGP4D729(DFN,BGPBDATE,BGPEDATE)
I 'BGPCHD S BGPSTOP=1 Q ;CHD
I0302ASC ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6)=0
;I BGPIHD S BGPD1=1
;I BGPIHD,BGPDMD2 S BGPD3=1
;I BGPIHD,'BGPDMD2 S BGPD2=1
I $G(BGPCHD) S BGPD4=1
I $G(BGPCHD),BGPDMD2 S BGPD6=1
I $G(BGPCHD),'BGPDMD2 S BGPD5=1
S BGPBPC=""
S BGPBP=$$MEANBP(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE)
I BGPBP["unknown" S BGPBPC=$$BPCPT^BGP4D22(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE) I BGPBPC]"" S BGPBP=$P(BGPBPC,U,2)_"^1"
S BGPBPDEV=$$MEANBP(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE,1)
I BGPBPDEV["unknown" S BGPBPCD=$$BPCPT^BGP4D22(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE,1) I BGPBPCD]"" S BGPBPDEV=$P(BGPBPCD,U,2)_"^1"
S BGPN1=$S($P(BGPBP,U,2):1,1:0)
S BGPN16=$S($P(BGPBPDEV,U,2):1,1:0)
S BGPLDL=$$LDL^BGP4D2(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE,1) ;date^value
I $P(BGPLDL,U) S BGPN11=1 ;had ldl done
S BGPLDL1=$$LDL^BGP4D2(DFN,BGPBDATE,BGPEDATE,1) ;date^value
I $P(BGPLDL1,U) S BGPN2=1 ;had ldl done
S BGPTOB=$$TOBACCO(DFN,BGP365,BGPEDATE)
I $P(BGPTOB,U) S BGPN3=1
S BGPBMI=$$BMI^BGP4D6(DFN,BGPEDATE,BGPAGEE),BGPN4=$S(BGPBMI]"":1,1:0)
;S BGPBMIR="" I 'BGPN4 S BGPBMIR=$$REF^BGP4D6(DFN,BGPBDATE,BGPEDATE,BGPAGEE) I $P(BGPBMIR,U) S BGPN4=1,BGPN8=1,BGPBMIR=1_U_"BMI: Ref ht "_$$DATE^BGP4UTL($P(BGPBMIR,U,3))_" wt "_$$DATE^BGP4UTL($P(BGPBMIR,U,6))
S BGPLIFE=$$LIFE(DFN,BGP365,BGPEDATE),BGPN5=$S($P(BGPLIFE,U):1,1:0)
S BGPLIFED=$$LIFED(DFN,BGP365,BGPEDATE),BGPN15=$S($P(BGPLIFED,U):1,1:0)
S BGPDEP=$$DEP(DFN,BGP365,BGPEDATE),BGPN6=$S($P(BGPDEP,U):1,1:0)
;I 'BGPN6 S BGPDEP=$$DEPREF^BGP4D25(DFN,BGPBDATE,BGPEDATE) I BGPDEP S BGPN6=1
S BGPDEPS=$$DEPCHD(DFN,BGPBDATE,BGPEDATE),BGPN12=$S($P(BGPDEPS,U):1,1:0)
;I BGPN1,BGPN2,BGPN3,BGPN10,BGPN5,BGPN12 S BGPN13=1
I BGPN4,'BGPN8 S BGPN10=1
I BGPN1,BGPN2,BGPN3,BGPN4,BGPN5 S BGPN7=1
I BGPN1,BGPN11,BGPN3,BGPN10,BGPN5 S BGPN9=1 ;IHD GPRA
I BGPN16,BGPN2,BGPN3,BGPN10,BGPN15 S BGPN14=1 ;CHD GPRA
S BGPALL=0 I BGPN1,BGPN11,BGPN3,BGPN10,BGPN5,BGPN6 S BGPALL=1 ;IHD ALL
S BGPALL1=0 I BGPN16,BGPN2,BGPN3,BGPN10,BGPN15,BGPN12 S BGPALL1=1 ;CHD ALL
S BGPVALUE="CHD"_$S(BGPD6:",AD",1:"")
;S BGPVALUE=BGPVALUE_"|||"_$S(BGPN14:"GPRA DEV ",1:"")_$S(BGPALL1:"ALL ",1:"")_$S(BGPN16:"BP: "_$P($P(BGPBPDEV,U)," ",1,3),1:"")
S BGPVALUE=BGPVALUE_"|||"_$S(BGPN14:"ALL: ",1:"")_$S(BGPN16:"BP: "_$P(BGPBPDEV,U),1:"")
S %=$S($P(BGPLDL1,U,2):"LDL: "_$$DATE^BGP4UTL($P(BGPLDL1,U,2)),1:"")
I %]"" S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":";",1:"") S BGPVALUE=BGPVALUE_" "_%
S %="" I $P(BGPTOB,U) S %="TOB: "_$S($P(BGPTOB,U,3)["/":$P(BGPTOB,U,3),1:$$DATE^BGP4UTL($P(BGPTOB,U,3)))_" "_$P(BGPTOB,U,2)
I %]"" S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":";",1:"") S BGPVALUE=BGPVALUE_" "_%
I BGPN10 D
.S %=$S($P(BGPBMI,U)]"":"BMI: "_$J(BGPBMI,5,1),1:$P(BGPBMIR,U,2))
.I %]"" S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":";",1:"") S BGPVALUE=BGPVALUE_" "_%
S %=$S($P(BGPLIFED,U):"LIFE: "_$$DATE^BGP4UTL($P(BGPLIFED,U,2))_" "_$P(BGPLIFED,U,3),1:"")
I %]"" S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":";",1:"") S BGPVALUE=BGPVALUE_" "_%
S %=$S($P(BGPDEPS,U):"DEP: "_$P(BGPDEPS,U,2),1:"")
I %]"" S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":";",1:"") S BGPVALUE=BGPVALUE_" "_%
I $G(BGPIISO) Q
E K BGPBP,BGPLDL,BGPTOB,BGPBMI,BGPLIFE,BGPDEP,BGPDV
Q
I0302 ;EP
NEW BGPX
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
;I BGPAGEB<20 S BGPSTOP=1 Q ;no need to process
I BGPACTUP,BGPAGEB>17 S BGPD1=1
I BGPACTCL,BGPAGEB>17 S BGPD2=1
I BGPACTCL,$$CHD^BGP4D729(DFN,BGP365,BGPEDATE) S BGPIHD=1,BGPD3=1
I '(BGPD1+BGPD2+BGPD3) S BGPSTOP=1 Q ;not in any denominator
BPCV ;EP - called from elder care routine
S BGPVALUE=""
S BGPVALUE=$$MEANBP1(DFN,BGPBDATE,BGPEDATE,1)
I BGPVALUE["unknown" S BGPVALUE=$$BPCPT^BGP4D22(DFN,BGPBDATE,BGPEDATE) I BGPVALUE]"" S BGPN1=1,BGPVALUE=$P(BGPVALUE,U,2) G V ;CPTS COUNT IN NUMERATOR 1 ONLY
S BGPXPHV=$P(BGPVALUE,U,1),BGPXPHV=$P(BGPXPHV," ")
I 'BGPN1 S BGPN1=$S($P(BGPVALUE,U,2):1,1:0) ;any value 2-6
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)
S BGPN5=$S($P(BGPVALUE,U,2)=5:1,1:0)
S BGPN6=$S($P(BGPVALUE,U,2)=6:1,1:0)
V S BGPVALUE=$S(BGPD1:"UP",1:"")_$S(BGPD2:",AC",1:"")_$S(BGPD3:",CHD",1:"")_"|||"_$P(BGPVALUE,U)
Q
DEP(P,BDATE,EDATE) ;EP
S X=$$DEP^BGP4D25(P,BDATE,EDATE) I $P(X,U) Q X
S X=$$DEPSCR^BGP4D25(P,BDATE,EDATE) I $P(X,U) Q X
Q ""
DEPCHD(P,BDATE,EDATE) ;EP
S X=$$DEP^BGP4D25(P,BDATE,EDATE) I $P(X,U) Q X
S X=$$DEPSCR^BGP4D25(P,BDATE,EDATE) I $P(X,U) Q X
S X=$$DEPSUIC^BGP4D25(P,BDATE,EDATE) I $P(X,U) Q X
Q ""
LIFE(P,BDATE,EDATE) ;EP
S X=$$MEDNUTR^BGP4D711(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$SPECNUTR^BGP4D711(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$SPECEX^BGP4D711(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$OTHREL^BGP4D711(P,BDATE,EDATE) I X]"" Q 1_U_X
Q ""
LIFED(P,BDATE,EDATE) ;EP
S X=$$MEDNUTRD^BGP4D711(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$SPECNUTR^BGP4D711(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$SPECEX^BGP4D711(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$OTHREL^BGP4D711(P,BDATE,EDATE) I X]"" Q 1_U_X
Q ""
TOBACCO(P,BDATE,EDATE) ;EP
S X=$$TOBACCO^BGP4D7(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$TOBDX(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$PED^BGP4D7(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$DENT^BGP4D7(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$CPTSM^BGP4D7(P,BDATE,EDATE) I X]"" Q 1_U_X
Q ""
MEANBP(P,BDATE,EDATE,GDEV) ;EP
S GDEV=$G(GDEV)
S X=$$BPS(P,BDATE,EDATE,"I",GDEV)
S S=$$SYSMEAN(X) I S="" Q "unknown^^"
S DS=$$DIAMEAN(X) I DS="" Q "unknown^^"
I S>159!(DS>99) Q S_"/"_DS_" STG 2 HTN"_U_6
I S>139&(S<160)!(DS>89&(DS<100)) Q S_"/"_DS_" STG 1 HTN"_U_5
I S>129&(S<140)!(DS>80&(DS<90)) Q S_"/"_DS_" PRE HTN 2"_U_4
I S>119&(S<130)!(DS=80) Q S_"/"_DS_" PRE HTN 1"_U_3
I S<120&(DS<80) Q S_"/"_DS_" NORMAL"_U_2
Q ""
;
MEANBPD(P,BDATE,EDATE,GDEV,A) ;EP
NEW S,X,DS,Y
S GDEV=$G(GDEV)
S X=$$BPS(P,BDATE,EDATE,"I",GDEV)
S S=$$SYSMEAN(X) I S="" Q "unknown^^"
S DS=$$DIAMEAN(X) I DS="" Q "unknown^^"
I A<60 D Q Y
.I S<140&(DS<90) S Y=S_"/"_DS_" CON"_U_4
.S Y=S_"/"_DS_" UNC"_U_3
I S<150&(DS<90) Q S_"/"_DS_" CON"_U_4
Q S_"/"_DS_" UNC"_U_3
;
SYSMEAN(X) ;EP
I X="" Q ""
S C=0 F Y=1:1:3 I $P(X,";",Y)]"" S C=C+1
I C<2 Q ""
S T=0 F Y=1:1:3 S T=$P($P(X,";",Y),"/")+T
Q T\C
;Q $$STRIP^XLFSTR($J((T/C),5,1)," ")
;
DIAMEAN(X) ;EP
I X="" Q ""
S C=0 F Y=1:1:3 I $P(X,";",Y)]"" S C=C+1
I C<2 Q ""
S T=0 F Y=1:1:3 S T=$P($P(X,";",Y),"/",2)+T
Q T\C
;Q $$STRIP^XLFSTR($J((T/C),5,1)," ")
;
BPS(P,BDATE,EDATE,F,GDEV) ;EP ;
I $G(F)="" S F="E"
S GDEV=$G(GDEV)
NEW BGPGLL,BGPGV,BGPG,X,Y,BGPBP,V,T,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 X=P_"^LAST 50 MEAS BP;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")
;S BGPGL=0 F S BGPGL=$O(BGPG(BGPGL)) Q:BGPGL'=+BGPGL!(BGPGLL=3) S BGPGBP=$P($G(BGPG(BGPGL)),U,2) D
S Y=0 F S Y=$O(^TMP($J,"BPV",Y)) Q:Y'=+Y!(BGPGLL=3) D
.S V=$P(^TMP($J,"BPV",Y),U,5)
.Q:$$CLINIC^APCLV(V,"C")=30 ;NO ER CLINIC VISITS COUNTED
.I $G(GDEV) Q:$$GDEV^BGP4D2(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
..Q:$P($G(^AUPNVMSR(X,2)),U,1)
..S T=$P($G(^AUPNVMSR(X,0)),U)
..Q:T="" ;BAD AD XREF
..Q:$P($G(^AUTTMSR(T,0)),U)'="BP" ;not a BP measurement type
..S Z=$P(^AUPNVMSR(X,0),U,4) ;blood pressure value
..I BGPBP="" S BGPBP=Z Q
..I $P(Z,"/")'>$P(BGPBP,"/") S BGPBP=Z
.Q:BGPBP=""
.S BGPGLL=BGPGLL+1
.I F="E" S $P(BGPGV,";",BGPGLL)=BGPBP_" "_$$FMTE^XLFDT($P(^TMP($J,"BPV",V),U))
.I F="I" S $P(BGPGV,";",BGPGLL)=$P(BGPBP," ")
K ^TMP($J,"BPV")
Q BGPGV
TOBDX(P,BDATE,EDATE) ;EP
K BGPG
S X=P_"^LAST DX [BGP TOBACCO DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)) Q $P(BGPG(1),U,2)_U_$P(BGPG(1),U)
;S X=P_"^LAST DX V15.82;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")
;I $D(BGPG(1)) Q $P(BGPG(1),U,2)_U_$P(BGPG(1),U)
S X=0,G="" F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G]"") D
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.Q:$P(^AUPNPROB(X,0),U,3)>EDATE
.Q:$P(^AUPNPROB(X,0),U,3)<BDATE
.S Y=$P(^AUPNPROB(X,0),U)
.I $E($P($$ICDDX^BGP4UTL2(Y),U,2),1,5)'="305.1",$P($$ICDDX^BGP4UTL2(Y),U,2)'="V15.82" Q
.S G=$P($$ICDDX^BGP4UTL2(Y),U,2)_" PL"
.Q
Q G
MEANBP1(P,BDATE,EDATE,GDEV) ;EP
S GDEV=$G(GDEV)
S X=$$BPS(P,BDATE,EDATE,"I",GDEV)
S S=$$SYSMEAN1(X) I S="" Q "unknown^^"
S DS=$$DIAMEAN1(X) I DS="" Q "unknown^^"
I S>159!(DS>99) Q S_"/"_DS_" STG 2 HTN"_U_6
I S>139&(S<160)!(DS>89&(DS<100)) Q S_"/"_DS_" STG 1 HTN"_U_5
I S>129&(S<140)!(DS>80&(DS<90)) Q S_"/"_DS_" PRE HTN 2"_U_4
I S>119&(S<130)!(DS=80) Q S_"/"_DS_" PRE HTN 1"_U_3
I S<120&(DS<80) Q S_"/"_DS_" NORMAL"_U_2
Q ""
;
SYSMEAN1(X) ;EP
I X="" Q ""
S C=0 F Y=1:1:3 I $P(X,";",Y)]"" S C=C+1
I C<1 Q ""
S T=0 F Y=1:1:3 S T=$P($P(X,";",Y),"/")+T
Q T\C
;Q $$STRIP^XLFSTR($J((T/C),5,1)," ")
;
DIAMEAN1(X) ;EP
I X="" Q ""
S C=0 F Y=1:1:3 I $P(X,";",Y)]"" S C=C+1
I C<1 Q ""
S T=0 F Y=1:1:3 S T=$P($P(X,";",Y),"/",2)+T
Q T\C
;Q $$STRIP^XLFSTR($J((T/C),5,1)," ")
;
BGP4D41 ; IHS/CMI/LAB - measure 3 ;
+1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
+2 ;
+3 ;IHS/CMI/LAB - patch 1 7-7-03 added HDL and Triglyceride check to 30-1
+4 ; - fixed IMM Refusal check for null reason
I0302A ;EP
+1 SET BGPHTN=""
SET BGPIHD=""
+2 IF BGPAGEB<22
SET BGPSTOP=1
QUIT
+3 ;must be active clinical
IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+4 ;S BGPIHD=$$IHDCCVD^BGP4D729(DFN,BGPBDATE,BGPEDATE)
+5 SET BGPCHD=0
+6 SET BGPCHD=$$CHD^BGP4D729(DFN,BGPBDATE,BGPEDATE)
+7 ;CHD
IF 'BGPCHD
SET BGPSTOP=1
QUIT
I0302ASC ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6)=0
+2 ;I BGPIHD S BGPD1=1
+3 ;I BGPIHD,BGPDMD2 S BGPD3=1
+4 ;I BGPIHD,'BGPDMD2 S BGPD2=1
+5 IF $GET(BGPCHD)
SET BGPD4=1
+6 IF $GET(BGPCHD)
IF BGPDMD2
SET BGPD6=1
+7 IF $GET(BGPCHD)
IF 'BGPDMD2
SET BGPD5=1
+8 SET BGPBPC=""
+9 SET BGPBP=$$MEANBP(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE)
+10 IF BGPBP["unknown"
SET BGPBPC=$$BPCPT^BGP4D22(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE)
IF BGPBPC]""
SET BGPBP=$PIECE(BGPBPC,U,2)_"^1"
+11 SET BGPBPDEV=$$MEANBP(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE,1)
+12 IF BGPBPDEV["unknown"
SET BGPBPCD=$$BPCPT^BGP4D22(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE,1)
IF BGPBPCD]""
SET BGPBPDEV=$PIECE(BGPBPCD,U,2)_"^1"
+13 SET BGPN1=$SELECT($PIECE(BGPBP,U,2):1,1:0)
+14 SET BGPN16=$SELECT($PIECE(BGPBPDEV,U,2):1,1:0)
+15 ;date^value
SET BGPLDL=$$LDL^BGP4D2(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE,1)
+16 ;had ldl done
IF $PIECE(BGPLDL,U)
SET BGPN11=1
+17 ;date^value
SET BGPLDL1=$$LDL^BGP4D2(DFN,BGPBDATE,BGPEDATE,1)
+18 ;had ldl done
IF $PIECE(BGPLDL1,U)
SET BGPN2=1
+19 SET BGPTOB=$$TOBACCO(DFN,BGP365,BGPEDATE)
+20 IF $PIECE(BGPTOB,U)
SET BGPN3=1
+21 SET BGPBMI=$$BMI^BGP4D6(DFN,BGPEDATE,BGPAGEE)
SET BGPN4=$SELECT(BGPBMI]"":1,1:0)
+22 ;S BGPBMIR="" I 'BGPN4 S BGPBMIR=$$REF^BGP4D6(DFN,BGPBDATE,BGPEDATE,BGPAGEE) I $P(BGPBMIR,U) S BGPN4=1,BGPN8=1,BGPBMIR=1_U_"BMI: Ref ht "_$$DATE^BGP4UTL($P(BGPBMIR,U,3))_" wt "_$$DATE^BGP4UTL($P(BGPBMIR,U,6))
+23 SET BGPLIFE=$$LIFE(DFN,BGP365,BGPEDATE)
SET BGPN5=$SELECT($PIECE(BGPLIFE,U):1,1:0)
+24 SET BGPLIFED=$$LIFED(DFN,BGP365,BGPEDATE)
SET BGPN15=$SELECT($PIECE(BGPLIFED,U):1,1:0)
+25 SET BGPDEP=$$DEP(DFN,BGP365,BGPEDATE)
SET BGPN6=$SELECT($PIECE(BGPDEP,U):1,1:0)
+26 ;I 'BGPN6 S BGPDEP=$$DEPREF^BGP4D25(DFN,BGPBDATE,BGPEDATE) I BGPDEP S BGPN6=1
+27 SET BGPDEPS=$$DEPCHD(DFN,BGPBDATE,BGPEDATE)
SET BGPN12=$SELECT($PIECE(BGPDEPS,U):1,1:0)
+28 ;I BGPN1,BGPN2,BGPN3,BGPN10,BGPN5,BGPN12 S BGPN13=1
+29 IF BGPN4
IF 'BGPN8
SET BGPN10=1
+30 IF BGPN1
IF BGPN2
IF BGPN3
IF BGPN4
IF BGPN5
SET BGPN7=1
+31 ;IHD GPRA
IF BGPN1
IF BGPN11
IF BGPN3
IF BGPN10
IF BGPN5
SET BGPN9=1
+32 ;CHD GPRA
IF BGPN16
IF BGPN2
IF BGPN3
IF BGPN10
IF BGPN15
SET BGPN14=1
+33 ;IHD ALL
SET BGPALL=0
IF BGPN1
IF BGPN11
IF BGPN3
IF BGPN10
IF BGPN5
IF BGPN6
SET BGPALL=1
+34 ;CHD ALL
SET BGPALL1=0
IF BGPN16
IF BGPN2
IF BGPN3
IF BGPN10
IF BGPN15
IF BGPN12
SET BGPALL1=1
+35 SET BGPVALUE="CHD"_$SELECT(BGPD6:",AD",1:"")
+36 ;S BGPVALUE=BGPVALUE_"|||"_$S(BGPN14:"GPRA DEV ",1:"")_$S(BGPALL1:"ALL ",1:"")_$S(BGPN16:"BP: "_$P($P(BGPBPDEV,U)," ",1,3),1:"")
+37 SET BGPVALUE=BGPVALUE_"|||"_$SELECT(BGPN14:"ALL: ",1:"")_$SELECT(BGPN16:"BP: "_$PIECE(BGPBPDEV,U),1:"")
+38 SET %=$SELECT($PIECE(BGPLDL1,U,2):"LDL: "_$$DATE^BGP4UTL($PIECE(BGPLDL1,U,2)),1:"")
+39 IF %]""
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":";",1:"")
SET BGPVALUE=BGPVALUE_" "_%
+40 SET %=""
IF $PIECE(BGPTOB,U)
SET %="TOB: "_$SELECT($PIECE(BGPTOB,U,3)["/":$PIECE(BGPTOB,U,3),1:$$DATE^BGP4UTL($PIECE(BGPTOB,U,3)))_" "_$PIECE(BGPTOB,U,2)
+41 IF %]""
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":";",1:"")
SET BGPVALUE=BGPVALUE_" "_%
+42 IF BGPN10
Begin DoDot:1
+43 SET %=$SELECT($PIECE(BGPBMI,U)]"":"BMI: "_$JUSTIFY(BGPBMI,5,1),1:$PIECE(BGPBMIR,U,2))
+44 IF %]""
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":";",1:"")
SET BGPVALUE=BGPVALUE_" "_%
End DoDot:1
+45 SET %=$SELECT($PIECE(BGPLIFED,U):"LIFE: "_$$DATE^BGP4UTL($PIECE(BGPLIFED,U,2))_" "_$PIECE(BGPLIFED,U,3),1:"")
+46 IF %]""
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":";",1:"")
SET BGPVALUE=BGPVALUE_" "_%
+47 SET %=$SELECT($PIECE(BGPDEPS,U):"DEP: "_$PIECE(BGPDEPS,U,2),1:"")
+48 IF %]""
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":";",1:"")
SET BGPVALUE=BGPVALUE_" "_%
+49 IF $GET(BGPIISO)
QUIT
E KILL BGPBP,BGPLDL,BGPTOB,BGPBMI,BGPLIFE,BGPDEP,BGPDV
+1 QUIT
I0302 ;EP
+1 NEW BGPX
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
+3 ;I BGPAGEB<20 S BGPSTOP=1 Q ;no need to process
+4 IF BGPACTUP
IF BGPAGEB>17
SET BGPD1=1
+5 IF BGPACTCL
IF BGPAGEB>17
SET BGPD2=1
+6 IF BGPACTCL
IF $$CHD^BGP4D729(DFN,BGP365,BGPEDATE)
SET BGPIHD=1
SET BGPD3=1
+7 ;not in any denominator
IF '(BGPD1+BGPD2+BGPD3)
SET BGPSTOP=1
QUIT
BPCV ;EP - called from elder care routine
+1 SET BGPVALUE=""
+2 SET BGPVALUE=$$MEANBP1(DFN,BGPBDATE,BGPEDATE,1)
+3 ;CPTS COUNT IN NUMERATOR 1 ONLY
IF BGPVALUE["unknown"
SET BGPVALUE=$$BPCPT^BGP4D22(DFN,BGPBDATE,BGPEDATE)
IF BGPVALUE]""
SET BGPN1=1
SET BGPVALUE=$PIECE(BGPVALUE,U,2)
GOTO V
+4 SET BGPXPHV=$PIECE(BGPVALUE,U,1)
SET BGPXPHV=$PIECE(BGPXPHV," ")
+5 ;any value 2-6
IF 'BGPN1
SET BGPN1=$SELECT($PIECE(BGPVALUE,U,2):1,1:0)
+6 SET BGPN2=$SELECT($PIECE(BGPVALUE,U,2)=2:1,1:0)
+7 SET BGPN3=$SELECT($PIECE(BGPVALUE,U,2)=3:1,1:0)
+8 SET BGPN4=$SELECT($PIECE(BGPVALUE,U,2)=4:1,1:0)
+9 SET BGPN5=$SELECT($PIECE(BGPVALUE,U,2)=5:1,1:0)
+10 SET BGPN6=$SELECT($PIECE(BGPVALUE,U,2)=6:1,1:0)
V SET BGPVALUE=$SELECT(BGPD1:"UP",1:"")_$SELECT(BGPD2:",AC",1:"")_$SELECT(BGPD3:",CHD",1:"")_"|||"_$PIECE(BGPVALUE,U)
+1 QUIT
DEP(P,BDATE,EDATE) ;EP
+1 SET X=$$DEP^BGP4D25(P,BDATE,EDATE)
IF $PIECE(X,U)
QUIT X
+2 SET X=$$DEPSCR^BGP4D25(P,BDATE,EDATE)
IF $PIECE(X,U)
QUIT X
+3 QUIT ""
DEPCHD(P,BDATE,EDATE) ;EP
+1 SET X=$$DEP^BGP4D25(P,BDATE,EDATE)
IF $PIECE(X,U)
QUIT X
+2 SET X=$$DEPSCR^BGP4D25(P,BDATE,EDATE)
IF $PIECE(X,U)
QUIT X
+3 SET X=$$DEPSUIC^BGP4D25(P,BDATE,EDATE)
IF $PIECE(X,U)
QUIT X
+4 QUIT ""
LIFE(P,BDATE,EDATE) ;EP
+1 SET X=$$MEDNUTR^BGP4D711(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+2 SET X=$$SPECNUTR^BGP4D711(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+3 SET X=$$SPECEX^BGP4D711(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+4 SET X=$$OTHREL^BGP4D711(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+5 QUIT ""
LIFED(P,BDATE,EDATE) ;EP
+1 SET X=$$MEDNUTRD^BGP4D711(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+2 SET X=$$SPECNUTR^BGP4D711(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+3 SET X=$$SPECEX^BGP4D711(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+4 SET X=$$OTHREL^BGP4D711(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+5 QUIT ""
TOBACCO(P,BDATE,EDATE) ;EP
+1 SET X=$$TOBACCO^BGP4D7(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+2 SET X=$$TOBDX(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+3 SET X=$$PED^BGP4D7(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+4 SET X=$$DENT^BGP4D7(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+5 SET X=$$CPTSM^BGP4D7(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+6 QUIT ""
MEANBP(P,BDATE,EDATE,GDEV) ;EP
+1 SET GDEV=$GET(GDEV)
+2 SET X=$$BPS(P,BDATE,EDATE,"I",GDEV)
+3 SET S=$$SYSMEAN(X)
IF S=""
QUIT "unknown^^"
+4 SET DS=$$DIAMEAN(X)
IF DS=""
QUIT "unknown^^"
+5 IF S>159!(DS>99)
QUIT S_"/"_DS_" STG 2 HTN"_U_6
+6 IF S>139&(S<160)!(DS>89&(DS<100))
QUIT S_"/"_DS_" STG 1 HTN"_U_5
+7 IF S>129&(S<140)!(DS>80&(DS<90))
QUIT S_"/"_DS_" PRE HTN 2"_U_4
+8 IF S>119&(S<130)!(DS=80)
QUIT S_"/"_DS_" PRE HTN 1"_U_3
+9 IF S<120&(DS<80)
QUIT S_"/"_DS_" NORMAL"_U_2
+10 QUIT ""
+11 ;
MEANBPD(P,BDATE,EDATE,GDEV,A) ;EP
+1 NEW S,X,DS,Y
+2 SET GDEV=$GET(GDEV)
+3 SET X=$$BPS(P,BDATE,EDATE,"I",GDEV)
+4 SET S=$$SYSMEAN(X)
IF S=""
QUIT "unknown^^"
+5 SET DS=$$DIAMEAN(X)
IF DS=""
QUIT "unknown^^"
+6 IF A<60
Begin DoDot:1
+7 IF S<140&(DS<90)
SET Y=S_"/"_DS_" CON"_U_4
+8 SET Y=S_"/"_DS_" UNC"_U_3
End DoDot:1
QUIT Y
+9 IF S<150&(DS<90)
QUIT S_"/"_DS_" CON"_U_4
+10 QUIT S_"/"_DS_" UNC"_U_3
+11 ;
SYSMEAN(X) ;EP
+1 IF X=""
QUIT ""
+2 SET C=0
FOR Y=1:1:3
IF $PIECE(X,";",Y)]""
SET C=C+1
+3 IF C<2
QUIT ""
+4 SET T=0
FOR Y=1:1:3
SET T=$PIECE($PIECE(X,";",Y),"/")+T
+5 QUIT T\C
+6 ;Q $$STRIP^XLFSTR($J((T/C),5,1)," ")
+7 ;
DIAMEAN(X) ;EP
+1 IF X=""
QUIT ""
+2 SET C=0
FOR Y=1:1:3
IF $PIECE(X,";",Y)]""
SET C=C+1
+3 IF C<2
QUIT ""
+4 SET T=0
FOR Y=1:1:3
SET T=$PIECE($PIECE(X,";",Y),"/",2)+T
+5 QUIT T\C
+6 ;Q $$STRIP^XLFSTR($J((T/C),5,1)," ")
+7 ;
BPS(P,BDATE,EDATE,F,GDEV) ;EP ;
+1 IF $GET(F)=""
SET F="E"
+2 SET GDEV=$GET(GDEV)
+3 NEW BGPGLL,BGPGV,BGPG,X,Y,BGPBP,V,T,Z
+4 SET BGPGLL=0
SET BGPGV=""
+5 KILL BGPG
+6 KILL ^TMP($JOB,"BPV")
+7 SET A="^TMP($J,""BPV"","
SET B=P_"^LAST 365 VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+8 IF '$DATA(^TMP($JOB,"BPV",1))
QUIT ""
+9 ;S X=P_"^LAST 50 MEAS BP;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")
+10 ;S BGPGL=0 F S BGPGL=$O(BGPG(BGPGL)) Q:BGPGL'=+BGPGL!(BGPGLL=3) S BGPGBP=$P($G(BGPG(BGPGL)),U,2) D
+11 SET Y=0
FOR
SET Y=$ORDER(^TMP($JOB,"BPV",Y))
IF Y'=+Y!(BGPGLL=3)
QUIT
Begin DoDot:1
+12 SET V=$PIECE(^TMP($JOB,"BPV",Y),U,5)
+13 ;NO ER CLINIC VISITS COUNTED
IF $$CLINIC^APCLV(V,"C")=30
QUIT
+14 IF $GET(GDEV)
IF $$GDEV^BGP4D2(V)
QUIT
+15 ;no measurements to look at
IF '$DATA(^AUPNVMSR("AD",V))
QUIT
+16 ;NOW GET ALL BPS ON THIS VISIT
+17 SET BGPBP=""
+18 SET X=0
FOR
SET X=$ORDER(^AUPNVMSR("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:2
+19 ;BAD AD XREF
IF '$DATA(^AUPNVMSR(X,0))
QUIT
+20 IF $PIECE($GET(^AUPNVMSR(X,2)),U,1)
QUIT
+21 SET T=$PIECE($GET(^AUPNVMSR(X,0)),U)
+22 ;BAD AD XREF
IF T=""
QUIT
+23 ;not a BP measurement type
IF $PIECE($GET(^AUTTMSR(T,0)),U)'="BP"
QUIT
+24 ;blood pressure value
SET Z=$PIECE(^AUPNVMSR(X,0),U,4)
+25 IF BGPBP=""
SET BGPBP=Z
QUIT
+26 IF $PIECE(Z,"/")'>$PIECE(BGPBP,"/")
SET BGPBP=Z
End DoDot:2
+27 IF BGPBP=""
QUIT
+28 SET BGPGLL=BGPGLL+1
+29 IF F="E"
SET $PIECE(BGPGV,";",BGPGLL)=BGPBP_" "_$$FMTE^XLFDT($PIECE(^TMP($JOB,"BPV",V),U))
+30 IF F="I"
SET $PIECE(BGPGV,";",BGPGLL)=$PIECE(BGPBP," ")
End DoDot:1
+31 KILL ^TMP($JOB,"BPV")
+32 QUIT BGPGV
TOBDX(P,BDATE,EDATE) ;EP
+1 KILL BGPG
+2 SET X=P_"^LAST DX [BGP TOBACCO DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,"BGPG(")
+3 IF $DATA(BGPG(1))
QUIT $PIECE(BGPG(1),U,2)_U_$PIECE(BGPG(1),U)
+4 ;S X=P_"^LAST DX V15.82;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")
+5 ;I $D(BGPG(1)) Q $P(BGPG(1),U,2)_U_$P(BGPG(1),U)
+6 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+7 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+8 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+9 IF $PIECE(^AUPNPROB(X,0),U,3)>EDATE
QUIT
+10 IF $PIECE(^AUPNPROB(X,0),U,3)<BDATE
QUIT
+11 SET Y=$PIECE(^AUPNPROB(X,0),U)
+12 IF $EXTRACT($PIECE($$ICDDX^BGP4UTL2(Y),U,2),1,5)'="305.1"
IF $PIECE($$ICDDX^BGP4UTL2(Y),U,2)'="V15.82"
QUIT
+13 SET G=$PIECE($$ICDDX^BGP4UTL2(Y),U,2)_" PL"
+14 QUIT
End DoDot:1
+15 QUIT G
MEANBP1(P,BDATE,EDATE,GDEV) ;EP
+1 SET GDEV=$GET(GDEV)
+2 SET X=$$BPS(P,BDATE,EDATE,"I",GDEV)
+3 SET S=$$SYSMEAN1(X)
IF S=""
QUIT "unknown^^"
+4 SET DS=$$DIAMEAN1(X)
IF DS=""
QUIT "unknown^^"
+5 IF S>159!(DS>99)
QUIT S_"/"_DS_" STG 2 HTN"_U_6
+6 IF S>139&(S<160)!(DS>89&(DS<100))
QUIT S_"/"_DS_" STG 1 HTN"_U_5
+7 IF S>129&(S<140)!(DS>80&(DS<90))
QUIT S_"/"_DS_" PRE HTN 2"_U_4
+8 IF S>119&(S<130)!(DS=80)
QUIT S_"/"_DS_" PRE HTN 1"_U_3
+9 IF S<120&(DS<80)
QUIT S_"/"_DS_" NORMAL"_U_2
+10 QUIT ""
+11 ;
SYSMEAN1(X) ;EP
+1 IF X=""
QUIT ""
+2 SET C=0
FOR Y=1:1:3
IF $PIECE(X,";",Y)]""
SET C=C+1
+3 IF C<1
QUIT ""
+4 SET T=0
FOR Y=1:1:3
SET T=$PIECE($PIECE(X,";",Y),"/")+T
+5 QUIT T\C
+6 ;Q $$STRIP^XLFSTR($J((T/C),5,1)," ")
+7 ;
DIAMEAN1(X) ;EP
+1 IF X=""
QUIT ""
+2 SET C=0
FOR Y=1:1:3
IF $PIECE(X,";",Y)]""
SET C=C+1
+3 IF C<1
QUIT ""
+4 SET T=0
FOR Y=1:1:3
SET T=$PIECE($PIECE(X,";",Y),"/",2)+T
+5 QUIT T\C
+6 ;Q $$STRIP^XLFSTR($J((T/C),5,1)," ")
+7 ;
