PGM                                                                
/*---------------------------------------------------------*/                   
/*   TESTGETPH :  QSYGETPH のテスト                        */                   
/*---------------------------------------------------------*/                   
             DCL        VAR(&MSG) TYPE(*CHAR) LEN(132)                          
             DCL        VAR(&MSGID) TYPE(*CHAR) LEN(7)                          
             DCL        VAR(&MSGDTA) TYPE(*CHAR) LEN(132)                       
             DCL        VAR(&MSGF) TYPE(*CHAR) LEN(10)                          
             DCL        VAR(&MSGFLIB) TYPE(*CHAR) LEN(10)                       
             DCL        VAR(&SBS) TYPE(*CHAR) LEN(20)                           
             DCLF       FILE(TEST.COM/TESTGETPD)                                
             DCL        VAR(&OS400) TYPE(*CHAR) LEN(6)                          
             DCL        VAR(&PRFHND) TYPE(*CHAR) LEN(12)                        
             DCL        VAR(&APIERR) TYPE(*CHAR) LEN(116) +                     
                          VALUE(X'000074') /* 2 進数  */                        
             DCL        VAR(&NULL4) TYPE(*CHAR) LEN(4) +                        
                          VALUE(X'00000000')                                    
             DCL        VAR(&PASSLEN) TYPE(*CHAR) LEN(4) +                      
                          VALUE(X'000A') /* 10 */                               
             DCL        VAR(&CCSID) TYPE(*CHAR) LEN(4) +                        
                          VALUE(X'FFFF') /* 65535 */                            
             DCL        VAR(&INLPGM) TYPE(*CHAR) LEN(10)                        
             DCL        VAR(&INLPGMLIB) TYPE(*CHAR) LEN(10)                     
             DCL        VAR(&API) TYPE(*CHAR) LEN(10)                           
             MONMSG     MSGID(CPF0000) EXEC(GOTO CMDLBL(ERROR))                 
                                                                                
 /*(1) OS400 のリリースを検索する */                                            
             RTVDTAARA  DTAARA(QGPL/QSS1MRI (1 6)) RTNVAR(&OS400)               
                                                                                
 /*(2) サイン・オン画面を表示してユーザー、パスワードを受け取る */              
             CHGVAR     VAR(&COPYRIGHT) VALUE('(C) COPYRIGHT OFFICE +           
                          QUATTRO 2012-')                                       
             RTVJOBA    JOB(&DEVNAME)                                           
             RTVSYSVAL  SYSVAL(QCTLSBSD) RTNVAR(&SBS)                           
             CHGVAR     VAR(&SBSNAME) VALUE(%SST(&SBS 1 10))                    
             SNDRCVF    RCDFMT(SIGNON)                                          
             IF         COND(&IN03 *EQ '1') THEN(RETURN)                        
                                                                                
 /*(3) QSYGETPH でログイン・ハンドルを生成する */                               
             IF         COND(&OS400 *LT 'V5R3M0') THEN(DO) /* +                 
                          V5R3M0 未満  */                                       
             CALL       PGM(QSYGETPH) PARM(&USERID &PASSWRD &PRFHND +           
                          &APIERR)                                              
             ENDDO      /* V5R3M0 未満  */                                      
             ELSE       CMD(DO) /* V5R3M0 以上  */                              
             CHGVAR     VAR(%BIN(&PASSLEN)) VALUE(10)                           
             CHGVAR     VAR(%BIN(&CCSID)) VALUE(65535)                          
             CALL       PGM(QSYGETPH) PARM(&USERID &PASSWRD &PRFHND +           
                          &APIERR &PASSLEN &CCSID)                              
             ENDDO      /* V5R3M0 以上  */                                      
             IF         COND(%SST(&APIERR 5 4) *NE &NULL4) THEN(DO)             
             CHGVAR     VAR(&API) VALUE('QSYGETPH')                             
             GOTO       APIERR                                                  
             ENDDO                                                              
                                                                                
 /*(4)  指定したユーザーで JOB を開始する */                                    
             CALL       PGM(QWTSETP) PARM(&PRFHND &APIERR)                      
             IF         COND(%SST(&APIERR 5 4) *NE &NULL4) THEN(DO)             
             CHGVAR     VAR(&API) VALUE('QWTSETP')                              
             GOTO       APIERR                                                  
             ENDDO                                                              
                                                                                
 /*(5) ユーザー・プロフィールで登録されている初期プログラムを起動する */        
             RTVUSRPRF  USRPRF(*CURRENT) INLPGM(&INLPGM) +                      
                          INLPGMLIB(&INLPGMLIB)                                 
             CALL       PGM(&INLPGMLIB/&INLPGM)                                 
                                                                                
 /*(6) ハンドルを解放して JOB を終了する */                                     
             CALL       PGM(QSYRLSPH) PARM(&PRFHND)                             
                                                                                
             RETURN                                                             
                                                                                
 APIERR:                                                                        
             CHGVAR     VAR(&MSGID) VALUE(%SST(&APIERR 9 7))                    
             CHGVAR     VAR(&MSGDTA) VALUE(%SST(&APIERR 17 100))                
             CHGVAR     VAR(&MSGF) VALUE('QCPFMSG   ')                          
             CHGVAR     VAR(&MSGFLIB) VALUE('QSYS      ')                       
             SNDPGMMSG  MSG('API: ' *CAT &API *TCAT +                           
                          ' でエラーがありました。 ') +                         
                          TOMSGQ(*TOPGMQ) MSGTYPE(*COMP)                        
             GOTO       SNDERR                                                  
 ERROR:      RCVMSG     MSGTYPE(*LAST) RMV(*NO) MSG(&MSG) +                     
                          MSGDTA(&MSGDTA) MSGID(&MSGID) MSGF(&MSGF) +           
                          MSGFLIB(&MSGFLIB)                                     
 SNDERR:     IF         COND(&MSGID *EQ ' ') THEN(DO)                           
             SNDPGMMSG  MSG(&MSG) TOMSGQ(*SYSOPR)                               
             ENDDO                                                              
             ELSE       CMD(DO)                                                 
             SNDPGMMSG  MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +                    
                          MSGDTA(&MSGDTA) TOMSGQ(*TOPGMQ) +                     
                          MSGTYPE(*ESCAPE)                                      
             ENDDO                                                              
             ENDPGM