BGP8D714 ; IHS/CMI/LAB - measure 6 ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
PREG ;EP
NEW B,E,A,CNT,BGPD,BGPG,X,Y,BGPDX,C,D,G,T,%,CTR,VIEN,DXT,PXT,CPTT,BGPV,H
I '$G(FORM) S FORM=""
I $G(CPBD)="" S CPBD=$$FMADD^XLFDT(BDATE,-365)
I $G(CPED)="" S CPED=EDATE
S BGPD=""
D ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
I '$D(BGPV) G PROB
S B=0,CNT=0,BGPD="" ;if there is one before time frame set this to 1
S NORXCHR=$G(NORXCHR)
S NORX=$G(NORX)
K BGPG
S DXT=$O(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
S PXT=$O(^ATXAX("B","BGP PREGNANCY ICD PROCEDURES",0))
S CPTT=$O(^ATXAX("B","BGP PREGNANCY CPT CODES",0))
;CHECK DX, PROCS, CPTS for 2 separate visits
S B=0,CTR=0 F S CTR=$O(BGPV(CTR)) Q:CTR'=+CTR D
.;get visit into VIEN
.S VIEN=$P(BGPV(CTR),U,5)
.S D=$$VD^APCLV(VIEN)
.S C=$$CLINIC^APCLV(VIEN,"C")
.I NORXCHR,C=39 Q
.I NORX,C=39 Q
.S C=$$PRIMPROV^APCLV(VIEN,"D")
.I NORXCHR,C=53 Q ;no chr as primary provider
.;now check for dx
.S Y=0,H="" F S Y=$O(^AUPNVPOV("AD",VIEN,Y)) Q:Y'=+Y D
..S %=+^AUPNVPOV(Y,0)
..I $$ICD^BGP8UTL2(%,DXT,9) S BGPDX(D)="",CNT=CNT+1,H=1 I D>$$FMADD^XLFDT(EDATE,-365) S B=1
.Q:H
.;NOW GO THROUGH CPTS
.S Y=0,H="" F S Y=$O(^AUPNVCPT("AD",VIEN,Y)) Q:Y'=+Y D
..S %=+^AUPNVCPT(Y,0)
..I $$ICD^BGP8UTL2(%,CPTT,1) I '$D(BGPDX(D)) S BGPDX(D)="",CNT=CNT+1,H=1 I D>$$FMADD^XLFDT(EDATE,-365) S B=1
.Q:H
.;NOW PROCEDURES
.S Y=0,H="" F S Y=$O(^AUPNVPRC("AD",VIEN,Y)) Q:Y'=+Y D
..S %=+^AUPNVPRC(Y,0)
..I $$ICD^BGP8UTL2(%,PXT,0) I '$D(BGPDX(D)) S BGPDX(D)="",CNT=CNT+1,H=1 I D>$$FMADD^XLFDT(EDATE,-365) S B=1
.Q:H
.Q
I CNT>1,B D G MA
.;SET BGPD TO SECOND VISIT DATE
.S X=0,C=0 F S X=$O(BGPDX(X)) Q:X'=+X!(C>1) S C=C+1 I C=2 S BGPD=X
;
PROB ;
I '$G(B) Q $$RF(P,CPBD,CPED) ;no pregnancy visit during time period ;-Lori fix in 09
S T=$O(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",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)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.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^BGP8UTL2(Y,T,9)
.S G=$P(^AUPNPROB(X,0),U,8)
.Q
I G=0,BGPD="" Q $$RF(P,CPBD,CPED)
S BGPD=G
MA ;now check for abortion or miscarriage
K BGPG S Y="BGPG(" S X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_$$FMTE^XLFDT(BGPD)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q $$RF(P,CPBD,CPED) ;HAD MIS/AB
S BGPG=$$LASTPRC^BGP8UTL1(P,"BGP ABORTION PROCEDURES",BGPD,EDATE)
I BGPG Q $$RF(P,CPBD,CPED)
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)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.Q:$P(^AUPNPROB(X,0),U,8)<BGPD
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^BGP8UTL2(Y,T,9)
.S G=1
.Q
I G Q $$RF(P,CPBD,CPED)
;now check CPTs for Abortion and Miscarriage
S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
S %=$$CPT^BGP8DU(P,BGPD,EDATE,T,3)
I %]"" Q $$RF(P,CPBD,CPED)
S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
S %=$$CPT^BGP8DU(P,BGPD,EDATE,T,3)
I %]"" Q $$RF(P,CPBD,CPED)
S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
S %=$$TRAN^BGP8DU(P,BGPD,EDATE,T,3)
I %]"" Q $$RF(P,CPBD,CPED)
S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
S %=$$TRAN^BGP8DU(P,BGPD,EDATE,T,3)
I %]"" Q $$RF(P,CPBD,CPED)
I FORM="" Q 1
Q 1_U_$$DATE^BGP8UTL(BGPD)
RF(P,CPBD,CPED) ;CHECK REPRODUCTIVE FACTORS
S A=""
I $P($G(^AUPNREP(P,11)),U,1)="Y" D I A S BGPD=B G MARF
.S B=$P($G(^AUPNREP(P,11)),U,2) Q:B=""
.Q:B<CPBD
.Q:B>CPED
.S A=1
.Q
Q 0
MARF ;
;now check for abortion or miscarriage
K BGPG S Y="BGPG(" S X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_$$FMTE^XLFDT(BGPD)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 0 ;HAD MIS/AB
S BGPG=$$LASTPRC^BGP8UTL1(P,"BGP ABORTION PROCEDURES",BGPD,EDATE)
I BGPG 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)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.Q:$P(^AUPNPROB(X,0),U,8)<BGPD
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^BGP8UTL2(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^BGP8DU(P,BGPD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
S %=$$CPT^BGP8DU(P,BGPD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
S %=$$TRAN^BGP8DU(P,BGPD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
S %=$$TRAN^BGP8DU(P,BGPD,EDATE,T,3)
I %]"" Q 0
I FORM="" Q 1
Q 1_U_$$DATE^BGP8UTL(BGPD)
BGP8D714 ; IHS/CMI/LAB - measure 6 ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
PREG ;EP
+1 NEW B,E,A,CNT,BGPD,BGPG,X,Y,BGPDX,C,D,G,T,%,CTR,VIEN,DXT,PXT,CPTT,BGPV,H
+2 IF '$GET(FORM)
SET FORM=""
+3 IF $GET(CPBD)=""
SET CPBD=$$FMADD^XLFDT(BDATE,-365)
+4 IF $GET(CPED)=""
SET CPED=EDATE
+5 SET BGPD=""
+6 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
+7 IF '$DATA(BGPV)
GOTO PROB
+8 ;if there is one before time frame set this to 1
SET B=0
SET CNT=0
SET BGPD=""
+9 SET NORXCHR=$GET(NORXCHR)
+10 SET NORX=$GET(NORX)
+11 KILL BGPG
+12 SET DXT=$ORDER(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
+13 SET PXT=$ORDER(^ATXAX("B","BGP PREGNANCY ICD PROCEDURES",0))
+14 SET CPTT=$ORDER(^ATXAX("B","BGP PREGNANCY CPT CODES",0))
+15 ;CHECK DX, PROCS, CPTS for 2 separate visits
+16 SET B=0
SET CTR=0
FOR
SET CTR=$ORDER(BGPV(CTR))
IF CTR'=+CTR
QUIT
Begin DoDot:1
+17 ;get visit into VIEN
+18 SET VIEN=$PIECE(BGPV(CTR),U,5)
+19 SET D=$$VD^APCLV(VIEN)
+20 SET C=$$CLINIC^APCLV(VIEN,"C")
+21 IF NORXCHR
IF C=39
QUIT
+22 IF NORX
IF C=39
QUIT
+23 SET C=$$PRIMPROV^APCLV(VIEN,"D")
+24 ;no chr as primary provider
IF NORXCHR
IF C=53
QUIT
+25 ;now check for dx
+26 SET Y=0
SET H=""
FOR
SET Y=$ORDER(^AUPNVPOV("AD",VIEN,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+27 SET %=+^AUPNVPOV(Y,0)
+28 IF $$ICD^BGP8UTL2(%,DXT,9)
SET BGPDX(D)=""
SET CNT=CNT+1
SET H=1
IF D>$$FMADD^XLFDT(EDATE,-365)
SET B=1
End DoDot:2
+29 IF H
QUIT
+30 ;NOW GO THROUGH CPTS
+31 SET Y=0
SET H=""
FOR
SET Y=$ORDER(^AUPNVCPT("AD",VIEN,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+32 SET %=+^AUPNVCPT(Y,0)
+33 IF $$ICD^BGP8UTL2(%,CPTT,1)
IF '$DATA(BGPDX(D))
SET BGPDX(D)=""
SET CNT=CNT+1
SET H=1
IF D>$$FMADD^XLFDT(EDATE,-365)
SET B=1
End DoDot:2
+34 IF H
QUIT
+35 ;NOW PROCEDURES
+36 SET Y=0
SET H=""
FOR
SET Y=$ORDER(^AUPNVPRC("AD",VIEN,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+37 SET %=+^AUPNVPRC(Y,0)
+38 IF $$ICD^BGP8UTL2(%,PXT,0)
IF '$DATA(BGPDX(D))
SET BGPDX(D)=""
SET CNT=CNT+1
SET H=1
IF D>$$FMADD^XLFDT(EDATE,-365)
SET B=1
End DoDot:2
+39 IF H
QUIT
+40 QUIT
End DoDot:1
+41 IF CNT>1
IF B
Begin DoDot:1
+42 ;SET BGPD TO SECOND VISIT DATE
+43 SET X=0
SET C=0
FOR
SET X=$ORDER(BGPDX(X))
IF X'=+X!(C>1)
QUIT
SET C=C+1
IF C=2
SET BGPD=X
End DoDot:1
GOTO MA
+44 ;
PROB ;
+1 ;no pregnancy visit during time period ;-Lori fix in 09
IF '$GET(B)
QUIT $$RF(P,CPBD,CPED)
+2 SET T=$ORDER(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
+3 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+4 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+5 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+6 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+7 IF $PIECE(^AUPNPROB(X,0),U,8)<BDATE
QUIT
+8 SET Y=$PIECE(^AUPNPROB(X,0),U)
+9 IF '$$ICD^BGP8UTL2(Y,T,9)
QUIT
+10 SET G=$PIECE(^AUPNPROB(X,0),U,8)
+11 QUIT
End DoDot:1
+12 IF G=0
IF BGPD=""
QUIT $$RF(P,CPBD,CPED)
+13 SET BGPD=G
MA ;now check for abortion or miscarriage
+1 KILL BGPG
SET Y="BGPG("
SET X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_$$FMTE^XLFDT(BGPD)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+2 ;HAD MIS/AB
IF $DATA(BGPG(1))
QUIT $$RF(P,CPBD,CPED)
+3 SET BGPG=$$LASTPRC^BGP8UTL1(P,"BGP ABORTION PROCEDURES",BGPD,EDATE)
+4 IF BGPG
QUIT $$RF(P,CPBD,CPED)
+5 SET T=$ORDER(^ATXAX("B","BGP MISCARRIAGE/ABORTION DXS",0))
+6 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+7 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+8 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+9 IF $PIECE(^AUPNPROB(X,0),U,8)<BGPD
QUIT
+10 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+11 SET Y=$PIECE(^AUPNPROB(X,0),U)
+12 IF '$$ICD^BGP8UTL2(Y,T,9)
QUIT
+13 SET G=1
+14 QUIT
End DoDot:1
+15 IF G
QUIT $$RF(P,CPBD,CPED)
+16 ;now check CPTs for Abortion and Miscarriage
+17 SET T=$ORDER(^ATXAX("B","BGP CPT ABORTION",0))
+18 SET %=$$CPT^BGP8DU(P,BGPD,EDATE,T,3)
+19 IF %]""
QUIT $$RF(P,CPBD,CPED)
+20 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+21 SET %=$$CPT^BGP8DU(P,BGPD,EDATE,T,3)
+22 IF %]""
QUIT $$RF(P,CPBD,CPED)
+23 SET T=$ORDER(^ATXAX("B","BGP CPT ABORTION",0))
+24 SET %=$$TRAN^BGP8DU(P,BGPD,EDATE,T,3)
+25 IF %]""
QUIT $$RF(P,CPBD,CPED)
+26 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+27 SET %=$$TRAN^BGP8DU(P,BGPD,EDATE,T,3)
+28 IF %]""
QUIT $$RF(P,CPBD,CPED)
+29 IF FORM=""
QUIT 1
+30 QUIT 1_U_$$DATE^BGP8UTL(BGPD)
RF(P,CPBD,CPED) ;CHECK REPRODUCTIVE FACTORS
+1 SET A=""
+2 IF $PIECE($GET(^AUPNREP(P,11)),U,1)="Y"
Begin DoDot:1
+3 SET B=$PIECE($GET(^AUPNREP(P,11)),U,2)
IF B=""
QUIT
+4 IF B<CPBD
QUIT
+5 IF B>CPED
QUIT
+6 SET A=1
+7 QUIT
End DoDot:1
IF A
SET BGPD=B
GOTO MARF
+8 QUIT 0
MARF ;
+1 ;now check for abortion or miscarriage
+2 KILL BGPG
SET Y="BGPG("
SET X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_$$FMTE^XLFDT(BGPD)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+3 ;HAD MIS/AB
IF $DATA(BGPG(1))
QUIT 0
+4 SET BGPG=$$LASTPRC^BGP8UTL1(P,"BGP ABORTION PROCEDURES",BGPD,EDATE)
+5 IF BGPG
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)="D"
QUIT
+9 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+10 IF $PIECE(^AUPNPROB(X,0),U,8)<BGPD
QUIT
+11 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+12 SET Y=$PIECE(^AUPNPROB(X,0),U)
+13 IF '$$ICD^BGP8UTL2(Y,T,9)
QUIT
+14 SET G=1
+15 QUIT
End DoDot:1
+16 IF G
QUIT 0
+17 ;now check CPTs for Abortion and Miscarriage
+18 SET T=$ORDER(^ATXAX("B","BGP CPT ABORTION",0))
+19 SET %=$$CPT^BGP8DU(P,BGPD,EDATE,T,3)
+20 IF %]""
QUIT 0
+21 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+22 SET %=$$CPT^BGP8DU(P,BGPD,EDATE,T,3)
+23 IF %]""
QUIT 0
+24 SET T=$ORDER(^ATXAX("B","BGP CPT ABORTION",0))
+25 SET %=$$TRAN^BGP8DU(P,BGPD,EDATE,T,3)
+26 IF %]""
QUIT 0
+27 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+28 SET %=$$TRAN^BGP8DU(P,BGPD,EDATE,T,3)
+29 IF %]""
QUIT 0
+30 IF FORM=""
QUIT 1
+31 QUIT 1_U_$$DATE^BGP8UTL(BGPD)
