lib/maracasVisuLib/src/interface/tcl/windows/data_browser.tcl

   1 package require BLT
   2 package require mclistbox
   3 catch { namespace import blt::* }
   4 catch { namespace import mclistbox::* }
   5
   6 namespace eval data_browser {
   7
   8     # public interface
   9     namespace export \
  10         sel_study    \
  11         sel_serie    \
  12         create       \
  13         positionate  \
  14         set_studies  \
  15         forget
  16
  17     # variables
  18     variable widgets
  19
  20     variable sel_study ""
  21     variable sel_serie ""
  22     variable local_id
  23
  24 }
  25
  26 proc data_browser::reset { parent } {
  27
  28     # For programming facilities
  29     upvar data_browser::widgets widgets
  30
  31     set widgets(base)      "$parent"
  32     set widgets(data_brw)  "$parent\.data_browser"
  33     set widgets(up_brw)    "$parent\.data_browser.01"
  34     set widgets(down_brw)  "$parent\.data_browser.02"
  35     set widgets(split)     "$parent\.data_browser.03"
  36     set widgets(up_view)   "$parent\.data_browser.01.lst"
  37     set widgets(down_view) "$parent\.data_browser.02.lst"
  38     set widgets(up_hs)     "$parent\.data_browser.01.hs"
  39     set widgets(up_vs)     "$parent\.data_browser.01.vs"
  40     set widgets(down_hs)   "$parent\.data_browser.02.hs"
  41     set widgets(down_vs)   "$parent\.data_browser.02.vs"
  42
  43 }
  44
  45 proc data_browser::create { parent id } {
  46
  47     # For programming facilities
  48     upvar data_browser::widgets widgets
  49     upvar data_browser::sel_study sel_study
  50     upvar data_browser::sel_serie sel_serie
  51     upvar data_browser::local_id  local_id
  52
  53     set local_id $id
  54     data_browser::reset $parent
  55
  56     # frames
  57     frame $widgets(data_brw) -borderwidth 1 -height 100 -relief groove -width 200
  58     frame $widgets(up_brw)   -borderwidth 1 -height 100 -relief groove -width 200
  59     frame $widgets(down_brw) -borderwidth 1 -height 100 -relief groove -width 200
  60     frame $widgets(split)    -borderwidth 2 -relief raised
  61
  62     # multi-column listboxes
  63     mclistbox $widgets(up_view)                       \
  64         -borderwidth        1                         \
  65         -highlightthickness 0                         \
  66         -relief             groove                    \
  67         -selectborderwidth  0                         \
  68         -columnrelief       flat                      \
  69         -labelanchor        w                         \
  70         -columnborderwidth  0                         \
  71         -selectmode         single                    \
  72         -labelborderwidth   2                         \
  73         -labelrelief        raised                    \
  74         -selectcommand      "data_browser::cb_select"
  75     scrollbar $widgets(up_vs) -command "$widgets(up_view) yview"
  76     scrollbar $widgets(up_hs) -command "$widgets(up_view) xview" -orient horizontal
  77     $widgets(up_view) configure -xscrollcommand "$widgets(up_hs) set"
  78     $widgets(up_view) configure -yscrollcommand "$widgets(up_vs) set"
  79
  80     mclistbox $widgets(down_view)                           \
  81         -borderwidth        1                               \
  82         -highlightthickness 0                               \
  83         -relief             groove                          \
  84         -selectborderwidth  0                               \
  85         -columnrelief       flat                            \
  86         -labelanchor        w                               \
  87         -columnborderwidth  0                               \
  88         -selectmode         extended                        \
  89         -labelborderwidth   2                               \
  90         -labelrelief        raised                          \
  91         -selectcommand      "data_browser::cb_select_serie"
  92     scrollbar $widgets(down_vs) -command "$widgets(down_view) yview"
  93     scrollbar $widgets(down_hs) -command "$widgets(down_view) xview" -orient horizontal
  94     $widgets(down_view) configure -xscrollcommand "$widgets(down_hs) set"
  95     $widgets(down_view) configure -yscrollcommand "$widgets(down_vs) set"
  96
  97     bind $widgets(down_view) <Double-Button-1> "global_window::cb_image_browse"
  98
  99     # split binds
 100     bind $widgets(split) <B1-Motion> {
 101         set root [ split %W . ]
 102         set nb [ llength $root ]
 103         incr nb -1
 104         set root [ lreplace $root $nb $nb ]
 105         set root [ join $root . ]
 106         set height [ winfo height $root ].0
 107         set val [ expr (%Y - [winfo rooty $root]) /$height ]
 108         if { $val >= 0 && $val <= 1.0 } {
 109             place $root.01 -relheight $val
 110             place $root.03 -rely $val
 111             place $root.02 -relheight [ expr 1.0 - $val ]
 112         }
 113     }
 114
 115 }
 116
 117 proc data_browser::positionate { } {
 118
 119     # For programming facilities
 120     upvar data_browser::widgets  widgets
 121     upvar data_browser::local_id local_id
 122
 123     set global_window::window_shown $local_id
 124
 125     pack  $widgets(data_brw)  -anchor center -expand 1 -fill both -side top
 126     place $widgets(up_brw)    -x 0 -y 0 -relwidth 1 -height -1 -relheight 0.5 -anchor nw -bordermode ignore
 127     place $widgets(down_brw)  -x 0 -y 0 -rely 1 -relwidth 1 -height -1 -relheight 0.5 -anchor sw -bordermode ignore
 128     pack  $widgets(up_view)   -anchor center -expand 1 -fill both -side top
 129     pack  $widgets(down_view) -anchor center -expand 1 -fill both -side top
 130     place $widgets(split)     -x 0 -relx 0.9 -y 0 -rely 0.5 -width 10 -height 10 -anchor e -bordermode ignore
 131
 132     grid  $widgets(up_view)   -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news
 133     grid  $widgets(up_vs)     -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news
 134     grid  $widgets(up_hs)     -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news
 135
 136     grid  rowconfig    $widgets(up_brw) 0 -weight 1 -minsize 0
 137     grid  columnconfig $widgets(up_brw) 0 -weight 1 -minsize 0
 138
 139     grid  $widgets(down_view) -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news
 140     grid  $widgets(down_vs)   -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news
 141     grid  $widgets(down_hs)   -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news
 142
 143     grid  rowconfig    $widgets(down_brw) 0 -weight 1 -minsize 0
 144     grid  columnconfig $widgets(down_brw) 0 -weight 1 -minsize 0
 145
 146     data_browser::controls 0
 147
 148 }
 149
 150 proc data_browser::forget { } {
 151
 152     # For programming facilities
 153     upvar data_browser::widgets  widgets
 154
 155     grid  forget $widgets(down_hs)
 156     grid  forget $widgets(down_vs)
 157     grid  forget $widgets(down_view)
 158     grid  forget $widgets(up_hs)
 159     grid  forget $widgets(up_vs)
 160     grid  forget $widgets(up_view)
 161     place forget $widgets(split)
 162     pack  forget $widgets(down_view)
 163     pack  forget $widgets(up_view)
 164     place forget $widgets(down_brw)
 165     place forget $widgets(up_brw)
 166     pack  forget $widgets(data_brw)
 167
 168 }
 169
 170 proc data_browser::clean_list { } {
 171
 172     # For programming facilities
 173     upvar data_browser::widgets   widgets
 174     upvar data_browser::sel_study sel_study
 175     upvar data_browser::sel_serie sel_serie
 176
 177     catch { $widgets(up_view) column delete c08 }
 178     catch { $widgets(up_view) column delete c07 }
 179     catch { $widgets(up_view) column delete c06 }
 180     catch { $widgets(up_view) column delete c05 }
 181     catch { $widgets(up_view) column delete c04 }
 182     catch { $widgets(up_view) column delete c03 }
 183     catch { $widgets(up_view) column delete c02 }
 184     catch { $widgets(up_view) column delete c01 }
 185     catch { $widgets(up_view) column delete c00 }
 186
 187     catch { $widgets(down_view) column delete c08 }
 188     catch { $widgets(down_view) column delete c07 }
 189     catch { $widgets(down_view) column delete c06 }
 190     catch { $widgets(down_view) column delete c05 }
 191     catch { $widgets(down_view) column delete c04 }
 192     catch { $widgets(down_view) column delete c03 }
 193     catch { $widgets(down_view) column delete c02 }
 194     catch { $widgets(down_view) column delete c01 }
 195     catch { $widgets(down_view) column delete c00 }
 196
 197 }
 198
 199 proc data_browser::set_data { } {
 200
 201     # For programming facilities
 202     upvar data_browser::widgets   widgets
 203     upvar data_browser::sel_study sel_study
 204     upvar data_browser::sel_serie sel_serie
 205     upvar data_browser::local_id  local_id
 206
 207     data_browser::clean_list
 208     $widgets(down_view) column add c00 -label "$string_table::str_serie_name"        -width 20
 209     $widgets(down_view) column add c01 -label "$string_table::str_serie_number"      -width 10
 210     $widgets(down_view) column add c02 -label "$string_table::str_serie_date"        -width 15
 211     $widgets(down_view) column add c03 -label "$string_table::str_serie_time"        -width 10
 212     $widgets(down_view) column add c04 -label "$string_table::str_serie_modality"    -width 10
 213     $widgets(down_view) column add c05 -label "$string_table::str_serie_bodypart"    -width 10
 214     $widgets(down_view) column add c06 -label "$string_table::str_serie_description" -width 100
 215     $widgets(down_view) column add c07 -label "$string_table::str_serie_diagnostic"  -width 100
 216     $widgets(up_view)   column add c00 -label "$string_table::str_patient_name"      -width 20
 217     $widgets(up_view)   column add c01 -label "$string_table::str_patient_id"        -width 10
 218     $widgets(up_view)   column add c02 -label "$string_table::str_study_name"        -width 15
 219     $widgets(up_view)   column add c03 -label "$string_table::str_study_id"          -width 10
 220     $widgets(up_view)   column add c04 -label "$string_table::str_study_date"        -width 10
 221     $widgets(up_view)   column add c05 -label "$string_table::str_study_time"        -width 10
 222     $widgets(up_view)   column add c06 -label "$string_table::str_institution"       -width 20
 223     $widgets(up_view)   column add c07 -label "$string_table::str_description"       -width 200
 224
 225     $widgets(up_view) label bind c00 <ButtonPress-1> "data_browser::sort_mclst $widgets(up_view) c00"
 226     $widgets(up_view) label bind c01 <ButtonPress-1> "data_browser::sort_mclst $widgets(up_view) c01"
 227     $widgets(up_view) label bind c02 <ButtonPress-1> "data_browser::sort_mclst $widgets(up_view) c02"
 228     $widgets(up_view) label bind c03 <ButtonPress-1> "data_browser::sort_mclst $widgets(up_view) c03"
 229     $widgets(up_view) label bind c04 <ButtonPress-1> "data_browser::sort_mclst $widgets(up_view) c04"
 230     $widgets(up_view) label bind c05 <ButtonPress-1> "data_browser::sort_mclst $widgets(up_view) c05"
 231     $widgets(up_view) label bind c06 <ButtonPress-1> "data_browser::sort_mclst $widgets(up_view) c06"
 232     $widgets(up_view) label bind c07 <ButtonPress-1> "data_browser::sort_mclst $widgets(up_view) c07"
 233
 234     $widgets(down_view) label bind c00 <ButtonPress-1> "data_browser::sort_mclst $widgets(down_view) c00"
 235     $widgets(down_view) label bind c01 <ButtonPress-1> "data_browser::sort_mclst $widgets(down_view) c01"
 236     $widgets(down_view) label bind c02 <ButtonPress-1> "data_browser::sort_mclst $widgets(down_view) c02"
 237     $widgets(down_view) label bind c03 <ButtonPress-1> "data_browser::sort_mclst $widgets(down_view) c03"
 238     $widgets(down_view) label bind c04 <ButtonPress-1> "data_browser::sort_mclst $widgets(down_view) c04"
 239     $widgets(down_view) label bind c05 <ButtonPress-1> "data_browser::sort_mclst $widgets(down_view) c05"
 240     $widgets(down_view) label bind c06 <ButtonPress-1> "data_browser::sort_mclst $widgets(down_view) c06"
 241     $widgets(down_view) label bind c07 <ButtonPress-1> "data_browser::sort_mclst $widgets(down_view) c07"
 242
 243     $widgets(up_view) delete 0 end
 244     set studies [ studies_dll ]
 245     foreach study $studies {
 246
 247         array set arr [ studyData_dll $study ]
 248         $widgets(up_view) insert end [ list  \
 249             $arr(ID_Patient_Name)            \
 250             $arr(ID_Patient_ID)              \
 251             $arr(ID_File_Name)               \
 252             $arr(ID_Study_ID)                \
 253             $arr(ID_Study_Date)              \
 254             $arr(ID_Study_Time)              \
 255             $arr(ID_Institution_Name)        \
 256             $arr(ID_Study_Description)       \
 257         ]
 258
 259     }
 260
 261     data_browser::sort_mclst $widgets(up_view) c00
 262     data_browser::controls 0
 263
 264 }
 265
 266 proc data_browser::cb_select { args } {
 267
 268     # For programming facilities
 269     upvar data_browser::widgets   widgets
 270     upvar data_browser::sel_study sel_study
 271     upvar data_browser::sel_serie sel_serie
 272
 273     if { [ string compare $args "" ] != 0 } {
 274
 275         set sel [ $widgets(up_view) get [ $widgets(up_view) curselection ] ]
 276         set sel_study [ lindex $sel 2 ]
 277         set series [ series_dll $sel_study ]
 278         $widgets(down_view) delete 0 end
 279         foreach serie $series {
 280
 281             array set arr [ serieData_dll $sel_study $serie ]
 282             $widgets(down_view) insert end [ list        \
 283                 $arr(ID_File_Name)                       \
 284                 $arr(ID_Series_Number)                   \
 285                 $arr(ID_Series_Date)                     \
 286                 $arr(ID_Series_Time)                     \
 287                 $arr(ID_Modality)                        \
 288                 $arr(ID_Body_Part_Examined)              \
 289                 $arr(ID_Series_Description)              \
 290                 $arr(ID_Admitting_Diagnoses_Description) \
 291             ]
 292
 293         }
 294
 295         data_browser::controls 0
 296
 297     }
 298
 299
 300 }
 301
 302 proc data_browser::sort_mclst { lst id } {
 303
 304     # For programming facilities
 305     upvar data_browser::widgets   widgets
 306     upvar data_browser::sel_study sel_study
 307     upvar data_browser::sel_serie sel_serie
 308
 309     set data   [ $lst get 0 end ]
 310     set index  [ lsearch -exact [ $lst column names ] $id ]
 311     set result [ lsort -index $index $data ]
 312     $lst delete 0 end
 313     eval $lst insert end $result
 314
 315 }
 316
 317
 318 proc data_browser::cb_select_serie { args } {
 319
 320     # For programming facilities
 321     upvar data_browser::widgets   widgets
 322     upvar data_browser::sel_study sel_study
 323     upvar data_browser::sel_serie sel_serie
 324
 325     if { [ string compare $args "" ] != 0 } {
 326
 327         set sel [ $widgets(down_view) curselection ]
 328         if { [ llength $sel ] == 1 } {
 329
 330             set sel_serie [ lindex [ $widgets(down_view) get $sel ] 0 ]
 331             set data [ serieData_dll $sel_study $sel_serie ]
 332             data_browser::controls 1
 333
 334         } elseif { [ llength $sel ] == 2 } {
 335
 336             data_browser::controls 2
 337
 338         } else {
 339
 340             data_browser::controls 0
 341
 342         }
 343
 344     }
 345
 346 }
 347
 348 proc data_browser::get_subdata { } {
 349
 350     # For programming facilities
 351     upvar data_browser::widgets   widgets
 352     upvar data_browser::sel_study sel_study
 353     upvar data_browser::sel_serie sel_serie
 354
 355     set sel [ $widgets(down_view) curselection ]
 356     set sel_data [ $widgets(down_view) get $sel ]
 357     if { [ llength $sel ] == 2 } {
 358
 359         return [ list [ lindex [ lindex $sel_data 0 ] 0 ] [ lindex [ lindex $sel_data 1 ] 0 ] ]
 360
 361     }
 362     return ""
 363
 364
 365 }
 366
 367 proc data_browser::controls { { id -1 } } {
 368
 369     if { $id == -1 } {
 370
 371         global_window::active_controls 0
 372
 373     } else {
 374
 375         if { $id == 0 } {
 376
 377             global_window::active_controls [   \
 378                 expr                           \
 379                 $global_window::en_params    | \
 380                 $global_window::en_load      | \
 381                 $global_window::en_open      | \
 382                 $global_window::en_help      | \
 383                 0
 384             ]
 385
 386         } elseif { $id == 1 } {
 387
 388             global_window::active_controls [   \
 389                 expr                           \
 390                 $global_window::en_ibrw      | \
 391                 $global_window::en_params    | \
 392                 $global_window::en_load      | \
 393                 $global_window::en_open      | \
 394                 $global_window::en_help      | \
 395                 0
 396             ]
 397
 398         } elseif { $id == 2 } {
 399
 400             global_window::active_controls [   \
 401                 expr                           \
 402                 $global_window::en_subtract  | \
 403                 $global_window::en_params    | \
 404                 $global_window::en_load      | \
 405                 $global_window::en_open      | \
 406                 $global_window::en_help      | \
 407                 0
 408             ]
 409
 410         }
 411
 412     }
 413
 414 }
 415
 416 # EOF - data_browser.tcl