PUNCH ' SETCODE AC(1) '                                                
* Token Creation routine.  Must be authorized to System Level Name/Token Pair
* Reads input tokens from DDname TOKIN.
*
* New name/token pairs are echoed via WTO to the console
*
* Author:  Lionel B. Dyck
*          Kaiser Permanente Information Technology
*          25 N. Via Monte Ave
*          Walnut Creek, Ca 94598
*          e-mail: lionel.b.dyck@kp.org
*
TOKCREAT CSECT                                                                  
TOKCREAT AMODE 31                                                               
TOKCREAT RMODE 24                                                               
         BAKR  R14,R0                                                           
         LR    R12,R15                                                          
         USING TOKCREAT,R12                                                     
         LOAD  EP=IEANTDL                                                       
         ST    R0,IEANTDL                                                       
         LOAD  EP=IEANTCR                                                       
         ST    R0,IEANTCR                                                       
         OPEN  TOKIN                                                            
GETTOKEN GET   TOKIN                                                            
         LR    R5,R1                                                            
         CLI   0(R5),C'*'                                                       
         BE    GETTOKEN                                                         
         MVC   NAME,0(R5)                                                       
         MVC   TOKEN,19(R5)                                                     
         MVC   WTONAME,NAME                                                     
         MVC   WTOTOKEN,TOKEN                                                   
         MODESET KEY=ZERO,MODE=SUP                                              
         L     R15,IEANTDL                                                      
         CALL  (15),(LEVEL,NAME,RETCODE)                                        
         L     R3,RETCODE                                                       
         C     R3,=F'04'                                                        
         BNH   CREATE                                                           
         L     R8,RETCODE                                                       
         LR    R9,R15                                                           
         ABEND 1                                                                
CREATE   DS    0H                                                               
         L     R15,IEANTCR                                                      
         CALL  (15),(LEVEL,NAME,TOKEN,PERSOPT,RETCODE)                          
         MODESET KEY=NZERO,MODE=PROB                                            
         CLC   RETCODE,=F'0'                                                    
         BNE   ABEND2                                                           
         LA    R1,WTOA                                                          
         SVC   35                                                               
         B     GETTOKEN                                                         
ABEND2   DS    0H                                                               
         L     R8,RETCODE                                                       
         LR    R9,R15                                                           
         ABEND 2                                                                
EXIT     DS    0H                                                               
         CLOSE (TOKIN)                                                          
         DELETE EP=IEANTCR                                                      
         DELETE EP=IEANDTL                                                      
         SR    R15,R15                                                          
         PR                                                                     
         EJECT                                                                  
         YREGS ,                                                                
         EJECT                                                                  
         IEANTASM                                                               
         LTORG                                                                  
IEANTDL  DS    F                                                                
IEANTCR  DS    F                                                                
LEVEL    DC    A(IEANT_SYSTEM_LEVEL)                                            
NAME     DS    CL16                                                             
TOKEN    DS    CL16                                                             
PERSOPT  DC    A(IEANT_PERSIST)                                                 
RETCODE  DS    F                                                                
         ORG   ,                                                                
         DS    0F                                                               
WTOA     DC    AL2(WTOAE-WTOA),AL2(0)                                           
WTOMSG   DC    C'TOKEN CREATION:  '                                             
WTONAME  DS    CL16                                                             
         DC    C'VALUE: '                                                       
WTOTOKEN DS    CL16                                                             
WTOAE    EQU   *                                                                
         DS    0F                                                               
TOKIN    DCB   DSORG=PS,RECFM=FB,LRECL=80,                             X        
               MACRF=GL,DDNAME=TOKIN,                                  X        
               EODAD=EXIT                                                       
         END   ,