BGP9D41 ; IHS/CMI/LAB - measure 3 ;
;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
;
;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=$$IHD^BGP9D721(DFN,BGPBDATE,BGPEDATE)
I 'BGPIHD S BGPSTOP=1 Q ;no IHD
I0302ASC ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPD1,BGPD2,BGPD3,BGPD4)=0
S BGPD1=1
I BGPDMD2 S BGPD3=1
I 'BGPDMD2 S BGPD2=1
S BGPBPC=""
S BGPBP=$$MEANBP(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE)
I BGPBP["unknown" S BGPBPC=$$BPCPT^BGP9D22(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE) I BGPBPC]"" S BGPBP=$P(BGPBPC,U,2)_"^1"
S BGPN1=$S($P(BGPBP,U,2):1,1:0)
S BGPLDL=$$LDL^BGP9D2(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE,1) ;date^value
I $P(BGPLDL,U) S BGPN2=1 ;had ldl done
S BGPTOB=$$TOBACCO(DFN,BGP365,BGPEDATE)
I $P(BGPTOB,U) S BGPN3=1
S BGPBMI=$$BMI^BGP9D6(DFN,BGPEDATE,BGPAGEE),BGPN4=$S(BGPBMI]"":1,1:0)
S BGPBMIR="" I 'BGPN4 S BGPBMIR=$$REF^BGP9D6(DFN,BGPBDATE,BGPEDATE,BGPAGEE) I $P(BGPBMIR,U) S BGPN4=1,BGPN8=1,BGPBMIR=1_U_"BMI: ref: ht "_$$DATE^BGP9UTL($P(BGPBMIR,U,3))_" wt "_$$DATE^BGP9UTL($P(BGPBMIR,U,6))
S BGPLIFE=$$LIFE(DFN,BGP365,BGPEDATE),BGPN5=$S($P(BGPLIFE,U):1,1:0)
S BGPDEP=$$DEP(DFN,BGP365,BGPEDATE),BGPN6=$S($P(BGPDEP,U):1,1:0)
I BGPN1,BGPN2,BGPN3,BGPN4,BGPN5 S BGPN7=1
I BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,'BGPN8 S BGPN9=1
I BGPN4,'BGPN8 S BGPN10=1
S BGPALL=0 I BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6 S BGPALL=1
S BGPDV=$S(BGPD1:"IHD",1:"")_$S(BGPD3:";AD",1:"")
S BGPVALUE=BGPDV_"|||"_$S(BGPN7:"GPRA ",1:"")_$S(BGPALL:"ALL ",1:"")_$S(BGPN1:"BP: "_$P($P(BGPBP,U)," ",1,3),1:"")
S %=$S($P(BGPLDL,U,2):"LDL: "_$$DATE^BGP9UTL($P(BGPLDL,U,2)),1:"")
I %]"" S BGPVALUE=BGPVALUE_" "_%
S %="" I $P(BGPTOB,U) S %="TOB: "_$S($P(BGPTOB,U,3)["/":$P(BGPTOB,U,3),1:$$DATE^BGP9UTL($P(BGPTOB,U,3)))_": "_$P(BGPTOB,U,2)
I %]"" S BGPVALUE=BGPVALUE_" "_%
S %=$S($P(BGPBMI,U)]"":"BMI: "_$J(BGPBMI,5,1),1:$P(BGPBMIR,U,2))
I %]"" S BGPVALUE=BGPVALUE_" "_%
S %=$S($P(BGPLIFE,U):"LIFE: "_$$DATE^BGP9UTL($P(BGPLIFE,U,2))_":"_$P(BGPLIFE,U,3),1:"")
I %]"" S BGPVALUE=BGPVALUE_" "_%
S %=$S($P(BGPDEP,U):"DEP: "_$P(BGPDEP,U,2),1:"")
I %]"" S BGPVALUE=BGPVALUE_" "_%
I $G(BGPIISO) Q
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^BGP9D721(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^BGP9D22(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 BGPXPNV=$P(BGPVALUE,U,1),BGPXPNV=$P(BGPXPNV," ")
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^BGP9D25(P,BDATE,EDATE) I $P(X,U) Q X
S X=$$DEPSCR^BGP9D25(P,BDATE,EDATE) I $P(X,U) Q X
Q ""
LIFE(P,BDATE,EDATE) ;EP
S X=$$MEDNUTR^BGP9D711(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$SPECNUTR^BGP9D711(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$SPECEX^BGP9D711(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$OTHREL^BGP9D711(P,BDATE,EDATE) I X]"" Q 1_U_X
Q ""
TOBACCO(P,BDATE,EDATE) ;EP
S X=$$TOBACCO^BGP9D7(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$TOBDX(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$PED^BGP9D7(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$DENT^BGP9D7(P,BDATE,EDATE) I X]"" Q 1_U_X
S X=$$CPTSM^BGP9D7(P,BDATE,EDATE) I X]"" Q 1_U_X
Q ""
MEANBP(P,BDATE,EDATE) ;EP
S X=$$BPS(P,BDATE,EDATE,"I")
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>79&(DS<90)) Q S_"/"_DS_" PRE STG II"_U_4
I S>119&(S<130)!(DS=80) Q S_"/"_DS_" PRE STG 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) ;EP ;
I $G(F)="" S F="E"
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
.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
..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
BGP9D41 ; IHS/CMI/LAB - measure 3 ;
+1 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
+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=$$IHD^BGP9D721(DFN,BGPBDATE,BGPEDATE)
+5 ;no IHD
IF 'BGPIHD
SET BGPSTOP=1
QUIT
I0302ASC ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPD1,BGPD2,BGPD3,BGPD4)=0
+2 SET BGPD1=1
+3 IF BGPDMD2
SET BGPD3=1
+4 IF 'BGPDMD2
SET BGPD2=1
+5 SET BGPBPC=""
+6 SET BGPBP=$$MEANBP(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE)
+7 IF BGPBP["unknown"
SET BGPBPC=$$BPCPT^BGP9D22(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE)
IF BGPBPC]""
SET BGPBP=$PIECE(BGPBPC,U,2)_"^1"
+8 SET BGPN1=$SELECT($PIECE(BGPBP,U,2):1,1:0)
+9 ;date^value
SET BGPLDL=$$LDL^BGP9D2(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE,1)
+10 ;had ldl done
IF $PIECE(BGPLDL,U)
SET BGPN2=1
+11 SET BGPTOB=$$TOBACCO(DFN,BGP365,BGPEDATE)
+12 IF $PIECE(BGPTOB,U)
SET BGPN3=1
+13 SET BGPBMI=$$BMI^BGP9D6(DFN,BGPEDATE,BGPAGEE)
SET BGPN4=$SELECT(BGPBMI]"":1,1:0)
+14 SET BGPBMIR=""
IF 'BGPN4
SET BGPBMIR=$$REF^BGP9D6(DFN,BGPBDATE,BGPEDATE,BGPAGEE)
IF $PIECE(BGPBMIR,U)
SET BGPN4=1
SET BGPN8=1
SET BGPBMIR=1_U_"BMI: ref: ht "_$$DATE^BGP9UTL($PIECE(BGPBMIR,U,3))_" wt "_$$DATE^BGP9UTL($PIECE(BGPBMIR,U,6))
+15 SET BGPLIFE=$$LIFE(DFN,BGP365,BGPEDATE)
SET BGPN5=$SELECT($PIECE(BGPLIFE,U):1,1:0)
+16 SET BGPDEP=$$DEP(DFN,BGP365,BGPEDATE)
SET BGPN6=$SELECT($PIECE(BGPDEP,U):1,1:0)
+17 IF BGPN1
IF BGPN2
IF BGPN3
IF BGPN4
IF BGPN5
SET BGPN7=1
+18 IF BGPN1
IF BGPN2
IF BGPN3
IF BGPN4
IF BGPN5
IF 'BGPN8
SET BGPN9=1
+19 IF BGPN4
IF 'BGPN8
SET BGPN10=1
+20 SET BGPALL=0
IF BGPN1
IF BGPN2
IF BGPN3
IF BGPN4
IF BGPN5
IF BGPN6
SET BGPALL=1
+21 SET BGPDV=$SELECT(BGPD1:"IHD",1:"")_$SELECT(BGPD3:";AD",1:"")
+22 SET BGPVALUE=BGPDV_"|||"_$SELECT(BGPN7:"GPRA ",1:"")_$SELECT(BGPALL:"ALL ",1:"")_$SELECT(BGPN1:"BP: "_$PIECE($PIECE(BGPBP,U)," ",1,3),1:"")
+23 SET %=$SELECT($PIECE(BGPLDL,U,2):"LDL: "_$$DATE^BGP9UTL($PIECE(BGPLDL,U,2)),1:"")
+24 IF %]""
SET BGPVALUE=BGPVALUE_" "_%
+25 SET %=""
IF $PIECE(BGPTOB,U)
SET %="TOB: "_$SELECT($PIECE(BGPTOB,U,3)["/":$PIECE(BGPTOB,U,3),1:$$DATE^BGP9UTL($PIECE(BGPTOB,U,3)))_": "_$PIECE(BGPTOB,U,2)
+26 IF %]""
SET BGPVALUE=BGPVALUE_" "_%
+27 SET %=$SELECT($PIECE(BGPBMI,U)]"":"BMI: "_$JUSTIFY(BGPBMI,5,1),1:$PIECE(BGPBMIR,U,2))
+28 IF %]""
SET BGPVALUE=BGPVALUE_" "_%
+29 SET %=$SELECT($PIECE(BGPLIFE,U):"LIFE: "_$$DATE^BGP9UTL($PIECE(BGPLIFE,U,2))_":"_$PIECE(BGPLIFE,U,3),1:"")
+30 IF %]""
SET BGPVALUE=BGPVALUE_" "_%
+31 SET %=$SELECT($PIECE(BGPDEP,U):"DEP: "_$PIECE(BGPDEP,U,2),1:"")
+32 IF %]""
SET BGPVALUE=BGPVALUE_" "_%
+33 IF $GET(BGPIISO)
QUIT
+34 KILL BGPBP,BGPLDL,BGPTOB,BGPBMI,BGPLIFE,BGPDEP,BGPDV
+35 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^BGP9D721(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^BGP9D22(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE)
IF BGPVALUE]""
SET BGPN1=1
SET BGPVALUE=$PIECE(BGPVALUE,U,2)
GOTO V
+3 SET BGPXPNV=$PIECE(BGPVALUE,U,1)
SET BGPXPNV=$PIECE(BGPXPNV," ")
+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^BGP9D25(P,BDATE,EDATE)
IF $PIECE(X,U)
QUIT X
+2 SET X=$$DEPSCR^BGP9D25(P,BDATE,EDATE)
IF $PIECE(X,U)
QUIT X
+3 QUIT ""
LIFE(P,BDATE,EDATE) ;EP
+1 SET X=$$MEDNUTR^BGP9D711(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+2 SET X=$$SPECNUTR^BGP9D711(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+3 SET X=$$SPECEX^BGP9D711(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+4 SET X=$$OTHREL^BGP9D711(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+5 QUIT ""
TOBACCO(P,BDATE,EDATE) ;EP
+1 SET X=$$TOBACCO^BGP9D7(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^BGP9D7(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+4 SET X=$$DENT^BGP9D7(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+5 SET X=$$CPTSM^BGP9D7(P,BDATE,EDATE)
IF X]""
QUIT 1_U_X
+6 QUIT ""
MEANBP(P,BDATE,EDATE) ;EP
+1 SET X=$$BPS(P,BDATE,EDATE,"I")
+2 SET S=$$SYSMEAN(X)
IF S=""
QUIT "unknown^^"
+3 SET DS=$$DIAMEAN(X)
IF DS=""
QUIT "unknown^^"
+4 IF S>159!(DS>99)
QUIT S_"/"_DS_" STG 2 HTN"_U_6
+5 IF S>139&(S<160)!(DS>89&(DS<100))
QUIT S_"/"_DS_" STG 1 HTN"_U_5
+6 IF S>129&(S<140)!(DS>79&(DS<90))
QUIT S_"/"_DS_" PRE STG II"_U_4
+7 IF S>119&(S<130)!(DS=80)
QUIT S_"/"_DS_" PRE STG 1"_U_3
+8 IF S<120&(DS<80)
QUIT S_"/"_DS_" NORMAL"_U_2
+9 QUIT ""
+10 ;
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) ;EP ;
+1 IF $GET(F)=""
SET F="E"
+2 SET BGPGLL=0
SET BGPGV=""
+3 KILL BGPG
+4 KILL ^TMP($JOB,"BPV")
+5 SET A="^TMP($J,""BPV"","
SET B=P_"^LAST 365 VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+6 IF '$DATA(^TMP($JOB,"BPV",1))
QUIT ""
+7 ;S X=P_"^LAST 50 MEAS BP;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")
+8 ;S BGPGL=0 F S BGPGL=$O(BGPG(BGPGL)) Q:BGPGL'=+BGPGL!(BGPGLL=3) S BGPGBP=$P($G(BGPG(BGPGL)),U,2) D
+9 SET Y=0
FOR
SET Y=$ORDER(^TMP($JOB,"BPV",Y))
IF Y'=+Y!(BGPGLL=3)
QUIT
Begin DoDot:1
+10 SET V=$PIECE(^TMP($JOB,"BPV",Y),U,5)
+11 ;NO ER CLINIC VISITS COUNTED
IF $$CLINIC^APCLV(V,"C")=30
QUIT
+12 ;no measurements to look at
IF '$DATA(^AUPNVMSR("AD",V))
QUIT
+13 ;NOW GET ALL BPS ON THIS VISIT
+14 SET BGPBP=""
+15 SET X=0
FOR
SET X=$ORDER(^AUPNVMSR("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:2
+16 ;BAD AD XREF
IF '$DATA(^AUPNVMSR(X,0))
QUIT
+17 SET T=$PIECE($GET(^AUPNVMSR(X,0)),U)
+18 ;BAD AD XREF
IF T=""
QUIT
+19 ;not a BP measurement type
IF $PIECE($GET(^AUTTMSR(T,0)),U)'="BP"
QUIT
+20 ;blood pressure value
SET Z=$PIECE(^AUPNVMSR(X,0),U,4)
+21 IF BGPBP=""
SET BGPBP=Z
QUIT
+22 IF $PIECE(Z,"/")'>$PIECE(BGPBP,"/")
SET BGPBP=Z
End DoDot:2
+23 IF BGPBP=""
QUIT
+24 SET BGPGLL=BGPGLL+1
+25 IF F="E"
SET $PIECE(BGPGV,";",BGPGLL)=BGPBP_" "_$$FMTE^XLFDT($PIECE(^TMP($JOB,"BPV",V),U))
+26 IF F="I"
SET $PIECE(BGPGV,";",BGPGLL)=$PIECE(BGPBP," ")
End DoDot:1
+27 KILL ^TMP($JOB,"BPV")
+28 QUIT BGPGV
TOBDX(P,BDATE,EDATE) ;EP
+1 KILL BGPG
+2 SET X=P_"^LAST DX [BGP GPRA SMOKING 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)'="A"
QUIT
+8 IF $PIECE(^AUPNPROB(X,0),U,3)>EDATE
QUIT
+9 IF $PIECE(^AUPNPROB(X,0),U,3)<BDATE
QUIT
+10 SET Y=$PIECE(^AUPNPROB(X,0),U)
+11 IF $EXTRACT($PIECE($$ICDDX^ICDCODE(Y),U,2),1,5)'="305.1"
IF $PIECE($$ICDDX^ICDCODE(Y),U,2)'="V15.82"
QUIT
+12 SET G=$PIECE($$ICDDX^ICDCODE(Y),U,2)_" PL"
+13 QUIT
End DoDot:1
+14 QUIT G
