BUD8RP7A ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2008 5:11 PM ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
PRGHLST ;EP - list of pregnant females
;is patient pregnant during the time period BUDBD and BUDED
Q:BUDSEX'="F"
S BUDP=$$PREG(DFN,$$FMADD^XLFDT(BUDED,(-(30*20))),BUDED)
I '$P(BUDP,U) Q ;not pregnant
S BUDHIV=$$HIV(DFN,BUDED)
I '$P(BUDHIV,U) Q ;no HIV
S ^XTMP("BUD8RP7",BUDJ,BUDH,"PRGH",BUDAGEP,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDP,"*",2)_"#"_$P(BUDHIV,"*",2)
Q
;
PREG(P,BDATE,EDATE,NORXCHR) ;EP
NEW BUDDX,B,CNT,BUDD,BUDG,BUDALL,BUDA,BUDDX,C,X,V,D,G,Z,T,%
S B=0,CNT=0,BUDD="",BUDALL="" ;if there is one before time frame set this to 1
S NORXCHR=$G(NORXCHR)
K BUDG
S Y="BUDG("
S X=P_"^ALL DX [BGP GPRA PREGNANCY DIAGNOSES;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
;now reorder by date of diagnosis and eliminate all chr and rx if necessary
;unduplicate by date
S X=0 F S X=$O(BUDG(X)) Q:X'=+X S BUDA($P(BUDG(X),U,1))=BUDG(X)
K BUDG
M BUDG=BUDA
K BUDA
S X=0 F S X=$O(BUDG(X)) Q:X'=+X D
.;get date
.S D=$P(BUDG(X),U,1)
.S C=$$CLINIC^APCLV($P(BUDG(X),U,5),"C")
.I NORXCHR,C=39 Q
.S C=$$PRIMPROV^APCLV($P(BUDG(X),U,5),"D")
.I NORXCHR,C=53 Q ;no chr as primary provider
.S V=$P(BUDG(X),U,5)
.S BUDDX(D)="",CNT=CNT+1,BUDALL=BUDALL_V_"|"_$P(BUDG(X),U,2)_U I CNT=2 S BUDD=D
.I D>$$FMADD^XLFDT(EDATE,-365) S B=1
.Q
I CNT>1,B G MA
I 'B Q 0 ;no visit during time period
PROB S T=$O(^ATXAX("B","BGP GPRA PREGNANCY 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)'="A"
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.Q:$P(^AUPNPROB(X,0),U,8)<BDATE
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^ATXCHK(Y,T,9)
.S G=$P(^AUPNPROB(X,0),U,8),Z=X
.Q
I G=0,BUDD="" Q 0 ;no dxs and no problem list
S BUDD=G,BUDALL=BUDALL_"Problem List: "_$$VAL^XBDIQ1(9000011,Z,.01)_" on "_$$DATE^BUD8UTL1(G)
MA ;now check for abortion or miscarriage
;abortion first
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)
I $D(BUDG(1)) Q 0 ;HAD MIS/AB
S BUDG=$$LASTPRC^BUD8UTL1(P,"BGP ABORTION PROCEDURES",BDATE,EDATE)
I BUDG Q 0
S T=$O(^ATXAX("B","BGP MISCARRIAGE/ABORTION DXS",0))
S (X,G)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:$P(^AUPNPROB(X,0),U,12)'="A"
.Q:$P(^AUPNPROB(X,0),U,8)<BUDD
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^ATXCHK(Y,T,9)
.S G=1
.Q
I G Q 0
;now check CPTs for Abortion and Miscarriage
S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
S %=$$CPT^BUD8DU(P,BUDD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
S %=$$CPT^BUD8DU(P,BUDD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
S %=$$TRAN^BUD8DU(P,BUDD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
S %=$$TRAN^BUD8DU(P,BUDD,EDATE,T,3)
I %]"" Q 0
Q 1_"*"_BUDALL
;
HIV(P,EDATE) ;HIV DX OR PL? return date of most recent
NEW BDATE,BUDG,Y,X,E,T,G,C,S,D,BUDD,BUDA
S Y="BUDG("
K BUDG
S BDATE=$P(^DPT(P,0),U,3) ;dob
S C=0,S=0 ;c is total count s is one during past 6 months
S X=P_"^ALL DX [BGP HIV/AIDS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
;reorder and unduplicate by date
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)
;now count and check for 1 in past 6 months
S Y=$$FMADD^XLFDT(EDATE,-180)
S D=0 F S D=$O(BUDD(D)) Q:D'=+D S C=C+1 I D'<Y S S=1
I 'S Q "" ;no HIV dx in past 6 months
I C>2,S D Q Y
.S Y="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
.K BUDG,BUDD
.S X=P_"^LAST DX [BGP HIV/AIDS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BUDG(")
.S Y=Y_"@"_$P(BUDG(1),U,2)_" "_$$FMTE^XLFDT($P(BUDG(1),U))
S T=$O(^ATXAX("B","BGP HIV/AIDS DXS",0))
S X=0,G="" F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G]"") D
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^ATXCHK(Y,T,9)
.S G=$P(^AUPNPROB(X,0),U,8),C=$$VAL^XBDIQ1(9000011,X,.01)
.Q
K BUDD,BUDG
I G,S D Q Y
.S Y="1*"
.S Y=Y_"Problem List Diagnosis: "_C_" "_$$FMTE^XLFDT(G)_U
.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
.S X=P_"^LAST DX [BGP HIV/AIDS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BUDG(")
.S Y=Y_"@"_$P(BUDG(1),U,2)_" "_$$FMTE^XLFDT($P(BUDG(1),U))
Q ""
PRGRLST ;EP - list of pregnant females
;is patient pregnant during the time period BUDBD and BUDED
Q:BUDSEX'="F"
S BUDP=$$PREG(DFN,$$FMADD^XLFDT(BUDED,(-(30*20))),BUDED)
I '$P(BUDP,U) Q ;not pregnant
S BUDRACE=$$RACE^BUD8RPTC(DFN),BUDRACE=$P(BUDRACE,U,2)
S ^XTMP("BUD8RP7",BUDJ,BUDH,"PRGR",BUDRACE,BUDCOM,BUDAGEP,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"*",2)
Q
;
PRGELST ;EP - list of pregnant females
;is patient pregnant during the time period BUDBD and BUDED
Q:BUDSEX'="F"
S BUDP=$$PREG(DFN,$$FMADD^XLFDT(BUDED,(-(30*20))),BUDED)
I '$P(BUDP,U) Q ;not pregnant
S BUDRACE=$$HISP^BUD8RPTC(DFN)
I +BUDRACE=1 S BUDRACE="Hispanic or Latino"
I +BUDRACE=2 S BUDRACE="All Others"
S ^XTMP("BUD8RP7",BUDJ,BUDH,"PRGE",BUDRACE,BUDCOM,BUDAGEP,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"*",2)
Q
;
BUD8RP7A ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2008 5:11 PM ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
PRGHLST ;EP - list of pregnant females
+1 ;is patient pregnant during the time period BUDBD and BUDED
+2 IF BUDSEX'="F"
QUIT
+3 SET BUDP=$$PREG(DFN,$$FMADD^XLFDT(BUDED,(-(30*20))),BUDED)
+4 ;not pregnant
IF '$PIECE(BUDP,U)
QUIT
+5 SET BUDHIV=$$HIV(DFN,BUDED)
+6 ;no HIV
IF '$PIECE(BUDHIV,U)
QUIT
+7 SET ^XTMP("BUD8RP7",BUDJ,BUDH,"PRGH",BUDAGEP,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=$PIECE(BUDP,"*",2)_"#"_$PIECE(BUDHIV,"*",2)
+8 QUIT
+9 ;
PREG(P,BDATE,EDATE,NORXCHR) ;EP
+1 NEW BUDDX,B,CNT,BUDD,BUDG,BUDALL,BUDA,BUDDX,C,X,V,D,G,Z,T,%
+2 ;if there is one before time frame set this to 1
SET B=0
SET CNT=0
SET BUDD=""
SET BUDALL=""
+3 SET NORXCHR=$GET(NORXCHR)
+4 KILL BUDG
+5 SET Y="BUDG("
+6 SET X=P_"^ALL DX [BGP GPRA PREGNANCY DIAGNOSES;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+7 ;now reorder by date of diagnosis and eliminate all chr and rx if necessary
+8 ;unduplicate by date
+9 SET X=0
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X
QUIT
SET BUDA($PIECE(BUDG(X),U,1))=BUDG(X)
+10 KILL BUDG
+11 MERGE BUDG=BUDA
+12 KILL BUDA
+13 SET X=0
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X
QUIT
Begin DoDot:1
+14 ;get date
+15 SET D=$PIECE(BUDG(X),U,1)
+16 SET C=$$CLINIC^APCLV($PIECE(BUDG(X),U,5),"C")
+17 IF NORXCHR
IF C=39
QUIT
+18 SET C=$$PRIMPROV^APCLV($PIECE(BUDG(X),U,5),"D")
+19 ;no chr as primary provider
IF NORXCHR
IF C=53
QUIT
+20 SET V=$PIECE(BUDG(X),U,5)
+21 SET BUDDX(D)=""
SET CNT=CNT+1
SET BUDALL=BUDALL_V_"|"_$PIECE(BUDG(X),U,2)_U
IF CNT=2
SET BUDD=D
+22 IF D>$$FMADD^XLFDT(EDATE,-365)
SET B=1
+23 QUIT
End DoDot:1
+24 IF CNT>1
IF B
GOTO MA
+25 ;no visit during time period
IF 'B
QUIT 0
PROB SET T=$ORDER(^ATXAX("B","BGP GPRA PREGNANCY 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)'="A"
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 '$$ICD^ATXCHK(Y,T,9)
QUIT
+7 SET G=$PIECE(^AUPNPROB(X,0),U,8)
SET Z=X
+8 QUIT
End DoDot:1
+9 ;no dxs and no problem list
IF G=0
IF BUDD=""
QUIT 0
+10 SET BUDD=G
SET BUDALL=BUDALL_"Problem List: "_$$VAL^XBDIQ1(9000011,Z,.01)_" on "_$$DATE^BUD8UTL1(G)
MA ;now check for abortion or miscarriage
+1 ;abortion first
+2 KILL BUDG
SET Y="BUDG("
SET X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_$$FMTE^XLFDT(BUDD)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+3 ;HAD MIS/AB
IF $DATA(BUDG(1))
QUIT 0
+4 SET BUDG=$$LASTPRC^BUD8UTL1(P,"BGP ABORTION PROCEDURES",BDATE,EDATE)
+5 IF BUDG
QUIT 0
+6 SET T=$ORDER(^ATXAX("B","BGP MISCARRIAGE/ABORTION DXS",0))
+7 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
QUIT
+9 IF $PIECE(^AUPNPROB(X,0),U,8)<BUDD
QUIT
+10 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+11 SET Y=$PIECE(^AUPNPROB(X,0),U)
+12 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+13 SET G=1
+14 QUIT
End DoDot:1
+15 IF G
QUIT 0
+16 ;now check CPTs for Abortion and Miscarriage
+17 SET T=$ORDER(^ATXAX("B","BGP CPT ABORTION",0))
+18 SET %=$$CPT^BUD8DU(P,BUDD,EDATE,T,3)
+19 IF %]""
QUIT 0
+20 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+21 SET %=$$CPT^BUD8DU(P,BUDD,EDATE,T,3)
+22 IF %]""
QUIT 0
+23 SET T=$ORDER(^ATXAX("B","BGP CPT ABORTION",0))
+24 SET %=$$TRAN^BUD8DU(P,BUDD,EDATE,T,3)
+25 IF %]""
QUIT 0
+26 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+27 SET %=$$TRAN^BUD8DU(P,BUDD,EDATE,T,3)
+28 IF %]""
QUIT 0
+29 QUIT 1_"*"_BUDALL
+30 ;
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
+2 SET Y="BUDG("
+3 KILL BUDG
+4 ;dob
SET BDATE=$PIECE(^DPT(P,0),U,3)
+5 ;c is total count s is one during past 6 months
SET C=0
SET S=0
+6 SET X=P_"^ALL DX [BGP HIV/AIDS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+7 ;reorder and unduplicate by date
+8 KILL BUDD
SET X=0
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X
QUIT
SET D=$PIECE(BUDG(X),U,1)
SET BUDD(D)=BUDG(X)
+9 ;now count and check for 1 in past 6 months
+10 SET Y=$$FMADD^XLFDT(EDATE,-180)
+11 SET D=0
FOR
SET D=$ORDER(BUDD(D))
IF D'=+D
QUIT
SET C=C+1
IF D'<Y
SET S=1
+12 ;no HIV dx in past 6 months
IF 'S
QUIT ""
+13 IF C>2
IF S
Begin DoDot:1
+14 SET Y="1*"
+15 ;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
+16 KILL BUDG,BUDD
+17 SET X=P_"^LAST DX [BGP HIV/AIDS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,"BUDG(")
+18 SET Y=Y_"@"_$PIECE(BUDG(1),U,2)_" "_$$FMTE^XLFDT($PIECE(BUDG(1),U))
End DoDot:1
QUIT Y
+19 SET T=$ORDER(^ATXAX("B","BGP HIV/AIDS DXS",0))
+20 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+21 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+22 SET Y=$PIECE(^AUPNPROB(X,0),U)
+23 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+24 SET G=$PIECE(^AUPNPROB(X,0),U,8)
SET C=$$VAL^XBDIQ1(9000011,X,.01)
+25 QUIT
End DoDot:1
+26 KILL BUDD,BUDG
+27 IF G
IF S
Begin DoDot:1
+28 SET Y="1*"
+29 SET Y=Y_"Problem List Diagnosis: "_C_" "_$$FMTE^XLFDT(G)_U
+30 SET X=0
FOR
SET X=$ORDER(BUDD(X))
IF X'=+X
QUIT
SET Y=Y_$PIECE(BUDD(X),U,5)_"|"_$PIECE(BUDD(X),U,2)_U
+31 SET X=P_"^LAST DX [BGP HIV/AIDS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,"BUDG(")
+32 SET Y=Y_"@"_$PIECE(BUDG(1),U,2)_" "_$$FMTE^XLFDT($PIECE(BUDG(1),U))
End DoDot:1
QUIT Y
+33 QUIT ""
PRGRLST ;EP - list of pregnant females
+1 ;is patient pregnant during the time period BUDBD and BUDED
+2 IF BUDSEX'="F"
QUIT
+3 SET BUDP=$$PREG(DFN,$$FMADD^XLFDT(BUDED,(-(30*20))),BUDED)
+4 ;not pregnant
IF '$PIECE(BUDP,U)
QUIT
+5 SET BUDRACE=$$RACE^BUD8RPTC(DFN)
SET BUDRACE=$PIECE(BUDRACE,U,2)
+6 SET ^XTMP("BUD8RP7",BUDJ,BUDH,"PRGR",BUDRACE,BUDCOM,BUDAGEP,$PIECE(^DPT(DFN,0),U),DFN)=$PIECE(BUDP,"*",2)
+7 QUIT
+8 ;
PRGELST ;EP - list of pregnant females
+1 ;is patient pregnant during the time period BUDBD and BUDED
+2 IF BUDSEX'="F"
QUIT
+3 SET BUDP=$$PREG(DFN,$$FMADD^XLFDT(BUDED,(-(30*20))),BUDED)
+4 ;not pregnant
IF '$PIECE(BUDP,U)
QUIT
+5 SET BUDRACE=$$HISP^BUD8RPTC(DFN)
+6 IF +BUDRACE=1
SET BUDRACE="Hispanic or Latino"
+7 IF +BUDRACE=2
SET BUDRACE="All Others"
+8 SET ^XTMP("BUD8RP7",BUDJ,BUDH,"PRGE",BUDRACE,BUDCOM,BUDAGEP,$PIECE(^DPT(DFN,0),U),DFN)=$PIECE(BUDP,"*",2)
+9 QUIT
+10 ;
