BGP5D3.m

BGP5D3 ; IHS/CMI/LAB - measure 11 17 Oct 2009 12:40 PM ;

 ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143

 ;

 ;

I10 ;EP

 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0

 S (BGPSEAL,BGPSEALD,BGPSEALR)=""

 K BGPSEALS,BGPSELDS,BGPSEALR

 D SEAL^BGP5D3A(DFN,BGPBDATE,BGPEDATE) ;this is for the number of sealants only

 D SEALR^BGP5D3A(DFN,BGPBDATE,BGPEDATE)

 S BGPN1=$P(BGPSEAL,U)+$P(BGPSEALR,U,1)

 ;BGPN1 is total # of sealants for sealant measure

 I BGPAGEB>1,BGPAGEB<16 S BGPN2=BGPN1

 I BGPAGEB>1,BGPAGEB<20,BGPN1 S BGPN7=1

 I BGPAGEB>15 S BGPN3=BGPN1

 I BGPAGEB>18 S BGPN4=BGPN1

I101 ;

 ;get new sealant definition 2015 gpra dev

 S BGPSEALD=""

 I 'BGPN1 S BGPSEALD=$$SEALDEV^BGP5D3A(DFN,BGPBDATE,BGPEDATE)

 I BGPSEALD S BGPN7=1

 I BGPAGEB>1,BGPAGEB<6,BGPN7 S BGPN10=1

 I BGPAGEB>2,BGPAGEB<6,BGPN7 S BGPN5=1

 I BGPAGEB>5,BGPAGEB<10,BGPN7 S BGPN6=1

 I BGPAGEB>9,BGPAGEB<13,BGPN7 S BGPN8=1

 I BGPAGEB>12,BGPAGEB<16,BGPN7 S BGPN9=1

 I BGPAGEB>1,BGPAGEB<16 S BGPD7=1

 I BGPAGEB>4,BGPAGEB<20 S BGPD8=1

 ;I 'BGPN1,'BGPD7 S BGPSTOP=1 Q

 S BGPVALUE="UP|||"   ;    _+BGPN1_" sealants"

 I 'BGPN1,BGPD7!(BGPD8) S BGPVALUE=BGPVALUE_$P(BGPSEALD,U,2)

 I BGPN1 S BGPVALUE=BGPVALUE_"; "_+BGPN1_" sealants: " S X=0 F  S X=$O(BGPSEALS(X)) Q:X'=+X  S D=0 F  S D=$O(BGPSEALS(X,D)) Q:D'=+D  S BGPVALUE=BGPVALUE_$S(X=1:"",1:"; ")_$$DATE^BGP5UTL(D)_" "_BGPSEALS(X,D)

 K BGPSEAL,BGPSEALD,BGPSEALR

 Q

I11 ;EP

 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPD1,BGPD2)=0

 NEW BGPFLUOR

 I '$G(BGPACTUP) S BGPSTOP=1 Q

 I BGPACTUP S BGPD1=1

 S BGPFLUOR=$$TF^BGP5D3A(DFN,BGPBDATE,BGPEDATE)

 ;I $P(BGPFLUOR,U,3)["Refused" S BGPN2=1 G I111

 S BGPN1=$P(BGPFLUOR,U)

 I BGPN1>4 S BGPN1=4

 I BGPAGEB>0,BGPAGEB<16 S BGPD2=1,BGPN3=$S(BGPN1:1,1:0)

 ;I BGPD1,'BGPD2 S BGPD3=1

I111 ;

 S BGPVALUE="UP|||"_+BGPN1_" topical fluoride"

 I +BGPN1 S BGPVALUE=BGPVALUE_": " F X=2:1:5 I $P(BGPFLUOR,U,X)]"" S BGPVALUE=BGPVALUE_$S(X>2:", ",1:"")_$$DATE^BGP5UTL($P($P(BGPFLUOR,U,X),"|",1))_" "_$P($P(BGPFLUOR,U,X),"|",2)

 ;I BGPN2 S BGPVALUE=BGPVALUE_": "_$$DATE^BGP5UTL($P(BGPFLUOR,U,2))_" "_$P(BGPFLUOR,U,3)

 S BGPVALUD="UP|||"

 I +BGPN1 S BGPVALUD=BGPVALUD_+BGPN1_" topical fluoride" I +BGPN1 S BGPVALUD=BGPVALUD_": " F X=2:1:5 I $P(BGPFLUOR,U,X)]"" S BGPVALUD=BGPVALUD_$S(X>2:", ",1:"")_$$DATE^BGP5UTL($P($P(BGPFLUOR,U,X),"|",1))_" "_$P($P(BGPFLUOR,U,X),"|",2)

 ;I BGPN2 S BGPVALUD=BGPVALUD_": "_$$DATE^BGP5UTL($P(BGPFLUOR,U,2))_" "_$P(BGPFLUOR,U,3)

 K ^TMP($J,"A"),BGPFLUOR

 Q

I12 ;EP

 NEW BGPHR,V,BGPAIM

 S BGPAIM=$$AGE^BGP5D36(DFN,2,BGPBDATE)

 ;I BGPAIM<6 S BGPSTOP=1 Q

 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13,BGPD14,BGPD15,BGPD16,BGPD17,BGPHR)=0

 S BGPHR=$$HIGHR^BGP5D3A(DFN,BGPEDATE)

 I BGPAGEB>49,BGPACTUP S BGPD5=1

 I BGPAGEB>49,BGPAGEB<65,BGPACTUP S BGPD6=1

 I BGPAGEB>64,BGPACTUP S BGPD7=1

 I BGPDMD2 S BGPD4=1

 I BGPAGEB>49,BGPACTCL S BGPD1=1

 I BGPAGEB>49,BGPAGEB<65,BGPACTCL S BGPD2=1

 I BGPAGEB>64,BGPACTCL S BGPD3=1

 I BGPACTCL S BGPD8=1

 I BGPAIM>5,BGPAGEB<18,BGPACTCL S BGPD9=1

 I BGPAGEB>17,BGPAGEB<50,BGPACTCL S BGPD10=1

 I BGPAGEB>17,BGPAGEB<50,BGPACTCL,BGPHR S BGPD11=1

 I BGPACTUP S BGPD12=1

 I BGPAIM>5,BGPAGEB<18,BGPACTUP S BGPD13=1

 I BGPAGEB>17,BGPAGEB<50,BGPACTUP S BGPD14=1

 I BGPAGEB>17,BGPAGEB<50,BGPACTUP,BGPHR S BGPD15=1

 I BGPAGEB>17,BGPACTUP S BGPD16=1

 I BGPAGEB>17,BGPACTCL S BGPD17=1

 I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9+BGPD10+BGPD11+BGPD12+BGPD13+BGPD14+BGPD15+BGPD16+BGPD17) S BGPSTOP=1 Q

 S BGPVALUE=$$FLU(DFN,,BGPEDATE) ;set to date of flu shot

 I $P(BGPVALUE,U,3)=1 S BGPN1=1

 ;I $P(BGPVALUE,U,3)=2 S BGPN2=1

 I $P(BGPVALUE,U,3)=3 S BGPN3=1,BGPN1=1

 I BGPN1 S BGPN7=1

 S BGPDV=""

 I BGPRTYPE=4 S BGPDV=$S(BGPACTUP:"UP",1:"") D

 .I BGPACTCL S BGPDV=BGPDV_$S(BGPDV]"":",AC",1:"AC")

 .I BGPD4 S BGPDV=BGPDV_$S(BGPDV]"":",AD",1:"AD")

 .I BGPHR S BGPDV=BGPDV_$S(BGPDV]"":",HR",1:"HR")

 I BGPRTYPE=1 D

 .S BGPDV=$S(BGPD3!(BGPD2):"AC",1:"") I BGPD4 S BGPDV=BGPDV_$S(BGPDV]"":",AD",1:"AD")

 .S BGPVALUD=$S(BGPD8:"AC",1:"")

 I BGPRTYPE=3!(BGPRTYPE=8) S BGPDV="AC"

 I BGPRTYPE=7 D

 .I BGPACTCL S BGPDV="AC"

 .I BGPD4 S BGPDV=BGPDV_$S(BGPDV]"":",AD",1:"AD")

 .I BGPHR S BGPDV=BGPDV_$S(BGPDV]"":",HR",1:"HR")

 I BGPRTYPE'=1 S BGPVALUE=BGPDV_"|||"_$$DATE^BGP5UTL($P(BGPVALUE,U,1))_" "_$P(BGPVALUE,U,2)

 I BGPRTYPE=1 D

 .S BGPDV=BGPDV_"|||"

 .S BGPVALUD=BGPVALUD_"|||"

 .I BGPN7 S BGPVALUD=BGPVALUD_$$DATE^BGP5UTL($P(BGPVALUE,U,1))_" "_$P(BGPVALUE,U,2),BGPVALUE=BGPDV_$$DATE^BGP5UTL($P(BGPVALUE,U,1))_" "_$P(BGPVALUE,U,2) Q

 .S BGPVALUE=BGPDV

 K BGPLFLU,BGPDV,BGPHR

 Q

I13 ;EP

 G I13^BGP5D3B

 ;

I15 ;EP

 K BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPPAP,BGPI7,BGPI7DA,BGPI7DB,BGPI7DC,BGPI7DD,BGPPAP4,BGPPAP6

 S BGPI7DA=0,BGPI7DB=0,BGPI7DC=0,BGPI7DD=0,BGPN1=0,BGPN2=0,BGPN3=0,BGPPAP4="",BGPN4=0,BGPPAP6="",BGPHPV=""

 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6)=0

 S BGPI7=$$DEN7(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)

 I BGPACTUP,BGPI7 S BGPI7DA=1

 I BGPACTCL,BGPI7 S BGPI7DB=1

 I BGPACTCL,BGPI7,BGPAGEB>23,BGPAGEE<65 S BGPI7DC=1,BGPD4=1  ;2014 GPRA DEV

 I BGPACTUP,BGPI7,BGPAGEB>23,BGPAGEE<65 S BGPI7DD=1

 I BGPACTCL,BGPI7,BGPAGEB>29,BGPAGEE<65 S BGPD1=1

 I BGPACTCL,BGPI7,BGPAGEB>23,BGPAGEB<30 S BGPD2=1

 I BGPACTUP,BGPI7,BGPAGEB>29,BGPAGEE<65 S BGPD7=1

 I BGPACTUP,BGPI7,BGPAGEB>23,BGPAGEB<30 S BGPD8=1

 I 'BGPI7DC,'BGPI7DD S BGPSTOP=1 Q  ;not in either denom so quit

 ;I BGPTIME=1,BGPD4,'(BGPD1+BGPD2) W !,DFN,?10,"BGPD4=",BGPD4,?20,"BGPD2=",BGPD2,?30,"BGPD1=",BGPD1,?40,"AGEB: ",BGPAGEB,?50,"AGEE: ",BGPAGEE

 S BGPPAP=$$PAP(DFN,BGPEDATE,3,1)

 ;S BGPPAP4=$$PAP(DFN,BGPEDATE,4,1)

 S BGPN1=0 I $P(BGPPAP,U)=1 S BGPN1=1

 I $P(BGPPAP,U,3)["Ref" S BGPN2=1

 I BGPN1,'BGPN2 S BGPN3=1

 S BGPN4=0 I $P(BGPPAP,U,1)=1 S BGPN4=1  ;PAP IN 3 YRS, NO REFUSALS

 ;for gpra dev, if they didn't have pap in 4 years check HPV

 I 'BGPN4,(BGPD1!(BGPD7)) D

 .S BGPPAP6=$$PAP(DFN,BGPEDATE,5)

 .S BGPHPV=$$HPV(DFN,BGPEDATE,5)

 .I BGPHPV,BGPPAP6 S BGPN5=1

 I BGPN4!(BGPN5) S BGPN6=1

 ;I BGPTIME=1 W ?40,"BGPN4=",BGPN4,?50,"BGPN5=",?60,"BGPN6=",BGPN6

 S BGPVALUE=$S(BGPI7DD:"UP",1:"")_$S(BGPI7DC:",AC",1:"")_"|||"

 ;I BGPRTYPE=1 S BGPVALUE=$S(BGPI7DA:"UP",1:"")_$S(BGPI7DB:",AC",1:"")_"|||" I BGPN3 S BGPVALUE=BGPVALUE_$$DATE^BGP5UTL($P(BGPPAP,U,2))_" "_$P(BGPPAP,U,3)

 ;I BGPRTYPE=3 S BGPVALUE="AC|||"_$$DATE^BGP5UTL($P(BGPPAP,U,2))_" "_$P(BGPPAP,U,3)

 I BGPN4 S BGPVALUE=BGPVALUE_"PAP 3 YRS: "_$$DATE^BGP5UTL($P(BGPPAP,U,2))_" "_$P(BGPPAP,U,3)

 I BGPN5 S BGPVALUE=BGPVALUE_" PAP&HPV 5 YRS: "_$$DATE^BGP5UTL($P(BGPPAP6,U,2))_" "_$P(BGPPAP6,U,3)_"; HPV: "_$$DATE^BGP5UTL($P(BGPHPV,U,2))_" "_$P(BGPHPV,U,3)

 K BGPLPAP,BGPPAP,BGPHPV,BGPPAP4,BGPPAP6

 Q

 ;

HPV(P,EDATE,YEARS) ;EP

 NEW BGPC,BGPLPAP,T,BGPLT,B,D,E,L,X,J,BGP

 S BGPC=""

 S BGPLPAP=""

 S BDATE=$$FMADD^XLFDT(EDATE,-(365*YEARS))

 S T=$O(^ATXAX("B","BGP HPV LOINC CODES",0))

 S BGPLT=$O(^ATXLAB("B","BGP HPV 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))

 ...S Z=$P(^AUPNVLAB(X,0),U),Z=$P($G(^LAB(60,Z,0)),U) I Z="HPV" S BGPC="1^"_(9999999-D)_"^Lab" Q

 ...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC="1^"_(9999999-D)_"^Lab" Q

 ...Q:'T

 ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""

 ...Q:'$$LOINC(J,T)

 ...S BGPC="1^"_(9999999-D)_"^Lab-loinc" Q

 ...Q

 S BGPLPAP=BGPC

 K BGP

 S T="BGP HPV DXS"

 S X=$$LASTDX^BGP5UTL1(P,T,BDATE,EDATE) I X,$P(BGPLPAP,U,2)<$P(X,U,3) S BGPLPAP="1^"_$P(X,U,3)_"^POV "_$P(X,U,2)

 S T=$O(^ATXAX("B","BGP HPV CPTS",0))

 I T D  I X]"",$P(BGPLPAP,U,2)<$P(X,U,1) S BGPLPAP="1^"_$P(X,U)_"^CPT "_$P(X,U,2)

 .S X=$$CPT^BGP5DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5) I X]"" Q

 .S X=$$TRAN^BGP5DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5)

 S T="HPV SCREEN",T=$O(^BWPN("B",T,0))

 I T D  I X]"",$P(BGPLPAP,U,2)<X S BGPLPAP="1^"_X_"^WH"

 .S X=$$WH^BGP5DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)

 S T="PAP SMEAR",T=$O(^BWPN("B",T,0))

 I T D  I X]"",$P(BGPLPAP,U,2)<X S BGPLPAP="1^"_X_"^WH"

 .S X=$$PAPHPVWH(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)

 Q BGPLPAP

 ;

FLU(P,BD,ED,FORE) ;EP

 G FLU^BGP5D37

BI() ;

 Q $S($O(^AUTTIMM(0))>100:1,1:0)

DEN7(P,AGEB,AGEE,SEX,EDATE) ;EP

 I SEX'="F" Q 0

 I AGEB<24 Q 0

 I AGEE>64 Q 0

 I $$HYSTER(P,EDATE) Q 0

 Q 1

H1(I) ;

 I $P($G(^ICPT(I,0)),U,1)=90664 Q 1

 I $P($G(^ICPT(I,0)),U,1)=90666 Q 1

 I $P($G(^ICPT(I,0)),U,1)=90667 Q 1

 I $P($G(^ICPT(I,0)),U,1)=90668 Q 1

 Q ""

PAP(P,EDATE,YEARS,REFUSAL) ;EP

 NEW BGPC,BGPLPAP,T,BGPLT,B,D,E,L,X,J,BGP

 S BGPC=""

 S BGPLPAP=""

 S BDATE=$$FMADD^XLFDT(EDATE,-(365*YEARS))

 S T=$O(^ATXAX("B","BGP PAP LOINC CODES",0))

 S BGPLT=$O(^ATXLAB("B","BGP PAP SMEAR 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))

 ...S Z=$P(^AUPNVLAB(X,0),U),Z=$P($G(^LAB(60,Z,0)),U) I Z="PAP SMEAR" S BGPC="1^"_(9999999-D)_"^Lab" Q

 ...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC="1^"_(9999999-D)_"^Lab" Q

 ...Q:'T

 ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""

 ...Q:'$$LOINC(J,T)

 ...S BGPC="1^"_(9999999-D)_"^Lab-loinc" Q

 ...Q

 S BGPLPAP=BGPC

 K BGP

 S T="BGP PAP SMEAR DXS"

 I BGPRTYPE=3 S T="BGP HEDIS PAP SMEAR DXS"

 S X=$$LASTDX^BGP5UTL1(P,T,BDATE,EDATE) I X,$P(BGPLPAP,U,2)<$P(X,U,3) S BGPLPAP="1^"_$P(X,U,3)_"^POV "_$P(X,U,2)

 ;K BGP S BGP(1)=$$LASTPRC^BGP5UTL1(P,"BGP PAP PROCEDURES",BDATE,EDATE)

 ;I $D(BGP(1)),$P(BGPLPAP,U,2)<$P(BGP(1),U,3) S BGPLPAP="1^"_$P(BGP(1),U,3)_"^PROC "_$P(BGP(1),U,2)

 S T=$O(^ATXAX("B","BGP CPT PAP",0))

 I T D  I X]"",$P(BGPLPAP,U,2)<$P(X,U,1) S BGPLPAP="1^"_$P(X,U)_"^CPT "_$P(X,U,2)

 .S X=$$CPT^BGP5DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5) I X]"" Q

 .S X=$$TRAN^BGP5DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,5)

 S T="PAP SMEAR",T=$O(^BWPN("B",T,0))

 I T D  I X]"",$P(BGPLPAP,U,2)<X S BGPLPAP="1^"_X_"^WH"

 .S X=$$WH^BGP5DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)

 I BGPLPAP]"" Q BGPLPAP

 I $G(REFUSAL) Q ""  ;no Refusals counted

 S T=$$REFUSAL^BGP5UTL1(P,60,$O(^LAB(60,"B","PAP SMEAR",0)),$$FMADD^XLFDT(EDATE,-365),EDATE)

 I T Q "1^"_$P(T,U,2)_"^Refused Lab"

 S BGPLT=$O(^ATXLAB("B","BGP PAP SMEAR TAX",0))

 I 'BGPLT Q 0

 S X=0,T="" F  S X=$O(^ATXLAB(BGPLT,21,X)) Q:X'=+X!($P(T,U)=1)  D

 .S T=""

 .S Y=$P(^ATXLAB(BGPLT,21,X,0),U)

 .Q:'Y

 .S T=$$REFUSAL^BGP5UTL1(P,60,Y,$$FMADD^XLFDT(EDATE,-365),EDATE)

 I T Q 1_"^"_$P(T,U,2)_"^Refused Lab "

 ;add cpt Refusals v11.1

 S T=$$CPTREFT^BGP5UTL1(P,$$FMADD^XLFDT(EDATE,-365),EDATE,$O(^ATXAX("B","BGP CPT PAP",0)))

 I T S T="1^"_$P(T,U,2)_"^Refused CPT "_$P(T,U,4) Q T

 Q ""

PAPHPVWH(P,BDATE,EDATE,T,F) ;EP

 I '$G(P) Q ""

 I '$G(T) Q ""

 I '$G(F) S F=1

 I $G(EDATE)="" Q ""

 I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)

 ;go through procedures in a date range for this patient, check proc type

 NEW D,X,Y,G,V,O

 S (G,V)=0,I="" F  S V=$O(^BWPCD("C",P,V)) Q:V=""  D

 .Q:'$D(^BWPCD(V,0))

 .I $P(^BWPCD(V,0),U,4)'=T Q

 .Q:$$UP^XLFSTR($$VAL^XBDIQ1(9002086.1,V,.05))="ERROR/DISREGARD"

 .S D=$P(^BWPCD(V,0),U,12)

 .Q:D<BDATE

 .Q:D>EDATE

 .;DOES HPV SAY YES?

 .I '$P(^BWPCD(V,0),U,8) Q  ;has to have HPV yes

 .S I=$O(G(0)) I I>D Q

 .S G=V,G(D)=""

 .Q

 I 'G Q ""

 I F=1 Q $S(G:1,1:"")

 I F=2 Q G

 I F=3 S D=$P(^BWPCD(G,0),U,12) Q D

 I F=4 S D=$P(^BWPCD(G,0),U,12) Q $$FMTE^XLFDT(D)

 Q ""

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 ""

HYSTER(P,EDATE) ;EP 

 I '$G(P) Q ""

 NEW X,T

 S X=$$LASTPRC^BGP5UTL1(P,"BGP HYSTERECTOMY PROCEDURES",$$DOB^AUPNPAT(P),EDATE)

 I X Q 1

 S T="HYSTERECTOMY",T=$O(^BWPN("B",T,0))

 I T D  I X]"" Q 1

 .S X=$$WH^BGP5DU(P,$$DOB^AUPNPAT(P),EDATE,T,2)

 S T=$O(^ATXAX("B","BGP HYSTERECTOMY CPTS",0))

 I T D  I X]"" Q 1

 .S X=$$CPT^BGP5DU(P,$P(^DPT(P,0),U,3),EDATE,T,3) I X]"" Q

 .S X=$$TRAN^BGP5DU(P,$P(^DPT(P,0),U,3),EDATE,T,3)

 S X=$$LASTDX^BGP5UTL1(P,"BGP HYSTERECTOMY DXS",$$DOB^AUPNPAT(P),EDATE)

 I X Q 1

 S X=$$PLTAX^BGP5DU(P,"BGP HYSTERECTOMY DXS")

 I X Q 1

 Q ""

BGP5D3    ; IHS/CMI/LAB - measure 11 17 Oct 2009 12:40 PM ;

 +1       ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143

 +2       ;

 +3       ;

I10       ;EP

 +1        SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0

 +2        SET (BGPSEAL,BGPSEALD,BGPSEALR)=""

 +3        KILL BGPSEALS,BGPSELDS,BGPSEALR

 +4       ;this is for the number of sealants only

           DO SEAL^BGP5D3A(DFN,BGPBDATE,BGPEDATE)

 +5        DO SEALR^BGP5D3A(DFN,BGPBDATE,BGPEDATE)

 +6        SET BGPN1=$PIECE(BGPSEAL,U)+$PIECE(BGPSEALR,U,1)

 +7       ;BGPN1 is total # of sealants for sealant measure

 +8        IF BGPAGEB>1

               IF BGPAGEB<16

                   SET BGPN2=BGPN1

 +9        IF BGPAGEB>1

               IF BGPAGEB<20

                   IF BGPN1

                       SET BGPN7=1

 +10       IF BGPAGEB>15

               SET BGPN3=BGPN1

 +11       IF BGPAGEB>18

               SET BGPN4=BGPN1

I101      ;

 +1       ;get new sealant definition 2015 gpra dev

 +2        SET BGPSEALD=""

 +3        IF 'BGPN1

               SET BGPSEALD=$$SEALDEV^BGP5D3A(DFN,BGPBDATE,BGPEDATE)

 +4        IF BGPSEALD

               SET BGPN7=1

 +5        IF BGPAGEB>1

               IF BGPAGEB<6

                   IF BGPN7

                       SET BGPN10=1

 +6        IF BGPAGEB>2

               IF BGPAGEB<6

                   IF BGPN7

                       SET BGPN5=1

 +7        IF BGPAGEB>5

               IF BGPAGEB<10

                   IF BGPN7

                       SET BGPN6=1

 +8        IF BGPAGEB>9

               IF BGPAGEB<13

                   IF BGPN7

                       SET BGPN8=1

 +9        IF BGPAGEB>12

               IF BGPAGEB<16

                   IF BGPN7

                       SET BGPN9=1

 +10       IF BGPAGEB>1

               IF BGPAGEB<16

                   SET BGPD7=1

 +11       IF BGPAGEB>4

               IF BGPAGEB<20

                   SET BGPD8=1

 +12      ;I 'BGPN1,'BGPD7 S BGPSTOP=1 Q

 +13      ;    _+BGPN1_" sealants"

           SET BGPVALUE="UP|||"

 +14       IF 'BGPN1

               IF BGPD7!(BGPD8)

                   SET BGPVALUE=BGPVALUE_$PIECE(BGPSEALD,U,2)

 +15       IF BGPN1

               SET BGPVALUE=BGPVALUE_"; "_+BGPN1_" sealants: "

               SET X=0

               FOR 

                   SET X=$ORDER(BGPSEALS(X))

                   IF X'=+X

                       QUIT 

                   SET D=0

                   FOR 

                       SET D=$ORDER(BGPSEALS(X,D))

                       IF D'=+D

                           QUIT 

                       SET BGPVALUE=BGPVALUE_$SELECT(X=1:"",1:"; ")_$$DATE^BGP5UTL(D)_" "_BGPSEALS(X,D)

 +16       KILL BGPSEAL,BGPSEALD,BGPSEALR

 +17       QUIT 

I11       ;EP

 +1        SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPD1,BGPD2)=0

 +2        NEW BGPFLUOR

 +3        IF '$GET(BGPACTUP)

               SET BGPSTOP=1

               QUIT 

 +4        IF BGPACTUP

               SET BGPD1=1

 +5        SET BGPFLUOR=$$TF^BGP5D3A(DFN,BGPBDATE,BGPEDATE)

 +6       ;I $P(BGPFLUOR,U,3)["Refused" S BGPN2=1 G I111

 +7        SET BGPN1=$PIECE(BGPFLUOR,U)

 +8        IF BGPN1>4

               SET BGPN1=4

 +9        IF BGPAGEB>0

               IF BGPAGEB<16

                   SET BGPD2=1

                   SET BGPN3=$SELECT(BGPN1:1,1:0)

 +10      ;I BGPD1,'BGPD2 S BGPD3=1

I111      ;

 +1        SET BGPVALUE="UP|||"_+BGPN1_" topical fluoride"

 +2        IF +BGPN1

               SET BGPVALUE=BGPVALUE_": "

               FOR X=2:1:5

                   IF $PIECE(BGPFLUOR,U,X)]""

                       SET BGPVALUE=BGPVALUE_$SELECT(X>2:", ",1:"")_$$DATE^BGP5UTL($PIECE($PIECE(BGPFLUOR,U,X),"|",1))_" "_$PIECE($PIECE(BGPFLUOR,U,X),"|",2)

 +3       ;I BGPN2 S BGPVALUE=BGPVALUE_": "_$$DATE^BGP5UTL($P(BGPFLUOR,U,2))_" "_$P(BGPFLUOR,U,3)

 +4        SET BGPVALUD="UP|||"

 +5        IF +BGPN1

               SET BGPVALUD=BGPVALUD_+BGPN1_" topical fluoride"

               IF +BGPN1

                   SET BGPVALUD=BGPVALUD_": "

                   FOR X=2:1:5

                       IF $PIECE(BGPFLUOR,U,X)]""

                           SET BGPVALUD=BGPVALUD_$SELECT(X>2:", ",1:"")_$$DATE^BGP5UTL($PIECE($PIECE(BGPFLUOR,U,X),"|",1))_" "_$PIECE($PIECE(BGPFLUOR,U,X),"|",2)

 +6       ;I BGPN2 S BGPVALUD=BGPVALUD_": "_$$DATE^BGP5UTL($P(BGPFLUOR,U,2))_" "_$P(BGPFLUOR,U,3)

 +7        KILL ^TMP($JOB,"A"),BGPFLUOR

 +8        QUIT 

I12       ;EP

 +1        NEW BGPHR,V,BGPAIM

 +2        SET BGPAIM=$$AGE^BGP5D36(DFN,2,BGPBDATE)

 +3       ;I BGPAIM<6 S BGPSTOP=1 Q

 +4        SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13,BGPD14,BGPD15,BGPD16,BGPD17,BGPHR)=0

 +5        SET BGPHR=$$HIGHR^BGP5D3A(DFN,BGPEDATE)

 +6        IF BGPAGEB>49

               IF BGPACTUP

                   SET BGPD5=1

 +7        IF BGPAGEB>49

               IF BGPAGEB<65

                   IF BGPACTUP

                       SET BGPD6=1

 +8        IF BGPAGEB>64

               IF BGPACTUP

                   SET BGPD7=1

 +9        IF BGPDMD2

               SET BGPD4=1

 +10       IF BGPAGEB>49

               IF BGPACTCL

                   SET BGPD1=1

 +11       IF BGPAGEB>49

               IF BGPAGEB<65

                   IF BGPACTCL

                       SET BGPD2=1

 +12       IF BGPAGEB>64

               IF BGPACTCL

                   SET BGPD3=1

 +13       IF BGPACTCL

               SET BGPD8=1

 +14       IF BGPAIM>5

               IF BGPAGEB<18

                   IF BGPACTCL

                       SET BGPD9=1

 +15       IF BGPAGEB>17

               IF BGPAGEB<50

                   IF BGPACTCL

                       SET BGPD10=1

 +16       IF BGPAGEB>17

               IF BGPAGEB<50

                   IF BGPACTCL

                       IF BGPHR

                           SET BGPD11=1

 +17       IF BGPACTUP

               SET BGPD12=1

 +18       IF BGPAIM>5

               IF BGPAGEB<18

                   IF BGPACTUP

                       SET BGPD13=1

 +19       IF BGPAGEB>17

               IF BGPAGEB<50

                   IF BGPACTUP

                       SET BGPD14=1

 +20       IF BGPAGEB>17

               IF BGPAGEB<50

                   IF BGPACTUP

                       IF BGPHR

                           SET BGPD15=1

 +21       IF BGPAGEB>17

               IF BGPACTUP

                   SET BGPD16=1

 +22       IF BGPAGEB>17

               IF BGPACTCL

                   SET BGPD17=1

 +23       IF '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9+BGPD10+BGPD11+BGPD12+BGPD13+BGPD14+BGPD15+BGPD16+BGPD17)

               SET BGPSTOP=1

               QUIT 

 +24      ;set to date of flu shot

           SET BGPVALUE=$$FLU(DFN,,BGPEDATE)

 +25       IF $PIECE(BGPVALUE,U,3)=1

               SET BGPN1=1

 +26      ;I $P(BGPVALUE,U,3)=2 S BGPN2=1

 +27       IF $PIECE(BGPVALUE,U,3)=3

               SET BGPN3=1

               SET BGPN1=1

 +28       IF BGPN1

               SET BGPN7=1

 +29       SET BGPDV=""

 +30       IF BGPRTYPE=4

               SET BGPDV=$SELECT(BGPACTUP:"UP",1:"")

               Begin DoDot:1

 +31               IF BGPACTCL

                       SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AC",1:"AC")

 +32               IF BGPD4

                       SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AD",1:"AD")

 +33               IF BGPHR

                       SET BGPDV=BGPDV_$SELECT(BGPDV]"":",HR",1:"HR")

               End DoDot:1

 +34       IF BGPRTYPE=1

               Begin DoDot:1

 +35               SET BGPDV=$SELECT(BGPD3!(BGPD2):"AC",1:"")

                   IF BGPD4

                       SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AD",1:"AD")

 +36               SET BGPVALUD=$SELECT(BGPD8:"AC",1:"")

               End DoDot:1

 +37       IF BGPRTYPE=3!(BGPRTYPE=8)

               SET BGPDV="AC"

 +38       IF BGPRTYPE=7

               Begin DoDot:1

 +39               IF BGPACTCL

                       SET BGPDV="AC"

 +40               IF BGPD4

                       SET BGPDV=BGPDV_$SELECT(BGPDV]"":",AD",1:"AD")

 +41               IF BGPHR

                       SET BGPDV=BGPDV_$SELECT(BGPDV]"":",HR",1:"HR")

               End DoDot:1

 +42       IF BGPRTYPE'=1

               SET BGPVALUE=BGPDV_"|||"_$$DATE^BGP5UTL($PIECE(BGPVALUE,U,1))_" "_$PIECE(BGPVALUE,U,2)