BUD7RPTP.m

BUD7RPTP ; 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(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

 D PATLISTS

 D EOJ

 Q

 ;

EOJ ;

 K ^TMP($J)

 K ^XTMP("BUD7RPT1",BUDJ,BUDH)

 Q

T4 ;

 Q

T3A ;

 D HEADER Q:BUDQUIT  D T3ASH

 ;print out each line

 S BUDZ=0 F  S BUDZ=$O(^BUDETTA("AC",BUDZ)) Q:BUDZ>38!(BUDQUIT)  D

 .S BUDC=$O(^BUDETTA("AC",BUDZ,0))

 .I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T3ASH

 .S BUDY=^BUDETTA(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(^BUDETTA("B",43,0))

 I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T3ASH

 W !,$P(^BUDETTA(BUDC,0),U,2),?5,$P(^BUDETTA(BUDC,0),U,3)

 S BUDC=$O(^BUDETTA("AC",39,0))

 I $Y>(IOSL-2) D HEADER Q:BUDQUIT  D T3ASH

 S BUDY=^BUDETTA(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(^BUDETTA(1,11)),80),!

 F Y=2:1:4 S X=$O(^BUDETTA("B",Y,0)) W !,$P(^BUDETTA(X,0),U,2),?5,$P(^BUDETTA(X,0),U,3),?33,$P(^BUDETTA(X,0),U,4),?50,$P(^BUDETTA(X,0),U,5),?68,$P(^BUDETTA(X,0),U,6)

 W !,$TR($J("",80)," ","-")

 Q

T3BSH ;

 W !!,$$CTR("TABLE 3B -",80)

 W !,$$CTR("PATIENTS BY RACE/ETHNICITY/LANGUAGE",80),!,BUD80L

 ;W !,$TR($J("",80)," ","-")

 Q

TZSH ;

 W !!,$$CTR("CENTER/GRANTEE PROFILE",80)

 W !,$$CTR("COVER SHEET",80),!

 ;W !,$TR($J("",80)," ","-")

 W !!,$$CTR("PATIENTS BY ZIP CODE",80)

 W !,$TR($J("",80)," ","-")

 W !!?5,"ZIP CODE",?40,"PATIENTS"

 W !,$TR($J("",80)," ","-")

 Q

PATLISTS ;

 D ^BUD7RPTL

 Q

T3B ;

 D HEADER Q:BUDQUIT  D T3BSH

 ;print out each line

 W !?66,"NUMBER"

 W !,"PATIENTS BY HISPANIC/LATINO IDENTITY",?67,"(a)",!,BUD80L

 W !,"NUMBER OF PATIENTS",!,BUD80L

 S BUDX=0 F  S BUDX=$O(BUDHISP(BUDX)) Q:BUDX'=+BUDX!(BUDQUIT)  D

 .I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T3BSH

 .W !?2,$P(BUDHISP(BUDX),U),?8,$P(BUDHISP(BUDX),U,2)

 .I $P(BUDHISP(BUDX),U,4)]"" W !?8,$P(BUDHISP(BUDX),U,4)

 .I $P(BUDHISP(BUDX),U,3)]"" W ?65,$$C($P(BUDHISP(BUDX),U,3))

 .W !,BUD80L

 ;

 I $Y>(IOSL-6) D HEADER Q:BUDQUIT  D T3BSH

 W !!,BUD80L,!?66,"NUMBER"

 W !,"PATIENTS BY RACE",?67,"(a)",!,BUD80L

 W !,"NUMBER OF PATIENTS",!,BUD80L

 F BUDX="5A","5B","5C","5Z",6,7,8,9,10,11 Q:BUDQUIT  D

 .I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T3BSH

 .W !?2,$P(BUDRACET(BUDX),U),?8,$P(BUDRACET(BUDX),U,2)

 .I $P(BUDRACET(BUDX),U,4)]"" W !?8,$P(BUDRACET(BUDX),U,4)

 .I $P(BUDRACET(BUDX),U,3)]"" W ?65,$$C($P(BUDRACET(BUDX),U,3))

 .W !,BUD80L

 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,"12",?8,"PATIENTS BEST SERVED IN A LANGUAGE OTHER THAN ENGLISH",!,BUD80L

 W !

 Q

TZ ;

 D HEADER Q:BUDQUIT  D TZSH

 ;print out each line

 S BUDZTOT=0

 S ^XTMP("BUD7RPT1",BUDJ,BUDH,"ZIP","OTHER ZIP CODES")=0

 ;GET TOTAL

 S BUDZ="" F  S BUDZ=$O(^XTMP("BUD7RPT1",BUDJ,BUDH,"ZIP",BUDZ)) Q:BUDZ=""  D

 .S BUDY=^XTMP("BUD7RPT1",BUDJ,BUDH,"ZIP",BUDZ)

 .S BUDZTOT=BUDZTOT+BUDY

 ;CALCULATE "OTHER"

 S BUDZ="" F  S BUDZ=$O(^XTMP("BUD7RPT1",BUDJ,BUDH,"ZIP",BUDZ)) Q:BUDZ=""  D

 .Q:BUDZ["OTHER"

 .Q:BUDZ["Unknown"

 .S BUDY=^XTMP("BUD7RPT1",BUDJ,BUDH,"ZIP",BUDZ)

 .S X=BUDY/BUDZTOT I X<.001 K ^XTMP("BUD7RPT1",BUDJ,BUDH,"ZIP",BUDZ) S ^XTMP("BUD7RPT1",BUDJ,BUDH,"ZIP","OTHER ZIP CODES")=^XTMP("BUD7RPT1",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("BUD7RPT1",BUDJ,BUDH,"Z",BUDZ,BUDCOM)) Q:BUDCOM=""  D

 ...S BUDSEX="" F  S BUDSEX=$O(^XTMP("BUD7RPT1",BUDJ,BUDH,"Z",BUDZ,BUDCOM,BUDSEX)) Q:BUDSEX=""  D

 ....S BUDNAME="" F  S BUDNAME=$O(^XTMP("BUD7RPT1",BUDJ,BUDH,"Z",BUDZ,BUDCOM,BUDSEX,BUDNAME)) Q:BUDNAME=""  D

 .....S DFN=0 F  S DFN=$O(^XTMP("BUD7RPT1",BUDJ,BUDH,"Z",BUDZ,BUDCOM,BUDSEX,BUDNAME,DFN)) Q:DFN'=+DFN  D

 ......S X=0 F  S X=$O(^XTMP("BUD7RPT1",BUDJ,BUDH,"Z",BUDZ,BUDCOM,BUDSEX,BUDNAME,DFN,X)) Q:X'=+X  D

 .......S ^XTMP("BUD7RPT1",BUDJ,BUDH,"Z",BUDZ_"*",BUDCOM,BUDSEX,BUDNAME,DFN,X)=""

 .......K ^XTMP("BUD7RPT1",BUDJ,BUDH,"Z",BUDZ,BUDCOM,BUDSEX,BUDNAME,DFN,X)

  S BUDZ="" F  S BUDZ=$O(^XTMP("BUD7RPT1",BUDJ,BUDH,"ZIP",BUDZ)) Q:BUDZ=""!(BUDQUIT)  D

 .I $Y>(IOSL-4) D HEADER Q:BUDQUIT  D TZSH

 .S BUDY=^XTMP("BUD7RPT1",BUDJ,BUDH,"ZIP",BUDZ)

 .W !?8,BUDZ,?40,$$C(BUDY),!,BUD80L

 Q:BUDQUIT

 W !!?8,"TOTAL",?40,$$C(BUDZTOT),!

 Q

T5 ;print table 5

 D HEADER Q:BUDQUIT  D T5SH

 ;lines 1-8

 F BUDL=1:1:7 S BUDY=$O(^BUDETFIV("B",BUDL,0)) Q:BUDQUIT  D

 .Q:'BUDY

 .W !

 .I +BUDL<10 W " "

 .W BUDL,".",?6,$P(^BUDETFIV(BUDY,0),U,2)

 .I $P(^BUDETFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDETFIV(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(^BUDETFIV("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(^BUDETFIV(BUDY,0),U,2)

 .I $P(^BUDETFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDETFIV(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(^BUDETFIV("B",BUDL,0)) Q:BUDQUIT  D

 .I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T5SH

 .W !,BUDL,".",?6,$P(^BUDETFIV(BUDY,0),U,2) I $P(^BUDETFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDETFIV(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 - 14)",?60,$$C($P(BUDTAB5(15),U,1)),?71,$$C($P(BUDTAB5(15),U,2)),!,BUD80L

 F BUDL=16:1:17 S BUDY=$O(^BUDETFIV("B",BUDL,0)) Q:BUDQUIT  D

 .I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T5SH

 .W !,BUDL,".",?6,$P(^BUDETFIV(BUDY,0),U,2) I $P(^BUDETFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDETFIV(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(^BUDETFIV("B",BUDL,0)) Q:BUDQUIT  D

 .I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T5SH

 .W !,BUDL,".",?6,$P(^BUDETFIV(BUDY,0),U,2) I $P(^BUDETFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDETFIV(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","20B","20C" S BUDY=$O(^BUDETFIV("B",BUDL,0)) Q:BUDQUIT  D

 .I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T5SH

 .W !,BUDL,".",?6,$P(^BUDETFIV(BUDY,0),U,2)

 .I $P(^BUDETFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDETFIV(BUDY,0),U,3)

 .I $P(^BUDETFIV(BUDY,0),U,4)]"" W !?6,$P(^BUDETFIV(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:1:22 S BUDY=$O(^BUDETFIV("B",BUDL,0)) Q:BUDQUIT  D

 .I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T5SH

 .W !,BUDL,".",?6,$P(^BUDETFIV(BUDY,0),U,2) I $P(^BUDETFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDETFIV(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=23 S BUDY=$O(^BUDETFIV("B",BUDL,0)) Q:BUDQUIT  D

 .I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T5SH

 .W !,BUDL,".",?6,$P(^BUDETFIV(BUDY,0),U,2) I $P(^BUDETFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDETFIV(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(^BUDETFIV("B",BUDL,0)) Q:BUDQUIT  D

 .I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T5SH

 .W !,BUDL,".",?6,$P(^BUDETFIV(BUDY,0),U,2) I $P(^BUDETFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDETFIV(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",28 S BUDY=$O(^BUDETFIV("B",BUDL,0)) Q:BUDQUIT  D

 .I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T5SH

 .W !,BUDL,".",?6,$P(^BUDETFIV(BUDY,0),U,2) I $P(^BUDETFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDETFIV(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

 F BUDL="29A",30,31,32 S BUDY=$O(^BUDETFIV("B",BUDL,0)) Q:BUDQUIT  D

 .I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T5SH

 .W !,BUDL,".",?6,$P(^BUDETFIV(BUDY,0),U,2) I $P(^BUDETFIV(BUDY,0),U,3)]"" W !?6,$P(^BUDETFIV(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,"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",!

 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,"ENCOUNTERS",?71,"PATIENTS"

 W !,"PERSONNEL BY MAJOR SERVICE CATEGORY",?54,"(a)",?64,"(b)",?73,"(c)"

 W !,$TR($J("",80)," ","-")

 Q

T6 ;

 D T6^BUD7RPP1

 Q

HEADER ;EP

 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

HEADER1 ;

 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 2007",$E(X,70)="Page ",$E(X,75)=BUDPG W !,X

 ;W !?3,$P(^VA(200,DUZ,0),U,2),?10,"UDS 2007",$$CTR($P(^DIC(4,BUDSITE,0),U),80),?70,"Page ",BUDPG

 ;W $$CTR($P(^DIC(4,BUDSITE,0),U),80),!

 W !,"UDS No.  ",$P(^BUDESITE(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")

 ;----------

BUD7RPTP  ; 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(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       DO PATLISTS

 +11       DO EOJ

 +12       QUIT 

 +13      ;

EOJ       ;

 +1        KILL ^TMP($JOB)

 +2        KILL ^XTMP("BUD7RPT1",BUDJ,BUDH)

 +3        QUIT 

T4        ;

 +1        QUIT 

T3A       ;

 +1        DO HEADER

           IF BUDQUIT

               QUIT 

           DO T3ASH

 +2       ;print out each line

 +3        SET BUDZ=0

           FOR 

               SET BUDZ=$ORDER(^BUDETTA("AC",BUDZ))

               IF BUDZ>38!(BUDQUIT)

                   QUIT 

               Begin DoDot:1

 +4                SET BUDC=$ORDER(^BUDETTA("AC",BUDZ,0))

 +5                IF $Y>(IOSL-3)

                       DO HEADER

                       IF BUDQUIT

                           QUIT 

                       DO T3ASH

 +6                SET BUDY=^BUDETTA(BUDC,0)

 +7       ;column one End control

                   SET BUDX=$PIECE(BUDY,U,2)

 +8                WRITE !

 +9                IF BUDX<10

                       WRITE " "

 +10               WRITE $PIECE(BUDY,U,2),?5,$PIECE(BUDY,U,3)

 +11      ;I +BUDX=0 Q

 +12               WRITE ?35,$$C($PIECE(BUDTOT("M"),U,BUDX)),?50,$$C($PIECE(BUDTOT("F"),U,BUDX)),?68,$$C($PIECE(BUDTOT("ALL"),U,BUDX))

 +13               IF BUDX=20

                       Begin DoDot:2

 +14                       IF $Y>(IOSL-4)

                               DO HEADER

                               IF BUDQUIT

                                   QUIT 

                               DO T3ASH

 +15                       WRITE !!?10,"SUBTOTAL 0-19",?35,$$C(BUD019("M")),?50,$$C(BUD019("F")),?68,$$C(BUD019("ALL")),!

                       End DoDot:2

               End DoDot:1

 +16       SET BUDC=$ORDER(^BUDETTA("B",43,0))

 +17       IF $Y>(IOSL-3)

               DO HEADER

               IF BUDQUIT

                   QUIT 

               DO T3ASH

 +18       WRITE !,$PIECE(^BUDETTA(BUDC,0),U,2),?5,$PIECE(^BUDETTA(BUDC,0),U,3)

 +19       SET BUDC=$ORDER(^BUDETTA("AC",39,0))

 +20       IF $Y>(IOSL-2)

               DO HEADER

               IF BUDQUIT

                   QUIT 

               DO T3ASH

 +21       SET BUDY=^BUDETTA(BUDC,0)

 +22      ;column one End control

           SET BUDX=$PIECE(BUDY,U,2)

 +23       WRITE !

 +24       WRITE $PIECE(BUDY,U,2),?5,$PIECE(BUDY,U,3)

 +25       WRITE ?35,$$C($PIECE(BUDTOT("M"),U,BUDX)),?50,$$C($PIECE(BUDTOT("F"),U,BUDX)),?68,$$C($PIECE(BUDTOT("ALL"),U,BUDX))

 +26       WRITE !

 +27       QUIT 

T3ASH     ;

 +1        WRITE !,$$CTR($GET(^BUDETTA(1,11)),80),!

 +2        FOR Y=2:1:4

               SET X=$ORDER(^BUDETTA("B",Y,0))

               WRITE !,$PIECE(^BUDETTA(X,0),U,2),?5,$PIECE(^BUDETTA(X,0),U,3),?33,$PIECE(^BUDETTA(X,0),U,4),?50,$PIECE(^BUDETTA(X,0),U,5),?68,$PIECE(^BUDETTA(X,0),U,6)

 +3        WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")

 +4        QUIT 

T3BSH     ;

 +1        WRITE !!,$$CTR("TABLE 3B -",80)

 +2        WRITE !,$$CTR("PATIENTS BY RACE/ETHNICITY/LANGUAGE",80),!,BUD80L

 +3       ;W !,$TR($J("",80)," ","-")

 +4        QUIT 

TZSH      ;

 +1        WRITE !!,$$CTR("CENTER/GRANTEE PROFILE",80)

 +2        WRITE !,$$CTR("COVER SHEET",80),!

 +3       ;W !,$TR($J("",80)," ","-")

 +4        WRITE !!,$$CTR("PATIENTS BY ZIP CODE",80)

 +5        WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")

 +6        WRITE !!?5,"ZIP CODE",?40,"PATIENTS"

 +7        WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")

 +8        QUIT 

PATLISTS  ;

 +1        DO ^BUD7RPTL

 +2        QUIT 

T3B       ;

 +1        DO HEADER

           IF BUDQUIT

               QUIT 

           DO T3BSH

 +2       ;print out each line

 +3        WRITE !?66,"NUMBER"

 +4        WRITE !,"PATIENTS BY HISPANIC/LATINO IDENTITY",?67,"(a)",!,BUD80L

 +5        WRITE !,"NUMBER OF PATIENTS",!,BUD80L

 +6        SET BUDX=0

           FOR 

               SET BUDX=$ORDER(BUDHISP(BUDX))

               IF BUDX'=+BUDX!(BUDQUIT)

                   QUIT 

               Begin DoDot:1

 +7                IF $Y>(IOSL-3)

                       DO HEADER

                       IF BUDQUIT

                           QUIT 

                       DO T3BSH

 +8                WRITE !?2,$PIECE(BUDHISP(BUDX),U),?8,$PIECE(BUDHISP(BUDX),U,2)

 +9                IF $PIECE(BUDHISP(BUDX),U,4)]""

                       WRITE !?8,$PIECE(BUDHISP(BUDX),U,4)

 +10               IF $PIECE(BUDHISP(BUDX),U,3)]""

                       WRITE ?65,$$C($PIECE(BUDHISP(BUDX),U,3))

 +11               WRITE !,BUD80L

               End DoDot:1

 +12      ;

 +13       IF $Y>(IOSL-6)

               DO HEADER

               IF BUDQUIT

                   QUIT 

               DO T3BSH

 +14       WRITE !!,BUD80L,!?66,"NUMBER"

 +15       WRITE !,"PATIENTS BY RACE",?67,"(a)",!,BUD80L

 +16       WRITE !,"NUMBER OF PATIENTS",!,BUD80L

 +17       FOR BUDX="5A","5B","5C","5Z",6,7,8,9,10,11

               IF BUDQUIT

                   QUIT 

               Begin DoDot:1

 +18               IF $Y>(IOSL-3)

                       DO HEADER

                       IF BUDQUIT

                           QUIT 

                       DO T3BSH

 +19               WRITE !?2,$PIECE(BUDRACET(BUDX),U),?8,$PIECE(BUDRACET(BUDX),U,2)

 +20               IF $PIECE(BUDRACET(BUDX),U,4)]""

                       WRITE !?8,$PIECE(BUDRACET(BUDX),U,4)

 +21               IF $PIECE(BUDRACET(BUDX),U,3)]""

                       WRITE ?65,$$C($PIECE(BUDRACET(BUDX),U,3))

 +22               WRITE !,BUD80L

               End DoDot:1

 +23       IF $Y>(IOSL-6)

               DO HEADER

               IF BUDQUIT

                   QUIT 

               DO T3BSH

 +24       WRITE !!,BUD80L,!?66,"NUMBER"

 +25       WRITE !,"PATIENTS BY LANGUAGE",?67,"(a)",!,BUD80L

 +26       WRITE !,"NUMBER OF PATIENTS",!,BUD80L

 +27       WRITE !?2,"12",?8,"PATIENTS BEST SERVED IN A LANGUAGE OTHER THAN ENGLISH",!,BUD80L

 +28       WRITE !

 +29       QUIT 

TZ        ;

 +1        DO HEADER

           IF BUDQUIT

               QUIT 

           DO TZSH

 +2       ;print out each line

 +3        SET BUDZTOT=0

 +4        SET ^XTMP("BUD7RPT1",BUDJ,BUDH,"ZIP","OTHER ZIP CODES")=0

 +5       ;GET TOTAL

 +6        SET BUDZ=""

           FOR 

               SET BUDZ=$ORDER(^XTMP("BUD7RPT1",BUDJ,BUDH,"ZIP",BUDZ))

               IF BUDZ=""

                   QUIT 

               Begin DoDot:1

 +7                SET BUDY=^XTMP("BUD7RPT1",BUDJ,BUDH,"ZIP",BUDZ)

 +8                SET BUDZTOT=BUDZTOT+BUDY

               End DoDot:1

 +9       ;CALCULATE "OTHER"

 +10       SET BUDZ=""