
PROC qcp$withdraw_correction (
correction_identifier, ci: name 1 .. 7 = $required
output, o: file = $output
status )

crev ignore k=status
crev work k=string
crev count v=1
crev history k=boolean
crev last_base k=string
crev local_status k=status



IF $file($value(output) open_position) = '$BOI' THEN
   ofile = $string($value(output)) //'.$ASIS'
ELSE
   ofile = $string($value(output))
IFEND

crev qev$correction_base k=string s=xdcl
crev qev$installation_base k=string s=xdcl
crev qev$modifier_base k=string s=xdcl
crev qev$correction_identifier k=string s=xdcl



"**************************************************************************
" Setup default values
"**************************************************************************
qev$correction_base   =   ':$SYSTEM.$SYSTEM.FIELD_MAINTENANCE'
qev$target_base       =   ':$SYSTEM.$SYSTEM.QCU_MAINTENANCE'
qev$modifier_base     =   ':$SYSTEM.$SYSTEM.NOSVE_MAINTENANCE'
qev$correction        =   $string($value(correction_identifier))


crev tb_path k=string v=qev$target_base
crev tc_path k=string v=qev$target_base//'.LINK_INPUT_FILES'
crev cc_path k=string v=qev$correction_base//'.'//qev$correction
     cc_path = cc_path//'.LINK_INPUT_FILES'
crev mc_path k=string v=qev$modifier_base//'.LINK_INPUT_FILES'
crev bo_path k=string v=qev$correction_base
crev hi_path k=string v=qev$correction_base//'.HISTORY.$ASIS'
crev lb_path k=string v=qev$correction_base//'.LIBRARIES'
crev na_path k=string v=qev$correction_base//'.'//qev$correction//'.NAMES'
crev nh_path k=string v=$unique
crev id_path k=string v=qev$target_base//'.IDENTIFICATION'
crev ll_path k=string v=qev$correction_base//'.PATHS'
crev cp_path k=string v=qev$correction_base//'.LINK_INPUT_FILES'


crev temp1 k=string v=$unique//'.$asis'
crev temp2 k=string v=$unique//'.$asis'
crev temp3 k=string v=$unique

crev here k=boolean v=FALSE

crev ci k=string v=$string($value(correction_identifier))
crev available k=boolean v=FALSE

IF NOT $file($fname(cc_path),catalog) THEN
   putl ' ' o=$fname(ofile)
   putl '                    WARNING' o=$fname(ofile)
   putl '     The correction identifier specified does not describe' o=$fname(ofile//'.$eoi')
   putl '     a correction currently installed. Please review your' o=$fname(ofile//'.$eoi')
   putl '     request.' o=$fname(ofile//'.$eoi')
   putl ' '  o=$fname(ofile//'.$eoi')
   putl ' ' o=$fname(ofile//'.$eoi')
   EXIT_PROC
IFEND


IF NOT $file($fname(qev$modifier_base),catalog) THEN
 putl '                        WARNING' o=$fname(ofile//'.$eoi')
 putl '      Unable to generate a correction system due to absence' o=$fname(ofile//'.$eoi')
 putl '      of the '//qev$modifier_base//' catalog' o=$fname(ofile//'.$eoi')
 EXIT_PROC
IFEND

delc $fname(tb_path) do=cac status=ignore
crec $fname(tb_path) status=ignore
crec $fname(tc_path) status = ignore
detf $fname(hi_path) status=ignore

   crev system_base k=string
   crev previous k=string
   crev work1 k=string
   crev last k=string
   crev next_base k=string
   crev entries
IF $file($fname(hi_path),permanent) THEN
   attf $fname(hi_path) op=$asis
   accl work i=$fname(hi_path) lc=count
       last = $substr(work,43,6)
       system_base = $substr(work,43,6)
       next_base = $substr(work,43,6)
       previous = $substr(work,14,7)
    WHILE count > 0 DO
             last_base = $substr(work,14,7)
       IF $substr(work,3,7) = ci THEN
         next_base = last
         last_base = previous
         available = TRUE
       ELSE
         previous = $substr(work,14,7)
         last = $substr(work,3,7)
         work1 = $substr(work,1,25)
         work1 = work1//$substr(next_base,1,7)
         work1 = work1//$substr(work,33,47)
         putl work1 o=$fname(nh_path//'.$eoi')
         entries = entries + 1
       IFEND
     accl work i=$fname(hi_path) lc=count
    WHILEND

" If we are backing out a correction which is the first in the list
" and there are following corrections, use the identifier of the
" last one in the list.

      IF next_base = system_base THEN
         next_base = last
      IFEND
" save the identifier for later use
putl last_base o=$fname(id_path)


      IF entries = 0 THEN
         put_line '-'  o=$fname(ofile//'.$eoi')
         put_line '                      ADVISE'  o=$fname(ofile//'.$eoi')
         put_line '      Withdrawal of correction '//$strrep(ci)//' forces' o=$fname(ofile//'.$eoi')
         put_line '      the system back to the installed base level.'      o=$fname(ofile//'.$eoi')
         put_line ' '                                                       o=$fname(ofile//'.$eoi')
         put_line '      To properly reestablish the base system the  '     o=$fname(ofile//'.$eoi')
         put_line '      command WITHDRAW_CORRECTION_SYSTEM should be'      o=$fname(ofile//'.$eoi')
         put_line '      entered. This will install the last base system'   o=$fname(ofile//'.$eoi')
         put_line '      to the deadstart device. A subsequent deadstart'   o=$fname(ofile//'.$eoi')
         put_line '      will activate the base system.'                    o=$fname(ofile//'.$eoi')
         put_line ' '                                                       o=$fname(ofile//'.$eoi')
         put_line '      Another option is to install a new correction and' o=$fname(ofile//'.$eoi')
         put_line '      generate a new correction system.'                 o=$fname(ofile//'.$eoi')
         put_line ' '                                                       o=$fname(ofile//'.$eoi')
       delc $fname(tb_path) do=cac status=ignore
       EXIT_PROC
    IFEND


     rewf $fname(nh_path) status=ignore
     delf $fname(hi_path) status=ignore
     copf $fname(nh_path) $fname(hi_path)
     detf $fname(hi_path) status=ignore

   crev libs k=string d=1..10 v=''
   crev c1 v=1
   attf $fname(na_path) op=$asis
   accl work i=$fname(na_path) lc=count

    WHILE count > 0 DO
      libs(c1) = work
      c1 = c1 + 1
      accl work i=$fname(na_path) lc=count
    WHILEND

     attf $fname(lb_path) op=$asis
     accl work i=$fname(lb_path) lc=count

    WHILE count > 0 DO
        FOR i = 1 TO c1 DO
          IF libs(i) = work THEN
             here = TRUE
             libs(i) = ''
          IFEND
        FOREND
          IF NOT here THEN
           putl work o=$fname(temp3//'.$eoi')
          IFEND
          here = FALSE
         accl work i=$fname(lb_path) lc=count
     WHILEND

         rewf $fname(temp3) status=ignore
         detf $fname(lb_path) status=ignore
         delf $fname(lb_path) status=ignore
         copf $fname(temp3) $fname(lb_path)

ELSE
   putl ' '         o=$fname(ofile//'.$eoi')
   putl '                     WARNING' o=$fname(ofile//'.$eoi')
   putl '     There is no record of any modifications having been made' o=$fname(ofile//'.$eoi')
   putl '     to the current system. Please review your request.'      o=$fname(ofile//'.$eoi')
   putl ' '                                                o=$fname(ofile//'.$eoi')
   EXIT_PROC
IFEND

  IF NOT available THEN
   putl ' ' o=$fname(ofile//'.$eoi')
   putl '                     WARNING' o=$fname(ofile//'.$eoi')
   putl '     The correction identifier specified does not describe' o=$fname(ofile//'.$eoi')
   putl '     a correction currently installed. Please review your'  o=$fname(ofile//'.$eoi')
   putl '     request.'                                              o=$fname(ofile//'.$eoi')
   putl ' '                                                          o=$fname(ofile//'.$eoi')
  EXIT_PROC
  IFEND


putl ' '                                       o=$fname(ofile//'.$eoi')
putl '    Backing out Correction Level '//$strrep(ci)  o=$fname(ofile//'.$eoi')
putl ' '                                               o=$fname(ofile//'.$eoi')
putl '    Basing new Correction System on Level '//last_base  o=$fname(ofile//'.$eoi')
putl ' '                                                      o=$fname(ofile//'.$eoi')



" Modify correction base to reflect removal of named correction
" by deleting the associated libraries from the link files.

   crev temp5 k=string v=$unique
   crev dl_path k=string
   detf $fname(ll_path) status=ignore
   attf $fname(ll_path) op=$asis
    accl work i=$fname(ll_path) lc=count
     WHILE count > 0 DO
      IF $substr(work,31,7) = ci THEN
       dl_path = cp_path//'.'//$substr(work,1,28)
        delf $fname(dl_path)
      ELSE
       putl work o=$fname(temp5//'.$eoi')
      IFEND
       accl work i=$fname(ll_path) lc=count
     WHILEND
    rewf $fname(temp5)   status=ignore
    delf $fname(ll_path) status=ignore
    copf $fname(temp5) $fname(ll_path)


display_catalog $fname(cc_path) o=$fname(temp2)
rewf $fname(temp2) status=ignore
crev libnew k=string d=1..20 v=''
crev libnc v=1
accl v=work i=$fname(temp2//'.$asis') lc=count
WHILE count >0 DO
 IF $substr(work,5,5) = 'FILE:' THEN
   libnew(libnc) = $substr(work,11,$strlen(work))
   libnc = libnc + 1
 IFEND
 accl v=work i=$fname(temp2//'.$asis') lc=count
WHILEND

display_catalog $fname(mc_path) o=$fname(temp1)
rewf $fname(temp1) status=ignore
crev libold k=string d=1..20 v=''
crev liboc v=1
accl v=work i=$fname(temp1//'.$asis') lc=count
WHILE count >0 DO
 IF $substr(work,5,5) = 'FILE:' THEN
   libold(liboc) = $substr(work,11,$strlen(work))
   liboc = liboc + 1
 IFEND
 accl v=work i=$fname(temp1//'.$asis') lc=count
WHILEND

 crev bf_path k=string
 crev cf_path k=string
 crev tf_path k=string
 crev lf_path k=string
 crev repair  k=boolean


       FOR i = 1 TO liboc-1 DO
         IF libold(i) <> 'OS_VERSION' THEN
            lib = libold(i)
                repair = FALSE
              FOR j = 1 TO libnc DO
                IF libnew(j) = lib THEN
                   repair = TRUE
                   EXIT
                IFEND
              FOREND
          IFEND
            cf_path = cc_path//'.'//lib
            bf_path = mc_path//'.'//lib
            tf_path = tc_path//'.'//lib
            lf_path = cp_path//'.'//lib
          IF repair THEN

               IF $file($fname(lf_path),permanent) THEN
               putl '       Repairing Library '//lib
               copy_file $fname(lf_path) $fname(tf_path) status=local_status
                    IF NOT local_status.normal THEN
                     EXIT_PROC WITH local_status
                    IFEND
               ELSE
                putl '      Backing out Library '//lib
                copy_file $fname(bf_path) $fname(tf_path) status=local_status
                   IF NOT local_status.normal THEN
                      EXIT_PROC WITH local_status
                   IFEND
               IFEND
           ELSE
             copy_file $fname(bf_path) $fname(tf_path) status=local_status
               IF NOT local_status.normal THEN
                  EXIT_PROC WITH local_status
               IFEND
           IFEND
           FOREND

           crev nx_path k=string v=qev$correction_base//'.'//next_base
           nx_path = nx_path//'.link_input_files'
           copy_file $fname(nx_path//'.OS_VERSION') $fname(tc_path//'.OS_VERSION') status=local_status
               IF NOT local_status.normal THEN
                  EXIT_PROC WITH local_status
               IFEND

detf $fname(hi_path) status=ignore
detf $fname(na_path) status=ignore
detf $fname(lb_path) status=ignore
detf $fname(cp_path) status=ignore
detf $fname(ll_path) status=ignore

delc $fname(bo_path//'.'//ci) do=cac status=ignore


        putl ''                                               o=$fname(ofile//'.$eoi')
        putl '     End Installation of '//last_base//' Correction level' o=$fname(ofile//'.$eoi')
        putl ''                                               o=$fname(ofile//'.$eoi')

PROCEND qcp$withdraw_correction
