- 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