BGP8D715 ; IHS/CMI/LAB - measure 6 ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
PREG(P,BDATE,EDATE,NOCHR,NORX,FORM,CPBD,CPED,TCNT) ;EP
I $P($G(^DPT(P,0)),U,2)'="F" Q ""
NEW B,E,A,CNT,BGPD,BGPG,X,Y,BGPDX,C,D,G,T,%,CTR,VIEN,DXT,PXT,CPTT,BGPV,H,BGP20M,T1,T2,MADX,APC,MCPT,ACPT
I '$G(FORM) S FORM=""
I $G(CPBD)="" S CPBD=$$FMADD^XLFDT(BDATE,-365)
I $G(CPED)="" S CPED=EDATE
I '$G(TCNT) S TCNT=1
S D=$$RF(P,BDATE,EDATE) I D Q $S(FORM="":1,1:$$DATE^BGP8UTL(D)) ;REPRODUCTIVE FACTORS
;check problem list next
PL ;must be modified in the past 20 months from EDATE
S BGP20M=$$FMADD^XLFDT(EDATE,-608)
S T=$O(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
S T1=$O(^ATXAX("B","BGP MISCARRIAGE/ABORTION DXS",0))
S (X,G,A)=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"
.S A=0
.;S D=$P(^AUPNPROB(X,0),U,3)
.;I D'<BGP20M,D'>EDATE S A=1
.;S D=$P(^AUPNPROB(X,0),U,8)
.;I D'<BGP20M,D'>EDATE S A=1
.;S D=$P(^AUPNPROB(X,0),U,13)
.;I D'<BGP20M,D'>EDATE S A=1
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.Q:$P(^AUPNPROB(X,0),U,8)<BGP20M
.;Q:'A
.S Y=$P(^AUPNPROB(X,0),U)
.I '$$ICD^BGP8UTL2(Y,T,9),'$$ICD^BGP8UTL2(Y,T1,9) Q ;must be one of these
.S G=$P(^AUPNPROB(X,0),U,8)
I G Q $S(FORM="":1,1:$$DATE^BGP8UTL(G))
V ;now visits
D ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
I '$D(BGPV) Q ""
S CNT=0,BGPD=""
S NOCHR=$G(NOCHR)
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))
S MADX=$O(^ATXAX("B","BGP MISCARRIAGE/ABORTION DXS",0))
S APC=$O(^ATXAX("B","BGP ABORTION PROCEDURES",0))
S MCPT=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
S ACPT=$O(^ATXAX("B","BGP CPT ABORTION",0))
;CHECK DX, PROCS, CPTS for CNT separate visits
S B=0,CTR=0 F S CTR=$O(BGPV(CTR)) Q:CTR'=+CTR!(CNT>(TCNT-1)) D
.;get visit into VIEN
.S VIEN=$P(BGPV(CTR),U,5)
.S D=$$VD^APCLV(VIEN)
.S C=$$CLINIC^APCLV(VIEN,"C")
.I NORX,C=39 Q
.S C=$$PRIMPROV^APCLV(VIEN,"D")
.I NOCHR,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)!($$ICD^BGP8UTL2(%,MADX,9)) S BGPDX(D)="",CNT=CNT+1,H=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)!($$ICD^BGP8UTL2(%,MCPT,1))!($$ICD^BGP8UTL2(%,ACPT,1)) I '$D(BGPDX(D)) S BGPDX(D)="",CNT=CNT+1,H=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)!($$ICD^BGP8UTL2(%,APC,0)) I '$D(BGPDX(D)) S BGPDX(D)="",CNT=CNT+1,H=1
.Q:H
.Q
I CNT>(TCNT-1) S D=$O(BGPDX(0)) Q $S(FORM="":1,1:$$DATE^BGP8UTL(D))
Q ""
RF(P,CPBD,CPED) ;CHECK REPRODUCTIVE FACTORS
NEW A,B
I $P($G(^AUPNREP(P,11)),U,1)'="Y" Q ""
S A=""
S B=$P($G(^AUPNREP(P,11)),U,2)
I B="" Q ""
I B<CPBD Q ""
I B>CPED Q ""
Q B
BGP8D715 ; IHS/CMI/LAB - measure 6 ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
PREG(P,BDATE,EDATE,NOCHR,NORX,FORM,CPBD,CPED,TCNT) ;EP
+1 IF $PIECE($GET(^DPT(P,0)),U,2)'="F"
QUIT ""
+2 NEW B,E,A,CNT,BGPD,BGPG,X,Y,BGPDX,C,D,G,T,%,CTR,VIEN,DXT,PXT,CPTT,BGPV,H,BGP20M,T1,T2,MADX,APC,MCPT,ACPT
+3 IF '$GET(FORM)
SET FORM=""
+4 IF $GET(CPBD)=""
SET CPBD=$$FMADD^XLFDT(BDATE,-365)
+5 IF $GET(CPED)=""
SET CPED=EDATE
+6 IF '$GET(TCNT)
SET TCNT=1
+7 ;REPRODUCTIVE FACTORS
SET D=$$RF(P,BDATE,EDATE)
IF D
QUIT $SELECT(FORM="":1,1:$$DATE^BGP8UTL(D))
+8 ;check problem list next
PL ;must be modified in the past 20 months from EDATE
+1 SET BGP20M=$$FMADD^XLFDT(EDATE,-608)
+2 SET T=$ORDER(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
+3 SET T1=$ORDER(^ATXAX("B","BGP MISCARRIAGE/ABORTION DXS",0))
+4 SET (X,G,A)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+5 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+6 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+7 SET A=0
+8 ;S D=$P(^AUPNPROB(X,0),U,3)
+9 ;I D'<BGP20M,D'>EDATE S A=1
+10 ;S D=$P(^AUPNPROB(X,0),U,8)
+11 ;I D'<BGP20M,D'>EDATE S A=1
+12 ;S D=$P(^AUPNPROB(X,0),U,13)
+13 ;I D'<BGP20M,D'>EDATE S A=1
+14 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+15 IF $PIECE(^AUPNPROB(X,0),U,8)<BGP20M
QUIT
+16 ;Q:'A
+17 SET Y=$PIECE(^AUPNPROB(X,0),U)
+18 ;must be one of these
IF '$$ICD^BGP8UTL2(Y,T,9)
IF '$$ICD^BGP8UTL2(Y,T1,9)
QUIT
+19 SET G=$PIECE(^AUPNPROB(X,0),U,8)
End DoDot:1
+20 IF G
QUIT $SELECT(FORM="":1,1:$$DATE^BGP8UTL(G))
V ;now visits
+1 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
+2 IF '$DATA(BGPV)
QUIT ""
+3 SET CNT=0
SET BGPD=""
+4 SET NOCHR=$GET(NOCHR)
+5 SET NORX=$GET(NORX)
+6 KILL BGPG
+7 SET DXT=$ORDER(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
+8 SET PXT=$ORDER(^ATXAX("B","BGP PREGNANCY ICD PROCEDURES",0))
+9 SET CPTT=$ORDER(^ATXAX("B","BGP PREGNANCY CPT CODES",0))
+10 SET MADX=$ORDER(^ATXAX("B","BGP MISCARRIAGE/ABORTION DXS",0))
+11 SET APC=$ORDER(^ATXAX("B","BGP ABORTION PROCEDURES",0))
+12 SET MCPT=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+13 SET ACPT=$ORDER(^ATXAX("B","BGP CPT ABORTION",0))
+14 ;CHECK DX, PROCS, CPTS for CNT separate visits
+15 SET B=0
SET CTR=0
FOR
SET CTR=$ORDER(BGPV(CTR))
IF CTR'=+CTR!(CNT>(TCNT-1))
QUIT
Begin DoDot:1
+16 ;get visit into VIEN
+17 SET VIEN=$PIECE(BGPV(CTR),U,5)
+18 SET D=$$VD^APCLV(VIEN)
+19 SET C=$$CLINIC^APCLV(VIEN,"C")
+20 IF NORX
IF C=39
QUIT
+21 SET C=$$PRIMPROV^APCLV(VIEN,"D")
+22 ;no chr as primary provider
IF NOCHR
IF C=53
QUIT
+23 ;now check for dx
+24 SET Y=0
SET H=""
FOR
SET Y=$ORDER(^AUPNVPOV("AD",VIEN,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+25 SET %=+^AUPNVPOV(Y,0)
+26 IF $$ICD^BGP8UTL2(%,DXT,9)!($$ICD^BGP8UTL2(%,MADX,9))
SET BGPDX(D)=""
SET CNT=CNT+1
SET H=1
End DoDot:2
+27 IF H
QUIT
+28 ;NOW GO THROUGH CPTS
+29 SET Y=0
SET H=""
FOR
SET Y=$ORDER(^AUPNVCPT("AD",VIEN,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+30 SET %=+^AUPNVCPT(Y,0)
+31 IF $$ICD^BGP8UTL2(%,CPTT,1)!($$ICD^BGP8UTL2(%,MCPT,1))!($$ICD^BGP8UTL2(%,ACPT,1))
IF '$DATA(BGPDX(D))
SET BGPDX(D)=""
SET CNT=CNT+1
SET H=1
End DoDot:2
+32 IF H
QUIT
+33 ;NOW PROCEDURES
+34 SET Y=0
SET H=""
FOR
SET Y=$ORDER(^AUPNVPRC("AD",VIEN,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+35 SET %=+^AUPNVPRC(Y,0)
+36 IF $$ICD^BGP8UTL2(%,PXT,0)!($$ICD^BGP8UTL2(%,APC,0))
IF '$DATA(BGPDX(D))
SET BGPDX(D)=""
SET CNT=CNT+1
SET H=1
End DoDot:2
+37 IF H
QUIT
+38 QUIT
End DoDot:1
+39 IF CNT>(TCNT-1)
SET D=$ORDER(BGPDX(0))
QUIT $SELECT(FORM="":1,1:$$DATE^BGP8UTL(D))
+40 QUIT ""
RF(P,CPBD,CPED) ;CHECK REPRODUCTIVE FACTORS
+1 NEW A,B
+2 IF $PIECE($GET(^AUPNREP(P,11)),U,1)'="Y"
QUIT ""
+3 SET A=""
+4 SET B=$PIECE($GET(^AUPNREP(P,11)),U,2)
+5 IF B=""
QUIT ""
+6 IF B<CPBD
QUIT ""
+7 IF B>CPED
QUIT ""
+8 QUIT B
