BUDERP7B ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
;
HTN ;EP - list of HTN
;is patient pregnant during the time period BUDDD and BUDED
S BUDDOB=$P(^DPT(DFN,0),U,3)
S BUDDDB=($E(BUDBD,1,3)-85)_"0101"
S BUDDDE=($E(BUDBD,1,3)-18)_"1231"
Q:BUDDOB>BUDDDE
Q:BUDDOB<BUDDDB
Q:BUDMEDV<1
;
S BUDP=$$HTNDX(DFN,$$DOB^AUPNPAT(DFN),BUDCCAD)
I '$P(BUDP,U) Q ;not dx'ed before june 30
;PREGNANCY
Q:$$PREG^BUDERP6B(DFN,BUDBD,BUDED,BUDBD)
Q:$$EXCL(DFN,BUDDOB,BUDED)
S BUDP=$$HTNDX(DFN,$$DOB^AUPNPAT(DFN),BUDED,1)
S BUDRACEX=$$RACE^BUDERPTC(DFN),BUDRACE=$P(BUDRACEX,U,2),BUDRACEP=$P(BUDRACEX,U,5)
S BUDRACEE=$$RACE^BUDERP7I(BUDRACE)
S BUDR=""
S BUDETHN=$P($$HISP^BUDERPTC(DFN),U,1)
I +BUDETHN=1 S BUDETHNN="Hispanic or Latino"
I +BUDETHN=2 S BUDETHNN="Non-Hispanic/Latino"
I +BUDETHN=3 S BUDETHNN="Unreported/Refused to Report"
I BUDRACEP=8,+BUDETHN=3 S BUDR=1 G SETSECTB
I +BUDETHN=1 S BUDR=BUDRACEP G SETSECTB
I +BUDETHN=2 S BUDR=BUDRACEP G SETSECTB
;I +BUDETHN=3,BUDRACEP=8 S BUDR=1
SETSECTB ;
S $P(BUDSECTB(+BUDETHN,BUDR),U,1)=$P($G(BUDSECTB(+BUDETHN,BUDR)),U,1)+1 ;COL 1
S $P(BUDSECTB(+BUDETHN,BUDR),U,2)=$P($G(BUDSECTB(+BUDETHN,BUDR)),U,2)+1 ;COL 2
;TOTAL LINE
S $P(BUDSECTB(4),U,1)=$P($G(BUDSECTB(4)),U,1)+1
S $P(BUDSECTB(4),U,2)=$P($G(BUDSECTB(4)),U,2)+1
;SUBTOTAL LINE
S $P(BUDSECTB(+BUDETHN),U,1)=$P($G(BUDSECTB(+BUDETHN)),U,1)+1
S $P(BUDSECTB(+BUDETHN),U,2)=$P($G(BUDSECTB(+BUDETHN)),U,2)+1
I $G(BUDHTRL) S ^XTMP("BUDERP7",BUDJ,BUDH,"HTR",BUDRACEP,+BUDETHN,BUDCCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)
;I $G(BUDHTEL) S ^XTMP("BUDERP7",BUDJ,BUDH,"HTE",BUDETHNN,BUDCCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)
;now check BP
S BUDDP=$$LASTBP(DFN,BUDBD,BUDED)
I BUDDP]"" S BUDV=$$BPCHK(BUDDP) G SET
;now check cpts
S T=$O(^ATXAX("B","BUD SYSTOLIC BP CPTS",0))
S BUDS=$$CPT^BUDEDU(DFN,BUDBD,BUDED,T,6)
S T=$O(^ATXAX("B","BUD DIASTOLIC BP CPTS",0))
S BUDD=$$CPT^BUDEDU(DFN,BUDBD,BUDED,T,6)
I 'BUDS,'BUDD S BUDV=0_U_"NO BP TAKEN DURING THE REPORT PERIOD" G SET ;DIDN'T HAVE BOTH IN TIME PERIOD
S S=$P(BUDS,U,3)
S D=$P(BUDD,U,3)
S G=0
I S="3074F",D="3078F" S G=1
I S="3074F",D="3079F" S G=1
I S="3075F",D="3078F" S G=1
I S="3075F",D="3079F" S G=1
S BUDV=G_U_"CPTs: "_$P(BUDS,U,3)_" on "_$$FMTE^XLFDT($P(BUDS,U,2))_" and "_$P(BUDD,U,3)_" on "_$$FMTE^XLFDT($P(BUDD,U,2))
SET ;
I $P(BUDV,U) D
.S $P(BUDSECTB(+BUDETHN,BUDR),U,3)=$P($G(BUDSECTB(+BUDETHN,BUDR)),U,3)+1
.S $P(BUDSECTB(4),U,3)=$P($G(BUDSECTB(4)),U,3)+1
.S $P(BUDSECTB(+BUDETHN),U,3)=$P($G(BUDSECTB(+BUDETHN)),U,3)+1
;I $P(BUDV,U) S $P(BUDSECTE(8),U,BUDETHN)=$P($G(BUDSECTE(8)),U,BUDETHN)+1,$P(BUDSECTE(8),U,9)=$P($G(BUDSECTE(8)),U,9)+1
I $G(BUDHTCRL),$P(BUDV,U,1) S ^XTMP("BUDERP7",BUDJ,BUDH,"HTCR",BUDRACEP,+BUDETHN,BUDCCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
I $G(BUDHTURL),'$P(BUDV,U,1) S ^XTMP("BUDERP7",BUDJ,BUDH,"HTUR",BUDRACEP,+BUDETHN,BUDCCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)_"#"_$P(BUDV,U,2)
;I $G(BUDHTCEL),$P(BUDV,U,1) S ^XTMP("BUDERP7",BUDJ,BUDH,"HTCE",BUDETHNN,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
;I $G(BUDHTUEL),'$P(BUDV,U,1) S ^XTMP("BUDERP7",BUDJ,BUDH,"HTUE",BUDETHNN,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
Q
;
EXCL(P,BDATE,EDATE) ;EP
NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB,BDATE
S BDATE=$$DOB^AUPNPAT(P)
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
S BUDTOB=0
S TIEN=$O(^BUDETSSC("B","T7 HTN EXCLUSIONS",0))
S CTR=0 F S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR!(BUDTOB) D
.S VIEN=$P(BUDVS(CTR),U,5)
.S VDATE=$P(BUDVS(CTR),U,1)
.;POV/SNOMED
.S X=0 F S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X!(BUDTOB) D
..Q:'$D(^AUPNVPOV(X,0))
..S Y=$$VALI^XBDIQ1(9000010.07,X,.01) I $D(^BUDETSSC("AD",Y,TIEN)) S BUDTOB=1 Q
..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
..Q:Y=""
..I $D(^BUDETSSC("AS",Y,TIEN)) S BUDTOB=1 Q
.;CPT
.S X=0 F S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X!(BUDTOB) D
..Q:'$D(^AUPNVCPT(X,0))
..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
..Q:Y=""
..I $D(^BUDETSSC("AC",Y,TIEN)) S BUDTOB=1 Q
.;V TRANS
.S X=0 F S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X!(BUDTOB) D
..Q:'$D(^AUPNVTC(X,0))
..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
..Q:Y=""
..I $D(^BUDETSSC("AC",Y,TIEN)) S BUDTOB=1 Q
.;V PROC
.S X=0 F S X=$O(^AUPNVPRC("AD",VIEN,X)) Q:X'=+X!(BUDTOB) D
..Q:'$D(^AUPNVPRC(X,0))
..S Y=$$VALI^XBDIQ1(9000010.08,X,.01)
..I $D(^BUDETSSC("AP",Y,TIEN)) S BUDTOB=1 Q
I BUDTOB Q 1
S Y=$$PLCL^BUDEDU(P,"T7 HTN EXCLUSIONS",EDATE,0)
I Y Q 1
Q ""
BPCHK(BP) ;
NEW S,D
S S=$P($P(BP,U,4),"/")
S D=$P($P(BP,U,4),"/",2)
I S>139 Q 0_U_$P(BP,U,4)_" "_$$FMTE^XLFDT($P(BP,U,2))
I D>89 Q 0_U_$P(BP,U,4)_" "_$$FMTE^XLFDT($P(BP,U,2))
Q 1_U_$P(BP,U,4)_" "_$$FMTE^XLFDT($P(BP,U,2))
RACE(R) ;EP
I R="Unreported" Q 8
I R="Asian" Q 1
I R="Native Hawaiian" Q 2
I R="Other Pacific Islander" Q 3
I R="Black/African American" Q 4
I R="American Indian/Alaska Native" Q 5
I R="White" Q 6
Q ""
HTNDX(P,BDATE,EDATE,STOP) ;EP
NEW BUDDX,B,CNT,BUDD,BUDG,BUDALL
S STOP=$G(STOP)
S B=0,CNT=0,BUDD="",BUDALL="" ;if there is one before time frame set this to 1
;
;V10.0 ICD10
K BUDG S %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S T=$O(^BUDETSSC("B","T7 HTN DIAGNOSES",0))
S X=0,G="" F S X=$O(BUDG(X)) Q:X'=+X!(G) D
.S Y=+$P(BUDG(X),U,4)
.S Z=$P($G(^AUPNVPOV(Y,0)),U,1)
.S V=$P(BUDG(X),U,5)
.S C=$$PRIMPROV^APCLV(V,"D")
.Q:C=53
.Q:$P(^AUPNVSIT(V,0),U,7)="C"
.I $D(^BUDETSSC("AD",Z,T)) S G=1_"^"_$P(BUDG(X),U,5)_"|"_$P(BUDG(X),U,2) Q
.S S=$$VAL^XBDIQ1(9000010.07,Y,1101) I S]"",$D(^BUDETSSC("AS",S,T)) S G=1_"^"_$P(BUDG(X),U,5)_"|"_S Q
I G]"" Q G
PROBDX ;
S G=$$PLCL^BUDEDU(P,"T7 HTN DIAGNOSES",EDATE,0)
I G Q 1_U_"Problem List: "_$P(G,U,2)_" on "_$$DATE^BUDEUTL1($P(G,U,3))
Q ""
LASTBP(P,BDATE,EDATE) ;EP
;TABLE ALL BPs in date order
I $G(F)="" S F="E"
NEW BUDGLL,BUDGV,BUDG,A,B,E,Y,V,BUDBP,X,Z,BUDD
S BUDGLL=0,BUDGV=""
K ^TMP($J,"BPV")
K BUDBP
S BUDD=""
S A="^TMP($J,""BPV"",",B=P_"^LAST 365 MEAS BP;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"BPV",1)) Q ""
;SET UP ARRAY BY DATE
S BUDBP=""
K BUDG
S Y=0 F S Y=$O(^TMP($J,"BPV",Y)) Q:Y'=+Y D
.S V=$P(^TMP($J,"BPV",Y),U,5)
.;I $$CLINIC^APCLV(V,"C")=30 Q
.;Q:$$GDEV^BUD8D2(V)
.Q:'$D(^AUPNVMSR("AD",V))
.;NOW GET ALL BPS ON THIS VISIT
.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"
..Q:$P($G(^AUPNVMSR(X,2)),U,1)
..S BUDD=(9999999-$$VD^APCLV(V)) ;use this date
..S BUDG(BUDD,X)=$P(^AUPNVMSR(X,0),U,4)
K ^TMP($J,"BPV")
I '$O(BUDG(0)) Q "" ;no BPS
S BUDD=$O(BUDG(0)) ;use this date and check all AND get lowest S and D
S Y=0,S=99999,D=99999 F S Y=$O(BUDG(BUDD,Y)) Q:Y'=+Y!(BUDBP]"") D
.S Z=$P(BUDG(BUDD,Y),U,1) ;blood pressure value
.I $P(Z,"/")<S S S=$P(Z,"/")
.I $P(Z,"/",2)<D S D=$P(Z,"/",2)
I S]"",D]"" S BUDBP=S_"/"_D
K ^TMP($J,"BPV")
I BUDBP="" Q ""
Q 1_U_(9999999-BUDD)_U_"BP"_U_BUDBP
BUDERP7B ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
+1 ;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
+2 ;
HTN ;EP - list of HTN
+1 ;is patient pregnant during the time period BUDDD and BUDED
+2 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+3 SET BUDDDB=($EXTRACT(BUDBD,1,3)-85)_"0101"
+4 SET BUDDDE=($EXTRACT(BUDBD,1,3)-18)_"1231"
+5 IF BUDDOB>BUDDDE
QUIT
+6 IF BUDDOB<BUDDDB
QUIT
+7 IF BUDMEDV<1
QUIT
+8 ;
+9 SET BUDP=$$HTNDX(DFN,$$DOB^AUPNPAT(DFN),BUDCCAD)
+10 ;not dx'ed before june 30
IF '$PIECE(BUDP,U)
QUIT
+11 ;PREGNANCY
+12 IF $$PREG^BUDERP6B(DFN,BUDBD,BUDED,BUDBD)
QUIT
+13 IF $$EXCL(DFN,BUDDOB,BUDED)
QUIT
+14 SET BUDP=$$HTNDX(DFN,$$DOB^AUPNPAT(DFN),BUDED,1)
+15 SET BUDRACEX=$$RACE^BUDERPTC(DFN)
SET BUDRACE=$PIECE(BUDRACEX,U,2)
SET BUDRACEP=$PIECE(BUDRACEX,U,5)
+16 SET BUDRACEE=$$RACE^BUDERP7I(BUDRACE)
+17 SET BUDR=""
+18 SET BUDETHN=$PIECE($$HISP^BUDERPTC(DFN),U,1)
+19 IF +BUDETHN=1
SET BUDETHNN="Hispanic or Latino"
+20 IF +BUDETHN=2
SET BUDETHNN="Non-Hispanic/Latino"
+21 IF +BUDETHN=3
SET BUDETHNN="Unreported/Refused to Report"
+22 IF BUDRACEP=8
IF +BUDETHN=3
SET BUDR=1
GOTO SETSECTB
+23 IF +BUDETHN=1
SET BUDR=BUDRACEP
GOTO SETSECTB
+24 IF +BUDETHN=2
SET BUDR=BUDRACEP
GOTO SETSECTB
+25 ;I +BUDETHN=3,BUDRACEP=8 S BUDR=1
SETSECTB ;
+1 ;COL 1
SET $PIECE(BUDSECTB(+BUDETHN,BUDR),U,1)=$PIECE($GET(BUDSECTB(+BUDETHN,BUDR)),U,1)+1
+2 ;COL 2
SET $PIECE(BUDSECTB(+BUDETHN,BUDR),U,2)=$PIECE($GET(BUDSECTB(+BUDETHN,BUDR)),U,2)+1
+3 ;TOTAL LINE
+4 SET $PIECE(BUDSECTB(4),U,1)=$PIECE($GET(BUDSECTB(4)),U,1)+1
+5 SET $PIECE(BUDSECTB(4),U,2)=$PIECE($GET(BUDSECTB(4)),U,2)+1
+6 ;SUBTOTAL LINE
+7 SET $PIECE(BUDSECTB(+BUDETHN),U,1)=$PIECE($GET(BUDSECTB(+BUDETHN)),U,1)+1
+8 SET $PIECE(BUDSECTB(+BUDETHN),U,2)=$PIECE($GET(BUDSECTB(+BUDETHN)),U,2)+1
+9 IF $GET(BUDHTRL)
SET ^XTMP("BUDERP7",BUDJ,BUDH,"HTR",BUDRACEP,+BUDETHN,BUDCCOM,BUDAGE,$PIECE(^DPT(DFN,0),U),DFN)=$PIECE(BUDP,"^",2)
+10 ;I $G(BUDHTEL) S ^XTMP("BUDERP7",BUDJ,BUDH,"HTE",BUDETHNN,BUDCCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)
+11 ;now check BP
+12 SET BUDDP=$$LASTBP(DFN,BUDBD,BUDED)
+13 IF BUDDP]""
SET BUDV=$$BPCHK(BUDDP)
GOTO SET
+14 ;now check cpts
+15 SET T=$ORDER(^ATXAX("B","BUD SYSTOLIC BP CPTS",0))
+16 SET BUDS=$$CPT^BUDEDU(DFN,BUDBD,BUDED,T,6)
+17 SET T=$ORDER(^ATXAX("B","BUD DIASTOLIC BP CPTS",0))
+18 SET BUDD=$$CPT^BUDEDU(DFN,BUDBD,BUDED,T,6)
+19 ;DIDN'T HAVE BOTH IN TIME PERIOD
IF 'BUDS
IF 'BUDD
SET BUDV=0_U_"NO BP TAKEN DURING THE REPORT PERIOD"
GOTO SET
+20 SET S=$PIECE(BUDS,U,3)
+21 SET D=$PIECE(BUDD,U,3)
+22 SET G=0
+23 IF S="3074F"
IF D="3078F"
SET G=1
+24 IF S="3074F"
IF D="3079F"
SET G=1
+25 IF S="3075F"
IF D="3078F"
SET G=1
+26 IF S="3075F"
IF D="3079F"
SET G=1
+27 SET BUDV=G_U_"CPTs: "_$PIECE(BUDS,U,3)_" on "_$$FMTE^XLFDT($PIECE(BUDS,U,2))_" and "_$PIECE(BUDD,U,3)_" on "_$$FMTE^XLFDT($PIECE(BUDD,U,2))
SET ;
+1 IF $PIECE(BUDV,U)
Begin DoDot:1
+2 SET $PIECE(BUDSECTB(+BUDETHN,BUDR),U,3)=$PIECE($GET(BUDSECTB(+BUDETHN,BUDR)),U,3)+1
+3 SET $PIECE(BUDSECTB(4),U,3)=$PIECE($GET(BUDSECTB(4)),U,3)+1
+4 SET $PIECE(BUDSECTB(+BUDETHN),U,3)=$PIECE($GET(BUDSECTB(+BUDETHN)),U,3)+1
End DoDot:1
+5 ;I $P(BUDV,U) S $P(BUDSECTE(8),U,BUDETHN)=$P($G(BUDSECTE(8)),U,BUDETHN)+1,$P(BUDSECTE(8),U,9)=$P($G(BUDSECTE(8)),U,9)+1
+6 IF $GET(BUDHTCRL)
IF $PIECE(BUDV,U,1)
SET ^XTMP("BUDERP7",BUDJ,BUDH,"HTCR",BUDRACEP,+BUDETHN,BUDCCOM,BUDAGE,$PIECE(^DPT(DFN,0),U),DFN)=$PIECE(BUDP,"^",2)_"^"_$PIECE(BUDV,U,2)
+7 IF $GET(BUDHTURL)
IF '$PIECE(BUDV,U,1)
SET ^XTMP("BUDERP7",BUDJ,BUDH,"HTUR",BUDRACEP,+BUDETHN,BUDCCOM,BUDAGE,$PIECE(^DPT(DFN,0),U),DFN)=$PIECE(BUDP,"^",2)_"#"_$PIECE(BUDV,U,2)
+8 ;I $G(BUDHTCEL),$P(BUDV,U,1) S ^XTMP("BUDERP7",BUDJ,BUDH,"HTCE",BUDETHNN,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
+9 ;I $G(BUDHTUEL),'$P(BUDV,U,1) S ^XTMP("BUDERP7",BUDJ,BUDH,"HTUE",BUDETHNN,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
+10 QUIT
+11 ;
EXCL(P,BDATE,EDATE) ;EP
+1 NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB,BDATE
+2 SET BDATE=$$DOB^AUPNPAT(P)
+3 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+4 SET BUDTOB=0
+5 SET TIEN=$ORDER(^BUDETSSC("B","T7 HTN EXCLUSIONS",0))
+6 SET CTR=0
FOR
SET CTR=$ORDER(BUDVS(CTR))
IF CTR'=+CTR!(BUDTOB)
QUIT
Begin DoDot:1
+7 SET VIEN=$PIECE(BUDVS(CTR),U,5)
+8 SET VDATE=$PIECE(BUDVS(CTR),U,1)
+9 ;POV/SNOMED
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF X'=+X!(BUDTOB)
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+12 SET Y=$$VALI^XBDIQ1(9000010.07,X,.01)
IF $DATA(^BUDETSSC("AD",Y,TIEN))
SET BUDTOB=1
QUIT
+13 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+14 IF Y=""
QUIT
+15 IF $DATA(^BUDETSSC("AS",Y,TIEN))
SET BUDTOB=1
QUIT
End DoDot:2
+16 ;CPT
+17 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X!(BUDTOB)
QUIT
Begin DoDot:2
+18 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+19 SET Y=$$VAL^XBDIQ1(9000010.18,X,.01)
+20 IF Y=""
QUIT
+21 IF $DATA(^BUDETSSC("AC",Y,TIEN))
SET BUDTOB=1
QUIT
End DoDot:2
+22 ;V TRANS
+23 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X!(BUDTOB)
QUIT
Begin DoDot:2
+24 IF '$DATA(^AUPNVTC(X,0))
QUIT
+25 SET Y=$$VAL^XBDIQ1(9000010.33,X,.07)
+26 IF Y=""
QUIT
+27 IF $DATA(^BUDETSSC("AC",Y,TIEN))
SET BUDTOB=1
QUIT
End DoDot:2
+28 ;V PROC
+29 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AD",VIEN,X))
IF X'=+X!(BUDTOB)
QUIT
Begin DoDot:2
+30 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+31 SET Y=$$VALI^XBDIQ1(9000010.08,X,.01)
+32 IF $DATA(^BUDETSSC("AP",Y,TIEN))
SET BUDTOB=1
QUIT
End DoDot:2
End DoDot:1
+33 IF BUDTOB
QUIT 1
+34 SET Y=$$PLCL^BUDEDU(P,"T7 HTN EXCLUSIONS",EDATE,0)
+35 IF Y
QUIT 1
+36 QUIT ""
BPCHK(BP) ;
+1 NEW S,D
+2 SET S=$PIECE($PIECE(BP,U,4),"/")
+3 SET D=$PIECE($PIECE(BP,U,4),"/",2)
+4 IF S>139
QUIT 0_U_$PIECE(BP,U,4)_" "_$$FMTE^XLFDT($PIECE(BP,U,2))
+5 IF D>89
QUIT 0_U_$PIECE(BP,U,4)_" "_$$FMTE^XLFDT($PIECE(BP,U,2))
+6 QUIT 1_U_$PIECE(BP,U,4)_" "_$$FMTE^XLFDT($PIECE(BP,U,2))
RACE(R) ;EP
+1 IF R="Unreported"
QUIT 8
+2 IF R="Asian"
QUIT 1
+3 IF R="Native Hawaiian"
QUIT 2
+4 IF R="Other Pacific Islander"
QUIT 3
+5 IF R="Black/African American"
QUIT 4
+6 IF R="American Indian/Alaska Native"
QUIT 5
+7 IF R="White"
QUIT 6
+8 QUIT ""
HTNDX(P,BDATE,EDATE,STOP) ;EP
+1 NEW BUDDX,B,CNT,BUDD,BUDG,BUDALL
+2 SET STOP=$GET(STOP)
+3 ;if there is one before time frame set this to 1
SET B=0
SET CNT=0
SET BUDD=""
SET BUDALL=""
+4 ;
+5 ;V10.0 ICD10
+6 KILL BUDG
SET %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+7 SET T=$ORDER(^BUDETSSC("B","T7 HTN DIAGNOSES",0))
+8 SET X=0
SET G=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+9 SET Y=+$PIECE(BUDG(X),U,4)
+10 SET Z=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+11 SET V=$PIECE(BUDG(X),U,5)
+12 SET C=$$PRIMPROV^APCLV(V,"D")
+13 IF C=53
QUIT
+14 IF $PIECE(^AUPNVSIT(V,0),U,7)="C"
QUIT
+15 IF $DATA(^BUDETSSC("AD",Z,T))
SET G=1_"^"_$PIECE(BUDG(X),U,5)_"|"_$PIECE(BUDG(X),U,2)
QUIT
+16 SET S=$$VAL^XBDIQ1(9000010.07,Y,1101)
IF S]""
IF $DATA(^BUDETSSC("AS",S,T))
SET G=1_"^"_$PIECE(BUDG(X),U,5)_"|"_S
QUIT
End DoDot:1
+17 IF G]""
QUIT G
PROBDX ;
+1 SET G=$$PLCL^BUDEDU(P,"T7 HTN DIAGNOSES",EDATE,0)
+2 IF G
QUIT 1_U_"Problem List: "_$PIECE(G,U,2)_" on "_$$DATE^BUDEUTL1($PIECE(G,U,3))
+3 QUIT ""
LASTBP(P,BDATE,EDATE) ;EP
+1 ;TABLE ALL BPs in date order
+2 IF $GET(F)=""
SET F="E"
+3 NEW BUDGLL,BUDGV,BUDG,A,B,E,Y,V,BUDBP,X,Z,BUDD
+4 SET BUDGLL=0
SET BUDGV=""
+5 KILL ^TMP($JOB,"BPV")
+6 KILL BUDBP
+7 SET BUDD=""
+8 SET A="^TMP($J,""BPV"","
SET B=P_"^LAST 365 MEAS BP;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+9 IF '$DATA(^TMP($JOB,"BPV",1))
QUIT ""
+10 ;SET UP ARRAY BY DATE
+11 SET BUDBP=""
+12 KILL BUDG
+13 SET Y=0
FOR
SET Y=$ORDER(^TMP($JOB,"BPV",Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+14 SET V=$PIECE(^TMP($JOB,"BPV",Y),U,5)
+15 ;I $$CLINIC^APCLV(V,"C")=30 Q
+16 ;Q:$$GDEV^BUD8D2(V)
+17 IF '$DATA(^AUPNVMSR("AD",V))
QUIT
+18 ;NOW GET ALL BPS ON THIS VISIT
+19 SET X=0
FOR
SET X=$ORDER(^AUPNVMSR("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:2
+20 ;BAD AD XREF
IF '$DATA(^AUPNVMSR(X,0))
QUIT
+21 SET T=$PIECE($GET(^AUPNVMSR(X,0)),U)
+22 ;BAD AD XREF
IF T=""
QUIT
+23 IF $PIECE($GET(^AUTTMSR(T,0)),U)'="BP"
QUIT
+24 IF $PIECE($GET(^AUPNVMSR(X,2)),U,1)
QUIT
+25 ;use this date
SET BUDD=(9999999-$$VD^APCLV(V))
+26 SET BUDG(BUDD,X)=$PIECE(^AUPNVMSR(X,0),U,4)
End DoDot:2
End DoDot:1
+27 KILL ^TMP($JOB,"BPV")
+28 ;no BPS
IF '$ORDER(BUDG(0))
QUIT ""
+29 ;use this date and check all AND get lowest S and D
SET BUDD=$ORDER(BUDG(0))
+30 SET Y=0
SET S=99999
SET D=99999
FOR
SET Y=$ORDER(BUDG(BUDD,Y))
IF Y'=+Y!(BUDBP]"")
QUIT
Begin DoDot:1
+31 ;blood pressure value
SET Z=$PIECE(BUDG(BUDD,Y),U,1)
+32 IF $PIECE(Z,"/")<S
SET S=$PIECE(Z,"/")
+33 IF $PIECE(Z,"/",2)<D
SET D=$PIECE(Z,"/",2)
End DoDot:1
+34 IF S]""
IF D]""
SET BUDBP=S_"/"_D
+35 KILL ^TMP($JOB,"BPV")
+36 IF BUDBP=""
QUIT ""
+37 QUIT 1_U_(9999999-BUDD)_U_"BP"_U_BUDBP
