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