- 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