- 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
