TIDE*
  •   Corporation^

-------
      Program: MAIN.PRG
qnl-
       System:
       Author :
    Copyright
Last modified:
    /
 Paper Work Reduction Managemnt System
 John Pitts,  Fred,  Melissa, Karen
(c)      ,  Compex Corporation
 12/28/89      17:23
            Calls:  TEMPLAT2
                 :  LOGIN_SCRN()
                 :  CLEAR_BODY
                 :  MODTEMPLAT
                 :  MENUPOPUP2()
                 :  CLR_MSGS
                 :  MENU1_1
                 :  MENU1_2
                 :  MENU1_3
                 :  MENU1_4
                 :  MENU1 5
                               (procedure
                               (function
                               (procedure
                               (procedure
                               (function
                               (procedure
                               (procedure
                               (procedure
                               (procedure
                               (procedure
                               (procedure
                           in NEWTEMP4.PRG)
                           in NEWTEMP4.PRG)
                           in NEWTEMP4.PRG)
                           in NEWTEMP4.PRG)
                           in NEWTEMP4.PRG)
                           in NEWTEMP4.PRG)
                           in MENUS.PRG)
                           in MENUS.PRG)
                           in MENUS.PRG)
                           in MENUS.PRG)
                           in MENUS.PRG)
        Documented 12/28/89 at 17:32
                                                 SNAP!  version 3.12e
  t procedure
  t procedure
set procedure
  t procedure
  t procedure
set procedure
  t procedure
  t procedure
^,^t procedure
=;p,t procedure
  it procedure
  it procedure
set procedure
  :t procedure
          to  newtemp4
          to  menus
          to  form2_ab
          to  sf83f
          to  editnotl
          to  checktes
          to  showte
          to  icw_inpt
          to  ombresp
          to  rpts
          to  browse
          to  clipper
          to  rlib
          to  extend
 ex**************************************************
                                                    *
      File:  PRAMAIN1.PRG                           *
      Description:
      Ext. Usage;
  Main PRAMS II module which
  calls all other modules.
  This module includes login
  and security functions.

 NEWTEMP3.PRG
 ATINSAY, KEYINPUT  from  RLIB
                                                *
                                                *
                                                *
                                                *
                                                *
                                                *
  ***************************************************

**********  initialize Variables   ***********

  ablic tlcolor, msglcolor,  nullmsg,  bodycolorl,kmax
public mtempheadl, mtemphead2,headframe,msgpframe,intmp_head
  ublic inp_f rame, body frame,  access_lev                 ~"
  ablic trk_isrted        &&  for  testing if TRACKING was sorted since last add
  rk_isrted =  .f.
                                       HEADQUARTERS LIBRARY
                                       ENVIRONMENTAL PROTECTION AGENCY
                                       WASHINGTON, D.C. 20460

-------
  •clare menu_l[6]                           && MAIN MENU  Prompt  array
menu_l[l]  = "1   ICR MANAGEMENT"
  nu_l[2]  = "2   TRACKING EVENTS"
  •nu_l[3]  = "3   ICB MANAGEMENT"
...^nu_l[4]  = "4   RUN REPORTS"
™».nu_l[5]  = "5   SYSTEM ADMINISTRATION"
  •nu_l[6]  = "E   EXIT PRAMS II"

mltitle = "** MAIN MENU **"

  r**********  Blank Array for holding Menu Prompts   ***********************
public mprompts[8]
-'illfmprompts,"11)

  r**********  Menu Prompts  & Max Key for Menu 1.0  ************************
declare mp_l[6]
  »_![!] = "Functions  for SF-83, Form 2B, and  ICW Input/Edit/Query11
  i_l[2] = "Input Package and ICW Tracking Event  Data"
rop_l[3l = "Functions  for Information Collection  Budget Form 2A"
  '^t4] = "Functions  to Generate Standard Reports"
  >_1[5] = "Maintain Users,  Code Tables, and Export  Data Files"
rap_l[6] = "End PRAMS  II Operation  and Return  to  DOS Environment"

  >l_key =53

***************************  Frame Style Variables   ***********************
   rame =  "oi.Mio1  "                               && box characters
  'rame =  «(>*£» UAAJ  "
m"0_0 frame =  "BBB      "
  .empheadl = "PAPERWORK  REDUCTION  ACT"
  :emphead2 = "MANAGEMENT  SYSTEM  II"
wody_f rame = "	"
** framing = "6±,M±6>  "
  jadframe =  "    AAA  "
  ;gpframe =  "AAA      "
 intmp_head = "PAPERWORK  REDUCTION  ACT"
  ip_frame =  "         "
  it**************************  Color Variables   ****************************
  Lcolor = "GR+/B,B/GR+,,,GR+/B"                && Color  strings
 menucolor = "B/W,B/W,B/W,,R/BG"
  sadcolor = IIGR+/B,GR+/B,GR+/B, ,GR+/B"
  sglcolor = "B/W, B/W, B/W, , B/W"
 accolor = "RB+/B,RB+/B, , ,RB+/B"
 •"ogincolor = "RB+/W,RB+/W, , ,w/RB+"
  adycolorl = "W/B,B/w,,,w/B"
  ld_color = ""
 ral_0color = "BG+/B,GR+/B+,,,RB+/B"
  rig_color = ""

 mhO_Ostr = "0.0"                                  && Template Header Menu Numbers
  'il_0str = "1.0"

 nall_msg = ""                                     && Template Bottom Msgs
 msgml_0 = " Use  "+chr(24)+" or  "+chr(25)+;

-------
   11 keys or 1st Letter to Select Item then  to  Execute "

r-curity = .f.

. .***************  MAIN Body of Program  *******************
set confirm on
;  t Scoreboard off
:  t delimiters to "[]"
set delimiters on
  tcancel(.f.)

uj.'ig_color = setcolorQ
*-~mplat2 (tlcolor,dtcolor,bodycolorl,mhO_Ostr,null_msg,msglcolor)
  curity = login_scrn()
_ _ear_body(bodycolorl)

    .not. security
    @ 11,15,15,65 box "AAA AAA   "
    atinsay( 13, 20, 'w*/r',  '****  UNAUTHORIZED  ACCESS ATTEMPT  ****')
    inkey(lO)
    clear screen
    ? "****  Have a Nice Day!!   ****"
    quit
  :dif

do  while  .t.
    teraplat2(tlcolor,dtcolor, bodycolorl, mhO_Ostr,null_msg,insglcolor)
    modtemplat(mhl_0str,dtcolor,msgml_0,msglcolor)
    selection  = menupopup2 (9,25,14,49,ml_0color,menu_l,inltitle,mp_l,mpl_key)
    *   clear_body(bodycolorl)
    if  selection =  5  .and.  access_lev = 0
       tone(220,3)
       tone(220,3)
       atinsay(24,0,'W/R1,centring;
          ("UNAUTHORIZED  SELECTION -  Your security level is insufficient  for  this
       inkey(30)
       clr_msgs()
       loop
    endif
    clear_body(bodycolorl)
    do  case
    case selection = 1
       menul_l()
    case selection = 2
       menul_2()
    case selection = 3
       menul_3()
    case selection = 4
       menul_4()
    case selection = 5
       menul_5()
    case selection = 6
       set color to  &orig_color
       clear
       quit
    otherwise
        loop
    endcase

 enddo

-------
 =t color to  &orig_color
clear

 * End of PROC pramainl - the main PRAMS2 PROC
 * End of FILE main.prg

 : EOF: MAIN.PRG

-------
  Procedure file

          System
          Author
       Copyright
   Last modified

   Procs & Fncts
 NEWTEMP4.PRG

 Paper Work Reduction Managemnt  System
 John Pitts, Fred,  Melissa,  Karen
(c)      , Compex  Corporation
 11/27/89      22:30

 TEMPLAT2
 MENUPOPUP1()
 MODTEMPLAT
 REDRAWTMPL
 CLEAR_BODY
 LOGIN_SCRN()
 MENUPOPUP2()
 AFUNC()
 CENTRING()
 INPJTMPL
 CLR_INBODY
 CLR MSGS
       Documented 12/28/89 at 17:32
       ****************************!
************************************************
    File: NEWTEMP4.PRG                         *
                                               *
    Template PROCS & FUNCs for a system        *
    Has a Header area, Body, & Msg/Prompt area *
    Uses Shadow Boxes for Menu display in Body *
    Clear Body area PROC                       *
                                               *
    NOTE: Modified menupopup2 for scroll msgs  *
                                               *
************************************************
                                  SNAP!
version 3.12e
        Procedure:  TEMPLAT2

        Called by:  MAIN.PRG
                 :  MENU1 2
                 (procedure  in  MENUS.PRG)
 rocedure templat2
parameters head_color, sec_color,body_color,  menu_numb,msg_prompt,msg_color

 * mtempheadl = "PAPERWORK  REDUCTION  ACT"
 * mtemphead2 = "MANAGEMENT  SYSTEM  II"
** body_frame = '	"
 * framing = "Qi,3 U6> "
 * headframe = "    AAA  "
»* msgpframe = "AAA      "

 lear
_et color to &head_color
@ 0,0,2,79 box headframe

-------
  0,(80  -  (len(mtempheadl)))/2  say mtempheadl
e 1, (80  -  (Ien(mtemphead2)) )/2  say mtemphead2
•"?t color  to &body_color
  3,0,21,79  box body_frame
_3t color  to &head_color
@ 22,0,24,79 box rasgpframe
  it color  to &sec_color                          && Change to Secondary color
  0,3 say  "Screen "                           && Hard Coded name; make parm
@ 0,10 say menu_numb
" 0,65 say "Ver. 1.1"
  >t color  to &msg_color
« 23, 40-((len(msg_prompt)/2))  say msg_prompt

  * End of  PROC templat2

*************************************************
       FUNCTION: menupopupl                     *
                                                *
*        Shadow box menu for use in BODY area   *
                                                *
                                                *
  ************************************************
  i
 *!       Function: MENUPOPUPIQ
  i
  i
 iunction menupopupl
 ~irameters ul_row,ul_col,lr_row,lr_col,mcolor,marray,  menu_title

 _ld_color = setcolor()
 set color to "N/N,N/N,,,N/N"
  3r shadow = ul_row -  3  to  lr_row + 5
   @  shadow, lr_col +  5  say "0"
 next
 " shadow - 1, ul_col - 3 say replicate("U",  (lr_col - ul_col)+8)
  2t color to Smcolor

 fl ul_row-4,ul_col-4,lr_row+4,lr_col+4 box  "flBB      "
   ul_row-3,ul_col+((lr_col-ul_col)/2) -(len(menu_title)/2)  say menu_title
   ul_row-2, ul_col-4 to ul_row-2,lr_col+4
 @ lr_row+2, ul_col-4 to lr_row+2,lr_col+4
  * @ lr_row+3,ul_col  SAY "  to return"

 return(achoice(ul_row,ul_col,lr_row,lr_col,marray))


  ************************************************
 *      PROCEDURE: modtemplat                    *
                                                 *
          Alter template display for MENU number *
 *        in  header and message prompt  at bottom *
                                                 *
  ************************************************
         Procedure: MODTEMPLAT

-------
        Called by
MAIN.PRG
MENU1_1
MENU1_2
MENU1_3
MENU1_4
MENU1_5
MENU1_1_1
EDITFORMS
MENU1_5_2
MENU1_4_7
SETRPTOUT
                                  (procedure
                                  (procedure
                                  (procedure
                                  (procedure
                                  (procedure
                                  (procedure
                                  (procedure
                                  (procedure
                                  (procedure
                                  (function
          in MENUS.PRG)
          in MENUS.PRG)
          in MENUS.PRG)
          in MENUS.PRG)
          in MENUS.PRG)
          in MENUS.PRG)
          in MENUS.PRG)
          in MENUS.PRG)
          in MENUS.PRG)
          in RPTS.PRG)
 rocedure modtemplat
_ irameters menu_numb,numb_color,msg_prompt,  msg_color

 Ld_color = setcolor()
 it color to "RB+/B,RB+/B»,,RB+/B"
@ 0,10 say menu_numb + "     "
-^t color to &msg_color
 * IF msg_prompt == ""
 k    @ 23,0 SAY REPLICATE(" ",80)
** ELSE
 *  @ 23, 40-((LEN(msg_prompt)/2)) SAY msg_prompt
 « ENDIF
set color to Sold color
 *************************************************
 *      PROCEDURE: redrawtmpl                     *
                                                 *
         Redraw the menu template after altering*
 *        for input/edit form display             *
                                                 *
  ************************************************
        Procedure

        Called by
 REDRAWTMPL

 MENU1_1
 MENU1_3
 MENU1_4
 MENU1_5
 MENU1_1_1
 MENU1_5_2
 MENU1 4 7
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
 orocedure redrawtmpl
  irameters head_color,menu_numb,numb_color

 ** mtempheadl = "PAPERWORK  REDUCTION  ACT"
  * mtemphead2 = "MANAGEMENT  SYSTEM  II"
  * framing = "61,'*±6*  "
 -* headframe = "    AAA  "
 +* msgpframe = "AAA      "

 _ld_color = setcolor()
 set color to Shead color

-------
  0,0,2,79 box headframe
@ 0,(80 - (len(mtempheadl)))/2 say mtempheadl
n 1,(80 - (Ien(mtemphead2)))/2 say mtemphead2
 * SET COLOR TO &body_color
 k <§ 3,0,21,79 BOX body_frame
** SET COLOR TO &head_color
  22,0,24,79 box msgpframe
 it color to &numb_color
@ 0,3 say "Screen "
 * @ 0,10 SAY menu_numb
  0,65 say "Ver. 1.1"
x* SET COLOR TO &msg_color
*•* @ 23, 40-((LEN(msg_prompt)/2)) SAY msgjprompt
  »t color to &numb_color
,. 0,10 say menu_numb + "      "
set color to &msg_color
  • IF msg_prompt == ""
      @  23,0 SAY REPLICATE("  ",80)
** ELSE
  i  @ 23, 40-((LEN(msg_prompt)/2))  SAY msg_prompt
  • ENDIF
    color to Sold color
                              && Change to Secondary color
                          && Hard  Coded name; make para
  t************************* **************** ******
 *       PROCEDURE:  clear_body                    *
                                                 *
          Alter template display by clearing     *
 *         i.e., redrawing body area              *
                                                 *
  r***********************************************
 *l
         Procedure

         Called by
CLEAR_BODY

HAIN.PRG
MENU1_1
MENU1_2
MENU1_3
MENU1_4
MENU1_5
MENU1_1_1
WHICHOMB
EDITFORMS
MENU1_5_2
MENU1_4_7
SHOW_TES
SETRPTOUT
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(function
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in SHOWTE.PRG)
in RPTS.PRG)
   rocedure clear_body
   irameters body_color

   * body_frame  =  "	°"
   Ld__color =  setcolor()
 set~color to &body_color
 n 3,0,21,79  box  body_frame
   jt  color to Sold  color
  *************************************************

-------
       FUNCTION:  login_scrn                     *
*                                               *
         Popup Used ID and Password Input boxes *
         and validate in SYSTEM.DBF (Encrypted) *
                                                *
*************************************************
         Function: LOGIN_SCRN()

        Called by: MAIN.PRG

             Uses: SYSTEM.DBF

            k******4
 anction login_scrn

public access_lev
 rftries = 0
 ser = space(10)
pwd =  space(10)
=ccess = .f.

_se system

 :> while pwtries  <  3  .and.  .not. access
   set color to "W/B,W/B,,,W/B"
   if pwtries  > 0
      @ 4,0,22,79 box	"
   endif
   set color to "W/B,W/B,,,W/B"
   @ 7,20,13,60 box mO_0frame
   set color to "N/N,N/N,,,N/N"
   for shadow  = 8 to  14
      @ shadow, 61  say "0"
   next
   @ 14, 21 say replicate("0",  40)
   set color to "W/B,W/B,,,W/B"
   @ 8,20  to 8,60
   6 12,20 to  12,60

   atinsay(  10, 25, 'gr+/b',  'Enter User ID: ')
   user =  keyinput( 11,  .t.,  .t. )

    @ 9,22,15,62 box mO_Oframe
    set  color  to "N/N,N/N,,,N/N"
    for  shadow  = 10  to 16
       @  shadow,  63  say "u"
    next
    @  16,  23 say replicate("u",  40)
    set  color to "W/B,W/B,,,W/B"
    @  10,22 to 10,62
    <§  14,22 to 14,62

    atinsay( 12, 27,  'gr+/b',  'Enter Password:  ')
    pwd = keyinput(  12, .t., .f. )
    if empty(user)  .or. empty(pwd)
       loop
    endif

-------
  locate for trim(user_id)  == user  .and. trim(password)  == encrypted(pwd)
  pwtries = pwtries+1
  i f  .not. found()
      if pwtries  !=  3
        @ 11,15,15,65  box "AAA  AAA   "
        atinsay(  13,  22,  'w/r1,  'INVALID LOGIN ATTEMPT...Try Again1)
        inkey(lO)
      endif
  endif
  if  found()
      access_lev  = sec_level
      access =  .t.
  endif
 nddo
_j6
return(access)

 * End of Function Login_scrn

• ***** ****************************
*!
Function  MENUPOPUP2()
*!
* !
        Called by
          MAIN.PRG
          MENU1_1
          MENU1_2
          MENU1_3
          MENU1_4
          MENU1_5
          MENU1_1_1
          EDITFORMS
          MENU1_5_2
          MENU1_4_7
          SETRPTOUT
   Calls   CENTRING()
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(function
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in RPTS.PRG)
                                   (function   in NEWTEMP4.PRG)
 function menupopup2
  arameters ul_row,ul_col, lr_row,lr_col,mcolor,marray,menu_title, prmptarr,kmax

 old_color = setcolor()
  2t color to  "N/N,N/N,,,N/N"
  or shadow =  ul_row  -  3  to lr_row  +  5
   @  shadow,  lr_col  +  5  say "u"
  =xt
   shadow - 1,  ul_col - 3 say replicate("U",  (lr_col - ul_col)+8)
 =et color to  Smcolor

   ul_row-4,ul_col-4,lr_row+4,lr_col+4 box "RRB      "
   ul_row-3,ul_col+((lr_col-ul_col)/2) -(len(menu_title)/2)  say menu_title
 @ ul_row-2, ul_col-4 to ul_row-2, lr_col-(-4
   lr_row+2, ul_col-4 to lr_row+2,lr_col+4
  * @  lr_row+3,ul_col SAY " to return"
 •**  Set up Public Vars for the current menu

 ~copy(prmptarr,  mprompts)
 @ 23,00 say centring(mprompts[i])
                                    && Copy in prompt array
                                    && Setup 1st prompt

-------
  •y_max = kmax                              && Move max ASCII key

-•-**** End of Menu PUB VARS Setup

..vjturn (achoice (ul_row, ul_col, lr_row, lr_col (marray, "", "AFUNC"))

  End of Menupopupl Function
         Function: AFUNC()

            Calls: CENTRING()
                          (function  in NEWTEMP4.PRG)
*!
  inction afunc
parameters anode, apos, ascr

  ' anode = 0
   @ 23,00 say centring(mprompts[apos])
   return(2)
  idif
  latkey = lastkey()
@ 23,00 say centring(mprompts[apos])
   whatkey =13
   return(1)
endif
-f  (whatkey < key_max+l  .and. whatkey  >  48)  .or.  ;
      whatkey =  69  .or. whatkey  =  101  .or. whatkey  = 82 .or. whatkey = 114
   return(3)
endif
  :turn(2)

* End of Function Afunc
          Function   CENTRING()
 *i
called by
 * 1
 -^ I
  jnction centring
 parameters string
MENUPOPUP2()
AFUNC()
WHICHOMB
FORM2B
CHK_FY_IN()
FORM2A
INP_ICW_TE
SHOWJTES
R_D_TES
TICK_HEAD
MONTHLY
PEND_HEAD
SCANO
(function
(function
(procedure
(procedure
(function
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(function
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in MENUS.PRG)
in FORM2_AB.PRG)
in FORM2_AB.PRG)
in FORM2_AB.PRG)
in CHECKTES.PRG)
in SHOWTE.PRG)
in SHOWTE.PRG)
in RPTS.PRG)
in RPTS.PRG)
in RPTS.PRG)
in BROWSE.PRG)

-------
  ore (80 - len(string))  / 2 to temp
if 2 * temp + len(string)  < 80
 -  return(space(temp)  + string + space(temp) + " ")
  dif
__turn(space(temp)  + string + space(temp))

  End of Function Centring
*i
*!
*!
        Procedure  INP TMPL
Called by
 * I
MENU1_1
MENU1_2
MENU1_3
MENU1_5
MENU1_1_1
WHICHOMB
MENU1_5_2
MENU1_4_7
EDIT_TE
DEL_TE
R D TES
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in CHECKTES.PRG)
in CHECKTES.PRG)
in SHOWTE.PRG)
 procedure  inp_tmpl
 --rameters head_color,  sec_color,menu_numb,max_pages

    intmp_head  =  "PAPERWORK  REDUCTION  ACT"
 **  headframe = "    AAA  "
    msgpframe = "AAA       "
    inp_frame = "          "
 cur_page = 1

   ear
 t>et color  to &head_color
 n 0,0,1,79 box headframe
   0,(80  -  (len(intmp_head)))/2 say intmp_head
 _ 2,0,22,79 box  inp_frame
 @ 23,0,24,79 box msgpframe
  •t color  to  &sec_color
   0,3 say  "Screen "
 @ 0,10 say menu_numb
 " 0,65 say "Page " +   str(cur_page,1,0) + " of "
  • SET COLOR TO  &msg_color
 •-••  @ 23, 40-(  (LEN(msg_prompt)/2) ) SAY msg_prompt

    End of PROC inp_tmpl
                                          && Change to Secondary color
                                       && Hard Coded name; make parm

                                          + str(max_pages,1,0)
 * !
         Procedure: CLR_INBODY

         Called by: MENU1_1
                   : MENU1 2
                            (procedure in MENUS.PRG)
                            (procedure in MENUS.PRG)

-------
*!
*!
*!
MENU1_3
MENU1_1_1
FORM2B
FORM2A
SF83
INP_PKG_TE
GET_PKGTE
INP_ICW_TE
GET_ICWTE
ED_PKG_TE
ED_ICW_TE
DEL_TE
SHOW_TES
R D TES
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
in MENUS.PRG)
in MENUS.PRG)
in FORM2_AB.PRG)
in FORM2_AB.PRG)
in SF83F.PRG)
in CHECKTES.PRG)
in CHECKTES.PRG)
in CHECKTES.PRG)
in CHECKTES.PRG)
in CHECKTES.PRG)
in CHECKTES.PRG)
in CHECKTES.PRG)
in SHOWTE.PRG)
in SHOWTE.PRG)
  ocedure clr_inbody

old_color = setcolor()
  t color to  Sbodycolorl
  2,0,22,79 box  inp_frame
set color to  &old_color
   End of  PROC clr_inbody

   •kit ************** ********* ****** 1C*******
 * i
         Procedure
         Called by
 *i
 *!
 j. i
 CLR_MSGS

 MAIN.PRG
 MENU1_1
 MENU1_2
 MENU1_3
 MENU1_4
 WHICHOMB
 EDITFORMS
 MENU1_4_7
 FORM2A
 SF83
 VLDATE()
 STOPJTST()
 CHK_DATE()
 GET_PKGTE
 IS_CODE()
 GET_ICWTE
 ICWINPUT
 V_HRSDIF()
 (procedure
 (procedure
 (procedure
 (procedure
 (procedure
 (procedure
 (procedure
 (procedure
 (procedure
 (function
 (function
 (function
 (procedure
 (function
 (procedure
 (procedure
 (function
 in MENUS.PRG)
 in MENUS.PRG)
 in MENUS.PRG)
 in MENUS.PRG)
 in MENUS.PRG)
 in MENUS.PRG)
 in MENUS.PRG)
 in FORM2_AB.PRG)
 in SF83F.PRG)
 in SF83F.PRG)
 in SF83F.PRG)
 in SF83F.PRG)
 in CHECKTES.PRG)
 in CHECKTES.PRG)
 in CHECKTES.PRG)
 in ICW_INPT.PRG)
 in ICW_INPT.PRG)
   rocedure clr_msgs

   Ld_color = setcolor()
   2t color to  &bodycolorl
   24,0 clear  to  24,79
   2t color to  &old_color
   sturn
  ** End of  PROC  clr_inbody

-------
EOF:  NEWTEMP4.PRG

-------
   Procedure  file  MENUS.PRG
*•
*:
       System
       Author
    Copyright
Last modified

Procs & Fncts
*:
*:
 Paper Work Reduction Managemnt system
 John Pitts, Fred,  Melissa,  Karen
(c)      ,  Compex Corporation
 11/29/89     12:31

 MENU1_1
 MENU1_2
 MENU1_3
 MENU1_4
 MENU1_5
 MENU1_1_1
 WHICHOMB
 ICR_TEST()
 EDITFORMS
 ADDUSER2
 V_DUPE()
 MENU1_5_2
 EXP_TEXT_2
 EXP_TEXT_1
 ICRSUM
 ARCH_ICR
 ICR_PACK
 ICR_CHANGE
 MENU1  4 7
        Documented 12/28/89 at  17:32
        t************* ***************-.
 T, ************************************************
 *    FILE: MENUS.PRG                            *
                                                *
     Description: All menus                     *
 *                 called  from Main Menu in      *
                  file PRAMAIN1.PRG             *
                                                *
 ******* til********* **************** ***************
                                                 SNAP!  version  3.12e
  ************************************************
                                                 *
                                                 *
                                                 *
                                                 *
                                                 *
                                                 *
                                                 *
                                                 *
  ************************************************
  PROCEDURE:  menul_l

  Called from:   PRAMAIN1.PRG

  Description:  Displays menu 1.1 for ICR
               MGT Function selection.
         Procedure:  MENU1_1

         Called by:  MAIN. PRG

             Calls:  CLEAR_BODY
                  :  MODTEMPLAT
                                (procedure in NEWTEMP4.PRG)
                                (procedure in NEWTEMP4.PRG)

-------
* !
*!
*!
                   MENUPOPUP2()
                   CLR_MSGS
                   EDITORNO()
                   INPJTMPL
                   CLR_INBODY
                   SF83
                   ICWINPUT
                   WHICHOMB
                   REDRAWTMPL
(function
(procedure
(function
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in EDITNOT1.PRG)
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in SF83F.PRG)
in ICW_INPT.PRG)
in MENUS.PRG)
in NEWTEMP4.PRG)
                                                      ***********************
procedure menul_l
«»-ivate number, response
  blic acces_lev
__t confirm on

  sponse = "N"
  ********************** Declare MENU 1.1 Selections

i-""clare menul_l[7]
                  CREATE NEW ICR"
                  CREATE NEW PACKAGE"
                  EDIT EXISTING PACKAGE"
                  CREATE NEW ICW"
                  EDIT EXISTING ICW"
                  INPUT AN OMB RESPONSE"
                  RETURN TO MAIN MENU"

mi_ltitle =  "**  ICR MGT MENU  **"
-ul_lstr = "1.1"

  ********************** Declare MENU 1.1 Prompts   **************************

i  clare mp_l_l[7]
nul
menul
nul
nul
menul
nul
_1
~1
1
1
1
1
[1]
[3]
[4]
[5]
[6]
[7]
=
"1
"2
"3
"4
"5
"6
"R
   ""Input the first or original SF-83  for an ICR"
    1_1[2] = "Create a New Package - Enter SF-83  Data for an Existing ICR"
   'l_l[3] = "Edit SF-83 data for an Existing ICR"
           = "Enter data for a New Inventory Correction Worksheet"
           = "Edit data for an Existing Inventory Correction Worksheet"
    "Input OMB Action Notice for an SF-83 or an Inventory Correction Worksheet"
 mp_l_l[7] = "Return to MAIN MENU"

   l_l_key = 56                         && Max INKEY Value for this menu

 ************************ Menu Selection Process Loop  ***********************

 	 while .t.
    clear_body(bodycolorl)
    modtemplat(mhl_lstr,tlcolor,null_msg,msglcolor)
    selection = menupopup2 (8,25,14 , 51,ml_0color,menul_l,ml_ltitlef ;
       mp_l_l, mpl_l_key)
    if (selection = 1  .or. selection = 2  .or. selection = 4  .or.  selection =  6);
          .and. access_lev = 0
       tone(220,3)
       tone(220,3)
       atinsay(24,0,'W/R1.centring;
          ("UNAUTHORIZED  SELECTION - Your security level is  insufficient  for  this
       inkey(30)

-------
   clr_msgs()
   loop
endif
clear_body(bodycolorl)

do case
case selection =1         && CREATE new ICR (SF83) w/ or w/out ICR #
   clear_body(bodycolorl)
   @ 11,11,15,69 box "Ei»
   @ 23,0 say centring ;
       ("If this SF-83 relates to an ICR that was assigned a number during the
   @ 24,0 say centring ;
       ("process, the Desk Officer will have provided that ICR number for inpu
   @ 13, 14 say "Do you have an ICR number for this SF-83?  (Y/N)  "
   @ 13,62 get response pict "!" valid(response == "Y" ;
       .or. response == "N")
   read
   @ 23,00 clear to 24,79
   if  response == "Y"   && ICR exists, add a new PKG = 01
       old_icr_no = editorno(l,2) && get & validate ICR number
       if old_icr_no = -1         && ICR # didn't exist,  error loop
         loop
       endif
       select package       && Go to PKG work area and add a  blank  rec
       append blank
       select icr           && reselect ICR area, pointer  at  exist  rec
       inp_tmpl(tlcolor,dtcolor,"1.1.1",3)
       clr_inbody()
       sf83(l,old_icr_no,01)  && Update old  ICR, add new  PKG
       *     RETURN
    else             && New  SF-83 with  no previous ICR summary
       inp_tmpl(tlcolor,dtcolor,"1.1.1",3)
       new_icr_no  =  editorno(0,2)
       sf83(0, new_icr_no,  01)   &&  Create both  ICR  & PKG, blanks exist
       close all
       *    RETURN
    endif

 case selection  =2    && CREATE  new PACKAGE  from SF83  NOT the 1st
    number =  editorno(0,3)  && get  ICR #  and  validate
    if number  == "E"     && error  condition  - ICR did  not exist

       loop              && stay in this  menu for next selection
    endif
    icr_no =  val(substr(number,1,4))
    pkg_no =  val(substr(number,6,2))
    select package
    append blank      && to PKG, w.a.  for ICR update is still open
    inp_tmpl(tlcolor,dtcolor,"1.1.2",4)
    sf83(0,icr_no,pkg_no+l)    && Add PKG & update ICR summary
    close all
 case  selection =3   && EDIT existing PACKAGE from SF83 NOT the  1st
    number = editorno(lr3)  && get ICR # and validate
    if number == "E"     && error condition - ICR did not exist
       loop              && stay in this menu for next selection
    endif
    icr_no = val(substr(number,1,4))
    pkg_no = val(substr(number,6,2))
    inp_tmpl(tlcolor,dtcolor,"1.1.3",4)
    sf83(2,icr_no,pkg_no)

-------
                                 && Create New ICW record
                                 && get ICR # and validate
                                 && error condition - ICR did not exist

                                 && if NOT good ICR
                                 && good icr;pass # open appended DBF
   close all
case selection = 4
   number = editorno(0,4)
   if number == "E"
      clear_body(bodycolor1)
      loop
   endif
   icr_no = val(number)
   inp_tmpl(tIcolor,dtcolor,"1.1.4", 2)
   icwinput(0,icr_no)
   close all
case selection =5           && Edit an ICW input form
   status = editorno(l,4)    && Routine to get Farms & set rec ptr
   if status == "E"
      clear_body(bodycolorl)
      loop                  && Open files wre closed in editorno()
   endif
   inp_tmpl(tIcolor,dtcolor,"1.1.5",2)
     icwinput(1,0)
     close all
   case selection =  6
     whichoitib()
     close all
                             && Purpose=Edit; 0->get ICR# from  FIELD
                             && Close up ICW DBF
                            && Input OMB RESP HARD CODED FOR  PKG
   case selection  =  7
      clear_body(bodycolorl)
      return
   endcase
   redrawtmpl (t Icolor, mhl_lstr, dtcolor)

 iddo

**  End PROC menul_l

 t***********************************************
                              && Close up ICW DBF


                               && Clear body before  return  to  menu
     PROCEDURE:  1_2MENU.PRG

     Called from:  PRAMAIN1.PRG
                                              *
                                              *
                                              *
   Description: Displays menu 1.2 for ICR     *
                tracking Function selection.   *
        Procedure  MENU1 2
* !
  i
  i

*!
  i
  i
X I
 *!
      Called by

          Calls
MAIN.PRG

TEMPLAT2
MODTEMPLAT
MENUPOPUP2()
CLR_MSGS
CLEAR_BODY
INPJTMPL
CLR_INBODY
INP_PKG_TE
SHOW TES
(procedure
(procedure
(function
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in CHECKTES.PRG)
in SHOWTE.PRG)

-------
                 :  INP_ICW_TE     (procedure in CHECKTES.PRG)
*!                :  EDIT_TE        (procedure in CHECKTES.PRG)
                 :  DEL_TE         (procedure in CHECKTES.PRG)

                 ki
orocedure menul_2

  ********************** Declare MENU 1.2 Selections  ***********************

  clare menul_2[8]                            && MAIN MENU Prompt array
  nul_2[l] = "1   ENTER PACKAGE EVENT"
menul_2[2] = "2   DISPLAY PACKAGE EVENTS"
—nul_2[3] = "3   ENTER ICW EVENT"
  nul_2[4] = "4   DISPLAY ICW EVENTS"
..._nul_2[5] = "5   DISPLAY ALL ICR EVENTS"
menul_2[6] = "6   EDIT A TRACKING EVENT"
  nul_2[7] = "7   DELETE A TRACKING EVENT"
  nul_2[8] - "R   RETURN TO MAIN MENU"

  _2title = "** TRACKING EVENT MENU  **"
  l_2str = "1.2"

************************ Declare MENU 1.2 Prompts   **************************

  clare mp_l_2[8]
mp_l_2[l] = "Input One or More Tracking Events  for  PACKAGE  types"
  _1_2[2] = "Display Tracking Events for One or More  PACKAGE types"
  _1_2[3] = "Input One or More Tracking Events  for  ICW  types"
mp_l_2[4] = "Display Tracking Events for One or More  ICW types"
—_l_2[5] = "Display Both PACKAGE and ICW Tracking  Events "
  _1_2[6] = "Edit a Tracking Event  for a Package  or an  ICW"
...r_l_2[7] = "Delete a Tracking Event for a  Package  or an ICW"
mp_l_2[8] = "Return to MAIN  MENU"

  >l_2_key = 55                         && Max  INKEY Value for this menu

  *********************** Menu  Selection  Process Loop  ***********************

uu  while .t.
    templat2 (t Icolor, dtcolor, bodycolorl, mhO_Ostr, null_msg, msglcolor)
    modtemplat(mhl_2str,tlcolor,null_msg,msglcolor)
    selection  = menupopup2 (8,26,15, 52,ml_0color,menul_2 ,ml_2title,  ;
       mp_l_2,  mpl_2_key)
    if (selection = 1  .or.  selection = 3  .or.  selection = 6;
          .or.  selection = 7) .and.  access_lev = 0
       tone(220,3)
       tone(220,3)
       atinsay(24,0,'W/R1,centring;
          ("UNAUTHORIZED SELECTION - Your security level is  insufficient  for this
       inkey(30)
       clr_msgs()
       loop
    endif

    clear_body(bodycolorl)

    do case
    case selection =1            && Input PKG  Tracking  Events
       old_color = setcolor()
       inp_tmpl(tlcolor,dtcolor,"1.2.1", 1) && Set Input  Screen  Template

-------
                                         && Clear INP Template body
                                         && Call PKG T.E.Input PROC

                                && Display PKG Tracking Events
                                         && Call SHOWTE w/ type=l
                                && Input PKG Tracking Events
   clr_inbody()
   inp_pkg_te()
   set color to &old_color
case selection  = 2
   show_tes(l)
case selection  = 3
   old_color =  setcolor()
   inp_tmpl(tlcolor,dtcolor,"1.2.3",!) && Set Input Screen Template
   clr_inbody()                         && Clear INP Template body
   inp_icw_te()                         && Call ICW T.E. Input PROC
   set color to &old_color
case selection =4            && Display ICW Tracking Events
   old_color = setcolor()
   inp_tmpl(tlcolor,dtcolor,"1.2.4",!) && Set Input Screen Template
   show_tes(2)                          && Call SHOWTE w/ type=2
   set color to &old_color
case selection =5            && Display Both Types Tracking Events
   old_color = setcolor()
   inp_tmpl(tlcolor,dtcolor,"1.2.5",1) && Set Input Screen Template
   show_tes(3)
   set color to &old color
   case  selection = 6
      edit_te()
   case  selection = 7
      del_te()
   case  selection = 8
      clear_body(bodycolorl)
      return
   endcase
         && Call SHOWTE w/ type=3

&& EDIT PKG Tracking Event

&& Delete PKG Tracking Event
                               &&  Clear body before return to menu
 iddo

**  End of listing 1_2MENU.PRG

 r***********************************************
*    File: 1_3MENU.PRG                          *
                                                *
     Called from:  PRAMAIN1.PRG                 *
X                                               *
*    Description: Displays menu 1.3 for ICB     *
                  Function selection.           *

*                                               *
 t***********************************************
        Procedure  MENU1 3
*!
        Called by

            Calls
                 MAIN.PRG

                 MODTEMPLAT
                 MENUPOPUP2()
                 CLR_MSGS
                 CLEAR_BODY
                 INPJTMPL
                 CLR_INBODY
                 EDITORNO()
                 FORM2B
                 ICRJTEST()
  (procedure
  (function
  (procedure
  (procedure
  (procedure
  (procedure
  (function
  (procedure
  (function
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in EDITNOT1.PRG)
in FORM2_AB.PRG)
in MENUS.PRG)

-------
                 :  FORM2A         (procedure in FORM2_AB.PRG)
*!                :  REDRAWTMPL     (procedure in NEWTEMP4.PRG)


procedure menul_3

 dare menul_3[5]                            && MAIN MENU Prompt array
  nul_3[l] = "1   INPUT ORIGINAL PROFILE SHEET (FORM 2B)"
menul_3[2] = "2   EDIT ORIGINAL PROFILE SHEET (FORM 2B)"
  nul_3[3] = "3   INPUT ICB PROFILE SHEET (FORM 2A)"
 •nul_3[4] = "4   EDIT ICB PROFILE SHEET (FORM 2A)"
menul_3[5] = "R   RETURN TO MAIN MENU"

  _3title = "**  ICB MGT MENU  **"
mnl_3str = "1.3"
************************ Declare MENU 1.3 Prompts  **************************

  •clare mp_l_3 [ 5 ]

  ~"Ynput data from an ICR Profile Sheet (Form 2B) for ORIGINAL Clearance"

  ""Review/Modify existing ICR Profile Sheet  (Form 2B) for ORIGINAL Clearance"
—>_1_3[3] = "Input data  from an ICB Profile Sheet  (Form  2A)  "
  (_l_3[4] = "Review/Modify existing ICB Profile Sheet (Form  2A)  data"
.lltj_l_3[5] = "Return to MAIN MENU"

  .l_3_key = 50                         && Max INKEY Value for  this menu

************************ Menu Selection Process Loop  ***********************


uo  while  .t.

    modtemplat(mhl_3str,tlcolor,null_msg,msglcolor)
    selection  = menupopup2(9,20,13,62,ml_0color,menul_3,ml_3title, ;
       mp_l_3,  mpl_3_key)
    if (selection = 1  .or.  selection = 3)  .and.  access_lev = 0
       tone(220,3)
       tone(220,3)
       atinsay(24,0,"W/R1,centring;
          ("UNAUTHORIZED SELECTION - Your  security level  is  insufficient for this
       inkey(30)
       clr_msgs()
       loop
    endif
    clear_body(bodycolorl)

    *****************  Get the ICR #  - Both CASES will need a valid  ICR  ********

    do case
    case selection =1             &&  Input a FORM 2B
       inp_tmpl(tlcolor,dtcolor,"1.3.1",3)
       clr_inbody()
       new_icr_no = editorno(0,1)
       form2b(0, new_icr_no)     && Call Form 2B for New ICR
       clear_body(bodycolorl)
       close all                 && Clean up  DBFs,Relations,Work areas
       *   return
    case selection =2   && EDIT existing Form 2B
       old icr no = editorno(l,1)

-------
  if (old_icr_no - -1)
     clear_body(bodycolorl)
     close all
     loop
  endif
  select package
  @ 14, 17 say "Searching for Package.  One moment,please..."
  seek old_icr_no
  if .not. found()
     tone(220,3)
     tone(220,3)
     atinsay(24,0,'W/R',centring;
        ("There are no packages for that ICR  #  - verify number &  call  system
     inkey(30)
     clr_msgs()
     clear_body(bodycolorl)
     close all
     loop
  endif
  do while icr_number = old_icr_no
     skip
  enddo
  skip -1
  select  icb_prof
  seek old_icr_no
  if  .not. found()
     tone(220,3)
     tone(220,3)
     atinsay(24,0,'W/R1,centring;
         ("There is no  ICR profile  for the  ICR # - check number & call system
      inkey(30)
     clrjmsgs()
     clear_body(bodycolorl)
     close all
      loop
  endif
   inp_tmpl(tlcolor,dtcolor,"1.3.2",2)
   form2b(l,  old_icr_no)
   close  all

case selection =3             && Create/input FORM 2A
   icr_no =  icr_test(l)         && FARM = 1 for input new
   if icr_no  = -1      &&  icr/PKG not exist,  files already closed
      clear_body(bodycolorl)
      loop
   endif
   inp_tmpl(tlcolor,dtcolor,"1.3.3", 2) && Set Input Screen Template
   form2a(0,icr_no)
   close all
   clear_body(bodycolorl)

case selection =4                    && Edit/Review FORM  2A
   icr_no = icr_test(2)        &&  FARM = 2 for edit old
   if icr_no = -1              && no  PKG, files already closed
      clear_body(bodycolorl)
      loop
   endif
   inp_tmpl(tlcolor,dtcolor,"1.3.4" ,2) && Set Input Screen Template
   form2a(1,icr_no)
   close all

-------
     clear_body (bodycolorl)
   case  selection = 5
      clear_body(bodycolorl)     &&  Clear body  before return to menu
      return

   endcase

   redrawtmpl(tlcolor,mhl_3str,dtcolor)

 iddo && Main  proc  loop for menu 1.3

**  End of listing 1_3MENU.PRG

 it***********************************************
     File:  1_4MENU.PRG

     Called from:   PRAMAIN1.PRG
                                                *
                                                *
                                                *
*                                               *
     Description:  Displays menu 1.4 for REPORT  *
                   Function selection.           *
                                                *
*                                               *
 ************************************************
        Procedure  MENU1 4
        Called by

            Calls
             Uses
           Indexes
                   MAIN.PRG

                   MODTEMPLAT
                   MENUPOPUP2()
                   CLEAR_BODY
                   SET_RPTOUT()
                   CLR_MSGS
                   TICKLER
                   MONTHLY
                   EDITFORMS
                   PEND_RPT
                   TRAK_RPT
                   MENU1_4_7
                   REDRAWTMPL

                   ICR.DBF
                   PACKAGE.DBF

                   ICRINDEX.NDX
                   PACKAGEl.NDX
                   PACKAGE2.NDX
(procedure
(function
(procedure
(function
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in RPTS.PRG)
in NEWTEMP4.PRG)
in RPTS.PRG)
in RPTS.PRG)
in MENUS.PRG)
in RPTS.PRG)
in RPTS.PRG)
in MENUS.PRG)
in NEWTEMP4.PRG)
 procedure menul_4

  rivate sort_key,  prn_status

 -et delimiters on

 Declare menul_4[8]
 menul_4[l] = "1   PRINT ICR STATUS REPORT"
                                              && MAIN MENU Prompt array

-------
  nul_4[2] = "2   PRINT TICKLER REPORT"
menul_4[3] = "3   PRINT MONTHLY REPORT"
«• nul_4[4] = "4   EDIT FORMS"
  nul_4[5] = "5   LIST PROPOSED ICRs"
_.._nul_4[6] = "6   LIST TRACKING EVENT HISTORY"
menul_4[7] = "7   ICR SUMMARY"
  nul_4[8] = "R   RETURN TO MAIN MENU"

ml_4title = "**  REPORTS MENU  **"
  l_4str = "1.4"

************************ Declare MENU 1.4 Prompts  **************************

  clare mp_l_4[8]
-,'_1_4[1] =;
   "Generate ICR STATUS report for IPB - Grouped by PO,  sorted by ICR #  or OMB #
  __
    "Generate a  listing of all  ICRs with Expiration Date within 9 months of today
mp_l_4[3] = "Generates the MONTHLY report grouped by  Program office"
  _1_4[4] = "Print data  from an  SF-83/Form 2B/ICW for Desk Officer Edits"
  __
    "Generate  list of ICRs,  proposed  at  ICB, that have  not yet processed an SF-83
 mn_i_4[6]  = "Generates  a  listing  of  all Tracking events for a given ICR #"
   __
    "Display an ICR Summary  on screen  or  Print  report of ICR Change History"
 mp_l_4[8]  = "Return to  MAIN MENU"

   •l_4_key  = 55                        &&  Max  INKEY Value for this menu

 ••.**********************  Menu Selection  Process Loop  ***********************

 _j while .t.

    modtemplat (mhl_4str , tlcolor , nulljmsg , msglcolor )
    selection = menupopup2 ( 8 , 22 , 15, 52 ,ml_0color,menul_4 ,ml_4title, ;
       mp_l_4, mpl_4_key)
    clear_body(bodycolorl)

    do case
    case selection = 1
       modtemplat ("1.4.1", tlcolor,  null_msg,  msglcolor)
       sort_key = " "
       prn_status = 4
       @ 10,14,17,66 box "Ei»0UE° "
       @ 12,20 say "Do you want the ICRs sorted by"
       *  ATINSAY(13,34,"GR+/B","I")
       @ 13,34 say "CR Number"
       *  ATINSAY(14,34,"GR+/B","0")
       @ 14,34 say "<0>MB Number"
       @ 16,  31 say "Enter Selection: "
       @ 23,0  say centring;
           ("Enter  to  sort by ICR Number or  <0>  to  sort  by  OMB Number")
       @ 24,0  say centring;
           ("Both sort selections will first be  grouped Program Office or Agency")
       @ 16,  48 get sort_key pict "!" valid (sort_key  =  "I" .or.  ;
           sort_key = "O")
       read
       @ 23,0 clear to  24,79
       prn_status  = set_rptout(l)
       if  prn_status =4     && error  condition  in PRN  setup

-------
      clear_body(bodycolor1)
      clr_rasgs()
      loop                 && repaint menu
   endif
   modtemplat("1.4.1",  tlcolor,  nulljmsg, msglcolor)
   status(sort_key,prn_status)
   set device to screen
   set printer to
   close all
   clear_body(bodycolor1)

case selection = 2
   raodtemplatC'l^.Z",  tlcolor,  nulljmsg, msglcolor)
   sort_key = " "
   prn_status = 4
   *  @ 10,14,17,66 BOX "E±»B3$iEa "
   prn_status = set_rptout(l)
   if prn_status =4    && error condition in PRN setup
      clear_body(bodycolorl)
      clr_msgs()
      loop                 && repaint menu
   endif
   modtemplat(n1.4.2",  tlcolor, null_msg, msglcolor)
   tickler(sort_key,prn_status)
   set device to screen
   set printer to
   close all
   clear_body(bodycolorl)

case  selection = 3
   modtemplat("1.4.3", tlcolor, null_msg, msglcolor)
   sort_key = "  "
   prn_status =  4
   @  10,14,17,66 box "
   prnjstatus =  set_rptout(1)
   if prn_status =4    && error condition  in  PRN  setup
      clear_body(bodycolor1)
      clr_msgs()
      loop                 && repaint menu
   endif
   modtemplat("1.4.3", tlcolor,  nulljmsg, msglcolor)
   monthly(sort_key,prnjstatus)
   set  device to screen
   set  printer  to
   close all
   clearjbody(bodycolorl)

 case  selection =4        && Call Editforms  Sub-Menu
    editforms()
    clearjbody(bodycolorl)
 case  selection =5        && Print list of "PENDING" iCR's
    modtemplatC'l^.S",  tlcolor,  nulljnsg, msglcolor)
    clear_body(bodycolorl)
    @  10,14,17,66 box  "EI
    prnjstatus = set_rptout(1)
    if prnjstatus ==4     && error condition in PRN setup
       clearjbody(bodycolorl)
       clr_msgs()
       loop                 && repaint menu
    endif

-------
   iaodtemplat("1.4.5",  tricolor,  null_msg,  msglcolor)
   pend_rpt()
   set device to screen
   set printer to
   close all
   clear_body(bodycolorl)
   loop
case selection =6                && Tracking Events history report
   modtemplat("1.4.6",  tlcolor,  null_msg,  msglcolor)
   @ 10,13,16,67 box "EI»aUEB "
   icr_numb = 0
   pkg_numb = 0
   @ 23,0 say centring;
      ("To list all Traking Events for all Packages, enter 00 for the PACKAGE
   @ 12, 16 say "Enter the ICR.PACKAGE Number for the History"
   set delimiters off
   @ 14,35 say "[      .   ]"
   @ 14,37 get icr_numb pict "9999"
   @ 14,42 get pkg_numb pict "99"
   read
   set delimiters on
   @ 23, 0 clear to 24,79
   select  1
   use icr index icrindex.ndx
   seek  (icr_numb)
   is_icr_flg = found()
   if pkg_numb = 0
      select 2
      use  package index packagel.ndx
      seek icr_numb
   else
      select 2
      use  package index package2.ndx
      sk_str =  str(icr_numb,4,0)+str(pkg_numb,2,0)
      seek pad(sk_str,len(indexkey(0)))
    endif
    is_pkg_flg  = found()
    if  is_icr_flg .and. is_pkg_flg
      prn_status =  4
      clear_body(bodycolorl)
       *  @ 10,14,17,66 BOX "ti»*
      prn_status =  set_rptout(l)
       if prn_status =4     && error condition in PRN setup
          clear_body(bodycolorl)
          clr_msgs()
          loop                 && repaint  menu
       endif
       modtemplatC'l^.e",  tlcolor,  null_msg, msglcolor)
       trak_rpt (icr_numb, pkg_numb)
       set device to screen
       set printer to
       close all
       clear_body(bodycolorl)
       loop
    endif
    @ 11,14 clear to 15, 66
    atinsay(12,15,'W/R1,;
       "INVALID ENTRY  - Please check number and try again.")
    @ 14,20 say "Press any key to return to EDIT FORMS MENU..."
    inkey(60)

-------
     clear_body(bodycolorl)
     loop

  case selection = 7
     menul_4_7()
  case selection = 8
     clear_body(bodycolorl)
     return
  endcase
  clear_body(bodycolorl)
  redrawtmpl(tlcolor,mhl_4str,dtcolor)

-~iddo

 •• End of listing  1_4MENU.PRG

 :***********************************************
     File:  1_5MENU.PRG                          *
*                                               *
     Called from:   PRAMAIN1.PRG                 *
                                                *
*    Description:  Displays menu 1.5 for         *
                  SYSTEM ADNIM Functions.        *
                                                *
                                                *
*************************************************
                             && Review/display an  ICR summary


                      && Clear body before return  to menu
*!
*i
*!
 *'
        Procedure
        Called by
            Calls
 X I
             Uses
Indexes
MENU1_5

MAIN.PRG

MODTEMPLAT
MENUPOPUP2()
CLEAR_BODY
INP_TMPL
ADDUSER2
REDRAWTMPL
MENU1_5_2
ARCH_ICR
ICR_PACK
EXP_TEXT_1
EXP_TEXT_2

SYSTEM.DBF
ICR.DBF

ICRINDEX.NDX
                        (procedure
                        (function
                        (procedure
                        (procedure
                        (procedure
                        (procedure
                        (procedure
                        (procedure
                        (procedure
                        (procedure
                        (procedure
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in MENUS.PRG)
in NEWTEMP4.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
in MENUS.PRG)
 .--ocedure menul  5
  sclare menul_5[7]
  »nul_5[l]  =  "1
 menul_5[2]  =  "2
  jnul_5[3]  =  "3
  jnul_5[4]  =  "4
 menul_5[5]  =  "5
 ™9nul_5[6]  =  "6
        ADD/UPDATE USER TABLE"
        UPDATE SYSTEM TABLES"
        ARCHIVE RECORDS"
        BACKUP/EXPORT DATA FILES"
        RESTORE DATA FILES"
        EXPORT DATA TO DBASE III"
                                   && MAIN  MENU Prompt array

-------
 snul_5[7] = "R   RETURN TO MAIN MENU"

 -._5title = "**  SYSTEM ADMIN  MENU  **"
 il5str = "1.5"
                         Declare MENU 1.4  Prompts  **************************

 jclare mp_l_5[7]
 p_l_5[l]  =;
   "Add a  new User  or  Edit old User Profile - User ID, Password, Access Level, etc"
 >_1_5[2]  = ;
   "Update a  System Look-up Table: AA/Division Codes, Agency Codes, Event Codes"
 >_i_5[3]  = ;
   "Move Selected ICR  Records from the DBMS to the Archive for storage"
  __
   "Copy data files to floppy disk(s) for Backup or Export to other systems"
  >_1_5[5] = "Reload previous Backup files from floppy disk(s) to the DBMS"
  )_1_5[6] = "Export PRAMS II data and index files for use with DBASE III"
mp_l_5[7] = "Return to the MAIN MENU"

  >l_5_key = 54                         && Max INKEY Value for this menu

•"-•v********************** Menu Selection Process Loop  ***********************
  rivate selection,  a_or_m,icr_numb,ok_arc

do while .t.

   modtemplat (mhl_5str , t Icolor , nul l_msg , msglcolor )
   selection = menupopup2(8,25, 14,52,ml_0color,menul_5,ml_5title, ;
      mp_l_5, mpl_5_key)
   clear_body (bodycolor 1 )

   do case
   case  selection =1       && Add/Modify a User Profile
      a_or_m  = "A"
      @  9,13,16,67 box "E±»a^iEfl  "
      @  11,20 say "Do you want to:"
      *  ATINSAY(12,35,"GR+/B","A")
      @  12,35 say "dd a  NEW User  Profile"
      *  ATINSAY(13,35,"GR+/B","M")
      @  13,35 say "odify an Existing  Profile"
      @  14,20 say "Enter your Selection:  "
      @  23,0  say centring  ;
          ("Press   to Add a new user or   to  update an existing user")
      @  14,42 get a_or_m pict  "!" valid (a_or_m == "A"  .or.  ;
          a_or_m ==  "M")
      read
       if a_or_m =  "A"
          inp_tmpl (tlcolor , dtcolor , " 1.5. la" , 1)
          use system
          append blank
          adduser2 (a_or_m)
          redrawtmpl (tlcolor ,mhl_5str, dtcolor)
          clear_body(bodycolorl)
          loop
       else
          uid = space (10)
          @ 10,14  clear to  15,66
          @ 12,23  say "Enter User ID of Profile to Modify:"
          * @ 14,33 SAY "[              ]"

-------
      e  14,34  get uid pict  "@!"
      read
      use system
      locate for user_id == uid
      if .not.  found()
         @ 10,14 clear  to  15,66
         tone(220,3)
         tone(220,3)
         atinsay(12,16,"W/R",;
            "INVALID USER  ID  - check before attempting again")
         @ 14,20 say "Press any  key to return to Menu	"
         inkey(60)
         clear_body(bodycolorl)
         return
      endif
      inp_tmpl(tlcolor,dtcolor,"1.5.1m",1)
      adduser2(a_or_m)
      redrawtmpl(tlcolor,mhl_5str,dtcolor)
      clear_body(bodycolorl)
      loop
   endif

case selection =2     && Update PRAMS2 look-up tables
   menul_5_2()        && Call sub-menu for table selection
case selection =3     && Delete an ICR & move to archive
   icr_numb = 0
   again =  "Y"
   ok_arc = "Y"
   @  10,13,15,67 box "Ei»B*iE" "
   do while  .t.
      @  12,17 say  ;
          "Enter the 4-digit number of the  ICR to archive"
      *  @ 13,36 SAY "[      ]"
      @  13,37 get  icr_numb pict "9999"
      read
      str_icr_no = substr(str((icr_numb+10000),5,0),2,4)
      use icr  index icrindex.ndx
      seek(icr_numb)
      if .not.  found()
          @  11,14 clear to  14,66
          atinsay(12,22,'W/R1,;
             11  **   Unable  to locate ICR # "+str_icr_no + "  ** ")
          @  13,30 say  "Try  again?  (Y/N)  "
          @  13,47 get  again pict  "!"  valid  (again =="Y" .or.;
             again  ==  "N")
          read
          if again  ==  "Y"
             @ 11,14 clear to  14,66
             loop
          else
             close  all
             exit   &&  the  Do  While loop - fall thru to Menu
          endif   && again =  ?
       endif  && if ICR #  not found
       * ICR # FOUND - Prompt for confirmation of archive
       @ 11,14 clear to 14,66
       @ 12,16 say  ;
          "Ready to ARCHIVE all  DATA Records for ICR # "+str_icr_no
       @ 13,32 say "CONFIRM (Y/N)  "
       § 13,47 get ok_arc pict "!" valid (ok_arc =="Y"  .or.;

-------
        ok_arc == "N")
     read
     if ok_arc == "N"
        close all
        exit  && the Do While loop - fall thru to Menu
     endif
     @ 11,14 clear to 14,66
     § 12,18 say "Copying records to ARCHIVE - Please be Patient."
     arch_icr(icr_numb)
     *  INKEY(30)
     @ 11,14 clear to 14,66
     @ 11,27 say "Copy to ARCHIVE Completed."
     @ 13,14 say;
        "Should I continue & delete ICR from Active Database?"
     @ 14,32 say "CONFIRM? (Y/N) "
     @ 14,48 get ok_arc pict "!" valid  (ok_arc =="Y"  .or.;
        ok_arc == "N")
     read
     if ok_arc == "Y"
        @ 11,14 clear to 14,66
        @ 11,19 say  ;
            "Deleting records now - Please be Patient."
        icr_pack(icr_numb)
        § 11,14 clear to 14,66
        § 12,20 say  ;
            "Archive  Process Complete  for ICR  #  "+str_icr_no
        @ 13,26 say  "Archive another  ICR?  (Y/N)  "
        @ 13,54      get again pict "!"  valid  (again =="Y"  .or.;
            again ==  "N")
        read
        if  again ==  "Y"
            @ 11,14 clear to  14,66
            loop
        else
            close all
            exit  &&  the  Do While  loop - fall  thru to Menu
        endif   && again = ?
      else     && NOT OK  to Archive  the records
        close all
        exit  && the Do  While  loop  - fall  thru to Menu
      endif
   enddo  && CASE 3 main  Do Loop

case selection =4     &&  Backup/Export all  data files
   selection = "  "
   exp_text_l()
   @ 9,12,16,68 box "Ei»BUEB "
   @ 11,15 say ;
      "Are you ready to execute the Backup/Export function?"
   @ 13,28 say "Enter response (Y/N)  "
   @ 13,50 get selection pict "!" valid (selection == "Y" .or.  ;
      selection == "N")
   read
   if selection == "Y"
      run pramsexp.bat
   endif
case selection =5    && Restore data files from floppy
   selection = " "
   exp_text_2()
   @ 9,12,16,68 box  "Ei»sJiiEa "

-------
     @ 11,18 say  ;
        "Are you  ready to execute the Restore  function?"
     @ 13,28 say  "Enter  response  (Y/N) "
     @ 13,50 get  selection  pict "!" valid  (selection == "Y"  .or.  ;
        selection —  "N")
     read
     if selection ==  "Y"
        run pramrest.bat
     endif
   case selection  =6     &&   Export data  to DB3 format
     run db3exprt.bat
   case selection  =  7
     clear_body(bodycolorl)     && Clear body before return to menu
     return
   endcase
   redrawtmpl(tlcolor,mhl_5str,dtcolor)
   clear_body (bodycolorl)

enddo

 * End  of  listing  1_5MENU.PRG

** End  of  File Level l.X menus
     File: M1_1_1.PRG                           *
                                                *
     Called from:  1_1MENU.PRG  (Menu i.i)       *
                                                *
     Description: Set of stubs  for test only    *
                                                *
                                                *
 ************************************************
        Procedure  MENU1  1  1
            Calls
                  CLEAR_BODY
                  MODTEMPLAT
                  MENUPOPUP2()
                  INP_TMPL
                  CLR_INBODY
                  EDITORNO()
                  FORM2B
                  SF83
                  REDRAWTMPL
  rocedure menul  1  1
(procedure
(procedure
(function
(procedure
(procedure
(function
(procedure
(procedure
(procedure
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in EDITNOT1.PRG)
in FORM2_AB.PRG)
in SF83F.PRG)
in NEWTEMP4.PRG)
response = "  "
 ********************* Declare MENU 1.1.1 Selections

declare menul_l_l[3]
-enul_l_l[l]  =  "1   INPUT ORIGINAL SF-83ICB PROFILE"
 enul_l_l[2]  =  "2   INPUT ORIGINAL SF-83"
_..enul_l_l[3]  =  "R   RETURN TO ICR MGT MENU"
                                                       ***********************

-------
;  _l_ltitl = "** CREATE ICR MENU  **"
mhl_l_lstr = "1.1.1"

  ******************** Declare MENU 1.1.1 Prompts  **************************
        mp_l_l_l[3]
  ,_!_!_! [1] = ;
   "Input Original ICB Profile Form 2B and CREATE a New ICR Summary"
mp_l_l_l[2] = "Input First Occurance of SF-83 Data to CREATE  a  New  ICR  Summary"
  _1_1_1[3] = "Return to Previous Menu - ICR MGT"

mpl_l_lkey =50

  ********************** Menu Selection Process Loop  ***********************

do while  .t.

   clear_body(bodycolorl)
   modtemplat (mhl_l_lstr , tlcolor , null_msg , msglcolor )
   selection = menupopup2 (10, 25, 12,55, ml_0color/menul_l_l,ml_l_ltitl/mp_l_l_l,  m
   *    clear_body(bodycolorl)

   do  case
   case selection  =1              &&  Input a FORM  2B
       inp_tmpl( tlcolor, dtcolor, "1.1.1", 3)
       clr_inbody()
       new_icr_no = editorno (0,1)
       form2b(0, new_icr_no)     && Call Form 2B  for New ICR
       clr_inbody()
       close all                 && Clean up DBFs, Relations, Work areas
       return
   case selection  =  2
       clear_body (bodycolorl)
       @ 11,11,15,69  box  "Ei»flSjiEB   "
       @ 23,0  say centring  ;
          ("If this SF-83 relates  to an ICR that  was  assigned a number during the
       @ 24,0  say centring  ;
          ("process,  the  Desk Officer will have provided that ICR number for  inpu
       @  13,  14 say "Do you have an ICR number  for  this SF-83?  (Y/N) "
       @  13,62 get  response pict "!" valid(response == "Y" ;
          .or.  response ==  "N")
       read
       @  23,00 clear to 24,79
       if  response  == "Y"   && ICR exists,  add  a  new PKG = 01
          old_icr_no = editorno (1,2) && get & validate ICR number
          if old_icr_no = -1         && ICR # didn't exist, error loop
             loop
          end if
          select package      && Go to PKG work area and add  a  blank rec
          append blank
          select icr          && reselect ICR area, pointer at  exist rec
          inp_tmpl (tlcolor , dtcolor , " 1 . 1 . la" , 3 )
          clr_inbody ( )
          sf83(l,old_icr_no,01)  && Update old ICR, add new PKG
          return
       else            && New SF-83 with no previous ICR summary
          inp_tmpl (tlcolor, dtcolor, "1. 1. lb" ,3)
          new_icr_no = editorno (0, 2)
          sf83(0,  new_icr_no, 01)   && Create both  ICR & PKG,  blanks exist
          close all

-------
         return
      endif
   case selection = 3
      clear_body(bodycolorl)
      return
   endcase
   redrawtmpl(tlcolor,mhl_lstr,dtcolor)
_.jddo

   End of PROC menul_l_l

********************************************
    PROC: whichomb                         *
     Prompts for ICR & PKG and validates   *
     existence; sets up work areas; calls  *
*    procs omb_pkg_rs or ombicw in FILE    *
     OMBRESP.PRG for input of data and     *
     update of summary totals in ICR.DBF   *
*                                          *
  ******************************************
                         &&  Clear body before return to menu
        Procedure  WHICHOMB
*!
 *!
Called by

    Calls
 *!
             Uses
           Indexes
 * i
MENU1_1

CHK_DATE()
CLR_MSGS
CENTRING()
INPJTMPL
OMBICW
CLEAR_BODY
OMB_PKG_RS

ICW.DBF
ICR.DBF
PACKAGE.DBF

ICW_DATE.NDX
ICW_ICR.NDX
ICRINDEX.NDX
ICRAGNCY.NDX
ICROMBAG.NDX
PACKAGE1.NDX
PACKAGE2.NDX
                                   (procedure  in MENUS.PRG)
(function
(procedure
(function
(procedure
(procedure
(procedure
(procedure
in SF83F.PRG)
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in OMBRESP.PRG)
in NEWTEMP4.PRG)
in OMBRESP.PRG)
  •ocedure whichomb
   •ivate response, icr_no, pkg_no, is_icw_f Ig, is_icr_f Ig, is_pkg_f Ig, ef f_date

 set color to "BG+/B,BG+/B,,,RB+/B"

   >sponse = "Y"
 icr_no = 0
   :g_no = 0
   :f_date = date()
 is_icw_flg = .t.
 ^<3_icr_flg = .t.

-------
 3_pkg_flg = .t.
@ 10,13,16,67 box "t±»e\±E*  "

 > while .t.

   § 23,00 say centring ;
      ("If OMB is in response  to an SF-83 submission,  press letter N now.")
   @ 12,25 say "Is the OMB Response for an lew?"
   * ATINSAY(14,34,'GR+/B','Y1)
   * @ 14,35 SAY "es or"
   * ATINSAY(14,41,'GR+/B1,'N')
   @ 14,28 say "Enter Response:  (Y/N)  " ;
      get response pict "!" valid (response == "Y" .or.  response == "N")
   read
   @ 23,0 clear to 24,79          && clear msg area
   if response == "Y"          && Yes this is an ICW OMB Action Notice
      § 11,14 clear to 15, 66      && Clear the Prompt box
      @ 12,16 say "Enter the ICW Data below for the record to Update."
      @ 13,32 say "ICR #: "
      @ 14,23 say "Effective Date: "
      @ 13,40 get icr_no picture "9999"
      @ 14,40 get eff_date picture "§D" valid chk_date(eff_date)

      read
      clr_msgs()
      str_icr_no = substr(str((icr_no+10000),5,0) ,2,4)

      select  1
      use  icw index  icw_date.ndx, icw_icr.ndx
      icw_sk_str = str(icr_no,4,0)+dtos(eff_date)
      seek pad(icw_sk_str,len(indexkey(0)))
      is_icw_flg = foundQ
      select  2
      use  icr index  icrindex.ndx,icragncy.ndx,  icrombag.ndx
      seek icr_no
      is_icr_flg = found()
      select  icw

      if  .not.  is_icr_flg
          @ 11,14  clear to 15, 66       &&  Clear  the Prompt  box
          atinsay(12,19,'W/R',"  ** An  ICW does not exist  for  ICR # "+;
             str_icr_no+" ** ")
      end if
       if  .not.  is_icw_flg           && NO ICW record  for ICR Number
          if is_icr_flg            &&  should I clear the  prompt box
             @ 11,14  clear to  15,  66      && clear the Prompt box
          endif
          atinsay(13,17,'W/R',"  ** An ICW does not exist  for  Date "+;
             dtoc(eff_date)+"  ** ")
       endif
       if  .not. is_icw_flg .or.  .not.  is_icr_flg
          tone(220,3)
          tone(220,3)
          atinsay(24,0,'w/r',centring("Check inputs before retrying selection"))
          @ 15,31 say "Try Again? (Y/N) "
          @ 15,48 get response pict "!" valid (response  == "Y"  .or.;
             response == "N")
          read
          clrjmsgs()
          if response == "Y"

-------
         @  11,14  clear to  15,  66       &&  Clear the Prompt box
         close all
         loop
      else
         close all
         return
      endif
   endif
   * ICR &  ICW records exist;  icw selected & both pointers accurate
   * ICR &  ICR dbfs are open and  the pointers in position
   inp_tmpl(tlcolor,dtcolor,"1.1.6a", 2)
   ombicw()
   close all
   return
endif   &&  for IF Y to ICW OMB prompt

** Otherwise fall thru for OMB Resp for a Package
select 1
use package index packagel.ndx,package2.ndx
select 2
use icr index icrindex.ndx,icragncy.ndx,icrombag.ndx
select package
@ 24,0 say centring ;
    ("Entering 00 for the Package # will select the most recent package.")
@ 11,14 clear to 15, 66      && Clear the Prompt box
@ 12,16 say "Enter the ICR.PACKAGE # for the record to Update."
@ 13,35 say "[     .   ]"
set delimiters off
@ 13,37 get icr_no picture  "9999"
@ 13,42 get pkg_no picture  "99"
read
set delimiters on

str_icr_no =  substr(str((icr_no+10000),5,0),2,4)
str_pkg_no =  substr(str((pkg_no+100),3,0),2,2)

**  PACKAGE has  been  selected with  icr#  + pkg#  (packagel.ndx)  index on

if  pkg_no  >  0
    *  sk_pkg_str  =  STR(icr_no,4,0)+STR(pkg_no,2,0)
    *  SEEK  PAD(sk_pkg_str,LEN(INDEXKEY(0)))
    seek icr_no
    do while  icr_number =  icr_no
       is_pkg_flg = .f.
       if pkg_number  = pkg_no
         is_pkg_flg  = .t.
         exit
       endif
       skip
    enddo
 else
    *  SET ORDER TO  2    &&  select  packagel.ndx,  icr# only as index key
    seek icr_no
    is_pkg_flg = found()
 endif


 select icr
 seek icr_no
 is_icr_flg = found()

-------
  select package        &&  proper index  is  already set

  @  11,14  clear to  15,  66
  if .not.  is_pkg_flg           &&  NO PKG  record for ICR Number
     atinsay(12,16,'W/R'," **  A PACKAGE does not exist for ICR # "+;
       str_icr_no+"."+str_pkg_no+" **  ")
  endif
  if .not.  is_icr_flg           &&  NO ICR  record for ICR Number
     atinsay(13,18,'W/R1,11 **  An ICR does  not exist for ICR # " + ;
       str_icr_no+"  ** ")
  endif
  if .not.  is_pkg_flg .or. .not. is_icr_flg
     tone(220,3)
     tone(220,3)
     atinsay(24,0,'w/r1,centring("Check inputs before retrying selection"))
     @ 15,31 say "Try Again? (Y/N)  "
     @ 15,48  get response pict "!" valid (response == "Y" .or.;
        response == "N")
     read
     clr_msgs()
     if response == "Y"
        @ 11,14 clear to  15, 66      && Clear the Prompt box
        loop
     else
        close all
        return
     endif  && respose test
  endif   && not found tests
  * ICR & PKG records exist; pkg selected
  clear_body(bodycolorl)
  *    IF pkg_no = 0
  *        DO WHILE ICR_NUMBER  <>  icr_no        && move pointer  till icr #  chang
  *            SKIP
  *        ENDDO
  *        SKIP -1                              && move back  to  last good icr pk
  *    ENDIF
  * Pointer now set  for package with 00 as  pkg  # input ->  most  recent pkg
  inp_tmpl(tlcolor,dtcolor,"1.1.6b",2)
  omb_pkg_rs()
  close all
  return

 iddo   &&  End of main  do  loop  for  which_omb


 **********************************************
  FUNCTION: icr_test                         *
  RETURNS  a Valid  ICR  number  if good         *
*          if  error ,  -1  is returned          *
 **********************************************
        *********************

         Function:  ICR_TEST()

       Called by:  MENU1_3        (procedure in MENUS.PRG)

             Uses:  PACKAGE.DBF
                 :  ICR.DBF
                 :  ICB PROF.DBF

-------
          Indexes
*!
PACKAGEl.NDX
PACKAGE2.NDX
ICRINDEX.NDX
ICRAGNCY.NDX
ICROMBAG.NDX
ICB.NDX
  notion icr_test
  rameters addoredit

—sponse = "Y"
  _icr = .t.
	_pkg = .t.
icr_numb = 0


§ 10,13,16,67 box "Ei»a*iEa "

  lect 1                               && Set up work area  for  PACKAGE.DBF
use package                            && and index with PACKAGEl.NDX
««»t index to packagel.ndx,package2.ndx  && This will stay open  unless  error

  lect 2
use icr index icrindex.ndx,icragncy.ndx,icrombag.ndx

  dect 3
use icb_prof index  icb.ndx

  lect icr

do while  .t.

   select icr
   @  12,  20 say  "Enter the ICR Number  for the ICB  Profile"
   @  14,36  get icr_numb  picture "9999"

   read
   str_icr_no =  substr(str((icr_numb+10000) ,5,0) ,2,4)
   seek  icr_numb
   is_icr = found()
   select package
   seek  icr_numb
   is_pkg = found()
   select icb_prof
   seek  icr_numb
    icb_exist =  found()
    if icb_exist  .and.  addoredit = 1
       @  11,14  clear to 15,  66
       atinsay(12,15,'W/R',;
          "An ICB Profile (2A) already exists for number "+str_icr_no)
       atinsay(13,16,'W/R«, ;
          "Use EDIT FORM 2A Menu Selection to update old data")
       @ 15,25 say "Try Another ICR Number?  (Y/N)  "
       *  ATINSAY(15,34,'GR+/B','Y')
       *  @ 15,35 SAY "es or"
       *  ATINSAY(15,41,'GR+/B','N')
       @ 15,55  get response pict "!" valid (response == "Y"  .or.;
          response == "N")

-------
   read
   if response == "Y"
      @ 11,14 clear to 15,  66      && Clear the Prompt box
      loop
   else
      close all
      return(-1)
   endif  && for response = Y
endif   && for duplicate icb record found
if .not. icb_exist .and. addoredit = 2
   @ 11,14 clear to 15, 66
   atinsay(12,15,'W/R1,;
      "An ICB Profile (2A)  does NOT exists for number "+str_icr_no)
   atinsay(13,16,'W/R1,;
      "Use INPUT FORM 2A Menu Selection to input new data")
   @ 15,25 say "Try Another ICR Number? (Y/N) "
   *   ATINSAY(15,34,'GR+/B1,'Y')
   *   @ 15,35 SAY "es or"
   *   ATINSAY(15,41,'GR+/B1,'N')
   @ 15,55  get response pict "!" valid (response == "Y"  .or.;
      response == "N")
   read
   if response == "Y"
      @ 11,14 clear to 15, 66      && Clear  the Prompt  box
      loop
   else
      close all
      return(-1)
   endif  &&  for response  = Y
endif   &&  for old  icb record NOT  found
if is_pkg  .and.  is_icr   && ICR  & PKG  are;  goto  last PKG
   select package
   set  filter to icr_number = icr_numb
   go top
   go bottom
   select  3                            &&   and set  ICB_PROF work area

   return(icr_numb)
endif

@ 11,14 clear to 15,  66
if .not.  is_pkg
    atinsay(12,20,'W/R1,"A  PACKAGE  does not exist for number "+str_icr_no)
endif
 if .not.  is_icr
    atinsay(13,22,'W/R1,"An ICR  does not exist for number "+str_icr_no)
endif

 @ 15,25 say "Try Another ICR Number? (Y/N) "
 *  ATINSAY(15,34,'GR+/B','Y')
 *  @ 15,35 SAY "es or"
 *  ATINSAY(15,41,'GR+/B','N')
 @ 15,55 get response pict "!" valid (response == "Y" .or.;
    response == "N")
 read
 if response == "Y"
    @ 11,14 clear to 15, 66      && Clear the Prompt box
    loop
 else
    close all

-------
                                  (procedure  in MENUS.PRG)
                                  (procedure
                                  (procedure
                                  (function
                                  (function
                                  (procedure
                                  (procedure
                                  (procedure
                                  (procedure
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in RPTS.PRG)
in NEWTEMP4.PRG)
in RPTS.PRG)
in RPTS.PRG)
in RPTS.PRG)
     return(-1)
  end if
 iddo   && ICR Number Input loop

  End of FUNC icr_test

 *******************************
       *********************

       Procedure  EDITFORMS
Called by  MENU1_4

    Calls  CLEAR_BODY
           MODTEMPLAT
           MENUPOPUP2()
           SET_RPTOUT()
           CLR_MSGS
           SF83_RPT
           F2B_RPT
           ICW_RPT

     Uses  ICR.DBF
           PACKAGE.DBF
           AGENCIES.DBF
           ICB_PROF.DBF
           ICW.DBF

  Indexes  ICRINDEX.NDX
           ICRAGNCY.NDX
           ICROMBAG.NDX
           PACKAGE1.NDX
           PACKAGE2.NDX
           ICB.NDX
           ICW_ICR.NDX
           ICW DATE.NDX
procedure editfoois  && for menus selection 1.4.4

 civate icr_numb,response,pkg_numb

******************** Declare MENU 1.4.4.1 Selections  ********************

 aclare menu!441[4]
menu!441[l] = "1   PRINT SF-83 "
 2nul441[2] = "2   PRINT ICR PROFILE  (FORM 2B)"
 2nul441[3] = "3   PRINT ICW"
menul441[4] = "R   RETURN TO REPORTS MENU"
 1441title =  "**  EDIT FORMS MENU
 M441str = "1.4.4"
                                    **"
  ********************* Declare MENU  1.4.4.1  Prompts   ************************

declare mp_1441[4]
  p_1441[l]  =  "Print an SF-83 data  for  a  given  ICR  &  Package number"
  p_1441[2]  =  "Print an Original  ICR  Profile  (Form  2B)  for a given ICR number"
,»p_1441[3]  =  "Print an Inventory Correction  Worksheet for a given ICR number"
mp_1441[4]  =  "Leave this Menu and  Return to  REPORTS  MENU"

-------
mp!441_key =51                         && Max INKEY Value for this menu

 *********************** Menu Selection Process Loop  ***********************

HO while .t.
   clear_body(bodycolorl)
   modtemplat(mhl441str,tlcolor,null_msg,msglcolor)
   selection = menupopup2(lll24,14,54,ml_0colorlmenul441,ml441title, ;
      mp_1441, mp!441_key)
   clear_body(bodycolorl)

   @ 10,13,16,67 box "Ei»flUE8 "

   do case
   case selection = 1
      modtemplat("1.4.4.1",tlcolor,null_msg,msglcolor)
      icr_numb = 0
      pkg_numb = 0
      @ 12, 18 say "Enter the ICR Number  for the SF-83:"
      set delimiters off
      set confirm off
      @ 14,33 say "[      .    ]"
      @ 14,35 get icr_numb pict "9999"
      @ 14,40 get pkg_numb pict "99"
      read
      set confirm on
      set delimiters on
      select  1
      use icr  index icrindex.ndx,icragncy.ndx,icrombag.ndx
      seek(icr_numb)
      is_icr_flg = found()
      select  2
      use package  index packagel.ndx
      *   pkg_sk_str =  STR(icr_numb,4,0)+STR(pkg_numb,2,0)
      seek  icr_numb
      do  while icr_number =  icr_numb
          is_pkg_flg =  .f.
          if pkg_number = pkg_numb
             is_pkg_flg = .t.
            exit
          end if
          skip
      enddo
       if  is_icr_flg  .and. is_pkg_flg      && OKAY to run report
          select 3
          use agencies
          prn_status  = 4
          clear_body(bodycolorl)
          *  @ 10,14,17,66 BOX "Ei»"UE8 "
          prn_status  = set_rptout(l)
          if prn_status =4    && error condition in PRN setup
             clear_body(bodycolorl)
             clr_msgs()
             loop                 && repaint menu
          endif
          sf83_rpt(icr_numb,pkg_numb)
          set device to screen
          set printer to
          close all

-------
      clear_body(bodycolorl)
      loop
   end if
   § 11,14 clear to 15,  66
   atinsay(12,15,'W/R«,;
      "INVALID ENTRY -  Please check number and try again.")
   @ 14,20 say "Press any key to return to EDIT FORMS MENU..."
   inkey(60)
   clear_body(bodycolorl)
   loop

case selection = 2
   modtemplat("1.4.4.2",tIcolor,null_msg,msglcolor)
   icr_numb = 0
   @ 12, 16 say "Enter the ICR Number for the ICB Profile (Form 2B)"
   *  §14,35 SAY "[     ]"
   @ 14,36 get icr_numb pict "9999"
   read
   select 1
   use icr index icr index, ndx, icragncy. ndx, icrombag. ndx
   seek icr_numb
   is_icr_flg = found()
   select 2
   use package index packagel.ndx,package2.ndx
   seek icr_numb
   is_pkg_flg = found()
   if is_pkg_flg
      do while icr_number =  icr_numb
         skip
      enddo
      skip -1
   end if
   select 3
   use  icb_prof index  icb.ndx
   seek icr_numb
    is_icb_flg = found()

    if is_icr_flg .and.  is_pkg_flg  .and. is_icb_flg
      prn_status = 4
      clear_body(bodycolorl)
      *     @  10,14,17,66 BOX "Ei»8UE« "
      prn_status = set_rptout(l)
       if  prn_status =4     && error condition in PRN setup
          clear_body(bodycolorl)
          clr_msgs()
          loop                 && repaint  menu
      endif
       f2b_rpt(icr_numb)
       set device to screen
       set printer  to
       close  all
       clear_body(bodycolorl)
       loop
    endif
    @ 11,14 clear to 15,  66
    atinsay(12,15,'W/R1,;
       "INVALID ENTRY - Please check number and try again.")
    @ 14,20 say "Press any key to return to EDIT FORMS MENU..."
    inkey(60)
    clear_body(bodycolorl)

-------
     loop
  case selection  =  3
     modtemplat("1.4.4.3",tlcolor,null_msg,msglcolor)
     icr_numb = 0
     @ 12,  24 say "Enter the ICR Number for the ICW"
     *  § 14,35 SAY "[      ]"
     @ 14,36 get  icr_numb pict "9999"
     read
     select 1
     use icr index  icrindex.ndx, icragncy. ndx, icrombag. ndx
     seek (icr_numb)
     is_icr_flg = found()
     select 2
     use icw index  icw_icr.ndx,icw_date.ndx
     seek (icr_numb)
     is_icw_flg = found()

     if is_icr_flg .and. is_icw_flg
        ************** put call to report here *****************************
        prn_status = 4
        clear_body(bodycolorl)
        *   @ 10,14,17,66 BOX
        prn_status = set_rptout(l)
        if prn_status =4    && error condition  in  PRN  setup
           clear_body(bodycolorl)
           clr_msgs()
           loop                 && repaint menu
        endif
        icw_rpt(icr_numb)
        set device to screen
        set printer to
        close all
        clear_body(bodycolorl)
         loop
      endif
      @  11,14 clear to 15, 66
      atinsay(12,15,'W/R',;
         "INVALID ENTRY  - Please check  number and try  again.")
      @  14,20 say "Press any key to return  to EDIT FORMS MENU..."
      inkey(60)
      clear_body(bodycolorl)
      loop
   case  selection = 4
      clear_body(bodycolorl)
      return

   endcase
 •nddo

** End of PROG editforms
        Procedure:  ADDUSER2

        Called by:  MENU1_5        (procedure in MENUS.PRG)

            Calls:  V_DUPE()       (function  in MENUS.PRG)
                 :  STOP_TST()     (function  in SF83F.PRG)

-------
*!
 •ocedure adduser2
  rameters addormod

nrivate stop_test, again
  t color to "BG+/B,GR+/B, f ,RB+/B"
  op_test = "C"
again = " "
  8,18,16,62 box "UAc
e 10, 18 say "A »+replicate("All,42)+" '"

   addormod == "A"
   @ 9,30 say " * NEW USER INPUT * "
else
   @ 9,26 say " * MODIFY A PROFILE *"
  idif

  > while .t.
   store user_id to user
   if addormod == "M"
      store decrypted (trim (pas sword )) to pwd
   else
      store password to pwd
   endif
   store lastupdate to last_udate
   store fullname to real_name
   store sec_level to security
   do while stop_test <> "D"
      @12,20 say "  User ID:  "
      @13,20 say " Password:  "
      §14,20 say "User Name:  "
      @15,20 say " Security:  "
      @12,32 get user pict "!!!!!!!!!!" valid v_dupe(l,user)
      @13,32 get pwd pict "!!!!!! 1 !!!" valid v_dupe(2 ,pwd)
      @14,32 get real_name pict "@!"
      @15,32 get security pict  "9" valid v_dupe( 3, security)

      read

      stop_test =  stop_tst()
      if  stop_test ==  "E"
          if addormod ==  "A"
             go bottom
             delete
             pack
          endif
          close all
          return
       endif

    enddo  && Review loop

    if addormod == "M"
       locate for user_id == user
       replace user_id with user, password with encrypted (trim (pwd) ),;
          fullname with real_name, lastupdate with date(),;
          sec_level with security
       close all

-------
     return
  endif
  go bottom
  replace user_id with user,password with encrypted(trim(pwd)),;
     fullname with real_name, lastupdate with date(),;
     sec_level with security
  @ 17,18,19,62 box "UAi'UAA1 "
  @ 18,22 say "Add Another User?  (Y/N) "
  @ 18,46 get again pict "!" valid  (again == "Y"  .or. again  == "N")
  read
  if again == "N"
     close all
     return
  endif
  § 17,18 clear to 19,62
  stop_test  = "C"
  append blank
 iddo  && for main Loop

  End of PROC adduser2
         Function:  V_DUPE()
*!
 !       Called by:  ADDUSER2        (procedure in MENUS.PRG)
 i

"metion v_dupe
 irameter parm_type,id_or_pwd

if addormod == "M"
   return(.t.)
 idif

 f parm_type = 1
   locate for user_id == id_or_pwd
   if found()
      tone(220,3)
      tone(220,3)
      atinsay(24,6,"W/R»,;
         "Duplicate User ID - Please Re-enter  	 Press any  key  to  continue")
      inkey(30)
      @ 24,0 clear to 24,79
      return(.f.)
   else
      return(.t.)
   endif
«ndif
  f parm_type  = 2
   locate  for  password == encrypted(id_or_pwd)
   if found()
      tone(220,3)
      tone(220,3)
      atinsay(24,6,"W/R",;
          "Duplicate  Password  -  Please  Re-enter 	 Press  any key to continue")
      inkey(30)
      @  24,0 clear to  24,79
      return(.f.)

-------
   else
      return(.t.)
   endif
 idif

if parm_type  =  3
   if id_or_pwd  >  1
      tone(220,3)
      tone(220,3)
      atinsay(24,4,"W/R",;
         "Must  be  0 for Read Only or 1 for Read/Write..
      inkey(30)
      @  24,0  clear to 24,79
      return(.f.)
   else
      return(.t.)
   endif
 ndif

 * End of FUNG v_dupe

**************************
                                                        ..Press  any key to conti
        Procedure

        Called by

            Calls
             Uses
                  MENU1_5_2

                  MENU1_5

                  MODTEMPLAT
                  MENUPOPUP2()
                  INP_TMPL
                  REDRAWTMPL
                  CLEAR_BODY

                  AADIV.DBF
                  AGENCIES.DBF
                  EVENTS.DBF
(procedure in MENUS.PRG)
(procedure
(function
(procedure
(procedure
(procedure
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
in NEWTEMP4.PRG)
                                                && MENU 1.5.2 Prompt array
Tocedure menul_5_2

,-rivate selection

 eclare menul_5_2[4]
 enul_5_2[l]  = "1   UPDATE AA/DIVISION TABLE"
menul_5_2[2]  = "2   UPDATE AGENCIES TABLES"
 enul_5_2[3]  = "3   UPDATE EVENTS TABLE"
 enul_5_2[4]  = "R   RETURN TO ADMIN MENU"

ml_5_2titl = "**  TABLE SELECTION  **"
 hl_5_2str = "1.5.2"

************************ Declare MENU 1..5.2 Prompts   ***********************

 eclare mp_l_5_2[4]
mp_l_5_2[l] =;
   "Add new codes or modify old fields in AA/Division  Code  Look-up Table"
 P_l_5_2[2] = ;
   "Add new codes or modify old fields in the Agency Code Look-up Table"
mp_l_5_2[3] = ;

-------
   "Add new codes or modify old fields in Tracking Event Code Look-up Table"
mp_l_5_2[4] = "Return to the ADMIN MENU"

  >l_5_2key = 51                         && Max INKEY Value  for this menu

************************ Menu Selection Process Loop  ***********************

  > while .t.

   modtemplat(mhl_5_2strftlcolor,null_msg,msglcolor)
   selection = menupopup2 (8,25,11,53, ml_0color,menul_5_2,ml_5_2titl, ;
      mp_l_5_2, mp1_5_2 key)
   do case
   case selection = 1
      inp_tmpl(tlcolor,dtcolor,"1.5.2.1",1)
      use aadiv
      scan("AA/DIV.dbf","Updating the AA/Division Codes  Look-up  Table")
      close all
   case selection = 2
      inp_tmpl(tlcolor,dtcolor,"1.5.2.1",!)
      use agencies
      scan("AGENCIES.dbf","Updating the Agency Codes  Look-up Table")
      close all
   case selection = 3
      inp_tmpl(tlcolor,dtcolor,"1.5.2.1",!)
      use  events
      scan ("EVENTS.dbf"/'Updating the Tracking Event  Codes Look-up Table")
      close all
   case selection = 4
      return
   end CASE
   redrawtmpl(tlcolor,mhl_5_2str,dtcolor)
   clear_body(bodycolorl)

  iddo

   End of  PROC menul_5_2

 ..A****************************************
 *     PROCEDURE  to  display text prior to
         restoring data from floppy
         Procedure:  EXP_TEXT_2

         Called by:  MENU1_5        (procedure in MENUS.PRG)

    ********************************************************************
 orocedure exp_text_2

  2lp_buff = savescreen(0,0,24,79)
 clear

  5Xt
                       RESTORE   DATA   FILES

      THIS SELECTION WILL ALLOW THE RESTORING OF ALL  PRAMS  II DATA FILES
      FROM A SERIES OF FLOPPY  DISKS CONTAINING A PREVIOUS BACKUP/EXPORT.
      THE PRAMS II APPLICATION WILL BE HALTED TEMPORARILY AND THE SCREEN

-------
    WILL CHANGE TO THE DOS ENVIRONMENT. YOU WILL RETURN TO PRAMS II
    WHEN THE OPERATION IS COMPLETED OR ABORTED.

                  ******   CAUTION   ******
    THIS PROCESS  UTILIZES THE  DOS  "RESTORE" ROUTINE.   THE ADMINISTRATOR
    MUST HAVE  A COMPLETE SET OF  PREVIOUS  BACKUP DISKS READY AND ON HAND
    OR THE  PROCESS MAY DAMAGE  THE  CURRENT PRAMS II  FILES.

    PLEASE  NOTE THAT  ANY DATA  CURRENTLY ON THE HARD DISK RELATING TO THE
    PRAMS II SYSTEM WILL BE WRITTEN OVER. THIS EFFECTIVELY DESTROYS ANY
    PREVIOUS DATA RESIDENT IN  THE  SYSTEM  AT TIME OF RESTORE AND REPLACES
    IT WITH THE DATA  FROM THE  FLOPPY  DISKS.   CARE  SHOULD BE TAKEN THAT
    THE DATA TO BE RESTORED IS A NEWER VERSION THAN THAT WHICH IS ALREADY
    IN THE  SYSTEM HARD DISK FILES.

    THIS OPERATION UTILIZES THE  SYSTEM FLOPPY DRIVE,  A:, WHICH IS USUALLY
    THE UPPER  FLOPPY  DRIVE ON  A  STANDARD  PC.   BE  CERTAIN THAT IF THE BACKUP
    WAS DONE ON A HIGH DENSITY DRIVE, THE TARGET  DRIVE IS OF THE SAME TYPE

—1DTEXT
  0,0,24,79  box "6l,3 *i6J"
X = 0
Hn while i  = 0
   i = inkey(O)
  iddo

  iStscreen  (0,0,24,79,help_buff)

return

  End pf PROC exp_text_l


  :****************************************
      PROCEDURE to display text  prior to
*       export of data to floppy
 *i       Procedure: EXP_TEXT_1

         Called by: MENU1_5         (procedure  in MENUS.PRG)
 * !

   ocedure  exp_text_l

 ' slp_buff  = savescreen(0,0,24,79)
   ear

 text
                 BACKUP  &  EXPORT   DATA   FILES

      THIS  SELECTION WILL ALLOW THE SYSTEM ADMINISTRATOR TO WRITE THE PRAMS
      DATA  FILES  OUT TO A SERIES OF FLOPPY DISKS  FOR EITHER BACKUP STORAGE
      OR EXPORT TO A DESK OFFICER'S PC WHERE THE  FILES MAY BE RESTORED AND
      VIEWED WITH DBASE III.

                   ******  CAUTION  ******
      THIS  PROCESS UTILIZES THE DOS "BACKUP" ROUTINE.  THE ADMINISTRATOR
      MUST  HAVE A SUFFICIENT NUMBER OF HIGH-DENSITY,FORMATED FLOPPY DISKS

-------
    READY AND AVAILABLE  BEFORE THIS  PROCESS  IS  EXECUTED.

    IF THE NUMBER OF  AVAILABLE FORMATED DISKS IS INSUFFICIENT FOR THE
    DATA EXTRACTION,  THERE ARE TWO OPTIONS:  (1)  GET MORE  DISKS & PREPARE
    THEM ON  ANOTHER MACHINE  (THE  SYSTEM WILL PAUSE AND WAIT FOR YOU) ;
     (2) AT THE  PROMPT FOR THE NEXT DISK,  PRESS   and  AT THE SAME
    TIME  (THIS  WILL ABORT THE PROCESS.  YOU WILL HAVE TO RESTART FROM THE
    BEGINNING).

    THE DATA FILES  ON THE FLOPPIES MAY  BE RESTORED TO THIS OR ANY OTHER
    PC-DOS SYSTEM BY  ISSUING THE  DOS COMMAND "RESTORE" (WITH PARAMETERS)
    FROM THE COMMAND  LINE.   REFER TO PRAMS2  USER MANUAL FOR MORE DETAILS.

  DTEXT
.  0,0,24,79 box "OI.'UO"1
i  = 0
   while  i =  0
   i = inkey(O)
enddo

  stscreen (0,0,24,79,help_buff)

rp.turn

  End pf PROC exp_text_2

  ******************************

* i
•••'      Procedure: ICRSUM

       **********
procedure icrsum
  rameters _icr_numbe


  ilect icr
  •t color to "BG+/B,GR+/B,,,RB+/B"

**************************   set up local  Variables  *************************


_te_status=te_status
  .e_date = te_date
   icr_title=icr_title
*_dabo_name=dabo_name
  "sxp_date=exp_date
   cr_cmnts = icr_cmnts
_dum_resp=sum_resp
  sum_rpt_h=sum_rpt_h r
  ium_adj rpt=sum_adj rpt
_ mm_adj rsp=sum_adj rsp
_sum_pc_rs=sum_pc_rsp
  ;um_pc_hr=sum_pc_hrs

 * clear
 -00,  20 say "ICR    SUMMARY   REVIEW"
   24,0  say centring ;
    ("You  may update the ICR Comments by entering new text & saving  with Ctrl-W")
 @ 2,  0,  9,  80 box

-------
  3,  2  say "ICR Number:  "+substr(str( (_icr_numbe+10000) ,5, 0) ,2,4)
@ 3,  22 say "Expires:  "+dtoc(exp_date)
" 3,  43 say "Last Track Event:  " +_te_status+ " on "+dtoc(_te_date)

c 4,  2  say "Title: "
0 4,  9  say memoline(icr_title,68,l)
  5,  9  say memoline(icr_title,68,2)
 _icr_title = memoedit(_icr_title,4,ll,5,78, .F. )

  :eyboard ( chr (23))
  6,  2  say "Department/Agency/Bureau/Office: "
e 7,2 say memoline(dabo_name,78,l)
a 8,2 say memoline(dabo_name,78,2)
  _dabo_name = memoedit (_dabo_name ,9,11,10,78, .F.)


  10, 0, 17, 80 box "UAi'UAA1 "
  11, 2 say "Summary of Responses and Reporting Hours:"
@ 12, 11 say "                           Responses     Reporting Hours"
 ' 13, 11 say "                           ---------     --------------- "
  14, 8 say "       Total Inventory:   "+ str(_sum_resp)  +  "       "+str(_sum_rpt
is 15, 8 say "     Total Adjustments:   "+ str(_sum_adjrsp)+"       "+str(_sum_adj

-------
  rameters  _icr_numbe

*«=et talk on
  ,tr_icr=SUBSTR(STR((_ICR_NUMBE+10000),5,0),2,4)

*@ 11,14 CLEAR TO 14,66
   12 20, say "Now archiving ICR Number "+str_icr"
  i 11,23, say "One moment,  please	"

  ;e arc_icr.dbf
  ipend from icr.dbf for icr_number = _icr_numbe
use arc_pkg.dbf
»~pend from package.dbf for icr_number = _icr_numbe
  ,e arc_icb.dbf
.jpend from icb_prof.dbf for icr_number = _icr_numbe
use arc_icw.dbf
  >pend from icw.dbf for icr_number = _icr_numbe
  ;e arc_trk.dbf
append from tracking.dbf for icr_number = _icr_numbe

  turn

* End of PROC arch icr
   PROCEDURE:   icr_pack   (for the PRAMS project; 9/25/89        *
   PARAMETERS: _ICR_NUMBE                                       *
   DESCRIPTION:  deletes all records of a chosen ICR#           *
                 for all the databases  (related by  icr number)  *
                 into associated archive databases.
 *'
         Procedure  ICR  PACK
 *!
 *!
 *!
 * !
 j. i
         Called by

              Uses
           Indexes
MENU1_5

ICR.DBF
PACKAGE.DBF
ICW.DBF
TRACKING.DBF
ICB_PROF.DBF

ICRINDEX.NDX
ICRAGNCY.NDX
ICROMBAG.NDX
PACKAGEl.NDX
PACKAGE2.NDX
ICW_ICR.NDX
ICW_DATE.NDX
TRAKICR.NDX
TRAKPKG.NDX
TRAKDATE.NDX
ICB.NDX
(procedure  in MENUS.PRG)
 nrocedure icr_pack

-------
 irameters _icr_numbe


 set talk on
~=tr_icr=SUBSTR(STR((_ICR_NUMBE+10000),5,0),2,4)
*clear

 ? 10, 0 say "   Now deleting Icr Number "+str_icr+" from the main working  files
*@ 11, 0 say "   This will take a few minutes.  "
 » 12, 0 say "   Archive files are uneffected."

e 12,15 say "ICR records —"
••~>e icr index icrindex.ndx,icragncy.ndx,icrombag.ndx
  jlete for icr_number=_icr_numbe
rack
@ 12,29 say "DONE"+space(8)+"PACKAGE records..."
  ;e package index packagel.ndxrpackage2.ndx
  jlete for icr_number=_icr_numbe
pack
  12,60 say "DONE"
  13,15 say "ICW records..."
use icw index icw_icr.ndx,icw_date.ndx
^lete for icr_number=_icr_numbe
  ick
  13,29 say "pONE"+space(8)+"TRACKING records..."
use tracking  index trakicr.ndx,trakpkg.ndx,trakdate.ndx
  ;lete for icr_number=_icr_numbe
  ick
@ 13,60 say "DONE"
" 14,33 say "ICB records..."
  se icb_prof  index icb.ndx
Delete for icr_number=_icr_numbe
nack
  14,47 say "DONE"

return

  End of  PROC icr_pack
   PROCEDURE:  ICR_CHANGE                                   *
 * PARAMETERS:  _icr_numbe
   DESCRIPTION:  Displays fields summary information about *
   a selected ICR as listed in the ICR.DBF database and    *
 * allows changes to this information which is then stored *
   in the database called CHANGICR.DBF.                    *
         Procedure: ICR_CHANGE

         Called by: MENU1_4_7       (procedure in MENUS.PRG)

             Calls: DOWNJTON        (procedure in SF83F.PRG)

              Uses: CHANGICR.DBF

-------
  •ocedure icr_change
parameters _icr_numbe

  lect 2
u^e changicr.dbf

  lect icr

**************************  set up local Variables   *************************
  .r_icr=substr(str((_icr_numbe+10000) ,5,0) ,2,4)
  :e_status=te_status
_icr_title=icr_title
 •}abo_name=dabo_name        && these remain un-editable  here.

_icr_cmnts = icr_cmnts

  ixp_date  = exp_date
_ lewexpire = exp_date

  ;um_resp  = sum_resp
  iew_resp  = sum_resp
 num_rpt_h = sum_rpt_hr
  iew_rpt_h = sum_rpt_hr

 sum_adjrpt= sum_adjrpt
  iew_adjrpt= sum_adjrpt

_sum_ad j rsp= sum_ad j rsp
  iew_adjrsp= sum_adjrsp

_£um_pc_rs = sum_pc_rsp
 new_pc_rs = sum_pc_rsp

_3um_pc_hr = sum_pc_hrs
_new_pc_hr = sum_pc_hrs

  2t color to "BG+/B,GR+/B, , ,RB+/B"

•••00, 20 say  "ICR   SUMMARY   REVIEW"
   1,  0, 11, 80 box "UA£J "AA3  "
.2,1 say "ICR Number:  "+str_icr
@  2,  30 say "Expires:  "+dtoc(_exp_date)
   2,  50 say "    Tracking Event  Status:  " +_te_status
   4,  1 say "Title: "
keyboard (chr( 23))
  icr_title = memoedit(_icr_title, 4, 11,5,78, .f. )

keyboard ( chr (23))
0  7,  l say "Department / Agency / Bureau / Office: "
  dabo_name = memoedit (_dabo_name, 8, 11,9,78, . f. )
   10,  0,  17,  80 box "AA'J "AA1  "
   11,  2  say "Summary of Responses and Reporting Hours:"
   12,  2  say "                   Responses           Hours"
   12,  51 say "New Responses    New Hours"
   13,  2  say "                   ---------           ----- »
   13,  51 say " -------------    --------- "
   14,  2  say "Total Inventory:"

-------
  14,  20 say _sum_resp pict "##########"
e 14,  36 say _sum_rpt_h pict "##########"
» 14,  52 say _new_resp pict "I#########"
  14,  68 say _new_rpt_h pict »##########»
. 15,  2 say "Adjustments:11
@ 15,  20 say _sum_adjrsp pict "##########"
  15,  36 say _sum_adjrpt pict "##########"
  15,  52 say _new_adjrsp pict " #!########»
i 15,  68 say _new_adjrpt pict "##########"
"16,  2 say "Program Change:"
  16,  20 say _sum_pc_rs pict "##########"
e 16,  36 say _sum_pc_hr pict "##########"
a 16,  52 say  _new_pc_rs pict "##########"
  16,  68 say _new_pc_hr pict "##########"

* keyboard(chr(23))
  18,0,22,80 box '»  "UAA1 "

e 18,  1 say "Comments:  (CTRL-W to exit) "
 2mpcolor = setcolor()
 2t color to "GR+/B,GR+/B,,,GR+/B"
_icr_cmnts = memoedit(_icr_cmnts,19,1,21,78,.t.)
set color to &tempcolor

 splace icr_cmnts with _icr_cmnts

 )ne(440,3)
 3ne(440,3)

n 24,  0 say centring;
   ("Press  to edit expiration date or totals or  to leave unchanaed
_^tion=inkey(60)                                                              y
if action=305
   @ 3, 23 say "New Expiration:" get _newexpire
   @ 14, 52 get _new_resp
   @ 15, 52 get _new_adjrsp
   @ 16, 52 get _new_pc_rs
   § 14, 66 get _new_rpt_h
   § 15, 66 get _new_adjrpt
   @ 16, 66 get _new_pc_hr
   read
 ndif

 f _newexpire <>_exp_date .or. _new_resp   <> _sum_resp .or. ;
      _new_adjrspo_sum_adjrsp  .or.  _new_pc_rs  <> _sum_pc_rs  .or.  ;
      _new_rpt_h <> _sum_rpt_h  .or.  _new_adjrpt <>  sum adjrpt .or.  ;
      _new_pc_hr <> _sum_pc_hr                      ~   ~
   tempcolor = setcolor()
   set color to "BG+/N,GR+/N,,,w/N"
   @ 6, 2, 16, 77 box "UAc'UAA3  "
   @ 7, 4 say "Enter justification for this change:  (CTRL-W to exit  and  save)"
   select changicr                                                            ;
   action=0
   _chg_reason=" "
   do while empty(_chg_reason)=.t. .and. action<>286
      _chg_reason = memoedit(_chg_reason,8,4,15,75)
      if empty(_chg_reason)=.t.
         down_ton()
         @ 24, 0 say centring;
            ("A Justification must be entered or Press   to quit without s

-------
        action=inkey(60)
     endif
  enddo

  if action<>286
     append blank
     replace chg_reason with _chg_reason
     replace newexpire with _newexpire
     replace oldexpire with _exp_date

     replace new_resp with _new_resp
     replace old_resp with _sum_resp

     replace new_rpthrs with _new_rpt_h
     replace old_rpthrs with _sum_rpt_h

     replace new_adjrpt with _new_adjrpt
     replace old_adjrpt with _sum_adjrpt

     replace new_adjrsp with _new_adjrsp
     replace old_adjrsp with _sum_adjrsp

     replace new_pc_rsp with _new_pc_rs
     replace old_pc_rsp with _sum_pc_rs

     replace new_pc_hrs with _new_pc_hr
     replace old_pc_hrs with _sum_pc_hr

     replace chg_reason with _chg_reason
     replace chg_date  with  date()
     replace icr_number with _icr_numbe
      select  icr
      replace exp_date    with _newexpire
      replace sum_resp    with _new_resp
      replace sum_rpt_hr with _new_rpt_h
      replace sum_adjrpt with _new_adjrpt
      replace sum_adjrsp with _new_adjrsp
      replace sum_pc_rsp with _new_pc_rs
      replace sum_pc_hrs with _new_pc_hr
      replace icr_cmnts with _icr_cmnts

   endif      &&  if the changes were not  aborted with ALT-N
 ndif            && if  there were any changes made

-aturn

   END OF PROCEDURE: ICR_CHANGE

 *******************************************
        Procedure: MENU1_4_7

        Called by: MENU1_4         (procedure in MENUS.PRG)

            Calls: MODTEMPLAT      (procedure in NEWTEMP4.PRG)
                  : MENUPOPUP2()    (function  in NEWTEMP4.PRG)
                  : CLEAR_BODY      (procedure in NEWTEMP4.PRG)

-------
*!
4. I
*!
*!
*l
             Uses
          Indexes
                   INP_TMPL
                   ICR_CHANGE
                   REDRAWTMPL
                   SET_RPTOUT()
                   CLR_MSGS
                   ICRHISTRY

                   ICR.DBF

                   ICRINDEX.NDX
                   ICRAGNCY.NDX
                   ICROMBAG.NDX
(procedure in NEWTEMP4.PRG)
(procedure in MENUS.PRG)
(procedure in NEWTEMP4.PRG)
(function  in RPTS.PRG)
(procedure in NEWTEMP4.PRG)
(procedure in RPTS.PRG)
                                               && MAIN MENU  Prompt array
  •ocedure menul_4_7

  •.clare menul_4_7[3]
  ;nul_4_7[l] = "1   DISPLAY AN ICR SUMMARY"
menul_4_7[2] = "2   PRINT ICR CHANGE HISTORY"
--«nul_4_7[3] = "R   RETURN TO MAIN MENU"

._47title = "**  ICR SUMMARY MENU  **»
mh!47str = "1.4.7"

  c********************** Declare MENU 1.4 Prompts  **************************

  •.clare mp_l_4_7[3]
  >_1_4_7 [ 1 ] =;
   "Display on Screen the Summary Status for an ICR  &  allow update of Comments"
  ___
    "Print  an ICR  Summary  and  the  history of  changes to the Total Inventory"
 ...p_l_4_7[3]  = "Return to  REPORTS  MENU"

  jl_4_7key = 50                          && Max INKEY Value for this menu

 ************************  Menu Selection Process Loop  ***********************

  >  while .t.

    modtemplat(mh!47str,tlcolor,null_msg,msglcolor)
    selection = menupopup2(9,22,Il,52,ml_0color,menul_4_7,ml47title,;
       mp_l_4_7,  mpl_4_7key)
    clear_body(bodycolor1)

    do case
    case selection = 1

       icr_no = 0
       modtemplat("1.4.7a",  tlcolor, null_msg, msglcolor)
       @ 10,14,16,66 box "Ei»83siEa "
       @ 12,17 say "Enter the ICR Number for the Summary Review:  "
       @ 14, 36 get icr_no pict "9999"
       read
       select 1
       use icr index icrindex.ndx,icragncy.ndx,icrombag.ndx
       seek  icr_no
       if  found()
           inp_tmpl(tlcolor,dtcolor,"!.4.7a",l)
           icr_change(icr_no)   &&  modified ICR  summary  display
           redrawtmpl(tlcolor,mhl_4str,dtcolor)

-------
       clear_body(bodycolorl)
       close  all
       loop
     endif
     @  11,15 clear to  15,65
     atinsay(12,19,  "W/R", "INVALID ENTRY - Unable  to  locate ICR # ";
       + substr(str((icr_no+10000),5,0),2,4))
     @  14,  25  say  "Strike  any  key  to continue	"
     inkey(30)

  case  selection = 2

     icr_no =  0
     modtemplat("1.4.7a",  tlcolor, null_msg, msglcolor)
     §  10,14,16,66 box "Ei»8UEa  "
     @  12,17 say "Enter the  ICR Number for the Summary Report: "
     @  14,  36  get  icr_no pict  "9999"
     read
     select 1
     use  icr index icrindex.ndx
     seek icr_no
     if found()
        sort_key = " "
        prn_status = 4
        *    @ 10,14,17,66 BOX "Ei»aJ»±E» "
        prn_status = set_rptout(l)
        if prn_status =4    && error condition in PRN setup
           clear_body(bodycolorl)
           clr_msgs()
           loop                 && repaint menu
        endif
        *   modtemplatC'l^^", tlcolor, null_msg, msglcolor)
        icrhistry(icr_no, prn_status)
        set device to screen
        set printer to
     else
        close  all
        @  11,15 clear to  15,65
        atinsay(12,19,  "W/R",  "INVALID ENTRY - Unable to  locate  ICR #  ";
           +  substr(str((icr_no+10000),5,0),2,4))
        @  14,  25  say  "Strike any  key  to  continue	"
        inkey(30)
     endif   && if  icr  found test

   case selection  = 3
     clear_body(bodycolorl)     && Clear body before  return to menu
     return
   endcase
   clear_body(bodycolorl)      && Clear body before  return  to menu
   redrawtmpl(tlcolor,mh!47str,dtcolor)

 iddo

  End of  PROC  menul_4_7

** End  of FILE menus.prg
*•, EOF: MENUS.PRG

-------
+•  Procedure file:  FORM2_AB.PRG

           System:  Paper Work Reduction Managemnt System
*:          Author:  John Pitts, Fred,  Melissa, Karen
        Copyright (c)      ,  Compex Corporation
    Last modified:  10/01/89       1:06
*:
*•
    Procs & Fncts: FORM2B
                 : CHK_FY_IN()
                 : FORM2A
        Documented 12/28/89 at 17:33                SNAP!  version  3.12e

** THIS PROGRAM INPUTS or EDITS THE EPA FORM 2B OF THE PRAMS  PROJECT.
*!
*i
Procedure

Called by


    Calls
FORM2B

MENU1_3
MENU1_1_1

CENTRING()
CLR_INBODY
CHK_FY_IN()
STOP_TST()
(procedure in MENUS.PRG)
(procedure in MENUS.PRG)

(function  in NEWTEMP4.PRG)
(procedure in NEWTEMP4.PRG)
(function  in FORM2_AB.PRG)
(function  in SF83F.PRG)
   ocedure form2b
 ...rameters purpose, _icr_numbe

   t confirm on

 select  icr

   cr_title=icr_title
 _aa_code = aa_code
  rfiv_code = div_code
   cr_cmnts=icr_cmnts

 select  icb_prof
    current_fy = year(date())
    _fiscalxl="X"
 else
    _fiscalxl="  "
   id if
 ^ current_fy = year(date())  + 1
    _fiscalx2="X"
   se
    _fiscalx2=" "
 endif
 ' ' current_fy = year(date())  + 2
    __fiscalx3="X"
 uj.se
    _fiscalx3=" "
   idif
   these will determine the filling of FY_CURRENT and FY_NEXT
  est_hoursl=orig_estl

-------
select package
 r>oc_first=poc_first
 poc_last=poc_last
_poc_mail=poc_mail
 poc_phone=poc_phone
 pkg_abstr=pkg_abstrc

set delimiters to "[]"
 3t delimiters on

w 24,0 say centring("ICR PROFILE INPUT for ORIGINAL Clearance")
"age_one = 1
 axjpgs = 2
 toptest = "C"                         && C for  CONTINUE
x = .y.

 sleet icr                             && Select work area ICR.DBF

 • ******************  Set up var  for  Current FY
 e month(date()) > 9
   fiscalyr = year(date())+l
else
   fiscalyr = year(date())
 ndif

 tr_icr=substr(str((_icr_number+10000) ,5,0) ,2,4)


 •*o while  stoptest<>"D"                  && THE MAIN LOOP

   *  @ 24,0 SAY  CENTRING("FORM 2B INPUT  FORM")

   *************************  set up  First  Page *********************************
   clr_inbody()
   set color  to  "BG+/B,GR+/B,,,RB+/B"
   @  2,0  clear to 22,79
   atinsay(0,65,'RB+/B1,  "Page " +  str (page_one, 1, 0) + " of  " +  str (max_pgs, 1, 0

   @  2,  29,  4,  51 box "UAi'UAA3  "
   @  3,  30 say  "ICR number:  " +str_icr+".00"

    @  5,  0, 9,  79 box "UAi'UAA3 "
    @  6,  1 say "ICR  Title:  (Use Arrow keys  to scroll;  Press   when done)"

    @  10,  0,  13,  79  box "UAcJUAAJ "
    @  11,  1 say "Mark X at the expected FY of request  for  original clearance:11
    @  12,  18 say "FY" + right(str(fiscalyr,4,0),2)
    @  12,  38 say "FY" + right(str(fiscalyr+1,4,0),2)
    @  12,  59 say "FY" + right(str(fiscalyr+2,4,0),2)

    @  12,24 say _fiscalxl
    @  12,44 say _fiscalx2
    @  12,65 say _fiscalx3

    @ 14, 0, 19,  79  box "UAi'UAA1 "
    @ 15, 1 say "Contact person: "
    @ 15, 30 say "First name:  "
    @ 16, 30 say " Last name:  "
    @ 17, 30 say " Mail code:  "

-------
@ 18, 30 say " Telephone: "
@ 20, 0, 22, 65 box "
@ 21, 1 say "Estimated burden hours for this ICR: "

tmp_color = setcolor()
set color to "GR+/B,G+/B, , ,RB+/B"
_icr_title = memoedit(_icr_title,7,2,8,77, .t. )
set color to &tmp_color
good_x =0     && good x initialized to false
do while  good_x = 0
   @ 12,24 get _fiscalxl pict "!"
   read
   good_x = chk_fy_in(_fiscalxl)
enddo

if _fiscalxl == " "  .or. _fiscalxl == ""
   good_x =0     && good x  initialized to false
   do while  good_x = 0
      § 12,44 get _fiscalx2  pict  "!"
      read
      good_x = chk_fy_in(_fiscalx2)
   enddo
else
   _fiscalx2 = " "
   _fiscalx3 = " "
   @  12,44 say _fiscalx2
   @  12,65 say _fiscalx3
end if

if  (_fiscalxl == "  "  .or. _fiscalxl  ==  "")  .and.;
       (_fiscalx2 == "  "  .or. _fiscalx2  == "")
   good_x =0     && good x  initialized to false
   do while  good_x =  0
      @  12,65 get _fiscalx3  pict "!"
      read
      good_x = chk_fy_in(_fiscalx3)
   enddo
else
   _fiscalx3 =  "  "
    @ 12,65  say _fiscalx3

endif

 @ 15,  43 get _poc_first
 @ 16,  43 get _poc_last
 @ 17,  43 get _poc_mail
 @ 18,  43 get _poc_phone picture "@R (NNN) 999-9999"

 @ 21,  43 get _est_hoursl picture »##########"

 read

 ************************* set up Second Page ********************************
 clr_inbody()
 @ 2,0 clear to 22,79
 atinsay(0,65,'RB+/B1,"Page  "+str(page_one+l,1,0)  +  " of  "  +  str(max_pgs,1,0))

-------
  @ 2,  15,  4,  65 box  "UAi'UAA1  "
  @ 3,  22  say  "AA Code:        "
  @ 3,  40  say  "Division Code:      "

  @ 5,  0,  14,  79 box  "UAc'UAA1  "
  @ 6,  2   say  "Abstract:  (Use  Arrow  keys  to  Scroll;  Press  when done.)11

  @ 15,  0,  22,  79 box "UAi'UAA1  "
  @ 16,  2  say  "ICR  Comments:  (Use  Arrow keys to Scroll;  Press  when don

  @ 3,  31  get  _aa_code pict  "NNN"
  § 3,  55  get  _div_code pict "##"
  read
  tmp_color =  setcolor()
  set color to "GR+/B,G+/B,,,RB+/B"
  _pkg_abstr=memoedit(_pkg_abstr,7,3,13,77,.t.)
  set color to &tmp_color

  tmp_color =  setcolorQ
  set color to "GR+/B,G+/B,,,RB+/B"
  _icr_cmnts=memoedit(_icr_cmnts,17,3,21,77,.t.)
  set color to &tmp_color

  ****************   End of FORM 2B Input Screens  ****************************


  stoptest = stop_tst()
  if stoptest="E"
     if purpose=0
        clr_inbody()
        @  7,20,12,60 box "Ei»°UEfl  "
        @  9,28 say "Adjusting record  indexes"
        @10, 28 say "One moment please	"
        delete       && Select  (icr.dbf)  has been done already
        select icb_prof
        delete
        select package
        delete
        pack
        select icb_prof
        pack
        select icr
        pack
      endif
      *  in the case of editing record  is  abandoned,  not  deleted.
      set  delimiters  off
      return
  endif

  iddo       && end  of main  loop


   if this 2b  form  entry  was not abandoned  in the stoptest program,
  the following  replacements  pass the temporary
** variables into the real  field names of the appropriate databases.


_jlect icr
replace icr_number with  _icr_number

-------
  place icr_title with _icr_title
replace aa_code with _aa_code
-"place div_code with _div_code
  place pending with .t.
  make pending field be editable
replace icr_cmnts with _icr_cmnts
select icb_prof
  place icr_number with _icr_number
   case
uase upper (_fiscalxl)="X"
   replace current_fy with fiscalyr
   replace next_fy with (fiscalyr+1)
 _se upper(_fiscalx2)="X"
   replace current_fy with (fiscalyr+1)
   replace next_fy with fiscalyr+2
  se upper(_fiscalx3)="X"
   replace current_fy with (fiscalyr+2)
   replace next_fy with (fiscalyr+3)
  dcase

r-pplace orig_estl with _est_hoursl

  lect package
replace icr_number with _icr_numbe
  place pkg_number with 0
  place poc_first with _poc_first
replace poc_last with _poc_last
 --place pocjnail with _poc_mail
  place poc_phone with _poc_phone
~-place pkg_abstrc with _pkg_abstr
  lect 1
*  (selected for "aesthetic purposes")
  set delimiters off
  turn

**  End of PROC form2b
* i
*!
 Function: CHK_FY_IN()

Called by: FORM2B

    Calls: CENTRING()
(procedure in FORM2_AB.PRG)

(function  in NEWTEMP4.PRG)
function chk_fy_in
  irameters response

if response == " " .or. response
   return(1)
  .se
   tone(440,3)
   tone(440,3)
                         == "X"   .or.  response  ==  ""

-------
   tmp_color =  setcolor()
   set color to "W/R,W/R,,,W/R"
   @ 24,0  say centring("Invalid Input -  Enter Either a space or ")
   inkey(lO)
   set color to &tmp_color
   @ 24,0  say centring("FORM 2B INPUT FORM")
   set color to "BG+/B,GR+/B,,,RB+/B"
   return(0)
endif

 * End of  FUNG  chk_fy_in
 * End of FILE FORM_2B.PRG

 *********************  PROCEDURE:  FORM2A  *********************************
                        DESCRIPTION:  An input form utilizing 3 databases   *
*                       from the PRAMS project for the purpose of adding or*
                        editing an EPA form 2A; the Information Collection *
                        Budjet "Profile Sheet".                             *
        Procedure: FORM2A

        Called by: MENU1_3         (procedure  in MENUS.PRG)

            Calls: CENTRING()      (function   in NEWTEMP4.PRG)
                 : CLR_INBODY      (procedure  in NEWTEMP4.PRG)
                 : STOP_TST()      (function   in SF83F.PRG)
                 : CLR_MSGS        (procedure  in NEWTEMP4.PRG)

    ********************************************************************
 procedure form2a
  arameters purpose, _icr_numbe

 *** create memvar duplicates for all  fields
 -rivate micr_title, mpoc_first,  mpoc_last, mpoc_phone,  mcur_omb_no
  rivate mexp_date, msum_rpt_hr,  mest_hoursl,  madj_hoursl,  mprg_changl
 ^rivate mest_hours2,  madj_hours2,  mprg_chang2, mest_total,  micb_reason
 orivate mreason_l, mreason_2,  mreason_3,  mreason_4,  mreasonS
  irivate mreason_6, mreason,  mreason_icr

 ***   _icr_numbe=  (is received from outside.)
  **   _pkg_numbe=0

 select icr
 m.cur_omb_no  = cur_omb_no
  iexp_date =  exp_date
 .iicr_title =icr_title
 msum_rpt_hr  =sum_rpt_hr
  ;elect package
 mpoc_first = poc_first
  ipoc_last = poc_last
  \poc_phone =poc_phone

 select icb_prof

-------
                              &&  Will be  0  if  no  Form 2B submitted
                              &&  Total Estimate as of 9/10/thisFY
                              &&  All adjustments  thisFY
                              &&  All PRg  changes  thisFY
                              &&  Should be  same as EST_TOTAL1
                              &&  Propose  adjustment nextFY
                              &&  Proposed Prg_Change nextFY
                               && Total Estimate  nextFY
 •eason_icr
 •easonl
  ' purpose = 0
   append blank
  idif
  »rig_estl = orig_estl
,uest_totll = est_totall
madj_hoursl = adj_hoursl
  >rg_changl = prg_changl
  •st_hours2 = est_hours2
madj_hours2 = adj_hours2
  >rg_chang2 = prg_chang2
  >st_totl2  =  est_tota!2
micb_reason = icb_reason
            = reason_icr
            reason_l
       _    reason_2
mreason_3 = reason_3
  eason_4 = reason_4
  •eason_5 = reason_5
mreason_6 = reason_6
  •eason = " "
max_pgs = 1
-nge_one = 1
  24,0 say centring("FORM 2A - ICB PROFILE SHEET INPUT")
_J month(date())  > 9
   fyl = year(date())+l
   fy2 = fyl + 1
  .se
   fyl = year(date())
   fy2 = fyl + 1
  idif
stop_test="C"

  > while stop_test<>"D"
                                          &&  "C"  means continue

                                          &&  DO UNTIL USER SELECTS  "DONE"
   clr_inbody()
   set color to "BG+/B,GR+/13. , ,RB+/B"
   * @ 2,0 CLEAR TO 22,79
   atinsay(0,65,'RB+/B1, "Page  " +  str(page_one,1, 0)  + "  of " + str(max_pgs,1,0
    @  15, 0, 22, 80 box "UA£JUAA3  "
    @  16, 2 say "(i) Reason  for  adjustment or program change: (CTRL-W to exit)"
    @  20, 2 say "(j) If this ICR should not be on  "+str(fy2,4,0) + ;
       " budget, mark  T   on reason  number(s):"
    @  7, 0, 15, 80 box "UAi'UAA3  "
    @  8, 3 say "FISCAL YEAR  "+str (fyl, 4,0)+space(26)+"FISCAL YEAR "+ str(fy2,4,0)
    @  9, 4 say "ICB original est.:"+space(27)+"Burden hours:"
    @  11, 10 say "Adjustments:"+space(28)+"Adjustments:"
    @  12, 6 say "Program  Changes:"+space(24)+"Program Changes:"
    @  14, 7 say "Total Estimate: "+space(24)+  "Total Estimate:"
    @  2, 0, 7, 80 box "UA£3UAA3  "
    @  3, 3 say "ICR Number:  "+space(12)+?
       "Current OMB #: "+space(14)+"Expires on:  "
    @  4, 3 say "Title: "
    @  5, 3 say "Contact:  "
    @  6, 3 say "Phone #:  "
    @  6, 44 say "OMB Approved  Hours: "
    ***************  Change  colors and put in  old data read  only  **************

-------
temp_color = setcolor()
set color to "RB+/B,RB+/B,,,RB+/B"
@ 3,15 say substr(str((_icr_numbe+10000),5,0),2,4)
@ 3,42 say icr->cur_omb_no pict "@R ####-####"
@ 3,68 say icr->exp_date pict "@D"
§ 4, 10 say memoline(icr->icr_title,66,l)
@ 5, 12 say trim(package->poc_first)+» »+ trim(package->poc last)
@ 6, 12 say package->poc_phone pict "@R (NNN) 999-999"     ~
@ 6, 63 say icr->sum_rpt_hrs picture "@B"
set color to &temp_color

*** get input fields into memvar duplicates
*mICR_TITLE=memoedit(mICR_TITLE,4,16,4,78,.T.,"")
*@ 5, 16 GET mPOC_FIRST
*@ 5, 28 GET mPOC_LAST
*@ 5, 63 GET mPOC_PHONE PICTURE '9999999999'
*@ 3, 42 GET mCUR_OMB_NO PICTURE '99999999'
*@ 3, 63 GET mEXP_DATE VALID Chk_date(mEXP_DATE)
*@ 6, 63 GET mSUM_RPT_HR PICTURE '9999999999'
@ 9, 25 get morig_estl picture '9999999999'
@ 11, 25 get madj_hoursl picture '9999999999'
@ 12, 25 get raprg_changl picture '9999999999'
@ 14, 25 get mest_totll
mest_hours2 = mest_totll
@ 9, 63 get mest_hours2 picture '9999999999'
@ 11, 63 get madj_hours2 picture '9999999999'
@ 12, 63 get mprg_chang2 picture '9999999999'
@ 14, 63 get mest_tot!2 picture '9999999999'
read
micb_reason=memoedit(micb_reason,17,6,19,78,.t.,"")
mreaslogic=.f.
@ 21,  6 say "   1."  get mreason_l
@ 21, 16 say "   2."  get mreason_2
@ 21, 26 say "   3."  get mreason_3
@ 21, 36 say "   4."  get mreason_4
@ 21, 46 say "   5."  get mreason_5
@ 21, 56 say "   6."  get mreaslogic

read

if mreason_4
   @ 21, 6 say "Enter the ICR# to which this ICR  is related:
      get mreason_icr  picture '9999'
   read
endif

if  mreaslogic
   @ 21, 6 say "Enter other reason: " get mreason 6
   read
endif
read

stop_test = stop_tst()

if stop_test == "E"
   if purpose = 0
      select icb_prof

-------
         delete
         pack
      endif
      * in the case of editing,  record is only abandoned, not deleted.
      return
   endif
   clrjmsgs()
enddo
                                                   && END OF MAIN  LOOP
*SELECT ICR
REPLACE ICRJTITLE WITH mICR_TITLE
 REPLACE CUR_OMB_NO WITH mCUR_OMB_NO
 REPLACE EXP_DATE WITH mEXP_DATE
* REPLACE SUM_RPT_HR WITH mSUM_RPT_HR

 SELECT PACKAGE
*REPLACE POC_FIRST WITH mPOC_FIRST
 REPLACE POC_LAST WITH mPOC_LAST
 REPLACE POC PHONE WITH mPOC PHONE
 alect
.aplace
replace
 Bplace
 aplace
replace
 aplace
 splace
replace
i-eplace
 Bplace
 splace
replace
 aplace
 Bplace
replace
-aplace

^eturn
icb_prof
 orig_estl with morig_estl
 est_totall with mest_totll
 adj_hoursl with madj_hoursl
 prg_changl with mprg_changl
 est_hours2 with mest_hours2
 adj_hours2 with madj_hours2
 prg_chang2 with mprg_chang2
 est_tota!2  with mest_tot!2
 icb_reason with micb_reason
 reason_icr with mreason_icr
 reason_l with mreason_l
 reason_2 with mreason_2
 reason_3 with mreason_3
 reason_4 with mreason_4
 reason_5 with mreason_5
 reason 6 with mreason 6
 * End of PROC form2a

** End of FILE FORM_2A.PRG
 : EOF: FORM2 AB.PRG

-------
  Procedure file: SF83F.PRG

          System: Paper Work Reduction Managemnt  System
          Author: John Pitts, Fred, Melissa, Karen
       Copyright  (c)      , Compex Corporation
   Last modified: 11/16/89     11:14
Procs & Fncts:
                  SF83
                  VLDATEO
                  UP_TON
                  DOWN_TON
                  STOP_TST()
                  CHK_DATE()
                  V_MAILCODE()
        Documented  12/28/89  at  17:33
                                                SNAP!  version  3.12e
-* THIS  "PROCEDURE"  ACCEPTS ALL THE  DATA FOUND ON
** GOVERNMENT FORM CALLED SF_83.
 * MOST  OF THE DATA  IS STORED IN PACKAGE.DBF
 << IT SHOULD BE ENTERED EITHER WITH  A RECORD FOUND,
** OR A  BLANK APPENDED DEPENDING ON  USER'S earlier choice.
• i
 i
 i
*!
 i
 i
*!
 i
 i
  I
* !
  i
  i
*!
  ;
  i
    Procedure  SF83
    Called by
        Calls
          Uses
       Indexes
MENU1_1
MENU1_1_1

CLR_MSGS
V_MAILCODE()
VLDATE()
CHK_DATE()
STOP_TST()
CLR_INBODY
GET_PKGTE

TRACKING.DBF

TRAKICR.NDX
TRAKPKG.NDX
TRAKDATE.NDX
(procedure in MENUS.PRG)
(procedure in MENUS.PRG)
(procedure
(function
(function
(function
(function
(procedure
(procedure
in NEWTEMP4.PRG)
in SF83F.PRG)
in SF83F.PRG)
in SF83F.PRG)
in SF83F.PRG)
in NEWTEMP4.PRG)
in CHECKTES.PRG)
  rocedure sf83
 .arameters purpose, _icr_numbe, _pkg_numbe
 public _aa_code, _div_code

  et delimiters to  "[]«
 set delimiters on
 -et confirm on

 Delect package
 * _pkg_numbe  already  defined

-------
  _icr_numbe already defined
_ttl_rechr=ttl_rechrs
 ttl_hour=ttl_hours
 ttl_respo=ttl_respon
_adj ustmen=adj ustment
 pgm_chang=pgm_change
 tab_diffe=tab_differ
_2ur_omb_i=cur_omb_in
_req_burde=req_burden
 rec_reten=rec_retent
 tir_per_kp=hr_per_kpr
_no_rec_kp=no_rec_kpr
 hr_per_rs=hr_per_rsp
 per_rspon=per_rspond
_no_respdn=no_respdnt
 stat_fla=stat_flag
 ed_fla=ed_flag
_req_x_dat=req_x_date
_review_ty=review_typ
 fr_dat=fr_date
 aolect_ty=colect_typ
_pkg_abstr=pkg_abstrc
 other_aut=other_auth
 usc_chapt=usc_chaptr
_usc_titl=usc_title
 affectpu7=affectpub7
 affectpu6=affectpub6
 a ffectpu5=a f fectpubS
_a f fectpu4=a f fectpub4
 affectpu3=affectpub3
 affectpu2=affectpub2
_a ffectpul=a f fectpubl
 poc_phon=poc_phone
 poc_firs=poc_first
_poc_las=poc_last
jpoc_mai=poc_mai1
 pkg_titl=pkg_title
 =ur_omb_n=cur_omb_no
_obligatio=obligation
 freq_r_l=freg_rr_l
 freq_r_2=freq_rr_2
_freq_r_3=freq_rr_3
 freq_r_4=freq_rr_4
 freq_r_5=freq_rr_5
_freq_r_6=freq_rr_6
_freq_r_7=freq_rr_7
 freq_r_8=freq_rr_8
 freq_r_9=freq_rr_9
_freq_dscr=freq_dscrp
 purpos_l=purpose_l
 pu rp o s_2=pu rp o s e_2
_purpos_3=purpose_3
 purpos_4 =purpose_4
 purpos_5=purpose_5
 purpos_6=purpose_6
_purpos_7=purpose_7
 stat_cmnt = stat_cmnts
 gen_cmnts = gen_comnts
_agencynam = dabo_name
 dos inits = do initals

-------
select icr
' ? purpose # 0 .and. _pkg_numbe
   seek  icrnumbe
 agencycod = agency
  cr_cmnts = icr_cmnts
_ cr_ombno = cur_omb_no
if empty (_poc_mai)
   _aa_code = "   "
   _div_code = 0
else
   _aa_code = aa_code
    divcode = div_code
  t************************  set up  local Variables   *************************

max_pgs = 4
  ige_one = 1
  .optest="C"          && C ->  "CONTINUE"
oid_color = setcolor()
-^.r^c^no =  substr(str( (_icr_number+10000) ,5,0) ,2,4)
  :r_pkg_no =  substr (str ( (_pkg_numbe+100) ,3,0) ,2,2)


  > while stoptesto"D"   && D  ->  "DONE"
   clr_msgs()
   *************************  Set  up First  Page *********************************
   set color  to "BG+/B,GR+/B» , ,RB+/B"
   @  2,0 clear to 22,79
   atinsay(0,65, 'RB+/B1 ,  "Page "  +   str(page_one, 1, 0)  + " of " + str(max_pgs, 1, 0

   @  2,  0,  4,  16 box "UAi'UAA3  "
   @  3,  2  say "ICR #:"+str_icr_no+"."+str_pkg_no
   @  2,  17,  4, 48 box "UAe'UAA3  "
   @  3,  19  say "AA Code:        DIV  Code:    "
   @  3,  28  say _aa_code
   @  3,  44  say _div_code pict "99"
   @  2,  49,  4, 79 box "UAi3 UAA1  "
   @  3,  51 say "Desk Officer Initials     "
   @  5,  0,  8, 56 box "UAi'UAA3  "
   @  6,  2  say "1. Department/ Agency/ Bureau: (Press Ctrl-W when done)"
    @  5,  59,  8, 79 box "UA£3 UAA1  "
    @  6,  61 say "2. Agency Code:"
    @  7,60  say space (9)
    @  9, 0,  13, 79 box "UAi'UAA3  "
    @  10,  2 say "3. Name of person who can answer questions concerning  this  reque
    @  11,  5 say "First Name"+space(21)+"      Mail Code"
    @  12,  5 say "Last Namell+space(28)+"Telephone"
    @  14,  0, 17, 79 box "UAi'UAA1  "
    @  15,  2 say "4. Title:  (Arrow keys to scroll, CTRL-W to  exit)"
    @  18,  0, 22, 79 box "UAc'UAA3  "
    @  19,  2 say "5.  Legal authority  for information  collection  or rule: (site U.S
    @  20, 2 say "    law, or executive order)"
    @ 21, 2 say "        USC:"+space(32)+"or"

    @ 3,74 get _dos_inits pict "AA"
    read

-------
tmp_color = setcolorQ
set color to "GR+/B,RB+/B,,,RB+/B"
_agencynam = memoedit(_agencynam,7,3,7,54)
set color to &tmp_color

§ 7, 64 get _agencycod
§ 11, 17 get _poc_firs
@ 12, 17 get _poc_las
@ 11, 53 get _poc_mai pict "@!" valid v_mailcode(_poc_mai)
§ 12, 53 get _poc_phon picture '§R  (NNN) 999-9999'
read

tmp_color = setcolor()
set color to "GR+/B,RB+/B,,,RB+/B"
_pkg_titl = memoedit(_pkg_titl,16,6,16,76)
set color to &tmp_color

@ 21, 5 get _usc_titl picture  '99'
@ 21, 23 get _usc_chapt
@ 21, 53 get _other_aut

read

********************************* beginning of second page ******************
@ 2,0 clear to  22,79
atinsay(0,65,'RB+/B1,  "Page  "+str(page_one+l,1,0)+ " of " + str(max_pgs,1,0))

@ 2, 0,  6, 79 box "UAi'UAA3  "
@ 3, 2  say "6.  Affected  Public:  (X  all  that apply)         Federal Agencies/e
@ 4, 5  say "Individuals/households        Farms          Non-profit institutio
@ 5, 5  say "State/local  government        Businesses     Small Business/Organi
 @ 7,  0,  17,  79 box "UAi'UAA1  "
 @ 8,  2 say "13.  Abstract:  (Arrow keys to scroll, CTRL-W when finished.)"
 @ 18,  0,  21,  39 box "UAt'UAA3  "
 i 19,  2 say "14. Type of information collection:"
 @ 20,  6 say "(Enter number from  SF 83)"
 @ 18,  40,  21, 79 box "UAi3UAA1  "
 @ 19,  42 say "15. Type of review requested:"
 @ 20,  46 say "(Enter selection from SF 83)"

 @ 4,  2 get _affectpul pict "!" valid vldate(0,_affectpul)
 @ 5,  2 get _affectpu2 pict "!" valid vldate(0,_affectpu2)
 @ 4, 31 get _affectpu3 pict
 §5, 31 get _affectpu4 pict
 @ 3, 46 get _affectpu5 pict
 @ 4, 46 get _affectpu6 pict
 @ 5, 46 get _affectpu7 pict
  valid vldate(0,_affectpu3)
11 valid vldate(0,_affectpu4)
" valid vldate(0,_affectpu5)
11 valid vldate(0,_affectpu6)
11 valid vldate(0,_affectpu7)
 read
 tmp_color = setcolor()
 set color to "GR+/B,RB+/B,,,RB+/B"
 _pkg_abstr = memoedit(_pkg_abstr,9,2,16,77)
 set color to &tmp_color
 @ 20, 35 get _colect_ty picture  '!'  valid vldate(l,_colect_ty)
 @ 20, 76 get _review_ty picture  '9'  valid vldate(2,_review_ty)

 read

 ********************************** beginning  of  third  page *************
 @ 2,0 clear to  22,79

-------
atinsay(0,65,'RBVB', "Page "+str(page_one+2, 1,0)+ » of '• + str(max_pgs,l,0))

@ 2,  0,  8,  51 box "J  333A33  "
@ 2,  2 say  "17.  Annual Reporting/disclosure burden:"
@ 3,  2 say  "Number of respondents"
@ 4,  2 say  "Number responses per respndt."
§ 5,  2 say  "Total annual responses"
§ 6,  2 say  "Hours per response"
8 7,  2 say  "Total hours"
@ 11,  52, 22, 79 box "UA£3UAA3  "
@ 12,  53 say "23. Frequency:"
@ 13,  58 say "Recordkeeping"
@ 14,  58 say "On occasion"
@ 15,  58 say "Weekly"
@ 16,  58 say "Monthly"
@ 17,  58 say "Quarterly"
@ 18,  58 say "Semi-annually"
§19,  58 say "Annually"
@ 20,  58 say "Biennially"
@ 21,  58 say "Other:"
@ 2,  52, 11, 79  box "' 3J 'AA3 "
§ 2,  53  say "21. Expires: "
§ 3,  53  say "22. Purpose: "
@ 4,  58  say "Benefits"
@ 5,  58  say "Program Evaluation"
@ 6,  58  say "Statistics"
@ 7,  58  say "Regulatory/compliance"
@ 8,  58  say "Program planning/mgt"
@ 9,  58  say "Research"
@ 10,  58 say "Audit"
§8,  0,  14,  51 box "AA'33A1J "
@ 9,  2 say  "18.  Annual Recordkeeping Burden:"
§ 10,  2  say "No. of record keepers"
§ 11,  2  say "Hours per record keeper"
@ 12,  2  say "Total hours"
@ 13,  2  say "Retention period (in years)"
@ 14,  0, 19, 51  box "AA'3  33 "
@ 15,  2  say "19. Total Annual Burden:"
@ 16,  2  say "Requested"
9 17,  2  say "In  current OMB inventory"
@ 18,  2  say "Difference  (requested-current)"
@ 19,  0, 22, 51  box "3 33UAA3 "
*@ 20, 2 SAY "20. Explanation  Program Change"
*@ 21, 2 SAY "of difference:   Adjustment"
*§ 20,0,22,51 BOX "   3UAA3  "
@ 19,0 say  "A"+replicate("A",l5)
@ 19,16  say "i"
@ 20,16  say •»••+»  Program Change:"
@ 21,16  say "3"+"     Adjustments:"
@ 22,16  say "A"
@ 20,2 say  "20.  OMB #:"
@ 21,  4  say _icr_ombno picture  "@R 9999-9999"

@ 3,  40  get _no_respdn picture  "@ 99999999"
@ 4,  44  get _per_rspon picture  "@ 9999"
@ 5,  40  get _ttl_respo picture  "@ 99999999"
@ 6,  41  get _hr_per_rs picture  "@ 9999.99"
@ 7,  39  get _ttl_hour picture "@ 999999999"
@ 10,  42 get _no_rec_kp picture "@ 999999"
@ 11,  42 get _hr_per_kp picture "@ 999.99"

-------
@ 12, 35 get _ttl_rechr picture "? 9999999999.99"
@ 13, 46 get _rec_reten picture "@ 99"
@ 16, 35 get _req_burde picture "@ 9999999999999"
@ 17, 35 get _cur_omb_i picture "§ 9999999999999"
@ 18, 35 get _tab_diffe picture "§ 9999999999999"
@ 20, 35 get _pgm_chang picture "@ 9999999999999"
@ 21, 35 get _adjustmen picture "@ 9999999999999"
@ 21,4 get _cur_oab_n picture "@R 9999-9999"
@ 2, 66 get _req_x_dat valid chk_date(_req_x_dat)
*if dtoc(_req_x_dat)="  /  /  "
*    _REQ_X_DAT=date() +10 9 5
* 1095 if three years expressed in days
* which is the default expiration criteria
*endif
@ 4, 54 get _purpos_l pict
@ 5, 54 get _purpos_2 pict
@ 6, 54 get _purpos_3 pict
@ 7, 54 get _purpos_4 pict
@ 8, 54 get _purpos_5 pict
valid vldate(0,_purpos_l)
valid vldate(0,_purpos_2)
valid vldate(0,_purpos_3)
valid vldate(0,_purpos_4)
valid vldate(0,_purpos_5)
  9, 54 get _purpos_6 pict "!" valid vldate(0,_purpos_6)
  1 H  Ci A M A^  mti»i^Aa "7 i^ 1 <-»4- II II ira 1 i /4 *r1/4a^A/n  rMi>«r%/^e 1
  10, 54 get _purpos_7 pict
 @ 13, 54 get _freq_r_l pict
 @ 14, 54 get _freq_r_2 pict
 @ 15, 54 get _freq_r_3 pict
 @ 16, 54 get _freq_r_4 pict
 @ 17, 54 get _freq_r_5 pict
 @ 18, 54 get _freq_r_6 pict
 @ 19, 54 get _freq_r_7 pict
 @ 20, 54 get _freq_r_8 pict
 @ 21, 54 get _freq_r_9 pict
 read
 valid vldate(0,_purpos_7)
 valid vldate(0,_freq_r_l)
 valid vldate(0,_freq_r_3)
 valid vldate(0,_freq_r_4)
 valid vldate(0,_freq_r_5)
 valid vldate(0,_freq_r_7)
 valid vldate(0,_freq_r_7)
 valid vldate(0,_freq_r_7)
 valid vldate(0,_freq_r_8)
 valid vldate(0,_freq_r_9)
 if _freq_r_9 ==  "X"
    @  18,27,21,78 box "UAi3UAA1  "
    @  19,30  say " Enter description  for  Frequency Other below:"
    *  §  20,34 SAY "[" + SPACE(27)  +  "]"
    @  20,37  get _freq_dscr
 end if

 read

 **************************** beginning  of  fourth page *******************
 @ 2,0 clear to 22,79
 atinsay(0,65,'RB+/B1, "Page "+str(page_one+3,1,0)+ " of " + str(max_pgs,l,0))

 @ 2,  0, 4,  79 box  "UAi3UAA1  "
 @ 3,  2 say "24.  Respondents obligation  to  comply: (Enter number from SF-83)"
 @ 5,  0, 8,  79 box  "UAc.'UAA1  "
 @ 6,  2 say "25.  Are the respondents primarily educational agencies/institutio
 @ 7,  6 say "primary purpose related to  federal educations programs?  (Y/N): "
 @ 9,  0, 15, 79 box "UAi1 UAA3 "
 @ 10, 2 say "26. Does the ICR have sampling/statistical requirements?  (Y/N)  :
 @ 11, 2 say "     Enter Statistician's Comments:   (Press  when done)"
 @ 16, 0, 22, 79  box "UAt3UAA3 "
 @ 17, 2 say "Package Comments: (Arrow keys to scroll; Press  when  don

 *** get input fields into memvar duplicates

 @ 3,  73 get _obligatio picture '9' valid vldate(3,_obligatio)

-------
  @  7,  73  get _ed_fla picture "Y"
  @  10,  73 get _stat_fla picture "Y"
  read

  tmp_color = setcolorQ
  set color to "GR+/B,RB+/B, , ,RB+/B"

  _stat_cmnt = memoedit(_stat_cmnt,12,2,14,77,.t.)
  _gen_cmnts = memoedit(_gen_cmnts,18,2,20,77,.t.)

  set color to &tmp_color


  *************  All READS Complete - Check to Review/Add/Abort  **************

  stoptest = stop_tst()
  clrjnsgs ()

  if stoptest == "E"
     *  fix bug here to convert icr_numbe and pkg_numbe back into numbersW
     _aa_code = "   "
     _div_code = 0
     if purpose = 0 .and.  _pkg_numbe = 1  && Both ICR & PKG appended
        clr_inbody()
        @ 7,20,12,60 box "E±»B^±EB  "
        @ 9,28 say "Adjusting record indexes"
        @10,28 say "One moment please	"
        select icr
        delete
        select package
        delete
        pack
        select icr
        pack
     end if
     if (purpose = 0 .and. _pkg_numbe >  1)  .or.  ;   && Only PKG appended
        (purpose = 1 .and. _pkg_numbe =  1)
        clr_inbody()
        @ 7,20,12,60 box  "E±»aUE"  "
        @ 9,28 say  "Adjusting record indexes"
        @10,28 say  "One moment  please	"
        select package
        delete
        pack
     end if
     **** purpose =  1  & pkg  # > 1 -> a  simple  edit, so  just abandon changes
     return

  endif

  iddo  &&  End of  Main Do Loop
  loop  is  exitable when the stoptest parameter="D"
* below is ignored when stoptest="E" or  stoptest="R"

  r***********  Prompt for  addition of comments to ICR Summary  **************
ddd_cmnt = " "
"ive screen
  10,14,16,66 box "Ei»8^±EB "
. 12,18 say "Do you want  to add comments to the ICR Summary ?"
§ 14,33 say "Enter (Y/N)  "

-------
  24,0 say centring;
   ("Package comments will not be reflected at the Summary level")
" 14,  45 get add_cmnt pict "!" valid (add_cmnt = "Y" .or. ;
   add_cmnt = "N")
.jad
if add_cmnt == "Y"
   select icr
   clr_msgs()
   @ 3,3,15,76 box "UAe'UAA1  "
   @ 4,5 say ;
      "UPDATE ICR COMMENTS: (Arrow keys scroll; Press  when  done)11
   tmp_color = setcolorQ
   set color to "GR+/B,RB+/B,,,RB+/B"
   _icr_cmnts = memoedit(_icr_cmnts,5,5,14,74,.t.)
   set color to &tmp_color
endif
  •store screen

***********************  NOW update the record  *****************************

  .r_inbody()
«> 7,20,12,60 box "t±»a%iE* "
fl 9,28 say "Adjusting record indexes"
  .0,28 say "One moment please	"

select package

  jplace ttl_rechrs with _ttl_rechr
replace ttl_hours with _ttl_hour
  iplace ttl_respon with _ttl_respo
  iplace adjustment with _adjustmen
j-eplace pgm_change with _pgm_chang
replace tab_differ with _tab_diffe
  splace cur_omb_in with _cur_omb_in
  iplace req_burden with _req_burde
replace rec_retent with _rec_reten
  iplace hr_per_kpr with _hr_per_kp
  iplace no_rec_kpr with _no_rec_kp
replace hr_per_rsp with _hr_per_rs
—jplace per_rspond with _per_rspon
  jplace no_respdnt with _no_respdn
.^place stat_flag with _stat_fla
replace ed_flag with _ed_fla
  jplace req_x_date with _req_x_dat
  jplace review_typ with _review_ty
replace fr_date with _fr_dat
  jplace colect_typ with _colect_ty
  jplace pkg_abstrc with _pkg_abstr
replace other_auth with _other_aut
'"splace usc_chaptr with _usc_chapt
  jplace usc_title with _usc_titl

replace affectpub? with _affectpu7
  eplace affectpube with _affectpu6
  aplace affectpubS with _affectpu5
 replace affectpub4 with _affectpu4
 "aplace affectpubS with _affectpu3
  aplace affectpub2 with _affectpu2
 splace affectpubl with _affectpul
 replace poc_phone with _poc_phon

-------
 splace poc_first with _poc_firs
replace poc_last with _poc_las
 splace poc_mail with _poc_mai
 splace pkg_title with _pkg_titl
replace cur_omb_no with _cur_omb_n
^eplace obligation with _obligatio
 splace freq_rr_l with _freq_r_l
_splace freq_rr_2 with _freq_r_2
replace freq_rr_3 with _freq_r_3
 splace freq_rr_4 with _freq_r_4
 splace freq_rr_5 with _freq_r_5
replace freq_rr_6 with _freq_r_6
 splace freq_rr_7 with _freq_r_7
 splace freq_rr_8 with _freq_r_8
..eplace freq_rr_9 with _freq_r_9
replace freq_dscrp with _freq_dscr
 splace purpose_l with _purpos_l
 splace purpose_2 with _purpos_2
replace purpose_3 with _purpos_3
 splace purpose_4 with _purpos_4
 splace purpose_5 with _purpos_5
replace purpose_6 with _purpos_6
-splace purpose_7 with _purpos_7
 splace stat_cmnts with _stat_cmnt
.splace gen_comnts with _gen_cmnts
replace dabo_name with _agencynam
 splace do_initals with _dos_inits

replace icr_number with _icr_numbe
 splace pkg_number with _pkg_numbe

Delect icr
if purpose = 0 .and. _pkg_numbe = 1
   replace icr_number with  icr numbe
 ndif
replace icr_title with _pkg_titl
 eplace agency with _agencycod
 eplace dabo_name with _agencynam
replace init_date with date()
 eplace pending with .f.
 eplace icr_cmnts with _icr_cmnts
^eplace aa_code with _aa_code
replace div_code with _div_code

 f purpose = 0 .or. (purpose = l .and. _pkg_numbe =  1)
   save screen
   select 3
   use tracking index trakicr.ndx,trakpkg.ndx,trakdate.ndx
   str_all_no = substr(str((_icr_numbe+10000),5,0),2,4)+"."
      +substr(str((_pkg_numbe+100),3,0),2,2)
   get_pkgte(_icr_numbe, _pkg_numbe,  str_all_no, 0)
   restore screen
endif
 aa_code = "   "
 div_code = 0
return

 * End of PROC sf83

-------
 t***********************************************

        *******************

         Function: VLDATE()

        Called by: SF83           (procedure in SF83F.PRG)

            Calls: DOWNJTON       (procedure in SF83F.PRG)
                 : CLR_MSGS       (procedure in NEWTEMP4.PRG)

*
"anction vldate
 irameters which_get,  value
^0  case
r-ase which_get =0   && for all "X"-box inputs
   if value =="X" .or. value = " "
      return(.t.)
   else
      do down_ton
      atinsay( 24,14,"W/R", ;
         "Invalid Selection - VALID selections are  or blank")
      inkey(lO)
      clr_msgs()
      return  (.f.)
   endif
 ise which_get =1   && for sf-83 collection type  (#14)
   if value $  "12345AB"
      return(.t.)
   else
      do down_ton
      atinsay( 24,2,"W/R",  ;
         "Invalid Selection - VALID selections are <1>,  <2>,  <3>,  <4>,  <5>, ,
      inkey(lO)
      clr_rasgs()
      return  (.f.)
   endif
 ase which_get =2    && for sf-83 review type  (#15)
   if value  <  6  .and.  value >  0
      return(.t.)
   else
      do down_ton
      atinsay( 24,8,"W/R", ;
          "Invalid Selection  -  VALID selections  are <1>,  <2>,  <3>,  <4>,  <5>")
       inkey(lO)
       clr_msgs()
       return (.f.)
   endif
 case  which_get =3    &&  for sf-83  obligation (#24)
    if value < 4  .and.  value >  0
       return(.t.)
    else
       do down_ton
       atinsay( 24,13,"W/R",  ;
          "Invalid Selection -  VALID selections are <1>,  <2>, <3>")
       inkey(lO)
       clr_msgs()
       return  (.f.)
    endif
 °ndcase

-------
** End of Function vldate

:  *****************************************************

+1

        Procedure: UP_TON
*!

]  ocedure up_ton
tone(0250,01)
f  ne(0275,01)
i  ne(0300,03)
,. »turn
 *!
Procedure:  DOWN_TON

Called by:  ICR_CHANGE
         :  VLDATE()
(procedure  in MENUS.PRG)
(function  in SF83F.PRG)
 orocedure down_ton
   ne(0300,01)
   ne(0275,01)
 tone(0250,03)
   turn

 »« End of ton PROCs

   *******************************************************
          Function

         Called by
 *!
             Calls
 *!
           STOP_TST()

           ADDUSER2
           FORM2B
           FORM2A
           SF83
           ICWINPUT
           OMB_PKG_RS
           OMBICW

           CLR MSGS
   inction stop_tst

 public access_lev

   ip_color = setcolor()
 set color to   "B/W,B/W,,,W/B"
   jsponse = "R"
   me(440,3)
 cone(440,3)
 13  24, 0 say  ;
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
(procedure
in MENUS.PRG)
in FORM2_AB.PRG)
in FORM2_AB.PRG)
in SF83F.PRG)
in ICW_INPT.PRG)
in OMBRESP.PRG)
in OMBRESP.PRG)
 (procedure in NEWTEMP4.PRG)

-------
   ("   Post ata ;  eview data ?  scape without saving - Enter Selection "
   get response pict  "1" valid (response == "D" .or. ;
   response == "R" .or.  response == "E" )
  ad
+*. response = "D" .and.  access_lev = 0
   tone(220,3)
   tone(220,3)
   atinsay(24,0,'W/R',centring;
      ("UNAUTHORIZED  SELECTION - Your security level is insufficient for this fu
   inkey(30)
   clr_msgs()
   return("E")
-~dif


set color to &tmp_color
  rjmsgs()
  turn(upper(response))

   end of FUNG stoptest

************************************
* Date validation function
*!
         Function
 *!      Called by
 *!
             Calls
CHK_DATE ( )

WHICHOMB       (procedure in MENUS. PRG)
SF83           (procedure in SF83F.PRG)
GET_PKGTE      (procedure in CHECKTES.PRG)
GET_ICWTE      (procedure in CHECKTES.PRG)
ED_ICW_TE      (procedure in CHECKTES.PRG)
DEL_TE         (procedure in CHECKTES.PRG)
ICWINPUT       (procedure in ICW_INPT.PRG)

CLR_MSGS       (procedure in NEWTEMP4 .PRG)
 *--nction  chk_date
   rameters  when

 if .not.  empty (when)
    if when  < (date()  - 2190)  .or.  when > (date()  + 1835)
       atinsay(24,0, 'W/R1 , centring;
          ("INVALID DATE - May not  be 6 yrs less than or 5 yrs greater today's da
       tone(220,3)
       tone (220 ,3)
       inkey(30)
       clr_msgs()
       return ( . f . )
    endif
 endif
   :turn ( . t . )

 * End of FUNC chk_date

   ***************************************

-------
         Function:  V_MAILCODE()

        Called by:  SF83           (procedure in SF83F.PRG)
function v_mailcode
 irameters mcode

if empty (mcode)
   _aa_code - "    "
   _div_code = 0
   @ 3,  28 say _aa_code
   @ 3,  44 say _div_code pict "99"
   return (.t.)
   select aadiv
   seek mcode
   if found()
      _aa_code = aa_code
      _div_code = div_code
   else
      _aa_code = "   "
      _div_code = 0
   endif
   @ 3, 28 say _aa_code
   @ 3, 44 say _div_code pict "99"
   select package
   return ( . t . )
endif
 '* End of FILE sf83new.prg
  : EOF: SF83F.PRG

-------
*!
*:
*:
Procedure file:  EDITNOT1.PRG

        System:  Paper Work Reduction Managemnt System
        Author:  John Pitts, Fred,  Melissa,  Karen
     Copyright (c)      ,  Compex Corporation
 Last modified:  10/11/89      17:21

 Procs & Fncts:  EDITORNOQ
              :  REL_FORM2B
              :  REL_ICR
              :  GETVAL_ICR()
        Documented 12/28/89 at 17:34
                                                 SNAP!  version 3.12e
   FILE: EDITNOT1.PRG

   For FUNC editorno()
   RECEIVES: purpose  (i.e. editrecords or addrecords)
             choice (Form 2B or SF-83)
   RETURNS: cur_icr_no  (current icr number or new icr  number)

   this program is used to find a desired icr number if  an  edit
   is in progress, or alternately if an input is in progress,  to
   append blanks to the particular work areas involved in the
   append. These work areas which form is being used.  The  form used
   is indicated by the SELECTION parameter.
 *!
 *!
 -•-1
 * I
 *
 * !
  i
  !
 *!
  i
  i
 *!
  i
       Function

      Called by



          Calls



           Uses
        Indexes
EDITORNO()

MENU1_1
MENU1_3
MENU1_1_1

REL_FORM2B
REL_ICR
GETVAL_ICR()

AADIV.DBF
ICW.DBF
ICR.DBF
PACKAGE.DBF

MAILCODE.NDX
ICW_ICR.NDX
ICW_DATE.NDX
ICRINDEX.NDX
ICRAGNCY.NDX
ICROMBAG.NDX
PACKAGE1.NDX
(procedure in MENUS.PRG)
(procedure in MENUS.PRG)
(procedure in MENUS.PRG)

(procedure in EDITNOT1.PRG)
(procedure in EDITNOT1.PRG)
(function  in EDITNOT1.PRG)
 ^unction editorno
 parameters purpose,  choice

-------
:  t delimiters on
set confirm on
'  r_sought =0                         && Init ICR # to 0
   CLEAR
»» clear_body()
<•*- case
  se purpose =0                   && Menu call for "Add Recs"
   do case
   case choice =1                 && Add ICR Form 2B
      rel_form2b()
      select icr                    && Select ICR.DBF
      go bottom
      store icr_number+l to icr_sought  && Take last ICR #  &  increment
      append blank
      select icb_prof                    && Select ICR_PROF.DBF
      append blank
      select package                    && Select PACKAGE.DBF
      append blank
      return(icr_sought)
   case choice =2                 && Add ICR original SF-83
      rel_icr()                    && LEAVES ICR selected
      go bottom
      store icr_number+l to icr_sought  && Take last ICR #  &  increment
      append blank
      select package
      append blank
      *    select  icb_prof                     && Select ICB_PROF.DBF
      *    append  blank
      select  icr                     &&  Select ICR.DBF
      return(icr_sought)
   case choice =3                 && Add New Package
      numb_str =  getval_icr(0)   && if there  is a  valid  icr XXXX.01
      if numb_str ==  "E"    &&open DBF was closed, okay to  loop
         return("E")
      endif
      select  3             &&  PKG &  ICR OPEN now  open TRACKING.DBF
      use  aadiv  index mailcode.ndx
       *    use tracking index  trakicr.ndx,trakpkg.ndx,trakdate.ndx
       return(numb_str)      &&  PKG w/ numb_str for parsing

    case choice =4                  && Add New ICW
       numb_str = getval_icr(2)  && get/valididate  icr #
       if  numb_str ==  "E"        &&open DBF was closed,  okay to loop
          return("E")
       endif
       use icw index icw_icr.ndx,icw_date.ndx
       append blank          &&  PKG open in getval  now add new record
       return(numb_str)      &&  PKG w/ numb_str for parsing
    endcase    && For CASE choice = 1

   ise purpose =1                   && Menu call for "Edit Recs"
    **** Get the ICR # before continuing for choice 1 & 2
    if choice = 1 .or. choice =2  && need to get old icr #
       @ 11,11,16,69 box "Ei»a!?iEa "
       @ 13,  27 say  "Enter the ICR Number :  "
       @ 13,  51 get  icr_sought pict "####"
       read
    endif    && for choice = 2
    do case
    case choice = 1

-------
   rel_form2b()             &&  set relations  for Form 2B edit
   @ 14, 19 say "Searching for ICR.   One moment,please..."
   seek icr_sought
   if .not. foundQ
      tone(220,3)
      tone(220,3)
      @ 12,12 clear to 15,68
      atinsay(13,27,"W/R", "ICR # "+ ;
         substr(str((icr_sought+10000),5,0),2,4)+;
         " does NOT exist!")
      inkey(30)
      close all
      return(-l)           && return (-1) for Error condition
   endif
   set color to &old_color
   return(icr_sought)
case choice =2         && Old ICR from ICB, new SF-83(PKG)
   select 1
   use icr index icrindex.ndx,icragncy.ndx,icrombag.ndx
   seek  (icr_sought)
   is_icr = found()
   select 2
   use package  index packagel.ndx
   seek(icr_sought)
   if found()
      is_pkg =  .t.
      do while  icr_number = icr_sought
          skip
      enddo
      skip -1
      if pkg_number  >  0
          is_pkg_01 = .t.
      else
          is_pkg_01 = .f.
      endif
    else        &&  for  if  FOUND()
       is_pkg = .f.
    endif   &&  for  if FOUND()
    select 3
    use  aadiv index mailcode.ndx
    *   USE tracking  index trakicr.ndx,trakpkg.ndx,trakdate.ndx
    select icr
    if is_icr .and.  .not.  is_pkg_01  .and.  is_pkg
       return(icr_sought)   &&  Everything OKAY to continue
    endif

    @ 12,12 clear to 15,68
    if .not.  is_icr
       atinsay(12,27,"W/R",  "ICR # "+;
          substr(str((icr_sought+10000),5,0),2,4)+;
          11 does NOT exist!")
    endif
    if is_pkg_01
       atinsay(14,18,"W/R",;
          "A PACKAGE 01 already exists for ICR # "+;
          substr(str((icr_sought+10000),5,0),2,4))
       atinsay(13,18,"W/R",;
          "Use CREATE PACKAGE Menu option to add new SF-83")

    endif

-------
     @ 23,0 say centring ("Press any key to return to menu....11)
     inkey(90)
     close all
     return(-1)           && return (-1) for Error condition
  case choice =3                 && Edit Package
     numb_str = getval_icr(l)  && if there is a valid  icr  XXXX.01
     * NOT error condition, PKG is left OPEN/selected;ICR  open also
     select 3
     use aadiv index mailcode.ndx
     *   USE tracking index trakicr.ndx,trakpkg.ndx,trakdate.ndx
     return(numb_str)     && PKG numb_str for parsing
  case choice =4                 && Edit ICW
     numb_str = getval_icr(3)  && Get/Validate ICW Farms input
     return(numb_str)       && *  numb_str here  is "E"(error)  or
     *    any other char for okay.
     *  ICW.DBF is left open & rec ptr
     *  positioned if ok to edit ICW

  endcase  && purpose = 1

 idcase        && Main CASE  function
 *  End of  FUNG  editorno



 e***********************************


*!
        Procedure
*:
*'.       Called by
 i
 !            Uses
*!
*!         Indexes
• i
 i
•• i
*!
REL_FORM2B

EDITORNO()      (function  in EDITNOT1.PRG)

ICR.DBF
ICB_PROF.DBF
PACKAGE.DBF

ICRINDEX.NDX
ICRAGNCY.NDX
ICROMBAG.NDX
ICB.NDX
PACKAGE1.NDX
PACKAGE2.NDX
  i
  i
*!
  :ocedure rel_form2b

select 1
••se icr index icrindex.ndx, icragncy.ndx, icrombag.ndx

-alect 2
use icb_prof index icb.ndx

  alect 3
use package index packagel.ndx,package2.ndx

  select 4
*use  agencies.dbf
*set  index to agencies.ndx

-------
select icr
  set relation to icr_number into icb_prof, to icr_number into package
  :    to icr_mraber into agencies
  ' End of PROC rel_form2b

  r************* **********************
*!
 *!
        Procedure  REL ICR
Called by

     Uses



  Indexes
EDITORNO()

ICR.DBF
PACKAGE.DBF
AADIV.DBF

ICRINDEX.NDX
ICRAGNCY.NDX
ICROMBAG.NDX
PACKAGE1.NDX
PACKAGE2.NDX
MAINCODE.NDX
                                   (function  in EDITNOT1.PRG)
  rocedure  rel_icr

 Delect  1
 "«;e  icr index icrindex.ndx,  icragncy.ndx,  icrombag.ndx

  jlect  2
 use  package  index packagel.ndx,  package2.ndx

  ilect  3
 use  aadiv  index maincode.ndx

  select 3
  ase tracking index trakicr.ndx, trakpkg.ndx, trakdate.ndx

  select 3
  ise icb_prof index icb.ndx

  jlect  icr

 return   && return to function editorno

  « End  of PROC rel icr
  ****************************************
                                         *
 *   FUNCTION: getval_icr                *
                                         *
     Takes an ICR # and LOCATES in DBF   *
     and returns a string of the ICR #   *
 *   and the highest PKG # w. decimal pt *

-------
    or ("E")  if not exist               *
*****************************************
                                  (function  in EDITNOT1.PRG)
 Function  GETVAL_ICR()

Called by  EDITORNO()

     Uses  PACKAGE.DBF
           ICR.DBF
           ICW.DBF

  Indexes  PACKAGEl.NDX
           PACKAGE2.NDX
           ICRINDEX.NDX
           ICRAGNCY.NDX
           ICROMBAG.NDX
           ICW_ICR.NDX
           ICW DATE.NDX
 mnction getval_icr
 "arameters add_edit
  et delimiters on
 ,-rivate number, response, last_numb, eff_date, numb_icr, omb_numb
                             &&  if  0,called from add;  if 1,  from edit
  ssponse = "Y"
  sr_numb = "0000"
 whole_numb = "0000.00"
  umb_icr =0       && this  ICR  # var  is numeric,  not string as above
  mb_numb = 0
 cff_date = date()
 is_pkg_flg = .t.     &&  flags  for existence  of ICR & PKG records
  s_icr_flg = .t.

 @ 10,13,16,67 bOX  "Ei»aJj±E9  "

  elect  1                                        && Set up work area for PACKAGE
 use package index  packagel.ndx, package2.ndx   && will stay open unless error

  elect  2
 _se icr index icrindex.ndx,  icragncy.ndx,  icrombag.ndx

  elect  package
  o while .t.
    do case
    case  add_edit = 0
       @ 12,22 say "Enter the ICR Number for the new Package:"
       @ 14,36 get icr_numb picture "9999"
       read
       seek val(icr_numb)
       if found()
          do while icr_number = val(icr_numb)
             skip
          enddo
          skip -1
          last_numb = icr_numb + "." + str(pkg_number,2,0)

-------
      return(last_numb)
   else
      @  11,14  clear  to  15,  66
      atinsay(12,16,'W/R1 ,"A Previous  PACKAGE  does not exist for ICR # ";
         +icr_numb)
      @  15,35  say  "Try  Another ICR Number?  (Y/N)  "
      @  15,55  get  response picture "!" valid (response == "Y" .or.;
         response  == "N")
      read
      if response  == "Y"
         @ 11,14 clear  to 15,  66      &&  Clear the Prompt box
         loop
      else
         close all
         return("E")
      endif
   endif

case add_edit  =1     && getval_icr is for edit function
   select package
   @ 12, 16 say "Enter the ICR Number for the Package to Edit:"
   @ 14,37 get whole_numb picture "9999.99"
   read
   *   LOCATE  FOR ICR_NUMBER = VAL(SUBSTR(whole_numb,1,4))  .AND.  ;
      *                         PKG_NUMBER = VAL(SUBSTR(whole_numb,6,2))

   icrno = val(substr(whole_numb,l,4))
   pkgno = val(substr(whole_numb,6,2))
   seek icrno
   if found()
      do while icr_number = icrno
         is_pkg_fIg =  .f.
         if  pkg_number = pkgno
            is_pkg_flg  =  .t.
            exit
         endif
         skip
      enddo
   endif
   select  icr          &&  now  set  pointer to icr  record  for update
   *  LOCATE FOR  ICR_NUMBER = VAL(SUBSTR(whole_numb,1,4))
   seek icrno
   is_icr_flg  = found()
   if is_pkg_flg  .and.  is_icr_flg
      select package
      return(whole_numb)
   else
      @ 11,14  clear to 15,  66
      if .not. is_pkg_flg
          atinsay(12,22,'W/R1,"A PACKAGE  does  not exist for ICR " +whole_numb)
      endif
      if .not. is_icr_flg
          atinsay(13,20,'W/R',"An ICR Summary  does not exist for ICR " +whole_
      endif

       8 14,25 say "Try Another ICR Number? (Y/N) "
       @ 14,55 get response picture "!" valid (response == "Y" .or.;
          response == "N")
       read
       if response == "Y"

-------
         @ 11,14  clear to 15,  66      && Clear the Prompt box
         loop
      else
         close all
         return("E")
      end if
   endif

case add_edit = 2    && Adding new ICW for some ICR#
   @ 12, 21 say "Enter the ICR Number for the new ICW:"
   @ 14,36 get numb_icr picture "9999"
   read
   select icr
   icr_numb = str(numb_icr,4,0)
   seek numb_icr
   if found()
      return(icr_numb)
   else
      @ 11,14 clear to 15, 66
      atinsay(12,16,'W/R1,"A ICR Record does not exist  for  ICR #  "+;
          icr_numb)
      @ 14,25 say "Try Another  ICR Number?  (Y/N) "
      @ 15,55  get response picture "!" valid  (response ==  "Y" .or.;
          response == "N")
      read
      if  response == "Y"
          @ 11,14 clear to 15,  66      && Clear the  Prompt box
          loop
      else
          close all
          return("E")
      endif
    endif

 case  add_edit  =3     &&  Editing an  existing ICW for ICR#,OMB#, Effect date
    @  11,16 say "Enter  the ICW  Data  below for the record to  Edit."
    @  13,32 say "ICR #:  "
    @  14,23 say "OMB  (Docket)  #: "
    @  15,23 say "Effective Date: "
    @  13,41 get numb_icr picture "9999"
    @  14,41 get omb_numb picture "99999999"
    @  15,41 get eff_date picture "@D"
    read
    use  icw index icw_icr.ndx,icw_date.ndx
    locate for icr_number =  numb_icr .and.  icb_omb_no = omb_numb  ;
       .and.  effct_date = eff_date
    if found()
       returnC'O")
    else
       @ 11,14 clear to 15,  66
       atinsay(12,19,'W/R1,"An ICW with those parameters does  not exist")
       @ 15,25 say "Try Another ICR Number? (Y/N) "
       *  ATINSAY(15,34,'GR+/B1,'Y')
       *  @ 15,35 SAY "es or"
       *  ATINSAY(15,41,'GR+/B1,'N')
       @ 15,55  get response picture "!" valid  (response ==  "Y" .or.;
          response == "N")
       read
       if response == "Y"
          @  11,14 clear to 15,  66      && Clear the Prompt  box

-------
           loop
        else
           close all
           return("E")
        endif
     end if
  endcase  && For MAIN Case clause

nddo   && For MAIN DO WHILE loop

* End of FUNC getval_icr
: EOF:  EDITNOT1.PRG

-------
  Procedure file  CHECKTES.PRG
          System
          Author
       Copyright
   Last modified

   Procs & Fncts
                Paper Work Reduction Managemnt System
                John Pitts, Fred, Melissa, Karen
                (c)      , Compex Corporation
                12/05/89      13:37

                INP_PKG_TE
                CHK_IS_PKG()
                GET_PKGTE
                IS_CODE()
                EVENTSPOP
                INP_ICW_TE
                CHK_IS_ICW()
                GET_ICWTE
                ED_PKG_TE
                EDIT_TE
                ED_ICW_TE
                DEL TE
       Documented 12/28/89 at 17:34
                                                  SNAP!  version 3.12e
    File: GETPKGTE.PRG

    MAIN PROC: inp_pkg_te
***********************************************
                                              *
                                              *
                                              *
                                              *
   Description:  Procedure will input one or   *
                more Tracing Events for one   *
                or more ICR/Packages          *
                                              *
   Called From:  Screen 1.2 ,Menu Selection 1  *
                                              *
                                              *
                                              *
                                              *
                                              *
***********************************************
     Receives:  N/A

     Returns :  N/A
* i
* i
*i
      Procedure

      Called by

          Calls



           Uses
          Indexes
INP_PKG_TE

MENU1_2

CHK_IS_PKG()
GET_PKGTE
CLR_INBODY

PACKAGE.DBF
TRACKING.DBF
EVENTS.DBF
ICR.DBF

PACKAGE2.NDX
TRAKICR.NDX
TRAKPKG.NDX
TRAKDATE.NDX
(procedure in MENUS.PRG)

(function  in CHECKTES.PRG)
(procedure in CHECKTES.PRG)
(procedure in NEWTEMP4.PRG)

-------
                 :  ICRINDEX.NDX
*!

 •ocedure inp_pkg_te

«t confirm on
 •suit = .t.
 jsponse = " "
te_icr_no = 0
 »_pkg_no = 0
 imber = "0000.00"
another = .t.

 st color to "BGVB,GR+/B,,,RB+/B"

splect 1
  ie package.dbf index  package2.ndx

select 2
  >e tracking.dbf index trakicr.ndx,trakpkg.ndx,trakdate.ndx

select 3
-->e events.dbf

_jlect 4
use icr  index icrindex.ndx

  > while  .t.
   @  7,13,12,67 box "Ei»a^iiEfl  "
   @  9,  18  say "Enter the ICR  Number for the  Tracking Event:"
   @  11,36  get number picture  "9999.99"
   read
   te_icr_no = val(substr(number,1,4))
   te_pkg_no = val (substr(number,6,2))
   result = chk_is_pkg(te_icr_no,te_pkg_no)
   if result
       get_pkgte(te_icr_no,te_pkg_no, number,1)
       @  7,13,12,67  box  "t±»°k±E° "
       §  9,  24 say "Add  Tracking Event for another ICR?"
       @  11,32 say "Enter (Y/N) "
       §  11,44 get response  picture "!"  valid (response == "Y" .or.;
          response == "N")
       read
       if response == "Y"
          clr_inbody()                      && Clear INP Template body area
          loop                             && Go back to start of Main loop
       else
          close all                        && Close all work areas/files
          return                           && Return to Caller 1_2MENU.PRG
       endif
    endif

    ***************  Bad PKG number  - Prompt for another try  ******************

    @ 9,16,10,66 box ""
    atinsay(9,20,'W/R'," ** A  PACKAGE for "-t-substr (str ((te_icr_no+10000) , 5,0) , 2, 4
       +substr(str((te_pkg_no+100),3,0),2,2)+" does NOT exist! **  ")
    @ 11,27 say "Try another number?  (Y/N) "
    @ 11,53 get response pict  "!"  valid  (response ==  "Y"  .or.;
       response ==  "N")

-------
   read
   if response == "Y"
      clr_inbody()
      loop
   else
      close all
      return
   endif
enddo

   End of PROC inpjpkg_te

••***********************************************
     FUNCTION: chk_is_pkg                       *
                                                *
*    Description: Fucntion to check package.dbf *
                  for ICR.PKG # input           *
                                                *
*    Called From: Main PROC inp_pkg_te          *
                 (this file CHECKPKG.PRG above) *
                                                *
*    Receives: ICR#  (_te_icr_numb -> inp_icr_no)*
*              PKG#  (_te_pkg_numb -> inp_pkg_no)*
                                                *
     Returns: Result of LOCATE  (i.e. FOUND())   *
*                                               *
  ***********************************************
         Function: CHK_IS_PKG()

 *!      Called by: INP_PKG_TE      (procedure  in  CHECKTES.PRG)


 function chk_is_pkg
 i  rameters  inp_icr_no,inp_pkg_no

 private  sk_str

 .  lect package                            && pkg  db is indexed to icr# AND pkg#
 -,._str = str(inp_icr_no,4,0)+str(inp_pkg_no)
 seek pad(sk_str,len(indexkey(0)))
   turn(  found())

 ** End of  FUNCTION chk_is_pkg

   ***********************************************
      PROCEDURE:  get_pkgte                       *
 *                                               *
      Description:  Draws Tracking event Input     *
                   form and gets data.  Checks     *
 *                 for duplicate records and     *
                   prompts user for more of same *
                                                 *
 *    Called From:  Main PROC inp_pkg_te          *
                  (this file CHECKPKG.PRG above)  *
                                                 *
      Receives:  ICR # (_te_icr_numb -> _icr_numb *
 *              PKG # (_te_pkg_numb -> _pkg_numb *

-------
              TEXT  #  (number ->  number)
     Returns: N/A
     Calls: N/A

    This  routine is  also called by sf83f  to
    automatically  input TE "II"
 t***********************************************
*!
* i
*!
Procedure
        Called by
            Calls
GET_PKGTE

SF83
INP_PKG_TE
ED_PKG_TE

CLR_INBODY
IS_CODE()
CHK_DATE()
CLR MSGS
                          (procedure in SF83F.PRG)
                          (procedure in CHECKTES.PRG)
                          (procedure in CHECKTES.PRG)

                          (procedure in NEWTEMP4.PRG)
                          (function  in CHECKTES.PRG)
                          (function  in SF83F.PRG)
                          (procedure in NEWTEMP4.PRG)
  rocedure get_pkgte
parameters _icr_numb, _pkg_numb, number,sf83_flag
*** sf83_flag was added to auto trigger te input on sf-83 input  *******

  jsponse = "Y"
good_code = .t.
 " ipe_te = .t.
  sleet tracking
miere = recno()
do while .t.                     && Main loop for get_pkgte
   set color to "BG+/B,GR+/B,,,RB+/B"
   clr_inbody()
   ****************  initialize local field variables   ********************
   if sf83_flag =3     && this is an edit
      _te_code = evnt_code
      _te_date = evnt_date
      _te_close =  .f.
      _te_cmnts =  evnt_cmnts
      _te_icwflg = icw_flag
   else
      _te_code = "  "
      _te_date = date()
      _te_close =  .f.
      _te_cmnts =  ""
      _te_icwflg = .f.
   endif
   ****************   Paint  Input Window  &  get  Data   ***********************
   @  8,10,  21,70 box "E±»BJj±EB "
   @  10,10  say "I"
   @  10,11  to  10,69  double
    @ 10,40  say "E"
    @ 10,70  say "l "
    if sf83_flag = 3
               && this is an edit
       @ 9,  14 say "Edit Package Tracking Event for ICR #
          substr(str((_icr_numb+10000),5,0),2,4)+".";
          +substr(str((_pkg_numb+100),3,0),2,2)
    else

-------
   @ 9,  14 say "Input Package Tracking Event for ICR # " +;
      substr(str((_icr_numb+10000),5,0) ,2,4)+".";
      +substr(str((_pkg_numb+100),3,0) ,2,2)
endif
@ 11,16 say "Event Code: "
@ 11,45 say "Date: "
@ 11,40 say "9"
@ 12,10 say "I"
@ 12,11 to 12,69 double
@ 12,40 say "E"
@ 12,70 say H1 "
@ 13,16 say "Enter Comments below:  (Press CTRL-W when done)"
§ 14,10 say "C"+replicate("A",59)+"H"

if  (sf83_flag =1 .or. sf83_flag = 3)  && THis was NOT called  from  SF-83
    @ 11, 28 get _te_code pict "@A !!" valid is_code(_te_code)
else
    _te_code = "II"
    atinsay(ll, 28, "RB+/B", _te_code)
endif
@ 11, 51 get _te_date pict "@D" valid chk_date(_te_date)

read
temp_color =  setcolor()
set color to  "GR+/B,GR+/B,,,RB+/B"
_te_cmnts = memoedit(_te_cmnts,15,12,20,68,.t.)   &&  MEMOEDIT for Comments
set color to  &temp_color
if  .not.(_te_code $  "CRCSISPORP")
    select tracking      && change work area to TRACKING.DBF
    dupe_te =  .f.
    seek _icr_numb
    if  found()
       do  while  icr_number =  _icr_numb
          if pkg_number  =  _pkg_numb  .and.  evnt_code == _te_code;
                .and.  evnt_date = _te_date
            dupe_te  = .t.
            exit
          else
            skip
          endif
       enddo
    endif  &&  if icr # found  in  trak dbf
    if dupe_te     && a  duplicate was found
       @ 4,10,6,70 box "UAc'UAA1  "
       atinsay(5,19,'w/r1,'****   DUPLICATE TRACKING EVENT ENTRY  ****')
       atinsay(24,0,'w/r',centring;
          ("Press  to  Abort  operation or any other key to continue.
       tone(440,2)
       tone(440,2)
       te_cont = inkey(60)
       clr_msgs()
       if te_cont = 286
          clr_inbody()
          return
       endif
       clr_msgs()
       if sf83_flag > 0      && THis was NOT called  from SF-83  input
          clr_inbody()         && Clear input  body & loop to input  window
          loop
       else

-------
           return
        endif   &&  for  if NOT  from  sf83
     endif     && for if duplicate  entry
  endif         && this was added  for  in  string check
  ********* Prompt to accept or reject **************

  @  4,10,7,70  box  "UAi'UAA1 "
  @  5,18 say "Do you want  to  add this  Tracking Event record?"
  @  6,33 say "Enter  (Y/N)  "
  @  6,45 get response  picture "!"  valid  (response == "Y" .or.;
     response  == "N")
  read
  if response  == "Y"
     if  sf83_flag  #  3
        append blank
     else
        goto where
     endif
     replace icr_number with  _icr_numb,  pkg_number with _pkg_numb, ;
        evnt_code  with _te_code,  evnt_date with _te_date, ;
        evnt_close with _te_close, evnt_cmnts with _te_cmnts
     if  sf83_flag  < 1       && TE input was called from sf-83  input
        if  icr->te_date <= _te_date
           replace icr->te_status with _te_code
           replace icr->te_date with _te_date
        endif
     else
        select icr
        seek _icr_numb
        if te_date <= _te_date
           replace te_status with _te_code
           replace te_date with _te_date
        endif
        select tracking
     endif &&  for sf_83 fig
  endif
  if sf83_flag <  1 .or. sf83_flag = 3 && sf-83  input or  edit te
     return
  endif
  @  4,10,7,70  box "UA£3UAAJ  "
  @  5,14 say  "Add another  Tracking Event  for ICR number "+ number*"  ?"
  @  6,33 say  "Enter (Y/N) "
  @  6,45 get  response picture  "!" valid  (response == "Y" .or.;
      response ==  "N")
  read
  if response ==  "N"
      clr_inbody()
      return
  else
      loop
  endif
      && End  of Main  function loop  for get_pkgte
 fcEnd of PROC get_pkgte

*************************************************
     FUNCTION: is_code                          *
                                                *
*    Description:  Test if Tracking Event code   *
*                 entered exists in EVENTS. DBF  *

-------
                  look-up table.                 *
*                                               *
     Called by:  VALID clause in get_pkgte PROC  *
                    in same file above          *
»    Receives:  Event Code (_te_code -> code     *
*    Returns:  Result of LOCATE ( i.e. FOUND () )     *
     Calls: N/A                                 *
                                                *
*************************************************


*!
         Function: IS_CODE()
  i
-1      Called by: GET_PKGTE       (procedure in CHECKTES.PRG)
*'                : GET_ICWTE       (procedure in CHECKTES.PRG)

            Calls: EVENTSPOP       (procedure in CHECKTES.PRG)
*!                : CLR_MSGS        (procedure in NEWTEMP4.PRG)


runction is_code
--irameters code

_jlect events


  scate for event_code == code
codexists = foundQ
  :  .not. codexists  .or. empty (code)
    tmp_color =  setcolor()
    set color to "W/R,W/R, , ,W/R"
    @ 24,00 say  centring  ;
       ("Event Code  "+code+"  is NOT a  valid code  -  Press  now for Code List")
    tone(220,3)
    tone(220,3)
    if  inkey(15) = 63
       eventspop ( )
    endif
    set color to &tmp_color
    clr_msgs()
  alect  tracking

 return (codexists)

  * End  of FUNG is_code to validate Event Code input

 *** End of FILE GETPKGTE.PRG
 ************ PROCEDURE :   EVENTSPOP *****************************
       DESCRIPTION:    this is invoked from the tracking event
       input procedure if the question mark key is entered in as a
 *     response.  This action then results in the temporary
       display of all possible events and their codes for the
       use to reference and which disappears again, leaving
       the original input screen the way it was.

-------
       Procedure: EVENTSPOP

       Called by: IS_CODE()
                                  (function  in CHECKTES.PRG)
procedure eventspop

:  lect events
go top
r~ve screen
i  2, 19, 23, 80 box "
t 3, 21 say "Event Code
0 4, 21 say " -----------
:  5
(   while .not. eof()
   § x, 21 say event_code + "
   x=x+l
   skip
enddo
                             Tracking  Event  Description"
                                             " + trim(event_name)
i  22,  21 say " Press any key to return to inputs. "
...key(O)
restore screen
  turn
  ***********************************************
     File:  CHECKICW.PRG

     MAIN PROC: inp_icw_te

     Description: Procedure will input one or
                  more Tracing Events for one
                  or more ICR ICWs
                                                 *
                                                 *
                                                 *
                                                 *
                                                 *
      Called  From:  Screen 1.2  ,Menu Selection 4   *
                                                 *
                                                 *
                                                 *
                                                 *
                                                 *
 *************************************************
     Receives: N/A

     Returns: N/A
 * i
 *1
 *!
 *!
        Procedure

        Called by

            Calls
              Uses
INP_ICW_TE

MENU1_2

CENTRING()
CHK_IS_ICW()
GET_ICWTE
CLR_INBODY

ICW.DBF
TRACKING.DBF
EVENTS.DBF
ICR.DBF
                                   (procedure in MENUS.PRG)

                                   (function  in NEWTEMP4.PRG)
                                   (function  in CHECKTES.PRG)
                                   (procedure in CHECKTES.PRG)
                                   (procedure in NEWTEMP4.PRG)

-------
 1         Indexes
*!
 \
*\
 i
ICW_ICR.NDX
ICW_DATE.NDX
TRAKICR.NDX
TRAKPKG.NDX
TRAKDATE.NDX
ICRINDEX.NDX
procedure inp_icw_te

 »t delimiters on
set confirm on

 jsult = .t.
_3sponse = " "
te_icr_no = 0
  >_pkg_no = 0
  imber = "0000.00"
another = .t.

  it color to "BGVB,GR+/B,,,RB+/B"

**********************  set up Databases & Work Areas   ************************
  alect 1
.SB icw index icw_icr.ndx,icw_date.ndx

  jlect 2
  ;e tracking.dbf  index trakicr.ndx,trakpkg.ndx,trakdate.ndx

  sleet 3
  se events.dbf

select 4
  >e icr  index icrindex.ndx


  3 while  .t.
   @  10,13,15,67  box  "Ei»B^lEB  "
   @  12,  18 say  "Enter the  ICR  Number for  the  Tracking Event."
   @  24,0  say centring("An  ICW  record must exist for the ICR # entered")
   @  14,35  get number picture  "9999.99"
   read
   @  24,0  clear                        && Clear the Msg Prompt area
   te_icr_no = val(substr(number,1,4))
   te_pkg_no = val(substr(number,6,2))
   result  = chk_is_icw(te_icr_no)
    if result
       get_icwte(te_icr_no,te_pkg_no,0)
       @  10,13,15,67 box  "Ei»9^iE8  "
       @  12, 21  say "Add  ICW Tracking Event for another ICR?"
       @  14,33 say "Enter (Y/N)  "
       @  14,45 get response picture "!" valid (response ==  "Y"  .or.;
          response == "N")
       read
       if response == "Y"
          clr_inbody()                     && Clear INP Template body  area
          loop                             && Go back to start  of Main loop
       else
          close all                        && Close all work  areas/files
          return                           && Return to Caller  1 2MENU.PRG

-------
     end if
  endif

  ***************   Bad  PKG  number - Prompt  for another try  ******************

  @  12,16,13,66  box ""
  atinsay(12,25,'W/R'," **  ICW "+substr(str((te_icr_no+10000),5,0),2,4) ;
     +" does NOT exist! **  ")
  @  14,27  say "Try another  number? (Y/N)  "  get response picture "!";
     valid (response == "Y" .or.  response ==  "N")
  read
  if response == "Y"
     clr_inbody()
     loop
  else
     close all
     return
  endif
enddo

   End  of  PROC inp_icw_te

*************************************************
     FUNCTION: chk_is_icw                       *
                                                *
*    Description: Fucntion to check ICW.DBF     *
                  for ICR.PKG # input

*    Called From: Main  PROC inp_icw_te
                 (this  file CHECKICW.PRG above)

     Receives: ICR#  (_te_icr_numb  -> inp_icr_no)
*              PKG#  (_te_pkg_numb  -> inp_pkg_no)*
                                                *
     Returns: Result of LOCATE  (i.e. FOUND())   *
*                                               *
  ***********************************************
         Function: CHK_IS_ICW()

 *!      Called by: INP_ICW_TE      (procedure  in  CHECKTES.PRG)
 function  chk_is_icw
   rameters  inp_icr_no

 select  icw
 =:oek inp_icr_no
   turn(found())

 ** End  of FUNCTION chk_is_icw

   ***********************************************
 *    PROCEDURE:  get_icwte                       *
 •••                                               *
      Description:  Draws Tracking event Input    *
                   form and gets data.  Checks    *
 *                 for duplicate records and     *

-------
                  prompts user for more of same

     Called From:  Main PROC inp_icw_te
                 (this file CHECKICW.PRG above)

     Receives:  ICR # (_te_icr_numb -> _icr_numb
               PKG # (_te_pkg_numb -> _pkg_numb
               TEXT # (number -> number)
     Returns:  N/A
     Calls: N/A
*************************************************
*!
*!
* i
Procedure  GET ICWTE
        Called by
            Calls
           INP_ICW_TE
           ED_ICW_TE

           CLR_INBODY
           IS_CODE()
           CHK_DATE()
           CLR MSGS
(procedure in CHECKTES.PRG)
(procedure in CHECKTES.PRG)

(procedure in NEWTEMP4.PRG)
(function  in CHECKTES.PRG)
(function  in SF83F.PRG)
(procedure in NEWTEMP4.PRG)
  ocedure get_icwte
  rameters _icr_numb, _pkg_numb, sf83_flag

  •ivate response, good_code
  isponse = "Y"
>_juod_code =  . t.

  lect tracking
  ere = recno()
do while .t.                     && Main  loop  for  get_icwte
   set color to  "BG+/B,GR+/B,,,RB+/B"
   clr_inbody()
   if sf83_flag  =3      && this  is an edit
      _te_code = evnt_code
      _te_date = evnt_date
      _te_close  =  .f.
      _te_cmnts  =  evnt_cmnts
      _te_icwflg = icw_flag
   else
      _te_code = "   "
      _te_date = date()
      _te_close  =  .f.
      _te_cmnts  =  ""
      _te_icwflg = .t.                    && Flag to indicate an ICW Event
   endif
   @  8,10,  21,70 box "EiwoijiE0 "
   @  10,10  say "I"
   @  10,11  to 10,69 double
   @  10,40  say "E"
   @  10,70  say H1 "
    if sf83_flag =  3
       @  9,  17 say  "Edit an  ICW Tracking Event for ICR # "+;
          substr(str((_icr_numb+10000),5,0),2,4)
   else

-------
   @ 9,  17 say "Input an ICW Tracking Event for ICR # "+;
      substr(str((_icr_numb+10000),5,0),2,4)
end if
@ 11,17  say "Event Code: " get _te_code pict "@A !!" valid is_code(_te_code)
@ 11,42  say "Date: " get _te_date pict "@D" valid chk_date(_te_date)
§ 11,40  say "fl"
§ 12,10  say "1"
@ 12,11  to 12,69 double
@ 12,40  say "E"
@ 12,70  say "l "
8 13,16  say "Enter Comments below: (Press CTRL-W to when done)"
@ 14,12  to 14,68
read
temp_color = setcolor()
set color to "GR+/B,GR+/B,,,RB+/B"
_te_cmnts = memoedit(_te_cmnts,15,12,20,68,.t.)
set color to &temp_color

********************  Test Code  for  Valid  or  Duplicate   ********************

dupe_te =  .f.

select tracking
if  .not.(_te_code $  "CRCSISPORP")
    seek _icr_numb
    if found()
      do  while  icr_number = _icr_numb
          if   evnt_code  == _te_code  .and.  evnt_date = _te_date
             dupe_te  = .t.
             exit
          else
             skip
          endif
      enddo
    endif   && if icr # found in trak dbf
    if dupe_te     && a duplicate was found
      @  4,10,6,70 box "UAi'UAA1  "
      atinsay(5,19,'w/r1,'****  DUPLICATE TRACKING EVENT ENTRY  ****')
      tone(440,2)
      tone(440,2)
      atinsay(24,0,'w/r1,centring;
          ("Press  to Abort operation or any other key to continue....
       te_cont = inkey(60)
       clr_msgs()
       if te_cont = 286
          clr_inbody()
          return
       endif
       clr_msgs()
       clr_inbody()
       loop
    endif
 endif
 *********  Prompt to accept or  reject **************

 @  4,10,7,70 box  "UA£JUAA3  "
 §  5,18 say  "Do you want  to add  this Tracking Event  record?"
 @  6,33 say  "Enter  (Y/N)  "
 @  6,45 get  response  picture "!" valid  (response ==  "Y"  .or.;
     response  ==  "N")

-------
  read
  if response == "Y"
     if sf83_flag # 3
        append blank
     else
        goto where
     endif
     replace icr_number with _icr_numb, pkg_number with _pkg_numb, ;
        evnt_code with _te_code, evnt_date with _te_date, ;
        evnt_close with _te_close, evnt_cmnts with _te_cmnts , ;
        icw_flag with _te_icwflg
     select icr
     seek _icr_numb
     if found()
        if te_date <= _te_date
           replace te_status with _te_code
           replace te_date with _te_date
        endif
     endif
     select tracking


     *  trk_isrted =  .F.
  endif
  if sf83_flag =  3
     return
  endif
   @  4,10,7,70 box  "
   @  5,13  say "Add  another ICW Tracking  Event  for ICR number "+;
      substr(str((_icr_numb+10000) ,5,0) ,2,4)+"  ?"
   @  6,33  say "Enter  (Y/N)  "
   @  6,45  get response pict "!" valid  (response == "Y" .or.;
      response == "N")
   read
   if response == "N"
      clr_inbody ( )
      return
   else
      loop
   endif
-.iddo  * End of  Main  function loop for get_icwte

 'End of PROC get_icwte
        Procedure  ED PKG TE
        Called by

            Calls
             Uses
EDIT_TE        (procedure in CHECKTES.PRG)

GET_PKGTE      (procedure in CHECKTES.PRG)
CLR_INBODY     (procedure in NEWTEMP4.PRG)

PACKAGE.DBF
TRACKING.DBF
EVENTS.DBF
ICR.DBF

-------
          Indexes:  PACKAGE2.NDX
*!                :  TRAKICR.NDX
                 :  TRAKPKG.NDX
 !                :  TRAKDATE.NDX
~J                :  ICRINDEX.NDX
*!

 rocedure ed_pkg_te

 it confirm on
 iSUlt = .t.
response = " "
*-^_icr_no = 0
 >_pkg_no = 0
..amber = "0000.00"
another = .t.
 »_when = dateQ
 iat_code = space(2)

 it color to "BG+/B,GR+/B,,,RB+/B"

select 1
'";e package.dbf index  package2.ndx

_>lect 2
use tracking.dbf index trakicr.ndx,trakpkg.ndx,trakdate.ndx

  »lect 3
use events.dbf

  jlect 4
    icr  index icrindex.ndx

   while  .t.
   @  7,13,12,67 box "E±»BUEg  "
   @  8,  15  say  "Enter  ICR #,  CODE,  DATE for the Tracking Event:"
   @  9,36 get number picture  "9999.99"
   @  10,36  get  what_code picture "@!  AA"
   @  11,36  get  te_when
   read
   te_icr_no =  val(substr(number,1,4))
   te_pkg_no =  val(substr(number,6,2))
    *    result = chk_is_pkg(te_icr_no,te_pkg_no)
    select tracking
    seek te_icr_no
    if found()
       do while   icr_number = te_icr_no
          result = .f.
          if (pkg_number = te_pkg_no  .and. evnt_code = what_code
                .and. evnt_date = te_when .and. icw_flag =  .f.)
             result = .t.
             exit
          endif
          skip
       enddo
    else
       result = .f.
    endif
    if result
       get_pkgte(te_icr_no,te_pkg_no,  number,3)

-------
     close all                        && Close all work areas/files
     return                           && Return to Caller 1_2MENU.PRG
  end if

  ***************  Bad PKG number - Prompt for another try   ******************

  @ 8,14,11,66 box ""
  atinsay(9,16,'W/R1," An Event with those parameters cannot be  found  ")
  @ 11,32 say "Try again? (Y/N) "
  @ 11,49 get response pict "!"  valid  (response ==  "Y"  .or.;
     response == "N")
  read
  if response = "Y"
     clr_inbody()
     loop
  else
     close all
     return
  endif
  ddo

  End of PROC ed_pkg_te

  *******************************************
       r*******************

        Procedure:  EDIT_TE

*!      Called by:  MENU1_2        (procedure in MENUS.PRG)

            Calls:  INP_TMPL       (procedure in NEWTEMP4.PRG)
                 :  ED_ICW_TE      (procedure in CHECKTES.PRG)
*!               :  ED_PKG_TE      (procedure in CHECKTES.PRG)


procedure edit_te

  ivate response
response = "Y"

  7,13,12,67 box "
c 9,19 say "Is the Event you want to Edit for an ICW?"
@ 10,  33 say "Enter  (Y/N) " get response pict "!" valid  (response  == "Y"  ;
   .or.  response == "N")
  ad
if response == "Y"
   old_color = setcolor()
   inp_tmpl(tlcolor,dtcolor,"1.2.6",1)  && Set Input  Screen Template
   ed_icw_te()
   set color to &old_color
  se
   old_color = setcolor()
   inp_tmpl(tlcolor,dtcolor,"1.2.6",l)  && Set Input  Screen Template
   ed jpkg_te ()
   set color to &old_color
end
  jturn

 - End of PROC edit te

-------
  ******************************************
*!
*l
*!
*!
*!
Procedure

Called by

    Calls



     Uses



  Indexes
ED_ICW_TE

EDIT_TE

CHK_DATE()
GET_ICWTE
CLR_INBODY

TRACKING.DBF
EVENTS.DBF
ICR.DBF

TRAKICR.NDX
TRAKPKG.NDX
TRAKDATE.NDX
ICRINDEX.NDX
(procedure in CHECKTES.PRG)

(function  in SF83F.PRG)
(procedure in CHECKTES.PRG)
(procedure in NEWTEMP4.PRG)
procedure ed_icw_te

  st confirm on
_jsult = .t.
response = " "
  imber = "0000.00"
  •_pkg_no = 0
te_icr_no = 0
  icther = .t.
  »_when = date()
»aat_code = space (2)

  it color to "BG+/BfGR+/B, f/RB+/B"

select 1
  ;e tracking. dbf index trakicr.ndx,trakpkg.ndx,trakdate.ndx

select 2
-•36 events. dbf
 use icr index icr index. ndx

  3 while .t.
    @ 7,13,12,67 box "E±»
    @ 8, 15 say "Enter ICR #,  CODE, DATE for the Tracking Event:"
    @ 9,36 get number picture "9999.99"
    @ 10,36 get what_code picture "@! AA"
    @ 11,36 get te_when valid chk_date(te_when)
    read
    *   result = chk_is_pkg(te_icr_no,te_pkg_no)
    te_icr_no = val(substr (number, 1,4) )
    te_pkg_no = val(substr(number,6,2) )

    select tracking
    seek te_icr_no
    if  found()
       do while  icr_number = te_icr_no
          result =  .f.

-------
        if (pkg_number = te_pkg_no .and. evnt_code = what_code  ;
              .and. evnt_date = te_when .and. icw_flag =  .t.)
           result = .t.
           exit
        end if
        skip
     enddo
  else
     result = .f.
  endif
  if result
     get_icwte(te_icr_no,te_pkg_no,3)
     close all                        && Close all work areas/files
     return                           && Return  to Caller 1_2MENU.PRG
  endif

  ***************  Bad PKG number - Prompt  for another try  ******************

  @ 8,14 clear to  11,66
  atinsay(9,16,'W/R1," An Event with those  parameters cannot be found ")
  @ 11,32 say "Try again?  (Y/N) "
  @ 11,49 get response pict  "!"  valid  (response ==  "Y"  .or.;
     response == "N")
  read
  if response == "Y"
     clr_inbody()
     loop
  else
     close all
     return
  endif
=nddo

 * End  of PROC  ed_icw_te

*********************************************
        Procedure

        Called by

            Calls



             Uses

          Indexes
 DELJTE

 MENU1_2

 CHK_DATE()
 INP_TMPL
 CLR_INBODY

•TRACKING.DBF

 TRAKICR.NDX
 TRAKPKG.NDX
 TRAKDATE.NDX
(procedure in MENUS.PRG)

(function  in SF83F.PRG)
(procedure in NEWTEMP4.PRG)
(procedure in NEWTEMP4.PRG)
  rocedure del_te

private response, te_icr_no, te_pkg_no, number,another

  esponse = "Y"
 ue_icr_no = 0
number = "0000.00"

-------
  at_code = space(2)
te_when = dateQ
J->l_flag = 0
  •lect 1
uje tracking index trakicr.ndx,trakpkg.ndx,trakdate.ndx
Another = "Y»

  * while .t.
   @ 7,13,12,67 box "Ei»a\iE'> "
   @ 9,17 say "Is the Event you want to Delete for an ICW?"
   @ 10, 33 say "Enter (Y/N) " get response pict "!" valid  (response ==  "Y"
      .or. response == "N")
   read
   @ 8,14 clear to 11,66
   @ 8, 15 say "Enter ICR  #, CODE, DATE for the Tracking Event:"
   @ 9,36 get number picture "9999.99"
   @ 10,36 get what_code picture  "@! AA"
   @ 11,36 get te_when valid chk_date(te_when)
   read
   te_icr_no = val(substr(number,1,4))
   te_pkg_no = val(substr(number,6,2))
   if response ==  "N"
      _icw_flg =  .f.
   else
      _icw_flg =  .t.
   end if
   seek te_icr_no
   if found()
      do  while   icr_number = te_icr_no
          result  =  .f.
          if (pkg_number  = te_pkg_no  .and.  evnt_code = what_code ;
                .and.  evnt_date = te_when  .and.  icw_flag =  _icw_flg)
             result =  .t.
             exit
          end if
          skip
       enddo
    else
       result =  .f.
    endif
    if result
       old_color = setcolor()
       inp_tmpl(tlcolor,dtcolor,"1.2.7",1)  && Set Input Screen Template
       set color to "BG+/B,GR+/B,,,RB+/B"
       clr_inbody()
       _te_code = evnt_code
       _te_date = evnt_date
       _te_cmnts = evnt_cmnts
       @ 8,10,  21,70 box "E±»a^iE9 "
       @ 10,10 say "1"
       § 10,11 to 10,69 double
       @ 10,40 say "E"
       @ 10,70 say "l "
       @ 9, 17 say "Delete an Tracking Event for ICR #  "+;
          substr(str((te_icr_no+10000),5,0) ,2,4)+"."+;
          substr(str((te_pkg_no+100),3,0),2,3)
       @ 11,17 say "Event  Code:  ["+_te_code+"]"
       @ 11,42 say "Date:  ["+dtoc(_te_date)+"]"
       @ 11,40 say "8"
       @ 12,10 say "i"

-------
  @ 12,11 to 12,69 double
  @ 12,40 say "E»
  @ 12,70 say Hl "
  @ 13,25 say "** Tracking Event Comments **"
  @ 14,12 to 14,68
  lines = mlcount(evnt_cmnts,56)
  if lines > 5
     lines = 5
  end if
  for i = 0 to (lines-1)
     § 15+i,12 say memoline(evnt_cmnts,56,i+1)
  next
  @ 4,10,7,70 box "UAi'UAA3 "
  @ 5,16 say "Do you want to Delete this Tracking Event  record?"
  § 6,33 say "Enter (Y/N) "
  § 6,45 get response picture "!" valid  (response ==  "Y" .or.;
     response == "N")
  read
  if response == "Y"
     delete
     del_flag = del_flag + 1
  endif
  @ 5,11 clear to 6,69
  @ 5,14 say "Do you want  to Delete another  Tracking  Event record?"
  @ 6,33 say "Enter  (Y/N)  "
  @ 6,45 get another picture "!" valid  (response  == "Y"  .or.;
     response ==  "N")
  read
   if another ==  "Y"
     clr_inbody()
     loop
   endif
   if del_flag >  0
     clr_inbody()
     @  7,20,12,60  box  "ti»'\iE° "
     @  9,28 say  "Adjusting record  indexes"
     @10,28 say  "One moment please	"
     pack
     close all
     set color to &old_color
     return
   endif
   return
else  && result  = not found
   § 8,14 clear  to 11,66
   atinsay(9,16,'W/R1," An Event with those parameters cannot be found ")
   @ 11,32 say "Try again? (Y/N) "
   @ 11,49 get response pict "!"  valid  (response ==  "Y"  .or.;
      response == "N")
   read
   if response == "Y"
      § 8,14 clear to 11,66
      loop
   else
      if del_flag > 0
         clr_inbody()
         @ 7,20,12,60 box »E±»a^iEB "
         @ 9,28 say "Adjusting  record indexes"
         §10,28 say "One moment please	"
         pack

-------
         endif
         close  all
         return
      endif
   endif  &&  for result
  .ddo  && for main  loop

  End of PROC del te
   End of FILE checktes.prg
*:  EOF:  CHECKTES.PRG

-------
*:
   Procedure file:  SHOWTE.PRG

           System:  Paper Work Reduction Managemnt System
           Author:  John Pitts, Fred,  Melissa, Karen
        Copyright (c)     ,  Compex Corporation
    Last modified:  12/05/89     12:53

    Procs & Fncts:  SHOW_TES
                 :  TE_EXIST()
                 :  R_D_TES
                 :  RW_MEMOS()
        Documented 12/28/89 at 17:34
        k****************************:
  :***********************************************
     File: SHOWTE.PRG  (w/ new display PROC)     *
                                                    SNAP!  version 3.12e
     MAIN PROC: show_tes

     Description:
                                                *
                                                *
                                                *
                                                *
-•-                                               *
                                                *
                                                *
*    Called From:   menul_2, selection(2,4,5)     *
                     in FILE LEV_1X_M.PRG       *
     Receives: N/A                              *
*                                               *
     Returns: N/A                               *
                                                *
XX***********************************************
 * I
  I

 * I
 *!
         Procedure
        Called by

            Calls
              Uses
SHOWJTES

MENU1_2

CENTRING()
TE_EXIST()
R_D_TES
CLR_INBODY
CLEAR_BODY

TRACKING.DBF
(procedure in MENUS.PRG)

(function  in NEWTEMP4.PRG)
(function  in SHOWTE.PRG)
(procedure in SHOWTE.PRG)
(procedure in NEWTEMP4.PRG)
(procedure in NEWTEMP4.PRG)
  rocedure show_tes
 ^arameters tejtype

   FARM te_type indicate if PKG or ICW or Both TE for search/display
            l = package only  ; 2 = ICW only ; 3 = Both
 *          trigger on ICW_FLAG field of TRACKING.DBF

  rivate te_icr_no,te_pkg_no,result,number, response, sorted

 -et color to "BG+/B,GR+/B,,,RB+/B"

-------
 umber = "0000.00"
response = "Y"

 elect 1
use tracking

 o while .t.
   set color to "BG+/B,GR+/B,,,RB+/B"
   @ 10,13,15,67 box "£i»"JsiE8  "
   @ 12, 20 say "Enter the ICR Number for Tracking Event: "
   @ 24,0 say centring ("Use 00 for Package # for all ICR Events.")
   @ 14,35 get number picture "9999.99"
   read
   @ 24,0 clear                       && Clear the Msg Prompt area
   te_icr_no = val(substr(number,1,4))
   te_pkg_no = val(substr(number,6,2))
   result = te_exist(te_icr_no,te_pkg_no, te_type)
   if result
      r_d_tes (te_icr_no, te_pkg_no, te_type, number)
      e 10,13,15,67 box "fil»»«W£« "
      @ 12, 21 say "Display Tracking Events for another  ICR?"
      @ 14,33 say "Enter (Y/N) "
      @ 14,45 get response pict  "!" valid (response == "Y"  .or.;
         response == "N")
      read
      if response == "Y"
         clr_inbody()                     && Clear INP Template body area
         loop                             && Go back  to  start  of Main loop
      else
         close all                        && Close all work areas/files
         return                           && Return to Caller  1_2MENU.PRG
      endif
    end if

    ***************  T.E.S  do not exist - Prompt  for another try  ***************

    @  12,16,13,66 box  ""
    atinsay(12,24,'W/R1,"No Tracking  Events  on  file  for "+number+" ")
    @  14,28  say "Try another number?  (Y/N) " get  response pict "!";
       valid (response  ==  "Y" .or.  response  ==  "N")
    read
    if response ==  "Y"
       clear_body(bodycolorl)
       loop
    else
       close all
       return
    endif
 enddo

  ••* End of PROC show tes
          Function: TE_EXIST()

         Called by: SHOWJTES       (procedure in SHOWTE.PRG)

-------
          Indexes:  TRAKICR.NDX
*!                :  TRAKPKG.NDX

  ****************
Lunction te_exist
parameters icr_no,  pkg_no,  type_te


do case

i  se type_te =1             && PACKAGE Events only
   if pkg_no = 0
      set index to trakicr.ndx
      seek (icr_no)
      if found()
         do while icr_number = icr_no   && loop thru matching  ICRs
            if icw_flag = .f.           && Test if for PKG only
               return(.t.)
            endif
            skip
         enddo
         return(.f.)    && no match with ICW_FLAG =  .F.
      else
         return(.f.)
      endif    &&  for IF FOUND()
   else
      *  LOCATE  FOR ICR_NUMBER =  icr_no  .AND.  PKG_NUMBER = pkg_no ;
         *                    .AND. ICW_FLAG  =  .F.
      set index  to trakpkg.ndx
      sk_str = str(icr_no,4,0)+str(pkg_no,2,0)
      seek pad (sk_str, len (indexkey (0)))
      if foundQ
         do while  icr_number =  icr_no   &&  loop thru matching ICRs
            if  icw_flag =  .f.            &&  Test if  for PKG  only
                return(.t.)
            endif
            skip
         enddo
         return(.f.)     &&  no match  with ICW_FLAG  = .F.
      else
         return(.f.)
      endif     &&  for IF FOUND(}
    endif    &&  for IF PKG#  = 0

   se type_te  =2             &&  ICW Events Only
    *       IF pkg_no  =  0
    *            LOCATE  FOR ICR_NUMBER = icr_no .AND. ICW_FLAG =  .T.
    *         ELSE
    *            LOCATE  FOR ICR_NUMBER = icr_no .AND. ICW_FLAG =  .T.;
       *                 .AND. PKG_NUMBER = pkg_no
    *       ENDIF
    *        RETURN (FOUNDO)
    if pkg_no  = 0
       set index to trakicr.ndx
       seek (icr_no)
       if found()
          do while icr_number = icr_no   &&  loop thru matching ICRs
             if  icw_flag = .t.           &&  Test if for  ICW only
                 return(.t.)
             endif

-------
           skip
        enddo
        return(.f.)    && no match with ICW_FLAG =  .F.
     else
        return(.f.)
     endif     &&  for  IF FOUND()
  else
     *  LOCATE  FOR ICR_NUMBER =  icr_no  .AND. PKG_NUMBER  =  pkg_no ;
        *                    .AND. ICW_FLAG = .F.
     set  index to trakpkg.ndx
     sk_str  =  str(icr_no,4,0)+str(pkg_no,2,0)
     seek pad(sk_str,len(indexkey(0)))
     if foundj)
        do while  icr_number  =  icr_no   && loop thru matching ICRs
           if  icw_flag =  .t.            && Test if  for ICW  only
               return(.t.)
           endif
           skip
        enddo
        return(.f-)    && no match  with ICW_FLAG = .F.
     else
        return(.f.)
     endif     &&  for IF FOUND()
   endif    &&  for IF PKG# =  0

case type_te  =3             && Both PACKAGE &  ICW  EVENTS
   *        IF pkg_no = 0
   *            LOCATE FOR ICR_NUMBER = icr_no
   *          ELSE
   *            LOCATE FOR ICR_NUMBER = icr_no  .AND. PKG_NUMBER  = pkg_no
   *        ENDIF
   *        RETURN (FOUNDO)
   if pkg_no = 0
      set index to trakicr.ndx
      seek (icr_no)
   else
      *  LOCATE FOR ICR_NUMBER = icr_no .AND. PKG_NUMBER = pkg_no  ;
         *                   .AND. ICW_FLAG =  .F.
      set index to  trakpkg.ndx
      sk_str = str(icr_no,4,0)+str(pkg_no,2,0)
      seek pad(sk_str,len(indexkey(0)))
   endif     &&  for  IF  PKG# = 0
   return (found())
  idcase

 ** End of FUNC  te_exist

  ****** ********************************
         Procedure:  R_D_TES

         Called by:  SHOWJTES        (procedure  in  SHOWTE.PRG)

             Calls:  INP_TMPL        (procedure  in  NEWTEMP4.PRG)
                  :  CLR_INBODY     (procedure  in  NEWTEMP4.PRG)
                  :  CENTRING()      (function  in  NEWTEMP4.PRG)

              Uses:  ICR.DBF

-------
                 :  TRAKTEMP.DBF
                 :  TRACKING.DBF

          Indexes:  ICRINDEX.NDX
                 :  TRAKICR.NDX
                 :  TTMPDATE.NDX

                 Iri
crocedure r_d_tes
 irameters icr_numb,pkg_numb,srch_fIg,str_icr_no

old_color = setcolor()
 ip_tmpl(tlcolor,dtcolor,"1.2.2", 1) && Set Input Screen Template
 at color to &old_color
w 10,15,15,64 box IIE±»BUE<> "
fl 12, 26 say "Selecting records for display."
  13, 29 say "One moment, please	"

select 2                              && Set up Work  area  for ICR.DBF with
 se icr index icrindex.ndx
 sek icr_numb

 sleet 3
 5e traktemp           && INDEX ttmpdate.ndx
«ap   && clear any existing records
f-lose traktemp
 alect 1          &&  Reset Work area 1 to  sorted tracking
 se tracking
set index to trakicr.ndx
 sek(icr_numb)
 opy to traktemp.dbf  while icr_number = icr_numb
select 3
••se traktemp  index ttmpdate.ndx
 eindex

clr_inbody()

 ldtec_row  =0   && init  # rows  for  TE comments size comparison
*  SET filters  for traktemp which  is already open, filled and indexed
 ~o case
 ase srch_flg =1      &&  Display only TEs  for Packages

   if pkg_numb  =0    &&  All  PKG  TEs  - use  medium display -> PKG/CODE/DATE

      set filter to  icr_number = icr_numb  .and. icw_flag = .f.

      te_head_l =  "  Events :  All Packages"
      te_head_2 =  "with ICR Number ["+substr(str((icr_numb+10000),5,0),2,4)+"]"

      declare te_names[3]
      te_names[l]  =  "PKG_NUMBER"
      te_names[2]  =  "EVNT_CODE"
      te_names[3]  =  "EVNT_DATE"

      declare te_picts[3]
      te_picts[l]  =  "99"
      te_picts[2]  =  "!!"
       te_picts[3]  =  "@D"

       declare te_titles[3]

-------
     te_titles[l] =  "PKG"
     te_titles[2] =  "CODE"
     te_titles[3] =  "  DATE  "

     te_left = 26       && left col of TE PKG/CODE/DATE window
     cline_lnth =49    && Comments display line length

  else      && TEs for specific PKG - use narrow display -> CODE/DATE
     set filter to icr_number = icr_numb .and. pkg_number = pkg_numb  ;
        .and. icw_flag =  .f.

     te_head_l = " Tracking Events for"
     te_head_2 = "ICR/PACKAGE  ["+substr(str((icr_numb+10000), 5,0) , 2,4)  ;
        -t-"."+substr(str( (pkg_numb-HOO) ,3,0) ,2,2)+"]"

     declare te_names[2]
     te_names[l] =   "EVNT_CODE"
     te_names[2] =   "EVNT_DATE"

     declare te_picts[2]
     te_picts[l] = "!!"
     te_picts[2] = "iD"

     declare te_titles[2]
     te_titles[l] =   "CODE"
     te_titles[2] =   "   DATE   "

     te_left =  26        && left  col  of TE  PKG/CODE/DATE window
     cline_lnth = 49    && Comments  display line length

   endif

'-ase srch_flg =2         && Display  only TEs for ICWs

   if pkg_numb  =0        && All ICW TEs  for all PKG #s

      set  filter to  icr_number = icr_numb  .and. icw_flag = .t.
      te_head_l = "    Events :  All ICWs"
      te_head_2 = "with ICR Number ["+substr(str((icr_numb+10000),5,0),2,4)+"]"

      declare te_names[3]
      te_names[l] =   "PKG_NUMBER"
      te_names[2] =   "EVNT_CODE"
      te_names[3] =   "EVNT_DATE"

      declare te_picts[3]
      te_picts[l] = "99"
      te_picts[2] = "!!"
      te_picts[3] = "@D"

      declare te_titles[3]
      te_titles[l]  =  "PKG"
      te_titles[2]  =  "CODE"
      te_titles[3]  =  "   DATE  "

      te_left =26        && left col of TE PKG/CODE/DATE window
      cline_lnth = 49     && Comments display line  length

    else      && TEs  for  specific PKG - use narrow  display ->  CODE/DATE

-------
  set  filter to icr_number =  icr_numb  .and. pkg_number = pkg_numb ;
      .and.  icw_flag =  . t.

  te_head_l =  " ICW Tracking  Events "
  te_head_2 =  "for ICR/PACKAGE  ["+substr(str( (icr_numb+10000) ,5,0) ,2,4)+;
      "."+substr(str((pkg_numb+100),3,0), 2,2) +"]"

  declare  te_names[2]
  te_names[l]  =   "EVNT_CODE"
  te_names[2]  =   "EVNT_DATE"

  declare  te_picts[2]
  te_j>icts[l]  = "!!"
  te_picts[2]  = "§D"

  declare  te_titles[2]
  te_titles[l] =   "CODE"
  te_titles[2] =   "   DATE  "

  te_left  = 26       &&  left  col of TE PKG/CODE/DATE window
  cline_lnth = 49    &&  Comments display  line length

endif

e srch_flg  = 3         && TEs  for BOTH  packages & ICWs

if pkg_numb =0       &&  No specific pkg number

   set filter to icr_number = icr_numb
   te_head_l = "  ALL Tracking Events"
   te_head_2 = "with ICR Number  ["+ substr(str((icr_numb+10000),5,0),2,4)+"]"

   declare  te_names[4]
   te_names[l] =  "PKG_NUMBER"
   te_naraes[2] =  "EVNT_CODE"
   te_names[3] =  "EVNT_DATE"
   te_names[4] =  "ICW_FLAG"

   declare  te_picts[4]
   te_picts[l] =  "99"
   te_picts[2] =  "!!"
   te_picts[3] =  "@D"
   te_picts[4] =  "Y"
   declare te_titles[4]
   te_titles[l] =   "PKG"
   te_titles[2] =   "CODE"
   te_titles[3] =   "   DATE   "
   te_titles[4] =   "ICW"

   te_left =  30        &&  left  col  of TE  PKG/CODE/DATE window
   cline_lnth = 45     &&  Comments  display  line  length

 else      &&  TEs  for  specific  PKG-use  medium2 display->CODE/DATE/ICW

   set filter to  icr_number =  icr_numb .and. pkg_number = pkg_numb ;

   te_head_l  = "  ALL  Tracking  Events  "
   te_head_2  = "for ICR/PACKAGE ["+substr(str((icr_numb+lOOOO),5,0),2,4) + ;
       "."+substr(str((pkg_numb+lOO),3,0),2,2)+"]"

-------
     declare  te_names[3]
     te_names[l] =   "EVNT_CODE"
     te_names[2] =   »EVNT_DATE"
     te_names[3] =   "ICW_FLAG"

     declare  te_picts[3]
     te_picts[l] =  "!!"
     te_picts[2] =  "@D"
     tejpicts[3] =  "Y"

     declare  te_titles[3]
     te_titles[l] =  "CODE"
     te_titles[2] =  "   DATE  "
     te_titles[3] =  "ICW"

     te_left  =26        &&  left col of TE PKG/ CODE/ DATE window
     cline_lnth = 49    &&  Comments display line length

   end if

endcase

  > top         && Make sure filters are set


  <*** All Arrays, Work Areas ( f iles) , & header Vars  initialized  ************

****************  Display Box for DBEDIT of Records   ************************
' 2,0,22,te_left box "6i,M±6J "
  5,1 to 5,te_left-l
« 3,2 say te_head_l
fl 4,2 say te_head_2
  24,00 say centring ("Use "+chr(24)+"  "+chr(25)+;
   11 to Scroll List - Press  to Exit View")
@ 2,te_left+l,ll,79 box "6i.3U63 "
  4,te_left+2 to 4,78
  3,te_left+9 say "***  TRACKING EVENT COMMENTS   ***"
 ~ 12,te_left+l,22,79 box "oi.
  14,te_left+2 to 14,78
 c 13,te_left+9 say "***  GENERAL  ICR COMMENTS   ***"

  ic*********  Call The DBEDIT FUNCTION w/  FARMS from  above  ******************
  jmp_color = setcolor()
 set color to "GR+/B, B/W, , , B/RB+"

  3edit(6, 2, 21, te_left-l,te_names,"rw_memos",te_picts,te_titles,"iNi", ;
    n  >  it \
 --it color to &temp_color
  it filter to                           && Clear the  filter
 _,j  top                                  && Reset file pointer
 select  tracking
  aturn

 **  End  PROC  r_d_tes


 „*******************************************

-------
 I
*!        Function: RW_MEMOS()
 i
 i
runction rwjmemos
-arameters status, fld_ptr

_ac_rows = ralcount(evnt_cmnts,cline_lnth)
if tec_rows > 6
   tec_rows = 6
 ndif

1f status = 0
   if oldtec_row > tec_rows
      @ 5,te_left+2 clear to 10,77
   endif
   for row = 0 to tec_rows - 1
      § 5+row,te_left+3 say  itiemoline(evnt_cmnts,cline_lnth,row+l)
   next
   oldtec_row = tec_rows

   for i = 0 to 6
      @ 15+i,te_left+3  say memoline(icr->icr_cmnts,cline_lnth,i+1)
   next

   return(1)
 ndif

if status =  1  .or.  status =  2
   tone(220,3)
   tone(220,3)
   return(1)
-ndif
  f status =  3
   return(0)
endif

  eyval  =  lastkey()
do case
  ase keyval  = 27
   return(O)
 utherwise
   return(1)
  ndcase

 **  End FUNC rw_memos

  *  End of FILE SHOWTE.PRG
 *:  EOF: SHOWTE.PRG

-------
  Procedure file:  ICW_INPT.PRG

          System:  Paper Work Reduction Managemnt System
          Author:  John Pitts, Fred,  Melissa, Karen
       Copyright (c)      ,  Compex Corporation
   Last modified:  10/05/89       6:30

   Procs & Fncts:  ICWINPUT
                :  V_RSPDIF()
                :  V_HRSDIF()
       Documented 12/28/89 at 17:35
                  SNAP!   version 3.12e
         PROCEDURE: ICWINPUT   (for the PRAMS project)       *
         Description: This procedure inputs the data  from  *
         the EPA form called the Inventory Correction      *
         Worksheet.  (Entered with record pointer  already   *
         set up, or blank already appended.                 *
       Procedure: ICWINPUT

       Called by: MENU1_1

           Calls: CHK_DATE()
                : V_RSPDIF()
                : V_HRSDIF()
                : STOP_TST()
                : CLR MSGS
(procedure in MENUS.PRG)
(function  in
(function  in
(function  in
(function  in
(procedure in
SF83F.PRG)
ICW_INPT.PRG)
ICW_INPT.PRG)
SF83F.PRG)
NEWTEMP4.PRG)
 rocedure icwinput
 arameters purpose,  _icr_numbe

 rivate micw_logged,  mdesk_offc,  micb_omb_no
 rivate meffct_date,  magncy_numb,  magncy_numb,  mfunct_code, mfunct_code
private mexpir_date,  mexpir_date
"rivate mrespd_old,  mhours_old, mresp_new,  mhours_new, mresp_diff
 rivate mhours_diff,  mrsp_adj_er,  mhrs_adj_er,  mrspadjrest, mhr_adjrest
t.rivate mrspadjciu,  mhr_adj_ciu,  mrsp_prg_ch, mhrs_prg_ch,micw_cmnts
private response

 esponse = "R"

 et confirm on
 elimiters="[]"
aet delimiters on
i->age_one=l
 iax_pgs=2

select icw

 ** initialize and fill memvar duplicates for all  fields

 •' f purpose =1                      && Edit  existing  ICW

-------
   _icr_numbe = icr_number
endif
  else  _icr_numbe was passed

micw_logged = icw_logged
—iesk_offc =  desk_offc
 Lcb_omb_no = icb_omb_no
...3ffct_date - effct_date
magncy_numb = agncy_numb
 :unct_code = funct_code
 sxpir_date = expir_date
mrespd_old = respd_old
 iours_old = hours_old
 resp_new = resp_new
iunours_new = hours_new
"•"esp_diff = resp_diff
 iours_diff = hours_diff
 :sp_adj_er = rsp_adj_er
mhrs_adj_er = hrs_adj_er
 -spadjrest = rspadjrest
 ir_adjrest = hr_adjrest
mrspadjciu = rspadjciu
-'ir_adj_ciu = hr_adj_ciu
 rsp_prg_ch = rsp_prg_ch
,u.irs_prg_ch = hrs_prg_ch
micw_cmnts = icw_comnts

 :optest = "C"

 3 while stoptest <> »D"               && Main DO  loop for PROC

   ************************* Set up First page
   set color to "BG+/B,GR+/B,,,RB+/B"
   @ 2,0 clear to 22,79
   str_icr=substr(str((_icr_numbe+10000),5,0) ,2,4)

   atinsay(0,65,'RBVB', "Page  » +  str (page_one, 1,0)  + »  of » + str(max_pgs, 1,0

   @ 2, 10, 4, 70 box "UAi'UAA1 "
   @ 3, 13 say "INVENTORY  CORRECTION  WORKSHEET   for  ICR  Number •"
   atinsay(3, 64, 'RB+/B1,str_icr)
   @ 5, 5, 13, 79 box "UAi'UAA1 "
   @ 6, 7 say "Date:"
   @ 8, 7 say "From (desk officer):"
   @ 10, 7 say "Docket number or OMB#:"
   @ 12, 7 say "Effective date  of correction:"
   @ 14, 5, 22, 79 box "UA^1 UAA3 "
   @ 15, 10 say "SF 83 item:     Currently  in inventory:"+space(6)+"as corrected
   @ 17, 7 say "Agency/Bureau  #:"
   @ 18, 7 say "Functional code:"
   @ 19, 7 say "Expiration date:"

   magncy_numb = _icr_numbe

   *** get input fields into memvar duplicates
   @ 6, 37 get micw_logged
   @ 8, 37 get mdesk_offc picture  'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX'
   @ 10, 37 get micb_omb_no picture  '@R  9999-9999"
   @ 12, 37 get meffct_date valid chk_date(mexpir_date)
   @ 17, 37 get magncy_numb picture  '999999'

-------
@ 17, 53 get magncy_numb picture '999999'
@ 18, 37 get mfunct_code
@ 18, 53 get mfunct_code
@ 19, 37 get mexpir_date valid chk_date(mexpir_date)
@ 19, 53 get mexpir_date valid chk_date(mexpir_date)
read

************************* get up Second Page ********************************
@ 2,0 clear to 22,79
atinsay(0,65,'RB+/B',"Page " + str(page_one+l,1,0)+ " of  "  +  str(max_pgs,1,0)

do while  .t.  && math review lopp start
   bad_hrs =  .f.
   bad_rsp =  .f.
   § 2, 0, 7, 78 box "UAi'UAA1 '•
   § 3, 3 say "Reporting Burden:"
   @ 3, 40 say "Responses:"
   @ 3, 58 say "Reporting Hours:"
   @ 4, 17 say "In  Inventory  (old):"
   @ 5, 17 say "New  (if changed):"
   @ 6, 17 say "Difference  (new-old):"
   @ 8, 0, 15, 78 box "UAe'UAA3  "
   @ 9, 3 say "Adjustments:"
   @ 9, 40 say "Responses:"
   @ 9, 58 say "Reporting Hours:"
   @ 10,  17  say  "Correction-Error:"
   @ 11,  17  say  "Correction-Reestimate:"
   @ 12,  17  say  "Change in  use:"
   @ 14,  3 say "Program Changes:"
   @ 16,0,22,78  box "UAi'UAA3  "
   @ 17,3 say "ICW  Comments:  (Use  Arrow keys to Scroll; Press  when d
    @ 4,  40 get
    § 4,  60 get
    @ 5,  40 get
    @ 5,  60 get
    read
    mresp_diff •
    mhours diff
mrespd_old picture  '9999999999'
mhours_old picture  '9999999999'
mresp_new picture  '9999999999'
mhours_new picture  '9999999999'

=  mresp_new -  mrespd_old
= mhours new  - mhours  old
    § 6, 40 get mresp_diff picture '9999999999' valid v_rspdif(mresp_diff)
    *READ
    @ 6, 60 get mhours_diff picture '9999999999'valid v_hrsdif(mhours_diff)
    *READ
    @ 10, 40 get mrsp_adj_er picture '9999999999'
    @ 10, 60 get mhrs_adj_er picture '9999999999'
    @ 11, 40 get mrspadjrest picture '9999999999'
    @ 11, 60 get mhr_adjrest picture '9999999999'
    @ 12, 40 get mrspadjciu picture '9999999999'
    @ 12, 60 get mhr_adj_ciu picture '9999999999'
    @ 14, 40 get mrsp_prg_ch picture '9999999999'
    @ 14, 60 get mhrs_prg_ch picture '9999999999'

    read

    tmp_color = setcolor()
    set color to "GR+/B,RB+/B,,,RB+/B"
    micw_cmnts = memoedit(micw_cmnts, 18,3,21,75)
    set color to &tmp_color

-------
  if  mresp_diff  #  (mrsp_adj_er + mrspadjrest + mrspadjciu + mrsp_prg_ch)
     bad_rsp = .t.
  endif
  if  mhours_diff #  (mhrs_prg_ch + mhrs_adj_er + mhr_adjrest + mhr_adj_ciu)
     bad_hrs = .t.
  endif

  if  bad_rsp .or. bad_hrs
     temp_color = setcolor()
     set color to "N/R,N/R,,,N/R"
     save screen
     @ 16,0,22,78 box "UAi5 UAA3  "
     *  @ 20,2,23,77 BOX "UA£3 UAAJ  "
     if bad_rsp .and. bad_hrs
        §17,8 say ;
           "Sum of Adjustments &  Program Changes does NOT equal the Differen
        @ 18,18 say "as input for BOTH Responses and Reporting Hours."
     elseif bad_rsp
        @ 17,13 say "Sum of Adjustments & Program Changes does NOT equal the
        @ 18,24 say "Difference as input for Responses."
     elseif bad_hrs
        @ 17,13 say "Sum of Adjustments & Program Changes does NOT equal the
        @ 18,21 say "Difference as input for Reporting Hours."
     endif
     tone(220,3)
     tone(220,3)
     @ 20,4 say  ;
        "If you want to  leave the data as is enter  at the prompt;  otherw
     @ 21,12  say  ;
        "enter   to review/edit the data.  Enter selection: "

     *    ATINSAY( 2 4 , 0, ' W/R' ,CENTRING;
        *("eview & edit data or ontinue.   Enter Selection:  "))
     @ 21,64  get response pict "!" valid  (response == "R"  .or.  response == "
     read
      if response == "C"
        set color  to &temp_color
        restore screen
        exit
      endif
      set  color to &temp_color
      restore screen
   else
      exit
   endif  && for if bad difference(s)
enddo  &&  for math review lopp

***********   Finished with ICW Form - Review/Abort/Post  Check Now  **********
stoptest = stop_tst()
if stoptest="E"
   if purpose=0
      delete
      pack
   endif
   * in the case of editing record is abandoned, not deleted.
   set delimiters off
   return
endif
clr_msgs()

-------
 nddo       &&  end of main loop

 ** if not abandoned in the stoptest,  then replacements made below

replace icr_number with _icr_numbe
"eplace icw_logged with micw_logged
 eplace desk_offc with mdesk_offc
_eplace icb_omb_no with micb_omb_no
replace effct_date with meffct_date
 eplace agncy_numb with magncy_numb
 eplace funct_code with mfunct_code
replace expir_date with mexpir_date
 eplace respd_old with mrespd_old
 eplace hours_old with mhours_old
j. eplace resp_new with mresp_new
^eplace hours_new with mhours_new
 eplace resp_diff with mresp_diff
 eplace hours_diff with mhours_diff
replace rsp_adj_er with mrsp_adj_er
 eplace hrs_adj_er with mhrs_adj_er
 eplace rspadjrest with mrspadjrest
replace hr_adjrest with mhr_adjrest
-eplace rspadjciu with mrspadjciu
 eplace hr_adj_ciu with mhr_adj_ciu
«. eplace rsp_prg_ch with mrsp_prg_ch
replace hrs_prg_ch with mhrs_prg_ch
 eplace icw_comnts with micw_cmnts

*  set delimiters off
 eturn

„****** End of PROC  icw_inpt
*********************************
         *********************

          Function: V_RSPDIF()

        Called by:  ICWINPUT       (procedure in ICW_INPT.PRG)

        ****************************************************************
 unction  v_rspdif
 parameters rsp_dif
 nrivate allow

  How = 0

  f (mresp_diff = mresp_new - mrespd_old)
    return(.t.)
 end if
 *-.emp_color =  setcolor()
 set color to  »W/R,R/W, , ,W/R"
 j  24,0 say;
    11 Difference  does NOT equal New minus Old. Should I allow data entry? Enter  (
  one(220,3)
 .one(220,3)
 *@ 24, 76 GET allow PICT "!" VALID (allow == "Y" .OR. allow == "N")
  READ
 illow = inkey(60)
 if allow = 89 .or. allow = 121
    set color to  &temp_color

-------
   return ( . t . )
else
   set color to &temp_color
   return ( . f . )
end if
  End of FUNG v_rspdif
  !       Function: V_HRSDIF()
*!
  1      Called by: ICWINPUT        (procedure in ICW_INPT.PRG)
  !
-i          Calls: CLR_MSGS        (procedure in NEWTEMP4 . PRG)
* i

_ met ion v_hrsdif
parameters hr_dif
  rivate allow

allow = 0

  £  (mhours_diff = mhours_new -  mhours_old)
    return ( . t . )
endif
  >mp_color = setcolor()
  2t color to "W/RfR/W, , ,W/R"
@ 24,0 say;
    11 Difference does  NOT equal  New minus Old.  Should I allow data entry? Enter  (
  jne(220,3)
tone (220, 3)
* @ 24,  76 GET allow  PICT " 1 " VALID (allow ==  "Y" .OR. allow == "N")
   read
_llow =  inkey(60)
 if allow = 89  .or.  allow = 121
    clr_msgs()
    set  color to  &temp_color
    return ( . t . )
  Ise
    clr_msgs()
    set  color to  &temp_color
    return ( . f . )
  ndif
  : EOF:  ICW INPT.PRG

-------
  *********************************************************************

   Procedure  file: OMBRESP.PRG

           System: Paper Work Reduction Managemnt System
           Author: John Pitts,  Fred,  Melissa,  Karen
        Copyright  (c)      ,  Compex Corporation
                  09/28/89      19:30
Last modified

Procs & Fncts
                   OMB_PKG_RS
                   OMBICW
        Documented 12/28/89  at 17:35
                                                SNAP!  version  3.12e
 ************************************************************
*         PROCEDURE:  OMBRESPO  (for the PRAMS project)      *
          Description:  This procedure inputs the data from  *
   the OMB response form.   The data goes first into         *
*         the PACKAGE database (eventually updating  the    *
   central ICR database).                                    *
        Procedure: OMB_PKG_RS

        Called by: WHICHOMB

            Calls: STOP_TST()
                               (procedure  in MENUS.PRG)

                               (function   in SF83F.PRG)
procedure omb_pkg_rs

 age_one = 1
 ax_pgs = 2
stoptest = "C"
 ad_rpt_df =  .f.
 ad_rsp_df =  .f.
bad_sumrsp =  .f.
1 ad_sumrpt =  .f.
 msg_resp = "R"
                                  && "C"  -> continue screen display/review
                                  && difference flags for validation

                                  && mismatch flags old sums vs. new
 nrivate micrnumber, mpkgnumber, momb_xdate,  momb_apprv,  mcur_ombno
  rivate mombprvrsp, mombprevhr, mombnewrsp,  mombnewrpt
  rivate mombrsperr, mombrpterr,mombrspest, mombrptest,
 private mombrspciu, mombrptciu

  ****  this  is will be calculated
 private mombrespadj, mombrptadj
 ********** **********************

 t-rivate mombpgcrsp, mombprgrpt
 orivate momb_cndit, morob_cmnts

  * Init local  Input vars  with PACKAGE which  was open/selected in caller *****
  icrnumber = icr_number
  pkgnumber = pkg_number
 momb_xdate = omb_x_date
 TTiomb_apprv = omb_approv
                                   && passed from outside
                                   && passed from outside
                                   && OMB Approved expiration date
                                   && ICR OMB Approval flag

-------
 ;ur_ombno
mombprvrsp
 )mbprevhr
 jmbnewrsp
mombnewrpt
™resp_diff
 rpthr_dif

mombrspadj
 ambrptadj
 ambrsperr
mombrpterr
 ambrspest
 Dmbrptest
mombrspciu
mombrptciu
 ambpgcrsp
 Dmbprgrpt
momb_cndit
 amb cmnts
cur_omb_no
ombprevrsp
ombprevhrs
ombnewresp
ombnewrpt
mombnewrsp
mombnewrpt

ombrespadj
ombrptadj
0
0
0
0
0
0
ombprgcrsp
ombprgrpt
omb_condit
omb  cmnts
mombprvrsp
mombprevhr
&& OMB assigned OMB number
&& Previous Total number of responses
&& Previous Total reporting hours
&& New Total number of responses
&& New Total reporting hours
&& Response differ = New total - Old
&& Rpt Hours differ = New total - Old

&& New adjustments to numb of responses
&& New adjustments to reporting hours
&& These 6 are the break out that OMB
&& provides for the adjustments to  both
&& reporting hrs and numb of responses
            && New Program changes to  #  of  responses
            && New Program changes to  Reporting Hrs
            && Conditions for renewal  flag
            && Conditions will be palced here
 ***************  Get existing Summary totals for Update  ********************
  sleet icr
 _sum_resp
 "sum_rpthr
  sumadjrsp
  sumadj rpt
 _sum_pcrsp
 ~3um_pchrs
  sxp_date
  icr ombno
 sum_resp
 sum_rpt_hr
 sum_adjrsp
 sum_adjrpt
 sum_pc_rsp
 sum_pc_hrs
 exp_date
 cur omb no
  ombprvrsp = _sum_resp
  ombprevhr = _sum_rpthr
       && Total  #  of Responses
       && Total  Reporting Hours
       && Total  of Adjustments for  Responses
       && Total  of Adjustments to Reporting Hours
       && Total  Program Changes  for Responses
       && Total  Program Changes  to  Reporting Hours
       && Old OMB  Approved  Expiration Date
       && Old OMB  Assigned  OMB number,  if exists

       && Set Previous Status to old totals
  *************************  Begin Main DO Loop  *****************************
  elect package
 'o while stoptest <> "D"
                            && "D" -> Done,  post record & exit
    ************************* set up First Page *********************************
    set color to "BG+/B,GR+/B,,,RB+/B"
    @ 2,0 clear to 22,79
    atinsay(0,65,'RB+/B1, "Page " +  str(page_one,1,0)  + " of " + str(max_pgs, 1,0
    @ 2, 1, 6, 78 box "UAi'UAA3  "
    § 3, 16 say "OMB Response Data for ICR Number [M+space(7)+"]"
    atinsay(3,50,' RB+/B',str(micrnumber,4,0)+"."+str(mpkgnumber,2,0))
    @ 4,3 to 4,76         && Draw Dividing line
    @ 5,3 say "Approved:(Y/N) "+space(8)+"Expiration Date:"+space(14)+"OMB  #: "
    @ 7, 5, 22, 74 box "UAi'UAA1 "
    @ 8, 7 say "EFFECT ON BURDEN"+space (14) +"RESPONSES"+space (7) +"REPORTING HRS"
    @ 9, 10 say "Previous Status:"
    @ 10, 10 say  "New Status:"
    @ 11, 10 say  "Difference:"
    @ 13, 7 say "EXPLANTION OF THE DIFFERENCE"
    @ 14, 7 say "Adjustments:"
    @ 15, 10 say  "Correction-Error:"

-------
@ 16,  10 say "Correction-Reestimate:"
8 17,  10 say "Change in use:11
@ 18,  10 say "Adjustment Totals:"+space(8)+str(mombrspadj ,10,0)+ ;
   space(5)+str(mombrptadj,10,0)


@ 20,  7 say "Program Changes:11
@ 21,  10 say '(Use "-" for decrease)1

*DO WHILE .T.             && Intermediate do loop for validate & re-enter dat
*@ 3,  18 SAY mICRNUMBER PICTURE '9999'
*@ 3,  23 SAY nPKGNUMBER PICTURE '99'
§ 5, 20 get momb_apprv pict "Y"
@ 5, 42 get momb_xdate
@ 5, 65 get mcur_ombno picture '9999-9999'
@ 9, 38 get mombprvrsp picture '99999999'
@ 9, 55 get mombprevhr picture '99999999'
§10,  38 get mombnewrsp picture '99999999'
@ 10,  55 get mombnewrpt picture '99999999'
read

** Redisplay new difference calculations
mresp_diff = mombnewrsp - mombprvrsp  && Response differ =  New total - Old
@ 11, 36 say mresp_diff pict  "@R [9999999999]"
mrpthr_dif = mombnewrpt - mombprevhr  && Rpt Hours  differ = New  total - Old
@ 11, 53 say mrpthr_dif pict  "@R [9999999999]"

@ 15, 38 get mombrsperr picture '99999999'
@ 15, 55 get mombrpterr picture '99999999'
 @ 16, 38 get mombrspest picture '99999999'
 @ 16, 55 get mombrptest picture '99999999'
 @ 17, 38 get mombrspciu picture '99999999'
 @ 17, 55 get mombrptciu picture '99999999'
 **  the  last  six gets will tabulate later &  replace  the 2 OMB adjustment field
 read

 ******************   Display New Adjustment  Totals   *************************

 mombrspadj  = mombrsperr+mombrspest+mombrspciu
 mombrptad j  = mombrpterr+mombrptest+mombrptciu
 @  18,  37 say mombrspadj  pict  "@R  [999999999]"
 @  18,  56 say mombrptadj  pict  "@R  [999999999]"

 @  21,  38 get mombpgcrsp picture  '99999999'
 @  21,  55 get mombprgrpt picture  '99999999'

 read
 ************************* set up  Second Page ********************************
 @ 2,0 clear to 22,79
 atinsay(0,65,'RB+/B',"Page "  + str(page_one+l, 1,0)+ " of " + str(max_pgs, 1,0)

 @ 3,  21, 7, 57 box "UAi'UAA3  "
 @ 4,  23 say "is there a condition for renewal"
 @ 5,  23 say "or other comments associated with"
 @ 6,  23 say "this OMB response form?"
 § 9,  1, 22, 78 box "UAi3UAA3  "
 @ 10, 8 say "OMB REMARKS:  (Use Arrow keys to Scroll; Press  when done

 @ 6,  54 get momb_cndit pict  "Y"
 read

-------
if momb_cndit
   tmp_color = setcolor()
   set color to "GR+/B,  G+/B, , ,RB+/B"
   momb_cmnts = memoedit (momb_cmnts , 11 , 2 , 2 1 , 77 , . t . , "" , 70 )
   set color to &tmp_color
endif
                 check Calcs; Set Flags; Do error Loop  *********************
if (mombrspadj+mombpgcrsp) # mresp_diff
   bad_rsp_df = .t.
else
   bad_rsp_df = .f.
endif
if (mombrptadj+mombprgrpt) # mrpthr_dif
   bad_rpt_df = .t.
else
   bad_rpt_df = .f.
endif
if mombprvrsp # _sum_resp
   bad_sumrsp = .t.
else
   bad_sumrsp = . f .
endif
if mombprevhr # _sum_rpthr
   bad_sumrpt = .t.
else
   bad_sumrpt = . f .
endif
temp_color = setcolor()
if bad_rsp_df  .or. bad_rpt_df  .or. bad_sumrsp  .or.  bad_sumrpt
   *   SAVE SCREEN
   tone (220 ,3)
   tone (220, 3)
   temp_color = setcolor()
   set color to "BG+/N,W/N, , , BG+/N"
   @  2,1,23,78 box "E±»Bis±EB  "
   @  3,18 say  "OMB RESPONSE DATA -  INPUT VALIDATION CONFLICT"
   @  4,18 say  " --------------------------------------------- "
   if bad_rsp_df
       atinsay( 6,29,"R+/N", "* Response Difference *")
       atinsay( 7,8,"R+/N",  ;
          "Sum  of all Adjustments &  Prog Changes does NOT equal Difference.")
   else
       @  6,29 say "*  Response Difference *"
       @  7,  10  say  ;
          "NO ERROR  - Difference equals sum of Adjustments & Prog Changes."
    endif

    if bad_rpt_df
       atinsay( 9,31,"R+/N", "* Reporting Hours *")
       atinsay( 10,  8, "R+/N", ;
          "Sum of all Adjustments & Prog Changes does NOT equal Difference.")
    else
       § 9,31 say "* Reporting Hours *"
       @ 10,  10 say   ;
          "NO ERROR - Difference equals sum of Adjustments &  Prog Changes."
    endif

    if bad_sumrsp

-------
     atinsay( 12,27/"R+/N11,11* Response Previous Status *")
     atinsay( 13,  8,  "RVN",  ;
        "New OMB Previous Status does NOT equal existing PRAMS II Status.")
  else
     6 12,27 say "* Response Previous Status *"
     § 13, 15 say ;
        "NO ERROR - New and existing data reconciled."
  endif

  if bad_sumrpt
     atinsay( 15,25, "RVN", "* Reporting Hrs Previous Status *")
     atinsay( 16, 8, "R+/N",  ;
        "New OMB Previous Status does NOT equal existing PRAMS II Status.")
  else
     § 15,25 say "* Reporting Hrs Previous Status *"
     @ 16,15 say ;
        "NO ERROR - New and existing data reconciled.11
  endif

  @  18,10 say ;
     "***  Notify Desk Officer of ERROR before posting data  ***»
  @  20,8  say ;
     "You may enter  to review and edit data to correct error(s)  or"
  @  21,5  say ;
     "enter  to escape without saving or enter  to  post data  as is."
  @  22,25 say "Enter Selection:(R/E/D)"get emsg_resp;
     pict "!" valid  (emsg_resp == "R"  .or. emsg_resp ==  "D" .or.  ;
     emsg_resp ==  "E")
  read
  *  IF emsg_resp ==  "D"  .OR.  emsg_resp == "E"
  set color  to &tenp_color
  *  RESTORE SCREEN
  *  EXIT
  *  ENDIF
  if emsg_resp ==  "R"
     set  color to  &temp_color
     atinsay(23fO,'GR+/B1,replicate("A",80))
      loop
  endif
   *  RESTORE SCREEN

   *   ELSE                    &&  All error  flags  are clear
   *   SET COLOR TO &temp_color
   *   RESTORE SCREEN
   *     EXIT

endif  && if any bad flags are set
* ENDDO  && intermediate Validation loop

if emsg_resp == "E"
   return
endif
if emsg_resp == "D"
   exit
endif
stoptest = stop_tst()
if stoptest="E"
   return
endif

-------
 iddo
        && end of main loop
 •* if not abandoned in the stoptest,  then replacements made below ***********
- REPLACE ICR_NUMBER WITH mICRNUMBER
* REPLACE PKG_NUMBER WITH mPKGNUMBER
 iplace omb_x_date with momb_xdate
 iplace omb_approv with momb_apprv
replace cur_omb_no with mcur_ombno
 iplace ombprevrsp with mombprvrsp
 >place ombprevhrs with mombprevhr
replace ombnewresp with mombnewrsp
 'tplace ombnewrpt with mombnewrpt
 splace ombrespadj with mombrsperr+mombrspest+mombrspciu
iplace ombrptadj with mombrpterr+mombiptest+mombrptciu
replace ombprgcrsp with mombpgcrsp
  place ombprgrpt with mombprgrpt
  ' mcur_ombno <> _icr_ombno
   replace new_no_flg with .t.
  idif
  •place omb_condit with momb_cndit
replace omb_cmnts with momb_cmnts

  r****************  NOW update existing ICR Totals  *************************
                                           && NEW Total  #  of  Responses
                                           && Total Reporting Hours
select icr
  splace sum_resp with mombnewrsp
  tplace sum_rpt_hr with mombnewrpt
* Total of Adjustments for Responses
  splace sum_adjrsp with _sumadjrsp+mombrsperr+mombrspest+mombrspciu
  Total of Adjustments to Reporting Hours
j. ^place sum_adjrpt with _sumadjrpt+mombrpterr+mombrptest+mombrptciu
* Total Program Changes for Responses
  iplace sum_pc_rsp with _sum_pcrsp+mombpgcrsp
  Total Program Changes to Reporting Hours
replace sum_pc_hrs with _sum_pchrs+mombprgrpt
  iplace exp_date with momb_xdate
 replace cur_omb_no with mcur_ombno
                                          && Old OMB Approved  Expiration Date
                                          && Old OMB Assigned  OMB number
 return

  if  End  of  PROC omb_pkg_rs


  «r* Start  of OMB ICW.PRG
           PROCEDURE:  OMBICW    (for the PRAMS project)
 *         Description:  This procedure inputs the data from
           the EPA form called the Inventory Correction
           Worksheet.   The data is input to the ICW database *
 *         much as under icw_inpt.prg, but the data is input *
           into special OMB fields in this ICW database.     *
           Record is entered with record pointer or a blank  *
           already set up.                                   *
 *************************************************************

-------
*!
        Procedure:  OMBICW

        Called by:  WHICHOMB

            Calls:  STOP_TST()
                     (procedure in MENUS.PRG)

                     (function  in SF83F.PRG)
  *********************************************************************
  ocedure ombicw
parameters purpose,  _icr_numbe

  lect icw
  * initialize and fill memvar duplicates for all replacable fields,
  ivate micr_numbf  momb_agncy
private mombfuncod, mombexpire
  ivate mombrspold, mombhrsold
  ivate mombrspnew, mombhrsnew
                                mombrsperr
                                mombhrsest
private mombrspdif,
—ivate mombhrserr,
       mombhrsdif,
       mombrspest,
  ivate mombrspciu, mombhrsciu
r*. ivate mombrsppch, mombhrspch, micw_cmnts
orivate _totrspadj,_tothrsadj , emsg_resp, stop_test
  otrspadj = 0
 "tothrsadj = 0

  cr numb = icr number
                  && local vars for calcs
 ******* The OMB APPROVED  fields are first  filled  with the  requested  ********
.. jmb_agncy
mombfuncod
  tmbexpire
  imbrspold
mombhrsold
  imbrspnew
  imbhrsnew
mombrspdif
mnmbhrsdif
  jmbrsperr
  >mbhrserr
mombrspest
  imbhrsest
  >mbrspciu
mombhrsciu
-ombrsppch
  imbhrspch
...icw cmnts
agncy_numb
funct_code
expir_date
respd_old
hours_old
resp_new
hours_new
resp_diff
hours_diff
rsp_adj_er
hrs_adj_er
rspadjrest
hr_adj rest
rspadjciu
hr_adj_ciu
rsp_prg_ch
hrs_prg_ch
icw  comnts
&& old
&& old
&& OMB
&& OMB
&& OMB
&& OMB
   \
                                    \
                                     \
&&
&&
&&
&&   /
&&  /
&& /
&& OMB
&& OMB
                                      response  inventory
                                      rpt hrs inventory
                                      approved  response inventory
                                      approved  rpt hrs inventory
                                      approved  resp difference
                                      approved  rpt hrs difference
        These six are OMB approved
        Adjustments broken out
                                       approved Prg responses changes
                                       approved rpt hrs Prg changes
  ilect icr

  Lcr_resp
  Lcr_rpthr
  _icradjrsp
  icradjhrs
 sum_resp
 sum_rpt_hr
 sum__ad j rsp
 sum_adj rpt

-------
 Lcrpcrsp  = sum_pc_rsp
_icrpchrs  = sum_pc_hrs
 Lcr_xdate = exp_date

select lew

 ige_one=l
 ix_pgs=2
emsg_resp = "R"
 :optest = "C"

do while stoptest <> "D"

   ************************* set up First Page *********************************
   set color to "BG+/B,GR+/B,,,RB+/B"
   @ 2,0 clear to 22,79
   atinsay(0,65,'RB+/B1, "Page " +  str(page_one,l,0)  + "  of "  + str(max_pgs,l,0

   @ 2, 2, 4, 76 box "UAi'UAA5 "
   @ 3, 10 say "OMB Response Data Input for an ICW with ICR #:  " ;
      +substr(str((micr_numb+10000),5,0),2,4)
   @ 5, 3 say "Date of  completion of this ICW:"
   @ 7, 3 say "FROM:(desk  officer responsible)"
   @ 9, 3 say "Docket number or OMB #:"
   @ 11, 3 say "Effective  date of correction(s):"
   § 13, 5,  22, 73 box  "UAi'UAA1 "
   @ 14, 10  say "  ITEM        CURRENT       REQUESTED"+space(6) +"OMB APPROVED"
   @ 15, 8 to 15,71
   @ 16, 7 say "Agency/Bureau  #: "
   @ 18, 7 say "Functional code: "
   @ 20, 7 say "Expiration date: "
   @ 14,54 say "OMB  Approved:  "
   *e  16,  54 SAY  "[         ]"
   *§  18,  54 SAY  "[      ]"
   *@  20,  54 SAY  "[           ]"

    @  5,  37  say  icw_logged
    @ 7,  37  say desk_offc
    @  9,  37  say  icb_omb_no picture  "@R 9999-9999"
    @  11,  37  say  effct_date
    @  16,  27  say  substr(str((micr_numb+10000) ,5,0),2,4)
    @  16,  39  say  momb_agncy
    @  16,  56  get  momb_agncy && PICTURE "@B "
    @  18,  25  say mombfuncod
    @  18,  39  say mombfuncod
    @  18,  56 get mombfuncod && PICTURE "@B "
    @  20,  25 say _icr_xdate
    @ 20,  39 say expir_date
    @ 20,  56 get mombexpire

    read

    ************************* set up Second Page ********************************
    @ 2,0 clear to 22,79
    atinsay(0,65,'RB+/B1 ,"Page " +  str(page_one+1,1,0)+ "  of "  + str(max_pgs, 1,0)

    § 2, 33  say "REQUESTED"+space(18)+"OMB APPROVED"
    @ 3, 26  say "Responses    Report Hrs       Responses    Report Hrs"

    @ 4, 0,  9, 79 box "UAi'UAA3 "

-------
§ 5, 3 say "In Inventory (old):"
@ 6, 3 say "New (if changed):"
@ 8, 3 say "Difference (new - old):"
@ 10, 0, 14, 79 box "UAi'UAA1  "
@ 11, 3 say "Correction - Error:"
@ 12, 3 say "Correction-Reestimate:"
@ 13, 3 say "Change in use:"
@ 15, 0, 17, 79 box "UAt'UAA'  "
@ 16, 3 say "Program Changes:"
§ 18, 0, 22, 79 box
@ 19, 2 say "ICW Comments: (Use Arrow keys to Scroll; Press CTRL-W when done)

*DO WHILE .T.   && loop for ERROR review
@ 5, 26 say respd_old picture '9999999999'
§ 5, 39 say hours_old picture '9999999999'
@ 5, 54 get mombrspold picture '9999999999'
§ 5, 67 get mombhrsold picture '9999999999'
@ 6, 26 say resp_new picture '9999999999'
@ 6, 39 say hours_new picture
§ 6, 54 get mombrspnew picture
@ 6, 67 get mombhrsnew picture
@ 8, 26 say resp_diff picture
@ 8, 39 say hours_diff picture
@ 8, 54 get mombrspdif picture
@ 8, 67 get mombhrsdif picture
@ 11, 26 say rsp_adj_er picture
§ 11, 39 say hrs_adj_er picture
@ 11, 54 get mombrsperr picture
@ 11, 67 get mombhrserr picture
§ 12, 26 say rspadjrest picture
@ 12, 39 say hr_adjrest picture
§ 12, 54 get mombrspest picture
@ 12, 67 get mombhrsest picture
§ 13, 26 say rspadjciu picture
§ 13, 39 say hr_adj_ciu picture
@ 13, 54 get mombrspciu picture
@ 13, 67 get mombhrsciu picture
@ 16, 26 say rsp_prg_ch picture
§ 16, 39 say hrs_prg_ch picture
@ 16, 54 get mombrsppch picture
§ 16, 67 get mombhrspch picture
'9999999999'
 '9999999999'
 '9999999999'
'9999999999'
 199999999991

 '9999999999'
 199999999991

  '9999999999
  '9999999999
  •9999999999
  '9999999999
  •9999999999
  •9999999999
  •9999999999
  •9999999999
  9999999999'
  •9999999999
  •9999999999
  '9999999999
  '9999999999
  •9999999999
  •9999999999

  '9999999999
read
tmp_color = setcolor()
set color to "GR+/B,G+/B»i,RB+/B"
micw_cmnts=memoedit (micw_cmnts ,20,3,21,78)
set color to &tmp_color

*************  Finished Input - Test for Post/Review/Abort   *****************

_totrspadj = mombrsperr+mombrspest+mombrspciu
_tothrsadj = mombhrserr+mombhrsest+mombhrsciu

if (_totrspadj+mombrsppch)  # mombrspdif
   bad_rsp_df = .t.
else
   bad_rsp_df = .f.
endif
if (_tothrsadj+mombhrspch)  # mombhrsdif

-------
   bad_rpt_df = .t.
else
   bad_rpt_df = .f.
endif
if mombrspdif # (mombrspnew - mombrspold)
   bad_sumrsp = .t.
else
   bad_sumrsp = .f.
endif
if mombhrsdif # (mombhrsnew - mombhrsold)
   bad_sumrpt = .t.
else
   bad_sumrpt = .f.
endif

if bad_rsp_df .or. bad_rpt_df .or. bad_sumrsp .or. bad_sumrpt
   save screen
   tone(220,3)
   tone(220,3)
   temp_color = setcolorQ
   set color to "BG+/N,W/N,,,BG+/N"
   @ 2,1,23,78 box "Ei»fl*iEfl "
   @ 3,18  say "OMB RESPONSE  DATA  - INPUT VALIDATION CONFLICT"
   @ 4,18  say "	"
   if bad_rsp_df
      atinsay( 6,29,"R+/N","* Response Difference *")
      atinsay( 7,8,"R+/N",  ;
          "Sum of  all  Adjustments  & Prog Changes does NOT  equal Difference.")
   else
      @  6,29 say  "* Response Difference *"
      @  7, 10  say ;
          "NO ERROR -  Difference equals sum  of Adjustments & Prog Changes."
   endif

    if bad_rpt_df
      atinsay(  9,31,"R+/N",  "*  Reporting  Hours  *")
      atinsay(  10, 8, "R+/N",  ;
          "Sum of  all  Adjustments  &  Prog Changes does NOT  equal Difference.")
    else
       @  9,31 say  "* Reporting  Hours  *"
       @  10, 10 say ;
          "NO ERROR - Difference equals  sum of Adjustments & Prog Changes."
    endif

    if bad_sumrsp
       atinsay( 12I27,"R+/N","* New-Old Response Status *")
       atinsay( 13,10, "R+/N",   ;
           "New Responses minus Old Inventory does  NOT equal Difference.")
    else
       @ 12,27 say "* New-Old Response Status *"
       @ 13, 15 say ;
           "NO ERROR - New minus Old equals Difference."
    endif

    if bad_sumrpt
       atinsay( 15,25, "R+/N",  "* New-Old Reporting Hrs Status  *")
       atinsay( 16, 8, "R+/N",  ;
           "New Reporting Hrs minus Old Inventory does NOT  equal  Difference.")
    else
       @  15,25 say "* New-Old Reporting Hrs Status *"

-------
        @  16,15  say ;
           "NO ERROR - New minus  Old equals Difference.11
     endif

     § 18,10 say ;
        "***  Notify Desk Officer of ERROR before posting data  ***••
     @ 20,8 say  ;
        "You may enter  to review and edit data to correct error(s) or"
     @ 21,5 say  ;
        "enter  to escape without saving or enter  to post data as is."
     @ 22,25 say "Enter Selection:(R/E/D)"get emsg_resp;
        pict "!" valid (emsg_resp == "R" .or. emsg_resp == "D"  .or.  ;
        emsg_resp == "E")
     read
     * IF emsg_resp == "D" .OR. emsg_resp == "E"
     set color to &temp_color
     *  RESTORE  SCREEN
     *  EXIT
     * ENDIF
     if emsg_resp == "R"
        set color to &temp_color
        atinsay(23,0,'GR+/B1,replicate("A",80))
        loop
     endif
     * RESTORE SCREEN

     *  ELSE                    &&' All  error flags are clear
     *  SET COLOR TO  &temp_color
     *  RESTORE SCREEN
     *    EXIT

  endif   && if any bad flags are  set
  *  ENDDO   && intermediate Validation loop

  if emsg_resp ==  "E"
     return
  endif
  if emsg_resp ==  "D"
     exit
  endif
  stoptest  =  stop_tst()
  if stoptest ="E"
      close  all
      return
  endif

 iddo   && End of  main loop

"**  if not abandoned in the stoptest,  then replacements made below ***********

 •place ombagncyno with momb_agncy
_ jplace ombfuncode with mombfuncod
replace ombexpire with mombexpire

 aplace ombrespold with mombrspold
replace ombhrs_old with mombhrsold
 aplace ombrespnew with mombrspnew
 aplace ombhrs_new with mombhrsnew
..aplace ombrespdif with mombrspdif
replace ombhrs_dif with mombhrsdif

-------
  iplace ombrspader with monbrsperr
replace ombhrsader with mombhrserr
—.place ombrsadres with mombrspest
  splace ombhradres with mombhrsest
^place ombrsadciu with mombrspciu
replace ombhradciu with mombhrsciu
  iplace ombrsprgch with mombrsppch
  :place ombhrprgch with mombhrspch
replace icw_comnts with micw_cmnts

  ***************  NOW update the ICR SUMMARY STATUS totals  ****************
select icr

   mombrspdif # 0 .or. mombrspdif # icw->resp_diff
   replace sum_resp with mombrspnew
endif
   mombhrsdif # 0  .or. mombhrsdif # icw->hours_diff
   replace sum_rpt_hr with mombhrsnew
endif
  ;place sum_adjrsp with _icradjrsp + _totrspadj
  splace sum_adjrpt with _icradjhrs + _tothrsadj
replace sum_pc_rsp with _icrpcrsp + mombrsppch
*"»place sum_pc_hrs with _icrpchrs + mombhrspch

_J mombexpire <> _icr_xdate
   replace exp_date with mombexpire
  idif

return

  • End of  PROC OMBICW

** End of File OMBRESP.PRG
   EOF: OMBRESP.PRG

-------
TIDE*
  •   Corporation^

-------