BGP7D7 ; IHS/CMI/LAB - measure 31 06 Nov 2014 2:31 PM ;
;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
I18 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPXPHD,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,"",BGPBDATE,BGPEDATE) 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=$$TOBHF^BGP7D712(DFN,BGPBDATE,BGPEDATE) ;get last HF from the 3 categories
S BGPSDX=$$DX(DFN,BGPBDATE,BGPEDATE)
S BGPUDX=$$DXU(DFN,BGPBDATE,BGPEDATE)
S BGPSMDX=$$DXS(DFN,BGPBDATE,BGPEDATE)
S BGPSLDX=$$DXSL(DFN,BGPBDATE,BGPEDATE)
S BGPXPHD=$$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 BGPSLDX]"" S BGPN1=1
I BGPXPHD]"" S BGPN1=1
I BGP1320]"" S BGPN1=1
I BGPSCPT]"" S BGPN1=1
I BGPUDX]"" S BGPN1=1
I BGPSMDX]"" S BGPN1=1
S (BGPVALUE,BGPVAL)=""
I 'BGPN1 G TAEND
S F=BGPTOB
D
.I $P(F,U,1)["CURRENT"!($P(F,U,1)["CESSATION")!($P(F,U,1)["HEAVY TOBACCO SMOKER")!($P(F,U,1)["LIGHT TOBACCO SMOKER") S BGPN2=1,BGPVAL=$P(BGPTOB,U,2)_" SCREEN, "_$P(BGPTOB,U,2)_" USER" Q ;SMOKING CATEGORY
.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 ;SMOKELESS CATEGORY
.I BGPUDX]"" S BGPN2=1,BGPVAL=$$DATE^BGP7UTL($P(BGPUDX,U,2))_" SCREEN, "_$$DATE^BGP7UTL($P(BGPUDX,U,2))_" USER" Q
.I BGPSMDX]"" S BGPN2=1,BGPVAL=$$DATE^BGP7UTL($P(BGPSMDX,U,2))_" SCREEN, "_$$DATE^BGP7UTL($P(BGPSMDX,U,2))_" USER" Q
.I BGPSLDX]"" S BGPN2=1,BGPVAL=$$DATE^BGP7UTL($P(BGPSLDX,U,2))_" SCREEN, "_$$DATE^BGP7UTL($P(BGPSLDX,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)!($P(BGPSCPT,U)="G9276") D Q
..S BGPN2=1,BGPVAL=$$DATE^BGP7UTL($P(BGPSCPT,U,2))_" SCREEN, "_$$DATE^BGP7UTL($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^BGP7UTL($P(BGPSCPT,U,2))_" SCREEN, "_$$DATE^BGP7UTL($P(BGPSCPT,U,2))_" USER" Q
;BGPN3 - SMOKER OR NOT
D
.I $P(F,U,1)["CURRENT SMOKER"!($P(F,U,1)="CESSATION-SMOKER")!($P(F,U,1)["HEAVY TOBACCO SMOKER")!($P(F,U,1)["LIGHT TOBACCO SMOKER") S BGPN3=1,BGPVAL=BGPVAL_", "_$P(F,U,2)_" SMOKER" Q
.I BGPSMDX]"" S BGPN3=1,BGPVAL=BGPVAL_", "_$$DATE^BGP7UTL($P(BGPSMDX,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^BGP7UTL($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^BGP7UTL($P(BGPSCPT,U,2))_" SMOKELESS" Q
.I BGPSLDX]"" S BGPN4=1,BGPVAL=BGPVAL_", "_$$DATE^BGP7UTL($P(BGPSLDX,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^BGP7UTL($P(BGPSDX,U,2))_" SCREEN" Q
.I BGPSCPT]"" S BGPVAL=$$DATE^BGP7UTL($P(BGPSCPT,U,2))_" SCREEN" Q
.I BGPXPHD]"" S BGPVAL=$$DATE^BGP7UTL($P(BGPXPHD,U,2))_" SCREEN" Q
.I BGP1320]"" S BGPVAL=$$DATE^BGP7UTL($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,BGPXPHD,BGP1320,BGP20M
K ^TMP($J,"A")
Q
;
PREGSCRN ;
G PREGSCRN^BGP7D713
;
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:V']""
.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
NEW BGPG,S,SN,Y,E,X,D,T
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 SN=$O(^BGPSNOMG("B","TOBACCO SCREEN PATIENT ED",0))
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^BGP7UTL2(S)
.I $P(S,U,1)'="-1",$$ICD^BGP7UTL2($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
.I $P(T,"-")="G9276" S %=T_U_$P(BGPG(X),U) Q
.I $P(T,"-")="G9275" S %=T_U_$P(BGPG(X),U) Q
.I $P(T,"-")]"",$D(^BGPSNOMG(SN,11,"B",$P(T,"-"))) S %=T_U_$P(BGPG(X),U) Q
Q %
PREG(P,BDATE,EDATE,NORXCHR,NORX,FORM,CPBD,CPED) ;EP
G PREG^BGP7D714
;
DX(P,BDATE,EDATE) ;EP - WAS THERE SCREENING?
K BGPG
S BGPG(1)=$$LASTDX^BGP7UTL1(P,"BGP TOBACCO DXS",BDATE,EDATE)
I BGPG(1)]"" Q $P($$ICDDX^BGP7UTL2($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 TOBACCO 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)="I"
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.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^BGP7UTL2(Y,T,9)
.S G=$P($$ICDDX^BGP7UTL2(Y),U,2)_U_$P(^AUPNPROB(X,0),U,3)_U_Y
.Q
I G]"" Q G
S G=$$IPLSNOID^BGP7DU(P,"PXRM BGP TOBACCO SCREENED",BDATE,EDATE) I G S G=$P(G,U,2)_U_$P(G,U,3) Q G
Q G
DXSL(P,BDATE,EDATE) ;EP - WAS THERE A SMOKELESS USER DX?
K BGPG
S BGPG(1)=$$LASTDX^BGP7UTL1(P,"BGP GPRA SMOKELESS DXS",BDATE,EDATE)
I BGPG(1)]"" Q $P($$ICDDX^BGP7UTL2($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 SMOKELESS 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)="I"
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.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^BGP7UTL2(Y,T,9)
.S G=$P($$ICDDX^BGP7UTL2(Y),U,2)_U_$P(^AUPNPROB(X,0),U,3)_U_Y
.Q
I G]"" Q G
S G=$$IPLSNOID^BGP7DU(P,"PXRM BGP TOBACCO SMOKELESS",BDATE,EDATE) I G S G=$P(G,U,2)_U_$P(G,U,3) Q G
Q G
;
DXU(P,BDATE,EDATE) ;EP - WAS THERE A USER DX?
K BGPG
S BGPG(1)=$$LASTDX^BGP7UTL1(P,"BGP TOBACCO USER DXS",BDATE,EDATE)
I BGPG(1)]"" Q $P($$ICDDX^BGP7UTL2($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 TOBACCO USER 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)="I"
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.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^BGP7UTL2(Y,T,9)
.S G=$P($$ICDDX^BGP7UTL2(Y),U,2)_U_$P(^AUPNPROB(X,0),U,3)_U_Y
.Q
I G]"" Q G
S G=$$IPLSNOID^BGP7DU(P,"PXRM BGP CURRENT TOBACCO",BDATE,EDATE) I G S G=$P(G,U,2)_U_$P(G,U,3) Q G
Q G
DXS(P,BDATE,EDATE) ;EP - WAS THERE A SMOKING USER DX?
K BGPG
S BGPG(1)=$$LASTDX^BGP7UTL1(P,"BGP GPRA SMOKING DXS",BDATE,EDATE)
I BGPG(1)]"" Q $P($$ICDDX^BGP7UTL2($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)="I"
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.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^BGP7UTL2(Y,T,9)
.S G=$P($$ICDDX^BGP7UTL2(Y),U,2)_U_$P(^AUPNPROB(X,0),U,3)_U_Y
.Q
I G]"" Q G
S G=$$IPLSNOID^BGP7DU(P,"PXRM BGP TOBACCO SMOKER",BDATE,EDATE) I G S G=$P(G,U,2)_U_$P(G,U,3) Q G
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^BGP7UTL(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^BGP7UTL(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^BGP7DU(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 ""
BGP7D7 ; IHS/CMI/LAB - measure 31 06 Nov 2014 2:31 PM ;
+1 ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
I18 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPXPHD,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,"",BGPBDATE,BGPEDATE)
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 ;get last HF from the 3 categories
SET BGPTOB=$$TOBHF^BGP7D712(DFN,BGPBDATE,BGPEDATE)
+2 SET BGPSDX=$$DX(DFN,BGPBDATE,BGPEDATE)
+3 SET BGPUDX=$$DXU(DFN,BGPBDATE,BGPEDATE)
+4 SET BGPSMDX=$$DXS(DFN,BGPBDATE,BGPEDATE)
+5 SET BGPSLDX=$$DXSL(DFN,BGPBDATE,BGPEDATE)
+6 SET BGPXPHD=$$PED(DFN,BGPBDATE,BGPEDATE)
+7 SET BGP1320=$$DENT(DFN,BGPBDATE,BGPEDATE)
+8 SET BGPSCPT=$$CPTSM(DFN,BGPBDATE,BGPEDATE)
+9 SET BGPN1=$SELECT(BGPTOB]"":1,1:0)
+10 IF BGPSDX]""
SET BGPN1=1
+11 IF BGPSLDX]""
SET BGPN1=1
+12 IF BGPXPHD]""
SET BGPN1=1
+13 IF BGP1320]""
SET BGPN1=1
+14 IF BGPSCPT]""
SET BGPN1=1
+15 IF BGPUDX]""
SET BGPN1=1
+16 IF BGPSMDX]""
SET BGPN1=1
+17 SET (BGPVALUE,BGPVAL)=""
+18 IF 'BGPN1
GOTO TAEND
+19 SET F=BGPTOB
+20 Begin DoDot:1
+21 ;SMOKING CATEGORY
IF $PIECE(F,U,1)["CURRENT"!($PIECE(F,U,1)["CESSATION")!($PIECE(F,U,1)["HEAVY TOBACCO SMOKER")!($PIECE(F,U,1)["LIGHT TOBACCO SMOKER")
SET BGPN2=1
SET BGPVAL=$PIECE(BGPTOB,U,2)_" SCREEN, "_$PIECE(BGPTOB,U,2)_" USER"
QUIT
+22 ;SMOKELESS CATEGORY
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
+23 IF BGPUDX]""
SET BGPN2=1
SET BGPVAL=$$DATE^BGP7UTL($PIECE(BGPUDX,U,2))_" SCREEN, "_$$DATE^BGP7UTL($PIECE(BGPUDX,U,2))_" USER"
QUIT
+24 IF BGPSMDX]""
SET BGPN2=1
SET BGPVAL=$$DATE^BGP7UTL($PIECE(BGPSMDX,U,2))_" SCREEN, "_$$DATE^BGP7UTL($PIECE(BGPSMDX,U,2))_" USER"
QUIT
+25 IF BGPSLDX]""
SET BGPN2=1
SET BGPVAL=$$DATE^BGP7UTL($PIECE(BGPSLDX,U,2))_" SCREEN, "_$$DATE^BGP7UTL($PIECE(BGPSLDX,U,2))_" USER"
QUIT
+26 IF ($PIECE(BGPSCPT,U)="1034F")!($PIECE(BGPSCPT,U)="1035F")!($PIECE(BGPSCPT,U)="G0376")!($PIECE(BGPSCPT,U)="G0375")!($PIECE(BGPSCPT,U)=99407)!($PIECE(BGPSCPT,U)="G9276")
Begin DoDot:2
+27 SET BGPN2=1
SET BGPVAL=$$DATE^BGP7UTL($PIECE(BGPSCPT,U,2))_" SCREEN, "_$$DATE^BGP7UTL($PIECE(BGPSCPT,U,2))_" USER"
QUIT
End DoDot:2
QUIT
+28 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^BGP7UTL($PIECE(BGPSCPT,U,2))_" SCREEN, "_$$DATE^BGP7UTL($PIECE(BGPSCPT,U,2))_" USER"
QUIT
End DoDot:1
+29 ;BGPN3 - SMOKER OR NOT
+30 Begin DoDot:1
+31 IF $PIECE(F,U,1)["CURRENT SMOKER"!($PIECE(F,U,1)="CESSATION-SMOKER")!($PIECE(F,U,1)["HEAVY TOBACCO SMOKER")!($PIECE(F,U,1)["LIGHT TOBACCO SMOKER")
SET BGPN3=1
SET BGPVAL=BGPVAL_", "_$PIECE(F,U,2)_" SMOKER"
QUIT
+32 IF BGPSMDX]""
SET BGPN3=1
SET BGPVAL=BGPVAL_", "_$$DATE^BGP7UTL($PIECE(BGPSMDX,U,2))_" SMOKER"
QUIT
+33 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
+34 SET BGPN3=1
SET BGPVAL=BGPVAL_", "_$$DATE^BGP7UTL($PIECE(BGPSCPT,U,2))_" SMOKER"
QUIT
End DoDot:2
End DoDot:1
+35 ;BGPN4 - SMOKELESS
+36 Begin DoDot:1
+37 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
+38 IF $PIECE(BGPSCPT,U)="1035F"!($PIECE(BGPSCPT,U)="G8456")
SET BGPN4=1
SET BGPVAL=BGPVAL_", "_$$DATE^BGP7UTL($PIECE(BGPSCPT,U,2))_" SMOKELESS"
QUIT
+39 IF BGPSLDX]""
SET BGPN4=1
SET BGPVAL=BGPVAL_", "_$$DATE^BGP7UTL($PIECE(BGPSLDX,U,2))_" SMOKELESS"
QUIT
End DoDot:1
+40 ;BGPN5 - ETS
+41 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")
+42 IF BGPN1
IF BGPVAL=""
Begin DoDot:1
+43 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
+44 IF BGPSDX]""
SET BGPVAL=$$DATE^BGP7UTL($PIECE(BGPSDX,U,2))_" SCREEN"
QUIT
+45 IF BGPSCPT]""
SET BGPVAL=$$DATE^BGP7UTL($PIECE(BGPSCPT,U,2))_" SCREEN"
QUIT
+46 IF BGPXPHD]""
SET BGPVAL=$$DATE^BGP7UTL($PIECE(BGPXPHD,U,2))_" SCREEN"
QUIT
+47 IF BGP1320]""
SET BGPVAL=$$DATE^BGP7UTL($PIECE(BGP1320,U,2))_" SCREEN"
QUIT
End DoDot:1
+48 SET V=$SELECT(BGPD1:"UP",1:"")_$SELECT(BGPACTCL:",AC",1:"")_$SELECT(BGPD8:",PREG",1:"")
+49 SET BGPVALUE=V_"|||"_BGPVAL
+50 ;
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,BGPXPHD,BGP1320,BGP20M
+5 KILL ^TMP($JOB,"A")
+6 QUIT
+7 ;
PREGSCRN ;
+1 GOTO PREGSCRN^BGP7D713
+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 V']""
QUIT
+6 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+7 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+8 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+9 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),".")
+10 QUIT
End DoDot:1
+11 IF G=0
QUIT ""
+12 QUIT "ADA 1320"_U_$PIECE(G,U,2)
PED(P,BDATE,EDATE) ;EP
+1 NEW BGPG,S,SN,Y,E,X,D,T
+2 KILL BGPG
+3 SET Y="BGPG("
+4 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 IF '$DATA(BGPG)
QUIT ""
+6 SET SN=$ORDER(^BGPSNOMG("B","TOBACCO SCREEN PATIENT ED",0))
+7 SET (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+8 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPG(X),U,4),0),U)
+9 IF 'T
QUIT
+10 IF '$DATA(^AUTTEDT(T,0))
QUIT
+11 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+12 IF $PIECE(T,"-")="TO"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+13 IF $PIECE(T,"-",2)="TO"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+14 IF $PIECE(T,"-",2)="SHS"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+15 SET S=$PIECE(T,"-",1)
+16 SET S=$$ICDDX^BGP7UTL2(S)
+17 IF $PIECE(S,U,1)'="-1"
IF $$ICD^BGP7UTL2($PIECE(S,U,1),$ORDER(^ATXAX("B","BGP TOBACCO DXS",0)),9)
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+18 IF $PIECE(T,"-")="D1320"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+19 IF $PIECE(T,"-")="99406"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+20 IF $PIECE(T,"-")="99407"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+21 IF $PIECE(T,"-")="G0375"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+22 IF $PIECE(T,"-")="G0376"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+23 IF $PIECE(T,"-")="1034F"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+24 IF $PIECE(T,"-")="1035F"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+25 IF $PIECE(T,"-")="1036F"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+26 IF $PIECE(T,"-")="1000F"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+27 IF $PIECE(T,"-")="G8455"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+28 IF $PIECE(T,"-")="G8456"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+29 IF $PIECE(T,"-")="G8457"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+30 IF $PIECE(T,"-")="G8402"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+31 IF $PIECE(T,"-")="G8453"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+32 IF $PIECE(T,"-")="G9276"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+33 IF $PIECE(T,"-")="G9275"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+34 IF $PIECE(T,"-")]""
IF $DATA(^BGPSNOMG(SN,11,"B",$PIECE(T,"-")))
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
End DoDot:1
+35 QUIT %
PREG(P,BDATE,EDATE,NORXCHR,NORX,FORM,CPBD,CPED) ;EP
+1 GOTO PREG^BGP7D714
+2 ;
DX(P,BDATE,EDATE) ;EP - WAS THERE SCREENING?
+1 KILL BGPG
+2 SET BGPG(1)=$$LASTDX^BGP7UTL1(P,"BGP TOBACCO DXS",BDATE,EDATE)
+3 IF BGPG(1)]""
QUIT $PIECE($$ICDDX^BGP7UTL2($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 TOBACCO 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)="I"
QUIT
+7 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+8 IF $PIECE(^AUPNPROB(X,0),U,3)>EDATE
QUIT
+9 IF $PIECE(^AUPNPROB(X,0),U,3)<BDATE
QUIT
+10 SET Y=$PIECE(^AUPNPROB(X,0),U)
+11 IF '$$ICD^BGP7UTL2(Y,T,9)
QUIT
+12 SET G=$PIECE($$ICDDX^BGP7UTL2(Y),U,2)_U_$PIECE(^AUPNPROB(X,0),U,3)_U_Y
+13 QUIT
End DoDot:1
+14 IF G]""
QUIT G
+15 SET G=$$IPLSNOID^BGP7DU(P,"PXRM BGP TOBACCO SCREENED",BDATE,EDATE)
IF G
SET G=$PIECE(G,U,2)_U_$PIECE(G,U,3)
QUIT G
+16 QUIT G
DXSL(P,BDATE,EDATE) ;EP - WAS THERE A SMOKELESS USER DX?
+1 KILL BGPG
+2 SET BGPG(1)=$$LASTDX^BGP7UTL1(P,"BGP GPRA SMOKELESS DXS",BDATE,EDATE)
+3 IF BGPG(1)]""
QUIT $PIECE($$ICDDX^BGP7UTL2($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 SMOKELESS 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)="I"
QUIT
+7 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+8 IF $PIECE(^AUPNPROB(X,0),U,3)>EDATE
QUIT
+9 IF $PIECE(^AUPNPROB(X,0),U,3)<BDATE
QUIT
+10 SET Y=$PIECE(^AUPNPROB(X,0),U)
+11 IF '$$ICD^BGP7UTL2(Y,T,9)
QUIT
+12 SET G=$PIECE($$ICDDX^BGP7UTL2(Y),U,2)_U_$PIECE(^AUPNPROB(X,0),U,3)_U_Y
+13 QUIT
End DoDot:1
+14 IF G]""
QUIT G
+15 SET G=$$IPLSNOID^BGP7DU(P,"PXRM BGP TOBACCO SMOKELESS",BDATE,EDATE)
IF G
SET G=$PIECE(G,U,2)_U_$PIECE(G,U,3)
QUIT G
+16 QUIT G
+17 ;
DXU(P,BDATE,EDATE) ;EP - WAS THERE A USER DX?
+1 KILL BGPG
+2 SET BGPG(1)=$$LASTDX^BGP7UTL1(P,"BGP TOBACCO USER DXS",BDATE,EDATE)
+3 IF BGPG(1)]""
QUIT $PIECE($$ICDDX^BGP7UTL2($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 TOBACCO USER 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)="I"
QUIT
+7 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+8 IF $PIECE(^AUPNPROB(X,0),U,3)>EDATE
QUIT
+9 IF $PIECE(^AUPNPROB(X,0),U,3)<BDATE
QUIT
+10 SET Y=$PIECE(^AUPNPROB(X,0),U)
+11 IF '$$ICD^BGP7UTL2(Y,T,9)
QUIT
+12 SET G=$PIECE($$ICDDX^BGP7UTL2(Y),U,2)_U_$PIECE(^AUPNPROB(X,0),U,3)_U_Y
+13 QUIT
End DoDot:1
+14 IF G]""
QUIT G
+15 SET G=$$IPLSNOID^BGP7DU(P,"PXRM BGP CURRENT TOBACCO",BDATE,EDATE)
IF G
SET G=$PIECE(G,U,2)_U_$PIECE(G,U,3)
QUIT G
+16 QUIT G
DXS(P,BDATE,EDATE) ;EP - WAS THERE A SMOKING USER DX?
+1 KILL BGPG
+2 SET BGPG(1)=$$LASTDX^BGP7UTL1(P,"BGP GPRA SMOKING DXS",BDATE,EDATE)
+3 IF BGPG(1)]""
QUIT $PIECE($$ICDDX^BGP7UTL2($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)="I"
QUIT
+7 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+8 IF $PIECE(^AUPNPROB(X,0),U,3)>EDATE
QUIT
+9 IF $PIECE(^AUPNPROB(X,0),U,3)<BDATE
QUIT
+10 SET Y=$PIECE(^AUPNPROB(X,0),U)
+11 IF '$$ICD^BGP7UTL2(Y,T,9)
QUIT
+12 SET G=$PIECE($$ICDDX^BGP7UTL2(Y),U,2)_U_$PIECE(^AUPNPROB(X,0),U,3)_U_Y
+13 QUIT
End DoDot:1
+14 IF G]""
QUIT G
+15 SET G=$$IPLSNOID^BGP7DU(P,"PXRM BGP TOBACCO SMOKER",BDATE,EDATE)
IF G
SET G=$PIECE(G,U,2)_U_$PIECE(G,U,3)
QUIT G
+16 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^BGP7UTL(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^BGP7UTL(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^BGP7DU(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 ""
