2001-12-31 如何於 CL 中作日期運算？
CL 中並不提供日期運算函式，但可透過 CVTDAT 指令作日期格式轉換，
以下範例將 Job Date 轉換成 Julian number( 4 位年 + 3 位數字(1-366))，
加1，並將之轉換為日期，如果這是今年最後一天，日期無法轉換，請用次年的第一天。
File : QCLSRC
Member : CLDATEC
Type : CLP
PGM
DCL VAR(&TODAY) TYPE(*CHAR) LEN(6)
DCL VAR(&TOMORROW) TYPE(*CHAR) LEN(6)
DCL VAR(&WORKDATE) TYPE(*CHAR) LEN(7)
DCL VAR(&YEAR) TYPE(*DEC) LEN(4)
DCL VAR(&DAY) TYPE(*DEC) LEN(3)
RTVJOBA DATE(&TODAY)
CVTDAT DATE(&TODAY) TOVAR(&WORKDATE) FROMFMT(*JOB) +
TOFMT(*LONGJUL) TOSEP(*NONE)
/* Find tomorrow's date */
CHGVAR &DAY %SST(&WORKDATE 5 3)
CHGVAR &DAY (&DAY + 1)
CHGVAR %SST(&WORKDATE 5 3) &DAY
CVTDAT DATE(&WORKDATE) TOVAR(&TOMORROW) +
FROMFMT(*LONGJUL) TOFMT(*JOB) TOSEP(*NONE)
MONMSG CPF0555 EXEC(DO)
CHGVAR &YEAR %SST(&WORKDATE 1 4)
CHGVAR &YEAR (&YEAR + 1)
CHGVAR %SST(&WORKDATE 1 4) &YEAR
CHGVAR %SST(&WORKDATE 5 3) '001'
CVTDAT DATE(&WORKDATE) TOVAR(&TOMORROW) +
FROMFMT(*LONGJUL) TOFMT(*JOB) TOSEP(*NONE)
ENDDO
/* Tomorrow's date is now in &TOMORROW */
ENDPGM
星期三, 11月 01, 2023
2001-12-31 如何於 CL 中作日期運算？
2001-12-31 如何定時自動檢核 System ASP Storage 的使用百分比？
如何定時自動檢核 System ASP Storage 的使用百分比？
System ASP Storage 的使用百分比可以從執行指令 WRKSYSSTS 結果得知，
Work with System Status SYSTEM
12/31/01 08:42:10
% CPU used . . . . . . . : 4.9 Auxiliary storage:
% DB capability . . . . : .0 System ASP . . . . . . : 33.95 G
Elapsed time . . . . . . : 00:07:28 % system ASP used . . : 48.6081
Jobs in system . . . . . : 459 Total . . . . . . . . : 33.95 G
% perm addresses . . . . : .013 Current unprotect used : 1697 M
% temp addresses . . . . : .013 Maximum unprotect . . : 1759 M
Type changes (if allowed), press Enter.
System Pool Reserved Max -----DB----- ---Non-DB---
Pool Size (M) Size (M) Active Fault Pages Fault Pages
1 95.28 56.43 +++++ .0 .0 .4 .4
2 508.31 2.10 160 .0 .0 .0 .0
3 6.39 .00 5 .0 .0 .0 .0
4 30.00 .01 15 .0 .0 .1 .4
Bottom
Command
===>
F3=Exit F4=Prompt F5=Refresh F9=Retrieve F10=Restart
F11=Display transition data F12=Cancel F24=More keys
系統可藉由手動開機方式設定 System ASP Threshold 值，
當系統硬碟資源使用率達到設定值時，系統會自動送出一個訊息通知系統操作員，
系統硬碟資源使用率已達到設定值，此時系統操作員或系統管理者需要採取適當的
程序來將使用率下降，像是清除System Log或報表或某些過時的資料。
但這種做法比較被動，我們可以依據需求更改Threshold 值，並定時針測ASP使
用率而不用透過手動開機方式設定 System ASP Threshold 值，取得較彈性的管理方式。
File : QCLSRC
Member : THRESHOLDC
Type : CLP
PGM
DCL VAR(&FORMAT) TYPE(*CHAR) LEN(8) VALUE('SSTS0200')
DCL VAR(&LENFLD) TYPE(*DEC) LEN(4) VALUE(68)
DCL VAR(&SYSUSEC) TYPE(*CHAR) LEN(4)
DCL VAR(&SYSUSE) TYPE(*DEC) LEN(9 2)
DCL VAR(&SYSINFO) TYPE(*CHAR) LEN(68)
DCL VAR(&ERRCODE) TYPE(*CHAR) LEN(8) +
VALUE(X'0000000000000000')
DCL VAR(&RESETSY) TYPE(*CHAR) LEN(10) VALUE(*YES)
DCL VAR(&Q90PER) TYPE(*DEC) LEN(9 2) VALUE(900000)
PROCED1: CALL PGM(QWCRSSTS) PARM( &SYSINFO &LENFLD &FORMAT &RESETSY +
&ERRCODE )
MONMSG MSGID(CPF0000) +
EXEC(GOTO PROCED2)
CHGVAR &SYSUSEC VALUE(%SST(&SYSINFO 53 4))
CHGVAR &SYSUSE %BINARY(&SYSUSEC)
IF (&SYSUSE > &Q90PER) (DO)
SNDPGMMSG MSG('**SYSTEM OVER 90% ASP**') +
TOMSGQ(QSYSOPR) MSGTYPE(*INFO)
RETURN
ENDDO
SNDPGMMSG MSG('**SYSTEM UNDER 90% ASP**') +
TOMSGQ(QSYSOPR) MSGTYPE(*INFO)
RETURN
PROCED2: SNDPGMMSG MSG('GETTING ERROR ON SYS CALL') TOMSGQ(QSYSOPR) +
MSGTYPE(*INFO)
ENDPGM
參考資料 Retrieve System Status (QWCRSSTS) API
Retrieve System Status (QWCRSSTS) API
http://publib.boulder.ibm.com/pubs/html/as400/v5r1/ic2924/info/apis/qwcrssts.htm
2001-12-23 如何取得 AS/400 最近開機時間為何時？
如何取得 AS/400 最近開機時間為何時？
File : QCLSRC
Member : LASTIPLC
Type : CLP
藉由 QUSRJOBI API 檢核 System Job SCPF 的啟動時間，可以得知系統開機時間。
/* Program LASTIPLC */
PGM
DCL VAR(&DATA) TYPE(*CHAR) LEN(150)
DCL VAR(&BIN) TYPE(*CHAR) LEN(4) VALUE(X'00000096')
DCL VAR(&CEN) TYPE(*CHAR) LEN(1)
DCL VAR(&YY) TYPE(*CHAR) LEN(2)
DCL VAR(&MM) TYPE(*CHAR) LEN(2)
DCL VAR(&DD) TYPE(*CHAR) LEN(2)
DCL VAR(&HH) TYPE(*CHAR) LEN(2)
DCL VAR(&M) TYPE(*CHAR) LEN(2)
DCL VAR(&SS) TYPE(*CHAR) LEN(2)
DCL VAR(&FMT) TYPE(*CHAR) LEN(8) VALUE('JOBI0400')
DCL VAR(&JOB) TYPE(*CHAR) LEN(26) +
VALUE('SCPF QSYS 000000')
DCL VAR(&JOBI) TYPE(*CHAR) LEN(16)
CALL PGM(QUSRJOBI) PARM(&DATA &BIN &FMT &JOB &JOBI)
CHGVAR VAR(&CEN) VALUE(%SST(&DATA 63 1))
CHGVAR VAR(&YY) VALUE(%SST(&DATA 64 2))
CHGVAR VAR(&MM) VALUE(%SST(&DATA 66 2))
CHGVAR VAR(&DD) VALUE(%SST(&DATA 68 2))
CHGVAR VAR(&HH) VALUE(%SST(&DATA 70 2))
CHGVAR VAR(&M) VALUE(%SST(&DATA 72 2))
CHGVAR VAR(&SS) VALUE(%SST(&DATA 74 2))
SNDPGMMSG MSG('The system was last IPL''d on ' || &MM +
|| '/' || &DD || '/' || &YY || ' at ' || +
&HH || ':' || &M || ':' || &SS || '.')
END:
ENDPGM
2001-12-19 如何自動增加 DataBase Phyiscal File Size ?
如何自動增加 DataBase Phyiscal File Size ?
當使用者執行應用程式時，有時會遇到一個訊息"Record not added. Member FILENAME is full. (C I 9999)" ，
由於系統在產生資料庫檔案(Physical File)時，有參數 SIZE 預設值如下：
Member size: SIZE
Initial number of records . . 10000
Increment number of records . 1000
Maximum increments . . . . . . 3
您可在在產生資料庫檔案(Physical File)時，指定資料庫檔案(Physical File)的
初始筆數(Initial number of records)，
當資料筆數到達初始筆數時，系統會依增加筆數容量(Increment number of records)自動增加，
系統同時紀錄可自動增加的次數是否到達所指定的最大增加次數(Maximum increments)，
以預設值為例，預設資料筆數為 10000 筆，當資料到達 10000 筆時，系統會自動增加 1000 筆容量，
但自動增加的次數為 3 次，所以該資料庫檔案(Physical File)的最大容量為 13000 筆資料，當您的資料到達
13000 筆時，要再新增資料時系統就會發出"Record not added. Member FILENAME is full. (C I 9999)"訊息
，此時就需回覆此訊息 Cancel , Ignor , 0-9999
Cancel 取消
Ingore 忽略
0-9999 設定自動增加次數
當您回覆 Cancel 或 Ignore 時您的應用程式均無法繼續正常執行，要讓使用者繼續執行就必須回覆 0 - 9999
之間的值，以讓系統自動增加資料庫檔案(Physical File)的筆數。
當您回覆 Cancel 或 Ignore 時您亦可終止應用程式，並用 CHGPF 更改資料庫檔案(Physical File)的 SIZE 參數。
那要如何避免系統因為此種需擴大資料庫檔案(Physical File)的筆數而導致程式中斷的情形呢？
可使用系統自動回覆訊息功能，設定該訊息自動回覆如下：
下指令
WRKRPYLE 及 新增一個 message id CPA5305 自動回覆訊息
ADDRPYLE SEQNBR(100) MSGID(CPA5305) RPY(9999)
9999 為自動增加的次數，您可依需求設定一個適當值
使用此方法時，要注意若您的應用程式設計不當像新增資料時有無窮迴圈時，您的硬碟空間有被耗盡的可能，
而導致系統當機。
2001-12-15 工具: CHGSCDTIM 更改工作排程時間
工具: CHGSCDTIM 更改工作排程時間
The following source code was provided by Randy Gish .
It is the reader's responsibility to ensure that procedures and techniques
used from this code are accurate and appropriate for the user's installation.
No warranty is implied or expressed. Please back up your files before you run
a new procedure or program or make significant changes to disk files, and be
sure to test all procedures and programs before putting them into production.
CHGSCDTIM Command Source:
CMD PROMPT('Change Job Schedule Time')
PARM KWD(JOBNAM) TYPE(*NAME) LEN(10) MIN(1) +
PROMPT('Scheduled Job Name')
PARM KWD(INCREMENT) TYPE(*CHAR) LEN(6) MIN(1) +
PROMPT('Increment Time (HHMMSS)')
PARM KWD(CUTOFF) TYPE(*CHAR) LEN(6) +
PROMPT('Cutoff Time (HHMMSS)')
PARM KWD(RESET) TYPE(*CHAR) LEN(6) +
PROMPT('Reset Time (HHMMSS)')
PARM KWD(TIMVAL) TYPE(*CHAR) LEN(4) RSTD(*YES) +
DFT(*SCD) VALUES(*SCD *SYS) PROMPT('Time +
Value to Increment')
CHGSCDTIM Command Processing Program Source:
/* This program increments the scheduled time for a Job Schedule Entry. The */
/* increment, cutoff, and reset times should be passed as 'HHMMSS'. */
PGM PARM(&JOBSCDNAM &INCREMENT &CUTOFF &RESET &TIMVAL)
DCL VAR(&JOBSCDNAM) TYPE(*CHAR) LEN(10)
DCL VAR(&INCREMENT) TYPE(*CHAR) LEN(6)
DCL VAR(&CUTOFF) TYPE(*CHAR) LEN(6)
DCL VAR(&RESET) TYPE(*CHAR) LEN(6)
DCL VAR(&TIMVAL) TYPE(*CHAR) LEN(4)
DCL VAR(&USRSPC) TYPE(*CHAR) LEN(20) +
VALUE('CHGSCDTIM QTEMP ') /* USER +
SPACE NAME FOR APIS */
DCL VAR(&CNTHDL) TYPE(*CHAR) LEN(16) +
VALUE(' ') /* CONTINUATION +
HANDLE */
DCL VAR(&NUMENTB) TYPE(*CHAR) LEN(4) /* NUMBER +
OF ENTRIES FROM LIST JOB SCHEDULE ENTRIES +
IN BINARY FORM */
DCL VAR(&NUMENT) TYPE(*DEC) LEN(8 0) /* NUMBER +
OF ENTRIES FROM LIST JOB SCHEDULE ENTRIES +
IN DECIMAL FORM */
DCL VAR(&GENHDR) TYPE(*CHAR) LEN(140) /* GENERIC +
HEADER INFORMATION FROM THE USER SPACE */
DCL VAR(&LSTSTS) TYPE(*CHAR) LEN(1) /* STATUS OF +
THE LIST IN THE USER SPACE */
DCL VAR(&OFFSETB) TYPE(*CHAR) LEN(4) /* OFFSET +
TO THE LIST PORTION OF THE USER SPACE IN +
BINARY FORM */
DCL VAR(&STRPOSB) TYPE(*CHAR) LEN(4) /* STARTING +
POSITION IN THE USER SPACE IN BINARY FORM */
DCL VAR(&ELENB) TYPE(*CHAR) LEN(4) /* LIST JOB +
ENTRY LENGTH IN BINARY 4 FORM */
DCL VAR(&LENTRY) TYPE(*CHAR) LEN(1156) /* +
RETRIEVE AREA FOR LIST JOB SCHEDULE ENTRY */
DCL VAR(&INCHH) TYPE(*CHAR) LEN(2)
DCL VAR(&INCMM) TYPE(*CHAR) LEN(2)
DCL VAR(&INCSS) TYPE(*CHAR) LEN(2)
DCL VAR(&INCHH#) TYPE(*DEC) LEN(2 0)
DCL VAR(&INCMM#) TYPE(*DEC) LEN(2 0)
DCL VAR(&INCSS#) TYPE(*DEC) LEN(2 0)
DCL VAR(&SCDHH) TYPE(*CHAR) LEN(2)
DCL VAR(&SCDMM) TYPE(*CHAR) LEN(2)
DCL VAR(&SCDSS) TYPE(*CHAR) LEN(2)
DCL VAR(&SCDHH#) TYPE(*DEC) LEN(2 0)
DCL VAR(&SCDMM#) TYPE(*DEC) LEN(2 0)
DCL VAR(&SCDSS#) TYPE(*DEC) LEN(2 0)
DCL VAR(&SCDTIME) TYPE(*CHAR) LEN(6)
DCL VAR(&NEWHH#) TYPE(*DEC) LEN(3 0)
DCL VAR(&NEWMM#) TYPE(*DEC) LEN(3 0)
DCL VAR(&NEWSS#) TYPE(*DEC) LEN(3 0)
DCL VAR(&NEWTIME) TYPE(*CHAR) LEN(6)
DCL VAR(&SYSTIME) TYPE(*CHAR) LEN(6)
DCL VAR(&MSGID) TYPE(*CHAR) LEN(07)
DCL VAR(&MSGF) TYPE(*CHAR) LEN(10)
DCL VAR(&MSGL) TYPE(*CHAR) LEN(10)
DCL VAR(&MSGDTA) TYPE(*CHAR) LEN(132)
MONMSG MSGID(CPF0000 MCH0000) EXEC(GOTO CMDLBL(ERROR))
/* Delete the user space if it already exists. */
DLTUSRSPC USRSPC(QTEMP/CHGSCDTIM)
MONMSG MSGID(CPF0000)
/* Create the user space. The user space will be 256 bytes and */
/* will be initialized to blanks. */
CALL PGM(QUSCRTUS) PARM(&USRSPC 'CHGSCDTIM ' +
X'00000100' ' ' '*ALL ' 'TEMPORARY +
USER SPACE ')
MONMSG MSGID(CPF3C00) EXEC(GOTO CMDLBL(ERROR))
/* List the job schedule entry of the name specified. */
CALL PGM(QWCLSCDE) PARM(&USRSPC 'SCDL0200' +
&JOBSCDNAM &CNTHDL 0)
/* Retrieve the generic header from the user space. */
CALL PGM(QUSRTVUS) PARM(&USRSPC X'00000001' +
X'0000008C' &GENHDR)
MONMSG MSGID(CPF3C00) EXEC(GOTO CMDLBL(ERROR))
/* Get the information status for the list from the generic header. */
CHGVAR VAR(&LSTSTS) VALUE(%SST(&GENHDR 104 1))
IF COND(&LSTSTS = 'I') THEN(GOTO CMDLBL(ENDPGM))
/* Get the number of entries returned and convert to decimal. */
/* If zero, go to ENDPGM. */
CHGVAR VAR(&NUMENTB) VALUE(%SST(&GENHDR 133 4))
CHGVAR VAR(&NUMENT) VALUE(%BIN(&NUMENTB))
IF COND(&NUMENT = 0) THEN(GOTO CMDLBL(ENDPGM))
/* Get the list entry length and offset. These values are used to */
/* set up the starting position. */
CHGVAR VAR(&ELENB) VALUE(%SST(&GENHDR 137 4))
CHGVAR VAR(&OFFSETB) VALUE(%SST(&GENHDR 125 4))
CHGVAR VAR(%BIN(&STRPOSB)) VALUE(%BIN(&OFFSETB) + 1)
/* Retrieve the list entry. */
CALL PGM(QUSRTVUS) PARM(&USRSPC &STRPOSB &ELENB +
&LENTRY)
MONMSG MSGID(CPF3C00) EXEC(GOTO CMDLBL(ERROR))
/* Retrieve the scheduled time if TIMVAL = *SCD */
IF COND(&TIMVAL = '*SCD') +
THEN(DO)
CHGVAR VAR(&SCDHH) VALUE(%SST(&LENTRY 102 2))
CHGVAR VAR(&SCDMM) VALUE(%SST(&LENTRY 104 2))
CHGVAR VAR(&SCDSS) VALUE(%SST(&LENTRY 106 2))
CHGVAR VAR(&SCDHH#) VALUE(&SCDHH)
CHGVAR VAR(&SCDMM#) VALUE(&SCDMM)
CHGVAR VAR(&SCDSS#) VALUE(&SCDSS)
CHGVAR VAR(&SCDTIME) VALUE(&SCDHH || &SCDMM || +
&SCDSS)
ENDDO
/* Parse current time if TIMVAL = *SYS */
IF COND(&TIMVAL = '*SYS') +
THEN(DO)
RTVSYSVAL SYSVAL(QTIME) RTNVAR(&SYSTIME)
CHGVAR VAR(&SCDHH) VALUE(%SST(&SYSTIME 1 2))
CHGVAR VAR(&SCDMM) VALUE(%SST(&SYSTIME 3 2))
CHGVAR VAR(&SCDSS) VALUE(%SST(&SYSTIME 5 2))
CHGVAR VAR(&SCDHH#) VALUE(&SCDHH)
CHGVAR VAR(&SCDMM#) VALUE(&SCDMM)
CHGVAR VAR(&SCDSS#) VALUE(&SCDSS)
CHGVAR VAR(&SCDTIME) VALUE(&SCDHH || &SCDMM || +
&SCDSS)
ENDDO
/* Parse increment time */
CHGVAR VAR(&INCHH) VALUE(%SST(&INCREMENT 1 2))
CHGVAR VAR(&INCMM) VALUE(%SST(&INCREMENT 3 2))
CHGVAR VAR(&INCSS) VALUE(%SST(&INCREMENT 5 2))
CHGVAR VAR(&INCHH#) VALUE(&INCHH)
CHGVAR VAR(&INCMM#) VALUE(&INCMM)
CHGVAR VAR(&INCSS#) VALUE(&INCSS)
/* Calculate new scheduled time */
CHGVAR VAR(&NEWHH#) VALUE(&SCDHH# + &INCHH#)
CHGVAR VAR(&NEWMM#) VALUE(&SCDMM# + &INCMM#)
CHGVAR VAR(&NEWSS#) VALUE(&SCDSS# + &INCSS#)
IF COND(&NEWSS# >= 60) +
THEN(DO)
CHGVAR VAR(&NEWSS#) VALUE(&NEWSS# - 60)
CHGVAR VAR(&NEWMM#) VALUE(&NEWMM# + 1)
ENDDO
IF COND(&NEWMM# >= 60) +
THEN(DO)
CHGVAR VAR(&NEWMM#) VALUE(&NEWMM# - 60)
CHGVAR VAR(&NEWHH#) VALUE(&NEWHH# + 1)
ENDDO
IF COND(&NEWHH# >= 24) +
THEN(DO)
CHGVAR VAR(&NEWHH#) VALUE(&NEWHH# - 24)
ENDDO
CHGVAR VAR(&SCDHH#) VALUE(&NEWHH#)
CHGVAR VAR(&SCDMM#) VALUE(&NEWMM#)
CHGVAR VAR(&SCDSS#) VALUE(&NEWSS#)
CHGVAR VAR(&SCDHH) VALUE(&SCDHH#)
CHGVAR VAR(&SCDMM) VALUE(&SCDMM#)
CHGVAR VAR(&SCDSS) VALUE(&SCDSS#)
CHGVAR VAR(&NEWTIME) VALUE(&SCDHH || &SCDMM || +
&SCDSS)
/* Check if new time exceeds cutoff time */
IF COND(&CUTOFF *NE ' ' *AND &RESET *NE ' ' +
*AND (&NEWTIME *LT &SCDTIME *OR &NEWTIME +
*GE &CUTOFF)) THEN(CHGVAR VAR(&NEWTIME) +
VALUE(&RESET))
/* Update job schedule entry */
CHGJOBSCDE JOB(&JOBSCDNAM) SCDTIME(&NEWTIME)
GOTO CMDLBL(ENDPGM)
ERROR: RCVMSG MSGDTA(&MSGDTA) MSGID(&MSGID) MSGF(&MSGF) +
MSGFLIB(&MSGL)
MONMSG MSGID(CPF0000)
SNDPGMMSG MSGID(&MSGID) MSGF(&MSGL/&MSGF) +
MSGDTA(&MSGDTA) MSGTYPE(*ESCAPE)
MONMSG MSGID(CPF0000)
ENDPGM: DLTUSRSPC USRSPC(QTEMP/CHGSCDTIM)
MONMSG MSGID(CPF0000)
ENDPGM
CHGSCDTIM Command Validity Checker Source:
/* This program is the validity checker for the CHGSCDTIM (Change Schedule */
/* Time) command. It verifies that the job exists and that the increment, */
/* cutoff, and reset times are valid. */
PGM PARM(&JOBSCDNAM &INCREMENT &CUTOFF &RESET &TIMVAL)
DCL VAR(&JOBSCDNAM) TYPE(*CHAR) LEN(10)
DCL VAR(&INCREMENT) TYPE(*CHAR) LEN(6)
DCL VAR(&CUTOFF) TYPE(*CHAR) LEN(6)
DCL VAR(&RESET) TYPE(*CHAR) LEN(6)
DCL VAR(&TIMVAL) TYPE(*CHAR) LEN(4)
DCL VAR(&USRSPC) TYPE(*CHAR) LEN(20) +
VALUE('CHGSCDTIM QTEMP ') /* USER +
SPACE NAME FOR APIS */
DCL VAR(&CNTHDL) TYPE(*CHAR) LEN(16) +
VALUE(' ') /* CONTINUATION +
HANDLE */
DCL VAR(&NUMENTB) TYPE(*CHAR) LEN(4) /* NUMBER +
OF ENTRIES FROM LIST JOB SCHEDULE ENTRIES +
IN BINARY FORM */
DCL VAR(&NUMENT) TYPE(*DEC) LEN(8 0) /* NUMBER +
OF ENTRIES FROM LIST JOB SCHEDULE ENTRIES +
IN DECIMAL FORM */
DCL VAR(&GENHDR) TYPE(*CHAR) LEN(140) /* GENERIC +
HEADER INFORMATION FROM THE USER SPACE */
DCL VAR(&LSTSTS) TYPE(*CHAR) LEN(1) /* STATUS OF +
THE LIST IN THE USER SPACE */
DCL VAR(&OFFSETB) TYPE(*CHAR) LEN(4) /* OFFSET +
TO THE LIST PORTION OF THE USER SPACE IN +
BINARY FORM */
DCL VAR(&STRPOSB) TYPE(*CHAR) LEN(4) /* STARTING +
POSITION IN THE USER SPACE IN BINARY FORM */
DCL VAR(&ELENB) TYPE(*CHAR) LEN(4) /* LIST JOB +
ENTRY LENGTH IN BINARY 4 FORM */
DCL VAR(&LENTRY) TYPE(*CHAR) LEN(1156) /* +
RETRIEVE AREA FOR LIST JOB SCHEDULE ENTRY */
DCL VAR(&HH) TYPE(*CHAR) LEN(2)
DCL VAR(&MM) TYPE(*CHAR) LEN(2)
DCL VAR(&SS) TYPE(*CHAR) LEN(2)
DCL VAR(&MSGID) TYPE(*CHAR) LEN(07)
DCL VAR(&MSGF) TYPE(*CHAR) LEN(10)
DCL VAR(&MSGL) TYPE(*CHAR) LEN(10)
DCL VAR(&MSGDTA) TYPE(*CHAR) LEN(132)
MONMSG MSGID(CPF0000 MCH0000) EXEC(GOTO CMDLBL(ERROR))
/* Delete the user space if it already exists. */
DLTUSRSPC USRSPC(QTEMP/CHGSCDTIM)
MONMSG MSGID(CPF0000)
/* Create the user space. The user space will be 256 bytes and */
/* will be initialized to blanks. */
CALL PGM(QUSCRTUS) PARM(&USRSPC 'CHGSCDTIM ' +
X'00000100' ' ' '*ALL ' 'TEMPORARY +
USER SPACE ')
MONMSG MSGID(CPF3C00) EXEC(GOTO CMDLBL(ERROR))
/* List the job schedule entry of the name specified. */
CALL PGM(QWCLSCDE) PARM(&USRSPC 'SCDL0200' +
&JOBSCDNAM &CNTHDL 0)
/* Retrieve the generic header from the user space. */
CALL PGM(QUSRTVUS) PARM(&USRSPC X'00000001' +
X'0000008C' &GENHDR)
MONMSG MSGID(CPF3C00) EXEC(GOTO CMDLBL(ERROR))
/* Get the information status for the list from the generic header. */
CHGVAR VAR(&LSTSTS) VALUE(%SST(&GENHDR 104 1))
IF COND(&LSTSTS = 'I') THEN(GOTO CMDLBL(ENDPGM))
/* Get the number of entries returned and convert to decimal. */
/* If zero, send error message and exit. */
CHGVAR VAR(&NUMENTB) VALUE(%SST(&GENHDR 133 4))
CHGVAR VAR(&NUMENT) VALUE(%BIN(&NUMENTB))
IF COND(&NUMENT = 0) +
THEN(DO)
SNDPGMMSG MSGID(CPD0006) MSGF(QCPFMSG) MSGDTA('0000 +
Job name ' *CAT &JOBSCDNAM *TCAT ' not found +
on Job Schedule.') MSGTYPE(*DIAG)
SNDPGMMSG MSGID(CPF0002) MSGF(QCPFMSG) MSGTYPE(*ESCAPE)
GOTO CMDLBL(ENDPGM)
ENDDO
/* Get the list entry length and offset. These values are used to */
/* set up the starting position. */
CHGVAR VAR(&ELENB) VALUE(%SST(&GENHDR 137 4))
CHGVAR VAR(&OFFSETB) VALUE(%SST(&GENHDR 125 4))
CHGVAR VAR(%BIN(&STRPOSB)) VALUE(%BIN(&OFFSETB) + 1)
/* Retrieve the list entry. */
CALL PGM(QUSRTVUS) PARM(&USRSPC &STRPOSB &ELENB +
&LENTRY)
MONMSG MSGID(CPF3C00) EXEC(GOTO CMDLBL(ERROR))
IF COND(%SST(&LENTRY 2 10) *NE &JOBSCDNAM) +
THEN(DO)
SNDPGMMSG MSGID(CPD0006) MSGF(QCPFMSG) MSGDTA('0000 +
Job name ' *CAT &JOBSCDNAM *TCAT ' not found +
on Job Schedule.') MSGTYPE(*DIAG)
SNDPGMMSG MSGID(CPF0002) MSGF(QCPFMSG) MSGTYPE(*ESCAPE)
GOTO CMDLBL(ENDPGM)
ENDDO
/* Check increment time */
CHGVAR VAR(&HH) VALUE(%SST(&INCREMENT 1 2))
CHGVAR VAR(&MM) VALUE(%SST(&INCREMENT 3 2))
CHGVAR VAR(&SS) VALUE(%SST(&INCREMENT 5 2))
IF COND(&HH *LT '00' *OR &HH *GT '23' *OR +
&MM *LT '00' *OR &MM *GT '59' *OR +
&SS *LT '00' *OR &SS *GT '59') +
THEN(DO)
SNDPGMMSG MSGID(CPD0006) MSGF(QCPFMSG) MSGDTA('0000 +
Increment time is not valid.') MSGTYPE(*DIAG)
SNDPGMMSG MSGID(CPF0002) MSGF(QCPFMSG) MSGTYPE(*ESCAPE)
ENDDO
/* Check cutoff time */
IF COND(&CUTOFF *NE ' ') +
THEN(DO)
CHGVAR VAR(&HH) VALUE(%SST(&CUTOFF 1 2))
CHGVAR VAR(&MM) VALUE(%SST(&CUTOFF 3 2))
CHGVAR VAR(&SS) VALUE(%SST(&CUTOFF 5 2))
IF COND(&HH *LT '00' *OR &HH *GT '24' *OR +
&MM *LT '00' *OR &MM *GT '59' *OR +
&SS *LT '00' *OR &SS *GT '59') +
THEN(DO)
SNDPGMMSG MSGID(CPD0006) MSGF(QCPFMSG) MSGDTA('0000 +
Cutoff time is not valid.') MSGTYPE(*DIAG)
SNDPGMMSG MSGID(CPF0002) MSGF(QCPFMSG) MSGTYPE(*ESCAPE)
ENDDO
/* Check reset time */
CHGVAR VAR(&HH) VALUE(%SST(&RESET 1 2))
CHGVAR VAR(&MM) VALUE(%SST(&RESET 3 2))
CHGVAR VAR(&SS) VALUE(%SST(&RESET 5 2))
IF COND(&HH *LT '00' *OR &HH *GT '23' *OR +
&MM *LT '00' *OR &MM *GT '59' *OR +
&SS *LT '00' *OR &SS *GT '59') +
THEN(DO)
SNDPGMMSG MSGID(CPD0006) MSGF(QCPFMSG) MSGDTA('0000 +
Reset time is not valid.') MSGTYPE(*DIAG)
SNDPGMMSG MSGID(CPF0002) MSGF(QCPFMSG) MSGTYPE(*ESCAPE)
ENDDO
ENDDO
GOTO CMDLBL(ENDPGM)
ERROR:
RCVMSG MSGDTA(&MSGDTA) MSGID(&MSGID) MSGF(&MSGF) +
MSGFLIB(&MSGL)
MONMSG MSGID(CPF0000)
SNDPGMMSG MSGID(&MSGID) MSGF(&MSGL/&MSGF) +
MSGDTA(&MSGDTA) MSGTYPE(*ESCAPE)
MONMSG MSGID(CPF0000)
ENDPGM: DLTUSRSPC USRSPC(QTEMP/CHGSCDTIM)
MONMSG MSGID(CPF0000)
ENDPGM
CHGSCDTIM Help Panel Group Source:
:PNLGRP.
:HELP name=CHGSCDTIMP.
:P.
The "Change Job Schedule Time" (CHGSCDTIM) command increments the
schedule time for a job on the AS/400 job scheduler. This enables
you to submit a job from the scheduler on a periodic basis of less
than a day (e.g., every hour or every 15 minutes). Simply run the
CHGSCDTIM command from your program that is called by the scheduler
and specify the job name and the increment time in HHMMSS format.
The schedule time for the job will be incremented by the amount of
time you specified. You can increment the currently scheduled time
or the current system time. You can also optionally specify a cutoff
and reset time. This would enable you to run a job periodically
within certain times each day (e.g., every hour from 8:00 a.m. to
8:00 p.m.).
:EHELP.
:HELP name='CHGSCDTIMP/JOBNAM'.
:P.
Scheduled Job Name:
:LINES.
This is the name of the job as you defined it on
the job scheduler.
:ELINES.
:EHELP.
:HELP name='CHGSCDTIMP/INCREMENT'.
:P.
Increment time:
:LINES.
This is the amount of time you would like to increment
the scheduled job. The format is HHMMSS.
:ELINES.
:EHELP.
:HELP name='CHGSCDTIMP/CUTOFF'.
:P.
Cutoff time:
:LINES.
This is the time of day you would like to stop
incrementing the job. The format is HHMMSS. If a
cutoff time is specified, a reset time is required.
:ELINES.
:EHELP.
:HELP name='CHGSCDTIMP/RESET'.
:P.
Reset time:
:LINES.
This is the time of day you would like to restart the
job. The format is HHMMSS. A reset time is required
if a cutoff time is specified.
:ELINES.
:EHELP.
:HELP name='CHGSCDTIMP/TIMVAL'.
:P.
Time value:
:LINES.
This is the time value that you would like to
increment. *SCD will increment the time on the
scheduler. *SYS will set the schedule time to
the current time plus the increment.
:ELINES.
:EHELP.
:EPNLGRP.
The following CL program can be used to create the CHGSCDTIM command.
The program assumes that the source is in QGPL/CSTCMDSRC:
PGM
DCL VAR(&LIBRARY) TYPE(*CHAR) LEN(10) VALUE('QGPL')
DCL VAR(&SRCFILE) TYPE(*CHAR) LEN(10) VALUE('CSTCMDSRC')
/* Create Command Processing Program */
CRTCLPGM PGM(&LIBRARY/CHGSCDTIMC) SRCFILE(&LIBRARY/&SRCFILE)
/* Create Validity Checker Program */
CRTCLPGM PGM(&LIBRARY/CHGSCDTIMV) SRCFILE(&LIBRARY/&SRCFILE)
/* Create Help Panel Group */
CRTPNLGRP PNLGRP(&LIBRARY/CHGSCDTIMP) +
SRCFILE(&LIBRARY/&SRCFILE)
/* Create Change Job Schedule Time Command */
CRTCMD CMD(&LIBRARY/CHGSCDTIM) PGM(&LIBRARY/CHGSCDTIMC) +
SRCFILE(&LIBRARY/&SRCFILE) +
VLDCKR(&LIBRARY/CHGSCDTIMV) +
HLPPNLGRP(&LIBRARY/CHGSCDTIMP) HLPID(CHGSCDTIMP)
ENDPGM
2001-11-14 工具：CHGNETAPOP
工具：CHGNETAPOP
當使用指令 CHGNETA 時，有許多參數值均是顯示“*SAME“，若您要知道現有設定值為何值時，
您就須執行 DSPNETA 顯示 AS/400 網路屬性，如此ㄧ來顯得很麻煩，可利用 AS/400 指令參數 PMTOVRPGM，
設定指令顯示時的初設值，底下範例供您參考，您可依 AS/400 的版本更改成您自己的版本。
File : QCLSRC
Member : CHGNETAPOP
Type : CLP
Usage : CRTCLPGM PGM(QUSRSYS/CHGNETAPOP)
CHGCMD CMD(QSYS/CHGNETA) PMTOVRPGM(QUSRSYS/CHGNETAPOP)
/*********************************************************************/
/* Program Name: CHGNETAPOP Network Attributes prompt override pgm */
/* Source Name : QGPL/QCLSRC(CHGNETAPOP) */
/* Used By : QSYS/CHGNETA *CMD */
/* Requires : Nothing */
/* Written By : Syed Hussain Akbar */
/* Organisation: Systems (Pvt) Ltd */
/* Date Written: May 18th, 1995 */
/* OS Version : V2 Release 3 */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* Modified By :Vengoal Chang */
/* Date Modified:Nov 14th, 2001 */
/* OS Version :V4 Release 4 */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* Description : */
/* This is the prompt override program which fills */
/* the parameters of the CHGNETA command. */
/* */
/* CHGCMD CMD(QSYS/CHGNETA) PMTOVRPGM(QUSRSYS/CHGNETAPOP) */
/*********************************************************************/
PGM PARM(&CMDNAME &RETCMD)
DCL VAR(&CMDNAME) TYPE(*CHAR) LEN(20)
DCL VAR(&RETCMD) TYPE(*CHAR) LEN(5700)
DCL VAR(&RETLEN) TYPE(*DEC) LEN(5 0)
DCL VAR(&CRETLEN) TYPE(*CHAR) LEN(2)
DCL VAR(&INUM) TYPE(*DEC) LEN(2)
DCL VAR(&ISTART) TYPE(*DEC) LEN(2)
DCL VAR(&SYSNAME) TYPE(*CHAR) LEN(8)
DCL VAR(&LCLNETID) TYPE(*CHAR) LEN(8)
DCL VAR(&LCLCPNAME) TYPE(*CHAR) LEN(8)
DCL VAR(&LCLLOCNAME) TYPE(*CHAR) LEN(8)
DCL VAR(&DFTMODE) TYPE(*CHAR) LEN(8)
DCL VAR(&NODETYPE) TYPE(*CHAR) LEN(8)
DCL VAR(&DTACPR) TYPE(*DEC) LEN(10 0)
DCL VAR(&CDTACPR) TYPE(*CHAR) LEN(10)
DCL VAR(&DTACPRINM) TYPE(*DEC) LEN(10 0)
DCL VAR(&CDTACPRINM) TYPE(*CHAR) LEN(10)
DCL VAR(&MAXINTSSN) TYPE(*DEC) LEN(5 0)
DCL VAR(&CMAXINTSSN) TYPE(*CHAR) LEN(5)
DCL VAR(&RAR) TYPE(*DEC) LEN(5 0)
DCL VAR(&CRAR) TYPE(*CHAR) LEN(5)
DCL VAR(&NETSERVER) TYPE(*CHAR) LEN(85)
DCL VAR(&ALRSTS) TYPE(*CHAR) LEN(10)
DCL VAR(&ALRPRIFP) TYPE(*CHAR) LEN(10)
DCL VAR(&ALRDFTFP) TYPE(*CHAR) LEN(10)
DCL VAR(&ALRLOGSTS) TYPE(*CHAR) LEN(7)
DCL VAR(&ALRBCKFP) TYPE(*CHAR) LEN(16)
DCL VAR(&ALRRQSFP) TYPE(*CHAR) LEN(16)
DCL VAR(&ALRCTLD) TYPE(*CHAR) LEN(10)
DCL VAR(&ALRHLDCNT) TYPE(*DEC) LEN(5 0)
DCL VAR(&CALRHLDCNT) TYPE(*CHAR) LEN(5)
DCL VAR(&ALRFTR) TYPE(*CHAR) LEN(10)
DCL VAR(&ALRFTRLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&MSGQ) TYPE(*CHAR) LEN(10)
DCL VAR(&MSGQLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&OUTQ) TYPE(*CHAR) LEN(10)
DCL VAR(&OUTQLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&JOBACN) TYPE(*CHAR) LEN(10)
DCL VAR(&MAXHOP) TYPE(*DEC) LEN(5 0)
DCL VAR(&CMAXHOP) TYPE(*CHAR) LEN(5)
DCL VAR(&DDMACC) TYPE(*CHAR) LEN(10)
DCL VAR(&DDMACCLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&PCSACC) TYPE(*CHAR) LEN(10)
DCL VAR(&PCSACCLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&DFTNETTYPE) TYPE(*CHAR) LEN(10)
DCL VAR(&DFTCNNLST) TYPE(*CHAR) LEN(10)
DCL VAR(&ALWANYNET) TYPE(*CHAR) LEN(10)
DCL VAR(&NWSDOMAIN) TYPE(*CHAR) LEN(8)
DCL VAR(&ALWVRTAPPN) TYPE(*CHAR) LEN(10)
DCL VAR(&ALWHPRTWR) TYPE(*CHAR) LEN(10)
DCL VAR(&VRTAUTODEV) TYPE(*DEC) LEN(5 0)
DCL VAR(&CVRTAUTODV) TYPE(*CHAR) LEN(5)
DCL VAR(&HPRPTHTMR) TYPE(*CHAR) LEN(40)
DCL VAR(&ALWADDCLU) TYPE(*CHAR) LEN(10)
DCL VAR(&MDMCNTRYID) TYPE(*CHAR) LEN(2)
/* Retrieve current parameters */
RTVNETA SYSNAME(&SYSNAME) LCLNETID(&LCLNETID) +
LCLCPNAME(&LCLCPNAME) +
LCLLOCNAME(&LCLLOCNAME) DFTMODE(&DFTMODE) +
NODETYPE(&NODETYPE) DTACPR(&DTACPR) +
DTACPRINM(&DTACPRINM) +
MAXINTSSN(&MAXINTSSN) RAR(&RAR) +
NETSERVER(&NETSERVER) ALRSTS(&ALRSTS) +
ALRPRIFP(&ALRPRIFP) ALRDFTFP(&ALRDFTFP) +
ALRLOGSTS(&ALRLOGSTS) ALRBCKFP(&ALRBCKFP) +
ALRRQSFP(&ALRRQSFP) ALRCTLD(&ALRCTLD) +
ALRHLDCNT(&ALRHLDCNT) ALRFTR(&ALRFTR) +
ALRFTRLIB(&ALRFTRLIB) MSGQ(&MSGQ) +
MSGQLIB(&MSGQLIB) OUTQ(&OUTQ) +
OUTQLIB(&OUTQLIB) JOBACN(&JOBACN) +
MAXHOP(&MAXHOP) DDMACC(&DDMACC) +
DDMACCLIB(&DDMACCLIB) PCSACC(&PCSACC) +
PCSACCLIB(&PCSACCLIB) +
DFTNETTYPE(&DFTNETTYPE) +
DFTCNNLST(&DFTCNNLST) +
ALWANYNET(&ALWANYNET) +
NWSDOMAIN(&NWSDOMAIN) +
ALWVRTAPPN(&ALWVRTAPPN) +
ALWHPRTWR(&ALWHPRTWR) +
VRTAUTODEV(&VRTAUTODEV) +
HPRPTHTMR(&HPRPTHTMR) +
ALWADDCLU(&ALWADDCLU) MDMCNTRYID(&MDMCNTRYID)
/* Convert the numeric variables to string to allow concatenation */
/* Also substitute the special values. */
CHGVAR VAR(&CDTACPR) VALUE(&DTACPR)
IF COND(&DTACPR *EQ 0) THEN(CHGVAR +
VAR(&CDTACPR) VALUE(*NONE))
IF COND(&DTACPR *EQ -1) THEN(CHGVAR +
VAR(&CDTACPR) VALUE(*REQUEST))
IF COND(&DTACPR *EQ -2) THEN(CHGVAR +
VAR(&CDTACPR) VALUE(*ALLOW))
IF COND(&DTACPR *EQ -3) THEN(CHGVAR +
VAR(&CDTACPR) VALUE(*REQUIRE))
CHGVAR VAR(&CDTACPRINM) VALUE(&DTACPRINM)
IF COND(&DTACPRINM *EQ 0) THEN(CHGVAR +
VAR(&CDTACPRINM) VALUE(*NONE))
IF COND(&DTACPRINM *EQ -1) THEN(CHGVAR +
VAR(&CDTACPRINM) VALUE(*REQUEST))
CHGVAR VAR(&CMAXINTSSN) VALUE(&MAXINTSSN)
CHGVAR VAR(&CRAR) VALUE(&RAR)
CHGVAR VAR(&CALRHLDCNT) VALUE(&ALRHLDCNT)
CHGVAR VAR(&CMAXHOP) VALUE(&MAXHOP)
CHGVAR VAR(&CVRTAUTODV) VALUE(&VRTAUTODEV)
CHGVAR VAR(&RETCMD) VALUE('?<SYSNAME(' |< &SYSNAME +
|< ') ')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<LCLNETID(' +
|< &LCLNETID |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<LCLCPNAME(' +
|< &LCLCPNAME |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<LCLLOCNAME(' +
|< &LCLLOCNAME |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<DFTMODE(' +
|< &DFTMODE |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<NODETYPE(' +
|< &NODETYPE |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<DTACPR(' +
|< &CDTACPR |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<DTACPRINM(' +
|< &CDTACPRINM |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<MAXINTSSN(' +
|< &CMAXINTSSN |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<RAR(' +
|< &CRAR |< ')')
/* Build the combined string for NETSERVER */
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<NETSERVER(')
CHGVAR VAR(&INUM) VALUE(1)
NET1: CHGVAR VAR(&ISTART) VALUE(((&INUM -1) * 17) + 1)
IF COND(%SST(&NETSERVER &ISTART 9) *NE ' ') +
THEN(DO)
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |< '(' |< +
%SST(&NETSERVER &ISTART 9))
CHGVAR VAR(&ISTART) VALUE(&ISTART + 9)
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> +
%SST(&NETSERVER &ISTART 8) |< ')')
CHGVAR VAR(&INUM) VALUE(&INUM + 1)
IF COND(&INUM *LT 6) THEN(GOTO CMDLBL(NET1))
ENDDO
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<ALRSTS(' +
|< &ALRSTS |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<ALRPRIFP(' +
|< &ALRPRIFP |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<ALRDFTFP(' +
|< &ALRDFTFP |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<ALRLOGSTS(' +
|< &ALRLOGSTS |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<ALRBCKFP(' +
|< %SST(&ALRBCKFP 1 8) |> %SST(&ALRBCKFP +
9 8) |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<ALRRQSFP(' +
|< %SST(&ALRRQSFP 1 8) |> %SST(&ALRRQSFP +
9 8) |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<ALRCTLD(' +
|< &ALRCTLD |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<ALRHLDCNT(' +
|< &CALRHLDCNT |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<ALRFTR(')
IF COND(&ALRFTRLIB *NE ' ') THEN(DO)
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |< &ALRFTRLIB |< +
'/')
ENDDO
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |< &ALRFTR |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<MSGQ(')
IF COND(&MSGQLIB *NE ' ') THEN(DO)
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |< &MSGQLIB |< '/')
ENDDO
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |< &MSGQ |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<OUTQ(')
IF COND(&OUTQLIB *NE ' ') THEN(DO)
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |< &OUTQLIB |< '/')
ENDDO
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |< &OUTQ |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<JOBACN(' +
|< &JOBACN |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<MAXHOP(' +
|< &CMAXHOP |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<DDMACC(')
IF COND(&DDMACCLIB *NE ' ') THEN(DO)
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |< &DDMACCLIB |< +
'/')
ENDDO
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |< &DDMACC |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<PCSACC(')
IF COND(&PCSACCLIB *NE ' ') THEN(DO)
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |< &PCSACCLIB |< +
'/')
ENDDO
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |< &PCSACC |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> +
'?<DFTNETTYPE(' |< &DFTNETTYPE |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<DFTCNNLST(' +
|< &DFTCNNLST |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<ALWANYNET(' +
|< &ALWANYNET |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<NWSDOMAIN(' +
|< &NWSDOMAIN |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<ALWVRTAPPN(' +
|< &ALWVRTAPPN |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<ALWHPRTWR(' +
|< &ALWHPRTWR |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<VRTAUTODEV(' +
|< &CVRTAUTODV |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<HPRPTHTMR(' +
|< &HPRPTHTMR |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<ALWADDCLU(' +
|< &ALWADDCLU |< ')')
CHGVAR VAR(&RETCMD) VALUE(&RETCMD |> '?<MDMCNTRYID(' +
|< &MDMCNTRYID |< ')')
/* Calculate size of the returned command line */
CHGVAR VAR(&RETLEN) VALUE(700)
CALCLEN: CHGVAR VAR(&RETLEN) VALUE(&RETLEN - 1)
IF COND(%SST(&RETCMD &RETLEN 1) *NE ' ') +
THEN(GOTO CMDLBL(CALCLEN))
CHGVAR VAR(%BIN(&CRETLEN)) VALUE(&RETLEN)
CHGVAR VAR(&RETCMD) VALUE(&CRETLEN |< &RETCMD)
ENDPGM
2001-11-08 如何將一份報表切割頁次列印（Command CPYSPLPAG Copy Spooled by Page Range）?
如何將一份報表切割頁次列印（Command CPYSPLPAG Copy Spooled by Page Range）?
有時候同一份報表頁數可能長達數百數千頁，此時使用者若僅要部份頁次或者需要傳輸某幾頁
報表，為了減輕網路的負擔，最好的方式就是切割使用者所要求的頁次，再做處理。這個工具
可指定重新列印原報表頁次區間。
Copy Spool by Page Range (CPYSPLPAG)
Type choices, press Enter.
Spool file name . . . . . . . . Name
Job name . . . . . . . . . . . . * Name, *
User name . . . . . . . . . . Name
Job number . . . . . . . . . . 000000-999999
Spool file number . . . . . . . *LAST 000001-999999, *ONLY, *LAST
Bottom
F3=Exit F4=Prompt F5=Refresh F10=Additional parameters F12=Cancel
F13=How to use this display F24=More keys
按 F10 可指定重印頁次區間。
Copy Spool by Page Range (CPYSPLPAG)
Type choices, press Enter.
Spool file name . . . . . . . . Name
Job name . . . . . . . . . . . . * Name, *
User name . . . . . . . . . . Name
Job number . . . . . . . . . . 000000-999999
Spool file number . . . . . . . *LAST 000001-999999, *ONLY, *LAST
Additional Parameters
Range of pages to copy:
Starting page . . . . . . . . *FIRST 1-9999, *FIRST, *LAST
Ending page . . . . . . . . . *LAST 1-9999, *LAST, *FIRST
Bottom
F3=Exit F4=Prompt F5=Refresh F12=Cancel F13=How to use this display
F24=More keys
-------------------------------------------------------------------------------
CPYSPLPAG command
File : QCMDSRC
Member : CPYSPLPAG
Type : CMD
/******************************************************************************/
/* */
/* System....... Utilities */
/* Program...... CPYSPLPAG - Copy Spool File BY Page Range */
/* Written by... Vengoal Cahng */
/* Date......... 11/08/2001 */
/* */
/* */
/* Program Description */
/* */
/* */
/* It can perform operations on the entire spool file or a specified */
/* Page range. */
/* */
/* */
/* NOTE: This Command does not handle AFPDS Spool Files. */
/* */
/* * * * * * * * * Indicator Usage * * * * * * * * * * * * * * * * */
/* */
/* */
/* */
/* * * * * * * * * Externally Called Programs * * * * * * * * * */
/* */
/* From/To Program-Id Parameters */
/* */
/* */
/* */
/* */
/* * * * * * * * * * * Maintenance Log * * * * * * * * * * * * */
/* */
/* Req # Date Programmer Modification Reason */
/* */
/*********************************************************************/
CMD PROMPT('Copy Spool by Page Range')
PARM KWD(FILE) TYPE(*NAME) LEN(10) MIN(1) +
EXPR(*YES) PROMPT('Spool file name')
PARM KWD(JOB) TYPE(QUAL1) SNGVAL(*) DFT(*) +
PROMPT('Job name')
PARM KWD(SPLNBR) TYPE(*DEC) LEN(6 0) DFT(*LAST) +
RANGE(000001 999999) SPCVAL((*ONLY -1) +
(*LAST -2)) PROMPT('Spool file number')
PARM KWD(PAGERANGE) TYPE(PAGELIST) +
PMTCTL(*PMTRQS) PROMPT('Range of pages +
to copy')
QUAL1: QUAL TYPE(*NAME) LEN(10) MIN(1) EXPR(*YES)
QUAL TYPE(*NAME) LEN(10) MIN(0) EXPR(*YES) +
PROMPT('User name')
QUAL TYPE(*CHAR) LEN(6) RANGE(000000 999999) +
MIN(0) FULL(*YES) PROMPT('Job number')
QUAL2: QUAL TYPE(*NAME) LEN(10) MIN(1)
QUAL TYPE(*NAME) LEN(10) MIN(1) +
EXPR(*YES) PROMPT('Library name')
PAGELIST: ELEM TYPE(*INT2) DFT(*FIRST) RANGE(1 9999) +
SPCVAL((*FIRST -2) (*LAST -1)) +
PROMPT('Starting page')
ELEM TYPE(*INT2) DFT(*LAST) RANGE(1 9999) +
SPCVAL((*LAST -1) (*FIRST -2)) +
PROMPT('Ending page')
File : QCLSRC
Member : CPYSPLPAGC
Type : CLP
/*********************************************************************/
/* */
/* System ........... Utilities */
/* Program........... CPYSPLPAGC Program to copy spool file to text */
/* Written by........ Vengoal Cahng */
/* Date.............. Nov 8, 2001 */
/* */
/* */
/* Program Description */
/* */
/* It can perform operations on the entire spool file or a specified */
/* Page range. */
/* */
/* */
/* NOTE: This program does not handle AFPDS Spool Files. */
/* */
/* Parameters: */
/* NAME I/O DESCRIPTION COMMENTS */
/* &FILE Input Spool file Spool file to copy */
/* &FULLJOB Input Job name Spool file job */
/* &SPLNBR Input Spool nbr Spool file number */
/* &PAGRNG Input Page Range Page Range to Print */
/* * * * * * * * * * * * Maintenance Log * * * * * * * * * * * * * * */
/* */
/* Req#. Date Programmer Modification Reason */
/* */
/*********************************************************************/
PGM PARM(&FILE &FULLJOB &SPLNBR &PAGRNG)
DCL &FILE *CHAR LEN(10)
DCL &FULLJOB *CHAR LEN(26)
DCL &JOB *CHAR LEN(10)
DCL &USER *CHAR LEN(10)
DCL &JOBNBR *CHAR LEN(6)
DCL &SPLNBR *DEC LEN(6 0)
DCL &PAGRNG *CHAR LEN(6)
DCL &ERRORSW *LGL /* Standard error */
DCL &MSGID *CHAR LEN(7) /* Standard error */
DCL &MSG *CHAR LEN(512) /* Standard error */
DCL &MSGDTA *CHAR LEN(512) /* Standard error */
DCL &MSGF *CHAR LEN(10) /* Standard error */
DCL &MSGFLIB *CHAR LEN(10) /* Standard error */
DCL &KEYVAR *CHAR LEN(4) /* Standard error */
DCL &KEYVAR2 *CHAR LEN(4) /* Standard error */
DCL &RTNTYPE *CHAR LEN(2) /* Standard error */
DCL VAR(&FRPAGE) TYPE(*DEC) LEN(7 0)
DCL VAR(&TOPAGE) TYPE(*DEC) LEN(7 0)
DCL VAR(&SPLFDS) TYPE(*CHAR) LEN(1000)
DCL VAR(&DSLENB) TYPE(*CHAR) LEN(4)
DCL VAR(&INTJOB) TYPE(*CHAR) LEN(16)
DCL VAR(&INTSPLF) TYPE(*CHAR) LEN(16)
DCL VAR(&SPLNBRA) TYPE(*CHAR) LEN(6)
DCL VAR(&SPLNBRB) TYPE(*CHAR) LEN(4)
DCL VAR(&NBRPGSB) TYPE(*CHAR) LEN(4)
DCL VAR(&NBRPGS) TYPE(*DEC) LEN(9 0)
DCL VAR(&CPIB) TYPE(*CHAR) LEN(4)
DCL VAR(&CPI) TYPE(*DEC) LEN(9 1)
DCL VAR(&PAGWTHB) TYPE(*CHAR) LEN(4)
DCL VAR(&PAGWTH) TYPE(*DEC) LEN(9 0)
MONMSG MSGID(CPF0000) EXEC(GOTO STDERR1) /* Std err */
CHGVAR &JOB %SST(&FULLJOB 1 10)
CHGVAR &USER %SST(&FULLJOB 11 10)
CHGVAR &JOBNBR %SST(&FULLJOB 21 6)
CHGVAR VAR(&SPLNBRA) VALUE(&SPLNBR)
DLTOVR FILE(INPUT)
MONMSG CPF0000
DLTF FILE(QTEMP/SPLTEMP)
MONMSG MSGID(CPF2105) /* file not found */
CRTPF FILE(QTEMP/SPLTEMP) RCDLEN(220) IGCDTA(*YES)
IF COND(&SPLNBR *EQ -2) THEN(DO)
CHGVAR VAR(&SPLNBRA) VALUE('*LAST')
ENDDO
IF COND(&SPLNBR *EQ -1) THEN(DO)
CHGVAR VAR(&SPLNBRA) VALUE('*ONLY')
ENDDO
IF (&FULLJOB *EQ '*') DO /* Use current job */
CPYSPLF FILE(&FILE) TOFILE(QTEMP/SPLTEMP) +
SPLNBR(&SPLNBRA) MBROPT(*ADD) +
CTLCHAR(*PRTCTL)
ENDDO /* Use current job */
IF (&FULLJOB *NE '*') DO /* Specific job name */
IF (&USER *EQ ' ') CHGVAR &USER '*N'
IF (&JOBNBR *EQ ' ') CHGVAR &JOBNBR '*N'
CPYSPLF FILE(&FILE) TOFILE(QTEMP/SPLTEMP) +
JOB(&JOBNBR/&USER/&JOB) SPLNBR(&SPLNBRA) +
MBROPT(*ADD) +
CTLCHAR(*PRTCTL)
ENDDO /* Specific job name used */
IF COND(&SPLNBR *EQ -2) THEN(DO)
CHGVAR VAR(&SPLNBR) VALUE(-1) /* *LAST */
ENDDO
ELSE DO
IF COND(&SPLNBR *EQ -1) THEN(DO)
CHGVAR VAR(&SPLNBR) VALUE(0) /* *ONLY */
ENDDO
ENDDO
/* Build work variables used for parameters to attribute API. */
CHGVAR VAR(&DSLENB) VALUE(X'000003E8') /* Change +
length to the hex form of '1000' */
CHGVAR VAR(%BIN(&SPLNBRB 1 4)) VALUE(&SPLNBR)
/* Call API */
CALL PGM(QUSRSPLA) PARM(&SPLFDS &DSLENB +
'SPLA0100' &FULLJOB &INTJOB &INTSPLF &FILE +
&SPLNBRB)
/* Retrieve results: */
CHGVAR VAR(&NBRPGSB) VALUE(%SST(&SPLFDS 141 4))
CHGVAR VAR(&NBRPGS) VALUE(%BIN(&NBRPGSB 1 4))
CHGVAR VAR(&CPIB) VALUE(%SST(&SPLFDS 177 4))
CHGVAR VAR(&CPI) VALUE(%BIN(&CPIB 1 4))
CHGVAR VAR(&CPI) VALUE(&CPI / 10)
CHGVAR VAR(&PAGWTHB) VALUE(%SST(&SPLFDS 429 4))
CHGVAR VAR(&PAGWTH) VALUE(%BIN(&PAGWTHB 1 4))
CHGVAR VAR(&FRPAGE) VALUE(%BIN(&PAGRNG 3 2))
CHGVAR VAR(&TOPAGE) VALUE(%BIN(&PAGRNG 5 2))
IF COND(&TOPAGE *GT &NBRPGS) THEN(DO)
SNDPGMMSG MSG('To Page cannot be greater than Total +
number of Pages')
GOTO RETN
ENDDO
IF COND(&FRPAGE *EQ 0) THEN(DO)
SNDPGMMSG MSG('From Page cannot be Zeros.')
GOTO RETN
ENDDO
IF COND(&TOPAGE *EQ 0) THEN(DO)
SNDPGMMSG MSG('To Page cannot be Zeros.')
GOTO RETN
ENDDO
IF COND(&TOPAGE = -2) THEN(CHGVAR VAR(&TOPAGE) +
VALUE(1))
IF COND(&FRPAGE = -2) THEN(CHGVAR VAR(&FRPAGE) +
VALUE(1))
IF COND(&TOPAGE = -1) THEN(CHGVAR VAR(&TOPAGE) +
VALUE(&NBRPGS))
IF COND(&FRPAGE = -1) THEN(CHGVAR VAR(&FRPAGE) +
VALUE(&NBRPGS))
IF COND(&FRPAGE *GT &TOPAGE) THEN(DO)
SNDPGMMSG MSG('From Page cannot be greater than to +
Page.')
GOTO RETN
ENDDO
PRINT:
OVRDBF FILE(INPUT) TOFILE(QTEMP/SPLTEMP)
OVRPRTF FILE(QPRINT) PAGESIZE(*N &PAGWTH) CPI(&CPI) +
SPLFNAME(&FILE) IGCDTA(*YES)
CALL PGM(CPYSPLPAGR) PARM(&FRPAGE &TOPAGE )
DLTOVR INPUT
DLTOVR QPRINT
RMVMSG CLEAR(*ALL)
SNDPGMMSG MSG('Spooled file ' *CAT &FILE *TCAT ' has +
been reprinted.') MSGTYPE(*COMP)
RETN:
RETURN /* Normal end for MODIFY(*YES) */
STDERR1: /* Standard error handling routine */
IF &ERRORSW SNDPGMMSG MSGID(CPF9999) +
MSGF(QCPFMSG) MSGTYPE(*ESCAPE)
CHGVAR &ERRORSW '1' /* Set to fail on error */
RCVMSG MSGTYPE(*EXCP) RMV(*NO) KEYVAR(&KEYVAR)
STDERR2: RCVMSG MSGTYPE(*PRV) MSGKEY(&KEYVAR) RMV(*NO) +
KEYVAR(&KEYVAR2) MSG(&MSG) MSGDTA(&MSGDTA) +
MSGID(&MSGID) RTNTYPE(&RTNTYPE) +
MSGF(&MSGF) SNDMSGFLIB(&MSGFLIB)
IF (&RTNTYPE *NE '02') GOTO STDERR3
IF (&MSGID *NE ' ') SNDPGMMSG MSGID(&MSGID) +
MSGF(&MSGFLIB/&MSGF) MSGDTA(&MSGDTA) +
MSGTYPE(*DIAG)
IF (&MSGID *EQ ' ') SNDPGMMSG MSG(&MSG) +
MSGTYPE(*DIAG)
RMVMSG MSGKEY(&KEYVAR2)
STDERR3: RCVMSG MSGKEY(&KEYVAR) MSGDTA(&MSGDTA) +
MSGID(&MSGID) MSGF(&MSGF) +
SNDMSGFLIB(&MSGFLIB)
SNDPGMMSG MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
MSGDTA(&MSGDTA) MSGTYPE(*ESCAPE)
ENDPGM
File : QRPGLESRC
Member : CPYSPLPAGR
Type : RPGLE
H DEBUG OPTION(*SRCSTMT:*NODEBUGIO)
* RSTSPLFR - Copy text to spool - Called by RSTSPLFC
*
* PRTCTL Keyword : Data structure A(12)+S(3)
* Position contents
* 1-3 A(3) space-before blank or 0-255
* 4-6 A(3) space-after blank or 0-255
* 7-9 A(3) skip-before blank or 0-255
* 10-12 A(3) skip-after blank or 0-255
* 13-15 S(3) line count 3 digit numeric
* (zoned decimal)
*
FINPUT IP F 220 DISK
FQPRINT O F 198 PRINTER PRTCTL(LINE)
F OFLIND(*INOF)
*
D LINE DS 15
D SPCBFR 3 3
D SKPBFR 7 9
*****************************************************************
* Parameters
*****************************************************************
D WrkNum7 S 7P 0
D FrPage S Like(WrkNum7)
D ToPage S Like(WrkNum7)
D CurPage S Like(WrkNum7)
*****************************************************************
IINPUT AA 01
I 1 3 SKPBFR
I 4 4 SPCBFR
I 6 203 DATA
*****************************************************************
*** Parameters:
*****************************************************************
C *ENTRY Plist
C Parm FrPage
C Parm ToPage
C If SpcBfr = *Blanks
C Eval CurPage = CurPage + 1
C If CurPage >= FrPage and
C CurPage <= ToPage
C Move '1' *In90
C Else
C If CurPage > ToPage
C Move '0' *In90
C Move '1' *INLR
C EndIf
C EndIf
C EndIf
C 90 EXCEPT PRINT Print
OQPRINT E PRINT
O DATA 198
使用方法
1. CRTBNDRPG CPYSPLPAGR
2. CRTCLPGM CPYSPLPAGC
3. CRTCMD CMD(CPYSPLPAG) PGM(CPYSPLPAGC)
4. 於 Command Line 輸入 CPTSPLPAG 按 F4
再輸入相關參數。
2001-11-08 如何使 SQL 查詢結果加上顏色分類，以快速分辨所要的資料？
如何使 SQL 查詢結果加上顏色分類，以快速分辨所要的資料？
當我們觀看 SQL 的查詢結果時，我們無法得到警示性的圖形，如果我們想要查詢客戶的銷售狀況，
若能依不同的銷售量區間並給予各區間不同的顏色來顯示查詢結果，將會給予使用者較容易找到較
重要的警示性資料。
為了要在查詢結果中顯示不同的顏色，我們需要於顯示資料前加入顏色的屬性於欄位或行，我們所
用的屬性如下：
x'20' 正常 Normal
x'21' 反白 Reverse
x'22' 高亮度 HI
x'23' 高亮度反白 HI reverse
x'28' 紅色 Red
x'29' 紅色反白 Red reverse
x'2A' 閃爍 Blink
x'2B' 閃爍反白 Blink reverse
為了要定義警示性區間，我們使用 SQL CASE 指令，類似 RPG IV 的 CASE 指令
+-------------------------------------------------------------------------------+
| |
| |
| +-ELSE NULL---------------+ |
| >--CASE----searched-when-clause----+-------------------------+--END---------> |
| +-simple-when-clause---+ +-ELSE--result-expression-+ |
| |
| searched-when-clause: |
| <-----------------------------------------------------+ |
| +----WHEN--search-condition--THEN----result-expression----------------------| |
| +-NULL--------------+ |
| |
| simple-when-clause: |
| <-----------------------------------------------+ |
| +--expression----WHEN--expression--THEN----result-expression----------------| |
| +-NULL--------------+ |
| |
+-------------------------------------------------------------------------------+
在底下的例子中，我們顯示系統中檔案欄位數超過 100個的檔案，反白區是檔案欄位數超過 250 個，
紅色區是檔案欄位數超過 1000 個，紅色閃爍區是檔案欄位數超過 2500 個。
啟動 SQL --> STRSQL
Enter SQL Statements
Type SQL statement, press Enter.
===> SELECT CASE
WHEN count(*) > 2500 THEN (X'2A'||SYSTEM_TABLE_SCHEMA||X'28')
WHEN count(*) > 1000 THEN (X'28'||SYSTEM_TABLE_SCHEMA)
WHEN count(*) > 250 THEN (X'22'||SYSTEM_TABLE_SCHEMA)
else (' '||SYSTEM_TABLE_SCHEMA)
end AS LIB,
SYSTEM_TABLE_NAME AS TABLE,
COUNT(*) AS FIELDS
FROM QSYS2/SYSCOLUMNS
group by system_table_schema, system_table_name
having count(*) > 100
Bottom
F3=Exit F4=Prompt F6=Insert line F9=Retrieve F10=Copy line
F12=Cancel F13=Services F24=More keys
2001-11-07 如何顯示某些處理程序的百分比狀況？
如何顯示某些處理程序的百分比狀況？
某些程序可能需要較長的時間處理，例如 On-Line 處理大批資料時，系統僅顯示輸入暫停，
使用者根本不知道系統處理進度，也不知何時可以完成該項工作，往往會影響到使用者的工
作效率，所以在開發應用軟體時，針對耗時的程序，最好要考慮回應處理狀況給使用者。
File : QRPGLESRC
Member : PROGSMSGR
Type : RPGLE
Usage : CRTBNDRPG PROGSMSGR
Call PROGSMSGR
H DEBUG OPTION(*SRCSTMT:*NODEBUGIO)
*====================================================================*
* Progress Percentage Message *
*--------------------------------------------------------------------*
* *
* 2001/11 Vengoal Chang *
*--------------------------------------------------------------------*
Fimtmpf if e k disk infds(infdsx)
*---------------------------------------------------------------------
D infdsx ds
D NbrOfRcds 10i 0 overlay(infdsx:156)
D TwoPercent s 10u 0 inz(0)
D RecordCnt s 10u 0 inz(0)
D PercentComp s 10u 0 inz(0)
D InPrgVary s 50 varying
D InProgressMsg s 50
D ConstantPeriod s 50 inz(*all'.')
* -------------------------------------------------------------
D qmhsndpm PR ExtPgm('QMHSNDPM') SEND MESSAGES
D 7 const ID
D 20 const FILE
D 73 const TEXT
D 10i 0 const LENGTH
D 10 const TYPE
D 10 const QUEUE
D 10i 0 const STACK ENTRY
D 4 const KEY
Db like(vApiErrDS)
*----------------------------------------------------------------
D vApiErrDs ds
D vbytpv 10i 0 inz(%size(vApiErrDs)) bytes provided
D vbytav 10i 0 inz(0) bytes returned
D vmsgid 7a error msgid
D vresvd 1a reserved
D vrpldta 50a replacement data
C eval TwoPercent=%int((NbrOfRcds/100)*2)
C
C read imtmpf
C Dow not %eof
C exsr srInProgress
C read imtmpf
C Enddo
C eval *inLR = *on
* ---------------------------------------------------------------------
C srInProgress begsr
C eval RecordCnt = RecordCnt + 1
1B C if %rem(RecordCnt:TwoPercent)=0
C eval InPrgVary=InPrgVary+'>'
C eval InProgressMsg=InPrgVary+ConstantPeriod
C eval PercentComp=PercentComp+2
* Send status message
C callp QMHSNDPM(
C 'CPF9898':'QCPFMSG *LIBL ':
C %char(PercentComp) + '% completed: ' +
C InProgressMsg :
C 65:'*STATUS':'*EXT': 1:' ':
C vApiErrDS)
1E C endif
C endsr
您可將 File IMTMPF 改成您要處理的檔案再 Compile。
2001-11-05 如何讓您的 ＲＰＧ 程式發出 beep 聲音？以提醒使用者某些工作已完成
如何讓您的 ＲＰＧ 程式發出 beep 聲音？以提醒使用者某些工作已完成
FILE : QRPGLESRC
Member : BEEPR
Type : RPGLE
Usage : CRTBNDRPG BEEPR DFTACTGRP(*NO)
H DFTACTGRP(*NO) BNDDIR('QSNAPI')
Dbeep pr extproc('QsnBeep')
Dhandle 9b 0 value
Dhandle2 9b 0 value
Derrcode 10 OPTIONS(*OMIT)
Dreturn 9b 0 Options(*OMIT)
C callp(e) beep(0:0:*omit:*OMIT)
C eval *inlr = *on
參考資料
Generate a Beep (QsnBeep) API
http://publib.boulder.ibm.com/pubs/html/as400/v5r1/ic2924/info/apis/QsnBeep.htm
2001-10-22 如何從一文字(DDS A type)欄位擷取 Packed (DDS P type)形態的數字？
如何從一文字(DDS A type)欄位擷取 Packed (DDS P type)形態的數字？
有時候您的資料若是從其他較舊的系統如 S/36 或是從 IBM mainframe 上取得，
有可能某些欄位定義是文字格式，但是其內容為卻又是 Packed 形態的數字，那你
就必須依其應該有的格式將他轉為 Packed 形態的數字，才能用來處理計算式，或
直接將舊有資料轉為 AS/400 新格式以利後續處理。
底下的範例是，處理 2 位文字但其內含 3 位長度的 packed數字，有兩個函數，一
個是處理 3 位整數，沒有小數；而另一個函數是處理 1 位整數，兩位小數。
*--------------------------------------------------------------*
* Vengoal Chang Development Resource Copyright 2001.10 *
* *
* \\\\\\\ *
* ( o o ) *
*-------------------oOO----(_)----OOo--------------------------*
* *
* System name . . . : Technical Support *
* Text . . . . . . . : Convert Character filed to Packed Num *
* *
* Author . . . . . . : Vengoal Chang *
* *
* ooooO Ooooo *
* ( ) ( ) *
*-----------------( )-------------( )----------------------*/
* (_) (_) */
* */
* */
*Extracting Packed Data From A Character Field */
* */
* Complied with command CRTBNDRPG CVTCHR2PK */
* */
* Example : CALL CVTCHR2PK X'123F' will display 123 and 1.23 */
* CALL CVTCHR2PK X'1234' will display "Invalid" */
* CALL CVTCHR2PK X'123D' will display 123- and 1.23- */
* */
*--------------------------------------------------------------*/
H dftactgrp(*NO)
D GetDec_03_00 pr N
D charin 2 const
D pckout 3p 0
D GetDec_03_02 pr N
D charin 2 const
D pckout 3p 2
D packOut30 S 3p 0
D packOut32 S 3p 2
D tempStr S 20
D error S N
C *entry Plist
C Parm Char 2
C Eval Error= GetDec_03_00(Char : packOut30)
C If Not Error
C Eval tempStr = %editc(packOut30 : 'L')
C 'Packed 3,0' Dsply tempStr
C EndIf
C Eval Error= GetDec_03_02(Char : packOut32)
C If Not Error
C Eval tempStr = %editc(packOut32 : 'L')
C 'Packed 3,2' Dsply tempStr
C EndIf
C Eval *InLr = *On
*===========================================================
*Assume that a input field has a three-digit packed
*decimal values with zero decimal positions
*===========================================================
P GetDec_03_00 b export
D pi N
D charin 2 const
D pckout 3p 0
D charout ds 2
D decout 3p 0
D*--- PACKED FIELD MANIPULATION
D PCK S 1 DIM(16)
D PCKC S 16
D idx S 2 0 inz(1)
*-- PACKED NUMERIC DATA STRUCTURES
D PNUMD0 DS INZ
D PNUM0 1 16P 0
D PACKEVEN
D*-- VALID PACKED SIGNS
D C@PKSN c const(
D X'0F1F2F3F4F5F6F7F8F9F-
D 0D1D2D3D4D5D6D7D8D9D-
D 0C1C2C3C4C5C6C7C8C9C')
* calcs to verify that charin is valid packed data
C move charin PCKC
C Z-ADD *ZEROS PNUM0
C MOVEA PNUMD0 PCK
C MOVEA PCKC PCK
*-- CHECK EACH BYTE
C DO 16 idx
C PCK(idx) IFGE X'00'
C PCK(idx) ANDLE X'99'
C idx ANDNE 16
C ITER
C ENDIF
*
*-- ON THE LAST BYTE, CHECK FOR VALID SIGNS
C idx IFEQ 16
C C@PKSN CHECK PCK(idx) 80
C N80 LEAVE
C ENDIF
*
*-- INVALID DIGIT FOUND
*
C 'Invalid' Dsply
C ENDDO
C If *In80 = *Off
C eval charout = charin
C eval pckout = decout
C return *Off
C Else
C return *On
C EndIf
P e
*===========================================================
*Assume that a input field has a three-digit packed
*decimal values with two decimal positions
*===========================================================
P GetDec_03_02 b export
D pi N
D charin 2 const
D pckout 3p 2
D charout ds 2
D decout 3p 2
D*--- PACKED FIELD MANIPULATION
D PCK S 1 DIM(16)
D PCKC S 16
D idx S 2 0 inz(1)
*-- PACKED NUMERIC DATA STRUCTURES
D PNUMD0 DS INZ
D PNUM0 1 16P 0
D PACKEVEN
D*-- VALID PACKED SIGNS
D C@PKSN c const(
D X'0F1F2F3F4F5F6F7F8F9F-
D 0D1D2D3D4D5D6D7D8D9D-
D 0C1C2C3C4C5C6C7C8C9C')
* calcs to verify that charin is valid packed data
C move charin PCKC
C Z-ADD *ZEROS PNUM0
C MOVEA PNUMD0 PCK
C MOVEA PCKC PCK
*-- CHECK EACH BYTE
C DO 16 idx
C PCK(idx) IFGE X'00'
C PCK(idx) ANDLE X'99'
C idx ANDNE 16
C ITER
C ENDIF
*
*-- ON THE LAST BYTE, CHECK FOR VALID SIGNS
C idx IFEQ 16
C C@PKSN CHECK PCK(idx) 80
C N80 LEAVE
C ENDIF
*
*-- INVALID DIGIT FOUND
*
C 'Invalid' Dsply
C ENDDO
C If *In80 = *Off
C eval charout = charin
C eval pckout = decout
C return *Off
C Else
C return *On
C EndIf
P e
2001-10-18 如何於 Interactive SQL 環境中直接執行 CL Command？
如何於 Interactive SQL 環境中直接執行 CL Command？
當你執行 STRSQL 指令，進入輸入 SQL 指令畫面，執行某些 SQL 指令（如 Select * from
library/file）後，有時可能會需要執行某些CL 指令（如 WRKACTJOB），這時你必須離開 SQL
環境，回到 Command Line 才能執行 CL 指令，然後再執行 STRSQL 指令，進入輸入 SQL 指令
畫面執行為完成的 SQL 指令，如此進進出出非常浪費時間，有四兩種方式可以直接於 SQL 環境中直
接執行 CL 指令，兩種使用 SQL PROCEDURE，另兩種直接呼叫系統程式，以上四種你高興用哪個就用哪個。
1. 於 SQL 環境中，建立 呼叫系統程式 QCMDEXC 的 PROCEDURE 如下：
Command Line : STRSQL 進入 輸入 SQL 指令畫面，並輸入如下：
Enter SQL Statements
Type SQL statement, press Enter.
===> CREATE PROCEDURE your-library/exccmd
(IN cmd CHAR (32000), IN len DEC (15,5))
LANGUAGE CL
NOT DETERMINISTIC
NO SQL
EXTERNAL NAME QSYS/QCMDEXC
PARAMETER STYLE GENERAL
Bottom
F3=Exit F4=Prompt F6=Insert line F9=Retrieve F10=Copy line
F12=Cancel F13=Services F24=More keys
你要將 your-library 改成你自己的 library ，接著按執行鍵產生 exccmd PROCEDURE，
此 cmd PROCEDURE第一個參數是 CL 指令，第二個參數是 CL 指令的長度。
你可在 Enter SQL Statements 畫面輸入 Call exccmd ('WRKACTJOB', 9)，此時系統會
執行 WRKACTJOB 指令的畫面，按 F3 回到 Enter SQL Statements 畫面。
2. 於 SQL 環境中，建立 呼叫系統程式 QUSCMDLN 的 PROCEDURE 如下：
Command Line : STRSQL 進入 輸入 SQL 指令畫面，並輸入如下：
Enter SQL Statements
Type SQL statement, press Enter.
===> CREATE PROCEDURE chancy/cmd
LANGUAGE CL
NOT DETERMINISTIC
NO SQL
EXTERNAL NAME QSYS/QUSCMDLN
PARAMETER STYLE GENERAL
Bottom
F3=Exit F4=Prompt F6=Insert line F9=Retrieve F10=Copy line
F12=Cancel F13=Services F24=More keys
你要將 your-library 改成你自己的 library ，接著按執行鍵產生 cmd PROCEDURE，
你可在 Enter SQL Statements 畫面輸入 Call cmd，此時會出現在 SEU 環境中按 F21
相同的指令畫面視窗，按 F12 回到 Enter SQL Statements 畫面。
3. 於 SQL 環境中，直接呼叫 QCMD 進入 Command Entry 畫面，按 F3 回到 Enter SQL Statements 畫面。
Command Line : STRSQL 進入 輸入 SQL 指令畫面，並輸入如下：
Enter SQL Statements
Type SQL statement, press Enter.
===> call qcmd
Bottom
F3=Exit F4=Prompt F6=Insert line F9=Retrieve F10=Copy line
F12=Cancel F13=Services F24=More keys
Command Entry WTWNAS01
Request level: 2
Previous commands and messages:
(No previous commands or messages)
Bottom
Type command, press Enter.
===>
F3=Exit F4=Prompt F9=Retrieve F10=Include detailed messages
F11=Display full F12=Cancel F13=Information Assistant F24=More keys
4. 於 SQL 環境中，直接呼叫 QUSCMDLN 進入 Command 視窗畫面，按 F12 回到 Enter SQL Statements 畫面。
Command Line : STRSQL 進入 輸入 SQL 指令畫面，並輸入如下：
Enter SQL Statements
Type SQL statement, press Enter.
===> call QSYS/QUSCMDLN
Bottom
F3=Exit F4=Prompt F6=Insert line F9=Retrieve F10=Copy line
F12=Cancel F13=Services F24=More keys
Enter SQL Statements
Type SQL statement, press Enter.
===> call QSYS/QUSCMDLN
..............................................................................
: Command :
: :
: ===> :
: F4=Prompt F9=Retrieve F12=Cancel :
: :
:............................................................................:
2001-09-25 如何於 CLP 或 RPG 中判斷使用者按下 F3 或 F12 取消 RUNQRY 指令 ？
如何於 CLP 或 RPG 中判斷使用者按下 F3 或 F12 取消 RUNQRY 指令 ？
由於執行 RUNQRY 且指定參數“是否篩選資料“ RCDSLT(*YES)時，
系統會顯示條件畫面供使用者輸入條件，如下：
Select Records
Type comparisons, press Enter. Specify OR to start each new group.
Tests: EQ, NE, LE, GE, LT, GT, RANGE, LIST, LIKE, IS, ISNOT...
AND/OR Field Test Value (Field, Number, 'Characters', or ...)
PH04 GE 19970101
AND PH04 LE 19971231
Bottom
Field Text Len Dec
PH05 VENDOR NO. 6
PH13 AMOUNT 11 2
PH04 RECEIVE DATE 8 0
PH01 BATCH NO. 7
PH02 PO NO. 9
More...
F3=Exit F9=Insert F11=Display names only F12=Cancel
F18=Files F19=Next group F20=Reorganize F24=More keys
(C) COPYRIGHT IBM CORP. 1988
此時使用者可按 F3 或 F12 取消 RUNQRY 指令，
但此時系統並不會有 CPF6801 "Command prompting ended when user pressed F3."
的訊息出現，所以您無法於 CLP 中使用 MONMSG CPF6801 來偵測使用者是否按下 F3 或 F12，
必須使用 System API 來擷取使用者是否按下 F3 或 F12。
------------------------------------------------------------------------------
使用 QUSRJOBI (Retrieve Job Information) API CLP 範例
可使用 QUSRJOBI (Retrieve Job Information) API.
CLP 範例 GETEXITC（Compiled with CRTCLPGM GETEXITC）如下：
dcl &a_len *char 4 /* Bin Data/Entry length */
dcl &a_rcv *char 1000 /* Receiver Variable, the */
/* length is variable. It */
/* must be in &A_LEN. */
dcl &msgdta *char 256
dcl &Action *char 20 +
value( 'RUNQRY RCDSLT(*YES)' )
runqry Range1 outtype(*PRINTER) rcdslt(*YES)
/* ---------------------------------------------------*/
/* Test for cancel */
/* ---------------------------------------------------*/
chgvar %bin( &a_len 1 4 ) 307
call QUSRJOBI ( +
&a_rcv +
&a_len +
'JOBI0600' +
'*' +
' ' +
)
/* Test job status for *CANCEL (F12) */
if ( %sst( &a_rcv 104 1 ) *eq '1' ) do
chgvar &msgdta ( +
'Action' *bcat +
&Action *bcat +
'cancelled.' +
)
sndpgmmsg msgid( CPF9897 ) +
msgf( QSYS/QCPFMSG ) +
msgdta( &msgdta ) +
msgtype( *INFO )
return
enddo
/* Test job status for *EXIT (F3) */
if ( %sst( &a_rcv 103 1 ) *eq '1' ) do
chgvar &msgdta ( +
'Action' *bcat +
&Action *bcat +
'cancelled.' +
)
sndpgmmsg msgid( CPF9897 ) msgf( QSYS/QCPFMSG ) +
msgdta( &msgdta ) +
msgtype( *INFO )
return
enddo
/* ---------------------------------------------------*/
/* RUNQRY was not canceled */
/* ---------------------------------------------------*/
---------------------------------------------------------
使用 QWCRTVCA 及 QWCCCJOB API 的 RPG 範例
可使用 QWCRTVCA (Retrieve Current Attributes) API擷取job F3 及 F12 屬性旗標，
然後使用 QWCCCJOB (Change Current Job) API 重設 job F3 及 F12 屬性旗標.
使用 API 的 RPG 範例 GETEXITR (Compiled with "CRTBNDRPG GETEXITR")如下：
**-- Parameter: --------------------------------------------
D Fkey s 3
**-- QWCRTVCA API: ----------------------------------------
D CurAtr Ds
D AtNbrAtrRtn 10i 0
D AtAtrLen1 10i 0
D AtAtrKey1 10i 0
D AtAtrDtaTyp1 1a
D 3a
D AtAtrDtaLen1 10i 0
D F12 1n
D 3a
D AtAtrLen2 10i 0
D AtAtrKey2 10i 0
D AtAtrDtaTyp2 1a
D 3a
D AtAtrDtaLen2 10i 0
D F3 1n
D 3a
**
D CurAtrLen s 10i 0 Inz( %Len( CurAtr ))
D FmtNam s 8a Inz( 'RTVC0100' )
D KeyFldNbr s 10i 0 Inz( 2 )
D KeyFlds Ds
D 10i 0 Inz( 301 )
D 10i 0 Inz( 503 )
**-- QWCCCJOB API: ----------------------------------------
D ChgAtr Ds
D CaAtrFldNbr 10i 0 Inz( 2 )
D CaAtrKey1 10i 0 Inz( 1 )
D CaAtrLen1 10i 0 Inz( 1 )
D CaAtrVal1 1a Inz( '0' )
D CaAtrKey2 10i 0 Inz( 2 )
D CaAtrLen2 10i 0 Inz( 1 )
D CaAtrVal2 1a Inz( '0' )
**
D ApiError Ds
D AeBytAvl 10i 0 Inz( 8 )
D AeBytRtn 10i 0 Inz( 0 )
**
C *Entry Plist
C Parm Fkey
**
C Call 'QWCRTVCA'
C Parm CurAtr
C Parm CurAtrLen
C Parm FmtNam
C Parm KeyFldNbr
C Parm KeyFlds
C Parm ApiError
**
C Call 'QWCCCJOB'
C Parm ChgAtr
C Parm ApiError
**
C Select
C When F3
C Eval Fkey = 'F3'
C When F12
C Eval Fkey = 'F12'
C Other
C Eval Fkey = *Blanks
C EndSl
**
C Return
測試 使用 API 的 RPG 範例 GETEXITRTC (Compiled with "CRTCLPGM GETEXITRC")如下：
DCL &FKEY *CHAR 3
DCL &MSGDTA *CHAR 256
DCL &ACTION *CHAR 20 +
VALUE( 'RUNQRY RCDSLT(*YES)' )
RUNQRY VENDOR97 RCDSLT( *YES ) OUTTYPE( *PRINTER )
CALL GETEXITR &FKEY
IF ( &FKEY *GT ' ' ) GOTO ENDPGM
/* ...CONTINUE PROCESSING */
ENDPGM:
CHGVAR &MSGDTA ( 'You pressed' *BCAT +
&FKEY *BCAT +
'ACTION' *BCAT +
&ACTION *BCAT +
'CANCELLED.' +
)
QSYS/SNDPGMMSG MSGID( CPF9897 ) +
MSGF( QSYS/QCPFMSG ) +
MSGDTA( &MSGDTA ) +
MSGTYPE( *INFO )
ENDPGM
參考資料
1. Retrieve Job Information (QUSRJOBI) API
http://publib.boulder.ibm.com/pubs/html/as400/v5r1/ic2924/info/apis/qusrjobi.htm
2. Retrieve Current Attributes (QWCRTVCA) API
http://publib.boulder.ibm.com/pubs/html/as400/v5r1/ic2924/info/apis/qwcrtvca.htm
3. Change Current Job (QWCCCJOB) API
http://publib.boulder.ibm.com/pubs/html/as400/v5r1/ic2924/info/apis/qwcccjob.htm
訂閱：
文章 (Atom)