BGP2D5 ; IHS/CMI/LAB - measure calc ;
;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
;
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^BGP2D5A(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_"SCREEN: "_$P(BGPN2,U,3)_" "_$P(BGPN2,U,2)
I $P(BGPN3,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:"") S BGPVALUE=BGPVALUE_"DX/PROC: "_$P(BGPN3,U,3)_" "_$P(BGPN3,U,2)
I $P(BGPN4,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:"") S BGPVALUE=BGPVALUE_"PT ED: "_$P(BGPN4,U,3)_" "_$P(BGPN4,U,2)
I BGPRTYPE'=1,$P(BGPN5,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:"") S BGPVALUE=BGPVALUE_"SCREEN: "_$P(BGPN5,U,3)_" "_$P(BGPN5,U,2)
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
I BGPAGEB>14,BGPAGEB<41,BGPACTCB S BGPD4=1 ;ac+bh
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(BGPDVCOU,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_"EXAM: "_$$DATE^BGP2UTL($P(BGPDVEX,U,2))_" "_$P(BGPDVEX,U,4)
I $P(BGPDVDX,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; DX: ",1:"DX: ")_$$DATE^BGP2UTL($P(BGPDVDX,U,2))_" "_$P(BGPDVDX,U,4)
I $P(BGPDVPED,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; PT ED: ",1:"PT ED: ")_$$DATE^BGP2UTL($P(BGPDVPED,U,2))_" "_$P(BGPDVPED,U,4)
I $P(BGPDVCOU,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; COUNSEL ",1:"COUNSEL ")_$$DATE^BGP2UTL($P(BGPDVCOU,U,2))_" "_$P(BGPDVCOU,U,4)
I BGPRTYPE'=1,$P(BGPDVREF,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:"")_$$DATE^BGP2UTL($P(BGPDVREF,U,2))_" "_$P(BGPDVREF,U,3)
S BGPVALUD="" I BGPD4 S BGPVALUD="AC+BH"_"|||" D
.I $P(BGPDVEX,U)=1 S BGPVALUD=BGPVALUD_"EXAM: "_$$DATE^BGP2UTL($P(BGPDVEX,U,2))_" "_$P(BGPDVEX,U,4)
.I $P(BGPDVDX,U)=1 S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; DX: ",1:"DX: ")_$$DATE^BGP2UTL($P(BGPDVDX,U,2))_" "_$P(BGPDVDX,U,4)
.I $P(BGPDVPED,U)=1 S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; PT ED: ",1:"PT ED: ")_$$DATE^BGP2UTL($P(BGPDVPED,U,2))_" "_$P(BGPDVPED,U,4)
.I $P(BGPDVCOU,U)=1 S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; COUNSEL ",1:"COUNSEL ")_$$DATE^BGP2UTL($P(BGPDVCOU,U,2))_" "_$P(BGPDVCOU,U,4)
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^BGP2UTL($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^BGP2UTL((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^BGP2UTL1(P,9999999.15,$O(^AUTTEXAM("C",34,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
I $P(G,U)=1 Q 1_"^"_$P(G,U,2)_"^Refused Ex 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_"^Refused 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)_"^Refused BH UTS" Q
.I X="REF" S BGPC=1,BGPV=1_"^"_(9999999-D)_"^Refused BH" Q
.Q
I BGPC Q BGPV
Q ""
DVDX(P,BDATE,EDATE) ;EP
I $G(P)="" Q ""
G DVDX^BGP2D54
;
DVPED(P,BDATE,EDATE) ;EP
NEW BGPG,Y,X,BGPLDV,E,D,T,S,BGPV
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") S BGPLDV=1_"^"_$P(BGPG(X),U)_"^PED "_T_U_"PED "_T_U_$$DATE^BGP2UTL($P(BGPG(X),U)) Q
.S S=$P(T,"-",1)
.S S=$$ICDDX^ICDCODE(S)
.I $P(S,U,1)'="-1",$$ICD^ATXCHK($P(S,U,1),$O(^ATXAX("B","BGP IPV/DV EDUC DXS",0)),9) S BGPLDV=1_"^"_$P(BGPG(X),U)_"^PED "_T_U_"PED "_T_U_$$DATE^BGP2UTL($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(BGPLDV,U,2)<(9999999-$P(D,".")) D
...S BGPLDV=1_"^"_(9999999-$P(D,"."))_"^BH PED "_T_U_"BH PED "_T_U_$$DATE^BGP2UTL((9999999-$P(D,".")))
..S S=$P(T,"-",1)
..S S=$$ICDDX^ICDCODE(S)
..I $P(S,U,1)'="-1",$$ICD^ATXCHK($P(S,U,1),$O(^ATXAX("B","BGP IPV/DV EDUC DXS",0)),9),$P(BGPLDV,U,2)<(9999999-$P(D,".")) D
...S BGPLDV=1_"^"_(9999999-$P(D,"."))_"^BH PED "_T_U_"BH PED "_T_U_$$DATE^BGP2UTL((9999999-$P(D,".")))
Q BGPLDV ;I BGPC Q BGPV
DV61(P,BDATE,EDATE) ;EP
NEW BGPLDV,BGPG,Y,X,E
S BGPLDV=""
K BGPG S Y="BGPG(" S X=P_"^LAST DX [BGP IPV/DV COUNSELING ICDS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) S BGPLDV=1_"^"_$P(BGPG(1),U)_"^"_$P(BGPG(1),U,2)_U_"POV "_$P(BGPG(1),U,2)_U_$$DATE^BGP2UTL($P(BGPG(1),U))
Q BGPLDV
ALHF(P,BDATE,EDATE) ;EP - alcohol hf or screening pov
NEW BGPLAL,BGPG,%,E,BGPC,T,F,D,X
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^BGP2UTL($P(BGPG(1),U))_U_$P(BGPG(1),U,1)
;now add in v measurements
S BGPC=$$LASTITEM^BGP2DU(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^BGP2UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)
S BGPC=$$LASTITEM^BGP2DU(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^BGP2UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)
S BGPC=$$LASTITEM^BGP2DU(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^BGP2UTL($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)) I $P(BGPLAL,U,4)<$P(BGPG(1),U,1) S BGPLAL=1_"^HF CAGE 0/4^"_$$DATE^BGP2UTL($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)) I $P(BGPLAL,U,4)<$P(BGPG(1),U,1) S BGPLAL=1_"^HF CAGE 1/4^"_$$DATE^BGP2UTL($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)) I $P(BGPLAL,U,4)<$P(BGPG(1),U,1) S BGPLAL=1_"^HF CAGE 2/4^"_$$DATE^BGP2UTL($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)) I $P(BGPLAL,U,4)<$P(BGPG(1),U,1) S BGPLAL=1_"^HF CAGE 3/4^"_$$DATE^BGP2UTL($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)) I $P(BGPLAL,U,4)<$P(BGPG(1),U,1) S BGPLAL=1_"^HF CAGE 4/4^"_$$DATE^BGP2UTL($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^BGP2UTL((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 Meas "_T_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
I $P(BGPLAL,U,4)<$P(BGPC,U,4) S BGPLAL=BGPC
K BGPG S %=P_"^LAST DX [BGP ALCOHOL SCREEN DXS;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)),$P(BGPLAL,U,4)<$P(BGPG(1),U,1) S BGPLAL=1_U_"POV "_$P(BGPG(1),U,2)_U_$$DATE^BGP2UTL($P(BGPG(1),U))_U_$P(BGPG(1),U,1)
;now add in CPT codes
S BGPC=$$CPT^BGP2DU(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^BGP2UTL($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^BGP2UTL((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 POV 29.1"_U_$$DATE^BGP2UTL((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^BGP2UTL((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^BGP2UTL1(P,"BGP ALCOHOL PROCEDURES",BDATE,EDATE)
I BGPG Q 1_U_"Proc "_$P(BGPG,U,2)_U_$$DATE^BGP2UTL($P(BGPG,U,3))_U_$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_T_U_$$DATE^BGP2UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)
.S S=$P(T,"-",1)
.S S=$$ICDDX^ICDCODE(S)
.I $P(S,U,1)'="-1",$$ICD^ATXCHK($P(S,U,1),$O(^ATXAX("B","BGP ALCOHOL EDUC DXS",0)),9),$P(BGPLPED,U,4)<$P(BGPG(X),U,1) S BGPLPED=1_U_""_T_U_$$DATE^BGP2UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)
.I $P(T,"-",1)="99408"!($P(T,"-",1)="99409")!($P(T,"-",1)["G0396")!($P(T,"-",1)["G0397")!($P(T,"-")["H0049")!($P(T,"-")["H0050")!($P(T,"-")["3016F"),$P(BGPLPED,U,4)<$P(BGPG(X),U) D
..S BGPLPED=1_U_T_U_$$DATE^BGP2UTL($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_T_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
..S S=$P(T,"-",1)
..S S=$$ICDDX^ICDCODE(S)
..I $P(S,U,1)'="-1",$$ICD^ATXCHK($P(S,U,1),$O(^ATXAX("B","BGP ALCOHOL EDUC DXS",0)),9) D
...S BGPLPED=1_U_T_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
..I $P(T,"-",1)="99408"!($P(T,"-",1)="99409")!($P(T,"-",1)["G0396")!($P(T,"-",1)["G0397")!($P(T,"-")["H0049")!($P(T,"-")["H0050"),$P(BGPLPED,U,4)<(9999999-D) D
...S BGPLPED=1_U_T_U_$$DATE^BGP2UTL((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))
I '$G(C) Q ""
S (H,D)=0 K O
F S H=$O(^AUTTHF("AC",C,H)) Q:'+H D
.Q:'$D(^AUPNVHF("AA",P,H))
.S D="" F S D=$O(^AUPNVHF("AA",P,H,D)) Q:D'=+D D
..Q:(9999999-D)>EDATE ;after time frame
..Q:(9999999-D)<BDATE ;before time frame
..S O(D)=$O(^AUPNVHF("AA",P,H,D,""))
.Q
S D=$O(O(0))
I D="" Q D
Q $$VAL^XBDIQ1(9000010.23,O(D),.01)_"^"_$$DATE^BGP2UTL(9999999-D)_U_(9999999-D)
;
ALREF(P,BDATE,EDATE) ;EP
;add Refusal for exam 35
S G=$$REFUSAL^BGP2UTL1(P,9999999.15,$O(^AUTTEXAM("C",35,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
I $P(G,U)=1 Q 1_"^Refused Ex 35^"_$$DATE^BGP2UTL($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 ""
BGP2D5 ; IHS/CMI/LAB - measure calc ;
+1 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
+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^BGP2D5A(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_"SCREEN: "_$PIECE(BGPN2,U,3)_" "_$PIECE(BGPN2,U,2)
+21 IF $PIECE(BGPN3,U)=1
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_"DX/PROC: "_$PIECE(BGPN3,U,3)_" "_$PIECE(BGPN3,U,2)
+22 IF $PIECE(BGPN4,U)=1
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_"PT ED: "_$PIECE(BGPN4,U,3)_" "_$PIECE(BGPN4,U,2)
+23 IF BGPRTYPE'=1
IF $PIECE(BGPN5,U)=1
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_"SCREEN: "_$PIECE(BGPN5,U,3)_" "_$PIECE(BGPN5,U,2)
+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
+9 ;ac+bh
IF BGPAGEB>14
IF BGPAGEB<41
IF BGPACTCB
SET BGPD4=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(BGPDVCOU,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_"EXAM: "_$$DATE^BGP2UTL($PIECE(BGPDVEX,U,2))_" "_$PIECE(BGPDVEX,U,4)
+14 IF $PIECE(BGPDVDX,U)=1
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; DX: ",1:"DX: ")_$$DATE^BGP2UTL($PIECE(BGPDVDX,U,2))_" "_$PIECE(BGPDVDX,U,4)
+15 IF $PIECE(BGPDVPED,U)=1
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; PT ED: ",1:"PT ED: ")_$$DATE^BGP2UTL($PIECE(BGPDVPED,U,2))_" "_$PIECE(BGPDVPED,U,4)
+16 IF $PIECE(BGPDVCOU,U)=1
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; COUNSEL ",1:"COUNSEL ")_$$DATE^BGP2UTL($PIECE(BGPDVCOU,U,2))_" "_$PIECE(BGPDVCOU,U,4)
+17 IF BGPRTYPE'=1
IF $PIECE(BGPDVREF,U)=1
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")_$$DATE^BGP2UTL($PIECE(BGPDVREF,U,2))_" "_$PIECE(BGPDVREF,U,3)
+18 SET BGPVALUD=""
IF BGPD4
SET BGPVALUD="AC+BH"_"|||"
Begin DoDot:1
+19 IF $PIECE(BGPDVEX,U)=1
SET BGPVALUD=BGPVALUD_"EXAM: "_$$DATE^BGP2UTL($PIECE(BGPDVEX,U,2))_" "_$PIECE(BGPDVEX,U,4)
+20 IF $PIECE(BGPDVDX,U)=1
SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; DX: ",1:"DX: ")_$$DATE^BGP2UTL($PIECE(BGPDVDX,U,2))_" "_$PIECE(BGPDVDX,U,4)
+21 IF $PIECE(BGPDVPED,U)=1
SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; PT ED: ",1:"PT ED: ")_$$DATE^BGP2UTL($PIECE(BGPDVPED,U,2))_" "_$PIECE(BGPDVPED,U,4)
+22 IF $PIECE(BGPDVCOU,U)=1
SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; COUNSEL ",1:"COUNSEL ")_$$DATE^BGP2UTL($PIECE(BGPDVCOU,U,2))_" "_$PIECE(BGPDVCOU,U,4)
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^BGP2UTL($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^BGP2UTL((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^BGP2UTL1(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)_"^Refused Ex 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_"^Refused 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)_"^Refused BH UTS"
QUIT
+20 IF X="REF"
SET BGPC=1
SET BGPV=1_"^"_(9999999-D)_"^Refused BH"
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^BGP2D54
+3 ;
DVPED(P,BDATE,EDATE) ;EP
+1 NEW BGPG,Y,X,BGPLDV,E,D,T,S,BGPV
+2 KILL BGPG
+3 SET Y="BGPG("
SET BGPLDV=""
+4 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 IF '$DATA(BGPG(1))
GOTO BHPED
+6 KILL BGPV
SET (X,D,E)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
Begin DoDot:1
+7 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPG(X),U,4),0),U)
+8 IF 'T
QUIT
+9 IF '$DATA(^AUTTEDT(T,0))
QUIT
+10 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+11 IF $PIECE(T,"-",1)="DV"!($PIECE(T,"-",2)="DV")
SET BGPLDV=1_"^"_$PIECE(BGPG(X),U)_"^PED "_T_U_"PED "_T_U_$$DATE^BGP2UTL($PIECE(BGPG(X),U))
QUIT
+12 SET S=$PIECE(T,"-",1)
+13 SET S=$$ICDDX^ICDCODE(S)
+14 IF $PIECE(S,U,1)'="-1"
IF $$ICD^ATXCHK($PIECE(S,U,1),$ORDER(^ATXAX("B","BGP IPV/DV EDUC DXS",0)),9)
SET BGPLDV=1_"^"_$PIECE(BGPG(X),U)_"^PED "_T_U_"PED "_T_U_$$DATE^BGP2UTL($PIECE(BGPG(X),U))
QUIT
End DoDot:1
+15 ;
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")
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^BGP2UTL((9999999-$PIECE(D,".")))
End DoDot:3
+8 SET S=$PIECE(T,"-",1)
+9 SET S=$$ICDDX^ICDCODE(S)
+10 IF $PIECE(S,U,1)'="-1"
IF $$ICD^ATXCHK($PIECE(S,U,1),$ORDER(^ATXAX("B","BGP IPV/DV EDUC DXS",0)),9)
IF $PIECE(BGPLDV,U,2)<(9999999-$PIECE(D,"."))
Begin DoDot:3
+11 SET BGPLDV=1_"^"_(9999999-$PIECE(D,"."))_"^BH PED "_T_U_"BH PED "_T_U_$$DATE^BGP2UTL((9999999-$PIECE(D,".")))
End DoDot:3
End DoDot:2
End DoDot:1
+12 ;I BGPC Q BGPV
QUIT BGPLDV
DV61(P,BDATE,EDATE) ;EP
+1 NEW BGPLDV,BGPG,Y,X,E
+2 SET BGPLDV=""
+3 KILL BGPG
SET Y="BGPG("
SET X=P_"^LAST DX [BGP IPV/DV COUNSELING ICDS;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)_"^"_$PIECE(BGPG(1),U,2)_U_"POV "_$PIECE(BGPG(1),U,2)_U_$$DATE^BGP2UTL($PIECE(BGPG(1),U))
+5 QUIT BGPLDV
ALHF(P,BDATE,EDATE) ;EP - alcohol hf or screening pov
+1 NEW BGPLAL,BGPG,%,E,BGPC,T,F,D,X
+2 SET BGPLAL=""
+3 KILL BGPG
SET %=P_"^LAST EXAM 35;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+4 IF $DATA(BGPG(1))
SET BGPLAL=1_"^Ex 35^"_$$DATE^BGP2UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U,1)
+5 ;now add in v measurements
+6 SET BGPC=$$LASTITEM^BGP2DU(P,BDATE,EDATE,"MEASUREMENT","AUDT")
+7 IF $PIECE(BGPLAL,U,4)<$PIECE(BGPC,U,2)
SET BGPLAL=1_U_"Meas "_$PIECE(BGPC,U,3)_U_$$DATE^BGP2UTL($PIECE(BGPC,U,2))_U_$PIECE(BGPC,U,2)
+8 SET BGPC=$$LASTITEM^BGP2DU(P,BDATE,EDATE,"MEASUREMENT","AUDC")
+9 IF $PIECE(BGPLAL,U,4)<$PIECE(BGPC,U,2)
SET BGPLAL=1_U_"Meas "_$PIECE(BGPC,U,3)_U_$$DATE^BGP2UTL($PIECE(BGPC,U,2))_U_$PIECE(BGPC,U,2)
+10 SET BGPC=$$LASTITEM^BGP2DU(P,BDATE,EDATE,"MEASUREMENT","CRFT")
+11 IF $PIECE(BGPLAL,U,4)<$PIECE(BGPC,U,2)
SET BGPLAL=1_U_"Meas "_$PIECE(BGPC,U,3)_U_$$DATE^BGP2UTL($PIECE(BGPC,U,2))_U_$PIECE(BGPC,U,2)
+12 ;pcc health factor CAGE only in v10.0
+13 KILL BGPG
SET %=P_"^LAST HEALTH CAGE 0/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+14 IF $DATA(BGPG(1))
IF $PIECE(BGPLAL,U,4)<$PIECE(BGPG(1),U,1)
SET BGPLAL=1_"^HF CAGE 0/4^"_$$DATE^BGP2UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U,1)
+15 KILL BGPG
SET %=P_"^LAST HEALTH CAGE 1/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+16 IF $DATA(BGPG(1))
IF $PIECE(BGPLAL,U,4)<$PIECE(BGPG(1),U,1)
SET BGPLAL=1_"^HF CAGE 1/4^"_$$DATE^BGP2UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U,1)
+17 KILL BGPG
SET %=P_"^LAST HEALTH CAGE 2/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+18 IF $DATA(BGPG(1))
IF $PIECE(BGPLAL,U,4)<$PIECE(BGPG(1),U,1)
SET BGPLAL=1_"^HF CAGE 2/4^"_$$DATE^BGP2UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U,1)
+19 KILL BGPG
SET %=P_"^LAST HEALTH CAGE 3/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+20 IF $DATA(BGPG(1))
IF $PIECE(BGPLAL,U,4)<$PIECE(BGPG(1),U,1)
SET BGPLAL=1_"^HF CAGE 3/4^"_$$DATE^BGP2UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U,1)
+21 KILL BGPG
SET %=P_"^LAST HEALTH CAGE 4/4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+22 IF $DATA(BGPG(1))
IF $PIECE(BGPLAL,U,4)<$PIECE(BGPG(1),U,1)
SET BGPLAL=1_"^HF CAGE 4/4^"_$$DATE^BGP2UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U,1)
+23 ;CHECK BH HF FILE
+24 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
+25 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
+26 IF 'F
QUIT
+27 IF '$DATA(^AUTTHF(F,0))
QUIT
+28 SET T=$PIECE(^AUTTHF(F,0),U,3)
+29 IF 'T
QUIT
+30 IF $PIECE($GET(^AUTTHF(F,0)),U)["CAGE "
SET BGPC=1_U_"BH HF "_$PIECE(^AUTTHF(F,0),U)_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
+31 QUIT
End DoDot:2
+32 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
+33 IF 'F
QUIT
+34 IF '$DATA(^AUTTMSR(F,0))
QUIT
+35 SET T=$PIECE(^AUTTMSR(F,0),U,1)
+36 IF T="AUDT"!(T="AUDC")!(T="CRFT")
SET BGPC=1_U_"BH Meas "_T_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
End DoDot:2
End DoDot:1
+37 IF $PIECE(BGPLAL,U,4)<$PIECE(BGPC,U,4)
SET BGPLAL=BGPC
+38 KILL BGPG
SET %=P_"^LAST DX [BGP ALCOHOL SCREEN DXS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+39 IF $DATA(BGPG(1))
IF $PIECE(BGPLAL,U,4)<$PIECE(BGPG(1),U,1)
SET BGPLAL=1_U_"POV "_$PIECE(BGPG(1),U,2)_U_$$DATE^BGP2UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U,1)
+40 ;now add in CPT codes
+41 SET BGPC=$$CPT^BGP2DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0)),6)
+42 IF $PIECE(BGPLAL,U,4)<$PIECE(BGPC,U,2)
SET BGPLAL=1_U_"CPT "_$PIECE(BGPC,U,3)_U_$$DATE^BGP2UTL($PIECE(BGPC,U,2))_U_$PIECE(BGPC,U,2)
+43 ;go through BH record file and find up to 1 visits in date range
+44 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
+45 SET X=$PIECE($GET(^AMHREC(V,14)),U)
+46 Begin DoDot:2
+47 ;no test
IF X=""
QUIT
+48 ;don't count Refusal here
IF $EXTRACT(X)="U"
QUIT
+49 IF X="REF"
QUIT
+50 SET BGPC=1_U_"BH Alcohol scrn"_U_$$DATE^BGP2UTL((9999999-$PIECE(D,".")))_U_(9999999-$PIECE(D,"."))
End DoDot:2
+51 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
+52 IF 'BGPP
QUIT
+53 SET BGPP=$PIECE($GET(^AMHPROB(BGPP,0)),U)
+54 IF BGPP=29.1
SET BGPC=1_U_"BH POV 29.1"_U_$$DATE^BGP2UTL((9999999-$PIECE(D,".")))_U_(9999999-$PIECE(D,"."))
QUIT
+55 QUIT
End DoDot:2
+56 SET T=$ORDER(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0))
+57 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
+58 IF 'F
QUIT
+59 IF '$$ICD^ATXCHK(T,$PIECE(+$GET(^AUPNVCPT(X,0)),U,1),1)
QUIT
+60 SET I=$$VAL^XBDIQ1(81,F,.01)
+61 SET BGPC=1_U_"BH CPT "_I_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
End DoDot:2
End DoDot:1
+62 IF $PIECE(BGPLAL,U,4)<$PIECE(BGPC,U,4)
SET BGPLAL=BGPC
+63 ;
+64 QUIT BGPLAL
ALPRC(P,BDATE,EDATE) ;EP
+1 SET BGPG=$$LASTPRC^BGP2UTL1(P,"BGP ALCOHOL PROCEDURES",BDATE,EDATE)
+2 IF BGPG
QUIT 1_U_"Proc "_$PIECE(BGPG,U,2)_U_$$DATE^BGP2UTL($PIECE(BGPG,U,3))_U_$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_T_U_$$DATE^BGP2UTL($PIECE(BGPG(X),U))_U_$PIECE(BGPG(X),U)
+11 SET S=$PIECE(T,"-",1)
+12 SET S=$$ICDDX^ICDCODE(S)
+13 IF $PIECE(S,U,1)'="-1"
IF $$ICD^ATXCHK($PIECE(S,U,1),$ORDER(^ATXAX("B","BGP ALCOHOL EDUC DXS",0)),9)
IF $PIECE(BGPLPED,U,4)<$PIECE(BGPG(X),U,1)
SET BGPLPED=1_U_""_T_U_$$DATE^BGP2UTL($PIECE(BGPG(X),U))_U_$PIECE(BGPG(X),U)
+14 IF $PIECE(T,"-",1)="99408"!($PIECE(T,"-",1)="99409")!($PIECE(T,"-",1)["G0396")!($PIECE(T,"-",1)["G0397")!($PIECE(T,"-")["H0049")!($PIECE(T,"-")["H0050")!($PIECE(T,"-")["3016F")
IF $PIECE(BGPLPED,U,4)<$PIECE(BGPG(X),U)
Begin DoDot:2
+15 SET BGPLPED=1_U_T_U_$$DATE^BGP2UTL($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_T_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
+7 SET S=$PIECE(T,"-",1)
+8 SET S=$$ICDDX^ICDCODE(S)
+9 IF $PIECE(S,U,1)'="-1"
IF $$ICD^ATXCHK($PIECE(S,U,1),$ORDER(^ATXAX("B","BGP ALCOHOL EDUC DXS",0)),9)
Begin DoDot:3
+10 SET BGPLPED=1_U_T_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
End DoDot:3
+11 IF $PIECE(T,"-",1)="99408"!($PIECE(T,"-",1)="99409")!($PIECE(T,"-",1)["G0396")!($PIECE(T,"-",1)["G0397")!($PIECE(T,"-")["H0049")!($PIECE(T,"-")["H0050")
IF $PIECE(BGPLPED,U,4)<(9999999-D)
Begin DoDot:3
+12 SET BGPLPED=1_U_T_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT BGPLPED
+14 ;
LASTHF(P,C,BDATE,EDATE) ;EP - get last factor in category C for patient P
+1 SET C=$ORDER(^AUTTHF("B",C,0))
+2 IF '$GET(C)
QUIT ""
+3 SET (H,D)=0
KILL O
+4 FOR
SET H=$ORDER(^AUTTHF("AC",C,H))
IF '+H
QUIT
Begin DoDot:1
+5 IF '$DATA(^AUPNVHF("AA",P,H))
QUIT
+6 SET D=""
FOR
SET D=$ORDER(^AUPNVHF("AA",P,H,D))
IF D'=+D
QUIT
Begin DoDot:2
+7 ;after time frame
IF (9999999-D)>EDATE
QUIT
+8 ;before time frame
IF (9999999-D)<BDATE
QUIT
+9 SET O(D)=$ORDER(^AUPNVHF("AA",P,H,D,""))
End DoDot:2
+10 QUIT
End DoDot:1
+11 SET D=$ORDER(O(0))
+12 IF D=""
QUIT D
+13 QUIT $$VAL^XBDIQ1(9000010.23,O(D),.01)_"^"_$$DATE^BGP2UTL(9999999-D)_U_(9999999-D)
+14 ;
ALREF(P,BDATE,EDATE) ;EP
+1 ;add Refusal for exam 35
+2 SET G=$$REFUSAL^BGP2UTL1(P,9999999.15,$ORDER(^AUTTEXAM("C",35,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
+3 IF $PIECE(G,U)=1
QUIT 1_"^Refused Ex 35^"_$$DATE^BGP2UTL($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 ""
