BGP4D25 ; IHS/CMI/LAB - measure 6 03 Jun 2014 3:16 PM ;
;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
;
IA ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11)=0
I BGPACTCL,BGPAGEB>7,BGPAGEB<18 S BGPD1=1 ;8-17
I BGPACTCL,BGPAGEB>17 S BGPD2=1 ;>17
I BGPACTCL,BGPAGEB>64 S BGPD3=1 ;65 AND OLDER
I BGPACTUP,BGPAGEB>7,BGPAGEB<18 S BGPD4=1
I BGPACTUP,BGPAGEB>17 S BGPD5=1 ;>17 UP
I BGPACTUP,BGPAGEB>64 S BGPD6=1 ;65 UP
I BGPACTCL,BGPAGEB>11,BGPAGEB<19 S BGPD9=1
I BGPDMD2 S BGPD7=1
I $$CHD^BGP4D729(DFN,BGP365,BGPEDATE),BGPACTCL S BGPIHD=1,BGPD8=1
I BGPACTCB,BGPAGEB>17 S BGPD10=1 ;>17
I BGPACTCB,BGPAGEB>11,BGPAGEB<19 S BGPD11=1
;I BGPRTYPE=4,BGPAGEB<18,'BGPIHD,'BGPDMD2 S BGPSTOP=1 Q ;IF THEY ARE UNDER 18 AND NOT IHD AND NOT DM Q
I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9+BGPD10+BGPD11) S BGPSTOP=1 Q
DEPEP ;EP - called from elder
S BGPVALUE=""
S BGPN3=0 S BGPDEP=$$DEP(DFN,BGPBDATE,BGPEDATE) I $P(BGPDEP,U)=1 S BGPN3=1
S BGPN2=0 S BGPDEPS=$$DEPSCR(DFN,BGPBDATE,BGPEDATE) I $P(BGPDEPS,U)=1 S BGPN2=1
S BGPN5=0 S BGPDEDU=$$DEPEDU(DFN,BGPBDATE,BGPEDATE) I $P(BGPDEDU,U)=1 S BGPN5=1
S BGPN6=0 S BGPSUIC=$$DEPSUIC(DFN,BGPBDATE,BGPEDATE) I $P(BGPSUIC,U)=1 S BGPN6=1
S BGPN10=0 S BGPDEPSD=$$DEPSCRD(DFN,BGPBDATE,BGPEDATE) I $P(BGPDEPSD,U)=1 S BGPN10=1
I BGPN2 S BGPN1=1
I BGPN3 S BGPN1=1
S BGPREF=""
;S BGPN4=0 I 'BGPN1 S BGPREF=$$DEPREF(DFN,BGPBDATE,BGPEDATE) I $P(BGPREF,U)=1 S BGPN4=1
I BGPN4 S BGPN1=1
I BGPN1,'BGPN4 S BGPN7=1
S BGPN8=0 I BGPN2!(BGPN3)!(BGPN6) S BGPN8=1
I BGPN10!(BGPN3)!(BGPN6) S BGPN10=1
S BGPVALUE=""
I (BGPD4+BGPD5+BGPD6) S BGPVALUE="UP"
I (BGPD1+BGPD2+BGPD3) S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":",",1:"")_"AC"
I BGPD7 S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":",",1:"")_"AD"
I BGPD8 S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":",",1:"")_"CHD"
S BGPVALUE=BGPVALUE_"|||"
I BGPDEPS]"" S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":";SCREEN: ",1:"SCREEN: ") S BGPVALUE=BGPVALUE_$P(BGPDEPS,U,3)_" "_$P(BGPDEPS,U,5)
I BGPDEP]"" S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":";DX: ",1:"DX: ") S BGPVALUE=BGPVALUE_$P(BGPDEP,U,2)
I BGPDEDU]"" S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":";PT ED: ",1:"PT ED: ") S BGPVALUE=BGPVALUE_$P(BGPDEDU,U,3)_" "_$P(BGPDEDU,U,2)
I BGPRTYPE'=1,BGPREF]"" S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:"") S BGPVALUE=BGPVALUE_$P(BGPREF,U,3)_" "_$P(BGPREF,U,2)
;I BGPD5!(BGPD9) S BGPVALUD=$S(BGPD5:"AC",BGPD9:"AC",1:"")
I BGPD10!(BGPD11) S BGPVALUD=$G(BGPVALUD)_$S($G(BGPVALUD)]"":",AC+BH",1:"AC+BH")
I $G(BGPVALUD)]"" S BGPVALUD=BGPVALUD_"|||" D
.I BGPDEPSD]"" S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; SCREEN: ",1:"SCREEN: ") S BGPVALUD=BGPVALUD_$P(BGPDEPSD,U,3)_" "_$P(BGPDEPSD,U,5)
.I BGPDEP]"" S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; DX: ",1:"DX: ") S BGPVALUD=BGPVALUD_$P(BGPDEP,U,2)
.I BGPSUIC]"" S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; SUIC DX: ",1:"SUIC DX: ") S BGPVALUD=BGPVALUD_$P(BGPSUIC,U,3)_" "_$P(BGPSUIC,U,2)
K BGPDEP,BGPDEPS,BGPREF,BGPDEDU
Q
;
DEP(P,BDATE,EDATE) ;EP
I $G(P)="" Q ""
NEW BGPG,BGPDEP,BGPV,Y,X,E,D,V,BGPC,BGPP
K BGPG,BGPDEP
S BGPV=""
S Y="BGPG("
S X=P_"^LAST 2 DX [BGP MOOD DISORDERS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(2)) S BGPDEP((9999999-$P(BGPG(1),U)))="",BGPDEP((9999999-$P(BGPG(2),U)))="" Q 1_U_$$DATE^BGP4UTL($P(BGPG(2),U))_" POV "_$P(BGPG(2),U,2)_" + "_$$DATE^BGP4UTL($P(BGPG(1),U))_" POV "_$P(BGPG(1),U,2)_U_U_$P(BGPG(1),U,1)
S BGPC=0 I $D(BGPG(1)) S BGPC=1,BGPV=$P(BGPG(1),U,5),BGPDEP((9999999-$P(BGPG(1),U)))=""
;
S E=9999999-BDATE,D=9999999-EDATE-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC>1) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC>1) D
.S X=0 F S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(BGPC>1) S BGPP=$P($G(^AMHRPRO(X,0)),U) D
..Q:'BGPP
..I $P(^AMHREC(V,0),U,16)]"",BGPV]"",$P(^AMHREC(V,0),U,16)=BGPV Q ;same visit found in pcc
..I $D(BGPDEP(D)) Q ;already got a dx on this date
..S BGPP=$P($G(^AMHPROB(BGPP,0)),U)
..I BGPP=14 S BGPC=BGPC+1,BGPDEP(D)=BGPP Q
..I BGPP=15 S BGPC=BGPC+1,BGPDEP(D)=BGPP Q
..I $E(BGPP,1,3)=296 S BGPC=BGPC+1,BGPDEP(D)=BGPP Q
..I BGPP=291.89 S BGPC=BGPC+1,BGPDEP(D)=BGPP Q
..I BGPP=292.84 S BGPC=BGPC+1,BGPDEP(D)=BGPP Q
..I BGPP="293.83" S BGPC=BGPC+1,BGPDEP(D)=BGPP Q
..I BGPP="301.13" S BGPC=BGPC+1,BGPDEP(D)=BGPP Q
..I BGPP=300.4 S BGPC=BGPC+1,BGPDEP(D)=BGPP Q
..I BGPP="311." S BGPC=BGPC+1,BGPDEP(D)=BGPP Q
..Q
S X=$O(BGPDEP(0)),Y=$O(BGPDEP(X))
I BGPC>1 Q 1_"^"_$$FMTE^XLFDT((9999999-X))_" BH POV "_BGPDEP(X)_" + "_$$FMTE^XLFDT((9999999-Y))_" BH POV "_BGPDEP(Y)_U_U_(9999999-Y)
Q ""
DEPSUIC(P,BDATE,EDATE) ;EP
I $G(P)="" Q ""
NEW BGPV,Y,X,BGPP,BGPC,E,D,V,BGPG
S BGPV=""
S Y="BGPG("
S X=P_"^LAST DX [BGP SUICIDAL IDEATION DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 1_U_"POV "_$P(BGPG(1),U,2)_U_$$DATE^BGP4UTL($P(BGPG(1),U))
;
S BGPC=""
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>1) D
.S X=0 F S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(BGPC>1) S BGPP=$P($G(^AMHRPRO(X,0)),U) D
..Q:'BGPP
..S BGPP=$P($G(^AMHPROB(BGPP,0)),U)
..I BGPP=39 S BGPC=1_U_"BH POV 39"_U_$$DATE^BGP4UTL((9999999-$P(D,".")))
..Q
Q BGPC
DEPSCR(P,BDATE,EDATE) ;EP
NEW BGPDEPS,BGPG,%,E,Y,X,BGPC,D,V,BGPP,T
S BGPDEPS=""
I $G(P)="" Q ""
K BGPG S %=P_"^LAST EXAM 36;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S BGPDEPS=1_"^DEP SCRN^"_$$DATE^BGP4UTL($P(BGPG(1),U))_U_$P(BGPG(1),U)_U_"Ex 36"
K BGPG
S Y="BGPG("
S X=P_"^LAST DX [BGP DEPRESSION SCRN DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)),$P(BGPDEPS,U,4)<$P(BGPG(1),U) S BGPDEPS=1_U_"POV "_$P(BGPG(1),U,2)_" DEP"_U_$$DATE^BGP4UTL($P(BGPG(1),U))_U_$P(BGPG(1),U)_U_"POV "_$P(BGPG(1),U,2)
;CPT CODE ADDED IN 11.1
S Y=$$CPTI^BGP4DU(DFN,BDATE,EDATE,+$$CODEN^ICPTCOD("1220F"))
I Y,$P(BGPDEPS,U,4)<$P(Y,U,2) S BGPDEPS=1_U_"CPT 1220F"_U_$$DATE^BGP4UTL($P(Y,U,2))_U_$P(Y,U,2)_U_"CPT 1220F"
;now add in v measurements
S BGPC=$$LASTITEM^BGP4DU(P,BDATE,EDATE,"MEASUREMENT","PHQ2")
I $P(BGPDEPS,U,4)<$P(BGPC,U,2) S BGPDEPS=1_U_"Meas "_$P(BGPC,U,3)_U_$$DATE^BGP4UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)_U_"Meas "_$P(BGPC,U,3)
S BGPC=$$LASTITEM^BGP4DU(P,BDATE,EDATE,"MEASUREMENT","PHQ9")
I $P(BGPDEPS,U,4)<$P(BGPC,U,2) S BGPDEPS=1_U_"Meas "_$P(BGPC,U,3)_U_$$DATE^BGP4UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)_U_"Meas "_$P(BGPC,U,3)
BHSCR ;
S D=0,BGPC="",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(^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=14.1 S BGPC=1_U_"BH 14.1"_U_$$DATE^BGP4UTL(9999999-D)_U_(9999999-D)_U_"BH POV 14.1" Q
.Q:BGPC
.S X=0 F S X=$O(^AMHRMSR("AD",V,X)) Q:X'=+X!(BGPC) S BGPP=$P($G(^AMHRMSR(X,0)),U) D
..Q:'BGPP
..S BGPP=$P($G(^AUTTMSR(BGPP,0)),U)
..I BGPP="PHQ2"!(BGPP="PHQ9") S BGPC=1_U_"BH "_BGPP_U_$$DATE^BGP4UTL(9999999-D)_U_(9999999-D)_U_"BH Meas "_BGPP
.I $P($G(^AMHREC(V,14)),U,5)="P"!($P($G(^AMHREC(V,14)),U,5)="N") S BGPC=1_U_"BH Dep Exam"_U_$$DATE^BGP4UTL(9999999-D)_U_(9999999-D)_U_"BH Exam 36"
I BGPC]"",$P(BGPDEPS,U,4)<$P(BGPC,U,4) S BGPDEPS=BGPC
;add in measurements
;ANMC
S T=$O(^AUTTHF("B","PRIME MD SCORE",0))
I T="" Q BGPDEPS
S BGPC="" S D=0 F S D=$O(^AUPNVHF("AA",P,T,D)) Q:D'=+D!(BGPC]"") D
.S Y=9999999-D
.Q:Y<BDATE
.Q:Y>EDATE
.S BGPC=1_U_"PRIME MD SCORE HEALTH FACTOR"_U_$$DATE^BGP4UTL(9999999-D)_U_(9999999-D)_U_"PRIME MD SCORE"
.Q
I $P(BGPDEPS,U,4)<$P(BGPC,U,4) S BGPDEPS=BGPC
Q BGPDEPS
DEPSCRD(P,BDATE,EDATE) ;EP
NEW BGPDEPS,BGPG,%,E,Y,X,BGPC,D,V,BGPP,T
S BGPDEPS=""
I $G(P)="" Q ""
K BGPG S %=P_"^LAST EXAM 36;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S BGPDEPS=1_"^DEP SCRN^"_$$DATE^BGP4UTL($P(BGPG(1),U))_U_$P(BGPG(1),U)_U_"Ex 36"
K BGPG
S Y="BGPG("
S X=P_"^LAST DX [BGP DEPRESSION SCRN DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)),$P(BGPDEPS,U,4)<$P(BGPG(1),U) S BGPDEPS=1_U_"POV "_$P(BGPG(1),U,2)_" DEP"_U_$$DATE^BGP4UTL($P(BGPG(1),U))_U_$P(BGPG(1),U)_U_"POV "_$P(BGPG(1),U,2)
;CPT CODE ADDED IN 11.1
S Y=$$CPTI^BGP4DU(DFN,BDATE,EDATE,+$$CODEN^ICPTCOD("1220F"))
I Y,$P(BGPDEPS,U,4)<$P(Y,U,2) S BGPDEPS=1_U_"CPT 1220F"_U_$$DATE^BGP4UTL($P(Y,U,2))_U_$P(Y,U,2)_U_"CPT 1220F"
;now add in v measurements
S BGPC=$$LASTITEM^BGP4DU(P,BDATE,EDATE,"MEASUREMENT","PHQ2")
I $P(BGPDEPS,U,4)<$P(BGPC,U,2) S BGPDEPS=1_U_"Meas "_$P(BGPC,U,3)_U_$$DATE^BGP4UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)_U_"Meas "_$P(BGPC,U,3)
S BGPC=$$LASTITEM^BGP4DU(P,BDATE,EDATE,"MEASUREMENT","PHQ9")
I $P(BGPDEPS,U,4)<$P(BGPC,U,2) S BGPDEPS=1_U_"Meas "_$P(BGPC,U,3)_U_$$DATE^BGP4UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)_U_"Meas "_$P(BGPC,U,3)
S BGPC=$$LASTITEM^BGP4DU(P,BDATE,EDATE,"MEASUREMENT","PHQT")
I $P(BGPDEPS,U,4)<$P(BGPC,U,2) S BGPDEPS=1_U_"Meas "_$P(BGPC,U,3)_U_$$DATE^BGP4UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)_U_"Meas "_$P(BGPC,U,3)
BHSCRD ;
S D=0,BGPC="",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(^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=14.1 S BGPC=1_U_"BH 14.1"_U_$$DATE^BGP4UTL(9999999-D)_U_(9999999-D)_U_"BH POV 14.1" Q
.Q:BGPC
.S X=0 F S X=$O(^AMHRMSR("AD",V,X)) Q:X'=+X!(BGPC) S BGPP=$P($G(^AMHRMSR(X,0)),U) D
..Q:'BGPP
..S BGPP=$P($G(^AUTTMSR(BGPP,0)),U)
..I BGPP="PHQ2"!(BGPP="PHQ9")!(BGPP="PHQT") S BGPC=1_U_"BH "_BGPP_U_$$DATE^BGP4UTL(9999999-D)_U_(9999999-D)_U_"BH Meas "_BGPP
.I $P($G(^AMHREC(V,14)),U,5)="P"!($P($G(^AMHREC(V,14)),U,5)="N") S BGPC=1_U_"BH Dep Exam"_U_$$DATE^BGP4UTL(9999999-D)_U_(9999999-D)_U_"BH Exam 36"
I BGPC]"",$P(BGPDEPS,U,4)<$P(BGPC,U,4) S BGPDEPS=BGPC
;add in measurements
;ANMC
S T=$O(^AUTTHF("B","PRIME MD SCORE",0))
I T="" Q BGPDEPS
S BGPC="" S D=0 F S D=$O(^AUPNVHF("AA",P,T,D)) Q:D'=+D!(BGPC]"") D
.S Y=9999999-D
.Q:Y<BDATE
.Q:Y>EDATE
.S BGPC=1_U_"PRIME MD SCORE HEALTH FACTOR"_U_$$DATE^BGP4UTL(9999999-D)_U_(9999999-D)_U_"PRIME MD SCORE"
.Q
I $P(BGPDEPS,U,4)<$P(BGPC,U,4) S BGPDEPS=BGPC
Q BGPDEPS
DEPREF(P,BDATE,EDATE) ;EP
NEW G
S G=$$REFUSAL^BGP4UTL1(P,9999999.15,$O(^AUTTEXAM("C",36,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
I $P(G,U)=1 Q 1_"^Refused Ex 36^"_$$DATE^BGP4UTL($P(G,U,2))_U_$P(G,U,2)
Q ""
DEPEDU(P,BDATE,EDATE) ;EP
NEW BGPG,Y,X,E,D,T,BGPDEPE,V,BGPC,G,I,Z,S
K BGPG
S Y="BGPG(",BGPDEPE=""
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I '$D(BGPG(1)) G DEPMH
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)="DEP"!($P(T,"-",1)="BH")!($P(T,"-",1)="SB")!($P(T,"-",1)="PDEP"),$P(BGPDEPE,U,4)<$P(BGPG(X),U,1) S BGPDEPE=1_U_""_T_U_$$DATE^BGP4UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)
.S S=$P(T,"-",1)
.S S=$$ICDDX^BGP4UTL2(S)
.I $P(S,U,1)'="-1",$$ICD^BGP4UTL2($P(S,U,1),$O(^ATXAX("B","BGP DEP SCREEN EDUC DXS",0)),9),$P(BGPDEPE,U,4)<$P(BGPG(X),U,1) S BGPDEPE=1_U_""_T_U_$$DATE^BGP4UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)
DEPMH ;
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)
..S S=$P(T,"-",1)
..S S=$$ICDDX^BGP4UTL2(S)
..I $P(S,U,1)'="-1",$$ICD^BGP4UTL2($P(S,U,1),$O(^ATXAX("B","BGP DEP SCREEN EDUC DXS",0)),9) D
...S BGPC=1_U_T_U_$$DATE^BGP4UTL((9999999-D))_U_(9999999-D)
I $P(BGPDEPE,U,4)<$P(BGPC,U,4) S BGPDEPE=BGPC
Q BGPDEPE
BGP4D25 ; IHS/CMI/LAB - measure 6 03 Jun 2014 3:16 PM ;
+1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
+2 ;
IA ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11)=0
+2 ;8-17
IF BGPACTCL
IF BGPAGEB>7
IF BGPAGEB<18
SET BGPD1=1
+3 ;>17
IF BGPACTCL
IF BGPAGEB>17
SET BGPD2=1
+4 ;65 AND OLDER
IF BGPACTCL
IF BGPAGEB>64
SET BGPD3=1
+5 IF BGPACTUP
IF BGPAGEB>7
IF BGPAGEB<18
SET BGPD4=1
+6 ;>17 UP
IF BGPACTUP
IF BGPAGEB>17
SET BGPD5=1
+7 ;65 UP
IF BGPACTUP
IF BGPAGEB>64
SET BGPD6=1
+8 IF BGPACTCL
IF BGPAGEB>11
IF BGPAGEB<19
SET BGPD9=1
+9 IF BGPDMD2
SET BGPD7=1
+10 IF $$CHD^BGP4D729(DFN,BGP365,BGPEDATE)
IF BGPACTCL
SET BGPIHD=1
SET BGPD8=1
+11 ;>17
IF BGPACTCB
IF BGPAGEB>17
SET BGPD10=1
+12 IF BGPACTCB
IF BGPAGEB>11
IF BGPAGEB<19
SET BGPD11=1
+13 ;I BGPRTYPE=4,BGPAGEB<18,'BGPIHD,'BGPDMD2 S BGPSTOP=1 Q ;IF THEY ARE UNDER 18 AND NOT IHD AND NOT DM Q
+14 IF '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9+BGPD10+BGPD11)
SET BGPSTOP=1
QUIT
DEPEP ;EP - called from elder
+1 SET BGPVALUE=""
+2 SET BGPN3=0
SET BGPDEP=$$DEP(DFN,BGPBDATE,BGPEDATE)
IF $PIECE(BGPDEP,U)=1
SET BGPN3=1
+3 SET BGPN2=0
SET BGPDEPS=$$DEPSCR(DFN,BGPBDATE,BGPEDATE)
IF $PIECE(BGPDEPS,U)=1
SET BGPN2=1
+4 SET BGPN5=0
SET BGPDEDU=$$DEPEDU(DFN,BGPBDATE,BGPEDATE)
IF $PIECE(BGPDEDU,U)=1
SET BGPN5=1
+5 SET BGPN6=0
SET BGPSUIC=$$DEPSUIC(DFN,BGPBDATE,BGPEDATE)
IF $PIECE(BGPSUIC,U)=1
SET BGPN6=1
+6 SET BGPN10=0
SET BGPDEPSD=$$DEPSCRD(DFN,BGPBDATE,BGPEDATE)
IF $PIECE(BGPDEPSD,U)=1
SET BGPN10=1
+7 IF BGPN2
SET BGPN1=1
+8 IF BGPN3
SET BGPN1=1
+9 SET BGPREF=""
+10 ;S BGPN4=0 I 'BGPN1 S BGPREF=$$DEPREF(DFN,BGPBDATE,BGPEDATE) I $P(BGPREF,U)=1 S BGPN4=1
+11 IF BGPN4
SET BGPN1=1
+12 IF BGPN1
IF 'BGPN4
SET BGPN7=1
+13 SET BGPN8=0
IF BGPN2!(BGPN3)!(BGPN6)
SET BGPN8=1
+14 IF BGPN10!(BGPN3)!(BGPN6)
SET BGPN10=1
+15 SET BGPVALUE=""
+16 IF (BGPD4+BGPD5+BGPD6)
SET BGPVALUE="UP"
+17 IF (BGPD1+BGPD2+BGPD3)
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":",",1:"")_"AC"
+18 IF BGPD7
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":",",1:"")_"AD"
+19 IF BGPD8
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":",",1:"")_"CHD"
+20 SET BGPVALUE=BGPVALUE_"|||"
+21 IF BGPDEPS]""
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":";SCREEN: ",1:"SCREEN: ")
SET BGPVALUE=BGPVALUE_$PIECE(BGPDEPS,U,3)_" "_$PIECE(BGPDEPS,U,5)
+22 IF BGPDEP]""
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":";DX: ",1:"DX: ")
SET BGPVALUE=BGPVALUE_$PIECE(BGPDEP,U,2)
+23 IF BGPDEDU]""
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":";PT ED: ",1:"PT ED: ")
SET BGPVALUE=BGPVALUE_$PIECE(BGPDEDU,U,3)_" "_$PIECE(BGPDEDU,U,2)
+24 IF BGPRTYPE'=1
IF BGPREF]""
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_$PIECE(BGPREF,U,3)_" "_$PIECE(BGPREF,U,2)
+25 ;I BGPD5!(BGPD9) S BGPVALUD=$S(BGPD5:"AC",BGPD9:"AC",1:"")
+26 IF BGPD10!(BGPD11)
SET BGPVALUD=$GET(BGPVALUD)_$SELECT($GET(BGPVALUD)]"":",AC+BH",1:"AC+BH")
+27 IF $GET(BGPVALUD)]""
SET BGPVALUD=BGPVALUD_"|||"
Begin DoDot:1
+28 IF BGPDEPSD]""
SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; SCREEN: ",1:"SCREEN: ")
SET BGPVALUD=BGPVALUD_$PIECE(BGPDEPSD,U,3)_" "_$PIECE(BGPDEPSD,U,5)
+29 IF BGPDEP]""
SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; DX: ",1:"DX: ")
SET BGPVALUD=BGPVALUD_$PIECE(BGPDEP,U,2)
+30 IF BGPSUIC]""
SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; SUIC DX: ",1:"SUIC DX: ")
SET BGPVALUD=BGPVALUD_$PIECE(BGPSUIC,U,3)_" "_$PIECE(BGPSUIC,U,2)
End DoDot:1
+31 KILL BGPDEP,BGPDEPS,BGPREF,BGPDEDU
+32 QUIT
+33 ;
DEP(P,BDATE,EDATE) ;EP
+1 IF $GET(P)=""
QUIT ""
+2 NEW BGPG,BGPDEP,BGPV,Y,X,E,D,V,BGPC,BGPP
+3 KILL BGPG,BGPDEP
+4 SET BGPV=""
+5 SET Y="BGPG("
+6 SET X=P_"^LAST 2 DX [BGP MOOD DISORDERS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+7 IF $DATA(BGPG(2))
SET BGPDEP((9999999-$PIECE(BGPG(1),U)))=""
SET BGPDEP((9999999-$PIECE(BGPG(2),U)))=""
QUIT 1_U_$$DATE^BGP4UTL($PIECE(BGPG(2),U))_" POV "_$PIECE(BGPG(2),U,2)_" + "_$$DATE^BGP4UTL($PIECE(BGPG(1),U))_" POV "_$PIECE(BGPG(1),U,2)_U_U_$PIECE(BGPG(1),U,1)
+8 SET BGPC=0
IF $DATA(BGPG(1))
SET BGPC=1
SET BGPV=$PIECE(BGPG(1),U,5)
SET BGPDEP((9999999-$PIECE(BGPG(1),U)))=""
+9 ;
+10 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>1)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(BGPC>1)
QUIT
Begin DoDot:1
+11 SET X=0
FOR
SET X=$ORDER(^AMHRPRO("AD",V,X))
IF X'=+X!(BGPC>1)
QUIT
SET BGPP=$PIECE($GET(^AMHRPRO(X,0)),U)
Begin DoDot:2
+12 IF 'BGPP
QUIT
+13 ;same visit found in pcc
IF $PIECE(^AMHREC(V,0),U,16)]""
IF BGPV]""
IF $PIECE(^AMHREC(V,0),U,16)=BGPV
QUIT
+14 ;already got a dx on this date
IF $DATA(BGPDEP(D))
QUIT
+15 SET BGPP=$PIECE($GET(^AMHPROB(BGPP,0)),U)
+16 IF BGPP=14
SET BGPC=BGPC+1
SET BGPDEP(D)=BGPP
QUIT
+17 IF BGPP=15
SET BGPC=BGPC+1
SET BGPDEP(D)=BGPP
QUIT
+18 IF $EXTRACT(BGPP,1,3)=296
SET BGPC=BGPC+1
SET BGPDEP(D)=BGPP
QUIT
+19 IF BGPP=291.89
SET BGPC=BGPC+1
SET BGPDEP(D)=BGPP
QUIT
+20 IF BGPP=292.84
SET BGPC=BGPC+1
SET BGPDEP(D)=BGPP
QUIT
+21 IF BGPP="293.83"
SET BGPC=BGPC+1
SET BGPDEP(D)=BGPP
QUIT
+22 IF BGPP="301.13"
SET BGPC=BGPC+1
SET BGPDEP(D)=BGPP
QUIT
+23 IF BGPP=300.4
SET BGPC=BGPC+1
SET BGPDEP(D)=BGPP
QUIT
+24 IF BGPP="311."
SET BGPC=BGPC+1
SET BGPDEP(D)=BGPP
QUIT
+25 QUIT
End DoDot:2
End DoDot:1
+26 SET X=$ORDER(BGPDEP(0))
SET Y=$ORDER(BGPDEP(X))
+27 IF BGPC>1
QUIT 1_"^"_$$FMTE^XLFDT((9999999-X))_" BH POV "_BGPDEP(X)_" + "_$$FMTE^XLFDT((9999999-Y))_" BH POV "_BGPDEP(Y)_U_U_(9999999-Y)
+28 QUIT ""
DEPSUIC(P,BDATE,EDATE) ;EP
+1 IF $GET(P)=""
QUIT ""
+2 NEW BGPV,Y,X,BGPP,BGPC,E,D,V,BGPG
+3 SET BGPV=""
+4 SET Y="BGPG("
+5 SET X=P_"^LAST DX [BGP SUICIDAL IDEATION DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+6 IF $DATA(BGPG(1))
QUIT 1_U_"POV "_$PIECE(BGPG(1),U,2)_U_$$DATE^BGP4UTL($PIECE(BGPG(1),U))
+7 ;
+8 SET BGPC=""
+9 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>1)
QUIT
Begin DoDot:1
+10 SET X=0
FOR
SET X=$ORDER(^AMHRPRO("AD",V,X))
IF X'=+X!(BGPC>1)
QUIT
SET BGPP=$PIECE($GET(^AMHRPRO(X,0)),U)
Begin DoDot:2
+11 IF 'BGPP
QUIT
+12 SET BGPP=$PIECE($GET(^AMHPROB(BGPP,0)),U)
+13 IF BGPP=39
SET BGPC=1_U_"BH POV 39"_U_$$DATE^BGP4UTL((9999999-$PIECE(D,".")))
+14 QUIT
End DoDot:2
End DoDot:1
+15 QUIT BGPC
DEPSCR(P,BDATE,EDATE) ;EP
+1 NEW BGPDEPS,BGPG,%,E,Y,X,BGPC,D,V,BGPP,T
+2 SET BGPDEPS=""
+3 IF $GET(P)=""
QUIT ""
+4 KILL BGPG
SET %=P_"^LAST EXAM 36;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+5 IF $DATA(BGPG(1))
SET BGPDEPS=1_"^DEP SCRN^"_$$DATE^BGP4UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U)_U_"Ex 36"
+6 KILL BGPG
+7 SET Y="BGPG("
+8 SET X=P_"^LAST DX [BGP DEPRESSION SCRN DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+9 IF $DATA(BGPG(1))
IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPG(1),U)
SET BGPDEPS=1_U_"POV "_$PIECE(BGPG(1),U,2)_" DEP"_U_$$DATE^BGP4UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U)_U_"POV "_$PIECE(BGPG(1),U,2)
+10 ;CPT CODE ADDED IN 11.1
+11 SET Y=$$CPTI^BGP4DU(DFN,BDATE,EDATE,+$$CODEN^ICPTCOD("1220F"))
+12 IF Y
IF $PIECE(BGPDEPS,U,4)<$PIECE(Y,U,2)
SET BGPDEPS=1_U_"CPT 1220F"_U_$$DATE^BGP4UTL($PIECE(Y,U,2))_U_$PIECE(Y,U,2)_U_"CPT 1220F"
+13 ;now add in v measurements
+14 SET BGPC=$$LASTITEM^BGP4DU(P,BDATE,EDATE,"MEASUREMENT","PHQ2")
+15 IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPC,U,2)
SET BGPDEPS=1_U_"Meas "_$PIECE(BGPC,U,3)_U_$$DATE^BGP4UTL($PIECE(BGPC,U,2))_U_$PIECE(BGPC,U,2)_U_"Meas "_$PIECE(BGPC,U,3)
+16 SET BGPC=$$LASTITEM^BGP4DU(P,BDATE,EDATE,"MEASUREMENT","PHQ9")
+17 IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPC,U,2)
SET BGPDEPS=1_U_"Meas "_$PIECE(BGPC,U,3)_U_$$DATE^BGP4UTL($PIECE(BGPC,U,2))_U_$PIECE(BGPC,U,2)_U_"Meas "_$PIECE(BGPC,U,3)
BHSCR ;
+1 SET D=0
SET BGPC=""
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(^AMHRPRO("AD",V,X))
IF X'=+X!(BGPC)
QUIT
SET BGPP=$PIECE($GET(^AMHRPRO(X,0)),U)
Begin DoDot:2
+3 IF 'BGPP
QUIT
+4 SET BGPP=$PIECE($GET(^AMHPROB(BGPP,0)),U)
+5 IF BGPP=14.1
SET BGPC=1_U_"BH 14.1"_U_$$DATE^BGP4UTL(9999999-D)_U_(9999999-D)_U_"BH POV 14.1"
QUIT
End DoDot:2
+6 IF BGPC
QUIT
+7 SET X=0
FOR
SET X=$ORDER(^AMHRMSR("AD",V,X))
IF X'=+X!(BGPC)
QUIT
SET BGPP=$PIECE($GET(^AMHRMSR(X,0)),U)
Begin DoDot:2
+8 IF 'BGPP
QUIT
+9 SET BGPP=$PIECE($GET(^AUTTMSR(BGPP,0)),U)
+10 IF BGPP="PHQ2"!(BGPP="PHQ9")
SET BGPC=1_U_"BH "_BGPP_U_$$DATE^BGP4UTL(9999999-D)_U_(9999999-D)_U_"BH Meas "_BGPP
End DoDot:2
+11 IF $PIECE($GET(^AMHREC(V,14)),U,5)="P"!($PIECE($GET(^AMHREC(V,14)),U,5)="N")
SET BGPC=1_U_"BH Dep Exam"_U_$$DATE^BGP4UTL(9999999-D)_U_(9999999-D)_U_"BH Exam 36"
End DoDot:1
+12 IF BGPC]""
IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPC,U,4)
SET BGPDEPS=BGPC
+13 ;add in measurements
+14 ;ANMC
+15 SET T=$ORDER(^AUTTHF("B","PRIME MD SCORE",0))
+16 IF T=""
QUIT BGPDEPS
+17 SET BGPC=""
SET D=0
FOR
SET D=$ORDER(^AUPNVHF("AA",P,T,D))
IF D'=+D!(BGPC]"")
QUIT
Begin DoDot:1
+18 SET Y=9999999-D
+19 IF Y<BDATE
QUIT
+20 IF Y>EDATE
QUIT
+21 SET BGPC=1_U_"PRIME MD SCORE HEALTH FACTOR"_U_$$DATE^BGP4UTL(9999999-D)_U_(9999999-D)_U_"PRIME MD SCORE"
+22 QUIT
End DoDot:1
+23 IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPC,U,4)
SET BGPDEPS=BGPC
+24 QUIT BGPDEPS
DEPSCRD(P,BDATE,EDATE) ;EP
+1 NEW BGPDEPS,BGPG,%,E,Y,X,BGPC,D,V,BGPP,T
+2 SET BGPDEPS=""
+3 IF $GET(P)=""
QUIT ""
+4 KILL BGPG
SET %=P_"^LAST EXAM 36;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+5 IF $DATA(BGPG(1))
SET BGPDEPS=1_"^DEP SCRN^"_$$DATE^BGP4UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U)_U_"Ex 36"
+6 KILL BGPG
+7 SET Y="BGPG("
+8 SET X=P_"^LAST DX [BGP DEPRESSION SCRN DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+9 IF $DATA(BGPG(1))
IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPG(1),U)
SET BGPDEPS=1_U_"POV "_$PIECE(BGPG(1),U,2)_" DEP"_U_$$DATE^BGP4UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U)_U_"POV "_$PIECE(BGPG(1),U,2)
+10 ;CPT CODE ADDED IN 11.1
+11 SET Y=$$CPTI^BGP4DU(DFN,BDATE,EDATE,+$$CODEN^ICPTCOD("1220F"))
+12 IF Y
IF $PIECE(BGPDEPS,U,4)<$PIECE(Y,U,2)
SET BGPDEPS=1_U_"CPT 1220F"_U_$$DATE^BGP4UTL($PIECE(Y,U,2))_U_$PIECE(Y,U,2)_U_"CPT 1220F"
+13 ;now add in v measurements
+14 SET BGPC=$$LASTITEM^BGP4DU(P,BDATE,EDATE,"MEASUREMENT","PHQ2")
+15 IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPC,U,2)
SET BGPDEPS=1_U_"Meas "_$PIECE(BGPC,U,3)_U_$$DATE^BGP4UTL($PIECE(BGPC,U,2))_U_$PIECE(BGPC,U,2)_U_"Meas "_$PIECE(BGPC,U,3)
+16 SET BGPC=$$LASTITEM^BGP4DU(P,BDATE,EDATE,"MEASUREMENT","PHQ9")
+17 IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPC,U,2)
SET BGPDEPS=1_U_"Meas "_$PIECE(BGPC,U,3)_U_$$DATE^BGP4UTL($PIECE(BGPC,U,2))_U_$PIECE(BGPC,U,2)_U_"Meas "_$PIECE(BGPC,U,3)
+18 SET BGPC=$$LASTITEM^BGP4DU(P,BDATE,EDATE,"MEASUREMENT","PHQT")
+19 IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPC,U,2)
SET BGPDEPS=1_U_"Meas "_$PIECE(BGPC,U,3)_U_$$DATE^BGP4UTL($PIECE(BGPC,U,2))_U_$PIECE(BGPC,U,2)_U_"Meas "_$PIECE(BGPC,U,3)
BHSCRD ;
+1 SET D=0
SET BGPC=""
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(^AMHRPRO("AD",V,X))
IF X'=+X!(BGPC)
QUIT
SET BGPP=$PIECE($GET(^AMHRPRO(X,0)),U)
Begin DoDot:2
+3 IF 'BGPP
QUIT
+4 SET BGPP=$PIECE($GET(^AMHPROB(BGPP,0)),U)
+5 IF BGPP=14.1
SET BGPC=1_U_"BH 14.1"_U_$$DATE^BGP4UTL(9999999-D)_U_(9999999-D)_U_"BH POV 14.1"
QUIT
End DoDot:2
+6 IF BGPC
QUIT
+7 SET X=0
FOR
SET X=$ORDER(^AMHRMSR("AD",V,X))
IF X'=+X!(BGPC)
QUIT
SET BGPP=$PIECE($GET(^AMHRMSR(X,0)),U)
Begin DoDot:2
+8 IF 'BGPP
QUIT
+9 SET BGPP=$PIECE($GET(^AUTTMSR(BGPP,0)),U)
+10 IF BGPP="PHQ2"!(BGPP="PHQ9")!(BGPP="PHQT")
SET BGPC=1_U_"BH "_BGPP_U_$$DATE^BGP4UTL(9999999-D)_U_(9999999-D)_U_"BH Meas "_BGPP
End DoDot:2
+11 IF $PIECE($GET(^AMHREC(V,14)),U,5)="P"!($PIECE($GET(^AMHREC(V,14)),U,5)="N")
SET BGPC=1_U_"BH Dep Exam"_U_$$DATE^BGP4UTL(9999999-D)_U_(9999999-D)_U_"BH Exam 36"
End DoDot:1
+12 IF BGPC]""
IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPC,U,4)
SET BGPDEPS=BGPC
+13 ;add in measurements
+14 ;ANMC
+15 SET T=$ORDER(^AUTTHF("B","PRIME MD SCORE",0))
+16 IF T=""
QUIT BGPDEPS
+17 SET BGPC=""
SET D=0
FOR
SET D=$ORDER(^AUPNVHF("AA",P,T,D))
IF D'=+D!(BGPC]"")
QUIT
Begin DoDot:1
+18 SET Y=9999999-D
+19 IF Y<BDATE
QUIT
+20 IF Y>EDATE
QUIT
+21 SET BGPC=1_U_"PRIME MD SCORE HEALTH FACTOR"_U_$$DATE^BGP4UTL(9999999-D)_U_(9999999-D)_U_"PRIME MD SCORE"
+22 QUIT
End DoDot:1
+23 IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPC,U,4)
SET BGPDEPS=BGPC
+24 QUIT BGPDEPS
DEPREF(P,BDATE,EDATE) ;EP
+1 NEW G
+2 SET G=$$REFUSAL^BGP4UTL1(P,9999999.15,$ORDER(^AUTTEXAM("C",36,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
+3 IF $PIECE(G,U)=1
QUIT 1_"^Refused Ex 36^"_$$DATE^BGP4UTL($PIECE(G,U,2))_U_$PIECE(G,U,2)
+4 QUIT ""
DEPEDU(P,BDATE,EDATE) ;EP
+1 NEW BGPG,Y,X,E,D,T,BGPDEPE,V,BGPC,G,I,Z,S
+2 KILL BGPG
+3 SET Y="BGPG("
SET BGPDEPE=""
+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 DEPMH
+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)="DEP"!($PIECE(T,"-",1)="BH")!($PIECE(T,"-",1)="SB")!($PIECE(T,"-",1)="PDEP")
IF $PIECE(BGPDEPE,U,4)<$PIECE(BGPG(X),U,1)
SET BGPDEPE=1_U_""_T_U_$$DATE^BGP4UTL($PIECE(BGPG(X),U))_U_$PIECE(BGPG(X),U)
+12 SET S=$PIECE(T,"-",1)
+13 SET S=$$ICDDX^BGP4UTL2(S)
+14 IF $PIECE(S,U,1)'="-1"
IF $$ICD^BGP4UTL2($PIECE(S,U,1),$ORDER(^ATXAX("B","BGP DEP SCREEN EDUC DXS",0)),9)
IF $PIECE(BGPDEPE,U,4)<$PIECE(BGPG(X),U,1)
SET BGPDEPE=1_U_""_T_U_$$DATE^BGP4UTL($PIECE(BGPG(X),U))_U_$PIECE(BGPG(X),U)
End DoDot:1
DEPMH ;
+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!(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 SET S=$PIECE(T,"-",1)
+7 SET S=$$ICDDX^BGP4UTL2(S)
+8 IF $PIECE(S,U,1)'="-1"
IF $$ICD^BGP4UTL2($PIECE(S,U,1),$ORDER(^ATXAX("B","BGP DEP SCREEN EDUC DXS",0)),9)
Begin DoDot:3
+9 SET BGPC=1_U_T_U_$$DATE^BGP4UTL((9999999-D))_U_(9999999-D)
End DoDot:3
End DoDot:2
End DoDot:1
+10 IF $PIECE(BGPDEPE,U,4)<$PIECE(BGPC,U,4)
SET BGPDEPE=BGPC
+11 QUIT BGPDEPE
