BUDARP7B ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2013 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)
S BUDBDB=($E(BUDBD,1,3)-85)_"0101"
S BUDBDE=($E(BUDBD,1,3)-18)_"1231"
Q:BUDDOB>BUDBDE
Q:BUDDOB<BUDBDB
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 BUDRACEX=$$RACE^BUDARPTC(DFN),BUDRACE=$P(BUDRACEX,U,2),BUDRACEP=$P(BUDRACEX,U,5)
S BUDRACEE=$$RACE^BUDARP7I(BUDRACE)
S BUDR=""
S BUDETHN=$P($$HISP^BUDARPTC(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("BUDARP7",BUDJ,BUDH,"HTR",BUDRACEP,+BUDETHN,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)
;I $G(BUDHTEL) S ^XTMP("BUDARP7",BUDJ,BUDH,"HTE",BUDETHNN,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)
;now check BP
S BUDBP=$$LASTITEM^BUDADU(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^BUDADU(DFN,BUDBD,BUDED,T,6)
S T=$O(^ATXAX("B","BUD DIASTOLIC BP CPTS",0))
S BUDD=$$CPT^BUDADU(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("BUDARP7",BUDJ,BUDH,"HTCR",BUDRACEP,+BUDETHN,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
I $G(BUDHTURL),'$P(BUDV,U,1) S ^XTMP("BUDARP7",BUDJ,BUDH,"HTUR",BUDRACEP,+BUDETHN,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)_"#"_$P(BUDV,U,2)
;I $G(BUDHTCEL),$P(BUDV,U,1) S ^XTMP("BUDARP7",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("BUDARP7",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 ""
;
BUDARP7B ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2013 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 SET BUDBDB=($EXTRACT(BUDBD,1,3)-85)_"0101"
+4 SET BUDBDE=($EXTRACT(BUDBD,1,3)-18)_"1231"
+5 IF BUDDOB>BUDBDE
QUIT
+6 IF BUDDOB<BUDBDB
QUIT
+7 IF BUDMEDV<2
QUIT
+8 ;
+9 SET BUDP=$$HTNDX(DFN,$$DOB^AUPNPAT(DFN),BUDCAD)
+10 ;not dx'ed before june 30
IF '$PIECE(BUDP,U)
QUIT
+11 SET BUDP=$$HTNDX(DFN,$$DOB^AUPNPAT(DFN),BUDED,1)
+12 SET BUDRACEX=$$RACE^BUDARPTC(DFN)
SET BUDRACE=$PIECE(BUDRACEX,U,2)
SET BUDRACEP=$PIECE(BUDRACEX,U,5)
+13 SET BUDRACEE=$$RACE^BUDARP7I(BUDRACE)
+14 SET BUDR=""
+15 SET BUDETHN=$PIECE($$HISP^BUDARPTC(DFN),U,1)
+16 IF +BUDETHN=1
SET BUDETHNN="Hispanic or Latino"
+17 IF +BUDETHN=2
SET BUDETHNN="Non-Hispanic/Latino"
+18 IF +BUDETHN=3
SET BUDETHNN="Unreported/Refused to Report"
+19 IF BUDRACEP=8
IF +BUDETHN=3
SET BUDR=1
GOTO SETSECTB
+20 IF +BUDETHN=1
SET BUDR=BUDRACEP
GOTO SETSECTB
+21 IF +BUDETHN=2
SET BUDR=BUDRACEP
GOTO SETSECTB
+22 ;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("BUDARP7",BUDJ,BUDH,"HTR",BUDRACEP,+BUDETHN,BUDCOM,BUDAGE,$PIECE(^DPT(DFN,0),U),DFN)=$PIECE(BUDP,"^",2)
+10 ;I $G(BUDHTEL) S ^XTMP("BUDARP7",BUDJ,BUDH,"HTE",BUDETHNN,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)
+11 ;now check BP
+12 SET BUDBP=$$LASTITEM^BUDADU(DFN,BUDBD,BUDED,"MEASUREMENT","BP")
+13 IF BUDBP]""
SET BUDV=$$BPCHK(BUDBP)
GOTO SET
+14 ;now check cpts
+15 SET T=$ORDER(^ATXAX("B","BUD SYSTOLIC BP CPTS",0))
+16 SET BUDS=$$CPT^BUDADU(DFN,BUDBD,BUDED,T,6)
+17 SET T=$ORDER(^ATXAX("B","BUD DIASTOLIC BP CPTS",0))
+18 SET BUDD=$$CPT^BUDADU(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("BUDARP7",BUDJ,BUDH,"HTCR",BUDRACEP,+BUDETHN,BUDCOM,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("BUDARP7",BUDJ,BUDH,"HTUR",BUDRACEP,+BUDETHN,BUDCOM,BUDAGE,$PIECE(^DPT(DFN,0),U),DFN)=$PIECE(BUDP,"^",2)_"#"_$PIECE(BUDV,U,2)
+8 ;I $G(BUDHTCEL),$P(BUDV,U,1) S ^XTMP("BUDARP7",BUDJ,BUDH,"HTCE",BUDETHNN,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
+9 ;I $G(BUDHTUEL),'$P(BUDV,U,1) S ^XTMP("BUDARP7",BUDJ,BUDH,"HTUE",BUDETHNN,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
+10 QUIT
+11 ;
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 ;
