BGP0D5 ; IHS/CMI/LAB - measure calc ;
;;10.0;IHS CLINICAL REPORTING;**1**;JUN 18, 2010
;
I20 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
I 'BGPACTUP S BGPSTOP=1 Q
I BGPSEX'="F" S BGPSTOP=1 Q
I BGPAGEB<15 S BGPSTOP=1 Q
I BGPAGEB>44 S BGPSTOP=1 Q
I BGPACTUP S BGPD2=1
I BGPACTCL S BGPD1=1
S BGPN2=$$ALHF(DFN,BGP365,BGPEDATE)
S BGPN3=$$ALDX^BGP0D5A(DFN,BGP365,BGPEDATE)
I 'BGPN3 S BGPN3=$$ALPRC(DFN,BGP365,BGPEDATE)
S BGPN4=$$ALPED(DFN,BGP365,BGPEDATE)
S BGPN5=0
I BGPN2 S BGPN1=1
I BGPN3 S BGPN1=1
I BGPN4 S BGPN1=1
I 'BGPN1 S BGPN5=$$ALREF(DFN,BGP365,BGPEDATE)
I BGPN5 S BGPN1=1
I BGPN1,'BGPN5 S BGPN6=1
S BGPVALUE=$S(BGPD2:"UP",1:"")_";"_$S(BGPD1:"AC",1:"")_"|||"
I $P(BGPN2,U)=1 S BGPVALUE=BGPVALUE_$P(BGPN2,U,2)_" "_$P(BGPN2,U,3)
I $P(BGPN3,U)=1 S BGPVALUE=BGPVALUE_$P(BGPN3,U,2)_" "_$P(BGPN3,U,3)
I $P(BGPN4,U)=1 S BGPVALUE=BGPVALUE_$P(BGPN4,U,2)_" "_$P(BGPN4,U,3)
I $P(BGPN5,U)=1 S BGPVALUE=BGPVALUE_$P(BGPN5,U,2)_" "_$P(BGPN5,U,3)
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
Q
I21 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
S (BGPDVEX,BGPDVDX,BGPDVPED,BGPDVREF)=""
I 'BGPACTUP S BGPSTOP=1 Q
I BGPSEX'="F" S BGPSTOP=1 Q
I BGPAGEB<13 S BGPSTOP=1 Q
I BGPACTUP S BGPD3=1
I BGPACTCL S BGPD1=1
I BGPAGEB>14,BGPAGEB<41,BGPACTCL S BGPD2=1 ;gpra denominator 15-40
DV ;EP - called from elder care
S BGPDVEX=$$DVEX(DFN,BGP365,BGPEDATE) I $P(BGPDVEX,U)=1 S BGPN2=1 ;EXAM ONLY
S BGPDVDX=$$DVDX(DFN,BGP365,BGPEDATE) I $P(BGPDVDX,U)=1 S BGPN3=1 ;DX ONLY
S BGPDVPED=$$DVPED(DFN,BGP365,BGPEDATE) I $P(BGPDVPED,U)=1 S BGPN4=1,BGPN8=1 ;W/O V61.11
S BGPDVCOU=$$DV61(DFN,BGP365,BGPEDATE) I $P(BGPDVPED,U)=1 S BGPN4=1 ;include in education for gpra
I BGPN2 S BGPN1=1
I BGPN3 S BGPN1=1
I BGPN4 S BGPN1=1
I 'BGPN1 S BGPDVREF=$$REFDV(DFN,BGP365,BGPEDATE) I $P(BGPDVREF,U)=1 S BGPN5=1
I BGPN5 S BGPN1=1
I BGPN1,'BGPN5 S BGPN6=1 ;
I BGPN2!(BGPN3)!(BGPDVCOU) S BGPN7=1
S BGPVALUE=$S(BGPD3:"UP",1:"")_";"_$S(BGPD1:"AC",1:"")_"|||"
I $P(BGPDVEX,U)=1 S BGPVALUE=BGPVALUE_$P(BGPDVEX,U,3)_" "_$$DATE^BGP0UTL($P(BGPDVEX,U,2))
I $P(BGPDVDX,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":";",1:"")_$P(BGPDVDX,U,3)_" "_$$DATE^BGP0UTL($P(BGPDVDX,U,2))
I $P(BGPDVPED,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":";",1:"")_$P(BGPDVPED,U,3)_" "_$$DATE^BGP0UTL($P(BGPDVPED,U,2))
I $P(BGPDVCOU,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":";",1:"")_$P(BGPDVCOU,U,3)_" "_$$DATE^BGP0UTL($P(BGPDVCOU,U,2))
I $P(BGPDVREF,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":";",1:"")_$P(BGPDVREF,U,3)_" "_$$DATE^BGP0UTL($P(BGPDVREF,U,2))
S BGPVALUD="" I BGPD2 S BGPVALUD="AC15-40"_"|||" D
.I $P(BGPDVEX,U)=1 S BGPVALUD=BGPVALUD_$P(BGPDVEX,U,3)_" "_$$DATE^BGP0UTL($P(BGPDVEX,U,2))
.I $P(BGPDVDX,U)=1 S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":";",1:"")_$P(BGPDVDX,U,3)_" "_$$DATE^BGP0UTL($P(BGPDVDX,U,2))
.I $P(BGPDVPED,U)=1 S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":";",1:"")_$P(BGPDVPED,U,3)_" "_$$DATE^BGP0UTL($P(BGPDVPED,U,2))
.I $P(BGPDVCOU,U)=1 S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":";",1:"")_$P(BGPDVCOU,U,3)_" "_$$DATE^BGP0UTL($P(BGPDVCOU,U,2))
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
Q
;
DVEX(P,BDATE,EDATE) ;EP
S BGPLDV=""
K BGPG S %=P_"^LAST EXAM 34;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S BGPLDV=1_"^"_$P(BGPG(1),U)_"^IPV EXAM 34"_U_"Ex 34"_U_$$DATE^BGP0UTL($P(BGPG(1),U))
S BGPC=0,BGPV=""
S E=9999999-BDATE,D=9999999-EDATE-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC) D
.S X=$P($G(^AMHREC(V,14)),U)
.I X="" Q ;no test
.I $E(X)="U" Q ;don't count refusal here
.I X="REF" Q
.S BGPC=BGPC+1,BGPV="1^"_(9999999-D)_"^BH IPV EXAM"_U_" BH Ex 34"_U_$$DATE^BGP0UTL((9999999-D))
I $P(BGPLDV,U,2)<$P(BGPC,U,2) S BGPLDV=BGPC
Q BGPLDV
REFDV(P,BDATE,EDATE) ;EP
;add refusal for exam 34
S G=$$REFUSAL^BGP0UTL1(P,9999999.15,$O(^AUTTEXAM("C",34,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
I $P(G,U)=1 Q 1_"^"_$P(G,U,2)_"^ref exam 34"
S G=""
S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.09,X)) Q:X'=+X!(G) D
.S H=""
.I $P($P($G(^AUTTEDT(X,0)),U),"-")="DV"!($P($P($G(^AUTTEDT(X,0)),U),"-",2)="DV") S H=1
.Q:H'=1
.S D=0 F S D=$O(^AUPNPREF("AA",P,9999999.09,X,D)) Q:D'=+D D
..S Z=9999999-D
..Q:Z<BDATE
..Q:Z>EDATE
..S G=1_"^"_Z_"^ref PtEd "_$P(^AUTTEDT(X,0),U)
I $P(G,U,1)=1 Q G
S BGPC=0 K BGPV
S E=9999999-BDATE,D=9999999-EDATE-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC) D
.S X=$P($G(^AMHREC(V,14)),U)
.I X="" Q ;no test
.I X="U" S BGPC=1,BGPV=1_"^"_(9999999-D)_"^BH UTS" Q
.I X="REF" S BGPC=1,BGPV=1_"^"_(9999999-D)_"^BH REF" Q
.Q
I BGPC Q BGPV
Q ""
DVDX(P,BDATE,EDATE) ;EP
I $G(P)="" Q ""
G DVDX^BGP0D54
;
DVPED(P,BDATE,EDATE) ;EP
K BGPG
S Y="BGPG(",BGPLDV=""
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I '$D(BGPG(1)) G BHPED
K BGPV S (X,D,E)=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,"-",1)="DV"!($P(T,"-",2)="DV")!($P(T,"-")="995.80")!($P(T,"-")="995.81")!($P(T,"-")="995.82")!($P(T,"-")="995.83") S BGPLDV=1_"^"_$P(BGPG(X),U)_"^PED "_T_U_"PED "_T_U_$$DATE^BGP0UTL($P(BGPG(X),U)) Q
.I $P(T,"-",1)="995.85"!($P(T,"-")="V15.41")!($P(T,"-")="V15.42")!($P(T,"-")="V15.49") S BGPLDV=1_"^"_$P(BGPG(X),U)_"^PED "_T_U_"PED "_T_U_$$DATE^BGP0UTL($P(BGPG(X),U)) Q
BHPED ;
K BGPV S BGPC="",T="" S E=9999999-BDATE,D=9999999-EDATE-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC) D
.S X=0 F S X=$O(^AMHREDU("AD",V,X)) Q:X'=+X!(BGPC) S T=$P($G(^AMHREDU(X,0)),U) D
..Q:'T
..Q:'$D(^AUTTEDT(T,0))
..S T=$P(^AUTTEDT(T,0),U,2)
..I $P(T,"-")="DV"!($P(T,"-",2)="DV")!($P(T,"-")="995.80")!($P(T,"-")="995.81")!($P(T,"-")="995.82")!($P(T,"-")="995.83")!$P(T,"-",1)="995.85"!($P(T,"-")="V15.41")!($P(T,"-")="V15.42")!($P(T,"-")="V15.49"),$P(BGPLDV,U,2)<(9999999-$P(D,".")) D
...S BGPLDV=1_"^"_(9999999-$P(D,"."))_"^BH PED "_T_U_"BH PED "_T_U_$$DATE^BGP0UTL((9999999-$P(D,".")))
Q BGPLDV ;I BGPC Q BGPV
DV61(P,BDATE,EDATE) ;
NEW BGPLDV
S BGPLDV=""
K BGPG S X=P_"^LAST DX V61.11;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) S BGPLDV=1_"^"_$P(BGPG(1),U)_"^V61.11"_U_"POV V61.11"_U_$$DATE^BGP0UTL($P(BGPG(1),U))
Q BGPLDV
ALHF(P,BDATE,EDATE) ;EP - alcohol hf or screening pov
S BGPLAL=""
K BGPG S %=P_"^LAST EXAM 35;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S BGPLAL=1_"^Ex 35^"_$$DATE^BGP0UTL($P(BGPG(1),U))_U_$P(BGPG(1),U,1)
;S V=$$LASTHF(P,"ALCOHOL/DRUG",BDATE,EDATE)
;I V]"",$P(BGPLAL,U,4)<$P(V,U,3) S BGPLAL=1_U_"HF: "_V
;S V=$$LASTHF(P,"ALCOHOL",BDATE,EDATE)
;I V]"",$P(BGPLAL,U,4)<$P(V,U,3) S BGPLAL=1_U_"HF: "_V
;S V=$$LASTHF(P,"SBIRT",BDATE,EDATE)
;I V]"",$P(BGPLAL,U,4)<$P(V,U,3) S BGPLAL=1_U_"HF: "_V
;now add in v measurements
S BGPC=$$LASTITEM^BGP0DU(P,BDATE,EDATE,"MEASUREMENT","AUDT")
I $P(BGPLAL,U,4)<$P(BGPC,U,2) S BGPLAL=1_U_"MEAS: "_$P(BGPC,U,3)_U_$$DATE^BGP0UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)
S BGPC=$$LASTITEM^BGP0DU(P,BDATE,EDATE,"MEASUREMENT","AUDC")
I $P(BGPLAL,U,4)<$P(BGPC,U,2) S BGPLAL=1_U_"MEAS: "_$P(BGPC,U,3)_U_$$DATE^BGP0UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)
S BGPC=$$LASTITEM^BGP0DU(P,BDATE,EDATE,"MEASUREMENT","CRFT")
I $P(BGPLAL,U,4)<$P(BGPC,U,2) S BGPLAL=1_U_"MEAS: "_$P(BGPC,U,3)_U_$$DATE^BGP0UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)
;pcc health factor CAGE only in v10.0
K BGPG S %=P_"^LAST HEALTH CAGE 0/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S BGPLAL=1_"^HF: CAGE 0/4^"_$$DATE^BGP0UTL($P(BGPG(1),U))_U_$P(BGPG(1),U,1)
K BGPG S %=P_"^LAST HEALTH CAGE 1/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S BGPLAL=1_"^HF: CAGE 1/4^"_$$DATE^BGP0UTL($P(BGPG(1),U))_U_$P(BGPG(1),U,1)
K BGPG S %=P_"^LAST HEALTH CAGE 2/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S BGPLAL=1_"^HF: CAGE 2/4^"_$$DATE^BGP0UTL($P(BGPG(1),U))_U_$P(BGPG(1),U,1)
K BGPG S %=P_"^LAST HEALTH CAGE 3/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S BGPLAL=1_"^HF: CAGE 3/4^"_$$DATE^BGP0UTL($P(BGPG(1),U))_U_$P(BGPG(1),U,1)
K BGPG S %=P_"^LAST HEALTH CAGE 4/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S BGPLAL=1_"^HF: CAGE 4/4^"_$$DATE^BGP0UTL($P(BGPG(1),U))_U_$P(BGPG(1),U,1)
;CHECK BH HF FILE
S BGPC="",T="",F="" S E=9999999-BDATE,D=9999999-EDATE-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC) D
.S X=0 F S X=$O(^AMHRHF("AD",V,X)) Q:X'=+X!(BGPC) S F=$P($G(^AMHRHF(X,0)),U) D
..Q:'F
..Q:'$D(^AUTTHF(F,0))
..S T=$P(^AUTTHF(F,0),U,3)
..Q:'T
..I $P($G(^AUTTHF(F,0)),U)["CAGE " S BGPC=1_U_"BH HF: "_$P(^AUTTHF(F,0),U)_U_$$DATE^BGP0UTL((9999999-D))_U_(9999999-D)
..Q
.S X=0 F S X=$O(^AMHRMSR("AD",V,X)) Q:X'=+X!(BGPC) S F=$P($G(^AMHRMSR(X,0)),U) D
..Q:'F
..Q:'$D(^AUTTMSR(F,0))
..S T=$P(^AUTTMSR(F,0),U,1)
..I T="AUDT"!(T="AUDC")!(T="CRFT") S BGPC=1_U_"BH MSR: "_T_U_$$DATE^BGP0UTL((9999999-D))_U_(9999999-D)
I $P(BGPLAL,U,4)<$P(BGPC,U,4) S BGPLAL=BGPC
K BGPG S %=P_"^LAST DX V11.3;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)),$P(BGPLAL,U,4)<$P(BGPG(1),U,1) S BGPLAL=1_U_"DX: V11.3"_U_$$DATE^BGP0UTL($P(BGPG(1),U))_U_$P(BGPG(1),U,1)
K BGPG
S %=P_"^LAST DX V79.1;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)),$P(BGPLAL,U,4)<$P(BGPG(1),U,1) S BGPLAL=1_U_"DX: V79.1"_U_$$DATE^BGP0UTL($P(BGPG(1),U))_U_$P(BGPG(1),U,1)
;now add in CPT codes
S BGPC=$$CPT^BGP0DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0)),6)
I $P(BGPLAL,U,4)<$P(BGPC,U,2) S BGPLAL=1_U_"CPT: "_$P(BGPC,U,3)_U_$$DATE^BGP0UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)
;go through BH record file and find up to 1 visits in date range
S E=9999999-BDATE,D=9999999-EDATE-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC) D
.S X=$P($G(^AMHREC(V,14)),U)
.D
..I X="" Q ;no test
..I $E(X)="U" Q ;don't count refusal here
..I X="REF" Q
..S BGPC=1_U_"BH Alcohol scrn"_U_$$DATE^BGP0UTL((9999999-$P(D,".")))_U_(9999999-$P(D,"."))
.S X=0 F S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(BGPC) S BGPP=$P($G(^AMHRPRO(X,0)),U) D
..Q:'BGPP
..S BGPP=$P($G(^AMHPROB(BGPP,0)),U)
..I BGPP=29.1 S BGPC=1_U_"BH dx: 29.1"_U_$$DATE^BGP0UTL((9999999-$P(D,".")))_U_(9999999-$P(D,".")) Q
..Q
.S T=$O(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0))
.S X=0 F S X=$O(^AMHRPROC("AD",V,X)) Q:X'=+X!(BGPC) S F=$P($G(^AMHRPROC(X,0)),U) D
..Q:'F
..I '$$ICD^ATXCHK(T,$P(+$G(^AUPNVCPT(X,0)),U,1),1) Q
..S I=$$VAL^XBDIQ1(81,F,.01)
..S BGPC=1_U_"BH CPT: "_I_U_$$DATE^BGP0UTL((9999999-D))_U_(9999999-D)
I $P(BGPLAL,U,4)<$P(BGPC,U,4) S BGPLAL=BGPC
;
Q BGPLAL
ALPRC(P,BDATE,EDATE) ;EP
S BGPG=$$LASTPRC^BGP0UTL1(P,"BGP ALCOHOL PROCEDURES",BDATE,EDATE)
I BGPG Q 1_U_"PROC "_$P(BGPG,U,2)_U_$$DATE^BGP0UTL($P(BGPG,U,3))
Q ""
ALPED(P,BDATE,EDATE) ;EP
K BGPG
S Y="BGPG(",BGPLPED=""
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I '$D(BGPG(1)) G ALMH
S (X,D,E)=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,"-",1)="CD"!($P(T,"-",2)="CD")!($P(T,"-",1)="AOD")!($P(T,"-",2)="AOD"),$P(BGPLPED,U,4)<$P(BGPG(X),U) S BGPLPED=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)
.I $P(T,"-",1)="V11.3"!($P(T,"-",1)="V79.1")!($P(T,"-",1)["303.")!($P(T,"-",1)["305.0")!($P(T,"-")["291.")!($P(T,"-")["357.5"),$P(BGPLPED,U,4)<$P(BGPG(X),U) D
..S BGPLPED=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)
ALMH ;
S BGPC="",T="" S E=9999999-BDATE,D=9999999-EDATE-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC) D
.S X=0 F S X=$O(^AMHREDU("AD",V,X)) Q:X'=+X S T=$P($G(^AMHREDU(X,0)),U) D
..Q:'T
..Q:'$D(^AUTTEDT(T,0))
..S T=$P(^AUTTEDT(T,0),U,2)
..I $P(T,"-",1)="CD"!($P(T,"-",2)="CD")!($P(T,"-",1)="AOD")!($P(T,"-",2)="AOD"),$P(BGPLPED,U,4)<(9999999-D) S BGPLPED=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL((9999999-D))_U_(9999999-D)
..I $P(T,"-",1)="V11.3"!($P(T,"-",1)="V79.1")!($P(T,"-",1)["303.")!($P(T,"-",1)["305.0")!($P(T,"-")["291.")!($P(T,"-")["357.5"),$P(BGPLPED,U,4)<(9999999-D) D
...S BGPLPED=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL((9999999-D))_U_(9999999-D)
Q BGPLPED
;
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)_U_(9999999-D)
;
ALREF(P,BDATE,EDATE) ;EP
;add refusal for exam 35
S G=$$REFUSAL^BGP0UTL1(P,9999999.15,$O(^AUTTEXAM("C",35,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
I $P(G,U)=1 Q 1_"^ref exam 35^"_$$DATE^BGP0UTL($P(G,U,2))_U_$P(G,U,2)
Q ""
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 ""
BGP0D5 ; IHS/CMI/LAB - measure calc ;
+1 ;;10.0;IHS CLINICAL REPORTING;**1**;JUN 18, 2010
+2 ;
I20 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+3 IF BGPSEX'="F"
SET BGPSTOP=1
QUIT
+4 IF BGPAGEB<15
SET BGPSTOP=1
QUIT
+5 IF BGPAGEB>44
SET BGPSTOP=1
QUIT
+6 IF BGPACTUP
SET BGPD2=1
+7 IF BGPACTCL
SET BGPD1=1
+8 SET BGPN2=$$ALHF(DFN,BGP365,BGPEDATE)
+9 SET BGPN3=$$ALDX^BGP0D5A(DFN,BGP365,BGPEDATE)
+10 IF 'BGPN3
SET BGPN3=$$ALPRC(DFN,BGP365,BGPEDATE)
+11 SET BGPN4=$$ALPED(DFN,BGP365,BGPEDATE)
+12 SET BGPN5=0
+13 IF BGPN2
SET BGPN1=1
+14 IF BGPN3
SET BGPN1=1
+15 IF BGPN4
SET BGPN1=1
+16 IF 'BGPN1
SET BGPN5=$$ALREF(DFN,BGP365,BGPEDATE)
+17 IF BGPN5
SET BGPN1=1
+18 IF BGPN1
IF 'BGPN5
SET BGPN6=1
+19 SET BGPVALUE=$SELECT(BGPD2:"UP",1:"")_";"_$SELECT(BGPD1:"AC",1:"")_"|||"
+20 IF $PIECE(BGPN2,U)=1
SET BGPVALUE=BGPVALUE_$PIECE(BGPN2,U,2)_" "_$PIECE(BGPN2,U,3)
+21 IF $PIECE(BGPN3,U)=1
SET BGPVALUE=BGPVALUE_$PIECE(BGPN3,U,2)_" "_$PIECE(BGPN3,U,3)
+22 IF $PIECE(BGPN4,U)=1
SET BGPVALUE=BGPVALUE_$PIECE(BGPN4,U,2)_" "_$PIECE(BGPN4,U,3)
+23 IF $PIECE(BGPN5,U)=1
SET BGPVALUE=BGPVALUE_$PIECE(BGPN5,U,2)_" "_$PIECE(BGPN5,U,3)
+24 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
+25 QUIT
I21 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 SET (BGPDVEX,BGPDVDX,BGPDVPED,BGPDVREF)=""
+3 IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+4 IF BGPSEX'="F"
SET BGPSTOP=1
QUIT
+5 IF BGPAGEB<13
SET BGPSTOP=1
QUIT
+6 IF BGPACTUP
SET BGPD3=1
+7 IF BGPACTCL
SET BGPD1=1
+8 ;gpra denominator 15-40
IF BGPAGEB>14
IF BGPAGEB<41
IF BGPACTCL
SET BGPD2=1
DV ;EP - called from elder care
+1 ;EXAM ONLY
SET BGPDVEX=$$DVEX(DFN,BGP365,BGPEDATE)
IF $PIECE(BGPDVEX,U)=1
SET BGPN2=1
+2 ;DX ONLY
SET BGPDVDX=$$DVDX(DFN,BGP365,BGPEDATE)
IF $PIECE(BGPDVDX,U)=1
SET BGPN3=1
+3 ;W/O V61.11
SET BGPDVPED=$$DVPED(DFN,BGP365,BGPEDATE)
IF $PIECE(BGPDVPED,U)=1
SET BGPN4=1
SET BGPN8=1
+4 ;include in education for gpra
SET BGPDVCOU=$$DV61(DFN,BGP365,BGPEDATE)
IF $PIECE(BGPDVPED,U)=1
SET BGPN4=1
+5 IF BGPN2
SET BGPN1=1
+6 IF BGPN3
SET BGPN1=1
+7 IF BGPN4
SET BGPN1=1
+8 IF 'BGPN1
SET BGPDVREF=$$REFDV(DFN,BGP365,BGPEDATE)
IF $PIECE(BGPDVREF,U)=1
SET BGPN5=1
+9 IF BGPN5
SET BGPN1=1
+10 ;
IF BGPN1
IF 'BGPN5
SET BGPN6=1
+11 IF BGPN2!(BGPN3)!(BGPDVCOU)
SET BGPN7=1
+12 SET BGPVALUE=$SELECT(BGPD3:"UP",1:"")_";"_$SELECT(BGPD1:"AC",1:"")_"|||"
+13 IF $PIECE(BGPDVEX,U)=1
SET BGPVALUE=BGPVALUE_$PIECE(BGPDVEX,U,3)_" "_$$DATE^BGP0UTL($PIECE(BGPDVEX,U,2))
+14 IF $PIECE(BGPDVDX,U)=1
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":";",1:"")_$PIECE(BGPDVDX,U,3)_" "_$$DATE^BGP0UTL($PIECE(BGPDVDX,U,2))
+15 IF $PIECE(BGPDVPED,U)=1
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":";",1:"")_$PIECE(BGPDVPED,U,3)_" "_$$DATE^BGP0UTL($PIECE(BGPDVPED,U,2))
+16 IF $PIECE(BGPDVCOU,U)=1
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":";",1:"")_$PIECE(BGPDVCOU,U,3)_" "_$$DATE^BGP0UTL($PIECE(BGPDVCOU,U,2))
+17 IF $PIECE(BGPDVREF,U)=1
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":";",1:"")_$PIECE(BGPDVREF,U,3)_" "_$$DATE^BGP0UTL($PIECE(BGPDVREF,U,2))
+18 SET BGPVALUD=""
IF BGPD2
SET BGPVALUD="AC15-40"_"|||"
Begin DoDot:1
+19 IF $PIECE(BGPDVEX,U)=1
SET BGPVALUD=BGPVALUD_$PIECE(BGPDVEX,U,3)_" "_$$DATE^BGP0UTL($PIECE(BGPDVEX,U,2))
+20 IF $PIECE(BGPDVDX,U)=1
SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":";",1:"")_$PIECE(BGPDVDX,U,3)_" "_$$DATE^BGP0UTL($PIECE(BGPDVDX,U,2))
+21 IF $PIECE(BGPDVPED,U)=1
SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":";",1:"")_$PIECE(BGPDVPED,U,3)_" "_$$DATE^BGP0UTL($PIECE(BGPDVPED,U,2))
+22 IF $PIECE(BGPDVCOU,U)=1
SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":";",1:"")_$PIECE(BGPDVCOU,U,3)_" "_$$DATE^BGP0UTL($PIECE(BGPDVCOU,U,2))
End DoDot:1
+23 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
+24 QUIT
+25 ;
DVEX(P,BDATE,EDATE) ;EP
+1 SET BGPLDV=""
+2 KILL BGPG
SET %=P_"^LAST EXAM 34;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+3 IF $DATA(BGPG(1))
SET BGPLDV=1_"^"_$PIECE(BGPG(1),U)_"^IPV EXAM 34"_U_"Ex 34"_U_$$DATE^BGP0UTL($PIECE(BGPG(1),U))
+4 SET BGPC=0
SET BGPV=""
+5 SET E=9999999-BDATE
SET D=9999999-EDATE-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)!(BGPC)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(BGPC)
QUIT
Begin DoDot:1
+6 SET X=$PIECE($GET(^AMHREC(V,14)),U)
+7 ;no test
IF X=""
QUIT
+8 ;don't count refusal here
IF $EXTRACT(X)="U"
QUIT
+9 IF X="REF"
QUIT
+10 SET BGPC=BGPC+1
SET BGPV="1^"_(9999999-D)_"^BH IPV EXAM"_U_" BH Ex 34"_U_$$DATE^BGP0UTL((9999999-D))
End DoDot:1
+11 IF $PIECE(BGPLDV,U,2)<$PIECE(BGPC,U,2)
SET BGPLDV=BGPC
+12 QUIT BGPLDV
REFDV(P,BDATE,EDATE) ;EP
+1 ;add refusal for exam 34
+2 SET G=$$REFUSAL^BGP0UTL1(P,9999999.15,$ORDER(^AUTTEXAM("C",34,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
+3 IF $PIECE(G,U)=1
QUIT 1_"^"_$PIECE(G,U,2)_"^ref exam 34"
+4 SET G=""
+5 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.09,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+6 SET H=""
+7 IF $PIECE($PIECE($GET(^AUTTEDT(X,0)),U),"-")="DV"!($PIECE($PIECE($GET(^AUTTEDT(X,0)),U),"-",2)="DV")
SET H=1
+8 IF H'=1
QUIT
+9 SET D=0
FOR
SET D=$ORDER(^AUPNPREF("AA",P,9999999.09,X,D))
IF D'=+D
QUIT
Begin DoDot:2
+10 SET Z=9999999-D
+11 IF Z<BDATE
QUIT
+12 IF Z>EDATE
QUIT
+13 SET G=1_"^"_Z_"^ref PtEd "_$PIECE(^AUTTEDT(X,0),U)
End DoDot:2
End DoDot:1
+14 IF $PIECE(G,U,1)=1
QUIT G
+15 SET BGPC=0
KILL BGPV
+16 SET E=9999999-BDATE
SET D=9999999-EDATE-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)!(BGPC)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(BGPC)
QUIT
Begin DoDot:1
+17 SET X=$PIECE($GET(^AMHREC(V,14)),U)
+18 ;no test
IF X=""
QUIT
+19 IF X="U"
SET BGPC=1
SET BGPV=1_"^"_(9999999-D)_"^BH UTS"
QUIT
+20 IF X="REF"
SET BGPC=1
SET BGPV=1_"^"_(9999999-D)_"^BH REF"
QUIT
+21 QUIT
End DoDot:1
+22 IF BGPC
QUIT BGPV
+23 QUIT ""
DVDX(P,BDATE,EDATE) ;EP
+1 IF $GET(P)=""
QUIT ""
+2 GOTO DVDX^BGP0D54
+3 ;
DVPED(P,BDATE,EDATE) ;EP
+1 KILL BGPG
+2 SET Y="BGPG("
SET BGPLDV=""
+3 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 IF '$DATA(BGPG(1))
GOTO BHPED
+5 KILL BGPV
SET (X,D,E)=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,"-",1)="DV"!($PIECE(T,"-",2)="DV")!($PIECE(T,"-")="995.80")!($PIECE(T,"-")="995.81")!($PIECE(T,"-")="995.82")!($PIECE(T,"-")="995.83")
SET BGPLDV=1_"^"_$PIECE(BGPG(X),U)_"^PED "_T_U_"PED "_T_U_$$DATE^BGP0UTL($PIECE(BGPG(X),U))
QUIT
+11 IF $PIECE(T,"-",1)="995.85"!($PIECE(T,"-")="V15.41")!($PIECE(T,"-")="V15.42")!($PIECE(T,"-")="V15.49")
SET BGPLDV=1_"^"_$PIECE(BGPG(X),U)_"^PED "_T_U_"PED "_T_U_$$DATE^BGP0UTL($PIECE(BGPG(X),U))
QUIT
End DoDot:1
BHPED ;
+1 KILL BGPV
SET BGPC=""
SET T=""
SET E=9999999-BDATE
SET D=9999999-EDATE-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)!(BGPC)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(BGPC)
QUIT
Begin DoDot:1
+2 SET X=0
FOR
SET X=$ORDER(^AMHREDU("AD",V,X))
IF X'=+X!(BGPC)
QUIT
SET T=$PIECE($GET(^AMHREDU(X,0)),U)
Begin DoDot:2
+3 IF 'T
QUIT
+4 IF '$DATA(^AUTTEDT(T,0))
QUIT
+5 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+6 IF $PIECE(T,"-")="DV"!($PIECE(T,"-",2)="DV")!($PIECE(T,"-")="995.80")!($PIECE(T,"-")="995.81")!($PIECE(T,"-")="995.82")!($PIECE(T,"-")="995.83")!$PIECE(T,"-",1)="995.85"!($PIECE(T,"-")="V15.41")!($PIECE(T,"-")="V15.42")!($PI
ECE(T,"-")="V15.49")
IF $PIECE(BGPLDV,U,2)<(9999999-$PIECE(D,"."))
Begin DoDot:3
+7 SET BGPLDV=1_"^"_(9999999-$PIECE(D,"."))_"^BH PED "_T_U_"BH PED "_T_U_$$DATE^BGP0UTL((9999999-$PIECE(D,".")))
End DoDot:3
End DoDot:2
End DoDot:1
+8 ;I BGPC Q BGPV
QUIT BGPLDV
DV61(P,BDATE,EDATE) ;
+1 NEW BGPLDV
+2 SET BGPLDV=""
+3 KILL BGPG
SET X=P_"^LAST DX V61.11;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 IF $DATA(BGPG(1))
SET BGPLDV=1_"^"_$PIECE(BGPG(1),U)_"^V61.11"_U_"POV V61.11"_U_$$DATE^BGP0UTL($PIECE(BGPG(1),U))
+5 QUIT BGPLDV
ALHF(P,BDATE,EDATE) ;EP - alcohol hf or screening pov
+1 SET BGPLAL=""
+2 KILL BGPG
SET %=P_"^LAST EXAM 35;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+3 IF $DATA(BGPG(1))
SET BGPLAL=1_"^Ex 35^"_$$DATE^BGP0UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U,1)
+4 ;S V=$$LASTHF(P,"ALCOHOL/DRUG",BDATE,EDATE)
+5 ;I V]"",$P(BGPLAL,U,4)<$P(V,U,3) S BGPLAL=1_U_"HF: "_V
+6 ;S V=$$LASTHF(P,"ALCOHOL",BDATE,EDATE)
+7 ;I V]"",$P(BGPLAL,U,4)<$P(V,U,3) S BGPLAL=1_U_"HF: "_V
+8 ;S V=$$LASTHF(P,"SBIRT",BDATE,EDATE)
+9 ;I V]"",$P(BGPLAL,U,4)<$P(V,U,3) S BGPLAL=1_U_"HF: "_V
+10 ;now add in v measurements
+11 SET BGPC=$$LASTITEM^BGP0DU(P,BDATE,EDATE,"MEASUREMENT","AUDT")
+12 IF $PIECE(BGPLAL,U,4)<$PIECE(BGPC,U,2)
SET BGPLAL=1_U_"MEAS: "_$PIECE(BGPC,U,3)_U_$$DATE^BGP0UTL($PIECE(BGPC,U,2))_U_$PIECE(BGPC,U,2)
+13 SET BGPC=$$LASTITEM^BGP0DU(P,BDATE,EDATE,"MEASUREMENT","AUDC")
+14 IF $PIECE(BGPLAL,U,4)<$PIECE(BGPC,U,2)
SET BGPLAL=1_U_"MEAS: "_$PIECE(BGPC,U,3)_U_$$DATE^BGP0UTL($PIECE(BGPC,U,2))_U_$PIECE(BGPC,U,2)
+15 SET BGPC=$$LASTITEM^BGP0DU(P,BDATE,EDATE,"MEASUREMENT","CRFT")
+16 IF $PIECE(BGPLAL,U,4)<$PIECE(BGPC,U,2)
SET BGPLAL=1_U_"MEAS: "_$PIECE(BGPC,U,3)_U_$$DATE^BGP0UTL($PIECE(BGPC,U,2))_U_$PIECE(BGPC,U,2)
+17 ;pcc health factor CAGE only in v10.0
+18 KILL BGPG
SET %=P_"^LAST HEALTH CAGE 0/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+19 IF $DATA(BGPG(1))
SET BGPLAL=1_"^HF: CAGE 0/4^"_$$DATE^BGP0UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U,1)
+20 KILL BGPG
SET %=P_"^LAST HEALTH CAGE 1/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+21 IF $DATA(BGPG(1))
SET BGPLAL=1_"^HF: CAGE 1/4^"_$$DATE^BGP0UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U,1)
+22 KILL BGPG
SET %=P_"^LAST HEALTH CAGE 2/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+23 IF $DATA(BGPG(1))
SET BGPLAL=1_"^HF: CAGE 2/4^"_$$DATE^BGP0UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U,1)
+24 KILL BGPG
SET %=P_"^LAST HEALTH CAGE 3/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+25 IF $DATA(BGPG(1))
SET BGPLAL=1_"^HF: CAGE 3/4^"_$$DATE^BGP0UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U,1)
+26 KILL BGPG
SET %=P_"^LAST HEALTH CAGE 4/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+27 IF $DATA(BGPG(1))
SET BGPLAL=1_"^HF: CAGE 4/4^"_$$DATE^BGP0UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U,1)
+28 ;CHECK BH HF FILE
+29 SET BGPC=""
SET T=""
SET F=""
SET E=9999999-BDATE
SET D=9999999-EDATE-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)!(BGPC)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(BGPC)
QUIT
Begin DoDot:1
+30 SET X=0
FOR
SET X=$ORDER(^AMHRHF("AD",V,X))
IF X'=+X!(BGPC)
QUIT
SET F=$PIECE($GET(^AMHRHF(X,0)),U)
Begin DoDot:2
+31 IF 'F
QUIT
+32 IF '$DATA(^AUTTHF(F,0))
QUIT
+33 SET T=$PIECE(^AUTTHF(F,0),U,3)
+34 IF 'T
QUIT
+35 IF $PIECE($GET(^AUTTHF(F,0)),U)["CAGE "
SET BGPC=1_U_"BH HF: "_$PIECE(^AUTTHF(F,0),U)_U_$$DATE^BGP0UTL((9999999-D))_U_(9999999-D)
+36 QUIT
End DoDot:2
+37 SET X=0
FOR
SET X=$ORDER(^AMHRMSR("AD",V,X))
IF X'=+X!(BGPC)
QUIT
SET F=$PIECE($GET(^AMHRMSR(X,0)),U)
Begin DoDot:2
+38 IF 'F
QUIT
+39 IF '$DATA(^AUTTMSR(F,0))
QUIT
+40 SET T=$PIECE(^AUTTMSR(F,0),U,1)
+41 IF T="AUDT"!(T="AUDC")!(T="CRFT")
SET BGPC=1_U_"BH MSR: "_T_U_$$DATE^BGP0UTL((9999999-D))_U_(9999999-D)
End DoDot:2
End DoDot:1
+42 IF $PIECE(BGPLAL,U,4)<$PIECE(BGPC,U,4)
SET BGPLAL=BGPC
+43 KILL BGPG
SET %=P_"^LAST DX V11.3;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+44 IF $DATA(BGPG(1))
IF $PIECE(BGPLAL,U,4)<$PIECE(BGPG(1),U,1)
SET BGPLAL=1_U_"DX: V11.3"_U_$$DATE^BGP0UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U,1)
+45 KILL BGPG
+46 SET %=P_"^LAST DX V79.1;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+47 IF $DATA(BGPG(1))
IF $PIECE(BGPLAL,U,4)<$PIECE(BGPG(1),U,1)
SET BGPLAL=1_U_"DX: V79.1"_U_$$DATE^BGP0UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U,1)
+48 ;now add in CPT codes
+49 SET BGPC=$$CPT^BGP0DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0)),6)
+50 IF $PIECE(BGPLAL,U,4)<$PIECE(BGPC,U,2)
SET BGPLAL=1_U_"CPT: "_$PIECE(BGPC,U,3)_U_$$DATE^BGP0UTL($PIECE(BGPC,U,2))_U_$PIECE(BGPC,U,2)
+51 ;go through BH record file and find up to 1 visits in date range
+52 SET E=9999999-BDATE
SET D=9999999-EDATE-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)!(BGPC)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(BGPC)
QUIT
Begin DoDot:1
+53 SET X=$PIECE($GET(^AMHREC(V,14)),U)
+54 Begin DoDot:2
+55 ;no test
IF X=""
QUIT
+56 ;don't count refusal here
IF $EXTRACT(X)="U"
QUIT
+57 IF X="REF"
QUIT
+58 SET BGPC=1_U_"BH Alcohol scrn"_U_$$DATE^BGP0UTL((9999999-$PIECE(D,".")))_U_(9999999-$PIECE(D,"."))
End DoDot:2
+59 SET X=0
FOR
SET X=$ORDER(^AMHRPRO("AD",V,X))
IF X'=+X!(BGPC)
QUIT
SET BGPP=$PIECE($GET(^AMHRPRO(X,0)),U)
Begin DoDot:2
+60 IF 'BGPP
QUIT
+61 SET BGPP=$PIECE($GET(^AMHPROB(BGPP,0)),U)
+62 IF BGPP=29.1
SET BGPC=1_U_"BH dx: 29.1"_U_$$DATE^BGP0UTL((9999999-$PIECE(D,".")))_U_(9999999-$PIECE(D,"."))
QUIT
+63 QUIT
End DoDot:2
+64 SET T=$ORDER(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0))
+65 SET X=0
FOR
SET X=$ORDER(^AMHRPROC("AD",V,X))
IF X'=+X!(BGPC)
QUIT
SET F=$PIECE($GET(^AMHRPROC(X,0)),U)
Begin DoDot:2
+66 IF 'F
QUIT
+67 IF '$$ICD^ATXCHK(T,$PIECE(+$GET(^AUPNVCPT(X,0)),U,1),1)
QUIT
+68 SET I=$$VAL^XBDIQ1(81,F,.01)
+69 SET BGPC=1_U_"BH CPT: "_I_U_$$DATE^BGP0UTL((9999999-D))_U_(9999999-D)
End DoDot:2
End DoDot:1
+70 IF $PIECE(BGPLAL,U,4)<$PIECE(BGPC,U,4)
SET BGPLAL=BGPC
+71 ;
+72 QUIT BGPLAL
ALPRC(P,BDATE,EDATE) ;EP
+1 SET BGPG=$$LASTPRC^BGP0UTL1(P,"BGP ALCOHOL PROCEDURES",BDATE,EDATE)
+2 IF BGPG
QUIT 1_U_"PROC "_$PIECE(BGPG,U,2)_U_$$DATE^BGP0UTL($PIECE(BGPG,U,3))
+3 QUIT ""
ALPED(P,BDATE,EDATE) ;EP
+1 KILL BGPG
+2 SET Y="BGPG("
SET BGPLPED=""
+3 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 IF '$DATA(BGPG(1))
GOTO ALMH
+5 SET (X,D,E)=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,"-",1)="CD"!($PIECE(T,"-",2)="CD")!($PIECE(T,"-",1)="AOD")!($PIECE(T,"-",2)="AOD")
IF $PIECE(BGPLPED,U,4)<$PIECE(BGPG(X),U)
SET BGPLPED=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL($PIECE(BGPG(X),U))_U_$PIECE(BGPG(X),U)
+11 IF $PIECE(T,"-",1)="V11.3"!($PIECE(T,"-",1)="V79.1")!($PIECE(T,"-",1)["303.")!($PIECE(T,"-",1)["305.0")!($PIECE(T,"-")["291.")!($PIECE(T,"-")["357.5")
IF $PIECE(BGPLPED,U,4)<$PIECE(BGPG(X),U)
Begin DoDot:2
+12 SET BGPLPED=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL($PIECE(BGPG(X),U))_U_$PIECE(BGPG(X),U)
End DoDot:2
End DoDot:1
ALMH ;
+1 SET BGPC=""
SET T=""
SET E=9999999-BDATE
SET D=9999999-EDATE-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)!(BGPC)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(BGPC)
QUIT
Begin DoDot:1
+2 SET X=0
FOR
SET X=$ORDER(^AMHREDU("AD",V,X))
IF X'=+X
QUIT
SET T=$PIECE($GET(^AMHREDU(X,0)),U)
Begin DoDot:2
+3 IF 'T
QUIT
+4 IF '$DATA(^AUTTEDT(T,0))
QUIT
+5 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+6 IF $PIECE(T,"-",1)="CD"!($PIECE(T,"-",2)="CD")!($PIECE(T,"-",1)="AOD")!($PIECE(T,"-",2)="AOD")
IF $PIECE(BGPLPED,U,4)<(9999999-D)
SET BGPLPED=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL((9999999-D))_U_(9999999-D)
+7 IF $PIECE(T,"-",1)="V11.3"!($PIECE(T,"-",1)="V79.1")!($PIECE(T,"-",1)["303.")!($PIECE(T,"-",1)["305.0")!($PIECE(T,"-")["291.")!($PIECE(T,"-")["357.5")
IF $PIECE(BGPLPED,U,4)<(9999999-D)
Begin DoDot:3
+8 SET BGPLPED=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL((9999999-D))_U_(9999999-D)
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT BGPLPED
+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)_U_(9999999-D)
+14 ;
ALREF(P,BDATE,EDATE) ;EP
+1 ;add refusal for exam 35
+2 SET G=$$REFUSAL^BGP0UTL1(P,9999999.15,$ORDER(^AUTTEXAM("C",35,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
+3 IF $PIECE(G,U)=1
QUIT 1_"^ref exam 35^"_$$DATE^BGP0UTL($PIECE(G,U,2))_U_$PIECE(G,U,2)
+4 QUIT ""
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 ""
