BUD8RP7B ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2008 5:11 PM ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
HTN ;EP - list of HTN
;is patient pregnant during the time period BUDBD and BUDED
S BUDDOB=$P(^DPT(DFN,0),U,3)
Q:BUDDOB>2901231
Q:BUDDOB>2851231 ;2003 TESTING
Q:BUDMEDV<2
;
S BUDP=$$HTNDX(DFN,$$DOB^AUPNPAT(DFN),BUDCAD)
I '$P(BUDP,U) Q ;not dx'ed before june 30
S BUDP=$$HTNDX(DFN,$$DOB^AUPNPAT(DFN),BUDED,1)
S BUDRACE=$$RACE^BUD8RPTC(DFN),BUDRACE=$P(BUDRACE,U,2)
S BUDRACE=$$RACE^BUD8RP7I(BUDRACE),BUDR=$$RACE(BUDRACE)
S BUDETHN=$P($$HISP^BUD8RPTC(DFN),U,1)
I +BUDETHN=1 S BUDETHNN="Hispanic or Latino"
I +BUDETHN=2 S BUDETHNN="All Others"
S $P(BUDSECTB(6),U,BUDR)=$P($G(BUDSECTB(6)),U,BUDR)+1
S $P(BUDSECTB(7),U,BUDR)=$P($G(BUDSECTB(7)),U,BUDR)+1
S $P(BUDSECTB(6),U,9)=$P($G(BUDSECTB(6)),U,9)+1
S $P(BUDSECTB(7),U,9)=$P($G(BUDSECTB(7)),U,9)+1
S $P(BUDSECTE(6),U,BUDETHN)=$P($G(BUDSECTE(6)),U,BUDETHN)+1
S $P(BUDSECTE(7),U,BUDETHN)=$P($G(BUDSECTE(7)),U,BUDETHN)+1
S $P(BUDSECTE(6),U,3)=$P($G(BUDSECTE(6)),U,3)+1
S $P(BUDSECTE(7),U,3)=$P($G(BUDSECTE(7)),U,3)+1
I $G(BUDHTRL) S ^XTMP("BUD8RP7",BUDJ,BUDH,"HTR",BUDRACE,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)
I $G(BUDHTEL) S ^XTMP("BUD8RP7",BUDJ,BUDH,"HTE",BUDETHNN,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)
;now check BP
S BUDBP=$$LASTITEM^BUD8DU(DFN,BUDBD,BUDED,"MEASUREMENT","BP")
I BUDBP]"" S BUDV=$$BPCHK(BUDBP) G SET
;now check cpts
S T=$O(^ATXAX("B","BUD SYSTOLIC BP CPTS",0))
S BUDS=$$CPT^BUD8DU(DFN,BUDBD,BUDED,T,6)
S T=$O(^ATXAX("B","BUD DIASTOLIC BP CPTS",0))
S BUDD=$$CPT^BUD8DU(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) S $P(BUDSECTB(8),U,BUDR)=$P($G(BUDSECTB(8)),U,BUDR)+1,$P(BUDSECTB(8),U,9)=$P($G(BUDSECTB(8)),U,9)+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("BUD8RP7",BUDJ,BUDH,"HTCR",BUDRACE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
I $G(BUDHTURL),'$P(BUDV,U,1) S ^XTMP("BUD8RP7",BUDJ,BUDH,"HTUR",BUDRACE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
I $G(BUDHTCEL),$P(BUDV,U,1) S ^XTMP("BUD8RP7",BUDJ,BUDH,"HTCE",BUDETHNN,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
I $G(BUDHTUEL),'$P(BUDV,U,1) S ^XTMP("BUD8RP7",BUDJ,BUDH,"HTUE",BUDETHNN,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
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
K BUDG
S Y="BUDG("
S X=P_"^LAST DX [BUD HYPERTENSION DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BUDG(1)) Q 1_"^"_$P(BUDG(1),U,5)_"|"_$P(BUDG(1),U,2)
I STOP Q ""
PROBDX S T=$O(^ATXAX("B","BUD HYPERTENSION DXS",0))
S (X,G)=0,Z="" 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,8)>EDATE
.Q:$P(^AUPNPROB(X,0),U,8)<BDATE
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^ATXCHK(Y,T,9)
.S G=$P(^AUPNPROB(X,0),U,8),Z=X
.Q
I G Q 1_U_"Problem List: "_$$VAL^XBDIQ1(9000011,Z,.01)_" on "_$$FMTE^XLFDT($P(^AUPNPROB(Z,0),U,8))
Q ""
;
BUD8RP7B ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2008 5:11 PM ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
HTN ;EP - list of HTN
+1 ;is patient pregnant during the time period BUDBD and BUDED
+2 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+3 IF BUDDOB>2901231
QUIT
+4 ;2003 TESTING
IF BUDDOB>2851231
QUIT
+5 IF BUDMEDV<2
QUIT
+6 ;
+7 SET BUDP=$$HTNDX(DFN,$$DOB^AUPNPAT(DFN),BUDCAD)
+8 ;not dx'ed before june 30
IF '$PIECE(BUDP,U)
QUIT
+9 SET BUDP=$$HTNDX(DFN,$$DOB^AUPNPAT(DFN),BUDED,1)
+10 SET BUDRACE=$$RACE^BUD8RPTC(DFN)
SET BUDRACE=$PIECE(BUDRACE,U,2)
+11 SET BUDRACE=$$RACE^BUD8RP7I(BUDRACE)
SET BUDR=$$RACE(BUDRACE)
+12 SET BUDETHN=$PIECE($$HISP^BUD8RPTC(DFN),U,1)
+13 IF +BUDETHN=1
SET BUDETHNN="Hispanic or Latino"
+14 IF +BUDETHN=2
SET BUDETHNN="All Others"
+15 SET $PIECE(BUDSECTB(6),U,BUDR)=$PIECE($GET(BUDSECTB(6)),U,BUDR)+1
+16 SET $PIECE(BUDSECTB(7),U,BUDR)=$PIECE($GET(BUDSECTB(7)),U,BUDR)+1
+17 SET $PIECE(BUDSECTB(6),U,9)=$PIECE($GET(BUDSECTB(6)),U,9)+1
+18 SET $PIECE(BUDSECTB(7),U,9)=$PIECE($GET(BUDSECTB(7)),U,9)+1
+19 SET $PIECE(BUDSECTE(6),U,BUDETHN)=$PIECE($GET(BUDSECTE(6)),U,BUDETHN)+1
+20 SET $PIECE(BUDSECTE(7),U,BUDETHN)=$PIECE($GET(BUDSECTE(7)),U,BUDETHN)+1
+21 SET $PIECE(BUDSECTE(6),U,3)=$PIECE($GET(BUDSECTE(6)),U,3)+1
+22 SET $PIECE(BUDSECTE(7),U,3)=$PIECE($GET(BUDSECTE(7)),U,3)+1
+23 IF $GET(BUDHTRL)
SET ^XTMP("BUD8RP7",BUDJ,BUDH,"HTR",BUDRACE,BUDCOM,BUDAGE,$PIECE(^DPT(DFN,0),U),DFN)=$PIECE(BUDP,"^",2)
+24 IF $GET(BUDHTEL)
SET ^XTMP("BUD8RP7",BUDJ,BUDH,"HTE",BUDETHNN,BUDCOM,BUDAGE,$PIECE(^DPT(DFN,0),U),DFN)=$PIECE(BUDP,"^",2)
+25 ;now check BP
+26 SET BUDBP=$$LASTITEM^BUD8DU(DFN,BUDBD,BUDED,"MEASUREMENT","BP")
+27 IF BUDBP]""
SET BUDV=$$BPCHK(BUDBP)
GOTO SET
+28 ;now check cpts
+29 SET T=$ORDER(^ATXAX("B","BUD SYSTOLIC BP CPTS",0))
+30 SET BUDS=$$CPT^BUD8DU(DFN,BUDBD,BUDED,T,6)
+31 SET T=$ORDER(^ATXAX("B","BUD DIASTOLIC BP CPTS",0))
+32 SET BUDD=$$CPT^BUD8DU(DFN,BUDBD,BUDED,T,6)
+33 ;DIDN'T HAVE BOTH IN TIME PERIOD
IF 'BUDS
IF 'BUDD
SET BUDV=0_U_"NO BP TAKEN DURING THE REPORT PERIOD"
GOTO SET
+34 SET S=$PIECE(BUDS,U,3)
+35 SET D=$PIECE(BUDD,U,3)
+36 SET G=0
+37 IF S="3074F"
IF D="3078F"
SET G=1
+38 IF S="3074F"
IF D="3079F"
SET G=1
+39 IF S="3075F"
IF D="3078F"
SET G=1
+40 IF S="3075F"
IF D="3079F"
SET G=1
+41 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)
SET $PIECE(BUDSECTB(8),U,BUDR)=$PIECE($GET(BUDSECTB(8)),U,BUDR)+1
SET $PIECE(BUDSECTB(8),U,9)=$PIECE($GET(BUDSECTB(8)),U,9)+1
+2 IF $PIECE(BUDV,U)
SET $PIECE(BUDSECTE(8),U,BUDETHN)=$PIECE($GET(BUDSECTE(8)),U,BUDETHN)+1
SET $PIECE(BUDSECTE(8),U,9)=$PIECE($GET(BUDSECTE(8)),U,9)+1
+3 IF $GET(BUDHTCRL)
IF $PIECE(BUDV,U,1)
SET ^XTMP("BUD8RP7",BUDJ,BUDH,"HTCR",BUDRACE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=$PIECE(BUDP,"^",2)_"^"_$PIECE(BUDV,U,2)
+4 IF $GET(BUDHTURL)
IF '$PIECE(BUDV,U,1)
SET ^XTMP("BUD8RP7",BUDJ,BUDH,"HTUR",BUDRACE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=$PIECE(BUDP,"^",2)_"^"_$PIECE(BUDV,U,2)
+5 IF $GET(BUDHTCEL)
IF $PIECE(BUDV,U,1)
SET ^XTMP("BUD8RP7",BUDJ,BUDH,"HTCE",BUDETHNN,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=$PIECE(BUDP,"^",2)_"^"_$PIECE(BUDV,U,2)
+6 IF $GET(BUDHTUEL)
IF '$PIECE(BUDV,U,1)
SET ^XTMP("BUD8RP7",BUDJ,BUDH,"HTUE",BUDETHNN,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=$PIECE(BUDP,"^",2)_"^"_$PIECE(BUDV,U,2)
+7 QUIT
+8 ;
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 KILL BUDG
+5 SET Y="BUDG("
+6 SET X=P_"^LAST DX [BUD HYPERTENSION DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+7 IF $DATA(BUDG(1))
QUIT 1_"^"_$PIECE(BUDG(1),U,5)_"|"_$PIECE(BUDG(1),U,2)
+8 IF STOP
QUIT ""
PROBDX SET T=$ORDER(^ATXAX("B","BUD HYPERTENSION DXS",0))
+1 SET (X,G)=0
SET Z=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+2 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
QUIT
+3 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+4 IF $PIECE(^AUPNPROB(X,0),U,8)<BDATE
QUIT
+5 SET Y=$PIECE(^AUPNPROB(X,0),U)
+6 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+7 SET G=$PIECE(^AUPNPROB(X,0),U,8)
SET Z=X
+8 QUIT
End DoDot:1
+9 IF G
QUIT 1_U_"Problem List: "_$$VAL^XBDIQ1(9000011,Z,.01)_" on "_$$FMTE^XLFDT($PIECE(^AUPNPROB(Z,0),U,8))
+10 QUIT ""
+11 ;
