CTITLEFOSMS -- WRITE RECORDS TO DSN DATABASE 00010000 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA AUTHOR J. M. PONTON 00020000 CA DESIGNER J. M. PONTON 00030000 CA LANGUAGE VSFORTRAN 00040000 CA SYSTEM IBM (SEE CRAY) 00050000 CA WRITTEN 07-18-85 00060000 C 00070000 C SPECIAL NOTE : YOU MUST RELINK THE FOLLOWING PROGRAMS WHENEVER 00080000 C CHANGES ARE MADE TO THIS ROUTINE 00090000 C 00100000 C UTUPL,UTDSNE,PREDMUX,TAPECOPY,REFORMAT,IPREFP,IPVELP,IPEDIT 00110000 C 00120000 C REVISED MO-DA-YR BY PROGRAMMER FOR REASON 00130000 C REVISED 08-16-85 JMP - ALLOW FOSMS TO WRITE TO DSN D. B. 00140000 C REVISED 08-20-85 JMP - 1. CHANGE OPERATOR MESSAGE. 00150000 C 2. IN 'OPEN' MODE, USE OPERATOR 00160000 C MESSAGE LOGIC. 00170000 C 3. EXTEND EXPIRATION DATE FOR RET- 00180000 C ENTION GROUP 99. 00190000 C REVISED 08-22-85 JMP - IGNORE RECORDS WITH BLKCOUNT = 0 IF 00200000 C A RECORD IS IN THE D. B. WITH NON- 00210000 C ZERO BLKCOUNT. 00220000 C REVISED 08-26-85 JMP - DON'T EXTEND EXPIRATION DATE FOR RET- 00230000 C ENTION GROUP 99. 00240000 C REVISED 08-27-85 JMP - DO NOT ACCESS LINE DATABASE IF 'LINE' 00250000 C FIELD IS BLANK. 00260000 C REVISED 08-28-85 JMP - IF RETENTION GROUP OF INPUT RECORD = 00270000 C 99, USE THE RETENTION GROUP FROM THE 00280000 C DATABASE, IF THE RECORD IS ALREADY IN 00290000 C THE DATABASE. 00300000 C REVISED 09-04-85 JMP - FIX BUG INTRODUCED BY UPDATE OF 8/27. 00310000 C IT COULD 0 OUT THE NUMERIC FIELDS. 00320000 C CONVERT IFAM CALLS TO 'M204EX' CALLS. 00330000 C REVISED 09-24-85 JMP - PUT IN CHECK TO MAKE SURE LAST CHAR- 00340000 C ACTER OF 'SMSUSER' FIELD IS LEXICALLY 00350000 C GREATER THAN OR EQUAL TO BLANK. 00360000 C REVISED 10-08-85 JMP - CHANGE RET. GRP. 2 EXTENSION PERIOD 00370000 C FROM 30 TO 45 DAYS. 00380000 C REVISED 10-09-85 JMP - ADD EXTRA SAFEGUARDS TO AVOID ENQUEUIN00390000 C PROBLEMS. ADD NRETRY ARGUMENT TO USUPD00400000 C CALL. 00410000 C REVISED 10-15-85 JMP - 1. ALLOW EXPIRATION EXTENSION WHEN REA00420000 C DATASETS IN RETENTION GROUP 3, 4, O00430000 C 2. IF THE DATABASE 'STATUS' FIELD IS '00440000 C DON'T UPDATE THE EXPIRATION DATE. 00450000 C 3. IF IT IS AN UPLOAD JOB, AND THE DSN00460000 C IS UNAVAILABLE, WRITE TO THE FLAT F00470000 C WITH NO OPERATOR MESSAGE. 00480000 C REVISED 11-05-85 JMP - FIX PROBLEM IF IN 'OPEN' MODE AND DOWN00490000 C .TRUE.: THE RECORD WAS BEING DROPPED D00500000 C TO COMPILER OPTIMIZATION ERROR. 00510000 C REVISED 12-09-85 WAB - FIX PROBLEM - NOT EXTENDING EXPIRATION00520000 C DATES WHEN READING XLM DATA SETS 00530000 C REVISED 01-02-86 JMP - PUT IN DUMMY CALL TO IFCALL SO FOSMS M00540000 C LINKED WITH 'NCAL'. 00550000 C REVISED 01-08-86 JMP - PUT IN COMMENT LINE TO JUMP TO THE COD00560000 C THAT WRITES RECORDS OUT TO THE ALTERNA00570000 C FILE. THIS IS IN CASE OF EMERGENCY, WE00580000 C MERELY EDIT OUT THE COMMENT, RECOMPILE00590000 C CONTINUE RUNNING UNTIL THE PROBLEM CAN00600000 C PERMANENTLY FIXED. 00610000 C REVISED 01-15-86 JMP - SET FOSMS BACK TO RUNNING ON THE D. B.00620000 C REVISED 02-06-86 WAB - CHANGE EXTENTION TIME TO 30 DAYS FOR G00630000 C ADD RETENTION GROUP 9 - 2 DAYS 00640000 C REVISED 02-06-86 WAB - CHANGE EXT. TIME TO 120 DAYS FOR GROUP00650000 C CHANGE EXT. TIME TO 60 DAYS FOR GROUP 00660000 C REVISED 02-24-86 WAB - CHANGE EXT. TIME TO 7 DAYS FOR GROUP 300670000 C REVISED 03-06-86 WAB - CHANGE EXT. TIME TO 90 DAYS FOR GROUP 00680000 C CHANGE EXT. TIME TO 45 DAYS FOR GROUP 00690000 C CHANGE EXT. TIME TO 21 DAYS FOR GROUP 00700000 C REVISED 04-02-86 WAB - ADD RET. GROUP 88 WHICH IS USED ONLY 00710000 C ON THE FIRST CALL FOR AN OUTPUT MSS DA00720000 C REVISED 04-03-86 WAB - CHANGE EXT. TIME TO 5 DAYS FOR GROUP 00730000 C REVISED 04-21-86 WAB - CHANGE RETENTION TO 7 DAYS FOR GROUP 300740000 C REVISED 05-12-86 WAB - CHANGE TO USE 2 FILE DSN DATABASE 00750000 C REMOVED OPEN - CLOSE MODE CODE 00760000 C REVISED 07-07-86 WAB - FIX PROBLEM WITH 5 CHARACTER USERIDS 00770000 C REVISED 08-26-86 WAB - ADD SECOND IFFIND FOR DSNUM IN STORED 00780000 C FILE IF SPOOL MEMBER IS SPECIFIED 00790000 C REVISED 09-23-86 REM - ADD JOB CLASS TO CALLING LIST OF JOBINF. 00800000 C REVISED 01-08-87 WAB - REMOVE STATE-COUNTY FIELD FROM EDIT SPECS 00810000 C REVISED 01-19-87 WAB - ADD NOLABEL TAPE HANDLING CODE; ONLY 00820000 C "N" TAPES (LIB1) WILL BE PROCESSED 00830000 C REVISED 02-12-87 WAB - ADD VOLSER TO FIND SPECS FOR OUTPUT "N" 00840000 C TAPE RECORDS 00850000 C REVISED 03-10-87 WAB - ADDED RETGRPS 40,41 & 42 00860000 C REVISED 04-06-87 WAB - CHANGE UGASEQ TO UGASMT 00870000 C REVISED 04-30-87 WAB - ADDED SMSUSER IS PRESENT AND STATUS IS 00880000 C NOT PRESENT TO LIB 2 RECORDS 00890000 C REVISED 01-22-88 WAB - CHANGE GROUP0 TO 30 DAY EXTENSION; 00900000 C REMOVED DISK GROUPS 1,2,4 AS PART OF 00910000 C CONVERTING TO DASD FROM MSS 00920000 C REVISED 09-12-88 WAB - CHANGE GROUP9 TO 10 DAY RETENTION 00930000 C REVISED 12-02-88 WAB - REMOVE XDUMPX CALL FOR NOLABEL TAPE ERROR 00940000 C REVISED 08-02-89 WAB - CHANGED GROUP 0 DISK TO 90 DAYS 00950000 C REVISED 03-16-90 RFC - ADDED GEODATA DATABASE TO NOLABEL FIND 00960000 C SPECIFICATION 00970000 C REVISED 03-23-90 REM - CHANGE RETENTION ON GROUP 9 TO 90 DAYS. 00980000 C REVISED 08-22-90 PJF - ALLOW 'L' TYPE DATASETS FOR UNISEC. 00990000 C REVISED 11-05-91 REP - REMOVE INDEX FUNCTION CALL. 01000000 C REVISED 06/10/93 REM - CHANGE MODEL 204 CHANNEL NAME. 01010000 C REVISED 12/21/93 ESN - REMOVE OPERATOR MESSAGE IF M204SA DOWN. 01020000 C 01030000 CA 01040000 CA CALL FOSMS(REC) 01050000 CA 01060000 CA IN/OUT ARGUMENT TYPE DESCRIPTION 01070000 CA ------ -------- ---- ----------- 01080000 CA IN REC CHAR CHARACTER VARIABLE CONTAINING A STANDARD 01090000 CA SMS DATA RECORD. (SEE BELOW FOR DETAILS OF01100000 CA FORMAT.) 01110000 CA 01120000 CA 01130000 CA THIS SUBROUTINE NORMALLY WORKS AS FOLLOWS: 01140000 CA 1. A FIND REQUEST FOR THE RECORD IS BUILT. 01150000 CA 2. THE DSN DATABASE IS SEARCHED FOR THE PRESENCE OF THIS DATASET01160000 CA AND SPOOL MEMBER. 01170000 CA 3. IF THE RECORD WAS FOUND, THE 'LUDATE', 'FWRIT', AND POSSIBLY 01180000 CA THE 'EXDATE' FIELDS ARE UPDATED. 01190000 CA 4. IF THE RECORD WAS NOT FOUND, OR IF IT IS AN OUTPUT RECORD, 01200000 CA A RECORD CONSISTING OF 28 FIELDS IS CREATED IN THE DSN DATA- 01210000 CA BASE. 01220000 CA 01230000 CA AN EXCEPTION TO THE PROCEDURE ABOVE IS IF MODEL 204 IS NOT AVAIL- 01240000 CA ABLE. IN THIS CASE, THE OPERATOR IS NOTIFIED OF THE PROBLEM AND 01250000 CA ASKED TO RESPOND. IF THE RESPONSE IS 'R' (RETRY), THE SUBROUTINE 01260000 CA CHECKS M204 AGAIN. IF THE RESPONSE IS 'C' (CONTINUE), THEN FOSMS 01270000 CA DYNAMICALLY ALLOCATES A DATASET AND MERELY WRITES THE INPUT REC- 01280000 CA ORDS TO THE FLAT FILE. 01290000 CA 01300000 CA DESCRIPTION OF SMS FORMATTED INPUT RECORD. 01310000 CA ----------- -- --- --------- ----- ------- 01320000 CA 01330000 CA CC 1 INPUT/OUTPUT ('I' OR 'O'). 01340000 CA CC 2-4 USE COUNT 01350000 CA CC 5-12 DATE ('MM/YY/DD') 01360000 CA CC 13-30 USER NAME; 13-18 VOLSER FOR OUTPUT "N" TAPES 01370000 CA CC 31-74 DATA SET NAME (SPOOL MEMBER IN BYTES 73-74). 01380000 CA CC 75-174 LIST OF LAST 20 PROCESSES. 01390000 CA CC 175-180 TSO USERID 01400000 CA CC 181-188 SYSTEM ID 01410000 CA CC 189-208 LINE NAME 01420000 CA CC 209-212 BLOCK COUNT (NUMERIC) 01430000 CA CC 213-216 BLOCK SIZE (NUMERIC) 01440000 CA CC 217-220 RETENTION GROUP (NUMERIC) 01450000 CA CC 221-224 BEGINNING SHOTPT/DP (NUMERIC) 01460000 CA CC 225-228 ENDING SHOTPT/DP (NUMERIC) 01470000 CA CC 229-232 LENGTH OF RECS (NUMERIC) 01480000 CA CC 233-236 PROCESSING SAMPLE RATE (NUMERIC) 01490000 CA CC 237-240 TRACES PER SHOTPT (NUMERIC) 01500000 CA CC 241-268 AREA NAME 01510000 CA CC 269-276 JOBNAME (MAY OR MAY NOT BE ON RECORD.) 01520000 CA CC 277-280 JOB NUMBER (MAY OR MAY NOT BE ON RECORD.) 01530000 CA CC 281-300 FILLER 01540000 CA 01550000 C EJECT 01560000 C 01570000 SUBROUTINE FOSMS(REC) 01580000 IMPLICIT INTEGER (A-Z) 01590000 C 01600000 CHARACTER*(*) REC 01610000 CHARACTER PROJCT*5,DSTRCT*2 01620000 CHARACTER LOGIN*12,CHANL*8 01630000 CHARACTER FSPEC*300,GSPEC*80,LSPEC*50,LGSPEC*320 01640000 CHARACTER PSPEC(4)*600 01650000 CHARACTER DATE*16,NEWDAT*16 01660000 CHARACTER JOBNAM*8,JOBNUM*8 01670000 CHARACTER*1 MCLASS 01680000 CHARACTER CRDATE*6,LUDATE*6,EXDATE*6 01690000 CHARACTER*4 REPLY 01700000 CHARACTER CURFIL*11 01710000 CHARACTER DSNAME*42,DSNUM*7,DSTYPE*1,VOLSER*6 01720000 CHARACTER FWRIT*1 01730000 CHARACTER*64 OPMSG 01740000 CHARACTER*44 ALTDSN 01750000 CHARACTER*8 DDNAME 01760000 CHARACTER*80 ERRMSG 01770000 INTEGER IDATA(4) 01780000 CHARACTER CDATA*8 01790000 EQUIVALENCE (CDATA,IDATA(3)) 01800000 LOGICAL DBPROB,SPOOL 01810000 CREP 01820000 CHARACTER*36 GDCHAR 01830000 CREP 01840000 CHARACTER CREC*600 01850000 EQUIVALENCE (CREC(13:13),VOLSER) 01860000 EQUIVALENCE (CREC(31:31),DSNAME) 01870000 EQUIVALENCE (CREC(209:209),BLKCNT) 01880000 EQUIVALENCE (CREC(217:217),RETGRP) 01890000 EQUIVALENCE (CREC(281:281),LUDATE) 01900000 EQUIVALENCE (CREC(287:287),EXDATE) 01910000 EQUIVALENCE (CREC(293:293),CRDATE) 01920000 EQUIVALENCE (CREC(299:299),DSTYPE) 01930000 EQUIVALENCE (CREC(300:300),FWRIT) 01940000 EQUIVALENCE (CREC(301:301),DSTRCT) 01950000 EQUIVALENCE (CREC(303:303),DSNUM) 01960000 EQUIVALENCE (CREC(310:310),PROJCT) 01970000 C 01980000 DATA IFKALL /1/ 01990000 DATA IFDTRD /3/ 02000000 DATA IFEPRM /4/ 02010000 DATA IFFNSH /6/ 02020000 DATA IFGERR /7/ 02030000 DATA IFSTRN /13/ 02040000 DATA IFOPEN /24/ 02050000 DATA IFCNT /25/ 02060000 DATA IFFIND /30/ 02070000 DATA IFBREC /37/ 02080000 DATA IFGET /40/ 02090000 DATA IFPUT /52/ 02100000 DATA IFBOUT /71/ 02110000 C DATA CHANL/'IFAM2HLT'/ 02120000 DATA CHANL/'IFAM2HLA'/ 02130000 DATA LOGIN /'DBGSMS;SMS;'/ 02140000 C 02150000 DATA OPMSG/'*** M204SA IS DOWN. TYPE "R" FOR RETRY, "C" FOR CONTIN02160000 *UE. ***'/ 02170000 DATA ALTDSN /'DBG.M204DSN.DATA'/ 02180000 C 02190000 C 02200000 DATA PSPEC /'EDIT(LUDATE)(POS(281),A(6));', 02210000 + 'EDIT(LUDATE,EXDATE)(POS(281),2A(6));', 02220000 + 'EDIT(DSNAME,SPOOL,PROCESS,SMSUSER,SYSID,LNAME,BLKCOUNT,BLKSIZE, 02230000 +RETNGROUP,BEGSHT1,ENDSHT1,RECLEN,SAMPLERT,TRACES,AREA,JOBNAME, 02240000 +JOBNUM,LUDATE,EXDATE,CRDATE,DSTYPE,FWRIT,DISTRICT,DSNUM,PROJECT) 02250000 +(POS(31),A(42),A(2),A(100),A(6),A(8),A(20),8B(31),A(28),A(8),A(4),02260000 +3A(6),2A(1),A(2),A(7),A(5));', 02270000 + 'EDIT(DSNAME,SPOOL,PROCESS,SMSUSER,SYSID,LNAME,BLKCOUNT,BLKSIZE, 02280000 +RETNGROUP,BEGSHT1,ENDSHT1,RECLEN,SAMPLERT,TRACES,AREA,JOBNAME, 02290000 +JOBNUM,LUDATE,EXDATE,CRDATE,DSTYPE,FWRIT,DISTRICT,DSNUM,PROJECT, 02300000 +SURVEY,STATE(1),STATE(2),STATE(3),STATE(4),COUNTY(1),COUNTY(2), 02310000 +COUNTY(3),COUNTY(4)) 02320000 +(POS(31),A(42),A(2),A(100),A(6),A(8),A(20),8B(31),A(28),A(8),A(4),02330000 +3A(6),2A(1),A(2),A(7),A(5),X(6),A(6),4A(2),4A(43));'/ 02340000 C 02350000 DATA LGSPEC /'EDIT(SURVEY,STATE(1),STATE(2),STATE(3),STATE(4), 02360000 +COUNTY(1),COUNTY(2),COUNTY(3),COUNTY(4)) 02370000 +(POS(321),A(6),4A(2),4A(43));'/ 02380000 C 02390000 DATA GSPEC 02400000 +/'EDIT(BLKCOUNT,RETNGROUP,RETNGROUP)(B(31),B(31),A(8));'/ 02410000 CREP 02420000 DATA GDCHAR 02430000 +/'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'/ 02440000 CREP 02450000 DBPROB = .FALSE. 02460000 TYPE = -1 02470000 CDATA=' ' 02480000 C 02490000 C RETRIEVE JOB INFORMATION. 02500000 C 02510000 CALL ZOWIE 02520000 CALL JOBINF(JOBNAM, JOBNUM, JCLASS) 02530000 IF (REC(269:276) .EQ. ' ') THEN 02540000 REC(269:276) = JOBNAM 02550000 REC(277:280) = JOBNUM(5:8) 02560000 ENDIF 02570000 C 02580000 C ************************************************** 02590000 C *** IN CASE OF EMERGENCY, THE FOLLOWING LINE *** 02600000 C *** MAY BE UNCOMMENTED, FOSMS RECOMPILED AND *** 02610000 C *** ALL JOBS WILL AUTOMATICALLY WRITE TO THE *** 02620000 C *** ALTDSN FILE. THIS WILL BUY TIME UNTIL A *** 02630000 C *** PERMANENT SOLUTION TO THE EMERGENCY MAY *** 02640000 C *** BE FOUND. *** 02650000 C ************************************************** 02660000 C 02670000 C GO TO 995 02680000 C 02690000 C 02700000 C 02710000 C DUMMY CALL TO FORCE LOAD OF S1DAT3 AND IFAM ROUTINES. 02720000 C 02730000 IF (1 .EQ. 2) THEN 02740000 CALL S1DATE 02750000 CALL IFCALL 02760000 ENDIF 02770000 C 02780000 C MOVE REC INTO CREC SO THAT WE HAVE MORE WORK SPACE AND CAN 02790000 C EQUIVALENCE TO IT 02800000 C 02810000 CREC = REC 02820000 C 02830000 C CRACK THE DATASET NAME 02840000 C 02850000 CALL USNOC2(DSNAME, 1, '.', COL, *1) 02860000 1 CONTINUE 02870000 DSTRCT = DSNAME(2:COL-1) 02880000 C 'DISTRICT' FIELD 02890000 DSTYPE = DSNAME(COL+1:COL+1) 02900000 C 'DSTYPE' FIELD 02910000 NEXT = COL + 1 02920000 CALL USNOC2(DSNAME, NEXT, '.', COL, *2) 02930000 2 CONTINUE 02940000 DSNUM = DSNAME(NEXT+1:COL-1) 02950000 C 'DSNUM' FIELD 02960000 NEXT = COL + 1 02970000 CALL USNOC2(DSNAME, NEXT, '.', COL, *3) 02980000 3 CONTINUE 02990000 PROJCT = DSNAME(NEXT+3:COL-1) 03000000 C 'PROJECT' FIELD 03010000 C 03020000 C BUILD FIND REQUEST FOR DATASET. 03030000 C 03040000 DSNLEN = USLEN(DSNUM) 03050000 C 03060000 C DISK OR SL TAPE DATASET 03070000 IF (DSTYPE.NE.'N' .AND. RETGRP.NE.11) THEN 03080000 IF (REC(73:74) .NE. ' ') THEN 03090000 FSPEC = 'DSNUM=''' // DSNUM(1:DSNLEN) // ''';SPOOL=''' // 03100000 + REC(73:74) // ''';FILE$ ACTIVE OR FILE$ STORED;END;' 03110000 SPOOL=.TRUE. 03120000 ELSE 03130000 FSPEC = 'DSNUM=''' // DSNUM(1:DSNLEN) // 03140000 + ''';FILE$ ACTIVE OR FILE$ STORED;END;' 03150000 SPOOL=.FALSE. 03160000 ENDIF 03170000 C 03180000 C NOLABEL TAPE DATASET 03190000 C 03200000 C CHECK FOR INPUT OR OUTPUT; VOLSER IS DSNUM FOR INPUT AND IT'S IN 03210000 C BYTES 13-18 FOR OUTPUT 03220000 C ONLY LIB1 TAPES WILL BE PROCESSED UNTIL LATER, HOWEVER THE CODE IS 03230000 C ALL IN PLACE 03240000 C 03250000 C OUTPUT RECORD 03260000 C 03270000 ELSEIF (CREC(1:1) .EQ. 'O') THEN 03280000 SPOOL=.FALSE. 03290000 VLEN=USLEN(VOLSER) 03300000 FSPEC='FILE$ NOLABEL;VOLSER=''' // VOLSER(1:VLEN) // ''';END;' 03310000 C 03320000 C INPUT RECORD 03330000 C 03340000 ELSE 03350000 SPOOL=.FALSE. 03360000 IF(DSNUM(1:1).EQ.'N') THEN 03370000 FSPEC='FILE$ NOLABEL;STATUS=NOT X;' // 03380000 + 'VOLSER=''' // DSNUM(1:DSNLEN) // ''';END;' 03390000 ELSEIF(DSNUM(1:1).EQ.'Z') THEN 03400000 FSPEC='FILE$ NOTARCO;TAPE LOCATION=PLANO;' // 03410000 + 'SMSUSER IS PRESENT;STATUS IS NOT PRESENT;' // 03420000 + 'STOREEL=''' // DSNUM(1:DSNLEN) // ''';END;' 03430000 ELSE 03440000 FSPEC='FILE$ DSN2 OR STORED OR GEODATA;' // 03450000 + 'TAPE LOCATION=PLANO;' // 03460000 + 'SMSUSER IS PRESENT;STATUS IS NOT PRESENT;' // 03470000 + 'STOREEL=''' // DSNUM(1:DSNLEN) // ''';END;' 03480000 ENDIF 03490000 ENDIF 03500000 C 03510000 C OPEN YE OLDE DATABASE 03520000 C 03530000 5 CALL M204EX(IFFNSH,ERRCOD) 03540000 CALL M204EX(IFSTRN,ERRCOD,2,LOGIN,1,THRD,CHANL) 03550000 IF(ERRCOD .NE. 0) THEN 03560000 CALL M204EX(IFGERR,ERRCOD,ERRMSG) 03570000 WRITE(6,*) 'DATABASE ACCESS PROBLEM - ERROR # : ',ERRCOD 03580000 WRITE(6,*) ERRMSG 03590000 DBPROB = .TRUE. 03600000 GOTO 990 03610000 ENDIF 03620000 C 03630000 CALL M204EX(IFOPEN,ERRCOD,'GROUP PROCESSD;UPDATE;') 03640000 IF(ERRCOD.NE.0 .AND. ERRCOD.NE.16 .AND. ERRCOD.NE.32) THEN 03650000 CALL M204EX(IFGERR,ERRCOD,ERRMSG) 03660000 WRITE(6,*) 'DATABASE FILE OPEN PROBLEM - ERROR # : ',ERRCOD 03670000 WRITE(6,*) ERRMSG 03680000 DBPROB = .TRUE. 03690000 CALL M204EX(IFFNSH,ERRCOD) 03700000 GOTO 990 03710000 ENDIF 03720000 C 03730000 TRIED=0 03740000 10 CALL M204EX(IFFIND,ERRCOD,FSPEC) 03750000 C FIRST CHECK FOR RECORD ENQUEUE CONFLICT 03760000 TRIED=TRIED+1 03770000 IF(ERRCOD .EQ. 3 ) THEN 03780000 IF(TRIED .GE. 3) GOTO 995 03790000 GOTO 10 03800000 ENDIF 03810000 C 03820000 IF(ERRCOD .NE. 0) THEN 03830000 CALL M204EX(IFGERR,ERRCOD,ERRMSG) 03840000 WRITE(6,*) 'DATABASE RECORD FIND PROBLEM - ERROR # : ',ERRCOD 03850000 WRITE(6,*) ERRMSG 03860000 DBPROB = .TRUE. 03870000 CALL M204EX(IFFNSH,ERRCOD) 03880000 GOTO 995 03890000 ENDIF 03900000 C 03910000 CALL M204EX(IFCNT,ERRCOD,COUNT) 03920000 IF(ERRCOD .NE. 0) THEN 03930000 CALL M204EX(IFGERR,ERRCOD,ERRMSG) 03940000 WRITE(6,*) 'DATABASE RECORD COUNT PROBLEM - ERROR # : ',ERRCOD 03950000 WRITE(6,*) ERRMSG 03960000 DBPROB = .TRUE. 03970000 CALL M204EX(IFFNSH,ERRCOD) 03980000 GOTO 995 03990000 ENDIF 04000000 C 04010000 C NOLABEL ERROR CHECKING - IF WE DON'T FIND A RECORD, BLOW OFF THE JOB 04020000 C 04030000 IF(DSTYPE.EQ.'N' .AND. COUNT.LT.1) THEN 04040000 WRITE(6,*) 'NOLABEL DATABASE RECORD COUNT ERROR' 04050000 WRITE(6,*) 'FOUND ',COUNT,' RECORDS' 04060000 CALL M204EX(IFFNSH,ERRCOD) 04070000 GOTO 995 04080000 ENDIF 04090000 C 04100000 C IF NONE FOUND AND A SPOOL MEMBER WAS USED, CHECK STORED FOR THE DSNUM04110000 C ONLY, LEST WE CREATE AN ACTIVE SPOOL MEMBER FOR A STORED DATASET 04120000 C 04130000 IF(COUNT .LT. 1 .AND. SPOOL) THEN 04140000 FSPEC = 'DSNUM=''' // DSNUM(1:DSNLEN) 04150000 + // ''';FILE$ STORED;END;' 04160000 SPOOL=.FALSE. 04170000 TRIED=0 04180000 GOTO 10 04190000 ENDIF 04200000 C 04210000 C IF NONE FOUND, SET TYPE TO ACTIVE ADD 04220000 C 04230000 IF(COUNT .LT. 1) THEN 04240000 TYPE=4 04250000 FWRIT = ' ' 04260000 IF (REC(1:1) .EQ. 'I') FWRIT = 'I' 04270000 IF (REC(1:1) .EQ. 'O') FWRIT = 'Y' 04280000 GOTO 100 04290000 ENDIF 04300000 C 04310000 IF(COUNT .GT. 1 .AND. DSTYPE .NE. 'N') THEN 04320000 WRITE(6,*) 'FOUND ',COUNT,' RECORDS IN THE DATABASE' 04330000 WRITE(6,*) 'DSNAME = ',DSNAME 04340000 WRITE(6,*) 'DSNUM = ',DSNUM 04350000 WRITE(6,*) 'SPOOL = ',REC(73:74) 04360000 GOTO 995 04370000 ENDIF 04380000 C 04390000 TRIED=0 04400000 20 CALL M204EX(IFGET,ERRCOD,IDATA,GSPEC) 04410000 C FIRST CHECK FOR RECORD ENQUEUE CONFLICT 04420000 TRIED=TRIED+1 04430000 IF(ERRCOD .EQ. 3 ) THEN 04440000 IF(TRIED .GE. 3) GOTO 995 04450000 GOTO 20 04460000 ENDIF 04470000 C 04480000 IF(ERRCOD .NE. 0) THEN 04490000 CALL M204EX(IFGERR,ERRCOD,ERRMSG) 04500000 WRITE(6,*) 'DATABASE RECORD GET PROBLEM - ERROR # : ',ERRCOD 04510000 WRITE(6,*) ERRMSG 04520000 DBPROB = .TRUE. 04530000 CALL M204EX(IFFNSH,ERRCOD) 04540000 GOTO 995 04550000 ENDIF 04560000 C 04570000 CALL M204EX(IFEPRM,ERRCOD,'CURFILE;',CURFIL) 04580000 IF(ERRCOD .NE. 0) THEN 04590000 CALL M204EX(IFGERR,ERRCOD,ERRMSG) 04600000 WRITE(6,*) 'DATABASE PARM GET PROBLEM - ERROR # : ',ERRCOD 04610000 WRITE(6,*) ERRMSG 04620000 DBPROB = .TRUE. 04630000 CALL M204EX(IFFNSH,ERRCOD) 04640000 GOTO 995 04650000 ENDIF 04660000 C 04670000 C FIND THE TYPE OF UPDATE 04680000 C 04690000 IF(CURFIL(1:6) .EQ. 'STORED' .AND. 04700000 + DSTYPE .NE. 'N') THEN 04710000 TYPE=1 04720000 GOTO 100 04730000 ENDIF 04740000 IF(REC(1:1) .EQ. 'I') THEN 04750000 TYPE=2 04760000 GOTO 100 04770000 ENDIF 04780000 IF(REC(1:1) .EQ. 'O') THEN 04790000 TYPE=3 04800000 GOTO 100 04810000 ENDIF 04820000 C 04830000 C SYSTEM IS UP, CREATE ASSORTED FIELDS BASED ON TYPE OF UPDATE 04840000 C 04850000 100 IF(TYPE .LT. 1 .OR. TYPE .GT. 4) THEN 04860000 WRITE(6,*) 'UNABLE TO DETERMINE UPDATE TYPE' 04870000 WRITE(6,*) REC(1:100) 04880000 GOTO 995 04890000 ENDIF 04900000 C CONVERT DATE FROM 'MM/DD/YY' TO 'YYMMDD' 04910000 C 04920000 LUDATE = REC(11:12) // REC(5:6) // REC(8:9) 04930000 IF (REC(5:5) .EQ. ' ') LUDATE(3:3) = '0' 04940000 C 04950000 C SET CRDATE TO LUDATE - IT WON'T BE USED UNLESS THIS IS A NEW RECORD 04960000 C 04970000 CRDATE=LUDATE 04980000 C 04990000 C CHECK VALIDITY OF DSTYPE. 05000000 C 05010000 IF (DSTYPE.NE.'D' .AND. DSTYPE.NE.'T' .AND. DSTYPE.NE.'N' 05020000 * .AND. DSTYPE.NE.'L') THEN 05030000 WRITE (6, 9010) DSNAME 05040000 9010 FORMAT(' *** ERROR *** FOSMS: INVALID DATASET TYPE...',A42) 05050000 CALL M204EX(IFFNSH,ERRCOD) 05060000 GOTO 995 05070000 ENDIF 05080000 C 05090000 C CHECK VALIDITY OF RECORD TYPE 05100000 C 05110000 IF (REC(1:1) .NE. 'O' .AND. REC(1:1) .NE. 'I') THEN 05120000 WRITE (6, 9020) REC(1:1) 05130000 9020 FORMAT(' *** ERROR *** FOSMS: INVALID RECORD TYPE...',A1) 05140000 CALL M204EX(IFFNSH,ERRCOD) 05150000 GOTO 995 05160000 ENDIF 05170000 C 05180000 C IF THIS IS A STORED UPDATE (TYPE=1) DON'T BOTHER WITH EXDATE 05190000 C 05200000 IF(TYPE .EQ. 1) GOTO 110 05210000 C 05220000 C IF RETENTION GROUP = 99, AND GROUP FROM EXISTING RECORD IS NON-ZERO 05230000 C USE THE EXISTING RECORD'S GROUP 05240000 C 05250000 IF (RETGRP .EQ. 99 .AND. CDATA(1:1) .NE. ' ') 05260000 + RETGRP = IDATA(2) 05270000 C 05280000 C CALCULATE NEW EXPIRATION DATE. 05290000 C 05300000 IADD = 30 05310000 IF (DSTYPE .EQ. 'D') THEN 05320000 IF (RETGRP .EQ. 0 .OR. RETGRP .EQ. 40) IADD = 90 05330000 IF (RETGRP .EQ. 3) IADD = 7 05340000 IF (RETGRP .EQ. 9) IADD = 90 05350000 IF (RETGRP .EQ. 88) IADD = 7 05360000 ELSE 05370000 IF (RETGRP .EQ. 0 .OR. RETGRP .EQ. 40) IADD = 180 05380000 IF (RETGRP .EQ. 3) IADD = 7 05390000 IF (RETGRP .EQ. 11) IADD = 60 05400000 ENDIF 05410000 C 05420000 CALL S1CV01(REC(5:12), DATE(9:16)) 05430000 CALL S1DAT3(DATE, IADD, NEWDAT) 05440000 EXDATE(1:2) = NEWDAT(7:8) 05450000 EXDATE(3:4) = NEWDAT(1:2) 05460000 EXDATE(5:6) = NEWDAT(4:5) 05470000 C 05480000 C 05490000 110 CONTINUE 05500000 C 05510000 C====================================================================== 05520000 C 05530000 C UPDATE THE DATABASE - CREATE A RECORD IF NEEDED 05540000 C 05550000 C=======================================================================05560000 C 05570000 IF(TYPE .NE. 4) GOTO 120 05580000 C 05590000 C ACTIVE CREATE TYPE, SOOOOO CREATE A NEW RECORD 05600000 C TYPE 3 MEANS ALL INFO BUT LINE DATABASE... TYPE 4 IS TYPE 3 PLUS 05610000 C LINE DATABASE INFO 05620000 C 05630000 C TYPE SHOULD BE 4, HOWEVER I'M SETTING IT TO 3; IF THE LINE INFO 05640000 C IS RETRIEVED SUCCESSFULLY, IT WILL BE RESET TO 4 05650000 C 05660000 TYPE=3 05670000 C 05680000 TRIED=0 05690000 111 CALL M204EX(IFBREC,ERRCOD,';','ACTIVE;') 05700000 C FIRST CHECK FOR RECORD ENQUEUE CONFLICT 05710000 TRIED=TRIED+1 05720000 IF(ERRCOD .EQ. 3 ) THEN 05730000 IF(TRIED .GE. 3) THEN 05740000 CALL M204EX(IFFNSH,ERRCOD) 05750000 GOTO 995 05760000 ENDIF 05770000 GOTO 111 05780000 ENDIF 05790000 C 05800000 IF(ERRCOD .NE. 0) THEN 05810000 CALL M204EX(IFGERR,ERRCOD,ERRMSG) 05820000 WRITE(6,*) 'DATABASE RECORD CREATE PROBLEM - ERROR # : ',ERRCOD 05830000 WRITE(6,*) ERRMSG 05840000 DBPROB = .TRUE. 05850000 CALL M204EX(IFFNSH,ERRCOD) 05860000 GOTO 995 05870000 ENDIF 05880000 C 05890000 C ******************************************************************* 05900000 C GET SOME OTHER FIELDS FROM THE LINE DATABASE. 05910000 C 05920000 NC = USLEN(REC(189:208)) 05930000 C 05940000 C DO NOT ACCESS THE LINE DATABASE IF 'LINE' IS BLANK. 05950000 C 05960000 IF (NC .EQ. 0) GOTO 120 05970000 C 05980000 LSPEC = 'LNAME=''' // REC(189:189+NC-1) // ''';PROJECT=' // 05990000 + PROJCT // ';END;' 06000000 C 06010000 C 06020000 C OPEN THE LINE DATABASE 06030000 C 06040000 CALL M204EX(IFSTRN,ERRCOD,2,LOGIN,0,LTHRD,CHANL) 06050000 IF(ERRCOD .NE. 0) THEN 06060000 CALL M204EX(IFGERR,ERRCOD,ERRMSG) 06070000 WRITE(6,*) 'LINE DATABASE ACCESS PROBLEM - ERROR # : ',ERRCOD 06080000 WRITE(6,*) ERRMSG 06090000 GOTO 120 06100000 ENDIF 06110000 C 06120000 CALL M204EX(IFOPEN,ERRCOD,'FILE LINE;;') 06130000 IF(ERRCOD.NE.0 .AND. ERRCOD.NE.16 .AND. ERRCOD.NE.32) THEN 06140000 CALL M204EX(IFGERR,ERRCOD,ERRMSG) 06150000 WRITE(6,*) 'LINE DATABASE OPEN PROBLEM - ERROR # : ',ERRCOD 06160000 WRITE(6,*) ERRMSG 06170000 CALL M204EX(IFDTRD,ERRCOD,THRD,OTHRD) 06180000 GOTO 120 06190000 ENDIF 06200000 C 06210000 TRIED=0 06220000 112 CALL M204EX(IFFIND,ERRCOD,LSPEC) 06230000 C FIRST CHECK FOR RECORD ENQUEUE CONFLICT 06240000 TRIED=TRIED+1 06250000 IF(ERRCOD .EQ. 3 ) THEN 06260000 IF(TRIED .GE. 3) THEN 06270000 CALL M204EX(IFDTRD,ERRCOD,THRD,OTHRD) 06280000 GOTO 120 06290000 ENDIF 06300000 GOTO 112 06310000 ENDIF 06320000 C 06330000 IF(ERRCOD .NE. 0) THEN 06340000 CALL M204EX(IFGERR,ERRCOD,ERRMSG) 06350000 WRITE(6,*) 'LINE DATABASE FIND PROBLEM - ERROR # : ',ERRCOD 06360000 WRITE(6,*) ERRMSG 06370000 CALL M204EX(IFDTRD,ERRCOD,THRD,OTHRD) 06380000 GOTO 120 06390000 ENDIF 06400000 C 06410000 CALL M204EX(IFCNT,ERRCOD,COUNT) 06420000 IF(ERRCOD .NE. 0) THEN 06430000 CALL M204EX(IFGERR,ERRCOD,ERRMSG) 06440000 WRITE(6,*) 'LINE DATABASE COUNT PROBLEM - ERROR # : ',ERRCOD 06450000 WRITE(6,*) ERRMSG 06460000 CALL M204EX(IFDTRD,ERRCOD,THRD,OTHRD) 06470000 GOTO 120 06480000 ENDIF 06490000 C 06500000 IF(COUNT .LT. 1) THEN 06510000 CALL M204EX(IFDTRD,ERRCOD,THRD,OTHRD) 06520000 GOTO 120 06530000 ENDIF 06540000 C 06550000 TRIED=0 06560000 113 CALL M204EX(IFGET,ERRCOD,CREC,LGSPEC) 06570000 C FIRST CHECK FOR RECORD ENQUEUE CONFLICT 06580000 TRIED=TRIED+1 06590000 IF(ERRCOD .EQ. 3 ) THEN 06600000 IF(TRIED .GE. 3) THEN 06610000 CALL M204EX(IFDTRD,ERRCOD,THRD,OTHRD) 06620000 GOTO 120 06630000 ENDIF 06640000 GOTO 113 06650000 ENDIF 06660000 C 06670000 IF(ERRCOD .NE. 0) THEN 06680000 CALL M204EX(IFGERR,ERRCOD,ERRMSG) 06690000 WRITE(6,*) 'LINE DATABASE GET PROBLEM - ERROR # : ',ERRCOD 06700000 WRITE(6,*) ERRMSG 06710000 CALL M204EX(IFDTRD,ERRCOD,THRD,OTHRD) 06720000 ENDIF 06730000 C 06740000 C DELETE THE LINE THREAD 06750000 C 06760000 CALL M204EX(IFDTRD,ERRCOD,THRD,OTHRD) 06770000 C 06780000 C GOT THE LINE DATA, SO SET TYPE TO 4 06790000 C 06800000 TYPE=4 06810000 C 06820000 C ******************************************************************* 06830000 C 06840000 C FINALLY WE'RE READY TO UPDATE THE DATABASE 06850000 C 06860000 120 CONTINUE 06870000 C 06880000 C ALL DATA IS IN "CREC" SO JUST USE THE APPROPRIATE PUT SPECS 06890000 C "TYPE" IS THE UPDATE TYPE AS SET EARLIER 06900000 C 06910000 C CHECK FOR TRAILING TRASH IN TSO USERID FIELD 06920000 C 06930000 C 06940000 CREP 06950000 CREP IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789',CREC(180:180)) 06960000 CREP + .EQ. 0) CREC(180:180)=' ' 06970000 C 06980000 DO 125 III = 1, 36 06990000 IF (CREC(180:180) .EQ. GDCHAR(III:III)) GO TO 127 07000000 125 CONTINUE 07010000 CREC(180:180) = ' ' 07020000 127 CONTINUE 07030000 CREP 07040000 C 07050000 TRIED=0 07060000 130 CALL M204EX(IFPUT,ERRCOD,CREC,PSPEC(TYPE)) 07070000 C FIRST CHECK FOR RECORD ENQUEUE CONFLICT 07080000 TRIED=TRIED+1 07090000 IF(ERRCOD .EQ. 3 ) THEN 07100000 IF(TRIED .GE. 3) THEN 07110000 CALL M204EX(IFKALL,IFBOUT,ERRCOD) 07120000 IF(ERRCOD .NE. 0) THEN 07130000 CALL M204EX(IFGERR,ERRCOD,ERRMSG) 07140000 WRITE(6,*) 'DATABASE BACKOUT PROBLEM - ERROR # : ',ERRCOD 07150000 WRITE(6,*) ERRMSG 07160000 DBPROB = .TRUE. 07170000 ENDIF 07180000 CALL M204EX(IFFNSH,ERRCOD) 07190000 GOTO 995 07200000 ENDIF 07210000 GOTO 130 07220000 ENDIF 07230000 C 07240000 IF(ERRCOD .NE. 0) THEN 07250000 CALL M204EX(IFGERR,ERRCOD,ERRMSG) 07260000 WRITE(6,*) 'DATABASE RECORD PUT PROBLEM - ERROR # : ',ERRCOD 07270000 WRITE(6,*) ERRMSG 07280000 DBPROB = .TRUE. 07290000 CALL M204EX(IFKALL,IFBOUT,ERRCOD) 07300000 IF(ERRCOD .NE. 0) THEN 07310000 CALL M204EX(IFGERR,ERRCOD,ERRMSG) 07320000 WRITE(6,*) 'DATABASE BACKOUT PROBLEM - ERROR # : ',ERRCOD 07330000 WRITE(6,*) ERRMSG 07340000 DBPROB = .TRUE. 07350000 ENDIF 07360000 CALL M204EX(IFFNSH,ERRCOD) 07370000 GOTO 995 07380000 ENDIF 07390000 C 07400000 CALL M204EX(IFFNSH,ERRCOD) 07410000 IF(DBPROB) WRITE(6,*) 07420000 + 'DATABASE PROBLEM RESOLVED - SMS RECORD UPDATED SUCCESSFULLY' 07430000 RETURN 07440000 C 07450000 C **************************************************************** 07460000 C 07470000 C RETRY AND FLAT FILE OUTPUT CODE 07480000 C 07490000 990 REPLY = ' ' 07500000 CESN CALL USWTOR(OPMSG, 64, REPLY, 1, STATUS) 07510000 CESN IF (REPLY .NE. 'C') GOTO 5 07520000 C 07530000 C DYNAMICALLY ALLOCATE THE ALTERNATE FILE. 07540000 C 07550000 995 DDNAME = ' ' 07560000 CALL UGASMT(ALTDSN, DDNAME, DCBADR, ERR, ERIN) 07570000 IF (ERR .NE. 1) THEN 07580000 WRITE (6, 9000) ERR, ERIN 07590000 9000 FORMAT(' *** ERROR *** FOSMS: M204 IS DOWN. UNABLE TO ALLOCATE ', 07600000 * 'THE ALTERNATE DATASET ***',/,10X,'ERR,ERIN=',I6,1X,Z8) 07610000 GO TO 999 07620000 ENDIF 07630000 C 07640000 C SAVE JOB INFORMATION ON FLAT FILE. 07650000 C 07660000 REC(269:276) = JOBNAM 07670000 REC(277:280) = JOBNUM(5:8) 07680000 C 07690000 C OPEN FILE, WRITE THE RECORD TO THE FILE USING DISP 'MOD', 07700000 C AND CLOSE IT. 07710000 C 07720000 CALL FOMOD(ALTDSN, DCBADR, DDNAME, REC) 07730000 WRITE(6,*) 'SMS RECORD UPDATE WILL BE PERFORMED LATER' 07740000 C 07750000 C DEALLOCATE THE ALTERNATE DATASET. 07760000 C 07770000 CALL UGUNAL(DCBADR, ERR, ERIN) 07780000 IF (ERR .NE. 1) THEN 07790000 WRITE (6, 9040) ERR, ERIN 07800000 9040 FORMAT(' *** ERROR *** FOSMS: ERROR IN CALL TO UGUNAL, ERR, ', 07810000 * 'ERIN=',I6,1X,Z8) 07820000 GO TO 999 07830000 ENDIF 07840000 C 07850000 CALL M204EX(IFFNSH,ERRCOD) 07860000 RETURN 07870000 C 07880000 999 CONTINUE 07890000 CALL XDUMPX 07900000 RETURN 07910000 END 07920000