- BUDDRPP1 ; IHS/CMI/LAB - UDS PRINT TABLE 6 05 Dec 2007 6:26 AM 30 Dec 2016 10:42 AM 17 Nov 2016 7:11 AM ;
- ;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
- T6 ;EP
- S BUDPG=0,BUDQUIT="",BUDFNP=1,BUDTYPE="D"
- D HEADER^BUDDRPTP Q:BUDQUIT D T6SH
- K BUDFNP
- S BUDORD=0 F S BUDORD=$O(^BUDDTSC("B",BUDORD)) Q:BUDORD'=+BUDORD!(BUDORD>30)!(BUDQUIT) D PRN
- D HEADER^BUDDRPTP Q:BUDQUIT D T6SH1
- S BUDORD=30,BUDTYPE="S" F S BUDORD=$O(^BUDDTSC("B",BUDORD)) Q:BUDORD'=+BUDORD!(BUDQUIT) D PRN
- Q
- PRN ;
- D
- .S BUDY=0 F S BUDY=$O(^BUDDTSC("B",BUDORD,BUDY)) Q:BUDY'=+BUDY!(BUDQUIT) D
- ..;gather all lines into an array
- ..K BUDARR
- ..S BUDHD=$P(^BUDDTSC(BUDY,0),U,2)
- ..S (X,C,M)=0 F S X=$O(^BUDDTSC(BUDY,2,X)) Q:X'=+X S C=C+1,$P(BUDARR(C),U,2)=$P(^BUDDTSC(BUDY,2,X,0),U,1),M=C
- ..S (X,C)=0 F S X=$O(^BUDDTSC(BUDY,3,X)) Q:X'=+X S C=C+1,$P(BUDARR(C),U,3)=$P(^BUDDTSC(BUDY,3,X,0),U,1) S:C>M M=C
- ..S (X,C)=0 F S X=$O(^BUDDTSC(BUDY,4,X)) Q:X'=+X S C=C+1,$P(BUDARR(C),U,4)=$P(^BUDDTSC(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(^BUDDTSC(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^BUDDRPTP 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,"Applicable",?58,"Number of",?70,"Number of"
- W !?30,"ICD-10-CM Code",?58,"Visits",?70,"patients"
- W !?30,"CPT-4/II",?42,"Code or CPT-4/"
- W !?30,"Code",?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")
- ;----------
- BUDDRPP1 ; IHS/CMI/LAB - UDS PRINT TABLE 6 05 Dec 2007 6:26 AM 30 Dec 2016 10:42 AM 17 Nov 2016 7:11 AM ;
- +1 ;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
- T6 ;EP
- +1 SET BUDPG=0
- SET BUDQUIT=""
- SET BUDFNP=1
- SET BUDTYPE="D"
- +2 DO HEADER^BUDDRPTP
- IF BUDQUIT
- QUIT
- DO T6SH
- +3 KILL BUDFNP
- +4 SET BUDORD=0
- FOR
- SET BUDORD=$ORDER(^BUDDTSC("B",BUDORD))
- IF BUDORD'=+BUDORD!(BUDORD>30)!(BUDQUIT)
- QUIT
- DO PRN
- +5 DO HEADER^BUDDRPTP
- IF BUDQUIT
- QUIT
- DO T6SH1
- +6 SET BUDORD=30
- SET BUDTYPE="S"
- FOR
- SET BUDORD=$ORDER(^BUDDTSC("B",BUDORD))
- IF BUDORD'=+BUDORD!(BUDQUIT)
- QUIT
- DO PRN
- +7 QUIT
- PRN ;
- +1 Begin DoDot:1
- +2 SET BUDY=0
- FOR
- SET BUDY=$ORDER(^BUDDTSC("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(^BUDDTSC(BUDY,0),U,2)
- +6 SET (X,C,M)=0
- FOR
- SET X=$ORDER(^BUDDTSC(BUDY,2,X))
- IF X'=+X
- QUIT
- SET C=C+1
- SET $PIECE(BUDARR(C),U,2)=$PIECE(^BUDDTSC(BUDY,2,X,0),U,1)
- SET M=C
- +7 SET (X,C)=0
- FOR
- SET X=$ORDER(^BUDDTSC(BUDY,3,X))
- IF X'=+X
- QUIT
- SET C=C+1
- SET $PIECE(BUDARR(C),U,3)=$PIECE(^BUDDTSC(BUDY,3,X,0),U,1)
- IF C>M
- SET M=C
- +8 SET (X,C)=0
- FOR
- SET X=$ORDER(^BUDDTSC(BUDY,4,X))
- IF X'=+X
- QUIT
- SET C=C+1
- SET $PIECE(BUDARR(C),U,4)=$PIECE(^BUDDTSC(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(^BUDDTSC(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^BUDDRPTP
- 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,"Applicable",?58,"Number of",?70,"Number of"
- +5 WRITE !?30,"ICD-10-CM Code",?58,"Visits",?70,"patients"
- +6 WRITE !?30,"CPT-4/II",?42,"Code or CPT-4/"
- +7 WRITE !?30,"Code",?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 ;----------