BGP2D7.m

BGP2D7 ; IHS/CMI/LAB - measure 31 ;

 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66

I18 ;EP

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

 I BGPAGEB<5 S BGPSTOP=1 Q

 I BGPACTUP S BGPD1=1

 I BGPAGEB>4,BGPAGEB<14 S BGPD2=1

 I BGPAGEB>13,BGPAGEB<18 S BGPD3=1

 I BGPAGEB>17,BGPAGEB<25 S BGPD4=1

 I BGPAGEB>24,BGPAGEB<45 S BGPD5=1

 I BGPAGEB>44,BGPAGEB<65 S BGPD6=1

 I BGPAGEB>64 S BGPD7=1

 I BGPSEX="F",$$PREG(DFN,$$FMADD^XLFDT(BGPEDATE,-608),BGPEDATE,1,1) S BGPD8=1

 I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8) S BGPSTOP=1 Q

 S BGP20M=$$FMADD^XLFDT(BGPEDATE,-608)

TA ;EP - called from elder

 ;S BGPTOB=$$TOBACCO(DFN,BGPBDATE,BGPEDATE)

 S BGPTOB=$$TOBHF^BGP2D712(DFN,BGPBDATE,BGPEDATE)  ;get last HF from the 3 categories during the report period

 S BGPSDX=$$DX(DFN,BGPBDATE,BGPEDATE)

 S BGPXPWD=$$PED(DFN,BGPBDATE,BGPEDATE)

 S BGP1320=$$DENT(DFN,BGPBDATE,BGPEDATE)

 S BGPSCPT=$$CPTSM(DFN,BGPBDATE,BGPEDATE)

 S BGPN1=$S(BGPTOB]"":1,1:0)

 I BGPSDX]"" S BGPN1=1

 I BGPXPWD]"" S BGPN1=1

 I BGP1320]"" S BGPN1=1

 I BGPSCPT]"" S BGPN1=1

 S (BGPVALUE,BGPVAL)=""

 I 'BGPN1 G TAEND  ;not screened so don't bother with other numerators

 S F=BGPTOB

 S %=""

 S T=$O(^ATXAX("B","BGP TOBACCO PAST USE DXS",0))

 I BGPSDX]"" S I=$P(BGPSDX,U,3) I $$ICD^ATXCHK(I,T,9) S %=1

 ;BGPN2 - USER

 D

 .I $P(F,U,1)["CURRENT"!($P(F,U,1)["CESSATION") S BGPN2=1,BGPVAL=$P(BGPTOB,U,2)_" SCREEN, "_$P(BGPTOB,U,2)_" USER" Q

 .I $P(F,U,4)["CURRENT"!($P(F,U,4)["CESSATION") S BGPN2=1,BGPVAL=$P(BGPTOB,U,5)_" SCREEN, "_$P(BGPTOB,U,5)_" USER" Q

 .I (BGPSDX]""&(%="")) S BGPN2=1,BGPVAL=$$DATE^BGP2UTL($P(BGPSDX,U,2))_" SCREEN, "_$$DATE^BGP2UTL($P(BGPSDX,U,2))_" USER" Q

 .I ($P(BGPSCPT,U)="1034F")!($P(BGPSCPT,U)="1035F")!($P(BGPSCPT,U)="G0376")!($P(BGPSCPT,U)="G0375")!($P(BGPSCPT,U)=99407) S BGPN2=1,BGPVAL=$$DATE^BGP2UTL($P(BGPSCPT,U,2))_" SCREEN, "_$$DATE^BGP2UTL($P(BGPSCPT,U,2))_" USER" Q

 .I $P(BGPSCPT,U)=99406!($P(BGPSCPT,U)="G8455")!($P(BGPSCPT,U)="G8456")!($P(BGPSCPT,U)="G8402")!($P(BGPSCPT,U)="G8453") S BGPN2=1,BGPVAL=$$DATE^BGP2UTL($P(BGPSCPT,U,2))_" SCREEN, "_$$DATE^BGP2UTL($P(BGPSCPT,U,2))_" USER" Q

 ;BGPN3 - SMOKER OR NOT

 D

 .I $P(F,U,1)["CURRENT SMOKER"!($P(F,U,1)="CESSATION-SMOKER") S BGPN3=1,BGPVAL=BGPVAL_", "_$P(F,U,2)_" SMOKER" Q

 .I BGPSDX]""&(%="") S BGPN3=1,BGPVAL=BGPVAL_", "_$$DATE^BGP2UTL($P(BGPSDX,U,2))_" SMOKER" Q

 .I $P(BGPSCPT,U)="1034F"!($P(BGPSCPT,U)="G0376")!($P(BGPSCPT,U)="G0375")!($P(BGPSCPT,U)=99407)!($P(BGPSCPT,U)=99406)!($P(BGPSCPT,U)="G8455")!($P(BGPSCPT,U)="G8402")!($P(BGPSCPT,U)="G8453") D

 ..S BGPN3=1,BGPVAL=BGPVAL_", "_$$DATE^BGP2UTL($P(BGPSCPT,U,2))_" SMOKER" Q

 ;BGPN4 - SMOKELESS

 D

 .I $P(F,U,4)="CURRENT SMOKELESS"!($P(F,U,4)="CURRENT SMOKER & SMOKELESS")!($P(F,U,4)="CESSATION-SMOKELESS") S BGPN4=1,BGPVAL=BGPVAL_", "_$P(F,U,5)_" SMOKELESS" Q

 .I $P(BGPSCPT,U)="1035F"!($P(BGPSCPT,U)="G8456") S BGPN4=1,BGPVAL=BGPVAL_", "_$$DATE^BGP2UTL($P(BGPSCPT,U,2))_" SMOKELESS" Q

 ;BGPN5 - ETS

 I $P(F,U,7)="SMOKER IN HOME"!($P(F,U,7)["ENVIRON") S BGPN5=1,BGPVAL=$S(BGPVAL["SCREEN":BGPVAL_", "_$P(F,U,8)_" ETS",1:$P(BGPTOB,U,8)_" SCREEN, ETS")

 I BGPN1,BGPVAL="" D

 .I BGPTOB]"" S BGPVAL=$S($P(BGPTOB,U,2)]"":$P(BGPTOB,U,2)_" SCREEN",$P(BGPTOB,U,5)]"":$P(BGPTOB,U,5)_" SCREEN",$P(BGPTOB,U,8)]"":$P(BGPTOB,U,8)_" SCREEN",1:"") Q

 .I BGPSDX]"" S BGPVAL=$$DATE^BGP2UTL($P(BGPSDX,U,2))_" SCREEN" Q

 .I BGPSCPT]"" S BGPVAL=$$DATE^BGP2UTL($P(BGPSCPT,U,2))_" SCREEN" Q

 .I BGPXPWD]"" S BGPVAL=$$DATE^BGP2UTL($P(BGPXPWD,U,2))_" SCREEN" Q

 .I BGP1320]"" S BGPVAL=$$DATE^BGP2UTL($P(BGP1320,U,2))_" SCREEN" Q

 S V=$S(BGPD1:"UP",1:"")_$S(BGPACTCL:",AC",1:"")_$S(BGPD8:",PREG",1:"")

 S BGPVALUE=V_"|||"_BGPVAL

 ;

TAEND ;now check pregnancy if necessary

 S V=$S(BGPD1:"UP",1:"")_$S(BGPACTCL:",AC",1:"")_$S(BGPD8:",PREG",1:"")

 S BGPVALUE=V_"|||"_BGPVAL

 I BGPRTYPE'=5,BGPD8,'BGPN1 D PREGSCRN

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

 K ^TMP($J,"A")

 Q

 ;

PREGSCRN ;

 G PREGSCRN^BGP2D713

 ;

I023 ;EP - PHN

 K BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE

 I 'BGPACTUP S BGPSTOP=1 Q

 S (BGPN1,BGPN2)=0

 S BGPVALUE=$$PHNV(DFN,BGP365,BGPEDATE,BGPHOME)

 S BGPN1=BGPVALUE

 S BGPVALUE="UP|||"_$P(BGPVALUE,U)_" all PHN; "_$P(BGPVALUE,U,2)_" home; "_$P(BGPVALUE,U,12)_" driver all; "_$P(BGPVALUE,U,13)_" driver home"

 K ^TMP($J,"A")

 Q

PHNV(P,BDATE,EDATE,HOMELOC) ;

 S HOMELOC=$G(HOMELOC)

 K ^TMP($J,"A") S A="^TMP($J,""A"","

 S B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)

 I '$D(^TMP($J,"A",1)) Q "0^0^0^0^0^0^0^0^0^0^0^0^0"

 S (X,Y)=0,C="0^0^0^0^0^0^0^0^0^0^0^0^0" F  S X=$O(^TMP($J,"A",X)) Q:X'=+X  S V=$P(^TMP($J,"A",X),U,5) D

 .;S Y=0 I $$CLINIC^APCLV(V,"C")=45 S Y=1 Q

 .S (D,Y,Z)=0

 .F  S D=$O(^AUPNVPRV("AD",V,D)) Q:D'=+D  S Q=$P(^AUPNVPRV(D,0),U) D

 ..Q:Q=""

 ..S %=$$VALI^XBDIQ1($S($P(^DD(9000010.06,.01,0),U,2)["200":200,1:6),Q,$S($P(^DD(9000010.06,.01,0),U,2)["200":53.5,1:2))

 ..I % S %=$P($G(^DIC(7,+%,9999999)),U)

 ..I %'=13,%'=91 Q  ;not a phn or driver

 ..S $P(C,U,1)=$P(C,U,1)+1

 ..I %=91 S $P(C,U,12)=$P(C,U,12)+1

 ..D HOME

 ..D AGE

 Q C

 ;

HOME ;

 S HV=0

 I $$CLINIC^APCLV(V,"C")=11 S $P(C,U,2)=$P(C,U,2)+1,HV=1 S:%=91 $P(C,U,13)=$P(C,U,13)+1 Q

 Q:HOMELOC=""

 I HOMELOC=$P(^AUPNVSIT(V,0),U,6) S $P(C,U,2)=$P(C,U,2)+1,HV=1 S:%=91 $P(C,U,13)=$P(C,U,13)+1 Q

 Q

AGE ;

 S DAYS=$$FMDIFF^XLFDT($P($P(^AUPNVSIT(V,0),U),"."),$P(^DPT(P,0),U,3))

 S YRS=$$AGE^AUPNPAT(P,$P($P(^AUPNVSIT(V,0),U),"."))

 I DAYS<29 S $P(C,U,3)=$P(C,U,3)+1 S:HV=1 $P(C,U,4)=$P(C,U,4)+1 Q

 I DAYS>28,YRS<1 S $P(C,U,5)=$P(C,U,5)+1 S:HV=1 $P(C,U,6)=$P(C,U,6)+1 Q

 I YRS>0,YRS<65 S $P(C,U,7)=$P(C,U,7)+1 S:HV=1 $P(C,U,8)=$P(C,U,8)+1 Q

 I YRS>64 S $P(C,U,9)=$P(C,U,9)+1 S:HV=1 $P(C,U,10)=$P(C,U,10)+1 Q

 W BGPBOMB

 Q

DENT(P,BDATE,EDATE) ;EP

 K ^TMP($J,"A")

 S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)

 I '$D(^TMP($J,"A",1)) Q ""

 S (X,G)=0 F  S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G)  S V=$P(^TMP($J,"A",X),U,5) D

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

 .Q:'$P(^AUPNVSIT(V,0),U,9)

 .Q:$P(^AUPNVSIT(V,0),U,11)

 .S Z=0 F  S Z=$O(^AUPNVDEN("AD",V,Z)) Q:Z'=+Z!(G)  S B=$P($G(^AUPNVDEN(Z,0)),U) I B S B=$P($G(^AUTTADA(B,0)),U) I B=1320 S G=1_U_$P($P(^AUPNVSIT(V,0),U),".")

 .Q

 I G=0 Q ""

 Q "ADA 1320"_U_$P(G,U,2)

PED(P,BDATE,EDATE) ;EP

 K BGPG

 S Y="BGPG("

 S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)

 I '$D(BGPG) Q ""

 S (X,D)=0,%="",T="" F  S X=$O(BGPG(X)) Q:X'=+X!(%]"")  D

 .S T=$P(^AUPNVPED(+$P(BGPG(X),U,4),0),U)

 .Q:'T

 .Q:'$D(^AUTTEDT(T,0))

 .S T=$P(^AUTTEDT(T,0),U,2)

 .I $P(T,"-")="TO" S %=T_U_$P(BGPG(X),U) Q

 .I $P(T,"-",2)="TO" S %=T_U_$P(BGPG(X),U) Q

 .I $P(T,"-",2)="SHS" S %=T_U_$P(BGPG(X),U) Q

 .S S=$P(T,"-",1)

 .S S=$$ICDDX^ICDCODE(S)

 .I $P(S,U,1)'="-1",$$ICD^ATXCHK($P(S,U,1),$O(^ATXAX("B","BGP TOBACCO DXS",0)),9) S %=T_U_$P(BGPG(X),U) Q

 .I $P(T,"-")="D1320" S %=T_U_$P(BGPG(X),U) Q

 .I $P(T,"-")="99406" S %=T_U_$P(BGPG(X),U) Q

 .I $P(T,"-")="99407" S %=T_U_$P(BGPG(X),U) Q

 .I $P(T,"-")="G0375" S %=T_U_$P(BGPG(X),U) Q

 .I $P(T,"-")="G0376" S %=T_U_$P(BGPG(X),U) Q

 .I $P(T,"-")="1034F" S %=T_U_$P(BGPG(X),U) Q

 .I $P(T,"-")="1035F" S %=T_U_$P(BGPG(X),U) Q

 .I $P(T,"-")="1036F" S %=T_U_$P(BGPG(X),U) Q

 .I $P(T,"-")="1000F" S %=T_U_$P(BGPG(X),U) Q

 .I $P(T,"-")="G8455" S %=T_U_$P(BGPG(X),U) Q

 .I $P(T,"-")="G8456" S %=T_U_$P(BGPG(X),U) Q

 .I $P(T,"-")="G8457" S %=T_U_$P(BGPG(X),U) Q

 .I $P(T,"-")="G8402" S %=T_U_$P(BGPG(X),U) Q

 .I $P(T,"-")="G8453" S %=T_U_$P(BGPG(X),U) Q

 Q %

PREG(P,BDATE,EDATE,NORXCHR,NORX) ;EP

 NEW BGPDX,B,CNT,BGPD,BGPG,Y,X,D,C,T,G,%

 S B=0,CNT=0,BGPD=""  ;if there is one before time frame set this to 1

 S NORXCHR=$G(NORXCHR)

 S NORX=$G(NORX)

 K BGPG

 S Y="BGPG("

 S X=P_"^ALL DX [BGP PREGNANCY DIAGNOSES 2;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)

 ;now reorder by date of diagnosis and eliminate all chr and rx if necessary

 I '$D(BGPG) G PROB  ;no diagnoses

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

 .;get date

 .S D=$P(BGPG(X),U,1)

 .S C=$$CLINIC^APCLV($P(BGPG(X),U,5),"C")

 .I NORXCHR,C=39 Q

 .I NORX,C=39 Q

 .S C=$$PRIMPROV^APCLV($P(BGPG(X),U,5),"D")

 .I NORXCHR,C=53 Q  ;no chr as primary provider

 .S BGPDX(D)="",CNT=CNT+1 I CNT=2 S BGPD=D

 .I D>$$FMADD^XLFDT(EDATE,-365) S B=1

 .Q

 I CNT>1,B G MA

PROB ;

 I '$G(B) Q ""  ;no pregnancy visit during time period  ;-Lori fix in 09

 S T=$O(^ATXAX("B","BGP GPRA PREGNANCY DIAGNOSES",0))

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

 .Q:$P(^AUPNPROB(X,0),U,12)'="A"

 .Q:$P(^AUPNPROB(X,0),U,8)>EDATE

 .Q:$P(^AUPNPROB(X,0),U,8)<BDATE

 .S Y=$P(^AUPNPROB(X,0),U)

 .Q:'$$ICD^ATXCHK(Y,T,9)

 .S G=$P(^AUPNPROB(X,0),U,8)

 .Q

 I G=0,BGPD="" Q 0  ;no dxs and no problem list

 S BGPD=G

MA ;now check for abortion or miscarriage

 ;abortion first

 K BGPG S Y="BGPG(" S X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_$$FMTE^XLFDT(BGPD)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)

 I $D(BGPG(1)) Q 0  ;HAD MIS/AB

 S BGPG=$$LASTPRC^BGP2UTL1(P,"BGP ABORTION PROCEDURES",BDATE,EDATE)

 I BGPG Q 0

 S T=$O(^ATXAX("B","BGP MISCARRIAGE/ABORTION DXS",0))

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

 .Q:$P(^AUPNPROB(X,0),U,12)'="A"

 .Q:$P(^AUPNPROB(X,0),U,8)<BGPD

 .Q:$P(^AUPNPROB(X,0),U,8)>EDATE

 .S Y=$P(^AUPNPROB(X,0),U)

 .Q:'$$ICD^ATXCHK(Y,T,9)

 .S G=1

 .Q

 I G Q 0

 ;now check CPTs for Abortion and Miscarriage

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

 S %=$$CPT^BGP2DU(P,BGPD,EDATE,T,3)

 I %]"" Q 0

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

 S %=$$CPT^BGP2DU(P,BGPD,EDATE,T,3)

 I %]"" Q 0

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

 S %=$$TRAN^BGP2DU(P,BGPD,EDATE,T,3)

 I %]"" Q 0

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

 S %=$$TRAN^BGP2DU(P,BGPD,EDATE,T,3)

 I %]"" Q 0

 Q 1

DX(P,BDATE,EDATE) ;EP

 K BGPG

 S BGPG(1)=$$LASTDX^BGP2UTL1(P,"BGP GPRA SMOKING DXS",BDATE,EDATE)

 I BGPG(1)]"" Q $P($$ICDDX^ICDCODE($P(BGPG(1),U,4),$P(BGPG(1),U,1)),U,2)_U_$P(BGPG(1),U,3)_U_$P(BGPG(1),U,4)

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

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

 .Q:$P(^AUPNPROB(X,0),U,12)'="A"

 .Q:$P(^AUPNPROB(X,0),U,3)>EDATE

 .Q:$P(^AUPNPROB(X,0),U,3)<BDATE

 .S Y=$P(^AUPNPROB(X,0),U)

 .Q:'$$ICD^ATXCHK(Y,T,9)

 .S G=$P($$ICDDX^ICDCODE(Y),U,2)_U_$P(^AUPNPROB(X,0),U,3)_U_Y

 .Q

 Q G

TOBACCO(P,BDATE,EDATE,CESSIN) ;EP - USED FOR TOBACCO SCREEN ONLY

 K BGPTOB,BGP

 S CESSIN=$G(CESSIN)

 D TOBACCO1

 I BGPTOB]"" Q BGPTOB

 D TOBACCO0

 I $D(BGPTOB) Q BGPTOB

 Q ""

TOBACCO1 ;check for tobacco documented in health factors

 K BGPTOB

 S BGPTOB=$$LASTHF(P,"TOBACCO (SMOKING)",BDATE,EDATE) K O,D,H

 Q:BGPTOB]""

 S BGPTOB=$$LASTHF(P,"TOBACCO (SMOKELESS - CHEWING/DIP)",BDATE,EDATE) K O,D,H

 Q:BGPTOB]""

 I 'CESSIN S BGPTOB=$$LASTHF(P,"TOBACCO (EXPOSURE)",BDATE,EDATE) K O,D,H

 Q:BGPTOB]""

 S BGPTOB=$$LASTHF(P,"TOBACCO",BDATE,EDATE) K O,D,H

 Q

TOBACCO0 ;lookup in health status

 S (X,Y)=0 F  S X=$O(^AUPNHF("AA",P,X)) Q:X'=+X!(Y)  I $$VAL^XBDIQ1(9999999.64,X,.03)="TOBACCO" S Y=X

 Q:'Y

 S E=$O(^AUPNHF("AA",P,Y,0)) Q:'E

 I (9999999-E)>EDATE Q  ;documented after time frame

 I (9999999-E)<BDATE Q  ;documented before year

 S Y=$P(^AUTTHF(Y,0),U)

 S BGPTOB=Y_"^"_$$DATE^BGP2UTL(9999999-E)_"^"_(9999999-E)

 K Y,E,X

 Q

 ;

LASTHF(P,C,BDATE,EDATE) ;EP - get last factor in category C for patient P

 S C=$O(^AUTTHF("B",C,0)) ;ien of category passed

 I '$G(C) Q ""

 S (H,D)=0 K O

 F  S H=$O(^AUTTHF("AC",C,H))  Q:'+H  D

 .Q:'$D(^AUPNVHF("AA",P,H))

 .S D="" F  S D=$O(^AUPNVHF("AA",P,H,D)) Q:D'=+D  D

 ..Q:(9999999-D)>EDATE  ;after time frame

 ..Q:(9999999-D)<BDATE  ;before time frame

 ..S O(D)=$O(^AUPNVHF("AA",P,H,D,""))

 .Q

 S D=$O(O(0))

 I D="" Q D

 Q $$VAL^XBDIQ1(9000010.23,O(D),.01)_"^"_$$DATE^BGP2UTL(9999999-D)_"^"_(9999999-D)

 ;

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

 ;

CPTSM(P,BDATE,EDATE) ;EP - did pat have TOBACCO SCREENING cpt?

 NEW X

 S X=$$CPT^BGP2DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP TOBACCO SCREEN CPTS",0)),5)

 I X]"" Q $P(X,U,2)_U_$P(X,U,1)

 Q ""

BGP2D7    ; IHS/CMI/LAB - measure 31 ;

 +1       ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66

I18       ;EP

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

 +2        IF BGPAGEB<5

               SET BGPSTOP=1

               QUIT 

 +3        IF BGPACTUP

               SET BGPD1=1

 +4        IF BGPAGEB>4

               IF BGPAGEB<14

                   SET BGPD2=1

 +5        IF BGPAGEB>13

               IF BGPAGEB<18

                   SET BGPD3=1

 +6        IF BGPAGEB>17

               IF BGPAGEB<25

                   SET BGPD4=1

 +7        IF BGPAGEB>24

               IF BGPAGEB<45

                   SET BGPD5=1

 +8        IF BGPAGEB>44

               IF BGPAGEB<65

                   SET BGPD6=1

 +9        IF BGPAGEB>64

               SET BGPD7=1

 +10       IF BGPSEX="F"

               IF $$PREG(DFN,$$FMADD^XLFDT(BGPEDATE,-608),BGPEDATE,1,1)

                   SET BGPD8=1

 +11       IF '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8)

               SET BGPSTOP=1

               QUIT 

 +12       SET BGP20M=$$FMADD^XLFDT(BGPEDATE,-608)

TA        ;EP - called from elder

 +1       ;S BGPTOB=$$TOBACCO(DFN,BGPBDATE,BGPEDATE)

 +2       ;get last HF from the 3 categories during the report period

           SET BGPTOB=$$TOBHF^BGP2D712(DFN,BGPBDATE,BGPEDATE)

 +3        SET BGPSDX=$$DX(DFN,BGPBDATE,BGPEDATE)

 +4        SET BGPXPWD=$$PED(DFN,BGPBDATE,BGPEDATE)

 +5        SET BGP1320=$$DENT(DFN,BGPBDATE,BGPEDATE)

 +6        SET BGPSCPT=$$CPTSM(DFN,BGPBDATE,BGPEDATE)

 +7        SET BGPN1=$SELECT(BGPTOB]"":1,1:0)

 +8        IF BGPSDX]""

               SET BGPN1=1

 +9        IF BGPXPWD]""

               SET BGPN1=1

 +10       IF BGP1320]""

               SET BGPN1=1

 +11       IF BGPSCPT]""

               SET BGPN1=1

 +12       SET (BGPVALUE,BGPVAL)=""

 +13      ;not screened so don't bother with other numerators

           IF 'BGPN1

               GOTO TAEND

 +14       SET F=BGPTOB

 +15       SET %=""

 +16       SET T=$ORDER(^ATXAX("B","BGP TOBACCO PAST USE DXS",0))

 +17       IF BGPSDX]""

               SET I=$PIECE(BGPSDX,U,3)

               IF $$ICD^ATXCHK(I,T,9)

                   SET %=1

 +18      ;BGPN2 - USER

 +19       Begin DoDot:1

 +20           IF $PIECE(F,U,1)["CURRENT"!($PIECE(F,U,1)["CESSATION")

                   SET BGPN2=1

                   SET BGPVAL=$PIECE(BGPTOB,U,2)_" SCREEN, "_$PIECE(BGPTOB,U,2)_" USER"

                   QUIT 

 +21           IF $PIECE(F,U,4)["CURRENT"!($PIECE(F,U,4)["CESSATION")

                   SET BGPN2=1

                   SET BGPVAL=$PIECE(BGPTOB,U,5)_" SCREEN, "_$PIECE(BGPTOB,U,5)_" USER"

                   QUIT 

 +22           IF (BGPSDX]""&(%=""))

                   SET BGPN2=1

                   SET BGPVAL=$$DATE^BGP2UTL($PIECE(BGPSDX,U,2))_" SCREEN, "_$$DATE^BGP2UTL($PIECE(BGPSDX,U,2))_" USER"

                   QUIT 

 +23           IF ($PIECE(BGPSCPT,U)="1034F")!($PIECE(BGPSCPT,U)="1035F")!($PIECE(BGPSCPT,U)="G0376")!($PIECE(BGPSCPT,U)="G0375")!($PIECE(BGPSCPT,U)=99407)

                   SET BGPN2=1

                   SET BGPVAL=$$DATE^BGP2UTL($PIECE(BGPSCPT,U,2))_" SCREEN, "_$$DATE^BGP2UTL($PIECE(BGPSCPT,U,2))_" USER"

                   QUIT 

 +24           IF $PIECE(BGPSCPT,U)=99406!($PIECE(BGPSCPT,U)="G8455")!($PIECE(BGPSCPT,U)="G8456")!($PIECE(BGPSCPT,U)="G8402")!($PIECE(BGPSCPT,U)="G8453")

                   SET BGPN2=1

                   SET BGPVAL=$$DATE^BGP2UTL($PIECE(BGPSCPT,U,2))_" SCREEN, "_$$DATE^BGP2UTL($PIECE(BGPSCPT,U,2))_" USER"

                   QUIT 

           End DoDot:1

 +25      ;BGPN3 - SMOKER OR NOT

 +26       Begin DoDot:1

 +27           IF $PIECE(F,U,1)["CURRENT SMOKER"!($PIECE(F,U,1)="CESSATION-SMOKER")

                   SET BGPN3=1

                   SET BGPVAL=BGPVAL_", "_$PIECE(F,U,2)_" SMOKER"

                   QUIT 

 +28           IF BGPSDX]""&(%="")

                   SET BGPN3=1

                   SET BGPVAL=BGPVAL_", "_$$DATE^BGP2UTL($PIECE(BGPSDX,U,2))_" SMOKER"

                   QUIT 

 +29           IF $PIECE(BGPSCPT,U)="1034F"!($PIECE(BGPSCPT,U)="G0376")!($PIECE(BGPSCPT,U)="G0375")!($PIECE(BGPSCPT,U)=99407)!($PIECE(BGPSCPT,U)=99406)!($PIECE(BGPSCPT,U)="G8455")!($PIECE(BGPSCPT,U)="G8402")!($PIECE(BGPSCPT,U)="G8453")

                   Begin DoDot:2

 +30                   SET BGPN3=1

                       SET BGPVAL=BGPVAL_", "_$$DATE^BGP2UTL($PIECE(BGPSCPT,U,2))_" SMOKER"

                       QUIT 

                   End DoDot:2

           End DoDot:1

 +31      ;BGPN4 - SMOKELESS

 +32       Begin DoDot:1

 +33           IF $PIECE(F,U,4)="CURRENT SMOKELESS"!($PIECE(F,U,4)="CURRENT SMOKER & SMOKELESS")!($PIECE(F,U,4)="CESSATION-SMOKELESS")

                   SET BGPN4=1

                   SET BGPVAL=BGPVAL_", "_$PIECE(F,U,5)_" SMOKELESS"

                   QUIT 

 +34           IF $PIECE(BGPSCPT,U)="1035F"!($PIECE(BGPSCPT,U)="G8456")

                   SET BGPN4=1

                   SET BGPVAL=BGPVAL_", "_$$DATE^BGP2UTL($PIECE(BGPSCPT,U,2))_" SMOKELESS"

                   QUIT 

           End DoDot:1

 +35      ;BGPN5 - ETS

 +36       IF $PIECE(F,U,7)="SMOKER IN HOME"!($PIECE(F,U,7)["ENVIRON")

               SET BGPN5=1

               SET BGPVAL=$SELECT(BGPVAL["SCREEN":BGPVAL_", "_$PIECE(F,U,8)_" ETS",1:$PIECE(BGPTOB,U,8)_" SCREEN, ETS")

 +37       IF BGPN1

               IF BGPVAL=""

                   Begin DoDot:1

 +38                   IF BGPTOB]""

                           SET BGPVAL=$SELECT($PIECE(BGPTOB,U,2)]"":$PIECE(BGPTOB,U,2)_" SCREEN",$PIECE(BGPTOB,U,5)]"":$PIECE(BGPTOB,U,5)_" SCREEN",$PIECE(BGPTOB,U,8)]"":$PIECE(BGPTOB,U,8)_" SCREEN",1:"")

                           QUIT 

 +39                   IF BGPSDX]""

                           SET BGPVAL=$$DATE^BGP2UTL($PIECE(BGPSDX,U,2))_" SCREEN"

                           QUIT 

 +40                   IF BGPSCPT]""

                           SET BGPVAL=$$DATE^BGP2UTL($PIECE(BGPSCPT,U,2))_" SCREEN"

                           QUIT 

 +41                   IF BGPXPWD]""

                           SET BGPVAL=$$DATE^BGP2UTL($PIECE(BGPXPWD,U,2))_" SCREEN"