BUDCRP7B ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
HTN ;EP - list of HTN
;is patient pregnant during the time period BUDCD and BUDED
S BUDDOB=$P(^DPT(DFN,0),U,3)
S BUDCDB=($E(BUDBD,1,3)-85)_"0101"
S BUDCDE=($E(BUDBD,1,3)-18)_"1231"
Q:BUDDOB>BUDCDE
Q:BUDDOB<BUDCDB
Q:BUDMEDV<2
;
S BUDP=$$HTNDX(DFN,$$DOB^AUPNPAT(DFN),BUDCAD)
I '$P(BUDP,U) Q ;not dx'ed before june 30
;PREGNANCY
Q:$$PREG^BUDCRP7A(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED)
Q:$$ESRD(DFN,BUDDOB,BUDED)
S BUDP=$$HTNDX(DFN,$$DOB^AUPNPAT(DFN),BUDED,1)
S BUDRACEX=$$RACE^BUDCRPTC(DFN),BUDRACE=$P(BUDRACEX,U,2),BUDRACEP=$P(BUDRACEX,U,5)
S BUDRACEE=$$RACE^BUDCRP7I(BUDRACE)
S BUDR=""
S BUDETHN=$P($$HISP^BUDCRPTC(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("BUDCRP7",BUDJ,BUDH,"HTR",BUDRACEP,+BUDETHN,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)
;I $G(BUDHTEL) S ^XTMP("BUDCRP7",BUDJ,BUDH,"HTE",BUDETHNN,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)
;now check BP
S BUDCP=$$LASTITEM^BUDCDU(DFN,BUDBD,BUDED,"MEASUREMENT","BP")
I BUDCP]"" S BUDV=$$BPCHK(BUDCP) G SET
;now check cpts
S T=$O(^ATXAX("B","BUD SYSTOLIC BP CPTS",0))
S BUDS=$$CPT^BUDCDU(DFN,BUDBD,BUDED,T,6)
S T=$O(^ATXAX("B","BUD DIASTOLIC BP CPTS",0))
S BUDD=$$CPT^BUDCDU(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("BUDCRP7",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("BUDCRP7",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("BUDCRP7",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("BUDCRP7",BUDJ,BUDH,"HTUE",BUDETHNN,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
Q
;
ESRD(P,BDATE,EDATE) ;EP
NEW X,T
S X=$$LASTDX^BGP6UTL1(P,"BGP ESRD PMS DXS",BDATE,EDATE)
I X Q 1_U_"POV "_$P(X,U,2)_U_$P(X,U,3)
S T=$O(^ATXAX("B","BGP ESRD CPTS",0))
I T D I X]"" Q 1_U_"CPT "_$P(X,U,2)_U_$P(X,U,1)
.S X=$$CPT^BGP6DU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP6DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
S X=$$LASTPRC^BGP6UTL1(P,"BGP ESRD PROCS",BDATE,EDATE)
I X Q 1_U_"PRC "_$P(X,U,2)_U_$P(X,U,3)
Q 0
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(^BUDCTSSC("B","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 Y=$P($G(^AUPNVPOV(Y,0)),U,1)
.I $D(^BUDCTSSC("AD",Y,T)) S G=1_"^"_$P(BUDG(X),U,5)_"|"_$P(BUDG(X),U,2)
I G]"" Q G
PROBDX S T=$O(^BUDCTSSC("B","HTN DIAGNOSES",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)="D"
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.Q:$P(^AUPNPROB(X,0),U,8)<BDATE
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$D(^BUDCTSSC("AD",Y,T))
.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 ""
BUDCRP7B ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
+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 BUDCD and BUDED
+2 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+3 SET BUDCDB=($EXTRACT(BUDBD,1,3)-85)_"0101"
+4 SET BUDCDE=($EXTRACT(BUDBD,1,3)-18)_"1231"
+5 IF BUDDOB>BUDCDE
QUIT
+6 IF BUDDOB<BUDCDB
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 ;PREGNANCY
+12 IF $$PREG^BUDCRP7A(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED)
QUIT
+13 IF $$ESRD(DFN,BUDDOB,BUDED)
QUIT
+14 SET BUDP=$$HTNDX(DFN,$$DOB^AUPNPAT(DFN),BUDED,1)
+15 SET BUDRACEX=$$RACE^BUDCRPTC(DFN)
SET BUDRACE=$PIECE(BUDRACEX,U,2)
SET BUDRACEP=$PIECE(BUDRACEX,U,5)
+16 SET BUDRACEE=$$RACE^BUDCRP7I(BUDRACE)
+17 SET BUDR=""
+18 SET BUDETHN=$PIECE($$HISP^BUDCRPTC(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("BUDCRP7",BUDJ,BUDH,"HTR",BUDRACEP,+BUDETHN,BUDCOM,BUDAGE,$PIECE(^DPT(DFN,0),U),DFN)=$PIECE(BUDP,"^",2)
+10 ;I $G(BUDHTEL) S ^XTMP("BUDCRP7",BUDJ,BUDH,"HTE",BUDETHNN,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)
+11 ;now check BP
+12 SET BUDCP=$$LASTITEM^BUDCDU(DFN,BUDBD,BUDED,"MEASUREMENT","BP")
+13 IF BUDCP]""
SET BUDV=$$BPCHK(BUDCP)
GOTO SET
+14 ;now check cpts
+15 SET T=$ORDER(^ATXAX("B","BUD SYSTOLIC BP CPTS",0))
+16 SET BUDS=$$CPT^BUDCDU(DFN,BUDBD,BUDED,T,6)
+17 SET T=$ORDER(^ATXAX("B","BUD DIASTOLIC BP CPTS",0))
+18 SET BUDD=$$CPT^BUDCDU(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("BUDCRP7",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("BUDCRP7",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("BUDCRP7",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("BUDCRP7",BUDJ,BUDH,"HTUE",BUDETHNN,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
+10 QUIT
+11 ;
ESRD(P,BDATE,EDATE) ;EP
+1 NEW X,T
+2 SET X=$$LASTDX^BGP6UTL1(P,"BGP ESRD PMS DXS",BDATE,EDATE)
+3 IF X
QUIT 1_U_"POV "_$PIECE(X,U,2)_U_$PIECE(X,U,3)
+4 SET T=$ORDER(^ATXAX("B","BGP ESRD CPTS",0))
+5 IF T
Begin DoDot:1
+6 SET X=$$CPT^BGP6DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
IF X]""
QUIT
+7 SET X=$$TRAN^BGP6DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
End DoDot:1
IF X]""
QUIT 1_U_"CPT "_$PIECE(X,U,2)_U_$PIECE(X,U,1)
+8 SET X=$$LASTPRC^BGP6UTL1(P,"BGP ESRD PROCS",BDATE,EDATE)
+9 IF X
QUIT 1_U_"PRC "_$PIECE(X,U,2)_U_$PIECE(X,U,3)
+10 QUIT 0
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(^BUDCTSSC("B","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 Y=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+11 IF $DATA(^BUDCTSSC("AD",Y,T))
SET G=1_"^"_$PIECE(BUDG(X),U,5)_"|"_$PIECE(BUDG(X),U,2)
End DoDot:1
+12 IF G]""
QUIT G
PROBDX SET T=$ORDER(^BUDCTSSC("B","HTN DIAGNOSES",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)="D"
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 '$DATA(^BUDCTSSC("AD",Y,T))
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 ""
