BUDRPTC ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
;
PROC ;EP - called from xbdbque
S BUDJ=$J,BUDH=$H
K ^TMP($J)
S ^XTMP("BUDRPT1",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"UDS REPORT"
K BUDTOT F X=1:1:39 S $P(BUDTOT("M"),U,X)=0,$P(BUDTOT("F"),U,X)=0,$P(BUDTOT("ALL"),U,X)=0 ;for table 3A
K BUDRACET
F X=1:1:35 S BUDTAB5(X)="0^0"
S BUDTAB5("29A")="0^0"
F X="1A","1B","1C",1,2,3,4,5,6,7,8 S BUDRACET(X)=0
F X=1:1:26 S $P(BUDT6("V"),U,X)=0,$P(BUDT6("P"),U,X)=0
S BUD019("M")="",BUD019("F")="",BUD019("ALL")=""
S DFN=0 F S DFN=$O(^DPT(DFN)) Q:DFN'=+DFN D
.K ^TMP($J,"VISITS"),^TMP($J,"VISITSLIST"),^TMP($J,"PATIENTS"),^TMP($J,"ORPHANS")
.Q:$P(^DPT(DFN,0),U,19) ;merged away
.S BUDAGE=$$AGE^AUPNPAT(DFN,BUDCAD)
.S BUDSEX=$P(^DPT(DFN,0),U,2)
.S BUDCOM=$$COMMRES^AUPNPAT(DFN,"E") I BUDCOM="" S BUDCOM="UNKNOWN"
.D GETV ;get visits that meet criteria
.I BUDTV=0 Q ;user doesn't have any visits
.I $G(BUDT3A) D T3A
.I $G(BUDT3B) D T3B
.I $G(BUDT5) D T5
.I $G(BUDT6) D T6
.Q
Q
;
T4 ;
Q
T3A ;
S G=0 F X=4:1:41 Q:G D
.S L=$P(^BUDTTA(X,0),U,7),H=$P(^BUDTTA(X,0),U,8),P=$P(^BUDTTA(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,"VISITSLIST",X)) Q:X'=+X S ^XTMP("BUDRPT1",BUDJ,BUDH,"3A",BUDAGE,BUDSEX,BUDCOM,DFN,X)=""
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<20 S BUD019(BUDSEX)=BUD019(BUDSEX)+1,BUD019("ALL")=BUD019("ALL")+1
Q
T3B ;
S BUDR=$$RACE(DFN)
I BUDR="" S BUDR="D"
I $P(BUDR,U)="1A" S BUDRACET("1A")=BUDRACET("1A")+1
I $P(BUDR,U)="1B" S BUDRACET("1B")=BUDRACET("1B")+1
I $P(BUDR,U)=5 S BUDRACET("1C")=BUDRACET("1C")+1
I $P(BUDR,U)="B" S BUDRACET(2)=BUDRACET(2)+1
I $P(BUDR,U)=3 S BUDRACET(3)=BUDRACET(3)+1
I $P(BUDR,U)="W" S BUDRACET(4)=BUDRACET(4)+1
I $P(BUDR,U)="HSP" S BUDRACET(5)=BUDRACET(5)+1
I $P(BUDR,U)="D" S BUDRACET(6)=BUDRACET(6)+1
I $P(BUDR,U)="U" S BUDRACET(6)=BUDRACET(6)+1
I $P(BUDR,U)=7 S BUDRACET(6)=BUDRACET(6)+1
I $G(BUDT3BL),'$G(BUDT3AL) S X=0 F S X=$O(^TMP($J,"VISITSLIST",X)) Q:X'=+X S ^XTMP("BUDRPT1",BUDJ,BUDH,"3A",BUDAGE,BUDSEX,BUDCOM,DFN,X)=""
Q
T5 ;tally prim provider by discipline and by user
S BUDV=0 F S BUDV=$O(^TMP($J,"VISITSLIST",BUDV)) Q:BUDV'=+BUDV D
.;S BUDV=$P(^TMP($J,"VISITS",BUDVN),U,5)
.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(^BUDTFIVE("C",BUDP,0)) I BUDY="" S BUDT5LN=35 D T5SET Q
.S BUDT5LN=$P(^BUDTFIVE(BUDY,0),U)
.I BUDT5LN=20 S P=$$PRIMPOV^APCLV(BUDV,"C") I $E(P,1,3)=303!($E(P,1,3)="304")!($E(P,1,3)="305") S BUDT5LN=21
.D T5SET
.Q
Q
T5SET ;
I BUDT5LN>0,BUDT5LN<8 D T5PHY
I BUDT5LN>8,BUDT5LN<15 D T5NUR
I BUDT5LN>15,BUDT5LN<19 D T5DENT
I BUDT5LN=20 D T520
I BUDT5LN=21 D T521
I BUDT5LN=22 D T522
I BUDT5LN=23 D T523
I BUDT5LN>23,BUDT5LN<29 D T5ENA
I BUDT5LN="29A" D T529A
I +BUDT5LN>29,BUDT5LN<33 D T5ADM
I BUDT5LN=35 D T5OTH
I $G(BUDT5L)!($G(BUDT5L2)) S ^XTMP("BUDRPT1",BUDJ,BUDH,"T5",BUDT5LN,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV)=$$PRIMPROV^APCLV(BUDV,"N")_"^"_$$PRIMPROV^APCLV(BUDV,"P")
I $G(BUDT5L1) S ^XTMP("BUDRPT1",BUDJ,BUDH,"T51",BUDT5LN,$$PRIMPROV^APCLV(BUDV,"N"))=$$PRIMPROV^APCLV(BUDV,"D")_" "_$$PRIMPROV^APCLV(BUDV,"E")
Q
T5PHY ;set physcian enc total, set med serv enc and user totals
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1 ;total encounters for this line
S $P(BUDTAB5(8),U)=$P(BUDTAB5(8),U)+1 ;total phy 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 ;total encounters for this line
I BUDT5LN=12 Q
I BUDT5LN=13 Q
I BUDT5LN=14 Q
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
T5DENT ;
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1 ;total encounters for this line
I BUDT5LN=18 Q
S $P(BUDTAB5(19),U)=$P(BUDTAB5(19),U)+1 ;total dental services line
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 ;total encounters for this line
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 ;total encounters for this line
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 ;total encounters for this line
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 ;total encounters for this line
Q
T5ENA ;
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1 ;total encounters for this line
I BUDT5LN=23 Q
I BUDT5LN=26 Q
I BUDT5LN=27 Q
I BUDT5LN=28 Q
S $P(BUDTAB5(29),U)=$P(BUDTAB5(29),U)+1 ;total enabling services line
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 encounters for this line
Q
T5ADM ;
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1 ;total encounters for this line
S $P(BUDTAB5(33),U)=$P(BUDTAB5(33),U)+1 ;total adm services line
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^BUDRPTC1
Q
RACE(DFN) ;EP
I $G(DFN)="" Q ""
I $$BEN^AUPNPAT(DFN,"C")="01" Q "3^AI/AN"
NEW X S X=$P(^DPT(DFN,0),U,6)
S G="" I X S Y=$P(^DIC(10,X,0),U,1),X=$P(^DIC(10,X,0),U,2) D I G]"" Q G ;PATCH 1 FIXED
.I X="A" S G="1A^ASIAN" Q
.I X="H" S G="1B^NH" Q
.I X=5 S G="5^AS/PI" Q
.I X=4!(X="B") S G="B^BL" Q
.I X=3 S G="3^AI/AN" Q
.I X=6!(X="W") S G="W^WH" Q
.I X=1 S G="HSP^HSP/W" Q
.I X=2 S G="HSP^HSP/B" Q
.I X="D" S G="D^DECL" Q
.I X="7" S G="7^UNK" Q
.I X="U" S G="U^UNK" Q
Q "U^UNK"
GETV ;get all visits for this patient and tally in BUDTV
K ^TMP($J,"VISITS"),^TMP($J,"VISITSLIST"),^TMP($J,"PATIENTS"),^TMP($J,"ORPHANS")
S BUDTV=0
S A="^TMP($J,""VISITS"",",B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BUDBD)_"-"_$$FMTE^XLFDT(BUDED),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"VISITS",1)) Q
S X=0 F S X=$O(^TMP($J,"VISITS",X)) Q:X'=+X S V=$P(^TMP($J,"VISITS",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.S L=$P(^AUPNVSIT(V,0),U,6)
.Q:L=""
.Q:'$D(^BUDUSITE(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"
.I '$D(^AUPNVPRV("AD",V)) S ^TMP($J,"ORPHANS",V)="" Q
.I $$PRIMPROV^APCLV(V,"D")="" S ^TMP($J,"ORPHANS",V)="" Q ;no prim prov disc
.I '$D(^AUPNVPOV("AD",V)) S ^TMP($J,"ORPHANS",V)="" Q
.;must have a primary dx other than .9999
.S Y=$$PRIMPOV^APCLV(V,"C") I Y=".9999" S ^TMP($J,"ORPHANS",V)="" Q
.Q:"AHOSR"'[$P(^AUPNVSIT(V,0),U,7)
.S C=$$CLINIC^APCLV(V,"C")
.I C]"",$D(^BUDCNTL(1,11,"B",C)) Q ;not a clinic code we want
.S BUDTV=BUDTV+1
.S ^TMP($J,"VISITSLIST",V)=""
.Q
Q
BUDRPTC ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
+3 ;
PROC ;EP - called from xbdbque
+1 SET BUDJ=$JOB
SET BUDH=$HOROLOG
+2 KILL ^TMP($JOB)
+3 SET ^XTMP("BUDRPT1",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"UDS REPORT"
+4 ;for table 3A
KILL BUDTOT
FOR X=1:1:39
SET $PIECE(BUDTOT("M"),U,X)=0
SET $PIECE(BUDTOT("F"),U,X)=0
SET $PIECE(BUDTOT("ALL"),U,X)=0
+5 KILL BUDRACET
+6 FOR X=1:1:35
SET BUDTAB5(X)="0^0"
+7 SET BUDTAB5("29A")="0^0"
+8 FOR X="1A","1B","1C",1,2,3,4,5,6,7,8
SET BUDRACET(X)=0
+9 FOR X=1:1:26
SET $PIECE(BUDT6("V"),U,X)=0
SET $PIECE(BUDT6("P"),U,X)=0
+10 SET BUD019("M")=""
SET BUD019("F")=""
SET BUD019("ALL")=""
+11 SET DFN=0
FOR
SET DFN=$ORDER(^DPT(DFN))
IF DFN'=+DFN
QUIT
Begin DoDot:1
+12 KILL ^TMP($JOB,"VISITS"),^TMP($JOB,"VISITSLIST"),^TMP($JOB,"PATIENTS"),^TMP($JOB,"ORPHANS")
+13 ;merged away
IF $PIECE(^DPT(DFN,0),U,19)
QUIT
+14 SET BUDAGE=$$AGE^AUPNPAT(DFN,BUDCAD)
+15 SET BUDSEX=$PIECE(^DPT(DFN,0),U,2)
+16 SET BUDCOM=$$COMMRES^AUPNPAT(DFN,"E")
IF BUDCOM=""
SET BUDCOM="UNKNOWN"
+17 ;get visits that meet criteria
DO GETV
+18 ;user doesn't have any visits
IF BUDTV=0
QUIT
+19 IF $GET(BUDT3A)
DO T3A
+20 IF $GET(BUDT3B)
DO T3B
+21 IF $GET(BUDT5)
DO T5
+22 IF $GET(BUDT6)
DO T6
+23 QUIT
End DoDot:1
+24 QUIT
+25 ;
T4 ;
+1 QUIT
T3A ;
+1 SET G=0
FOR X=4:1:41
IF G
QUIT
Begin DoDot:1
+2 SET L=$PIECE(^BUDTTA(X,0),U,7)
SET H=$PIECE(^BUDTTA(X,0),U,8)
SET P=$PIECE(^BUDTTA(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,"VISITSLIST",X))
IF X'=+X
QUIT
SET ^XTMP("BUDRPT1",BUDJ,BUDH,"3A",BUDAGE,BUDSEX,BUDCOM,DFN,X)=""
+7 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<20
SET BUD019(BUDSEX)=BUD019(BUDSEX)+1
SET BUD019("ALL")=BUD019("ALL")+1
+3 QUIT
T3B ;
+1 SET BUDR=$$RACE(DFN)
+2 IF BUDR=""
SET BUDR="D"
+3 IF $PIECE(BUDR,U)="1A"
SET BUDRACET("1A")=BUDRACET("1A")+1
+4 IF $PIECE(BUDR,U)="1B"
SET BUDRACET("1B")=BUDRACET("1B")+1
+5 IF $PIECE(BUDR,U)=5
SET BUDRACET("1C")=BUDRACET("1C")+1
+6 IF $PIECE(BUDR,U)="B"
SET BUDRACET(2)=BUDRACET(2)+1
+7 IF $PIECE(BUDR,U)=3
SET BUDRACET(3)=BUDRACET(3)+1
+8 IF $PIECE(BUDR,U)="W"
SET BUDRACET(4)=BUDRACET(4)+1
+9 IF $PIECE(BUDR,U)="HSP"
SET BUDRACET(5)=BUDRACET(5)+1
+10 IF $PIECE(BUDR,U)="D"
SET BUDRACET(6)=BUDRACET(6)+1
+11 IF $PIECE(BUDR,U)="U"
SET BUDRACET(6)=BUDRACET(6)+1
+12 IF $PIECE(BUDR,U)=7
SET BUDRACET(6)=BUDRACET(6)+1
+13 IF $GET(BUDT3BL)
IF '$GET(BUDT3AL)
SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"VISITSLIST",X))
IF X'=+X
QUIT
SET ^XTMP("BUDRPT1",BUDJ,BUDH,"3A",BUDAGE,BUDSEX,BUDCOM,DFN,X)=""
+14 QUIT
T5 ;tally prim provider by discipline and by user
+1 SET BUDV=0
FOR
SET BUDV=$ORDER(^TMP($JOB,"VISITSLIST",BUDV))
IF BUDV'=+BUDV
QUIT
Begin DoDot:1
+2 ;S BUDV=$P(^TMP($J,"VISITS",BUDVN),U,5)
+3 SET BUDP=$$PRIMPROV^APCLV(BUDV,"D")
+4 IF BUDP=""
QUIT
+5 ;special case for DX of MH
+6 ;special case for provider code 15 and location CHS*
+7 IF $EXTRACT($$VAL^XBDIQ1(9000010,BUDV,.06),1,3)="CHS"
IF BUDP=15
SET BUDT5LN=2
DO T5SET
QUIT
+8 SET BUDY=$ORDER(^BUDTFIVE("C",BUDP,0))
IF BUDY=""
SET BUDT5LN=35
DO T5SET
QUIT
+9 SET BUDT5LN=$PIECE(^BUDTFIVE(BUDY,0),U)
+10 IF BUDT5LN=20
SET P=$$PRIMPOV^APCLV(BUDV,"C")
IF $EXTRACT(P,1,3)=303!($EXTRACT(P,1,3)="304")!($EXTRACT(P,1,3)="305")
SET BUDT5LN=21
+11 DO T5SET
+12 QUIT
End DoDot:1
+13 QUIT
T5SET ;
+1 IF BUDT5LN>0
IF BUDT5LN<8
DO T5PHY
+2 IF BUDT5LN>8
IF BUDT5LN<15
DO T5NUR
+3 IF BUDT5LN>15
IF BUDT5LN<19
DO T5DENT
+4 IF BUDT5LN=20
DO T520
+5 IF BUDT5LN=21
DO T521
+6 IF BUDT5LN=22
DO T522
+7 IF BUDT5LN=23
DO T523
+8 IF BUDT5LN>23
IF BUDT5LN<29
DO T5ENA
+9 IF BUDT5LN="29A"
DO T529A
+10 IF +BUDT5LN>29
IF BUDT5LN<33
DO T5ADM
+11 IF BUDT5LN=35
DO T5OTH
+12 IF $GET(BUDT5L)!($GET(BUDT5L2))
SET ^XTMP("BUDRPT1",BUDJ,BUDH,"T5",BUDT5LN,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV)=$$PRIMPROV^APCLV(BUDV,"N")_"^"_$$PRIMPROV^APCLV(BUDV,"P")
+13 IF $GET(BUDT5L1)
SET ^XTMP("BUDRPT1",BUDJ,BUDH,"T51",BUDT5LN,$$PRIMPROV^APCLV(BUDV,"N"))=$$PRIMPROV^APCLV(BUDV,"D")_" "_$$PRIMPROV^APCLV(BUDV,"E")
+14 QUIT
T5PHY ;set physcian enc total, set med serv enc and user totals
+1 ;total encounters for this line
SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 ;total phy encs line
SET $PIECE(BUDTAB5(8),U)=$PIECE(BUDTAB5(8),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 ;total encounters for this line
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 ;total med services line
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 ;total encounters for this line
SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 IF BUDT5LN=18
QUIT
+3 ;total dental services line
SET $PIECE(BUDTAB5(19),U)=$PIECE(BUDTAB5(19),U)+1
+4 IF $DATA(^TMP($JOB,"PATIENTS","DENT SERV",DFN))
QUIT
+5 SET ^TMP($JOB,"PATIENTS","DENT SERV",DFN)=""
SET $PIECE(BUDTAB5(19),U,2)=$PIECE(BUDTAB5(19),U,2)+1
+6 QUIT
T520 ;
+1 ;total encounters for this line
SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 IF $DATA(^TMP($JOB,"PATIENTS","20 SERV",DFN))
QUIT
+3 SET ^TMP($JOB,"PATIENTS","20 SERV",DFN)=""
SET $PIECE(BUDTAB5(20),U,2)=$PIECE(BUDTAB5(20),U,2)+1
+4 QUIT
T521 ;
+1 ;total encounters for this line
SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 IF $DATA(^TMP($JOB,"PATIENTS","21 SERV",DFN))
QUIT
+3 SET ^TMP($JOB,"PATIENTS","21 SERV",DFN)=""
SET $PIECE(BUDTAB5(21),U,2)=$PIECE(BUDTAB5(21),U,2)+1
+4 QUIT
T522 ;
+1 ;total encounters for this line
SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 IF $DATA(^TMP($JOB,"PATIENTS","22 SERV",DFN))
QUIT
+3 SET ^TMP($JOB,"PATIENTS","22 SERV",DFN)=""
SET $PIECE(BUDTAB5(22),U,2)=$PIECE(BUDTAB5(22),U,2)+1
+4 QUIT
T523 ;
+1 ;total encounters for this line
SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 QUIT
T5ENA ;
+1 ;total encounters for this line
SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 IF BUDT5LN=23
QUIT
+3 IF BUDT5LN=26
QUIT
+4 IF BUDT5LN=27
QUIT
+5 IF BUDT5LN=28
QUIT
+6 ;total enabling services line
SET $PIECE(BUDTAB5(29),U)=$PIECE(BUDTAB5(29),U)+1
+7 IF $DATA(^TMP($JOB,"PATIENTS","ENA SERV",DFN))
QUIT
+8 SET ^TMP($JOB,"PATIENTS","ENA SERV",DFN)=""
SET $PIECE(BUDTAB5(29),U,2)=$PIECE(BUDTAB5(29),U,2)+1
+9 QUIT
T529A ;
+1 ;total encounters for this line
SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 QUIT
T5ADM ;
+1 ;total encounters for this line
SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 ;total adm services line
SET $PIECE(BUDTAB5(33),U)=$PIECE(BUDTAB5(33),U)+1
+3 IF $DATA(^TMP($JOB,"PATIENTS","ADM SERV",DFN))
QUIT
+4 SET ^TMP($JOB,"PATIENTS","ADM SERV",DFN)=""
SET $PIECE(BUDTAB5(33),U,2)=$PIECE(BUDTAB5(33),U,2)+1
+5 QUIT
T5OTH ;
+1 SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 QUIT
+3 ;
T6 ;
+1 DO T6^BUDRPTC1
+2 QUIT
RACE(DFN) ;EP
+1 IF $GET(DFN)=""
QUIT ""
+2 IF $$BEN^AUPNPAT(DFN,"C")="01"
QUIT "3^AI/AN"
+3 NEW X
SET X=$PIECE(^DPT(DFN,0),U,6)
+4 ;PATCH 1 FIXED
SET G=""
IF X
SET Y=$PIECE(^DIC(10,X,0),U,1)
SET X=$PIECE(^DIC(10,X,0),U,2)
Begin DoDot:1
+5 IF X="A"
SET G="1A^ASIAN"
QUIT
+6 IF X="H"
SET G="1B^NH"
QUIT
+7 IF X=5
SET G="5^AS/PI"
QUIT
+8 IF X=4!(X="B")
SET G="B^BL"
QUIT
+9 IF X=3
SET G="3^AI/AN"
QUIT
+10 IF X=6!(X="W")
SET G="W^WH"
QUIT
+11 IF X=1
SET G="HSP^HSP/W"
QUIT
+12 IF X=2
SET G="HSP^HSP/B"
QUIT
+13 IF X="D"
SET G="D^DECL"
QUIT
+14 IF X="7"
SET G="7^UNK"
QUIT
+15 IF X="U"
SET G="U^UNK"
QUIT
End DoDot:1
IF G]""
QUIT G
+16 QUIT "U^UNK"
GETV ;get all visits for this patient and tally in BUDTV
+1 KILL ^TMP($JOB,"VISITS"),^TMP($JOB,"VISITSLIST"),^TMP($JOB,"PATIENTS"),^TMP($JOB,"ORPHANS")
+2 SET BUDTV=0
+3 SET A="^TMP($J,""VISITS"","
SET B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BUDBD)_"-"_$$FMTE^XLFDT(BUDED)
SET E=$$START1^APCLDF(B,A)
+4 IF '$DATA(^TMP($JOB,"VISITS",1))
QUIT
+5 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"VISITS",X))
IF X'=+X
QUIT
SET V=$PIECE(^TMP($JOB,"VISITS",X),U,5)
Begin DoDot:1
+6 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+7 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+8 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+9 SET L=$PIECE(^AUPNVSIT(V,0),U,6)
+10 IF L=""
QUIT
+11 ;not valid location
IF '$DATA(^BUDUSITE(BUDSITE,11,L))
QUIT
+12 IF $PIECE(^AUPNVSIT(V,0),U,7)="C"
QUIT
+13 IF $PIECE(^AUPNVSIT(V,0),U,7)="T"
QUIT
+14 IF $PIECE(^AUPNVSIT(V,0),U,7)="N"
QUIT
+15 IF '$DATA(^AUPNVPRV("AD",V))
SET ^TMP($JOB,"ORPHANS",V)=""
QUIT
+16 ;no prim prov disc
IF $$PRIMPROV^APCLV(V,"D")=""
SET ^TMP($JOB,"ORPHANS",V)=""
QUIT
+17 IF '$DATA(^AUPNVPOV("AD",V))
SET ^TMP($JOB,"ORPHANS",V)=""
QUIT
+18 ;must have a primary dx other than .9999
+19 SET Y=$$PRIMPOV^APCLV(V,"C")
IF Y=".9999"
SET ^TMP($JOB,"ORPHANS",V)=""
QUIT
+20 IF "AHOSR"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+21 SET C=$$CLINIC^APCLV(V,"C")
+22 ;not a clinic code we want
IF C]""
IF $DATA(^BUDCNTL(1,11,"B",C))
QUIT
+23 SET BUDTV=BUDTV+1
+24 SET ^TMP($JOB,"VISITSLIST",V)=""
+25 QUIT
End DoDot:1
+26 QUIT
