BUDERPP1 ;IHS/CMI/LAB - UDS PRINT TAB 1-6A;
;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
T6 ;EP
S BUDPG=0,BUDQUIT="",BUDFNP=1,BUDTYPE="D"
D HEADER^BUDERPTP Q:BUDQUIT D T6SH
K BUDFNP
S BUDORD=0 F S BUDORD=$O(^BUDETSC("B",BUDORD)) Q:BUDORD'=+BUDORD!(BUDORD>30)!(BUDQUIT) D PRN
D HEADER^BUDERPTP Q:BUDQUIT D T6SH1
S BUDORD=30,BUDTYPE="S" F S BUDORD=$O(^BUDETSC("B",BUDORD)) Q:BUDORD'=+BUDORD!(BUDQUIT) D PRN
Q
PRN ;
D
.S BUDY=0 F S BUDY=$O(^BUDETSC("B",BUDORD,BUDY)) Q:BUDY'=+BUDY!(BUDQUIT) D
..;gather all lines into an array
..K BUDARR
..S BUDHD=$P(^BUDETSC(BUDY,0),U,2)
..S (X,C,M)=0 F S X=$O(^BUDETSC(BUDY,2,X)) Q:X'=+X S C=C+1,$P(BUDARR(C),U,2)=$P(^BUDETSC(BUDY,2,X,0),U,1),M=C
..S (X,C)=0 F S X=$O(^BUDETSC(BUDY,3,X)) Q:X'=+X S C=C+1,$P(BUDARR(C),U,3)=$P(^BUDETSC(BUDY,3,X,0),U,1) S:C>M M=C
..S (X,C)=0 F S X=$O(^BUDETSC(BUDY,4,X)) Q:X'=+X S C=C+1,$P(BUDARR(C),U,4)=$P(^BUDETSC(BUDY,4,X,0),U,1) S:C>M M=C
..S M=M\2 S:M=0 M=1
..S $P(BUDARR(1),U,1)=$P(^BUDETSC(BUDY,0),U,3)
..S $P(BUDARR(1),U,5)=$$C($P(BUDT6("V"),U,BUDORD))
..S $P(BUDARR(1),U,6)=$$C($P(BUDT6("P"),U,BUDORD))
..I $Y>(IOSL-6) D HEADER^BUDERPTP Q:BUDQUIT D:BUDTYPE="D" T6SH D:BUDTYPE="S" T6SH1
..I BUDHD W !,$P(BUDARR(1),U,1),!,BUD80L Q
..S BUDL=0 F S BUDL=$O(BUDARR(BUDL)) Q:BUDL'=+BUDL!(BUDQUIT) D
...W !,$P(BUDARR(BUDL),U,1),?5,$P(BUDARR(BUDL),U,2),?28,$P(BUDARR(BUDL),U,4)
...W ?59,$P(BUDARR(BUDL),U,5),?71,$P(BUDARR(BUDL),U,6)
..W !,BUD80L
;
W !
Q
T6SH ;
W !,$$CTR("TABLE 6A-",80),!
W $$CTR("SELECTED DIAGNOSES AND SERVICES RENDERED",80)
W !,$TR($J("",80)," ","-")
W !,?56,"Number of",?70,"Number of"
W !,?28,"Applicable",?56,"Visits by",?70,"Patients"
W !?28,"ICD-10-CM",?56,"Diagnosis",?70,"with"
W !?28,"Code",?56,"regardless",?70,"Diagnosis"
W !?56,"of primacy",?70,"regardless"
W !?70,"of primacy"
I BUDTYPE="D" W !,"Diagnostic Category",?58,"(A)",?74,"(B)"
I BUDTYPE="S" W !,"Service Category",?59,"(A)",?76,"(B)"
W !,$TR($J("",80)," ","-"),!
Q
T6SH1 ;
W !,$$CTR("TABLE 6A-",80),!
W $$CTR("SELECTED DIAGNOSES AND SERVICES RENDERED",80)
W !,$TR($J("",80)," ","-")
W !,?30,"Applicable",?42,"",?58,"Number of",?70,"Number of"
W !?30,"ICD-10-CM Code",?58,"Visits",?70,"patients"
W !?30,"or CPT-4/II",?42,""
W !?30,"Code",?42,""
I BUDTYPE="D" W !,"Diagnostic Category",?60,"(A)",?73,"(B)"
I BUDTYPE="S" W !,"Service Category",?60,"(A)",?75,"(B)"
W !,$TR($J("",80)," ","-"),!
Q
C(X) ;
S X2=0,X3=8
D COMMA^%DTC
Q X
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")
;----------
BUDERPP1 ;IHS/CMI/LAB - UDS PRINT TAB 1-6A;
+1 ;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
T6 ;EP
+1 SET BUDPG=0
SET BUDQUIT=""
SET BUDFNP=1
SET BUDTYPE="D"
+2 DO HEADER^BUDERPTP
IF BUDQUIT
QUIT
DO T6SH
+3 KILL BUDFNP
+4 SET BUDORD=0
FOR
SET BUDORD=$ORDER(^BUDETSC("B",BUDORD))
IF BUDORD'=+BUDORD!(BUDORD>30)!(BUDQUIT)
QUIT
DO PRN
+5 DO HEADER^BUDERPTP
IF BUDQUIT
QUIT
DO T6SH1
+6 SET BUDORD=30
SET BUDTYPE="S"
FOR
SET BUDORD=$ORDER(^BUDETSC("B",BUDORD))
IF BUDORD'=+BUDORD!(BUDQUIT)
QUIT
DO PRN
+7 QUIT
PRN ;
+1 Begin DoDot:1
+2 SET BUDY=0
FOR
SET BUDY=$ORDER(^BUDETSC("B",BUDORD,BUDY))
IF BUDY'=+BUDY!(BUDQUIT)
QUIT
Begin DoDot:2
+3 ;gather all lines into an array
+4 KILL BUDARR
+5 SET BUDHD=$PIECE(^BUDETSC(BUDY,0),U,2)
+6 SET (X,C,M)=0
FOR
SET X=$ORDER(^BUDETSC(BUDY,2,X))
IF X'=+X
QUIT
SET C=C+1
SET $PIECE(BUDARR(C),U,2)=$PIECE(^BUDETSC(BUDY,2,X,0),U,1)
SET M=C
+7 SET (X,C)=0
FOR
SET X=$ORDER(^BUDETSC(BUDY,3,X))
IF X'=+X
QUIT
SET C=C+1
SET $PIECE(BUDARR(C),U,3)=$PIECE(^BUDETSC(BUDY,3,X,0),U,1)
IF C>M
SET M=C
+8 SET (X,C)=0
FOR
SET X=$ORDER(^BUDETSC(BUDY,4,X))
IF X'=+X
QUIT
SET C=C+1
SET $PIECE(BUDARR(C),U,4)=$PIECE(^BUDETSC(BUDY,4,X,0),U,1)
IF C>M
SET M=C
+9 SET M=M\2
IF M=0
SET M=1
+10 SET $PIECE(BUDARR(1),U,1)=$PIECE(^BUDETSC(BUDY,0),U,3)
+11 SET $PIECE(BUDARR(1),U,5)=$$C($PIECE(BUDT6("V"),U,BUDORD))
+12 SET $PIECE(BUDARR(1),U,6)=$$C($PIECE(BUDT6("P"),U,BUDORD))
+13 IF $Y>(IOSL-6)
DO HEADER^BUDERPTP
IF BUDQUIT
QUIT
IF BUDTYPE="D"
DO T6SH
IF BUDTYPE="S"
DO T6SH1
+14 IF BUDHD
WRITE !,$PIECE(BUDARR(1),U,1),!,BUD80L
QUIT
+15 SET BUDL=0
FOR
SET BUDL=$ORDER(BUDARR(BUDL))
IF BUDL'=+BUDL!(BUDQUIT)
QUIT
Begin DoDot:3
+16 WRITE !,$PIECE(BUDARR(BUDL),U,1),?5,$PIECE(BUDARR(BUDL),U,2),?28,$PIECE(BUDARR(BUDL),U,4)
+17 WRITE ?59,$PIECE(BUDARR(BUDL),U,5),?71,$PIECE(BUDARR(BUDL),U,6)
End DoDot:3
+18 WRITE !,BUD80L
End DoDot:2
End DoDot:1
+19 ;
+20 WRITE !
+21 QUIT
T6SH ;
+1 WRITE !,$$CTR("TABLE 6A-",80),!
+2 WRITE $$CTR("SELECTED DIAGNOSES AND SERVICES RENDERED",80)
+3 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+4 WRITE !,?56,"Number of",?70,"Number of"
+5 WRITE !,?28,"Applicable",?56,"Visits by",?70,"Patients"
+6 WRITE !?28,"ICD-10-CM",?56,"Diagnosis",?70,"with"
+7 WRITE !?28,"Code",?56,"regardless",?70,"Diagnosis"
+8 WRITE !?56,"of primacy",?70,"regardless"
+9 WRITE !?70,"of primacy"
+10 IF BUDTYPE="D"
WRITE !,"Diagnostic Category",?58,"(A)",?74,"(B)"
+11 IF BUDTYPE="S"
WRITE !,"Service Category",?59,"(A)",?76,"(B)"
+12 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-"),!
+13 QUIT
T6SH1 ;
+1 WRITE !,$$CTR("TABLE 6A-",80),!
+2 WRITE $$CTR("SELECTED DIAGNOSES AND SERVICES RENDERED",80)
+3 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+4 WRITE !,?30,"Applicable",?42,"",?58,"Number of",?70,"Number of"
+5 WRITE !?30,"ICD-10-CM Code",?58,"Visits",?70,"patients"
+6 WRITE !?30,"or CPT-4/II",?42,""
+7 WRITE !?30,"Code",?42,""
+8 IF BUDTYPE="D"
WRITE !,"Diagnostic Category",?60,"(A)",?73,"(B)"
+9 IF BUDTYPE="S"
WRITE !,"Service Category",?60,"(A)",?75,"(B)"
+10 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-"),!
+11 QUIT
C(X) ;
+1 SET X2=0
SET X3=8
+2 DO COMMA^%DTC
+3 QUIT X
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 ;----------
