BUD4RPTP ; IHS/CMI/LAB - UDS REPORT PRINT ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
PRINT ;EP
S BUDPG=0
S BUDQUIT=0
S BUD80L="",$P(BUD80L,"_",79)="_"
I $G(BUDT3A) D T3A G:BUDQUIT EOJ
I $G(BUDT3B) D T3B G:BUDQUIT EOJ
I $G(BUDT4) D T4 G:BUDQUIT EOJ
I $G(BUDT5) D T5 G:BUDQUIT EOJ
I $G(BUDT6) D T6 G:BUDQUIT EOJ
D PATLISTS
D EOJ
Q
;
EOJ ;
K ^TMP($J)
K ^XTMP("BUD4RPT1",BUDJ,BUDH)
Q
T4 ;
Q
T3A ;
D HEADER Q:BUDQUIT D T3ASH
;print out each line
S BUDC=3 F S BUDC=$O(^BUDFTTA("B",BUDC)) Q:BUDC'=+BUDC!(BUDQUIT) D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T3ASH
.S BUDY=^BUDFTTA(BUDC,0)
.S BUDX=$P(BUDY,U,2) ;column one and control
.W !
.I BUDX<10 W " "
.W $P(BUDY,U,2),?5,$P(BUDY,U,3)
.;I +BUDX=0 Q
.W ?35,$$C($P(BUDTOT("M"),U,BUDX)),?50,$$C($P(BUDTOT("F"),U,BUDX)),?68,$$C($P(BUDTOT("ALL"),U,BUDX))
.I BUDX=20 D
..I $Y>(IOSL-4) D HEADER Q:BUDQUIT D T3ASH
..W !!?10,"SUBTOTAL 0-19",?35,$$C(BUD019("M")),?50,$$C(BUD019("F")),?68,$$C(BUD019("ALL")),!
Q
T3ASH ;
W !,$$CTR($G(^BUDFTTA(1,11)),80),!
F X=2:1:3 W !,$P(^BUDFTTA(X,0),U,2),?5,$P(^BUDFTTA(X,0),U,3),?33,$P(^BUDFTTA(X,0),U,4),?50,$P(^BUDFTTA(X,0),U,5),?68,$P(^BUDFTTA(X,0),U,6)
W !,$TR($J("",80)," ","-"),!
Q
T3BSH ;
W !!,$$CTR("TABLE 3B -",80)
W !,$$CTR("USERS BY RACE/ETHNICITY/LANGUAGE",80),!
W !,$TR($J("",80)," ","-")
W !,"RACE/ETHNICITY/LANGUAGE",?65,"NUMBER (a)"
W !,"PROPORTION OF USERS"
W !,$TR($J("",80)," ","-")
Q
PATLISTS ;
D ^BUD4RPTL
Q
T3B ;
D HEADER Q:BUDQUIT D T3BSH
;print out each line
W !?3,"1a.",?8,"Asian",?65,$$C(BUDRACET("1A")),!,BUD80L
W !?3,"1b.",?8,"Native Hawaiian",?65,$$C(BUDRACET("1B")),!,BUD80L
W !?3,"1c.",?8,"Other Pacific Islander",?65,$$C(BUDRACET("1C")),!,BUD80L
I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T3BSH
W !,"1.",?13,"Asian/Pacific Islander (sum lines 1a+1b+1c)",?65,$$C(BUDRACET("1A")+BUDRACET("1B")+BUDRACET("1C")),!,BUD80L
I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T3BSH
W !,"2.",?8,"Black/African American (not Hispanic or Latino)",?65,$$C(BUDRACET(2)),!,BUD80L
I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T3BSH
W !,"3.",?8,"American Indian/Alaska Native",?65,$$C(BUDRACET(3)),!,BUD80L
I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T3BSH
W !,"4.",?8,"White (not Hispanic or Latino)",?65,$$C(BUDRACET(4)),!,BUD80L
I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T3BSH
W !,"5.",?8,"Hispanic or Latino (all races)",?65,$$C(BUDRACET(5)),!,BUD80L
I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T3BSH
W !,"6.",?8,"Unreported / Refused to Report",?65,$$C(BUDRACET(6)),!,BUD80L
I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T3BSH
S Y=0 F X="1A","1B","1C",1,2,3,4,5,6 S Y=Y+$G(BUDRACET(X))
W !,"7.",?12,"TOTAL USERS (SUM LINES 1-6)",?65,$$C(Y),!,BUD80L
I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T3BSH
W !,"8.",?8,"Users needing interpretation/Bilingual/Sign Language Services",!,BUD80L
Q
T5 ;print table 5
D HEADER Q:BUDQUIT D T5SH
;lines 1-8
F BUDL=1:1:7 S BUDY=$O(^BUDFTFIV("B",BUDL,0)) Q:BUDQUIT D
.Q:'BUDY
.W !
.I +BUDL<10 W " "
.W BUDL,".",?6,$P(^BUDFTFIV(BUDY,0),U,2)
.W ?60,$$C($P(BUDTAB5(BUDL),U,1),0)
.W ?71,$$C($P(BUDTAB5(BUDL),U,2),2)
.W !,BUD80L
W !," 8.",?10,"TOTAL PHYSICIANS",!?8,"(Total Lines 1 through 7)",?60,$$C($P(BUDTAB5(8),U,1)),?71,$$C($P(BUDTAB5(8),U,2),2),!,BUD80L
;print out lines 9-15
F BUDL="9A","9B",10:1:11 S BUDY=$O(^BUDFTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !
.I +BUDL<10 W " "
.W BUDL,".",?6,$P(^BUDFTFIV(BUDY,0),U,2)
.W ?60,$$C($P(BUDTAB5(BUDL),U,1),0)
.W ?71,$$C($P(BUDTAB5(BUDL),U,2),2)
.W !,BUD80L
F BUDL=12:1:14 S BUDY=$O(^BUDFTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,BUDL,".",?6,$P(^BUDFTFIV(BUDY,0),U,2)
.W ?60,$$C($P(BUDTAB5(BUDL),U,1),2)
.W ?71,$$C($P(BUDTAB5(BUDL),U,2),2)
.W !,BUD80L
I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
W !,"15.",?10,"TOTAL MEDICAL CARE SERVICES",!?10,"(TOTAL LINES 8 THROUGH 14)",?60,$$C($P(BUDTAB5(15),U,1)),?71,$$C($P(BUDTAB5(15),U,2)),!,BUD80L
F BUDL=16:1:17 S BUDY=$O(^BUDFTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,BUDL,".",?6,$P(^BUDFTFIV(BUDY,0),U,2)
.W ?60,$$C($P(BUDTAB5(BUDL),U,1),0)
.W ?71,$$C($P(BUDTAB5(BUDL),U,2),2)
.W !,BUD80L
T518 F BUDL=18 S BUDY=$O(^BUDFTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,BUDL,".",?6,$P(^BUDFTFIV(BUDY,0),U,2)
.W ?60,$$C($P(BUDTAB5(BUDL),U,1),2)
.W ?71,$$C($P(BUDTAB5(BUDL),U,2),2)
.W !,BUD80L
I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
W !,"19.",?10,"TOTAL DENTAL SERVICES",!?10,"(TOTAL LINES 16 THROUGH 18)",?60,$$C($P(BUDTAB5(19),U,1)),?71,$$C($P(BUDTAB5(19),U,2)),!,BUD80L
D HEADER Q:BUDQUIT D T5SH ;force page break before line 20
F BUDL="20A","20B","20C" S BUDY=$O(^BUDFTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,BUDL,".",?6,$P(^BUDFTFIV(BUDY,0),U,2)
.I $P(^BUDFTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDFTFIV(BUDY,0),U,3)
.I $P(^BUDFTFIV(BUDY,0),U,4)]"" W !?6,$P(^BUDFTFIV(BUDY,0),U,4)
.W ?60,$$C($P(BUDTAB5(BUDL),U,1),0)
.W ?71,$$C($P(BUDTAB5(BUDL),U,2),2)
.W !,BUD80L
I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
W !,"20.",?10,"MENTAL HEALTH SERVICES",!?10,"(TOTAL LINES 20A + 20B +20C)",?60,$$C($P(BUDTAB5(20),U,1)),?71,$$C($P(BUDTAB5(20),U,2)),!,BUD80L
F BUDL=21:1:22 S BUDY=$O(^BUDFTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,BUDL,".",?6,$P(^BUDFTFIV(BUDY,0),U,2)
.W ?60,$$C($P(BUDTAB5(BUDL),U,1),0)
.W ?71,$$C($P(BUDTAB5(BUDL),U,2),0)
.W !,BUD80L
F BUDL=23 S BUDY=$O(^BUDFTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,BUDL,".",?6,$P(^BUDFTFIV(BUDY,0),U,2)
.W ?60,$$C($P(BUDTAB5(BUDL),U,1),2)
.W ?71,$$C($P(BUDTAB5(BUDL),U,2),2)
.W !,BUD80L
F BUDL=24:1:25 S BUDY=$O(^BUDFTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,BUDL,".",?6,$P(^BUDFTFIV(BUDY,0),U,2)
.W ?60,$$C($P(BUDTAB5(BUDL),U,1),0)
.W ?71,$$C($P(BUDTAB5(BUDL),U,2),2)
.W !,BUD80L
F BUDL=26:1:28 S BUDY=$O(^BUDFTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,BUDL,".",?6,$P(^BUDFTFIV(BUDY,0),U,2)
.W ?60,$$C($P(BUDTAB5(BUDL),U,1),2)
.W ?71,$$C($P(BUDTAB5(BUDL),U,2),2)
.W !,BUD80L
I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
W !,"29.",?10,"TOTAL ENABLING SERVICES",!?10,"(TOTAL LINES 24 THROUGH 28)",?60,$$C($P(BUDTAB5(29),U,1)),?71,$$C($P(BUDTAB5(29),U,2)),!,BUD80L
F BUDL="29A",30,31,32 S BUDY=$O(^BUDFTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,BUDL,".",?6,$P(^BUDFTFIV(BUDY,0),U,2)
.W ?60,$$C($P(BUDTAB5(BUDL),U,1),2)
.W ?71,$$C($P(BUDTAB5(BUDL),U,2),2)
.W !,BUD80L
I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
W !,"33.",?10,"TOTAL ADMINISTRATION AND FACILITY",!?10,"(TOTAL LINES 30+31+32)"
W ?60,$$C($P(BUDTAB5(33),U,1),2),?71,$$C($P(BUDTAB5(33),U,2),2),!,BUD80L
I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
W !,"34.",?10,"GRAND TOTAL: (TOTAL LINES",!?10,"(15+19+20+21+22+23+29+29A+33)"
S Y=0 F X=15,19,20,21,22,29 S Y=Y+$P(BUDTAB5(X),U)
W ?60,$$C(Y),?71,$$C(Y,2),!,BUD80L
I $P(BUDTAB5(35),U) D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !!,$P(BUDTAB5(35),U)," encounters did not fit into any of the above categories",!
Q
T5SH ;
W !,$$CTR("TABLE 5 - STAFFING AND UTILIZATION",80)
;W !,$$CTR("STAFFING AND UTILIZATION",80),!
W !,$TR($J("",80)," ","-")
W !,?54,"FTEs",?60,"ENCOUNTERS",?71," USERS"
W !,"PERSONNEL BY MAJOR SERVICE CATEGORY",?54,"(a)",?64,"(b)",?73,"(c)"
W !,$TR($J("",80)," ","-")
Q
T6 ;
D T6^BUD4RPP1
Q
G:'BUDPG HEADER1
K DIR I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BUDQUIT=1 Q
W:$D(IOF) @IOF S BUDPG=BUDPG+1
S X=$$CTR($P(^DIC(4,BUDSITE,0),U),60),$E(X,3)=$P(^VA(200,DUZ,0),U,2),$E(X,10)="UDS 2004",$E(X,70)="Page ",$E(X,75)=BUDPG W !,X
;W !?3,$P(^VA(200,DUZ,0),U,2),?10,"UDS 2004",$$CTR($P(^DIC(4,BUDSITE,0),U),80),?70,"Page ",BUDPG
;W $$CTR($P(^DIC(4,BUDSITE,0),U),80),!
W !,"UDS No. ",$P(^BUDFSITE(BUDSITE,0),U,2),?50,"Date Run: ",$$FMTE^XLFDT(DT)
W !,"Reporting Period: ",$$FMTE^XLFDT(BUDBD)," through ",$$FMTE^XLFDT(BUDED)
W !
Q
C(X,Y) ;
I $G(Y)=1,+X=0 Q ""
I $G(Y)=2 Q "********"
S X2=0,X3=8
D COMMA^%DTC
Q X
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
USR() ;EP - Return name of current user from ^VA(200.
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;----------
BUD4RPTP ; IHS/CMI/LAB - UDS REPORT PRINT ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
PRINT ;EP
+1 SET BUDPG=0
+2 SET BUDQUIT=0
+3 SET BUD80L=""
SET $PIECE(BUD80L,"_",79)="_"
+4 IF $GET(BUDT3A)
DO T3A
IF BUDQUIT
GOTO EOJ
+5 IF $GET(BUDT3B)
DO T3B
IF BUDQUIT
GOTO EOJ
+6 IF $GET(BUDT4)
DO T4
IF BUDQUIT
GOTO EOJ
+7 IF $GET(BUDT5)
DO T5
IF BUDQUIT
GOTO EOJ
+8 IF $GET(BUDT6)
DO T6
IF BUDQUIT
GOTO EOJ
+9 DO PATLISTS
+10 DO EOJ
+11 QUIT
+12 ;
EOJ ;
+1 KILL ^TMP($JOB)
+2 KILL ^XTMP("BUD4RPT1",BUDJ,BUDH)
+3 QUIT
T4 ;
+1 QUIT
T3A ;
+1 DO HEADER
IF BUDQUIT
QUIT
DO T3ASH
+2 ;print out each line
+3 SET BUDC=3
FOR
SET BUDC=$ORDER(^BUDFTTA("B",BUDC))
IF BUDC'=+BUDC!(BUDQUIT)
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T3ASH
+5 SET BUDY=^BUDFTTA(BUDC,0)
+6 ;column one and control
SET BUDX=$PIECE(BUDY,U,2)
+7 WRITE !
+8 IF BUDX<10
WRITE " "
+9 WRITE $PIECE(BUDY,U,2),?5,$PIECE(BUDY,U,3)
+10 ;I +BUDX=0 Q
+11 WRITE ?35,$$C($PIECE(BUDTOT("M"),U,BUDX)),?50,$$C($PIECE(BUDTOT("F"),U,BUDX)),?68,$$C($PIECE(BUDTOT("ALL"),U,BUDX))
+12 IF BUDX=20
Begin DoDot:2
+13 IF $Y>(IOSL-4)
DO HEADER
IF BUDQUIT
QUIT
DO T3ASH
+14 WRITE !!?10,"SUBTOTAL 0-19",?35,$$C(BUD019("M")),?50,$$C(BUD019("F")),?68,$$C(BUD019("ALL")),!
End DoDot:2
End DoDot:1
+15 QUIT
T3ASH ;
+1 WRITE !,$$CTR($GET(^BUDFTTA(1,11)),80),!
+2 FOR X=2:1:3
WRITE !,$PIECE(^BUDFTTA(X,0),U,2),?5,$PIECE(^BUDFTTA(X,0),U,3),?33,$PIECE(^BUDFTTA(X,0),U,4),?50,$PIECE(^BUDFTTA(X,0),U,5),?68,$PIECE(^BUDFTTA(X,0),U,6)
+3 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-"),!
+4 QUIT
T3BSH ;
+1 WRITE !!,$$CTR("TABLE 3B -",80)
+2 WRITE !,$$CTR("USERS BY RACE/ETHNICITY/LANGUAGE",80),!
+3 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+4 WRITE !,"RACE/ETHNICITY/LANGUAGE",?65,"NUMBER (a)"
+5 WRITE !,"PROPORTION OF USERS"
+6 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+7 QUIT
PATLISTS ;
+1 DO ^BUD4RPTL
+2 QUIT
T3B ;
+1 DO HEADER
IF BUDQUIT
QUIT
DO T3BSH
+2 ;print out each line
+3 WRITE !?3,"1a.",?8,"Asian",?65,$$C(BUDRACET("1A")),!,BUD80L
+4 WRITE !?3,"1b.",?8,"Native Hawaiian",?65,$$C(BUDRACET("1B")),!,BUD80L
+5 WRITE !?3,"1c.",?8,"Other Pacific Islander",?65,$$C(BUDRACET("1C")),!,BUD80L
+6 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T3BSH
+7 WRITE !,"1.",?13,"Asian/Pacific Islander (sum lines 1a+1b+1c)",?65,$$C(BUDRACET("1A")+BUDRACET("1B")+BUDRACET("1C")),!,BUD80L
+8 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T3BSH
+9 WRITE !,"2.",?8,"Black/African American (not Hispanic or Latino)",?65,$$C(BUDRACET(2)),!,BUD80L
+10 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T3BSH
+11 WRITE !,"3.",?8,"American Indian/Alaska Native",?65,$$C(BUDRACET(3)),!,BUD80L
+12 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T3BSH
+13 WRITE !,"4.",?8,"White (not Hispanic or Latino)",?65,$$C(BUDRACET(4)),!,BUD80L
+14 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T3BSH
+15 WRITE !,"5.",?8,"Hispanic or Latino (all races)",?65,$$C(BUDRACET(5)),!,BUD80L
+16 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T3BSH
+17 WRITE !,"6.",?8,"Unreported / Refused to Report",?65,$$C(BUDRACET(6)),!,BUD80L
+18 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T3BSH
+19 SET Y=0
FOR X="1A","1B","1C",1,2,3,4,5,6
SET Y=Y+$GET(BUDRACET(X))
+20 WRITE !,"7.",?12,"TOTAL USERS (SUM LINES 1-6)",?65,$$C(Y),!,BUD80L
+21 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T3BSH
+22 WRITE !,"8.",?8,"Users needing interpretation/Bilingual/Sign Language Services",!,BUD80L
+23 QUIT
T5 ;print table 5
+1 DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+2 ;lines 1-8
+3 FOR BUDL=1:1:7
SET BUDY=$ORDER(^BUDFTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+4 IF 'BUDY
QUIT
+5 WRITE !
+6 IF +BUDL<10
WRITE " "
+7 WRITE BUDL,".",?6,$PIECE(^BUDFTFIV(BUDY,0),U,2)
+8 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),0)
+9 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+10 WRITE !,BUD80L
End DoDot:1
+11 WRITE !," 8.",?10,"TOTAL PHYSICIANS",!?8,"(Total Lines 1 through 7)",?60,$$C($PIECE(BUDTAB5(8),U,1)),?71,$$C($PIECE(BUDTAB5(8),U,2),2),!,BUD80L
+12 ;print out lines 9-15
+13 FOR BUDL="9A","9B",10:1:11
SET BUDY=$ORDER(^BUDFTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+14 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+15 WRITE !
+16 IF +BUDL<10
WRITE " "
+17 WRITE BUDL,".",?6,$PIECE(^BUDFTFIV(BUDY,0),U,2)
+18 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),0)
+19 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+20 WRITE !,BUD80L
End DoDot:1
+21 FOR BUDL=12:1:14
SET BUDY=$ORDER(^BUDFTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+22 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+23 WRITE !,BUDL,".",?6,$PIECE(^BUDFTFIV(BUDY,0),U,2)
+24 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),2)
+25 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+26 WRITE !,BUD80L
End DoDot:1
+27 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+28 WRITE !,"15.",?10,"TOTAL MEDICAL CARE SERVICES",!?10,"(TOTAL LINES 8 THROUGH 14)",?60,$$C($PIECE(BUDTAB5(15),U,1)),?71,$$C($PIECE(BUDTAB5(15),U,2)),!,BUD80L
+29 FOR BUDL=16:1:17
SET BUDY=$ORDER(^BUDFTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+30 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+31 WRITE !,BUDL,".",?6,$PIECE(^BUDFTFIV(BUDY,0),U,2)
+32 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),0)
+33 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+34 WRITE !,BUD80L
End DoDot:1
T518 FOR BUDL=18
SET BUDY=$ORDER(^BUDFTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+1 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+2 WRITE !,BUDL,".",?6,$PIECE(^BUDFTFIV(BUDY,0),U,2)
+3 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),2)
+4 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+5 WRITE !,BUD80L
End DoDot:1
+6 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+7 WRITE !,"19.",?10,"TOTAL DENTAL SERVICES",!?10,"(TOTAL LINES 16 THROUGH 18)",?60,$$C($PIECE(BUDTAB5(19),U,1)),?71,$$C($PIECE(BUDTAB5(19),U,2)),!,BUD80L
+8 ;force page break before line 20
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+9 FOR BUDL="20A","20B","20C"
SET BUDY=$ORDER(^BUDFTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+10 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+11 WRITE !,BUDL,".",?6,$PIECE(^BUDFTFIV(BUDY,0),U,2)
+12 IF $PIECE(^BUDFTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDFTFIV(BUDY,0),U,3)
+13 IF $PIECE(^BUDFTFIV(BUDY,0),U,4)]""
WRITE !?6,$PIECE(^BUDFTFIV(BUDY,0),U,4)
+14 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),0)
+15 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+16 WRITE !,BUD80L
End DoDot:1
+17 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+18 WRITE !,"20.",?10,"MENTAL HEALTH SERVICES",!?10,"(TOTAL LINES 20A + 20B +20C)",?60,$$C($PIECE(BUDTAB5(20),U,1)),?71,$$C($PIECE(BUDTAB5(20),U,2)),!,BUD80L
+19 FOR BUDL=21:1:22
SET BUDY=$ORDER(^BUDFTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+20 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+21 WRITE !,BUDL,".",?6,$PIECE(^BUDFTFIV(BUDY,0),U,2)
+22 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),0)
+23 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),0)
+24 WRITE !,BUD80L
End DoDot:1
+25 FOR BUDL=23
SET BUDY=$ORDER(^BUDFTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+26 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+27 WRITE !,BUDL,".",?6,$PIECE(^BUDFTFIV(BUDY,0),U,2)
+28 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),2)
+29 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+30 WRITE !,BUD80L
End DoDot:1
+31 FOR BUDL=24:1:25
SET BUDY=$ORDER(^BUDFTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+32 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+33 WRITE !,BUDL,".",?6,$PIECE(^BUDFTFIV(BUDY,0),U,2)
+34 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),0)
+35 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+36 WRITE !,BUD80L
End DoDot:1
+37 FOR BUDL=26:1:28
SET BUDY=$ORDER(^BUDFTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+38 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+39 WRITE !,BUDL,".",?6,$PIECE(^BUDFTFIV(BUDY,0),U,2)
+40 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),2)
+41 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+42 WRITE !,BUD80L
End DoDot:1
+43 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+44 WRITE !,"29.",?10,"TOTAL ENABLING SERVICES",!?10,"(TOTAL LINES 24 THROUGH 28)",?60,$$C($PIECE(BUDTAB5(29),U,1)),?71,$$C($PIECE(BUDTAB5(29),U,2)),!,BUD80L
+45 FOR BUDL="29A",30,31,32
SET BUDY=$ORDER(^BUDFTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+46 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+47 WRITE !,BUDL,".",?6,$PIECE(^BUDFTFIV(BUDY,0),U,2)
+48 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),2)
+49 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+50 WRITE !,BUD80L
End DoDot:1
+51 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+52 WRITE !,"33.",?10,"TOTAL ADMINISTRATION AND FACILITY",!?10,"(TOTAL LINES 30+31+32)"
+53 WRITE ?60,$$C($PIECE(BUDTAB5(33),U,1),2),?71,$$C($PIECE(BUDTAB5(33),U,2),2),!,BUD80L
+54 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+55 WRITE !,"34.",?10,"GRAND TOTAL: (TOTAL LINES",!?10,"(15+19+20+21+22+23+29+29A+33)"
+56 SET Y=0
FOR X=15,19,20,21,22,29
SET Y=Y+$PIECE(BUDTAB5(X),U)
+57 WRITE ?60,$$C(Y),?71,$$C(Y,2),!,BUD80L
+58 IF $PIECE(BUDTAB5(35),U)
Begin DoDot:1
+59 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+60 WRITE !!,$PIECE(BUDTAB5(35),U)," encounters did not fit into any of the above categories",!
End DoDot:1
+61 QUIT
T5SH ;
+1 WRITE !,$$CTR("TABLE 5 - STAFFING AND UTILIZATION",80)
+2 ;W !,$$CTR("STAFFING AND UTILIZATION",80),!
+3 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+4 WRITE !,?54,"FTEs",?60,"ENCOUNTERS",?71," USERS"
+5 WRITE !,"PERSONNEL BY MAJOR SERVICE CATEGORY",?54,"(a)",?64,"(b)",?73,"(c)"
+6 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+7 QUIT
T6 ;
+1 DO T6^BUD4RPP1
+2 QUIT
+1 IF 'BUDPG
GOTO HEADER1
+2 KILL DIR
IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET BUDQUIT=1
QUIT
+1 IF $DATA(IOF)
WRITE @IOF
SET BUDPG=BUDPG+1
+2 SET X=$$CTR($PIECE(^DIC(4,BUDSITE,0),U),60)
SET $EXTRACT(X,3)=$PIECE(^VA(200,DUZ,0),U,2)
SET $EXTRACT(X,10)="UDS 2004"
SET $EXTRACT(X,70)="Page "
SET $EXTRACT(X,75)=BUDPG
WRITE !,X
+3 ;W !?3,$P(^VA(200,DUZ,0),U,2),?10,"UDS 2004",$$CTR($P(^DIC(4,BUDSITE,0),U),80),?70,"Page ",BUDPG
+4 ;W $$CTR($P(^DIC(4,BUDSITE,0),U),80),!
+5 WRITE !,"UDS No. ",$PIECE(^BUDFSITE(BUDSITE,0),U,2),?50,"Date Run: ",$$FMTE^XLFDT(DT)
+6 WRITE !,"Reporting Period: ",$$FMTE^XLFDT(BUDBD)," through ",$$FMTE^XLFDT(BUDED)
+7 WRITE !
+8 QUIT
C(X,Y) ;
+1 IF $GET(Y)=1
IF +X=0
QUIT ""
+2 IF $GET(Y)=2
QUIT "********"
+3 SET X2=0
SET X3=8
+4 DO COMMA^%DTC
+5 QUIT X
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
USR() ;EP - Return name of current user from ^VA(200.
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
+1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
+2 ;----------
