IBM Mainframe Forum Index
 
Log In
 
IBM Mainframe Forum Index Mainframe: Search IBM Mainframe Forum: FAQ Register
 

CICS Program "DATETIME"


IBM Mainframe Forums -> CICS
Post new topic   Reply to topic
View previous topic :: View next topic  
Author Message
Bill O'Boyle

CICS Moderator


Joined: 14 Jan 2008
Posts: 2501
Location: Atlanta, Georgia, USA

PostPosted: Mon Nov 11, 2013 8:42 pm
Reply with quote

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'                   

Regards,
Back to top
View user's profile Send private message
haimzeevi

New User


Joined: 01 Mar 2010
Posts: 27
Location: Israel

PostPosted: Thu Nov 14, 2013 1:48 pm
Reply with quote

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
Back to top
View user's profile Send private message
Bill O'Boyle

CICS Moderator


Joined: 14 Jan 2008
Posts: 2501
Location: Atlanta, Georgia, USA

PostPosted: Thu Nov 14, 2013 5:41 pm
Reply with quote

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.

Hope all is well....

Shalom,
Back to top
View user's profile Send private message
haimzeevi

New User


Joined: 01 Mar 2010
Posts: 27
Location: Israel

PostPosted: Thu Nov 14, 2013 6:11 pm
Reply with quote

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
Back to top
View user's profile Send private message
View previous topic :: :: View next topic  
Post new topic   Reply to topic View Bookmarks
All times are GMT + 6 Hours
Forum Index -> CICS

 


Similar Topics
Topic Forum Replies
No new posts How to Login in to cics region and is... CICS 7
No new posts Spoolopen cics CICS 0
No new posts Error to invoke MPP program through B... IMS DB/DC 3
No new posts Check if CICS is online in JCL CICS 10
No new posts Using API Gateway from CICS program CICS 0
Search our Forums:

Back to Top