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

BUDCRP7B.m

Go to the documentation of this file. 
  1. BUDCRP7B ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
  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 BUDCD and BUDED
  1.  S BUDDOB=$P(^DPT(DFN,0),U,3)
  1.  S BUDCDB=($E(BUDBD,1,3)-85)_"0101"
  1.  S BUDCDE=($E(BUDBD,1,3)-18)_"1231"
  1.  Q:BUDDOB>BUDCDE
  1.  Q:BUDDOB<BUDCDB
  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.  ;PREGNANCY
  1.  Q:$$PREG^BUDCRP7A(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED)
  1.  Q:$$ESRD(DFN,BUDDOB,BUDED)
  1.  S BUDP=$$HTNDX(DFN,$$DOB^AUPNPAT(DFN),BUDED,1)
  1.  S BUDRACEX=$$RACE^BUDCRPTC(DFN),BUDRACE=$P(BUDRACEX,U,2),BUDRACEP=$P(BUDRACEX,U,5)
  1.  S BUDRACEE=$$RACE^BUDCRP7I(BUDRACE)
  1.  S BUDR=""
  1.  S BUDETHN=$P($$HISP^BUDCRPTC(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("BUDCRP7",BUDJ,BUDH,"HTR",BUDRACEP,+BUDETHN,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)
  1.  ;I $G(BUDHTEL) S ^XTMP("BUDCRP7",BUDJ,BUDH,"HTE",BUDETHNN,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)
  1.  ;now check BP
  1.  S BUDCP=$$LASTITEM^BUDCDU(DFN,BUDBD,BUDED,"MEASUREMENT","BP")
  1.  I BUDCP]"" S BUDV=$$BPCHK(BUDCP) G SET
  1.  ;now check cpts
  1.  S T=$O(^ATXAX("B","BUD SYSTOLIC BP CPTS",0))
  1.  S BUDS=$$CPT^BUDCDU(DFN,BUDBD,BUDED,T,6)
  1.  S T=$O(^ATXAX("B","BUD DIASTOLIC BP CPTS",0))
  1.  S BUDD=$$CPT^BUDCDU(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("BUDCRP7",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("BUDCRP7",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("BUDCRP7",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("BUDCRP7",BUDJ,BUDH,"HTUE",BUDETHNN,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
  1.  Q
  1.  ;
  1. ESRD(P,BDATE,EDATE) ;EP
  1.  NEW X,T
  1.  S X=$$LASTDX^BGP6UTL1(P,"BGP ESRD PMS DXS",BDATE,EDATE)
  1.  I X Q 1_U_"POV "_$P(X,U,2)_U_$P(X,U,3)
  1.  S T=$O(^ATXAX("B","BGP ESRD CPTS",0))
  1.  I T D  I X]"" Q 1_U_"CPT "_$P(X,U,2)_U_$P(X,U,1)
  1.  .S X=$$CPT^BGP6DU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
  1.  .S X=$$TRAN^BGP6DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
  1.  S X=$$LASTPRC^BGP6UTL1(P,"BGP ESRD PROCS",BDATE,EDATE)
  1.  I X Q 1_U_"PRC "_$P(X,U,2)_U_$P(X,U,3)
  1.  Q 0
  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.  ;
  1.  ;V10.0 ICD10
  1.  K BUDG S %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
  1.  S T=$O(^BUDCTSSC("B","HTN DIAGNOSES",0))
  1.  S X=0,G="" F  S X=$O(BUDG(X)) Q:X'=+X!(G]"")  D
  1.  .S Y=+$P(BUDG(X),U,4)
  1.  .S Y=$P($G(^AUPNVPOV(Y,0)),U,1)
  1.  .I $D(^BUDCTSSC("AD",Y,T)) S G=1_"^"_$P(BUDG(X),U,5)_"|"_$P(BUDG(X),U,2)
  1.  I G]"" Q G
  1. PROBDX S T=$O(^BUDCTSSC("B","HTN DIAGNOSES",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)="D"
  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:'$D(^BUDCTSSC("AD",Y,T))
  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 ""