/* REXX */                                                                      
/**********************************************************************/        
/* This program converts a zoned decimal (character) number to a      */        
/* binary format. The inputs to the program are:                      */        
/*                                                                    */        
/* char_num    - The zoned decimal number to be converted.            */        
/* bin_length  - The number of bytes of the binary value. The length  */        
/*               must be 2, 4 or 8 bytes.                             */        
/*               If not provided the minimum length is used.          */        
/*                                                                    */        
/* The output of the program varies with the type of invocation:      */        
/*                                                                    */        
/* COMMAND    - Displays a message line, and a detail line. Details   */        
/*              may include error information or the result of the    */        
/*              conversion. The binary value is shown in hexadecimal  */        
/*              format. A return code is set.                         */        
/* SUBROUTINE - Displays a message line and a detail line. The        */        
/*              detail line contains the binary value. If an error    */        
/*              occurs the detail line is null. A return code is      */        
/*              provided in variable RESULT.                          */        
/* FUNCTION   - Returns only the binary value. If an error occurs     */        
/*              a null is returned.                                   */        
/**********************************************************************/        
NUMERIC DIGITS 32                                                               
PARSE ARG char_num bin_length                                                   
PARSE UPPER SOURCE . zorg .                                                     
                                                                                
zrc     = 0                                                                     
zmsg2   = ''                                                                    
bin_num = ''                                                                    
                                                                                
SELECT                                                                          
WHEN char_num = ''                                                              
THEN DO                                                                         
       zmsg1 = 'No zoned decimal value passed to C2B.'                          
       zrc   = 16                                                               
       SIGNAL Done                                                              
     END                                                                        
WHEN \DATATYPE(char_num,'W')                                                    
THEN DO                                                                         
       zmsg1 = 'Value passed to C2B is not a valid whole number.'               
       zmsg2 = 'char_num =' char_num';'                                         
       zrc   = 12                                                               
       SIGNAL Done                                                              
     END                                                                        
WHEN char_num < 0                                                               
THEN fill_char = 'F'                                                            
OTHERWISE                                                                       
     fill_char = '0'                                                            
END /* SELECT */                                                                
                                                                                
hex_num = STRIP(D2X(char_num,16),'L',fill_char)                                 
IF hex_num = '' THEN hex_num = fill_char                                        
                                                                                
IF \DATATYPE(LENGTH(hex_num) / 2,'W')                                           
THEN hex_num = fill_char''hex_num    /* Even number of digits. */               
                                                                                
bit_zero = LEFT(X2B(hex_num),1)                                                 
                                                                                
SELECT                                                                          
WHEN bit_zero = '1' & fill_char = '0'                                           
THEN hex_num  = fill_char''fill_char''hex_num                                   
WHEN bit_zero = '0' & fill_char = 'F'                                           
THEN hex_num  = fill_char''fill_char''hex_num                                   
OTHERWISE NOP                                                                   
END /* SELECT */                                                                
                                                                                
hex_length = LENGTH(hex_num)                                                    
                                                                                
SELECT                                                                          
WHEN hex_length > 16                                                            
THEN DO                                                                         
       zmsg1 = 'Value passed to C2B exceeds an 8-byte binary number.'           
       zmsg2 = "C'"char_num"' = X'"hex_num"'."                                  
       zrc   = 8                                                                
       SIGNAL Done                                                              
     END                                                                        
WHEN bin_length =  ''                                                           
THEN SELECT                                                                     
     WHEN hex_length >= 10                                                      
     THEN bin_length =  16                                                      
     WHEN hex_length >=  6                                                      
     THEN bin_length =   8                                                      
     OTHERWISE                                                                  
          bin_length =   4                                                      
     END /* SELECT */                                                           
WHEN bin_length =  2                                                            
THEN bin_length =  4                                                            
WHEN bin_length =  4                                                            
THEN bin_length =  8                                                            
WHEN bin_length =  8                                                            
THEN bin_length = 16                                                            
OTHERWISE                                                                       
     zmsg1 = 'Value passed to C2B must be 2, 4 or 8 bytes.'                     
     zmsg2 = 'bin_length =' bin_length';'                                       
     zrc   = 8                                                                  
     SIGNAL Done                                                                
END /* SELECT */                                                                
                                                                                
IF hex_length > bin_length                                                      
THEN DO                                                                         
       zmsg1 = 'Value passed to C2B exceeds length passed.'                     
       zmsg2 = "LENGTH('"hex_num"'X) >" bin_length / 2                          
       zrc   = 8                                                                
       SIGNAL Done                                                              
     END                                                                        
                                                                                
zmsg1   = 'The value of the binary number is:'                                  
hex_num = RIGHT(hex_num,bin_length,fill_char)                                   
zmsg2   = "C'"char_num"' = X'"hex_num"'."                                       
INTERPRET "bin_num = '"hex_num"'X"                                              
                                                                                
Done:                                                                           
SELECT                                                                          
WHEN zorg = 'COMMAND'                                                           
THEN DO                                                                         
       SAY zmsg1                                                                
       SAY zmsg2                                                                
       EXIT zrc                                                                 
     END                                                                        
WHEN zorg = 'SUBROUTINE'                                                        
THEN DO                                                                         
       SAY zmsg1                                                                
       SAY bin_num                                                              
       RETURN zrc     /* Placed in RESULT. */                                   
     END                                                                        
OTHERWISE /* FUNCTION */                                                        
     RETURN bin_num                                                             
END /* SELECT */