*PROCESS MARGINS(2,132);
  /******************************************************************/
  /* DCOMMON blocks are chained to RCOMMON, initialised by DBNAME   */
  /* where _initDcommon returns a handle to be stored in user       */
  /* common area and used in subsequent get/set operations          */
  _Dcommon: proc returns(fixed bin(31) byaddr);
     Dcl (addr, null, trim, substr)              builtin;
     Define alias HANDLE           pointer;
     DCL fname                     char(32),
         dbname                    char(16),
         c64                       char(64),
         (rptr,dptr,dbptr)         pointer;
     Dcl rname                     char(32) init("REG_FIRST_DCOMMON");
     /* the primary procedure should not be called */
     return(16);

  _initDcommon: ENTRY(dbname) returns(pointer byaddr);
     if reg_area_xptr=null then return(null);
     if rcom_xptr=null then return(null);
     dcommptr=null;
     dptr=_fndDcommon(dbname); /* test exist */
     if dptr = null then do;
        ALLOCATE DCOMMON IN (reg_area) SET(dcommptr);
        dcommon.run_number = 1;
        dcommon.db_name = substr(dbname,1,16);
        dcommon.max_users = 4096;
        dcommon.prev_dcommon = null;
        dcommon.next_dcommon = _getRcommonP(rname);
        if _setRcommonP(rname,dcommptr)>0 then STOP;
        end;
     return(dcommptr);

  /* find existing DCOMMON block named DBNAME in chain */
  _fndDcommon: ENTRY(dbname) returns(pointer byaddr);
     do rptr = _getRcommonP(rname)
        repeat (rptr ->dcommon.next_dcommon)
        while  (rptr ^= null);
        if  rptr->dcommon.db_name = dbname then return(rptr);
        end;
     return(null);

  /* set routines always return a return code = value validation */
  _setDcommonC: ENTRY(dbptr,fname,C64) returns(fixed bin(31) byaddr);
     if dbptr = null then return(16);
     /* check DCOMMON seems valid? */
     dcommptr = dbptr;  if dcommon.run_number > 0 then;
     SELECT(fname);
        when("DB_NAME")   do; dcommon.db_name   = substr(C64,1,16); return(0); end;
        when("DB_DSNAME") do; dcommon.db_dsname = C64; return(0); end;
        otherwise;
        END;
     return(16);

  _getDcommonC: ENTRY(dbptr,fname) returns(char(64) byaddr);
     if dbptr = null then  return("Error > DBPTR pointer is null");
     /* check DCOMMON seems valid */
     if dbptr->dcommon.run_number > 0 then;
     SELECT(fname);
        when("DB_NAME")   return(dbptr->dcommon.db_name);
        when("DB_DSNAME") return(dbptr->dcommon.db_dsname);
        otherwise;
        END;
     return("unknown field name");

 Dcl Dcommptr                  pointer;
 DCL     1 DCOMMON             BASED(DCOMMPTR),
           2 NEXT_DCOMMON      POINTER,
           2 PREV_DCOMMON      POINTER,
           2 RUN_NUMBER        FIXED BINARY(31),
           2 DB_DSNAME         CHARACTER(64) VARYING,
           2 DB_NAME           CHARACTER(16),
           2 MAX_USERS         fixed bin(31),
           2 and_much_more     char(1024);
 %include _Rcommon;
 end _Dcommon;