

PROCEDURE qcm$generate_levels, generate_levels, genls  (
  qcu_ident, qi: data_name = $required
  status)


  VAR
    wev$working_catalog :(XREF) string
    wev$build_level :(XREF) string
    wev$development_base :(XREF) string
    product_table :(XDCL) string
    base_table: (XDCL) string
    pacs_catalog :(XDCL) string
    licensed_products : string = 'all'
    include_subproducts : name
    exclude_subproducts : name
    use_alternate_intve_paths : boolean = FALSE
    alternate_intve_paths_file : string= $unique
    catalog_count : integer
    copy_error : boolean= false
    create_target_catalog : string
    element_count : integer
    errors_found : boolean
    error_output : string= $unique
    formats : list 0..$max_list of string
    formats_file : string= $unique
    ignore_status : status
    intve_paths : list 0..$max_list of string
    intve_paths_file : string= $unique
    local_status : status
    pacs_commands_file : string= $unique
    pacs_paths : list 0..$max_list of string
    pacs_paths_file : string= $unique
    pacs_status : status
    source_file : string
    subproduct_file : string= $unique
    subproduct_list : list 0..$max_list of string
    target_file : string
    temp_list : list 0..$max_list of string
    temp_subproduct_file : string= $unique
    compile_file : string = $unique
    get_all : boolean = FALSE
    ignore : status
    selection_criteria_file : string = $unique
    wev$pacs_catalog : string = $string(pacs_catalog)
  VAREND

putl ''
putl ' Begin Levels generation'


product_table = wev$working_catalog
product_table = product_table//'.object.maintenance.qcf$qcu_product_table'
base_table = wev$development_base//'.os.'//wev$build_level//'.'
pacs_catalog = '.'//$job(user)//'.'//$string(qcu_ident)//'_PB'

 disc $fname(pacs_catalog) do=permits output=$null status=local_status
    IF NOT local_status.normal THEN
      IF local_status.condition = PFE$UNKNOWN_LAST_SUBCATALOG THEN
        create_catalog catalog=$fname(pacs_catalog) status=local_status
      IFEND
      EXIT_PROC with local_status WHEN NOT local_status.normal
    IFEND

get_products pt=$fname(product_table) ..
  pacc=$fname(pacs_catalog) ..
  lp=all,,,aip=$fname(alternate_intve_paths_file),ip=$fname(intve_paths_file) ..
  f=$fname(formats_file),pp=$fname(pacs_paths_file)  ..
  pc=$fname(pacs_commands_file) status=local_status

      EXIT_PROC with local_status WHEN NOT local_status.normal

    accl v=formats i=$fname(formats_file) status=local_status
       EXIT_PROC WITH local_status  WHEN NOT local_status.normal

    accl v=intve_paths i=$fname(intve_paths_file) status=local_status
       EXIT_PROC WITH local_status  WHEN NOT local_status.normal

       EXIT_PROC  WHEN ($size(formats) <> $size(intve_paths))

    FOR list = 1 TO $size(intve_paths) DO
      verify_file_entry file_name=$fname(intve_paths(list)) format=$name(formats(list)) status=local_status

      IF NOT local_status.normal THEN
      p1 = $translate(ltu,intve_paths(list))
      c1 = $scan_string('BOUND',p1)
          IF c1 > 0 THEN
            n1 = $substr(p1,c1,$strlen(p1)-c1+1)
          ELSE
            n1 = 'VERSION'
          IFEND
       copf $fname(base_table//n1) $fname(intve_paths(list))
      IFEND
    FOREND

    accl v=pacs_paths i=$fname(pacs_paths_file) status=local_status
       EXIT_PROC WITH local_status  WHEN NOT local_status.normal

       EXIT_PROC  WHEN ($size(intve_paths) <> $size(pacs_paths))


      get_subproduct_list pt=$fname(product_table) licensed_product=all ..
                output=$fname(temp_subproduct_file//'.$eoi') status=local_status
             EXIT_PROC WITH local_status  WHEN NOT local_status.normal


      standardize_name_list i=$fname(temp_subproduct_file) o=$fname(subproduct_file) ..
              status=local_status
             EXIT_PROC WITH local_status  WHEN NOT local_status.normal

    accl v=subproduct_list i=$fname(subproduct_file) status=local_status
       EXIT_PROC WITH local_status  WHEN NOT local_status.normal


    FOR EACH subcatalog IN subproduct_list DO
      delcc  c=pacs_catalog//$name(subcatalog) do=cc status=ignore
    FOREND


  copy_block: ..
    BLOCK

    file_entry_loop: ..
      FOR file_position = 1 TO $size(intve_paths) DO
        source_file = intve_paths(file_position)
        target_file = pacs_paths(file_position)
        create_target_catalog = pacs_paths(file_position)
        element_count = $path($fname(create_target_catalog), count)
        VAR
          catalog_element : array 1..element_count of string
        VAREND
      save_catalog_paths: ..
        FOR catalog_position = 3 TO (element_count - 1) DO
          catalog_element(catalog_position) = $path($fname(create_target_catalog), catalog)
          create_target_catalog = $path($fname(create_target_catalog), catalog)
        FOREND save_catalog_paths
      create_catalog_loop: ..
        FOR catalog_count = (element_count - 1) TO 3 BY - 1 DO
          create_catalog catalog=$fname(catalog_element(catalog_count)) status=local_status
          EXIT copy_block WHEN NOT local_status.normal AND ..
                local_status.condition <> PFE$NAME_ALREADY_SUBCATALOG
          local_status.normal = true
        FOREND create_catalog_loop
        delete_variable name=catalog_element status=ignore_status
        copy_file input=$fname(source_file) output=$fname(target_file) status=local_status
        IF NOT local_status.normal AND ..
           local_status.condition <> FSE$EMPTY_INPUT_FILE THEN
          disv local_status output=$response status=ignore_status
          local_status = $status(true)
          copy_error = true
        IFEND
      FOREND file_entry_loop
      IF copy_error THEN
        local_status = $status(false, 'WE', wee$errors_in_pacs_catalog)
      IFEND

    BLOCKEND copy_block
    EXIT_PROC  WHEN NOT local_status.normal


    VAR
       myfile: string = '.'//$job(user)//'.'//qcu_ident//'_QF'
       temp2 : string = $unique
       level : string
       work : string
    VAREND

    copf $fname(pacs_commands_file) $fname(myfile)
    detf $fname(myfile) status=ignore

    EDIF f=$fname(myfile)  p=$null o=$fname(temp2)
       rewf $fname(temp2)
       l ' level='
       QUIT

    accl v=work i=$fname(temp2)
    level = $substr(work,19,6)
    EDIF f=$fname(myfile) p=$null o=$null
       R level $string(qcu_ident)
       QUIT

    rewf $fname(myfile) status=ignore
    include_command command='PACKAGE_SOFTWARE' status=pacs_status
  pacs_block: ..
    BLOCK
      EXIT pacs_block WHEN NOT pacs_status.normal
      include_file file=$fname(myfile) status=local_status
    BLOCKEND pacs_block
    include_command command='quit' status=ignore_status

    IF NOT pacs_status.normal THEN
      IF NOT local_status.normal THEN
        display_value value=pacs_status output=$response status=ignore_status
        EXIT_PROC
      ELSE
        local_status = pacs_status
        EXIT_PROC WITH local_status
      IFEND
    ELSEIF NOT local_status.normal THEN
      EXIT_PROC WITH local_status
    IFEND

  detach_file file=$fname(alternate_intve_paths_file) status=ignore_status
  detach_file file=$fname(error_output) status=ignore_status
  detach_file file=$fname(formats_file) status=ignore_status
  detach_file file=$fname(intve_paths_file) status=ignore_status
  detach_file file=$fname(pacs_commands_file) status=ignore_status
  detach_file file=$fname(pacs_paths_file) status=ignore_status
  detach_file file=$fname(subproduct_file) status=ignore_status
  detach_file file=$fname(temp_subproduct_file) status=ignore_status

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND qcm$generate_levels
