/* 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;