BUDDRP6Q.m

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)