/* ICUEXTR: Converts ADMCDATA file into a CMS flat file.       *
****************************************************************
* THIS PROGRAMM HAS BEEN WRITTEN BY:  RUPP THOMAS              *
* VORARLBERGER ILLWERKE AG - BREGENZ  23/12/94                 *
* VERSION:  1.0                       23/12/94                 *
*!!*************************************************************
This exec written in GDDM-REXX takes an ICU ADMCDATA file
and extracts the data within it. A flat file is created
with the same name on the a-disk.
 
ICUEXTR filename
************************************************************!!*/
         /*************************************************
         * Parameter:                                     *
         *   1   fn     Name of ADMCDATA Files            *
         *************************************************/
         parse upper arg fn . '(' o1 o2 o3 o4 .;
         /*************************************************
         * Show Help Info. It shows all lines between the *
         * first and second line containing "!!".         *
         * The lines with "!!" will not be displayed.     *
         *************************************************/
         if fn = '?'
           then
             do;
               'VMFCLEAR';
               ende = 0;
               do i = 1 to sourceline() until(ende);
                 if pos('!!',sourceline(i)) > 0
                   then
                     do;
                       do j = i+1 while pos('!!',sourceline(j)) = 0;
                         say sourceline(j);
                       end;
                       ende = 1;
                     end;
               end;
               exit 100;
             end;
         /********************
         * Start processing  *
         ********************/
         ft = 'LIST';       /* File type of the file to be output    */
         fm = 'A';          /* File mode of the file to be output    */
         missingvalues = ''; /* Missing ICU data values shown as this*/
         /**************************************************
         * Put out error message if no filename was passed *
         **************************************************/
         if fn = ''
           then
             do;
               say 'First Argument has to be the name of the ADMCDATA file.';
             exit 1;
           end;
         /* Check existence of the requested file */
         'STATE' fn 'ADMCDATA *';
         /***********************************************
         * Put out error message if file does not exist *
         ***********************************************/
         if rc ^= 0
           then
             do;
               say 'Could not find' fn 'ADMCDATA. RC =' rc;
             exit rc;
           end;
         /****************************************************
         * Check existence of flat file, deleting if present *
         ****************************************************/
         'STATE' fn ft fm;           /* Check existence of flat file */
         if rc = 0                   /* .. and delete, if found      */
           then 'CMDCALL ERASE' fn ft fm;
 
         'GDDMREXX INIT';
         Address GDDM;
         /* Set default: permit dual-byte */
         'ESSUDS . "DEFAULT MIXSOSI=YES"';
         /* Ignore existing nicknames     */
         'ESSUDS . "NICKNAME REPLACE   "';
         /* Open 'dummy' device           */
         'DSOPEN 1 1 L79A3 0 () 1 (" ")';
         /* .. and use it as primary      */
         'DSUSE 1 1';
         /* Create an ICU chart           */
         'CSCCRT 1 1';
         /* Load requested ICU data file  */
         'CSLOAD 1 2 "'fn'"';
         /*********************************************************
         * Test for 'freed' data and exit if file is of this type *
         *********************************************************/
         /* Test to see if free data      */
         'CSQNUM 1 12 .FREETIED';
         if freetied = 2             /* File is of free data type     */
           then
             do;
               say 'ICUEXTR does not support files containing free data'
               say 'See "ICU Users Guide" for definition of free data'
               'GDDMREXX TERM';
               exit 99;
             end;
         /* Query number of components       */
         'CSQNUM 1 5 .NOYS'
         /* Query number of elements         */
         'CSQNUM 1 6 .NOXS'
         /* Query the X data values          */
         'CSQXDT 1 0 .NOXS .X.'
         /* Query X data selection           */
         'CSQXSL 1 0 .NOXS .XSEL'
         /* Query data label number/length   */
         'CSQCHL 1 7 .NOLABS .LENLABS'
         /* Query d-group name number/length */
         'CSQCHL 1 6 .NODGN  .LENDGN '
         /* Get labels:  Loop is temporary restriction due to bug */
         /* in process of being fixed.                            */
         if nolabs > 0
           then
             do i = 1 to nolabs;
               'CSQCHA 1 7 .I 1 .LENLABS .TEMP.';
               lbls.i = temp.1;
             end;
         /* Query Y-data for each component */
         do i = 1 to noys;
           'CSQYDT 1 .I .NOXS .Y.'i'.';
         end;
         /* Query the chart's Z data        */
         'CSQZDT 1 .NOYS .Z.';
         if nodgn > 0                /* Get data group names:  Loop   */
           then                      /* is temporary                  */
             do i = 1 to nodgn;
               'CSQCHA 1 6 .I 1 .LENDGN  .TEMP.';
               dgns.i = temp.1;
             end;
         /* Query length of the heading   */
         'CSQCHL 1 8 .NOHDR  .LENHDR';
         /* Query heading                 */
         if nohdr > 0
           then 'CSQCHA 1 8 1 .NOHDR .LENHDR  .HDR.';
         address command 'GDDMREXX TERM';      /* terminate GDDM-REXX */
         address CMS;
         outline  = copies(' ',13+lenlabs);       /* Set to all-blank */
         outline2 = copies(' ',13+lenlabs)        /* Set to all-blank */
         do i = 1 to noys;
           outline = outline right(z.i,20);/* Right align I'th Z value*/
           dgn = left(dgns.i,20);         /* Left align I'th dg name  */
           dgn = strip(dgn,'T');          /* Remove trailing blanks   */
           dgn = strip(dgn,'T','00'x);    /* Remove trailing nulls    */
           outline2 = outline2 right(dgn,20); /* Right align dg name  */
         end;
         /****************************************************
         * Center the header and put out as 1st line of file *
         ****************************************************/
         /* Center */
         hdroff = trunc(max((length(outline2)-length(hdr.1))/2,1));
         /* Pad with leading blanks */
         hdr.1 = copies(' ',hdroff)!!hdr.1;
         /* ensure all hex00 goto blank */
         hdr.1 = translate(hdr.1,' ','00'x);
         outline= translate(outline,' ','00'x);
         outline2= translate(outline2,' ','00'x);
         queue hdr.1;           /* Queue header as 1st line of output */
         queue outline2;        /* Queue data group names as 2nd line */
         queue outline;         /* Queue Z-values as 3rd line         */
         queue copies('-',length(outline)+2);    /* 4th line, row '-' */
         do i = 1 to noxs;
         outline = lbls.i right(x.i,20) '!';  /* Data label ri align. */
         do j = 1 to noys;
           if y.j.i = 1.E+72
             then y.j.i = missingvalues;            /* Test 'missing' */
           outline = outline right(y.j.i,20); /* Concat next Y-value  */
         end;
         outline = translate(outline,' ','00'x);
         queue outline;                  /* Queue line of Y-yalues    */
       end;
       /**********************************************
       * Now perform the physical output to the file *
       **********************************************/
       'EXECIO' queued() 'DISKW' fn ft fm' 0 V 121 (FINIS';
       exit;
