- 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 ;
