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

BUD0RP7A.m

Go to the documentation of this file. 
  1. BUD0RP7A ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2010 5:11 PM ;
  1.  ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
  1.  ;;
  1. PRGHLST ;EP - list of pregnant females
  1.  ;is patient pregnant during the time period BUDBD and BUDED
  1.  Q:BUDSEX'="F"
  1.  S BUDP=$$PREG(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED)
  1.  I '$P(BUDP,U) Q  ;not pregnant
  1.  S BUDHIV=$$HIV(DFN,BUDED)
  1.  I '$P(BUDHIV,U) Q  ;no HIV
  1.  S BUDRACEX=$$RACE^BUD0RPTC(DFN),BUDRACE=$P(BUDRACEX,U,2),BUDRACEP=$P(BUDRACEX,U,5)
  1.  S BUDRACEE=$$RACE^BUD0RP7I(BUDRACE)
  1.  S BUDR=""
  1.  S BUDETHN=$P($$HISP^BUD0RPTC(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=17 G SETSECTH  ;BOTH BLANK OR REFUSED
  1.  I +BUDETHN=1 S BUDR=BUDRACEP G SETSECTH
  1.  I +BUDETHN=2!(+BUDETHN=3) S BUDR=BUDRACEP+8
  1. SETSECTH ;
  1.  S $P(BUDSECTH(1),U,BUDR)=$P($G(BUDSECTH(1)),U,BUDR)+1
  1.  S $P(BUDSECTH(1),U,18)=$P($G(BUDSECTH(1)),U,18)+1
  1.  S ^XTMP("BUD0RP7",BUDJ,BUDH,"PRGH",BUDAGEP,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDP,"*",2)_"#"_$P(BUDHIV,"*",2)
  1.  Q
  1.  ;
  1. PREG(P,BDATE,EDATE,NORXCHR) ;EP
  1.  NEW BUDDX,B,CNT,BUDD,BUDG,BUDALL,BUDA,BUDDX,C,X,V,D,G,Z,T,%
  1.  S B=0,CNT=0,BUDD="",BUDALL=""  ;if there is one before time frame set this to 1
  1.  S NORXCHR=$G(NORXCHR)
  1.  K BUDG
  1.  S Y="BUDG("
  1.  S X=P_"^ALL DX [BGP GPRA PREGNANCY DIAGNOSES;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1.  ;now reorder by date of diagnosis and eliminate all chr and rx if necessary
  1.  ;unduplicate by date
  1.  S X=0 F  S X=$O(BUDG(X)) Q:X'=+X  S BUDA($P(BUDG(X),U,1))=BUDG(X)
  1.  K BUDG
  1.  M BUDG=BUDA
  1.  K BUDA
  1.  S X=0 F  S X=$O(BUDG(X)) Q:X'=+X  D
  1.  .;get date
  1.  .S D=$P(BUDG(X),U,1)
  1.  .S C=$$CLINIC^APCLV($P(BUDG(X),U,5),"C")
  1.  .I NORXCHR,C=39 Q
  1.  .S C=$$PRIMPROV^APCLV($P(BUDG(X),U,5),"D")
  1.  .I NORXCHR,C=53 Q  ;no chr as primary provider
  1.  .S V=$P(BUDG(X),U,5)
  1.  .S BUDDX(D)="",CNT=CNT+1,BUDALL=BUDALL_V_"|"_$P(BUDG(X),U,2)_U I CNT=2 S BUDD=D
  1.  .I D>$$FMADD^XLFDT(EDATE,-365) S B=1
  1.  .Q
  1.  I CNT>1,B G MA
  1.  I 'B Q 0  ;no visit during time period
  1. PROB S T=$O(^ATXAX("B","BGP GPRA PREGNANCY 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)'="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=0,BUDD="" Q 0  ;no dxs and no problem list
  1.  S BUDD=G,BUDALL=BUDALL_"Problem List: "_$$VAL^XBDIQ1(9000011,Z,.01)_" on "_$$DATE^BUD0UTL1(G)
  1. MA ;now check for abortion or miscarriage
  1.  ;abortion first
  1.  K BUDG S Y="BUDG(" S X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_$$FMTE^XLFDT(BUDD)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1.  I $D(BUDG(1)) Q 0  ;HAD MIS/AB
  1.  S BUDG=$$LASTPRC^BUD0UTL1(P,"BGP ABORTION PROCEDURES",BDATE,EDATE)
  1.  I BUDG Q 0
  1.  S T=$O(^ATXAX("B","BGP MISCARRIAGE/ABORTION DXS",0))
  1.  S (X,G)=0 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)<BUDD
  1.  .Q:$P(^AUPNPROB(X,0),U,8)>EDATE
  1.  .S Y=$P(^AUPNPROB(X,0),U)
  1.  .Q:'$$ICD^ATXCHK(Y,T,9)
  1.  .S G=1
  1.  .Q
  1.  I G Q 0
  1.  ;now check CPTs for Abortion and Miscarriage
  1.  S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
  1.  S %=$$CPT^BUD0DU(P,BUDD,EDATE,T,3)
  1.  I %]"" Q 0
  1.  S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
  1.  S %=$$CPT^BUD0DU(P,BUDD,EDATE,T,3)
  1.  I %]"" Q 0
  1.  S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
  1.  S %=$$TRAN^BUD0DU(P,BUDD,EDATE,T,3)
  1.  I %]"" Q 0
  1.  S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
  1.  S %=$$TRAN^BUD0DU(P,BUDD,EDATE,T,3)
  1.  I %]"" Q 0
  1.  Q 1_"*"_BUDALL
  1.  ;
  1. HIV(P,EDATE) ;HIV DX OR PL?  return date of most recent
  1.  NEW BDATE,BUDG,Y,X,E,T,G,C,S,D,BUDD,BUDA,GOT
  1.  S GOT=""
  1.  S Y="BUDG("
  1.  K BUDG
  1.  S BDATE=$P(^DPT(P,0),U,3)  ;dob
  1.  S C=0,S=0,G=0  ;c is total count s is one during past 6 months, G is on problem list
  1.  ;check problem list
  1.  S T=$O(^ATXAX("B","BGP HIV/AIDS DXS",0))
  1.  S X=0,G="" 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.  .S Y=$P(^AUPNPROB(X,0),U)
  1.  .Q:'$$ICD^ATXCHK(Y,T,9)
  1.  .S G=$P(^AUPNPROB(X,0),U,8),C=$$VAL^XBDIQ1(9000011,X,.01)
  1.  .Q
  1.  I G D  Q Y
  1.  .S Y="1*"
  1.  .I G S Y=Y_"Problem List Diagnosis: "_C_" "_$$FMTE^XLFDT(G)_U
  1.  S Y="BUDG("
  1.  K BUDG
  1.  S X=P_"^ALL DX [BGP HIV/AIDS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1.  ;reorder and unduplicate by date
  1.  K BUDD S X=0 F  S X=$O(BUDG(X)) Q:X'=+X  S D=$P(BUDG(X),U,1),BUDD(D)=BUDG(X)
  1.  ;now count and check for 1 in past 6 months
  1.  S Y=$$FMADD^XLFDT(EDATE,-180)
  1.  S D=0 F  S D=$O(BUDD(D)) Q:D'=+D  S C=C+1 I D'<Y S S=1
  1.  ;I 'S Q ""  ;no HIV dx in past 6 months
  1.  I C>1 S GOT=1
  1.  ;.S Y="1*"
  1.  ;.;S X=0 F  S X=$O(BUDD(X)) Q:X'=+X  S Y=Y_$P(BUDD(X),U,5)_"|"_$P(BUDD(X),U,2)_U
  1.  ;.K BUDG,BUDD
  1.  ;.S X=P_"^LAST DX [BGP HIV/AIDS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BUDG(")
  1.  ;.S Y=Y_"@"_$P(BUDG(1),U,2)_"  "_$$FMTE^XLFDT($P(BUDG(1),U))
  1.  ;K BUDD,BUDG
  1.  I G!(GOT) D  Q Y
  1.  .S Y="1*"
  1.  .I G S Y=Y_"Problem List Diagnosis: "_C_" "_$$FMTE^XLFDT(G)_U
  1.  .S X=0 F  S X=$O(BUDD(X)) Q:X<$$FMADD^XLFDT(EDATE,-365)  S Y=Y_$P(BUDD(X),U,5)_"|"_$P(BUDD(X),U,2)_U
  1.  .S X=P_"^LAST DX [BGP HIV/AIDS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BUDG(")
  1.  .S Y=Y_"@"_$P(BUDG(1),U,2)_" "_$$FMTE^XLFDT($P(BUDG(1),U))
  1.  Q ""
  1. PRGRLST ;EP - list of pregnant females
  1.  ;is patient pregnant during the time period BUDBD and BUDED
  1.  Q:BUDSEX'="F"
  1.  S BUDP=$$PREG(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED)
  1.  I '$P(BUDP,U) Q  ;not pregnant
  1.  S BUDHISPN=$$HISP^BUD0RPTC(DFN)
  1.  S BUDHISP=$P($$HISP^BUD0RPTC(DFN),U,1)  ;1=hispanic 2=non hispanic
  1.  ;S BUDHISP1=BUDHISP+2  ;set piece
  1.  ;
  1.  S BUDR1=$$RACE^BUD0RPTC(DFN)
  1.  S BUDR=$P(BUDR1,U,1)  ;LINE
  1.  S ^XTMP("BUD0RP7",BUDJ,BUDH,"PRGR",$P(BUDR1,U,5),BUDHISP,BUDCOM,BUDAGEP,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"*",2)
  1.  Q
  1.  ;
  1. PRGELST ;EP - list of pregnant females
  1.  ;is patient pregnant during the time period BUDBD and BUDED
  1.  Q:BUDSEX'="F"
  1.  S BUDP=$$PREG(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED)
  1.  I '$P(BUDP,U) Q  ;not pregnant
  1.  S BUDRACE=$$HISP^BUD0RPTC(DFN)
  1.  I +BUDRACE=1 S BUDRACE="Hispanic or Latino"
  1.  I +BUDRACE=2 S BUDRACE="All Others"
  1.  S ^XTMP("BUD0RP7",BUDJ,BUDH,"PRGE",BUDRACE,BUDCOM,BUDAGEP,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"*",2)
  1.  Q
  1.  ;