BUDBRP6Q ; IHS/CMI/LAB - HIV/DEP ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
L ;EP - NEW HIV
NEW BUDGOT,BUDDOA
S BUDGOT=""
S BUDDOB=$P(^DPT(DFN,0),U,3)
Q:BUDMEDV<1
S BUDX28TH=$E(BUDDOB,1,3)+18_$E(BUDDOB,4,7)
K BUDG
S Y="BUDG("
S X=DFN_"^FIRST DX [BUD HIV DXS" S E=$$START1^APCLDF(X,Y)
I '$D(BUDG(1)) Q ;NO HIV DXS
S BUDHIVD=$P(BUDG(1),U,1)
S BUDHIVDX=$P(BUDG(1),U,2)
S D=($E(BUDBD,1,3)-1)_"1001"
S E=$E(BUDED,1,3)_"0930"
I BUDHIVD<D Q
I BUDHIVD>E Q
S BUDDOA=""
;now check problem list date of onset, if date of onset is prior to the report period quit
S T=$O(^ATXAX("B","BUD HIV DXS",0))
S (X,G)=0,Z="" F S X=$O(^AUPNPROB("AC",DFN,X)) Q:X'=+X D
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,13)="" ;no date of onset so don't bother
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^ATXCHK(Y,T,9)
.S BUDDOA=$P(^AUPNPROB(X,0),U,13)
.I $P(^AUPNPROB(X,0),U,13)<BUDHIVD S G=1
.Q
I G Q
S BUDHIVF=$$FU(DFN,$$FMADD^XLFDT(BUDHIVD,1))
I BUDHIVF S BUDSECTL("HIV")=$G(BUDSECTL("HIV"))+1
S ;put the rest in demoninator
S BUDSECTL("PTS")=$G(BUDSECTL("PTS"))+1 D
.I $G(BUDHIV2L) D
..I BUDHIVF="" S ^XTMP("BUDBRP6B",BUDJ,BUDH,"HIV2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)="First HIV: "_BUDHIVDX_": "_$$DATE^BUDBUTL1(BUDHIVD)_"|Follow-up: "_$P(BUDHIVF,U,2)_" "_$$DATE^BUDBUTL1($P(BUDHIVF,U,1))_"|"_$$DATE^BUDBUTL1(BUDDOA)
.I $G(BUDHIV1L) D
..I BUDHIVF]"" S ^XTMP("BUDBRP6B",BUDJ,BUDH,"HIV1",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)="First HIV: "_BUDHIVDX_": "_$$DATE^BUDBUTL1(BUDHIVD)_"|Follow-up: "_$P(BUDHIVF,U,2)_" "_$$DATE^BUDBUTL1($P(BUDHIVF,U,1))_"|"_$$DATE^BUDBUTL1(BUDDOA)
Q
FU(P,BD) ;WAS THERE AN HIV VISIT WITHIN 90 DAYS OF BD
NEW BUDVS
S ED=$$FMADD^XLFDT(BD,90)
D ALLV^APCLAPIU(P,BD,ED,"BUDVS")
I '$D(BUDVS) Q ""
NEW X,Y,V,G,D,C,T,L1,L2,L3
S G=""
S X=0 F S X=$O(BUDVS(X)) Q:X'=+X!(G) D
.S V=$P(BUDVS(X),U,5)
.S C=$$CLINIC^APCLV(V,"C") I C=59 S G=$P(BUDVS(X),U,1)_U_"Clinic: 59" Q
.S D=$$PRIMPOV^APCLV(V,"I")
.I $$ICD^ATXCHK(D,$O(^ATXAX("B","BUD HIV FU DXS",0)),9) S G=$P(BUDVS(X),U,1)_U_"DX: "_$P(^ICD9(D,0),U,1) Q
.S C=0 F S C=$O(^AUPNVCPT("AD",V,C)) Q:C'=+C!(G) D
..S T=$$VALI^XBDIQ1(9000010.18,C,.01)
..I $$ICD^ATXCHK(T,$O(^ATXAX("B","BUD HIV FU CPTS",0)),1) S G=$P(BUDVS(X),U,1)_U_"CPT: "_$P(^ICPT(T,0),U,1) Q
.S L1=$O(^ATXLAB("B","BGP HIV TEST TAX",0))
.S L2=$O(^ATXLAB("B","BGP CD4 TAX",0))
.S L3=$O(^ATXLAB("B","BGP HIV VIRAL LOAD TAX",0))
.S C=0 F S C=$O(^AUPNVLAB("AD",V,C)) Q:C'=+C!(G) D
..S T=$$VALI^XBDIQ1(9000010.09,C,.01)
..I L1,$D(^ATXLAB(L1,21,"B",T)) S G=$P(BUDVS(X),U,1)_U_"LAB: "_$P(^LAB(60,T,0),U,1) Q
..I L2,$D(^ATXLAB(L2,21,"B",T)) S G=$P(BUDVS(X),U,1)_U_"LAB: "_$P(^LAB(60,T,0),U,1) Q
..I L3,$D(^ATXLAB(L3,21,"B",T)) S G=$P(BUDVS(X),U,1)_U_"LAB: "_$P(^LAB(60,T,0),U,1) Q
Q G
M ;EP
NEW BUDGOT
S BUDGOT=""
S BUDDOB=$P(^DPT(DFN,0),U,3)
Q:BUDMEDV<1
S BUDX12RB=($E(BUDBD,1,3)-12)_"1231"
Q:BUDDOB>BUDX12RB
S BUDP12BD=($E(BUDDOB,1,3)+12)_$E(BUDDOB,4,7)
K BUDG
;DENOMINATOR EXCLUSION, ANY ONE WITH ACTIVE PL ENTRY OF THE DX OR SNOMED
Q:$$HASDEPPL(DFN) ;pcc or bh problem list
Q:$$HASDEPOV(DFN,BUDBD,BUDED) ;PCC DX DURING REPORT PERIOD
S BUDSECTM("PTS")=$G(BUDSECTM("PTS"))+1 ;DENOMINATOR
;DO THEY HAVE A SCREEN?
;CHECK exam, phq2, phq9, phqt for a positive and if no positive get the first negative
S (BUDSCR,BUDPLAN)=""
S BUDSCR=$$DEPRES(DFN,BUDBD,BUDED)
I BUDSCR]"" G R
;now check for any without a result and assume negative (per Duane)
S BUDSCR=$$DEPNORES(DFN,BUDBD,BUDED)
R ;
S BUDN=0
I BUDSCR="" G M1
I $P(BUDSCR,U,3)["NEG" S BUDSECTM("DEP")=$G(BUDSECTM("DEP"))+1 S BUDN=1 G M1
;CHECK FOR PLAN
S BUDPLAN=$$PLAN(DFN,$P(BUDSCR,U,1),BUDED) ;PLAN BETWEEN DATE OF SCREEN AND END OF REPORT PERIOD
I BUDPLAN]"" S BUDSECTM("DEP")=$G(BUDSECTM("DEP"))+1,BUDN=1
M1 ;LISTS
D
.I $G(BUDDEP2L),'BUDN D
..S ^XTMP("BUDBRP6B",BUDJ,BUDH,"DEP2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=BUDSCR_"|"_BUDPLAN
.I $G(BUDDEP1L),BUDN D
..S ^XTMP("BUDBRP6B",BUDJ,BUDH,"DEP1",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=BUDSCR_"|"_BUDPLAN
Q
PLAN(P,BDATE,EDATE) ;
;CHECK MEDS, CPTS, SNOMEDS
NEW BUDVS,BUDDEPS,BUDV,BUDX,BUDA,BUDB,BUDP,BUDY,X,T,Y,A,B,J,D,R,K,BUDRX,BUDRXRF,BUDXRX,BUDNORM
;BGPDEPS=DATE SCREEN^SCREEN ITEM^SCREEN RESULT^FU PLAN ITEM
S BUDVS="BUDVS"
D ALLV^APCLAPIU(P,BDATE,EDATE,.BUDVS)
S BUDX=0,BUDC=0,BUDDEPS=""
S B=$O(^BUDBCNTL("B","DEPRESSION INTERVENTION SNOMED",0))
S T=$O(^BUDBCNTL("B","BUD RX NORM DEPRESSION",0))
S J=$O(^ATXAX("B","BGP HEDIS ANTIDEPRESSANT MEDS",0))
S K=$O(^ATXAX("B","BGP HEDIS ANTIDEPRESSANT NDC",0))
F S BUDX=$O(BUDVS(BUDX)) Q:BUDX'=+BUDX!(BUDDEPS]"") D
.;DX/snomed
.S BUDV=$P(BUDVS(BUDX),U,5)
.S BUDY=0 F S BUDY=$O(^AUPNVPOV("AD",BUDV,BUDY)) Q:BUDY'=+BUDY!(BUDDEPS]"") D
..Q:'$D(^AUPNVPOV(BUDY,0))
..;Q:'$$ICD^ATXCHK($P(^AUPNVPOV(BUDY,0),U),$O(^ATXAX("B","BUD DEPRESSION SCRN DXS",0)),9)
..;NOW CHECK SNOMED
..S A=$P($G(^AUPNVPOV(BUDY,11)),U,1)
..Q:A=""
..I $D(^BUDBCNTL(B,11,"B",A)) S BUDDEPS=$$VD^APCLV(BUDV)_U_"SNOMED: "_A Q
.;CPT
.S BUDY=0 F S BUDY=$O(^AUPNVCPT("AD",BUDV,BUDY)) Q:BUDY'=+BUDY!(BUDDEPS]"") D
..Q:'$D(^AUPNVCPT(BUDY,0))
..Q:'$$ICD^ATXCHK($P(^AUPNVCPT(BUDY,0),U),$O(^ATXAX("B","BUD DEP INTERVENTION CPTS",0)),1)
..S BUDDEPS=$$VD^APCLV(BUDV)_U_"CPT: "_$$GET1^DIQ(9000010.18,BUDY,.01)
.;NOW CHECK MEDS
.S BUDY=0 F S BUDY=$O(^AUPNVMED("AD",BUDV,BUDY)) Q:BUDY'=+BUDY!(BUDDEPS]"") D
..Q:'$D(^AUPNVMED(BUDY,0))
..S D=$P(^AUPNVMED(BUDY,0),U,1)
..Q:D=""
..Q:'$D(^PSDRUG(D,0))
..I $D(^ATXAX(J,21,"B",D)) S BUDDEPS=$$VD^APCLV(BUDV)_U_"RX: "_$$VAL^XBDIQ1(9000010.14,BUDY,.01) Q
..;check NDC
..I $$NDC(D,K) S BUDDEPS=$$VD^APCLV(BUDV)_U_"RX: "_$$VAL^XBDIQ1(9000010.14,BUDY,.01) Q
..;check rxnorm?
..;GET PRESCRIPTION
..S BUDRXRF=""
..S BUDRX=$O(^PSRX("APCC",BUDY,0)) I 'BUDRX Q ;NO 52 ENTRY
..I BUDRX S BUDRXRF=$O(^PSRX("APCC",BUDY,BUDRX,"")) S:BUDRXRF="" BUDRXRF=0
..S BUDNORM=""
..I BUDRXRF S BUDNORM=$P($G(^PSRX(BUDRX,1,BUDRXRF,9999999)),U,19)
..I BUDNORM="" S BUDNORM=$P($G(^PSRX(BUDRX,999999921)),U,7)
..I BUDNORM]"",$D(^BUDBCNTL(T,11,"B",BUDNORM)) S BUDDEPS=$$VD^APCLV(BUDV)_U_"RX NORM: "_$$VAL^XBDIQ1(9000010.14,BUDY,.01) Q
I BUDDEPS]"" Q BUDDEPS
;
S D=0,E=9999999-BDATE,D=9999999-EDATE-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BUDDEPS]"") S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V D
.S X=0 F S X=$O(^AMHRPROC("AD",V,X)) Q:X'=+X S BUDP=$P($G(^AMHRPROC(X,0)),U) D
..Q:'BUDP
..Q:'$$ICD^ATXCHK(BUDP,$O(^ATXAX("B","BUD DEP INTERVENTION CPTS",0)),1)
..S BUDDEPS=9999999-$P(D,".")_U_"BH CPT: "_$$GET1^DIQ(9002011.04,X,.01)
Q BUDDEPS
NDC(A,B) ;
;a is drug ien
;b is taxonomy ien
NEW BUDNDC
S BUDNDC=$P($G(^PSDRUG(A,2)),U,4)
I BUDNDC]"",B,$D(^ATXAX(B,21,"B",BUDNDC)) Q 1
Q 0
DEPRES(P,BD,ED) ;
;DID PT HAVE AN EXAM 36 DURING REPORT PERIOD
NEW %,E,D,V,X,G,BUDC
NEW BUDG,BUDR,BUDALL
S BUDC=0
K BUDG S %=P_"^ALL EXAM 36;DURING "_BD_"-"_ED,E=$$START1^APCLDF(%,"BUDG(")
S E=0 F S E=$O(BUDG(E)) Q:E'=+E D
.S BUDR=$S($P(BUDG(E),U,2)="PO":"POS",$P(BUDG(E),U,2)="RF":"POS",1:"NEG")
.S BUDALL(BUDR,$P(BUDG(E),U,1))=$P(BUDG(E),U,1)_U_"PCC EX 36"_U_BUDR_" "_$P(BUDG(E),U,2) ;W !,P," ",BUDALL(BUDR,$P(BUDG(E),U,1))
;phq2
K BUDG S %=P_"^ALL MEAS PHQ2;DURING "_BD_"-"_ED,E=$$START1^APCLDF(%,"BUDG(") ;ZW BUDG Q ""
S E=0 F S E=$O(BUDG(E)) Q:E'=+E D
.S BUDR=$$MRES($P(BUDG(E),U,3),$P(BUDG(E),U,2))
.S BUDALL($P(BUDR," "),$P(BUDG(E),U,1))=$P(BUDG(E),U,1)_U_"PCC PHQ2"_U_BUDR ;W !,P," ",BUDALL(BUDR,$P(BUDG(E),U,1))
K BUDG S %=P_"^ALL MEAS PHQ9;DURING "_BD_"-"_ED,E=$$START1^APCLDF(%,"BUDG(") ;ZW BUDG Q ""
S E=0 F S E=$O(BUDG(E)) Q:E'=+E D
.S BUDR=$$MRES($P(BUDG(E),U,3),$P(BUDG(E),U,2))
.S BUDALL($P(BUDR," ",1),$P(BUDG(E),U,1))=$P(BUDG(E),U,1)_U_"PCC PHQ9"_U_BUDR ;W !,P," ",BUDALL(BUDR,$P(BUDG(E),U,1))
K BUDG S %=P_"^ALL MEAS PHQT;DURING "_BD_"-"_ED,E=$$START1^APCLDF(%,"BUDG(") ;ZW BUDG Q ""
S E=0 F S E=$O(BUDG(E)) Q:E'=+E D
.S BUDR=$$MRES($P(BUDG(E),U,3),$P(BUDG(E),U,2))
.S BUDALL($P(BUDR," ",1),$P(BUDG(E),U,1))=$P(BUDG(E),U,1)_U_"PCC PHQT"_U_BUDR ;W !,P," ",BUDALL(BUDR,$P(BUDG(E),U,1))
;SNOMED
;ALL POVS
K BUDG S %=P_"^ALL DX;DURING "_BD_"-"_ED,E=$$START1^APCLDF(%,"BUDG(")
S E=0 F S E=$O(BUDG(E)) Q:E'=+E D
.S BUDR=+$P(BUDG(E),U,4)
.I $P($G(^AUPNVPOV(BUDR,11)),U,1)=428181000124104 D
..S BUDALL("POS",$P(BUDG(E),U,1))=$P(BUDG(E),U,1)_U_"SNOMED "_"428181000124104"_U_"POS"
;NOW GO TO BH
;BH EXAM
BHSCR ;
S D=0,E=9999999-BD,D=9999999-ED-1_".9999"
F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V D
.I $P($G(^AMHREC(V,14)),U,5)="N" S I=9999999-$P(D,".") I '$D(BUDALL("NEG",I)) S BUDR="NEG",BUDALL(BUDR,I)=I_U_"BH EX"_U_BUDR
.I $P($G(^AMHREC(V,14)),U,5)="P"!($P($G(^AMHREC(V,14)),U,5)="REF") S I=9999999-$P(D,".") I '$D(BUDALL("POS",I)) S BUDR="POS",BUDALL(BUDR,I)=I_U_"BH EX"_U_BUDR
.S X=0 F S X=$O(^AMHRMSR("AD",V,X)) Q:X'=+X S BUDP=$P($G(^AMHRMSR(X,0)),U) D
..Q:'BUDP
..S BUDP=$P($G(^AUTTMSR(BUDP,0)),U)
..I BUDP="PHQ2"!(BUDP="PHQ9")!(BUDP="PHQT") D
...S BUDR=$$MRES(BUDP,$P(^AMHRMSR(X,0),U,4))
...I '$D(BUDALL($P(BUDR," "),(9999999-$P(D,".")))) D
....S BUDALL($P(BUDR," "),(9999999-$P(D,".")))=(9999999-$P(D,"."))_U_"BH "_BUDP_U_BUDR
I $D(BUDALL("POS")) S X=$O(BUDALL("POS",0)) Q BUDALL("POS",X)
I $D(BUDALL("NEG")) S Y=$O(BUDALL("NEG",0)) Q BUDALL("NEG",Y)
Q ""
PRIMPOV(V) ;
NEW Y,Z,P
S Y=0,Z=""
I $P(^AUPNVSIT(V,0),U,7)="H" F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y I $P(^AUPNVPOV(Y,0),U,12)="P" S Z=Y
I $P(^AUPNVSIT(V,0),U,7)'="H" S Y=$O(^AUPNVPOV("AD",V,0)) I Y S Z=Y
Q Z
HASDEPOV(P,BDATE,EDATE) ;EP - do they have one dx in 6 months prior to beginning of report period
I '$G(P) Q ""
NEW T,B,BUDVS,BUDX,BUDV,BUDDX2,BUDDX3,BUDDX4,BUDDX5
S T=$O(^ATXAX("B","BUD DEPRESSION/BIPOLAR DXS",0))
S B=$O(^BUDBCNTL("B","DEPRESSION SNOMED CODES",0))
S BUDVS="BUDVS",BUDDX4=""
D ALLV^APCLAPIU(P,BDATE,EDATE,.BUDVS)
S BUDX=0 F S BUDX=$O(BUDVS(BUDX)) Q:BUDX'=+BUDX!(BUDDX4) D
.S BUDV=$P(BUDVS(BUDX),U,5)
.S BUDI=$$PRIMPOV(BUDV)
.Q:BUDI=""
.S BUDDX3=$P($G(^AUPNVPOV(BUDI,0)),U)
.Q:BUDDX3=""
.Q:'$D(^ICD9(BUDDX3))
.I $$ICD^ATXCHK(BUDDX3,T,9) S BUDDX4=1_"^"_$P($$ICDDX^ICDCODE(BUDDX3),U,2)_"^"_$$VD^APCLV(BUDV)_"^"_BUDDX3 Q ;FOUND ONE
.;NOW CHECK SNOMED
.S A=$P($G(^AUPNVPOV(BUDI,11)),U,1)
.Q:A=""
.I $D(^BUDBCNTL(B,11,"B",A)) S BUDDX4=1_"^"_$P($$ICDDX^ICDCODE(BUDDX3),U,2)_"^"_$$VD^APCLV(BUDV)_"^"_BUDDX3 Q ;FOUND ONE
.Q
I BUDDX4 Q BUDDX4
S SD=$$FMADD^XLFDT(BDATE,-1),SD=SD_".9999"
F S SD=$O(^AMHREC("AF",P,SD)) Q:SD'=+SD!($P(SD,".")>EDATE)!(BUDDX4) D
.S BUDDX2=0 F S BUDDX2=$O(^AMHREC("AF",P,SD,BUDDX2)) Q:BUDDX2'=+BUDDX2!(BUDDX4) D
..S BUDDX5=0 S BUDDX5=$O(^AMHRPRO("AD",BUDDX2,BUDDX5)) Q:BUDDX5=""!(BUDDX4]"") D
...S BUDDX3=$P($G(^AMHRPRO(BUDDX5,0)),U,1)
...Q:BUDDX3=""
...S Z=$P($G(^AMHPROB(BUDDX3,0)),U,5) ;ICD9 CODE
...I Z="" Q
...S Y=+$$CODEN^ICDCODE(Z,80)
...I $$ICD^ATXCHK(Y,T,9) S BUDDX4=1_"^"_$P($$ICDDX^ICDCODE(Y),U,2)_"^"_SD_"^"_BUDDX3_"^"_BUDDX5 Q ;FOUND ONE
Q BUDDX4
HASDEPPL(P) ;EP - ACTIVE DEPRESSION ON PL
NEW A,B,C,D,T,X,G,Z
S T=$O(^ATXAX("B","BUD DEPRESSION/BIPOLAR DXS",0))
S B=$O(^BUDBCNTL("B","DEPRESSION SNOMED CODES",0))
S X=0,G="",Z="" F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:$P(^AUPNPROB(X,0),U,12)="D" ;DELETED PROBLEM
.Q:$P(^AUPNPROB(X,0),U,12)="I" ;INACTIVE PROBLEM
.S Y=$P(^AUPNPROB(X,0),U)
.I $$ICD^ATXCHK(Y,T,9) S G=1 Q ;CHECK DX
.;NOW CHECK SNOMED
.S A=$P($G(^AUPNPROB(X,800)),U,1) ;SNOMED CODE
.Q:A=""
.I $D(^BUDBCNTL(B,11,"B",A)) S G=1 Q
.Q
Q G ;HAS DEPRESSION ON PL
;NOW CHECK BH PL - DON'T CHECK BH PROBLEM LIST PER DUANE AND DENISE
S (X,G)=0 F S X=$O(^AMHPPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:$P(^AMHPPROB(X,0),U,12)="D"
.Q:$P(^AMHPPROB(X,0),U,12)="I"
.S Y=$P(^AMHPPROB(X,0),U,1) ;THIS IS A DSM CODE
.;GO GET ICD9 CODE
.S Z=$P($G(^AMHPROB(Y,0)),U,5)
.Q:Z=""
.;GET INTERNAL OF THAT
.S Y=+$$CODEN^ICDCODE(Z,80)
.I $$ICD^ATXCHK(Y,T,9) S G=1 Q
Q ""
DEPNORES(P,BDATE,EDATE) ;EP
;CHECK FOR V79.0, CPTS
NEW BUDVS,BUDDEPS,BUDV,BUDX,BUDA,BUDB,BUDP,BUDY,X,T,Y,S,A
;BGPDEPS=DATE SCREEN^SCREEN ITEM^SCREEN RESULT^FU PLAN ITEM
S BUDVS="BUDVS"
D ALLV^APCLAPIU(P,BDATE,EDATE,.BUDVS)
S BUDX=0,BUDC=0
F S BUDX=$O(BUDVS(BUDX)) Q:BUDX'=+BUDX D
.;DX
.S BUDV=$P(BUDVS(BUDX),U,5)
.S BUDY=0 F S BUDY=$O(^AUPNVPOV("AD",BUDV,BUDY)) Q:BUDY'=+BUDY D
..Q:'$D(^AUPNVPOV(BUDY,0))
..I $$ICD^ATXCHK($P(^AUPNVPOV(BUDY,0),U),$O(^ATXAX("B","BUD DEPRESSION SCRN DXS",0)),9) D Q
...S BUDDEPS($$VD^APCLV(BUDV))=$$VD^APCLV(BUDV)_U_"POV: "_$$GET1^DIQ(9000010.07,BUDY,.01)_U_"NEG"
..I $P($G(^AUPNVPOV(BUDY,11)),U,1)=428171000124102 S BUDDEPS($$VD^APCLV(BUDV))=$$VD^APCLV(BUDV)_U_"SNOMED: "_$$GET1^DIQ(9000010.07,BUDY,1101)_U_"NEG"
.;CPT
.S BUDY=0 F S BUDY=$O(^AUPNVCPT("AD",BUDV,BUDY)) Q:BUDY'=+BUDY D
..Q:'$D(^AUPNVCPT(BUDY,0))
..Q:'$$ICD^ATXCHK($P(^AUPNVCPT(BUDY,0),U),$O(^ATXAX("B","BUD DEPRESSION SCREEN CPTS",0)),1)
..S BUDDEPS($$VD^APCLV(V))=$$VD^APCLV(BUDV)_U_"CPT: "_$$GET1^DIQ(9000010.18,BUDY,.01)_U_"NEG"
.;====================================
BHNORES ;
S D=0,E=9999999-BDATE,D=9999999-EDATE-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V D
.S X=0 F S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X S BUDP=$P($G(^AMHRPRO(X,0)),U) D
..Q:'BUDP
..S BUDP=$P($G(^AMHPROB(BUDP,0)),U)
..I BUDP=14.1 S BUDDEPS((9999999-$P(D,".")))=9999999-$P(D,".")_U_"BH DX: "_BUDP_U_"NEG"
..I BUDP="V79.0" S BUDDEPS((9999999-$P(D,".")))=9999999-$P(D,".")_U_"BH DX: "_BUDP_U_"NEG"
.S X=0 F S X=$O(^AMHRPROC("AD",V,X)) Q:X'=+X S BUDP=$P($G(^AMHRPROC(X,0)),U) D
..Q:'BUDP
..Q:'$$ICD^ATXCHK(BUDP,$O(^ATXAX("B","BUD DEPRESSION SCRN CPTS",0)),1)
..S BUDDEPS((9999999-$P(D,".")))=9999999-$P(D,".")_U_"BH CPT: "_$$GET1^DIQ(9002011.04,X,.01)_U_"NEG"
S Y=$O(BUDDEPS(0)) I Y Q BUDDEPS(Y)
Q ""
PHQ(Y) ;
I Y="PHQ2" Q 1
I Y="PHQ9" Q 1
I Y="PHQT" Q 1
Q ""
MRES(T,R) ;
I T="PHQ9",R'<10 Q "POS "_R
I T="PHQ2",R'<3 Q "POS "_R
I T="PHQT",R'<10 Q "POS "_R
Q "NEG "_R
BUDBRP6Q ; IHS/CMI/LAB - HIV/DEP ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
L ;EP - NEW HIV
+1 NEW BUDGOT,BUDDOA
+2 SET BUDGOT=""
+3 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+4 IF BUDMEDV<1
QUIT
+5 SET BUDX28TH=$EXTRACT(BUDDOB,1,3)+18_$EXTRACT(BUDDOB,4,7)
+6 KILL BUDG
+7 SET Y="BUDG("
+8 SET X=DFN_"^FIRST DX [BUD HIV DXS"
SET E=$$START1^APCLDF(X,Y)
+9 ;NO HIV DXS
IF '$DATA(BUDG(1))
QUIT
+10 SET BUDHIVD=$PIECE(BUDG(1),U,1)
+11 SET BUDHIVDX=$PIECE(BUDG(1),U,2)
+12 SET D=($EXTRACT(BUDBD,1,3)-1)_"1001"
+13 SET E=$EXTRACT(BUDED,1,3)_"0930"
+14 IF BUDHIVD<D
QUIT
+15 IF BUDHIVD>E
QUIT
+16 SET BUDDOA=""
+17 ;now check problem list date of onset, if date of onset is prior to the report period quit
+18 SET T=$ORDER(^ATXAX("B","BUD HIV DXS",0))
+19 SET (X,G)=0
SET Z=""
FOR
SET X=$ORDER(^AUPNPROB("AC",DFN,X))
IF X'=+X
QUIT
Begin DoDot:1
+20 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+21 ;no date of onset so don't bother
IF $PIECE(^AUPNPROB(X,0),U,13)=""
QUIT
+22 SET Y=$PIECE(^AUPNPROB(X,0),U)
+23 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+24 SET BUDDOA=$PIECE(^AUPNPROB(X,0),U,13)
+25 IF $PIECE(^AUPNPROB(X,0),U,13)<BUDHIVD
SET G=1
+26 QUIT
End DoDot:1
+27 IF G
QUIT
+28 SET BUDHIVF=$$FU(DFN,$$FMADD^XLFDT(BUDHIVD,1))
+29 IF BUDHIVF
SET BUDSECTL("HIV")=$GET(BUDSECTL("HIV"))+1
S ;put the rest in demoninator
+1 SET BUDSECTL("PTS")=$GET(BUDSECTL("PTS"))+1
Begin DoDot:1
+2 IF $GET(BUDHIV2L)
Begin DoDot:2
+3 IF BUDHIVF=""
SET ^XTMP("BUDBRP6B",BUDJ,BUDH,"HIV2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)="First HIV: "_BUDHIVDX_": "_$$DATE^BUDBUTL1(BUDHIVD)_"|Follow-up: "_$PIECE(BUDHIVF,U,2)_" "_$$DATE^BUDBUTL1($PIECE(BUDHIVF,U,1))_"|"_$$DATE^BUDBUTL1(
BUDDOA)
End DoDot:2
+4 IF $GET(BUDHIV1L)
Begin DoDot:2
+5 IF BUDHIVF]""
SET ^XTMP("BUDBRP6B",BUDJ,BUDH,"HIV1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)="First HIV: "_BUDHIVDX_": "_$$DATE^BUDBUTL1(BUDHIVD)_"|Follow-up: "_$PIECE(BUDHIVF,U,2)_" "_$$DATE^BUDBUTL1($PIECE(BUDHIVF,U,1))_"|"_$$DATE^BUDBUTL1(
BUDDOA)
End DoDot:2
End DoDot:1
+6 QUIT
FU(P,BD) ;WAS THERE AN HIV VISIT WITHIN 90 DAYS OF BD
+1 NEW BUDVS
+2 SET ED=$$FMADD^XLFDT(BD,90)
+3 DO ALLV^APCLAPIU(P,BD,ED,"BUDVS")
+4 IF '$DATA(BUDVS)
QUIT ""
+5 NEW X,Y,V,G,D,C,T,L1,L2,L3
+6 SET G=""
+7 SET X=0
FOR
SET X=$ORDER(BUDVS(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+8 SET V=$PIECE(BUDVS(X),U,5)
+9 SET C=$$CLINIC^APCLV(V,"C")
IF C=59
SET G=$PIECE(BUDVS(X),U,1)_U_"Clinic: 59"
QUIT
+10 SET D=$$PRIMPOV^APCLV(V,"I")
+11 IF $$ICD^ATXCHK(D,$ORDER(^ATXAX("B","BUD HIV FU DXS",0)),9)
SET G=$PIECE(BUDVS(X),U,1)_U_"DX: "_$PIECE(^ICD9(D,0),U,1)
QUIT
+12 SET C=0
FOR
SET C=$ORDER(^AUPNVCPT("AD",V,C))
IF C'=+C!(G)
QUIT
Begin DoDot:2
+13 SET T=$$VALI^XBDIQ1(9000010.18,C,.01)
+14 IF $$ICD^ATXCHK(T,$ORDER(^ATXAX("B","BUD HIV FU CPTS",0)),1)
SET G=$PIECE(BUDVS(X),U,1)_U_"CPT: "_$PIECE(^ICPT(T,0),U,1)
QUIT
End DoDot:2
+15 SET L1=$ORDER(^ATXLAB("B","BGP HIV TEST TAX",0))
+16 SET L2=$ORDER(^ATXLAB("B","BGP CD4 TAX",0))
+17 SET L3=$ORDER(^ATXLAB("B","BGP HIV VIRAL LOAD TAX",0))
+18 SET C=0
FOR
SET C=$ORDER(^AUPNVLAB("AD",V,C))
IF C'=+C!(G)
QUIT
Begin DoDot:2
+19 SET T=$$VALI^XBDIQ1(9000010.09,C,.01)
+20 IF L1
IF $DATA(^ATXLAB(L1,21,"B",T))
SET G=$PIECE(BUDVS(X),U,1)_U_"LAB: "_$PIECE(^LAB(60,T,0),U,1)
QUIT
+21 IF L2
IF $DATA(^ATXLAB(L2,21,"B",T))
SET G=$PIECE(BUDVS(X),U,1)_U_"LAB: "_$PIECE(^LAB(60,T,0),U,1)
QUIT
+22 IF L3
IF $DATA(^ATXLAB(L3,21,"B",T))
SET G=$PIECE(BUDVS(X),U,1)_U_"LAB: "_$PIECE(^LAB(60,T,0),U,1)
QUIT
End DoDot:2
End DoDot:1
+23 QUIT G
M ;EP
+1 NEW BUDGOT
+2 SET BUDGOT=""
+3 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+4 IF BUDMEDV<1
QUIT
+5 SET BUDX12RB=($EXTRACT(BUDBD,1,3)-12)_"1231"
+6 IF BUDDOB>BUDX12RB
QUIT
+7 SET BUDP12BD=($EXTRACT(BUDDOB,1,3)+12)_$EXTRACT(BUDDOB,4,7)
+8 KILL BUDG
+9 ;DENOMINATOR EXCLUSION, ANY ONE WITH ACTIVE PL ENTRY OF THE DX OR SNOMED
+10 ;pcc or bh problem list
IF $$HASDEPPL(DFN)
QUIT
+11 ;PCC DX DURING REPORT PERIOD
IF $$HASDEPOV(DFN,BUDBD,BUDED)
QUIT
+12 ;DENOMINATOR
SET BUDSECTM("PTS")=$GET(BUDSECTM("PTS"))+1
+13 ;DO THEY HAVE A SCREEN?
+14 ;CHECK exam, phq2, phq9, phqt for a positive and if no positive get the first negative
+15 SET (BUDSCR,BUDPLAN)=""
+16 SET BUDSCR=$$DEPRES(DFN,BUDBD,BUDED)
+17 IF BUDSCR]""
GOTO R
+18 ;now check for any without a result and assume negative (per Duane)
+19 SET BUDSCR=$$DEPNORES(DFN,BUDBD,BUDED)
R ;
+1 SET BUDN=0
+2 IF BUDSCR=""
GOTO M1
+3 IF $PIECE(BUDSCR,U,3)["NEG"
SET BUDSECTM("DEP")=$GET(BUDSECTM("DEP"))+1
SET BUDN=1
GOTO M1
+4 ;CHECK FOR PLAN
+5 ;PLAN BETWEEN DATE OF SCREEN AND END OF REPORT PERIOD
SET BUDPLAN=$$PLAN(DFN,$PIECE(BUDSCR,U,1),BUDED)
+6 IF BUDPLAN]""
SET BUDSECTM("DEP")=$GET(BUDSECTM("DEP"))+1
SET BUDN=1
M1 ;LISTS
+1 Begin DoDot:1
+2 IF $GET(BUDDEP2L)
IF 'BUDN
Begin DoDot:2
+3 SET ^XTMP("BUDBRP6B",BUDJ,BUDH,"DEP2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=BUDSCR_"|"_BUDPLAN
End DoDot:2
+4 IF $GET(BUDDEP1L)
IF BUDN
Begin DoDot:2
+5 SET ^XTMP("BUDBRP6B",BUDJ,BUDH,"DEP1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=BUDSCR_"|"_BUDPLAN
End DoDot:2
End DoDot:1
+6 QUIT
PLAN(P,BDATE,EDATE) ;
+1 ;CHECK MEDS, CPTS, SNOMEDS
+2 NEW BUDVS,BUDDEPS,BUDV,BUDX,BUDA,BUDB,BUDP,BUDY,X,T,Y,A,B,J,D,R,K,BUDRX,BUDRXRF,BUDXRX,BUDNORM
+3 ;BGPDEPS=DATE SCREEN^SCREEN ITEM^SCREEN RESULT^FU PLAN ITEM
+4 SET BUDVS="BUDVS"
+5 DO ALLV^APCLAPIU(P,BDATE,EDATE,.BUDVS)
+6 SET BUDX=0
SET BUDC=0
SET BUDDEPS=""
+7 SET B=$ORDER(^BUDBCNTL("B","DEPRESSION INTERVENTION SNOMED",0))
+8 SET T=$ORDER(^BUDBCNTL("B","BUD RX NORM DEPRESSION",0))
+9 SET J=$ORDER(^ATXAX("B","BGP HEDIS ANTIDEPRESSANT MEDS",0))
+10 SET K=$ORDER(^ATXAX("B","BGP HEDIS ANTIDEPRESSANT NDC",0))
+11 FOR
SET BUDX=$ORDER(BUDVS(BUDX))
IF BUDX'=+BUDX!(BUDDEPS]"")
QUIT
Begin DoDot:1
+12 ;DX/snomed
+13 SET BUDV=$PIECE(BUDVS(BUDX),U,5)
+14 SET BUDY=0
FOR
SET BUDY=$ORDER(^AUPNVPOV("AD",BUDV,BUDY))
IF BUDY'=+BUDY!(BUDDEPS]"")
QUIT
Begin DoDot:2
+15 IF '$DATA(^AUPNVPOV(BUDY,0))
QUIT
+16 ;Q:'$$ICD^ATXCHK($P(^AUPNVPOV(BUDY,0),U),$O(^ATXAX("B","BUD DEPRESSION SCRN DXS",0)),9)
+17 ;NOW CHECK SNOMED
+18 SET A=$PIECE($GET(^AUPNVPOV(BUDY,11)),U,1)
+19 IF A=""
QUIT
+20 IF $DATA(^BUDBCNTL(B,11,"B",A))
SET BUDDEPS=$$VD^APCLV(BUDV)_U_"SNOMED: "_A
QUIT
End DoDot:2
+21 ;CPT
+22 SET BUDY=0
FOR
SET BUDY=$ORDER(^AUPNVCPT("AD",BUDV,BUDY))
IF BUDY'=+BUDY!(BUDDEPS]"")
QUIT
Begin DoDot:2
+23 IF '$DATA(^AUPNVCPT(BUDY,0))
QUIT
+24 IF '$$ICD^ATXCHK($PIECE(^AUPNVCPT(BUDY,0),U),$ORDER(^ATXAX("B","BUD DEP INTERVENTION CPTS",0)),1)
QUIT
+25 SET BUDDEPS=$$VD^APCLV(BUDV)_U_"CPT: "_$$GET1^DIQ(9000010.18,BUDY,.01)
End DoDot:2
+26 ;NOW CHECK MEDS
+27 SET BUDY=0
FOR
SET BUDY=$ORDER(^AUPNVMED("AD",BUDV,BUDY))
IF BUDY'=+BUDY!(BUDDEPS]"")
QUIT
Begin DoDot:2
+28 IF '$DATA(^AUPNVMED(BUDY,0))
QUIT
+29 SET D=$PIECE(^AUPNVMED(BUDY,0),U,1)
+30 IF D=""
QUIT
+31 IF '$DATA(^PSDRUG(D,0))
QUIT
+32 IF $DATA(^ATXAX(J,21,"B",D))
SET BUDDEPS=$$VD^APCLV(BUDV)_U_"RX: "_$$VAL^XBDIQ1(9000010.14,BUDY,.01)
QUIT
+33 ;check NDC
+34 IF $$NDC(D,K)
SET BUDDEPS=$$VD^APCLV(BUDV)_U_"RX: "_$$VAL^XBDIQ1(9000010.14,BUDY,.01)
QUIT
+35 ;check rxnorm?
+36 ;GET PRESCRIPTION
+37 SET BUDRXRF=""
+38 ;NO 52 ENTRY
SET BUDRX=$ORDER(^PSRX("APCC",BUDY,0))
IF 'BUDRX
QUIT
+39 IF BUDRX
SET BUDRXRF=$ORDER(^PSRX("APCC",BUDY,BUDRX,""))
IF BUDRXRF=""
SET BUDRXRF=0
+40 SET BUDNORM=""
+41 IF BUDRXRF
SET BUDNORM=$PIECE($GET(^PSRX(BUDRX,1,BUDRXRF,9999999)),U,19)
+42 IF BUDNORM=""
SET BUDNORM=$PIECE($GET(^PSRX(BUDRX,999999921)),U,7)
+43 IF BUDNORM]""
IF $DATA(^BUDBCNTL(T,11,"B",BUDNORM))
SET BUDDEPS=$$VD^APCLV(BUDV)_U_"RX NORM: "_$$VAL^XBDIQ1(9000010.14,BUDY,.01)
QUIT
End DoDot:2
End DoDot:1
+44 IF BUDDEPS]""
QUIT BUDDEPS
+45 ;
+46 SET D=0
SET E=9999999-BDATE
SET D=9999999-EDATE-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)!(BUDDEPS]"")
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V
QUIT
Begin DoDot:1
+47 SET X=0
FOR
SET X=$ORDER(^AMHRPROC("AD",V,X))
IF X'=+X
QUIT
SET BUDP=$PIECE($GET(^AMHRPROC(X,0)),U)
Begin DoDot:2
+48 IF 'BUDP
QUIT
+49 IF '$$ICD^ATXCHK(BUDP,$ORDER(^ATXAX("B","BUD DEP INTERVENTION CPTS",0)),1)
QUIT
+50 SET BUDDEPS=9999999-$PIECE(D,".")_U_"BH CPT: "_$$GET1^DIQ(9002011.04,X,.01)
End DoDot:2
End DoDot:1
+51 QUIT BUDDEPS
NDC(A,B) ;
+1 ;a is drug ien
+2 ;b is taxonomy ien
+3 NEW BUDNDC
+4 SET BUDNDC=$PIECE($GET(^PSDRUG(A,2)),U,4)
+5 IF BUDNDC]""
IF B
IF $DATA(^ATXAX(B,21,"B",BUDNDC))
QUIT 1
+6 QUIT 0
DEPRES(P,BD,ED) ;
+1 ;DID PT HAVE AN EXAM 36 DURING REPORT PERIOD
+2 NEW %,E,D,V,X,G,BUDC
+3 NEW BUDG,BUDR,BUDALL
+4 SET BUDC=0
+5 KILL BUDG
SET %=P_"^ALL EXAM 36;DURING "_BD_"-"_ED
SET E=$$START1^APCLDF(%,"BUDG(")
+6 SET E=0
FOR
SET E=$ORDER(BUDG(E))
IF E'=+E
QUIT
Begin DoDot:1
+7 SET BUDR=$SELECT($PIECE(BUDG(E),U,2)="PO":"POS",$PIECE(BUDG(E),U,2)="RF":"POS",1:"NEG")
+8 ;W !,P," ",BUDALL(BUDR,$P(BUDG(E),U,1))
SET BUDALL(BUDR,$PIECE(BUDG(E),U,1))=$PIECE(BUDG(E),U,1)_U_"PCC EX 36"_U_BUDR_" "_$PIECE(BUDG(E),U,2)
End DoDot:1
+9 ;phq2
+10 ;ZW BUDG Q ""
KILL BUDG
SET %=P_"^ALL MEAS PHQ2;DURING "_BD_"-"_ED
SET E=$$START1^APCLDF(%,"BUDG(")
+11 SET E=0
FOR
SET E=$ORDER(BUDG(E))
IF E'=+E
QUIT
Begin DoDot:1
+12 SET BUDR=$$MRES($PIECE(BUDG(E),U,3),$PIECE(BUDG(E),U,2))
+13 ;W !,P," ",BUDALL(BUDR,$P(BUDG(E),U,1))
SET BUDALL($PIECE(BUDR," "),$PIECE(BUDG(E),U,1))=$PIECE(BUDG(E),U,1)_U_"PCC PHQ2"_U_BUDR
End DoDot:1
+14 ;ZW BUDG Q ""
KILL BUDG
SET %=P_"^ALL MEAS PHQ9;DURING "_BD_"-"_ED
SET E=$$START1^APCLDF(%,"BUDG(")
+15 SET E=0
FOR
SET E=$ORDER(BUDG(E))
IF E'=+E
QUIT
Begin DoDot:1
+16 SET BUDR=$$MRES($PIECE(BUDG(E),U,3),$PIECE(BUDG(E),U,2))
+17 ;W !,P," ",BUDALL(BUDR,$P(BUDG(E),U,1))
SET BUDALL($PIECE(BUDR," ",1),$PIECE(BUDG(E),U,1))=$PIECE(BUDG(E),U,1)_U_"PCC PHQ9"_U_BUDR
End DoDot:1
+18 ;ZW BUDG Q ""
KILL BUDG
SET %=P_"^ALL MEAS PHQT;DURING "_BD_"-"_ED
SET E=$$START1^APCLDF(%,"BUDG(")
+19 SET E=0
FOR
SET E=$ORDER(BUDG(E))
IF E'=+E
QUIT
Begin DoDot:1
+20 SET BUDR=$$MRES($PIECE(BUDG(E),U,3),$PIECE(BUDG(E),U,2))
+21 ;W !,P," ",BUDALL(BUDR,$P(BUDG(E),U,1))
SET BUDALL($PIECE(BUDR," ",1),$PIECE(BUDG(E),U,1))=$PIECE(BUDG(E),U,1)_U_"PCC PHQT"_U_BUDR
End DoDot:1
+22 ;SNOMED
+23 ;ALL POVS
+24 KILL BUDG
SET %=P_"^ALL DX;DURING "_BD_"-"_ED
SET E=$$START1^APCLDF(%,"BUDG(")
+25 SET E=0
FOR
SET E=$ORDER(BUDG(E))
IF E'=+E
QUIT
Begin DoDot:1
+26 SET BUDR=+$PIECE(BUDG(E),U,4)
+27 IF $PIECE($GET(^AUPNVPOV(BUDR,11)),U,1)=428181000124104
Begin DoDot:2
+28 SET BUDALL("POS",$PIECE(BUDG(E),U,1))=$PIECE(BUDG(E),U,1)_U_"SNOMED "_"428181000124104"_U_"POS"
End DoDot:2
End DoDot:1
+29 ;NOW GO TO BH
+30 ;BH EXAM
BHSCR ;
+1 SET D=0
SET E=9999999-BD
SET D=9999999-ED-1_".9999"
+2 FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^AMHREC(V,14)),U,5)="N"
SET I=9999999-$PIECE(D,".")
IF '$DATA(BUDALL("NEG",I))
SET BUDR="NEG"
SET BUDALL(BUDR,I)=I_U_"BH EX"_U_BUDR
+4 IF $PIECE($GET(^AMHREC(V,14)),U,5)="P"!($PIECE($GET(^AMHREC(V,14)),U,5)="REF")
SET I=9999999-$PIECE(D,".")
IF '$DATA(BUDALL("POS",I))
SET BUDR="POS"
SET BUDALL(BUDR,I)=I_U_"BH EX"_U_BUDR
+5 SET X=0
FOR
SET X=$ORDER(^AMHRMSR("AD",V,X))
IF X'=+X
QUIT
SET BUDP=$PIECE($GET(^AMHRMSR(X,0)),U)
Begin DoDot:2
+6 IF 'BUDP
QUIT
+7 SET BUDP=$PIECE($GET(^AUTTMSR(BUDP,0)),U)
+8 IF BUDP="PHQ2"!(BUDP="PHQ9")!(BUDP="PHQT")
Begin DoDot:3
+9 SET BUDR=$$MRES(BUDP,$PIECE(^AMHRMSR(X,0),U,4))
+10 IF '$DATA(BUDALL($PIECE(BUDR," "),(9999999-$PIECE(D,"."))))
Begin DoDot:4
+11 SET BUDALL($PIECE(BUDR," "),(9999999-$PIECE(D,".")))=(9999999-$PIECE(D,"."))_U_"BH "_BUDP_U_BUDR
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+12 IF $DATA(BUDALL("POS"))
SET X=$ORDER(BUDALL("POS",0))
QUIT BUDALL("POS",X)
+13 IF $DATA(BUDALL("NEG"))
SET Y=$ORDER(BUDALL("NEG",0))
QUIT BUDALL("NEG",Y)
+14 QUIT ""
PRIMPOV(V) ;
+1 NEW Y,Z,P
+2 SET Y=0
SET Z=""
+3 IF $PIECE(^AUPNVSIT(V,0),U,7)="H"
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y
QUIT
IF $PIECE(^AUPNVPOV(Y,0),U,12)="P"
SET Z=Y
+4 IF $PIECE(^AUPNVSIT(V,0),U,7)'="H"
SET Y=$ORDER(^AUPNVPOV("AD",V,0))
IF Y
SET Z=Y
+5 QUIT Z
HASDEPOV(P,BDATE,EDATE) ;EP - do they have one dx in 6 months prior to beginning of report period
+1 IF '$GET(P)
QUIT ""
+2 NEW T,B,BUDVS,BUDX,BUDV,BUDDX2,BUDDX3,BUDDX4,BUDDX5
+3 SET T=$ORDER(^ATXAX("B","BUD DEPRESSION/BIPOLAR DXS",0))
+4 SET B=$ORDER(^BUDBCNTL("B","DEPRESSION SNOMED CODES",0))
+5 SET BUDVS="BUDVS"
SET BUDDX4=""
+6 DO ALLV^APCLAPIU(P,BDATE,EDATE,.BUDVS)
+7 SET BUDX=0
FOR
SET BUDX=$ORDER(BUDVS(BUDX))
IF BUDX'=+BUDX!(BUDDX4)
QUIT
Begin DoDot:1
+8 SET BUDV=$PIECE(BUDVS(BUDX),U,5)
+9 SET BUDI=$$PRIMPOV(BUDV)
+10 IF BUDI=""
QUIT
+11 SET BUDDX3=$PIECE($GET(^AUPNVPOV(BUDI,0)),U)
+12 IF BUDDX3=""
QUIT
+13 IF '$DATA(^ICD9(BUDDX3))
QUIT
+14 ;FOUND ONE
IF $$ICD^ATXCHK(BUDDX3,T,9)
SET BUDDX4=1_"^"_$PIECE($$ICDDX^ICDCODE(BUDDX3),U,2)_"^"_$$VD^APCLV(BUDV)_"^"_BUDDX3
QUIT
+15 ;NOW CHECK SNOMED
+16 SET A=$PIECE($GET(^AUPNVPOV(BUDI,11)),U,1)
+17 IF A=""
QUIT
+18 ;FOUND ONE
IF $DATA(^BUDBCNTL(B,11,"B",A))
SET BUDDX4=1_"^"_$PIECE($$ICDDX^ICDCODE(BUDDX3),U,2)_"^"_$$VD^APCLV(BUDV)_"^"_BUDDX3
QUIT
+19 QUIT
End DoDot:1
+20 IF BUDDX4
QUIT BUDDX4
+21 SET SD=$$FMADD^XLFDT(BDATE,-1)
SET SD=SD_".9999"
+22 FOR
SET SD=$ORDER(^AMHREC("AF",P,SD))
IF SD'=+SD!($PIECE(SD,".")>EDATE)!(BUDDX4)
QUIT
Begin DoDot:1
+23 SET BUDDX2=0
FOR
SET BUDDX2=$ORDER(^AMHREC("AF",P,SD,BUDDX2))
IF BUDDX2'=+BUDDX2!(BUDDX4)
QUIT
Begin DoDot:2
+24 SET BUDDX5=0
SET BUDDX5=$ORDER(^AMHRPRO("AD",BUDDX2,BUDDX5))
IF BUDDX5=""!(BUDDX4]"")
QUIT
Begin DoDot:3
+25 SET BUDDX3=$PIECE($GET(^AMHRPRO(BUDDX5,0)),U,1)
+26 IF BUDDX3=""
QUIT
+27 ;ICD9 CODE
SET Z=$PIECE($GET(^AMHPROB(BUDDX3,0)),U,5)
+28 IF Z=""
QUIT
+29 SET Y=+$$CODEN^ICDCODE(Z,80)
+30 ;FOUND ONE
IF $$ICD^ATXCHK(Y,T,9)
SET BUDDX4=1_"^"_$PIECE($$ICDDX^ICDCODE(Y),U,2)_"^"_SD_"^"_BUDDX3_"^"_BUDDX5
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+31 QUIT BUDDX4
HASDEPPL(P) ;EP - ACTIVE DEPRESSION ON PL
+1 NEW A,B,C,D,T,X,G,Z
+2 SET T=$ORDER(^ATXAX("B","BUD DEPRESSION/BIPOLAR DXS",0))
+3 SET B=$ORDER(^BUDBCNTL("B","DEPRESSION SNOMED CODES",0))
+4 SET X=0
SET G=""
SET Z=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+5 ;DELETED PROBLEM
IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+6 ;INACTIVE PROBLEM
IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+7 SET Y=$PIECE(^AUPNPROB(X,0),U)
+8 ;CHECK DX
IF $$ICD^ATXCHK(Y,T,9)
SET G=1
QUIT
+9 ;NOW CHECK SNOMED
+10 ;SNOMED CODE
SET A=$PIECE($GET(^AUPNPROB(X,800)),U,1)
+11 IF A=""
QUIT
+12 IF $DATA(^BUDBCNTL(B,11,"B",A))
SET G=1
QUIT
+13 QUIT
End DoDot:1
+14 ;HAS DEPRESSION ON PL
QUIT G
+15 ;NOW CHECK BH PL - DON'T CHECK BH PROBLEM LIST PER DUANE AND DENISE
+16 SET (X,G)=0
FOR
SET X=$ORDER(^AMHPPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+17 IF $PIECE(^AMHPPROB(X,0),U,12)="D"
QUIT
+18 IF $PIECE(^AMHPPROB(X,0),U,12)="I"
QUIT
+19 ;THIS IS A DSM CODE
SET Y=$PIECE(^AMHPPROB(X,0),U,1)
+20 ;GO GET ICD9 CODE
+21 SET Z=$PIECE($GET(^AMHPROB(Y,0)),U,5)
+22 IF Z=""
QUIT
+23 ;GET INTERNAL OF THAT
+24 SET Y=+$$CODEN^ICDCODE(Z,80)
+25 IF $$ICD^ATXCHK(Y,T,9)
SET G=1
QUIT
End DoDot:1
+26 QUIT ""
DEPNORES(P,BDATE,EDATE) ;EP
+1 ;CHECK FOR V79.0, CPTS
+2 NEW BUDVS,BUDDEPS,BUDV,BUDX,BUDA,BUDB,BUDP,BUDY,X,T,Y,S,A
+3 ;BGPDEPS=DATE SCREEN^SCREEN ITEM^SCREEN RESULT^FU PLAN ITEM
+4 SET BUDVS="BUDVS"
+5 DO ALLV^APCLAPIU(P,BDATE,EDATE,.BUDVS)
+6 SET BUDX=0
SET BUDC=0
+7 FOR
SET BUDX=$ORDER(BUDVS(BUDX))
IF BUDX'=+BUDX
QUIT
Begin DoDot:1
+8 ;DX
+9 SET BUDV=$PIECE(BUDVS(BUDX),U,5)
+10 SET BUDY=0
FOR
SET BUDY=$ORDER(^AUPNVPOV("AD",BUDV,BUDY))
IF BUDY'=+BUDY
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVPOV(BUDY,0))
QUIT
+12 IF $$ICD^ATXCHK($PIECE(^AUPNVPOV(BUDY,0),U),$ORDER(^ATXAX("B","BUD DEPRESSION SCRN DXS",0)),9)
Begin DoDot:3
+13 SET BUDDEPS($$VD^APCLV(BUDV))=$$VD^APCLV(BUDV)_U_"POV: "_$$GET1^DIQ(9000010.07,BUDY,.01)_U_"NEG"
End DoDot:3
QUIT
+14 IF $PIECE($GET(^AUPNVPOV(BUDY,11)),U,1)=428171000124102
SET BUDDEPS($$VD^APCLV(BUDV))=$$VD^APCLV(BUDV)_U_"SNOMED: "_$$GET1^DIQ(9000010.07,BUDY,1101)_U_"NEG"
End DoDot:2
+15 ;CPT
+16 SET BUDY=0
FOR
SET BUDY=$ORDER(^AUPNVCPT("AD",BUDV,BUDY))
IF BUDY'=+BUDY
QUIT
Begin DoDot:2
+17 IF '$DATA(^AUPNVCPT(BUDY,0))
QUIT
+18 IF '$$ICD^ATXCHK($PIECE(^AUPNVCPT(BUDY,0),U),$ORDER(^ATXAX("B","BUD DEPRESSION SCREEN CPTS",0)),1)
QUIT
+19 SET BUDDEPS($$VD^APCLV(V))=$$VD^APCLV(BUDV)_U_"CPT: "_$$GET1^DIQ(9000010.18,BUDY,.01)_U_"NEG"
End DoDot:2
+20 ;====================================
End DoDot:1
BHNORES ;
+1 SET D=0
SET E=9999999-BDATE
SET D=9999999-EDATE-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V
QUIT
Begin DoDot:1
+2 SET X=0
FOR
SET X=$ORDER(^AMHRPRO("AD",V,X))
IF X'=+X
QUIT
SET BUDP=$PIECE($GET(^AMHRPRO(X,0)),U)
Begin DoDot:2
+3 IF 'BUDP
QUIT
+4 SET BUDP=$PIECE($GET(^AMHPROB(BUDP,0)),U)
+5 IF BUDP=14.1
SET BUDDEPS((9999999-$PIECE(D,".")))=9999999-$PIECE(D,".")_U_"BH DX: "_BUDP_U_"NEG"
+6 IF BUDP="V79.0"
SET BUDDEPS((9999999-$PIECE(D,".")))=9999999-$PIECE(D,".")_U_"BH DX: "_BUDP_U_"NEG"
End DoDot:2
+7 SET X=0
FOR
SET X=$ORDER(^AMHRPROC("AD",V,X))
IF X'=+X
QUIT
SET BUDP=$PIECE($GET(^AMHRPROC(X,0)),U)
Begin DoDot:2
+8 IF 'BUDP
QUIT
+9 IF '$$ICD^ATXCHK(BUDP,$ORDER(^ATXAX("B","BUD DEPRESSION SCRN CPTS",0)),1)
QUIT
+10 SET BUDDEPS((9999999-$PIECE(D,".")))=9999999-$PIECE(D,".")_U_"BH CPT: "_$$GET1^DIQ(9002011.04,X,.01)_U_"NEG"
End DoDot:2
End DoDot:1
+11 SET Y=$ORDER(BUDDEPS(0))
IF Y
QUIT BUDDEPS(Y)
+12 QUIT ""
PHQ(Y) ;
+1 IF Y="PHQ2"
QUIT 1
+2 IF Y="PHQ9"
QUIT 1
+3 IF Y="PHQT"
QUIT 1
+4 QUIT ""
MRES(T,R) ;
+1 IF T="PHQ9"
IF R'<10
QUIT "POS "_R
+2 IF T="PHQ2"
IF R'<3
QUIT "POS "_R
+3 IF T="PHQT"
IF R'<10
QUIT "POS "_R
+4 QUIT "NEG "_R
