BGP6D714 ; IHS/CMI/LAB - measure 6 ;
;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
;
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=BDATE
I $G(CPED)="" S CPED=EDATE
S A=""
I $P($G(^AUPNREP(P,11)),U,1)="Y" D I A S BGPD=B G MA
.S B=$P($G(^AUPNREP(P,11)),U,2) Q:B=""
.Q:B<CPBD
.Q:B>CPED
.S A=1
.Q
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^BGP6UTL2(%,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^BGP6UTL2(%,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^BGP6UTL2(%,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 "" ;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^BGP6UTL2(Y,T,9)
.S G=$P(^AUPNPROB(X,0),U,8)
.Q
I G=0,BGPD="" Q 0
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 0 ;HAD MIS/AB
S BGPG=$$LASTPRC^BGP6UTL1(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^BGP6UTL2(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^BGP6DU(P,BGPD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
S %=$$CPT^BGP6DU(P,BGPD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
S %=$$TRAN^BGP6DU(P,BGPD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
S %=$$TRAN^BGP6DU(P,BGPD,EDATE,T,3)
I %]"" Q 0
I FORM="" Q 1
Q 1_U_$$DATE^BGP6UTL(BGPD)
BGP6D714 ; IHS/CMI/LAB - measure 6 ;
+1 ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
+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=BDATE
+4 IF $GET(CPED)=""
SET CPED=EDATE
+5 SET A=""
+6 IF $PIECE($GET(^AUPNREP(P,11)),U,1)="Y"
Begin DoDot:1
+7 SET B=$PIECE($GET(^AUPNREP(P,11)),U,2)
IF B=""
QUIT
+8 IF B<CPBD
QUIT
+9 IF B>CPED
QUIT
+10 SET A=1
+11 QUIT
End DoDot:1
IF A
SET BGPD=B
GOTO MA
+12 SET BGPD=""
+13 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
+14 IF '$DATA(BGPV)
GOTO PROB
+15 ;if there is one before time frame set this to 1
SET B=0
SET CNT=0
SET BGPD=""
+16 SET NORXCHR=$GET(NORXCHR)
+17 SET NORX=$GET(NORX)
+18 KILL BGPG
+19 SET DXT=$ORDER(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
+20 SET PXT=$ORDER(^ATXAX("B","BGP PREGNANCY ICD PROCEDURES",0))
+21 SET CPTT=$ORDER(^ATXAX("B","BGP PREGNANCY CPT CODES",0))
+22 ;CHECK DX, PROCS, CPTS for 2 separate visits
+23 SET B=0
SET CTR=0
FOR
SET CTR=$ORDER(BGPV(CTR))
IF CTR'=+CTR
QUIT
Begin DoDot:1
+24 ;get visit into VIEN
+25 SET VIEN=$PIECE(BGPV(CTR),U,5)
+26 SET D=$$VD^APCLV(VIEN)
+27 SET C=$$CLINIC^APCLV(VIEN,"C")
+28 IF NORXCHR
IF C=39
QUIT
+29 IF NORX
IF C=39
QUIT
+30 SET C=$$PRIMPROV^APCLV(VIEN,"D")
+31 ;no chr as primary provider
IF NORXCHR
IF C=53
QUIT
+32 ;now check for dx
+33 SET Y=0
SET H=""
FOR
SET Y=$ORDER(^AUPNVPOV("AD",VIEN,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+34 SET %=+^AUPNVPOV(Y,0)
+35 IF $$ICD^BGP6UTL2(%,DXT,9)
SET BGPDX(D)=""
SET CNT=CNT+1
SET H=1
IF D>$$FMADD^XLFDT(EDATE,-365)
SET B=1
End DoDot:2
+36 IF H
QUIT
+37 ;NOW GO THROUGH CPTS
+38 SET Y=0
SET H=""
FOR
SET Y=$ORDER(^AUPNVCPT("AD",VIEN,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+39 SET %=+^AUPNVCPT(Y,0)
+40 IF $$ICD^BGP6UTL2(%,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
+41 IF H
QUIT
+42 ;NOW PROCEDURES
+43 SET Y=0
SET H=""
FOR
SET Y=$ORDER(^AUPNVPRC("AD",VIEN,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+44 SET %=+^AUPNVPRC(Y,0)
+45 IF $$ICD^BGP6UTL2(%,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
+46 IF H
QUIT
+47 QUIT
End DoDot:1
+48 IF CNT>1
IF B
Begin DoDot:1
+49 ;SET BGPD TO SECOND VISIT DATE
+50 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
+51 ;
PROB ;
+1 ;no pregnancy visit during time period ;-Lori fix in 09
IF '$GET(B)
QUIT ""
+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^BGP6UTL2(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 0
+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 0
+3 SET BGPG=$$LASTPRC^BGP6UTL1(P,"BGP ABORTION PROCEDURES",BGPD,EDATE)
+4 IF BGPG
QUIT 0
+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^BGP6UTL2(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^BGP6DU(P,BGPD,EDATE,T,3)
+19 IF %]""
QUIT 0
+20 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+21 SET %=$$CPT^BGP6DU(P,BGPD,EDATE,T,3)
+22 IF %]""
QUIT 0
+23 SET T=$ORDER(^ATXAX("B","BGP CPT ABORTION",0))
+24 SET %=$$TRAN^BGP6DU(P,BGPD,EDATE,T,3)
+25 IF %]""
QUIT 0
+26 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+27 SET %=$$TRAN^BGP6DU(P,BGPD,EDATE,T,3)
+28 IF %]""
QUIT 0
+29 IF FORM=""
QUIT 1
+30 QUIT 1_U_$$DATE^BGP6UTL(BGPD)
