BUD0RPTP ; IHS/CMI/LAB - UDS REPORT PRINT 30 Dec 2010 10:44 AM 22 Oct 2010 12:16 PM ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
PRINT ;EP
S BUDPG=0,BUDTPG=0
S BUDQUIT=0
S BUD80L="",$P(BUD80L,"_",79)="_"
I $G(BUDTZ) D TZ G:BUDQUIT EOJ
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
I $G(BUDT6B) D T6B G:BUDQUIT EOJ
I $G(BUDT7) D T7 G:BUDQUIT EOJ
D PATLISTS
D EOJ
Q
;
EOJ ;
K ^TMP($J)
K ^XTMP("BUD0RPT1",BUDJ,BUDH)
Q
T4 ;
Q
T3A ;
I $G(BUDSTMP) D STEMP^BUD0RPTS
S BUDPG=0
D HEADER Q:BUDQUIT D T3ASH
;print out each line
S BUDZ=0 F S BUDZ=$O(^BUDTTTA("AC",BUDZ)) Q:BUDZ>38!(BUDQUIT) D
.S BUDC=$O(^BUDTTTA("AC",BUDZ,0))
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T3ASH
.S BUDY=^BUDTTTA(BUDC,0)
.S BUDX=$P(BUDY,U,2) ;column one End 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")),!
S BUDC=$O(^BUDTTTA("B",43,0))
I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T3ASH
W !,$P(^BUDTTTA(BUDC,0),U,2),?5,$P(^BUDTTTA(BUDC,0),U,3)
S BUDC=$O(^BUDTTTA("AC",39,0))
I $Y>(IOSL-2) D HEADER Q:BUDQUIT D T3ASH
S BUDY=^BUDTTTA(BUDC,0)
S BUDX=$P(BUDY,U,2) ;column one End control
W !
W $P(BUDY,U,2),?5,$P(BUDY,U,3)
W ?35,$$C($P(BUDTOT("M"),U,BUDX)),?50,$$C($P(BUDTOT("F"),U,BUDX)),?68,$$C($P(BUDTOT("ALL"),U,BUDX))
W !
Q
T3ASH ;
W !,$$CTR($G(^BUDTTTA(1,11)),80),!
F Y=2:1:4 S X=$O(^BUDTTTA("B",Y,0)) W !,$P(^BUDTTTA(X,0),U,2),?5,$P(^BUDTTTA(X,0),U,3),?33,$P(^BUDTTTA(X,0),U,4),?50,$P(^BUDTTTA(X,0),U,5),?68,$P(^BUDTTTA(X,0),U,6)
W !,$TR($J("",80)," ","-")
Q
T3BSH ;
W !!,$$CTR("TABLE 3B -",80)
W !,$$CTR("PATIENTS BY HISPANIC OR LATINO IDENTITY/RACE/LANGUAGE",80),!,BUD80L
;W !!,BUD80L
Q:$G(BUDLANG)
W !?41,"NOT",?53,"UNREPORTED/"
W !?25,"HISPANIC/",?39,"HISPANIC/",?53,"REFUSED TO",?70,"TOTAL"
W !?3,"PATIENTS BY RACE",?26,"LATINO",?40,"LATINO",?54,"REPORT",?70,"(d)"
W !?28,"(a)",?41,"(b)",?56,"(c)"
W !,BUD80L
W !,"NUMBER OF PATIENTS",!,BUD80L
Q
TZSH ;
W !!,$$CTR("PATIENTS BY ZIP CODE",80)
W !,$TR($J("",80)," ","-")
W !!?5,"ZIP CODE",?40,"PATIENTS"
W !,$TR($J("",80)," ","-")
Q
PATLISTS ;
D ^BUD0RPTL
Q
T3B ;
S BUDPG=0
D HEADER Q:BUDQUIT D T3BSH
;print out each line
;
I $Y>(IOSL-6) D HEADER Q:BUDQUIT D T3BSH
F BUDX="1","2A","2B","2",3,4,5,6,7,8 Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T3BSH
.W !?2,$P(BUDRACET(BUDX),U),?6,$P(BUDRACET(BUDX),U,2)
.I $P(BUDRACET(BUDX),U,7)]"" W !?6,$P(BUDRACET(BUDX),U,7)
.I $P(BUDRACET(BUDX),U,8)]"" W !?6,$P(BUDRACET(BUDX),U,8)
.I $P(BUDRACET(BUDX),U,3)]"" W ?25,$$C($P(BUDRACET(BUDX),U,3))
.I $P(BUDRACET(BUDX),U,4)]"" W ?39,$$C($P(BUDRACET(BUDX),U,4))
.I $P(BUDRACET(BUDX),U,5)]"" W ?53,$$C($P(BUDRACET(BUDX),U,5))
.I $P(BUDRACET(BUDX),U,6)]"" W ?67,$$C($P(BUDRACET(BUDX),U,6))
.W !,BUD80L
S BUDLANG=1
I $Y>(IOSL-6) D HEADER Q:BUDQUIT D T3BSH
W !!,BUD80L,!?66,"NUMBER"
W !,"PATIENTS BY LANGUAGE",?67,"(a)",!,BUD80L
W !,"NUMBER OF PATIENTS",!,BUD80L
W !?2,"9",?8,"PATIENTS BEST SERVED IN A LANGUAGE OTHER THAN ",!?2,"ENGLISH",!,BUD80L
W !
K BUDLANG
Q
TZ ;
D HEADER Q:BUDQUIT D TZSH
;print out each line
S BUDZTOT=0
S ^XTMP("BUD0RPT1",BUDJ,BUDH,"ZIP","OTHER ZIP CODES")=0
;GET TOTAL
S BUDZ="" F S BUDZ=$O(^XTMP("BUD0RPT1",BUDJ,BUDH,"ZIP",BUDZ)) Q:BUDZ="" D
.S BUDY=^XTMP("BUD0RPT1",BUDJ,BUDH,"ZIP",BUDZ)
.S BUDZTOT=BUDZTOT+BUDY
;CALCULATE "OTHER"
S BUDZ="" F S BUDZ=$O(^XTMP("BUD0RPT1",BUDJ,BUDH,"ZIP",BUDZ)) Q:BUDZ="" D
.Q:BUDZ["OTHER"
.Q:BUDZ["Unknown"
.S BUDY=^XTMP("BUD0RPT1",BUDJ,BUDH,"ZIP",BUDZ)
.S X=BUDY/BUDZTOT I X<.001 K ^XTMP("BUD0RPT1",BUDJ,BUDH,"ZIP",BUDZ) S ^XTMP("BUD0RPT1",BUDJ,BUDH,"ZIP","OTHER ZIP CODES")=^XTMP("BUD0RPT1",BUDJ,BUDH,"ZIP","OTHER ZIP CODES")+BUDY D
..;now reset the list so the others collate at the end
..S BUDCOM="" F S BUDCOM=$O(^XTMP("BUD0RPT1",BUDJ,BUDH,"Z",BUDZ,BUDCOM)) Q:BUDCOM="" D
...S BUDSEX="" F S BUDSEX=$O(^XTMP("BUD0RPT1",BUDJ,BUDH,"Z",BUDZ,BUDCOM,BUDSEX)) Q:BUDSEX="" D
....S BUDNAME="" F S BUDNAME=$O(^XTMP("BUD0RPT1",BUDJ,BUDH,"Z",BUDZ,BUDCOM,BUDSEX,BUDNAME)) Q:BUDNAME="" D
.....S DFN=0 F S DFN=$O(^XTMP("BUD0RPT1",BUDJ,BUDH,"Z",BUDZ,BUDCOM,BUDSEX,BUDNAME,DFN)) Q:DFN'=+DFN D
......S X=0 F S X=$O(^XTMP("BUD0RPT1",BUDJ,BUDH,"Z",BUDZ,BUDCOM,BUDSEX,BUDNAME,DFN,X)) Q:X'=+X D
.......S ^XTMP("BUD0RPT1",BUDJ,BUDH,"Z",BUDZ_"*",BUDCOM,BUDSEX,BUDNAME,DFN,X)=""
.......K ^XTMP("BUD0RPT1",BUDJ,BUDH,"Z",BUDZ,BUDCOM,BUDSEX,BUDNAME,DFN,X)
S BUDZ="" F S BUDZ=$O(^XTMP("BUD0RPT1",BUDJ,BUDH,"ZIP",BUDZ)) Q:BUDZ=""!(BUDQUIT) D
.I $Y>(IOSL-4) D HEADER Q:BUDQUIT D TZSH
.S BUDY=^XTMP("BUD0RPT1",BUDJ,BUDH,"ZIP",BUDZ)
.W !?8,BUDZ,?40,$$C(BUDY),!,BUD80L
Q:BUDQUIT
W !!?8,"TOTAL",?40,$$C(BUDZTOT),!
Q
T5 ;print table 5
S BUDPG=0 D HEADER Q:BUDQUIT D T5SH
;lines 1-8
F BUDL=1:1:7 S BUDY=$O(^BUDTTFIV("B",BUDL,0)) Q:BUDQUIT D
.Q:'BUDY
.W !
.I +BUDL<10 W " "
.W BUDL,".",?6,$P(^BUDTTFIV(BUDY,0),U,2)
.I $P(^BUDTTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDTTFIV(BUDY,0),U,3)
.I $P($G(BUDTAB5(BUDL)),U,1)]"" W ?60,$$C($P(BUDTAB5(BUDL),U,1),$S(BUDL=6:2,1:0)),?71,$$C($P(BUDTAB5(BUDL),U,2),2)
.W !,BUD80L
W !," 8.",?10,"Total Physicians",!?8,"(Lines 1 - 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 S BUDY=$O(^BUDTTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !
.I +BUDL<10 W " "
.W $$LOW^XLFSTR(BUDL),".",?6,$P(^BUDTTFIV(BUDY,0),U,2)
.I $P(^BUDTTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDTTFIV(BUDY,0),U,3)
.W ?60,$$C($P(BUDTAB5(BUDL),U,1),0)
.W ?71,$$C($P(BUDTAB5(BUDL),U,2),2)
.W !,BUD80L
W !,"10a.",?10,"Total Midlevel Practitioners",!?8,"(Lines 9a - 10)",?60,$$C($P(BUDTAB5("10A"),U,1)),?71,$$C($P(BUDTAB5("10A"),U,2),2),!,BUD80L
F BUDL=11:1:14 S BUDY=$O(^BUDTTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,$$LOW^XLFSTR(BUDL),".",?6,$P(^BUDTTFIV(BUDY,0),U,2) I $P(^BUDTTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDTTFIV(BUDY,0),U,3)
.W ?60,$$C($P(BUDTAB5(BUDL),U,1),$S(BUDL=11:0,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",!?10,"(Lines 8 + 10a 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(^BUDTTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,$$LOW^XLFSTR(BUDL),".",?6,$P(^BUDTTFIV(BUDY,0),U,2) I $P(^BUDTTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDTTFIV(BUDY,0),U,3)
.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(^BUDTTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,$$LOW^XLFSTR(BUDL),".",?6,$P(^BUDTTFIV(BUDY,0),U,2) I $P(^BUDTTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDTTFIV(BUDY,0),U,3)
.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,"(Lines 16 - 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","20A1","20A2","20B","20C" S BUDY=$O(^BUDTTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,$$LOW^XLFSTR(BUDL),".",?6,$P(^BUDTTFIV(BUDY,0),U,2)
.I $P(^BUDTTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDTTFIV(BUDY,0),U,3)
.I $P(^BUDTTFIV(BUDY,0),U,4)]"" W !?6,$P(^BUDTTFIV(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,"(Lines 20a - c)",?60,$$C($P(BUDTAB5(20),U,1)),?71,$$C($P(BUDTAB5(20),U,2)),!,BUD80L
F BUDL=21 S BUDY=$O(^BUDTTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,$$LOW^XLFSTR(BUDL),".",?6,$P(^BUDTTFIV(BUDY,0),U,2) I $P(^BUDTTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDTTFIV(BUDY,0),U,3)
.W ?60,$$C($P(BUDTAB5(BUDL),U,1),0)
.W ?71,$$C($P(BUDTAB5(BUDL),U,2),0)
.W !,BUD80L
F BUDL=22 S BUDY=$O(^BUDTTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,$$LOW^XLFSTR(BUDL),".",?8,$P(^BUDTTFIV(BUDY,0),U,2) I $P(^BUDTTFIV(BUDY,0),U,3)]"" W !?8,$P(^BUDTTFIV(BUDY,0),U,3)
.W ?60,$$C($P(BUDTAB5(BUDL),U,1),0)
.W ?71,$$C($P(BUDTAB5(BUDL),U,2),0)
.W !,BUD80L
F BUDL="22A","22B","22C" S BUDY=$O(^BUDTTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,$$LOW^XLFSTR(BUDL),".",?6,$P(^BUDTTFIV(BUDY,0),U,2)
.I $P(^BUDTTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDTTFIV(BUDY,0),U,3)
.I $P(^BUDTTFIV(BUDY,0),U,4)]"" W !?6,$P(^BUDTTFIV(BUDY,0),U,4)
.I BUDL'="22C" W ?60,$$C($P(BUDTAB5(BUDL),U,1),1)
.I BUDL="22C" W ?60,$$C($P(BUDTAB5(BUDL),U,1),2)
.W ?71,$$C($P(BUDTAB5(BUDL),U,2),2)
.W !,BUD80L
W !,"22d.",?10,"Total Vision Services",!?10,"(Lines 22a-c)",?60,$$C($P(BUDTAB5("22D"),U,1)),?71,$$C($P(BUDTAB5("22D"),U,2)),!,BUD80L
F BUDL=23 S BUDY=$O(^BUDTTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,$$LOW^XLFSTR(BUDL),".",?6,$P(^BUDTTFIV(BUDY,0),U,2) I $P(^BUDTTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDTTFIV(BUDY,0),U,3)
.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(^BUDTTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,$$LOW^XLFSTR(BUDL),".",?6,$P(^BUDTTFIV(BUDY,0),U,2) I $P(^BUDTTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDTTFIV(BUDY,0),U,3)
.W ?60,$$C($P(BUDTAB5(BUDL),U,1),0)
.W ?71,$$C($P(BUDTAB5(BUDL),U,2),2)
.W !,BUD80L
F BUDL=26,27,"27a","27b",28 S BUDY=$O(^BUDTTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,$$LOW^XLFSTR(BUDL),".",?6,$P(^BUDTTFIV(BUDY,0),U,2) I $P(^BUDTTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDTTFIV(BUDY,0),U,3)
.W ?60,$$C($P(BUDTAB5(BUDL),U,1),2),?71,$$C($P(BUDTAB5(BUDL),U,2),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,"(Lines 24 - 28)",?60,$$C($P(BUDTAB5(29),U,1)),?71,$$C($P(BUDTAB5(29),U,2)),!,BUD80L
I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
W !,"29a.",?10,"Other Programs/ Services",!?10,"(specify__)",?60,$$C($P(BUDTAB5(29),U,1),2),?71,$$C($P(BUDTAB5(29),U,2),2),!,BUD80L
F BUDL="30A","30B","30C" S BUDY=$O(^BUDTTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,$$LOW^XLFSTR(BUDL),".",?6,$P(^BUDTTFIV(BUDY,0),U,2) I $P(^BUDTTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDTTFIV(BUDY,0),U,3)
.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 !,"30.",?10,"Total Administrative Staff",!?10,"(Lines 30a-30c)"
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
F BUDL=31,32 S BUDY=$O(^BUDTTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,$$LOW^XLFSTR(BUDL),".",?6,$P(^BUDTTFIV(BUDY,0),U,2) I $P(^BUDTTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDTTFIV(BUDY,0),U,3)
.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,"Total (Lines ",!?10,"15+19+20+21+22+22d+23+29+29a+33)"
S Y=0 F X=15,19,20,21,22,"22D",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)," visits did not fit into any of the above categories",!
W !
Q
T5SH ;
W !,$$CTR("TABLE 5 - STAFFING AND UTILIZATION",80)
;W !,$$CTR("STAFFING AND UTILIZATION",80),!
W !,$TR($J("",80)," ","-")
W !,?54,"FTEs",?60,"CLINIC",?71,"PATIENTS"
W !?60,"VISITS"
W !,"PERSONNEL BY MAJOR SERVICE CATEGORY",?54,"(a)",?64,"(b)",?73,"(c)"
W !,$TR($J("",80)," ","-")
Q
T6 ;
D T6^BUD0RPP1
Q
T6B ;
D PRINT^BUD0RP6B
Q
T7 ;
D PRINT^BUD0RP7
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
I $G(BUDTPG)=0 G HEADER2
;I BUDPG=0,'$G(BUDFNP) G HEADER2
I $G(BUDTPG)!($G(BUDFNP)) W:$D(IOF) @IOF
;W:$D(IOF) @IOF
S X=$$CTR($P(^DIC(4,BUDSITE,0),U),60),$E(X,3)=$P(^VA(200,DUZ,0),U,2),$E(X,10)="UDS 2010",$E(X,70)="Page ",$E(X,75)=BUDPG W !,X
;W !?3,$P(^VA(200,DUZ,0),U,2),?10,"UDS 2010",$$CTR($P(^DIC(4,BUDSITE,0),U),80),?70,"Page ",BUDPG
;W $$CTR($P(^DIC(4,BUDSITE,0),U),80),!
W !,"UDS No. ",$P(^BUDTSITE(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")
;----------
BUD0RPTP ; IHS/CMI/LAB - UDS REPORT PRINT 30 Dec 2010 10:44 AM 22 Oct 2010 12:16 PM ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
PRINT ;EP
+1 SET BUDPG=0
SET BUDTPG=0
+2 SET BUDQUIT=0
+3 SET BUD80L=""
SET $PIECE(BUD80L,"_",79)="_"
+4 IF $GET(BUDTZ)
DO TZ
IF BUDQUIT
GOTO EOJ
+5 IF $GET(BUDT3A)
DO T3A
IF BUDQUIT
GOTO EOJ
+6 IF $GET(BUDT3B)
DO T3B
IF BUDQUIT
GOTO EOJ
+7 IF $GET(BUDT4)
DO T4
IF BUDQUIT
GOTO EOJ
+8 IF $GET(BUDT5)
DO T5
IF BUDQUIT
GOTO EOJ
+9 IF $GET(BUDT6)
DO T6
IF BUDQUIT
GOTO EOJ
+10 IF $GET(BUDT6B)
DO T6B
IF BUDQUIT
GOTO EOJ
+11 IF $GET(BUDT7)
DO T7
IF BUDQUIT
GOTO EOJ
+12 DO PATLISTS
+13 DO EOJ
+14 QUIT
+15 ;
EOJ ;
+1 KILL ^TMP($JOB)
+2 KILL ^XTMP("BUD0RPT1",BUDJ,BUDH)
+3 QUIT
T4 ;
+1 QUIT
T3A ;
+1 IF $GET(BUDSTMP)
DO STEMP^BUD0RPTS
+2 SET BUDPG=0
+3 DO HEADER
IF BUDQUIT
QUIT
DO T3ASH
+4 ;print out each line
+5 SET BUDZ=0
FOR
SET BUDZ=$ORDER(^BUDTTTA("AC",BUDZ))
IF BUDZ>38!(BUDQUIT)
QUIT
Begin DoDot:1
+6 SET BUDC=$ORDER(^BUDTTTA("AC",BUDZ,0))
+7 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T3ASH
+8 SET BUDY=^BUDTTTA(BUDC,0)
+9 ;column one End control
SET BUDX=$PIECE(BUDY,U,2)
+10 WRITE !
+11 IF BUDX<10
WRITE " "
+12 WRITE $PIECE(BUDY,U,2),?5,$PIECE(BUDY,U,3)
+13 ;I +BUDX=0 Q
+14 WRITE ?35,$$C($PIECE(BUDTOT("M"),U,BUDX)),?50,$$C($PIECE(BUDTOT("F"),U,BUDX)),?68,$$C($PIECE(BUDTOT("ALL"),U,BUDX))
+15 IF BUDX=20
Begin DoDot:2
+16 IF $Y>(IOSL-4)
DO HEADER
IF BUDQUIT
QUIT
DO T3ASH
+17 WRITE !!?10,"SUBTOTAL 0-19",?35,$$C(BUD019("M")),?50,$$C(BUD019("F")),?68,$$C(BUD019("ALL")),!
End DoDot:2
End DoDot:1
+18 SET BUDC=$ORDER(^BUDTTTA("B",43,0))
+19 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T3ASH
+20 WRITE !,$PIECE(^BUDTTTA(BUDC,0),U,2),?5,$PIECE(^BUDTTTA(BUDC,0),U,3)
+21 SET BUDC=$ORDER(^BUDTTTA("AC",39,0))
+22 IF $Y>(IOSL-2)
DO HEADER
IF BUDQUIT
QUIT
DO T3ASH
+23 SET BUDY=^BUDTTTA(BUDC,0)
+24 ;column one End control
SET BUDX=$PIECE(BUDY,U,2)
+25 WRITE !
+26 WRITE $PIECE(BUDY,U,2),?5,$PIECE(BUDY,U,3)
+27 WRITE ?35,$$C($PIECE(BUDTOT("M"),U,BUDX)),?50,$$C($PIECE(BUDTOT("F"),U,BUDX)),?68,$$C($PIECE(BUDTOT("ALL"),U,BUDX))
+28 WRITE !
+29 QUIT
T3ASH ;
+1 WRITE !,$$CTR($GET(^BUDTTTA(1,11)),80),!
+2 FOR Y=2:1:4
SET X=$ORDER(^BUDTTTA("B",Y,0))
WRITE !,$PIECE(^BUDTTTA(X,0),U,2),?5,$PIECE(^BUDTTTA(X,0),U,3),?33,$PIECE(^BUDTTTA(X,0),U,4),?50,$PIECE(^BUDTTTA(X,0),U,5),?68,$PIECE(^BUDTTTA(X,0),U,6)
+3 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+4 QUIT
T3BSH ;
+1 WRITE !!,$$CTR("TABLE 3B -",80)
+2 WRITE !,$$CTR("PATIENTS BY HISPANIC OR LATINO IDENTITY/RACE/LANGUAGE",80),!,BUD80L
+3 ;W !!,BUD80L
+4 IF $GET(BUDLANG)
QUIT
+5 WRITE !?41,"NOT",?53,"UNREPORTED/"
+6 WRITE !?25,"HISPANIC/",?39,"HISPANIC/",?53,"REFUSED TO",?70,"TOTAL"
+7 WRITE !?3,"PATIENTS BY RACE",?26,"LATINO",?40,"LATINO",?54,"REPORT",?70,"(d)"
+8 WRITE !?28,"(a)",?41,"(b)",?56,"(c)"
+9 WRITE !,BUD80L
+10 WRITE !,"NUMBER OF PATIENTS",!,BUD80L
+11 QUIT
TZSH ;
+1 WRITE !!,$$CTR("PATIENTS BY ZIP CODE",80)
+2 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+3 WRITE !!?5,"ZIP CODE",?40,"PATIENTS"
+4 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+5 QUIT
PATLISTS ;
+1 DO ^BUD0RPTL
+2 QUIT
T3B ;
+1 SET BUDPG=0
+2 DO HEADER
IF BUDQUIT
QUIT
DO T3BSH
+3 ;print out each line
+4 ;
+5 IF $Y>(IOSL-6)
DO HEADER
IF BUDQUIT
QUIT
DO T3BSH
+6 FOR BUDX="1","2A","2B","2",3,4,5,6,7,8
IF BUDQUIT
QUIT
Begin DoDot:1
+7 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T3BSH
+8 WRITE !?2,$PIECE(BUDRACET(BUDX),U),?6,$PIECE(BUDRACET(BUDX),U,2)
+9 IF $PIECE(BUDRACET(BUDX),U,7)]""
WRITE !?6,$PIECE(BUDRACET(BUDX),U,7)
+10 IF $PIECE(BUDRACET(BUDX),U,8)]""
WRITE !?6,$PIECE(BUDRACET(BUDX),U,8)
+11 IF $PIECE(BUDRACET(BUDX),U,3)]""
WRITE ?25,$$C($PIECE(BUDRACET(BUDX),U,3))
+12 IF $PIECE(BUDRACET(BUDX),U,4)]""
WRITE ?39,$$C($PIECE(BUDRACET(BUDX),U,4))
+13 IF $PIECE(BUDRACET(BUDX),U,5)]""
WRITE ?53,$$C($PIECE(BUDRACET(BUDX),U,5))
+14 IF $PIECE(BUDRACET(BUDX),U,6)]""
WRITE ?67,$$C($PIECE(BUDRACET(BUDX),U,6))
+15 WRITE !,BUD80L
End DoDot:1
+16 SET BUDLANG=1
+17 IF $Y>(IOSL-6)
DO HEADER
IF BUDQUIT
QUIT
DO T3BSH
+18 WRITE !!,BUD80L,!?66,"NUMBER"
+19 WRITE !,"PATIENTS BY LANGUAGE",?67,"(a)",!,BUD80L
+20 WRITE !,"NUMBER OF PATIENTS",!,BUD80L
+21 WRITE !?2,"9",?8,"PATIENTS BEST SERVED IN A LANGUAGE OTHER THAN ",!?2,"ENGLISH",!,BUD80L
+22 WRITE !
+23 KILL BUDLANG
+24 QUIT
TZ ;
+1 DO HEADER
IF BUDQUIT
QUIT
DO TZSH
+2 ;print out each line
+3 SET BUDZTOT=0
+4 SET ^XTMP("BUD0RPT1",BUDJ,BUDH,"ZIP","OTHER ZIP CODES")=0
+5 ;GET TOTAL
+6 SET BUDZ=""
FOR
SET BUDZ=$ORDER(^XTMP("BUD0RPT1",BUDJ,BUDH,"ZIP",BUDZ))
IF BUDZ=""
QUIT
Begin DoDot:1
+7 SET BUDY=^XTMP("BUD0RPT1",BUDJ,BUDH,"ZIP",BUDZ)
+8 SET BUDZTOT=BUDZTOT+BUDY
End DoDot:1
+9 ;CALCULATE "OTHER"
+10 SET BUDZ=""
FOR
SET BUDZ=$ORDER(^XTMP("BUD0RPT1",BUDJ,BUDH,"ZIP",BUDZ))
IF BUDZ=""
QUIT
Begin DoDot:1
+11 IF BUDZ["OTHER"
QUIT
+12 IF BUDZ["Unknown"
QUIT
+13 SET BUDY=^XTMP("BUD0RPT1",BUDJ,BUDH,"ZIP",BUDZ)
+14 SET X=BUDY/BUDZTOT
IF X<.001
KILL ^XTMP("BUD0RPT1",BUDJ,BUDH,"ZIP",BUDZ)
SET ^XTMP("BUD0RPT1",BUDJ,BUDH,"ZIP","OTHER ZIP CODES")=^XTMP("BUD0RPT1",BUDJ,BUDH,"ZIP","OTHER ZIP CODES")+BUDY
Begin DoDot:2
+15 ;now reset the list so the others collate at the end
+16 SET BUDCOM=""
FOR
SET BUDCOM=$ORDER(^XTMP("BUD0RPT1",BUDJ,BUDH,"Z",BUDZ,BUDCOM))
IF BUDCOM=""
QUIT
Begin DoDot:3
+17 SET BUDSEX=""
FOR
SET BUDSEX=$ORDER(^XTMP("BUD0RPT1",BUDJ,BUDH,"Z",BUDZ,BUDCOM,BUDSEX))
IF BUDSEX=""
QUIT
Begin DoDot:4
+18 SET BUDNAME=""
FOR
SET BUDNAME=$ORDER(^XTMP("BUD0RPT1",BUDJ,BUDH,"Z",BUDZ,BUDCOM,BUDSEX,BUDNAME))
IF BUDNAME=""
QUIT
Begin DoDot:5
+19 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("BUD0RPT1",BUDJ,BUDH,"Z",BUDZ,BUDCOM,BUDSEX,BUDNAME,DFN))
IF DFN'=+DFN
QUIT
Begin DoDot:6
+20 SET X=0
FOR
SET X=$ORDER(^XTMP("BUD0RPT1",BUDJ,BUDH,"Z",BUDZ,BUDCOM,BUDSEX,BUDNAME,DFN,X))
IF X'=+X
QUIT
Begin DoDot:7
+21 SET ^XTMP("BUD0RPT1",BUDJ,BUDH,"Z",BUDZ_"*",BUDCOM,BUDSEX,BUDNAME,DFN,X)=""
+22 KILL ^XTMP("BUD0RPT1",BUDJ,BUDH,"Z",BUDZ,BUDCOM,BUDSEX,BUDNAME,DFN,X)
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+23 SET BUDZ=""
FOR
SET BUDZ=$ORDER(^XTMP("BUD0RPT1",BUDJ,BUDH,"ZIP",BUDZ))
IF BUDZ=""!(BUDQUIT)
QUIT
Begin DoDot:1
+24 IF $Y>(IOSL-4)
DO HEADER
IF BUDQUIT
QUIT
DO TZSH
+25 SET BUDY=^XTMP("BUD0RPT1",BUDJ,BUDH,"ZIP",BUDZ)
+26 WRITE !?8,BUDZ,?40,$$C(BUDY),!,BUD80L
End DoDot:1
+27 IF BUDQUIT
QUIT
+28 WRITE !!?8,"TOTAL",?40,$$C(BUDZTOT),!
+29 QUIT
T5 ;print table 5
+1 SET BUDPG=0
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+2 ;lines 1-8
+3 FOR BUDL=1:1:7
SET BUDY=$ORDER(^BUDTTFIV("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(^BUDTTFIV(BUDY,0),U,2)
+8 IF $PIECE(^BUDTTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDTTFIV(BUDY,0),U,3)
+9 IF $PIECE($GET(BUDTAB5(BUDL)),U,1)]""
WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),$SELECT(BUDL=6:2,1:0)),?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+10 WRITE !,BUD80L
End DoDot:1
+11 WRITE !," 8.",?10,"Total Physicians",!?8,"(Lines 1 - 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
SET BUDY=$ORDER(^BUDTTFIV("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 $$LOW^XLFSTR(BUDL),".",?6,$PIECE(^BUDTTFIV(BUDY,0),U,2)
+18 IF $PIECE(^BUDTTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDTTFIV(BUDY,0),U,3)
+19 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),0)
+20 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+21 WRITE !,BUD80L
End DoDot:1
+22 WRITE !,"10a.",?10,"Total Midlevel Practitioners",!?8,"(Lines 9a - 10)",?60,$$C($PIECE(BUDTAB5("10A"),U,1)),?71,$$C($PIECE(BUDTAB5("10A"),U,2),2),!,BUD80L
+23 FOR BUDL=11:1:14
SET BUDY=$ORDER(^BUDTTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+24 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+25 WRITE !,$$LOW^XLFSTR(BUDL),".",?6,$PIECE(^BUDTTFIV(BUDY,0),U,2)
IF $PIECE(^BUDTTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDTTFIV(BUDY,0),U,3)
+26 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),$SELECT(BUDL=11:0,1:2))
+27 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+28 WRITE !,BUD80L
End DoDot:1
+29 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+30 WRITE !,"15.",?10,"Total Medical Care",!?10,"(Lines 8 + 10a through 14)",?60,$$C($PIECE(BUDTAB5(15),U,1)),?71,$$C($PIECE(BUDTAB5(15),U,2)),!,BUD80L
+31 FOR BUDL=16:1:17
SET BUDY=$ORDER(^BUDTTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+32 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+33 WRITE !,$$LOW^XLFSTR(BUDL),".",?6,$PIECE(^BUDTTFIV(BUDY,0),U,2)
IF $PIECE(^BUDTTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDTTFIV(BUDY,0),U,3)
+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
T518 FOR BUDL=18
SET BUDY=$ORDER(^BUDTTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+1 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+2 WRITE !,$$LOW^XLFSTR(BUDL),".",?6,$PIECE(^BUDTTFIV(BUDY,0),U,2)
IF $PIECE(^BUDTTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDTTFIV(BUDY,0),U,3)
+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,"(Lines 16 - 18)",?60,$$C($PIECE(BUDTAB5(19),U,1)),?71,$$C($PIECE(BUDTAB5(19),U,2)),!,BUD80L
+8 ;D HEADER Q:BUDQUIT D T5SH ;force page break before line 20
+9 FOR BUDL="20A","20A1","20A2","20B","20C"
SET BUDY=$ORDER(^BUDTTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+10 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+11 WRITE !,$$LOW^XLFSTR(BUDL),".",?6,$PIECE(^BUDTTFIV(BUDY,0),U,2)
+12 IF $PIECE(^BUDTTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDTTFIV(BUDY,0),U,3)
+13 IF $PIECE(^BUDTTFIV(BUDY,0),U,4)]""
WRITE !?6,$PIECE(^BUDTTFIV(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,"(Lines 20a - c)",?60,$$C($PIECE(BUDTAB5(20),U,1)),?71,$$C($PIECE(BUDTAB5(20),U,2)),!,BUD80L
+19 FOR BUDL=21
SET BUDY=$ORDER(^BUDTTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+20 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+21 WRITE !,$$LOW^XLFSTR(BUDL),".",?6,$PIECE(^BUDTTFIV(BUDY,0),U,2)
IF $PIECE(^BUDTTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDTTFIV(BUDY,0),U,3)
+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=22
SET BUDY=$ORDER(^BUDTTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+26 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+27 WRITE !,$$LOW^XLFSTR(BUDL),".",?8,$PIECE(^BUDTTFIV(BUDY,0),U,2)
IF $PIECE(^BUDTTFIV(BUDY,0),U,3)]""
WRITE !?8,$PIECE(^BUDTTFIV(BUDY,0),U,3)
+28 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),0)
+29 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),0)
+30 WRITE !,BUD80L
End DoDot:1
+31 FOR BUDL="22A","22B","22C"
SET BUDY=$ORDER(^BUDTTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+32 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+33 WRITE !,$$LOW^XLFSTR(BUDL),".",?6,$PIECE(^BUDTTFIV(BUDY,0),U,2)
+34 IF $PIECE(^BUDTTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDTTFIV(BUDY,0),U,3)
+35 IF $PIECE(^BUDTTFIV(BUDY,0),U,4)]""
WRITE !?6,$PIECE(^BUDTTFIV(BUDY,0),U,4)
+36 IF BUDL'="22C"
WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),1)
+37 IF BUDL="22C"
WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),2)
+38 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+39 WRITE !,BUD80L
End DoDot:1
+40 WRITE !,"22d.",?10,"Total Vision Services",!?10,"(Lines 22a-c)",?60,$$C($PIECE(BUDTAB5("22D"),U,1)),?71,$$C($PIECE(BUDTAB5("22D"),U,2)),!,BUD80L
+41 FOR BUDL=23
SET BUDY=$ORDER(^BUDTTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+42 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+43 WRITE !,$$LOW^XLFSTR(BUDL),".",?6,$PIECE(^BUDTTFIV(BUDY,0),U,2)
IF $PIECE(^BUDTTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDTTFIV(BUDY,0),U,3)
+44 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),2)
+45 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+46 WRITE !,BUD80L
End DoDot:1
+47 FOR BUDL=24:1:25
SET BUDY=$ORDER(^BUDTTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+48 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+49 WRITE !,$$LOW^XLFSTR(BUDL),".",?6,$PIECE(^BUDTTFIV(BUDY,0),U,2)
IF $PIECE(^BUDTTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDTTFIV(BUDY,0),U,3)
+50 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),0)
+51 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+52 WRITE !,BUD80L
End DoDot:1
+53 FOR BUDL=26,27,"27a","27b",28
SET BUDY=$ORDER(^BUDTTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+54 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+55 WRITE !,$$LOW^XLFSTR(BUDL),".",?6,$PIECE(^BUDTTFIV(BUDY,0),U,2)
IF $PIECE(^BUDTTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDTTFIV(BUDY,0),U,3)
+56 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),2),?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+57 ;W ?60,$$C($P(BUDTAB5(BUDL),U,1),2)
+58 ;W ?71,$$C($P(BUDTAB5(BUDL),U,2),2)
+59 WRITE !,BUD80L
End DoDot:1
+60 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+61 WRITE !,"29.",?10,"Total Enabling Services",!?10,"(Lines 24 - 28)",?60,$$C($PIECE(BUDTAB5(29),U,1)),?71,$$C($PIECE(BUDTAB5(29),U,2)),!,BUD80L
+62 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+63 WRITE !,"29a.",?10,"Other Programs/ Services",!?10,"(specify__)",?60,$$C($PIECE(BUDTAB5(29),U,1),2),?71,$$C($PIECE(BUDTAB5(29),U,2),2),!,BUD80L
+64 FOR BUDL="30A","30B","30C"
SET BUDY=$ORDER(^BUDTTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+65 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+66 WRITE !,$$LOW^XLFSTR(BUDL),".",?6,$PIECE(^BUDTTFIV(BUDY,0),U,2)
IF $PIECE(^BUDTTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDTTFIV(BUDY,0),U,3)
+67 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),2)
+68 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+69 WRITE !,BUD80L
End DoDot:1
+70 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+71 WRITE !,"30.",?10,"Total Administrative Staff",!?10,"(Lines 30a-30c)"
+72 WRITE ?60,$$C($PIECE(BUDTAB5(33),U,1),2),?71,$$C($PIECE(BUDTAB5(33),U,2),2),!,BUD80L
+73 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+74 FOR BUDL=31,32
SET BUDY=$ORDER(^BUDTTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+75 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+76 WRITE !,$$LOW^XLFSTR(BUDL),".",?6,$PIECE(^BUDTTFIV(BUDY,0),U,2)
IF $PIECE(^BUDTTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDTTFIV(BUDY,0),U,3)
+77 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),2)
+78 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+79 WRITE !,BUD80L
End DoDot:1
+80 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+81 WRITE !,"33.",?10,"TOTAL ADMINISTRATION AND FACILITY",!?10,"(TOTAL LINES 30+31+32)"
+82 WRITE ?60,$$C($PIECE(BUDTAB5(33),U,1),2),?71,$$C($PIECE(BUDTAB5(33),U,2),2),!,BUD80L
+83 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+84 WRITE !,"34.",?10,"Total (Lines ",!?10,"15+19+20+21+22+22d+23+29+29a+33)"
+85 SET Y=0
FOR X=15,19,20,21,22,"22D",29
SET Y=Y+$PIECE(BUDTAB5(X),U)
+86 WRITE ?60,$$C(Y),?71,$$C(Y,2),!,BUD80L
+87 IF $PIECE(BUDTAB5(35),U)
Begin DoDot:1
+88 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+89 WRITE !!,$PIECE(BUDTAB5(35),U)," visits did not fit into any of the above categories",!
End DoDot:1
+90 WRITE !
+91 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,"CLINIC",?71,"PATIENTS"
+5 WRITE !?60,"VISITS"
+6 WRITE !,"PERSONNEL BY MAJOR SERVICE CATEGORY",?54,"(a)",?64,"(b)",?73,"(c)"
+7 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+8 QUIT
T6 ;
+1 DO T6^BUD0RPP1
+2 QUIT
T6B ;
+1 DO PRINT^BUD0RP6B
+2 QUIT
T7 ;
+1 DO PRINT^BUD0RP7
+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 $GET(BUDTPG)=0
GOTO HEADER2
+2 ;I BUDPG=0,'$G(BUDFNP) G HEADER2
+3 IF $GET(BUDTPG)!($GET(BUDFNP))
IF $DATA(IOF)
WRITE @IOF
+4 ;W:$D(IOF) @IOF
SET BUDTPG=$GET(BUDTPG)+1
+1 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 2010"
SET $EXTRACT(X,70)="Page "
SET $EXTRACT(X,75)=BUDPG
WRITE !,X
+2 ;W !?3,$P(^VA(200,DUZ,0),U,2),?10,"UDS 2010",$$CTR($P(^DIC(4,BUDSITE,0),U),80),?70,"Page ",BUDPG
+3 ;W $$CTR($P(^DIC(4,BUDSITE,0),U),80),!
+4 WRITE !,"UDS No. ",$PIECE(^BUDTSITE(BUDSITE,0),U,2),?50,"Date Run: ",$$FMTE^XLFDT(DT)
+5 WRITE !,"Reporting Period: ",$$FMTE^XLFDT(BUDBD)," through ",$$FMTE^XLFDT(BUDED)
+6 WRITE !
+7 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 ;----------
