BUDHRPTP ;IHS/CMI/LAB - UDS REPORT PRINT;
;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
;
PRINT ;EP
;
S BUDPG=0,BUDTPG=0,BUDSCTC=0,BUDZLIST=0
;ARE THERE ANY LISTS?
I ($G(BUDT3BRL)+$G(BUDT4IPP)+$G(BUDT4PMI)+$G(BUDT4CHA)+$G(BUDT3AL)+$G(BUDT5L)+$G(BUDT5L1)+$G(BUDT6L)+$G(BUDTZL)+$G(BUDT5L2))>0 S BUDZLIST=1
S BUDQUIT=0
S BUD80L="",$P(BUD80L,"_",79)="_"
S:$G(BUDROT)="" BUDROT="P"
I BUDROT="D" D G PL
.D ^%ZISC
.K ^TMP($J)
.S ^TMP($J,"BUDDEL",0)=0
.S BUDDECNT=0
.I $G(BUDTZ) D REOZ
I $G(BUDTZ) S BUDSCTC=BUDSCTC+1 D TZ G:BUDQUIT EOJ D SECT
I $G(BUDT3A) S BUDSCTC=BUDSCTC+1 D T3A G:BUDQUIT EOJ D SECT
I $G(BUDT3B) S BUDSCTC=BUDSCTC+1 D T3B G:BUDQUIT EOJ D SECT
I $G(BUDT4) S BUDSCTC=BUDSCTC+1 D T4 G:BUDQUIT EOJ D SECT
I $G(BUDT5) S BUDSCTC=BUDSCTC+1 D T5 G:BUDQUIT EOJ D SECT
I $G(BUDT6) S BUDSCTC=BUDSCTC+1 D T6 G:BUDQUIT EOJ D SECT
S BUDBD=BUDXXBD,BUDED=BUDXXED
I $G(BUDT6B) S BUDSCTC=BUDSCTC+1 D T6B G:BUDQUIT EOJ
I $G(BUDT7) S BUDSCTC=BUDSCTC+1 D T7 G:BUDQUIT EOJ
S BUDBD=BUDHOLBD,BUDED=BUDHOLED
I $G(BUDT9) S BUDSCTC=BUDSCTC+1 D T9 G:BUDQUIT EOJ I BUDTSCTC>1,BUDROT'="D" D SECT
PL ;
D PATLISTS
I BUDROT'="D" W !,"***** END OF REPORT *****",!
D ^%ZISC
I BUDROT="D" D SAVEDEL^BUDHRPTD
I $G(BUDT9D) D WDEL^BUDHRPTQ
D EOJ
Q
SECT ;
I BUDTSCTC>1,BUDROT'="D" W !,"***** END OF SECTION ",BUDSCTC," *****",!
Q
;
EOJ ;
K ^TMP($J)
K ^XTMP("BUDHRPT1",BUDJ,BUDH)
K ^XTMP("BUDHRPT9DEL",BUDJ,BUDH)
Q
T9 ;
D T9^BUDHRPP2
Q
T4 ;
D T4^BUDHRPP2
Q
T3A ;
D T3A^BUDHRPL3
Q
T3BSH ;
W !!,$$CTR("TABLE 3B -",80)
W !,$$CTR("DEMOGRAPHIC CHARACTERISTICS",80),!,$$CTR("Patients by Race and Hispanic or Latino Ethnicity",80),!,BUD80L
;W !!,BUD80L
Q:$G(BUDLANG)
W !?53,"UNREPORTED/"
W !?41,"NON-",?53,"REFUSED TO",?70,"TOTAL"
W !?25,"HISPANIC/",?39,"HISPANIC/",?53,"REPORT",?71,"(d)"
W !?3,"PATIENTS BY RACE",?26,"LATINO",?40,"LATINO",?53,"ETHNICITY",?67,"(Sum Columns"
W !?28,"(a)",?41,"(b)",?56,"(c)",?70,"a+b+c)"
W !,BUD80L
Q
TZSH ;
W !!,$$CTR("PATIENT BY ZIP CODE",80)
W !,$TR($J("",80)," ","-")
W !!?5,"Zip Code",?20,"None/",?34,"Medicaid/CHIP/",?51,"Medicare",?63,"Private",?72,"Total"
W !?20,"Uninsured",?34,"Other Public",?72,"Patients"
W !?7,"(a)",?23,"(b)",?39,"(c)",?54,"(d)",?65,"(e)",?74,"(f)"
W !,$TR($J("",80)," ","-")
Q
PATLISTS ;
D ^BUDHRPTL
Q
T3B ;
S BUDPG=0
D HEADER Q:BUDQUIT D T3BSH
;
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,9)]"" W !?6,$P(BUDRACET(BUDX),U,9)
.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
D REST3B^BUDHRPTQ
K BUDLANG
Q
TZ ;
D HEADER Q:BUDQUIT D TZSH
;print out each line
S BUDZTOT=0,BUDBTOT=0,BUDCTOT=0,BUDDTOT=0,BUDETOT=0,BUDFTOT=0
;GET TOTAL
S BUDZ="" F S BUDZ=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ)) Q:BUDZ="" D
.S BUDY=^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ)
.S BUDZTOT=BUDZTOT+BUDY
.S BUDBTOT=BUDBTOT+$G(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ,"b"))
.S BUDCTOT=BUDCTOT+$G(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ,"c"))
.S BUDDTOT=BUDDTOT+$G(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ,"d"))
.S BUDETOT=BUDETOT+$G(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ,"e"))
.S BUDFTOT=BUDFTOT+$G(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ,"f"))
;CALCULATE "OTHER"
;RESET BY TOTAL #
D REOZ
S BUDYY=0 F S BUDYY=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIPORDER",BUDYY)) Q:BUDYY="" D
.S BUDZ="" F S BUDZ=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIPORDER",BUDYY,BUDZ)) Q:BUDZ=""!(BUDQUIT) D
..I $Y>(IOSL-4) D HEADER Q:BUDQUIT D TZSH
..S BUDY=^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ)
..W !?8,BUDZ
..W ?20,$$C(+$G(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ,"b")))
..W ?35,$$C(+$G(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ,"c")))
..W ?50,$$C(+$G(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ,"d")))
..W ?63,$$C(+$G(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ,"e")))
..W ?72,$$C(+$G(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ,"f")))
..W !,BUD80L
Q:BUDQUIT
I $Y>(IOSL-6) D HEADER Q:BUDQUIT D TZSH
W !?2,"Other Zip Codes" D
.W ?20,$$C(0)
.W ?35,$$C(0)
.W ?50,$$C(0)
.W ?63,$$C(0)
.W ?72,$$C(0)
W !,BUD80L
W !?2,"Unknown Residence" D
.W ?20,$$C(+$G(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP","Unknown Residence","b")))
.W ?35,$$C(+$G(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP","Unknown Residence","c")))
.W ?50,$$C(+$G(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP","Unknown Residence","d")))
.W ?63,$$C(+$G(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP","Unknown Residence","e")))
.W ?72,$$C(+$G(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP","Unknown Residence","f")))
W !,BUD80L,!?8,"TOTAL",?20,$$C(BUDBTOT),?35,$$C(BUDCTOT),?50,$$C(BUDDTOT),?63,$$C(BUDETOT),?72,$$C(BUDFTOT),!
Q
REOZ ;
S BUDZ="" F S BUDZ=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ)) Q:BUDZ="" D
.Q:BUDZ["Unknown"
.S BUDY=^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ)
.S BUDYY=9999999-BUDY
.S ^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIPORDER",(9999999-BUDY),BUDZ)=BUDY
.D
..;now reset the list
..S BUDINS="" F S BUDINS=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDZ,BUDINS)) Q:BUDINS="" D
...S BUDCCOM="" F S BUDCCOM=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDZ,BUDINS,BUDCCOM)) Q:BUDCCOM="" D
....S BUDSEX="" F S BUDSEX=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDZ,BUDINS,BUDCCOM,BUDSEX)) Q:BUDSEX="" D
.....S BUDNAME="" F S BUDNAME=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDZ,BUDINS,BUDCCOM,BUDSEX,BUDNAME)) Q:BUDNAME="" D
......S DFN=0 F S DFN=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDZ,BUDINS,BUDCCOM,BUDSEX,BUDNAME,DFN)) Q:DFN'=+DFN D
.......S X=0 F S X=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDZ,BUDINS,BUDCCOM,BUDSEX,BUDNAME,DFN,X)) Q:X'=+X D
........S ^XTMP("BUDHRPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZ,BUDINS,BUDCCOM,BUDSEX,BUDNAME,DFN,X)=""
........K ^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDZ,BUDINS,BUDCCOM,BUDSEX,BUDNAME,DFN,X)
Q
T5 ;print 5
S BUDPG=0 D HEADER Q:BUDQUIT D T5SH
F BUDL=1:1:7 S BUDY=$O(^BUDHTFIV("B",BUDL,0)) Q:BUDQUIT D
.Q:'BUDY
.W !
.I +BUDL<10 W " "
.W BUDL,".",?6,$P(^BUDHTFIV(BUDY,0),U,2)
.I $P(^BUDHTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDHTFIV(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.",?8,"Total Physicians (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(^BUDHTFIV("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(^BUDHTFIV(BUDY,0),U,2)
.I $P(^BUDHTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDHTFIV(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.",?8,"Total NPs, PAs, CNMs (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(^BUDHTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,$$LOW^XLFSTR(BUDL),".",?6,$P(^BUDHTFIV(BUDY,0),U,2) I $P(^BUDHTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDHTFIV(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.",?8,"Total Medical (Lines 8+10a through 14)",?60,$$C($P(BUDTAB5(15),U,1)),?71,$$C($P(BUDTAB5(15),U,2)),!,BUD80L
F BUDL=16,17,"17a" S BUDY=$O(^BUDHTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,$$LOW^XLFSTR(BUDL),".",?6,$P(^BUDHTFIV(BUDY,0),U,2) I $P(^BUDHTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDHTFIV(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(^BUDHTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,$$LOW^XLFSTR(BUDL),".",?6,$P(^BUDHTFIV(BUDY,0),U,2) I $P(^BUDHTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDHTFIV(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.",?8,"Total Dental Services (Lines 16 - 18)",?60,$$C($P(BUDTAB5(19),U,1)),?71,$$C($P(BUDTAB5(19),U,2)),!,BUD80L
F BUDL="20A","20A1","20A2","20B","20C" S BUDY=$O(^BUDHTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,$$LOW^XLFSTR(BUDL),".",?6,$P(^BUDHTFIV(BUDY,0),U,2)
.I $P(^BUDHTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDHTFIV(BUDY,0),U,3)
.I $P(^BUDHTFIV(BUDY,0),U,4)]"" W !?6,$P(^BUDHTFIV(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.",?8,"Total Mental Health (Lines 20a-c)",?60,$$C($P(BUDTAB5(20),U,1)),?71,$$C($P(BUDTAB5(20),U,2)),!,BUD80L
F BUDL=21 S BUDY=$O(^BUDHTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,$$LOW^XLFSTR(BUDL),".",?8,$P(^BUDHTFIV(BUDY,0),U,2) I $P(^BUDHTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDHTFIV(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(^BUDHTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,$$LOW^XLFSTR(BUDL),".",?8,$P(^BUDHTFIV(BUDY,0),U,2) I $P(^BUDHTFIV(BUDY,0),U,3)]"" W !?8,$P(^BUDHTFIV(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(^BUDHTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,$$LOW^XLFSTR(BUDL),".",?6,$P(^BUDHTFIV(BUDY,0),U,2)
.I $P(^BUDHTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDHTFIV(BUDY,0),U,3)
.I $P(^BUDHTFIV(BUDY,0),U,4)]"" W !?6,$P(^BUDHTFIV(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.",?8,"Total Vision Services (Lines 22a-c)",?60,$$C($P(BUDTAB5("22D"),U,1)),?71,$$C($P(BUDTAB5("22D"),U,2)),!,BUD80L
F BUDL=23 S BUDY=$O(^BUDHTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,$$LOW^XLFSTR(BUDL),".",?8,$P(^BUDHTFIV(BUDY,0),U,2) I $P(^BUDHTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDHTFIV(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(^BUDHTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,$$LOW^XLFSTR(BUDL),".",?6,$P(^BUDHTFIV(BUDY,0),U,2) I $P(^BUDHTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDHTFIV(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","27c",28 S BUDY=$O(^BUDHTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,$$LOW^XLFSTR(BUDL),".",?6,$P(^BUDHTFIV(BUDY,0),U,2) I $P(^BUDHTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDHTFIV(BUDY,0),U,3)
.W ?60,$$C($P(BUDTAB5(BUDL),U,1),2),?71,$$C($P(BUDTAB5(BUDL),U,2),2)
.W !,BUD80L
I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
W !,"29.",?8,"Total Enabling Services (Lines 24 - 28)",?60,$$C($P(BUDTAB5(29),U,1)),?71,$$C($P(BUDTAB5(29),U,2)),!,BUD80L
I $Y>(IOSL-5) D HEADER Q:BUDQUIT D T5SH
W !,"29a.",?8,"Other Programs/ Services",!?8,"(specify__)",?60,$$C($P(BUDTAB5("29a"),U,1),2),?71,$$C($P(BUDTAB5("29a"),U,2),2),!,BUD80L
W !,"29b.",?12,"Quality Improvement Staff",?60,$$C($P(BUDTAB5("29b"),U,1),2),?71,$$C($P(BUDTAB5("29b"),U,2),2),!,BUD80L
F BUDL="30A","30B","30C" S BUDY=$O(^BUDHTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,$$LOW^XLFSTR(BUDL),".",?6,$P(^BUDHTFIV(BUDY,0),U,2) I $P(^BUDHTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDHTFIV(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
F BUDL=31,32 S BUDY=$O(^BUDHTFIV("B",BUDL,0)) Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER Q:BUDQUIT D T5SH
.W !,$$LOW^XLFSTR(BUDL),".",?6,$P(^BUDHTFIV(BUDY,0),U,2) I $P(^BUDHTFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDHTFIV(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.",?8,"Total Facility and Non-Clinical",!?8,"Support Staff (Lines 30a-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.",?8,"Grand Total (Lines ",!?8,"15+19+20+21+22+22d+23+29+29a+29b+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 !,$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^BUDHRPP1
Q
T6B ;
D PRINT^BUDHRP6B
Q
T7 ;
D PRINT^BUDHRP7
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 BUDTPG=0 D:'$G(BUDZLIST) COVPAGET^BUDHUTL1 D:$G(BUDZLIST) COVPAGEP^BUDHUTL1 S BUDTPG=1 ;SECURITY
I $G(BUDTPG)=0 G HEADER2
I $G(BUDTPG)!($G(BUDFNP)) W:$D(IOF) @IOF
;
W $$CTR("***** SENSITIVE INFORMATION *****",IOM),!
S X=$$CTR($P(^DIC(4,BUDSITE,0),U),55),$E(X,3)=$P(^VA(200,DUZ,0),U,2),$E(X,10)="UDS 2018",$E(X,55)="Section "_BUDSCTC_" of "_BUDTSCTC_", Page "_BUDPG W !,X
W !,"UDS No. ",$P(^BUDHSITE(BUDSITE,0),U,2),?50,"Date Run: ",$$FMTE^XLFDT(DT)
W !,"Reporting Period: ",$$FMTE^XLFDT(BUDBD)," through ",$$FMTE^XLFDT(BUDED)
W !,"Population: ",$S($G(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$G(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$G(BUDBEN)=3:"All (both Indian/Alaskan Natives and Non 01)",$G(BUDBEN)=4:"Homeless",1:"")
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
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
USR() ;EP - Return name
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;----------
LOC() ;EP - Return loc
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;----------
BUDHRPTP ;IHS/CMI/LAB - UDS REPORT PRINT;
+1 ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
+2 ;
PRINT ;EP
+1 ;
+2 SET BUDPG=0
SET BUDTPG=0
SET BUDSCTC=0
SET BUDZLIST=0
+3 ;ARE THERE ANY LISTS?
+4 IF ($GET(BUDT3BRL)+$GET(BUDT4IPP)+$GET(BUDT4PMI)+$GET(BUDT4CHA)+$GET(BUDT3AL)+$GET(BUDT5L)+$GET(BUDT5L1)+$GET(BUDT6L)+$GET(BUDTZL)+$GET(BUDT5L2))>0
SET BUDZLIST=1
+5 SET BUDQUIT=0
+6 SET BUD80L=""
SET $PIECE(BUD80L,"_",79)="_"
+7 IF $GET(BUDROT)=""
SET BUDROT="P"
+8 IF BUDROT="D"
Begin DoDot:1
+9 DO ^%ZISC
+10 KILL ^TMP($JOB)
+11 SET ^TMP($JOB,"BUDDEL",0)=0
+12 SET BUDDECNT=0
+13 IF $GET(BUDTZ)
DO REOZ
End DoDot:1
GOTO PL
+14 IF $GET(BUDTZ)
SET BUDSCTC=BUDSCTC+1
DO TZ
IF BUDQUIT
GOTO EOJ
DO SECT
+15 IF $GET(BUDT3A)
SET BUDSCTC=BUDSCTC+1
DO T3A
IF BUDQUIT
GOTO EOJ
DO SECT
+16 IF $GET(BUDT3B)
SET BUDSCTC=BUDSCTC+1
DO T3B
IF BUDQUIT
GOTO EOJ
DO SECT
+17 IF $GET(BUDT4)
SET BUDSCTC=BUDSCTC+1
DO T4
IF BUDQUIT
GOTO EOJ
DO SECT
+18 IF $GET(BUDT5)
SET BUDSCTC=BUDSCTC+1
DO T5
IF BUDQUIT
GOTO EOJ
DO SECT
+19 IF $GET(BUDT6)
SET BUDSCTC=BUDSCTC+1
DO T6
IF BUDQUIT
GOTO EOJ
DO SECT
+20 SET BUDBD=BUDXXBD
SET BUDED=BUDXXED
+21 IF $GET(BUDT6B)
SET BUDSCTC=BUDSCTC+1
DO T6B
IF BUDQUIT
GOTO EOJ
+22 IF $GET(BUDT7)
SET BUDSCTC=BUDSCTC+1
DO T7
IF BUDQUIT
GOTO EOJ
+23 SET BUDBD=BUDHOLBD
SET BUDED=BUDHOLED
+24 IF $GET(BUDT9)
SET BUDSCTC=BUDSCTC+1
DO T9
IF BUDQUIT
GOTO EOJ
IF BUDTSCTC>1
IF BUDROT'="D"
DO SECT
PL ;
+1 DO PATLISTS
+2 IF BUDROT'="D"
WRITE !,"***** END OF REPORT *****",!
+3 DO ^%ZISC
+4 IF BUDROT="D"
DO SAVEDEL^BUDHRPTD
+5 IF $GET(BUDT9D)
DO WDEL^BUDHRPTQ
+6 DO EOJ
+7 QUIT
SECT ;
+1 IF BUDTSCTC>1
IF BUDROT'="D"
WRITE !,"***** END OF SECTION ",BUDSCTC," *****",!
+2 QUIT
+3 ;
EOJ ;
+1 KILL ^TMP($JOB)
+2 KILL ^XTMP("BUDHRPT1",BUDJ,BUDH)
+3 KILL ^XTMP("BUDHRPT9DEL",BUDJ,BUDH)
+4 QUIT
T9 ;
+1 DO T9^BUDHRPP2
+2 QUIT
T4 ;
+1 DO T4^BUDHRPP2
+2 QUIT
T3A ;
+1 DO T3A^BUDHRPL3
+2 QUIT
T3BSH ;
+1 WRITE !!,$$CTR("TABLE 3B -",80)
+2 WRITE !,$$CTR("DEMOGRAPHIC CHARACTERISTICS",80),!,$$CTR("Patients by Race and Hispanic or Latino Ethnicity",80),!,BUD80L
+3 ;W !!,BUD80L
+4 IF $GET(BUDLANG)
QUIT
+5 WRITE !?53,"UNREPORTED/"
+6 WRITE !?41,"NON-",?53,"REFUSED TO",?70,"TOTAL"
+7 WRITE !?25,"HISPANIC/",?39,"HISPANIC/",?53,"REPORT",?71,"(d)"
+8 WRITE !?3,"PATIENTS BY RACE",?26,"LATINO",?40,"LATINO",?53,"ETHNICITY",?67,"(Sum Columns"
+9 WRITE !?28,"(a)",?41,"(b)",?56,"(c)",?70,"a+b+c)"
+10 WRITE !,BUD80L
+11 QUIT
TZSH ;
+1 WRITE !!,$$CTR("PATIENT BY ZIP CODE",80)
+2 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+3 WRITE !!?5,"Zip Code",?20,"None/",?34,"Medicaid/CHIP/",?51,"Medicare",?63,"Private",?72,"Total"
+4 WRITE !?20,"Uninsured",?34,"Other Public",?72,"Patients"
+5 WRITE !?7,"(a)",?23,"(b)",?39,"(c)",?54,"(d)",?65,"(e)",?74,"(f)"
+6 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+7 QUIT
PATLISTS ;
+1 DO ^BUDHRPTL
+2 QUIT
T3B ;
+1 SET BUDPG=0
+2 DO HEADER
IF BUDQUIT
QUIT
DO T3BSH
+3 ;
+4 IF $Y>(IOSL-6)
DO HEADER
IF BUDQUIT
QUIT
DO T3BSH
+5 FOR BUDX="1","2A","2B","2",3,4,5,6,7,8
IF BUDQUIT
QUIT
Begin DoDot:1
+6 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T3BSH
+7 WRITE !?2,$PIECE(BUDRACET(BUDX),U),?6,$PIECE(BUDRACET(BUDX),U,2)
+8 IF $PIECE(BUDRACET(BUDX),U,7)]""
WRITE !?6,$PIECE(BUDRACET(BUDX),U,7)
+9 IF $PIECE(BUDRACET(BUDX),U,8)]""
WRITE !?6,$PIECE(BUDRACET(BUDX),U,8)
+10 IF $PIECE(BUDRACET(BUDX),U,9)]""
WRITE !?6,$PIECE(BUDRACET(BUDX),U,9)
+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 DO REST3B^BUDHRPTQ
+17 KILL BUDLANG
+18 QUIT
TZ ;
+1 DO HEADER
IF BUDQUIT
QUIT
DO TZSH
+2 ;print out each line
+3 SET BUDZTOT=0
SET BUDBTOT=0
SET BUDCTOT=0
SET BUDDTOT=0
SET BUDETOT=0
SET BUDFTOT=0
+4 ;GET TOTAL
+5 SET BUDZ=""
FOR
SET BUDZ=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ))
IF BUDZ=""
QUIT
Begin DoDot:1
+6 SET BUDY=^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ)
+7 SET BUDZTOT=BUDZTOT+BUDY
+8 SET BUDBTOT=BUDBTOT+$GET(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ,"b"))
+9 SET BUDCTOT=BUDCTOT+$GET(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ,"c"))
+10 SET BUDDTOT=BUDDTOT+$GET(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ,"d"))
+11 SET BUDETOT=BUDETOT+$GET(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ,"e"))
+12 SET BUDFTOT=BUDFTOT+$GET(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ,"f"))
End DoDot:1
+13 ;CALCULATE "OTHER"
+14 ;RESET BY TOTAL #
+15 DO REOZ
+16 SET BUDYY=0
FOR
SET BUDYY=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIPORDER",BUDYY))
IF BUDYY=""
QUIT
Begin DoDot:1
+17 SET BUDZ=""
FOR
SET BUDZ=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIPORDER",BUDYY,BUDZ))
IF BUDZ=""!(BUDQUIT)
QUIT
Begin DoDot:2
+18 IF $Y>(IOSL-4)
DO HEADER
IF BUDQUIT
QUIT
DO TZSH
+19 SET BUDY=^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ)
+20 WRITE !?8,BUDZ
+21 WRITE ?20,$$C(+$GET(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ,"b")))
+22 WRITE ?35,$$C(+$GET(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ,"c")))
+23 WRITE ?50,$$C(+$GET(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ,"d")))
+24 WRITE ?63,$$C(+$GET(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ,"e")))
+25 WRITE ?72,$$C(+$GET(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ,"f")))
+26 WRITE !,BUD80L
End DoDot:2
End DoDot:1
+27 IF BUDQUIT
QUIT
+28 IF $Y>(IOSL-6)
DO HEADER
IF BUDQUIT
QUIT
DO TZSH
+29 WRITE !?2,"Other Zip Codes"
Begin DoDot:1
+30 WRITE ?20,$$C(0)
+31 WRITE ?35,$$C(0)
+32 WRITE ?50,$$C(0)
+33 WRITE ?63,$$C(0)
+34 WRITE ?72,$$C(0)
End DoDot:1
+35 WRITE !,BUD80L
+36 WRITE !?2,"Unknown Residence"
Begin DoDot:1
+37 WRITE ?20,$$C(+$GET(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP","Unknown Residence","b")))
+38 WRITE ?35,$$C(+$GET(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP","Unknown Residence","c")))
+39 WRITE ?50,$$C(+$GET(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP","Unknown Residence","d")))
+40 WRITE ?63,$$C(+$GET(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP","Unknown Residence","e")))
+41 WRITE ?72,$$C(+$GET(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP","Unknown Residence","f")))
End DoDot:1
+42 WRITE !,BUD80L,!?8,"TOTAL",?20,$$C(BUDBTOT),?35,$$C(BUDCTOT),?50,$$C(BUDDTOT),?63,$$C(BUDETOT),?72,$$C(BUDFTOT),!
+43 QUIT
REOZ ;
+1 SET BUDZ=""
FOR
SET BUDZ=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ))
IF BUDZ=""
QUIT
Begin DoDot:1
+2 IF BUDZ["Unknown"
QUIT
+3 SET BUDY=^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIP",BUDZ)
+4 SET BUDYY=9999999-BUDY
+5 SET ^XTMP("BUDHRPT1",BUDJ,BUDH,"ZIPORDER",(9999999-BUDY),BUDZ)=BUDY
+6 Begin DoDot:2
+7 ;now reset the list
+8 SET BUDINS=""
FOR
SET BUDINS=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDZ,BUDINS))
IF BUDINS=""
QUIT
Begin DoDot:3
+9 SET BUDCCOM=""
FOR
SET BUDCCOM=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDZ,BUDINS,BUDCCOM))
IF BUDCCOM=""
QUIT
Begin DoDot:4
+10 SET BUDSEX=""
FOR
SET BUDSEX=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDZ,BUDINS,BUDCCOM,BUDSEX))
IF BUDSEX=""
QUIT
Begin DoDot:5
+11 SET BUDNAME=""
FOR
SET BUDNAME=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDZ,BUDINS,BUDCCOM,BUDSEX,BUDNAME))
IF BUDNAME=""
QUIT
Begin DoDot:6
+12 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDZ,BUDINS,BUDCCOM,BUDSEX,BUDNAME,DFN))
IF DFN'=+DFN
QUIT
Begin DoDot:7
+13 SET X=0
FOR
SET X=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDZ,BUDINS,BUDCCOM,BUDSEX,BUDNAME,DFN,X))
IF X'=+X
QUIT
Begin DoDot:8
+14 SET ^XTMP("BUDHRPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZ,BUDINS,BUDCCOM,BUDSEX,BUDNAME,DFN,X)=""
+15 KILL ^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDZ,BUDINS,BUDCCOM,BUDSEX,BUDNAME,DFN,X)
End DoDot:8
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+16 QUIT
T5 ;print 5
+1 SET BUDPG=0
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+2 FOR BUDL=1:1:7
SET BUDY=$ORDER(^BUDHTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+3 IF 'BUDY
QUIT
+4 WRITE !
+5 IF +BUDL<10
WRITE " "
+6 WRITE BUDL,".",?6,$PIECE(^BUDHTFIV(BUDY,0),U,2)
+7 IF $PIECE(^BUDHTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDHTFIV(BUDY,0),U,3)
+8 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)
+9 WRITE !,BUD80L
End DoDot:1
+10 WRITE !," 8.",?8,"Total Physicians (Lines 1 - 7)",?60,$$C($PIECE(BUDTAB5(8),U,1)),?71,$$C($PIECE(BUDTAB5(8),U,2),2),!,BUD80L
+11 ;print out lines 9-15
+12 FOR BUDL="9A","9B",10
SET BUDY=$ORDER(^BUDHTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+13 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+14 WRITE !
+15 IF +BUDL<10
WRITE " "
+16 WRITE $$LOW^XLFSTR(BUDL),".",?6,$PIECE(^BUDHTFIV(BUDY,0),U,2)
+17 IF $PIECE(^BUDHTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDHTFIV(BUDY,0),U,3)
+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 WRITE !,"10a.",?8,"Total NPs, PAs, CNMs (Lines 9a - 10)",?60,$$C($PIECE(BUDTAB5("10A"),U,1)),?71,$$C($PIECE(BUDTAB5("10A"),U,2),2),!,BUD80L
+22 FOR BUDL=11:1:14
SET BUDY=$ORDER(^BUDHTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+23 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+24 WRITE !,$$LOW^XLFSTR(BUDL),".",?6,$PIECE(^BUDHTFIV(BUDY,0),U,2)
IF $PIECE(^BUDHTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDHTFIV(BUDY,0),U,3)
+25 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),$SELECT(BUDL=11:0,1:2))
+26 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+27 WRITE !,BUD80L
End DoDot:1
+28 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+29 WRITE !,"15.",?8,"Total Medical (Lines 8+10a through 14)",?60,$$C($PIECE(BUDTAB5(15),U,1)),?71,$$C($PIECE(BUDTAB5(15),U,2)),!,BUD80L
+30 FOR BUDL=16,17,"17a"
SET BUDY=$ORDER(^BUDHTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+31 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+32 WRITE !,$$LOW^XLFSTR(BUDL),".",?6,$PIECE(^BUDHTFIV(BUDY,0),U,2)
IF $PIECE(^BUDHTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDHTFIV(BUDY,0),U,3)
+33 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),0)
+34 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+35 WRITE !,BUD80L
End DoDot:1
T518 FOR BUDL=18
SET BUDY=$ORDER(^BUDHTFIV("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(^BUDHTFIV(BUDY,0),U,2)
IF $PIECE(^BUDHTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDHTFIV(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.",?8,"Total Dental Services (Lines 16 - 18)",?60,$$C($PIECE(BUDTAB5(19),U,1)),?71,$$C($PIECE(BUDTAB5(19),U,2)),!,BUD80L
+8 FOR BUDL="20A","20A1","20A2","20B","20C"
SET BUDY=$ORDER(^BUDHTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+9 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+10 WRITE !,$$LOW^XLFSTR(BUDL),".",?6,$PIECE(^BUDHTFIV(BUDY,0),U,2)
+11 IF $PIECE(^BUDHTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDHTFIV(BUDY,0),U,3)
+12 IF $PIECE(^BUDHTFIV(BUDY,0),U,4)]""
WRITE !?6,$PIECE(^BUDHTFIV(BUDY,0),U,4)
+13 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),0)
+14 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+15 WRITE !,BUD80L
End DoDot:1
+16 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+17 WRITE !,"20.",?8,"Total Mental Health (Lines 20a-c)",?60,$$C($PIECE(BUDTAB5(20),U,1)),?71,$$C($PIECE(BUDTAB5(20),U,2)),!,BUD80L
+18 FOR BUDL=21
SET BUDY=$ORDER(^BUDHTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+19 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+20 WRITE !,$$LOW^XLFSTR(BUDL),".",?8,$PIECE(^BUDHTFIV(BUDY,0),U,2)
IF $PIECE(^BUDHTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDHTFIV(BUDY,0),U,3)
+21 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),0)
+22 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),0)
+23 WRITE !,BUD80L
End DoDot:1
+24 FOR BUDL=22
SET BUDY=$ORDER(^BUDHTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+25 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+26 WRITE !,$$LOW^XLFSTR(BUDL),".",?8,$PIECE(^BUDHTFIV(BUDY,0),U,2)
IF $PIECE(^BUDHTFIV(BUDY,0),U,3)]""
WRITE !?8,$PIECE(^BUDHTFIV(BUDY,0),U,3)
+27 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),0)
+28 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),0)
+29 WRITE !,BUD80L
End DoDot:1
+30 FOR BUDL="22A","22B","22C"
SET BUDY=$ORDER(^BUDHTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+31 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+32 WRITE !,$$LOW^XLFSTR(BUDL),".",?6,$PIECE(^BUDHTFIV(BUDY,0),U,2)
+33 IF $PIECE(^BUDHTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDHTFIV(BUDY,0),U,3)
+34 IF $PIECE(^BUDHTFIV(BUDY,0),U,4)]""
WRITE !?6,$PIECE(^BUDHTFIV(BUDY,0),U,4)
+35 IF BUDL'="22C"
WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),1)
+36 IF BUDL="22C"
WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),2)
+37 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+38 WRITE !,BUD80L
End DoDot:1
+39 WRITE !,"22d.",?8,"Total Vision Services (Lines 22a-c)",?60,$$C($PIECE(BUDTAB5("22D"),U,1)),?71,$$C($PIECE(BUDTAB5("22D"),U,2)),!,BUD80L
+40 FOR BUDL=23
SET BUDY=$ORDER(^BUDHTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+41 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+42 WRITE !,$$LOW^XLFSTR(BUDL),".",?8,$PIECE(^BUDHTFIV(BUDY,0),U,2)
IF $PIECE(^BUDHTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDHTFIV(BUDY,0),U,3)
+43 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),2)
+44 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+45 WRITE !,BUD80L
End DoDot:1
+46 FOR BUDL=24:1:25
SET BUDY=$ORDER(^BUDHTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+47 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+48 WRITE !,$$LOW^XLFSTR(BUDL),".",?6,$PIECE(^BUDHTFIV(BUDY,0),U,2)
IF $PIECE(^BUDHTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDHTFIV(BUDY,0),U,3)
+49 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),0)
+50 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+51 WRITE !,BUD80L
End DoDot:1
+52 FOR BUDL=26,27,"27a","27b","27c",28
SET BUDY=$ORDER(^BUDHTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+53 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+54 WRITE !,$$LOW^XLFSTR(BUDL),".",?6,$PIECE(^BUDHTFIV(BUDY,0),U,2)
IF $PIECE(^BUDHTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDHTFIV(BUDY,0),U,3)
+55 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),2),?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+56 WRITE !,BUD80L
End DoDot:1
+57 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+58 WRITE !,"29.",?8,"Total Enabling Services (Lines 24 - 28)",?60,$$C($PIECE(BUDTAB5(29),U,1)),?71,$$C($PIECE(BUDTAB5(29),U,2)),!,BUD80L
+59 IF $Y>(IOSL-5)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+60 WRITE !,"29a.",?8,"Other Programs/ Services",!?8,"(specify__)",?60,$$C($PIECE(BUDTAB5("29a"),U,1),2),?71,$$C($PIECE(BUDTAB5("29a"),U,2),2),!,BUD80L
+61 WRITE !,"29b.",?12,"Quality Improvement Staff",?60,$$C($PIECE(BUDTAB5("29b"),U,1),2),?71,$$C($PIECE(BUDTAB5("29b"),U,2),2),!,BUD80L
+62 FOR BUDL="30A","30B","30C"
SET BUDY=$ORDER(^BUDHTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+63 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+64 WRITE !,$$LOW^XLFSTR(BUDL),".",?6,$PIECE(^BUDHTFIV(BUDY,0),U,2)
IF $PIECE(^BUDHTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDHTFIV(BUDY,0),U,3)
+65 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),2)
+66 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+67 WRITE !,BUD80L
End DoDot:1
+68 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+69 FOR BUDL=31,32
SET BUDY=$ORDER(^BUDHTFIV("B",BUDL,0))
IF BUDQUIT
QUIT
Begin DoDot:1
+70 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+71 WRITE !,$$LOW^XLFSTR(BUDL),".",?6,$PIECE(^BUDHTFIV(BUDY,0),U,2)
IF $PIECE(^BUDHTFIV(BUDY,0),U,3)]""
WRITE !?6,$PIECE(^BUDHTFIV(BUDY,0),U,3)
+72 WRITE ?60,$$C($PIECE(BUDTAB5(BUDL),U,1),2)
+73 WRITE ?71,$$C($PIECE(BUDTAB5(BUDL),U,2),2)
+74 WRITE !,BUD80L
End DoDot:1
+75 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+76 WRITE !,"33.",?8,"Total Facility and Non-Clinical",!?8,"Support Staff (Lines 30a-32)"
+77 WRITE ?60,$$C($PIECE(BUDTAB5(33),U,1),2),?71,$$C($PIECE(BUDTAB5(33),U,2),2),!,BUD80L
+78 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+79 WRITE !,"34.",?8,"Grand Total (Lines ",!?8,"15+19+20+21+22+22d+23+29+29a+29b+33)"
+80 SET Y=0
FOR X=15,19,20,21,22,"22D",29
SET Y=Y+$PIECE(BUDTAB5(X),U)
+81 WRITE ?60,$$C(Y),?71,$$C(Y,2),!,BUD80L
+82 IF $PIECE(BUDTAB5(35),U)
Begin DoDot:1
+83 IF $Y>(IOSL-3)
DO HEADER
IF BUDQUIT
QUIT
DO T5SH
+84 WRITE !!,$PIECE(BUDTAB5(35),U)," visits did not fit into any of the above categories",!
End DoDot:1
+85 WRITE !
+86 QUIT
T5SH ;
+1 WRITE !,$$CTR("TABLE 5 - STAFFING AND UTILIZATION",80)
+2 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+3 WRITE !,?54,"FTEs",?60,"CLINIC",?71,"PATIENTS"
+4 WRITE !?60,"VISITS"
+5 WRITE !,"PERSONNEL BY MAJOR SERVICE CATEGORY",?54,"(a)",?64,"(b)",?73,"(c)"
+6 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+7 QUIT
T6 ;
+1 DO T6^BUDHRPP1
+2 QUIT
T6B ;
+1 DO PRINT^BUDHRP6B
+2 QUIT
T7 ;
+1 DO PRINT^BUDHRP7
+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 ;SECURITY
IF BUDTPG=0
IF '$GET(BUDZLIST)
DO COVPAGET^BUDHUTL1
IF $GET(BUDZLIST)
DO COVPAGEP^BUDHUTL1
SET BUDTPG=1
+2 IF $GET(BUDTPG)=0
GOTO HEADER2
+3 IF $GET(BUDTPG)!($GET(BUDFNP))
IF $DATA(IOF)
WRITE @IOF
+4 ;
SET BUDTPG=$GET(BUDTPG)+1
+1 WRITE $$CTR("***** SENSITIVE INFORMATION *****",IOM),!
+2 SET X=$$CTR($PIECE(^DIC(4,BUDSITE,0),U),55)
SET $EXTRACT(X,3)=$PIECE(^VA(200,DUZ,0),U,2)
SET $EXTRACT(X,10)="UDS 2018"
SET $EXTRACT(X,55)="Section "_BUDSCTC_" of "_BUDTSCTC_", Page "_BUDPG
WRITE !,X
+3 WRITE !,"UDS No. ",$PIECE(^BUDHSITE(BUDSITE,0),U,2),?50,"Date Run: ",$$FMTE^XLFDT(DT)
+4 WRITE !,"Reporting Period: ",$$FMTE^XLFDT(BUDBD)," through ",$$FMTE^XLFDT(BUDED)
+5 WRITE !,"Population: ",$SELECT($GET(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$GET(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$GET(BUDBEN)=3:"All (both Indian/Alaskan Natives and Non 01)",$GET(BUDBEN)=4:"Homeless
",1:"")
+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
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
USR() ;EP - Return name
+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 loc
+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 ;----------
