BGP8D41 ; IHS/CMI/LAB - measure 3 ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
;IHS/CMI/LAB - patch 1 7-7-03 added HDL and Triglyceride check to 30-1
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^BGP8D729(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^BGP8D22(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^BGP8D25(P,BDATE,EDATE) I $P(X,U) Q X
S X=$$DEPSCR^BGP8D25(P,BDATE,EDATE) I $P(X,U) Q X
Q ""
DEPCHD(P,BDATE,EDATE) ;EP
S X=$$DEP^BGP8D25(P,BDATE,EDATE) I $P(X,U) Q X
S X=$$DEPSCR^BGP8D25(P,BDATE,EDATE) I $P(X,U) Q X
S X=$$DEPSUIC^BGP8D25(P,BDATE,EDATE) I $P(X,U) Q X
Q ""
LIFE(P,BDATE,EDATE) ;EP
S X=$$MEDNUTR^BGP8D711(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$SPECNUTR^BGP8D711(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$SPECEX^BGP8D711(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$OTHREL^BGP8D711(P,BDATE,EDATE) I X]"" Q 1_U_X
Q ""
LIFED(P,BDATE,EDATE) ;EP
S X=$$MEDNUTRD^BGP8D711(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$SPECNUTR^BGP8D711(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$SPECEX^BGP8D711(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$OTHREL^BGP8D711(P,BDATE,EDATE) I X]"" Q 1_U_X
Q ""
TOBACCO(P,BDATE,EDATE) ;EP
S X=$$TOBACCO^BGP8D7(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$TOBDX(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$PED^BGP8D7(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$DENT^BGP8D7(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$CPTSM^BGP8D7(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 S_"/"_DS_U_1
;
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<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)," ")
;
DIAMEAN(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)," ")
;
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^BGP8D2(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^BGP8UTL2(Y),U,2),1,5)'="305.1",$P($$ICDDX^BGP8UTL2(Y),U,2)'="V15.82" Q
.S G=$P($$ICDDX^BGP8UTL2(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 S_"/"_DS_U_1
;
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)," ")
;
BGP8D41 ; IHS/CMI/LAB - measure 3 ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
+3 ;IHS/CMI/LAB - patch 1 7-7-03 added HDL and Triglyceride check to 30-1
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^BGP8D729(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^BGP8D22(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 ;S BGPN2=$S($P(BGPVALUE,U,2)=2:1,1:0)
+7 ;S BGPN3=$S($P(BGPVALUE,U,2)=3:1,1:0)
+8 ;S BGPN4=$S($P(BGPVALUE,U,2)=4:1,1:0)
+9 ;S BGPN5=$S($P(BGPVALUE,U,2)=5:1,1:0)
+10 ;S BGPN6=$S($P(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^BGP8D25(P,BDATE,EDATE)
IF $PIECE(X,U)
QUIT X
+2 SET X=$$DEPSCR^BGP8D25(P,BDATE,EDATE)
IF $PIECE(X,U)
QUIT X
+3 QUIT ""
DEPCHD(P,BDATE,EDATE) ;EP
+1 SET X=$$DEP^BGP8D25(P,BDATE,EDATE)
IF $PIECE(X,U)
QUIT X
+2 SET X=$$DEPSCR^BGP8D25(P,BDATE,EDATE)
IF $PIECE(X,U)
QUIT X
+3 SET X=$$DEPSUIC^BGP8D25(P,BDATE,EDATE)
IF $PIECE(X,U)
QUIT X
+4 QUIT ""
LIFE(P,BDATE,EDATE) ;EP
+1 SET X=$$MEDNUTR^BGP8D711(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+2 SET X=$$SPECNUTR^BGP8D711(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+3 SET X=$$SPECEX^BGP8D711(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+4 SET X=$$OTHREL^BGP8D711(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+5 QUIT ""
LIFED(P,BDATE,EDATE) ;EP
+1 SET X=$$MEDNUTRD^BGP8D711(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+2 SET X=$$SPECNUTR^BGP8D711(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+3 SET X=$$SPECEX^BGP8D711(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+4 SET X=$$OTHREL^BGP8D711(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+5 QUIT ""
TOBACCO(P,BDATE,EDATE) ;EP
+1 SET X=$$TOBACCO^BGP8D7(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^BGP8D7(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+4 SET X=$$DENT^BGP8D7(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+5 SET X=$$CPTSM^BGP8D7(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 ;I S>159!(DS>99) Q S_"/"_DS_" STG 2 HTN"_U_6
+6 ;I S>139&(S<160)!(DS>89&(DS<100)) Q S_"/"_DS_" STG 1 HTN"_U_5
+7 ;I S>129&(S<140)!(DS>80&(DS<90)) Q S_"/"_DS_" PRE HTN 2"_U_4
+8 ;I S>119&(S<130)!(DS=80) Q S_"/"_DS_" PRE HTN 1"_U_3
+9 ;I S<120&(DS<80) Q S_"/"_DS_" NORMAL"_U_2
+10 QUIT S_"/"_DS_U_1
+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<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 ;
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<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 ;
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^BGP8D2(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^BGP8UTL2(Y),U,2),1,5)'="305.1"
IF $PIECE($$ICDDX^BGP8UTL2(Y),U,2)'="V15.82"
QUIT
+13 SET G=$PIECE($$ICDDX^BGP8UTL2(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 ;I S>159!(DS>99) Q S_"/"_DS_" STG 2 HTN"_U_6
+6 ;I S>139&(S<160)!(DS>89&(DS<100)) Q S_"/"_DS_" STG 1 HTN"_U_5
+7 ;I S>129&(S<140)!(DS>80&(DS<90)) Q S_"/"_DS_" PRE HTN 2"_U_4
+8 ;I S>119&(S<130)!(DS=80) Q S_"/"_DS_" PRE HTN 1"_U_3
+9 ;I S<120&(DS<80) Q S_"/"_DS_" NORMAL"_U_2
+10 QUIT S_"/"_DS_U_1
+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 ;
