BGP0D3.m

BGP0D3 ; IHS/CMI/LAB - measure 11 17 Oct 2008 12:40 PM ;

 ;;10.0;IHS CLINICAL REPORTING;**1**;JUN 18, 2010

 ;

 ;

I10 ;EP

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

 S (BGPSEAL,BGPSEALD)=""

 K BGPSEALS,BGPSELDS

 D SEAL^BGP0D3A(DFN,BGPBDATE,BGPEDATE)

 I $P(BGPSEAL,U,2)]"" S BGPN5=$P(BGPSEAL,U,1) G I101

 S BGPN1=$P(BGPSEAL,U)

 I BGPAGEB<12 S BGPN2=BGPN1

 I BGPAGEB>11,BGPAGEB<19 S BGPN3=BGPN1

 I BGPAGEB>18 S BGPN4=BGPN1

I101 ;

 ;get new sealant definition 2010 gpra dev

 I BGPAGEB>5,BGPAGEB<16 S BGPD7=1 S BGPSEALD=$$SEALDEV^BGP0D3A(DFN,BGPBDATE,BGPEDATE) I BGPSEALD S BGPN7=1

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

 I 'BGPN1,BGPN5 S BGPVALUE=BGPVALUE_": "_$$DATE^BGP0UTL($P(BGPSEAL,U,2))_" "_$P(BGPSEAL,U,3)

 I BGPN1 S BGPVALUE=BGPVALUE_": " 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^BGP0UTL(D)_" "_BGPSEALS(X,D)

 I BGPD7 S BGPVALUD=$S(BGPD7:"UP6-15",1:"")_"|||" I BGPN7 S BGPVALUD=BGPVALUD_" "_$P(BGPSEALD,U,2)

 K BGPSEAL,BGPSEALD

 Q

I11 ;EP

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

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

 I BGPACTUP S BGPD1=1

 S BGPFLUOR=$$TF^BGP0D3A(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>1,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^BGP0UTL($P($P(BGPFLUOR,U,X),"|",1))_" "_$P($P(BGPFLUOR,U,X),"|",2)

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

 S BGPVALUD="UP 2-15|||"_+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^BGP0UTL($P($P(BGPFLUOR,U,X),"|",1))_" "_$P($P(BGPFLUOR,U,X),"|",2)

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

 Q

I12 ;EP

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

 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 '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7) 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,'BGPN2 S BGPN7=1

 S BGPDV=""

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

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

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

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

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

 I BGPRTYPE=7 S BGPDV="AD"

 S BGPVALUE=BGPDV_"|||"_$$DATE^BGP0UTL($P(BGPVALUE,U,1))_" "_$P(BGPVALUE,U,2)

 K BGPLFLU,BGPDV

 Q

I13 ;EP

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

 I BGPAGEB>64,BGPACTUP S BGPD3=1

 I BGPDMD2 S BGPD2=1

 I BGPAGEB>64,BGPACTCL S BGPD1=1

 I '(BGPD1+BGPD2+BGPD3) S BGPSTOP=1 Q

 I BGPRTYPE=3,'BGPD1 S BGPSTOP=1 Q

PN ;EP - called from elder

 S BGPVALUE=$$PNEU^BGP0D31(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) ;set to date of PNEU shot

 ;I BGPVALUE]"" S BGPN1=1

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

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

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

 S BGPVAL=$$PNEU^BGP0D31(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE)

 I $P(BGPVAL,U,3)=1!($P(BGPVAL,U,3)=3) S BGPN4=1  ;HAD IN PAST 5 YEARS SO "UP TO DATE"

 I $P(BGPVAL,U,3)=2 S BGPN5=1

 I $P(BGPVAL,U,3)=3 S BGPN6=1

 S BGPN7=0 I BGPAGEB>65 S BGPN7=$$PNEU^BGP0D31(DFN,$$FMADD^XLFDT($$DOB^AUPNPAT(DFN),+(65*365)),BGPEDATE) I $P(BGPN7,U,3)=1!($P(BGPN7,U,3)=3) S BGPN4=1 ;over 65 and had one after 65

 I BGPAGEB<65,BGPN1 S BGPN4=1  ;anyone under and had 1 ever

 S BGPDV=""

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

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

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

 I BGPRTYPE=1 S BGPDV=$S(BGPD1:"AC",1:"") I BGPD2 S BGPDV=BGPDV_$S(BGPDV]"":",AD",1:"AD")

 I BGPRTYPE=7 S BGPDV="AD"

 I BGPRTYPE=3!(BGPRTYPE=5) S BGPVALUE="AC"_"|||"_$$DATE^BGP0UTL($P(BGPVALUE,U,1))_" "_$P(BGPVALUE,U,2) I 1

 E  S BGPVALUE=BGPDV_"|||"_$$DATE^BGP0UTL($P(BGPVALUE,U,1))_" "_$P(BGPVALUE,U,2)_$S(BGPVALUE]"":" (ever)",1:"")_" "_$$DATE^BGP0UTL($P(BGPVAL,U,1))_" "_$P(BGPVAL,U,2)_$S(BGPVAL]"":" (past 5 yrs)",1:"")

 K BGPLPNU

 Q

I15 ;EP

 K BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPPAP,BGPI7,BGPI7DA,BGPI7DB

 S BGPI7DA=0,BGPI7DB=0,BGPI7DC=0,BGPN1=0,BGPN2=0,BGPN3=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

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

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

 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

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

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

 K BGPLPAP

 Q

 ;

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

 NEW BGPG,BGPLFLU,EDATE,X,E,%,I,T,J,V,G,D,R

 K BGPG

 S BGPLFLU=""

 I $G(BD)="" S BD=$$FMADD^XLFDT(ED,-365)

 S EDATE=$$FMTE^XLFDT(ED),BDATE=$$FMTE^XLFDT(BD)

 S X=P_"^LAST IMM 88;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")

 I $D(BGPG(1)) S BGPLFLU=$P(BGPG(1),U)_U_"Imm 88"

 S X=P_"^LAST IMM 111;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")

 I $D(BGPG(1)),$P(BGPLFLU,U)<$P(BGPG(1),U) S BGPLFLU=$P(BGPG(1),U)_U_"Imm 111"

 S X=P_"^LAST IMM 15;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")

 I $D(BGPG(1)),$P(BGPLFLU,U)<$P(BGPG(1),U) S BGPLFLU=$P(BGPG(1),U)_U_"Imm 15"

 S X=P_"^LAST IMM 16;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")

 I $D(BGPG(1)),$P(BGPLFLU,U)<$P(BGPG(1),U) S BGPLFLU=$P(BGPG(1),U)_U_"Imm 16"

 S X=P_"^LAST IMM 135;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")

 I $D(BGPG(1)),$P(BGPLFLU,U)<$P(BGPG(1),U) S BGPLFLU=$P(BGPG(1),U)_U_"Imm 135"

 K BGPG S %=P_"^LAST DX V04.8;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")

 I $D(BGPG(1)) I $P(BGPLFLU,U)<$P(BGPG(1),U,1) S BGPLFLU=$P(BGPG(1),U,1)_U_"V04.8"

 K BGPG S %=P_"^LAST DX V04.81;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")

 I $D(BGPG(1)) D

 .S T=$O(^ATXAX("B","SURVEILLANCE CPT H1N1",0))

 .S X=0 F  S X=$O(BGPG(X)) Q:X'=+X  D

 ..S V=$P(BGPG(X),U,5)

 ..S G=0

 ..S J=0 F  S J=$O(^AUPNVCPT("AD",V,J)) Q:J'=+J  S I=$P(^AUPNVCPT(J,0),U,1) I $$ICD^ATXCHK(I,T,1)!($$H1(I)) S G=1

 ..Q:G=1

 ..I $P(BGPLFLU,U)<$P(BGPG(X),U,1) S BGPLFLU=$P(BGPG(1),U,1)_U_"V04.81"

 K BGPG S %=P_"^LAST DX V06.6;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")

 I $D(BGPG(1)) D

 .S T=$O(^ATXAX("B","SURVEILLANCE CPT H1N1",0))

 .S X=0 F  S X=$O(BGPG(X)) Q:X'=+X  D

 ..S V=$P(BGPG(X),U,5)

 ..S G=0

 ..S J=0 F  S J=$O(^AUPNVCPT("AD",V,J)) Q:J'=+J  S I=$P(^AUPNVCPT(J,0),U,1) I $$ICD^ATXCHK(I,T,1)!($$H1(I)) S G=1

 ..Q:G=1

 ..I $P(BGPLFLU,U)<$P(BGPG(X),U,1) S BGPLFLU=$P(BGPG(1),U,1)_U_"V06.06"

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

 I T D  I X]"" I $P(BGPLFLU,U)<X S BGPLFLU=$P(X,U)_U_"CPT "_$P(X,U,2)

 .S X=$$CPT^BGP0DU(P,,ED,T,5) I X]"" Q

 .S X=$$TRAN^BGP0DU(P,,ED,T,5)

 I BGPLFLU]"" Q BGPLFLU_U_1

 ;contraindication new in 8.0

 F BGPZ=15,16,88,111,135 S X=$$FLCONT(P,BGPZ,$$DOB^AUPNPAT(P),ED) Q:X]""

 I X]"" Q X_U_3

 ;NMI refusal

 S G=$$NMIREF^BGP0UTL1(P,9999999.14,$O(^AUTTIMM("C",88,0)),$$DOB^AUPNPAT(P),ED)

 I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3

 S G=$$NMIREF^BGP0UTL1(P,9999999.14,$O(^AUTTIMM("C",111,0)),$$DOB^AUPNPAT(P),ED)

 I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3

 S G=$$NMIREF^BGP0UTL1(P,9999999.14,$O(^AUTTIMM("C",15,0)),$$DOB^AUPNPAT(P),ED)

 I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3

 S G=$$NMIREF^BGP0UTL1(P,9999999.14,$O(^AUTTIMM("C",16,0)),$$DOB^AUPNPAT(P),ED)

 I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3

 S G=$$NMIREF^BGP0UTL1(P,9999999.14,$O(^AUTTIMM("C",135,0)),$$DOB^AUPNPAT(P),ED)

 I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3

 I $G(FORE) Q ""

 S G=$$REFUSAL^BGP0UTL1(P,9999999.14,$O(^AUTTIMM("C",88,0)),$$FMADD^XLFDT(ED,-365),ED)

 I $P(G,U)=1 Q $P(G,U,2)_U_"Refused"_U_2

 S G=$$REFUSAL^BGP0UTL1(P,9999999.14,$O(^AUTTIMM("C",111,0)),$$FMADD^XLFDT(ED,-365),ED)

 I $P(G,U)=1 Q $P(G,U,2)_U_"Refused"_U_2

 S G=$$REFUSAL^BGP0UTL1(P,9999999.14,$O(^AUTTIMM("C",15,0)),$$FMADD^XLFDT(ED,-365),ED)

 I $P(G,U)=1 Q $P(G,U,2)_U_"Refused"_U_2

 S G=$$REFUSAL^BGP0UTL1(P,9999999.14,$O(^AUTTIMM("C",16,0)),$$FMADD^XLFDT(ED,-365),ED)

 I $P(G,U)=1 Q $P(G,U,2)_U_"Refused"_U_2

 S G=$$REFUSAL^BGP0UTL1(P,9999999.14,$O(^AUTTIMM("C",135,0)),$$FMADD^XLFDT(ED,-365),ED)

 I $P(G,U)=1 Q $P(G,U,2)_U_"Refused"_U_2

 S (X,G)=0,Y=$O(^AUTTIMM("C",88,0)) F  S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G)  D

 .S R=$P(^BIPC(X,0),U,3)

 .Q:R=""

 .Q:'$D(^BICONT(R,0))

 .Q:$P(^BICONT(R,0),U,1)'["Refusal"

 .S D=$P(^BIPC(X,0),U,4)

 .Q:D=""

 .Q:$P(^BIPC(X,0),U,4)<BD

 .Q:$P(^BIPC(X,0),U,4)>ED

 .S G=1

 I G Q $P(G,U,2)_U_"Refused Imm pkg"_U_2

 S (X,G)=0,Y=$O(^AUTTIMM("C",111,0)) I Y F  S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G)  D

 .S R=$P(^BIPC(X,0),U,3)

 .Q:R=""

 .Q:'$D(^BICONT(R,0))

 .Q:$P(^BICONT(R,0),U,1)'["Refusal"

 .S D=$P(^BIPC(X,0),U,4)

 .Q:D=""

 .Q:$P(^BIPC(X,0),U,4)<BD

 .Q:$P(^BIPC(X,0),U,4)>ED

 .S G=1

 I G Q $P(G,U,2)_U_"Refused Imm pkg"_U_2

 S (X,G)=0,Y=$O(^AUTTIMM("C",15,0)) I Y F  S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G)  D

 .S R=$P(^BIPC(X,0),U,3)

 .Q:R=""

 .Q:'$D(^BICONT(R,0))

 .Q:$P(^BICONT(R,0),U,1)'["Refusal"

 .S D=$P(^BIPC(X,0),U,4)

 .Q:D=""

 .Q:$P(^BIPC(X,0),U,4)<BD

 .Q:$P(^BIPC(X,0),U,4)>ED

 .S G=1

 I G Q $P(G,U,2)_U_"Refused Imm pkg"_U_2

 S (X,G)=0,Y=$O(^AUTTIMM("C",16,0)) I Y F  S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G)  D

 .S R=$P(^BIPC(X,0),U,3)

 .Q:R=""

 .Q:'$D(^BICONT(R,0))

 .Q:$P(^BICONT(R,0),U,1)'["Refusal"

 .S D=$P(^BIPC(X,0),U,4)

 .Q:D=""

 .Q:$P(^BIPC(X,0),U,4)<BD

 .Q:$P(^BIPC(X,0),U,4)>ED

 .S G=1

 I G Q $P(G,U,2)_U_"Refused Imm pkg"_U_2

 S (X,G)=0,Y=$O(^AUTTIMM("C",135,0)) I Y F  S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G)  D

 .S R=$P(^BIPC(X,0),U,3)

 .Q:R=""

 .Q:'$D(^BICONT(R,0))

 .Q:$P(^BICONT(R,0),U,1)'["Refusal"

 .S D=$P(^BIPC(X,0),U,4)

 .Q:D=""

 .Q:$P(^BIPC(X,0),U,4)<BD

 .Q:$P(^BIPC(X,0),U,4)>ED

 .S G=1

 I G Q $P(G,U,2)_U_"Refused Imm pkg"_U_2

 Q ""

FLCONT(P,C,BD,ED) ;EP

 NEW X,G,Y,R,D

 S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F  S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G)  D

 .S R=$P(^BIPC(X,0),U,3)

 .Q:R=""

 .Q:'$D(^BICONT(R,0))

 .S D=$P(^BIPC(X,0),U,4)

 .Q:D=""

 .Q:$P(^BIPC(X,0),U,4)<BD

 .Q:$P(^BIPC(X,0),U,4)>ED

 .I $P(^BICONT(R,0),U,1)="Egg Allergy" S G=D_U_"Contraindication: Egg Allergy"

 .I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G=D_U_"Contraindication: Anaphylaxis"

 Q G

BI() ;

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

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

 I SEX'="F" Q 0

 I AGEB<21 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

 K BGPC

 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^BGP0UTL1(P,T,BDATE,EDATE) I X,$P(BGPLPAP,U,2)<$P(X,U,3) S BGPLPAP="1^"_$P(X,U,3)_"^"_$P(X,U,2)

 K BGP S %=P_"^LAST PROCEDURE 91.46;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGP(")

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

 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)_"^"_$P(X,U,2)

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

 .S X=$$TRAN^BGP0DU(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^BGP0DU(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)

 I BGPLPAP]"" Q BGPLPAP

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

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

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

 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^BGP0UTL1(P,60,Y,$$FMADD^XLFDT(EDATE,-365),EDATE)

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

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

 S X=$$LASTPRC^BGP0UTL1(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^BGP0DU(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^BGP0DU(P,$P(^DPT(P,0),U,3),EDATE,T,3) I X]"" Q

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

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

 I X Q 1

 Q ""

BGP0D3    ; IHS/CMI/LAB - measure 11 17 Oct 2008 12:40 PM ;

 +1       ;;10.0;IHS CLINICAL REPORTING;**1**;JUN 18, 2010

 +2       ;

 +3       ;

I10       ;EP

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

 +2        SET (BGPSEAL,BGPSEALD)=""

 +3        KILL BGPSEALS,BGPSELDS

 +4        DO SEAL^BGP0D3A(DFN,BGPBDATE,BGPEDATE)

 +5        IF $PIECE(BGPSEAL,U,2)]""

               SET BGPN5=$PIECE(BGPSEAL,U,1)

               GOTO I101

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

 +7        IF BGPAGEB<12

               SET BGPN2=BGPN1

 +8        IF BGPAGEB>11

               IF BGPAGEB<19

                   SET BGPN3=BGPN1

 +9        IF BGPAGEB>18

               SET BGPN4=BGPN1

I101      ;

 +1       ;get new sealant definition 2010 gpra dev

 +2        IF BGPAGEB>5

               IF BGPAGEB<16

                   SET BGPD7=1

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

                   IF BGPSEALD

                       SET BGPN7=1

 +3        SET BGPVALUE="UP|||"_+BGPN1_" sealants"

 +4        IF 'BGPN1

               IF BGPN5

                   SET BGPVALUE=BGPVALUE_": "_$$DATE^BGP0UTL($PIECE(BGPSEAL,U,2))_" "_$PIECE(BGPSEAL,U,3)

 +5        IF BGPN1

               SET BGPVALUE=BGPVALUE_": "

               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^BGP0UTL(D)_" "_BGPSEALS(X,D)

 +6        IF BGPD7

               SET BGPVALUD=$SELECT(BGPD7:"UP6-15",1:"")_"|||"

               IF BGPN7

                   SET BGPVALUD=BGPVALUD_" "_$PIECE(BGPSEALD,U,2)

 +7        KILL BGPSEAL,BGPSEALD

 +8        QUIT 

I11       ;EP

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

 +2        IF '$GET(BGPACTUP)

               SET BGPSTOP=1

               QUIT 

 +3        IF BGPACTUP

               SET BGPD1=1

 +4        SET BGPFLUOR=$$TF^BGP0D3A(DFN,BGPBDATE,BGPEDATE)

 +5        IF $PIECE(BGPFLUOR,U,3)["Refused"

               SET BGPN2=1

               GOTO I111

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