BUDDRP6Q ; IHS/CMI/LAB - HIV/DEP ;
;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
;
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) ;FIRST DX IN RPMS
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 X=$$GETV^BUDDRP6U(DFN,($E(BUDBD,1,3)-1)_0101,BUDED,BUDSITE)
;I X<1,BUDMEDV<1 Q
S BUDDOA=""
;now check problem list date of onset, if date of onset is prior to the report period quit
S T=$O(^BUDDTSSC("B","T6B HIV HIV CODES",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)
.Q:'$D(^BUDDTSSC("AD",Y,T))
.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("BUDDRP6B",BUDJ,BUDH,"HIV2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)="First HIV: "_BUDHIVDX_": "_$$DATE^BUDDUTL1(BUDHIVD)_"|Follow-up: "_$P(BUDHIVF,U,2)_" "_$$DATE^BUDDUTL1($P(BUDHIVF,U,1))_"|"_$$DATE^BUDDUTL1(BUDDOA)
.I $G(BUDHIV1L) D
..I BUDHIVF]"" S ^XTMP("BUDDRP6B",BUDJ,BUDH,"HIV1",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)="First HIV: "_BUDHIVDX_": "_$$DATE^BUDDUTL1(BUDHIVD)_"|Follow-up: "_$P(BUDHIVF,U,2)_" "_$$DATE^BUDDUTL1($P(BUDHIVF,U,1))_"|"_$$DATE^BUDDUTL1(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 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
;REFUSAL OF DEPRESSION SCREENING EXAM OR CPT OR MEASUREMENT
I $$REFDS(DFN,BUDBD,BUDED) Q
;DENOMINATOR EXCLUSION, ANY ONE WITH ACTIVE PL ENTRY OF THE DX OR SNOMED
;GET DATE OF FIRST SCREEN IN REPORT PERIOD
I $$HASDEPPL(DFN,"T6B DEP DEP/BIPOLAR CODES",$$VD^APCLV(BUDFRSTV)) Q ;pcc or bh problem list
;Q:$$HASDEPOV(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT($$VD^APCLV(BUDFRSTV),-1)) ;PCC DX DURING REPORT PERIOD
S BUDFDEP=$$FDEPSCR^BUDDRP6M(DFN,BUDBD,BUDED)
;if screen, was there a diagnosis before the SCREEN AND DURING REPORT PERIOD? if so, quit
I BUDFDEP Q:$$HASDEPOV(DFN,BUDBD,BUDFDEP)
I 'BUDFDEP Q:$$HASDEPOV(DFN,BUDBD,BUDED) ;if no screen quit if any 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]"" Q:$$HASDEPOV(DFN,BUDBD,$P(BUDSCR,U,1)) ;dx prior to screen and during report period
I BUDSCR]"" G R
;now check for any without a result and assume negative (per Duane)
;S BUDSCR=$$DEPNORES(DFN,BUDBD,BUDED) ;NO CPTS PER MEGAN
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),$P(BUDSCR,U,1)) ;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("BUDDRP6B",BUDJ,BUDH,"DEP2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDSCR_"|"_BUDPLAN
.I $G(BUDDEP1L),BUDN D
..S ^XTMP("BUDDRP6B",BUDJ,BUDH,"DEP1",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDSCR_"|"_BUDPLAN
Q
REFDS(P,BDATE,EDATE) ;
I $$REFRU^BUDDUTL1(P,9999999.15,$O(^AUTTEXAM("C",36,0)),BDATE,EDATE) Q 1
I $$REFRU^BUDDUTL1(P,81,$P($$CPT^ICPTCOD("3725F"),U,1),BDATE,EDATE) Q 1
I $$REFRU^BUDDUTL1(P,81,$P($$CPT^ICPTCOD("1220F"),U,1),BDATE,EDATE) Q 1
I $$REFRU^BUDDUTL1(P,81,$P($$CPT^ICPTCOD("G0444"),U,1),BDATE,EDATE) Q 1
I $$REFRU^BUDDUTL1(P,9999999.07,$O(^AUTTMSR("B","PHQ2",0)),BDATE,EDATE) Q 1
I $$REFRU^BUDDUTL1(P,9999999.07,$O(^AUTTMSR("B","PHQ9",0)),BDATE,EDATE) Q 1
I $$REFRU^BUDDUTL1(P,9999999.07,$O(^AUTTMSR("B","PHQT",0)),BDATE,EDATE) Q 1
Q ""
PLAN(P,BDATE,EDATE) ;
;CHECK MEDS, CPTS, SNOMEDS
NEW BUDVS,BUDDEPS,BUDV,BUDX,BUDA,BUDD,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,BUDD=0,BUDDEPS=""
S T=$O(^BUDDTSSC("B","T6B DEP DEPRESSION PLAN CODES",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))
..;NOW CHECK SNOMED
..S A=$P($G(^AUPNVPOV(BUDY,11)),U,1)
..Q:A=""
..I $D(^BUDDTSSC("AS",A,T)) 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))
..S A=$$VAL^XBDIQ1(9000010.18,BUDY,.01)
..Q:'$D(^BUDDTSSC("AC",A,T))
..S BUDDEPS=$$VD^APCLV(BUDV)_U_"CPT: "_A
.;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(^BUDDTSSC(T,19,"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=$$VAL^XBDIQ1(9002011.04,X,.01) D
..Q:BUDP=""
..Q:'$D(^BUDDTSSC("AC",BUDP,T))
..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,BUDD
NEW BUDG,BUDR,BUDALL
S BUDD=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"
.I $P($G(^AUPNVPOV(BUDR,11)),U,1)=428171000124102 D
..S BUDALL("NEG",$P(BUDG(E),U,1))=$P(BUDG(E),U,1)_U_"SNOMED "_"428171000124102"_U_"NEG"
;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(^BUDDTSSC("B","T6B DEP DEP/BIPOLAR 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)
.I $D(^BUDDTSSC("AD",BUDDX3,T)) S BUDDX4=1_"^"_$P($$ICDDX^ICDEX(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(^BUDDTSSC("AS",A,T)) S BUDDX4=1_"^"_$P($$ICDDX^ICDEX(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^ICDEX(Z,80)
...I $D(^BUDDTSSC("AD",Y,T)) S BUDDX4=1_"^"_$P($$ICDDX^ICDEX(Y),U,2)_"^"_SD_"^"_BUDDX3_"^"_BUDDX5 Q ;FOUND ONE
...S Z=$P($G(^AMHPROB(BUDDX3,0)),U,17) ;ICD9 CODE
...I Z="" Q
...S Y=+$$CODEN^ICDEX(Z,80)
...I $D(^BUDDTSSC("AD",Y,T)) S BUDDX4=1_"^"_$P($$ICDDX^ICDEX(Y),U,2)_"^"_SD_"^"_BUDDX3_"^"_BUDDX5 Q ;FOUND ONE
Q BUDDX4
HASDEPPL(P,A,BD) ;EP - ACTIVE DEPRESSION ON PL
I $G(P)="" Q ""
I $G(A)="" Q ""
N T,N S T=$O(^BUDDTSSC("B",A,0))
I 'T Q ""
N X,Y,I,A,D,G S (X,Y)=0,I="" F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) I $D(^AUPNPROB(X,0)) D
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.S A=0,D="",G="" F S A=$O(^AUPNPROB(X,14,A)) Q:A'=+A!(G) D
..S D=$$VD^APCLV($P(^AUPNPROB(X,14,A,0),U,1))
..I D'>BD S G=1 ;GOOD DATE
.I 'G S A=0,D="" F S A=$O(^AUPNPROB(X,15,A)) Q:A'=+A!(G) D
..S D=$$VD^APCLV($P(^AUPNPROB(X,15,A,0),U,1))
..I D'>BD S G=1
.I 'G I $P(^AUPNPROB(X,0),U,8)'>BD S G=1
.I 'G I $P(^AUPNPROB(X,0),U,3)'>BD S G=1
.Q:'G
.S Y=$P(^AUPNPROB(X,0),U) I $D(^BUDDTSSC("AD",Y,T)) S I=1_U_$$VAL^XBDIQ1(9000011,X,.01)_U_$P(^AUPNPROB(X,0),U,3) Q
.S N=$$VAL^XBDIQ1(9000011,X,80001) I N]"",$D(^BUDDTSSC("AS",N,T)) S I=1_U_N_U_$P(^AUPNPROB(X,0),U,3)
Q I
;
DEPNORES(P,BDATE,EDATE) ;EP
;CHECK FOR V79.0, CPTS
NEW BUDVS,BUDDEPS,BUDV,BUDX,BUDA,BUDD,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,BUDD=0
F S BUDX=$O(BUDVS(BUDX)) Q:BUDX'=+BUDX D
.S BUDV=$P(BUDVS(BUDX),U,5)
.;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(^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 SCREEN 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
BUDDRP6Q ; IHS/CMI/LAB - HIV/DEP ;
+1 ;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
+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 ;FIRST DX IN RPMS
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 ;S X=$$GETV^BUDDRP6U(DFN,($E(BUDBD,1,3)-1)_0101,BUDED,BUDSITE)
+17 ;I X<1,BUDMEDV<1 Q
+18 SET BUDDOA=""
+19 ;now check problem list date of onset, if date of onset is prior to the report period quit
+20 SET T=$ORDER(^BUDDTSSC("B","T6B HIV HIV CODES",0))
+21 SET (X,G)=0
SET Z=""
FOR
SET X=$ORDER(^AUPNPROB("AC",DFN,X))
IF X'=+X
QUIT
Begin DoDot:1
+22 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+23 ;no date of onset so don't bother
IF $PIECE(^AUPNPROB(X,0),U,13)=""
QUIT
+24 SET Y=$PIECE(^AUPNPROB(X,0),U)
+25 ;Q:'$$ICD^ATXCHK(Y,T,9)
+26 IF '$DATA(^BUDDTSSC("AD",Y,T))
QUIT
+27 SET BUDDOA=$PIECE(^AUPNPROB(X,0),U,13)
+28 IF $PIECE(^AUPNPROB(X,0),U,13)<BUDHIVD
SET G=1
+29 QUIT
End DoDot:1
+30 IF G
QUIT
+31 SET BUDHIVF=$$FU(DFN,$$FMADD^XLFDT(BUDHIVD,1))
+32 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("BUDDRP6B",BUDJ,BUDH,"HIV2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)="First HIV: "_BUDHIVDX_": "_$$DATE^BUDDUTL1(BUDHIVD)_"|Follow-up: "_$PIECE(BUDHIVF,U,2)_" "_$$DATE^BUDDUTL1($PIECE(BUDHIVF,U,1))_"|"_$$DATE^BUDDUTL1
(BUDDOA)
End DoDot:2
+4 IF $GET(BUDHIV1L)
Begin DoDot:2
+5 IF BUDHIVF]""
SET ^XTMP("BUDDRP6B",BUDJ,BUDH,"HIV1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)="First HIV: "_BUDHIVDX_": "_$$DATE^BUDDUTL1(BUDHIVD)_"|Follow-up: "_$PIECE(BUDHIVF,U,2)_" "_$$DATE^BUDDUTL1($PIECE(BUDHIVF,U,1))_"|"_$$DATE^BUDDUTL1
(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 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 ;REFUSAL OF DEPRESSION SCREENING EXAM OR CPT OR MEASUREMENT
+10 IF $$REFDS(DFN,BUDBD,BUDED)
QUIT
+11 ;DENOMINATOR EXCLUSION, ANY ONE WITH ACTIVE PL ENTRY OF THE DX OR SNOMED
+12 ;GET DATE OF FIRST SCREEN IN REPORT PERIOD
+13 ;pcc or bh problem list
IF $$HASDEPPL(DFN,"T6B DEP DEP/BIPOLAR CODES",$$VD^APCLV(BUDFRSTV))
QUIT
+14 ;Q:$$HASDEPOV(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT($$VD^APCLV(BUDFRSTV),-1)) ;PCC DX DURING REPORT PERIOD
+15 SET BUDFDEP=$$FDEPSCR^BUDDRP6M(DFN,BUDBD,BUDED)
+16 ;if screen, was there a diagnosis before the SCREEN AND DURING REPORT PERIOD? if so, quit
+17 IF BUDFDEP
IF $$HASDEPOV(DFN,BUDBD,BUDFDEP)
QUIT
+18 ;if no screen quit if any dx during report period
IF 'BUDFDEP
IF $$HASDEPOV(DFN,BUDBD,BUDED)
QUIT
+19 ;DENOMINATOR
SET BUDSECTM("PTS")=$GET(BUDSECTM("PTS"))+1
+20 ;DO THEY HAVE A SCREEN?
+21 ;CHECK exam, phq2, phq9, phqt for a positive and if no positive get the first negative
+22 SET (BUDSCR,BUDPLAN)=""
+23 SET BUDSCR=$$DEPRES(DFN,BUDBD,BUDED)
+24 ;dx prior to screen and during report period
IF BUDSCR]""
IF $$HASDEPOV(DFN,BUDBD,$PIECE(BUDSCR,U,1))
QUIT
+25 IF BUDSCR]""
GOTO R
+26 ;now check for any without a result and assume negative (per Duane)
+27 ;S BUDSCR=$$DEPNORES(DFN,BUDBD,BUDED) ;NO CPTS PER MEGAN
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),$PIECE(BUDSCR,U,1))
+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("BUDDRP6B",BUDJ,BUDH,"DEP2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDSCR_"|"_BUDPLAN
End DoDot:2
+4 IF $GET(BUDDEP1L)
IF BUDN
Begin DoDot:2
+5 SET ^XTMP("BUDDRP6B",BUDJ,BUDH,"DEP1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDSCR_"|"_BUDPLAN
End DoDot:2
End DoDot:1
+6 QUIT
REFDS(P,BDATE,EDATE) ;
+1 IF $$REFRU^BUDDUTL1(P,9999999.15,$ORDER(^AUTTEXAM("C",36,0)),BDATE,EDATE)
QUIT 1
+2 IF $$REFRU^BUDDUTL1(P,81,$PIECE($$CPT^ICPTCOD("3725F"),U,1),BDATE,EDATE)
QUIT 1
+3 IF $$REFRU^BUDDUTL1(P,81,$PIECE($$CPT^ICPTCOD("1220F"),U,1),BDATE,EDATE)
QUIT 1
+4 IF $$REFRU^BUDDUTL1(P,81,$PIECE($$CPT^ICPTCOD("G0444"),U,1),BDATE,EDATE)
QUIT 1
+5 IF $$REFRU^BUDDUTL1(P,9999999.07,$ORDER(^AUTTMSR("B","PHQ2",0)),BDATE,EDATE)
QUIT 1
+6 IF $$REFRU^BUDDUTL1(P,9999999.07,$ORDER(^AUTTMSR("B","PHQ9",0)),BDATE,EDATE)
QUIT 1
+7 IF $$REFRU^BUDDUTL1(P,9999999.07,$ORDER(^AUTTMSR("B","PHQT",0)),BDATE,EDATE)
QUIT 1
+8 QUIT ""
PLAN(P,BDATE,EDATE) ;
+1 ;CHECK MEDS, CPTS, SNOMEDS
+2 NEW BUDVS,BUDDEPS,BUDV,BUDX,BUDA,BUDD,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 BUDD=0
SET BUDDEPS=""
+7 SET T=$ORDER(^BUDDTSSC("B","T6B DEP DEPRESSION PLAN CODES",0))
+8 SET J=$ORDER(^ATXAX("B","BGP HEDIS ANTIDEPRESSANT MEDS",0))
+9 SET K=$ORDER(^ATXAX("B","BGP HEDIS ANTIDEPRESSANT NDC",0))
+10 FOR
SET BUDX=$ORDER(BUDVS(BUDX))
IF BUDX'=+BUDX!(BUDDEPS]"")
QUIT
Begin DoDot:1
+11 ;DX/snomed
+12 SET BUDV=$PIECE(BUDVS(BUDX),U,5)
+13 SET BUDY=0
FOR
SET BUDY=$ORDER(^AUPNVPOV("AD",BUDV,BUDY))
IF BUDY'=+BUDY!(BUDDEPS]"")
QUIT
Begin DoDot:2
+14 IF '$DATA(^AUPNVPOV(BUDY,0))
QUIT
+15 ;NOW CHECK SNOMED
+16 SET A=$PIECE($GET(^AUPNVPOV(BUDY,11)),U,1)
+17 IF A=""
QUIT
+18 IF $DATA(^BUDDTSSC("AS",A,T))
SET BUDDEPS=$$VD^APCLV(BUDV)_U_"SNOMED: "_A
QUIT
End DoDot:2
+19 ;CPT
+20 SET BUDY=0
FOR
SET BUDY=$ORDER(^AUPNVCPT("AD",BUDV,BUDY))
IF BUDY'=+BUDY!(BUDDEPS]"")
QUIT
Begin DoDot:2
+21 IF '$DATA(^AUPNVCPT(BUDY,0))
QUIT
+22 SET A=$$VAL^XBDIQ1(9000010.18,BUDY,.01)
+23 IF '$DATA(^BUDDTSSC("AC",A,T))
QUIT
+24 SET BUDDEPS=$$VD^APCLV(BUDV)_U_"CPT: "_A
End DoDot:2
+25 ;NOW CHECK MEDS
+26 SET BUDY=0
FOR
SET BUDY=$ORDER(^AUPNVMED("AD",BUDV,BUDY))
IF BUDY'=+BUDY!(BUDDEPS]"")
QUIT
Begin DoDot:2
+27 IF '$DATA(^AUPNVMED(BUDY,0))
QUIT
+28 SET D=$PIECE(^AUPNVMED(BUDY,0),U,1)
+29 IF D=""
QUIT
+30 IF '$DATA(^PSDRUG(D,0))
QUIT
+31 IF $DATA(^ATXAX(J,21,"B",D))
SET BUDDEPS=$$VD^APCLV(BUDV)_U_"RX: "_$$VAL^XBDIQ1(9000010.14,BUDY,.01)
QUIT
+32 ;check NDC
+33 IF $$NDC(D,K)
SET BUDDEPS=$$VD^APCLV(BUDV)_U_"RX: "_$$VAL^XBDIQ1(9000010.14,BUDY,.01)
QUIT
+34 ;check rxnorm?
+35 ;GET PRESCRIPTION
+36 SET BUDRXRF=""
+37 ;NO 52 ENTRY
SET BUDRX=$ORDER(^PSRX("APCC",BUDY,0))
IF 'BUDRX
QUIT
+38 IF BUDRX
SET BUDRXRF=$ORDER(^PSRX("APCC",BUDY,BUDRX,""))
IF BUDRXRF=""
SET BUDRXRF=0
+39 SET BUDNORM=""
+40 IF BUDRXRF
SET BUDNORM=$PIECE($GET(^PSRX(BUDRX,1,BUDRXRF,9999999)),U,19)
+41 IF BUDNORM=""
SET BUDNORM=$PIECE($GET(^PSRX(BUDRX,999999921)),U,7)
+42 IF BUDNORM]""
IF $DATA(^BUDDTSSC(T,19,"B",BUDNORM))
SET BUDDEPS=$$VD^APCLV(BUDV)_U_"RX NORM: "_$$VAL^XBDIQ1(9000010.14,BUDY,.01)
QUIT
End DoDot:2
End DoDot:1
+43 IF BUDDEPS]""
QUIT BUDDEPS
+44 ;
+45 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
+46 SET X=0
FOR
SET X=$ORDER(^AMHRPROC("AD",V,X))
IF X'=+X
QUIT
SET BUDP=$$VAL^XBDIQ1(9002011.04,X,.01)
Begin DoDot:2
+47 IF BUDP=""
QUIT
+48 IF '$DATA(^BUDDTSSC("AC",BUDP,T))
QUIT
+49 SET BUDDEPS=9999999-$PIECE(D,".")_U_"BH CPT: "_$$GET1^DIQ(9002011.04,X,.01)
End DoDot:2
End DoDot:1
+50 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,BUDD
+3 NEW BUDG,BUDR,BUDALL
+4 SET BUDD=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
+29 IF $PIECE($GET(^AUPNVPOV(BUDR,11)),U,1)=428171000124102
Begin DoDot:2
+30 SET BUDALL("NEG",$PIECE(BUDG(E),U,1))=$PIECE(BUDG(E),U,1)_U_"SNOMED "_"428171000124102"_U_"NEG"
End DoDot:2
End DoDot:1
+31 ;NOW GO TO BH
+32 ;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(^BUDDTSSC("B","T6B DEP DEP/BIPOLAR CODES",0))
+4 SET BUDVS="BUDVS"
SET BUDDX4=""
+5 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+6 SET BUDX=0
FOR
SET BUDX=$ORDER(BUDVS(BUDX))
IF BUDX'=+BUDX!(BUDDX4)
QUIT
Begin DoDot:1
+7 SET BUDV=$PIECE(BUDVS(BUDX),U,5)
+8 SET BUDI=$$PRIMPOV(BUDV)
+9 IF BUDI=""
QUIT
+10 SET BUDDX3=$PIECE($GET(^AUPNVPOV(BUDI,0)),U)
+11 ;FOUND ONE
IF $DATA(^BUDDTSSC("AD",BUDDX3,T))
SET BUDDX4=1_"^"_$PIECE($$ICDDX^ICDEX(BUDDX3),U,2)_"^"_$$VD^APCLV(BUDV)_"^"_BUDDX3
QUIT
+12 ;NOW CHECK SNOMED
+13 SET A=$PIECE($GET(^AUPNVPOV(BUDI,11)),U,1)
+14 IF A=""
QUIT
+15 ;FOUND ONE
IF $DATA(^BUDDTSSC("AS",A,T))
SET BUDDX4=1_"^"_$PIECE($$ICDDX^ICDEX(BUDDX3),U,2)_"^"_$$VD^APCLV(BUDV)_"^"_BUDDX3
QUIT
+16 QUIT
End DoDot:1
+17 IF BUDDX4
QUIT BUDDX4
+18 SET SD=$$FMADD^XLFDT(BDATE,-1)
SET SD=SD_".9999"
+19 FOR
SET SD=$ORDER(^AMHREC("AF",P,SD))
IF SD'=+SD!($PIECE(SD,".")>EDATE)!(BUDDX4)
QUIT
Begin DoDot:1
+20 SET BUDDX2=0
FOR
SET BUDDX2=$ORDER(^AMHREC("AF",P,SD,BUDDX2))
IF BUDDX2'=+BUDDX2!(BUDDX4)
QUIT
Begin DoDot:2
+21 SET BUDDX5=0
SET BUDDX5=$ORDER(^AMHRPRO("AD",BUDDX2,BUDDX5))
IF BUDDX5=""!(BUDDX4]"")
QUIT
Begin DoDot:3
+22 SET BUDDX3=$PIECE($GET(^AMHRPRO(BUDDX5,0)),U,1)
+23 IF BUDDX3=""
QUIT
+24 ;ICD9 CODE
SET Z=$PIECE($GET(^AMHPROB(BUDDX3,0)),U,5)
+25 IF Z=""
QUIT
+26 SET Y=+$$CODEN^ICDEX(Z,80)
+27 ;FOUND ONE
IF $DATA(^BUDDTSSC("AD",Y,T))
SET BUDDX4=1_"^"_$PIECE($$ICDDX^ICDEX(Y),U,2)_"^"_SD_"^"_BUDDX3_"^"_BUDDX5
QUIT
+28 ;ICD9 CODE
SET Z=$PIECE($GET(^AMHPROB(BUDDX3,0)),U,17)
+29 IF Z=""
QUIT
+30 SET Y=+$$CODEN^ICDEX(Z,80)
+31 ;FOUND ONE
IF $DATA(^BUDDTSSC("AD",Y,T))
SET BUDDX4=1_"^"_$PIECE($$ICDDX^ICDEX(Y),U,2)_"^"_SD_"^"_BUDDX3_"^"_BUDDX5
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+32 QUIT BUDDX4
HASDEPPL(P,A,BD) ;EP - ACTIVE DEPRESSION ON PL
+1 IF $GET(P)=""
QUIT ""
+2 IF $GET(A)=""
QUIT ""
+3 NEW T,N
SET T=$ORDER(^BUDDTSSC("B",A,0))
+4 IF 'T
QUIT ""
+5 NEW X,Y,I,A,D,G
SET (X,Y)=0
SET I=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
IF $DATA(^AUPNPROB(X,0))
Begin DoDot:1
+6 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+7 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+8 SET A=0
SET D=""
SET G=""
FOR
SET A=$ORDER(^AUPNPROB(X,14,A))
IF A'=+A!(G)
QUIT
Begin DoDot:2
+9 SET D=$$VD^APCLV($PIECE(^AUPNPROB(X,14,A,0),U,1))
+10 ;GOOD DATE
IF D'>BD
SET G=1
End DoDot:2
+11 IF 'G
SET A=0
SET D=""
FOR
SET A=$ORDER(^AUPNPROB(X,15,A))
IF A'=+A!(G)
QUIT
Begin DoDot:2
+12 SET D=$$VD^APCLV($PIECE(^AUPNPROB(X,15,A,0),U,1))
+13 IF D'>BD
SET G=1
End DoDot:2
+14 IF 'G
IF $PIECE(^AUPNPROB(X,0),U,8)'>BD
SET G=1
+15 IF 'G
IF $PIECE(^AUPNPROB(X,0),U,3)'>BD
SET G=1
+16 IF 'G
QUIT
+17 SET Y=$PIECE(^AUPNPROB(X,0),U)
IF $DATA(^BUDDTSSC("AD",Y,T))
SET I=1_U_$$VAL^XBDIQ1(9000011,X,.01)_U_$PIECE(^AUPNPROB(X,0),U,3)
QUIT
+18 SET N=$$VAL^XBDIQ1(9000011,X,80001)
IF N]""
IF $DATA(^BUDDTSSC("AS",N,T))
SET I=1_U_N_U_$PIECE(^AUPNPROB(X,0),U,3)
End DoDot:1
+19 QUIT I
+20 ;
DEPNORES(P,BDATE,EDATE) ;EP
+1 ;CHECK FOR V79.0, CPTS
+2 NEW BUDVS,BUDDEPS,BUDV,BUDX,BUDA,BUDD,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 BUDD=0
+7 FOR
SET BUDX=$ORDER(BUDVS(BUDX))
IF BUDX'=+BUDX
QUIT
Begin DoDot:1
+8 SET BUDV=$PIECE(BUDVS(BUDX),U,5)
+9 ;CPT
+10 SET BUDY=0
FOR
SET BUDY=$ORDER(^AUPNVCPT("AD",BUDV,BUDY))
IF BUDY'=+BUDY
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVCPT(BUDY,0))
QUIT
+12 IF '$$ICD^ATXCHK($PIECE(^AUPNVCPT(BUDY,0),U),$ORDER(^ATXAX("B","BUD DEPRESSION SCREEN CPTS",0)),1)
QUIT
+13 SET BUDDEPS($$VD^APCLV(V))=$$VD^APCLV(BUDV)_U_"CPT: "_$$GET1^DIQ(9000010.18,BUDY,.01)_U_"NEG"
End DoDot:2
+14 ;====================================
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(^AMHRPROC("AD",V,X))
IF X'=+X
QUIT
SET BUDP=$PIECE($GET(^AMHRPROC(X,0)),U)
Begin DoDot:2
+3 IF 'BUDP
QUIT
+4 IF '$$ICD^ATXCHK(BUDP,$ORDER(^ATXAX("B","BUD DEPRESSION SCREEN CPTS",0)),1)
QUIT
+5 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
+6 SET Y=$ORDER(BUDDEPS(0))
IF Y
QUIT BUDDEPS(Y)
+7 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
