- BGP5D41 ; IHS/CMI/LAB - measure 3 ;
- ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143
- ;
- ;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^BGP5D729(DFN,BGPBDATE,BGPEDATE)
- S BGPCHD=0
- S BGPCHD=$$CHD^BGP5D729(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,BGPD7)=0
- ;I BGPIHD S BGPD1=1
- ;I BGPIHD,BGPDMD2 S BGPD3=1
- ;I BGPIHD,'BGPDMD2 S BGPD2=1
- I BGPCHD S BGPD7=1 ;USER POP
- I $G(BGPCHD),BGPACTCL S BGPD4=1
- I $G(BGPCHD),BGPACTCL,BGPDMD2 S BGPD6=1
- I $G(BGPCHD),BGPACTCL,'BGPDMD2 S BGPD5=1
- S BGPBPC=""
- S BGPBP=$$MEANBP(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE)
- I BGPBP["unknown" S BGPBPC=$$BPCPT^BGP5D22(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^BGP5D22(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^BGP5D2(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE,1) ;date^value
- I $P(BGPLDL,U) S BGPN11=1 ;had ldl done
- S BGPLDL1=$$LDL^BGP5D2(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^BGP5D6(DFN,BGPEDATE,BGPAGEE),BGPN4=$S(BGPBMI]"":1,1:0)
- ;S BGPBMIR="" I 'BGPN4 S BGPBMIR=$$REF^BGP5D6(DFN,BGPBDATE,BGPEDATE,BGPAGEE) I $P(BGPBMIR,U) S BGPN4=1,BGPN8=1,BGPBMIR=1_U_"BMI: Ref ht "_$$DATE^BGP5UTL($P(BGPBMIR,U,3))_" wt "_$$DATE^BGP5UTL($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^BGP5D25(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="UP"_$S(BGPD4:",AC",1:"")_" 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^BGP5UTL($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^BGP5UTL($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^BGP5UTL($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^BGP5D729(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^BGP5D22(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^BGP5D25(P,BDATE,EDATE) I $P(X,U) Q X
- S X=$$DEPSCR^BGP5D25(P,BDATE,EDATE) I $P(X,U) Q X
- Q ""
- DEPCHD(P,BDATE,EDATE) ;EP
- S X=$$DEP^BGP5D25(P,BDATE,EDATE) I $P(X,U) Q X
- S X=$$DEPSCR^BGP5D25(P,BDATE,EDATE) I $P(X,U) Q X
- S X=$$DEPSUIC^BGP5D25(P,BDATE,EDATE) I $P(X,U) Q X
- Q ""
- LIFE(P,BDATE,EDATE) ;EP
- S X=$$MEDNUTR^BGP5D711(P,BDATE,EDATE) I X]"" Q 1_U_X
- S X=$$SPECNUTR^BGP5D711(P,BDATE,EDATE) I X]"" Q 1_U_X
- S X=$$SPECEX^BGP5D711(P,BDATE,EDATE) I X]"" Q 1_U_X
- S X=$$OTHREL^BGP5D711(P,BDATE,EDATE) I X]"" Q 1_U_X
- Q ""
- LIFED(P,BDATE,EDATE) ;EP
- S X=$$MEDNUTRD^BGP5D711(P,BDATE,EDATE) I X]"" Q 1_U_X
- S X=$$SPECNUTR^BGP5D711(P,BDATE,EDATE) I X]"" Q 1_U_X
- S X=$$SPECEX^BGP5D711(P,BDATE,EDATE) I X]"" Q 1_U_X
- S X=$$OTHREL^BGP5D711(P,BDATE,EDATE) I X]"" Q 1_U_X
- Q ""
- TOBACCO(P,BDATE,EDATE) ;EP
- S X=$$TOBACCO^BGP5D7(P,BDATE,EDATE) I X]"" Q 1_U_X
- S X=$$TOBDX(P,BDATE,EDATE) I X]"" Q 1_U_X
- S X=$$PED^BGP5D7(P,BDATE,EDATE) I X]"" Q 1_U_X
- S X=$$DENT^BGP5D7(P,BDATE,EDATE) I X]"" Q 1_U_X
- S X=$$CPTSM^BGP5D7(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<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^BGP5D2(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^BGP5UTL2(Y),U,2),1,5)'="305.1",$P($$ICDDX^BGP5UTL2(Y),U,2)'="V15.82" Q
- .S G=$P($$ICDDX^BGP5UTL2(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)," ")
- ;
- BGP5D41 ; IHS/CMI/LAB - measure 3 ;
- +1 ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143
- +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 ;I 'BGPACTCL S BGPSTOP=1 Q ;must be active clinical
- +4 ;S BGPIHD=$$IHDCCVD^BGP5D729(DFN,BGPBDATE,BGPEDATE)
- +5 SET BGPCHD=0
- +6 SET BGPCHD=$$CHD^BGP5D729(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,BGPD7)=0
- +2 ;I BGPIHD S BGPD1=1
- +3 ;I BGPIHD,BGPDMD2 S BGPD3=1
- +4 ;I BGPIHD,'BGPDMD2 S BGPD2=1
- +5 ;USER POP
- IF BGPCHD
- SET BGPD7=1
- +6 IF $GET(BGPCHD)
- IF BGPACTCL
- SET BGPD4=1
- +7 IF $GET(BGPCHD)
- IF BGPACTCL
- IF BGPDMD2
- SET BGPD6=1
- +8 IF $GET(BGPCHD)
- IF BGPACTCL
- IF 'BGPDMD2
- SET BGPD5=1
- +9 SET BGPBPC=""
- +10 SET BGPBP=$$MEANBP(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE)
- +11 IF BGPBP["unknown"
- SET BGPBPC=$$BPCPT^BGP5D22(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE)
- IF BGPBPC]""
- SET BGPBP=$PIECE(BGPBPC,U,2)_"^1"
- +12 SET BGPBPDEV=$$MEANBP(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE,1)
- +13 IF BGPBPDEV["unknown"
- SET BGPBPCD=$$BPCPT^BGP5D22(DFN,$$FMADD^XLFDT(BGPEDATE,-(2*365)),BGPEDATE,1)
- IF BGPBPCD]""
- SET BGPBPDEV=$PIECE(BGPBPCD,U,2)_"^1"
- +14 SET BGPN1=$SELECT($PIECE(BGPBP,U,2):1,1:0)
- +15 SET BGPN16=$SELECT($PIECE(BGPBPDEV,U,2):1,1:0)
- +16 ;date^value
- SET BGPLDL=$$LDL^BGP5D2(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE,1)
- +17 ;had ldl done
- IF $PIECE(BGPLDL,U)
- SET BGPN11=1
- +18 ;date^value
- SET BGPLDL1=$$LDL^BGP5D2(DFN,BGPBDATE,BGPEDATE,1)
- +19 ;had ldl done
- IF $PIECE(BGPLDL1,U)
- SET BGPN2=1
- +20 SET BGPTOB=$$TOBACCO(DFN,BGP365,BGPEDATE)
- +21 IF $PIECE(BGPTOB,U)
- SET BGPN3=1
- +22 SET BGPBMI=$$BMI^BGP5D6(DFN,BGPEDATE,BGPAGEE)
- SET BGPN4=$SELECT(BGPBMI]"":1,1:0)
- +23 ;S BGPBMIR="" I 'BGPN4 S BGPBMIR=$$REF^BGP5D6(DFN,BGPBDATE,BGPEDATE,BGPAGEE) I $P(BGPBMIR,U) S BGPN4=1,BGPN8=1,BGPBMIR=1_U_"BMI: Ref ht "_$$DATE^BGP5UTL($P(BGPBMIR,U,3))_" wt "_$$DATE^BGP5UTL($P(BGPBMIR,U,6))
- +24 ;S BGPLIFE=$$LIFE(DFN,BGP365,BGPEDATE),BGPN5=$S($P(BGPLIFE,U):1,1:0)
- +25 SET BGPLIFED=$$LIFED(DFN,BGP365,BGPEDATE)
- SET BGPN15=$SELECT($PIECE(BGPLIFED,U):1,1:0)
- +26 SET BGPDEP=$$DEP(DFN,BGP365,BGPEDATE)
- SET BGPN6=$SELECT($PIECE(BGPDEP,U):1,1:0)
- +27 ;I 'BGPN6 S BGPDEP=$$DEPREF^BGP5D25(DFN,BGPBDATE,BGPEDATE) I BGPDEP S BGPN6=1
- +28 SET BGPDEPS=$$DEPCHD(DFN,BGPBDATE,BGPEDATE)
- SET BGPN12=$SELECT($PIECE(BGPDEPS,U):1,1:0)
- +29 ;I BGPN1,BGPN2,BGPN3,BGPN10,BGPN5,BGPN12 S BGPN13=1
- +30 IF BGPN4
- IF 'BGPN8
- SET BGPN10=1
- +31 IF BGPN1
- IF BGPN2
- IF BGPN3
- IF BGPN4
- IF BGPN5
- SET BGPN7=1
- +32 ;IHD GPRA
- IF BGPN1
- IF BGPN11
- IF BGPN3
- IF BGPN10
- IF BGPN5
- SET BGPN9=1
- +33 ;CHD GPRA
- IF BGPN16
- IF BGPN2
- IF BGPN3
- IF BGPN10
- IF BGPN15
- SET BGPN14=1
- +34 ;IHD ALL
- SET BGPALL=0
- IF BGPN1
- IF BGPN11
- IF BGPN3
- IF BGPN10
- IF BGPN5
- IF BGPN6
- SET BGPALL=1
- +35 ;CHD ALL
- SET BGPALL1=0
- IF BGPN16
- IF BGPN2
- IF BGPN3
- IF BGPN10
- IF BGPN15
- IF BGPN12
- SET BGPALL1=1
- +36 SET BGPVALUE="UP"_$SELECT(BGPD4:",AC",1:"")_" CHD"_$SELECT(BGPD6:",AD",1:"")
- +37 ;S BGPVALUE=BGPVALUE_"|||"_$S(BGPN14:"GPRA DEV ",1:"")_$S(BGPALL1:"ALL ",1:"")_$S(BGPN16:"BP: "_$P($P(BGPBPDEV,U)," ",1,3),1:"")
- +38 SET BGPVALUE=BGPVALUE_"|||"_$SELECT(BGPN14:"ALL: ",1:"")_$SELECT(BGPN16:"BP: "_$PIECE(BGPBPDEV,U),1:"")
- +39 SET %=$SELECT($PIECE(BGPLDL1,U,2):"LDL: "_$$DATE^BGP5UTL($PIECE(BGPLDL1,U,2)),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^BGP5UTL($PIECE(BGPTOB,U,3)))_" "_$PIECE(BGPTOB,U,2)
- +42 IF %]""
- SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":";",1:"")
- SET BGPVALUE=BGPVALUE_" "_%
- +43 IF BGPN10
- Begin DoDot:1
- +44 SET %=$SELECT($PIECE(BGPBMI,U)]"":"BMI: "_$JUSTIFY(BGPBMI,5,1),1:$PIECE(BGPBMIR,U,2))
- +45 IF %]""
- SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":";",1:"")
- SET BGPVALUE=BGPVALUE_" "_%
- End DoDot:1
- +46 SET %=$SELECT($PIECE(BGPLIFED,U):"LIFE: "_$$DATE^BGP5UTL($PIECE(BGPLIFED,U,2))_" "_$PIECE(BGPLIFED,U,3),1:"")
- +47 IF %]""
- SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":";",1:"")
- SET BGPVALUE=BGPVALUE_" "_%
- +48 SET %=$SELECT($PIECE(BGPDEPS,U):"DEP: "_$PIECE(BGPDEPS,U,2),1:"")
- +49 IF %]""
- SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":";",1:"")
- SET BGPVALUE=BGPVALUE_" "_%
- +50 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^BGP5D729(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^BGP5D22(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^BGP5D25(P,BDATE,EDATE)
- IF $PIECE(X,U)
- QUIT X
- +2 SET X=$$DEPSCR^BGP5D25(P,BDATE,EDATE)
- IF $PIECE(X,U)
- QUIT X
- +3 QUIT ""
- DEPCHD(P,BDATE,EDATE) ;EP
- +1 SET X=$$DEP^BGP5D25(P,BDATE,EDATE)
- IF $PIECE(X,U)
- QUIT X
- +2 SET X=$$DEPSCR^BGP5D25(P,BDATE,EDATE)
- IF $PIECE(X,U)
- QUIT X
- +3 SET X=$$DEPSUIC^BGP5D25(P,BDATE,EDATE)
- IF $PIECE(X,U)
- QUIT X
- +4 QUIT ""
- LIFE(P,BDATE,EDATE) ;EP
- +1 SET X=$$MEDNUTR^BGP5D711(P,BDATE,EDATE)
- IF X]""
- QUIT 1_U_X
- +2 SET X=$$SPECNUTR^BGP5D711(P,BDATE,EDATE)
- IF X]""
- QUIT 1_U_X
- +3 SET X=$$SPECEX^BGP5D711(P,BDATE,EDATE)
- IF X]""
- QUIT 1_U_X
- +4 SET X=$$OTHREL^BGP5D711(P,BDATE,EDATE)
- IF X]""
- QUIT 1_U_X
- +5 QUIT ""
- LIFED(P,BDATE,EDATE) ;EP
- +1 SET X=$$MEDNUTRD^BGP5D711(P,BDATE,EDATE)
- IF X]""
- QUIT 1_U_X
- +2 SET X=$$SPECNUTR^BGP5D711(P,BDATE,EDATE)
- IF X]""
- QUIT 1_U_X
- +3 SET X=$$SPECEX^BGP5D711(P,BDATE,EDATE)
- IF X]""
- QUIT 1_U_X
- +4 SET X=$$OTHREL^BGP5D711(P,BDATE,EDATE)
- IF X]""
- QUIT 1_U_X
- +5 QUIT ""
- TOBACCO(P,BDATE,EDATE) ;EP
- +1 SET X=$$TOBACCO^BGP5D7(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^BGP5D7(P,BDATE,EDATE)
- IF X]""
- QUIT 1_U_X
- +4 SET X=$$DENT^BGP5D7(P,BDATE,EDATE)
- IF X]""
- QUIT 1_U_X
- +5 SET X=$$CPTSM^BGP5D7(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<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^BGP5D2(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^BGP5UTL2(Y),U,2),1,5)'="305.1"
- IF $PIECE($$ICDDX^BGP5UTL2(Y),U,2)'="V15.82"
- QUIT
- +13 SET G=$PIECE($$ICDDX^BGP5UTL2(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 ;
