BGP0D7 ; IHS/CMI/LAB - measure 31 ;
;;10.0;IHS CLINICAL REPORTING;**1**;JUN 18, 2010
I18 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPXPTD,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,BGPBDATE,BGPEDATE)
S BGPSDX=$$DX(DFN,BGPBDATE,BGPEDATE)
S BGPXPTD=$$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 BGPXPTD]"" 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=$P(BGPTOB,U)
S %=""
I BGPSDX]"",$P(BGPSDX,U,1)="305.13" S %=1
I BGPSDX]"",$P(BGPSDX,U,1)="V15.82" S %=1
;BGPN2 - USER
D
.I F["CURRENT"!(F["CESSATION") S BGPN2=1,BGPVAL=$P(BGPTOB,U,2)_" SCREEN, USER" Q
.I (BGPSDX]""&(%="")) S BGPN2=1,BGPVAL=$$DATE^BGP0UTL($P(BGPSDX,U,2))_" SCREEN, 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^BGP0UTL($P(BGPSCPT,U,2))_" SCREEN, 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^BGP0UTL($P(BGPSCPT,U,2))_" SCREEN, USER" Q
;BGPN3 - SMOKER OR NOT
D
.I F["CURRENT SMOKER"!(F="CESSATION-SMOKER") S BGPN3=1,BGPVAL=BGPVAL_", SMOKER" Q
.I BGPSDX]""&(%="") S BGPN3=1,BGPVAL=BGPVAL_", 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") S BGPN3=1,BGPVAL=BGPVAL_", SMOKER" Q
;BGPN4 - SMOKELESS
D
.I F="CURRENT SMOKELESS"!(F="CURRENT SMOKER & SMOKELESS")!(F="CESSATION-SMOKELESS") S BGPN4=1,BGPVAL=BGPVAL_", SMOKELESS" Q
.I $P(BGPSCPT,U)="1035F"!($P(BGPSCPT,U)="G8456") S BGPN4=1,BGPVAL=BGPVAL_", SMOKELESS" Q
;BGPN5 - ETS
I F="SMOKER IN HOME"!(F["ENVIRON") S BGPN5=1,BGPVAL=$S(BGPVAL["SCREEN":BGPVAL_", ETS",1:$P(BGPTOB,U,2)_"SCREEN, ETS")
I BGPN1,BGPVAL="" D
.I BGPTOB]"" S BGPVAL=$P(BGPTOB,U,2)_" SCREEN" Q
.I BGPSDX]"" S BGPVAL=$$DATE^BGP0UTL($P(BGPSDX,U,2))_" SCREEN" Q
.I BGPSCPT]"" S BGPVAL=$$DATE^BGP0UTL($P(BGPSCPT,U,2))_" SCREEN" Q
.I BGPXPTD]"" S BGPVAL=$$DATE^BGP0UTL($P(BGPXPTD,U,2))_" SCREEN" Q
.I BGP1320]"" S BGPVAL=$$DATE^BGP0UTL($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,BGPXPTD,BGP1320,BGP20M
K ^TMP($J,"A")
Q
;
PREGSCRN ;
S BGPTOB=$$TOBACCO(DFN,BGP20M,BGPEDATE)
S BGPSDX=$$DX(DFN,BGP20M,BGPEDATE)
S BGPXPTD=$$PED(DFN,BGP20M,BGPEDATE)
S BGP1320=$$DENT(DFN,BGP20M,BGPEDATE)
S BGPSCPT=$$CPTSM(DFN,BGP20M,BGPEDATE)
S BGPN6=$S(BGPTOB]"":1,1:0)
I BGPSDX]"" S BGPN6=1
I BGPXPTD]"" S BGPN6=1
I BGP1320]"" S BGPN6=1
I BGPSCPT]"" S BGPN6=1
S (BGPVALUE,BGPVAL)=""
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
;BGPN7 - USER
D
.I F["CURRENT"!(F["CESSATION") S BGPN7=1,BGPVAL=$P(BGPTOB,U,2)_" SCREEN, USER" Q
.I (BGPSDX]""&(%="")) S BGPN7=1,BGPVAL=$$DATE^BGP0UTL($P(BGPSDX,U,2))_" SCREEN, USER" Q
.I ($P(BGPSCPT,U)="1034F")!($P(BGPSCPT,U)="1035F")!($P(BGPSCPT,U)="G0376")!($P(BGPSCPT,U)="G0375")!($P(BGPSCPT,U)=99407) S BGPN7=1,BGPVAL=$$DATE^BGP0UTL($P(BGPSCPT,U,2))_" SCREEN, USER" Q
.I $P(BGPSCPT,U)=99406!($P(BGPSCPT,U)="G8455")!($P(BGPSCPT,U)="G8456")!($P(BGPSCPT,U)="G8402")!($P(BGPSCPT,U)="G8453") S BGPN7=1,BGPVAL=$$DATE^BGP0UTL($P(BGPSCPT,U,2))_" SCREEN, USER" Q
;BGPN8 - SMOKER OR NOT
D
.I F["CURRENT SMOKER"!(F="CESSATION-SMOKER") S BGPN8=1,BGPVAL=BGPVAL_", SMOKER" Q
.I BGPSDX]""&(%="") S BGPN8=1,BGPVAL=BGPVAL_", 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") S BGPN8=1,BGPVAL=BGPVAL_", SMOKER" Q
;BGPN9 - SMOKELESS
D
.I F="CURRENT SMOKELESS"!(F="CURRENT SMOKER & SMOKELESS")!(F="CESSATION-SMOKELESS") S BGPN9=1,BGPVAL=BGPVAL_", SMOKELESS" Q
.I $P(BGPSCPT,U)="1035F"!($P(BGPSCPT,U)="G8456") S BGPN9=1,BGPVAL=BGPVAL_", SMOKELESS" Q
;BGPN5 - ETS
I F="SMOKER IN HOME"!(F["ENVIRON") S BGPN10=1,BGPVAL=BGPVAL_$S(BGPVAL["SCREEN":BGPVAL_", ETS",1:$P(BGPTOB,U,2)_" SCREEN, ETS")
S V=$S(BGPD1:"UP",1:"")_$S(BGPACTCL:",AC",1:"")_$S(BGPD8:",PREG",1:"")
I BGPN1,BGPVAL="" D
.I BGPTOB]"" S BGPVAL=$P(BGPTOB,U,2)_" SCREEN" Q
.I BGPSDX]"" S BGPVAL=$$DATE^BGP0UTL($P(BGPSDX,U,2))_" SCREEN" Q
.I BGPSCPT]"" S BGPVAL=$$DATE^BGP0UTL($P(BGPSCPT,U,2))_" SCREEN" Q
.I BGPXPTD]"" S BGPVAL=$$DATE^BGP0UTL($P(BGPXPTD,U,2))_" SCREEN" Q
.I BGP1320]"" S BGPVAL=$$DATE^BGP0UTL($P(BGP1320,U,2))_" SCREEN" Q
S V=$S(BGPD1:"UP",1:"")_$S(BGPACTCL:",AC",1:"")_$S(BGPD8:",PREG",1:"")
S BGPVALUE=V_"|||"_BGPVAL
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^BGP0UTL1(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^BGP0DU(P,BGPD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
S %=$$CPT^BGP0DU(P,BGPD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
S %=$$TRAN^BGP0DU(P,BGPD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
S %=$$TRAN^BGP0DU(P,BGPD,EDATE,T,3)
I %]"" Q 0
Q 1
DX(P,BDATE,EDATE) ;EP
K BGPG
S BGPG(1)=$$LASTDX^BGP0UTL1(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^BGP0UTL(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^BGP0UTL(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^BGP0DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP TOBACCO SCREEN CPTS",0)),5)
I X]"" Q $P(X,U,2)_U_$P(X,U,1)
;S X=$$CPTI^BGP0DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("1034F"))
;I X Q "1034F"_U_$P(X,U,2)
;S X=$$CPTI^BGP0DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("1035F"))
;I X Q "1035F"_U_$P(X,U,2)
;S X=$$CPTI^BGP0DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("1036F"))
;I X Q "1036F"_U_$P(X,U,2)
Q ""
BGP0D7 ; IHS/CMI/LAB - measure 31 ;
+1 ;;10.0;IHS CLINICAL REPORTING;**1**;JUN 18, 2010
I18 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPXPTD,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,BGPBDATE,BGPEDATE)
+2 SET BGPSDX=$$DX(DFN,BGPBDATE,BGPEDATE)
+3 SET BGPXPTD=$$PED(DFN,BGPBDATE,BGPEDATE)
+4 SET BGP1320=$$DENT(DFN,BGPBDATE,BGPEDATE)
+5 SET BGPSCPT=$$CPTSM(DFN,BGPBDATE,BGPEDATE)
+6 SET BGPN1=$SELECT(BGPTOB]"":1,1:0)
+7 IF BGPSDX]""
SET BGPN1=1
+8 IF BGPXPTD]""
SET BGPN1=1
+9 IF BGP1320]""
SET BGPN1=1
+10 IF BGPSCPT]""
SET BGPN1=1
+11 SET (BGPVALUE,BGPVAL)=""
+12 ;not screened so don't bother with other numerators
IF 'BGPN1
GOTO TAEND
+13 SET F=$PIECE(BGPTOB,U)
+14 SET %=""
+15 IF BGPSDX]""
IF $PIECE(BGPSDX,U,1)="305.13"
SET %=1
+16 IF BGPSDX]""
IF $PIECE(BGPSDX,U,1)="V15.82"
SET %=1
+17 ;BGPN2 - USER
+18 Begin DoDot:1
+19 IF F["CURRENT"!(F["CESSATION")
SET BGPN2=1
SET BGPVAL=$PIECE(BGPTOB,U,2)_" SCREEN, USER"
QUIT
+20 IF (BGPSDX]""&(%=""))
SET BGPN2=1
SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGPSDX,U,2))_" SCREEN, USER"
QUIT
+21 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^BGP0UTL($PIECE(BGPSCPT,U,2))_" SCREEN, USER"
QUIT
+22 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^BGP0UTL($PIECE(BGPSCPT,U,2))_" SCREEN, USER"
QUIT
End DoDot:1
+23 ;BGPN3 - SMOKER OR NOT
+24 Begin DoDot:1
+25 IF F["CURRENT SMOKER"!(F="CESSATION-SMOKER")
SET BGPN3=1
SET BGPVAL=BGPVAL_", SMOKER"
QUIT
+26 IF BGPSDX]""&(%="")
SET BGPN3=1
SET BGPVAL=BGPVAL_", SMOKER"
QUIT
+27 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")
SET BGPN3=1
SET BGPVAL=BGPVAL_", SMOKER"
QUIT
End DoDot:1
+28 ;BGPN4 - SMOKELESS
+29 Begin DoDot:1
+30 IF F="CURRENT SMOKELESS"!(F="CURRENT SMOKER & SMOKELESS")!(F="CESSATION-SMOKELESS")
SET BGPN4=1
SET BGPVAL=BGPVAL_", SMOKELESS"
QUIT
+31 IF $PIECE(BGPSCPT,U)="1035F"!($PIECE(BGPSCPT,U)="G8456")
SET BGPN4=1
SET BGPVAL=BGPVAL_", SMOKELESS"
QUIT
End DoDot:1
+32 ;BGPN5 - ETS
+33 IF F="SMOKER IN HOME"!(F["ENVIRON")
SET BGPN5=1
SET BGPVAL=$SELECT(BGPVAL["SCREEN":BGPVAL_", ETS",1:$PIECE(BGPTOB,U,2)_"SCREEN, ETS")
+34 IF BGPN1
IF BGPVAL=""
Begin DoDot:1
+35 IF BGPTOB]""
SET BGPVAL=$PIECE(BGPTOB,U,2)_" SCREEN"
QUIT
+36 IF BGPSDX]""
SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGPSDX,U,2))_" SCREEN"
QUIT
+37 IF BGPSCPT]""
SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGPSCPT,U,2))_" SCREEN"
QUIT
+38 IF BGPXPTD]""
SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGPXPTD,U,2))_" SCREEN"
QUIT
+39 IF BGP1320]""
SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGP1320,U,2))_" SCREEN"
QUIT
End DoDot:1
+40 SET V=$SELECT(BGPD1:"UP",1:"")_$SELECT(BGPACTCL:",AC",1:"")_$SELECT(BGPD8:",PREG",1:"")
+41 SET BGPVALUE=V_"|||"_BGPVAL
+42 ;
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,BGPXPTD,BGP1320,BGP20M
+5 KILL ^TMP($JOB,"A")
+6 QUIT
+7 ;
PREGSCRN ;
+1 SET BGPTOB=$$TOBACCO(DFN,BGP20M,BGPEDATE)
+2 SET BGPSDX=$$DX(DFN,BGP20M,BGPEDATE)
+3 SET BGPXPTD=$$PED(DFN,BGP20M,BGPEDATE)
+4 SET BGP1320=$$DENT(DFN,BGP20M,BGPEDATE)
+5 SET BGPSCPT=$$CPTSM(DFN,BGP20M,BGPEDATE)
+6 SET BGPN6=$SELECT(BGPTOB]"":1,1:0)
+7 IF BGPSDX]""
SET BGPN6=1
+8 IF BGPXPTD]""
SET BGPN6=1
+9 IF BGP1320]""
SET BGPN6=1
+10 IF BGPSCPT]""
SET BGPN6=1
+11 SET (BGPVALUE,BGPVAL)=""
+12 SET F=$PIECE(BGPTOB,U)
+13 SET %=""
+14 IF BGPSDX]""
IF $PIECE(BGPSDX,U,1)="305.13"
SET %=1
+15 IF BGPSDX]""
IF $PIECE(BGPSDX,U,1)="V15.82"
SET %=1
+16 ;BGPN7 - USER
+17 Begin DoDot:1
+18 IF F["CURRENT"!(F["CESSATION")
SET BGPN7=1
SET BGPVAL=$PIECE(BGPTOB,U,2)_" SCREEN, USER"
QUIT
+19 IF (BGPSDX]""&(%=""))
SET BGPN7=1
SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGPSDX,U,2))_" SCREEN, USER"
QUIT
+20 IF ($PIECE(BGPSCPT,U)="1034F")!($PIECE(BGPSCPT,U)="1035F")!($PIECE(BGPSCPT,U)="G0376")!($PIECE(BGPSCPT,U)="G0375")!($PIECE(BGPSCPT,U)=99407)
SET BGPN7=1
SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGPSCPT,U,2))_" SCREEN, USER"
QUIT
+21 IF $PIECE(BGPSCPT,U)=99406!($PIECE(BGPSCPT,U)="G8455")!($PIECE(BGPSCPT,U)="G8456")!($PIECE(BGPSCPT,U)="G8402")!($PIECE(BGPSCPT,U)="G8453")
SET BGPN7=1
SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGPSCPT,U,2))_" SCREEN, USER"
QUIT
End DoDot:1
+22 ;BGPN8 - SMOKER OR NOT
+23 Begin DoDot:1
+24 IF F["CURRENT SMOKER"!(F="CESSATION-SMOKER")
SET BGPN8=1
SET BGPVAL=BGPVAL_", SMOKER"
QUIT
+25 IF BGPSDX]""&(%="")
SET BGPN8=1
SET BGPVAL=BGPVAL_", SMOKER"
QUIT
+26 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")
SET BGPN8=1
SET BGPVAL=BGPVAL_", SMOKER"
QUIT
End DoDot:1
+27 ;BGPN9 - SMOKELESS
+28 Begin DoDot:1
+29 IF F="CURRENT SMOKELESS"!(F="CURRENT SMOKER & SMOKELESS")!(F="CESSATION-SMOKELESS")
SET BGPN9=1
SET BGPVAL=BGPVAL_", SMOKELESS"
QUIT
+30 IF $PIECE(BGPSCPT,U)="1035F"!($PIECE(BGPSCPT,U)="G8456")
SET BGPN9=1
SET BGPVAL=BGPVAL_", SMOKELESS"
QUIT
End DoDot:1
+31 ;BGPN5 - ETS
+32 IF F="SMOKER IN HOME"!(F["ENVIRON")
SET BGPN10=1
SET BGPVAL=BGPVAL_$SELECT(BGPVAL["SCREEN":BGPVAL_", ETS",1:$PIECE(BGPTOB,U,2)_" SCREEN, ETS")
+33 SET V=$SELECT(BGPD1:"UP",1:"")_$SELECT(BGPACTCL:",AC",1:"")_$SELECT(BGPD8:",PREG",1:"")
+34 IF BGPN1
IF BGPVAL=""
Begin DoDot:1
+35 IF BGPTOB]""
SET BGPVAL=$PIECE(BGPTOB,U,2)_" SCREEN"
QUIT
+36 IF BGPSDX]""
SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGPSDX,U,2))_" SCREEN"
QUIT
+37 IF BGPSCPT]""
SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGPSCPT,U,2))_" SCREEN"
QUIT
+38 IF BGPXPTD]""
SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGPXPTD,U,2))_" SCREEN"
QUIT
+39 IF BGP1320]""
SET BGPVAL=$$DATE^BGP0UTL($PIECE(BGP1320,U,2))_" SCREEN"
QUIT
End DoDot:1
+40 SET V=$SELECT(BGPD1:"UP",1:"")_$SELECT(BGPACTCL:",AC",1:"")_$SELECT(BGPD8:",PREG",1:"")
+41 SET BGPVALUE=V_"|||"_BGPVAL
+42 QUIT
+43 ;
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^BGP0UTL1(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^BGP0DU(P,BGPD,EDATE,T,3)
+19 IF %]""
QUIT 0
+20 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+21 SET %=$$CPT^BGP0DU(P,BGPD,EDATE,T,3)
+22 IF %]""
QUIT 0
+23 SET T=$ORDER(^ATXAX("B","BGP CPT ABORTION",0))
+24 SET %=$$TRAN^BGP0DU(P,BGPD,EDATE,T,3)
+25 IF %]""
QUIT 0
+26 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+27 SET %=$$TRAN^BGP0DU(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^BGP0UTL1(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^BGP0UTL(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^BGP0UTL(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^BGP0DU(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 ;S X=$$CPTI^BGP0DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("1034F"))
+5 ;I X Q "1034F"_U_$P(X,U,2)
+6 ;S X=$$CPTI^BGP0DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("1035F"))
+7 ;I X Q "1035F"_U_$P(X,U,2)
+8 ;S X=$$CPTI^BGP0DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("1036F"))
+9 ;I X Q "1036F"_U_$P(X,U,2)
+10 QUIT ""
