BUDDRPL3 ; IHS/CMI/LAB - UDS print lists ;
;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
;
T53 ;EP
S BUDP=0
D T53H
S BUDX2L=35,BUDX2L2=0,BUDY=$O(^BUDDTFIV("B",BUDX2L,0)),BUDY=$P(^BUDDTFIV(BUDY,0),U,2)_" "_$P(^BUDDTFIV(BUDY,0),U,3)_" "_$P(^BUDDTFIV(BUDY,0),U,4)
S BUDCCOM="" F S BUDCCOM=$O(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM)) Q:BUDCCOM=""!(BUDQUIT) D
.S BUDAGE="" F S BUDAGE=$O(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE)) Q:BUDAGE=""!(BUDQUIT) D
..S BUDSEX="" F S BUDSEX=$O(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX)) Q:BUDSEX=""!(BUDQUIT) D
...S DFN=0 F S DFN=$O(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN)) Q:DFN'=+DFN!(BUDQUIT) D T5W
...Q
..Q
.Q
W !
Q
T5W ;
I '$$DUP(DFN),'$$DUPOE(DFN,"OTH SERV"),'$$DUPOE(DFN,"ENA SERV") Q ;NO DUPES
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)
W ?51,$P(^DPT(DFN,0),U,2),?55,$$AGE^AUPNPAT(DFN,BUDCCAD),?60,$E($P($$RACE^BUDDRPTC(DFN),U,3)_"-"_$P($$RACE^BUDDRPTC(DFN),U,4),1,19)
D MEDSERV
Q:BUDQUIT
D DENTSERV
Q:BUDQUIT
D MENTSERV
Q:BUDQUIT
D SUBSERV
Q:BUDQUIT
D OTHSERV
Q:BUDQUIT
D ENASERV
Q:BUDQUIT
Q
;
TW ;
W !?5,$$FMTE^XLFDT($P($P(^AUPNVSIT(BUDV,0),U),".")),?18,$E($$PRIMPROV^APCLV(BUDV,"E"),1,17),?36,$$PRIMPROV^APCLV(BUDV,"T"),?42,$$PRIMPROV^APCLV(BUDV,"D")
W ?48,$$PRIMPOV^APCLV(BUDV,"C"),?56,$P(^AUPNVSIT(BUDV,0),U,7),?59,$E($$CLINIC^APCLV(BUDV,"E"),1,9),?70,$E($$LOCENC^APCLV(BUDV,"E"),1,9)
Q
MEDSERV ;
Q:'$$DUP(DFN,"MED SERV")
W !!,"Line 15 Total Medical Care"
I $Y>(IOSL-4) D T53H Q:BUDQUIT
S BUDD=0 F S BUDD=$O(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MED SERV",BUDD)) Q:BUDD'=+BUDD!(BUDQUIT) D
.Q:$P(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MED SERV",BUDD),U,2)=""
.F BUDPIEC=1:1 S BUDV=$P(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MED SERV",BUDD),U,BUDPIEC) Q:BUDV=""!(BUDQUIT) D
..I $Y>(IOSL-3) D T53H Q:BUDQUIT
..D TW
..Q
Q
DENTSERV ;
Q:'$$DUP(DFN,"DENT SERV")
W !!,"Line 19 Total Dental Services"
I $Y>(IOSL-4) D T53H Q:BUDQUIT
S BUDD=0 F S BUDD=$O(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",BUDD)) Q:BUDD'=+BUDD!(BUDQUIT) D
.Q:$P(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",BUDD),U,2)=""
.F BUDPIEC=1:1 S BUDV=$P(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",BUDD),U,BUDPIEC) Q:BUDV=""!(BUDQUIT) D
..I $Y>(IOSL-3) D T53H Q:BUDQUIT
..D TW
..Q
Q
MENTSERV ;
Q:'$$DUP(DFN,"MENT SERV")
W !!,"Line 20 Mental Health"
I $Y>(IOSL-4) D T53H Q:BUDQUIT
S BUDD=0 F S BUDD=$O(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",BUDD)) Q:BUDD'=+BUDD!(BUDQUIT) D
.Q:$P(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",BUDD),U,2)=""
.F BUDPIEC=1:1 S BUDV=$P(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",BUDD),U,BUDPIEC) Q:BUDV=""!(BUDQUIT) D
..I $Y>(IOSL-3) D T53H Q:BUDQUIT
..D TW
..Q
Q
SUBSERV ;
Q:'$$DUP(DFN,"SUB SERV")
W !!,"Line 21 Substance Abuse Services"
I $Y>(IOSL-4) D T53H Q:BUDQUIT
S BUDD=0 F S BUDD=$O(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",BUDD)) Q:BUDD'=+BUDD!(BUDQUIT) D
.Q:$P(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",BUDD),U,2)=""
.F BUDPIEC=1:1 S BUDV=$P(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",BUDD),U,BUDPIEC) Q:BUDV=""!(BUDQUIT) D
..I $Y>(IOSL-3) D T53H Q:BUDQUIT
..D TW
..Q
Q
OTHSERV ;
Q:'$$DUPOE(DFN,"OTH SERV")
W !!,"Line 22 Other Professional Services"
I $Y>(IOSL-4) D T53H Q:BUDQUIT
S BUDDIS="" F S BUDDIS=$O(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDDIS)) Q:BUDDIS=""!(BUDQUIT) D OTHSERV1
Q
OTHSERV1 ;
S BUDD=0 F S BUDD=$O(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDDIS,BUDD)) Q:BUDD'=+BUDD!(BUDQUIT) D
.Q:$P(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDDIS,BUDD),U,2)=""
.F BUDPIEC=1:1 S BUDV=$P(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDDIS,BUDD),U,BUDPIEC) Q:BUDV=""!(BUDQUIT) D
..I $Y>(IOSL-3) D T53H Q:BUDQUIT
..D TW
..Q
Q
ENASERV ;
Q:'$$DUPOE(DFN,"ENA SERV")
W !!,"Line 29 Total Enabling Services"
I $Y>(IOSL-4) D T53H Q:BUDQUIT
S BUDDIS="" F S BUDDIS=$O(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDDIS)) Q:BUDDIS=""!(BUDQUIT) D ENASERV1
Q
ENASERV1 ;
S BUDD=0 F S BUDD=$O(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDDIS,BUDD)) Q:BUDD'=+BUDD!(BUDQUIT) D
.Q:$P(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDDIS,BUDD),U,2)=""
.F BUDPIEC=1:1 S BUDV=$P(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDDIS,BUDD),U,BUDPIEC) Q:BUDV=""!(BUDQUIT) D
..I $Y>(IOSL-3) D T53H Q:BUDQUIT
..D TW
..Q
Q
DUP(DFN,T) ;
NEW X,Y,G
S G=""
S T=$G(T)
I T="" D Q G
.F X="MED SERV","DENT SERV","MENT SERV","SUB SERV" D
..S Y=0 S Y=$O(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,X,Y)) I Y D
...I $P(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,X,Y),U,2)]"" S G=1
...Q
S Y=0 F S Y=$O(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,T,Y)) Q:Y'=+Y D
.I $P(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,T,Y),U,2)]"" S G=1
.Q
Q G
;
DUPOE(DFN,T) ;
NEW X,Y,G
S G=""
S T=$G(T)
I T="" Q ""
S Y="" F S Y=$O(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,T,Y)) Q:Y'=+Y D
.S X=0 F S X=$O(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,T,Y,X)) Q:X'=+X D
..I $P(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,T,Y,X),U,2)]"" S G=1
.Q
Q G
T53H ;
G:'BUDGPG T5H2
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
T5H2 ;
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, Patients w/Multiple Visits on Same",80)
W !,$$CTR("Day in Same Service Categories",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 patients with multiple visits on the same day for the same",!,"BPHC service category.",!,"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 !
W !,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?50,"SEX",?55,"AGE",?60,"RACE*"
W !?5,"VISIT DATE",?18,"PROV TYPE",?36,"INI",?40,"PROV CD",?48,"PRI DX",?55,"SRV",?59,"CLINIC",?70,"LOCATION"
W !,$TR($J("",80)," ","-")
; !!,BUDSUBT,!
S BUDP=1
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")
;----------
T3A ;EP
I $G(BUDSTMP) D STEMP^BUDDRPTS
S BUDPG=0
D HEADER^BUDDRPTP Q:BUDQUIT D T3ASH
;print out each line
S BUDZ=0 F S BUDZ=$O(^BUDDTTA("AC",BUDZ)) Q:BUDZ>38!(BUDQUIT) D
.S BUDD=$O(^BUDDTTA("AC",BUDZ,0))
.I $Y>(IOSL-3) D HEADER^BUDDRPTP Q:BUDQUIT D T3ASH
.S BUDY=^BUDDTTA(BUDD,0)
.S BUDX=$P(BUDY,U,2) ;column one End control
.W !
.I BUDX<10 W " "
.W $P(BUDY,U,2),?5,$P(BUDY,U,3)
.;I +BUDX=0 Q
.W ?35,$$C($P(BUDTOT("M"),U,BUDX)),?50,$$C($P(BUDTOT("F"),U,BUDX)),?68,$$C($P(BUDTOT("ALL"),U,BUDX))
.I BUDX=18 D
..I $Y>(IOSL-4) D HEADER^BUDDRPTP Q:BUDQUIT D T3ASH
..W !!?10,"SUBTOTAL Ages 0-17",?35,$$C(BUD019("M")),?50,$$C(BUD019("F")),?68,$$C(BUD019("ALL")),!
S BUDD=$O(^BUDDTTA("B",43,0))
I $Y>(IOSL-3) D HEADER^BUDDRPTP Q:BUDQUIT D T3ASH
W !,$P(^BUDDTTA(BUDD,0),U,2),?5,$P(^BUDDTTA(BUDD,0),U,3)
S BUDD=$O(^BUDDTTA("AC",39,0))
I $Y>(IOSL-2) D HEADER^BUDDRPTP Q:BUDQUIT D T3ASH
S BUDY=^BUDDTTA(BUDD,0)
S BUDX=$P(BUDY,U,2) ;column one End control
W !
W $P(BUDY,U,2),?5,$P(BUDY,U,3)
W ?35,$$C($P(BUDTOT("M"),U,BUDX)),?50,$$C($P(BUDTOT("F"),U,BUDX)),?68,$$C($P(BUDTOT("ALL"),U,BUDX))
W !
Q
T3ASH ;
W !,$$CTR($G(^BUDDTTA(1,11)),80),!
F Y=2:1:4 S X=$O(^BUDDTTA("B",Y,0)) W !,$P(^BUDDTTA(X,0),U,2),?5,$P(^BUDDTTA(X,0),U,3),?33,$P(^BUDDTTA(X,0),U,4),?50,$P(^BUDDTTA(X,0),U,5),?68,$P(^BUDDTTA(X,0),U,6)
W !,$TR($J("",80)," ","-")
Q
C(X,Y) ;
I $G(Y)=1,+X=0 Q ""
I $G(Y)=2 Q "********"
S X2=0,X3=8
D COMMA^%DTC
Q X
BUDDRPL3 ; IHS/CMI/LAB - UDS print lists ;
+1 ;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
+2 ;
T53 ;EP
+1 SET BUDP=0
+2 DO T53H
+3 SET BUDX2L=35
SET BUDX2L2=0
SET BUDY=$ORDER(^BUDDTFIV("B",BUDX2L,0))
SET BUDY=$PIECE(^BUDDTFIV(BUDY,0),U,2)_" "_$PIECE(^BUDDTFIV(BUDY,0),U,3)_" "_$PIECE(^BUDDTFIV(BUDY,0),U,4)
+4 SET BUDCCOM=""
FOR
SET BUDCCOM=$ORDER(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM))
IF BUDCCOM=""!(BUDQUIT)
QUIT
Begin DoDot:1
+5 SET BUDAGE=""
FOR
SET BUDAGE=$ORDER(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE))
IF BUDAGE=""!(BUDQUIT)
QUIT
Begin DoDot:2
+6 SET BUDSEX=""
FOR
SET BUDSEX=$ORDER(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX))
IF BUDSEX=""!(BUDQUIT)
QUIT
Begin DoDot:3
+7 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN))
IF DFN'=+DFN!(BUDQUIT)
QUIT
DO T5W
+8 QUIT
End DoDot:3
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 WRITE !
+12 QUIT
T5W ;
+1 ;NO DUPES
IF '$$DUP(DFN)
IF '$$DUPOE(DFN,"OTH SERV")
IF '$$DUPOE(DFN,"ENA SERV")
QUIT
+2 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)
+3 WRITE ?51,$PIECE(^DPT(DFN,0),U,2),?55,$$AGE^AUPNPAT(DFN,BUDCCAD),?60,$EXTRACT($PIECE($$RACE^BUDDRPTC(DFN),U,3)_"-"_$PIECE($$RACE^BUDDRPTC(DFN),U,4),1,19)
+4 DO MEDSERV
+5 IF BUDQUIT
QUIT
+6 DO DENTSERV
+7 IF BUDQUIT
QUIT
+8 DO MENTSERV
+9 IF BUDQUIT
QUIT
+10 DO SUBSERV
+11 IF BUDQUIT
QUIT
+12 DO OTHSERV
+13 IF BUDQUIT
QUIT
+14 DO ENASERV
+15 IF BUDQUIT
QUIT
+16 QUIT
+17 ;
TW ;
+1 WRITE !?5,$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT(BUDV,0),U),".")),?18,$EXTRACT($$PRIMPROV^APCLV(BUDV,"E"),1,17),?36,$$PRIMPROV^APCLV(BUDV,"T"),?42,$$PRIMPROV^APCLV(BUDV,"D")
+2 WRITE ?48,$$PRIMPOV^APCLV(BUDV,"C"),?56,$PIECE(^AUPNVSIT(BUDV,0),U,7),?59,$EXTRACT($$CLINIC^APCLV(BUDV,"E"),1,9),?70,$EXTRACT($$LOCENC^APCLV(BUDV,"E"),1,9)
+3 QUIT
MEDSERV ;
+1 IF '$$DUP(DFN,"MED SERV")
QUIT
+2 WRITE !!,"Line 15 Total Medical Care"
+3 IF $Y>(IOSL-4)
DO T53H
IF BUDQUIT
QUIT
+4 SET BUDD=0
FOR
SET BUDD=$ORDER(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MED SERV",BUDD))
IF BUDD'=+BUDD!(BUDQUIT)
QUIT
Begin DoDot:1
+5 IF $PIECE(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MED SERV",BUDD),U,2)=""
QUIT
+6 FOR BUDPIEC=1:1
SET BUDV=$PIECE(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MED SERV",BUDD),U,BUDPIEC)
IF BUDV=""!(BUDQUIT)
QUIT
Begin DoDot:2
+7 IF $Y>(IOSL-3)
DO T53H
IF BUDQUIT
QUIT
+8 DO TW
+9 QUIT
End DoDot:2
End DoDot:1
+10 QUIT
DENTSERV ;
+1 IF '$$DUP(DFN,"DENT SERV")
QUIT
+2 WRITE !!,"Line 19 Total Dental Services"
+3 IF $Y>(IOSL-4)
DO T53H
IF BUDQUIT
QUIT
+4 SET BUDD=0
FOR
SET BUDD=$ORDER(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",BUDD))
IF BUDD'=+BUDD!(BUDQUIT)
QUIT
Begin DoDot:1
+5 IF $PIECE(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",BUDD),U,2)=""
QUIT
+6 FOR BUDPIEC=1:1
SET BUDV=$PIECE(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",BUDD),U,BUDPIEC)
IF BUDV=""!(BUDQUIT)
QUIT
Begin DoDot:2
+7 IF $Y>(IOSL-3)
DO T53H
IF BUDQUIT
QUIT
+8 DO TW
+9 QUIT
End DoDot:2
End DoDot:1
+10 QUIT
MENTSERV ;
+1 IF '$$DUP(DFN,"MENT SERV")
QUIT
+2 WRITE !!,"Line 20 Mental Health"
+3 IF $Y>(IOSL-4)
DO T53H
IF BUDQUIT
QUIT
+4 SET BUDD=0
FOR
SET BUDD=$ORDER(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",BUDD))
IF BUDD'=+BUDD!(BUDQUIT)
QUIT
Begin DoDot:1
+5 IF $PIECE(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",BUDD),U,2)=""
QUIT
+6 FOR BUDPIEC=1:1
SET BUDV=$PIECE(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",BUDD),U,BUDPIEC)
IF BUDV=""!(BUDQUIT)
QUIT
Begin DoDot:2
+7 IF $Y>(IOSL-3)
DO T53H
IF BUDQUIT
QUIT
+8 DO TW
+9 QUIT
End DoDot:2
End DoDot:1
+10 QUIT
SUBSERV ;
+1 IF '$$DUP(DFN,"SUB SERV")
QUIT
+2 WRITE !!,"Line 21 Substance Abuse Services"
+3 IF $Y>(IOSL-4)
DO T53H
IF BUDQUIT
QUIT
+4 SET BUDD=0
FOR
SET BUDD=$ORDER(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",BUDD))
IF BUDD'=+BUDD!(BUDQUIT)
QUIT
Begin DoDot:1
+5 IF $PIECE(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",BUDD),U,2)=""
QUIT
+6 FOR BUDPIEC=1:1
SET BUDV=$PIECE(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",BUDD),U,BUDPIEC)
IF BUDV=""!(BUDQUIT)
QUIT
Begin DoDot:2
+7 IF $Y>(IOSL-3)
DO T53H
IF BUDQUIT
QUIT
+8 DO TW
+9 QUIT
End DoDot:2
End DoDot:1
+10 QUIT
OTHSERV ;
+1 IF '$$DUPOE(DFN,"OTH SERV")
QUIT
+2 WRITE !!,"Line 22 Other Professional Services"
+3 IF $Y>(IOSL-4)
DO T53H
IF BUDQUIT
QUIT
+4 SET BUDDIS=""
FOR
SET BUDDIS=$ORDER(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDDIS))
IF BUDDIS=""!(BUDQUIT)
QUIT
DO OTHSERV1
+5 QUIT
OTHSERV1 ;
+1 SET BUDD=0
FOR
SET BUDD=$ORDER(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDDIS,BUDD))
IF BUDD'=+BUDD!(BUDQUIT)
QUIT
Begin DoDot:1
+2 IF $PIECE(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDDIS,BUDD),U,2)=""
QUIT
+3 FOR BUDPIEC=1:1
SET BUDV=$PIECE(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDDIS,BUDD),U,BUDPIEC)
IF BUDV=""!(BUDQUIT)
QUIT
Begin DoDot:2
+4 IF $Y>(IOSL-3)
DO T53H
IF BUDQUIT
QUIT
+5 DO TW
+6 QUIT
End DoDot:2
End DoDot:1
+7 QUIT
ENASERV ;
+1 IF '$$DUPOE(DFN,"ENA SERV")
QUIT
+2 WRITE !!,"Line 29 Total Enabling Services"
+3 IF $Y>(IOSL-4)
DO T53H
IF BUDQUIT
QUIT
+4 SET BUDDIS=""
FOR
SET BUDDIS=$ORDER(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDDIS))
IF BUDDIS=""!(BUDQUIT)
QUIT
DO ENASERV1
+5 QUIT
ENASERV1 ;
+1 SET BUDD=0
FOR
SET BUDD=$ORDER(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDDIS,BUDD))
IF BUDD'=+BUDD!(BUDQUIT)
QUIT
Begin DoDot:1
+2 IF $PIECE(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDDIS,BUDD),U,2)=""
QUIT
+3 FOR BUDPIEC=1:1
SET BUDV=$PIECE(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDDIS,BUDD),U,BUDPIEC)
IF BUDV=""!(BUDQUIT)
QUIT
Begin DoDot:2
+4 IF $Y>(IOSL-3)
DO T53H
IF BUDQUIT
QUIT
+5 DO TW
+6 QUIT
End DoDot:2
End DoDot:1
+7 QUIT
DUP(DFN,T) ;
+1 NEW X,Y,G
+2 SET G=""
+3 SET T=$GET(T)
+4 IF T=""
Begin DoDot:1
+5 FOR X="MED SERV","DENT SERV","MENT SERV","SUB SERV"
Begin DoDot:2
+6 SET Y=0
SET Y=$ORDER(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,X,Y))
IF Y
Begin DoDot:3
+7 IF $PIECE(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,X,Y),U,2)]""
SET G=1
+8 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
QUIT G
+9 SET Y=0
FOR
SET Y=$ORDER(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,T,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+10 IF $PIECE(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,T,Y),U,2)]""
SET G=1
+11 QUIT
End DoDot:1
+12 QUIT G
+13 ;
DUPOE(DFN,T) ;
+1 NEW X,Y,G
+2 SET G=""
+3 SET T=$GET(T)
+4 IF T=""
QUIT ""
+5 SET Y=""
FOR
SET Y=$ORDER(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,T,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+6 SET X=0
FOR
SET X=$ORDER(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,T,Y,X))
IF X'=+X
QUIT
Begin DoDot:2
+7 IF $PIECE(^XTMP("BUDDRPT1",BUDJ,BUDH,"T53",BUDCCOM,BUDAGE,BUDSEX,DFN,T,Y,X),U,2)]""
SET G=1
End DoDot:2
+8 QUIT
End DoDot:1
+9 QUIT G
T53H ;
+1 IF 'BUDGPG
GOTO T5H2
+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
T5H2 ;
+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, Patients w/Multiple Visits on Same",80)
+6 WRITE !,$$CTR("Day in Same Service Categories",80)
+7 WRITE !,$$CTR($PIECE(^DIC(4,BUDSITE,0),U),80)
+8 SET X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED)
WRITE !,$$CTR(X,80)
+9 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+10 IF BUDP=0
WRITE !,"List of all patients with multiple visits on the same day for the same",!,"BPHC service category.",!,"Age is calculated as of June 30.",!
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"
+13 WRITE !
End DoDot:1
+14 WRITE !,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?50,"SEX",?55,"AGE",?60,"RACE*"
+15 WRITE !?5,"VISIT DATE",?18,"PROV TYPE",?36,"INI",?40,"PROV CD",?48,"PRI DX",?55,"SRV",?59,"CLINIC",?70,"LOCATION"
+16 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+17 ; !!,BUDSUBT,!
+18 SET BUDP=1
+19 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 ;----------
T3A ;EP
+1 IF $GET(BUDSTMP)
DO STEMP^BUDDRPTS
+2 SET BUDPG=0
+3 DO HEADER^BUDDRPTP
IF BUDQUIT
QUIT
DO T3ASH
+4 ;print out each line
+5 SET BUDZ=0
FOR
SET BUDZ=$ORDER(^BUDDTTA("AC",BUDZ))
IF BUDZ>38!(BUDQUIT)
QUIT
Begin DoDot:1
+6 SET BUDD=$ORDER(^BUDDTTA("AC",BUDZ,0))
+7 IF $Y>(IOSL-3)
DO HEADER^BUDDRPTP
IF BUDQUIT
QUIT
DO T3ASH
+8 SET BUDY=^BUDDTTA(BUDD,0)
+9 ;column one End control
SET BUDX=$PIECE(BUDY,U,2)
+10 WRITE !
+11 IF BUDX<10
WRITE " "
+12 WRITE $PIECE(BUDY,U,2),?5,$PIECE(BUDY,U,3)
+13 ;I +BUDX=0 Q
+14 WRITE ?35,$$C($PIECE(BUDTOT("M"),U,BUDX)),?50,$$C($PIECE(BUDTOT("F"),U,BUDX)),?68,$$C($PIECE(BUDTOT("ALL"),U,BUDX))
+15 IF BUDX=18
Begin DoDot:2
+16 IF $Y>(IOSL-4)
DO HEADER^BUDDRPTP
IF BUDQUIT
QUIT
DO T3ASH
+17 WRITE !!?10,"SUBTOTAL Ages 0-17",?35,$$C(BUD019("M")),?50,$$C(BUD019("F")),?68,$$C(BUD019("ALL")),!
End DoDot:2
End DoDot:1
+18 SET BUDD=$ORDER(^BUDDTTA("B",43,0))
+19 IF $Y>(IOSL-3)
DO HEADER^BUDDRPTP
IF BUDQUIT
QUIT
DO T3ASH
+20 WRITE !,$PIECE(^BUDDTTA(BUDD,0),U,2),?5,$PIECE(^BUDDTTA(BUDD,0),U,3)
+21 SET BUDD=$ORDER(^BUDDTTA("AC",39,0))
+22 IF $Y>(IOSL-2)
DO HEADER^BUDDRPTP
IF BUDQUIT
QUIT
DO T3ASH
+23 SET BUDY=^BUDDTTA(BUDD,0)
+24 ;column one End control
SET BUDX=$PIECE(BUDY,U,2)
+25 WRITE !
+26 WRITE $PIECE(BUDY,U,2),?5,$PIECE(BUDY,U,3)
+27 WRITE ?35,$$C($PIECE(BUDTOT("M"),U,BUDX)),?50,$$C($PIECE(BUDTOT("F"),U,BUDX)),?68,$$C($PIECE(BUDTOT("ALL"),U,BUDX))
+28 WRITE !
+29 QUIT
T3ASH ;
+1 WRITE !,$$CTR($GET(^BUDDTTA(1,11)),80),!
+2 FOR Y=2:1:4
SET X=$ORDER(^BUDDTTA("B",Y,0))
WRITE !,$PIECE(^BUDDTTA(X,0),U,2),?5,$PIECE(^BUDDTTA(X,0),U,3),?33,$PIECE(^BUDDTTA(X,0),U,4),?50,$PIECE(^BUDDTTA(X,0),U,5),?68,$PIECE(^BUDDTTA(X,0),U,6)
+3 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+4 QUIT
C(X,Y) ;
+1 IF $GET(Y)=1
IF +X=0
QUIT ""
+2 IF $GET(Y)=2
QUIT "********"
+3 SET X2=0
SET X3=8
+4 DO COMMA^%DTC
+5 QUIT X
