BUDHRP6V.m

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

 ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90

 ;

 ;

ADOLWT ;EP - called from xbdbque

 ;

 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)-4)_"1231"   ;REPORT PERIOD 3 BD

 Q:BUDDOB>BUD3RB

 Q:BUDDOB<BUD17RB

 Q:BUDMEDV<1

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

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

 Q:$$HOSPIND^BUDHRP6C(DFN,BUDBD,BUDED)  ;new v18, hospice

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

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

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

 I G=5 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'=5 S ^XTMP("BUDHRP6B",BUDJ,BUDH,"WAC2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDBMI

 .I $G(BUDWAC1L) D

 ..I G=5 S ^XTMP("BUDHRP6B",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(^BUDHSITE(BUDSITE,11,L))

 .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,BUDHT,BUDWT,BUDVAL

 S BUDVAL=""

 S BUDHT=$$LASTITEM^APCLAPIU(P,"HT","MEASUREMENT",BDATE,EDATE,"A") I BUDHT]"" S BUDHT="HT: "_$P(BUDHT,U,3)

 S BUDWT=$$LASTITEM^APCLAPIU(P,"WT","MEASUREMENT",BDATE,EDATE,"A") I BUDWT]"" S BUDWT="WT: "_$P(BUDWT,U,3)

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

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

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

 Q BUDHT_U_BUDWT_U_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(^BUDHTSSC("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(^BUDHTSSC("AD",Y,T)) S G="POV "_$P(BUDG(X),U,2)

 Q G

REF(P,BDATE,EDATE) ;EP

 NEW F,G,I,ID,C,X,D,H,W,R,T

 S G=0

 S T=$O(^BUDHTSSC("B","T6B ADULTWT REFUSAL",0))

 S F=9999999.07,I=$O(^AUTTMSR("B","BMI",0))

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

 .S D=9999999-$P(ID,".") ;ID

 .Q:D'=BDATE

 .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(T,13,"B",R)) S G=1 Q

 ..S R=$$VALI^XBDIQ1(9000022,X,.07)

 ..I R="R"!(R="N")!(R="U") S G=1 Q

 I G Q G

 ;now check for WT or HT

 S (W,H)=""

 S F=9999999.07,I=$O(^AUTTMSR("B","WT",0))

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

 .S D=9999999-$P(ID,".") ;ID

 .Q:D'=BDATE

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

 ..S R=$$VALI^XBDIQ1(9000022,X,.07)

 ..I R="R"!(R="N")!(R="U") S W=1

 I W Q 1

 S F=9999999.07,I=$O(^AUTTMSR("B","HT",0))

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

 .S D=9999999-$P(ID,".") ;ID

 .Q:D'=BDATE

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

 ..S R=$$VALI^XBDIQ1(9000022,X,.07)

 ..I R="R"!(R="N")!(R="U") S H=1

 I H Q 1

 S H=$$MRND(P,BDATE,EDATE)

 Q H

MRND(P,BDATE,EDATE) ;EP

 NEW F,G,I,ID,C,X,D,H,W,R,TNDM,TAN,TBN

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

 S TAN=$O(^BUDHTSSC("B","T6B ADULTWT ABOVE NORM",0))

 S TBN=$O(^BUDHTSSC("B","T6B ADULTWT BELOW NORM",0))

 S G=0

 S F=81,I=""

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

 .I '$$ICD^ATXCHK(I,$O(^ATXAX("B","BGP IPC ABOVE NORMAL FU CPTS",0)),1),'$$ICD^ATXCHK(I,$O(^ATXAX("B","BGP IPC BELOW NORMAL FU CPTS",0)),1) Q

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

 ..S D=9999999-$P(ID,".") ;ID

 ..Q:D<BDATE

 ..Q:D>EDATE

 ..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(TNDM,13,"B",R)) S G=1 Q

 ...S R=$$VALI^XBDIQ1(9000022,X,.07)

 ...I R="N"!(R="U") S G=1

 I G Q G

 S F=9002318.4,I=""

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

 .I '$D(^BUDHTSSC(TAN,13,"B",I)),'$D(^BUDHTSSC(TBN,13,"B",I)) Q

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

 ..S D=9999999-$P(ID,".") ;ID

 ..Q:D<BDATE

 ..Q:D>EDATE

 ..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(TNDM,13,"B",R)) S G=1 Q

 ...S R=$$VALI^XBDIQ1(9000022,X,.07)

 ...I R="N"!(R="U") S G=1

 I G Q G

 ;MEDS

 S F=50,I=""

 NEW T,T1

 S T=$O(^ATXAX("B","BGP IPC BELOW NORMAL MEDS",0))

 S T1=$O(^ATXAX("B","BGP IPC ABOVE NORMAL MEDS",0))

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

 .I '$D(^ATXAX(T,21,"B",I)),'$D(^ATXAX(T,21,"B",I)) Q

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

 ..S D=9999999-$P(ID,".") ;ID

 ..Q:D<BDATE

 ..Q:D>EDATE

 ..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(TDNM,"B",13,R)) S G=1 Q

 I G Q G

 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(^BUDHTSSC("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_" "_$$DATE^BUDHUTL1(VDATE) Q

 ..I $P(T,"-",1)="97802"!($P(T,"-",1)="97803")!($P(T,"-",1)="97804") S BUDNUT=T_" "_$$DATE^BUDHUTL1(VDATE) Q

 ..S S=$P(T,"-",1) I S]"",$D(^BUDHTSSC("AS",S,TIEN)) S BUDNUT=T_" "_$$DATE^BUDHUTL1(VDATE) 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(^BUDHTSSC("AC",Y,TIEN)) S BUDNUT="CPT: "_Y_" "_$$DATE^BUDHUTL1(VDATE) 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(^BUDHTSSC("AC",Y,TIEN)) S BUDNUT="CPT/TRAN: "_Y_" "_$$DATE^BUDHUTL1(VDATE) 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(^BUDHTSSC("AS",Y,TIEN)) S BUDNUT="SNOMED: "_Y_" "_$$DATE^BUDHUTL1(VDATE) Q

 I BUDNUT]"" Q BUDNUT

 ;CHECK PROBLEM LIST FOR SNOMED

 S X=$$PLCL^BUDHDU(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(^BUDHTSSC("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" S BUDPA=T_" "_$$DATE^BUDHUTL1(VDATE) Q

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

 ..I S]"",$D(^BUDHTSSC("AS",S,TIEN)) S BUDPA=T_" "_$$DATE^BUDHUTL1(VDATE) 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(^BUDHTSSC("AC",Y,TIEN)) S BUDPA="CPT: "_Y_" "_$$DATE^BUDHUTL1(VDATE) 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(^BUDHTSSC("AC",Y,TIEN)) S BUDPA="CPT/TRAN: "_Y_" "_$$DATE^BUDHUTL1(VDATE) 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 Y]"",$D(^BUDHTSSC("AS",Y,TIEN)) S BUDPA="SNOMED: "_Y_" "_$$DATE^BUDHUTL1(VDATE) Q

 ..S Y=$$VALI^XBDIQ1(9000010.07,X,.01) I $D(^BUDHTSSC("AD",Y,TIEN)) S BUDPA="DX "_Y_" "_$$DATE^BUDHUTL1(VDATE) Q

 I BUDPA]"" Q BUDPA

 ;CHECK PROBLEM LIST FOR SNOMED

 S X=$$PLCL^BUDHDU(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^BUDHRP6B(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED,BUDBD)

 ;REFUSAL, ETC.

 ;PALLIATIVE CARE

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

 Q:$$PALL(DFN,D,$$VD^APCLV(BUDLASTV))  ;HAD PALLIATIVE CARE

 Q:$$REF(DFN,D,$$VD^APCLV(BUDLASTV))  ;HAD A REFUSAL

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

 ;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("BUDHRP6B",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^BUDHDU(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 BUDBMI>25 S BUDOW="OW"

 I +BUDBMI=25 S BUDOW="OW"

 I BUDBMI<18.5 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 D=$$VD^APCLV(BUDLASTV)

 I BUDOW]"" S BUDPLAN=$$ANFU^BUDHUTL3(DFN,$$FMADD^XLFDT(D,-394),D)

 I BUDUW]"" S BUDPLAN=$$BLFU^BUDHUTL3(DFN,$$FMADD^XLFDT(D,-394),D)

 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("BUDHRP6B",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^BUDHUTL1(BUDBMID)_U_$S(BUDOW]"":"OVERWEIGHT",BUDUW]"":"UNDERWEIGHT",1:"")_U_BUDPLAN

 .I $G(BUDAWS1L) D

 ..I G S ^XTMP("BUDHRP6B",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^BUDHUTL1(BUDBMID)_U_$S(BUDOW]"":"OVERWEIGHT",BUDUW]"":"UNDERWEIGHT",1:"")_U_BUDPLAN

 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(^BUDHTSSC("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(^BUDHTSSC("AD",Z,T)) S G=1 Q

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

 .Q:Y=""

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

 I G Q G

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

 Q G

G ;EP

 G G^BUDHRP6R

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

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

 +2       ;

 +3       ;

ADOLWT    ;EP - called from xbdbque

 +1       ;

 +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)-4)_"1231"

 +6        IF BUDDOB>BUD3RB

               QUIT 

 +7        IF BUDDOB<BUD17RB

               QUIT 

 +8        IF BUDMEDV<1

               QUIT 

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

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

               QUIT 

 +11      ;new v18, hospice

           IF $$HOSPIND^BUDHRP6C(DFN,BUDBD,BUDED)

               QUIT 

 +12       IF $$PREG^BUDHRP6B(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED,BUDBD)

               QUIT 

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

 +14       SET G=0

           FOR X=1:1:5

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

                   SET G=G+1

 +15       IF G=5

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

 +16      ;put the rest in demoninator

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

           Begin DoDot:1

 +18           IF $GET(BUDWAC2L)

                   Begin DoDot:2

 +19                   IF G'=5

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

                   End DoDot:2

 +20           IF $GET(BUDWAC1L)

                   Begin DoDot:2

 +21                   IF G=5

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

                   End DoDot:2

           End DoDot:1

 +22       QUIT 

 +23      ;

 +24      ;

VBBD(P,BDATE,EDATE) ;EP

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