BGP2D41.m

BGP2D41 ; IHS/CMI/LAB - measure 3 ;

 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66

 ;

 ;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^BGP2D729(DFN,BGPBDATE,BGPEDATE)

 S BGPCHD=0

 I BGPRTYPE'=4 S BGPCHD=$$CHD^BGP2D729(DFN,BGPBDATE,BGPEDATE)

 I 'BGPIHD,'BGPCHD S BGPSTOP=1 Q  ;no IHD or 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^BGP2D22(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^BGP2D22(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^BGP2D2(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE,1) ;date^value

 I $P(BGPLDL,U) S BGPN11=1  ;had ldl done

 S BGPLDL1=$$LDL^BGP2D2(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^BGP2D6(DFN,BGPEDATE,BGPAGEE),BGPN4=$S(BGPBMI]"":1,1:0)

 S BGPBMIR="" I 'BGPN4 S BGPBMIR=$$REF^BGP2D6(DFN,BGPBDATE,BGPEDATE,BGPAGEE) I $P(BGPBMIR,U) S BGPN4=1,BGPN8=1,BGPBMIR=1_U_"BMI: Ref ht "_$$DATE^BGP2UTL($P(BGPBMIR,U,3))_" wt "_$$DATE^BGP2UTL($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^BGP2D25(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 BGPDV="IHD"_$S(BGPD3:",AD",1:"")

 ;S BGPVALUE=BGPDV_"|||"_$S(BGPN9:"GPRA ",1:"")_$S(BGPALL:"ALL  ",1:"")_$S(BGPN1:"BP: "_$P($P(BGPBP,U)," ",1,3),1:"")

 S BGPVALUE=BGPDV_"|||"_$S(BGPN9:"ALL: ",1:"")

 S %="" S BGPVALUE=BGPVALUE_$S(BGPN1:"BP: "_$P(BGPBP,U),1:"")

 S %=$S($P(BGPLDL,U,2):"LDL: "_$$DATE^BGP2UTL($P(BGPLDL,U,2))_" "_$P(BGPLDL,U,3),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^BGP2UTL($P(BGPTOB,U,3)))_" "_$P(BGPTOB,U,2)

 I %]"" S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":";",1:"") S BGPVALUE=BGPVALUE_" "_%

 S %=$S($P(BGPBMI,U)]"":"BMI: "_$$STRIP^XLFSTR($J(BGPBMI,5,1)," "),1:$S(BGPRTYPE'=1:$P(BGPBMIR,U,2),1:""))

 I %]"" S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":";",1:"") S BGPVALUE=BGPVALUE_" "_%

 S %=$S($P(BGPLIFE,U):"LIFE: "_$$DATE^BGP2UTL($P(BGPLIFE,U,2))_" "_$P(BGPLIFE,U,3),1:"")

 I %]"" S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":";",1:"") S BGPVALUE=BGPVALUE_" "_%

 S %=$S($P(BGPDEP,U):"DEP: "_$P(BGPDEP,U,2),1:"")

 I %]"" S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":";",1:"") S BGPVALUE=BGPVALUE_" "_%

 S BGPVALUD="CHD"_$S(BGPD6:",AD",1:"")

 ;S BGPVALUD=BGPVALUD_"|||"_$S(BGPN14:"GPRA DEV  ",1:"")_$S(BGPALL1:"ALL  ",1:"")_$S(BGPN16:"BP: "_$P($P(BGPBPDEV,U)," ",1,3),1:"")

 S BGPVALUD=BGPVALUD_"|||"_$S(BGPN14:"ALL: ",1:"")_$S(BGPN16:"BP: "_$P(BGPBPDEV,U),1:"")

 S %=$S($P(BGPLDL1,U,2):"LDL: "_$$DATE^BGP2UTL($P(BGPLDL1,U,2)),1:"")

 I %]"" S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":";",1:"") S BGPVALUD=BGPVALUD_" "_%

 S %="" I $P(BGPTOB,U) S %="TOB: "_$S($P(BGPTOB,U,3)["/":$P(BGPTOB,U,3),1:$$DATE^BGP2UTL($P(BGPTOB,U,3)))_" "_$P(BGPTOB,U,2)

 I %]"" S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":";",1:"") S BGPVALUD=BGPVALUD_" "_%

 I BGPN10 D

 .S %=$S($P(BGPBMI,U)]"":"BMI: "_$J(BGPBMI,5,1),1:$P(BGPBMIR,U,2))

 .I %]"" S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":";",1:"") S BGPVALUD=BGPVALUD_" "_%

 S %=$S($P(BGPLIFED,U):"LIFE: "_$$DATE^BGP2UTL($P(BGPLIFED,U,2))_" "_$P(BGPLIFED,U,3),1:"")

 I %]"" S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":";",1:"") S BGPVALUD=BGPVALUD_" "_%

 S %=$S($P(BGPDEPS,U):"DEP: "_$P(BGPDEPS,U,2),1:"")

 I %]"" S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":";",1:"") S BGPVALUD=BGPVALUD_" "_%

 I $G(BGPIISO) Q

E K BGPBP,BGPLDL,BGPTOB,BGPBMI,BGPLIFE,BGPDEP,BGPDV

 Q

I0302 ;EP

 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>19 S BGPD1=1

 I BGPACTCL,BGPAGEB>19 S BGPD2=1

 I BGPACTCL,$$IHD^BGP2D721(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=$$MEANBP(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE)

 I BGPVALUE["unknown" S BGPVALUE=$$BPCPT^BGP2D22(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE) I BGPVALUE]"" S BGPN1=1,BGPVALUE=$P(BGPVALUE,U,2) G V  ;CPTS COUNT IN NUMERATOR 1 ONLY

 S BGPXPWV=$P(BGPVALUE,U,1),BGPXPWV=$P(BGPXPWV," ")

 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:",IHD",1:"")_"|||"_$P(BGPVALUE,U)

 Q

DEP(P,BDATE,EDATE) ;EP

 S X=$$DEP^BGP2D25(P,BDATE,EDATE) I $P(X,U) Q X

 S X=$$DEPSCR^BGP2D25(P,BDATE,EDATE) I $P(X,U) Q X

 Q ""

DEPCHD(P,BDATE,EDATE) ;EP

 S X=$$DEP^BGP2D25(P,BDATE,EDATE) I $P(X,U) Q X

 S X=$$DEPSCR^BGP2D25(P,BDATE,EDATE) I $P(X,U) Q X

 S X=$$DEPSUIC^BGP2D25(P,BDATE,EDATE) I $P(X,U) Q X

 Q ""

LIFE(P,BDATE,EDATE) ;EP

 S X=$$MEDNUTR^BGP2D711(P,BDATE,EDATE) I X]"" Q 1_U_X

 S X=$$SPECNUTR^BGP2D711(P,BDATE,EDATE) I X]"" Q 1_U_X

 S X=$$SPECEX^BGP2D711(P,BDATE,EDATE) I X]"" Q 1_U_X

 S X=$$OTHREL^BGP2D711(P,BDATE,EDATE) I X]"" Q 1_U_X

 Q ""

LIFED(P,BDATE,EDATE) ;EP

 S X=$$MEDNUTRD^BGP2D711(P,BDATE,EDATE) I X]"" Q 1_U_X

 S X=$$SPECNUTR^BGP2D711(P,BDATE,EDATE) I X]"" Q 1_U_X

 S X=$$SPECEX^BGP2D711(P,BDATE,EDATE) I X]"" Q 1_U_X

 S X=$$OTHREL^BGP2D711(P,BDATE,EDATE) I X]"" Q 1_U_X

 Q ""

TOBACCO(P,BDATE,EDATE) ;EP

 S X=$$TOBACCO^BGP2D7(P,BDATE,EDATE) I X]"" Q 1_U_X

 S X=$$TOBDX(P,BDATE,EDATE) I X]"" Q 1_U_X

 S X=$$PED^BGP2D7(P,BDATE,EDATE) I X]"" Q 1_U_X

 S X=$$DENT^BGP2D7(P,BDATE,EDATE) I X]"" Q 1_U_X

 S X=$$CPTSM^BGP2D7(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 ""

 ;

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^BGP2D2(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 GPRA SMOKING 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)'="A"

 .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^ICDCODE(Y),U,2),1,5)'="305.1",$P($$ICDDX^ICDCODE(Y),U,2)'="V15.82" Q

 .S G=$P($$ICDDX^ICDCODE(Y),U,2)_" PL"

 .Q

 Q G

BGP2D41   ; IHS/CMI/LAB - measure 3 ;

 +1       ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66

 +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        SET BGPIHD=$$IHDCCVD^BGP2D729(DFN,BGPBDATE,BGPEDATE)

 +5        SET BGPCHD=0

 +6        IF BGPRTYPE'=4

               SET BGPCHD=$$CHD^BGP2D729(DFN,BGPBDATE,BGPEDATE)

 +7       ;no IHD or CHD

           IF 'BGPIHD

               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        IF BGPIHD

               SET BGPD1=1

 +3        IF BGPIHD

               IF BGPDMD2

                   SET BGPD3=1

 +4        IF BGPIHD

               IF 'BGPDMD2

                   SET 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^BGP2D22(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^BGP2D22(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^BGP2D2(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^BGP2D2(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^BGP2D6(DFN,BGPEDATE,BGPAGEE)

           SET BGPN4=$SELECT(BGPBMI]"":1,1:0)

 +22       SET BGPBMIR=""

           IF 'BGPN4

               SET BGPBMIR=$$REF^BGP2D6(DFN,BGPBDATE,BGPEDATE,BGPAGEE)

               IF $PIECE(BGPBMIR,U)

                   SET BGPN4=1

                   SET BGPN8=1

                   SET BGPBMIR=1_U_"BMI: Ref ht "_$$DATE^BGP2UTL($PIECE(BGPBMIR,U,3))_" wt "_$$DATE^BGP2UTL($PIECE(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^BGP2D25(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 BGPDV="IHD"_$SELECT(BGPD3:",AD",1:"")

 +36      ;S BGPVALUE=BGPDV_"|||"_$S(BGPN9:"GPRA ",1:"")_$S(BGPALL:"ALL  ",1:"")_$S(BGPN1:"BP: "_$P($P(BGPBP,U)," ",1,3),1:"")

 +37       SET BGPVALUE=BGPDV_"|||"_$SELECT(BGPN9:"ALL: ",1:"")

 +38       SET %=""

           SET BGPVALUE=BGPVALUE_$SELECT(BGPN1:"BP: "_$PIECE(BGPBP,U),1:"")

 +39       SET %=$SELECT($PIECE(BGPLDL,U,2):"LDL: "_$$DATE^BGP2UTL($PIECE(BGPLDL,U,2))_" "_$PIECE(BGPLDL,U,3),1:"")

 +40       IF %]""

               SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":";",1:"")

               SET BGPVALUE=BGPVALUE_" "_%

 +41       SET %=""

           IF $PIECE(BGPTOB,U)

               SET %="TOB: "_$SELECT($PIECE(BGPTOB,U,3)["/":$PIECE(BGPTOB,U,3),1:$$DATE^BGP2UTL($PIECE(BGPTOB,U,3)))_" "_$PIECE(BGPTOB,U,2)

 +42       IF %]""

               SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":";",1:"")

               SET BGPVALUE=BGPVALUE_" "_%

 +43       SET %=$SELECT($PIECE(BGPBMI,U)]"":"BMI: "_$$STRIP^XLFSTR($JUSTIFY(BGPBMI,5,1)," "),1:$SELECT(BGPRTYPE'=1:$PIECE(BGPBMIR,U,2),1:""))

 +44       IF %]""

               SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":";",1:"")

               SET BGPVALUE=BGPVALUE_" "_%

 +45       SET %=$SELECT($PIECE(BGPLIFE,U):"LIFE: "_$$DATE^BGP2UTL($PIECE(BGPLIFE,U,2))_" "_$PIECE(BGPLIFE,U,3),1:"")

 +46       IF %]""

               SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":";",1:"")

               SET BGPVALUE=BGPVALUE_" "_%

 +47       SET %=$SELECT($PIECE(BGPDEP,U):"DEP: "_$PIECE(BGPDEP,U,2),1:"")

 +48       IF %]""

               SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":";",1:"")

               SET BGPVALUE=BGPVALUE_" "_%

 +49       SET BGPVALUD="CHD"_$SELECT(BGPD6:",AD",1:"")

 +50      ;S BGPVALUD=BGPVALUD_"|||"_$S(BGPN14:"GPRA DEV  ",1:"")_$S(BGPALL1:"ALL  ",1:"")_$S(BGPN16:"BP: "_$P($P(BGPBPDEV,U)," ",1,3),1:"")

 +51       SET BGPVALUD=BGPVALUD_"|||"_$SELECT(BGPN14:"ALL: ",1:"")_$SELECT(BGPN16:"BP: "_$PIECE(BGPBPDEV,U),1:"")

 +52       SET %=$SELECT($PIECE(BGPLDL1,U,2):"LDL: "_$$DATE^BGP2UTL($PIECE(BGPLDL1,U,2)),1:"")

 +53       IF %]""

               SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":";",1:"")

               SET BGPVALUD=BGPVALUD_" "_%

 +54       SET %=""

           IF $PIECE(BGPTOB,U)

               SET %="TOB: "_$SELECT($PIECE(BGPTOB,U,3)["/":$PIECE(BGPTOB,U,3),1:$$DATE^BGP2UTL($PIECE(BGPTOB,U,3)))_" "_$PIECE(BGPTOB,U,2)

 +55       IF %]""

               SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":";",1:"")

               SET BGPVALUD=BGPVALUD_" "_%

 +56       IF BGPN10

               Begin DoDot:1

 +57               SET %=$SELECT($PIECE(BGPBMI,U)]"":"BMI: "_$JUSTIFY(BGPBMI,5,1),1:$PIECE(BGPBMIR,U,2))

 +58               IF %]""

                       SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":";",1:"")

                       SET BGPVALUD=BGPVALUD_" "_%

               End DoDot:1

 +59       SET %=$SELECT($PIECE(BGPLIFED,U):"LIFE: "_$$DATE^BGP2UTL($PIECE(BGPLIFED,U,2))_" "_$PIECE(BGPLIFED,U,3),1:"")

 +60       IF %]""

               SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":";",1:"")

               SET BGPVALUD=BGPVALUD_" "_%

 +61       SET %=$SELECT($PIECE(BGPDEPS,U):"DEP: "_$PIECE(BGPDEPS,U,2),1:"")

 +62       IF %]""

               SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":";",1:"")

               SET BGPVALUD=BGPVALUD_" "_%

 +63       IF $GET(BGPIISO)

               QUIT 

E          KILL BGPBP,BGPLDL,BGPTOB,BGPBMI,BGPLIFE,BGPDEP,BGPDV

 +1        QUIT 

I0302     ;EP

 +1        SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0

 +2       ;I BGPAGEB<20 S BGPSTOP=1 Q  ;no need to process

 +3        IF BGPACTUP

               IF BGPAGEB>19

                   SET BGPD1=1

 +4        IF BGPACTCL

               IF BGPAGEB>19

                   SET BGPD2=1

 +5        IF BGPACTCL

               IF $$IHD^BGP2D721(DFN,BGP365,BGPEDATE)

                   SET BGPIHD=1

                   SET BGPD3=1

 +6       ;not in any denominator

           IF '(BGPD1+BGPD2+BGPD3)

               SET BGPSTOP=1

               QUIT 

BPCV      ;EP - called from elder care routine

 +1        SET BGPVALUE=$$MEANBP(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE)

 +2       ;CPTS COUNT IN NUMERATOR 1 ONLY

           IF BGPVALUE["unknown"

               SET BGPVALUE=$$BPCPT^BGP2D22(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE)

               IF BGPVALUE]""

                   SET BGPN1=1

                   SET BGPVALUE=$PIECE(BGPVALUE,U,2)

                   GOTO V

 +3        SET BGPXPWV=$PIECE(BGPVALUE,U,1)

           SET BGPXPWV=$PIECE(BGPXPWV," ")

 +4       ;any value 2-6

           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        SET BGPN5=$SELECT($PIECE(BGPVALUE,U,2)=5:1,1:0)

 +9        SET BGPN6=$SELECT($PIECE(BGPVALUE,U,2)=6:1,1:0)

V          SET BGPVALUE=$SELECT(BGPD1:"UP",1:"")_$SELECT(BGPD2:",AC",1:"")_$SELECT(BGPD3:",IHD",1:"")_"|||"_$PIECE(BGPVALUE,U)

 +1        QUIT 

DEP(P,BDATE,EDATE) ;EP

 +1        SET X=$$DEP^BGP2D25(P,BDATE,EDATE)

           IF $PIECE(X,U)

               QUIT X

 +2        SET X=$$DEPSCR^BGP2D25(P,BDATE,EDATE)

           IF $PIECE(X,U)

               QUIT X

 +3        QUIT ""

DEPCHD(P,BDATE,EDATE) ;EP

 +1        SET X=$$DEP^BGP2D25(P,BDATE,EDATE)

           IF $PIECE(X,U)

               QUIT X

 +2        SET X=$$DEPSCR^BGP2D25(P,BDATE,EDATE)

           IF $PIECE(X,U)

               QUIT X

 +3        SET X=$$DEPSUIC^BGP2D25(P,BDATE,EDATE)

           IF $PIECE(X,U)

               QUIT X

 +4        QUIT ""

LIFE(P,BDATE,EDATE) ;EP

 +1        SET X=$$MEDNUTR^BGP2D711(P,BDATE,EDATE)

           IF X]""

               QUIT 1_U_X

 +2        SET X=$$SPECNUTR^BGP2D711(P,BDATE,EDATE)

           IF X]""

               QUIT 1_U_X

 +3        SET X=$$SPECEX^BGP2D711(P,BDATE,EDATE)

           IF X]""

               QUIT 1_U_X

 +4        SET X=$$OTHREL^BGP2D711(P,BDATE,EDATE)