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

BGP8D714.m

Go to the documentation of this file.
  1. BGP8D714 ; IHS/CMI/LAB - measure 6 ;
  1. ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
  1. ;
  1. PREG ;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 BGPD=""
  1. D ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
  1. I '$D(BGPV) G PROB
  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 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>1,B D G MA
  1. .;SET BGPD TO SECOND VISIT DATE
  1. .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
  1. ;
  1. PROB ;
  1. I '$G(B) Q $$RF(P,CPBD,CPED) ;no pregnancy visit during time period ;-Lori fix in 09
  1. S T=$O(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
  1. S (X,G)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
  1. .Q:$P(^AUPNPROB(X,0),U,12)="D"
  1. .Q:$P(^AUPNPROB(X,0),U,12)="I"
  1. .Q:$P(^AUPNPROB(X,0),U,8)>EDATE
  1. .Q:$P(^AUPNPROB(X,0),U,8)<BDATE
  1. .S Y=$P(^AUPNPROB(X,0),U)
  1. .Q:'$$ICD^BGP8UTL2(Y,T,9)
  1. .S G=$P(^AUPNPROB(X,0),U,8)
  1. .Q
  1. I G=0,BGPD="" Q $$RF(P,CPBD,CPED)
  1. S BGPD=G
  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(BGPD)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1. I $D(BGPG(1)) Q $$RF(P,CPBD,CPED) ;HAD MIS/AB
  1. S BGPG=$$LASTPRC^BGP8UTL1(P,"BGP ABORTION PROCEDURES",BGPD,EDATE)
  1. I BGPG Q $$RF(P,CPBD,CPED)
  1. S T=$O(^ATXAX("B","BGP MISCARRIAGE/ABORTION DXS",0))
  1. S (X,G)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
  1. .Q:$P(^AUPNPROB(X,0),U,12)="D"
  1. .Q:$P(^AUPNPROB(X,0),U,12)="I"
  1. .Q:$P(^AUPNPROB(X,0),U,8)<BGPD
  1. .Q:$P(^AUPNPROB(X,0),U,8)>EDATE
  1. .S Y=$P(^AUPNPROB(X,0),U)
  1. .Q:'$$ICD^BGP8UTL2(Y,T,9)
  1. .S G=1
  1. .Q
  1. I G Q $$RF(P,CPBD,CPED)
  1. ;now check CPTs for Abortion and Miscarriage
  1. S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
  1. S %=$$CPT^BGP8DU(P,BGPD,EDATE,T,3)
  1. I %]"" Q $$RF(P,CPBD,CPED)
  1. S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
  1. S %=$$CPT^BGP8DU(P,BGPD,EDATE,T,3)
  1. I %]"" Q $$RF(P,CPBD,CPED)
  1. S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
  1. S %=$$TRAN^BGP8DU(P,BGPD,EDATE,T,3)
  1. I %]"" Q $$RF(P,CPBD,CPED)
  1. S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
  1. S %=$$TRAN^BGP8DU(P,BGPD,EDATE,T,3)
  1. I %]"" Q $$RF(P,CPBD,CPED)
  1. I FORM="" Q 1
  1. Q 1_U_$$DATE^BGP8UTL(BGPD)
  1. RF(P,CPBD,CPED) ;CHECK REPRODUCTIVE FACTORS
  1. S A=""
  1. I $P($G(^AUPNREP(P,11)),U,1)="Y" D I A S BGPD=B G MARF
  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. Q 0
  1. MARF ;
  1. ;now check for abortion or miscarriage
  1. 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)
  1. I $D(BGPG(1)) Q 0 ;HAD MIS/AB
  1. S BGPG=$$LASTPRC^BGP8UTL1(P,"BGP ABORTION PROCEDURES",BGPD,EDATE)
  1. I BGPG Q 0
  1. S T=$O(^ATXAX("B","BGP MISCARRIAGE/ABORTION DXS",0))
  1. S (X,G)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
  1. .Q:$P(^AUPNPROB(X,0),U,12)="D"
  1. .Q:$P(^AUPNPROB(X,0),U,12)="I"
  1. .Q:$P(^AUPNPROB(X,0),U,8)<BGPD
  1. .Q:$P(^AUPNPROB(X,0),U,8)>EDATE
  1. .S Y=$P(^AUPNPROB(X,0),U)
  1. .Q:'$$ICD^BGP8UTL2(Y,T,9)
  1. .S G=1
  1. .Q
  1. I G Q 0
  1. ;now check CPTs for Abortion and Miscarriage
  1. S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
  1. S %=$$CPT^BGP8DU(P,BGPD,EDATE,T,3)
  1. I %]"" Q 0
  1. S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
  1. S %=$$CPT^BGP8DU(P,BGPD,EDATE,T,3)
  1. I %]"" Q 0
  1. S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
  1. S %=$$TRAN^BGP8DU(P,BGPD,EDATE,T,3)
  1. I %]"" Q 0
  1. S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
  1. S %=$$TRAN^BGP8DU(P,BGPD,EDATE,T,3)
  1. I %]"" Q 0
  1. I FORM="" Q 1
  1. Q 1_U_$$DATE^BGP8UTL(BGPD)