BUDCRPP1 ; IHS/CMI/LAB - UDS PRINT TABLE 6 05 Dec 2007 6:26 AM 30 Dec 2015 10:42 AM ; 17 Nov 2015 7:11 AM
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
T6 ;EP
S BUDPG=0,BUDQUIT="",BUDFNP=1,BUDTYPE="D"
D HEADER^BUDCRPTP Q:BUDQUIT D T6SH
K BUDFNP
S BUDORD=0 F S BUDORD=$O(^BUDCTSC("B",BUDORD)) Q:BUDORD'=+BUDORD!(BUDORD>30)!(BUDQUIT) D PRN
D HEADER^BUDCRPTP Q:BUDQUIT D T6SH1
S BUDORD=30,BUDTYPE="S" F S BUDORD=$O(^BUDCTSC("B",BUDORD)) Q:BUDORD'=+BUDORD!(BUDQUIT) D PRN
Q
PRN ;
D
.S BUDY=0 F S BUDY=$O(^BUDCTSC("B",BUDORD,BUDY)) Q:BUDY'=+BUDY!(BUDQUIT) D
..;gather all lines into an array
..K BUDARR
..S BUDHD=$P(^BUDCTSC(BUDY,0),U,2)
..S (X,C,M)=0 F S X=$O(^BUDCTSC(BUDY,2,X)) Q:X'=+X S C=C+1,$P(BUDARR(C),U,2)=$P(^BUDCTSC(BUDY,2,X,0),U,1),M=C
..S (X,C)=0 F S X=$O(^BUDCTSC(BUDY,3,X)) Q:X'=+X S C=C+1,$P(BUDARR(C),U,3)=$P(^BUDCTSC(BUDY,3,X,0),U,1) S:C>M M=C
..S (X,C)=0 F S X=$O(^BUDCTSC(BUDY,4,X)) Q:X'=+X S C=C+1,$P(BUDARR(C),U,4)=$P(^BUDCTSC(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(^BUDCTSC(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^BUDCRPTP 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),?25,$P(BUDARR(BUDL),U,3),?42,$P(BUDARR(BUDL),U,4)
...W ?61,$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 !,?25,"Applicable",?42,"Applicable",?58,"Number of",?70,"Number of"
W !?25,"ICD-9-CM",?42,"ICD-10-CM",?58,"Visits by",?70,"Patients"
W !?25,"Code",?42,"Code",?58,"Diagnosis",?70,"with"
W !?58,"regardless",?70,"Diagnosis"
W !?58,"of primacy",?70,"regardless"
W !?70,"of primacy"
I BUDTYPE="D" W !,"Diagnostic Category",?60,"(A)",?74,"(B)"
I BUDTYPE="S" W !,"Service Category",?60,"(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 !,?25,"Applicable",?42,"Applicable",?58,"Number of",?70,"Number of"
W !?25,"ICD-9-CM or",?42,"ICD-10-CM",?58,"Visits",?70,"patients"
W !?25,"CPT-4/II",?42,"Code or CPT-4/"
W !?25,"code(s)",?42,"II Code"
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")
;----------
BUDCRPP1 ; IHS/CMI/LAB - UDS PRINT TABLE 6 05 Dec 2007 6:26 AM 30 Dec 2015 10:42 AM ; 17 Nov 2015 7:11 AM
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
T6 ;EP
+1 SET BUDPG=0
SET BUDQUIT=""
SET BUDFNP=1
SET BUDTYPE="D"
+2 DO HEADER^BUDCRPTP
IF BUDQUIT
QUIT
DO T6SH
+3 KILL BUDFNP
+4 SET BUDORD=0
FOR
SET BUDORD=$ORDER(^BUDCTSC("B",BUDORD))
IF BUDORD'=+BUDORD!(BUDORD>30)!(BUDQUIT)
QUIT
DO PRN
+5 DO HEADER^BUDCRPTP
IF BUDQUIT
QUIT
DO T6SH1
+6 SET BUDORD=30
SET BUDTYPE="S"
FOR
SET BUDORD=$ORDER(^BUDCTSC("B",BUDORD))
IF BUDORD'=+BUDORD!(BUDQUIT)
QUIT
DO PRN
+7 QUIT
PRN ;
+1 Begin DoDot:1
+2 SET BUDY=0
FOR
SET BUDY=$ORDER(^BUDCTSC("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(^BUDCTSC(BUDY,0),U,2)
+6 SET (X,C,M)=0
FOR
SET X=$ORDER(^BUDCTSC(BUDY,2,X))
IF X'=+X
QUIT
SET C=C+1
SET $PIECE(BUDARR(C),U,2)=$PIECE(^BUDCTSC(BUDY,2,X,0),U,1)
SET M=C
+7 SET (X,C)=0
FOR
SET X=$ORDER(^BUDCTSC(BUDY,3,X))
IF X'=+X
QUIT
SET C=C+1
SET $PIECE(BUDARR(C),U,3)=$PIECE(^BUDCTSC(BUDY,3,X,0),U,1)
IF C>M
SET M=C
+8 SET (X,C)=0
FOR
SET X=$ORDER(^BUDCTSC(BUDY,4,X))
IF X'=+X
QUIT
SET C=C+1
SET $PIECE(BUDARR(C),U,4)=$PIECE(^BUDCTSC(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(^BUDCTSC(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^BUDCRPTP
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),?25,$PIECE(BUDARR(BUDL),U,3),?42,$PIECE(BUDARR(BUDL),U,4)
+17 WRITE ?61,$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 !,?25,"Applicable",?42,"Applicable",?58,"Number of",?70,"Number of"
+5 WRITE !?25,"ICD-9-CM",?42,"ICD-10-CM",?58,"Visits by",?70,"Patients"
+6 WRITE !?25,"Code",?42,"Code",?58,"Diagnosis",?70,"with"
+7 WRITE !?58,"regardless",?70,"Diagnosis"
+8 WRITE !?58,"of primacy",?70,"regardless"
+9 WRITE !?70,"of primacy"
+10 IF BUDTYPE="D"
WRITE !,"Diagnostic Category",?60,"(A)",?74,"(B)"
+11 IF BUDTYPE="S"
WRITE !,"Service Category",?60,"(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 !,?25,"Applicable",?42,"Applicable",?58,"Number of",?70,"Number of"
+5 WRITE !?25,"ICD-9-CM or",?42,"ICD-10-CM",?58,"Visits",?70,"patients"
+6 WRITE !?25,"CPT-4/II",?42,"Code or CPT-4/"
+7 WRITE !?25,"code(s)",?42,"II Code"
+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 ;----------
