BUDDRP6V.m

BUDDRP6V ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;

 ;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66

 ;

 ;

ADOLWT ;EP - called from xbdbque

 ;must have DOB between 1/1/06 and 12/31/06

 NEW BUDBMI,BUDDOB,BUD17RB,BUD3RB,BUD18BD,X,G

 S BUDDOB=$P(^DPT(DFN,0),U,3)

 S BUD17RB=($E(BUDBD,1,3)-17)_"0101"  ;RERPORT PERIOD 17 BD

 S BUD3RB=($E(BUDED,1,3)-3)_"1231"   ;REPORT PERIOD 3 BD

 Q:BUDDOB>BUD3RB

 Q:BUDDOB<BUD17RB

 Q:BUDMEDV<1  ;AT LEAST 1 MEDICAL VISIT

 S BUD18BD=$E(BUDDOB,1,3)+18_$E(BUDDOB,4,7)

 I '$$VBBD(DFN,BUDDOB,$$FMADD^XLFDT(BUD18BD,-1)) Q  ;SEEN AT LEAST ONCE BEFORE 18TH DOB

 Q:$$PREG^BUDDRP6B(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED,BUDBD)

 S BUDBMI=$$BMINPA(DFN,BUDBD,BUDED,BUDAGE)

 S G=0 F X=1:1:3 I $P(BUDBMI,U,X)]"" S G=G+1

 I G=3 S BUDSECTE("AWT")=$G(BUDSECTE("AWT"))+1

 ;put the rest in demoninator

 S BUDSECTE("PTS")=$G(BUDSECTE("PTS"))+1 D

 .I $G(BUDWAC2L) D

 ..I G'=3 S ^XTMP("BUDDRP6B",BUDJ,BUDH,"WAC2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDBMI

 .I $G(BUDWAC1L) D

 ..I G=3 S ^XTMP("BUDDRP6B",BUDJ,BUDH,"WAC1",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDBMI

 Q

 ;

 ;

VBBD(P,BDATE,EDATE) ;EP

 NEW BUDVL,G,V,A,L

 K BUDVL

 S G=""

 S A="BUDVL(",B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)

 I '$D(BUDVL) Q ""

 S X=0 F  S X=$O(BUDVL(X)) Q:X'=+X  S V=$P(BUDVL(X),U,5) D

 .Q:'$D(^AUPNVSIT(V,0))

 .Q:'$P(^AUPNVSIT(V,0),U,9)

 .Q:$P(^AUPNVSIT(V,0),U,11)

 .Q:'$D(^AUPNVPRV("AD",V))

 .Q:'$D(^AUPNVPOV("AD",V))

 .S L=$P(^AUPNVSIT(V,0),U,6)

 .Q:L=""

 .Q:'$D(^BUDDSITE(BUDSITE,11,L))  ;not valid location

 .Q:$P(^AUPNVSIT(V,0),U,7)="C"

 .Q:$P(^AUPNVSIT(V,0),U,7)="T"

 .Q:$P(^AUPNVSIT(V,0),U,7)="N"

 .Q:$P(^AUPNVSIT(V,0),U,7)="D"

 .Q:$P(^AUPNVSIT(V,0),U,7)="X"

 .Q:$P(^AUPNVSIT(V,0),U,7)="E"

 .S G=V

 .Q

 Q G

 ;

BMINPA(P,BDATE,EDATE,AGE) ;EP

 NEW %,W,H,B,D,%DT,RETVAL,BUDBMI,BUDNE,BUDPA

 S BUDBMI=$$LASTITEM^APCLAPIU(P,"BMIP","MEASUREMENT",BDATE,EDATE,"A") I BUDBMI]"" S BUDBMI=$P(BUDBMI,U,3)_" %ile meas" ;get percentile

 I BUDBMI="" S BUDBMI=$$LASTITEM^APCLAPIU(P,"BMI","MEASUREMENT",BDATE,EDATE,"A") I BUDBMI]"" S BUDBMI=$P(BUDBMI,U,3)_" BMI meas"

 I BUDBMI="" S BUDBMI=$$BMI(P,BDATE,EDATE,AGE) I BUDBMI]"" S BUDBMI=BUDBMI_" BMI"

 I BUDBMI="" S BUDBMI=$$BMIPROC(P,BDATE,EDATE)

 ;I BUDBMI="" I $$REF(P,$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),-(6*30.5)),$$VD^APCLV(BUDLASTV)) Q "REF"

 S BUDNE=$$NUTR(P,BDATE,EDATE)

 S BUDPA=$$PA(P,BDATE,EDATE)

 Q BUDBMI_U_BUDNE_U_BUDPA

BMIPROC(P,BDATE,EDATE) ;EP

 NEW D,BUDG,E,%

 K BUDG S %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")

 NEW X,Y,G,T

 S T=$O(^BUDDTSSC("B","T6B ADOLWT BMI DIAGNOSES CODES",0))

 S G=""

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

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

 .S Y=$P($G(^AUPNVPOV(Y,0)),U,1)

 .I $D(^BUDDTSSC("AD",Y,T)) S G="POV "_$P(BUDG(X),U,2)

 Q G

REF(P,BDATE,EDATE) ;EP

 NEW H,W

 S H=$$REFRNU^BUDDUTL1(P,9999999.07,$O(^AUTTMSR("B","HT",0)),BDATE,EDATE)

 I H Q 1

 S W=$$REFRNU^BUDDUTL1(P,9999999.07,$O(^AUTTMSR("B","WT",0)),BDATE,EDATE)

 I W Q 1

 Q ""

ADULTBMI(P,BDATE,EDATE,AGE) ;EP

 NEW BUDBMI

 S BUDBMI=$$LASTITEM^APCLAPIU(P,"BMI","MEASUREMENT",BDATE,EDATE,"A") I BUDBMI]"" S BUDBMI=$P(BUDBMI,U,3)_U_$P(BUDBMI,U)

 I BUDBMI="" S BUDBMI=$$BMI(P,BDATE,EDATE,AGE) I BUDBMI]"" S BUDBMI=BUDBMI_U_$P($$WT(P,BDATE,EDATE),U,1)

 Q BUDBMI

BMI(P,BDATE,EDATE,AGE) ;EP

 NEW HDATE,BUDBMIH,W,H,X

 S BUDBMIH=""

 I AGE>18,AGE<51 D  Q BUDBMIH

 .S HDATE=$$FMADD^XLFDT(BDATE,-(5*365)),HDATE=$$FMTE^XLFDT(HDATE)

 .;S BDATE=$$FMADD^XLFDT(BDATE,-(5*365))

 .S BDATE=$$FMTE^XLFDT(BDATE),EDATE=$$FMTE^XLFDT(EDATE)

 .S W=$P($$WT(P,BDATE,EDATE),U,1) I W=""!(W="?") Q

 .S H=$$HT(P,HDATE,EDATE) I H="" Q

 .S W=W*.45359,H=(H*.0254),H=(H*H),BUDBMIH=(W/H)

 I AGE>50 D  Q BUDBMIH

 .S HDATE=$$FMADD^XLFDT(BDATE,-(2*365)),HDATE=$$FMTE^XLFDT(HDATE)

 .S BDATE=$$FMTE^XLFDT(BDATE),EDATE=$$FMTE^XLFDT(EDATE)

 .S W=$P($$WT(P,BDATE,EDATE),U,1) I W=""!(W="?") Q

 .S HDATE=BDATE

 .S H=$$HT(P,HDATE,EDATE) I H="" Q

 .S W=W*.45359,H=(H*.0254),H=(H*H),BUDBMIH=(W/H)

 I AGE<19 D  Q BUDBMIH

 .S X=$$HTWTSD(P,BDATE,EDATE)

 .I '$P(X,"^") Q

 .I '$P(X,"^",2) Q

 .S W=$P(X,"^"),H=$P(X,"^",2)

 .S W=W*.45359,H=(H*.0254),H=(H*H),BUDBMIH=(W/H)

 .Q

 Q ""

HT(P,BDATE,EDATE) ;EP

 I 'P Q ""

 NEW %,BUDARRY,H,E

 S %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BUDARRY(") S H=$P($G(BUDARRY(1)),U,2)

 I H="" Q H

 I H["?" Q ""

 S H=$J(H,2,0)

 Q H

WT(P,BDATE,EDATE) ;EP

 I 'P Q ""

 NEW %,E,BUDLW,X,BUDLN,BUDL,BUDLD,BUDLZ,BUDLX,ICD

 K BUDL S BUDLW="" S BUDLX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(BUDLX,"BUDL(")

 S BUDLN=0 F  S BUDLN=$O(BUDL(BUDLN)) Q:BUDLN'=+BUDLN!(BUDLW]"")  D

 .S BUDLZ=$P(BUDL(BUDLN),U,5)

 .I '$D(^AUPNVPOV("AD",BUDLZ)) S BUDLW=$P(BUDL(BUDLN),U,2) Q

 . S BUDLD=0 F  S BUDLD=$O(^AUPNVPOV("AD",BUDLZ,BUDLD)) Q:'BUDLD!(BUDLW]"")  D

 .. S D=$P(BUDL(BUDLN),U)

 .. I $$ICD^ATXAPI($P(^AUPNVPOV(BUDLD,0),U,1),$O(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0)),9) Q

 .. S BUDLW=$P(BUDL(BUDLN),U,2)_U_$P(BUDL(BUDLN),U,1)

 ..Q

 Q BUDLW

HTWTSD(P,BDATE,EDATE) ;get last ht / wt on same day

 I '$G(P) Q ""

 KILL BUDLWTS,BUDLHTS,%,X,BUDLWTS1,BUDLHTS1,Y

 ;get all hts during time frame

 S %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BUDLHTS(")

 S Y=0 F  S Y=$O(BUDLHTS(Y)) Q:Y'=+Y  I $P(BUDLHTS(Y),U,2)="?"!($P(BUDLHTS(Y),U,2)="") K BUDLHTS(Y)

 ;set the array up by date

 K BUDLHTS1 S X=0 F  S X=$O(BUDLHTS(X)) Q:X'=+X  S BUDLHTS1($P(BUDLHTS(X),U))=X

 ;get all wts during time frame

 S %=P_"^ALL MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BUDLWTS(")

 S Y=0 F  S Y=$O(BUDLWTS(Y)) Q:Y'=+Y  I $P(BUDLWTS(Y),U,2)="?"!($P(BUDLWTS(Y),U,2)="") K BUDLWTS(Y)

 ;set the array up by date

 K BUDLWTS1 S X=0 F  S X=$O(BUDLWTS(X)) Q:X'=+X  S BUDLWTS1($P(BUDLWTS(X),U))=X

 S BUDLCHT="",X=9999999 F  S X=$O(BUDLWTS1(X),-1) Q:X=""!(BUDLCHT]"")  I $D(BUDLHTS1(X)) S BUDLCHT=$P(BUDLWTS(BUDLWTS1(X)),U,2)_U_$P(BUDLHTS(BUDLHTS1(X)),U,2)

 Q BUDLCHT

 ;

NUTR(P,BDATE,EDATE) ;EP

 NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,S,T,BUDNUT

 S BUDNUT=""

 D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")

 S TIEN=$O(^BUDDTSSC("B","T6B ADOLWT NUTRITION CODES",0))

 S CTR=0 F  S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR  D

 .S VIEN=$P(BUDVS(CTR),U,5)

 .S VDATE=$P(BUDVS(CTR),U,1)

 .S X=0 F  S X=$O(^AUPNVPED("AD",VIEN,X)) Q:X'=+X  D

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

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

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

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

 ..I $P(T,"-",2)="N"!($P(T,"-",2)="DT")!($P(T,"-",2)="MNT")!($P(T,"-",1)="MNT") S BUDNUT=T Q

 ..I $P(T,"-",1)="97802"!($P(T,"-",1)="97803")!($P(T,"-",1)="97804") S BUDNUT=T Q

 .;CPT

 .S X=0 F  S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X  D

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

 ..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)

 ..Q:Y=""

 ..I $D(^BUDDTSSC("AC",Y,TIEN)) S BUDNUT="CPT: "_Y Q

 .;V TRANS

 .S X=0 F  S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X  D

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

 ..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)

 ..Q:Y=""

 ..I $D(^BUDDTSSC("AC",Y,TIEN)) S BUDNUT="CPT/TRAN: "_Y Q

 .;SNOMED

 .S X=0 F  S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X  D

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

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

 ..Q:Y=""

 ..I $D(^BUDDTSSC("AS",Y,TIEN)) S BUDNUT="SNOMED: "_Y Q

 I BUDNUT]"" Q BUDNUT

 ;CHECK PROBLEM LIST FOR SNOMED

 S X=$$PLCL^BUDDDU(P,"T6B ADOLWT NUTRITION CODES",EDATE,0,BDATE) I X Q "PROBLEM SNOMED "_$P(X,U,2)

 Q ""

PA(P,BDATE,EDATE) ;EP

 NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,S,T,BUDPA

 S BUDPA=""

 D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")

 S TIEN=$O(^BUDDTSSC("B","T6B ADOLWT PHYSICAL ACT CODES",0))

 S CTR=0 F  S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR  D

 .S VIEN=$P(BUDVS(CTR),U,5)

 .S VDATE=$P(BUDVS(CTR),U,1)

 .S X=0 F  S X=$O(^AUPNVPED("AD",VIEN,X)) Q:X'=+X  D

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

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

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

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

 ..I $P(T,"-",2)="EX"!($P(T,"-",1)="Z1.89") S BUDPA=T Q

 ..I $P(T,"-",1)="97802"!($P(T,"-",1)="97803")!($P(T,"-",1)="97804") S BUDPA=T Q

 .;CPT

 .S X=0 F  S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X  D

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

 ..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)

 ..Q:Y=""

 ..I $D(^BUDDTSSC("AC",Y,TIEN)) S BUDPA="CPT: "_Y Q

 .;V TRANS

 .S X=0 F  S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X  D

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

 ..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)

 ..Q:Y=""

 ..I $D(^BUDDTSSC("AC",Y,TIEN)) S BUDPA="CPT/TRAN: "_Y Q

 .;SNOMED

 .S X=0 F  S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X  D

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

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

 ..Q:Y=""

 ..I $D(^BUDDTSSC("AS",Y,TIEN)) S BUDPA="SNOMED: "_Y Q

 ..S Y=$$VALI^XBDIQ1(9000010.07,X,.01) I $D(^BUDDTSSC("AD",Y,TIEN)) S BUDPA="DX "_Y Q

 I BUDPA]"" Q BUDPA

 ;CHECK PROBLEM LIST FOR SNOMED

 S X=$$PLCL^BUDDDU(P,"T6B ADOLWT PHYSICAL ACT CODES",EDATE,0,BDATE) I X Q "PROBLEM SNOMED "_$P(X,U,2)

 Q ""

ADULT ;EP

 NEW BUDDOB,BUDX18RB,BUDX18TH,BUDBMI,BUDOW,BUDUW,BUDPLAN,BUDBMIV,BUDBMID

 S BUDDOB=$P(^DPT(DFN,0),U,3)

 S BUDX18RB=($E(BUDBD,1,3)-18)_"1231"

 Q:BUDDOB>BUDX18RB

 Q:BUDMEDV<1

 S BUDX18TH=$E(BUDDOB,1,3)+18_$E(BUDDOB,4,7)

 I '$$VBBD(DFN,BUDX18TH,BUDED) Q  ;quit if no visiT AFTER 18TH BIRTHDAY

 Q:$$PREG^BUDDRP6B(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED,BUDBD)

 ;REFUSAL, ETC.

 ;PALLIATIVE CARE

 Q:$$PALL(DFN,BUDBD,BUDED)  ;HAD PALLIATIVE CARE

 Q:$$REF(DFN,BUDBD,BUDED)  ;HAD A REFUSAL

 S D=$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),-182)

 ;I D<BUDBD S D=BUDBD

 S BUDBMI=$$ADULTBMI(DFN,D,$$VD^APCLV(BUDLASTV),BUDAGE)

 S BUDBMIV=$P(BUDBMI,U,1)

 S BUDBMID=$P(BUDBMI,U,2)

 S BUDOW="",BUDUW="",BUDPLAN=""

 ;I BUDBMI="" S BUDPLAN=$$PLAN(DFN,BUDBD,BUDED) I BUDPLAN]"" S G=0 S ^XTMP("BUDDRP6B",BUDJ,BUDH,"AWS2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDBMI_U_$S(BUDOW]"":"OVERWEIGHT",BUDUW]"":"UNDERWEIGHT",1:"")_U_BUDPLAN Q  ;NO BMI

 I BUDBMI="" S Y=$$CPTI^BUDDDU(P,BUDBD,BUDED,$P($$CPT^ICPTCOD("3008F"),U,1)) I Y S BUDBMI="CPT: 3008F" S G=0 G D

 I BUDBMI="" S G=0 G D

 I BUDAGE<65 D  G N

 .I BUDBMI>25 S BUDOW="OW"

 .I BUDBMI<18.5 S BUDUW="UW"

 I BUDBMI'<30 S BUDOW="OW"

 I BUDBMI<23 S BUDUW="UW"

 ;put the rest in demoninator

N I BUDOW="",BUDUW="" S BUDSECTF("PLAN")=$G(BUDSECTF("PLAN"))+1 S G=1 G D  ;not over/underweight & HAD BMI PUT IN NUM/DEN

 S BUDPLAN=$$PLAN(DFN,$$FMADD^XLFDT(BUDBMID,-182),BUDBMID)

 S G=0

 I BUDPLAN]"" S G=1,BUDSECTF("PLAN")=$G(BUDSECTF("PLAN"))+1

D ;put the rest in demoninator

 S BUDSECTF("PTS")=$G(BUDSECTF("PTS"))+1 D

 .I $G(BUDAWS2L) D

 ..I 'G S ^XTMP("BUDDRP6B",BUDJ,BUDH,"AWS2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$S($P(BUDBMIV,U,1)]"":$J($P(BUDBMIV,U,1),6,2),1:"")_" "_$$DATE^BUDDUTL1(BUDBMID)_U_$S(BUDOW]"":"OVERWEIGHT",BUDUW]"":"UNDERWEIGHT",1:"")_U_BUDPLAN

 .I $G(BUDAWS1L) D

 ..I G S ^XTMP("BUDDRP6B",BUDJ,BUDH,"AWS1",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$S($P(BUDBMIV,U,1)]"":$J($P(BUDBMIV,U,1),6,2),1:"")_" "_$$DATE^BUDDUTL1(BUDBMID)_U_$S(BUDOW]"":"OVERWEIGHT",BUDUW]"":"UNDERWEIGHT",1:"")_U_BUDPLAN

 Q

 ;

PLAN(P,BDATE,EDATE) ;

 NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,S,T,BUDPL,C

 S BUDPL=""

 D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")

 S TIEN=$O(^BUDDTSSC("B","T6B ADULTWT PLAN CODES",0))

 S CTR=0 F  S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR  D

 .S VIEN=$P(BUDVS(CTR),U,5)

 .S VDATE=$P(BUDVS(CTR),U,1)

 .S C=$$CLINIC^APCLV(VIEN,"C") I C]"",$D(^BUDDTSSC(TIEN,17,"B",C)) S BUDPL="Clinic "_C_U_VDATE Q

 .S X=0 F  S X=$O(^AUPNVPED("AD",VIEN,X)) Q:X'=+X!(BUDPL]"")  D

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

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

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

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

 ..I $P(T,"-",2)="EX"!($P(T,"-",2)="LA")!($P(T,"-",2)="N")!($P(T,"-",2)="DT")!($P(T,"-",2)="MNT") S BUDPL=T_U_VDATE Q

 ..I $P(T,"-",1)="OBS"!($P(T,"-",1)="V65.3")!($P(T,"-",1)="V65.41")!($P(T,"-",1)="278.00")!($P(T,"-",1)="278.01")!($P(T,"-",1)="Z71.3") S BUDPL=T_U_VDATE Q

 .;CPT

 .S X=0 F  S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X!(BUDPL]"")  D

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

 ..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)

 ..Q:Y=""

 ..I $D(^BUDDTSSC("AC",Y,TIEN)) S BUDPL="CPT: "_Y_U_VDATE Q

 .;V TRANS

 .S X=0 F  S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X!(BUDPL]"")  D

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

 ..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)

 ..Q:Y=""

 ..I $D(^BUDDTSSC("AC",Y,TIEN)) S BUDPL="CPT/TRAN: "_Y_U_VDATE Q

 .;SNOMED

 .S X=0 F  S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X!(BUDPL]"")  D

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

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

 ..I Y]"",$D(^BUDDTSSC("AS",Y,TIEN)) S BUDPL="SNOMED: "_Y_U_VDATE Q

 ..S Y=$$VALI^XBDIQ1(9000010.07,X,.01) I $D(^BUDDTSSC("AD",Y,TIEN)) S BUDPL="DX "_$$VAL^XBDIQ1(9000010.07,X,.01)_U_VDATE Q

 .;PROVIDER CODES

 .S X=0 F  S X=$O(^AUPNVPRV("AD",VIEN,X)) Q:X'=+X!(BUDPL]"")  D

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

 ..S Y=$$VALI^XBDIQ1(9000010.06,X,.01)

 ..Q:Y=""

 ..S Y=$$PROVCLSC^XBFUNC1(Y)

 ..Q:Y=""

 ..I $D(^BUDDTSSC(16,"B",Y)) S BUDPL="Prv: "_Y_U_VDATE Q

 I BUDPL]"" Q BUDPL

 ;CHECK PROBLEM LIST FOR SNOMED

 S X=$$PLCL^BUDDDU(P,"T6B ADULTWT PLAN CODES",EDATE,0,BDATE) I X Q "PROBLEM SNOMED "_$P(X,U,2)

 Q ""

PALL(P,BDATE,EDATE) ;

 NEW D,BUDG,E,%

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

 NEW X,Y,G,T,V,Z,A

 S T=$O(^BUDDTSSC("B","T6B ADULTWT PALLIATIVE CARE",0))

 S G=""

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

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

 .S Z=$P($G(^AUPNVPOV(Y,0)),U,1)

 .I $D(^BUDDTSSC("AD",Z,T)) S G=1 Q

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

 .Q:Y=""

 .I $D(^BUDDTSSC("AS",Y,T)) S G=1

 I G Q G

 S X=$$PLCL^BUDDDU(P,"T6B ADULTWT PALLIATIVE CARE",EDATE,0,BDATE) I X Q 1  ;"PROBLEM SNOMED "_$P(X,U,2)

 Q G

G ;EP

 G G^BUDDRP6R

BUDDRP6V  ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;

 +1       ;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66

 +2       ;

 +3       ;

ADOLWT    ;EP - called from xbdbque

 +1       ;must have DOB between 1/1/06 and 12/31/06

 +2        NEW BUDBMI,BUDDOB,BUD17RB,BUD3RB,BUD18BD,X,G

 +3        SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)

 +4       ;RERPORT PERIOD 17 BD

           SET BUD17RB=($EXTRACT(BUDBD,1,3)-17)_"0101"

 +5       ;REPORT PERIOD 3 BD

           SET BUD3RB=($EXTRACT(BUDED,1,3)-3)_"1231"

 +6        IF BUDDOB>BUD3RB

               QUIT 

 +7        IF BUDDOB<BUD17RB

               QUIT 

 +8       ;AT LEAST 1 MEDICAL VISIT

           IF BUDMEDV<1

               QUIT 

 +9        SET BUD18BD=$EXTRACT(BUDDOB,1,3)+18_$EXTRACT(BUDDOB,4,7)

 +10      ;SEEN AT LEAST ONCE BEFORE 18TH DOB

           IF '$$VBBD(DFN,BUDDOB,$$FMADD^XLFDT(BUD18BD,-1))

               QUIT 

 +11       IF $$PREG^BUDDRP6B(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED,BUDBD)

               QUIT 

 +12       SET BUDBMI=$$BMINPA(DFN,BUDBD,BUDED,BUDAGE)

 +13       SET G=0

           FOR X=1:1:3

               IF $PIECE(BUDBMI,U,X)]""

                   SET G=G+1

 +14       IF G=3

               SET BUDSECTE("AWT")=$GET(BUDSECTE("AWT"))+1

 +15      ;put the rest in demoninator

 +16       SET BUDSECTE("PTS")=$GET(BUDSECTE("PTS"))+1

           Begin DoDot:1

 +17           IF $GET(BUDWAC2L)

                   Begin DoDot:2

 +18                   IF G'=3

                           SET ^XTMP("BUDDRP6B",BUDJ,BUDH,"WAC2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDBMI

                   End DoDot:2

 +19           IF $GET(BUDWAC1L)

                   Begin DoDot:2

 +20                   IF G=3

                           SET ^XTMP("BUDDRP6B",BUDJ,BUDH,"WAC1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDBMI

                   End DoDot:2

           End DoDot:1

 +21       QUIT 

 +22      ;

 +23      ;

VBBD(P,BDATE,EDATE) ;EP

 +1        NEW BUDVL,G,V,A,L

 +2        KILL BUDVL

 +3        SET G=""

 +4        SET A="BUDVL("

           SET B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)

           SET E=$$START1^APCLDF(B,A)

 +5        IF '$DATA(BUDVL)

               QUIT ""

 +6        SET X=0

           FOR 

               SET X=$ORDER(BUDVL(X))

               IF X'=+X

                   QUIT 

               SET V=$PIECE(BUDVL(X),U,5)

               Begin DoDot:1

 +7                IF '$DATA(^AUPNVSIT(V,0))

                       QUIT 

 +8                IF '$PIECE(^AUPNVSIT(V,0),U,9)

                       QUIT 

 +9                IF $PIECE(^AUPNVSIT(V,0),U,11)

                       QUIT 

 +10               IF '$DATA(^AUPNVPRV("AD",V))

                       QUIT 

 +11               IF '$DATA(^AUPNVPOV("AD",V))

                       QUIT 

 +12               SET L=$PIECE(^AUPNVSIT(V,0),U,6)

 +13               IF L=""

                       QUIT 

 +14      ;not valid location

                   IF '$DATA(^BUDDSITE(BUDSITE,11,L))

                       QUIT 

 +15               IF $PIECE(^AUPNVSIT(V,0),U,7)="C"

                       QUIT 

 +16               IF $PIECE(^AUPNVSIT(V,0),U,7)="T"

                       QUIT 

 +17               IF $PIECE(^AUPNVSIT(V,0),U,7)="N"

                       QUIT 

 +18               IF $PIECE(^AUPNVSIT(V,0),U,7)="D"

                       QUIT 

 +19               IF $PIECE(^AUPNVSIT(V,0),U,7)="X"

                       QUIT 

 +20               IF $PIECE(^AUPNVSIT(V,0),U,7)="E"

                       QUIT 

 +21               SET G=V

 +22               QUIT 

               End DoDot:1

 +23       QUIT G

 +24      ;

BMINPA(P,BDATE,EDATE,AGE) ;EP

 +1        NEW %,W,H,B,D,%DT,RETVAL,BUDBMI,BUDNE,BUDPA

 +2       ;get percentile

           SET BUDBMI=$$LASTITEM^APCLAPIU(P,"BMIP","MEASUREMENT",BDATE,EDATE,"A")

           IF BUDBMI]""

               SET BUDBMI=$PIECE(BUDBMI,U,3)_" %ile meas"

 +3        IF BUDBMI=""

               SET BUDBMI=$$LASTITEM^APCLAPIU(P,"BMI","MEASUREMENT",BDATE,EDATE,"A")

               IF BUDBMI]""

                   SET BUDBMI=$PIECE(BUDBMI,U,3)_" BMI meas"

 +4        IF BUDBMI=""

               SET BUDBMI=$$BMI(P,BDATE,EDATE,AGE)

               IF BUDBMI]""

                   SET BUDBMI=BUDBMI_" BMI"

 +5        IF BUDBMI=""

               SET BUDBMI=$$BMIPROC(P,BDATE,EDATE)

 +6       ;I BUDBMI="" I $$REF(P,$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),-(6*30.5)),$$VD^APCLV(BUDLASTV)) Q "REF"

 +7        SET BUDNE=$$NUTR(P,BDATE,EDATE)