Joined: 14 Jan 2008 Posts: 2501 Location: Atlanta, Georgia, USA
Below, please find CICS/Assembler program "DATETIME", which uses the z/OS "TIME" Macro (LINKAGE=SYSTEM) and returns the Current Gregorian-Date, FMT=CL8'CCYYMMDD', the Current-Time, FMT=CL12'HHMMSSTHMIJU' (M=Milliseconds, I=Ten-Thousandths, J=Hundred-Thousandths and U=Microseconds), the Current Julian-Date, FMT=CL7'CCYYDDD' and the Time Macro Reason-Code, FMT=CL4, ideally with ZEROS.
Internal comments should suffice for usage.
Code:
*PROCESS RENT PROGRAM IS RE-ENTRANT
*ASM XOPTS(NOEPILOG,SP) SUPPRESS EPILOGUE, ACTIVATE SP
***********************************************************************
*---------------------------------------------------------------------*
* *
* THIS SUB-PROGRAM WILL RETURN THE CURRENT-GREGORIAN DATE, THE *
* CURRENT-TIME AND THE CURRENT JULIAN-DATE, WITH FORMATS OF *
* C'CCYYMMDD', C'HHMMSSTHMIJU' AND C'CCYYDDD', RESPECTIVELY. *
* *
* EXAMPLE COMMAREA - *
* *
* 03 WS-DATETIME-COMMAREA. *
* 05 WS-DATETIME-GREGORIAN *
* PIC 9(08). *
* 05 WS-DATETIME-CURR-TIME *
* PIC 9(12). *
* 05 WS-DATETIME-JULIAN *
* PIC 9(07). *
* 05 WS-DATETIME-RSN-CODE *
* PIC 9(04). *
* 03 WS-DATETIME PIC X(08) VALUE 'DATETIME'. *
* *
* THE COMMAREA DOES NOT NEED TO BE INITIALIZED. *
* *
* EXEC CICS LINK *
* PROGRAM (WS-DATETIME) *
* COMMAREA(WS-DATETIME-COMMAREA) *
* LENGTH (LENGTH OF WS-DATETIME-COMMAREA) *
* END-EXEC. *
* *
* THE RETURN-CODE IS RETURNED IN R15 TO THE CALLER, OTHERWISE *
* KNOWN AS THE RETURN-CODE SPECIAL-REGISTER FOR COBOL-CALLERS. *
* *
* A NON-ZERO VALUE IN 'WS-DATETIME-RSN-CODE', ALONG WITH A *
* NON-ZERO VALUE IN R15, INDICATES A PROBLEM ISSUING THE TIME *
* MACRO. *
* *
* OTHERWISE, A NON-ZERO VALUE IN R15 INDICATES A PROBLEM WITH *
* THE 'GETMAIN' API WHEN 'STGPROT' IS DETECTED AS 'ACTIVE'. *
* *
* THE 'PPT' ENTRY MUST BE DEFINED AS EXECUTION-KEY = 'CICS' *
* AND _N O T_ 'USER'. *
* *
* THIS SUB-PROGRAM ADDRESSES THE 'CSA' DSECT, THEN ON TO THE *
* 'SIT' DSECT, IN ORDER TO DETERMINE WHETHER 'STGPROT' IS ON *
* OR OFF. IF 'ON', THEN A 16-BYTE GETMAIN OF 'CICSDATAKEY' IS *
* ISSUED, IN ORDER TO AVOID A 'S0C4'. A SUBSEQUENT FREEMAIN IS *
* ISSUED BEFORE RETURNING TO THE CALLER. *
* *
*---------------------------------------------------------------------*
***********************************************************************
PRINT NOGEN SUPPRESS MACRO-EXPANSION
PRINT OFF SUPPRESS PRINTING
DFHCSAD TYPE=DSECT CSA-DSECT
DROP R13 MERELY A FORMALITY
DFHSIT TYPE=DSECT,JVMCCPROFILE=DFHJVMCC, X
JVMPROFILEDIR='/usr/lpp/cicsts/cicsts42/JVMProfiles'
DFHAFCD TYPE=DSECT AFCB-DSECT
PRINT GEN ACTIVATE MACRO-EXPANSION
PRINT ON ACTIVATE PRINTING
COMDSECT DSECT COMMAREA DSECT (R7)
USING *,R7 INFORM ASSEMBLER
COMMAREA EQU * BEGIN COMMAREA
COMMGREG DS CL8 GREGORIAN-DATE AS C'CCYYMMDD'
COMMTIME DS CL12 CURRENT-TIME AS C'HHMMSSTHMIJU'
COMMJULN DS CL7 JULIAN-DATE AS C'CCYYDDD'
COMMRSNC DS CL4 REASON-CODE (FROM TIME-MACRO)
COMMLGTH EQU *-COMMAREA COMMAREA-LGTH
DFHEISTG DSECT DYNAMIC-STG (R13)
DWORD DS D ALIGNED-DBLWORD
PROTCVDA DS F STG-PROTECTION CVDA
RETNCODE DS H RETURN-CODE HWORD
TIMEWORK DS XL16 STG-AREA FOR 'TIME' MACRO (KEY9)
WORKUNPK DS CL(L'TIMEWORK) UNPACK-WORKAREA
TIMELIST TIME LINKAGE=SYSTEM,MF=L TIME MACRO-LIST
DATETIME DFHEIENT CODEREG=R3,DATAREG=R13,EIBREG=R11
LA R15,4095 PREPARE FOR 'STH'
STH R15,RETNCODE STORE IN HWORD
LH R15,EIBCALEN PREPARE FOR 'CHI'
CHI R15,COMMLGTH MINIMUM-LGTH?
BL CICSRETN NO, RETURN TO THE CALLER
XC DFHEIUSR(DFHEIEND-DFHEIUSR),DFHEIUSR
L R7,DFHEICAP COMMAREA-ADDRESSABILITY
MVI COMMAREA,C'0' ENSURE ALL ZEROS
MVC COMMAREA+1(COMMLGTH-1),COMMAREA
LA R9,TIMEWORK POINT TO TIME-WORKAREA (KEY9)
DFHAFCD TYPE=LOCATE ESTABLISH ADDRESSABILITY (R15)
L R15,AFCSA-DFHAFCB(,R15) CSA-ADDRESSABILITY
L R15,CSASITBA-DFHCSADS(,R15)
TM SITCICSF-DFHSITDS(R15),SITSTPRO
BZ ISSUTIME NO, ISSUE TIME-MACRO
XR R9,R9 CLEAR FOR 'GETMAIN'
MVC PROTCVDA,DFHVALUE(ACTIVE)
LA R15,L'TIMEWORK PREPARE FOR 'ST'
ST R15,DWORD+4 STORE IN 2ND-WORD FOR 'GETMAIN'
*
EXEC CICS GETMAIN NOHANDLE, GET CICS KEY8 STG, WHEN X
SET (R9), STG-PROTECT IS ACTIVE, DUE TO X
FLENGTH(DWORD+4), TIME-MACRO TRANSFERRING TO/FROM X
INITIMG(DWORD), DIFFERENT LPARS ('PC' AND 'PT' X
CICSDATAKEY, INSTRUCTIONS) AND AVOID 'S0C4'
*
ICM R15,B'1111',EIBRESP GOOD RESPONSE-CODE?
STH R15,RETNCODE STORE AS HWORD
BNZ CICSRETN NO, RETURN TO THE CALLER
ISSUTIME EQU *
*
TIME DEC,0(,R9),LINKAGE=SYSTEM,ZONE=LT,DATETYPE=YYYYMMDD, X
MF=(E,TIMELIST)
*
LTR R15,R15 GOOD RETURN-CODE?
STH R15,RETNCODE STORE AS HWORD
BZ UPDEIBDT YES, UPDATE EIBDATE/EIBTIME
CVD R0,DWORD MAKE IT DECIMAL
OI DWORD+L'DWORD-1,X'0F' ENSURE 'F' SIGN-NIBBLE
UNPK COMMRSNC,DWORD UNPACK 'REASON-CODE'
CLC PROTCVDA,DFHVALUE(ACTIVE)
BNE CICSRETN NO, RETURN TO THE CALLER
B ISSUFREE ISSUE 'FREEMAIN'
UPDEIBDT EQU *
*
EXEC CICS ASKTIME NOHANDLE, UPDATE EIBDATE/EIBTIME
*
UNPK COMMJULN,EIBDATE POPULATE AS C'01YYDDD'
OI COMMJULN+L'COMMJULN-1,X'F0'
UNPK WORKUNPK(L'COMMGREG+1),8(5,R9)
MVC COMMGREG,WORKUNPK POPULATE AS C'CCYYMMDD'
MVC COMMJULN(1),WORKUNPK INSERT JULIAN-CENTURY
UNPK WORKUNPK(L'COMMTIME+1),0(7,R9)
MVC COMMTIME,WORKUNPK POPULATE AS C'HHMMSSTHMIJU'
CLC PROTCVDA,DFHVALUE(ACTIVE)
BNE CICSRETN NO, RETURN TO THE CALLER
ISSUFREE EQU *
*
EXEC CICS FREEMAIN, FREE THE KEY8 STG, SUPPRESSING X
DATAPOINTER(R9), ALL ERRORS, FALLTHRU AND RETURN X
NOHANDLE, TO THE CALLER
*
CICSRETN EQU *
LH R15,RETNCODE RETURN-CODE HWORD
*
DFHEIRET RCREG=R15 RETURN TO THE CALLER
*
DFHREGS , CICS REGISTER-MACRO
*
LTORG ,
*
DATETIME AMODE 31 ,
DATETIME RMODE ANY ,
*
END , END 'DATETIME'
Hi Bill,
It's a cute program, it reminds me my good days of coding Assembler with macro-level CICS.
I just wonder: what for?
Issuing EXEC CICS ASKTIME ABSTIME(var1) and
EXEC CICS FORMATTIME ABSTIME(var1) YYYYDDD(Julian date var) and/or all other formats of date and time provide you with all your needs...
One exception I can think about is: the need of current time without changing the EIB's values within a transaction, since ASKTIME sets EIBTIME. But, you do issue an EXEC CICS ASKTIME in the code...
All the best,
Haim Zeevi
Joined: 14 Jan 2008 Posts: 2501 Location: Atlanta, Georgia, USA
Hello Haim,
Actually, a program such as this is good for a virtual unique Date/Time stamp, with the Time granularity down to the Microsecond.
As far as ABSTIME, prior to CICS/TS 4.1, the low-order data-byte was always X'0C' as the true milliseconds were not included. With the introduction of TS/4.1, the milliseconds are provided. You can also obtain a Time stamp of HHMMSSTHM, via the LE Callable Date service "CEELOCT", which has always included milliseconds.
However, milliseconds may not be enough for uniqueness and this is why granularity down to the Microsecond is a better choice/option.
As far as issuing an ASKTIME, it's merely to obtain the current Julian YYDDD. Issuing an additional Time Macro to obtain the CCYYDDD Julian-Date is unneeded overhead.
Thanks Bill, you're right: the microseconds make the difference.
Same as in DB2, where IDENTITY feature was added to ensure uniqueness, since microseconds didn't provide enough precision...
Best regards to Dixie from Israel...
Haim Zeevi
