BGP8D53 ; IHS/CMI/LAB - measure calc ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;\
IK ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13)=0
S BGPSEXA=0
I 'BGPACTUP S BGPSTOP=1 Q
I BGPSEX'="F" S BGPSTOP=1 Q
I BGPAGEB<16 S BGPSTOP=1 Q
I BGPAGEB>25 S BGPSTOP=1 Q
I BGPACTUP S BGPD2=1
I BGPACTCL S BGPD1=1
I BGPACTCL,BGPAGEB>15,BGPAGEB<21 S BGPD3=1
I BGPACTCL,BGPAGEB>20,BGPAGEB<26 S BGPD4=1
I BGPACTUP,BGPAGEB>15,BGPAGEB<21 S BGPD5=1
I BGPACTUP,BGPAGEB>20,BGPAGEB<26 S BGPD6=1
I BGPACTCL,BGPAGEB>20,BGPAGEB<25 S BGPD7=1 ;AC 21-24 V18
I BGPAGEB>15,BGPAGEB<25,$$SEXA(DFN,BGPBDATE,BGPEDATE),'$$HOSPICE^BGP8D74(DFN,BGPBDATE,BGPEDATE) S BGPSEXA=1 ;SEXUALLY ACTIVE, NO HOSPICE 16-24
I BGPACTCL,BGPSEXA S BGPD8=1
I BGPACTCL,BGPSEXA,BGPAGEB>15,BGPAGEB<21 S BGPD9=1
I BGPACTCL,BGPSEXA,BGPAGEB>20,BGPAGEB<25 S BGPD10=1
I BGPACTUP,BGPSEXA S BGPD11=1
I BGPACTUP,BGPSEXA,BGPAGEB>15,BGPAGEB<21 S BGPD12=1
I BGPACTUP,BGPSEXA,BGPAGEB>20,BGPAGEB<25 S BGPD13=1
S BGPNV=$$CHL(DFN,BGPBDATE,BGPEDATE)
S BGPN1=+BGPNV
I 'BGPN1 S BGPREF=$$REFCHL(DFN,BGPBDATE,BGPEDATE) I BGPREF S BGPN2=1
S BGPVALUE=$S(BGPD2:"UP",1:"")_$S(BGPD1:",AC",1:"")_$S(BGPSEXA:",SA",1:"")_"|||"_$S(BGPN1:$P(BGPNV,U,3)_" "_$P(BGPNV,U,2),BGPN2:$P(BGPREF,U,3)_" "_$P(BGPREF,U,2),1:"")
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
Q
CHL(P,BDATE,EDATE) ;EP
I '$G(P) Q ""
S BGPC=""
K BGPG S %=P_"^LAST DX [BGP CHLAMYDIA SCREEN DXS;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 1_U_$$DATE^BGP8UTL($P(BGPG(1),U))_U_$P(BGPG(1),U,2)
;check cpt taxonomy
S T=$O(^ATXAX("B","BGP CHLAMYDIA CPTS",0))
I T D I X Q 1_U_"CPT "_$P(X,U,3)_U_$$DATE^BGP8UTL($P(X,U,2))
.S X=$$CPT^BGP8DU(P,BDATE,EDATE,T,6) I X]"" Q
.S X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,6)
;now get all loinc/taxonomy tests
S BGPC=""
S T=$O(^ATXAX("B","BGP CHLAMYDIA LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","BGP CHLAMYDIA TESTS TAX",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(BGPC) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC) D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC) D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_"Lab test"_U_$$DATE^BGP8UTL((9999999-D)) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S R=$P(^AUPNVLAB(X,0),U,4)
...S BGPC=1_U_"Lab Test "_U_$$DATE^BGP8UTL((9999999-D))
...Q
I BGPC Q BGPC
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVMIC("AE",P,D)) Q:D'=+D!(D>B)!(BGPC) D
.S L=0 F S L=$O(^AUPNVMIC("AE",P,D,L)) Q:L'=+L!(BGPC) D
..S X=0 F S X=$O(^AUPNVMIC("AE",P,D,L,X)) Q:X'=+X!(BGPC) D
...Q:'$D(^AUPNVMIC(X,0))
...I BGPLT,$P(^AUPNVMIC(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVMIC(X,0),U))) S BGPC=1_U_"Micro test"_U_$$DATE^BGP8UTL((9999999-D)) Q
...Q:'T
...S J=$P($G(^AUPNVMIC(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S R=$P(^AUPNVMIC(X,0),U,4)
...S BGPC=1_U_"Micro Test "_U_$$DATE^BGP8UTL((9999999-D))
...Q
Q BGPC
LOINC(A,B) ;
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
REFCHL(P,BDATE,EDATE) ;refusal for chlamydia
NEW T,BGPT,G,BGPT1
S T=$$CPTREFT^BGP8UTL1(P,BDATE,EDATE,$O(^ATXAX("B","BGP CHLAMYDIA CPTS",0)),"R")
I T S T="1^"_"Refused CPT "_$P(T,U,4)_U_$$DATE^BGP8UTL($P(T,U,2)) Q T
S BGPT=$O(^ATXLAB("B","BGP CHLAMYDIA TESTS TAX",0))
I BGPT D I $P(G,U) Q "1^"_"Refused Lab "_U_$$DATE^BGP8UTL($P(G,U,2))
.S (G,BGPT1)=0 F S BGPT1=$O(^ATXLAB(BGPT,21,"B",BGPT1)) Q:BGPT1=""!($P(G,U)) D
..S G=$$REFUSAL^BGP8UTL1(P,60,BGPT1,BDATE,EDATE)
Q ""
SEXA(P,BDATE,EDATE) ;EP
NEW A,B,C,BGPMEDS1,X
;DX
S X=$$LASTDX^BGP8UTL1(P,"BGP SEXUAL ACTIVITY DXS",BDATE,EDATE) I X Q 1
S X=$$LASTPRC^BGP8UTL1(P,"BGP SEXUAL ACTIVITY PROCEDURES",BDATE,EDATE) I X Q 1
S X=$$CPT^BGP8DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP CPT SEXUAL ACTIVITY",0)),1) I X Q 1
K BGPMEDS1
D GETMEDS^BGP8UTL2(P,BDATE,EDATE,"BGP HEDIS CONTRACEPTION MEDS","BGP HEDIS CONTRACEPTION NDC",,,.BGPMEDS1)
I $D(BGPMEDS1) Q 1
I $$PREGTEST(DFN,BGPBDATE,BGPEDATE) Q 1
I $$PREG^BGP8D715(DFN,$$FMADD^XLFDT(EDATE,-608),BGPEDATE,1,1,"",BGPBDATE,BGPEDATE) Q 1
Q 0
PREGTEST(P,BDATE,EDATE) ;EP - pregnancy test with no isotretinoin med
;LOOP ALL CPTS
NEW D,BD,ED,X,Y,D,G,V,T,BGPMEDS1,Z
S T=$O(^ATXAX("B","BGP CPT PREGNANCY TEST",0))
S ED=(9999999-EDATE),BD=9999999-BDATE,G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G) D
..Q:'$D(^AUPNVSIT(V,0))
..Q:'$D(^AUPNVCPT("AD",V))
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X!(G) D
...Q:'$$ICD^BGP8UTL2($P(^AUPNVCPT(X,0),U),T,1) ;NOT A PREG TEST
...S D=$$VD^APCLV(V) ;DATE
...;GET ANY MED FROM D TO D+6
...K BGPMEDS1
...D GETMEDS^BGP8UTL2(P,D,$$FMADD^XLFDT(D,6),"BGP HEDIS ISOTRETINOIN MEDS","BGP HEDIS ISOTRETINOIN NDC",,,.BGPMEDS1)
...Q:$D(BGPMEDS1)
...S Z=$$RAD^BGP8DU(P,D,$$FMADD^XLFDT(D,6),$O(^ATXAX("B","BGP CPT XRAY",0)),1) I Z Q
...S Z=$$CPT^BGP8DU(P,D,$$FMADD^XLFDT(D,6),$O(^ATXAX("B","BGP CPT XRAY",0)),1) I Z Q
...S G=1
Q G
PREG(P,BDATE,EDATE,NORXCHR,NORX,FORM,CPBD,CPED) ;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 A=""
I $P($G(^AUPNREP(P,11)),U,1)="Y" D
.S B=$P($G(^AUPNREP(P,11)),U,2) Q:B=""
.Q:B<CPBD
.Q:B>CPED
.S A=1
.Q
I A Q A
S BGPD=""
D ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
I '$D(BGPV) Q 0
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!(CNT>0) 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>0 Q 1
MA ;now check for abortion or miscarriage
K BGPG S Y="BGPG(" S X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 1 ;HAD MIS/AB
S BGPG=$$LASTPRC^BGP8UTL1(P,"BGP ABORTION PROCEDURES",BDATE,EDATE)
I BGPG Q 1
;now check CPTs for Abortion and Miscarriage
S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
S %=$$CPT^BGP8DU(P,BDATE,EDATE,T,3)
I %]"" Q 1
S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
S %=$$CPT^BGP8DU(P,BDATE,EDATE,T,3)
I %]"" Q 1
S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
S %=$$TRAN^BGP8DU(P,BDATE,EDATE,T,3)
I %]"" Q 1
S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
S %=$$TRAN^BGP8DU(P,BDATE,EDATE,T,3)
I %]"" Q 1
Q 0
BGP8D53 ; IHS/CMI/LAB - measure calc ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;\
IK ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13)=0
+2 SET BGPSEXA=0
+3 IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+4 IF BGPSEX'="F"
SET BGPSTOP=1
QUIT
+5 IF BGPAGEB<16
SET BGPSTOP=1
QUIT
+6 IF BGPAGEB>25
SET BGPSTOP=1
QUIT
+7 IF BGPACTUP
SET BGPD2=1
+8 IF BGPACTCL
SET BGPD1=1
+9 IF BGPACTCL
IF BGPAGEB>15
IF BGPAGEB<21
SET BGPD3=1
+10 IF BGPACTCL
IF BGPAGEB>20
IF BGPAGEB<26
SET BGPD4=1
+11 IF BGPACTUP
IF BGPAGEB>15
IF BGPAGEB<21
SET BGPD5=1
+12 IF BGPACTUP
IF BGPAGEB>20
IF BGPAGEB<26
SET BGPD6=1
+13 ;AC 21-24 V18
IF BGPACTCL
IF BGPAGEB>20
IF BGPAGEB<25
SET BGPD7=1
+14 ;SEXUALLY ACTIVE, NO HOSPICE 16-24
IF BGPAGEB>15
IF BGPAGEB<25
IF $$SEXA(DFN,BGPBDATE,BGPEDATE)
IF '$$HOSPICE^BGP8D74(DFN,BGPBDATE,BGPEDATE)
SET BGPSEXA=1
+15 IF BGPACTCL
IF BGPSEXA
SET BGPD8=1
+16 IF BGPACTCL
IF BGPSEXA
IF BGPAGEB>15
IF BGPAGEB<21
SET BGPD9=1
+17 IF BGPACTCL
IF BGPSEXA
IF BGPAGEB>20
IF BGPAGEB<25
SET BGPD10=1
+18 IF BGPACTUP
IF BGPSEXA
SET BGPD11=1
+19 IF BGPACTUP
IF BGPSEXA
IF BGPAGEB>15
IF BGPAGEB<21
SET BGPD12=1
+20 IF BGPACTUP
IF BGPSEXA
IF BGPAGEB>20
IF BGPAGEB<25
SET BGPD13=1
+21 SET BGPNV=$$CHL(DFN,BGPBDATE,BGPEDATE)
+22 SET BGPN1=+BGPNV
+23 IF 'BGPN1
SET BGPREF=$$REFCHL(DFN,BGPBDATE,BGPEDATE)
IF BGPREF
SET BGPN2=1
+24 SET BGPVALUE=$SELECT(BGPD2:"UP",1:"")_$SELECT(BGPD1:",AC",1:"")_$SELECT(BGPSEXA:",SA",1:"")_"|||"_$SELECT(BGPN1:$PIECE(BGPNV,U,3)_" "_$PIECE(BGPNV,U,2),BGPN2:$PIECE(BGPREF,U,3)_" "_$PIECE(BGPREF,U,2),1:"")
+25 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
+26 QUIT
CHL(P,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 SET BGPC=""
+3 KILL BGPG
SET %=P_"^LAST DX [BGP CHLAMYDIA SCREEN DXS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+4 IF $DATA(BGPG(1))
QUIT 1_U_$$DATE^BGP8UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U,2)
+5 ;check cpt taxonomy
+6 SET T=$ORDER(^ATXAX("B","BGP CHLAMYDIA CPTS",0))
+7 IF T
Begin DoDot:1
+8 SET X=$$CPT^BGP8DU(P,BDATE,EDATE,T,6)
IF X]""
QUIT
+9 SET X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,6)
End DoDot:1
IF X
QUIT 1_U_"CPT "_$PIECE(X,U,3)_U_$$DATE^BGP8UTL($PIECE(X,U,2))
+10 ;now get all loinc/taxonomy tests
+11 SET BGPC=""
+12 SET T=$ORDER(^ATXAX("B","BGP CHLAMYDIA LOINC CODES",0))
+13 SET BGPLT=$ORDER(^ATXLAB("B","BGP CHLAMYDIA TESTS TAX",0))
+14 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!(BGPC)
QUIT
Begin DoDot:1
+15 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC)
QUIT
Begin DoDot:2
+16 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC)
QUIT
Begin DoDot:3
+17 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+18 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=1_U_"Lab test"_U_$$DATE^BGP8UTL((9999999-D))
QUIT
+19 IF 'T
QUIT
+20 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+21 IF '$$LOINC(J,T)
QUIT
+22 SET R=$PIECE(^AUPNVLAB(X,0),U,4)
+23 SET BGPC=1_U_"Lab Test "_U_$$DATE^BGP8UTL((9999999-D))
+24 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+25 IF BGPC
QUIT BGPC
+26 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVMIC("AE",P,D))
IF D'=+D!(D>B)!(BGPC)
QUIT
Begin DoDot:1
+27 SET L=0
FOR
SET L=$ORDER(^AUPNVMIC("AE",P,D,L))
IF L'=+L!(BGPC)
QUIT
Begin DoDot:2
+28 SET X=0
FOR
SET X=$ORDER(^AUPNVMIC("AE",P,D,L,X))
IF X'=+X!(BGPC)
QUIT
Begin DoDot:3
+29 IF '$DATA(^AUPNVMIC(X,0))
QUIT
+30 IF BGPLT
IF $PIECE(^AUPNVMIC(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVMIC(X,0),U)))
SET BGPC=1_U_"Micro test"_U_$$DATE^BGP8UTL((9999999-D))
QUIT
+31 IF 'T
QUIT
+32 SET J=$PIECE($GET(^AUPNVMIC(X,11)),U,13)
IF J=""
QUIT
+33 IF '$$LOINC(J,T)
QUIT
+34 SET R=$PIECE(^AUPNVMIC(X,0),U,4)
+35 SET BGPC=1_U_"Micro Test "_U_$$DATE^BGP8UTL((9999999-D))
+36 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+37 QUIT BGPC
LOINC(A,B) ;
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
REFCHL(P,BDATE,EDATE) ;refusal for chlamydia
+1 NEW T,BGPT,G,BGPT1
+2 SET T=$$CPTREFT^BGP8UTL1(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP CHLAMYDIA CPTS",0)),"R")
+3 IF T
SET T="1^"_"Refused CPT "_$PIECE(T,U,4)_U_$$DATE^BGP8UTL($PIECE(T,U,2))
QUIT T
+4 SET BGPT=$ORDER(^ATXLAB("B","BGP CHLAMYDIA TESTS TAX",0))
+5 IF BGPT
Begin DoDot:1
+6 SET (G,BGPT1)=0
FOR
SET BGPT1=$ORDER(^ATXLAB(BGPT,21,"B",BGPT1))
IF BGPT1=""!($PIECE(G,U))
QUIT
Begin DoDot:2
+7 SET G=$$REFUSAL^BGP8UTL1(P,60,BGPT1,BDATE,EDATE)
End DoDot:2
End DoDot:1
IF $PIECE(G,U)
QUIT "1^"_"Refused Lab "_U_$$DATE^BGP8UTL($PIECE(G,U,2))
+8 QUIT ""
SEXA(P,BDATE,EDATE) ;EP
+1 NEW A,B,C,BGPMEDS1,X
+2 ;DX
+3 SET X=$$LASTDX^BGP8UTL1(P,"BGP SEXUAL ACTIVITY DXS",BDATE,EDATE)
IF X
QUIT 1
+4 SET X=$$LASTPRC^BGP8UTL1(P,"BGP SEXUAL ACTIVITY PROCEDURES",BDATE,EDATE)
IF X
QUIT 1
+5 SET X=$$CPT^BGP8DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP CPT SEXUAL ACTIVITY",0)),1)
IF X
QUIT 1
+6 KILL BGPMEDS1
+7 DO GETMEDS^BGP8UTL2(P,BDATE,EDATE,"BGP HEDIS CONTRACEPTION MEDS","BGP HEDIS CONTRACEPTION NDC",,,.BGPMEDS1)
+8 IF $DATA(BGPMEDS1)
QUIT 1
+9 IF $$PREGTEST(DFN,BGPBDATE,BGPEDATE)
QUIT 1
+10 IF $$PREG^BGP8D715(DFN,$$FMADD^XLFDT(EDATE,-608),BGPEDATE,1,1,"",BGPBDATE,BGPEDATE)
QUIT 1
+11 QUIT 0
PREGTEST(P,BDATE,EDATE) ;EP - pregnancy test with no isotretinoin med
+1 ;LOOP ALL CPTS
+2 NEW D,BD,ED,X,Y,D,G,V,T,BGPMEDS1,Z
+3 SET T=$ORDER(^ATXAX("B","BGP CPT PREGNANCY TEST",0))
+4 SET ED=(9999999-EDATE)
SET BD=9999999-BDATE
SET G=0
+5 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)!(G)
QUIT
Begin DoDot:1
+6 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V!(G)
QUIT
Begin DoDot:2
+7 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+8 IF '$DATA(^AUPNVCPT("AD",V))
QUIT
+9 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+10 ;NOT A PREG TEST
IF '$$ICD^BGP8UTL2($PIECE(^AUPNVCPT(X,0),U),T,1)
QUIT
+11 ;DATE
SET D=$$VD^APCLV(V)
+12 ;GET ANY MED FROM D TO D+6
+13 KILL BGPMEDS1
+14 DO GETMEDS^BGP8UTL2(P,D,$$FMADD^XLFDT(D,6),"BGP HEDIS ISOTRETINOIN MEDS","BGP HEDIS ISOTRETINOIN NDC",,,.BGPMEDS1)
+15 IF $DATA(BGPMEDS1)
QUIT
+16 SET Z=$$RAD^BGP8DU(P,D,$$FMADD^XLFDT(D,6),$ORDER(^ATXAX("B","BGP CPT XRAY",0)),1)
IF Z
QUIT
+17 SET Z=$$CPT^BGP8DU(P,D,$$FMADD^XLFDT(D,6),$ORDER(^ATXAX("B","BGP CPT XRAY",0)),1)
IF Z
QUIT
+18 SET G=1
End DoDot:3
End DoDot:2
End DoDot:1
+19 QUIT G
PREG(P,BDATE,EDATE,NORXCHR,NORX,FORM,CPBD,CPED) ;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 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
+12 IF A
QUIT A
+13 SET BGPD=""
+14 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
+15 IF '$DATA(BGPV)
QUIT 0
+16 ;if there is one before time frame set this to 1
SET B=0
SET CNT=0
SET BGPD=""
+17 SET NORXCHR=$GET(NORXCHR)
+18 SET NORX=$GET(NORX)
+19 KILL BGPG
+20 SET DXT=$ORDER(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
+21 SET PXT=$ORDER(^ATXAX("B","BGP PREGNANCY ICD PROCEDURES",0))
+22 SET CPTT=$ORDER(^ATXAX("B","BGP PREGNANCY CPT CODES",0))
+23 ;CHECK DX, PROCS, CPTS for 2 separate visits
+24 SET B=0
SET CTR=0
FOR
SET CTR=$ORDER(BGPV(CTR))
IF CTR'=+CTR!(CNT>0)
QUIT
Begin DoDot:1
+25 ;get visit into VIEN
+26 SET VIEN=$PIECE(BGPV(CTR),U,5)
+27 SET D=$$VD^APCLV(VIEN)
+28 SET C=$$CLINIC^APCLV(VIEN,"C")
+29 IF NORXCHR
IF C=39
QUIT
+30 IF NORX
IF C=39
QUIT
+31 SET C=$$PRIMPROV^APCLV(VIEN,"D")
+32 ;no chr as primary provider
IF NORXCHR
IF C=53
QUIT
+33 ;now check for dx
+34 SET Y=0
SET H=""
FOR
SET Y=$ORDER(^AUPNVPOV("AD",VIEN,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+35 SET %=+^AUPNVPOV(Y,0)
+36 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
+37 IF H
QUIT
+38 ;NOW GO THROUGH CPTS
+39 SET Y=0
SET H=""
FOR
SET Y=$ORDER(^AUPNVCPT("AD",VIEN,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+40 SET %=+^AUPNVCPT(Y,0)
+41 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
+42 IF H
QUIT
+43 ;NOW PROCEDURES
+44 SET Y=0
SET H=""
FOR
SET Y=$ORDER(^AUPNVPRC("AD",VIEN,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+45 SET %=+^AUPNVPRC(Y,0)
+46 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
+47 IF H
QUIT
+48 QUIT
End DoDot:1
+49 IF CNT>0
QUIT 1
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(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+2 ;HAD MIS/AB
IF $DATA(BGPG(1))
QUIT 1
+3 SET BGPG=$$LASTPRC^BGP8UTL1(P,"BGP ABORTION PROCEDURES",BDATE,EDATE)
+4 IF BGPG
QUIT 1
+5 ;now check CPTs for Abortion and Miscarriage
+6 SET T=$ORDER(^ATXAX("B","BGP CPT ABORTION",0))
+7 SET %=$$CPT^BGP8DU(P,BDATE,EDATE,T,3)
+8 IF %]""
QUIT 1
+9 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+10 SET %=$$CPT^BGP8DU(P,BDATE,EDATE,T,3)
+11 IF %]""
QUIT 1
+12 SET T=$ORDER(^ATXAX("B","BGP CPT ABORTION",0))
+13 SET %=$$TRAN^BGP8DU(P,BDATE,EDATE,T,3)
+14 IF %]""
QUIT 1
+15 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+16 SET %=$$TRAN^BGP8DU(P,BDATE,EDATE,T,3)
+17 IF %]""
QUIT 1
+18 QUIT 0
