BUDHRP6Q.m

BUDHRP6Q ;IHS/CMI/LAB - UDS T6B;

 ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;**1**;OCT 12, 2018;Build 2

 ;

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

 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 BUDDOA=""

 ;now check problem list date of onset

 S T=$O(^BUDHTSSC("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)=""

 .S Y=$P(^AUPNPROB(X,0),U)

 .;)

 .Q:'$D(^BUDHTSSC("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("BUDHRP6B",BUDJ,BUDH,"HIV2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)="First HIV: "_BUDHIVDX_": "_$$DATE^BUDHUTL1(BUDHIVD)_"|Follow-up: "_$P(BUDHIVF,U,2)_" "_$$DATE^BUDHUTL1($P(BUDHIVF,U,1))_"|"_$$DATE^BUDHUTL1(BUDDOA)

 .I $G(BUDHIV1L) D

 ..I BUDHIVF]"" S ^XTMP("BUDHRP6B",BUDJ,BUDH,"HIV1",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)="First HIV: "_BUDHIVDX_": "_$$DATE^BUDHUTL1(BUDHIVD)_"|Follow-up: "_$P(BUDHIVF,U,2)_" "_$$DATE^BUDHUTL1($P(BUDHIVF,U,1))_"|"_$$DATE^BUDHUTL1(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)-13)_"1231"

 Q:BUDDOB>BUDX12RB

 S BUDP12BD=($E(BUDDOB,1,3)+12)_$E(BUDDOB,4,7)

 K BUDG

 ;get first depression screen during the report period.

 S BUDFDEP=$$FDEPSCR^BUDHRP6M(DFN,BUDBD,BUDED)

 ;DENOMINATOR EXCLUSION - ACTIVE DX FOR DEPRESSION OR BIPOLAR DX BEFORE SCREEN OR IF NO SCREEN USE END DATE OF REPORT PERIOD

 I $$HASDEPPL(DFN,"T6B DEP DEPRESSION CODES",$S(BUDFDEP]"":$$FMADD^XLFDT(BUDFDEP,-1),1:BUDED)) Q  ;pcc or bh problem list

 I $$HASDEPPL(DFN,"T6B DEP BIPOLAR DXS",$S(BUDFDEP]"":$$FMADD^XLFDT(BUDFDEP,-1),1:BUDED)) Q  ;pcc or bh problem list

 ;if screen, was there a diagnosis before the SCREEN AND DURING REPORT PERIOD? if so, quit

 I BUDFDEP Q:$$HASDEPOV(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BUDFDEP,-1),"T6B DEP DEPRESSION CODES")

 I 'BUDFDEP Q:$$HASDEPOV(DFN,$$DOB^AUPNPAT(DFN),BUDED,"T6B DEP DEPRESSION CODES")  ;if no screen quit if any dx during report period

 I BUDFDEP Q:$$HASDEPOV(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BUDFDEP,-1),"T6B DEP BIPOLAR DXS")

 I 'BUDFDEP Q:$$HASDEPOV(DFN,$$DOB^AUPNPAT(DFN),BUDED,"T6B DEP BIPOLAR DXS")  ;if no screen quit if any dx during report period

 ;

 I 'BUDFDEP Q:$$REFUSAL(DFN,BUDBD,BUDED)  ;if no screen, quit if they refused

 ;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)  ;MOST RECENT WITH A RESULT

 ;

R ;

 S BUDSECTM("PTS")=$G(BUDSECTM("PTS"))+1  ;DENOMINATOR

 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=$$FUPLAN(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("BUDHRP6B",BUDJ,BUDH,"DEP2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDSCR_"|"_BUDPLAN

 .I $G(BUDDEP1L),BUDN D

 ..S ^XTMP("BUDHRP6B",BUDJ,BUDH,"DEP1",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDSCR_"|"_BUDPLAN

 Q

REFUSAL(P,BDATE,EDATE) ;

 ;CHECK REFUSAL FILE FIRST FOR FLU CVX OR FLU CPT AND MEDICAL REASON NOT DONE SNOMED OR PATIENT REASON NOT DONE SNOMED OR SYSTEM REASON NOT DONE SNOMED

 ;ITEM 1-2, 1-3, 1-4

 NEW F,G,I,C,ID,X,T1,T2

 S T1=$O(^BUDHTSSC("B","PXRM BGP IPC NOT DONE MED",0))

 S T2=$O(^BUDHTSSC("B","PXRM BGP IPC NOT DONE PAT",0))

 S F=0,G="" F F=9999999.07,9999999.15  D

 .S I="" F  S I=$O(^AUPNPREF("AA",P,F,I)) Q:I=""!(G)  D

 ..;check all file vs item combos

 ..I F=9999999.15,$$VAL^XBDIQ1(9999999.15,I,.02)'=36 Q

 ..I F=9999999.07 S C=$P($G(^AUTTMSR(I,0)),U,1) I C'="PHQ2",C'="PHQ9",C'="PHQT" Q

 ..S ID=0 F  S ID=$O(^AUPNPREF("AA",P,F,I,ID)) Q:ID=""!(G)  D

 ...S X=0 F  S X=$O(^AUPNPREF("AA",P,F,I,ID,X)) Q:X'=+X!(G)  D

 ....;get snomed reason not done and it must be in one of the subsets

 ....S R=$$VALI^XBDIQ1(9000022,X,1.01)  ;SNOMED REASON NOT DONE

 ....I R]"",$D(BUDHTSSC(T1,13,"B",R)) S G=1 Q

 ....I R]"",$D(BUDHTSSC(T2,13,"B",R)) S G=1 Q

 ....I $$VALI^XBDIQ1(9000022,X,.07)="R" S G=1 Q

 ....I $$VALI^XBDIQ1(9000022,X,.07)="N" S G=1 Q

 Q G

FUPLAN(P,BDATE,EDATE) ;

 ;PROBLEM LIST SNOMED ENTERED ON BDATE

 NEW X,G,S,BUDG,Y,I,V,W,Z,TAX,BUDMEDS1,TAX1,M,R,B,O,T1,T2,T3,D1,D,C,C1,T4

 S T1=$O(^BUDHTSSC("B","PXRM BGP IPC DEP INTER",0))

 S T2=$O(^BUDHTSSC("B","T6B DEP DEPRESSION CODES",0))

 S T3=$O(^BUDHTSSC("B","T6B DEP BIPOLAR DXS",0))

 S T4=$O(^BUDHTSSC("B","T6B DEP DEPRESSION PLAN CODES",0))

 S X=0,G="" F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G)  D

 .Q:'$D(^AUPNPROB(X,0))

 .Q:$P(^AUPNPROB(X,0),U,12)="D"

 .Q:$P(^AUPNPROB(X,0),U,8)'=BDATE

 .S S=$$VAL^XBDIQ1(9000011,X,80001)

 .Q:S=""

 .I '$D(^BUDHTSSC(T1,13,"B",S)) Q

 .S G=1_U_"F/U PL "_S

 I G Q G

 ;now vpov using asnc

 S Y="BUDG("

 S X=P_"^ALL DX;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)

 S X=0 F  S X=$O(BUDG(X)) Q:X'=+X!(G)  D

 .S I=+$P(BUDG(X),U,4)

 .S V=$P(BUDG(X),U,5)

 .S S=$$VAL^XBDIQ1(9000010.07,I,1101)

 .I S="" Q

 .I '$D(^BUDHTSSC(T1,13,"B",S)) Q

 .S G=1_U_"F/U POV "_S

 I G Q G

 ;NOW CPT

 S C=0 F  S C=$O(^AUPNVCPT("AA",P,C)) Q:C'=+C!(G)  D

 .S C1=$P($G(^ICPT(C,0)),U,1)

 .Q:C1=""

 .Q:'$D(^BUDHTSSC(T4,14,"B",C1))

 .S D=0 F  S D=$O(^AUPNVCPT("AA",P,C,D)) Q:D'=+D!(G)  D

 ..S D1=9999999-D

 ..Q:D1<BDATE

 ..Q:D1>EDATE

 ..S G=1_U_"F/U CPT "_C1

 I G Q G

 ;REFERRALS?  ANY V REFERRAL ON DATE WITH A SNOMED AS .01 FIELD

 S Z=0 F  S Z=$O(^AUPNVREF("AC",P,Z)) Q:Z'=+Z!(G)  D

 .S V=$P($G(^AUPNVREF(Z,0)),U,3)

 .S D=$$VD^APCLV(V)

 .Q:D<BDATE

 .Q:D>EDATE

 .S S=$P($G(^AUPNVREF(Z,0)),U,1) Q:S=""

 .Q:'$D(^BUDHTSSC(T1,13,"B",S))

 .S G=1_U_"F/U Referral: "_S Q

 I G Q G

 S G=""

 ;V PATIENT EDUCATION

 K BUDG

 S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)

 S X=0 F  S X=$O(BUDG(X)) Q:X'=+X!(G)  D

 .S I=+$P(BUDG(X),U,4)

 .S T=$$VALI^XBDIQ1(9000010.16,I,.01)

 .Q:'T

 .Q:'$D(^AUTTEDT(T,0))

 .S T=$P(^AUTTEDT(T,0),U,2)

 .I $P(T,"-",2)'="FU" Q  ;must be followup

 .S S=$P(T,"-",1)

 .S C=$$ICDDX^ICDEX(S)

 .I $P(C,U,1)'="-1",$$ICD^ATXAPI($P(C,U,1),$O(^ATXAX("B","BGP IPC DEPRESSION DIAG DXS",0)),9) S G=1_U_"F/U Pt Ed "_T Q

 .I $P(C,U,1)'="-1",$$ICD^ATXAPI($P(C,U,1),$O(^ATXAX("B","BGP IPC BIPOLAR DISORDER DXS",0)),9) S G=1_U_"F/U Pt Ed "_T Q

 .;is it a snomed?

 .I $D(^BUDHTSSC(T1,13,"B",S)) S G=1_U_"F/U Pt Ed "_T Q

 .I $D(^BUDHTSSC(T2,13,"B",S)) S G=1_U_"F/U Pt Ed "_T Q

 .I $D(^BUDHTSSC(T3,13,"B",S)) S G=1_U_"F/U Pt Ed "_T Q

 I G Q G

 ;v med first

 D GETMEDS^BUDHUTL2(P,BDATE,EDATE,"BGP IPC DEPRESSION MEDS","",,,.BUDMEDS1,"BGP IPC DEPRESSION RXNORM")

 S X=0,T=0,W="" F  S X=$O(BUDMEDS1(X)) Q:X'=+X!(G)  D

 .S Y=$P(BUDMEDS1(X),U,4)  ;vmed ien

 .Q:'$D(^AUPNVMED(Y,0))

 .Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"

 .S D=$P(^AUPNVMED(Y,0),U,1)  ;drug ien

 .;DAYS SUPPLY MUST BE >0

 .S E=$P(^AUPNVMED(Y,0),U,8) ;date discontinued

 .S S=$P(^AUPNVMED(Y,0),U,7) ;DAYS SUPPLY

 .Q:'S

 .I E,E'>$P(BUDMEDS1(X),U,1) Q  ;at least one day

 .S G=1_U_"F/U Med "_$$VAL^XBDIQ1(9000010.14,Y,.01)

 I G Q G

 ;how about orders

 ;go through all 52 for one ordered on BDATE

 S TAX=$O(^ATXAX("B","BGP IPC DEPRESSION MEDS",0))

 S TAX1=$O(^BGPSNOMR("B","BGP IPC DEPRESSION RXNORM",0))

 S Z=0,G="" F  S Z=$O(^PS(55,P,"P",Z)) Q:Z'=+Z!(G)  D

 .S R=$P(^PS(55,P,"P",Z,0),U,1)

 .Q:'$D(^PSRX(R,0))  ;bad xref

 .S D=$P(^PSRX(R,0),U,6)

 .Q:'D  ;no drug??

 .S M=0

 .I $D(^ATXAX(TAX,21,"B",D)) S M=1

 .S B=$$VAL^XBDIQ1(9000010.14,R,9999999.27)

 .I B]"",$D(^BGPSNOMR(TAX1,11,"B",B)) S M=1

 .Q:'M

 .;ORDER

 .S O=$P($G(^PSRX(R,"OR1")),U,2)  ;order number

 .Q:'O

 .Q:'$D(^OR(100,O))

 .S A=0 F  S A=$O(^OR(100,O,8,A)) Q:A'=+A!(G)  D

 ..S D=$P($G(^OR(100,O,8,A,0)),U,1)

 ..I $P(D,".")=BDATE S G=1_U_"F/U PSRX Order"

 I G Q G

EHRO ;EPRES

 ;EHR OUTSIDE

 S C=$$PRES^BUDHRP6W(P,TAX,BDATE,EDATE)

 I C]"" Q 1_U_$P(C,U,1)_" on "_$$FMTE^XLFDT($P(C,U,3))

 Q ""

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

 .I $P(BUDG(E),U,2)="?" Q  ;no result

 .S BUDR=$S($P(BUDG(E),U,2)="PO":"POS",$P(BUDG(E),U,2)="RF":"POS",1:"NEG")

 .S BUDALL(9999999-$P(BUDG(E),U,1))=$P(BUDG(E),U,1)_U_"PCC EX 36"_U_BUDR_" "_$P(BUDG(E),U,2)

 ;phq2

 K BUDG S %=P_"^ALL MEAS PHQ2;DURING "_BD_"-"_ED,E=$$START1^APCLDF(%,"BUDG(")

 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(9999999-$P(BUDG(E),U,1))=$P(BUDG(E),U,1)_U_"PCC PHQ2"_U_BUDR

 K BUDG S %=P_"^ALL MEAS PHQ9;DURING "_BD_"-"_ED,E=$$START1^APCLDF(%,"BUDG(")

 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(9999999-$P(BUDG(E),U,1))=$P(BUDG(E),U,1)_U_"PCC PHQ9"_U_BUDR

 K BUDG S %=P_"^ALL MEAS PHQT;DURING "_BD_"-"_ED,E=$$START1^APCLDF(%,"BUDG(")

 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(9999999-$P(BUDG(E),U,1))=$P(BUDG(E),U,1)_U_"PCC PHQT"_U_BUDR

 ;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($P(D,"."))) S BUDR="NEG",BUDALL($P(D,"."))=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($P(D,"."))=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(D,"."))) D

 ....S BUDALL($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)

 S X=$O(BUDALL(0)) I 'X Q ""

 Q BUDALL(X)

 ;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,A) ;EP - 

 I '$G(P) Q ""

 NEW T,B,BUDVS,BUDX,BUDV,BUDDX2,BUDDX3,BUDDX4,BUDDX5

 S T=$O(^BUDHTSSC("B",A,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(^BUDHTSSC("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(^BUDHTSSC("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)

 ...I Z="" Q

 ...S Y=+$$CODEN^ICDEX(Z,80)

 ...I $D(^BUDHTSSC("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)

 ...I Z="" Q

 ...S Y=+$$CODEN^ICDEX(Z,80)

 ...I $D(^BUDHTSSC("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(^BUDHTSSC("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

 .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(^BUDHTSSC("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(^BUDHTSSC("AS",N,T)) S I=1_U_N_U_$P(^AUPNPROB(X,0),U,3)

 Q I

 ;

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

BUDHRP6Q  ;IHS/CMI/LAB - UDS T6B;

 +1       ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;**1**;OCT 12, 2018;Build 2

 +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        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       SET BUDDOA=""

 +17      ;now check problem list date of onset

 +18       SET T=$ORDER(^BUDHTSSC("B","T6B HIV HIV CODES",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               IF $PIECE(^AUPNPROB(X,0),U,13)=""

                       QUIT 

 +22               SET Y=$PIECE(^AUPNPROB(X,0),U)

 +23      ;)

 +24               IF '$DATA(^BUDHTSSC("AD",Y,T))

                       QUIT 

 +25               SET BUDDOA=$PIECE(^AUPNPROB(X,0),U,13)

 +26               IF $PIECE(^AUPNPROB(X,0),U,13)<BUDHIVD

                       SET G=1

 +27               QUIT 

               End DoDot:1

 +28       IF G

               QUIT 

 +29       SET BUDHIVF=$$FU(DFN,$$FMADD^XLFDT(BUDHIVD,1))

 +30       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("BUDHRP6B",BUDJ,BUDH,"HIV2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)="First HIV: "_BUDHIVDX_": "_$$DATE^BUDHUTL1(BUDHIVD)_"|Follow-up: "_$PIECE(BUDHIVF,U,2)_" "_$$DATE^BUDHUTL1($PIECE(BUDHIVF,U,1))_"|"_$$DATE^BUDHUTL1