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"
QUIT
+42 IF BGP1320]""
SET BGPVAL=$$DATE^BGP2UTL($PIECE(BGP1320,U,2))_" SCREEN"
QUIT
End DoDot:1
+43 SET V=$SELECT(BGPD1:"UP",1:"")_$SELECT(BGPACTCL:",AC",1:"")_$SELECT(BGPD8:",PREG",1:"")
+44 SET BGPVALUE=V_"|||"_BGPVAL
+45 ;
TAEND ;now check pregnancy if necessary
+1 SET V=$SELECT(BGPD1:"UP",1:"")_$SELECT(BGPACTCL:",AC",1:"")_$SELECT(BGPD8:",PREG",1:"")
+2 SET BGPVALUE=V_"|||"_BGPVAL
+3 IF BGPRTYPE'=5
IF BGPD8
IF 'BGPN1
DO PREGSCRN
+4 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,BGPSDX,BGPXPWD,BGP1320,BGP20M
+5 KILL ^TMP($JOB,"A")
+6 QUIT
+7 ;
PREGSCRN ;
+1 GOTO PREGSCRN^BGP2D713
+2 ;
I023 ;EP - PHN
+1 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE
+2 IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+3 SET (BGPN1,BGPN2)=0
+4 SET BGPVALUE=$$PHNV(DFN,BGP365,BGPEDATE,BGPHOME)
+5 SET BGPN1=BGPVALUE
+6 SET BGPVALUE="UP|||"_$PIECE(BGPVALUE,U)_" all PHN; "_$PIECE(BGPVALUE,U,2)_" home; "_$PIECE(BGPVALUE,U,12)_" driver all; "_$PIECE(BGPVALUE,U,13)_" driver home"
+7 KILL ^TMP($JOB,"A")
+8 QUIT
PHNV(P,BDATE,EDATE,HOMELOC) ;
+1 SET HOMELOC=$GET(HOMELOC)
+2 KILL ^TMP($JOB,"A")
SET A="^TMP($J,""A"","
+3 SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+4 IF '$DATA(^TMP($JOB,"A",1))
QUIT "0^0^0^0^0^0^0^0^0^0^0^0^0"
+5 SET (X,Y)=0
SET C="0^0^0^0^0^0^0^0^0^0^0^0^0"
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+6 ;S Y=0 I $$CLINIC^APCLV(V,"C")=45 S Y=1 Q
+7 SET (D,Y,Z)=0
+8 FOR
SET D=$ORDER(^AUPNVPRV("AD",V,D))
IF D'=+D
QUIT
SET Q=$PIECE(^AUPNVPRV(D,0),U)
Begin DoDot:2
+9 IF Q=""
QUIT
+10 SET %=$$VALI^XBDIQ1($SELECT($PIECE(^DD(9000010.06,.01,0),U,2)["200":200,1:6),Q,$SELECT($PIECE(^DD(9000010.06,.01,0),U,2)["200":53.5,1:2))
+11 IF %
SET %=$PIECE($GET(^DIC(7,+%,9999999)),U)
+12 ;not a phn or driver
IF %'=13
IF %'=91
QUIT
+13 SET $PIECE(C,U,1)=$PIECE(C,U,1)+1
+14 IF %=91
SET $PIECE(C,U,12)=$PIECE(C,U,12)+1
+15 DO HOME
+16 DO AGE
End DoDot:2
End DoDot:1
+17 QUIT C
+18 ;
HOME ;
+1 SET HV=0
+2 IF $$CLINIC^APCLV(V,"C")=11
SET $PIECE(C,U,2)=$PIECE(C,U,2)+1
SET HV=1
IF %=91
SET $PIECE(C,U,13)=$PIECE(C,U,13)+1
QUIT
+3 IF HOMELOC=""
QUIT
+4 IF HOMELOC=$PIECE(^AUPNVSIT(V,0),U,6)
SET $PIECE(C,U,2)=$PIECE(C,U,2)+1
SET HV=1
IF %=91
SET $PIECE(C,U,13)=$PIECE(C,U,13)+1
QUIT
+5 QUIT
AGE ;
+1 SET DAYS=$$FMDIFF^XLFDT($PIECE($PIECE(^AUPNVSIT(V,0),U),"."),$PIECE(^DPT(P,0),U,3))
+2 SET YRS=$$AGE^AUPNPAT(P,$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
+3 IF DAYS<29
SET $PIECE(C,U,3)=$PIECE(C,U,3)+1
IF HV=1
SET $PIECE(C,U,4)=$PIECE(C,U,4)+1
QUIT
+4 IF DAYS>28
IF YRS<1
SET $PIECE(C,U,5)=$PIECE(C,U,5)+1
IF HV=1
SET $PIECE(C,U,6)=$PIECE(C,U,6)+1
QUIT
+5 IF YRS>0
IF YRS<65
SET $PIECE(C,U,7)=$PIECE(C,U,7)+1
IF HV=1
SET $PIECE(C,U,8)=$PIECE(C,U,8)+1
QUIT
+6 IF YRS>64
SET $PIECE(C,U,9)=$PIECE(C,U,9)+1
IF HV=1
SET $PIECE(C,U,10)=$PIECE(C,U,10)+1
QUIT
+7 WRITE BGPBOMB
+8 QUIT
DENT(P,BDATE,EDATE) ;EP
+1 KILL ^TMP($JOB,"A")
+2 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+3 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+4 SET (X,G)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+5 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+6 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+7 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+8 SET Z=0
FOR
SET Z=$ORDER(^AUPNVDEN("AD",V,Z))
IF Z'=+Z!(G)
QUIT
SET B=$PIECE($GET(^AUPNVDEN(Z,0)),U)
IF B
SET B=$PIECE($GET(^AUTTADA(B,0)),U)
IF B=1320
SET G=1_U_$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+9 QUIT
End DoDot:1
+10 IF G=0
QUIT ""
+11 QUIT "ADA 1320"_U_$PIECE(G,U,2)
PED(P,BDATE,EDATE) ;EP
+1 KILL BGPG
+2 SET Y="BGPG("
+3 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 IF '$DATA(BGPG)
QUIT ""
+5 SET (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+6 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPG(X),U,4),0),U)
+7 IF 'T
QUIT
+8 IF '$DATA(^AUTTEDT(T,0))
QUIT
+9 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+10 IF $PIECE(T,"-")="TO"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+11 IF $PIECE(T,"-",2)="TO"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+12 IF $PIECE(T,"-",2)="SHS"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+13 SET S=$PIECE(T,"-",1)
+14 SET S=$$ICDDX^ICDCODE(S)
+15 IF $PIECE(S,U,1)'="-1"
IF $$ICD^ATXCHK($PIECE(S,U,1),$ORDER(^ATXAX("B","BGP TOBACCO DXS",0)),9)
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+16 IF $PIECE(T,"-")="D1320"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+17 IF $PIECE(T,"-")="99406"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+18 IF $PIECE(T,"-")="99407"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+19 IF $PIECE(T,"-")="G0375"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+20 IF $PIECE(T,"-")="G0376"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+21 IF $PIECE(T,"-")="1034F"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+22 IF $PIECE(T,"-")="1035F"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+23 IF $PIECE(T,"-")="1036F"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+24 IF $PIECE(T,"-")="1000F"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+25 IF $PIECE(T,"-")="G8455"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+26 IF $PIECE(T,"-")="G8456"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+27 IF $PIECE(T,"-")="G8457"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+28 IF $PIECE(T,"-")="G8402"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+29 IF $PIECE(T,"-")="G8453"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
End DoDot:1
+30 QUIT %
PREG(P,BDATE,EDATE,NORXCHR,NORX) ;EP
+1 NEW BGPDX,B,CNT,BGPD,BGPG,Y,X,D,C,T,G,%
+2 ;if there is one before time frame set this to 1
SET B=0
SET CNT=0
SET BGPD=""
+3 SET NORXCHR=$GET(NORXCHR)
+4 SET NORX=$GET(NORX)
+5 KILL BGPG
+6 SET Y="BGPG("
+7 SET X=P_"^ALL DX [BGP PREGNANCY DIAGNOSES 2;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+8 ;now reorder by date of diagnosis and eliminate all chr and rx if necessary
+9 ;no diagnoses
IF '$DATA(BGPG)
GOTO PROB
+10 SET B=0
SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
Begin DoDot:1
+11 ;get date
+12 SET D=$PIECE(BGPG(X),U,1)
+13 SET C=$$CLINIC^APCLV($PIECE(BGPG(X),U,5),"C")
+14 IF NORXCHR
IF C=39
QUIT
+15 IF NORX
IF C=39
QUIT
+16 SET C=$$PRIMPROV^APCLV($PIECE(BGPG(X),U,5),"D")
+17 ;no chr as primary provider
IF NORXCHR
IF C=53
QUIT
+18 SET BGPDX(D)=""
SET CNT=CNT+1
IF CNT=2
SET BGPD=D
+19 IF D>$$FMADD^XLFDT(EDATE,-365)
SET B=1
+20 QUIT
End DoDot:1
+21 IF CNT>1
IF B
GOTO MA
PROB ;
+1 ;no pregnancy visit during time period ;-Lori fix in 09
IF '$GET(B)
QUIT ""
+2 SET T=$ORDER(^ATXAX("B","BGP GPRA PREGNANCY DIAGNOSES",0))
+3 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+4 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
QUIT
+5 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+6 IF $PIECE(^AUPNPROB(X,0),U,8)<BDATE
QUIT
+7 SET Y=$PIECE(^AUPNPROB(X,0),U)
+8 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+9 SET G=$PIECE(^AUPNPROB(X,0),U,8)
+10 QUIT
End DoDot:1
+11 ;no dxs and no problem list
IF G=0
IF BGPD=""
QUIT 0
+12 SET BGPD=G
MA ;now check for abortion or miscarriage
+1 ;abortion first
+2 KILL BGPG
SET Y="BGPG("
SET X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_$$FMTE^XLFDT(BGPD)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+3 ;HAD MIS/AB
IF $DATA(BGPG(1))
QUIT 0
+4 SET BGPG=$$LASTPRC^BGP2UTL1(P,"BGP ABORTION PROCEDURES",BDATE,EDATE)
+5 IF BGPG
QUIT 0
+6 SET T=$ORDER(^ATXAX("B","BGP MISCARRIAGE/ABORTION DXS",0))
+7 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
QUIT
+9 IF $PIECE(^AUPNPROB(X,0),U,8)<BGPD
QUIT
+10 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+11 SET Y=$PIECE(^AUPNPROB(X,0),U)
+12 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+13 SET G=1
+14 QUIT
End DoDot:1
+15 IF G
QUIT 0
+16 ;now check CPTs for Abortion and Miscarriage
+17 SET T=$ORDER(^ATXAX("B","BGP CPT ABORTION",0))
+18 SET %=$$CPT^BGP2DU(P,BGPD,EDATE,T,3)
+19 IF %]""
QUIT 0
+20 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+21 SET %=$$CPT^BGP2DU(P,BGPD,EDATE,T,3)
+22 IF %]""
QUIT 0
+23 SET T=$ORDER(^ATXAX("B","BGP CPT ABORTION",0))
+24 SET %=$$TRAN^BGP2DU(P,BGPD,EDATE,T,3)
+25 IF %]""
QUIT 0
+26 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+27 SET %=$$TRAN^BGP2DU(P,BGPD,EDATE,T,3)
+28 IF %]""
QUIT 0
+29 QUIT 1
DX(P,BDATE,EDATE) ;EP
+1 KILL BGPG
+2 SET BGPG(1)=$$LASTDX^BGP2UTL1(P,"BGP GPRA SMOKING DXS",BDATE,EDATE)
+3 IF BGPG(1)]""
QUIT $PIECE($$ICDDX^ICDCODE($PIECE(BGPG(1),U,4),$PIECE(BGPG(1),U,1)),U,2)_U_$PIECE(BGPG(1),U,3)_U_$PIECE(BGPG(1),U,4)
+4 SET T=$ORDER(^ATXAX("B","BGP GPRA SMOKING DXS",0))
+5 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+6 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
QUIT
+7 IF $PIECE(^AUPNPROB(X,0),U,3)>EDATE
QUIT
+8 IF $PIECE(^AUPNPROB(X,0),U,3)<BDATE
QUIT
+9 SET Y=$PIECE(^AUPNPROB(X,0),U)
+10 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+11 SET G=$PIECE($$ICDDX^ICDCODE(Y),U,2)_U_$PIECE(^AUPNPROB(X,0),U,3)_U_Y
+12 QUIT
End DoDot:1
+13 QUIT G
TOBACCO(P,BDATE,EDATE,CESSIN) ;EP - USED FOR TOBACCO SCREEN ONLY
+1 KILL BGPTOB,BGP
+2 SET CESSIN=$GET(CESSIN)
+3 DO TOBACCO1
+4 IF BGPTOB]""
QUIT BGPTOB
+5 DO TOBACCO0
+6 IF $DATA(BGPTOB)
QUIT BGPTOB
+7 QUIT ""
TOBACCO1 ;check for tobacco documented in health factors
+1 KILL BGPTOB
+2 SET BGPTOB=$$LASTHF(P,"TOBACCO (SMOKING)",BDATE,EDATE)
KILL O,D,H
+3 IF BGPTOB]""
QUIT
+4 SET BGPTOB=$$LASTHF(P,"TOBACCO (SMOKELESS - CHEWING/DIP)",BDATE,EDATE)
KILL O,D,H
+5 IF BGPTOB]""
QUIT
+6 IF 'CESSIN
SET BGPTOB=$$LASTHF(P,"TOBACCO (EXPOSURE)",BDATE,EDATE)
KILL O,D,H
+7 IF BGPTOB]""
QUIT
+8 SET BGPTOB=$$LASTHF(P,"TOBACCO",BDATE,EDATE)
KILL O,D,H
+9 QUIT
TOBACCO0 ;lookup in health status
+1 SET (X,Y)=0
FOR
SET X=$ORDER(^AUPNHF("AA",P,X))
IF X'=+X!(Y)
QUIT
IF $$VAL^XBDIQ1(9999999.64,X,.03)="TOBACCO"
SET Y=X
+2 IF 'Y
QUIT
+3 SET E=$ORDER(^AUPNHF("AA",P,Y,0))
IF 'E
QUIT
+4 ;documented after time frame
IF (9999999-E)>EDATE
QUIT
+5 ;documented before year
IF (9999999-E)<BDATE
QUIT
+6 SET Y=$PIECE(^AUTTHF(Y,0),U)
+7 SET BGPTOB=Y_"^"_$$DATE^BGP2UTL(9999999-E)_"^"_(9999999-E)
+8 KILL Y,E,X
+9 QUIT
+10 ;
LASTHF(P,C,BDATE,EDATE) ;EP - get last factor in category C for patient P
+1 ;ien of category passed
SET C=$ORDER(^AUTTHF("B",C,0))
+2 IF '$GET(C)
QUIT ""
+3 SET (H,D)=0
KILL O
+4 FOR
SET H=$ORDER(^AUTTHF("AC",C,H))
IF '+H
QUIT
Begin DoDot:1
+5 IF '$DATA(^AUPNVHF("AA",P,H))
QUIT
+6 SET D=""
FOR
SET D=$ORDER(^AUPNVHF("AA",P,H,D))
IF D'=+D
QUIT
Begin DoDot:2
+7 ;after time frame
IF (9999999-D)>EDATE
QUIT
+8 ;before time frame
IF (9999999-D)<BDATE
QUIT
+9 SET O(D)=$ORDER(^AUPNVHF("AA",P,H,D,""))
End DoDot:2
+10 QUIT
End DoDot:1
+11 SET D=$ORDER(O(0))
+12 IF D=""
QUIT D
+13 QUIT $$VAL^XBDIQ1(9000010.23,O(D),.01)_"^"_$$DATE^BGP2UTL(9999999-D)_"^"_(9999999-D)
+14 ;
LOINC(A,B) ;
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
+7 ;
CPTSM(P,BDATE,EDATE) ;EP - did pat have TOBACCO SCREENING cpt?
+1 NEW X
+2 SET X=$$CPT^BGP2DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP TOBACCO SCREEN CPTS",0)),5)
+3 IF X]""
QUIT $PIECE(X,U,2)_U_$PIECE(X,U,1)
+4 QUIT ""
