-------
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^
-------