- 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)