BUDRPTL ; IHS/CMI/LAB - UDS print lists ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
START ;
S BUDQUIT="",BUDGPG=0
I $G(BUDT3AL) D T3A
Q:BUDQUIT
I $G(BUDT3BL),'$G(BUDT3AL) D T3A
Q:BUDQUIT
I $G(BUDT4L) D T4
Q:BUDQUIT
I $G(BUDT5L) D T5
Q:BUDQUIT
I $G(BUDT5L1) D T51
Q:BUDQUIT
I $G(BUDT5L2) D T52
Q:BUDQUIT
I $G(BUDT6L) D T6
Q:BUDQUIT
I $G(BUDTOL) D TOL
Q
T4 ;
Q
T3A ;
S BUDP=0
D T3H Q:BUDQUIT
S BUDAGE="" F S BUDAGE=$O(^XTMP("BUDRPT1",BUDJ,BUDH,"3A",BUDAGE)) Q:BUDAGE'=+BUDAGE!(BUDQUIT) D
.S BUDSEX="" F S BUDSEX=$O(^XTMP("BUDRPT1",BUDJ,BUDH,"3A",BUDAGE,BUDSEX)) Q:BUDSEX=""!(BUDQUIT) D
..S BUDCOM="" F S BUDCOM=$O(^XTMP("BUDRPT1",BUDJ,BUDH,"3A",BUDAGE,BUDSEX,BUDCOM)) Q:BUDCOM=""!(BUDQUIT) D
...S DFN="" F S DFN=$O(^XTMP("BUDRPT1",BUDJ,BUDH,"3A",BUDAGE,BUDSEX,BUDCOM,DFN)) Q:DFN'=+DFN!(BUDQUIT) D
....I $Y>(IOSL-3) D T3H Q:BUDQUIT
....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)),?36,$E(BUDCOM,1,12),?51,$P(^DPT(DFN,0),U,2),?55,$$AGE^AUPNPAT(DFN,BUDCAD),?60,$P($$RACE^BUDRPTC(DFN),U,2)
....S BUDV=0 F S BUDV=$O(^XTMP("BUDRPT1",BUDJ,BUDH,"3A",BUDAGE,BUDSEX,BUDCOM,DFN,BUDV)) Q:BUDV'=+BUDV!(BUDQUIT) D
.....I $Y>(IOSL-3) D T3H Q:BUDQUIT
.....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)
Q
T3H ;
G:'BUDGPG T3H1
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
T3H1 ;
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("*** BPHC Uniform Data System (UDS) ***",80)
W !,$$CTR("Patient List for Tables 3A, 3B",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 W !,"List of all Users, defined as any patient with one or more visits during the",!,"calendar year, with gender, age, race or ethnicity, and visit information.",!,"Age is calculated as of June 30.",!
W !,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?50,"SEX",?55,"AGE",?60,"RACE/ETHN"
S BUDP=1
W !,$TR($J("",80)," ","-")
Q
T52 ;
D T52^BUDRPTL2
Q
T51 ;
D T51H Q:BUDQUIT
S BUD5L="" F S BUD5L=$O(^XTMP("BUDRPT1",BUDJ,BUDH,"T51",BUD5L)) Q:BUD5L=""!(BUDQUIT) D
.I $Y>(IOSL-3) D T51H Q:BUDQUIT
.S BUDY=$O(^BUDTFIVE("B",BUD5L,0)),BUDY=$P(^BUDTFIVE(BUDY,0),U,2)
.W !!,"Line ",BUD5L," ",BUDY
.S BUDPROV="" F S BUDPROV=$O(^XTMP("BUDRPT1",BUDJ,BUDH,"T51",BUD5L,BUDPROV)) Q:BUDPROV=""!(BUDQUIT) D
..W !,BUDPROV,?35,^XTMP("BUDRPT1",BUDJ,BUDH,"T51",BUD5L,BUDPROV)
.Q
Q
T51H ;
G:'BUDGPG T51H1
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
T51H1 ;
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("*** BPHC Uniform Data System (UDS) ***",80)
W !,$$CTR("Provider List for Table 5 Columns A, By Service Category",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)," ","-")
;W !,"List of all Active Provider Personnel sorted by Major Service Category.",!
W !,"PROVIDER NAME",?35,"PROVIDER CODE",?70,"FTE"
W !,$TR($J("",80)," ","-")
Q
T5 ;
S BUDP=0
;D T5H Q:BUDQUIT
S BUD5L="" F S BUD5L=$O(^XTMP("BUDRPT1",BUDJ,BUDH,"T5",BUD5L)) Q:BUD5L=""!(BUDQUIT) D
.D T5H Q:BUDQUIT
.S BUDY=$O(^BUDTFIVE("B",BUD5L,0)),BUDY=$P(^BUDTFIVE(BUDY,0),U,2)
.W !!,"Line ",BUD5L," ",BUDY
.S BUDCOM="" F S BUDCOM=$O(^XTMP("BUDRPT1",BUDJ,BUDH,"T5",BUD5L,BUDCOM)) Q:BUDCOM=""!(BUDQUIT) D
..S BUDAGE="" F S BUDAGE=$O(^XTMP("BUDRPT1",BUDJ,BUDH,"T5",BUD5L,BUDCOM,BUDAGE)) Q:BUDAGE=""!(BUDQUIT) D
...S BUDSEX="" F S BUDSEX=$O(^XTMP("BUDRPT1",BUDJ,BUDH,"T5",BUD5L,BUDCOM,BUDAGE,BUDSEX)) Q:BUDSEX=""!(BUDQUIT) D
....S DFN=0 F S DFN=$O(^XTMP("BUDRPT1",BUDJ,BUDH,"T5",BUD5L,BUDCOM,BUDAGE,BUDSEX,DFN)) Q:DFN'=+DFN!(BUDQUIT) D T5W
....Q
...Q
..Q
.Q
Q
T5W 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)),?36,$E(BUDCOM,1,12),?51,$P(^DPT(DFN,0),U,2),?55,$$AGE^AUPNPAT(DFN,BUDCAD),?60,$P($$RACE^BUDRPTC(DFN),U,2)
K BUDVLST S BUDV=0 F S BUDV=$O(^XTMP("BUDRPT1",BUDJ,BUDH,"T5",BUD5L,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV)) Q:BUDV'=+BUDV!(BUDQUIT) D
.S BUDVLST($P(^AUPNVSIT(BUDV,0),U),BUDV)=""
S BUDDD=0 F S BUDDD=$O(BUDVLST(BUDDD)) Q:BUDDD=""!(BUDQUIT) D
.S BUDV=0 F S BUDV=$O(BUDVLST(BUDDD,BUDV)) Q:BUDV'=+BUDV!(BUDQUIT) D
..I $Y>(IOSL-3) D T5H Q:BUDQUIT
..W !?5,$$FMTE^XLFDT($P($P(^AUPNVSIT(BUDV,0),U),".")),?25,$E($$PRIMPROV^APCLV(BUDV,"E"),1,14),?42,$$PRIMPROV^APCLV(BUDV,"D"),?50,$P(^AUPNVSIT(BUDV,0),U,7),?55,$E($$CLINIC^APCLV(BUDV,"E"),1,14),?70,$E($$LOCENC^APCLV(BUDV,"E"),1,9)
..Q
Q
T5H ;
G:'BUDGPG T5H1
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
T5H1 ;
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("*** BPHC Uniform Data System (UDS) ***",80)
W !,$$CTR("Patient List for Table 5 Columns B & C, By Service Category",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 W !,"List of all Users, sorted by defined Service Categories. Displays",!,"community, gender, age and visit data, including Provider codes."
W !,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?50,"SEX",?55,"AGE",?60,"RACE/ETHN"
W !,$TR($J("",80)," ","-")
S BUDP=1
Q
T6 ;
S BUDP=0
;D T6H Q:BUDQUIT
S BUD6L="" F S BUD6L=$O(^XTMP("BUDRPT1",BUDJ,BUDH,"T6",BUD6L)) Q:BUD6L=""!(BUDQUIT) D
.D T6H Q:BUDQUIT
.W !!,"Line ",BUD6L," ",$P($T(@BUD6L),";;",2)
.S BUDCOM="" F S BUDCOM=$O(^XTMP("BUDRPT1",BUDJ,BUDH,"T6",BUD6L,BUDCOM)) Q:BUDCOM=""!(BUDQUIT) D
..S BUDAGE="" F S BUDAGE=$O(^XTMP("BUDRPT1",BUDJ,BUDH,"T6",BUD6L,BUDCOM,BUDAGE)) Q:BUDAGE=""!(BUDQUIT) D
...S BUDSEX="" F S BUDSEX=$O(^XTMP("BUDRPT1",BUDJ,BUDH,"T6",BUD6L,BUDCOM,BUDAGE,BUDSEX)) Q:BUDSEX=""!(BUDQUIT) D
....S DFN=0 F S DFN=$O(^XTMP("BUDRPT1",BUDJ,BUDH,"T6",BUD6L,BUDCOM,BUDAGE,BUDSEX,DFN)) Q:DFN'=+DFN!(BUDQUIT) D T6W
....Q
...Q
..Q
.Q
Q
T6W ;
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)),?36,$E(BUDCOM,1,12),?51,$P(^DPT(DFN,0),U,2),?55,$$AGE^AUPNPAT(DFN,BUDCAD),?60,$P($$RACE^BUDRPTC(DFN),U,2)
S BUDV=0 F S BUDV=$O(^XTMP("BUDRPT1",BUDJ,BUDH,"T6",BUD6L,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV)) Q:BUDV'=+BUDV!(BUDQUIT) D
.I $Y>(IOSL-3) D T6H Q:BUDQUIT
.W !?5,$$FMTE^XLFDT($P($P(^AUPNVSIT(BUDV,0),U),".")),?25,^XTMP("BUDRPT1",BUDJ,BUDH,"T6",BUD6L,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV),?40,$P(^AUPNVSIT(BUDV,0),U,7),?45,$E($$CLINIC^APCLV(BUDV,"E"),1,15),?60,$E($$LOCENC^APCLV(BUDV,"E"),1,15)
.Q
Q
T6H ;
G:'BUDGPG T6H1
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
T6H1 ;
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("*** BPHC Uniform Data System (UDS) ***",80)
W !,$$CTR("Patient List for Table 6, By Diagnosis Category",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 W !,"List of all Users, sorted by primary diagnosis and tests/screening",!,"categories. Displays community, gender, age and visit data, and codes."
W !,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?50,"SEX",?55,"AGE",?60,"RACE/ETHN"
W !,$TR($J("",80)," ","-")
S BUDP=1
Q
TOL ;
D TOL^BUDRPTL1
Q
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")
;----------
1 ;;Symptomatic HIV
2 ;;Asymptomatic HIV
3 ;;Tuberculosis
4 ;;Syphilis and other venereal diseases
5 ;;Asthma
6 ;;Chronic bronchitis and emphysema
7 ;;Abnormal breast findings, female
8 ;;Abnormal cervical findings
9 ;;Diabetes mellitus
10 ;;Heart disease (selected)
11 ;;Hypertension
12 ;;Contact dermatitis and other eczema
13 ;;Dehydration
14 ;;Exposure to heat or cold
15 ;;Otitis media and eustachian tube disorders
16 ;;Selected perinatal medical conditions
17 ;;Lack of expected normal physiological development
18 ;;Alcohol dependence
19 ;;Drug dependence
20 ;;Other Mental disorders, excluding drug or alcohol dependence
21 ;;HIV Test
22 ;;Mammogram
23 ;;Pap Smear
24 ;;Selected Immunizations
25 ;;Contraceptive Management
26 ;;Health supervision of infant or child (ages 0 through 11)
BUDRPTL ; IHS/CMI/LAB - UDS print lists ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
START ;
+1 SET BUDQUIT=""
SET BUDGPG=0
+2 IF $GET(BUDT3AL)
DO T3A
+3 IF BUDQUIT
QUIT
+4 IF $GET(BUDT3BL)
IF '$GET(BUDT3AL)
DO T3A
+5 IF BUDQUIT
QUIT
+6 IF $GET(BUDT4L)
DO T4
+7 IF BUDQUIT
QUIT
+8 IF $GET(BUDT5L)
DO T5
+9 IF BUDQUIT
QUIT
+10 IF $GET(BUDT5L1)
DO T51
+11 IF BUDQUIT
QUIT
+12 IF $GET(BUDT5L2)
DO T52
+13 IF BUDQUIT
QUIT
+14 IF $GET(BUDT6L)
DO T6
+15 IF BUDQUIT
QUIT
+16 IF $GET(BUDTOL)
DO TOL
+17 QUIT
T4 ;
+1 QUIT
T3A ;
+1 SET BUDP=0
+2 DO T3H
IF BUDQUIT
QUIT
+3 SET BUDAGE=""
FOR
SET BUDAGE=$ORDER(^XTMP("BUDRPT1",BUDJ,BUDH,"3A",BUDAGE))
IF BUDAGE'=+BUDAGE!(BUDQUIT)
QUIT
Begin DoDot:1
+4 SET BUDSEX=""
FOR
SET BUDSEX=$ORDER(^XTMP("BUDRPT1",BUDJ,BUDH,"3A",BUDAGE,BUDSEX))
IF BUDSEX=""!(BUDQUIT)
QUIT
Begin DoDot:2
+5 SET BUDCOM=""
FOR
SET BUDCOM=$ORDER(^XTMP("BUDRPT1",BUDJ,BUDH,"3A",BUDAGE,BUDSEX,BUDCOM))
IF BUDCOM=""!(BUDQUIT)
QUIT
Begin DoDot:3
+6 SET DFN=""
FOR
SET DFN=$ORDER(^XTMP("BUDRPT1",BUDJ,BUDH,"3A",BUDAGE,BUDSEX,BUDCOM,DFN))
IF DFN'=+DFN!(BUDQUIT)
QUIT
Begin DoDot:4
+7 IF $Y>(IOSL-3)
DO T3H
IF BUDQUIT
QUIT
+8 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)),?36,...
... $EXTRACT(BUDCOM,1,12),?51,$PIECE(^DPT(DFN,0),U,2),?55,$$AGE^AUPNPAT(DFN,BUDCAD),?60,$PIECE($$RACE^BUDRPTC(DFN),U,2)
+9 SET BUDV=0
FOR
SET BUDV=$ORDER(^XTMP("BUDRPT1",BUDJ,BUDH,"3A",BUDAGE,BUDSEX,BUDCOM,DFN,BUDV))
IF BUDV'=+BUDV!(BUDQUIT)
QUIT
Begin DoDot:5
+10 IF $Y>(IOSL-3)
DO T3H
IF BUDQUIT
QUIT
+11 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
+12 QUIT
T3H ;
+1 IF 'BUDGPG
GOTO T3H1
+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
T3H1 ;
+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("*** BPHC Uniform Data System (UDS) ***",80)
+5 WRITE !,$$CTR("Patient List for Tables 3A, 3B",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
WRITE !,"List of all Users, defined as any patient with one or more visits during the",!,"calendar year, with gender, age, race or ethnicity, and visit information.",!,"Age is calculated as of June 30.",!
+10 WRITE !,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?50,"SEX",?55,"AGE",?60,"RACE/ETHN"
+11 SET BUDP=1
+12 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+13 QUIT
T52 ;
+1 DO T52^BUDRPTL2
+2 QUIT
T51 ;
+1 DO T51H
IF BUDQUIT
QUIT
+2 SET BUD5L=""
FOR
SET BUD5L=$ORDER(^XTMP("BUDRPT1",BUDJ,BUDH,"T51",BUD5L))
IF BUD5L=""!(BUDQUIT)
QUIT
Begin DoDot:1
+3 IF $Y>(IOSL-3)
DO T51H
IF BUDQUIT
QUIT
+4 SET BUDY=$ORDER(^BUDTFIVE("B",BUD5L,0))
SET BUDY=$PIECE(^BUDTFIVE(BUDY,0),U,2)
+5 WRITE !!,"Line ",BUD5L," ",BUDY
+6 SET BUDPROV=""
FOR
SET BUDPROV=$ORDER(^XTMP("BUDRPT1",BUDJ,BUDH,"T51",BUD5L,BUDPROV))
IF BUDPROV=""!(BUDQUIT)
QUIT
Begin DoDot:2
+7 WRITE !,BUDPROV,?35,^XTMP("BUDRPT1",BUDJ,BUDH,"T51",BUD5L,BUDPROV)
End DoDot:2
+8 QUIT
End DoDot:1
+9 QUIT
T51H ;
+1 IF 'BUDGPG
GOTO T51H1
+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
T51H1 ;
+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("*** BPHC Uniform Data System (UDS) ***",80)
+5 WRITE !,$$CTR("Provider List for Table 5 Columns A, By Service Category",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 ;W !,"List of all Active Provider Personnel sorted by Major Service Category.",!
+10 WRITE !,"PROVIDER NAME",?35,"PROVIDER CODE",?70,"FTE"
+11 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+12 QUIT
T5 ;
+1 SET BUDP=0
+2 ;D T5H Q:BUDQUIT
+3 SET BUD5L=""
FOR
SET BUD5L=$ORDER(^XTMP("BUDRPT1",BUDJ,BUDH,"T5",BUD5L))
IF BUD5L=""!(BUDQUIT)
QUIT
Begin DoDot:1
+4 DO T5H
IF BUDQUIT
QUIT
+5 SET BUDY=$ORDER(^BUDTFIVE("B",BUD5L,0))
SET BUDY=$PIECE(^BUDTFIVE(BUDY,0),U,2)
+6 WRITE !!,"Line ",BUD5L," ",BUDY
+7 SET BUDCOM=""
FOR
SET BUDCOM=$ORDER(^XTMP("BUDRPT1",BUDJ,BUDH,"T5",BUD5L,BUDCOM))
IF BUDCOM=""!(BUDQUIT)
QUIT
Begin DoDot:2
+8 SET BUDAGE=""
FOR
SET BUDAGE=$ORDER(^XTMP("BUDRPT1",BUDJ,BUDH,"T5",BUD5L,BUDCOM,BUDAGE))
IF BUDAGE=""!(BUDQUIT)
QUIT
Begin DoDot:3
+9 SET BUDSEX=""
FOR
SET BUDSEX=$ORDER(^XTMP("BUDRPT1",BUDJ,BUDH,"T5",BUD5L,BUDCOM,BUDAGE,BUDSEX))
IF BUDSEX=""!(BUDQUIT)
QUIT
Begin DoDot:4
+10 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("BUDRPT1",BUDJ,BUDH,"T5",BUD5L,BUDCOM,BUDAGE,BUDSEX,DFN))
IF DFN'=+DFN!(BUDQUIT)
QUIT
DO T5W
+11 QUIT
End DoDot:4
+12 QUIT
End DoDot:3
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 QUIT
T5W 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)),?36,...
... $EXTRACT(BUDCOM,1,12),?51,$PIECE(^DPT(DFN,0),U,2),?55,$$AGE^AUPNPAT(DFN,BUDCAD),?60,$PIECE($$RACE^BUDRPTC(DFN),U,2)
+1 KILL BUDVLST
SET BUDV=0
FOR
SET BUDV=$ORDER(^XTMP("BUDRPT1",BUDJ,BUDH,"T5",BUD5L,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV))
IF BUDV'=+BUDV!(BUDQUIT)
QUIT
Begin DoDot:1
+2 SET BUDVLST($PIECE(^AUPNVSIT(BUDV,0),U),BUDV)=""
End DoDot:1
+3 SET BUDDD=0
FOR
SET BUDDD=$ORDER(BUDVLST(BUDDD))
IF BUDDD=""!(BUDQUIT)
QUIT
Begin DoDot:1
+4 SET BUDV=0
FOR
SET BUDV=$ORDER(BUDVLST(BUDDD,BUDV))
IF BUDV'=+BUDV!(BUDQUIT)
QUIT
Begin DoDot:2
+5 IF $Y>(IOSL-3)
DO T5H
IF BUDQUIT
QUIT
+6 WRITE !?5,$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT(BUDV,0),U),".")),?25,$EXTRACT($$PRIMPROV^APCLV(BUDV,"E"),1,14),?42,$$PRIMPROV^APCLV(BUDV,"D"),?50,$PIECE(^AUPNVSIT(BUDV,0),U,7),?55,$EXTRACT($$CLINIC^APCLV(BUDV,"E"),1,14),?70,...
... $EXTRACT($$LOCENC^APCLV(BUDV,"E"),1,9)
+7 QUIT
End DoDot:2
End DoDot:1
+8 QUIT
T5H ;
+1 IF 'BUDGPG
GOTO T5H1
+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
T5H1 ;
+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("*** BPHC Uniform Data System (UDS) ***",80)
+5 WRITE !,$$CTR("Patient List for Table 5 Columns B & C, By Service Category",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
WRITE !,"List of all Users, sorted by defined Service Categories. Displays",!,"community, gender, age and visit data, including Provider codes."
+10 WRITE !,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?50,"SEX",?55,"AGE",?60,"RACE/ETHN"
+11 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+12 SET BUDP=1
+13 QUIT
T6 ;
+1 SET BUDP=0
+2 ;D T6H Q:BUDQUIT
+3 SET BUD6L=""
FOR
SET BUD6L=$ORDER(^XTMP("BUDRPT1",BUDJ,BUDH,"T6",BUD6L))
IF BUD6L=""!(BUDQUIT)
QUIT
Begin DoDot:1
+4 DO T6H
IF BUDQUIT
QUIT
+5 WRITE !!,"Line ",BUD6L," ",$PIECE($TEXT(@BUD6L),";;",2)
+6 SET BUDCOM=""
FOR
SET BUDCOM=$ORDER(^XTMP("BUDRPT1",BUDJ,BUDH,"T6",BUD6L,BUDCOM))
IF BUDCOM=""!(BUDQUIT)
QUIT
Begin DoDot:2
+7 SET BUDAGE=""
FOR
SET BUDAGE=$ORDER(^XTMP("BUDRPT1",BUDJ,BUDH,"T6",BUD6L,BUDCOM,BUDAGE))
IF BUDAGE=""!(BUDQUIT)
QUIT
Begin DoDot:3
+8 SET BUDSEX=""
FOR
SET BUDSEX=$ORDER(^XTMP("BUDRPT1",BUDJ,BUDH,"T6",BUD6L,BUDCOM,BUDAGE,BUDSEX))
IF BUDSEX=""!(BUDQUIT)
QUIT
Begin DoDot:4
+9 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("BUDRPT1",BUDJ,BUDH,"T6",BUD6L,BUDCOM,BUDAGE,BUDSEX,DFN))
IF DFN'=+DFN!(BUDQUIT)
QUIT
DO T6W
+10 QUIT
End DoDot:4
+11 QUIT
End DoDot:3
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 QUIT
T6W ;
+1 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)),?36,...
... $EXTRACT(BUDCOM,1,12),?51,$PIECE(^DPT(DFN,0),U,2),?55,$$AGE^AUPNPAT(DFN,BUDCAD),?60,$PIECE($$RACE^BUDRPTC(DFN),U,2)
+2 SET BUDV=0
FOR
SET BUDV=$ORDER(^XTMP("BUDRPT1",BUDJ,BUDH,"T6",BUD6L,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV))
IF BUDV'=+BUDV!(BUDQUIT)
QUIT
Begin DoDot:1
+3 IF $Y>(IOSL-3)
DO T6H
IF BUDQUIT
QUIT
+4 WRITE !?5,$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT(BUDV,0),U),".")),?25,^XTMP("BUDRPT1",BUDJ,BUDH,"T6",BUD6L,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV),?40,$PIECE(^AUPNVSIT(BUDV,0),U,7),?45,$EXTRACT($$CLINIC^APCLV(BUDV,"E"),1,15),?60,$EXTRACT($$LOCENC^
APCLV(BUDV,"E"),1,15)
+5 QUIT
End DoDot:1
+6 QUIT
T6H ;
+1 IF 'BUDGPG
GOTO T6H1
+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
T6H1 ;
+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("*** BPHC Uniform Data System (UDS) ***",80)
+5 WRITE !,$$CTR("Patient List for Table 6, By Diagnosis Category",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
WRITE !,"List of all Users, sorted by primary diagnosis and tests/screening",!,"categories. Displays community, gender, age and visit data, and codes."
+10 WRITE !,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?50,"SEX",?55,"AGE",?60,"RACE/ETHN"
+11 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+12 SET BUDP=1
+13 QUIT
TOL ;
+1 DO TOL^BUDRPTL1
+2 QUIT
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 ;----------
1 ;;Symptomatic HIV
2 ;;Asymptomatic HIV
3 ;;Tuberculosis
4 ;;Syphilis and other venereal diseases
5 ;;Asthma
6 ;;Chronic bronchitis and emphysema
7 ;;Abnormal breast findings, female
8 ;;Abnormal cervical findings
9 ;;Diabetes mellitus
10 ;;Heart disease (selected)
11 ;;Hypertension
12 ;;Contact dermatitis and other eczema
13 ;;Dehydration
14 ;;Exposure to heat or cold
15 ;;Otitis media and eustachian tube disorders
16 ;;Selected perinatal medical conditions
17 ;;Lack of expected normal physiological development
18 ;;Alcohol dependence
19 ;;Drug dependence
20 ;;Other Mental disorders, excluding drug or alcohol dependence
21 ;;HIV Test
22 ;;Mammogram
23 ;;Pap Smear
24 ;;Selected Immunizations
25 ;;Contraceptive Management
26 ;;Health supervision of infant or child (ages 0 through 11)
