Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BUD2RP7B

BUD2RP7B.m

Go to the documentation of this file. 
  1. BUD2RP7B ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2012 5:11 PM ;
  1.  ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
  1.  ;
  1. HTN ;EP - list of HTN
  1.  ;is patient pregnant during the time period BUDBD and BUDED
  1.  S BUDDOB=$P(^DPT(DFN,0),U,3)
  1.  S BUDBDB=($E(BUDBD,1,3)-85)_"0101"
  1.  S BUDBDE=($E(BUDBD,1,3)-18)_"1231"
  1.  Q:BUDDOB>BUDBDE
  1.  Q:BUDDOB<BUDBDB
  1.  Q:BUDMEDV<2
  1.  ;
  1.  S BUDP=$$HTNDX(DFN,$$DOB^AUPNPAT(DFN),BUDCAD)
  1.  I '$P(BUDP,U) Q  ;not dx'ed before june 30
  1.  S BUDP=$$HTNDX(DFN,$$DOB^AUPNPAT(DFN),BUDED,1)
  1.  S BUDRACEX=$$RACE^BUD2RPTC(DFN),BUDRACE=$P(BUDRACEX,U,2),BUDRACEP=$P(BUDRACEX,U,5)
  1.  S BUDRACEE=$$RACE^BUD2RP7I(BUDRACE)
  1.  S BUDR=""
  1.  S BUDETHN=$P($$HISP^BUD2RPTC(DFN),U,1)
  1.  I +BUDETHN=1 S BUDETHNN="Hispanic or Latino"
  1.  I +BUDETHN=2 S BUDETHNN="Non-Hispanic/Latino"
  1.  I +BUDETHN=3 S BUDETHNN="Unreported/Refused to Report"
  1.  I BUDRACEP=8,+BUDETHN=3 S BUDR=1 G SETSECTB
  1.  I +BUDETHN=1 S BUDR=BUDRACEP G SETSECTB
  1.  I +BUDETHN=2 S BUDR=BUDRACEP G SETSECTB
  1.  ;I +BUDETHN=3,BUDRACEP=8 S BUDR=1
  1. SETSECTB ;
  1.  S $P(BUDSECTB(+BUDETHN,BUDR),U,1)=$P($G(BUDSECTB(+BUDETHN,BUDR)),U,1)+1  ;COL 1
  1.  S $P(BUDSECTB(+BUDETHN,BUDR),U,2)=$P($G(BUDSECTB(+BUDETHN,BUDR)),U,2)+1  ;COL 2
  1.  ;TOTAL LINE
  1.  S $P(BUDSECTB(4),U,1)=$P($G(BUDSECTB(4)),U,1)+1
  1.  S $P(BUDSECTB(4),U,2)=$P($G(BUDSECTB(4)),U,2)+1
  1.  ;SUBTOTAL LINE
  1.  S $P(BUDSECTB(+BUDETHN),U,1)=$P($G(BUDSECTB(+BUDETHN)),U,1)+1
  1.  S $P(BUDSECTB(+BUDETHN),U,2)=$P($G(BUDSECTB(+BUDETHN)),U,2)+1
  1.  I $G(BUDHTRL) S ^XTMP("BUD2RP7",BUDJ,BUDH,"HTR",BUDRACEP,+BUDETHN,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)
  1.  ;I $G(BUDHTEL) S ^XTMP("BUD2RP7",BUDJ,BUDH,"HTE",BUDETHNN,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)
  1.  ;now check BP
  1.  S BUDBP=$$LASTITEM^BUD2DU(DFN,BUDBD,BUDED,"MEASUREMENT","BP")
  1.  I BUDBP]"" S BUDV=$$BPCHK(BUDBP) G SET
  1.  ;now check cpts
  1.  S T=$O(^ATXAX("B","BUD SYSTOLIC BP CPTS",0))
  1.  S BUDS=$$CPT^BUD2DU(DFN,BUDBD,BUDED,T,6)
  1.  S T=$O(^ATXAX("B","BUD DIASTOLIC BP CPTS",0))
  1.  S BUDD=$$CPT^BUD2DU(DFN,BUDBD,BUDED,T,6)
  1.  I 'BUDS,'BUDD S BUDV=0_U_"NO BP TAKEN DURING THE REPORT PERIOD" G SET  ;DIDN'T HAVE BOTH IN TIME PERIOD
  1.  S S=$P(BUDS,U,3)
  1.  S D=$P(BUDD,U,3)
  1.  S G=0
  1.  I S="3074F",D="3078F" S G=1
  1.  I S="3074F",D="3079F" S G=1
  1.  I S="3075F",D="3078F" S G=1
  1.  I S="3075F",D="3079F" S G=1
  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))
  1. SET ;
  1.  I $P(BUDV,U) D
  1.  .S $P(BUDSECTB(+BUDETHN,BUDR),U,3)=$P($G(BUDSECTB(+BUDETHN,BUDR)),U,3)+1
  1.  .S $P(BUDSECTB(4),U,3)=$P($G(BUDSECTB(4)),U,3)+1
  1.  .S $P(BUDSECTB(+BUDETHN),U,3)=$P($G(BUDSECTB(+BUDETHN)),U,3)+1
  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
  1.  I $G(BUDHTCRL),$P(BUDV,U,1) S ^XTMP("BUD2RP7",BUDJ,BUDH,"HTCR",BUDRACEP,+BUDETHN,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
  1.  I $G(BUDHTURL),'$P(BUDV,U,1) S ^XTMP("BUD2RP7",BUDJ,BUDH,"HTUR",BUDRACEP,+BUDETHN,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)_"#"_$P(BUDV,U,2)
  1.  ;I $G(BUDHTCEL),$P(BUDV,U,1) S ^XTMP("BUD2RP7",BUDJ,BUDH,"HTCE",BUDETHNN,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
  1.  ;I $G(BUDHTUEL),'$P(BUDV,U,1) S ^XTMP("BUD2RP7",BUDJ,BUDH,"HTUE",BUDETHNN,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
  1.  Q
  1.  ;
  1. BPCHK(BP) ;
  1.  NEW S,D
  1.  S S=$P($P(BP,U,4),"/")
  1.  S D=$P($P(BP,U,4),"/",2)
  1.  I S>139 Q 0_U_$P(BP,U,4)_"  "_$$FMTE^XLFDT($P(BP,U,2))
  1.  I D>89 Q 0_U_$P(BP,U,4)_"  "_$$FMTE^XLFDT($P(BP,U,2))
  1.  Q 1_U_$P(BP,U,4)_"  "_$$FMTE^XLFDT($P(BP,U,2))
  1. RACE(R) ;EP
  1.  I R="Unreported" Q 8
  1.  I R="Asian" Q 1
  1.  I R="Native Hawaiian" Q 2
  1.  I R="Other Pacific Islander" Q 3
  1.  I R="Black/African American" Q 4
  1.  I R="American Indian/Alaska Native" Q 5
  1.  I R="White" Q 6
  1.  Q ""
  1. HTNDX(P,BDATE,EDATE,STOP) ;EP
  1.  NEW BUDDX,B,CNT,BUDD,BUDG,BUDALL
  1.  S STOP=$G(STOP)
  1.  S B=0,CNT=0,BUDD="",BUDALL=""  ;if there is one before time frame set this to 1
  1.  K BUDG
  1.  S Y="BUDG("
  1.  S X=P_"^LAST DX [BUD HYPERTENSION DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1.  I $D(BUDG(1)) Q 1_"^"_$P(BUDG(1),U,5)_"|"_$P(BUDG(1),U,2)
  1.  I STOP Q ""
  1. PROBDX S T=$O(^ATXAX("B","BUD HYPERTENSION DXS",0))
  1.  S (X,G)=0,Z="" F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G)  D
  1.  .Q:$P(^AUPNPROB(X,0),U,12)'="A"
  1.  .Q:$P(^AUPNPROB(X,0),U,8)>EDATE
  1.  .Q:$P(^AUPNPROB(X,0),U,8)<BDATE
  1.  .S Y=$P(^AUPNPROB(X,0),U)
  1.  .Q:'$$ICD^ATXCHK(Y,T,9)
  1.  .S G=$P(^AUPNPROB(X,0),U,8),Z=X
  1.  .Q
  1.  I G Q 1_U_"Problem List: "_$$VAL^XBDIQ1(9000011,Z,.01)_" on "_$$FMTE^XLFDT($P(^AUPNPROB(Z,0),U,8))
  1.  Q ""
  1.  ;