BUDHRPTL ; IHS/CMI/LAB - UDS ;
;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
;
START ;
S BUDQUIT="",BUDGPG=0
I $G(BUDTZL) S BUDGPG=0,BUDSCTC=$G(BUDSCTC)+1 D TZ D SECT
Q:BUDQUIT
I $G(BUDT3AL) S BUDGPG=0,BUDSCTC=$G(BUDSCTC)+1 D T3A D SECT
Q:BUDQUIT
I $G(BUDT3BRL) S BUDGPG=0,BUDSCTC=$G(BUDSCTC)+1 D T3BR D SECT
Q:BUDQUIT
I $G(BUDT4IPP) S BUDGPG=0,BUDSCTC=$G(BUDSCTC)+1 D T4IPPL D SECT
Q:BUDQUIT
I $G(BUDT4PMI) S BUDGPG=0,BUDSCTC=$G(BUDSCTC)+1 D T4PMIS D SECT
Q:BUDQUIT
I $G(BUDT4CHA) S BUDGPG=0,BUDSCTC=$G(BUDSCTC)+1 D T4CHAR D SECT
Q:BUDQUIT
I $G(BUDT5L1) S BUDGPG=0,BUDSCTC=$G(BUDSCTC)+1 D T51 D SECT
Q:BUDQUIT
I $G(BUDT5L) S BUDGPG=0,BUDSCTC=$G(BUDSCTC)+1 D T5 D SECT
Q:BUDQUIT
I $G(BUDT5L2) S BUDGPG=0,BUDSCTC=$G(BUDSCTC)+1 D T52 D SECT
Q:BUDQUIT
I $G(BUDT6L) S BUDGPG=0,BUDSCTC=$G(BUDSCTC)+1 D T6 D SECT
Q:BUDQUIT
Q
SECT ;
I BUDTSCTC>1,BUDROT'="D" W !,"***** END OF SECTION ",BUDSCTC," *****",!
Q
S(V) ;
S BUDDECNT=BUDDECNT+1
S ^TMP($J,"BUDDEL",BUDDECNT)=$G(V)
Q
T3BR ;
D T3BR^BUDHRPL4
Q
T4IPPL ;
D T4IPPL^BUDHRPL5
Q
T4PMIS ;
D T4PMIS^BUDHRPL5
Q
T4CHAR ;
D T4CHAR^BUDHRPL5
Q
T3A ;
D T3A^BUDHRPL2
Q
T52 ;
D T52^BUDHRPL2
Q
T51 ;EP
D T51^BUDHRPL2
Q
T5 ;
I BUDROT="D" D T5DH
S BUDP=0
S BUDX2L="" F S BUDX2L=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"T5",BUDX2L)) Q:BUDX2L=""!(BUDQUIT) D
.Q:BUDX2L=35
.S BUDX2L2="" F S BUDX2L2=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"T5",BUDX2L,BUDX2L2)) Q:BUDX2L2=""!(BUDQUIT) D
..S BUDX2LL=BUDX2L_$S(BUDX2L2=0:"",1:BUDX2L2)
..S BUDY=$O(^BUDHTFIV("B",BUDX2LL,0)),BUDY=$P(^BUDHTFIV(BUDY,0),U,2)_" "_$P(^BUDHTFIV(BUDY,0),U,3)_" "_$P(^BUDHTFIV(BUDY,0),U,4)
..S BUDSUBT="Line "_BUDX2LL_" "_BUDY
..I BUDROT="P" D T5H Q:BUDQUIT
..I BUDROT="D" D S(""),S(BUDSUBT)
..S BUDCCOM="" F S BUDCCOM=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"T5",BUDX2L,BUDX2L2,BUDCCOM)) Q:BUDCCOM=""!(BUDQUIT) D
...S BUDAGE="" F S BUDAGE=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"T5",BUDX2L,BUDX2L2,BUDCCOM,BUDAGE)) Q:BUDAGE=""!(BUDQUIT) D
....S BUDSEX="" F S BUDSEX=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"T5",BUDX2L,BUDX2L2,BUDCCOM,BUDAGE,BUDSEX)) Q:BUDSEX=""!(BUDQUIT) D
.....S DFN=0 F S DFN=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"T5",BUDX2L,BUDX2L2,BUDCCOM,BUDAGE,BUDSEX,DFN)) Q:DFN'=+DFN!(BUDQUIT) D T5W
I BUDROT="P" W !
Q
T5W I BUDROT="P" 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))
I BUDROT="P" W ?36,$E(BUDCCOM,1,12),?51,$P(^DPT(DFN,0),U,2),?55,$$AGE^AUPNPAT(DFN,BUDCCAD),?60,$E($P($$RACE^BUDHRPTC(DFN),U,4),1,16)," (",$P($$RACE^BUDHRPTC(DFN),U,3),")"
K BUDVLST S BUDV=0 F S BUDV=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"T5",BUDX2L,BUDX2L2,BUDCCOM,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 BUDROT="P",$Y>(IOSL-3) D T5H Q:BUDQUIT
..I BUDROT="P" D
...W !?5,$$FMTE^XLFDT($P($P(^AUPNVSIT(BUDV,0),U),".")),?25,$E($$PRIMPROV^APCLV(BUDV,"E"),1,14),?42,$E($$PRIMPROV^APCLV(BUDV,"D"),1,8),?50,$P(^AUPNVSIT(BUDV,0),U,7),?55,$E($$CLINIC^APCLV(BUDV,"E"),1,14),?70,$E($$LOCENC^APCLV(BUDV,"E"),1,9)
..I BUDROT="D" D
...S X=$P(^DPT(DFN,0),U,1)_U_$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))_U_$E(BUDCCOM,1,12)_U_$P(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCCAD)
...S X=X_U_$E($P($$RACE^BUDHRPTC(DFN),U,4),1,16)_" ("_$P($$RACE^BUDHRPTC(DFN),U,3)_")"
...S X=X_U_$$FMTE^XLFDT($P($P(^AUPNVSIT(BUDV,0),U),"."))_U_$$PRIMPROV^APCLV(BUDV,"E")_U_$$PRIMPROV^APCLV(BUDV,"D")_U_$P(^AUPNVSIT(BUDV,0),U,7)_U_$$CLINIC^APCLV(BUDV,"E")_U_$$LOCENC^APCLV(BUDV,"E")
...D S(X)
...Q
Q
T5DH ;
D T5DH^BUDHRPTE
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 !,$$CTR("***** SENSITIVE INFORMATION *****",IOM)
W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?55,"Section "_BUDSCTC_" of "_BUDTSCTC_", Page "_BUDGPG,!
W !,$$CTR("*** RPMS Uniform Data System (UDS) "_$$VER^BUDHBAN()_" ***",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),!
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)",BUDBEN=4:"Homeless",1:"")
W $$CTR(X,80),!
W $TR($J("",80)," ","-")
I BUDP=0 W !,"List of all patients, sorted by defined Service Categories. Displays",!,"community, gender, age and visit data, including Provider codes.",!,"Age on the patient list is calculated as of June 30." D
.W !,"* (R) - denotes the value was obtained from the Race field"
.W !," (C) - denotes the value was obtained from the Classification/Beneficiary field"
W !,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?50,"SEX",?55,"AGE",?60,"RACE*"
W !?5,"VISIT DATE",?25,"PROV TYPE",?41,"PROV CD",?50,"SRV",?55,"CLINIC",?62,"LOCATION"
W !,$TR($J("",80)," ","-")
W !!,BUDSUBT,!
S BUDP=1
Q
TZ ;
S BUDP=0
I BUDROT="P" D TZH Q:BUDQUIT
I BUDROT="D" D TZHD^BUDHRPTD
S BUDYY=0 F S BUDYY=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZNEW",BUDYY)) Q:BUDYY'=+BUDYY!(BUDQUIT) D TZ1
Q:BUDQUIT
;
S BUDYY="Unknown Residence" D TZ2
Q
TZ2 ;
S BUDINS="" F S BUDINS=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDYY,BUDINS)) Q:BUDINS=""!(BUDQUIT) D
.S BUDCCOM="" F S BUDCCOM=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDYY,BUDINS,BUDCCOM)) Q:BUDCCOM=""!(BUDQUIT) D
..S BUDSEX="" F S BUDSEX=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDYY,BUDINS,BUDCCOM,BUDSEX)) Q:BUDSEX=""!(BUDQUIT) D
...S BUDNAME="" F S BUDNAME=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDYY,BUDINS,BUDCCOM,BUDSEX,BUDNAME)) Q:BUDNAME=""!(BUDQUIT) D
....S DFN="" F S DFN=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDYY,BUDINS,BUDCCOM,BUDSEX,BUDNAME,DFN)) Q:DFN'=+DFN!(BUDQUIT) D
.....I BUDROT="P",$Y>(IOSL-3) D TZH Q:BUDQUIT
.....I BUDROT="P" 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(BUDCCOM,1,12),?51,$P(^DPT(DFN,0),U,2),?55,"Unk Res",?65,$$INS(BUDINS)
.....S BUDV=0 F S BUDV=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDYY,BUDINS,BUDCCOM,BUDSEX,BUDNAME,DFN,BUDV)) Q:BUDV'=+BUDV!(BUDQUIT) D
......I BUDROT="P",$Y>(IOSL-3) D TZH Q:BUDQUIT
......I BUDROT="P" 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 BUDROT="D" D
.......S X=$P(^DPT(DFN,0),U,1)_U_$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))_U_$E(BUDCCOM,1,12)_U_$P(^DPT(DFN,0),U,2)_U_"Unk Res"_U_$$INS(BUDINS)
.......S X=X_U_$$FMTE^XLFDT($P($P(^AUPNVSIT(BUDV,0),U),"."))_U_$$PRIMPROV^APCLV(BUDV,"E")_U_$P(^AUPNVSIT(BUDV,0),U,7)_U_$$CLINIC^APCLV(BUDV,"E")_U_$$LOCENC^APCLV(BUDV,"E")
.......D S^BUDHRPTD(X)
I BUDROT="P" W !
Q
TZ1 ;
S BUDZIP="" F S BUDZIP=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZIP)) Q:BUDZIP=""!(BUDQUIT) D
.S BUDINS="" F S BUDINS=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZIP,BUDINS)) Q:BUDINS=""!(BUDQUIT) D
..S BUDCCOM="" F S BUDCCOM=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZIP,BUDINS,BUDCCOM)) Q:BUDCCOM=""!(BUDQUIT) D
...S BUDSEX="" F S BUDSEX=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZIP,BUDINS,BUDCCOM,BUDSEX)) Q:BUDSEX=""!(BUDQUIT) D
....S BUDNAME="" F S BUDNAME=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZIP,BUDINS,BUDCCOM,BUDSEX,BUDNAME)) Q:BUDNAME=""!(BUDQUIT) D
.....S DFN="" F S DFN=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZIP,BUDINS,BUDCCOM,BUDSEX,BUDNAME,DFN)) Q:DFN'=+DFN!(BUDQUIT) D
......I BUDROT="P",$Y>(IOSL-3) D TZH Q:BUDQUIT
......I BUDROT="P" 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(BUDCCOM,1,12),?51,$P(^DPT(DFN,0),U,2),?55,BUDZIP,?65,$$INS(BUDINS)
......S BUDV=0 F S BUDV=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZIP,BUDINS,BUDCCOM,BUDSEX,BUDNAME,DFN,BUDV)) Q:BUDV'=+BUDV!(BUDQUIT) D
.......I BUDROT="P",$Y>(IOSL-3) D TZH Q:BUDQUIT
.......I BUDROT="P" 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 BUDROT="D" D
........S X=$P(^DPT(DFN,0),U,1)_U_$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))_U_$E(BUDCCOM,1,12)_U_$P(^DPT(DFN,0),U,2)_U_BUDZIP_U_$$INS(BUDINS)
........S X=X_U_$$FMTE^XLFDT($P($P(^AUPNVSIT(BUDV,0),U),"."))_U_$$PRIMPROV^APCLV(BUDV,"E")_U_$P(^AUPNVSIT(BUDV,0),U,7)_U_$$CLINIC^APCLV(BUDV,"E")_U_$$LOCENC^APCLV(BUDV,"E")
........D S^BUDHRPTD(X)
I BUDROT="P" W !
Q
INS(Z) ;
I Z="e" Q "PI"
I Z="d" Q "Medicare"
I Z="c" Q "MCD/CHIP/OP"
I Z="b" Q "None/Unins"
Q ""
TZH ;
I BUDROT="D" Q
D TZH^BUDHRPTD
Q
T6 ;
I BUDROT="D" D T6DH
S BUDP=0
S BUDX2L=0 F S BUDX2L=$O(^BUDHTSC("B",BUDX2L)) Q:BUDX2L'=+BUDX2L S BUDY=0 F S BUDY=$O(^BUDHTSC("B",BUDX2L,BUDY)) Q:BUDY'=+BUDY D
.Q:'$D(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L))
.I BUDROT="P" D T6H Q:BUDQUIT
.S BUDLLL="",X=0 F S X=$O(^BUDHTSC(BUDY,2,X)) Q:X'=+X S BUDLLL=BUDLLL_" "_$P(^BUDHTSC(BUDY,2,X,0),U,1)
.I BUDROT="P" W !!,"Line ",$P(^BUDHTSC(BUDY,0),U,3)," ",BUDLLL
.I BUDROT="D" D S(""),S("Line "_$P(^BUDHTSC(BUDY,0),U,3)_" "_BUDLLL)
.S BUDCCOM="" F S BUDCCOM=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM)) Q:BUDCCOM=""!(BUDQUIT) D
..S BUDAGE="" F S BUDAGE=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE)) Q:BUDAGE=""!(BUDQUIT) D
...S BUDSEX="" F S BUDSEX=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE,BUDSEX)) Q:BUDSEX=""!(BUDQUIT) D
....S DFN=0 F S DFN=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE,BUDSEX,DFN)) Q:DFN'=+DFN!(BUDQUIT) D T6W
I BUDROT="P" W !
Q
T6W ;
I BUDROT="P",$Y>(IOSL-3) D T6H Q:BUDQUIT W !!,"Line ",$P(^BUDHTSC(BUDY,0),U,3)," ",BUDLLL
I BUDROT="P" 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))
I BUDROT="P" W ?36,$E(BUDCCOM,1,12),?51,$P(^DPT(DFN,0),U,2),?55,$$AGE^AUPNPAT(DFN,BUDCCAD),?60,$E($P($$RACE^BUDHRPTC(DFN),U,4),1,16)," (",$P($$RACE^BUDHRPTC(DFN),U,3),")"
K BUDVRR S BUDV=0,BUDVC=0 F S BUDV=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE,BUDSEX,DFN,BUDV)) Q:BUDV'=+BUDV!(BUDQUIT) S BUDVC=BUDVC+1,BUDVRR($$VD^APCLV(BUDV),BUDVC)=BUDV
S BUDVD=0 F S BUDVD=$O(BUDVRR(BUDVD)) Q:BUDVD="" S BUDVC=0 F S BUDVC=$O(BUDVRR(BUDVD,BUDVC)) Q:BUDVC="" D
.I BUDROT="P",$Y>(IOSL-3) D T6H Q:BUDQUIT W !!,"Line ",$P(^BUDHTSC(BUDY,0),U,3)," ",BUDLLL
.S BUDV=BUDVRR(BUDVD,BUDVC)
.S Z=^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE,BUDSEX,DFN,BUDV)
.F A=1:1 S J=$P(Z,U,A) Q:J="" D
..I BUDROT="P" W !?5,$$FMTE^XLFDT($P($P(^AUPNVSIT(BUDV,0),U),".")),?25,J,?40,$P(^AUPNVSIT(BUDV,0),U,7),?45,$E($$CLINIC^APCLV(BUDV,"E"),1,15),?62,$E($$LOCENC^APCLV(BUDV,"E"),1,15) Q
..S X=$P(^DPT(DFN,0),U,1)_U_$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))_U_$E(BUDCCOM,1,12)_U_$P(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCCAD)
..S X=X_U_$E($P($$RACE^BUDHRPTC(DFN),U,4),1,16)_" ("_$P($$RACE^BUDHRPTC(DFN),U,3)_")"
..S X=X_U_$$FMTE^XLFDT($P($P(^AUPNVSIT(BUDV,0),U),"."))_U_J_U_$P(^AUPNVSIT(BUDV,0),U,7)_U_$$CLINIC^APCLV(BUDV,"E")_U_$$LOCENC^APCLV(BUDV,"E")
..D S^BUDHRPTD(X)
..Q
I BUDX2L=35 D
.S BUDW=0 F S BUDW=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE,BUDSEX,DFN,"WH","MAM",BUDW)) Q:BUDW'=+BUDW!(BUDQUIT) D
..I BUDROT="P" W !?5,$P(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE,BUDSEX,DFN,"WH","MAM",BUDW),U,2),?25,$P(^(BUDW),U,1)
..I BUDROT="D" D
...S X=$P(^DPT(DFN,0),U,1)_U_$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))_U_$E(BUDCCOM,1,12)_U_$P(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCCAD)
...S X=X_U_$E($P($$RACE^BUDHRPTC(DFN),U,4),1,16)_" ("_$P($$RACE^BUDHRPTC(DFN),U,3)_")"
...S X=X_U_$P(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE,BUDSEX,DFN,"WH","MAM",BUDW),U,2)_U_$P(^(BUDW),U,1)
...D S(X)
I BUDX2L=36 D
.S BUDW=0 F S BUDW=$O(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE,BUDSEX,DFN,"WH","PAP",BUDW)) Q:BUDW'=+BUDW!(BUDQUIT) D
..I BUDROT="P" W !?5,$P(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE,BUDSEX,DFN,"WH","PAP",BUDW),U,2),?25,$P(^(BUDW),U,1)
..I BUDROT="D" D
...S X=$P(^DPT(DFN,0),U,1)_U_$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))_U_$E(BUDCCOM,1,12)_U_$P(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCCAD)
...S X=X_U_$E($P($$RACE^BUDHRPTC(DFN),U,4),1,16)_" ("_$P($$RACE^BUDHRPTC(DFN),U,3)_")"
...S X=X_U_$P(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE,BUDSEX,DFN,"WH","PAP",BUDW),U,2)_U_$P(^(BUDW),U,1)
...D S(X)
Q
T6H ;
I BUDROT="D" D T6DH Q
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 !,$$CTR("***** SENSITIVE INFORMATION *****",IOM)
W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?55,"Section "_BUDSCTC_" of "_BUDTSCTC_", Page "_BUDGPG,!
W !,$$CTR("Patient List for Table 6A, 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),!
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)",BUDBEN=4:"Homeless",1:"")
W $$CTR(X,80),!
W $TR($J("",80)," ","-")
I BUDP=0 W !,"List of all patients, sorted by diagnosis and tests/screening",!,"categories. Displays community, gender, age and visit data, and codes." D
.W !,"* (R) - denotes the value was obtained from the Race field"
.W !," (C) - denotes the value was obtained from the Classification/Beneficiary field"
W !,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?50,"SEX",?55,"AGE",?60,"RACE*"
W !?5,"VISIT DATE",?25,"VALUE",?41,"SRV",?45,"CLINIC",?63,"LOCATION"
W !,$TR($J("",80)," ","-")
S BUDP=1
Q
CTR(X,Y) ;
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
T6DH ;
D T6DH^BUDHRPTD
Q
BUDHRPTL ; IHS/CMI/LAB - UDS ;
+1 ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
+2 ;
START ;
+1 SET BUDQUIT=""
SET BUDGPG=0
+2 IF $GET(BUDTZL)
SET BUDGPG=0
SET BUDSCTC=$GET(BUDSCTC)+1
DO TZ
DO SECT
+3 IF BUDQUIT
QUIT
+4 IF $GET(BUDT3AL)
SET BUDGPG=0
SET BUDSCTC=$GET(BUDSCTC)+1
DO T3A
DO SECT
+5 IF BUDQUIT
QUIT
+6 IF $GET(BUDT3BRL)
SET BUDGPG=0
SET BUDSCTC=$GET(BUDSCTC)+1
DO T3BR
DO SECT
+7 IF BUDQUIT
QUIT
+8 IF $GET(BUDT4IPP)
SET BUDGPG=0
SET BUDSCTC=$GET(BUDSCTC)+1
DO T4IPPL
DO SECT
+9 IF BUDQUIT
QUIT
+10 IF $GET(BUDT4PMI)
SET BUDGPG=0
SET BUDSCTC=$GET(BUDSCTC)+1
DO T4PMIS
DO SECT
+11 IF BUDQUIT
QUIT
+12 IF $GET(BUDT4CHA)
SET BUDGPG=0
SET BUDSCTC=$GET(BUDSCTC)+1
DO T4CHAR
DO SECT
+13 IF BUDQUIT
QUIT
+14 IF $GET(BUDT5L1)
SET BUDGPG=0
SET BUDSCTC=$GET(BUDSCTC)+1
DO T51
DO SECT
+15 IF BUDQUIT
QUIT
+16 IF $GET(BUDT5L)
SET BUDGPG=0
SET BUDSCTC=$GET(BUDSCTC)+1
DO T5
DO SECT
+17 IF BUDQUIT
QUIT
+18 IF $GET(BUDT5L2)
SET BUDGPG=0
SET BUDSCTC=$GET(BUDSCTC)+1
DO T52
DO SECT
+19 IF BUDQUIT
QUIT
+20 IF $GET(BUDT6L)
SET BUDGPG=0
SET BUDSCTC=$GET(BUDSCTC)+1
DO T6
DO SECT
+21 IF BUDQUIT
QUIT
+22 QUIT
SECT ;
+1 IF BUDTSCTC>1
IF BUDROT'="D"
WRITE !,"***** END OF SECTION ",BUDSCTC," *****",!
+2 QUIT
S(V) ;
+1 SET BUDDECNT=BUDDECNT+1
+2 SET ^TMP($JOB,"BUDDEL",BUDDECNT)=$GET(V)
+3 QUIT
T3BR ;
+1 DO T3BR^BUDHRPL4
+2 QUIT
T4IPPL ;
+1 DO T4IPPL^BUDHRPL5
+2 QUIT
T4PMIS ;
+1 DO T4PMIS^BUDHRPL5
+2 QUIT
T4CHAR ;
+1 DO T4CHAR^BUDHRPL5
+2 QUIT
T3A ;
+1 DO T3A^BUDHRPL2
+2 QUIT
T52 ;
+1 DO T52^BUDHRPL2
+2 QUIT
T51 ;EP
+1 DO T51^BUDHRPL2
+2 QUIT
T5 ;
+1 IF BUDROT="D"
DO T5DH
+2 SET BUDP=0
+3 SET BUDX2L=""
FOR
SET BUDX2L=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"T5",BUDX2L))
IF BUDX2L=""!(BUDQUIT)
QUIT
Begin DoDot:1
+4 IF BUDX2L=35
QUIT
+5 SET BUDX2L2=""
FOR
SET BUDX2L2=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"T5",BUDX2L,BUDX2L2))
IF BUDX2L2=""!(BUDQUIT)
QUIT
Begin DoDot:2
+6 SET BUDX2LL=BUDX2L_$SELECT(BUDX2L2=0:"",1:BUDX2L2)
+7 SET BUDY=$ORDER(^BUDHTFIV("B",BUDX2LL,0))
SET BUDY=$PIECE(^BUDHTFIV(BUDY,0),U,2)_" "_$PIECE(^BUDHTFIV(BUDY,0),U,3)_" "_$PIECE(^BUDHTFIV(BUDY,0),U,4)
+8 SET BUDSUBT="Line "_BUDX2LL_" "_BUDY
+9 IF BUDROT="P"
DO T5H
IF BUDQUIT
QUIT
+10 IF BUDROT="D"
DO S("")
DO S(BUDSUBT)
+11 SET BUDCCOM=""
FOR
SET BUDCCOM=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"T5",BUDX2L,BUDX2L2,BUDCCOM))
IF BUDCCOM=""!(BUDQUIT)
QUIT
Begin DoDot:3
+12 SET BUDAGE=""
FOR
SET BUDAGE=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"T5",BUDX2L,BUDX2L2,BUDCCOM,BUDAGE))
IF BUDAGE=""!(BUDQUIT)
QUIT
Begin DoDot:4
+13 SET BUDSEX=""
FOR
SET BUDSEX=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"T5",BUDX2L,BUDX2L2,BUDCCOM,BUDAGE,BUDSEX))
IF BUDSEX=""!(BUDQUIT)
QUIT
Begin DoDot:5
+14 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"T5",BUDX2L,BUDX2L2,BUDCCOM,BUDAGE,BUDSEX,DFN))
IF DFN'=+DFN!(BUDQUIT)
QUIT
DO T5W
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 IF BUDROT="P"
WRITE !
+16 QUIT
T5W IF BUDROT="P"
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))
+1 IF BUDROT="P"
WRITE ?36,$EXTRACT(BUDCCOM,1,12),?51,$PIECE(^DPT(DFN,0),U,2),?55,$$AGE^AUPNPAT(DFN,BUDCCAD),?60,$EXTRACT($PIECE($$RACE^BUDHRPTC(DFN),U,4),1,16)," (",$PIECE($$RACE^BUDHRPTC(DFN),U,3),")"
+2 KILL BUDVLST
SET BUDV=0
FOR
SET BUDV=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"T5",BUDX2L,BUDX2L2,BUDCCOM,BUDAGE,BUDSEX,DFN,BUDV))
IF BUDV'=+BUDV!(BUDQUIT)
QUIT
Begin DoDot:1
+3 SET BUDVLST($PIECE(^AUPNVSIT(BUDV,0),U),BUDV)=""
End DoDot:1
+4 SET BUDDD=0
FOR
SET BUDDD=$ORDER(BUDVLST(BUDDD))
IF BUDDD=""!(BUDQUIT)
QUIT
Begin DoDot:1
+5 SET BUDV=0
FOR
SET BUDV=$ORDER(BUDVLST(BUDDD,BUDV))
IF BUDV'=+BUDV!(BUDQUIT)
QUIT
Begin DoDot:2
+6 IF BUDROT="P"
IF $Y>(IOSL-3)
DO T5H
IF BUDQUIT
QUIT
+7 IF BUDROT="P"
Begin DoDot:3
+8 WRITE !?5,$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT(BUDV,0),U),".")),?25,$EXTRACT($$PRIMPROV^APCLV(BUDV,"E"),1,14),?42,...
... $EXTRACT($$PRIMPROV^APCLV(BUDV,"D"),1,8),?50,$PIECE(^AUPNVSIT(BUDV,0),U,7),?55,$EXTRACT($$CLINIC^APCLV(BUDV,"E"),1,14),?70,$EXTRACT($$LOCENC^APCLV(BUDV,"E"),1,9)
End DoDot:3
+9 IF BUDROT="D"
Begin DoDot:3
+10 SET X=$PIECE(^DPT(DFN,0),U,1)_U_$SELECT($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))_U_$EXTRACT(BUDCCOM,1,12)_U_$PIECE(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCCAD)
+11 SET X=X_U_$EXTRACT($PIECE($$RACE^BUDHRPTC(DFN),U,4),1,16)_" ("_$PIECE($$RACE^BUDHRPTC(DFN),U,3)_")"
+12 SET X=X_U_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT(BUDV,0),U),"."))_U_$$PRIMPROV^APCLV(BUDV,"E")_U_$$PRIMPROV^APCLV(BUDV,"D")_U_$PIECE(^AUPNVSIT(BUDV,0),U,7)_U_$$CLINIC^APCLV(BUDV,"E")_U_$$LOCENC^APCLV(BUDV,"E")
+13 DO S(X)
+14 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+15 QUIT
T5DH ;
+1 DO T5DH^BUDHRPTE
+2 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 !,$$CTR("***** SENSITIVE INFORMATION *****",IOM)
+3 WRITE !?3,$PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?55,"Section "_BUDSCTC_" of "_BUDTSCTC_", Page "_BUDGPG,!
+4 WRITE !,$$CTR("*** RPMS Uniform Data System (UDS) "_$$VER^BUDHBAN()_" ***",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 SET X="Population: "_$SELECT($GET(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$GET(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$GET(BUDBEN)=3:"All (both Indian/Alaskan Natives and Non 01)",BUDBEN=4:"Homeless",1:"")
+9 WRITE $$CTR(X,80),!
+10 WRITE $TRANSLATE($JUSTIFY("",80)," ","-")
+11 IF BUDP=0
WRITE !,"List of all patients, sorted by defined Service Categories. Displays",!,"community, gender, age and visit data, including Provider codes.",!,"Age on the patient list is calculated as of June 30."
Begin DoDot:1
+12 WRITE !,"* (R) - denotes the value was obtained from the Race field"
+13 WRITE !," (C) - denotes the value was obtained from the Classification/Beneficiary field"
End DoDot:1
+14 WRITE !,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?50,"SEX",?55,"AGE",?60,"RACE*"
+15 WRITE !?5,"VISIT DATE",?25,"PROV TYPE",?41,"PROV CD",?50,"SRV",?55,"CLINIC",?62,"LOCATION"
+16 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+17 WRITE !!,BUDSUBT,!
+18 SET BUDP=1
+19 QUIT
TZ ;
+1 SET BUDP=0
+2 IF BUDROT="P"
DO TZH
IF BUDQUIT
QUIT
+3 IF BUDROT="D"
DO TZHD^BUDHRPTD
+4 SET BUDYY=0
FOR
SET BUDYY=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZNEW",BUDYY))
IF BUDYY'=+BUDYY!(BUDQUIT)
QUIT
DO TZ1
+5 IF BUDQUIT
QUIT
+6 ;
+7 SET BUDYY="Unknown Residence"
DO TZ2
+8 QUIT
TZ2 ;
+1 SET BUDINS=""
FOR
SET BUDINS=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDYY,BUDINS))
IF BUDINS=""!(BUDQUIT)
QUIT
Begin DoDot:1
+2 SET BUDCCOM=""
FOR
SET BUDCCOM=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDYY,BUDINS,BUDCCOM))
IF BUDCCOM=""!(BUDQUIT)
QUIT
Begin DoDot:2
+3 SET BUDSEX=""
FOR
SET BUDSEX=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDYY,BUDINS,BUDCCOM,BUDSEX))
IF BUDSEX=""!(BUDQUIT)
QUIT
Begin DoDot:3
+4 SET BUDNAME=""
FOR
SET BUDNAME=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDYY,BUDINS,BUDCCOM,BUDSEX,BUDNAME))
IF BUDNAME=""!(BUDQUIT)
QUIT
Begin DoDot:4
+5 SET DFN=""
FOR
SET DFN=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDYY,BUDINS,BUDCCOM,BUDSEX,BUDNAME,DFN))
IF DFN'=+DFN!(BUDQUIT)
QUIT
Begin DoDot:5
+6 IF BUDROT="P"
IF $Y>(IOSL-3)
DO TZH
IF BUDQUIT
QUIT
+7 IF BUDROT="P"
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(BUDCCOM,1,12),?51,$PIECE(^DPT(DFN,0),U
,2),?55,"Unk Res",?65,$$INS(BUDINS)
+8 SET BUDV=0
FOR
SET BUDV=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"Z",BUDYY,BUDINS,BUDCCOM,BUDSEX,BUDNAME,DFN,BUDV))
IF BUDV'=+BUDV!(BUDQUIT)
QUIT
Begin DoDot:6
+9 IF BUDROT="P"
IF $Y>(IOSL-3)
DO TZH
IF BUDQUIT
QUIT
+10 IF BUDROT="P"
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($$LOCENC^APCLV(BUDV,"E"),1,14)
+11 IF BUDROT="D"
Begin DoDot:7
+12 SET X=$PIECE(^DPT(DFN,0),U,1)_U_$SELECT($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))_U_$EXTRACT(BUDCCOM,1,12)_U_$PIECE(^DPT(DFN,0),U,2)_U_"Unk
Res"_U_$$INS(BUDINS)
+13 SET X=X_U_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT(BUDV,0),U),"."))_U_$$PRIMPROV^APCLV(BUDV,"E")_U_$PIECE(^AUPNVSIT(BUDV,0),U,7)_U_$$CLINIC^APCLV(BUDV,"E")_U_$$LOCENC^APCLV(BUDV,"E")
+14 DO S^BUDHRPTD(X)
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 IF BUDROT="P"
WRITE !
+16 QUIT
TZ1 ;
+1 SET BUDZIP=""
FOR
SET BUDZIP=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZIP))
IF BUDZIP=""!(BUDQUIT)
QUIT
Begin DoDot:1
+2 SET BUDINS=""
FOR
SET BUDINS=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZIP,BUDINS))
IF BUDINS=""!(BUDQUIT)
QUIT
Begin DoDot:2
+3 SET BUDCCOM=""
FOR
SET BUDCCOM=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZIP,BUDINS,BUDCCOM))
IF BUDCCOM=""!(BUDQUIT)
QUIT
Begin DoDot:3
+4 SET BUDSEX=""
FOR
SET BUDSEX=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZIP,BUDINS,BUDCCOM,BUDSEX))
IF BUDSEX=""!(BUDQUIT)
QUIT
Begin DoDot:4
+5 SET BUDNAME=""
FOR
SET BUDNAME=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZIP,BUDINS,BUDCCOM,BUDSEX,BUDNAME))
IF BUDNAME=""!(BUDQUIT)
QUIT
Begin DoDot:5
+6 SET DFN=""
FOR
SET DFN=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZIP,BUDINS,BUDCCOM,BUDSEX,BUDNAME,DFN))
IF DFN'=+DFN!(BUDQUIT)
QUIT
Begin DoDot:6
+7 IF BUDROT="P"
IF $Y>(IOSL-3)
DO TZH
IF BUDQUIT
QUIT
+8 IF BUDROT="P"
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(BUDCCOM,1,12),?51,$PIECE(^DPT(
DFN,0),U,2),?55,BUDZIP,?65,$$INS(BUDINS)
+9 SET BUDV=0
FOR
SET BUDV=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZIP,BUDINS,BUDCCOM,BUDSEX,BUDNAME,DFN,BUDV))
IF BUDV'=+BUDV!(BUDQUIT)
QUIT
Begin DoDot:7
+10 IF BUDROT="P"
IF $Y>(IOSL-3)
DO TZH
IF BUDQUIT
QUIT
+11 IF BUDROT="P"
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,
+12 IF BUDROT="D"
Begin DoDot:8
+13 SET X=$PIECE(^DPT(DFN,0),U,1)_U_$SELECT($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))_U_$EXTRACT(BUDCCOM,1,12)_U_$PIECE(^DPT(DFN,0),U,2)
_U_BUDZIP_U_$$INS(BUDINS)
+14 SET X=X_U_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT(BUDV,0),U),"."))_U_$$PRIMPROV^APCLV(BUDV,"E")_U_$PIECE(^AUPNVSIT(BUDV,0),U,7)_U_$$CLINIC^APCLV(BUDV,"E")_U_$$LOCENC^APCLV(BUDV,"E")
+15 DO S^BUDHRPTD(X)
End DoDot:8
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+16 IF BUDROT="P"
WRITE !
+17 QUIT
INS(Z) ;
+1 IF Z="e"
QUIT "PI"
+2 IF Z="d"
QUIT "Medicare"
+3 IF Z="c"
QUIT "MCD/CHIP/OP"
+4 IF Z="b"
QUIT "None/Unins"
+5 QUIT ""
TZH ;
+1 IF BUDROT="D"
QUIT
+2 DO TZH^BUDHRPTD
+3 QUIT
T6 ;
+1 IF BUDROT="D"
DO T6DH
+2 SET BUDP=0
+3 SET BUDX2L=0
FOR
SET BUDX2L=$ORDER(^BUDHTSC("B",BUDX2L))
IF BUDX2L'=+BUDX2L
QUIT
SET BUDY=0
FOR
SET BUDY=$ORDER(^BUDHTSC("B",BUDX2L,BUDY))
IF BUDY'=+BUDY
QUIT
Begin DoDot:1
+4 IF '$DATA(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L))
QUIT
+5 IF BUDROT="P"
DO T6H
IF BUDQUIT
QUIT
+6 SET BUDLLL=""
SET X=0
FOR
SET X=$ORDER(^BUDHTSC(BUDY,2,X))
IF X'=+X
QUIT
SET BUDLLL=BUDLLL_" "_$PIECE(^BUDHTSC(BUDY,2,X,0),U,1)
+7 IF BUDROT="P"
WRITE !!,"Line ",$PIECE(^BUDHTSC(BUDY,0),U,3)," ",BUDLLL
+8 IF BUDROT="D"
DO S("")
DO S("Line "_$PIECE(^BUDHTSC(BUDY,0),U,3)_" "_BUDLLL)
+9 SET BUDCCOM=""
FOR
SET BUDCCOM=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM))
IF BUDCCOM=""!(BUDQUIT)
QUIT
Begin DoDot:2
+10 SET BUDAGE=""
FOR
SET BUDAGE=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE))
IF BUDAGE=""!(BUDQUIT)
QUIT
Begin DoDot:3
+11 SET BUDSEX=""
FOR
SET BUDSEX=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE,BUDSEX))
IF BUDSEX=""!(BUDQUIT)
QUIT
Begin DoDot:4
+12 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE,BUDSEX,DFN))
IF DFN'=+DFN!(BUDQUIT)
QUIT
DO T6W
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+13 IF BUDROT="P"
WRITE !
+14 QUIT
T6W ;
+1 IF BUDROT="P"
IF $Y>(IOSL-3)
DO T6H
IF BUDQUIT
QUIT
WRITE !!,"Line ",$PIECE(^BUDHTSC(BUDY,0),U,3)," ",BUDLLL
+2 IF BUDROT="P"
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))
+3 IF BUDROT="P"
WRITE ?36,$EXTRACT(BUDCCOM,1,12),?51,$PIECE(^DPT(DFN,0),U,2),?55,$$AGE^AUPNPAT(DFN,BUDCCAD),?60,$EXTRACT($PIECE($$RACE^BUDHRPTC(DFN),U,4),1,16)," (",$PIECE($$RACE^BUDHRPTC(DFN),U,3),")"
+4 KILL BUDVRR
SET BUDV=0
SET BUDVC=0
FOR
SET BUDV=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE,BUDSEX,DFN,BUDV))
IF BUDV'=+BUDV!(BUDQUIT)
QUIT
SET BUDVC=BUDVC+1
SET BUDVRR($$VD^APCLV(BUDV),BUDVC)=BUDV
+5 SET BUDVD=0
FOR
SET BUDVD=$ORDER(BUDVRR(BUDVD))
IF BUDVD=""
QUIT
SET BUDVC=0
FOR
SET BUDVC=$ORDER(BUDVRR(BUDVD,BUDVC))
IF BUDVC=""
QUIT
Begin DoDot:1
+6 IF BUDROT="P"
IF $Y>(IOSL-3)
DO T6H
IF BUDQUIT
QUIT
WRITE !!,"Line ",$PIECE(^BUDHTSC(BUDY,0),U,3)," ",BUDLLL
+7 SET BUDV=BUDVRR(BUDVD,BUDVC)
+8 SET Z=^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE,BUDSEX,DFN,BUDV)
+9 FOR A=1:1
SET J=$PIECE(Z,U,A)
IF J=""
QUIT
Begin DoDot:2
+10 IF BUDROT="P"
WRITE !?5,$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT(BUDV,0),U),".")),?25,J,?40,$PIECE(^AUPNVSIT(BUDV,0),U,7),?45,$EXTRACT($$CLINIC^APCLV(BUDV,"E"),1,15),?62,$EXTRACT($$LOCENC^APCLV(BUDV,"E"),1,15)
QUIT
+11 SET X=$PIECE(^DPT(DFN,0),U,1)_U_$SELECT($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))_U_$EXTRACT(BUDCCOM,1,12)_U_$PIECE(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCCAD)
+12 SET X=X_U_$EXTRACT($PIECE($$RACE^BUDHRPTC(DFN),U,4),1,16)_" ("_$PIECE($$RACE^BUDHRPTC(DFN),U,3)_")"
+13 SET X=X_U_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT(BUDV,0),U),"."))_U_J_U_$PIECE(^AUPNVSIT(BUDV,0),U,7)_U_$$CLINIC^APCLV(BUDV,"E")_U_$$LOCENC^APCLV(BUDV,"E")
+14 DO S^BUDHRPTD(X)
+15 QUIT
End DoDot:2
End DoDot:1
+16 IF BUDX2L=35
Begin DoDot:1
+17 SET BUDW=0
FOR
SET BUDW=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE,BUDSEX,DFN,"WH","MAM",BUDW))
IF BUDW'=+BUDW!(BUDQUIT)
QUIT
Begin DoDot:2
+18 IF BUDROT="P"
WRITE !?5,$PIECE(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE,BUDSEX,DFN,"WH","MAM",BUDW),U,2),?25,$PIECE(^(BUDW),U,1)
+19 IF BUDROT="D"
Begin DoDot:3
+20 SET X=$PIECE(^DPT(DFN,0),U,1)_U_$SELECT($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))_U_$EXTRACT(BUDCCOM,1,12)_U_$PIECE(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCCAD)
+21 SET X=X_U_$EXTRACT($PIECE($$RACE^BUDHRPTC(DFN),U,4),1,16)_" ("_$PIECE($$RACE^BUDHRPTC(DFN),U,3)_")"
+22 SET X=X_U_$PIECE(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE,BUDSEX,DFN,"WH","MAM",BUDW),U,2)_U_$PIECE(^(BUDW),U,1)
+23 DO S(X)
End DoDot:3
End DoDot:2
End DoDot:1
+24 IF BUDX2L=36
Begin DoDot:1
+25 SET BUDW=0
FOR
SET BUDW=$ORDER(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE,BUDSEX,DFN,"WH","PAP",BUDW))
IF BUDW'=+BUDW!(BUDQUIT)
QUIT
Begin DoDot:2
+26 IF BUDROT="P"
WRITE !?5,$PIECE(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE,BUDSEX,DFN,"WH","PAP",BUDW),U,2),?25,$PIECE(^(BUDW),U,1)
+27 IF BUDROT="D"
Begin DoDot:3
+28 SET X=$PIECE(^DPT(DFN,0),U,1)_U_$SELECT($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))_U_$EXTRACT(BUDCCOM,1,12)_U_$PIECE(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCCAD)
+29 SET X=X_U_$EXTRACT($PIECE($$RACE^BUDHRPTC(DFN),U,4),1,16)_" ("_$PIECE($$RACE^BUDHRPTC(DFN),U,3)_")"
+30 SET X=X_U_$PIECE(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE,BUDSEX,DFN,"WH","PAP",BUDW),U,2)_U_$PIECE(^(BUDW),U,1)
+31 DO S(X)
End DoDot:3
End DoDot:2
End DoDot:1
+32 QUIT
T6H ;
+1 IF BUDROT="D"
DO T6DH
QUIT
+2 IF 'BUDGPG
GOTO T6H1
+3 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 !,$$CTR("***** SENSITIVE INFORMATION *****",IOM)
+3 WRITE !?3,$PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?55,"Section "_BUDSCTC_" of "_BUDTSCTC_", Page "_BUDGPG,!
+4 WRITE !,$$CTR("Patient List for Table 6A, By Diagnosis Category",80),!
+5 WRITE $$CTR($PIECE(^DIC(4,BUDSITE,0),U),80),!
+6 SET X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED)
WRITE $$CTR(X,80),!
+7 SET X="Population: "_$SELECT($GET(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$GET(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$GET(BUDBEN)=3:"All (both Indian/Alaskan Natives and Non 01)",BUDBEN=4:"Homeless",1:"")
+8 WRITE $$CTR(X,80),!
+9 WRITE $TRANSLATE($JUSTIFY("",80)," ","-")
+10 IF BUDP=0
WRITE !,"List of all patients, sorted by diagnosis and tests/screening",!,"categories. Displays community, gender, age and visit data, and codes."
Begin DoDot:1
+11 WRITE !,"* (R) - denotes the value was obtained from the Race field"
+12 WRITE !," (C) - denotes the value was obtained from the Classification/Beneficiary field"
End DoDot:1
+13 WRITE !,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?50,"SEX",?55,"AGE",?60,"RACE*"
+14 WRITE !?5,"VISIT DATE",?25,"VALUE",?41,"SRV",?45,"CLINIC",?63,"LOCATION"
+15 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+16 SET BUDP=1
+17 QUIT
CTR(X,Y) ;
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
T6DH ;
+1 DO T6DH^BUDHRPTD
+2 QUIT
