BGP9D7 ; IHS/CMI/LAB - measure 31 ;
;;9.0;IHS CLINICAL REPORTING;**1**;JUL 01, 2009
;
I18 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPXPND,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,(-(30*20))),BGPEDATE) S BGPD8=1
I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8) S BGPSTOP=1 Q
S BGP20M=$$FMADD^XLFDT(BGPEDATE,-600)
TA ;EP - called from elder
S BGPTOB=$$TOBACCO(DFN,$S(BGPD8:BGP20M,1:BGP365),BGPEDATE)
S BGPN1=$S(BGPTOB]"":1,1:0)
S BGPSDX=$$DX(DFN,$S(BGPD8:BGP20M,1:BGP365),BGPEDATE)
S BGPXPND=$$PED(DFN,$S(BGPD8:BGP20M,1:BGP365),BGPEDATE)
S BGP1320=$$DENT(DFN,$S(BGPD8:BGP20M,1:BGP365),BGPEDATE)
S BGPSCPT=$$CPTSM(DFN,$S(BGPD8:BGP20M,1:BGP365),BGPEDATE)
I BGPSDX]"" S BGPN1=1
I BGPXPND]"" S BGPN1=1
I BGP1320]"" S BGPN1=1
I BGPSCPT]"" S BGPN1=1
S F=$P(BGPTOB,U)
S %=""
I BGPSDX]"",$P(BGPSDX,U,1)="305.13" S %=1
I BGPSDX]"",$P(BGPSDX,U,1)="V15.82" S %=1
I F["CURRENT"!(BGPSDX]""&(%=""))!(F["CESSATION")!($P(BGPSCPT,U)="1034F")!($P(BGPSCPT,U)="1035F")!($P(BGPSCPT,U)="G0376")!($P(BGPSCPT,U)="G0375")!($P(BGPSCPT,U)=99407)!($P(BGPSCPT,U)=99406) S BGPN2=1
I F="CURRENT SMOKELESS"!(F="CURRENT SMOKER & SMOKELESS")!(F="CESSATION-SMOKELESS")!($P(BGPSCPT,U)="1035F") S BGPN4=1
I 'BGPN4,F["CURRENT SMOKER"!(BGPSDX]""&(%=""))!(F="CESSATION-SMOKER")!($P(BGPSCPT,U)="1034F")!($P(BGPSCPT,U)="G0376")!($P(BGPSCPT,U)="G0375")!($P(BGPSCPT,U)=99407)!($P(BGPSCPT,U)=99406) S BGPN3=1
;I BGPN2,BGPXPND]"" S BGPN5=1
I F="SMOKER IN HOME"!(F["ENVIRON") S BGPN5=1
S V=$S(BGPD1:"UP",1:"")_$S(BGPACTCL:",AC",1:"")_$S(BGPD8:",PREG",1:"")
S V=V_"|||"
S S=$S(F="CURRENT SMOKER":"Cur Smk",F="CURRENT SMOKELESS":"Cur smkl",F["NON":"NTU",F="CURRENT SMOKER & SMOKELESS":"Cur smk/smkl",F["SMOKER IN HOME":"Smk Home",F["ENVIRON":"ETS",1:"")
I S="" S S=$S(F="CESSATION-SMOKER":"Cess Smk",F["CESSATION-SMOKELESS":"Cess smkl",1:"")
I S="" S S=$S(F="PREVIOUS SMOKER":"Prev smk",F="PREVIOUS SMOKELESS":"Prev smkl",F["PREVIOUS":"Prev smk/smkl",F="SMOKE FREE HOME":"Smk free home",1:"")
I S="" S S=F
I S]"" S S="HF "_S_" "_$P(BGPTOB,U,2)
I BGP1320]"" S S=S_" 1320 ADA "_$$DATE^BGP9UTL($P(BGP1320,U,2))
I BGPSDX]"" S S=S_" DX "_$S($P(BGPSDX,U,1)="305.13":"quit",$P(BGPSDX,U,1)="V15.82":"V15.82",1:"Cur smk")_" "_$$DATE^BGP9UTL($P(BGPSDX,U,2))
I BGPXPND]"" S S=S_" PtEd "_$P(BGPXPND,U)_" "_$$DATE^BGP9UTL($P(BGPXPND,U,2))
I BGPSCPT]"" S S=S_" CPT "_$P(BGPSCPT,U)_" "_$$DATE^BGP9UTL($P(BGPSCPT,U,2))
S BGPVALUE=V_" "_S
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,BGPSDX,BGPXPND,BGP1320,BGP20M
K ^TMP($J,"A")
Q
;
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
.I $P(T,"-")="305.1" S %=T_U_$P(BGPG(X),U) Q
.I $P(T,"-")="305.10" S %=T_U_$P(BGPG(X),U) Q
.I $P(T,"-")="305.11" S %=T_U_$P(BGPG(X),U) Q
.I $P(T,"-")="305.12" S %=T_U_$P(BGPG(X),U) Q
.I $P(T,"-")="305.13" S %=T_U_$P(BGPG(X),U) Q
.I $P(T,"-")="649.00" S %=T_U_$P(BGPG(X),U) Q
.I $P(T,"-")="649.01" S %=T_U_$P(BGPG(X),U) Q
.I $P(T,"-")="649.02" S %=T_U_$P(BGPG(X),U) Q
.I $P(T,"-")="649.03" S %=T_U_$P(BGPG(X),U) Q
.I $P(T,"-")="649.04" S %=T_U_$P(BGPG(X),U) Q
.I $P(T,"-")="V15.82" S %=T_U_$P(BGPG(X),U) Q
Q %
PREG(P,BDATE,EDATE,NORXCHR) ;EP
NEW BGPDX,B,CNT,BGPD,BGPG
S B=0,CNT=0,BGPD="" ;if there is one before time frame set this to 1
S NORXCHR=$G(NORXCHR)
K BGPG
S Y="BGPG("
S X=P_"^ALL DX [BGP GPRA PREGNANCY DIAGNOSES;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
.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^BGP9UTL1(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^BGP9DU(P,BGPD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
S %=$$CPT^BGP9DU(P,BGPD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
S %=$$TRAN^BGP9DU(P,BGPD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
S %=$$TRAN^BGP9DU(P,BGPD,EDATE,T,3)
I %]"" Q 0
Q 1
DX(P,BDATE,EDATE) ;EP
K BGPG
S BGPG(1)=$$LASTDX^BGP9UTL1(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)
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)_" PL"_U_$P(^AUPNPROB(X,0),U,3)
.Q
Q G
TOBACCO(P,BDATE,EDATE) ;EP
K BGPTOB,BGP
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",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^BGP9UTL(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^BGP9UTL(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 smoking cpt?
NEW X
S X=$$CPT^BGP9DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP SMOKING CPTS",0)),5)
I X]"" Q $P(X,U,2)_U_$P(X,U,1)
;S X=$$CPTI^BGP9DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("1034F"))
;I X Q "1034F"_U_$P(X,U,2)
;S X=$$CPTI^BGP9DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("1035F"))
;I X Q "1035F"_U_$P(X,U,2)
;S X=$$CPTI^BGP9DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("1036F"))
;I X Q "1036F"_U_$P(X,U,2)
Q ""
BGP9D7 ; IHS/CMI/LAB - measure 31 ;
+1 ;;9.0;IHS CLINICAL REPORTING;**1**;JUL 01, 2009
+2 ;
I18 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPXPND,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,(-(30*20))),BGPEDATE)
SET BGPD8=1
+11 IF '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8)
SET BGPSTOP=1
QUIT
+12 SET BGP20M=$$FMADD^XLFDT(BGPEDATE,-600)
TA ;EP - called from elder
+1 SET BGPTOB=$$TOBACCO(DFN,$SELECT(BGPD8:BGP20M,1:BGP365),BGPEDATE)
+2 SET BGPN1=$SELECT(BGPTOB]"":1,1:0)
+3 SET BGPSDX=$$DX(DFN,$SELECT(BGPD8:BGP20M,1:BGP365),BGPEDATE)
+4 SET BGPXPND=$$PED(DFN,$SELECT(BGPD8:BGP20M,1:BGP365),BGPEDATE)
+5 SET BGP1320=$$DENT(DFN,$SELECT(BGPD8:BGP20M,1:BGP365),BGPEDATE)
+6 SET BGPSCPT=$$CPTSM(DFN,$SELECT(BGPD8:BGP20M,1:BGP365),BGPEDATE)
+7 IF BGPSDX]""
SET BGPN1=1
+8 IF BGPXPND]""
SET BGPN1=1
+9 IF BGP1320]""
SET BGPN1=1
+10 IF BGPSCPT]""
SET BGPN1=1
+11 SET F=$PIECE(BGPTOB,U)
+12 SET %=""
+13 IF BGPSDX]""
IF $PIECE(BGPSDX,U,1)="305.13"
SET %=1
+14 IF BGPSDX]""
IF $PIECE(BGPSDX,U,1)="V15.82"
SET %=1
+15 IF F["CURRENT"!(BGPSDX]""&(%=""))!(F["CESSATION")!($PIECE(BGPSCPT,U)="1034F")!($PIECE(BGPSCPT,U)="1035F")!($PIECE(BGPSCPT,U)="G0376")!($PIECE(BGPSCPT,U)="G0375")!($PIECE(BGPSCPT,U)=99407)!($PIECE(BGPSCPT,U)=99406)
SET BGPN2=1
+16 IF F="CURRENT SMOKELESS"!(F="CURRENT SMOKER & SMOKELESS")!(F="CESSATION-SMOKELESS")!($PIECE(BGPSCPT,U)="1035F")
SET BGPN4=1
+17 IF 'BGPN4
IF F["CURRENT SMOKER"!(BGPSDX]""&(%=""))!(F="CESSATION-SMOKER")!($PIECE(BGPSCPT,U)="1034F")!($PIECE(BGPSCPT,U)="G0376")!($PIECE(BGPSCPT,U)="G0375")!($PIECE(BGPSCPT,U)=99407)!($PIECE(BGPSCPT,U)=99406)
SET BGPN3=1
+18 ;I BGPN2,BGPXPND]"" S BGPN5=1
+19 IF F="SMOKER IN HOME"!(F["ENVIRON")
SET BGPN5=1
+20 SET V=$SELECT(BGPD1:"UP",1:"")_$SELECT(BGPACTCL:",AC",1:"")_$SELECT(BGPD8:",PREG",1:"")
+21 SET V=V_"|||"
+22 SET S=$SELECT(F="CURRENT SMOKER":"Cur Smk",F="CURRENT SMOKELESS":"Cur smkl",F["NON":"NTU",F="CURRENT SMOKER & SMOKELESS":"Cur smk/smkl",F["SMOKER IN HOME":"Smk Home",F["ENVIRON":"ETS",1:"")
+23 IF S=""
SET S=$SELECT(F="CESSATION-SMOKER":"Cess Smk",F["CESSATION-SMOKELESS":"Cess smkl",1:"")
+24 IF S=""
SET S=$SELECT(F="PREVIOUS SMOKER":"Prev smk",F="PREVIOUS SMOKELESS":"Prev smkl",F["PREVIOUS":"Prev smk/smkl",F="SMOKE FREE HOME":"Smk free home",1:"")
+25 IF S=""
SET S=F
+26 IF S]""
SET S="HF "_S_" "_$PIECE(BGPTOB,U,2)
+27 IF BGP1320]""
SET S=S_" 1320 ADA "_$$DATE^BGP9UTL($PIECE(BGP1320,U,2))
+28 IF BGPSDX]""
SET S=S_" DX "_$SELECT($PIECE(BGPSDX,U,1)="305.13":"quit",$PIECE(BGPSDX,U,1)="V15.82":"V15.82",1:"Cur smk")_" "_$$DATE^BGP9UTL($PIECE(BGPSDX,U,2))
+29 IF BGPXPND]""
SET S=S_" PtEd "_$PIECE(BGPXPND,U)_" "_$$DATE^BGP9UTL($PIECE(BGPXPND,U,2))
+30 IF BGPSCPT]""
SET S=S_" CPT "_$PIECE(BGPSCPT,U)_" "_$$DATE^BGP9UTL($PIECE(BGPSCPT,U,2))
+31 SET BGPVALUE=V_" "_S
+32 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,BGPSDX,BGPXPND,BGP1320,BGP20M
+33 KILL ^TMP($JOB,"A")
+34 QUIT
+35 ;
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 IF $PIECE(T,"-")="305.1"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+14 IF $PIECE(T,"-")="305.10"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+15 IF $PIECE(T,"-")="305.11"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+16 IF $PIECE(T,"-")="305.12"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+17 IF $PIECE(T,"-")="305.13"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+18 IF $PIECE(T,"-")="649.00"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+19 IF $PIECE(T,"-")="649.01"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+20 IF $PIECE(T,"-")="649.02"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+21 IF $PIECE(T,"-")="649.03"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+22 IF $PIECE(T,"-")="649.04"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+23 IF $PIECE(T,"-")="V15.82"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
End DoDot:1
+24 QUIT %
PREG(P,BDATE,EDATE,NORXCHR) ;EP
+1 NEW BGPDX,B,CNT,BGPD,BGPG
+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 KILL BGPG
+5 SET Y="BGPG("
+6 SET X=P_"^ALL DX [BGP GPRA PREGNANCY DIAGNOSES;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+7 ;now reorder by date of diagnosis and eliminate all chr and rx if necessary
+8 ;no diagnoses
IF '$DATA(BGPG)
GOTO PROB
+9 SET B=0
SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
Begin DoDot:1
+10 ;get date
+11 SET D=$PIECE(BGPG(X),U,1)
+12 SET C=$$CLINIC^APCLV($PIECE(BGPG(X),U,5),"C")
+13 IF NORXCHR
IF C=39
QUIT
+14 SET C=$$PRIMPROV^APCLV($PIECE(BGPG(X),U,5),"D")
+15 ;no chr as primary provider
IF NORXCHR
IF C=53
QUIT
+16 SET BGPDX(D)=""
SET CNT=CNT+1
IF CNT=2
SET BGPD=D
+17 IF D>$$FMADD^XLFDT(EDATE,-365)
SET B=1
+18 QUIT
End DoDot:1
+19 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^BGP9UTL1(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^BGP9DU(P,BGPD,EDATE,T,3)
+19 IF %]""
QUIT 0
+20 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+21 SET %=$$CPT^BGP9DU(P,BGPD,EDATE,T,3)
+22 IF %]""
QUIT 0
+23 SET T=$ORDER(^ATXAX("B","BGP CPT ABORTION",0))
+24 SET %=$$TRAN^BGP9DU(P,BGPD,EDATE,T,3)
+25 IF %]""
QUIT 0
+26 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+27 SET %=$$TRAN^BGP9DU(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^BGP9UTL1(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)
+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)_" PL"_U_$PIECE(^AUPNPROB(X,0),U,3)
+12 QUIT
End DoDot:1
+13 QUIT G
TOBACCO(P,BDATE,EDATE) ;EP
+1 KILL BGPTOB,BGP
+2 DO TOBACCO1
+3 IF BGPTOB]""
QUIT BGPTOB
+4 DO TOBACCO0
+5 IF $DATA(BGPTOB)
QUIT BGPTOB
+6 QUIT ""
TOBACCO1 ;check for tobacco documented in health factors
+1 KILL BGPTOB
SET BGPTOB=$$LASTHF(P,"TOBACCO",BDATE,EDATE)
KILL O,D,H
+2 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^BGP9UTL(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^BGP9UTL(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 smoking cpt?
+1 NEW X
+2 SET X=$$CPT^BGP9DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP SMOKING CPTS",0)),5)
+3 IF X]""
QUIT $PIECE(X,U,2)_U_$PIECE(X,U,1)
+4 ;S X=$$CPTI^BGP9DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("1034F"))
+5 ;I X Q "1034F"_U_$P(X,U,2)
+6 ;S X=$$CPTI^BGP9DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("1035F"))
+7 ;I X Q "1035F"_U_$P(X,U,2)
+8 ;S X=$$CPTI^BGP9DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("1036F"))
+9 ;I X Q "1036F"_U_$P(X,U,2)
+10 QUIT ""
