Retrieve Last Spooled file ID with API QSPRILSP
擷取 Job 最後產生的報表資訊 API QSPRILSP
pgm
dcl &SplfNbr1 *int 4
dcl &SplfNbr2 *int 4
dcl &RcvVar *char 70
dcl &BytesAvail *int 4 stg(*defined) defvar(&RcvVar 1)
dcl &BytesRtn *int 4 stg(*defined) defvar(&RcvVar 5)
dcl &SplfName *char 10 stg(*defined) defvar(&RcvVar 9)
dcl &JobName *char 10 stg(*defined) defvar(&RcvVar 19)
dcl &UserName *char 10 stg(*defined) defvar(&RcvVar 29)
dcl &JobNbr *char 6 stg(*defined) defvar(&RcvVar 39)
dcl &SplfNbr *int 4 stg(*defined) defvar(&RcvVar 45)
dcl &SysName *char 8 stg(*defined) defvar(&RcvVar 49)
dcl &SplfCrtDat *char 7 stg(*defined) defvar(&RcvVar 57)
dcl &SplfCrtTim *char 6 stg(*defined) defvar(&RcvVar 65)
dcl &RcvVarLen *int 4 value(70)
dcl &FmtName *char 10
dcl &ErrorCode *char 8
dcl &Stat *lgl
dcl &SplfExists *lgl
callsubr subr(RtvSplfNbr) rtnval(&SplfNbr1)
call pgm1
callsubr subr(RtvSplfNbr) rtnval(&SplfNbr2)
/* If pgm1 created a report, continue with other tasks. */
if (&SplfNbr2 *ne &SplfNbr1) do
call pgm2
call pgm3
call pgm4
enddo
return
subr subr(RtvSplfNbr)
chgvar &BytesAvail 70
chgvar &FmtName 'SPRL0100'
chgvar &ErrorCode x'0000000000000000'
chgvar &SplfExists '1'
call QSPRILSP (&RcvVar &RcvVarLen &FmtName &ErrorCode)
monmsg cpf333a exec(chgvar &SplfExists '0')
if (&SplfExists) then
else do
chgvar &SplfNbr 0
enddo
endsubr rtnval(&SplfNbr)
endpgm
Copy from https://www.itjungle.com/2006/02/08/fhg020806-story01/
星期一, 11月 13, 2023
2023-11-13 Retrieve Current job last spooled file ID with API QSPRILSP
星期四, 11月 09, 2023
2018-12-03 Check Daily Batch Jobs started or not
Check Daily Batch Jobs started or not
CHKBCHJOB CLP read file CHKBCHJOBP and check current time >= start time and current time < end time and chkflg ='Y',
then call API get the job active information, If job does not active, then send the job not acticve message to sysopr.
If job active, but status is MSGW, also send message to sysopr.
File : QDDSSRC
Member: CHKBCHJOBP
Type : PF
Usage : CrtPF File(CHKBCHJOBP)
A*****************************************************************
A* FUNCTION : CHKBCHJOB monitor batch job file
A* FILE : CHKBCHJOBP
A* AUTHOR : Vengoal Chang
A* DATE : 2018/12/03
A*****************************************************************
A UNIQUE
A R BCHJOBR TEXT('Batch job record')
A JOBNAME 10A COLHDG(' JOB NAME')
A JOBUSER 10A COLHDG(' USER')
A STRTIME 6S 0 COLHDG('start time')
A ENDTIME 6S 0 COLHDG('end time')
A CHKFLAG 1A COLHDG('check Y/N')
A NOTE 32O COLHDG('note')
A UPDDATE 8S 0 COLHDG('update date')
A UPDTIME 6S 0 COLHDG('update time')
A*----------------------------------------------------------------
A K JOBNAME
File : QCLSRC
Member: CHKBCHJOBC
Type : CLP
OS400 : V5R4 above
Usage : CrtClPgm Pgm(ChkBCHJOBC)
/* =============================================================== */
/* = Program ChkBchJobC = */
/* = ChkBchJob CLP = */
/* = Paramater notes: = */
/* = Read CHKBCHJOBP file to check daily job active or not = */
/* =============================================================== */
/* = Date : 2018/12/03 = */
/* = Author: Vengoal Chang = */
/* =============================================================== */
PGM
DCL &CURTIMEC *CHAR 6
DCL &STRTIMEC *CHAR 6
DCL &ENDTIMEC *CHAR 6
DCL &CURTIME *DEC (6 0)
DCL &MSGTEXT *CHAR 256
DCL &USP_NAME *CHAR 10
DCL &USP_LIB *CHAR 10
DCL &USP_QUAL *CHAR 20
DCL &USP_TYPE *CHAR 10
DCL &USP_SIZE *CHAR 4
DCL &USP_FILL *CHAR 1
DCL &USP_AUT *CHAR 10
DCL &USP_TEXT *CHAR 50
DCL &API_USQUAL *CHAR 20
DCL &API_JBQUAL *CHAR 26
DCL &API_JBNAM *CHAR 10
DCL &API_USER *CHAR 10
DCL &API_JOBNR *CHAR 6
DCL &API_STATUS *CHAR 10
DCL &STARTPOS *CHAR 4
DCL &DATALEN *CHAR 4
DCL &HEADER *CHAR 150
DCL &LST_OFFSET *DEC (10 0)
DCL &LST_SIZE *DEC (10 0)
DCL &LST_DATA *CHAR 4096
DCL &LST_NBR *DEC (5 0)
DCL &LST_LEN *DEC (5 0)
DCL &LST_LENBIN *CHAR 4
DCL &LST_POSBIN *CHAR 4
DCL &LST_COUNT *DEC (5 0) VALUE(0)
DCL &EXC_COUNT *DEC (5 0) VALUE(0)
DCL &TYPE *CHAR 1 VALUE('*')
DCL &NBRTORTN *CHAR 4
DCL &KEYSTORTN *CHAR 16
DCL &KEY1 *CHAR 4
DCL &KEY2 *CHAR 4
DCL &KEY3 *CHAR 4
DCL &KEY4 *CHAR 4
DCL &SBSSYS *CHAR 20
DCL &WRKSTS *CHAR 4
DCL &MSGRPLY *CHAR 1
DCL &USER *CHAR 10
DCL &CURUSR *CHAR 10
DCL &JOBNBR *CHAR 6
DCL &STATUS *CHAR 10
DCL &JOBTYPE *CHAR 1
DCL &SUBTYPE *CHAR 1
DCLF CHKBCHJOBP
MONMSG (CPF0000 MCH0000) *NONE GOTO ERROR
READF:
RCVF
MONMSG CPF0864 *N GOTO ENDF
RTVSYSVAL SYSVAL(QTIME) RTNVAR(&CURTIMEC)
CHGVAR &CURTIME &CURTIMEC
IF (&CURTIME >= &STRTIME *AND +
&CURTIME < &ENDTIME *AND +
&CHKFLAG = 'Y') Do
CallSubR SubR(ListJob)
If (&LST_NBR *EQ 0) Do
CHGVAR &STRTIMEC &STRTIME
CHGVAR &ENDTIMEC &ENDTIME
CHGVAR &MSGTEXT +
('* Bctch Job=' *CAT +
&JOBNAME *CAT 'run time : ' *CAT +
&STRTIMEC *BCAT '~' *BCAT &ENDTIMEC *CAT +
', program not started !')
SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) +
MSGDTA(&MSGTEXT) TOMSGQ(*SYSOPR)
EndDo
EndDo
Goto READF
ENDF:
Return
Error:
Call QMHMOVPM ( ' ' +
'*DIAG' +
x'00000001' +
'*PGMBDY' +
x'00000001' +
x'0000000800000000' +
)
Call QMHRSNEM ( ' ' +
x'0000000800000000' +
)
/****************************************************************/
/* Sub routine ListJob */
/****************************************************************/
SUBR SUBR(ListJob)
CHGVAR VAR(%BIN(&NBRTORTN)) VALUE(4)
/* 0101 -- Ststus as WRKACTJOB */
CHGVAR VAR(%BIN(&KEY1 )) VALUE(0101)
/* 1906 -- Subsystem */
CHGVAR VAR(%BIN(&KEY2 )) VALUE(1906)
/* 1307 -- Message Reply */
CHGVAR VAR(%BIN(&KEY3 )) VALUE(1307)
/* 0305 -- Current user profile */
CHGVAR VAR(%BIN(&KEY4 )) VALUE(0305)
CHGVAR VAR(&KEYSTORTN) VALUE(&KEY1 *CAT &KEY2 *CAT +
&KEY3 *CAT &KEY4)
CHGVAR VAR(&USP_NAME) VALUE('CHKJOBNAME')
CHGVAR VAR(&USP_LIB) VALUE('QTEMP')
CHGVAR VAR(&USP_QUAL) VALUE(&USP_NAME *CAT +
&USP_LIB)
CHGVAR VAR(&USP_TYPE) VALUE('MYTYPE')
CHGVAR VAR(%BIN(&USP_SIZE)) VALUE(128000)
CHGVAR VAR(&USP_FILL) VALUE(' ')
CHGVAR VAR(&USP_AUT) VALUE('*USE')
CHGVAR VAR(&USP_TEXT) VALUE('my user space')
DLTUSRSPC USRSPC(&USP_LIB/&USP_NAME)
MONMSG CPF0000
CALL PGM(QUSCRTUS) PARM(&USP_QUAL &USP_TYPE +
&USP_SIZE &USP_FILL &USP_AUT &USP_TEXT)
CHGVAR VAR(&API_USQUAL) VALUE(&USP_QUAL)
CHGVAR VAR(&API_JBNAM) VALUE(&JOBNAME)
CHGVAR VAR(&API_USER) VALUE('*ALL')
/* CHGVAR VAR(&API_USER) VALUE(&JOBUSER) */
CHGVAR VAR(&API_JOBNR) VALUE('*ALL')
CHGVAR VAR(&API_STATUS) VALUE('*ACTIVE')
CHGVAR VAR(&API_JBQUAL) VALUE(&API_JBNAM *CAT +
&API_USER *CAT &API_JOBNR)
CALL PGM(QUSLJOB) PARM(&API_USQUAL 'JOBL0200' +
&API_JBQUAL &API_STATUS X'00000000' +
&TYPE &NBRTORTN &KEYSTORTN)
CHGVAR VAR(%BIN(&STARTPOS)) VALUE(1)
CHGVAR VAR(%BIN(&DATALEN)) VALUE(140)
CALL PGM(QUSRTVUS) PARM(&API_USQUAL &STARTPOS +
&DATALEN &HEADER)
CHGVAR VAR(&LST_OFFSET) VALUE(%BIN(&HEADER 125 4))
CHGVAR VAR(&LST_SIZE) VALUE(%BIN(&HEADER 129 4))
CHGVAR VAR(&LST_NBR) VALUE(%BIN(&HEADER 133 4))
CHGVAR VAR(&LST_LEN) VALUE(%BIN(&HEADER 137 4))
CHGVAR VAR(%BIN(&LST_POSBIN)) VALUE(&LST_OFFSET + 1)
CHGVAR VAR(&LST_LENBIN) VALUE(%SST(&HEADER 137 4))
CHGVAR VAR(&LST_COUNT) VALUE(0)
IF (&LST_NBR *EQ 0) DO
/* Job not found */
Goto Lst_End
ENDDO
LST_LOOP: IF COND(&LST_COUNT *EQ &LST_NBR) THEN(GOTO +
CMDLBL(LST_END))
CALL PGM(QUSRTVUS) PARM(&API_USQUAL &LST_POSBIN +
&LST_LENBIN &LST_DATA)
CHGVAR VAR(&JOBNAME) VALUE(%SST(&LST_DATA 1 10))
CHGVAR VAR(&USER) VALUE(%SST(&LST_DATA 11 10))
CHGVAR VAR(&JOBNBR) VALUE(%SST(&LST_DATA 21 6))
CHGVAR VAR(&STATUS) VALUE(%SST(&LST_DATA 43 10))
CHGVAR VAR(&JOBTYPE) VALUE(%SST(&LST_DATA 53 1))
CHGVAR VAR(&SUBTYPE) VALUE(%SST(&LST_DATA 54 1))
/* for status */
CHGVAR VAR(&WRKSTS ) VALUE(%SST(&LST_DATA 81 4))
/* for subsystem */
CHGVAR VAR(&SBSSYS ) VALUE(%SST(&LST_DATA 101 20))
/* for msgrply */
CHGVAR VAR(&MSGRPLY) VALUE(%SST(&LST_DATA 137 1))
/* for current user */
CHGVAR VAR(&CURUSR ) VALUE(%SST(&LST_DATA 157 10))
IF (&WRKSTS *EQ 'MSGW' *AND &MSGRPLY *EQ '1') DO
CHGVAR &MSGTEXT ('* Job' *BCAT +
&JOBNBR *TCAT '/' *CAT +
&USER *TCAT '/' *CAT +
&JOBNAME *BCAT 'status is' *BCAT +
&WRKSTS *TCAT '.')
SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) +
MSGDTA(&MSGTEXT) TOMSGQ(*SYSOPR)
EndDo
CHGVAR VAR(&LST_COUNT) VALUE(&LST_COUNT + 1)
CHGVAR VAR(%BIN(&LST_POSBIN)) +
VALUE(%BIN(&LST_POSBIN) + &LST_LEN)
GOTO CMDLBL(LST_LOOP)
LST_END:
DLTUSRSPC USRSPC(&USP_LIB/&USP_NAME)
ENDSUBR
EndPgm:
EndPgm
File : QCLSRC
Member: CHKBCHJOB
Type : CLP
Usage : CRTCLPGM CHKBCHJOB
Insert your batch job which need to be monitored to CHKBCHJOBP
SBMJOB CMD(CALL CHKBCHJOB) JOB(CHKBCHJOB)
PGM
/*-- Global error monitoring: --------------------------------------*/
MonMsg CPF0000 *N GoTo Error
Loop:
Call ChkBchJobC
DlyJob 300
Goto Loop
Return:
Return
/*-- Error handling: -----------------------------------------------*/
Error:
Call QMHMOVPM ( ' ' +
'*DIAG' +
x'00000001' +
'*PGMBDY' +
x'00000001' +
x'0000000800000000' +
)
Call QMHRSNEM ( ' ' +
x'0000000800000000' +
)
EndPgm:
EndPgm
2017-11-21 Check Message Queue Manager started or not
Check Message Queue Manager started or not
File : QCLSRC
Member: CHKMQM
Type : CLLE
Usage : CrtCLMod Module( ChkMqm )
CrtPgm Pgm( ChkMqm ) BndSrvPgm((QMQM/LIBMQM))
/*-------------------------------------------------------------------*/
/* */
/* Program . . : CHKMQM */
/* Description : Check MQM Status */
/* Author . . : Vengoal Chang */
/* Published . : AS400ePaper */
/* Date . . . : November 21, 2017 */
/* */
/* Program function: CHKMQM command processing program */
/* */
/* */
/* Programmer's notes: */
/* */
/* Compile options: */
/* CrtCLMod Module( ChkMqm ) */
/* CrtPgm Pgm( ChkMqm ) */
/* BndSrvPgm((QMQM/LIBMQM)) */
/*-------------------------------------------------------------------*/
/* */
/* Exceptions monitored : */
/* MQCONN MQRC_Q_MGR_STOPPING */
/* MQRC_Q_MGR_QUIESCING */
/* MQRC_Q_MGR_NOT_AVAILABLE */
/* MQRC_STORAGE_NOT_AVAILABLE */
/* */
/*-------------------------------------------------------------------*/
Pgm ( &MQMName &RCChar)
Dcl &MQMName *CHAR 48
Dcl &RCChar *Char 10
/* Define local variables */
Dcl &HCONN *CHAR 4 X'00000000'
Dcl &CCODE *CHAR 4 X'00000000'
Dcl &REASON *CHAR 4 X'00000000'
Dcl &NOTAVAIL *CHAR 4 X'0000080B'
Dcl &STOPPING *CHAR 4 X'00000872'
Dcl &QUIESCING *CHAR 4 X'00000871'
Dcl &NOSTORAGE *CHAR 4 X'00000817'
Dcl &UNKNOWN *CHAR 4 X'0000080A'
Dcl &MsgDta *Char 256
Dcl &Rc *Dec (10 0)
/*-- Global error monitoring: --------------------------------------*/
MonMsg (CPF0000 MCH3601) *N GoTo Error
AddLibLe QMQM
MonMsg CPF0000
/******************************************************/
/* Connect to queue manager */
/******************************************************/
CallPrc 'MQCONN' (&MQMName &Hconn &Ccode &Reason)
If (%bin(&Ccode) *ne 0) Do
/*************************************************/
/* MQCONN failed */
/*************************************************/
ChgVar &Rc %Bin(&Reason)
ChgVar &RcChar &Rc
Select
When (&Reason = &STOPPING) Do
ChgVar &MsgDta ('Qmgr' *bcat &MQMName *Bcat +
'stopping, RC =' *bcat &RcChar)
EndDo
When (&Reason = &NOTAVAIL) Do
ChgVar &MsgDta ('Qmgr' *bcat &MQMName *Bcat +
'not available, RC =' *bcat &RcChar)
EndDo
When (&Reason = &QUIESCING) Do
ChgVar &MsgDta ('Qmgr' *bcat &MQMName *Bcat +
'quiescing, RC =' *bcat &RcChar)
EndDo
When (&Reason = &NOSTORAGE) Do
ChgVar &MsgDta ('Qmgr' *bcat &MQMName *Bcat +
'nostorage, RC =' *bcat &RcChar)
EndDo
When (&Reason = &UNKNOWN) Do
ChgVar &MsgDta ('Qmgr' *bcat &MQMName *Bcat +
'unknown, RC =' *bcat &RcChar)
EndDo
Otherwise Do
ChgVar &MsgDta ('Qmgr' *bcat &MQMName *Bcat +
'conn error, RC =' *bcat &RcChar)
EndDo
EndSelect
SndPgmMsg MsgId(CPF9898) MsgF(QCPFMSG) +
MsgDta(&MsgDta) ToPgmQ(*Ext) MsgType(*Info)
Goto Return
ENDDO
ChgVar &MsgDta ('Qmgr' *bcat &MQMName *Bcat +
'started')
SndPgmMsg MsgId(CPF9898) MsgF(QCPFMSG) +
MsgDta(&MsgDta) ToPgmQ(*EXT) MsgType(*INFO)
/******************************************************/
/* MQCONN worked so disonnect */
/******************************************************/
CallPrc 'MQDISC' (&Hconn &Ccode &Reason)
Return:
Return
/*-- Error handling: -----------------------------------------------*/
Error:
Call QMHMOVPM ( ' ' +
'*DIAG' +
x'00000001' +
'*PGMBDY' +
x'00000001' +
x'0000000800000000' +
)
Call QMHRSNEM ( ' ' +
x'0000000800000000' +
)
EndPgm:
EndPgm
File : QCMDSRC
Member: CHKMQM
Type : CMD
Usage : CrtCmd Cmd( CHKMQM )
Pgm( CHKMQM )
SrcFile( QCMDSRC )
Allow( *IPGM *BPGM )
/*-------------------------------------------------------------------*/
/* */
/* Compile options: */
/* */
/* CrtCmd Cmd( CHKMQM ) */
/* Pgm( CHKMQM ) */
/* SrcMbr( CHKMQM ) */
/* Allow( *IPGM *BPGM ) */
/* */
/*-------------------------------------------------------------------*/
Cmd Prompt( 'Check MQ Queue Manager')
Parm Kwd(MQMNAME) Type(*CHAR) Len(48) Min(1) +
Prompt('Message Queue Manager name')
Parm Kwd(RC) Type(*CHAR) Len(10) +
RtnVal(*Yes) +
Prompt('Return code')
File : QCLSRC
Member: CHKMQMTSTC
Type : CLP
Usage : CRTCLPGM CHKMQMTSTC
PGM
DCL &MQMNAME *CHAR 48
DCL &RC *CHAR 10
/*-- Global error monitoring: --------------------------------------*/
MonMsg CPF0000 *N GoTo Error
CHGVAR &MQMNAME 'TEST'
CHKMQM MQMNAME(&MQMNAME) RC(&RC)
If (&RC *NE ' ') Do
DmpClPgm
/* MQM got Exception */
/* do exception process */
EndDo
CHGVAR &MQMNAME 'TEST1'
CHKMQM MQMNAME(&MQMNAME) RC(&RC)
If (&RC *NE ' ') Do
DmpClPgm
/* MQM got Exception */
/* do exception process */
EndDo
Return:
RCLACTGRP ACTGRP(*ELIGIBLE)
Return
/*-- Error handling: -----------------------------------------------*/
Error:
RCLACTGRP ACTGRP(*ELIGIBLE)
Call QMHMOVPM ( ' ' +
'*DIAG' +
x'00000001' +
'*PGMBDY' +
x'00000001' +
x'0000000800000000' +
)
Call QMHRSNEM ( ' ' +
x'0000000800000000' +
)
EndPgm:
EndPgm
2016-04-06 擷取系統時間至微秒單位(Get system timesatmp with a precision in microseconds by API QWCCVTDT)
擷取系統時間至微秒單位(Get system timesatmp with a precision in microseconds by API QWCCVTDT)
範例含 CLP, RPGLE, COBOL。
File : QCLSRC
Member: GETSYSTIMC
Type : CLP
Usage : CRTCLPGM PGM(GETSYSTIMC)
PGM
/* For Convert Date & Time... */
dcl &CDT_I_FORM *char 10 value( '*CURRENT' )
dcl &CDT_I_VAR *char 8
dcl &CDT_O_FORM *char 10 value( '*YYMD' )
dcl &CDT_O_VAR *char 20
dcl &CDT_I_TZ *char 10 value( '*SYS' )
dcl &CDT_O_TZ *char 10 value( '*SYS' )
dcl &CDT_O_TZi *char 111 value( ' ' )
dcl &CDT_O_TZl *int value( 0 )
dcl &CDT_O_Pi *char 1 value( '1' )
/* And we'll need to specify an errcode receiver at one point... */
dcl &ERRCODE *char 116 value( x'00000074' )
dcl &ERRLEN *int value( 0 )
call QWCCVTDT ( +
&CDT_I_FORM +
&CDT_I_VAR +
&CDT_O_FORM +
&CDT_O_VAR +
&ERRCODE +
&CDT_I_TZ +
&CDT_O_TZ +
&CDT_O_TZi +
&CDT_O_TZl +
&CDT_O_Pi +
)
SndPgmMsg MsgId(CPF9898) MsgF(*LIBL/QCPFMSG) +
MsgDta(&CDT_O_VAR)
Return
ENDPGM
File : QRPGLESRC
Member: GETSYSTIMR
Type : RPGLE
Usage : CRTBNDRPG PGM(GETSYSTIMR)
**-- API error data structure:
D ERRC0100 Ds Qualified
D BytPrv 10i 0 Inz( %Size( ERRC0100 ))
D BytAvl 10i 0
D MsgId 7a
D 1a
D MsgDta 128a
DOutputVar DS
D CurCentury 2
D CurYear 2
D CurMonth 2
D CurDay 2
D CurHour 2
D CurMinute 2
D CurSecond 2
D CurMicroSec 6
D TimeZoneInfL 10i 0
C Move *On *InLr
C Call 'QWCCVTDT'
C Parm '*CURRENT' InputFmt 10
C Parm InputVar 1
C Parm '*YYMD' OutputFmt 10
C Parm OutputVar
C Parm ERRC0100
C Parm InpTimeZone 10
C Parm '*SYS' OutTimeZone 10
C Parm TimeZineInf 1
C Parm 0 TimeZoneInfL
C Parm '1' PrcInd 1
C OutputVar dsply
File : QCBLLESRC
Member: GETSYSTIME
Type : COBOL
Usage : CRTCBLPGM PGM(GETSYSTIME)
IDENTIFICATION DIVISION.
PROGRAM-ID. SAMPLE07.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-AS400.
OBJECT-COMPUTER. IBM-AS400.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 DATES.
05 INPUT-DATE PIC X(10).
05 OUTPUT-DATE17 PIC X(17).
05 OUTPUT-DATE20 PIC X(20).
05 INPUT-DATE-FORMAT PIC X(10).
05 OUTPUT-DATE-FORMAT PIC X(10).
05 INPUT-TIME-ZONE PIC X(10) VALUE '*SYS'.
05 OUTPUT-TIME-ZONE PIC X(10) VALUE '*SYS'.
05 TIME-ZONE-INFO PIC X(10).
05 TIME-ZONE-INFO-LEN PIC S9(9) BINARY VALUE ZERO.
05 PRECISION-INDICATOR PIC X(01) VALUE '1'.
01 CURRENTTIME.
05 CUR-YEAR PIC X(04).
05 CUR-MONTH PIC X(02).
05 CUR-DAY PIC X(02).
05 CUR-HH PIC X(02).
05 CUR-MM PIC X(02).
05 CUR-SS PIC X(02).
05 CUR-MICROSECOND PIC X(06).
01 ERRPARM.
05 INPUT-L PIC S9(9) BINARY VALUE 116.
05 OUTPUT-L PIC S9(9) BINARY VALUE ZERO.
05 EXCEPTION-ID PIC X(7).
05 RESERVED PIC X(1).
05 EXCEPTION-DATA PIC X(100).
PROCEDURE DIVISION.
MAINLINE.
PERFORM GET-DATE-08
GOBACK.
GET-DATE-08.
MOVE SPACES TO EXCEPTION-ID.
MOVE "*CURRENT" TO INPUT-DATE-FORMAT.
MOVE "*YYMD " TO OUTPUT-DATE-FORMAT.
CALL "QWCCVTDT" USING INPUT-DATE-FORMAT ,
INPUT-DATE ,
OUTPUT-DATE-FORMAT,
CURRENTTIME ,
ERRPARM ,
INPUT-TIME-ZONE ,
OUTPUT-TIME-ZONE ,
TIME-ZONE-INFO ,
TIME-ZONE-INFO-LEN,
PRECISION-INDICATOR.
DISPLAY 'TIMESTAMP FROM COBOL: ' CURRENTTIME.
參照: Convert Date and Time Format (QWCCVTDT) API
星期三, 11月 08, 2023
2010-03-03 如何於 CLP 中將英文字轉換為大寫(uppercase)或小寫(lowercase)？(Command CVTCASE with Convert Case API QLGCNVCS)
如何於 CLP 中將英文字轉換為大寫(uppercase)或小寫(lowercase)？(Command CVTCASE with Convert Case API QLGCNVCS)
File : QCLSRC
Member: CVTCASE
Type : CLP
Usage : CRTCLPGM CVTCASE
/* =============================================================== */
/* = Command CvtCase CPP = */
/* = CvtCase CLP = */
/* = Paramater notes: = */
/* = VALUE : string to be converted = */
/* = TOVAR : CL var for converted data = */
/* = OPTION: convert option *UPPER or *LOWER = */
/* =============================================================== */
/* = Date : 2010/03/03 = */
/* = Author: Vengoal Chang = */
/* =============================================================== */
pgm (&InValue &OutToVar &InOption)
/*--------------------------------------------------------*/
/* declaration */
/*--------------------------------------------------------*/
dcl &InValue *char 4096
dcl &CvtText *char 4096
dcl &OutToVar *char 4096
dcl &OutValue *char 4096
dcl &InOption *char 6
dcl &InValueL *dec 5 0
dcl &OutToVarL *dec 5 0
dcl &LenC *char 2
dcl &ReqUpper *char 22
dcl &ReqLower *char 22
dcl &upper *lgl
dcl &CCSIDReq *char 4 x'00000001'
dcl &CCSIDInp *char 4 x'00000000'
dcl &Uppercase *char 4 x'00000000'
dcl &Lowercase *char 4 x'00000001'
dcl &Reserved *char 10 x'00000000000000000000'
/*----------------------------------------------*/
/* QLGCNVCS - Convert Case QlgConvertCase */
/*----------------------------------------------*/
dcl &DataLen *char 4 x'00000050'
dcl &ErrCde *char 4 x'00000000'
dcl &MsgId *char 7
dcl &MsgDta *char 256
dcl &Msgf *char 10
dcl &MsgfLib *char 10
dcl &MsgTxt *char 256
monmsg msgid(CPF0000 MCH0000) exec(goto Error)
/*--------------------------------------------------------*/
/* Setup Request Control Block */
/*--------------------------------------------------------*/
chgvar &ReqUpper (&CCSIDReq || +
&CCSIDInp || +
&Uppercase || +
&Reserved)
chgvar &ReqLower (&CCSIDReq || +
&CCSIDInp || +
&Lowercase || +
&Reserved)
chgvar &LenC %sst(&InValue 1 2)
chgvar &InValueL %bin(&LenC)
chgvar &LenC %sst(&OutToVar 1 2)
chgvar &OutToVarL %bin(&LenC)
chgvar %bin(&Datalen) &InValueL
If (&InValueL > &OutToVarL) +
chgvar %bin(&Datalen) &OutToVarL
chgvar &CvtText %sst(&InValue 3 &InValueL)
chgvar &OutValue ' '
/*----------------------------------------------*/
/* Convert to Upper */
/*----------------------------------------------*/
if (&InOption *EQ '*UPPER') do
Call Pgm(QLGCNVCS) +
parm(&ReqUpper +
&CvtText +
&OutValue +
&Datalen +
&ErrCde )
enddo
/*--------------------------------------------------------*/
/* Convert to lower case */
/*--------------------------------------------------------*/
else do
Call Pgm(QLGCNVCS) +
parm(&Reqlower +
&CvtText +
&OutValue +
&Datalen +
&ErrCde )
enddo
chgvar %sst(&OutToVar 3 &OutToVarL) &OutValue
Return
/* =============================================================== */
/* = Error routine = */
/* =============================================================== */
Error:
RcvMsg MsgType( *Excp ) +
MsgDta( &MsgDta ) +
MsgID( &MsgID ) +
MsgF( &MsgF ) +
MsgFLib( &MsgFLib )
MonMsg ( CPF0000 MCH0000 )
SndMsg:
SndPgmMsg MsgID( &MsgID ) +
MsgF( &MsgFLib/&MsgF ) +
MsgDta( &MsgDta ) +
MsgType( *Escape )
MonMsg ( CPF0000 MCH0000 )
/* =============================================================== */
/* = End of program = */
/* =============================================================== */
EndPgm
File : QMDSRC
Member: CVTCASE
Type : CMD
Usage : CRTCMD CMD(xxx/CvtCase)
PGM(*LIBL/CvtCase)
SRCFILE(xxx/QCMDSRC)
SRCMBR(CvtCase)
ALLOW(*BMOD *BPGM *IMOD *IPGM)
/* =============================================================== */
/* = Command....... CvtCase = */
/* = CPP........... CvtCaseC CLP = */
/* = Description... Convert string to upper or lower case = */
/* = = */
/* =============================================================== */
/* = To create: = */
/* = = */
/* = CRTCMD CMD(xxx/CvtCase) = */
/* = PGM(*LIBL/CvtCase) = */
/* = SRCFILE(xxx/QCMDSRC) = */
/* = SRCMBR(CvtCase) = */
/* = ALLOW(*BMOD *BPGM *IMOD *IPGM) = */
/* = = */
/* =============================================================== */
/* = Date : 2010/03/03 = */
/* = Author: Vengoal Chang = */
/* =============================================================== */
CMD PROMPT('Convert case to upper or lower')
PARM KWD(VALUE) TYPE(*CHAR) LEN(4096) MIN(1) +
EXPR(*YES) VARY(*YES *INT2) CASE(*MONO) +
PROMPT('Value')
PARM KWD(TOVAR) TYPE(*CHAR) LEN(1) RTNVAL(*YES) +
MIN(1) VARY(*YES *INT2) PROMPT('CL var +
for converted data')
PARM KWD(OPTION) TYPE(*CHAR) LEN(6) RSTD(*YES) +
DFT(*UPPER) VALUES(*UPPER *LOWER) +
PROMPT('Convert to')
File : QCLSRC
Member: CVTCASET
Type : CLP
Usage : CRTCLPGM PGM(*LIBL/CvtCaseT)
SRCFILE(xxx/QCLSRC)
SRCMBR(CvtCaseT)
CALL CvtCaseT
PGM
DCL &CVTTEXT *CHAR 20 'abc DeF Ghj'
DCL &OUTPUT *CHAR 20
CVTCASE VALUE(&CVTTEXT) TOVAR(&OUTPUT)
SNDPGMMSG MSG('String' *BCAT &CVTTEXT *BCAT +
'TO UPPER case:' *BCAT +
&OUTPUT) MSGTYPE(*COMP)
CVTCASE VALUE(&CVTTEXT) TOVAR(&OUTPUT) OPTION(*LOWER)
SNDPGMMSG MSG('String' *BCAT &CVTTEXT *BCAT +
'TO UPPER case:' *BCAT +
&OUTPUT) MSGTYPE(*COMP)
ENDPGM
2009-07-16 如何於 CL 中直接做字元與 16 進位字串間的轉換？(cvthc將字元轉換為 16 進位字串，cvtch將16 進位字串轉換為字元)
如何於 CL 中直接做字元與 16 進位字串間的轉換？(cvthc將字元轉換為 16 進位字串，cvtch將16 進位字串轉換為字元)
要於 CL 中直接做字元與 16 進位字串間的轉換，需要呼叫系統 API (cvthc:將字元轉換為 16 進位字串，cvtch:將16 進位字串轉換為字元)。
例如：
使用 cvthc 將 "AB" 轉換為 "C1C2"。
使用 cvtch 將 "C1C1" 轉換為 "AB"。
File : QCLSRC
Member: CVTHC1TO2
Type : CLLE
OS version: V5R4 以上
Usage : CRTCLMOD (xxx/CVTHC1TO2)
cvthc:將字元轉換為 16 進位字串
PGM (&SRCSTR &SRCLEN &TGTSTR)
DCL VAR(&SRCSTR) TYPE(*CHAR) LEN(256)
DCL VAR(&PSRCSTR) TYPE(*PTR) STG(*DEFINED) +
DEFVAR(&SRCSTR)
DCL VAR(&TGTSTR) TYPE(*CHAR) LEN(512)
DCL VAR(&PTGTSTR) TYPE(*PTR) STG(*DEFINED) +
DEFVAR(&TGTSTR)
DCL VAR(&SRCLEN) TYPE(*DEC) LEN(3 0)
DCL VAR(&TGTLEN) TYPE(*INT)
CHGVAR &TGTLEN (&SRCLEN * 2)
/* Convert char 'AB' to Hex String 'C1C2' */
CALLPRC PRC('cvthc') PARM(&PTGTSTR +
&PSRCSTR (&TGTLEN *BYVAL))
ENDPGM
File : QCMDSRC
Member: CVTHC1TO2
Type : CMD
OS version: V5R4 以上
Usage : CRTCMD CMD(xxx/CVTHC1TO2) PGM(xxx/CVTHC1TO2) ALLOW(*IPGM *BPGM)
/*================================================================*/
/* COMMAND CVTHC1TO2 */
/* TO COMPILE : */
/* CRTCMD CMD(XXX/CVTHC1TO2) PGM(XXX/CVTHC1TO2) + */
/* SRCFILE(XXX/QCMDSRC) */
/*================================================================*/
CVTHC1TO2: CMD PROMPT('CVT Char to HEX String (cvthc)')
PARM KWD(SRCSTR) TYPE(*CHAR) LEN(256) MIN(1) +
PROMPT('Source string')
PARM KWD(SRCLEN) TYPE(*DEC) LEN(3) MIN(1) +
EXPR(*YES) PROMPT('Source string length')
PARM KWD(TGTSTR) TYPE(*CHAR) LEN(512) +
RTNVAL(*YES) PROMPT('CL var for +
HEX output (512)')
File : QCLSRC
Member: CVTCH2TO1
Type : CLLE
OS version: V5R4 以上
Usage : CRTCLMOD (xxx/CVTCH2TO1)
CRTPGM PGM(xxxx/CVTCH2TO1) BNDDIR(QC2LE)
cvtch:將16 進位字串轉換為字元
PGM (&SRCSTR &SRCLEN &TGTSTR)
DCL VAR(&SRCSTR) TYPE(*CHAR) LEN(512) /* Hex STR */
DCL VAR(&PSRCSTR) TYPE(*PTR) STG(*DEFINED) +
DEFVAR(&SRCSTR)
DCL VAR(&TGTSTR) TYPE(*CHAR) LEN(256) /* Char STR*/
DCL VAR(&PTGTSTR) TYPE(*PTR) STG(*DEFINED) +
DEFVAR(&TGTSTR)
DCL VAR(&SRCLEN) TYPE(*DEC) LEN(3 0)
DCL VAR(&HEXSTRLEN) TYPE(*INT)
CHGVAR &HEXSTRLEN &SRCLEN
/* Convert Hex String 'C1C2' to char 'AB' */
CALLPRC PRC('cvtch') PARM(&PTGTSTR +
&PSRCSTR (&HEXSTRLEN *BYVAL))
ENDPGM
File : QCMDSRC
Member: CVTCH2TO1
Type : CMD
OS version: V5R4 以上
Usage : CRTCMD CMD(xxx/CVTCH2TO1) PGM(xxx/CVTCH2TO1) ALLOW(*IPGM *BPGM)
/*================================================================*/
/* COMMAND CVTCH2TO1 */
/* TO COMPILE : */
/* CRTCMD CMD(XXX/CVTCH2TO1) PGM(XXX/CVTCH2TO1) + */
/* SRCFILE(XXX/QCMDSRC) */
/*================================================================*/
/* USAGE SAMPLE in CLP: */
/*================================================================*/
CVTHC1TO2: CMD PROMPT('CVT Hex String to Char (cvtch)')
PARM KWD(SRCSTR) TYPE(*CHAR) LEN(512) MIN(1) +
PROMPT('Source string')
PARM KWD(SRCLEN) TYPE(*DEC) LEN(3) MIN(1) +
EXPR(*YES) PROMPT('Source string length')
PARM KWD(TGTSTR) TYPE(*CHAR) LEN(256) +
RTNVAL(*YES) PROMPT('CL var for +
Char output (256)')
File : QCLSRC
Member: CVTHEXCT
Type : CLLE
OS version: V5R4 以上
Usage : CRTBNDCL PGM(xxx/CVTHEXCT)
CALL CVTHEXCT
WRKJOB option 4, see last QPPGMDMP file
PGM
DCL VAR(&SRCSTR) TYPE(*CHAR) LEN(256)
DCL VAR(&TGTSTR) TYPE(*CHAR) LEN(512)
DCL VAR(&SRCLEN) TYPE(*INT)
CVThc1To2 SRCSTR('ABCDEFGHIJK') SRCLEN(11) +
TGTSTR(&TGTSTR)
CVTch2TO1 SRCSTR(&TGTSTR ) SRCLEN(22) +
TGTSTR(&SRCSTR)
dmpclpgm
ENDPGM
2008-07-01 如何於 CLP 中以 Host name 取得主機的 IP 或以 IP 取得主機的 Host name？(Command GETHOSTGet Host by Name(gethostbyname) & Get Host by Address(gethostbyaddr))
如何於 CLP 中以 Host name 取得主機的 IP 或以 IP 取得主機的 Host name？(Command GETHOSTGet Host by Name(gethostbyname) & Get Host by Address(gethostbyaddr))
File : QRPGLESRC
Member: GETHOST
Type : RPGLE
Usage : CRTBNDRPG PGM(GETHOST)
**
** To compile:
** CRTBNDRPG PGM(xxxx) SRCFILE(xxxx/xxxx) DFTACTGRP(*NO) +
** ACTGRP(*CALLER)
** (actually, activation group can be whatever you prefer)
**
H DEBUG OPTION(*SRCSTMT:*NODEBUGIO) DFTACTGRP(*NO) ACTGRP(*CALLER)
** -------------------------------------------------------------------
D* The "internet" address family.
** -------------------------------------------------------------------
D AF_INET C CONST(2)
** -------------------------------------------------------------------
D INet_Addr PR 10U 0 ExtProc('inet_addr')
D char_addr 16A
** -------------------------------------------------------------------
D inet_ntoa PR * ExtProc('inet_ntoa')
D ulong_addr 10U 0 VALUE
** -------------------------------------------------------------------
D* any address availabl
D INADDR_ANY C CONST(0)
D* broadcast
D INADDR_BRO C CONST(4294967295)
D* loopback/localhost
D INADDR_LOO C CONST(2130706433)
D* no address exists
D INADDR_NON C CONST(4294967295)
** -------------------------------------------------------------------
D GetHostNam PR * extProc('gethostbyname')
D HostName 256A
** -------------------------------------------------------------------
** gethostbyaddr()--Get Host Information for IP Address
** -------------------------------------------------------------------
D GetHostAdr PR * ExtProc('gethostbyaddr')
D IP_Address 10U 0
D Addr_Len 10I 0 VALUE
D Addr_Fam 10I 0 VALUE
** -------------------------------------------------------------------
** Host Database Entry (for DNS lookups, etc)
** -------------------------------------------------------------------
D p_hostent S *
D hostent DS Based(p_hostent)
D h_name *
D h_aliases *
D h_addrtype 5I 0
D h_length 5I 0
D h_addrlist *
D p_h_addr S * Based(h_addrlist)
D h_addr S 10U 0 Based(p_h_addr)
D*** internal "work" variables. (not part of /COPY file)
D wkInput S 256A
D wkIP S 10U 0
D wkLen S 10I 0
D p_Name S * INZ(*NULL)
D wkName S 256A BASED(p_name)
C****************************************************************
C* Parameters:
C*
C* RetType: May be *NAME or *ADDR. If *NAME is given,
C* we'll return a domain name. If *ADDR we'll return an
C* IP Address.
C*
C* Input: Host or IP address to lookup. IP addresses should
C* be given in x.x.x.x format.
C*
C* Output: Resulting IP address, host name or error code.
C* Error codes are: *TYPE = invalid "RetType" parameter.
C* *BLANK = Input cant be blank
C* *FAIL = Lookup failed for this host.
C****************************************************************
C *entry plist
c parm RetType 5
c parm Input 256
c parm Output 256
C* If we werent given enough parms, just end this program now...
C* (we'll seton LR, even) We can't return an error since we
c* don't have an output parm to return it in (ack!)
c if %parms < 3
c eval *inlr = *on
c return
c endif
C* Did we have a valid return type?
c if RetType <> '*NAME'
c and RetType <> '*ADDR'
c eval Output = '*TYPE'
c Return
c endif
C* Was some input given?
C if Input = *blanks
c eval Output = '*BLANK'
c Return
c endif
C* were we given an IP address or a name?
c eval wkInput = %trim(Input) + x'00'
c eval wkIP = inet_addr(wkInput)
C* An address was requested... and the input was already
C* an address... return the input directly.
c if RetType = '*ADDR'
c and wkIP <> INADDR_NON
c eval Output = %trim(Input)
c Return
c endif
C* Call the OS/400 resolver routines to get the information that
C* we require. (It will check the hosts table first, then try DNS)
c if wkIP = INADDR_NON
c eval p_hostent = gethostnam(wkInput)
c else
c eval p_hostent = gethostadr(wkIP:4:AF_INET)
c endif
c if p_hostent = *NULL
c eval Output = '*FAIL'
c return
c endif
C* if we're returning an address, we'll need to use inet_ntoa
C* to convert it back to dotted-decimal x.x.x.x format.
C*
c if RetType = '*ADDR'
c eval p_name = inet_ntoa(h_addr)
c if p_name = *NULL
c eval Output = '*FAIL'
c else
c x'00' scan wkName wkLen
c eval Output = %subst(wkName:1:wkLen-1)
c endif
c return
c endif
C* the hostent structure contains a pointer to the requested
C* domain name... we'll need to base a variable on that pointer,
C* and then convert it from the "C" format for strings to a
C* fixed-length RPG string
c if h_name = *NULL
c eval Output = '*FAIL'
c return
c endif
c eval p_name = h_name
c x'00' scan wkName wkLen
c eval Output = %subst(wkName:1:wkLen-1)
c return
File : QCMDSRC
Member: GETHOST
Type : CMD
Usage : CRTCMD CMD(GETHOST) PGM(GETHOST) ALLOW(*IPGM *BPGM)
/* COMMAND GETHOST */
/* TO COMPILE : */
/* CRTCMD CMD(XXX/GETHOST) PGM(XXX/GETHOST ) + */
/* SRCFILE(XXX/QCMDSRC) */
/*================================================================*/
/* USAGE SAMPLE in CLP: */
/* GETHOST RETTYPE(*ADDR) INPUT(&HOSTNAME) OUTPUT(&HOSTIP) */
/* GETHOST RETTYPE(*NAME) INPUT(&HOSTIP) OUTPUT(&HOSTNAME) */
/* */
/* OUTPUT Resulting IP address, host name or error code. */
/* Error codes are: *TYPE = invalid "RetType" parameter */
/* *BLANK = Input cant be blank */
/* *FAIL = Lookup failed for this host */
/*================================================================*/
GETHOST: CMD PROMPT('Get Host by Name & by Address')
PARM KWD(RETTYPE) TYPE(*CHAR) LEN(5) RSTD(*YES) +
VALUES(*ADDR *NAME) MIN(1) PROMPT('Return +
type')
PARM KWD(INPUT) TYPE(*CHAR) LEN(256) MIN(0) +
EXPR(*YES) PROMPT('Input Host name or +
address')
PARM KWD(OUTPUT) TYPE(*CHAR) LEN(256) +
RTNVAL(*YES) PROMPT('Output Host name or +
address')
File : QCLSRC
Member: GETHOSTC
Type : CLP
Usage : CRTCLPGM GETHOSTC
執行 CALL RTVSQLINFC 後，會產生 QPPGMDMP 報表，檢視 QPPGMDMP 報表，
PGM
DCL &INPUT *CHAR 256
DCL &IPOUTPUT *CHAR 256
DCL &NMOUTPUT *CHAR 256
/* 以主機名稱取 IP 位址 */
GETHOST RETTYPE(*ADDR) INPUT('tw.yahoo.com') +
OUTPUT(&IPOUTPUT)
/* 以 IP 位址取主機名稱 */
GETHOST RETTYPE(*NAME) INPUT(&IPOUTPUT) +
OUTPUT(&NMOUTPUT)
DMPCLPGM
ENDPGM
部分報表輸出範例：
Display Spooled File
File . . . . . : QPPGMDMP Page/Line 1/24
Control . . . . . Columns 1 - 78
Find . . . . . .
*...+....1....+....2....+....3....+....4....+....5....+....6....+....7....+...
Variable Type Length Value
*...+....1....+....2....+
&IPOUTPUT *CHAR 256 '202.43.195.52 '
+26 ' '
+51 ' '
+76 ' '
+101 ' '
+126 ' '
+151 ' '
+176 ' '
+201 ' '
+226 ' '
+251 ' '
&NMOUTPUT *CHAR 256 'vip1.tw.tpe.yahoo.com '
+26 ' '
+51 ' '
星期一, 11月 06, 2023
2003-05-13 如何免手動開關機設定 ASP 硬碟儲存區的臨界值(Threshold Value) (Command DSPASP, CHGASP)?
如何免手動開關機設定 ASP 硬碟儲存區的臨界值(Threshold Value) ?
AS/400(iSeries)的硬碟儲存區是將許多實體的硬碟（例如 10 顆 36G 的硬碟組合成
一個邏輯磁碟區。）組合而成一個 ASP。系統將之視為與記憶體一體，當記憶體不夠用
時，系統會自動將硬碟區視為記憶體的一部份，已增加系統整體效能，由於有如此功能，
為了防止硬碟空間不足，所以需要設定臨界值來通知相關人員採取適當措施（增加硬碟），
但是要更改這個臨界值，需要手動開機設定，步驟較煩瑣，所以在此介紹利用 System API
來完成這項工作。
此工具可適用於 OS/400 V4R4以後，且須具有 *ALLOBJ 或 *SERVICE 特殊權限者才能執行。
File : QCLSRC
Member: DSPASPC
Type : CLP
Usage : CRTCLPGM DSPASPC
PGM
/* ***************************************************************** */
/* This job uses API QYASPOL to determine the current ASP Threshold. */
/* If this is being run Interactively, the details will be displayed */
/* on the users screen, prior to being written to file ASPTHRESH2, */
/* via Query ASPTHRESH. */
/* */
/* */
/* ***************************************************************** */
/* API parameters */
DCL VAR(&RCVR) TYPE(*CHAR) LEN(116)
DCL VAR(&LEN) TYPE(*CHAR) LEN(4)
DCL VAR(&LIST) TYPE(*CHAR) LEN(80)
DCL VAR(&NUMR) TYPE(*CHAR) LEN(4)
DCL VAR(&NUMF) TYPE(*CHAR) LEN(4)
DCL VAR(&FLTR) TYPE(*CHAR) LEN(16)
DCL VAR(&FMT) TYPE(*CHAR) LEN(8) VALUE('YASP0200')
DCL VAR(&ERR) TYPE(*CHAR) LEN(80)
DCL VAR(&FSIZE) TYPE(*CHAR) LEN(4)
DCL VAR(&FKEY) TYPE(*CHAR) LEN(4)
DCL VAR(&FFDSIZE) TYPE(*CHAR) LEN(4)
DCL VAR(&FDATA) TYPE(*CHAR) LEN(4)
/* Terminal Id */
DCL VAR(&TERMINAL) TYPE(*CHAR) LEN(10)
DCL VAR(&TYPE) TYPE(*CHAR) LEN(1)
/* ASP No */
DCL VAR(&APIASPNO) TYPE(*DEC) LEN(2 0)
DCL VAR(&ASPNO) TYPE(*CHAR) LEN(2)
/* ASP Threshold */
DCL VAR(&APIASPTHLD) TYPE(*DEC) LEN(2 0)
DCL VAR(&ASPTHLD) TYPE(*CHAR) LEN(2)
/* ASP %used */
DCL VAR(&APIASPUSE) TYPE(*CHAR) LEN(5)
DCL VAR(&PERUSED) TYPE(*DEC) LEN(5 2)
/* ASP Total */
DCL VAR(&APIASPTOT) TYPE(*DEC) LEN(11 0)
DCL VAR(&ASPTOT) TYPE(*CHAR) LEN(11)
/* ASP Available */
DCL VAR(&APIASPAVL) TYPE(*DEC) LEN(11 0)
RTVJOBA JOB(&TERMINAL) TYPE(&TYPE)
CREATEFILE: CRTPF FILE(QGPL/ASPTHRESH) RCDLEN(132)
MONMSG MSGID(CPF0000) EXEC(CLRPFM +
FILE(QGPL/ASPTHRESH))
CRTDTAARA: CRTDTAARA DTAARA(QGPL/ASPTHRESH) TYPE(*CHAR) LEN(2) +
TEXT('ASP Threshold')
MONMSG MSGID(CPF0000) EXEC(CHGDTAARA +
DTAARA(QGPL/ASPTHRESH) VALUE(' '))
CHGVAR VAR(%BIN(&FSIZE 1 4)) VALUE(16)
CHGVAR VAR(%BIN(&FKEY 1 4)) VALUE(1)
CHGVAR VAR(%BIN(&FFDSIZE 1 4)) VALUE(4)
CHGVAR VAR(%BIN(&FDATA 1 4)) VALUE(-1)
CHGVAR VAR(&FLTR) VALUE(&FSIZE *CAT &FKEY *CAT +
&FFDSIZE *CAT &FDATA)
CHGVAR VAR(%BIN(&ERR 1 4)) VALUE(80)
CHGVAR VAR(%BIN(&ERR 5 4)) VALUE(0)
CHGVAR VAR(%SST(&ERR 9 72)) VALUE(' ')
CHGVAR VAR(%BIN(&LEN 1 4)) VALUE(116)
CHGVAR VAR(%BIN(&NUMF 1 4)) VALUE(1)
CHGVAR VAR(%BIN(&NUMR 1 4)) VALUE(1)
/* Call API QYASPOL */
CALL PGM(QGY/QYASPOL) PARM(&RCVR &LEN &LIST &NUMR +
&NUMF &FLTR &FMT &ERR)
/* Parse info received from API */
CHGVAR VAR(&APIASPNO) VALUE(%BIN(&RCVR 3 2))
CHGVAR VAR(&APIASPTOT) VALUE(%BIN(&RCVR 9 4))
CHGVAR VAR(&APIASPAVL) VALUE(%BIN(&RCVR 13 4))
CHGVAR VAR(&APIASPTHLD) VALUE(%bin(&RCVR 63 2))
/* Calculate ASP %used */
CHGVAR VAR(&PERUSED) VALUE(100 - ((&APIASPAVL / +
&APIASPTOT) * 100))
/* Move *DEC to *CHAR fields */
CHGVAR VAR(&APIASPUSE) VALUE(&PERUSED)
CHGVAR VAR(&ASPTOT) VALUE(&APIASPTOT)
CHGVAR VAR(&ASPNO) VALUE(&APIASPNO)
CHGVAR VAR(&ASPTHLD) VALUE(&APIASPTHLD)
IF COND(&TYPE *EQ '0') THEN(GOTO CMDLBL(BATCH))
SNDBRKMSG MSG('ASP No: ' *CAT &ASPNO *CAT ' ASP +
%Threshold: ' *CAT &ASPTHLD *CAT ' +
ASP %Used: ' *CAT &APIASPUSE) +
TOMSGQ(&TERMINAL)
batch:
/* Set up file ASPTHRESH2, containing ASP Threshold% */
CHGDTAARA DTAARA(QGPL/ASPTHRESH) VALUE(&ASPTHLD)
DSPDTAARA DTAARA(QGPL/ASPTHRESH) OUTPUT(*PRINT)
CPYSPLF FILE(QPDSPDTA) TOFILE(QGPL/ASPTHRESH) +
SPLNBR(*LAST) MBROPT(*REPLACE)
RUNQRY: RUNQRY QRYFILE((ASPTHRESH))
ENDPGM
File : QCMDSRC
Member: DSPASP
Type : CMD
Usage : CRTCMD CMD(your-lib/DSPASP) PGM(your-lib/DSPASPC)
/* CPP DSPASPC */
CMD PROMPT('Display ASP Threshold')
File : QCLSRC
Member: CHGASPC
Type : CLP
Usage : CRTCLPGM CHGASPC
/**********************/
/* COMMAND CHGASP CPP */
/**********************/
PGM PARM(&ASP &THRESHOLD)
DCL VAR(&TERMINAL) TYPE(*CHAR) LEN(10)
DCL VAR(&ASP) TYPE(*CHAR) LEN(4)
DCL VAR(&THRESHOLD) TYPE(*CHAR) LEN(4)
DCL VAR(&COUNTER) TYPE(*DEC) LEN(1)
/* API parameters */
DCL VAR(&HANDLE) TYPE(*CHAR) LEN(8)
DCL VAR(&ERROR) TYPE(*CHAR) LEN(96)
DCL VAR(&BYTESPROV) TYPE(*CHAR) LEN(4)
DCL VAR(&BYTESAVAIL) TYPE(*CHAR) LEN(4)
DCL VAR(&EXCEPID) TYPE(*CHAR) LEN(7)
DCL VAR(&RESERVED) TYPE(*CHAR) LEN(1)
DCL VAR(&EXCEPDATA) TYPE(*CHAR) LEN(80)
DCL VAR(&OPKEY) TYPE(*CHAR) LEN(4)
DCL VAR(&OPVAR) TYPE(*CHAR) LEN(8)
DCL VAR(&OPVARLEN) TYPE(*CHAR) LEN(4)
DCL VAR(&FORMAT) TYPE(*CHAR) LEN(8) +
VALUE('DMOP0100')
DCL VAR(&ASPNO) TYPE(*CHAR) LEN(4)
DCL VAR(&ASPTHRESH) TYPE(*CHAR) LEN(4)
RTVJOBA JOB(&TERMINAL)
/* Start DASD Management Session - QYASSDMS API */
CHGVAR VAR(%BIN(&BYTESPROV 1 4)) VALUE(0)
CHGVAR VAR(&ERROR) VALUE(&BYTESPROV *CAT +
&BYTESAVAIL *CAT &EXCEPID *CAT &RESERVED +
*CAT &EXCEPDATA)
STARTSESS: CALL PGM(QYASSDMS) PARM(&HANDLE &ERROR)
MONMSG MSGID(CPFBA21) EXEC(DO) /* session already +
active */
CHGVAR VAR(&COUNTER) VALUE(&COUNTER + 1)
IF COND(&COUNTER *EQ 3) THEN(DO)
SNDBRKMSG MSG('CHGASP: DASD Management session still +
in use - job will now end') TOMSGQ(&TERMINAL)
GOTO CMDLBL(END)
ENDDO
SNDBRKMSG MSG('DASD Management session still in use - +
please wait for 6 mins to allow the +
previous session to end. Press enter to +
continue.') TOMSGQ(&TERMINAL)
DLYJOB DLY(360)
GOTO CMDLBL(STARTSESS)
ENDDO
/* Start DASD Management Operation - QYASSDMO API */
CHGVAR VAR(%BIN(&OPKEY 1 4)) VALUE(1)
CHGVAR VAR(%BIN(&aspno 1 4)) VALUE(&ASP)
CHGVAR VAR(%BIN(&ASPTHRESH 1 4)) VALUE(&THRESHOLD)
CHGVAR VAR(&OPVAR) VALUE(&ASPNO *CAT &ASPTHRESH)
CALL PGM(QYASSDMO) PARM(&HANDLE &OPKEY &OPVAR +
&OPVARLEN &FORMAT &ERROR)
/* End DASD Management Operation - QYASEDMO API */
CALL PGM(QYASEDMO) PARM(&HANDLE &ERROR)
MONMSG MSGID(CPFBA46) /* not active */
/* End DASD Management Session - QYASEDMS API */
CALL PGM(QYASEDMS) PARM(&HANDLE &ERROR)
DSPASP
MONMSG MSGID(CPF0000)
END: ENDPGM
File : QCMDSRC
Member: CHGASP
Type : CMD
Usage : CRTCMD CMD(your-lib/CHGASP) PGM (your-lib/CHGASPC)
/* CPP CHGASPC */
CMD PROMPT(' Set ASP Threshold ')
PARM KWD(ASP) TYPE(*CHAR) LEN(4) RSTD(*NO) +
DFT('1') CHOICE(' Eg ''1'' ') +
PROMPT('Enter ASP No: ''1'', ''2'' etc ')
PARM KWD(THRESHOLD) TYPE(*CHAR) LEN(4) RSTD(*NO) +
DFT('80') CHOICE(' Eg ''80'' ') +
PROMPT('Enter ASP Threshold')
2003-04-28 如何快速得知 IFS 目錄下的檔案大小？
如何快速得知 IFS 目錄下的檔案大小？
IBM 提供 V5R1 PTF SI05156 (superseded by SI05856) 及 V5R2 PTF SI05155
可以執行程式指定目錄及可以快速得知該目錄下檔案大小。
For the full report:
call qsrsrv parm("METRICS" '/')
To omit QNTC, QNETWARE, QLANSRV use the following.
call qsrsrv parm("METRICS" '/' "EPFS")
Or for a specific directory.
call qsrsrv parm("METRICS" '/mydir/mysubdir')
2003-03-25 如何讓系統操作人員將使用者設定為可以進入系統？(Command EBLUSRPRF Enabled User Profile)
如何讓系統操作人員將使用者設定為可以進入系統？(Command EBLUSRPRF Enabled User Profile)
當使用者的 SignOn 錯誤次數超過系統值 QMAXSIGN 的設定值時，若另一系統值
QMAXSGNACN設為 2 或 3 時，此時系統會將使用者狀態設為失效(disabled)。所已有需要讓系統操
作人員能將該失效使用者重新設定為有效，該使用者才可以進入系統。
但在開發此工具時，需要注意不得讓系統操作人員將具有 *ALLOBJ, *SECADM, *SERVICE
高級權限的人員，執行啟用（enabled）使用者的動作。
此程式需以 QSECOFR 使用者產生，並指定繼承程式擁有者的權限，系統操作人員執行此
程式時，才能間接取得 QSECOFR 的權限，更改使用者狀態，同時亦排除更改具有高級權
限的使用者。
這裡也提供 Command EBLUSRPRF 使系統操作人員便於使用。
File : QCLSRC
Member: EBLUSRPRF
Type : CLP
Usage : 此程式需以 QSECOFR 使用者產生
CRTCLPGM EBLUSRPRF USRPRF(*OWNER)
/* Program : EBLUSRPRF */
/* Version : 1.00 */
/* System : iSeries */
/* */
/* Compile the program with user QSECOFR */
/* and adopt authority : */
/* CHGPGM PGM(EBLUSRPRF) USRPRF(*OWNER) */
RSETUSRPRF: PGM PARM(&USRPRF &PASSWORD &PWDEXP &STATUS)
DCL VAR(&USRPRF) TYPE(*CHAR) LEN(10)
DCL VAR(&PASSWORD) TYPE(*CHAR) LEN(10)
DCL VAR(&PWDEXP) TYPE(*CHAR) LEN(10)
DCL VAR(&STATUS) TYPE(*CHAR) LEN(10)
DCL VAR(&CURUSER) TYPE(*CHAR) LEN(10)
DCL VAR(&GRPPRF) TYPE(*CHAR) LEN(10)
DCL VAR(&SPCAUT) TYPE(*CHAR) LEN(100)
DCL VAR(&ALLOBJ) TYPE(*LGL)
/* Parameters for QCLSCAN */
DCL VAR(&STRINGLEN) TYPE(*DEC) LEN(3 0) VALUE(100)
DCL VAR(&STRPOS) TYPE(*DEC) LEN(3 0) VALUE(1)
DCL VAR(&PATTERN) TYPE(*CHAR) LEN(10)
DCL VAR(&PATTERNLEN) TYPE(*DEC) LEN(3 0) VALUE(10)
DCL VAR(&TRANSLATE) TYPE(*CHAR) LEN(1) VALUE('1')
DCL VAR(&TRIM) TYPE(*CHAR) LEN(1) VALUE('1')
DCL VAR(&WILD) TYPE(*CHAR) LEN(1) VALUE(' ')
DCL VAR(&RESULT) TYPE(*DEC) LEN(3 0)
/* Check userprofile existence */
CHKOBJ OBJ(QSYS/&USRPRF) OBJTYPE(*USRPRF)
MONMSG MSGID(CPF0000) EXEC(DO)
SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('***** +
Error ****** invalid userprofile') +
TOPGMQ(*PRV) MSGTYPE(*ESCAPE)
ENDDO
/* new password same as userprofile */
IF COND(&PASSWORD *EQ *USRPRF) THEN(CHGVAR +
VAR(&PASSWORD) VALUE(&USRPRF))
/* retrieve current user */
RTVJOBA USER(&CURUSER)
/* Retrieve userprofile attributes */
RTVUSRPRF USRPRF(&USRPRF) SPCAUT(&SPCAUT) GRPPRF(&GRPPRF)
/* Check if the userprofile to be changed has */
/* *ALLOBJ authority. */
CHGVAR VAR(&PATTERN) VALUE('*ALLOBJ')
CALL PGM(QCLSCAN) PARM(&SPCAUT &STRINGLEN &STRPOS +
&PATTERN &PATTERNLEN &TRANSLATE &TRIM +
&WILD &RESULT)
/* String *ALLOBJ was found */
IF COND(&RESULT *NE 0) THEN(CHGVAR VAR(&ALLOBJ) +
VALUE('1'))
/* Do not allow to let userprofile QSECOFR, QSRV or */
/* any userprofile with *ALLOBJ authority or group */
/* profile QSECOFR to be changed. */
/* */
IF COND(&USRPRF = QSECOFR *OR &USRPRF = QSRV +
*OR &ALLOBJ *OR &GRPPRF *EQ QSECOFR) THEN(DO)
SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('*** +
Error *** not authorised to change this +
user profile') TOPGMQ(*PRV) MSGTYPE(*ESCAPE)
ENDDO
/* Before resetting the userprofile, let the current */
/* user authenticate by typing his own password. */
/* This prevents changing a userprofile on a terminal */
/* where the normal user went for dinner. */
?CHKPWD
MONMSG MSGID(CPF0000) EXEC(RETURN)
/* Change userprofile */
CHGUSRPRF USRPRF(&USRPRF) PASSWORD(&PASSWORD) +
PWDEXP(&PWDEXP) STATUS(&STATUS)
MONMSG MSGID(CPF0000) EXEC(DO)
SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('*** +
Error occurred *** see joblog') +
TOPGMQ(*PRV) MSGTYPE(*ESCAPE)
ENDDO
/* Log the changes into the History log */
SNDPGMMSG MSG('Userprofile ' *CAT &USRPRF *TCAT ' +
reset by user ' *CAT &CURUSER) TOMSGQ(QHST)
SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) +
MSGDTA('Userprofile ' *CAT &USRPRF *BCAT +
'reset') TOPGMQ(*PRV) MSGTYPE(*COMP)
END: ENDPGM
File : QCMDSRC
Member: RSETUSRPRF
Type : CMD
Usage : CRTCMD CMD(your-lib/EBLUSRPRF) PGM(your-lib/EBLUSRPRF)
/* Command : EBLUSRPRF */
/* Version : 1.00 */
/* System : iSeries */
/* Description : Enable userprofile and password */
RSETUSRPRF: CMD PROMPT('Enable userprofile and password')
PARM KWD(USRPRF) TYPE(*NAME) LEN(10) MIN(1) +
PROMPT('User profile')
PARM KWD(PASSWORD) TYPE(*CHAR) LEN(10) +
DFT(*USRPRF) SPCVAL((*USRPRF) (*SAME)) +
DSPINPUT(*PROMPT) PROMPT('User password')
PARM KWD(PWDEXP) TYPE(*CHAR) LEN(10) RSTD(*YES) +
DFT(*YES) VALUES(*SAME *NO *YES) +
PROMPT('Set password to expired')
PARM KWD(STATUS) TYPE(*CHAR) LEN(10) RSTD(*YES) +
DFT(*ENABLED) VALUES(*ENABLED *DISABLED +
*SAME) PROMPT('Status')
2003-03-12 如何於 CL 中轉換字串中每個英文單字的第一個字為大寫？
如何於 CL 中轉換字串中每個英文單字的第一個字為大寫？
File : QCLSRC
Member: CVTCASEC
Type : CLP
Usage : CRTCLPGM CVTCASEC
CALL CVTCASEC 'AS/400 IS VERY GOOD.'
pgm (&CvtText) /* Convert this text */
/*--------------------------------------------------------*/
/* declaration */
/*--------------------------------------------------------*/
dcl &CvtText *char 80
dcl &ReqUpper *char 22
dcl &ReqLower *char 22
dcl &Pos *dec 3 1
dcl &Posl *dec 3 0
dcl &Len *dec 3 0
dcl &upper *lgl
dcl &CCSIDReq *char 4 x'00000001'
dcl &CCSIDInp *char 4 x'00000000'
dcl &Uppercase *char 4 x'00000000'
dcl &Lowercase *char 4 x'00000001'
dcl &Reserved *char 10 x'00000000000000000000'
/*----------------------------------------------*/
/* QLGCNVCS - Convert Case QlgConvertCase */
/*----------------------------------------------*/
dcl &Input *char 80
dcl &Output *char 80
dcl &DataLen *char 4 x'00000050'
dcl &ErrCde *char 4 x'00000000'
/*--------------------------------------------------------*/
/* Setup Request Control Block */
/*--------------------------------------------------------*/
chgvar &ReqUpper (&CCSIDReq || +
&CCSIDInp || +
&Uppercase || +
&Reserved)
chgvar &ReqLower (&CCSIDReq || +
&CCSIDInp || +
&Lowercase || +
&Reserved)
chgvar &upper '1'
/*--------------------------------------------------------*/
/* Convert Upper (First letter), then lower case */
/*--------------------------------------------------------*/
loop:
if (&Pos *ge 80) goto endloop
/*----------------------------------------------*/
/* Convert to Lower */
/*----------------------------------------------*/
if (%sst(&CvtText &Pos 1) = ' ') do
if (*Not &Upper) do
chgvar &output ' '
chgvar %bin(&Datalen) &len
Call Pgm(QLGCNVCS) +
parm(&Reqlower +
&input +
&output +
&Datalen +
&ErrCde )
chgvar %sst(&CvtText &Posl &len) &Output
enddo
chgvar &upper '1'
chgvar &Pos (&Pos + 1)
enddo
/*----------------------------------------------*/
/* Convert to Upper */
/*----------------------------------------------*/
if (%sst(&CvtText &Pos 1) *ne ' ') do
if &upper do
chgvar &input %sst(&CvtText &Pos 1)
chgvar &output ' '
chgvar %bin(&Datalen) 1
Call Pgm(QLGCNVCS) +
parm(&ReqUpper +
&input +
&output +
&Datalen +
&ErrCde )
chgvar %sst(&CvtText &Pos 1) %sst(&Output 1 1)
chgvar &Pos (&Pos + 1)
chgvar &Posl &Pos
chgvar &upper '0'
chgvar &len 0
enddo
else do
chgvar &len (&len + 1)
chgvar %sst(&input &len 1) %sst(&CvtText &Pos 1)
chgvar &Pos (&Pos + 1)
enddo
enddo
goto loop
endloop:
SndPgmMsg Msg(&Cvttext) Msgtype(*Comp)
EndPgm
2003-02-19 如何於 CLP 中傳送著色的訊息？(Send colored message in CLP)
如何於 CLP 中傳送著色的訊息？(Send colored message in CLP)
File : QCLSRC
Member: SNDCOLMSGC
Type : CLP
Usage : CRTCLPGM SNDCOLMSGC
OS Version: All
/* TO COMPILE : */
/* */
/* CRTCLPGM PGM(XXX/SNDCOLMSG) SRCFILE(XXX/QCLSRC) */
SNDCOLMSG: PGM PARM(&MSG &COLOR &MSGTYPE)
DCL VAR(&MSG) TYPE(*CHAR) LEN(80)
DCL VAR(&COLOR) TYPE(*CHAR) LEN(1)
DCL VAR(&MSGTYPE) TYPE(*CHAR) LEN(10)
DCL VAR(&LASTBYTE) TYPE(*CHAR) LEN(1) VALUE(X'20')
DCL VAR(&TEXT) TYPE(*CHAR) LEN(82)
CHGVAR VAR(&TEXT) VALUE(&COLOR *CAT &MSG *TCAT +
&LASTBYTE)
SNDPGMMSG MSG(&TEXT) TOPGMQ(*EXT) MSGTYPE(&MSGTYPE)
SNDPGMMSG MSG(&TEXT) MSGTYPE(&MSGTYPE)
END: ENDPGM
此程式中有二個 SNDPGMMSG 指令，你可以選取一種顯示方式或二者。
二者顯示方式稍有不同，可以自行比較一下。
File : QCMDSRC
Member: SNDCOLMSG
Type : CMD
Usage : CRTCMD CMD(SNDCOLMSG) PGM(SNDCOLMSGC)
OS Version: All
/* Description : Send a colored message */
/* */
/* To compile : */
/* */
/* CRTCMD CMD(XXX/SNDCOLMSG) PGM(XXX/SNDCOLMSG) + */
/* SRCFILE(XXX/QCMDSRC) */
/* */
SNDCOLMSG: CMD PROMPT('Send colored message')
PARM KWD(MSG) TYPE(*CHAR) LEN(80) PROMPT('Message')
PARM KWD(COLOR) TYPE(*CHAR) LEN(1) RSTD(*YES) +
DFT(*GREEN) SPCVAL( +
(*GREEN X'20') +
(*GREEN_REVERSE X'21') +
(*WHITE X'22') +
(*WHITE_REVERSE X'23') +
(*GREEN_UNDERSCORE X'24') +
(*GREEN_UNDERSCORE_REVERSE X'25') +
(*WHITE_UNDERSCORE X'26') +
(*RED X'28') +
(*RED_REVERSE X'29') +
(*RED_BLINK X'2A') +
(*RED_REVERSE_BLINK X'2B') +
(*RED_UNDERSCORE X'2C') +
(*RED_UNDERSCORE_REVERSE X'2D') +
(*RED_UNDERSCORE_BLINK X'2E') +
(*TURQUOISE X'30') +
(*TURQUOISE_REVERSE X'31') +
(*YELLOW X'32') +
(*YELLOW_REVERSE X'33') +
(*TURQUOISE_UNDERSCORE X'34') +
(*TURQUOISE_UNDERSCORE_REVERSE X'35') +
(*YELLOW_UNDERSCORE X'36') +
(*PINK X'38') +
(*PINK_REVERSE X'39') +
(*BLUE X'3A') +
(*BLUE_REVERSE X'3B') +
(*PINK_UNDERSCORE X'3C') +
(*PINK_UNDERSCORE_REVERSE X'3D') +
(*BLUE_UNDERSCORE X'3E') +
) PROMPT('Color')
PARM KWD(MSGTYPE) TYPE(*CHAR) LEN(10) RSTD(*YES) +
DFT(*INFO) VALUES(*INFO *COMP) +
PROMPT('Message type')
執行範例：
SNDCOLMSG MSG('Hello World') COLOR(*PINK)
SNDCOLMSG MSG('Error') COLOR(*RED_REVERSE_BLINK)
2003-01-22 如何讓您的 ＲＰＧ 程式發出 beep 聲音？以提醒使用者某些工作已完成？
如何讓您的 ＲＰＧ 程式發出 beep 聲音？以提醒使用者某些工作已完成？
如何讓您的 ＲＰＧ 程式發出 beep 聲音？以提醒使用者某些工作已完成？
前期電子報以 RPG 為範例，本期以 CL 為範例。
因為會使用 CALLPRC 呼叫內建函數，所以此程式的原始型態需為 CLLE。
File : QCLSRC
Member: BEEPC
Type : CLLE
Version : V3R2 later
Usage : CRTBNDCL BEEPC
/* To compile : */
/* The source type must be "CLLE" (and not CLP). */
/* Compile with STRPDM option 14 or use the */
/* CRTBNDCL command. */
/* */
BEEP: PGM
DCL VAR(&RTNVALBIN) TYPE(*CHAR) LEN(4)
DCL VAR(&RTNVALDEC) TYPE(*DEC) LEN(5 0)
CALLPRC PRC('QsnBeep') PARM(X'00000000' X'00000000' +
X'00000000') RTNVAL(%BIN(&RTNVALBIN))
CHGVAR VAR(&RTNVALDEC) VALUE(%BIN(&RTNVALBIN))
IF COND(&RTNVALDEC *NE 0) THEN(SNDPGMMSG +
MSGID(CPF9898) MSGF(QCPFMSG) +
MSGDTA('error occurred') MSGTYPE(*ESCAPE))
END: ENDPGM
訂閱：
文章 (Atom)