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

BUDARPL4.m

Go to the documentation of this file. 
  1. BUDARPL4 ; IHS/CMI/LAB - UDS REPORT DRIVER TABLE 6B ;
  1.  ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
  1.  ;
  1.  ;
  1.  ;
  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.  ;----------
  1. RACEL(R,E) ;EP
  1.  I R=1,E=1 Q "Line 1:  Asian, Hispanic"
  1.  I R=1,E=2 Q "Line 1:  Asian, Non-Hispanic"
  1.  I R=2,E=1 Q "Line 2a:  Native Hawaiian, Hispanic"
  1.  I R=2,E=2 Q "Line 2a:  Native Hawaiian, Non-Hispanic"
  1.  I R=3,E=1 Q "Line 2b:  Other Pacific Islander, Hispanic"
  1.  I R=3,E=2 Q "Line 2b:  Other Pacific Islander, Non-Hispanic"
  1.  I R=4,E=1 Q "Line 3:  Black/African American, Hispanic"
  1.  I R=4,E=2 Q "Line 3:  Black/African American, Non-Hispanic"
  1.  I R=5,E=1 Q "Line 4:  American Indian/Alaska Native, Hispanic"
  1.  I R=5,E=2 Q "Line 4:  American Indian/Alaska Native, Non-Hispanic"
  1.  I R=6,E=1 Q "Line 5:  White, Hispanic"
  1.  I R=6,E=2 Q "Line 5:  White, Non-Hispanic"
  1.  I R=7,E=1 Q "Line 6:  More than one race, Hispanic"
  1.  I R=7,E=2 Q "Line 6:  More than one race, Non-Hispanic"
  1.  I R=8,E=1 Q "Line 7:  Unreported / Refused to Report, Hispanic"
  1.  I R=8,E=2 Q "Line 7:  Unreported / Refused to Report, Non-Hispanic"
  1.  I R=8,E=3 Q "Line 7:  Unreported / Refused to Report, Unreported / Refused to Report"
  1.  Q "UNKNOWN"
  1.  ;
  1. RACE(R) ;EP
  1.  I R="UNREP/REF" Q "7-Line 7: Unreported"
  1.  I R="ASIAN" Q "3-Line 1: Asian"
  1.  I R="NATIVE HAWAIIAN" Q "1-Line 2a: Native Hawaiian"
  1.  I R="OTH PAC ISLANDER" Q "2-Line 2b: Other Pacific Islander"
  1.  I R="BLACK" Q "4-Line 3: Black/African American"
  1.  I R="AI/AN" Q "5-Line 4: American Indian/Alaska Native"
  1.  I R="WHITE" Q "6-Line 5: White"
  1.  I R="HISPANIC,WHITE" Q "6-Line 5: White"
  1.  I R="HISPANIC,BLACK" Q "5-Line 3: Black/African American"
  1.  Q ""
  1. T3BR ;EP
  1.  S BUDP=0,BUDQUIT=0,BUDTOT=0
  1.  D T3BRH Q:BUDQUIT
  1.  I '$D(^XTMP("BUDARPT1",BUDJ,BUDH,"3BR")) W !!,"No patients to report." Q
  1.  D T3BRL1
  1.  I $Y>(IOSL-3) D T3BRH G:BUDQUIT T3BRLX
  1.  W !!,"TOTAL PATIENTS: ",BUDTOT,!
  1. T3BRLX ;
  1.  Q
  1. T3BRL1 ;
  1.  I $Y>(IOSL-7) D T3BRH Q:BUDQUIT
  1.  S BUDTOT=0
  1.  S BUDRACE="" F  S BUDRACE=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"3BR",BUDRACE)) Q:BUDRACE=""!(BUDQUIT)  D
  1.  .S BUDETH="" F  S BUDETH=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"3BR",BUDRACE,BUDETH)) Q:BUDETH=""!(BUDQUIT)  D T3BRL2
  1.  Q
  1. T3BRL2 ;
  1.  S BUDSTOT=0
  1.  S BUDRACEL=$$RACEL(BUDRACE,BUDETH)
  1.  W !,BUDRACEL
  1.  S BUDA="" F  S BUDA=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"3BR",BUDRACE,BUDETH,BUDA)) Q:BUDA=""!(BUDQUIT)  D
  1.  .S BUDSEX="" F  S BUDSEX=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"3BR",BUDRACE,BUDETH,BUDA,BUDSEX)) Q:BUDSEX=""!(BUDQUIT)  D
  1.  ..S BUDCOM="" F  S BUDCOM=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"3BR",BUDRACE,BUDETH,BUDA,BUDSEX,BUDCOM)) Q:BUDCOM=""!(BUDQUIT)  D
  1.  ...S DFN=0 F  S DFN=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"3BR",BUDRACE,BUDETH,BUDA,BUDSEX,BUDCOM,DFN)) Q:DFN'=+DFN!(BUDQUIT)  D
  1.  ....I $Y>(IOSL-3) D T3BRH Q:BUDQUIT  W !,BUDRACEL,!
  1.  ....S BUDTOT=BUDTOT+1,BUDSTOT=BUDSTOT+1
  1.  ....W !,$E($P(^DPT(DFN,0),U,1),1,22),?24,$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))
  1.  ....W ?36,$E(BUDCOM,1,12),?51,$P(^DPT(DFN,0),U,2),?55,$$AGE^AUPNPAT(DFN,BUDCAD)
  1.  ....S BUDRACV=$$RACE^BUDARPTC(DFN)
  1.  ....W !?2,$E($P(BUDRACV,U,4),1,16)_" ("_$P(BUDRACV,U,3),")"  ;,?60,$E($P($$RACE^BUDARPTC(DFN),U,3)_"-"_$P($$RACE^BUDARPTC(DFN),U,4),1,19)
  1.  ....S BUDHISV=$$HISP^BUDARPTC(DFN)
  1.  ....W ?24,$P(BUDHISV,U,3)," (",$P(BUDHISV,U,2),")"
  1.  ....S BUDV=0 F  S BUDV=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"3BR",BUDRACE,BUDETH,BUDA,BUDSEX,BUDCOM,DFN,BUDV)) Q:BUDV'=+BUDV!(BUDQUIT)  D
  1.  .....I $Y>(IOSL-3) D T3BRH Q:BUDQUIT  W !,BUDRACEL,!
  1.  .....W !?5,$$FMTE^XLFDT($P($P(^AUPNVSIT(BUDV,0),U),".")),?25,$E($$PRIMPROV^APCLV(BUDV,"E"),1,14),?42,$P(^AUPNVSIT(BUDV,0),U,7),?45,$E($$CLINIC^APCLV(BUDV,"E"),1,14),?62,$E($$LOCENC^APCLV(BUDV,"E"),1,14)
  1.  I $Y>(IOSL-4) D T3BRH Q:BUDQUIT
  1.  W !!,"Sub-Total ",BUDRACEL,":  ",BUDSTOT,!
  1.  Q
  1. T3BRH ;
  1.  G:'BUDGPG T3BRH1
  1.  K DIR I $E(IOST)="C",IO=IO(0),'$D(ZTQUEUED) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BUDQUIT=1 Q
  1. T3BRH1 ;
  1.  W:$D(IOF) @IOF S BUDGPG=BUDGPG+1
  1.  W !,"***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****"
  1.  W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BUDGPG,!
  1.  W !,$$CTR("***  RPMS Uniform Data System (UDS)  ***",80)
  1.  W !,$$CTR("Patient List for Table 3B, Patients by Hispanic or Latino Identity and Race",80),!
  1.  W $$CTR($P(^DIC(4,BUDSITE,0),U),80),!
  1.  S X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED) W $$CTR(X,80),!
  1.  S X="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)",1:"") W $$CTR(X,80),!
  1.  W $TR($J("",80)," ","-")
  1.  I BUDP=0 D
  1.  .W !,"List of all patients with one or more visits during the calendar year, with"
  1.  .W !,"gender, age, Hispanic or Latino Identity, race, and visit information."
  1.  .W !,"Age is calculated as of June 30."
  1.  .W !,"* (E) - denotes the value was obtained from the Ethnicity field"
  1.  .W !,"  (R) - denotes the value was obtained from the Race field"
  1.  .W !,"  (C) - denotes the value was obtained from the Classification/Beneficiary field"
  1.  .W !
  1.  W !,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?50,"SEX",?55,"AGE"
  1.  W !,?2,"RACE*",?24,"HISPANIC OR LATINO IDENTITY*"
  1.  W !?5,"VISIT DATE",?25,"PROV TYPE",?41,"SRV",?45,"CLINIC",?62,"LOCATION"
  1.  W !,$TR($J("",80)," ","-"),!
  1.  S BUDP=1
  1.  Q
  1.  ;
  1. T3BE ;EP
  1.  S BUDP=0,BUDQUIT=0,BUDTOT=0
  1.  D T3BEH Q:BUDQUIT
  1.  I '$D(^XTMP("BUDARPT1",BUDJ,BUDH,"3BE")) W !!,"No patients to report." Q
  1.  D T3BEL1
  1.  I $Y>(IOSL-3) D T3BEH G:BUDQUIT T3BELX
  1.  W !!,"TOTAL PATIENTS: ",BUDTOT,!
  1. T3BELX ;
  1.  Q
  1. T3BEL1 ;
  1.  I $Y>(IOSL-7) D T3BEH Q:BUDQUIT
  1.  S BUDTOT=0
  1.  S BUDRACE="" F  S BUDRACE=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"3BE",BUDRACE)) Q:BUDRACE=""!(BUDQUIT)  D T3BEL2
  1.  Q
  1. T3BEL2 ;
  1.  S BUDSTOT=0
  1.  W !,$P(BUDRACE,"-",1),!
  1.  S BUDA="" F  S BUDA=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"3BE",BUDRACE,BUDA)) Q:BUDA=""!(BUDQUIT)  D
  1.  .S BUDSEX="" F  S BUDSEX=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"3BE",BUDRACE,BUDA,BUDSEX)) Q:BUDSEX=""!(BUDQUIT)  D
  1.  ..S BUDCOM="" F  S BUDCOM=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"3BE",BUDRACE,BUDA,BUDSEX,BUDCOM)) Q:BUDCOM=""!(BUDQUIT)  D
  1.  ...S DFN=0 F  S DFN=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"3BE",BUDRACE,BUDA,BUDSEX,BUDCOM,DFN)) Q:DFN'=+DFN!(BUDQUIT)  D
  1.  ....I $Y>(IOSL-3) D T3BEH Q:BUDQUIT  W !,$P(BUDRACE,"-",1),!
  1.  ....S BUDTOT=BUDTOT+1,BUDSTOT=BUDSTOT+1
  1.  ....W !,$E($P(^DPT(DFN,0),U,1),1,22),?24,$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))
  1.  ....W ?36,$E(BUDCOM,1,12),?51,$P(^DPT(DFN,0),U,2),?55,$$AGE^AUPNPAT(DFN,BUDCAD),?60,$E($P($$HISP^BUDARPTC(DFN),U,2)_"-"_$P($$HISP^BUDARPTC(DFN),U,3),1,19)
  1.  ....S BUDV=0 F  S BUDV=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"3BE",BUDRACE,BUDA,BUDSEX,BUDCOM,DFN,BUDV)) Q:BUDV'=+BUDV!(BUDQUIT)  D
  1.  .....I $Y>(IOSL-3) D T3BEH Q:BUDQUIT  W !,$P(BUDRACE,"-",1),!
  1.  .....W !?5,$$FMTE^XLFDT($P($P(^AUPNVSIT(BUDV,0),U),".")),?25,$E($$PRIMPROV^APCLV(BUDV,"E"),1,14),?42,$P(^AUPNVSIT(BUDV,0),U,7),?45,$E($$CLINIC^APCLV(BUDV,"E"),1,14),?62,$E($$LOCENC^APCLV(BUDV,"E"),1,14)
  1.  I $Y>(IOSL-4) D T3BEH Q:BUDQUIT
  1.  W !!,"Sub-Total ",$P(BUDRACE,"-",1),":  ",BUDSTOT,!
  1.  Q
  1. T3BEH ;
  1.  G:'BUDGPG T3BEH1
  1.  K DIR I $E(IOST)="C",IO=IO(0),'$D(ZTQUEUED) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BUDQUIT=1 Q
  1. T3BEH1 ;
  1.  W:$D(IOF) @IOF S BUDGPG=BUDGPG+1
  1.  W !,"***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****"
  1.  W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BUDGPG,!
  1.  W !,$$CTR("***  RPMS Uniform Data System (UDS)  ***",80)
  1.  W !,$$CTR("Patient List for Table 3B, Patients by Ethnicity",80),!
  1.  W $$CTR($P(^DIC(4,BUDSITE,0),U),80),!
  1.  S X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED) W $$CTR(X,80),!
  1.  S X="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)",1:"") W $$CTR(X,80),!
  1.  W $TR($J("",80)," ","-")
  1.  I BUDP=0 D
  1.  .W !,"List of all patients with one or more visits during the calendar year, with"
  1.  .W !,"gender, age, ethnicity, and visit information."
  1.  .W !,"Age is calculated as of June 30."
  1.  .W !,"* E- denotes the value was obtained from the Ethnicity field"
  1.  .W !,"  R- denotes the value was obtained from the Race field"
  1.  .W !,"  C- denotes the value was obtained from the Classification/Beneficiary field"
  1.  .W !
  1.  W !,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?50,"SEX",?55,"AGE",?60,"ETHNICITY*"
  1.  W !?5,"VISIT DATE",?25,"PROV TYPE",?41,"SRV",?45,"CLINIC",?62,"LOCATION"
  1.  W !,$TR($J("",80)," ","-"),!
  1.  S BUDP=1
  1.  Q
  1.  ;