Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BUDDRPP1

BUDDRPP1.m

Go to the documentation of this file.
  1. 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
  1. T6 ;EP
  1. S BUDPG=0,BUDQUIT="",BUDFNP=1,BUDTYPE="D"
  1. D HEADER^BUDDRPTP Q:BUDQUIT D T6SH
  1. K BUDFNP
  1. S BUDORD=0 F S BUDORD=$O(^BUDDTSC("B",BUDORD)) Q:BUDORD'=+BUDORD!(BUDORD>30)!(BUDQUIT) D PRN
  1. D HEADER^BUDDRPTP Q:BUDQUIT D T6SH1
  1. S BUDORD=30,BUDTYPE="S" F S BUDORD=$O(^BUDDTSC("B",BUDORD)) Q:BUDORD'=+BUDORD!(BUDQUIT) D PRN
  1. Q
  1. PRN ;
  1. D
  1. .S BUDY=0 F S BUDY=$O(^BUDDTSC("B",BUDORD,BUDY)) Q:BUDY'=+BUDY!(BUDQUIT) D
  1. ..;gather all lines into an array
  1. ..K BUDARR
  1. ..S BUDHD=$P(^BUDDTSC(BUDY,0),U,2)
  1. ..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
  1. ..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
  1. ..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
  1. ..S M=M\2 S:M=0 M=1
  1. ..S $P(BUDARR(1),U,1)=$P(^BUDDTSC(BUDY,0),U,3)
  1. ..S $P(BUDARR(1),U,5)=$$C($P(BUDT6("V"),U,BUDORD))
  1. ..S $P(BUDARR(1),U,6)=$$C($P(BUDT6("P"),U,BUDORD))
  1. ..I $Y>(IOSL-6) D HEADER^BUDDRPTP Q:BUDQUIT D:BUDTYPE="D" T6SH D:BUDTYPE="S" T6SH1
  1. ..I BUDHD W !,$P(BUDARR(1),U,1),!,BUD80L Q
  1. ..S BUDL=0 F S BUDL=$O(BUDARR(BUDL)) Q:BUDL'=+BUDL!(BUDQUIT) D
  1. ...W !,$P(BUDARR(BUDL),U,1),?5,$P(BUDARR(BUDL),U,2),?28,$P(BUDARR(BUDL),U,4)
  1. ...W ?59,$P(BUDARR(BUDL),U,5),?71,$P(BUDARR(BUDL),U,6)
  1. ..W !,BUD80L
  1. ;
  1. W !
  1. Q
  1. T6SH ;
  1. W !,$$CTR("TABLE 6A-",80),!
  1. W $$CTR("SELECTED DIAGNOSES AND SERVICES RENDERED",80)
  1. W !,$TR($J("",80)," ","-")
  1. W !,?56,"Number of",?70,"Number of"
  1. W !,?28,"Applicable",?56,"Visits by",?70,"Patients"
  1. W !?28,"ICD-10-CM",?56,"Diagnosis",?70,"with"
  1. W !?28,"Code",?56,"regardless",?70,"Diagnosis"
  1. W !?56,"of primacy",?70,"regardless"
  1. W !?70,"of primacy"
  1. I BUDTYPE="D" W !,"Diagnostic Category",?58,"(A)",?74,"(B)"
  1. I BUDTYPE="S" W !,"Service Category",?59,"(A)",?76,"(B)"
  1. W !,$TR($J("",80)," ","-"),!
  1. Q
  1. T6SH1 ;
  1. W !,$$CTR("TABLE 6A-",80),!
  1. W $$CTR("SELECTED DIAGNOSES AND SERVICES RENDERED",80)
  1. W !,$TR($J("",80)," ","-")
  1. W !,?30,"Applicable",?42,"Applicable",?58,"Number of",?70,"Number of"
  1. W !?30,"ICD-10-CM Code",?58,"Visits",?70,"patients"
  1. W !?30,"CPT-4/II",?42,"Code or CPT-4/"
  1. W !?30,"Code",?42,"II Code"
  1. I BUDTYPE="D" W !,"Diagnostic Category",?60,"(A)",?73,"(B)"
  1. I BUDTYPE="S" W !,"Service Category",?60,"(A)",?75,"(B)"
  1. W !,$TR($J("",80)," ","-"),!
  1. Q
  1. C(X) ;
  1. S X2=0,X3=8
  1. D COMMA^%DTC
  1. Q X
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1. Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1. ;----------
  1. USR() ;EP - Return name of current user from ^VA(200.
  1. Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
  1. ;----------
  1. LOC() ;EP - Return location name from file 4 based on DUZ(2).
  1. Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
  1. ;----------