id division. program-id. nameadrs1. ***************************************************************** * Name & Address Data Entry Program, by Owen Townsend, June 2009 * - Demo data entry screen program for Micro Focus COBOL * See documentation at: www.uvsoftware.ca/mvscobol.htm#Part_7 * - subdirs required, compiling, testing, verifying * You may download from: www.uvsoftware.ca/nameadrs1.cbl * * ** Name & Address Entry Screen ** * * Telephone: [ 6049805434 ] * Name: [ TOWNSEND, OWEN ] (Last, First) * Address1: [ 4667 HOSKINS RD. ] * Address2: [ ] * City: [ NORTH VANCOUVER ] * State: [ BC ] * Zip: [ V7K2R3 * * Message: * * Command---> ______________________________ <--- * a=add,c=change,d=delete,n=next,p=prior,b=Blankscreen,q=quit * ** Command Examples ** * --> a,b <-- Add record & Blank screen for next add * --> a <-- Add, No Blank for multi names same adrs * --> n1,,604 <-- read Next record key1 => 604....... * --> n2,,SMIT <-- read Next record key2 => SMIT...... * --> c,n <-- Change current record & read Next * HomeKey=1stField, EndKey=CommandField, TabKey=NextField * * ** record layout ** * 01 na-rec. * 05 na-tel pic x(010). 0000 0009 010 * 05 na-name pic x(030). 0010 0039 030 * 05 na-adrs1 pic x(030). 0040 0069 030 * 05 na-adrs2 pic x(030). 0070 0099 030 * 05 na-city pic x(030). 0100 0129 030 * 05 na-state pic x(030). 0130 0159 030 * 05 na-zip pic x(012). 0160 0171 012 * 05 filler001 pic x(083). 0172 0254 083 * * logical rec-size=255 (ISAM), physical rec-size=256 (for uvhd) * key1 = telephone#, key2 = name * *eject * ** commands ** * * a=add, c=change, d=delete, n1=nextkey1, n2=nextkey2, * p1=priorkey1, p2=priorkey2, b=blankscreen, q=quit * * arg1=a/c/d/n1/n2/p1/p2/b/q * arg2=b/n1/n2 * arg3=999 - 1st few digits of Next/Prior key1 (tel#) * arg3=XXX - 1st few chars of Next/Prior key2 (name) * * a - Add record, do not Blank screen * (allows change current N&A for next similar N&A) * a,b - Add record & Blank screen for next enter * a,n1 - Add & get Next key1 (for change ?) * a,n2 - Add & get Next key2 (for change ?) * a,n1,604 - Add & get Next key1 > 604........ * a,n2,SMITH - Add & get Next key2 > SMITH...... * * c - Change record (allows same arg2 & arg3 as Add) * d - Delete record (allows same arg2 & arg3 as Add) * * n1 - get Next record by key1 (higher than current key1) * n - 'n' defaults to 'n1' * n2 - get Next record by key2 (higher than current key2) * n1,,604 - get Next by key1 (higher than arg3) * n2,,SMITH - get Next by key2 (higher than arg3) * * p - get Prior record (allows same arg2 & arg3 as Next) * b - Blank screen (to Add a new record ?) * q - Quit the program * * ** compile & test program ** * * 1. mfcbl1 program.cbl <-- compile program * 2. makeISF2 dat1/nameadrs1 255 0,10,10,30 <- create 2 dummy recs * 3. export NAMEADRS=dat1/nameadrs1 <-- export external name * 4. cobrun cblx/nameadrs1 <-- execute program * 5. vi dat1/nameadrs1.dat <-- investigate with vi * * compile script at: 'http://www.uvsoftware.ca/mvscobol.htm#5E1' * subdir setup at: 'http://www.uvsoftware.ca/mvscobol.htm#7B1' * Directives at: 'http://www.uvsoftware.ca/mvscobol.htm#5D1' * file handler config 'http://www.uvsoftware.ca/mvscobol.htm#5D1' * Error codes at: 'http://www.uvsoftware.ca/cnvaids.htm#5F1' * * makeISF2 not essential, will create file (ignore err #23 N/F) * *eject environment division. special-names. console is crt cursor is cursr crt status is key-status. input-output section. file-control. select nameadrs assign external nameadrs organization is indexed access is dynamic record key is na-tel alternate key is na-name with duplicates file status is na-status. data division. file section. fd nameadrs. 01 na-rec. 05 na-tel pic x(010). 05 na-name pic x(030). 05 na-adrs1 pic x(030). 05 na-adrs2 pic x(030). 05 na-city pic x(030). 05 na-state pic x(030). 05 na-zip pic x(012). 05 filler pic x(083). * working-storage section. 01 ws1-rec. 05 ws1-tel pic x(010). 05 ws1-name pic x(030). 05 ws1-adrs1 pic x(030). 05 ws1-adrs2 pic x(030). 05 ws1-city pic x(030). 05 ws1-state pic x(030). 05 ws1-zip pic x(012). 05 filler pic x(083). * 01 ws2-rec. 05 ws2-tel pic x(010). 05 ws2-name pic x(030). 05 ws2-adrs1 pic x(030). 05 ws2-adrs2 pic x(030). 05 ws2-city pic x(030). 05 ws2-state pic x(030). 05 ws2-zip pic x(012). 05 filler pic x(083). * 01 na-stuff. 05 na-status pic x(2). 88 na-status-fnf value "35". 88 na-status-rnf value "23". 88 na-status-eof value "10". 05 na-namexln pic x(8) value "NAMEADRS". 05 na-namexfn pic x(60) value spaces. 05 na-commas pic 9(3) value zero. * *eject 01 cmds. 05 cmd1 pic x(30). 05 cmd2 pic x(30). 01 cmdxs. 05 cmdx pic x(30). 05 cmdx1 pic x(30). 05 cmdx2 pic x(30). 05 cmdx3 pic x(30). 05 cmdx4 pic x(30). 05 cmdx11 pic x. 05 cmdx12 pic x. 05 cmdx21 pic x. 05 cmdx22 pic x. 05 cmdx31 pic x. 05 cmdx32 pic x. * 01 msgs. 05 msg1 pic x(60). 05 msg2 pic x(60). * 01 cursr. 05 cursr-row pic 99. 05 cursr-col pic 99. * 01 key-status. 05 key-type pic x. 05 key-code1 pic 99 comp-x. 05 key-code2 pic 99 comp-x. * *eject * ** screen section ** screen section. 01 screen1. 03 blank screen. 03 line 03 column 17 value "** Name & Address Entry Screen **". * 03 line plus 2 column 04 value "Telephone: [ ". 03 column 17 pic 9(10) using ws1-tel. 03 column 29 value " ]". 03 line plus 1 column 04 value "Name: [ ". 03 column 17 pic x(30) using ws1-name. 03 column 47 value " ] (Lastname, Firstname)". 03 line plus 1 column 04 value "Address1: [ ". 03 column 17 pic x(30) using ws1-adrs1. 03 column 47 value " ]". 03 line plus 1 column 04 value "Address2: [ ". 03 column 17 pic x(30) using ws1-adrs2. 03 column 47 value " ]". 03 line plus 1 column 04 value "City: [ ". 03 column 17 pic x(30) using ws1-city. 03 column 47 value " ]". 03 line plus 1 column 04 value "State: [ ". 03 column 17 pic x(30) using ws1-state. 03 column 47 value " ]". 03 line plus 1 column 04 value "Zip: [ ". 03 column 17 pic x(12) using ws1-zip. 03 column 27 value " ]". * 03 line plus 2 column 04 value "Message: ". 03 column 17 pic x(60) from msg1. 03 line plus 1 column 17 pic x(60) from msg2. * 03 line plus 1 column 04 value "Command---> ". 03 column 16 pic x(30) to cmd2. 03 column 46 value " <---". 03 line plus 1 column 04 value "a=add, c=change, d=delete, n=next, p=prior, ". 03 column 48 value "b=Blank screen, q=quit". * 03 line plus 2 column 21 value "** Command Examples **". 03 line plus 1 column 04 value "--> a,b <-- Add record & Blank screen for next add". 03 line plus 1 column 04 value "--> a <-- Add, No Blank for multi names same adrs". 03 line plus 1 column 04 value "--> n1,,604 <-- read Next record key1 => 604.......". 03 line plus 1 column 04 value "--> n2,,SMIT <-- read Next record key2 => SMIT......". 03 line plus 1 column 04 value "--> c,n <-- Change current record & read Next". 03 line plus 1 column 04 value "HomeKey=1stField, EndKey=CommandField, TabKey=NextField". * *eject procedure division. init. perform open-na. initialize na-rec. perform readkey1n. * mainloop. move na-rec to ws1-rec. initialize cmds. move 15 to cursr-row. move 04 to cursr-col. perform display-screen1. accept screen1. move ws1-rec to ws2-rec. initialize msgs. perform cmdextract. * * test command1 (a,c,d,n,b,q) if cmdx11 = 'a' perform addrecord else if cmdx11 = 'c' perform changerecord else if cmdx11 = 'd' perform deleterecord else if cmdx11 = 'n' perform nextrecord else if cmdx11 = 'p' perform priorrecord else if cmdx11 = 'b' perform blankscreen else if cmdx11 = 'q' perform quitprogram else move "command1 invalid (not a,c,d,n,b,q)" to msg1. go to mainloop. * * open nameadrs file open-na section. display na-namexln upon environment-name. accept na-namexfn from environment-value. if na-namexfn (1:1) < '0' string "filename: ", na-namexln, " NOT exported" delimited by size into msg1 string "export NAMEADRS=dat1/nameadrs1 <-- example" delimited by size into msg2 display screen1 stop run returning na-status. open I-O nameadrs. if na-status <> "00" string "Next key > read ERROR, file-status = " na-status delimited by size into msg1 string "filename: ", na-namexln, "=" na-namexfn, delimited by size into msg2 display screen1. *** stop run returning na-status. *** cmtd out to run when dummy file not init'd with makeISF2 exit section. * *eject * verify data to be displayed & display screen * - verify telephone# numeric (to prevent "illegal char errmsg") display-screen1 section. if ws1-tel = spaces move zeros to ws1-tel. if ws1-tel not numeric string "Tel# ", ws1-tel, " must be numeric, zero filled for display" delimited by size into msg2 move zeros to ws1-tel. display screen1. exit section. * * extract command components from 30 byte cmd input area * arg1=a/c/d/n1/n2/p1/p2/b/q * arg2=b/n1/n2 * arg3=999 - 1st few digits of Next/Prior key1 (tel#) * arg3=XXX - 1st few chars of Next/Prior key2 (name) cmdextract section. initialize cmdxs. move cmd2 to cmdx. unstring cmdx delimited by ',' into cmdx1, cmdx2, cmdx3, cmdx4. move cmdx1 to cmdx11. move cmdx2 to cmdx21. move cmdx3 to cmdx31. move cmdx1 (2:1) to cmdx12. move cmdx2 (2:1) to cmdx22. move cmdx3 (2:1) to cmdx32. exit section. * *eject * process cmd 'a' = addrecord * a - Add record, do not Blank screen * a,b - Add record & Blank screen for next enter * a,n1 - Add & get Next key1 (for change ?) * a,n2 - Add & get Next key2 (for change ?) * a,n1,604 - Add & get Next key1 > 604........ * a,n2,SMITH - Add & get Next key2 > SMITH...... addrecord section. move ws1-rec to na-rec. call "CBL_TOUPPER" using na-rec by value length na-rec. move zero to na-commas. inspect na-name tallying na-commas for all ','. if na-commas = 0 move "name must include a comma (Lastname, Firstname)" to msg1 exit section. write na-rec. if na-status <> "00" string "add record ERROR, file-status = " na-status delimited by size into msg1 string "filename: ", na-namexln, "=" na-namexfn, delimited by size into msg2 exit section. if cmdx21 = 'b' initialize na-rec. if cmdx21 = 'n' perform getnext. exit section. * * process cmd 'c' = changerecord * Change record options - same arg2 & arg3 options as Add changerecord section. move ws1-rec to na-rec. call "CBL_TOUPPER" using na-rec by value length na-rec. move zero to na-commas. inspect na-name tallying na-commas for all ','. if na-commas = 0 move "name must include a comma (Lastname, Firstname)" to msg1 exit section. rewrite na-rec. if na-status <> "00" string "change record ERROR, file-status = " na-status delimited by size into msg1 string "filename: ", na-namexln, "=" na-namexfn, delimited by size into msg2 exit section. if cmdx21 = 'b' initialize na-rec. if cmdx21 = 'n' perform getnext. exit section. * *eject * process cmd 'd' = deleterecord * Delete record options - same arg2 & arg3 options as Add deleterecord section. move ws1-rec to na-rec. delete nameadrs. if na-status <> "00" string "delete record ERROR, file-status = " na-status delimited by size into msg1 string "filename: ", na-namexln, "=" na-namexfn, delimited by size into msg2 exit section. move "record DELETED" to msg1. if cmdx21 = 'b' initialize na-rec. if cmdx21 = 'n' perform getnext. exit section. * * process cmd 'n' = read Next record with key > * nextrecord command examples & options: * n1 - get Next record by key1 (higher than current key1) * n2 - get Next record by key2 (higher than current key2) * n1,,604 - get Next by key1 (higher than arg3) * n2,,SMITH - get Next by key2 (higher than arg3) nextrecord section. move cmdx12 to cmdx22. perform getnext. exit section. * * process cmd 'p' = read Prior record with key < * priorrecord options - same as nextrecord (see above) priorrecord section. move cmdx12 to cmdx22. perform getprior. exit section. * * process cmd 'b' = Blank screen blankscreen section. initialize na-rec. exit section. * * process cmd 'q' = Quit program quitprogram section. move "program terminated by Quit command" to msg1. display screen1. stop run returning 0. exit section. * *eject * getnext record by key 1 or 2 (1 or 2 stored in cmdx22) getnext. initialize na-rec. if cmdx22 = '2' move ws2-name to na-name if cmdx31 <> ' ' move cmdx3 to na-name end-if perform readkey2n else move ws2-tel to na-tel if cmdx31 <> ' ' move cmdx3 to na-tel end-if perform readkey1n end-if. exit section. * * getprior record by key 1 or 2 (1 or 2 stored in cmdx22) getprior. initialize na-rec. if cmdx22 = '2' move ws2-name to na-name if cmdx31 <> ' ' move cmdx3 to na-name end-if perform readkey2p else move ws2-tel to na-tel if cmdx31 <> ' ' move cmdx3 to na-tel end-if perform readkey1p end-if. exit section. * *eject * read next record with key1 > na-tel readkey1n section. start nameadrs key > na-tel. if na-status <> "00" string "Next key > start ERROR, file-status = " na-status delimited by size into msg1 string "filename: ", na-namexln, "=" na-namexfn, delimited by size into msg2 exit section. read nameadrs next. if na-status <> "00" string "Next key > read ERROR, file-status = " na-status delimited by size into msg1 string "filename: ", na-namexln, "=" na-namexfn, delimited by size into msg2. exit section. * * read next record with key2 > na-name readkey2n section. start nameadrs key > na-name. if na-status <> "00" string "Next key > start ERROR, file-status = " na-status delimited by size into msg1 string "filename: ", na-namexln, "=" na-namexfn, delimited by size into msg2 exit section. read nameadrs next. if na-status <> "00" string "Next key > read ERROR, file-status = " na-status delimited by size into msg1 string "filename: ", na-namexln, "=" na-namexfn, delimited by size into msg2. exit section. * *eject * read Prior record with key1 < na-tel readkey1p section. start nameadrs key < na-tel. if na-status <> "00" string "Prior key < start ERROR, file-status = " na-status delimited by size into msg1 string "filename: ", na-namexln, "=" na-namexfn, delimited by size into msg2 exit section. read nameadrs previous. if na-status <> "00" string "Prior key < read ERROR, file-status = " na-status delimited by size into msg1 string "filename: ", na-namexln, "=" na-namexfn, delimited by size into msg2. exit section. * * read Prior record with key2 < na-name readkey2p section. start nameadrs key < na-name. if na-status <> "00" string "Prior key < start ERROR, file-status = " na-status delimited by size into msg1 string "filename: ", na-namexln, "=" na-namexfn, delimited by size into msg2 exit section. read nameadrs previous. if na-status <> "00" string "Prior key < read ERROR, file-status = " na-status delimited by size into msg1 string "filename: ", na-namexln, "=" na-namexfn, delimited by size into msg2. exit section. ************************ end nameadrs1 *************************