BUDDRPTC ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
;
;
PROC ;EP - called from xbdbque
D PROC^BUDDRPTE ;set up variables
S DFN=0 F S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN D
.K ^TMP($J)
.Q:'$D(^AUPNPAT(DFN,0))
.Q:'$D(^DPT(DFN,0))
.Q:$P(^DPT(DFN,0),U,19)
.I $P(^DPT(DFN,0),U,2)'="F",$P(^DPT(DFN,0),U,2)'="M" Q
.Q:$$DEMO^BUDDDU(DFN,"E")
.;
.I BUDBEN=1,$$BEN^AUPNPAT(DFN,"C")'="01" Q
.I BUDBEN=2,$$BEN^AUPNPAT(DFN,"C")="01" Q
.S BUDAGE=$$AGE^AUPNPAT(DFN,BUDCCAD)
.S BUDSEX=$P(^DPT(DFN,0),U,2)
.S BUDCCOM=$$COMMRES^AUPNPAT(DFN,"E") I BUDCCOM="" S BUDCCOM="UNKNOWN"
.D GETV^BUDDRPTD
.I BUDUDSPT=0 Q ;NOT ON ANY TABLE
.I $G(BUDTZ) D TZ
.I $G(BUDT3A) D T3A
.I $G(BUDT3B) D T3B
.I $G(BUDT4) D T4^BUDDRPC2
.I $G(BUDT5) D T5
.I $G(BUDT6) D T6
.I $G(BUDT6B) D T6B
.I $G(BUDT7) D T7
.I $G(BUDT9) D T9^BUDDRPC4
.I $G(BUDT9D) D T9D^BUDDRPC3
.Q
Q
T3A ;
S G=0,Y=0 F S Y=$O(^BUDDTTA("AC",Y)) Q:'Y!(G) S X=$O(^BUDDTTA("AC",Y,0)) D
.S L=$P(^BUDDTTA(X,0),U,7),H=$P(^BUDDTTA(X,0),U,8),P=$P(^BUDDTTA(X,0),U,2)
.I BUDAGE<0 S P=1 S $P(BUDTOT(BUDSEX),U,P)=$P(BUDTOT(BUDSEX),U,P)+1,$P(BUDTOT("ALL"),U,P)=$P(BUDTOT("ALL"),U,P)+1 D T S G=1 Q
.I BUDAGE'<L,BUDAGE'>H S $P(BUDTOT(BUDSEX),U,P)=$P(BUDTOT(BUDSEX),U,P)+1,$P(BUDTOT("ALL"),U,P)=$P(BUDTOT("ALL"),U,P)+1 D T S G=1
.Q
I $G(BUDT3AL) S X=0 F S X=$O(^TMP($J,"VISITSUDSPT",X)) Q:X'=+X S ^XTMP("BUDDRPT1",BUDJ,BUDH,"3A",BUDAGE,BUDSEX,BUDCCOM,DFN,X)=""
I $G(BUDSTMP) S ^XTMP("BUDDRPT1",BUDJ,BUDH,"3ATEMP",DFN)=""
Q
T ;
S $P(BUDTOT(BUDSEX),U,39)=$P(BUDTOT(BUDSEX),U,39)+1,$P(BUDTOT("ALL"),U,39)=$P(BUDTOT("ALL"),U,39)+1
I BUDAGE<18 S BUD019(BUDSEX)=BUD019(BUDSEX)+1,BUD019("ALL")=BUD019("ALL")+1
Q
TZ ;
S BUDR=$$ZIP(DFN)
I BUDR="" S BUDR="Unknown Residence"
S BUDINS=$$ZIPINS^BUDDRPC3(DFN,BUDLASTV)
I BUDINS="" S BUDINS="b"
S ^XTMP("BUDDRPT1",BUDJ,BUDH,"ZIP",BUDR)=$G(^XTMP("BUDDRPT1",BUDJ,BUDH,"ZIP",BUDR))+1 ;column a
S ^XTMP("BUDDRPT1",BUDJ,BUDH,"ZIP",BUDR,BUDINS)=$G(^XTMP("BUDDRPT1",BUDJ,BUDH,"ZIP",BUDR,BUDINS))+1
S ^XTMP("BUDDRPT1",BUDJ,BUDH,"ZIP",BUDR,"f")=$G(^XTMP("BUDDRPT1",BUDJ,BUDH,"ZIP",BUDR,"f"))+1 ;column f
I $G(BUDTZL) S X=0 F S X=$O(^TMP($J,"VISITSUDSPT",X)) Q:X'=+X S ^XTMP("BUDDRPT1",BUDJ,BUDH,"Z",BUDR,BUDINS,BUDCCOM,BUDSEX,$P(^DPT(DFN,0),U),DFN,X)=""
Q
T3B ;
S BUDHISPN=$$HISP(DFN)
S BUDHISP=$P($$HISP(DFN),U,1) ;column
S BUDHISP1=BUDHISP+2 ;set piece
;
S BUDR1=$$RACE(DFN)
S BUDR=$P(BUDR1,U,1) ;LINE
S $P(BUDRACET(BUDR),U,BUDHISP1)=$P(BUDRACET(BUDR),U,BUDHISP1)+1 ;HISPANIC COLUMN FOR RACE
S $P(BUDRACET(BUDR),U,6)=$P(BUDRACET(BUDR),U,6)+1 ;TOTAL COLUMN FOR RACE
I BUDR="2A"!(BUDR="2B") S $P(BUDRACET(2),U,BUDHISP1)=$P(BUDRACET(2),U,BUDHISP1)+1,$P(BUDRACET(2),U,6)=$P(BUDRACET(2),U,6)+1 ;total line 2
S $P(BUDRACET(8),U,BUDHISP1)=$P(BUDRACET(8),U,BUDHISP1)+1,$P(BUDRACET(8),U,6)=$P(BUDRACET(8),U,6)+1
I $P(BUDR1,U,5)=16 S $P(BUDR1,U,5)=8
S BUDXX=$$LOTE^BUDDRPTD(DFN,BUDLASTV) I BUDXX S $P(BUDLANG(12),U,2)=$P(BUDLANG(12),U,2)+1
I $G(BUDT3BRL) S X=0 F S X=$O(^TMP($J,"VISITSUDSPT",X)) Q:X'=+X S ^XTMP("BUDDRPT1",BUDJ,BUDH,"3BR",$P(BUDR1,U,5),$P(BUDHISPN,U,1),BUDAGE,BUDSEX,BUDCCOM,DFN,X)=BUDR1_"|||"_BUDHISPN_"|||"_BUDXX
D SEXOR^BUDDRPTE
D GENDIDEN^BUDDRPTE
Q
T5 ;tally prim provider
S BUDV=0 F S BUDV=$O(^TMP($J,"VISITSTABLE5",BUDV)) Q:BUDV'=+BUDV D
.S BUDP=$$PRIMPROV^APCLV(BUDV,"D")
.I BUDP="" Q
.;special case for DX of MH
.;special case for provider code 15 and location CHS*
.I $E($$VAL^XBDIQ1(9000010,BUDV,.06),1,3)="CHS",BUDP=15 S BUDT5LN=2 D T5SET Q
.S BUDY=$O(^BUDDTFIV("C",BUDP,0)) I BUDY="" S BUDT5LN=35 D T5SET Q
.;next lines for Bh stuff based on dx
.S T=$O(^BUDDCNTL("B","BH DISCIPLINES FOR 20 AND 21",0))
.I $D(^BUDDCNTL(T,11,"B",BUDP)) D D T5SET Q
..S P=$$PRIMPOV^APCLV(BUDV,"I")
..I P,$D(^BUDDTSSC("AD",P,$O(^BUDDTSSC("B","T5 BH CODES L20A",0)))) S BUDT5LN="21" Q
..S BUDT5LN=$P(^BUDDCNTL(T,11,$O(^BUDDCNTL(T,11,"B",BUDP,0)),0),U,2) Q
.S BUDT5LN=$P(^BUDDTFIV(BUDY,0),U)
.D T5SET
.Q
Q
T5SET ;
I BUDT5LN>0,BUDT5LN<8 D T5PHY
I +BUDT5LN>8,+BUDT5LN<11 D T5MID
I +BUDT5LN>10,BUDT5LN<15 D T5NUR
I BUDT5LN>15,+BUDT5LN<19 D T5DENT
I +BUDT5LN=20 D T520
I BUDT5LN=21 D T521
I $L(BUDT5LN)=3,$E(BUDT5LN,1,2)=22 D T5VISION
I BUDT5LN=22 D T522
I BUDT5LN=23 D T523
I BUDT5LN>23,BUDT5LN<29 D T5ENA
I BUDT5LN="29A" D T529A
I BUDT5LN["30" D T530A
I +BUDT5LN>29,BUDT5LN<33 D T5ADM
I BUDT5LN=35 D T5OTH
I $G(BUDT5L)!($G(BUDT5L2)) D
.Q:BUDT5LN=12
.Q:BUDT5LN=13
.Q:BUDT5LN=14
.Q:BUDT5LN=18
.Q:BUDT5LN="22C"
.Q:BUDT5LN=23
.Q:BUDT5LN=26
.Q:BUDT5LN="30A"
.Q:BUDT5LN=32
.Q:BUDT5LN=27
.Q:BUDT5LN="27a"
.Q:BUDT5LN="27b"
.Q:BUDT5LN="27c"
.Q:BUDT5LN=28
.Q:BUDT5LN="29A"
.Q:BUDT5LN="29b"
.Q:BUDT5LN="30B"
.Q:BUDT5LN="30C"
.Q:BUDT5LN=31
.S ^XTMP("BUDDRPT1",BUDJ,BUDH,"T5",+BUDT5LN,$S(BUDT5LN="20A1":"A1",BUDT5LN="20A2":"A2",+BUDT5LN=BUDT5LN:0,1:$E(BUDT5LN,$L(BUDT5LN))),BUDCCOM,BUDAGE,BUDSEX,DFN,BUDV)=$$PRIMPROV^APCLV(BUDV,"N")_"^"_$$PRIMPROV^APCLV(BUDV,"P")
I $G(BUDT5L1) S ^XTMP("BUDDRPT1",BUDJ,BUDH,"T51",+BUDT5LN,$S(BUDT5LN="20A1":"A1",BUDT5LN="20A2":"A2",+BUDT5LN=BUDT5LN:0,1:$E(BUDT5LN,$L(BUDT5LN))),$$PRIMPROV^APCLV(BUDV,"N"))=$$PRIMPROV^APCLV(BUDV,"D")_" "_$$PRIMPROV^APCLV(BUDV,"E")
Q
T5PHY ;set
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1
S $P(BUDTAB5(8),U)=$P(BUDTAB5(8),U)+1
S $P(BUDTAB5(15),U)=$P(BUDTAB5(15),U)+1
I $G(BUDT5L3) D
.I $D(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MED SERV",$$VD^APCLV(BUDV))) D I 1
..S ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MED SERV",$$VD^APCLV(BUDV))=^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MED SERV",$$VD^APCLV(BUDV))_U_BUDV
.E S ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MED SERV",$$VD^APCLV(BUDV))=BUDV
I $D(^TMP($J,"PATIENTS","MED SERV",DFN)) Q
S ^TMP($J,"PATIENTS","MED SERV",DFN)="",$P(BUDTAB5(15),U,2)=$P(BUDTAB5(15),U,2)+1
Q
T5MID ;
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1 ;total visits for this line
S $P(BUDTAB5("10A"),U)=$P(BUDTAB5("10A"),U)+1 ;total MID encs line
S $P(BUDTAB5(15),U)=$P(BUDTAB5(15),U)+1 ;total med services line
I $D(^TMP($J,"PATIENTS","MED SERV",DFN)) Q
S ^TMP($J,"PATIENTS","MED SERV",DFN)="",$P(BUDTAB5(15),U,2)=$P(BUDTAB5(15),U,2)+1
Q
T5NUR ;
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1
I BUDT5LN=12 Q
I BUDT5LN=13 Q
I BUDT5LN=14 Q
S $P(BUDTAB5(15),U)=$P(BUDTAB5(15),U)+1
I $D(^TMP($J,"PATIENTS","MED SERV",DFN)) Q
S ^TMP($J,"PATIENTS","MED SERV",DFN)="",$P(BUDTAB5(15),U,2)=$P(BUDTAB5(15),U,2)+1
Q
T5DENT ;
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1
I BUDT5LN=18 Q
S $P(BUDTAB5(19),U)=$P(BUDTAB5(19),U)+1
I $G(BUDT5L3) D I 1
.I $D(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",$$VD^APCLV(BUDV))) D
..S ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",$$VD^APCLV(BUDV))=^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",$$VD^APCLV(BUDV))_U_BUDV
.E S ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",$$VD^APCLV(BUDV))=BUDV
I $D(^TMP($J,"PATIENTS","DENT SERV",DFN)) Q
S ^TMP($J,"PATIENTS","DENT SERV",DFN)="",$P(BUDTAB5(19),U,2)=$P(BUDTAB5(19),U,2)+1
Q
T520 ;
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1
S $P(BUDTAB5(20),U)=$P(BUDTAB5(20),U)+1
I $G(BUDT5L3) D I 1
.I $D(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",$$VD^APCLV(BUDV))) D
..S ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",$$VD^APCLV(BUDV))=^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",$$VD^APCLV(BUDV))_U_BUDV
.E S ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",$$VD^APCLV(BUDV))=BUDV
I $D(^TMP($J,"PATIENTS","20 SERV",DFN)) Q
S ^TMP($J,"PATIENTS","20 SERV",DFN)="",$P(BUDTAB5(20),U,2)=$P(BUDTAB5(20),U,2)+1
Q
T521 ;
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1
I $G(BUDT5L3) D I 1
.I $D(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",$$VD^APCLV(BUDV))) D
..S ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",$$VD^APCLV(BUDV))=^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",$$VD^APCLV(BUDV))_U_BUDV
.E S ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",$$VD^APCLV(BUDV))=BUDV
I $D(^TMP($J,"PATIENTS","21 SERV",DFN)) Q
S ^TMP($J,"PATIENTS","21 SERV",DFN)="",$P(BUDTAB5(21),U,2)=$P(BUDTAB5(21),U,2)+1
Q
T522 ;
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1
I $G(BUDT5L3) D I 1
.I $D(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDP,$$VD^APCLV(BUDV))) D
..S ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDP,$$VD^APCLV(BUDV))=^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDP,$$VD^APCLV(BUDV))_U_BUDV
.E S ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDP,$$VD^APCLV(BUDV))=BUDV
I $D(^TMP($J,"PATIENTS","22 SERV",DFN)) Q
S ^TMP($J,"PATIENTS","22 SERV",DFN)="",$P(BUDTAB5(22),U,2)=$P(BUDTAB5(22),U,2)+1
Q
T523 ;
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1
Q
T5VISION ;
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1
I BUDT5LN="22C" Q
S $P(BUDTAB5("22D"),U)=$P(BUDTAB5("22D"),U)+1 ;total vision line
I $G(BUDT5L3) D I 1
.I $D(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"VISION SERV",BUDP,$$VD^APCLV(BUDV))) D
..S ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"VISION SERV",BUDP,$$VD^APCLV(BUDV))=^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"VISION SERV",BUDP,$$VD^APCLV(BUDV))_U_BUDV
.E S ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"VISION SERV",BUDP,$$VD^APCLV(BUDV))=BUDV
I $D(^TMP($J,"PATIENTS","22D SERV",DFN)) Q
S ^TMP($J,"PATIENTS","22D SERV",DFN)="",$P(BUDTAB5("22D"),U,2)=$P(BUDTAB5("22D"),U,2)+1
Q
T5ENA ;
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1
I BUDT5LN=23 Q
I BUDT5LN=26 Q
I $E(BUDT5LN,1,2)=27 Q
I BUDT5LN=28 Q
I BUDT5LN=24!(BUDT5LN=25) S $P(BUDTAB5(29),U)=$P(BUDTAB5(29),U)+1 ;total enabling services line
I $G(BUDT5L3) D I 1
.I $D(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDT5LN,$$VD^APCLV(BUDV))) D
..S ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDT5LN,$$VD^APCLV(BUDV))=^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDT5LN,$$VD^APCLV(BUDV))_U_BUDV
.E S ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDT5LN,$$VD^APCLV(BUDV))=BUDV
I $D(^TMP($J,"PATIENTS","ENA SERV",DFN)) Q
S ^TMP($J,"PATIENTS","ENA SERV",DFN)="",$P(BUDTAB5(29),U,2)=$P(BUDTAB5(29),U,2)+1
Q
T529A ;
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1 ;total visits for this line
Q
T530A ;
Q ;all of line 3 grayed out
S $P(BUDTAB5(30),U)=$P(BUDTAB5(30),U)+1 ;total line 30
T5ADM ;
Q ;all of 31, 32, 33 is grayed out
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1 ;total visits for this line
S $P(BUDTAB5(33),U)=$P(BUDTAB5(33),U)+1
I $D(^TMP($J,"PATIENTS","ADM SERV",DFN)) Q
S ^TMP($J,"PATIENTS","ADM SERV",DFN)="",$P(BUDTAB5(33),U,2)=$P(BUDTAB5(33),U,2)+1
Q
T5OTH ;
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1
Q
;
T6 ;
D T6^BUDDRPC1
Q
;
HISP(DFN) ;EP
NEW X,Y,Z,V,A,C,R
S A="",X=""
I $G(DFN)="" Q ""
S Y=$$ETHN(DFN)
I Y="HISPANIC OR LATINO" Q 1_U_"E"_U_Y
I Y="NOT HISPANIC OR LATINO" Q 2_U_"E"_U_Y
S C=0,R="",A="",Z=""
S Y=0 F S Y=$O(^DPT(DFN,.02,Y)) Q:Y'=+Y D
.S C=C+1
.I X="" S X=$P(^DPT(DFN,.02,Y,0),U,1) ;
I C>1 Q 2_U_"R"_U_"MULT RACE"
I X S Z=$P(^DIC(10,X,0),U,2)
I Z=1 Q 1_U_"R"_U_$$RABB(Z)
I Z=2 Q 1_U_"R"_U_$$RABB(Z)
I Z="D"!(Z="U")!(Z=7) D Q A
.I Y]"" S A=3_U_"E"_U_Y Q
.S A=3_U_"R"_U_$$RABB(Z)
I Z]"" Q 2_"^R^"_$$RABB(Z)
I Y]"" Q 3_U_"E"_U_Y
HISPN ;
S X=$P(^DPT(DFN,0),U,6)
S Z=""
I X S Z=$P(^DIC(10,X,0),U,2)
I Z=1 Q 1_U_"R"_U_$$RABB(Z)
I Z=2 Q 1_U_"R"_U_$$RABB(Z)
I Z="D"!(Z="U")!(Z=7) D Q V
.I Y]"" S V=3_U_"E"_U_Y Q
.S V=3_U_"R"_U_$$RABB(Z)
I Z]"" Q 2_"^R^"_$$RABB(Z)
I Y]"" Q 3_U_"E"_U_Y
I $$BEN^AUPNPAT(DFN,"C")="01",Y="" Q 2_U_"C"_U_"AI/AN"
Q 3_"^E^BLANK RACE & ETHNICITY"
;
ETHN(P) ;EP
NEW Z,E
S E=""
S Z=0 F S Z=$O(^DPT(P,.06,Z)) Q:Z'=+Z!(E]"") D
.S E=$P($G(^DPT(P,.06,Z,0)),U,1)
.Q:E=""
.S E=$P($G(^DIC(10.2,E,0)),U,1)
.Q
Q E
RACE(DFN) ;EP
NEW X,Y,Z,C,A
I $G(DFN)="" Q ""
S C=0,R="",X="",A=""
S Y=0 F S Y=$O(^DPT(DFN,.02,Y)) Q:Y'=+Y D
.S C=C+1
.I X="" S X=$P(^DPT(DFN,.02,Y,0),U,1),Z=$P($G(^DIC(10,X,0)),U),X=$P($G(^DIC(10,X,0)),U,2)
I C>1 Q "6^MORE THAN ONE RACE^R"_U_"MORE THAN ONE RACE"_U_7
I X]"" S A=$$SETRC(X) Q A
S X=$P(^DPT(DFN,0),U,6)
I X="" G CL
I X S Z=$P(^DIC(10,X,0),U),X=$P($G(^DIC(10,X,0)),U,2)
I X="" G CL
Q $$SETRC(X)
CL I $$BEN^AUPNPAT(DFN,"C")="01" Q "4^AI/AN^C^AI/AN^5"
Q "7^UNREP/REF^C^BLANK RACE^8"
;
SETRC(X) ;
I X="A" Q "1^ASIAN^R"_U_Z_U_1
I X="H" Q "2A^NATIVE HAWAIIAN^R"_U_Z_U_2
I X=5 Q "2B^OTH PAC ISLANDER^R"_U_Z_U_3
I X=4!(X="B") Q "3^BLACK^R"_U_Z_U_4
I X=3!(X="Z")!(X="AIAN") Q "4^AI/AN^R"_U_Z_U_5
I X=6!(X="W") Q "5^WHITE^R"_U_Z_U_6
I X=1 Q "5^WHITE^R"_U_Z_U_6
I X="D" Q "7^UNREP/REF^R"_U_Z_U_8
I X="7" Q "7^UNREP/REF^R"_U_Z_U_8
I X="U" Q "7^UNREP/REF^R"_U_Z_U_8
I X=2 Q "3^BLACK^R"_U_Z_U_4
I X="O" Q "7^UNREP/REF^R"_U_Z_U_8
I Z="OTHER" Q "7^UNREP/REF^R"_U_Z_U_8
Q ""
ZIP(DFN) ;
I $G(DFN)="" Q ""
Q $E($P($G(^DPT(DFN,.11)),U,6),1,5)
;
RABB(X) ;
I X="A" Q "ASIAN"
I X="H" Q "NATIVE HAWAIIAN"
I X=5 Q "OTH PAC ISLANDER"
I X="B" Q "BLACK/AFRICAN"
I X=4 Q "BLACK NOT HISP"
I X=3!(X="Z")!(X="AIAN") Q "AI/AN"
I X="W" Q "WHITE"
I X=6 Q "WHITE NOT HISP"
I X=1 Q "HISPANIC, WHITE"
I X="D" Q "DECLINED"
I X="7" Q "UNKNOWN"
I X="U" Q "UNKNOWN BY PT"
I X=2 Q "HISPANIC, BLACK"
Q "??"
T6B ;
S BUDAGE=$$AGE^AUPNPAT(DFN,BUDED)
S BUDAGEP=$$AGE^AUPNPAT(DFN,BUDCCAD)
D IMM^BUDDRP6C
D PAPD^BUDDRP6D
D ADOLWT^BUDDRP6V
D ADULT^BUDDRP6V
D G^BUDDRP6V
D H^BUDDRP6U
D I^BUDDRP6O
D J^BUDDRP6M
D K^BUDDRP6N
D L^BUDDRP6Q
D M^BUDDRP6Q
D N^BUDDRP6A
S BUDAGE=$$AGE^AUPNPAT(DFN,BUDCCAD)
Q
T7 ;
S BUDAGE=$$AGE^AUPNPAT(DFN,BUDED)
S BUDAGEP=$$AGE^AUPNPAT(DFN,BUDCCAD)
D PRGHLST^BUDDRP7A
D PRGRLST^BUDDRP7A
D HTN^BUDDRP7B
D DM^BUDDRP7C
S BUDAGE=$$AGE^AUPNPAT(DFN,BUDCCAD)
Q
IWTO(P) ;
I $P(^DPT(DFN,0),U,1)["DEMO,PATIENT" Q 1
I $P(^DPT(DFN,0),U,1)["PATIENT,CRS" Q 1
I $P(^DPT(DFN,0),U,1)["PATIENT,UDS" Q 1
NEW X,T
S T=$O(^ATXAX("B","DEMO COMMUNITY TAXONOMY",0))
S X=$P($G(^AUPNPAT(P,11)),U,18) I X="" Q 0
I '$D(^ATXAX(T,21,"B",($P(^AUPNPAT(P,11),U,18)))),'$D(^ATXAX(T,21,"AA",$P(^AUPNPAT(P,11),U,18),$P(^AUPNPAT(P,11),U,18))) Q 0
Q 1
BUDDRPTC ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
+1 ;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
+2 ;
+3 ;
PROC ;EP - called from xbdbque
+1 ;set up variables
DO PROC^BUDDRPTE
+2 SET DFN=0
FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF DFN'=+DFN
QUIT
Begin DoDot:1
+3 KILL ^TMP($JOB)
+4 IF '$DATA(^AUPNPAT(DFN,0))
QUIT
+5 IF '$DATA(^DPT(DFN,0))
QUIT
+6 IF $PIECE(^DPT(DFN,0),U,19)
QUIT
+7 IF $PIECE(^DPT(DFN,0),U,2)'="F"
IF $PIECE(^DPT(DFN,0),U,2)'="M"
QUIT
+8 IF $$DEMO^BUDDDU(DFN,"E")
QUIT
+9 ;
+10 IF BUDBEN=1
IF $$BEN^AUPNPAT(DFN,"C")'="01"
QUIT
+11 IF BUDBEN=2
IF $$BEN^AUPNPAT(DFN,"C")="01"
QUIT
+12 SET BUDAGE=$$AGE^AUPNPAT(DFN,BUDCCAD)
+13 SET BUDSEX=$PIECE(^DPT(DFN,0),U,2)
+14 SET BUDCCOM=$$COMMRES^AUPNPAT(DFN,"E")
IF BUDCCOM=""
SET BUDCCOM="UNKNOWN"
+15 DO GETV^BUDDRPTD
+16 ;NOT ON ANY TABLE
IF BUDUDSPT=0
QUIT
+17 IF $GET(BUDTZ)
DO TZ
+18 IF $GET(BUDT3A)
DO T3A
+19 IF $GET(BUDT3B)
DO T3B
+20 IF $GET(BUDT4)
DO T4^BUDDRPC2
+21 IF $GET(BUDT5)
DO T5
+22 IF $GET(BUDT6)
DO T6
+23 IF $GET(BUDT6B)
DO T6B
+24 IF $GET(BUDT7)
DO T7
+25 IF $GET(BUDT9)
DO T9^BUDDRPC4
+26 IF $GET(BUDT9D)
DO T9D^BUDDRPC3
+27 QUIT
End DoDot:1
+28 QUIT
T3A ;
+1 SET G=0
SET Y=0
FOR
SET Y=$ORDER(^BUDDTTA("AC",Y))
IF 'Y!(G)
QUIT
SET X=$ORDER(^BUDDTTA("AC",Y,0))
Begin DoDot:1
+2 SET L=$PIECE(^BUDDTTA(X,0),U,7)
SET H=$PIECE(^BUDDTTA(X,0),U,8)
SET P=$PIECE(^BUDDTTA(X,0),U,2)
+3 IF BUDAGE<0
SET P=1
SET $PIECE(BUDTOT(BUDSEX),U,P)=$PIECE(BUDTOT(BUDSEX),U,P)+1
SET $PIECE(BUDTOT("ALL"),U,P)=$PIECE(BUDTOT("ALL"),U,P)+1
DO T
SET G=1
QUIT
+4 IF BUDAGE'<L
IF BUDAGE'>H
SET $PIECE(BUDTOT(BUDSEX),U,P)=$PIECE(BUDTOT(BUDSEX),U,P)+1
SET $PIECE(BUDTOT("ALL"),U,P)=$PIECE(BUDTOT("ALL"),U,P)+1
DO T
SET G=1
+5 QUIT
End DoDot:1
+6 IF $GET(BUDT3AL)
SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"VISITSUDSPT",X))
IF X'=+X
QUIT
SET ^XTMP("BUDDRPT1",BUDJ,BUDH,"3A",BUDAGE,BUDSEX,BUDCCOM,DFN,X)=""
+7 IF $GET(BUDSTMP)
SET ^XTMP("BUDDRPT1",BUDJ,BUDH,"3ATEMP",DFN)=""
+8 QUIT
T ;
+1 SET $PIECE(BUDTOT(BUDSEX),U,39)=$PIECE(BUDTOT(BUDSEX),U,39)+1
SET $PIECE(BUDTOT("ALL"),U,39)=$PIECE(BUDTOT("ALL"),U,39)+1
+2 IF BUDAGE<18
SET BUD019(BUDSEX)=BUD019(BUDSEX)+1
SET BUD019("ALL")=BUD019("ALL")+1
+3 QUIT
TZ ;
+1 SET BUDR=$$ZIP(DFN)
+2 IF BUDR=""
SET BUDR="Unknown Residence"
+3 SET BUDINS=$$ZIPINS^BUDDRPC3(DFN,BUDLASTV)
+4 IF BUDINS=""
SET BUDINS="b"
+5 ;column a
SET ^XTMP("BUDDRPT1",BUDJ,BUDH,"ZIP",BUDR)=$GET(^XTMP("BUDDRPT1",BUDJ,BUDH,"ZIP",BUDR))+1
+6 SET ^XTMP("BUDDRPT1",BUDJ,BUDH,"ZIP",BUDR,BUDINS)=$GET(^XTMP("BUDDRPT1",BUDJ,BUDH,"ZIP",BUDR,BUDINS))+1
+7 ;column f
SET ^XTMP("BUDDRPT1",BUDJ,BUDH,"ZIP",BUDR,"f")=$GET(^XTMP("BUDDRPT1",BUDJ,BUDH,"ZIP",BUDR,"f"))+1
+8 IF $GET(BUDTZL)
SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"VISITSUDSPT",X))
IF X'=+X
QUIT
SET ^XTMP("BUDDRPT1",BUDJ,BUDH,"Z",BUDR,BUDINS,BUDCCOM,BUDSEX,$PIECE(^DPT(DFN,0),U),DFN,X)=""
+9 QUIT
T3B ;
+1 SET BUDHISPN=$$HISP(DFN)
+2 ;column
SET BUDHISP=$PIECE($$HISP(DFN),U,1)
+3 ;set piece
SET BUDHISP1=BUDHISP+2
+4 ;
+5 SET BUDR1=$$RACE(DFN)
+6 ;LINE
SET BUDR=$PIECE(BUDR1,U,1)
+7 ;HISPANIC COLUMN FOR RACE
SET $PIECE(BUDRACET(BUDR),U,BUDHISP1)=$PIECE(BUDRACET(BUDR),U,BUDHISP1)+1
+8 ;TOTAL COLUMN FOR RACE
SET $PIECE(BUDRACET(BUDR),U,6)=$PIECE(BUDRACET(BUDR),U,6)+1
+9 ;total line 2
IF BUDR="2A"!(BUDR="2B")
SET $PIECE(BUDRACET(2),U,BUDHISP1)=$PIECE(BUDRACET(2),U,BUDHISP1)+1
SET $PIECE(BUDRACET(2),U,6)=$PIECE(BUDRACET(2),U,6)+1
+10 SET $PIECE(BUDRACET(8),U,BUDHISP1)=$PIECE(BUDRACET(8),U,BUDHISP1)+1
SET $PIECE(BUDRACET(8),U,6)=$PIECE(BUDRACET(8),U,6)+1
+11 IF $PIECE(BUDR1,U,5)=16
SET $PIECE(BUDR1,U,5)=8
+12 SET BUDXX=$$LOTE^BUDDRPTD(DFN,BUDLASTV)
IF BUDXX
SET $PIECE(BUDLANG(12),U,2)=$PIECE(BUDLANG(12),U,2)+1
+13 IF $GET(BUDT3BRL)
SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"VISITSUDSPT",X))
IF X'=+X
QUIT
SET ^XTMP("BUDDRPT1",BUDJ,BUDH,"3BR",$PIECE(BUDR1,U,5),$PIECE(BUDHISPN,U,1),BUDAGE,BUDSEX,BUDCCOM,DFN,X)=BUDR1_"|||"_BUDHISPN_"|||"_BUDXX
+14 DO SEXOR^BUDDRPTE
+15 DO GENDIDEN^BUDDRPTE
+16 QUIT
T5 ;tally prim provider
+1 SET BUDV=0
FOR
SET BUDV=$ORDER(^TMP($JOB,"VISITSTABLE5",BUDV))
IF BUDV'=+BUDV
QUIT
Begin DoDot:1
+2 SET BUDP=$$PRIMPROV^APCLV(BUDV,"D")
+3 IF BUDP=""
QUIT
+4 ;special case for DX of MH
+5 ;special case for provider code 15 and location CHS*
+6 IF $EXTRACT($$VAL^XBDIQ1(9000010,BUDV,.06),1,3)="CHS"
IF BUDP=15
SET BUDT5LN=2
DO T5SET
QUIT
+7 SET BUDY=$ORDER(^BUDDTFIV("C",BUDP,0))
IF BUDY=""
SET BUDT5LN=35
DO T5SET
QUIT
+8 ;next lines for Bh stuff based on dx
+9 SET T=$ORDER(^BUDDCNTL("B","BH DISCIPLINES FOR 20 AND 21",0))
+10 IF $DATA(^BUDDCNTL(T,11,"B",BUDP))
Begin DoDot:2
+11 SET P=$$PRIMPOV^APCLV(BUDV,"I")
+12 IF P
IF $DATA(^BUDDTSSC("AD",P,$ORDER(^BUDDTSSC("B","T5 BH CODES L20A",0))))
SET BUDT5LN="21"
QUIT
+13 SET BUDT5LN=$PIECE(^BUDDCNTL(T,11,$ORDER(^BUDDCNTL(T,11,"B",BUDP,0)),0),U,2)
QUIT
End DoDot:2
DO T5SET
QUIT
+14 SET BUDT5LN=$PIECE(^BUDDTFIV(BUDY,0),U)
+15 DO T5SET
+16 QUIT
End DoDot:1
+17 QUIT
T5SET ;
+1 IF BUDT5LN>0
IF BUDT5LN<8
DO T5PHY
+2 IF +BUDT5LN>8
IF +BUDT5LN<11
DO T5MID
+3 IF +BUDT5LN>10
IF BUDT5LN<15
DO T5NUR
+4 IF BUDT5LN>15
IF +BUDT5LN<19
DO T5DENT
+5 IF +BUDT5LN=20
DO T520
+6 IF BUDT5LN=21
DO T521
+7 IF $LENGTH(BUDT5LN)=3
IF $EXTRACT(BUDT5LN,1,2)=22
DO T5VISION
+8 IF BUDT5LN=22
DO T522
+9 IF BUDT5LN=23
DO T523
+10 IF BUDT5LN>23
IF BUDT5LN<29
DO T5ENA
+11 IF BUDT5LN="29A"
DO T529A
+12 IF BUDT5LN["30"
DO T530A
+13 IF +BUDT5LN>29
IF BUDT5LN<33
DO T5ADM
+14 IF BUDT5LN=35
DO T5OTH
+15 IF $GET(BUDT5L)!($GET(BUDT5L2))
Begin DoDot:1
+16 IF BUDT5LN=12
QUIT
+17 IF BUDT5LN=13
QUIT
+18 IF BUDT5LN=14
QUIT
+19 IF BUDT5LN=18
QUIT
+20 IF BUDT5LN="22C"
QUIT
+21 IF BUDT5LN=23
QUIT
+22 IF BUDT5LN=26
QUIT
+23 IF BUDT5LN="30A"
QUIT
+24 IF BUDT5LN=32
QUIT
+25 IF BUDT5LN=27
QUIT
+26 IF BUDT5LN="27a"
QUIT
+27 IF BUDT5LN="27b"
QUIT
+28 IF BUDT5LN="27c"
QUIT
+29 IF BUDT5LN=28
QUIT
+30 IF BUDT5LN="29A"
QUIT
+31 IF BUDT5LN="29b"
QUIT
+32 IF BUDT5LN="30B"
QUIT
+33 IF BUDT5LN="30C"
QUIT
+34 IF BUDT5LN=31
QUIT
+35 SET ^XTMP("BUDDRPT1",BUDJ,BUDH,"T5",+BUDT5LN,$SELECT(BUDT5LN="20A1":"A1",BUDT5LN="20A2":"A2",+BUDT5LN=BUDT5LN:0,1:$EXTRACT(BUDT5LN,$LENGTH(BUDT5LN))),BUDCCOM,BUDAGE,BUDSEX,DFN,BUDV)=$$PRIMPROV^APCLV(BUDV,"N")_"^"_$$PRIMPROV^APCLV(BUDV,"
P")
End DoDot:1
+36 IF $GET(BUDT5L1)
SET ^XTMP("BUDDRPT1",BUDJ,BUDH,"T51",+BUDT5LN,$SELECT(BUDT5LN="20A1":"A1",BUDT5LN="20A2":"A2",+BUDT5LN=BUDT5LN:0,1:$EXTRACT(BUDT5LN,$LENGTH(BUDT5LN))),$$PRIMPROV^APCLV(BUDV,"N"))=$$PRIMPROV^APCLV(BUDV,"D")_" "_$$PRIMPROV^APCLV(BUDV,"E")
+37 QUIT
T5PHY ;set
+1 SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 SET $PIECE(BUDTAB5(8),U)=$PIECE(BUDTAB5(8),U)+1
+3 SET $PIECE(BUDTAB5(15),U)=$PIECE(BUDTAB5(15),U)+1
+4 IF $GET(BUDT5L3)
Begin DoDot:1
+5 IF $DATA(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MED SERV",$$VD^APCLV(BUDV)))
Begin DoDot:2
+6 SET ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MED SERV",$$VD^APCLV(BUDV))=^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MED SERV",$$VD^APCLV(BUDV))_U_BUDV
End DoDot:2
IF 1
+7 IF '$TEST
SET ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MED SERV",$$VD^APCLV(BUDV))=BUDV
End DoDot:1
+8 IF $DATA(^TMP($JOB,"PATIENTS","MED SERV",DFN))
QUIT
+9 SET ^TMP($JOB,"PATIENTS","MED SERV",DFN)=""
SET $PIECE(BUDTAB5(15),U,2)=$PIECE(BUDTAB5(15),U,2)+1
+10 QUIT
T5MID ;
+1 ;total visits for this line
SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 ;total MID encs line
SET $PIECE(BUDTAB5("10A"),U)=$PIECE(BUDTAB5("10A"),U)+1
+3 ;total med services line
SET $PIECE(BUDTAB5(15),U)=$PIECE(BUDTAB5(15),U)+1
+4 IF $DATA(^TMP($JOB,"PATIENTS","MED SERV",DFN))
QUIT
+5 SET ^TMP($JOB,"PATIENTS","MED SERV",DFN)=""
SET $PIECE(BUDTAB5(15),U,2)=$PIECE(BUDTAB5(15),U,2)+1
+6 QUIT
T5NUR ;
+1 SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 IF BUDT5LN=12
QUIT
+3 IF BUDT5LN=13
QUIT
+4 IF BUDT5LN=14
QUIT
+5 SET $PIECE(BUDTAB5(15),U)=$PIECE(BUDTAB5(15),U)+1
+6 IF $DATA(^TMP($JOB,"PATIENTS","MED SERV",DFN))
QUIT
+7 SET ^TMP($JOB,"PATIENTS","MED SERV",DFN)=""
SET $PIECE(BUDTAB5(15),U,2)=$PIECE(BUDTAB5(15),U,2)+1
+8 QUIT
T5DENT ;
+1 SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 IF BUDT5LN=18
QUIT
+3 SET $PIECE(BUDTAB5(19),U)=$PIECE(BUDTAB5(19),U)+1
+4 IF $GET(BUDT5L3)
Begin DoDot:1
+5 IF $DATA(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",$$VD^APCLV(BUDV)))
Begin DoDot:2
+6 SET ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",$$VD^APCLV(BUDV))=^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",$$VD^APCLV(BUDV))_U_BUDV
End DoDot:2
+7 IF '$TEST
SET ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",$$VD^APCLV(BUDV))=BUDV
End DoDot:1
IF 1
+8 IF $DATA(^TMP($JOB,"PATIENTS","DENT SERV",DFN))
QUIT
+9 SET ^TMP($JOB,"PATIENTS","DENT SERV",DFN)=""
SET $PIECE(BUDTAB5(19),U,2)=$PIECE(BUDTAB5(19),U,2)+1
+10 QUIT
T520 ;
+1 SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 SET $PIECE(BUDTAB5(20),U)=$PIECE(BUDTAB5(20),U)+1
+3 IF $GET(BUDT5L3)
Begin DoDot:1
+4 IF $DATA(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",$$VD^APCLV(BUDV)))
Begin DoDot:2
+5 SET ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",$$VD^APCLV(BUDV))=^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",$$VD^APCLV(BUDV))_U_BUDV
End DoDot:2
+6 IF '$TEST
SET ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",$$VD^APCLV(BUDV))=BUDV
End DoDot:1
IF 1
+7 IF $DATA(^TMP($JOB,"PATIENTS","20 SERV",DFN))
QUIT
+8 SET ^TMP($JOB,"PATIENTS","20 SERV",DFN)=""
SET $PIECE(BUDTAB5(20),U,2)=$PIECE(BUDTAB5(20),U,2)+1
+9 QUIT
T521 ;
+1 SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 IF $GET(BUDT5L3)
Begin DoDot:1
+3 IF $DATA(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",$$VD^APCLV(BUDV)))
Begin DoDot:2
+4 SET ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",$$VD^APCLV(BUDV))=^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",$$VD^APCLV(BUDV))_U_BUDV
End DoDot:2
+5 IF '$TEST
SET ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",$$VD^APCLV(BUDV))=BUDV
End DoDot:1
IF 1
+6 IF $DATA(^TMP($JOB,"PATIENTS","21 SERV",DFN))
QUIT
+7 SET ^TMP($JOB,"PATIENTS","21 SERV",DFN)=""
SET $PIECE(BUDTAB5(21),U,2)=$PIECE(BUDTAB5(21),U,2)+1
+8 QUIT
T522 ;
+1 SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 IF $GET(BUDT5L3)
Begin DoDot:1
+3 IF $DATA(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDP,$$VD^APCLV(BUDV)))
Begin DoDot:2
+4 SET ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDP,$$VD^APCLV(BUDV))=^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDP,$$VD^APCLV(BUDV))_U_BUDV
End DoDot:2
+5 IF '$TEST
SET ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDP,$$VD^APCLV(BUDV))=BUDV
End DoDot:1
IF 1
+6 IF $DATA(^TMP($JOB,"PATIENTS","22 SERV",DFN))
QUIT
+7 SET ^TMP($JOB,"PATIENTS","22 SERV",DFN)=""
SET $PIECE(BUDTAB5(22),U,2)=$PIECE(BUDTAB5(22),U,2)+1
+8 QUIT
T523 ;
+1 SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 QUIT
T5VISION ;
+1 SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 IF BUDT5LN="22C"
QUIT
+3 ;total vision line
SET $PIECE(BUDTAB5("22D"),U)=$PIECE(BUDTAB5("22D"),U)+1
+4 IF $GET(BUDT5L3)
Begin DoDot:1
+5 IF $DATA(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"VISION SERV",BUDP,$$VD^APCLV(BUDV)))
Begin DoDot:2
+6 SET ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"VISION SERV",BUDP,$$VD^APCLV(BUDV))=^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"VISION SERV",BUDP,$$VD^APCLV(BUDV))_U_BUDV
End DoDot:2
+7 IF '$TEST
SET ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"VISION SERV",BUDP,$$VD^APCLV(BUDV))=BUDV
End DoDot:1
IF 1
+8 IF $DATA(^TMP($JOB,"PATIENTS","22D SERV",DFN))
QUIT
+9 SET ^TMP($JOB,"PATIENTS","22D SERV",DFN)=""
SET $PIECE(BUDTAB5("22D"),U,2)=$PIECE(BUDTAB5("22D"),U,2)+1
+10 QUIT
T5ENA ;
+1 SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 IF BUDT5LN=23
QUIT
+3 IF BUDT5LN=26
QUIT
+4 IF $EXTRACT(BUDT5LN,1,2)=27
QUIT
+5 IF BUDT5LN=28
QUIT
+6 ;total enabling services line
IF BUDT5LN=24!(BUDT5LN=25)
SET $PIECE(BUDTAB5(29),U)=$PIECE(BUDTAB5(29),U)+1
+7 IF $GET(BUDT5L3)
Begin DoDot:1
+8 IF $DATA(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDT5LN,$$VD^APCLV(BUDV)))
Begin DoDot:2
+9 SET ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDT5LN,$$VD^APCLV(BUDV))=^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDT5LN,$$VD^APCLV(BUDV))_U_BUDV
End DoDot:2
+10 IF '$TEST
SET ^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDT5LN,$$VD^APCLV(BUDV))=BUDV
End DoDot:1
IF 1
+11 IF $DATA(^TMP($JOB,"PATIENTS","ENA SERV",DFN))
QUIT
+12 SET ^TMP($JOB,"PATIENTS","ENA SERV",DFN)=""
SET $PIECE(BUDTAB5(29),U,2)=$PIECE(BUDTAB5(29),U,2)+1
+13 QUIT
T529A ;
+1 ;total visits for this line
SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 QUIT
T530A ;
+1 ;all of line 3 grayed out
QUIT
+2 ;total line 30
SET $PIECE(BUDTAB5(30),U)=$PIECE(BUDTAB5(30),U)+1
T5ADM ;
+1 ;all of 31, 32, 33 is grayed out
QUIT
+2 ;total visits for this line
SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+3 SET $PIECE(BUDTAB5(33),U)=$PIECE(BUDTAB5(33),U)+1
+4 IF $DATA(^TMP($JOB,"PATIENTS","ADM SERV",DFN))
QUIT
+5 SET ^TMP($JOB,"PATIENTS","ADM SERV",DFN)=""
SET $PIECE(BUDTAB5(33),U,2)=$PIECE(BUDTAB5(33),U,2)+1
+6 QUIT
T5OTH ;
+1 SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 QUIT
+3 ;
T6 ;
+1 DO T6^BUDDRPC1
+2 QUIT
+3 ;
HISP(DFN) ;EP
+1 NEW X,Y,Z,V,A,C,R
+2 SET A=""
SET X=""
+3 IF $GET(DFN)=""
QUIT ""
+4 SET Y=$$ETHN(DFN)
+5 IF Y="HISPANIC OR LATINO"
QUIT 1_U_"E"_U_Y
+6 IF Y="NOT HISPANIC OR LATINO"
QUIT 2_U_"E"_U_Y
+7 SET C=0
SET R=""
SET A=""
SET Z=""
+8 SET Y=0
FOR
SET Y=$ORDER(^DPT(DFN,.02,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+9 SET C=C+1
+10 ;
IF X=""
SET X=$PIECE(^DPT(DFN,.02,Y,0),U,1)
End DoDot:1
+11 IF C>1
QUIT 2_U_"R"_U_"MULT RACE"
+12 IF X
SET Z=$PIECE(^DIC(10,X,0),U,2)
+13 IF Z=1
QUIT 1_U_"R"_U_$$RABB(Z)
+14 IF Z=2
QUIT 1_U_"R"_U_$$RABB(Z)
+15 IF Z="D"!(Z="U")!(Z=7)
Begin DoDot:1
+16 IF Y]""
SET A=3_U_"E"_U_Y
QUIT
+17 SET A=3_U_"R"_U_$$RABB(Z)
End DoDot:1
QUIT A
+18 IF Z]""
QUIT 2_"^R^"_$$RABB(Z)
+19 IF Y]""
QUIT 3_U_"E"_U_Y
HISPN ;
+1 SET X=$PIECE(^DPT(DFN,0),U,6)
+2 SET Z=""
+3 IF X
SET Z=$PIECE(^DIC(10,X,0),U,2)
+4 IF Z=1
QUIT 1_U_"R"_U_$$RABB(Z)
+5 IF Z=2
QUIT 1_U_"R"_U_$$RABB(Z)
+6 IF Z="D"!(Z="U")!(Z=7)
Begin DoDot:1
+7 IF Y]""
SET V=3_U_"E"_U_Y
QUIT
+8 SET V=3_U_"R"_U_$$RABB(Z)
End DoDot:1
QUIT V
+9 IF Z]""
QUIT 2_"^R^"_$$RABB(Z)
+10 IF Y]""
QUIT 3_U_"E"_U_Y
+11 IF $$BEN^AUPNPAT(DFN,"C")="01"
IF Y=""
QUIT 2_U_"C"_U_"AI/AN"
+12 QUIT 3_"^E^BLANK RACE & ETHNICITY"
+13 ;
ETHN(P) ;EP
+1 NEW Z,E
+2 SET E=""
+3 SET Z=0
FOR
SET Z=$ORDER(^DPT(P,.06,Z))
IF Z'=+Z!(E]"")
QUIT
Begin DoDot:1
+4 SET E=$PIECE($GET(^DPT(P,.06,Z,0)),U,1)
+5 IF E=""
QUIT
+6 SET E=$PIECE($GET(^DIC(10.2,E,0)),U,1)
+7 QUIT
End DoDot:1
+8 QUIT E
RACE(DFN) ;EP
+1 NEW X,Y,Z,C,A
+2 IF $GET(DFN)=""
QUIT ""
+3 SET C=0
SET R=""
SET X=""
SET A=""
+4 SET Y=0
FOR
SET Y=$ORDER(^DPT(DFN,.02,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+5 SET C=C+1
+6 IF X=""
SET X=$PIECE(^DPT(DFN,.02,Y,0),U,1)
SET Z=$PIECE($GET(^DIC(10,X,0)),U)
SET X=$PIECE($GET(^DIC(10,X,0)),U,2)
End DoDot:1
+7 IF C>1
QUIT "6^MORE THAN ONE RACE^R"_U_"MORE THAN ONE RACE"_U_7
+8 IF X]""
SET A=$$SETRC(X)
QUIT A
+9 SET X=$PIECE(^DPT(DFN,0),U,6)
+10 IF X=""
GOTO CL
+11 IF X
SET Z=$PIECE(^DIC(10,X,0),U)
SET X=$PIECE($GET(^DIC(10,X,0)),U,2)
+12 IF X=""
GOTO CL
+13 QUIT $$SETRC(X)
CL IF $$BEN^AUPNPAT(DFN,"C")="01"
QUIT "4^AI/AN^C^AI/AN^5"
+1 QUIT "7^UNREP/REF^C^BLANK RACE^8"
+2 ;
SETRC(X) ;
+1 IF X="A"
QUIT "1^ASIAN^R"_U_Z_U_1
+2 IF X="H"
QUIT "2A^NATIVE HAWAIIAN^R"_U_Z_U_2
+3 IF X=5
QUIT "2B^OTH PAC ISLANDER^R"_U_Z_U_3
+4 IF X=4!(X="B")
QUIT "3^BLACK^R"_U_Z_U_4
+5 IF X=3!(X="Z")!(X="AIAN")
QUIT "4^AI/AN^R"_U_Z_U_5
+6 IF X=6!(X="W")
QUIT "5^WHITE^R"_U_Z_U_6
+7 IF X=1
QUIT "5^WHITE^R"_U_Z_U_6
+8 IF X="D"
QUIT "7^UNREP/REF^R"_U_Z_U_8
+9 IF X="7"
QUIT "7^UNREP/REF^R"_U_Z_U_8
+10 IF X="U"
QUIT "7^UNREP/REF^R"_U_Z_U_8
+11 IF X=2
QUIT "3^BLACK^R"_U_Z_U_4
+12 IF X="O"
QUIT "7^UNREP/REF^R"_U_Z_U_8
+13 IF Z="OTHER"
QUIT "7^UNREP/REF^R"_U_Z_U_8
+14 QUIT ""
ZIP(DFN) ;
+1 IF $GET(DFN)=""
QUIT ""
+2 QUIT $EXTRACT($PIECE($GET(^DPT(DFN,.11)),U,6),1,5)
+3 ;
RABB(X) ;
+1 IF X="A"
QUIT "ASIAN"
+2 IF X="H"
QUIT "NATIVE HAWAIIAN"
+3 IF X=5
QUIT "OTH PAC ISLANDER"
+4 IF X="B"
QUIT "BLACK/AFRICAN"
+5 IF X=4
QUIT "BLACK NOT HISP"
+6 IF X=3!(X="Z")!(X="AIAN")
QUIT "AI/AN"
+7 IF X="W"
QUIT "WHITE"
+8 IF X=6
QUIT "WHITE NOT HISP"
+9 IF X=1
QUIT "HISPANIC, WHITE"
+10 IF X="D"
QUIT "DECLINED"
+11 IF X="7"
QUIT "UNKNOWN"
+12 IF X="U"
QUIT "UNKNOWN BY PT"
+13 IF X=2
QUIT "HISPANIC, BLACK"
+14 QUIT "??"
T6B ;
+1 SET BUDAGE=$$AGE^AUPNPAT(DFN,BUDED)
+2 SET BUDAGEP=$$AGE^AUPNPAT(DFN,BUDCCAD)
+3 DO IMM^BUDDRP6C
+4 DO PAPD^BUDDRP6D
+5 DO ADOLWT^BUDDRP6V
+6 DO ADULT^BUDDRP6V
+7 DO G^BUDDRP6V
+8 DO H^BUDDRP6U
+9 DO I^BUDDRP6O
+10 DO J^BUDDRP6M
+11 DO K^BUDDRP6N
+12 DO L^BUDDRP6Q
+13 DO M^BUDDRP6Q
+14 DO N^BUDDRP6A
+15 SET BUDAGE=$$AGE^AUPNPAT(DFN,BUDCCAD)
+16 QUIT
T7 ;
+1 SET BUDAGE=$$AGE^AUPNPAT(DFN,BUDED)
+2 SET BUDAGEP=$$AGE^AUPNPAT(DFN,BUDCCAD)
+3 DO PRGHLST^BUDDRP7A
+4 DO PRGRLST^BUDDRP7A
+5 DO HTN^BUDDRP7B
+6 DO DM^BUDDRP7C
+7 SET BUDAGE=$$AGE^AUPNPAT(DFN,BUDCCAD)
+8 QUIT
IWTO(P) ;
+1 IF $PIECE(^DPT(DFN,0),U,1)["DEMO,PATIENT"
QUIT 1
+2 IF $PIECE(^DPT(DFN,0),U,1)["PATIENT,CRS"
QUIT 1
+3 IF $PIECE(^DPT(DFN,0),U,1)["PATIENT,UDS"
QUIT 1
+4 NEW X,T
+5 SET T=$ORDER(^ATXAX("B","DEMO COMMUNITY TAXONOMY",0))
+6 SET X=$PIECE($GET(^AUPNPAT(P,11)),U,18)
IF X=""
QUIT 0
+7 IF '$DATA(^ATXAX(T,21,"B",($PIECE(^AUPNPAT(P,11),U,18))))
IF '$DATA(^ATXAX(T,21,"AA",$PIECE(^AUPNPAT(P,11),U,18),$PIECE(^AUPNPAT(P,11),U,18)))
QUIT 0
+8 QUIT 1
