BGP0EL3.m

BGP0EL3 ; IHS/CMI/LAB - measure 1,2,3,4 05 Apr 2009 1:44 PM ;

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

 ;

I9 ;EP

 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0

 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN6,BGPN7,BGPN8)=0

 I BGPAGEB<55 S BGPSTOP=1 Q

 I 'BGPACTCL S BGPSTOP=1 Q

 S BGPD1=1

 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1

 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1

 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1

 I BGPAGEB>84 S BGPD5=1

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

 I BGPVALUE]"" S BGPN1=1  ;FLU SHOT

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

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

 I BGPN1,'BGPN2 S BGPN7=1

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

 K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,J,K,G,I,L,T

 K BGPX,BGPY,BGPC,BGPG

 Q

I10 ;EP

 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0

 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8)=0

 I BGPAGEB<55 S BGPSTOP=1 Q

 I 'BGPACTCL S BGPSTOP=1 Q

 S BGPD1=1

 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1

 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1

 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1

 I BGPAGEB>84 S BGPD5=1

 D PN^BGP0D3

 S BGPVALUE="AC|||"_$P(BGPVALUE,"|||",2)

 K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,J,K,G,I,L,T,BGPLHGB

 K BGPUP,BGPGFR,BGPX,BGPY,BGPC,BGPG

 Q

I11 ;EP

 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0

 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN6,BGPN7)=0

 I BGPAGEB<55 S BGPSTOP=1 Q

 I 'BGPACTCL S BGPSTOP=1 Q

 I $P(^DPT(DFN,0),U,2)'="F" S BGPSTOP=1 Q

 I $$MAS^BGP0D4(DFN,BGPEDATE) S BGPSTOP=1 Q

 S BGPD1=1

 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1

 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1

 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1

 I BGPAGEB>84 S BGPD5=1

 S BGPMAM=$$MAM^BGP0D4(DFN,BGPEDATE,2)

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

 S BGPN2=0 I $P(BGPMAM,U,3)["ref" S BGPN2=1

 I BGPN1,'BGPN2 S BGPN3=1

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

 K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,J,K,G,I,L,T,BGPLHGB

 K BGPUP,BGPGFR,BGPX,BGPY,BGPC,BGPG,BGPMAM

 Q

I12 ;EP

 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0

 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN6,BGPN7,BGPN8)=0

 I BGPAGEB<55 S BGPSTOP=1 Q

 I 'BGPACTCL S BGPSTOP=1 Q

 I $$CRC^BGP0D61(DFN,BGPEDATE) S BGPSTOP=1 Q  ;has colorectal cancer

 S BGPD1=1

 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1

 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1

 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1

 I BGPAGEB>84 S BGPD5=1

 D CRCP^BGP0D61

 S BGPVALUE="AC|||"_$P(BGPVALUE,"|||",2)

 K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P

 K BGPX,BGPY,BGPC,BGPG

 Q

 ;

I13 ;EP

 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8)=0

 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN6)=0

 I BGPAGEB<55 S BGPSTOP=1 Q

 I 'BGPACTCL S BGPSTOP=1 Q

 S BGPD1=1

 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1

 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1

 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1

 I BGPAGEB>84 S BGPD5=1

 D TA^BGP0D7

 S BGPVALUE=BGPVALUE_$S(BGPN1:";SCREENED",1:"")_$S(BGPN2:";USER",1:"")_$S(BGPN3:";SMOKER",1:"")_$S(BGPN4:";SMOKELESS",1:"")

 S BGPVALUE="AC|||"_$P(BGPVALUE,"|||",2)

 K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,BGPSDX,BGPXPTD,BGP1320

 K BGPX,BGPY,BGPC,BGPG

 Q

I14 ;EP

 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0

 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN6,BGPN7)=0

 S BGPDVREF=""

 I BGPAGEB<55 S BGPSTOP=1 Q

 I 'BGPACTCL S BGPSTOP=1 Q

 I BGPSEX'="F" S BGPSTOP=1 Q

 S BGPD1=1

 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1

 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1

 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1

 I BGPAGEB>84 S BGPD5=1

 D DV^BGP0D5

 S BGPVALUE="AC|||"_$P(BGPVALUE,"|||",2)

 Q

 ;

I15 ;EP

 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0

 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN6,BGPN7,BGPN8,BGPN9)=0

 I BGPAGEB<55 S BGPSTOP=1 Q

 I 'BGPACTCL S BGPSTOP=1 Q

 S BGPD1=1

 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1

 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1

 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1

 I BGPAGEB>84 S BGPD5=1

 D DEPEP^BGP0D25

 S BGPVALUE="AC|||"_$P(BGPVALUE,"|||",2)

 Q

I16 ;EP

 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0

 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8)=0

 I BGPAGEB<55 S BGPSTOP=1 Q

 I BGPAGEB>74 S BGPSTOP=1 Q

 I 'BGPACTCL S BGPSTOP=1 Q

 S BGPD1=1

 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1

 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1

 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1

 I BGPAGEB>84 S BGPD5=1

 S BGPBMI=$$BMI^BGP0D6(DFN,BGPEDATE,BGPAGEE),BGPN1=$S(BGPBMI]"":1,1:0)

 S BGPN2=$$OW^BGP0D6(DFN,BGPBMI,BGPAGEE)

 S BGPN3=$$OB^BGP0D6(DFN,BGPBMI,BGPAGEE)

 I BGPN2!(BGPN3) S BGPN4=1

 I 'BGPN1 S BGPREF=$$REF^BGP0D6(DFN,BGP365,BGPEDATE,BGPAGEB) I $P(BGPREF,U)=1 S BGPN5=1

 I BGPN5 S BGPN1=1

 S BGPVALUE="AC"

 S BGPVALUE=BGPVALUE_"|||"_$S(BGPBMI]"":$$SB^BGP0PDL1($J($P(BGPBMI,U),6,2)),1:"")_" "_$S(BGPN2:"OW",1:"")_" "_$S(BGPN3:"OB",1:"")

 I BGPN5 S BGPVALUE=BGPVALUE_"ref "_$P(BGPREF,U,2)_" "_$$DATE^BGP0UTL($P(BGPREF,U,3))_" "_$P(BGPREF,U,5)_" "_$$DATE^BGP0UTL($P(BGPREF,U,6))

 K X,Y,Z,%,A,B,C,D,E,F,G,H,BDATE,EDATE,P,V,S,F,T,BGPBMI

 K BGPL,BGPLWTS,BGPLHTS,%,X,BGPLWTS1,BGPLHTS1,Y

 Q

I17 ;EP

 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0

 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN6,BGPN7)=0

 I BGPAGEB<55 S BGPSTOP=1 Q

 I 'BGPACTCL S BGPSTOP=1 Q

 S BGPD1=1

 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1

 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1

 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1

 I BGPAGEB>84 S BGPD5=1

 D BPCV^BGP0D41

 S BGPVALUE="AC|||"_$P(BGPVALUE,"|||",2)

 K X,Y,Z

 Q

I19 ;EP

 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0

 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN6,BGPN7)=0

 I BGPAGEB<55 S BGPSTOP=1 Q

 I 'BGPACTCL S BGPSTOP=1 Q

 I $P(^DPT(DFN,0),U,2)'="F" S BGPSTOP=1 Q

 I 'BGPACTCL S BGPSTOP=1 Q

 S BGPFRAC=$$FRACTURE(DFN,$$FMADD^XLFDT(BGPBDATE,-180),$$FMADD^XLFDT(BGPBDATE,180))

 I '$P(BGPFRAC,U) S BGPSTOP=1 Q

 S BGPD1=1

 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1

 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1

 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1

 I BGPAGEB>84 S BGPD5=1

 S BGPISD=$P(BGPFRAC,U,2),BGPISV=$P(BGPFRAC,U,3),BGPISV=$P(BGPFRAC,U,4)

 S BGPBMD=""

 I $P(BGPFRAC,U,3)="H" S BGPBMD=$$TXBMD^BGP0EL4(DFN,$P($P(^AUPNVSIT(BGPISV,0),U),"."),$$DSCHDATE^APCLV(BGPISV,"I"),1)

 I $P(BGPFRAC,U,3)'="H" S BGPBMD=$$TXBMD^BGP0EL4(DFN,BGPISD,$$FMADD^XLFDT(BGPISD,180))

 I $P(BGPBMD,U) S BGPN1=1

 S BGPVALUE="AC "

 S Y=""

 F X=5,6,7 S V=$P(BGPFRAC,U,X) I V]"" S:Y]"" Y=Y_";" S Y=Y_V

 S BGPVALUE=BGPVALUE_"Fracture: "_Y_" on "_$$DATE^BGP0UTL($P(BGPFRAC,U,2))_"|||"_$P(BGPBMD,U,2)

 K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,FBD,FED

 Q

IELDFSA ;EP

 D IELDFSA^BGP0EL31

 Q

IELDASA ;EP

 D IELDASA^BGP0EL31

 Q

IELDPHA ;EP - PHN

 D IELDPHA^BGP0EL31

 Q

IRAO ;EP

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

 I BGPAGEB<55 S BGPSTOP="" Q

 I $P(^DPT(DFN,0),U,2)'="F" S BGPSTOP="" Q

 I 'BGPACTCL S BGPSTOP="" Q

 S BGPD1=1

 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1

 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1

 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1

 I BGPAGEB>84 S BGPD5=1

 S T=$O(^ATXAX("B","BGP OSTEOPOROSIS DXS",0))

 I 'T W BGPBOMB Q

 I $$LASTDX^BGP0UTL1(DFN,"BGP OSTEOPOROSIS DXS",$P(^DPT(DFN,0),U,3),BGPEDATE) S BGPSTOP=1 Q  ;had osteoporosis dx

 S BGPPAP=$$OSTEOSCR^BGP0D42(DFN,$$FMADD^XLFDT(BGPBDATE,-(365*2)),BGPEDATE)

 I BGPPAP S BGPN1=1

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

 S BGPVALUE="AC"

 S BGPVALUE=BGPVALUE_"|||"_$P(BGPPAP,U,2)_" "_$$DATE^BGP0UTL($P(BGPPAP,U,3))_$S($P(BGPPAP,U,1)=3:" (refused)",1:"")

 K BGPPAP,X

 Q

 ;

IRAA ;EP

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

 I 'BGPACTCL S BGPSTOP=1 Q

 I BGPAGEB<55 S BGPSTOP=1 Q

 D IRAA^BGP0D82

 Q

FRACTURE(P,BDATE,EDATE) ;EP

 S (X,I,Y,T)=0

 K BGPG,BGPV S BGPGO=""

 S Y="BGPG("

 S X=P_"^FIRST DX [BGP FRACTURE DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)

 I $D(BGPG(1)) D

 .S BGPV($P(BGPG(1),U),$P(BGPG(1),U,5))="DX: "_$P(BGPG(1),U,2)

 .S BGPGO=1

 K BGPG

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

 S X=0 F  S X=$O(^AUPNVCPT("AC",P,X)) Q:X'=+X  D

 .S I=$P($G(^AUPNVCPT(X,0)),U) Q:I=""

 .S C=$P($$CPT^ICPTCOD(I),U,2) Q:C=""

 .Q:'$$ICD^ATXCHK(I,T,1)

 .S V=$P(^AUPNVCPT(X,0),U,3)

 .Q:V=""

 .S D=$P($P($G(^AUPNVSIT(V,0)),U),".")

 .Q:D<BDATE

 .Q:D>EDATE

 .I '$D(BGPV(D,V)) S BGPV(D,V)=""

 .S $P(BGPV(D,V),U,2)="CPT: "_C

 ;

 ;TRAN

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

 S X=0 F  S X=$O(^AUPNVTC("AC",P,X)) Q:X'=+X  D

 .S I=$P($G(^AUPNVTC(X,0)),U,7) Q:I=""

 .S C=$P($$CPT^ICPTCOD(I),U,2) Q:C=""

 .Q:'$$ICD^ATXCHK(I,T,1)

 .S V=$P(^AUPNVTC(X,0),U,3)

 .Q:V=""

 .S D=$P($P($G(^AUPNVSIT(V,0)),U),".")

 .Q:D<BDATE

 .Q:D>EDATE

 .I '$D(BGPV(D,V)) S BGPV(D,V)=""

 .S $P(BGPV(D,V),U,2)="TRAN: "_C

 K BGPG S Y="BGPG("

 S BGPG=$$FIRSTPRC^BGP0UTL1(P,"BGP FRACTURE PROCEDURES",BDATE,EDATE)

 I $P(BGPG,U)=1 D

 .S D=$P(BGPG,U,3)

 .S V=$P(BGPG,U,5),V=$P($G(^AUPNVPRC(V,0)),U,3)

 .Q:'V

 .I '$D(BGPV(D,V)) S BGPV(D,V)=""

 .S $P(BGPV(D,V),U,3)="PROC: "_$P(BGPG,U,2)

 S BGPISD=$O(BGPV(0))

 I BGPISD="" Q ""

 S BGPISV=$O(BGPV(BGPISD,0))

 S BGPIST=$P(^AUPNVSIT(BGPISV,0),U,7) I BGPIST="H" S X=$$DSCHDATE^APCLV(BGPISV,"I") D

 .Q:X=""

 .Q:X=BGPISD

 .S BGPV(X,BGPISV)=BGPV(BGPISD,BGPISV)

 .K BGPV(BGPISD,BGPISV)

 .S BGPISD=X

 I BGPISD="" Q ""

 ;n

 ;

 S BGPX=$$TXBMD^BGP0EL4(P,$$FMADD^XLFDT(BGPISD,-365),$$FMADD^XLFDT(BGPISD,-1)) I $P(BGPX,U) S $P(BGPV(BGPISD,BGPISV),U,5)=$P(BGPX,U,2) Q ""

 ;if outpatient exclude if any fracture in 60 days prior to index start date

 I BGPIST'="H",$$FRACT(P,$$FMADD^XLFDT(BGPISD,-60),$$FMADD^XLFDT(BGPISD,-1)) S $P(BGPV(BGPISD,BGPISV),U,5)="excl: prior fx" Q ""

 I BGPIST="H" S D=$P($P(^AUPNVSIT(BGPISV,0),U),".") I $$FRACT(P,$$FMADD^XLFDT(D,-60),$$FMADD^XLFDT(D,-1)) S $P(BGPV(BGPISD,BGPISV),U,5)="excl: prior fx" Q ""

 Q 1_U_BGPISD_U_BGPISV_U_BGPIST_U_BGPV(BGPISD,BGPISV)

 ;

FRACT(P,FBD,FED) ;

 S (X,I,Y,T)=0

 K BGPG S BGPGO=""

 S Y="BGPG("

 S X=P_"^FIRST DX [BGP FRACTURE DXS;DURING "_$$FMTE^XLFDT(FBD)_"-"_$$FMTE^XLFDT(FED) S E=$$START1^APCLDF(X,Y)

 I $D(BGPG(1)) Q 1

 K BGPG

 S BGPG=0

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

 S X=0 F  S X=$O(^AUPNVCPT("AC",P,X)) Q:X'=+X!(BGPG)  D

 .S I=$P($G(^AUPNVCPT(X,0)),U) Q:I=""

 .S C=$P($$CPT^ICPTCOD(I),U,2) Q:C=""

 .Q:'$$ICD^ATXCHK(I,T,1)

 .S V=$P(^AUPNVCPT(X,0),U,3)

 .S D=$P($P($G(^AUPNVSIT(V,0)),U),".")

 .Q:D<FBD

 .Q:D>FED

 .S BGPG=1

 I BGPG Q 1

 ;

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

 S X=0 F  S X=$O(^AUPNVTC("AC",P,X)) Q:X'=+X!(BGPG)  D

 .S I=$P($G(^AUPNVTC(X,0)),U,7) Q:I=""

 .S C=$P($$CPT^ICPTCOD(I),U,2) Q:C=""

 .Q:'$$ICD^ATXCHK(I,T,1)

 .S V=$P(^AUPNVTC(X,0),U,3)

 .Q:V=""

 .S D=$P($P($G(^AUPNVSIT(V,0)),U),".")

 .Q:D<FBD

 .Q:D>FED

 .S BGPG=1

 I BGPG Q 1

 ;

 S BGPG=$$FIRSTPRC^BGP0UTL1(P,"BGP FRACTURE PROCEDURES",FBD,FED)

 I $P(BGPG,U)=1 Q 1

 Q ""

BGP0EL3   ; IHS/CMI/LAB - measure 1,2,3,4 05 Apr 2009 1:44 PM ;

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

 +2       ;

I9        ;EP

 +1        SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0

 +2        SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN6,BGPN7,BGPN8)=0

 +3        IF BGPAGEB<55

               SET BGPSTOP=1

               QUIT 

 +4        IF 'BGPACTCL

               SET BGPSTOP=1

               QUIT 

 +5        SET BGPD1=1

 +6        IF BGPAGEB>54

               IF BGPAGEB<65

                   SET BGPD2=1

 +7        IF BGPAGEB>64

               IF BGPAGEB<75

                   SET BGPD3=1

 +8        IF BGPAGEB>74

               IF BGPAGEB<85

                   SET BGPD4=1

 +9        IF BGPAGEB>84

               SET BGPD5=1

 +10      ;set to date of flu shot

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

 +11      ;FLU SHOT

           IF BGPVALUE]""

               SET BGPN1=1

 +12      ;REFUSAL

           IF $PIECE(BGPVALUE,U,3)=2

               SET BGPN2=1

 +13      ;CONTRAINDICATION

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

               SET BGPN3=1

               SET BGPN1=1

 +14       IF BGPN1

               IF 'BGPN2

                   SET BGPN7=1

 +15       SET BGPVALUE="AC"_"|||"_$$DATE^BGP0UTL($PIECE(BGPVALUE,U,1))_" "_$PIECE(BGPVALUE,U,2)

 +16       KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,J,K,G,I,L,T

 +17       KILL BGPX,BGPY,BGPC,BGPG

 +18       QUIT 

I10       ;EP

 +1        SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0

 +2        SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8)=0

 +3        IF BGPAGEB<55

               SET BGPSTOP=1

               QUIT 

 +4        IF 'BGPACTCL

               SET BGPSTOP=1

               QUIT 

 +5        SET BGPD1=1

 +6        IF BGPAGEB>54

               IF BGPAGEB<65

                   SET BGPD2=1

 +7        IF BGPAGEB>64

               IF BGPAGEB<75

                   SET BGPD3=1

 +8        IF BGPAGEB>74

               IF BGPAGEB<85

                   SET BGPD4=1

 +9        IF BGPAGEB>84

               SET BGPD5=1

 +10       DO PN^BGP0D3

 +11       SET BGPVALUE="AC|||"_$PIECE(BGPVALUE,"|||",2)

 +12       KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,J,K,G,I,L,T,BGPLHGB

 +13       KILL BGPUP,BGPGFR,BGPX,BGPY,BGPC,BGPG

 +14       QUIT 

I11       ;EP

 +1        SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0

 +2        SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN6,BGPN7)=0

 +3        IF BGPAGEB<55

               SET BGPSTOP=1

               QUIT 

 +4        IF 'BGPACTCL

               SET BGPSTOP=1

               QUIT 

 +5        IF $PIECE(^DPT(DFN,0),U,2)'="F"

               SET BGPSTOP=1

               QUIT 

 +6        IF $$MAS^BGP0D4(DFN,BGPEDATE)

               SET BGPSTOP=1

               QUIT 

 +7        SET BGPD1=1

 +8        IF BGPAGEB>54

               IF BGPAGEB<65

                   SET BGPD2=1

 +9        IF BGPAGEB>64

               IF BGPAGEB<75

                   SET BGPD3=1

 +10       IF BGPAGEB>74

               IF BGPAGEB<85

                   SET BGPD4=1

 +11       IF BGPAGEB>84

               SET BGPD5=1

 +12       SET BGPMAM=$$MAM^BGP0D4(DFN,BGPEDATE,2)

 +13       SET BGPN1=0

           IF $PIECE(BGPMAM,U)=1

               SET BGPN1=1

 +14       SET BGPN2=0

           IF $PIECE(BGPMAM,U,3)["ref"

               SET BGPN2=1

 +15       IF BGPN1

               IF 'BGPN2

                   SET BGPN3=1

 +16       SET BGPVALUE="AC"_"|||"_$$DATE^BGP0UTL($PIECE(BGPMAM,U,2))_" "_$PIECE(BGPMAM,U,3)

 +17       KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,J,K,G,I,L,T,BGPLHGB

 +18       KILL BGPUP,BGPGFR,BGPX,BGPY,BGPC,BGPG,BGPMAM

 +19       QUIT 

I12       ;EP

 +1        SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0

 +2        SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN6,BGPN7,BGPN8)=0

 +3        IF BGPAGEB<55

               SET BGPSTOP=1

               QUIT 

 +4        IF 'BGPACTCL

               SET BGPSTOP=1

               QUIT 

 +5       ;has colorectal cancer

           IF $$CRC^BGP0D61(DFN,BGPEDATE)

               SET BGPSTOP=1

               QUIT 

 +6        SET BGPD1=1

 +7        IF BGPAGEB>54

               IF BGPAGEB<65

                   SET BGPD2=1

 +8        IF BGPAGEB>64

               IF BGPAGEB<75

                   SET BGPD3=1

 +9        IF BGPAGEB>74

               IF BGPAGEB<85

                   SET BGPD4=1

 +10       IF BGPAGEB>84

               SET BGPD5=1

 +11       DO CRCP^BGP0D61

 +12       SET BGPVALUE="AC|||"_$PIECE(BGPVALUE,"|||",2)

 +13       KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P

 +14       KILL BGPX,BGPY,BGPC,BGPG

 +15       QUIT 

 +16      ;

I13       ;EP

 +1        SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8)=0

 +2        SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN6)=0

 +3        IF BGPAGEB<55

               SET BGPSTOP=1

               QUIT 

 +4        IF 'BGPACTCL

               SET BGPSTOP=1

               QUIT 

 +5        SET BGPD1=1

 +6        IF BGPAGEB>54

               IF BGPAGEB<65

                   SET BGPD2=1

 +7        IF BGPAGEB>64

               IF BGPAGEB<75

                   SET BGPD3=1

 +8        IF BGPAGEB>74

               IF BGPAGEB<85

                   SET BGPD4=1

 +9        IF BGPAGEB>84

               SET BGPD5=1

 +10       DO TA^BGP0D7

 +11       SET BGPVALUE=BGPVALUE_$SELECT(BGPN1:";SCREENED",1:"")_$SELECT(BGPN2:";USER",1:"")_$SELECT(BGPN3:";SMOKER",1:"")_$SELECT(BGPN4:";SMOKELESS",1:"")

 +12       SET BGPVALUE="AC|||"_$PIECE(BGPVALUE,"|||",2)

 +13       KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,BGPSDX,BGPXPTD,BGP1320

 +14       KILL BGPX,BGPY,BGPC,BGPG

 +15       QUIT 

I14       ;EP

 +1        SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0

 +2        SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN6,BGPN7)=0

 +3        SET BGPDVREF=""

 +4        IF BGPAGEB<55

               SET BGPSTOP=1

               QUIT 

 +5        IF 'BGPACTCL

               SET BGPSTOP=1

               QUIT 

 +6        IF BGPSEX'="F"

               SET BGPSTOP=1

               QUIT 

 +7        SET BGPD1=1

 +8        IF BGPAGEB>54

               IF BGPAGEB<65

                   SET BGPD2=1

 +9        IF BGPAGEB>64

               IF BGPAGEB<75

                   SET BGPD3=1

 +10       IF BGPAGEB>74

               IF BGPAGEB<85

                   SET BGPD4=1

 +11       IF BGPAGEB>84

               SET BGPD5=1

 +12       DO DV^BGP0D5

 +13       SET BGPVALUE="AC|||"_$PIECE(BGPVALUE,"|||",2)

 +14       QUIT 

 +15      ;

I15       ;EP

 +1        SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0

 +2        SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN6,BGPN7,BGPN8,BGPN9)=0

 +3        IF BGPAGEB<55

               SET BGPSTOP=1

               QUIT 

 +4        IF 'BGPACTCL

               SET BGPSTOP=1

               QUIT 

 +5        SET BGPD1=1

 +6        IF BGPAGEB>54

               IF BGPAGEB<65

                   SET BGPD2=1

 +7        IF BGPAGEB>64

               IF BGPAGEB<75

                   SET BGPD3=1

 +8        IF BGPAGEB>74

               IF BGPAGEB<85

                   SET BGPD4=1

 +9        IF BGPAGEB>84

               SET BGPD5=1

 +10       DO DEPEP^BGP0D25

 +11       SET BGPVALUE="AC|||"_$PIECE(BGPVALUE,"|||",2)

 +12       QUIT 

I16       ;EP

 +1        SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0