Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP8D53

BGP8D53.m

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