Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BUDRPTP

BUDRPTP.m

Go to the documentation of this file. 
  1. BUDRPTP ; IHS/CMI/LAB - UDS REPORT PRINT ;
  1.  ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
  1.  ;
  1. PRINT ;EP
  1.  S BUDPG=0
  1.  S BUDQUIT=0
  1.  S BUD80L="",$P(BUD80L,"_",79)="_"
  1.  I $G(BUDT3A) D T3A G:BUDQUIT EOJ
  1.  I $G(BUDT3B) D T3B G:BUDQUIT EOJ
  1.  I $G(BUDT4) D T4 G:BUDQUIT EOJ
  1.  I $G(BUDT5) D T5 G:BUDQUIT EOJ
  1.  I $G(BUDT6) D T6 G:BUDQUIT EOJ
  1.  D PATLISTS
  1.  D EOJ
  1.  Q
  1.  ;
  1. EOJ ;
  1.  K ^TMP($J)
  1.  K ^XTMP("BUDRPT1",BUDJ,BUDH)
  1.  Q
  1. T4 ;
  1.  Q
  1. T3A ;
  1.  D HEADER Q:BUDQUIT  D T3ASH
  1.  ;print out each line
  1.  S BUDC=3 F  S BUDC=$O(^BUDTTA("B",BUDC)) Q:BUDC'=+BUDC!(BUDQUIT)  D
  1.  .I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T3ASH
  1.  .S BUDY=^BUDTTA(BUDC,0)
  1.  .S BUDX=$P(BUDY,U,2)  ;column one and control
  1.  .W !
  1.  .I BUDX<10 W " "
  1.  .W $P(BUDY,U,2),?5,$P(BUDY,U,3)
  1.  .;I +BUDX=0 Q
  1.  .W ?35,$$C($P(BUDTOT("M"),U,BUDX)),?50,$$C($P(BUDTOT("F"),U,BUDX)),?68,$$C($P(BUDTOT("ALL"),U,BUDX))
  1.  .I BUDX=20 D
  1.  ..I $Y>(IOSL-4) D HEADER Q:BUDQUIT  D T3ASH
  1.  ..W !!?10,"SUBTOTAL 0-19",?35,$$C(BUD019("M")),?50,$$C(BUD019("F")),?68,$$C(BUD019("ALL")),!
  1.  Q
  1. T3ASH ;
  1.  W !,$$CTR($G(^BUDTTA(1,11)),80),!
  1.  F X=2:1:3 W !,$P(^BUDTTA(X,0),U,2),?5,$P(^BUDTTA(X,0),U,3),?33,$P(^BUDTTA(X,0),U,4),?50,$P(^BUDTTA(X,0),U,5),?68,$P(^BUDTTA(X,0),U,6)
  1.  W !,$TR($J("",80)," ","-"),!
  1.  Q
  1. T3BSH ;
  1.  W !!,$$CTR("TABLE 3B -",80)
  1.  W !,$$CTR("USERS BY RACE/ETHNICITY/LANGUAGE",80),!
  1.  W !,$TR($J("",80)," ","-")
  1.  W !,"RACE/ETHNICITY/LANGUAGE",?65,"NUMBER (a)"
  1.  W !,"PROPORTION OF USERS"
  1.  W !,$TR($J("",80)," ","-")
  1.  Q
  1. PATLISTS ;
  1.  D ^BUDRPTL
  1.  Q
  1. T3B ;
  1.  D HEADER Q:BUDQUIT  D T3BSH
  1.  ;print out each line
  1.  W !?3,"1a.",?8,"Asian",?65,$$C(BUDRACET("1A")),!,BUD80L
  1.  W !?3,"1b.",?8,"Native Hawaiian",?65,$$C(BUDRACET("1B")),!,BUD80L
  1.  W !?3,"1c.",?8,"Other Pacific Islander",?65,$$C(BUDRACET("1C")),!,BUD80L
  1.  I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T3BSH
  1.  W !,"1.",?13,"Asian/Pacific Islander (sum lines 1a+1b+1c)",?65,$$C(BUDRACET("1A")+BUDRACET("1B")+BUDRACET("1C")),!,BUD80L
  1.  I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T3BSH
  1.  W !,"2.",?8,"Black/African American (not Hispanic or Latino)",?65,$$C(BUDRACET(2)),!,BUD80L
  1.  I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T3BSH
  1.  W !,"3.",?8,"American Indian/Alaska Native",?65,$$C(BUDRACET(3)),!,BUD80L
  1.  I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T3BSH
  1.  W !,"4.",?8,"White (not Hispanic or Latino)",?65,$$C(BUDRACET(4)),!,BUD80L
  1.  I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T3BSH
  1.  W !,"5.",?8,"Hispanic or Latino (all races)",?65,$$C(BUDRACET(5)),!,BUD80L
  1.  I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T3BSH
  1.  W !,"6.",?8,"Unreported / Refused to Report",?65,$$C(BUDRACET(6)),!,BUD80L
  1.  I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T3BSH
  1.  S Y=0 F X="1A","1B","1C",1,2,3,4,5,6 S Y=Y+$G(BUDRACET(X))
  1.  W !,"7.",?12,"TOTAL USERS (SUM LINES 1-6)",?65,$$C(Y),!,BUD80L
  1.  I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T3BSH
  1.  W !,"8.",?8,"Users needing interpretation/Bilingual/Sign Language Services",!,BUD80L
  1.  Q
  1. T5 ;print table 5
  1.  D HEADER Q:BUDQUIT  D T5SH
  1.  ;lines 1-8
  1.  F BUDL=1:1:7 S BUDY=$O(^BUDTFIVE("B",BUDL,0)) Q:BUDQUIT  D
  1.  .W !
  1.  .I +BUDL<10 W " "
  1.  .W BUDL,".",?6,$P(^BUDTFIVE(BUDY,0),U,2)
  1.  .W ?60,$$C($P(BUDTAB5(BUDL),U,1),0)
  1.  .W ?71,$$C($P(BUDTAB5(BUDL),U,2),2)
  1.  .W !,BUD80L
  1.  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
  1.  ;print out lines 9-15
  1.  F BUDL=9:1:11 S BUDY=$O(^BUDTFIVE("B",BUDL,0)) Q:BUDQUIT  D
  1.  .I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T5SH
  1.  .W !
  1.  .I +BUDL<10 W " "
  1.  .W BUDL,".",?6,$P(^BUDTFIVE(BUDY,0),U,2)
  1.  .W ?60,$$C($P(BUDTAB5(BUDL),U,1),0)
  1.  .W ?71,$$C($P(BUDTAB5(BUDL),U,2),2)
  1.  .W !,BUD80L
  1.  F BUDL=12:1:14 S BUDY=$O(^BUDTFIVE("B",BUDL,0)) Q:BUDQUIT  D
  1.  .I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T5SH
  1.  .W !,BUDL,".",?6,$P(^BUDTFIVE(BUDY,0),U,2)
  1.  .W ?60,$$C($P(BUDTAB5(BUDL),U,1),2)
  1.  .W ?71,$$C($P(BUDTAB5(BUDL),U,2),2)
  1.  .W !,BUD80L
  1.  I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T5SH
  1.  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
  1.  F BUDL=16:1:17 S BUDY=$O(^BUDTFIVE("B",BUDL,0)) Q:BUDQUIT  D
  1.  .I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T5SH
  1.  .W !,BUDL,".",?6,$P(^BUDTFIVE(BUDY,0),U,2)
  1.  .W ?60,$$C($P(BUDTAB5(BUDL),U,1),0)
  1.  .W ?71,$$C($P(BUDTAB5(BUDL),U,2),2)
  1.  .W !,BUD80L
  1. T518 F BUDL=18 S BUDY=$O(^BUDTFIVE("B",BUDL,0)) Q:BUDQUIT  D
  1.  .I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T5SH
  1.  .W !,BUDL,".",?6,$P(^BUDTFIVE(BUDY,0),U,2)
  1.  .W ?60,$$C($P(BUDTAB5(BUDL),U,1),2)
  1.  .W ?71,$$C($P(BUDTAB5(BUDL),U,2),2)
  1.  .W !,BUD80L
  1.  I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T5SH
  1.  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
  1.  D HEADER Q:BUDQUIT  D T5SH  ;force page break before line 20
  1.  F BUDL=20:1:22 S BUDY=$O(^BUDTFIVE("B",BUDL,0)) Q:BUDQUIT  D
  1.  .I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T5SH
  1.  .W !,BUDL,".",?6,$P(^BUDTFIVE(BUDY,0),U,2)
  1.  .I $P(^BUDTFIVE(BUDY,0),U,3)]"" W !?6,$P(^BUDTFIVE(BUDY,0),U,3)
  1.  .I $P(^BUDTFIVE(BUDY,0),U,4)]"" W !?6,$P(^BUDTFIVE(BUDY,0),U,4)
  1.  .W ?60,$$C($P(BUDTAB5(BUDL),U,1),0)
  1.  .W ?71,$$C($P(BUDTAB5(BUDL),U,2),0)
  1.  .W !,BUD80L
  1.  F BUDL=23 S BUDY=$O(^BUDTFIVE("B",BUDL,0)) Q:BUDQUIT  D
  1.  .I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T5SH
  1.  .W !,BUDL,".",?6,$P(^BUDTFIVE(BUDY,0),U,2)
  1.  .W ?60,$$C($P(BUDTAB5(BUDL),U,1),2)
  1.  .W ?71,$$C($P(BUDTAB5(BUDL),U,2),2)
  1.  .W !,BUD80L
  1.  F BUDL=24:1:25 S BUDY=$O(^BUDTFIVE("B",BUDL,0)) Q:BUDQUIT  D
  1.  .I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T5SH
  1.  .W !,BUDL,".",?6,$P(^BUDTFIVE(BUDY,0),U,2)
  1.  .W ?60,$$C($P(BUDTAB5(BUDL),U,1),0)
  1.  .W ?71,$$C($P(BUDTAB5(BUDL),U,2),2)
  1.  .W !,BUD80L
  1.  F BUDL=26:1:28 S BUDY=$O(^BUDTFIVE("B",BUDL,0)) Q:BUDQUIT  D
  1.  .I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T5SH
  1.  .W !,BUDL,".",?6,$P(^BUDTFIVE(BUDY,0),U,2)
  1.  .W ?60,$$C($P(BUDTAB5(BUDL),U,1),2)
  1.  .W ?71,$$C($P(BUDTAB5(BUDL),U,2),2)
  1.  .W !,BUD80L
  1.  I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T5SH
  1.  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
  1.  F BUDL="29A",30,31,32 S BUDY=$O(^BUDTFIVE("B",BUDL,0)) Q:BUDQUIT  D
  1.  .I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T5SH
  1.  .W !,BUDL,".",?6,$P(^BUDTFIVE(BUDY,0),U,2)
  1.  .W ?60,$$C($P(BUDTAB5(BUDL),U,1),2)
  1.  .W ?71,$$C($P(BUDTAB5(BUDL),U,2),2)
  1.  .W !,BUD80L
  1.  I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T5SH
  1.  W !,"33.",?10,"TOTAL ADMINISTRATION AND FACILITY",!?10,"(TOTAL LINES 30+31+32)"
  1.  W ?60,$$C($P(BUDTAB5(33),U,1),2),?71,$$C($P(BUDTAB5(33),U,2),2),!,BUD80L
  1.  I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T5SH
  1.  W !,"34.",?10,"GRAND TOTAL: (TOTAL LINES",!?10,"(15+19+20+21+22+23+29+29A+33)"
  1.  S Y=0 F X=15,19,20,21,22,29,33 S Y=Y+$P(BUDTAB5(X),U)
  1.  W ?60,$$C(Y),?71,$$C(Y,2),!,BUD80L
  1.  I $P(BUDTAB5(35),U) D
  1.  .I $Y>(IOSL-3) D HEADER Q:BUDQUIT  D T5SH
  1.  .W !!,$P(BUDTAB5(35),U)," encounters did not fit into any of the above categories",!
  1.  Q
  1. T5SH ;
  1.  W !,$$CTR("TABLE 5 - STAFFING AND UTILIZATION",80)
  1.  ;W !,$$CTR("STAFFING AND UTILIZATION",80),!
  1.  W !,$TR($J("",80)," ","-")
  1.  W !,?54,"FTEs",?60,"ENCOUNTERS",?71," USERS"
  1.  W !,"PERSONNEL BY MAJOR SERVICE CATEGORY",?54,"(a)",?64,"(b)",?73,"(c)"
  1.  W !,$TR($J("",80)," ","-")
  1.  Q
  1. T6 ;
  1.  D T6^BUDRPTP1
  1.  Q
  1.  G:'BUDPG HEADER1
  1.  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
  1. HEADER1 ;
  1.  W:$D(IOF) @IOF S BUDPG=BUDPG+1
  1.  W !?3,$P(^VA(200,DUZ,0),U,2),$$CTR($P(^DIC(4,BUDSITE,0),U),80),?70,"Page ",BUDPG
  1.  ;W $$CTR($P(^DIC(4,BUDSITE,0),U),80),!
  1.  W !,"UDS No.  ",$P(^BUDUSITE(BUDSITE,0),U,2),?50,"Date Run: ",$$FMTE^XLFDT(DT)
  1.  W !,"Reporting Period:  ",$$FMTE^XLFDT(BUDBD)," through ",$$FMTE^XLFDT(BUDED)
  1.  W !
  1.  Q
  1. C(X,Y) ;
  1.  I $G(Y)=1,+X=0 Q ""
  1.  I $G(Y)=2 Q "********"
  1.  S X2=0,X3=8
  1.  D COMMA^%DTC
  1.  Q X
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1. USR() ;EP - Return name of current user from ^VA(200.
  1.  Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
  1.  ;----------
  1. LOC() ;EP - Return location name from file 4 based on DUZ(2).
  1.  Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
  1.  ;----------