BUD8RPL4 ; 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")
;----------
RACE(R) ;EP
I R="UNREP/REF" Q "7-Line 10: Unreported"
I R="ASIAN" Q "3-Line 5a: Asian"
I R="NATIVE HAWAIIAN" Q "1-Line 5b: Native Hawaiian"
I R="OTH PAC ISLANDER" Q "2-Line 5c: Other Pacific Islander"
I R="BLACK" Q "4-Line 6: Black/African American"
I R="AI/AN" Q "5-Line 7: American Indian/Alaska Native"
I R="WHITE" Q "6-Line 8: White"
I R="HISPANIC,WHITE" Q "6-Line 8: White"
I R="HISPANIC,BLACK" Q "5-Line 7: Black/African American"
Q ""
T3BR ;EP
S BUDP=0,BUDQUIT=0,BUDTOT=0
D T3BRH Q:BUDQUIT
I '$D(^XTMP("BUD8RPT1",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("BUD8RPT1",BUDJ,BUDH,"3BR",BUDRACE)) Q:BUDRACE=""!(BUDQUIT) D T3BRL2
Q
T3BRL2 ;
S BUDSTOT=0
W !,$P(BUDRACE,"-",2),!
S BUDA="" F S BUDA=$O(^XTMP("BUD8RPT1",BUDJ,BUDH,"3BR",BUDRACE,BUDA)) Q:BUDA=""!(BUDQUIT) D
.S BUDSEX="" F S BUDSEX=$O(^XTMP("BUD8RPT1",BUDJ,BUDH,"3BR",BUDRACE,BUDA,BUDSEX)) Q:BUDSEX=""!(BUDQUIT) D
..S BUDCOM="" F S BUDCOM=$O(^XTMP("BUD8RPT1",BUDJ,BUDH,"3BR",BUDRACE,BUDA,BUDSEX,BUDCOM)) Q:BUDCOM=""!(BUDQUIT) D
...S DFN=0 F S DFN=$O(^XTMP("BUD8RPT1",BUDJ,BUDH,"3BR",BUDRACE,BUDA,BUDSEX,BUDCOM,DFN)) Q:DFN'=+DFN!(BUDQUIT) D
....I $Y>(IOSL-3) D T3BRH Q:BUDQUIT W !,$P(BUDRACE,"-",2),!
....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($$RACE^BUD8RPTC(DFN),U,3)_"-"_$P($$RACE^BUD8RPTC(DFN),U,4),1,19)
....S BUDV=0 F S BUDV=$O(^XTMP("BUD8RPT1",BUDJ,BUDH,"3BR",BUDRACE,BUDA,BUDSEX,BUDCOM,DFN,BUDV)) Q:BUDV'=+BUDV!(BUDQUIT) D
.....I $Y>(IOSL-3) D T3BRH Q:BUDQUIT W !,$P(BUDRACE,"-",2),!
.....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 ",$P(BUDRACE,"-",2),": ",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 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, race, and visit information."
.W !,"Age is calculated as of June 30."
.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,"RACE*"
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("BUD8RPT1",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("BUD8RPT1",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("BUD8RPT1",BUDJ,BUDH,"3BE",BUDRACE,BUDA)) Q:BUDA=""!(BUDQUIT) D
.S BUDSEX="" F S BUDSEX=$O(^XTMP("BUD8RPT1",BUDJ,BUDH,"3BE",BUDRACE,BUDA,BUDSEX)) Q:BUDSEX=""!(BUDQUIT) D
..S BUDCOM="" F S BUDCOM=$O(^XTMP("BUD8RPT1",BUDJ,BUDH,"3BE",BUDRACE,BUDA,BUDSEX,BUDCOM)) Q:BUDCOM=""!(BUDQUIT) D
...S DFN=0 F S DFN=$O(^XTMP("BUD8RPT1",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^BUD8RPTC(DFN),U,2)_"-"_$P($$HISP^BUD8RPTC(DFN),U,3),1,19)
....S BUDV=0 F S BUDV=$O(^XTMP("BUD8RPT1",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
;
BUD8RPL4 ; 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 ;----------
RACE(R) ;EP
+1 IF R="UNREP/REF"
QUIT "7-Line 10: Unreported"
+2 IF R="ASIAN"
QUIT "3-Line 5a: Asian"
+3 IF R="NATIVE HAWAIIAN"
QUIT "1-Line 5b: Native Hawaiian"
+4 IF R="OTH PAC ISLANDER"
QUIT "2-Line 5c: Other Pacific Islander"
+5 IF R="BLACK"
QUIT "4-Line 6: Black/African American"
+6 IF R="AI/AN"
QUIT "5-Line 7: American Indian/Alaska Native"
+7 IF R="WHITE"
QUIT "6-Line 8: White"
+8 IF R="HISPANIC,WHITE"
QUIT "6-Line 8: White"
+9 IF R="HISPANIC,BLACK"
QUIT "5-Line 7: 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("BUD8RPT1",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("BUD8RPT1",BUDJ,BUDH,"3BR",BUDRACE))
IF BUDRACE=""!(BUDQUIT)
QUIT
DO T3BRL2
+4 QUIT
T3BRL2 ;
+1 SET BUDSTOT=0
+2 WRITE !,$PIECE(BUDRACE,"-",2),!
+3 SET BUDA=""
FOR
SET BUDA=$ORDER(^XTMP("BUD8RPT1",BUDJ,BUDH,"3BR",BUDRACE,BUDA))
IF BUDA=""!(BUDQUIT)
QUIT
Begin DoDot:1
+4 SET BUDSEX=""
FOR
SET BUDSEX=$ORDER(^XTMP("BUD8RPT1",BUDJ,BUDH,"3BR",BUDRACE,BUDA,BUDSEX))
IF BUDSEX=""!(BUDQUIT)
QUIT
Begin DoDot:2
+5 SET BUDCOM=""
FOR
SET BUDCOM=$ORDER(^XTMP("BUD8RPT1",BUDJ,BUDH,"3BR",BUDRACE,BUDA,BUDSEX,BUDCOM))
IF BUDCOM=""!(BUDQUIT)
QUIT
Begin DoDot:3
+6 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("BUD8RPT1",BUDJ,BUDH,"3BR",BUDRACE,BUDA,BUDSEX,BUDCOM,DFN))
IF DFN'=+DFN!(BUDQUIT)
QUIT
Begin DoDot:4
+7 IF $Y>(IOSL-3)
DO T3BRH
IF BUDQUIT
QUIT
WRITE !,$PIECE(BUDRACE,"-",2),!
+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($$RACE^BUD8RPTC(DFN),U,3)_"-"_$PIECE($$RACE^BUD8RPTC(DFN),U,4),1,19)
+11 SET BUDV=0
FOR
SET BUDV=$ORDER(^XTMP("BUD8RPT1",BUDJ,BUDH,"3BR",BUDRACE,BUDA,BUDSEX,BUDCOM,DFN,BUDV))
IF BUDV'=+BUDV!(BUDQUIT)
QUIT
Begin DoDot:5
+12 IF $Y>(IOSL-3)
DO T3BRH
IF BUDQUIT
QUIT
WRITE !,$PIECE(BUDRACE,"-",2),!
+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 T3BRH
IF BUDQUIT
QUIT
+15 WRITE !!,"Sub-Total ",$PIECE(BUDRACE,"-",2),": ",BUDSTOT,!
+16 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 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, race, and visit information."
+12 WRITE !,"Age is calculated as of June 30."
+13 WRITE !,"* R- denotes the value was obtained from the Race field"
+14 WRITE !," C- denotes the value was obtained from the Classification/Beneficiary field"
+15 WRITE !
End DoDot:1
+16 WRITE !,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?50,"SEX",?55,"AGE",?60,"RACE*"
+17 WRITE !?5,"VISIT DATE",?25,"PROV TYPE",?41,"SRV",?45,"CLINIC",?62,"LOCATION"
+18 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-"),!
+19 SET BUDP=1
+20 QUIT
+21 ;
T3BE ;EP
+1 SET BUDP=0
SET BUDQUIT=0
SET BUDTOT=0
+2 DO T3BEH
IF BUDQUIT
QUIT
+3 IF '$DATA(^XTMP("BUD8RPT1",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("BUD8RPT1",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("BUD8RPT1",BUDJ,BUDH,"3BE",BUDRACE,BUDA))
IF BUDA=""!(BUDQUIT)
QUIT
Begin DoDot:1
+4 SET BUDSEX=""
FOR
SET BUDSEX=$ORDER(^XTMP("BUD8RPT1",BUDJ,BUDH,"3BE",BUDRACE,BUDA,BUDSEX))
IF BUDSEX=""!(BUDQUIT)
QUIT
Begin DoDot:2
+5 SET BUDCOM=""
FOR
SET BUDCOM=$ORDER(^XTMP("BUD8RPT1",BUDJ,BUDH,"3BE",BUDRACE,BUDA,BUDSEX,BUDCOM))
IF BUDCOM=""!(BUDQUIT)
QUIT
Begin DoDot:3
+6 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("BUD8RPT1",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^BUD8RPTC(DFN),U,2)_"-"_$PIECE($$HISP^BUD8RPTC(DFN),U,3),1,19)
+11 SET BUDV=0
FOR
SET BUDV=$ORDER(^XTMP("BUD8RPT1",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 ;
