BGP8D5 ; IHS/CMI/LAB - measure calc ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
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>13,BGPAGEB<47,BGPACTUP S BGPD5=1
I BGPAGEB>13,BGPAGEB<47,BGPACTCL S BGPD4=1
DV ;EP - called from elder care
S BGPDVEX=$$DVEX(DFN,BGPBDATE,BGPEDATE) I $P(BGPDVEX,U)=1 S BGPN2=1 ;EXAM ONLY
S BGPDVDX=$$DVDX(DFN,BGPBDATE,BGPEDATE) I $P(BGPDVDX,U)=1 S BGPN3=1 ;DX ONLY
S BGPDVPED=$$DVPED(DFN,BGPBDATE,BGPEDATE) I $P(BGPDVPED,U)=1 S BGPN4=1,BGPN8=1 ;W/O V61.11
S BGPDVCOU=$$DV61(DFN,BGPBDATE,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^BGP8UTL($P(BGPDVEX,U,2))_" "_$P(BGPDVEX,U,4)
I $P(BGPDVDX,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; DX: ",1:"DX: ")_$$DATE^BGP8UTL($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^BGP8UTL($P(BGPDVPED,U,2))_" "_$P(BGPDVPED,U,4)
I $P(BGPDVCOU,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; COUNSEL ",1:"COUNSEL ")_$$DATE^BGP8UTL($P(BGPDVCOU,U,2))_" "_$P(BGPDVCOU,U,4)
I BGPRTYPE'=1,$P(BGPDVREF,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:"")_$$DATE^BGP8UTL($P(BGPDVREF,U,2))_" "_$P(BGPDVREF,U,3)
S BGPVALUD="" I BGPD4 S BGPVALUD="AC"_"|||" D
.I $P(BGPDVEX,U)=1 S BGPVALUD=BGPVALUD_"EXAM: "_$$DATE^BGP8UTL($P(BGPDVEX,U,2))_" "_$P(BGPDVEX,U,4)
.I $P(BGPDVDX,U)=1 S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; DX: ",1:"DX: ")_$$DATE^BGP8UTL($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^BGP8UTL($P(BGPDVPED,U,2))_" "_$P(BGPDVPED,U,4)
.I $P(BGPDVCOU,U)=1 S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; COUNSEL ",1:"COUNSEL ")_$$DATE^BGP8UTL($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^BGP8UTL($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^BGP8UTL((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^BGP8UTL1(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^BGP8D54
;
DVPED(P,BDATE,EDATE) ;EP
NEW BGPG,Y,X,BGPLDV,E,D,T,S,BGPV,SN
K BGPG
S Y="BGPG(",BGPLDV=""
S SN=$O(^BGPSNOMR("B","IPV/DV PATIENT ED",0))
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^BGP8UTL($P(BGPG(X),U)) Q
.S S=$P(T,"-",1)
.S S=$$ICDDX^BGP8UTL2(S)
.I $P(S,U,1)'="-1",$$ICD^BGP8UTL2($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^BGP8UTL($P(BGPG(X),U)) Q
.I $P(T,"-",1)]"",$D(^BGPSNOMR(SN,11,"B",$P(T,"-",1))) S BGPLDV=1_"^"_$P(BGPG(X),U)_"^PED "_T_U_"PED "_T_U_$$DATE^BGP8UTL($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^BGP8UTL((9999999-$P(D,".")))
..S S=$P(T,"-",1)
..S S=$$ICDDX^BGP8UTL2(S)
..I $P(S,U,1)'="-1",$$ICD^BGP8UTL2($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^BGP8UTL((9999999-$P(D,".")))
..I $P(T,"-",1)]"",$D(^BGPSNOMR(SN,11,"B",$P(T,"-",1))) S BGPLDV=1_"^"_(9999999-$P(D,"."))_"^BH PED "_T_U_"BH PED "_T_U_$$DATE^BGP8UTL((9999999-$P(D,"."))) Q
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^BGP8UTL($P(BGPG(1),U))
Q BGPLDV
ALPRC(P,BDATE,EDATE) ;EP
S BGPG=$$LASTPRC^BGP8UTL1(P,"BGP ALCOHOL PROCEDURES",BDATE,EDATE)
I BGPG Q 1_U_"Proc "_$P(BGPG,U,2)_U_$$DATE^BGP8UTL($P(BGPG,U,3))_U_$P(BGPG,U,3)
Q ""
ALPED(P,BDATE,EDATE) ;EP
NEW BGPG
NEW X,Y,D,E,T,%,S,BGPLPED,SN
S Y="BGPG(",BGPLPED=""
S SN=$O(^BGPSNOMR("B","ALCOHOL SCREEN PATIENT ED",0))
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
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^BGP8UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)
.S S=$P(T,"-",1)
.S S=$$ICDDX^BGP8UTL2(S)
.I $P(S,U,1)'="-1",$$ICD^BGP8UTL2($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^BGP8UTL($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^BGP8UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)
.I $P(T,"-")]"",$D(^BGPSNOMR(SN,11,"B",$P(T,"-"))),$P(BGPLPED,U,4)<$P(BGPG(X),U) D
..S BGPLPED=1_U_T_U_$$DATE^BGP8UTL($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^BGP8UTL((9999999-D))_U_(9999999-D)
..S S=$P(T,"-",1)
..S S=$$ICDDX^BGP8UTL2(S)
..I $P(S,U,1)'="-1",$$ICD^BGP8UTL2($P(S,U,1),$O(^ATXAX("B","BGP ALCOHOL EDUC DXS",0)),9),$P(BGPLPED,U,4)<(9999999-D) D
...S BGPLPED=1_U_T_U_$$DATE^BGP8UTL((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^BGP8UTL((9999999-D))_U_(9999999-D)
..I $P(T,"-")]"",$D(^BGPSNOMR(SN,11,"B",$P(T,"-"))),$P(BGPLPED,U,4)<(9999999-D) D
...S BGPLPED=1_U_T_U_$$DATE^BGP8UTL((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^BGP8UTL(9999999-D)_U_(9999999-D)
;
ALREF(P,BDATE,EDATE) ;EP
;add Refusal for exam 35
S G=$$REFUSAL^BGP8UTL1(P,9999999.15,$O(^AUTTEXAM("C",35,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
I $P(G,U)=1 Q 1_"^Refused Ex 35^"_$$DATE^BGP8UTL($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 ""
BGP8D5 ; IHS/CMI/LAB - measure calc ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
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 IF BGPAGEB>13
IF BGPAGEB<47
IF BGPACTUP
SET BGPD5=1
+10 IF BGPAGEB>13
IF BGPAGEB<47
IF BGPACTCL
SET BGPD4=1
DV ;EP - called from elder care
+1 ;EXAM ONLY
SET BGPDVEX=$$DVEX(DFN,BGPBDATE,BGPEDATE)
IF $PIECE(BGPDVEX,U)=1
SET BGPN2=1
+2 ;DX ONLY
SET BGPDVDX=$$DVDX(DFN,BGPBDATE,BGPEDATE)
IF $PIECE(BGPDVDX,U)=1
SET BGPN3=1
+3 ;W/O V61.11
SET BGPDVPED=$$DVPED(DFN,BGPBDATE,BGPEDATE)
IF $PIECE(BGPDVPED,U)=1
SET BGPN4=1
SET BGPN8=1
+4 ;include in education for gpra
SET BGPDVCOU=$$DV61(DFN,BGPBDATE,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 ;I 'BGPN1 S BGPDVREF=$$REFDV(DFN,BGP365,BGPEDATE) I $P(BGPDVREF,U)=1 S BGPN5=1
+9 ;I BGPN5 S 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^BGP8UTL($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^BGP8UTL($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^BGP8UTL($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^BGP8UTL($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^BGP8UTL($PIECE(BGPDVREF,U,2))_" "_$PIECE(BGPDVREF,U,3)
+18 SET BGPVALUD=""
IF BGPD4
SET BGPVALUD="AC"_"|||"
Begin DoDot:1
+19 IF $PIECE(BGPDVEX,U)=1
SET BGPVALUD=BGPVALUD_"EXAM: "_$$DATE^BGP8UTL($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^BGP8UTL($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^BGP8UTL($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^BGP8UTL($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^BGP8UTL($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^BGP8UTL((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^BGP8UTL1(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^BGP8D54
+3 ;
DVPED(P,BDATE,EDATE) ;EP
+1 NEW BGPG,Y,X,BGPLDV,E,D,T,S,BGPV,SN
+2 KILL BGPG
+3 SET Y="BGPG("
SET BGPLDV=""
+4 SET SN=$ORDER(^BGPSNOMR("B","IPV/DV PATIENT ED",0))
+5 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+6 IF '$DATA(BGPG(1))
GOTO BHPED
+7 KILL BGPV
SET (X,D,E)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
Begin DoDot:1
+8 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPG(X),U,4),0),U)
+9 IF 'T
QUIT
+10 IF '$DATA(^AUTTEDT(T,0))
QUIT
+11 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+12 IF $PIECE(T,"-",1)="DV"!($PIECE(T,"-",2)="DV")
SET BGPLDV=1_"^"_$PIECE(BGPG(X),U)_"^PED "_T_U_"PED "_T_U_$$DATE^BGP8UTL($PIECE(BGPG(X),U))
QUIT
+13 SET S=$PIECE(T,"-",1)
+14 SET S=$$ICDDX^BGP8UTL2(S)
+15 IF $PIECE(S,U,1)'="-1"
IF $$ICD^BGP8UTL2($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^BGP8UTL($PIECE(BGPG(X),U))
QUIT
+16 IF $PIECE(T,"-",1)]""
IF $DATA(^BGPSNOMR(SN,11,"B",$PIECE(T,"-",1)))
SET BGPLDV=1_"^"_$PIECE(BGPG(X),U)_"^PED "_T_U_"PED "_T_U_$$DATE^BGP8UTL($PIECE(BGPG(X),U))
QUIT
End DoDot:1
+17 ;
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^BGP8UTL((9999999-$PIECE(D,".")))
End DoDot:3
+8 SET S=$PIECE(T,"-",1)
+9 SET S=$$ICDDX^BGP8UTL2(S)
+10 IF $PIECE(S,U,1)'="-1"
IF $$ICD^BGP8UTL2($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^BGP8UTL((9999999-$PIECE(D,".")))
End DoDot:3
+12 IF $PIECE(T,"-",1)]""
IF $DATA(^BGPSNOMR(SN,11,"B",$PIECE(T,"-",1)))
SET BGPLDV=1_"^"_(9999999-$PIECE(D,"."))_"^BH PED "_T_U_"BH PED "_T_U_$$DATE^BGP8UTL((9999999-$PIECE(D,".")))
QUIT
End DoDot:2
End DoDot:1
+13 ;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^BGP8UTL($PIECE(BGPG(1),U))
+5 QUIT BGPLDV
ALPRC(P,BDATE,EDATE) ;EP
+1 SET BGPG=$$LASTPRC^BGP8UTL1(P,"BGP ALCOHOL PROCEDURES",BDATE,EDATE)
+2 IF BGPG
QUIT 1_U_"Proc "_$PIECE(BGPG,U,2)_U_$$DATE^BGP8UTL($PIECE(BGPG,U,3))_U_$PIECE(BGPG,U,3)
+3 QUIT ""
ALPED(P,BDATE,EDATE) ;EP
+1 NEW BGPG
+2 NEW X,Y,D,E,T,%,S,BGPLPED,SN
+3 SET Y="BGPG("
SET BGPLPED=""
+4 SET SN=$ORDER(^BGPSNOMR("B","ALCOHOL SCREEN PATIENT ED",0))
+5 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+6 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)="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^BGP8UTL($PIECE(BGPG(X),U))_U_$PIECE(BGPG(X),U)
+12 SET S=$PIECE(T,"-",1)
+13 SET S=$$ICDDX^BGP8UTL2(S)
+14 IF $PIECE(S,U,1)'="-1"
IF $$ICD^BGP8UTL2($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^BGP8UTL($PIECE(BGPG(X),U))_U_$PIECE(BGPG(X),U)
+15 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
+16 SET BGPLPED=1_U_T_U_$$DATE^BGP8UTL($PIECE(BGPG(X),U))_U_$PIECE(BGPG(X),U)
End DoDot:2
+17 IF $PIECE(T,"-")]""
IF $DATA(^BGPSNOMR(SN,11,"B",$PIECE(T,"-")))
IF $PIECE(BGPLPED,U,4)<$PIECE(BGPG(X),U)
Begin DoDot:2
+18 SET BGPLPED=1_U_T_U_$$DATE^BGP8UTL($PIECE(BGPG(X),U))_U_$PIECE(BGPG(X),U)
End DoDot:2
End DoDot:1
ALMH 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
+1 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
+2 IF 'T
QUIT
+3 IF '$DATA(^AUTTEDT(T,0))
QUIT
+4 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+5 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^BGP8UTL((9999999-D))_U_(9999999-D)
+6 SET S=$PIECE(T,"-",1)
+7 SET S=$$ICDDX^BGP8UTL2(S)
+8 IF $PIECE(S,U,1)'="-1"
IF $$ICD^BGP8UTL2($PIECE(S,U,1),$ORDER(^ATXAX("B","BGP ALCOHOL EDUC DXS",0)),9)
IF $PIECE(BGPLPED,U,4)<(9999999-D)
Begin DoDot:3
+9 SET BGPLPED=1_U_T_U_$$DATE^BGP8UTL((9999999-D))_U_(9999999-D)
End DoDot:3
+10 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
+11 SET BGPLPED=1_U_T_U_$$DATE^BGP8UTL((9999999-D))_U_(9999999-D)
End DoDot:3
+12 IF $PIECE(T,"-")]""
IF $DATA(^BGPSNOMR(SN,11,"B",$PIECE(T,"-")))
IF $PIECE(BGPLPED,U,4)<(9999999-D)
Begin DoDot:3
+13 SET BGPLPED=1_U_T_U_$$DATE^BGP8UTL((9999999-D))_U_(9999999-D)
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT BGPLPED
+15 ;
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^BGP8UTL(9999999-D)_U_(9999999-D)
+14 ;
ALREF(P,BDATE,EDATE) ;EP
+1 ;add Refusal for exam 35
+2 SET G=$$REFUSAL^BGP8UTL1(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^BGP8UTL($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 ""
