- BUDERPTL ; IHS/CMI/LAB - UDS ;
- ;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
- ;
- START ;
- S BUDQUIT="",BUDGPG=0
- I $G(BUDTZL) S BUDGPG=0 D TZ
- Q:BUDQUIT
- I $G(BUDT3AL) S BUDGPG=0 D T3A
- Q:BUDQUIT
- I $G(BUDT3BRL) S BUDGPG=0 D T3BR
- Q:BUDQUIT
- I $G(BUDT4IPP) S BUDGPG=0 D T4IPPL
- Q:BUDQUIT
- I $G(BUDT4PMI) S BUDGPG=0 D T4PMIS
- Q:BUDQUIT
- I $G(BUDT4CHA) S BUDGPG=0 D T4CHAR
- Q:BUDQUIT
- I $G(BUDT5L1) S BUDGPG=0 D T51
- Q:BUDQUIT
- I $G(BUDT5L) S BUDGPG=0 D T5
- Q:BUDQUIT
- I $G(BUDT5L2) S BUDGPG=0 D T52
- Q:BUDQUIT
- I $G(BUDT6L) S BUDGPG=0 D T6
- Q:BUDQUIT
- Q
- S(V) ;
- S BUDDECNT=BUDDECNT+1
- S ^TMP($J,"BUDDEL",BUDDECNT)=$G(V)
- Q
- T3BR ;
- D T3BR^BUDERPL4
- Q
- T4IPPL ;
- D T4IPPL^BUDERPL5
- Q
- T4PMIS ;
- D T4PMIS^BUDERPL5
- Q
- T4CHAR ;
- D T4CHAR^BUDERPL5
- Q
- T3A ;
- D T3A^BUDERPL2
- Q
- T52 ;
- D T52^BUDERPL2
- Q
- T51 ;EP
- D T51^BUDERPL2
- Q
- T5 ;
- I BUDROT="D" D T5DH
- S BUDP=0
- S BUDX2L="" F S BUDX2L=$O(^XTMP("BUDERPT1",BUDJ,BUDH,"T5",BUDX2L)) Q:BUDX2L=""!(BUDQUIT) D
- .Q:BUDX2L=35
- .S BUDX2L2="" F S BUDX2L2=$O(^XTMP("BUDERPT1",BUDJ,BUDH,"T5",BUDX2L,BUDX2L2)) Q:BUDX2L2=""!(BUDQUIT) D
- ..S BUDX2LL=BUDX2L_$S(BUDX2L2=0:"",1:BUDX2L2)
- ..S BUDY=$O(^BUDETFIV("B",BUDX2LL,0)),BUDY=$P(^BUDETFIV(BUDY,0),U,2)_" "_$P(^BUDETFIV(BUDY,0),U,3)_" "_$P(^BUDETFIV(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("BUDERPT1",BUDJ,BUDH,"T5",BUDX2L,BUDX2L2,BUDCCOM)) Q:BUDCCOM=""!(BUDQUIT) D
- ...S BUDAGE="" F S BUDAGE=$O(^XTMP("BUDERPT1",BUDJ,BUDH,"T5",BUDX2L,BUDX2L2,BUDCCOM,BUDAGE)) Q:BUDAGE=""!(BUDQUIT) D
- ....S BUDSEX="" F S BUDSEX=$O(^XTMP("BUDERPT1",BUDJ,BUDH,"T5",BUDX2L,BUDX2L2,BUDCCOM,BUDAGE,BUDSEX)) Q:BUDSEX=""!(BUDQUIT) D
- .....S DFN=0 F S DFN=$O(^XTMP("BUDERPT1",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^BUDERPTC(DFN),U,4),1,16)," (",$P($$RACE^BUDERPTC(DFN),U,3),")"
- K BUDVLST S BUDV=0 F S BUDV=$O(^XTMP("BUDERPT1",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^BUDERPTC(DFN),U,4),1,16)_" ("_$P($$RACE^BUDERPTC(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^BUDERPTE
- 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("*** RPMS 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),!
- 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 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^BUDERPTD
- S BUDYY=0 F S BUDYY=$O(^XTMP("BUDERPT1",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("BUDERPT1",BUDJ,BUDH,"Z",BUDYY,BUDINS)) Q:BUDINS=""!(BUDQUIT) D
- .S BUDCCOM="" F S BUDCCOM=$O(^XTMP("BUDERPT1",BUDJ,BUDH,"Z",BUDYY,BUDINS,BUDCCOM)) Q:BUDCCOM=""!(BUDQUIT) D
- ..S BUDSEX="" F S BUDSEX=$O(^XTMP("BUDERPT1",BUDJ,BUDH,"Z",BUDYY,BUDINS,BUDCCOM,BUDSEX)) Q:BUDSEX=""!(BUDQUIT) D
- ...S BUDNAME="" F S BUDNAME=$O(^XTMP("BUDERPT1",BUDJ,BUDH,"Z",BUDYY,BUDINS,BUDCCOM,BUDSEX,BUDNAME)) Q:BUDNAME=""!(BUDQUIT) D
- ....S DFN="" F S DFN=$O(^XTMP("BUDERPT1",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("BUDERPT1",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^BUDERPTD(X)
- I BUDROT="P" W !
- Q
- TZ1 ;
- S BUDZIP="" F S BUDZIP=$O(^XTMP("BUDERPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZIP)) Q:BUDZIP=""!(BUDQUIT) D
- .S BUDINS="" F S BUDINS=$O(^XTMP("BUDERPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZIP,BUDINS)) Q:BUDINS=""!(BUDQUIT) D
- ..S BUDCCOM="" F S BUDCCOM=$O(^XTMP("BUDERPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZIP,BUDINS,BUDCCOM)) Q:BUDCCOM=""!(BUDQUIT) D
- ...S BUDSEX="" F S BUDSEX=$O(^XTMP("BUDERPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZIP,BUDINS,BUDCCOM,BUDSEX)) Q:BUDSEX=""!(BUDQUIT) D
- ....S BUDNAME="" F S BUDNAME=$O(^XTMP("BUDERPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZIP,BUDINS,BUDCCOM,BUDSEX,BUDNAME)) Q:BUDNAME=""!(BUDQUIT) D
- .....S DFN="" F S DFN=$O(^XTMP("BUDERPT1",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("BUDERPT1",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^BUDERPTD(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^BUDERPTD
- Q
- T6 ;
- I BUDROT="D" D T6DH
- S BUDP=0
- S BUDX2L=0 F S BUDX2L=$O(^BUDETSC("B",BUDX2L)) Q:BUDX2L'=+BUDX2L S BUDY=0 F S BUDY=$O(^BUDETSC("B",BUDX2L,BUDY)) Q:BUDY'=+BUDY D
- .Q:'$D(^XTMP("BUDERPT1",BUDJ,BUDH,"T6",BUDX2L))
- .I BUDROT="P" D T6H Q:BUDQUIT
- .S BUDLLL="",X=0 F S X=$O(^BUDETSC(BUDY,2,X)) Q:X'=+X S BUDLLL=BUDLLL_" "_$P(^BUDETSC(BUDY,2,X,0),U,1)
- .I BUDROT="P" W !!,"Line ",$P(^BUDETSC(BUDY,0),U,3)," ",BUDLLL
- .I BUDROT="D" D S(""),S("Line "_$P(^BUDETSC(BUDY,0),U,3)_" "_BUDLLL)
- .S BUDCCOM="" F S BUDCCOM=$O(^XTMP("BUDERPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM)) Q:BUDCCOM=""!(BUDQUIT) D
- ..S BUDAGE="" F S BUDAGE=$O(^XTMP("BUDERPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE)) Q:BUDAGE=""!(BUDQUIT) D
- ...S BUDSEX="" F S BUDSEX=$O(^XTMP("BUDERPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE,BUDSEX)) Q:BUDSEX=""!(BUDQUIT) D
- ....S DFN=0 F S DFN=$O(^XTMP("BUDERPT1",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(^BUDETSC(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^BUDERPTC(DFN),U,4),1,16)," (",$P($$RACE^BUDERPTC(DFN),U,3),")"
- K BUDVRR S BUDV=0,BUDVC=0 F S BUDV=$O(^XTMP("BUDERPT1",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(^BUDETSC(BUDY,0),U,3)," ",BUDLLL
- .S BUDV=BUDVRR(BUDVD,BUDVC)
- .S Z=^XTMP("BUDERPT1",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^BUDERPTC(DFN),U,4),1,16)_" ("_$P($$RACE^BUDERPTC(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^BUDERPTD(X)
- ..Q
- I BUDX2L=35 D
- .S BUDW=0 F S BUDW=$O(^XTMP("BUDERPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE,BUDSEX,DFN,"WH","MAM",BUDW)) Q:BUDW'=+BUDW!(BUDQUIT) D
- ..I BUDROT="P" W !?5,$P(^XTMP("BUDERPT1",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^BUDERPTC(DFN),U,4),1,16)_" ("_$P($$RACE^BUDERPTC(DFN),U,3)_")"
- ...S X=X_U_$P(^XTMP("BUDERPT1",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("BUDERPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE,BUDSEX,DFN,"WH","PAP",BUDW)) Q:BUDW'=+BUDW!(BUDQUIT) D
- ..I BUDROT="P" W !?5,$P(^XTMP("BUDERPT1",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^BUDERPTC(DFN),U,4),1,16)_" ("_$P($$RACE^BUDERPTC(DFN),U,3)_")"
- ...S X=X_U_$P(^XTMP("BUDERPT1",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 !,"***** 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 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^BUDERPTD
- Q
- BUDERPTL ; IHS/CMI/LAB - UDS ;
- +1 ;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
- +2 ;
- START ;
- +1 SET BUDQUIT=""
- SET BUDGPG=0
- +2 IF $GET(BUDTZL)
- SET BUDGPG=0
- DO TZ
- +3 IF BUDQUIT
- QUIT
- +4 IF $GET(BUDT3AL)
- SET BUDGPG=0
- DO T3A
- +5 IF BUDQUIT
- QUIT
- +6 IF $GET(BUDT3BRL)
- SET BUDGPG=0
- DO T3BR
- +7 IF BUDQUIT
- QUIT
- +8 IF $GET(BUDT4IPP)
- SET BUDGPG=0
- DO T4IPPL
- +9 IF BUDQUIT
- QUIT
- +10 IF $GET(BUDT4PMI)
- SET BUDGPG=0
- DO T4PMIS
- +11 IF BUDQUIT
- QUIT
- +12 IF $GET(BUDT4CHA)
- SET BUDGPG=0
- DO T4CHAR
- +13 IF BUDQUIT
- QUIT
- +14 IF $GET(BUDT5L1)
- SET BUDGPG=0
- DO T51
- +15 IF BUDQUIT
- QUIT
- +16 IF $GET(BUDT5L)
- SET BUDGPG=0
- DO T5
- +17 IF BUDQUIT
- QUIT
- +18 IF $GET(BUDT5L2)
- SET BUDGPG=0
- DO T52
- +19 IF BUDQUIT
- QUIT
- +20 IF $GET(BUDT6L)
- SET BUDGPG=0
- DO T6
- +21 IF BUDQUIT
- QUIT
- +22 QUIT
- S(V) ;
- +1 SET BUDDECNT=BUDDECNT+1
- +2 SET ^TMP($JOB,"BUDDEL",BUDDECNT)=$GET(V)
- +3 QUIT
- T3BR ;
- +1 DO T3BR^BUDERPL4
- +2 QUIT
- T4IPPL ;
- +1 DO T4IPPL^BUDERPL5
- +2 QUIT
- T4PMIS ;
- +1 DO T4PMIS^BUDERPL5
- +2 QUIT
- T4CHAR ;
- +1 DO T4CHAR^BUDERPL5
- +2 QUIT
- T3A ;
- +1 DO T3A^BUDERPL2
- +2 QUIT
- T52 ;
- +1 DO T52^BUDERPL2
- +2 QUIT
- T51 ;EP
- +1 DO T51^BUDERPL2
- +2 QUIT
- T5 ;
- +1 IF BUDROT="D"
- DO T5DH
- +2 SET BUDP=0
- +3 SET BUDX2L=""
- FOR
- SET BUDX2L=$ORDER(^XTMP("BUDERPT1",BUDJ,BUDH,"T5",BUDX2L))
- IF BUDX2L=""!(BUDQUIT)
- QUIT
- Begin DoDot:1
- +4 IF BUDX2L=35
- QUIT
- +5 SET BUDX2L2=""
- FOR
- SET BUDX2L2=$ORDER(^XTMP("BUDERPT1",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(^BUDETFIV("B",BUDX2LL,0))
- SET BUDY=$PIECE(^BUDETFIV(BUDY,0),U,2)_" "_$PIECE(^BUDETFIV(BUDY,0),U,3)_" "_$PIECE(^BUDETFIV(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("BUDERPT1",BUDJ,BUDH,"T5",BUDX2L,BUDX2L2,BUDCCOM))
- IF BUDCCOM=""!(BUDQUIT)
- QUIT
- Begin DoDot:3
- +12 SET BUDAGE=""
- FOR
- SET BUDAGE=$ORDER(^XTMP("BUDERPT1",BUDJ,BUDH,"T5",BUDX2L,BUDX2L2,BUDCCOM,BUDAGE))
- IF BUDAGE=""!(BUDQUIT)
- QUIT
- Begin DoDot:4
- +13 SET BUDSEX=""
- FOR
- SET BUDSEX=$ORDER(^XTMP("BUDERPT1",BUDJ,BUDH,"T5",BUDX2L,BUDX2L2,BUDCCOM,BUDAGE,BUDSEX))
- IF BUDSEX=""!(BUDQUIT)
- QUIT
- Begin DoDot:5
- +14 SET DFN=0
- FOR
- SET DFN=$ORDER(^XTMP("BUDERPT1",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^BUDERPTC(DFN),U,4),1,16)," (",$PIECE($$RACE^BUDERPTC(DFN),U,3),")"
- +2 KILL BUDVLST
- SET BUDV=0
- FOR
- SET BUDV=$ORDER(^XTMP("BUDERPT1",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^BUDERPTC(DFN),U,4),1,16)_" ("_$PIECE($$RACE^BUDERPTC(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^BUDERPTE
- +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 !,"***** 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 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 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^BUDERPTD
- +4 SET BUDYY=0
- FOR
- SET BUDYY=$ORDER(^XTMP("BUDERPT1",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("BUDERPT1",BUDJ,BUDH,"Z",BUDYY,BUDINS))
- IF BUDINS=""!(BUDQUIT)
- QUIT
- Begin DoDot:1
- +2 SET BUDCCOM=""
- FOR
- SET BUDCCOM=$ORDER(^XTMP("BUDERPT1",BUDJ,BUDH,"Z",BUDYY,BUDINS,BUDCCOM))
- IF BUDCCOM=""!(BUDQUIT)
- QUIT
- Begin DoDot:2
- +3 SET BUDSEX=""
- FOR
- SET BUDSEX=$ORDER(^XTMP("BUDERPT1",BUDJ,BUDH,"Z",BUDYY,BUDINS,BUDCCOM,BUDSEX))
- IF BUDSEX=""!(BUDQUIT)
- QUIT
- Begin DoDot:3
- +4 SET BUDNAME=""
- FOR
- SET BUDNAME=$ORDER(^XTMP("BUDERPT1",BUDJ,BUDH,"Z",BUDYY,BUDINS,BUDCCOM,BUDSEX,BUDNAME))
- IF BUDNAME=""!(BUDQUIT)
- QUIT
- Begin DoDot:4
- +5 SET DFN=""
- FOR
- SET DFN=$ORDER(^XTMP("BUDERPT1",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("BUDERPT1",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^BUDERPTD(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("BUDERPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZIP))
- IF BUDZIP=""!(BUDQUIT)
- QUIT
- Begin DoDot:1
- +2 SET BUDINS=""
- FOR
- SET BUDINS=$ORDER(^XTMP("BUDERPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZIP,BUDINS))
- IF BUDINS=""!(BUDQUIT)
- QUIT
- Begin DoDot:2
- +3 SET BUDCCOM=""
- FOR
- SET BUDCCOM=$ORDER(^XTMP("BUDERPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZIP,BUDINS,BUDCCOM))
- IF BUDCCOM=""!(BUDQUIT)
- QUIT
- Begin DoDot:3
- +4 SET BUDSEX=""
- FOR
- SET BUDSEX=$ORDER(^XTMP("BUDERPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZIP,BUDINS,BUDCCOM,BUDSEX))
- IF BUDSEX=""!(BUDQUIT)
- QUIT
- Begin DoDot:4
- +5 SET BUDNAME=""
- FOR
- SET BUDNAME=$ORDER(^XTMP("BUDERPT1",BUDJ,BUDH,"ZNEW",BUDYY,BUDZIP,BUDINS,BUDCCOM,BUDSEX,BUDNAME))
- IF BUDNAME=""!(BUDQUIT)
- QUIT
- Begin DoDot:5
- +6 SET DFN=""
- FOR
- SET DFN=$ORDER(^XTMP("BUDERPT1",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("BUDERPT1",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^BUDERPTD(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^BUDERPTD
- +3 QUIT
- T6 ;
- +1 IF BUDROT="D"
- DO T6DH
- +2 SET BUDP=0
- +3 SET BUDX2L=0
- FOR
- SET BUDX2L=$ORDER(^BUDETSC("B",BUDX2L))
- IF BUDX2L'=+BUDX2L
- QUIT
- SET BUDY=0
- FOR
- SET BUDY=$ORDER(^BUDETSC("B",BUDX2L,BUDY))
- IF BUDY'=+BUDY
- QUIT
- Begin DoDot:1
- +4 IF '$DATA(^XTMP("BUDERPT1",BUDJ,BUDH,"T6",BUDX2L))
- QUIT
- +5 IF BUDROT="P"
- DO T6H
- IF BUDQUIT
- QUIT
- +6 SET BUDLLL=""
- SET X=0
- FOR
- SET X=$ORDER(^BUDETSC(BUDY,2,X))
- IF X'=+X
- QUIT
- SET BUDLLL=BUDLLL_" "_$PIECE(^BUDETSC(BUDY,2,X,0),U,1)
- +7 IF BUDROT="P"
- WRITE !!,"Line ",$PIECE(^BUDETSC(BUDY,0),U,3)," ",BUDLLL
- +8 IF BUDROT="D"
- DO S("")
- DO S("Line "_$PIECE(^BUDETSC(BUDY,0),U,3)_" "_BUDLLL)
- +9 SET BUDCCOM=""
- FOR
- SET BUDCCOM=$ORDER(^XTMP("BUDERPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM))
- IF BUDCCOM=""!(BUDQUIT)
- QUIT
- Begin DoDot:2
- +10 SET BUDAGE=""
- FOR
- SET BUDAGE=$ORDER(^XTMP("BUDERPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE))
- IF BUDAGE=""!(BUDQUIT)
- QUIT
- Begin DoDot:3
- +11 SET BUDSEX=""
- FOR
- SET BUDSEX=$ORDER(^XTMP("BUDERPT1",BUDJ,BUDH,"T6",BUDX2L,BUDCCOM,BUDAGE,BUDSEX))
- IF BUDSEX=""!(BUDQUIT)
- QUIT
- Begin DoDot:4
- +12 SET DFN=0
- FOR
- SET DFN=$ORDER(^XTMP("BUDERPT1",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(^BUDETSC(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^BUDERPTC(DFN),U,4),1,16)," (",$PIECE($$RACE^BUDERPTC(DFN),U,3),")"
- +4 KILL BUDVRR
- SET BUDV=0
- SET BUDVC=0
- FOR
- SET BUDV=$ORDER(^XTMP("BUDERPT1",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(^BUDETSC(BUDY,0),U,3)," ",BUDLLL
- +7 SET BUDV=BUDVRR(BUDVD,BUDVC)
- +8 SET Z=^XTMP("BUDERPT1",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^BUDERPTC(DFN),U,4),1,16)_" ("_$PIECE($$RACE^BUDERPTC(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^BUDERPTD(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("BUDERPT1",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("BUDERPT1",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^BUDERPTC(DFN),U,4),1,16)_" ("_$PIECE($$RACE^BUDERPTC(DFN),U,3)_")"
- +22 SET X=X_U_$PIECE(^XTMP("BUDERPT1",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("BUDERPT1",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("BUDERPT1",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^BUDERPTC(DFN),U,4),1,16)_" ("_$PIECE($$RACE^BUDERPTC(DFN),U,3)_")"
- +30 SET X=X_U_$PIECE(^XTMP("BUDERPT1",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 !,"***** 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 6A, 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 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 diagnosis and tests/screening",!,"categories. Displays community, gender, age and visit data, and codes."
- 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,"VALUE",?41,"SRV",?45,"CLINIC",?63,"LOCATION"
- +16 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
- +17 SET BUDP=1
- +18 QUIT
- CTR(X,Y) ;
- +1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
- T6DH ;
- +1 DO T6DH^BUDERPTD
- +2 QUIT