Black Box 4/BlackBox.cdr/dbase/ccb_fix.arj/CCB_FORM.LST

File List | 1991-06-09 | 113.0 KB | 2,787 lines

    1:  // Module Name: CCB_FORM.COD
    2:  // Description: This module produces dBASE IV .FMT files
    3:  //              with popups or BROWSE for VALID clause field validation
    4:  //              and/or Context Sensitive Help for each field.
    5:  //
    6:
    7:  Format (.fmt) File Template with POPUP or BROWSE field validation
    8:  -----------------------------------------------------------------
    9:  Version 1.11.33
   10:  Ashton-Tate (c) 1987, 1988, 1989, 1990
   11:  Written by Kirk J. Nason & Bill Ramos
   12:
   13:  ════════════════════════════════════════════════════════════════════════════════
   14:           *****  NOT AN OFFICIAL ASHTON-TATE RELEASE OF FORM.GEN  *****
   15:              Key assignments and features could change WITHOUT notice
   16:
   17:  GENERAL NOTE:
   18:    dBASE has a new REQUIRED keyword for the @ GET command. Currently the
   19:    Screen Designer does not have a option for this!  If you want the
   20:    REQUIRED keyword after every VALID use the DOS environment variable:
   21:    SET DTL_REQ=ON and restart dBASE.  NOW every generated VALID will look like
   22:    @ <row>,<col> ... GET <var> VALID REQUIRED <exp>
   23:    This environment variable will be removed at some future date!
   24:
   25:  ════════════════════════════════════════════════════════════════════════════════
   26:
   27:  This template will support POPUPs or BROWSE for VALID clause field validations
   28:  and context sensitive help for each field.  If you choose these features,
   29:  please note the following:  F1: calls the context sensitive help,  F2:(switch to
   30:  edit/browse) is disabled, but if the ZOOM option is used F9 will ZOOM to another
   31:  form,  F6:invokes the "cut" portion of cut/paste,  Ctrl-F5:invokes editing of
   32:  "cut" data, and  F8:invokes the "paste" code,  F7:Allows you to move "windows"
   33:  around.
   34:
   35:  Example:
   36:   In FORM Design - "ACCEPT value when" under "Edit options" enter,
   37:   "POPUP" = "vendor->vendor_id ORDER vendor_id REQ SHADOW ZOOM vendors"
   38:   "BROWSE" ="vendor->vendor_id ORDER vendor_id FIELDS id,name FROM 5,0 TO 6,30"
   39:   -------------------------------------------------------------------------------
   40:   this will activate a popup or BROWSE if the data entered is invalid for
   41:   that field and will also make the field REQUIRED.
   42:
   43:  ************   SET DBTRAP OFF  is required to use these features  ************
   44:
   45:  Explanation of the string follows:
   46:
   47:  POPUP               Indicates that a POPUP will be used for this field.
   48:  BROWSE              Indicates that BROWSE will be used for this field.
   49:  <file>-><fieldname> Indicates the .DBF to open and FIELD to use as validation.
   50:  ORDER <tag name>    Indicates which INDEX TAG to SEEK in.
   51:  REQ                 Indicates the FIELD requires data (can't be left empty).
   52:                      Leave REQ out if the field is NOT required.      OPTIONAL!
   53:  SHADOW              Use shadowing effect on POPUPs or BROWSE.        OPTIONAL!
   54:
   55:  FROM <r,c> TO <r,c> Window coordinates for the BROWSE table.         OPTIONAL!
   56:  FIELDS <fld list>   Field list for the BROWSE table.                 OPTIONAL!
   57:  UPDATE              Allow APPENDing and EDITing of BROWSE table.     OPTIONAL!
   58:                      Note: "FIELDS <fld list>" is REQUIRED for UPDATE
   59:  FORMAT <file name>  Format file to use with BROWSE FORMAT            OPTIONAL!
   60:                      Note: overrides FIELDS <fld list>
   61:  ZOOM <file name>    Format file to use with "ZOOMed" EDIT            OPTIONAL!
   62:                      Note: Zooms to EDIT another FORM based on file->fieldname
   63:                            info above.
   64:  NOTE: The string must be entered with the quotes as in the example.
   65:
   66:  ════════════════════════════════════════════════════════════════════════════════
   67:
   68:  Explanation of the Context Sensitive Help file follows:
   69:
   70:  If you want to create your own help file, here is the structure that is required.
   71:
   72:  Structure for Help Database (.dbf):
   73:  <first 6 chars. of the format filename>_H.dbf
   74:                         ---------------
   75:
   76:  Field   Field Name  Type        Width  Dec   Tag
   77:  -------------------------------------------------
   78:      1   FLD_NAME    Character     10         Yes  Field name to lookup on F1
   79:      2   FLD_HEADNG  Character     25          No  Heading to show user on window
   80:      3   FLD_HELP    Memo          10          No  Help text to show user
   81:  -------------------------------------------------
   82:          Total                     46
   83:  {
   84:  include "ccb_form.def"    // Form selectors
    1:  //---------------------------------------------------------------------------
    2:  // FORM.DEF     NPI form object data selectors
    3:  // Ashton-Tate (c) 1987, 1988
    4:  //
    5:  // Updated 9-21-88 KJN
    6:  //
    7:  // This include file contains all the selectors required for forms.
    8:  // *** DO NOT CHANGE ANY OF THE NUMBERS BELOW ***
    9:  //
   10:  //---------------------------------------------------------------------------
   11:  // NOTE:
   12:  // Selectors listed in the following table which are shown to have
   13:  // "Value: Number" will sometimes return the null string instead
   14:  // of the numeric zero.  For logical compares, null is the same
   15:  // as zero, however when emitting the value to the output file
   16:  // the null string must be converted to a numeric zero explicitly.
   17:  // A user defined function is used in the FORM.COD template program
   18:  // called NUL2ZERO() for converting null strings to explicit numeric
   19:  // zeros.
   20:  //---------------------------------------------------------------------------
   21:  {
   22:  selectors
   23:  #lstoff
  138:  ;
  139:  //
  140:  // Values returned by Fld_Fieldtype
  141:  //
  142:  enum dbf = 0,    // Field from a database
  143:       calc,       // Calculated expression
  144:       sum,        // Summary ie. Average, Count, etc.
  145:       predef,     // Predefined ie. Date, Page, etc.
  146:       memvar;     // Memvar reference
  147:
  148:  enum  on_key_help    = "F1",        // Help procedure key
  149:        on_key_toggle  = "F3"        // Previous screen Toggle
  150:        on_key_recalc  = "F5",        // Recalc expressions - not used yet
  151:        on_key_cut     = "F6",        // Cut data to variable
  152:        on_key_edpaste = "Ctrl-F5",    // Edit Paste data
  153:        on_key_move    = "F7",        // Move active window
  154:        on_key_paste   = "F8",        // Paste Cut Data
  155:        on_key_zoom    = "F9";        // Zoom to Form
  156:
  157:  //
  158:  // Enum string constants for international translation
  159:  //
  160:  enum  wrong_class = "Can't use FORM.GEN on non-form objects.  ",
  161:        form_empty  = "Form design was empty.  ",
  162:        bad_pick    = "Picklist coordinates exceed column 79 - move field left",
  163:        bad_shadow  = "Shadow coordinates exceed column 79 - move field left",
  164:        dbtrap_err  = "ERROR - SET DBTRAP OFF to use this FORM.",
  165:        use_err     = "not found!",
  166:        select_msg1 = "[Select:]+CHR(17)+CHR(196)+CHR(217)+[   Cancel:Esc]",
  167:        select_msg2 = "[   Pan Left:F3   Pan Right:F4   Move Window:" +
  168:                       on_key_move +"]",
  169:        paste_msg1  = " - cut to scrap.   Edit:" + on_key_edpaste +
  170:                      "   Paste:"+ on_key_paste,
  171:        paste_msg2  = "Editing paste string.   Move Window:F7",
  172:        wind_msg1   = "[Position: ]+CHR(27)+CHR(26)+CHR(25)+CHR(24)+[   Exit: Esc]",
  173:        help_msg1   = "Scroll thru Help:Ctrl-Home   Exit Viewing Help:Esc   ",
  174:        help_msg2   = "See Original Screen:" + on_key_toggle,
  175:        hit_any_key = "Hit any key to try again",
  176:        more_info_needed = "You did not enter all the required information"
  177:  ;
  178:
  179:  }
  180:     85:  include "builtin.def" // Builtin functions
    1:  //---------------------------------------------------------------------------
    2:  // BUILTIN.DEF  Template builtin function selectors
    3:  // Ashton-Tate (c) 1987, 1988, 1989, 1990
    4:  //
    5:  // Updated 3-14-90 KJN
    6:  // Added common UDF's to bottom of builtin.def
    7:  //
    8:  // --------------------------------------------------------------
    9:  // Builtin Functions
   10:  // --------------------------------------------------------------
   11:  // This set of selectors designate builtin functions which should
   12:  // appear in templates as <selector>([parm][,parm]...)
   13:  // They must be included in every template.
   14:  //
   15:  // *** DO NOT CHANGE ANY OF THE NUMBERS BELOW ***
   16:  //
   17:  //---------------------------------------------------------------------------
   18:  {
   19:  selectors
   20:  #lstoff
  201:  ;
  202:  }
  203:  {
  204:  //--------------------------------------------------------------
  205:  // Enum Statements for dBASE IV internal Settings
  206:  // Use with functions numset() & strset()
  207:  //
  208:  // For convience this enum declaration has been placed in this
  209:  // file, since they can be used in all design objects
  210:  //--------------------------------------------------------------
  211:  // Enum for numset()
  212:  // Note: FSE = Full Screen Edit
  213:  //
  214:  enum _device_file = 0,  //  0 File handle for SET DEVICE TO <filename>
  215:       _blocksize ,       //  1 Number of 512-byte pages in DBT
  216:       _flgalter ,        //  2 Output routed to alt. file
  217:       _flgbell  ,        //  3 Bell 0:off 1:on
  218:       _flgcarry ,        //  4 Carry 0:off 1:on
  219:       _flgcent  ,        //  5 Use 4-digit years
  220:       _flgclock ,        //  6 Clock 0:off 1:on
  221:       _flgcnfrm ,        //  7 Confirm 0:off 1:on
  222:       _flgcolor ,        //  8 Color set flag 0=b/w 1=cga 2=ega24 4=mono43
  223:                          //                  6=ega43  3 & 5=N/A
  224:       _flgconsole,       //  9 Console 0:off 1:on
  225:       _flgcrypt ,        // 10 File encryption 0:off 1:on
  226:       _flgcursgn,        // 11 Currency symbol display 0:left 1:right
  227:       _flgdebug ,        // 12 Route STEP, ECHO to printer 0:off 1:on
  228:       _flgdelete,        // 13 Deleted records vanish 0:off 1:on
  229:       _flgdelim ,        // 14 Delimiters 0:off 1:on
  230:       _flgdesign,        // 15 Design mode 0:off 1:on
  231:       _flgdev ,            // 16 Always compile file 0:off 1:on
  232:       _flgdohist,        // 17 Do History 0:off 1:on
  233:       _flgecho  ,        // 18 Echo 0:off 1:on
  234:       _flgesc   ,        // 19 Escape 0:off 1:on
  235:       _flgexact ,        // 20 Exact 0:off 1:on
  236:       _flgexcl  ,        // 21 Exclusive 0:off 1:on
  237:       _flgfield ,        // 22 fields 0:off 1:on
  238:       _flgfixed ,        // 23 Fixed point 0:off 1:on
  239:       _flgflush ,        // 24 Autosave 0:off 1:on
  240:       _flghead  ,        // 25 Headings on DISPLAY, SUM, etc. 0:off 1:on
  241:       _flghelp  ,        // 26 Offer help on error 0:off 1:on
  242:       _flghist  ,        // 27 History 0:off 1:on
  243:       _flginstruct,      // 28 Instruct 0:off 1:on
  244:       _flginten ,        // 29 High intensity 0:off 1:on
  245:       _flgmenu  ,        // 30 Put menus up in FSE 0:off 1:on
  246:       _flgnear  ,        // 31 Stay at next record if SEEK/FIND fail 0:off 1:on
  247:       _flgprint ,        // 32 Route output to printer
  248:       _flgscore ,        // 33 FALSE:  screen doesn't use line 0
  249:       _flgscprt ,        // 34 0:@'s to screen 1:  @'s routed to printer
  250:       _flgshare ,        // 35 Allow shared access to databases
  251:       _flgspace ,        // 36 Set space ON/off (for print engine).
  252:       _flgsql,            // 37 0: dBASE mode 1: SQL mode
  253:       _flgsqlcode,       // 38 1: executing SQL generated cmds
  254:       _flgstatus,        // 39 Status 0:off 1:on
  255:       _flgstep,          // 40 Single-step DO files 0:off 1:on
  256:       _flgtalk ,         // 41 Talk 0:off 1:on
  257:       _flgtitle,         // 42 Titles 0:off 1:on
  258:       _flgtrap,            // 43 Trap 0:off 1:on
  259:       _flguniq,          // 44 Indices 0:Non-unique 1: Unique keys
  260:       _flgautolk,        // 45 Automatic lock flag for network 0:off 1:on
  261:       _flgrefresh,       // 46 The refresh count Returns: Number
  262:       _memowidth,        // 47 Displayed width of memo fields Returns: Number
  263:       _mindec,           // 48 Minimum (or fixed) # decimals Returns: Number
  264:       _odometer,         // 49 Interval odometer is updated Returns: Number
  265:       _safety,           // 50 Safety 0:off 1:on
  266:       _setmrgn,          // 51 Printer left margin Returns: Number
  267:       _reprocess,        // 52 Reprocess count Returns: Number
  268:       _nbuffers,         // 53 Maximum number of I/O buffers Returns: Number
  269:       _lenYNOF           // 54 Default max of YES/NO/ON/OFF
  270:  ;
  271:  //
  272:  // Enum for strset()
  273:  // Note: FSE = Full Screen Edit
  274:  //
  275:  enum _getdelim = 0,     //  0 FSE l,r delimiters
  276:       _disp_currency,    //  1 Current FSE currency string
  277:       _def_currency,     //  2 Default FSE currency string
  278:       _lang_type,        //  3 Language type designator string
  279:       _wordproc,            //  4 Program used for memo fields
  280:       _tedit,            //  5 Program used for MODIFY COMMAND
  281:       _dotprompt,        //  6 Dot prompt string
  282:       _sqlprompt,        //  7 Sql prompt string
  283:       _sql_dir,            //  8 Path for SQL system files
  284:       _sql_database,     //  9 Name of SQL system database
  285:       _font_file,        // 10 Name of font file
  286:       _defdrive,            // 11 DBASE default drive
  287:       _disp_period,      // 12 Current display decimal point
  288:       _disp_comma,       // 13 Current FSE separator
  289:       _def_period,       // 14 Default display decimal point
  290:       _def_comma         // 15 Default FSE separator
  291:  ;
  292:  //
  293:  // Enum for Monitor types
  294:  // Values returned by numset(_flgcolor)
  295:   enum mono   = 0,
  296:        cga,
  297:        ega25,
  298:        mono43 = 4,
  299:        ega43  = 6
  300:  ;
  301:  //
  302:  // Values returned by Object Class
  303:  //
  304:   enum app    = 1,  // 1) Application object
  305:        popup,       // 2) Popup object
  306:        f_pick,      // 3) File picklist object
  307:        s_pick,      // 4) Fields picklist object
  308:        v_pick,      // 5) Values picklist object
  309:        bar = 7,     // 7) Horizontal Bar object
  310:                     // 6,8 N/A
  311:        btch   = 9   // 9) Batch object
  312:        form     = 11,
  313:        label    = 12,
  314:        report   = 13,
  315:        table_dbf= 20,
  316:        update   = 21,
  317:        query    = 22,
  318:        catalog  = 23
  319:  ;
  320:  //
  321:  // Values returned Textgetl() or Textgetc() at End of file
  322:  //
  323:  enum eof = -1;
  324:  //
  325:  // Enum string constants for international translation
  326:  //
  327:  enum any_key      = "Press any key ...",
  328:       read_only    = " can't be opened - possible read-only file.  ",
  329:       gen_request  = "Generation request cancelled.  ",
  330:       gen_complete = "Generation is complete.  "
  331:  ;
  332:  //
  333:  // Generic User Defined functions follow
  334:
  335:  define say_center(mrow, mstring)
  336:     // mrow = Row to put string
  337:     // mstring = Text to display to Row position
  338:     enum width_of_screen = 80;
  339:     var mcol;
  340:     mcol = ( width_of_screen / 2) - ( len( mstring)/2)
  341:     cursor_pos( mrow, mcol )
  342:     cput(mstring)
  343:  enddef
  344:
  345:  define say(mrow, mcol, mstring)
  346:     // mrow = Row to put string
  347:     // mcol = Column to put string
  348:     // mstring = Text to display to Row position
  349:     cursor_pos( mrow, mcol )
  350:     cput( mstring )
  351:  enddef
  352:
  353:  define abs(value)
  354:     // Absolute value of a number
  355:     // value = Number to convert to absolute value
  356:     if value < 0 then
  357:       value = val( substr( str( value ), 2))
  358:     endif
  359:     return value;
  360:  enddef
  361:
  362:  define beep(value)
  363:     // Simulate a bell
  364:     // value = Number of times to beep
  365:     var cnt;
  366:     cnt = 1
  367:     do while cnt <= value
  368:        cput( chr(7) )
  369:        cnt = cnt + 1
  370:     enddo
  371:     return;
  372:  enddef
  373:
  374:  define cap_first(string)
  375:     // Takes and returns a string with first letter capped
  376:     return upper( substr( string,1,1)) + lower( substr( string,2))
  377:  enddef
  378:
  379:  define nul2zero(numbr)
  380:     // if number is nul and we are expecting a zero - convert the nul to 0
  381:     return (numbr ? numbr : 0);
  382:  enddef
  383:  }
  384:     86:
   87:  // Enum ON KEY labels AND error strings in FORM.DEF
   88:
   89:  enum  offset = 3,             // Offset for lmarg()
   90:        max_workareas = 8,   // Maximum workareas to leave the files open
   91:        screen_width = 80;    // Screen width for now
   92:  //
   93:
   94:  if FRAME_CLASS != form then // We are not processing a form object
   95:    pause(wrong_class + any_key)
   96:    goto NoGen;
   97:  endif
   98:
   99:  var  fmt_name,     // Format file name
  100:       crlf,         // line feed
  101:       carry_flg,    // Flag to test carry loop
  102:       carry_cnt,    // Count of the number of fields to carry
  103:       carry_len,    // Cumulative length of carry line until 75 characters
  104:       carry_lent,   // Total cumulative length of carry line
  105:       carry_first,  // Flag to test "," output for carry fields
  106:       color_flg,    // Flag to if color should stay on am line
  107:       line_cnt,     // Count for total lines processed (Mulitple page forms)
  108:       page_cnt,     // Count for total pages processed (Mulitple page forms)
  109:       temp,         // tempory work variable
  110:       cnt,          // Foreach loop variable
  111:       wnd_cnt,      // Window counter
  112:       wnd_names,    // Window names so I can clear them at the bottom of the file
  113:       default_drv,  // dBASE default drive
  114:       dB_status,    // dBASE status before entering designer
  115:       scrn_size,    // Screen size when generation starts
  116:       left_delimiter, // Delimiter to put around SAY
  117:       right_delimiter,
  118:       max_pop_row,  // Maximum row that a popup or shadow can start
  119:       display,      // Type of display screen we are on
  120:       is_extensions,// Form extensions
  121:       is_popup,     // POPUP validation requested
  122:       is_help,      // HELP (context sensitive) requested
  123:       is_recalc,    // RECALC for calculated fields is requested
  124:       is_replace,   // REPLACE lookuped fields into the main file ?
  125:       is_zoom,      // ZOOM to form code is requested
  126:       udf_file,     // UDF file has been created
  127:       hlp_name,     // HELP .dbf name
  128:       trow_positn,  // Temporary variable for row_positn
  129:       tcol_positn,  // Temporary variable for col_positn
  130:       at_pop,       // "POPUP" is in FLD_OK_COND
  131:       temp_key,     // store KEY field
  132:       get_list,     // GET's processed on a page
  133:       workarea_cnt, // Workareas USE'd with gen extensions
  134:       workarea_dbfs,// String with all .dbf's USE'd with gen extensions
  135:       color;        // Color returned from getcolor function
  136:
  137:   //-----------------------------------------------
  138:   // Assign default values to some of the variables
  139:   //-----------------------------------------------
  140:   carry_flg = carry_first = carry_cnt = carry_len = carry_lent =
  141:   is_popup = is_zoom = is_help = is_recalc = is_replace = udf_file =
  142:   workarea_cnt = wnd_cnt = line_cnt =  color_flg = cnt = is_extensions =0
  143:
  144:   crlf = chr(10)
  145:   temp = get_list = workarea_dbfs = ""
  146:   page_cnt = 1
  147:   left_delimiter = right_delimiter = "\""
  148:
  149:   screen_size()
  150:   //-------------------------------
  151:   // Create Format file
  152:   //-------------------------------
  153:   if !make_program(".fmt") then goto nogen
  154:
  155:   header()                   // Print Header in the Format file
  156:   fmt_file_init()            // Format file initializtion code
  157:   fmt_file_body()            // @ SAY GET Processing
  158:   fmt_file_exit()            // Format file exit code
  159:   make_pop_code()            // Create the Procedure File for POPUP's if required
  160:   make_replace_code()        // Make procedures for the replace of lookup's
  161:   make_zoom_to_form()        // Make procedures for the zoom system
  162:   make_help_code()           // Make procedures for the help system
  163:   make_recalc_code()         // Make procedures for the calculated fields
  164:   if is_help or is_popup then
  165:      // Make shadow procedures
  166:      make_shadow_proc()
  167:   endif
  168:   if is_extensions then
  169:      // Make other udfs like cut, paste, _key_vars
  170:      make_other_udfs()
  171:   endif
  172:
  173:   if cnt == 0 then
  174:      pause(form_empty + any_key)
  175:   endif
  176:
  177:   fileerase( fmt_name + ".fmo")  // Force dBASE to recompile the .fmo
  178:   nogen:
  179:  return 0;
  180:
  181:  //---------------------------------------
  182:  // Template user defined functions follow
  183:  //---------------------------------------
  184:
  185:  define fmt_file_init()
  186:  //
  187:  // Format file initialization code
  188:  //
  189:  }
  190:
  191:  *-- Format file initialization code --------------------------------------------
  192:
  193:  *-- Some of these PRIVATE variables are created based on CodeGen and may not
  194:  *-- be used by your particular .fmt file
  195:  PRIVATE lc_talk, lc_cursor, lc_display, lc_status, lc_carry, lc_proc,;
  196:          ln_typeahd
  197:
  198:  IF SET("TALK") = "ON"
  199:     SET TALK OFF
  200:     lc_talk = "ON"
  201:  ELSE
  202:     lc_talk = "OFF"
  203:  ENDIF
  204:  lc_cursor = SET("CURSOR")
  205:  SET CURSOR ON
  206:  {if at("43", display_type()) then}
  207:
  208:  *-- This form was created in {display_type()} mode
  209:  lc_display = SET("display")
  210:  // MONO, COLOR, EGA25, EGA43, MONO43
  211:  IF .NOT. "43" $ lc_display                             && In 25 line mode
  212:     IF "EGA" $ lc_display
  213:        *-- If EGA is in lc_display try EGA43
  214:        SET DISPLAY TO EGA43
  215:     ELSE
  216:        *-- Otherwise try MONO43
  217:        SET DISPLAY TO MONO43
  218:     ENDIF
  219:  ENDIF
  220:  {endif}
  221:
  222:  lc_escape = SET("ESCAPE")
  223:  SET ESCAPE OFF
  224:  lc_status = SET("STATUS")
  225:  *-- SET STATUS was \
  226:  {if dB_status then}
  227:  ON when you went into the Forms Designer.
  228:  IF lc_status = "OFF"
  229:     SET STATUS ON
  230:  {else}
  231:  OFF when you went into the Forms Designer.
  232:  IF lc_status = "ON"
  233:     SET STATUS OFF
  234:  {endif}
  235:  ENDIF
  236:  //-----------------------------------------------------------------------
  237:  // Process fields to build "SET CARRY" and WINDOW commands.
  238:  //-----------------------------------------------------------------------
  239:  {
  240:   foreach FLD_ELEMENT flds
  241:     new_page(flds)
  242:     if FLD_CARRY then carry_flg = 1; ++carry_cnt endif
  243:     if chr(FLD_VALUE_TYPE) == "M" and FLD_MEM_TYP and wnd_cnt < 20 then
  244:        ++wnd_cnt
  245:        wnd_names = wnd_names + "wndow" + wnd_cnt + ",";
  246:  }
  247:
  248:  *-- Window for memo field {cap_first(FLD_FIELDNAME)}.
  249:  DEFINE WINDOW { Window_Def(flds)}\
  250:  {  endif
  251:   next flds
  252:   print(crlf);
  253:   if carry_flg then
  254:  }
  255:
  256:  lc_carry = SET("CARRY")
  257:  *-- Fields to carry forward during APPEND.
  258:  SET CARRY TO { Carry_Flds()}
  259:
  260:  {endif}
  261:  {      if check_for_gen_extensions() then
  262:            is_extensions = 1;
  263:  }
  264:
  265:  IF TYPE("gc_cut") = "U"
  266:     PRIVATE gc_cut
  267:     gc_cut     = SPACE(254)                  && Global variable for cut and paste
  268:  ENDIF
  269:  lc_proc    = SET("procedure")               && Store procedure file name
  270:  ln_typeahd = SET("typeahead")               && Store "typeahead" setting for _Paste
  271:  lc_design  = SET("design")                  && Store "design" setting
  272:
  273:  SET PROCEDURE TO u_{substr(name,1,6)}
  274:  SET TYPEAHEAD TO 255
  275:  SET DESIGN OFF
  276:
  277:  DO _key_vars                               && Initialize Keyboard variables
  278:
  279:  IF SET("DBTRAP") = "ON"                    && If dbtrap is on warn user
  280:     DO _dbtrap                              && Put up error box
  281:     KEYBOARD CHR( kn_Esc)                   && Escape out of the form since
  282:  ENDIF                                      &&   UDF's won't run
  283:  {    if workarea_cnt <= max_workareas and is_popup then}
  284:
  285:  DO S_{lower(substr(name,1,7))}{tabto(40)}&& Open up Lookup Files
  286:  {    endif
  287:    endif  // gen_extensions
  288:    if is_help then}
  289:
  290:  ON KEY LABEL {on_key_help} \
  291:  DO {"H_" + lower(rtrim(substr(name,1,6)))} WITH VARREAD() && Call Help code
  292:  { else
  293:      if is_extensions then}
  294:  ON KEY LABEL {on_key_help}
  295:  {   endif
  296:    endif
  297:    if is_popup then}
  298:  ON KEY LABEL F2 ?? CHR(7)
  299:  { endif
  300:    if is_recalc then}
  301:  ON KEY LABEL {on_key_recalc} \
  302:  DO {"R_" + lower(rtrim(substr(name,1,6)))} WITH VARREAD() && Call Recalc code
  303:  {else
  304:      if is_extensions then}
  305:  ON KEY LABEL {on_key_recalc}
  306:  {    endif
  307:    endif
  308:    if is_zoom then}
  309:  ON KEY LABEL {on_key_zoom} \
  310:  DO {"Z_" + lower(rtrim(substr(name,1,6)))} WITH VARREAD() && Call Zoom code
  311:  { else
  312:      if is_extensions then}
  313:  ON KEY LABEL {on_key_zoom}
  314:  {   endif
  315:    endif
  316:    if is_extensions then}
  317:  ON KEY LABEL {on_key_cut} DO _Cut
  318:  ON KEY LABEL {on_key_edpaste} DO _Edpaste
  319:  ON KEY LABEL {on_key_paste} DO _Paste
  320:
  321:  {  endif
  322:     if is_replace then
  323:         make_memvar_declarations()
  324:     endif
  325:  return;
  326:  // eof - fmt_file_init()
  327:  enddef
  328:
  329:  //--------------------------------------------------------------
  330:  define fmt_file_body()
  331:  }
  332:
  333:  *-- @ SAY GETS Processing. -----------------------------------------------------
  334:
  335:
  336:  *--  Format Page: {page_cnt = 1
  337:                     page_cnt}
  338:
  339:  {line_cnt = wnd_cnt = 0
  340:   foreach ELEMENT k
  341:     color = getcolor(FLD_DISPLAY, FLD_EDITABLE) // get color of element
  342:     if new_page(k) then
  343:        write_recalc_get_list()
  344:        get_list = "";
  345:  }
  346:  READ
  347:
  348:  *-- Format Page: {page_cnt}
  349:
  350:  {  endif
  351:  //
  352:
  353:     if ELEMENT_TYPE == @TEXT_ELEMENT or ELEMENT_TYPE == @FLD_ELEMENT then
  354:       if FLD_FIELDTYPE == calc then}
  355:  *-- Calculated field: {cap_first(FLD_FIELDNAME)} - {FLD_DESCRIPT}
  356:  {    endif
  357:       if FLD_FIELDTYPE == memvar then}
  358:  *-- Memory variable: {cap_first(FLD_FIELDNAME)}
  359:  {    endif}
  360:  @ {nul2zero(ROW_POSITN) - line_cnt},{nul2zero(COL_POSITN)} \
  361:  {  endif
  362:     if ELEMENT_TYPE == @BOX_ELEMENT then}
  363:  @ {box_coordinates(k)}\
  364:  {  endif}
  365:  //
  366:  {  case ELEMENT_TYPE of
  367:     @TEXT_ELEMENT:
  368:     // Certain control characters can cause dBASE problems ie, ASCII(13,26,0)
  369:     // so the form designer will either send them to us as a string if they are
  370:     // all the same character or as individual characters if they differ. We
  371:     // handle this by using the chr() function to "SAY" them in dBASE.
  372:  }
  373:  SAY \
  374:  {     if asc(TEXT_ITEM) < 32 then
  375:          if len(TEXT_ITEM) == 1 then}
  376:  CHR({asc(TEXT_ITEM)}) \
  377:  {       else}
  378:  REPLICATE(CHR({asc(TEXT_ITEM)}), {len(TEXT_ITEM)}) \
  379:  {       endif
  380:        else
  381:           if substr(TEXT_ITEM,1,1) == "\"" then
  382:              // Double quote is being used on the design surface need to use
  383:              // brackets "[]" as delimiters
  384:              left_delimiter = "["
  385:              right_delimiter = "]"
  386:           endif
  387:           left_delimiter + TEXT_ITEM + right_delimiter} \
  388:  {        left_delimiter = right_delimiter = "\""
  389:        endif
  390:        outcolor()}
  391:  {  @BOX_ELEMENT:
  392:         outbox(BOX_TYPE, BOX_SPECIAL_CHAR)}
  393:  {      outcolor()}
  394:  {  @FLD_ELEMENT:
  395:        if !FLD_EDITABLE then; // its a SAY}
  396:  SAY \
  397:  {        if FLD_FIELDTYPE == calc then
  398:              // Loop thru expression in case it is longer than 237
  399:              foreach FLD_EXPRESSION fcursor in k
  400:                 FLD_EXPRESSION}
  401:  {           next}
  402:  // Output a space after the Fld_expression and get ready for picture clause
  403:   \
  404:  {        else // not a editable field
  405:              if FLD_FIELDTYPE == dbf then temp = "" else temp = "m->" endif
  406:                 temp + cap_first(FLD_FIELDNAME)} \
  407:  {        endif
  408:           if Ok_Template(k) then}
  409:  PICTURE "{picture_for_say(k);}" \
  410:  {        endif
  411:        else // it's a GET}
  412:  GET \
  413:  {        if FLD_FIELDTYPE == dbf then temp = "" else temp = "m->" endif
  414:           get_list = get_list + FLD_FIELDNAME + ","
  415:           temp + cap_first(FLD_FIELDNAME)} \
  416:  {        if chr(FLD_VALUE_TYPE) == "M" && FLD_MEM_TYP && wnd_cnt < 20 then ++wnd_cnt
  417:              if Fld_mem_typ == 1}OPEN {endif}WINDOW wndow{wnd_cnt} \
  418:  {        endif
  419:           if Ok_Template(k) then}
  420:  PICTURE "{picture_for_get(k);}" \
  421:  {        endif
  422:           if FLD_L_BOUND or FLD_U_BOUND then color_flg = 1;}
  423:  ;
  424:     RANGE {FLD_L_BOUND}{if FLD_U_BOUND then},{FLD_U_BOUND}{endif} \
  425:  {        endif
  426:           if FLD_OK_COND then color_flg = 1;}
  427:  ;
  428:  {           if ( at("POPUP", upper(ltrim(FLD_OK_COND))) == "2" and
  429:                   ok_coordinates( k, 2, 1, bad_pick )
  430:                 ) or
  431:                 at("BROWSE", upper(ltrim(FLD_OK_COND))) == "2" then
  432:                 // A POPUP or BROWSE is desired for showing coded values,
  433:                 // redo the VALID clause to call a UDF based on "U_" + FLD_FIELDNAME
  434:  }
  435:     VALID {if is_required(FLD_OK_COND) or
  436:               upper(getenv("dtl_req")) == "ON" then}REQUIRED {endif}\
  437:  {  get_udfname(FLD_FIELDNAME)}( {cap_first(FLD_FIELDNAME)} ) \
  438:  {              // Allow a user's UDF to follow "BROWSE" OR "POPUP" logic
  439:                 if at(".AND.", upper(FLD_OK_COND)) then
  440:                    substr( FLD_OK_COND, at(".AND.", upper(FLD_OK_COND)))} \
  441:  {              endif
  442:              else
  443:                  if !popup_or_browse(k) then
  444:  }
  445:     VALID {if upper(getenv("dtl_req")) == "ON" then}REQUIRED {endif}{FLD_OK_COND} \
  446:  {
  447:                  endif
  448:              endif
  449:
  450:              if FLD_REJ_MSG then}
  451:  ;
  452:     ERROR \
  453:  {              if !at("IIF", upper(FLD_REJ_MSG))}"{endif}{FLD_REJ_MSG}\
  454:  {              if !at("IIF", upper(FLD_REJ_MSG))}"{endif} \
  455:  {           endif
  456:           endif // FLD_OK_COND
  457:           if FLD_ED_COND then color_flg = 1;}
  458:  ;
  459:     WHEN {FLD_ED_COND} \
  460:  {
  461:           endif
  462:           if FLD_DEF_VAL then color_flg = 1;}
  463:  ;
  464:     DEFAULT {FLD_DEF_VAL} \
  465:  {        endif
  466:           if FLD_HLP_MSG then color_flg = 1;}
  467:  ;
  468:     MESSAGE \
  469:  {           if !at("IIF", upper(FLD_HLP_MSG))}"{endif}{FLD_HLP_MSG}\
  470:  {           if !at("IIF", upper(FLD_HLP_MSG))}"{endif} \
  471:  {        endif
  472:        endif // FLD_EDITABLE}
  473:  {     outcolor()}
  474:  {     color_flg = 0;
  475:     otherwise: goto getnext;
  476:     endcase
  477:  }
  478:
  479:  //Leave the above blank line, it forces a line feed!
  480:  //-----------------
  481:  // End of @ SAY GET
  482:  //-----------------
  483:  {  ++cnt;
  484:     getnext:
  485:   next k;
  486:   write_recalc_get_list()  // Write last line of recalc list
  487:  return;
  488:  // eof - fmt_file_body()
  489:  enddef
  490:
  491:  //--------------------------------------------------------------
  492:  define fmt_file_exit()
  493:  }
  494:
  495:  *-- Format file exit code -----------------------------------------------------
  496:
  497:  {if is_extensions then}
  498:  *-- Get rid of the ON KEY set above
  499:  {  if is_help then}
  500:  ON KEY LABEL {on_key_help}
  501:  {  endif}
  502:  ON KEY LABEL F2
  503:  {  if is_recalc then}
  504:  ON KEY LABEL {on_key_recalc}
  505:  {  endif}
  506:  ON KEY LABEL {on_key_cut}
  507:  ON KEY LABEL {on_key_edpaste}
  508:  ON KEY LABEL {on_key_paste}
  509:  {  if is_zoom then}
  510:  ON KEY LABEL {on_key_zoom}
  511:  {  endif
  512:       if workarea_cnt <= max_workareas and is_popup then}
  513:
  514:  DO C_{lower(substr(name,1,7))}{tabto(40)}&& Close up Lookup Files
  515:  {    endif}
  516:
  517:  SET PROCEDURE TO (lc_proc)
  518:  SET TYPEAHEAD TO (ln_typeahd)
  519:  SET DESIGN &lc_design.
  520:  {endif}
  521:
  522:  *-- SET STATUS was \
  523:  {if dB_status then}
  524:  ON when you went into the Forms Designer.
  525:  IF lc_status = "OFF"  && Entered form with status off
  526:     SET STATUS OFF     && Turn STATUS "OFF" on the way out
  527:  {else}
  528:  OFF when you went into the Forms Designer.
  529:  IF lc_status = "ON"  && Entered form with status on
  530:     SET STATUS ON     && Turn STATUS "ON" on the way out
  531:  {endif}
  532:  ENDIF
  533:  {if carry_flg then}
  534:
  535:  SET CARRY &lc_carry.
  536:  {endif}
  537:  SET CURSOR &lc_cursor.
  538:  {if at("43", display_type()) then}
  539:  SET DISPLAY TO &lc_display.      && Reset Screen size if changed
  540:  {endif}
  541:  SET ESCAPE &lc_escape.
  542:  SET TALK &lc_talk.
  543:
  544:  {if wnd_names then}
  545:  RELEASE WINDOWS {substr(wnd_names, 1, (len(wnd_names) - 1))}
  546:  {endif
  547:   if is_extensions then}
  548:
  549:  RELEASE ALL LIKE kn_*
  550:  RELEASE ALL LIKE rn_*
  551:  {endif}
  552:  *-- EOP: {filename(fmt_name)}FMT
  553:  {return;
  554:  // eof - fmt_file_exit()
  555:  enddef
  556:
  557:  //--------------------------------------------------------------
  558:  define header()
  559:      // Print Header in program
  560:      print( replicate( "*",80) + crlf);}
  561:  *-- Name.......: {filename(fmt_name)}FMT
  562:  *-- Date.......: {ltrim( substr( date(),1,8))}
  563:  *-- Version....: dBASE IV, Format {FRAME_VER}.1
  564:  *-- Notes......: Format files use "" as delimiters!
  565:  {   print( replicate( "*",80) + crlf);
  566:  enddef
  567:
  568:  //---------------------------------------------------------------------------
  569:  // Standard FORM extension routines
  570:  include "ccb_fext.cod"
    1:  {
    2:  // Module Name: FORM_EXT.COD
    3:  // Description: This module produces PROCEDURES & FUNCTIONS
    4:  //              used in form processing (for FORM.COD)
    5:  //
    6:  //----Modified 6/9/91 by Barry Fox, Fox Computer Consulting to allow
    7:  //    help support generation to proceed if database name is different
    8:  //    from form name.  Will prompt user for database name to check for
    9:  //    existance of help dbf if no help dbf is found corresponding to
   10:  //    form name.
   11:  //
   12:  define screen_size()
   13:     // Test screen size if display > 2 screen is 43 lines
   14:     display = numset(_flgcolor)
   15:     if display > ega25 then
   16:         scrn_size = 39
   17:         max_pop_row = 36
   18:     else
   19:         scrn_size = 21
   20:         max_pop_row = 18
   21:     endif
   22:
   23:     // Test to see if status was off before going into form designer
   24:     dB_status = numset(_flgstatus)
   25:     if scrn_size == 21 and !db_status then
   26:        scrn_size = 24
   27:        max_pop_row = 21
   28:     endif
   29:     if scrn_size == 39 and !db_status then // status is off
   30:        scrn_size = 42
   31:        max_pop_row = 39
   32:     endif
   33:     return;
   34:  enddef
   35:
   36:  //--------------------------------------------------------------
   37:  define display_type()
   38:      // Find out the display type we are working on
   39:      var temp;
   40:      case display of
   41:         mono:   temp = "MONO"
   42:         cga:    temp = "COLOR"
   43:         ega25:  temp = "EGA25"
   44:         mono43: temp = "MONO43"
   45:         ega43:  temp = "EGA43"
   46:       endcase
   47:       return temp;
   48:  enddef
   49:
   50:  //--------------------------------------------------------------
   51:  define getcolor(f_display,         // Color of the current field
   52:                  f_editable         // Field is SAY or GET
   53:                 )
   54:   // Determines the color from f_display and f_editable (GET or SAY)
   55:   enum  Foreground  =   7,
   56:         Intensity   =   8,  // Color
   57:         Background  = 112,
   58:         MIntensity  = 256,
   59:         Reverse     = 512,  // Mono
   60:         Underline   =1024,
   61:         Blink       =2048,
   62:         default     =32768; // Screen set to default
   63:
   64:   var forgrnd, enhanced, backgrnd, blnk, underln, revrse, use_colors, incolor;
   65:   incolor=""
   66:
   67:   use_colors  = default & f_display
   68:   forgrnd  = Foreground & f_display
   69:   enhanced = (Intensity & f_display) || (MIntensity & f_display)
   70:   backgrnd = Background & f_display
   71:   blnk     = Blink  & f_display
   72:   underln  = Underline & f_display
   73:   revrse   = Reverse & f_display
   74:
   75:   if not use_colors then // Use system colors, no colors set in designer
   76:
   77:      if backgrnd then backgrnd = backgrnd/16 endif
   78:
   79:      if (display != mono and display != mono43) then
   80:         case forgrnd of
   81:          0: incolor = "n"
   82:          1: incolor = "b"
   83:          2: incolor = "g"
   84:          3: incolor = "bg"
   85:          4: incolor = "r"
   86:          5: incolor = "rb"
   87:          6: incolor = "gr"
   88:          7: incolor = "w"
   89:         endcase
   90:      else
   91:         incolor = "w"
   92:      endif
   93:
   94:      if revrse then
   95:         incolor = incolor + "i"
   96:      endif
   97:      if underln then
   98:         incolor = incolor + "u"
   99:      endif
  100:      if enhanced then
  101:         incolor = incolor + "+"
  102:      endif
  103:      if blnk then
  104:         incolor = incolor + "*"
  105:      endif
  106:
  107:      incolor = incolor + "/"
  108:
  109:      if (display != mono and display != mono43) then
  110:         case backgrnd of
  111:          0: incolor = incolor + "n"
  112:          1: incolor = incolor + "b"
  113:          2: incolor = incolor + "g"
  114:          3: incolor = incolor + "bg"
  115:          4: incolor = incolor + "r"
  116:          5: incolor = incolor + "rb"
  117:          6: incolor = incolor + "gr"
  118:          7: incolor = incolor + "w"
  119:         endcase
  120:      else
  121:         incolor = incolor + "n"
  122:      endif
  123:
  124:      if f_editable and incolor then
  125:         incolor = incolor + "," + incolor
  126:      endif
  127:
  128:   endif // use no colors
  129:   return alltrim(incolor);
  130:  enddef
  131:
  132:  //--------------------------------------------------------------
  133:  define outbox(mbox,            // Border type
  134:                mchar            // Special character of border
  135:               )
  136:     // Output the of Box border and character if any
  137:     var result;
  138:     case mbox of
  139:        0: result = " " // single
  140:        1: result = " DOUBLE "
  141:        2: result = " CHR("+mchar+") "
  142:     endcase
  143:     return result;
  144:  enddef
  145:
  146:  //--------------------------------------------------------------
  147:  define outcolor()
  148:    // Output the of color of the @ SAY GET or Box
  149:    var result;
  150:    result = "";
  151:    if len(color) > 0 then
  152:       if color_flg then
  153:          // If flag is set output a dBASE continuation ";"
  154:          result = ";" + crlf + space(3)
  155:       endif
  156:       result = result + "COLOR " + color + " "
  157:    endif
  158:    return result;
  159:  enddef
  160:
  161:  //--------------------------------------------------------------
  162:  define window_def(cur)                  // Pass in foreach cursor
  163:     // Build dBASE window command
  164:     var result;
  165:     result = "wndow" + wnd_cnt + " FROM " + Box_Coordinates(cur)
  166:     result = result + outbox(cur.BOX_TYPE, cur.BOX_SPECIAL_CHAR)
  167:     color = getcolor(cur.FLD_DISPLAY, cur.FLD_EDITABLE)
  168:     result = result + outcolor()
  169:     return result;
  170:  enddef
  171:
  172:  //--------------------------------------------------------------
  173:  define box_coordinates(cur)             // Pass in foreach cursor
  174:     // Build box coordinates for a dBASE window command
  175:     var result, temp_page, line_cnt;
  176:     temp_page = page_cnt;
  177:
  178:     // Adjust box coordinates so that negative numbers are not generated
  179:     do while ( nul2zero(cur.BOX_TOP) - (scrn_size * temp_page) ) <= 1
  180:        temp_page = temp_page - 1
  181:     enddo
  182:     //-- Adjust "temp_page" for page 1 and 2
  183:     if page_cnt == 1 then
  184:        temp_page = 0
  185:     endif
  186:     if page_cnt == 2 then
  187:        temp_page = 1
  188:     endif
  189:     //-------------------------
  190:
  191:     if !temp_page then
  192:        line_cnt = 0
  193:     else
  194:        line_cnt = (scrn_size * temp_page) + (1 * temp_page)
  195:     endif
  196:
  197:     result = nul2zero(cur.BOX_TOP) - line_cnt +","
  198:     result = result + nul2zero(cur.BOX_LEFT) + " TO "
  199:     temp = nul2zero(cur.BOX_TOP) + cur.BOX_HEIGHT - line_cnt - 1
  200:     if temp > scrn_size then temp = scrn_size endif
  201:     result = result + temp + "," + (nul2zero(cur.BOX_LEFT) + cur.BOX_WIDTH - 1)
  202:     return result;
  203:  enddef
  204:
  205:  //--------------------------------------------------------------
  206:  define carry_flds()
  207:     // Build dBASE SET CARRY command
  208:     carry_len = carry_lent = 13
  209:     carry_first = 0
  210:     foreach FLD_ELEMENT flds
  211:        if FLD_CARRY then
  212:           carry_len = carry_len + len(FLD_FIELDNAME + ",")
  213:           carry_lent = carry_lent + len(FLD_FIELDNAME + ",")
  214:           if carry_lent > 1000 then
  215:              print(crlf + "SET CARRY TO ")
  216:              carry_len = carry_lent = 13
  217:           endif
  218:           if carry_len > 75 then
  219:             print(";" + crlf + "  ")
  220:             carry_len = 2
  221:           endif
  222:           temp = cap_first(FLD_FIELDNAME)
  223:           if !carry_first then
  224:              print(temp)
  225:              carry_first = 1
  226:           else
  227:              print("," + temp)
  228:           endif
  229:        endif
  230:      next flds
  231:      print(" ADDITIVE");
  232:   return
  233:  enddef
  234:
  235:  //--------------------------------------------------------------
  236:  define picture_for_get(c)
  237:       if c.FLD_PICFUN then}@{c.FLD_PICFUN}\
  238:  {       if at("S", c.FLD_PICFUN) then}{c.FLD_PIC_SCROLL}{endif}\
  239:   {//leave this space}\
  240:  {    endif
  241:       if at("M", c.FLD_PICFUN) then
  242:          c.FLD_PIC_CHOICE}\
  243:  {    else
  244:          c.FLD_TEMPLATE}\
  245:  {    endif
  246:   return;
  247:  enddef
  248:
  249:  //--------------------------------------------------------------
  250:  define picture_for_say(c)
  251:       if c.FLD_PICFUN then}@{c.FLD_PICFUN}\
  252:  {       if at("S", c.FLD_PICFUN) then}{c.FLD_PIC_SCROLL}{endif}\
  253:   {//leave this space}\
  254:  {       endif
  255:       if !at("M", c.FLD_PICFUN) then
  256:          c.FLD_TEMPLATE}\
  257:  {    endif
  258:   return;
  259:  enddef
  260:
  261:  //--------------------------------------------------------------
  262:  define ok_template(cur)                 // Pass in foreach cursor
  263:       if cur.FLD_TEMPLATE && !(chr(cur.FLD_VALUE_TYPE) == "D" ||
  264:                                chr(cur.FLD_VALUE_TYPE) == "M") then
  265:          return 1;
  266:       else
  267:          return 0;
  268:       endif
  269:  enddef
  270:  //--------------------------------------------------------------
  271:  define ok_coordinates(cur,              // Current cursor
  272:                        xtra_width,       // Additional width to check ie, shadow
  273:                        want_message,     // Display message flag 0:No 1:Yes
  274:                        message)          // Message to display to user
  275:       // Check to see if coordinates of popup or shadow will fit on screen
  276:       // based on the dimensions of the current field
  277:       if nul2zero(cur.COL_POSITN) + len(cur.FLD_TEMPLATE) + xtra_width > screen_width then
  278:          if want_message then
  279:             beep(2)                      // UDF in builtin.def
  280:             cls()
  281:             say_center(10,"Error on Field: " + cur.FLD_FIELDNAME)
  282:             say_center(12, message)
  283:             pause(any_key)
  284:          endif
  285:          return 0;
  286:       else
  287:          return 1;
  288:       endif
  289:  enddef
  290:
  291:  //--------------------------------------------------------------
  292:  define make_program(ext)
  293:     // Attempt to create program (fmt) file.
  294:     ext = upper( ext)
  295:     default_drv = strset(_defdrive)  // grab default drive from dBASE
  296:     fmt_name = FRAME_PATH + NAME     // Put path on to object name
  297:     if not fileok(fmt_name) then
  298:        if not default_drv then
  299:           fmt_name = NAME
  300:        else
  301:           fmt_name = default_drv + ":" + NAME
  302:        endif
  303:     endif
  304:     fmt_name = upper(fmt_name)
  305:     if not create(fmt_name + ext) then
  306:          pause(fileroot(fmt_name) + ext + read_only + any_key)
  307:          return 0;
  308:       endif
  309:     return 1;
  310:  enddef
  311:
  312:  //--------------------------------------------------------------
  313:  define make_udf()
  314:     // Attempt to create dBASE procedure (prg) file.
  315:     var udf_root_file_name;
  316:     udf_root_file_name =  frame_path + "u_" + rtrim(substr(name,1,6))
  317:     if not create( udf_root_file_name + ".PRG") then
  318:        pause(udf_root_file_name + ".PRG" + read_only + any_key)
  319:        return 0;
  320:     endif
  321:     // Force dBASE to recompile the .prg
  322:     fileerase(udf_root_file_name + ".DBO")
  323:     udf_file = 1 // Global flag to determine if UDF file was created
  324:     return 1;
  325:  enddef
  326:
  327:  //--------------------------------------------------------------
  328:  define udf_header()
  329:      // Print Header in UDF program
  330:      print("*"+replicate("-",78)+crlf);}
  331:  *-- Name....: {frame_path}u_{rtrim(substr(name,1,6))}.PRG
  332:  *-- Date....: {ltrim(SUBSTR(date(),1,8))}
  333:  *-- Version.: dBASE IV, Procedures for Format (.fmt) v{Frame_ver}.1
  334:  *-- Notes...: Procedure file for VALID POPUPs and/or Context Sensitive Help
  335:  *-- ........: for {filename(fmt_name)}FMT
  336:  {print("*"+replicate("-",78)+crlf);
  337:  enddef
  338:
  339:  //--------------------------------------------------------------
  340:  define make_pop_code()
  341:       var lookup_dbf,  // store get_file(FLD_OK_COND) for faster processing
  342:           is_format,   // is there a format file
  343:           temp_name,   // store get_popname(FLD_OK_COND) for faster processing
  344:           ;
  345:           //              temp_key;    // store KEY field
  346:
  347:  //   Create the Procedure File for POPUP's if required
  348:       if is_popup then
  349:  //          if !at("FORMBROW", upper(getenv("dtl_form"))) then
  350:               if !make_udf() then
  351:                    return 0;
  352:                endif
  353:              udf_header()
  354:  //          endif
  355:            if workarea_cnt <= max_workareas then
  356:  }
  357:  PROCEDURE S_{lower(substr(name,1,7))}{tabto(40)}&& Open Lookup files for faster processing
  358:  {           foreach FLD_ELEMENT flds
  359:                   if popup_or_browse(flds) then
  360:                      lookup_dbf = get_file(FLD_OK_COND)
  361:                      if not at(lookup_dbf, workarea_dbfs) then
  362:                         workarea_dbfs = workarea_dbfs + "," + lookup_dbf;
  363:  }
  364:    USE {lookup_dbf} ORDER {get_key(FLD_OK_COND)} IN SELECT() \
  365:  {                      if (upper(lookup_dbf) == FLD_FILENAME) then}
  366:  AGAIN ALIAS {"A"+substr(lookup_dbf,1,7)}
  367:  {                      else}
  368:   {//leave this space}
  369:  {                      endif
  370:                      endif
  371:                   endif
  372:              next flds;
  373:  }
  374:  RETURN
  375:  *-- EOP: S_{lower(substr(name,1,7))}
  376:
  377:  PROCEDURE C_{lower(substr(name,1,7))}{tabto(40)}&& Close Lookup files
  378:  {           workarea_dbfs = ""
  379:              foreach FLD_ELEMENT flds
  380:                   if popup_or_browse(flds) then
  381:                      lookup_dbf = get_file(FLD_OK_COND);
  382:                      if not at(lookup_dbf, workarea_dbfs) then
  383:                         workarea_dbfs = workarea_dbfs + "," + lookup_dbf;
  384:  }
  385:    USE IN ALIAS("{ upper(lookup_dbf) == FLD_FILENAME ? "A"+substr(lookup_dbf,1,7) : lookup_dbf }")
  386:  {                   endif
  387:                   endif
  388:              next flds;
  389:            endif
  390:  }
  391:  RETURN
  392:  *-- EOP: C_{lower(substr(name,1,7))}
  393:
  394:  FUNCTION Empty                       && Determine if the passed argument is NULL
  395:  {lmarg(offset)}
  396:  PARAMETER x
  397:  PRIVATE retval, lc_type
  398:  lc_type = TYPE("x")
  399:  DO CASE
  400:    CASE lc_type = "C"
  401:      retval = (LEN(TRIM(x))=0)
  402:    CASE lc_type$"NF"
  403:      retval = (x=0)
  404:    CASE lc_type = "D"
  405:      retval = (" "$DTOC(x))
  406:    OTHERWISE lc_type = "U"
  407:      retval = .T.
  408:  ENDCASE
  409:  {lmarg(0)}
  410:  RETURN (retval)
  411:  *-- EOP: _Empty
  412:
  413:  {print("*"+replicate("-",78)+crlf);}
  414:  PROCEDURE _DbfEmpty
  415:     *-- Error box if Lookup .dbf is empty
  416:     *-- Save the screen and setup window
  417:     PRIVATE ALL LIKE l?_*
  418:     DEFINE WINDOW u_error FROM 5,15 TO 11,55
  419:     SAVE SCREEN TO u_error
  420:     DO _Shadowg WITH 5,15,11,55
  421:
  422:     *-- Activate the window and put up error message
  423:     ACTIVATE WINDOW u_error
  424:     lc_fpath = SET("fullpath")
  425:     SET FULLPATH OFF
  426:     @ 1,2 SAY "Lookup table: " + SUBSTR( DBF(),3) + " is empty!"
  427:     @ 2,2 SAY "{any_key}"
  428:     ln_errorky = INKEY(10)
  429:
  430:     *-- Restore the screen and clean up
  431:     SET FULLPATH &lc_fpath.
  432:     RELEASE WINDOW u_error
  433:     RESTORE SCREEN FROM u_error
  434:     RELEASE SCREEN u_error
  435:  RETURN
  436:  *-- EOP: _DbfEmpty
  437:
  438:  {
  439:            line_cnt = 0
  440:            page_cnt = 1
  441:
  442:            foreach FLD_ELEMENT flds
  443:
  444:                 at_pop = at("POPUP", upper(ltrim(FLD_OK_COND))) == "2" ? 1 : 0;
  445:
  446:                 new_page(flds)
  447:                 if popup_or_browse(flds) then
  448:                      trow_positn = nul2zero(ROW_POSITN) - line_cnt
  449:                      tcol_positn = nul2zero(COL_POSITN)
  450:                      color = getcolor(FLD_DISPLAY, FLD_EDITABLE) // get color of element
  451:
  452:                      if at_pop and !ok_coordinates(flds, 2, 0, "") then loop endif
  453:
  454:                      print("*"+replicate("-",78)+crlf);
  455:  }
  456:  FUNCTION {get_udfname(FLD_FIELDNAME)}
  457:  {lmarg(offset)}
  458:  PARAMETER fld_name
  459:  PRIVATE ALL LIKE l?_*
  460:  PRIVATE fld_name, rtn_fld
  461:
  462:  ll_return = .T.                      && Declare return variable for function
  463:  ln_row = ROW()                       && Current Row of Get
  464:  ln_col = COL()                       && Current Column of Get
  465:  rtn_fld = fld_name                   && Current Value of Get
  466:
  467:  {                   if !is_required(FLD_OK_COND) then}
  468:  IF EMPTY(fld_name)                   && Not a required field
  469:    RETURN (.T.)                       && if null field
  470:  ENDIF
  471:
  472:  {                    endif
  473:                       if is_help then}
  474:
  475:  ON KEY LABEL {on_key_help}
  476:  {                    endif
  477:                       if is_recalc then}
  478:  ON KEY LABEL {on_key_recalc}
  479:  {                    endif
  480:                       if is_zoom then}
  481:  ON KEY LABEL {on_key_zoom}
  482:  {                    endif}
  483:
  484:  lc_alias = ALIAS()                   && Grab current workarea
  485:  //--------------------------------------------------------------------------
  486:  // kjn New design for Edit/Browse that will eliminate the @ GET code
  487:  // Will allow this code to go away
  488:  //--------------------------------------------------------------------------
  489:
  490:  IF ln_row = {row_positn} .AND. (ln_col >= {col_positn} .AND. ln_col <= {col_positn+FLD_LENGTH+6} )
  491:     ll_edit = .T.
  492:  ELSE
  493:     ll_edit = .F.
  494:  ENDIF
  495:
  496:  {                   lookup_dbf = get_file(FLD_OK_COND);
  497:                      temp_key = alltrim(get_key(FLD_OK_COND));
  498:
  499:                      if workarea_cnt <= max_workareas then
  500:  }
  501:  SELECT ("{ upper(lookup_dbf) == FLD_FILENAME ? "A"+substr(lookup_dbf,1,7) :
  502:                                                 lookup_dbf }")
  503:  {                   else}
  504:  SELECT SELECT()
  505:  IF FILE("{lookup_dbf}.dbf")
  506:     USE {lookup_dbf} ORDER {temp_key} \
  507:  {                     if (upper(lookup_dbf) == FLD_FILENAME) then}
  508:  AGAIN
  509:  {                     else}
  510:   {//leave this space}
  511:  {                     endif}
  512:  ELSE
  513:     SET MESSAGE TO "{lookup_dbf}.dbf {use_err}  {any_key}"
  514:     ll_wait = INKEY(0)
  515:     SET MESSAGE TO
  516:     RETURN .F.
  517:  ENDIF
  518:  {                   endif  // workarea_cnt}
  519:
  520:  lc_exact = SET("EXACT")              && Store value of EXACT
  521:  SET EXACT ON
  522:  {                   if !at_pop then}
  523:  lc_near =  SET("NEAR")               && Store value of NEAR
  524:  SET NEAR ON                          && Do "soft" seek into "BROWSE"
  525:
  526:  {                   endif
  527:                      if chr(FLD_VALUE_TYPE) == "C" then}
  528:  fld_name = IIF( EMPTY( TRIM( fld_name)), fld_name, TRIM( fld_name))
  529:  {                   endif}
  530:  SEEK fld_name
  531:
  532:  SET EXACT &lc_exact.                 && Restore SET EXACT to org. value
  533:  {                   if !at_pop then}
  534:  SET NEAR  &lc_near.                  && Restore SET NEAR  to org. value
  535:  {                   endif}
  536:
  537:  IF .NOT. FOUND()
  538:
  539:  {                   temp_name = get_popname(FLD_OK_COND);
  540:
  541:                      if at_pop then  // Gen for Popup lookup}
  542:     DEFINE POPUP {temp_name} FROM \
  543:  {                      if trow_positn < max_pop_row then
  544:                            trow_positn + 1},{tcol_positn} ;
  545:      TO {scrn_size-1},{tcol_positn + len(FLD_TEMPLATE) + 1} ;
  546:  {                      else
  547:                             trow_positn - 11},{tcol_positn} ;
  548:      TO {trow_positn - 1},{tcol_positn + len(FLD_TEMPLATE) + 1} ;
  549:  {                      endif}
  550:      PROMPT FIELD {get_field(FLD_OK_COND)} ;
  551:      MESSAGE {select_msg1}
  552:
  553:     ON SELECTION POPUP {temp_name} DEACTIVATE POPUP
  554:
  555:  {                      if chr(FLD_VALUE_TYPE) == "C" then}
  556:     KEYBOARD TRIM( fld_name ) CLEAR
  557:
  558:  {                      endif
  559:                      else
  560:                         // Gen for BROWSE lookup
  561:                         if (is_update(FLD_OK_COND) and is_fields(FLD_OK_COND)) then
  562:                         // If updateable and fields declared then check for no records
  563:  }
  564:  //  Currently BLOWS dbase UP kjn
  565:  //
  566:  //   IF RECCOUNT() = 0
  567:  //      APPEND BLANK
  568:  //      REPLACE {cap_first(FLD_FIELDNAME)} WITH \
  569:  //{            cap_first(FLD_FILENAME)}->{cap_first(FLD_FIELDNAME)}
  570:  //      KEYBOARD( CHR( kn_Tab)) CLEAR
  571:  //   ENDIF
  572:  //{                      else}
  573:     IF RECCOUNT() = 0
  574:        DO _DbfEmpty
  575:        ll_return = .F.
  576:     ENDIF
  577:
  578:     IF ll_return
  579:
  580:  {                         lmarg(offset*2)
  581:                         endif}
  582:     DEFINE WINDOW {temp_name} FROM \
  583:  {                      if is_window(FLD_OK_COND) then
  584:                            get_browse_window(flds)
  585:                         else
  586:                            print("14,0 TO 20,79")
  587:                         endif
  588:  }
  589:
  590:  {                   endif}
  591:     SAVE SCREEN TO {temp_name}
  592:
  593:  {                   if is_shadow(FLD_OK_COND) then
  594:                         if at_pop and ok_coordinates( flds, 4, 1, bad_shadow ) then
  595:  }
  596:     DO _Shadowg WITH {get_pop_shadow(FLD_TEMPLATE);}
  597:  {                      endif
  598:                         if !at_pop then}
  599:     DO _Shadowg WITH \
  600:  {                         if is_window(FLD_OK_COND) then
  601:                               get_browse_shadow(FLD_OK_COND)
  602:                            else
  603:                               print("14,0,20,77")
  604:                            endif
  605:                         endif
  606:                      endif
  607:                      if at_pop then}
  608:     ACTIVATE POPUP {temp_name}
  609:
  610:     rtn_fld = PROMPT()               && Get user choice from Picklist
  611:
  612:     RELEASE POPUP {temp_name}
  613:  {                   else}
  614:
  615:     lc_message = {select_msg1} +;
  616:                  {select_msg2}
  617:
  618:     lc_message = IIF("500" $ VERSION(1), ;
  619:                   LEFT( lc_message, LEN( lc_message) - 17) , lc_message)
  620:     SET MESSAGE TO lc_message
  621:
  622:     ON KEY LABEL Ctrl-M KEYBOARD( CHR( kn_CtrlEnd)) CLEAR   && Same as Enter send Ctrl-W
  623:
  624:  {                   is_format = is_format_file(flds, FLD_OK_COND);
  625:                      if is_format then}
  626:     IF FILE("{fileroot( get_format_file( FLD_OK_COND)) + ".FMT"}")
  627:        SET FORMAT TO {fileroot( get_format_file(FLD_OK_COND))}
  628:     ENDIF
  629:
  630:  {                   endif}
  631:     IF .NOT. "500" $ VERSION(1)
  632:        ON KEY LABEL {on_key_move} DO _MoveWind WITH WINDOW(), lc_message
  633:     ENDIF
  634:
  635:     BROWSE WINDOW {temp_name} NOMENU COMPRESS NOFOLLOW NODELETE LOCK 1 \
  636:  {                   if ( !is_update(FLD_OK_COND) or
  637:                           !is_fields(FLD_OK_COND) or
  638:                           ( upper(lookup_dbf) == FLD_FILENAME )
  639:                         ) then}
  640:  ;
  641:        NOAPPEND NOEDIT \
  642:  {                   endif
  643:                      if is_format then}
  644:  ;
  645:        FORMAT \
  646:  {                   endif
  647:                      if is_fields(FLD_OK_COND) then}
  648:  ;
  649:        FIELDS {get_browse_fields_list(flds)} \
  650:  //                                             outputs correct line spacing
  651:  {                   endif}
  652:
  653:
  654:  //  Currently BLOWS dbase UP kjn
  655:  //{                   if is_update(FLD_OK_COND) then}
  656:  //   IF EMPTY({cap_first(get_field(FLD_OK_COND))}) .AND. RECCOUNT() = 1
  657:  //      lc_safety = SET("SAFETY")
  658:  //      SET SAFETY OFF
  659:  //      ZAP
  660:  //      SET SAFETY &lc_safety.
  661:  //   ENDIF
  662:  //
  663:  //{                   endif}
  664:  {                   if is_format then}
  665:     SET FORMAT TO
  666:  {                   endif}
  667:     ON KEY LABEL {on_key_move}
  668:     ON KEY LABEL Ctrl-M
  669:     SET MESSAGE TO
  670:
  671:     RELEASE WINDOW {temp_name}
  672:  {                   endif}
  673:
  674:     RESTORE SCREEN FROM {temp_name}
  675:
  676:  {//  for code that blows up above kjn
  677:   //                   if !(is_update(FLD_OK_COND) and is_fields(FLD_OK_COND)) then
  678:                         // Need ENDIF for IF ll_return above
  679:
  680:                        if (is_update(FLD_OK_COND) and is_fields(FLD_OK_COND)) then
  681:                        // for now gen endif for this, kjn.  if append works
  682:                        // delete this if and uncomment out the one right above
  683:                         lmarg(offset)
  684:  }
  685:     ENDIF
  686:  {                   endif}
  687:
  688:     IF LASTKEY() <> kn_esc
  689:  {                   if !at_pop then}
  690:       rtn_fld = {cap_first(get_field(FLD_OK_COND))}
  691:  {                   endif}
  692:  {                   if is_required(FLD_OK_COND) then}
  693:
  694:       IF EMPTY(rtn_fld)             && Is a required field, so return .F.
  695:          ll_return = .F.
  696:       ELSE
  697:  {                      lmarg(offset * 2)
  698:                      endif}
  699:
  700:  //--------------------------------------------------------------------------
  701:  // kjn New design for Edit/Browse that will eliminate the @ GET code
  702:  // Will allow this code to go away
  703:  //--------------------------------------------------------------------------
  704:       IF ll_edit
  705:          @ {trow_positn},{tcol_positn} GET rtn_fld \
  706:  {        if Ok_Template(flds) then}
  707:  PICTURE "{picture_for_get(flds);}" \
  708:  {           outcolor()}
  709:  {        endif}
  710:
  711:       ENDIF
  712:  //--------------------------------------------------------------------------
  713:
  714:       REPLACE {cap_first(FLD_FILENAME)}->{cap_first(FLD_FIELDNAME)} WITH \
  715:  {                   if chr(FLD_VALUE_TYPE) == "C" or
  716:                         at("BROWSE", upper(ltrim(FLD_OK_COND))) == "2" then}
  717:  rtn_fld
  718:  {                   else}
  719:  VAL(rtn_fld)
  720:  {                   endif}
  721:
  722:       ll_return = .T.
  723:  {                   if is_required(FLD_OK_COND) then
  724:                         lmarg(offset)}
  725:       ENDIF
  726:  {                   endif}
  727:     ELSE
  728:       ll_return = .F.
  729:  {
  730:                      if !is_required(FLD_OK_COND) then
  731:  }
  732:
  733:       IF EMPTY(fld_name)             && Not a required field, so return .t.
  734:          ll_return = .T.
  735:       ENDIF
  736:
  737:  {                   endif}
  738:     ENDIF
  739:
  740:  ELSE
  741:    ll_return = .T.
  742:  ENDIF
  743:  {if is_replace(FLD_OK_COND) then}
  744:
  745:  IF ll_return
  746:     DO U_{lower(substr(FLD_FIELDNAME,1,7))} WITH ll_edit, \
  747:  {                   if chr(FLD_VALUE_TYPE) == "C" or
  748:                         at("BROWSE", upper(ltrim(FLD_OK_COND))) == "2" then}
  749:  rtn_fld
  750:  {                   else}
  751:  VAL(rtn_fld)
  752:  {                   endif}
  753:  ENDIF
  754:  {endif}
  755:
  756:  {if workarea_cnt > max_workareas then}
  757:  USE
  758:
  759:  {endif}
  760:  SELECT (lc_alias)                    && Go back to the edit file
  761:
  762:  {if is_help then}
  763:  ON KEY LABEL {on_key_help} \
  764:  DO {"H_" + lower(rtrim(substr(name,1,6)))} WITH VARREAD() && Call Help code
  765:  {endif
  766:   if is_recalc then}
  767:  ON KEY LABEL {on_key_recalc} \
  768:  DO {"R_" + lower(rtrim(substr(name,1,6)))} WITH VARREAD() && Call Recalc code
  769:  {endif
  770:   if is_zoom then}
  771:  ON KEY LABEL {on_key_zoom} \
  772:  DO {"Z_" + lower(rtrim(substr(name,1,6)))} WITH VARREAD() && Call Zoom code
  773:  {endif
  774:   lmarg(0)}
  775:  RETURN (ll_return)
  776:  *-- EOP: {get_udfname(FLD_FIELDNAME)}
  777:
  778:  {              endif
  779:            next flds
  780:        endif   // there were POPUP VALID clauses
  781:
  782:       return;
  783:  // eof - make_pop_code()
  784:  enddef
  785:
  786:  //--------------------------------------------------------------
  787:  define make_shadow_proc()
  788:       // Make the dBASE code for shadowing
  789:       print("*"+replicate("-",78)+crlf);
  790:  }
  791:  PROCEDURE _Shadowg                      && displays shadow that grows
  792:  {    lmarg(offset)}
  793:  PARAMETER x1,y1,x2,y2
  794:  PRIVATE   x1,y1,x2,y2
  795:
  796:  x0 = x2+1
  797:  y0 = y2+2
  798:  dx = 1
  799:  dy = (y2-y1) / (x2-x1)
  800:  DO WHILE x0 <> x1 .OR. y0 <> y1+2
  801:    @ x0,y0 FILL TO x2+1,y2+2 COLOR n+/n
  802:    x0 = IIF(x0<>x1,x0 - dx,x0)
  803:    y0 = IIF(y0<>y1+2,y0 - dy,y0)
  804:    y0 = IIF(y0<y1+2,y1+2,y0)
  805:  ENDDO
  806:  {    lmarg(0)}
  807:  RETURN
  808:  *-- EOP: _Shadowg
  809:
  810:  {print("*"+replicate("-",78)+crlf);}
  811:  PROCEDURE _dbtrap                             && error routine for SET("dbtrap")
  812:  {    var wcol1, wcol2, error_msg_length;
  813:        error_msg_length = len( dbtrap_err)
  814:        wcol1 = (screen_width/2) - ( error_msg_length/2) - 2
  815:        wcol2 = (screen_width/2) + ( error_msg_length/2) + 2
  816:       lmarg(offset);
  817:  }
  818:  SET CURSOR OFF
  819:  PRIVATE ALL LIKE l?_*
  820:  SAVE SCREEN TO _dbtrap
  821:  DO _Shadowg WITH 10, {wcol1}, 15, {wcol2}
  822:  DEFINE WINDOW _dbtrap FROM 10,{wcol1} TO 15,{wcol2} DOUBLE
  823:  ACTIVATE WINDOW _dbtrap
  824:  lc_error = "{dbtrap_err}"
  825:  lc_error2 = "{any_key}"
  826:  @ 1, CENTER( lc_error,  {wcol2 - wcol1}) SAY lc_error
  827:  @ 2, CENTER( lc_error2, {wcol2 - wcol1}) SAY lc_error2
  828:  lc_wait = INKEY(10)
  829:  RELEASE WINDOW _dbtrap
  830:  RESTORE SCREEN FROM _dbtrap
  831:  RELEASE SCREEN _dbtrap
  832:  SET CURSOR ON
  833:  {    lmarg(0)}
  834:  RETURN
  835:  *-- EOP: _dbtrap
  836:  {    return;
  837:  enddef // make_shadow_proc()
  838:
  839:  //--------------------------------------------------------------
  840:  define make_help_code()
  841:       //------------------------------------
  842:       // Make procedures for the help system
  843:       // called from form.gen
  844:       //------------------------------------
  845:        if is_help then
  846:           // If the udf file has not already been created, make it.
  847:          if !udf_file then
  848:             if !make_udf() then
  849:                return 0;
  850:             endif
  851:             // Put up the UDF header
  852:             udf_header()
  853:          endif
  854:          // Make procedures for the help system
  855:          make_help()
  856:        endif
  857:  return;
  858:  enddef
  859:
  860:  //--------------------------------------------------------------
  861:  define make_help()
  862:     // Make the dBASE code for help
  863:     var help_name;
  864:     help_name = "H_" + lower(rtrim(substr(name,1,6)))
  865:     print("*"+replicate("-",78)+crlf);
  866:  }
  867:
  868:  PROCEDURE {help_name}
  869:  {    lmarg(offset)}
  870:  *-- Activates the HELP window
  871:  PARAMETER lc_var
  872:  PRIVATE ALL LIKE l?_*
  873:  IF .NOT. FILE("{fileroot(hlp_name)}.dbf")
  874:     *-- Help file has been deleted or can't be found
  875:     RETURN
  876:  ENDIF
  877:
  878:  SET CURSOR OFF
  879:  ON KEY LABEL {on_key_help}
  880:
  881:  *-- Select workarea and open Help dbf
  882:  lc_area = ALIAS()
  883:  SELECT SELECT()
  884:  USE {fileroot(hlp_name)} ORDER fld_name NOUPDATE   && Open HELP .dbf
  885:
  886:  lc_exact = SET("EXACT")                && Store value of EXACT
  887:  SET EXACT ON
  888:  SEEK lc_var
  889:  SET EXACT &lc_exact.
  890:
  891:  IF FOUND()                             && If found show Help
  892:    ln_t = 5
  893:    ln_l = 6
  894:    ln_b = 15
  895:    ln_r = 74
  896:    DEFINE WINDOW {lower(help_name)} FROM ln_t+1, ln_l+2 TO ln_b-1, ln_r-2 NONE
  897:    ON ERROR lc_error = error()
  898:    SAVE SCREEN TO {lower(help_name)}
  899:
  900:    *-- Make Help Box
  901:    DO _Shadowg WITH ln_t, ln_l, ln_b, ln_r
  902:    @ ln_t+1, ln_l+1 CLEAR TO ln_b-1, ln_r-1
  903:    @ ln_t, ln_l TO ln_b, ln_r DOUBLE
  904:
  905:    ln_memline = SET("MEMO")
  906:    SET MEMOWIDTH TO 65
  907:    IF MEMLINES(fld_help) > 9
  908:      @ ln_t+1,ln_r SAY CHR(24)
  909:      @ ln_b-1,ln_r SAY CHR(25)
  910:      SET CURSOR ON
  911:    ENDIF
  912:    lc_string = CHR(185)+ [ Help for ] + TRIM(fld_headng) +[ ] + CHR(204)
  913:    lc_message = IIF( MEMLINES(fld_help) > 9 , ;
  914:                      "{help_msg1}" , ;
  915:                      "" ;
  916:  //                    "{help_msg1 + help_msg2}" , ;
  917:  //                    "{help_msg2}" ;
  918:                    )
  919:
  920:    @ ln_t,CENTER(lc_string,80) SAY lc_string
  921:    @ 0,0 GET fld_help OPEN WINDOW {lower(help_name)} MESSAGE lc_message
  922:  //  ON KEY LABEL {on_key_toggle} DO _Toggle
  923:  //  ON KEY LABEL {on_key_move} DO _MoveWind WITH WINDOW(), lc_message
  924:    READ
  925:    SET MEMOWIDTH TO ln_memline
  926:    ON ERROR
  927:  //  ON KEY LABEL {on_key_toggle}
  928:  //  ON KEY LABEL {on_key_move}
  929:    RELEASE WINDOW {lower(help_name)}
  930:    RESTORE SCREEN FROM {lower(help_name)}
  931:    RELEASE SCREEN {lower(help_name)}
  932:  ENDIF
  933:  SET MESSAGE TO
  934:  SET CURSOR ON
  935:  USE                                              && Close help file
  936:  SELECT (lc_area)                                 && Back to edit work area
  937:  ON KEY LABEL {on_key_help} DO {help_name} WITH VARREAD()
  938:  {    lmarg(0)}
  939:  RETURN
  940:  *-- EOP: {help_name}
  941:
  942:  //{    print("*"+replicate("-",78)+crlf);}
  943:  //PROCEDURE _Toggle
  944:  //{    lmarg(offset)}
  945:  //PRIVATE ln_wait
  946:  //*-- Toggles the Help message back to the original screen
  947:  //SAVE SCREEN TO Toggle
  948:  //RESTORE SCREEN FROM {lower(help_name)}
  949:  //{    if (scrn_size == 24 or scrn_size == 42) then}
  950:  //@ {scrn_size}, 0
  951:  //@ {scrn_size}, CENTER("{any_key}", {screen_width}) SAY "{any_key}"
  952:  //{    else}
  953:  //SET MESSAGE TO "{any_key}"
  954:  //{    endif}
  955:  //ln_wait = INKEY(15)
  956:  //RESTORE SCREEN FROM Toggle
  957:  //RELEASE SCREEN Toggle
  958:  //SET MESSAGE TO lc_message
  959:  //{    lmarg(0)}
  960:  //RETURN
  961:  //*-- EOP: _Toggle
  962:  //
  963:  {return;
  964:  enddef
  965:
  966:  //--------------------------------------------------------------
  967:  define make_other_udfs()
  968:      // Make other UDF's used durning form processing
  969:      print(crlf + "*"+replicate("-",78)+crlf);
  970:  }
  971:  PROCEDURE _Cut
  972:  {    lmarg(offset)}
  973:  *-- Cut data from a field
  974:  PRIVATE ALL LIKE l?_*
  975:
  976:  lc_field = VARREAD()
  977:  lc_type = TYPE( lc_field)
  978:  SAVE SCREEN TO _cut
  979:
  980:  DO CASE
  981:  CASE lc_type = "C"
  982:      gc_cut = TRIM( &lc_field.)
  983:  CASE lc_type $ "NF"
  984:      ln_cnt = 0
  985:      ln_number = &lc_field.
  986:      DO WHILE _numdec( ln_number)
  987:         ln_number = ln_number * 10
  988:         ln_cnt = ln_cnt + 1
  989:      ENDDO
  990:      gc_cut = LTRIM( STR( &lc_field., 14, ln_cnt))
  991:  CASE lc_type = "D"
  992:      gc_cut = DTOC( &lc_field.)
  993:  CASE lc_type = "L"
  994:      gc_cut = IIF( &lc_field., "Y", "F")
  995:  CASE lc_type = "M"
  996:      gc_cut = SUBSTR( &lc_field., 1, 254)
  997:      ln_len = LEN( TRIM( gc_cut))
  998:      ln_cnt = 1
  999:
 1000:      DO WHILE ln_cnt <= ln_len
 1001:         *-- Get rid of MODI COMM's soft carriage returns characters
 1002:         IF ASC( SUBSTR( gc_cut, ln_cnt, 1)) = 141 .OR.;
 1003:            ASC( SUBSTR( gc_cut, ln_cnt, 1)) =  10 .OR.;
 1004:            ASC( SUBSTR( gc_cut, ln_cnt, 1)) =  13
 1005:
 1006:            IF ASC( SUBSTR( gc_cut, ln_cnt, 1)) =  13
 1007:               gc_cut = STUFF( gc_cut, ln_cnt, 1, " ")
 1008:            ELSE
 1009:               gc_cut = STUFF( gc_cut, ln_cnt, 1, "")
 1010:            ENDIF
 1011:
 1012:            ln_len = LEN( TRIM( gc_cut))             && Length of string can change
 1013:            LOOP
 1014:         ENDIF
 1015:         ln_cnt = ln_cnt + 1
 1016:        ENDDO
 1017:  ENDCASE
 1018:
 1019:  lc_message = SUBSTR( gc_cut, 1, {(screen_width - 1) - len(paste_msg1)}) + "{paste_msg1}"
 1020:  {    if (scrn_size == 24 or scrn_size == 42) then}
 1021:  @ {scrn_size}, CENTER(lc_message, {screen_width}) SAY lc_message
 1022:  {    else}
 1023:  SET MESSAGE TO lc_message
 1024:  {    endif}
 1025:  ln_key = INKEY(2.5)
 1026:  gc_cut = gc_cut + SPACE( 254 - LEN( gc_cut))
 1027:  SET MESSAGE TO
 1028:  RESTORE SCREEN FROM _cut
 1029:  RELEASE SCREEN _cut
 1030:  {    lmarg(0)}
 1031:  RETURN
 1032:
 1033:  {    print("*"+replicate("-",78)+crlf);}
 1034:  PROCEDURE _Paste
 1035:  {    lmarg(offset)}
 1036:  *-- Cut data to a field
 1037:  PRIVATE ALL LIKE l?_*
 1038:
 1039:  lc_field = VARREAD()                               && Grab field we left from
 1040:  lc_type = TYPE( lc_field)                          && Grab the data type
 1041:  lc_cut = TRIM( gc_cut)                             && Trim blanks from cut data
 1042:
 1043:  IF lc_type = "D"
 1044:      *-- Remove "/" from character data so that KEYBOARD will work on a
 1045:      *-- date field
 1046:  //  KJN "/" -> set("sepa")
 1047:      lc_cut = STUFF(lc_cut, AT("/", lc_cut), 1, "") && Get rid of first  "/"
 1048:      lc_cut = STUFF(lc_cut, AT("/", lc_cut), 1, "") && Get rid of second "/"
 1049:  ENDIF
 1050:  *-- Keyboard cut data into the field
 1051:  DO CASE
 1052:     CASE lc_type $ "NFD"
 1053:        *-- Start at the beginning of the field and clear it.
 1054:        KEYBOARD ( CHR(kn_home) + CHR(kn_CtrlY) + lc_cut) CLEAR
 1055:     CASE lc_type <> "M"
 1056:        *-- Paste at the location of the cursor
 1057:        KEYBOARD (lc_cut) CLEAR
 1058:     OTHERWISE
 1059:        IF LEN( &lc_field.) > 0
 1060:           *-- Pad space to offset "scrap" from end of memo
 1061:           lc_cut = " " + lc_cut
 1062:        ENDIF
 1063:        REPLACE &lc_field. WITH lc_cut ADDITIVE         && Replace into memo field
 1064:        ln_keyboard = CHR(kn_ctrlhme) + CHR(kn_ctrlpdn) + ;
 1065:                      CHR(kn_space) + CHR(kn_bakspce)   && Makes EDIT think data has changed
 1066:        KEYBOARD (ln_keyboard) CLEAR                    && Move to bottom of memo
 1067:  ENDCASE
 1068:  {    lmarg(0)}
 1069:  RETURN
 1070:
 1071:  {    print("*"+replicate("-",78)+crlf);}
 1072:  PROCEDURE _Edpaste
 1073:  {    lmarg(offset)}
 1074:  *-- Edit Cut data
 1075:  PRIVATE ALL LIKE l?_*
 1076:
 1077:  lc_deli = SET("DELIMITERS")
 1078:  lc_form = SET("FORMAT")
 1079:  SET DELIMITERS OFF
 1080:  SET FORMAT TO
 1081:  SAVE SCREEN TO _edpaste
 1082:  DEFINE WINDOW _edpaste FROM \
 1083:  {    if !(scrn_size == 24 or scrn_size == 42) then
 1084:          scrn_size-2},0 TO {scrn_size},79
 1085:  {    else
 1086:          scrn_size-3},0 TO {scrn_size-1},79
 1087:  {    endif}
 1088:
 1089:  lc_message = "{paste_msg2}"
 1090:  lc_message = IIF("500" $ VERSION(1), ;
 1091:                   LEFT( lc_message, LEN( lc_message) - 17) , lc_message)
 1092:  IF .NOT. "500" $ VERSION(1)
 1093:     ON KEY LABEL {on_key_move} DO _MoveWind WITH WINDOW(), lc_message
 1094:  ENDIF
 1095:  ACTIVATE WINDOW _edpaste
 1096:  SET MESSAGE TO lc_message
 1097:  @ 0,0 GET gc_cut PICTURE "@S78"
 1098:  READ
 1099:  ON KEY LABEL {on_key_move}
 1100:  SET MESSAGE TO
 1101:  RELEASE WINDOW _edpaste
 1102:  RESTORE SCREEN FROM _edpaste
 1103:  RELEASE SCREEN _edpaste
 1104:  SET DELIMITERS &lc_deli.
 1105:  SET FORM TO (lc_form)
 1106:  {    lmarg(0)}
 1107:  RETURN
 1108:
 1109:  {    print("*"+replicate("-",78)+crlf);}
 1110:  PROCEDURE _MoveWind
 1111:  PARAMETER wind_name, message
 1112:  {    lmarg(offset)}
 1113:  *----------------------------------------------------------
 1114:  *- Move the &wind_name. window based on arrow keys.  Any
 1115:  *- other key stops the move process.
 1116:  *----------------------------------------------------------
 1117:  ON KEY LABEL {on_key_move}
 1118:  ON ERROR ?? CHR(7)
 1119:  SET MESSAGE TO
 1120:  DO WHILE .T.
 1121:    SET MESSAGE TO {wind_msg1}
 1122:    ln_keyhit = INKEY(0)
 1123:    IF ln_keyhit <> 0
 1124:      DO CASE
 1125:        CASE ln_keyhit = kn_RghtArw               && Right arrow
 1126:           MOVE WINDOW &wind_name. BY 0,1
 1127:        CASE ln_keyhit = kn_UpArw                 && Up arrow
 1128:           MOVE WINDOW &wind_name. BY -1,0
 1129:        CASE ln_keyhit = kn_LeftArw               && Left arrow
 1130:           MOVE WINDOW &wind_name. BY 0,-1
 1131:        CASE ln_keyhit = kn_DownArw               && Down Arrow
 1132:           MOVE WINDOW &wind_name. BY 1,0
 1133:        OTHERWISE
 1134:           EXIT
 1135:      ENDCASE
 1136:    ENDIF
 1137:  ENDDO
 1138:  ON ERROR
 1139:  ON KEY LABEL {on_key_move} DO _MoveWind WITH WINDOW(), "&message."
 1140:  SET MESSAGE TO message
 1141:  {    lmarg(0)}
 1142:  RETURN
 1143:  *-- EOP: _MoveWind
 1144:
 1145:  {    print("*"+replicate("-",78)+crlf);}
 1146:  FUNCTION _numdec
 1147:  PARAMETER ln_dec
 1148:  IF ln_dec - INT(ln_dec) > 0
 1149:     RETURN .T.
 1150:  ELSE
 1151:     RETURN .F.
 1152:  ENDIF
 1153:  *-- EOF: _numdec
 1154:
 1155:  {    print("*"+replicate("-",78)+crlf);}
 1156:  FUNCTION Center
 1157:  *-- UDF to center a string.
 1158:  *-- lc_string = String to center
 1159:  *-- ln_width = Width of screen to center in
 1160:  *--
 1161:  *-- Ex. @ 15,center(string,80) say string
 1162:  *-- Will center the <string> withing 80 columns
 1163:  PARAMETER lc_string, ln_width
 1164:  RETURN ((ln_width/2)-(LEN(lc_string)/2))
 1165:  *-- EOP: Center()
 1166:
 1167:  {print("*"+replicate("-",78)+crlf);}
 1168:  PROCEDURE _key_vars
 1169:  *----------------------------------------------------------------------------
 1170:  * Enumerate the key values for LASTKEY() and INKEY() functions
 1171:  *
 1172:  * To check for the Escape key after the INKEY()
 1173:  *
 1174:  *   ln_key = INKEY(0)   && Wait for any key press
 1175:  *   IF ln_key = kn_Esc  && Escape was pressed
 1176:  *     DO esc_hand
 1177:  *   ENDIF
 1178:  *
 1179:  *----------------------------------------------------------------------------
 1180:  IF TYPE("kn_end") = "U"
 1181:  {lmarg(offset)}
 1182:  PUBLIC kn_End     , kn_Tab     , kn_Enter   , kn_CtrlEnd , kn_CtrlY   , ;
 1183:         kn_Home    , kn_Esc     , kn_CtrlHme , kn_CtrlPDn , kn_CtrlPUp , ;
 1184:         kn_Space   , kn_BakSpce , kn_RghtArw , kn_UpArw   , kn_LeftArw , ;
 1185:         kn_DownArw , kn_PgDn    , kn_PgUp    , kn_F1      , kn_Del     , ;
 1186:         kn_CtrLArw , kn_CtrRArw , kn_f7      , kn_ShftF7
 1187:
 1188:    kn_End     =   2      && Ctrl-B
 1189:    kn_Tab     =   9      && Ctrl-I
 1190:    kn_Enter   =  13      && Ctrl-M
 1191:    kn_CtrlEnd =  23      && Ctrl-W
 1192:    kn_CtrlY   =  25
 1193:    kn_Home    =  26      && Ctrl-Z
 1194:    kn_Esc     =  27      && Ctrl-[
 1195:    kn_CtrlHme =  29      && Ctrl-]
 1196:    kn_CtrlPDn =  30      && Ctrl-PgDn
 1197:    kn_CtrlPUp =  31      && Ctrl-PgUp
 1198:    kn_Space   =  32
 1199:    kn_BakSpce = 127
 1200:    kn_RghtArw =   4      && Ctrl-D
 1201:    kn_UpArw   =   5      && Ctrl-E
 1202:    kn_LeftArw =  19      && Ctrl-S
 1203:    kn_DownArw =  24      && Ctrl-X
 1204:    kn_PgDn    =   3      && Ctrl-C
 1205:    kn_PgUp    =  18      && Ctrl-R
 1206:    kn_F1      =  28      && Ctrl-\
 1207:    kn_Del     =   7      && Ctrl-G
 1208:    kn_CtrLArw =   1      && Ctrl-A
 1209:    kn_CtrRArw =   6      && Ctrl-F
 1210:    kn_F7      =  -6
 1211:    kn_ShftF7   = -26
 1212:
 1213:  *----------------------------------------------------------------------------
 1214:  * Enumerate the key values for READKEY()
 1215:  *
 1216:  * To check to see if data has changed
 1217:  *
 1218:  *   IF READKEY() >= rn_updated   && Data has changed
 1219:  *     REPLACE name WITH m->name
 1220:  *   ENDIF
 1221:  *
 1222:  * To check for page down regardless of data change
 1223:  *
 1224:  *   ln_readkey = READKEY()
 1225:  *   IF ln_readkey = rn_PgDn .OR. ln_readkey = rn_PgDn+rn_Updated
 1226:  *     DO pgdn_hand
 1227:  *   ENDIF
 1228:  *
 1229:  *----------------------------------------------------------------------------
 1230:  PUBLIC rn_Updated , rn_LeftArw , rn_BakSpce , rn_RghtArw , rn_CtrLArw , ;
 1231:         rn_CtrRArw , rn_UpArw   , rn_DownArw , rn_PgUp    , rn_PgDn    , ;
 1232:         rn_Esc     , rn_CtrlEnd , rn_Enter   , rn_EnterA  , rn_CtrlHme , ;
 1233:         rn_CtrlPUp , rn_CtrlPDn , rn_F1
 1234:
 1235:    rn_Updated = 256      && Add to rn_key value for updated condition
 1236:    rn_LeftArw =   0      && Includes Ctrl-S and Ctrl-H - backward one character
 1237:    rn_BakSpce =   0      && backward one character
 1238:    rn_RghtArw =   1      && Includes Ctrl-D and Ctrl-L - forward one character
 1239:    rn_CtrLArw =   2      && Ctrl-Left Arrow, includes Ctrl-A - previous word
 1240:    rn_CtrRArw =   3      && Ctrl-Right Arrow, includes Ctrl-F - next word
 1241:    rn_UpArw   =   4      && Includes Ctrl-E and Ctrl-K - backward one field
 1242:    rn_DownArw =   5      && Includes Ctrl-J and Ctrl-X - forward one field
 1243:    rn_PgUp    =   6      && Includes Ctrl-R - backward one screen
 1244:    rn_PgDn    =   7      && Includes Ctrl-C - forward one screen
 1245:    rn_Esc     =  12      && Includes Ctrl-Q - Terminate w/o save
 1246:    rn_CtrlEnd =  14 + rn_updated  && Includes Ctrl-W - Terminate w/save
 1247:    rn_Enter   =  15      && Includes Ctrl-M  RETURN of fill last record
 1248:    rn_EnterA  =  16      && Enter at the beginning of a record in APPEND
 1249:    rn_CtrlHme =  33      && Ctrl-Home - Menu display toggle
 1250:    rn_CtrlPUp =  34      && Ctrl-PgUp - Zoom Out
 1251:    rn_CtrlPDn =  35      && Ctrl-PgDn - Zoom In
 1252:    rn_F1      =  36      && Help function key
 1253:  {lmarg(0)}
 1254:  ENDIF
 1255:
 1256:  RETURN
 1257:  *-- EOP: _key_vars
 1258:
 1259:  {return;
 1260:  enddef
 1261:
 1262:  //--------------------------------------------------------------
 1263:
 1264:  define check_for_gen_extensions()
 1265:     // Check for all the different extensions to forms support for this fmt file
 1266:     // Help extension
 1267:     var dbf_name;
 1268:     // next line modified to include rtrim statement per Bill Ramos
 1269:     hlp_name = frame_path + rtrim(substr( fileroot( fmt_name), 1, 6)) + "_H"
 1270:     if fileexist(hlp_name + ".DBF") and fileexist(hlp_name + ".DBT") then
 1271:        is_help = 1      // Global flag for help support
 1272:     // Following lines added by Barry Fox to prompt user for the name of the
 1273:     // the database to check for help support.  This allows the generation
 1274:     // help support when the form name differs from the parent database
 1275:     // name.
 1276:       else
 1277:     dbf_name = askuser("Enter dbf name for help support or press ENTER to continue ","",12)
 1278:     hlp_name = frame_path + rtrim(substr( fileroot( dbf_name), 1, 6)) + "_H"
 1279:     if fileexist(hlp_name + ".DBF") and fileexist(hlp_name+ ".DBT" ) then
 1280:        is_help = 1
 1281:   endif
 1282:  endif
 1283:     foreach FLD_ELEMENT flds
 1284:         // Popup or Browse support
 1285:         if popup_or_browse(flds) then
 1286:            is_popup = 1
 1287:            workarea_cnt = workarea_cnt + 1
 1288:         endif
 1289:         // Zoom support
 1290:         if is_zoom(FLD_OK_COND) then
 1291:            is_zoom = 1
 1292:         endif
 1293:         // Recalc support
 1294:         if is_recalc(FLD_DESCRIPT) then
 1295:            is_recalc = 1
 1296:         endif
 1297:         // Replace lookup support
 1298:         if is_replace(FLD_OK_COND) then
 1299:            is_replace = 1
 1300:         endif
 1301:     next flds
 1302:     if is_help or is_popup or is_zoom or is_recalc or is_replace then
 1303:        return 1;
 1304:     else
 1305:        return 0;
 1306:     endif
 1307:  enddef
 1308:
 1309:  //--------------------------------------------------------------
 1310:  define popup_or_browse(cur)             // Pass in foreach cursor
 1311:     // Check for "popup" or "browse" string for this fmt file
 1312:     if at("POPUP",  upper(ltrim(cur.FLD_OK_COND))) == "2" or
 1313:        at("BROWSE", upper(ltrim(cur.FLD_OK_COND))) == "2" then
 1314:        return 1;
 1315:     else
 1316:        return 0;
 1317:     endif
 1318:  enddef
 1319:
 1320:  //--------------------------------------------------------------
 1321:  define new_page(cur)               // Pass in foreach cursor
 1322:     // Checks for a page break and adjusts line_cnt and page_cnt
 1323:     if nul2zero(cur.ROW_POSITN) - line_cnt > scrn_size then
 1324:        line_cnt = line_cnt + scrn_size + 1;
 1325:        ++page_cnt;
 1326:        return 1;
 1327:     endif
 1328:  return 0;
 1329:  enddef
 1330:
 1331:  //--------------------------------------------------------------
 1332:  define parse_line( before,         // Out: chars before the look_for string
 1333:                     input,          // In:  line being parsed
 1334:                     look_for        // In:  string searched for
 1335:                   )                 // Rtn: chars after the look_for string
 1336:       // If the look_for sting is not found, the before sting will equal the
 1337:       // input string, and the returned value will be NUL
 1338:       var location, after;
 1339:
 1340:       location = at(look_for, upper(input))
 1341:       if location == 0 then
 1342:            before = input
 1343:            return ( "" );
 1344:       endif
 1345:
 1346:       before = substr( input, 1, location-1)
 1347:       after  = substr( input, location)
 1348:       after  = substr( after, 1, len(after) - 1)
 1349:
 1350:       return ( alltrim( substr( after,
 1351:                                  1 + len(look_for),
 1352:                                  get_next_key_word(
 1353:                                                    substr( after,
 1354:                                                            1 + len( look_for)
 1355:                                                          )
 1356:                                                    )
 1357:                               )
 1358:                       )
 1359:              );
 1360:  // end: parse_line()
 1361:  enddef
 1362:
 1363:  //--------------------------------------------------------------
 1364:  define get_next_key_word(rest_of_str)   // String to search for keyword
 1365:     var str_length;
 1366:
 1367:     str_length = len(rest_of_str)
 1368:     rest_of_str = upper(rest_of_str)
 1369:
 1370:     for cnt = 1 to str_length
 1371:
 1372:        if at(" ORDER", substr(rest_of_str, cnt)) == 1  or
 1373:           at(" REQ",   substr(rest_of_str, cnt)) == 1  or
 1374:           at(" SHADOW",substr(rest_of_str, cnt)) == 1  or
 1375:           at(" FIELDS",substr(rest_of_str, cnt)) == 1  or
 1376:           at(" UPDATE",substr(rest_of_str, cnt)) == 1  or
 1377:           at(" FORMAT",substr(rest_of_str, cnt)) == 1  or
 1378:           at(" FROM",  substr(rest_of_str, cnt)) == 1  or
 1379:           at(" REPLACE",  substr(rest_of_str, cnt)) == 1  or
 1380:           at(" ZOOM",  substr(rest_of_str, cnt)) == 1  then
 1381:             exit
 1382:        endif
 1383:
 1384:     next
 1385:     return cnt - 1;
 1386:  enddef
 1387:
 1388:  //--------------------------------------------------------------
 1389:  // Parsing routines for pulling objects out of the VALID string
 1390:  // "POPUP" = "file->fld_name ORDER key_fld REQ"
 1391:  // 1234567890123456789012345678901234567890123
 1392:  //            1         2         3         4
 1393:  define get_file(valid_str)
 1394:       var  s_arrow,            // String "->"
 1395:            test,
 1396:            s_equal,            // String "="
 1397:            next_alpha,
 1398:            at_alias,
 1399:            s_before,           // String before the searched for item
 1400:            r_target,           // Remainder of the target string after item
 1401:            use_name;           // Return for file
 1402:
 1403:       s_arrow = "->"
 1404:       s_equal = "="
 1405:       r_target = parse_line( s_before, valid_str, s_equal )      // ' "file->...'
 1406:       next_alpha = atalpha(r_target)                             // 3
 1407:       at_alias = at(s_arrow, r_target)                           // 7
 1408:       use_name = substr(r_target,next_alpha,at_alias-next_alpha) // 'file'
 1409:
 1410:       return cap_first(use_name);
 1411:  enddef
 1412:
 1413:  //--------------------------------------------------------------
 1414:  define get_udfname(fld_str)
 1415:       // Create UDF name
 1416:       return cap_first( "l_" + substr( fld_str,1,6) );
 1417:  enddef
 1418:
 1419:  //--------------------------------------------------------------
 1420:  define get_key(valid_str)
 1421:       var  s_order,            // String "ORDER "
 1422:            at_space,
 1423:            s_before,           // String before the searched for item
 1424:            r_target,           // Remainder of the target string after item
 1425:            order_tag;          // Search TAG to ORDER BY
 1426:
 1427:       s_order = "ORDER "
 1428:       r_target = parse_line( s_before, valid_str, s_order ) // 'key_fld REQ'
 1429:       at_space = at(" ",r_target)
 1430:       if at_space == 0 then
 1431:            order_tag = substr(r_target, 1, len(r_target)) // 'key_fld"'
 1432:       else
 1433:            order_tag = substr(r_target, 1, at_space)
 1434:       endif
 1435:       return cap_first(order_tag);
 1436:  enddef
 1437:
 1438:  //--------------------------------------------------------------
 1439:  define get_field(valid_str)
 1440:       var  s_arrow,            // String "->"
 1441:            at_space,
 1442:            s_before,           // String before the searched for item
 1443:            r_target,           // Remainder of the target string after item
 1444:            fld_name;           // Field name to lookup in target file
 1445:
 1446:       s_arrow = "->"
 1447:       r_target = parse_line( s_before,
 1448:                              valid_str, s_arrow ) // 'fld_name ORDER...'
 1449:       at_space = at(" ",r_target)
 1450:
 1451:       fld_name = ( at_space == 0 ? r_target : substr(r_target, 1, at_space-1) );
 1452:
 1453:       return cap_first(fld_name);
 1454:  enddef
 1455:
 1456:  //--------------------------------------------------------------
 1457:  define get_popname(valid_str)
 1458:       // Create popup name
 1459:       return ( lower( "l_" + substr( get_field( valid_str),1,6) ) );
 1460:  enddef
 1461:
 1462:  //--------------------------------------------------------------
 1463:  define is_required(valid_str)
 1464:       // Determines if the field is required before moving to the next field
 1465:       return ( ( at(" REQ ",  upper(valid_str)) ? 1 : 0 ) or
 1466:                ( at(" REQ\"", upper(valid_str)) ? 1 : 0 )
 1467:              );
 1468:  enddef
 1469:
 1470:  //--------------------------------------------------------------
 1471:  define is_shadow(valid_str)
 1472:       // Determines if the user wants shadowing for popup
 1473:       return ( ( at(" SHADOW ",  upper(valid_str)) ? 1 : 0 ) or
 1474:                ( at(" SHADOW\"", upper(valid_str)) ? 1 : 0 )
 1475:              );
 1476:  enddef
 1477:
 1478:  //--------------------------------------------------------------
 1479:  define is_update(valid_str)
 1480:       // Determines if the user wants updating in the BROWSE
 1481:       return ( ( at(" UPDATE ",  upper(valid_str)) ? 1 : 0 ) or
 1482:                ( at(" UPDATE\"", upper(valid_str)) ? 1 : 0 )
 1483:              );
 1484:  enddef
 1485:
 1486:  //--------------------------------------------------------------
 1487:  define is_format_file(k, valid_str)
 1488:      // Determines if the user has a format file entered and is valid
 1489:      var is_format, format_file;
 1490:
 1491:      is_format = ( at(" FORMAT ", upper(valid_str)) ? 1 : 0 );
 1492:
 1493:      if is_format then
 1494:         format_file = parse_line("", k.FLD_OK_COND, "FORMAT ")
 1495:         format_file = (at(".", format_file) ? format_file : format_file + ".fmt");
 1496:         is_format = ( fileexist(format_file) ? 1 : 0 );
 1497:       endif
 1498:
 1499:       return is_format;
 1500:  enddef
 1501:
 1502:  //--------------------------------------------------------------
 1503:  define is_window(valid_str)
 1504:       // Determines if the user wants windowing for BROWSE
 1505:       return ( at(" FROM ",upper(valid_str)) ? 1 : 0 );
 1506:  enddef
 1507:
 1508:  //--------------------------------------------------------------
 1509:  define is_fields(valid_str)
 1510:       // Determines if the user wants to set fields for BROWSE
 1511:       return ( at(" FIELDS ",upper(valid_str)) ? 1 : 0 );
 1512:  enddef
 1513:
 1514:  //--------------------------------------------------------------
 1515:  define is_zoom(valid_str)
 1516:       // Determines if the field wants zoom before moving to the next field
 1517:       return ( ( at(" ZOOM ",  upper(valid_str)) ? 1 : 0 ) or
 1518:                ( at(" ZOOM\"", upper(valid_str)) ? 1 : 0 )
 1519:              );
 1520:  enddef
 1521:
 1522:  //--------------------------------------------------------------
 1523:  define is_recalc(descrip_str)
 1524:       // Determines if the users wants recalc on calculated fields
 1525:       return  ( at("RECALC",  upper(descrip_str)) ? 1 : 0 );
 1526:  enddef
 1527:
 1528:  //--------------------------------------------------------------
 1529:  define is_replace(valid_str)
 1530:       // Determines if the users wants recalc on calculated fields
 1531:       return  ( at(" REPLACE ",  upper(valid_str)) ? 1 : 0 );
 1532:  enddef
 1533:
 1534:  //--------------------------------------------------------------
 1535:  define get_pop_shadow(field_template)   // Pass in FLD_TEMPLATE to deter. shadow
 1536:       if trow_positn < max_pop_row then
 1537:          trow_positn + 1},{tcol_positn},{scrn_size-1},{tcol_positn+len(Field_template)+1}
 1538:  {    else
 1539:          trow_positn - 11},{tcol_positn},{trow_positn - 1},{tcol_positn+len(Field_template)+1}
 1540:  {    endif
 1541:       return;
 1542:  enddef
 1543:
 1544:  //--------------------------------------------------------------
 1545:  define get_browse_shadow(from_to)
 1546:       // Determine shadow coordinates for BROWSE
 1547:
 1548:       var from_clause, from_coord, to_coord, r1, c1, r2, c2;
 1549:
 1550:       // Get From clause for the DEFINE WINDOW
 1551:       from_clause = alltrim( upper( parse_line("", from_to, "FROM ")))
 1552:
 1553:       if !from_clause then return ""; endif
 1554:
 1555:       // Get FROM coordinates
 1556:       from_coord = alltrim( substr( from_clause, 1, at("TO", from_clause) - 1))
 1557:       r1 = substr( from_coord, 1, at(",", from_coord)-1)
 1558:       c1 = substr( from_coord, at(",", from_coord)+1)
 1559:
 1560:       // Get TO coordinates
 1561:       to_coord   = alltrim( substr( from_clause, at("TO", from_clause) + 2))
 1562:       r2 = substr( to_coord, 1, at(",", to_coord)-1)
 1563:       // Check shadow height and adjust if necessary
 1564:       r2 = (val( r2) + 1) <= scrn_size ? r2 : str( scrn_size - 1) ;
 1565:
 1566:       c2 = substr( to_coord, at(",", to_coord)+1)
 1567:       // Check shadow width and adjust if necessary
 1568:       c2 = (val(c2)+2) <= 79 ? c2 : str(77) ;
 1569:
 1570:       print( r1 + "," + c1 + "," + r2 + "," + c2)
 1571:       return;
 1572:  enddef
 1573:
 1574:  //--------------------------------------------------------------
 1575:  define get_browse_fields_list(k)
 1576:    // Search for "FIELDS" in FLD_OK_COND and return the field list for BROWSE
 1577:    var field_list, key_length;
 1578:
 1579:    field_list = parse_line("", k.FLD_OK_COND, "FIELDS ")
 1580:    key_length = len( temp_key)
 1581:
 1582:    if is_update(k.FLD_OK_COND) then
 1583:      // Add /R readonly flag to KEY field of lookup table, if updateable
 1584:      return substr( field_list, 1, at( upper(temp_key), upper(field_list)) + key_length -1)
 1585:              + " /R" +
 1586:            substr( field_list, at( upper(temp_key), upper(field_list)) + key_length);
 1587:    else
 1588:      return field_list;
 1589:    endif
 1590:  enddef
 1591:
 1592:  //--------------------------------------------------------------
 1593:  define get_browse_window(k)
 1594:    // Search for "FROM" in FLD_OK_COND and return the list for BROWSE
 1595:    return parse_line("", k.FLD_OK_COND, "FROM ");
 1596:  enddef
 1597:
 1598:  //--------------------------------------------------------------
 1599:  define get_format_file(_file)
 1600:    // Search for "FORMAT" in FLD_OK_COND and return the NAME for BROWSE
 1601:    return cap_first(parse_line("", _file, "FORMAT "))
 1602:  enddef
 1603:
 1604:  define get_zoom_format_file(_file)
 1605:   // Search for "ZOOM" in FLD_OK_COND and return the FORMAT NAME for EDIT
 1606:    return cap_first(parse_line("", _file, "ZOOM "));
 1607:  enddef
 1608:
 1609:  define make_zoom_to_form()
 1610:    var zoom_name, lookup_dbf;
 1611:    zoom_name = "Z_" + lower(rtrim(substr(name,1,6)))
 1612:    if !is_zoom then
 1613:      return 0;
 1614:    endif
 1615:    print(crlf + "*"+replicate("-",78)+crlf);
 1616:  }
 1617:  PROCEDURE {zoom_name}
 1618:  *-- Branch to another EDIT form based on lc_var
 1619:  PARAMETER lc_var
 1620:  PRIVATE ALL LIKE l?_*
 1621:
 1622:  ON KEY LABEL {on_key_zoom}
 1623:  SAVE SCREEN TO {zoom_name}
 1624:  lc_area = ALIAS()
 1625:  ll_edit = .F.
 1626:  SELECT SELECT()
 1627:  DO CASE
 1628:  {  foreach FLD_ELEMENT flds
 1629:        if is_zoom( FLD_OK_COND) then
 1630:          lookup_dbf = get_file( FLD_OK_COND);
 1631:  }
 1632:     CASE lc_var = "{FLD_FIELDNAME}"
 1633:  {        if workarea_cnt > max_workareas then}
 1634:        IF FILE("{lookup_dbf}.dbf")
 1635:           USE {lookup_dbf} ORDER {alltrim(get_key( FLD_OK_COND))}
 1636:  {            if chr( FLD_VALUE_TYPE) == "C" then}
 1637:           lc_var = IIF( EMPTY( TRIM( lc_var)), lc_var, TRIM( lc_var))
 1638:  {            endif
 1639:           else
 1640:  }
 1641:           SELECT ("{ upper(lookup_dbf) == FLD_FILENAME ?
 1642:                                                "A"+substr(lookup_dbf,1,7) :
 1643:                                                 lookup_dbf}")
 1644:  {         endif   }
 1645:           SEEK &lc_area.->&lc_var.
 1646:
 1647:           IF FILE("{fileroot( get_zoom_format_file( FLD_OK_COND)) + ".FMT"}")
 1648:               SET FORMAT TO {fileroot( get_zoom_format_file(FLD_OK_COND))}
 1649:           ENDIF
 1650:           ll_edit = .T.
 1651:  {        if workarea_cnt > max_workareas then}
 1652:        ENDIF
 1653:  {         endif
 1654:        endif
 1655:     next
 1656:  }
 1657:     OTHERWISE
 1658:         KEYBOARD CHR( kn_CtrlHme ) CLEAR          && Gets user into memo field
 1659:  ENDCASE
 1660:
 1661:  IF ll_edit
 1662:     EDIT NEXT 1                                   && Edit the Zoomed record
 1663:  ENDIF
 1664:
 1665:  {  if workarea_cnt > max_workareas then}
 1666:  USE
 1667:  {  endif}
 1668:  SELECT (lc_area)                                 && Back to edit work area
 1669:  RESTORE SCREEN FROM {zoom_name}
 1670:  RELEASE SCREEN {zoom_name}
 1671:  {  if is_help then}
 1672:  ON KEY LABEL {on_key_help} DO {"H_" + lower(rtrim(substr(name,1,6)))} WITH VARREAD()
 1673:  {  endif
 1674:     if is_recalc then}
 1675:  ON KEY LABEL {on_key_recalc} DO {"R_" + lower(rtrim(substr(name,1,6)))} WITH VARREAD()
 1676:  {  endif}
 1677:  ON KEY LABEL {on_key_cut} DO _Cut
 1678:  ON KEY LABEL {on_key_paste} DO _Paste
 1679:  ON KEY LABEL {on_key_edpaste} DO _Edpaste
 1680:  ON KEY LABEL {on_key_zoom} DO {zoom_name} WITH VARREAD()
 1681:  RETURN
 1682:  *-- EOP: {zoom_name}
 1683:  {enddef
 1684:
 1685:  define make_recalc_code()
 1686:    var recalc_name;
 1687:    recalc_name = "R_" + lower(rtrim(substr(name,1,6)))
 1688:    if !is_recalc then
 1689:      return 0;
 1690:    endif
 1691:    if !udf_file then
 1692:       if !make_udf() then
 1693:          return 0;
 1694:       endif
 1695:       // Put up the UDF header
 1696:       udf_header()
 1697:    endif
 1698:    print(crlf + "*"+replicate("-",78)+crlf);
 1699:  }
 1700:  PROCEDURE {recalc_name}
 1701:  *-- Recalculate calculated fields
 1702:  PARAMETER lc_var
 1703:  PRIVATE ALL LIKE l?_*
 1704:  ON KEY LABEL {on_key_recalc}
 1705:
 1706:  {textopen( fmt_name + ".tmp")
 1707:   temp = textgetl();
 1708:   if page_cnt > 1 then
 1709:  }
 1710:  DO CASE
 1711:     CASE lc_var $ "{temp}"
 1712:  {   lmarg(offset*2)
 1713:   endif
 1714:   color_flg = line_cnt = 0;
 1715:   foreach FLD_ELEMENT k
 1716:     if new_page(k) then
 1717:        temp = textgetl();
 1718:        lmarg(offset)
 1719:  }
 1720:
 1721:   CASE lc_var $ "{temp}"
 1722:  {     lmarg(offset*2)
 1723:     endif
 1724:     color = getcolor(FLD_DISPLAY, FLD_EDITABLE) // get color of element
 1725:     if FLD_FIELDTYPE == calc and is_recalc(FLD_DESCRIPT) then}
 1726:  *-- Calculated field: {cap_first(FLD_FIELDNAME)} - {FLD_DESCRIPT}
 1727:  @ {nul2zero(ROW_POSITN) - line_cnt},{nul2zero(COL_POSITN)} SAY \
 1728:  {  // Loop thru expression in case it is longer than 237
 1729:         foreach FLD_EXPRESSION fcursor in k
 1730:            FLD_EXPRESSION}
 1731:  {      next}
 1732:  // Output a space after the Fld_expression and get ready for picture clause
 1733:   \
 1734:  {      if Ok_Template(k) then}
 1735:  PICTURE "{picture_for_say(k);}" \
 1736:  {      endif
 1737:         outcolor()}
 1738:
 1739:  {  endif
 1740:   next k;
 1741:   if page_cnt > 1 then
 1742:     lmarg(0)
 1743:  }
 1744:  ENDCASE
 1745:  {endif}
 1746:
 1747:  ON KEY LABEL {on_key_recalc} DO {"R_" + lower(rtrim(substr(name,1,6)))} WITH VARREAD()
 1748:  RETURN
 1749:  *-- EOP: {recalc_name}
 1750:  { textclose()
 1751:    fileerase( fmt_name + ".tmp")
 1752:  enddef
 1753:
 1754:  define write_recalc_get_list()
 1755:   if is_recalc then                // Write get list out for each page
 1756:      append( fmt_name + ".tmp")    // Used for "recalc" option
 1757:      print( get_list + crlf)
 1758:      append( fmt_name + ".fmt")
 1759:   endif
 1760:  enddef
 1761:
 1762:  //--------------------------------------------------------------
 1763:  define make_replace_code()
 1764:    // Make REPLACE and @ GET statements for other fields related to the LOOKUP
 1765:    var replace_field_name, field_list, temp2;
 1766:
 1767:    if !is_replace then
 1768:      return 0;
 1769:    endif
 1770:
 1771:    color_flg = line_cnt = 0;
 1772:
 1773:    foreach FLD_ELEMENT x
 1774:      if is_replace( FLD_OK_COND ) then  // found a field with REPLACE
 1775:        replace_field_name = "U_" + lower( rtrim( substr( FLD_FIELDNAME, 1, 7)));
 1776:        print(crlf + "*"+replicate("-",78)+crlf);
 1777:  }
 1778:  PROCEDURE {replace_field_name}
 1779:     PARAMETER is_edit, key_field
 1780:     *-- Update Look'ed up fields for {cap_first( FLD_FIELDNAME )}
 1781:
 1782:  {     if  at("POPUP", upper(ltrim(FLD_OK_COND))) then}
 1783:     SEEK key_field
 1784:
 1785:  {     endif
 1786:        lmarg(4)
 1787:        get_replace_fields_list(x)
 1788:        get_memvar_fields_list(x)
 1789:        lmarg(0)
 1790:  }
 1791:
 1792:     IF is_edit
 1793:  {     foreach FLD_ELEMENT y
 1794:           if is_replace( y.FLD_OK_COND) and x == y then
 1795:
 1796:               field_list = upper( parse_line( "", y.FLD_OK_COND, "REPLACE ") )
 1797:               do while len(field_list) > 0
 1798:                  temp = upper( substr( field_list, 1, at(" WITH", field_list) - 1 ))
 1799:                  temp2 = at("M->",  upper(temp)) ?
 1800:                         substr( temp, at("M->", upper(temp)) + 3 ) :
 1801:                         temp;
 1802:                  foreach FLD_ELEMENT z
 1803:                     if FLD_FIELDNAME == alltrim( temp2 ) then
 1804:                        color = getcolor(z.FLD_DISPLAY, z.FLD_EDITABLE); // get color of element
 1805:  }
 1806:        @ {z.ROW_POSITN},{z.COL_POSITN} GET \
 1807:  {                     if at("M->",  upper(temp)) then
 1808:                           temp}
 1809:  {                     else
 1810:                           cap_first(z.FLD_FILENAME)}->\
 1811:  {                        cap_first(z.FLD_FIELDNAME)}\
 1812:  {                     endif
 1813:                        if Ok_Template(z) then}
 1814:   PICTURE "{picture_for_get(z);}" \
 1815:  {                        outcolor()}
 1816:  {                     endif}
 1817:
 1818:  {                     exit
 1819:                     endif
 1820:                  next z
 1821:                  if at( ",", field_list) > 0 then
 1822:                     field_list = substr( field_list, at( ",", field_list) + 1 )
 1823:                  else
 1824:                     field_list = ""
 1825:                  endif
 1826:               enddo
 1827:  }
 1828:     ENDIF
 1829:  RETURN
 1830:  *-- EOP: {replace_field_name}
 1831:
 1832:  {            exit
 1833:           endif
 1834:        next y
 1835:      endif
 1836:    next x
 1837:   return;
 1838:  enddef
 1839:
 1840:  //--------------------------------------------------------------
 1841:  define get_replace_fields_list(k)
 1842:    // Search for "REPLACE" in FLD_OK_COND and return the field list for REPLACE
 1843:    var field_list, key_length, first_loop;
 1844:
 1845:    first_loop = 1;
 1846:    // Get REPLACE field data
 1847:    field_list = upper( parse_line( "",k.FLD_OK_COND, "REPLACE ") )
 1848:
 1849:    // Fix the data up and print on multiple lines
 1850:    do while len( field_list) > 0
 1851:       if !at("M->", upper(substr(field_list, 1, at(" WITH", field_list) - 1 ))) then
 1852:          if first_loop then
 1853:             print("REPLACE ")
 1854:             first_loop = 0
 1855:          else
 1856:             print( ", ;" + crlf + space( 7))
 1857:          endif
 1858:          print( cap_first( k.FLD_FILENAME) + "->" +
 1859:                  cap_first(alltrim(substr(field_list, 1, at(" WITH", field_list) - 1 ))) +
 1860:                  " WITH "
 1861:               )
 1862:
 1863:          temp = cap_first( alltrim( substr( field_list, at( "WITH", field_list) + 4 )))
 1864:          if at( ",", temp) > 0 then
 1865:             temp = substr( temp, 1, at( ",", temp) - 1 )
 1866:          endif
 1867:
 1868:          print( temp)
 1869:       endif
 1870:       if at( ",", field_list) > 0 then
 1871:          field_list = substr( field_list, at(",", field_list) + 1 );
 1872:          if len( alltrim( field_list) ) == 0 then
 1873:             field_list = ""
 1874:          endif
 1875:       else
 1876:          field_list = ""
 1877:       endif
 1878:    enddo
 1879:    print( crlf )
 1880:    return ;
 1881:  enddef
 1882:
 1883:  define get_memvar_fields_list(k)
 1884:    // Search for "REPLACE" in FLD_OK_COND and return the field list for MEMVAR
 1885:    // declaration
 1886:    var field_list, key_length;
 1887:
 1888:    field_list = upper( parse_line( "",k.FLD_OK_COND, "REPLACE ") )
 1889:    // Produce memvar statements instead of replace statements
 1890:    do while len( field_list) > 0
 1891:       if at("M->", upper(substr(field_list, 1, at(" WITH", field_list) - 1 ))) then
 1892:          // Before "WITH"
 1893:          print( cap_first( alltrim( substr(field_list, 1,
 1894:                         at(" WITH", field_list) - 1 ))) +
 1895:                  " = "
 1896:               )
 1897:          // After "WITH"
 1898:          temp = cap_first( alltrim( substr( field_list, at( "WITH", field_list) + 4 )))
 1899:          if at( ",", temp) > 0 then
 1900:             temp = substr( temp, 1, at( ",", temp) - 1 )
 1901:          endif
 1902:          print( temp + crlf)
 1903:       endif
 1904:
 1905:       if at( ",", field_list) > 0 then
 1906:           field_list = substr( field_list, at(",", field_list) + 1 )
 1907:          if len( alltrim( field_list) ) == 0 then
 1908:             field_list = ""
 1909:          endif
 1910:       else
 1911:          field_list = ""
 1912:       endif
 1913:    enddo
 1914:    return ;
 1915:  enddef
 1916:
 1917:  define make_memvar_declarations()
 1918:      // Make memvars for lookups
 1919:      foreach FLD_ELEMENT
 1920:         if FLD_FIELDTYPE == memvar then
 1921:  }
 1922:  IF TYPE("M->{FLD_FIELDNAME}") = "U"
 1923:     m->{FLD_FIELDNAME} = \
 1924:  {          if chr(FLD_VALUE_TYPE) == "C" then
 1925:                 print("SPACE(" + len(FLD_TEMPLATE) + ")")
 1926:             endif
 1927:            if at(chr(FLD_VALUE_TYPE), "NF") then
 1928:                 print("0")
 1929:             endif
 1930:            if chr(FLD_VALUE_TYPE) == "D" then
 1931:                 print("{  \  \  }")
 1932:             endif
 1933:            if chr(FLD_VALUE_TYPE) == "L" then
 1934:                 print(".F.")
 1935:             endif     //
 1936:             print(crlf)
 1937:  }
 1938:  ENDIF
 1939:  {
 1940:         endif
 1941:       next
 1942:  return ;
 1943:  enddef
 1944:  }
 1945:    571:  //---------------------------------------------------------------------------
  572:  }
  573:  // EOP CCB_FORM.COD
  574:  Compilation complete (no errors).