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

BUDDRP7B.m

Go to the documentation of this file. 
  1. BUDDRP7B ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
  1.  ;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
  1.  ;
  1. HTN ;EP - list of HTN
  1.  ;is patient pregnant during the time period BUDDD and BUDED
  1.  S BUDDOB=$P(^DPT(DFN,0),U,3)
  1.  S BUDDDB=($E(BUDBD,1,3)-85)_"0101"
  1.  S BUDDDE=($E(BUDBD,1,3)-18)_"1231"
  1.  Q:BUDDOB>BUDDDE
  1.  Q:BUDDOB<BUDDDB
  1.  Q:BUDMEDV<1
  1.  ;
  1.  S BUDP=$$HTNDX(DFN,$$DOB^AUPNPAT(DFN),BUDCCAD)
  1.  I '$P(BUDP,U) Q  ;not dx'ed before june 30
  1.  ;PREGNANCY
  1.  Q:$$PREG^BUDDRP6B(DFN,BUDBD,BUDED,BUDBD)
  1.  Q:$$EXCL(DFN,BUDDOB,BUDED)
  1.  S BUDP=$$HTNDX(DFN,$$DOB^AUPNPAT(DFN),BUDED,1)
  1.  S BUDRACEX=$$RACE^BUDDRPTC(DFN),BUDRACE=$P(BUDRACEX,U,2),BUDRACEP=$P(BUDRACEX,U,5)
  1.  S BUDRACEE=$$RACE^BUDDRP7I(BUDRACE)
  1.  S BUDR=""
  1.  S BUDETHN=$P($$HISP^BUDDRPTC(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("BUDDRP7",BUDJ,BUDH,"HTR",BUDRACEP,+BUDETHN,BUDCCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)
  1.  ;I $G(BUDHTEL) S ^XTMP("BUDDRP7",BUDJ,BUDH,"HTE",BUDETHNN,BUDCCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)
  1.  ;now check BP
  1.  S BUDDP=$$LASTITEM^BUDDDU(DFN,BUDBD,BUDED,"MEASUREMENT","BP")
  1.  I BUDDP]"" S BUDV=$$BPCHK(BUDDP) G SET
  1.  ;now check cpts
  1.  S T=$O(^ATXAX("B","BUD SYSTOLIC BP CPTS",0))
  1.  S BUDS=$$CPT^BUDDDU(DFN,BUDBD,BUDED,T,6)
  1.  S T=$O(^ATXAX("B","BUD DIASTOLIC BP CPTS",0))
  1.  S BUDD=$$CPT^BUDDDU(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("BUDDRP7",BUDJ,BUDH,"HTCR",BUDRACEP,+BUDETHN,BUDCCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
  1.  I $G(BUDHTURL),'$P(BUDV,U,1) S ^XTMP("BUDDRP7",BUDJ,BUDH,"HTUR",BUDRACEP,+BUDETHN,BUDCCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)_"#"_$P(BUDV,U,2)
  1.  ;I $G(BUDHTCEL),$P(BUDV,U,1) S ^XTMP("BUDDRP7",BUDJ,BUDH,"HTCE",BUDETHNN,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
  1.  ;I $G(BUDHTUEL),'$P(BUDV,U,1) S ^XTMP("BUDDRP7",BUDJ,BUDH,"HTUE",BUDETHNN,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
  1.  Q
  1.  ;
  1. EXCL(P,BDATE,EDATE) ;EP
  1.  NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB,BDATE
  1.  S BDATE=$$DOB^AUPNPAT(P)
  1.  D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
  1.  S BUDTOB=0
  1.  S TIEN=$O(^BUDDTSSC("B","T7 HTN EXCLUSIONS",0))
  1.  S CTR=0 F  S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR!(BUDTOB)  D
  1.  .S VIEN=$P(BUDVS(CTR),U,5)
  1.  .S VDATE=$P(BUDVS(CTR),U,1)
  1.  .;POV/SNOMED
  1.  .S X=0 F  S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X!(BUDTOB)  D
  1.  ..Q:'$D(^AUPNVPOV(X,0))
  1.  ..S Y=$$VALI^XBDIQ1(9000010.07,X,.01) I $D(^BUDDTSSC("AD",Y,TIEN)) S BUDTOB=1 Q
  1.  ..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
  1.  ..Q:Y=""
  1.  ..I $D(^BUDDTSSC("AS",Y,TIEN)) S BUDTOB=1 Q
  1.  .;CPT
  1.  .S X=0 F  S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X!(BUDTOB)  D
  1.  ..Q:'$D(^AUPNVCPT(X,0))
  1.  ..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
  1.  ..Q:Y=""
  1.  ..I $D(^BUDDTSSC("AC",Y,TIEN)) S BUDTOB=1 Q
  1.  .;V TRANS
  1.  .S X=0 F  S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X!(BUDTOB)  D
  1.  ..Q:'$D(^AUPNVTC(X,0))
  1.  ..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
  1.  ..Q:Y=""
  1.  ..I $D(^BUDDTSSC("AC",Y,TIEN)) S BUDTOB=1 Q
  1.  .;V PROC
  1.  .S X=0 F  S X=$O(^AUPNVPRC("AD",VIEN,X)) Q:X'=+X!(BUDTOB)  D
  1.  ..Q:'$D(^AUPNVPRC(X,0))
  1.  ..S Y=$$VALI^XBDIQ1(9000010.08,X,.01)
  1.  ..I $D(^BUDDTSSC("AP",Y,TIEN)) S BUDTOB=1 Q
  1.  I BUDTOB Q 1
  1.  S Y=$$PLCL^BUDDDU(P,"T7 HTN EXCLUSIONS",EDATE,0)
  1.  I Y Q 1
  1.  Q ""
  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(^BUDDTSSC("B","T7 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 Z=$P($G(^AUPNVPOV(Y,0)),U,1)
  1.  .S V=$P(BUDG(X),U,5)
  1.  .S C=$$PRIMPROV^APCLV(V,"D")
  1.  .Q:C=53
  1.  .Q:$P(^AUPNVSIT(V,0),U,7)="C"
  1.  .I $D(^BUDDTSSC("AD",Z,T)) S G=1_"^"_$P(BUDG(X),U,5)_"|"_$P(BUDG(X),U,2) Q
  1.  .S S=$$VAL^XBDIQ1(9000010.07,Y,1101) I S]"",$D(^BUDDTSSC("AS",S,T)) S G=1_"^"_$P(BUDG(X),U,5)_"|"_S Q
  1.  I G]"" Q G
  1. PROBDX ;
  1.  S G=$$PLCL^BUDDDU(P,"T7 HTN DIAGNOSES",EDATE,0)
  1.  I G Q 1_U_"Problem List: "_$P(G,U,2)_" on "_$$DATE^BUDDUTL1($P(G,U,3))
  1.  Q ""