H*CTO, MON01 GROUP BEING ASSEMBLED.˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙HH*ASSEM˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙H H1 AVMBIT PAGE 1 DATE: 08/29/84H  d 0001 NAM AVMBIT A01 A CCS CCS 3.0 SL-149A0100001dd 0002 * A0100002dd 0003 * CYBERCREDIT SYSTEM VERSION 3 A0100003dd 0004 * DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA A0100004dd 0005 * COPYRIGHT CONTROL DATA CORPORATION, 1979 A0100005dd 0006 * A0100006dd 0007 * A0100007dd 0008 * CONSTRUCT BIT MASKS. A0100008dd 0009 * A0100009dd 0010 * ROUTINE TO REVIEW EACH CODE IN 'VRES' AND IF THE CODE IS IN 'RES'A0100010dd 0011 * SET THE CORRESPONDING BIT IN EITHER 'BIT1' OR 'BIT2'. IF A CODE A0100011dd 0012 * IN 'VRES' IS NOT FOUND IN 'RES', THE CODE IS FLAGGED FOR REPORTINA0100012dd 0013 * AS AN ERROR BY 'AVMCON'. 'BIT1' IS BIT MASK FOR RESULT CODES 1-16A0100013dd 0014 * AND 'BIT2' IS FOR RESULTS 17-32 . A0100014dd 0015 * A0100015dd 0016 * CALLING SEQUENCE: A0100016dd 0017 * CALL AVMBIT(RES,VRES,BIT1,BIT2) A0100017dd 0018 * WHERE: A0100018dd 0019 * RES - LIST OF ALL VALID RESULT CODES. A0100019dd 0020 * VRES - LIST OF RESULT CODES BIT MASKS ARE TO BE CONSTRUCTED FOR.A0100020dd 0021 * BIT1 - RETURNED BIT MASK FOR RESULT CODES 1 - 16. A0100021dd 0022 * BIT2 - RETURNED BIT MASK FOR RESULT CODES 17 - 32. A0100022dd 0023 * A0100023d  d 0025 ENT AVMBIT A0100025d  d 0027 * COMMUNICATIONS REGION USED. A0100027dd 0028 0002 EQU LPMASK($2) A0100028dd 0029 0012 EQU NZERO($12) A0100029dd 0030 0022 EQU ZERO($22) A0100030dd 0031 0023 EQU ONEBIT($23) A0100031d  d 0033 EXT AVMCKV CHECKS FOR PARTICULAR ELEMENT IN AN ARRAY. A0100033dH1 AVMBIT PAGE 2 DATE: 08/29/84H  d 0035 P0000 0000 AVMBIT 0 0 A0100035dd 0036 P0001 E8FE LDQ* AVMBIT PICK UP ADDRESS OF CALLER. A0100036dd 0037 P0002 0D04 INQ 4 INCREMENT RETURN VALUE TO NEXT EXECUTABLE A0100037dd 0038 P0003 48FC STQ* AVMBIT INSTRUCTION. A0100038dd 0039 P0004 5839 RTJ* PARGET PICK UP PARAMETER ADDRESSES. A0100039dd 0040 P0005 C832 LDA* RES PICK UP ADDRESS OF RES FOR SUBROUTINE CALL. A0100040dd 0041 P0006 6812 STA* CON150 STORE INTO PARAMETER LIST OF CALL. A0100041dd 0042 P0007 0A00 ENA 0 A0100042dd 0043 XFA 1 ZERO BIT MASKS R1 AND R2. A0100043d 0043 P0008 07C1 d 0044 XFA 2 A0100044d 0044 P0009 07C2 d 0045 CON050 XFA I I IS POINTER INTO VRES. A0100045d 0045 P000A 07C7 d 0046 P000B CD2D LDA* (VRES),I PICK UP NEXT CODE FROM VRES. A0100046dd 0047 P000C 0111 SAN CON055 SKIP IF CODE IS NON-ZERO. A0100047dd 0048 P000D 1824 JMP* CON300 CODE WAS ZERO FROM DUPLICATE ENTRY. BYPASS. A0100048dd 0049 P000E 682E CON055 STA* POS SAVE IN LOCAL VARIABLE. A0100049dd 0050 P000F B82C EOR* ASTRKS CHECK FOR TERMINATION - END OF CODES IN VRES. A0100050dd 0051 P0010 0115 SAN CON100 SKIP IF NOT THE END. A0100051dd 0052 CON060 SR1* (BIT1) CONSTRUCTION COMPLETE. SAVE BIT MASKS R1 AND RA0100052d 0052 P0011 04C1  0052 P0012 C127 d 0053 SR2* (BIT2) IN BIT1 AND BIT2. A0100053d 0053 P0013 04C2  0053 P0014 C126 d 0054 P0015 1832 JMP* CON500 EXIT RETURN. A0100054dd 0055 P0016 5400 X CON100 RTJ AVMCKV CHECK IF VRES(I) IS IN RES. A0100055d P0017 7FFF X d 0056 P0018 0000 CON150 NUM 0 ADDRESS OF RES. A0100056dd 0057 P0019 003C P ADC POS ADDRESS OF VRES(I). A0100057dd 0058 P001A C822 LDA* POS CHECK FOR VRES(I) NOT IN RES. A0100058dd 0059 P001B 0124 SAP CON160 SKIP IF VRES(I) IN RES. A0100059dd 0060 P001C CD1C LDA* (VRES),I ILLEGAL CODE IN VRES, FLAG IT AS AN ERROR. A0100060dd 0061 P001D 0864 TCA A A0100061dd 0062 P001E 6D1A STA* (VRES),I SET TO ITS COMPLEMENT AS THE FLAG. A0100062dd 0063 P001F 1812 JMP* CON300 CONTINUE PROCESSING IGNORING THIS CODE. A0100063dd 0064 CON160 XFA Q SAVE RETURNED INDEX IN Q. A0100064d 0064 P0020 07C5 d 0065 P0021 A027 AND- ONEBIT+4 CHECK WHICH REGISTER TO SET BIT IN. A0100065dd 0066 ANQ- LPMASK+4 INDEX ONLY BY FIRST FOUR BITS. A0100066d 0066 P0022 0405  0066 P0023 A006 d 0067 P0024 0852 TCQ Q COMPLEMENT TO GET INDEX FROM END OF MASK TABLEA0100067dd 0068 P0025 0116 SAN CON200 SKIP IF BIT TO BE SET IS IN R2. A0100068dd 0069 AR1- ONEBIT+15,Q RESULT CODE WAS IN FIRST 16, SET APPROPRIATE BA0100069d 0069 P0026 0429  0069 P0027 8032 d 0070 S1N CON300-*-1 SKIP IF ADDITION DID NOT YIELD ZERO. A0100070d 0070 P0028 0058 d 0071 LR1- NZERO SET TO $FFFF IF ADDITION CAUSED MASK TO GO TO A0100071d 0071 P0029 0401  0071 P002A C012 H1 AVMBIT PAGE 3 DATE: 08/29/84H  d 0072 P002B 1806 JMP* CON300 A0100072dd 0073 CON200 AR2- ONEBIT+15,Q RESULT CODE WAS IN 2ND 16, SET APPROPRAITE BITA0100073d 0073 P002C 042A  0073 P002D 8032 d 0074 S2N CON300-*-1 SKIP IF ADDITION DID NOT YIELD ZERO. A0100074d 0074 P002E 0092 d 0075 LR2- NZERO SET TO $FFFF IF ADDITION CAUSED MASK TO GO TO A0100075d 0075 P002F 0402  0075 P0030 C012 d 0076 CON300 XFI A BUMP POINTER TO GET NEXT CODE FROM VRES. A0100076d 0076 P0031 07E6 d 0077 P0032 09E0 INA -31 CHECK IF MAXIMUM NUMBER OF CODES PROCESSED. A0100077dd 0078 P0033 0131 SAM CON350 SKIP IF MAXIMUM NUMBER NOT PROCESSED. A0100078dd 0079 P0034 18DC JMP* CON060 ALL CODES DONE, SAVE BIT MASKS AND EXIT. A0100079dd 0080 P0035 0920 CON350 INA 32 RESTORE POINTER TO GET NEXT CODE. A0100080dd 0081 P0036 18D3 JMP* CON050 GO GET NEXT CODE. A0100081dH1 AVMBIT PAGE 4 DATE: 08/29/84H  d 0083 * VARIABLES AND CONSTANTS USED. A0100083dd 0084 * A0100084dd 0085 P0037 0000 RES NUM 0 ABSOLUTE ADDRESS OF RESULT CODE ARRAY. A0100085dd 0086 P0038 0000 VRES NUM 0 ABSOLUTE ADDRESS OF VALID RESULT CODES ARRAY. A0100086dd 0087 P0039 0000 BIT1 NUM 0 ABSOLUTE ADDRESS OF BIT MASK FOR RESULTS 1 - 1A0100087dd 0088 P003A 0000 BIT2 NUM 0 ABSOLUTE ADDRESS OF BIT MASK FOR RESULTS 17 - A0100088dd 0089 P003B 2A2A ASTRKS NUM $2A2A LITERAL ASTERISKS. A0100089dd 0090 P003C 0000 POS NUM 0 LOCAL VARIABLE USED FOR SUBROUTINE CALL. A0100090dH1 AVMBIT PAGE 5 DATE: 08/29/84H  d 0092 * ROUTINE TO PICK UP PARAMETER ADDRESSES FROM CALLER. A0100092dd 0093 * A0100093dd 0094 P003D 0000 PARGET 0 0 A0100094dd 0095 P003E E8C1 LDQ* AVMBIT CONTAINS THE STARTING ADDRESS + 4 OF PARAMETERA0100095dd 0096 P003F 0DFE INQ -1 LIST. MOVE TO END OF LIST. A0100096dd 0097 P0040 0A03 ENA 3 A0100097dd 0098 XFA I I IS INDEX INTO PARAMETER STORAGE. A0100098d 0098 P0041 07C7 d 0099 P0042 C622 PAR100 LDA- (ZERO),Q PICK UP ABSOLUTE ADDRESS OF NEXT PARAMETER. A0100099dd 0100 P0043 69F3 STA* RES,I STORE INTO PARAMETER STORAGE. A0100100dd 0101 P0044 0DFE INQ -1 DECREMENT TO GET NEXT PARAMETER ADDRESS. A0100101dd 0102 DIP *-PAR100 SKIP IF ALL PARAMETERS PICKED UP. A0100102d 0102 P0045 06E3 d 0103 P0046 1CF6 JMP* (PARGET) RETURN. A0100103dH1 AVMBIT PAGE 6 DATE: 08/29/84H  d 0105 P0047 1CB8 CON500 JMP* (AVMBIT) EXIT RETURN. A0100105dd 0106 END A0100106d  D PGM= 0048 ( 72) COM = 0000 ( 0) DAT = 0000 ( 0) D H1 AVMBIT PAGE 7 DATE: 08/29/84H     E Q U I V A L E N C E S -----------------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0000 I 00FF (000255) HH 0028 LPMASK 0002 (000002) 0066, 0066 HH 0029 NZERO 0012 (000018) 0071, 0071, 0075, 0075 HH 0030 ZERO 0022 (000034) 0099 HH 0031 ONEBIT 0023 (000035) 0065, 0069, 0069, 0073, 0073 HH1 AVMBIT PAGE 8 DATE: 08/29/84H     S Y M B O L S -------------  B DEF.LINE NAME ADDRESS REFERENCED AT LINE NUMBER B H 0025 AVMBIT 0000 0025, 0036, 0038, 0095, 0105 HH 0045 CON050 000A 0081 HH 0049 CON055 000E 0047 HH 0052 CON060 0011 0079 HH 0055 CON100 0016 0051 HH 0056 CON150 0018 0041 HH 0064 CON160 0020 0059 HH 0073 CON200 002C 0068 HH 0076 CON300 0031 0048, 0063, 0070, 0070, 0070, 0072HH 0074, 0074, 0074 HH 0080 CON350 0035 0078 HH 0085 RES 0037 0040, 0100 HH 0086 VRES 0038 0046, 0060, 0062 HH 0087 BIT1 0039 0052, 0052, 0052 HH 0088 BIT2 003A 0053, 0053, 0053 HH 0089 ASTRKS 003B 0050 HH 0090 POS 003C 0049, 0057, 0058 HH 0094 PARGET 003D 0039, 0103 HH 0099 PAR100 0042 0102, 0102, 0102, 0102 HH 0105 CON500 0047 0054 HH1 AVMBIT PAGE 9 DATE: 08/29/84H     E X T E R N A L S -----------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0033 AVMCKV 0017 0055 HH1 AVMBIT PAGE 10 DATE: 08/29/84H  > *** A L P H A B E T I C A L S O R T O F S Y M B O L S *** >  H ASTRKS 0089 AVMBIT 0025 AVMCKV 0033 BIT1 0087 BIT2 0088 HH CON050 0045 CON055 0049 CON060 0052 CON100 0055 CON150 0056 HH CON160 0064 CON200 0073 CON300 0076 CON350 0080 CON500 0105 HH I 0000 LPMASK 0028 NZERO 0029 ONEBIT 0031 PAR100 0099 HH PARGET 0094 POS 0090 RES 0085 VRES 0086 ZERO 0030 HH HP1 PH1 CCSADD PAGE 1 DATE: 08/29/84H  d 0001 NAM CCSADD A02 A CCS CCS 3.0 PSR'D SL-149********dd 0002 * A0200002dd 0003 * CYBERCREDIT SYSTEM VERSION 3 A0200003dd 0004 * DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA A0200004dd 0005 * COPYRIGHT CONTROL DATA CORPORATION, 1979 A0200005dd 0006 * A0200006dd 0007 * ADD STRING 1 TO STRING 2 AND PLACE THE SUM IN STRING 3 A0200007dd 0008 * A0200008dd 0009 * ROUTINE TO ADD 2 STRINGS OF ASCII CHARACTERS AND PLACE THE SUM A0200009dd 0010 * (IN ASCII FORMAT) INTO STRING 3 A0200010dd 0011 * A0200011dd 0012 * CALLING SEQUENCE: A0200012dd 0013 * CALL CCSADD(STR1,POS1,STR2,POS2,STR3,POS3) A0200013dd 0014 * A0200014dd 0015 * WHERE THE PARAMETERS HAVE THE FOLLOWING DEFINITION: A0200015dd 0016 * STR1 = ARRAY STRING 1 IS FROM - 9 CHARACTERS A0200016dd 0017 * POS1 = STARTING CHARACTER POSITION IN ARRAY FOR STRING 1 A0200017dd 0018 * STR2 = ARRAY STRING 2 IS FROM - 12 CHARACTERS A0200018dd 0019 * POS2 = STARTING CHARACTER POSITION IN ARRAY FOR STRING 2 A0200019dd 0020 * STR3 = ARRAY STRING 3 IS FROM - 12 CHARACTERS A0200020dd 0021 * POS3 = STARTING CHARACTER POSITION IN ARRAY FOR STRING 3 A0200021dd 0022 * A0200022dd 0023 * THE ARITHMETIC OPERATION PROCEEDS FROM RIGHT TO LEFT. A0200023dd 0024 * A0200024dd 0025 * THE LENGTHS OF THE ARRAYS ARE 9, 12, 12 RESPECTIVELY. A0200025dd 0026 * A0200026dd 0027 * ANY OVERFLOW WILL BE TRUNCATED ON THE LEFT. A0200027dd 0028 * A0200028dd 0029 * THE ARRAYS MUST CONTAIN VALID ASCII CHARACTERS. A0200029dd 0030 * A0200030dd 0031 * THE THREE STRING NEED NOT BE UNIQUE, THAT IS A NUMBER MAY BE A0200031dd 0032 * ADDED TO ITSELF-EXAMPLE: A0200032dd 0033 * CALL CCSADD(ARR1,4,ARR2,2,ARR2,2) A0200033dd 0034 * A0200034dd 0035 * ADDITION OF NEGATIVE NUMBERS IS ALLOWED WITH THE FOLLOWING A0200035dd 0036 * PROVISION- THE LAST DIGIT OF EACH ARRAY MUST REFLECT ITS SIGN A0200036dd 0037 * AS FOLLOWS: A0200037dd 0038 * NUMBER ASCII POS. ASCII NEG. WILL PRINT(IF NEG) A0200038dd 0039 * 0 30 7D ] A0200039dd 0040 * 1 31 4A J A0200040dd 0041 * 2 32 4B K A0200041dd 0042 * 3 33 4C L A0200042dd 0043 * 4 34 4D M A0200043dd 0044 * 5 35 4E N A0200044dd 0045 * 6 36 4F O A0200045dd 0046 * 7 37 50 P A0200046dd 0047 * 8 38 51 Q A0200047dd 0048 * 9 39 52 R A0200048dd 0049 * NOTE: IF THESE ARRAYS ARE TO BE PRINTED, THE LAST DIGIT WILL A0200049dd 0050 * HAVE TO BE CHANGED TO ITS ASSOCIATED ASCII VALUE (IF NEG.).A0200050dd 0051 * IF THEY ARE TO BE USED IN SUBSEQUENT ADDS, THE DIGIT WILL A0200051dd 0052 * HAVE TO RESTORED TO ITS ORIGINAL VALUE. A0200052dd 0053 * A0200053dH1 CCSADD PAGE 2 DATE: 08/29/84H  d 0054 DPK MAC A0200054dd 0055 VFD N4/0,N4/$F,N3/0,N5/$E A0200055dd 0056 EMC A0200056dd 0057 DAD MAC A0200057dd 0058 VFD N4/0,N4/$F,N3/0,N5/8 A0200058dd 0059 EMC A0200059dd 0060 DUN MAC A0200060dd 0061 VFD N4/0,N4/$F,N3/0,N5/$F A0200061dd 0062 EMC A0200062dd 0063 MOV MAC A0200063dd 0064 VFD N4/0,N4/$F,N3/0,N5/1 A0200064dd 0065 EMC A0200065dd 0066 ENT CCSADD A0200066dd 0067 0022 EQU ZERO($22) A0200067dd 0068 P0000 0000 CCSADD 0 0 A0200068dd 0069 * SAVE REGISTERS A0200069dd 0070 P0001 4800 STQ SAVEQ A0200070d P0002 00C5 d 0071 P0003 C0FF LDA- I A0200071dd 0072 P0004 6800 STA SAVEI A0200072d P0005 00C3   d 0074 P0006 E8F9 LDQ* CCSADD PICK UP ADDRESS OF CALLING PROGRAM A0200074dd 0075 P0007 0D06 INQ 6 MOVE TO NEXT EXECUTABLE INSTRUCTION A0200075dd 0076 P0008 48F7 STQ* CCSADD SAVE RETURN ADDRESS A0200076dd 0077 P0009 5800 RTJ PARGET PICK UP ADDRESS OF PARAMETERS A0200077d P000A 00BF   d 0079 *****************CONVERT ARRAY 1 FROM ASCII TO PACKED DECIMAL A0200079d  d 0082 P000B C000 LDA =XWK1 LOAD A WITH ADDRESS OF WORK AREA TO RECEIVE A0200082d P000C 00A0 P d 0083 * CONVERTED ASCII (TO PACKED DECIMAL) A0200083dd 0084 XFA 2 PUT IN REGISTER 2 A0200084d 0084 P000D 07C2 d 0085 P000E EC00 LDQ (POS1) STARTING POSITION IN FIRST ARRAY ???*A010********d P000F 008A d 0086 P0010 0DFE INQ -1 DECREMENT TO GET BYTE INDEX A0200086dd 0087 P0011 0A00 ENA 0 ZERO A FOR LONG LEFT SHIFT A0200087dd 0088 P0012 0FEF LLS 15 RESULT OF SHIFT - Q=BYTE OFFSET A=WORD OFFSET A0200088dd 0089 P0013 8800 ADD ARR1 ADD ADDR TO ARRAY 1 TO GET ACTUAL ADDR???*A010********d P0014 0084 d 0090 XFA 1 TRANSFER TO REGISTER 1 A0200090d 0090 P0015 07C1 d 0091 XFQ I SAVE BIT SHOWING BYTE OR WORD OFFSET A0200091d 0091 P0016 07A7 d 0092 * A0200092dd 0093 P0017 EC00 LDQ (POS1) LOAD Q WITH POSITION IN ARRAY OF FIRST???*A010********d P0018 0081 d 0094 P0019 0D07 INQ 7 CHAR-OFFSET TO LAST CHAR A0200094dH1 CCSADD PAGE 3 DATE: 08/29/84H  d 0095 SAVE1 LCA* (ARR1),Q SAVE THAT LAST BYTE TO BE RELOADED A0200095d 0095 P001A 04C5  0095 P001B C27D d 0096 P001C 6800 STA SCHAR AFTER CALL TO PACK ROUTINE A0200096d P001D 0081 d 0097 P001E 4800 STQ SOFST SAVE OFFSET TO BE USED IN RELOAD OF CHAR A0200097d P001F 0080  d 0099 P0020 09C5 INA -$3A ???*A010********dd 0100 P0021 0139 SAM L03 SENSE DIGIT ASCII, BYPASS CONVERSION ???*A010********dd 0101 P0022 09EF INA -$4A+$3A ???*A010********dd 0102 P0023 0122 SAP L01 SENSE NOT POSITIVE DIGIT ???*A010********dd 0103 P0024 093A INA -$10+$4A CONVERT POS. DIGIT($41-$49=POS. DIGITS???*A010********dd 0104 P0025 1804 JMP* L02 ???*A010********dd 0105 P0026 09CE L01 INA -$7B+$4A ???*A010********dd 0106 P0027 0114 SAN L04 SENSE NOT POSITIVE ZERO ???*A010********dd 0107 P0028 0A30 ENA $30 CONVERT POS. ZERO ???*A010********dd 0108 L02 SCA* (ARR1),Q STORE CONVERTED CHAR. ???*A010********d 0108 P0029 04C5  0108 P002A C36E d 0109 P002B 180C L03 JMP* ISPOS1 ???*A010********dd 0110 P002C 09FD L04 INA -$7D+$7B ???*A010********dd 0111 P002D 0102 SAZ ISZR1 SENSE NEG. ZERO ???*A010********dd 0112 P002E 0964 INA -$19+$7D CONVERT NEG. DIGIT($4A-$52=NEG. DIGITS???*A010********dd 0113 P002F 1802 JMP* ISNEG1 A0200110dd 0114 * A0200111dd 0115 P0030 0930 ISZR1 INA $30 SET A TO ZERO A0200112dd 0116 * A0200113dd 0117 ISNEG1 SCA* (ARR1),Q CORRECT LAST BYTE OF ARRAY TO ASCII A0200114d 0117 P0031 04C5  0117 P0032 C366 d 0118 P0033 C0FF LDA- I A0200115dd 0119 P0034 B000 EOR =N$6849 SET APPROPRIATE BITS FOR CALL A0200116d P0035 6849 d 0120 * BITS - 15 14-11 10-5 4-0 A0200117dd 0121 * B SIGN # OF # 0F A0200118dd 0122 * DIGIT DEC- DIGITS A0200119dd 0123 * D=NEG PLACES A0200120dd 0124 * A0200121dd 0125 * B= 0-WORD BOUNDARY A0200122dd 0126 * B= 1-BYTE BOUNDARY A0200123dd 0127 * B WAS SET IN EARLIER INSTRUCITONS A0200124dd 0128 P0036 1804 JMP* PACK1 A0200125dd 0129 * A0200126dd 0130 P0037 C0FF ISPOS1 LDA- I RESTORE BYTE OR WORD OFFSET A0200127dd 0131 P0038 B000 EOR =N$0049 FROM REG I AND SET APPROPRIATE BITS FOR CALL A0200128d P0039 0049 d 0132 * SEE ABOVE A0200129dd 0133 PACK1 DPK PERFORM THE PACK A0200130d 0133 P003A 0F0E d 0134 P003B C863 LDA* SCHAR RESTORE SAVED LAST CHARACTER A0200131dd 0135 P003C E863 LDQ* SOFST A0200132dd 0136 RESTA SCA* (ARR1),Q PUT SAVED CHARACTER INTO ARRAY A0200133dH1 CCSADD PAGE 4 DATE: 08/29/84H   0136 P003D 04C5  0136 P003E C35A   d 0138 **************************CONVERT ARRAY 2 TO PACKED DECIMAL A0200135d d 0140 * LOAD A WITH ADDRESS OF WORK AREA TO RECEIVE A0200137dd 0141 P003F C000 LDA =XWK2 CONVERTED ASCII (TO PACKED DECIMAL) A0200138d P0040 00AB P d 0142 XFA 2 PUT IN REGISTER 2 A0200139d 0142 P0041 07C2  d 0144 P0042 EC59 LDQ* (POS2) STARTING POSITION IN SECOND ARRAY A0200141dd 0145 P0043 0DFE INQ -1 DECREMENT TO GET BYTE INDEX A0200142dd 0146 P0044 0A00 ENA 0 ZERO A FOR LONG LEFT SHIFT A0200143dd 0147 P0045 0FEF LLS 15 RESULT OF SHIFT - Q=BYTE OFFSET A=WORD OFFSET A0200144dd 0148 P0046 8854 ADD* ARR2 ADD ADDRESS TO ARRAY 2 TO GET ACTUAL ADDRESS A0200145dd 0149 XFA 1 TRANSFER TO REGISTER 1 A0200146d 0149 P0047 07C1 d 0150 XFQ I SAVE BIT SHOWING BYTE OR WORD OFFSET A0200147d 0150 P0048 07A7 d 0151 * A0200148d d 0153 P0049 EC52 LDQ* (POS2) LOAD Q WITH POSITION IN ARRAY OF FIRST A0200150dd 0154 P004A 0D0A INQ 10 CHAR-INCREASE WITH OFFSET TO LAST CHAR A0200151dd 0155 * A0200152dd 0156 SAVE2 LCA* (ARR2),Q SAVE CHARACTER TO BE RELOADED AFTER CALL A0200153d 0156 P004B 04C5  0156 P004C C24E d 0157 P004D 6851 STA* SCHAR TO PACK A0200154d d 0159 P004E 4851 STQ* SOFST SAVE OFFSET TO BE USED IN RELOAD OF CHAR A0200156dd 0160 P004F 09C5 INA -$3A ???*A010********dd 0161 P0050 0139 SAM L13 SENSE DIGIT ASCII, BYPASS CONVERSION ???*A010********dd 0162 P0051 09EF INA -$4A+$3A ???*A010********dd 0163 P0052 0122 SAP L11 SENSE NOT POSITIVE DIGIT ???*A010********dd 0164 P0053 093A INA -$10+$4A CONVERT POS. DIGIT ???*A010********dd 0165 P0054 1804 JMP* L12 ???*A010********dd 0166 P0055 09CE L11 INA -$7B+$4A ???*A010********dd 0167 P0056 0114 SAN L14 SENSE NOT POSITIVE ZERO ???*A010********dd 0168 P0057 0A30 ENA $30 CONVERT POS. ZERO ???*A010********dd 0169 L12 SCA* (ARR2),Q STORE CONVERTED CHAR. ???*A010********d 0169 P0058 04C5  0169 P0059 C341 d 0170 P005A 180C L13 JMP* ISPOS2 ???*A010********dd 0171 P005B 09FD L14 INA -$7D+$7B ???*A010********dd 0172 P005C 0102 SAZ ISZR2 SENSE NEG. ZERO ???*A010********dd 0173 P005D 0964 INA -$19+$7D ???*A010********dd 0174 P005E 1802 JMP* ISNEG2 GO SET REST OF REGISTER A FOR NEGATIVE NO. A0200168dd 0175 P005F 0930 ISZR2 INA $30 RESET A TO ZERO A0200169dd 0176 * A0200170dd 0177 ISNEG2 SCA* (ARR2),Q CORRECT LAST BYTE OF WORK AREA A0200171d 0177 P0060 04C5 H1 CCSADD PAGE 5 DATE: 08/29/84H   0177 P0061 C339 d 0178 P0062 C0FF LDA- I RESTORE BYTE OR WORD OFFSET A0200172dd 0179 P0063 B000 EOR =N$684C SET APPROPRIATE BITS FOR CALL A0200173d P0064 684C d 0180 * BITS - 15 14-11 10-5 4-0 A0200174dd 0181 * B SIGN # OF # OF A0200175dd 0182 * DIGIT DEC. DIGITS A0200176dd 0183 * D=NEG PLACES A0200177dd 0184 * A0200178dd 0185 * B = 0-WORD BOUNDARY A0200179dd 0186 * B = 1-BYTE BOUNDARY A0200180dd 0187 * B IS SET IN EARLIER INSTRUCTIONS A0200181dd 0188 P0065 1804 JMP* PACK2 A0200182dd 0189 * A0200183dd 0190 P0066 C0FF ISPOS2 LDA- I RESTORE BYTE OR WORD OFFSET A0200184dd 0191 P0067 B000 EOR =N$004C FROM REG I AND SET APOPRIATE BITS FOR CALL A0200185d P0068 004C d 0192 * SEE ABOVE A0200186dd 0193 PACK2 DPK PERFORM THE PACK A0200187d 0193 P0069 0F0E d 0194 P006A C834 LDA* SCHAR RESTORE LAST CHARACTER A0200188dd 0195 P006B E834 LDQ* SOFST A0200189dd 0196 SCA* (ARR2),Q A0200190d 0196 P006C 04C5  0196 P006D C32D   d 0198 ***************************PERFORM THE ADD A0200192dd 0199 P006E C000 LDA =XWK1 TRANSFER ADDRESS OF WORK AREAS (CONVERTED TO A0200193d P006F 00A0 P d 0200 XFA 1 PACKED DECIMAL BY DPK INSTRUCTION) A0200194d 0200 P0070 07C1 d 0201 P0071 C000 LDA =XWK2 A0200195d P0072 00AB P d 0202 XFA 2 A0200196d 0202 P0073 07C2 d 0203 P0074 C000 LDA =XWK3 A0200197d P0075 00B6 P d 0204 XFA 3 A0200198d 0204 P0076 07C3 d 0205 * PERFORM THE ADD A0200199dd 0206 DAD A0200200d 0206 P0077 0F08   d 0208 **************************CONVERT ANSWER TO ASCII TO SEND BACK A0200202d d 0210 P0078 C000 LDA =XWK3 TRANSFER ADDRESS OF ANSWER FROM ADD TO A0200204d P0079 00B6 P d 0211 XFA 1 REGISTER 1 A0200205d 0211 P007A 07C1 d 0212 P007B C000 LDA =XWK4 TRANSFER ADDRESS OF AREA TO RECEIVE A0200206d P007C 00C1 P H1 CCSADD PAGE 6 DATE: 08/29/84H  d 0213 XFA 2 UNPACKED ANSWER TO REGISTER 2 A0200207d 0213 P007D 07C2  d 0215 * READY REGISTER Q-THE INPUT TO THE SUBROUTINE A0200209dd 0216 * IS ALWAYS ON WORD BOUNDARY A0200210dd 0217 P007E 0A00 ENA 0 A0200211dd 0218 P007F B000 EOR =N$004C A0200212d P0080 004C d 0219 * THE BITS FOR THIS INSTRUCTIONS ARE: A0200213dd 0220 * BITS- 15 14-11 10-5 4-0 A0200214dd 0221 * 0 ZERO # OF # OF A0200215dd 0222 * DEC. DIGITS A0200216dd 0223 * PLACES A0200217dd 0224 XFA Q A0200218d 0224 P0081 07C5 d 0225 DUN PERFORM THE UNPACK A0200219d 0225 P0082 0F0F d 0226 * THE ANSWER MUST BE MOVED TO OUTPUT ARRAY A0200220dd 0227 P0083 C000 LDA =XWK4 SINCE THE OUTPUT ARRAY WILL NOT ALWAYS A0200221d P0084 00C1 P d 0228 XFA 1 BE ON BYTE BOUNDARY A0200222d 0228 P0085 07C1 d 0229 P0086 EC17 LDQ* (POS3) LOAD Q WITH INDEX INTO OUTPUT ARRAY A0200223dd 0230 P0087 0DFE INQ -1 DECREMENT TO GET BYTE OFFSET A0200224dd 0231 P0088 0A00 ENA 0 ZERO A FOR LONG LEFT SHIFT A0200225dd 0232 P0089 0FEF LLS 15 RESULT OF SHIFT - Q=BYTE INDEX A=WORD INDEX A0200226dd 0233 P008A 8812 ADD* ARR3 ADD INDEX TO SET TO BEGINNING BYTE OF OUTPUT A0200227dd 0234 XFA 2 TRANSFER THAT ADDRESS TO 2 A0200228d 0234 P008B 07C2 d 0235 ERQ =N$000C INCREASE Q WITH LENGTH OF DESTINATION ARRAY A0200229d 0235 P008C 0405  0235 P008D B000  0235 P008E 000C d 0236 P008F 0A00 ENA 0 A0200230dd 0237 P0090 B000 EOR =N$000C INCREASE A WITH LENGTH OF SOURCE ARRAY A0200231d P0091 000C d 0238 MOV PERFORM THE MOVE A0200232d 0238 P0092 0F01 d 0239 * RESTORE REGISTERS A0200233dd 0240 P0093 C835 LDA* SAVEI A0200234dd 0241 P0094 60FF STA- I A0200235dd 0242 P0095 E832 LDQ* SAVEQ A0200236d d 0244 P0096 1C00 JMP (CCSADD) RETURN A0200238d P0097 FF68 H1 CCSADD PAGE 7 DATE: 08/29/84H  d 0246 * VARIABLES USED A0200240dd 0247 * A0200241dd 0248 P0098 0000 ARR1 NUM 0 ADDRESS OF FIRST ARRAY A0200242dd 0249 P0099 0000 POS1 NUM 0 ADDRESS OF FIRST POSITION A0200243dd 0250 P009A 0000 ARR2 NUM 0 ADDRESS OF SECOND ARRAY A0200244dd 0251 P009B 0000 POS2 NUM 0 ADDRESS OF SECOND POSITION A0200245dd 0252 P009C 0000 ARR3 NUM 0 ADDRESS OF THIRD ARRAY A0200246dd 0253 P009D 0000 POS3 NUM 0 ADDRESS OF THIRD POSITION A0200247dd 0254 P009E 0000 SCHAR NUM 0 A0200248dd 0255 P009F 0000 SOFST NUM 0 A0200249dd 0256 P00A0 000B BZS WK1(11),WK2(11),WK3(11),WK4(6) WORK ARRAYS A0200250d P00AB 000B  P00B6 000B  P00C1 0006 d 0257 P00C7 0000 SAVEQ NUM 0 A0200251dd 0258 P00C8 0000 SAVEI NUM 0 A0200252d        d 0261 * ROUTINE TO PICK UP PARAMETER ADDRESSES A0200255dd 0262 * A0200256dd 0263 P00C9 0000 PARGET 0 0 A0200257dd 0264 P00CA E800 LDQ CCSADD PICK UP LOCATION OF CALLER + 6 A0200258d P00CB FF34 d 0265 P00CC 0DFE INQ -1 MOVE TO END OF PARAMETER LIST A0200259dd 0266 P00CD 0A05 ENA 5 SET UP INDEX INTO PARAMETER STORAGE A0200260dd 0267 P00CE 60FF STA- I A0200261dd 0268 P00CF C622 PAR100 LDA- (ZERO),Q PICK UP ABSOLUTE ADDRESS OF PARAMETER A0200262dd 0269 P00D0 69C7 STA* ARR1,I STORE IN PARAMETER LIST A0200263dd 0270 P00D1 0DFE INQ -1 DECREMENT INDEX INTO PARAMETER LIST A0200264dd 0271 DIP *-PAR100 SKIP IF ALL PARAMEETER ADDRESS RETRIEVED A0200265d 0271 P00D2 06E3 d 0272 P00D3 1CF5 JMP* (PARGET) RETURN A0200266dd 0273 END A0200267d  D PGM= 00D4 ( 212) COM = 0000 ( 0) DAT = 0000 ( 0) D H1 CCSADD PAGE 8 DATE: 08/29/84H     E Q U I V A L E N C E S -----------------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0000 I 00FF (000255) 0071, 0118, 0130, 0178, 0190, 0241HH 0267 HH 0067 ZERO 0022 (000034) 0268 HH1 CCSADD PAGE 9 DATE: 08/29/84H     S Y M B O L S -------------  B DEF.LINE NAME ADDRESS REFERENCED AT LINE NUMBER B H 0066 CCSADD 0000 0066, 0074, 0076, 0244, 0264 HH 0095 SAVE1 001A HH 0105 L01 0026 0102 HH 0108 L02 0029 0104 HH 0109 L03 002B 0100 HH 0110 L04 002C 0106 HH 0115 ISZR1 0030 0111 HH 0117 ISNEG1 0031 0113 HH 0130 ISPOS1 0037 0109 HH 0133 PACK1 003A 0128 HH 0136 RESTA 003D HH 0156 SAVE2 004B HH 0166 L11 0055 0163 HH 0169 L12 0058 0165 HH 0170 L13 005A 0161 HH 0171 L14 005B 0167 HH 0175 ISZR2 005F 0172 HH 0177 ISNEG2 0060 0174 HH 0190 ISPOS2 0066 0170 HH 0193 PACK2 0069 0188 HH 0248 ARR1 0098 0089, 0095, 0095, 0095, 0108, 0108HH 0108, 0117, 0117, 0117, 0136, 0136HH 0136, 0269 HH 0249 POS1 0099 0085, 0093 HH 0250 ARR2 009A 0148, 0156, 0156, 0156, 0169, 0169HH 0169, 0177, 0177, 0177, 0196, 0196HH 0196 HH 0251 POS2 009B 0144, 0153 HH 0252 ARR3 009C 0233 HH 0253 POS3 009D 0229 HH 0254 SCHAR 009E 0096, 0134, 0157, 0194 HH 0255 SOFST 009F 0097, 0135, 0159, 0195 HH 0256 WK1 00A0 0082, 0199 HH 0256 WK2 00AB 0141, 0201 HH 0256 WK3 00B6 0203, 0210 HH 0256 WK4 00C1 0212, 0227 HH 0257 SAVEQ 00C7 0070, 0242 HH 0258 SAVEI 00C8 0072, 0240 HH 0263 PARGET 00C9 0077, 0272 HH 0268 PAR100 00CF 0271, 0271, 0271, 0271 HH1 CCSADD PAGE 10 DATE: 08/29/84H  > *** A L P H A B E T I C A L S O R T O F S Y M B O L S *** >  H ARR1 0248 ARR2 0250 ARR3 0252 CCSADD 0066 I 0000 HH ISNEG1 0117 ISNEG2 0177 ISPOS1 0130 ISPOS2 0190 ISZR1 0115 HH ISZR2 0175 L01 0105 L02 0108 L03 0109 L04 0110 HH L11 0166 L12 0169 L13 0170 L14 0171 PACK1 0133 HH PACK2 0193 PAR100 0268 PARGET 0263 POS1 0249 POS2 0251 HH POS3 0253 RESTA 0136 SAVE1 0095 SAVE2 0156 SAVEI 0258 HH SAVEQ 0257 SCHAR 0254 SOFST 0255 WK1 0256 WK2 0256 HH WK3 0256 WK4 0256 ZERO 0067 HP1 PH1 CCSBLK PAGE 1 DATE: 08/29/84H  d 0001 NAM CCSBLK A03 A CCS CCS 3.0 SL-149A0300001dd 0002 * A0300002dd 0003 * A0300003dd 0004 * CYBERCREDIT SYSTEM VERSION 3 A0300004dd 0005 * DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA A0300005dd 0006 * COPYRIGHT CONTROL DATA CORPORATION, 1979 A0300006dd 0007 * A0300007dd 0008 * BLANK FILL ARRAY FOR SPECIFIED NUMBER OF BYTES. A0300008dd 0009 * A0300009dd 0010 * ROUTINE TO BLANK FILL (ASCII,$2020) ARRAY 'BUF' WITH 'BYTLEN' A0300010dd 0011 * BLANKS, WHERE 'BYTLEN' IS THE NUMBER OF BYTES IN 'BUF' TO BE A0300011dd 0012 * BLANKED. A0300012dd 0013 * CALLING SEQUENCE: A0300013dd 0014 * CALL CCSBLK(BUF,BYTLEN) A0300014dd 0015 * WHERE: A0300015dd 0016 * BUF - THE BUFFER TO BE BLANK FILLED. A0300016dd 0017 * BYTLEN - THE NUMBER OF BYTES IN BUF TO BE BLANKED. A0300017dd 0018 * A0300018dd 0019 MOV MAC A0300019dd 0020 VFD N4/0,N4/$F,N3/0,N5/1 MOVE STRING REQUEST. A0300020dd 0021 EMC A0300021d  d 0023 ENT CCSBLK A0300023d  d 0025 * COMMUNICATIONS REGION USED. A0300025dd 0026 0022 EQU ZERO($22) A0300026d  d 0028 * THE BLANKING OPERATION IS DONE VIA THE MOVE STRING REQUEST. IF THA0300028dd 0029 * LENGTH OF STRING 1 (A REG.) IS SET TO ZERO, STRING 2 IS ENTIRELY A0300029dd 0030 * FILLED WITH BLANKS. A0300030d  d 0032 P0000 0000 CCSBLK 0 0 A0300032d d 0034 P0001 480E STQ* SAVEQ SAVE Q REGISTER. A0300034d d 0036 P0002 E8FD LDQ* CCSBLK PICK UP ADDRESS OF BUFFER TO BE BLANKED. A0300036dd 0037 P0003 0814 TRQ A A0300037dd 0038 P0004 0902 INA 2 A0300038dd 0039 P0005 68FA STA* CCSBLK RETURN VALUE. A0300039dd 0040 P0006 C622 LDA- (ZERO),Q A0300040dd 0041 XFA 2 R2 CONTAINS THE DESTINATION STRING ADDRESS, INA0300041d 0041 P0007 07C2 d 0042 * THIS CASE, THE BUFFER TO BE BLANKED. A0300042dd 0043 P0008 0D01 INQ 1 INCREMENT TO GET NEXT PARAMETER, BYTLEN. A0300043dd 0044 P0009 E622 LDQ- (ZERO),Q PICK UP ADDRESS OF NEXT PARAMETER, BYTLEN. A0300044dd 0045 P000A E622 LDQ- (ZERO),Q PICK UP VALUE OF PARAMETER. A0300045dd 0046 P000B 0A00 ENA 0 SET LENGTH OF STRING 1 TO ZERO. A0300046dd 0047 MOV PERFORM THE BLANKING OPERATION. A0300047d 0047 P000C 0F01 H1 CCSBLK PAGE 2 DATE: 08/29/84H  d 0048 P000D E802 LDQ* SAVEQ RESTORE Q REGISTER. A0300048dd 0049 P000E 1CF1 JMP* (CCSBLK) EXIT RETURN. A0300049d d 0051 P000F 0000 SAVEQ NUM 0 A0300051dd 0052 END A0300052d  D PGM= 0010 ( 16) COM = 0000 ( 0) DAT = 0000 ( 0) D H1 CCSBLK PAGE 3 DATE: 08/29/84H     E Q U I V A L E N C E S -----------------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0000 I 00FF (000255) HH 0026 ZERO 0022 (000034) 0040, 0044, 0045 HH1 CCSBLK PAGE 4 DATE: 08/29/84H     S Y M B O L S -------------  B DEF.LINE NAME ADDRESS REFERENCED AT LINE NUMBER B H 0023 CCSBLK 0000 0023, 0036, 0039, 0049 HH 0051 SAVEQ 000F 0034, 0048 HH1 CCSBLK PAGE 5 DATE: 08/29/84H  > *** A L P H A B E T I C A L S O R T O F S Y M B O L S *** >  H CCSBLK 0023 I 0000 SAVEQ 0051 ZERO 0026 HP1 PH1 CCSCST PAGE 1 DATE: 08/29/84H  d 0001 NAM CCSCST A04 A CCS CCS 3.0 SL-149A0400001dd 0002 * A0400002dd 0003 * A0400003dd 0004 * CYBERCREDIT SYSTEM VERSION 3 A0400004dd 0005 * DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA A0400005dd 0006 * COPYRIGHT CONTROL DATA CORPORATION, 1979 A0400006dd 0007 * A0400007dd 0008 * COMPARE STRING REQUEST FOR LESS THAN, EQUALITY, AND GREATER THAN.A0400008dd 0009 * A0400009dd 0010 * ROUTINE TO COMPARE TWO STRINGS OF BYTES OF SPECIFIED LENGTHS AND A0400010dd 0011 * DETERMINE WHETHER STRING 1 IS LESS THAN, EQUAL TO, OR GREATER THAA0400011dd 0012 * STRING 2. A0400012dd 0013 * CALLING SEQUENCE: A0400013dd 0014 * CALL CCSCST(STR1,POS1,LEN1,STR2,POS2,LEN2,COMPIN) A0400014dd 0015 * WHERE THE PARMATERS HAVE THE FOLLOWING DEFINTION: A0400015dd 0016 * STR1 = ARRAY STRING 1 IS FROM. A0400016dd 0017 * POS1 = STARTING CHARATER POSITION IN ARRAY FOR STRING 1. A0400017dd 0018 * LEN1 = LENGTH IN BYTES OF STRING 1. A0400018dd 0019 * STR2 = ARRAY STRING 2 IS FROM. A0400019dd 0020 * POS2 = STARTING CHARACTER POSITION IN ARRAY FOR STRING 2. A0400020dd 0021 * LEN2 = LENGTH IN BYTES OF STRING 2. A0400021dd 0022 * COMPIN = COMPARISON INDICATOR FOR RETURN. RETURNED VALUES ARE: A0400022dd 0023 * < 0 STRING 1 LESS THAN STRING 2 A0400023dd 0024 * = 0 STRING 1 EQUALS STRING 2 A0400024dd 0025 * AND > 0 STRING 1 GREATER THAN STRING 2 . A0400025dd 0026 * A0400026dd 0027 * THESE VALUES FOR COMPIN ALLOW ANY LOGICAL COMPARISON OF THE TWO A0400027dd 0028 * STRINGS: A0400028dd 0029 * STRING COMPARISON COMPIN VALUE A0400029dd 0030 * EQ EQ 0 A0400030dd 0031 * NE NE 0 A0400031dd 0032 * LE LE 0 A0400032dd 0033 * LT LT 0 A0400033dd 0034 * GE GE 0 A0400034dd 0035 * GT GT 0 A0400035dd 0036 * A0400036dd 0037 SLT MAC A0400037dd 0038 VFD N4/0,N4/$F,N3/0,N5/5 SKIP IF STRING LESS THAN. A0400038dd 0039 EMC A0400039dd 0040 SGT MAC A0400040dd 0041 VFD N4/0,N4/$F,N3/0,N5/7 SKIP IF STRING GREATER THAN. A0400041dd 0042 EMC A0400042d  d 0044 ENT CCSCST A0400044d d 0046 * COMMUNICATIONS REGION USED. A0400046dd 0047 0003 EQU ONE($3) A0400047dd 0048 0022 EQU ZERO($22) A0400048dH1 CCSCST PAGE 2 DATE: 08/29/84H  d 0050 P0000 0000 CCSCST 0 0 A0400050d d 0052 * SAVE REGISTERS. A0400052dd 0053 P0001 4833 STQ* SAVEQ A0400053dd 0054 P0002 C0FF LDA- I A0400054dd 0055 P0003 6832 STA* SAVEI A0400055d d 0057 P0004 E8FB LDQ* CCSCST PICK UP ADDRESS OF CALLER. A0400057dd 0058 P0005 0D07 INQ 7 MOVE RETURN ADDRESS TO NEXT EXECUTABLE INSTRUCTA0400058dd 0059 P0006 48F9 STQ* CCSCST SAVE RETURN ADDRESS. A0400059dd 0060 P0007 582F RTJ* PARGET PICK UP ADDRESS OF PARAMETERS FROM CALLER. A0400060dd 0061 P0008 0AFE ENA -1 INITIALIZE RETURN VALUE OF COMPIN. A0400061dd 0062 P0009 6C2A STA* (COMPIN) A0400062dd 0063 P000A 0A01 ENA 1 INITIALIZE FLAG FOR WHICH COMPARISON TO A0400063dd 0064 XFA 4 PERFORM. A0400064d 0064 P000B 07C4 d 0065 P000C EC22 COM100 LDQ* (POS1) PICK UP START CHARACTER POSITION IN STRING 1. A0400065dd 0066 P000D 0DFE INQ -1 DECREMENT TO GET BYTE COUNT. A0400066dd 0067 P000E 0A00 ENA 0 ZERO A FOR LONG LEFT SHIFT. A0400067dd 0068 P000F 0FEF LLS 15 Q = BYTE OFFSET, A = START WORD INDEX. A0400068dd 0069 XFQ 3 SAVE BYTE OFFSET. A0400069d 0069 P0010 07A3 d 0070 P0011 881C ADD* STR1 ADD BASE ADDRESS TO GET WORD ADDRESS OF STRING A0400070dd 0071 XFA 1 SAVE ADDRESS IN R1. A0400071d 0071 P0012 07C1 d 0072 P0013 EC1E LDQ* (POS2) PICK UP START CHARACTER POSITION IN STRING 2. A0400072dd 0073 P0014 0DFE INQ -1 DECREMENT TO GET BYTE COUNT. A0400073dd 0074 P0015 0A00 ENA 0 ZERO A FOR LONG LEFT SHIFT A0400074dd 0075 P0016 0FEF LLS 15 Q = BYTE OFFSET, A = START WORD INDEX. A0400075dd 0076 P0017 8819 ADD* STR2 ADD BASE ADDRESS TO GET WORD ADDRESS OF STRING A0400076dd 0077 XFA 2 SAVE ADDRESS IN R2. A0400077d 0077 P0018 07C2 d 0078 P0019 FC19 ADQ* (LEN2) ADD LENGTH OF STRING 2 TO BYTE OFFSET OF STRINGA0400078dd 0079 XF3 A RECALL BYTE OFFSET OF STRING 1. A0400079d 0079 P001A 0766 d 0080 P001B 8C14 ADD* (LEN1) ADD LENGTH OF STRING 1 TO BYTE OFFSET OF STRINGA0400080dd 0081 S4Z COM200-*-1 SKIP IF GREATER THAN COMPARISON TO BE DONE. A0400081d 0081 P001C 0003 d 0082 SLT SKIP IF STRING 1 LESS THAN STRING 2. A0400082d 0082 P001D 0F05 d 0083 P001E 1805 JMP* COM300 STRING NOT LESS THAN, BUMP COMPIN AND CHECK GT.A0400083dd 0084 P001F 1809 JMP* COM500 STRING LESS THAN. RETURN. A0400084dd 0085 COM200 SGT SKIP IF STRING 1 LESS THAN STRING 2. A0400085d 0085 P0020 0F07 d 0086 P0021 1807 JMP* COM500 STRING NOT GREATER THAN, MUST BE EQUAL. RETURN.A0400086dd 0087 P0022 1805 JMP* COM400 STRING GREATER THAN, BUMP COMPIN AND RETURN. A0400087dd 0088 P0023 DC10 COM300 RAO* (COMPIN) BUMP COMPARE INDICATOR. A0400088dd 0089 SB4- ONE SET FLAG FOR WHICH COMPARISON FUNCTION TO GT. A0400089d 0089 P0024 0404  0089 P0025 9003 d 0090 P0026 18E5 JMP* COM100 NOT LESS THAN, CHECK FOR GREATER THAN. A0400090dd 0091 P0027 DC0C COM400 RAO* (COMPIN) BUMP COMPARE INDICATOR FOR GRETAER THAN CONDITIA0400091d H1 CCSCST PAGE 3 DATE: 08/29/84H  d 0093 * RESTORE REGISTERS. A0400093dd 0094 P0028 60FF COM500 STA- I A0400094dd 0095 P0029 E80B LDQ* SAVEQ A0400095dd 0096 P002A C80B LDA* SAVEI A0400096dd 0097 P002B 60FF STA- I A0400097dd 0098 P002C 1CD3 JMP* (CCSCST) RETURN. A0400098dH1 CCSCST PAGE 4 DATE: 08/29/84H  d 0100 * PARAMETER STORAGE. A0400100dd 0101 * A0400101dd 0102 P002D 0000 STR1 NUM 0 ABSOLUTE ADDRESS OF ARRAY STRING 1 IS FROM. A0400102dd 0103 P002E 0000 POS1 NUM 0 ABSOLUTE ADDRESS OF CHAR POS STRING 1 BEGINS INA0400103dd 0104 P002F 0000 LEN1 NUM 0 ABSOLUTE ADDRESS OF LENGTH OF STRING 1. A0400104dd 0105 P0030 0000 STR2 NUM 0 ABSOLUTE ADDRESS OF ARRAY STRING 2 IS FROM. A0400105dd 0106 P0031 0000 POS2 NUM 0 ABSLOUTE ADDRESS OF CHAR POS STRING 2 BEGINS INA0400106dd 0107 P0032 0000 LEN2 NUM 0 ABSOLUTE ADDRESS OF LENGTH OF STRING 2. A0400107dd 0108 P0033 0000 COMPIN NUM 0 ABSOLUTE ADDRESS OF COMPARE INDICATOR. A0400108dd 0109 P0034 0000 SAVEQ NUM 0 A0400109dd 0110 P0035 0000 SAVEI NUM 0 A0400110d    d 0112 * ROUTINE TO PICK PARAMETER ADDRESSES. A0400112dd 0113 P0036 0000 PARGET 0 0 A0400113dd 0114 P0037 E8C8 LDQ* CCSCST PICK UP ADDRESS OF CALLER + 7. A0400114dd 0115 P0038 0DFE INQ -1 MOVE TO END OF PARAMETER LIST. A0400115dd 0116 P0039 0A06 ENA 6 INTIALIZE INDEX INTO PARAMETER STORAGE. A0400116dd 0117 P003A 60FF STA- I A0400117dd 0118 P003B C622 PAR100 LDA- (ZERO),Q PICK UP ABSOLUTE ADDRESS OF NEXT PARAMETER. A0400118dd 0119 P003C 69F0 STA* STR1,I STORE ADDRESS IN PARAMETER STORAGE. A0400119dd 0120 P003D 0DFE INQ -1 DECREMENT INDEX IN PARAMETER LIST. A0400120dd 0121 DIP *-PAR100 SKIP IF ALL PARAMETER ADDRESSES RETRIEVED. A0400121d 0121 P003E 06E3 d 0122 P003F 1CF6 JMP* (PARGET) RETURN. A0400122d  d 0124 END A0400124d  D PGM= 0040 ( 64) COM = 0000 ( 0) DAT = 0000 ( 0) D H1 CCSCST PAGE 5 DATE: 08/29/84H     E Q U I V A L E N C E S -----------------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0000 I 00FF (000255) 0054, 0094, 0097, 0117 HH 0047 ONE 0003 (000003) 0089, 0089 HH 0048 ZERO 0022 (000034) 0118 HH1 CCSCST PAGE 6 DATE: 08/29/84H     S Y M B O L S -------------  B DEF.LINE NAME ADDRESS REFERENCED AT LINE NUMBER B H 0044 CCSCST 0000 0044, 0057, 0059, 0098, 0114 HH 0065 COM100 000C 0090 HH 0085 COM200 0020 0081, 0081, 0081 HH 0088 COM300 0023 0083 HH 0091 COM400 0027 0087 HH 0094 COM500 0028 0084, 0086 HH 0102 STR1 002D 0070, 0119 HH 0103 POS1 002E 0065 HH 0104 LEN1 002F 0080 HH 0105 STR2 0030 0076 HH 0106 POS2 0031 0072 HH 0107 LEN2 0032 0078 HH 0108 COMPIN 0033 0062, 0088, 0091 HH 0109 SAVEQ 0034 0053, 0095 HH 0110 SAVEI 0035 0055, 0096 HH 0113 PARGET 0036 0060, 0122 HH 0118 PAR100 003B 0121, 0121, 0121, 0121 HH1 CCSCST PAGE 7 DATE: 08/29/84H  > *** A L P H A B E T I C A L S O R T O F S Y M B O L S *** >  H CCSCST 0044 COM100 0065 COM200 0085 COM300 0088 COM400 0091 HH COM500 0094 COMPIN 0108 I 0000 LEN1 0104 LEN2 0107 HH ONE 0047 PAR100 0118 PARGET 0113 POS1 0103 POS2 0106 HH SAVEI 0110 SAVEQ 0109 STR1 0102 STR2 0105 ZERO 0048 HH HP1 PH1 CCSEAC PAGE 1 DATE: 08/29/84H  d 0001 NAM CCSEAC A05 A CCS CCS 3.0 PSR'D SL-149********dd 0002 * A0500002dd 0003 * CYBERCREDIT SYSTEM VERSION 3 A0500003dd 0004 * DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA CALIFORNIA A0500004dd 0005 * COPYRIGHT CONTROL DATA CORPORATION, 1979 A0500005dd 0006 * EBCDIC TO ASCII AND ASCII TO EBCDIC CONVERSION A0500006d d 0008 * THIS ROUTINE WILL CONVERT AN EBCDIC BUFFER TO ASCII, OR AN ASCII A0500008dd 0009 * BUFFER TO EBCDIC. THE CONVERSION WILL ONLY CONVERT THE 64 CHAR- A0500009dd 0010 * ACTER SET-INCLUDING NEGATIVE OVERPUNCH. A0500010dd 0011 * ASCII CHARACTER EBCDIC ASCII CHARACTER EBCDICA0500011dd 0012 * -------------------------- -------------------------- A0500012dd 0013 * $20 (BLANK) $40 $40 @ $7C A0500013dd 0014 * 21 ! 5A 41 A C1 A0500014dd 0015 * 22 " 7F 42 B C2 A0500015dd 0016 * 23 # 7B 43 C C3 A0500016dd 0017 * 24 $ 5B 44 D C4 A0500017dd 0018 * 25 % 6C 45 E C5 A0500018dd 0019 * 26 & 50 46 F C6 A0500019dd 0020 * 27 ' 7D 47 G C7 A0500020dd 0021 * 28 ( 4D 48 H C8 A0500021dd 0022 * 29 ) 5D 49 I C9 A0500022dd 0023 * 2A * 5C 4A J D1 A0500023dd 0024 * 2B + 4E 4B K D2 A0500024dd 0025 * 2C , 6B 4C L D3 A0500025dd 0026 * 2D - 60 4D M D4 A0500026dd 0027 * 2E . 4B 4E N D5 A0500027dd 0028 * 2F / 61 4F O D6 A0500028dd 0029 * 30 0 F0 50 P D7 A0500029dd 0030 * 31 1 F1 51 Q D8 A0500030dd 0031 * 32 2 F2 52 R D9 A0500031dd 0032 * 33 3 F3 53 S E2 A0500032dd 0033 * 34 4 F4 54 T E3 A0500033dd 0034 * 35 5 F5 55 U E4 A0500034dd 0035 * 36 6 F6 56 V E5 A0500035dd 0036 * 37 7 F7 57 W E6 A0500036dd 0037 * 38 8 F8 58 X E7 A0500037dd 0038 * 39 9 F9 59 Y E8 A0500038dd 0039 * 3A : 7A 5A Z E9 A0500039dd 0040 * 3B ; 5E 5B [ 4A A0500040dd 0041 * 3C < 4C 5C \ 5F A0500041dd 0042 * 3D = 7E 5D ] 27 A0500042dd 0043 * 3E > 6E 5E ^ 4F A0500043dd 0044 * 3F ? 6F 5F _ 6D A0500044dd 0045 * 7D (NULL) D0 A0500045dd 0046 * ****************************************************** ???*A010********dd 0047 * 30 0 C0 ********dd 0048 * ***************************************************** ???*A010********d d 0050 * A CALLING OPTION IS AVAILABLE TO HANDLE CHARACTERS OUTSIDE OF A0500047dd 0051 * THIS CHARACTER SET IN ONE OF TWO WAYS: A0500048dd 0052 * 1) LEAVE UNCHANGED A0500049dd 0053 * OR 2) CONVERT TO BLANKS. A0500050dH1 CCSEAC PAGE 2 DATE: 08/29/84H  d 0054 * THE CALLING SEQUENCES FOR THE ROUTINES ARE: A0500051dd 0055 * CALL CCSA2E ( BUFFER, NUMCHR, FLAG ) - ASCII TO EBCDIC A0500052dd 0056 * CALL CCSE2A ( BUFFER, NUMCHR, FLAG ) - EBCDIC TO ASCII A0500053dd 0057 * WHERE A0500054dd 0058 * BUFFER - IS THE BUFFER TO BE CONVERTED A0500055dd 0059 * NUMCHR - IS THE NUMBER OF CHARACTERS TO CONVERT A0500056dd 0060 * FLAG - IS THE FLAG OPTION FOR CONVERSION OF CHARACTERS A0500057dd 0061 * OUTSIDE THE 64 CHARACTER CHARACTER SET. THE FLAG A0500058dd 0062 * HAS TWO OPTIONS: A0500059dd 0063 * = 0 - LEAVE CHARACTERS UNCHANGED A0500060dd 0064 * NOT = 0 - CONVERT THESE CHARACTERS TO BLANKS. A0500061d   d 0066 * ENTRY POINTS A0500063dd 0067 ENT CCSE2A EBCDIC TO ASCII. A0500064dd 0068 ENT CCSA2E ASCII TO EBCDIC. A0500065d d 0070 * COMMUNICATIONS REGION USED. A0500067dd 0071 0022 EQU ZERO($22) A0500068dH1 CCSEAC PAGE 3 DATE: 08/29/84H  d 0073 P0000 0000 CCSE2A NUM 0 EBCDIC TO ASCII ENTRY POINT. A0500070dd 0074 P0001 C8FE LDA* CCSE2A RETRIEVE ADDRESS OF PARAMETER LIST. A0500071dd 0075 P0002 5822 RTJ* PARGET SAVE REGISTERS AND OBTAIN PARAMETER ADDRESSES.A0500072dd 0076 P0003 C000 LDA =XCONE2A SET CONVERSION TABLE FOR EBCDIC TO ASCII. A0500073d P0004 003B P d 0077 P0005 6831 STA* CONTAB A0500074dd 0078 P0006 0A20 ENA $20 SET VALUE OF BLANK FOR ASCII. A0500075dd 0079 P0007 6830 STA* BLANK A0500076dd 0080 P0008 1809 JMP* CONVRT CONVERT THE BUFFER. A0500077d  d 0082 P0009 0000 CCSA2E NUM 0 ASCII TO EBCDIC ENTRY POINT. A0500079dd 0083 P000A C8FE LDA* CCSA2E RETRIEVE ADDRESS OF PARAMETER LIST. A0500080dd 0084 P000B 5819 RTJ* PARGET SAVE REGISTERS AND OBTAIN PARAMETER ADDRESSES.A0500081dd 0085 P000C C000 LDA =XCONA2E SET CONVERSION TABLE FOR ASCII TO EBCDIC. A0500082d P000D 00BB P d 0086 P000E 6828 STA* CONTAB A0500083dd 0087 P000F 0A40 ENA $40 SET VALUE OF BLANK FOR EBCDIC. A0500084dd 0088 P0010 6827 STA* BLANK A0500085d  d 0090 P0011 EC23 CONVRT LDQ* (NUMCHR) BEGIN CONVERSION. ESTABLISH CHARACTER A0500087dd 0091 P0012 0DFE INQ -1 POINTER FOR BUFFER BEING CONVERTED. A0500088dd 0092 P0013 CC22 LDA* (FLAG) RETRIEVE FLAG - DETERMINES HANDLING OF CHAR- A0500089dd 0093 * ACTERS OUTSIDE OF 64 CHARACTER CHARACTER SET. A0500090dd 0094 P0014 60FF STA- I A0500091dd 0095 CON100 LCA* (BUFFER),Q BEGIN CONVERSION LOOP. GET NEXT CHARACTER TO A0500092d 0095 P0015 04C5  0095 P0016 C21D d 0096 * CONVERT. A0500093dd 0097 LCA* (CONTAB),A GET CONVERSION CHARACTER. A0500094d 0097 P0017 04C6  0097 P0018 C21E d 0098 P0019 0113 SAN CON200 SKIP IF CONVERSION CHARACTER FOUND. A0500095dd 0099 P001A C0FF LDA- I CHECK FLAG ON HANDLING OF CHARACTERS NOT A0500096dd 0100 * FOUND. A0500097dd 0101 P001B 0103 SAZ CON300 SKIP IF TO REMAIN UNCHANGED. A0500098dd 0102 P001C C81B LDA* BLANK ELSE, CONVERT CHARACTER TO A BLANK. A0500099dd 0103 CON200 SCA* (BUFFER),Q SAVE CONVERTED CHARACTER. A0500100d 0103 P001D 04C5  0103 P001E C315 d 0104 CON300 DQP *-CON100 END OF CONVERSION LOOP. REPEAT LOOP IF MORE A0500101d 0104 P001F 06AA d 0105 * CHARACTERS TO CONVERT. A0500102d d 0107 P0020 C81A LDA* ISAVE END OF CONVERSION, RESTORE Q AND I REGISTERS A0500104dd 0108 P0021 60FF STA- I AND RETURN. A0500105dd 0109 P0022 E817 LDQ* QSAVE A0500106dd 0110 P0023 1C15 JMP* (RETURN) A0500107dH1 CCSEAC PAGE 4 DATE: 08/29/84H  d 0112 * REGISTER SAVE AND PARAMETER PICK UP ROUTINE. A0500109dd 0113 P0024 0000 PARGET NUM 0 ENTRY. A0500110dd 0114 P0025 4814 STQ* QSAVE SAVE Q AND I REGISTERS. A0500111dd 0115 P0026 E0FF LDQ- I A0500112dd 0116 P0027 4813 STQ* ISAVE A0500113dd 0117 P0028 0822 TRA Q A CONTAINS ADDRESS OF PARAMETER LIST. A0500114dd 0118 P0029 0D03 INQ 3 CALCULATE AND SAVE RETURN ADDRESS. A0500115dd 0119 P002A 480E STQ* RETURN A0500116dd 0120 P002B 0DFE INQ -1 MOVE TO END OF PARAMETER LIST. A0500117dd 0121 P002C 0A02 ENA 2 INTIALIZE POINTER INTO LOCAL PARAMETER ADDRESSA0500118dd 0122 P002D 60FF STA- I STORAGE. A0500119dd 0123 P002E C622 PAR100 LDA- (ZERO),Q BEGIN PARAMETER ADDRESS PICK UP LOOP. GET A0500120dd 0124 * ADDRESS OF NEXT PARAMETER. A0500121dd 0125 P002F 6904 STA* BUFFER,I SAVE IN PARAMETER ADDRESS STORAGE. A0500122dd 0126 P0030 0DFE INQ -1 DECREMENT POINTER TO POINT TO NEXT PARAMETER. A0500123dd 0127 DIP *-PAR100 END OF LOOP. REPEAT IF MORE PARAMETERS. A0500124d 0127 P0031 06E3  d 0129 P0032 1CF1 JMP* (PARGET) END OF ROUTINE. RETURN. A0500126d   d 0131 * PARAMETER ADDRESS AND VARIABLE STORAGE. A0500128dd 0132 P0033 0000 BUFFER NUM 0 ABSOLUTE ADDRESS OF BUFFER PARAMETER. A0500129dd 0133 P0034 0000 NUMCHR NUM 0 ABSOLUTE ADDRESS OF NUMCHR PARAMETER. A0500130dd 0134 P0035 0000 FLAG NUM 0 ABSOLUTE ADDRESS OF FLAG PARAMETER. A0500131dd 0135 P0036 0000 CONTAB NUM 0 ABSOLUTE ADDRESS OF CONVERSION TABLE IN USE. A0500132dd 0136 P0037 0000 BLANK NUM 0 CHARACTER FOR BLANK IN OUTPUT MODE. A0500133dd 0137 P0038 0000 RETURN NUM 0 COMMON RETURN ADRESS. A0500134dd 0138 P0039 0000 QSAVE NUM 0 Q REGISTER SAVE. A0500135dd 0139 P003A 0000 ISAVE NUM 0 I REGISTER SAVE. A0500136dH1 CCSEAC PAGE 5 DATE: 08/29/84H  d 0141 * EBCDIC TO ASCII TRANSLATION TABLE. A0500138dd 0142 P003B 0000 CONE2A NUM $0000 $ 0 - $ 1 EBCDIC A0500139dd 0143 P003C 0000 NUM $0000 2 - 3 A0500140dd 0144 P003D 0000 NUM $0000 4 - 5 A0500141dd 0145 P003E 0000 NUM $0000 6 - 7 A0500142dd 0146 P003F 0000 NUM $0000 8 - 9 A0500143dd 0147 P0040 0000 NUM $0000 A - B A0500144dd 0148 P0041 0000 NUM $0000 C - D A0500145dd 0149 P0042 0000 NUM $0000 E - F A0500146dd 0150 P0043 0000 NUM $0000 10 - 11 A0500147dd 0151 P0044 0000 NUM $0000 12 - 13 A0500148dd 0152 P0045 0000 NUM $0000 14 - 15 A0500149dd 0153 P0046 0000 NUM $0000 16 - 17 A0500150dd 0154 P0047 0000 NUM $0000 18 - 19 A0500151dd 0155 P0048 0000 NUM $0000 1A - 1B A0500152dd 0156 P0049 0000 NUM $0000 1C - 1D A0500153dd 0157 P004A 0000 NUM $0000 1E - 1F A0500154dd 0158 P004B 0000 NUM $0000 20 - 21 A0500155dd 0159 P004C 0000 NUM $0000 22 - 23 A0500156dd 0160 P004D 0000 NUM $0000 24 - 25 A0500157dd 0161 P004E 005D NUM $005D 26 - 27 ] A0500158dd 0162 P004F 0000 NUM $0000 28 - 29 A0500159dd 0163 P0050 0000 NUM $0000 2A - 2B A0500160dd 0164 P0051 0000 NUM $0000 2C - 2D A0500161dd 0165 P0052 0000 NUM $0000 2E - 2F A0500162dd 0166 P0053 0000 NUM $0000 30 - 31 A0500163dd 0167 P0054 0000 NUM $0000 32 - 33 A0500164dd 0168 P0055 0000 NUM $0000 34 - 35 A0500165dd 0169 P0056 0000 NUM $0000 36 - 37 A0500166dd 0170 P0057 0000 NUM $0000 38 - 39 A0500167dd 0171 P0058 0000 NUM $0000 3A - 3B A0500168dd 0172 P0059 0000 NUM $0000 3C - 3D A0500169dd 0173 P005A 0000 NUM $0000 3E - 3F A0500170dd 0174 P005B 2000 NUM $2000 40 - 41 (BLANK) A0500171dd 0175 P005C 0000 NUM $0000 42 - 43 A0500172dd 0176 P005D 0000 NUM $0000 44 - 45 A0500173dd 0177 P005E 0000 NUM $0000 46 - 47 A0500174dd 0178 P005F 0000 NUM $0000 48 - 49 A0500175dd 0179 P0060 5B2E NUM $5B2E 4A - 4B [ . A0500176dd 0180 P0061 3C28 NUM $3C28 4C - 4D < ( A0500177dd 0181 P0062 2B5E NUM $2B5E 4E - 4F + ^ A0500178dd 0182 P0063 2600 NUM $2600 50 - 51 & A0500179dd 0183 P0064 0000 NUM $0000 52 - 53 A0500180dd 0184 P0065 0000 NUM $0000 54 - 55 A0500181dd 0185 P0066 0000 NUM $0000 56 - 57 A0500182dd 0186 P0067 0000 NUM $0000 58 - 59 A0500183dd 0187 P0068 2124 NUM $2124 5A - 5B ! $ A0500184dd 0188 P0069 2A29 NUM $2A29 5C - 5D * ) A0500185dd 0189 P006A 3B5C NUM $3B5C 5E - 5F ; \ A0500186dd 0190 P006B 2D2F NUM $2D2F 60 - 61 - / A0500187dd 0191 P006C 0000 NUM $0000 62 - 63 A0500188dd 0192 P006D 0000 NUM $0000 64 - 65 A0500189dd 0193 P006E 0000 NUM $0000 66 - 67 A0500190dH1 CCSEAC PAGE 6 DATE: 08/29/84H  d 0194 P006F 0000 NUM $0000 68 - 69 A0500191dd 0195 P0070 002C NUM $002C 6A - 6B , A0500192dd 0196 P0071 255F NUM $255F 6C - 6D % _ A0500193dd 0197 P0072 3E3F NUM $3E3F 6E - 6F > ? A0500194dd 0198 P0073 0000 NUM $0000 70 - 71 A0500195dd 0199 P0074 0000 NUM $0000 72 - 73 A0500196dd 0200 P0075 0000 NUM $0000 74 - 75 A0500197dd 0201 P0076 0000 NUM $0000 76 - 77 A0500198dd 0202 P0077 0000 NUM $0000 78 - 79 A0500199dd 0203 P0078 3A23 NUM $3A23 7A - 7B : # A0500200dd 0204 P0079 4027 NUM $4027 7C - 7D @ ' A0500201dd 0205 P007A 3D22 NUM $3D22 7E - 7F = " A0500202dd 0206 P007B 0000 NUM $0000 80 - 81 A0500203dd 0207 P007C 0000 NUM $0000 82 - 83 A0500204dd 0208 P007D 0000 NUM $0000 84 - 85 A0500205dd 0209 P007E 0000 NUM $0000 86 - 87 A0500206dd 0210 P007F 0000 NUM $0000 88 - 89 A0500207dd 0211 P0080 0000 NUM $0000 8A - 8B A0500208dd 0212 P0081 0000 NUM $0000 8C - 8D A0500209dd 0213 P0082 0000 NUM $0000 8E - 8F A0500210dd 0214 P0083 0000 NUM $0000 90 - 91 A0500211dd 0215 P0084 0000 NUM $0000 92 - 93 A0500212dd 0216 P0085 0000 NUM $0000 94 - 95 A0500213dd 0217 P0086 0000 NUM $0000 96 - 97 A0500214dd 0218 P0087 0000 NUM $0000 98 - 99 A0500215dd 0219 P0088 0000 NUM $0000 9A - 9B A0500216dd 0220 P0089 0000 NUM $0000 9C - 9D A0500217dd 0221 P008A 0000 NUM $0000 9E - 9F A0500218dd 0222 P008B 0000 NUM $0000 A0 - A1 A0500219dd 0223 P008C 0000 NUM $0000 A2 - A3 A0500220dd 0224 P008D 0000 NUM $0000 A4 - A5 A0500221dd 0225 P008E 0000 NUM $0000 A6 - A7 A0500222dd 0226 P008F 0000 NUM $0000 A8 - A9 A0500223dd 0227 P0090 0000 NUM $0000 AA - AB A0500224dd 0228 P0091 0000 NUM $0000 AC - AD A0500225dd 0229 P0092 0000 NUM $0000 AE - AF A0500226dd 0230 P0093 0000 NUM $0000 B0 - B1 A0500227dd 0231 P0094 0000 NUM $0000 B2 - B3 A0500228dd 0232 P0095 0000 NUM $0000 B4 - B5 A0500229dd 0233 P0096 0000 NUM $0000 B6 - B7 A0500230dd 0234 P0097 0000 NUM $0000 B8 - B9 A0500231dd 0235 P0098 0000 NUM $0000 BA - BB A0500232dd 0236 P0099 0000 NUM $0000 BC - BD A0500233dd 0237 P009A 0000 NUM $0000 BE - BF A0500234dd 0238 P009B 3041 NUM $3041 C0 - C1 0 A ???*A010********dd 0239 P009C 4243 NUM $4243 C2 - C3 B C A0500236dd 0240 P009D 4445 NUM $4445 C4 - C5 D E A0500237dd 0241 P009E 4647 NUM $4647 C6 - C7 F G A0500238dd 0242 P009F 4849 NUM $4849 C8 - C9 H I A0500239dd 0243 P00A0 0000 NUM $0000 CA - CB A0500240dd 0244 P00A1 0000 NUM $0000 CC - CD A0500241dd 0245 P00A2 0000 NUM $0000 CE - CF A0500242dd 0246 P00A3 7D4A NUM $7D4A D0 - D1 (NULL) J A0500243dH1 CCSEAC PAGE 7 DATE: 08/29/84H  d 0247 P00A4 4B4C NUM $4B4C D2 - D3 K L A0500244dd 0248 P00A5 4D4E NUM $4D4E D4 - D5 M N A0500245dd 0249 P00A6 4F50 NUM $4F50 D6 - D7 O P A0500246dd 0250 P00A7 5152 NUM $5152 D8 - D9 Q R A0500247dd 0251 P00A8 0000 NUM $0000 DA - DB A0500248dd 0252 P00A9 0000 NUM $0000 DC - DD A0500249dd 0253 P00AA 0000 NUM $0000 DE - DF A0500250dd 0254 P00AB 0000 NUM $0000 E0 - E1 A0500251dd 0255 P00AC 5354 NUM $5354 E2 - E3 S T A0500252dd 0256 P00AD 5556 NUM $5556 E4 - E5 U V A0500253dd 0257 P00AE 5758 NUM $5758 E6 - E7 W X A0500254dd 0258 P00AF 595A NUM $595A E8 - E9 Y Z A0500255dd 0259 P00B0 0000 NUM $0000 EA - EB A0500256dd 0260 P00B1 0000 NUM $0000 EC - ED A0500257dd 0261 P00B2 0000 NUM $0000 EE - EF A0500258dd 0262 P00B3 3031 NUM $3031 F0 - F1 0 1 A0500259dd 0263 P00B4 3233 NUM $3233 F2 - F3 2 3 A0500260dd 0264 P00B5 3435 NUM $3435 F4 - F5 4 5 A0500261dd 0265 P00B6 3637 NUM $3637 F6 - F7 6 7 A0500262dd 0266 P00B7 3839 NUM $3839 F8 - F9 8 9 A0500263dd 0267 P00B8 0000 NUM $0000 FA - FB A0500264dd 0268 P00B9 0000 NUM $0000 FC - FD A0500265dd 0269 P00BA 0000 NUM $0000 FE - FF A0500266dd 0270 * END OF TABLE. A0500267dH1 CCSEAC PAGE 8 DATE: 08/29/84H  d 0272 * ASCII TO EBDIC CONVERSION TABLE. A0500269dd 0273 P00BB 0000 CONA2E NUM $0000 $ 0 - $ 1 ASCII A0500270dd 0274 P00BC 0000 NUM $0000 2 - 3 A0500271dd 0275 P00BD 0000 NUM $0000 4 - 5 A0500272dd 0276 P00BE 0000 NUM $0000 6 - 7 A0500273dd 0277 P00BF 0000 NUM $0000 8 - 9 A0500274dd 0278 P00C0 0000 NUM $0000 A - B A0500275dd 0279 P00C1 0000 NUM $0000 C - D A0500276dd 0280 P00C2 0000 NUM $0000 E - F A0500277dd 0281 P00C3 0000 NUM $0000 10 - 11 A0500278dd 0282 P00C4 0000 NUM $0000 12 - 13 A0500279dd 0283 P00C5 0000 NUM $0000 14 - 15 A0500280dd 0284 P00C6 0000 NUM $0000 16 - 17 A0500281dd 0285 P00C7 0000 NUM $0000 18 - 19 A0500282dd 0286 P00C8 0000 NUM $0000 1A - 1B A0500283dd 0287 P00C9 0000 NUM $0000 1C - 1D A0500284dd 0288 P00CA 0000 NUM $0000 1E - 1F A0500285dd 0289 P00CB 405A NUM $405A 20 - 21 (BLANK) ! A0500286dd 0290 P00CC 7F7B NUM $7F7B 22 - 23 " # A0500287dd 0291 P00CD 5B6C NUM $5B6C 24 - 25 $ % A0500288dd 0292 P00CE 507D NUM $507D 26 - 27 & ' A0500289dd 0293 P00CF 4D5D NUM $4D5D 28 - 29 ( ) A0500290dd 0294 P00D0 5C4E NUM $5C4E 2A - 2B * + A0500291dd 0295 P00D1 6B60 NUM $6B60 2C - 2D , - A0500292dd 0296 P00D2 4B61 NUM $4B61 2E - 2F . / A0500293dd 0297 P00D3 F0F1 NUM $F0F1 30 - 31 0 1 A0500294dd 0298 P00D4 F2F3 NUM $F2F3 32 - 33 2 3 A0500295dd 0299 P00D5 F4F5 NUM $F4F5 34 - 35 4 5 A0500296dd 0300 P00D6 F6F7 NUM $F6F7 36 - 37 6 7 A0500297dd 0301 P00D7 F8F9 NUM $F8F9 38 - 39 8 9 A0500298dd 0302 P00D8 7A5E NUM $7A5E 3A - 3B : ; A0500299dd 0303 P00D9 4C7E NUM $4C7E 3C - 3D < = A0500300dd 0304 P00DA 6E6F NUM $6E6F 3E - 3F > ? A0500301dd 0305 P00DB 7CC1 NUM $7CC1 40 - 41 @ A A0500302dd 0306 P00DC C2C3 NUM $C2C3 42 - 43 B C A0500303dd 0307 P00DD C4C5 NUM $C4C5 44 - 45 D E A0500304dd 0308 P00DE C6C7 NUM $C6C7 46 - 47 F G A0500305dd 0309 P00DF C8C9 NUM $C8C9 48 - 49 H I A0500306dd 0310 P00E0 D1D2 NUM $D1D2 4A - 4B J K A0500307dd 0311 P00E1 D3D4 NUM $D3D4 4C - 4D L M A0500308dd 0312 P00E2 D5D6 NUM $D5D6 4E - 4F N O A0500309dd 0313 P00E3 D7D8 NUM $D7D8 50 - 51 P Q A0500310dd 0314 P00E4 D9E2 NUM $D9E2 52 - 53 R S A0500311dd 0315 P00E5 E3E4 NUM $E3E4 54 - 55 T U A0500312dd 0316 P00E6 E5E6 NUM $E5E6 56 - 57 V W A0500313dd 0317 P00E7 E7E8 NUM $E7E8 58 - 59 X Y A0500314dd 0318 P00E8 E94A NUM $E94A 5A - 5B Z [ A0500315dd 0319 P00E9 5F27 NUM $5F27 5C - 5D \ ] A0500316dd 0320 P00EA 4F6D NUM $4F6D 5E - 5F ^ _ A0500317dd 0321 P00EB 0000 NUM $0000 60 - 61 A0500318dd 0322 P00EC 0000 NUM $0000 62 - 63 A0500319dd 0323 P00ED 0000 NUM $0000 64 - 65 A0500320dd 0324 P00EE 0000 NUM $0000 66 - 67 A0500321dH1 CCSEAC PAGE 9 DATE: 08/29/84H  d 0325 P00EF 0000 NUM $0000 68 - 69 A0500322dd 0326 P00F0 0000 NUM $0000 6A - 6B A0500323dd 0327 P00F1 0000 NUM $0000 6C - 6D A0500324dd 0328 P00F2 0000 NUM $0000 6E - 6F A0500325dd 0329 P00F3 0000 NUM $0000 70 - 71 A0500326dd 0330 P00F4 0000 NUM $0000 72 - 73 A0500327dd 0331 P00F5 0000 NUM $0000 74 - 75 A0500328dd 0332 P00F6 0000 NUM $0000 76 - 77 A0500329dd 0333 P00F7 0000 NUM $0000 78 - 79 A0500330dd 0334 P00F8 00C0 NUM $00C0 7A - 7B POSITIVE 0 ???*A010********dd 0335 P00F9 00D0 NUM $00D0 7C - 7D (NULL) A0500332dd 0336 P00FA 0000 NUM $0000 7E - 7F A0500333dd 0337 P00FB 0000 NUM $0000 80 - 81 A0500334dd 0338 P00FC 0000 NUM $0000 82 - 83 A0500335dd 0339 P00FD 0000 NUM $0000 84 - 85 A0500336dd 0340 P00FE 0000 NUM $0000 86 - 87 A0500337dd 0341 P00FF 0000 NUM $0000 88 - 89 A0500338dd 0342 P0100 0000 NUM $0000 8A - 8B A0500339dd 0343 P0101 0000 NUM $0000 8C - 8D A0500340dd 0344 P0102 0000 NUM $0000 8E - 8F A0500341dd 0345 P0103 0000 NUM $0000 90 - 91 A0500342dd 0346 P0104 0000 NUM $0000 92 - 93 A0500343dd 0347 P0105 0000 NUM $0000 94 - 95 A0500344dd 0348 P0106 0000 NUM $0000 96 - 97 A0500345dd 0349 P0107 0000 NUM $0000 98 - 99 A0500346dd 0350 P0108 0000 NUM $0000 9A - 9B A0500347dd 0351 P0109 0000 NUM $0000 9C - 9D A0500348dd 0352 P010A 0000 NUM $0000 9E - 9F A0500349dd 0353 P010B 0000 NUM $0000 A0 - A1 A0500350dd 0354 P010C 0000 NUM $0000 A2 - A3 A0500351dd 0355 P010D 0000 NUM $0000 A4 - A5 A0500352dd 0356 P010E 0000 NUM $0000 A6 - A7 A0500353dd 0357 P010F 0000 NUM $0000 A8 - A9 A0500354dd 0358 P0110 0000 NUM $0000 AA - AB A0500355dd 0359 P0111 0000 NUM $0000 AC - AD A0500356dd 0360 P0112 0000 NUM $0000 AE - AF A0500357dd 0361 P0113 0000 NUM $0000 B0 - B1 A0500358dd 0362 P0114 0000 NUM $0000 B2 - B3 A0500359dd 0363 P0115 0000 NUM $0000 B4 - B5 A0500360dd 0364 P0116 0000 NUM $0000 B6 - B7 A0500361dd 0365 P0117 0000 NUM $0000 B8 - B9 A0500362dd 0366 P0118 0000 NUM $0000 BA - BB A0500363dd 0367 P0119 0000 NUM $0000 BC - BD A0500364dd 0368 P011A 0000 NUM $0000 BE - BF A0500365dd 0369 P011B 0000 NUM $0000 C0 - C1 A0500366dd 0370 P011C 0000 NUM $0000 C2 - C3 A0500367dd 0371 P011D 0000 NUM $0000 C4 - C5 A0500368dd 0372 P011E 0000 NUM $0000 C6 - C7 A0500369dd 0373 P011F 0000 NUM $0000 C8 - C9 A0500370dd 0374 P0120 0000 NUM $0000 CA - CB A0500371dd 0375 P0121 0000 NUM $0000 CC - CD A0500372dd 0376 P0122 0000 NUM $0000 CE - CF A0500373dd 0377 P0123 0000 NUM $0000 D0 - D1 A0500374dH1 CCSEAC PAGE 10 DATE: 08/29/84H  d 0378 P0124 0000 NUM $0000 D2 - D3 A0500375dd 0379 P0125 0000 NUM $0000 D4 - D5 A0500376dd 0380 P0126 0000 NUM $0000 D6 - D7 A0500377dd 0381 P0127 0000 NUM $0000 D8 - D9 A0500378dd 0382 P0128 0000 NUM $0000 DA - DB A0500379dd 0383 P0129 0000 NUM $0000 DC - DD A0500380dd 0384 P012A 0000 NUM $0000 DE - DF A0500381dd 0385 P012B 0000 NUM $0000 E0 - E1 A0500382dd 0386 P012C 0000 NUM $0000 E2 - E3 A0500383dd 0387 P012D 0000 NUM $0000 E4 - E5 A0500384dd 0388 P012E 0000 NUM $0000 E6 - E7 A0500385dd 0389 P012F 0000 NUM $0000 E8 - E9 A0500386dd 0390 P0130 0000 NUM $0000 EA - EB A0500387dd 0391 P0131 0000 NUM $0000 EC - ED A0500388dd 0392 P0132 0000 NUM $0000 EE - EF A0500389dd 0393 P0133 0000 NUM $0000 F0 - F1 A0500390dd 0394 P0134 0000 NUM $0000 F2 - F3 A0500391dd 0395 P0135 0000 NUM $0000 F4 - F5 A0500392dd 0396 P0136 0000 NUM $0000 F6 - F7 A0500393dd 0397 P0137 0000 NUM $0000 F8 - F9 A0500394dd 0398 P0138 0000 NUM $0000 FA - FB A0500395dd 0399 P0139 0000 NUM $0000 FC - FD A0500396dd 0400 P013A 0000 NUM $0000 FE - FF A0500397dd 0401 * END OF TABLE A0500398d   d 0403 END A0500400d  D PGM= 013B ( 315) COM = 0000 ( 0) DAT = 0000 ( 0) D H1 CCSEAC PAGE 11 DATE: 08/29/84H     E Q U I V A L E N C E S -----------------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0000 I 00FF (000255) 0094, 0099, 0108, 0115, 0122 HH 0071 ZERO 0022 (000034) 0123 HH1 CCSEAC PAGE 12 DATE: 08/29/84H     S Y M B O L S -------------  B DEF.LINE NAME ADDRESS REFERENCED AT LINE NUMBER B H 0067 CCSE2A 0000 0067, 0074 HH 0068 CCSA2E 0009 0068, 0083 HH 0090 CONVRT 0011 0080 HH 0095 CON100 0015 0104, 0104, 0104, 0104 HH 0103 CON200 001D 0098 HH 0104 CON300 001F 0101 HH 0113 PARGET 0024 0075, 0084, 0129 HH 0123 PAR100 002E 0127, 0127, 0127, 0127 HH 0132 BUFFER 0033 0095, 0095, 0095, 0103, 0103, 0103HH 0125 HH 0133 NUMCHR 0034 0090 HH 0134 FLAG 0035 0092 HH 0135 CONTAB 0036 0077, 0086, 0097, 0097, 0097 HH 0136 BLANK 0037 0079, 0088, 0102 HH 0137 RETURN 0038 0110, 0119 HH 0138 QSAVE 0039 0109, 0114 HH 0139 ISAVE 003A 0107, 0116 HH 0142 CONE2A 003B 0076 HH 0273 CONA2E 00BB 0085 HH1 CCSEAC PAGE 13 DATE: 08/29/84H  > *** A L P H A B E T I C A L S O R T O F S Y M B O L S *** >  H BLANK 0136 BUFFER 0132 CCSA2E 0068 CCSE2A 0067 CON100 0095 HH CON200 0103 CON300 0104 CONA2E 0273 CONE2A 0142 CONTAB 0135 HH CONVRT 0090 FLAG 0134 I 0000 ISAVE 0139 NUMCHR 0133 HH PAR100 0123 PARGET 0113 QSAVE 0138 RETURN 0137 ZERO 0071 HH HP1 PH1 CCSGET PAGE 1 DATE: 08/29/84H  d 0001 NAM CCSGET A06 A CCS CCS 3.0 SL-149A0600001dd 0002 * A0600002dd 0003 * A0600003dd 0004 * CYBERCREDIT SYSTEM VERSION 3 A0600004dd 0005 * DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA A0600005dd 0006 * COPYRIGHT CONTROL DATA CORPORATION, 1979 A0600006dd 0007 * A0600007dd 0008 * GET CHARACTER FROM ARRAY. A0600008dd 0009 * A0600009dd 0010 * ROUTINE TO RETRIEVE A SPECIFIED CHARACTER FROM A BUFFER ACCORDINGA0600010dd 0011 * TO CHARACTER POSITION. A0600011dd 0012 * CALLING SEQUENCE: A0600012dd 0013 * CALL CCSGET(BUF,CHRPOS,CHAR) A0600013dd 0014 * WHERE: A0600014dd 0015 * BUF = THE ARRAY TO RETRIEVE THE CHARACTER FROM. A0600015dd 0016 * CHRPOS = THE CHARACTER POSITION OF THE CHARACTER TO RETRIEVEA0600016dd 0017 * CHAR = VARIABLE TO RECEIVE THE RETRIEVED CHARACTER. A0600017dd 0018 * A0600018d  d 0020 ENT CCSGET A0600020d d 0022 * COMMUNICATIONS REGION USED. A0600022dd 0023 0022 EQU ZERO($22) A0600023d  d 0025 P0000 0000 CCSGET 0 0 A0600025d d 0027 * SAVE REGISTERS A0600027dd 0028 P0001 4813 STQ* SAVEQ A0600028dd 0029 P0002 C0FF LDA- I A0600029dd 0030 P0003 6812 STA* SAVEI A0600030d d 0032 P0004 E8FB LDQ* CCSGET PICK UP ADDRESS OF CALLER. A0600032dd 0033 P0005 0D03 INQ 3 MOVE TO NEXT EXECUTABLE INSTRUCTION. A0600033dd 0034 P0006 48F9 STQ* CCSGET SAVE RETURN VALUE. A0600034dd 0035 P0007 580F RTJ* PARGET PICK UP PARAMETER ADDRESSES. A0600035dd 0036 P0008 EC0A LDQ* (CHRPOS) PICK UP POSITION OF CHARACTER TO GET. A0600036dd 0037 P0009 0DFE INQ -1 BIAS TO GET BYTE INDEX. A0600037dd 0038 LCA* (BUF),Q PICK UP THE DESIRED CHARACTER. A0600038d 0038 P000A 04C5  0038 P000B C206 d 0039 P000C 6C07 STA* (CHAR) SAVE CHARACTER FOR RETURN. A0600039d d 0041 * RESTORE REGISTERS. A0600041dd 0042 P000D C808 LDA* SAVEI A0600042dd 0043 P000E 60FF STA- I A0600043dd 0044 P000F E805 LDQ* SAVEQ A0600044d d 0046 P0010 1CEF JMP* (CCSGET) RETURN. A0600046d  d 0048 * PARAMETER ADDRESS STORAGE. A0600048dH1 CCSGET PAGE 2 DATE: 08/29/84H  d 0049 P0011 0000 BUF NUM 0 ABSOLUTE ADDRESS OF ARRAY TO RETRIEVE FROM. A0600049dd 0050 P0012 0000 CHRPOS NUM 0 ABSOLUTE ADDRESS OF CHARACTER POSITION TO GET.A0600050dd 0051 P0013 0000 CHAR NUM 0 ABSOLUTE ADDRESS OF RETURNED CHARACTER. A0600051dd 0052 P0014 0000 SAVEQ NUM 0 A0600052dd 0053 P0015 0000 SAVEI NUM 0 A0600053d  d 0055 P0016 0000 PARGET 0 0 ROUTINE TO PICK UP ADDRESSES OF PARAMETERS. A0600055dd 0056 P0017 E8E8 LDQ* CCSGET PICK UP ADDRESS OF CALLER+3. A0600056dd 0057 P0018 0DFE INQ -1 MOVE TO END OF PARAMETER LIST. A0600057dd 0058 P0019 0A02 ENA 2 SET UP INDEX INTO PARAMETER STORAGE. A0600058dd 0059 P001A 60FF STA- I A0600059dd 0060 P001B C622 PAR100 LDA- (ZERO),Q PICK UP ABSOLUTE ADDRESS OF NEXT PARAMETER. A0600060dd 0061 P001C 69F4 STA* BUF,I SAVE IN PARAMETER STORAGE. A0600061dd 0062 P001D 0DFE INQ -1 DECREMENT INDEX INTO PARAMETER LIST. A0600062dd 0063 DIP *-PAR100 SKIP IF ALL PARAMETER ADDRESSES RETRIEVED. A0600063d 0063 P001E 06E3 d 0064 P001F 1CF6 JMP* (PARGET) RETURN. A0600064d  d 0066 END A0600066d  D PGM= 0020 ( 32) COM = 0000 ( 0) DAT = 0000 ( 0) D H1 CCSGET PAGE 3 DATE: 08/29/84H     E Q U I V A L E N C E S -----------------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0000 I 00FF (000255) 0029, 0043, 0059 HH 0023 ZERO 0022 (000034) 0060 HH1 CCSGET PAGE 4 DATE: 08/29/84H     S Y M B O L S -------------  B DEF.LINE NAME ADDRESS REFERENCED AT LINE NUMBER B H 0020 CCSGET 0000 0020, 0032, 0034, 0046, 0056 HH 0049 BUF 0011 0038, 0038, 0038, 0061 HH 0050 CHRPOS 0012 0036 HH 0051 CHAR 0013 0039 HH 0052 SAVEQ 0014 0028, 0044 HH 0053 SAVEI 0015 0030, 0042 HH 0055 PARGET 0016 0035, 0064 HH 0060 PAR100 001B 0063, 0063, 0063, 0063 HH1 CCSGET PAGE 5 DATE: 08/29/84H  > *** A L P H A B E T I C A L S O R T O F S Y M B O L S *** >  H BUF 0049 CCSGET 0020 CHAR 0051 CHRPOS 0050 I 0000 HH PAR100 0060 PARGET 0055 SAVEI 0053 SAVEQ 0052 ZERO 0023 HH HP1 PH1 CCSHXA PAGE 1 DATE: 08/29/84H  d 0001 NAM CCSHXA A07 A CCS CCS 3.0 SL-149A0700001dd 0002 * A0700002dd 0003 * A0700003dd 0004 * CYBERCREDIT SYSTEM VERSION 3 A0700004dd 0005 * DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA A0700005dd 0006 * COPYRIGHT CONTROL DATA CORPORATION, 1979 A0700006dd 0007 * A0700007dd 0008 * CONVERT ONE WORD HEXADECIMAL TO TWO WORDS OF ASCII. A0700008dd 0009 * A0700009dd 0010 * ROUTINE TO CONVERT A HEXADECIMAL WORD INTO ITS ASCII REPRESENTA- A0700010dd 0011 * TION FOR OUTPUT. A0700011dd 0012 * CALLING SEQUENCE: A0700012dd 0013 * CALL CCSHXA(N,BUF) A0700013dd 0014 * WHERE: N = THE HEXADECIMAL WORD TO BE CONVERTED. A0700014dd 0015 * BUF = THE TWO WORD ARRAY TO RECEIVE THE ASCII CONVERSIONA0700015dd 0016 * A0700016d  d 0018 ENT CCSHXA A0700018d  d 0020 * COMMUNICATIONS REGION USED. A0700020dd 0021 0002 EQU LPMASK($2) A0700021dd 0022 0022 EQU ZERO($22) A0700022d  d 0024 P0000 0000 CCSHXA 0 0 ENTRY. A0700024d d 0026 * SAVE REGISTERS. A0700026dd 0027 P0001 4820 STQ* SAVEQ A0700027dd 0028 P0002 C0FF LDA- I A0700028dd 0029 P0003 681F STA* SAVEI A0700029d d 0031 P0004 E8FB LDQ* CCSHXA PICK UP ADDRESS OF CALLER. A0700031dd 0032 P0005 0D02 INQ 2 MOVE TO NEXT EXECUTABLE INSTRUCTION. A0700032dd 0033 P0006 48F9 STQ* CCSHXA SAVE RETURN ADDRESS. A0700033dd 0034 P0007 581C RTJ* PARGET PICK UP ADDRESSES OF PARAMETERS. A0700034dd 0035 P0008 0A03 ENA 3 A0700035dd 0036 XFA 1 INITIALIZE R1, INDEX INTO BUF STORAGE. A0700036d 0036 P0009 07C1 d 0037 P000A 0CFE ENQ -1 INITIALIZE Q, INDEX FOR WHICH NIBBLE TO CONVERA0700037dd 0038 HXA100 XFQ 2 SAVE IN R2. A0700038d 0038 P000B 07A2 d 0039 P000C CC13 LDA* (N) PICK UP NUMBER TO CONVERT. A0700039dd 0040 P000D 0173 HXA200 SQM HXA300 SKIP IF CORRECT NIBBLE IN POSITION. A0700040dd 0041 P000E 0F44 ARS 4 NOT THE CORRECT NIBBLE, SHIFT TO GET NEXT NIBBA0700041dd 0042 P000F 0DFE INQ -1 DECREMENT INDEX. A0700042dd 0043 P0010 18FC JMP* HXA200 SEE IF CORRECT NIBBLE IN POSITION. A0700043dd 0044 P0011 A006 HXA300 AND- LPMASK+4 MASK TO GET NUMBER TO CONVERT. A0700044dd 0045 P0012 09F5 INA -$A SEE IF NUMBER A LETTER IN HEXADECIMAL. A0700045dd 0046 P0013 0131 SAM HXA400 SKIP IF NUMBER < $A, NOT A LETTER. A0700046dd 0047 P0014 0907 INA 7 WAS A LETTER, ADD LETTER CONVERSION. A0700047dd 0048 P0015 093A HXA400 INA $3A INCREMENT TO GET ASCII CONVERSION. A0700048dH1 CCSHXA PAGE 2 DATE: 08/29/84H  d 0049 SCA* (BUF),1 STORE INTO BUFFER TO RECEIVE CONVERSION. A0700049d 0049 P0016 04C1  0049 P0017 C309 d 0050 XF2 Q RECALL NIBBLE INDEX. A0700050d 0050 P0018 0745 d 0051 P0019 0D01 INQ 1 INCREMENT TO EXTRACT NEXT NIBBLE. A0700051dd 0052 D1P *-HXA100 SKIP IF ALL NIBBLES HAVE BEEN CONVERTED. A0700052d 0052 P001A 062F  d 0054 * RESTORE REGISTERS. A0700054dd 0055 P001B C807 LDA* SAVEI A0700055dd 0056 P001C 60FF STA- I A0700056dd 0057 P001D E804 LDQ* SAVEQ A0700057d d 0059 P001E 1CE1 JMP* (CCSHXA) RETURN. A0700059dH1 CCSHXA PAGE 3 DATE: 08/29/84H  d 0061 * PARAMETER STORAGE. A0700061dd 0062 * A0700062dd 0063 P001F 0000 N NUM 0 ABSOLUTE ADDRESS OF NUMBER TO CONVERT. A0700063dd 0064 P0020 0000 BUF NUM 0 ABSOLUTE ADDRESS OF ARRAY TO RECEIVE CONVERSIOA0700064dd 0065 P0021 0000 SAVEQ NUM 0 A0700065dd 0066 P0022 0000 SAVEI NUM 0 A0700066d    d 0068 * ROUTINE TO PICK UP PARAMETER ADDRESSES. A0700068dd 0069 * A0700069dd 0070 P0023 0000 PARGET 0 0 A0700070dd 0071 P0024 E8DB LDQ* CCSHXA PICK UP LOCATION OF CALLER +2. A0700071dd 0072 P0025 0DFE INQ -1 MOVE TO END OF PARAMETER LIST. A0700072dd 0073 P0026 0A01 ENA 1 SET UP INDEX INTO PARAMETER STORAGE. A0700073dd 0074 P0027 60FF STA- I A0700074dd 0075 P0028 C622 PAR100 LDA- (ZERO),Q PICK UP ABSOLUTE ADDRESS OF PARAMETER. A0700075dd 0076 P0029 69F5 STA* N,I STORE INTO PARAMETER STORAGE AREA. A0700076dd 0077 P002A 0DFE INQ -1 DECREMENT INDEX INTO CALLER'S PARAMETER LIST. A0700077dd 0078 DIP *-PAR100 SKIP IF BOTH PARAMETERS HAVE RETRIEVED. A0700078d 0078 P002B 06E3 d 0079 P002C 1CF6 JMP* (PARGET) RETURN. A0700079d    d 0081 END A0700081d  D PGM= 002D ( 45) COM = 0000 ( 0) DAT = 0000 ( 0) D H1 CCSHXA PAGE 4 DATE: 08/29/84H     E Q U I V A L E N C E S -----------------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0000 I 00FF (000255) 0028, 0056, 0074 HH 0021 LPMASK 0002 (000002) 0044 HH 0022 ZERO 0022 (000034) 0075 HH1 CCSHXA PAGE 5 DATE: 08/29/84H     S Y M B O L S -------------  B DEF.LINE NAME ADDRESS REFERENCED AT LINE NUMBER B H 0018 CCSHXA 0000 0018, 0031, 0033, 0059, 0071 HH 0038 HXA100 000B 0052, 0052, 0052, 0052 HH 0040 HXA200 000D 0043 HH 0044 HXA300 0011 0040 HH 0048 HXA400 0015 0046 HH 0063 N 001F 0039, 0076 HH 0064 BUF 0020 0049, 0049, 0049 HH 0065 SAVEQ 0021 0027, 0057 HH 0066 SAVEI 0022 0029, 0055 HH 0070 PARGET 0023 0034, 0079 HH 0075 PAR100 0028 0078, 0078, 0078, 0078 HH1 CCSHXA PAGE 6 DATE: 08/29/84H  > *** A L P H A B E T I C A L S O R T O F S Y M B O L S *** >  H BUF 0064 CCSHXA 0018 HXA100 0038 HXA200 0040 HXA300 0044 HH HXA400 0048 I 0000 LPMASK 0021 N 0063 PAR100 0075 HH PARGET 0070 SAVEI 0066 SAVEQ 0065 ZERO 0022 HP1 PH1 CCSMVA PAGE 1 DATE: 08/29/84H  d 0001 NAM CCSMVA A08 A CCS CCS 3.0 SL-149A0800001dd 0002 * A0800002dd 0003 * A0800003dd 0004 * CYBERCREDIT SYSTEM VERSION 3 A0800004dd 0005 * DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA A0800005dd 0006 * COPYRIGHT CONTROL DATA CORPORATION, 1979 A0800006dd 0007 * A0800007dd 0008 * MOVE STRING REQUEST. A0800008dd 0009 * A0800009dd 0010 * ROUTINE TO MOVE ONE STRING OF BTYES FROM ONE LOCATION TO ANOTHER.A0800010dd 0011 * MOVE IS ACCOMPLISHED WITH THE 'MOV' REQUEST. THE MOVE REQUEST HASA0800011dd 0012 * THE FOLLOWING PARAMETER ASSIGNMENTS: A0800012dd 0013 * R1 = ADDRESS OF THE SOURCE STRING. A0800013dd 0014 * R2 = ADDRESS OF THE DESTINATION STRING. A0800014dd 0015 * A = B + LENGTH OF SOURCE STRING IN BYTES. A0800015dd 0016 * Q = B + LENGTH OF DESTINATION STRING IN BYTES. A0800016dd 0017 * WHERE B IS THE BYTE OFFSET: A0800017dd 0018 * B = 0 FOR WORD BOUNDARY. A0800018dd 0019 * = $8000 FOR BYTE BOUNDARY. A0800019dd 0020 * A0800020dd 0021 * CALLING SEQUENCE: A0800021dd 0022 * CALL CCSMVA(SOURCE,SPOS,SLEN,DESTIN,DPOS,DLEN) A0800022dd 0023 * WHERE THE PARAMETERS HAVE THE FOLLOWING DEFINITIONS: A0800023dd 0024 * SOURCE = NAME OF ARRAY SOURCE STRING IS FROM. A0800024dd 0025 * SPOS = BYTE NUMBER WHERE THE STRING BEGINS IN THE SOURCE A0800025dd 0026 * ARRAY. A0800026dd 0027 * SLEN = LENGTH OF SORUCE STRING IN BYTES. A0800027dd 0028 * DESTIN = NAME OF ARRAY DESTINATION STRING IS IN. A0800028dd 0029 * DPOS = BYTE NUMBER WHERE THE DESTINATION STRING BEGINS IN A0800029dd 0030 * DESTINATION ARRAY. A0800030dd 0031 * DLEN = LENGTH OF DESTINATION STRING IN BYTES. A0800031dd 0032 * A0800032dd 0033 * NOTES: THE FOLLOWING OPERATION OCCCURS IF THE STRING LENGTHS ARE A0800033dd 0034 * NOT EQUAL: A0800034dd 0035 * 1. LENGTH OF DESTINATION STRING = 0. A0800035dd 0036 * 'MOV' INSTRUCTION IS A NOP. A0800036dd 0037 * 2. LENGTH OF SOURCE STRING < LENGTH OF DESTINATION STRING. A0800037dd 0038 * REMAINDER OF DESTINATION STRING IS BLANK FILLED. A0800038dd 0039 * 3. LENGTH OF SOURCE STRING > LENGTH OF DESTINATION STRING. A0800039dd 0040 * ONLY THE SPECIFIED NUMBER OF BYTES OF DESTINATION STRIA0800040dd 0041 * FILLED WITH SOURCE STRING. A0800041dd 0042 * 4. LENGTH OF SOURCE STRING = 0. A0800042dd 0043 * BLANK FILLS (ASCII,$2020) DESTINATION STRING. A0800043dd 0044 * A0800044dd 0045 MOV MAC A0800045dd 0046 VFD N4/0,N4/$F,N3/0,N5/1 MOVE STRING REQUEST. A0800046dd 0047 EMC A0800047d  d 0049 ENT CCSMVA A0800049d d 0051 * COMMUNICATIONS REGION USED. A0800051dd 0052 0022 EQU ZERO($22) A0800052dH1 CCSMVA PAGE 2 DATE: 08/29/84H  d 0054 P0000 0000 CCSMVA 0 0 A0800054d d 0056 * SAVE REGISTERS. A0800056dd 0057 P0001 4822 STQ* SAVEQ A0800057dd 0058 P0002 C0FF LDA- I A0800058dd 0059 P0003 6821 STA* SAVEI A0800059d d 0061 P0004 E8FB LDQ* CCSMVA PICK UP ADDRESS OF CALLER. A0800061dd 0062 P0005 0D06 INQ 6 MOVE TO NEXT EXECUTABLE INSTRUCTION. A0800062dd 0063 P0006 48F9 STQ* CCSMVA SAVE RETURN ADDRESS. A0800063dd 0064 P0007 581E RTJ* PARGET PICK ADDRESS OF PARAMETERS. A0800064dd 0065 P0008 EC16 LDQ* (SPOS) PICK UP STARTING CHARACTER POSITION IN SOURCE.A0800065dd 0066 P0009 0DFE INQ -1 DECREMENT TO GET BYTE INDEX. A0800066dd 0067 P000A 0A00 ENA 0 ZERO A FOR LONG LEFT SHIFT. A0800067dd 0068 P000B 0FEF LLS 15 Q = BYTE OFFSET, A = WORD INDEX INTO SOURCE. A0800068dd 0069 P000C 8811 ADD* SOURCE ADD ADDRESS OF SOURCE TO GET SOURCE STRING ADDA0800069dd 0070 XFA 1 ADDRESS. SAVE IN R1. A0800070d 0070 P000D 07C1 d 0071 P000E 40FF STQ- I SAVE BYTE OFFSET OF SOURCE STRING. A0800071dd 0072 P000F EC12 LDQ* (DPOS) PICK UP START CHARACTER POSITION IN DESTINAT. A0800072dd 0073 P0010 0DFE INQ -1 DECREMENT TO GET BYTE INDEX. A0800073dd 0074 P0011 0A00 ENA 0 ZERO A FOR LONG LEFT SHIFT. A0800074dd 0075 P0012 0FEF LLS 15 Q = BYTE OFFSET, A = WORD INDEX INTO DESTINAT.A0800075dd 0076 P0013 880D ADD* DESTIN ADD ADDRESS OF DESTINATION ARRAY TO DESTINATIOA0800076dd 0077 XFA 2 STRING ADDRESS. SAVE IN R2 A0800077d 0077 P0014 07C2 d 0078 P0015 C0FF LDA- I SET BYTE OFFSET OF SOURCE STRING IN A. A0800078dd 0079 P0016 8C09 ADD* (SLEN) SET LENGTH OF SOURCE STRING IN A. A0800079dd 0080 P0017 FC0B ADQ* (DLEN) SET LENGTH OF DESTINATION STRING IN Q. A0800080dd 0081 MOV PERFORM THE MOVE. A0800081d 0081 P0018 0F01  d 0083 * RESTORE REGISTERS. A0800083dd 0084 P0019 C80B LDA* SAVEI A0800084dd 0085 P001A 60FF STA- I A0800085dd 0086 P001B E808 LDQ* SAVEQ A0800086d d 0088 P001C 1CE3 JMP* (CCSMVA) RETURN. A0800088dH1 CCSMVA PAGE 3 DATE: 08/29/84H  d 0090 * VARIABLES USED. A0800090dd 0091 * A0800091dd 0092 P001D 0000 SOURCE NUM 0 ADDRESS OF SOURCE ARRAY. A0800092dd 0093 P001E 0000 SPOS NUM 0 ADDRESS OF STARTING BYTE POSITION FOR SOURCE A0800093dd 0094 * STRING. A0800094dd 0095 P001F 0000 SLEN NUM 0 ADDRESS OF LENGTH OF SOURCE STRING. A0800095dd 0096 P0020 0000 DESTIN NUM 0 ADDRESS OF DESTINATION ARRAY. A0800096dd 0097 P0021 0000 DPOS NUM 0 ADDRESS OF STARTING BYTE POSITION FOR DESTI- A0800097dd 0098 * NATION STRING. A0800098dd 0099 P0022 0000 DLEN NUM 0 ADDRESS OF LENGTH OF DESTINATION STRING. A0800099dd 0100 P0023 0000 SAVEQ NUM 0 A0800100dd 0101 P0024 0000 SAVEI NUM 0 A0800101d    d 0103 * ROUTINE TO PICK UP PARAMETER ADDRESSES. A0800103dd 0104 * A0800104dd 0105 P0025 0000 PARGET 0 0 A0800105dd 0106 P0026 E8D9 LDQ* CCSMVA PICK UP LOCATION OF CALLER + 6. A0800106dd 0107 P0027 0DFE INQ -1 MOVE TO END OF PARAMETER LIST A0800107dd 0108 P0028 0A05 ENA 5 SET UP INDEX INTO PARAMETER STORAGE. A0800108dd 0109 P0029 60FF STA- I A0800109dd 0110 P002A C622 PAR100 LDA- (ZERO),Q PICK UP ABSOLUTE ADDRESS OF PARAMETER. A0800110dd 0111 P002B 69F1 STA* SOURCE,I STORE IN PARAMETER LIST A0800111dd 0112 P002C 0DFE INQ -1 DECREMENT INDEX INTO PARAMETER LIST. A0800112dd 0113 DIP *-PAR100 SKIP IF ALL PARAMETER ADDRESS RETRIEVED. A0800113d 0113 P002D 06E3 d 0114 P002E 1CF6 JMP* (PARGET) RETURN. A0800114d  d 0116 END A0800116d  D PGM= 002F ( 47) COM = 0000 ( 0) DAT = 0000 ( 0) D H1 CCSMVA PAGE 4 DATE: 08/29/84H     E Q U I V A L E N C E S -----------------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0000 I 00FF (000255) 0058, 0071, 0078, 0085, 0109 HH 0052 ZERO 0022 (000034) 0110 HH1 CCSMVA PAGE 5 DATE: 08/29/84H     S Y M B O L S -------------  B DEF.LINE NAME ADDRESS REFERENCED AT LINE NUMBER B H 0049 CCSMVA 0000 0049, 0061, 0063, 0088, 0106 HH 0092 SOURCE 001D 0069, 0111 HH 0093 SPOS 001E 0065 HH 0095 SLEN 001F 0079 HH 0096 DESTIN 0020 0076 HH 0097 DPOS 0021 0072 HH 0099 DLEN 0022 0080 HH 0100 SAVEQ 0023 0057, 0086 HH 0101 SAVEI 0024 0059, 0084 HH 0105 PARGET 0025 0064, 0114 HH 0110 PAR100 002A 0113, 0113, 0113, 0113 HH1 CCSMVA PAGE 6 DATE: 08/29/84H  > *** A L P H A B E T I C A L S O R T O F S Y M B O L S *** >  H CCSMVA 0049 DESTIN 0096 DLEN 0099 DPOS 0097 I 0000 HH PAR100 0110 PARGET 0105 SAVEI 0101 SAVEQ 0100 SLEN 0095 HH SOURCE 0092 SPOS 0093 ZERO 0052 HP1 PH1 CCSPUT PAGE 1 DATE: 08/29/84H  d 0001 NAM CCSPUT A09 A CCS CCS 3.0 SL-149A0900001dd 0002 * A0900002dd 0003 * A0900003dd 0004 * CYBERCREDIT SYSTEM VERSION 3 A0900004dd 0005 * DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA A0900005dd 0006 * COPYRIGHT CONTROL DATA CORPORATION, 1979 A0900006dd 0007 * A0900007dd 0008 * PUT CHARACTER INTO SPECIFIED POSITION IN AN ARRAY. A0900008dd 0009 * A0900009dd 0010 * ROUTINE TO PLACE A CHARACTER INTO A SPECIFIED POSITION IN AN ARRAA0900010dd 0011 * CALLING SEQUENCE: A0900011dd 0012 * CALL CCSPUT(CHAR,CHRPOS,BUF) A0900012dd 0013 * WHERE: A0900013dd 0014 * CHAR = CHARACTER TO BE PLACED IN THE ARRAY. A0900014dd 0015 * CHRPOS = CHARACTER POSITION THE CHARACTER IS TO BE PUT INTO.A0900015dd 0016 * BUF = ARRAY TO RECEIVE THE CHARACTER. A0900016dd 0017 * A0900017d  d 0019 ENT CCSPUT A0900019d d 0021 * COMMUNICATIONS REGION USED. A0900021dd 0022 0022 EQU ZERO($22) A0900022d  d 0024 P0000 0000 CCSPUT 0 0 A0900024d d 0026 * SAVE REGISTERS A0900026dd 0027 P0001 4813 STQ* SAVEQ A0900027dd 0028 P0002 C0FF LDA- I A0900028dd 0029 P0003 6812 STA* SAVEI A0900029d d 0031 P0004 E8FB LDQ* CCSPUT PICK UP ADDRESS OF CALLER. A0900031dd 0032 P0005 0D03 INQ 3 MOVE TO NEXT EXECUTABLE INSTRUCTION. A0900032dd 0033 P0006 48F9 STQ* CCSPUT SAVE RETURN ADDRESS. A0900033dd 0034 P0007 580F RTJ* PARGET PICK UP ADDRESSES OF PARAMETERS. A0900034dd 0035 P0008 EC0A LDQ* (CHRPOS) PICK UP CHARACTER POSITION TO BE STORED INTO. A0900035dd 0036 P0009 0DFE INQ -1 BIAS TO GET BYTE INDEX. A0900036dd 0037 P000A CC07 LDA* (CHAR) PICK UP CHARACTER TO BE STORED. A0900037dd 0038 SCA* (BUF),Q STORE CHARACTER INTO BUFFER. A0900038d 0038 P000B 04C5  0038 P000C C307  d 0040 * RESTORE REGISTERS. A0900040dd 0041 P000D C808 LDA* SAVEI A0900041dd 0042 P000E 60FF STA- I A0900042dd 0043 P000F E805 LDQ* SAVEQ A0900043d d 0045 P0010 1CEF JMP* (CCSPUT) RETURN. A0900045d  d 0047 * PARAMETER STORAGE. A0900047dd 0048 * A0900048dH1 CCSPUT PAGE 2 DATE: 08/29/84H  d 0049 P0011 0000 CHAR NUM 0 ABSOLUTE ADDRESS OF CHARACTER TO STORE. A0900049dd 0050 P0012 0000 CHRPOS NUM 0 ABSOLUTE ADDRESS OF CHARACTER POSITION TO PUT.A0900050dd 0051 P0013 0000 BUF NUM 0 ABSOLUTE ADDRESS OF ARRAY TO RECEIVE CHARACTERA0900051dd 0052 P0014 0000 SAVEQ NUM 0 A0900052dd 0053 P0015 0000 SAVEI NUM 0 A0900053d  d 0055 P0016 0000 PARGET 0 0 ROUTINE TO PICK UP PARAMETER ADDRESSES. A0900055dd 0056 P0017 E8E8 LDQ* CCSPUT PICK UP ADDRESS OF CALLER+3. A0900056dd 0057 P0018 0DFE INQ -1 MOVE TO END OF PARAMETER LIST. A0900057dd 0058 P0019 0A02 ENA 2 INITIALIZE INDEX INTO PARAMETER STORAGE. A0900058dd 0059 P001A 60FF STA- I A0900059dd 0060 P001B C622 PAR100 LDA- (ZERO),Q PICK UP ABSOLUTE ADDRESS OF NEXT PARAMETER. A0900060dd 0061 P001C 69F4 STA* CHAR,I STORE INTO PARAMETER STORAGE. A0900061dd 0062 P001D 0DFE INQ -1 DECREMENT INDEX INTO PARAMETER LIST. A0900062dd 0063 DIP *-PAR100 SKIP IF ALL PARAMETERS HAVE BEEN RETRIEVED. A0900063d 0063 P001E 06E3 d 0064 P001F 1CF6 JMP* (PARGET) RETURN. A0900064d  d 0066 END A0900066d  D PGM= 0020 ( 32) COM = 0000 ( 0) DAT = 0000 ( 0) D H1 CCSPUT PAGE 3 DATE: 08/29/84H     E Q U I V A L E N C E S -----------------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0000 I 00FF (000255) 0028, 0042, 0059 HH 0022 ZERO 0022 (000034) 0060 HH1 CCSPUT PAGE 4 DATE: 08/29/84H     S Y M B O L S -------------  B DEF.LINE NAME ADDRESS REFERENCED AT LINE NUMBER B H 0019 CCSPUT 0000 0019, 0031, 0033, 0045, 0056 HH 0049 CHAR 0011 0037, 0061 HH 0050 CHRPOS 0012 0035 HH 0051 BUF 0013 0038, 0038, 0038 HH 0052 SAVEQ 0014 0027, 0043 HH 0053 SAVEI 0015 0029, 0041 HH 0055 PARGET 0016 0034, 0064 HH 0060 PAR100 001B 0063, 0063, 0063, 0063 HH1 CCSPUT PAGE 5 DATE: 08/29/84H  > *** A L P H A B E T I C A L S O R T O F S Y M B O L S *** >  H BUF 0051 CCSPUT 0019 CHAR 0049 CHRPOS 0050 I 0000 HH PAR100 0060 PARGET 0055 SAVEI 0053 SAVEQ 0052 ZERO 0022 HH HP1 PH1 CCSPYT PAGE 1 DATE: 08/29/84H  d 0001 NAM CCSPYT A10 A CCS CCS 3.0 SL-149A1000001dd 0002 * A1000002dd 0003 * CYBERCREDIT SYSTEM VERSION 3 A1000003dd 0004 * DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA A1000004dd 0005 * COPYRIGHT CONTROL DATA CORPORATION, 1979 A1000005dd 0006 * A1000006dd 0007 ENT CCSPYT A1000007d  d 0009 P0000 0000 CCSPYT 0 0 PROGRAM ENTRY POIT. A1000009dd 0010 P0001 E8FE LDQ* CCSPYT PICK UP CALLER ADDRESS A1000010dd 0011 P0002 0D02 INQ 2 SET UP RETURN ADDRESS A1000011dd 0012 P0003 4400 STQ+ CCSPYT SAVE A1000012d P0004 0000 P d 0013 P0005 1CFA JMP* (CCSPYT) RETURN A1000013d  d 0015 END A1000015d  D PGM= 0006 ( 6) COM = 0000 ( 0) DAT = 0000 ( 0) D H1 CCSPYT PAGE 2 DATE: 08/29/84H     E Q U I V A L E N C E S -----------------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0000 I 00FF (000255) HH1 CCSPYT PAGE 3 DATE: 08/29/84H     S Y M B O L S -------------  B DEF.LINE NAME ADDRESS REFERENCED AT LINE NUMBER B H 0007 CCSPYT 0000 0007, 0010, 0012, 0013 HH1 CCSPYT PAGE 4 DATE: 08/29/84H  > *** A L P H A B E T I C A L S O R T O F S Y M B O L S *** >  H CCSPYT 0007 I 0000 HP1 PH1 CCSTIM PAGE 1 DATE: 08/29/84H  d 0001 NAM CCSTIM A11 A CCS CCS 3.0 SL-149A1100001dd 0002 * A1100002dd 0003 * A1100003dd 0004 * CYBERCREDIT SYSTEM VERSION 3 A1100004dd 0005 * DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA A1100005dd 0006 * COPYRIGHT CONTROL DATA CORPORATION, 1979 A1100006dd 0007 * A1100007dd 0008 * STORE ASCII CONVERSION OF TIME OF DAY . A1100008dd 0009 * A1100009dd 0010 * ROUTINE TO PICK UP THE TIME OF DAY AND CONVERT IT TO ITS ASCII A1100010dd 0011 * EQUIVALENT. A1100011dd 0012 * A1100012dd 0013 * CALLING SEQUENCE: A1100013dd 0014 * CALL CCSTIM(BUF) A1100014dd 0015 * WHERE BUF IS THE TWO WORD LOCATION TO RECEIVE THE CONVERTED TIME.A1100015dd 0016 * RETURNED TIME IS EXPRESSED IN MILITARY TIME, HHMM. A1100016dd 0017 * A1100017d d 0019 ENT CCSTIM A1100019d d 0021 EXT HORMIN SYSTEM WALL CLOCK IN MILITARY TIME. A1100021d d 0023 * COMMUNICATIONS REGION USED. A1100023dd 0024 0022 EQU ZERO($22) A1100024dd 0025 0046 EQU TEN($46) A1100025d  d 0027 P0000 0000 CCSTIM 0 0 A1100027d d 0029 * SAVE REGISTERS. A1100029dd 0030 P0001 4825 STQ* SAVEQ A1100030dd 0031 P0002 C0FF LDA- I A1100031dd 0032 P0003 6824 STA* SAVEI A1100032d d 0034 P0004 E8FB LDQ* CCSTIM PICK UP ADDRESS OF CALLER. A1100034dd 0035 P0005 C622 LDA- (ZERO),Q PICK UP ADDRESS OF THE PARAMETER BUF. A1100035dd 0036 P0006 681F STA* BUF SAVE ADDRESS. A1100036dd 0037 P0007 0D01 INQ 1 MOVE CALLER TO NEXT EXECUTABLE INSTRUCTION. A1100037dd 0038 P0008 48F7 STQ* CCSTIM SAVE RETURN VALUE. A1100038dd 0039 P0009 C81A LDA* THOUS INITIALIZE DVISOR. SET AT 1000 INITIALLY, THENA1100039dd 0040 P000A 681A STA* DVISOR VARIES FROM 1000 TO 1. A1100040dd 0041 P000B C400 X LDA HORMIN PICK UP THE CURRENT TIME. A1100041d P000C 7FFF X d 0042 P000D 0C00 ENQ 0 INITIALIZE BYTE INDEX INTO BUF. A1100042dd 0043 P000E 40FF STQ- I A1100043dd 0044 P000F 0C00 TIM100 ENQ 0 ZERO Q FOR DIVIDE. A1100044dd 0045 P0010 3814 DVI* DVISOR DIVIDE TO PICK UP NEXT NUMBER TO CONVERT. A1100045dd 0046 P0011 0930 INA $30 ADD ASCII CONVERSION. A1100046dd 0047 SCA* (BUF),I STORE CONVERTED NUMBER INTO BUF. A1100047d 0047 P0012 04C7  0047 P0013 C312 d 0048 XFQ 1 SAVE REMAINDER FROM LAST DIVISION IN R1. A1100048d 0048 P0014 07A1 H1 CCSTIM PAGE 2 DATE: 08/29/84H  d 0049 P0015 0C00 ENQ 0 ZERO Q FOR DIVIDE. A1100049dd 0050 P0016 C80E LDA* DVISOR GET NEXT DIVISOR VALUE. A1100050dd 0051 P0017 3046 DVI- TEN A1100051dd 0052 P0018 0106 SAZ TIM200 SKIP WHEN NUMBER IS FULLY CONVERTED. A1100052dd 0053 P0019 680B STA* DVISOR SAVE NEW DIVISOR VALUE. A1100053dd 0054 P001A C0FF LDA- I INCREMENT BYTE INDEX INTO BUF. A1100054dd 0055 P001B 0901 INA 1 A1100055dd 0056 P001C 60FF STA- I A1100056dd 0057 XF1 A RECALL REMAINDER FROM PREVIOUS DIVISION. A1100057d 0057 P001D 0726 d 0058 P001E 18F0 JMP* TIM100 GO CONVERT NEXT NUMBER. A1100058d d 0060 * RESTORE REGISTERS. A1100060dd 0061 P001F C808 TIM200 LDA* SAVEI A1100061dd 0062 P0020 60FF STA- I A1100062dd 0063 P0021 E805 LDQ* SAVEQ A1100063d d 0065 P0022 1CDD JMP* (CCSTIM) A1100065d d 0067 * VARIABLES AND PARAMETERS USED. A1100067dd 0068 P0023 03E8 THOUS NUM 1000 NUMERIC VALUE 1000. A1100068dd 0069 P0024 0000 DVISOR NUM 0 CURRENT DIVISOR VALUE. A1100069dd 0070 P0025 0000 BUF NUM 0 ABSOLUTE ADDRESS OF LOCATION TO RECEIVE THE TIA1100070dd 0071 P0026 0000 SAVEQ NUM 0 A1100071dd 0072 P0027 0000 SAVEI NUM 0 A1100072d d 0074 END A1100074d  D PGM= 0028 ( 40) COM = 0000 ( 0) DAT = 0000 ( 0) D H1 CCSTIM PAGE 3 DATE: 08/29/84H     E Q U I V A L E N C E S -----------------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0000 I 00FF (000255) 0031, 0043, 0054, 0056, 0062 HH 0024 ZERO 0022 (000034) 0035 HH 0025 TEN 0046 (000070) 0051 HH1 CCSTIM PAGE 4 DATE: 08/29/84H     S Y M B O L S -------------  B DEF.LINE NAME ADDRESS REFERENCED AT LINE NUMBER B H 0019 CCSTIM 0000 0019, 0034, 0038, 0065 HH 0044 TIM100 000F 0058 HH 0061 TIM200 001F 0052 HH 0068 THOUS 0023 0039 HH 0069 DVISOR 0024 0040, 0045, 0050, 0053 HH 0070 BUF 0025 0036, 0047, 0047, 0047 HH 0071 SAVEQ 0026 0030, 0063 HH 0072 SAVEI 0027 0032, 0061 HH1 CCSTIM PAGE 5 DATE: 08/29/84H     E X T E R N A L S -----------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0021 HORMIN 000C 0041 HH1 CCSTIM PAGE 6 DATE: 08/29/84H  > *** A L P H A B E T I C A L S O R T O F S Y M B O L S *** >  H BUF 0070 CCSTIM 0019 DVISOR 0069 HORMIN 0021 I 0000 HH SAVEI 0072 SAVEQ 0071 TEN 0025 THOUS 0068 TIM100 0044 HH TIM200 0061 ZERO 0024 HP1 PH1 COLECT PAGE 1 DATE: 08/29/84H  d 0001 NAM COLECT A12 A CCS CCS 3.0 SL-149A1200001dd 0002 * A1200002dd 0003 * CYBERCREDIT SYSTEM VERSION 3 A1200003dd 0004 * DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA A1200004dd 0005 * COPYRIGHT CONTROL DATA CORPORATION, 1979 A1200005dd 0006 * A1200006dd 0007 * A1200007dd 0008 * DUMMY PROGRAM TO JUMP AROUND LABELED COMMON. A1200008dd 0009 * A1200009dd 0010 ENT COLECT A1200010dd 0011 EXT FCOLEC A1200011d d 0013 P0000 1400 X COLECT JMP FCOLEC JUMP TO THE FORTRAN MAIN MODULE. A1200013d P0001 7FFF X d 0014 END A1200014d  D PGM= 0002 ( 2) COM = 0000 ( 0) DAT = 0000 ( 0) D H1 COLECT PAGE 2 DATE: 08/29/84H     E Q U I V A L E N C E S -----------------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0000 I 00FF (000255) HH1 COLECT PAGE 3 DATE: 08/29/84H     S Y M B O L S -------------  B DEF.LINE NAME ADDRESS REFERENCED AT LINE NUMBER B H 0010 COLECT 0000 0010 HH1 COLECT PAGE 4 DATE: 08/29/84H     E X T E R N A L S -----------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0011 FCOLEC 0001 0013 HH1 COLECT PAGE 5 DATE: 08/29/84H  > *** A L P H A B E T I C A L S O R T O F S Y M B O L S *** >  H COLECT 0010 FCOLEC 0011 I 0000 HP1 PH1 DATHAN PAGE 1 DATE: 08/29/84H  d 0001 NAM DATHAN A13 A CCS CCS 3.0 SL-149A1300001dd 0002 * A1300002dd 0003 * A1300003dd 0004 * CYBERCREDIT SYSTEM VERSION 3 A1300004dd 0005 * DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA A1300005dd 0006 * COPYRIGHT CONTROL DATA CORPORATION, 1979 A1300006dd 0007 * A1300007dd 0008 * DATE HANDLER PROGRAM FOR DATE CHECKS AND JULIAN CONVERSIONS. A1300008dd 0009 * A1300009dd 0010 * ROUTINE TO PERFORM THREE TASKS INVOLVING DATES: A1300010dd 0011 * 1. CONVERT A SIX CHARACTER (ASCII) DATE INTO ITS JULIAN A1300011dd 0012 * EQUIVALENT (1 - 365). A1300012dd 0013 * 2. CHECK A SIX CHARACTER (ASCII) DATE FOR A VALID DATE, I.E.A1300013dd 0014 * 0 < MONTH < 13, AND 0 < DAY < ALLOWABLES DAYS IN THAT MONTH.A1300014dd 0015 * 3. CONVERT A NUMERIC JULIAN DATE (1 - 365) INTO ITS ASCII A1300015dd 0016 * VALUES FOR MONTH AND DAY, MMDD. A1300016dd 0017 * ****NOTE: NO CONSIDERATION IS GIVEN TO LEAP YEARS. A1300017dd 0018 * A1300018dd 0019 * CALLING SEQUENCES: A1300019dd 0020 * 1. INTEGER FUNCTION FOR CALENDAR TO JULIAN DATE CONVERSION: A1300020dd 0021 * VARIABLE = ICALJL(DATE,STRPOS) A1300021dd 0022 * WHERE: A1300022dd 0023 * DATE = ARRAY DATE IS CONTAINED IN. A1300023dd 0024 * STRPOS = STARTING POSITION IN ARRAY OF THE DATE. A1300024dd 0025 * RETURNED VALUES FOR THE FUNCTION ARE THE JULIAN CONVERSION A1300025dd 0026 * IF THE DATE SUPLLIED WAS VALID, OR -1 IF THE DATE SUPPLIED A1300026dd 0027 * WAS NOT VALID. A1300027dd 0028 * 2. INTEGER FUNCTION FOR DATE VALIDATION CHECK: A1300028dd 0029 * VARIABLE = IDATVR(DATE,STRPOS) A1300029dd 0030 * WHERE THE PARAMETERS HAVE THE SAME DEFINITION AS ABOVE. A1300030dd 0031 * RETURNED VALUES ARE: = 0, DATE VALID, AND = -1, DATE INVALIDA1300031dd 0032 * 3. JULIAN DATE TO ASCII CALENDAR DATE CONVERSION. A1300032dd 0033 * CALL JULCAL(JULIAN,DATE,STRPOS) A1300033dd 0034 * WHERE: A1300034dd 0035 * JULIAN = JULIAN DATE FOR CONVERSION (1 - 365). A1300035dd 0036 * DATE = ARRAY TO RECEIVE THE MONTH AND DAY FROM THE A1300036dd 0037 * CONVERSION. A1300037dd 0038 * STRPOS = STARTING POSITION IN DATE ARRAY TO RECEIVE THE CON-A1300038dd 0039 * VERTED DATE. A1300039dd 0040 * FOR THIS ROUTINE, IF JULIAN < 0, THE DATE FIELD IS ZERO- A1300040dd 0041 * FILLED (ASCII,$30). A1300041dd 0042 * A1300042d  d 0044 ENT ICALJL CALENDAR TO JULIAN CONVERSION. A1300044dd 0045 ENT IDATVR DATE VALIDATION ROUTINE. A1300045dd 0046 ENT JULCAL JULIAN TO CALENDAR CONVERSION. A1300046d  d 0048 * COMMUNICATIONS REGION USED. A1300048dd 0049 0003 EQU ONE($3) A1300049dd 0050 0004 EQU THREE($4) A1300050dd 0051 0022 EQU ZERO($22) A1300051dH1 DATHAN PAGE 2 DATE: 08/29/84H  d 0052 0024 EQU TWO($24) A1300052dd 0053 0046 EQU TEN($46) A1300053dH1 DATHAN PAGE 3 DATE: 08/29/84H  d 0055 * CALENDAR DATE TO JULIAN DATE CONVERSION. A1300055dd 0056 * A1300056dd 0057 P0000 0000 ICALJL 0 0 A1300057d d 0059 * SAVE REGISTERS. A1300059dd 0060 P0001 485F STQ* SAVEQ A1300060dd 0061 P0002 C0FF LDA- I A1300061dd 0062 P0003 685E STA* SAVEI A1300062d d 0064 P0004 E8FB LDQ* ICALJL PICK UP ADDRESS OF CALLER. A1300064dd 0065 P0005 4847 STQ* CALLER SAVE FOR PARAMETER PICK UP. A1300065dd 0066 P0006 0D02 INQ 2 INCREMENT RETURN ADDRESS TO NEXT INTSTRUCTION.A1300066dd 0067 P0007 485B STQ* IRTN SAVE RETURN ADDRESS. A1300067dd 0068 P0008 585B RTJ* PARGET PICK UP PARAMETER ADDRESSES. A1300068dd 0069 P0009 5816 RTJ* VALDAT CHECK IF VALID CALENDAR DATE SUPPLIED. A1300069dd 0070 P000A 0136 SAM CAL200 SKIP IF NO. RETURN JULIAN < 0 INDICATING ERRORA1300070dd 0071 P000B C846 LDA* DATE+1 PICK UP CONVERTED NUMBER OF DAYS PASSED. A1300071dd 0072 P000C E846 LDQ* DATE+2 SET UP INDEX INTO DAYS PER MONTH TABLE. A1300072dd 0073 P000D 0DFD INQ -2 A1300073dd 0074 P000E 0172 SQM CAL200 SKIP IF MONTH = 1. A1300074dd 0075 P000F 8A44 CAL100 ADD* DAYMON,Q ADD DAYS PER MONTH FOR NEXT MONTH. A1300075dd 0076 DQP *-CAL100 CONTINUE UNTIL ALL MONTHS THRU JANUARY ADDED IA1300076d 0076 P0010 06A1 d 0077 P0011 1800 CAL200 JMP RETURN RETURN. A1300077d P0012 0095 H1 DATHAN PAGE 4 DATE: 08/29/84H  d 0079 *‚ DATE VALIDATION CHECK. CHECK MONTH (1 - 12), DAY (1 - MAXIMUM FORA1300079dd 0080 * MONTH), AND YEAR (0 - 99). A1300080dd 0081 * A1300081dd 0082 P0013 0000 IDATVR 0 0 ENTRY POINT. A1300082d d 0084 * SAVE REGISTERS. A1300084dd 0085 P0014 484C STQ* SAVEQ A1300085dd 0086 P0015 C0FF LDA- I A1300086dd 0087 P0016 684B STA* SAVEI A1300087d d 0089 P0017 E8FB LDQ* IDATVR PICK UP ADDRESS OF CALLER. A1300089dd 0090 P0018 4834 STQ* CALLER SAVE FOR PARAMETER PICK UP ROUTINE. A1300090dd 0091 P0019 0D02 INQ 2 MOVE RETURN ADDRESS TO NEXT INSTRUCTION. A1300091dd 0092 P001A 4848 STQ* IRTN SAVE RETURN ADDRESS. A1300092dd 0093 P001B 5848 RTJ* PARGET PICK UP PARAMETER ADDRESSES. A1300093dd 0094 P001C 5803 RTJ* VALDAT CHECK DATE FOR VALIDITY. RETURN VALUE IN A. A1300094dd 0095 P001D 1800 JMP RETURN RETURN. RETURNED VALUES: =0,VALID; =-1,INVALIDA1300095d P001E 0089 H1 DATHAN PAGE 5 DATE: 08/29/84H  d 0097 * ACTUAL DATE VALIDATION ROUTINE. CHECKS EACH CHARACTER IN THE DATEA1300097dd 0098 * FOR A NUMERIC ENTRY, CONVERTS THE MONTH AND DAY ENTRIES, AND A1300098dd 0099 * CHECKS FOR 0 < MONTH < 13, AND 0 < DAY < MAXIMUM DAYS IN THIS A1300099dd 0100 * MONTH. A1300100dd 0101 * A1300101dd 0102 P001F 0000 VALDAT 0 0 A1300102dd 0103 P0020 CC2E LDA* (PARAMS+1) PICK UP STARTING POSITION IN ARRAY OF DATE. A1300103dd 0104 P0021 09FE INA -1 DECREMENT TO GET BYTE INDEX. A1300104dd 0105 XFA 1 R1 IS BYTE INDEX. A1300105d 0105 P0022 07C1 d 0106 P0023 0A02 ENA 2 A1300106dd 0107 P0024 60FF STA- I INTIALIZE POINTER INTO DATE STORAGE. A1300107dd 0108 VAL050 LCA* (PARAMS+0),1 PICK UP NEXT CHARACTER, TENS DIGIT OF DATE FIEA1300108d 0108 P0025 04C1  0108 P0026 C227 d 0109 P0027 581D RTJ* NUMCHK CHECK FOR A ASCII NUMBER. A1300109dd 0110 P0028 2046 MUI- TEN ENTRY IS ASCII NUMBER. CONVERT TO TENS. A1300110dd 0111 P0029 0822 TRA Q SAVE TENS IN Q. A1300111dd 0112 AR1- ONE INCREMENT BYTE INDEX TO GET NEXT CHARACTER. A1300112d 0112 P002A 0401  0112 P002B 8003 d 0113 LCA* (PARAMS+0),1 PICK UP NEXT CHARACTER, ONES DIGIT OF DATE FIEA1300113d 0113 P002C 04C1  0113 P002D C220 d 0114 P002E 5816 RTJ* NUMCHK CHECK FRO AN ASCII NUMBER. A1300114dd 0115 P002F 0834 AAQ A ADD TENS DIGIT TO GET CONVERTED MONTH,DAY,YEARA1300115dd 0116 P0030 6920 STA* DATE,I SAVE CONVERTED FIELD. A1300116dd 0117 AR1- ONE INCREMENT BYTE INDEX TO GET NEXT CHARACTER. A1300117d 0117 P0031 0401  0117 P0032 8003 d 0118 DIP *-VAL050 SKIP IF MONTH, DAY, AND YEAR HAVE BEEN CHECKEDA1300118d 0118 P0033 06EE d 0119 * CONTINUE. ALL CHARACTERS WERE NUMERIC. A1300119d  d 0121 * CHECK VALUE FOR MONTH. A1300121dd 0122 P0034 C81E LDA* DATE+2 A1300122dd 0123 P0035 09FE INA -1 CHECK FOR MONTH < 1. A1300123dd 0124 P0036 013B SAM VAL100 SKIP IF MONTH < 1. A1300124dd 0125 P0037 09F3 INA -12 CHECK FOR MONTH > 12. A1300125dd 0126 P0038 0129 SAP VAL100 SKIP IF MONTH > 12. A1300126dd 0127 * MONTH OK, CHECK VALUE FOR DAY. A1300127dd 0128 P0039 E819 LDQ* DATE+2 GET INDEX INTO DAYS PER MONTH TABLE. A1300128dd 0129 P003A 0DFE INQ -1 A1300129dd 0130 P003B C816 LDA* DATE+1 PICK UP VALUE FOR DAY. A1300130dd 0131 P003C 09FE INA -1 CHECK FOR DAY < 1. A1300131dd 0132 P003D 0134 SAM VAL100 SKIP IF DAY < 1. A1300132dd 0133 P003E 9A15 SUB* DAYMON,Q CHECK FOR DAY > MAXIMUM ALLOWABLE FOR THIS MONA1300133dd 0134 P003F 0122 SAP VAL100 SKIP IF DAY > MAXIMUM ALLOWABLE FOR THIS MONTHA1300134dd 0135 P0040 0A00 ENA 0 DATE GIVEN IS VALID. RETURN A = 0. A1300135dd 0136 P0041 1802 JMP* VAL200 A1300136dd 0137 P0042 0AFE VAL100 ENA -1 DATE INVALID, ERROR. RETURN A < 0. A1300137dd 0138 P0043 1CDB VAL200 JMP* (VALDAT) RETURN. A1300138dH1 DATHAN PAGE 6 DATE: 08/29/84H    d 0140 * ROUTINE TO CHECK A REGISTER FOR AN ASCII NUMBER ($30 - $39), AND A1300140dd 0141 * RETURN THE ACTUAL NUMBER IT REPRESENTS IN THE A REGISTER. IF A1300141dd 0142 * THE A REGISTER IS NOT AN ASCII NUMBER, JUMP TO REPORT ERROR. A1300142dd 0143 P0044 0000 NUMCHK 0 0 A1300143dd 0144 P0045 09CF INA -$30 CHECK FOR A < $30. A1300144dd 0145 P0046 0132 SAM NUM100 SKIP IF A < $30. A1300145dd 0146 P0047 09F5 INA -$A CHECK FOR A > $3A. A1300146dd 0147 P0048 0131 SAM NUM200 SKIP IF A NOT > $3A. A1300147dd 0148 P0049 18F8 NUM100 JMP* VAL100 NOT A NUMERIC ENTRY, JUMP TO REPORT ERROR. A1300148dd 0149 P004A 090A NUM200 INA $A CONVERT A REGISTER TO HOLD NUMBER REPRESENTATIA1300149dd 0150 P004B 1CF8 JMP* (NUMCHK) RETURN. A1300150dH1 DATHAN PAGE 7 DATE: 08/29/84H  d 0152 * VARIABLES AND CONSTANTS USED. A1300152dd 0153 * A1300153dd 0154 P004C 0000 CALLER NUM 0 ADDRESS OF CALLER FOR PARAMETER RETRIEVAL. A1300154dd 0155 * PARAMETER ADDRESSES. A1300155dd 0156 * ROUTINE = ICALJL IDATVR JULCAL A1300156dd 0157 P004D 0000 PARAMS NUM 0 +0 DATE DATE JULIAN A1300157dd 0158 P004E 0000 NUM 0 +1 STRPOS STRPOS DATE A1300158dd 0159 P004F 0000 NUM 0 +2 DUMMY DUMMY STRPOS A1300159dd 0160 P0050 0000 DATE NUM 0 YEAR YEAR MONTH A1300160dd 0161 P0051 0000 NUM 0 DAY DAY DAY A1300161dd 0162 P0052 0000 NUM 0 MONTH MONTH YEAR A1300162dd 0163 * NUMBER OF DAYS IN EACH MONTH. A1300163dd 0164 P0053 001F DAYMON NUM 31,28,31,30,31,30,31,31,30,31,30,31 A1300164d P0054 001C  P0055 001F  P0056 001E  P0057 001F  P0058 001E  P0059 001F  P005A 001F  P005B 001E  P005C 001F  P005D 001E  P005E 001F d 0165 P005F 016D DAYSYR NUM 365 NUMBER OF DAYS IN A YEAR. A1300165dd 0166 P0060 0000 SAVEQ NUM 0 A1300166dd 0167 P0061 0000 SAVEI NUM 0 A1300167dd 0168 P0062 0000 IRTN NUM 0 RETURN ADDRESS. A1300168d    d 0170 * ROUTINE TO PICK UP PARAMETER ADDRESSES. A1300170dd 0171 * A1300171dd 0172 P0063 0000 PARGET 0 0 A1300172dd 0173 P0064 E8E7 LDQ* CALLER PICK UP ADDRESS OF CALLER. A1300173dd 0174 P0065 0D02 INQ 2 MOVE TO END OF PARAMETER LIST. A1300174dd 0175 P0066 0A02 ENA 2 A1300175dd 0176 P0067 60FF STA- I A1300176dd 0177 P0068 C622 PAR100 LDA- (ZERO),Q PICK UP NEXT PARAMETER ADDRESS. A1300177dd 0178 P0069 69E3 STA* PARAMS,I STORE INTO PARAMETER ADDRESS STORAGE. A1300178dd 0179 P006A 0DFE INQ -1 DECREMENT INDEX INTO PARAMETER LIST. A1300179dd 0180 DIP *-PAR100 SKIP IF ALL PARAMETER ADDRESS ARE RETRIEVED. A1300180d 0180 P006B 06E3 d 0181 P006C 1CF6 JMP* (PARGET) RETURN. A1300181dH1 DATHAN PAGE 8 DATE: 08/29/84H  d 0183 *‚ CONVERT JULIAN DATE TO AN ASCII CALENDAR DATE. A1300183dd 0184 * A1300184dd 0185 P006D 0000 JULCAL 0 0 ENTRY POINT. A1300185d d 0187 * SAVE REGISTERS. A1300187dd 0188 P006E 48F1 STQ* SAVEQ A1300188dd 0189 P006F C0FF LDA- I A1300189dd 0190 P0070 68F0 STA* SAVEI A1300190d d 0192 P0071 E8FB LDQ* JULCAL PICK UP ADDRESS OF CALLER. A1300192dd 0193 P0072 48D9 STQ* CALLER SAVE FOR PARAMETER ADDRESS RETRIEVAL. A1300193dd 0194 P0073 0D03 INQ 3 MOVE RETURN ADDRESS TO NEXT INSTRUCTION. A1300194dd 0195 P0074 48ED STQ* IRTN SAVE THE RETURN ADDRESS. A1300195dd 0196 P0075 58ED RTJ* PARGET PICK UP PARAMETER ADDRESS. A1300196dd 0197 P0076 CCD6 LDA* (PARAMS+0) PICK UP JULIAN DATE TO CONVERT. A1300197dd 0198 P0077 09FE INA -1 CHECK FOR JULIAN DATE > 0. A1300198dd 0199 P0078 0125 SAP JUL100 SKIP IF DATE > 0. A1300199dd 0200 P0079 C000 LDA =N$3030 JULIAN DATE < 0, ZERO FILL DATE FIELD. A1300200d P007A 3030 d 0201 P007B 68D4 STA* DATE A1300201dd 0202 P007C 68D4 STA* DATE+1 A1300202dd 0203 P007D 1820 JMP* JUL450 A1300203dd 0204 P007E 0901 JUL100 INA 1 RESTORE JULIAN DATE. A1300204dd 0205 P007F 98DF SUB* DAYSYR SUBTRACT 365 UNTIL VALUE IS BETWEEN 1 AND 365.A1300205dd 0206 DAP *-JUL100 SKIP WHEN LAST 365 SUBTRACTED WAS TOO MUCH. A1300206d 0206 P0080 06C2 d 0207 P0081 0901 INA 1 ADD ONE TO COMPENSATE FOR DECREMENT INSTRUCTIOA1300207dd 0208 P0082 88DC JUL200 ADD* DAYSYR ADD 365 TO RESTORE DATE TO CONVERT. A1300208dd 0209 P0083 0864 TCA A LOOP THRU ALL MONTHS SUBTRACTING DAYS IN THAT A1300209dd 0210 P0084 0C00 ENQ 0 MONTH UNTIL MONTH THIS DAY OCCURRED IN IS FOUNA1300210dd 0211 P0085 8ACD JUL300 ADD* DAYMON,Q ADD DAYS IN MONTH TO RESTORE VALUE TO > 0. A1300211dd 0212 P0086 0122 SAP JUL400 SKIP IF CHANGE IN SIGN INDICATING MONTH FOUND.A1300212dd 0213 P0087 0D01 INQ 1 MONTH NOT FOUND, INCREMENT INDEX TO NEXT MONTHA1300213dd 0214 P0088 18FC JMP* JUL300 ADD NEXT MONTH DAYS. A1300214dd 0215 P0089 9AC9 JUL400 SUB* DAYMON,Q A1300215dd 0216 P008A 0864 TCA A NUMBER OF DAYS INTO MONTH FOR THIS JULIAN DATEA1300216dd 0217 P008B 68C5 STA* DATE+1 SAVE IN LOCAL VARIABLE. A1300217dd 0218 P008C 0D01 INQ 1 INCREMENT MONTH INDEX TO GET MONTH OF JUL. DATA1300218d d 0220 * CONVERT MONTH AND DAY TO ASCII REPRESENTATIONS. A1300220dd 0221 P008D 0814 TRQ A MONTH OF JULIAN DATE. A1300221dd 0222 P008E 0C00 ENQ 0 ZERO Q FOR DIVIDE. A1300222dd 0223 P008F 3046 DVI- TEN DIVIDE TO GET A = TENS DIGIT AND Q = ONES DIGIA1300223dd 0224 P0090 0930 INA $30 ADD ASCII CONVERSION TO GET NUMBER. A1300224dd 0225 P0091 0FC8 ALS 8 SHIFT TO REPRESENT TENS. A1300225dd 0226 P0092 0930 INA $30 ADD CONVERSION FOR ONES DIGIT. A1300226dd 0227 P0093 0834 AAQ A ADD ONES DIGIT TO GET FULLY CONVERTED MONTH. A1300227dd 0228 P0094 68BB STA* DATE SAVE CONVERTED MONTH. A1300228dd 0229 P0095 C8BB LDA* DATE+1 PICK UP VALUE OF DAY FOR CONVERSION. A1300229dd 0230 P0096 0C00 ENQ 0 ZERO Q FOR DIVIDE. A1300230dd 0231 P0097 3046 DVI- TEN DIVIDE TO GET A = TENS DIGIT AND Q = ONES DIGIA1300231dd 0232 P0098 0930 INA $30 ADD ASCII CONVERSION TO TENS DIGIT. A1300232dd 0233 P0099 0FC8 ALS 8 SHIFT TO REPRESENT TENS. A1300233dH1 DATHAN PAGE 9 DATE: 08/29/84H  d 0234 P009A 0930 INA $30 ADD ASCII CONVERSION FOR ONES DIGIT. A1300234dd 0235 P009B 0834 AAQ A ADD ONES DIGIT TO GET FULLY CONVERTED DAY. A1300235dd 0236 P009C 68B4 STA* DATE+1 SAVE CONVERTED VALUE OF DAY. A1300236d d 0238 * MOVE ASCII CONVERSION OF DATE TO RETURN BUFFER. A1300238dd 0239 P009D ECB1 JUL450 LDQ* (PARAMS+2) PICK UP DESTINATION POSITION IN RETURN BUFFERA1300239dd 0240 P009E 0D02 INQ 2 MOVE TO END OF RETURN BUFFER. A1300240dd 0241 P009F 0A03 ENA 3 A1300241dd 0242 P00A0 60FF STA- I INTIALIZE BYTE INDEX INTO CONVERTED DATE. A1300242dd 0243 JUL500 LCA* DATE,I PICK UP NEXT CHARACTER OF CONVERTED DATE. A1300243d 0243 P00A1 0487  0243 P00A2 C2AD d 0244 SCA* (PARAMS+1),Q STORE INTO RETURN BUFFER. A1300244d 0244 P00A3 04C5  0244 P00A4 C3A9 d 0245 P00A5 0DFE INQ -1 DECREMENT INDEX INTO RETURN BUFFER. A1300245dd 0246 DIP *-JUL500 SKIP WHEN ALL OF DATE MOVED. A1300246d 0246 P00A6 06E5  d 0248 * RESTORE REGISTERS. A1300248dd 0249 P00A7 E8B9 RETURN LDQ* SAVEI A1300249dd 0250 P00A8 40FF STQ- I A1300250dd 0251 P00A9 E8B6 LDQ* SAVEQ A1300251d d 0253 P00AA 1CB7 JMP* (IRTN) RETURN. A1300253d  d 0255 END A1300255d  D PGM= 00AB ( 171) COM = 0000 ( 0) DAT = 0000 ( 0) D H1 DATHAN PAGE 10 DATE: 08/29/84H     E Q U I V A L E N C E S -----------------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0000 I 00FF (000255) 0061, 0086, 0107, 0176, 0189, 0242HH 0250 HH 0049 ONE 0003 (000003) 0112, 0112, 0117, 0117 HH 0050 THREE 0004 (000004) HH 0051 ZERO 0022 (000034) 0177 HH 0052 TWO 0024 (000036) HH 0053 TEN 0046 (000070) 0110, 0223, 0231 HH1 DATHAN PAGE 11 DATE: 08/29/84H     S Y M B O L S -------------  B DEF.LINE NAME ADDRESS REFERENCED AT LINE NUMBER B H 0044 ICALJL 0000 0044, 0064 HH 0045 IDATVR 0013 0045, 0089 HH 0046 JULCAL 006D 0046, 0192 HH 0075 CAL100 000F 0076, 0076, 0076, 0076 HH 0077 CAL200 0011 0070, 0074 HH 0102 VALDAT 001F 0069, 0094, 0138 HH 0108 VAL050 0025 0118, 0118, 0118, 0118 HH 0137 VAL100 0042 0124, 0126, 0132, 0134, 0148 HH 0138 VAL200 0043 0136 HH 0143 NUMCHK 0044 0109, 0114, 0150 HH 0148 NUM100 0049 0145 HH 0149 NUM200 004A 0147 HH 0154 CALLER 004C 0065, 0090, 0173, 0193 HH 0157 PARAMS 004D 0103, 0108, 0108, 0108, 0113, 0113HH 0113, 0178, 0197, 0239, 0244, 0244HH 0244 HH 0160 DATE 0050 0071, 0072, 0116, 0122, 0128, 0130HH 0201, 0202, 0217, 0228, 0229, 0236HH 0243, 0243, 0243 HH 0164 DAYMON 0053 0075, 0133, 0211, 0215 HH 0165 DAYSYR 005F 0205, 0208 HH 0166 SAVEQ 0060 0060, 0085, 0188, 0251 HH 0167 SAVEI 0061 0062, 0087, 0190, 0249 HH 0168 IRTN 0062 0067, 0092, 0195, 0253 HH 0172 PARGET 0063 0068, 0093, 0181, 0196 HH 0177 PAR100 0068 0180, 0180, 0180, 0180 HH 0204 JUL100 007E 0199, 0206, 0206, 0206, 0206 HH 0208 JUL200 0082 HH 0211 JUL300 0085 0214 HH 0215 JUL400 0089 0212 HH 0239 JUL450 009D 0203 HH 0243 JUL500 00A1 0246, 0246, 0246, 0246 HH 0249 RETURN 00A7 0077, 0095 HH1 DATHAN PAGE 12 DATE: 08/29/84H  > *** A L P H A B E T I C A L S O R T O F S Y M B O L S *** >  H CAL100 0075 CAL200 0077 CALLER 0154 DATE 0160 DAYMON 0164 HH DAYSYR 0165 I 0000 ICALJL 0044 IDATVR 0045 IRTN 0168 HH JUL100 0204 JUL200 0208 JUL300 0211 JUL400 0215 JUL450 0239 HH JUL500 0243 JULCAL 0046 NUM100 0148 NUM200 0149 NUMCHK 0143 HH ONE 0049 PAR100 0177 PARAMS 0157 PARGET 0172 RETURN 0249 HH SAVEI 0167 SAVEQ 0166 TEN 0053 THREE 0050 TWO 0052 HH VAL050 0108 VAL100 0137 VAL200 0138 VALDAT 0102 ZERO 0051 HH HP1 PH1 GETACT PAGE 1 DATE: 08/29/84H  d 0001 NAM GETACT A14 A CCS CCS 3.0 SL-149A1400001dd 0002 * A1400002dd 0003 * A1400003dd 0004 * CYBERCREDIT SYSTEM VERSION 3 A1400004dd 0005 * DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA A1400005dd 0006 * COPYRIGHT CONTROL DATA CORPORATION, 1979 A1400006dd 0007 * A1400007dd 0008 * RETRIEVE ACTIVITY FROM ACTIVITY BUFFER. A1400008dd 0009 * A1400009dd 0010 * CALLING SEQUENCE: A1400010dd 0011 * FTN CALL GETACF(STRING,BUFFER,LENGTH,OSW) A1400011dd 0012 * RPG EXIT GETACR A1400012dd 0013 * RLABL STRING A1400013dd 0014 * RLABL BUFFER A1400014dd 0015 * RLABL LENGTH A1400015dd 0016 * RLABL OSW A1400016dd 0017 * A1400017dd 0018 * PARAMETER DEFINTIONS: A1400018dd 0019 * STRING - THE ACTIVITY STRING RETURNED TO THE CALLER AS FOLLOA1400019dd 0020 * ACTIVITY DATE - MMDDYY (6 BYTES) A1400020dd 0021 * ACTION CODE (2 BYTES) A1400021dd 0022 * RESULT CODE (2 BYTES) A1400022dd 0023 * LETTER CODE (2 BYTES) A1400023dd 0024 * COLLECTOR ID (4 BYTES) A1400024dd 0025 * COMMENT (56 BYTES BLANK FILLED IF NECESSARY) A1400025dd 0026 * BUFFER - THE ACTIVITY BLOCK CONTAING THE COMPACTED ACTIVITIEA1400026dd 0027 * LENGTH - THE LENGTH OF THE BUFFER PASSSED AS A 4 BYTE A1400027dd 0028 * ASCII/EBCDIC FIELD CONTAINING THE NUMBER OF BYTES IN THA1400028dd 0029 * BUFFER. A1400029dd 0030 * OSW - THE STATUS WORD. ON RETURN, OSW HAS THE FOLLOWING A1400030dd 0031 * MEANING: (RETURNED VALUES ARE IN ASCII/EBCDIC) A1400031dd 0032 * = 0 REQUEST COMPLETED. A1400032dd 0033 * = 1 REQUEST REJECTED. ALL ACTIVITIES HAVE BEENA1400033dd 0034 * RETRIEVED FROM THIS ACTIVITY BLOCK. A1400034dd 0035 * A1400035dd 0036 MOV MAC A1400036dd 0037 VFD N4/0,N4/$F,N3/0,N5/1 MOVE STRING REQUEST A1400037dd 0038 EMC A1400038dd 0039 SEQ MAC A1400039dd 0040 VFD N4/0,N4/$F,N3/0,N5/2 SKIP IF STRING EQUAL A1400040dd 0041 EMC A1400041dd 0042 * A1400042dd 0043 ENT GETACR ENTRY POINT FOR RPG CALLERS. A1400043dd 0044 ENT GETACF ENTRY POINT FOR FTN CALLERS. A1400044dd 0045 * A1400045dd 0046 EXT R9FLDL PICKS UP ADDRESS OF RPG PARAMETERS. A1400046dd 0047 EXT R9BASE BASE ADDRESS OF RPG PARAMETERS. A1400047dd 0048 0002 EQU LPMASK($2) COMMUNICATONS REGION USED. A1400048dd 0049 0003 EQU ONE($3) A1400049dd 0050 0005 EQU SEVEN($5) A1400050dd 0051 0022 EQU ZERO($22) A1400051dd 0052 0023 EQU ONEBIT($23) A1400052dd 0053 0024 EQU TWO($24) A1400053dH1 GETACT PAGE 2 DATE: 08/29/84H  d 0054 0046 EQU TEN($46) A1400054dH1 GETACT PAGE 3 DATE: 08/29/84H  d 0056 P0000 0000 GETACR 0 0 RPG ENTRY. A1400056dd 0057 P0001 E8FE LDQ* GETACR A1400057dd 0058 P0002 4875 STQ* RETURN SAVE RETURN ADDRESS. A1400058dd 0059 P0003 5835 RTJ* RPGGET GET PARAMETERS FROM RPG. A1400059dd 0060 P0004 180B JMP* START A1400060d  d 0062 P0005 0000 GETACF 0 0 FTN ENTRY. A1400062dd 0063 P0006 4800 STQ SAVEQ SAVE Q AND I REGISTERS 138*A009A1400063d P0007 012C d 0064 P0008 C0FF LDA- I FOR RETURN. 138*A009A1400064dd 0065 P0009 6800 STA SAVEI 138*A009A1400065d P000A 012A d 0066 P000B E8F9 LDQ* GETACF A1400066dd 0067 P000C 0D04 INQ 4 MOVE TO NEXT EXECUTABLE INSTRUCTION. A1400067dd 0068 P000D 486A STQ* RETURN SAVE RETURN ADDRESS. A1400068dd 0069 P000E 584C RTJ* FTNGET GET PARAMETERS FROM FTN. A1400069d  d 0071 P000F 5800 START RTJ CHKBLK CHECK IF SAME BLOCK AND SET BUFFER POINTER. A1400071d P0010 0098 d 0072 P0011 5800 RTJ BLKSTR BLANK OUT ACTIVITY STRING. A1400072d P0012 00F0 d 0073 P0013 5800 RTJ GETLEN GET LENGTH OF NEXT ACTIVITY STRING IN BUFFER. A1400073d P0014 00D5 d 0074 P0015 C863 LDA* LEN A1400074dd 0075 P0016 0118 SAN MOVEIT SKIP IF STRING PRESENT IN BUFFER. A1400075dd 0076 P0017 0A01 ENA 1 NO STRING IN BUFFER. ALL ACTIVITIES HAVE BEEN A1400076dd 0077 P0018 6864 STA* OSW REMOVED FROM THIS ACTIVITY BLOCK. SET ERROR FLA1400077dd 0078 P0019 0A00 ENA 0 ZERO INTERNAL BUFFER FOR BLOCK CHECK. NEXT CALA1400078dd 0079 P001A 0C27 ENQ 39 TO GETACT WILL TREAT THE BUFFER AS A NEW BUFFEA1400079dd 0080 P001B 6A62 START1 STA* LASACT,Q A1400080dd 0081 DQP *-START1 SKIP IF ALL OF INTERNAL BUFFER ZEROED. A1400081d 0081 P001C 06A1 d 0082 P001D 1800 JMP MOVCMP EXIT. A1400082d P001E 010F d 0083 * SET UP REGISTERS FOR MOVE. A1400083dd 0084 P001F C800 MOVEIT LDA BUFPTR BYTE LOCATION INTO BUFFER OF ACTIVITY TO BE REA1400084d P0020 0087 d 0085 P0021 0901 INA 1 SET TO NEXT CHARACTER PAST TERMINATION CHARACTA1400085dd 0086 P0022 8850 ADD* PARAMS+3 ADD BYTE OFFSET. A1400086dd 0087 XFA 3 SAVE FOR OFFSET CHECKING. A1400087d 0087 P0023 07C3 d 0088 P0024 0F41 ARS 1 GET WORD ADDRESS RELATIVE TO START OF BUFFER. A1400088dd 0089 P0025 884C ADD* PARAMS+2 ADD TO BASE ADDRESS OF BUFFER. A1400089dd 0090 XFA 1 R1 IS SOURCE STRING ADDRESS. A1400090d 0090 P0026 07C1 d 0091 LR2* PARAMS R2 IS DESTINATION STRING ADDRESS. A1400091d 0091 P0027 0482  0091 P0028 C047 d 0092 P0029 C84F LDA* LEN LENGTH OF MOVE IN BYTES. A1400092dd 0093 P002A 0822 TRA Q SOURCE STRING LENGTH = DESTINATION STRING LENGA1400093dd 0094 AN3- ONEBIT CHECK BYTE OFFSET OF SOURCE STRING. A1400094dH1 GETACT PAGE 4 DATE: 08/29/84H   0094 P002B 0403  0094 P002C A023 d 0095 S3Z MOV010-*-1 SKIP IF WORD BOUNDARY. A1400095d 0095 P002D 00C1 d 0096 P002E 8032 ADD- ONEBIT+15 SET FLAG =$8000 TO INDICATE BYTE BOUNDARY. A1400096dd 0097 MOV010 LR3* PARAMS+1 CHECK BYTE OFFSET OF DESTINATION STRING. A1400097d 0097 P002F 0483  0097 P0030 C040 d 0098 S3Z MOV020-*-1 SKIP IF WORD BOUNDARY. A1400098d 0098 P0031 00C1 d 0099 P0032 F032 ADQ- ONEBIT+15 SET FLAG = $8000 TO INDICATE BYTE BOUNDARY. A1400099dd 0100 MOV020 MOV A1400100d 0100 P0033 0F01   d 0102 P0034 0A00 ENA 0 MOVE COMPLETE. SET OSW TO ZERO TO INDICATE A1400102dd 0103 P0035 6847 STA* OSW SATISFACTORY COMPLETION. A1400103dd 0104 P0036 1800 JMP MOVCMP EXIT. A1400104d P0037 00F6 H1 GETACT PAGE 5 DATE: 08/29/84H  d 0106 * PICK UP RPG PARAMETERS - A CONTAINS ADDRESS OF PARAMETER LIST. A1400106dd 0107 * A1400107dd 0108 P0038 0000 RPGGET 0 0 A1400108dd 0109 P0039 6817 STA* PADD SAVE ADDRESS OF PARAMETER LIST. A1400109dd 0110 P003A 0C00 ENQ 0 A1400110dd 0111 XFQ 1 INITIALIZE R1 A1400111d 0111 P003B 07A1 d 0112 P003C 5815 RPG005 RTJ* RPGPAR GET NEXT PARAMETER. A1400112dd 0113 P003D 0111 SAN RPG010 SKIP IF PARAMETER FOUND. A1400113dd 0114 P003E 180D JMP* RPG050 END OF PARAMETER LIST. A1400114dd 0115 RPG010 XFI A I CONTAINS BYTE ADDRESS RELATIVE TO R9BASE. A1400115d 0115 P003F 07E6 d 0116 P0040 0F41 ARS 1 GET WORD ADDRESS RELATIVE TO R9BASE. A1400116dd 0117 P0041 880D ADD* RIBASE ) ADD TO BASE TO GET ABSOLUTE ADDRESS. A1400117dd 0118 SRA* PARAMS,1 STORE INTO PARAMETER LIST, INDEXED BY R1. A1400118d 0118 P0042 048E  0118 P0043 C12C d 0119 XFI A CHECK BYTE OFFSET. A1400119d 0119 P0044 07E6 d 0120 P0045 A023 AND- ONEBIT =0, WORD BOUNDARY. =1, BYTE BOUNDARY. A1400120dd 0121 RPG015 SRA* PARAMS+1,1 STORE INTO NEXT LOCATION IN PARMAETER LIST. A1400121d 0121 P0046 048E  0121 P0047 C129 d 0122 AR1- TWO BUMP INDEX REGISTER. A1400122d 0122 P0048 0401  0122 P0049 8024 d 0123 P004A 18F1 JMP* RPG005 GO GET NEXT PARAMETER. A1400123dd 0124 P004B C804 RPG050 LDA* RBLANK SET BLANK EQUAL TO EBCDIC A1400124dd 0125 P004C 682E STA* BLANKS BLANK = $40. A1400125dd 0126 P004D 1CEA JMP* (RPGGET) RETURN. A1400126d  d 0128 P004E 7FFF X RIBASE ADC R9BASE BASE ADDRESS OF RPG PARAMETERS. A1400128dd 0129 P004F 4040 RBLANK NUM $4040 EBCDIC BLANKS. A1400129dd 0130 P0050 0000 PADD NUM 0 ABSOLUTE ADDRESS OF PARAMETER LIST FOR RPG. A1400130dH1 GETACT PAGE 6 DATE: 08/29/84H  d 0132 P0051 0000 RPGPAR 0 0 PICK UP PARAMETER ADDRESS AND BYTE OFFSET. A1400132dd 0133 P0052 E8FD LDQ* PADD A1400133dd 0134 P0053 C622 LDA- (ZERO),Q PICK UP ADDRESS FROM LIST. A1400134dd 0135 P0054 0900 INA 0 CHECK FOR $FFFF - END OF PARAMETER LIST. A1400135dd 0136 P0055 0103 SAZ RPG500 SKIP IF END OF PARAMETER LIST. A1400136dd 0137 P0056 5400 X RTJ R9FLDL RELATIVE BYTE ADDRESS RETURNED IN I. A1400137d P0057 7FFF X d 0138 P0058 D8F7 RAO* PADD BUMP TO ALLOW RETRIEVAL OF NEXT PARAMETER. A1400138dd 0139 P0059 1CF7 RPG500 JMP* (RPGPAR) RETURN. A1400139dH1 GETACT PAGE 7 DATE: 08/29/84H  d 0141 * PICK UP PARAMETERS FROM FTN. NEXT FOUR LOCATIONS AFTER CALLER A1400141dd 0142 * HAVE THE PARAMETERS. A1400142dd 0143 * A1400143dd 0144 P005A 0000 FTNGET 0 0 A1400144dd 0145 P005B E800 LDQ GETACF ADDRESS OF PARAMETER LIST. A1400145d P005C FFA8 d 0146 P005D 0D03 INQ 3 GO TO END OF LIST. A1400146dd 0147 LR1- SEVEN SET UP INDEX INTO PARAMETER STORAGE. A1400147d 0147 P005E 0401  0147 P005F C005 d 0148 LR2- ZERO INITIALIZE R2. A1400148d 0148 P0060 0402  0148 P0061 C022 d 0149 P0062 C622 FTN010 LDA- (ZERO),Q PICK UP ABSOLUTE ADDRESS OF PARAMETER. A1400149dd 0150 SRA* PARAMS-1,1 STORE INTO PARAMETER STORAGE. A1400150d 0150 P0063 048E  0150 P0064 C10A d 0151 SR2* PARAMS,1 ZERO BYTE OFFSET TO INDICATE WORD BOUNDARY. A1400151d 0151 P0065 048A  0151 P0066 C109 d 0152 P0067 0DFE INQ -1 BUMP TO GET NEXT PARAMETER. A1400152dd 0153 SB1- ONE DECREMENT INDEX INTO PARAMETER STORAGE. A1400153d 0153 P0068 0401  0153 P0069 9003 d 0154 D1P *-FTN010 SKIP IF ALL PARAMETERS PICKED UP. A1400154d 0154 P006A 0628 d 0155 P006B C803 FTN020 LDA* FBLANK SET BLANK EQUAL TO ASCII A1400155dd 0156 P006C 680E STA* BLANKS BLANKS = $20. A1400156dd 0157 P006D 1CEC JMP* (FTNGET) RETURN. A1400157d  d 0159 P006E 2020 FBLANK NUM $2020 ASCII BLANKS. A1400159dH1 GETACT PAGE 8 DATE: 08/29/84H  d 0161 * VARIABLES USED IN THIS PROGRAM. A1400161dd 0162 * A1400162dd 0163 P006F 0000 PARAMS NUM 0 ABSOLUTE ADDRESS OF STRING. A1400163dd 0164 P0070 0000 NUM 0 +1 BYTE OFFSET OF STRING. A1400164dd 0165 P0071 0000 NUM 0 +2 ABSOLUTE ADDRESS OF BUFFER. A1400165dd 0166 P0072 0000 NUM 0 +3 BYTE OFFSET OF BUFFER A1400166dd 0167 P0073 0000 NUM 0 +4 ABSOLUTE ADDRESS OF LENGTH. A1400167dd 0168 P0074 0000 NUM 0 +5 BYTE OFFSET OF LENGTH. A1400168dd 0169 P0075 0000 NUM 0 +6 ABSOLUTE ADDRESS OF OSW. A1400169dd 0170 P0076 0000 NUM 0 +7 BYTE OFFSET OF OSW. A1400170dd 0171 P0077 0000 RETURN NUM 0 RETURN ADDRESS. A1400171dd 0172 P0078 0000 LEN NUM 0 LENGTH OF ACTIVITY STRING. A1400172dd 0173 P0079 00AA TERMIN NUM $AA TERMINATION CHARACTERS OF ACTIVITY STRINGS. A1400173dd 0174 P007A 0000 BLANKS NUM 0 ASCII/EBCDIC BLANKS USED IN PROGRAM. A1400174dd 0175 P007B 0000 LENBUF NUM 0 LENGTH OF BUFFER INPUT. A1400175dd 0176 P007C 0000 OSW NUM 0 LOCAL STATUS WORD CONVERTED ON RETURN. A1400176dd 0177 P007D 0028 LASACT BSS LASACT(40) FIRST 80 BYTES OF LAST ACTIVITY BUFFER PASSED A1400177dd 0178 * GETACT. USED TO SEE IF NEW ACTIVITY BLOCK PASSA1400178dd 0179 P00A5 0050 ACTLEN NUM 80 NUMBER OF BYTES SAVED FROM LAST BLOCK. A1400179dd 0180 P00A6 007D P ADLACT ADC LASACT ADDRESS OF LASACT FOR STRING OPERATIONS. A1400180dd 0181 P00A7 0000 BUFPTR NUM 0 INTERNAL POINTER INTO BUFFER. ON ENTRY, CONTAIA1400181dd 0182 * INDEX INTO THE LAST BUFFER THE LAST ACTIVITY WA1400182dd 0183 * RETRIEVED FROM. ON EXIT, CONTAINS INDEX INTO A1400183dd 0184 * BUFFER OF CURRENT ACTIVITY RETRIEVED. A1400184dH1 GETACT PAGE 9 DATE: 08/29/84H  d 0186 * ROUTINE TO CHECK IF CURRENT BLOCK EQUALS LAST BLOCK. IF YES, USE A1400186dd 0187 * THE POINTER STORED UPON LAST EXIT OF PROGRAM. IF NO, SET POINTER A1400187dd 0188 * TO THE END OF THE CURRRENT BLOCK. A1400188dd 0189 * A1400189dd 0190 P00A8 0000 CHKBLK 0 0 A1400190dd 0191 P00A9 C8CC LDA* PARAMS+7 PICK UP OFFSET OF OSW. CHECK OSW FOR '01'. A1400191dd 0192 P00AA 0901 INA 1 INDICATING RESET TO RETREIVE ACTIVITIES FROM A1400192dd 0193 XFA 1 START OF THIS BLOCK. A1400193d 0193 P00AB 07C1 d 0194 LCA* (PARAMS+6),1 PICK UP SECOND BYTE OF OSW. A1400194d 0194 P00AC 04C1  0194 P00AD C2C7 d 0195 P00AE A023 AND- ONEBIT+0 CHECK FOR 1. A1400195dd 0196 P00AF 011E SAN CHK300 SKIP IF RESET SELECTED. A1400196dd 0197 LR1* ADLACT SOURCE STRING 1 FOR COMPARISON. A1400197d 0197 P00B0 0481  0197 P00B1 C0F4 d 0198 LR2* PARAMS+2 SOURCE STRING 2 FOR COMPARISON. A1400198d 0198 P00B2 0482  0198 P00B3 C0BD d 0199 P00B4 C8F0 LDA* ACTLEN LENGTH OF STRING FOR COMPARISON. A1400199dd 0200 P00B5 0822 TRA Q STRING LENGTHS ARE EQUAL. A1400200dd 0201 LR3* PARAMS+3 BYTE OFFSET FOR BUFFER. A1400201d 0201 P00B6 0483  0201 P00B7 C0BA d 0202 S3Z CHK010-*-1 SKIP IF WORD BOUNDARY. A1400202d 0202 P00B8 00C1 d 0203 P00B9 F032 ADQ- ONEBIT+15 SET FLAG TO $8000 TO INDICATE BYTE BOUNDARY. A1400203dd 0204 CHK010 SEQ A1400204d 0204 P00BA 0F02 d 0205 P00BB 1803 JMP* CHK300 STRINGS NOT EQUAL. A1400205dd 0206 P00BC C8EA LDA* BUFPTR STRINGS EQUAL. POINTER EQUALS VALUE SAVED. A1400206dd 0207 P00BD 180F JMP* CHK500 A1400207dd 0208 P00BE 5811 CHK300 RTJ* BUFLEN STRINGS NOT EQUAL. GO PICKUP LENGTH. A1400208dd 0209 LR1* PARAMS+2 MOVE IN FIRST 80 BYTES OF CURRENT BUFFER INTO A1400209d 0209 P00BF 0481  0209 P00C0 C0B0 d 0210 LR2* ADLACT LASACT. R1 IS SOURCE ADDRESS. R2 IS DEST. ADD.A1400210d 0210 P00C1 0482  0210 P00C2 C0E3 d 0211 P00C3 C8E1 LDA* ACTLEN LENGTH OF MOVE. A1400211dd 0212 P00C4 0822 TRA Q SOURCE STRING LENGTH = DESTINATION STRING LENGA1400212dd 0213 LR3* PARAMS+3 BYTE OFFSET FOR BUFFER. A1400213d 0213 P00C5 0483  0213 P00C6 C0AB d 0214 S3Z CHK400-*-1 SKIP IF WORD BOUNDARY. A1400214d 0214 P00C7 00C1 d 0215 P00C8 8032 ADD- ONEBIT+15 SET FLAG TO $8000 TO INDICATE BYTE BOUNDARY. A1400215dd 0216 CHK400 MOV A1400216d 0216 P00C9 0F01 d 0217 P00CA C8B0 LDA* LENBUF SET POINTER TO END OF A1400217dd 0218 P00CB 09FE INA -1 NEW BUFFER INPUT. A1400218dd 0219 P00CC 09FE CHK500 INA -1 SKIP OVER TERMINATON CHARACTER POINTER IS NOW A1400219dH1 GETACT PAGE 10 DATE: 08/29/84H  d 0220 P00CD 68D9 STA* BUFPTR SAVE IN POINTER. A1400220dd 0221 P00CE 1CD9 JMP* (CHKBLK) RETURN. A1400221dH1 GETACT PAGE 11 DATE: 08/29/84H  d 0223 * EXTRACT LENGTH OF BUFFER. A1400223dd 0224 * A1400224dd 0225 P00CF 0000 BUFLEN 0 0 A1400225dd 0226 P00D0 0A00 ENA 0 A1400226dd 0227 P00D1 68A9 STA* LENBUF ZERO BUFFER LENGTH. A1400227dd 0228 LR1* PARAMS+5 R1 IS BYTE INDEX INTO LENGTH PARAMETER. A1400228d 0228 P00D2 0481  0228 P00D3 C0A0 d 0229 P00D4 C814 LDA* THOUS A1400229dd 0230 P00D5 6812 BUF010 STA* BUMULT STORE MULTIPLIER. A1400230dd 0231 LCA (PARAMS+4),1 PICK UP NEXT NUMBER FROM LENGTH. A1400231d 0231 P00D6 04C1  0231 P00D7 C200  0231 P00D8 FF9A d 0232 P00D9 A006 AND- LPMASK+4 EXTRACT NUMERIC VALUE. A1400232dd 0233 P00DA 280D MUI* BUMULT MULTIPLY TO GET VALUE. A1400233dd 0234 P00DB 8800 ADD LENBUF ADD TO BUFFER LENGTH. A1400234d P00DC FF9E d 0235 P00DD 6800 STA LENBUF A1400235d P00DE FF9C d 0236 P00DF C808 LDA* BUMULT GET NEXT MULTIPLIER. A1400236dd 0237 P00E0 0C00 ENQ 0 ZERO MSB OF DIVIDEND. A1400237dd 0238 P00E1 3046 DVI- TEN A1400238dd 0239 P00E2 0103 SAZ BUF500 BUFFER LENGTH EXTRACTED. SKIP FOR RETURN. A1400239dd 0240 AR1- ONE INCREMENT BYTE INDEX. A1400240d 0240 P00E3 0401  0240 P00E4 8003 d 0241 P00E5 18EF JMP* BUF010 GET NEXT NUMBER. A1400241dd 0242 P00E6 1CE8 BUF500 JMP* (BUFLEN) RETURN. A1400242d  d 0244 P00E7 0000 BUMULT NUM 0 MULTIPLIER OF CURRENT NUMBER FOR DECIMAL CONV.A1400244dd 0245 P00E8 03E8 THOUS NUM 1000 NUMERIC VALUE 1000. A1400245dH1 GETACT PAGE 12 DATE: 08/29/84H  d 0247 * SCAN ACTIVITY BUFFER BACKWARDS STARTING AT BUFPTR FOR TERMINATIONA1400247dd 0248 * CHARACTER OF NEXT ACTIVITY. SAVE THE LENGTH OF THE ACTIVITY. IF A1400248dd 0249 * NO TERMINATION CHARACTER IS FOUND, ALL ACTIVITIES HAVE BEEN REPORA1400249dd 0250 * FOR THIS BUFFER. SET FLAG TO REPORT THIS CONDITION. A1400250dd 0251 * A1400251dd 0252 P00E9 0000 GETLEN 0 0 A1400252dd 0253 P00EA C8BC LDA* BUFPTR POINTER IN BUFFER. A1400253dd 0254 P00EB 8800 ADD PARAMS+3 BYTE OFFSET. POINTER REFLECTS BYTES INTO BUFFEA1400254d P00EC FF85 d 0255 XFA 1 A1400255d 0255 P00ED 07C1 d 0256 GETL01 LCA (PARAMS+2),1 GET NEXT CHARACTER. A1400256d 0256 P00EE 04C1  0256 P00EF C200  0256 P00F0 FF80 d 0257 P00F1 B800 EOR TERMIN CHECK FOR TERMINATION CHARACTER. A1400257d P00F2 FF86 d 0258 P00F3 0103 SAZ GETL02 SKIP IF TERMINATION CHARACTER FOUND. A1400258dd 0259 D1P *-GETL01 SKIP IF ALL OF BUFFER BELOW BUFPTR SEARCHED. A1400259d 0259 P00F4 0626 d 0260 P00F5 0A00 ENA 0 ERROR - ALL ACTIVITIES REPORTED. NEED NEW BLOCA1400260dd 0261 P00F6 1809 JMP* GETL03 A1400261dd 0262 GETL02 SB1 PARAMS+3 SUBTRACT BYTE OFFSET TO GET ABSOLUTE POINTER. A1400262d 0262 P00F7 0481  0262 P00F8 9000  0262 P00F9 FF78 d 0263 XF1 A R1 IS STARTING BYTE-1 OF ACTIVITY TO REMOVE A1400263d 0263 P00FA 0726 d 0264 P00FB 0864 TCA A COMPLEMENT TO GET NEGATIVE VALUE. A1400264dd 0265 P00FC 88AA ADD* BUFPTR BUFPTR IS ENDING BYTE OF ACTIVITY TO BE REMOVEA1400265dd 0266 * RESULT IS LENGTH OF ACTIVITY FOR MOVE. A1400266dd 0267 SR1* BUFPTR STORE NEW VALUE OF BUFPTR. A1400267d 0267 P00FD 0481  0267 P00FE C1A8 d 0268 P00FF 6800 GETL03 STA LEN SAVE LENGTH OF MOVE. A1400268d P0100 FF77 d 0269 P0101 1CE7 JMP* (GETLEN) RETURN. A1400269dH1 GETACT PAGE 13 DATE: 08/29/84H  d 0271 * ROUTINE TO BLANK THE ACTIVITY STRING TO RECEIVE THE ACTIVITY. A1400271dd 0272 * A1400272dd 0273 P0102 0000 BLKSTR 0 0 A1400273dd 0274 P0103 C800 LDA BLANKS A1400274d P0104 FF75 d 0275 P0105 A00A AND- LPMASK+8 STORE ONLY A CHARACTER AT A TIME. A1400275dd 0276 P0106 0C47 ENQ 71 START AT END OF BUFFER. A1400276dd 0277 P0107 F800 ADQ PARAMS+1 BYTE OFFSET. A1400277d P0108 FF67 d 0278 XFQ 1 A1400278d 0278 P0109 07A1 d 0279 BLK010 SCA (PARAMS),1 A1400279d 0279 P010A 04C1  0279 P010B C300  0279 P010C FF62 d 0280 D1P *-BLK010 SKIP IF ALL OF STRING BLANKED. A1400280d 0280 P010D 0623 d 0281 P010E 1CF3 JMP* (BLKSTR) RETURN. A1400281dH1 GETACT PAGE 14 DATE: 08/29/84H  d 0283 * CONVERT RETURN VALUE OF STATUS WORD INTO ASCII/EBCDIC VALUE. A1400283dd 0284 * A1400284dd 0285 P010F 0000 CONOSW 0 0 A1400285dd 0286 P0110 0C00 ENQ 0 A1400286dd 0287 P0111 C800 LDA BLANKS GET CONVERSION CHARACTER - ASCII OR EBCDIC. A1400287d P0112 FF67 d 0288 P0113 B800 EOR FBLANK IF FBLANK, RETURN IN ASCII. A1400288d P0114 FF59 d 0289 P0115 0102 SAZ CON010 SKIP IF FTN CALLER FOR ASCII CONVERSION. A1400289dd 0290 P0116 0D60 INQ $60 RPG CALLER, RETURN IN EBCDIC. A1400290dd 0291 P0117 0D60 INQ $60 A1400291dd 0292 P0118 0D30 CON010 INQ $30 A1400292dd 0293 P0119 4813 STQ* CONCHR SAVE THE CONVERSION CHARACTER. A1400293dd 0294 LR4 OSW SAVE OSW IN R4. A1400294d 0294 P011A 0484  0294 P011B C000  0294 P011C FF5F d 0295 LR1 PARAMS+7 SET BYTE OFFSET. A1400295d 0295 P011D 0481  0295 P011E C000  0295 P011F FF56 d 0296 P0120 C80C LDA* CONCHR PICK UP CONVERSION CHARCTER (=ASCII/EBCDIC 0).A1400296dd 0297 SCA (PARAMS+6),1 STORE ZERO INTO BYTE TWO OF OSW. A1400297d 0297 P0121 04C1  0297 P0122 C300  0297 P0123 FF51 d 0298 AR1- ONE INCREMENT BYTE INDEX. A1400298d 0298 P0124 0401  0298 P0125 8003 d 0299 S4Z CON600-*-1 SKIP IF NO ERROR TO REPORT. A1400299d 0299 P0126 0001 d 0300 P0127 0901 INA 1 SET FLAG IF ERROR - ALL ACTIVITIES FROM THIS A1400300dd 0301 * BUFFER REPORTED. A1400301dd 0302 CON600 SCA (PARAMS+6),1 STORE FLAG INTO BYTE 1. A1400302d 0302 P0128 04C1  0302 P0129 C300  0302 P012A FF4A d 0303 P012B 1CE3 JMP* (CONOSW) RETURN. A1400303d  d 0305 P012C 0000 CONCHR NUM 0 CONVERSION VALUE TO GET NUMERIC. $30 IN ASCIIA1400305dd 0306 * $F0 IN EBCDIC. A1400306dH1 GETACT PAGE 15 DATE: 08/29/84H  d 0308 * REQUEST PROCESSED. CONVERT STATUS WORD INTO TWO BYTES ASCII/EBCDIA1400308dd 0309 * AND RETURN. A1400309dd 0310 * A1400310dd 0311 P012D 58E1 MOVCMP RTJ* CONOSW CONVERT STATUS WORD. A1400311dd 0312 P012E C806 LDA* SAVEI RESTORE Q AND I REGISTERS 138*A009A1400312dd 0313 P012F 60FF STA- I IN CASE OF RETURN TO FORTRAN 138*A009A1400313dd 0314 P0130 E803 LDQ* SAVEQ CALLER. NO EFFECT ON RETURN TO 138*A009A1400314dd 0315 * RPG CALLER. 138*A009A1400315dd 0316 P0131 1C00 JMP (RETURN) RETURN TO CALLER. A1400316d P0132 FF44  d 0318 P0133 0000 SAVEQ NUM 0 Q AND I REGISTER SAVE. 138*A009A1400318dd 0319 P0134 0000 SAVEI NUM 0 138*A009A1400319d d 0321 END END OF PROGRAM. A1400321d  D PGM= 0135 ( 309) COM = 0000 ( 0) DAT = 0000 ( 0) D H1 GETACT PAGE 16 DATE: 08/29/84H     E Q U I V A L E N C E S -----------------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0000 I 00FF (000255) 0064, 0313 HH 0048 LPMASK 0002 (000002) 0232, 0275 HH 0049 ONE 0003 (000003) 0153, 0153, 0240, 0240, 0298, 0298HH 0050 SEVEN 0005 (000005) 0147, 0147 HH 0051 ZERO 0022 (000034) 0134, 0148, 0148, 0149 HH 0052 ONEBIT 0023 (000035) 0094, 0094, 0096, 0099, 0120, 0195HH 0203, 0215 HH 0053 TWO 0024 (000036) 0122, 0122 HH 0054 TEN 0046 (000070) 0238 HH1 GETACT PAGE 17 DATE: 08/29/84H     S Y M B O L S -------------  B DEF.LINE NAME ADDRESS REFERENCED AT LINE NUMBER B H 0043 GETACR 0000 0043, 0057 HH 0044 GETACF 0005 0044, 0066, 0145 HH 0071 START 000F 0060 HH 0080 START1 001B 0081, 0081, 0081, 0081 HH 0084 MOVEIT 001F 0075 HH 0097 MOV010 002F 0095, 0095, 0095 HH 0100 MOV020 0033 0098, 0098, 0098 HH 0108 RPGGET 0038 0059, 0126 HH 0112 RPG005 003C 0123 HH 0115 RPG010 003F 0113 HH 0121 RPG015 0046 HH 0124 RPG050 004B 0114 HH 0128 RIBASE 004E 0117 HH 0129 RBLANK 004F 0124 HH 0130 PADD 0050 0109, 0133, 0138 HH 0132 RPGPAR 0051 0112, 0139 HH 0139 RPG500 0059 0136 HH 0144 FTNGET 005A 0069, 0157 HH 0149 FTN010 0062 0154, 0154, 0154, 0154 HH 0155 FTN020 006B HH 0159 FBLANK 006E 0155, 0288 HH 0163 PARAMS 006F 0086, 0089, 0091, 0091, 0091, 0097HH 0097, 0097, 0118, 0118, 0118, 0121HH 0121, 0121, 0150, 0150, 0150, 0151HH 0151, 0151, 0191, 0194, 0194, 0194HH 0198, 0198, 0198, 0201, 0201, 0201HH 0209, 0209, 0209, 0213, 0213, 0213HH 0228, 0228, 0228, 0231, 0254, 0256HH 0262, 0277, 0279, 0295, 0297, 0302HH 0171 RETURN 0077 0058, 0068, 0316 HH 0172 LEN 0078 0074, 0092, 0268 HH 0173 TERMIN 0079 0257 HH 0174 BLANKS 007A 0125, 0156, 0274, 0287 HH 0175 LENBUF 007B 0217, 0227, 0234, 0235 HH 0176 OSW 007C 0077, 0103, 0294 HH 0177 LASACT 007D 0080, 0180 HH 0179 ACTLEN 00A5 0199, 0211 HH 0180 ADLACT 00A6 0197, 0197, 0197, 0210, 0210, 0210HH 0181 BUFPTR 00A7 0084, 0206, 0220, 0253, 0265, 0267HH 0267, 0267 HH 0190 CHKBLK 00A8 0071, 0221 HH1 GETACT PAGE 18 DATE: 08/29/84H  H 0204 CHK010 00BA 0202, 0202, 0202 HH 0208 CHK300 00BE 0196, 0205 HH 0216 CHK400 00C9 0214, 0214, 0214 HH 0219 CHK500 00CC 0207 HH 0225 BUFLEN 00CF 0208, 0242 HH 0230 BUF010 00D5 0241 HH 0242 BUF500 00E6 0239 HH 0244 BUMULT 00E7 0230, 0233, 0236 HH 0245 THOUS 00E8 0229 HH 0252 GETLEN 00E9 0073, 0269 HH 0256 GETL01 00EE 0259, 0259, 0259, 0259 HH 0262 GETL02 00F7 0258 HH 0268 GETL03 00FF 0261 HH 0273 BLKSTR 0102 0072, 0281 HH 0279 BLK010 010A 0280, 0280, 0280, 0280 HH 0285 CONOSW 010F 0303, 0311 HH 0292 CON010 0118 0289 HH 0302 CON600 0128 0299, 0299, 0299 HH 0305 CONCHR 012C 0293, 0296 HH 0311 MOVCMP 012D 0082, 0104 HH 0318 SAVEQ 0133 0063, 0314 HH 0319 SAVEI 0134 0065, 0312 HH1 GETACT PAGE 19 DATE: 08/29/84H     E X T E R N A L S -----------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0046 R9FLDL 0057 0137 HH 0047 R9BASE 004E 0128 HH1 GETACT PAGE 20 DATE: 08/29/84H  > *** A L P H A B E T I C A L S O R T O F S Y M B O L S *** >  H ACTLEN 0179 ADLACT 0180 BLANKS 0174 BLK010 0279 BLKSTR 0273 HH BUF010 0230 BUF500 0242 BUFLEN 0225 BUFPTR 0181 BUMULT 0244 HH CHK010 0204 CHK300 0208 CHK400 0216 CHK500 0219 CHKBLK 0190 HH CON010 0292 CON600 0302 CONCHR 0305 CONOSW 0285 FBLANK 0159 HH FTN010 0149 FTN020 0155 FTNGET 0144 GETACF 0044 GETACR 0043 HH GETL01 0256 GETL02 0262 GETL03 0268 GETLEN 0252 I 0000 HH LASACT 0177 LEN 0172 LENBUF 0175 LPMASK 0048 MOV010 0097 HH MOV020 0100 MOVCMP 0311 MOVEIT 0084 ONE 0049 ONEBIT 0052 HH OSW 0176 PADD 0130 PARAMS 0163 R9BASE 0047 R9FLDL 0046 HH RBLANK 0129 RETURN 0171 RIBASE 0128 RPG005 0112 RPG010 0115 HH RPG015 0121 RPG050 0124 RPG500 0139 RPGGET 0108 RPGPAR 0132 HH SAVEI 0319 SAVEQ 0318 SEVEN 0050 START 0071 START1 0080 HH TEN 0054 TERMIN 0173 THOUS 0245 TWO 0053 ZERO 0051 HH HP1 PH1 ICCSAD PAGE 1 DATE: 08/29/84H  d 0001 NAM ICCSAD A15 A CCS CCS 3.0 SL-149A1500001dd 0002 * A1500002dd 0003 * A1500003dd 0004 * CYBERCREDIT SYSTEM VERSION 3 A1500004dd 0005 * DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA A1500005dd 0006 * COPYRIGHT CONTROL DATA CORPORATION, 1979 A1500006dd 0007 * A1500007dd 0008 * CONVERT ASCII REPRENSENTATION OF DECIMAL NUMBER. A1500008dd 0009 * A1500009dd 0010 * INTEGER FUNCTION TO CONVERT A ONE WORD ASCII REPRESENTATION OF A A1500010dd 0011 * DECIMAL NUMBER TO A NUMBER. A1500011dd 0012 * CALLING SEQUENCE: A1500012dd 0013 * VARIABLE =ICCSAD(NUM) A1500013dd 0014 * WHERE NUM IS THE NUMBER TO BE CONVERTED. A1500014dd 0015 * *****NOTE: THE CONTENTS OF THE PARAMETER PASSED ARE NOT ALTERED. A1500015dd 0016 * A1500016d  d 0018 ENT ICCSAD A1500018d d 0020 * COMMUNICATIONS REGION USED. A1500020dd 0021 0002 EQU LPMASK($2) A1500021dd 0022 0022 EQU ZERO($22) A1500022dd 0023 0046 EQU TEN($46) A1500023d  d 0025 P0000 0000 ICCSAD 0 0 A1500025d d 0027 * SAVE REGISTERS A1500027dd 0028 P0001 4819 STQ* SAVEQ A1500028dd 0029 P0002 C0FF LDA- I A1500029dd 0030 P0003 6818 STA* SAVEI A1500030d d 0032 P0004 E8FB LDQ* ICCSAD PICK UP ADDRESS OF PARAMETER LIST. A1500032dd 0033 P0005 C622 LDA- (ZERO),Q PICK UP ADDRESS OF PARAMETER. A1500033dd 0034 P0006 6813 STA* NUM SAVE PARAMETER ADDRESS. A1500034dd 0035 P0007 0D01 INQ 1 MOVE RETURN ADDRESS TO NEXT EXECUTABLE INSTRUCA1500035dd 0036 P0008 48F7 STQ* ICCSAD SAVE RETURN ADDRESS. A1500036dd 0037 P0009 0C00 ENQ 0 ZERO BYTE INDEX INTO NUM. A1500037dd 0038 LCA* (NUM),Q PICK UP LEFT BYTE OF NUMBER. A1500038d 0038 P000A 04C5  0038 P000B C20E d 0039 P000C A006 AND- LPMASK+4 CONVERT TO A NUMBER. A1500039dd 0040 P000D 2046 MUI- TEN MULTIPLY SINCE NUMBER REPRESENTS TENS. A1500040dd 0041 P000E 60FF STA- I SAVE IN I. A1500041dd 0042 P000F 0C01 ENQ 1 SET Q TO RETRIEVE RIGHT BYTE OF NUMBER. A1500042dd 0043 LCA* (NUM),Q RETRIEVE RIGHT BYTE. A1500043d 0043 P0010 04C5  0043 P0011 C208 d 0044 P0012 A006 AND- LPMASK+4 CONVERT TO A NUMBER. A1500044dd 0045 P0013 E0FF LDQ- I RECALL TENS. A1500045dd 0046 P0014 0834 AAQ A ADD TO GET FULLY CONVERTED NUMBER. A1500046d H1 ICCSAD PAGE 2 DATE: 08/29/84H  d 0048 * RESTORE REGISTERS. A1500048dd 0049 P0015 E806 LDQ* SAVEI A1500049dd 0050 P0016 40FF STQ- I A1500050dd 0051 P0017 E803 LDQ* SAVEQ A1500051dd 0052 P0018 1CE7 JMP* (ICCSAD) RETURN. A1500052d d 0054 * PARAMETER STORAGE. A1500054dd 0055 P0019 0000 NUM NUM 0 ABSOLUTE ADDRESS OF NUMBER TO CONVERT. A1500055dd 0056 P001A 0000 SAVEQ NUM 0 A1500056dd 0057 P001B 0000 SAVEI NUM 0 A1500057d d 0059 END A1500059d  D PGM= 001C ( 28) COM = 0000 ( 0) DAT = 0000 ( 0) D H1 ICCSAD PAGE 3 DATE: 08/29/84H     E Q U I V A L E N C E S -----------------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0000 I 00FF (000255) 0029, 0041, 0045, 0050 HH 0021 LPMASK 0002 (000002) 0039, 0044 HH 0022 ZERO 0022 (000034) 0033 HH 0023 TEN 0046 (000070) 0040 HH1 ICCSAD PAGE 4 DATE: 08/29/84H     S Y M B O L S -------------  B DEF.LINE NAME ADDRESS REFERENCED AT LINE NUMBER B H 0018 ICCSAD 0000 0018, 0032, 0036, 0052 HH 0055 NUM 0019 0034, 0038, 0038, 0038, 0043, 0043HH 0043 HH 0056 SAVEQ 001A 0028, 0051 HH 0057 SAVEI 001B 0030, 0049 HH1 ICCSAD PAGE 5 DATE: 08/29/84H  > *** A L P H A B E T I C A L S O R T O F S Y M B O L S *** >  H I 0000 ICCSAD 0018 LPMASK 0021 NUM 0055 SAVEI 0057 HH SAVEQ 0056 TEN 0023 ZERO 0022 HP1 PH1 PGGEN PAGE 1 DATE: 08/29/84H  d 0001 NAM PGGEN A16 A CCS CCS 3.0 SL-149A1600001dd 0002 * A1600002dd 0003 * CYBERCREDIT SYSTEM VERSION 3 A1600003dd 0004 * DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA A1600004dd 0005 * COPYRIGHT CONTROL DATA CORPORATION, 1979 A1600005dd 0006 * A1600006dd 0007 * A1600007dd 0008 * DUMMY PROGRAM TO JUMP AROUND LABELED COMMON A1600008dd 0009 * A1600009dd 0010 ENT PGGEN A1600010dd 0011 EXT PGGEN0 A1600011dd 0012 P0000 1400 X PGGEN JMP PGGEN0 JUMP TO FORTRAN MAIN MODULE A1600012d P0001 7FFF X d 0013 END A1600013d  D PGM= 0002 ( 2) COM = 0000 ( 0) DAT = 0000 ( 0) D H1 PGGEN PAGE 2 DATE: 08/29/84H     E Q U I V A L E N C E S -----------------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0000 I 00FF (000255) HH1 PGGEN PAGE 3 DATE: 08/29/84H     S Y M B O L S -------------  B DEF.LINE NAME ADDRESS REFERENCED AT LINE NUMBER B H 0010 PGGEN 0000 0010 HH1 PGGEN PAGE 4 DATE: 08/29/84H     E X T E R N A L S -----------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0011 PGGEN0 0001 0012 HH1 PGGEN PAGE 5 DATE: 08/29/84H  > *** A L P H A B E T I C A L S O R T O F S Y M B O L S *** >  H I 0000 PGGEN 0010 PGGEN0 0011 HP1 PH1 PUTACT PAGE 1 DATE: 08/29/84H  d 0001 NAM PUTACT A17 A CCS CCS 3.0 SL-149A1700001dd 0002 * A1700002dd 0003 * A1700003dd 0004 * CYBERCREDIT SYSTEM VERSION 3 A1700004dd 0005 * DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA A1700005dd 0006 * COPYRIGHT CONTROL DATA CORPORATION, 1979 A1700006dd 0007 * A1700007dd 0008 * PUT ACTIVITY STRING INTO ACTIVITY BUFFER. A1700008dd 0009 * A1700009dd 0010 * CALLING SEQUENCE: A1700010dd 0011 * FTN CALL PUTACF(STRING,BUFFER,LENGTH,OSW) A1700011dd 0012 * RPG EXIT PUTACR A1700012dd 0013 * RLABL STRING A1700013dd 0014 * RLABL BUFFER A1700014dd 0015 * RLABL LENGTH A1700015dd 0016 * RLABL OSW A1700016dd 0017 * A1700017dd 0018 * PARAMETER DEFINITONS: A1700018dd 0019 * STRING - THE ACTIVITY STRING DEFINED AS FOLLOWS: A1700019dd 0020 * ACTIVITY DATE - MMDDYY (6 BYTES) A1700020dd 0021 * ACTION CODE (2 BYTES) A1700021dd 0022 * RESULT CODE (2 BYTES) A1700022dd 0023 * LETTER CODE (2 BYTES) A1700023dd 0024 * COLLECTOR ID (4 BYTES) A1700024dd 0025 * COMMENTS (56 BYTES BLANK FILLED IF NECESSARY) A1700025dd 0026 * BUFFER - THE BUFFER TO RECEIVE THE COMPACTED ACTIVITY. A1700026dd 0027 * LENGTH - THE LENGTH OF THE BUFFER PASSED AS A 4 BYTE A1700027dd 0028 * ASCII/EBCDIC FIELD CONTAINING THE NUMBER OF BYTES A1700028dd 0029 * IN THE BUFFER. A1700029dd 0030 * OSW - THE OPERATOR/STATUS WORD. ON ENTRY, OSW HAS THE A1700030dd 0031 * FOLLOWING MEANING: A1700031dd 0032 * = 0 INDICATES THE STRING IS NOT TO BE FORCED. A1700032dd 0033 * INTO THE BUFFER. A1700033dd 0034 * = 1 INDICATES STRING IS TO BE FORCED INTO A1700034dd 0035 * THE BUFFER, DISCARDING THE OLDEST A1700035dd 0036 * ACTIVITY IF NECESSARY. A1700036dd 0037 * ON RETURN, OSW HAS MEANING ONLY FOR A NON-FORCING REQUEA1700037dd 0038 * RETURNED VALUES (IN ASCII/EBCDIC) ARE: A1700038dd 0039 * = 0 REQUEST COMPLETED. ENOUGH SPACE AVAILABLE A1700039dd 0040 * IN THE BUFFER TO PERFORM REQUEST. A1700040dd 0041 * = 1 REQUEST REJECTED. NOT ENOUGH SPACE AVAILABA1700041dd 0042 * IN THE BUFFER TO PERFORM REQUEST. A1700042dd 0043 * A1700043dd 0044 * A1700044dd 0045 MOV MAC A1700045dd 0046 VFD N4/0,N4/$F,N3/0,N5/1 MOVE STRING REQUEST A1700046dd 0047 EMC MOV A1700047dd 0048 * A1700048dd 0049 ENT PUTACR ENTRY POINT FOR RPG CALLERS. A1700049dd 0050 ENT PUTACF ENTRY POINT FOR FTN CALLERS. A1700050dd 0051 * A1700051dd 0052 EXT R9FLDL PICKS UP ADDRESS OF RPG PARAMETERS. A1700052dd 0053 EXT R9BASE BASE ADDRESS OF RPG PARAMETERS. A1700053dH1 PUTACT PAGE 2 DATE: 08/29/84H  d 0054 0002 EQU LPMASK($2) COMMUNICATIONS REGIONS USED. A1700054dd 0055 0003 EQU ONE($3) A1700055dd 0056 0005 EQU SEVEN($5) A1700056dd 0057 0022 EQU ZERO($22) A1700057dd 0058 0023 EQU ONEBIT($23) A1700058dd 0059 0024 EQU TWO($24) A1700059dd 0060 0046 EQU TEN($46) A1700060dH1 PUTACT PAGE 3 DATE: 08/29/84H  d 0062 P0000 0000 PUTACR 0 0 RPG ENTRY. A1700062dd 0063 P0001 E8FE LDQ* PUTACR A1700063dd 0064 P0002 4800 STQ RETURN SAVE RETURN ADDRESS. A1700064d P0003 00E7 d 0065 P0004 5800 RTJ RPGGET GET PARAMETERS FROM RPG. A1700065d P0005 00A6 d 0066 P0006 180D JMP* START A1700066d  d 0068 P0007 0000 PUTACF 0 0 FTN ENTRY. A1700068dd 0069 P0008 4800 STQ SAVEQ SAVE Q AND I REGISTERS 138*A009A1700069d P0009 017B d 0070 P000A C0FF LDA- I FOR RETURN. 138*A009A1700070dd 0071 P000B 6800 STA SAVEI 138*A009A1700071d P000C 0179 d 0072 P000D E8F9 LDQ* PUTACF A1700072dd 0073 P000E 0D04 INQ 4 MOVE TO NEXT EXECUTABLE INSTRUCTION. A1700073dd 0074 P000F 4800 STQ RETURN SAVE RETURN ADDRESS. A1700074d P0010 00DA d 0075 P0011 5800 RTJ FTNGET GET PARAMETERS FROM FTN. A1700075d P0012 00BB   d 0077 P0013 5800 START RTJ BUFLEN RETRIEVE LENGTH OF BUFFER. A1700077d P0014 00DE d 0078 P0015 5800 RTJ GETLEN GET LENGTH OF ACTIVITY STRING. A1700078d P0016 00F2 d 0079 P0017 5800 RTJ AVBYTE RETRIEVE BYTE SPACE AVAILABLE IN BUFFER. A1700079d P0018 0107 d 0080 P0019 C800 LDA BYTEAV NUMBER OF BYTES AVAILABLE. A1700080d P001A 00D2 d 0081 P001B 9800 SUB LEN SUBTRACT LENGTH OF STRING. A1700081d P001C 00CF d 0082 P001D 0131 SAM FORCHK SKIP IF NO ROOM AVAILABLE. A1700082dd 0083 P001E 184F JMP* MOVER ROOM AVAILABLE - PERFORM THE REQUEST. A1700083d  d 0085 P001F 0A01 FORCHK ENA 1 NO SPACE AVAILABLE - SEE IF A FORCE REQUEST. A1700085dd 0086 P0020 8800 ADD PARAMS+7 BYTE OFFSET FOR OSW. A1700086d P0021 00C8 d 0087 XFA 1 A1700087d 0087 P0022 07C1 d 0088 LCA (PARAMS+6),1 PICK UP BYTE 1 (RIGHTMOST) OF OSW. A1700088d 0088 P0023 04C1  0088 P0024 C200  0088 P0025 00C3 d 0089 P0026 A003 AND- LPMASK+1 =1 MEANS FORCE. A1700089dd 0090 P0027 0115 SAN MOVEF SKIP IF FORCE REQUEST. A1700090dd 0091 P0028 0A01 ENA 1 NON-FORCE REQUEST WITH INSUFFICIENT ROOM. A1700091dd 0092 P0029 6800 STA OSW SET OSW TO 1 (ERROR). A1700092d P002A 00C7 d 0093 P002B 1800 JMP MOVCMP MOVE ABORTED. A1700093d P002C 0152 H1 PUTACT PAGE 4 DATE: 08/29/84H  d 0095 * MOVEF - FORCE REQUEST CAUSING DELETION OF OLDEST ACTIVITY. A1700095dd 0096 * A1700096dd 0097 P002D C800 MOVEF LDA BYTEAV RECALCULATE BYTES AVAILABLE FOR ANY SUBSEQUENTA1700097d P002E 00BE d 0098 * REQUEST. A1700098dd 0099 P002F 0904 INA 4 EQUALS FIRST BYTE OF LAST ACTIVITY. A1700099dd 0100 P0030 8800 ADD PARAMS+3 SET BYTE OFFSET. SEARCH FOR END A1700100d P0031 00B4 d 0101 XFA 1 OF LAST ACTIVITY. A1700101d 0101 P0032 07C1 d 0102 MOVEF1 LCA (PARAMS+2),1 PICK UP NEXT CHARACTER FROM BUFFER. A1700102d 0102 P0033 04C1  0102 P0034 C200  0102 P0035 00AF d 0103 P0036 B800 EOR TERMIN SEE IF IT IS ACTIVITY TERMINATION CHARACTER. A1700103d P0037 00B6 d 0104 P0038 0103 SAZ MOVEF2 SKIP IF TERMINATION CHARACTER. A1700104dd 0105 AR1- ONE INCREMENT TO NEXT CHARACTER. A1700105d 0105 P0039 0401  0105 P003A 8003 d 0106 P003B 18F7 JMP* MOVEF1 A1700106dd 0107 MOVEF2 XF1 A R1 CONTAINS THE BYTE INDEX TO NEXT ACTIVITY INA1700107d 0107 P003C 0726 d 0108 P003D 09FB INA -4 SUBTRACT THE 4 RESERVED BYTES. A1700108dd 0109 P003E 9800 SUB LEN SUBTRACT LENGTH OF NEW STRING. A1700109d P003F 00AC d 0110 P0040 9800 SUB PARAMS+3 SUBTRACT BYTE OFFSET TO GET ABSOLUTE BYTES. A1700110d P0041 00A4 d 0111 P0042 6800 STA BYTEAV RESULT IS NEW BYTE SPACE AVAILABLE. A1700111d P0043 00A9 d 0112 P0044 0128 SAP MOVEF3 SKIP IF DELETION OF LAST ACTIVITY PROVIDES A1700112dd 0113 * ENOUGH ROOM FOR THE MOVE. A1700113dd 0114 P0045 8800 ADD LEN NEED MORE ROOM. RESET BYTES AVAILABLE. A1700114d P0046 00A5 d 0115 P0047 8800 ADD PARAMS+3 RESTORE BYTE OFFSET TO CHECK NEXT ACTIVITY. A1700115d P0048 009D d 0116 P0049 0901 INA 1 SKIP OVER LAST TERMINATON CHARACTER. A1700116dd 0117 P004A 6800 STA BYTEAV A1700117d P004B 00A1 d 0118 P004C 18E0 JMP* MOVEF GO DELETE ANOTHER ACTIVITY. A1700118d  d 0120 * SET UP STRING ADDRESSES FOR MOVE A1700120dd 0121 P004D 0A02 MOVEF3 ENA 2 A1700121dd 0122 P004E 8800 ADD PARAMS+2 ADD TO BASE TO GET ABSOLUTE ADDRESS. A1700122d P004F 0095 d 0123 XFA 2 DESTINATION STARTING POINT. A1700123d 0123 P0050 07C2 d 0124 P0051 E800 LDQ LEN GET LENGTH IN BYTES OF NEW ACTIVITY STRING. A1700124d P0052 0099 d 0125 P0053 F800 ADQ PARAMS+3 ADD BYTE OFFSET. A1700125d P0054 0091 d 0126 XFQ 3 SAVE FOR OFFSET CHECK. A1700126dH1 PUTACT PAGE 5 DATE: 08/29/84H   0126 P0055 07A3 d 0127 P0056 0F21 QRS 1 GET WORD ADDRESS OF SOURCE STRING. A1700127dd 0128 P0057 0832 AAQ Q ADD TO BASE. A1700128dd 0129 XFQ 1 R1 IS SOURCE STARTING WORD. A1700129d 0129 P0058 07A1 d 0130 XF3 A CHECK BYTE OFFSET OF SOURCE STRING. A1700130d 0130 P0059 0766 d 0131 P005A A023 AND- ONEBIT A1700131dd 0132 P005B 0101 SAZ MOVEF4 SKIP IF WORD BOUNDARY. A1700132dd 0133 P005C C032 LDA- ONEBIT+15 SET FLAG =$8000 TO INDICATE BYTE BOUNDARY. A1700133dd 0134 P005D 8800 MOVEF4 ADD LENBUF GET LENGTH OF SOURCE STRING IN BYTES. LENGTH =A1700134d P005E 0091 d 0135 P005F 0904 INA 4 BUFFER LENGTH - 4 RESVD BYTES - LENGTH OF CURRA1700135dd 0136 P0060 9800 SUB LEN ACTIVITY STRING. A1700136d P0061 008A d 0137 P0062 E800 LDQ LENBUF PUT LENGTH OF DESTINATION STRING IN Q. A1700137d P0063 008C d 0138 P0064 0DFC INQ -3 A1700138dd 0139 SBQ LEN A1700139d 0139 P0065 0485  0139 P0066 9000  0139 P0067 0084 d 0140 LR3* PARAMS+3 CHECK BYTE OFFSET OF DESTINATION STRING. A1700140d 0140 P0068 0483  0140 P0069 C07C d 0141 S3Z MOVEF5-*-1 SKIP IF WORD BOUNDARY. A1700141d 0141 P006A 00C1 d 0142 P006B F032 ADQ- ONEBIT+15 SET FLAG =$8000 TO INDICATE BYTE BOUNDARY. A1700142dd 0143 P006C 1822 MOVEF5 JMP* MOVEIT GO PERFORM THE MOVE. A1700143dH1 PUTACT PAGE 6 DATE: 08/29/84H  d 0145 P006D C87F MOVER LDA* BYTEAV SET UP SOURCE AND DESTINATION STRING ADDRESSESA1700145dd 0146 P006E 0904 INA 4 SOURCE POINT IS BYTEAV+4 BYTES INTO BUFFER. A1700146dd 0147 P006F 8876 ADD* PARAMS+3 ADD BYTE OFFSET. A1700147dd 0148 XFA 3 SAVE FOR OFFSET CHECKING. A1700148d 0148 P0070 07C3 d 0149 P0071 0F41 ARS 1 GET WORD LOCATION OF STRING. A1700149dd 0150 XFA 1 R1 IS RELATIVE SOURCE STRING ADDRESS. A1700150d 0150 P0072 07C1 d 0151 XF3 A RECALL STARTING POINT IN BUFFER. A1700151d 0151 P0073 0766 d 0152 P0074 9877 SUB* LEN THIS IS THE DESTINATION BYTE. A1700152dd 0153 XFA 4 SAVE FOR OFFSET CHECKING. A1700153d 0153 P0075 07C4 d 0154 P0076 0F41 ARS 1 GET WORD ADDRESS OF STRING. A1700154dd 0155 XFA 2 R2 IS DESTINATION STRING RELATIVE ADDRESS. A1700155d 0155 P0077 07C2 d 0156 P0078 C877 LDA* LENBUF GET LENGTH OF STRINGS FOR MOVE. LENGTH = LENGA1700156dd 0157 P0079 09FB INA -4 OF BUFFER - 4 - BYTES AVAIALABLE. A1700157dd 0158 P007A 9872 SUB* BYTEAV A1700158dd 0159 P007B 0822 TRA Q SOURCE STRING LENGTH = DESTINATION STRING LENGA1700159dd 0160 AN3- ONEBIT CHECK BYTE OFFSET OF SOURCE STRING. A1700160d 0160 P007C 0403  0160 P007D A023 d 0161 S3Z MOVER1-*-1 SKIP IF WORD BOUNDARY. A1700161d 0161 P007E 00C1 d 0162 P007F 8032 ADD- ONEBIT+15 SET FLAG =$8000 TO INDICATE BYTE BOUNDARY. A1700162dd 0163 MOVER1 AN4- ONEBIT CHECK BYTE OFFSET OF DESTINATION STRING. A1700163d 0163 P0080 0404  0163 P0081 A023 d 0164 S4Z MOVER2-*-1 SKIP IF WORD BOUNDARY. A1700164d 0164 P0082 0001 d 0165 P0083 F032 ADQ- ONEBIT+15 SET FLAG =$8000 TO INDICATE BYTE BOUNDARY. A1700165dd 0166 MOVER2 AR1* PARAMS+2 ADD TO BASE TO GET ABSOLUTE ADDRESS. A1700166d 0166 P0084 0481  0166 P0085 805F d 0167 AR2* PARAMS+2 ADD TO BASE TO GET ABSOLUTE ADDRESS. A1700167d 0167 P0086 0482  0167 P0087 805D d 0168 LR3* BYTEAV GET NEW VALUE OF BYTES AVAILABLE. NEW = OLD -A1700168d 0168 P0088 0483  0168 P0089 C063 d 0169 SB3* LEN LENGTH OF STRING. A1700169d 0169 P008A 0483  0169 P008B 9060 d 0170 SR3* BYTEAV A1700170d 0170 P008C 0483  0170 P008D C15F   d 0172 MOVEIT MOV MOVE REQUEST. A1700172d 0172 P008E 0F01 d 0173 * MOVE COMPLETE. NOW MOVE NEW ACTIVITY STRING INTO BUFFER. A1700173dd 0174 LR1* PARAMS SOURCE STRING ADDRESS. A1700174dH1 PUTACT PAGE 7 DATE: 08/29/84H   0174 P008F 0481  0174 P0090 C052 d 0175 P0091 C85E LDA* LENBUF MOVE TO END OF BUFFER. SUBTRACT A1700175dd 0176 * LENGTH OF NEW ACTIVITY STRING. RESULT A1700176dd 0177 P0092 9859 SUB* LEN IS BYTE INDEX FOR DESTINATION. A1700177dd 0178 P0093 8852 ADD* PARAMS+3 ADD BYTE OFFSET. A1700178dd 0179 XFA 3 SAVE FOR OFFSET CHECKING. A1700179d 0179 P0094 07C3 d 0180 P0095 0F41 ARS 1 GET WORD ADDRESS RELATIVE TO START OF BUFFER. A1700180dd 0181 P0096 884E ADD* PARAMS+2 ADD TO BUFFER ADDRESS. A1700181dd 0182 XFA 2 R2 CONTAINS DESTINATION STRING ADDRESS. A1700182d 0182 P0097 07C2 d 0183 P0098 C853 LDA* LEN LENGTH OF MOVE IN BYTES. A1700183dd 0184 P0099 0822 TRA Q SOURCE STRING LENGTH = DESTINATION STRING LENGA1700184dd 0185 AN3- ONEBIT CHECK BYTE OFFSET OF DESTINATION STRING. A1700185d 0185 P009A 0403  0185 P009B A023 d 0186 S3Z MOVE05-*-1 SKIP IF WORD BOUNDARY. A1700186d 0186 P009C 00C1 d 0187 P009D F032 ADQ- ONEBIT+15 SET FLAG =$8000 TO INDICATE BYTE BOUNDARY. A1700187dd 0188 MOVE05 LR4* PARAMS+1 CHECK BYTE OFFSET OF STRING. A1700188d 0188 P009E 0484  0188 P009F C044 d 0189 AN4- ONEBIT A1700189d 0189 P00A0 0404  0189 P00A1 A023 d 0190 S4Z MOVEST-*-1 SKIP IF WORD BOUNDARY. A1700190d 0190 P00A2 0001 d 0191 P00A3 8032 ADD- ONEBIT+15 SET FLAG =$8000 TO INDICATE BYTE BOUNDARY. A1700191d  d 0193 MOVEST MOV MOVE ACIVITY STRING INTO BUFFER. A1700193d 0193 P00A4 0F01 d 0194 P00A5 0A00 ENA 0 ZERO OPERATOR/STATUS WORD FOR SUCCESSFUL OPERAA1700194dd 0195 P00A6 684B STA* OSW A1700195dd 0196 P00A7 5800 RTJ CONBYT CONVERT BYTES AVAILABLE INTO BUFFER. A1700196d P00A8 009D d 0197 P00A9 1800 JMP MOVCMP MOVE COMPLETE. EXIT. A1700197d P00AA 00D4 H1 PUTACT PAGE 8 DATE: 08/29/84H  d 0199 * PICK UP RPG PARAMETERS - A CONTAINS ADDRESS OF PARAMETER LIST. A1700199dd 0200 * A1700200dd 0201 P00AB 0000 RPGGET 0 0 A1700201dd 0202 P00AC 6817 STA* PADD SAVE ADDRESS OF PARAMETER LIST. A1700202dd 0203 P00AD 0C00 ENQ 0 A1700203dd 0204 XFQ 1 INITIALIZE R1. A1700204d 0204 P00AE 07A1 d 0205 P00AF 5815 RPG005 RTJ* RPGPAR GET NEXT PARAMETER. A1700205dd 0206 P00B0 0111 SAN RPG010 SKIP IF PARAMETER FOUND. A1700206dd 0207 P00B1 180D JMP* RPG050 END OF PARAMETER LIST. A1700207dd 0208 RPG010 XFI A I CONTAINS BYTE ADDRESS RELATIVE TO R9BASE. A1700208d 0208 P00B2 07E6 d 0209 P00B3 0F41 ARS 1 GET WORD ADDRESS RELATIVE TO R9BASE. A1700209dd 0210 P00B4 880D ADD* RIBASE ADD TO BASE TO GET ABSOLUTE ADDRESS. A1700210dd 0211 SRA* PARAMS,1 STORE INTO PARAMETER LIST, INDEXED BY R1. A1700211d 0211 P00B5 048E  0211 P00B6 C12C d 0212 XFI A CHECK BYTE OFFSET. A1700212d 0212 P00B7 07E6 d 0213 P00B8 A023 AND- ONEBIT =0, WORD BOUNDARY. =1, BYTE BOUNDARY. A1700213dd 0214 RPG015 SRA* PARAMS+1,1 STORE INTO NEXT LOACTION IN PARAMETER LIST. A1700214d 0214 P00B9 048E  0214 P00BA C129 d 0215 AR1- TWO BUMP INDEX REGISTER. A1700215d 0215 P00BB 0401  0215 P00BC 8024 d 0216 P00BD 18F1 JMP* RPG005 GO GET NEXT PARAMETER. A1700216dd 0217 P00BE C804 RPG050 LDA* RBLANK SET BLANK EQUAL TO EBCDIC A1700217dd 0218 P00BF 682F STA* BLANKS BLANK = $40 A1700218dd 0219 P00C0 1CEA JMP* (RPGGET) RETURN. A1700219d  d 0221 P00C1 7FFF X RIBASE ADC R9BASE BASE ADDRESS OF RPG PARAMETERS. A1700221dd 0222 P00C2 4040 RBLANK NUM $4040 EBCDIC BLANKS. A1700222dd 0223 P00C3 0000 PADD NUM 0 ABSOLUTE ADDRESS OF PARAMETER LIST FOR RPG. A1700223dH1 PUTACT PAGE 9 DATE: 08/29/84H  d 0225 P00C4 0000 RPGPAR 0 0 PICK UP PARAMETER ADDRESS AND BYTE OFFSET. A1700225dd 0226 P00C5 E8FD LDQ* PADD A1700226dd 0227 P00C6 C622 LDA- (ZERO),Q A1700227dd 0228 P00C7 0900 INA 0 CHECK FOR $FFFF - END OF PARAMETER LIST. A1700228dd 0229 P00C8 0103 SAZ RPG500 SKIP IF END OF PARAMETER LIST. A1700229dd 0230 P00C9 5400 X RTJ R9FLDL RELATIVE BYTE ADDRESS RETURNED IN I. A1700230d P00CA 7FFF X d 0231 P00CB D8F7 RAO* PADD BUMP TO ALLOW RETRIEVAL OF NEXT PARAMETER. A1700231dd 0232 P00CC 1CF7 RPG500 JMP* (RPGPAR) RETURN. A1700232dH1 PUTACT PAGE 10 DATE: 08/29/84H  d 0234 * PICK UP PARAMETERS FROM FTN. NEXT FOUR LOCATIONS AFTER CALLER A1700234dd 0235 * HAVE THE PARAMETERS. A1700235dd 0236 * A1700236dd 0237 P00CD 0000 FTNGET 0 0 A1700237dd 0238 P00CE E800 LDQ PUTACF ADDRESS OF PARAMETER LIST. A1700238d P00CF FF37 d 0239 P00D0 0D03 INQ 3 GO TO END OF LIST. A1700239dd 0240 LR1- SEVEN SET UP INDEX INTO PARAMETER STORAGE. A1700240d 0240 P00D1 0401  0240 P00D2 C005 d 0241 LR2- ZERO INITIALIZE R2. A1700241d 0241 P00D3 0402  0241 P00D4 C022 d 0242 P00D5 C622 FTN010 LDA- (ZERO),Q PICK UP ABSOLUTE ADDRESS OF PARAMETER. A1700242dd 0243 SRA* PARAMS-1,1 STORE INTO PARAMETER STORAGE. A1700243d 0243 P00D6 048E  0243 P00D7 C10A d 0244 SR2* PARAMS,1 ZERO BYTE OFFSET TO INDICATE WORD BOUNDARY. A1700244d 0244 P00D8 048A  0244 P00D9 C109 d 0245 P00DA 0DFE INQ -1 BUMP TO GET NEXT PARAMETER. A1700245dd 0246 SB1- ONE DECREMENT INDEX INTO PARAMETER STORAGE. A1700246d 0246 P00DB 0401  0246 P00DC 9003 d 0247 D1P *-FTN010 SKIP IF ALL PARAMETERS PICKED UP. A1700247d 0247 P00DD 0628 d 0248 P00DE C803 FTN020 LDA* FBLANK SET BLANKS TO ASCII BLANKS A1700248dd 0249 P00DF 680F STA* BLANKS =$20. A1700249dd 0250 P00E0 1CEC JMP* (FTNGET) RETURN. A1700250d  d 0252 P00E1 2020 FBLANK NUM $2020 ASCII BLANKS. A1700252dH1 PUTACT PAGE 11 DATE: 08/29/84H  d 0254 * VARIABLES USED IN THIS PROGRAM. A1700254dd 0255 * A1700255dd 0256 P00E2 0000 PARAMS NUM 0 ABSOLUTE ADDRESS OF STRING. A1700256dd 0257 P00E3 0000 NUM 0 +1 BYTE OFFSET OF STRING. A1700257dd 0258 P00E4 0000 NUM 0 +2 ABSOLUTE ADDRESS OF BUFFER. A1700258dd 0259 P00E5 0000 NUM 0 +3 BYTE OFFSET OF BUFFER. A1700259dd 0260 P00E6 0000 NUM 0 +4 ABSOLUTE ADDRESS OF LENGTH. A1700260dd 0261 P00E7 0000 NUM 0 +5 BYTE OFFSET OF LENGTH. A1700261dd 0262 P00E8 0000 NUM 0 +6 ABSOLUTE ADDRESS OF OPERATOR/STATUS WORD. A1700262dd 0263 P00E9 0000 NUM 0 +7 BYTE OFFSET OF OSW. A1700263dd 0264 P00EA 0000 RETURN NUM 0 RETURN ADDRESS. A1700264dd 0265 P00EB 0000 LEN NUM 0 LENGTH IN BYTES OF ACTIVITY STRING. A1700265dd 0266 P00EC 0000 BYTEAV NUM 0 BYTES AVAILABLE IN BUFFER. A1700266dd 0267 P00ED 00AA TERMIN NUM $AA TERMINATION CHARACTER OF ACTIVITY STRINGS. A1700267dd 0268 P00EE 0000 BLANKS NUM 0 ASCII/EBCDIC BLANKS USED IN PROGRAM. A1700268dd 0269 P00EF 0000 LENBUF NUM 0 LENGTH IN BYTES OF BUFFER TO RECEIVE THE ACTIVA1700269dd 0270 P00F0 03E8 THOUS NUM 1000 NUMERIC VALUE 1000. A1700270dd 0271 P00F1 0000 OSW NUM 0 LOCAL OPERATOR STATUS WORD CONVERTED ON RETURNA1700271dH1 PUTACT PAGE 12 DATE: 08/29/84H  d 0273 * EXTRACT LENGTH OF BUFFER A1700273dd 0274 * A1700274dd 0275 P00F2 0000 BUFLEN 0 0 A1700275dd 0276 P00F3 0A00 ENA 0 A1700276dd 0277 P00F4 68FA STA* LENBUF ZERO BUFFER LENGTH. A1700277dd 0278 LR1* PARAMS+5 R1 IS BYTE INDEX INTO LENGTH PARAMETER. A1700278d 0278 P00F5 0481  0278 P00F6 C0F0 d 0279 P00F7 C8F8 LDA* THOUS A1700279dd 0280 P00F8 680F BUF010 STA* BUMULT STORE MULTIPLIER. A1700280dd 0281 LCA* (PARAMS+4),1 PICK UP NEXT NUMBER FROM LENGTH A1700281d 0281 P00F9 04C1  0281 P00FA C2EB d 0282 P00FB A006 AND- LPMASK+4 EXTRACT NUMERIC VALUE FROM IT. A1700282dd 0283 P00FC 280B MUI* BUMULT MULTIPLY TO GET VALUE. A1700283dd 0284 P00FD 88F1 ADD* LENBUF ADD TO LENGTH. A1700284dd 0285 P00FE 68F0 STA* LENBUF A1700285dd 0286 P00FF C808 LDA* BUMULT GET NEXT MULTIPLIER. A1700286dd 0287 P0100 0C00 ENQ 0 CLEAR Q FOR DIVIDE. A1700287dd 0288 P0101 3046 DVI- TEN A1700288dd 0289 P0102 0103 SAZ BUF500 BUFFER LENGTH EXTRACTED. RETURN. A1700289dd 0290 AR1- ONE INCREMENT BYTE INDEX. A1700290d 0290 P0103 0401  0290 P0104 8003 d 0291 P0105 18F2 JMP* BUF010 GET NEXT NUMBER. A1700291dd 0292 P0106 1CEB BUF500 JMP* (BUFLEN) RETURN. A1700292d  d 0294 P0107 0000 BUMULT NUM 0 MULTIPLIER VALUE OF CURRENT NUMBER. A1700294dH1 PUTACT PAGE 13 DATE: 08/29/84H  d 0296 * SCAN ACTIVITY STRING TO DETERMINE LENGTH OMITTING TRAILING BLANKSA1700296dd 0297 * PUT TERMINATION CHARACTER AT END AND SAVE THE LENGTH. A1700297dd 0298 * A1700298dd 0299 P0108 0000 GETLEN 0 0 A1700299dd 0300 P0109 0A46 ENA 70 START AT END OF STRING TO RETRIEVE CHARACTERS.A1700300dd 0301 P010A 88D8 ADD* PARAMS+1 SET BYTE OFFSET. A1700301dd 0302 XFA 1 A1700302d 0302 P010B 07C1 d 0303 GETL01 LCA* (PARAMS),1 GET NEXT CHARACTER OUT OF STRING. A1700303d 0303 P010C 04C1  0303 P010D C2D4 d 0304 P010E B8DF EOR* BLANKS CHECK FOR BLANK. A1700304dd 0305 P010F A00A AND- LPMASK+8 CHECK ONLY CHARACTER. A1700305dd 0306 P0110 0111 SAN GETL02 SKIP IF NON-BLANK. A1700306dd 0307 D1P *-GETL01 BLANK, GO GET NEXT CHARACTER. A1700307d 0307 P0111 0625 d 0308 GETL02 AR1- ONE STORE TERMINATION CHARCTER A1700308d 0308 P0112 0401  0308 P0113 8003 d 0309 P0114 C8D8 LDA* TERMIN AT END OF STRING. A1700309dd 0310 SCA* (PARAMS),1 A1700310d 0310 P0115 04C1  0310 P0116 C3CB d 0311 AR1- ONE ADD ONE TO GET NUMBER OF BYTES IN STRING. A1700311d 0311 P0117 0401  0311 P0118 8003 d 0312 SB1 PARAMS+1 SUBTRACT BYTE OFFSET TO GET ABSOLUTE LENGTH. A1700312d 0312 P0119 0481  0312 P011A 9000  0312 P011B FFC7 d 0313 SR1* LEN SAVE LENGTH OF STRING. A1700313d 0313 P011C 0481  0313 P011D C1CD d 0314 P011E 1CE9 JMP* (GETLEN) RETURN. A1700314dH1 PUTACT PAGE 14 DATE: 08/29/84H  d 0316 * ROUTINE TO EXTRACT THE AVAILABLE BYTE SPACE FROM BYTES 0- 3 OF A1700316dd 0317 * BUFFER. A1700317dd 0318 * A1700318dd 0319 P011F 0000 AVBYTE 0 0 A1700319dd 0320 P0120 0A00 ENA 0 A1700320dd 0321 P0121 68CA STA* BYTEAV ZERO BYTES AVAILABLE. A1700321dd 0322 LR1* PARAMS+3 R1 CONTAINS BYTE INDEX INTO BUFFER WITH OFFSETA1700322d 0322 P0122 0481  0322 P0123 C0C1 d 0323 P0124 C8CB LDA* THOUS SET UP MULTIPLIER. A1700323dd 0324 P0125 681F AVB010 STA* MULT A1700324d  d 0326 LCA* (PARAMS+2),1 PICK UP NEXT NUMBER. A1700326d 0326 P0126 04C1  0326 P0127 C2BC d 0327 P0128 B8C5 EOR* BLANKS CHECK IF BLANK. BLANK IMPLIES NEW BUFFER. A1700327dd 0328 P0129 A00A AND- LPMASK+8 ONLY CHECK A CHARACTER. A1700328dd 0329 P012A 010C SAZ AVB050 SKIP IF NEW BUFFER. A1700329dd 0330 P012B A006 AND- LPMASK+4 EXTRACT NUMBER. A1700330dd 0331 P012C 2800 MUI MULT MULITPLY TO GET CORRECT NUMBER. A1700331d P012D 0017 d 0332 P012E 88BD ADD* BYTEAV ADD TO TOTAL OF BYTES AVAILABLE. A1700332dd 0333 P012F 68BC STA* BYTEAV A1700333dd 0334 P0130 C814 LDA* MULT GET NEXT MULTIPLIER. A1700334dd 0335 P0131 0C00 ENQ 0 ZERO MSB OF DIVIDEND. A1700335dd 0336 P0132 3046 DVI- TEN A1700336dd 0337 P0133 010F SAZ AVB500 SKIP IF NUMBER FULLY EXTRACTED. A1700337dd 0338 AR1- ONE INCREMENT BYTE INDEX REGISTER. A1700338d 0338 P0134 0401  0338 P0135 8003 d 0339 P0136 18EE JMP* AVB010 GO GET NEXT NUMBER. A1700339dd 0340 P0137 C8B7 AVB050 LDA* LENBUF NEW BUFFER. BYTES AVAILABLE EQUALS BUFFER LENGA1700340dd 0341 P0138 09FA INA -5 MINUS THE 4 RESERVED BYTES AT THE BEGINNING AA1700341dd 0342 * TERMINATION CHARACTER AT END OF BUFFER. A1700342dd 0343 P0139 68B2 STA* BYTEAV A1700343dd 0344 P013A C8B2 LDA* TERMIN STORE TERMINATION CHARACTER A1700344dd 0345 LR1* LENBUF IN LAST POSITION OF BUFFER. A1700345d 0345 P013B 0481  0345 P013C C0B2 d 0346 AR1* PARAMS+3 ADD BYTE OFFSET. A1700346d 0346 P013D 0481  0346 P013E 80A6 d 0347 SB1- ONE R1 IS BYTE INDEX TO END OF BUFFER. A1700347d 0347 P013F 0401  0347 P0140 9003 d 0348 SCA* (PARAMS+2),1 STORE INTO BUFFER. A1700348d 0348 P0141 04C1  0348 P0142 C3A1 d 0349 P0143 1CDB AVB500 JMP* (AVBYTE) RETURN. A1700349d  d 0351 P0144 0000 MULT NUM 0 MULTIPLIER OF CURRENT NUMBER. A1700351dH1 PUTACT PAGE 15 DATE: 08/29/84H  d 0353 * ROUTINE TO CONVERT THE BYTES AVAILABLE IN BUFFER INTO A 4 BYTE A1700353dd 0354 * ASCII/EBCDIC FIELD AND STORE INTO BYTES 0- 3 OF BUFFER. A1700354dd 0355 * A1700355dd 0356 P0145 0000 CONBYT 0 0 A1700356dd 0357 P0146 0C00 ENQ 0 GET CONVERSION CHARACTER - ASCII OR EBCDIC. A1700357dd 0358 P0147 C8A6 LDA* BLANKS A1700358dd 0359 P0148 B898 EOR* FBLANK IF FBLANK, RETURN IN ASCII. A1700359dd 0360 P0149 0102 SAZ CON010 SKIP IF FTN CALLER FOR ASCII CONVERSION. A1700360dd 0361 P014A 0D60 INQ $60 RPG CALLLER, RETURN IN EBCDIC. A1700361dd 0362 P014B 0D60 INQ $60 A1700362dd 0363 P014C 0D30 CON010 INQ $30 A1700363dd 0364 P014D 4815 STQ* CONCHR SAVE THE CONVERSION CHARACTER. A1700364dd 0365 LR1* PARAMS+3 ADD BYTE OFFSET. R1 CONTAINS BYTE INDEX. A1700365d 0365 P014E 0481  0365 P014F C095 d 0366 P0150 C89F LDA* THOUS STARTING DIVISOR FOR CONVERSION. A1700366dd 0367 P0151 6810 CON020 STA* DVISOR SAVE DIVISOR. A1700367dd 0368 P0152 C899 LDA* BYTEAV A1700368dd 0369 P0153 0C00 ENQ 0 ZERO MSB OF DIVIDEND. A1700369dd 0370 P0154 380D DVI* DVISOR A CONTAINS NUMBER FOR THIS BYTE POSITION. A1700370dd 0371 P0155 880D ADD* CONCHR ADD CONVERSION CHARACTER. A1700371dd 0372 SCA* (PARAMS+2),1 STORE INTO BUFFER. A1700372d 0372 P0156 04C1  0372 P0157 C38C d 0373 AR1- ONE INCREMENT BYTE INDEX TO STORE INTO NEXT BYTE. A1700373d 0373 P0158 0401  0373 P0159 8003 d 0374 P015A 4891 STQ* BYTEAV STORE REMAINDER BACK INTO ORIGINAL VALUE. A1700374dd 0375 P015B 0C00 ENQ 0 ZERO MSB OF DIVIDEND. A1700375dd 0376 P015C C805 LDA* DVISOR GET NEXT DIVISOR VALUE. A1700376dd 0377 P015D 3046 DVI- TEN A1700377dd 0378 P015E 0101 SAZ CON050 SKIP IF CONVERSION COMPLETE. A1700378dd 0379 P015F 18F1 JMP* CON020 GO GET NEXT NUMBER. A1700379dd 0380 P0160 1CE4 CON050 JMP* (CONBYT) RETURN. A1700380d  d 0382 P0161 0000 DVISOR NUM 0 DIVISOR TO EXTRACT NEXT NUMBER. A1700382dd 0383 P0162 0000 CONCHR NUM 0 CONVERSION VALUE TO GET NUMERIC. $30 IN ASCIIA1700383dd 0384 * $F0 IN EBCDIC. A1700384d  H1 PUTACT PAGE 16 DATE: 08/29/84H  d 0387 * CONVERT RETURN VALUE OF OPERATOR/STATUS WORD INTO ASCII/EBCDIC A1700387dd 0388 * VALUE, AND CLEAR TERMINATION CHARACTER FROM STRING. A1700388dd 0389 * A1700389dd 0390 P0163 0000 CONOSW 0 0 A1700390dd 0391 LR4* OSW SAVE OSW IN R4. A1700391d 0391 P0164 0484  0391 P0165 C08B d 0392 LR1* PARAMS+7 SET BYTE OFFSET. A1700392d 0392 P0166 0481  0392 P0167 C081 d 0393 P0168 C8F9 LDA* CONCHR PICK UP CONVERSION CHARACTER (=ACSII/EBCDIC 0)A1700393dd 0394 SCA (PARAMS+6),1 STORE ZERO INTO BYTE TWO OF OSW. A1700394d 0394 P0169 04C1  0394 P016A C300  0394 P016B FF7C d 0395 AR1- ONE INCREMENT BYTE INDEX. A1700395d 0395 P016C 0401  0395 P016D 8003 d 0396 S4Z CON600-*-1 SKIP IF NO ERROR TO REPORT. A1700396d 0396 P016E 0001 d 0397 P016F 0901 INA 1 SET FLAG IF ERROR - NON-FORCE REQUEST WITH IN-A1700397dd 0398 * SUFFICIENT SPACE AVAILABLE IN BUFFER FOR REQUEA1700398dd 0399 CON600 SCA (PARAMS+6),1 STORE FLAG INTO BYTE 1. A1700399d 0399 P0170 04C1  0399 P0171 C300  0399 P0172 FF75 d 0400 P0173 E800 LDQ PARAMS+1 A1700400d P0174 FF6E d 0401 P0175 F800 ADQ LEN MOVE TO END OF STRING. A1700401d P0176 FF74 d 0402 P0177 0DFE INQ -1 MOVE POINTER TO TERMINATION CHARACTER. A1700402dd 0403 P0178 C800 LDA BLANKS A1700403d P0179 FF74 d 0404 SCA (PARAMS),Q BLANK OUT TERMINATION CHARACTER. A1700404d 0404 P017A 04C5  0404 P017B C300  0404 P017C FF65 d 0405 P017D 1CE5 JMP* (CONOSW) RETURN. A1700405dH1 PUTACT PAGE 17 DATE: 08/29/84H  d 0407 * REQUEST PROCESSED. CONVERT OPERATOR/STATUS WORD INTO 2 BYTES A1700407dd 0408 * ASCII/EBCIDC AND RETURN. A1700408dd 0409 * A1700409dd 0410 P017E 58E4 MOVCMP RTJ* CONOSW CONVERT OSW. A1700410dd 0411 P017F C806 LDA* SAVEI RESTORE Q AND I REGISTERS 138*A009A1700411dd 0412 P0180 60FF STA- I IN CASE OF RETURN TO FORTRAN. 138*A009A1700412dd 0413 P0181 E803 LDQ* SAVEQ CALLER. NO EFFECT ON RETURN TO 138*A009A1700413dd 0414 * RPG CALLER. 138*A009A1700414dd 0415 P0182 1C00 JMP (RETURN) RETURN EXIT. A1700415d P0183 FF66  d 0417 P0184 0000 SAVEQ NUM 0 Q AND I REGISTER SAVE. 138*A009A1700417dd 0418 P0185 0000 SAVEI NUM 0 138*A009A1700418d d 0420 END END OF PROGRAM A1700420d  D PGM= 0186 ( 390) COM = 0000 ( 0) DAT = 0000 ( 0) D H1 PUTACT PAGE 18 DATE: 08/29/84H     E Q U I V A L E N C E S -----------------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0000 I 00FF (000255) 0070, 0412 HH 0054 LPMASK 0002 (000002) 0089, 0282, 0305, 0328, 0330 HH 0055 ONE 0003 (000003) 0105, 0105, 0246, 0246, 0290, 0290HH 0308, 0308, 0311, 0311, 0338, 0338HH 0347, 0347, 0373, 0373, 0395, 0395HH 0056 SEVEN 0005 (000005) 0240, 0240 HH 0057 ZERO 0022 (000034) 0227, 0241, 0241, 0242 HH 0058 ONEBIT 0023 (000035) 0131, 0133, 0142, 0160, 0160, 0162HH 0163, 0163, 0165, 0185, 0185, 0187HH 0189, 0189, 0191, 0213 HH 0059 TWO 0024 (000036) 0215, 0215 HH 0060 TEN 0046 (000070) 0288, 0336, 0377 HH1 PUTACT PAGE 19 DATE: 08/29/84H     S Y M B O L S -------------  B DEF.LINE NAME ADDRESS REFERENCED AT LINE NUMBER B H 0049 PUTACR 0000 0049, 0063 HH 0050 PUTACF 0007 0050, 0072, 0238 HH 0077 START 0013 0066 HH 0085 FORCHK 001F 0082 HH 0097 MOVEF 002D 0090, 0118 HH 0102 MOVEF1 0033 0106 HH 0107 MOVEF2 003C 0104 HH 0121 MOVEF3 004D 0112 HH 0134 MOVEF4 005D 0132 HH 0143 MOVEF5 006C 0141, 0141, 0141 HH 0145 MOVER 006D 0083 HH 0163 MOVER1 0080 0161, 0161, 0161 HH 0166 MOVER2 0084 0164, 0164, 0164 HH 0172 MOVEIT 008E 0143 HH 0188 MOVE05 009E 0186, 0186, 0186 HH 0193 MOVEST 00A4 0190, 0190, 0190 HH 0201 RPGGET 00AB 0065, 0219 HH 0205 RPG005 00AF 0216 HH 0208 RPG010 00B2 0206 HH 0214 RPG015 00B9 HH 0217 RPG050 00BE 0207 HH 0221 RIBASE 00C1 0210 HH 0222 RBLANK 00C2 0217 HH 0223 PADD 00C3 0202, 0226, 0231 HH 0225 RPGPAR 00C4 0205, 0232 HH 0232 RPG500 00CC 0229 HH 0237 FTNGET 00CD 0075, 0250 HH 0242 FTN010 00D5 0247, 0247, 0247, 0247 HH 0248 FTN020 00DE HH 0252 FBLANK 00E1 0248, 0359 HH 0256 PARAMS 00E2 0086, 0088, 0100, 0102, 0110, 0115HH 0122, 0125, 0140, 0140, 0140, 0147HH 0166, 0166, 0166, 0167, 0167, 0167HH 0174, 0174, 0174, 0178, 0181, 0188HH 0188, 0188, 0211, 0211, 0211, 0214HH 0214, 0214, 0243, 0243, 0243, 0244HH 0244, 0244, 0278, 0278, 0278, 0281HH 0281, 0281, 0301, 0303, 0303, 0303HH 0310, 0310, 0310, 0312, 0322, 0322HH 0322, 0326, 0326, 0326, 0346, 0346HH 0346, 0348, 0348, 0348, 0365, 0365HH1 PUTACT PAGE 20 DATE: 08/29/84H  H 0365, 0372, 0372, 0372, 0392, 0392HH 0392, 0394, 0399, 0400, 0404 HH 0264 RETURN 00EA 0064, 0074, 0415 HH 0265 LEN 00EB 0081, 0109, 0114, 0124, 0136, 0139HH 0152, 0169, 0169, 0169, 0177, 0183HH 0313, 0313, 0313, 0401 HH 0266 BYTEAV 00EC 0080, 0097, 0111, 0117, 0145, 0158HH 0168, 0168, 0168, 0170, 0170, 0170HH 0321, 0332, 0333, 0343, 0368, 0374HH 0267 TERMIN 00ED 0103, 0309, 0344 HH 0268 BLANKS 00EE 0218, 0249, 0304, 0327, 0358, 0403HH 0269 LENBUF 00EF 0134, 0137, 0156, 0175, 0277, 0284HH 0285, 0340, 0345, 0345, 0345 HH 0270 THOUS 00F0 0279, 0323, 0366 HH 0271 OSW 00F1 0092, 0195, 0391, 0391, 0391 HH 0275 BUFLEN 00F2 0077, 0292 HH 0280 BUF010 00F8 0291 HH 0292 BUF500 0106 0289 HH 0294 BUMULT 0107 0280, 0283, 0286 HH 0299 GETLEN 0108 0078, 0314 HH 0303 GETL01 010C 0307, 0307, 0307, 0307 HH 0308 GETL02 0112 0306 HH 0319 AVBYTE 011F 0079, 0349 HH 0324 AVB010 0125 0339 HH 0340 AVB050 0137 0329 HH 0349 AVB500 0143 0337 HH 0351 MULT 0144 0324, 0331, 0334 HH 0356 CONBYT 0145 0196, 0380 HH 0363 CON010 014C 0360 HH 0367 CON020 0151 0379 HH 0380 CON050 0160 0378 HH 0382 DVISOR 0161 0367, 0370, 0376 HH 0383 CONCHR 0162 0364, 0371, 0393 HH 0390 CONOSW 0163 0405, 0410 HH 0399 CON600 0170 0396, 0396, 0396 HH 0410 MOVCMP 017E 0093, 0197 HH 0417 SAVEQ 0184 0069, 0413 HH 0418 SAVEI 0185 0071, 0411 HH1 PUTACT PAGE 21 DATE: 08/29/84H     E X T E R N A L S -----------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0052 R9FLDL 00CA 0230 HH 0053 R9BASE 00C1 0221 HH1 PUTACT PAGE 22 DATE: 08/29/84H  > *** A L P H A B E T I C A L S O R T O F S Y M B O L S *** >  H AVB010 0324 AVB050 0340 AVB500 0349 AVBYTE 0319 BLANKS 0268 HH BUF010 0280 BUF500 0292 BUFLEN 0275 BUMULT 0294 BYTEAV 0266 HH CON010 0363 CON020 0367 CON050 0380 CON600 0399 CONBYT 0356 HH CONCHR 0383 CONOSW 0390 DVISOR 0382 FBLANK 0252 FORCHK 0085 HH FTN010 0242 FTN020 0248 FTNGET 0237 GETL01 0303 GETL02 0308 HH GETLEN 0299 I 0000 LEN 0265 LENBUF 0269 LPMASK 0054 HH MOVCMP 0410 MOVE05 0188 MOVEF 0097 MOVEF1 0102 MOVEF2 0107 HH MOVEF3 0121 MOVEF4 0134 MOVEF5 0143 MOVEIT 0172 MOVER 0145 HH MOVER1 0163 MOVER2 0166 MOVEST 0193 MULT 0351 ONE 0055 HH ONEBIT 0058 OSW 0271 PADD 0223 PARAMS 0256 PUTACF 0050 HH PUTACR 0049 R9BASE 0053 R9FLDL 0052 RBLANK 0222 RETURN 0264 HH RIBASE 0221 RPG005 0205 RPG010 0208 RPG015 0214 RPG050 0217 HH RPG500 0232 RPGGET 0201 RPGPAR 0225 SAVEI 0418 SAVEQ 0417 HH SEVEN 0056 START 0077 TEN 0060 TERMIN 0267 THOUS 0270 HH TWO 0059 ZERO 0057 HP1 PH1 RPGDT1 PAGE 1 DATE: 08/29/84H  d 0001 NAM RPGDT1 A18 A CCS CCS 3.0 SL-149A1800001dd 0002 * RPG INTERFACE TO COLLECTOR ASSIGNMENT A1800002dd 0003 * A1800003dd 0004 * CYBERCREDIT SYSTEM VERSION 3 A1800004dd 0005 * DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA A1800005dd 0006 * COPYRIGHT CONTROL DATA CORPORATION, 1979 A1800006dd 0007 * A1800007dd 0008 ENT RPGDT1 A1800008dd 0009 EXT R9FLDL A1800009dd 0010 EXT R9BASE A1800010dd 0011 EXT FTNDT1 A1800011dd 0012 0003 EQU ONE(3) A1800012dd 0013 0022 EQU ZERO($22) A1800013dd 0014 0002 EQU LPMASK(2) A1800014dd 0015 P0000 0000 RPGDT1 NUM 0 ENTRY A1800015dd 0016 P0001 0CFE ENQ -1 A1800016dd 0017 XFQ 3 INITIALIZE R3 A1800017d 0017 P0002 07A3 d 0018 P0003 6842 STA* PADD SAVE ADDRESS OF RPG PARAMETER LIST A1800018dd 0019 P0004 5860 STRT RTJ* PICK CCSGET A PARAMETER A1800019dd 0020 P0005 0111 SAN CONT A1800020dd 0021 * END OF PARAMETER LIST A1800021dd 0022 P0006 1817 JMP* CLFTN A1800022dd 0023 * SINCE THE RETURNED PARAMETER IS LAST, WE NEED TO LOOK AHEAD SO A1800023dd 0024 * IT IS NOT STORED AS INPUT A1800024dd 0025 CONT XF3 Q CHECK FOR 1ST PARAMETER A1800025d 0025 P0007 0765 d 0026 P0008 0164 SQP CONT1 A1800026dd 0027 XFI 4 SAVE 1ST PARAMETER A1800027d 0027 P0009 07E4 d 0028 P000A 0C00 ENQ 0 A1800028dd 0029 XFQ 3 ZERO R3 FOR DESTINATION OFFSET A1800029d 0029 P000B 07A3 d 0030 P000C 18F7 JMP* STRT A1800030dd 0031 * MOVE PARAMETER TO FTN ARRAY A1800031dd 0032 CONT1 XF4 2 READ UP PREVIOUS ADDRESS A1800032d 0032 P000D 0782 d 0033 XFI 4 SAVE CURRENT ADDRESS A1800033d 0033 P000E 07E4 d 0034 P000F 0C06 ENQ 6 A1800034dd 0035 ** MOVE PARAMETER LOOP A1800035dd 0036 LOOP LCA* (A9BASE),2 PICK UP CHARACTER A1800036d 0036 P0010 04C2  0036 P0011 C235 d 0037 P0012 585B RTJ* EA A1800037dd 0038 L1 SCA* PRMS,3 STORE IN FTN ARRAY A1800038d 0038 P0013 0483  0038 P0014 C333 d 0039 AR2- ONE UP CHARACTER OFFSETS A1800039d 0039 P0015 0402  0039 P0016 8003 d 0040 AR3- ONE A1800040d 0040 P0017 0403 H1 RPGDT1 PAGE 2 DATE: 08/29/84H   0040 P0018 8003 d 0041 P0019 0DFE INQ -1 A1800041dd 0042 P001A 0141 SQZ CONT2 A1800042dd 0043 P001B 18F4 JMP* LOOP A1800043dd 0044 ** END MOVE PARAMETER LOOP A1800044dd 0045 P001C 18E7 CONT2 JMP* STRT CCSGET NEXT PARAMETER A1800045dd 0046 * A1800046dd 0047 * CALL FORTRAN PROGRAM A1800047dd 0048 * A1800048dd 0049 CLFTN SR4* RTNOF SAVE OFFSET OF COID A1800049d 0049 P001D 0484  0049 P001E C126 d 0050 * FIRST CONVERT THE OUTPUT FIELD (COID) TO ASCII A1800050dd 0051 * IN CASE A VALUE IS NOT RETURNED. A1800051dd 0052 P001F 0C00 ENQ 0 A1800052dd 0053 XFQ 3 A1800053d 0053 P0020 07A3 d 0054 P0021 0C04 ENQ 4 A1800054dd 0055 MLOOP LCA* (A9BASE),4 A1800055d 0055 P0022 04C4  0055 P0023 C223 d 0056 P0024 5849 RTJ* EA A1800056dd 0057 SCA* COID,3 A1800057d 0057 P0025 0483  0057 P0026 C33C d 0058 AR3- ONE A1800058d 0058 P0027 0403  0058 P0028 8003 d 0059 AR4- ONE A1800059d 0059 P0029 0404  0059 P002A 8003 d 0060 P002B 0DFE INQ -1 A1800060dd 0061 P002C 0141 SQZ FTN A1800061dd 0062 P002D 18F4 JMP* MLOOP A1800062dd 0063 P002E 5400 X FTN RTJ FTNDT1 A1800063d P002F 7FFF X d 0064 P0030 0047 P ADC PRMS A1800064dd 0065 P0031 0062 P ADC COID A1800065dd 0066 * RETURN COID A1800066dd 0067 P0032 0C00 ENQ 0 A1800067dd 0068 XFQ 3 A1800068d 0068 P0033 07A3 d 0069 P0034 0C04 ENQ 4 A1800069dd 0070 LR2* RTNOF A1800070d 0070 P0035 0482  0070 P0036 C00E d 0071 NOOP LCA* COID,3 A1800071d 0071 P0037 0483  0071 P0038 C22A d 0072 P0039 584B RTJ* AE A1800072dd 0073 N2 SCA* (A9BASE),2 A1800073d 0073 P003A 04C2  0073 P003B C30B H1 RPGDT1 PAGE 3 DATE: 08/29/84H  d 0074 AR2- ONE A1800074d 0074 P003C 0402  0074 P003D 8003 d 0075 AR3- ONE A1800075d 0075 P003E 0403  0075 P003F 8003 d 0076 P0040 0DFE INQ -1 A1800076dd 0077 P0041 0141 SQZ RET A1800077dd 0078 P0042 18F4 JMP* NOOP A1800078dd 0079 * RETURN A1800079dd 0080 P0043 1CBC RET JMP* (RPGDT1) A1800080dd 0081 * A1800081dd 0082 * A1800082dd 0083 * BUCKETS AND ARRAYS A1800083dd 0084 * A1800084dd 0085 P0044 0000 RTNOF NUM 0 A1800085dd 0086 P0045 0000 PADD NUM 0 A1800086dd 0087 P0046 7FFF X A9BASE ADC R9BASE A1800087dd 0088 P0047 001B BZS PRMS(27),COID(2) A1800088d P0062 0002 d 0089 * A1800089dd 0090 * A1800090dd 0091 * PICK UP NEXT PARAMETER AND ITS ADDRESS A1800091dd 0092 P0064 0000 PICK NUM 0 A1800092dd 0093 P0065 E8DF LDQ* PADD A1800093dd 0094 P0066 C622 LDA- (ZERO),Q CCSGET VALUE A1800094dd 0095 P0067 0900 INA 0 TEST FOR END OF LIST A1800095dd 0096 P0068 0103 SAZ EX1 A1800096dd 0097 P0069 5400 X RTJ R9FLDL RETURNS A-ATTRIBUTE BITS Q- FIELD LENGTH A1800097d P006A 7FFF X d 0098 P006B D8D9 RAO* PADD I- FIELD ADDRESS RELATIVE TO R9BASE A1800098dd 0099 P006C 1CF7 EX1 JMP* (PICK) A1800099dd 0100 *** CONVERSION SUPPORTS NUMERIC, ALPHA, AND BLANKS...NO SPECIAL CHARSA1800100dd 0101 * EBDIC TO ASCII A1800101dd 0102 P006D 0000 EA NUM 0 A1800102dd 0103 P006E 9000 SUB =N$00F0 A1800103d P006F 00F0 d 0104 P0070 0132 SAM L01 SKIP IF ALPHA OR BLANK A1800104dd 0105 P0071 0930 INA $30 NUMERIC A1800105dd 0106 P0072 1CFA JMP* (EA) A1800106dd 0107 P0073 090E L01 INA $E A1800107dd 0108 P0074 0133 SAM L02 A1800108dd 0109 P0075 8000 ADD =N$0053 ISOLATED S-Z A1800109d P0076 0053 d 0110 P0077 1CF5 JMP* (EA) A1800110dd 0111 P0078 0911 L02 INA $11 A1800111dd 0112 P0079 0133 SAM L03 A1800112dd 0113 P007A 8000 ADD =N$004A ISOLATED J - R A1800113d P007B 004A d 0114 P007C 1CF0 JMP* (EA) A1800114dd 0115 P007D 0910 L03 INA $10 A1800115dd 0116 P007E 0133 SAM L04 A1800116dd 0117 P007F 8000 ADD =N$0041 ISOLATED A - I A1800117d P0080 0041 H1 RPGDT1 PAGE 4 DATE: 08/29/84H  d 0118 P0081 1CEB JMP* (EA) A1800118dd 0119 P0082 0A20 L04 ENA $20 A1800119dd 0120 P0083 1CE9 JMP* (EA) A1800120dd 0121 * ASCII TO EBDIC A1800121dd 0122 P0084 0000 AE NUM 0 A1800122dd 0123 P0085 9000 SUB =N$0053 A1800123d P0086 0053 d 0124 P0087 0133 SAM N01 A1800124dd 0125 P0088 8000 ADD =N$00E2 CONVERT S - W A1800125d P0089 00E2 d 0126 P008A 1CF9 JMP* (AE) A1800126dd 0127 P008B 0909 N01 INA 9 A1800127dd 0128 P008C 0133 SAM N02 A1800128dd 0129 P008D 8000 ADD =N$00D1 CONVERT J-R A1800129d P008E 00D1 d 0130 P008F 1CF4 JMP* (AE) A1800130dd 0131 P0090 0909 N02 INA 9 A1800131dd 0132 P0091 0133 SAM N03 A1800132dd 0133 P0092 8000 ADD =N$00C1 CONVERT A - I A1800133d P0093 00C1 d 0134 P0094 1CEF JMP* (AE) A1800134dd 0135 P0095 0911 N03 INA $11 A1800135dd 0136 P0096 0133 SAM N04 A1800136dd 0137 P0097 8000 ADD =N$00F0 CONVERT NUMERIC A1800137d P0098 00F0 d 0138 P0099 1CEA JMP* (AE) A1800138dd 0139 P009A 0A40 N04 ENA $40 FORCE BLANK A1800139dd 0140 P009B 1CE8 JMP* (AE) A1800140dd 0141 END A1800141d  D PGM= 009C ( 156) COM = 0000 ( 0) DAT = 0000 ( 0) D H1 RPGDT1 PAGE 5 DATE: 08/29/84H     E Q U I V A L E N C E S -----------------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0000 I 00FF (000255) HH 0012 ONE 0003 (000003) 0039, 0039, 0040, 0040, 0058, 0058HH 0059, 0059, 0074, 0074, 0075, 0075HH 0013 ZERO 0022 (000034) 0094 HH 0014 LPMASK 0002 (000002) HH1 RPGDT1 PAGE 6 DATE: 08/29/84H     S Y M B O L S -------------  B DEF.LINE NAME ADDRESS REFERENCED AT LINE NUMBER B H 0008 RPGDT1 0000 0008, 0080 HH 0019 STRT 0004 0030, 0045 HH 0025 CONT 0007 0020 HH 0032 CONT1 000D 0026 HH 0036 LOOP 0010 0043 HH 0038 L1 0013 HH 0045 CONT2 001C 0042 HH 0049 CLFTN 001D 0022 HH 0055 MLOOP 0022 0062 HH 0063 FTN 002E 0061 HH 0071 NOOP 0037 0078 HH 0073 N2 003A HH 0080 RET 0043 0077 HH 0085 RTNOF 0044 0049, 0049, 0049, 0070, 0070, 0070HH 0086 PADD 0045 0018, 0093, 0098 HH 0087 A9BASE 0046 0036, 0036, 0036, 0055, 0055, 0055HH 0073, 0073, 0073 HH 0088 PRMS 0047 0038, 0038, 0038, 0064 HH 0088 COID 0062 0057, 0057, 0057, 0065, 0071, 0071HH 0071 HH 0092 PICK 0064 0019, 0099 HH 0099 EX1 006C 0096 HH 0102 EA 006D 0037, 0056, 0106, 0110, 0114, 0118HH 0120 HH 0107 L01 0073 0104 HH 0111 L02 0078 0108 HH 0115 L03 007D 0112 HH 0119 L04 0082 0116 HH 0122 AE 0084 0072, 0126, 0130, 0134, 0138, 0140HH 0127 N01 008B 0124 HH 0131 N02 0090 0128 HH 0135 N03 0095 0132 HH 0139 N04 009A 0136 HH1 RPGDT1 PAGE 7 DATE: 08/29/84H     E X T E R N A L S -----------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0009 R9FLDL 006A 0097 HH 0010 R9BASE 0046 0087 HH 0011 FTNDT1 002F 0063 HH1 RPGDT1 PAGE 8 DATE: 08/29/84H  > *** A L P H A B E T I C A L S O R T O F S Y M B O L S *** >  H A9BASE 0087 AE 0122 CLFTN 0049 COID 0088 CONT 0025 HH CONT1 0032 CONT2 0045 EA 0102 EX1 0099 FTN 0063 HH FTNDT1 0011 I 0000 L01 0107 L02 0111 L03 0115 HH L04 0119 L1 0038 LOOP 0036 LPMASK 0014 MLOOP 0055 HH N01 0127 N02 0131 N03 0135 N04 0139 N2 0073 HH NOOP 0071 ONE 0012 PADD 0086 PICK 0092 PRMS 0088 HH R9BASE 0010 R9FLDL 0009 RET 0080 RPGDT1 0008 RTNOF 0085 HH STRT 0019 ZERO 0013 HP1 PH1 TAPHAN PAGE 1 DATE: 08/29/84H  d 0001 NAM TAPHAN A19 A CCS CCS 3.0 SL-149A1900001dd 0002 * A1900002dd 0003 * CYBERCREDIT SYSTEM VERSION 3 A1900003dd 0004 * DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA A1900004dd 0005 * COPYRIGHT CONTROL DATA CORPORATION, 1979 A1900005dd 0006 * A1900006dd 0007 * A1900007dd 0008 *- FORTRAN INTERFACE FOR MOTION AND STATUS REQUESTS, SPECIFICALLY A1900008dd 0009 *- DESIGNED FOR MAG TAPE REQUESTS. THIS ROUTINE WILL HANDLE THE A1900009dd 0010 *- FOLLOWING REQUESTS USING THE CALLING SEQUENCE GIVEN. A1900010dd 0011 *- 1. MOTION REQUESTS A1900011dd 0012 *- CALL TAPMOT ( LU, ACTION ) A1900012dd 0013 *- WHERE LU IS THE MSOS LOGICAL UNIT ON WHICH TO PERFORM THE A1900013dd 0014 *- REQUEST AND ACTION REFERS TO ONE OF THE FOLLOWING MOTION A1900014dd 0015 *- REQUESTS: A1900015dd 0016 *- 0 = TERMINATES REQUEST 6 = BACKSPACE FILE A1900016dd 0017 *- 1 = BACKSPACE RECORD 7 = ADVANCE RECORD A1900017dd 0018 *- 2 = WRITE END-OF-FILE 8 = WRITE EOF AND REWIND A1900018dd 0019 *- 3 = REWIND 9 = WRITE EOF AND UNLOAD A1900019dd 0020 *- 4 = REWIND AND UNLOAD 10-15 = RESERVED A1900020dd 0021 *- 5 = ADVANCE FILE A1900021dd 0022 *- 2. STATUS REQUESTS A1900022dd 0023 *- I = STATIT ( LU ) (**NOTE: INTEGER FUNCTION)A1900023dd 0024 *- WHERE LU IS THE MSOS LOGICAL UNIT TO RETURN THE STATUS FOR. THE A1900024dd 0025 *- STATUS RETURNED IS WORD TWELVE OF THE PHYSICAL DEVICE TABLE. A1900025d  d 0027 *- PROGRAM ENTRY POINTS. A1900027dd 0028 ENT TAPMOT A1900028dd 0029 ENT STATIT A1900029d  d 0031 *- COMMUNICATIONS REGION USED. A1900031dd 0032 0022 EQU ZERO($22) A1900032dd 0033 00F4 EQU AMONI($F4) A1900033dd 0034 00EA EQU DISP($EA) A1900034dH1 TAPHAN PAGE 2 DATE: 08/29/84H  d 0036 *- A1900036dd 0037 *- MOTION REQUEST PROCESSOR. A1900037dd 0038 *- A1900038dd 0039 P0000 0000 TAPMOT NUM 0 SUBROUTINE ENTRY. A1900039dd 0040 P0001 E8FE LDQ* TAPMOT PICK UP FIRST PARAMETER, THE LOGICAL UNIT. A1900040dd 0041 P0002 0814 TRQ A A1900041dd 0042 P0003 E622 LDQ- (ZERO),Q A1900042dd 0043 P0004 E622 LDQ- (ZERO),Q A1900043dd 0044 P0005 4813 STQ* TAP040 SAVE LOGICAL UNIT IN REQUEST PARAMETER LIST. A1900044dd 0045 P0006 0822 TRA Q PICK UP SECOND PARAMETER, THE MOTION REQUEST. A1900045dd 0046 P0007 0D01 INQ 1 A1900046dd 0047 P0008 0902 INA 2 SAVE RETURN ADDRESS. A1900047dd 0048 P0009 68F6 STA* TAPMOT A1900048dd 0049 P000A E622 LDQ- (ZERO),Q A1900049dd 0050 P000B C622 LDA- (ZERO),Q A1900050dd 0051 P000C 0822 TRA Q VERIFY LEGAL REQUEST (-1 < ACTION < 16) . A1900051dd 0052 P000D 0121 SAP TAP010 A1900052dd 0053 P000E 180D JMP* TAP100 ILLEGAL REQUEST, LESS THAN ZERO. A1900053dd 0054 P000F 09E9 TAP010 INA -$16 A1900054dd 0055 P0010 0131 SAM TAP020 A1900055dd 0056 P0011 180A JMP* TAP100 ILLEGAL REQUEST, GREATER THAN 15. A1900056dd 0057 P0012 CA0A TAP020 LDA* ACTTBL,Q PICK UP MOTION REQUEST CODE FIELD AND A1900057dd 0058 P0013 6806 STA* TAP050 STORE INTO REQUEST PARAMETER LIST. A1900058d d 0060 *- MAKE MOTION REQUEST. A1900060dd 0061 P0014 54F4 TAP030 RTJ- (AMONI) A1900061dd 0062 P0015 5C00 VFD N1/0,N1/1,N5/$E,N1/0,N4/0,N4/0 A1900062dd 0063 P0016 001B P ADC TAP100 COMPLETION A1900063dd 0064 P0017 0000 NUM 0 THREAD A1900064dd 0065 P0018 0000 TAP040 NUM 0 LOGICAL UNIT A1900065dd 0066 P0019 0000 TAP050 NUM 0 MOTION REQUESTS. A1900066dd 0067 P001A 54EA RTJ- (DISP) A1900067d d 0069 *- REQUEST COMPLETE, RETURN. A1900069dd 0070 P001B 1CE4 TAP100 JMP* (TAPMOT) A1900070d  d 0072 *- MOTION REQUEST CODE TABLE. A1900072dd 0073 P001C 0000 ACTTBL NUM 0 0 = TERMINATE A1900073dd 0074 P001D 1000 NUM $1000 1 = BACKSPACE RECORD A1900074dd 0075 P001E 2000 NUM $2000 2 = WRITE END-OF-FILE A1900075dd 0076 P001F 3000 NUM $3000 3 = REWIND A1900076dd 0077 P0020 4000 NUM $4000 4 = REWIND AND UNLOAD A1900077dd 0078 P0021 5000 NUM $5000 5 = ADVANCE FILE A1900078dd 0079 P0022 6000 NUM $6000 6 = BACKSPACE FILE A1900079dd 0080 P0023 7000 NUM $7000 7 = ADVANCE RECORD A1900080dd 0081 P0024 2300 NUM $2300 8 = WRITE END-OF-FILE AND REWIND A1900081dd 0082 P0025 2400 NUM $2400 9 = WRITE END-OF-FILE AND REWIND/UNLOAD A1900082dd 0083 P0026 0000 NUM $0,0,0 10-15 = RESERVED A1900083d P0027 0000  P0028 0000 d 0084 P0029 0000 NUM $0,0,0 A1900084d P002A 0000  P002B 0000 H1 TAPHAN PAGE 3 DATE: 08/29/84H  d 0086 *- A1900086dd 0087 *- STATUS REQUEST PROCESSOR A1900087dd 0088 *- A1900088dd 0089 P002C 0000 STATIT NUM 0 SUBROUTINE ENTRY. A1900089dd 0090 P002D E8FE LDQ* STATIT PICK UP LOGICAL UNIT TO STATIT. A1900090dd 0091 P002E 0814 TRQ A A1900091dd 0092 P002F E622 LDQ- (ZERO),Q A1900092dd 0093 P0030 E622 LDQ- (ZERO),Q A1900093dd 0094 P0031 4807 STQ* STAT10 STORE INTO REQUEST PARAMETER LIST. A1900094dd 0095 P0032 0901 INA 1 SAVE RETURN ADDRES. A1900095dd 0096 P0033 68F8 STA* STATIT A1900096dd 0097 P0034 0A00 ENA 0 ZERO THIRD WORD OF REQUEST. A1900097dd 0098 P0035 6804 STA* STAT15 A1900098d d 0100 *- MAKE STATUS REQUEST. A1900100dd 0101 P0036 54F4 STAT05 RTJ- (AMONI) A1900101dd 0102 P0037 4600 VFD N1/0,N1/1,N5/3,N1/0,N8/0 A1900102dd 0103 P0038 0000 STAT10 NUM 0 LOGICAL UNIT A1900103dd 0104 P0039 0000 STAT15 NUM 0 A1900104d d 0106 *- STATUS COMPLETE, RETURN. A1900106dd 0107 P003A 1CF1 STAT20 JMP* (STATIT) A1900107d  d 0109 END A1900109d  D PGM= 003B ( 59) COM = 0000 ( 0) DAT = 0000 ( 0) D H1 TAPHAN PAGE 4 DATE: 08/29/84H     E Q U I V A L E N C E S -----------------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0000 I 00FF (000255) HH 0032 ZERO 0022 (000034) 0042, 0043, 0049, 0050, 0092, 0093HH 0033 AMONI 00F4 (000244) 0061, 0101 HH 0034 DISP 00EA (000234) 0067 HH1 TAPHAN PAGE 5 DATE: 08/29/84H     S Y M B O L S -------------  B DEF.LINE NAME ADDRESS REFERENCED AT LINE NUMBER B H 0028 TAPMOT 0000 0028, 0040, 0048, 0070 HH 0029 STATIT 002C 0029, 0090, 0096, 0107 HH 0054 TAP010 000F 0052 HH 0057 TAP020 0012 0055 HH 0061 TAP030 0014 HH 0065 TAP040 0018 0044 HH 0066 TAP050 0019 0058 HH 0070 TAP100 001B 0053, 0056, 0063 HH 0073 ACTTBL 001C 0057 HH 0101 STAT05 0036 HH 0103 STAT10 0038 0094 HH 0104 STAT15 0039 0098 HH 0107 STAT20 003A HH1 TAPHAN PAGE 6 DATE: 08/29/84H  > *** A L P H A B E T I C A L S O R T O F S Y M B O L S *** >  H ACTTBL 0073 AMONI 0033 DISP 0034 I 0000 STAT05 0101 HH STAT10 0103 STAT15 0104 STAT20 0107 STATIT 0029 TAP010 0054 HH TAP020 0057 TAP030 0061 TAP040 0065 TAP050 0066 TAP100 0070 HH TAPMOT 0028 ZERO 0032 HP1 PH1 UPD400 PAGE 1 DATE: 08/29/84H  d 0001 NAM UPD400 A20 A CCS CCS 3.0 SL-149 00001dd 0002 * UPD400 ENTRY POINT TO JUMP AROUND LABELLED COMMON 00002dd 0003 * CYBERCREDIT SYSTEM VERSION 3 00003dd 0004 * DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA 00004dd 0005 * COPYRIGHT CONTROL DATA CORPORATION, 1979 00005dd 0006 * 00006dd 0007 ENT UPD400 00007dd 0008 EXT FUPD4X MAIN PROCESSOR MODULE. 00008d d 0010 P0000 1400 X UPD400 JMP FUPD4X PASS CONTROL TO MAIN PROCESSOR. 00010d P0001 7FFF X  d 0012 END 00012d  D PGM= 0002 ( 2) COM = 0000 ( 0) DAT = 0000 ( 0) D H1 UPD400 PAGE 2 DATE: 08/29/84H     E Q U I V A L E N C E S -----------------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0000 I 00FF (000255) HH1 UPD400 PAGE 3 DATE: 08/29/84H     S Y M B O L S -------------  B DEF.LINE NAME ADDRESS REFERENCED AT LINE NUMBER B H 0007 UPD400 0000 0007 HH1 UPD400 PAGE 4 DATE: 08/29/84H     E X T E R N A L S -----------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0008 FUPD4X 0001 0010 HH1 UPD400 PAGE 5 DATE: 08/29/84H  > *** A L P H A B E T I C A L S O R T O F S Y M B O L S *** >  H FUPD4X 0008 I 0000 UPD400 0007 HP1 PH1 UPDATE PAGE 1 DATE: 08/29/84H  d 0001 NAM UPDATE A21 A CCS CCS 3.0 SL-149A2100001dd 0002 * UPDATE ENTRY POINT TO JUMP AROUND LABELLED COMMON A2100002dd 0003 * CYBERCREDIT SYSTEM VERSION 3 A2100003dd 0004 * DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA A2100004dd 0005 * COPYRIGHT CONTROL DATA CORPORATION, 1979 A2100005dd 0006 * A2100006dd 0007 ENT UPDATE A2100007dd 0008 EXT FUPDAT MAIN PROCESSOR MODULE. A2100008d d 0010 P0000 1400 X UPDATE JMP FUPDAT PASS CONTROL TO MAIN PROCESSOR. A2100010d P0001 7FFF X  d 0012 END A2100012d  D PGM= 0002 ( 2) COM = 0000 ( 0) DAT = 0000 ( 0) D H1 UPDATE PAGE 2 DATE: 08/29/84H     E Q U I V A L E N C E S -----------------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0000 I 00FF (000255) HH1 UPDATE PAGE 3 DATE: 08/29/84H     S Y M B O L S -------------  B DEF.LINE NAME ADDRESS REFERENCED AT LINE NUMBER B H 0007 UPDATE 0000 0007 HH1 UPDATE PAGE 4 DATE: 08/29/84H     E X T E R N A L S -----------------  B DEF.LINE NAME VALUE REFERENCED AT LINE NUMBER B H 0008 FUPDAT 0001 0010 HH1 UPDATE PAGE 5 DATE: 08/29/84H  > *** A L P H A B E T I C A L S O R T O F S Y M B O L S *** >  H FUPDAT 0008 I 0000 UPDATE 0007 HP1 PH*K,P06˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙HH*EOF˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙HH*K,L06,P22˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙HH*CTO, MON02 GROUP BEING COMPILED.˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙HH*FTN˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙H t FTN 3.3B (OPT = LPC) ACTADD PAGE 1 DATE: 08/29/84 TIME: 2116 t^ 1 PROGRAM ACTADD B0100001^^ 1 1 /B01 F CCS CCS 3.0 .LA - PSRD SL-149********^^ C B0100003^^ C CYBERCREDIT SYSTEM VERSION 3 B0100004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B0100005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B0100006^^ C B0100007^ ^ C THIS PROGRAM TAKES THE COLLECTOR ACTIVITIES THAT WERE B0100009^^ C GENERATED VIA COLECT AND PLACES THEM IN THE ACTFIL. B0100010^^ C IF NO BLOCK EXISTS IN ACTFIL ONE IS CREATED, IF THE B0100011^^ C ACTIVITY WILL NOT FIT IN AN EXISTING BLOCK A NEW BLOCK B0100012^^ C IS CREATED. B0100013^ ^ 2 INTEGER TDATA(15),ADATA(15),TREQ(24),AREQ(24),TREC(70),SUF(2), B0100015^^ 2 2 AREC(252),ACT(10),OSW,OBUF(1),USER(4),STG(40),LTH(2) B0100016^^ 3 INTEGER UDATA(15),UREQ(24),UREC(40),COID(2) B0100017^^ 4 INTEGER BZ B0100018^ ^ 5 EQUIVALENCE ( AREC(10) , OBUF(1) ) B0100020^ ^ 6 DATA TDATA /'LATRNSFL', 8*$2020, 0, 1, 0 / ********^^ 7 DATA ADATA /'LAACTFIL', 8*$2020, 1, 1, 1 / ********^^ 8 DATA UDATA /'LAUTIFIL', 8*$2020, 1, 1, 0 / ********^^ 9 DATA TREQ, AREQ / 48*0 /, LTH / '0482' / B0100025^^ 10 DATA BZ /'BZ'/, UREQ /24*0/ B0100026^  ^ C ACCEPT ITOS LOG ON B0100028^^ 11 CALL PGMIN ( USER, LU, MODE, NPORT ) B0100029^^ 12 CALL CCSCST(UDATA,1,2,USER,1,8,ISTAT) ********^^ 13 IF(ISTAT.EQ.0) GO TO 5 ********^^ 14 CALL CCSMVA(TDATA,3,6,TDATA,1,8) ********^^ 15 CALL CCSMVA(ADATA,3,6,ADATA,1,8) ********^^ 16 CALL CCSMVA(UDATA,3,6,UDATA,1,8) ********^^ 17 5 CONTINUE ********^  ^ C OPEN FILES FOR USE B0100031^^ 18 CALL OPENFL ( TREQ, TDATA, ISTAT ) B0100032^^ 19 IF ( ISTAT .GE. 0 ) GO TO 100 B0100033^^ C REPORT THE ERROR AND EXIT B0100034^^ 20 CALL FILERR ( TDATA, 3, ISTAT, LU ) B0100035^^ 21 CALL PGMOUT B0100036^ ^ 22 100 CALL OPENFL ( AREQ, ADATA, ISTAT ) B0100038^^ 23 IF ( ISTAT .GE. 0 ) GO TO 110 B0100039^^ C REPORT THE ERROR AND EXIT B0100040^^ 24 CALL FILERR ( ADATA, 3, ISTAT, LU ) B0100041^^ 25 CALL PGMOUT B0100042^ ^ 26 110 CALL OPENFL ( UREQ, UDATA, ISTAT ) B0100044^^ 27 UREQ(23) = 1 ********^^ 28 IF ( ISTAT .GE. 0 ) GO TO 200 B0100045^t FTN 3.3B (OPT = LPC) ACTADD PAGE 2 DATE: 08/29/84 TIME: 2116 t^ C REPORT ERROR AND EXIT B0100046^^ 29 CALL FILERR ( UDATA, 3, ISTAT, LU ) B0100047^^ 30 CALL PGMOUT B0100048^t FTN 3.3B (OPT = LPC) ACTADD PAGE 3 DATE: 08/29/84 TIME: 2116 t^ C GET THE NEXT RECORD FROM THE TRNSFL B0100050^^ 31 200 CALL GETS ( TREQ, TREC, I, ISTAT ) B0100051^^ C EOF ? B0100052^^ 32 IF ( AND(ISTAT,$100) .EQ. $100 ) GO TO 500 B0100053^^ 33 IF ( ISTAT .GE. 0 ) GO TO 210 B0100054^^ C REPORT THE ERROR AND EXIT B0100055^^ 34 CALL FILERR ( TDATA, 14, ISTAT, LU ) B0100056^^ 35 CALL PGMOUT B0100057^ ^ C IS THIS AN ACTIVITY RECORD ? B0100059^^ 36 210 IF ( TREC(15) .NE. $3031 ) GO TO 200 B0100060^^ C ****************************************************** ???*0012********^^ C 3 LINES DELETED ********^^ C ****************************************************** ???*0012********^ ^ C THIS IS AN ACTIVITY RECORD, SET UP THE ACTFIL KEY B0100065^^ 37 CALL CCSMVA ( TREC, 1, 16, ACT, 1, 18 ) B0100066^^ C GET THE ACTFIL RECORD IF IF EXISTS B0100067^^ 38 CALL READR ( AREQ, AREC, ACT, ISTAT ) B0100068^^ C EOF ? B0100069^^ 39 IF ( AND(ISTAT,$100) .EQ. $100 ) GO TO 215 B0100070^^ 40 IF ( ISTAT .GE. 0 ) GO TO 215 B0100071^^ C REPORT THE ERROR AND EXIT B0100072^^ 41 CALL FILERR ( ADATA, 13, ISTAT, LU ) B0100073^^ 42 CALL PGMOUT B0100074^ ^ C READ THE UTIFIL TO GET THE COLLECTOR NAME B0100076^^ 43 215 CALL CCSMVA ( TREC, 17, 4, COID, 1, 4 ) B0100077^^ 44 CALL READR ( UREQ, UREC, COID, ISTAT ) B0100078^^ 45 IF ( ISTAT .GE. 0 ) GO TO 220 B0100079^^ C REPORT ERROR AND EXIT B0100080^^ 46 CALL FILERR ( UDATA, 13, ISTAT, LU ) B0100081^^ 47 CALL PGMOUT B0100082^ ^ C SET UP THE STRING FOR THE PUTACF CALL B0100084^^ 48 220 CALL CCSMVA ( TREC, 31, 12, STG, 1, 12 ) B0100085^^ 49 CALL CCSMVA ( UREC, 5, 4, STG, 13, 4 ) B0100086^^ 50 CALL CCSMVA ( TREC, 43, 56, STG, 17, 60 ) B0100087^^ 51 OSW = $3030 B0100088^^ 52 SUF(2) = $3530 B0100089^^ C CHECK IF THE ACFIL RECORD IS THE CORRECT ACCOUNT B0100090^^ 53 CALL CCSCST ( AREC, 1, 16, TREC, 1, 16, ICOMP ) B0100091^^ 54 IF ( ICOMP .NE. 0 ) GO TO 300 B0100092^^ C ****************************************************** ???*A028********^^ C VERIFY BLOCK IS > 51 (I.E., BLOCK DID NOT COME FROM ********^^ C TAPE HISTORY) ********^^ 55 IF ( AREC(9) .GT. $3530 ) GO TO 300 ********^^ C ****************************************************** ???*A028********^ ^ C ATTEMPT TO PUTACF IN THE ACTFIL BLOCK B0100094^^ 56 CALL PUTACF ( STG, OBUF, LTH, OSW ) B0100095^^ C WAS THE PUTACF SUCCESSFUL ? B0100096^^ 57 IF (OSW .NE. $3030) GO TO 230 B0100097^^ C IT WAS SUCCESSFUL, UDATE THE ACTFIL RECORD B0100098^t FTN 3.3B (OPT = LPC) ACTADD PAGE 4 DATE: 08/29/84 TIME: 2116 t^ 58 CALL UPDREC ( AREQ, AREC, ISTAT ) B0100099^^ 59 IF ( ISTAT .GE. 0 ) GO TO 200 B0100100^^ C REPORT THE ERROR AND EXIT B0100101^^ 60 CALL FILERR ( ADATA, 15, ISTAT, LU ) B0100102^^ 61 CALL PGMOUT B0100103^ ^ C THE PUT WAS UNSUCCESSFUL, CREATE A NEW BLOCK B0100105^^ 62 230 SUF(2) = AREC(9) - 1 B0100106^^ 63 IF ( AND(SUF(2),$FF) .LT. $30 ) SUF(2) = SUF(2) - $F6 B0100107^ ^ C BLANK THE BLOCK, CREATE THE KEY FOR THE NEW ACTFIL RECORD B0100109^^ 64 300 CALL CCSBLK ( AREC, 500 ) B0100110^^ 65 CALL CCSMVA ( TREC, 1, 16, AREC, 1, 16 ) B0100111^^ 66 AREC(9) = SUF(2) B0100112^^ 67 CALL CCSMVA ( AREC, 1, 18, ACT, 1, 18 ) B0100113^^ C PLACE THE ACTIVITY IN THE BLOCK B0100114^^ 68 OSW = $3030 B0100115^^ 69 CALL PUTACF ( STG, OBUF, LTH, OSW ) B0100116^^ C PLACE THE RECORD IN THE ACTFIL B0100117^^ 70 CALL WRITER ( AREQ, AREC, ACT, ISTAT ) B0100118^^ 71 IF ( ISTAT .GE. 0 ) GO TO 200 B0100119^^ C REPORT THE ERROR AND EXIT B0100120^^ 72 CALL FILERR ( ADATA, 12, ISTAT, LU ) B0100121^^ 73 CALL PGMOUT B0100122^  ^ C CLOSE THE FILES B0100124^^ 74 500 CALL CLOSFL ( TREQ, ISTAT ) B0100125^^ 75 CALL CLOSFL ( AREQ, ISTAT ) B0100126^^ 76 CALL PGMOUT B0100127^^ 77 END B0100128^t FTN 3.3B (OPT = LPC) ACTADD PAGE 5 DATE: 08/29/84 TIME: 2116 t  PROGRAM LENGTH $0370 ( 880)   EXTERNALS 2 Q8STP PGMIN CCSCST CCSMVA OPENFL FILERR PGMOUT 22 GETS READR PUTACF UPDREC CCSBLK WRITER CLOSFL 2 t FTN 3.3B (OPT = LPC) ACTADD PAGE 6 DATE: 08/29/84 TIME: 2116 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < L 0001 (1) 0002 2,5,6,7,8,12,14,15,16,27,37,43,48,53,62,65,67L. 0002 (2) 0223 12,52,62,63,66 .0 0003 (3) 0226 14,15,16,20,24,290( 0004 (4) 0230 43,43,49 (" 0005 (5) 0233 49 "( 0006 (6) 0227 14,15,16 (* 0008 (8) 0224 12,14,15,16*( 000C (12) 0232 48,48,72 (( 000D (13) 022E 41,46,49 (" 000E (14) 022A 34 "" 000F (15) 023A 60 "( 0010 (16) 022C 37,53,65 ($ 0011 (17) 022F 43,50$$ 0012 (18) 022D 37,67$" 001F (31) 0231 48 "" 002B (43) 0234 50 "" 0038 (56) 0235 50 "" 003C (60) 0236 50 "" 00F6 (246) 023C 63 "" 00FF (255) 023B 63 "( 0100 (256) 0229 32,32,39 (" 01F4 (500) 023D 64 "( 3030 (12336) 0237 51,57,68 (" 3031 (12337) 022B 36 "$ 3530 (13616) 0238 52,55$   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < , ACT INTEGER 0195 1,37,38,67,70,4 ADATA INTEGER 0012 1,7,15,22,24,41,60,724( AND INTR.FN. 7FFF 32,39,63 (@ AREC INTEGER 0099 1,5,38,53,55,58,62,64,65,66,67,70@2 AREQ INTEGER 0039 1,9,22,38,58,70,75 2$ BZ INTEGER 021F 2,10 $& COID INTEGER 021D 2,43,44&" I INTEGER 0228 31 "$ ICOMP INTEGER 0239 53,54$x ISTAT INTEGER 0225 12,13,18,19,20,22,23,24,26,28,29,31,32,33,34,38,39,40,41,44,45,46,58,59,60,70,71,72,74,75x( LTH INTEGER 01CC 2,9,56,69(: LU INTEGER 0220 11,20,24,29,34,41,46,60,72 :" MODE INTEGER 0221 11 "" NPORT INTEGER 0222 11 "t FTN 3.3B (OPT = LPC) ACTADD PAGE 7 DATE: 08/29/84 TIME: 2116 t( OBUF INTEGER 00A2 1,5,56,69(0 OSW INTEGER 019F 1,51,56,57,68,69 00 STG INTEGER 01A4 2,48,49,50,56,69 0, SUF INTEGER 0097 1,52,62,63,66,. TDATA INTEGER 0003 1,6,14,18,20,34.8 TREC INTEGER 0051 1,31,36,37,43,48,50,53,658, TREQ INTEGER 0021 1,9,18,31,74 ,2 UDATA INTEGER 01CE 2,8,12,16,26,29,46 2& UREC INTEGER 01F5 2,44,49&, UREQ INTEGER 01DD 2,10,26,27,44,& USER INTEGER 01A0 2,11,12&   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " CCSBLK SUBROUTINE 033A 64 "$ CCSCST SUBROUTINE 02FF 11,53$< CCSMVA SUBROUTINE 0347 13,15,16,37,43,48,49,50,65,67<$ CLOSFL SUBROUTINE 0367 74,75$6 FILERR SUBROUTINE 0327 19,24,29,34,41,46,60,726" GETS SUBROUTINE 0295 31 "( OPENFL SUBROUTINE 0268 17,22,26 (" PGMIN SUBROUTINE 023F 10 ": PGMOUT SUBROUTINE 032D 20,25,30,35,42,47,61,73,76 :$ PUTACF SUBROUTINE 0312 55,69$ Q8STP INTEGER.FN. 036F $ READR SUBROUTINE 02B8 37,44$" UPDREC SUBROUTINE 031C 57 "" WRITER SUBROUTINE 0356 69 "   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 5 0267 13,17$$ 100 0277 19,22$$ 110 0284 23,26$. 200 0294 28,31,36,59,71 .$ 210 02AA 33,36$( 215 02CB 39,40,43 ($ 220 02E1 45,48$$ 230 032E 57,62$( 300 0339 54,55,64 ($ 500 0366 32,74$ ACTADD 0000 1  t FTN 3.3B (OPT = LPC) ACTMTN PAGE 1 DATE: 08/29/84 TIME: 2117 t^ 1 PROGRAM ACTMTN B0300001^^ 1 1 /B03 F CCS CCS 3.0 &LA SL-149********^^ C B0300003^^ C CYBERCREDIT SYSTEM VERSION 3 B0300004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B0300005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B0300006^^ C B0300007^ ^ C THIS PROGRAM DETERMINES THE NUMBER OF ACTIVITY BLOCKS B0300009^^ C THAT EACH ACCOUNT IN THE ACTFIL HAS AND THEN PRINTS A B0300010^^ C REPORT GIVING A SUMMARY LIST OF # OF ACCOUNTS WITH # B0300011^^ C OF BLOCKS. THIS PROGRAM THEN PROMPTS THE OPERATOR TO SEE B0300012^^ C IF ANY BLOCKS ARE TO PURGED, IF THEY ARE THEN THE B0300013^^ C OPERATOR IS PROMPTED TO DETERMINE THE LEVEL THAT IS B0300014^^ C TO BE PURGED, E.G. ANY BLOCK GREATER THAN 8. B0300015^ ^ 2 INTEGER ADATA(15),AREC(250),OLDACT(8),KEY(8),USER(4),AREQ(24), B0300017^^ 2 1 BLKTBL(11),BLKCNT,HD(3,20),DT(3) B0300018^ ^ 3 DATA ADATA / 'LAACTFIL', 8*$2020, 1, 1, 0 / ********^^ 4 DATA AREQ / 24*0 /, BLKCNT / 1 /, BLKTBL / 11*0 / B0300021^^ 5 DATA KEY / 8*0 /, OLDACT / 8*$2020 /, IFRST / 0 / B0300022^  ^ C ACCEPT ITOS LOG IN B0300024^^ 6 CALL PGMIN ( USER, LU, MODE, NPORT ) B0300025^^ 7 CALL CCSCST(ADATA,1,2,USER,1,8,ICM) ********^^ 8 IF(ICM.NE.0)CALL CCSMVA(ADATA,3,6,ADATA,1,8) ********^ ^ C GET THE LINE PRINTER REPORT HEADINGS B0300027^^ 9 CALL UTHEAD ( HD, DT ) B0300028^  ^ C OPEN ACTFIL FOR USE B0300030^^ 10 CALL OPENFL ( AREQ, ADATA, ISTAT ) B0300031^^ 11 IF ( ISTAT .GE. 0 ) GO TO 100 B0300032^^ C REPORT THE ERROR AND EXIT B0300033^^ 12 CALL FILERR ( ADATA, 3, ISTAT, LU ) B0300034^^ 13 CALL PGMOUT B0300035^t FTN 3.3B (OPT = LPC) ACTMTN PAGE 2 DATE: 08/29/84 TIME: 2117 t^ C GET THE NEXT RECORD FROM THE ACTFIL B0300037^^ 14 100 CALL GETS ( AREQ, AREC, KEY, ISTAT ) B0300038^^ C EOF ? B0300039^^ 15 IF ( AND(ISTAT,$100) .EQ. $100 ) GO TO 500 B0300040^^ 16 IF ( ISTAT .GE. 0 ) GO TO 200 B0300041^^ C REPORT THE ERROR AND EXIT B0300042^^ 17 CALL FILERR ( ADATA, 14, ISTAT, LU ) B0300043^^ 18 CALL PGMOUT B0300044^ ^ C SAME ACCOUNT NUMBER ? B0300046^^ 19 200 CALL CCSCST ( AREC, 1, 16, OLDACT, 1, 16, ICOMP ) B0300047^^ 20 IF ( ICOMP .EQ. 0 ) GO TO 300 B0300048^^ 21 IF ( IFRST .EQ. 0 ) GO TO 250 B0300049^ ^ C THIS IS A NEW ACCOUNT SAVE THE PREVIOUS ACCOUNTS COUNT B0300051^^ 22 IF ( BLKCNT .GT. 11 ) BLKCNT = 11 B0300052^^ 23 BLKTBL ( BLKCNT ) = BLKTBL ( BLKCNT ) + 1 B0300053^^ 24 BLKCNT = 1 B0300054^^ C SAVE THE NEW ACCOUNT NUMBER B0300055^^ 25 250 CALL CCSMVA ( AREC, 1, 16, OLDACT, 1, 16 ) B0300056^^ 26 IFRST = 1 B0300057^^ 27 GO TO 100 B0300058^  ^ C THIS IS THE SAME ACCOUNT, JUST INCREMENT THE COUNTER B0300060^^ 28 300 BLKCNT = BLKCNT + 1 B0300061^^ 29 GO TO 100 B0300062^  ^ C SAVE THE LAST COUNT B0300064^^ 30 500 IF ( BLKCNT .GT. 11 ) BLKCNT = 11 B0300065^^ 31 BLKTBL ( BLKCNT ) = BLKTBL ( BLKCNT ) + 1 B0300066^ ^ C PRINT THE TABLE B0300068^^ 32 WRITE ( 12, 4000 ) HD , DT B0300069^^ 33 WRITE ( LU, 1000 ) B0300070^^ 34 WRITE ( 12, 1000 ) B0300071^^ 35 DO 600 I = 1, 10 B0300072^^ 36 WRITE ( 12, 2000 ) BLKTBL(I), I B0300073^^ 37 600 WRITE ( LU, 2000 ) BLKTBL(I), I B0300074^^ 38 WRITE ( 12, 3000 ) BLKTBL(11) B0300075^^ 39 WRITE ( LU, 3000 ) BLKTBL(11) B0300076^  ^ C CLOSE ACTFIL , TERMINATE B0300078^^ 40 CALL CLOSFL ( AREQ, ISTAT ) B0300079^^ 41 CALL PGMOUT B0300080^  ^ C REPORT FORMATS B0300082^^ 42 1000 FORMAT (//, 14X, 'THE FOLLOWING IS A SUMMARY OF THE NUMBER OF', / B0300083^^ 42 1 14X, 'ACCOUNTS WITH XXX NUMBER OF ACTIVITY BLOCKS', / ) B0300084^ ^ 43 2000 FORMAT (14X, I5, ' ACCOUNTS WITH ' , I2, ' ACTIVITY BLOCKS' ) B0300086^t FTN 3.3B (OPT = LPC) ACTMTN PAGE 3 DATE: 08/29/84 TIME: 2117 t ^ 44 3000 FORMAT (14X, I5, ' ACCOUNTS WITH >10 ACTIVITY BLOCKS', // ) B0300088^ ^ 45 4000 FORMAT ( 1H1, /, 1X, 20A2,/,1X,20A2,/,1X,20A2,3X,'AS OF : ', B0300090^^ 45 1 A2,'/',A2,'/',A2,/ ) B0300091^ ^ 46 END B0300093^t FTN 3.3B (OPT = LPC) ACTMTN PAGE 4 DATE: 08/29/84 TIME: 2117 t  PROGRAM LENGTH $0307 ( 775)   EXTERNALS 2 Q8STP Q8QINI Q8QX Q8QEND PGMIN CCSCST CCSMVA 2, UTHEAD OPENFL FILERR PGMOUT GETS CLOSFL , t FTN 3.3B (OPT = LPC) ACTMTN PAGE 5 DATE: 08/29/84 TIME: 2117 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < > 0001 (1) 0002 3,4,7,8,19,23,24,25,26,28,31,35> 0002 (2) 0189 7 & 0003 (3) 018C 8,12,32& 0006 (6) 018D 8 " 0008 (8) 018A 7,8"" 000E (14) 0190 17 "( 0010 (16) 0191 19,19,25 ($ 0100 (256) 018F 15,15$   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < 0 ADATA INTEGER 0005 1,3,7,8,10,12,17 0" AND INTR.FN. 7FFF 15 "* AREC INTEGER 0014 1,14,19,25 *, AREQ INTEGER 0122 1,4,10,14,40 ,4 BLKCNT INTEGER 0145 1,4,22,23,24,28,30,3144 BLKTBL INTEGER 013A 1,4,23,31,36,37,38,394& DT INTEGER 0182 1,9,32 && HD INTEGER 0146 1,9,32 &( I INTEGER 0193 34,36,37 (" ICM INTEGER 018B 7,8"$ ICOMP INTEGER 0192 19,20$& IFRST INTEGER 0185 5,21,26&6 ISTAT INTEGER 018E 10,11,12,14,15,16,17,406& KEY INTEGER 0116 1,5,14 &0 LU INTEGER 0186 6,12,17,33,37,39 0 MODE INTEGER 0187 6 NPORT INTEGER 0188 6 ( OLDACT INTEGER 010E 1,5,19,25(" Q8QX1 INTEGER 0003 32 "" Q8QX2 INTEGER 0004 32 "$ USER INTEGER 011E 1,6,7$t FTN 3.3B (OPT = LPC) ACTMTN PAGE 6 DATE: 08/29/84 TIME: 2117 t   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < $ CCSCST SUBROUTINE 019B 6,19 $$ CCSMVA SUBROUTINE 01A7 8,25 $" CLOSFL SUBROUTINE 0270 39 "$ FILERR SUBROUTINE 01BB 11,17$" GETS SUBROUTINE 01C3 14 " OPENFL SUBROUTINE 01B3 9 PGMIN SUBROUTINE 0195 5 ( PGMOUT SUBROUTINE 0274 12,18,41 ( Q8QEND INTEGER.FN. 0230 Q8QINI INTEGER.FN. 0204 . Q8QX SUBROUTINE 0216 32,36,37,38,39 . Q8STP INTEGER.FN. 0306 UTHEAD SUBROUTINE 01AF 8    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < * 100 01C2 11,14,27,29*$ 200 01D6 16,19$$ 250 01F0 21,25$$ 300 01FA 20,28$$ 500 01FC 15,30$$ 600 024C 34,37$( 1000 0276 33,34,42 (( 2000 02AE 36,37,43 (( 3000 02C9 38,39,44 ($ 4000 02E3 31,45$ ACTMTN 0000 1 t FTN 3.3B (OPT = LPC) ADDDT1 PAGE 1 DATE: 08/29/84 TIME: 2117 t^ 1 SUBROUTINE ADDDT1 ( TABLE, ILU, IND) B0400001^^ 1 1 /B04 F CCS CCS 3.0 SL-149B0400002^^ C B0400003^^ C CYBERCREDIT SYSTEM VERSION 3 B0400004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B0400005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B0400006^^ C B0400007^^ C SUBROUTINE BUILDS A TEST INTO TABLE FROM CONVERSTATIONAL DIALOG B0400008^^ C WITH ILU B0400009^^ 2 INTEGER ELIT (8,4), PA(3), PB(3), CONLIT(3), RESLIT(2,5) , B0400010^^ 2 1 ER2LIT (12,2) B0400011^^ 3 DATA ELIT /'BAD OPERATOR BAD CONNECTOR PB .LE. PA BAD SYB0400012^^ 3 1NTAX '/ B0400013^^ 4 DATA ER2LIT /' TYPE Y IF CORRECT SYNTAX ERROR, REENTER '/ B0400014^^ 5 INTEGER WP, INPUT(40), Y B0400015^^ 6 INTEGER TABLE(11), TABLEN, CURPOS, TRES, MSG(3) B0400016^^ 7 DATA MSG / 'INPUT=' / B0400017^^ 8 EQUIVALENCE ( TABLE(2),TABLEN), (TABLE(10), CURPOS), B0400018^^ 8 1(TABLE(9), MAXTAB), (TABLE(8), LSTLFG), (TABLE(7), TRES) , B0400019^^ 8 2 (ICTST,TABLE(5)) B0400020^^ C TABLEN - TOTAL TABLE LENGTH B0400021^^ C CURPOS - CURRENT OFFSET IN TABLE TO CCSPUT THE NEXT DATA B0400022^^ C MAXTAB - MAXIMUM TABLE LENGTH AS DEFINED AT COMPILATION B0400023^^ C LSTLFG - LAST TEST FLAG ( =1 IF ADDING TEST TO TABLE END) B0400024^^ C TRES - OFFSET IN TABLE TO NUMBER OF RESULTS FIELD B0400025^^ C ICTST - OFFSET TO BEGINNING OF THIS TEST B0400026^^ 9 DATA LVL /0/, NLVL /0/, NP/0/, Y/'Y '/ B0400027^^ 10 IND = 0 B0400028^  ^ C DETERMINE NUMBER OF TESTS IN TABLE B0400030^^ 11 IMAXT = 0 B0400031^^ 12 LC = 11 B0400032^^ C CHECK FOR NEW TABLE B0400033^^ 13 IF ( TABLEN .EQ. 10) GO TO 200 B0400034^^ 14 100 IF ( TABLE(LC) .EQ. 0) GO TO 150 B0400035^^ 15 IMAXT = IMAXT + 1 B0400036^^ 16 LC = LC + TABLE(LC) B0400037^^ 17 IF (LC .GT. TABLEN + 1) GO TO 8000 B0400038^^ 18 GO TO 100 B0400039^^ C END OF TABLE - VERIFY B0400040^^ 19 150 IF ( TABLEN .NE. LC - 1) GO TO 8000 B0400041^  ^ 20 200 WRITE ( ILU,9000) IMAXT B0400043^^ 21 9000 FORMAT ( ' ADD TEST IN PROCESS. THERE ARE ' , I3, B0400044^^ 21 1 ' TESTS CURRENTLY IN TABLE' ,/, ' ENTER 3-DIGIT NUMBER OF TEST TB0400045^^ 21 2HAT PRECEEDS YOUR NEW TEST',/ ) B0400046^^ 22 CALL WTREAD ( ILU,-1, MSG, 6,-1, INPUT, 3, LN ) B0400047^^ 23 LN = (AND(INPUT(1),$F00)/$100)*100 + B0400048^^ 23 1 (AND(INPUT(1),$F))*10 + B0400049^^ 23 2 AND(INPUT(2),$F00)/$100 B0400050^^ C MAKE SURE LINE NUM IS WITHIN RANGE B0400051^^ 24 IF ( LN .LT. 0 .OR. LN .GT. IMAXT) GO TO 200 B0400052^t FTN 3.3B (OPT = LPC) ADDDT1 PAGE 2 DATE: 08/29/84 TIME: 2117 t^ C** LEVEL ENTRY SECTION B0400054^  ^ 25 LN = LN + 1 B0400056^^ 26 240 WRITE (ILU, 9010) LN B0400057^^ 27 9010 FORMAT ( ' STARTING TO DEVELOP A NEW TEST, NO=', I3, /, B0400058^^ 27 1 ' ENTER LEVEL NUMBER (1-9) THEN NEXT LEVEL (0-9) THEN NUMBER OFB0400059^^ 27 2 PARMS (1-9). ' ,/, ' SEPERATE FIELDS BY COMMAS, FOR EXAMPLE, INB0400060^^ 27 3PUT=1,0,3 ',/) B0400061^^ 28 250 CALL WTREAD ( ILU,-1, MSG, 6,-1, INPUT, 5, NP ) B0400062^^ 29 LVL = AND(INPUT(1),$FF00)/$100 B0400063^^ 30 NLVL = AND(INPUT(2),$FF00)/$100 B0400064^^ 31 NP = AND(INPUT(3),$FF00)/$100 B0400065^^ C EDIT AND CONVERT ENTERED FIELDS B0400066^^ 32 LVL = NUMDT1(LVL) B0400067^^ 33 NLVL = NUMDT1 (NLVL) B0400068^^ 34 NP = NUMDT1(NP) B0400069^^ 35 IF ( LVL .LT. 1 .OR. NLVL .LT. 0 .OR. NP .LT. 1) GO TO 300 B0400070^^ C CHECK LEVEL VS. SURROUNDING TESTS B0400071^^ 36 IF ( LN .EQ. 1 ) GO TO 270 B0400072^^ C CCSGET POSITION OF PREVIOUS TEST B0400073^^ 37 CALL GTPDT1 ( TABLE, LN-1, WP) B0400074^^ 38 CALL CCSGET ( TABLE(WP), 3, LVLP) B0400075^^ C CHECK FOR LEVEL BELOW PREVIOUS TEST LEVEL (ERROR CONDITION) B0400076^^ 39 IF ( LVL .LT. NUMDT1(LVLP) ) GO TO 310 B0400077^^ 40 270 IF ( LN .GT. IMAXT) GO TO 280 B0400078^^ 41 CALL GTPDT1 ( TABLE, LN, WP) B0400079^^ 42 CALL CCSGET ( TABLE(WP), 3, LVLN) B0400080^^ C CHECK FOR LEVEL ABOVE NEXT TEST LEVEL (ERROR CONDITION) B0400081^^ 43 IF ( LVL .GT. NUMDT1(LVLN) ) GO TO 310 B0400082^^ 44 LSTLFG = 0 B0400083^^ 45 GO TO 285 B0400084^^ C ADD TEST TO END B0400085^^ 46 280 LSTLFG = 1 B0400086^^ C VERIFY VALUES WITH OPERATOR B0400087^^ 47 285 WRITE ( ILU, 9035) LVL, NLVL, NP B0400088^^ 48 9035 FORMAT ( ' LVL=' ,I1, ', NLVL=' ,I1, ', NP=' ,I1, ' TYPE Y IF CORB0400089^^ 48 1RECT, TYPE N TO ENTER AGAIN.',/) B0400090^^ 49 CALL WTREAD ( ILU,-1, MSG, 6,-1, INPUT, 1, IND ) B0400091^^ 50 INPUT(1) = AND(INPUT(1),$FF00) + $20 B0400092^^ 51 IF ( INPUT(1) .NE. Y ) GO TO 240 B0400093^^ C MOVE LVL INFO TO TABLE B0400094^^ 52 CALL ALVDT1 ( TABLE, LN, LVL, NLVL, NP, IND) B0400095^^ 53 IF ( IND .LT. 0) GO TO 8100 B0400096^^ 54 GO TO 400 B0400097^ ^ C ERROR CONDITIONS ON LEVELS OR PARAMETERS B0400099^^ C NON-NUMERIC FIELD B0400100^^ 55 300 WRITE(ILU,9030)(INPUT(J), J = 1,3) B0400101^^ 56 9030 FORMAT ( 'NON-NUMERIC FIELD IN LAST INPUT, INPUT=', 2A2,A1, B0400102^^ 56 1 ' RE-ENTER LAST INPUT',/) B0400103^^ 57 GO TO 250 B0400104^^ C LEVEL NUMBER INCOMPATABILITY B0400105^^ 58 310 WRITE ( ILU, 9031) LVL B0400106^t FTN 3.3B (OPT = LPC) ADDDT1 PAGE 3 DATE: 08/29/84 TIME: 2117 t^ 59 9031 FORMAT ( 'LEVEL ERROR, LEVEL= ', I1, ' LEVEL MUST BE .GE. PREVIOUB0400107^^ 59 1S LVL' ,/, ' AND .LE. NEXT TEST LEVEL' ,/, B0400108^^ 59 2 ' REENTER LAST INPUT',/ ) B0400109^^ 60 GO TO 250 B0400110^t FTN 3.3B (OPT = LPC) ADDDT1 PAGE 4 DATE: 08/29/84 TIME: 2117 t^ C** PARAMETER ENTRY SECTION B0400112^  ^ 61 400 IP = 1 B0400114^^ C START PARAMETER PICK-UP LOOP B0400115^^ 62 405 IF ( IP .GT. NP ) GO TO 600 B0400116^^ 63 IF ( IP .NE. 1) GO TO 407 B0400117^^ 64 WRITE ( ILU, 9040) IP B0400118^^ 65 9040 FORMAT ( ' ENTER PARAMETER ',I1, ' INFO. ENTER OPERATOR (NULL/.EQB0400119^^ 65 1./.LE./.GT./.NE./.WE./.OS.)',/, B0400120^^ 65 2 ' FOLLOWED BY 6 CHARACTER PARAMETER VALUE ( 2 VALUES IF OPERATORB0400121^^ 65 3 IS .WE./.OS.' ,/, ' FOLLOWED BY CONNECTOR (.AND./.OR.).' ,/, B0400122^^ 65 4 ' SEPERATE FIELDS BY COMMA, FOR EXAMPLE,' ,/, B0400123^^ 65 5 ' INPUT=.WE.,000500,000650,.AND. ',/ ) B0400124^^ 66 GO TO 409 B0400125^^ 67 407 WRITE ( ILU, 9045) IP B0400126^^ 68 9045 FORMAT ( ' ENTER PARAMETER ',I1, ' INFO.',/) B0400127^^ 69 409 IF (IP .NE. NP) GO TO 410 B0400128^^ 70 WRITE (ILU, 9044) B0400129^^ 71 9044 FORMAT ( ' DO NOT INPUT CONNECTOR ON THIS LAST PARAMETER.',/) B0400130^^ 72 410 CONTINUE B0400131^^ 73 DO 411 I = 1,13 B0400132^^ 74 411 INPUT(I) = $2020 B0400133^^ 75 CALL WTREAD ( ILU, -1, MSG, 6, -1, INPUT, 26, LPN ) B0400134^^ 76 9041 FORMAT (12A2) B0400135^^ C EDIT OPERATOR, CONNECTOR, AND VALUE RANGE B0400136^^ C SET LAST PARAMETER INDICATOR B0400137^^ 77 LPN = 0 B0400138^^ 78 IF (IP .EQ. NP) LPN = 1 B0400139^^ 79 CALL PMEDT1 ( INPUT(1), LPN, IOP, ICON, CONLIT, PA, PB, IND) B0400140^^ 80 IF ( IND .LT. 0) GO TO 500 B0400141^^ C PARAMETERS CHECK OUT, RE-DISPLAY FOR VERIFICATION B0400142^^ 81 IF ( IOP.GT.4) GO TO 460 B0400143^^ 82 WRITE (ILU, 9042) ( INPUT(J), J=1, 2), PA, CONLIT B0400144^^ 83 9042 FORMAT ( ' OP=',2A2, ', PA=', 3A2, ', CON=',3A2, B0400145^^ 83 1 ' TYPE Y IF CORRECT, N TO REENTER',/) B0400146^^ 84 GO TO 465 B0400147^^ 85 460 WRITE (ILU, 9043) (INPUT(J), J= 1, 2), PA, PB, CONLIT B0400148^^ 86 9043 FORMAT ( ' OP=',2A2, ', PA=', 3A2, ', PB=', 3A2, ', CON=',3A2B0400149^^ 86 1 , ' TYPE Y IF CORRECT',/) B0400150^^ 87 465 CONTINUE B0400151^^ 88 CALL WTREAD ( ILU, -1, MSG, 6, -1, INPUT, 1, IND ) B0400152^^ 89 INPUT = AND(INPUT,$FF00) + $20 B0400153^^ 90 IF ( INPUT(1) .EQ. Y) GO TO 475 B0400154^^ 91 GO TO 405 B0400155^^ C MOVE PARAMETER INFO TO TABLE B0400156^^ 92 475 CALL APMDT1 ( TABLE,LPN, IOP, PA , PB , ICON, IND) B0400157^^ 93 IF ( IND .LT. 0) GO TO 8200 B0400158^^ C INCRAMENT PARAMETER COUNT AND LOOP B0400159^^ 94 IP = IP + 1 B0400160^^ 95 GO TO 405 B0400161^ ^ C ILLEGAL PARAMETER INPUT B0400163^^ 96 500 IND = AND ($0007,IND) B0400164^t FTN 3.3B (OPT = LPC) ADDDT1 PAGE 5 DATE: 08/29/84 TIME: 2117 t^ 97 WRITE ( ILU, 9050) (INPUT(J), J=1,11),(ELIT(JJ,IND),JJ=1,8) B0400165^^ 98 9050 FORMAT ( ' ERROR IN LAST INPUT. REENTER LAST LINE. ' ,/, B0400166^^ 98 1 'INPUT=', 11A2, 6X, 8A2) B0400167^^ 99 GO TO 410 B0400168^t FTN 3.3B (OPT = LPC) ADDDT1 PAGE 6 DATE: 08/29/84 TIME: 2117 t^ C** RESULT (COLLECTOR) ENTRY SECTION B0400170^  ^ 100 600 IRE = -4 B0400172^^ 101 WRITE ( ILU, 9060) B0400173^^ 102 9060 FORMAT ( ' ENTER RESULTS (COLLECTOR NUMBERS OR PRIORITY) TO ASSIGNB0400174^^ 102 1 IF TEST IS TRUE ',/, ' FIRST ENTER 2 DIGIT COUNT OF RESULTS TO B0400175^^ 102 2BE ENTERED ',/) B0400176^^ 103 CALL WTREAD ( ILU, -1, MSG, 6, -1, INPUT,2, IND ) B0400177^^ 104 IRMX=AND(INPUT,$F00)/$100*10+AND(INPUT,$F) B0400178^^ C CHECK FOR NO RESULTS (ILLEGAL) B0400179^^ 105 IF ( IRMX .LT. 1) GO TO 600 B0400180^^ 106 610 IRE = IRE + 5 B0400181^^ 107 IRE5 = IRE + 4 B0400182^^ C BRANCH IF DONE WITH RESULTS B0400183^^ 108 IF ( IRE .GT. IRMX) GO TO 800 B0400184^^ 109 IF ( IRE5 .LT. IRMX) GO TO 615 B0400185^^ C ON LAST GROUP OF 5 B0400186^^ 110 IRE5 = IRMX B0400187^^ 111 615 WRITE (ILU, 9062) IRE, IRE5 B0400188^^ 112 9062 FORMAT ( ' ENTER RESULT ', I2, ' THRU ', I2, '. EACH RESULT IS 4 B0400189^^ 112 1CHARACTERS.',/, ' SEPERATE RESULTS WITH COMMAS, FOR EXAMPLE, INPUB0400190^^ 112 2T=0071,0085,0091',/) B0400191^^ 113 620 DO 650 I = 1, 13 B0400192^^ 114 650 INPUT(I) = $2020 B0400193^^ 115 CALL WTREAD ( ILU, -1, MSG, 6, -1, INPUT, 26, IND ) B0400194^^ 116 9063 FORMAT (12A2) B0400195^^ 117 CALL RESDT1 (INPUT, RESLIT, IRE5, IND) B0400196^^ C IND1 USED FOR NORMAL AND ERROR MESSAGES B0400197^^ 118 IND1 = 1 B0400198^^ 119 IF ( IND .LT. 0) IND1 = 2 B0400199^^ 120 WRITE (ILU, 9064) IRE, IRE5, (INPUT(J),J=1,12), (ER2LIT(JJ,IND1), B0400200^^ 120 1 JJ = 1, 12 ) B0400201^^ 121 9064 FORMAT ( ' RESULT', I3, ' THRU' , I3, ' EQUALS ', 12A2,1X,12A2,/) B0400202^^ 122 IF (IND .LT. 0) GO TO 620 B0400203^^ C CHECK FOR VERIFICATION B0400204^^ 123 CALL WTREAD ( ILU, -1, MSG, 6, -1, INPUT, 1, IND ) B0400205^^ 124 INPUT(1) = AND(INPUT(1),$FF00) + $20 B0400206^^ 125 IF ( INPUT(1) .NE. Y) GO TO 615 B0400207^^ C LOAD RESULTS IN TABLE B0400208^^ 126 DO 670 I = IRE, IRE5 B0400209^^ 127 J = I - ((I-1)/5) * 5 B0400210^^ 128 CALL AREDT1 ( TABLE, RESLIT(1,J), IND) B0400211^^ 129 IF ( IND .LT. 0) GO TO 8300 B0400212^^ 130 670 CONTINUE B0400213^^ C LOOP BACK FOR MORE RESULTS B0400214^^ 131 GO TO 610 B0400215^  ^ C TEST HAS BEEN COMPLETELY ENTERED, DISPLAY COMPLETELY FOR B0400217^^ C VERIFICATION B0400218^^ 132 800 CALL DSPDT1 ( TABLE, LN, ILU, IND) B0400219^^ 133 IF (IND .LT. 0) GO TO 8400 B0400220^^ 134 WRITE (ILU, 9080) B0400221^t FTN 3.3B (OPT = LPC) ADDDT1 PAGE 7 DATE: 08/29/84 TIME: 2117 t^ 135 9080 FORMAT ( ' TYPE Y TO ADD TEST TO TABLE, N TO BYPASS.',/) B0400222^^ 136 CALL WTREAD ( ILU, -1, MSG, 6, -1, INPUT, 1, IND ) B0400223^^ 137 INPUT(1) = AND(INPUT(1),$FF00) + $20 B0400224^^ 138 9081 FORMAT (A1) B0400225^^ 139 IND = $8001 B0400226^^ 140 IF ( INPUT(1) .EQ. Y) IND = 0 B0400227^^ 141 RETURN B0400228^t FTN 3.3B (OPT = LPC) ADDDT1 PAGE 8 DATE: 08/29/84 TIME: 2117 t^ C** ERROR SECTION (NON EDIT ERRORS) B0400230^  ^ C TABLE LACKS INTEGRITY B0400232^^ 142 8000 WRITE (ILU, 9800) B0400233^^ 143 9800 FORMAT ( ' DECISION TABLE LACKS INTEGRITY. ') B0400234^^ 144 GO TO 8900 B0400235^^ C TABLE OVERFLOW B0400236^^ 145 8100 WRITE (ILU, 9830) B0400237^^ 146 GO TO 8900 B0400238^^ 147 8200 CONTINUE B0400239^^ 148 8300 WRITE (ILU, 9830) B0400240^^ 149 9830 FORMAT ( ' DECISION TABLE OVERFLOW, TEST MAY NOT BE ADDED ' ) B0400241^^ C BACK OUT PARTIAL TEST IF ALREADY IN B0400242^^ C FIGURE NUMBER OF WORDS THAT HAVE BEEN ADDED B0400243^^ 150 INW = CURPOS - ICTST B0400244^^ 151 DO 8350 I = CURPOS, TABLEN B0400245^^ 152 J = I - INW B0400246^^ 153 8350 TABLE(J) = TABLE(I) B0400247^^ 154 TABLEN = TABLEN - INW B0400248^^ 155 GO TO 8900 B0400249^^ 156 8400 WRITE (ILU, 9840) B0400250^^ 157 9840 FORMAT ( ' ERROR IN DISPLAY MODULE, TEST WAS NOT ADDED') B0400251^^ 158 GO TO 8900 B0400252^^ 159 8900 IND = $8001 B0400253^^ 160 RETURN B0400254^^ 161 END B0400255^t FTN 3.3B (OPT = LPC) ADDDT1 PAGE 9 DATE: 08/29/84 TIME: 2117 t  PROGRAM LENGTH $083D ( 2109)   EXTERNALS 2 Q8PKUP Q8PREP Q8QINI Q8QX Q8QEND WTREAD NUMDT1 22 GTPDT1 CCSGET ALVDT1 PMEDT1 APMDT1 RESDT1 AREDT1 2 DSPDT1  t FTN 3.3B (OPT = LPC) ADDDT1 PAGE 10 DATE: 08/29/84 TIME: 2117 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < & 8001 (-32766) 009A 139,159&6 FF00 (-255) 0088 29,30,31,50,89,124,137 6@ FFFE (-1) 0080 22,22,28,49,75,88,103,115,123,136@€ 0001 (1) 0000 15,17,19,22,23,25,28,29,35,36,37,46,49,50,51,55,61,63,73,75,78,79,82,85,88,90,94,97,103,105,113, €J 115,118,120,123,124,125,127,128,136,137,140J0 0002 (2) 0093 82,85,103,119,12804 0003 (3) 0082 22,31,38,42,55,82,85 4* 0005 (5) 0087 28,106,127 *> 0006 (6) 0081 22,28,49,75,88,103,115,123,136 >" 0007 (7) 0094 96 "( 000A (10) 007F 13,23,104(& 000F (15) 0086 23,104 && 001A (26) 008F 75,115 &" 0064 (100) 0085 23 "( 0F00 (3840) 0084 23,23,104(& 2020 (8224) 008E 74,114 &   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < B AND INTR.FN. 7FFF 23,23,29,30,31,50,89,96,104,124,137B* CONLIT INTEGER 0028 1,79,82,85 ** CURPOS INTEGER 7FFF 6,8,150,151*& ELIT INTEGER 0002 1,3,97 && ER2LIT INTEGER 0035 1,4,120&@ I INTEGER 008D 72,74,113,114,126,127,151,152,153@$ ICON INTEGER 0092 79,92$$ ICTST INTEGER 7FFF 8,150$‚ ILU INTEGER 7FFF 1,20,22,26,28,47,49,55,58,64,67,70,75,82,85,88,97,101,103,111,115,120,123,132,134,136,142,145,148, ‚" 156"0 IMAXT INTEGER 007D 10,11,15,20,24,400z IND INTEGER 7FFF 1,10,49,52,53,79,80,88,92,93,96,97,103,115,117,119,122,123,128,129,132,133,136,139,140,159 z. IND1 INTEGER 0099 117,118,119,120.‚ INPUT INTEGER 004E 4,22,23,28,29,30,31,49,50,51,55,74,75,79,82,85,88,89,90,97,103,104,114,115,117,120,123,124,125,136 ‚( ,137,140 (. INW INTEGER 009B 149,150,152,154.( IOP INTEGER 0091 79,81,92 (: IP INTEGER 008C 61,61,62,63,64,67,69,78,94 :> IRE INTEGER 0096 100,100,106,107,108,111,120,126>> IRE5 INTEGER 0098 106,107,109,110,111,117,120,126>6 IRMX INTEGER 0097 103,104,105,108,109,1106B J INTEGER 008B 55,55,82,85,97,120,127,128,152,153 B( JJ INTEGER 0095 97,97,120(t FTN 3.3B (OPT = LPC) ADDDT1 PAGE 11 DATE: 08/29/84 TIME: 2117 t0 LC INTEGER 007E 11,12,14,16,17,190@ LN INTEGER 0083 22,23,24,25,26,36,37,40,41,52,132@. LPN INTEGER 0090 75,77,78,79,92 .& LSTLFG INTEGER 7FFF 8,44,46&8 LVL INTEGER 007A 8,29,32,35,39,43,47,52,588$ LVLN INTEGER 008A 42,43$$ LVLP INTEGER 0089 38,39$ MAXTAB INTEGER 7FFF 8 B MSG INTEGER 0077 6,7,22,28,49,75,88,103,115,123,136 B0 NLVL INTEGER 007B 9,30,33,35,47,52 0< NP INTEGER 007C 9,28,31,34,35,47,52,62,69,78 <, PA INTEGER 0022 1,79,82,85,92,* PB INTEGER 0025 1,79,85,92 *$ Q8QX1 INTEGER 0001 82,85$( RESLIT INTEGER 002B 1,117,128(H TABLE INTEGER 7FFF 1,6,8,14,16,37,38,41,42,52,92,128,132,153H4 TABLEN INTEGER 7FFF 6,8,13,17,19,151,154 4" TRES INTEGER 7FFF 6,8", WP INTEGER 004D 4,37,38,41,42,0 Y INTEGER 0076 4,9,51,90,125,1400   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " ALVDT1 SUBROUTINE 0270 51 "" APMDT1 SUBROUTINE 050F 92 "" AREDT1 SUBROUTINE 06E2 127"$ CCSGET SUBROUTINE 01F4 37,42$" DSPDT1 SUBROUTINE 06EF 132"$ GTPDT1 SUBROUTINE 01EA 36,41$. NUMDT1 INTEGER.FN. 01C9 32,33,34,39,43 ." PMEDT1 SUBROUTINE 0428 78 " Q8PKUP INTEGER.FN. 07C3 Q8PREP INTEGER.FN. 07C0 Q8QEND INTEGER.FN. 0694 Q8QINI INTEGER.FN. 0795 D Q8QX SUBROUTINE 0671 20,26,47,55,58,64,67,82,85,97,111,120D" RESDT1 SUBROUTINE 065D 115"> WTREAD SUBROUTINE 071B 21,28,49,75,88,103,115,123,136 >   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 100 00A5 13,18$$ 150 00BA 14,19$( 200 00C2 13,20,24 ($ 240 013D 25,51$( 250 01AB 27,57,60 (t FTN 3.3B (OPT = LPC) ADDDT1 PAGE 12 DATE: 08/29/84 TIME: 2117 t$ 270 0200 36,40$$ 280 021C 40,46$$ 285 021E 44,47$$ 300 027E 35,55$( 310 02BC 39,43,58 ($ 400 030A 53,61$( 405 030D 61,91,95 ($ 407 03BB 63,67$$ 409 03DA 65,69$( 410 0403 69,72,99 ($ 411 0406 72,74$$ 460 0495 81,85$$ 465 04F8 83,87$$ 475 050E 90,92$$ 500 0520 80,96$* 600 056F 62,100,105 *& 610 05DA 105,131&* 615 05EC 109,111,125*& 620 0641 112,122&& 650 0644 112,114&& 670 06EA 125,130&& 800 06EE 108,132&( 8000 0736 17,19,142(& 8100 0751 53,145 && 8200 0757 93,147 && 8300 0757 129,148&& 8350 0787 150,153&& 8400 0794 133,156&2 8900 07B5 143,146,155,158,1592$ 9000 00CE 20,21$$ 9010 014B 26,27$$ 9030 0293 55,56$$ 9031 02C8 58,59$$ 9035 022E 47,48$$ 9040 0323 64,65$" 9041 041B 75 "$ 9042 046E 82,83$$ 9043 04D2 85,86$$ 9044 03E7 70,71$$ 9045 03C7 67,68$$ 9050 054A 97,98$& 9060 0578 101,102&& 9062 05FA 111,112&" 9063 0659 115"& 9064 0696 120,121&& 9080 0700 134,135&" 9081 0729 137"& 9800 073C 142,143&* 9830 075D 145,148,149*& 9840 079B 156,157& ADDDT1 07BD 1 t FTN 3.3B (OPT = LPC) ALVDT1 PAGE 1 DATE: 08/29/84 TIME: 2119 t^ 1 SUBROUTINE ALVDT1 ( TABLE, LN, LVL, NLVL, NP, IND) B0600001^^ 1 1 /B06 F CCS CCS 3.0 SL-149B0600002^^ C B0600003^^ C CYBERCREDIT SYSTEM VERSION 3 B0600004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B0600005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B0600006^^ C B0600007^^ C ROUTINE STARTS ADDING A NEW TEST TO TABLE. MOVES IN LEVEL, NEXT B0600008^^ C LEVEL, AND NUMBER OF PARAMETERS B0600009^^ 2 INTEGER TABLE(11), TABLEN, CURPOS, TRES B0600010^^ 3 EQUIVALENCE ( TABLE(2),TABLEN), (TABLE(10), CURPOS), B0600011^^ 3 1(TABLE(9), MAXTAB), (TABLE(8), LSTLFG), (TABLE(7), TRES) , B0600012^^ 3 2 (ICTST,TABLE(5)) B0600013^^ C TABLEN - TOTAL TABLE LENGTH B0600014^^ C CURPOS - CURRENT OFFSET IN TABLE TO CCSPUT THE NEXT DATA B0600015^^ C MAXTAB - MAXIMUM TABLE LENGTH AS DEFINED AT COMPILATION B0600016^^ C LSTLFG - LAST TEST FLAG ( =1 IF ADDING TEST TO TABLE END) B0600017^^ C TRES - OFFSET IN TABLE TO NUMBER OF RESULTS FIELD B0600018^^ C ICTST ' OFFSET TO BEGINNING OF THIS TEST B0600019^^ 4 IND = 0 B0600020^^ C CCSGET POSITION TO START LOADING TEST B0600021^^ 5 CALL GTPDT1 ( TABLE, LN, CURPOS) B0600022^^ 6 IF ( LSTLFG .EQ. 1) CURPOS = TABLEN + 1 B0600023^^ C ARE WE WORKING WITH LAST TEST B0600024^^ 7 IF ( LSTLFG .EQ. 1) GO TO 100 B0600025^^ C NO B0600026^^ C CHECK LENGTH OF SHORTEST POSSIBLE TEST VS. ROOM AVAILABLE B0600027^^ 8 IF (TABLEN + 11 .GT. MAXTAB) GO TO 8000 B0600028^^ C MOVE TABLE DOWN 3 WORDS FOR LEN, LVLS, AND NP B0600029^^ 9 DO 50 I = TABLEN, CURPOS, -1 B0600030^^ 10 50 TABLE(I+3) = TABLE(I) B0600031^^ 11 100 IF (CURPOS + 11 .GT. MAXTAB) GO TO 8000 B0600032^^ 12 TABLE (CURPOS+1) = LVL*$100 + NLVL + $3030 B0600033^^ 13 TABLE (CURPOS+2) = NP*$100 + $3020 B0600034^^ 14 TABLE (CURPOS) = 3 B0600035^^ 15 ICTST = CURPOS B0600036^^ 16 TABLEN = TABLEN + 3 B0600037^^ 17 CURPOS = CURPOS + 3 B0600038^^ 18 RETURN B0600039^^ 19 8000 IND = $8001 B0600040^^ 20 RETURN B0600041^^ 21 END B0600042^t FTN 3.3B (OPT = LPC) ALVDT1 PAGE 2 DATE: 08/29/84 TIME: 2119 t  PROGRAM LENGTH $0074 ( 116)   EXTERNALS  Q8PKUP Q8PREP GTPDT1  t FTN 3.3B (OPT = LPC) ALVDT1 PAGE 3 DATE: 08/29/84 TIME: 2119 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " 8001 (-32766) 0003 19 "" 3020 (12320) 0002 13 "" 3030 (12336) 0001 12 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < : CURPOS INTEGER 7FFF 2,3,5,6,9,11,12,13,14,15,17:$ I INTEGER 0000 8,10 $$ ICTST INTEGER 7FFF 3,15 $& IND INTEGER 7FFF 1,4,19 &" LN INTEGER 7FFF 1,5"$ LSTLFG INTEGER 7FFF 3,6,7$$ LVL INTEGER 7FFF 1,12 $& MAXTAB INTEGER 7FFF 3,8,11 &$ NLVL INTEGER 7FFF 1,12 $$ NP INTEGER 7FFF 1,13 $2 TABLE INTEGER 7FFF 1,2,3,5,10,12,13,142, TABLEN INTEGER 7FFF 2,3,6,8,9,16 ," TRES INTEGER 7FFF 2,3"   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  GTPDT1 SUBROUTINE 0007 4 Q8PKUP INTEGER.FN. 0057 Q8PREP INTEGER.FN. 0054    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 50 0020 8,10 $$ 100 002C 7,11 $& 8000 004C 8,11,19& ALVDT1 0051 1  t FTN 3.3B (OPT = LPC) APMDT1 PAGE 1 DATE: 08/29/84 TIME: 2119 t^ 1 SUBROUTINE APMDT1 ( TABLE,LPN, OP, PA, PB, CON, IND) B0700001^^ 1 1 /B07 F CCS CCS 3.0 SL-149B0700002^^ C B0700003^^ C CYBERCREDIT SYSTEM VERSION 3 B0700004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B0700005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B0700006^^ C B0700007^^ 2 INTEGER OP, PA(3), PB(3) , CON B0700008^^ C ROUTINE ADDS 1 PARAMETER GROUP TO TABLE B0700009^^ 3 INTEGER TABLE(11), TABLEN, CURPOS, TRES B0700010^^ 4 EQUIVALENCE ( TABLE(2),TABLEN), (TABLE(10), CURPOS), B0700011^^ 4 1(TABLE(9), MAXTAB), (TABLE(8), LSTLFG), (TABLE(7), TRES) , B0700012^^ 4 2 (ICTST,TABLE(5)) B0700013^^ C TABLEN - TOTAL TABLE LENGTH B0700014^^ C CURPOS - CURRENT OFFSET IN TABLE TO CCSPUT THE NEXT DATA B0700015^^ C MAXTAB - MAXIMUM TABLE LENGTH AS DEFINED AT COMPILATION B0700016^^ C LSTLFG - LAST TEST FLAG ( =1 IF ADDING TEST TO TABLE END) B0700017^^ C TRES - OFFSET IN TABLE TO NUMBER OF RESULTS FIELD B0700018^^ C ICTST ' OFFSET TO BEGINNING OF THIS TEST B0700019^^ 5 NV = 3 B0700020^^ C IF RANGE TEST INCREASE BY 3 B0700021^^ 6 IF (OP .GT. 4) NV = 6 B0700022^^ 7 IND = 0 B0700023^^ C IF LAST PARAMETER ALLOCATE 2 WORDS FOR RESULT COUNTS B0700024^^ 8 IF ( LPN .EQ. 1) NV = NV + 2 B0700025^^ C MOVE TRAILING TABLE DOWN IF NOT LAST TEST B0700026^^ 9 IF ( LSTLFG .EQ. 1) GO TO 100 B0700027^^ C CHECK TABLE LENGTH B0700028^^ 10 IF ( TABLEN + 1 + NV .GT. MAXTAB) GO TO 8000 B0700029^^ 11 DO 50 I = TABLEN, CURPOS, -1 B0700030^^ 12 J = I + NV + 1 B0700031^^ 13 50 TABLE(J) = TABLE(I) B0700032^^ 14 100 IF (CURPOS + 1 + NV .GT. MAXTAB) GO TO 8000 B0700033^^ C COMBINE OPERATOR AND CONNECTOR B0700034^^ 15 TABLE(CURPOS) = OP*$100 + CON + $3030 B0700035^^ 16 DO 150 I = 1,3 B0700036^^ 17 TABLEN = TABLEN + 1 B0700037^^ 18 CURPOS = CURPOS + 1 B0700038^^ 19 TABLE(ICTST) = TABLE(ICTST) + 1 B0700039^^ 20 150 TABLE (CURPOS) = PA(I) B0700040^^ 21 IF ( OP .LT. 5) GO TO 200 B0700041^^ 22 DO 175 I = 1,3 B0700042^^ 23 TABLEN = TABLEN + 1 B0700043^^ 24 CURPOS = CURPOS + 1 B0700044^^ 25 TABLE(ICTST) = TABLE(ICTST) + 1 B0700045^^ 26 175 TABLE(CURPOS) = PB(I) B0700046^^ 27 200 TABLEN = TABLEN + 1 B0700047^^ 28 CURPOS = CURPOS + 1 B0700048^^ 29 TABLE(ICTST) = TABLE(ICTST) + 1 B0700049^^ C PRELOAD RESULT COUNTS IF LAST PARAMETER B0700050^^ 30 IF ( LPN .NE. 1) RETURN B0700051^^ 31 TABLE (CURPOS) = $3030 B0700052^^ 32 TABLE (CURPOS + 1) = $3030 B0700053^^ C SAVE POSITION OF RESULT COUNT B0700054^t FTN 3.3B (OPT = LPC) APMDT1 PAGE 2 DATE: 08/29/84 TIME: 2119 t^ 33 TRES = CURPOS B0700055^^ 34 TABLEN = TABLEN + 2 B0700056^^ 35 CURPOS = CURPOS + 2 B0700057^^ 36 TABLE (ICTST) = TABLE (ICTST) + 2 B0700058^^ 37 RETURN B0700059^^ 38 8000 IND = $8001 B0700060^^ 39 RETURN B0700061^^ 40 END B0700062^t FTN 3.3B (OPT = LPC) APMDT1 PAGE 3 DATE: 08/29/84 TIME: 2119 t  PROGRAM LENGTH $00B8 ( 184)   EXTERNALS  Q8PKUP Q8PREP  t FTN 3.3B (OPT = LPC) APMDT1 PAGE 4 DATE: 08/29/84 TIME: 2119 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " 8001 (-32766) 0004 38 "( 3030 (12336) 0003 15,31,32 (   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < & CON INTEGER 7FFF 1,2,15 &F CURPOS INTEGER 7FFF 3,4,11,14,15,18,20,24,26,28,31,32,33,35F4 I INTEGER 0001 10,12,13,16,20,22,26 4, ICTST INTEGER 7FFF 4,19,25,29,36,& IND INTEGER 7FFF 1,7,38 &( J INTEGER 0002 11,12,13 (& LPN INTEGER 7FFF 1,8,30 &" LSTLFG INTEGER 7FFF 4,9"& MAXTAB INTEGER 7FFF 4,10,14&0 NV INTEGER 0000 4,5,6,8,10,12,14 0* OP INTEGER 7FFF 1,2,6,15,21*& PA INTEGER 7FFF 1,2,20 && PB INTEGER 7FFF 1,2,26 &B TABLE INTEGER 7FFF 1,3,4,13,15,19,20,25,26,29,31,32,36B4 TABLEN INTEGER 7FFF 3,4,10,11,17,23,27,344& TRES INTEGER 7FFF 3,4,33 &   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  Q8PKUP INTEGER.FN. 0090 Q8PREP INTEGER.FN. 008D    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 50 0028 10,13$$ 100 0037 9,14 $$ 150 004B 15,20$$ 175 005E 21,26$$ 200 0067 21,27$t FTN 3.3B (OPT = LPC) APMDT1 PAGE 5 DATE: 08/29/84 TIME: 2119 t( 8000 0084 10,14,38 ( APMDT1 008A 1  t FTN 3.3B (OPT = LPC) AREDT1 PAGE 1 DATE: 08/29/84 TIME: 2119 t^ 1 SUBROUTINE AREDT1 ( TABLE, RESLIT, IND) B0800001^^ 1 1 /B08 F CCS CCS 3.0 SL-149B0800002^^ C B0800003^^ C CYBERCREDIT SYSTEM VERSION 3 B0800004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B0800005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B0800006^^ C B0800007^^ C ROUTINE ADDS A RESULT VALUE TO THE DECISION TABLE B0800008^^ 2 INTEGER RESLIT(2), RSCNT B0800009^^ 3 INTEGER TABLE(11), TABLEN, CURPOS, TRES B0800010^^ 4 EQUIVALENCE ( TABLE(2),TABLEN), (TABLE(10), CURPOS), B0800011^^ 4 1(TABLE(9), MAXTAB), (TABLE(8), LSTLFG), (TABLE(7), TRES) , B0800012^^ 4 2 (ICTST,TABLE(5)) B0800013^^ C TABLEN - TOTAL TABLE LENGTH B0800014^^ C CURPOS - CURRENT OFFSET IN TABLE TO CCSPUT THE NEXT DATA B0800015^^ C MAXTAB - MAXIMUM TABLE LENGTH AS DEFINED AT COMPILATION B0800016^^ C LSTLFG - LAST TEST FLAG ( =1 IF ADDING TEST TO TABLE END) B0800017^^ C TRES - OFFSET IN TABLE TO NUMBER OF RESULTS FIELD B0800018^^ C ICTST - OFFSET TO BEGINNING OF THIS TEST B0800019^^ C WE ARE ADDING 1 RESULT (4 CHARACTERS). B0800020^^ C ARE WE WORKING WITH LAST TEST IN TABLE. B0800021^^ 5 IND = 0 B0800022^^ 6 IF (LSTLFG .EQ. 1) GO TO 100 B0800023^^ C NO, MOVE TABLE DOWN 2 WORDS IF ROOM B0800024^^ 7 IF ( TABLEN + 2 .GT. MAXTAB) GO TO 8000 B0800025^^ 8 DO 50 I = TABLEN, CURPOS, -1 B0800026^^ 9 50 TABLE(I+2) = TABLE(I) B0800027^^ 10 100 IF ( CURPOS+2 .GT. MAXTAB) GO TO 8000 B0800028^^ C ADD RESULT TO TABLE B0800029^^ 11 TABLE(CURPOS) = RESLIT(1) B0800030^^ 12 TABLE(CURPOS+1) = RESLIT(2) B0800031^^ 13 TABLE (ICTST) = TABLE (ICTST) + 2 B0800032^^ 14 TABLEN = TABLEN +2 B0800033^^ 15 CURPOS = CURPOS + 2 B0800034^^ C ADD RESULT COUNT B0800035^^ 16 TABLE(TRES) = TABLE(TRES) + 1 B0800036^^ 17 IF (AND($000A, TABLE(TRES)) .EQ. $000A ) B0800037^^ 17 1 TABLE(TRES) = AND($FF00, TABLE(TRES)) + $0130 B0800038^^ 18 RETURN B0800039^^ 19 8000 IND = $8001 B0800040^^ 20 RETURN B0800041^^ 21 END B0800042^t FTN 3.3B (OPT = LPC) AREDT1 PAGE 2 DATE: 08/29/84 TIME: 2119 t  PROGRAM LENGTH $006A ( 106)   EXTERNALS  Q8PKUP Q8PREP  t FTN 3.3B (OPT = LPC) AREDT1 PAGE 3 DATE: 08/29/84 TIME: 2119 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " 8001 (-32766) 0004 19 "" FF00 (-255) 0002 17 "$ 000A (10) 0001 17,17$" 0130 (304) 0003 17 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < $ AND INTR.FN. 7FFF 17,17$0 CURPOS INTEGER 7FFF 3,4,8,10,11,12,150" I INTEGER 0000 7,9"$ ICTST INTEGER 7FFF 4,13 $& IND INTEGER 7FFF 1,5,19 &" LSTLFG INTEGER 7FFF 4,6"& MAXTAB INTEGER 7FFF 4,7,10 &( RESLIT INTEGER 7FFF 1,2,11,12(6 TABLE INTEGER 7FFF 1,3,4,9,11,12,13,16,17 6* TABLEN INTEGER 7FFF 3,4,7,8,14 *( TRES INTEGER 7FFF 3,4,16,17(   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  Q8PKUP INTEGER.FN. 0051 Q8PREP INTEGER.FN. 004E    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < " 50 0016 7,9"$ 100 0022 6,10 $& 8000 0046 7,10,19& AREDT1 004B 1  t FTN 3.3B (OPT = LPC) ASCBIN PAGE 1 DATE: 08/29/84 TIME: 2119 t^ 1 SUBROUTINE ASCBIN(IN,IOUT) B0900001^^ 1 1 /B09 F CCS CCS 3.0 SL-149B0900002^^ C B0900003^^ C COPYRIGHT CONTROL DATA CORPORATION,1979 B0900004^^ C DATA SYSTEMS DIVISION- LA JOLLA, LA JOLLA CALIFORNIA B0900005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B0900006^^ C B0900007^^ C B0900008^^ C B0900009^^ C CONVERTS 2 ASCII NUMERIC BYTES INTO BINARY INTEGER B0900010^^ 2 J=AND(IN,$F)+(AND(IN,$0F00)/$100)*10 B0900011^^ 3 IOUT=J B0900012^^ 4 RETURN B0900013^^ 5 END B0900014^t FTN 3.3B (OPT = LPC) ASCBIN PAGE 2 DATE: 08/29/84 TIME: 2119 t  PROGRAM LENGTH $0020 ( 32)   EXTERNALS  Q8PKUP Q8PREP  t FTN 3.3B (OPT = LPC) ASCBIN PAGE 3 DATE: 08/29/84 TIME: 2119 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : <  000A (10) 0003 2 000F (15) 0001 2 0F00 (3840) 0002 2    VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " AND INTR.FN. 7FFF 2,2"" IN INTEGER 7FFF 1,2"" IOUT INTEGER 7FFF 1,3"$ J INTEGER 0000 1,2,3$   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  Q8PKUP INTEGER.FN. 001A Q8PREP INTEGER.FN. 0017    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : <  ASCBIN 0014 1  t FTN 3.3B (OPT = LPC) AVMCKD PAGE 1 DATE: 08/29/84 TIME: 2119 t^ 1 SUBROUTINE AVMCKD(ARR) B1000001^^ 1 1 /B10 F CCS CCS 3.0 SL-149B1000002^^ C B1000003^^ C CYBERCREDIT SYSTEM VERSION 3 B1000004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA CALIFORNIA B1000005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B1000006^^ C B1000007^^ C B1000008^^ C SCAN ARRAY CHECKING EACH ELEMENT FOR UNIQUENESS. B1000009^^ C B1000010^^ C ROUTINE TO SCAN ARRAY 'ARR' FOR A MAXIMUM OF 32 WORDS OR UNTIL AN B1000011^^ C '**' IS ENCOUNTERED, CHECKING FOR EACH ELEMENT TO BE UNIQUE WHEN B1000012^^ C COMPARED TO THE OTHER ELEMENTS. IF A DUPLICATE ENTRY IS FOUND, THEB1000013^^ C ENTRY IS FLAGGED BY SETTING IT TO ZERO. THIS WILL CAUSE BYPASS B1000014^^ C OF THIS CODE WHEN BIT MASK IS CONSTRUCTED. B1000015^^ C B1000016^^ 2 INTEGER ARR(1),ASTRKS B1000017^^ 3 DATA ASTRKS/'**'/ B1000018^  ^ 4 DO 20 I=1,32 B1000020^^ 5 IF(ARR(I).EQ.ASTRKS) GO TO 90 B1000021^^ 6 DO 10 J=1,32 B1000022^^ 7 IF(ARR(J).EQ.ASTRKS) GO TO 20 B1000023^^ 8 IF(I.EQ.J.OR.ARR(J).EQ.0) GO TO 10 B1000024^^ 9 IF(ARR(I).EQ.ARR(J)) ARR(J)=0 B1000025^^ 10 10 CONTINUE B1000026^^ 11 20 CONTINUE B1000027^ ^ 12 90 RETURN B1000029^^ 13 END B1000030^t FTN 3.3B (OPT = LPC) AVMCKD PAGE 2 DATE: 08/29/84 TIME: 2119 t  PROGRAM LENGTH $003E ( 62)   EXTERNALS  Q8PKUP Q8PREP  t FTN 3.3B (OPT = LPC) AVMCKD PAGE 3 DATE: 08/29/84 TIME: 2119 t, ***** L I S T O F S Y M B O L S *****,   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < * ARR INTEGER 7FFF 1,2,5,7,8,9*& ASTRKS INTEGER 0000 2,3,5,7&& I INTEGER 0001 3,5,8,9&& J INTEGER 0002 5,7,8,9&   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  Q8PKUP INTEGER.FN. 0039 Q8PREP INTEGER.FN. 0036    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < & 10 0025 5,8,10 && 20 002A 3,7,11 &$ 90 002F 5,12 $ AVMCKD 0033 1  t FTN 3.3B (OPT = LPC) AVMCKV PAGE 1 DATE: 08/29/84 TIME: 2119 t^ 1 SUBROUTINE AVMCKV(ARR,EL) B1100001^^ 1 1 /B11 F CCS CCS 3.0 SL-149B1100002^^ C B1100003^^ C CYBERCREDIT SYSTEM VERSION 3 B1100004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B1100005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B1100006^^ C B1100007^^ C B1100008^^ C CHECK ARRAY FOR PARTICULAR ELEMENT. B1100009^^ C B1100010^^ C ROUTINE TO CHECK IF THE VALUE 'EL' IS CONTAINED IN THE ARRAY 'ARR'B1100011^^ C 'ARR' IS 32 WORDS LONG, BUT MAY CONTAIN FEWER ELEMENTS WHEN TERMI-B1100012^^ C NATED BY '**'. IF 'EL' IS CONTAINED IN 'ARR', RETURN 'EL' WITH ITSB1100013^^ C INDEX-1. IF 'EL IS NOT CONTAINED IN 'ARR', RETURN 'EL' < 0. B1100014^^ C B1100015^^ 2 INTEGER ARR(1),EL,ASTRKS B1100016^^ 3 DATA ASTRKS/'**'/ B1100017^  ^ 4 DO 10 I=1,32 B1100019^^ 5 IF(ARR(I).EQ.ASTRKS) GO TO 80 B1100020^^ 6 IF(ARR(I).NE.EL) GO TO 10 B1100021^^ 7 EL = I-1 B1100022^^ 8 GO TO 90 B1100023^^ 9 10 CONTINUE B1100024^^ 10 80 EL = -1 B1100025^ ^ 11 90 RETURN B1100027^^ 12 END B1100028^t FTN 3.3B (OPT = LPC) AVMCKV PAGE 2 DATE: 08/29/84 TIME: 2119 t  PROGRAM LENGTH $002C ( 44)   EXTERNALS  Q8PKUP Q8PREP  t FTN 3.3B (OPT = LPC) AVMCKV PAGE 3 DATE: 08/29/84 TIME: 2119 t, ***** L I S T O F S Y M B O L S *****,   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < & ARR INTEGER 7FFF 1,2,5,6&$ ASTRKS INTEGER 0000 2,3,5$* EL INTEGER 7FFF 1,2,6,7,10 *& I INTEGER 0001 3,5,6,7&   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  Q8PKUP INTEGER.FN. 0025 Q8PREP INTEGER.FN. 0022    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 10 0015 3,6,9$$ 80 001A 5,10 $$ 90 001C 7,11 $ AVMCKV 001F 1  t FTN 3.3B (OPT = LPC) AVMCON PAGE 1 DATE: 08/29/84 TIME: 2120 t^ 1 PROGRAM AVMCON B1200001^^ 1 1 /B12 F CCS CCS 3.0 &LA SL-149********^^ C B1200003^^ C B1200004^^ C CYBERCREDIT SYSTEM VERSION 3 B1200005^^ C DATA SYSTEM - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B1200006^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B1200007^^ C B1200008^^ C B1200009^^ C CONSTRUCT ACTIVITY VERIFICATION MATRIX. B1200010^^ C B1200011^^ C THIS PROGRAM WILL CONSTRUCT THE ACTIVITY VERIFICATION MATRIX USED B1200012^^ C BY 'COLECT'. THE FILE 'AVMDESC' CONTAINS DESCRIPTIONS OF THE ACTIOB1200013^^ C AND RESULT CODES TO BE USED. ALSO, THIS PROGRAM WILL UPDATE THE B1200014^^ C UTILITY FILE RECORDS 'ACTC' AND 'RESC' WITH THE CURRENT ACTION ANDB1200015^^ C RESULT CODES IN USE. B1200016^^ C B1200017^^ C THE FORMAT OF THE INPUT DESCRIPTION RECORDS FROM 'AVMDESC' ARE: B1200018^^ C B1200019^^ C START COL # CHARS DESCRIPTION B1200020^^ C 1 2 IDENTIFIER. EITHER 'RS' FOR RESULT CODE B1200021^^ C RECORD, 'AC' FOR ACTION CODE RECORD, OR B1200022^^ C ANY OTHER CHARACTERS FOR COMMENT RECORD. B1200023^^ C B1200024^^ C 3 2 THE TWO CHARACTER ACTION OR RESULT CODE. B1200025^^ C B1200026^^ C 5 1 EITHER 'L' OR 'C' FOR LETTER OR COMMENT B1200027^^ C REQUIRED. ANY OTHER ENTRY IS IGNORED. B1200028^^ C B1200029^^ C 6 1 SAME AS COLUMN 5. B1200030^^ C B1200031^^ C 7 2 DEFAULT NUMBER OF DAYS TILL NEXT CONTACT B1200032^^ C FOR USE BY 'COLECT'. MUST BE IN THE RANGEB1200033^^ C OF 0 TO 63 . B1200034^^ C B1200035^^ C 9 64 FOR ACTION CODE RECORDS, THIS IS THE LISTB1200036^^ C OF RESULT CODE PERMITTED WITH THIS ACTIONB1200037^^ C FOR LESS THAN 32 TWO CHARACTER CODES, B1200038^^ C TERMINATE THE LIST WITH A '**' . B1200039^^ C B1200040^^ C UP TO 32 RESULT CODE AND 32 ACTION CODE RECORDS CAN BE PROCESSED. B1200041^^ C FOR MORE THAN 32 RECORDS, THE OVERFLOW RECORDS ARE REPORTED AS B1200042^^ C ERRORS AND IGNORED. OTHER ERRORS REPORTED AND RESTRICTIONS ARE: B1200043^^ C 1. ACTION OR RESULT CODE NOT UNIQUE. IT DUPLICATES A PREVIOUS B1200044^^ C ACTION OR RESULT CODE ENTERED. B1200045^^ C 2. NEXT CONTACT DATE FOR THIS ACTION OR RESULT CODE IS OUT OF B1200046^^ C RANGE (NCD < 0 OR NCD > 63). TO CONTINUE PROCESSING, THE B1200047^^ C NEXT CONTACT DATE IS SET TO ZERO IF THIS ERROR OCCURS. B1200048^^ C 3. FOR ACTION CODE RECORDS, THE ACTION CODE CANNOT BE THE SAMEB1200049^^ C AS ANY SCREEN FUNCTION CODE USED IN 'COLECT'. IF THE ACTIONB1200050^^ C CODE IS ON THIS RESERVED LIST, THE RECORD IS IGNORED. B1200051^^ C 4. FOR ACTION CODE RECORDS, THE LIST OF VALID RESULT CODES B1200052^^ C MUST CONTAIN VALID RESULTS. IF A RESULT CODE IN THE VALID B1200053^^ C RESULT CODE LIST IS NOT A RESULT CODE, IT WILL NOT BE USED B1200054^t FTN 3.3B (OPT = LPC) AVMCON PAGE 2 DATE: 08/29/84 TIME: 2120 t^ C IN THE BIT MASK CONSTRUCTION. B1200055^^ C B1200056^^ C THE PROGRAM LISTS ALL PROCESSED ACTION AND RESULT CODE RECORDS B1200057^^ C TO THE PRINTER WITH DIAGNOSTICS FOR ANY ERRORS. THE PRINT-OUT B1200058^^ C UTILIZES STANDARD REPORT STYLE HEADINGS FOR CCS 2.0. B1200059^^ C B1200060^t FTN 3.3B (OPT = LPC) AVMCON PAGE 3 DATE: 08/29/84 TIME: 2120 t^ 2 INTEGER BUF(8000), REQBUF(24), ID(4) B1200062^^ 3 INTEGER AMDATA(15), ADDATA(15), UTDATA(15), ACTC(2), RESC(2) B1200063^^ 4 INTEGER TABLE(162), ACT(1), RES(1), BIT1(1), BIT2(1), REQS(1) B1200064^^ 5 EQUIVALENCE ( REQBUF(15),NUMREC ) , ( TABLE(1),ACT(1) ) B1200065^^ 6 EQUIVALENCE ( TABLE(33),RES(1) ) , ( TABLE(65),BIT1(1) ) B1200066^^ 7 EQUIVALENCE ( TABLE(97),BIT2(1) ) , ( TABLE(129),REQS(1) ) B1200067^ ^ 8 INTEGER DUPMES(21), DUPMLN, NCDMES(24), NCDMLN, NRSMES(26), NRSMLNB1200069^^ 9 INTEGER OVFMES(24), OVFMLN, SCFMES(25), SCFMLN B1200070^^ 10 DATA DUPMES/ '****LAST RESULT CODE REJECTED - NOT UNIQUE' / B1200071^^ 11 DATA NCDMES/ '****NEXT CONTACT DATE OUT OF RANGE - SET TO ZERO' / B1200072^^ 12 DATA NRSMES/'**** " " ($ ) NOT A VALID RESULT CODE - IGNORED'/B1200073^^ 13 DATA OVFMES/ '****LAST RESULT CODE REJECTED - OVERFLOWS TABLE ' / B1200074^^ 14 DATA SCFMES/ '****LAST ACTION CODE A SCREEN FUNCTION - REJECTED '/B1200075^^ 15 DATA DUPMLN/ 42 /, NCDMLN/ 48 /, NRSMLN/ 52 /, OVFMLN/ 48 / B1200076^^ 16 DATA SCFMLN/ 50 / B1200077^^ 17 INTEGER ACTION(3) B1200078^^ 18 DATA ACTION/ 'ACTION' / B1200079^ ^ 19 INTEGER FUNCOD(18), NUMFUN B1200081^^ 20 DATA FUNCOD/ 'NADSDFDADCCSP1P2P3RLNQOASSDLAAEAUH ' / B1200082^^ 21 DATA NUMFUN/ 18 / B1200083^^ 22 DATA REQBUF/24*0/, ACTC/ 'ACTC' /, RESC/ 'RESC' / B1200084^ ^ C*********** ********^^ 23 INTEGER AMDAT(4),ADDAT(4) ********^^ 24 DATA AMDAT/'ACTVERTB'/, ADDAT/'AVMDESC '/ ********^^ 25 DATA AMDATA/'LAACTVTB', 8*$2020, 0, 1, -1 / ********^^ 26 DATA ADDATA/'LAAVMDSC', 8*$2020, 0, 200, 0 / ********^^ 27 DATA UTDATA/'LAUTIFIL', 8*$2020, 1, 1, 1 / ********^^ C******************** ********^ ^ 28 DATA TABLE/ 32*$2A2A, 32*$2A2A, 32*0, 32*0, 32*0, 2*0 / B1200088^ ^ 29 INTEGER LP, COMPL1, COMPL2, COMPL3, COMPL4, FLAG, TEMP(8), RECLEN B1200090^^ 30 DATA LP/ 9 /, RECLEN/ 80 / B1200091^ ^ 31 INTEGER ONE, SIX, TEN, NUMBYT, NZERO, FIVE B1200093^^ 32 DATA ONE/ 1 /, SIX/ 6 /, TEN/ 10 /, NUMBYT/ 64 /, NZERO/ $FFFF / B1200094^^ 33 DATA FIVE/ 5 / B1200095^ ^ 34 INTEGER AC, RS, REQ B1200097^^ 35 DATA AC/ 'AC' /, RS/ 'RS' / B1200098^ ^ 36 INTEGER HEAD(120), DATE(1), HDLEN, TOF, TOFLEN B1200100^^ 37 EQUIVALENCE ( HEAD(102),DATE(1) ) B1200101^^ 38 DATA HEAD/ 70*$2020, $A0A, 'ACTIVITY VERIFICATION MATRIX BUILD OF B1200102^^ 38 1', 14*$2020, ' - RESULT CODE INPUT', 5*$2020, $A0A/ B1200103^^ 39 DATA TOF/ $C /, TOFLEN/ 2 / B1200104^t FTN 3.3B (OPT = LPC) AVMCON PAGE 4 DATE: 08/29/84 TIME: 2120 t^ C ITOS LOGIN. B1200106^^ 40 CALL PGMIN(ID,LU,I,J) B1200107^^ C TERMINATE IF NOT MASTER CONSOLE. B1200108^^ 41 IF(J.NE.0) GO TO 950 B1200109^^ 42 CALL CCSCST(UTDATA,1,2,ID,1,8,ICM) ********^^ 43 IF(ICM.EQ.0) GO TO 5 ********^^ 44 CALL CCSMVA(AMDAT,1,8,AMDATA,1,8) ********^^ 45 CALL CCSMVA(ADDAT,1,8,ADDATA,1,8) ********^^ 46 CALL CCSMVA(UTDATA,3,6,UTDATA,1,8) ********^^ 47 5 CONTINUE ********^  ^ C LOGIN OK, OPEN DESCRIPTION RECORD FILE AND RETRIEVE 200 RECORDB1200111^^ C BLOCK. THIS SHOULD BE SUFFICIENT TO READ ALL RECORDS. B1200112^^ 48 CALL OPENFL(REQBUF,ADDATA,ISTAT) B1200113^^ C CHECK FOR ERROR. B1200114^^ 49 IF(ISTAT.LT.0) GO TO 50 B1200115^^ C NO ERROR, RETRIEVE RECORDS. B1200116^^ 50 CALL GETS(REQBUF,BUF,I,ISTAT) B1200117^^ C CHECK FOR ERROR. B1200118^^ 51 IF(ISTAT.LT.0) GO TO 60 B1200119^ ^ C NO ERROR, RECORD BLOCK RETRIEVED SUCESSFULLY. CLOSE FILE. B1200121^^ 52 CALL CLOSFL(REQBUF,ISTAT) B1200122^ ^ C RETRIEVE STANDARD HEADINGS FOR REPORT TYPE OUTPUT. B1200124^^ 53 CALL UTHEAD(HEAD,DATE) B1200125^ ^ 54 GO TO 90 B1200127^  ^ C FILE ERROR USING DESCRIPTION FILE. REPORT AND TERMINATE. B1200129^ ^ C OPEN FILE REQUEST. B1200131^^ 55 50 J = 3 B1200132^^ 56 GO TO 70 B1200133^ ^ C GETS ERROR. B1200135^^ 57 60 J = 14 B1200136^ ^ 58 70 CALL FILERR(ADDATA,J,ISTAT,LU) B1200138^^ 59 GO TO 900 B1200139^^ C OPEN FILE REQUEST. B1200140^t FTN 3.3B (OPT = LPC) AVMCON PAGE 5 DATE: 08/29/84 TIME: 2120 t^ C PROCESS ALL RESULT CODE RECORDS. VERIFY THEIR UNIQUE- B1200142^^ C NESS, SAVE LETTER AND COMMENT REQUIREMENTS, AND VALIDATE NEXT B1200143^^ C NEXT CONTACT DATE. B1200144^ ^ C SET UP COMPLETION VARIABLES FOR WRITE REQUESTS. B1200146^^ 60 90 ASSIGN 110 TO COMPL1 B1200147^^ 61 ASSIGN 150 TO COMPL2 B1200148^^ 62 ASSIGN 140 TO COMPL3 B1200149^ ^ C INTIALIZE POINTER TO NEXT AVAILABLE SPACE IN RESULT CODE ARRAYB1200151^^ 63 NEXT = 1 B1200152^ ^ C PRINT REPORT TYPE HEADINGS. B1200154^^ 64 ASSIGN 100 TO IRTN B1200155^^ 65 GO TO 600 B1200156^  ^ C LOOP THRU FILE LOOKING FOR RESULT CODE RECORDS. B1200158^^ 66 100 DO 150 I=1,NUMREC B1200159^^ C CALCULATE POINTER TO NEXT RECORD. B1200160^^ 67 J = 40*(I-1) + 1 B1200161^^ C CHECK FOR RESULT CODE RECORD. B1200162^^ 68 IF(BUF(J).NE.RS) GO TO 150 B1200163^ ^ C FOUND RESULT CODE RECORD. WRITE IT TO THE PRINTER. B1200165^^ 69 105 CALL FWRITE(LP,BUF(J),RECLEN,COMPL1,FLAG,TEMP) B1200166^^ 70 CALL DISP B1200167^ ^ C CHECK IF THIS IS MORE THAN THE 32 CODES ALLOWED. B1200169^^ 71 110 IF(NEXT.LT.33) GO TO 120 B1200170^^ C YES, TOO MANY RESULT CODES INPUT. REJECT THIS CODE. B1200171^^ 72 115 CALL FWRITE(LP,OVFMES,OVFMLN,COMPL2,FLAG,TEMP) B1200172^^ 73 CALL DISP B1200173^ ^ C VERIFY UNIQUENESS OF THIS CODE. B1200175^^ 74 120 K = BUF(J+1) B1200176^^ 75 CALL AVMCKV(RES,K) B1200177^^ 76 IF(K.LT.0) GO TO 130 B1200178^^ C CODE IS NOT UNIQUE, REJECT IT. B1200179^^ 77 125 CALL FWRITE(LP,DUPMES,DUPMLN,COMPL2,FLAG,TEMP) B1200180^^ 78 CALL DISP B1200181^ ^ C RETRIEVE FIFTH AND SIXTH CHARACTERS OF RECORD WHICH CONTAIN AB1200183^^ C LETTER OR COMMENT REQUIREMENTS FOR THIS RESULT. B1200184^^ 79 130 CALL CCSGET(BUF(J),FIVE,K) B1200185^^ 80 CALL CCSGET(BUF(J),SIX,L) B1200186^^ C ZERO REQUIREMENT ACCUMULATOR. B1200187^^ 81 REQ = 0 B1200188^^ C FLAG ANY LETTER OR COMMENT REQUIREMENT. B1200189^^ 82 IF(K.EQ.$4C.OR.L.EQ.$4C) REQ=$80 B1200190^^ 83 IF(K.EQ.$43.OR.L.EQ.$43) REQ=REQ+$40 B1200191^^ C EXTRACT NEXT CONTACT DATE. B1200192^^ 84 NCD = ICCSAD( BUF(J+3) ) B1200193^^ C VERIFY NEXT CONTACT DATE IS WITHIN RANGE. B1200194^t FTN 3.3B (OPT = LPC) AVMCON PAGE 6 DATE: 08/29/84 TIME: 2120 t^ 85 IF(NCD.GE.0.AND.NCD.LT.64) GO TO 140 B1200195^^ C NEXT CONTACT DATE OUT OF RANGE. SET IT TO ZERO AND REPORT ERROB1200196^^ 86 NCD = 0 B1200197^^ 87 135 CALL FWRITE(LP,NCDMES,NCDMLN,COMPL3,FLAG,TEMP) B1200198^^ 88 CALL DISP B1200199^ ^ C ADD NEXT CONTACT DATE TO REQUIREMENTS AND SAVE RESULT CODE ANDB1200201^^ C ITS ASSOCIATED REQUIREMENTS. B1200202^^ 89 140 REQ = REQ + NCD B1200203^^ 90 RES(NEXT) = BUF(J+1) B1200204^^ 91 REQS(NEXT) = REQ B1200205^ ^ C INCREMENT COUNTER AND GET NEXT RESULT CODE RECORD. B1200207^^ 92 NEXT = NEXT + 1 B1200208^ ^ 93 150 CONTINUE B1200210^t FTN 3.3B (OPT = LPC) AVMCON PAGE 7 DATE: 08/29/84 TIME: 2120 t^ C PROCESS ALL ACTION CODE RECORDS. VERIFY THEIR UNIQUENESS, DETEB1200212^^ C MINE BIT MASKS INDICATING VALID RESULT CODES, SAVE THEIR LETTEB1200213^^ C AND COMMENT REQUIREMENTS, AND VALIDATE NEXT CONTACT DATE. B1200214^ ^ C ASSIGN COMPLETION ADDRESSES FOR WRITE REQUESTS. B1200216^^ 94 ASSIGN 200 TO COMPL1 B1200217^^ 95 ASSIGN 300 TO COMPL2 B1200218^^ 96 ASSIGN 240 TO COMPL3 B1200219^^ 97 ASSIGN 260 TO COMPL4 B1200220^ ^ C RESET POINTER TO NEXT AVAILABLE SPOT IN ACTION CODE ARRAY. B1200222^^ 98 NEXT = 1 B1200223^ ^ C MOVE 'ACTION' WORDING INTO ERROR MESSAGES AND HEADINGS. B1200225^^ 99 CALL CCSMVA(ACTION,ONE,SIX,DUPMES,TEN,SIX) B1200226^^ 100 CALL CCSMVA(ACTION,ONE,SIX,OVFMES,TEN,SIX) B1200227^^ 101 CALL CCSMVA(ACTION,ONE,SIX,DATE,TEN,SIX) B1200228^ ^ C PRINT REPORT TYPE HEADINGS. B1200230^^ 102 ASSIGN 190 TO IRTN B1200231^^ 103 GO TO 600 B1200232^  ^ C LOOP THRU THE FILE CHECKING FOR ACTION CODE RECORDS. B1200234^^ 104 190 DO 300 I=1,NUMREC B1200235^^ C CALCULATE POINTER TO NEXT RECORD. B1200236^^ 105 J = 40*(I-1) + 1 B1200237^^ C CHECK FOR AN ACTION CODE RECORD. B1200238^^ 106 IF(BUF(J).NE.AC) GO TO 300 B1200239^^ C FOUND ACTION CODE RECORD. WRITE IT TO THE PRINTER. B1200240^^ 107 GO TO 105 B1200241^^ C CHECK FOR TABLE OVERFLOW WITH THIS ACTION CODE. B1200242^^ 108 200 IF(NEXT.LT.33) GO TO 210 B1200243^^ C TABLE OVERFLOW. MORE THAN THE ALLOWED 32 ACTION CODES ENTERED.B1200244^^ C REJECT THIS RECORD. B1200245^^ 109 GO TO 115 B1200246^ ^ C NO TABLE OVERFLOW. VERIFY UNIQUENESS OF THIS CODE. B1200248^^ 110 210 K = BUF(J+1) B1200249^^ 111 CALL AVMCKV(ACT,K) B1200250^^ 112 IF(K.LT.0) GO TO 220 B1200251^^ C CODE NOT UNIQUE, REJECT IT. B1200252^^ 113 GO TO 125 B1200253^ ^ C CODE UNIQUE. ACTION CODES CANNOT BE SCREEN FUNCTIONS. REJECT B1200255^^ C CODE IF IT IS. B1200256^^ 114 220 K = BUF(J+1) B1200257^^ 115 DO 225 L=1,NUMFUN B1200258^^ 116 IF(K.NE.FUNCOD(L)) GO TO 225 B1200259^^ C CODE IS A SCREEN FUNCTION CODE, REJECT IT. B1200260^^ 117 CALL FWRITE(LP,SCFMES,SCFMLN,COMPL2,FLAG,TEMP) B1200261^^ 118 CALL DISP B1200262^^ 119 225 CONTINUE B1200263^ t FTN 3.3B (OPT = LPC) AVMCON PAGE 8 DATE: 08/29/84 TIME: 2120 t^ C CODE OK. EXTRACT FIFTH AND SIXTH CHARACTERS FROM RECORD B1200265^^ C WHICH CONTAIN ANY LETTER OR COMMENT REQUIREMENTS. B1200266^^ 120 CALL CCSGET(BUF(J),FIVE,K) B1200267^^ 121 CALL CCSGET(BUF(J),SIX,L) B1200268^^ C ZERO REQUEST ACCUMULATOR. B1200269^^ 122 REQ = 0 B1200270^^ C SAVE ANY LETTER AND COMMENT REQUEST. B1200271^^ 123 IF(K.EQ.$4C.OR.L.EQ.$4C) REQ = $80 B1200272^^ 124 IF(K.EQ.$43.OR.L.EQ.$43) REQ=REQ+$40 B1200273^^ C EXTRACT NEXT CONTACT DATE. B1200274^^ 125 NCD = ICCSAD( BUF(J+3) ) B1200275^^ C VERIFY NEXT CONTACT DATE IS WITHIN RANGE. B1200276^^ 126 IF(NCD.GE.0.AND.NCD.LT.64) GO TO 240 B1200277^^ C NEXT CONTACT DATE OUT OF RANGE. SET IT TO ZERO AND REPORT ERROB1200278^^ 127 NCD = 0 B1200279^^ 128 GO TO 135 B1200280^ ^ C ADD NEXT CONTACT DATE TO ACCUMULATOR. B1200282^^ 129 240 REQ = REQ + NCD B1200283^ ^ C SAVE RESULT CODE AND ITS REQUIREMENTS. B1200285^^ 130 ACT(NEXT) = BUF(J+1) B1200286^^ 131 REQS(NEXT) = REQS(NEXT) + REQ*$100 B1200287^^ C CHECK FOR ADDITION YIELDING ZERO FOR $FFFF. B1200288^^ 132 IF(REQ.NE.0.AND.REQS(NEXT).EQ.0) REQS(NEXT)=NZERO B1200289^  ^ C DETERMINE RESULT CODE BIT MASKS FOR THIS ACTION CODE. B1200291^^ C ELIMINATE ANY DUPLICATE CODES. THE ROUITNE 'AVMCKD' WILL SET B1200292^^ C ANY DUPLICATE CODE TO BINARY ZERO, AND AS A RESULT WILL NOT B1200293^^ C HINDER BIT MASK CONSTRUCTION. B1200294^^ 133 CALL AVMCKD(BUF(J+4)) B1200295^^ 134 CALL AVMBIT(RES,BUF(J+4),BIT1(NEXT),BIT2(NEXT)) B1200296^^ C REPORT ANY REJECTED RESULT CODES. B1200297^^ 135 J = J + 4 B1200298^^ 136 DO 260 K=1,32 B1200299^^ 137 L = J + K B1200300^^ 138 IF(BUF(L).GE.0) GO TO 260 B1200301^^ C THIS RESULT CODE REJECTED. CONVERT IT BACK TO ITS ORIGINAL FORB1200302^^ C PLACE IT AND ITS HEXADECIMAL REPRESENTATION IN THE ERROR MESSAB1200303^^ C AND WRITE THE ERROR MESSAGE TO THE PRINTER. B1200304^^ 139 NRSMES(4) = -BUF(L) B1200305^^ 140 CALL CCSHXA(NRSMES(4),NRSMES(7)) B1200306^^ 141 CALL FWRITE(LP,NRSMES,NRSMLN,COMPL4,FLAG,TEMP) B1200307^^ 142 CALL DISP B1200308^^ 143 260 CONTINUE B1200309^  ^ C INCREMENT CODE POINTER AND GET NEXT ACTION CODE RECORD. B1200311^^ 144 NEXT = NEXT + 1 B1200312^  ^ 145 300 CONTINUE B1200314^t FTN 3.3B (OPT = LPC) AVMCON PAGE 9 DATE: 08/29/84 TIME: 2120 t^ C RETRIEVE OLD TABLE FROM FILE AND UPDATE WITH NEW TABLE. B1200316^^ C ZERO REQUEST BUFFER. B1200317^^ 146 DO 405 I=1,24 B1200318^^ 147 405 REQBUF(I) = 0 B1200319^ ^ C CLEAR THE FILE. B1200321^^ 148 CALL CLEAR(REQBUF,AMDATA,ISTAT) B1200322^^ C CHECK FOR ERROR. B1200323^^ 149 IF(ISTAT.LT.0) GO TO 450 B1200324^^ C NO ERROR, OPEN THE FILE. B1200325^^ 150 CALL OPENFL(REQBUF,AMDATA,ISTAT) B1200326^^ C CHECK FOR ERROR. B1200327^^ 151 IF(ISTAT.LT.0) GO TO 460 B1200328^^ C NO ERROR, SAVE THE NEW TABLE IN THE FILE. B1200329^^ 152 CALL PUTS(REQBUF,TABLE,ONE,ISTAT) B1200330^^ C CHECK FOR ERROR. B1200331^^ 153 IF(ISTAT.LT.0) GO TO 470 B1200332^^ C NO ERROR, UPDATE SUCCESSFUL. CLOSE FILE AND PROCEED TO UPDATE B1200333^^ C UTILITY FILE SECTION. B1200334^^ 154 CALL CLOSFL(REQBUF,ISTAT) B1200335^^ 155 GO TO 500 B1200336^  ^ C FILE MANAGER ERRORS USING FILE 'ACTVERTB'. B1200338^ ^ C CLEAR FILE REQUEST. B1200340^^ 156 450 J = 1 B1200341^^ 157 GO TO 480 B1200342^ ^ C OPEN FILE REQUEST. B1200344^^ 158 460 J = 3 B1200345^^ 159 GO TO 480 B1200346^ ^ C PUTS REQUEST. B1200348^^ 160 470 J = 11 B1200349^ ^ 161 480 CALL FILERR(AMDATA,J,ISTAT,LU) B1200351^^ 162 GO TO 900 B1200352^t FTN 3.3B (OPT = LPC) AVMCON PAGE 10 DATE: 08/29/84 TIME: 2120 t^ C UPDATE UTILITY FILE RECORDS. SORT ACTION CODE AND RESULT CODE B1200354^^ C ARRAYS INTO ALPHABETICAL ORDER. B1200355^^ 163 500 CALL AVMSRT(ACT) B1200356^^ 164 CALL AVMSRT(RES) B1200357^ ^ C OPEN UTILITY FILE AND UPDATE 'ACTC' AND 'RESC' RECORDS. B1200359^^ C ZERO REQUEST BUFFER FIRST. B1200360^^ 165 DO 505 I=1,32 B1200361^^ 166 505 REQBUF(I) = 0 B1200362^ ^ 167 CALL OPENFL(REQBUF,UTDATA,ISTAT) B1200364^^ C CHECK FOR ERROR. B1200365^^ 168 IF(ISTAT.LT.0) GO TO 550 B1200366^^ C NO ERROR, RETRIEVE 'ACTC' RECORD. B1200367^^ 169 CALL READR(REQBUF,BUF,ACTC,ISTAT) B1200368^^ C CHECK FOR ERROR. B1200369^^ 170 IF(ISTAT.LT.0) GO TO 560 B1200370^^ C NO ERROR, MOVE IN NEW ACTION CODES. B1200371^^ 171 CALL CCSMVA(ACT,ONE,NUMBYT,BUF(3),ONE,NUMBYT) B1200372^^ C SAVE UPDATED RECORD. B1200373^^ 172 CALL UPDREC(REQBUF,BUF,ISTAT) B1200374^^ C CHECK FOR ERROR. B1200375^^ 173 IF(ISTAT.LT.0) GO TO 570 B1200376^ ^ C UPDATE 'RESC' RECORD. B1200378^^ 174 CALL READR(REQBUF,BUF,RESC,ISTAT) B1200379^^ C CHECK FOR ERROR. B1200380^^ 175 IF(ISTAT.LT.0) GO TO 560 B1200381^^ C NO ERROR, MOVE IN NEW RESULT CODES. B1200382^^ 176 CALL CCSMVA(RES,ONE,NUMBYT,BUF(3),ONE,NUMBYT) B1200383^^ C SAVE UPDATED RECORD. B1200384^^ 177 CALL UPDREC(REQBUF,BUF,ISTAT) B1200385^^ C CHECK FOR ERROR. B1200386^^ 178 IF(ISTAT.LT.0) GO TO 570 B1200387^^ C NO ERROR, CLOSE FILE. MATRIX CONSTRUCTION COMPLETE. B1200388^^ 179 GO TO 900 B1200389^  ^ C FILE MANAGER ERRORS USING UTILITY FILE. B1200391^ ^ C OPEN FILE REQUEST. B1200393^^ 180 550 J = 3 B1200394^^ 181 GO TO 580 B1200395^ ^ C READR REQUEST. B1200397^^ 182 560 J = 13 B1200398^^ 183 GO TO 580 B1200399^ ^ C UPDREC REQUEST. B1200401^^ 184 570 J = 15 B1200402^ ^ 185 580 CALL FILERR(UTDATA,J,ISTAT,LU) B1200404^^ 186 GO TO 900 B1200405^t FTN 3.3B (OPT = LPC) AVMCON PAGE 11 DATE: 08/29/84 TIME: 2120 t^ C PRINT REPORT STYLE HEADINGS. B1200407^ ^ C GET TOP OF FORM. B1200409^^ 187 600 ASSIGN 610 TO ICOMPL B1200410^^ 188 CALL FWRITE(LP,TOF,TOFLEN,ICOMPL,FLAG,TEMP) B1200411^^ 189 CALL DISP B1200412^ ^ C OUTPUT HEADINGS. B1200414^^ 190 610 HDLEN = 40 B1200415^^ 191 ASSIGN 620 TO ICOMPL B1200416^^ 192 DO 620 I=1,5 B1200417^^ 193 J = 20*(I-1) + 1 B1200418^^ 194 IF(I.EQ.4) HDLEN=60 B1200419^^ 195 IF(I.EQ.5) J=91 B1200420^^ 196 CALL FWRITE(LP,HEAD(J),HDLEN,ICOMPL,FLAG,TEMP) B1200421^^ 197 CALL DISP B1200422^ ^ 198 620 CONTINUE B1200424^^ 199 GO TO IRTN B1200425^t FTN 3.3B (OPT = LPC) AVMCON PAGE 12 DATE: 08/29/84 TIME: 2120 t^ C CLOSE ANY FILES AND EXIT. B1200427^^ 200 900 CALL CLOSFL(REQBUF,ISTAT) B1200428^  ^ 201 950 CALL PGMOUT B1200430^^ 202 END B1200431^t FTN 3.3B (OPT = LPC) AVMCON PAGE 13 DATE: 08/29/84 TIME: 2120 t  PROGRAM LENGTH $2458 ( 9304)   EXTERNALS 2 Q8STP PGMIN CCSCST CCSMVA OPENFL GETS CLOSFL 22 UTHEAD FILERR FWRITE DISP AVMCKV CCSGET ICCSAD 22 AVMCKD AVMBIT CCSHXA CLEAR PUTS AVMSRT READR 2 UPDREC PGMOUT  t FTN 3.3B (OPT = LPC) AVMCON PAGE 14 DATE: 08/29/84 TIME: 2120 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < € 0001 (1) 0002 4,5,6,7,25,27,32,36,37,42,44,45,46,63,66,67,74,90,92,98,104,105,110,114,115,130,136,144,146,156, €* 165,192,193*" 0002 (2) 2163 42 "< 0003 (3) 2166 46,55,84,125,158,171,176,180 <" 0006 (6) 2167 46 "* 0008 (8) 2164 42,44,45,46*" 0014 (20) 2171 193"* 0028 (40) 216B 67,105,190 *& 0080 (128) 216E 82,123 &   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < ( AC INTEGER 20E2 33,35,106(2 ACT INTEGER 1F90 1,5,111,130,163,1712( ACTC INTEGER 1F8C 1,22,169 (0 ACTION INTEGER 20AF 16,18,99,100,101 0( ADDAT INTEGER 20C9 22,24,45 (, ADDATA INTEGER 1F6E 1,26,45,48,58,( AMDAT INTEGER 20C5 22,24,44 (2 AMDATA INTEGER 1F5F 1,25,44,148,150,1612& BIT1 INTEGER 1FD0 4,6,134&& BIT2 INTEGER 1FF0 4,7,134&| BUF INTEGER 0003 1,50,68,69,74,79,80,84,90,106,110,114,120,121,125,130,133,134,138,139,169,171,172,174,176,177|* COMPL1 INTEGER 20CE 28,60,69,94*2 COMPL2 INTEGER 20CF 28,61,72,77,95,117 2* COMPL3 INTEGER 20D0 28,62,87,96*( COMPL4 INTEGER 20D1 28,97,141(, DATE INTEGER 214A 35,37,53,101 ,* DUPMES INTEGER 2032 7,10,77,99 *& DUPMLN INTEGER 2047 7,15,77&, FIVE INTEGER 20E1 30,33,79,120 ,> FLAG INTEGER 20D2 28,69,72,77,87,117,141,188,196 >( FUNCOD INTEGER 20B2 18,20,116(. HDLEN INTEGER 215D 36,190,194,196 .. HEAD INTEGER 20E5 35,37,38,53,196.R I INTEGER 2161 40,50,66,67,104,105,146,147,165,166,192,193,194,195R$ ICM INTEGER 2165 42,43$. ICOMPL INTEGER 2170 187,188,191,196.& ID INTEGER 1F5B 1,40,42&* IRTN INTEGER 216A 63,102,199 *€ ISTAT INTEGER 2168 48,49,50,51,52,58,148,149,150,151,152,153,154,161,167,168,169,170,172,173,174,175,177,178,185,200€‚ J INTEGER 2162 40,41,55,57,58,67,68,69,74,79,80,84,90,105,106,110,114,120,121,125,130,133,134,135,137,156,158,160 ‚t FTN 3.3B (OPT = LPC) AVMCON PAGE 15 DATE: 08/29/84 TIME: 2120 t@ ,161,180,182,184,185,193,195,196 @\ K INTEGER 216C 74,74,75,76,79,82,83,110,111,112,114,116,120,123,124,136,137 \H L INTEGER 216D 80,82,83,115,116,121,123,124,137,138,139 H@ LP INTEGER 20CD 28,30,69,72,77,87,117,141,188,196@, LU INTEGER 2160 40,58,161,185,> NCD INTEGER 216F 83,84,85,86,89,125,126,127,129 >& NCDMES INTEGER 2048 7,11,87&& NCDMLN INTEGER 2060 7,15,87&L NEXT INTEGER 2169 62,63,71,90,91,92,98,108,130,131,132,134,144 L0 NRSMES INTEGER 2061 7,12,139,140,141 0( NRSMLN INTEGER 207B 7,15,141 (, NUMBYT INTEGER 20DF 30,32,171,176,( NUMFUN INTEGER 20C4 18,21,115(( NUMREC INTEGER 1F51 5,66,104 (( NZERO INTEGER 20E0 30,32,132(< ONE INTEGER 20DC 30,32,99,100,101,152,171,176 <* OVFMES INTEGER 207C 7,13,72,100*& OVFMLN INTEGER 2094 7,15,72&( RECLEN INTEGER 20DB 28,30,69 (H REQ INTEGER 20E4 33,81,82,83,89,91,122,123,124,129,131,132H^ REQBUF INTEGER 1F43 1,5,22,48,50,52,147,148,150,152,154,166,167,169,172,174,177,200^. REQS INTEGER 2010 4,7,91,131,132 .4 RES INTEGER 1FB0 4,6,75,90,134,164,1764( RESC INTEGER 1F8E 1,22,174 (( RS INTEGER 20E3 33,35,68 (( SCFMES INTEGER 2095 7,14,117 (( SCFMLN INTEGER 20AE 7,16,117 (6 SIX INTEGER 20DD 30,32,80,99,100,101,1216. TABLE INTEGER 1F90 1,5,6,7,28,152 .> TEMP INTEGER 20D3 28,69,72,77,87,117,141,188,196 >0 TEN INTEGER 20DE 30,32,99,100,101 0( TOF INTEGER 215E 36,39,188(( TOFLEN INTEGER 215F 36,39,188(2 UTDATA INTEGER 1F7D 1,27,42,46,167,185 2   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " AVMBIT SUBROUTINE 234E 133"" AVMCKD SUBROUTINE 233F 132"& AVMCKV SUBROUTINE 22C4 74,111 && AVMSRT SUBROUTINE 23BE 163,164&" CCSCST SUBROUTINE 217E 41 ", CCSGET SUBROUTINE 22EF 79,80,120,121," CCSHXA SUBROUTINE 236A 139": CCSMVA SUBROUTINE 23DF 43,45,46,99,100,101,171,176:" CLEAR SUBROUTINE 238D 147"* CLOSFL SUBROUTINE 2451 51,154,200 *: DISP SUBROUTINE 2423 69,73,78,88,118,142,189,197:* FILERR SUBROUTINE 23B6 58,161,185 *: FWRITE SUBROUTINE 241B 68,72,77,87,117,141,188,196:t FTN 3.3B (OPT = LPC) AVMCON PAGE 16 DATE: 08/29/84 TIME: 2120 t" GETS SUBROUTINE 21AA 49 "& ICCSAD INTEGER.FN. 2315 84,125 &* OPENFL SUBROUTINE 2397 47,150,167 *" PGMIN SUBROUTINE 2173 39 "" PGMOUT SUBROUTINE 2455 201"" PUTS SUBROUTINE 23A0 151" Q8STP INTEGER.FN. 2457 & READR SUBROUTINE 23D5 168,174&& UPDREC SUBROUTINE 23E7 171,177&" UTHEAD SUBROUTINE 21B7 52 "   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 5 21A0 43,47$$ 50 21BB 49,55$$ 60 21BE 51,57$$ 70 21C0 55,58$$ 90 21C8 53,60$$ 100 21DB 63,66$& 105 21F3 68,107 &$ 110 2201 60,71$& 115 2205 71,109 &$ 120 220D 71,74$& 125 2219 76,113 &$ 130 2221 76,79$& 135 2258 86,128 &( 140 2260 61,85,89 (* 150 226D 60,66,68,93*& 190 22A0 101,104&& 200 22B9 93,108 && 210 22BE 108,110&& 220 22CC 112,114&* 225 22E7 114,116,119** 240 2322 95,126,129 *. 260 2377 96,136,138,143 .. 300 237D 94,104,106,145 .& 405 2383 145,147&& 450 23AD 149,156&& 460 23B0 151,158&& 470 23B3 153,160&* 480 23B5 156,159,161*& 500 23BD 154,163&& 505 23C4 164,166&& 550 2407 168,180&* 560 240B 170,175,182** 570 240E 173,178,184** 580 2410 180,183,185** 600 2416 63,103,187 *& 610 2424 187,190&* 620 2449 190,192,198*t FTN 3.3B (OPT = LPC) AVMCON PAGE 17 DATE: 08/29/84 TIME: 2120 t2 900 2450 58,162,179,186,200 2& 950 2454 41,201 & AVMCON 0000 1  t FTN 3.3B (OPT = LPC) AVMDMP PAGE 1 DATE: 08/29/84 TIME: 2121 t^ 1 PROGRAM AVMDMP B1300001^^ 1 1 /B13 F CCS CCS 3.0 SL-149B1300002^^ C B1300003^^ C CYBERCREDIT SYSTEM VERSION 3 B1300004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B1300005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B1300006^^ C B1300007^^ C B1300008^^ C DUMP ACTIVITY VERIFICATION MATRIX. B1300009^^ C B1300010^^ C THIS PROGRAM WILL PRINT AN INTELLIGIBLE DUMP OF THE ACTIVITY VERI-B1300011^^ C FICATION MATRIX STORED IN THE FILE 'ACTVERTB'. THE MATRIX CALLED B1300012^^ C 'TBL' CONTAINS A LIST OF ALL VALID ACTION CODES, LIST OF ALL VALIDB1300013^^ C RESULT CODES, MASKS FOR DETERMINING VALID ACTION/RESULT CODE PAIRSB1300014^^ C AND DEFAULT VALUES FOR NEXT CONTACT DATE AND LETTER AND COMMENT B1300015^^ C REQUIREMENTS FOR EACH PAIR THAT IS VALID. A MORE DETAILED DESCRIP-B1300016^^ C TION OF 'TBL' IS FOUND IN THE AVMVAC SUBROUTINE. B1300017^^ C B1300018^ ^ 2 INTEGER REQBUF(24),IDATA(15),TBL(162),ACT(1),RES(1),OBUF(66) B1300020^^ 3 INTEGER ASTRKS,LETREQ,COMREQ,NCD,BZ,RL,LREQD,CREQD,ONE,DP,NA,SR,PPB1300021^^ 4 INTEGER HEAD1(21),HEAD2(10),HEAD3(3),HEAD4(6),HEAD5,HEAD6(7) B1300022^^ 5 INTEGER FLAG,TEMP(8),LEN,TOF,LF B1300023^^ 6 INTEGER BLANKS,NC,WRITE,STDHDR(20,3),DATE(3),HEAD7(5),HDRLEN B1300024^^ 7 INTEGER ASCZER,LENHD1,LENHD2,HDRONE,HDRTWO,HDRTHR,ONE,TWO,DATFLD B1300025^^ 8 INTEGER LENHD6,LENHD7,DATPOS,TILPOS,ZEROES,SIXTEN,ERRLEN,ASCNIN B1300026^^ 9 INTEGER UTILRQ(24),IDATB(15),UTILRC(41),UTKEY(2),Y,WONE B1300027^ ^ 10 DATA ASTRKS/'**'/,BZ/'BZ'/,RL/'RL'/,LREQD/'L '/,CREQD/'C '/, B1300029^^ 10 1 WONE/'01'/,DP/'DP'/,NA/'NA'/,SR/'SR'/,PP/'PP'/,BLANKS/' '/ B1300030^^ 11 DATA NC/'NC'/ B1300031^^ 12 DATA HEAD1/' ACTIVITY VERIFICATION TABLE PAGE'/ B1300032^^ 13 DATA HEAD2/'R E S U L T C O D E'/ B1300033^^ 14 DATA HEAD3/'ACT '/ B1300034^^ 15 DATA HEAD4/'ION L C CD'/ B1300035^^ 16 DATA HEAD5/'--'/ B1300036^^ 17 DATA HEAD6/' END OF TABLE '/ B1300037^^ 18 DATA HEAD7/'RUN DATE: '/ B1300038^^ 19 DATA IDATA/'ACTVERTB',8*$2020,0,1,0/,FLAG/0/,LEN/132/,LF/$D20/, B1300039^^ 19 1 TOF/$C20/,REQBUF/24*0/,OBUF/66*$2020/ B1300040^^ 20 DATA ASCZER/$2030/,LENHD1/34/,LENHD2/20/,HDRONE/1/,HDRTWO/41/, B1300041^^ 20 1 HDRTHR/81/,ONE/1/,TWO/2/,LENHD6/14/,LENHD7/10/ B1300042^^ 21 DATA DATPOS/63/,TILPOS/45/,ZEROES/$3030/,SIXTEN/$3136/,ERRLEN/44/ B1300043^^ 22 DATA ASCNIN/$39/,HDRLEN/40/,DATFLD/1/,LP/9/ B1300044^^ 23 DATA UTILRQ/24*0/,UTILRC/41*0/,UTKEY/'OLPM'/,NARL/0/,Y/'Y '/ B1300045^^ 24 DATA IDATB/'UTIFIL ',8*$2020,1,1,0/ B1300046^  ^ 25 EQUIVALENCE (TBL(1),ACT(1)),(TBL(33),RES(1)) B1300048^  ^ C LOGIN SECTION. B1300050^^ 26 CALL PGMIN(TEMP,LU,I,J) B1300051^^ C VERIFY MASTER CONSOLE ONLY. EXIT IF NOT. B1300052^t FTN 3.3B (OPT = LPC) AVMDMP PAGE 2 DATE: 08/29/84 TIME: 2121 t^ 27 IF(J.NE.0) GO TO 900 B1300053^^ C OPEN THE UTIFIL B1300054^^ 28 CALL OPENFL(UTILRQ,IDATB,ISTAT) B1300055^^ 29 IF(ISTAT.GE.0) GO TO 40 B1300056^^ 30 CALL FILERR(IDATB,3,ISTAT,LU) B1300057^^ 31 GO TO 900 B1300058^^ C RETRIEVE THE OLPM RECORD FROM THE UTIFIL B1300059^^ 32 40 CALL READR(UTILRQ,UTILRC,UTKEY,ISTAT) B1300060^^ 33 IF(ISTAT.GE.0)GO TO 50 B1300061^^ 34 CALL FILERR(IDATB,13,ISTAT,LU) B1300062^^ 35 GO TO 900 B1300063^^ C CLOSE THE UTIFIL B1300064^^ 36 50 CALL CLOSFL(UTILRQ,ISTAT) B1300065^^ C CHECK FOR NA PARAMETER B1300066^^ 37 CALL CCSCST(UTILRC,20,1,Y,1,1,ICOMP) B1300067^^ 38 IF(ICOMP.NE.0) GO TO 60 B1300068^^ 39 NARL=1 B1300069^^ 40 60 CONTINUE B1300070^  ^ C RETRIEVE TBL FROM FILE. B1300072^^ 41 100 CALL OPENFL(REQBUF,IDATA,ISTAT) B1300073^^ C CHECK FOR ERROR. B1300074^^ 42 IF(ISTAT.LT.0) GO TO 810 B1300075^^ C RETRIEVE TBL, THEN CLOSE FILE. B1300076^^ 43 CALL GETS(REQBUF,TBL,TEMP,ISTAT) B1300077^^ C CHECK FOR ERROR. B1300078^^ 44 IF(ISTAT.LT.0) GO TO 820 B1300079^^ 45 CALL CLOSFL(REQBUF,ISTAT) B1300080^ ^ C RETRIEVE STANDARD HEADINGS FOR OUTPUT. B1300082^^ 46 CALL UTHEAD(STDHDR,DATE) B1300083^t FTN 3.3B (OPT = LPC) AVMDMP PAGE 3 DATE: 08/29/84 TIME: 2121 t^ C B1300085^^ C DUMP MATRIX SHOWING FOR EACH ACTION/RESULT CODE PAIR WHETHER THE B1300086^^ C COMBINATION IS VALID. ALSO IF IT IS VALID, SHOW THE DEFAULT VALUE B1300087^^ C IN DAYS FOR NEXT CONTACT AND ANY LETTER OR COMMENT REQUIREMENTS. B1300088^^ C B1300089^^ C INTIALIZE VARIABLES. B1300090^^ 47 200 I = 1 B1300091^^ 48 J = 1 B1300092^^ 49 N = ASCZER B1300093^^ 50 ASSIGN 450 TO WRITE B1300094^^ C CHECK IF ANY RESULTS TO PROCESS THIS ROUND. B1300095^^ 51 210 IF(RES(J).EQ.ASTRKS) GO TO 355 B1300096^^ C B1300097^^ C OUTPUT HEADINGS. B1300098^^ C B1300099^^ C BLANK OUTPUT BUFFER. B1300100^^ 52 CALL CCSBLK(OBUF,LEN) B1300101^^ C SET TOP OF FORM. B1300102^^ 53 OBUF(1) = TOF B1300103^^ 54 CALL CCSMVA(HEAD1,ONE,LENHD1,OBUF,TILPOS,LENHD1) B1300104^^ C SET PAGE NUMBER. B1300105^^ 55 N = N+1 B1300106^^ 56 OBUF(57) = HEAD1(20) B1300107^^ 57 OBUF(58) = HEAD1(21) B1300108^^ 58 OBUF(59) = N B1300109^^ C MOVE IN STANDARD HEADING. B1300110^^ 59 IF(RES(M).EQ.NA.AND.NARL.EQ.1) OBUF(JJ+4)=RL B1300111^^ 60 CALL CCSMVA(STDHDR,HDRONE,HDRLEN,OBUF,TWO,HDRLEN) B1300112^^ 61 ASSIGN 215 TO ICOMPL B1300113^^ 62 GO TO WRITE B1300114^^ C MOVE IN SECOND LINE OF HEADING BLANKING REMAINING BUFFER. B1300115^^ 63 215 CALL CCSMVA(STDHDR,HDRTWO,HDRLEN,OBUF,ONE,LEN) B1300116^^ C MOVE IN DATE. B1300117^^ 64 TILPOS = TILPOS + 8 B1300118^^ 65 CALL CCSMVA(HEAD7,ONE,LENHD7,OBUF,TILPOS,LENHD7) B1300119^^ 66 CALL EDIT(DATE,ONE,OBUF,DATPOS,DATFLD) B1300120^^ 67 ASSIGN 220 TO ICOMPL B1300121^^ 68 GO TO WRITE B1300122^^ C MOVE IN THIRD LINE OF HEADING BLANKING REMAINING BUFFER. B1300123^^ 69 220 CALL CCSMVA(STDHDR,HDRTHR,HDRLEN,OBUF,ONE,LEN) B1300124^^ 70 ASSIGN 225 TO ICOMPL B1300125^^ 71 GO TO WRITE B1300126^^ C BLANK OUTPUT BUFFER. B1300127^^ 72 225 CALL CCSBLK(OBUF,LEN) B1300128^^ 73 OBUF(1) = LF B1300129^^ 74 TILPOS = TILPOS + 3 B1300130^^ 75 CALL CCSMVA(HEAD2,ONE,LENHD2,OBUF,TILPOS,LENHD2) B1300131^^ 76 ASSIGN 230 TO ICOMPL B1300132^^ 77 GO TO WRITE B1300133^^ C BLANK OUTPUT BUFFER. B1300134^^ 78 230 TILPOS=TILPOS - 11 B1300135^^ 79 CALL CCSBLK(OBUF,LEN) B1300136^^ 80 OBUF(1) = LF B1300137^^ 81 OBUF(2) = $20 B1300138^t FTN 3.3B (OPT = LPC) AVMDMP PAGE 4 DATE: 08/29/84 TIME: 2121 t^ 82 IF(J.NE.1) GO TO 235 B1300139^^ 83 L = ZEROES B1300140^^ 84 GO TO 240 B1300141^^ 85 235 L = SIXTEN B1300142^^ 86 240 DO 245 K=1,16 B1300143^^ 87 L = L+1 B1300144^^ 88 IF(AND(L,$FF).GT.ASCNIN) L=L+$F6 B1300145^^ 89 245 OBUF(4*K+2) = L B1300146^^ 90 250 ASSIGN 255 TO ICOMPL B1300147^^ 91 GO TO WRITE B1300148^^ C BLANK OUTPUT BUFFER. B1300149^^ 92 255 CALL CCSBLK(OBUF,LEN) B1300150^^ 93 DO 260 K=1,3 B1300151^^ 94 260 OBUF(K) = HEAD3(K) B1300152^^ 95 L = J + 15 B1300153^^ 96 DO 265 K=J,L B1300154^^ 97 IF(RES(K).EQ.ASTRKS) GO TO 270 B1300155^^ 98 M = AND(K-1,$F) + 1 B1300156^^ 99 265 OBUF(4*M+1) = RES(K) B1300157^^ 100 270 ASSIGN 275 TO ICOMPL B1300158^^ 101 GO TO WRITE B1300159^^ C BLANK OUTPUT BUFFER. B1300160^^ 102 275 CALL CCSBLK(OBUF,LEN) B1300161^^ 103 DO 280 K=1,3 B1300162^^ 104 280 OBUF(K) = HEAD4(K) B1300163^^ 105 DO 285 K=1,16 B1300164^^ 106 OBUF(4*K+0) = HEAD4(4) B1300165^^ 107 OBUF(4*K+1) = HEAD4(5) B1300166^^ 108 285 OBUF(4*K+2) = HEAD4(6) B1300167^^ 109 ASSIGN 290 TO ICOMPL B1300168^^ 110 GO TO WRITE B1300169^^ C BLANK OUTPUT BUFFER. B1300170^^ 111 290 CALL CCSBLK(OBUF,LEN) B1300171^^ 112 OBUF(1) = HEAD5 B1300172^^ 113 OBUF(2) = AND($FF20,HEAD5) B1300173^^ 114 DO 300 K=1,16 B1300174^^ 115 OBUF(4*K+0) = HEAD5 B1300175^^ 116 OBUF(4*K+1) = HEAD5 B1300176^^ 117 300 OBUF(4*K+2) = HEAD5 B1300177^^ 118 ASSIGN 305 TO ICOMPL B1300178^^ 119 GO TO WRITE B1300179^t FTN 3.3B (OPT = LPC) AVMDMP PAGE 5 DATE: 08/29/84 TIME: 2121 t^ C HEADINGS COMPLETE. PROCESS ACTION/RESULT CODE PAIRS FILLING THE B1300181^^ C OUTPUT BUFFER WITH THE INFORMATION PERTAINING TO EACH PAIR. B1300182^^ 120 305 L = I+15 B1300183^^ C LOOP THRU ALL ACTION CODES CHECKING ALL POSSIBLE RESULTS WITH IT. B1300184^^ 121 DO 350 K=I,L B1300185^^ C CHECK IF ALL ACTION CODES DONE. B1300186^^ 122 IF(ACT(K).EQ.ASTRKS) GO TO 355 B1300187^^ C BLANK OUTPUT BUFFER AND OUTPUT TWO BLANK LINES FOR TRIPLE SPACING.B1300188^^ 123 CALL CCSBLK(OBUF,LEN) B1300189^^ 124 OBUF(1) = LF B1300190^^ 125 ASSIGN 310 TO ICOMPL B1300191^^ 126 GO TO WRITE B1300192^^ 127 310 OBUF(1) = ACT(K) B1300193^^ 128 II = J + 15 B1300194^^ C LOOP THRU ALL RESULT CODES. B1300195^^ 129 DO 340 M=J,II B1300196^^ C CHECK IF ALL RESULT CODES CHECK WITH THIS ACTION CODE. B1300197^^ 130 IF(RES(M).EQ.ASTRKS) GO TO 345 B1300198^^ C CHECK THIS ACTION/RESULT CODE PAIR. B1300199^^ 131 CALL AVMVAC(TBL,ACT(K),RES(M),LETREQ,COMREQ,NCD) B1300200^^ 132 JJ = 4 * (AND(M-1,$F) + 1) - 2 B1300201^^ C CHECK IF THIS ACTION/RESULT CODE PAIR ALLOWED (NCD > OR = 0). B1300202^^ 133 IF(NCD.LT.0) GO TO 330 B1300203^^ C PAIR VALID. SET LETTER AND COMMENT REQUIREMENTS IF ANY. B1300204^^ 134 320 IF(LETREQ.NE.0) OBUF(JJ+2)=LREQD B1300205^^ 135 IF(COMREQ.NE.0) OBUF(JJ+3)=CREQD B1300206^^ C CHECK FOR ACTION = SR, RESULT = PP OR BZ, OR NCD = 0 INDICATING B1300207^^ C SPECIAL VALUE FOR NEXT CONTACT. B1300208^^ 136 IF(ACT(K).EQ.SR) OBUF(JJ+4)=WONE B1300209^^ 137 IF(RES(M).EQ.PP) OBUF(JJ+4)=DP B1300210^^ 138 IF(RES(M).EQ.BZ) OBUF(JJ+4)=RL B1300211^^ 139 IF(OBUF(JJ+4).NE.BLANKS) GO TO 340 B1300212^^ 140 IF(NCD.EQ.0) OBUF(JJ+4)=NC B1300213^^ 141 IF(OBUF(JJ+4).NE.BLANKS) GO TO 340 B1300214^^ C CONVERT NEXT CONTACT DATE. B1300215^^ 142 OBUF(JJ+4) = (NCD/10 * $100) + AND(NCD-(NCD/10)*10,$F) + ZEROES B1300216^^ 143 GO TO 340 B1300217^^ 144 330 OBUF(JJ+4) = NA B1300218^^ 145 340 CONTINUE B1300219^ ^ C OUTPUT BUFFER. B1300221^^ 146 345 ASSIGN 350 TO ICOMPL B1300222^^ 147 GO TO WRITE B1300223^^ 148 350 CONTINUE B1300224^ ^ C CHECK IF MORE ACTION/RESULT CODES TO CHECK. B1300226^^ 149 355 IF((I.EQ.17.AND.J.EQ.17).OR.(I.EQ.17.AND.M.LT.17).OR.(J.EQ.17.AND.B1300227^^ 149 1 K.LT.17).OR.(M.LT.17.AND.K.LT.17)) GO TO 400 B1300228^^ 150 IF(J.EQ.17) GO TO 370 B1300229^ ^ 151 J = 17 B1300231^^ 152 GO TO 210 B1300232^ ^ 153 370 I = 17 B1300234^t FTN 3.3B (OPT = LPC) AVMDMP PAGE 6 DATE: 08/29/84 TIME: 2121 t^ 154 J = 1 B1300235^^ 155 GO TO 210 B1300236^t FTN 3.3B (OPT = LPC) AVMDMP PAGE 7 DATE: 08/29/84 TIME: 2121 t^ C B1300238^^ C MATRIX OUTPUT COMPLETE. OUTPUT END OF MATRIX MESSAGE AND EXIT. B1300239^^ C B1300240^^ 156 400 CALL CCSBLK(OBUF,LEN) B1300241^^ 157 OBUF(1) = LF B1300242^^ 158 ASSIGN 405 TO ICOMPL B1300243^^ 159 GO TO WRITE B1300244^^ 160 405 TILPOS = TILPOS + 4 B1300245^^ 161 CALL CCSMVA(HEAD6,ONE,LENHD6,OBUF,TILPOS,LENHD6) B1300246^^ 162 ASSIGN 900 TO ICOMPL B1300247^  ^ C WRITE FILLED OUTPUT BUFFER. B1300249^^ 163 450 CALL FWRITE(LP,OBUF,LEN,ICOMPL,FLAG,TEMP) B1300250^^ 164 CALL DISP B1300251^t FTN 3.3B (OPT = LPC) AVMDMP PAGE 8 DATE: 08/29/84 TIME: 2121 t^ C B1300253^^ C FILE ERRORS. B1300254^^ C B1300255^^ C OPENFL ERROR. B1300256^^ 165 810 I = 3 B1300257^^ 166 GO TO 830 B1300258^ ^ C GETS ERROR. B1300260^^ 167 820 I = 14 B1300261^ ^ C REPORT ERROR TO USER. B1300263^^ 168 830 CALL FILERR(IDATA,I,ISTAT,LU) B1300264^ ^ C FORCE FILE CLOSURE, BYPASS ANY ERROR. B1300266^^ 169 850 CALL CLOSFL(REQBUF,ISTAT) B1300267^   ^ C NORMAL TERMINATION. B1300269^^ 170 900 CALL PGMOUT B1300270^^ 171 END B1300271^t FTN 3.3B (OPT = LPC) AVMDMP PAGE 9 DATE: 08/29/84 TIME: 2121 t  PROGRAM LENGTH $04F1 ( 1265)   EXTERNALS 2 Q8STP PGMIN OPENFL FILERR READR CLOSFL CCSCST 22 GETS UTHEAD CCSBLK CCSMVA EDIT AVMVAC FWRITE 2 DISP PGMOUT  t FTN 3.3B (OPT = LPC) AVMDMP PAGE 10 DATE: 08/29/84 TIME: 2121 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " FF20 (-223) 0216 113"‚ 0001 (1) 0002 2,19,20,22,24,25,37,39,47,48,53,55,59,73,80,82,86,87,93,98,99,103,105,107,112,114,116,124,127,132, ‚& 154,157&4 0003 (3) 0209 30,74,93,103,135,165 4& 000A (10) 0218 142,142&" 000D (13) 020A 34 "4 000F (15) 0215 95,98,120,128,132,1424$ 0014 (20) 020B 37,56$" 00F6 (246) 0214 88 "" 00FF (255) 0213 88 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < 4 ACT INTEGER 002A 1,25,122,127,131,136 40 AND INTR.FN. 7FFF 88,98,113,132,1420& ASCNIN INTEGER 01AE 7,22,88&& ASCZER INTEGER 019F 2,20,49&2 ASTRKS INTEGER 010E 2,10,51,97,122,130 2, BLANKS INTEGER 0157 2,10,139,141 ,( BZ INTEGER 0112 2,10,138 (( COMREQ INTEGER 0110 2,131,135(( CREQD INTEGER 0115 2,10,135 (& DATE INTEGER 0196 2,46,66&& DATFLD INTEGER 01A6 7,22,66&& DATPOS INTEGER 01A9 7,21,66&( DP INTEGER 0117 2,10,137 ($ ERRLEN INTEGER 01AD 7,21 $( FLAG INTEGER 014B 2,19,163 (, HDRLEN INTEGER 019E 2,22,60,63,69,& HDRONE INTEGER 01A2 2,20,60&& HDRTHR INTEGER 01A4 2,20,69&& HDRTWO INTEGER 01A3 2,20,63&, HEAD1 INTEGER 011B 2,12,54,56,57,& HEAD2 INTEGER 0130 2,13,75&& HEAD3 INTEGER 013A 2,14,94&4 HEAD4 INTEGER 013D 2,15,104,106,107,108 48 HEAD5 INTEGER 0143 2,16,112,113,115,116,117 8( HEAD6 INTEGER 0144 2,17,161 (& HEAD7 INTEGER 0199 2,18,65&@ I INTEGER 0206 26,47,120,121,149,153,165,167,168@$ ICOMP INTEGER 020C 37,38$N ICOMPL INTEGER 0210 60,67,70,76,90,100,109,118,125,146,158,162,163 Nt FTN 3.3B (OPT = LPC) AVMDMP PAGE 11 DATE: 08/29/84 TIME: 2121 t* IDATA INTEGER 001B 1,19,41,168*, IDATB INTEGER 01C7 7,24,28,30,34,* II INTEGER 0217 127,128,129*J ISTAT INTEGER 0208 28,29,30,32,33,34,36,41,42,43,44,45,168,169JL J INTEGER 0207 26,27,48,51,82,95,96,128,129,149,150,151,154 LN JJ INTEGER 020F 59,132,134,135,136,137,138,139,140,141,142,144 Nv K INTEGER 0212 86,89,93,94,96,97,98,99,103,104,105,106,107,108,114,115,116,117,121,122,127,131,136,149v> L INTEGER 0211 82,83,85,87,88,89,95,96,120,121>J LEN INTEGER 0154 2,19,52,63,69,72,79,92,102,111,123,156,163 J& LENHD1 INTEGER 01A0 2,20,54&& LENHD2 INTEGER 01A1 2,20,75&( LENHD6 INTEGER 01A7 7,20,161 (& LENHD7 INTEGER 01A8 7,20,65&( LETREQ INTEGER 010F 2,131,134(2 LF INTEGER 0156 2,19,73,80,124,157 2& LP INTEGER 0203 22,163 &( LREQD INTEGER 0114 2,10,134 (, LU INTEGER 0205 26,30,34,168 ,D M INTEGER 020E 59,98,99,129,130,131,132,137,138,149 D* N INTEGER 020D 48,49,55,58** NA INTEGER 0118 2,10,59,144*( NARL INTEGER 0204 23,39,59 (( NC INTEGER 0158 2,11,140 (0 NCD INTEGER 0111 2,131,133,140,1420‚ OBUF INTEGER 00CC 2,19,52,53,54,56,57,58,59,60,63,65,66,69,72,73,75,79,80,81,89,92,94,99,102,104,106,107,108,111,112 ‚t ,113,115,116,117,123,124,127,134,135,136,137,138,139,140,141,142,144,156,157,161,163 t< ONE INTEGER 0116 2,7,20,54,63,65,66,69,75,161 <( PP INTEGER 011A 2,10,137 (0 REQBUF INTEGER 0003 1,19,41,43,45,1690@ RES INTEGER 004A 2,25,51,59,97,99,130,131,137,138 @* RL INTEGER 0113 2,10,59,138*& SIXTEN INTEGER 01AC 7,21,85&( SR INTEGER 0119 2,10,136 (, STDHDR INTEGER 015A 2,46,60,63,69,* TBL INTEGER 002A 1,25,43,131** TEMP INTEGER 014C 2,26,43,163*> TILPOS INTEGER 01AA 7,21,54,64,65,74,75,78,160,161 >& TOF INTEGER 0155 2,19,53&& TWO INTEGER 01A5 7,20,60&* UTILRC INTEGER 01D6 7,23,32,37 *, UTILRQ INTEGER 01AF 7,23,28,32,36,& UTKEY INTEGER 01FF 7,23,32&( WONE INTEGER 0202 7,10,136 (J WRITE INTEGER 0159 2,50,62,68,71,77,91,101,110,119,126,147,159J& Y INTEGER 0201 7,23,37&* ZEROES INTEGER 01AB 7,21,83,142*t FTN 3.3B (OPT = LPC) AVMDMP PAGE 12 DATE: 08/29/84 TIME: 2121 t   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " AVMVAC SUBROUTINE 040C 130": CCSBLK SUBROUTINE 04B9 51,72,79,92,102,111,123,156:" CCSCST SUBROUTINE 0249 36 "4 CCSMVA SUBROUTINE 04CA 53,60,63,65,69,75,1614( CLOSFL SUBROUTINE 04EA 36,45,169(" DISP SUBROUTINE 04DD 163"" EDIT SUBROUTINE 02D2 65 "( FILERR SUBROUTINE 04E4 29,34,168(" FWRITE SUBROUTINE 04D5 163"" GETS SUBROUTINE 0260 42 "$ OPENFL SUBROUTINE 0225 27,41$" PGMIN SUBROUTINE 021A 25 "" PGMOUT SUBROUTINE 04EE 170" Q8STP INTEGER.FN. 04F0 " READR SUBROUTINE 0235 32 "" UTHEAD SUBROUTINE 026E 45 "   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 40 0234 29,32$$ 50 0244 33,36$$ 60 0256 38,40$" 100 0256 40 "" 200 0271 46 "* 210 027B 50,152,155 *$ 215 02BF 60,63$$ 220 02DD 66,69$$ 225 02E9 69,72$$ 230 02FE 75,78$$ 235 0313 82,85$$ 240 0316 83,86$$ 245 0326 86,89$" 250 0331 89 "$ 255 0337 89,92$$ 260 033C 92,94$$ 265 035F 95,99$& 270 0369 97,100 && 275 036F 100,102&& 280 0374 102,104&& 285 038D 104,108&& 290 03A0 108,111&& 300 03BA 113,117&& 305 03CA 117,120&t FTN 3.3B (OPT = LPC) AVMDMP PAGE 13 DATE: 08/29/84 TIME: 2121 t& 310 03EB 124,127&" 320 0422 133"& 330 047D 133,144&2 340 0481 128,139,141,143,1452& 345 0485 130,146&* 350 048B 120,146,148** 355 048E 51,122,149 *& 370 04B2 150,153&& 400 04B8 149,156&& 405 04C5 157,160&& 450 04D4 49,163 && 810 04DE 42,165 && 820 04E1 44,167 && 830 04E3 165,168&" 850 04E9 168"0 900 04ED 27,31,35,162,170 0 AVMDMP 0000 1  t FTN 3.3B (OPT = LPC) AVMSRT PAGE 1 DATE: 08/29/84 TIME: 2122 t^ 1 SUBROUTINE AVMSRT(ARR) B1400001^^ 1 1 /B14 F CCS CCS 3.0 SL-149B1400002^^ C B1400003^^ C CYBERCREDIT SYSTEM VERSION 3 B1400004^^ C DATA SYSTEMS -LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B1400005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B1400006^^ C B1400007^^ C B1400008^^ C SORT 32 WORD ARRAY 'ARR'. B1400009^^ C B1400010^^ C ROUTINE TO PERFORM AN ALPHABETICAL SORT OF THE ELEMENTS OF THE ARRB1400011^^ C 'ARR'. 'ARR' IS 32 WORDS LONG, BUT CAN CONTAIN FEWER ELEMENTS WHENB1400012^^ C TERMINATED BY ONE ELEMENT CONTAINING '**'. THE DOUBLE ASTERISK B1400013^^ C SHOULD NOT BE SORTED, BUT LEFT AT THE END OF THE LIST. B1400014^^ C B1400015^^ C SORT IS A BUBBLE SORT. B1400016^^ 2 INTEGER ARR(1),TEMP,ASTRKS B1400017^ ^ 3 DATA ASTRKS/'**'/ B1400019^ ^ 4 K = 1 B1400021^^ 5 IF(ARR(2).EQ.ASTRKS) GO TO 90 B1400022^^ 6 IF(ARR(2).GT.ARR(1)) GO TO 10 B1400023^^ 7 TEMP = ARR(2) B1400024^^ 8 ARR(2) = ARR(1) B1400025^^ 9 ARR(1) = TEMP B1400026^^ 10 10 DO 30 I=2,31 B1400027^^ 11 IF(ARR(I+1).EQ.ASTRKS) GO TO 90 B1400028^^ 12 IF(ARR(I).LT.ARR(I+1)) GO TO 30 B1400029^^ 13 TEMP = ARR(I) B1400030^^ 14 ARR(I) = ARR(I+1) B1400031^^ 15 ARR(I+1) = TEMP B1400032^^ 16 DO 20 J=I,2,-K B1400033^^ 17 IF(ARR(J).GT.ARR(J-1)) GO TO 30 B1400034^^ 18 TEMP = ARR(J) B1400035^^ 19 ARR(J) = ARR(J-1) B1400036^^ 20 ARR(J-1) = TEMP B1400037^^ 21 20 CONTINUE B1400038^^ 22 30 CONTINUE B1400039^ ^ C SORT COMPLETE. B1400041^^ 23 90 RETURN B1400042^^ 24 END B1400043^t FTN 3.3B (OPT = LPC) AVMSRT PAGE 2 DATE: 08/29/84 TIME: 2122 t  PROGRAM LENGTH $005D ( 93)   EXTERNALS  Q8PKUP Q8PREP  t FTN 3.3B (OPT = LPC) AVMSRT PAGE 3 DATE: 08/29/84 TIME: 2122 t, ***** L I S T O F S Y M B O L S *****,   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < H ARR INTEGER 7FFF 1,2,5,6,7,8,9,11,12,13,14,15,17,18,19,20 H( ASTRKS INTEGER 0001 2,3,5,11 (4 I INTEGER 0003 10,11,12,13,14,15,16 4. J INTEGER 0004 15,17,18,19,20 .& K INTEGER 0002 3,4,16 &0 TEMP INTEGER 0000 2,7,9,13,15,18,200   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  Q8PKUP INTEGER.FN. 0052 Q8PREP INTEGER.FN. 004F    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 10 0016 6,10 $$ 20 003D 15,21$* 30 0044 10,12,17,22*& 90 0049 5,11,23& AVMSRT 004C 1  t FTN 3.3B (OPT = LPC) AVMVAC PAGE 1 DATE: 08/29/84 TIME: 2122 t^ 1 SUBROUTINE AVMVAC(TBL,ACT,RES,LETREQ,COMREQ,NCD) B1500001^^ 1 1 /B15 F CCS CCS 3.0 SL-149B1500002^^ C B1500003^^ C CYBERCREDIT SYSTEM VERSION 3 B1500004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B1500005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B1500006^^ C B1500007^^ C B1500008^^ C VERIFY INPUT ACTIVITY CODES IF VALID, RETURN NEXT CONTACT DATE B1500009^^ C IN DAYS AND LETTER AND COMMENT REQUIREMENTS. B1500010^^ C B1500011^^ C CALLING SEQUENCE: B1500012^^ C CALL AVMVAC(TBL,ACT,RES,LETREQ,COMREQ,NCD) B1500013^^ C WHERE THE PARAMETERS HAVE THE FOLLOWING DEFINITIONS: B1500014^^ C TBL - THE ACTIVITY VERIFICATION TABLE CONSTRUCTED BY THE CONMATB1500015^^ C ROUTINE. TBL IS A 5 X 32 ARRAY WHERE THE RECORDS HAVE THE B1500016^^ C FOLLOWING FORMATS.: B1500017^^ C RECORD 1 - LIST OF UP TO 32 ACTION CODES UTILIZED. FRO LESS B1500018^^ C THAN 32 CODES, THE LIST IS TERMINATED BY '**'. B1500019^^ C RECORD 2 - SAME AS RECORD 1 EXCEPT FOR RESULT CODES UTILIZEDB1500020^^ C RECORD 3 - BIT MASK WHERE THE NTH ENTRY INDICATES WHICH RESUB1500021^^ C CODES (EACH RESULT CODE IS REPRESENTED BY ONE BIT) OF THE B1500022^^ C FIRST 16 RESULT CODES IN RECORD 2 ARE VALID WITH THE NTH B1500023^^ C ACTION CODE. B1500024^^ C RECORD 4 - SAME AS RECORD 3, EXCEPT FOR THE SECOND 16 RESULTB1500025^^ C CODES. B1500026^^ C RECORD 5 - NTH ENTRY HAS THE FOLLOWING MEANING: B1500027^^ C BIT 15 - LETTER REQUIREMENT FOR NTH ACTION CODB1500028^^ C BIT 14 - COMMENT REQUIREMENT FOR NTH ACITON COB1500029^^ C BITS 8-13 - NEXT CONTACT DATE IN DAYS FOR NTH B1500030^^ C ACTION CODE. B1500031^^ C BIT 7 - LETTER REQUIREMENT FOR NTH RESULT CODB1500032^^ C BIT 6 - COMMENT REQUIREMENT FOR NTH RESULT COB1500033^^ C BITS 0-5 - NEXT CONTACT DATE IN DAYS FOR NTH B1500034^^ C RESULT CODE. B1500035^^ C FOR LETTER AND COMMENT REQUIREMENTS, NON-ZERO IM-B1500036^^ C PLIES REQUIRED, ZERO IMPLIES OPTIONAL. B1500037^^ C ACT - ACTION CODE TO BE VERIFIED. B1500038^^ C RES - RESULT CODE TO BE VERIFIED. B1500039^^ C LETREQ - LETTER REQUIREMENTS FOR RETURN. NON-ZERO MEANS REQUIRED. B1500040^^ C COMREQ - COMMENT REQUIREMENTS FOR RETURN. NON-ZERO MEANS REQUIRED.B1500041^^ C NCD - NEXT CONTACT DATE IN DAYS RETURNED FOR THIS ACTION/RESULTB1500042^^ C CODE PAIR IF VALID. IF INVALID, NCD IS RETURNED LESS THANB1500043^^ C ZERO. B1500044^^ C B1500045^^ 2 INTEGER TBL(1),ACT,RES,LETREQ,COMREQ,NCD,BITTBL(16),FLAG B1500046^ ^ 3 DATA BITTBL/$8000,$4000,$2000,$1000,$800,$400,$200,$100,$80,$40, B1500048^^ 3 1 $20,$10,8,4,2,1/ B1500049^t FTN 3.3B (OPT = LPC) AVMVAC PAGE 2 DATE: 08/29/84 TIME: 2122 t^ C B1500051^^ C CHECK FOR VALID ACTION CODE. B1500052^^ 4 J = ACT B1500053^^ 5 CALL AVMCKV(TBL(1),J) B1500054^^ 6 IF(J.LT.0) GO TO 400 B1500055^^ 7 J = J+1 B1500056^^ C ACTION CODE VALID. CHECK FOR VALID RESULT CODE. B1500057^^ 8 K = RES B1500058^^ 9 CALL AVMCKV(TBL(33),K) B1500059^^ 10 IF(K.LT.0) GO TO 450 B1500060^^ 11 K = K+1 B1500061^^ 12 I = AND(K-1,$F) + 1 B1500062^ ^ C BOTH CODES VALID. DETERMINE WHICH BIT MASK TO VALIDATE ACTION/RESUB1500064^^ C CODE PAIR. B1500065^^ 13 FLAG = 64 + J B1500066^^ 14 IF(K.GT.16) FLAG = 96 + J B1500067^^ C VALIDATE RESULT CODE WITH THIS ACTION CODE. B1500068^^ 15 IF(AND(BITTBL(I),TBL(FLAG)).EQ.0) GO TO 450 B1500069^ ^ C VALID ACTION/RESULT CODE PAIR. DETERMINE DEFAULT NEXT CONTACT DATEB1500071^^ 16 NCD = AND(TBL(J+128),$3F00)/$100 B1500072^^ 17 I = AND(TBL(K+128),$3F) B1500073^^ 18 IF(NCD.GT.I) NCD=I B1500074^ ^ C DETERMINE LETTER AND COMMENT REQUIREMENTS. B1500076^^ 19 LETREQ = AND(TBL(J+128),$8000) + AND(TBL(K+128),$80) B1500077^^ 20 COMREQ = AND(TBL(J+128),$4000) + AND(TBL(K+128),$40) B1500078^ ^ C ACTIVITY CODES VERIFIED AS VALID - RETURN. B1500080^^ 21 GO TO 500 B1500081^t FTN 3.3B (OPT = LPC) AVMVAC PAGE 3 DATE: 08/29/84 TIME: 2122 t^ C B1500083^^ C ERROR - INVLAID CODE OR COMBINATION. B1500084^^ C B1500085^^ C INVALID ACTION CODE. B1500086^^ 22 400 NCD = -1 B1500087^^ 23 GO TO 500 B1500088^ ^ C INVALID RESULT CODE OR ACTION CODE/RESULT CODE COMBINATION. B1500090^^ 24 450 NCD = -2 B1500091^ ^ C RETURN EXIT. B1500093^^ 25 500 RETURN B1500094^^ 26 END B1500095^t FTN 3.3B (OPT = LPC) AVMVAC PAGE 4 DATE: 08/29/84 TIME: 2122 t  PROGRAM LENGTH $0097 ( 151)   EXTERNALS  Q8PKUP Q8PREP AVMCKV  t FTN 3.3B (OPT = LPC) AVMVAC PAGE 5 DATE: 08/29/84 TIME: 2122 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " 8000 (-32767) 0018 19 "" 000F (15) 0014 12 "" 003F (63) 0017 17 "$ 0040 (64) 0015 13,20$$ 0080 (128) 0019 19,20$" 3F00 (16128) 0016 16 "" 4000 (16384) 001A 20 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < $ ACT INTEGER 7FFF 1,2,4$0 AND INTR.FN. 7FFF 12,15,16,17,19,200& BITTBL INTEGER 0000 2,3,15 && COMREQ INTEGER 7FFF 1,2,20 &* FLAG INTEGER 0010 2,13,14,15 *. I INTEGER 0013 11,12,15,17,18 .8 J INTEGER 0011 3,4,5,6,7,13,14,16,19,20 8: K INTEGER 0012 7,8,9,10,11,12,14,17,19,20 :& LETREQ INTEGER 7FFF 1,2,19 &. NCD INTEGER 7FFF 1,2,16,18,22,24.$ RES INTEGER 7FFF 1,2,8$6 TBL INTEGER 7FFF 1,2,5,9,15,16,17,19,20 6   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " AVMCKV SUBROUTINE 001E 4,9" Q8PKUP INTEGER.FN. 0080 Q8PREP INTEGER.FN. 007D t FTN 3.3B (OPT = LPC) AVMVAC PAGE 6 DATE: 08/29/84 TIME: 2122 t   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 400 006E 6,22 $( 450 0071 10,15,24 (( 500 0073 20,23,25 ( AVMVAC 0078 1 t FTN 3.3B (OPT = LPC) BINASC PAGE 1 DATE: 08/29/84 TIME: 2123 t^ 1 SUBROUTINE BINASC(I,A) B1600001^^ 1 1 /B16 F CCS CCS 3.0 SL-149B1600002^^ C B1600003^^ C CYBERCREDIT SYSTEM VERSION 3 B1600004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B1600005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B1600006^^ C B1600007^^ C B1600008^^ C COPYRIGHT CONTROL DATA CORPORATION, 1978 B1600009^^ C DATA SYSTEMS . LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B1600010^^ C CREDIT COLLECTION SYSTEM VERSION 2.0 B1600011^^ C B1600012^^ C CONVERTS 1 WORD INTEGER TO ASCII 2 WORD DECIMAL (NO DECIMAL) B1600013^^ 2 INTEGER A(2) B1600014^^ 3 J=I B1600015^^ 4 J0=J-(J/10)*10 B1600016^^ 5 J=J/10 B1600017^^ 6 J1=J-(J/10)*10 B1600018^^ 7 J=J/10 B1600019^^ 8 J2=J-(J/10)*10 B1600020^^ 9 J=J/10 B1600021^^ 10 J3=J-(J/10)*10 B1600022^^ 11 A(1)=(J3+$30)*$100+ (J2+$30) B1600023^^ 12 A(2)=(J1+$30)*$100+ (J0+$30) B1600024^^ 13 RETURN B1600025^^ 14 END B1600026^t FTN 3.3B (OPT = LPC) BINASC PAGE 2 DATE: 08/29/84 TIME: 2123 t  PROGRAM LENGTH $0055 ( 85)   EXTERNALS  Q8PKUP Q8PREP  t FTN 3.3B (OPT = LPC) BINASC PAGE 3 DATE: 08/29/84 TIME: 2123 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < 0 000A (10) 0002 4,4,5,6,7,8,9,10 0   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < ( A INTEGER 7FFF 1,2,11,12(" I INTEGER 7FFF 1,3"2 J INTEGER 0000 2,3,4,5,6,7,8,9,10 2& J0 INTEGER 0001 3,4,12 && J1 INTEGER 0003 5,6,12 && J2 INTEGER 0004 7,8,11 && J3 INTEGER 0005 9,10,11&   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  Q8PKUP INTEGER.FN. 004D Q8PREP INTEGER.FN. 004A    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : <  BINASC 0047 1  t FTN 3.3B (OPT = LPC) BLDSRN PAGE 1 DATE: 08/29/84 TIME: 2123 t^ 1 PROGRAM BLDSRN B1700001^^ 1 1 /B17 F CCS CCS 3.0 SL-149B1700002^^ C B1700003^^ C CYBERCREDIT SYSTEM VERSION 3 B1700004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B1700005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B1700006^^ C B1700007^^ C B1700008^^ C GENERATE SCREEN FILE FOR DISPLAY. B1700009^^ C B1700010^^ C GENERATES A SCREEN FILE FROM 80 COLUMN INPUT RECORDS. INPUT IS FROB1700011^^ C THE FILE 'SCRNDESC'. THIS FILE IS LOADED ONTO THE SYSTEM VIA A PROB1700012^^ C CEDURE STREAM, MODIFIED WITH THE EDITIOR, USED FOR INPUT TO THIS B1700013^^ C PROGRAM, AND FINALLY SAVED ON TAPE. EACH RECORD IN THE SCREEN FILEB1700014^^ C 'SCRNFILE' CONTAINS A SCREEN DEFINITION WITH ENOUGH INFORMATION TOB1700015^^ C TO CONSTRUCT A SCREEN. THE FORMAT FOR THE INPUT RECORDS FROM B1700016^^ C 'SCRNDESC' IS: B1700017^^ C COLS DESCRIPTION B1700018^^ C FIRST CARD 1 - 2 SCREEN NUMBER. B1700019^^ C 3 - 80 COMMENTS. B1700020^^ C NEXT N RECS 1 - 2 LINE NUMBER FOR ITEM (01-24) B1700021^^ C 3 - 4 COLUMN NUMBER FOR ITEM (01-80). B1700022^^ C 5 - 6 LENGTH OF FIELD IN BYTES. B1700023^^ C 7 - 10 STARTING POSITION IN FILE IF B1700024^^ C APPLICABLE. B1700025^^ C 11 FIELD TYPE FOR EDITING (SEE BELOWB1700026^^ C 12 - 80 CONSTANT SCREEN FIELD. B1700027^^ C 41 - 80 COMMENTS IF NOT CONSTANT FIELD. B1700028^^ C LAST RECORD 1 - 3 CONSTANT 'END'. B1700029^^ C 4 - 80 COMMENTS. B1700030^^ C THE LAST RECORD TO TERMINATE THE SCREEN FILE BUILD IS AN 'END' B1700031^^ C RECORD WITH THE 'END' STARTING IN COLUMN ONE. B1700032^^ C B1700033^^ C FIELD TYPES USED ARE: B1700034^^ C 0 = CONSTANT SCREEN FIELD. B1700035^^ C 1 = DATE IN FORM MM/DD/YY. B1700036^^ C 2 = ALPHA/NUMERIC IN FILE. B1700037^^ C 3 = NINE DIGIT DOLLAR AMOUNT IN FORM 9999999.99 . B1700038^^ C 4 = TEN DIGIT PHONE NUMBER IN FORM 999/999-9999 . B1700039^^ C 5 = RESTRICTED USAGE TO REPORT COLLECTION ACTIVITY. B1700040^^ C 6 = SOCIAL SECURITY NUMBER IN FORM 999-99-9999 . B1700041^^ C 7 = TIME OF DAY IN 24 HOUR TIME, HHMM . B1700042^^ C 8 = CONSTANT SCREEN FIELD LABELLING CHANGE SCREEN ITEM. B1700043^^ C 9 = MOST RECENT COLLECTION ACTIVITY. B1700044^^ C B1700045^^ C DESCRIPTION OF THE OUTPUT SCREEN DEFINITION RECORD GIVEN IN THE B1700046^^ C DISPLY SUBROUTINE. B1700047^ ^ 2 INTEGER X,Y,TEMP(8),INBUF(42),OBUF(902),NXTWRD,FLDTYP, B1700049^^ 2 1 LENGTH,KEY,FILPOS(2),FLAG,ENDMSG(15),ZERO,CSF(1) B1700050^^ 3 INTEGER SCRSIZ,ERRMSG(26) B1700051^^ 4 DATA SCRSIZ / 900 / B1700052^^ 5 DATA ERRMSG / ' ***** SCREEN EXCEEDS MAXIMUM ALLOWABLE SIZE *', B1700053^^ 5 1 '****' / B1700054^t FTN 3.3B (OPT = LPC) BLDSRN PAGE 2 DATE: 08/29/84 TIME: 2123 t^ 6 INTEGER REQBF1(24),REQBF2(24),IDATA1(15),IDATA2(15) B1700055^^ 7 INTEGER END,LP,ONE,SIX,TWO B1700056^^ 8 INTEGER EIGHT,ENDLEN,OBFLEN,TC,XYN B1700057^^ 9 INTEGER TOF,LF,TITLE1(13),TITLE2(5),POSTI1 B1700058^^ 10 INTEGER POSTI2,LENTI1,LENTI2,STDHDR(60),DATE(3),DATPOS,HDRONE B1700059^^ 11 INTEGER HDRTWO,HDRLEN,FOUR,ASCTEN B1700060^ ^ 12 EQUIVALENCE (INBUF(1),KEY),(INBUF(1),Y),(INBUF(2),X), B1700062^^ 12 1 (INBUF(3),LENGTH),(INBUF(4),FILPOS(1)),(INBUF(6),CSF(1)) B1700063^ ^ 13 DATA REQBF1/24*0/,REQBF2/24*0/,IDATA1/'SCRNFILE',8*$2020,0,1,-1/, B1700065^^ 13 1 IDATA2/'SCRNDESC',8*$2020,0,1,-1/,OBUF/902*$2020/ B1700066^^ 14 DATA END/'EN'/,TWO/2/,LP/9/,ONE/1/,INPLEN/80/,FLAG/0/,ZERO/0/ B1700067^^ 15 DATA ENDLEN/30/,OBFLEN/1804/,XYN/-1/ B1700068^^ 16 DATA ENDMSG/$D0A,'SCREEN FILE BUILD COMPLETE '/ B1700069^^ 17 DATA TOF/$C00/,LF/$D20/,HDRLEN/40/ B1700070^^ 18 DATA TITLE1/'SCREEN FILE BUILD SCRNFILE'/,TITLE2/'RUN DATE '/ B1700071^^ 19 DATA POSTI1/45/,POSTI2/47/,LENTI1/26/,LENTI2/9/,DATPOS/57/ B1700072^^ 20 DATA HDRONE/1/,HDRTWO/41/,ASCTEN/$30/ B1700073^    ^ C B1700075^^ C PROGRAM LOGIN. MASTER CONSOLE USAGE ONLY ALLOWED. B1700076^^ C B1700077^^ 21 CALL PGMIN(TEMP,LU,I,J) B1700078^^ C EXIT IF NOT MASTER CONSOLE. B1700079^^ 22 IF(J.NE.0) GO TO 950 B1700080^ ^ C CLEAR SCREEN DECRIPTION FILE. B1700082^^ 23 CALL CLEAR(REQBF1,IDATA1,ISTAT) B1700083^^ C CHECK IF FILE OPEN OR OTHER ERROR. B1700084^^ 24 IF(ISTAT.LT.0) GO TO 810 B1700085^^ C NO ERRORS, OPEN BOTH FILES. LOCK FILE UPON ACCESS. B1700086^^ C ZERO OUT REQBF1 FIRST. B1700087^^ 25 DO 50 I=1,24 B1700088^^ 26 50 REQBF1(I) = 0 B1700089^^ 27 CALL OPENFL(REQBF1,IDATA1,ISTAT) B1700090^^ C CHECK FOR ERROR. B1700091^^ 28 IF(ISTAT.LT.0) GO TO 820 B1700092^^ C NO ERROR. B1700093^^ 29 CALL OPENFL(REQBF2,IDATA2,ISTAT) B1700094^^ C CHECK FOR ERROR. B1700095^^ 30 IF(ISTAT.LT.0) GO TO 830 B1700096^^ C NO ERRORS. RETRIEVE STANDARD HEADERS FOR OUTPUT. B1700097^^ 31 CALL UTHEAD(STDHDR,DATE) B1700098^^ C START SCREEN FILE CONSTRUCTION. B1700099^t FTN 3.3B (OPT = LPC) BLDSRN PAGE 3 DATE: 08/29/84 TIME: 2123 t^ C B1700101^^ C OUTPUT HEADER INFORMATION ON FRESH PAGE. B1700102^^ C B1700103^^ C SET TOP OF FORM. B1700104^^ 32 100 INBUF(1) = TOF B1700105^^ C MOVE IN FIRST LINE OF STANDARD HEADER BLANKING REMAINING BUFFER. B1700106^^ 33 CALL CCSMVA(STDHDR,HDRONE,HDRLEN,INBUF,TWO,INPLEN) B1700107^^ C MOVE IN FIRST LINE OF TITLE. B1700108^^ 34 CALL CCSMVA(TITLE1,ONE,LENTI1,INBUF,POSTI1,LENTI1) B1700109^^ C WRITE FIRST LINE. B1700110^^ 35 ASSIGN 110 TO ICOMPL B1700111^^ 36 CALL FWRITE(LP,INBUF,INPLEN,ICOMPL,FLAG,TEMP) B1700112^^ 37 CALL DISP B1700113^ ^ C MOVE IN SECOND LINE OF STANDARD HEADER BLANKING REMAINING BUFFER. B1700115^^ 38 110 CALL CCSMVA(STDHDR,HDRTWO,HDRLEN,INBUF,ONE,INPLEN) B1700116^^ C MOVE IN SECOND LINE OF TITLE. B1700117^^ 39 CALL CCSMVA(TITLE2,ONE,LENTI2,INBUF,POSTI2,LENTI2) B1700118^^ C MOVE IN RUN DATE. B1700119^^ 40 CALL EDIT(DATE,ONE,INBUF,DATPOS,ONE) B1700120^^ C WRITE SECOND LINE. B1700121^^ 41 ASSIGN 120 TO ICOMPL B1700122^^ 42 CALL FWRITE(LP,INBUF,INPLEN,ICOMPL,FLAG,TEMP) B1700123^^ 43 CALL DISP B1700124^ ^ C WRITE THIRD LINE OF STANDARD HEADER WITH LINE FEED AT END. B1700126^^ 44 120 STDHDR(60) = LF B1700127^^ 45 ASSIGN 130 TO ICOMPL B1700128^^ 46 CALL FWRITE(LP,STDHDR(41),HDRLEN,ICOMPL,FLAG,TEMP) B1700129^^ 47 CALL DISP B1700130^  ^ C B1700132^^ C RETRIEVE DESIRED SCREEN DEFINITION. B1700133^^ C B1700134^^ 48 130 CALL GETS(REQBF2,INBUF,TEMP,ISTAT) B1700135^^ C CHECK FOR ERROR. B1700136^^ 49 IF(ISTAT.LT.0) GO TO 840 B1700137^^ C CHECK FOR END OF SCREENS - TERMINATE IF YES. B1700138^^ 50 IF(KEY.EQ.END) GO TO 900 B1700139^ ^ C START NEW SCREEN. SET KEY INTO FIRST TWO BYTES OF OUTPUT RECORD. B1700141^^ 51 OBUF(1) = ICCSAD(KEY) B1700142^^ C OUTPUT SCREEN NUMBER AND TITLE. B1700143^^ 52 ASSIGN 150 TO ICOMPL B1700144^^ 53 CALL FWRITE(LP,INBUF,INPLEN,ICOMPL,FLAG,TEMP) B1700145^^ 54 CALL DISP B1700146^^ 55 150 NXTWRD = 2 B1700147^ ^ C READ SCREEN DEFINITIONS. B1700149^^ 56 200 CALL GETS(REQBF2,INBUF,TEMP,ISTAT) B1700150^^ C CHECK FOR ERROR. B1700151^^ 57 IF(ISTAT.LT.0) GO TO 840 B1700152^^ C LIST SCREEN DESCRIPTION RECORD INPUT. B1700153^t FTN 3.3B (OPT = LPC) BLDSRN PAGE 4 DATE: 08/29/84 TIME: 2123 t^ 58 ASSIGN 205 TO ICOMPL B1700154^^ 59 CALL FWRITE(LP,INBUF,INPLEN,ICOMPL,FLAG,TEMP) B1700155^^ 60 CALL DISP B1700156^^ C CHECK FOR END OF SCREEN DEFINITION. B1700157^^ 61 205 IF(Y.EQ.END) GO TO 300 B1700158^ ^ C CONSTRUCT SCREEN DEFINITION FROM INPUT. CONSTRUCT FIRST WORD, X-Y B1700160^^ C POSITIONING. SAVE INDEX FOR SECOND WORD. B1700161^^ 62 206 ISAVE = NXTWRD + 1 B1700162^^ 63 OBUF(NXTWRD) = (ICCSAD(X)-1)*$100 + ICCSAD(Y)-1 B1700163^ ^ C SET SECOND WORD, THE LOCATION OF THE NEXT FIELD DESCRIPTION. B1700165^^ C CONVERT FIELD TYPE AND LENGTH TO NUMBERS. B1700166^^ 64 FLDTYP = AND(INBUF(6)/$100,$F) B1700167^^ 65 LENGTH = ICCSAD(LENGTH) B1700168^^ C CHECK IF FIELD TYPE = 0 OR 8, CONSTANT SCREEN FIELD. B1700169^^ 66 IF(FLDTYP.EQ.0.OR.FLDTYP.EQ.8) GO TO 210 B1700170^^ 67 OBUF(NXTWRD+1) = NXTWRD + 5 B1700171^^ 68 IF((NXTWRD+5).GT.SCRSIZ) GO TO 280 B1700172^^ 69 GO TO 220 B1700173^^ C CONSTANT SCREEN FIELD. START OF NEXT FIELD DESCRIPTION MUST INCLUDB1700174^^ C ANY CHARACTERS SAVED. B1700175^^ 70 210 OBUF(NXTWRD+1) = NXTWRD + 5 + (LENGTH+1)/2 B1700176^^ 71 IF(OBUF(NXTWRD+1).GT.SCRSIZ) GO TO 280 B1700177^ ^ C GET THIRD WORD, LENGTH OF SCREEN ITEM. B1700179^^ 72 220 OBUF(NXTWRD+2) = LENGTH B1700180^ ^ C GET FOURTH AND FIFTH WORDS, FILE POSITION AND FIELD TYPE. B1700182^^ 73 IF(FLDTYP.EQ.0.OR.FLDTYP.EQ.8) GO TO 250 B1700183^^ 74 OBUF(NXTWRD+3) = ICCSAD(FILPOS(1))*100 + ICCSAD(FILPOS(2)) B1700184^^ 75 OBUF(NXTWRD+4) = FLDTYP B1700185^^ 76 GO TO 260 B1700186^ ^ C CONSTANT SCREEN FIELD - SET STARTING POSITION IN FILE FIELD TO ONEB1700188^^ C AND SAVE THE FIELD TYPE AND CONSTANT SCREEN FIELD. B1700189^^ 77 250 OBUF(NXTWRD+3) = 1 B1700190^^ 78 OBUF(NXTWRD+4) = FLDTYP B1700191^^ C SET STARTING BYTE INTO OBUF WHERE FIELD IS TO BE MOVED. B1700192^^ 79 J = (NXTWRD + 5) * 2 - 1 B1700193^^ 80 K=((LENGTH+1)/2) + (NXTWRD+5) B1700194^^ 81 IF(K.GE.SCRSIZ) GO TO 280 B1700195^^ 82 CALL CCSMVA(CSF,TWO,LENGTH,OBUF,J,LENGTH) B1700196^^ 83 260 NXTWRD = OBUF(NXTWRD+1) B1700197^^ 84 IF(NXTWRD.GE.SCRSIZ) GO TO 280 B1700198^^ 85 GO TO 200 B1700199^ ^ C SCRNFILE BUFFER WAS EXCEEDED - PRINT MESSAGE B1700201^^ C CONTINUE TO CHECK NEXT SCREENS B1700202^^ 86 280 NXTWRD=2 B1700203^^ 87 ASSIGN 290 TO ICOMPL B1700204^^ 88 CALL FWRITE(LP,ERRMSG,52,ICOMPL,FLAG,TEMP) B1700205^^ 89 CALL DISP B1700206^^ 90 290 ASSIGN 206 TO ICOMPL B1700207^t FTN 3.3B (OPT = LPC) BLDSRN PAGE 5 DATE: 08/29/84 TIME: 2123 t^ 91 CALL FWRITE(LU,ERRMSG,52,ICOMPL,FLAG,TEMP) B1700208^^ 92 CALL DISP B1700209^  ^ C SCREEN COMPLETE. TERMINATE SCREEN DESCRIPTION AND SAVE RECORD. B1700211^^ C B1700212^^ 93 300 OBUF(ISAVE) = 0 B1700213^^ 94 CALL WRITER(REQBF1,OBUF,OBUF(1),ISTAT) B1700214^^ C CHECK FOR ERROR. B1700215^^ 95 IF(ISTAT.LT.0) GO TO 850 B1700216^^ C NO ERROR, BLANK OUTPUT BUFFER AND PROCESS NEXT SCREEN. B1700217^^ 96 CALL CCSBLK(OBUF,OBFLEN) B1700218^^ 97 GO TO 100 B1700219^t FTN 3.3B (OPT = LPC) BLDSRN PAGE 6 DATE: 08/29/84 TIME: 2123 t^ C B1700221^^ C FILE ERRORS. B1700222^^ C B1700223^^ C CLEAR REQUEST, SCRNFILE. B1700224^^ 98 810 I = 1 B1700225^^ 99 GO TO 825 B1700226^^ C OPEN REQUEST, SCRNFILE. B1700227^^ 100 820 I = 3 B1700228^^ 101 825 CALL FILERR(IDATA1,I,ISTAT,LU) B1700229^^ 102 GO TO 910 B1700230^^ C OPEN REQUEST, SCRNDESC. B1700231^^ 103 830 I = 3 B1700232^^ 104 GO TO 845 B1700233^^ C GETS REQUEST, SCRNDESC. B1700234^^ 105 840 I = 14 B1700235^^ 106 845 CALL FILERR(IDATA2,I,ISTAT,LU) B1700236^^ 107 GO TO 910 B1700237^^ C WRITER REQUEST, SCRNFILE. B1700238^^ 108 850 I = 12 B1700239^^ 109 GO TO 825 B1700240^ ^ C NORMAL TERMINATION. OUTPUT BUILD COMPLETE MESSAGE. B1700242^^ 110 900 ASSIGN 905 TO ICOMPL B1700243^^ 111 CALL FWRITE(LP,ENDMSG,ENDLEN,ICOMPL,FLAG,TEMP) B1700244^^ 112 CALL DISP B1700245^^ 113 905 CALL WTREAD(LU,XYN,ENDMSG,ENDLEN,ZERO,ZERO,ZERO,TC) B1700246^ ^ C FORCE FILE CLOSURES. IGNORE ANY ERRORS. B1700248^^ 114 910 CALL CLOSFL(REQBF1,ISTAT) B1700249^^ 115 CALL CLOSFL(REQBF2,ISTAT) B1700250^^ C EXIT. B1700251^^ 116 950 CALL PGMOUT B1700252^^ 117 END B1700253^t FTN 3.3B (OPT = LPC) BLDSRN PAGE 7 DATE: 08/29/84 TIME: 2123 t  PROGRAM LENGTH $065D ( 1629)   EXTERNALS 2 Q8STP PGMIN CLEAR OPENFL UTHEAD CCSMVA FWRITE 22 DISP EDIT GETS ICCSAD WRITER CCSBLK FILERR 2 WTREAD CLOSFL PGMOUT  t FTN 3.3B (OPT = LPC) BLDSRN PAGE 8 DATE: 08/29/84 TIME: 2123 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " 000F (15) 04A1 64 "$ 0034 (52) 04A4 88,91$$ 0064 (100) 04A2 74,97$   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " AND INTR.FN. 7FFF 64 "$ ASCTEN INTEGER 0499 5,20 $& CSF INTEGER 0007 1,12,82&& DATE INTEGER 0492 5,31,40&& DATPOS INTEGER 0495 5,19,40&* END INTEGER 0436 5,14,50,61 *, ENDLEN INTEGER 043A 5,15,111,113 ,, ENDMSG INTEGER 03BD 1,16,111,113 ,( ERRMSG INTEGER 03CE 2,5,88,91(& FILPOS INTEGER 0005 1,12,74&< FLAG INTEGER 03BC 1,14,36,42,46,53,59,88,91,111<0 FLDTYP INTEGER 03BB 1,64,66,73,75,78 0, HDRLEN INTEGER 0498 5,17,33,38,46,& HDRONE INTEGER 0496 5,20,33&& HDRTWO INTEGER 0497 5,20,38&B I INTEGER 049C 21,25,26,98,100,101,103,105,106,108BP ICOMPL INTEGER 049F 34,36,41,42,45,46,52,53,58,59,87,88,90,91,110,111P. IDATA1 INTEGER 0418 5,13,23,27,101 .* IDATA2 INTEGER 0427 5,13,29,106*J INBUF INTEGER 0002 1,12,32,33,34,36,38,39,40,42,48,53,56,59,64J4 INPLEN INTEGER 049A 14,33,36,38,42,53,59 4( ISAVE INTEGER 04A0 61,62,93 (R ISTAT INTEGER 049E 23,24,27,28,29,30,48,49,56,57,94,95,101,106,114,115R* J INTEGER 049D 21,22,79,82*( K INTEGER 04A3 79,80,81 (* KEY INTEGER 0002 1,12,50,51 *2 LENGTH INTEGER 0004 1,12,65,70,72,80,822& LENTI1 INTEGER 0454 5,19,34&& LENTI2 INTEGER 0455 5,19,39&& LF INTEGER 043F 5,17,44&: LP INTEGER 0437 5,14,36,42,46,53,59,88,111 :0 LU INTEGER 049B 21,91,101,106,1130T NXTWRD INTEGER 03BA 1,55,62,63,67,68,70,71,72,74,75,77,78,79,80,83,84,86 T& OBFLEN INTEGER 043B 5,15,96&P OBUF INTEGER 0034 1,13,51,63,67,70,71,72,74,75,77,78,82,83,93,94,96P0 ONE INTEGER 0438 5,14,34,38,39,40 0t FTN 3.3B (OPT = LPC) BLDSRN PAGE 9 DATE: 08/29/84 TIME: 2123 t& POSTI1 INTEGER 0452 5,19,34&& POSTI2 INTEGER 0453 5,19,39&4 REQBF1 INTEGER 03E8 5,13,23,26,27,94,114 40 REQBF2 INTEGER 0400 5,13,29,48,56,1150. SCRSIZ INTEGER 03CD 2,4,68,71,81,84.0 STDHDR INTEGER 0456 5,31,33,38,44,46 0$ TC INTEGER 043C 5,113$B TEMP INTEGER 002C 1,21,36,42,46,48,53,56,59,88,91,111B& TITLE1 INTEGER 0440 5,18,34&& TITLE2 INTEGER 044D 5,18,39&& TOF INTEGER 043E 5,17,32&* TWO INTEGER 0439 5,14,33,82 *& X INTEGER 0003 1,12,63&( XYN INTEGER 043D 5,15,113 (* Y INTEGER 0002 1,12,61,63 *( ZERO INTEGER 03CC 1,14,113 (   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " CCSBLK SUBROUTINE 061D 95 ". CCSMVA SUBROUTINE 05E1 32,34,38,39,82 ." CLEAR SUBROUTINE 04B1 22 "& CLOSFL SUBROUTINE 0653 114,115&8 DISP SUBROUTINE 0600 36,43,47,54,60,89,92,112 8" EDIT SUBROUTINE 050B 39 "& FILERR SUBROUTINE 0629 101,106&8 FWRITE SUBROUTINE 05F8 34,42,46,53,59,88,91,111 8$ GETS SUBROUTINE 052D 48,56$* ICCSAD INTEGER.FN. 05B8 51,63,65,74*$ OPENFL SUBROUTINE 04C6 26,29$" PGMIN SUBROUTINE 04A6 20 "" PGMOUT SUBROUTINE 065A 116" Q8STP INTEGER.FN. 065C " UTHEAD SUBROUTINE 04D9 30 "" WRITER SUBROUTINE 0612 93 "" WTREAD SUBROUTINE 0649 113"   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 50 04BC 24,26$$ 100 04DC 31,97$$ 110 04FC 34,38$$ 120 051C 40,44$$ 130 052C 44,48$$ 150 054F 51,55$$ 200 0552 55,85$t FTN 3.3B (OPT = LPC) BLDSRN PAGE 10 DATE: 08/29/84 TIME: 2123 t$ 205 0567 57,61$$ 206 056E 61,90$$ 210 059F 66,70$$ 220 05AB 68,72$$ 250 05C7 73,77$$ 260 05E8 75,83$. 280 05F1 68,71,81,84,86 .$ 290 0601 86,90$$ 300 060C 61,93$$ 810 0622 24,98$& 820 0626 28,100 &* 825 0628 98,101,109 *& 830 062F 30,103 &( 840 0632 49,57,105(& 845 0634 103,106&& 850 063A 95,108 && 900 063D 50,110 && 905 0648 110,113&* 910 0652 101,107,114*& 950 0659 22,116 & BLDSRN 0000 1 t FTN 3.3B (OPT = LPC) BLKDT1 PAGE 1 DATE: 08/29/84 TIME: 2124 t^ 1 SUBROUTINE BLKDT1 ( IN , IC ) B1900001^^ 1 1 /B19 F CCS CCS 3.0 SL-149B1900002^^ C B1900003^^ C CYBERCREDIT SYSTEM VERSION 3 B1900004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B1900005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B1900006^^ C B1900007^^ 2 INTEGER IN(1) B1900008^^ 3 DO 10 I = 1, IC B1900009^^ 4 10 IN(I) = $2020 B1900010^^ 5 RETURN B1900011^^ 6 END B1900012^t FTN 3.3B (OPT = LPC) BLKDT1 PAGE 2 DATE: 08/29/84 TIME: 2124 t  PROGRAM LENGTH $001E ( 30)   EXTERNALS  Q8PKUP Q8PREP  t FTN 3.3B (OPT = LPC) BLKDT1 PAGE 3 DATE: 08/29/84 TIME: 2124 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : <  2020 (8224) 0001 4    VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " I INTEGER 0000 2,4"" IC INTEGER 7FFF 1,3"$ IN INTEGER 7FFF 1,2,4$   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  Q8PKUP INTEGER.FN. 0017 Q8PREP INTEGER.FN. 0014    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < " 10 0007 2,4" BLKDT1 0011 1  t FTN 3.3B (OPT = LPC) CCSDMP PAGE 1 DATE: 08/29/84 TIME: 2124 t^ 1 PROGRAM CCSDMP B2000001^^ 1 1 /B20 F CCS CCS 3.0 2 WORD RRN - PSRD SL-149********^^ C B2000003^^ C CYBERCREDIT SYSTEM VERSION 3 B2000004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B2000005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B2000006^^ C B2000007^^ C PROGRAM DUMPS SPECIFIC RECORDS FROM FM2.0 FILES, EITHER BY RECORD B2000008^^ C NUMBER OR KEY. ALSO DUMPS TAPE FILES. B2000009^^ 2 INTEGER BUFFER(2000), REQBUF(24), VOLNAM(4), FCBBFR(96) B2000010^^ 3 INTEGER INBF(30), EXACT, Y, RECSPC(16), LEXT(3), LIT3(3), B2000011^^ 3 * IDUSER(4), IDATA(15), LIT1(2), LIT2(2), SEQ(2), INDX(2), B2000012^^ 3 * OVER(2), KEY(16), KEYSTP(16) , TAPE0(3) B2000013^^ 4 INTEGER ISTR(2),ISTP(2) ********^^ 5 REAL RSTR ,RSTP ********^^ 6 DATA Y/$5900/, LEXT/'EXACT '/, LU/12/, SEQ/'SEQ '/, INDX/'INDX'/ B2000015^^ 7 DATA OVER/'OVER'/ B2000016^^ 8 DATA IDATA/15*$2020/, VOLNAM/4*0/, REQBUF/24*0/ B2000017^^ 9 DATA TAPE0/'TAPE0 '/ B2000018^  ^ 10 CALL PGMIN ( IDUSER, LUNIT, MDE, NOPRT) B2000022^^ 11 IF (NOPRT.NE.0) LU = 05 ********^^ 12 WRITE (LUNIT, 9000) B2000023^^ 13 9000 FORMAT ( 'GENERAL DUMP PGM IN ') B2000024^^ 14 100 WRITE (LUNIT, 9001) B2000025^^ 15 9001 FORMAT ( ' ENTER FILE NAME(CR) TO BE DUMPED, (CR) TO TERMINATE' ) B2000026^^ C*** SET UP PROGRAM INTERRUPT ********^^ 16 ASSIGN 100 TO INTRPT ********^^ 17 CALL PGMINT(INTRPT,0) ********^^ C*********** BLANK INPUT BUFFER ********^^ 18 CALL CCSMVA(INBF,1,0,INBF,1,60) ********^^ 19 CALL INPUT (LUNIT, INBF, NCH) B2000027^^ 20 IF (NCH .LE. 1) GO TO 8000 B2000028^^ C CHECK IF TAPE OR FILE DUMPING B2000029^^ 21 CALL CCSCST (INBF, 1, 5, TAPE0, 1, 5, IND) B2000030^^ 22 IF (IND .NE. 0) GO TO 120 B2000031^^ C TAPE DUMP B2000032^^ 23 IF (NOPRT.NE.0) GOTO 100 ********^^ 24 CALL TAPE ( LU, BUFFER, LUNIT) B2000033^^ 25 GO TO 100 B2000034^^ C CLOSE THE FILE (WHAT FILE) FOR GOOD LUCK B2000035^^ 26 120 CALL CLOSFL (REQBUF, MSTAT) B2000036^^ C OPEN FILE B2000037^^ C ****************************************************** ???*A027********^^ 27 CALL CCSMVA ( INBF, 1, NCH, IDATA, 1, 24 ) ********^^ C ***************************************************** ???*A027********^^ 28 IDATA(13) = 0 B2000039^^ 29 IDATA(14) = 1 B2000040^^ 30 IDATA(15) = 0 B2000041^^ 31 DO 130 I = 1, 24 B2000042^^ 32 130 REQBUF(I) = 0 B2000043^^ 33 CALL OPENFL (REQBUF, IDATA, ISTAT) B2000044^^ 34 IF (ISTAT .GE. 0) GO TO 150 B2000045^t FTN 3.3B (OPT = LPC) CCSDMP PAGE 2 DATE: 08/29/84 TIME: 2124 t^ C ERROR IN OPEN B2000046^^ 35 CALL FILERR (IDATA, 3, ISTAT, LUNIT) B2000047^^ 36 GO TO 100 B2000048^^ C GET FILE FCB TO DETERMINE RECORD LENGTH AND FILE TYPE B2000049^^ 37 150 CALL GETFCB (REQBUF, VOLNAM, INDEX, FCBBFR, JSTAT) B2000050^^ 38 IF (JSTAT .GE. 0) GO TO 200 B2000051^^ C ERROR IN GET FCB B2000052^^ 39 CALL FILERR (IDATA, 7, JSTAT, LUNIT) B2000053^^ 40 GO TO 100 B2000054^^ 41 200 LREC = FCBBFR(1) B2000055^^ 42 NRECM = FCBBFR(7) B2000056^^ 43 NRECL = FCBBFR(8) B2000057^^ 44 IDX = AND(FCBBFR(6), $0001) B2000058^^ C***** ALLOW READ OF LOCKED RECORDS ********^^ 45 REQBUF(23) = 1 ********^ ^ C LREC = NUMBER OF BYTES IN RECORD B2000059^^ C NREC = NUMBER OF RECORDS IN FILE. ********^^ C IDX = 1 IF INDEXED, 0 IF SEQUENTIAL B2000061^^ 46 CALL CCSMVA (SEQ, 1, 4, LIT1, 1, 4) B2000062^^ 47 IF (IDX .NE. 0) CALL CCSMVA (INDX, 1, 4, LIT1, 1 , 4) B2000063^^ 48 CALL CCSMVA ($2020, 1, 1, LIT2, 1, 4) B2000064^^ 49 RRN = NRECM * 32767.0 + NRECL ********^^ 50 WRITE (LUNIT, 9002) LIT1, LIT2, RRN ********^^ 51 9002 FORMAT ( 'FILE IS ', 2A2,' AND CONTAINS ',2A2,F7.0, ********^^ 51 * ' RECORDS.' ) B2000068^ ^ C FILE OPENED OKAY CONTINUE PROMPTING FOR WHAT RECORDS B2000070^^ 52 240 IF (IDX .EQ. 0) GO TO 300 ********^^ C PROMPT FOR WHICH INDEX B2000072^^ 53 250 WRITE (LUNIT, 9003) B2000073^^ 54 9003 FORMAT ( ' ENTER 0/1/2/3/4 (CR) FOR ACCESS BY RRN OR KEYS 1-4.') B2000074^^ 55 CALL INPUT (LUNIT, INBF, NCH) B2000075^^ 56 IF (NCH .EQ. 0) GO TO 100 B2000076^^ C CONVERT CHARACTER TO INTEGER B2000077^^ 57 CALL INTGR (INBF, 1, JRTYP) B2000078^^ C SAVE ACCESS TYPE IN REQUEST BUFFER B2000079^^ 58 REQBUF(14) = JRTYP B2000080^^ 59 IF (JRTYP .EQ. 0) IDX = 0 B2000081^^ 60 IF ( JRTYP.EQ.0) GO TO 300 B2000082^^ C ASK OPERATOR FOR HORSESHOES (CLOSE COUNTS) B2000083^^ 61 WRITE (LUNIT, 9004) B2000084^^ 62 9004 FORMAT ( ' ENTER Y(CR) IF AN EXACT KEY TO BE DUMPED, OTHERWISE DUMB2000085^^ 62 *P WILL USE 1ST CLOSE KEY ') B2000086^^ 63 CALL INPUT (LUNIT, INBF, NCH) B2000087^^ 64 EXACT = 0 B2000088^^ 65 IF ( AND(INBF(1), $FF00) .EQ. Y) EXACT = 1 B2000089^ ^ 66 300 WRITE (LUNIT, 9005) B2000091^^ 67 9005 FORMAT ( ' ENTER STARTING RECORD NUMBER OR KEY VALUE ') B2000092^^ 68 CALL INPUT (LUNIT, INBF, NCH) B2000093^^ 69 IF (NCH .LT. 1) GO TO 100 B2000094^^ 70 IF (IDX .EQ. 1) GO TO 350 B2000095^^ C***** CCSDMP NOW HANDLES DOUBLE PRECISION #'S FOR DUMP BY RRN. ********^t FTN 3.3B (OPT = LPC) CCSDMP PAGE 3 DATE: 08/29/84 TIME: 2124 t^ 71 IF (NCH .GT. 6) GO TO 300 ********^^ 72 CALL REALN (INBF, NCH, RSTR, ISTR(1) ) ********^^ 73 GO TO 400 B2000099^^ C KEY ENTERED - SAVE B2000100^^ 74 350 CALL CCSMVA (INBF, 1, NCH, KEY, 1, 32) B2000101^^ 75 IF ( EXACT .EQ. 1) GO TO 1000 B2000102^^ 76 400 WRITE(LUNIT, 9006) B2000103^^ 77 9006 FORMAT ( ' ENTER ENDING RECORD NUMBER OR KEY VALUE ') B2000104^^ 78 CALL INPUT ( LUNIT, INBF, NCH) B2000105^^ 79 IF ( NCH .LT. 1) GO TO 500 B2000106^^ 80 IF ( IDX .EQ. 1) GO TO 450 B2000107^^ C CONVERT RECORD NUMBER B2000108^^ 81 IF (NCH .GT. 6) GO TO 400 ********^^ 82 CALL REALN ( INBF, NCH, RSTP, ISTP(1) ) ********^^ 83 GO TO 1000 B2000111^^ 84 450 CALL CCSMVA ( INBF, 1, NCH, KEYSTP, 1, 32) B2000112^^ 85 GO TO 1000 B2000113^^ C NO STOP ENTERED, ASSUME STOP EQUALS START B2000114^^ 86 500 ISTP(1) = ISTR(1) ********^^ 87 ISTP(2) = ISTR(2) ********^^ 88 IF (IDX .EQ. 1) CALL CCSMVA (KEY,1,32,KEYSTP,1,32) B2000116^t FTN 3.3B (OPT = LPC) CCSDMP PAGE 4 DATE: 08/29/84 TIME: 2124 t^ C INITIAL GO AT RETRIEVING A RECORD B2000118^^ 89 1000 DO 1010 I = 1,16 B2000119^^ 90 1010 RECSPC(I) = 0 B2000120^^ 91 RECSPC(1) = ISTR(1) ********^^ 92 RECSPC(2) = ISTR(2) ********^^ 93 IF ( IDX .EQ. 1) CALL CCSMVA ( KEY, 1, 32, RECSPC, 1, 32) B2000122^^ 94 CALL READR (REQBUF, BUFFER, RECSPC, KSTAT) B2000123^^ C CHECK 1ST FOR GOOD READ RIGHT ON RECORD B2000124^^ 95 IF ( KSTAT .GE. 0 .AND. AND(KSTAT,$0200) .EQ. 0) GO TO 1100 B2000125^^ C CHECK FOR CLOSE WHEN CLOSE IS GOOD ENOUGH B2000126^^ 96 IF (KSTAT .GE. 0 .AND. EXACT .EQ. 0) GO TO 1100 B2000127^^ C WE ARE LEFT WITH EITHER NO RETRIEVE OR A CLOSE WHEN WE WANTED TO B2000128^^ C EXACT RECORD B2000129^^ 97 CALL FILERR ( IDATA, 13, KSTAT, LUNIT) B2000130^^ 98 GO TO 100 B2000131^  ^ C GOOD INITIAL RETRIEVE, SET UP DUMP HEADINGS B2000133^^ 99 1100 WRITE (LU,9007) B2000134^^ 100 9007 FORMAT ( '1 FILE NAME TYPE RETRIEVAL KEY LIMITS') B2000135^^ 101 IF (IDX .EQ. 1) GO TO 1150 B2000136^^ C RECORD NUMBER HEADINGS B2000137^^ 102 WRITE(LU,9008)(IDATA(I),I=1,4),LIT1,JRTYP,RSTR ********^^ 103 9008 FORMAT ( 4X, 4A2, 2X, 2A2, 5X, I1, 10X, F7.0 ) ********^^ 104 WRITE (LU,9009) RSTP ********^^ 105 9009 FORMAT ( 34X, F7.0, // ) ********^^ 106 GO TO 1200 B2000142^ ^ C KEY VALUE HEADINGS B2000144^^ 107 1150 CALL CCSMVA ($2020, 1, 1, LIT3, 1, 6) B2000145^^ 108 IF (EXACT .EQ. 1) CALL CCSMVA(LEXT, 1, 6, LIT3, 1, 6) B2000146^^ 109 WRITE (LU, 9010) (IDATA(I),I=1,4), LIT1, JRTYP, LIT3, KEY B2000147^^ 110 9010 FORMAT (4X, 4A2, 2X, 2A2, 5X, I1, 1X, 3A2, 3X, 16A2) B2000148^^ 111 IF (EXACT .EQ. 1) GO TO 1200 B2000149^^ 112 WRITE (LU,9011) KEYSTP B2000150^^ 113 9011 FORMAT ( 34X, 16A2, //) B2000151^^ C CHECK IF KEY VALUE PAST LIMIT B2000152^^ 114 1175 CALL CCSCST ( RECSPC, 1, 32, KEYSTP, 1, 32, IND) B2000153^^ 115 IF (IND .GT. 0) GO TO 240 ********^  ^ C PRINT THE RECORD B2000156^^ C ************* PRINT RELATIVE RECORD # IN FILE ******************** ********^^ 116 1200 RRN = REQBUF(16) * 32767.0 ********^^ 117 RRN = RRN + REQBUF(17) ********^^ 118 1205 WRITE(LU,9026)RRN ********^^ 119 9026 FORMAT(1X,'RELATIVE RECORD # IN FILE =',F7.0 ) ********^^ 120 CALL SEEIT (LU,BUFFER,LREC,0) ********^^ 121 IF (EXACT .EQ. 1) GO TO 240 ********^^ C ******************************************************************** ********^^ 122 WRITE (LU, 9012) B2000159^^ 123 9012 FORMAT (1H0) B2000160^ ^ C CHECK IF MORE RECORDS WANTED B2000162^t FTN 3.3B (OPT = LPC) CCSDMP PAGE 5 DATE: 08/29/84 TIME: 2124 t^ 124 IF (IDX .EQ. 1) GO TO 2000 B2000163^^ C CHECK IF PAST RECORD NUMBER LIMIT B2000164^^ 125 RNOW = REQBUF(16)*32767.0 + REQBUF(17) ********^^ 126 IF (RNOW .GE. RSTP ) GO TO 240 ********^ ^ C GET ADDITIONAL RECORDS B2000167^^ 127 2000 CALL GETS (REQBUF, BUFFER, RECSPC, LSTAT) B2000168^^ 128 IF (LSTAT .GE. 0 .AND. IDX .NE. 1) GO TO 1200 B2000169^^ 129 IF ( LSTAT .GE. 0 .AND. IDX .EQ. 1 ) GO TO 1175 B2000170^^ 130 CALL FILERR (IDATA, 14, LSTAT, LUNIT) B2000171^^ 131 GO TO 100 B2000172^   ^ C NORMAL TERMINATION, CLOSE FILE AND REPORT TO USER. B2000176^^ 132 8000 CALL CLOSFL (REQBUF, MSTAT) B2000177^^ 133 WRITE (LUNIT, 9100) B2000178^^ 134 9100 FORMAT ( 'GENERAL DUMP PROGRAM OUT. ') B2000179^^ 135 CALL PGMOUT B2000180^^ 136 END B2000185^t FTN 3.3B (OPT = LPC) CCSDMP PAGE 6 DATE: 08/29/84 TIME: 2124 t  PROGRAM LENGTH $0D18 ( 3352)   EXTERNALS 2 HFLOT Q8STP Q8QINI Q8QX Q8QEND FLOAT PGMIN 22 PGMINT CCSMVA INPUT CCSCST TAPE CLOSFL OPENFL 22 FILERR GETFCB INTGR REALN READR SEEIT GETS 2 PGMOUT  t FTN 3.3B (OPT = LPC) CCSDMP PAGE 7 DATE: 08/29/84 TIME: 2124 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " FF00 (-255) 08E9 65 "j 0000 (0) 0003 8,11,17,18,22,23,28,30,32,34,38,47,52,56,59,60,64,90,95,96,115,120,128,129 j€ 0001 (1) 0002 18,20,21,27,29,31,41,44,45,46,47,48,57,65,69,70,72,74,75,79,80,82,84,86,88,89,91,93,101,102,107, €> 108,109,111,114,121,124,128,129>& 0003 (3) 08DC 35,109 &2 0004 (4) 08E4 46,46,47,48,102,1092$ 0005 (5) 08D3 11,21$, 0006 (6) 08EA 71,81,107,108,$ 0007 (7) 08DF 39,42$" 000D (13) 08EE 97 "" 000E (14) 08F2 130"$ 0018 (24) 08D9 27,31$. 0020 (32) 08EB 74,84,88,93,114." 003C (60) 08D5 18 "" 0200 (512) 08ED 95 "& 2020 (8224) 08E5 48,107 &* 47FF FF00 0A0C 49,116,125 *   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < ( AND INTR.FN. 7FFF 44,65,95 (. BUFFER INTEGER 0005 1,24,94,120,127.8 EXACT INTEGER 086F 1,64,65,75,96,108,111,12180 FCBBFR INTEGER 07F1 1,37,41,42,43,44 02 I INTEGER 08DA 30,32,89,90,102,1092F IDATA INTEGER 088B 1,8,27,28,29,30,33,35,39,97,102,109,130F$ IDUSER INTEGER 0887 1,10 $J IDX INTEGER 08E3 43,44,47,52,59,70,80,88,93,101,124,128,129 JJ INBF INTEGER 0851 1,18,19,21,27,55,57,63,65,68,72,74,78,82,84J, IND INTEGER 08D7 21,22,114,115," INDEX INTEGER 08DD 37 "& INDX INTEGER 08A0 1,6,47 &$ INTRPT INTEGER 08D4 16,17$( ISTAT INTEGER 08DB 33,34,35 (* ISTP INTEGER 08C9 1,82,86,87 *0 ISTR INTEGER 08C7 1,72,86,87,91,92 02 JRTYP INTEGER 08E8 57,58,59,60,102,1092( JSTAT INTEGER 08DE 37,38,39 (. KEY INTEGER 08A4 1,74,88,93,109 .. KEYSTP INTEGER 08B4 1,84,88,112,114.* KSTAT INTEGER 08EC 94,95,96,97*& LEXT INTEGER 0881 1,6,108&t FTN 3.3B (OPT = LPC) CCSDMP PAGE 8 DATE: 08/29/84 TIME: 2124 t2 LIT1 INTEGER 089A 1,46,47,50,102,109 2& LIT2 INTEGER 089C 1,48,50&, LIT3 INTEGER 0884 1,107,108,109,( LREC INTEGER 08E0 41,41,120(. LSTAT INTEGER 08F1 127,128,129,130.F LU INTEGER 08CF 6,11,24,99,102,104,109,112,118,120,122 FZ LUNIT INTEGER 08D0 10,12,14,19,24,35,39,50,53,55,61,63,66,68,76,78,97,130,133 Z" MDE INTEGER 08D1 10 "& MSTAT INTEGER 08D8 26,132 &N NCH INTEGER 08D6 19,20,27,55,56,63,68,69,71,72,74,78,79,81,82,84N( NOPRT INTEGER 08D2 10,11,23 (( NRECL INTEGER 08E2 42,43,49 (( NRECM INTEGER 08E1 41,42,49 (" OVER INTEGER 08A2 1,7". Q8QX1 INTEGER 0004 50,102,109,112 .8 RECSPC INTEGER 0871 1,90,91,92,93,94,114,127 8L REQBUF INTEGER 07D5 1,8,26,32,33,37,45,58,94,116,117,125,127,132 L* RNOW REAL 08EF 124,125,126*4 RRN REAL 08E6 48,49,50,116,117,118 4, RSTP REAL 08CD 1,82,104,126 ,( RSTR REAL 08CB 1,72,102 (& SEQ INTEGER 089E 1,6,46 && TAPE0 INTEGER 08C4 1,9,21 && VOLNAM INTEGER 07ED 1,8,37 && Y INTEGER 0870 1,6,65 &   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < & CCSCST SUBROUTINE 0C73 20,114 &B CCSMVA SUBROUTINE 0BED 17,27,46,47,48,74,84,88,93,107,108 B& CLOSFL SUBROUTINE 0CFB 26,132 &, FILERR SUBROUTINE 0CF3 34,39,97,130 , FLOAT REAL.FN. 0C83 " GETFCB SUBROUTINE 0998 37 "" GETS SUBROUTINE 0CDD 127" HFLOT REAL.FN. 0C86 . INPUT SUBROUTINE 0AD3 18,55,63,68,78 ." INTGR SUBROUTINE 0A60 56 "" OPENFL SUBROUTINE 0987 32 " PGMIN SUBROUTINE 08F4 9 " PGMINT SUBROUTINE 0939 16 "" PGMOUT SUBROUTINE 0D15 134" Q8QEND INTEGER.FN. 0C3F Q8QINI INTEGER.FN. 0C91 6 Q8QX SUBROUTINE 0C29 50,102,104,109,112,118 6 Q8STP INTEGER.FN. 0D17 " READR SUBROUTINE 0B62 93 "$ REALN SUBROUTINE 0AE5 71,82$" SEEIT SUBROUTINE 0CAF 119"" TAPE SUBROUTINE 0961 23 "t FTN 3.3B (OPT = LPC) CCSDMP PAGE 9 DATE: 08/29/84 TIME: 2124 t   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < > 100 0912 13,16,23,25,36,40,56,69,98,131 >$ 120 0966 22,26$$ 130 097D 30,32$$ 150 0997 34,37$$ 200 09A9 38,41$. 240 0A2C 51,115,121,126 ." 250 0A31 52 "* 300 0AB4 52,60,66,71*$ 350 0AEB 70,74$( 400 0AF7 72,76,81 ($ 450 0B2B 80,84$$ 500 0B33 79,86$* 1000 0B45 75,83,85,89*$ 1010 0B48 89,90$( 1100 0B7F 95,96,99 (& 1150 0BEC 101,107&& 1175 0C72 113,129&. 1200 0C82 105,111,116,128." 1205 0C90 117"& 2000 0CDC 124,127&& 8000 0CFA 20,132 &$ 9000 0905 12,13$$ 9001 0918 14,15$$ 9002 0A10 50,51$$ 9003 0A37 53,54$$ 9004 0A78 61,62$$ 9005 0ABA 66,67$$ 9006 0AFE 76,77$& 9007 0B86 99,100 && 9008 0BCB 102,103&& 9009 0BE3 104,105&& 9010 0C41 109,110&& 9011 0C6B 112,113&& 9012 0CC0 122,123&& 9026 0C9A 118,119&& 9100 0D04 133,134& CCSDMP 0000 1  t FTN 3.3B (OPT = LPC) CCSPAS PAGE 1 DATE: 08/29/84 TIME: 2125 t^ 1 PROGRAM CCSPAS B2100001^^ 1 1 /B21 F CCS CCS 3.0 SL-149B2100002^^ 2 INTEGER USER(4),INP(2),OUTP(5),MSGO(4) B2100003^^ C B2100004^^ C CYBERCREDIT SYSTEM VERSION 3 B2100005^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B2100006^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B2100007^^ C B2100008^^ 3 DATA OUTP / $D0A, 'READY? ' / B2100009^^ 4 DATA MSGO / 'MNUPRO ' / B2100010^^ 5 DATA INP / ' ' / B2100011^^ 6 CALL PGMIN ( USER, LU, MODE, NPORT ) B2100012^^ 7 CALL WTREAD ( LU, -1, OUTP, 10, -1, INP , 1, L ) B2100013^^ 8 IF (AND(INP(1),$FF00).NE.$2000) CALL CHAIN ( MSGO ) B2100014^^ 9 CALL PGMOUT B2100015^^ 10 END B2100016^t FTN 3.3B (OPT = LPC) CCSPAS PAGE 2 DATE: 08/29/84 TIME: 2125 t  PROGRAM LENGTH $0034 ( 52)   EXTERNALS & Q8STP PGMIN WTREAD CHAIN PGMOUT & t FTN 3.3B (OPT = LPC) CCSPAS PAGE 3 DATE: 08/29/84 TIME: 2125 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : <  FF00 (-255) 0017 8 " FFFE (-1) 0014 7,7"" 0001 (1) 0001 7,8" 000A (10) 0015 7 2000 (8192) 0018 8    VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  AND INTR.FN. 7FFF 8 & INP INTEGER 0006 1,5,7,8& L INTEGER 0016 7 " LU INTEGER 0011 6,7" MODE INTEGER 0012 6 $ MSGO INTEGER 000D 1,4,8$ NPORT INTEGER 0013 6 $ OUTP INTEGER 0008 1,3,7$" USER INTEGER 0002 1,6"   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  CHAIN SUBROUTINE 002E 8 PGMIN SUBROUTINE 001A 5 PGMOUT SUBROUTINE 0031 8 Q8STP INTEGER.FN. 0033 WTREAD SUBROUTINE 0020 6    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : <  CCSPAS 0000 1  t FTN 3.3B (OPT = LPC) CCSSPC PAGE 1 DATE: 08/29/84 TIME: 2125 t^ 1 PROGRAM CCSSPC B2200001^^ 1 1 /B22 F CCS CCS 3.0 .LA SL-149********^^ C B2200003^^ C B2200004^^ C CYBERCREDIT SYSTEM VERSION 3 B2200005^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B2200006^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B2200007^^ C B2200008^^ C--------------------------------------------------------------------- B2200009^^ C B2200010^^ C AUDIT PRODUCES THE FILE SPACE REPORT. THE REPORT DISPLAYS FILE B2200011^^ C NAMES AND AVAILABLE SPACE INFORMATION IN THE FORM OF (1) MAXIMUM B2200012^^ C RECORDS ALLOWED, (2) NUMBER OF RECORDS CURRENTLY IN THE FILE, B2200013^^ C (3) NUMBER OF RECORDS REMAINING, AND (4) PERCENTAGE OF TOTAL FILE B2200014^^ C SPACE AVAILABLE. THIS INFORMATION IS GIVEN FOR SEVEN FILES : B2200015^^ C DELQMST, COSIGNER, ACCAGE, ACTFIL, SUMHIST, TAPEARC, AND INACCT. B2200016^^ C B2200017^^ C--------------------------------------------------------------------- B2200018^^ C B2200019^^ C ---- PROGRAM DECLARATIONS ---- B2200020^^ C B2200021^^ 2 EXTERNAL AMONTO,ADAYTO,AYERTO B2200022^^ C B2200023^^ 3 RELATIVE GETFCB B2200024^^ C B2200025^^ 4 INTEGER LU,LST,OD B2200026^^ 5 INTEGER REQBUF(24),VOLNAM(4),INDEX,FCBBFR(96),ISTAT,ERR(13) B2200027^^ 6 INTEGER NAME(4),REC B2200028^^ 7 REAL MXRECS,CURECS,AVRECS B2200029^^ 8 INTEGER MO,DA,YR B2200031^^ 9 INTEGER RPTHDR(9),HDR1(40),HDR2(40),MSGMU(40),MSGWN(40) B2200032^^ C B2200033^^ 10 REAL HIRECS,NMRECS,RMRECS,PCTREM,TDATRM,TDATRL,NEDATM,NEDATL B2200034^^ 11 REAL COMPM,COMPW B2200035^^ C B2200036^^ 12 DATA COMPM/05.0/,COMPW/15.0/ B2200037^^ 13 INTEGER IDATA(15),ID(4),DDAT(4,7),DDATA(4,7) ********^ ^ 14 DATA DDAT /'DELQMST COSIGNERACCAGE ACTFIL SUMHIST ' ********^^ 14 1, 'TAPEARC INACCT '/ ********^^ 14 2, DDATA/'LADLQMSTLACOSIGNLAACCAGELAACTFILLASUMHST' ********^^ 14 3, 'LATAPARCLAINACCT'/ ********^^ 15 DATA IDATA/ 12*$2020,0,1,0 / ********^^ 16 DATA REC / 0 / B2200042^^ 17 DATA LST/12/,LU/4/ B2200043^^ 18 DATA RPTHDR/' FILE SPACE REPORT'/ B2200044^^ 19 DATA HDR1/' FILE MAXIMUM CURRENT AVAILABLE B2200045^^ 19 2 PCT SPACE '/ B2200046^^ 20 DATA HDR2/' NAME RECORDS RECORDS RECORDS B2200047^^ 20 2 AVAILABLE '/ B2200048^^ 21 DATA MSGMU/' THIS FILE MUST BE COMPRESSED AND HISTORY MUST BE B2200049^^ 21 2RUN ***** '/ B2200050^^ 22 DATA MSGWN/' WARNING - THIS FILE SHOULD BE COMPRESSED B2200051^^ 22 2 ***** '/ B2200052^t FTN 3.3B (OPT = LPC) CCSSPC PAGE 2 DATE: 08/29/84 TIME: 2125 t^ C B2200053^^ 23 EQUIVALENCE (FCBBFR(25),NAME(1)) B2200054^^ 24 BYTE (ISIGN1,TDATRL(15=15)),(ISIGN2,NEDATL(15=15)) B2200055^^ C B2200056^^ C ---- GET DATE ---- B2200057^^ C B2200058^^ 25 MO = AND(AMONTO,$FFFF) B2200059^^ 26 DA = AND(ADAYTO,$FFFF) B2200060^^ 27 YR = AND(AYERTO,$FFFF) B2200061^^ C B2200062^^ 28 CALL PGMIN(ID,ISTAT,ISTAT,ISTAT) ********^^ 29 CALL CCSCST(DDATA,1,2,ID,1,8,ICM) ********^^ 30 IF(ICM.NE.0) CALL CCSMVA(DDAT ,1,56,DDATA,1,56) ********^^ C ---- GET APPROPRIATE FCBS ---- B2200063^^ C B2200064^^ 31 DO 199 K = 1, 7 B2200065^^ C ZERO THE REQUEST BUFFER FOR THE NEXT FILE B2200066^^ 32 DO 250 J = 1, 24 B2200067^^ 33 250 REQBUF(J) = 0 B2200068^^ C OPEN THE FILE FOR USE B2200069^^ 34 CALL CCSMVA(DDATA(1,K),1,8,IDATA,1,24) ********^^ 35 CALL OPENFL( REQBUF, IDATA, ISTAT ) ********^^ C ERROR ? B2200071^^ 36 IF ( ISTAT .GE. 0 ) GO TO 260 B2200072^^ 37 CALL FILERR( IDATA, 3, ISTAT, LU ) ********^^ 38 GO TO 199 B2200074^^ C GET THE FCB B2200075^^ 39 260 VOLNAM(1) = 0 B2200076^^ 40 CALL GETFCB ( REQBUF, VOLNAM, INDEX, FCBBFR, ISTAT ) B2200077^^ C ERROR ? B2200078^^ 41 IF ( ISTAT .GE. 0 ) GO TO 300 B2200079^^ 42 CALL FILERR( IDATA, 7, ISTAT, LU ) ********^^ 43 GO TO 280 B2200081^^ C B2200082^^ C ---- HIT ---- B2200083^^ C B2200084^^ 44 300 REC = REC + 1 B2200085^^ C B2200086^^ C ---- CONVERT TWO-WORD BINARY NUMBER TO REAL ---- B2200087^^ C B2200088^^ 45 TDATRM = FCBBFR(2) * 65536. B2200089^^ 46 TDATRL = FCBBFR(3) B2200090^^ 47 IF ( ISIGN1 .EQ. 1 ) TDATRL = TDATRL + 65535. B2200091^^ 48 HIRECS = TDATRM + TDATRL B2200092^^ C B2200093^^ 49 NEDATM = FCBBFR(7) * 65536. B2200094^^ 50 NEDATL = FCBBFR(8) B2200095^^ 51 IF ( ISIGN2 .EQ. 1 ) NEDATL = NEDATL + 65535. B2200096^^ 52 NMRECS = NEDATM + NEDATL B2200097^^ C B2200098^^ C ---- FIND REMAINING NUMBER OF RECORDS AND PREPARE FOR OUTPUT ---- B2200099^^ C B2200100^^ 53 RMRECS = HIRECS - NMRECS B2200101^^ 54 CURECS = NMRECS B2200102^t FTN 3.3B (OPT = LPC) CCSSPC PAGE 3 DATE: 08/29/84 TIME: 2125 t^ 55 MXRECS = HIRECS B2200103^^ 56 AVRECS = RMRECS B2200104^^ 57 PCTREM = 0 B2200105^^ 58 IF ( HIRECS .EQ. 0 ) GO TO 310 B2200106^^ 59 PCTREM = (RMRECS / HIRECS) * 100. B2200107^^ 60 310 IF ( REC .GT. 1 ) GO TO 350 B2200108^^ C B2200109^^ C ---- OUTPUT HEADERS ---- B2200110^^ C B2200111^^ 61 OD = LU B2200112^^ 62 WRITE (OD,3002) B2200113^^ 63 WRITE (OD,3005) (HDR1(I),I=1,35) B2200114^^ 64 WRITE (OD,3005) (HDR2(I),I=1,35) B2200115^^ 65 WRITE (OD,3001) B2200116^^ C B2200117^^ 66 OD = LST B2200118^^ 67 WRITE (OD,3000) (RPTHDR(I),I=1,9),MO,DA,YR B2200119^^ 68 WRITE (OD,3006) (HDR1(I),I=1,40) B2200120^^ 69 WRITE (OD,3006) (HDR2(I),I=1,40) B2200121^^ 70 WRITE (OD,3002) B2200122^^ C B2200123^^ C ---- OUTPUT FILE INFORMATION ---- B2200124^^ C B2200125^^ 71 350 OD = LU B2200126^^ 72 WRITE (OD,3020) (NAME(I),I=1,4),MXRECS,CURECS,AVRECS,PCTREM B2200127^^ 73 IF (PCTREM .GT. COMPW) GO TO 370 B2200128^^ 74 IF (PCTREM .GT. COMPM) GO TO 360 B2200129^^ 75 WRITE (OD,3005) (MSGMU(I),I=1,35) B2200130^^ 76 GO TO 370 B2200131^^ 77 360 WRITE (OD,3005) (MSGWN(I),I=1,35) B2200132^^ 78 370 WRITE (OD,3888) B2200133^^ C B2200134^^ 79 OD = LST B2200135^^ 80 WRITE (OD,3030) (NAME(I),I=1,4),MXRECS,CURECS,AVRECS,PCTREM B2200136^^ 81 IF (PCTREM .GT. COMPW) GO TO 390 B2200137^^ 82 IF (PCTREM .GT. COMPM) GO TO 380 B2200138^^ 83 WRITE (OD,3006) (MSGMU(I),I=1,40) B2200139^^ 84 GO TO 390 B2200140^^ 85 380 WRITE (OD,3006) (MSGWN(I),I=1,40) B2200141^^ 86 390 WRITE (OD,3001) B2200142^^ C B2200143^^ C ---- GET NEXT FCB ---- B2200144^^ C B2200145^^ C CLOSE THE FILE AND CONTINUE B2200146^^ 87 280 CALL CLOSFL ( REQBUF, ISTAT ) B2200147^^ 88 199 CONTINUE B2200148^^ C B2200149^^ C ---- END OF JOB PROCESSING ---- B2200150^^ C B2200151^^ 89 900 WRITE (LU,3002) B2200152^^ 90 WRITE (LST,3999) B2200153^^ 91 999 CALL PGMOUT B2200154^^ C B2200155^^ C ---- END ---- B2200156^t FTN 3.3B (OPT = LPC) CCSSPC PAGE 4 DATE: 08/29/84 TIME: 2125 t^ C B2200157^^ 92 3000 FORMAT (1H1,////,52X,9A2,2X,1H-,2X,2(1A2,1H/),1A2,////) B2200158^^ 93 3001 FORMAT (/) B2200159^^ 94 3002 FORMAT (//) B2200160^^ 95 3005 FORMAT (40A2) B2200161^^ 96 3006 FORMAT (31X,40A2) B2200162^^ 97 3020 FORMAT (5X,4A2,X,2(4X,F8.0),5X,F8.0,10X,F4.1,1H%) B2200163^^ 98 3030 FORMAT (36X,4A2,X,2(4X,F8.0),5X,F8.0,10X,F4.1,1H%) B2200164^^ 99 3888 FORMAT (X) B2200165^^ 100 3999 FORMAT (1H1) B2200166^^ 101 END B2200167^t FTN 3.3B (OPT = LPC) CCSSPC PAGE 5 DATE: 08/29/84 TIME: 2125 t  PROGRAM LENGTH $043A ( 1082)   EXTERNALS 2 HFLOT Q8STP Q8QINI Q8QX Q8QEND FLOAT AMONTO 22 ADAYTO AYERTO GETFCB PGMIN CCSCST CCSMVA OPENFL 2 FILERR CLOSFL PGMOUT  t FTN 3.3B (OPT = LPC) CCSSPC PAGE 6 DATE: 08/29/84 TIME: 2125 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < ( FFFF (65535) 01A4 25,26,27 (: 0000 (0) 0003 15,16,30,33,36,39,41,57,58 :d 0001 (1) 0002 15,23,29,30,31,32,34,39,44,47,51,60,63,64,67,68,69,72,75,77,80,83,85 d$ 0002 (2) 01A5 29,45$$ 0003 (3) 01AD 37,46$( 0007 (7) 01AA 31,42,49 (( 0008 (8) 01A6 29,34,50 ($ 0018 (24) 01AC 32,34$$ 0038 (56) 01A8 30,30$" 43E4 0000 0349 59 "$ 487F FF80 0347 47,51$$ 48C0 0000 0345 45,49$   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < ( AND INTR.FN. 7FFF 25,26,27 (* AVRECS REAL 0097 1,56,72,80 ** COMPM REAL 0155 1,12,74,82 ** COMPW REAL 0157 1,12,73,81 ** CURECS REAL 0095 1,54,72,80 *& DA INTEGER 009A 1,26,67&( DDAT INTEGER 016C 12,14,30 (. DDATA INTEGER 0188 12,14,29,30,34 . ERR INTEGER 0085 1 2 FCBBFR INTEGER 0024 1,23,40,45,46,49,502* HDR1 INTEGER 00A5 1,19,63,68 ** HDR2 INTEGER 00CD 1,20,64,69 *0 HIRECS REAL 0145 1,48,53,55,58,59 0B I INTEGER 01AE 63,63,64,67,68,69,72,75,77,80,83,85B$ ICM INTEGER 01A7 29,30$( ID INTEGER 0168 12,28,29 (0 IDATA INTEGER 0159 12,15,34,35,37,420$ INDEX INTEGER 0023 1,40 $$ ISIGN1 INTEGER 014F 23,47$$ ISIGN2 INTEGER 0153 24,51$8 ISTAT INTEGER 0084 1,28,35,36,37,40,41,42,878$ J INTEGER 01AB 31,33$$ K INTEGER 01A9 30,34$, LST INTEGER 0005 1,17,66,79,90,2 LU INTEGER 0004 1,17,37,42,61,71,892& MO INTEGER 0099 1,25,67&* MSGMU INTEGER 00F5 1,21,75,83 *t FTN 3.3B (OPT = LPC) CCSSPC PAGE 7 DATE: 08/29/84 TIME: 2125 t* MSGWN INTEGER 011D 1,22,77,85 ** MXRECS REAL 0093 1,55,72,80 ** NAME INTEGER 003C 1,23,72,80 *, NEDATL REAL 0153 1,24,50,51,52,& NEDATM REAL 0151 1,49,52&* NMRECS REAL 0147 1,52,53,54 *\ OD INTEGER 0006 1,61,62,63,64,65,66,67,68,69,70,71,72,75,77,78,79,80,83,85,86\8 PCTREM REAL 014B 1,57,59,72,73,74,80,81,828* REC INTEGER 0092 1,16,44,60 *, REQBUF INTEGER 0007 1,33,35,40,87,* RMRECS REAL 0149 1,53,56,59 *& RPTHDR INTEGER 009C 1,18,67&, TDATRL REAL 014F 1,24,46,47,48,& TDATRM REAL 014D 1,45,48&& VOLNAM INTEGER 001F 1,39,40&& YR INTEGER 009B 1,27,67&   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " CCSCST SUBROUTINE 01C5 28 "$ CCSMVA SUBROUTINE 01D1 30,34$" CLOSFL SUBROUTINE 03C5 87 "$ FILERR SUBROUTINE 01FB 36,42$ FLOAT REAL.FN. 0219 $ GETFCB SUBROUTINE 0206 1,40 $ HFLOT REAL.FN. 0321 " OPENFL SUBROUTINE 01F2 34 "" PGMIN SUBROUTINE 01BF 27 "" PGMOUT SUBROUTINE 03DA 90 " Q8QEND INTEGER.FN. 03AA Q8QINI INTEGER.FN. 0395 @ Q8QX SUBROUTINE 03A2 63,64,67,68,69,72,75,77,80,83,85 @ Q8STP INTEGER.FN. 0439    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < ( 199 03C8 30,38,88 ($ 250 01DC 31,33$$ 260 0202 36,39$$ 280 03C4 42,87$$ 300 0216 41,44$$ 310 0279 58,60$$ 350 02FD 60,71$$ 360 034E 74,77$( 370 0361 73,76,78 ($ 380 03AC 82,85$t FTN 3.3B (OPT = LPC) CCSSPC PAGE 8 DATE: 08/29/84 TIME: 2125 t( 390 03BF 81,84,86 (" 900 03CF 88 "" 999 03D9 90 "$ 3000 03DC 67,92$( 3001 03F5 65,86,93 (* 3002 03F8 62,70,89,94*. 3005 03FB 63,64,75,77,95 .. 3006 03FF 68,69,83,85,96 .$ 3020 0405 72,97$$ 3030 041B 80,98$$ 3888 0432 78,99$& 3999 0435 90,100 & CCSSPC 0000 1 t FTN 3.3B (OPT = LPC) CHEKID PAGE 1 DATE: 08/29/84 TIME: 2126 t^ 1 PROGRAM CHEKID B2300001^^ 1 1 /B23 F CCS CCS 3.0 SL-149B2300002^^ C B2300003^^ C B2300004^^ C CYBERCREDIT SYSTEM VERSION 3 B2300005^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B2300006^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B2300007^^ C B2300008^^ C--------------------------------------------------------------------- B2300009^^ C B2300010^^ C CHEKID CALLS THE ITOS EXECUTIVE TO VALIDATE THE USER. B2300011^^ C A VALID USER IS DEFINED AS THE CONSOLE OPERATOR B2300012^^ C WITH A BLANK ID (I.E. NOT $$). AN INVALID USER IS B2300013^^ C ANY USER OF A TERMINAL WHICH IS NOT TERMINAL ZERO. B2300014^^ C VALID USERS PROCEED TO THE NEXT REQUEST; INVALID B2300015^^ C USERS ARE REMOVED FROM THE PROCEDURE. B2300016^^ C B2300017^^ C--------------------------------------------------------------------- B2300018^^ C B2300019^^ 2 INTEGER USID,USPN B2300020^^ 3 DIMENSION USID(4),IOUT(4) B2300021^^ 4 DATA IOUT/'MNUPRO '/ B2300022^^ C B2300023^^ C**** PRINT OUT DAY,DATE,TIME,ID ********^^ 5 CALL STIME ********^^ 6 CALL PGMIN(USID,I1,I2,USPN) B2300024^^ 7 IF (USPN .EQ. 0) CALL PGMOUT B2300025^^ 8 CALL SYSMSG(76,0) B2300026^^ C ---- TAKE USER OUT OF PROCEDURE (EXIT) ---- * B2300027^^ 9 CALL CHAIN(IOUT) B2300028^^ 10 END B2300029^t FTN 3.3B (OPT = LPC) CHEKID PAGE 2 DATE: 08/29/84 TIME: 2126 t  PROGRAM LENGTH $0024 ( 36)   EXTERNALS , Q8STP STIME PGMIN PGMOUT SYSMSG CHAIN , t FTN 3.3B (OPT = LPC) CHEKID PAGE 3 DATE: 08/29/84 TIME: 2126 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " 0000 (0) 0001 7,8" 004C (76) 000D 7    VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  I1 INTEGER 000B 6 I2 INTEGER 000C 6 $ IOUT INTEGER 0007 3,4,9$$ USID INTEGER 0002 1,3,6$$ USPN INTEGER 0006 1,6,7$   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  CHAIN SUBROUTINE 0020 8 PGMIN SUBROUTINE 0011 4 PGMOUT SUBROUTINE 001A 7 Q8STP INTEGER.FN. 0023 STIME SUBROUTINE 000F 4 SYSMSG SUBROUTINE 001C 7    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : <  CHEKID 0000 1  t FTN 3.3B (OPT = LPC) CHUPD2 PAGE 1 DATE: 08/29/84 TIME: 2126 t^ 1 PROGRAM CHUPD2 B2600001^^ 1 1 /B26 F CCS CCS 3.0 .LA - PSRD 08-83 SL-149********^ ^ C CYBERCREDIT SYSTEM VERSION 3 B2600004^^ C DATA SYSTEM-LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B2600005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B2600006^ ^ C THIS PROGRAM WILL REQUEST THAT A HISTORY TAPE BE MOUNTED, B2600008^^ C IT WILL VERIFY THAT THE CORRECT TAPE IS MOUNTED, IT WILL B2600009^^ C THEN LOCATE THE CORRECT ACCOUNT AND VERIFY IT'S ON THE B2600010^^ C DELQMST FILE; THEN ADD THE ACTFIL FILE WITH THE ACTIVITY B2600011^^ C BLOCK FROM THE TAPE. WHEN COMPLETE IT WILL THEN PROCESS B2600012^^ C ALL REMAINING TAPES, AS DETERMINED BY THE UPREQ FILE. B2600013^^ C 173*A078********^^ C THE PURPOSE OF PSR A078 IS TO PREVENT DUPLICATE ********^^ C RECORDS WHEN ACCOUNTS ARE UPDATED BOTH FROM ********^^ C AND HISTORY TAPE. ********^^ C ********^^ C PSR A078 DOES THE FOLLOWING:- ********^^ C DEFINES A TEMPORARY FILE WHICH IS INDEXED BY ACCOUNT #. ********^^ C THE PRESENCE OF A RECORD IN THE TEMPORARY FILE MEANS ********^^ C THAT THIS PROGRAM WROTE THE RECORD HAVING ********^^ C SUFFIX 51 FOR THE SAME ACCOUNT. ********^^ C THE ABSENCE OF A RECORD IN THE TEMPORARY FILE MEANS ********^^ C THAT THIS PROGRAM DID NOT WRITE THE RECORD BUT, ********^^ C IF AN RECORD EXISTS, IT MUST HAVE BEEN WRITTEN ********^^ C BY . IF WROTE THE RECORD, ********^^ C THEN THIS PROGRAM WILL OVERLAY THAT RECORD WITH NEW DATA. ********^^ C ********^^ C THE DEFINED NUMBER OF RECORDS IN THE TEMPORARY FILE ********^^ C WILL BE ONE MORE THAN ARE ACTUALLY STORED IN . ********^^ C ********^^ C THE TEMPORARY FILE IS DELETED BY THIS PROGRAM AT ITS END. ********^^ C ********^^ 2 INTEGER UPRFCB(96), CHPBUF(24), CHPDAT(24), CHPREC(11) ********^^ 2 1 , VOLNAM(4), BUFCHP(24), DATCHP(15), ACTEMP(252) ********^^ 2 2 , CHPKEY(9), WRONKY ********^^ C ********^^ 3 DATA CHPBUF/24*0/ ********^^ 4 DATA CHPDAT/'CHUPTEMP',4*$2020,'SYSVOL ' ********^^ 4 1 , 18, 0, 0, $0001 ********^^ 4 2 , 16, 1, 0, 0 ********^^ 4 3 , 0, 0, 0, 0 / ********^^ 5 DATA VOLNAM/4*0/ ********^^ 6 DATA BUFCHP/24*0/, DATCHP/'CHUPTEMP',8*$2020,1,1,0/ ********^^ 7 DATA CHPREC/11*0/, WRONKY/$8200/ ********^^ C ********^^ 8 EQUIVALENCE (NEDATM,UPRFCB(7)), (NEDATL,UPRFCB(8)) ********^^ C ********^^ C 173*A078********^  ^ 9 INTEGER FP,REQBUF(72),IDATA(15),USER(4),RECBUF(1000),TREC(1001), B2600016^^ 9 2 AREC(252),HD(20,3),DT(3),FNAME(4,3),RTYPE,ZERO,ACT(9), B2600017^t FTN 3.3B (OPT = LPC) CHUPD2 PAGE 2 DATE: 08/29/84 TIME: 2126 t^ 9 2 COMMD(2),OK,EX,RD,TEMP(8),ERMSG(13),NFMSG(26),DATE(3), B2600018^^ 9 2 OLDTP(3),MTMSG(52),TFL(4),RESLT(2),PRYES(2),PRNO(2), B2600019^^ 9 2 RQACT(8),TPACT(8),SUF(3),BOROW(15),SW,SKP B2600020^^ 10 INTEGER BLK(8) B2600021^^ 11 INTEGER ENDMSG(7),NMTMSG(14),REEL B2600022^ ^ 12 EQUIVALENCE ( TREC(8),TPACT(8) ) B2600024^ ^ C INITIALIZE THE REQUEST BUFFERS B2600026^^ 13 DATA REQBUF / 72*0 / B2600027^ ^ C SET UP THE DATA FOR OPENING THE FILES B2600029^^ 14 DATA IDATA / 12*$2020, 1, 1, -1 / B2600030^ ^ C SET UP THE BUFFER WITH THE FILE NAMES TO BE USED B2600032^^ 15 INTEGER F2NAM(4,3) ********^^ 16 DATA F2NAM /'DELQMST ACTFIL UPREQ ' / ********^^ 17 DATA FNAME /'LADLQMSTLAACTFILLAUPDREQ' / ********^ ^ C MESSAGE BUFFERS CONTAINING DIRECTIONS AND INSTRUCTIONS B2600035^^ 18 DATA MTMSG / $D0A,'MOUNT TAPE LABELED: / / ', B2600036^^ 18 2 $D0A,'ENTER "OK" FOR READY', B2600037^^ C ****************************************************** ???*0016********^^ 18 2 $D0A,'ENTER "NX" FOR NEXT TAPE ', ********^^ C ****************************************************** ???*0016********^^ 18 2 $D0A,'ENTER "EX" TO END ',$D0A / B2600039^^ 19 DATA OK/'OK'/,EX/'EX'/,NX/'NX'/,ZERO/0/,RD/0/ B2600040^^ 20 DATA ERMSG / $D0A,'INCORRECT TAPE MOUNTED',$D0A / B2600041^^ 21 DATA NFMSG / $D0A,'ACCOUNT=# ',8*$2020,' NOT FOUND ON ', B2600042^^ 21 2 4*$2020,$D0A / B2600043^^ 22 DATA ENDMSG/'END OF HISTORY'/ B2600044^^ 23 DATA NMTMSG/$D0A,'END OF REEL X MOUNT REEL X'/ B2600045^^ 24 DATA TFL / 'TAPE ' / B2600046^^ 25 DATA PRYES,PRNO / ' YES',' NO' / B2600047^^ 26 DATA BLK / 8*$2020 / B2600048^ ^ 27 EXTERNAL MONTO,YERTO B2600050^ ^ C ACCEPT LOG ON FROM ITOS B2600052^^ 28 CALL PGMIN (USER,LU,MODE,NPORT) B2600053^^ 29 CALL CCSCST(FNAME,1,2,USER,1,8,ICM) ********^^ 30 IF(ICM.NE.0) CALL CCSMVA(F2NAM,1,24,FNAME,1,24) ********^ ^ C PICK UP SYSTEM DATE AND CONVERT B2600055^^ 31 IMTH=AND(MONTO,$FFFF) B2600056^^ 32 IYR=AND(YERTO,$FFFF) B2600057^ ^ C LOCATE THE REPORT HEADING INFORMATION B2600059^^ 33 CALL UTHEAD (HD,DT) B2600060^^ C PRINT THE REPORT HEADING B2600061^^ 34 WRITE (12,1000)(HD(I,1),I=1,20),(HD(I,2),I=1,20),DT,(HD(I,3), B2600062^^ 34 1 I=1,20) B2600063^ ^ C OPEN ALL FILES FOR USE, IF ERROR - PRINT MESSAGE AND EXIT B2600065^t FTN 3.3B (OPT = LPC) CHUPD2 PAGE 3 DATE: 08/29/84 TIME: 2126 t^ 35 DO 50 FP=1,2 B2600066^^ 36 DO 40 I=1,4 B2600067^^ 37 40 IDATA(I)=FNAME(I,FP) B2600068^^ 38 CALL OPENFL (REQBUF(24*FP+1),IDATA,ISTAT) B2600069^^ 39 RTYPE=3 B2600070^^ 40 IF (ISTAT.LT.0) GO TO 900 B2600071^^ 41 DO 45 I=5,12 B2600072^^ 42 45 IDATA (I)=$2020 B2600073^^ 43 50 CONTINUE B2600074^^ 44 DO 70 I=1,4 B2600075^^ 45 70 IDATA(I)=FNAME(I,3) B2600076^^ 46 IDATA(13)=0 B2600077^^ 47 CALL OPENFL (REQBUF(1),IDATA,ISTAT) B2600078^^ 48 IF (ISTAT.LT.0) GO TO 900 B2600079^^ C 173*A078********^^ C ********^^ C--- DEFINE THE TEMPORARY FILE AS FOLLOWS:- ********^^ C 1. GET THE FCB FOR . ********^^ C 2. CREATE FILE, INDEXED, # OF RECORDS WILL BE ********^^ C ONE MORE THAN STORED IN . ********^^ C THIS IS DONE BECAUSE MIGHT BE EMPTY ********^^ C ********^^ 49 RTYPE = 7 ********^^ 50 CALL GETFCB(REQBUF(1),VOLNAM,INDEX,UPRFCB,ISTAT) ********^^ 51 IF(ISTAT.LT.0) GO TO 910 ********^^ C ********^^ C--- FETCH NUMBER OF RECORDS. ********^^ 52 CHPDAT(14) = NEDATM ********^^ 53 CHPDAT(15) = NEDATL + 1 ********^^ C ********^^ C **** FIRST DELETE FILE IF PRESENT ? ********^^ 54 CALL DELETE(CHPBUF,CHPDAT,ISTAT) ********^^ 55 DO 78 I=1,24 ********^^ 56 78 CHPBUF(I) = 0 ********^^ C ********^^ C--- DEFINE THE TEMPORARY FILE. ********^^ 57 CALL CREATE(CHPBUF,CHPDAT,ISTAT) ********^^ 58 RTYPE = 0 ********^^ 59 IF(ISTAT.GE.0) GO TO 85 ********^^ 60 80 CONTINUE ********^^ 61 CALL FILERR(CHPDAT,RTYPE,ISTAT,LU) ********^^ 62 GO TO 950 ********^^ C ********^^ C--- OPEN THE TEMPORARY FILE. ********^^ 63 85 CONTINUE ********^^ 64 RTYPE = 3 ********^^ 65 CALL OPENFL(BUFCHP,DATCHP,ISTAT) ********^^ 66 IF(ISTAT.LT.0) GO TO 80 ********^^ C 173*A078********^ ^ C SEQUENTIALLY RETRIEVE RECORDS FROM THE UPREQ FILE B2600081^^ 67 100 CALL GETS ( REQBUF(1),RECBUF,KEY,ISTAT ) B2600082^^ C ****************************************************** 173*0016********^^ 68 105 RTYPE = 14 ********^t FTN 3.3B (OPT = LPC) CHUPD2 PAGE 4 DATE: 08/29/84 TIME: 2126 t^ C ****************************************************** 173*0016********^ ^ C CHECK IF AT END-OF-FILE B2600085^^ 69 IF (AND(ISTAT,$100).EQ.$100) GO TO 950 B2600086^^ C ****************************************************** 173*0016********^^ 70 IF ( ISTAT .LT. 0 ) GO TO 910 ********^^ C ****************************************************** 173*0016********^^ C SET UP ACCOUNT NUMBER FOR MESSAGE B2600088^^ 71 CALL CCSMVA (RECBUF,1,16,RQACT,1,16) B2600089^^ 72 CALL CCSMVA (RQACT,1,16,NFMSG,13,16) B2600090^ ^ C CHECK IF SAME TAPE TO BE PROCESSED ? B2600092^^ 73 CALL CCSCST (RECBUF,17,6,OLDTP,1,6,ICOMP) B2600093^^ 74 IF (ICOMP.EQ.0) GO TO 200 B2600094^ ^ C NEW TAPE TO PROCESS, SAVE DATE AND PROMPT OPERATOR B2600096^^ 75 SW=0 B2600097^^ 76 REEL=$31 B2600098^^ 77 CALL CCSMVA (RECBUF,17,6,OLDTP,1,6) B2600099^^ 78 MTMSG(12)=RECBUF(9) B2600100^^ 79 MTMSG(14)=RECBUF(10) B2600101^^ 80 MTMSG(16)=RECBUF(11) B2600102^^ C OUTPUT INSTRUCTIONS AND INPUT COMMANDS B2600103^^ 81 150 CALL WTREAD (LU,-1,MTMSG,104,-1,COMMD,2,IC) B2600104^^ C CHECK FOR TAPE READY B2600105^^ 82 IF (COMMD.EQ.OK) GO TO 210 B2600106^^ C CHECK FOR EXIT B2600107^^ 83 IF (COMMD.EQ.EX) GO TO 950 B2600108^^ C CHECK FOR NEXT RECORD B2600109^^ C ****************************************************** 173*0016********^^ 84 IF ( COMMD .NE. NX ) GO TO 150 ********^^ C SKIP UPDATE REQUESTS UNTIL REQUEST FOR DIFFERENT TAPE ********^^ C OR END FOUND ********^^ 85 CALL CCSMVA ( RECBUF, 17, 6, OLDTP, 1, 6 ) ********^^ 86 160 CALL GETS ( REQBUF, RECBUF, KEY, ISTAT ) ********^^ 87 IF ( AND(ISTAT,$100) .NE. 0 ) GO TO 105 ********^^ 88 IF ( ISTAT .LT. 0 ) GO TO 910 ********^^ 89 CALL CCSCST ( RECBUF, 17, 6, OLDTP, 1, 6, ICOMP ) ********^^ 90 IF ( ICOMP .NE. 0 ) GO TO 105 ********^^ 91 GO TO 160 ********^^ C ****************************************************** 173*0016********^ ^ C CHECK IF IT IS NECESSARY TO READ TAPE B2600113^^ 92 200 IF (RD.EQ.0) GO TO 210 B2600114^^ 93 RD=0 B2600115^^ 94 GO TO 300 B2600116^ ^ C GET NEXT RECORD FROM TAPE B2600118^^ 95 210 ASSIGN 220 TO IRTN B2600119^^ 96 CALL FREAD (6,TREC,2000,IRTN,0,TEMP) B2600120^^ 97 CALL DISP B2600121^^ C SET UP MESSAGE FOR TAPE B2600122^^ 98 220 CALL CCSMVA (TFL,1,8,NFMSG,43,8) B2600123^ t FTN 3.3B (OPT = LPC) CHUPD2 PAGE 5 DATE: 08/29/84 TIME: 2126 t^ C CHECK IF AT ROUTINE TO WRITE ACTFIL RECORD B2600125^^ 99 IF (SW.EQ.2) GO TO 400 B2600126^ ^ C CHECK IF LAST RECORD B2600128^^ 100 CALL CCSCST(TREC,1,14,ENDMSG,1,14,ICOMP) B2600129^^ 101 IF(ICOMP.EQ.0) GO TO 500 B2600130^^ C CHECK FOR EOF, IF EOF, THERE ARE MORE REELS B2600131^^ 102 IF(LINK(0).GE.0) GO TO 230 B2600132^^ C OUTPUT MESSAGE TO MOUNT NEXT REEL B2600133^^ 103 CALL CCSMVA(REEL,2,1,NMTMSG,15,1) B2600134^^ 104 REEL=REEL+1 B2600135^^ 105 CALL CCSMVA(REEL,2,1,NMTMSG,28,1) B2600136^^ 106 CALL WTREAD(LU,-1,NMTMSG,28,ZERO,ZERO,ZERO,IC) B2600137^^ 107 GO TO 150 B2600138^ ^ C CHECK WHICH WAY TO RUN B2600140^^ 108 230 IF(SW.EQ.1) GO TO 300 B2600141^ ^ C TAPE READY VERIFY TAPE DATE B2600143^^ 109 CALL CCSMVA (TREC,1,6,DATE,1,6) B2600144^^ 110 CALL CCSCST (DATE,1,6,OLDTP,1,6,ICOMP) B2600145^^ 111 IF (ICOMP.EQ.0) GO TO 240 B2600146^^ C OUTPUT ERROR MESSAGE B2600147^^ 112 CALL WTREAD (LU,-1,ERMSG,26,ZERO,ZERO,ZERO,IC) B2600148^^ 113 GO TO 150 B2600149^^ C TAPE CORRECT - PROCESS ACCOUNT B2600150^^ 114 240 SW=1 B2600151^^ 115 GO TO 210 B2600152^ ^ C PROCESS THE SAME TAPE REQUESTED B2600154^^ C FIRST, SEARCH THE REQUESTED ACCOUNT ON THE TAPE B2600155^^ 116 300 CALL CCSCST (TPACT,1,16,RQACT,1,16,ICOMP) B2600156^^ 117 IF (ICOMP.LT.0) GO TO 210 B2600157^^ 118 IF (ICOMP.EQ.0) GO TO 310 B2600158^^ 119 RD=1 B2600159^^ 120 GO TO 500 B2600160^ ^ C RETRIEVE THE DELQMST RECORD TO CHECK IF IT EXIT B2600162^^ 121 310 CALL READR (REQBUF(25),RECBUF,RQACT,ISTAT) B2600163^^ 122 RTYPE=13 B2600164^^ C SET UP MESSAGE FOR DELQMST FILE B2600165^^ 123 CALL CCSMVA (FNAME,1,8,NFMSG,43,8) B2600166^ ^ C END-OF-FILE ? B2600168^^ C***** PSR 07/83 ********^^ 124 IF(AND(ISTAT,$100).EQ.$100.OR.AND(ISTAT,$200).EQ.$200) GO TO 500 ********^^ C***** ********^^ C ****************************************************** ???*0016********^^ 125 IF ( ISTAT .LT. 0 ) GO TO 920 ********^^ C ****************************************************** ???*0016********^ ^ C SWITCH IS SET FOR THE ROUTINE TO WRITE THE ACTFIL RECORD B2600176^^ 126 SW=2 B2600177^^ 127 SKP=0 B2600178^t FTN 3.3B (OPT = LPC) CHUPD2 PAGE 6 DATE: 08/29/84 TIME: 2126 t^ 128 CALL CCSMVA (PRNO,1,4,RESLT,1,4) B2600179^^ 129 CALL CCSMVA (RECBUF,18,30,BOROW,1,30) B2600180^^ 130 GO TO 210 B2600181^ ^ C ROUTINE - TRY TO WRITE THE ACTFIL RECORD B2600183^^ C FIRST, CHECK IF IT IS EOF ? B2600184^^ 131 400 IF (LINK(0).LT.0) GO TO 480 B2600185^^ C CHECK IF THE ACCOUNT IS THE SAME B2600186^^ 132 CALL CCSCST (TPACT,1,16,RQACT,1,16,ICOMP) B2600187^^ 133 IF (ICOMP.EQ.0) GO TO 410 B2600188^^ 134 IF (SKP.EQ.1) GO TO 405 B2600189^^ 135 CALL CCSCST (TPACT,1,16,BLK,1,16,ICOMP) B2600190^^ 136 IF (ICOMP.EQ.0) GO TO 410 B2600191^^ 137 405 RD=1 B2600192^^ 138 GO TO 480 B2600193^ ^ C ACTFIL MANIPULATION B2600195^^ C SET UP SUFFIX = 50 AND SKIP FIRST BLOCK (COSIGNER) B2600196^^ 139 410 IF (SKP.EQ.1) GO TO 420 B2600197^^ 140 SUF(3)=$3530 B2600198^^ 141 I=1 B2600199^^ 142 GO TO 430 B2600200^^ 143 420 I=0 B2600201^ ^ C THIS IS THE ACTIVITY BLOCK B2600203^^ C CHECK IF THIS BLOCK IS THE GOOD ACCOUNT B2600204^^ 144 430 CALL CCSCST ( TREC(250*I+1),1,16,RQACT,1,16,ICOMP) B2600205^^ 145 IF (ICOMP.NE.0) GO TO 480 B2600206^^ C**** DON'T RELOAD ACTFIL BLOCKS WITH SUFFIX > 50 PSR 07/83 ********^^ 146 ISFX = TREC(250*I+9) ********^^ 147 IF(ISFX.GT.$3530) GO TO 480 ********^^ C CONVERT SUFFIX INTO A DECIMAL NUMBER, THEN INCREMENT 1 B2600207^^ C ****************************************************** 173*0016********^^ 148 440 K = ICCSAD(SUF(3)) ********^^ C ****************************************************** 173*0016********^^ 149 K=K+1 B2600209^^ 150 CALL HEXDEC (K,SUF) B2600210^^ C CHECK IF THE SUFFIX EXCEED OVER 99 B2600211^^ 151 IF (K.GT.99) GO TO 480 B2600212^^ C CREATE THE KEY AND PLACE ACTIVITY BLOCK IN THE RECORD B2600213^^ 152 CALL CCSMVA (RQACT,1,16,AREC,1,16) B2600214^^ 153 AREC(9)=SUF(3) B2600215^^ 154 CALL CCSMVA (AREC,1,18,ACT,1,18) B2600216^^ 155 CALL CCSMVA (TREC(250*I+1),19,482,AREC,19,482) B2600217^^ C PLACE THE RECORD IN THE ACTFIL B2600218^^ 156 CALL WRITER (REQBUF(49),AREC,ACT,ISTAT) B2600219^^ C 173*A078********^^ 157 RTYPE = 12 ********^^ 158 IF(ISTAT.GE.0) GO TO 450 ********^^ C ********^^ C--- SEE IF REJECT BECAUSE RECORD ALREADY EXISTS. ********^^ 159 IF(AND(ISTAT,$10).EQ.0) GO TO 930 ********^^ C ********^^ C--- IF SUFFIX NOT 51, BUMP IT AND TRY AGAIN. ********^t FTN 3.3B (OPT = LPC) CHUPD2 PAGE 7 DATE: 08/29/84 TIME: 2126 t^ 160 IF(ACT(9).NE.$3531) GO TO 440 ********^^ C ********^^ C--- SUFFIX IS 51; SEE IF I WROTE THE EXISTING RECORD. ********^^ C (PRESENCE OF RECORD SAYS I WROTE IT.) ********^^ 161 CALL CCSMVA(AREC,1,18,CHPKEY,1,18) ********^^ 162 RTYPE = 13 ********^^ 163 CALL READR(BUFCHP,CHPREC,CHPKEY,ISTAT) ********^^ C ********^^ C--- IF I WROTE IT, BUMP SUFFIX AND TRY AGAIN. ********^^ 164 IF(AND(ISTAT,WRONKY).EQ.0) GO TO 440 ********^^ C ********^^ C--- I DIDN'T WRITE IT. ********^^ C ********^^ C--- READ THE EXISTING RECORD AND UPDATE WITH NEW DATA. ********^^ 165 CALL CCSMVA(ACT,1,18,CHPKEY,1,18) ********^^ 166 RTYPE = 13 ********^^ 167 CALL READR(REQBUF(49),ACTEMP,CHPKEY,ISTAT) ********^^ 168 IF(AND(ISTAT,WRONKY).NE.0) GO TO 930 ********^^ 169 RTYPE = 15 ********^^ 170 CALL UPDREC(REQBUF(49),AREC,ISTAT) ********^^ 171 IF(ISTAT.LT.0) GO TO 930 ********^^ C ********^^ C--- DECLARE THAT I WROTE THIS RECORD BY ********^^ C WRITING A RECORD. ********^^ 172 445 CONTINUE ********^^ 173 RTYPE = 12 ********^^ 174 CALL WRITER(BUFCHP,AREC,AREC,ISTAT) ********^^ 175 IF(ISTAT.LT.0) GO TO 80 ********^^ 176 GO TO 477 ********^^ C ********^^ C--- RECORD SUCCESSFULLY WRITTEN; SEE IF SUFFIX IS 51. ********^^ 177 450 CONTINUE ********^^ 178 IF(ACT(9).EQ.$3531) GO TO 445 ********^^ C ********^^ C ********^^ 179 477 CONTINUE ********^^ C 173*A078********^^ 180 CALL CCSMVA (PRYES,1,4,RESLT,1,4) B2600222^^ C CHECK IF THE RECORD HAS FINISHED TO BE PLACED IN THE ACTFIL B2600223^^ 181 I=I+1 B2600224^^ 182 IF (I.LT.4) GO TO 430 B2600225^^ 183 SKP=1 B2600226^^ 184 GO TO 210 B2600227^ ^ C PRINT THE DETAIL B2600229^^ 185 480 WRITE (12,1100) RQACT,BOROW,DATE,RESLT B2600230^^ 186 CALL CCSBLK (BOROW,30) B2600231^^ 187 GO TO 510 B2600232^ ^ C OUTPUT NO-FOUND MESSAGE B2600234^^ 188 500 CALL WTREAD (LU,-1,NFMSG,52,ZERO,ZERO,ZERO,IC) B2600235^^ 189 510 SW=1 B2600236^^ 190 GO TO 100 B2600237^ t FTN 3.3B (OPT = LPC) CHUPD2 PAGE 8 DATE: 08/29/84 TIME: 2126 t^ C A FILE ERROR HAS OCCURRED - REPORT AND TERMINATE JOB B2600239^^ 191 900 CALL FILERR (IDATA,RTYPE,ISTAT,LU) B2600240^^ C ****************************************************** 173*0016********^^ 192 GO TO 950 ********^^ 193 910 CALL FILERR ( FNAME(1,3), RTYPE, ISTAT, LU ) ********^^ 194 GO TO 950 ********^^ 195 920 CALL FILERR ( FNAME, RTYPE, ISTAT, LU ) ********^^ 196 GO TO 950 ********^^ 197 930 CALL FILERR ( FNAME(1,2), RTYPE, ISTAT, LU ) ********^^ C ****************************************************** 173*0016********^ ^ C REPORT END AND CLOSE ALL FILES, THEN EXIT B2600242^^ 198 950 WRITE (12,1200) B2600243^^ 199 CALL CLOSFL (REQBUF(1),ISTAT) B2600244^^ 200 CALL CLOSFL (REQBUF(25),ISTAT) B2600245^^ 201 CALL CLOSFL (REQBUF(49),ISTAT) B2600246^^ C 173*A078********^^ C ********^^ C--- CLOSE AND DELETE TEMPORARY FILE. ********^^ 202 CALL CLOSFL(BUFCHP,ISTAT) ********^^ 203 DO 955 J = 1,24 ********^^ 204 955 BUFCHP(J) = 0 ********^^ 205 CALL DELETE(BUFCHP,CHPDAT,ISTAT) ********^^ C 173*A078********^^ 206 CALL PGMOUT B2600247^ ^ C OUTPUT FORMATS B2600249^^ 207 1000 FORMAT (1H1,20A2,9X,'TAPE HISTORY UPDATE REPORT',/,1X,20A2,14X, B2600250^^ 207 1 'RUN DATE:',A2,'/',A2,'/',A2,/,1X,20A2,//,20X,'ACCOUNT NUMBER', B2600251^^ 207 1 8X,'BORROWERS NAME',17X,'DATE OF TAPE',5X,'RECORDS ADDED TO ', B2600252^^ 207 1 'ACTIVITY FILE',/) B2600253^^ 208 1100 FORMAT (19X,8A2,5X,15A2,5X,A2,'/',A2,'/',A2,19X,2A2) B2600254^^ 209 1200 FORMAT (//,50X,'*** END OF REPORT ***') B2600255^^ 210 END B2600256^t FTN 3.3B (OPT = LPC) CHUPD2 PAGE 9 DATE: 08/29/84 TIME: 2126 t  PROGRAM LENGTH $10A4 ( 4260)   EXTERNALS 2 Q8STP Q8QINI Q8QX Q8QEND MONTO YERTO PGMIN 22 CCSCST CCSMVA UTHEAD OPENFL GETFCB DELETE CREATE 22 FILERR GETS WTREAD FREAD DISP LINK READR 22 ICCSAD HEXDEC WRITER UPDREC CCSBLK CLOSFL PGMOUT 2 t FTN 3.3B (OPT = LPC) CHUPD2 PAGE 10 DATE: 08/29/84 TIME: 2126 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < 0 FFFE (-1) 0C26 81,81,106,112,1880$ FFFF (65535) 0C17 31,32$‚ 0000 (0) 0003 3,4,5,6,7,13,19,30,40,46,48,51,56,58,59,66,70,74,75,87,88,90,92,93,96,101,102,111,117,118,125,127, ‚N 131,133,136,143,145,158,159,164,168,171,175,204N‚ 0001 (1) 0002 4,6,14,29,30,34,35,36,38,44,47,50,53,55,67,71,72,73,77,81,85,89,98,100,103,104,105,106,108,109,110 ‚€ ,112,114,116,119,123,128,129,132,134,135,137,139,141,144,149,152,154,155,161,165,180,181,183,188,€2 189,193,197,199,2032B 0002 (2) 0C12 29,34,35,81,99,103,105,126,185,197 B4 0004 (4) 0C1A 36,37,44,128,180,182 48 0006 (6) 0C24 73,73,77,85,89,96,109,1108, 0008 (8) 0C13 29,98,123,185,. 000D (13) 0C22 72,122,162,166 .( 000E (14) 0C1F 68,79,100(* 000F (15) 0C2C 103,169,185*B 0010 (16) 0C21 71,71,72,80,116,132,135,144,152,159B* 0011 (17) 0C23 73,77,85,89*. 0012 (18) 0C30 129,154,161,165.& 0013 (19) 0C36 155,155&. 0018 (24) 0C15 30,30,38,55,203." 001A (26) 0C2E 112"& 001C (28) 0C2D 105,106&* 001E (30) 0C31 129,129,186*& 002B (43) 0C2B 98,123 &" 0034 (52) 0C39 188"" 0068 (104) 0C27 81 "* 00FA (250) 0C33 144,146,155*, 0100 (256) 0C20 69,69,87,124 ,& 01E2 (482) 0C37 155,155&& 0200 (512) 0C2F 124,124&" 07D0 (2000) 0C2A 96 "" 2020 (8224) 0C1C 42 "& 3530 (13616) 0C32 140,147&& 3531 (13617) 0C38 160,178&   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < 4 ACT INTEGER 0B47 8,154,156,160,165,1784$ ACTEMP INTEGER 00CB 1,167$: AND INTR.FN. 7FFF 31,32,69,87,124,159,164,168:@ AREC INTEGER 09FE 8,152,153,154,155,156,161,170,174@( BLK INTEGER 0BE4 8,26,135 (, BOROW INTEGER 0BD3 8,129,185,186,t FTN 3.3B (OPT = LPC) CHUPD2 PAGE 11 DATE: 08/29/84 TIME: 2126 t: BUFCHP INTEGER 00A4 1,6,65,163,174,202,204,205 :, CHPBUF INTEGER 0065 1,3,54,56,57 ,6 CHPDAT INTEGER 007D 1,4,52,53,54,57,61,205 60 CHPKEY INTEGER 01C7 1,161,163,165,1670& CHPREC INTEGER 0095 1,7,163&, COMMD INTEGER 0B50 8,81,82,83,84,& DATCHP INTEGER 00BC 1,6,65 &, DATE INTEGER 0B84 8,109,110,185,& DT INTEGER 0B36 8,33,34&( ENDMSG INTEGER 0BEC 8,22,100 (( ERMSG INTEGER 0B5D 8,20,112 (& EX INTEGER 0B53 8,19,83&( F2NAM INTEGER 0C02 14,16,30 (@ FNAME INTEGER 0B39 8,17,29,30,37,45,123,193,195,197 @* FP INTEGER 01D1 8,35,37,38 *& HD INTEGER 0AFA 8,33,34&X I INTEGER 0C19 33,34,36,37,41,42,44,45,55,56,141,143,144,146,155,181,182X. IC INTEGER 0C28 81,106,112,188 .$ ICM INTEGER 0C14 29,30$^ ICOMP INTEGER 0C25 73,74,89,90,100,101,110,111,116,117,118,132,133,135,136,144,145^: IDATA INTEGER 021A 8,14,37,38,42,45,46,47,191 :$ IMTH INTEGER 0C16 30,31$" INDEX INTEGER 0C1D 50 "$ IRTN INTEGER 0C29 95,96$* ISFX INTEGER 0C34 145,146,147*‚ ISTAT INTEGER 0C1B 38,40,47,48,50,51,54,57,59,61,65,66,67,69,70,86,87,88,121,124,125,156,158,159,163,164,167,168,170, ‚N 171,174,175,191,193,195,197,199,200,201,202,205N$ IYR INTEGER 0C18 31,32$& J INTEGER 0C3A 202,204&2 K INTEGER 0C35 147,148,149,150,1512$ KEY INTEGER 0C1E 67,86$D LU INTEGER 0C0F 28,61,81,106,112,188,191,193,195,197 D" MODE INTEGER 0C10 28 "0 MTMSG INTEGER 0B8A 8,18,78,79,80,81 0$ NEDATL INTEGER 000C 8,53 $$ NEDATM INTEGER 000B 7,52 $2 NFMSG INTEGER 0B6A 8,21,72,98,123,188 20 NMTMSG INTEGER 0BF3 8,23,103,105,106 0" NPORT INTEGER 0C11 28 "$ NX INTEGER 0C0E 19,84$& OK INTEGER 0B52 8,19,82&0 OLDTP INTEGER 0B87 8,73,77,85,89,1100( PRNO INTEGER 0BC6 8,25,128 (( PRYES INTEGER 0BC4 8,25,180 (& Q8QX1 INTEGER 0004 34,185 &2 RD INTEGER 0B54 8,19,92,93,119,137 2F RECBUF INTEGER 022D 8,67,71,73,77,78,79,80,85,86,89,121,129F0 REEL INTEGER 0C01 8,76,103,104,105 0N REQBUF INTEGER 01D2 8,13,38,47,50,67,86,121,156,167,170,199,200,201N, RESLT INTEGER 0BC2 8,128,180,185,> RQACT INTEGER 0BC8 8,71,72,116,121,132,144,152,185>Z RTYPE INTEGER 0B45 8,39,49,58,61,64,68,122,157,162,166,169,173,191,193,195,197Z0 SKP INTEGER 0BE3 8,127,134,139,18300 SUF INTEGER 0BD0 8,140,148,150,1530t FTN 3.3B (OPT = LPC) CHUPD2 PAGE 12 DATE: 08/29/84 TIME: 2126 t6 SW INTEGER 0BE2 8,75,99,108,114,126,1896$ TEMP INTEGER 0B55 8,96 $& TFL INTEGER 0BBE 8,24,98&0 TPACT INTEGER 0615 8,12,116,132,135 0: TREC INTEGER 0615 8,12,96,100,109,144,146,155:& UPRFCB INTEGER 0005 1,8,50 && USER INTEGER 0229 8,28,29&& VOLNAM INTEGER 00A0 1,5,50 &* WRONKY INTEGER 01D0 1,7,164,168*0 ZERO INTEGER 0B46 8,19,106,112,188 0   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " CCSBLK SUBROUTINE 0FBF 185"@ CCSCST SUBROUTINE 0E91 28,73,89,100,110,116,132,135,144 @` CCSMVA SUBROUTINE 0F6D 30,71,72,77,85,98,103,105,109,123,128,129,152,154,155,161,165,180`. CLOSFL SUBROUTINE 0FF1 198,200,201,202." CREATE SUBROUTINE 0D19 56 "& DELETE SUBROUTINE 100A 53,205 &" DISP SUBROUTINE 0DD7 96 "2 FILERR SUBROUTINE 0FD3 59,191,193,195,197 2" FREAD SUBROUTINE 0DCF 95 "" GETFCB SUBROUTINE 0CF3 49 "$ GETS SUBROUTINE 0D36 66,86$" HEXDEC SUBROUTINE 0EE5 149"" ICCSAD INTEGER.FN. 0EDF 148"& LINK INTEGER.FN. 0E8A 102,131&( OPENFL SUBROUTINE 0CBC 37,47,65 (" PGMIN SUBROUTINE 0C3C 26 "" PGMOUT SUBROUTINE 100F 205" Q8QEND INTEGER.FN. 0FBD Q8QINI INTEGER.FN. 0F81 & Q8QX SUBROUTINE 0F8E 34,185 & Q8STP INTEGER.FN. 10A3 * READR SUBROUTINE 0F30 121,163,167*" UPDREC SUBROUTINE 0F52 169"" UTHEAD SUBROUTINE 0C5E 32 "& WRITER SUBROUTINE 0F0C 155,174&. WTREAD SUBROUTINE 0FC4 80,106,112,188 .t FTN 3.3B (OPT = LPC) CHUPD2 PAGE 13 DATE: 08/29/84 TIME: 2126 t   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 40 0CA5 35,37$$ 45 0CCB 40,42$$ 50 0CD4 34,43$$ 70 0CDB 43,45$$ 78 0D0F 54,56$( 80 0D22 59,66,175($ 85 0D2B 59,63$& 100 0D35 66,190 &( 105 0D3B 67,87,90 (, 150 0D81 80,84,107,113,$ 160 0DA6 85,91$$ 200 0DC3 74,92$8 210 0DCA 82,92,95,115,117,130,184 8$ 220 0DD8 95,98$& 230 0E16 102,108&& 240 0E38 111,114&* 300 0E3B 93,108,116 *& 310 0E4F 118,121&& 400 0E89 99,131 && 405 0EAC 134,137&* 410 0EB0 133,136,139*& 420 0EBB 139,143&* 430 0EBD 141,144,182** 440 0EDE 147,160,164*& 445 0F5B 171,178&& 450 0F68 158,177&& 477 0F6C 175,179&6 480 0F80 131,138,145,147,151,1856. 500 0FC3 101,120,124,188.& 510 0FCD 186,189&( 900 0FD2 40,48,191(, 910 0FD9 51,70,88,193 ,& 920 0FDF 125,195&. 930 0FE6 159,168,171,197.8 950 0FEB 61,69,83,192,194,196,198 8& 955 1000 202,204&& 1000 1011 33,207 && 1100 1079 185,208&& 1200 1091 198,209& CHUPD2 0000 1  t FTN 3.3B (OPT = LPC) CLRFIL PAGE 1 DATE: 08/29/84 TIME: 2128 t^ 1 PROGRAM CLRFIL B2800001^^ 1 1 /B28 F CCS CCS 3.0 SL-149B2800002^^ C B2800003^^ C CYBERCREDIT SYSTEM VERSION 3 B2800004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B2800005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B2800006^^ C B2800007^^ C THIS PROGRAM CLEARS DATA FILES USED BY INSTALLATION TEST B2800008^^ C KIT PROCEDURES. IT IS EXECUTED IN THE SYSTEM CONFIGURATOR MENU B2800009^^ C B2800010^^ 2 INTEGER ID(4) B2800011^^ 3 INTEGER TERMIN, BLANKS B2800012^^ 4 INTEGER REQBUF(24), IDATA(12,40), NUMENT B2800013^^ 5 INTEGER F1(12), F2(12), F3(12), F4(12), F5(12), F6(12), B2800014^^ 5 1 F7(12), F8(12), F9(12), F10(12), F11(12), F12(12), B2800015^^ 5 2 F13(12), F14(12), F15(12), F16(12), F17(12), F18(12), B2800016^^ 5 3 F19(12), F20(12), F21(12), F22(12), F23(12), F24(12), B2800017^^ 5 4 F25(12), F26(12), F27(12), F28(12), F29(12), F30(12), B2800018^^ 5 5 F31(12), F32(12), F33(12), F34(12), F35(12), F36(12) B2800019^^ 6 INTEGER F37(12), F38(12), F39(12), F40(12) B2800020^^ 7 EQUIVALENCE ( IDATA(1, 1), F1(1) ) , ( IDATA(1, 2), F2(1) ) , B2800021^^ 7 1 ( IDATA(1, 3), F3(1) ) , ( IDATA(1, 4), F4(1) ) , B2800022^^ 7 2 ( IDATA(1, 5), F5(1) ) , ( IDATA(1, 6), F6(1) ) , B2800023^^ 7 3 ( IDATA(1, 7), F7(1) ) , ( IDATA(1, 8), F8(1) ) , B2800024^^ 7 4 ( IDATA(1, 9), F9(1) ) , ( IDATA(1,10), F10(1) ) , B2800025^^ 7 5 ( IDATA(1,11), F11(1) ) , ( IDATA(1,12), F12(1) ) B2800026^^ 8 EQUIVALENCE ( IDATA(1,13), F13(1) ) , ( IDATA(1,14), F14(1) ) , B2800027^^ 8 1 ( IDATA(1,15), F15(1) ) , ( IDATA(1,16), F16(1) ) , B2800028^^ 8 2 ( IDATA(1,17), F17(1) ) , ( IDATA(1,18), F18(1) ) , B2800029^^ 8 3 ( IDATA(1,19), F19(1) ) , ( IDATA(1,20), F20(1) ) , B2800030^^ 8 4 ( IDATA(1,21), F21(1) ) , ( IDATA(1,22), F22(1) ) , B2800031^^ 8 5 ( IDATA(1,23), F23(1) ) , ( IDATA(1,24), F24(1) ) B2800032^^ 9 EQUIVALENCE ( IDATA(1,25), F25(1) ) , ( IDATA(1,26), F26(1) ) , B2800033^^ 9 1 ( IDATA(1,27), F27(1) ) , ( IDATA(1,28), F28(1) ) , B2800034^^ 9 2 ( IDATA(1,29), F29(1) ) , ( IDATA(1,30), F30(1) ) , B2800035^^ 9 3 ( IDATA(1,31), F31(1) ) , ( IDATA(1,32), F32(1) ) , B2800036^^ 9 4 ( IDATA(1,33), F33(1) ) , ( IDATA(1,34), F34(1) ) , B2800037^^ 9 5 ( IDATA(1,35), F35(1) ) , ( IDATA(1,36), F36(1) ) B2800038^^ 10 EQUIVALENCE ( IDATA(1,37), F37(1) ) , ( IDATA(1,38), F38(1) ) , B2800039^^ 10 1 ( IDATA(1,39), F39(1) ) , ( IDATA(1,40), F40(1) ) B2800040^ ^ 11 DATA TERMIN / '**' / B2800042^^ 12 DATA BLANKS / ' ' / B2800043^t FTN 3.3B (OPT = LPC) CLRFIL PAGE 2 DATE: 08/29/84 TIME: 2128 t^ C**** TABLE OF FILE NAMES/OWNERS TO BE CLEARED - DOUBLE ASTERISK ("**") B2800045^^ C**** IN FIRST TWO CHARACTERS OF FILE NAME INDICATE END OF TABLE. B2800046^^ C**** BLANKS FOR FIRST TWO CHARACTERS OF FILE NAME IS A NULL ENTRY (BY- B2800047^^ C**** PASSED). B2800048^ ^ 13 DATA F1 / 'ACCAGE CCS20 ' / B2800050^^ 14 DATA F2 / 'ACTFIL CCS20 ' / B2800051^^ 15 DATA F3 / 'ACTIVE CCS20 ' / B2800052^^ 16 DATA F4 / 'ACTVERTBCCS20 ' / B2800053^^ 17 DATA F5 / 'ADDACT CCS20 ' / B2800054^^ 18 DATA F6 / 'AGEWRK CCS20 ' / B2800055^^ 19 DATA F7 / 'AVMDESC CCS20 ' / B2800056^^ 20 DATA F8 / 'COLSTATSCCS20 ' / B2800057^^ 21 DATA F9 / 'COSIGNERCCS20 ' / B2800058^^ 22 DATA F10 / 'DAQUE CCS20 ' / B2800059^^ 23 DATA F11 / 'DECTBL CCS20 ' / B2800060^^ 24 DATA F12 / 'DELQMST CCS20 ' / B2800061^^ 25 DATA F13 / 'DLYASSN CCS20 ' / B2800062^^ 26 DATA F14 / 'DLYWRK CCS20 ' / B2800063^^ 27 DATA F15 / 'INACCT CCS20 ' / B2800064^^ 28 DATA F16 / 'LTRDESC CCS20 ' / B2800065^^ 29 DATA F17 / 'LTRFIL CCS20 ' / B2800066^^ 30 DATA F18 / 'NEWS CCS20 ' / B2800067^^ 31 DATA F19 / 'PGEXTR CCS20 ' / B2800068^^ 32 DATA F20 / 'RPTPGM CCS20 ' / B2800069^^ 33 DATA F21 / 'RSWFIL CCS20 ' / B2800070^^ 34 DATA F22 / 'SREQDL CCS20 ' / B2800071^^ 35 DATA F23 / 'SUMHIST CCS20 ' / B2800072^^ 36 DATA F24 / 'TAPEARC CCS20 ' / B2800073^^ 37 DATA F25 / 'TRANFL CCS20 ' / B2800074^^ 38 DATA F26 / 'TRNBCK CCS20 ' / B2800075^^ 39 DATA F27 / 'TRNSFL CCS20 ' / B2800076^^ 40 DATA F28 / 'UPHSTCM CCS20 ' / B2800077^^ 41 DATA F29 / 'UTIFIL CCS20 ' / B2800078^^ 42 DATA F30 / '** ' / B2800079^^ 43 DATA F31 / ' ' / B2800080^^ 44 DATA F32 / ' ' / B2800081^^ 45 DATA F33 / ' ' / B2800082^^ 46 DATA F34 / ' ' / B2800083^^ 47 DATA F35 / ' ' / B2800084^^ 48 DATA F36 / ' ' / B2800085^^ 49 DATA F37 / ' ' / B2800086^^ 50 DATA F38 / ' ' / B2800087^^ 51 DATA F39 / ' ' / B2800088^^ 52 DATA F40 / ' ' / B2800089^ ^ 53 DATA NUMENT / 40 / B2800091^t FTN 3.3B (OPT = LPC) CLRFIL PAGE 3 DATE: 08/29/84 TIME: 2128 t^ C**** RETRIEVE PROGRAM INFORMATION. B2800093^^ 54 50 CALL PGMIN ( ID, LU, MODE, NOPORT ) B2800094^ ^ C**** STARTING WITH FIRST TABLE ENTRY OF IDATA THRU LAST ENTRY DO B2800096^^ 55 100 DO 200 I=1,NUMENT B2800097^^ C** IF ENTRY IS TABLE TERMINATOR, EXIT LOOP AND TERMINATE PROGRAM B2800098^^ 56 IF ( IDATA(1,I) .EQ. TERMIN ) GO TO 300 B2800099^^ C** ELSE, CONTINUE. B2800100^ ^ C** IF FIRST TWO CHARACTERS OF FILE NAME BLANK, CONTINUE WITH NEXTB2800102^^ C** FILE NAME B2800103^^ 57 IF ( IDATA(1,I) .EQ. BLANKS ) GO TO 200 B2800104^^ C** ELSE, ZERO REQUEST BUFFER AND CLEAR SPECIFIED FILE B2800105^^ 58 DO 150 J=1,24 B2800106^^ 59 150 REQBUF(J) = 0 B2800107^^ 60 CALL CLEAR ( REQBUF, IDATA(1,I), ISTAT ) B2800108^^ C** IF NO ERROR, CONTINUE B2800109^^ 61 IF ( ISTAT .GE. 0 ) GO TO 200 B2800110^^ C** ELSE, REPORT ERROR B2800111^^ 62 CALL FILERR ( IDATA(1,I), 1, ISTAT, LU ) B2800112^^ C** EXIT LOOP AND TERMINATE PROGRAM B2800113^^ 63 GO TO 300 B2800114^^ C** CONTINUE LOOP. B2800115^^ 64 200 CONTINUE B2800116^   ^ C**** EXIT, NORMAL AND ERROR. B2800118^^ 65 300 CALL PGMOUT B2800119^^ 66 END B2800120^t FTN 3.3B (OPT = LPC) CLRFIL PAGE 4 DATE: 08/29/84 TIME: 2128 t  PROGRAM LENGTH $0253 ( 595)   EXTERNALS & Q8STP PGMIN CLEAR FILERR PGMOUT & t FTN 3.3B (OPT = LPC) CLRFIL PAGE 5 DATE: 08/29/84 TIME: 2128 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < : 0001 (1) 0002 7,8,9,10,55,56,57,58,60,62 :   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < & BLANKS INTEGER 0008 1,12,57&& F1 INTEGER 0021 1,7,13 && F10 INTEGER 008D 1,7,22 && F11 INTEGER 0099 1,7,23 && F12 INTEGER 00A5 1,7,24 && F13 INTEGER 00B1 1,8,25 && F14 INTEGER 00BD 1,8,26 && F15 INTEGER 00C9 1,8,27 && F16 INTEGER 00D5 1,8,28 && F17 INTEGER 00E1 1,8,29 && F18 INTEGER 00ED 1,8,30 && F19 INTEGER 00F9 1,8,31 && F2 INTEGER 002D 1,7,14 && F20 INTEGER 0105 1,8,32 && F21 INTEGER 0111 1,8,33 && F22 INTEGER 011D 1,8,34 && F23 INTEGER 0129 1,8,35 && F24 INTEGER 0135 1,8,36 && F25 INTEGER 0141 1,9,37 && F26 INTEGER 014D 1,9,38 && F27 INTEGER 0159 1,9,39 && F28 INTEGER 0165 1,9,40 && F29 INTEGER 0171 1,9,41 && F3 INTEGER 0039 1,7,15 && F30 INTEGER 017D 1,9,42 && F31 INTEGER 0189 1,9,43 && F32 INTEGER 0195 1,9,44 && F33 INTEGER 01A1 1,9,45 && F34 INTEGER 01AD 1,9,46 && F35 INTEGER 01B9 1,9,47 && F36 INTEGER 01C5 1,9,48 && F37 INTEGER 01D1 1,10,49&& F38 INTEGER 01DD 1,10,50&& F39 INTEGER 01E9 1,10,51&& F4 INTEGER 0045 1,7,16 && F40 INTEGER 01F5 1,10,52&& F5 INTEGER 0051 1,7,17 && F6 INTEGER 005D 1,7,18 &t FTN 3.3B (OPT = LPC) CLRFIL PAGE 6 DATE: 08/29/84 TIME: 2128 t& F7 INTEGER 0069 1,7,19 && F8 INTEGER 0075 1,7,20 && F9 INTEGER 0081 1,7,21 &. I INTEGER 0205 54,56,57,60,62 .$ ID INTEGER 0003 1,54 $6 IDATA INTEGER 0021 1,7,8,9,10,56,57,60,62 6( ISTAT INTEGER 0207 60,61,62 ($ J INTEGER 0206 57,59$$ LU INTEGER 0202 54,62$" MODE INTEGER 0203 54 "" NOPORT INTEGER 0204 54 "& NUMENT INTEGER 0201 1,53,55&& REQBUF INTEGER 0009 1,59,60&& TERMIN INTEGER 0007 1,11,56&   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " CLEAR SUBROUTINE 0239 59 "" FILERR SUBROUTINE 0246 61 "" PGMIN SUBROUTINE 0209 53 "" PGMOUT SUBROUTINE 0250 65 " Q8STP INTEGER.FN. 0252    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < " 50 0208 53 "" 100 020E 54 "$ 150 022B 57,59$* 200 024D 54,57,61,64*( 300 024F 56,63,65 ( CLRFIL 0000 1 t FTN 3.3B (OPT = LPC) CMPDLQ PAGE 1 DATE: 08/29/84 TIME: 2128 t^ 1 PROGRAM CMPDLQ B2900001^^ 1 1 /B29 F CCS CCS 3.0 SL-149B2900002^^ C B2900003^^ C CYBERCREDIT SYSTEM VERSION 3 B2900004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B2900005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B2900006^^ C B2900007^^ C B2900008^ ^ C COPYRIGTH CONTROL DATA CORPORATION, 1978 B2900010^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B2900011^^ C CREDIT COLLECTION SYSTEM VERSION 2.0 B2900012^ ^ C THIS PROGRAM PERFORMS A FILE COMPRESSION ON THE B2900014^^ C DELQMST FILE. THIS REMOVES ALL DELETED RECORDS B2900015^^ C THEREBY FREEING FILE SPACE. B2900016^ ^ 2 INTEGER USER(4),IDATA(15),REQBUF(24),RECBUF(2004) B2900018^ ^ 3 DATA REQBUF / 24*0 / B2900020^^ 4 DATA IDATA / 'DELQMST ', 8*$2020, -1, 1, 0 / B2900021^ ^ C ITOS LOGON B2900023^^ 5 CALL PGMIN ( USER, LU, MODE, NPORT ) B2900024^ ^ C OPEN DELQMST B2900026^^ 6 CALL OPENFL ( REQBUF, IDATA, ISTAT ) B2900027^^ 7 IF ( ISTAT .GE. 0 ) GO TO 100 B2900028^^ C ERROR ON OPEN B2900029^^ 8 CALL FILERR ( IDATA, 3, ISTAT, LU ) B2900030^^ 9 CALL PGMOUT B2900031^ ^ C PERFORM THE COMPRESSION B2900033^^ 10 100 CALL COMFIL ( REQBUF, RECBUF, ISTAT ) B2900034^^ 11 IF ( AND($100,ISTAT) .EQ. $100 ) GO TO 200 B2900035^^ 12 IF ( ISTAT .GE. 0 ) GO TO 100 B2900036^^ C ERROR ON COMPRESS B2900037^^ 13 CALL FILERR ( IDATA, 17, ISTAT, LU ) B2900038^^ C CLOSE DELQMST AND EXIT B2900039^^ 14 200 CALL CLOSFL ( REQBUF, ISTAT ) B2900040^^ 15 CALL PGMOUT B2900041^^ 16 END B2900042^t FTN 3.3B (OPT = LPC) CMPDLQ PAGE 2 DATE: 08/29/84 TIME: 2128 t  PROGRAM LENGTH $0837 ( 2103)   EXTERNALS 2 Q8STP PGMIN OPENFL FILERR PGMOUT COMFIL CLOSFL 2 t FTN 3.3B (OPT = LPC) CMPDLQ PAGE 3 DATE: 08/29/84 TIME: 2128 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : <  0003 (3) 0805 8 " 0011 (17) 0807 13 "$ 0100 (256) 0806 11,11$   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " AND INTR.FN. 7FFF 11 "* IDATA INTEGER 0006 1,4,6,8,13 *4 ISTAT INTEGER 0804 6,7,8,10,11,12,13,14 4& LU INTEGER 0801 5,8,13 & MODE INTEGER 0802 5 NPORT INTEGER 0803 5 $ RECBUF INTEGER 002D 1,10 $* REQBUF INTEGER 0015 1,3,6,10,14*" USER INTEGER 0002 1,5"   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " CLOSFL SUBROUTINE 0831 14 "" COMFIL SUBROUTINE 081F 10 "$ FILERR SUBROUTINE 0817 7,13 $ OPENFL SUBROUTINE 080F 5 PGMIN SUBROUTINE 0809 4 $ PGMOUT SUBROUTINE 081D 8,15 $ Q8STP INTEGER.FN. 0836    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < & 100 081E 7,10,12&$ 200 0830 11,14$ CMPDLQ 0000 1  t FTN 3.3B (OPT = LPC) CMPSUM PAGE 1 DATE: 08/29/84 TIME: 2128 t^ 1 PROGRAM CMPSUM B3000001^^ 1 1 /B30 F CCS CCS 3.0 SL-149B3000002^ ^ C CYBERCREDIT SYSTEM VERSION 3 B3000004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B3000005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B3000006^ ^ C THIS PROGRAM PERFORMS A FILE COMPRESSION ON THE B3000008^^ C SUMHIST FILE. B3000009^ ^ 2 INTEGER USER(4),IDATA(15),REQBUF(24),RECBUF(1000) B3000011^^ 3 DATA REQBUF / 24*0 / B3000012^^ 4 DATA IDATA / 'SUMHIST ',8*$2020,-1,1,0 / B3000013^ ^ 5 CALL PGMIN ( USER, LU, MODE, NPORT ) B3000015^^ 6 CALL OPENFL ( REQBUF, IDATA, ISTAT ) B3000016^^ 7 IF ( ISTAT .GE. 0 ) GO TO 100 B3000017^^ 8 CALL FILERR ( IDATA, 3, ISTAT, LU ) B3000018^^ 9 CALL PGMOUT B3000019^^ 10 100 CALL COMFIL ( REQBUF, RECBUF, ISTAT ) B3000020^^ 11 IF ( AND(ISTAT,$100) .EQ. $100 ) GO TO 200 B3000021^^ 12 IF ( ISTAT .GE. 0 ) GO TO 100 B3000022^^ 13 CALL FILERR ( IDATA, 17, ISTAT, LU ) B3000023^^ 14 200 CALL CLOSFL ( REQBUF, ISTAT ) B3000024^^ 15 CALL PGMOUT B3000025^^ 16 END B3000026^t FTN 3.3B (OPT = LPC) CMPSUM PAGE 2 DATE: 08/29/84 TIME: 2128 t  PROGRAM LENGTH $044B ( 1099)   EXTERNALS 2 Q8STP PGMIN OPENFL FILERR PGMOUT COMFIL CLOSFL 2 t FTN 3.3B (OPT = LPC) CMPSUM PAGE 3 DATE: 08/29/84 TIME: 2128 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : <  0003 (3) 0419 8 " 0011 (17) 041B 13 "$ 0100 (256) 041A 11,11$   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " AND INTR.FN. 7FFF 11 "* IDATA INTEGER 0006 1,4,6,8,13 *4 ISTAT INTEGER 0418 6,7,8,10,11,12,13,14 4& LU INTEGER 0415 5,8,13 & MODE INTEGER 0416 5 NPORT INTEGER 0417 5 $ RECBUF INTEGER 002D 1,10 $* REQBUF INTEGER 0015 1,3,6,10,14*" USER INTEGER 0002 1,5"   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " CLOSFL SUBROUTINE 0445 14 "" COMFIL SUBROUTINE 0433 10 "$ FILERR SUBROUTINE 042B 7,13 $ OPENFL SUBROUTINE 0423 5 PGMIN SUBROUTINE 041D 4 $ PGMOUT SUBROUTINE 0431 8,15 $ Q8STP INTEGER.FN. 044A    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < & 100 0432 7,10,12&$ 200 0444 11,14$ CMPSUM 0000 1  t FTN 3.3B (OPT = LPC) CPYIND PAGE 1 DATE: 08/29/84 TIME: 2128 t^ 1 PROGRAM CPYIND B3400001^^ 1 1 /B34 F CCS CCS 3.0 PSR'D SL-149********^^ C B3400003^^ C CYBERCREDIT SYSTEM VERSION 3 B3400004^^ C DATA SYSTEM - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B3400005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B3400006^^ C B3400007^^ C THIS PROGRAM COPIES AN INDEX FILE INTO ANOTHER INDEX FILE. B3400008^^ C THE MAXIMUM CHARACTERS TO BE COPIED IS 2000. BOTH FILES B3400009^^ C MUST BE INDEXED AND HAVE THE SAME FILE DESCRIPTION. B3400010^^ C B3400011^^ C B3400012^ ^ 2 INTEGER EOF,FCBI(96),FCBO(96),FMRDEL,FDEL B3400014^^ 3 INTEGER IDUSER(4),IBUF(5) B3400015^^ 4 INTEGER IDATA(15),INBUF(24),INREC(5002),KEY(50) B3400016^^ 5 INTEGER MSG1(17),MSG2(14),MSG3(8),MSG4(12),MSG5(7) B3400017^^ 6 INTEGER MSG10(19),MSG11(16),MSG12(17) B3400018^^ 7 INTEGER ODATA(15),OUTBUF(24),OUTREC(1002) B3400019^^ 8 INTEGER RECLEN,ZERO B3400020^ ^ 9 DATA EOF/0/,ICNT/0/,ZERO/0/ B3400022^^ 10 DATA INBUF/24*0/,OUTBUF/24*0/ B3400023^ ^ 11 DATA IDATA/12*$2020,0,5,0/ B3400025^^ 12 DATA ODATA/12*$2020,0,1,-1/ B3400026^ ^ 13 DATA MSG1/$1800,'INDEX FILE COPY (MAX 2000 BYTES)'/ B3400028^^ 14 DATA MSG2/$0A0D,$0A0D,'FILE NAME TO COPY FROM '/ B3400029^^ 15 DATA MSG3/$0A0D,'VOLUME NAME '/ B3400030^^ 16 DATA MSG4/$0A0D,'FILE NAME TO COPY TO '/ B3400031^^ 17 DATA MSG5/$0A0D,'OWNER NAME '/ B3400032^^ 18 DATA MSG10/$0A0D,$0A0D,'XXXXXXXX FILE COULD NOT BE LOCATED'/ B3400033^^ 19 DATA MSG11/$0A0D,$0A0D,'XXXXXXXX FILE NOT INDEX FILE'/ B3400034^^ 20 DATA MSG12/$0A0D,$0A0D,'FILE DESCRIPTION NOT THE SAME '/ B3400035^ ^ 21 EXTERNAL FMRDEL B3400037^ ^ 22 CALL PGMIN(IDUSER,LUNIT,MODE,NOPORT) B3400039^^ 23 ASSEM $C000,FMRDEL,$6800,FDEL B3400040^ ^ C GET FILE INFO FROM USER B3400042^^ 24 CALL WTREAD(LUNIT,-1,MSG1,34,-1,IBUF,0,ITC) B3400043^ ^ C GET FILE NAME 1 B3400045^^ 25 100 CALL CCSBLK(IBUF,8) B3400046^^ 26 CALL WTREAD(LUNIT,-1,MSG2,28,-1,IBUF,8,ITC) B3400047^^ 27 IF(IBUF.EQ.$2020) GO TO 100 B3400048^^ 28 CALL CCSMVA(IBUF,1,8,IDATA,1,8) B3400049^ ^ C GET VOLUME NAME 1 B3400051^^ 29 110 CALL CCSBLK(IBUF,8) B3400052^^ 30 CALL WTREAD(LUNIT,-1,MSG3,16,-1,IBUF,8,ITC) B3400053^^ 31 CALL CCSMVA(IBUF,1,8,IDATA,17,8) B3400054^t FTN 3.3B (OPT = LPC) CPYIND PAGE 2 DATE: 08/29/84 TIME: 2128 t ^ C GET OWNER NAME 1 B3400056^^ 32 120 CALL CCSBLK(IBUF,8) B3400057^^ 33 CALL WTREAD(LUNIT,-1,MSG5,14,-1,IBUF,8,ITC) B3400058^^ 34 CALL CCSMVA(IBUF,1,8,IDATA,9,8) B3400059^ ^ C GET FILE NAME 2 B3400061^^ 35 130 CALL CCSBLK(IBUF,8) B3400062^^ 36 CALL WTREAD(LUNIT,-1,MSG4,24,-1,IBUF,8,ITC) B3400063^^ 37 IF(IBUF(1).EQ.$2020) GO TO 130 B3400064^^ 38 CALL CCSMVA(IBUF,1,8,ODATA,1,8) B3400065^ ^ C GET VOLUME NAME 2 B3400067^^ 39 140 CALL CCSBLK(IBUF,8) B3400068^^ 40 CALL WTREAD(LUNIT,-1,MSG3,16,-1,IBUF,8,ITC) B3400069^^ 41 CALL CCSMVA(IBUF,1,8,ODATA,17,8) B3400070^ ^ C GET OWNER NAME 2 B3400072^^ 42 150 CALL CCSBLK(IBUF,8) B3400073^^ 43 CALL WTREAD(LUNIT,-1,MSG5,14,-1,IBUF,8,ITC) B3400074^^ 44 CALL CCSMVA(IBUF,1,8,ODATA,9,8) B3400075^ ^ C OPEN INPUT FILE B3400077^^ 45 200 CALL OPENFL(INBUF,IDATA,ISTAT) B3400078^^ 46 IF(AND(ISTAT,$8002).EQ.$8002) GO TO 320 B3400079^^ 47 IF(ISTAT.GE.0) GO TO 205 B3400080^^ 48 CALL FILERR(IDATA,3,ISTAT,LUNIT) B3400081^^ 49 GO TO 990 B3400082^ ^ C CLEAR THE OUTPUT FILE B3400084^^ 50 205 CALL CLEAR(OUTBUF,ODATA,ISTAT) B3400085^^ 51 IF(AND(ISTAT,$8002).EQ.$8002) GO TO 340 B3400086^^ 52 IF(ISTAT.GE.0) GO TO 210 B3400087^^ 53 CALL FILERR(ODATA,1,ISTAT,LUNIT) B3400088^^ 54 GO TO 990 B3400089^ ^ C OPEN OUTPUT FILE B3400091^^ 55 210 CALL OPENFL(OUTBUF,ODATA,ISTAT) B3400092^^ 56 IF(AND(ISTAT,$8002).EQ.$8002) GO TO 340 B3400093^^ 57 IF(ISTAT.GE.0) GO TO 220 B3400094^^ 58 CALL FILERR(ODATA,3,ISTAT,LUNIT) B3400095^^ 59 GO TO 990 B3400096^ ^ C CHECK SEE IF FILES ARE INDEX FILES B3400098^^ 60 220 CALL GETFCB(INBUF,ZERO,0,FCBI,ISTAT) B3400099^^ 61 IF(ISTAT.GE.0) GO TO 230 B3400100^^ 62 CALL FILERR(IDATA,7,ISTAT,LUNIT) B3400101^^ 63 GO TO 950 B3400102^^ 64 230 CALL GETFCB(OUTBUF,ZERO,0,FCBO,ISTAT) B3400103^^ 65 IF(ISTAT.GE.0) GO TO 235 B3400104^^ 66 CALL FILERR(ODATA,7,ISTAT,LUNIT) B3400105^^ 67 GO TO 950 B3400106^ ^ C CHECK FCB'S FOR EQUIVLENCE B3400108^t FTN 3.3B (OPT = LPC) CPYIND PAGE 3 DATE: 08/29/84 TIME: 2128 t^ 68 235 IF(FCBI(1).NE.FCBO(1)) GO TO 400 B3400109^^ 69 IF(FCBI(6).NE.FCBO(6)) GO TO 400 B3400110^^ 70 DO 236 II=15,22 B3400111^^ 71 IF(FCBI(II).NE.FCBO(II)) GO TO 400 B3400112^^ 72 236 CONTINUE B3400113^ ^ 73 RECLEN=FCBI(1)*2 B3400115^ ^ C READ THE INPUT FILE B3400117^^ 74 240 CALL CCSBLK(INREC,10000) B3400118^^ 75 CALL GETS(INBUF,INREC,INREC,ISTAT) B3400119^^ 76 IF(AND(ISTAT,$8100).EQ.$8100) GO TO 950 B3400120^^ 77 IF(AND(ISTAT,$100).EQ.$100) GO TO 250 B3400121^^ 78 IF(ISTAT.GE.0) GO TO 260 B3400122^^ 79 CALL FILERR(IDATA,13,ISTAT,LUNIT) B3400123^^ 80 GO TO 950 B3400124^^ 81 250 EOF=1 B3400125^ ^ C WRITE THE RECORD TO THE OUTPUT FILE B3400127^^ 82 260 NREC=INBUF(15) B3400128^^ 83 265 DO 300 I=1,NREC B3400129^^ 84 JW= FCBI(1) * (I-1) + 1 B3400130^^ 85 JB=(FCBI(1) * 2) * (I-1) B3400131^^ C ****************************************************** ???*A019********^^ C IGNORE DELETED RECORDS. ********^^ 86 IF (INREC(JW) .EQ. FDEL ) GO TO 300 ********^^ C ****************************************************** ???*A019********^ ^ C SET UP THE KEY B3400133^^ 87 270 CALL CCSBLK(KEY,100) B3400134^^ 88 CALL CCSMVA(INREC,FCBI(16)+JB,FCBI(15),KEY,1,FCBI(15)) B3400135^ ^ C SET UP OUTPUT RECORD B3400137^^ 89 280 CALL CCSMVA(INREC,JB+1,RECLEN,OUTREC,1,RECLEN) B3400138^^ 90 CALL WRITER(OUTBUF,OUTREC,KEY,ISTAT) B3400139^^ 91 IF(ISTAT.GE.0) GO TO 290 B3400140^^ 92 CALL FILERR(ODATA,12,ISTAT,LUNIT) B3400141^^ 93 GO TO 950 B3400142^ ^ C RECORD COUNT B3400144^^ 94 290 ICNT=ICNT+1 B3400145^^ 95 300 CONTINUE B3400146^ ^ 96 IF(EOF.EQ.1) GO TO 950 B3400148^^ 97 GO TO 240 B3400149^ ^ C ERROR MESSAGES B3400151^^ 98 320 CALL CCSMVA(IDATA,1,8,MSG10,5,8) B3400152^^ 99 CALL WTREAD(LUNIT,-1,MSG10,38,-1,IBUF,0,ITC) B3400153^^ 100 GO TO 950 B3400154^^ 101 340 CALL CCSMVA(ODATA,1,8,MSG10,5,8) B3400155^^ 102 CALL WTREAD(LUNIT,-1,MSG10,38,-1,IBUF,0,ITC) B3400156^^ 103 GO TO 950 B3400157^^ 104 360 CALL CCSMVA(IDATA,1,8,MSG11,5,8) B3400158^t FTN 3.3B (OPT = LPC) CPYIND PAGE 4 DATE: 08/29/84 TIME: 2128 t^ 105 CALL WTREAD(LUNIT,-1,MSG11,32,-1,IBUF,0,ITC) B3400159^^ 106 GO TO 950 B3400160^^ 107 380 CALL CCSMVA(ODATA,1,8,MSG11,5,8) B3400161^^ 108 CALL WTREAD(LUNIT,-1,MSG11,32,-1,IBUF,0,ITC) B3400162^^ 109 GO TO 950 B3400163^^ 110 400 CALL WTREAD(LUNIT,-1,MSG12,34,-1,IBUF,0,ITC) B3400164^^ 111 GO TO 950 B3400165^ ^ C CLOSE THE FILES B3400167^^ 112 950 CALL CLOSFL(INBUF,ISTAT) B3400168^^ 113 CALL CLOSFL(OUTBUF,ISTAT) B3400169^ ^ 114 990 CALL PGMOUT B3400171^^ 115 STOP B3400172^^ 116 END B3400173^t FTN 3.3B (OPT = LPC) CPYIND PAGE 5 DATE: 08/29/84 TIME: 2128 t  PROGRAM LENGTH $1B3E ( 6974)   EXTERNALS 2 Q8STP FMRDEL PGMIN WTREAD CCSBLK CCSMVA OPENFL 22 FILERR CLEAR GETFCB GETS WRITER CLOSFL PGMOUT 2 t FTN 3.3B (OPT = LPC) CPYIND PAGE 6 DATE: 08/29/84 TIME: 2128 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < * 8002 (-32765) 1943 46,46,51,56*$ 8100 (-32511) 1948 76,76$J FFFE (-1) 1937 24,24,26,30,33,36,40,43,99,102,105,108,110 JZ 0000 (0) 0003 9,10,11,12,24,47,52,57,60,61,64,65,78,91,99,102,105,108,110Z€ 0001 (1) 0002 12,24,26,28,30,31,33,34,36,37,38,40,41,43,44,53,68,73,81,83,84,85,88,89,94,96,98,99,101,102,104, €. 105,107,108,110.$ 0003 (3) 1944 48,58$. 0005 (5) 1951 98,101,104,107 .$ 0007 (7) 1945 62,66$d 0008 (8) 193A 25,26,28,29,30,31,32,33,34,35,36,38,39,40,41,42,43,44,98,101,104,107 d$ 0009 (9) 1940 34,44$" 000C (12) 1950 92 "" 000D (13) 194A 79 "$ 000E (14) 193F 33,43$( 0010 (16) 193D 30,40,88 ($ 0011 (17) 193E 31,41$" 0018 (24) 1941 36 "" 001C (28) 193B 26 "& 0020 (32) 1953 105,108&& 0022 (34) 1938 24,110 && 0026 (38) 1952 99,102 &" 0064 (100) 194F 87 "$ 0100 (256) 1949 77,77$$ 2020 (8224) 193C 27,37$" 2710 (10000) 1947 74 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < . AND INTR.FN. 7FFF 46,51,56,76,77 .( EOF INTEGER 0004 1,9,81,96(8 FCBI INTEGER 0005 1,60,68,69,71,73,84,85,888, FCBO INTEGER 0065 1,64,68,69,71,& FDEL INTEGER 00C5 1,23,86&( I INTEGER 194C 82,84,85 (r IBUF INTEGER 00CA 1,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,99,102,105,108,110r$ ICNT INTEGER 1933 9,94 $@ IDATA INTEGER 00CF 1,11,28,31,34,45,48,62,79,98,104 @$ IDUSER INTEGER 00C6 1,22 $$ II INTEGER 1946 69,71$4 INBUF INTEGER 00DE 1,10,45,60,75,82,112 40 INREC INTEGER 00F6 1,74,75,86,88,89 0t ISTAT INTEGER 1942 45,46,47,48,50,51,52,53,55,56,57,58,60,61,62,64,65,66,75,76,77,78,79,90,91,92,112,113tt FTN 3.3B (OPT = LPC) CPYIND PAGE 7 DATE: 08/29/84 TIME: 2128 tF ITC INTEGER 1939 24,26,30,33,36,40,43,99,102,105,108,110F* JB INTEGER 194E 84,85,88,89*( JW INTEGER 194D 83,84,86 (* KEY INTEGER 1480 1,87,88,90 *^ LUNIT INTEGER 1934 22,24,26,30,33,36,40,43,48,53,58,62,66,79,92,99,102,105,108,110^" MODE INTEGER 1935 22 "& MSG1 INTEGER 14B2 1,13,24&2 MSG10 INTEGER 14EC 1,18,98,99,101,102 24 MSG11 INTEGER 14FF 1,19,104,105,107,108 4( MSG12 INTEGER 150F 1,20,110 (& MSG2 INTEGER 14C3 1,14,26&* MSG3 INTEGER 14D1 1,15,30,40 *& MSG4 INTEGER 14D9 1,16,36&* MSG5 INTEGER 14E5 1,17,33,43 *" NOPORT INTEGER 1936 22 "( NREC INTEGER 194B 82,82,83 (F ODATA INTEGER 1520 1,12,38,41,44,50,53,55,58,66,92,101,107F4 OUTBUF INTEGER 152F 1,10,50,55,64,90,113 4& OUTREC INTEGER 1547 1,89,90&& RECLEN INTEGER 1931 1,73,89&( ZERO INTEGER 1932 1,9,60,64(   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < 6 CCSBLK SUBROUTINE 1A6D 24,29,32,35,39,42,74,876F CCSMVA SUBROUTINE 1AB9 27,31,34,38,41,44,88,89,98,101,104,107 F" CLEAR SUBROUTINE 19FE 50 "& CLOSFL SUBROUTINE 1B34 112,113&4 FILERR SUBROUTINE 1A87 47,53,58,62,66,79,92 4$ GETFCB SUBROUTINE 1A27 60,64$" GETS SUBROUTINE 1A71 74 "$ OPENFL SUBROUTINE 19E6 44,55$" PGMIN SUBROUTINE 1955 21 "" PGMOUT SUBROUTINE 1B3B 114" Q8STP INTEGER.FN. 1B3D " WRITER SUBROUTINE 1ACB 89 "F WTREAD SUBROUTINE 1AEC 23,26,30,33,36,40,43,99,102,105,108,110F   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 100 1968 24,27$" 110 1982 28 "" 120 1995 31 "$ 130 19A8 34,37$" 140 19BF 38 "" 150 19D2 41 "t FTN 3.3B (OPT = LPC) CPYIND PAGE 8 DATE: 08/29/84 TIME: 2128 t" 200 19E5 44 "$ 205 19FD 47,50$$ 210 1A12 52,55$$ 220 1A26 57,60$$ 230 1A37 61,64$$ 235 1A47 65,68$$ 236 1A63 69,72$$ 240 1A6C 73,97$$ 250 1A8E 77,81$$ 260 1A90 78,82$" 265 1A94 82 "" 270 1AB1 86 "" 280 1AC0 88 "$ 290 1ADA 91,94$( 300 1ADC 82,86,95 ($ 320 1AE4 46,98$( 340 1AF6 51,56,101(" 360 1B07 103"" 380 1B18 106", 400 1B29 68,69,71,110 ,H 950 1B33 62,67,76,80,93,96,100,103,106,109,111,112H, 990 1B3A 48,54,59,114 , CPYIND 0000 1 t FTN 3.3B (OPT = LPC) DACRTE PAGE 1 DATE: 08/29/84 TIME: 2129 t^ 1 PROGRAM DACRTE 00001^^ 1 1 /B36 F CCS CCS 3.1 CCS07 01/84 SL-149 00002^^ C 00003^^ C CYBERCREDIT SYSTEM VERSION 3 00004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA 00005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 00006^^ C 00007^ ^ C THIS PROGRAM REASSIGNS QUEUES AND PRIORITIES FOR ALL ACTIVE 00009^^ C ACCOUNTS IN THE DELQMST FILE AND CREATES THE DLYASSN FILE 00010^^ C WHICH IS USED BY THE ON-LINE AUTOMATIC FUNCTION 00011^ ^ 2 INTEGER DEQREQ(24),ASNREQ(24),DDATA(15),ADATA(15),ST,EFG,DT(3), 00013^^ 2 2 USER(4),HD(3,20),PRI(3,9),QUE(3,9),NQUE(2),NPRI(2),FDEL, 00014^^ 2 3 DEQREC(23000),ASNREC(462),QUEP(9),QUEL(9),PRIP(9),PRIL(9), 00015^^ 2 4 STG(40),LTHACT(2),NUMRD,ASCDAY(3),Q,P 00016^^ 3 EQUIVALENCE( DEQREQ(15),NUMRD ) 00017^ ^ 4 EXTERNAL FMRDEL 00019^ ^ 5 DATA DEQREQ, ASNREQ / 48*0 / 00021^^ 6 DATA DDATA / 'DELQMST ', 8*$2020, 0, 0, 0 / 00022^^ 7 DATA ADATA / 'DLYASSN ', 8*$2020, 0, 1, 0 / 00023^^ C************************************************************** 173*A032 00024^^ C VARIABLE FOR PP DATE CHECKING 00025^^ 8 INTEGER PPDATE(3) 00026^^ C VARIABLES FOR READING UTIFIL 00027^^ 9 INTEGER UDATA(15),UTIREQ(24),UTIREC(40),OLPM(2),PPLAG 00028^^ 10 DATA UDATA/'UTIFIL ',8*$2020,1,1,0/ 00029^^ 11 DATA UTIREQ/24*0/,OLPM/'OLPM'/ 00030^^ C************************************************************** 173*A032 00031^^ 12 DATA NUMREC / 23 /, ST / 0 /, EFG / 0 /, LTHACT / '0360' / 00032^^ 13 DATA QUE, PRI / 54*$2020 / 00033^t FTN 3.3B (OPT = LPC) DACRTE PAGE 2 DATE: 08/29/84 TIME: 2129 t^ C**** SET UP THE DELQMST STARTING CHARACTER POSITIONS FOR THE 00035^^ C QUEUE ASSIGNMENT PARAMETERS, IF NOT USED MUST BE ZERO (0) 00036^ ^ C P-1 P-2 P-3 P-4 P-5 P-6 P-7 P-8 P-9 00038^^ 14 DATA QUEP / 0, 0, 0, 0, 0, 0, 0, 0, 0 / 00039^ ^ C**** SET UP THE DELQMST PARAMETER LENGTH IN CHARACTERS MAX. = 6 00041^^ C IF UNUSED MUST BE ZERO (0) 00042^ ^ C P-1 P-2 P-3 P-4 P-5 P-6 P-7 P-8 P-9 00044^^ 15 DATA QUEL / 0, 0, 0, 0, 0, 0, 0, 0, 0 / 00045^  ^ C**** SET UP THE STARTING CHARACTER POSITIONS IN DELQMST FILE FOR 00047^^ C THE PRIORITY ASSIGNMENT PARAMETERS, IF UNSED MUST BE ZERO (0) 00048^ ^ C P-1 P-2 P-3 P-4 P-5 P-6 P-7 P-8 P-9 00050^^ 16 DATA PRIP / 0, 0, 0, 0, 0, 0, 0, 0, 0 / 00051^ ^ C**** SET UP THE PRIORITY PARAMETER CHARACTER LENGTHS MAX. = 6 00053^^ C IF UNUSED MUST BE ZERO (0) 00054^ ^ C P-1 P-2 P-3 P-4 P-5 P-6 P-7 P-8 P-9 00056^^ 17 DATA PRIL / 0, 0, 0, 0, 0, 0, 0, 0, 0 / 00057^ ^ C**** SET UP THE STARTING CHARACTER POSITIONS FOR THE MOST RECENT 00059^^ C PAYMENT AMOUNT AND PAYMENT DATE, USED FOR BROKEN PP'S 00060^ ^ 18 DATA LDATE / 0 / , LAMT / 0 / ,Q/$51/,P/$50/ 00062^t FTN 3.3B (OPT = LPC) DACRTE PAGE 3 DATE: 08/29/84 TIME: 2129 t^ C ACCEPT LOGIN FROM ITOS 00064^^ 19 CALL PGMIN ( USER, LU, MODE, NPORT ) 00065^ ^ C INITIALIZE VARIABLES 00067^^ 20 ASSEM $C000,FMRDEL,$6800,FDEL 00068^^ 21 IOSW = $3030 00069^^ 22 CALL UTHEAD ( HD, DT ) 00070^^ 23 DDATA(14) = NUMREC 00071^^ 24 M = 1 00072^  ^ C OPEN FILES FOR USE 00074^^ C************************************************************** 173*A032 00075^^ 25 CALL OPENFL(UTIREQ,UDATA,ISTAT) 00076^^ C CHECK FOR ERROR 00077^^ 26 IF(ISTAT.GE.0) GO TO 10 00078^^ 27 CALL FILERR(UDATA,3,ISTAT,LU) 00079^^ 28 GO TO 900 00080^^ C NO ERROR-RETRIEVE OLPM RECORD TO GET DELTA FACTOR FOR PP DATE PROC 00081^^ 29 10 CALL READR(UTIREQ,UTIREC,OLPM,ISTAT) 00082^^ C BE SURE CORRECT RECORD READ 00083^^ 30 IF(AND(ISTAT,$0200).EQ.$0200.OR.AND(ISTAT,$8100).EQ.$8100) 00084^^ 30 . GO TO 20 00085^^ C RECORD WAS FOUND-CK FOR OTHER ERROR 00086^^ 31 IF(ISTAT.LT.0) GO TO 20 00087^^ C RECORD FOUND - EVERYTHING OKAY SAVE LAG FACTOR 00088^^ 32 PPLAG = ICCSAD(UTIREC(6)) 00089^^ C PROCESSING COMPLETE-CLOSE FILE AND CONTINUE 00090^^ 33 CALL CLOSFL(UTIREQ,ISTAT) 00091^^ 34 GO TO 50 00092^^ C ERROR IN READR OF UTIFIL 00093^^ 35 20 CALL FILERR(UDATA,13,ISTAT,LU) 00094^^ 36 GO TO 900 00095^ ^ 37 50 CALL OPENFL( DEQREQ, DDATA, ISTAT ) 00097^^ C************************************************************** 173*A032 00098^^ 38 IF (ISTAT.GE.0) GO TO 100 00099^^ 39 CALL FILERR ( DDATA, 3, ISTAT, LU ) 00100^^ 40 GO TO 900 00101^^ 41 100 CALL CLEAR ( ASNREQ, ADATA, ISTAT ) 00102^^ 42 IF (ISTAT.GE.0) GO TO 110 00103^^ 43 CALL FILERR ( ADATA, 1, ISTAT, LU ) 00104^^ 44 GO TO 900 00105^^ 45 110 CALL OPENFL ( ASNREQ, ADATA, ISTAT ) 00106^^ 46 IF (ISTAT.GE.0) GO TO 200 00107^^ 47 CALL FILERR ( ADATA, 3, ISTAT, LU ) 00108^^ 48 GO TO 900 00109^t FTN 3.3B (OPT = LPC) DACRTE PAGE 4 DATE: 08/29/84 TIME: 2129 t^ C READ RECORDS FROM THE DELQMST AND PROCESS 00111^^ 49 200 CALL GETS ( DEQREQ, DEQREC, I, ISTAT ) 00112^^ C EOF? 00113^^ 50 IF (AND(ISTAT,$8100).EQ.$8100) GO TO 900 00114^^ 51 IF (AND(ISTAT,$100).EQ.$100) EFG = 1 00115^^ C FILE ERROR? 00116^^ 52 IF (ISTAT.GE.0) GO TO 210 00117^^ 53 CALL FILERR ( DDATA, 14, ISTAT, LU ) 00118^^ 54 GO TO 900 00119^^ 55 210 DO 300 I = 1 , NUMRD 00120^^ 56 L = 40*M - 39 00121^^ 57 K = 1000*I-999 00122^^ 58 J = 2*K-1 00123^^ C RECORD PRESENT? 00124^ ^ 59 IF (DEQREC(K).EQ.FDEL) GO TO 300 00126^ ^ C RECORD ACTIVE? 00128^^ 60 IF (AND(DEQREC(K+152),$FF).NE.$20) GO TO 300 00129^ ^ C*** IF CALC OF # DAYS DELQUIENT NEEDED REMOVE COMMENTS 00131^^ C AND INSTALL DAYS ROUTINE. 00132^^ C CALL DAYS (DEQREC(K),0875,DT,0001,ASCDAY,0) 00133^^ C CALL CCSMVA(ASCDAY,04,03,DEQREC(K),1013,03) 00134^ ^ C*** REMOVE COMMENT IF YOU WANT TO 00136^^ C*** VALIDATE ON LINE ACTIVITY BLOCK ...... 00137^^ C CALL VFYACF( DEQREC(K) ) 00138^ ^ C GET THE MOST RECENT ACTIVITY 00140^^ C**************************************************************138*A023 00141^^ 61 IOSW=$3031 00142^^ C**************************************************************138*A023 00143^^ 62 CALL GETACF ( STG, DEQREC(K+153), LTHACT, IOSW ) 00144^  ^ C REASSIGN QUEUE ALLOWED? 00146^^ 63 IF (AND(DEQREC(K+146),$FF).NE.$20) GO TO 220 00147^ t FTN 3.3B (OPT = LPC) DACRTE PAGE 5 DATE: 08/29/84 TIME: 2129 t^ C**** SET UP THE PARAMETERS FOR QUEUE ASSIGNMENT : 00150^^ C - THE MOST RECENT ACTION CODE IS IN : STG(4) 00151^^ C - RESULT CODE IS IN : STG(5) 00152^^ C - CONTACT DATE STARTS IN : STG(1) 00153^^ C - THE SYSTEM DATE STARTS IN : DT(1) 00154^   ^ C PARAMETER #1 00156^^ 64 CALL CCSMVA ( DEQREC, QUEP(1)+J-1, QUEL(1), QUE, 1, 6 ) 00157^ ^ C PARAMETER #2 00159^^ 65 CALL CCSMVA ( DEQREC, QUEP(2)+J-1, QUEL(2), QUE, 7, 6 ) 00160^ ^ C PARAMETER #3 00162^^ 66 CALL CCSMVA ( DEQREC, QUEP(3)+J-1, QUEL(3), QUE, 13, 6 ) 00163^ ^ C PARAMETER #4 00165^^ 67 CALL CCSMVA ( DEQREC, QUEP(4)+J-1, QUEL(4), QUE, 19, 6 ) 00166^ ^ C PARAMETER #5 00168^^ 68 CALL CCSMVA ( DEQREC, QUEP(5)+J-1, QUEL(5), QUE, 25, 6 ) 00169^ ^ C PARAMETER #6 00171^^ 69 CALL CCSMVA ( DEQREC, QUEP(6)+J-1, QUEL(6), QUE, 31, 6 ) 00172^ ^ C PARAMETER #7 00174^^ 70 CALL CCSMVA ( DEQREC, QUEP(7)+J-1, QUEL(7), QUE, 37, 6 ) 00175^ ^ C PARAMETER #8 00177^^ 71 CALL CCSMVA ( DEQREC, QUEP(8)+J-1, QUEL(8), QUE, 43, 6 ) 00178^ ^ C PARAMETER #9 00180^^ 72 CALL CCSMVA ( DEQREC, QUEP(9)+J-1, QUEL(9), QUE, 49, 6 ) 00181^t FTN 3.3B (OPT = LPC) DACRTE PAGE 6 DATE: 08/29/84 TIME: 2129 t^ C GET THE NEW QUEUE 00183^^ 73 CALL FTNDT1 ( QUE, NQUE ) 00184^^ C NEW QUEUE? 00185^^ 74 IF (NQUE(1).EQ.DEQREC(K+135).AND. 00186^^ 74 1 NQUE(2).EQ.DEQREC(K+136)) GO TO 220 00187^^ C QUEUE RETURN SUCCESSFUL? 00188^^ 75 IF (NQUE(1).EQ.$3939.AND. 00189^^ 75 1 NQUE(2).EQ.$3939) GO TO 220 00190^^ C SAVE OLD QUEUE , DATE , AND NEW QUEUE 00191^^ 76 CALL CCSMVA ( DEQREC, J+270, 4, DEQREC, J+295, 4 ) 00192^^ 77 CALL CCSMVA ( DT, 1, 6, DEQREC, J+299, 6 ) 00193^^ 78 CALL CCSMVA ( NQUE, 1, 4, DEQREC, J+270, 4 ) 00194^  ^ C GET THE NEW PRIORITY 00196^^ 79 220 CONTINUE 00197^t FTN 3.3B (OPT = LPC) DACRTE PAGE 7 DATE: 08/29/84 TIME: 2129 t^ C**** SET UP THE PARAMETERS FOR THE PRIORITY ASSIGNMENT - 00199^^ C - THE MOST RECENT ACTION CODE IS IN : STG(4) 00200^^ C - RESULT CODE IS IN : STG(5) 00201^^ C - CONTACT DATE STARTS IN : STG (1) 00202^^ C - THE SYSTEM DATE STARTS IN : DT(1) 00203^  ^ C PARAMETER #1 00205^^ 80 CALL CCSMVA ( DEQREC, PRIP(1)+J-1, PRIL(1), PRI, 1, 6 ) 00206^ ^ C PARAMETER #2 00208^^ 81 CALL CCSMVA ( DEQREC, PRIP(2)+J-1, PRIL(2), PRI, 7, 6 ) 00209^ ^ C PARAMETER #3 00211^^ 82 CALL CCSMVA ( DEQREC, PRIP(3)+J-1, PRIL(3), PRI, 13, 6 ) 00212^ ^ C PARAMETER #4 00214^^ 83 CALL CCSMVA ( DEQREC, PRIP(4)+J-1, PRIL(4), PRI, 19, 6 ) 00215^ ^ C PARAMETER #5 00217^^ 84 CALL CCSMVA ( DEQREC, PRIP(5)+J-1, PRIL(5), PRI, 25, 6 ) 00218^ ^ C PARAMETER #6 00220^^ 85 CALL CCSMVA ( DEQREC, PRIP(6)+J-1, PRIL(6), PRI, 31, 6 ) 00221^ ^ C PARAMETER #7 00223^^ 86 CALL CCSMVA ( DEQREC, PRIP(7)+J-1, PRIL(7), PRI, 37, 6 ) 00224^ ^ C PARAMETER #8 00226^^ 87 CALL CCSMVA ( DEQREC, PRIP(8)+J-1, PRIL(8), PRI, 43, 6 ) 00227^ ^ C PARAMETER #9 00229^^ 88 CALL CCSMVA ( DEQREC, PRIP(9)+J-1, PRIL(9), PRI, 49, 6 ) 00230^t FTN 3.3B (OPT = LPC) DACRTE PAGE 8 DATE: 08/29/84 TIME: 2129 t^ 89 CALL FTNDT1 ( PRI, NPRI ) 00232^^ C PRIORITY RETURN SUCCESSFUL? 00233^^ 90 IF (NPRI(1).EQ.$3939.AND. 00234^^ 90 1 NPRI(2) .EQ. $3939 ) GO TO 225 00235^^ C SAVE THE NEW PRIORITY 00236^^ 91 CALL CCSMVA ( NPRI, 1, 4, DEQREC, J+280, 4 ) 00237^ ^ C IS THIS ACCOUNT A PROMISE TO PAY? 00239^^ 92 225 IF ( AND(DEQREC(K+142),$FF00) .NE. $5900 ) GO TO 230 00240^ ^ C************************************************************** 173*A032 00242^^ C CHECK IF PROMISE DUE TO BE CHECKED (SYSTEM DATE EQUAL OR 00243^^ C PAST PROMISE TO PAY DATE + LAG FROM UTIFIL 00244^^ C ADD LAG FACTOR FROM UTIFIL OBTAINED ABOVE TO PROMISE TO PAY 00245^^ C DATE TO SEE OF PP IS BROKEN OR NOT 00246^^ C MOVE PP DATE TO WORK AREA 00247^^ 93 CALL CCSMVA(DEQREC,J+1015,6,PPDATE,1,6) 00248^^ 94 IK = ICALJL(PPDATE,1) 00249^^ 95 IK = IK + PPLAG 00250^^ 96 IF(IK.LE.365)GO TO 2250 00251^^ C YEAR HAS TURNED OVER-CONVERT THE DATE 00252^^ 97 PPDATE(3) = PPDATE(3) + 1 00253^^ 98 IF(AND(PPDATE(3),$FF).GT.$39) 00254^^ 98 . PPDATE(3) = PPDATE(3) + $F6 00255^^ C CONVERT THE DATE BACK 00256^^ 99 2250 CALL JULCAL(IK,PPDATE,1) 00257^^ C PP DATE IS READY TO BE CHECKED 00258^^ 100 CALL CCSCST( DT, 5, 2, PPDATE, 5, 2, ICOMP) 00259^^ C************************************************************** 173*A032 00260^^ C NOT DUE CHK FURTHER DUE 00261^^ 101 IF(ICOMP) 230, 2251, 2252 00262^ ^ C YEARS EQUAL CHECK MONTH AND DAY 00264^^ C************************************************************** 173*A032 00265^^ 102 2251 CALL CCSCST( DT, 1, 4, PPDATE, 1, 4, ICOMP ) 00266^^ C TODAYS DATE MUST BE EQUAL OR PAST PROMISE TO PAY DATE(PLUS LAG) 00267^^ C FOR CHECK 00268^^ C************************************************************** 173*A032 00269^^ 103 IF (ICOMP .LT. 0) GO TO 230 00270^ ^ C PROMISE DUE TO BE CHECKED. SEE IF LAST PAYMENT AMOUNT 00272^^ C CLEARS PROMISED AMOUNT. 00273^^ 104 2252 CALL CCSCST ( DEQREC, J+LAMT-1, 9, DEQREC, J+1021, 9, ICOMP) 00274^^ 105 IF(ICOMP .LT. 0) GO TO 224 00275^ ^ C LAST PAYMENT CLEARS PROMISE. VERIFY PAYMENT RECEIVED 00277^^ C AFTER COMMITMENT DATE. 00278^^ C************************************************************** 173*A018 00279^^ 106 CALL CCSCST (DEQREC, J+LDATE+3, 2, DEQREC, J+1044, 2, ICOMP) 00280^^ C************************************************************** 173*A018 00281^^ C BEFORE CHK FURTHER AFTER 00282^^ 107 IF(ICOMP) 224, 2253, 2254 00283^ ^ C YEARS EQUAL, CHECK MONTH AND DAY 00285^t FTN 3.3B (OPT = LPC) DACRTE PAGE 9 DATE: 08/29/84 TIME: 2129 t^ 108 2253 CALL CCSCST ( DEQREC, J+LDATE-1, 4, DEQREC, J+1040, 4, ICOMP) 00286^^ C PAYMENT DATE MUST BE PAST COMMITTMENT DATE FOR KEPT PROMISE. 00287^^ 109 IF( ICOMP .LT. 0 ) GO TO 224 00288^^ C**************************************************************138*A018 00289^  ^ C PROMISE KEPT, INCREMENT THE KEPT COUNT 00291^^ C**************************************************************138*A018 00292^^ 110 2254 DEQREC(K+518) = AND(DEQREC(K+518),$FF0F) + $31 00293^^ C**************************************************************138*A018 00294^^ 111 IF ( AND(DEQREC(K+518),$FF) .GT. $39 ) 00295^^ 111 1 DEQREC(K+518) = AND(DEQREC(K+518),$FFF) + $30F6 00296^^ C INCREMENT THE NEXT CONTACT DATE 7 DAYS 00297^^ 112 IK = ICALJL ( DEQREC, J+274 ) 00298^^ 113 IK = IK + 7 00299^^ 114 IF ( IK .LE. 365 ) GO TO 222 00300^^ 115 DEQREC(K+139) = DEQREC(K+139) + 1 00301^^ 116 IF ( AND(DEQREC(K+139),$FF) .GT. $39 ) 00302^^ 116 1 DEQREC(K+139) = DEQREC(K+139) + $F6 00303^^ 117 222 CALL JULCAL ( IK, DEQREC, J+274 ) 00304^^ C CLEAR THE PROMISED TO PAY FLAG 00305^^ 118 CALL CCSPUT ( $4B, J+284, DEQREC ) 00306^^ 119 GO TO 230 00307^  ^ C PROMISE BROKEN, INCREMENT THE BROKEN COUNT 00310^^ 120 224 DEQREC(K+519) = AND(DEQREC(K+519),$FF0F) + $31 00311^^ 121 IF ( AND(DEQREC(K+519),$FF) .GT. $39 ) 00312^^ 121 1 DEQREC(K+519) = AND(DEQREC(K+519),$FFF) + $30F6 00313^^ C SET THE PROMISED TO PAY FLAG TO BROKEN 00314^^ 122 CALL CCSPUT ( $42, J+284, DEQREC ) 00315^t FTN 3.3B (OPT = LPC) DACRTE PAGE 10 DATE: 08/29/84 TIME: 2129 t^ C BUILD THE DLYASSN RECORD - ACCT #, QUEUE, NEXTCD, PRIORITY 00317^^ 123 230 CALL CCSMVA ( DEQREC, J, 16, ASNREC, L, 40) 00318^^ 124 CALL CCSMVA ( DEQREC, J+270, 14, ASNREC, L+16, 14 ) 00319^  ^ C**** IF ADDITIONAL FIELDS ARE REQUIRED IN THE DLYASSN RECORD, 00321^^ C THEY SHOULD BE MOVED IN AT THIS POINT 00322^  ^ 125 M = M + 1 00324^^ 126 300 CONTINUE 00325^ ^ C SAVE THE DLYASSN RECORD 00327^^ 127 M = M - 1 00328^^ 128 IF ( M .EQ. 0 ) GO TO 310 00329^^ 129 CALL PUTS ( ASNREQ, ASNREC, M, ISTAT ) 00330^^ 130 IF (ISTAT.GE.0) GO TO 305 00331^^ 131 CALL FILERR ( ADATA, 11, ISTAT, LU ) 00332^^ 132 GO TO 900 00333^^ C UPDATE THE RECORDS IN THE DELQMST FILE 00334^^ 133 305 CALL UPDREC ( DEQREQ, DEQREC, ISTAT ) 00335^^ C FILE ERROR? 00336^^ 134 IF (ISTAT.GE.0) GO TO 310 00337^^ 135 CALL FILERR ( DDATA, 15, ISTAT, LU ) 00338^^ 136 GO TO 900 00339^^ C ****************************** CONTINUE 00340^^ 137 310 CONTINUE 00341^^ 138 M = 1 00342^^ 139 IF (EFG.EQ.0) GO TO 200 00343^ ^ C CLOSE THE FILES AND STOP 00345^^ 140 900 CALL CLOSFL ( DEQREQ, ISTAT ) 00346^^ 141 CALL CLOSFL ( ASNREQ, ISTAT ) 00347^^ 142 CALL PGMOUT 00348^^ 143 END 00349^t FTN 3.3B (OPT = LPC) DACRTE PAGE 11 DATE: 08/29/84 TIME: 2129 t  PROGRAM LENGTH $60C3 ( 24771)   EXTERNALS 2 Q8STP FMRDEL PGMIN UTHEAD OPENFL FILERR READR 22 ICCSAD CLOSFL CLEAR GETS GETACF CCSMVA FTNDT1 22 ICALJL JULCAL CCSCST CCSPUT PUTS UPDREC PGMOUT 2 t FTN 3.3B (OPT = LPC) DACRTE PAGE 12 DATE: 08/29/84 TIME: 2129 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < ( 8100 (-32511) 5D2B 30,30,50 (" FF00 (-255) 5D47 92 "& FF0F (-240) 5D53 110,120&‚ 0001 (1) 0002 7,10,24,43,51,55,58,64,65,66,67,68,69,70,71,72,74,75,77,78,80,81,82,83,84,85,86,87,88,90,91,93,94, ‚@ 97,99,102,104,108,115,125,127,138@8 0002 (2) 5D36 58,65,74,75,81,90,100,10688 0003 (3) 5D29 27,39,47,66,82,97,98,106 86 0004 (4) 5D43 76,76,78,83,91,102,108 6& 0005 (5) 5D4D 100,100&Z 0006 (6) 5D39 64,65,66,67,68,69,70,71,72,77,80,81,82,83,84,85,86,87,88,93Z. 0007 (7) 5D3A 65,70,81,86,113.& 0009 (9) 5D4F 104,104&" 000B (11) 5D5B 131"( 000D (13) 5D2C 35,66,82 (& 000E (14) 5D2F 53,124 &" 000F (15) 5D5C 135"& 0010 (16) 5D5A 123,124&$ 0013 (19) 5D3B 67,83$$ 0019 (25) 5D3C 68,84$$ 001F (31) 5D3D 69,85$$ 0025 (37) 5D3E 70,86$& 0028 (40) 5D31 56,123 &$ 002B (43) 5D3F 71,87$, 0031 (49) 5D40 72,88,110,120," 0042 (66) 5D59 122"" 004B (75) 5D57 117"& 00F6 (246) 5D4C 98,116 &4 00FF (255) 5D37 60,63,98,111,116,121 4$ 0100 (256) 5D2E 51,51$( 010E (270) 5D42 76,78,124(& 0112 (274) 5D56 112,117&" 0118 (280) 5D46 91 "& 011C (284) 5D58 118,122&" 0127 (295) 5D44 76 "" 012B (299) 5D45 77 "& 016D (365) 5D4B 96,114 &$ 0200 (512) 5D2A 30,30$" 03E7 (999) 5D34 57 "" 03E8 (1000) 5D33 57 "" 03F7 (1015) 5D49 93 "" 03FD (1021) 5D50 104"" 0410 (1040) 5D52 108"" 0414 (1044) 5D51 106"& 0FFF (4095) 5D54 111,121&" 3030 (12336) 5D26 21 "" 3031 (12337) 5D38 61 "t FTN 3.3B (OPT = LPC) DACRTE PAGE 13 DATE: 08/29/84 TIME: 2129 t& 30F6 (12534) 5D55 111,121&( 3939 (14649) 5D41 75,75,90 (" 5900 (22784) 5D48 92 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < 2 ADATA INTEGER 0042 1,7,41,43,45,47,1312J AND INTR.FN. 7FFF 30,30,50,51,60,63,92,98,110,111,116,120,121J ASCDAY INTEGER 5CC5 1 , ASNREC INTEGER 5AA9 1,123,124,129,0 ASNREQ INTEGER 001B 1,5,41,45,129,14102 DDATA INTEGER 0033 1,6,23,37,39,53,1352€ DEQREC INTEGER 00D1 1,49,59,60,62,63,64,65,66,67,68,69,70,71,72,74,76,77,78,80,81,82,83,84,85,86,87,88,91,92,93,104, €Z 106,108,110,111,112,115,116,117,118,120,121,122,123,124,133Z2 DEQREQ INTEGER 0003 1,3,5,37,49,133,1402. DT INTEGER 0053 1,22,77,100,102.* EFG INTEGER 0052 1,12,51,139*& FDEL INTEGER 00D0 1,20,59&$ HD INTEGER 005A 1,22 $( I INTEGER 5D2D 49,55,57 (F ICOMP INTEGER 5D4E 100,101,102,103,104,105,106,107,108,109F> IK INTEGER 5D4A 93,94,95,96,99,112,113,114,117 >* IOSW INTEGER 5D25 20,21,61,62*€ ISTAT INTEGER 5D28 25,26,27,29,30,31,33,35,37,38,39,41,42,43,45,46,47,49,50,51,52,53,129,130,131,133,134,135,140,141€‚ J INTEGER 5D35 57,58,64,65,66,67,68,69,70,71,72,76,77,78,80,81,82,83,84,85,86,87,88,91,93,104,106,108,112,117,118 ‚, ,122,123,124 ,R K INTEGER 5D32 56,57,58,59,60,62,63,74,92,110,111,115,116,120,121 R, L INTEGER 5D30 55,56,123,124,& LAMT INTEGER 5D21 18,104 &* LDATE INTEGER 5D20 17,106,108 *& LTHACT INTEGER 5CC3 1,12,62&< LU INTEGER 5D22 19,27,35,39,43,47,53,131,135 << M INTEGER 5D27 23,24,56,125,127,128,129,138 <" MODE INTEGER 5D23 19 "" NPORT INTEGER 5D24 19 "* NPRI INTEGER 00CE 1,89,90,91 *, NQUE INTEGER 00CC 1,73,74,75,78,& NUMRD INTEGER 0011 1,3,55 &$ NUMREC INTEGER 5D1F 11,23$& OLPM INTEGER 5D1C 7,11,29&$ P INTEGER 5CC9 1,18 $8 PPDATE INTEGER 5CCA 7,93,94,97,98,99,100,102 8& PPLAG INTEGER 5D1E 7,32,95&B PRI INTEGER 0096 1,13,80,81,82,83,84,85,86,87,88,89 B> PRIL INTEGER 5C92 1,17,80,81,82,83,84,85,86,87,88>> PRIP INTEGER 5C89 1,16,80,81,82,83,84,85,86,87,88>$ Q INTEGER 5CC8 1,18 $B QUE INTEGER 00B1 1,13,64,65,66,67,68,69,70,71,72,73 B> QUEL INTEGER 5C80 1,15,64,65,66,67,68,69,70,71,72>> QUEP INTEGER 5C77 1,14,64,65,66,67,68,69,70,71,72>t FTN 3.3B (OPT = LPC) DACRTE PAGE 14 DATE: 08/29/84 TIME: 2129 t$ ST INTEGER 0051 1,12 $$ STG INTEGER 5C9B 1,62 $, UDATA INTEGER 5CCD 7,10,25,27,35,$ USER INTEGER 0056 1,19 $& UTIREC INTEGER 5CF4 7,29,32&, UTIREQ INTEGER 5CDC 7,11,25,29,33,   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < 2 CCSCST SUBROUTINE 5FAF 99,102,104,106,108 2l CCSMVA SUBROUTINE 606E 63,65,66,67,68,69,70,71,72,76,77,78,80,81,82,83,84,85,86,87,88,91,93,123,124 l& CCSPUT SUBROUTINE 6052 117,122&" CLEAR SUBROUTINE 5DB5 41 "* CLOSFL SUBROUTINE 60B9 32,140,141 *8 FILERR SUBROUTINE 609C 26,35,39,43,47,53,131,1358$ FTNDT1 SUBROUTINE 5F63 72,89$" GETACF SUBROUTINE 5E25 61 "" GETS SUBROUTINE 5DD2 49 "& ICALJL INTEGER.FN. 602B 94,112 &" ICCSAD INTEGER.FN. 5D95 32 "& JULCAL SUBROUTINE 6048 99,117 &( OPENFL SUBROUTINE 5D73 24,37,45 (" PGMIN SUBROUTINE 5D5E 18 "" PGMOUT SUBROUTINE 60C0 141"" PUTS SUBROUTINE 6092 128" Q8STP INTEGER.FN. 60C2 " READR SUBROUTINE 5D83 29 "" UPDREC SUBROUTINE 60A3 133"" UTHEAD SUBROUTINE 5D6A 21 "   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 10 5D82 26,29$( 20 5D9E 30,31,35 ($ 50 5DA5 33,37$$ 100 5DB4 38,41$$ 110 5DC3 42,45$( 200 5DD1 46,49,139($ 210 5DF0 52,55$* 220 5EED 63,74,75,79*& 222 6043 114,117&. 224 6057 105,107,109,120.$ 225 5F7A 90,92$2 230 606D 92,101,103,119,123 2, 300 6087 55,59,60,126 ,& 305 60A2 130,133&t FTN 3.3B (OPT = LPC) DACRTE PAGE 15 DATE: 08/29/84 TIME: 2129 t* 310 60B0 128,134,137*@ 900 60B8 27,36,40,44,48,50,54,132,136,140 @$ 2250 5FA9 96,99$& 2251 5FC4 101,102&& 2252 5FD1 101,104&& 2253 5FFE 107,108&& 2254 6012 107,110& DACRTE 0000 1  t FTN 3.3B (OPT = LPC) R9BASE PAGE 1 DATE: 08/29/84 TIME: 2130 t^ 1 SUBROUTINE R9BASE 00350^^ 1 1 /C12 F CCS CCS 3.0 SL-149 00351^^ C 00352^^ C CYBERCREDIT SYSTEM VERSION 3 00353^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA 00354^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 00355^^ C 00356^^ 2 RETURN 00357^^ 3 END 00358^t FTN 3.3B (OPT = LPC) R9BASE PAGE 2 DATE: 08/29/84 TIME: 2130 t  PROGRAM LENGTH $0007 ( 7)   t FTN 3.3B (OPT = LPC) R9BASE PAGE 3 DATE: 08/29/84 TIME: 2130 t, ***** L I S T O F S Y M B O L S *****,   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : <  R9BASE 0003 1  t FTN 3.3B (OPT = LPC) R9FLDL PAGE 1 DATE: 08/29/84 TIME: 2130 t^ 1 SUBROUTINE R9FLDL 00359^^ 1 1 /C13 F CCS CCS 3.0 SL-149 00360^^ C 00361^^ C CYBERCREDIT SYSTEM VERSION 3 00362^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA 00363^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 00364^^ C 00365^^ 2 RETURN 00366^^ 3 END 00367^t FTN 3.3B (OPT = LPC) R9FLDL PAGE 2 DATE: 08/29/84 TIME: 2130 t  PROGRAM LENGTH $0007 ( 7)   t FTN 3.3B (OPT = LPC) R9FLDL PAGE 3 DATE: 08/29/84 TIME: 2130 t, ***** L I S T O F S Y M B O L S *****,   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : <  R9FLDL 0003 1  t FTN 3.3B (OPT = LPC) DACRTE PAGE 1 DATE: 08/29/84 TIME: 2131 t^ 1 PROGRAM DACRTE B6600001^^ 1 1 /B66 F CCS CCS 3.0 SL-149B6600002^^ C B6600003^^ C CYBERCREDIT SYSTEM VERSION 3 B6600004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B6600005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B6600006^^ C B6600007^ ^ C **** INSTALLATION TEST KIT VERSION**** B6600009^^ C THIS PROGRAM REASSIGNS QUEUES AND PRIORITIES FOR ALL ACTIVE B6600010^^ C ACCOUNTS IN THE DELQMST FILE AND CREATES THE DLYASSN FILE B6600011^^ C WHICH IS USED BY THE ON-LINE AUTOMATIC FUNCTION B6600012^ ^ 2 INTEGER DEQREQ(24),ASNREQ(24),DDATA(15),ADATA(15),ST,EFG,DT(3), B6600014^^ 2 2 USER(4),HD(3,20),PRI(3,9),QUE(3,9),NQUE(2),NPRI(2),FDEL, B6600015^^ 2 3 DEQREC(23000),ASNREC(462),QUEP(9),QUEL(9),PRIP(9),PRIL(9), B6600016^^ 2 4 STG(40),LTHACT(2) B6600017^ ^ 3 EXTERNAL FMRDEL B6600019^ ^ 4 DATA DEQREQ, ASNREQ / 48*0 / B6600021^^ 5 DATA DDATA / 'DELQMST ', 8*$2020, 0, 0, 0 / B6600022^^ 6 DATA ADATA / 'DLYASSN ', 8*$2020, 0, 1, 0 / B6600023^^ 7 DATA NUMREC / 23 /, ST / 0 /, EFG / 0 /, LTHACT / '0360' / B6600024^^ 8 DATA QUE, PRI / 54*$2020 / B6600025^^ 9 INTEGER QIMG, NINETH(2) B6600026^^ 10 DATA QIMG / 'Q' / , NINETH / '9000' / B6600027^t FTN 3.3B (OPT = LPC) DACRTE PAGE 2 DATE: 08/29/84 TIME: 2131 t^ C**** SET UP THE DELQMST STARTING CHARACTER POSITIONS FOR THE B6600029^^ C QUEUE ASSIGNMENT PARAMETERS, IF NOT USED MUST BE ZERO (0) B6600030^ ^ C P-1 P-2 P-3 P-4 P-5 P-6 P-7 P-8 P-9 B6600032^^ 11 DATA QUEP / 887, 0, 0, 0, 0, 0, 0, 0, 0 / B6600033^ ^ C**** SET UP THE DELQMST PARAMETER LENGTH IN CHARACTERS MAX. = 6 B6600035^^ C IF UNUSED MUST BE ZERO (0) B6600036^ ^ C P-1 P-2 P-3 P-4 P-5 P-6 P-7 P-8 P-9 B6600038^^ 12 DATA QUEL / 6, 0, 0, 0, 0, 0, 0, 0, 0 / B6600039^  ^ C**** SET UP THE STARTING CHARACTER POSITIONS IN DELQMST FILE FOR B6600041^^ C THE PRIORITY ASSIGNMENT PARAMETERS, IF UNSED MUST BE ZERO (0) B6600042^ ^ C P-1 P-2 P-3 P-4 P-5 P-6 P-7 P-8 P-9 B6600044^^ 13 DATA PRIP / 285, 0, 0, 0, 0, 0, 0, 0, 0 / B6600045^ ^ C**** SET UP THE PRIORITY PARAMETER CHARACTER LENGTHS MAX. = 6 B6600047^^ C IF UNUSED MUST BE ZERO (0) B6600048^ ^ C P-1 P-2 P-3 P-4 P-5 P-6 P-7 P-8 P-9 B6600050^^ 14 DATA PRIL / 1, 0, 0, 0, 0, 0, 0, 0, 0 / B6600051^ ^ C**** SET UP THE STARTING CHARACTER POSITIONS FOR THE MOST RECENT B6600053^^ C PAYMENT AMOUNT AND PAYMENT DATE, USED FOR BROKEN PP'S B6600054^ ^ 15 DATA LDATE / 1139 / , LAMT / 1103 / B6600056^t FTN 3.3B (OPT = LPC) DACRTE PAGE 3 DATE: 08/29/84 TIME: 2131 t^ C ACCEPT LOGIN FROM ITOS B6600058^^ 16 CALL PGMIN ( USER, LU, MODE, NPORT ) B6600059^ ^ C INITIALIZE VARIABLES B6600061^^ 17 ASSEM $C000,FMRDEL,$6800,FDEL B6600062^^ 18 CALL CCSBLK ( ASNREC, 920 ) B6600063^^ 19 IOSW = $3030 B6600064^^ 20 CALL UTHEAD ( HD, DT ) B6600065^^ 21 DDATA(14) = NUMREC B6600066^^ 22 M = 1 B6600067^  ^ C OPEN FILES FOR USE B6600069^^ 23 CALL OPENFL ( DEQREQ, DDATA, ISTAT ) B6600070^^ 24 IF (ISTAT.GE.0) GO TO 100 B6600071^^ 25 CALL FILERR ( DDATA, 3, ISTAT, LU ) B6600072^^ 26 GO TO 900 B6600073^^ 27 100 CALL CLEAR ( ASNREQ, ADATA, ISTAT ) B6600074^^ 28 IF (ISTAT.GE.0) GO TO 110 B6600075^^ 29 CALL FILERR ( ADATA, 1, ISTAT, LU ) B6600076^^ 30 GO TO 900 B6600077^^ 31 110 CALL OPENFL ( ASNREQ, ADATA, ISTAT ) B6600078^^ 32 IF (ISTAT.GE.0) GO TO 200 B6600079^^ 33 CALL FILERR ( ADATA, 3, ISTAT, LU ) B6600080^^ 34 GO TO 900 B6600081^t FTN 3.3B (OPT = LPC) DACRTE PAGE 4 DATE: 08/29/84 TIME: 2131 t^ C READ RECORDS FROM THE DELQMST AND PROCESS B6600083^^ 35 200 CALL GETS ( DEQREQ, DEQREC, I, ISTAT ) B6600084^^ C EOF? B6600085^^ 36 IF (AND(ISTAT,$8100).EQ.$8100) GO TO 900 B6600086^^ 37 IF (AND(ISTAT,$100).EQ.$100) EFG = 1 B6600087^^ C FILE ERROR? B6600088^^ 38 IF (ISTAT.GE.0) GO TO 210 B6600089^^ 39 CALL FILERR ( DDATA, 14, ISTAT, LU ) B6600090^^ 40 GO TO 900 B6600091^^ 41 210 DO 300 I = 1 , NUMREC B6600092^^ 42 L = 40*M - 39 B6600093^^ 43 K = 1000*I-999 B6600094^^ 44 J = 2*K-1 B6600095^^ C RECORD PRESENT? B6600096^^ 45 IF (DEQREC(K).EQ.$2020.OR. B6600097^^ 45 1 DEQREC(K).EQ.FDEL) GO TO 300 B6600098^^ C RECORD ACTIVE? B6600099^^ 46 IF (AND(DEQREC(K+152),$FF).NE.$20) GO TO 300 B6600100^ ^ C GET THE MOST RECENT ACTIVITY B6600102^^ C***************************************************************138*A023B6600103^^ 47 IOSW = $3031 B6600104^^ C***************************************************************138*A023B6600105^^ 48 CALL GETACF ( STG, DEQREC(K+153), LTHACT, IOSW ) B6600106^  ^ C REASSIGN QUEUE ALLOWED? B6600108^^ 49 IF (AND(DEQREC(K+146),$FF).NE.$20) GO TO 220 B6600109^ t FTN 3.3B (OPT = LPC) DACRTE PAGE 5 DATE: 08/29/84 TIME: 2131 t^ C**** SET UP THE PARAMETERS FOR QUEUE ASSIGNMENT : B6600112^^ C - THE MOST RECENT ACTION CODE IS IN : STG(4) B6600113^^ C - RESULT CODE IS IN : STG(5) B6600114^^ C - CONTACT DATE STARTS IN : STG(1) B6600115^^ C - THE SYSTEM DATE STARTS IN : DT(1) B6600116^   ^ C PARAMETER #1 B6600118^^ 50 CALL CCSMVA ( DEQREC, QUEP(1)+J-1, QUEL(1), QUE, 1, 6 ) B6600119^ ^ C PARAMETER #2 B6600121^^ 51 CALL CCSMVA ( DEQREC, QUEP(2)+J-1, QUEL(2), QUE, 7, 6 ) B6600122^ ^ C PARAMETER #3 B6600124^^ 52 CALL CCSMVA ( DEQREC, QUEP(3)+J-1, QUEL(3), QUE, 13, 6 ) B6600125^ ^ C PARAMETER #4 B6600127^^ 53 CALL CCSMVA ( DEQREC, QUEP(4)+J-1, QUEL(4), QUE, 19, 6 ) B6600128^ ^ C PARAMETER #5 B6600130^^ 54 CALL CCSMVA ( DEQREC, QUEP(5)+J-1, QUEL(5), QUE, 25, 6 ) B6600131^ ^ C PARAMETER #6 B6600133^^ 55 CALL CCSMVA ( DEQREC, QUEP(6)+J-1, QUEL(6), QUE, 31, 6 ) B6600134^ ^ C PARAMETER #7 B6600136^^ 56 CALL CCSMVA ( DEQREC, QUEP(7)+J-1, QUEL(7), QUE, 37, 6 ) B6600137^ ^ C PARAMETER #8 B6600139^^ 57 CALL CCSMVA ( DEQREC, QUEP(8)+J-1, QUEL(8), QUE, 43, 6 ) B6600140^ ^ C PARAMETER #9 B6600142^^ 58 CALL CCSMVA ( DEQREC, QUEP(9)+J-1, QUEL(9), QUE, 49, 6 ) B6600143^t FTN 3.3B (OPT = LPC) DACRTE PAGE 6 DATE: 08/29/84 TIME: 2131 t^ C GET THE NEW QUEUE B6600145^^ 59 CALL FTNDT1 ( QUE, NQUE ) B6600146^^ C NEW QUEUE? B6600147^^ 60 IF (NQUE(1).EQ.DEQREC(K+135).AND. B6600148^^ 60 1 NQUE(2).EQ.DEQREC(K+136)) GO TO 220 B6600149^^ C QUEUE RETURN SUCCESSFUL? B6600150^^ 61 IF (NQUE(1).EQ.$3939.AND. B6600151^^ 61 1 NQUE(2).EQ.$3939) GO TO 220 B6600152^^ C SAVE OLD QUEUE , DATE , AND NEW QUEUE B6600153^^ 62 CALL CCSMVA ( DEQREC, J+270, 4, DEQREC, J+295, 4 ) B6600154^^ 63 CALL CCSMVA ( DT, 1, 6, DEQREC, J+299, 6 ) B6600155^^ 64 CALL CCSMVA ( NQUE, 1, 4, DEQREC, J+270, 4 ) B6600156^  ^ C GET THE NEW PRIORITY B6600158^^ 65 220 CONTINUE B6600159^t FTN 3.3B (OPT = LPC) DACRTE PAGE 7 DATE: 08/29/84 TIME: 2131 t^ C**** SET UP THE PARAMETERS FOR THE PRIORITY ASSIGNMENT - B6600161^^ C - THE MOST RECENT ACTION CODE IS IN : STG(4) B6600162^^ C - RESULT CODE IS IN : STG(5) B6600163^^ C - CONTACT DATE STARTS IN : STG (1) B6600164^^ C - THE SYSTEM DATE STARTS IN : DT(1) B6600165^  ^ C PARAMETER #1 B6600167^^ 66 CALL CCSMVA ( DEQREC, PRIP(1)+J-1, PRIL(1), PRI, 1, 6 ) B6600168^ ^ C PARAMETER #2 B6600170^^ 67 CALL CCSMVA ( QIMG , 1 , 2 , PRI, 7, 6 ) B6600171^ ^ C PARAMETER #3 B6600173^^ 68 CALL CCSMVA ( DEQREC, PRIP(3)+J-1, PRIL(3), PRI, 13, 6 ) B6600174^ ^ C PARAMETER #4 B6600176^^ 69 CALL CCSMVA ( DEQREC, PRIP(4)+J-1, PRIL(4), PRI, 19, 6 ) B6600177^ ^ C PARAMETER #5 B6600179^^ 70 CALL CCSMVA ( DEQREC, PRIP(5)+J-1, PRIL(5), PRI, 25, 6 ) B6600180^ ^ C PARAMETER #6 B6600182^^ 71 CALL CCSMVA ( DEQREC, PRIP(6)+J-1, PRIL(6), PRI, 31, 6 ) B6600183^ ^ C PARAMETER #7 B6600185^^ 72 CALL CCSMVA ( DEQREC, PRIP(7)+J-1, PRIL(7), PRI, 37, 6 ) B6600186^ ^ C PARAMETER #8 B6600188^^ 73 CALL CCSMVA ( DEQREC, PRIP(8)+J-1, PRIL(8), PRI, 43, 6 ) B6600189^ ^ C PARAMETER #9 B6600191^^ 74 CALL CCSMVA ( DEQREC, PRIP(9)+J-1, PRIL(9), PRI, 49, 6 ) B6600192^t FTN 3.3B (OPT = LPC) DACRTE PAGE 8 DATE: 08/29/84 TIME: 2131 t^ 75 CALL FTNDT1 ( PRI, NPRI ) B6600194^^ C PRIORITY RETURN SUCCESSFUL? B6600195^^ 76 IF (NPRI(1).EQ.$3939.AND. B6600196^^ 76 1 NPRI(2) .EQ. $3939 ) GO TO 225 B6600197^^ C SAVE THE NEW PRIORITY B6600198^^ 77 CALL CCSMVA ( NPRI, 1, 4, DEQREC, J+280, 4 ) B6600199^ ^ C IS THIS ACCOUNT A PROMISE TO PAY? B6600201^^ 78 225 IF ( AND(DEQREC(K+142),$FF00) .NE. $5900 ) GO TO 230 B6600202^ ^ C***************************************************************138*A018B6600204^^ C CHECK IF PROMISE DUE TO BE CHECKED (SYSTEM DATE EQUAL OR B6600205^^ C PAST PROMISE TO PAY DATE). B6600206^^ 79 CALL CCSCST ( DT, 5, 2, DEQREC, J+1019, 2, ICOMP ) B6600207^^ C NOT DUE CHK FURTHER DUE B6600208^^ 80 IF (ICOMP) 230 , 2251 , 2252 B6600209^ ^ C YEARS EQUAL, CHECK MONTH AND DAY. B6600211^^ 81 2251 CALL CCSCST ( DT, 1, 4, DEQREC, J+1015, 4, ICOMP ) B6600212^^ C TODAY'S DATE MUST BE EQUAL OR PAST PROMISED TO BE DUE FOR B6600213^^ C CHECK. B6600214^^ 82 IF ( ICOMP .LT. 0 ) GO TO 230 B6600215^ ^ C PROMISE DUE TO BE CHECKED. SEE IF LAST PAYMENT AMOUNT CLEARS B6600217^^ C PROMISED AMOUNT. B6600218^^ 83 2252 CALL CCSCST ( DEQREC, J+LAMT-1, 9, DEQREC, J+1021, 9, ICOMP ) B6600219^^ 84 IF ( ICOMP .LT. 0 ) GO TO 224 B6600220^ ^ C LAST PAYMENT CLEARS PROMISE. VERIFY PAYMENT RECEIVED AFTER B6600222^^ C COMMITMENT DATE. B6600223^^ 85 CALL CCSCST ( DEQREC, J+LDATE+3, 2, DEQREC, J+1044, 2, ICOMP ) B6600224^^ C BEFORE CHK FURTHER AFTER B6600225^^ 86 IF (ICOMP) 224 , 2253 , 2254 B6600226^ ^ C YEARS EQUAL, CHECK MONTH AND DAY. B6600228^^ 87 2253 CALL CCSCST ( DEQREC, J+LDATE-1, 4, DEQREC, J+1040, 4, ICOMP ) B6600229^^ C PAYMENT DATE MUST BE PAST COMMITMENT DATE FOR KEPT PROMISE. B6600230^^ 88 IF ( ICOMP .LT. 0 ) GO TO 224 B6600231^^ C***************************************************************138*A018B6600232^  ^ C PROMISE KEPT, INCREMENT THE KEPT COUNT B6600234^^ C***************************************************************138*A018B6600235^^ 89 2254 DEQREC(K+518) = AND(DEQREC(K+518),$FF0F) + $31 B6600236^^ C***************************************************************138*A018B6600237^^ 90 IF ( AND(DEQREC(K+518),$FF) .GT. $39 ) B6600238^^ 90 1 DEQREC(K+518) = AND(DEQREC(K+518),$FFF) + $30F6 B6600239^^ C INCREMENT THE NEXT CONTACT DATE 7 DAYS B6600240^^ 91 IK = ICALJL ( DEQREC, J+274 ) B6600241^^ 92 IK = IK + 7 B6600242^^ 93 IF ( IK .LE. 365 ) GO TO 222 B6600243^^ 94 DEQREC(K+139) = DEQREC(K+139) + 1 B6600244^^ 95 IF ( AND(DEQREC(K+139),$FF) .GT. $39 ) B6600245^^ 95 1 DEQREC(K+139) = DEQREC(K+139) + $F6 B6600246^t FTN 3.3B (OPT = LPC) DACRTE PAGE 9 DATE: 08/29/84 TIME: 2131 t^ 96 222 CALL JULCAL ( IK, DEQREC, J+274 ) B6600247^^ C CLEAR THE PROMISED TO PAY FLAG B6600248^^ 97 CALL CCSPUT ( $4B, J+284, DEQREC ) B6600249^^ 98 GO TO 230 B6600250^  ^ C PROMISE BROKEN, INCREMENT THE BROKEN COUNT B6600253^^ 99 224 DEQREC(K+519) = AND(DEQREC(K+519),$FF0F) + $31 B6600254^^ 100 IF ( AND(DEQREC(K+519),$FF) .GT. $39 ) B6600255^^ 100 1 DEQREC(K+519) = AND(DEQREC(K+519),$FFF) + $30F6 B6600256^^ C SET THE PROMISED TO PAY FLAG TO BROKEN B6600257^^ 101 CALL CCSPUT ( $42, J+284, DEQREC ) B6600258^^ 102 CALL CCSMVA ( NINETH , 1 , 4 , DEQREC , J+280 , 4 ) B6600259^t FTN 3.3B (OPT = LPC) DACRTE PAGE 10 DATE: 08/29/84 TIME: 2131 t^ C BUILD THE DLYASSN RECORD - ACCT #, QUEUE, NEXTCD, PRIORITY B6600261^^ 103 230 CALL CCSMVA ( DEQREC, J, 16, ASNREC, L, 16) B6600262^^ 104 CALL CCSMVA ( DEQREC, J+270, 14, ASNREC, L+16, 14 ) B6600263^  ^ C**** IF ADDITIONAL FIELDS ARE REQUIRED IN THE DLYASSN RECORD, B6600265^^ C THEY SHOULD BE MOVED IN AT THIS POINT B6600266^  ^ 105 M = M + 1 B6600268^^ 106 300 CONTINUE B6600269^ ^ C SAVE THE DLYASSN RECORD B6600271^^ 107 M = M - 1 B6600272^^ 108 IF ( M .EQ. 0 ) GO TO 310 B6600273^^ 109 CALL PUTS ( ASNREQ, ASNREC, M, ISTAT ) B6600274^^ 110 IF (ISTAT.GE.0) GO TO 305 B6600275^^ 111 CALL FILERR ( ADATA, 11, ISTAT, LU ) B6600276^^ 112 GO TO 900 B6600277^^ C UPDATE THE RECORDS IN THE DELQMST FILE B6600278^^ 113 305 CALL UPDREC ( DEQREQ, DEQREC, ISTAT ) B6600279^^ C FILE ERROR? B6600280^^ 114 IF (ISTAT.GE.0) GO TO 310 B6600281^^ 115 CALL FILERR ( DDATA, 15, ISTAT, LU ) B6600282^^ 116 GO TO 900 B6600283^^ C BLANK OUT THE DELQ BUFFER AND CONTINUE B6600284^^ 117 310 CALL CCSBLK ( DEQREC, 30000 ) B6600285^^ 118 CALL CCSBLK (DEQREC(15001),16000) B6600286^^ 119 CALL CCSBLK ( ASNREC, 920 ) B6600287^^ 120 M = 1 B6600288^^ 121 IF (EFG.EQ.0) GO TO 200 B6600289^ ^ C CLOSE THE FILES AND STOP B6600291^^ 122 900 CALL CLOSFL ( DEQREQ, ISTAT ) B6600292^^ 123 CALL CLOSFL ( ASNREQ, ISTAT ) B6600293^^ 124 CALL PGMOUT B6600294^^ 125 END B6600295^t FTN 3.3B (OPT = LPC) DACRTE PAGE 11 DATE: 08/29/84 TIME: 2131 t  PROGRAM LENGTH $602F ( 24623)   EXTERNALS 2 Q8STP FMRDEL PGMIN CCSBLK UTHEAD OPENFL FILERR 22 CLEAR GETS GETACF CCSMVA FTNDT1 CCSCST ICALJL 2, JULCAL CCSPUT PUTS UPDREC CLOSFL PGMOUT , t FTN 3.3B (OPT = LPC) DACRTE PAGE 12 DATE: 08/29/84 TIME: 2131 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < $ 8100 (-32511) 5CD5 36,36$" FF00 (-255) 5CF0 78 "$ FF0F (-240) 5CFA 89,99$‚ 0001 (1) 0002 6,14,22,29,37,41,44,50,51,52,53,54,55,56,57,58,60,61,63,64,66,67,68,69,70,71,72,73,74,76,77,81,83, ‚4 87,94,102,105,107,12046 0002 (2) 5CDD 44,51,60,61,67,76,79,856. 0003 (3) 5CD3 25,33,52,68,85 .8 0004 (4) 5CEC 62,62,64,69,77,81,87,102 8" 0005 (5) 5CF2 79 "X 0006 (6) 5CE1 50,51,52,53,54,55,56,57,58,63,66,67,68,69,70,71,72,73,74 X. 0007 (7) 5CE2 51,56,67,72,92 .$ 0009 (9) 5CF6 83,83$" 000B (11) 5D05 111"$ 000D (13) 5CE3 52,68$& 000E (14) 5CD7 39,104 &" 000F (15) 5D06 115"* 0010 (16) 5D04 103,103,104*$ 0013 (19) 5CE4 53,69$$ 0019 (25) 5CE5 54,70$$ 001F (31) 5CE6 55,71$$ 0025 (37) 5CE7 56,72$$ 002B (43) 5CE8 57,73$* 0031 (49) 5CE9 58,74,89,99*" 0042 (66) 5D03 101"" 004B (75) 5D01 96 "" 00F6 (246) 5D00 95 ". 00FF (255) 5CDF 46,49,90,95,100.$ 0100 (256) 5CD6 37,37$( 010E (270) 5CEB 62,64,104($ 0112 (274) 5CFE 91,96$& 0118 (280) 5CEF 77,102 && 011C (284) 5D02 97,101 &" 0127 (295) 5CED 62 "" 012B (299) 5CEE 63 "" 016D (365) 5CFF 93 "& 0398 (920) 5CCE 18,119 &" 03E7 (999) 5CDB 43 "" 03E8 (1000) 5CDA 43 "" 03F7 (1015) 5CF5 81 "" 03FB (1019) 5CF3 79 "" 03FD (1021) 5CF7 83 "" 0410 (1040) 5CF9 87 "" 0414 (1044) 5CF8 85 "& 0FFF (4095) 5CFB 90,100 &" 2020 (8224) 5CDE 45 "" 3030 (12336) 5CD0 19 "t FTN 3.3B (OPT = LPC) DACRTE PAGE 13 DATE: 08/29/84 TIME: 2131 t" 3031 (12337) 5CE0 47 "& 30F6 (12534) 5CFC 90,100 &( 3939 (14649) 5CEA 61,61,76 (" 3E80 (16000) 5D08 118"" 5900 (22784) 5CF1 78 "" 7530 (30000) 5D07 117"   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < 2 ADATA INTEGER 0042 1,6,27,29,31,33,1112> AND INTR.FN. 7FFF 36,37,46,49,78,89,90,95,99,100 >4 ASNREC INTEGER 5AA9 1,18,103,104,109,119 40 ASNREQ INTEGER 001B 1,4,27,31,109,12302 DDATA INTEGER 0033 1,5,21,23,25,39,1152‚ DEQREC INTEGER 00D1 1,35,45,46,48,49,50,51,52,53,54,55,56,57,58,60,62,63,64,66,68,69,70,71,72,73,74,77,78,79,81,83,85, ‚Z 87,89,90,91,94,95,96,97,99,100,101,102,103,104,113,117,118 Z0 DEQREQ INTEGER 0003 1,4,23,35,113,1220, DT INTEGER 0053 1,20,63,79,81,* EFG INTEGER 0052 1,7,37,121 *& FDEL INTEGER 00D0 1,17,45&$ HD INTEGER 005A 1,20 $( I INTEGER 5CD4 35,41,43 (< ICOMP INTEGER 5CF4 79,80,81,82,83,84,85,86,87,88<. IK INTEGER 5CFD 90,91,92,93,96 .* IOSW INTEGER 5CCF 18,19,47,48*h ISTAT INTEGER 5CD2 23,24,25,27,28,29,31,32,33,35,36,37,38,39,109,110,111,113,114,115,122,123h€ J INTEGER 5CDC 43,44,50,51,52,53,54,55,56,57,58,62,63,64,66,68,69,70,71,72,73,74,77,79,81,83,85,87,91,96,97,101,€* 102,103,104*L K INTEGER 5CD9 42,43,44,45,46,48,49,60,78,89,90,94,95,99,100L, L INTEGER 5CD8 41,42,103,104,$ LAMT INTEGER 5CCA 14,83$( LDATE INTEGER 5CC9 14,85,87 (& LTHACT INTEGER 5CC3 1,7,48 &6 LU INTEGER 5CCB 16,25,29,33,39,111,115 6< M INTEGER 5CD1 21,22,42,105,107,108,109,120 <" MODE INTEGER 5CCC 16 "( NINETH INTEGER 5CC7 8,10,102 (" NPORT INTEGER 5CCD 16 "* NPRI INTEGER 00CE 1,75,76,77 *, NQUE INTEGER 00CC 1,59,60,61,64,& NUMREC INTEGER 5CC5 6,21,41&@ PRI INTEGER 0096 1,8,66,67,68,69,70,71,72,73,74,75@< PRIL INTEGER 5C92 1,14,66,68,69,70,71,72,73,74 << PRIP INTEGER 5C89 1,13,66,68,69,70,71,72,73,74 <& QIMG INTEGER 5CC6 8,10,67&@ QUE INTEGER 00B1 1,8,50,51,52,53,54,55,56,57,58,59@> QUEL INTEGER 5C80 1,12,50,51,52,53,54,55,56,57,58>> QUEP INTEGER 5C77 1,11,50,51,52,53,54,55,56,57,58>" ST INTEGER 0051 1,7"$ STG INTEGER 5C9B 1,48 $t FTN 3.3B (OPT = LPC) DACRTE PAGE 14 DATE: 08/29/84 TIME: 2131 t$ USER INTEGER 0056 1,16 $   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < . CCSBLK SUBROUTINE 6013 17,117,118,119 .. CCSCST SUBROUTINE 5F06 78,81,83,85,87 .l CCSMVA SUBROUTINE 5FC9 49,51,52,53,54,55,56,57,58,62,63,64,66,67,68,69,70,71,72,73,74,77,102,103,104l& CCSPUT SUBROUTINE 5FA9 96,101 &" CLEAR SUBROUTINE 5D33 27 "& CLOSFL SUBROUTINE 6025 122,123&2 FILERR SUBROUTINE 5FFE 24,29,33,39,111,1152$ FTNDT1 SUBROUTINE 5EDE 58,75$" GETACF SUBROUTINE 5DAA 47 "" GETS SUBROUTINE 5D50 35 "" ICALJL INTEGER.FN. 5F83 91 "" JULCAL SUBROUTINE 5FA0 96 "$ OPENFL SUBROUTINE 5D23 22,31$" PGMIN SUBROUTINE 5D0A 14 "" PGMOUT SUBROUTINE 602C 123"" PUTS SUBROUTINE 5FF4 108" Q8STP INTEGER.FN. 602E " UPDREC SUBROUTINE 6005 113"" UTHEAD SUBROUTINE 5D1A 19 "   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 100 5D32 24,27$$ 110 5D41 28,31$( 200 5D4F 32,35,121($ 210 5D6F 38,41$* 220 5E72 49,60,61,65*$ 222 5F9B 93,96$* 224 5FAE 84,86,88,99*$ 225 5EF5 76,78$. 230 5FD0 78,80,82,98,103., 300 5FE9 41,45,46,106 ,& 305 6004 110,113&* 310 6012 108,114,117*: 900 6024 25,30,34,36,40,112,116,122 :$ 2251 5F18 80,81$$ 2252 5F29 80,83$$ 2253 5F55 86,87$$ 2254 5F69 86,89$ DACRTE 0000 1 t FTN 3.3B (OPT = LPC) DAQUEL PAGE 1 DATE: 08/29/84 TIME: 2132 t^ 1 PROGRAM DAQUEL B3700001^^ 1 1 /B37 F CCS CCS 3.0 SL-149B3700002^^ C B3700003^^ C CYBERCREDIT SYSTEM VERSION 3 B3700004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B3700005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B3700006^^ C B3700007^ ^ C THIS PROGRAM LOCATES THE STARTING ACCOUNT FOR REVIEW FOR B3700009^^ C EACH QUEUE WITHIN THE DAILY ASSIGNMENT FILE. IT SAVES THE B3700010^^ C RELATIVE RECORD POINTER ALONG WITH THE QUEUE IDENTIFIER B3700011^^ C SO THAT COLECT CAN LOCATE THE START FOR EACH QUEUE'S B3700012^^ C AUTOMATIC FUNCTION B3700013^ ^ 2 INTEGER DLYREC(20),DLYREQ(24),QREQ(24),QREC(6),DDATA(15), B3700015^^ 2 1 QDATA(15),USER(4),QUEUE(2) B3700016^ ^ 3 DATA DDATA / 'DLYASSN ', 8*$2020, 0, 1, 0 / B3700018^^ 4 DATA QDATA / 'DAQUE ', 8*$2020, 0, 1, 0 / B3700019^ ^ 5 DATA DLYREQ, QREQ / 48*0 / B3700021^ ^ 6 DATA QUEUE / 0,0 / B3700023^ ^ C ACCEPT LOG ON FROM ITOS, VERIFY MASTER CONSOLE B3700025^^ 7 CALL PGMIN (USER,LU,MODE,NPORT) B3700026^^ 8 IF (NPORT.NE.0) CALL PGMOUT B3700027^ ^ C OPEN FILES FOR USE B3700029^^ 9 CALL OPENFL (DLYREQ,DDATA,ISTAT) B3700030^^ 10 IF (ISTAT.LT.0) GO TO 900 B3700031^^ 11 CALL OPENFL (QREQ,QDATA,ISTAT) B3700032^^ 12 IF (ISTAT.LT.0) GO TO 905 B3700033^ ^ C GET NEXT RECORD FROM THE ASSIGNMENT FIEL B3700035^^ 13 100 CALL GETS (DLYREQ,DLYREC,I,ISTAT) B3700036^^ 14 IF (AND(ISTAT,$100).EQ.$100) GO TO 950 B3700037^^ 15 IF (ISTAT.LT.0) GO TO 910 B3700038^^ C CHECK IF ON SAME QUEUE B3700039^^ 16 IF (QUEUE(1).EQ.DLYREC( 9).AND. B3700040^^ 16 2 QUEUE(2).EQ.DLYREC(10)) GO TO 100 B3700041^^ C NEW QUEUE, SAVE IN DAQUE B3700042^^ 17 QREC(1)=DLYREC( 9) B3700043^^ 18 QREC(2)=DLYREC(10) B3700044^^ 19 QREC(3)=DLYREQ(16) B3700045^^ 20 QREC(4)=DLYREQ(17) B3700046^^ 21 CALL WRITER (QREQ,QREC,QREC,ISTAT) B3700047^^ 22 IF (ISTAT.LT.0) GO TO 915 B3700048^^ 23 QUEUE(1)=DLYREC( 9) B3700049^^ 24 QUEUE(2)=DLYREC(10) B3700050^^ 25 GO TO 100 B3700051^^ 26 900 CALL FILERR ( DDATA, 3, ISTAT, LU ) B3700052^^ 27 GO TO 950 B3700053^^ 28 905 CALL FILERR ( QDATA, 3, ISTAT, LU ) B3700054^t FTN 3.3B (OPT = LPC) DAQUEL PAGE 2 DATE: 08/29/84 TIME: 2132 t^ 29 GO TO 950 B3700055^^ 30 910 CALL FILERR ( DDATA, 14, ISTAT, LU ) B3700056^^ 31 GO TO 950 B3700057^^ 32 915 CALL FILERR ( QDATA, 12, ISTAT, LU ) B3700058^ ^ 33 950 CALL CLOSFL(DLYREQ,ISTAT) B3700060^^ 34 CALL CLOSFL(QREQ,ISTAT) B3700061^^ 35 CALL PGMOUT B3700062^^ 36 END B3700063^t FTN 3.3B (OPT = LPC) DAQUEL PAGE 3 DATE: 08/29/84 TIME: 2132 t  PROGRAM LENGTH $00E9 ( 233)   EXTERNALS 2 Q8STP PGMIN PGMOUT OPENFL GETS WRITER FILERR 2 CLOSFL  t FTN 3.3B (OPT = LPC) DAQUEL PAGE 4 DATE: 08/29/84 TIME: 2132 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < $ 0003 (3) 0075 26,28$" 000C (12) 0077 32 "" 000E (14) 0076 30 "$ 0100 (256) 0074 14,14$   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " AND INTR.FN. 7FFF 14 "* DDATA INTEGER 004B 1,3,9,26,30*2 DLYREC INTEGER 0001 1,13,16,17,18,23,2420 DLYREQ INTEGER 0015 1,5,9,13,19,20,330" I INTEGER 0073 13 "J ISTAT INTEGER 0072 9,10,11,12,13,14,15,21,22,26,28,30,32,33,34J, LU INTEGER 006F 7,26,28,30,32, MODE INTEGER 0070 7 " NPORT INTEGER 0071 7,8", QDATA INTEGER 005A 1,4,11,28,32 ,0 QREC INTEGER 0045 1,17,18,19,20,21 0, QREQ INTEGER 002D 1,5,11,21,34 ,, QUEUE INTEGER 006D 1,6,16,23,24 ," USER INTEGER 0069 1,7"   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < $ CLOSFL SUBROUTINE 00E0 33,34$* FILERR SUBROUTINE 00C8 26,28,30,32*" GETS SUBROUTINE 0095 12 "$ OPENFL SUBROUTINE 0084 8,11 $ PGMIN SUBROUTINE 0079 6 $ PGMOUT SUBROUTINE 0082 8,35 $ Q8STP INTEGER.FN. 00E8 " WRITER SUBROUTINE 00B9 20 "t FTN 3.3B (OPT = LPC) DAQUEL PAGE 5 DATE: 08/29/84 TIME: 2132 t   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < ( 100 0094 12,16,25 ($ 900 00C7 10,26$$ 905 00CE 12,28$$ 910 00D4 15,30$$ 915 00DA 22,32$. 950 00DF 14,27,29,31,33 . DAQUEL 0000 1  t FTN 3.3B (OPT = LPC) DEBDT1 PAGE 1 DATE: 08/29/84 TIME: 2132 t^ 1 SUBROUTINE DEBDT1 ( ID, IAR, I) B3800001^^ 1 1 /B38 F CCS CCS 3.0 SL-149B3800002^^ C B3800003^^ C CYBERCREDIT SYSTEM VERSION 3 B3800004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B3800005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B3800006^^ C B3800007^^ 2 INTEGER IAR(1) B3800008^^ 3 WRITE (12, 9000) ID B3800009^^ 4 9000 FORMAT ( '0 ID=' , I4) B3800010^^ 5 WRITE (12, 9001) (IAR(J), J = 1, I) B3800011^^ 6 9001 FORMAT ( 25(1X, Z4)) B3800012^^ 7 RETURN B3800013^^ 8 END B3800014^t FTN 3.3B (OPT = LPC) DEBDT1 PAGE 2 DATE: 08/29/84 TIME: 2132 t  PROGRAM LENGTH $0040 ( 64)   EXTERNALS & Q8PKUP Q8PREP Q8QINI Q8QX Q8QEND & t FTN 3.3B (OPT = LPC) DEBDT1 PAGE 3 DATE: 08/29/84 TIME: 2132 t, ***** L I S T O F S Y M B O L S *****,   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " I INTEGER 7FFF 1,5"$ IAR INTEGER 7FFF 1,2,5$" ID INTEGER 7FFF 1,3"" J INTEGER 0000 5,5"   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  Q8PKUP INTEGER.FN. 0037 Q8PREP INTEGER.FN. 0034 Q8QEND INTEGER.FN. 000B Q8QINI INTEGER.FN. 0002 " Q8QX SUBROUTINE 0008 3,5"   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < " 9000 000D 2,4"" 9001 0028 5,6" DEBDT1 0031 1  t FTN 3.3B (OPT = LPC) DECMTN PAGE 1 DATE: 08/29/84 TIME: 2132 t^ 1 PROGRAM DECMTN B3900001^^ 1 1 /B39 F CCS CCS 3.0 1500 WD TB.SL-149********^^ C B3900003^^ C CYBERCREDIT SYSTEM VERSION 3 B3900004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B3900005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B3900006^^ C B3900007^^ C PROGRM MAINTAINS DECISION TABLE FILE B3900008^^ 2 INTEGER TABLE(1502) ********^^ 3 INTEGER CRT,TBTY(2),IDATA(15),REQBUF(24),USER(4) B3900010^^ 4 DATA REQBUF / 24*0 / B3900011^^ 5 DATA IDATA / 'DECTBL',9*$2020,0,1,0 / B3900012^^ 6 INTEGER TEMP(8) B3900013^^ 7 INTEGER CMDTB(8) B3900014^^ 8 DATA CMDTB / 'CRDEADDSPTDUEXDB'/ B3900015^^ 9 INTEGER Y, MSG(3), LN(3), ICMD(5), IU(2), IST(2) ********^^ 10 DATA Y/'Y '/, MSG / 'INPUT=' / B3900017^^ 11 DATA CRT / 4 /, TBTY / 'COPR' / B3900018^^ C TABLE LENGTH B3900019^^ 12 INTEGER COMTLN B3900020^^ 13 DATA COMTLN/1500/ ********^^ C DEBUG DUMP INDICATOR B3900022^^ 14 INTEGER DB B3900023^^ 15 DATA DB/0/ B3900024^  ^ C ACCEPT LOG ON FROM ITOS B3900026^^ 16 CALL PGMIN(USER,CRT,MODE,NPORT) B3900027^^ C**** IF NOT MASTER TERMINAL PRINTER LU = 05 ********^^ 17 NPLU = 12 ********^^ 18 IF (NPORT.NE.0) NPLU = 05 ********^ ^ 19 ASSIGN 150 TO INTRPT ********^^ 20 CALL PGMINT(INTRPT,INTRP) ********^ ^ C GET THE FILE FOR PROCESSING, IF FILE NOT DEFINED REPORT AS B3900031^^ C ERROR AND LEAVE. B3900032^ ^ 21 CALL OPENFL(REQBUF,IDATA,ISTAT) B3900034^^ C CHECK IF FILE PRESENT B3900035^^ 22 IF (ISTAT.LT.0) GO TO 8010 B3900036^^ 23 CALL CLOSFL(REQBUF,ISTAT) B3900037^  ^ C ASK USER WHICH TABLE TO USE, COLLECTOR OR PRIORITY B3900039^^ 24 WRITE(CRT,9000)COMTLN ********^^ 25 9000 FORMAT(' DECISION TABLE MAINTENCE PROGRAM IN (',I4,' WORDS)',/) ********^  ^ C USING ONLY 1 TABLE B3900043^^ 26 ITP = 1 B3900044^^ 27 150 WRITE (CRT, 9011) B3900045^^ 28 9011 FORMAT ( ' INPUT CR/DE/AD/DS/PT/DU/EX TO EITHER',/, B3900046^^ 28 1 ' CREATE A COMPLETE TABLE, DELETE A TEST, ADD A TEST',/, B3900047^t FTN 3.3B (OPT = LPC) DECMTN PAGE 2 DATE: 08/29/84 TIME: 2132 t^ 28 2 ' DISPLAY A TEST, PRINT THE TABLE, DUMP THE TABLE,',/, B3900048^^ 28 3 ' END PROCESSING',/) B3900049^^ 29 IF( DB .EQ. 1) CALL DEBDT1 (99,TABLE,1500) B3900050^^ 30 200 ICMD = 0 ********^^ 31 CALL WTREAD( CRT, -1, MSG, 6, -1, ICMD, 8, K ) ********^^ C DECODE COMMAND B3900052^^ C CREATE B3900053^^ 32 IF (ICMD .EQ. CMDTB(1) ) GO TO 1000 B3900054^^ C END B3900055^^ 33 IF (ICMD .EQ. CMDTB(7) ) GO TO 7000 B3900056^  ^ C GET THE TABLE B3900058^^ 34 TABLE(2) = COMTLN B3900059^^ 35 CALL RTVDT1(ITP,TABLE,IND) B3900060^^ 36 IF (IND .NE. 0) GO TO 8050 B3900061^^ C DELETE TEST B3900062^^ 37 IF ( ICMD .EQ. CMDTB(2)) GO TO 2000 B3900063^^ C ADD TEST B3900064^^ 38 IF ( ICMD .EQ. CMDTB(3)) GO TO 3000 B3900065^^ C DISPLAY B3900066^^ 39 IF ( ICMD .EQ. CMDTB(4)) GO TO 4000 B3900067^^ C PRINT B3900068^^ 40 IF (ICMD .EQ. CMDTB(5)) GO TO 5000 B3900069^^ C DUMP B3900070^^ 41 IF ( ICMD .EQ. CMDTB(6)) GO TO 6000 B3900071^^ C DEBUG B3900072^^ 42 IF ( ICMD .NE. CMDTB(8)) GO TO 900 B3900073^^ C TOGGLE DEBUG BIT B3900074^^ 43 DB = AND($1,DB+1) B3900075^^ 44 GO TO 150 B3900076^^ C ILLEGAL COMMAND B3900077^^ 45 900 WRITE(CRT,9012) ICMD(1) ********^^ 46 9012 FORMAT ( 'COMMAND ', A2, ' NOT IN TABLE, REENTER.') B3900079^^ 47 GO TO 200 B3900080^   ^ C CREATE NEW TABLE B3900082^^ C B3900083^^ 48 1000 WRITE (CRT, 9023) B3900084^^ 49 9023 FORMAT ( ' CREATE FUNCTION WILL CLEAR YOUR CURRENT TABLE FILE',/, B3900085^^ 49 1 ' TYPE Y IF YOU WISH TO DO THAT',/) B3900086^^ 50 CALL WTREAD ( CRT,-1, MSG, 6,-1, ICMD, 1, K ) B3900087^^ 51 IF (AND(ICMD,$FF00).NE.$5900) GO TO 150 B3900088^^ C GET RID OF OLD TABLE IF PRESENT B3900089^^ 52 CALL CLEAR(REQBUF,IDATA,ISTAT) B3900090^^ C VERIFY CLEAR WAS SUCESSFUL B3900091^^ 53 IF (ISTAT.LT.0) GO TO 8020 B3900092^^ C ASK IF INPUT FROM NON-CRT LU B3900093^^ 54 WRITE (CRT,9020) B3900094^^ 55 9020 FORMAT ( ' CREATE TABLE IN PROCESS, INPUT LU OF INPUT STREAM AS',B3900095^^ 55 1 /,' 2 NUMERIC DIGITS' ) B3900096^^ 56 WRITE ( CRT, 9022) B3900097^t FTN 3.3B (OPT = LPC) DECMTN PAGE 3 DATE: 08/29/84 TIME: 2132 t^ 57 9022 FORMAT ( ' IF LU 04 ENTERED, CREATION WILL BE VIA ADD TEST DIALOGB3900098^^ 57 1 ',/) B3900099^^ 58 CALL WTREAD ( CRT,-1, MSG, 6,-1, IST, 2, K ) B3900100^^ 59 9024 ILU = (AND(IST,$F00)/$100)*10 + AND(IST,$F) B3900101^^ C PASS CONTROL TO SUBROUTINE TO LOAD TABLE B3900102^^ 60 DO 1100 I = 1, COMTLN B3900103^^ 61 1100 TABLE(I) = 0 B3900104^^ C INITIALIZE TABLE LENGTH AND TYPE B3900105^^ 62 TABLE(2) = 10 B3900106^^ 63 TABLE(9) = COMTLN B3900107^^ 64 TABLE(4) = ITP B3900108^^ C BRANCH TO ADD IF LU = 04 B3900109^^ 65 IF (ILU .EQ. 4) GO TO 3000 B3900110^^ 66 CALL LDTDT1 ( TABLE, ILU, IND3) B3900111^^ C CHECK FOR ERROR B3900112^^ 67 IF ( IND3 .NE. 0) GO TO 8030 B3900113^^ C WRITE TABLE TO FILE B3900114^^ 68 DO 300 ISTAT = 1,24 B3900115^^ 69 300 REQBUF(ISTAT) = 0 B3900116^^ 70 CALL OPENFL(REQBUF,IDATA,ISTAT) B3900117^^ 71 CALL PUTS ( REQBUF, TABLE, 1, ISTAT ) B3900118^^ 72 IF ( ISTAT .LT. 0) GO TO 8040 B3900119^^ 73 CALL CLOSFL(REQBUF,ISTAT) B3900120^^ C TELL OPERATOR TABLE HAS BEEN LOADED B3900121^^ 74 WRITE (CRT, 9030) TBTY(ITP) B3900122^^ 75 9030 FORMAT ( 3X, A2, ' TABLE HAS BEEN FRESHLY LOADED') B3900123^^ 76 GO TO 150 B3900124^  ^ C DELETE TEST B3900126^^ 77 2000 CALL DELDT1 ( TABLE, CRT, IND) B3900127^^ 78 IF ( IND .LT. 0) GO TO 8060 B3900128^^ C UPDATE FILE B3900129^^ 79 GO TO 3100 B3900130^  ^ C ADD A TEST B3900132^^ C B3900133^^ 80 3000 CALL ADDDT1 (TABLE,CRT,IND) B3900134^^ 81 IF (IND .LT. 0) GO TO 150 B3900135^^ C CORE TABLE HAS BEEN UPDATED B3900136^^ C UPDATE DISK TABLE B3900137^^ C 1ST REMOVE OLD IMAGE B3900138^^ 82 3100 CALL CLEAR(REQBUF,IDATA,ISTAT) B3900139^^ 83 IF ( ISTAT .LT. 0) GO TO 8020 B3900140^^ 84 DO 310 ISTAT = 1,24 B3900141^^ 85 310 REQBUF(ISTAT) = 0 B3900142^^ 86 CALL OPENFL(REQBUF,IDATA,ISTAT) B3900143^^ 87 CALL PUTS ( REQBUF, TABLE, 1, ISTAT ) B3900144^^ 88 IF (ISTAT.LT.0) GO TO 8040 B3900145^^ 89 CALL CLOSFL(REQBUF,ISTAT) B3900146^^ 90 GO TO 150 B3900147^  t FTN 3.3B (OPT = LPC) DECMTN PAGE 4 DATE: 08/29/84 TIME: 2132 t^ C DISPLAY TEST ON CRT B3900149^^ 91 4000 WRITE ( CRT, 9040) B3900150^^ 92 9040 FORMAT ( ' DISPLAY TEST IN PROCESS. ENTER 3 DIGIT TEST NUMBER FOR B3900151^^ 92 1DISPLAY',/) B3900152^^ 93 CALL WTREAD ( CRT,-1, MSG, 6,-1, LN, 3, K ) B3900153^^ 94 LIN = AND(LN(1),$F00)/$100*100+AND(LN(1),$F)*10+ B3900154^^ 94 1 AND(LN(2),$F00)/$100 B3900155^^ 95 CALL DSPDT1 ( TABLE,LIN ,CRT,IND) B3900156^^ 96 IF (IND .EQ. 0) GO TO 150 B3900157^^ C ERROR IN DISPLAY MODULE, LINE NUM OUT OF RANGE B3900158^^ 97 WRITE (CRT, 9042) LIN B3900159^^ 98 9042 FORMAT (' ERROR IN LINE NUMBER', I4, ' NOT IN TABLE') B3900160^^ 99 GO TO 150 B3900161^  ^ C PRINT TABLE ON LP B3900163^^ 100 5000 CALL PRTDT1(TABLE,NPLU) ********^^ 101 WRITE (CRT, 9500) B3900165^^ 102 9500 FORMAT ( ' TABLE WAS PRINTED ON LINE PRINTER. ') B3900166^^ 103 GO TO 150 B3900167^  ^ C DUMP TABLE IN RELOADABLE FORMAT B3900169^^ 104 6000 WRITE ( CRT, 9060) B3900170^^ 105 9060 FORMAT ( ' DUMP TABLE IN PROCESS. TABLE WILL BE DUMPED IN FORM COMB3900171^^ 105 1PATIBLE' ,/, ' WITH CREATE FUNCTION. INPUT LU OF OUTPUT STREAM B3900172^^ 105 2AS 2 NUMERIC DIGITS ',/) B3900173^^ 106 CALL WTREAD ( CRT,-1, MSG, 6,-1, IU, 2, K ) B3900174^^ 107 LU = AND(IU,$F00)/$100*10+AND(IU,$F) B3900175^^ 108 CALL DPTDT1 ( TABLE, LU, IND) B3900176^^ 109 IF ( IND .NE. 0) GO TO 8070 B3900177^^ 110 WRITE ( CRT, 9061) LU B3900178^^ 111 9061 FORMAT ( ' TABLE DUMPED TO LU ', I3 ) B3900179^^ 112 GO TO 150 B3900180^^ 113 7000 CALL PGMOUT B3900181^    ^ C ERROR PROCESSING SECTION B3900183^^ C B3900184^^ 114 8010 WRITE (CRT,9801) B3900185^^ 115 9801 FORMAT ( ' FILE DECTBL NOT DEFINED. USE UTIL AND TRY AGAIN.') B3900186^^ 116 GO TO 8999 B3900187^^ 117 8020 WRITE (CRT,9802) ISTAT B3900188^^ 118 9802 FORMAT ( 'FILE DECTBL ERROR IN REMOVING ERROR-', Z4) B3900189^^ 119 GO TO 8999 B3900190^^ 120 8030 WRITE (CRT,9803) IND3 B3900191^^ 121 9803 FORMAT ( 'SUBROUTINE LDTABL ERROR-', Z4) B3900192^^ 122 GO TO 8999 B3900193^^ 123 8040 WRITE (CRT,9804) ISTAT B3900194^^ 124 9804 FORMAT ( 'FILE DECTBL ERROR IN STORING RECORD, ERROR-',Z4) B3900195^^ 125 GO TO 8999 B3900196^^ 126 8050 WRITE (CRT, 9805) IND B3900197^t FTN 3.3B (OPT = LPC) DECMTN PAGE 5 DATE: 08/29/84 TIME: 2132 t^ 127 9805 FORMAT ( ' NO DECISION TABLE IN SYSTEM, ERROR-', Z4) B3900198^^ 128 GO TO 8999 B3900199^^ 129 8060 WRITE ( CRT, 9806) IND B3900200^^ 130 9806 FORMAT ( 'SUBROUTINE DELDT1 ERROR-', Z4) B3900201^^ 131 GO TO 8999 B3900202^^ 132 8070 WRITE ( CRT, 9807) IND B3900203^^ 133 9807 FORMAT ( ' SUBROUTINE DPTDT1 ERROR-', Z4) B3900204^^ 134 GO TO 8999 B3900205^^ 135 8999 IF ( DB .EQ. 1) CALL DEBDT1 (8999, DECMTN, 12000) B3900206^^ 136 CALL PGMOUT B3900207^^ 137 END B3900208^t FTN 3.3B (OPT = LPC) DECMTN PAGE 6 DATE: 08/29/84 TIME: 2132 t  PROGRAM LENGTH $0B05 ( 2821)   EXTERNALS 2 Q8STP Q8QINI Q8QX Q8QEND PGMIN PGMINT OPENFL 22 CLOSFL DEBDT1 WTREAD RTVDT1 CLEAR LDTDT1 PUTS 2, DELDT1 ADDDT1 DSPDT1 PRTDT1 DPTDT1 PGMOUT , t FTN 3.3B (OPT = LPC) DECMTN PAGE 7 DATE: 08/29/84 TIME: 2132 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " FF00 (-255) 063F 51 "2 FFFE (-1) 063A 31,31,50,58,93,106 2V 0001 (1) 0002 5,26,29,31,32,43,45,50,58,60,68,71,84,87,93,94,106,135 V, 0002 (2) 0641 58,62,94,106 ," 0003 (3) 0648 93 "2 0006 (6) 063B 31,41,50,58,93,106 2$ 0008 (8) 063C 31,42$, 000A (10) 0644 59,62,94,107 ,( 000F (15) 0645 59,94,107(" 0063 (99) 0638 29 "" 0064 (100) 064A 94 "" 05DC (1500) 0639 29 "( 0F00 (3840) 0643 59,94,107(" 2327 (8999) 064C 135"" 2EE0 (12000) 064D 135"" 5900 (22784) 0640 51 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < . AND INTR.FN. 7FFF 43,51,59,94,107.: CMDTB INTEGER 0617 5,8,32,33,37,38,39,40,41,42:0 COMTLN INTEGER 062F 11,13,24,34,60,630€ CRT INTEGER 05E1 1,11,16,24,27,31,45,48,50,54,56,58,74,77,80,91,93,95,97,101,104,106,110,114,117,120,123,126,129, €" 132". DB INTEGER 0630 13,15,29,43,135.$ I INTEGER 0646 59,61$H ICMD INTEGER 0626 8,30,31,32,33,37,38,39,40,41,42,45,50,51 H2 IDATA INTEGER 05E4 1,5,21,52,70,82,86 2* ILU INTEGER 0642 58,59,65,66*J IND INTEGER 063E 35,36,77,78,80,81,95,96,108,109,126,129,132J( IND3 INTEGER 0647 66,67,120(" INTRP INTEGER 0635 20 "$ INTRPT INTEGER 0634 18,20$& IST INTEGER 062D 8,58,59&` ISTAT INTEGER 0636 21,22,23,52,53,68,69,70,71,72,73,82,83,84,85,86,87,88,89,117,123 `. ITP INTEGER 0637 25,26,35,64,74 .( IU INTEGER 062B 8,106,107(. K INTEGER 063D 31,50,58,93,106.* LIN INTEGER 0649 93,94,95,97*& LN INTEGER 0623 8,93,94&. LU INTEGER 064B 106,107,108,110." MODE INTEGER 0631 16 "t FTN 3.3B (OPT = LPC) DECMTN PAGE 8 DATE: 08/29/84 TIME: 2132 t4 MSG INTEGER 0620 8,10,31,50,58,93,106 4, NPLU INTEGER 0633 16,17,18,100 ,$ NPORT INTEGER 0632 16,18$F REQBUF INTEGER 05F3 1,4,21,23,52,69,70,71,73,82,85,86,87,89FP TABLE INTEGER 0003 1,29,34,35,61,62,63,64,66,71,77,80,87,95,100,108 P& TBTY INTEGER 05E2 1,11,74& TEMP INTEGER 060F 5 $ USER INTEGER 060B 1,16 $$ Y INTEGER 061F 8,10 $   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " ADDDT1 SUBROUTINE 08BD 80 "$ CLEAR SUBROUTINE 08C7 51,82$( CLOSFL SUBROUTINE 0886 22,73,89 (& DEBDT1 SUBROUTINE 0AFD 29,135 &" DELDT1 SUBROUTINE 08B1 77 "" DPTDT1 SUBROUTINE 09F5 107"" DSPDT1 SUBROUTINE 0938 94 "" LDTDT1 SUBROUTINE 085F 65 "( OPENFL SUBROUTINE 0876 20,70,86 (" PGMIN SUBROUTINE 064F 15 "" PGMINT SUBROUTINE 065F 18 "& PGMOUT SUBROUTINE 0B02 113,136&" PRTDT1 SUBROUTINE 096B 100"$ PUTS SUBROUTINE 087B 70,87$ Q8QEND INTEGER.FN. 0A86 Q8QINI INTEGER.FN. 0A7D F Q8QX SUBROUTINE 0A83 24,45,74,97,110,117,120,123,126,129,132F Q8STP INTEGER.FN. 0B04 " RTVDT1 SUBROUTINE 0724 34 ". WTREAD SUBROUTINE 09DC 30,50,58,93,106.   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < B 150 069B 18,27,44,51,76,81,90,96,99,103,112 B$ 200 0705 29,47$$ 300 086C 67,69$$ 310 08D2 83,85$$ 900 075F 42,45$$ 1000 0781 32,48$$ 1100 084A 59,61$$ 2000 08B0 37,77$( 3000 08BC 38,65,80 ($ 3100 08C6 78,82$$ 4000 08ED 39,91$t FTN 3.3B (OPT = LPC) DECMTN PAGE 9 DATE: 08/29/84 TIME: 2132 t& 5000 096A 40,100 && 6000 098B 41,104 && 7000 0A1B 33,113 && 8010 0A1D 22,114 &( 8020 0A40 53,83,117(& 8030 0A62 67,120 &( 8040 0A7C 72,88,123(& 8050 0AA3 36,126 && 8060 0AC3 78,129 && 8070 0ADD 109,132&> 8999 0AF8 115,119,122,125,128,131,134,135>$ 9000 067C 24,25$$ 9011 06A1 27,28$$ 9012 076B 45,46$$ 9020 07DA 54,55$$ 9022 080B 56,57$$ 9023 0787 48,49$" 9024 0834 58 "$ 9030 0899 74,75$$ 9040 08F3 91,92$$ 9042 0950 97,98$& 9060 0991 104,105&& 9061 0A0B 110,111&& 9500 0974 101,102&& 9801 0A23 114,115&& 9802 0A49 117,118&& 9803 0A6B 120,121&& 9804 0A88 123,124&& 9805 0AAC 126,127&& 9806 0ACC 129,130&& 9807 0AE6 132,133&$ DECMTN 0000 1,135$ t FTN 3.3B (OPT = LPC) DELDT1 PAGE 1 DATE: 08/29/84 TIME: 2133 t^ 1 SUBROUTINE DELDT1 ( TABLE , ILU , IND ) B4000001^^ 1 1 /B40 F CCS CCS 3.0 SL-149B4000002^^ C B4000003^^ C CYBERCREDIT SYSTEM VERSION 3 B4000004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B4000005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B4000006^^ C B4000007^^ 2 INTEGER WP, INPUT(3), Y, MSG(3) B4000008^^ 3 INTEGER TABLE(11), TABLEN, CURPOS, TRES B4000009^^ 4 EQUIVALENCE ( TABLE(2),TABLEN), (TABLE(10), CURPOS), B4000010^^ 4 1(TABLE(9), MAXTAB), (TABLE(8), LSTLFG), (TABLE(7), TRES) , B4000011^^ 4 2 (ICTST,TABLE(5)) B4000012^^ C TABLEN - TOTAL TABLE LENGTH B4000013^^ C CURPOS - CURRENT OFFSET IN TABLE TO CCSPUT THE NEXT DATA B4000014^^ C MAXTAB - MAXIMUM TABLE LENGTH AS DEFINED AT COMPILATION B4000015^^ C LSTLFG - LAST TEST FLAG ( =1 IF ADDING TEST TO TABLE END) B4000016^^ C TRES - OFFSET IN TABLE TO NUMBER OF RESULTS FIELD B4000017^^ C ICTST - OFFSET TO BEGINNING OF THIS TEST B4000018^^ 5 DATA LVL /0/, NLVL /0/, NP/0/, Y/'Y '/, MSG / 'INPUT=' / B4000019^^ 6 IND = 0 B4000020^  ^ C DETERMINE NUMBER OF TESTS IN TABLE B4000022^^ 7 IMAXT = 0 B4000023^^ 8 LC = 11 B4000024^^ C CHECK FOR NEW TABLE B4000025^^ 9 IF ( TABLEN .EQ. 10) GO TO 200 B4000026^^ 10 100 IF ( TABLE(LC) .EQ. 0) GO TO 150 B4000027^^ 11 IMAXT = IMAXT + 1 B4000028^^ 12 LC = LC + TABLE(LC) B4000029^^ 13 IF (LC .GT. TABLEN + 1) GO TO 8000 B4000030^^ 14 GO TO 100 B4000031^^ C END OF TABLE - VERIFY B4000032^^ 15 150 IF ( TABLEN .NE. LC - 1) GO TO 8000 B4000033^  ^ 16 200 WRITE ( ILU,9000) IMAXT B4000035^^ 17 9000 FORMAT ( ' DELETE TEST IN PROCESS. THERE ARE ',I3, ' TESTS CURRENB4000036^^ 17 1TLY IN TABLE ' ,/, ' ENTER 3-DIGIT NUMBER OF TEST TO BE DELETE'/)B4000037^^ 18 CALL WTREAD ( ILU, -1, MSG, 6, -1, INPUT, 3, LN ) B4000038^^ 19 LN = AND(INPUT(1),$F00)/$100*100 + B4000039^^ 19 1 AND(INPUT(1),$F)*10 + B4000040^^ 19 2 AND(INPUT(2),$F00)/$100 B4000041^^ C MAKE SURE LINE NUM IS WITHIN RANGE B4000042^^ 20 IF ( LN .LE. 0 .OR. LN .GT. IMAXT) GO TO 200 B4000043^  ^ 21 285 WRITE ( ILU, 9035) LN B4000045^^ 22 9035 FORMAT ( ' TEST TO DELETE NUMBER IS ',I3, ' TYPE Y IF CORB4000046^^ 22 1RECT, TYPE N TO ENTER AGAIN.',/) B4000047^^ 23 CALL WTREAD ( ILU, -1, MSG, 6, -1, INPUT, 1, I ) B4000048^^ 24 INPUT(1) = AND(INPUT(1),$FF00) + $20 B4000049^^ 25 IF ( INPUT(1) .NE. Y ) RETURN B4000050^^ C FIND POSITION IN TABLE OF TEST B4000051^t FTN 3.3B (OPT = LPC) DELDT1 PAGE 2 DATE: 08/29/84 TIME: 2133 t^ 26 CALL GTPDT1 ( TABLE, LN, WP) B4000052^^ 27 ICTST = WP B4000053^^ 28 CURPOS = ICTST + TABLE(ICTST) B4000054^^ C CCSGET TEST OUT OF TABLE B4000055^^ 29 INW = CURPOS - ICTST B4000056^^ 30 DO 500 I = CURPOS, TABLEN B4000057^^ 31 J = I - INW B4000058^^ 32 500 TABLE(J) = TABLE(I) B4000059^^ 33 TABLEN = TABLEN - INW B4000060^^ 34 RETURN B4000061^^ 35 8000 IND = $8001 B4000062^^ 36 RETURN B4000063^^ 37 END B4000064^t FTN 3.3B (OPT = LPC) DELDT1 PAGE 3 DATE: 08/29/84 TIME: 2133 t  PROGRAM LENGTH $0151 ( 337)   EXTERNALS 2 Q8PKUP Q8PREP Q8QINI Q8QX Q8QEND WTREAD GTPDT1 2 t FTN 3.3B (OPT = LPC) DELDT1 PAGE 4 DATE: 08/29/84 TIME: 2133 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " 8001 (-32766) 001A 35 "" FF00 (-255) 0017 24 "( FFFE (-1) 000F 18,18,23 (6 0001 (1) 0000 11,13,15,18,19,23,24,256" 0003 (3) 0011 18 "$ 0006 (6) 0010 18,23$$ 000A (10) 000E 9,19 $" 000F (15) 0015 19 "" 0064 (100) 0014 19 "$ 0F00 (3840) 0013 19,19$   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < ( AND INTR.FN. 7FFF 19,19,24 (, CURPOS INTEGER 7FFF 3,4,28,29,30 ,* I INTEGER 0016 23,30,31,32** ICTST INTEGER 7FFF 4,27,28,29 *, ILU INTEGER 7FFF 1,16,18,21,23,, IMAXT INTEGER 000C 6,7,11,16,20 ,& IND INTEGER 7FFF 1,6,35 &0 INPUT INTEGER 0002 1,18,19,23,24,25 0* INW INTEGER 0018 28,29,31,33*( J INTEGER 0019 30,31,32 (. LC INTEGER 000D 7,8,10,12,13,15.. LN INTEGER 0012 18,19,20,21,26 . LSTLFG INTEGER 7FFF 4 LVL INTEGER 0009 4 MAXTAB INTEGER 7FFF 4 ( MSG INTEGER 0006 1,5,18,23( NLVL INTEGER 000A 5 NP INTEGER 000B 5 4 TABLE INTEGER 7FFF 1,3,4,10,12,26,28,32 40 TABLEN INTEGER 7FFF 3,4,9,13,15,30,330" TRES INTEGER 7FFF 3,4"& WP INTEGER 0001 1,26,27&& Y INTEGER 0005 1,5,25 &t FTN 3.3B (OPT = LPC) DELDT1 PAGE 5 DATE: 08/29/84 TIME: 2133 t   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " GTPDT1 SUBROUTINE 00FF 25 " Q8PKUP INTEGER.FN. 0133 Q8PREP INTEGER.FN. 0130 Q8QEND INTEGER.FN. 004B Q8QINI INTEGER.FN. 0042 $ Q8QX SUBROUTINE 0048 16,21$$ WTREAD SUBROUTINE 008C 17,23$   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 100 0024 9,14 $$ 150 0039 10,15$& 200 0041 9,16,20&" 285 00B6 20 "$ 500 011A 29,32$( 8000 0126 13,15,35 ($ 9000 004D 16,17$$ 9035 00C1 21,22$ DELDT1 012D 1  t FTN 3.3B (OPT = LPC) DHUPDT PAGE 1 DATE: 08/29/84 TIME: 2134 t^ 1 PROGRAM DHUPDT B4200001^^ 1 1 /B42 F CCS CCS 3.0 .LA - PSRD 07-83 SL-149********^^ C B4200003^^ C CYBERCREDIT SYSTEM VERSION 3 B4200004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B4200005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B4200006^^ C B4200007^  ^ C THIS PROGRAM SEQUENTIALLY READS THE ADDACT FILE AND CHECKS FOR B4200010^^ C STATUS OF A IN COLUMN 17. WHEN A VALID RECORD IS FOUND, THE B4200011^^ C PROGRAM CHECKS TO SEE IF THE ACCOUNT EXISTS IN THE SUMHIST FILE. B4200012^^ C IF IT EXISTS, THE INFORMATION IN THE SUMHIST RECORD IS MOVED TO B4200013^^ C THE DELQMST FIELDS. THIS INFO WILL APPEAR IN THE CURRENT FIELDS, B4200014^^ C IF THE CURRENT FIELDS ARE BLANK, ELSE THE INFO WILL APPEAR IN THE B4200015^^ C PREVIOUS FIELDS. THE SUMHIST RECORD IS DELETED AFTER ALL INFO B4200016^^ C IS RETRIEVED. THE TAPEARC FILE IS ALSO CHECKED TO SEE IF THE B4200017^^ C ACCOUNT EXISTS. IF SO,THE TAPE ARCHIVE DATE IS MOVED TO THE B4200018^^ C THE DELQMST. FOR EACH ACCOUNT UPDATED, A RECORD IS WRITTEN TO B4200019^^ C THE PRINTER. B4200020^^ C ???*A078********^^ C ********^^ C PSR A078 MADE THE FOLLOWING CHANGES:- ********^^ C 1. THE ACTIVITY BLOCK FROM IS NOT ********^^ C MOVED TO . ********^^ C 2. THE ACTIVITY BLOCK FROM IS WRITTEN ********^^ C TO AS A NEW RECORD. ********^^ C ********^^ C THE REASON FOR THESE CHANGES IS THAT WILL READ ********^^ C WHEN IT NEEDS TO DISPLAY ACTIVITIES AND THE ********^^ C DATE OF ENTRIES IN DIFFERS FROM SYSTEM DATE. ********^^ C THE ORIGINAL IDEA WAS THAT THE LAST FEW ACTIVITIES WERE ********^^ C SAVED BOTH IN AND , BUT DOES NOT ********^^ C DISPLAY DUPLICATED ACTIVITIES ANYWAY. ********^^ C THEREFORE, THERE IS NO REASON TO STORE OLD ACTIVITIES ********^^ C IN . ********^^ C ???*A078********^  ^ 2 INTEGER ADDREQ(24),TAPREQ(24),SUMREQ(24),DELREQ(24) B4200022^^ 3 INTEGER ADATA(15),TDATA(15),SDATA(15),DDATA(15) B4200023^^ 4 INTEGER ADDREC(364),TAPREC(48),SUMREC(668),DELQRC(2002) B4200024^^ 5 INTEGER DELKEY(8),TAPKEY(8),SUMKEY(8) B4200025^^ C ???*A078********^^ 6 INTEGER ACTDAT(15), ACTREQ(24), ACTREC(252) ********^^ 6 1 , ROOM(3) ********^^ C ???*A078********^ ^ 7 INTEGER A,BLK(180),DELETE,DT(3),EOF,FDEL,FMRDEL B4200027^^ 8 INTEGER HDR(60),IDUSER(4),MPOS(9),MPPOS,MLEN(9) B4200028^^ 9 INTEGER PRT,PRTLN(66),SPOS(9),PAGE B4200029^^ 10 INTEGER UPD,ZERO(7),ONE(5),ICNT(6) B4200030^^ C ****************************************************** ???*A012********^^ 11 INTEGER MSG(10) ********^t FTN 3.3B (OPT = LPC) DHUPDT PAGE 2 DATE: 08/29/84 TIME: 2134 t^ C ****************************************************** ???*A012********^ ^ 12 INTEGER TDAT(4),SDAT(4),DDAT(4) ********^ ^ 13 DATA TDAT/'TAPEARC '/,SDAT/'SUMHIST '/,DDAT/'DELQMST '/ ********^^ 14 DATA ADATA/'LAADDACT',8*$2020,0,20,-1/ ********^^ 15 DATA TDATA/'LATAPARC',8*$2020,1, 1,-1/ ********^^ 16 DATA SDATA/'LASUMHST',8*$2020,1, 1,-1/ ********^^ 17 DATA DDATA/'LADLQMST',8*$2020,1,1,1/ ********^^ C ???*A078********^^ 18 DATA ACTDAT/'LAACTFIL',8*$2020,1,1,0/ ********^^ 18 1 , ACTREQ/24*0/ ********^^ C ???*A078********^^ C ****************************************************** ???*A012********^^ 19 DATA MSG / 'TAPEARC RECORD ONLY ' / ********^^ C ****************************************************** ???*A012********^ ^ 20 DATA ADDREQ/24*0/,TAPREQ/24*0/,SUMREQ/24*0/,DELREQ/24*0/ B4200037^^ 21 DATA A/'A '/,BLK/180*$2020/,LIN/0/,ZERO/7*$3030/ B4200038^^ 22 DATA ONE/4*$3030,$3130/,ICNT/6*$3030/,PRT/$100C/ B4200039^^ 23 DATA PAGE/0/ B4200040^t FTN 3.3B (OPT = LPC) DHUPDT PAGE 3 DATE: 08/29/84 TIME: 2134 t^ C DISCRIPTIONS OF MPOS AND SPOS B4200042^^ C FIELD DELQMST SUMHIST B4200043^^ C MADR1 48 54 B4200044^^ C MADR2 78 84 B4200045^^ C MCS 108 114 B4200046^^ C MZP 128 134 B4200047^^ C MPHN 133 139 B4200048^^ C MBNM 147 149 B4200049^^ C MBPHN 232 179 B4200050^^ C MBEX 242 189 B4200051^^ C MACT 307 193 B4200052^^ C MUPDT 863 17 B4200053^^ C MP1 667 553 B4200054^^ C MP2 697 583 B4200055^^ C MP3 727 613 B4200056^ ^ C MADR1, MADR2, MCS AND MZP ARE TREATED AS ONE BLOCK OF DATA B4200058^^ C MBPHN AND MBEX ARE TREATED AS ONE BLOCK OF DATA B4200059^ ^ C 1 2 3 4 5 6 7 8 9 B4200061^^ 24 DATA MPOS/ 48, 133, 147, 232, 307, 863, 667, 697, 727/ B4200062^^ 25 DATA MLEN/ 85, 10, 30, 14, 360, 6, 30, 30, 30/ B4200063^^ 26 DATA SPOS/ 54, 139, 149, 179, 193, 17, 553, 583, 613/ B4200064^^ 27 DATA MPPOS/757/ B4200065^ ^ 28 EXTERNAL FMRDEL B4200067^t FTN 3.3B (OPT = LPC) DHUPDT PAGE 4 DATE: 08/29/84 TIME: 2134 t^ 29 CALL PGMIN(IDUSER,LU,MODE,NOPORT) B4200069^^ C CHECK FOR MASTER TERMINAL B4200070^^ 30 IF(NOPORT.NE.0) GO TO 990 B4200071^^ 31 CALL CCSCST(ADATA,1,2,IDUSER,1,8,ICM) ********^^ 32 IF (ICM.EQ.0) GOTO 5 ********^^ 33 CALL CCSMVA(ADATA,3,6,ADATA,1,8) ********^^ 34 CALL CCSMVA(TDAT ,1,8,TDATA,1,8) ********^^ 35 CALL CCSMVA(SDAT ,1,8,SDATA,1,8) ********^^ 36 CALL CCSMVA(DDAT ,1,8,DDATA,1,8) ********^^ 37 CALL CCSMVA(ACTDAT,3,6,ACTDAT,1,8) ********^^ 38 5 CONTINUE ********^ ^ C BRING IN DATE, HEADERS AND DELETE CODE B4200073^^ 39 CALL UTHEAD(HDR,DT) B4200074^^ 40 ASSEM $C000,FMRDEL,$6800,FDEL B4200075^ ^ C OPEN ADDACT FILE B4200077^^ 41 CALL OPENFL(ADDREQ,ADATA,ISTAT) B4200078^^ 42 IF(ISTAT.GE.0) GO TO 100 B4200079^^ 43 CALL FILERR(ADATA,3,ISTAT,LU) B4200080^^ 44 GO TO 990 B4200081^ ^ C OPEN TAPEARC FILE B4200083^^ 45 100 CALL OPENFL(TAPREQ,TDATA,ISTAT) B4200084^^ 46 IF(ISTAT.GE.0) GO TO 120 B4200085^^ 47 CALL FILERR(TDATA,3,ISTAT,LU) B4200086^^ 48 GO TO 980 B4200087^ ^ C OPEN SUMHIST FILE B4200089^^ 49 120 CALL OPENFL(SUMREQ,SDATA,ISTAT) B4200090^^ 50 IF(ISTAT.GE.0) GO TO 140 B4200091^^ 51 CALL FILERR(SDATA,3,ISTAT,LU) B4200092^^ 52 GO TO 970 B4200093^ ^ C OPEN DELQMST FILE B4200095^^ 53 140 CALL OPENFL(DELREQ,DDATA,ISTAT) B4200096^^ C ???*A078********^^ 54 IF(ISTAT.GE.0) GO TO 150 ********^^ C ???*A078********^^ 55 CALL FILERR(DDATA,3,ISTAT,LU) B4200098^^ 56 GO TO 960 B4200099^^ C ???*A078********^^ C OPEN ACTFIL ********^^ 57 150 CALL OPENFL(ACTREQ,ACTDAT,ISTAT) ********^^ 58 IF(ISTAT.GE.0) GO TO 200 ********^^ 59 CALL FILERR(ACTDAT,3,ISTAT,LU) ********^^ 60 GO TO 950 ********^^ C ???*A078********^t FTN 3.3B (OPT = LPC) DHUPDT PAGE 5 DATE: 08/29/84 TIME: 2134 t^ C READ 20 ADDACT RECORDS B4200101^^ 61 200 CALL CCSBLK(ADDREC,720) B4200102^^ 62 CALL GETS(ADDREQ,ADDREC,ADDREC,ISTAT) B4200103^^ C EOF B4200104^^ 63 IF(AND(ISTAT,$8100).EQ.$8100) GO TO 520 B4200105^^ 64 IF(AND(ISTAT,$100).EQ.$100) GO TO 220 B4200106^^ 65 IF(ISTAT.GE.0) GO TO 230 B4200107^^ 66 CALL FILERR(ADATA,14,ISTAT,LU) B4200108^^ 67 GO TO 950 B4200109^ ^ C END OF FILE SET FLAG B4200111^^ 68 220 EOF=1 B4200112^ ^ C PROCESS RECORDS B4200114^^ 69 230 NREC=ADDREQ(15) B4200115^^ 70 DO 500 I=1,NREC B4200116^^ 71 J=18*(I-1) B4200117^^ 72 JJ=9*(I-1) B4200118^ ^ C CHECK IF DELETED OR NOT THERE B4200120^^ 73 IF(ADDREC(JJ+1).EQ.FDEL) GO TO 500 B4200121^^ C 2 CARDS DELETED ???*A078********^ ^ C CHECK FOR CODE OF A B4200125^^ 74 CALL CCSCST(A,1,1,ADDREC,J+17,1,ICOMP) B4200126^^ 75 IF(ICOMP.NE.0) GO TO 500 B4200127^^ 76 UPD=0 B4200128^   ^ C FOUND CODE A, CHECK FOR SUMHIST RECORD B4200131^^ 77 240 CALL CCSMVA(ADDREC,J+1,16,SUMKEY,1,16) B4200132^^ 78 CALL READR( SUMREQ,SUMREC,SUMKEY,ISTAT) B4200133^ ^ C EOF OR NOT FOUND B4200135^^ 79 IF(AND(ISTAT,$100).EQ.$100.OR.AND(ISTAT,$200).EQ.$200) GO TO 260 B4200136^^ 80 IF(ISTAT.LT.0) GO TO 250 B4200137^^ 81 UPD=$5300 B4200138^^ 82 GO TO 260 B4200139^^ 83 250 CALL FILERR(SDATA,13,ISTAT,LU) B4200140^^ 84 GO TO 950 B4200141^   ^ C GET DELQMST RECORD B4200144^^ 85 260 CALL CCSMVA(ADDREC,J+1,16,DELKEY,1,16) B4200145^^ 86 CALL READR(DELREQ,DELQRC,DELKEY,ISTAT) B4200146^ ^ C CHECK FOR LOCKED RECORD B4200148^^ 87 IF(AND(ISTAT,$80).EQ.$80) GO TO 260 B4200149^ ^ C EOF OR NOT THERE B4200151^^ 88 IF(AND(ISTAT,$100).EQ.$100.OR.AND(ISTAT,$200).EQ.$200) GO TO 270 B4200152^^ 89 IF(ISTAT.GE.0) GO TO 280 B4200153^t FTN 3.3B (OPT = LPC) DHUPDT PAGE 6 DATE: 08/29/84 TIME: 2134 t^ 90 270 CALL FILERR(DDATA,13,ISTAT,LU) B4200154^^ 91 GO TO 950 B4200155^   ^ C CHECK FOR TAPEARC RECORD B4200158^^ 92 280 CALL CCSMVA(ADDREC,J+1,16,TAPKEY,1,16) B4200159^^ 93 CALL READR(TAPREQ,TAPREC,TAPKEY,ISTAT) B4200160^ ^ C EOF OR NOT FOUND B4200162^^ 94 IF(AND(ISTAT,$100).EQ.$100.OR.AND(ISTAT,$200).EQ.$200) GO TO 300 B4200163^^ 95 IF(ISTAT.LT.0) GO TO 290 B4200164^^ 96 IF(UPD.EQ.$5300)UPD=$4200 B4200165^^ 97 IF(UPD.EQ.$0000)UPD=$5400 B4200166^^ 98 GO TO 295 B4200167^^ 99 290 CALL FILERR(TDATA,13,ISTAT,LU) B4200168^^ 100 GO TO 950 B4200169^ ^ C MOVE THE DATE TO TAPEARC INTO THE DELQMST B4200171^^ 101 295 CALL CCSMVA(TAPREC,17,6,DELQRC,1031,6) B4200172^ t FTN 3.3B (OPT = LPC) DHUPDT PAGE 7 DATE: 08/29/84 TIME: 2134 t^ C MOVE SUMHIST INFO INTO DELQMST B4200175^^ C CHECK FIRST FIELDS FOR BLANK, IF BLANK B4200176^^ C MOVE IN DATA IF NOT BLANK MOVE DATA B4200177^^ C TO PREVIOUS FIELDS B4200178^^ 102 300 IF(UPD.EQ.0) GO TO 500 B4200179^^ 103 IF(UPD.EQ.$5400) GO TO 350 B4200180^ ^ C MOVE IN THE SUMHIST FIELDS B4200182^^ 104 DO 320 II=1,5 B4200183^^ 105 CALL CCSCST(DELQRC,MPOS(II),MLEN(II),BLK,1,MLEN(II),ICOMP) B4200184^^ C CHECK FOR NOT BLANK AND HAS PREVIOUS FIELDB4200185^^ 106 IF(ICOMP.NE.0.AND.II.EQ.1) GO TO 310 B4200186^^ C CHECK FOR BLANK FIELD WITH NO PREVIOS FIELB4200187^^ 107 IF(ICOMP.EQ.0) GO TO 305 B4200188^ ^ C WAS NOT BLANK-CHECK IF BUS PHONE-IF B4200190^^ C BUS PHONE CHECK IF FIELD IS ZERO B4200191^^ C*************** PSR TO CHECK FOR ZERO HOME PHONE ALSO *** ********^^ 108 IF ( II.EQ.2 .OR. II.EQ.4 ) GO TO 303 ********^^ 109 GO TO 320 ********^^ 110 303 CONTINUE ********^^ C*************** END PSR CORRECTION FOR ZERO HOME PHONE *** ********^ ^ C WAS BUSINESS PHONE CHECK FOR ZERO B4200194^^ 111 CALL CCSCST(DELQRC,MPOS(II),10,ZERO,1,10,ICOMP) B4200195^^ 112 IF(ICOMP.NE.0) GO TO 320 B4200196^ ^ C FIELD WAS ZERO MOVE IN BUS PHONE AND EXT B4200198^^ C ONE CARD DELETED ???*A078********^ ^ C DELQMST FIELD IS BLANK B4200201^^ C MOVE SUMHIST FIELD TO DELQMST B4200202^^ 113 305 CALL CCSMVA(SUMREC,SPOS(II),MLEN(II),DELQRC,MPOS(II),MLEN(II)) B4200203^^ 114 GO TO 320 B4200204^ ^ C COMPARE TO SEE IF SUMHIST AND DELQMST B4200206^^ C FIELDS CONTAIN THE SAME INFO B4200207^^ 115 310 CALL CCSCST(DELQRC,MPOS(II),MLEN(II),SUMREC,SPOS(II),MLEN(II), B4200208^^ 115 1ICOMP) B4200209^^ 116 IF(ICOMP.EQ.0) GO TO 320 B4200210^ ^ C NOT THE SAME MOVE TO PREVIOUS FIELDS B4200212^^ 117 CALL CCSMVA(SUMREC,SPOS(II),MLEN(II),DELQRC,MPPOS,MLEN(II)) B4200213^ ^ 118 320 CONTINUE B4200215^ ^ C MOVE IN PERMANENT COMMENTS INTO THE B4200217^^ C FIRST AVAILABLE PERM COMMENT IN DELQMST B4200218^^ C CHECK TO SEE IF ANY COMMENTS TO MOVE B4200219^^ C ONE CARD CHANGED ???*A078********^^ 119 CALL CCSCST(SUMREC,SPOS(7),90,BLK,1,90,ICOMP) ********^^ 120 IF(ICOMP.EQ.0) GO TO 350 B4200221^ ^ C THERE ARE COMMENTS SEE IF ANY AVAILABLE B4200223^t FTN 3.3B (OPT = LPC) DHUPDT PAGE 8 DATE: 08/29/84 TIME: 2134 t^ C SPOT IN DELQMST B4200224^^ 121 DO 340 II=7,9 B4200225^^ 122 CALL CCSCST(DELQRC,MPOS(II),MLEN(II),BLK,1,MLEN(II),ICOMP) B4200226^^ 123 IF(ICOMP.NE.0) GO TO 340 B4200227^ ^ C FIND A PERM COMMENT IN SUMHIST B4200229^^ 124 DO 330 IJ=7,9 B4200230^^ 125 CALL CCSCST(SUMREC,SPOS(IJ),MLEN(IJ),BLK,1,MLEN(IJ),ICOMP) B4200231^^ 126 IF(ICOMP.EQ.0) GO TO 330 B4200232^ ^ C FOUND A COMMENT MOVE IT IN THEN BLANK IT B4200234^^ 127 CALL CCSMVA(SUMREC,SPOS(IJ),MLEN(IJ),DELQRC,MPOS(IJ),MLEN(IJ)) B4200235^^ 128 CALL CCSMVA(BLK,1,MLEN(IJ),SUMREC,SPOS(IJ),MLEN(IJ)) B4200236^^ 129 330 CONTINUE B4200237^^ 130 340 CONTINUE B4200238^ ^ C UPDATE THE DELQMST RECORD B4200240^^ 131 350 CALL UPDREC(DELREQ,DELQRC,ISTAT) B4200241^^ 132 IF(ISTAT.GE.0) GO TO 355 B4200242^^ 133 CALL FILERR(DDATA,15,ISTAT,LU) B4200243^^ 134 GO TO 950 B4200244^ ^ C UPDATE ADDACT B4200246^^ 135 355 CALL CCSMVA(UPD,1,1,ADDREC,J+17,1) B4200247^ ^ C DELETE THE SUMHIST RECORD B4200253^^ 136 360 IF(UPD.EQ.$5400) GO TO 380 B4200254^^ C FIRST ???*A078********^^ C--- CREATE RECORD. ********^^ C ********^^ C******** IF NO ACTIVITY SKIP THE CREATE OF THE ACTFIL RECORD - 03/83********^^ 137 CALL CCSCST(SUMREC,193,4,ROOM,1,0,ICM) ********^^ 138 IF(ICM.EQ.0) GO TO 365 ********^^ C******** PSR 03/83 END ********^^ C ********^^ 139 CALL CCSBLK(ACTREC,500) ********^^ C ********^^ C--- ACCOUNT GROUP & NUMBER ********^^ 140 CALL CCSMVA(DELQRC,1,16,ACTREC,1,16) ********^^ C--- SUFFIX = '51' ********^^ 141 ACTREC(9) = $3531 ********^^ C ********^^ C--- ACTIVITY BLOCK FROM SUMHIST ********^^ C ********^^ C--- FIRST, ADD 122 BYTES TO AVAILABLE ROOM. ********^^ 142 ROOM = $3030 ********^^ 143 CALL CCSMVA(SUMREC,193,4,ROOM,3,4) ********^^ 144 CALL DECHEX(ROOM,IROOM) ********^^ 145 IROOM = IROOM + 122 ********^^ 146 CALL BINASC(IROOM,ROOM(2)) ********^^ 147 CALL CCSMVA(ROOM,3,4,ACTREC,19,4) ********^^ 148 CALL CCSMVA(SUMREC,197,356,ACTREC,145,356) ********^^ C ********^^ C--- WRITE THIS RECORD. ********^t FTN 3.3B (OPT = LPC) DHUPDT PAGE 9 DATE: 08/29/84 TIME: 2134 t^ 149 CALL WRITER(ACTREQ,ACTREC,ACTREC,ISTAT) ********^^ 150 IF(ISTAT.GE.0) GO TO 365 ********^^ 151 CALL FILERR(ACTDAT,12,ISTAT,LU) ********^^ 152 GO TO 950 ********^^ 153 365 CONTINUE ********^^ C ???*A078********^^ 154 CALL DELREC(SUMREQ,SUMREC,ISTAT) B4200255^^ 155 IF(ISTAT.GE.0) GO TO 370 B4200256^^ 156 CALL FILERR(SDATA,16,ISTAT,LU) B4200257^^ 157 GO TO 950 B4200258^^ 158 370 DELETE=DELETE+1 B4200259^t FTN 3.3B (OPT = LPC) DHUPDT PAGE 10 DATE: 08/29/84 TIME: 2134 t ^ C PRINT HEADINGS B4200262^^ 159 380 IF(LIN.LT.56 .AND. LIN.NE.0) GO TO 400 B4200263^^ 160 PAGE=PAGE+1 B4200264^^ 161 WRITE(PRT,381)(HDR(K),K=1,20),PAGE B4200265^^ 162 381 FORMAT(1H1,4X,20A2,4X,'ACTIVE ACCOUNTS UPDATED FROM ', B4200266^^ 162 1'HISTORY SYSTEM',28X,'PAGE: ',I3) B4200267^^ 163 WRITE(PRT,382)(HDR(K),K=21,40),DT(1),DT(2),DT(3) B4200268^^ 164 382 FORMAT(1H ,4X,20A2,15X,'AS OF: ',A2,'/',A2,'/',A2) B4200269^^ 165 WRITE(PRT,383)(HDR(K),K=41,60) B4200270^^ 166 383 FORMAT(1H ,4X,20A2,/) B4200271^^ 167 WRITE(PRT,384) B4200272^^ 168 384 FORMAT(1H ,5X,'ACCOUNT NUMBER',10X,'BORROWERS NAME',22X, B4200273^^ 168 1'FORMER STATUS',8X,'INACTIVE DATE',3X,'TAPE ARCHIVE DATE',/) B4200274^^ 169 LIN=6 B4200275^ ^ C BUILD PRINT LINE B4200277^^ 170 400 CALL CCSBLK(PRTLN,132) B4200278^^ 171 CALL CCSMVA(DELQRC,1,16,PRTLN,1,16) B4200279^^ 172 CALL CCSMVA(DELQRC,18,30,PRTLN,26,30) B4200280^ ^ C MOVE IN DATE FROM SUMHIST B4200282^^ 173 410 IF(UPD.EQ.$5400) GO TO 420 B4200283^^ C ************** ONE CARD DELETED HERE ************* ???*A012********^^ 174 CALL EDIT(SUMREC,17,PRTLN,85,1) B4200285^^ 175 CALL CCSMVA(SUMREC,23,1,PRTLN,68,1) B4200286^ ^ C MOVE IN DATE FROM TAPEARC B4200288^^ 176 420 IF(UPD.EQ.$5300) GO TO 460 B4200289^^ C ************** ONE CARD DELETED HERE ************* ???*A012********^^ 177 CALL EDIT(TAPREC,17,PRTLN,103,1) B4200291^^ C ****************************************************** ???*A012********^^ 178 IF (UPD .NE. $5400 ) GO TO 460 ********^^ 179 CALL CCSMVA ( MSG, 1, 20, PRTLN, 68, 20 ) ********^^ C ****************************************************** ???*A012********^ ^ C PRINT DATA LINE B4200293^^ 180 460 WRITE(PRT,461)(PRTLN(K),K=1,60) B4200294^^ 181 461 FORMAT(1H ,4X,60A2) B4200295^^ 182 LIN=LIN+1 B4200296^^ C ****************************************************** ???*A012********^^ 183 IF (UPD .EQ. $5400 ) GO TO 500 ********^^ C ****************************************************** ???*A012********^ ^ C END OF LOOP GET NEXT RECORD IN BUFFER B4200298^^ 184 490 CALL CCSADD(ONE,1,ICNT,1,ICNT,1) B4200299^^ 185 500 CONTINUE B4200300^^ 186 CALL UPDREC(ADDREQ,ADDREC,ISTAT) ********^^ 187 IF(ISTAT.GE.0) GO TO 505 ********^^ 188 CALL FILERR(ADATA,15,ISTAT,LU) ********^^ 189 GO TO 950 ********^^ 190 505 CONTINUE ********^ ^ C CHECK IF EOF WAS FOUND DURING LAST READ B4200302^t FTN 3.3B (OPT = LPC) DHUPDT PAGE 11 DATE: 08/29/84 TIME: 2134 t^ 191 IF(EOF.NE.1) GO TO 200 B4200303^t FTN 3.3B (OPT = LPC) DHUPDT PAGE 12 DATE: 08/29/84 TIME: 2134 t ^ C EDIT AND PRINT TOTALS B4200307^^ 192 510 DO 520 I=1,11 B4200308^^ 193 CALL CCSCST(ICNT,I,1,ZERO,1,1,ICOMP) B4200309^^ 194 IF(ICOMP.NE.0) GO TO 530 B4200310^^ 195 CALL CCSMVA(BLK,1,1,ICNT,I,1) B4200311^^ 196 520 CONTINUE B4200312^^ 197 530 WRITE(PRT,531) B4200313^^ 198 531 FORMAT(1H ) B4200314^^ 199 WRITE(PRT,532)(ICNT(K),K=1,6) B4200315^^ 200 532 FORMAT(1H ,4X,'TOTAL NUMBER OF ACCOUNTS UPDATED FROM SUMHIST ', B4200316^^ 200 1 6A2) B4200317^^ 201 WRITE(PRT,533) B4200318^^ 202 533 FORMAT(1H ,/,44X,'**** END OF REPORT ****') B4200319^^ C ************** CARDS DELETED HERE **************** ???*0014********^ ^ C CLOSE THE FILES B4200345^^ 203 950 CALL CLOSFL(DELQRC,ISTAT) B4200346^^ C ONE CARD ADDED ???*A078********^^ 204 CALL CLOSFL(ACTREQ,ISTAT) ********^^ 205 960 CALL CLOSFL(SUMREQ,ISTAT) B4200347^^ 206 970 CALL CLOSFL(TAPREQ,ISTAT) B4200348^^ 207 980 CALL CLOSFL(ADDREQ,ISTAT) B4200349^ ^ 208 990 CALL PGMOUT B4200351^^ 209 END B4200352^t FTN 3.3B (OPT = LPC) DHUPDT PAGE 13 DATE: 08/29/84 TIME: 2134 t  PROGRAM LENGTH $1492 ( 5266)   EXTERNALS 2 Q8STP Q8QINI Q8QX Q8QEND FMRDEL PGMIN CCSCST 22 CCSMVA UTHEAD OPENFL FILERR CCSBLK GETS READR 22 UPDREC DECHEX BINASC WRITER DELREC EDIT CCSADD 2 CLOSFL PGMOUT  t FTN 3.3B (OPT = LPC) DHUPDT PAGE 14 DATE: 08/29/84 TIME: 2134 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < $ 8100 (-32511) 0F77 63,63$€ 0000 (0) 0003 14,18,20,21,23,30,32,42,46,50,54,58,65,75,76,80,89,95,97,102,106,107,112,116,120,123,126,132,137,€6 138,150,155,159,187,1946€ 0001 (1) 0002 14,15,16,17,18,31,33,34,35,36,37,68,70,71,72,73,74,77,85,92,104,105,106,111,119,122,125,128,135, €j 137,140,158,160,161,163,171,174,175,177,179,180,182,184,191,192,193,195,199j. 0002 (2) 0F70 31,108,146,163 .@ 0003 (3) 0F73 33,37,43,47,51,55,59,143,147,163 @. 0004 (4) 0F8B 108,137,143,147.0 0006 (6) 0F74 33,37,101,169,19900 0008 (8) 0F71 31,33,34,35,36,370. 0009 (9) 0F7F 72,121,124,141 .& 000A (10) 0F8C 111,111&" 000C (12) 0F99 151"( 000D (13) 0F85 83,90,99 (" 000E (14) 0F79 66 "& 000F (15) 0F8F 133,188&6 0010 (16) 0F82 77,77,85,92,140,156,17162 0011 (17) 0F80 74,101,135,174,177 2& 0012 (18) 0F7D 71,172 &" 0013 (19) 0F95 147"& 0014 (20) 0F9B 161,179&" 0017 (23) 0FA0 175"" 001A (26) 0F9E 172"& 001E (30) 0F9D 172,172&& 0044 (68) 0FA1 175,179&" 0055 (85) 0F9F 174"& 005A (90) 0F8D 119,119&" 0067 (103) 0FA2 177"$ 0080 (128) 0F86 87,87$" 0084 (132) 0F9C 170"" 0091 (145) 0F98 148"& 00C1 (193) 0F90 137,143&" 00C5 (197) 0F96 148". 0100 (256) 0F78 64,64,79,88,94 .& 0164 (356) 0F97 148,148&& 01F4 (500) 0F91 139,183&* 0200 (512) 0F83 79,79,88,94*" 02D0 (720) 0F76 61 "" 0407 (1031) 0F89 101"" 3030 (12336) 0F93 142"" 3531 (13617) 0F92 141"" 4200 (16896) 0F87 96 "( 5300 (21248) 0F84 81,96,176(6 5400 (21504) 0F88 97,103,136,173,178,183 6t FTN 3.3B (OPT = LPC) DHUPDT PAGE 15 DATE: 08/29/84 TIME: 2134 t   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < & A INTEGER 0DE8 1,21,74&0 ACTDAT INTEGER 0CC2 1,18,37,57,59,15108 ACTREC INTEGER 0CE9 1,139,140,141,147,148,1498. ACTREQ INTEGER 0CD1 1,18,57,149,204.6 ADATA INTEGER 0064 1,14,31,33,41,43,66,1886> ADDREC INTEGER 00A0 1,61,62,73,74,77,85,92,135,186 >4 ADDREQ INTEGER 0004 1,20,41,62,69,186,20740 AND INTR.FN. 7FFF 63,64,79,87,88,940< BLK INTEGER 0DE9 1,21,105,119,122,125,128,195 <& DDAT INTEGER 0F68 1,13,36&4 DDATA INTEGER 0091 1,17,36,53,55,90,133 4$ DELETE INTEGER 0E9D 1,158$& DELKEY INTEGER 0CAA 1,85,86&X DELQRC INTEGER 04D8 1,86,101,105,111,113,115,117,122,127,131,140,171,172,203 X. DELREQ INTEGER 004C 1,20,53,86,131 .( DT INTEGER 0E9E 1,39,163 (( EOF INTEGER 0EA1 1,68,191 (& FDEL INTEGER 0EA2 1,40,73&0 HDR INTEGER 0EA3 1,39,161,163,165 04 I INTEGER 0F7B 69,71,72,192,193,195 4, ICM INTEGER 0F72 31,32,137,138,4 ICNT INTEGER 0F50 1,22,184,193,195,199 4` ICOMP INTEGER 0F81 74,75,105,106,107,111,112,115,116,119,120,122,123,125,126,193,194`& IDUSER INTEGER 0EDF 1,29,31&F II INTEGER 0F8A 103,105,106,108,111,113,115,117,121,122F. IJ INTEGER 0F8E 123,125,127,128.* IROOM INTEGER 0F94 144,145,146*‚ ISTAT INTEGER 0F75 41,42,43,45,46,47,49,50,51,53,54,55,57,58,59,62,63,64,65,66,78,79,80,83,86,87,88,89,90,93,94,95,99 ‚d ,131,132,133,149,150,151,154,155,156,186,187,188,203,204,205,206,207 d4 J INTEGER 0F7C 70,71,74,77,85,92,1354( JJ INTEGER 0F7E 71,72,73 (6 K INTEGER 0F9A 161,161,163,165,180,1996. LIN INTEGER 0F6C 21,159,169,182 .L LU INTEGER 0F6D 29,43,47,51,55,59,66,83,90,99,133,151,156,188LD MLEN INTEGER 0EED 1,25,105,113,115,117,122,125,127,128 D" MODE INTEGER 0F6E 29 "< MPOS INTEGER 0EE3 1,24,105,111,113,115,122,127 <( MPPOS INTEGER 0EEC 1,27,117 (( MSG INTEGER 0F56 1,19,179 ($ NOPORT INTEGER 0F6F 29,30$( NREC INTEGER 0F7A 69,69,70 (( ONE INTEGER 0F4B 1,22,184 (, PAGE INTEGER 0F42 1,23,160,161 ,D PRT INTEGER 0EF6 1,22,161,163,165,167,180,197,199,201 D@ PRTLN INTEGER 0EF7 1,170,171,172,174,175,177,179,180@8 ROOM INTEGER 0DE5 1,137,142,143,144,146,1478& SDAT INTEGER 0F64 1,13,35&t FTN 3.3B (OPT = LPC) DHUPDT PAGE 16 DATE: 08/29/84 TIME: 2134 t4 SDATA INTEGER 0082 1,16,35,49,51,83,156 4@ SPOS INTEGER 0F39 1,26,113,115,117,119,125,127,128 @& SUMKEY INTEGER 0CBA 1,77,78&X SUMREC INTEGER 023C 1,78,113,115,117,119,125,127,128,137,143,148,154,174,175 X2 SUMREQ INTEGER 0034 1,20,49,78,154,205 2& TAPKEY INTEGER 0CB2 1,92,93&, TAPREC INTEGER 020C 1,93,101,177 ,. TAPREQ INTEGER 001C 1,20,45,93,206 .& TDAT INTEGER 0F60 1,13,34&0 TDATA INTEGER 0073 1,15,34,45,47,99 0L UPD INTEGER 0F43 1,76,81,96,97,102,103,135,136,173,176,178,183L, ZERO INTEGER 0F44 1,21,111,193 ,   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " BINASC SUBROUTINE 1279 145"" CCSADD SUBROUTINE 13EB 183"* CCSBLK SUBROUTINE 138D 61,139,170 *D CCSCST SUBROUTINE 140F 30,74,105,111,115,119,122,125,137,193Dr CCSMVA SUBROUTINE 141C 32,34,35,36,37,77,85,92,101,113,117,127,128,135,140,143,147,148,171,172,175,179,195r2 CLOSFL SUBROUTINE 147F 203,204,205,206,2072" DECHEX SUBROUTINE 1271 143"" DELREC SUBROUTINE 129B 153"& EDIT SUBROUTINE 13A5 173,177&J FILERR SUBROUTINE 1400 42,47,51,55,59,66,83,90,99,133,151,156,188 J" GETS SUBROUTINE 1035 61 ". OPENFL SUBROUTINE 0FE8 40,45,49,53,57 ." PGMIN SUBROUTINE 0FA4 28 "" PGMOUT SUBROUTINE 148F 208" Q8QEND INTEGER.FN. 13DD Q8QINI INTEGER.FN. 1465 2 Q8QX SUBROUTINE 13D5 161,163,165,180,1992 Q8STP INTEGER.FN. 1491 ( READR SUBROUTINE 1095 77,86,93 (& UPDREC SUBROUTINE 13F7 131,186&" UTHEAD SUBROUTINE 0FE0 38 "" WRITER SUBROUTINE 128B 148"   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 5 0FDF 32,38$$ 100 0FF7 42,45$$ 120 1006 46,49$$ 140 1014 50,53$$ 150 1022 54,57$( 200 1030 58,61,191(t FTN 3.3B (OPT = LPC) DHUPDT PAGE 17 DATE: 08/29/84 TIME: 2134 t$ 220 1050 64,68$$ 230 1053 65,69$" 240 1089 76 "$ 250 10AE 80,83$* 260 10B6 79,82,85,87*$ 270 10D7 88,90$$ 280 10DE 89,92$$ 290 1109 95,99$& 295 1110 97,101 && 300 1118 94,102 && 303 114D 108,110&& 305 115D 107,113&& 310 1175 106,115&6 320 11A6 103,109,112,114,116,1186* 330 121A 123,126,129** 340 121F 120,123,130** 350 1225 103,120,131*& 355 1236 132,135&" 360 1242 135"* 365 129A 138,150,153*& 370 12A9 155,158&& 380 12AB 136,159&& 381 12D0 161,162&& 382 1314 163,164&& 383 1340 165,166&& 384 134F 167,168&& 400 138C 159,170&" 410 139F 172"& 420 13B2 173,176&* 460 13C7 176,178,180*& 461 13DF 180,181&" 490 13EA 183"4 500 13F2 69,73,75,102,183,185 4& 505 1406 187,190&" 510 140C 191"* 520 1423 63,192,196 *& 530 1428 194,197&& 531 142E 197,198&& 532 1445 199,200&& 533 146B 201,202&B 950 147E 59,67,84,91,100,134,152,157,189,203B& 960 1485 55,205 && 970 1488 51,206 && 980 148B 47,207 &( 990 148E 30,44,208( DHUPDT 0000 1  t FTN 3.3B (OPT = LPC) DMPFIL PAGE 1 DATE: 08/29/84 TIME: 2136 t^ 1 PROGRAM DMPFIL B4500001^^ 1 1 /B45 F CCS CCS 3.0 . - PSRD 03/83 SL-149********^^ C B4500003^^ C CYBERCREDIT SYSTEM VERSION 3 B4500004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B4500005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B4500006^^ C B4500007^^ C B4500008^^ C THIS PROGRAM LISTS A SPECIFIED FILE TO TAPE. THE FILE CANNOT B4500009^^ C EXCEED 3000 CHARACTERS. THIS PROGRAM ALLOWS FOR MULTI-TAPE B4500010^^ C CAPABILITES. THE USERID MUST BE THE SAME AS THE OWNER ID ON THE+ B4500011^^ C FILE THAT IS TO BE DUMPED. IF A VOLUME IS ENTERED, ONLY THE B4500012^^ C VOLUME SPECIFIED IS SEARCHED FOR THAT FILE. IF NO VOLUME IS B4500013^^ C ENTERED, ALL MOUNTED VOLUMES WILL BE SEARCHED. DELETED RECORDS B4500014^^ C WILL NOT BE DUMPED TO TAPE. AT THE END OF THE DUMP TWO EOF'S ARE B4500015^^ C WRITTEN ON THE TAPE. AT THE END OF A REEL ONE EOF IS WRITTEN. B4500016^  ^ 2 INTEGER BLANK,BYTLEN,COMP,EOF,FCB(96),FDEL,FLAG,FMRDEL B4500018^^ 3 INTEGER FMEOFC,EOFC B4500019^^ 4 INTEGER IBUF(10),IDUSER(4),IDATA(15),IREQ(24) B4500020^^ 5 INTEGER IREC(6000),ICNT(6),FCBHDR(6),BUFLEN ********^^ 6 EQUIVALENCE (FCBHDR(6),FCB(1)) ********^^ 7 INTEGER MSG1(11),MSG2(11),MSG3(9),MSG4(39),MSG5(15) B4500022^^ 8 INTEGER MSG6(19),MSG7(19),MSG8(20),MSG9(20) B4500023^^ 9 INTEGER ONE(5),OREC(1002),RECLEN,STATIT B4500024^^ 10 INTEGER TAPE,TEMP(8),TPSTAT,Y,ZERO B4500025^ ^ 11 DATA BLANK/$2020/,EOF/0/,FLAG/0/,IRCT/0/,ICNT/6*$3030/ B4500027^^ 12 DATA IDATA/12*$2020,0,10,-1/,IREQ/24*0/ B4500028^^ 13 DATA ONE/4*$3030,$3031/,TAPE/$1006/,TEMP/8*0/ B4500029^^ 14 DATA Y/'Y '/,ZERO/0/ B4500030^^ 15 DATA BUFLEN /6000/ ********^ ^ 16 DATA MSG1/$1800,$0A0D,'DUMP FILE TO TAPE '/ B4500032^^ 17 DATA MSG2/$0A0D,$0A0D,'INPUT FILE NAME '/ B4500033^^ 18 DATA MSG3/$0A0D,$0A0D,'VOLUME NAME '/ B4500034^^ 19 DATA MSG4/$0A0D,$0A0D,'*****OPERATOR-MOUNT TAPE FOR XXXXXXXX ON', B4500035^^ 19 1' UNIT 0 WITH RING ',$0A0D,$0A0D,'READY (Y/N) '/ B4500036^^ 20 DATA MSG5/$0A0D,$0A0D,'FILE COULD NOT BE LOCATED '/ B4500037^^ 21 DATA MSG6/$0A0D,$0D0A,'RECORD EXCEEDS 2000 CHARACTERS '/ ********^^ 22 DATA MSG7/$0A0D,$0A0D,'THIS IS A SUPERVISOR COMMAND ONLY '/ B4500039^^ 23 DATA MSG8/$0A0D,$0A0D,'*****OPERATOR-REWIND TAPE ON UNIT 0 '/ B4500040^^ 24 DATA MSG9/$0A0D,$0A0D,' RECORDS WRITTEN TO TAPE'/ B4500041^ ^ 25 EXTERNAL FMRDEL,FMEOFC B4500043^t FTN 3.3B (OPT = LPC) DMPFIL PAGE 2 DATE: 08/29/84 TIME: 2136 t ^ 26 ASSEM $C000,+FCBHDR,$6400,+IREQ(10) ********^^ 27 IREQ(13) = 96 ********^^ 28 100 CALL PGMIN(IDUSER,LUNIT,MODE,NOPORT) B4500045^^ 29 IF(NOPORT.NE.0) GO TO 940 B4500046^ ^ C DISPLAY HEADING B4500048^^ 30 CALL WTREAD(LUNIT,-1,MSG1,22,-1,IBUF,0,ITC) B4500049^ ^ C GET INPUT FILE NAME B4500051^^ 31 110 CALL CCSBLK(IBUF,20) ********^^ 32 CALL WTREAD(LUNIT,-1,MSG2,22,-1,IBUF,18,ITC) ********^^ 33 IF(IBUF(10).EQ.0) GO TO 110 ********^^ 34 IF(ITC.EQ.4) GO TO 110 ********^^ 35 CALL CCSMVA(IBUF,1,16,IDATA,1,16) ********^ ^ C GET VOLUME NAME ********^^ 36 120 CALL CCSBLK(IBUF,20) ********^^ 37 CALL WTREAD(LUNIT,-1,MSG3,18,-1,IBUF,18,ITC) ********^^ 38 IF(ITC.EQ.4) GO TO 120 ********^^ 39 CALL CCSMVA(IBUF,1,8,IDATA,17,8) B4500060^ ^ C OPEN THE FILE B4500062^^ 40 130 CALL OPENFL(IREQ,IDATA,ISTAT) B4500063^^ 41 IF(ISTAT.GE.0) GO TO 140 B4500064^ ^ C CHECK FOR NOT PRESENT B4500066^^ 42 IF(AND(ISTAT,$8002).EQ.$8002) GO TO 900 B4500067^^ 43 CALL FILERR(IDATA,3,ISTAT,LUNIT) B4500068^^ 44 GO TO 990 B4500069^ ^ C GET DELETE CODE B4500071^^ 45 140 ASSEM $C000,FMRDEL,$6800,FDEL B4500072^^ 46 ASSEM $C000,+FMEOFC,$6800,EOFC B4500073^  ^ C GET FCB FOR RECORD LENGTH B4500080^^ 47 150 CALL GETFCB(IREQ,ZERO,ZERO,FCB,ISTAT) B4500081^^ 48 IF(ISTAT.GE.0) GO TO 160 B4500082^^ 49 CALL FILERR(IDATA,7,ISTAT,LUNIT) B4500083^^ 50 GO TO 980 B4500084^ ^ C CHECK RECORD LENGTH B4500086^^ 51 160 RECLEN=FCB(1) B4500087^^ 52 BYTLEN=RECLEN*2 B4500088^^ 53 IF(RECLEN.GT.1000) GO TO 920 ********^^ 54 NREC = BUFLEN/RECLEN ********^^ 55 IREQ(13)= NREC ********^ ^ C PROMPT OPERATOR TO MOUNT TAPE B4500091^^ 56 CALL CCSMVA(IDATA,1,8,MSG4,34,8) B4500092^^ 57 165 IBUF(1)=BLANK B4500093^^ 58 CALL WTREAD (LUNIT,-1,MSG4,78,-1,IBUF,1,ITC) B4500094^^ 59 IF(IBUF(1).NE.Y) GO TO 165 B4500095^t FTN 3.3B (OPT = LPC) DMPFIL PAGE 3 DATE: 08/29/84 TIME: 2136 t^ C READ THE INPUT FILE B4500097^^ 60 170 CONTINUE ********^^ 61 CALL GETS(IREQ,IREC,IREC,ISTAT) B4500099^^ 62 IF(ISTAT.GE.0) GO TO 190 B4500100^^ 63 IF(AND(ISTAT,$8100).EQ.$8100) GO TO 260 B4500101^^ 64 IF(AND(ISTAT,$100).EQ.$100) GO TO 180 B4500102^^ 65 CALL FILERR(IDATA,13,ISTAT,LUNIT) B4500103^^ 66 GO TO 980 B4500104^^ 67 180 EOF=1 B4500105^^ 68 190 NREC=IREQ(15) B4500106^^ 69 IF (NREC.LE.0) GO TO 250 ********^ ^ C PROCESS THE RECORDS B4500108^^ 70 200 DO 250 I=1,NREC B4500109^^ 71 J=(I-1)*RECLEN+1 B4500110^^ 72 JB=(I-1)*BYTLEN+1 B4500111^ ^ C IS RECORD DELETED B4500113^^ 73 IF(IREC(J).EQ.FDEL) GO TO 250 B4500114^^ 74 IF(IREC(J).EQ.EOFC) GO TO 260 B4500115^ ^ C WRITE A RECORD TO TAPE B4500117^^ 75 210 CALL CCSMVA(IREC,JB,BYTLEN,OREC,1,BYTLEN) B4500118^^ 76 ASSIGN 220 TO COMP B4500119^^ 77 CALL FWRITE(TAPE,OREC,RECLEN,COMP,FLAG,TEMP) B4500120^^ 78 CALL DISP B4500121^ ^ C GET TAPE STATUS B4500123^^ 79 220 TPSTAT=STATIT(TAPE) B4500124^^ 80 CALL CCSADD(ONE,2,ICNT,1,ICNT,1) B4500125^ ^ C CHECK FOR EOT B4500127^^ 81 IF(AND(TPSTAT,$200).NE.$200) GO TO 250 B4500128^ ^ C EOT WAS FOUND WRITE EOF MARK B4500130^^ 82 CALL TAPMOT(TAPE,2) B4500131^^ 83 CALL WTREAD(LUNIT,-1,MSG8,40,-1,IBUF,0,ITC) B4500132^^ 84 230 IBUF(1)=BLANK B4500133^^ 85 CALL WTREAD(LUNIT,-1,MSG4,78,-1,IBUF,1,ITC) B4500134^^ 86 IF(IBUF(1).NE.Y) GO TO 230 B4500135^ ^ C GET NEXT RECORD B4500137^^ 87 250 CONTINUE B4500138^^ 88 IF(EOF.EQ.0) GO TO 170 B4500139^ ^ C END OF DUMP TO TAPE B4500141^^ C WRITE TWO EOFS AND QUIT B4500142^^ 89 260 CALL TAPMOT(TAPE,2) B4500143^^ 90 CALL TAPMOT(TAPE,2) B4500144^^ 91 GO TO 980 B4500145^t FTN 3.3B (OPT = LPC) DMPFIL PAGE 4 DATE: 08/29/84 TIME: 2136 t ^ C FILE WAS NOT LOCATED B4500148^^ 92 900 CALL WTREAD(LUNIT,-1,MSG5,30,-1,IBUF,0,ITC) B4500149^^ 93 GO TO 990 B4500150^ ^ C FILE TOO LARGE B4500152^^ 94 920 CALL WTREAD(LUNIT,-1,MSG6,38,-1,IBUF,0,ITC) B4500153^^ 95 GO TO 980 B4500154^ ^ C NOT MASTER TERMINAL B4500156^^ 96 940 CALL WTREAD(LUNIT,-1,MSG7,38,-1,IBUF,0,ITC) B4500157^^ 97 GO TO 980 B4500158^ ^ C CLOSE THE INPUT FILE B4500160^^ 98 980 CALL CCSMVA(ICNT,1,12,MSG9,5,12) B4500161^^ 99 CALL WTREAD(LUNIT,-1,MSG9,40,-1,IBUF,0,ITC) B4500162^^ 100 CALL CLOSFL(IREQ,ISTAT) B4500163^^ 101 990 CALL PGMOUT B4500164^^ 102 STOP B4500165^^ 103 END B4500166^t FTN 3.3B (OPT = LPC) DMPFIL PAGE 5 DATE: 08/29/84 TIME: 2136 t  PROGRAM LENGTH $1E65 ( 7781)   EXTERNALS 2 Q8STP FMRDEL FMEOFC STATIT PGMIN WTREAD CCSBLK 22 CCSMVA OPENFL FILERR GETFCB GETS FWRITE DISP 2 CCSADD TAPMOT CLOSFL PGMOUT  t FTN 3.3B (OPT = LPC) DMPFIL PAGE 6 DATE: 08/29/84 TIME: 2136 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < $ 8002 (-32765) 1CC8 42,42$$ 8100 (-32511) 1CD0 63,63$@ FFFE (-1) 1CBF 30,30,32,37,58,83,85,92,94,96,99 @R 0000 (0) 0003 11,12,13,14,29,30,33,41,48,62,69,83,88,92,94,96,99 Rn 0001 (1) 0002 6,12,30,32,35,37,39,51,56,57,58,59,67,70,71,72,75,80,83,84,85,86,92,94,96,98,99n. 0002 (2) 1CCB 52,80,82,89,90 ." 0003 (3) 1CC9 43 "" 0005 (5) 1CDB 98 "" 0007 (7) 1CCA 49 "( 0008 (8) 1CC5 39,39,56 ($ 000C (12) 1CDA 98,98$" 000D (13) 1CD2 65 "$ 0010 (16) 1CC4 35,35$" 0011 (17) 1CC6 39 "$ 0012 (18) 1CC3 32,37$$ 0014 (20) 1CC2 31,36$$ 0016 (22) 1CC0 30,32$" 001E (30) 1CD8 92 "" 0022 (34) 1CCE 56 "$ 0026 (38) 1CD9 94,96$$ 0028 (40) 1CD7 83,99$$ 004E (78) 1CCF 58,85$$ 0100 (256) 1CD1 64,64$$ 0200 (512) 1CD6 81,81$" 03E8 (1000) 1CCC 53 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < * AND INTR.FN. 7FFF 42,63,64,81** BLANK INTEGER 0004 1,11,57,84 *& BUFLEN INTEGER 181B 1,15,54&* BYTLEN INTEGER 0005 1,52,72,75 *& COMP INTEGER 0006 1,76,77&* EOF INTEGER 0007 1,11,67,88 *& EOFC INTEGER 006F 1,46,74&( FCB INTEGER 000D 1,6,47,51(& FCBHDR INTEGER 0008 1,6,26 && FDEL INTEGER 006D 1,45,73&& FLAG INTEGER 006E 1,11,77&( I INTEGER 1CD3 70,71,72 (Z IBUF INTEGER 0070 1,30,31,32,33,35,36,37,39,57,58,59,83,84,85,86,92,94,96,99 Z* ICNT INTEGER 1815 1,11,80,98 *t FTN 3.3B (OPT = LPC) DMPFIL PAGE 7 DATE: 08/29/84 TIME: 2136 t8 IDATA INTEGER 007E 1,12,35,39,40,43,49,56,658$ IDUSER INTEGER 007A 1,28 $" IRCT INTEGER 1CBB 11 ", IREC INTEGER 00A5 1,61,73,74,75,< IREQ INTEGER 008D 1,12,26,27,40,47,55,61,68,100<F ISTAT INTEGER 1CC7 40,41,42,43,47,48,49,61,62,63,64,65,100FB ITC INTEGER 1CC1 30,32,34,37,38,58,83,85,92,94,96,99B* J INTEGER 1CD4 70,71,73,74*( JB INTEGER 1CD5 71,72,75 (H LUNIT INTEGER 1CBC 28,30,32,37,43,49,58,65,83,85,92,94,96,99H" MODE INTEGER 1CBD 28 "& MSG1 INTEGER 181C 6,16,30&& MSG2 INTEGER 1827 6,17,32&& MSG3 INTEGER 1832 6,18,37&, MSG4 INTEGER 183B 6,19,56,58,85,& MSG5 INTEGER 1862 6,20,92&& MSG6 INTEGER 1871 6,21,94&& MSG7 INTEGER 1884 6,22,96&& MSG8 INTEGER 1897 6,23,83&* MSG9 INTEGER 18AB 6,24,98,99 *$ NOPORT INTEGER 1CBE 28,29$0 NREC INTEGER 1CCD 53,54,55,68,69,700& ONE INTEGER 18BF 6,13,80&& OREC INTEGER 18C4 6,75,77&2 RECLEN INTEGER 1CAE 6,51,52,53,54,71,7722 TAPE INTEGER 1CAF 6,13,77,79,82,89,902& TEMP INTEGER 1CB0 6,13,77&& TPSTAT INTEGER 1CB8 6,79,81&* Y INTEGER 1CB9 6,14,59,86 *& ZERO INTEGER 1CBA 6,14,47&   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " CCSADD SUBROUTINE 1DF3 79 "$ CCSBLK SUBROUTINE 1CF9 30,36$. CCSMVA SUBROUTINE 1DD8 34,39,56,75,98 ." CLOSFL SUBROUTINE 1E5E 99 "" DISP SUBROUTINE 1DEC 77 "( FILERR SUBROUTINE 1D3C 42,49,65 (" FWRITE SUBROUTINE 1DE4 76 "" GETFCB SUBROUTINE 1D4C 46 "" GETS SUBROUTINE 1D8E 59 "" OPENFL SUBROUTINE 1D2E 39 "" PGMIN SUBROUTINE 1CE4 27 "" PGMOUT SUBROUTINE 1E62 101" Q8STP INTEGER.FN. 1E64 $ STATIT INTEGER.FN. 1DEE 6,79 $( TAPMOT SUBROUTINE 1E01 81,89,90 (< WTREAD SUBROUTINE 1E05 29,32,37,58,83,85,92,94,96,99<t FTN 3.3B (OPT = LPC) DMPFIL PAGE 8 DATE: 08/29/84 TIME: 2136 t   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < " 100 1CE3 27 "( 110 1CF8 30,33,34 ($ 120 1D16 35,38$" 130 1D2D 39 "$ 140 1D43 41,45$" 150 1D4B 46 "$ 160 1D5D 48,51$$ 165 1D79 56,59$$ 170 1D8D 59,88$$ 180 1DAA 64,67$$ 190 1DAD 62,68$" 200 1DB5 69 "" 210 1DD7 74 "$ 220 1DED 75,79$$ 230 1E0E 83,86$. 250 1E21 69,70,73,81,87 .( 260 1E28 63,74,89 ($ 900 1E2F 42,92$$ 920 1E39 53,94$$ 940 1E43 29,96$0 980 1E4D 49,66,91,95,97,980( 990 1E61 43,93,101( DMPFIL 0000 1 t FTN 3.3B (OPT = LPC) DPTDT1 PAGE 1 DATE: 08/29/84 TIME: 2136 t^ 1 SUBROUTINE DPTDT1 ( TABLE, LU, IND) B4600001^^ 1 1 /B46 F CCS CCS 3.0 SL-149B4600002^^ C B4600003^^ C CYBERCREDIT SYSTEM VERSION 3 B4600004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B4600005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B4600006^^ C B4600007^^ C DUMPS TABLE IN 80 BYTE RECORDS TO LU B4600008^^ 2 INTEGER TABLE(10), IDATA(40), STARS, EOFMRK B4600009^^ 3 EQUIVALENCE (ITBLEN, TABLE(2)) B4600010^^ 4 DATA STARS /'**'/, EOFMRK / '%%' / B4600011^^ 5 IND = $8001 B4600012^^ C CHECK FOR NO TABLE B4600013^^ 6 IF ( ITBLEN .LE. 11) RETURN B4600014^^ 7 ICUR = 11 B4600015^^ C CHECK FOR END OF TABLE B4600016^^ 8 10 IF ( TABLE(ICUR) .EQ. 0) GO TO 1000 B4600017^^ 9 ISTRT = ICUR + 1 B4600018^^ 10 ISTOP = ICUR + TABLE(ICUR) - 1 B4600019^^ 11 CALL BLKDT1 ( IDATA ,40) B4600020^^ 12 J = 0 B4600021^  ^ 13 DO 200 I = ISTRT, ISTOP B4600023^^ 14 J = J + 1 B4600024^^ 15 IF ( J .LE. 40) GO TO 100 B4600025^^ C WRITE FULL RECORD B4600026^^ 16 WRITE ( LU, 9000) IDATA B4600027^^ 17 9000 FORMAT ( 40A2) B4600028^^ 18 J = 1 B4600029^^ 19 CALL BLKDT1 (IDATA, 40) B4600030^^ 20 100 IDATA(J) = TABLE(I) B4600031^^ 21 200 CONTINUE B4600032^  ^ C DONE WITH TEST, TERMINATE RECORD WITH ** B4600034^^ 22 IF (J.LT.40) IDATA(J+1) = STARS B4600035^^ 23 WRITE (LU, 9000) IDATA B4600036^^ 24 IF ( J .NE. 40) GO TO 500 B4600037^^ C CCSPUT OUT SPARE RECORD WITH ** B4600038^^ 25 CALL BLKDT1( IDATA, 40) B4600039^^ 26 IDATA(1) = STARS B4600040^^ 27 WRITE ( LU, 9000) IDATA B4600041^^ 28 500 ICUR = ISTOP + 1 B4600042^^ 29 GO TO 10 B4600043^^ C END FILE AND RETURN B4600044^^ 30 1000 WRITE ( LU, 9000 ) EOFMRK B4600045^^ 31 IND = 0 B4600046^^ 32 RETURN B4600047^^ 33 END B4600048^t FTN 3.3B (OPT = LPC) DPTDT1 PAGE 2 DATE: 08/29/84 TIME: 2136 t  PROGRAM LENGTH $00E5 ( 229)   EXTERNALS , Q8PKUP Q8PREP Q8QINI Q8QX Q8QEND BLKDT1 , t FTN 3.3B (OPT = LPC) DPTDT1 PAGE 3 DATE: 08/29/84 TIME: 2136 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : <  8001 (-32766) 002B 5 : 0028 (40) 002F 11,15,16,19,22,23,24,25,27 :   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < & EOFMRK INTEGER 002A 2,4,30 &$ I INTEGER 0031 12,20$, ICUR INTEGER 002C 6,7,8,9,10,28,< IDATA INTEGER 0001 2,11,16,19,20,22,23,25,26,27 <& IND INTEGER 7FFF 1,5,31 &* ISTOP INTEGER 002E 9,10,13,28 *& ISTRT INTEGER 002D 8,9,13 &" ITBLEN INTEGER 7FFF 2,6"6 J INTEGER 0030 11,12,14,15,18,20,22,246, LU INTEGER 7FFF 1,16,23,27,30,( Q8QX1 INTEGER 0000 16,23,27 (( STARS INTEGER 0029 2,4,22,26(, TABLE INTEGER 7FFF 1,2,3,8,10,20,   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < ( BLKDT1 SUBROUTINE 004A 10,19,25 ( Q8PKUP INTEGER.FN. 00D4 Q8PREP INTEGER.FN. 00D1 Q8QEND INTEGER.FN. 006F Q8QINI INTEGER.FN. 005B * Q8QX SUBROUTINE 0067 16,23,27,30*t FTN 3.3B (OPT = LPC) DPTDT1 PAGE 4 DATE: 08/29/84 TIME: 2136 t   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 10 003B 7,29 $$ 100 007C 15,20$$ 200 0081 12,21$$ 500 00BA 24,28$$ 1000 00C1 8,30 $. 9000 0074 16,17,23,27,30 . DPTDT1 00CE 1 t FTN 3.3B (OPT = LPC) DSPDT1 PAGE 1 DATE: 08/29/84 TIME: 2136 t^ 1 SUBROUTINE DSPDT1 ( TABLE, LN, ILU, IND) B4700001^^ 1 1 /B47 F CCS CCS 3.0 SL-149B4700002^^ C B4700003^^ C CYBERCREDIT SYSTEM VERSION 3 B4700004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B4700005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B4700006^^ C B4700007^^ 2 INTEGER TABLE(10) , IDATA(40), WP, POLIT(14), PO, CON, CONLIT(9) B4700008^^ 3 INTEGER V1(3), V2(3) B4700009^^ 4 DATA LVL,NLVL,NP / 3*0/ B4700010^^ 5 EQUIVALENCE ( ICPRM, TABLE(6)) B4700011^^ 6 DATA POLIT /'NULL.EQ..LE..GT..NE..WE..OS.'/ B4700012^^ 7 DATA CONLIT /'.AND. .OR. '/ B4700013^^ 8 CALL GTPDT1 ( TABLE, LN, WP) B4700014^^ 9 IF ( WP .LT. 0) GO TO 8000 B4700015^^ 10 CALL CCSGET ( TABLE(WP), 3, LVL) B4700016^^ 11 CALL CCSGET ( TABLE(WP), 4, NLVL) B4700017^^ 12 CALL CCSGET ( TABLE(WP), 5, NP) B4700018^^ 13 LVL = AND( $F, LVL) B4700019^^ 14 NLVL= AND( $F, NLVL) B4700020^^ 15 NP = AND( $F, NP) B4700021^^ 16 WRITE ( ILU,9000) LN, LVL, NLVL, NP B4700022^^ 17 9000 FORMAT ( /,/, ' DECISION TABLE TEST NUMBER -', I4, B4700023^^ 17 1 ' LVL - ', I1, ', NLVL - ', I1, ', NP - ', I1 ) B4700024^^ 18 WRITE ( ILU,9001) B4700025^^ 19 9001 FORMAT ( / , ' PRM NUM OPERATOR VALUE 1 VALUE 2 B4700026^^ 19 1 CONNECTOR ') B4700027^  ^ C PARAMETER SECTION B4700029^^ 20 ICPRM = WP + 3 B4700030^^ 21 DO 500 I = 1, NP B4700031^^ 22 CALL BLKDT1 ( V2, 3) B4700032^^ 23 CALL GPMDT1 ( TABLE, PO, V1, V2, CON) B4700033^^ 24 IOP = ( PO+1) * 2 - 1 B4700034^^ 25 IOP1 = IOP + 1 B4700035^^ 26 ICON = ( CON + 1) * 3 -2 B4700036^^ 27 ICON1 = ICON + 2 B4700037^^ 28 IF ( I .NE. NP) GO TO 300 B4700038^^ C WORKING ON LAST PARAMETER, BLANK CONNECTOR B4700039^^ 29 ICON = 7 B4700040^^ 30 ICON1 = 9 B4700041^^ 31 300 WRITE ( ILU, 9002) I,(POLIT(L1), L1= IOP,IOP1), V1, V2, B4700042^^ 31 1 (CONLIT(L2), L2 = ICON, ICON1) B4700043^^ 32 9002 FORMAT ( 8X, I1, 10X,2A2, 6X,1H*,3A2,1H*, 5X, B4700044^^ 32 1 1H*,3A2, 1H*, 7X, 3A2 ) B4700045^^ 33 500 CONTINUE B4700046^  ^ C RESULTS SECTION B4700048^^ 34 WRITE ( ILU, 9003 ) TABLE(ICPRM), TABLE(ICPRM+1) B4700049^^ 35 9003 FORMAT ( / ,' NUMBER OF RESULT VALUES - ', A2, B4700050^^ 35 1 ', CURRENT POSITION - ', A2 ) B4700051^^ C CONVERT RESULT MAX TO INTEGER B4700052^t FTN 3.3B (OPT = LPC) DSPDT1 PAGE 2 DATE: 08/29/84 TIME: 2136 t^ 36 CALL CCSGET ( TABLE(ICPRM) , 1, IL) B4700053^^ 37 CALL CCSGET ( TABLE(ICPRM) , 2, IR) B4700054^^ 38 IMX = NUMDT1(IL) * 10 + NUMDT1(IR) B4700055^^ 39 L1 = ICPRM + 2 B4700056^^ 40 L2 = L1 + IMX*2 -1 B4700057^^ 41 WRITE ( ILU,9004) ( TABLE(I) , I = L1, L2) B4700058^^ 42 9004 FORMAT ( ' RESULTS - ', 2A2, 9 (1H,2A2) ) B4700059^^ 43 WRITE ( ILU, 9005) B4700060^^ 44 9005 FORMAT ( /, ' END OF TEST', //) B4700061^^ 45 IND = 0 B4700062^^ 46 RETURN B4700063^^ 47 8000 IND = $8001 B4700064^^ 48 RETURN B4700065^^ 49 END B4700066^t FTN 3.3B (OPT = LPC) DSPDT1 PAGE 3 DATE: 08/29/84 TIME: 2136 t  PROGRAM LENGTH $0255 ( 597)   EXTERNALS 2 Q8PKUP Q8PREP Q8QINI Q8QX Q8QEND GTPDT1 CCSGET 2 BLKDT1 GPMDT1 NUMDT1  t FTN 3.3B (OPT = LPC) DSPDT1 PAGE 4 DATE: 08/29/84 TIME: 2136 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " 8001 (-32766) 005D 47 "4 0001 (1) 0000 21,24,25,26,34,36,40 40 0002 (2) 0053 24,26,27,37,39,400. 0003 (3) 004D 10,20,22,26,31 ." 0004 (4) 004E 11 "" 0005 (5) 004F 12 "" 000A (10) 005C 38 "( 000F (15) 0050 13,14,15 (   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < ( AND INTR.FN. 7FFF 13,14,15 (& CON INTEGER 003A 2,23,26&& CONLIT INTEGER 003B 2,7,31 &* I INTEGER 0051 20,28,31,41*. ICON INTEGER 0055 25,26,27,29,31 .* ICON1 INTEGER 0056 26,27,30,31*0 ICPRM INTEGER 7FFF 4,20,34,36,37,39 0 IDATA INTEGER 0002 2 $ IL INTEGER 0059 36,38$2 ILU INTEGER 7FFF 1,16,18,31,34,41,432( IMX INTEGER 005B 37,38,40 (& IND INTEGER 7FFF 1,45,47&* IOP INTEGER 0052 23,24,25,31*( IOP1 INTEGER 0054 24,25,31 ($ IR INTEGER 005A 37,38$. L1 INTEGER 0057 31,31,39,40,41 .* L2 INTEGER 0058 31,31,40,41*& LN INTEGER 7FFF 1,8,16 &* LVL INTEGER 004A 2,10,13,16 ** NLVL INTEGER 004B 2,11,14,16 *0 NP INTEGER 004C 2,12,15,16,21,28 0& PO INTEGER 0039 2,23,24&& POLIT INTEGER 002B 2,6,31 &" Q8QX1 INTEGER 0001 31 "> TABLE INTEGER 7FFF 1,2,5,8,10,11,12,23,34,36,37,41>& V1 INTEGER 0044 2,23,31&* V2 INTEGER 0047 2,22,23,31 *0 WP INTEGER 002A 2,8,9,10,11,12,200t FTN 3.3B (OPT = LPC) DSPDT1 PAGE 5 DATE: 08/29/84 TIME: 2136 t   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " BLKDT1 SUBROUTINE 0101 21 ", CCSGET SUBROUTINE 01C5 9,11,12,36,37," GPMDT1 SUBROUTINE 0105 22 " GTPDT1 SUBROUTINE 005F 7 $ NUMDT1 INTEGER.FN. 01D1 38,38$ Q8PKUP INTEGER.FN. 022E Q8PREP INTEGER.FN. 022B Q8QEND INTEGER.FN. 01FA Q8QINI INTEGER.FN. 01E6 * Q8QX SUBROUTINE 01F4 16,31,34,41*   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 300 0128 28,31$$ 500 0186 20,33$$ 8000 0222 9,47 $$ 9000 009A 16,17$$ 9001 00CF 18,19$$ 9002 016C 31,32$$ 9003 019D 34,35$$ 9004 01FC 41,42$$ 9005 0213 43,44$ DSPDT1 0228 1  t FTN 3.3B (OPT = LPC) EDIT PAGE 1 DATE: 08/29/84 TIME: 2137 t^ 1 SUBROUTINE EDIT(INBUF,ISTART,OBUF,OSTART,ECODE) B5000001^^ 1 1 /B50 F CCS CCS 3.0 PSR'D SL-149********^^ C B5000003^^ C CYBERCREDIT SYSTEM VERSION 3 B5000004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B5000005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B5000006^^ C B5000007^^ C B5000008^^ C EDIT FIELDS FOR DISPLAY. B5000009^^ C B5000010^^ C ROUTINE TO EDIT OUTPUT FIELDS INTO A FORMAT COMMONLY ACCEPTED FOR B5000011^^ C THE FIELD. THIS INCULDES DATES, DOLLAR AMOUNTS, PHONE NUMBERS, ANDB5000012^^ C SOCIAL SECURITY NUMBERS. B5000013^^ C CALLING SEQUENCE: B5000014^^ C CALL EDIT(INBUF,ISTART,OBUF,OSTART,ECODE) B5000015^^ C WHERE THE PARAMETERS HAVE THE FOLLOWING DEFINITIONS: B5000016^^ C INBUF = INPUT BUFFER SOURCE FOR THE CHARACTERS TO EDIT. B5000017^^ C ISTART = STARTING CHARACTER OF THE FIELD TO EDIT. B5000018^^ C OBUF = OUTPUT BUFFER TO RECEIVE THE EDITED FIELD. B5000019^^ C OSTART = STARTING POSITION IN OUTPUT BUFFER OF THE EDITED FIELD. B5000020^^ C ECODE = THE EDIT CODE INDICATING WHAT TYPE OF EDITING TO PERFORM.B5000021^^ C CODES USED ARE: B5000022^^ C 0 = NOT USED. B5000023^^ C 1 = DATE EDIT IN FORM MM/DD/YY . B5000024^^ C 2 = NOT USED. B5000025^^ C ****************************************************** ???*A009********^^ C 3 = DOLLAR AMOUNT. NINE DIGIT FIELD EDITED TO 9999999.99S ********^^ C S=SIGN: POS.=BLANK, NEG.='-' ********^^ C ****************************************************** ???*A009********^^ C 4 = PHONE NUMBER IN THE FORM 999/999-9999 . B5000027^^ C 5 = NOT USED. B5000028^^ C 6 = SOCIAL SECURITY NUMBER IN THE FORM 999-99-9999 . B5000029^^ C 7-9 = NOT USED. B5000030^^ C IF AN ILLEGAL OR NOT USED EDIT CODE IS PASSED, THE SUBROUTINE IS B5000031^^ C IMMEDIATELY EXITED AND CONTROL RETURNED TO CALLER. B5000032^^ C B5000033^ ^ 2 INTEGER INBUF,ISTART,OBUF,OSTART,ECODE,STRPOS(10),EDTLEN(10),NINE B5000035^^ 3 INTEGER BLANK,MINUS,ZERO,ZSUPLN,BASE,EDIFIL(17) B5000036^ ^ 4 DATA STRPOS/0,1,0,7,15,0,24,0,0,0/,EDTLEN/0,7,0,9,11,0,10,0,0,0/ B5000038^^ 5 DATA NINE/$39/,BLANK/$20/,MINUS/$2D/,ZERO/$30/,ZSUPLN/5/ B5000039^^ 6 DATA EDIFIL/'99/99/9999999.999/999-9999-99-9999'/ B5000040^  ^ C CHECK FOR ILLEGAL EDIT CODE, OUT OF RANGE. B5000042^^ 7 IF(ECODE.LT.0.OR.ECODE.GT.9) GO TO 500 B5000043^^ C SET STARTING POSITION IN EDIT FILE FOR EDIT AND THE LENGTH OF EDITB5000044^^ C CHECK IF UNUSED EDIT CODE. B5000045^^ 8 BASE = STRPOS(ECODE+1) B5000046^^ 9 IF(BASE.EQ.0) GO TO 500 B5000047^^ 10 LEN = EDTLEN(ECODE+1) B5000048^ ^ C PEFORM THE EDITING. B5000050^t FTN 3.3B (OPT = LPC) EDIT PAGE 2 DATE: 08/29/84 TIME: 2137 t^ C ZERO INDEX INTO INPUT BUFFER. B5000051^^ 11 J = 0 B5000052^^ 12 DO 200 I=0,LEN B5000053^^ C RETRIEVE CHARACTER FROM EDIT FILE. B5000054^^ 13 CALL CCSGET(EDIFIL,BASE+I,M) B5000055^^ C IF CHARACTER IS NOT A NINE, STORE THE CHARACTER INTO THE OUTPUT BUB5000056^^ 14 IF(M.EQ.NINE) GO TO 100 B5000057^^ 15 CALL CCSPUT(M,OSTART+I,OBUF) B5000058^^ 16 GO TO 200 B5000059^^ C CHARACTER FROM EDIT FILE NOT AN EDIT CHARACTER. MOVE NEXT CHARACTEB5000060^^ C FROM INPUT BUFFER TO OUTPUT BUFFER. B5000061^^ 17 100 CALL CCSGET(INBUF,ISTART+J,M) B5000062^^ 18 CALL CCSPUT(M,OSTART+I,OBUF) B5000063^^ 19 J = J + 1 B5000064^^ 20 200 CONTINUE B5000065^  ^ C EDIT COMPLETE. EXIT IF EDIT WAS NOT FOR A DOLLAR AMOUNT FIELD. OTHB5000067^^ C WISE, ZERO SUPPRESS DOLLAR AMOUNTS AND CHECK DOLLR FIELD FOR A NEGB5000068^^ C ATIVE AMOUNT. B5000069^^ 21 IF(ECODE.NE.3) GO TO 500 B5000070^^ 22 DO 300 I=0,ZSUPLN B5000071^^ 23 CALL CCSGET(OBUF,OSTART+I,M) B5000072^^ 24 IF(M.NE.ZERO) GO TO 400 B5000073^^ 25 CALL CCSPUT(BLANK,OSTART+I,OBUF) B5000074^^ 26 300 CONTINUE B5000075^ ^ C ****************************************************** ???*A010********^^ C ..CHECK LAST DIGIT FOR OVERPUNCH & CONVERT AS REQUIRED ********^^ 27 400 J = OSTART + LEN ********^^ 28 CALL CCSGET (OBUF, J, M) ********^^ C ..IF NO OVERPUNCH(ASCII), SET SIGN=BLANK(POS.) & EXIT ********^^ 29 IF (M .LE. NINE) GO TO 420 ********^^ C ..IF OVERPUNCH = POSITIVE DIGIT($41-$49), CONVERT & SET SIGN ********^^ C .. = BLANK ********^^ 30 IF (M .GT. $49) GO TO 410 ********^^ 31 M = M - $10 ********^^ 32 CALL CCSPUT (M, J, OBUF) ********^^ 33 GO TO 420 ********^^ C ..IF OVERPUNCH=POSITIVE ZERO, CONVERT TO ASCII ZERO & SET ********^^ C .. SIGN=BLANK ********^^ 34 410 IF (M .NE. $7B) GO TO 430 ********^^ 35 CALL CCSPUT (ZERO, J, OBUF) ********^^ C ..SET SIGN = BLANK ********^^ 36 420 J = J + 1 ********^^ 37 CALL CCSPUT (BLANK, J, OBUF) ********^^ 38 GO TO 500 ********^^ C ..IF OVERPUNCH=NEG. ZERO, CONVERT & SET SIGN MINUS ********^^ 39 430 IF (M .NE. $7D) GO TO 440 ********^^ 40 CALL CCSPUT (ZERO, J, OBUF) ********^^ 41 GO TO 450 ********^^ C ..ASSUME OVERPUNCH = NEG. DIGIT($4A-$52), CONVERT & SET ********^^ C .. SIGN MINUS ********^^ 42 440 M = M - $19 ********^t FTN 3.3B (OPT = LPC) EDIT PAGE 3 DATE: 08/29/84 TIME: 2137 t^ 43 CALL CCSPUT (M, J, OBUF) ********^^ C ****************************************************** ???*A010********^^ C ****************************************************** ???*A009********^^ 44 450 J = J + 1 ********^^ 45 CALL CCSPUT (MINUS, J, OBUF) ********^^ C ****************************************************** ???*A009********^  ^ C EDITING COMPLETE. RETURN. B5000092^^ 46 500 RETURN. B5000093^^ 47 END B5000094^t FTN 3.3B (OPT = LPC) EDIT PAGE 4 DATE: 08/29/84 TIME: 2137 t  PROGRAM LENGTH $00F2 ( 242)   EXTERNALS  Q8PKUP Q8PREP CCSGET CCSPUT  t FTN 3.3B (OPT = LPC) EDIT PAGE 5 DATE: 08/29/84 TIME: 2137 t, ***** L I S T O F S Y M B O L S *****,   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < ( BASE INTEGER 0019 2,8,9,13 (( BLANK INTEGER 0015 2,5,25,37(, ECODE INTEGER 7FFF 1,2,7,8,10,21,& EDIFIL INTEGER 001A 2,6,13 && EDTLEN INTEGER 000A 2,4,10 &4 I INTEGER 002D 11,13,15,18,22,23,25 4& INBUF INTEGER 7FFF 1,2,17 && ISTART INTEGER 7FFF 1,2,17 &H J INTEGER 002C 10,11,17,19,27,28,32,35,36,37,40,43,44,45H* LEN INTEGER 002B 9,10,12,27 *N M INTEGER 002E 13,14,15,17,18,23,24,28,29,30,31,32,34,39,42,43N& MINUS INTEGER 0016 2,5,45 &( NINE INTEGER 0014 2,5,14,29(D OBUF INTEGER 7FFF 1,2,15,18,23,25,28,32,35,37,40,43,45 D2 OSTART INTEGER 7FFF 1,2,15,18,23,25,27 2$ STRPOS INTEGER 0000 2,4,8$, ZERO INTEGER 0017 2,5,24,35,40 ,& ZSUPLN INTEGER 0018 2,5,22 &   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < * CCSGET SUBROUTINE 004E 12,17,23,28*: CCSPUT SUBROUTINE 005A 14,18,25,32,35,37,40,43,45 : Q8PKUP INTEGER.FN. 00D6 Q8PREP INTEGER.FN. 00D3    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 100 0062 14,17$( 200 0071 11,16,20 ($ 300 0090 21,26$$ 400 0092 24,27$$ 410 00AB 30,34$( 420 00B2 29,33,36 ($ 430 00B9 34,39$$ 440 00C1 39,42$$ 450 00C8 40,44$, 500 00CD 7,9,21,38,46 ,t FTN 3.3B (OPT = LPC) EDIT PAGE 6 DATE: 08/29/84 TIME: 2137 t EDIT 00D0 1 t FTN 3.3B (OPT = LPC) FILERR PAGE 1 DATE: 08/29/84 TIME: 2137 t^ 1 SUBROUTINE FILERR(FILNAM,REQUES,ISTAT,LU) ********^^ 1 1 /B52 F CCS CCS 3.1 10-23-81 SL-149********^^ C ********^^ C FORMAT USER-SUPPLIED VARIABLES INTO AN ERROR MESSAGE AND ********^^ C DISPLAY IT ON THE TERMINAL. THE CRT OPERATOR MUST ********^^ C ACKNOWLEDGE THE MESSAGE BY TYPING CARRIAGE-RETURN. ********^^ C ********^^ C FILNAM: FOUR-WORD ARRAY CONTAINING ASCII FILE NAME ********^^ C REQUES: INTEGER DESIGNATING REQUEST ON WHICH ERROR OCCURRED-********^^ C 0 - CREATE 9 - RENAME ********^^ C 1 - CLEAR 10 - VOLUSE ********^^ C 2 - DELETE 11 - PUTS ********^^ C 3 - OPENFL 12 - WRITER ********^^ C 4 - CLOSFL 13 - READR ********^^ C 5 - LOKFIL 14 - GETS ********^^ C 6 - UNLFIL 15 - UPDREC ********^^ C 7 - GETFCB 16 - DELREC ********^^ C 8 - UPDFCB 17 - COMFIL ********^^ C ISTAT: FILE MANAGER ERROR STATUS WORD ********^^ C LU : LOGICAL UNIT OF TERMINAL ON WHICH TO DISPLAY MESSAGE********^^ C ********^^ C IF IS OTHER THAN THE INTEGERS 0-17, IT IS CONVERTED ********^^ C TO ASCII HEX AND IS USED IN LIEU OF THE REQUEST NAME. ********^^ C ********^^ 2 INTEGER FILNAM(4), REQUES ********^^ 2 1 , MSG(38), ACK(8) ********^^ 2 2 , SCRACH(3) ********^^ 2 3 , FILREQ(57) ********^^ C ********^^ 3 DATA MSG/$0D0A,'FILE MANAGER ERROR: FILE NAME = 12345678, REQUEST ********^^ 3 1= 123456, ISTAT = 1234. '/ ********^^ 4 DATA LENMSG/75/ ********^^ C--- THE FOLLOWING SPECIFIES BYTE POSITIONS IN THE ERROR MESSAGE ********^^ C WHERE ACTUAL FILE NAME, REQUEST, AND ISTAT ARE PLACED. ********^^ 5 DATA NAMFIL/35/, NREQ/55/, NISTAT/71/ ********^^ C ********^^ 6 DATA FILREQ/'CREATECLEAR DELETEOPENFLCLOSFLLOKFILUNLFILGETFCB' ********^^ 6 1 , 'UPDFCBRENAMEVOLUSEPUTS WRITERREADR GETS ' ********^^ 6 2 , 'UPDRECDELRECCOMFIL123456'/ ********^^ C ********^^ 7 DATA NONSTD/55/ ********^^ C ********^^ 8 DATA ACK/$0D0A,'CR TO CONTINUE'/ ********^^ 8 1 , LENACK/16/ ********^t FTN 3.3B (OPT = LPC) FILERR PAGE 2 DATE: 08/29/84 TIME: 2137 t^ C ********^^ C--- MOVE FILE NAME. ********^^ 9 CALL CCSMVA(FILNAM,1,8,MSG,NAMFIL,8) ********^^ C ********^^ C--- SAVE REQUEST TYPE CODE. ********^^ 10 KODE = REQUES ********^^ 11 IF(KODE.GE.0.AND.KODE.LE.17) GO TO 100 ********^^ C ********^^ C--- CONVERT THIS NON-STANDARD CODE TO ASCII HEX. ********^^ 12 CALL CCSHXA(KODE,FILREQ(NONSTD+1)) ********^^ 13 FILREQ(NONSTD) = $2024 ********^^ C ********^^ C--- CHANGE REQUEST CODE SO THAT IT POINTS TO LAST ENTRY IN . ********^^ 14 KODE = 18 ********^^ 15 100 CONTINUE ********^^ C ********^^ C--- MOVE REQUEST DESCRIPTION. ********^^ 16 J = 6*KODE +1 ********^^ 17 CALL CCSMVA(FILREQ,J,6,MSG,NREQ,6) ********^^ C ********^^ C--- CONVERT TO ASCII HEX. PLUG INTO ERROR MESSAGE. ********^^ 18 CALL CCSHXA(ISTAT,MSG(36)) ********^^ C ********^^ C--- DISPLAY ERROR MESSAGE. ********^^ 19 CALL WTREAD(LU,-1,MSG,LENMSG,0,0,0,J) ********^^ C ********^^ C--- DISPLAY ACKNOWLEDGE MESSAGE AND WAIT FOR CARRIAGE-RETURN. ********^^ 20 CALL WTREAD(LU,-1,ACK,LENACK,-1,SCRACH,1,J) ********^^ C ********^^ C ********^^ 21 RETURN ********^^ 22 END ********^t FTN 3.3B (OPT = LPC) FILERR PAGE 3 DATE: 08/29/84 TIME: 2137 t  PROGRAM LENGTH $00CB ( 203)   EXTERNALS & Q8PKUP Q8PREP CCSMVA CCSHXA WTREAD & t FTN 3.3B (OPT = LPC) FILERR PAGE 4 DATE: 08/29/84 TIME: 2137 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < $ FFFE (-1) 0077 19,20$$ 0000 (0) 0001 11,19$, 0001 (1) 0000 9,12,16,19,20,$ 0006 (6) 0076 16,17$" 0008 (8) 0072 9,9"" 2024 (8228) 0074 13 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < & ACK INTEGER 0028 2,8,20 &$ FILNAM INTEGER 7FFF 1,2,9$, FILREQ INTEGER 0033 2,6,12,13,17 ,$ ISTAT INTEGER 7FFF 1,18 $. J INTEGER 0075 15,16,17,19,20 .0 KODE INTEGER 0073 9,10,11,12,14,16 0$ LENACK INTEGER 0071 8,20 $$ LENMSG INTEGER 006C 3,19 $& LU INTEGER 7FFF 1,19,20&. MSG INTEGER 0002 2,3,9,17,18,19 ." NAMFIL INTEGER 006D 3,9" NISTAT INTEGER 006F 3 & NONSTD INTEGER 0070 6,12,13&$ NREQ INTEGER 006E 3,17 $& REQUES INTEGER 7FFF 1,2,10 &$ SCRACH INTEGER 0030 2,20 $   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < $ CCSHXA SUBROUTINE 008D 11,18$$ CCSMVA SUBROUTINE 0079 8,17 $ Q8PKUP INTEGER.FN. 00C0 Q8PREP INTEGER.FN. 00BD $ WTREAD SUBROUTINE 00A4 18,20$t FTN 3.3B (OPT = LPC) FILERR PAGE 5 DATE: 08/29/84 TIME: 2137 t   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 100 0095 11,15$ FILERR 00BA 1  t FTN 3.3B (OPT = LPC) FTNDT1 PAGE 1 DATE: 08/29/84 TIME: 2137 t^ 1 SUBROUTINE FTNDT1 ( P, COID) B5400001^^ 1 1 / F CCS CCS 3.0 1500 WD TBL SL-149 ********^^ C B5400003^^ C CYBERCREDIT SYSTEM VERSION 3 B5400004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B5400005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B5400006^^ C B5400007^  ^ C PARAMETERS B5400009^^ C INPUT P - AN ARRAY OF 6 CHARACTER DATA ELEMENTS, IE 3XN. B5400010^^ C OUTPUT COID - THE RETURNED 4 CHARACTER COLLECTOR ID B5400011^  ^ 2 INTEGER P(3,09), COID(2), INIT, PO, V1(3), V2(3) B5400013^^ 3 INTEGER CON, BOLVAL, TRUTH(2,09), TRUE, OLDLVL,OLDNLV, FIRST B5400014^^ C EQU FIRST 10 WORDS OF TABLE FOR GLOBAL INDICATORS B5400015^^ 4 EQUIVALENCE (INIT,TABLE(3)), (ITBLEN,TABLE(2)), B5400016^^ 4 * (ITYP,TABLE(4)), (ICTST,TABLE(5)), B5400017^^ 4 * (ICPRM,TABLE(6)) B5400018^^ C ************************************************ B5400019^^ C ***** ARRAY FOR DECISION TABLE **** B5400020^^ C LENGTH OF TABLE MUST BE IN 2ND WORD **** B5400021^^ 5 INTEGER TABLE (1502) ********^^ 6 DATA TABLE(2) /1500/ ********^^ C ************************************************ B5400024^^ 7 DATA IND/0/, FIRST/1/, TRUE/1/, NINES/$3939/ B5400025^  ^ C BEGIN EXECUTION B5400027^  ^ C READ IN DECISION TABLE IF 1ST TIME B5400029^^ 8 IF (FIRST .NE. 1) GO TO 100 B5400030^^ 9 J = TABLE(2) B5400031^^ 10 DO 50 I = 3, J B5400032^^ 11 50 TABLE(I) = 0 B5400033^^ 12 CALL RTVDT1 ( 1, TABLE, IND) B5400034^^ C CHECK FOR ERROR B5400035^^ 13 IF (IND .NE. 0) GO TO 8000 B5400036^^ 14 FIRST = 0 B5400037^  ^ C INITIALIZE THE TABLE B5400039^^ 15 100 INIT = 0 B5400040^^ C CCSGET THE 1ST TEST B5400041^^ 16 CALL GTSDT1 (TABLE,LVL,NLVL,NP) B5400042^  ^ C SAVE CURRENT LVL B5400044^^ 17 900 OLDLVL = LVL B5400045^  ^ C MAIN LOOP - CHECK EACH VARIABLE AGAINST PARAMETERIC VALUES B5400047^t FTN 3.3B (OPT = LPC) FTNDT1 PAGE 2 DATE: 08/29/84 TIME: 2137 t^ 18 DO 1000 I = 1, NP B5400048^  ^ C CCSGET OPERATOR OF ITH PARAMETER B5400050^^ C CCSGET THE VALUES AND CONNECTOR TO NEXT PARAMETER B5400051^^ 19 CALL GPMDT1 (TABLE,PO,V1,V2,CON) B5400052^^ 20 BOLVAL = TRUE B5400053^^ C IF THE OPERATOR IS NULL, FORCE TRUE B5400054^^ 21 IF ( PO .EQ. 0) GO TO 950 B5400055^  ^ C TEST THE INPUT VALUE VS. THE PARAMETRIC VALUES B5400057^^ 22 CALL TVPDT1 ( PO, P(1,I), V1, V2, BOLVAL) B5400058^^ C BOLVAL = 0-FALSE, 1-TRUE B5400059^^ C SAVE BOOLEAN VALUE AND NEXT CONNECTOR IN TRUTH TABLE B5400060^^ 23 950 TRUTH(1,I) = BOLVAL B5400061^^ 24 TRUTH(2,I) = CON B5400062^   ^ C END OF MAIN LOOP B5400064^^ 25 1000 CONTINUE B5400065^  ^ C EXAMINE RELATION BETWEEN PARAMETERS BASED ON TRUTH TABLE B5400067^^ 26 CALL TRHDT1 (TRUTH, NP, BOLVAL) B5400068^  ^ C IF TRUE, ASSIGN TO COLLECTOR AND CONTINUE WITH OTHER LEVELS B5400070^^ 27 IF ( BOLVAL .EQ. TRUE) GO TO 1500 B5400071^^ C OTHERWISE, START NEXT TEST B5400072^^ 28 CALL GTSDT1( TABLE,LVL,NLVL,NP) B5400073^^ C IF CURRENT LEVEL IS EXHAUSTED, RETURN B5400074^^ 29 IF (LVL .NE. OLDLVL) RETURN B5400075^^ C OTHERWISE, START TEST LOOP B5400076^^ 30 GO TO 900 B5400077^  ^ C TEST WAS TRUE, ASSIGN COLLECTOR B5400079^^ 31 1500 CALL VALDT1 (TABLE, COID) B5400080^^ C IF NEXT LEVEL BLANK, RETURN B5400081^^ 32 IF (NLVL .EQ. 0) RETURN B5400082^^ C OTHERWISE, FIND START OF LEVEL IN TABLE B5400083^^ 33 OLDNLV = NLVL B5400084^^ 34 1700 CALL GTSDT1( TABLE,LVL,NLVL,NP) B5400085^^ C CHECK FOR ERROR B5400086^^ 35 IF (LVL .LT. 0) GO TO 8000 B5400087^^ C START OF NEXT LEVEL FOUND B5400088^^ 36 IF ( LVL .EQ. OLDNLV) GO TO 900 B5400089^^ C OTHERWISE, KEEP LOOKING B5400090^^ 37 GO TO 1700 B5400091^  ^ C ERROR RETURNS, SET COID TO 9999 ON SYSTEM OR TABLE ERROR B5400093^t FTN 3.3B (OPT = LPC) FTNDT1 PAGE 3 DATE: 08/29/84 TIME: 2137 t^ 38 8000 COID(1) = NINES B5400094^^ 39 COID(2) = NINES B5400095^^ 40 RETURN B5400096^^ 41 END B5400097^t FTN 3.3B (OPT = LPC) FTNDT1 PAGE 4 DATE: 08/29/84 TIME: 2137 t  PROGRAM LENGTH $06A2 ( 1698)   EXTERNALS 2 Q8PKUP Q8PREP RTVDT1 GTSDT1 GPMDT1 TVPDT1 TRHDT1 2 VALDT1  t FTN 3.3B (OPT = LPC) FTNDT1 PAGE 5 DATE: 08/29/84 TIME: 2137 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < 2 0001 (1) 0000 7,8,12,18,22,23,38 2   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < 0 BOLVAL INTEGER 05E7 2,20,22,23,26,27 0, COID INTEGER 7FFF 1,2,31,38,39 ,& CON INTEGER 05E6 2,19,24&( FIRST INTEGER 05FD 2,7,8,14 (0 I INTEGER 0601 9,11,18,22,23,24 0 ICPRM INTEGER 0006 4 ICTST INTEGER 0005 4 & IND INTEGER 05FE 6,12,13&& INIT INTEGER 0003 2,4,15 & ITBLEN INTEGER 0002 4 ITYP INTEGER 0004 4 & J INTEGER 0600 8,9,10 &4 LVL INTEGER 0602 16,17,28,29,34,35,36 4& NINES INTEGER 05FF 7,38,39&. NLVL INTEGER 0603 16,28,32,33,34 .. NP INTEGER 0604 16,18,26,28,34 .& OLDLVL INTEGER 05FB 2,17,29&& OLDNLV INTEGER 05FC 2,33,36&& P INTEGER 7FFF 1,2,22 &* PO INTEGER 05DF 2,19,21,22 *> TABLE INTEGER 0001 4,4,5,6,9,11,12,16,19,28,31,34 >( TRUE INTEGER 05FA 2,7,20,27(* TRUTH INTEGER 05E8 2,23,24,26 *& V1 INTEGER 05E0 2,19,22&& V2 INTEGER 05E3 2,19,22&   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " GPMDT1 SUBROUTINE 0634 18 "( GTSDT1 SUBROUTINE 0626 15,28,34 ( Q8PKUP INTEGER.FN. 0698 Q8PREP INTEGER.FN. 0695 " RTVDT1 SUBROUTINE 0618 11 "" TRHDT1 SUBROUTINE 065B 25 "t FTN 3.3B (OPT = LPC) FTNDT1 PAGE 6 DATE: 08/29/84 TIME: 2137 t" TVPDT1 SUBROUTINE 0644 21 "" VALDT1 SUBROUTINE 0670 31 "   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 50 0611 9,11 $$ 100 0622 8,15 $( 900 062B 16,30,36 ($ 950 064A 21,23$$ 1000 0656 17,25$$ 1500 066F 27,31$$ 1700 067B 33,37$( 8000 068A 13,35,38 ( FTNDT1 0692 1 t FTN 3.3B (OPT = LPC) GPMDT1 PAGE 1 DATE: 08/29/84 TIME: 2138 t^ 1 SUBROUTINE GPMDT1 (TABLE, PO, V1, V2, CON) B5900001^^ 1 1 /B59 F CCS CCS 3.0 SL-149B5900002^^ C B5900003^^ C CYBERCREDIT SYSTEM VERSION 3 B5900004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B5900005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B5900006^^ C B5900007^^ C CCSGET PARAMETER DESCRIPTIONS B5900008^^ 2 INTEGER TABLE(10), PO, V1(3), V2(3), CON B5900009^^ C EQU FIRST 10 WORDS OF TABLE FOR GLOBAL INDICATORS B5900010^^ 3 EQUIVALENCE (INIT,TABLE(3)), (ITBLEN,TABLE(2)), B5900011^^ 3 * (ITYP,TABLE(4)), (ICTST,TABLE(5)), B5900012^^ 3 * (ICPRM,TABLE(6)) B5900013^^ 4 INTEGER POOF, CONOF B5900014^^ 5 DATA POOF/1/, CONOF/2/ B5900015^^ 6 CALL CCSGET ( TABLE(ICPRM), POOF, PO) B5900016^^ 7 PO = AND( $000F, PO) B5900017^^ 8 CALL CCSGET ( TABLE(ICPRM), CONOF, CON) B5900018^^ 9 CON = AND ($000F, CON) B5900019^^ C MOVE FIRST VALUE B5900020^^ 10 DO 100 I = 1,3 B5900021^^ 11 J = ICPRM + I B5900022^^ 12 100 V1(I) = TABLE(J) B5900023^^ C MOVE 2ND VALUE IF AVAILABLE B5900024^^ 13 IF (PO .LT. 5) GO TO 500 B5900025^^ 14 DO 200 I = 4, 6 B5900026^^ 15 J = ICPRM + I B5900027^^ 16 200 V2(I-3) = TABLE(J) B5900028^^ 17 ICPRM = ICPRM + 3 B5900029^^ C OTHERWISE, UPDATE POINTER TO NEXT PARAMETER AND RETURN B5900030^^ 18 500 ICPRM = ICPRM + 4 B5900031^^ 19 RETURN B5900032^^ 20 END B5900033^t FTN 3.3B (OPT = LPC) GPMDT1 PAGE 2 DATE: 08/29/84 TIME: 2138 t  PROGRAM LENGTH $005E ( 94)   EXTERNALS  Q8PKUP Q8PREP CCSGET  t FTN 3.3B (OPT = LPC) GPMDT1 PAGE 3 DATE: 08/29/84 TIME: 2138 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " 000F (15) 0002 7,9"   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " AND INTR.FN. 7FFF 7,9"& CON INTEGER 7FFF 1,2,8,9&$ CONOF INTEGER 0001 3,5,8$0 I INTEGER 0003 9,11,12,14,15,16 00 ICPRM INTEGER 7FFF 3,6,8,11,15,17,180 ICTST INTEGER 7FFF 3 INIT INTEGER 7FFF 2 ITBLEN INTEGER 7FFF 3 ITYP INTEGER 7FFF 3 . J INTEGER 0004 10,11,12,15,16 .* PO INTEGER 7FFF 1,2,6,7,13 *$ POOF INTEGER 0000 3,5,6$. TABLE INTEGER 7FFF 1,2,3,6,8,12,16.& V1 INTEGER 7FFF 1,2,12 && V2 INTEGER 7FFF 1,2,16 &   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " CCSGET SUBROUTINE 0009 5,8" Q8PKUP INTEGER.FN. 004D Q8PREP INTEGER.FN. 004A    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 100 001F 9,12 $$ 200 0031 13,16$$ 500 003D 13,18$ GPMDT1 0047 1  t FTN 3.3B (OPT = LPC) GTPDT1 PAGE 1 DATE: 08/29/84 TIME: 2138 t^ 1 SUBROUTINE GTPDT1 (TABLE, TN, WP) B6000001^^ 1 1 /B60 F CCS CCS 3.0 SL-149B6000002^^ C B6000003^^ C CYBERCREDIT SYSTEM VERSION 3 B6000004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B6000005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B6000006^^ C B6000007^^ C SUBROUTINE RETURNS THE WORD POSITION (WP) FOR THE TN TEST, B6000008^^ C NEGATIVE VALUE RETURNED IF ERROR B6000009^^ 2 INTEGER TABLE(11), WP, TN, TABLEN B6000010^^ 3 EQUIVALENCE ( TABLEN, TABLE(2)) B6000011^^ 4 IT = 0 B6000012^^ 5 WP= 11 B6000013^^ 6 10 IT =IT + 1 B6000014^^ 7 IF ( IT .EQ. TN) RETURN B6000015^^ 8 WP = WP + TABLE(WP) B6000016^^ 9 IF ( TABLE(WP) .EQ. 0) GO TO 8000 B6000017^^ 10 IF (WP .GT. TABLE(TABLEN) ) GO TO 8000 B6000018^^ 11 GO TO 10 B6000019^^ 12 8000 WP = $8001 B6000020^^ 13 RETURN B6000021^^ 14 END B6000022^t FTN 3.3B (OPT = LPC) GTPDT1 PAGE 2 DATE: 08/29/84 TIME: 2138 t  PROGRAM LENGTH $0034 ( 52)   EXTERNALS  Q8PKUP Q8PREP  t FTN 3.3B (OPT = LPC) GTPDT1 PAGE 3 DATE: 08/29/84 TIME: 2138 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " 8001 (-32766) 0001 12 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < & IT INTEGER 0000 3,4,6,7&, TABLE INTEGER 7FFF 1,2,3,8,9,10 ,& TABLEN INTEGER 7FFF 2,3,10 &$ TN INTEGER 7FFF 1,2,7$. WP INTEGER 7FFF 1,2,5,8,9,10,12.   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  Q8PKUP INTEGER.FN. 0029 Q8PREP INTEGER.FN. 0026    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 10 0006 5,11 $& 8000 001E 9,10,12& GTPDT1 0023 1  t FTN 3.3B (OPT = LPC) GTSDT1 PAGE 1 DATE: 08/29/84 TIME: 2138 t^ 1 SUBROUTINE GTSDT1 ( TABLE,LVL,NLVL,NP) B6100001^^ 1 1 /B61 F CCS CCS 3.0 SL-149B6100002^^ C B6100003^^ C CYBERCREDIT SYSTEM VERSION 3 B6100004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B6100005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B6100006^^ C B6100007^^ C CCSGET NEXT TEST FROM TABLE B6100008^^ 2 INTEGER TABLE(10) B6100009^^ C EQU FIRST 10 WORDS OF TABLE FOR GLOBAL INDICATORS B6100010^^ 3 EQUIVALENCE (INIT,TABLE(3)), (ITBLEN,TABLE(2)), B6100011^^ 3 * (ITYP,TABLE(4)), (ICTST,TABLE(5)), B6100012^^ 3 * (ICPRM,TABLE(6)) B6100013^^ 4 DATA LVLOF/3/, NLVLOF/4/, NPOF/5/ B6100014^  ^ C CHECK FOR NEW CALL FOR ENTIRE PROCESS B6100016^^ 5 IF (INIT .NE. 0) GO TO 100 B6100017^^ C NEW CALL, SET INDICES TO INITIAL CONDITION B6100018^^ 6 INIT = 1 B6100019^^ 7 ICTST = 11 B6100020^^ 8 ICPRM = 14 B6100021^^ 9 GO TO 200 B6100022^  ^ C CALCULATE START OF NEXT TEST B6100024^^ 10 100 ICTST = ICTST + TABLE(ICTST) B6100025^^ 11 ICPRM = ICTST + 3 B6100026^^ C CHECK FOR END (ERROR) B6100027^^ 12 IF (TABLE(ICTST) .EQ. 0 .OR. ICTST .GE. ITBLEN) GO TO 8000 B6100028^^ C OTHERWISE SET UP FOR TEST AND RETURN B6100029^^ 13 200 CALL CCSGET (TABLE(ICTST),LVLOF, LVL) B6100030^^ 14 CALL CCSGET ( TABLE(ICTST), NLVLOF, NLVL) B6100031^^ 15 LVL = AND ($000F, LVL) B6100032^^ 16 NLVL = AND ($000F,NLVL) B6100033^^ 17 CALL CCSGET ( TABLE(ICTST), NPOF, NP) B6100034^^ 18 NP = AND ($000F, NP) B6100035^^ 19 RETURN B6100036^^ C ERROR, SET LEVEL MINUS B6100037^^ 20 8000 LVL = $8001 B6100038^^ 21 NLVL = 0 B6100039^^ 22 NP = 0 B6100040^^ 23 RETURN B6100041^^ 24 END B6100042^t FTN 3.3B (OPT = LPC) GTSDT1 PAGE 2 DATE: 08/29/84 TIME: 2138 t  PROGRAM LENGTH $0066 ( 102)   EXTERNALS  Q8PKUP Q8PREP CCSGET  t FTN 3.3B (OPT = LPC) GTSDT1 PAGE 3 DATE: 08/29/84 TIME: 2138 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " 8001 (-32766) 0004 20 "( 000F (15) 0003 15,16,18 (   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < ( AND INTR.FN. 7FFF 15,16,18 (& ICPRM INTEGER 7FFF 3,8,11 &4 ICTST INTEGER 7FFF 3,7,10,11,12,13,14,174$ INIT INTEGER 7FFF 2,5,6$$ ITBLEN INTEGER 7FFF 3,12 $ ITYP INTEGER 7FFF 3 * LVL INTEGER 7FFF 1,13,15,20 *$ LVLOF INTEGER 0000 3,13 $* NLVL INTEGER 7FFF 1,14,16,21 *$ NLVLOF INTEGER 0001 3,14 $* NP INTEGER 7FFF 1,17,18,22 *$ NPOF INTEGER 0002 3,17 $4 TABLE INTEGER 7FFF 1,2,3,10,12,13,14,17 4   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < ( CCSGET SUBROUTINE 0027 13,14,17 ( Q8PKUP INTEGER.FN. 0053 Q8PREP INTEGER.FN. 0050    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 100 0012 5,10 $$ 200 0023 8,13 $$ 8000 0045 12,20$ GTSDT1 004D 1  t FTN 3.3B (OPT = LPC) INPUT PAGE 1 DATE: 08/29/84 TIME: 2138 t^ 1 SUBROUTINE INPUT (LU, BUF, NCH) B6400001^^ 1 1 /B64 F CCS CCS 3.0 SL-149B6400002^^ C B6400003^^ C CYBERCREDIT SYSTEM VERSION 3 B6400004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B6400005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B6400006^^ C B6400007^^ 2 INTEGER BUF(30), TEMP(8) B6400008^^ 3 IFLG = 0 B6400009^^ 4 ASSIGN 105 TO ICOMPL B6400010^^ 5 CALL FREAD (LU, BUF, 58, ICOMPL, IFLG, TEMP) B6400011^^ 6 CALL DISP B6400012^^ 7 105 NCH = BUF(30) B6400013^^ 8 RETURN B6400014^^ 9 END B6400015^t FTN 3.3B (OPT = LPC) INPUT PAGE 2 DATE: 08/29/84 TIME: 2138 t  PROGRAM LENGTH $0031 ( 49)   EXTERNALS  Q8PKUP Q8PREP FREAD DISP  t FTN 3.3B (OPT = LPC) INPUT PAGE 3 DATE: 08/29/84 TIME: 2138 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : <  003A (58) 000A 5    VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < & BUF INTEGER 7FFF 1,2,5,7&" ICOMPL INTEGER 0009 3,5"$ IFLG INTEGER 0008 2,3,5$" LU INTEGER 7FFF 1,5"" NCH INTEGER 7FFF 1,7"" TEMP INTEGER 0000 2,5"   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  DISP SUBROUTINE 0019 5 FREAD SUBROUTINE 0011 3 Q8PKUP INTEGER.FN. 0027 Q8PREP INTEGER.FN. 0024    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < " 105 001A 3,7" INPUT 0021 1  t FTN 3.3B (OPT = LPC) INTGR PAGE 1 DATE: 08/29/84 TIME: 2138 t^ 1 SUBROUTINE INTGR ( INBF, NCH, IOUT) B6500001^^ 1 1 /B65 F CCS CCS 3.0 SL-149B6500002^^ C B6500003^^ C CYBERCREDIT SYSTEM VERSION 3 CCS B6500004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B6500005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B6500006^^ C B6500007^^ 2 INTEGER INBF(1) B6500008^^ 3 J = 0 B6500009^^ 4 IOUT = 0 B6500010^^ 5 DO 100 I = NCH, 1, -1 B6500011^^ 6 CALL CCSGET (INBF, I, IWK) B6500012^^ 7 IWK = AND (IWK, $F) B6500013^^ 8 IOUT = (IWK*10**J) + IOUT B6500014^^ 9 J = J + 1 B6500015^^ 10 100 CONTINUE B6500016^^ 11 RETURN B6500017^^ 12 END B6500018^t FTN 3.3B (OPT = LPC) INTGR PAGE 2 DATE: 08/29/84 TIME: 2138 t  PROGRAM LENGTH $0033 ( 51)   EXTERNALS  Q8QI2F Q8PKUP Q8PREP CCSGET  t FTN 3.3B (OPT = LPC) INTGR PAGE 3 DATE: 08/29/84 TIME: 2138 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : <  000A (10) 0004 8 000F (15) 0003 7    VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  AND INTR.FN. 7FFF 7 " I INTEGER 0001 4,6"$ INBF INTEGER 7FFF 1,2,6$$ IOUT INTEGER 7FFF 1,4,8$$ IWK INTEGER 0002 6,7,8$& J INTEGER 0000 2,3,8,9&" NCH INTEGER 7FFF 1,5"   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  CCSGET SUBROUTINE 000E 5 Q8PKUP INTEGER.FN. 002B Q8PREP INTEGER.FN. 0028 Q8QI2F INTEGER.FN. 0016    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 100 001D 4,10 $ INTGR 0025 1  t FTN 3.3B (OPT = LPC) LCLRFL PAGE 1 DATE: 08/29/84 TIME: 2138 t^ 1 PROGRAM LCLRFL B6800001^^ 1 1 /B68 F CCS CCS 3.0 SL-149B6800002^^ C B6800003^^ C CYBERCREDIT SYSTEM VERSION 3 B6800004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B6800005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B6800006^^ C B6800007^^ C THIS PROGRAM CLEARS DATA FILES USED BY INSTALLATION TEST B6800008^^ C KIT PROCEDURES. IT IS EXECUTED IN THE SYSTEM CONFIGURATOR MENU B6800009^^ C B6800010^^ 2 INTEGER ID(4) B6800011^^ 3 INTEGER TERMIN, BLANKS B6800012^^ 4 INTEGER REQBUF(24), IDATA(12,40), NUMENT B6800013^^ 5 INTEGER F1(12), F2(12), F3(12), F4(12), F5(12), F6(12), B6800014^^ 5 1 F7(12), F8(12), F9(12), F10(12), F11(12), F12(12), B6800015^^ 5 2 F13(12), F14(12), F15(12), F16(12), F17(12), F18(12), B6800016^^ 5 3 F19(12), F20(12), F21(12), F22(12), F23(12), F24(12), B6800017^^ 5 4 F25(12), F26(12), F27(12), F28(12), F29(12), F30(12), B6800018^^ 5 5 F31(12), F32(12), F33(12), F34(12), F35(12), F36(12) B6800019^^ 6 INTEGER F37(12), F38(12), F39(12), F40(12) B6800020^^ 7 EQUIVALENCE ( IDATA(1, 1), F1(1) ) , ( IDATA(1, 2), F2(1) ) , B6800021^^ 7 1 ( IDATA(1, 3), F3(1) ) , ( IDATA(1, 4), F4(1) ) , B6800022^^ 7 2 ( IDATA(1, 5), F5(1) ) , ( IDATA(1, 6), F6(1) ) , B6800023^^ 7 3 ( IDATA(1, 7), F7(1) ) , ( IDATA(1, 8), F8(1) ) , B6800024^^ 7 4 ( IDATA(1, 9), F9(1) ) , ( IDATA(1,10), F10(1) ) , B6800025^^ 7 5 ( IDATA(1,11), F11(1) ) , ( IDATA(1,12), F12(1) ) B6800026^^ 8 EQUIVALENCE ( IDATA(1,13), F13(1) ) , ( IDATA(1,14), F14(1) ) , B6800027^^ 8 1 ( IDATA(1,15), F15(1) ) , ( IDATA(1,16), F16(1) ) , B6800028^^ 8 2 ( IDATA(1,17), F17(1) ) , ( IDATA(1,18), F18(1) ) , B6800029^^ 8 3 ( IDATA(1,19), F19(1) ) , ( IDATA(1,20), F20(1) ) , B6800030^^ 8 4 ( IDATA(1,21), F21(1) ) , ( IDATA(1,22), F22(1) ) , B6800031^^ 8 5 ( IDATA(1,23), F23(1) ) , ( IDATA(1,24), F24(1) ) B6800032^^ 9 EQUIVALENCE ( IDATA(1,25), F25(1) ) , ( IDATA(1,26), F26(1) ) , B6800033^^ 9 1 ( IDATA(1,27), F27(1) ) , ( IDATA(1,28), F28(1) ) , B6800034^^ 9 2 ( IDATA(1,29), F29(1) ) , ( IDATA(1,30), F30(1) ) , B6800035^^ 9 3 ( IDATA(1,31), F31(1) ) , ( IDATA(1,32), F32(1) ) , B6800036^^ 9 4 ( IDATA(1,33), F33(1) ) , ( IDATA(1,34), F34(1) ) , B6800037^^ 9 5 ( IDATA(1,35), F35(1) ) , ( IDATA(1,36), F36(1) ) B6800038^^ 10 EQUIVALENCE ( IDATA(1,37), F37(1) ) , ( IDATA(1,38), F38(1) ) , B6800039^^ 10 1 ( IDATA(1,39), F39(1) ) , ( IDATA(1,40), F40(1) ) B6800040^ ^ 11 DATA TERMIN / '**' / B6800042^^ 12 DATA BLANKS / ' ' / B6800043^t FTN 3.3B (OPT = LPC) LCLRFL PAGE 2 DATE: 08/29/84 TIME: 2138 t^ C**** TABLE OF FILE NAMES/OWNERS TO BE CLEARED - DOUBLE ASTERISK ("**") B6800045^^ C**** IN FIRST TWO CHARACTERS OF FILE NAME INDICATE END OF TABLE. B6800046^^ C**** BLANKS FOR FIRST TWO CHARACTERS OF FILE NAME IS A NULL ENTRY (BY- B6800047^^ C**** PASSED). B6800048^ ^ 13 DATA F1 / 'LAACCAGELA ' / B6800050^^ 14 DATA F2 / 'LAAGEWRKLA ' / B6800051^^ 15 DATA F3 / 'LAACTFILLA ' / B6800052^^ 16 DATA F4 / 'LAACTIVELA ' / B6800053^^ 17 DATA F5 / 'LAACTVTBLA ' / B6800054^^ 18 DATA F6 / 'LAADDACTLA ' / B6800055^^ 19 DATA F7 / 'LAAVMDSCLA ' / B6800056^^ 20 DATA F8 / 'LACLIENTLA ' / B6800057^^ 21 DATA F9 / 'LACOLSTSLA ' / B6800058^^ 22 DATA F10 / 'LACOSIGNLA ' / B6800059^^ 23 DATA F11 / 'LADAQUE LA ' / B6800060^^ 24 DATA F12 / 'LADECTBLLA ' / B6800061^^ 25 DATA F13 / 'LADLQKEYLA ' / B6800062^^ 26 DATA F14 / 'LADLQMSTLA ' / B6800063^^ 27 DATA F15 / 'LADLYASNLA ' / B6800064^^ 28 DATA F16 / 'LADLYWRKLA ' / B6800065^^ 29 DATA F17 / 'LAFILTMPLA ' / B6800066^^ 30 DATA F18 / 'LAFINTRNLA ' / B6800067^^ 31 DATA F19 / 'LAINACCTLA ' / B6800068^^ 32 DATA F20 / 'LALTRDSCLA ' / B6800069^^ 33 DATA F21 / 'LALTRFILLA ' / B6800070^^ 34 DATA F22 / 'LAPMTFILLA ' / B6800071^^ 35 DATA F23 / 'LAPGEXTRLA ' / B6800072^^ 36 DATA F24 / 'LARPTDATLA ' / B6800073^^ 37 DATA F25 / 'LARPTPGMLA ' / B6800074^^ 38 DATA F26 / 'LARSWFILLA ' / B6800075^^ 39 DATA F27 / 'LASREQDLLA ' / B6800076^^ 40 DATA F28 / 'LASUMHSTLA ' / B6800077^^ 41 DATA F29 / 'LATAPARCLA ' / B6800078^^ 42 DATA F30 / 'LATRANFLLA ' / B6800079^^ 43 DATA F31 / 'LATRNBCKLA ' / B6800080^^ 44 DATA F32 / 'LATRNSFLLA ' / B6800081^^ 45 DATA F33 / 'LAUPHSCMLA ' / B6800082^^ 46 DATA F34 / 'LAUTIFILLA ' / B6800083^^ 47 DATA F35 / '** ' / B6800084^^ 48 DATA F36 / ' ' / B6800085^^ 49 DATA F37 / ' ' / B6800086^^ 50 DATA F38 / ' ' / B6800087^^ 51 DATA F39 / ' ' / B6800088^^ 52 DATA F40 / ' ' / B6800089^ ^ 53 DATA NUMENT / 40 / B6800091^t FTN 3.3B (OPT = LPC) LCLRFL PAGE 3 DATE: 08/29/84 TIME: 2138 t^ C**** RETRIEVE PROGRAM INFORMATION. B6800093^^ 54 50 CALL PGMIN ( ID, LU, MODE, NOPORT ) B6800094^ ^ C**** STARTING WITH FIRST TABLE ENTRY OF IDATA THRU LAST ENTRY DO B6800096^^ 55 100 DO 200 I=1,NUMENT B6800097^^ C** IF ENTRY IS TABLE TERMINATOR, EXIT LOOP AND TERMINATE PROGRAM B6800098^^ 56 IF ( IDATA(1,I) .EQ. TERMIN ) GO TO 300 B6800099^^ C** ELSE, CONTINUE. B6800100^ ^ C** IF FIRST TWO CHARACTERS OF FILE NAME BLANK, CONTINUE WITH NEXTB6800102^^ C** FILE NAME B6800103^^ 57 IF ( IDATA(1,I) .EQ. BLANKS ) GO TO 200 B6800104^^ C** ELSE, ZERO REQUEST BUFFER AND CLEAR SPECIFIED FILE B6800105^^ 58 DO 150 J=1,24 B6800106^^ 59 150 REQBUF(J) = 0 B6800107^^ 60 CALL CLEAR ( REQBUF, IDATA(1,I), ISTAT ) B6800108^^ C** IF NO ERROR, CONTINUE B6800109^^ 61 IF ( ISTAT .GE. 0 ) GO TO 200 B6800110^^ C** ELSE, REPORT ERROR B6800111^^ 62 CALL FILERR ( IDATA(1,I), 1, ISTAT, LU ) B6800112^^ C** EXIT LOOP AND TERMINATE PROGRAM B6800113^^ 63 GO TO 300 B6800114^^ C** CONTINUE LOOP. B6800115^^ 64 200 CONTINUE B6800116^   ^ C**** EXIT, NORMAL AND ERROR. B6800118^^ 65 300 CALL PGMOUT B6800119^^ 66 END B6800120^t FTN 3.3B (OPT = LPC) LCLRFL PAGE 4 DATE: 08/29/84 TIME: 2138 t  PROGRAM LENGTH $0253 ( 595)   EXTERNALS & Q8STP PGMIN CLEAR FILERR PGMOUT & t FTN 3.3B (OPT = LPC) LCLRFL PAGE 5 DATE: 08/29/84 TIME: 2138 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < : 0001 (1) 0002 7,8,9,10,55,56,57,58,60,62 :   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < & BLANKS INTEGER 0008 1,12,57&& F1 INTEGER 0021 1,7,13 && F10 INTEGER 008D 1,7,22 && F11 INTEGER 0099 1,7,23 && F12 INTEGER 00A5 1,7,24 && F13 INTEGER 00B1 1,8,25 && F14 INTEGER 00BD 1,8,26 && F15 INTEGER 00C9 1,8,27 && F16 INTEGER 00D5 1,8,28 && F17 INTEGER 00E1 1,8,29 && F18 INTEGER 00ED 1,8,30 && F19 INTEGER 00F9 1,8,31 && F2 INTEGER 002D 1,7,14 && F20 INTEGER 0105 1,8,32 && F21 INTEGER 0111 1,8,33 && F22 INTEGER 011D 1,8,34 && F23 INTEGER 0129 1,8,35 && F24 INTEGER 0135 1,8,36 && F25 INTEGER 0141 1,9,37 && F26 INTEGER 014D 1,9,38 && F27 INTEGER 0159 1,9,39 && F28 INTEGER 0165 1,9,40 && F29 INTEGER 0171 1,9,41 && F3 INTEGER 0039 1,7,15 && F30 INTEGER 017D 1,9,42 && F31 INTEGER 0189 1,9,43 && F32 INTEGER 0195 1,9,44 && F33 INTEGER 01A1 1,9,45 && F34 INTEGER 01AD 1,9,46 && F35 INTEGER 01B9 1,9,47 && F36 INTEGER 01C5 1,9,48 && F37 INTEGER 01D1 1,10,49&& F38 INTEGER 01DD 1,10,50&& F39 INTEGER 01E9 1,10,51&& F4 INTEGER 0045 1,7,16 && F40 INTEGER 01F5 1,10,52&& F5 INTEGER 0051 1,7,17 && F6 INTEGER 005D 1,7,18 &t FTN 3.3B (OPT = LPC) LCLRFL PAGE 6 DATE: 08/29/84 TIME: 2138 t& F7 INTEGER 0069 1,7,19 && F8 INTEGER 0075 1,7,20 && F9 INTEGER 0081 1,7,21 &. I INTEGER 0205 54,56,57,60,62 .$ ID INTEGER 0003 1,54 $6 IDATA INTEGER 0021 1,7,8,9,10,56,57,60,62 6( ISTAT INTEGER 0207 60,61,62 ($ J INTEGER 0206 57,59$$ LU INTEGER 0202 54,62$" MODE INTEGER 0203 54 "" NOPORT INTEGER 0204 54 "& NUMENT INTEGER 0201 1,53,55&& REQBUF INTEGER 0009 1,59,60&& TERMIN INTEGER 0007 1,11,56&   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " CLEAR SUBROUTINE 0239 59 "" FILERR SUBROUTINE 0246 61 "" PGMIN SUBROUTINE 0209 53 "" PGMOUT SUBROUTINE 0250 65 " Q8STP INTEGER.FN. 0252    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < " 50 0208 53 "" 100 020E 54 "$ 150 022B 57,59$* 200 024D 54,57,61,64*( 300 024F 56,63,65 ( LCLRFL 0000 1 t FTN 3.3B (OPT = LPC) LDTDT1 PAGE 1 DATE: 08/29/84 TIME: 2139 t^ 1 SUBROUTINE LDTDT1 ( TABLE, ILU, IND) B7000001^^ 1 1 /B70 F CCS CCS 3.0 SL-149B7000002^^ C B7000003^^ C CYBERCREDIT SYSTEM VERSION 3 B7000004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B7000005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B7000006^^ C B7000007^^ C LOADS UP TABLE FROM SEQUENTIAL 80 BYTE RECORD FILE B7000008^^ 2 INTEGER TABLE(10), IDATA(40), EOFMRK B7000009^^ 3 EQUIVALENCE (ITBLEN, TABLE(2)) , (MAXTAB,TABLE(9)) B7000010^^ 4 INTEGER STARS B7000011^^ 5 DATA STARS /'**'/, EOFMRK / '%%' / B7000012^^ 6 IND = 0 B7000013^^ 7 JX = 11 B7000014^^ 8 IWDP = JX B7000015^^ 9 IWD = 1 B7000016^^ 10 50 READ (ILU, 9000) IDATA B7000017^^ 11 9000 FORMAT (40A2) B7000018^^ 12 IF (IDATA(1).EQ.EOFMRK) GO TO 7000 B7000019^^ C CHECK FOR SHORT RECORD B7000020^^ 13 DO 100 I = 1, 40 B7000021^^ 14 JX = JX + 1 B7000022^^ 15 IF ( IDATA(I) .EQ. STARS) GO TO 200 B7000023^^ 16 IWD = IWD + 1 B7000024^^ C CHECK TABLE LENGTH B7000025^^ 17 IF ( JX .GT. MAXTAB) GO TO 8000 B7000026^^ 18 100 TABLE (JX) = IDATA(I) B7000027^^ 19 GO TO 50 B7000028^^ C END OF TEST, STORE CNT OF WORDS IN TEST B7000029^^ 20 200 TABLE(IWDP) = IWD B7000030^^ 21 IWDP = JX B7000031^^ 22 IWD = 1 B7000032^^ 23 GO TO 50 B7000033^^ C EOF ON INPUT TO TABLE, SAVE CURRENT TABLE LENGTH B7000034^^ 24 7000 ITBLEN = JX - 1 B7000035^^ 25 RETURN B7000036^   ^ C ERROR SECTION B7000038^^ C EXCEEDED TABLE LENGTH B7000039^^ 26 8000 IND = $8001 B7000040^^ 27 RETURN B7000041^^ 28 END B7000042^t FTN 3.3B (OPT = LPC) LDTDT1 PAGE 2 DATE: 08/29/84 TIME: 2139 t  PROGRAM LENGTH $0097 ( 151)   EXTERNALS & Q8PKUP Q8PREP Q8QINI Q8QX Q8QEND & t FTN 3.3B (OPT = LPC) LDTDT1 PAGE 3 DATE: 08/29/84 TIME: 2139 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " 8001 (-32766) 002F 26 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < & EOFMRK INTEGER 0029 2,5,12 &( I INTEGER 002E 12,15,18 (, IDATA INTEGER 0001 2,10,12,15,18,$ ILU INTEGER 7FFF 1,10 $& IND INTEGER 7FFF 1,6,26 &$ ITBLEN INTEGER 7FFF 2,24 $, IWD INTEGER 002D 8,9,16,20,22 ,( IWDP INTEGER 002C 7,8,20,21(4 JX INTEGER 002B 6,7,8,14,17,18,21,24 4$ MAXTAB INTEGER 7FFF 3,17 $" Q8QX1 INTEGER 0000 10 "& STARS INTEGER 002A 3,5,15 &* TABLE INTEGER 7FFF 1,2,3,18,20*   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  Q8PKUP INTEGER.FN. 008A Q8PREP INTEGER.FN. 0087 Q8QEND INTEGER.FN. 004C Q8QINI INTEGER.FN. 0038 " Q8QX SUBROUTINE 0044 10 "   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < & 50 0037 9,19,23&$ 100 0066 12,18$$ 200 0072 15,20$$ 7000 007A 12,24$$ 8000 007F 17,26$$ 9000 004F 10,11$t FTN 3.3B (OPT = LPC) LDTDT1 PAGE 4 DATE: 08/29/84 TIME: 2139 t LDTDT1 0084 1 t FTN 3.3B (OPT = LPC) LMOVDT PAGE 1 DATE: 08/29/84 TIME: 2139 t^ 1 PROGRAM LMOVDT B7100001^^ 1 1 /B71 F CCS CCS 3.0 SL-149B7100002^^ C B7100003^^ C CYBERCREDIT SYSTEM VERSION 3 B7100004^^ C DATA SYSTEM - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B7100005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B7100006^^ C B7100007^^ C THIS PROGRAM COPIES ONE FILE TO ANOTHER FILE. B7100008^^ C THE MAXIMUM CHARACTERS TO BE COPIED IS 3000. BOTH FILES B7100009^^ C MUST HAVE THE SAME FILE DESCRIPTION. *** NOTE B7100010^^ C DELETED RECORDS ARE NOT COPIED TO THE OUTPUT FILE. B7100011^^ C B7100012^ ^ 2 INTEGER EOF,FCBI(96),FCBO(96),FMRDEL,FDEL B7100014^^ 3 INTEGER IDUSER(4),IBUF(5) B7100015^^ 4 INTEGER IDATA(15),INBUF(24),INREC(7502),KEY(50) B7100016^^ 5 INTEGER MSG1(17),MSG2(14),MSG3(8),MSG4(12),MSG5(7) B7100017^^ 6 INTEGER MSG10(19),MSG11(16),MSG12(17) B7100018^^ 7 INTEGER ODATA(15),OUTBUF(24),OUTREC(1502) B7100019^^ 8 INTEGER RECLEN,ZERO B7100020^^ 9 INTEGER INAMES(56),ONAMES(56),ASTRSK,BLANK(12) B7100021^^ C B7100022^^ 10 DATA INAMES/ B7100023^^ 10 1'DLACTVTB$$ DLDECTBL$$ DLRPTTBL$$ ', B7100024^^ 10 2'DLSCNDSC$$ DLSCNFIL$$ DLUTIFIL$$ ', B7100025^^ 10 3'** '/ B7100026^^ 11 DATA ONAMES/ B7100027^^ 11 1'LAACTVTBLA LADECTBLLA LARPTTBLLA ', B7100028^^ 11 2'LASCNDSCLA LASCNFILLA LAUTIFILLA ', B7100029^^ 11 3'** '/ B7100030^^ C B7100031^^ 12 DATA BLANK/12*$2020/,ASTRSK/'**'/ B7100032^^ 13 DATA EOF/0/,ICNT/0/,ZERO/0/ B7100033^^ 14 DATA INBUF/24*0/,OUTBUF/24*0/ B7100034^ ^ 15 DATA IDATA/12*$2020,0,5,0/ B7100036^^ 16 DATA ODATA/12*$2020,0,1,-1/ B7100037^ ^ 17 DATA MSG1/$1800,'INDEX FILE COPY (MAX 3000 BYTES)'/ B7100039^^ 18 DATA MSG2/$0A0D,$0A0D,'FILE NAME TO COPY FROM '/ B7100040^^ 19 DATA MSG3/$0A0D,'VOLUME NAME '/ B7100041^^ 20 DATA MSG4/$0A0D,'FILE NAME TO COPY TO '/ B7100042^^ 21 DATA MSG5/$0A0D,'OWNER NAME '/ B7100043^^ 22 DATA MSG10/$0A0D,$0A0D,'XXXXXXXX FILE COULD NOT BE LOCATED'/ B7100044^^ 23 DATA MSG11/$0A0D,$0A0D,'XXXXXXXX FILE NOT INDEX FILE'/ B7100045^^ 24 DATA MSG12/$0A0D,$0A0D,'FILE DESCRIPTION NOT THE SAME '/ B7100046^ ^ 25 EXTERNAL FMRDEL B7100048^ ^ 26 CALL PGMIN(IDUSER,LUNIT,MODE,NOPORT) B7100050^^ 27 ASSEM $C000,FMRDEL,$6800,FDEL B7100051^ ^ C B7100053^^ 28 K = 1 B7100054^t FTN 3.3B (OPT = LPC) LMOVDT PAGE 2 DATE: 08/29/84 TIME: 2139 t^ 29 GO TO 100 B7100055^^ 30 90 K = K + 16 B7100056^^ 31 100 CALL CCSCST(INAMES,K,2,ASTRSK,1,2,ICMP) B7100057^^ 32 IF(ICMP.EQ.0) GO TO 990 B7100058^^ C B7100059^^ C B7100060^^ 33 110 CALL CCSMVA(INAMES,K,16,IDATA,1,16) B7100061^^ 34 CALL CCSMVA(BLANK,1,8,IDATA,17,8) B7100062^^ C B7100063^^ 35 CALL CCSMVA(ONAMES,K,16,ODATA,1,16) B7100064^^ 36 CALL CCSMVA(BLANK,1,8,ODATA,17,8) B7100065^^ C B7100066^^ 37 DO 120 M = 1,24 B7100067^^ 38 INBUF(M)= 0 B7100068^^ 39 OUTBUF(M) = 0 B7100069^^ 40 120 CONTINUE B7100070^^ C OPEN INPUT FILE B7100071^^ 41 200 CALL OPENFL(INBUF,IDATA,ISTAT) B7100072^^ 42 IF(AND(ISTAT,$8002).EQ.$8002) GO TO 320 B7100073^^ 43 IF(ISTAT.GE.0) GO TO 205 B7100074^^ 44 CALL FILERR(IDATA,3,ISTAT,LUNIT) B7100075^^ 45 GO TO 990 B7100076^ ^ C CLEAR THE OUTPUT FILE B7100078^^ 46 205 CALL CLEAR(OUTBUF,ODATA,ISTAT) B7100079^^ 47 IF(ISTAT.GE.0) GO TO 210 B7100080^^ 48 CALL FILERR(ODATA,1,ISTAT,LUNIT) B7100081^^ 49 GO TO 990 B7100082^ ^ C OPEN OUTPUT FILE B7100084^^ 50 210 CALL OPENFL(OUTBUF,ODATA,ISTAT) B7100085^^ 51 IF(AND(ISTAT,$8002).EQ.$8002) GO TO 340 B7100086^^ 52 IF(ISTAT.GE.0) GO TO 220 B7100087^^ 53 CALL FILERR(ODATA,3,ISTAT,LUNIT) B7100088^^ 54 GO TO 990 B7100089^ ^ C CHECK SEE IF FILES ARE INDEX FILES B7100091^^ 55 220 CALL GETFCB(INBUF,ZERO,0,FCBI,ISTAT) B7100092^^ 56 IF(ISTAT.GE.0) GO TO 230 B7100093^^ 57 CALL FILERR(IDATA,7,ISTAT,LUNIT) B7100094^^ 58 GO TO 950 B7100095^^ 59 230 CALL GETFCB(OUTBUF,ZERO,0,FCBO,ISTAT) B7100096^^ 60 IF(ISTAT.GE.0) GO TO 235 B7100097^^ 61 CALL FILERR(ODATA,7,ISTAT,LUNIT) B7100098^^ 62 GO TO 950 B7100099^ ^ C CHECK FCB'S FOR EQUIVLENCE B7100101^^ 63 235 IF(FCBI(1).NE.FCBO(1)) GO TO 400 B7100102^^ 64 IF(FCBI(6).NE.FCBO(6)) GO TO 400 B7100103^^ 65 DO 236 II=15,22 B7100104^^ 66 IF(FCBI(II).NE.FCBO(II)) GO TO 400 B7100105^^ 67 236 CONTINUE B7100106^ ^ 68 RECLEN=FCBI(1)*2 B7100108^t FTN 3.3B (OPT = LPC) LMOVDT PAGE 3 DATE: 08/29/84 TIME: 2139 t ^ C READ THE INPUT FILE B7100110^^ 69 240 CALL CCSBLK(INREC,15000) B7100111^^ 70 CALL GETS(INBUF,INREC,INREC,ISTAT) B7100112^^ 71 IF(AND(ISTAT,$8100).EQ.$8100) GO TO 950 B7100113^^ 72 IF(AND(ISTAT,$100).EQ.$100) GO TO 250 B7100114^^ 73 IF(ISTAT.GE.0) GO TO 260 B7100115^^ 74 CALL FILERR(IDATA,13,ISTAT,LUNIT) B7100116^^ 75 GO TO 950 B7100117^^ 76 250 EOF=1 B7100118^ ^ C WRITE THE RECORD TO THE OUTPUT FILE B7100120^^ 77 260 NREC=INBUF(15) B7100121^^ 78 265 DO 300 I=1,NREC B7100122^^ 79 JW= FCBI(1) * (I-1) + 1 B7100123^^ 80 JB=(FCBI(1) * 2) * (I-1) B7100124^^ 81 IF(INREC(JW).EQ.FDEL) GO TO 300 B7100125^^ C B7100126^^ C CHECK IF ITS SEQUENTIAL B7100127^^ 82 IF(AND(FCBI(6),$0001).NE.$0001) GO TO 285 B7100128^ ^ C SET UP THE KEY B7100130^^ 83 270 CALL CCSBLK(KEY,100) B7100131^^ 84 CALL CCSMVA(INREC,FCBI(16)+JB,FCBI(15),KEY,1,FCBI(15)) B7100132^ ^ C SET UP OUTPUT RECORD B7100134^^ 85 280 CALL CCSMVA(INREC,JB+1,RECLEN,OUTREC,1,RECLEN) B7100135^^ 86 CALL WRITER(OUTBUF,OUTREC,KEY,ISTAT) B7100136^^ 87 IF(ISTAT.GE.0) GO TO 290 B7100137^^ 88 CALL FILERR(ODATA,12,ISTAT,LUNIT) B7100138^^ 89 GO TO 950 B7100139^^ C SEQUENTIAL PUTS B7100140^^ 90 285 CALL CCSMVA(INREC,JB+1,RECLEN,OUTREC,1,RECLEN) B7100141^^ 91 CALL PUTS(OUTBUF,OUTREC,1,ISTAT) B7100142^^ 92 IF(ISTAT.GE.0) GO TO 290 B7100143^^ 93 CALL FILERR(ODATA,11,ISTAT,LUNIT) B7100144^^ 94 GO TO 990 B7100145^ ^ C RECORD COUNT B7100147^^ 95 290 ICNT=ICNT+1 B7100148^^ 96 300 CONTINUE B7100149^ ^ 97 IF(EOF.EQ.1) GO TO 950 B7100151^^ 98 GO TO 240 B7100152^ ^ C ERROR MESSAGES B7100154^^ 99 320 CALL CCSMVA(IDATA,1,8,MSG10,5,8) B7100155^^ 100 CALL WTREAD(LUNIT,-1,MSG10,38,-1,IBUF,0,ITC) B7100156^^ 101 GO TO 950 B7100157^^ 102 340 CALL CCSMVA(ODATA,1,8,MSG10,5,8) B7100158^^ 103 CALL WTREAD(LUNIT,-1,MSG10,38,-1,IBUF,0,ITC) B7100159^^ 104 GO TO 950 B7100160^^ 105 360 CALL CCSMVA(IDATA,1,8,MSG11,5,8) B7100161^^ 106 CALL WTREAD(LUNIT,-1,MSG11,32,-1,IBUF,0,ITC) B7100162^t FTN 3.3B (OPT = LPC) LMOVDT PAGE 4 DATE: 08/29/84 TIME: 2139 t^ 107 GO TO 950 B7100163^^ 108 380 CALL CCSMVA(ODATA,1,8,MSG11,5,8) B7100164^^ 109 CALL WTREAD(LUNIT,-1,MSG11,32,-1,IBUF,0,ITC) B7100165^^ 110 GO TO 950 B7100166^^ 111 400 CALL WTREAD(LUNIT,-1,MSG12,34,-1,IBUF,0,ITC) B7100167^^ 112 GO TO 950 B7100168^ ^ C CLOSE THE FILES B7100170^^ 113 950 CALL CLOSFL(INBUF,ISTAT) B7100171^^ 114 CALL CLOSFL(OUTBUF,ISTAT) B7100172^^ 115 EOF = 0 B7100173^^ 116 GO TO 90 B7100174^^ 117 990 CALL PGMOUT B7100175^^ 118 STOP B7100176^^ 119 END B7100177^t FTN 3.3B (OPT = LPC) LMOVDT PAGE 5 DATE: 08/29/84 TIME: 2139 t  PROGRAM LENGTH $274A ( 10058)   EXTERNALS 2 Q8STP FMRDEL PGMIN CCSCST CCSMVA OPENFL FILERR 22 CLEAR GETFCB CCSBLK GETS WRITER PUTS WTREAD 2 CLOSFL PGMOUT  t FTN 3.3B (OPT = LPC) LMOVDT PAGE 6 DATE: 08/29/84 TIME: 2139 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < ( 8002 (-32765) 2574 42,42,51 ($ 8100 (-32511) 2579 71,71$6 FFFE (-1) 2584 100,100,103,106,109,1116j 0000 (0) 0003 13,14,15,16,32,38,39,43,47,52,55,56,59,60,73,87,92,100,103,106,109,111,115 j€ 0001 (1) 0002 16,28,31,33,34,35,36,37,48,63,68,76,78,79,80,82,84,85,90,91,95,97,99,100,102,103,105,106,108,109,€" 111"* 0002 (2) 256E 31,31,68,80*$ 0003 (3) 2575 44,53$. 0005 (5) 2583 99,102,105,108 .$ 0007 (7) 2576 57,61$6 0008 (8) 2570 34,34,36,99,102,105,1086" 000B (11) 2582 93 "" 000C (12) 2581 88 "" 000D (13) 257B 74 "* 0010 (16) 256D 30,33,35,84*$ 0011 (17) 2571 34,36$& 0020 (32) 2587 106,109&" 0022 (34) 2588 111"& 0026 (38) 2585 100,103&" 0064 (100) 2580 83 "$ 0100 (256) 257A 72,72$" 3A98 (15000) 2578 69 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < . AND INTR.FN. 7FFF 42,51,71,72,82 .& ASTRSK INTEGER 255B 1,12,31&* BLANK INTEGER 255C 1,12,34,36 *. EOF INTEGER 0004 1,13,76,97,115 .< FCBI INTEGER 0005 1,55,63,64,66,68,79,80,82,84 <, FCBO INTEGER 0065 1,59,63,64,66,& FDEL INTEGER 00C5 1,27,81&( I INTEGER 257D 77,79,80 (4 IBUF INTEGER 00CA 1,100,103,106,109,1114$ ICMP INTEGER 256F 31,32$$ ICNT INTEGER 2568 13,95$< IDATA INTEGER 00CF 1,15,33,34,41,44,57,74,99,105<$ IDUSER INTEGER 00C6 1,26 $$ II INTEGER 2577 64,66$* INAMES INTEGER 24EB 1,10,31,33 *6 INBUF INTEGER 00DE 1,14,38,41,55,70,77,11362 INREC INTEGER 00F6 1,69,70,81,84,85,902t FTN 3.3B (OPT = LPC) LMOVDT PAGE 7 DATE: 08/29/84 TIME: 2139 tz ISTAT INTEGER 2573 41,42,43,44,46,47,48,50,51,52,53,55,56,57,59,60,61,70,71,72,73,74,86,87,88,91,92,93,113,114z2 ITC INTEGER 2586 100,103,106,109,1112. JB INTEGER 257F 79,80,84,85,90 .( JW INTEGER 257E 78,79,81 (0 K INTEGER 256C 27,28,30,31,33,350* KEY INTEGER 1E44 1,83,84,86 *N LUNIT INTEGER 2569 26,44,48,53,57,61,74,88,93,100,103,106,109,111 N( M INTEGER 2572 36,38,39 (" MODE INTEGER 256A 26 "$ MSG1 INTEGER 1E76 1,17 $2 MSG10 INTEGER 1EB0 1,22,99,100,102,10324 MSG11 INTEGER 1EC3 1,23,105,106,108,109 4( MSG12 INTEGER 1ED3 1,24,111 ($ MSG2 INTEGER 1E87 1,18 $$ MSG3 INTEGER 1E95 1,19 $$ MSG4 INTEGER 1E9D 1,20 $$ MSG5 INTEGER 1EA9 1,21 $" NOPORT INTEGER 256B 26 "( NREC INTEGER 257C 77,77,78 (F ODATA INTEGER 1EE4 1,16,35,36,46,48,50,53,61,88,93,102,108F& ONAMES INTEGER 2523 1,11,35&: OUTBUF INTEGER 1EF3 1,14,39,46,50,59,86,91,114 :, OUTREC INTEGER 1F0B 1,85,86,90,91,* RECLEN INTEGER 24E9 1,68,85,90 ** ZERO INTEGER 24EA 1,13,55,59 *   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < $ CCSBLK SUBROUTINE 2653 68,83$" CCSCST SUBROUTINE 259A 31 "B CCSMVA SUBROUTINE 2720 32,34,35,36,84,85,90,99,102,105,108B" CLEAR SUBROUTINE 25E8 46 "& CLOSFL SUBROUTINE 273C 113,114&6 FILERR SUBROUTINE 266C 43,48,53,57,61,74,88,936$ GETFCB SUBROUTINE 260D 55,59$" GETS SUBROUTINE 2657 69 "$ OPENFL SUBROUTINE 25D2 40,50$" PGMIN SUBROUTINE 258A 25 "" PGMOUT SUBROUTINE 2747 117"" PUTS SUBROUTINE 26D2 90 " Q8STP INTEGER.FN. 2749 " WRITER SUBROUTINE 26B6 85 "2 WTREAD SUBROUTINE 26F3 99,103,106,109,111 2t FTN 3.3B (OPT = LPC) LMOVDT PAGE 8 DATE: 08/29/84 TIME: 2139 t   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < & 90 2596 28,116 &$ 100 2599 28,31$" 110 25A7 32 "$ 120 25CC 36,40$" 200 25D1 40 "$ 205 25E7 43,46$$ 210 25F6 47,50$$ 220 260C 52,55$$ 230 261D 56,59$$ 235 262D 60,63$$ 236 2649 64,67$$ 240 2652 68,98$$ 250 2673 72,76$$ 260 2675 73,77$" 265 2679 77 "" 270 269C 82 "" 280 26AB 84 "$ 285 26C7 82,90$( 290 26E0 87,92,95 (( 300 26E2 77,81,96 ($ 320 26EB 42,99$& 340 26FD 51,102 &" 360 270E 104"" 380 271F 107", 400 2731 63,64,66,111 ,H 950 273B 57,62,71,75,89,97,101,104,107,110,112,113H2 990 2746 32,45,49,54,94,117 2 LMOVDT 0000 1 t FTN 3.3B (OPT = LPC) LODDAT PAGE 1 DATE: 08/29/84 TIME: 2140 t^ 1 PROGRAM LODDAT B7200001^^ 1 1 /B72 F CCS CCS 3.0 SL-149B7200002^^ C LOAD DATA FILES FROM TAPE SYSTEM BUILD UTILITY B7200003^^ C CYBERCREDIT SYSTEM VERSION 3 B7200004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B7200005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B7200006^^ C B7200007^ ^ C LODDAT IS A SYSTEM BUILD UTILITY ONLY. IT IS DELETED AS PART OF B7200009^^ C SYSTEM INSTALLATION TO PREVENT ERRONEOUS USE. IT IS CALLED FROM B7200010^^ C THE SYSTEM FILE LOAD TAPE AND ITS FUNCTION IS TO LOAD FILES IDENT-B7200011^^ C IFIED ON THE TAPE. THE FORMAT OF EACH FILE ON THE TAPE IS: B7200012^^ C 1 HEADER RECORD - CONTAINS THE FILE NAME/OWNER IN THE FIRST 16 B7200013^^ C CHARACTERS OF ONE 80 CHARACTER RECORD. B7200014^^ C DEFAULT ID IS LOGON ID WHICH SHOULD BE "$$". B7200015^^ C N DATA RECORDS - THE FOLLOWING N RECORDS UP TO A FILE MARK ARE B7200016^^ C THE DATA RECORDS TO BE LOADED INTO THE FILE. B7200017^^ C LODDAT WILL EXAMINE FILE TYPE TO DETERMINE CORRECT WRITE REQUEST. B7200018^^ C THE MAXIMUM FILE SIZE ACCOMODATED (DUE TO INTERNAL BUFFER SIZE) B7200019^^ C IS 3000 BYTES. FILES GREATER THAN 2000 BYTES, HOWEVER, ARE READ B7200020^^ C IN TWO EQUAL PARTS (DUE TO MASTER CONSOLE I/O BUFFER LIMITATION B7200021^^ C OF 2000 BYTES). FOR EXAMPLE, A FILE WITH RECORDS 2400 BYTES LONG B7200022^^ C WILL HAVE TWO RECORDS ON TAPE FOR EACH FILE RECORD, AND THE TAPE B7200023^^ C RECORDS WILL EACH BE 1200 BYTES LONG (NOTE THIS WILL NOT HANDLE B7200024^^ C ODD NUMBER RECORD LENGTHS ABOVE 2000 BYTES). A FILE MARK FOLLOW- B7200025^^ C ING ANY FILE (TWO FILE MARKS TOGETHER) WILL TERMINATE THIS PRO- B7200026^^ C GRAM. RECORDS FOR INDEXED FILE MUST HAVE THE PRIMARY KEY OCCUPY B7200027^^ C THE FIRST BYTES OF THE RECORD (I.E., LEFT JUSTIFIED IN THE B7200028^^ C RECORD). B7200029^^ C B7200030^ ^ C**** FILE MANAGER BUFFERS. B7200032^^ 2 INTEGER REQBUF(24), RECBUF(1502), IDATA(15), FCBBUF(96) B7200033^^ 3 EQUIVALENCE ( RECBUF(1), FCBBUF(1) ) B7200034^^ 4 DATA IDATA / 12*$2020, 0, 1, 0/ B7200035^ ^ C**** TAPE INPUT BUFFERS. B7200037^^ 5 INTEGER TAPBUF(1001), FLAG, TEMP(8) B7200038^^ 6 EQUIVALENCE ( RECBUF(1), TAPBUF(1) ) B7200039^^ 7 DATA FLAG / 0 / B7200040^ ^ C**** TAPE STATUS FUNCTION. B7200042^^ 8 INTEGER STATIT B7200043^t FTN 3.3B (OPT = LPC) LODDAT PAGE 2 DATE: 08/29/84 TIME: 2140 t^ C**** READ NEXT RECORD FROM TAPE TO DETERMINE FILE NAME TO LOAD. B7200045^^ 9 100 ASSIGN 110 TO ICOMPL B7200046^^ 10 CALL FREAD ( 6, TAPBUF, 80, ICOMPL, FLAG, TEMP ) B7200047^^ 11 CALL DISP B7200048^ ^ C**** IF END-OF-FILE, TERMINATE PROGRAM B7200050^^ 12 110 IF ( AND(STATIT(6),$800) .NE. 0 ) GO TO 900 B7200051^^ C** ELSE, CONTINUE. B7200052^ ^ C**** OPEN SPECIFIED FILE B7200054^^ 13 120 CALL CCSMVA ( TAPBUF, 1,16, IDATA, 1,16 ) B7200055^^ 14 DO 125 I=1,24 B7200056^^ 15 125 REQBUF(I) = 0 B7200057^^ 16 CALL OPENFL ( REQBUF, IDATA, ISTAT ) B7200058^^ C** IF NO FILE ERROR, CONTINUE B7200059^^ 17 IF ( ISTAT .GE. 0 ) GO TO 130 B7200060^^ C** ELSE, REPORT ERROR B7200061^^ 18 CALL FILERR ( IDATA, 3, ISTAT, 5 ) B7200062^^ C** ADVANCE TAPE ONE FILE B7200063^^ 19 CALL TAPMOT ( 6, 5 ) B7200064^^ C** GO PROCESS NEXT FILE. B7200065^^ 20 GO TO 800 B7200066^ ^ C**** GET FCB OF FILE TO DETERMINE FILE TYPE AND RECORD LENGTH B7200068^^ 21 130 CALL GETFCB ( REQBUF, 0, 0, FCBBUF, ISTAT ) B7200069^^ C** IF NO FILE ERROR, CONTINUE B7200070^^ 22 IF ( ISTAT .GE. 0 ) GO TO 140 B7200071^^ C** ELSE, REPORT FILE ERROR AND EXIT. B7200072^^ 23 CALL FILERR ( IDATA, 7, ISTAT, 5 ) B7200073^^ 24 GO TO 900 B7200074^ ^ C**** SAVE FILE TYPE AND RECORD LENGTH. B7200076^^ 25 140 ITYPE = AND(1,FCBBUF(6)) B7200077^^ 26 IRLEN = FCBBUF(1) B7200078^^ 27 IRLENB = 2*IRLEN B7200079^^ 28 I2NDRC = IRLEN/2 +1 B7200080^ ^ C**** IF RECORD LENGTH OVER 1000 WORDS (2000 BYTES), CONTINUE B7200082^^ 29 150 IF ( IRLEN .GE. 1001 ) GO TO 160 B7200083^^ C** ELSE, READ NEXT RECORD FROM TAPE B7200084^^ 30 ASSIGN 200 TO ICOMPL B7200085^^ 31 CALL FREAD ( 6, TAPBUF, IRLENB, ICOMPL, FLAG, TEMP ) B7200086^^ 32 CALL DISP B7200087^ ^ C**** READ THE TWO PIECES OF THE RECORD FROM TAPE B7200089^^ 33 160 ASSIGN 170 TO ICOMPL B7200090^^ 34 CALL FREAD ( 6, TAPBUF, IRLEN, ICOMPL, FLAG, TEMP ) B7200091^^ 35 CALL DISP B7200092^^ C** IF END-OF-FILE ON FIRST PIECE, CONTINUE TO BYPASS READING SECOND B7200093^^ C** PIECE B7200094^^ 36 170 IF ( AND(STATIT(6),$800) .NE. 0 ) GO TO 200 B7200095^^ C** ELSE, READ SECOND PIECE B7200096^^ 37 ASSIGN 200 TO ICOMPL B7200097^^ 38 CALL FREAD ( 6, TAPBUF(I2NDRC), IRLEN, ICOMPL, FLAG, TEMP )B7200098^t FTN 3.3B (OPT = LPC) LODDAT PAGE 3 DATE: 08/29/84 TIME: 2140 t^ 39 CALL DISP B7200099^ ^ C**** IF NOT END-OF-FILE ON TAPE READ, CONTINUE B7200101^^ 40 200 IF ( AND(STATIT(6),$800) .EQ. 0 ) GO TO 210 B7200102^^ C** ELSE, CLOSE FILE B7200103^^ 41 CALL CLOSFL ( REQBUF, ISTAT ) B7200104^^ C** GO PROCESS NEXT FILE. B7200105^^ 42 GO TO 800 B7200106^ ^ C**** IF FILE TYPE IS INDEXED, CONTINUE B7200108^^ 43 210 IF ( ITYPE .NE. 0 ) GO TO 220 B7200109^^ C** ELSE, ADD RECORD TO SEQUENTIAL FILE B7200110^^ 44 CALL PUTS ( REQBUF, RECBUF, 1, ISTAT ) B7200111^^ C** IF NO FILE ERROR, CONTINUE WITH NEXT RECORD B7200112^^ 45 IF ( ISTAT .GE. 0 ) GO TO 700 B7200113^^ C** ELSE, REPORT FILE ERROR, CLOSE FILE, AND EXIT. B7200114^^ 46 CALL FILERR ( IDATA, 11, ISTAT, 5 ) B7200115^^ 47 CALL CLOSFL ( REQBUF, ISTAT ) B7200116^^ 48 GO TO 900 B7200117^ ^ C**** ADD RECORD TO INDEXED FILE B7200119^^ 49 220 CALL WRITER ( REQBUF, RECBUF, RECBUF, ISTAT ) B7200120^^ C** IF NO FILE ERROR, CONTINUE WITH NEXT RECORD B7200121^^ 50 IF ( ISTAT .GE. 0 ) GO TO 700 B7200122^^ C** ELSE, REPORT FILE ERROR, CLOSE FILE, AND EXIT. B7200123^^ 51 CALL FILERR ( IDATA, 12, ISTAT, 5 ) B7200124^^ 52 CALL CLOSFL ( REQBUF, ISTAT ) B7200125^^ 53 GO TO 900 B7200126^ ^ C**** CONTINUATION TO PROCESS NEXT RECORD. B7200128^^ 54 700 GO TO 150 B7200129^ ^ C**** CONTINUATION TO PROCESS NEXT FILE. B7200131^^ 55 800 GO TO 100 B7200132^  ^ C**** TERMINATION. B7200134^^ 56 900 CALL PGMOUT B7200135^  ^ 57 END B7200137^t FTN 3.3B (OPT = LPC) LODDAT PAGE 4 DATE: 08/29/84 TIME: 2140 t  PROGRAM LENGTH $06F2 ( 1778)   EXTERNALS 2 Q8STP STATIT FREAD DISP CCSMVA OPENFL FILERR 2, TAPMOT GETFCB CLOSFL PUTS WRITER PGMOUT , t FTN 3.3B (OPT = LPC) LODDAT PAGE 5 DATE: 08/29/84 TIME: 2140 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < @ 0000 (0) 0003 4,7,12,15,17,21,22,36,40,43,45,50@6 0001 (1) 0002 3,4,6,13,14,25,26,28,446" 0003 (3) 0619 18 ". 0005 (5) 061A 18,19,23,46,51 .8 0006 (6) 0613 7,12,19,25,31,34,36,38,408" 0007 (7) 061B 23 "" 000B (11) 0621 46 "" 000C (12) 0622 51 "$ 0010 (16) 0616 13,13$" 0050 (80) 0614 10 "" 03E9 (1001) 0620 29 "( 0800 (2048) 0615 12,36,40 (   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < * AND INTR.FN. 7FFF 12,25,36,40*, FCBBUF INTEGER 001C 1,3,21,25,26 ,. FLAG INTEGER 0609 4,7,10,31,34,38.$ I INTEGER 0617 13,15$( I2NDRC INTEGER 061F 27,28,38 (6 ICOMPL INTEGER 0612 7,10,30,31,33,34,37,38 64 IDATA INTEGER 05FA 1,4,13,16,18,23,46,5144 IRLEN INTEGER 061D 25,26,27,28,29,34,38 4( IRLENB INTEGER 061E 26,27,31 (L ISTAT INTEGER 0618 16,17,18,21,22,23,41,44,45,46,47,49,50,51,52 L( ITYPE INTEGER 061C 25,25,43 (* RECBUF INTEGER 001C 1,3,6,44,49*8 REQBUF INTEGER 0004 1,15,16,21,41,44,47,49,5282 TAPBUF INTEGER 001C 4,6,10,13,31,34,38 2, TEMP INTEGER 060A 4,10,31,34,38,   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " CCSMVA SUBROUTINE 063A 12 "( CLOSFL SUBROUTINE 06BB 40,47,52 (* DISP SUBROUTINE 06B2 10,32,35,39** FILERR SUBROUTINE 06D0 17,23,46,51** FREAD SUBROUTINE 06AA 7,31,34,38 *t FTN 3.3B (OPT = LPC) LODDAT PAGE 6 DATE: 08/29/84 TIME: 2140 t" GETFCB SUBROUTINE 0662 21 "" OPENFL SUBROUTINE 064D 15 "" PGMOUT SUBROUTINE 06EF 56 "" PUTS SUBROUTINE 06C5 43 " Q8STP INTEGER.FN. 06F1 * STATIT INTEGER.FN. 06B4 7,12,36,40 *" TAPMOT SUBROUTINE 065B 18 "" WRITER SUBROUTINE 06DA 49 "   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 100 0623 7,55 $$ 110 0630 7,12 $" 120 0639 12 "$ 125 0643 13,15$$ 130 0661 17,21$$ 140 0671 22,25$$ 150 067F 28,54$$ 160 068D 29,33$$ 170 0699 33,36$* 200 06B3 29,36,37,40*$ 210 06BF 40,43$$ 220 06D9 43,49$( 700 06EB 45,50,54 (( 800 06EC 19,42,55 (. 900 06EE 12,24,48,53,56 . LODDAT 0000 1 t FTN 3.3B (OPT = LPC) LODFIL PAGE 1 DATE: 08/29/84 TIME: 2140 t^ 1 PROGRAM LODFIL B7300001^^ 1 1 /B73 F CCS CCS 3.0 REPORT DUP RECORD SL-149********^^ C B7300003^^ C CYBERCREDIT SYSTEM VERSION 3 B7300004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B7300005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B7300006^^ C B7300007^^ C THIS PROGRAM TAKES A FILE CREATED BY THE DMPFIL PROGRAM AND LOADS B7300008^^ C IT INTO A SPECIFIED DISK FILE. THE MAXIMUM RECORD LENGTH IS B7300009^^ C 3000 CHARACTERS. THE DISK FILE CAN BE SEQUENTIAL OR INDEX FILE. B7300010^^ C IF THE DUMP WAS A MULTI-TAPE DUMP, THE OPERATOR IS PROMPTED TO B7300011^^ C MOUNT THE NEXT TAPE. THE PROGRAM LOOKS FOR TWO EOF'S ON THE TAPE B7300012^^ C FOR PROGRAM TERMINATION. IF LOADING A FILE NOT CREATED BY DMPFIL B7300013^^ C A SECOND EOF IS NEEDED TO LOAD THE FILE. B7300014^  ^ 2 INTEGER BLANK,BYTLEN,COMP,FCB(96),FLAG,ICNT(6) B7300016^^ 3 INTEGER IBUF(10),IDUSER(4),ODATA(15),OREQ(24),OREC(2002) B7300017^^ 4 INTEGER MSG1(11),MSG2(11),MSG3(9),MSG4(40),MSG5(15) B7300018^^ 5 INTEGER MSG6(19), MSG7(19), MSG8(27), MSG9(26) ***00019^^ 6 INTEGER ONE(5),RECLEN,STATIT B7300020^^ 7 INTEGER TAPE,TEMP(8),TPSTAT,Y,ZERO B7300021^ ^ 8 DATA BLANK/$2020/,FLAG/0/,ICNT/6*$3030/ B7300023^^ 9 DATA ODATA/12*$2020,0,1,-1/,ONE/4*$3030,$3031/ B7300024^^ 10 DATA OREQ/24*0/,TAPE/$1006/,TEMP/8*0/ B7300025^^ 11 DATA Y/'Y '/,ZERO/0/ B7300026^ ^ 12 DATA MSG1/$1800,$0A0D,'TAPE TO DISK FILE '/ B7300028^^ 13 DATA MSG2/$0A0D,$0A0D,'OUTPUT FILE NAME '/ B7300029^^ 14 DATA MSG3/$0A0D,$0A0D,'VOLUME NAME '/ B7300030^^ 15 DATA MSG4/$0A0D,$0A0D,'*****OPERATOR-MOUNT TAPE FOR XXXXXXXX ON', B7300031^^ 15 1' UNIT 0 WITHOUT RING',$0A0D,$0A0D,'READY (Y/N) '/ B7300032^^ 16 DATA MSG5/$0A0D,$0A0D,'FILE COULD NOT BE LOCATED '/ B7300033^^ 17 DATA MSG6/$0A0D,$0A0D,'FILE SIZE EXCEEDS 3000 CHARACTERS '/ B7300034^^ 18 DATA MSG7/$0A0D,$0A0D,'THIS IS A SUPERVISOR COMMAND ONLY '/ B7300035^^ 19 DATA MSG8/$0A0D,$0A0D, ***00036^^ 19 1 'LOAD COMPLETE. MOUNT NEXT REEL IF MULTI-REEL LOAD.'/ ***00037^^ 20 DATA MSG9/$0A0D,$0A0D,' RECORDS ADDED TO THE XXXX', B7300038^^ 20 1'XXXX FILE '/ B7300039^^ 21 INTEGER MSGA(15) ********^^ 22 DATA MSGA/$0D0C,'DUPLICATE RECORD CONTENTS ',$0D0A/ ********^ t FTN 3.3B (OPT = LPC) LODFIL PAGE 2 DATE: 08/29/84 TIME: 2140 t^ 23 100 CALL PGMIN(IDUSER,LUNIT,MODE,NOPORT) B7300042^^ 24 IF(NOPORT.NE.0) GO TO 940 B7300043^ ^ C DISPLAY HEADING B7300045^^ 25 CALL WTREAD(LUNIT,-1,MSG1,22,-1,IBUF,0,ITC) B7300046^ ^ C GET OUTPUT FILE NAME B7300048^^ 26 110 CALL CCSBLK(IBUF,8) B7300049^^ 27 CALL WTREAD(LUNIT,-1,MSG2,22,-1,IBUF,8,ITC) B7300050^^ 28 IF(IBUF(1).EQ.BLANK) GO TO 110 B7300051^^ 29 CALL CCSMVA(IBUF,1,8,ODATA,1,8) B7300052^ ^ C GET VOLUME NAME B7300054^^ 30 120 CALL CCSBLK(IBUF,8) B7300055^^ 31 CALL WTREAD(LUNIT,-1,MSG3,18,-1,IBUF,8,ITC) B7300056^^ 32 CALL CCSMVA(IBUF,1,8,ODATA,17,8) B7300057^ ^ C OPEN THE FILE B7300059^^ 33 130 CALL OPENFL(OREQ,ODATA,ISTAT) B7300060^^ 34 IF(ISTAT.GE.0) GO TO 140 B7300061^ ^ C CHECK FOR NOT PRESENT B7300063^^ 35 IF(AND(ISTAT,$8002).EQ.$8002) GO TO 900 B7300064^^ 36 CALL FILERR(ODATA,3,ISTAT,LUNIT) B7300065^^ 37 GO TO 990 B7300066^ ^ C COMPATE OWNER AND USERID B7300068^^ 38 140 CALL CCSCST(IDUSER,1,8,ODATA,9,8,ICOMP) B7300069^^ 39 IF(ICOMP.EQ.0) GO TO 150 B7300070^^ 40 GO TO 900 B7300071^ ^ C GET FCB FOR RECORD LENGHT B7300073^^ 41 150 CALL GETFCB(OREQ,ZERO,ZERO,FCB,ISTAT) B7300074^^ 42 IF(ISTAT.GE.0) GO TO 160 B7300075^^ 43 CALL FILERR(ODATA,7,ISTAT,LUNIT) B7300076^^ 44 GO TO 980 B7300077^ ^ C CHECK RECORD LENGTH B7300079^^ 45 160 RECLEN=FCB(1) B7300080^^ 46 BYTLEN=RECLEN*2 B7300081^^ 47 IF(RECLEN.GT.1500) GO TO 920 B7300082^ ^ C PROMPT OPERATOR TO MOUNT TAPE B7300084^^ 48 CALL CCSMVA(ODATA,1,8,MSG4,34,8) B7300085^^ 49 165 IBUF(1)=BLANK B7300086^^ 50 CALL WTREAD (LUNIT,-1,MSG4,80,-1,IBUF,1,ITC) B7300087^^ 51 IF(IBUF(1).NE.Y) GO TO 165 B7300088^t FTN 3.3B (OPT = LPC) LODFIL PAGE 3 DATE: 08/29/84 TIME: 2140 t^ C READ THE OUTPUT FILE B7300090^^ 52 170 CALL CCSBLK(OREC,3000) B7300091^^ 53 ASSIGN 180 TO COMP B7300092^^ 54 CALL FREAD(TAPE,OREC,RECLEN,COMP,FLAG,TEMP) B7300093^^ 55 CALL DISP B7300094^ ^ C CHECK TAPE STATUS B7300096^^ 56 180 TPSTAT=STATIT(TAPE) B7300097^ ^ C CHECK FOR EOF B7300099^^ 57 190 IF(AND(TPSTAT,$0800).EQ.$0800) GO TO 220 B7300100^ ^ C WRITE THE RECORDS TO THE FILE B7300102^^ 58 200 IF(AND(FCB(6),$0001).NE.$0001) GO TO 205 B7300103^^ 59 CALL WRITER(OREQ,OREC,OREC,ISTAT) B7300104^^ 60 IF(ISTAT.GE.0) GO TO 210 B7300105^^ 61 CALL FILERR(ODATA,12,ISTAT,LUNIT) B7300106^^ 62 IF(AND(ISTAT,$8010).EQ.$8010) GO TO 202 ********^^ 63 GO TO 980 B7300107^^ 64 202 CONTINUE ********^^ 65 IWLEN=(BYTLEN+1)/2 ********^^ 66 IF(IWLEN.GT.65 ) IWLEN=65 ********^^ 67 IBLEN = IWLEN*2 ********^^ 68 ISAV = OREC(IWLEN) ********^^ 68 ISAV = OREC(IWLEN) ********^^ 69 OREC(IWLEN) = MSG2(1) ********^^ 70 CALL WTREAD(09,-1,MSGA,30,0,0,0,ITC) ********^^ 71 MSGA(1) = MSG2(1) ********^^ 72 CALL WTREAD(09,-1,OREC,IBLEN,0,0,0,ITC) ********^^ 73 OREC(IWLEN) = ISAV ********^^ 74 GO TO 170 ********^ ^ 75 205 CALL PUTS(OREQ,OREC,1,ISTAT) B7300109^^ 76 IF(ISTAT.GE.0) GO TO 210 B7300110^^ 77 CALL FILERR(ODATA,11,ISTAT,LUNIT) B7300111^^ 78 GO TO 980 B7300112^ ^ C GET NEXT RECORDS B7300114^^ 79 210 CALL CCSADD(ONE,2,ICNT,1,ICNT,1) B7300115^^ 80 GO TO 170 B7300116^t FTN 3.3B (OPT = LPC) LODFIL PAGE 4 DATE: 08/29/84 TIME: 2140 t^ C END OF LOAD FOR CURRENT TAPE REEL. ***00118^^ 81 220 CALL WTREAD (LUNIT,-1,MSG8,54,-1,IBUF,0,ITC) ***00119^^ 82 GO TO 980 ***00120^t FTN 3.3B (OPT = LPC) LODFIL PAGE 5 DATE: 08/29/84 TIME: 2140 t ^ C FILE WAS NOT LOCATED B7300123^^ 83 900 CALL WTREAD(LUNIT,-1,MSG5,30,-1,IBUF,0,ITC) B7300124^^ 84 GO TO 990 B7300125^ ^ C FILE TOO LARGE B7300127^^ 85 920 CALL WTREAD(LUNIT,-1,MSG6,38,-1,IBUF,0,ITC) B7300128^^ 86 GO TO 980 B7300129^ ^ C NOT MASTER TERMINAL B7300131^^ 87 940 CALL WTREAD(LUNIT,-1,MSG7,38,-1,IBUF,0,ITC) B7300132^^ 88 GO TO 980 B7300133^ ^ C CLOSE THE OUTPUT FILE B7300135^^ 89 980 CALL CCSMVA(ICNT,1,12,MSG9,5,12) B7300136^^ 90 CALL CCSMVA(ODATA,1,8,MSG9,39,8) B7300137^^ 91 CALL WTREAD(LUNIT,-1,MSG9,52,-1,IBUF,0,ITC) B7300138^^ 92 CALL CLOSFL(OREQ,ISTAT) B7300139^^ 93 990 CALL PGMOUT B7300140^^ 94 STOP B7300141^^ 95 END B7300142^t FTN 3.3B (OPT = LPC) LODFIL PAGE 6 DATE: 08/29/84 TIME: 2140 t  PROGRAM LENGTH $0AD3 ( 2771)   EXTERNALS 2 Q8STP STATIT PGMIN WTREAD CCSBLK CCSMVA OPENFL 22 FILERR CCSCST GETFCB FREAD DISP WRITER PUTS 2 CCSADD CLOSFL PGMOUT  t FTN 3.3B (OPT = LPC) LODFIL PAGE 7 DATE: 08/29/84 TIME: 2140 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < $ 8002 (-32765) 0951 35,35$$ 8010 (-32751) 095D 62,62$B FFFE (-1) 094A 25,25,27,31,50,70,72,81,83,85,87,91BR 0000 (0) 0003 8,9,10,11,24,25,34,39,42,60,70,72,76,81,83,85,87,91Rr 0001 (1) 0002 9,25,27,28,29,31,32,38,45,48,49,50,51,58,65,69,70,71,72,75,79,81,83,85,87,89,90,91 r* 0002 (2) 0956 46,65,67,79*" 0003 (3) 0952 36 "" 0005 (5) 0965 89 "" 0007 (7) 0955 43 ": 0008 (8) 094D 26,27,29,30,31,32,38,48,90 :( 0009 (9) 0953 38,70,72 (" 000B (11) 0962 77 "$ 000C (12) 095C 61,89$" 0011 (17) 094F 32 "" 0012 (18) 094E 31 "$ 0016 (22) 094B 25,27$$ 001E (30) 0961 70,83$" 0022 (34) 0958 48 "$ 0026 (38) 0964 85,87$" 0027 (39) 0966 90 "" 0034 (52) 0967 91 "" 0036 (54) 0963 81 "" 0050 (80) 0959 50 "" 05DC (1500) 0957 47 "$ 0800 (2048) 095B 57,57$" 0BB8 (3000) 095A 52 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < * AND INTR.FN. 7FFF 35,57,58,62*( BLANK INTEGER 0004 1,8,28,49(& BYTLEN INTEGER 0005 1,46,65&& COMP INTEGER 0006 1,53,54&* FCB INTEGER 0007 1,41,45,58 *& FLAG INTEGER 0067 1,8,54 &( IBLEN INTEGER 095F 66,67,72 (P IBUF INTEGER 006E 1,25,26,27,28,29,30,31,32,49,50,51,81,83,85,87,91P( ICNT INTEGER 0068 1,8,79,89($ ICOMP INTEGER 0954 38,39$& IDUSER INTEGER 0078 1,23,38&( ISAV INTEGER 0960 67,68,73 (L ISTAT INTEGER 0950 33,34,35,36,41,42,43,59,60,61,62,75,76,77,92 Lt FTN 3.3B (OPT = LPC) LODFIL PAGE 8 DATE: 08/29/84 TIME: 2140 t@ ITC INTEGER 094C 25,27,31,50,70,72,81,83,85,87,91 @4 IWLEN INTEGER 095E 64,65,66,67,68,69,73 4H LUNIT INTEGER 0947 23,25,27,31,36,43,50,61,77,81,83,85,87,91H" MODE INTEGER 0948 23 "& MSG1 INTEGER 0875 1,12,25&, MSG2 INTEGER 0880 1,13,27,69,71,& MSG3 INTEGER 088B 1,14,31&* MSG4 INTEGER 0894 1,15,48,50 *& MSG5 INTEGER 08BC 1,16,83&& MSG6 INTEGER 08CB 1,17,85&& MSG7 INTEGER 08DE 1,18,87&& MSG8 INTEGER 08F1 1,19,81&, MSG9 INTEGER 090C 1,20,89,90,91,* MSGA INTEGER 0938 20,22,70,71*$ NOPORT INTEGER 0949 23,24$@ ODATA INTEGER 007C 1,9,29,32,33,36,38,43,48,61,77,90@& ONE INTEGER 0926 1,9,79 &8 OREC INTEGER 00A3 1,52,54,59,68,69,72,73,7582 OREQ INTEGER 008B 1,10,33,41,59,75,922, RECLEN INTEGER 092B 1,45,46,47,54,* TAPE INTEGER 092C 1,10,54,56 *& TEMP INTEGER 092D 1,10,54&& TPSTAT INTEGER 0935 1,56,57&& Y INTEGER 0936 1,11,51&& ZERO INTEGER 0937 1,11,41&   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " CCSADD SUBROUTINE 0A81 79 "( CCSBLK SUBROUTINE 0A09 25,30,52 (" CCSCST SUBROUTINE 09C3 38 ". CCSMVA SUBROUTINE 0AB4 28,32,48,89,90 ." CLOSFL SUBROUTINE 0ACC 91 "" DISP SUBROUTINE 0A19 54 "* FILERR SUBROUTINE 0A37 35,43,61,77*" FREAD SUBROUTINE 0A11 53 "" GETFCB SUBROUTINE 09D1 41 "" OPENFL SUBROUTINE 09AD 32 "" PGMIN SUBROUTINE 0969 22 "" PGMOUT SUBROUTINE 0AD0 93 "" PUTS SUBROUTINE 0A71 75 " Q8STP INTEGER.FN. 0AD2 $ STATIT INTEGER.FN. 0A1B 1,56 $" WRITER SUBROUTINE 0A2D 58 "@ WTREAD SUBROUTINE 0A8B 24,27,31,50,70,72,81,83,85,87,91 @t FTN 3.3B (OPT = LPC) LODFIL PAGE 9 DATE: 08/29/84 TIME: 2140 t   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < " 100 0968 22 "$ 110 097D 25,28$" 120 0999 29 "" 130 09AC 32 "$ 140 09C2 34,38$$ 150 09D0 39,41$$ 160 09E2 42,45$$ 165 09F6 48,51$( 170 0A08 51,74,80 ($ 180 0A1A 52,56$" 190 0A1F 56 "" 200 0A25 57 "$ 202 0A42 62,64$$ 205 0A70 58,75$( 210 0A80 60,76,79 ($ 220 0A8A 57,81$( 900 0A95 35,40,83 ($ 920 0A9F 47,85$$ 940 0AA9 24,87$4 980 0AB3 43,63,78,82,86,88,89 4( 990 0ACF 36,84,93 ( LODFIL 0000 1  t FTN 3.3B (OPT = LPC) LTPRNT PAGE 1 DATE: 08/29/84 TIME: 2141 t^ 1 SUBROUTINE LTPRNT(DT,LTFILB) B7400001^^ 1 1 /B74 F CCS CCS 3.0 PSR'D SL-149********^ ^ C B7400004^^ C CYBERCREDIT SYSTEM VERSION 3 B7400005^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B7400006^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B7400007^^ C B7400008^^ C B7400009^^ C SUBROUTINE TO ECHO PRINT THE LETTER DESCRIPTION FILE AFTER A B7400010^^ C VALID LETTER HAS BEEN WRITTEN TO THE LETTERFILE. ROUTINE READSB7400011^^ C LETTER FILE AND PRINTS THE LAST LETTER STORED. B7400012^  ^ C CALLING SEQUENCE: B7400015^ ^ C CALL LTPRNT(DT,LTFILB) B7400017^ ^ C WHERE: B7400019^ ^ C DT = CONVERTED SYSTEM CURRENT DATE/TIME FUNCTION B7400021^^ C LTFILB = LETTER FILE BUFFER B7400022^  ^ C COUNTERS, VARIABLES AND SMALL CONSTANTS B7400025^ ^ 2 INTEGER A, ALPHA(30), COL B7400027^^ 3 DATA A/$41/, ALPHA/30*$4141/, COL/0/ B7400028^ ^ 4 INTEGER DBLSPA, DOLLAR(6), FARRAY(27) B7400030^^ 5 DATA DBLSPA/$0D0A/,DOLLAR/'$9999999.99 '/ B7400031^ ^ 6 INTEGER FSWICH, IEND(2), IFLAG, LCNT,OBUF(66), LTFILB(756) B7400033^^ 7 DATA FSWICH/0/, IEND/'END'/, IFLAG/0/, LCNT/0/ B7400034^ ^ 8 INTEGER ITEMP(8) B7400036^^ 9 DATA ITEMP/8*0/ B7400037^ ^ 10 INTEGER LEN, POS(2), RECBUF(756), SNGLSP,TOPOPG B7400039^^ 11 DATA LEN/0/, POS/2*0/, SNGLSP/$000A/,TOPOPG/$000C/ B7400040^ ^ 12 INTEGER TYPE, AT, ASTRSK, D, DOL B7400042^^ 13 DATA AT/$0040/,ASTRSK/$002A/,DOL/$0024/,D/$0044/ B7400043^ ^ 14 INTEGER MAXLEN, PRTLEN, NO, MARGIN ***00045^^ 15 DATA MAXLEN/57/, PRTLEN/86/, NO/'N'/, MARGIN/$0005/ ********^ ^ 16 INTEGER FCOUNT, DT(3), PRT, SAVKEY B7400048^^ 17 DATA PRT/9/ B7400049^ ^ 18 INTEGER FEQ, REQBLF(24), STAR, NOF B7400051^^ 19 DATA FEQ/$463D/, STAR/$002A/, NOF/0/ B7400052^ ^ 20 INTEGER CC, PUN, LTRARR(760), ZERO, BLANK B7400054^t FTN 3.3B (OPT = LPC) LTPRNT PAGE 2 DATE: 08/29/84 TIME: 2141 t^ 21 DATA CC/2/, ZERO/$3030/,BLANK/$2020/ B7400055^ ^ C SET UP THE THREE TYPES OF DATE FIELDS ***00058^^ 22 INTEGER DATE1(9),DATE2(6),DATE3(4) ***00059^^ 23 DATA DATE1/'XXXXXXXXX 99, 9999'/ ***00060^^ 24 DATA DATE2/'XXX 99, 9999'/ ***00061^^ 25 DATA DATE3/$3939,$2F39,$392F,$3939/ ***00062^ ^ C MESSAGE BUFFERS B7400064^ ^ 26 INTEGER NAME(7), ADDRES(7) B7400066^^ 27 DATA NAME/'MR. JOHN SMITH'/, ADDRES/'616 ELAINE AVE'/ B7400067^ ^ 28 INTEGER CITYZP(10) B7400069^^ 29 DATA CITYZP/'SAN DIEGO, CA. 92115'/ B7400070^ ^ C SALUTATION B7400072^ ^ 30 INTEGER NAME1(5) B7400074^^ 31 DATA NAME1/'JOHN SMITH'/ B7400075^ ^ 32 INTEGER NAME2(5) B7400077^^ 33 DATA NAME2/'MR. SMITH '/ B7400078^ ^ C SIGNATURE LINE B7400080^ ^ 34 INTEGER CONAME(6), PHONE(7), EXT(4),COLDP(8) B7400082^^ 35 DATA CONAME/'MR. R. JONES'/, PHONE/'(999)999-9999'/ B7400083^^ 36 DATA EXT/'EXT 9999'/, COLDP/'COLLECTION DEPT '/ B7400084^ t FTN 3.3B (OPT = LPC) LTPRNT PAGE 3 DATE: 08/29/84 TIME: 2141 t^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++B7400087^^ C B7400088^^ C INITIALIZE COUNTERS B7400089^^ C B7400090^^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++B7400091^  ^ 37 CALL PGMIN(FARRAY,LU,MODE,NPORT) ********^^ 38 IF(NPORT.NE.0) PRT=5 ********^^ 39 40 FCOUNT=0 B7400094^^ 40 FSWICH=0 B7400095^^ 41 IPOINT=0 B7400096^^ 42 LCOUNT=0 B7400097^^ 43 ICOL=0 B7400098^^ 44 NOF=0 B7400099^ ^ 45 50 CALL CCSBLK(FARRAY,54) B7400101^ ^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++B7400103^^ C MOVE MAXIMUM OF 9 VALID FIELD DESCRIPTIONS TO TABLE FARRAY B7400104^^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++B7400105^ ^ 46 70 IPOINT=IPOINT+3 B7400107^^ 47 IARAPT=1 B7400108^^ 48 72 DO 90 I=1,9 B7400109^^ 49 CALL CCSCST(LTFILB,IPOINT,2,FEQ,1,2,ICOMP) B7400110^^ 50 74 IF(ICOMP .NE. 0) GO TO 90 B7400111^ ^ C WE HAVE A VALID 'F' - SET FSWITCH AND MOVE POINTER B7400113^ ^ 51 FSWICH=1 B7400115^^ 52 IPOINT=IPOINT+2 B7400116^ ^ C CHECK FOR NO 'F' FIELD OPTION B7400118^ ^ 53 75 CALL CCSCST(LTFILB, IPOINT, 1, NO, 1, 1, ICOMP) B7400120^^ 54 IF(ICOMP.NE.0) GO TO 77 B7400121^^ 55 NOF=1 B7400122^^ 56 IPOINT=IPOINT+1 B7400123^^ 57 GO TO 100 B7400124^ ^ C STORE IN ARRAY USING LINE NUMBER AS POINTER TO POSITION IN ARRAB7400126^ ^ 58 77 CALL CCSMVA(LTFILB,IPOINT,6,FARRAY,IARAPT,6) B7400128^ ^ 59 IARAPT=IARAPT+6 B7400130^^ 60 IPOINT=IPOINT+6 B7400131^^ 61 FCOUNT=FCOUNT+1 B7400132^^ 62 78 GO TO 90 B7400133^ ^ 63 90 CONTINUE B7400135^ ^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++B7400137^^ C B7400138^t FTN 3.3B (OPT = LPC) LTPRNT PAGE 4 DATE: 08/29/84 TIME: 2141 t^ C MOVE IN DATE AND ADDRESS BLOCK OF LETTER B7400139^^ C B7400140^^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++B7400141^  ^ 64 100 CALL CCSBLK(OBUF,132) B7400144^^ 65 CALL CCSMVA(DBLSPA, 1, 2, OBUF, 1, 2) B7400145^^ 66 DO 120 I=1,6 B7400146^^ 67 ASSIGN 115 TO ICOMP B7400147^^ 68 CALL FWRITE(PRT, OBUF, PRTLEN, ICOMP, IFLAG, ITEMP) B7400148^^ 69 CALL DISP B7400149^ ^ 70 115 CONTINUE B7400151^ ^ 71 120 CONTINUE B7400153^ ^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++B7400155^^ C MOVE IN CURRENT DATE B7400156^^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++B7400157^ ^ 72 130 CALL CCSBLK(OBUF(3), 129) B7400159^^ 73 CALL CCSMVA(SNGLSP, 1, 2, OBUF, 1, 2) B7400160^^ 74 ICOL=MAXLEN-18 B7400161^^ 75 125 CALL LTRDTE(DT, OBUF, ICOL, 1) B7400162^^ 76 127 ASSIGN 140 TO ICOMP B7400163^^ 77 CALL FWRITE(PRT,OBUF,PRTLEN,ICOMP,IFLAG,ITEMP) B7400164^^ 78 CALL DISP B7400165^ ^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++B7400167^^ C MOVE IN PESUDO NAME B7400168^^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++B7400169^ ^ 79 140 CALL CCSBLK(OBUF(3),129) B7400171^^ 80 CALL CCSMVA(DBLSPA, 1, 2, OBUF, 1, 2) B7400172^^ 81 CALL CCSMVA(NAME,1,14,OBUF,11,14) B7400173^^ 82 145 ASSIGN 150 TO ICOMP B7400174^^ 83 CALL FWRITE(PRT,OBUF,PRTLEN,ICOMP,IFLAG,ITEMP) B7400175^^ 84 CALL DISP B7400176^ ^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++B7400178^^ C MOVE IN PSEUDO ADDRESS B7400179^^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++B7400180^ ^ 85 150 CALL CCSBLK(OBUF(3),129) B7400182^^ 86 CALL CCSMVA(SNGLSP, 1, 2, OBUF, 1, 2) B7400183^^ 87 CALL CCSMVA(ADDRES,1,14,OBUF,11,14) B7400184^^ 88 155 ASSIGN 160 TO ICOMP B7400185^^ 89 CALL FWRITE(PRT,OBUF,PRTLEN,ICOMP,IFLAG,ITEMP) B7400186^^ 90 CALL DISP B7400187^ ^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++B7400189^^ C MOVE IN PSEUDO CITY,ZIP B7400190^^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++B7400191^ t FTN 3.3B (OPT = LPC) LTPRNT PAGE 5 DATE: 08/29/84 TIME: 2141 t^ 91 160 CALL CCSBLK(OBUF(3),129) B7400193^^ 92 CALL CCSMVA(SNGLSP, 1, 2, OBUF, 1, 2) B7400194^^ 93 CALL CCSMVA(CITYZP,1,20,OBUF,11,20) B7400195^^ 94 165 ASSIGN 400 TO ICOMP B7400196^^ 95 CALL FWRITE(PRT, OBUF, PRTLEN, ICOMP, IFLAG, ITEMP) B7400197^^ 96 CALL CCSMVA(DBLSPA,1,2,OBUF,1,2) B7400198^^ 97 CALL DISP B7400199^ t FTN 3.3B (OPT = LPC) LTPRNT PAGE 6 DATE: 08/29/84 TIME: 2141 t^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ B7400202^^ C B7400203^^ C BUILD BODY OF THE LETTER B7400204^^ C B7400205^^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ B7400206^ ^ 98 400 CALL CCSBLK(LTRARR,1520) B7400208^^ 99 IAT=0 B7400209^^ 100 CC=2 B7400210^^ 101 405 DO 650 I=1,24 B7400211^^ 102 IPOS=IPOINT B7400212^^ 103 LB=(I-1)*60+1 B7400213^^ 104 LW=(I-1)*30+1 B7400214^^ 105 LINCT=I B7400215^ ^ C CHECK FOR END B7400217^^ 106 430 CALL CCSCST(LTFILB,IPOINT,3,IEND,1,3,NCOMP) B7400218^^ 107 IF(NCOMP.EQ.0) GO TO 660 B7400219^ ^ C IF FIRST LINE, GO CHECK FOR @ B7400221^^ 108 440 IF(LINCT.EQ.1) GO TO 500 B7400222^ ^ C LOOK FOR CARRIAGE CONTROL AND LENGTH B7400224^^ 109 450 DO 470 J=1,MAXLEN B7400225^ ^ C MOVE IN CARRIAGE CONTROL FOR LAST LINE B7400227^^ 110 LTRARR(LW)=CC B7400228^ ^ C GET BYTE AND CHECK FOR * B7400230^^ 111 460 CALL CCSGET(LTFILB,IPOINT,N) B7400231^^ 112 465 IF(N.EQ.ASTRSK) GO TO 480 B7400232^^ 113 IPOINT=IPOINT+1 B7400233^ ^ C END OF ASTERSK SEARCH LOOP B7400235^^ 114 470 CONTINUE B7400236^ ^ C BYTE WAS * GET CARRIAGE CONTROL B7400238^^ 115 480 LENGTH=IPOINT-IPOS B7400239^^ 116 IPOINT=IPOINT+2 B7400240^^ 117 CALL CCSGET(LTFILB,IPOINT,N) B7400241^^ 118 CC=N-$30 B7400242^ ^ C MOVE IN THE TEXT AND GET NEXT LINE B7400244^^ 119 490 CALL CCSMVA(LTFILB,IPOS,LENGTH,LTRARR,LB+2,LENGTH) B7400245^^ 120 GO TO 640 B7400246^t FTN 3.3B (OPT = LPC) LTPRNT PAGE 7 DATE: 08/29/84 TIME: 2141 t ^ C FIRST LINE ONLY B7400249^^ C CHECK FOR @ B7400250^^ 121 500 DO 630 J=1,MAXLEN B7400251^ ^ C MOVE IN CARRIAGE CONTROL FROM LAST LINE B7400253^^ 122 LTRARR(LW)=CC B7400254^ ^ C GET BYTE AND CHECK FOR @ B7400256^^ 123 510 CALL CCSGET(LTFILB,IPOINT,N) B7400257^^ 124 520 IF(N.NE.AT) GO TO 600 B7400258^ ^ C BYTE WAS @ MOVE IN TEXT BEFORE @ B7400260^^ 125 530 LENGTH=IPOINT-IPOS B7400261^^ 126 IAT=1 B7400262^^ 127 CALL CCSMVA(LTFILB,IPOS,LENGTH,LTRARR,LB+2,LENGTH) B7400263^^ 128 LB=LB+LENGTH B7400264^^ 129 IPOINT=IPOINT+1 B7400265^ ^ C GET NAME TYPE B7400267^^ 130 540 CALL CCSGET(LTFILB,IPOINT,N) B7400268^^ 131 NAMSW=N-$30 B7400269^^ 132 IPOINT=IPOINT+1 B7400270^ ^ C GET PUNCUATION B7400272^^ 133 550 CALL CCSGET(LTFILB,IPOINT,N) B7400273^^ 134 PUN=N B7400274^^ 135 IPOINT=IPOINT+3 B7400275^ ^ C GET CARRIAGE CONTROL B7400277^^ 136 560 CALL CCSGET(LTFILB,IPOINT,N) B7400278^^ 137 CC=N-$30 B7400279^ ^ C MOVE IN THE NAME B7400281^^ 138 570 IF(NAMSW.EQ.2) GO TO 580 B7400282^^ 139 CALL CCSMVA(NAME1,1,10,LTRARR,LB+2,10) B7400283^^ 140 LB=LB+2+10 B7400284^^ 141 GO TO 590 B7400285^^ 142 580 CALL CCSMVA(NAME2,1,9,LTRARR,LB+2,9) B7400286^^ 143 LB=LB+2+9 B7400287^ ^ C MOVE IN PUNCUATION AND GET NEXT LINE B7400289^^ 144 590 CALL CCSMVA(PUN,2,1,LTRARR,LB,1) B7400290^^ 145 GO TO 640 B7400291^ ^ C WAS NOT @ CHECK FOR * B7400293^^ 146 600 IF(N.NE.ASTRSK) GO TO 620 B7400294^ ^ C WAS * GET CARRIAGE CONTROL B7400296^^ 147 IPOINT=IPOINT+2 B7400297^^ 148 CALL CCSGET(LTFILB,IPOINT,N) B7400298^^ 149 CC=N-$30 B7400299^ ^ C CHECK IF @ WAS FOUND B7400301^t FTN 3.3B (OPT = LPC) LTPRNT PAGE 8 DATE: 08/29/84 TIME: 2141 t^ 150 610 IF(IAT.EQ.1) GO TO 640 B7400302^ ^ C NO @ WAS FOUND TREAT AS REGULAR LINE B7400304^^ 151 615 LENGTH=IPOINT-IPOS-2 B7400305^^ 152 GO TO 490 B7400306^ ^ 153 620 IPOINT=IPOINT+1 B7400308^ ^ C END OF FIRST ONLY LOOP B7400310^^ 154 630 CONTINUE B7400311^ ^ C END OF BUILD LETTER BODY LOOP B7400313^^ 155 640 IPOINT=IPOINT+1 B7400314^^ 156 650 CONTINUE B7400315^t FTN 3.3B (OPT = LPC) LTPRNT PAGE 9 DATE: 08/29/84 TIME: 2141 t^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ B7400317^^ C B7400318^^ C BODY FOR LETTER HAS BEEN BUILT B7400319^^ C PUT IN PLUGS B7400320^^ C B7400321^^ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ B7400322^ ^ 157 660 DO 710 I=1,9 B7400324^^ 158 IW=(I-1)*3+1 B7400325^^ 159 665 IF(FARRAY(IW).EQ.BLANK) GO TO 730 B7400326^^ 160 LINE=FARRAY(IW)/$100 B7400327^^ 161 COL=AND(FARRAY(IW),$FF) B7400328^^ 162 LB=(LINE-1)*60+COL+2 B7400329^^ 163 LENGTH=FARRAY(IW+1)/$100 B7400330^^ 164 TYPE=AND(FARRAY(IW+1),$FF) B7400331^ ^ C CHECK FOR WHICH TYPE OF PLUG B7400333^^ 165 670 IF(TYPE.EQ.D) GO TO 680 B7400334^^ 166 IF(TYPE.EQ.DOL) GO TO 690 B7400335^^ 167 IF(TYPE.EQ.A) GO TO 700 B7400336^ ^ C TYPE WAS DATE MOVE IN DATE B7400338^^ C THREE DIFFERENT TYPES ***00339^^ 168 680 IF(LENGTH.EQ.1) CALL CCSMVA(DATE1,1,18,LTRARR,LB,18) ***00340^^ 169 IF(LENGTH.EQ.2) CALL CCSMVA(DATE2,1,12,LTRARR,LB,12) ***00341^^ 170 IF(LENGTH.EQ.3) CALL CCSMVA(DATE3,1,8,LTRARR,LB,8) ***00342^^ 171 GO TO 710 B7400343^ ^ C TYPE WAS DOLLAR MOVE IN DOLLAR B7400345^^ 172 690 CALL CCSMVA(DOLLAR,1,11,LTRARR,LB,11) B7400346^^ 173 GO TO 710 B7400347^ ^ C TYPE WAS ALPHA MOVE IN A'S B7400349^^ 174 700 CALL CCSMVA(ALPHA,1,LENGTH,LTRARR,LB,LENGTH) B7400350^ ^ C END OF PLUG LOOP B7400352^^ 175 710 CONTINUE B7400353^t FTN 3.3B (OPT = LPC) LTPRNT PAGE 10 DATE: 08/29/84 TIME: 2141 t^ C PRINT THE BODY OF THE LETTER B7400355^^ 176 730 DO 830 I=1,24 B7400356^^ 177 LB=(I-1)*60+1 B7400357^^ 178 LW=(I-1)*30+1 B7400358^^ 179 740 IF(LTRARR(LW).EQ.$2020) GO TO 900 B7400359^^ 180 CALL CCSBLK(OBUF,132) B7400360^^ 181 CC=LTRARR(LW) B7400361^^ 182 GO TO (750, 760, 770, 780),CC B7400362^ ^ C CC WAS 1 - SINGLE SPACE B7400364^^ 183 750 OBUF(1)=SNGLSP B7400365^^ 184 GO TO 810 B7400366^ ^ C CC WAS 2 - DOUBLE SPACE B7400368^^ 185 760 OBUF(1)=DBLSPA B7400369^^ 186 GO TO 810 B7400370^ ^ C CC WAS 3 - SINGLE THEN DOUBLE SPACE B7400372^^ 187 770 OBUF(1)=SNGLSP B7400373^^ 188 GO TO 790 B7400374^ ^ C CC WAS 4 - DOUBLE THEN DOUBLE SPACE B7400376^^ 189 780 OBUF(1)=DBLSPA B7400377^ ^ C WRITE A BLANK LINE B7400379^^ 190 790 ASSIGN 800 TO ICOMP B7400380^^ 191 CALL FWRITE(PRT,OBUF,PRTLEN,ICOMP,IFLAG,ITEMP) B7400381^^ 192 CALL DISP B7400382^ ^ C SET UP SECOND LINE B7400384^^ 193 800 OBUF(1)=DBLSPA B7400385^ ^ C MOVE IN A LINE OF TEXT AND PRINT B7400387^^ 194 810 CALL CCSMVA(LTRARR,LB+2,58,OBUF,11,58) B7400388^^ 195 ASSIGN 830 TO ICOMP B7400389^^ 196 CALL FWRITE(PRT,OBUF,PRTLEN,ICOMP,IFLAG,ITEMP) B7400390^^ 197 CALL DISP B7400391^ ^ C END OF PRINT LOOP B7400393^^ 198 830 CONTINUE B7400394^t FTN 3.3B (OPT = LPC) LTPRNT PAGE 11 DATE: 08/29/84 TIME: 2141 t ^ C MOVE IN SIGNATURE LINE AFTER SPACE FOUR LINES B7400397^ ^ 199 900 CALL CCSBLK(OBUF, 132) B7400399^^ 200 CALL CCSMVA(DBLSPA,1,2,OBUF,1,2) B7400400^^ 201 ASSIGN 920 TO ICOMP B7400401^^ 202 CALL FWRITE(PRT,OBUF,PRTLEN,ICOMP,IFLAG,ITEMP) B7400402^^ 203 CALL DISP B7400403^  ^ C MOVE IN PSEUDO SIGNATURE BLOCK B7400406^ ^ 204 920 CALL CCSBLK(OBUF(3), 129) B7400408^^ 205 CALL CCSMVA(DBLSPA,1, 2, OBUF, 1, 2) B7400409^^ 206 ASSIGN 930 TO ICOMP B7400410^^ C ****************************************************** ???*0007********^^ 207 CALL CCSMVA (CONAME, 1, 12, OBUF, 37, 12) ********^^ C ****************************************************** ???*0007********^^ 208 CALL FWRITE(PRT,OBUF,PRTLEN,ICOMP,IFLAG,ITEMP) B7400412^^ 209 CALL DISP B7400413^ ^ 210 930 CALL CCSBLK(OBUF(3), 129) B7400415^^ 211 CALL CCSMVA(SNGLSP, 1, 2, OBUF, 1, 2) B7400416^^ 212 ASSIGN 940 TO ICOMP B7400417^^ C ****************************************************** ???*0007********^^ 213 CALL CCSMVA (PHONE, 1, 13, OBUF, 37, 13) ********^^ C ****************************************************** ???*0007********^^ 214 CALL FWRITE(PRT,OBUF,PRTLEN,ICOMP,IFLAG,ITEMP) B7400419^^ 215 CALL DISP B7400420^ ^ 216 940 CALL CCSBLK(OBUF(3), 129) B7400422^^ 217 CALL CCSMVA(SNGLSP, 1, 2, OBUF, 1, 2) B7400423^^ C ****************************************************** ???*0007********^^ 218 CALL CCSMVA (EXT, 1, 8, OBUF, 37, 8) ********^^ C ****************************************************** ???*0007********^^ 219 ASSIGN 950 TO ICOMP B7400425^^ 220 CALL FWRITE(PRT,OBUF,PRTLEN,ICOMP,IFLAG,ITEMP) B7400426^^ 221 CALL DISP B7400427^ ^ 222 950 CALL CCSBLK(OBUF(3),129) B7400429^^ 223 CALL CCSMVA(DBLSPA,1,2,OBUF,1,2) B7400430^^ C ****************************************************** ???*0007********^^ 224 CALL CCSMVA (COLDP, 1, 15, OBUF, 37, 15) ********^^ 225 ASSIGN 1000 TO ICOMP B7400432^^ 226 CALL FWRITE(PRT,OBUF,PRTLEN,ICOMP,IFLAG,ITEMP) B7400433^^ 227 CALL DISP B7400434^ ^ 228 1000 RETURN B7400436^^ 229 END B7400437^t FTN 3.3B (OPT = LPC) LTPRNT PAGE 12 DATE: 08/29/84 TIME: 2141 t  PROGRAM LENGTH $0AA9 ( 2729)   EXTERNALS 2 Q8PKUP Q8PREP PGMIN CCSBLK CCSCST CCSMVA FWRITE 2 DISP LTRDTE CCSGET  t FTN 3.3B (OPT = LPC) LTPRNT PAGE 13 DATE: 08/29/84 TIME: 2141 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < € 0001 (1) 0000 47,48,49,51,53,55,56,61,65,66,73,75,80,81,86,87,92,93,96,101,103,104,106,108,109,113,121,126,129,€€ 132,139,142,144,150,153,155,157,158,162,163,164,168,169,170,172,174,176,177,178,183,185,187,189, €F 193,200,205,207,211,213,217,218,223,224F‚ 0002 (2) 0706 49,49,52,65,73,80,86,92,96,100,116,119,127,138,139,140,142,143,144,147,151,162,169,194,200,205,211 ‚( ,217,223 (N 0003 (3) 0702 46,72,79,85,91,106,135,158,170,204,210,216,222 N. 0006 (6) 0708 58,58,59,60,66 .* 0008 (8) 0721 170,170,218*. 0009 (9) 0705 48,142,143,157 .* 000A (10) 071C 139,139,140*0 000B (11) 070D 81,87,93,172,194 0* 000C (12) 0720 169,169,207*& 000D (13) 0725 213,213&( 000E (14) 070C 81,81,87 (& 000F (15) 0726 224,224&& 0012 (18) 070B 74,168 &$ 0014 (20) 070E 93,93$& 001E (30) 0715 104,178&. 0025 (37) 0724 207,213,218,224." 0036 (54) 0701 45 "& 003A (58) 0723 194,194&* 003C (60) 0713 103,162,177*: 0081 (129) 070A 72,79,85,91,204,210,216,222:* 0084 (132) 0709 64,180,199 *& 00FF (255) 071F 161,164&" 05F0 (1520) 070F 98 "" 2020 (8224) 0722 179"   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < & A INTEGER 0001 1,3,167&( ADDRES INTEGER 06C7 25,27,87 (& ALPHA INTEGER 0002 1,3,174&& AND INTR.FN. 7FFF 161,164&, ASTRSK INTEGER 038D 11,13,112,146,( AT INTEGER 038C 11,13,124(( BLANK INTEGER 06AC 19,21,159(D CC INTEGER 03B1 19,21,100,110,118,122,137,149,181,182D( CITYZP INTEGER 06CE 27,29,93 (* COL INTEGER 0020 1,3,161,162*( COLDP INTEGER 06F3 33,36,224(( CONAME INTEGER 06E2 33,35,207(t FTN 3.3B (OPT = LPC) LTPRNT PAGE 14 DATE: 08/29/84 TIME: 2141 t( D INTEGER 038E 11,13,165(( DATE1 INTEGER 06AD 21,23,168(( DATE2 INTEGER 06B6 21,24,169(( DATE3 INTEGER 06BC 21,25,170(D DBLSPA INTEGER 0021 3,5,65,80,96,185,189,193,200,205,223 D( DOL INTEGER 038F 11,13,166(& DOLLAR INTEGER 0022 3,5,172&& DT INTEGER 7FFF 1,16,75&( EXT INTEGER 06EF 33,36,218(> FARRAY INTEGER 0028 3,37,45,58,159,160,161,163,164 >( FCOUNT INTEGER 0394 15,39,61 (( FEQ INTEGER 0396 17,19,49 (( FSWICH INTEGER 0043 5,7,40,51(H I INTEGER 0704 47,66,101,103,104,105,157,158,176,177,178H* IARAPT INTEGER 0703 46,47,58,59*, IAT INTEGER 0710 98,99,126,150,* ICOL INTEGER 0700 42,43,74,75*€ ICOMP INTEGER 0707 49,50,53,54,67,68,76,77,82,83,88,89,94,95,190,191,195,196,201,202,206,208,212,214,219,220,225,226€& IEND INTEGER 0044 5,7,106&N IFLAG INTEGER 0046 5,7,68,77,83,89,95,191,196,202,208,214,220,226 N‚ IPOINT INTEGER 06FE 40,41,46,49,52,53,56,58,60,102,106,111,113,115,116,117,123,125,129,130,132,133,135,136,147,148,151 ‚( ,153,155 (: IPOS INTEGER 0711 101,102,115,119,125,127,151:N ITEMP INTEGER 008A 7,9,68,77,83,89,95,191,196,202,208,214,220,226 N: IW INTEGER 071D 157,158,159,160,161,163,164:& J INTEGER 0718 108,121&f LB INTEGER 0712 102,103,119,127,128,139,140,142,143,144,162,168,169,170,172,174,177,194f" LCNT INTEGER 0047 5,7"$ LCOUNT INTEGER 06FF 41,42$$ LEN INTEGER 0092 9,11 $N LENGTH INTEGER 071A 115,115,119,125,127,128,151,163,168,169,170,174N* LINCT INTEGER 0716 104,105,108** LINE INTEGER 071E 159,160,162*T LTFILB INTEGER 7FFF 1,6,49,53,58,106,111,117,119,123,127,130,133,136,148 T` LTRARR INTEGER 03B3 19,98,110,119,122,127,139,142,144,168,169,170,172,174,179,181,194`" LU INTEGER 06FB 37 ": LW INTEGER 0714 103,104,110,122,178,179,181:$ MARGIN INTEGER 0393 13,15$0 MAXLEN INTEGER 0390 13,15,74,109,121 0" MODE INTEGER 06FC 37 "Z N INTEGER 0719 111,112,117,118,123,124,130,131,133,134,136,137,146,148,149Z( NAME INTEGER 06C0 25,27,81 (( NAME1 INTEGER 06D8 29,31,139(( NAME2 INTEGER 06DD 31,33,142(* NAMSW INTEGER 071B 130,131,138*& NCOMP INTEGER 0717 106,107&( NO INTEGER 0392 13,15,53 (* NOF INTEGER 03B0 17,19,44,55*$ NPORT INTEGER 06FD 37,38$‚ OBUF INTEGER 0048 5,64,65,68,72,73,75,77,79,80,81,83,85,86,87,89,91,92,93,95,96,180,183,185,187,189,191,193,194,196, ‚j 199,200,202,204,205,207,208,210,211,213,214,216,217,218,220,222,223,224,226j( PHONE INTEGER 06E8 33,35,213($ POS INTEGER 0093 9,11 $R PRT INTEGER 0395 16,17,38,68,77,83,89,95,191,196,202,208,214,220,226Rt FTN 3.3B (OPT = LPC) LTPRNT PAGE 15 DATE: 08/29/84 TIME: 2141 tP PRTLEN INTEGER 0391 13,15,68,77,83,89,95,191,196,202,208,214,220,226 P* PUN INTEGER 03B2 19,134,144 * RECBUF INTEGER 0095 9 " REQBLF INTEGER 0397 17 "< SNGLSP INTEGER 0389 9,11,73,86,92,183,187,211,217<$ STAR INTEGER 03AF 17,19$$ TOPOPG INTEGER 038A 9,11 $2 TYPE INTEGER 038B 11,164,165,166,167 2$ ZERO INTEGER 06AB 19,21$   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < L CCSBLK SUBROUTINE 0A22 44,64,72,79,85,91,98,180,199,204,210,216,222 L( CCSCST SUBROUTINE 083D 48,53,106(: CCSGET SUBROUTINE 08FB 110,117,123,130,133,136,148:‚ CCSMVA SUBROUTINE 0A61 58,65,73,80,81,86,87,92,93,96,119,127,139,142,144,168,169,170,172,174,194,200,205,207,211,213,217, ‚* 218,223,224*J DISP SUBROUTINE 0A5C 68,78,84,90,97,192,197,203,209,215,221,227 JJ FWRITE SUBROUTINE 0A54 67,77,83,89,95,191,196,202,208,214,220,226 J" LTRDTE SUBROUTINE 07AD 74 "" PGMIN SUBROUTINE 0728 36 " Q8PKUP INTEGER.FN. 0A87 Q8PREP INTEGER.FN. 0A84    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < " 40 0733 38 "" 50 073D 44 "" 70 0741 45 "" 72 0746 47 "" 74 0751 49 "" 75 0759 52 "$ 77 0768 54,58$" 78 0777 61 "* 90 0778 47,50,62,63*$ 100 077D 56,64$$ 115 0798 66,70$$ 120 0798 65,71$" 125 07AC 74 "" 127 07B2 75 "" 130 079D 71 "$ 140 07BD 75,79$" 145 07CF 81 "$ 150 07DA 81,85$" 155 07EB 87 "$ 160 07F6 87,91$t FTN 3.3B (OPT = LPC) LTPRNT PAGE 16 DATE: 08/29/84 TIME: 2141 t" 165 0808 93 "$ 400 081B 93,98$" 405 0824 100"" 430 083C 105"" 440 084B 107"" 450 084F 108"" 460 085B 110"" 465 0860 111"& 470 0867 108,114&& 480 0869 112,115&& 490 0876 118,152&& 500 0884 108,121&" 510 088E 122"" 520 0892 123"" 530 0898 124"" 540 08AD 129"" 550 08B6 132"" 560 08BF 135"" 570 08C7 137"& 580 08DB 138,142&& 590 08E9 140,144&& 600 08F1 124,146&" 610 0902 149"" 615 0905 150"& 620 090D 146,153&& 630 090E 121,154&. 640 0912 119,145,150,155.& 650 0913 100,156&& 660 091A 107,157&" 665 0923 158"" 670 0945 164"& 680 0956 165,168&& 690 0976 166,172&& 700 097E 167,174&. 710 0985 157,171,173,175.& 730 098B 159,176&" 740 099A 178"& 750 09B6 181,183&& 760 09BB 181,185&& 770 09BF 181,187&& 780 09C2 181,189&& 790 09C4 187,190&& 800 09D2 190,193&* 810 09D4 183,186,194** 830 09EB 176,195,198*& 900 09F0 179,199&& 920 0A05 200,204&& 930 0A21 205,210&& 940 0A3E 211,216&& 950 0A5D 218,222&& 1000 0A7A 224,228& LTPRNT 0A7F 1 t FTN 3.3B (OPT = LPC) LTRBLD PAGE 1 DATE: 08/29/84 TIME: 2143 t^ 1 PROGRAM LTRBLD B7500001^^ 1 1 /B75 F CCS CCS 3.0 .LA PSR 07/83 SL-149********^ ^ C B7500004^^ C CYBERCREDIT SYSTEM VERSION 3 B7500005^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B7500006^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B7500007^^ C B7500008^ ^ C THIS PROGRAM IS DESIGNED TO BUILD THE LETTER FILE ( LTRFIL ) B7500010^^ C THE INFORMATION CONTAINED IN THE LETTER DESCRIPTION INPUT FILE B7500011^^ C (LTRDESC . FORMAT OF INPUT: B7500012^ ^ C *A,LN B7500014^^ C F1=L1,C1,T1,P1,L1 B7500015^^ C : B7500016^^ C : B7500017^^ C F9=L9,C9,T9,P9,L9 B7500018^^ C **SP B7500019^^ C **SP B7500020^^ C B7500021^^ C END B7500022^ ^ C WHERE: B7500024^ ^ C *A = CODE FOR START OF LETTER B7500026^^ C LN = TWO DIGIT LETTER NUMBER B7500027^^ C F1 - F9 = THE MASTERFILE FIELDS THAT HAVE BEEN SPECIFIED FB7500028^^ C USE IN THE LETTER. THE F1-F9 ARE FOR USER B7500029^^ C REFERENCE AND ONLY THE F IS RECOGNIZED BY THE B7500030^^ C BUILD ROUTINE. B7500031^ ^ C WHERE F1-9=LX,CX,TX,PX,LX B7500033^ ^ C LX = LETTER LINE # B7500035^^ C CX = COLUMN NUMBER TO START FIELD IN B7500036^^ C TX = TYPE OF FIELD FOR EDITING PURPOSES B7500037^^ C WHERE: A = ALPHANUMERIC STRING B7500038^^ C D = DATE - EDITED TO MM/DD/YY B7500039^^ C $ = NINE DIGIT AMOUNT EDITED TO $9999999.99 B7500040^^ C PX = STARTING POSITION OF SELECTED MASTERFILE FIELD B7500041^^ C LX = LENGTH OF FIELD - ONLY APPLIES TO 'A' TYPE FIELD. B7500042^^ C FIELD MUST BE .LE. 54 CHARACTERS. B7500043^ ^ C FILE MANAGER , WORK BUFFERS, AND FILES B7500045^ ^ 2 INTEGER INBUF(66), LTREC1(40), LTRS(100) , LFBUF, OBUF(66) ********^^ 3 DATA LFBUF/0/, LTREC1/40*$2A2A/, LTRS/100*$2020 /, OBUF/66*$2020/ ********^ ^ 4 INTEGER LRPTBL(42), REQBRP(24), INAMKY(3),LRCBF1(42),TEMP ********^^ 5 DATA REQBRP/24*0/,INAMKY/3*0/,LRCBF1/42*$2020/ ********^ ^ 6 INTEGER HDBUF(66),LTFILB(758) B7500053^^ 7 DATA HDBUF/66*$2020/ B7500054^t FTN 3.3B (OPT = LPC) LTRBLD PAGE 2 DATE: 08/29/84 TIME: 2143 t ^ 8 INTEGER PRTBUF(66), REQBLD(24), REQBLF(24), REQBUT(24) B7500057^^ 9 DATA REQBLD/24*0/, REQBLF/24*0/, REQBUT/24*0/ B7500058^ ^ C******** FILE DESCRIPTION BUFFERS... ********^^ 10 INTEGER IDATLD(15),IDATRP(15),IDATLF(15),IDATUT(15) ********^^ 11 INTEGER DATLD(4) ********^ ^ 12 DATA DATLD/'LTRDESC '/ ********^^ 13 DATA IDATLD/'LALTRDSC',8*$2020, 0, 1, 0/ ********^^ 14 DATA IDATRP/'LARPTTBL',8*$2020, 1, 1, 0/ ********^^ 15 DATA IDATLF/'LALTRFIL',8*$2020, 1, 1, 0/ ********^^ 16 DATA IDATUT/'LAUTIFIL',8*$2020, 1, 1, 1/ ********^ ^ C CONSTANTS B7500078^ ^ 17 INTEGER AMONTO, ADAYTO, AYERTO, FMRDEL B7500080^ ^ 18 INTEGER A, ACODE(2), BLANK, COLNUM, COMMA, DT(3) B7500082^^ 19 DATA A/$0041/,ACODE/'*A,'/,BLANK/$0020/,COLNUM/2/,COMMA/$002C/ B7500083^^ 20 DATA DT/3*$2020/ B7500084^ ^ 21 INTEGER ARAPNT,EACH,CARCTL(2) B7500086^^ 22 DATA ARAPNT/0/,EACH/$0040/,CARCTL/'**1'/ B7500087^ ^ 23 INTEGER D, EQSIGN, F, FMAX, IFLAG, ITEXTE B7500089^^ 24 DATA D/$0044/,EQSIGN/$003D/,F/$4600/,FMAX/9/,IFLAG/0/,ITEXTE/0/ B7500090^ ^ 25 INTEGER HD1(2), HD2(2), HD3(2), ILTR1, ILTR2 B7500092^^ 26 DATA HD1/'HDR1'/, HD2/'HDR2'/, HD3/'HDR3'/, ILTR1/5/, ILTR2/5/ B7500093^ ^ 27 INTEGER IEND(2), LENGTH, LINUM, LKEY1(2) B7500095^^ 28 DATA IEND/'END'/,LENGTH/5/,LINUM/1/,LKEY1/'LTR1'/ B7500096^ ^ 29 INTEGER LKEY2(2),NINE,SIX B7500098^^ 30 DATA LKEY2/'LTR2'/,NINE/$39/,SIX/$36/ B7500099^ ^ 31 INTEGER MAXLEN, MINLEN, MXLINE, M B7500101^^ 32 DATA MAXLEN/57/, MINLEN/1/, MXLINE/24/, M/$004D/ B7500102^ ^ 33 INTEGER MAXLTR, MSTRPO, STAR, TYPE, DOLLAR B7500104^^ 34 DATA MAXLTR/$3939/, MSTRPO/4/, STAR/$002A/, TYPE/3/ B7500105^^ 35 DATA DOLLAR/$0024/ B7500106^ ^ 36 INTEGER STAR2,TOPPAG B7500108^^ 37 DATA STAR2/$2A2A/, TOPPAG/$000C/ B7500109^ ^ 38 INTEGER SNGLSP, DBLSPA,A1,A2,A3,A4,RE,TWO ********^^ 39 DATA SNGLSP/$000A/, DBLSPA/$0D0A/,TWO/$32/ ********^ ^ C COUNTERS, KEYS, AND VARIABLES B7500114^ ^ 40 INTEGER ENDPOS, FCOUNT, PARAM, PRTSTR B7500116^^ 41 INTEGER TXTLIN ***00117^t FTN 3.3B (OPT = LPC) LTRBLD PAGE 3 DATE: 08/29/84 TIME: 2143 t ^ 42 INTEGER ID(4), ITEMP(8), IRCNT, LCOUNT, LDKEY, LFKEY B7500120^^ 43 DATA ID/4*0/,ITEMP/8*0/,IRCNT/0/,LCOUNT/0/,LDKEY/0/,LFKEY/0/ B7500121^ ^ 44 INTEGER ITYPEA, ITYPED, IDOLAR, NOF,NO B7500123^^ 45 DATA ITYPEA/0/, ITYPED/0/, IDOLAR/0/, NOF/0/, NO/$004E/ B7500124^ ^ 46 INTEGER LFSTR(4), NSWICH, PRT, SAVKEY, WKBUF(2) B7500126^^ 47 DATA LFSTR/4*0/,NSWICH/0/,PRT/9/,SAVKEY/0/, WKBUF/2*0/ B7500127^  ^ 48 INTEGER LINCTL,NUMCHK,ZEROES(2),WKKEY,PRTLEN B7500130^^ 49 DATA LINCTL/$3100/, NUMCHK/0/, ZEROES/2*0/ B7500131^^ 50 DATA WKKEY/0/,PRTLEN/86/ ********^  ^ 51 INTEGER LTRCNT, THREEO(3),RTNMKY(3) B7500135^^ 52 DATA LTRCNT/0/, THREEO/3*0/,RTNMKY/3*0/ B7500136^^ C MESSAGE BUFFERS B7500137^t FTN 3.3B (OPT = LPC) LTRBLD PAGE 4 DATE: 08/29/84 TIME: 2143 t^ 53 INTEGER AERROR(15) B7500139^^ 54 DATA AERROR/'EXPECTED "*A," - FOUND " ".'/ B7500140^ ^ 55 INTEGER BLNKER(21) B7500142^^ 56 DATA BLNKER/'FOUND AN ILLEGAL BLANK IN PARAMETER " ".'/ B7500143^ ^ 57 INTEGER COMAER(21) B7500145^^ 58 DATA COMAER/'EXPECTED LETTER NUMBER - FOUND A "COMMA".'/ B7500146^ ^ 59 INTEGER DUPKEY(24) B7500148^^ 60 DATA DUPKEY/'DUPLICATE KEY - LETTER NUMBER XX ALEADY PRESENT'/ B7500149^ ^ 61 INTEGER ENDERR(14) B7500151^^ 62 DATA ENDERR/'EXPECTED "END" FOUND " ".'/ B7500152^ ^ 63 INTEGER EQERR(12) B7500154^^ 64 DATA EQERR/'FORMAT MISSING "=" SIGN '/ B7500155^ ^ 65 INTEGER FMAXER(19) B7500157^^ 66 DATA FMAXER/'FIELD DESCRIPTION EXCEEDS LIMIT OF 9.'/ B7500158^ ^ 67 INTEGER FERROR(13) B7500160^^ 68 DATA FERROR/'EXPECTED "F" - FOUND " ".'/ B7500161^ ^ 69 INTEGER LNERR(24) B7500163^^ 70 DATA LNERR/'EXPECTED NUMBER WITH RANGE OF 01-99 FOUND " ".'/ B7500164^ ^ 71 INTEGER PAMERR(21) B7500166^^ 72 DATA PAMERR/'EXCEEDED PARAMETER LIMIT ON PARAMETER # .'/ ***00167^ ^ 73 INTEGER PARAM1(22) B7500169^^ 74 DATA PARAM1/'LINE NUMBER IN FIELD DESCRIPTION EXCEEDS 24.'/ B7500170^ ^ 75 INTEGER PARAM2(22) ***00172^^ 76 DATA PARAM2/'COLUMN NUMBER PLUS FIELD LENGTH EXCEEDS 54. '/ ***00173^  ^ 77 INTEGER PARAME(15) B7500176^^ 78 DATA PARAME/'ILLEGAL CHARACTER - FOUND " ".'/ B7500177^ ^ 79 INTEGER PARAM5(24) B7500179^^ 80 DATA PARAM5/'ILLEGAL USE OF PARAM 5. TYPE FIELD DOES NOT = A.'/ B7500180^ ^ 81 INTEGER RPTBLE(25) B7500182^^ 82 DATA RPTBLE/'UNABLE TO LOCATE FIELD NAME " " IN RPTTBL '/ B7500183^ ^ 83 INTEGER TEXT1(25) B7500185^^ 84 DATA TEXT1/'UNABLE TO LOCATE LINE CONTROL OR CONTROL INVALID.'/ B7500186^ ^ 85 INTEGER TEXT2(14) B7500188^^ 86 DATA TEXT2/'NUMBER OF LETTERS EXCEED 50 '/ ********^ ^ 87 INTEGER MXNUML,NLRC ********^^ 88 DATA MXNUML / 50/,NLRC / 1 / ********^t FTN 3.3B (OPT = LPC) LTRBLD PAGE 5 DATE: 08/29/84 TIME: 2143 t ^ 89 INTEGER TEXT3(13) B7500191^^ 90 DATA TEXT3/'NUMBER OF LINES EXCEED 24 '/ B7500192^^ 91 INTEGER MAXLIN(22) ***00193^^ 92 DATA MAXLIN/'MAX. LINE NUMBER FIELD EXCEEDS LETTER SIZE. '/ ***00194^ ^ 93 INTEGER UTFERR(19) B7500196^^ 94 DATA UTFERR/'UNABLE TO LOCATE LTRX IN THE UTIFIL '/ B7500197^ ^ 95 INTEGER HD2A(15) B7500199^^ 96 DATA HD2A/' LETTER FILE BUILD '/ B7500200^ ^ 97 INTEGER HD2B(2) B7500202^^ 98 DATA HD2B/'PAGE'/ B7500203^ ^ 99 INTEGER HD3A(3) B7500205^^ 100 DATA HD3A/'AS OF:'/ B7500206^ ^ 101 INTEGER PAGCNT,PAGOUT(2),CRCTL2(2),SALSW,DECPOS,DATATP,EDITCD B7500208^^ 102 DATA PAGCNT/0/,PAGOUT/2*$0000/,CRCTL2/'**2'/,SALSW/0/ B7500209^ ^ 103 INTEGER RTBLSW,STARSW,T,Y B7500211^^ 104 DATA RTBLSW/0/,STARSW/0/,T/'T'/,Y/'Y'/ B7500212^ ^ 105 INTEGER HDR(60),ZERO,WKAREA(2),SALNUM B7500214^^ 106 DATA ZERO/$3030/,WKAREA/2*$2020/ B7500215^   ^ 107 EXTERNAL AMONTO,AYERTO,ADAYTO,FMRDEL B7500219^^ C TYPE D FIELD LENGTHS FOR DATE FORMATS. ***00220^^ 108 INTEGER DLENS(3) ***00221^^ 109 DATA DLENS/18,12,8/ ***00222^ t FTN 3.3B (OPT = LPC) LTRBLD PAGE 6 DATE: 08/29/84 TIME: 2143 t^ C CALL IN INFORMATION FROM ITOS CONCERNING EXECUTION ENVIRONMENT B7500225^ ^ 110 10 CALL PGMIN (ID, LU, MODE, NOPORT) B7500227^ ^ C IF NOT A MASTER TERMINAL EXIT FROM PROGRAM B7500229^ ^ 111 20 IF (NOPORT .NE. 0) PRT = 5 ********^ ^ 112 CALL CCSCST(IDATUT,1,2,ID,1,8,ICM) ********^^ 113 IF(ICM.EQ.0) GO TO 25 ********^^ 114 CALL CCSMVA(IDATUT,3,6,IDATUT,1,8) ********^^ 115 CALL CCSMVA(IDATRP,3,6,IDATRP,1,8) ********^^ 116 CALL CCSMVA(IDATLF,3,6,IDATLF,1,8) ********^^ 117 CALL CCSMVA(DATLD ,1,8,IDATLD,1,8) ********^^ 118 25 CONTINUE ********^ ^ C OPEN LETTER DESCRIPTION FILE B7500233^ ^ 119 30 CALL OPENFL(REQBLD, IDATLD, ISTAT) B7500235^^ 120 32 IF (ISTAT .GE. 0) GO TO 35 B7500236^^ 121 CALL FILERR(IDATLD, 3, ISTAT, LU) B7500237^^ 122 GO TO 2010 B7500238^ ^ C OPEN REPORT TABLE FILE DESCRIPTION B7500240^ ^ 123 35 CALL OPENFL(REQBRP, IDATRP, ISTAT) B7500242^^ 124 37 IF(ISTAT .GE. 0) GO TO 40 B7500243^^ 125 CALL FILERR(IDATRP, 3, ISTAT, LU) B7500244^^ 126 GO TO 2010 B7500245^  ^ C BRING IN HEADINGS AND DATE B7500248^^ 127 40 CALL UTHEAD(HDR,DT) B7500249^  ^ C CALL IN SYSTEM DELETE CODE B7500252^ ^ 128 45 ASSEM $C000,FMRDEL,$6800,ISDEL B7500254^  ^ C******* CLEAR LTRFIL THEN OPEN IT. ********^ ^ 129 CALL CLEAR(REQBLF,IDATLF,ISTAT) ********^^ 130 DO 56 IZ = 1,24 ********^^ 131 56 REQBLF(IZ) = 0 ********^ ^ 132 57 CALL OPENFL(REQBLF,IDATLF,ISTAT) B7500259^^ 133 IF(ISTAT .GE. 0) GO TO 60 B7500260^^ 134 CALL FILERR(IDATLF, 3, ISTAT, LU) B7500261^^ 135 GO TO 2010 B7500262^ ^ C OPEN UTILITY FILE. B7500264^ ^ 136 60 CALL OPENFL(REQBUT, IDATUT, ISTAT) B7500266^t FTN 3.3B (OPT = LPC) LTRBLD PAGE 7 DATE: 08/29/84 TIME: 2143 t^ 137 65 IF (ISTAT .GE. 0) GO TO 90 ********^^ 138 CALL FILERR(IDATUT, 3, ISTAT, LU) B7500268^^ 139 GO TO 2010 B7500269^ ^ 140 90 NSWICH=0 B7500277^t FTN 3.3B (OPT = LPC) LTRBLD PAGE 8 DATE: 08/29/84 TIME: 2143 t^ C***********************************************************************B7500279^^ C READ A RECORD FROM THE LETTER DESCRIPTION FILE AND SEARCH B7500280^^ C FOR VALID '*A,LN'. B7500281^^ C***********************************************************************B7500282^^ C B7500283^^ 141 130 CALL GETS (REQBLD, INBUF, LDKEY, ISTAT) B7500284^^ 142 IF(AND(ISTAT,$100).EQ.$100) GO TO 196 ********^^ 143 IF(ISTAT .GE. 0) GO TO 135 B7500286^^ 144 CALL FILERR(INBUF, 14, ISTAT, LU) B7500287^^ 145 GO TO 2010 B7500288^ ^ C INITIALIZE COUNTERS B7500290^ ^ 146 135 LFSTR=1 B7500292^^ 147 ARAPNT=1 B7500293^^ 148 LCOUNT=1 B7500294^^ 149 TXTLIN = 0 ***00295^^ 150 SALNUM=0 B7500296^^ 151 LINEND=0 B7500297^^ 152 IRCNT=0 B7500298^^ 153 FCOUNT=0 B7500299^^ 154 NOF=0 B7500300^^ 155 SALSW=0 B7500301^^ 156 STARSW=0 B7500302^^ 157 IMAXLN = 0 ***00303^ ^ C CHECK FOR SYSTEM DELETE CODE AT BEGINNING OF EACH RECORD READ. B7500305^ ^ 158 136 IF(INBUF(1).EQ.ISDEL) GO TO 130 B7500307^ ^ 159 140 CALL CCSBLK(PRTBUF,PRTLEN) B7500309^^ 160 CALL CCSMVA(TOPPAG, 1, 2, PRTBUF, 1, 2) B7500310^^ 161 CALL CCSMVA(HDR,1,40,PRTBUF,5,40) B7500311^^ 162 ASSIGN 150 TO ICOMP B7500312^^ 163 CALL FWRITE(PRT,PRTBUF,PRTLEN,ICOMP,IFLAG, ITEMP) B7500313^^ 164 CALL DISP B7500314^ ^ 165 150 CALL CCSBLK(PRTBUF,PRTLEN) B7500316^^ 166 CALL CCSMVA(SNGLSP, 1, 2, PRTBUF, 1, 2) B7500317^^ 167 CALL CCSMVA(HDR,41,40,PRTBUF,5,40) B7500318^^ 168 CALL CCSMVA(HD2A, 1, 30, PRTBUF, 51, 30) B7500319^^ 169 CALL CCSMVA(HD2B, 1, 4, PRTBUF, 75, 4) ********^ ^ C CONVERT PAGE NUMBER B7500322^^ 170 160 PAGCNT=PAGCNT+1 B7500323^^ 171 A1=PAGCNT/$3E8 B7500324^^ 172 RE=PAGCNT-(A1*$3E8) B7500325^^ 173 A2=RE/$64 B7500326^^ 174 RE=RE-(A2*$64) B7500327^^ 175 A3=RE/$A B7500328^^ 176 RE=RE-(A3*$A) B7500329^^ 177 A4=RE B7500330^ ^ C MOVE PAGE COUNT TO PRINTER B7500332^t FTN 3.3B (OPT = LPC) LTRBLD PAGE 9 DATE: 08/29/84 TIME: 2143 t ^ 178 165 PAGOUT(2)=((A3+$30)*$100)+(A4+$30) B7500334^^ 179 PAGOUT(1)=((A1+$30)*$100)+(A2+$30) B7500335^ ^ C EDIT PAGE COUNT B7500337^ ^ 180 DO 166 I=1,3 B7500339^^ 181 CALL CCSCST(PAGOUT,I,1,ZERO,1,1,NCOMP) B7500340^^ 182 IF(NCOMP.NE.0) GO TO 167 B7500341^^ 183 CALL CCSMVA(BLANK,2,1,PAGOUT,I,1) B7500342^^ 184 166 CONTINUE B7500343^^ 185 167 CALL CCSMVA(PAGOUT,1,4,PRTBUF,80,4) ********^^ 186 ASSIGN 170 TO ICOMP B7500345^^ 187 CALL FWRITE(PRT,PRTBUF,PRTLEN,ICOMP,IFLAG, ITEMP) B7500346^^ 188 CALL DISP B7500347^ ^ 189 170 CALL CCSBLK(PRTBUF,PRTLEN) B7500349^^ 190 CALL CCSMVA(SNGLSP, 1, 2, PRTBUF, 1, 2) B7500350^^ 191 CALL CCSMVA(HDR,81,40,PRTBUF,5,40) B7500351^^ 192 CALL CCSMVA(HD3A, 1, 6, PRTBUF, 51, 6) B7500352^^ 193 CALL LTRDTE(DT,PRTBUF,60,1) B7500353^^ 194 ASSIGN 190 TO ICOMP B7500354^^ 195 CALL FWRITE(PRT,PRTBUF,PRTLEN,ICOMP,IFLAG,ITEMP) B7500355^^ 196 CALL DISP B7500356^   ^ C CHECK FOR END OF LETTER DESCRIPTION FILE. B7500360^^ 197 190 CALL CCSCST(INBUF, 1, 3, IEND, 1, 3, NCOMP) B7500361^^ 198 195 IF (NCOMP .NE. 0) GO TO 220 B7500362^^ 199 196 NSWICH = NSWICH +1 ********^ ^ C MOVE 'END' RECORD TO ECHO PRINT++++++++++++++++++++++++++++++++B7500365^ ^ 200 200 CALL CCSBLK(PRTBUF,132) B7500367^^ 201 PRTBUF(1)=SNGLSP B7500368^^ 202 CALL CCSMVA(INBUF, 1, 3, PRTBUF, 5, 3) B7500369^ ^ C NSWICH = 1, WE HAVE FOUND ONE END - GET ANOTHER RECORD. B7500371^ ^ 203 IF(NSWICH .EQ. 1) ASSIGN 130 TO ICOMP B7500373^ ^ C NSWICH = 2, WE HAVE THE SECOND END - GO TO CLOSE FILES. B7500375^ ^ 204 IF(NSWICH .EQ. 2) ASSIGN 1600 TO ICOMP B7500377^^ 205 CALL FWRITE(PRT, PRTBUF, PRTLEN, ICOMP, IFLAG, ITEMP) B7500378^^ 206 CALL DISP B7500379^  ^ C CHECK FOR VALID '*A,' CODE (START OF A NEW LETTER - BYTES 1-3) B7500382^^ 207 220 NSWICH=0 B7500383^ ^ C IF THERE IS A VALID *A SAVE FIELD AND PROCESS LETTER NUMBER. B7500385^ t FTN 3.3B (OPT = LPC) LTRBLD PAGE 10 DATE: 08/29/84 TIME: 2143 t^ 208 230 CALL CCSCST(INBUF, 1, 3, ACODE, 1, 3, NCOMP) B7500387^^ 209 IF(NCOMP .EQ. 0) GO TO 250 B7500388^^ 210 GO TO 235 B7500389^ ^ C *A NOT FOUND - PRINT ERROR MESSAGE AND ERRONEOUS DATATA B7500391^ ^ 211 235 CALL CCSBLK(OBUF,132) B7500393^^ 212 CALL CCSBLK(PRTBUF,PRTLEN) B7500394^^ 213 PRTBUF(1)=DBLSPA B7500395^^ 214 CALL CCSMVA(INBUF,1,80,PRTBUF,5,80) B7500396^^ 215 ASSIGN 236 TO ICOMP B7500397^^ 216 CALL FWRITE(PRT,PRTBUF,PRTLEN,ICOMP,IFLAG,ITEMP) B7500398^^ 217 CALL DISP B7500399^^ 218 236 CONTINUE B7500400^^ 219 OBUF(1)=DBLSPA B7500401^^ 220 CALL CCSMVA(INBUF,1,3,AERROR,25,3) B7500402^^ 221 CALL CCSMVA(AERROR,1,30,OBUF,10,30) B7500403^^ 222 IRCNT=IRCNT+1 B7500404^^ 223 ASSIGN 400 TO ICOMP B7500405^^ 224 CALL CCSMVA(INBUF, 1,3, OBUF, 34, 3) B7500406^^ 225 CALL FWRITE (PRT, OBUF,132, ICOMP, IFLAG, ITEMP) B7500407^^ 226 CALL DISP B7500408^ ^ C IF NSWICH = 1 WE HAVE AN END RECORD PRIOR TO READING B7500410^^ C NEXT LETTER B7500411^ ^ 227 250 IF(NSWICH .NE. 1) GO TO 320 B7500413^^ 228 251 CONTINUE B7500414^^ 229 OBUF(1)=SNGLSP B7500415^^ 230 CALL CCSBLK(OBUF,PRTLEN) B7500416^^ 231 CALL CCSMVA(INBUF,1,3,ENDERR,23,3) B7500417^^ 232 CALL CCSMVA(ENDERR,1,28,OBUF,10,28) B7500418^^ 233 IRCNT=IRCNT+1 B7500419^^ 234 ASSIGN 320 TO ICOMP B7500420^^ 235 CALL FWRITE(PRT, OBUF, PRTLEN, ICOMP, IFLAG, ITEMP) B7500421^^ 236 CALL DISP B7500422^ ^ C BLANK LETTER FILE B7500424^ ^ 237 320 CALL CCSBLK(LTFILB,1512) B7500426^^ 238 NSWICH=0 B7500427^   ^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++B7500431^^ C MOVE LETTER FILE POINTER (LTFILB) B7500432^^ C CHECK FOR VALID LETTER NUMBER (BYTES 4 AND 5) B7500433^^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++B7500434^ ^ 239 330 CALL CCSMVA(ZEROES, 1, 2, SAVKEY, 1, 2) B7500436^^ 240 335 DO 360 I = 1, 2 B7500437^^ 241 CALL CCSGET(INBUF, I+3, N) B7500438^^ 242 IF(N .GE. $30 .AND. N .LE. $39) GO TO 340 B7500439^^ 243 IF(N .EQ. BLANK .AND. I .EQ. 2) GO TO 337 B7500440^t FTN 3.3B (OPT = LPC) LTRBLD PAGE 11 DATE: 08/29/84 TIME: 2143 t ^ C IF NOT NUMERIC AND/OR POSITION 1 IS A BLANK - ERROR B7500442^ ^ 244 GO TO 390 B7500444^ ^ C VALID NUMBER - PLACE IN SAVKEY (LETTER NUMBER KEY) B7500446^ ^ 245 337 SAVKEY=SAVKEY/$100+$3000 B7500448^^ 246 GO TO 360 B7500449^ ^ 247 340 CALL CCSPUT(N, I, SAVKEY) B7500451^ ^ 248 360 CONTINUE B7500453^  ^ C MOVE '*A,LN' RECORD TO ECHO PRINT.+++++++++++++++++++++++++++++B7500457^ ^ 249 370 CALL CCSBLK(PRTBUF,PRTLEN) B7500459^^ 250 CALL CCSMVA(DBLSPA, 1, 2, PRTBUF, 1, 2) B7500460^^ 251 CALL CCSMVA(INBUF,1,80,PRTBUF,5,80) B7500461^^ 252 ASSIGN 380 TO ICOMP B7500462^^ 253 CALL FWRITE(PRT, PRTBUF, PRTLEN, ICOMP, IFLAG, ITEMP) B7500463^^ 254 CALL DISP B7500464^ ^ C CHECK IF LETTER NUMBER EXCEEDS MAXIMUM NUMBER OF LETTERS. B7500466^ ^ 255 380 IF(SAVKEY .GT. MAXLTR) GO TO 390 B7500468^ ^ C IF NOT > MAXIMUM - MOVE TO LETTER FILE AND LETTER PRINT. B7500470^ ^ 256 382 CALL CCSMVA(SAVKEY,1,2,LTFILB,LFSTR,2) B7500472^^ 257 LFSTR=LFSTR+2 B7500473^^ 258 GO TO 400 B7500474^ ^ C FOUND AN ILLEGAL CHARACTER B7500476^ ^ 259 390 CALL CCSBLK(OBUF,132) B7500478^^ 260 CALL CCSBLK(PRTBUF,PRTLEN) B7500479^^ 261 PRTBUF(1)=DBLSPA B7500480^^ 262 CALL CCSMVA(INBUF,1,80,PRTBUF,5,80) B7500481^^ 263 ASSIGN 395 TO ICOMP B7500482^^ 264 CALL FWRITE(PRT,PRTBUF,PRTLEN,ICOMP,IFLAG,ITEMP) B7500483^^ 265 CALL DISP B7500484^^ 266 395 CONTINUE B7500485^^ 267 OBUF(1)=SNGLSP B7500486^^ 268 CALL CCSMVA(INBUF,4,2,LNERR,44,2) B7500487^^ 269 CALL CCSMVA(LNERR,1,47,OBUF,10,47) B7500488^^ 270 IRCNT=IRCNT+1 B7500489^^ 271 ASSIGN 400 TO ICOMP B7500490^^ 272 CALL FWRITE(PRT, OBUF,132, ICOMP, IFLAG, ITEMP) B7500491^^ 273 CALL DISP B7500492^t FTN 3.3B (OPT = LPC) LTRBLD PAGE 12 DATE: 08/29/84 TIME: 2143 t ^ C***********************************************************************B7500495^^ C B7500496^^ C READ A RECORD AND SEARCH FOR VALID 'F' FIELD. B7500497^^ C B7500498^^ C***********************************************************************B7500499^ ^ 274 400 CALL CCSBLK(INBUF,80) B7500502^^ 275 IBYTE=0 B7500503^^ 276 CALL CCSBLK(PRTBUF, 132) B7500504^^ 277 420 CALL GETS (REQBLD, INBUF, LDKEY, ISTAT) B7500505^^ 278 IF(AND(ISTAT,$100).EQ.$100) GO TO 251 B7500506^^ 279 IF(ISTAT .GE. 0) GO TO 430 B7500507^^ 280 CALL FILERR(INBUF,14, ISTAT, LU) B7500508^^ 281 GO TO 2010 B7500509^ ^ C CHECK FOR SYSTEM DELETE CODE B7500511^ ^ 282 430 IF(INBUF(1).EQ.ISDEL) GO TO 420 B7500513^  ^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++B7500516^^ C "F" DESCRIPTION RECORD? B7500517^^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++B7500518^ ^ 283 520 ITYPEA=0 B7500520^^ 284 ITYPED=0 B7500521^^ 285 IDOLAR=0 B7500522^ ^ 286 CALL CCSCST(INBUF,1,1,F,1,1,NCOMP) B7500524^^ 287 IF(NCOMP .EQ. 0) GO TO 540 B7500525^^ C FCOUNT .GE. 1 (WE HAVE AT LEAST ONE B7500526^^ C "F" FIELD) - GO TO TEXT SEARCH B7500527^ ^ 288 525 IF(FCOUNT .GE. 1) GO TO 1200 B7500529^^ 289 PRTBUF(1)=SNGLSP B7500530^^ 290 CALL CCSMVA(INBUF, 1, 80, PRTBUF, 5, 80) B7500531^^ 291 ASSIGN 530 TO ICOMP B7500532^^ 292 CALL FWRITE(PRT,PRTBUF,PRTLEN,ICOMP,IFLAG,ITEMP) B7500533^^ 293 CALL DISP B7500534^ ^ C NO "F" FIELD + FCOUNT=0 (WE HAVE FOUND NO F FIELDS) B7500536^ ^ 294 530 CALL CCSBLK (OBUF,132) B7500538^^ 295 OBUF(1)=SNGLSP B7500539^^ 296 CALL CCSMVA(INBUF,1,1,FERROR,23,1) B7500540^^ 297 CALL CCSMVA(FERROR,1,26,OBUF,10,26) B7500541^^ 298 IRCNT=IRCNT+1 B7500542^^ 299 ASSIGN 1236 TO ICOMP B7500543^^ 300 CALL FWRITE (PRT, OBUF,132, ICOMP, IFLAG, ITEMP) B7500544^^ 301 CALL DISP B7500545^ ^ C FOUND A VALID "F" - MOVE TO LTRFILE IF LCOUNT IS LESS THEN 9. B7500547^ t FTN 3.3B (OPT = LPC) LTRBLD PAGE 13 DATE: 08/29/84 TIME: 2143 t^ 302 540 IF(FCOUNT .EQ. FMAX) GO TO 1140 B7500549^^ 303 CALL CCSMVA (INBUF, 1, 1, LTFILB, LFSTR, 1) B7500550^ ^ C MOVE "F" TO PRINT++++++++++++++++++++++++++++++++++++++++++++++B7500552^^ 304 PRTBUF(1)=SNGLSP B7500553^^ 305 CALL CCSMVA(INBUF, 1, 80, PRTBUF, 5, 85) B7500554^^ 306 ASSIGN 560 TO ICOMP B7500555^^ 307 CALL FWRITE(PRT,PRTBUF,PRTLEN,ICOMP,IFLAG,ITEMP) B7500556^^ 308 CALL DISP B7500557^  ^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++B7500560^^ C SEARCH FOR "=" FIELD. WILL SCAN SIX BYTES SEARCHING FOR '='. B7500561^^ C IF NOT FOUND WILL DROP TO PARA 600 AND PRINT ERROR. B7500562^^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++B7500563^ ^ 309 560 LFSTR=LFSTR+1 B7500565^^ 310 DO 580 I=1,41 B7500566^^ 311 CALL CCSGET(INBUF, I+1, N) B7500567^ ^ 312 ICNT=I B7500569^^ 313 IF(N .EQ. EQSIGN) GO TO 595 B7500570^^ 314 580 CONTINUE B7500571^ ^ C FALL THROUGH ERROR DID NOT FIND AN "=" SIGN B7500573^ ^ 315 590 CALL CCSBLK (OBUF,132) B7500575^^ 316 OBUF(1)=SNGLSP B7500576^^ 317 CALL CCSMVA(EQERR,1,24,OBUF,10,24) B7500577^^ 318 FCOUNT=FCOUNT+1 B7500578^^ 319 IRCNT=IRCNT+1 B7500579^^ 320 ASSIGN 400 TO ICOMP B7500580^^ 321 CALL FWRITE(PRT, OBUF,132, ICOMP, IFLAG, ITEMP) B7500581^^ 322 CALL DISP B7500582^ ^ C FOUND "=" SIGN, MOVE TO LETTER FILE(LTFILB). B7500584^ ^ 323 595 CALL CCSMVA(N, 2, 1, LTFILB, LFSTR, 1) B7500586^ ^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++B7500588^^ C SEARCH FOR VALID PARAMETERS FOLLOWING '=' SIGN. B7500589^^ C ICNT EQUALS THE POSITION OF THE '=' IN THE F RECORD. VALUE IS B7500590^^ C SET IN PARA 560. B7500591^^ C LINUM=1, COLNUM=2, TYPE=3, MSTRPO=4, LENGTH=5 B7500592^^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++B7500593^ ^ 324 600 PARAM=1 B7500595^^ 325 ICNT=ICNT+1 B7500596^^ 326 CALL CCSMVA(ZEROES, 1, 4, WKBUF, 1, 4) B7500597^^ 327 DO 1000 I = 1,16 B7500598^^ 328 IBYTE=IBYTE+1 B7500599^^ 329 CALL CCSGET(INBUF, I+ICNT, N) B7500600^ ^ 330 610 IF(N .GE. $30 .AND. N .LE. $39) GO TO 620 B7500602^t FTN 3.3B (OPT = LPC) LTRBLD PAGE 14 DATE: 08/29/84 TIME: 2143 t^ 331 IF(N .EQ. NO) GO TO 680 B7500603^^ 332 IF(N .EQ. COMMA) GO TO 700 B7500604^^ 333 IF(N .EQ. A) GO TO 780 B7500605^^ 334 IF(N .EQ. D) GO TO 820 B7500606^^ 335 IF(N .EQ. M) GO TO 630 B7500607^^ 336 IF(N .EQ. DOLLAR) GO TO 780 B7500608^^ 337 IF(N .EQ. BLANK) GO TO 660 B7500609^ ^ C AT THIS POINT IF FIELD IS NOT EQUAL TO 0-9, A COMMA, CHARACTER B7500611^^ C 'A', 'D', '$' OR A BLANK IT IS IN ERROR. B7500612^ ^ 338 615 CALL CCSBLK(OBUF,132) B7500614^^ 339 CALL CCSMVA(N,2,1,PARAME,28,1) B7500615^^ 340 CALL CCSMVA(PARAME,1,30,OBUF,10,30) B7500616^^ 341 GO TO 935 B7500617^ ^ C NUMERIC FIELD B7500619^ ^ 342 620 IF(IBYTE.EQ.1.OR. IBYTE .EQ. 2) GO TO 655 B7500621^^ 343 IF(IBYTE.EQ.3.AND. PARAM .EQ. MSTRPO) GO TO 655 B7500622^^ 344 IF(IBYTE.EQ.3 .AND. PARAM .NE. 4) GO TO 900 B7500623^^ 345 IF(IBYTE .EQ. 4 .AND. PARAM .NE. 4) GO TO 900 B7500624^^ 346 IF(IBYTE .EQ. 4 .AND. PARAM .EQ. MSTRPO) GO TO 655 B7500625^^ 347 IF(IBYTE .GT. 4) GO TO 900 B7500626^t FTN 3.3B (OPT = LPC) LTRBLD PAGE 15 DATE: 08/29/84 TIME: 2143 t ^ C USE OF MASTER FIELD NAME HAS BEEN SELECTED - N = 'M' B7500629^ ^ 348 630 IF(PARAM .NE. 3) GO TO 900 B7500631^^ 349 CALL CCSBLK(RTNMKY, 6) B7500632^ ^ C MOVE 1ST LETTER TO RTNAME KEY B7500634^ ^ 350 632 ICNT=I+ICNT B7500636^^ 351 INAMPO=1 B7500637^^ 352 CALL CCSMVA(N, 2, 1, RTNMKY, INAMPO, 1) B7500638^ ^ C MOVE REST OF RTNAME TO KEY B7500640^ ^ 353 634 DO 639 II=1, 6 B7500642^^ 354 INAMPO=INAMPO+1 B7500643^^ 355 CALL CCSGET(INBUF, II+ICNT, N) B7500644^^ 356 IF(N .EQ. $0020 .OR. N .EQ. $002C) GO TO 640 B7500645^^ 357 CALL CCSMVA(N, 2, 1, RTNMKY, INAMPO, 1) B7500646^^ 358 639 CONTINUE B7500647^ ^ C READ REPORT TABLE B7500649^ ^ 359 640 CALL CCSMVA(RTNMKY,1,6,HDBUF,1,6) B7500651^^ 360 CALL READR(REQBRP,LRPTBL,RTNMKY,ISTAT) B7500652^^ 361 IF(AND(ISTAT,$200).EQ.$200) GO TO 643 B7500653^^ 362 IF(ISTAT.GE.0) GO TO 644 B7500654^^ 363 CALL FILERR(IDATRP,13,ISTAT,LU) B7500655^^ 364 GO TO 2010 B7500656^^ 365 643 CALL CCSBLK(OBUF,132) B7500657^^ 366 OBUF(1)=SNGLSP B7500658^^ 367 CALL CCSMVA(HDBUF,1,6,RPTBLE,30,6) B7500659^^ 368 CALL CCSMVA(RPTBLE,1,50,OBUF,10,50) B7500660^^ 369 CALL CCSBLK(RTNMKY, 6) B7500661^^ 370 IRCNT=IRCNT+1 B7500662^^ 371 FCOUNT=FCOUNT+1 B7500663^^ 372 ASSIGN 400 TO ICOMP B7500664^^ 373 CALL FWRITE(PRT, OBUF,132, ICOMP, IFLAG, ITEMP) B7500665^^ 374 CALL DISP B7500666^ ^ C GET FIELD TYPE B7500668^  ^ C ...IF D TYPE DO D TYPE PROCESSING. ***00671^^ 375 644 CALL CCSCST (LRPTBL, 16, 1, Y, 1, 1, NCOMP) ***00672^^ 376 IF (NCOMP .NE. 0) GO TO 645 ***00673^^ 377 ITEMP2 = D ***00674^^ 378 ILENFL = 3 ***00675^^ 379 ILENTH = 8 ***00676^^ 380 GO TO 648 ***00677^^ C ...IF A TYPE DO A TYPE PROCESSING. ***00678^^ 381 645 CALL CCSCST (LRPTBL, 15, 1, A, 2, 1, NCOMP) ***00679^^ 382 IF (NCOMP .NE. 0) GO TO 646 ***00680^^ 383 ITEMP2 = A ***00681^t FTN 3.3B (OPT = LPC) LTRBLD PAGE 16 DATE: 08/29/84 TIME: 2143 t^ 384 CALL CCSMVA (LRPTBL, 11, 4, WKBUF, 1, 4) ***00682^^ 385 WKBUF(2) = ICCSAD (WKBUF(2)) ***00683^^ 386 ILENFL = ICCSAD (WKBUF(1))*100+WKBUF(2) ***00684^^ 387 ILENTH = ILENFL ***00685^^ 388 GO TO 648 ***00686^^ C ...MUST BE $ TYPE DO $ TYPE PROCESSING. ***00687^^ 389 646 ITEMP2 = DOLLAR ***00688^^ 390 ILENFL = NINE ***00689^^ 391 ILENTH = 11 ***00690^^ C ...DO COMMON PROCESSING FOR TYPE. ***00691^^ 392 648 CALL CCSMVA (ILENFL, 2, 1, LTFILB, LFSTR+3, 1) ***00692^^ 393 CALL CCSMVA (ITEMP2, 2, 1, LTFILB, LFSTR+4, 1) ***00693^^ C ...VERIFY FIELD DOES NOT EXCEED 54 CHAR/LINE. ***00694^^ 394 IF (ISVCOL + ILENTH .GT. 55) GO TO 920 ***00695^ ^ C MOVE IN MASTER POSITION B7500697^ ^ 395 649 CALL CCSMVA(LRPTBL, 7, 4, WKBUF, 1, 4) B7500699^^ 396 650 WKBUF(2)=ICCSAD(WKBUF(2)) B7500700^^ 397 WKBUF(1)=ICCSAD(WKBUF(1))*100+WKBUF(2) B7500701^^ 398 CALL CCSMVA(WKBUF(1), 1, 2, LTFILB, LFSTR+5, 2) B7500702^^ 399 GO TO 895 B7500703^t FTN 3.3B (OPT = LPC) LTRBLD PAGE 17 DATE: 08/29/84 TIME: 2143 t ^ C PLACE N INTO WKBUF TO LIMIT CHECK AND FOR CONVERSION B7500706^^ C (PARAGRAPH 670-737 FOR CONVERSION) B7500707^ ^ 400 655 IF(IBYTE .GT. 4) GO TO 900 B7500709^^ 401 CALL CCSPUT(N, IBYTE, WKBUF) B7500710^^ 402 GO TO 1000 B7500711^ ^ C FOUND A BLANK B7500713^ ^ 403 660 IF(PARAM.LE.TYPE.AND.ITYPED.EQ.1) GO TO 930 B7500715^^ 404 IF(PARAM.LE.MSTRPO.AND.ITYPED.NE.1) GO TO 930 B7500716^^ 405 IF(PARAM .EQ. LENGTH) GO TO 670 B7500717^ ^ C FOUND A BLANK MSTRPO PARAMATER(4) B7500719^ ^ 406 665 IF(IBYTE .EQ. 1) GO TO 930 B7500721^^ 407 IF(IBYTE .EQ. 2 .OR. IBYTE .EQ. 3) GO TO 720 B7500722^^ 408 IF(IBYTE .EQ. 4) GO TO 860 B7500723^^ 409 IF(IBYTE .EQ. 5) GO TO 880 B7500724^^ 410 GO TO 900 B7500725^ ^ C FOUND A BLANK IN LENGTH PARAMATER(5) B7500727^ ^ 411 670 IF(IBYTE .EQ. 1) GO TO 675 B7500729^^ 412 IF (IBYTE .EQ. 2) GO TO 720 ***00730^^ 413 IF (IBYTE .EQ. 3) GO TO 740 ***00731^ ^ 414 GO TO 900 B7500733^ ^ 415 675 IF(IDOLAR .EQ. 1) GO TO 890 B7500735^ ^ C ELSE GO TO ERROR PRINT B7500737^ ^ 416 GO TO 925 B7500739^ ^ C FOUND % - NO 'F' FIELD OPTION CHOSEN B7500741^ ^ 417 680 IF(PARAM .NE. 1) GO TO 905 B7500743^^ 418 NOF=1 B7500744^^ 419 LFSTR=LFSTR+1 B7500745^^ 420 CALL CCSMVA(N,2,1,LTFILB,LFSTR,1) B7500746^^ 421 LFSTR=LFSTR+1 B7500747^^ 422 GO TO 1120 B7500748^  ^ C FOUND A COMMA($2C) B7500754^ ^ 423 700 IF(IBYTE .EQ. 1) GO TO 910 B7500756^ ^ 424 IF(IBYTE .EQ. 2 .AND. PARAM .EQ. TYPE) GO TO 800 B7500758^^ 425 IF(IBYTE .EQ. 2) GO TO 720 B7500759^ ^ 426 IF(IBYTE .GE. 3 .AND. PARAM .EQ. TYPE) GO TO 900 B7500761^t FTN 3.3B (OPT = LPC) LTRBLD PAGE 18 DATE: 08/29/84 TIME: 2143 t^ 427 IF(IBYTE .EQ. 3) GO TO 740 B7500762^ ^ 428 IF(IBYTE .EQ. 4 .AND. PARAM. EQ. MSTRPO) GO TO 860 B7500764^^ 429 IF(IBYTE .EQ. 4 .AND. PARAM .NE. MSTRPO) GO TO 900 B7500765^ ^ 430 IF(IBYTE .EQ. 5 .AND. PARAM .EQ. MSTRPO) GO TO 880 B7500767^^ 431 IF(IBYTE .EQ. 5 .AND. PARAM .NE. MSTRPO) GO TO 900 B7500768^ ^ 432 GO TO 900 ***00770^   ^ C CONVERT SINGLE ASCII TO NUMERIC B7500774^  ^ 433 720 WKBUF(1)=ICCSAD(WKBUF(1))/10 B7500777^^ 434 GO TO 741 ***00778^ ^ C CONVERT 2 DIGIT NUMBER B7500780^ ^ 435 740 WKBUF(1)=ICCSAD(WKBUF(1)) B7500782^^ 436 741 GO TO (745, 750, 1000, 760, 755), PARAM ***00783^ ^ C LINE NUMBER ***00785^ ^ 437 745 IBYTE=0 B7500787^^ 438 PARAM=PARAM+1 B7500788^^ 439 IF(WKBUF(1).LT.1.OR.WKBUF(1).GT.24) GO TO 905 B7500789^^ 440 CALL CCSMVA(WKBUF(1), 2, 1, LTFILB, LFSTR+1, 1) B7500790^^ C ...UPDATE MAXLIN IF REQ'D. FOR LATER CHECK. ***00791^^ 441 IF (WKBUF(1) .GT. IMAXLN) IMAXLN = WKBUF(1) ***00792^^ 442 CALL CCSMVA(ZEROES, 1, 4, WKBUF, 1, 4) B7500793^^ 443 GO TO 1000 B7500794^ ^ C COLUMN NUMBER ***00796^ ^ 444 750 IBYTE=0 B7500798^^ 445 PARAM=PARAM+1 B7500799^^ 446 ISVCOL = WKBUF(1) ***00800^^ 447 IF(WKBUF(1).LT.MINLEN.OR.WKBUF(1).GT.MAXLEN-3) GO TO 920 B7500801^^ 448 CALL CCSMVA(WKBUF(1), 2, 1, LTFILB, LFSTR+2, 1) B7500802^^ 449 CALL CCSMVA(ZEROES, 1, 4, WKBUF, 1, 4) B7500803^^ 450 GO TO 1000 B7500804^ ^ C LENGTH ***00806^ ^ 451 755 IF(IDOLAR .EQ. 1) GO TO 890 B7500808^^ C ...(SET ILENTH FOR A TYPE.) ***00809^^ 452 ILENTH = WKBUF(1) ***00810^^ 453 IF (ITYPED .NE. 1) GO TO 757 ***00811^^ 454 IF (WKBUF(1) .LT. 1 .OR. WKBUF(1) .GT. 3) GO TO 900 ***00812^^ 455 ITEMP1 = WKBUF (1) ***00813^^ 456 ILENTH = DLENS(ITEMP1) ***00814^^ C ...IF FIELD EXCEEDS 54 CHAR/LINE, OUTPUT ERROR ***00815^t FTN 3.3B (OPT = LPC) LTRBLD PAGE 19 DATE: 08/29/84 TIME: 2143 t^ 457 757 IF (ISVCOL + ILENTH .GT. 55) GO TO 920 ***00816^^ 458 CALL CCSMVA(WKBUF(1), 2, 1, LTFILB, LFSTR+3, 1) B7500817^^ 459 GO TO 895 B7500818^  ^ C MSTRPO FIELD - TWO DIGIT B7500821^ ^ 460 760 IBYTE=0 B7500823^^ 461 PARAM=PARAM+1 B7500824^^ 462 CALL CCSMVA(WKBUF(1), 1, 2, LTFILB, LFSTR+5, 2) B7500825^^ 463 CALL CCSMVA(ZEROES, 1, 4, WKBUF, 1, 4) B7500826^^ 464 GO TO 1000 B7500827^ ^ C TYPE FIELD - IF 'A' FIELD TURN ON TYPE-A SWITCH B7500829^ ^ 465 780 IF(PARAM.NE.TYPE) GO TO 910 B7500831^^ 466 IF(N.EQ.A)ITYPEA=1 B7500832^^ 467 IF(N .EQ. DOLLAR) IDOLAR=1 B7500833^^ 468 CALL CCSPUT(N, LFSTR+4, LTFILB) B7500834^^ 469 GO TO 1000 B7500835^ ^ C FOUND A COMMA FOLLOWING A TYPE FIELD. INCREMENT PARAM COUNT B7500837^^ C AND IBYTE. B7500838^ ^ 470 800 PARAM=PARAM+1 B7500840^^ 471 IBYTE=0 B7500841^^ 472 GO TO 1000 B7500842^  ^ C IF TYPE FIELD = 'D' -- TURN ON D SWITCH. B7500845^ ^ 473 820 IF(PARAM.NE.TYPE) GO TO 910 B7500847^^ 474 IF(N.EQ.D)ITYPED=1 B7500848^^ 475 CALL CCSPUT(N, LFSTR+4, LTFILB) B7500849^^ 476 GO TO 1000 B7500850^    ^ C PARAM 4 HAS 3 DIGITS B7500855^ ^ 477 860 WKBUF(2)=ICCSAD(WKBUF(2))/10 B7500857^^ 478 WKBUF(1)=ICCSAD(WKBUF(1))*10+WKBUF(2) B7500858^^ 479 IF(PARAM .NE. 4) GO TO 900 B7500859^^ 480 865 CALL CCSMVA(WKBUF, 1, 2, LTFILB, LFSTR+5, 2) B7500860^ ^ C SET LETTER FILE POINTER TO ACCEPT NEW F DESC OR TEXT LINES. B7500862^ ^ 481 IF(IDOLAR .EQ. 1) GO TO 890 B7500864^^ 482 PARAM=PARAM+1 B7500865^^ 483 IBYTE=0 B7500866^^ 484 867 CALL CCSMVA(ZEROES, 1, 4, WKBUF, 1, 4) B7500867^^ 485 GO TO 1000 B7500868^ t FTN 3.3B (OPT = LPC) LTRBLD PAGE 20 DATE: 08/29/84 TIME: 2143 t^ C PARAM 4 HAS 4 DIGITS B7500870^ ^ 486 880 IF(WKBUF(1).GT.$3230.AND.WKBUF(2).GT.$3030) GO TO 900 B7500872^^ 487 WKBUF(2)=ICCSAD(WKBUF(2)) B7500873^^ 488 WKBUF(1)=ICCSAD(WKBUF(1))*100+WKBUF(2) B7500874^^ 489 885 CALL CCSMVA(WKBUF, 1, 2, LTFILB, LFSTR+5, 2) B7500875^^ 490 IF(IDOLAR .EQ. 1) GO TO 890 B7500876^^ 491 PARAM=PARAM+1 B7500877^^ 492 IBYTE=0 B7500878^^ 493 CALL CCSMVA(ZEROES, 1, 4, WKBUF, 1, 4) B7500879^^ 494 GO TO 1000 B7500880^ ^ C POSITION POINTER FOR NEW PARAMATER OR TEXT LINE. B7500882^ ^ 495 890 IF (IDOLAR .NE. 1) GO TO 895 ***00884^^ 496 CALL CCSMVA (NINE, 2, 1, LTFILB, LFSTR+3, 1) ***00885^^ C ...IF FIELD EXCEEDS 54 CHAR/LINE, OUTPUT ERROR. ***00886^^ 497 IF (ISVCOL + 11 .GT. 55) GO TO 920 ***00887^^ 498 895 LFSTR=LFSTR+7 B7500888^^ 499 CALL CCSMVA(ZEROES, 1, 4, WKBUF, 1, 4) B7500889^^ 500 GO TO 1120 B7500890^ ^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++B7500892^^ C FIELD DESCRIPTION ERROR ROUTINES: B7500893^^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++B7500894^ ^ C PARAMATER LENGTH IN ERROR. B7500896^ ^ 501 900 CALL CCSBLK(OBUF, PRTLEN) B7500898^^ 502 PARAM=PARAM+$30 B7500899^^ 503 CALL CCSMVA(PARAM,2,1,PAMERR,40,1) B7500900^^ 504 CALL CCSMVA(PAMERR,1,42,OBUF,10,42) B7500901^^ 505 PARAM=PARAM-$0030 B7500902^^ 506 GO TO 935 B7500903^ ^ C PARAMATER 1 ERROR. B7500905^ ^ 507 905 CALL CCSBLK(OBUF, PRTLEN) B7500907^^ 508 CALL CCSMVA(PARAM1,1,44,OBUF,10,44) B7500908^^ 509 GO TO 935 B7500909^ ^ C ILLEGAL CHARACTER IN PARAMATER FIELD. B7500911^ ^ 510 910 CALL CCSBLK(OBUF, PRTLEN) B7500913^^ 511 CALL CCSMVA(N,2,1,PARAME,28,1) B7500914^^ 512 CALL CCSMVA(PARAME,1,30,OBUF,10,30) B7500915^^ 513 GO TO 935 B7500916^ ^ C PARAMATER 2 ERROR. B7500918^ ^ 514 920 CALL CCSBLK(OBUF, PRTLEN) B7500920^^ 515 CALL CCSMVA(PARAM2, 1, 44, OBUF, 10, 44) ***00921^^ 516 GO TO 935 B7500922^ t FTN 3.3B (OPT = LPC) LTRBLD PAGE 21 DATE: 08/29/84 TIME: 2143 t^ C PARAMATER 5 ERROR. B7500924^ ^ 517 925 CALL CCSBLK(OBUF, PRTLEN) B7500926^^ 518 CALL CCSMVA(PARAM5,1,48,OBUF,10,48) B7500927^^ 519 GO TO 935 B7500928^ ^ C BLANK ERROR. B7500930^ ^ 520 930 CALL CCSBLK(OBUF, PRTLEN) B7500932^^ 521 PARAM=PARAM+$30 B7500933^^ 522 CALL CCSMVA(PARAM,2,1,BLNKER,39,1) B7500934^^ 523 CALL CCSMVA(BLNKER,1,42,OBUF,10,42) B7500935^^ 524 PARAM=PARAM-$30 B7500936^^ 525 GO TO 935 B7500937^ ^ C WRITE PARAMATER ERRORS. B7500939^ ^ 526 935 IRCNT=IRCNT+1 B7500941^^ 527 OBUF(1)=SNGLSP B7500942^^ 528 FCOUNT=FCOUNT+1 B7500943^^ 529 ASSIGN 400 TO ICOMP B7500944^^ 530 CALL FWRITE(PRT, OBUF, PRTLEN, ICOMP, IFLAG, ITEMP) B7500945^^ 531 CALL DISP B7500946^ ^ 532 1000 CONTINUE B7500948^  ^ C IF FIELD DESCRIPTION RECORDS LESS THEN 9 GO TO 400. B7500951^^ C IF NO 'F' FIELD OPTION USED - GO TO 1200 B7500952^ ^ 533 1120 IF(NOF .EQ. 1) GO TO 1210 B7500954^^ 534 FCOUNT=FCOUNT+1 B7500955^^ 535 IF(FCOUNT .LE. FMAX) GO TO 400 B7500956^  ^ 536 1140 CALL CCSBLK(OBUF,PRTLEN) B7500959^^ 537 OBUF(1)=SNGLSP B7500960^^ 538 IRCNT=IRCNT+1 B7500961^^ 539 CALL CCSMVA(FMAXER,1,38,OBUF,10,38) B7500962^^ 540 ASSIGN 1200 TO ICOMP B7500963^^ 541 CALL FWRITE(PRT, OBUF, PRTLEN, ICOMP, IFLAG, ITEMP) B7500964^^ 542 CALL DISP B7500965^t FTN 3.3B (OPT = LPC) LTRBLD PAGE 22 DATE: 08/29/84 TIME: 2143 t ^ C***********************************************************************B7500968^^ C B7500969^^ C READ A RECORD AND SEARCH FOR VALID TEXT LINES. B7500970^^ C B7500971^^ C***********************************************************************B7500972^ ^ C PROCESS RECORD CURRENTLY IN BUFFER B7500974^ ^ 543 1200 SALSW=1 B7500976^^ 544 GO TO 1230 B7500977^ ^ C GET NEXT RECORD AND PLACE IN BUFFER B7500979^  ^ 545 1210 CALL CCSBLK(INBUF, 80) B7500982^^ 546 SALSW=0 B7500983^^ 547 1220 CALL GETS(REQBLD, INBUF, LDKEY, ISTAT) B7500984^^ 548 IF(ISTAT .GE. 0) GO TO 1230 B7500985^^ 549 CALL FILERR(INBUF, 14, ISTAT, LU) B7500986^^ 550 GO TO 2010 B7500987^  ^ C CHECK FOR SYSTEM DELETE CODE B7500990^ ^ 551 1230 IF(INBUF(1).EQ.ISDEL) GO TO 1210 B7500992^  ^ C CHECK FOR END RECORD B7500995^ ^ 552 1236 TXTLIN = TXTLIN + 1 ***00997^^ 553 CALL CCSCST (INBUF, 1, 3, IEND, 1, 3, NCOMP) ***00998^^ 554 IF(NCOMP.EQ.0) GO TO 1245 B7500999^^ 555 NUMSW=0 B7501000^^ 556 ISTAR=0 B7501001^^ 557 IENDSW=0 B7501002^ ^ C MOVE LINE TO ECHO PRINT BUFFER+++++++++++++++++++++++++++++++++B7501004^ ^ 558 CALL CCSBLK(PRTBUF, 132) B7501006^^ 559 CALL CCSMVA(INBUF,1,80,PRTBUF,5,80) B7501007^^ 560 PRTBUF(1)=SNGLSP B7501008^^ 561 ASSIGN 1237 TO ICOMP B7501009^^ 562 CALL FWRITE(PRT,PRTBUF,PRTLEN,ICOMP,IFLAG,ITEMP) B7501010^^ 563 CALL DISP B7501011^   ^ C CHECK FOR LINE OVERFLOW B7501015^ ^ 564 1237 IF(LCOUNT.GT.MXLINE) GO TO 1450 B7501017^ ^ C CHECK FOR *A, - INDICATES NO END RECORD HAS BEEN READ B7501019^^ C PRIOR TO START OF NEW LETTER. B7501020^t FTN 3.3B (OPT = LPC) LTRBLD PAGE 23 DATE: 08/29/84 TIME: 2143 t ^ 565 1240 CALL CCSCST(INBUF,1,3,ACODE,1,3,NCOMP) B7501022^^ 566 IF(NCOMP.NE.0) GO TO 1260 B7501023^^ 567 OBUF(1)=SNGLSP B7501024^^ 568 CALL CCSBLK(OBUF,PRTLEN) B7501025^^ 569 CALL CCSMVA(INBUF,1,3,ENDERR,23,3) B7501026^^ 570 CALL CCSMVA(ENDERR,1,28,OBUF,10,28) B7501027^^ 571 IRCNT=IRCNT+1 B7501028^^ 572 ASSIGN 1241 TO ICOMP ***01029^^ 573 CALL FWRITE(PRT, OBUF, PRTLEN, ICOMP, IFLAG, ITEMP) B7501030^^ 574 CALL DISP B7501031^^ C ...CHECK FOR LINE NO. GT MAX. LINE IN LETTER. ***01032^^ 575 1241 IF (IMAXLN .LE. TXTLIN-1) GO TO 135 ***01033^^ 576 ASSIGN 135 TO IRTN ***01034^^ 577 GO TO 1252 ***01035^  ^ C IF END RECORD - MOVE END TO LTRFILE - GO TO PRINT ROUTINE. B7501038^ ^ 578 1245 CALL CCSMVA(INBUF,1,3,LTFILB,LFSTR,3) B7501040^^ 579 CALL CCSBLK(PRTBUF,PRTLEN) B7501041^^ 580 PRTBUF(1)=SNGLSP B7501042^^ 581 CALL CCSMVA(INBUF,1,80,PRTBUF,5,80) B7501043^^ 582 ASSIGN 1250 TO ICOMP B7501044^^ 583 CALL FWRITE(PRT,PRTBUF,PRTLEN,ICOMP,IFLAG,ITEMP) B7501045^^ 584 CALL DISP B7501046^^ C ...CHECK FOR LINE NO. GT MAX. LINE IN LETTER. ***01047^^ 585 1250 IF (IMAXLN .GT. TXTLIN-1) GO TO 1251 ***01048^^ 586 LFSTR=LFSTR+3 B7501049^^ 587 NSWICH=NSWICH+1 B7501050^^ 588 IF(NSWICH.EQ.2) GO TO 1600 B7501051^^ 589 GO TO 1500 B7501052^^ 590 1251 ASSIGN 130 TO IRTN ***01053^^ C ...COMMON LOGIC FOR *A AND END FOR LINE NO. (IN F STATEMENT) ***01054^^ C ... GT MAX. LINE IN LETTER. ***01055^^ C ...OUTPUT ERROR MSG. ***01056^^ 591 1252 CALL CCSBLK (OBUF, PRTLEN) ***01057^^ 592 CALL CCSMVA (MAXLIN, 1, 44, OBUF, 10, 44) ***01058^^ 593 ASSIGN 1254 TO ICOMP ***01059^^ 594 CALL FWRITE (PRT, OBUF, PRTLEN, ICOMP, IFLAG, ITEMP) ***01060^^ 595 CALL DISP ***01061^^ C ...FOR *A, RETURN AFTER READ OF RECORD. ***01062^^ C ...FOR END, RETURN TO READ NEXT RECORD. ***01063^^ 596 1254 GO TO IRTN ***01064^t FTN 3.3B (OPT = LPC) LTRBLD PAGE 24 DATE: 08/29/84 TIME: 2143 t  ^ C CHECK FOR VALID CARRIAGE CONTROL RANGE OF 1-4. B7501068^^ C **********SEARCH IS RIGHT TO LEFT*********************** B7501069^ ^ 597 1260 DO 1420 I= 75, 1, -1 ***01071^^ 598 CALL CCSGET(INBUF, I, N) B7501072^^ 599 1265 IF(N .EQ. BLANK) GO TO 1420 B7501073^^ 600 IF (I .GT. 57) GO TO 1440 ***01074^^ 601 IF(N.GE.$31.AND.N.LE.$34) GO TO 1290 B7501075^^ 602 IF(N .EQ. STAR) GO TO 1350 B7501076^^ 603 IF(N .EQ. EACH) GO TO 1380 B7501077^^ 604 IF(N.NE.BLANK) GO TO 1300 B7501078^ ^ C FOUND CARRIAGE CONTROL OR SALUTATION CODE B7501080^ ^ 605 1290 IF(NUMSW.EQ.1) GO TO 1420 B7501082^^ 606 L=ICCSAD(N) B7501083^^ 607 ENDPOS=I B7501084^^ 608 IENDSW=1 B7501085^^ 609 NUMSW=1 B7501086^^ 610 GO TO 1420 B7501087^ ^ C CHECK FOR INVALID CARRIAGE CONTROL B7501089^^ 611 1300 IF(ISTAR.EQ.1.AND.NUMSW.EQ.1) GO TO 1440 B7501090^^ 612 IF(ISTAR.EQ.1.AND.NUMSW.EQ.0) GO TO 1440 B7501091^^ 613 IF(ISTAR.EQ.0.AND.NUMSW.EQ.0) GO TO 1390 B7501092^^ 614 GO TO 1420 B7501093^ ^ C FOUND A * - SEARCH IS RIGHT TO LEFT, IF WE HAVE NOT FOUND A B7501095^^ C GO TO 1360 AND MOVE IN A DEFAULT VALUE OF 1. B7501096^ ^ 615 1350 IF(NUMSW .NE. 1) GO TO 1360 B7501098^^ 616 GO TO 1370 B7501099^ ^ C MOVE IN DEFAULT VALUE FOR CARRIAGE CONTROL - NO CONTROL INDICATB7501101^ ^ 617 1360 ENDPOS=I B7501103^^ 618 IF(ENDPOS .EQ. 57) GO TO 1440 B7501104^^ 619 ENDPOS=I+1 B7501105^^ 620 CALL CCSMVA(LINCTL, 1, 1, INBUF, ENDPOS, 1) B7501106^^ 621 L=1 B7501107^^ 622 NUMSW=1 B7501108^ ^ C INCREMENT ISTAR - CHECK IF ISTAR=2. B7501110^ ^ 623 1370 ISTAR=ISTAR+1 B7501112^^ 624 IF(ISTAR .EQ. 2 .AND. SALSW .EQ. 0) GO TO 1425 B7501113^^ 625 GO TO 1420 B7501114^ ^ C FOUND CODE FOR SALUTATION LINE -@ B7501116^ ^ 626 1380 CALL CCSGET(INBUF, I+1, N) B7501118^^ 627 IF (N .GT. $30 .AND. N .LT. $33) GO TO 1382 B7501119^t FTN 3.3B (OPT = LPC) LTRBLD PAGE 25 DATE: 08/29/84 TIME: 2143 t^ 628 GO TO 1440 B7501120^^ 629 1382 SALNUM=1 B7501121^^ 630 CALL CCSCST(INBUF, I+2, 1, STAR, 2, 1, NCOMP) B7501122^^ 631 IF(NCOMP .EQ. 0) GO TO 1385 B7501123^^ 632 GO TO 1386 B7501124^ ^ 633 1385 CALL CCSMVA(INBUF, I+2, 3, WKAREA, 1, 3) B7501126^^ 634 CALL CCSMVA(WKAREA, 1, 3, INBUF, I+3, 3) B7501127^^ 635 CALL CCSMVA(BLANK, 2, 1, INBUF, I+2, 1) B7501128^^ 636 ENDPOS=ENDPOS+1 B7501129^ ^ C FOUND @ CHECK FOR CORRECT CARRAIGE CONTROL B7501131^ ^ 637 1386 IF(NUMSW .EQ. 0 .AND. ISTAR .EQ. 0) GO TO 1390 B7501133^^ 638 IF(NUMSW .EQ. 0 .AND. ISTAR .EQ. 2) GO TO 1360 B7501134^^ 639 IF(ISTAR .NE. 2) GO TO 1440 B7501135^^ 640 GO TO 1425 B7501136^ ^ C ...FOUND NO CARRIAGE CONTROL CHARACTERS. ***01138^^ C ... DEFAULT TO **1. ***01139^^ 641 1390 ENDPOS = I ***01140^^ 642 IF(ENDPOS .GT. 54) GO TO 1440 B7501141^^ 643 ENDPOS=ENDPOS+1 B7501142^^ 644 CALL CCSMVA(CARCTL, 1, 3, INBUF, ENDPOS, 3) B7501143^^ 645 ENDPOS=ENDPOS+2 B7501144^^ 646 L=1 B7501145^^ 647 NUMSW=1 B7501146^^ 648 GO TO 1425 B7501147^ ^ 649 1420 CONTINUE B7501149^ ^ 650 IF(ISTAR.NE.2) GO TO 1440 B7501151^ ^ 651 1425 CALL CCSMVA(INBUF, 1, ENDPOS, LTFILB, LFSTR, ENDPOS) B7501153^^ 652 LCOUNT = LCOUNT + L B7501154^^ 653 LFSTR=LFSTR+ENDPOS B7501155^^ 654 GO TO 1210 B7501156^ ^ C TEXT ERROR ROUTINE. B7501158^ ^ 655 1440 CALL CCSBLK(OBUF,132) B7501160^^ 656 CALL CCSMVA(TEXT1,1,50,OBUF,10,50) B7501161^^ 657 IRCNT=IRCNT+1 B7501162^^ 658 ITEXTE=1 B7501163^^ 659 GO TO 1460 B7501164^  ^ C TEXT LINES EXCEED MAXIMUM ALLOWED. B7501167^ ^ 660 1450 CALL CCSBLK(OBUF,132) B7501169^^ 661 CALL CCSMVA(TEXT3,1,26,OBUF,10,26) B7501170^^ 662 LCOUNT=0 B7501171^^ 663 ITEXTE=2 B7501172^^ 664 IRCNT=IRCNT+1 B7501173^t FTN 3.3B (OPT = LPC) LTRBLD PAGE 26 DATE: 08/29/84 TIME: 2143 t^ 665 GO TO 1460 B7501174^ ^ C PRINT TEXT ERROR B7501176^ ^ 666 1460 ASSIGN 1210 TO ICOMP B7501178^^ 667 CALL FWRITE(PRT,OBUF,PRTLEN,ICOMP,IFLAG,ITEMP) B7501179^^ 668 CALL DISP B7501180^t FTN 3.3B (OPT = LPC) LTRBLD PAGE 27 DATE: 08/29/84 TIME: 2143 t ^ C***********************************************************************B7501183^^ C B7501184^^ C WRITE RECORD TO LETTER FILE B7501185^^ C B7501186^^ C***********************************************************************B7501187^ ^ 669 1500 IF(LTRCNT.GT.MXNUML)GO TO 1570 ********^^ 670 IF(IRCNT.NE.0) GO TO 130 B7501190^^ 671 CALL WRITER(REQBLF,LTFILB,SAVKEY,ISTAT) B7501191^^ 670 IF(IRCNT.NE.0) GO TO 130 B7501190^^ 671 CALL WRITER(REQBLF,LTFILB,SAVKEY,ISTAT) B7501191^^ 672 IF(AND(ISTAT,$8010).EQ.$8010) GO TO 1520 B7501192^^ 673 IF(ISTAT .GE. 0) GO TO 1550 B7501193^^ 674 CALL FILERR(IDATLF,12,ISTAT,LU) B7501194^^ 675 GO TO 2010 B7501195^ ^ C DUPLICATE KEY ERROR B7501197^ ^ 676 1520 CALL CCSBLK(OBUF,132) B7501199^^ 677 OBUF(1)=SNGLSP B7501200^^ 678 CALL CCSMVA(SAVKEY,1,2,DUPKEY,31,2) B7501201^^ 679 CALL CCSMVA(DUPKEY,1,48,OBUF,10,48) B7501202^^ 680 ASSIGN 130 TO ICOMP B7501203^^ 681 CALL FWRITE(PRT, OBUF, PRTLEN, ICOMP, IFLAG, ITEMP) B7501204^^ 682 CALL DISP B7501205^ ^ C SUCCESFUL WRITE TO FILE / INCREMENT LETTER COUNT. B7501207^ ^ 683 1550 LTRCNT=LTRCNT+1 B7501209^ ^ 684 1553 CALL CCSBLK(PRTBUF, PRTLEN) B7501211^^ 685 CALL CCSMVA(TOPPAG, 1, 2, PRTBUF, 1, 2) B7501212^^ 686 CALL CCSMVA(HDR,1,40,PRTBUF,5,40) B7501213^^ 687 ASSIGN 1554 TO ICOMP B7501214^^ 688 CALL FWRITE(PRT,PRTBUF,PRTLEN,ICOMP, IFLAG, ITEMP) B7501215^^ 689 CALL DISP B7501216^^ 690 1554 CALL CCSBLK(PRTBUF,PRTLEN) B7501217^^ 691 CALL CCSMVA(SNGLSP, 1, 2, PRTBUF, 1, 2) B7501218^^ 692 CALL CCSMVA(HDR,41,40,PRTBUF,5,40) B7501219^^ 693 CALL CCSMVA(HD2A, 1, 30, PRTBUF, 51, 30) B7501220^^ 694 CALL CCSMVA(HD2B,1,4,PRTBUF,75,4) ********^ ^ C CONVERT PAGE NUMBER B7501223^^ 695 PAGCNT=PAGCNT+1 B7501224^^ 696 A1=PAGCNT/$3E8 B7501225^^ 697 RE=PAGCNT-(A1*$3E8) B7501226^^ 698 A2=RE/$64 B7501227^^ 699 RE=RE-(A2*$64) B7501228^^ 700 A3=RE/$A B7501229^^ 701 RE=RE-(A3*$A) B7501230^^ 702 A4=RE B7501231^ ^ C MOVE PAGE COUNT TO PRINT B7501233^ ^ 703 1555 PAGOUT(2)=((A3+$30)*$100)+(A4+$30) B7501235^t FTN 3.3B (OPT = LPC) LTRBLD PAGE 28 DATE: 08/29/84 TIME: 2143 t^ 704 PAGOUT(1)=((A1+$30)*$100)+(A2+$30) B7501236^ ^ C EDIT PAGE COUNT B7501238^ ^ 705 DO 1556 IN=1,3 B7501240^^ 706 CALL CCSCST(PAGOUT,IN,1,ZERO,1,1,NCOMP) B7501241^^ 707 IF(NCOMP.NE.0) GO TO 1557 B7501242^^ 708 CALL CCSMVA(BLANK,2,1,PAGOUT,IN,1) B7501243^^ 709 1556 CONTINUE B7501244^^ 710 1557 CALL CCSMVA(PAGOUT,1,4,PRTBUF,80,4) ********^^ 711 ASSIGN 1558 TO ICOMP B7501246^^ 712 CALL FWRITE(PRT,PRTBUF,PRTLEN,ICOMP,IFLAG,ITEMP) B7501247^^ 713 CALL DISP B7501248^ ^ 714 1558 CALL CCSBLK(PRTBUF,PRTLEN) B7501250^^ 715 CALL CCSMVA(SNGLSP, 1, 2, PRTBUF, 1, 2) B7501251^^ 716 CALL CCSMVA(HDR,81,40,PRTBUF,5,40) B7501252^^ 717 CALL CCSMVA(HD3A, 1, 6, PRTBUF, 51, 6) B7501253^^ 718 CALL LTRDTE(DT,PRTBUF, 60, 1) B7501254^^ 719 ASSIGN 1559 TO ICOMP B7501255^^ 720 CALL FWRITE(PRT,PRTBUF,PRTLEN,ICOMP,IFLAG,ITEMP) B7501256^^ 721 CALL DISP B7501257^ ^ 722 1559 CONTINUE B7501259^ ^ C PLACE LETTER NUMBER IN LETTER # ARRAY FOR SORT ********^ ^ 723 LTRS(LTRCNT) = SAVKEY ********^ ^ C PRINT THE LETTER CURRENTLY IN LTFILB BUFFER B7501276^ ^ 724 1565 IF(IRCNT.GT.0) GO TO 130 B7501278^^ 725 CALL LTPRNT(DT,LTFILB) B7501279^^ 726 GO TO 130 B7501280^ ^ C NUMBER OF LETTERS EXCEED CURRENT MAXIMUM - PRINT ERROR MSG B7501282^ ^ 727 1570 CALL CCSBLK(OBUF, PRTLEN) B7501284^^ 728 OBUF(1)=SNGLSP B7501285^^ 729 CALL CCSMVA(TEXT2,1,28,OBUF,10,28) B7501286^^ 730 ASSIGN 1600 TO ICOMP B7501287^^ 731 CALL FWRITE(PRT,OBUF,132,ICOMP,IFLAG,ITEMP) B7501288^^ 732 CALL DISP B7501289^ ^ C***********************************************************************B7501291^^ C B7501292^^ C CLOSE FILE ROUTINES B7501293^^ C B7501294^^ C***********************************************************************B7501295^ ^ C COMPLETE UTILITY RECORDS LTR1 THRU LTR4. ********^ ^ 733 1600 CONTINUE ********^ t FTN 3.3B (OPT = LPC) LTRBLD PAGE 29 DATE: 08/29/84 TIME: 2143 t^ C SORT LETTER NUMBERS INTO ASCENDING ORDER. ********^^ C SORT IS A BUBBLE SORT. ********^ ^ 734 K = 1 ********^^ 735 MELM=LTRCNT-1 ********^^ 736 IF (MELM.LE.1) GO TO 1610 ********^^ 737 DO 1610 I=1,MELM ********^ ^ 738 IF(LTRS(I).LT.LTRS(I+1))GO TO 1615 ********^^ 739 TEMP = LTRS(I) ********^^ 740 LTRS(I) = LTRS(I+1) ********^^ 741 LTRS(I+1) = TEMP ********^^ 742 DO 1605 J=I,2,-K ********^^ 743 IF(LTRS(J).GT.LTRS(J-1))GO TO 1605 ********^^ 744 TEMP = LTRS(J) ********^^ 745 LTRS(J) = LTRS(J-1) ********^^ 746 LTRS(J-1) = TEMP ********^^ 747 1605 CONTINUE ********^^ 748 1610 CONTINUE ********^^ C *** SORT COMPLETE *** ********^  ^ 749 1615 K = LTRCNT ********^^ 750 1620 DO 1800 I = 0,NLRC ********^^ 751 J = 50 ********^^ 752 IF( K.LT.26 ) J = K*2 ********^^ 753 K2 = I*25+1 ********^ ^ 754 CALL CCSMVA( LTREC1,1,70,LRCBF1,1,80 ) ********^^ 755 CALL CCSMVA( LTRS(K2),1,J,LRCBF1,5,J ) ********^^ 756 CALL CCSMVA( LKEY1, 1, 4, LKEY2, 1,4 ) ********^^ 757 LKEY2(2) = LKEY2(2)+I ********^^ 758 CALL CCSMVA( LKEY2, 1, 4, LRCBF1,1,4 ) ********^^ 759 CALL CCSMVA( LRCBF1,1,80, OBUF ,1,80 ) ********^^ 760 K = K-25 ********^^ 761 IF (K.LT.0) K=0 ********^^ 762 1650 CONTINUE ********^^ 763 CALL WRITER ( REQBUT,LRCBF1,LKEY2,ISTAT ) ********^^ 764 IF (AND(ISTAT,$10).EQ.$10) GO TO 1675 ********^^ 765 IF (ISTAT.GE.0) GO TO 1750 ********^^ 766 CALL FILERR ( IDATUT,12,ISTAT,LU ) ********^^ 767 GO TO 2010 ********^ ^ C GET LTRX RECORD FROM UTILITY FILE. ********^ ^ 768 1675 CALL READR(REQBUT, LRCBF1, LKEY2, ISTAT) ********^^ 769 IF(AND(ISTAT,$200).EQ.$200) GO TO 1860 ********^^ 770 IF(AND(ISTAT,$100).EQ.$100) GO TO 1860 ********^^ 771 1677 IF(ISTAT .GE. 0) GO TO 1680 ********^^ 772 CALL FILERR(LRCBF1, 13, ISTAT, LU) ********^^ 773 GO TO 2010 ********^ ^ C MOVE UPDATE INFO TO LTRX RECORD BUFFER. ********^ t FTN 3.3B (OPT = LPC) LTRBLD PAGE 30 DATE: 08/29/84 TIME: 2143 t^ 774 1680 CALL CCSMVA( OBUF, 1,80, LRCBF1, 1,80 ) ********^  ^ C REWRITE LTRX TO UTILITY FILE ********^ ^ 775 1700 CALL UPDREC(REQBUT, LRCBF1, ISTAT) ********^^ 776 IF(ISTAT .GE. 0) GO TO 1750 ********^^ 777 CALL FILERR(LRCBF1, 15, ISTAT, LU) ********^^ 778 GO TO 2010 ********^ ^ C MOVE LTR1 TO ECHO PRINT AND PRINT AFTER ADVANCING ********^^ C TO TOP OF PAGE.++++++++++++++++++++++++++++++++++++++++++++++++********^ ^ 779 1750 CALL CCSBLK(PRTBUF,PRTLEN) ********^^ 780 PRTBUF(1)=DBLSPA ********^^ 781 IF(I.EQ.0) PRTBUF(1)=TOPPAG ********^^ 782 CALL CCSMVA(LRCBF1,1,60,PRTBUF,5,60) ********^^ 783 ASSIGN 1800 TO ICOMP ********^^ 784 CALL FWRITE(PRT,PRTBUF,PRTLEN,ICOMP,IFLAG,ITEMP) ********^^ 785 CALL DISP ********^ ^ 786 1800 CONTINUE ********^^ 787 GO TO 2010 ********^ ^ C LTRX RECORD WAS NOT FOUND PRINT MESSAGE ********^^ C WE SHOULD NEVER GET HERE BECAUSE OF WRITER. ********^ ^ 788 1860 CALL CCSBLK(OBUF,PRTLEN) ********^^ 789 OBUF(1) = DBLSPA ********^^ 790 IF(I.EQ.0) OBUF(1) = TOPPAG ********^^ 791 CALL CCSMVA(LKEY2,4,1,UTFERR,21,1) ********^^ 792 1870 CALL CCSMVA(UTFERR,1,38,OBUF,10,38) ********^^ 793 IF(I.LT.NLRC) ASSIGN 1800 TO ICOMP ********^^ 794 IF(I.EQ.NLRC) ASSIGN 2010 TO ICOMP ********^^ 795 CALL FWRITE(PRT,OBUF,PRTLEN,ICOMP,IFLAG,ITEMP) B7501380^^ 796 CALL DISP B7501381^ ^ C CLOSE FILES B7501383^ ^ 797 2010 CALL CLOSFL(REQBLD,ISTAT) B7501385^^ 798 CALL CLOSFL(REQBLF, ISTAT) B7501386^^ 799 CALL CLOSFL(REQBUT, ISTAT) B7501387^ ^ 800 2020 CALL PGMOUT B7501389^^ 801 END B7501390^t FTN 3.3B (OPT = LPC) LTRBLD PAGE 31 DATE: 08/29/84 TIME: 2143 t  PROGRAM LENGTH $15A6 ( 5542)   EXTERNALS 2 Q8STP FMRDEL PGMIN CCSCST CCSMVA OPENFL FILERR 22 UTHEAD CLEAR GETS CCSBLK FWRITE DISP LTRDTE 22 CCSGET CCSPUT READR ICCSAD WRITER LTPRNT UPDREC 2 CLOSFL PGMOUT  t FTN 3.3B (OPT = LPC) LTRBLD PAGE 32 DATE: 08/29/84 TIME: 2143 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < & 8010 (-32751) 0818 672,672&€ 0001 (1) 0002 13,14,15,16,28,32,88,112,114,115,116,117,130,146,147,148,158,160,161,166,168,169,170,179,180,181,€€ 183,185,190,192,193,197,199,201,202,203,208,213,214,219,220,221,222,224,227,229,231,232,233,239, €€ 240,250,251,256,261,262,267,269,270,282,286,288,289,290,295,296,297,298,303,304,305,309,310,311, €€ 316,317,318,319,323,324,325,326,327,328,339,340,342,351,352,353,354,357,359,366,367,368,370,371, €€ 375,381,384,386,392,393,395,397,398,403,404,406,411,415,417,418,419,420,421,423,433,435,438,439, €€ 440,441,442,445,446,447,448,449,451,452,453,454,455,458,461,462,463,466,467,470,474,478,480,481, €€ 482,484,486,488,489,490,491,493,495,496,499,503,504,508,511,512,515,518,522,523,526,527,528,533, €€ 534,537,538,539,543,551,552,553,559,560,565,567,569,570,571,575,578,580,581,585,587,592,597,605, €€ 608,609,611,612,615,619,620,621,622,623,626,629,630,633,634,635,636,643,644,646,647,651,656,657, €€ 658,661,664,677,678,679,683,685,686,691,693,694,695,704,705,706,708,710,715,717,718,728,729,734, €z 735,736,737,738,740,741,743,745,746,753,754,755,756,758,759,774,780,781,782,789,790,791,792z€ 0002 (2) 07D5 112,160,166,178,183,190,204,239,240,243,250,256,257,268,323,339,342,352,357,381,385,386,392,393, €€ 396,397,398,407,412,420,424,425,440,448,458,462,477,478,480,486,487,488,489,496,503,511,522,588, €f 624,630,633,635,638,639,645,650,663,678,685,691,703,708,715,742,752,757f€ 0003 (3) 07D8 114,115,116,121,125,134,138,180,197,202,208,220,224,231,241,343,344,348,378,392,407,413,426,427, €R 447,454,458,496,553,565,569,578,586,633,634,644,705R€ 0004 (4) 07E7 169,169,185,268,326,344,345,346,347,384,393,395,400,408,428,429,442,449,463,468,475,479,484,493, €6 499,694,710,756,758,7916~ 0005 (5) 07D4 111,161,167,191,202,214,251,262,290,305,398,409,430,431,462,480,489,559,581,686,692,716,755,782~F 0006 (6) 07D9 114,115,116,192,349,353,359,367,369,717F& 0007 (7) 080C 395,498&6 0008 (8) 07D6 112,114,115,116,117,3796€ 000A (10) 07EB 175,176,221,232,269,297,317,340,368,433,477,478,504,508,512,515,518,523,539,570,592,656,661,679, €. 700,701,729,792.* 000B (11) 080A 384,391,497*& 000C (12) 0819 674,766&& 000D (13) 0804 363,772&* 000E (14) 07DF 144,280,549*& 000F (15) 0809 381,777&* 0010 (16) 0800 327,375,764*" 0015 (21) 0821 791"* 0017 (23) 07F5 231,296,569** 0018 (24) 07DD 130,317,439** 0019 (25) 07F3 220,753,760*. 001A (26) 07FD 297,297,661,752.6 001C (28) 07F6 232,232,339,511,570,7296: 001E (30) 07E5 168,168,221,340,367,512,693:" 001F (31) 081A 678"" 0022 (34) 07F4 224"* 0026 (38) 0812 539,539,792*" 0027 (39) 0811 522"> 0028 (40) 07E2 161,161,167,191,503,686,692,716>* 0029 (41) 07E4 167,310,692** 002A (42) 0810 504,504,523*2 002C (44) 07FA 268,356,508,515,5922t FTN 3.3B (OPT = LPC) LTRBLD PAGE 33 DATE: 08/29/84 TIME: 2143 t& 002F (47) 07FB 269,269&V 0030 (48) 07EC 178,178,179,242,330,502,505,518,521,524,627,679,703,704V. 0032 (50) 0805 368,368,656,751.2 0033 (51) 07E6 168,192,627,693,7172* 003C (60) 07F1 193,718,782*" 0046 (70) 0820 754"* 004B (75) 07E8 169,597,694*V 0050 (80) 07EF 185,214,251,262,274,290,305,545,559,581,710,754,759,774V& 0051 (81) 07F0 191,716&" 0055 (85) 07FE 305": 0064 (100) 07EA 173,174,386,397,488,698,699:f 0084 (132) 07F2 200,211,225,259,272,276,294,300,315,321,338,365,373,558,655,660,676,731fB 0100 (256) 07DE 142,142,178,179,245,278,703,704,770B* 0200 (512) 0803 361,361,769*R 03E8 (1000) 07E9 171,172,402,443,450,464,469,472,476,485,494,696,697R" 05E8 (1512) 07F7 237"" 3000 (12288) 07F9 245"" 3030 (12336) 080F 486"" 3230 (12848) 080E 486"   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < 4 A INTEGER 0586 16,19,333,381,383,4664: A1 INTEGER 05B8 37,171,172,179,696,697,704 :: A2 INTEGER 05B9 37,173,174,179,698,699,704 :: A3 INTEGER 05BA 37,175,176,178,700,701,703 :2 A4 INTEGER 05BB 37,177,178,702,703 2, ACODE INTEGER 0587 16,19,208,565,, AERROR INTEGER 05ED 52,54,220,221,: AND INTR.FN. 7FFF 142,278,361,672,764,769,770:( ARAPNT INTEGER 058F 20,22,147(@ BLANK INTEGER 0589 16,19,183,243,337,599,604,635,708@, BLNKER INTEGER 05FC 54,56,522,523,( CARCTL INTEGER 0591 20,22,644($ COLNUM INTEGER 058A 16,19$$ COMAER INTEGER 0611 56,58$( COMMA INTEGER 058B 16,19,332(& CRCTL2 INTEGER 0787 100,102&0 D INTEGER 0593 22,24,334,377,4740( DATLD INTEGER 0582 9,12,117 (< DBLSPA INTEGER 05B7 37,39,213,219,250,261,780,789<* DLENS INTEGER 07CE 107,109,456*0 DOLLAR INTEGER 05B3 32,35,336,389,46704 DT INTEGER 058C 16,20,127,193,718,7254, DUPKEY INTEGER 0626 58,60,678,679,( EACH INTEGER 0590 20,22,603(4 ENDERR INTEGER 063E 60,62,231,232,569,5704V ENDPOS INTEGER 05BE 39,607,617,618,619,620,636,641,642,643,644,645,651,653 V( EQERR INTEGER 064C 62,64,317(( EQSIGN INTEGER 0594 22,24,313(t FTN 3.3B (OPT = LPC) LTRBLD PAGE 34 DATE: 08/29/84 TIME: 2143 t( F INTEGER 0595 22,24,286(B FCOUNT INTEGER 05BF 39,153,288,302,318,371,528,534,535 B, FERROR INTEGER 066B 66,68,296,297,, FMAX INTEGER 0596 22,24,302,535,( FMAXER INTEGER 0658 64,66,539($ HD1 INTEGER 0599 24,26$$ HD2 INTEGER 059B 24,26$, HD2A INTEGER 0770 94,96,168,693,, HD2B INTEGER 077F 96,98,169,694,$ HD3 INTEGER 059D 24,26$. HD3A INTEGER 0781 98,100,192,717 .* HDBUF INTEGER 0184 5,7,359,367*> HDR INTEGER 078E 104,127,161,167,191,686,692,716>€ I INTEGER 07ED 179,181,183,240,241,243,247,310,311,312,327,329,350,597,598,600,607,617,619,626,630,633,634,635, €V 641,737,738,739,740,741,742,750,753,757,781,790,793,794V€ IBYTE INTEGER 07FC 274,275,328,342,343,344,345,346,347,400,401,406,407,408,409,411,412,413,423,424,425,426,427,428, €B 429,430,431,437,444,460,471,483,492B& ICM INTEGER 07D7 112,113&6 ICNT INTEGER 07FF 311,312,325,329,350,3556€ ICOMP INTEGER 07E3 161,163,186,187,194,195,203,204,205,215,216,223,225,234,235,252,253,263,264,271,272,291,292,299, €€ 300,306,307,320,321,372,373,529,530,540,541,561,562,572,573,582,583,593,594,666,667,680,681,687, €N 688,711,712,719,720,730,731,783,784,793,794,795N, ID INTEGER 05C2 39,43,110,112,0 IDATLD INTEGER 0546 9,13,117,119,121 08 IDATLF INTEGER 0564 9,15,116,129,132,134,674 84 IDATRP INTEGER 0555 9,14,115,123,125,363 48 IDATUT INTEGER 0573 9,16,112,114,136,138,766 8@ IDOLAR INTEGER 05D4 43,45,285,415,451,467,481,490,495@, IEND INTEGER 05A1 26,28,197,553,* IENDSW INTEGER 0815 556,557,608*‚ IFLAG INTEGER 0597 22,24,163,187,195,205,216,225,235,253,264,272,292,300,307,321,373,530,541,562,573,583,594,667,681, ‚6 688,712,720,731,784,7956& II INTEGER 0802 352,355&6 ILENFL INTEGER 0807 377,378,386,387,390,3926> ILENTH INTEGER 0808 378,379,387,391,394,452,456,457>$ ILTR1 INTEGER 059F 24,26$$ ILTR2 INTEGER 05A0 24,26$2 IMAXLN INTEGER 07E1 156,157,441,575,5852* IN INTEGER 081B 704,706,708*" INAMKY INTEGER 0156 3,5"2 INAMPO INTEGER 0801 350,351,352,354,3572‚ INBUF INTEGER 0003 1,141,144,158,197,202,208,214,220,224,231,241,251,262,268,274,277,280,282,286,290,296,303,305,311, ‚r 329,355,545,547,549,551,553,559,565,569,578,581,598,620,626,630,633,634,635,644,651r\ IRCNT INTEGER 05CE 39,43,152,222,233,270,298,319,370,526,538,571,657,664,670,724\* IRTN INTEGER 0816 576,590,596*. ISDEL INTEGER 07DB 128,158,282,551.J ISTAR INTEGER 0814 555,556,611,612,613,623,624,637,638,639,650J€ ISTAT INTEGER 07DA 119,120,121,123,124,125,129,132,133,134,136,137,138,141,142,143,144,277,278,279,280,360,361,362, €z 363,547,548,549,671,672,673,674,763,764,765,766,768,769,770,771,772,775,776,777,797,798,799z. ISVCOL INTEGER 080B 394,446,457,497.‚ ITEMP INTEGER 05C6 39,43,163,187,195,205,216,225,235,253,264,272,292,300,307,321,373,530,541,562,573,583,594,667,681, ‚6 688,712,720,731,784,7956* ITEMP1 INTEGER 080D 454,455,456*2 ITEMP2 INTEGER 0806 376,377,383,389,3932t FTN 3.3B (OPT = LPC) LTRBLD PAGE 35 DATE: 08/29/84 TIME: 2143 t, ITEXTE INTEGER 0598 22,24,658,663,, ITYPEA INTEGER 05D2 43,45,283,466,8 ITYPED INTEGER 05D3 43,45,284,403,404,453,4748& IZ INTEGER 07DC 129,131&> J INTEGER 081E 741,743,744,745,746,751,752,755>: K INTEGER 081C 733,734,742,749,752,760,761:* K2 INTEGER 081F 752,753,755*2 L INTEGER 0817 605,606,621,646,65224 LCOUNT INTEGER 05CF 39,43,148,564,652,66240 LDKEY INTEGER 05D0 39,43,141,277,5470( LENGTH INTEGER 05A3 26,28,405(" LFBUF INTEGER 00D1 1,3"$ LFKEY INTEGER 05D1 39,43$‚ LFSTR INTEGER 05D7 45,47,146,256,257,303,309,323,392,393,398,419,420,421,440,448,458,462,468,475,480,489,496,498,578, ‚* 586,651,653*( LINCTL INTEGER 05E0 47,49,620(& LINEND INTEGER 07E0 150,151&$ LINUM INTEGER 05A4 26,28$( LKEY1 INTEGER 05A5 26,28,756(< LKEY2 INTEGER 05A7 28,30,756,757,758,763,768,791<, LNERR INTEGER 0678 68,70,268,269,N LRCBF1 INTEGER 0159 3,5,754,755,758,759,763,768,772,774,775,777,782N4 LRPTBL INTEGER 0114 3,360,375,381,384,3954t LTFILB INTEGER 01C6 5,237,256,303,323,392,393,398,420,440,448,458,462,468,475,480,489,496,578,651,671,725t8 LTRCNT INTEGER 05E6 50,52,669,683,723,735,7498& LTREC1 INTEGER 0045 1,3,754&J LTRS INTEGER 006D 1,3,723,738,739,740,741,743,744,745,746,755JR LU INTEGER 07D1 110,121,125,134,138,144,280,363,549,674,766,772,777R( M INTEGER 05AE 30,32,335(( MAXLEN INTEGER 05AB 30,32,447(( MAXLIN INTEGER 0747 90,92,592(( MAXLTR INTEGER 05AF 32,34,255(. MELM INTEGER 081D 734,735,736,737.( MINLEN INTEGER 05AC 30,32,447(" MODE INTEGER 07D2 110"@ MSTRPO INTEGER 05B0 32,34,343,346,404,428,429,430,431@( MXLINE INTEGER 05AD 30,32,564(( MXNUML INTEGER 0738 86,88,669(€ N INTEGER 07F8 241,242,243,247,311,313,323,329,330,331,332,333,334,335,336,337,339,352,355,356,357,401,420,466, €V 467,468,474,475,511,598,599,601,602,603,604,606,626,627Vn NCOMP INTEGER 07EE 181,182,197,198,208,209,286,287,375,376,381,382,553,554,565,566,630,631,706,707n, NINE INTEGER 05A9 28,30,390,496,0 NLRC INTEGER 0739 86,88,750,793,7940( NO INTEGER 05D6 43,45,331(0 NOF INTEGER 05D5 43,45,154,418,5330& NOPORT INTEGER 07D3 110,111&H NSWICH INTEGER 05DB 45,47,140,199,203,204,207,227,238,587,588H$ NUMCHK INTEGER 05E1 47,49$N NUMSW INTEGER 0813 554,555,605,609,611,612,613,615,622,637,638,647N€ OBUF INTEGER 00D2 1,3,211,219,221,224,225,229,230,232,235,259,267,269,272,294,295,297,300,315,316,317,321,338,340, €€ 365,366,368,373,501,504,507,508,510,512,514,515,517,518,520,523,527,530,536,537,539,541,567,568, €€ 570,573,591,592,594,655,656,660,661,667,676,677,679,681,727,728,729,731,759,774,788,789,790,792, €" 795"> PAGCNT INTEGER 0784 100,102,170,171,172,695,696,697>t FTN 3.3B (OPT = LPC) LTRBLD PAGE 36 DATE: 08/29/84 TIME: 2143 tN PAGOUT INTEGER 0785 100,102,178,179,181,183,185,703,704,706,708,710N, PAMERR INTEGER 0690 70,72,503,504,‚ PARAM INTEGER 05C0 39,324,343,344,345,346,348,403,404,405,417,424,426,428,429,430,431,436,438,445,461,465,470,473,479 ‚@ ,482,491,502,503,505,521,522,524 @( PARAM1 INTEGER 06A5 72,74,508(( PARAM2 INTEGER 06BB 74,76,515(( PARAM5 INTEGER 06E0 78,80,518(4 PARAME INTEGER 06D1 76,78,339,340,511,5124‚ PRT INTEGER 05DC 45,47,111,163,187,195,205,216,225,235,253,264,272,292,300,307,321,373,530,541,562,573,583,594,667, ‚: 681,688,712,720,731,784,795:‚ PRTBUF INTEGER 04BC 7,159,160,161,163,165,166,167,168,169,185,187,189,190,191,192,193,195,200,201,202,205,212,213,214, ‚€ 216,249,250,251,253,260,261,262,264,276,289,290,292,304,305,307,558,559,560,562,579,580,581,583, €v 684,685,686,688,690,691,692,693,694,710,712,714,715,716,717,718,720,779,780,781,782,784v‚ PRTLEN INTEGER 05E5 47,50,159,163,165,187,189,195,205,212,216,230,235,249,253,260,264,292,307,501,507,510,514,517,520, ‚z 530,536,541,562,568,573,579,583,591,594,667,681,684,688,690,712,714,720,727,779,784,788,795zR RE INTEGER 05BC 37,172,173,174,175,176,177,697,698,699,700,701,702 R6 REQBLD INTEGER 04FE 7,9,119,141,277,547,79766 REQBLF INTEGER 0516 7,9,129,131,132,671,7986* REQBRP INTEGER 013E 3,5,123,360*6 REQBUT INTEGER 052E 7,9,136,763,768,775,7996, RPTBLE INTEGER 06F8 80,82,367,368,& RTBLSW INTEGER 078A 102,104&< RTNMKY INTEGER 05EA 50,52,349,352,357,359,360,369<* SALNUM INTEGER 07CD 104,150,629*6 SALSW INTEGER 0789 100,102,155,543,546,6246D SAVKEY INTEGER 05DD 45,47,239,245,247,255,256,671,678,723D$ SIX INTEGER 05AA 28,30$p SNGLSP INTEGER 05B6 37,39,166,190,201,229,267,289,295,304,316,366,527,537,560,567,580,677,691,715,728p, STAR INTEGER 05B1 32,34,602,630,$ STAR2 INTEGER 05B4 35,37$* STARSW INTEGER 078B 102,104,156*& T INTEGER 078C 102,104&0 TEMP INTEGER 0183 3,739,741,744,7460( TEXT1 INTEGER 0711 82,84,656(( TEXT2 INTEGER 072A 84,86,729(( TEXT3 INTEGER 073A 88,90,661($ THREEO INTEGER 05E7 50,52$4 TOPPAG INTEGER 05B5 35,37,160,685,781,7904$ TWO INTEGER 05BD 37,39$2 TXTLIN INTEGER 05C1 39,149,552,575,585 28 TYPE INTEGER 05B2 32,34,403,424,426,465,4738, UTFERR INTEGER 075D 92,94,791,792,. WKAREA INTEGER 07CB 104,106,633,634.‚ WKBUF INTEGER 05DE 45,47,326,384,385,386,395,396,397,398,401,433,435,439,440,441,442,446,447,448,449,452,454,455,458, ‚N 462,463,477,478,480,484,486,487,488,489,493,499N$ WKKEY INTEGER 05E4 47,50$* Y INTEGER 078D 102,104,375*. ZERO INTEGER 07CA 104,106,181,706.D ZEROES INTEGER 05E2 47,49,239,326,442,449,463,484,493,499Dt FTN 3.3B (OPT = LPC) LTRBLD PAGE 37 DATE: 08/29/84 TIME: 2143 t   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < € CCSBLK SUBROUTINE 1059 158,165,189,200,211,212,230,237,249,259,260,274,276,294,315,338,349,365,369,501,507,510,514,517, €^ 520,536,545,558,568,579,591,655,660,676,684,690,714,727,779,788^J CCSCST SUBROUTINE 0D08 111,181,197,208,286,375,381,553,565,630,706J6 CCSGET SUBROUTINE 0CA6 240,311,329,355,598,6266€ CCSMVA SUBROUTINE 100B 113,115,116,117,160,161,166,167,168,169,183,185,190,191,192,202,214,220,221,224,231,232,239,250, €€ 251,256,262,268,269,290,296,297,303,305,317,323,326,339,340,352,357,359,367,368,384,392,393,395, €€ 398,420,440,442,448,449,458,462,463,480,484,489,493,496,499,503,504,508,511,512,515,518,522,523, €€ 539,559,569,570,578,581,592,620,633,634,635,644,651,656,661,678,679,685,686,691,692,693,694,708, €V 710,715,716,717,729,754,755,756,758,759,774,782,791,792V. CCSPUT SUBROUTINE 0F16 247,401,468,475." CLEAR SUBROUTINE 0880 128"* CLOSFL SUBROUTINE 1599 797,798,799*€ DISP SUBROUTINE 1042 163,188,196,206,217,226,236,254,265,273,293,301,308,322,374,531,542,563,574,584,595,668,682,689, €2 713,721,732,785,7962N FILERR SUBROUTINE 0CD5 120,125,134,138,144,280,363,549,674,766,772,777N€ FWRITE SUBROUTINE 103A 161,187,195,205,216,225,235,253,264,272,292,300,307,321,373,530,541,562,573,583,594,667,681,688, €2 712,720,731,784,7952* GETS SUBROUTINE 107C 140,277,547*J ICCSAD INTEGER.FN. 0F3C 385,386,396,397,433,435,477,478,487,488,606J" LTPRNT SUBROUTINE 1413 724"& LTRDTE SUBROUTINE 09AC 192,718&. OPENFL SUBROUTINE 0859 118,123,132,136." PGMIN SUBROUTINE 0823 109"" PGMOUT SUBROUTINE 15A3 799" Q8STP INTEGER.FN. 15A5 & READR SUBROUTINE 0CC5 359,768&" UPDREC SUBROUTINE 1515 774"" UTHEAD SUBROUTINE 0878 127"& WRITER SUBROUTINE 12E5 670,763&   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < " 10 0822 109"" 20 0828 110"& 25 0858 113,118&" 30 0858 118"" 32 085D 119"& 35 0869 120,123&" 37 086D 123"& 40 0877 124,127&" 45 087B 127"& 56 0887 129,131&" 57 0890 131"t FTN 3.3B (OPT = LPC) LTRBLD PAGE 38 DATE: 08/29/84 TIME: 2143 t& 60 089E 133,136&" 65 08A2 136"& 90 08AC 137,140&> 130 08AF 140,158,203,590,670,680,724,726>. 135 08C6 143,146,575,576." 136 08E0 157"" 140 08E7 158"& 150 0908 161,165&" 160 0927 169"" 165 094A 177"& 166 0978 179,184&& 167 097D 182,185&& 170 0992 185,189&& 190 09BC 193,197&" 195 09C4 197"& 196 09C8 142,199&" 200 09CA 199"& 220 09EC 198,207&" 230 09EE 207"& 235 09FE 209,211&& 236 0A1D 214,218&& 250 0A42 209,227&& 251 0A46 227,278&* 320 0A66 227,234,237*" 330 0A6C 238"" 335 0A73 239"& 337 0A8F 243,245&& 340 0A96 242,247&* 360 0A9B 239,246,248*" 370 0AA0 248"& 380 0AC0 251,255&" 382 0AC5 255"* 390 0AD0 243,255,259*& 395 0AED 262,266&> 400 0B0C 222,258,271,274,320,372,529,535>& 420 0B15 276,282&& 430 0B2E 279,282&" 520 0B35 282"" 525 0B4A 287"& 530 0B68 290,294&& 540 0B8B 287,302&& 560 0BAE 305,309&& 580 0BC6 309,314&" 590 0BCB 314"& 595 0BE8 313,323&" 600 0BF0 323"" 610 0C06 329"" 615 0C3D 337"& 620 0C51 330,342&& 630 0C85 335,348&" 632 0C8D 349"" 634 0C9D 352"& 639 0CB8 352,358&& 640 0CBD 356,359&t FTN 3.3B (OPT = LPC) LTRBLD PAGE 39 DATE: 08/29/84 TIME: 2143 t& 643 0CDC 361,365&& 644 0D07 362,375&& 645 0D1F 376,381&& 646 0D43 382,389&* 648 0D4B 379,388,392*" 649 0D69 394"" 650 0D70 395". 655 0D85 342,343,346,400.& 660 0D92 337,403&" 665 0DAE 405"& 670 0DC9 405,411&& 675 0DD6 411,415&& 680 0DDE 331,417&& 700 0DF3 332,423&. 720 0E3B 407,412,425,433.* 740 0E45 413,427,435*& 741 0E48 433,436&& 745 0E57 436,437&& 750 0E81 436,444&& 755 0EAB 436,451&& 757 0ECB 453,457&& 760 0EDE 436,460&* 780 0EF5 333,336,465*& 800 0F1C 424,470&& 820 0F23 334,473&* 860 0F3B 408,428,477*" 865 0F4F 479"" 867 0F62 483"* 880 0F6B 409,430,486*" 885 0F80 488"2 890 0F9C 415,451,481,490,4952. 895 0FB5 398,459,495,498.Z 900 0FC1 344,345,347,348,400,410,414,426,429,431,432,454,479,486,501Z* 905 0FDC 417,439,507*. 910 0FE8 423,465,473,510.2 920 0FFB 394,447,457,497,5142& 925 1007 415,517&. 930 1014 403,404,406,520.> 935 102D 340,506,509,513,516,519,525,526>N 1000 1043 326,402,436,443,450,464,469,472,476,485,494,532N* 1120 104A 421,500,533*& 1140 1058 302,536&* 1200 1071 288,540,543*2 1210 1076 533,545,551,654,6662" 1220 107B 546"* 1230 108F 543,548,551*& 1236 1097 298,552&& 1237 10CC 560,564&" 1240 10D4 564"& 1241 1108 571,575&& 1245 1116 554,578&& 1250 1139 581,585&& 1251 114E 585,590&& 1252 1151 576,591&t FTN 3.3B (OPT = LPC) LTRBLD PAGE 40 DATE: 08/29/84 TIME: 2143 t& 1254 116B 592,596&& 1260 116D 566,597&" 1265 1175 598"& 1290 11A0 601,605&& 1300 11B4 604,611&& 1350 11D5 602,615&* 1360 11DC 615,617,638*& 1370 11F0 615,623&& 1380 11FE 603,626&& 1382 1215 627,629&& 1385 122C 631,633&& 1386 124F 631,637&* 1390 126C 613,637,641*: 1420 1284 597,599,605,610,614,625,649:. 1425 1291 624,640,648,651.B 1440 12A3 600,611,612,618,628,639,642,650,655B& 1450 12B6 564,660&* 1460 12C9 658,665,666*& 1500 12D7 588,669&& 1520 12FF 672,676&& 1550 1324 673,683&" 1553 1325 683"& 1554 1346 686,690&" 1555 138D 702"& 1556 13BA 704,709&& 1557 13C0 707,710&& 1558 13D6 710,714&& 1559 1405 718,722&" 1565 140B 723"& 1570 1418 669,727&. 1600 1435 204,588,730,733.* 1605 146F 741,743,747** 1610 1472 736,737,748*& 1615 1474 738,749&" 1620 1476 749"" 1650 14CA 761"& 1675 14E6 764,768&" 1677 14FE 770"& 1680 150C 771,774&" 1700 1514 774"* 1750 1527 765,776,779*. 1800 154F 749,783,786,793.* 1860 1555 769,770,788*" 1870 156E 791"Z 2010 1598 121,126,135,139,145,281,364,550,675,767,773,778,787,794,797Z" 2020 15A2 799" LTRBLD 0000 1 t FTN 3.3B (OPT = LPC) LTRDTE PAGE 1 DATE: 08/29/84 TIME: 2153 t^ 1 SUBROUTINE LTRDTE(INBUF, OBUF, ICOL, ECODE) F7600001^^ 1 1 /B76 F CCS CCS 3.0 SL-149F7600002^^ C F7600003^^ C CYBERCREDIT SYSTEM VERSION 3 F7600004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA F7600005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 F7600006^^ C F7600007^ ^ C CALL SEQUENCE: F7600009^^ C F7600010^^ C CALL LTRDTE(OBUF,ICOL,ECODE) F7600011^^ C F7600012^^ C WHERE: F7600013^ ^ C INBUF= INPUT F7600015^^ C OBUF = OUTPUT BUFFER F7600016^^ C ICOL = STARTING POSITION IN THE LINE DATE IS TO BE PLACED. F7600017^^ C ECODE = 1 - OUTPUT DATE WITH FULL SPELLING OF MONTH F7600018^^ C EX: SEPTEMBER 29, 1979 F7600019^^ C = 2 - OUTPUT DATE WITH SHORT SPELLING OF MONTH F7600020^^ C EX: SEP 29, 1979 F7600021^^ C = 3 - OUTPUT DATE IN NUMERIC FORM F7600022^^ C EX: 09/29/79 F7600023^ ^ 2 INTEGER ECODE, ICOL, IYEAR, IDAY, IMONTH F7600025^ ^ 3 INTEGER IDAYR(4) F7600027^^ 4 DATA IDAYR/' , 19 '/ F7600028^ ^ 5 INTEGER OBUF(66), INBUF(66) F7600031^ ^ 6 INTEGER JAN(4),FEB(4),MAR(3) F7600033^^ 7 DATA JAN/'JANUARY'/,FEB/'FEBRUARY'/,MAR/'MARCH'/ F7600034^ ^ 8 INTEGER APR(3),MAY(2),JUN(2),JUL(2) F7600036^^ 9 DATA APR/'APRIL'/,MAY/'MAY'/,JUN/'JUNE'/,JUL/'JULY'/ F7600037^ ^ 10 INTEGER AUG(3),SEP(5),OCT(4) F7600039^^ 11 DATA AUG/'AUGUST'/,SEP/'SEPTEMBER'/,OCT/'OCTOBER'/ F7600040^ ^ 12 INTEGER NOV(4),DEC(4) F7600042^^ 13 DATA NOV/'NOVEMBER'/,DEC/'DECEMBER'/ F7600043^  ^ 14 INTEGER SMONTH(24) F7600046^^ 15 DATA SMONTH/'JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC'/ F7600047^  ^ C***********************************************************************F7600050^^ C F7600051^^ C DETERMINE IF DATE IS TO BE FULL, SHORT OR NUMERIC F7600052^^ C F7600053^^ C***********************************************************************F7600054^ t FTN 3.3B (OPT = LPC) LTRDTE PAGE 2 DATE: 08/29/84 TIME: 2153 t ^ 16 IMONTH=INBUF(1) F7600057^^ 17 IDAY=INBUF(2) F7600058^^ 18 IYEAR=INBUF(3) F7600059^^ 19 LCOL=ICOL F7600060^ ^ 20 20 IF(ECODE .EQ. 1) GO TO 30 F7600062^^ 21 IF(ECODE .EQ. 2) GO TO 200 F7600063^^ 22 GO TO 300 F7600064^ ^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++F7600066^^ C MOVE DAY AND AYERTO TO IDAYR ARRAY F7600067^^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++F7600068^ ^ 23 30 CALL CCSMVA(IDAY,1,2,IDAYR,1,2) F7600070^^ 24 CALL CCSMVA(IYEAR,1,2,IDAYR,7,2) F7600071^ ^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++F7600073^^ C F7600074^^ C RETRIEVE LONG SPELLING OF MONTH AND PLACE IN CURRENT DATE ARRAYF7600075^^ C F7600076^^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++F7600077^ ^ 25 40 IMONTH=ICCSAD(IMONTH) F7600079^^ 26 42 GO TO (50,60,70,80,90,100,110,120,130,140,150,160), IMONTH F7600080^ ^ C JANUARY F7600082^ ^ 27 50 CALL CCSMVA(JAN, 1, 7, OBUF, LCOL, 7) F7600084^^ 28 CALL CCSMVA(IDAYR, 1, 8, OBUF, LCOL+8, 8) F7600085^^ 29 GO TO 400 F7600086^ ^ C FEBRUARY F7600088^ ^ 30 60 CALL CCSMVA(FEB, 1, 8, OBUF, LCOL, 8) F7600090^^ 31 CALL CCSMVA(IDAYR, 1, 8, OBUF, LCOL+9, 8) F7600091^^ 32 GO TO 400 F7600092^ ^ C MARCH F7600094^ ^ 33 70 CALL CCSMVA(MAR, 1, 5, OBUF, LCOL, 5) F7600096^^ 34 CALL CCSMVA(IDAYR, 1, 8, OBUF, LCOL+6, 8) F7600097^^ 35 GO TO 400 F7600098^ ^ C APRIL F7600100^ ^ 36 80 CALL CCSMVA(APR, 1, 5, OBUF, LCOL, 5) F7600102^^ 37 CALL CCSMVA(IDAYR, 1, 8, OBUF, LCOL+6, 8) F7600103^^ 38 GO TO 400 F7600104^ ^ C MAY F7600106^ ^ 39 90 CALL CCSMVA(MAY, 1, 3, OBUF, LCOL, 3) F7600108^^ 40 CALL CCSMVA(IDAYR, 1, 8, OBUF, LCOL+4, 8) F7600109^t FTN 3.3B (OPT = LPC) LTRDTE PAGE 3 DATE: 08/29/84 TIME: 2153 t^ 41 GO TO 400 F7600110^ ^ C JUNE F7600112^ ^ 42 100 CALL CCSMVA(JUN, 1, 4, OBUF, LCOL, 4) F7600114^^ 43 CALL CCSMVA(IDAYR, 1, 8, OBUF, LCOL+5, 8) F7600115^^ 44 GO TO 400 F7600116^ ^ C JULY F7600118^ ^ 45 110 CALL CCSMVA(JUL, 1, 4, OBUF, LCOL, 4) F7600120^^ 46 CALL CCSMVA(IDAYR, 1, 8, OBUF, LCOL+5, 8) F7600121^^ 47 GO TO 400 F7600122^ ^ C AUGUST F7600124^ ^ 48 120 CALL CCSMVA(AUG, 1, 6, OBUF, LCOL, 6) F7600126^^ 49 CALL CCSMVA(IDAYR, 1, 8, OBUF, LCOL+7, 8) F7600127^^ 50 GO TO 400 F7600128^ ^ C SEPTEMBER F7600130^ ^ 51 130 CALL CCSMVA(SEP, 1, 9, OBUF, LCOL, 9) F7600132^^ 52 135 CALL CCSMVA(IDAYR, 1, 8, OBUF, LCOL+10, 8) F7600133^^ 53 GO TO 400 F7600134^ ^ C OCTOBER F7600136^ ^ 54 140 CALL CCSMVA(OCT, 1, 7, OBUF, LCOL, 7) F7600138^^ 55 CALL CCSMVA(IDAYR, 1, 8, OBUF, LCOL+8, 8) F7600139^^ 56 GO TO 400 F7600140^ ^ C NOVEMBER F7600142^ ^ 57 150 CALL CCSMVA(NOV, 1, 8, OBUF, LCOL, 8) F7600144^^ 58 CALL CCSMVA(IDAYR, 1, 8, OBUF, LCOL+9, 8) F7600145^^ 59 GO TO 400 F7600146^ ^ C DECEMBER F7600148^ ^ 60 160 CALL CCSMVA(DEC, 1, 8, OBUF, LCOL, 8) F7600150^^ 61 CALL CCSMVA(IDAYR, 1, 8, OBUF, LCOL+9, 8) F7600151^^ 62 GO TO 400 F7600152^ ^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++F7600154^^ C ECODE=2 - SHORT SPELLING OF IMONTH F7600155^^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++F7600156^ ^ 63 200 IMONTH=ICCSAD(IMONTH) F7600158^^ 64 IPOS=(IMONTH-1)*4+1 F7600159^^ 65 CALL CCSMVA(SMONTH,IPOS,3,OBUF,ICOL,3) F7600160^^ 66 CALL CCSMVA(IDAY, 1, 2, IDAYR, 1, 2) F7600161^^ 67 CALL CCSMVA(IYEAR,1,2, IDAYR, 7,2) F7600162^ t FTN 3.3B (OPT = LPC) LTRDTE PAGE 4 DATE: 08/29/84 TIME: 2153 t^ C MOVE TO PRINTER F7600164^ ^ 68 CALL CCSMVA(IDAYR, 1, 8, OBUF, ICOL+4, 8) F7600166^ ^ 69 GO TO 400 F7600168^ ^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++F7600170^^ C ECODE = 3 OR 0 F7600171^^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++F7600172^ ^ 70 300 CALL EDIT(INBUF,1,OBUF,LCOL,1) F7600174^ ^ 71 400 RETURN F7600176^^ 72 END F7600177^t FTN 3.3B (OPT = LPC) LTRDTE PAGE 5 DATE: 08/29/84 TIME: 2153 t  PROGRAM LENGTH $01FC ( 508)   EXTERNALS & Q8PKUP Q8PREP CCSMVA ICCSAD EDIT & t FTN 3.3B (OPT = LPC) LTRDTE PAGE 6 DATE: 08/29/84 TIME: 2153 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < ‚ 0001 (1) 0000 16,20,23,24,27,28,30,31,33,34,36,37,39,40,42,43,45,46,48,49,51,52,54,55,57,58,60,61,64,66,67,68,70 ‚. 0002 (2) 0049 21,23,24,66,67 .( 0003 (3) 004F 39,39,65 (. 0004 (4) 0050 40,42,45,64,68 .. 0005 (5) 004D 33,33,36,43,46 .( 0006 (6) 004E 34,37,48 (. 0007 (7) 004A 24,27,49,54,67 .R 0008 (8) 004B 28,28,30,31,34,37,40,43,46,49,52,55,57,58,60,61,68 R* 0009 (9) 004C 31,51,58,61*   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < & APR INTEGER 0013 7,9,36 && AUG INTEGER 001C 9,11,48&( DEC INTEGER 002C 11,13,60 (( ECODE INTEGER 7FFF 1,2,20,21(& FEB INTEGER 000C 5,7,30 &, ICOL INTEGER 7FFF 1,2,19,65,68 ,* IDAY INTEGER 0002 2,17,23,66 *V IDAYR INTEGER 0004 2,4,23,24,28,31,34,37,40,43,46,49,52,55,58,61,66,67,68 V0 IMONTH INTEGER 0003 2,16,25,26,63,64 0. INBUF INTEGER 7FFF 1,5,16,17,18,70.( IPOS INTEGER 0051 63,64,65 (* IYEAR INTEGER 0001 2,18,24,67 *& JAN INTEGER 0008 5,7,27 && JUL INTEGER 001A 7,9,45 && JUN INTEGER 0018 7,9,42 &p LCOL INTEGER 0048 18,19,27,28,30,31,33,34,36,37,39,40,42,43,45,46,48,49,51,52,54,55,57,58,60,61,70 p& MAR INTEGER 0010 5,7,33 && MAY INTEGER 0016 7,9,39 &( NOV INTEGER 0028 11,13,57 (t OBUF INTEGER 7FFF 1,5,27,28,30,31,33,34,36,37,39,40,42,43,45,46,48,49,51,52,54,55,57,58,60,61,65,68,70 t& OCT INTEGER 0024 9,11,54&& SEP INTEGER 001F 9,11,51&( SMONTH INTEGER 0030 13,15,65 (t FTN 3.3B (OPT = LPC) LTRDTE PAGE 7 DATE: 08/29/84 TIME: 2153 t   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < x CCSMVA SUBROUTINE 0172 23,24,27,28,30,31,33,34,36,37,39,40,42,43,45,46,48,49,51,52,54,55,57,58,60,61,65,66,67,68x" EDIT SUBROUTINE 01A5 70 "$ ICCSAD INTEGER.FN. 017B 25,63$ Q8PKUP INTEGER.FN. 01B4 Q8PREP INTEGER.FN. 01B1    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < " 20 005A 19 "$ 30 0069 20,23$" 40 0078 24 "" 42 007D 25 "$ 50 0095 25,27$$ 60 00A9 25,30$$ 70 00BC 25,33$$ 80 00D0 25,36$$ 90 00E3 25,39$$ 100 00F7 25,42$$ 110 010A 25,45$$ 120 011D 25,48$$ 130 012F 25,51$" 135 0136 51 "$ 140 0142 25,54$$ 150 0155 25,57$$ 160 0167 25,60$$ 200 017A 21,63$$ 300 01A4 21,70$H 400 01AB 28,32,35,38,41,44,47,50,53,56,59,62,69,71H LTRDTE 01AE 1  t FTN 3.3B (OPT = LPC) LTRPRT PAGE 1 DATE: 08/29/84 TIME: 2153 t^ 1 PROGRAM LTRPRT 00001^^ 1 1 /B77 F CCS CCS 3.0 PSR'D SL-149 00002^ ^ C CYBERCREDIT SYSTEM VERSION 3 00004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA 00005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 00006^^ C 00007^ ^ C THIS PROGRAM IS DESIGNED TO PRINT REQUESTED LETTERS 00009^^ C THAT WERE REQUESTED BY COLLECTORS DURING THE COLLECTION 00010^^ C ACTIVITIES. 00011^^ C 00012^^ C FILES, IO BUFFERS, AND FILE MANAGER******************** 00013^ ^ 2 INTEGER BUF(6),DATBUF(13),DMBUF(1000) 00015^^ 3 DATA BUF/6*$2020/,DATBUF/13*$2020/ 00016^ ^ 4 INTEGER FARRAY(27),FULNAM(25),PBUF(67) 00018^^ 5 DATA FARRAY/27*0/,FULNAM/25*$2020/ 00019^^ 6 DATA PBUF/'1 ',66*' '/ 00020^ ^ 7 INTEGER LASNAM(15),LTFILB(756),LTRFBF(40),OBUF(66) 00022^^ 8 DATA LASNAM/15*$2020/,LTFILB/756*$2020/,LTRFBF/40*$2020/ 00023^ ^ 9 INTEGER IOBUF(41),LTRARR(760) 00025^^ 10 DATA IOBUF/41*0/,LTRARR/760*$2020/ 00026^ ^ 11 INTEGER REQ1(24),REQ2(24),REQ3(24),REQ4(24) 00028^ ^ 12 DATA REQ1/24*0/,REQ2/24*0/,REQ3/24*0/,REQ4/24*0/ 00030^ ^ 13 INTEGER SALARA(33),TFBUF(69) 00032^^ 14 DATA SALARA/33*$2020/,TFBUF/69*$2020/ 00033^ ^ C FILE DATA........ 00035^ ^ 15 INTEGER DAT1(15),DAT2(15),DAT3(15),DAT4(15) 00037^^ 15 +, LD1(4),LD2(4),LD3(4),LD4(4) 00038^ ^ 16 DATA DAT1/'LACOSIGN ',01,01,00/ 00040^^ 16 +, DAT2/'LADLQMST ',01,01,00/ 00041^^ 16 +, DAT3/'LALTRFIL ',01,01,00/ 00042^^ 16 +, DAT4/'LATRNSFL ',00,01,00/ 00043^ ^ 17 DATA LD1 /'COSIGNER'/,LD2 /'DELQMST '/ 00045^^ 17 +, LD3 /'LTRFIL '/,LD4 /'TRNSFL '/ 00046^ ^ C CONSTANTS***************** 00048^ ^ 18 INTEGER A,ADAYTO,AMONTO,ASTRSK,AT,AYERTO,B 00050^^ 19 DATA A/$0041/,ASTRSK/$002A/,AT/$0040/,B/$0042/ 00051^ ^ 20 INTEGER BLANK(10),COMMA,LENGTH,COID,CC 00053^^ 21 DATA BLANK/10*$2020/,COMMA/$2C2C/,LENGTH/0/,COID/0/,CC/2/ 00054^t FTN 3.3B (OPT = LPC) LTRPRT PAGE 2 DATE: 08/29/84 TIME: 2153 t ^ 22 INTEGER DATLIN,FIRLEN,FULLEN,EJT,DBLSPC 00056^^ 23 DATA DATLIN/3/,EJT/'1 '/,DBLSPC/'0 '/ 00057^ ^ 24 INTEGER D,DOL,DT(3),EOF,EXT(2),FEQ 00059^^ 25 DATA D/$0044/,DOL/$0024/,DT/3*0/,EOF/$100/ 00060^^ 26 DATA FEQ/$463D/,EXT/'EXT'/ 00061^ ^ 27 INTEGER IEND(2),MARGIN,MAXLEN,NO,PUN 00063^^ 28 DATA IEND/'END'/,MARGIN/13/,MAXLEN/57/ 00064^^ 29 DATA NO/$4E20/ 00065^ ^ 30 INTEGER RECTYP,TWO,START 00067^^ 31 DATA RECTYP/$3031/,TWO/$0032/ 00068^ ^ 32 INTEGER WRONKY,XYN,ZERO 00070^^ 33 DATA WRONKY/$200/,XYN/-1/,ZERO/0/ 00071^ ^ 34 INTEGER YES,ZEROE 00073^^ 35 DATA YES/$5920/,ZEROE/$3030/ 00074^ ^ C KEYS, VAIRABLES, MISC************** 00076^ ^ 36 INTEGER COL,COLCPO 00078^^ 37 DATA COL/0/,COLCPO/0/ 00079^ ^ 38 INTEGER FCOUNT,FSWICH,IARAPT,IADR,ICTLD 00081^^ 39 DATA FSWICH/0/,FCOUNT/0/,IARAPT/0/,IADR/0/,ICTLD/0/ 00082^ ^ 40 INTEGER ICOL,IPOINT,IPOS 00084^^ 41 DATA ICOL/0/,IPOINT/0/,IPOS/0/ 00085^ ^ 42 INTEGER LCOUNT,LTLPT 00087^^ 43 DATA LCOUNT/0/,LTLPT/0/ 00088^ ^ 44 INTEGER MNAM(15),MADR1(15),MADR2(15),MCS(10),MZP(3),MBNM(15) 00090^^ 45 INTEGER MSLCD,LTBUPT,LTRF(2) 00091^^ 46 DATA MSLCD/0/,LTBUPT/0/,LTRF/'LTRF'/ 00092^ ^ 47 INTEGER NOF,NUMCLC 00094^^ 48 DATA NOF/0/,NUMCLC/0/ 00095^ ^ 49 INTEGER POS,SALC(2),SALLEN 00097^^ 50 DATA POS/0/,SALC/'SALC'/,SALLEN/0/ 00098^ ^ 51 INTEGER TCIDWK(2),TCIDCK(2),TCIDKY(2) 00100^ ^ 52 INTEGER TACTKY(8),TACTWK(9) 00102^ ^ 53 INTEGER TCIDSC,TFKEY(8),TLACKY 00104^^ 54 DATA TCIDSC/0/,TLACKY/0/ 00105^ ^ 55 INTEGER TLRKY,TLRPNT,TLRWKY,TYPE 00107^^ 56 DATA TLRKY/0/,TLRPNT/0/,TLRWKY/0/,TYPE/0/ 00108^t FTN 3.3B (OPT = LPC) LTRPRT PAGE 3 DATE: 08/29/84 TIME: 2153 t ^ C MESSAGE BUFFERS************MESSAGE BUFFERS 00110^ ^ 57 INTEGER ACCTNO(10) 00112^^ 58 DATA ACCTNO/$D0A,'1234567890123456',$D0A/ 00113^ ^ 59 INTEGER MSG2(40) 00115^^ 60 DATA MSG2/$1820,'DO YOU WISH TO PRINT ALL OF THE LETTERS ' 00116^^ 60 +, 'REQUESTED BY THE COLLECTORS?',$0D0A,' (Y/N): '/ 00117^ ^ 61 INTEGER MSG4(30) 00119^^ 62 DATA MSG4/'LINE THE * TO THE TOP OF PAGE AND SEVENTH CHARACTER ' 00120^^ 62 +, 'POSITION'/ 00121^ ^ 63 INTEGER MSG4A(31) 00123^^ 64 DATA MSG4A/ 00124^^ 64 1$1820,'DO YOU WISH TO HAVE ANOTHER ALIGNMENT ', 00125^^ 64 2 'LINE PRINTED? (Y/N) :' / 00126^ ^ 65 INTEGER MSG6(40) 00128^^ 66 DATA MSG6/ 00129^^ 66 1$A0D,'ENTER ACCOUNT NUMBER OF THE NEXT LETTE', 00130^^ 66 2 'R TO BE PRINTED - (16 DIGITS MAX). ',$0A0D/ 00131^ ^ 67 INTEGER MSG7(33) 00133^^ 68 DATA MSG7/ ' UNABLE TO LOCATE ACCOUNT ', 00134^^ 68 1 'IN THE DELQMST FILE '/ 00135^ ^ 69 INTEGER MSG5(33) 00137^^ 70 DATA MSG5/$A0D,'UNABLE TO LOCATE ACCOUNT ', 00138^^ 70 1 ' IN THE TRNSFL FILE '/ 00139^ ^ 71 INTEGER MSG9(23) 00141^^ 72 DATA MSG9/ 00142^^ 72 1 ' UNABLE TO LOCATE COLLECTOR TTTT IN UTIFIL. '/ 00143^ ^ 73 INTEGER MSG9A(40) 00145^^ 74 DATA MSG9A/ 00146^^ 74 1 ' LETTER TO BE SENT TO ACCOUNT NUMBER XX', 00147^^ 74 2 'XXXXXXXXXXXXXX HAS NOT BEEN PRINTED '/ 00148^ ^ 75 INTEGER MSG10(40) 00150^^ 76 DATA MSG10/ 00151^^ 76 1 ' UNABLE TO LOCATE LETTER NUMBER ', 00152^^ 76 2 'TO BE SENT TO ACCT# . '/ 00153^  ^ 77 INTEGER MSG12(40) 00156^^ 78 DATA MSG12/ 00157^^ 78 1 ' UNABLE TO LOCATE ACCOUNT XXXXXXXXXXXXX', 00158^^ 78 2 'XXX IN THE COSIGNER FILE '/ 00159^ ^ 79 INTEGER MSG13(23) 00161^^ 80 DATA MSG13/ '1 UNABLE TO LOCATE LTRF RECORD IN THE UTIFIL '/ 00162^t FTN 3.3B (OPT = LPC) LTRPRT PAGE 4 DATE: 08/29/84 TIME: 2153 t ^ 81 INTEGER REFLIN(2),COF(2) 00164^^ 82 DATA REFLIN/'RE: '/,COF/'C/O '/ 00165^  ^ C EXTERNALS************************** 00168^ ^ 83 EXTERNAL AMONTO,AYERTO,ADAYTO 00170^ ^ C**** SYSPRT PARAMETERS........ 00172^ ^ 84 INTEGER SYSPRM(6),PLN,NLU,IPF,NLINE,ISERR,NU 00174^ ^ 85 EQUIVALENCE ( SYSPRM(1),PLN ),( SYSPRM(2),NLU ) 00176^^ 85 +, ( SYSPRM(3),IPF ),( SYSPRM(4),NLINE ) 00177^^ 85 +, ( SYSPRM(5),ISERR ),( SYSPRM(6),NU ) 00178^ ^ 86 DATA PLN/080/,NLU/05/,IPF/00/,NLINE/0/,ISERR/0/,NU/1/ 00180^ ^ 87 INTEGER USER(4),GRPBUF(10) 00182^^ 87 +, LU,PLU,NPORT,IWAY,IMODE,IALL,IOPT,ITF 00183^ ^ 88 DATA PLU/12/,IWAY/3/,IMODE/3/ 00185^ ^ C**** 00187^^ C**** BEGIN PROGRAM ....... 00188^ ^ C*** GET EXTERNAL SWITCHS, USER INFO, HEADINGS, AND OTHER PARAMETERS 00190^ ^ 89 CALL PGMINT( IADR,ICTLD ) 00192^ ^ 90 CALL PGMIN ( USER,LU,MODE,NPORT ) 00194^ ^ C*** CCS/LA LOOK-ALIKE..... 00196^ ^ 91 CALL CCSCST( DAT1,1,2,USER,1,8,ICM ) 00198^^ 92 IF ( ICM.EQ.0 ) GO TO 5 00199^^ 93 CALL CCSMVA( LD1,1,8,DAT1,1,16 ) 00200^^ 94 CALL CCSMVA( LD2,1,8,DAT2,1,16 ) 00201^^ 95 CALL CCSMVA( LD3,1,8,DAT3,1,16 ) 00202^^ 96 CALL CCSMVA( LD4,1,8,DAT4,1,16 ) 00203^^ 97 5 CONTINUE 00204^ ^ 98 CALL GTSYSP( IWAY, 25 ) 00206^^ 99 CALL GTSYSP( IMODE, 26 ) 00207^^ 100 CALL PRTORF( IPF,PLU,NLU,NPORT,IWAY ) 00208^^ 101 CALL GETGRP( GRPBUF,IALL,IMODE ) 00209^ ^ C**** OPEN FILES AND GET UTIFIL RECORDS 00211^ ^ 102 IF( NPORT.EQ.0 .OR. IPF.EQ.1 ) GO TO 25 00213^^ 103 EJT = $0C20 00214^^ 104 DBLSPC = $0A20 00215^ t FTN 3.3B (OPT = LPC) LTRPRT PAGE 5 DATE: 08/29/84 TIME: 2153 t^ 105 25 CONTINUE 00217^ ^ 106 CALL SYSPRT( ICM,0,SYSPRM,0 ) 00219^^ 107 IF( ISERR.LT.0 ) GO TO 9840 00220^ ^ C BRING IN SYSTEM DATE 00222^ ^ 108 40 DT(1)=AND($FFFF,AMONTO) 00224^^ 109 DT(2)=AND($FFFF,ADAYTO) 00225^^ 110 DT(3)=AND($FFFF,AYERTO) 00226^ ^ C OPEN LETTER FILE (LTRFIL) 00228^ ^ 111 50 CALL OPENFL(REQ3,DAT3,ISTAT) 00230^^ 112 IF( ISTAT.LT.0 ) GO TO 9820 00231^ ^ C OPEN TRANSACTION FILE (TRNSFL) 00233^ ^ 113 70 CALL OPENFL(REQ4,DAT4,ISTAT) 00235^^ 114 IF( ISTAT.LT.0 ) GO TO 9830 00236^ ^ C OPEN DELINQUENT MASTER FILE (DELQMST) - OVERRIDE LOCKED RECORDS 00238^ ^ 115 80 CALL OPENFL(REQ2,DAT2,ISTAT) 00240^^ 116 REQ2(23)=1 00241^^ 117 IF( ISTAT.LT.0 ) GO TO 9810 00242^ ^ C OPEN COSIGNER FILE - OVERRIDE LOCKED RECORDS 00244^ ^ 118 90 CALL OPENFL(REQ1, DAT1, ISTAT) 00246^^ 119 REQ1(23)=1 00247^^ 120 IF( ISTAT.LT.0 ) GO TO 9800 00248^ ^ C INITIALIZE COUNTERS AND POINTERS 00250^ ^ 121 120 COLCPO=0 00252^^ 122 NUMCLC=0 00253^^ 123 LTLPT=0 00254^^ 124 TLRPNT=0 00255^^ 125 LTBUPT=0 00256^ ^ C PROMPT OPERATOR TO ALIGN PAPER IN PRINTER 00258^ ^ 126 200 CONTINUE 00260^^ 127 CALL CCSBLK(OBUF,PLN) 00261^^ 128 CALL CCSMVA( PBUF , 1, 2, OBUF, 1, PLN ) 00262^^ C PUT * IN 7TH POSITION, REQUIRES DISPLACEMENT OF 8 00263^^ 129 CALL CCSMVA (ASTRSK, 2, 1, OBUF, 8, 1) 00264^^ 130 CALL CCSMVA(MSG4, 1, 60, OBUF, 12, 60) 00265^ ^ 131 230 CONTINUE 00267^^ 132 CALL SYSPRT( OBUF,1,SYSPRM,0 ) 00268^ ^ 133 240 CALL CCSBLK( IOBUF,80 ) 00270^t FTN 3.3B (OPT = LPC) LTRPRT PAGE 6 DATE: 08/29/84 TIME: 2153 t^ 134 CALL WTREAD(LU,XYN,MSG4A,62,XYN,IOBUF,80,ITC) 00271^^ 135 IF(IOBUF(1) .EQ. YES) GO TO 230 00272^^ 136 IF(IOBUF(1) .EQ. NO) GO TO 300 00273^^ 137 GO TO 240 00274^ t FTN 3.3B (OPT = LPC) LTRPRT PAGE 7 DATE: 08/29/84 TIME: 2153 t^ C*********************************************************************** 00278^^ C 00279^^ C READ UTILITY FILE TO 00280^^ C GET SALUTATION CODES FROM UTILITY FILE 00281^^ C 00282^^ C*********************************************************************** 00283^ ^ 138 300 CONTINUE 00285^^ 139 CALL GETUTI( SALC,IOBUF,IFOUND,IFER,0 ) 00286^^ 140 IF( IFER.LT.0 ) GO TO 9840 00287^^ 141 IF( IFOUND.NE.1 ) GO TO 330 00288^ ^ 142 320 CONTINUE 00290^^ 143 CALL CCSMVA( SALC,1,4,MSG13,20,4 ) 00291^^ 144 GO TO 350 00292^ ^ C LOAD SALUTATION CODES ARRAY 00294^ ^ 145 330 CALL CCSMVA(IOBUF, 5, 65, SALARA, 1, 65) 00296^ ^ C READ THE LTRF RECORD FROM THE UTIFIL 00298^^ 146 340 CONTINUE 00299^^ 147 CALL GETUTI( LTRF,LTRFBF,IFOUND,IFER,0 ) 00300^^ 148 IF( IFER.LT.0 ) GO TO 9840 00301^^ 149 IF( IFOUND.NE.1 ) GO TO 400 00302^ ^ C DID NOT FIND LTRF PRINT MESSAGE 00304^^ 150 350 CONTINUE 00305^^ 151 CALL CCSMVA(MSG13,1,46,OBUF,1,PLN) 00306^^ 152 360 CONTINUE 00307^^ 153 CALL SYSPRT( OBUF,1,SYSPRM,0 ) 00308^^ 154 GO TO 9900 00309^ ^ C*********************************************************************** 00311^^ C 00312^^ C CHECK WITH OPERATOR TO DETERMINE IF ALL LETTERS ARE TO BE 00313^^ C PRINTED. 00314^^ C 00315^^ C*********************************************************************** 00316^ ^ 155 400 CONTINUE 00318^^ 156 CALL CCSBLK( IOBUF,80 ) 00319^^ 157 410 CALL WTREAD(LU,XYN,MSG2,80,XYN,IOBUF,80,ITC) 00320^^ 158 IF(IOBUF(1) .EQ. YES) GO TO 430 00321^^ 159 IF(IOBUF(1) .EQ. NO) GO TO 420 00322^^ 160 GO TO 400 00323^ ^ C GET ACCOUNT NUMBER FROM OPERATOR 00325^ ^ 161 420 CALL CCSBLK( IOBUF,80 ) 00327^^ 162 MSG2 = MSG6 00328^^ 163 CALL WTREAD(LU,XYN,MSG6,80,0, 0, 0, ITC) 00329^^ 164 CALL WTREAD(LU,XYN,ACCTNO,20,XYN,IOBUF,80 ,ITC) 00330^^ 165 IF( ITC.NE.2 ) GO TO 420 00331^t FTN 3.3B (OPT = LPC) LTRPRT PAGE 8 DATE: 08/29/84 TIME: 2153 t ^ 166 CALL CCSMVA( IOBUF,1,IOBUF(41),TACTWK,1,16 ) 00333^  ^ C LOCATE ACCOUNT IN TRANSACTION FILE LETTER PRINT IS TO 00336^^ C START WITH 00337^ ^ 167 430 CONTINUE 00339^^ 168 TFKEY(1) = ZERO 00340^^ 169 TFKEY(2) = 1 00341^ ^ 170 CALL READR( REQ4,TFBUF,TFKEY,ISTAT ) 00343^^ 171 IF( IOBUF.EQ.YES ) GO TO 507 00344^^ 172 GO TO 445 00345^ ^ 173 440 CONTINUE 00347^^ 174 CALL GETS( REQ4,TFBUF,TFKEY,ISTAT ) 00348^^ 175 445 CONTINUE 00349^^ 176 IF( AND(ISTAT,EOF).EQ.EOF ) GO TO 470 00350^^ 177 IF( ISTAT.LT.0 ) GO TO 9830 00351^ ^ 178 450 CALL CCSCST(TFBUF, 1, 16, TACTWK, 1, 16, ICOMP) 00353^^ C ****************************************************** ???*A031 00354^^ 179 IF (ICOMP .NE. 0) GO TO 440 00355^^ C CHECK TO BE SURE THIS RECORD IS A VALID LETTER REQUEST. 00356^^ 180 CALL CCSCST (TFBUF, 29, 2, RECTYP, 1, 2, ICOMP) 00357^^ 181 IF (ICOMP .NE. 0) GO TO 440 00358^^ 182 CALL CCSCST (TFBUF, 41, 2, BLANK, 1, 2, ICOMP) 00359^^ 183 IF (ICOMP .EQ. 0) GO TO 440 00360^^ 184 GO TO 520 00361^^ C ****************************************************** ???*A031 00362^ ^ C*** NOTIFY OPERATOR OF INABILITY TO LOCATE ACCOUNT NUMBER 00364^ ^ 185 470 CALL CCSMVA(TACTWK,1,16,MSG5,28,16) 00366^^ 186 CALL WTREAD(LU,XYN,MSG5,66,0,0,0,ITC) 00367^^ 187 GO TO 400 00368^ t FTN 3.3B (OPT = LPC) LTRPRT PAGE 9 DATE: 08/29/84 TIME: 2153 t^ C*********************************************************************** 00371^^ C 00372^^ C READ TRANSACTION FILE 00373^^ C 00374^^ C*********************************************************************** 00375^ ^ 188 500 CONTINUE 00377^^ 189 IF( ICTLD.NE.0 ) GO TO 9900 00378^^ 190 CALL CCSBLK(TACTKY, 16) 00379^^ 191 CALL CCSBLK(TLRKY, 2) 00380^^ 192 TLACKY=0 00381^ ^ 193 505 CALL GETS (REQ4, TFBUF, TFBUF, ISTAT) 00383^^ 194 507 IF(AND(ISTAT, EOF) .EQ. EOF) GO TO 3000 00384^^ 195 IF( ISTAT.LT.0 ) GO TO 9830 00385^ ^ C CHECK FOR RECORD TYPE 00387^ ^ 196 520 CALL CCSCST(TFBUF, 29, 2, RECTYP, 1, 2, ICOMP) 00389^^ 197 IF(ICOMP .NE. 0) GO TO 500 00390^^ 198 CALL CCSCST(TFBUF,41,2,BLANK,1,2,ICOMP) 00391^^ 199 IF(ICOMP.EQ.0) GO TO 500 00392^ ^ C*** CHECK FOR VALID ACCOUNT GROUP 00394^^ 200 IF( ICKGRP( GRPBUF,IALL,TFBUF,1 ).EQ.1 ) GO TO 500 00395^ ^ C MOVE ACCOUNT NUMBER (TACCT) TO KEY (TACTKY) 00397^ ^ 201 530 CALL CCSMVA(TFBUF, 1, 16, TACTKY, 1, 16) 00400^ ^ C READ UTIFIL TO GET COLLECTOR INFO 00402^^ C IF COLLECTOR ID NOT FOUND DONT PROCESS 00403^^ C ANY OF THE LETTERS WITH THIS ID. 00404^ ^ 202 540 CALL CCSMVA(TFBUF,17,4,TCIDKY,1,4) 00406^ ^ 203 550 COID=0 00408^ ^ C*** IF SAME COLLECTOR ID AS LAST, THEN SKIP 00410^ ^ 204 CALL CCSCST( TCIDKY,1,4,MSG9,30,4,ICM ) 00412^^ 205 IF( ICM.EQ.0 ) GO TO 566 00413^^ 206 CALL CCSCST( TCIDKY,1,4,IOBUF,1,4,ICM ) 00414^^ 207 IF( ICM.EQ.0 ) GO TO 570 00415^ ^ 208 CALL GETUTI( TCIDKY,IOBUF,IFOUND,IFER,0 ) 00417^^ 209 IF( IFOUND.NE.1 ) GO TO 570 00418^^ 210 IF( IFER.LT.0 ) GO TO 9840 00419^ ^ C COLLECTOR ID WAS NOT FOUND PRINT MESSAGE 00421^^ 211 560 CONTINUE 00422^^ 212 CALL CCSMVA(TFBUF,17,4,MSG9,30,4) 00423^^ 213 CALL CCSMVA(MSG9,1,46,OBUF,1,PLN) 00424^ t FTN 3.3B (OPT = LPC) LTRPRT PAGE 10 DATE: 08/29/84 TIME: 2153 t^ C PRINT MESSAGE COID NOT FOUND 00426^ ^ 214 564 CONTINUE 00428^^ 215 PBUF = EJT 00429^^ 216 CALL SYSPRT( PBUF,1,SYSPRM,0 ) 00430^^ 217 PBUF = DBLSPC 00431^^ 218 CALL SYSPRT( PBUF,2,SYSPRM,0 ) 00432^^ 219 CALL SYSPRT( OBUF,1,SYSPRM,0 ) 00433^^ 220 CALL SYSPRT( PBUF,1,SYSPRM,0 ) 00434^ ^ 221 566 CONTINUE 00436^^ 222 CALL CCSMVA(TFBUF,1,16,MSG9A,39,16) 00437^^ 223 CALL CCSMVA(MSG9A,1,80,OBUF,1,PLN) 00438^ ^ C PRINT ACCOUNT NUMBER OF LETTER NOT PRINTED 00440^ ^ 224 568 CONTINUE 00442^^ 225 CALL SYSPRT( OBUF,1,SYSPRM,0 ) 00443^^ 226 GO TO 500 00444^ ^ C MOVE LETTER CODE(TLR) TO KEY (TLRKY) 00446^ ^ 227 570 CALL CCSMVA(TFBUF, 41, 2, TLRKY, 1, 2) 00448^  ^ C MOVE LETTER ADDRESS CODE (TLAC) TO KEY (TLACKY) 00451^ ^ 228 580 CALL CCSGET(TFBUF, 105, TLACKY) 00453^ t FTN 3.3B (OPT = LPC) LTRPRT PAGE 11 DATE: 08/29/84 TIME: 2153 t^ C*********************************************************************** 00456^^ C 00457^^ C READ LETTER FILE(LTFIL) KEY = TLRKY FROM 00458^^ C TRANSACTION FILE 00459^^ C 00460^^ C*********************************************************************** 00461^ ^ 229 700 CALL CCSCST(TLRKY, 1, 2, TLRWKY, 1, 2, ICOMP) 00463^^ 230 IF(ICOMP .EQ. 0) GO TO 1000 00464^ ^ C NOT EQUAL MOVE KEY TO WORK KEY 00466^ ^ 231 730 CALL CCSMVA(TLRKY, 1, 2, TLRWKY, 1, 2) 00468^ ^ C TLRKY AND TLRWKY NOT EQUAL - READ LETTER FILE 00470^ ^ 232 750 CALL READR(REQ3,LTFILB, TLRKY, ISTAT) 00472^^ 233 IF(AND(ISTAT,WRONKY).EQ.WRONKY.OR.AND(ISTAT,EOF).EQ.EOF) GO TO 780 00473^^ 234 IF( ISTAT.LT.0 ) GO TO 9820 00474^^ 235 GO TO 900 00475^ ^ C NOTIFY OPEATOR UNABLE TO LOCATE REQUESTED LETTER 00477^ ^ 236 780 CALL CCSMVA(TLRWKY,1, 2, MSG10, 34, 2) 00479^^ 237 CALL CCSMVA(TACTKY, 1, 16, MSG10, 61, 16) 00480^^ 238 CALL CCSMVA(MSG10,1,80,OBUF,1,PLN) 00481^^ 239 GO TO 2200 00482^ ^ C INITIALIZE COUNTERS AND ARRAYS 00484^ ^ 240 900 FCOUNT=0 00486^^ 241 FSWICH=0 00487^^ 242 IPOINT=0 00488^^ C DMBUPT=0 00489^^ 243 LCOUNT=0 00490^^ 244 ICOL=0 00491^^ 245 NOF=0 00492^ ^ C MOVE MAXIMUM OF 9 VALID FIELD DESCRIPTIONS TO TABLE FARRAY 00494^ ^ 246 920 IPOINT=IPOINT+3 00496^^ 247 IARAPT=1 00497^^ 248 CALL CCSBLK(FARRAY,54) 00498^ ^ 249 930 DO 990 I=1,9 00500^^ 250 CALL CCSCST(LTFILB,IPOINT,2,FEQ,1,2,ICOMP) 00501^^ 251 935 IF(ICOMP .NE. 0) GO TO 995 00502^ ^ C LTFILB = 'F=' - SET SWITCH AND MOVE POINTER 00504^ ^ 252 940 FSWICH=1 00506^^ 253 IPOINT=IPOINT+2 00507^ ^ C CHECK FOR 'F=NO' - WHICH DESIGNATES A LETTER WITH NO F FIELDS. 00509^t FTN 3.3B (OPT = LPC) LTRPRT PAGE 12 DATE: 08/29/84 TIME: 2153 t ^ 254 950 CALL CCSCST(LTFILB,IPOINT, 1, NO, 1, 1, ICOMP) 00511^^ 255 IF(ICOMP.NE.0) GO TO 960 00512^^ 256 NOF=1 00513^^ 257 IPOINT=IPOINT+1 00514^^ 258 START=IPOINT 00515^^ 259 GO TO 1000 00516^ ^ C STORE IN ARRAY USING LINE NUMBER AS POINTER 00518^ ^ 260 960 CALL CCSMVA(LTFILB, IPOINT, 6, FARRAY, IARAPT, 6) 00520^ ^ C INCREMENT COUNTERS AND POINTERS 00522^ ^ 261 970 IARAPT=IARAPT+6 00524^^ 262 IPOINT=IPOINT+6 00525^^ 263 FCOUNT=FCOUNT+1 00526^ ^ 264 990 CONTINUE 00528^^ 265 995 START=IPOINT 00529^t FTN 3.3B (OPT = LPC) LTRPRT PAGE 13 DATE: 08/29/84 TIME: 2153 t^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 00531^^ C 00532^^ C READ INFORMATION FOR LETTER 00533^^ C 00534^^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 00535^ ^ C*** CHECK IF TO SEND TO COSIGNER OR BORROWER ? 00537^ ^ 266 1000 CONTINUE 00539^^ 267 IF( TLACKY.LT.$31 .OR. TLACKY.GT.$33 ) GO TO 1030 00540^ ^ C SEND TO COSIGNER READ COSIGNER FILE 00542^^ 268 CALL READR(REQ1,DMBUF,TACTKY,ISTAT) 00543^^ 269 IF(AND(ISTAT,WRONKY).EQ.WRONKY) GO TO 1010 00544^^ 270 IF(AND(ISTAT,EOF).EQ.EOF) GO TO 1010 00545^^ 271 IF(ISTAT.LT.0) GO TO 9800 00546^^ 272 GO TO 1020 00547^ ^ C COSIGNER WAS NOT FOUND PRINT MESSAGE 00549^^ 273 1010 CONTINUE 00550^^ 274 CALL CCSMVA( TFBUF,1,16,MSG12,28,16 ) 00551^^ 275 CALL CCSMVA(MSG12,1,80,OBUF,1,PLN ) 00552^^ 276 GO TO 2200 00553^ ^ C SEND TO CORRECT COSIGNER 00555^^ 277 1020 J=((TLACKY-$30)-1)*115 00556^^ 278 CALL CCSMVA(DMBUF,J+20,30,MNAM,1,30) 00557^^ 279 CALL CCSMVA(DMBUF,J+50,30,MADR1,1,30) 00558^^ 280 CALL CCSBLK(MADR2,30) 00559^^ 281 CALL CCSMVA(DMBUF,J+80,20,MCS,1,20) 00560^^ 282 CALL CCSMVA(DMBUF,J+100,5,MZP,1,5) 00561^^ 283 CALL CCSBLK(MBNM,30) 00562^^ 284 CALL CCSGET(DMBUF,J+18,MSLCD) 00563^ ^ C READ DELQMST FOR LETTER FIELDS 00565^^ 285 1030 CONTINUE 00566^^ 286 CALL READR(REQ2,DMBUF,TACTKY,ISTAT) 00567^^ 287 IF(AND(ISTAT,WRONKY).EQ.WRONKY) GO TO 1040 00568^^ 288 IF(AND(ISTAT,EOF).EQ.EOF) GO TO 1040 00569^^ 289 IF(ISTAT.LT.0) GO TO 9810 00570^^ 290 GO TO 1050 00571^ ^ C DID NOT FIND BORROWER PRINT MESSAGE 00573^^ 291 1040 CONTINUE 00574^^ 292 CALL CCSMVA( TFBUF,1,16,MSG7,28,16 ) 00575^^ 293 CALL CCSMVA(MSG7,1,66,OBUF,1,PLN) 00576^^ 294 GO TO 2200 00577^ ^ C CHECK FOR HOME OR BUSINESS 00579^^ C MOVE IN DATA FOR HEADINGS 00580^^ C************************************************************ ???*A03 00581^^ C FIRST MOVE THE LETTER DATE 00582^^ C AND AMOUNT FROM TRANSFL 00583^^ 295 1050 CALL CCSMVA(TFBUF,106,6,DMBUF,842,6) 00584^t FTN 3.3B (OPT = LPC) LTRPRT PAGE 14 DATE: 08/29/84 TIME: 2153 t^ 296 CALL CCSMVA(TFBUF,112,9,DMBUF,848,9) 00585^^ 297 IF(TLACKY.EQ.B) GO TO 1070 00586^^ C*********************************************************** ???*A037 00587^^ C CHECK IF COSIGNER 00588^^ 298 IF(TLACKY .GE. $31 .AND. TLACKY .LE. $33) GO TO 1100 00589^ ^ C SEND TO BORROWERS HOME 00591^^ 299 1060 CALL CCSGET( DMBUF,17,MSLCD ) 00592^^ 300 CALL CCSMVA(DMBUF,18,30,MNAM,1,30) 00593^^ 301 CALL CCSMVA(DMBUF,48,30,MADR1,1,30) 00594^^ 302 CALL CCSMVA(DMBUF,78,30,MADR2,1,30) 00595^^ 303 CALL CCSMVA(DMBUF,108,30,MCS,1,20) 00596^^ 304 CALL CCSMVA(DMBUF,128,5,MZP,1,5) 00597^^ 305 CALL CCSBLK(MBNM,30) 00598^^ 306 GO TO 1100 00599^ ^ C SEND TO BORROWERS BUSINESS ADDRESS 00601^^ 307 1070 CALL CCSMVA(DMBUF,18,30,MNAM,1,30) 00602^^ 308 CALL CCSGET( DMBUF,17,MSLCD ) 00603^^ 309 CALL CCSMVA(DMBUF,177,30,MADR1,1,30) 00604^^ 310 CALL CCSMVA(DMBUF,207,20,MCS,1,20) 00605^^ 311 CALL CCSMVA(DMBUF,227,5,MZP,1,5) 00606^^ 312 CALL CCSMVA(DMBUF,147,30,MBNM,1,30) 00607^^ 313 CALL CCSBLK(MADR2,30) 00608^^ 314 GO TO 1100 00609^t FTN 3.3B (OPT = LPC) LTRPRT PAGE 15 DATE: 08/29/84 TIME: 2153 t^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 00611^^ C 00612^^ C PRINT THE LETTER 00613^^ C 00614^^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 00615^ ^ C PRINT THE TOP 8 LINES 00617^^ 315 1100 CONTINUE 00618^^ 316 PBUF = EJT 00619^^ 317 CALL SYSPRT( PBUF,1,SYSPRM,0 ) 00620^^ 318 PBUF = DBLSPC 00621^^ 319 CALL SYSPRT( PBUF,DATLIN,SYSPRM,0 ) 00622^ ^ C PRINT DATE 00624^^ C BLANK OUT BUFFER RECEIVING CONVERTED DATE 00625^^ 320 1140 CALL CCSBLK( OBUF,PLN ) 00626^^ 321 CALL CCSBLK(DATBUF,26) 00627^^ 322 CALL LTRDTE(DT,DATBUF,1,1) 00628^^ 323 1150 CALL CCSMVA(DATBUF,1,26,OBUF,46,26) 00629^^ 324 OBUF = DBLSPC 00630^^ 325 CALL SYSPRT( OBUF,1,SYSPRM,0 ) 00631^ ^ C PRINT REFERENCE 00633^^ 326 1160 CALL CCSBLK( OBUF(2),PLN-2 ) 00634^^ 327 CALL CCSMVA(REFLIN,1,4,OBUF,46,4) 00635^ ^ C CHECK ACCOUNT SWITCH IN LTRF 00637^^ 328 1170 CALL CCSCST(LTRFBF,5,1,TWO,2,1,ICOMP) 00638^^ 329 CALL CCSMVA(TFBUF,2,15,OBUF,51,15) 00639^^ 330 IF(ICOMP.EQ.0) GO TO 1180 00640^^ 331 CALL CCSMVA(TFBUF,1,1,OBUF,50,1) 00641^^ 332 1180 CONTINUE 00642^^ 333 CALL SYSPRT( OBUF,1,SYSPRM,0 ) 00643^ ^ C GET SALUTATION 00645^^ C ****************************************************** ???*A034 00646^^ 334 1190 SALLEN = 1 00647^^ 335 CALL CCSBLK (FULNAM, 40) 00648^^ 336 CALL CCSBLK (LASNAM, 30) 00649^^ C CHECK FOR NON-LEGAL SALUTATION CODE 00650^^ 337 IF (MSLCD .LT. $31 .OR. MSLCD .GT. $38) GO TO 1220 00651^^ 338 MSLCD = MSLCD - $30 00652^^ C ****************************************************** ???*A034 00653^^ 339 N=(MSLCD-1)*8+1 00654^^ 340 CALL CCSMVA(SALARA,N,8,FULNAM,1,8) 00655^ ^ C FIND END OF SALUTATION 00657^^ 341 1200 DO 1210 I=1,8 00658^^ 342 CALL CCSCST(FULNAM,I,1,BLANK,1,1,ICOMP) 00659^^ 343 IF(ICOMP.EQ.0) GO TO 1215 00660^^ 344 1210 CONTINUE 00661^^ 345 1215 IF(I.GT.1) GO TO 1216 00662^^ 346 SALLEN=1 00663^^ 347 GO TO 1220 00664^t FTN 3.3B (OPT = LPC) LTRPRT PAGE 16 DATE: 08/29/84 TIME: 2153 t^ 348 1216 SALLEN=I+1 00665^ ^ C FIND END OF LAST NAME 00667^^ 349 1220 DO 1230 I=1,30 00668^^ 350 CALL CCSCST(MNAM,I,1,COMMA,1,1,ICOMP) 00669^^ 351 IF(ICOMP.EQ.0) GO TO 1250 00670^^ 352 1230 CONTINUE 00671^ ^ C COMMA NOT FOUND PRINT AS IS 00673^^ 353 CALL CCSMVA(MNAM,1,30,FULNAM,SALLEN,30) 00674^ ^ C FIND END OF NAME 00676^^ 354 DO 1245 FULLEN=30,1,-1 00677^^ 355 CALL CCSCST(FULNAM,FULLEN,1,BLANK,1,1,ICOMP) 00678^^ 356 IF(ICOMP.NE.0) GO TO 1246 00679^^ 357 1245 CONTINUE 00680^^ 358 FULLEN=30 00681^^ 359 1246 GO TO 1290 00682^ ^ C MOVE LAST NAME INTO BUFFER 00684^^ 360 1250 LASLEN=I-1 00685^^ 361 CALL CCSMVA(MNAM,1,LASLEN,LASNAM,1,LASLEN) 00686^  ^ C FIND FIRST NAME 00689^^ 362 1260 N1=I+1 00690^^ 363 DO 1262 I=N1,30 00691^^ 364 CALL CCSCST(MNAM,I,1,BLANK,1,1,ICOMP) 00692^^ 365 IF(ICOMP.NE.0) GO TO 1264 00693^^ 366 1262 CONTINUE 00694^ ^ C NO FIRST NAME 00696^^ 367 CALL CCSMVA(MNAM,1,LASLEN,FULNAM,SALLEN,LASLEN) 00697^^ 368 FULLEN=LASLEN+SALLEN 00698^^ 369 GO TO 1290 00699^ ^ C FOUND FIRST NAME, FIND END OF FIRST NAME 00701^^ 370 1264 N1=I 00702^^ 371 DO 1266 I=N1,30 00703^^ 372 CALL CCSCST(MNAM,I,1,BLANK,1,1,ICOMP) 00704^^ 373 IF(ICOMP.EQ.0) GO TO 1275 00705^^ 374 1266 CONTINUE 00706^ ^ C DID NOT FIND END OF FIRST NAME 00708^^ 375 FIRLEN=30-N1+1 00709^^ 376 GO TO 1280 00710^ ^ C SEE IF THERE IS MIDDLE INITIAL 00712^^ 377 1275 CALL CCSCST(MNAM,I+1,1,BLANK,1,1,ICOMP) 00713^^ 378 IF(ICOMP.NE.0) GO TO 1276 00714^ ^ C NO MIDDLE INITIAL 00716^^ 379 FIRLEN=I-N1 00717^^ 380 GO TO 1280 00718^t FTN 3.3B (OPT = LPC) LTRPRT PAGE 17 DATE: 08/29/84 TIME: 2153 t ^ C INCLUDE MIDDLE INITIAL IN FIRST NAME 00720^^ 381 1276 FIRLEN=I-N1+2 00721^ ^ C MOVE FIRST NAME, MI AND LAST INTO FULNAM 00723^^ 382 1280 FULLEN=SALLEN 00724^^ 383 CALL CCSMVA( MNAM,N1,FIRLEN,FULNAM,FULLEN,FIRLEN) 00725^^ 384 FULLEN=FULLEN+FIRLEN+1 00726^^ 385 CALL CCSMVA(LASNAM,1,LASLEN,FULNAM,FULLEN,LASLEN) 00727^^ 386 FULLEN=FULLEN+LASLEN-1 00728^ ^ C PRINT 2 BLANK LINES 00730^^ 387 1290 CONTINUE 00731^^ 388 CALL SYSPRT( PBUF,1,SYSPRM,0 ) 00732^ ^ C PRINT NAME 00734^^ 389 1300 CALL CCSBLK(OBUF,PLN) 00735^^ 390 CALL CCSMVA(FULNAM,1,30,OBUF,MARGIN,30) 00736^ ^ 391 CALL SYSPRT( OBUF,1,SYSPRM,0 ) 00738^ ^ C IF SENT TO BUSINESS PRINT C/O LINE 00740^^ 392 1320 CALL CCSBLK( OBUF,PLN ) 00741^^ 393 IF(TLACKY.NE.B) GO TO 1330 00742^^ 394 CALL CCSMVA(COF,1,4,OBUF,MARGIN,4) 00743^^ 395 CALL CCSMVA(MBNM,1,30,OBUF,MARGIN+5,30) 00744^ ^ 396 CALL SYSPRT( OBUF,1,SYSPRM,0 ) 00746^ ^ C PRINT ADDRESS 1 00748^^ 397 1330 CALL CCSBLK( OBUF,PLN ) 00749^^ 398 CALL CCSMVA(MADR1,1,30,OBUF,MARGIN,30) 00750^ ^ 399 CALL SYSPRT( OBUF,1,SYSPRM,0 ) 00752^ ^ C IF THERE IS A ADDRESS 2 PRINT IT 00754^^ 400 1340 CALL CCSCST(MADR2,1,10,BLANK,1,10,ICOMP) 00755^^ 401 IF(ICOMP.EQ.0) GO TO 1350 00756^^ 402 CALL CCSBLK( OBUF,PLN ) 00757^^ 403 CALL CCSMVA(MADR2,1,30,OBUF,MARGIN,30) 00758^ ^ 404 CALL SYSPRT( OBUF,1,SYSPRM,0 ) 00760^ ^ C PRINT MCS AND ZIP 00762^^ 405 1350 CALL CCSBLK( OBUF,PLN ) 00763^^ 406 CALL CCSMVA(MCS,1,20,OBUF,MARGIN,20) 00764^^ 407 CALL CCSMVA(MZP,1,5,OBUF,MARGIN+22,5) 00765^^ 408 1355 CONTINUE 00766^^ 409 CALL SYSPRT( OBUF,1,SYSPRM,0 ) 00767^ ^ C PRINT 2 BLANK LINES 00769^^ 410 1360 CALL CCSBLK(OBUF,PLN) 00770^ ^ 411 CALL SYSPRT( PBUF,1,SYSPRM,0 ) 00772^t FTN 3.3B (OPT = LPC) LTRPRT PAGE 18 DATE: 08/29/84 TIME: 2153 t ^ 412 1370 CONTINUE 00774^t FTN 3.3B (OPT = LPC) LTRPRT PAGE 19 DATE: 08/29/84 TIME: 2153 t^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 00776^^ C 00777^^ C BUILD BODY OF THE LETTER 00778^^ C 00779^^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 00780^ ^ 413 1400 CALL CCSBLK(LTRARR,1520) 00782^^ 414 IPOINT=START 00783^^ 415 IAT=0 00784^^ 416 CC=2 00785^^ 417 1405 DO 1650 I=1,24 00786^^ 418 IPOS=IPOINT 00787^^ 419 LB=(I-1)*60+1 00788^^ 420 LW=(I-1)*30+1 00789^^ 421 LINCT=I 00790^ ^ C CHECK FOR END 00792^^ 422 1430 CALL CCSCST(LTFILB,IPOINT,3,IEND,1,3,ICOMP) 00793^^ 423 IF(ICOMP.EQ.0) GO TO 1660 00794^ ^ C IF FIRST LINE, GO CHECK FOR @ 00796^^ 424 1440 IF(LINCT.EQ.1) GO TO 1500 00797^ ^ C LOOK FOR CARRIAGE CONTROL AND LENGTH 00799^^ 425 1450 DO 1470 J=1,MAXLEN 00800^ ^ C MOVE IN CARRIAGE CONTROL FOR LAST LINE 00802^^ 426 LTRARR(LW)=CC 00803^ ^ C GET BYTE AND CHECK FOR * 00805^^ 427 1460 CALL CCSGET(LTFILB,IPOINT,N) 00806^^ 428 1465 IF(N.EQ.ASTRSK) GO TO 1480 00807^^ 429 IPOINT=IPOINT+1 00808^ ^ C END OF ASTERSK SEARCH LOOP 00810^^ 430 1470 CONTINUE 00811^ ^ C BYTE WAS * GET CARRIAGE CONTROL 00813^^ 431 1480 LENGTH=IPOINT-IPOS 00814^^ 432 IPOINT=IPOINT+2 00815^^ 433 CALL CCSGET(LTFILB,IPOINT,N) 00816^^ 434 CC=N-$30 00817^ ^ C MOVE IN THE TEXT AND GET NEXT LINE 00819^^ 435 1490 CALL CCSMVA(LTFILB,IPOS,LENGTH,LTRARR,LB+2,LENGTH) 00820^^ 436 GO TO 1640 00821^t FTN 3.3B (OPT = LPC) LTRPRT PAGE 20 DATE: 08/29/84 TIME: 2153 t ^ C FIRST LINE ONLY 00824^^ C CHECK FOR @ 00825^^ 437 1500 DO 1630 J=1,MAXLEN 00826^ ^ C MOVE IN CARRIAGE CONTROL FROM LAST LINE 00828^^ 438 LTRARR(LW)=CC 00829^ ^ C GET BYTE AND CHECK FOR @ 00831^^ 439 1510 CALL CCSGET(LTFILB,IPOINT,N) 00832^^ 440 1520 IF(N.NE.AT) GO TO 1600 00833^ ^ C BYTE WAS @ MOVE IN TEXT BEFORE @ 00835^^ 441 1530 LENGTH=IPOINT-IPOS 00836^^ 442 IAT=1 00837^^ 443 CALL CCSMVA(LTFILB,IPOS,LENGTH,LTRARR,LB+2,LENGTH) 00838^^ 444 LB=LB+LENGTH 00839^^ 445 IPOINT=IPOINT+1 00840^ ^ C GET NAME TYPE 00842^^ 446 1540 CALL CCSGET(LTFILB,IPOINT,N) 00843^^ 447 NAMSW=N-$30 00844^^ 448 IPOINT=IPOINT+1 00845^ ^ C GET PUNCUATION 00847^^ 449 1550 CALL CCSGET(LTFILB,IPOINT,N) 00848^^ 450 PUN=N 00849^^ 451 IPOINT=IPOINT+3 00850^ ^ C GET CARRIAGE CONTROL 00852^^ 452 1560 CALL CCSGET(LTFILB,IPOINT,N) 00853^^ 453 CC=N-$30 00854^ ^ C MOVE IN THE NAME 00856^^ 454 1570 IF(NAMSW.EQ.2.AND.SALLEN.GT.1) GO TO 1580 00857^^ 455 CALL CCSMVA(FULNAM,1,FULLEN,LTRARR,LB+2,FULLEN) 00858^^ 456 LB=LB+2+FULLEN 00859^^ 457 GO TO 1590 00860^^ C SET UP CORRECT SPACING FOR SALUTATION 00861^^ 458 1580 SALLEN = SALLEN - 1 00862^^ 459 CALL CCSMVA(FULNAM,1,SALLEN,LTRARR,LB+2,SALLEN) 00863^^ 460 LB=LB+SALLEN 00864^^ 461 CALL CCSMVA(LASNAM,1,LASLEN,LTRARR,LB+2,LASLEN) 00865^^ 462 LB=LB+LASLEN+2 00866^ ^ C MOVE IN PUNCUATION AND GET NEXT LINE 00868^^ 463 1590 CALL CCSMVA(PUN,2,1,LTRARR,LB,1) 00869^^ 464 GO TO 1640 00870^ ^ C WAS NOT @ CHECK FOR * 00872^^ 465 1600 IF(N.NE.ASTRSK) GO TO 1620 00873^ ^ C WAS * GET CARRIAGE CONTROL 00875^^ 466 IPOINT=IPOINT+2 00876^t FTN 3.3B (OPT = LPC) LTRPRT PAGE 21 DATE: 08/29/84 TIME: 2153 t^ 467 CALL CCSGET(LTFILB,IPOINT,N) 00877^^ 468 CC=N-$30 00878^ ^ C CHECK IF @ WAS FOUND 00880^^ 469 1610 IF(IAT.EQ.1) GO TO 1640 00881^ ^ C NO @ WAS FOUND TREAT AS REGULAR LINE 00883^^ 470 1615 LENGTH=IPOINT-IPOS-2 00884^^ 471 GO TO 1490 00885^ ^ 472 1620 IPOINT=IPOINT+1 00887^ ^ C END OF FIRST ONLY LOOP 00889^^ 473 1630 CONTINUE 00890^ ^ C END OF BUILD LETTER BODY LOOP 00892^^ 474 1640 IPOINT=IPOINT+1 00893^^ 475 1650 CONTINUE 00894^t FTN 3.3B (OPT = LPC) LTRPRT PAGE 22 DATE: 08/29/84 TIME: 2153 t^ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 00896^^ C 00897^^ C BODY FOR LETTER HAS BEEN BUILT 00898^^ C PUT IN PLUGS 00899^^ C 00900^^ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 00901^ ^ 476 1660 DO 1710 I=1,9 00903^^ 477 IW=(I-1)*3+1 00904^^ 478 1665 IF(FARRAY(IW).EQ.BLANK) GO TO 1730 00905^^ 479 LINE=FARRAY(IW)/$100 00906^^ 480 COL=AND(FARRAY(IW),$FF) 00907^^ 481 LB=(LINE-1)*60+COL+2 00908^^ 482 LENGTH=FARRAY(IW+1)/$100 00909^^ 483 TYPE=AND(FARRAY(IW+1),$FF) 00910^^ 484 POS=AND(FARRAY(IW+2),$FFFF) 00911^ ^ C CHECK FOR WHICH TYPE OF PLUG 00913^^ 485 1670 IF(TYPE.EQ.D) GO TO 1680 00914^^ 486 IF(TYPE.EQ.DOL) GO TO 1690 00915^^ 487 IF(TYPE.EQ.A) GO TO 1700 00916^^ 488 GO TO 1700 00917^ ^ C TYPE WAS DATE MOVE IN DATE 00919^^ C IF MASTER FILE POS IS ZERO, USE CURRENT DATE 00920^^ 489 1680 IF (POS .NE. $0000) GO TO 1682 00921^^ 490 CALL EDIT (DT, 1, LTRARR, LB, 1) 00922^^ 491 GO TO 1710 00923^^ C CHECK TYPE OF DATE TO PRINT 00924^^ 492 1682 IF(LENGTH.EQ.2.OR.LENGTH.EQ.1) GO TO 1685 00925^^ 493 IF(IDATVR(DMBUF,POS).LT.0) GO TO 1710 00926^^ 494 CALL EDIT(DMBUF,POS,LTRARR,LB,1) 00927^^ 495 GO TO 1710 00928^^ 496 1685 CALL CCSMVA(DMBUF,POS,6,BUF,1,6) 00929^^ 497 IF(IDATVR(BUF,1).LT.0) GO TO 1710 00930^^ C DATE TYPE EQUAL 1 OR 2 00931^^ 498 CALL CCSBLK(DATBUF,18) 00932^^ 499 CALL LTRDTE(BUF,DATBUF,1,LENGTH) 00933^^ 500 IF(LENGTH.EQ.1) CALL CCSMVA(DATBUF,1,18,LTRARR,LB,18) 00934^^ 501 IF(LENGTH.EQ.2) CALL CCSMVA(DATBUF,1,12,LTRARR,LB,12) 00935^^ 502 GO TO 1710 00936^ ^ C TYPE WAS DOLLAR,CENTER AND MOVE IN $ 00938^^ 503 1690 CALL CCSBLK(BUF,12) 00939^^ 504 CALL CCSMVA(BLANK,1,11,LTRARR,LB,11) 00940^^ 505 CALL EDIT(DMBUF,POS,BUF,1,3) 00941^ ^ 506 DO 1692 J=1,10 00943^^ 507 CALL CCSCST(BUF,J,1,BLANK,1,1,ICOMP) 00944^^ 508 IF(ICOMP.NE.0) GO TO 1694 00945^^ 509 1692 CONTINUE 00946^^ 510 1694 LB=LB+((10-(10-J))/2) 00947^^ 511 CALL CCSMVA(DOL,2,1,LTRARR,LB,1) 00948^^ 512 N1=10-J+1 00949^t FTN 3.3B (OPT = LPC) LTRPRT PAGE 23 DATE: 08/29/84 TIME: 2153 t^ 513 CALL CCSMVA(BUF,J,N1,LTRARR,LB+1,N1) 00950^^ 514 GO TO 1710 00951^ ^ C TYPE WAS ALPHA MOVE IN STRING 00953^^ 515 1700 CALL CCSMVA(DMBUF,POS,LENGTH,LTRARR,LB,LENGTH) 00954^ ^ C END OF PLUG LOOP 00956^^ 516 1710 CONTINUE 00957^^ C PRINT THE BODY OF THE LETTER 00958^^ 517 1730 DO 1830 I=1,24 00959^^ 518 LB=(I-1)*60+1 00960^^ 519 LW=(I-1)*30+1 00961^^ 520 1740 IF(LTRARR(LW).EQ.$2020) GO TO 2000 00962^^ 521 CC=LTRARR(LW) 00963^ ^ C CC IS NUMBER OF BLANK LINES TO PRINT 00965^^ 522 1750 CONTINUE 00966^^ 523 CALL CCSBLK( OBUF,PLN ) 00967^^ 524 IF ( CC.LE.1 ) GO TO 1810 00968^ ^ 525 OBUF = DBLSPC 00970^^ 526 IF ( CC.EQ.2 ) GO TO 1810 00971^ ^ 527 ICC = CC/2 00973^^ 528 CC = CC - ICC*2 00974^^ 529 IF( CC.EQ.0 ) ICC = ICC-1 00975^^ 530 IF( CC.EQ.0 ) CC = 2 00976^ ^ 531 CALL SYSPRT( OBUF,ICC,SYSPRM,0 ) 00978^^ 532 GO TO 1750 00979^ ^ C MOVE IN A LINE OF TEXT AND PRINT 00981^^ 533 1810 CONTINUE 00982^^ 534 CALL CCSMVA( LTRARR,LB+2,58,OBUF,MARGIN,58 ) 00983^ ^ 535 CALL SYSPRT( OBUF,1,SYSPRM,0 ) 00985^ ^ C END OF PRINT LOOP 00987^^ 536 1830 CONTINUE 00988^  ^ C PRINT 2 LINES 00990^^ 537 2000 CONTINUE 00991^^ 538 CALL SYSPRT( PBUF,1,SYSPRM,0 ) 00992^^ 539 CALL CCSBLK( OBUF,PLN ) 00993^ ^ C GET COID SALUTATION 00995^^ C************************************************************** ???*A041 00996^^ 540 2010 TCIDSC = 0 00997^^ 541 CALL CCSMVA(IOBUF,21,1,TCIDSC,2,1) 00998^^ C************************************************************** ???*A041 00999^^ 542 TCIDSC=TCIDSC-$30 01000^^ 543 N=MARGIN+27 01001^^ C************************************************************** ???*A042 01002^t FTN 3.3B (OPT = LPC) LTRPRT PAGE 24 DATE: 08/29/84 TIME: 2153 t^ 544 2020 IF(TCIDSC.LE.0) GO TO 2051 01003^^ C************************************************************** ???*A042 01004^^ 545 J=(TCIDSC-1)*8+1 01005^^ 546 CALL CCSMVA(SALARA,J,8,OBUF,N,8) 01006^ ^ C FIND END OF SALUTATION 01008^^ 547 2030 DO 2040 I=1,8 01009^^ 548 J=N+I 01010^^ 549 CALL CCSCST(OBUF,J,1,BLANK,1,1,ICOMP) 01011^^ 550 IF(ICOMP.EQ.0) GO TO 2050 01012^^ 551 2040 CONTINUE 01013^ ^ C MOVE IN FIRST INITIAL 01015^^ 552 2050 N=N+I+1 01016^^ C************************************************************** ???*A042 01017^^ 553 2051 CALL CCSMVA(IOBUF,20,1,OBUF,N,1) 01018^^ C************************************************************** ???*A042 01019^ ^ C MOVE IN LAST NAME 01021^^ 554 2060 N=N+2 01022^^ 555 CALL CCSMVA(IOBUF,5,15,OBUF,N,15) 01023^ ^ C PRINT COID 01025^^ 556 2070 CONTINUE 01026^^ 557 CALL SYSPRT( OBUF,1,SYSPRM,0 ) 01027^ ^ C PRINT PHONE NUMBER 01029^^ 558 2080 N=MARGIN+27 01030^^ C IF THERE IS A PHONE NUMBER, PRINT IT 01031^^ 559 CALL CCSCST (IOBUF, 22, 10, BLANK, 1, 10, ICOMP) 01032^^ 560 IF (ICOMP .EQ. 0) GO TO 2090 01033^^ 561 CALL CCSBLK(OBUF(2),130) 01034^^ 562 CALL EDIT(IOBUF,22,OBUF,N,4) 01035^ ^ 563 CALL SYSPRT( OBUF,1,SYSPRM,0 ) 01037^ ^ C IF THERE IS AN EXTENSION PRINT IT 01039^^ 564 2090 CALL CCSCST(IOBUF,32,4,BLANK,1,4,ICOMP) 01040^^ 565 IF(ICOMP.EQ.0) GO TO 2100 01041^^ 566 CALL CCSBLK(OBUF(2),130) 01042^^ 567 CALL CCSMVA(EXT,1,3,OBUF,N,3) 01043^^ 568 CALL CCSMVA(IOBUF,32,4,OBUF,N+4,4) 01044^ ^ 569 CALL SYSPRT( OBUF,1,SYSPRM,0 ) 01046^ ^ C PRINT LTRF STRING 01048^^ 570 2100 CONTINUE 01049^^ 571 CALL CCSBLK( OBUF,PLN ) 01050^^ 572 CALL CCSMVA(LTRFBF,6,30,OBUF,N,30) 01051^ ^ 573 OBUF = DBLSPC 01053^^ 574 CALL SYSPRT( OBUF,1,SYSPRM,0 ) 01054^ ^ 575 2110 CONTINUE 01056^t FTN 3.3B (OPT = LPC) LTRPRT PAGE 25 DATE: 08/29/84 TIME: 2153 t ^ C GO GET NEXT TRANSACTION 01058^^ 576 2120 GO TO 500 01059^  ^ C PRINT ERROR MESSAGE 01061^^ 577 2200 CONTINUE 01062^^ 578 PBUF = EJT 01063^^ 579 CALL SYSPRT( PBUF,1,SYSPRM,0 ) 01064^^ 580 PBUF = DBLSPC 01065^^ 581 CALL SYSPRT( PBUF,2,SYSPRM,0 ) 01066^^ 582 CALL SYSPRT( OBUF,1,SYSPRM,0 ) 01067^ ^ 583 GO TO 500 01069^ ^ C**** DONE PRINT TWO PAGE EJECTS...... 01071^ ^ 584 3000 CONTINUE 01073^^ 585 PBUF = EJT 01074^^ 586 CALL SYSPRT( PBUF,2,SYSPRM,0 ) 01075^^ 587 GO TO 9900 01076^t FTN 3.3B (OPT = LPC) LTRPRT PAGE 26 DATE: 08/29/84 TIME: 2153 t ^ C**** ERROR SECTION FILE 1 01079^^ 588 9800 CONTINUE 01080^^ 589 IREQ = AND(REQ1(4),$FF) 01081^^ 590 IF (IREQ.LT.11) IREQ = IREQ-1 01082^^ 591 IF (IREQ.EQ.18) IREQ = 10 01083^^ 592 CALL FILERR( DAT1,IREQ,ISTAT,LU ) 01084^^ 593 IERR = 1 01085^^ 594 GO TO 9900 01086^ ^ C**** ERROR SECTION FILE 2 01088^^ 595 9810 CONTINUE 01089^^ 596 IREQ = AND(REQ2(4),$FF) 01090^^ 597 IF (IREQ.LT.11) IREQ = IREQ-1 01091^^ 598 IF (IREQ.EQ.18) IREQ = 10 01092^^ 599 CALL FILERR( DAT2,IREQ,ISTAT,LU ) 01093^^ 600 IERR = 1 01094^^ 601 GO TO 9900 01095^ ^ C**** ERROR SECTION FILE 3 01097^^ 602 9820 CONTINUE 01098^^ 603 IREQ = AND(REQ3(4),$FF) 01099^^ 604 IF (IREQ.LT.11) IREQ = IREQ-1 01100^^ 605 IF (IREQ.EQ.18) IREQ = 10 01101^^ 606 CALL FILERR( DAT3,IREQ,ISTAT,LU ) 01102^^ 607 IERR = 1 01103^^ 608 GO TO 9900 01104^ ^ C**** ERROR SECTION FILE 4 01106^^ 609 9830 CONTINUE 01107^^ 610 IREQ = AND(REQ4(4),$FF) 01108^^ 611 IF (IREQ.LT.11) IREQ = IREQ-1 01109^^ 612 IF (IREQ.EQ.18) IREQ = 10 01110^^ 613 CALL FILERR( DAT4,IREQ,ISTAT,LU ) 01111^^ 614 IERR = 1 01112^^ 615 GO TO 9900 01113^ ^ C**** ERROR SECTION FILE 5 01115^^ 616 9840 CONTINUE 01116^^ 615 GO TO 9900 01113^ ^ C**** ERROR SECTION FILE 5 01115^^ 616 9840 CONTINUE 01116^^ 617 IERR = 1 01117^^ 618 GO TO 9900 01118^ ^ C CLOSE FILES AND EXIT 01120^^ 619 9900 CONTINUE 01121^^ 620 CALL CLOSFL(REQ3,ISTAT) 01122^^ 621 CALL CLOSFL(REQ4,ISTAT) 01123^^ 622 CALL CLOSFL(REQ2,ISTAT) 01124^^ 623 CALL CLOSFL(REQ1,ISTAT) 01125^^ 624 CALL GETUTI( ISTAT,ISTAT,IFOUND,IFER,2 ) 01126^^ 625 CALL SYSPRT( ISTAT,0,SYSPRM,1 ) 01127^ ^ C EXIT 01129^^ 626 CALL PGMOUT 01130^^ 627 END 01131^t FTN 3.3B (OPT = LPC) LTRPRT PAGE 27 DATE: 08/29/84 TIME: 2153 t  PROGRAM LENGTH $1860 ( 6240)   EXTERNALS 2 Q8STP ADAYTO AMONTO AYERTO PGMINT PGMIN CCSCST 22 CCSMVA GTSYSP PRTORF GETGRP SYSPRT OPENFL CCSBLK 22 WTREAD GETUTI READR GETS ICKGRP CCSGET LTRDTE 2& EDIT IDATVR FILERR CLOSFL PGMOUT & t FTN 3.3B (OPT = LPC) LTRPRT PAGE 28 DATE: 08/29/84 TIME: 2153 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < . FFFF (65535) 0E6E 108,109,110,484.€ 0000 (0) 0003 5,10,12,16,21,25,33,37,39,41,43,46,48,50,54,56,86,92,102,106,107,112,114,117,120,121,122,123,124,€€ 125,132,139,140,147,148,153,163,177,179,181,183,186,189,192,195,197,199,203,205,207,208,210,216, €€ 218,219,220,225,230,234,240,241,242,243,244,245,251,255,271,289,317,319,325,330,333,343,351,356, €€ 365,373,378,388,391,396,399,401,404,409,411,415,423,489,493,497,508,529,530,531,535,538,540,544, €N 550,557,560,563,565,569,574,579,581,582,586,625N‚ 0001 (1) 0002 16,33,85,86,91,93,94,95,96,102,108,116,119,128,129,130,132,135,136,141,143,145,149,151,153,158,159 ‚€ ,166,168,169,178,180,182,185,196,198,200,201,202,204,206,209,213,216,219,220,222,223,225,227,229,€€ 231,236,237,238,247,249,250,252,254,256,257,263,274,275,277,278,279,281,282,292,293,300,301,302, €€ 303,304,307,309,310,311,312,317,322,323,325,327,328,331,333,334,339,340,341,342,345,346,348,349, €€ 350,353,354,355,360,361,362,364,367,372,375,377,384,385,386,388,390,391,394,395,396,398,399,400, €€ 403,404,406,407,409,411,417,419,420,422,424,425,429,437,442,445,448,454,455,458,459,461,463,469, €€ 472,474,476,477,481,482,483,490,492,494,496,497,499,500,501,504,505,506,507,511,512,513,517,518, €€ 519,524,529,535,538,541,545,547,549,552,553,557,559,563,564,567,569,574,579,582,590,593,597,600, €6 604,607,611,614,617,6256‚ 0002 (2) 0E66 91,109,128,129,165,169,180,182,191,196,198,218,227,229,231,236,250,253,326,328,329,381,416,432,435 ‚€ ,443,454,455,456,459,461,462,463,466,470,481,484,492,501,510,511,526,527,528,530,534,541,554,561,€. 566,581,586,624.6 0003 (3) 0E87 246,422,451,477,505,5676Z 0004 (4) 0E77 143,143,202,204,206,212,327,394,562,564,568,589,596,603,610Z> 0005 (5) 0E79 145,282,304,311,328,395,407,555>: 0006 (6) 0E8B 260,260,261,262,295,496,572:J 0008 (8) 0E67 91,93,94,95,96,129,339,340,341,545,546,547 J* 0009 (9) 0E8A 249,296,476*F 000A (10) 0EA2 400,400,506,510,512,559,591,598,605,612F6 000B (11) 0EAD 504,504,590,597,604,6116* 000C (12) 0E71 130,501,503** 000F (15) 0E9D 329,329,555*N 0010 (16) 0E69 93,94,95,96,166,178,185,190,201,222,237,274,292N. 0011 (17) 0E81 202,212,299,308.B 0012 (18) 0E91 284,300,307,498,500,591,598,605,612B> 0014 (20) 0E78 143,164,278,281,303,310,406,553>" 0015 (21) 0EB1 541"* 0016 (22) 0EA3 407,559,562*& 0019 (25) 0E6A 98,102 &* 001A (26) 0E6B 99,321,323 ** 001C (28) 0E7F 185,274,292*& 001D (29) 0E7D 180,196&€ 001E (30) 0E82 204,212,278,279,280,283,300,301,302,303,305,307,309,312,313,336,349,353,354,358,363,371,375,390, €6 395,398,403,420,519,5726& 0020 (32) 0EB3 564,568&" 0022 (34) 0E85 236"" 0027 (39) 0E83 222"" 0028 (40) 0E9E 335"* 0029 (41) 0E7E 182,198,227*. 002E (46) 0E7B 151,213,323,327.t FTN 3.3B (OPT = LPC) LTRPRT PAGE 29 DATE: 08/29/84 TIME: 2153 t> 0030 (48) 0E8E 277,301,338,434,447,453,468,542>& 0032 (50) 0E90 279,331&* 0033 (51) 0E8C 267,298,329*" 0036 (54) 0E88 248"& 003A (58) 0EB0 534,534&2 003C (60) 0E70 130,130,419,481,5182" 003D (61) 0E86 237"" 003E (62) 0E73 134"& 0041 (65) 0E7A 145,145&& 0042 (66) 0E80 186,293&" 004E (78) 0E96 302"J 0050 (80) 0E72 133,134,156,157,161,163,164,223,238,275,281J" 0069 (105) 0E84 228"" 006A (106) 0E92 295"" 006C (108) 0E97 303"" 0070 (112) 0E94 296"" 0073 (115) 0E8F 277"" 0080 (128) 0E98 304"& 0082 (130) 0EB2 561,566&" 0093 (147) 0E9C 312"" 00B1 (177) 0E99 309"" 00CF (207) 0E9A 310"" 00E3 (227) 0E9B 311"6 00FF (255) 0EAC 480,483,589,596,603,6106" 034A (842) 0E93 295"" 0350 (848) 0E95 296"" 05F0 (1520) 0EA4 413"" 0A20 (2592) 0E6D 104"" 0C20 (3104) 0E6C 103"" 2020 (8224) 0EAE 520"   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < ( A INTEGER 0C16 17,19,487(( ACCTNO INTEGER 0CC8 56,58,164(b AND INTR.FN. 7FFF 108,109,110,176,194,233,269,270,287,288,480,483,484,589,596,603,610b0 ASTRSK INTEGER 0C17 17,19,129,428,4650( AT INTEGER 0C18 17,19,440(, B INTEGER 0C19 17,19,297,393,\ BLANK INTEGER 0C1A 19,21,182,198,342,355,364,372,377,400,478,504,507,549,559,564\> BUF INTEGER 0004 1,3,496,497,499,503,505,507,513>X CC INTEGER 0C27 19,21,416,426,434,438,453,468,521,524,526,527,528,529,530X( COF INTEGER 0E49 80,82,394(( COID INTEGER 0C26 19,21,203(, COL INTEGER 0C44 35,37,480,481,( COLCPO INTEGER 0C45 35,37,121(( COMMA INTEGER 0C24 19,21,350(( D INTEGER 0C2D 23,25,485(2 DAT1 INTEGER 0BCA 14,16,91,93,118,59220 DAT2 INTEGER 0BD9 14,16,94,115,599 0t FTN 3.3B (OPT = LPC) LTRPRT PAGE 30 DATE: 08/29/84 TIME: 2153 t0 DAT3 INTEGER 0BE8 14,16,95,111,606 00 DAT4 INTEGER 0BF7 14,16,96,113,613 0> DATBUF INTEGER 000A 1,3,321,322,323,498,499,500,501>( DATLIN INTEGER 0C28 21,23,319(@ DBLSPC INTEGER 0C2C 21,23,104,217,318,324,525,573,580@‚ DMBUF INTEGER 0017 1,268,278,279,281,282,284,286,295,296,299,300,301,302,303,304,307,308,309,310,311,312,493,494,496, ‚& 505,515&, DOL INTEGER 0C2E 23,25,486,511,8 DT INTEGER 0C2F 23,25,108,109,110,322,49088 EJT INTEGER 0C2B 21,23,103,215,316,578,58588 EOF INTEGER 0C32 23,25,176,194,233,270,2888( EXT INTEGER 0C33 23,26,567(B FARRAY INTEGER 03FF 3,5,248,260,478,479,480,482,483,484B, FCOUNT INTEGER 0C46 37,39,240,263,( FEQ INTEGER 0C35 23,26,250(6 FIRLEN INTEGER 0C29 21,375,379,381,383,384 6, FSWICH INTEGER 0C47 37,39,241,252,N FULLEN INTEGER 0C2A 21,354,355,358,368,382,383,384,385,386,455,456 NN FULNAM INTEGER 041A 3,5,335,340,342,353,355,367,383,385,390,455,459N* GRPBUF INTEGER 0E55 86,101,200 *€ I INTEGER 0E89 248,341,342,345,348,349,350,360,362,363,364,370,371,372,377,379,381,417,419,420,421,476,477,517, €2 518,519,547,548,5522( IADR INTEGER 0C49 37,39,89 (* IALL INTEGER 0E64 86,101,200 *0 IARAPT INTEGER 0C48 37,39,247,260,2610. IAT INTEGER 0EA5 414,415,442,469.2 ICC INTEGER 0EAF 526,527,528,529,53128 ICM INTEGER 0E68 91,92,106,204,205,206,2078( ICOL INTEGER 0C4B 39,41,244(€ ICOMP INTEGER 0E7C 178,179,180,181,182,183,196,197,198,199,229,230,250,251,254,255,328,330,342,343,350,351,355,356, €f 364,365,372,373,377,378,400,401,422,423,507,508,549,550,559,560,564,565f, ICTLD INTEGER 0C4A 37,39,89,189 ,( IEND INTEGER 0C36 26,28,422(6 IERR INTEGER 0EB5 592,593,600,607,614,6176: IFER INTEGER 0E76 139,140,147,148,208,210,624:: IFOUND INTEGER 0E75 139,141,147,149,208,209,624:, IMODE INTEGER 0E63 86,88,99,101 ,€ IOBUF INTEGER 07E3 8,10,133,134,135,136,139,145,156,157,158,159,161,164,166,171,206,208,541,553,555,559,562,564,568 €0 IPF INTEGER 0E4D 83,85,86,100,102 0‚ IPOINT INTEGER 0C4C 39,41,242,246,250,253,254,257,258,260,262,265,414,418,422,427,429,431,432,433,439,441,445,446,448, ‚> 449,451,452,466,467,470,472,474>< IPOS INTEGER 0C4D 39,41,418,431,435,441,443,470<b IREQ INTEGER 0EB4 588,589,590,591,592,596,597,598,599,603,604,605,606,610,611,612,613b, ISERR INTEGER 0E4F 83,85,86,107 ,€ ISTAT INTEGER 0E6F 111,112,113,114,115,117,118,120,170,174,176,177,193,194,195,232,233,234,268,269,270,271,286,287, €N 288,289,592,599,606,613,620,621,622,623,624,625N6 ITC INTEGER 0E74 134,157,163,164,165,1866> IW INTEGER 0EAA 476,477,478,479,480,482,483,484>, IWAY INTEGER 0E62 86,88,98,100 ,f J INTEGER 0E8D 277,277,278,279,281,282,284,425,437,506,507,510,512,513,545,546,548,549fB LASLEN INTEGER 0EA0 360,360,361,367,368,385,386,461,462B2 LASNAM INTEGER 0476 6,8,336,361,385,4612~ LB INTEGER 0EA6 418,419,435,443,444,455,456,459,460,461,462,463,481,490,494,500,501,504,510,511,513,515,518,534~( LCOUNT INTEGER 0C4E 41,43,243(t FTN 3.3B (OPT = LPC) LTRPRT PAGE 31 DATE: 08/29/84 TIME: 2153 t( LD1 INTEGER 0C06 14,17,93 (( LD2 INTEGER 0C0A 14,17,94 (( LD3 INTEGER 0C0E 14,17,95 (( LD4 INTEGER 0C12 14,17,96 (T LENGTH INTEGER 0C25 19,21,431,435,441,443,444,470,482,492,499,500,501,515T* LINCT INTEGER 0EA8 420,421,424** LINE INTEGER 0EAB 478,479,481*( LTBUPT INTEGER 0C9A 43,46,125(Z LTFILB INTEGER 0485 6,8,232,250,254,260,422,427,433,435,439,443,446,449,452,467Z( LTLPT INTEGER 0C4F 41,43,123(t LTRARR INTEGER 080C 8,10,413,426,435,438,443,455,459,461,463,490,494,500,501,504,511,513,515,520,521,534 t( LTRF INTEGER 0C9B 43,46,147(. LTRFBF INTEGER 0779 6,8,147,328,572.H LU INTEGER 0E5F 86,90,134,157,163,164,186,592,599,606,613H: LW INTEGER 0EA7 419,420,426,438,519,520,521:2 MADR1 INTEGER 0C5F 43,279,301,309,398 26 MADR2 INTEGER 0C6E 43,280,302,313,400,403 6L MARGIN INTEGER 0C38 26,28,390,394,395,398,403,406,407,534,543,558L, MAXLEN INTEGER 0C39 26,28,425,437,2 MBNM INTEGER 0C8A 43,283,305,312,395 22 MCS INTEGER 0C7D 43,281,303,310,406 2N MNAM INTEGER 0C50 43,278,300,307,350,353,361,364,367,372,377,383 N" MODE INTEGER 0E65 90 "0 MSG10 INTEGER 0DE0 74,76,236,237,2380, MSG12 INTEGER 0E08 76,78,274,275,, MSG13 INTEGER 0E30 78,80,143,151,, MSG2 INTEGER 0CD2 58,60,157,162,( MSG4 INTEGER 0CFA 60,62,130(( MSG4A INTEGER 0D18 62,64,134(, MSG5 INTEGER 0D80 68,70,185,186,, MSG6 INTEGER 0D37 64,66,162,163,, MSG7 INTEGER 0D5F 66,68,292,293,0 MSG9 INTEGER 0DA1 70,72,204,212,2130, MSG9A INTEGER 0DB8 72,74,222,223,< MSLCD INTEGER 0C99 43,46,284,299,308,337,338,339<2 MZP INTEGER 0C87 43,282,304,311,407 2€ N INTEGER 0E9F 338,339,340,427,428,433,434,439,440,446,447,449,450,452,453,465,467,468,543,546,548,552,553,554, €6 555,558,562,567,568,5726J N1 INTEGER 0EA1 361,362,363,370,371,375,379,381,383,512,513J* NAMSW INTEGER 0EA9 446,447,454*( NLINE INTEGER 0E4E 83,85,86 (, NLU INTEGER 0E4C 83,85,86,100 ,0 NO INTEGER 0C3A 26,29,136,159,2540, NOF INTEGER 0C9D 46,48,245,256,, NPORT INTEGER 0E61 86,90,100,102,( NU INTEGER 0E50 83,85,86 (( NUMCLC INTEGER 0C9E 46,48,122(‚ OBUF INTEGER 07A1 6,127,128,129,130,132,151,153,213,219,223,225,238,275,293,320,323,324,325,326,327,329,331,333,389, ‚€ 390,391,392,394,395,396,397,398,399,402,403,404,405,406,407,409,410,523,525,531,534,535,539,546, €^ 549,553,555,557,561,562,563,566,567,568,569,571,572,573,574,582^n PBUF INTEGER 0433 3,6,128,215,216,217,218,220,316,317,318,319,388,411,538,578,579,580,581,585,586nt PLN INTEGER 0E4B 83,85,86,127,128,151,213,223,238,275,293,320,326,389,392,397,402,405,410,523,539,571 t( PLU INTEGER 0E60 86,88,100(@ POS INTEGER 0C9F 48,50,484,489,493,494,496,505,515@t FTN 3.3B (OPT = LPC) LTRPRT PAGE 32 DATE: 08/29/84 TIME: 2153 t* PUN INTEGER 0C3B 26,450,463 *, RECTYP INTEGER 0C3C 29,31,180,196,( REFLIN INTEGER 0E47 80,82,327(8 REQ1 INTEGER 0B04 10,12,118,119,268,589,62388 REQ2 INTEGER 0B1C 10,12,115,116,286,596,62284 REQ3 INTEGER 0B34 10,12,111,232,603,6204< REQ4 INTEGER 0B4C 10,12,113,170,174,193,610,621<0 SALARA INTEGER 0B64 12,14,145,340,5460, SALC INTEGER 0CA0 48,50,139,143,P SALLEN INTEGER 0CA2 48,50,334,346,348,353,367,368,382,454,458,459,460P. START INTEGER 0C3E 29,258,265,414 .‚ SYSPRM INTEGER 0E4B 83,85,106,132,153,216,218,219,220,225,317,319,325,333,388,391,396,399,404,409,411,531,535,538,557, ‚> 563,569,574,579,581,582,586,625>6 TACTKY INTEGER 0CA9 50,190,201,237,268,286 6. TACTWK INTEGER 0CB1 50,166,178,185 ." TCIDCK INTEGER 0CA5 50 "2 TCIDKY INTEGER 0CA7 50,202,204,206,208 28 TCIDSC INTEGER 0CBA 50,54,540,541,542,544,5458" TCIDWK INTEGER 0CA3 50 "x TFBUF INTEGER 0B85 12,14,170,174,178,180,182,193,196,198,200,201,202,212,222,227,228,274,292,295,296,329,331x2 TFKEY INTEGER 0CBB 50,168,169,170,174 2@ TLACKY INTEGER 0CC3 50,54,192,228,267,277,297,298,393@8 TLRKY INTEGER 0CC4 54,56,191,227,229,231,2328( TLRPNT INTEGER 0CC5 54,56,124(0 TLRWKY INTEGER 0CC6 54,56,229,231,2360( TWO INTEGER 0C3D 29,31,328(4 TYPE INTEGER 0CC7 54,56,483,485,486,4874( USER INTEGER 0E51 86,90,91 (0 WRONKY INTEGER 0C3F 31,33,233,269,28708 XYN INTEGER 0C40 31,33,134,157,163,164,18680 YES INTEGER 0C42 33,35,135,158,1710( ZERO INTEGER 0C41 31,33,168($ ZEROE INTEGER 0C43 33,35$   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < € CCSBLK SUBROUTINE 1775 125,133,156,161,190,191,248,280,283,305,313,320,321,326,335,336,389,392,397,402,405,410,413,498, €6 503,523,539,561,566,5716~ CCSCST SUBROUTINE 173B 90,178,180,182,196,198,204,206,229,250,254,328,342,350,355,364,372,377,400,422,507,549,559,564 ~J CCSGET SUBROUTINE 15A5 227,284,299,308,427,433,439,446,449,452,467J€ CCSMVA SUBROUTINE 16F7 92,94,95,96,128,129,130,143,145,151,166,185,201,202,212,213,222,223,227,231,236,237,238,260,274, €€ 275,278,279,281,282,292,293,295,296,300,301,302,303,304,307,309,310,311,312,323,327,329,331,340, €€ 353,361,367,383,385,390,394,395,398,403,406,407,435,443,455,459,461,463,496,500,501,504,511,513, €B 515,534,541,546,553,555,567,568,572B. CLOSFL SUBROUTINE 1843 619,621,622,623.. EDIT SUBROUTINE 1779 489,494,505,562.. FILERR SUBROUTINE 17F4 591,599,606,613." GETGRP SUBROUTINE 0EF9 100"& GETS SUBROUTINE 1029 171,193&. GETUTI SUBROUTINE 10E3 138,147,208,624.t FTN 3.3B (OPT = LPC) LTRPRT PAGE 33 DATE: 08/29/84 TIME: 2153 t$ GTSYSP SUBROUTINE 0EEB 97,99$" ICKGRP INTEGER.FN. 10AE 200"& IDATVR INTEGER.FN. 1621 493,497&& LTRDTE SUBROUTINE 1642 321,499&. OPENFL SUBROUTINE 0F29 110,113,115,118." PGMIN SUBROUTINE 0EBB 89 "" PGMINT SUBROUTINE 0EB7 88 "" PGMOUT SUBROUTINE 185D 625"" PRTORF SUBROUTINE 0EF2 99 " Q8STP INTEGER.FN. 185F . READR SUBROUTINE 11E1 169,232,268,286.€ SYSPRT SUBROUTINE 1780 105,132,153,216,218,219,220,225,317,319,325,333,388,391,396,399,404,409,411,531,535,538,557,563, €: 569,574,579,581,582,586,625:2 WTREAD SUBROUTINE 0FFD 133,157,163,164,1862   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 5 0EEA 92,97$& 25 0F0D 102,105&" 40 0F19 107"" 50 0F28 110"" 70 0F33 112"" 80 0F3C 114"" 90 0F48 117"" 120 0F54 120"" 200 0F5F 125"& 230 0F79 130,135&& 240 0F7E 132,137&& 300 0F98 136,138&" 320 0FA9 141"& 330 0FB1 141,145&" 340 0FB8 145"& 350 0FC6 143,150&" 360 0FCD 151". 400 0FD5 149,155,160,187." 410 0FD8 156"* 420 0FEB 159,161,165*& 430 1013 158,167&. 440 1028 171,179,181,183.& 445 102E 171,175&" 450 103B 177"& 470 1062 176,185&: 500 1074 187,197,199,200,226,576,583:" 505 1084 192"& 507 1089 171,194&& 520 1095 183,196&" 530 10B6 200"" 540 10BE 201"" 550 10C5 202"" 560 10F4 210"t FTN 3.3B (OPT = LPC) LTRPRT PAGE 34 DATE: 08/29/84 TIME: 2153 t" 564 1102 213"& 566 111E 205,221&" 568 112C 223"* 570 1133 207,209,227*" 580 113A 227"" 700 113F 228"" 730 114D 230"" 750 1155 231"& 780 116E 233,236&& 900 1185 234,240&" 920 1192 245"" 930 119C 248"" 935 11A8 250"" 940 11AC 251"" 950 11B0 253"& 960 11C2 255,260&" 970 11C9 260"& 990 11D0 248,264&& 995 11D5 251,265&* 1000 11D7 230,259,266** 1010 11F9 269,270,273*& 1020 120A 271,277&& 1030 1247 267,285&* 1040 125D 287,288,291*& 1050 126D 289,295&" 1060 128A 298"& 1070 12B6 297,307&. 1100 12E2 298,306,314,315." 1140 12F4 319"" 1150 1300 322"" 1160 1310 325"" 1170 131F 327"& 1180 133A 330,332&" 1190 133F 333"" 1200 1361 340"& 1210 136F 340,344&& 1215 1374 343,345&& 1216 137A 345,348&* 1220 137D 337,347,349*& 1230 138B 349,352&& 1245 13A8 353,357&& 1246 13B0 356,359&& 1250 13B1 351,360&" 1260 13BC 361"& 1262 13CF 362,366&& 1264 13DD 365,370&& 1266 13EF 370,374&& 1275 13F7 373,377&& 1276 140A 378,381&* 1280 140E 375,380,382** 1290 1428 359,369,387*" 1300 142E 388"" 1320 143E 391"& 1330 145F 393,397&t FTN 3.3B (OPT = LPC) LTRPRT PAGE 35 DATE: 08/29/84 TIME: 2153 t" 1340 146E 399"& 1350 148A 401,405&" 1355 14A0 407"" 1360 14A5 409"" 1370 14AE 411"" 1400 14AE 411"" 1405 14BC 416"" 1430 14D3 421"" 1440 14E0 423"" 1450 14E4 424"" 1460 14F0 426"" 1465 14F5 427"& 1470 14FC 424,430&& 1480 14FE 428,431&& 1490 150B 434,471&& 1500 1517 424,437&" 1510 1521 438"" 1520 1525 439"" 1530 152B 440"" 1540 1541 445"" 1550 154A 448"" 1560 1554 451"" 1570 155C 453"& 1580 1575 454,458&& 1590 1593 456,463&& 1600 159B 440,465&" 1610 15AC 468"" 1615 15B0 469"& 1620 15B8 465,472&& 1630 15BA 437,473&. 1640 15BE 435,464,469,474.& 1650 15BF 416,475&& 1660 15C6 423,476&" 1665 15CF 477"" 1670 15F9 484"& 1680 160D 485,489&& 1682 1619 489,492&& 1685 162F 492,496&& 1690 165D 486,503&& 1692 167D 505,509&& 1694 1682 508,510&* 1700 16A2 487,488,515*> 1710 16A9 476,491,493,495,497,502,514,516>& 1730 16B0 478,517&" 1740 16BF 519"& 1750 16CA 521,532&* 1810 16F3 524,526,533*& 1830 1703 517,536&& 2000 1708 520,537&" 2010 1710 539"" 2020 1722 543"" 2030 1734 546"& 2040 1747 546,551&& 2050 174C 550,552&t FTN 3.3B (OPT = LPC) LTRPRT PAGE 36 DATE: 08/29/84 TIME: 2153 t& 2051 1750 544,553&" 2060 1757 553"" 2070 1760 555"" 2080 1765 557"& 2090 1785 560,564&& 2100 17AE 565,570&" 2110 17C2 574"" 2120 17C2 574". 2200 17C4 238,276,294,577.& 3000 17DB 194,584&* 9800 17E3 120,271,588** 9810 17FD 117,289,595** 9820 1813 112,234,602*. 9830 1829 114,177,195,609.2 9840 183F 107,140,148,210,6162B 9900 1842 153,189,587,594,601,608,615,618,619B LTRPRT 0000 1 t FTN 3.3B (OPT = LPC) LTRSTA PAGE 1 DATE: 08/29/84 TIME: 2202 t^ 1 PROGRAM LTRSTA B7800001^^ 1 1 /B78 F CCS 3.0 .LA/LETTER STATS 05/84 SL-149********^ ^ C CYBERCREDIT SYSTEM VERSION 3 B7800004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIRORNIA B7800005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B7800006^^ C B7800007^ ^ C THIS PROGRAMS PRINTS WHICH LETTERS WERE SENT BY EACH COLLECTOR B7800009^^ C B7800010^^ 2 INTEGER IDUSER(4),DT(3),TRNREC(0690),TRNREQ(24) ********^^ 3 INTEGER TDATA(15),TYPE,TLR(3),COIDCT,MAT(100,50 ),COID(100) ********^^ 4 INTEGER COIDWK(2),COIDPS,PRT(66,8),PAGE,IBUF(3),ZERO(3) ********^^ 5 INTEGER BLANK,PRTLIN(66),POS,PASS,LTR1(40) ********^^ 6 INTEGER HDL1(66),HDL2(66),HDL3(66),HDL4(66),HDL5(66) B7800015^^ 7 INTEGER HDL6(66),HDL7(66),C,TC(51),TL(100),LTR(100) ********^^ 8 INTEGER UTKEY(2),AST,TOTAL(3),IBUF2(3),HDL8(66) B7800018^^ 9 INTEGER HDLA(66),HDLB(66),TTC ********^^ C B7800019^^ C B7800020^^ 10 DATA TDATA/'LATRNSFL',8*$2020,0,10,0/,TRNREQ/24*0/ ********^^ 11 DATA TYPE/'01'/,COIDCT/0/,COIDWK/2*$FFFF/,TTC/0/,L/0/ ********^^ 12 DATA TLR/3*$3030/,PAGE/0/,ZERO/3*$3030/ B7800023^^ 13 DATA TC/51*0/,TL/100*0/,LTR/100*0/,IBUF/3*$3030/ ********^^ 14 DATA BLANK/$2020/,MAT/ 5000*0/,COID/100*$2020/ ********^^ 15 DATA PASS/0/,IEOF/0/,IREC/0/ ********^^ 16 DATA AST/'**'/,TOTAL/'TOTALS'/ ********^^ 17 DATA UTKEY/'LTR1'/,IBUF2/3*$3030/ B7800029^ ^ C POS. 01 +------------------ THRU ------------------+ 44 ********^^ 18 DATA HDL1/'1---------- HDR1 GOES HERE -------------- ' ********^^ 18 +, ' COLLECTOR LETTER STATISTICS ' ********^^ 18 +, ' PAGE '/ ********^ ^ C POS. 01 +------------------ THRU ------------------+ 44 ********^^ 19 DATA HDL2/' ---------- HDR2 GOES HERE -------------- ' ********^^ 19 +, ' AS OF: ' ********^^ 19 +, ' '/ ********^ ^ C POS. 01 +------------------ THRU ------------------+ 44 ********^^ 20 DATA HDL3/' ---------- HDR3 GOES HERE -------------- ' ********^^ 20 +, ' ' ********^^ 20 +, ' '/ ********^ ^ C POS. 01 +------------------ THRU ------------------+ 44 ********^^ 21 DATA HDL4/' ' ********^^ 21 +, ' LETTERS REQUESTED ' ********^^ 21 +, ' '/ ********^ ^ C POS. 01 +------------------ THRU ------------------+ 44 ********^^ 22 DATA HDL5/' COLLECTOR ' ********^^ 22 +, ' ' ********^^ 22 +, ' '/ ********^ t FTN 3.3B (OPT = LPC) LTRSTA PAGE 2 DATE: 08/29/84 TIME: 2202 t^ C POS. 01 +------------------ THRU ------------------+ 44 ********^^ 23 DATA HDL6/' COLLECTOR ' ********^^ 23 +, ' ' ********^^ 23 +, ' '/ ********^ ^ C POS. 01 +------------------ THRU ------------------+ 44 ********^^ 24 DATA HDLA/' COLLECTOR ' ********^^ 24 +, ' ' ********^^ 24 +, ' '/ ********^ ^ C POS. 01 +------------------ THRU ------------------+ 44 ********^^ 25 DATA HDLB/' COLLECTOR ' ********^^ 25 +, ' ' ********^^ 25 +, ' '/ ********^ ^ C POS. 01 +------------------ THRU ------------------+ 44 ********^^ 26 DATA HDL7/' TOTALS ' ********^^ 26 +, ' ' ********^^ 26 +, ' '/ ********^ ^ C POS. 01 +------------------ THRU ------------------+ 44 ********^^ 27 DATA HDL8/' LTR1 RECORD NOT FOUND ' ********^^ 27 +, ' ' ********^^ 27 +, ' '/ ********^  ^ 28 EQUIVALENCE (PRT(1,1),HDL1(1)) B7800064^^ 29 EQUIVALENCE (PRT(1,2),HDL2(1)) B7800065^^ 30 EQUIVALENCE (PRT(1,3),HDL3(1)) B7800066^^ 31 EQUIVALENCE (PRT(1,4),HDL4(1)) B7800067^^ 32 EQUIVALENCE (PRT(1,5),HDL5(1)) B7800068^^ 33 EQUIVALENCE (PRT(1,6),HDL6(1)) B7800069^^ 34 EQUIVALENCE (PRT(1,7),HDLA(1)) ********^^ 35 EQUIVALENCE (PRT(1,8),HDLB(1)) ********^ ^ 36 INTEGER UTFILE(4),SYPFIL(4) ********^^ 37 DATA UTFILE/'UTIFIL '/,SYPFIL/'SYSPRT '/ ********^ ^ 38 EQUIVALENCE ( TRNREQ(15), NUMRD ) ********^^ 39 INTEGER HEAD(18) ********^ ^ 40 DATA HEAD/$0D0A,$0A17,'EXECUTING LTRSTA ',$0F16/ ********^ ^ 41 INTEGER U(8),GRPBUF(10),HDR(20,3) ********^^ 41 +, LU,PLU,NPORT,IWAY,IMODE,IALL,IOPT,ITF ********^ ^ 42 DATA PLU/12/,IFOUND/0/ ********^ ^ 43 INTEGER L14(66) ********^ ^ 44 DATA L14/' **LTRSTA** ERROR IN FILE : XXXXXXXX ' ********^^ 44 +, ' RUN ABORTED ********** ' ********^^ 44 +, ' '/ ********^ t FTN 3.3B (OPT = LPC) LTRSTA PAGE 3 DATE: 08/29/84 TIME: 2202 t^ C**** SYSPRT PARAMETERS........ ********^ ^ 45 INTEGER SYSPRM(6),PLN,NLU,IPF,NLINE,ISERR,NU ********^ ^ 46 EQUIVALENCE ( SYSPRM(1),PLN ),( SYSPRM(2),NLU ) ********^^ 46 +, ( SYSPRM(3),IPF ),( SYSPRM(4),NLINE ) ********^^ 46 +, ( SYSPRM(5),ISERR ),( SYSPRM(6),NU ) ********^ ^ 47 DATA PLN/132/,NLU/05/,IPF/00/,NLINE/0/,ISERR/0/,NU/1/ ********^t FTN 3.3B (OPT = LPC) LTRSTA PAGE 4 DATE: 08/29/84 TIME: 2202 t ^ C**** ********^^ C**** BEGIN PROGRAM ....... ********^ ^ C*** GET EXTERNAL SWITCHS, USER INFO, HEADINGS, AND OTHER PARAMETERS ********^ ^ 48 CALL PGMIN ( IDUSER,LUNIT,MODE,NPORT ) ********^ ^ C*** CCS/LA LOOK-ALIKE..... ********^ ^ 49 CALL CCSCST( TDATA,1,2,USER,1,8,ICM ) ********^^ 50 IF ( ICM.EQ.0 ) GO TO 5 ********^^ 51 CALL CCSMVA( TDATA,3,6,TDATA,1,16 ) ********^^ 52 5 CONTINUE ********^ ^ 53 CALL CCSMVA( IDUSER,1,8,HEAD,23,8 ) ********^^ 54 CALL WTREAD( LUNIT,-1,HEAD,36,0,0,0,ITC ) ********^^ 55 CALL UTHEAD( HDR,DT ) ********^ ^ 56 CALL GTSYSP( IWAY, 29 ) ********^^ 57 CALL GTSYSP( IMODE, 30 ) ********^^ 58 CALL PRTORF( IPF,PLU,NLU,NPORT,IWAY ) ********^^ 59 CALL GETGRP( GRPBUF,IALL,IMODE ) ********^ ^ C**** OPEN FILES AND GET UTIFIL RECORDS ********^ ^ 60 CALL SYSPRT( HDL1,0,SYSPRM,0 ) ********^^ 61 IF( ISERR.LT.0 ) CALL CCSMVA( SYPFIL,1,8,UTFILE,1,8 ) ********^^ 62 IF( ISERR.LT.0 ) GO TO 9820 ********^ ^ 63 CALL OPENFL( TRNREQ,TDATA,ISTAT ) ********^^ 64 IF ( ISTAT.LT.0 ) GO TO 9800 ********^^ 65 TRNREQ(23) = 1 ********^ ^ 66 CALL EDIT( DT,1,HDL2,70,1 ) ********^^ C--- CALL CCSTIM( HDL2(40) ) ********^^ 67 CALL CCSMVA( HDR(01,01),1,40,HDL1,2,40 ) ********^^ 68 CALL CCSMVA( HDR(01,02),1,40,HDL2,2,40 ) ********^^ 69 CALL CCSMVA( HDR(01,03),1,40,HDL3,2,40 ) ********^^ 70 IF(NPORT.NE.0) CALL CCSPUT( $0C,1,HDL1 ) ********^  ^ C READ LTR1 THRU LTR4 ********^^ 71 150 DO 170 I=1,4 ********^^ 72 155 CONTINUE ********^^ 73 CALL GETUTI( UTKEY,LTR1,IFOUND,IFER,0 ) ********^^ 74 IF( IFER.LT.0 ) GO TO 9810 ********^^ 75 IF( IFOUND.EQ.0 ) GO TO 160 ********^ ^ 76 157 IF ( I.EQ.1 ) GO TO 900 ********^^ 77 GO TO 180 ********^ ^ 78 160 UTKEY(2)=UTKEY(2)+1 ********^ t FTN 3.3B (OPT = LPC) LTRSTA PAGE 5 DATE: 08/29/84 TIME: 2202 t^ 79 162 DO 164 J=1,25 ********^^ 80 J1=I*25-25+J ********^^ 81 J2=(J-1)*2+5 ********^^ 82 J3= I+4 ********^^ 83 J4=(J-1)*4+16 ********^^ 84 CALL CCSCST(LTR1,J2,2,AST,1,2,ICOMP) ********^^ 85 IF(ICOMP.EQ.0) GO TO 170 ********^^ 86 CALL CCSCST(LTR1,J2,2,BLANK,1,2,ICOMP) ********^^ 87 IF(ICOMP.EQ.0) GO TO 170 ********^^ 88 CALL CCSMVA(LTR1,J2,2,PRT(1,J3),J4,2) ********^^ 89 CALL CCSMVA(LTR1,J2,2,IBUF,5,2) ********^^ 90 L = L+1 ********^^ 91 LTR(L) = IBUF(3) ********^^ 92 164 CONTINUE ********^ ^ 93 170 CONTINUE ********^ ^ 94 180 CONTINUE ********^^ 95 CALL CCSMVA( HDL8,1,0,HDL8,1,132 ) ********^^ C READ TRANSACTION FILE B7800138^^ 96 200 CONTINUE ********^^ 97 CALL GETS(TRNREQ,TRNREC,TRNREC,ISTAT) B7800140^^ 98 IF( AND(ISTAT,$8100).EQ.$8100 ) GO TO 282 ********^^ 99 IF( ISTAT.LT.0 ) GO TO 9800 ********^ ^ 100 220 NREC=TRNREQ(15) B7800147^^ 101 IF ( NREC.LE.0 ) GO TO 282 ********^^ 102 230 DO 280 N=1,NREC ********^^ 103 JW=(N-1)*69 ********^^ 104 JB=(N-1)*138 ********^^ 105 CALL CCSCST(TRNREC,JB+29,2,TYPE,1,2,ICOMP) B7800151^^ 106 IF(ICOMP.NE.0) GO TO 280 B7800152^^ 107 CALL CCSCST(TRNREC,JB+41,2,BLANK,1,2,ICOMP) B7800153^^ 108 IF(ICOMP.EQ.0) GO TO 280 B7800154^ ^ C***** CHECK IF OK TO USE THIS ACCOUNT GROUP. ********^^ 109 IF( ICKGRP( GRPBUF,IALL,TRNREC,JB+1 ).EQ.1 ) GO TO 280 ********^ ^ C TYPE 01 FOUND SEE IF LETTER WAS SENT B7800156^^ 110 240 CALL CCSMVA(TRNREC,JB+41,2,TLR,5,2) B7800157^^ 111 LTRNO = TLR(3) ********^ ^ C SEE IF COLLECTOR CHANGED B7800161^^ 112 250 CALL CCSCST(TRNREC,JB+17,4,COIDWK,1,4,ICOMP) B7800162^^ 113 IF(ICOMP.EQ.0) GO TO 270 B7800163^ ^ C COID HAS CHNAGED INCREMENT COUNT AND B7800165^^ C MOVE IN COID B7800166^^ 114 260 COIDCT=COIDCT+1 B7800167^^ 115 IF ( COIDCT.LE.50 ) GO TO 265 ********^^ 116 KFLG = 1 ********^^ 117 COIDCT = COIDCT-1 ********^^ 118 GO TO 282 ********^^ 119 262 CONTINUE ********^t FTN 3.3B (OPT = LPC) LTRSTA PAGE 6 DATE: 08/29/84 TIME: 2202 t^ 120 KFLG = 0 ********^^ 121 COIDCT = 1 ********^^ 122 CALL CCSBLK( COID,200 ) ********^^ 123 DO 264 I0=1,100 ********^^ 124 TL(I0) = 0 ********^^ 125 IF( I0.LE.50 ) TC(I0) = 0 ********^^ 126 DO 264 I1=1,50 ********^^ 127 264 MAT(I0,I1) = 0 ********^^ 128 265 CONTINUE ********^^ 129 TTC = TTC+1 ********^^ 130 COIDPS=(COIDCT-1)*4+1 B7800168^^ 131 CALL CCSMVA(TRNREC,JB+17,4,COID,COIDPS,4) B7800169^^ 132 CALL CCSMVA(TRNREC,JB+17,4,COIDWK,1,4) B7800170^ ^ C ADD 1 TO MATRIX B7800172^^ 133 270 DO 272 II=1,L B7800173^^ 134 IF(LTRNO.EQ.LTR(II)) GO TO 274 B7800174^^ 135 272 CONTINUE B7800175^^ 136 GO TO 280 ********^^ 137 274 LTRNO=II B7800176^^ 138 276 MAT(LTRNO,COIDCT)=MAT(LTRNO,COIDCT) + 1 B7800177^^ 139 IREC=IREC+1 B7800178^^ 140 280 CONTINUE B7800179^^ 141 IF(IEOF.EQ.0) GO TO 200 B7800180^ ^ C COMPUTE MATRIX TOTALS B7800182^^ C COMPUTE COLLECTORS TOTALS (ACROSS) B7800183^^ 142 282 C=COIDCT B7800184^^ 143 DO 286 I=1,C B7800185^^ 144 DO 284 II=1,L B7800186^^ 145 TC(I)=MAT(II,I)+TC(I) B7800187^^ 146 284 CONTINUE B7800188^^ 147 286 CONTINUE B7800189^ ^ C COMPUTE LETTER TOTALS (DOWN) B7800191^^ 148 290 DO 294 II=1,L B7800192^^ 149 DO 292 I=1,C B7800193^^ 150 TL(II)=MAT(II,I)+TL(II) B7800194^^ 151 292 CONTINUE B7800195^^ 152 294 CONTINUE B7800196^ ^ C COMPUTE TOTAL TOTALS B7800198^^ 153 295 DO 296 I=1,C B7800199^^ 154 TC(51)= TC(51) + TC(I) ********^^ 155 296 CONTINUE B7800201^t FTN 3.3B (OPT = LPC) LTRSTA PAGE 7 DATE: 08/29/84 TIME: 2202 t ^ 156 LT = L ********^^ 157 IF ( LT.GT.0 ) LT = LT-1 ********^^ 158 LTC = LT/25+1 ********^ ^ 159 DO 450 LTP=1,LTC ********^ ^ 160 LZ = (L-LTP*25)+25 ********^^ C PRINT PASS 1 THRU 3 ********^^ 161 360 PASS = 1 ********^^ 162 N1=(PASS-1)*50+1 ********^^ 163 N2=PASS*50 ********^^ 164 IF(C.LT.N2)N2=C ********^ ^ C PRINT 1-25 ********^^ 165 370 DO 440 I=N1,N2 ********^^ 166 COIDPS=(I-1)*4+1 ********^^ 167 IF(I.NE.N1) GO TO 410 ********^ ^ C PRINT HEADINGS ********^^ 168 380 PAGE=PAGE+1 ********^^ 169 CALL BHXDEC(PAGE,IBUF) ********^^ 170 390 CALL CCSMVA(IBUF,5,2,HDL1,126,2) ********^ ^ C CHECK IF LESS THAN 26 LETTERS ********^^ 171 IF(LZ.GE.26) GO TO 398 ********^^ 172 J=LZ*4+16 ********^^ 173 JJ=LTP+4 ********^^ 174 CALL CCSMVA(TOTAL,1,6,PRT(1,JJ),J,6) ********^^ 175 398 DO 400 J=1,5 ********^^ 176 JJ = J ********^^ 177 IF(J.GE.5)JJ=LTP+4 ********^ ^ 178 CALL SYSPRT( PRT(1,JJ),1,SYSPRM,0 ) ********^^ 179 IF( J.EQ.3 .OR. J.EQ.5 ) CALL SYSPRT( HDL8,1,SYSPRM,0 ) ********^ ^ 180 400 CONTINUE ********^ ^ C BUILD PRINT LINE ********^^ 181 410 CALL CCSBLK(PRTLIN,132) ********^^ 182 CALL CCSMVA(COID,COIDPS,4,UTKEY,1,4) ********^^ 183 CALL GETUTI( UTKEY,LTR1,IFOUND,IFER,0 ) ********^^ 184 IF ( IFER.LT.0 ) GO TO 9800 ********^^ 185 IF ( IFOUND.EQ.1 ) CALL CCSMVA( UTKEY,1,4,LTR1,5,74 ) ********^ ^ 186 415 CALL CCSMVA (LTR1,5,12,PRTLIN,2,12) ********^^ 187 IF(LZ.LT.26) L1=LZ ********^^ 188 IF(LZ.GE.26) L1=25 ********^^ 189 DO 420 II=1,L1 ********^^ 190 J=(II-1)*4+15 ********^^ 191 J2=LTP*25-25+II ********^^ 192 CALL BHXDEC(MAT(J2,I),IBUF) ********^^ 193 418 CALL CCSMVA(IBUF,4,3,PRTLIN, J ,3) ********^^ 194 420 CONTINUE ********^t FTN 3.3B (OPT = LPC) LTRSTA PAGE 8 DATE: 08/29/84 TIME: 2202 t ^ C IF LESS THAN 26 LETTERS MOVE TOTALS ********^^ C INTO FIRST PAGE ********^^ 195 IF(LZ.GE.26) GO TO 430 ********^^ 196 CALL BHXDEC(TC(I),IBUF2) ********^^ 197 424 J=LZ*4+16 ********^^ 198 CALL CCSMVA(IBUF2,3,4,PRTLIN,J,4) ********^^ C PRINT DETAIL LINE ********^^ 199 430 CONTINUE ********^^ 200 CALL SYSPRT( PRTLIN,1,SYSPRM,0 ) ********^ ^ 201 440 CONTINUE ********^ ^ C IF END-PRINT TOTAL LINE ********^^ 202 441 IF((I-1).LT.C) GO TO 450 ********^^ 203 IF(KFLG.EQ.1) GO TO 450 ********^^ 204 CALL CCSBLK(HDL7(7),118) ********^^ 205 DO 444 K=1,L1 ********^^ 206 J=(K-1)*4+14 ********^^ 207 J2= LTP*25-25+K ********^^ 208 CALL BHXDEC(TL(J2),IBUF2) ********^^ 209 443 CALL CCSMVA(IBUF2,3,4,HDL7,J,4) ********^^ 210 444 CONTINUE ********^ ^ C IF LESS THAN 26 LETTERS CALCULATE AND ********^^ C PRINT TOTAL OF TOTALS ********^^ 211 446 IF (LZ .GE. 26) GO TO 4491 ********^^ 212 CALL BHXDEC(TC(51),IBUF2) ********^^ 213 449 J=LZ*4+16 ********^^ 214 CALL CCSMVA(IBUF2,3,4,HDL7,J,4) ********^^ 215 4491 CONTINUE ********^^ 216 CALL SYSPRT( HDL8,1,SYSPRM,0 ) ********^^ 217 CALL SYSPRT( HDL7,1,SYSPRM,0 ) ********^ ^ 218 450 CONTINUE ********^^ 219 IF ( KFLG.EQ.1 ) GO TO 262 ********^^ 220 GO TO 9900 ********^    ^ C**** ERROR SECTION FILE 1 ********^^ 221 9800 CONTINUE ********^^ 222 IREQ = AND(TRNREQ(4),$FF) ********^^ 223 IF (IREQ.LT.11) IREQ = IREQ-1 ********^^ 224 IF (IREQ.EQ.18) IREQ = 10 ********^^ 225 CALL FILERR( TDATA,IREQ,ISTAT,LUNIT ) ********^^ 226 CALL CCSMVA( TDATA,1,8,L14,32,8 ) ********^^ 227 IERR = 1 ********^^ 228 GO TO 9900 ********^ ^ C**** ERROR SECTION FILE 2 ********^^ 229 9810 CONTINUE ********^^ 230 CALL SYSPRT( HDL8,1,SYSPRM,0 ) ********^t FTN 3.3B (OPT = LPC) LTRSTA PAGE 9 DATE: 08/29/84 TIME: 2202 t ^ C**** ERROR SECTION FILE 3 ********^^ 231 9820 CONTINUE ********^^ 232 CALL CCSMVA( UTFILE,1,8,L14,32,8 ) ********^^ 233 IERR = 1 ********^^ 234 GO TO 9900 ********^ ^ C**** CLOSE THE FILES AND EXIT........ ********^^ 235 9900 CONTINUE ********^^ 236 IF (IERR.EQ.1) CALL SYSPRT( L14,1,SYSPRM,0 ) ********^ ^ 237 CALL CLOSFL( TRNREQ,ISTAT ) ********^^ 238 CALL GETUTI( UTKEY,LTR1,IFOUND,IFER,2 ) ********^^ 239 CALL SYSPRT( HDL4,0,SYSPRM,1 ) ********^ ^ 240 CALL PGMOUT ********^^ 241 END B7800394^t FTN 3.3B (OPT = LPC) LTRSTA PAGE 10 DATE: 08/29/84 TIME: 2202 t  PROGRAM LENGTH $1FDC ( 8156)   EXTERNALS 2 Q8STP PGMIN CCSCST CCSMVA WTREAD UTHEAD GTSYSP 22 PRTORF GETGRP SYSPRT OPENFL EDIT CCSPUT GETUTI 22 GETS ICKGRP CCSBLK BHXDEC FILERR CLOSFL PGMOUT 2  UNDEFINED SYMS  900 t FTN 3.3B (OPT = LPC) LTRSTA PAGE 11 DATE: 08/29/84 TIME: 2202 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < $ 8100 (-32511) 1BBE 98,98$" FFFE (-1) 1BA9 54 "‚ 0000 (0) 0003 10,11,12,13,14,15,42,47,50,54,60,61,62,64,70,73,74,75,85,87,95,99,101,106,108,113,120,124,125,127, ‚N 141,157,178,179,183,184,200,216,217,230,236,239N€ 0001 (1) 0002 28,29,30,31,32,33,34,35,46,47,49,51,53,54,61,65,66,67,68,69,70,71,76,78,79,81,83,84,86,88,90,95, €€ 102,103,104,105,107,109,112,114,116,117,121,123,126,129,130,132,133,138,139,143,144,148,149,153, €€ 157,158,159,161,162,166,168,174,175,178,179,182,185,189,190,200,202,203,205,206,216,217,219,223, €: 226,227,230,232,233,236,239:T 0002 (2) 1BA0 49,67,68,69,78,81,84,86,88,89,105,107,110,170,186,238T@ 0003 (3) 1BA5 51,69,91,111,179,193,198,209,214 @t 0004 (4) 1BB3 71,82,83,112,130,131,132,166,172,173,177,182,185,190,193,197,198,206,209,213,214,222 t@ 0005 (5) 1BB9 81,89,110,170,175,177,179,185,186@& 0006 (6) 1BA6 51,174 &0 0008 (8) 1BA3 49,53,61,226,232 0& 000C (12) 1BB1 70,186 &0 0010 (16) 1BA7 51,83,172,197,2130$ 0017 (23) 1BA8 53,65$8 0019 (25) 1BB6 79,80,158,160,188,191,2078& 001D (29) 1BAC 56,105 &" 001E (30) 1BAD 57 "& 0020 (32) 1BDA 226,232&" 0024 (36) 1BAA 54 "* 0028 (40) 1BB0 67,67,68,69*2 0032 (50) 1BC6 115,125,126,162,1632" 0045 (69) 1BC2 103"" 0046 (70) 1BAF 66 "" 004A (74) 1BD4 185"" 0076 (118) 1BD6 204"" 007E (126) 1BD2 170"& 0084 (132) 1BBD 95,181 &" 008A (138) 1BC4 104"& 00C8 (200) 1BC8 122,141&" 00FF (255) 1BD9 222"   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < & AND INTR.FN. 7FFF 98,222 && AST INTEGER 1A9B 1,16,84&* BLANK INTEGER 18EF 1,14,86,107*8 C INTEGER 199D 1,142,143,149,153,164,20280 COID INTEGER 1671 1,14,122,131,182 0@ COIDCT INTEGER 02E8 1,11,114,115,117,121,130,138,142 @t FTN 3.3B (OPT = LPC) LTRSTA PAGE 12 DATE: 08/29/84 TIME: 2202 t0 COIDPS INTEGER 16D7 1,130,131,166,1820, COIDWK INTEGER 16D5 1,11,112,132 ,& DT INTEGER 0008 1,55,66&( GRPBUF INTEGER 1B0A 40,59,109(4 HDL1 INTEGER 16D8 1,18,28,60,67,70,170 4, HDL2 INTEGER 171A 1,19,29,66,68,* HDL3 INTEGER 175C 1,20,30,69 ** HDL4 INTEGER 179E 1,21,31,239*& HDL5 INTEGER 17E0 1,22,32&& HDL6 INTEGER 1822 1,23,33&4 HDL7 INTEGER 195B 1,26,204,209,214,217 42 HDL8 INTEGER 1AA2 1,27,95,179,216,2302& HDLA INTEGER 1864 1,24,34&& HDLB INTEGER 18A6 1,25,35&. HDR INTEGER 1B14 40,55,67,68,69 .* HEAD INTEGER 1AF0 38,40,53,54*Z I INTEGER 1BB2 70,76,80,82,143,145,149,150,153,154,165,166,167,192,196,202Z. I0 INTEGER 1BC9 122,124,125,127.& I1 INTEGER 1BCA 126,127&( IALL INTEGER 1B54 40,59,109(: IBUF INTEGER 18E9 1,13,89,91,169,170,192,193 :< IBUF2 INTEGER 1A9F 1,17,196,198,208,209,212,214 <$ ICM INTEGER 1BA4 49,50$B ICOMP INTEGER 1BBC 84,85,86,87,105,106,107,108,112,113B& IDUSER INTEGER 0004 1,48,53&& IEOF INTEGER 1AE6 15,141 &. IERR INTEGER 1BDB 226,227,233,236.0 IFER INTEGER 1BB4 73,74,183,184,23804 IFOUND INTEGER 1B55 42,73,75,183,185,238 4F II INTEGER 1BCB 133,134,137,144,145,148,150,189,190,191F( IMODE INTEGER 1B53 40,57,59 (* IPF INTEGER 1B9A 44,46,47,58*& IREC INTEGER 1AE7 15,139 &2 IREQ INTEGER 1BD8 221,222,223,224,2252. ISERR INTEGER 1B9C 44,46,47,61,62 .6 ISTAT INTEGER 1BAE 63,64,97,98,99,225,237 6" ITC INTEGER 1BAB 54 "( IWAY INTEGER 1B52 40,56,58 (b J INTEGER 1BB5 78,80,81,83,172,174,175,176,177,179,190,193,197,198,206,209,213,214b$ J1 INTEGER 1BB7 79,80$@ J2 INTEGER 1BB8 80,81,84,86,88,89,191,192,207,208@( J3 INTEGER 1BBA 81,82,88 (( J4 INTEGER 1BBB 82,83,88 (B JB INTEGER 1BC3 103,104,105,107,109,110,112,131,132B6 JJ INTEGER 1BD3 172,173,174,176,177,1786& JW INTEGER 1BC1 102,103&* K INTEGER 1BD7 204,206,207*2 KFLG INTEGER 1BC7 115,116,120,203,2192< L INTEGER 1AE5 11,90,91,133,144,148,156,160 <2 L1 INTEGER 1BD5 187,187,188,189,20520 L14 INTEGER 1B56 42,44,226,232,2360. LT INTEGER 1BCC 155,156,157,158.* LTC INTEGER 1BCD 157,158,159*6 LTP INTEGER 1BCE 158,160,173,177,191,2076t FTN 3.3B (OPT = LPC) LTRSTA PAGE 13 DATE: 08/29/84 TIME: 2202 t* LTR INTEGER 1A35 1,13,91,134*@ LTR1 INTEGER 1933 1,73,84,86,88,89,183,185,186,238 @2 LTRNO INTEGER 1BC5 110,111,134,137,1382( LUNIT INTEGER 1B9E 48,54,225(F LZ INTEGER 1BCF 159,160,171,172,187,188,195,197,211,213F8 MAT INTEGER 02E9 1,14,127,138,145,150,192 8" MODE INTEGER 1B9F 48 "* N INTEGER 1BC0 101,103,104*. N1 INTEGER 1BD0 161,162,165,167.. N2 INTEGER 1BD1 162,163,164,165.( NLINE INTEGER 1B9B 44,46,47 (* NLU INTEGER 1B99 44,46,47,58** NPORT INTEGER 1B51 40,48,58,70*. NREC INTEGER 1BBF 99,100,101,102 .( NU INTEGER 1B9D 44,46,47 (" NUMRD INTEGER 02CB 38 ", PAGE INTEGER 18E8 1,12,168,169 ,0 PASS INTEGER 1932 1,15,161,162,163 0( PLN INTEGER 1B98 44,46,47 (( PLU INTEGER 1B50 40,42,58 (D PRT INTEGER 16D8 1,28,29,30,31,32,33,34,35,88,174,178 D4 PRTLIN INTEGER 18F0 1,181,186,193,198,2004( SYPFIL INTEGER 1AEC 35,37,61 (H SYSPRM INTEGER 1B98 44,46,60,178,179,200,216,217,230,236,239 H8 TC INTEGER 199E 1,13,125,145,154,196,212 84 TDATA INTEGER 02D5 1,10,49,51,63,225,22640 TL INTEGER 19D1 1,13,124,150,208 0, TLR INTEGER 02E5 1,12,110,111 ,( TOTAL INTEGER 1A9C 1,16,174 (@ TRNREC INTEGER 000B 1,97,105,107,109,110,112,131,132 @< TRNREQ INTEGER 02BD 1,10,38,63,65,97,100,222,237 <( TTC INTEGER 1AE4 1,11,129 (( TYPE INTEGER 02E4 1,11,105 (" U INTEGER 1B02 40 "" USER REAL 1BA1 49 ", UTFILE INTEGER 1AE8 35,37,61,232 ,: UTKEY INTEGER 1A99 1,17,73,78,182,183,185,238 :$ ZERO INTEGER 18EC 1,12 $   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < 2 BHXDEC SUBROUTINE 1F0B 168,192,196,208,2122* CCSBLK SUBROUTINE 1F44 121,181,204*4 CCSCST SUBROUTINE 1D27 48,84,86,105,107,112 4r CCSMVA SUBROUTINE 1FA5 50,53,61,67,68,69,88,89,95,110,131,132,170,174,182,185,186,193,198,209,214,226,232 r" CCSPUT SUBROUTINE 1C63 70 "" CLOSFL SUBROUTINE 1FC9 236"" EDIT SUBROUTINE 1C43 65 "" FILERR SUBROUTINE 1F9F 224"" GETGRP SUBROUTINE 1C1A 58 "t FTN 3.3B (OPT = LPC) LTRSTA PAGE 14 DATE: 08/29/84 TIME: 2202 t" GETS SUBROUTINE 1CE4 95 "* GETUTI SUBROUTINE 1FCD 71,183,238 *$ GTSYSP SUBROUTINE 1C0C 55,57$" ICKGRP INTEGER.FN. 1D39 109"" OPENFL SUBROUTINE 1C35 62 "" PGMIN SUBROUTINE 1BDD 47 "" PGMOUT SUBROUTINE 1FD9 239"" PRTORF SUBROUTINE 1C13 57 " Q8STP INTEGER.FN. 1FDB B SYSPRT SUBROUTINE 1FB1 59,178,179,200,216,217,230,236,239 B" UTHEAD SUBROUTINE 1C08 54 "" WTREAD SUBROUTINE 1BFE 53 "   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 5 1BF6 50,52$" 150 1C67 70 "" 155 1C6A 71 "" 157 1C7B 75 "$ 160 1C81 75,78$" 162 1C83 78 "$ 164 1CD2 78,92$* 170 1CD7 70,85,87,93*$ 180 1CDC 76,94$& 200 1CE3 95,141 &" 220 1CF6 99 "" 230 1D00 101"" 240 1D42 109"" 250 1D51 111"" 260 1D60 113"& 262 1D6E 118,219&* 264 1D87 122,126,127*& 265 1D99 115,128&& 270 1DB6 113,133&& 272 1DC3 133,135&& 274 1DC6 134,137&" 276 1DC9 137"6 280 1DD8 101,106,108,109,136,1406. 282 1DE3 98,101,118,142 .& 284 1DFD 143,146&& 286 1DFF 142,147&" 290 1E01 147"& 292 1E17 148,151&& 294 1E19 147,152&" 295 1E1B 152"& 296 1E24 152,155&" 360 1E47 160"" 370 1E5A 164"" 380 1E6D 167"" 390 1E73 169"t FTN 3.3B (OPT = LPC) LTRSTA PAGE 15 DATE: 08/29/84 TIME: 2202 t& 398 1E94 171,175&& 400 1EB3 175,180&& 410 1EB8 167,181&" 415 1EDB 185"" 418 1F0E 192"& 420 1F16 188,194&" 424 1F23 196"& 430 1F2E 195,199&& 440 1F34 164,201&" 441 1F37 201"" 443 1F5E 208"& 444 1F65 204,210&" 446 1F67 210"" 449 1F6E 212". 450 1F84 158,202,203,218." 900 7FFF 76 "& 4491 1F7A 211,215&, 9800 1F8E 64,99,184,221,& 9810 1FB0 74,229 && 9820 1FB6 62,231 &. 9900 1FC0 219,228,234,235. LTRSTA 0000 1  t FTN 3.3B (OPT = LPC) MHUPDT PAGE 1 DATE: 08/29/84 TIME: 2224 t^ 1 PROGRAM MHUPDT B7900001^^ 1 1 /B79 F CCS CCS 3.0 .LA - PSRD 07-83 SL-149********^^ C B7900003^^ C CYBERCREDIT SYSTEM VERSION 3 B7900004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B7900005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B7900006^^ C B7900007^ ^ C B7900009^^ C FORTRAN VERSION OF MHUPDT. DELETES RECORDS AFTER WRITING B7900010^^ C THEM TO TAPE. HANDLES MULTI-VOLUME OUTPUT TAPE FILES. B7900011^^ C WITH A LITTLE LUCK PROGRAM SHOULD BE 50% FASTER THAN B7900012^^ C THE CURRENT PROGRAMS (IE. MHUPDT AND MHDELE) B7900013^^ C B7900014^ ^ 2 EXTERNAL AMONTO,ADAYTO,AYERTO B7900016^ ^ 3 INTEGER AMONTO,ADAYTO,AYERTO,WRTAPE,STATIT B7900018^ ^ 4 DIMENSION ID(4),IREQBI(24),IDATAI(15),IREQBD(24),IDATAD(15) B7900020^^ 5 DIMENSION IREQBC(24),IDATAC(15),IREQBA(24),IDATAA(15),IREQBS(24) B7900021^^ 6 DIMENSION IDATAS(15),IREQBT(24),IDATAT(15),IREQBU(24),IDATAU(15) B7900022^^ 7 DIMENSION IUTREC(42),IHDR(20,3),MSG1(19),MSG2(21),MSG3(37) B7900023^^ 8 DIMENSION IWORK(3),JDAYS(3),ICURDT(3) B7900024^^ 9 DIMENSION IDLREC(1002),IINREC(14),JSTAT(3),ISUREC(335),IUTKY1(2) B7900025^^ 10 DIMENSION IUTKY2(2),ITRLR(7),IFROM(10),ILEN(10),ITO(10) B7900026^ ^ 11 DIMENSION ISVKEY(8),IDLKEY(8),ISUKEY(8),ICOKEY(8),IACKEY(9) B7900028^^ 12 DIMENSION ITAKEY(8),ITPDTL(4),ITEMP(8),MSG5(37),ITYPE(6,3) B7900029^^ 13 DIMENSION ITOTS(3) B7900030^  ^ 14 DATA IREQBI /24*0/,IREQBD /24*0/,IREQBC /24*0/,IREQBA /24*0/ B7900033^^ 15 DATA IREQBS /24*0/,IREQBT /24*0/,IREQBU /24*0/,IFLAG /0/ B7900034^^ 16 DATA ITLUN /$1006/,IUTKY1 /'HDR0'/,IUTKY2 /'RSW1'/ B7900035^^ 17 DATA IDLREC /1002*$2020/, ITEMP /8*0/,JSTAT /$0052,$0053,$0057/ B7900036^^ 18 DATA ILINE /0/,IPAGE /1/, ITOTS /3*0/, ICOUNT/0/, IDELE/0/ B7900037^^ 19 DATA ITYPE/'RELEASED ', B7900038^^ 19 . 'SATISFIED ', B7900039^^ 19 . 'WRITTEN-OFF '/ B7900040^ ^ 20 INTEGER DATAD(4),DATAC(4),DATAS(4),DATAT(4) ********^^ 21 DATA DATAD,DATAC,DATAS,DATAT/'DELQMST COSIGNERSUMHIST TAPEARC '/ ********^^ 22 DATA IDATAI /'LAINACCT',8*$2020,0,1,0/ ********^^ 23 DATA IDATAD /'LADLQMST',8*$2020,1,1,1/ ********^^ 24 DATA IDATAC /'LACOSIGN',8*$2020,1,1,1/ ********^^ 25 DATA IDATAA /'LAACTFIL',8*$2020,1,1,1/ ********^^ 26 DATA IDATAS /'LASUMHST',8*$2020,1,1,1/ ********^^ 27 DATA IDATAT /'LATAPARC',8*$2020,1,1,1/ ********^^ 28 DATA IDATAU /'LAUTIFIL',8*$2020,1,1,1/ ********^ ^ 29 DATA IFROM / 1, 18, 147, 232, 307, 667, 963, 881, 887, 271/ B7900050^^ 30 DATA ILEN / 16, 125, 30, 14, 360, 90, 4, 6, 9, 4/ B7900051^^ 31 DATA ITO / 1, 24, 149, 179, 193, 553, 643, 647, 653, 662/ B7900052^t FTN 3.3B (OPT = LPC) MHUPDT PAGE 2 DATE: 08/29/84 TIME: 2224 t ^ 32 DATA LMSG1 / 38/ B7900054^^ 33 DATA MSG1 /$D0A,'"RSW1" RECORD NOT PRESENT IN UTIFIL'/ B7900055^ ^ 34 DATA LMSG2 / 42/ B7900057^^ 35 DATA MSG2 /$D0A,'VALUES IN "RSW1" RECORD -- NOT NUMERIC.'/ B7900058^ ^ 36 DATA ITRLR /'END OF HISTORY'/ B7900060^^ 37 DATA LMSG4 / 50/ B7900061^ ^ 38 DATA LMSG5 / 74/ B7900063^^ 39 DATA MSG5 /$D0A,'END-OF-TAPE -- MOUNT ANOTHER REEL.',$D0A,'CARRIAGB7900064^^ 39 .E RETURN WHEN READY. ',$D0A,'READY '/ B7900065^  ^ 40 EQUIVALENCE (IRCT,ITOTS(1)),(ISCT,ITOTS(2)),(IWCT,ITOTS(3)), B7900068^^ 40 . (IR,JDAYS(1)),(IS,JDAYS(2)),(IW,JDAYS(3)) B7900069^ t FTN 3.3B (OPT = LPC) MHUPDT PAGE 3 DATE: 08/29/84 TIME: 2224 t^ 41 CALL PGMIN (ID,LU,I,K) B7900072^^ 42 CALL CCSCST(IDATAU,1,2,ID,1,8,ICM) ********^^ 43 IF(ICM.EQ.0) GO TO 5 ********^^ 44 CALL CCSMVA(IDATAI,3,6,IDATAI,1,8) ********^^ 45 CALL CCSMVA(DATAD ,1,8,IDATAD,1,8) ********^^ 46 CALL CCSMVA(DATAC ,1,8,IDATAC,1,8) ********^^ 47 CALL CCSMVA(IDATAA,3,6,IDATAA,1,8) ********^^ 48 CALL CCSMVA(DATAS ,1,8,IDATAS,1,8) ********^^ 49 CALL CCSMVA(DATAT ,1,8,IDATAT,1,8) ********^^ 50 CALL CCSMVA(IDATAU,3,6,IDATAU,1,8) ********^^ 51 5 CONTINUE ********^^ 52 IF (K.EQ.0) GO TO 20 B7900073^^ C CALL PGMOUT B7900074^ ^ C OPEN THE INACCT FILE B7900077^^ 53 20 CONTINUE B7900078^^ 54 CALL OPENFL (IREQBI,IDATAI,ISTAT) B7900079^^ 55 IF (ISTAT.GE.0) GO TO 40 B7900080^^ 56 CALL FILERR (IDATAI,3,ISTAT,LU) B7900081^^ 57 CALL PGMOUT B7900082^ ^ C OPEN THE DELQMST FILE B7900084^^ 58 40 CONTINUE B7900085^^ 59 CALL OPENFL (IREQBD,IDATAD,ISTAT) B7900086^^ 60 IF (ISTAT.GE.0) GO TO 60 B7900087^^ 61 CALL FILERR (IDATAD,3,ISTAT,LU) B7900088^^ 62 CALL CLOSFL (IREQBI,ISTAT) B7900089^^ 63 CALL PGMOUT B7900090^ ^ C OPEN THE COSIGNER FILE B7900092^^ 64 60 CONTINUE B7900093^^ 65 CALL OPENFL (IREQBC,IDATAC,ISTAT) B7900094^^ 66 IF (ISTAT.GE.0) GO TO 80 B7900095^^ 67 CALL FILERR (IDATAC,3,ISTAT,LU) B7900096^^ 68 CALL CLOSFL (IREQBI,ISTAT) B7900097^^ 69 CALL CLOSFL (IREQBD,ISTAT) B7900098^^ 70 CALL PGMOUT B7900099^ ^ C OPEN THE ACTFIL B7900101^^ 71 80 CONTINUE B7900102^^ 72 CALL OPENFL (IREQBA,IDATAA,ISTAT) B7900103^^ 73 IF (ISTAT.GE.0) GO TO 100 B7900104^^ 74 CALL FILERR (IDATAA,3,ISTAT,LU) B7900105^^ 75 CALL CLOSFL (IREQBI,ISTAT) B7900106^^ 76 CALL CLOSFL (IREQBD,ISTAT) B7900107^^ 77 CALL CLOSFL (IREQBC,ISTAT) B7900108^^ 78 CALL PGMOUT B7900109^ ^ C OPEN THE SUMHIST FILE B7900111^^ 79 100 CONTINUE B7900112^^ 80 CALL OPENFL (IREQBS,IDATAS,ISTAT) B7900113^^ 81 IF (ISTAT.GE.0) GO TO 120 B7900114^^ 82 CALL FILERR (IDATAS,3,ISTAT,LU) B7900115^^ 83 CALL CLOSFL (IREQBI,ISTAT) B7900116^t FTN 3.3B (OPT = LPC) MHUPDT PAGE 4 DATE: 08/29/84 TIME: 2224 t^ 84 CALL CLOSFL (IREQBD,ISTAT) B7900117^^ 85 CALL CLOSFL (IREQBC,ISTAT) B7900118^^ 86 CALL CLOSFL (IREQBA,ISTAT) B7900119^^ 87 CALL PGMOUT B7900120^ ^ C OPEN THE TAPEARC FILE B7900122^^ 88 120 CONTINUE B7900123^^ 89 CALL OPENFL (IREQBT,IDATAT,ISTAT) B7900124^^ 90 IF (ISTAT.GE.0) GO TO 140 B7900125^^ 91 CALL FILERR (IDATAT,3,ISTAT,LU) B7900126^^ 92 CALL CLOSFL (IREQBI,ISTAT) B7900127^^ 93 CALL CLOSFL (IREQBD,ISTAT) B7900128^^ 94 CALL CLOSFL (IREQBC,ISTAT) B7900129^^ 95 CALL CLOSFL (IREQBA,ISTAT) B7900130^^ 96 CALL CLOSFL (IREQBS,ISTAT) B7900131^^ 97 CALL PGMOUT B7900132^ ^ C ACCESS THE UTIFIL FOR HSRS AND RSW B7900134^^ 98 140 CONTINUE B7900135^^ 99 CALL OPENFL (IREQBU,IDATAU,ISTAT) B7900136^^ 100 IF (ISTAT.GE.0) GO TO 180 B7900137^^ 101 CALL FILERR (IDATAU,3,ISTAT,LU) B7900138^ ^ C END OF PROGRAM BRANCH B7900140^^ 102 160 CONTINUE B7900141^^ 103 CALL CLOSFL (IREQBI,ISTAT) B7900142^^ 104 CALL CLOSFL (IREQBD,ISTAT) B7900143^^ 105 CALL CLOSFL (IREQBC,ISTAT) B7900144^^ 106 CALL CLOSFL (IREQBA,ISTAT) B7900145^^ 107 CALL CLOSFL (IREQBS,ISTAT) B7900146^^ 108 CALL CLOSFL (IREQBT,ISTAT) B7900147^^ 109 CALL PGMOUT B7900148^^ 110 180 CONTINUE B7900149^t FTN 3.3B (OPT = LPC) MHUPDT PAGE 5 DATE: 08/29/84 TIME: 2224 t^ C GET HEADERS FROM UTIFIL B7900151^^ 111 DO 220 N = 1,3 B7900152^^ 112 IUTKY1(2) = IUTKY1(2)+1 B7900153^^ 113 CALL READR (IREQBU,IUTREC,IUTKY1,ISTAT) B7900154^ ^ C RECORD THERE? B7900156^^ 114 IF (ISTAT.GE.0.AND.AND(ISTAT,$200).NE.$200) GO TO 200 B7900157^^ 115 CALL FILERR (IDATAU,13,ISTAT,LU) B7900158^^ 116 CALL CLOSFL (IREQBU,ISTAT) B7900159^^ 117 GO TO 160 B7900160^^ 118 200 CONTINUE B7900161^^ 119 CALL CCSMVA (IUTREC,5,40,IHDR(1,N),1,40) B7900162^^ 120 220 CONTINUE B7900163^ ^ C- GET THE RSW1 RECORD FROM THE UTIFIL B7900165^^ 121 CALL READR (IREQBU,IUTREC,IUTKY2,ISTAT) B7900166^ ^ C RECORD THERE? B7900168^^ 122 IF (ISTAT.GE.0.AND.AND(ISTAT,$200).NE.$200) GO TO 240 B7900169^^ 123 CALL WTREAD (LU,-1,MSG1,LMSG1,-1,0,0,K) B7900170^^ 124 CALL CLOSFL (IREQBU,ISTAT) B7900171^^ 125 GO TO 160 B7900172^^ 126 240 CONTINUE B7900173^ ^ C VALIDATE THE RSW1 KEY AND STORE # OF DAYSB7900175^^ 127 DO 300 I = 1,3 B7900176^^ 128 JDAYS(I)=0 B7900177^^ 129 J = 5*I B7900178^^ 130 DO 280 N = 1,3 B7900179^^ 131 CALL CCSGET (IUTREC,J+N,K) B7900180^^ 132 IF (K.GE.$30.AND.K.LE.$39) GO TO 260 B7900181^^ 133 CALL WTREAD (LU,-1,MSG2,LMSG2,-1,0,0,K) B7900182^^ 134 CALL CLOSFL (IREQBU,ISTAT) B7900183^^ 135 GO TO 160 B7900184^^ 136 260 CONTINUE B7900185^ ^ C CONVER TO HEX B7900187^^ 137 IF (N.EQ.1) JDAYS(I) = JDAYS(I)+AND(K,$F)*100 B7900188^^ 138 IF (N.EQ.2) JDAYS(I) = JDAYS(I)+AND(K,$F)*10 B7900189^^ 139 IF (N.EQ.3) JDAYS(I) = JDAYS(I)+AND(K,$F)*1 B7900190^^ 140 280 CONTINUE B7900191^^ 141 300 CONTINUE B7900192^ ^ C CLOSE THE UTIFIL B7900194^^ 142 CALL CLOSFL (IREQBU,ISTAT) B7900195^ ^ C PICK UP SYSTEM DATE AND WRITE IT AS THE B7900197^^ C HEADER RECORD B7900198^^ 143 ICURDT(1) = AND(AMONTO,$FFFF) B7900199^^ 144 ICURDT(2) = AND(ADAYTO,$FFFF) B7900200^^ 145 ICURDT(3) = AND(AYERTO,$FFFF) B7900201^^ 146 ICURJL = ICALJL(ICURDT,1) B7900202^^ 147 ICURYR = ICCSAD(ICURDT(3)) B7900203^^ 148 CALL CCSBLK (IDLREC,2000) B7900204^t FTN 3.3B (OPT = LPC) MHUPDT PAGE 6 DATE: 08/29/84 TIME: 2224 t ^ C BUILD THE TAPE HEADER B7900206^^ 149 CALL CCSMVA (ICURDT,1,6,IDLREC,1,6) B7900207^^ 150 INUM = 3 B7900208^^ 151 ASSIGN 2000 TO WRTAPE B7900209^^ 152 ASSIGN 360 TO IRETRN B7900210^^ 153 GO TO WRTAPE B7900211^t FTN 3.3B (OPT = LPC) MHUPDT PAGE 7 DATE: 08/29/84 TIME: 2224 t^ C READ THE NEXT RECORD FROM THE INACCT FILE B7900213^^ C AND STORE IT INTO IINREC B7900214^^ 154 360 CONTINUE B7900215^^ 155 ICOUNT=ICOUNT + 1 B7900216^^ 156 CALL GETS (IREQBI,IINREC,K,ISTAT) B7900217^ ^ C CHECK FOR EOF B7900219^^ 157 IF (AND(ISTAT,$8100).NE.$8100) GO TO 420 B7900220^ ^ C END OF FILE ON INACCT FILE WRITE EOF B7900222^^ C TRAILER, WRITE EOF AND UNLOAD TAPE B7900223^^ 158 K = IRCT+ISCT+IWCT B7900224^^ 159 WRITE (12,400) IRCT,ISCT,IWCT,K B7900225^^ 160 400 FORMAT (1H0,9X,'TOTALS',//,12X,'RELEASED ',I5,/,12X, B7900226^^ 160 . 'SATISFIED ',I5,/,12X,'WRITTEN-OFF ',I5,//, B7900227^^ 160 . 7X,'MOVED TO HISTORY ',I5) B7900228^ ^ C WRITE TRAILER B7900230^^ 161 CALL CCSBLK (IDLREC,22) B7900231^^ 162 CALL CCSMVA (ITRLR,1,14,IDLREC,1,14) B7900232^^ 163 INUM=10 B7900233^^ 164 ASSIGN 410 TO IRETRN B7900234^^ 165 GO TO WRTAPE B7900235^^ 166 410 CONTINUE B7900236^^ 167 CALL TAPMOT (ITLUN,2) B7900237^^ 168 CALL TAPMOT (ITLUN,4) B7900238^^ 169 GO TO 160 ********^ ^ 170 420 CONTINUE B7900241^^ 171 IF (ISTAT.GE.0) GO TO 440 B7900242^^ 172 CALL FILERR (IDATAI,14,ISTAT,LU) B7900243^^ 173 GO TO 160 B7900244^t FTN 3.3B (OPT = LPC) MHUPDT PAGE 8 DATE: 08/29/84 TIME: 2224 t^ C COMPARE ACCOUNT NUMBER TO PREVIOUS ACCT B7900246^^ C NUMBER B7900247^^ 174 440 CONTINUE B7900248^^ 175 IF (ICOUNT.EQ.1) GO TO 480 B7900249^^ 176 CALL CCSCST (IINREC,1,16,ISVKEY,1,16,ICOMP) B7900250^^ C***** PSR 07/83 ********^^ 177 IF (ICOMP.EQ.0) GO TO 360 ********^^ C***** ********^ ^ C SAVE NEW ACCOUNT NUMBER AND GET THE STATUSB7900262^^ C CODE FROM THE INACCT RECORD B7900263^^ 178 480 CONTINUE B7900264^^ 179 CALL CCSMVA (IINREC,1,16,ISVKEY,1,16) B7900265^^ 180 CALL CCSGET (IINREC,17,IWORK) B7900266^ ^ C CHECK FOR R,S,W CODE B7900268^^ 181 IREAD = 0 B7900269^^ 182 DO 500 N = 1,3 B7900270^^ 183 IF(IWORK.EQ.JSTAT(N)) GO TO 580 B7900271^^ 184 500 CONTINUE B7900272^^ 185 IREAD = -1 B7900273^ ^ C- ACCOUNT STAUTS CODE INACCT IS NOT B7900275^^ C- EQUAL TO R,S,W. CHECK TH STATUS B7900276^^ C OF THE DELQMST FILE B7900277^^ 186 DO 520 K = 1,8 B7900278^^ 187 IDLKEY(K) = ISVKEY(K) B7900279^^ 188 520 CONTINUE B7900280^^ 189 CALL READR (IREQBD,IDLREC,IDLKEY,ISTAT) B7900281^ ^ C CHECK FOR NOT FOUND OR EOF B7900283^^ 190 IF (AND(ISTAT,$200).EQ.$200 .OR. AND(ISTAT,$8100).EQ.$8100) B7900284^^ 190 . GO TO 360 ********^^ 191 IF (ISTAT.GE.0) GO TO 540 B7900286^^ 192 CALL FILERR (IDATAD,13,ISTAT,LU) B7900287^^ 193 GO TO 160 B7900288^^ 194 540 CONTINUE B7900289^ ^ C CHECK STATUS OF DELQMST B7900291^^ 195 CALL CCSMVA (IDLREC,306,1,IINREC,17,1) B7900292^^ 196 CALL CCSGET (IINREC,17,IWORK) B7900293^^ 197 DO 560 N = 1,3 B7900294^^ 198 IF (IWORK.EQ.JSTAT(N)) GO TO 580 B7900295^^ 199 560 CONTINUE B7900296^ ^ C ACCT NOT R,S,W; READ NEXT INACCT RECORD ********^^ 200 GO TO 360 ********^ ^ C VAILDATE THE DATE IN THE INACCT RECORD B7900301^^ 201 580 CONTINUE B7900302^^ 202 K = ICALJL(IINREC(10),1) B7900303^^ 203 IF (K.GT.0) GO TO 620 B7900304^ ^ C INVALID DATE PUT IN TODAYS DATE B7900306^t FTN 3.3B (OPT = LPC) MHUPDT PAGE 9 DATE: 08/29/84 TIME: 2224 t^ C UPDATE THE INACCT RECORD B7900307^^ C AND GET ANOTHER RECORD B7900308^^ 204 CALL CCSMVA (ICURDT,1,6,IINREC(10),1,6) B7900309^^ 205 CALL UPDREC (IREQBI,IINREC,ISTAT) B7900310^^ 206 IF (ISTAT.GE.0) GO TO 620 B7900311^^ 207 CALL FILERR (IDATAI,15,ISTAT,LU) B7900312^^ 208 GO TO 160 B7900313^^ 209 600 CONTINUE B7900314^^ 210 GO TO 360 B7900315^ ^ C SEE IF NUMBER OF DAYS IS WITHIN TOLERANCE B7900317^^ 211 620 CONTINUE B7900318^^ 212 IF (JDAYS(N).LE.((ICURJL-ICALJL(IINREC(10),1))+ B7900319^^ 212 . 365*(ICURYR-ICCSAD(IINREC(12))))) GO TO 640 B7900320^ ^ C DOES NOT MEET - GET NEXT RECORD B7900322^^ 213 GO TO 360 B7900323^t FTN 3.3B (OPT = LPC) MHUPDT PAGE 10 DATE: 08/29/84 TIME: 2224 t^ C SET UP KEYS FOR READING THE OTHER FILES B7900325^^ 214 640 CONTINUE B7900326^^ 215 DO 660 K = 1,8 B7900327^^ 216 IDLKEY(K) = ISVKEY(K) B7900328^^ 217 ICOKEY(K) = ISVKEY(K) B7900329^^ 218 ISUKEY(K) = ISVKEY(K) B7900330^^ 219 IACKEY(K) = ISVKEY(K) B7900331^^ 220 ITAKEY(K) = ISVKEY(K) B7900332^^ 221 660 CONTINUE B7900333^ ^ C READ DELQMST IF NOT ALREADY READ B7900335^^ 222 IF (IREAD.EQ.0) CALL READR (IREQBD,IDLREC,IDLKEY,ISTAT) B7900336^^ 223 IF (IREAD.NE.0) GO TO 680 B7900337^ ^ C REC NOT THERE OR EOF, READ NEXT INACCT ********^^ 224 IF (AND(ISTAT,$200).EQ.$200 .OR. AND(ISTAT,$8100).EQ.$8100) B7900340^^ 224 . GO TO 360 ********^^ 225 IF (ISTAT.GE.0) GO TO 680 B7900342^^ 226 CALL FILERR (IDATAD,13,ISTAT,LU) B7900343^^ 227 GO TO 160 B7900344^^ 228 680 CONTINUE B7900345^^ C CHECK IF R,S,W-IF R,S,W WRITE TO TAPE B7900346^^ 229 IF(AND(IDLREC(153),$FF).EQ.$20) GO TO 360 ********^^ 230 ASSIGN 700 TO IRETRN B7900349^^ 231 INUM = 1000 B7900350^^ 232 GO TO WRTAPE B7900351^ ^ C BUILD SUMHIST B7900353^^ 233 700 CONTINUE B7900354^ ^ 234 DO 710 J= 1,10 B7900356^^ 235 CALL CCSMVA (IDLREC,IFROM(J),ILEN(J),ISUREC,ITO(J),ILEN(J)) B7900357^^ 236 710 CONTINUE B7900358^ ^ 237 ISUREC(9) = ICURDT(1) B7900360^^ 238 ISUREC(10) = ICURDT(2) B7900361^^ 239 ISUREC(11) = ICURDT(3) B7900362^^ 240 ISUREC(12) = AND(ISUREC(12),$FF)+IWORK*$100 B7900363^ ^ C**************************************************** PSR (05/83) ********^^ C*** CHECK IF NAME CHANGE NOT COMPLETE - IF SO MOVE ********^^ C*** OLD NAME KEY TO CURRENT NAME KEY ! THEN DELETE ********^ ^ 241 CALL CCSCST(IDLREC,1047,6,0,0,0,ICOMP) ********^^ 242 IF(ICOMP.NE.0) CALL CCSMVA(IDLREC,1047,6,IDLREC,18,6) ********^^ C DELETE RECORD FROM DELQMST B7900365^^ C WRITE RECORD TO SUMHIST FILE B7900366^^ 243 CALL DELREC (IREQBD,IDLREC,ISTAT) B7900367^^ 244 IF (ISTAT.GE.0) GO TO 720 B7900368^^ C**************************************************** PSR (05/83) ********^^ C*** IF CANT FIND OLD KEY 2 - THEN DONT WORRY ABOUT IT ! ********^ ^ 245 IF(ISTAT.EQ.$8800) GO TO 720 ********^^ C**************************************************** *** (05/83) ********^t FTN 3.3B (OPT = LPC) MHUPDT PAGE 11 DATE: 08/29/84 TIME: 2224 t^ 246 CALL FILERR (IDATAD,16,ISTAT,LU) B7900369^^ 247 GO TO 160 B7900370^ ^ 248 720 CONTINUE B7900372^^ 249 CALL WRITER (IREQBS,ISUREC,ISUKEY,ISTAT) B7900373^^ 250 IF (ISTAT.GE.0) GO TO 800 B7900374^^ 251 IF (AND(ISTAT,$8010).EQ.$8010) GO TO 740 B7900375^^ 252 CALL FILERR (IDATAS,12,ISTAT,LU) B7900376^^ 253 GO TO 160 B7900377^ ^ C RECORD FOR THIS ACCT # ALREADY EXISTS B7900379^^ C UPDATE IT B7900380^^ 254 740 CONTINUE B7900381^^ 255 CALL READR (IREQBS,IDLREC,ISUKEY,ISTAT) B7900382^^ 256 IF (ISTAT.GE.0) GO TO 760 B7900383^^ 257 CALL FILERR (IDATAS,13,ISTAT,LU) B7900384^^ 258 GO TO 160 B7900385^^ 259 760 CONTINUE B7900386^^ 260 CALL CCSMVA (ISUREC,1,666,IDLREC,1,666) B7900387^^ 261 CALL UPDREC (IREQBS,IDLREC,ISTAT) B7900388^^ 262 IF (ISTAT.GE.0) GO TO 780 B7900389^^ 263 CALL FILERR (IDATAS,15,ISTAT,LU) B7900390^^ 264 GO TO 160 B7900391^^ 265 780 CONTINUE B7900392^ ^ C SEE IF ANY COSIGNERS B7900394^^ 266 800 CONTINUE B7900395^^ 267 M = 0 B7900396^^ 268 CALL CCSBLK (IDLREC,500) B7900397^^ 269 CALL READR (IREQBC,IDLREC,ICOKEY,ISTAT) B7900398^ ^ C RECORD THERE OR EOF? B7900400^^ 270 IF (AND(ISTAT,$200).EQ.$200 .OR. AND(ISTAT,$8100).EQ.$8100) B7900401^^ 270 . GO TO 860 B7900402^^ 271 IF (ISTAT.GE.0) GO TO 820 B7900403^^ 272 CALL FILERR (IDATAC,13,ISTAT,LU) B7900404^^ 273 GO TO 160 B7900405^ ^ C COSIGNER RECORD FOUND -DELETE IT B7900407^^ 274 820 CONTINUE B7900408^^ 275 M = 1 B7900409^^ 276 CALL DELREC (IREQBC,IDLREC,ISTAT) B7900410^^ 277 IF (ISTAT.GE.0) GO TO 840 B7900411^^ 278 CALL FILERR (IDATAC,16,ISTAT,LU) B7900412^^ 279 GO TO 160 B7900413^ ^ C RESTORE THE KEY B7900415^^ 280 840 CONTINUE B7900416^^ 281 CALL CCSMVA (ISVKEY,1,16,IDLREC,1,16) B7900417^^ C ****************************************************** ???*0016********^^ 282 GO TO 870 ********^ ^ C BLANK COSIGNER PART OF RECORD, NO ********^^ C COSIGNER FOUND ********^t FTN 3.3B (OPT = LPC) MHUPDT PAGE 12 DATE: 08/29/84 TIME: 2224 t^ 283 860 CALL CCSBLK ( IDLREC, 500 ) ********^^ C ****************************************************** ???*0016********^ ^ C BEING ASSEMBLING THE ACTIVITY BLOCKS B7900419^^ C ****************************************************** ???*0016********^^ 284 870 CONTINUE ********^^ C ****************************************************** ???*0016********^ ^ C POSITION AFTER COSIGNER B7900422^^ 285 K = 251 B7900423^^ 286 880 CONTINUE B7900424^^ 287 IACKEY(9) = $2020 B7900425^^ 288 CALL READR (IREQBA,IDLREC(K),IACKEY,ISTAT) B7900426^ ^ C CHECK FOR NO ERROR OR EOF B7900428^^ C ****************************************************** ???*0016********^^ 289 IF ( ISTAT .GE. 0 ) GO TO 900 ********^^ 290 IF ( AND(ISTAT,$8100) .NE. 0 ) GO TO 960 ********^^ C ****************************************************** ???*0016********^^ 291 CALL FILERR (IDATAA,13,ISTAT,LU) B7900430^^ 292 GO TO 160 B7900431^^ 293 900 CONTINUE B7900432^ ^ C WAS THE ACTFIL RECORD RETRIEVED THE SAME B7900434^^ C KEY IF NOT THE SAEM BRANCH TO WRITE B7900435^^ 294 CALL CCSCST (ISVKEY,1,16,IDLREC(K),1,16,ICOMP) B7900436^^ 295 IF (ICOMP.NE.0) GO TO 960 B7900437^ ^ C FOUND AN ACTFIL BLOCK - DELETE IT AND B7900439^^ C LOOK FOR MORE B7900440^^ 296 CALL DELREC (IREQBA,IDLREC(K),ISTAT) B7900441^^ 297 IF (ISTAT.GE.0) GO TO 920 B7900442^^ 298 CALL FILERR (IDATAA,16,ISTAT,LU) B7900443^^ 299 GO TO 160 B7900444^^ 300 920 CONTINUE B7900445^ ^ C RESTORE KEY B7900447^^ 301 CALL CCSMVA (ISVKEY,1,16,IACKEY,1,18) B7900448^^ 302 CALL CCSMVA (ISVKEY,1,16,IDLREC(K),1,16) B7900449^ ^ C ****************************************************** ???*0016********^^ C IF ACTFIL RECORD ALREADY CAME FROM TAPE ********^^ C HISTORY (SUFFIX > 50), CONTINUE TO READ ********^^ C AND DELETE BLOCKS OVER 50 - DO NOT SAVE ********^^ C TO TAPE ********^^ 303 IF ( IDLREC(K+8) .GE. $3531 ) GO TO 880 ********^^ C ****************************************************** ???*0016********^ ^ C INCREMENT TO POSITION NEXT ACTIVITY BLOCK B7900451^^ 304 K = K+250 B7900452^^ 305 IF (K.LT.1000) GO TO 880 B7900453^ ^ C TAPE BUFFER FULL--OUTPUT BUFFER B7900455^^ C GO BACK AND SEE IF MORE. B7900456^t FTN 3.3B (OPT = LPC) MHUPDT PAGE 13 DATE: 08/29/84 TIME: 2224 t^ 306 M = -1 B7900457^^ 307 INUM = K-1 B7900458^^ 308 ASSIGN 940 TO IRETRN B7900459^^ 309 GO TO WRTAPE B7900460^^ 310 940 CONTINUE B7900461^^ 311 CALL CCSBLK (IDLREC,2000) B7900462^^ 312 K = 1 B7900463^^ 313 GO TO 880 B7900464^ ^ C DETERMINE IF THER IS ANYTHING IN BUFFER B7900466^^ C TO WRITE B7900467^^ 314 960 CONTINUE B7900468^^ 315 IF ((M.EQ.0.AND.K.LT.501).OR.(M.LT.0.AND.K.LT.251)) GO TO 980 B7900469^^ 316 INUM = K-1 B7900470^^ 317 ASSIGN 980 TO IRETRN B7900471^^ 318 GO TO WRTAPE B7900472^ ^ C GET TAPEARC RECORD TEST TO SEE IF DATES B7900474^^ C WILL BE LOST B7900475^^ 319 980 CONTINUE B7900476^^ 320 CALL CCSBLK (ITPDTL,8) B7900477^^ 321 CALL READR (IREQBT,IDLREC,ITAKEY,ISTAT) B7900478^ ^ C RECORD THERE OR EOF B7900480^^ 322 IF (AND(ISTAT,$200).EQ.$200 .OR. AND(ISTAT,$8100).EQ.$8100) B7900481^^ 322 . GO TO 1100 B7900482^^ 323 IF (ISTAT.GE.0) GO TO 1000 B7900483^^ 324 CALL FILERR (IDATAT,13,ISTAT,LU) B7900484^^ 325 GO TO 160 B7900485^^ 326 1000 CONTINUE B7900486^ ^ C SEE IF DATES ARE LOST B7900488^^ 327 IF (IDLREC(21).EQ.$2020) GO TO 1040 B7900489^ ^ C EDIT LOST DATE FOR OUTPUT LINE B7900491^^ 328 ASSIGN 1020 TO IFORM B7900492^^ 329 CALL ENCODE (ITPDTL,IFORM,3,IDLREC(21)) B7900493^^ 330 1020 FORMAT (A2,'/',A2,'/',A2) B7900494^^ 331 1040 CONTINUE B7900495^ ^ C MOVE DATES DOWN B7900497^^ 332 DO 1060 K = 20,9,-1 B7900498^^ 333 IDLREC(K+3) = IDLREC(K) B7900499^ ^ C MOVE CURRENT DATE TO DATE1 B7900501^^ 334 1060 CONTINUE B7900502^^ 335 CALL CCSMVA (ICURDT,1,6,IDLREC,17,6) B7900503^^ 336 CALL UPDREC (IREQBT,IDLREC,ISTAT) B7900504^^ 337 IF (ISTAT.GE.0) GO TO 1080 B7900505^^ 338 CALL FILERR (IDATAT,15,ISTAT,LU) B7900506^^ 339 GO TO 160 B7900507^^ 340 1080 CONTINUE B7900508^^ 341 GO TO 1140 ********^ t FTN 3.3B (OPT = LPC) MHUPDT PAGE 14 DATE: 08/29/84 TIME: 2224 t^ C NO RECORD EXISTS - CREATE A TAPEARC RECORDB7900511^^ 342 1100 CONTINUE B7900512^^ 343 CALL CCSBLK (IDLREC,46) B7900513^^ 344 CALL CCSMVA (ISVKEY,1,16,IDLREC,1,16) B7900514^^ 345 CALL CCSMVA (ICURDT,1,6,IDLREC,17,6) B7900515^^ 346 CALL CCSMVA (ISVKEY,1,16,ITAKEY,1,16) B7900516^^ 347 CALL WRITER (IREQBT,IDLREC,ITAKEY,ISTAT) B7900517^^ 348 IF(ISTAT.GE.0) GO TO 1140 ********^^ 349 CALL FILERR (IDATAT,12,ISTAT,LU) B7900519^^ 350 GO TO 160 B7900520^ t FTN 3.3B (OPT = LPC) MHUPDT PAGE 15 DATE: 08/29/84 TIME: 2224 t^ C PRINT HEADINGS B7900530^^ 351 1140 CONTINUE B7900531^^ 352 IF (ILINE.NE.0) GO TO 1200 B7900532^^ 353 WRITE (12,1160)(IHDR(M,1),M=1,20),IPAGE B7900533^^ 354 1160 FORMAT (1H1,20A2,8X,'ACCOUNT MOVEMENT TO HISTORY',42X, B7900534^^ 354 . 'PAGE ',I3) B7900535^^ 355 WRITE (12,1180)(IHDR(M,2),M=1,20),ICURDT,(IHDR(M,3),M=1,20), B7900536^^ 355 . IR,IS,IW B7900537^^ 356 1180 FORMAT (1X,20A2,12X,'RUN DATE: ',A2,'/',A2,'/',A2,/,1X,20A2, B7900538^^ 356 . 9X,'AS OF: RELEASED',I3,' DAYS, SATISFIED ',I3, B7900539^^ 356 . ' DAYS, WRITTEN-OFF ',I3,' DAYS',/,1H0,15X,'ACCOUNT', B7900540^^ 356 . 9X,'BORROWERS',24X,'INACTIVE',9X,'DATE',5X, B7900541^^ 356 . 'DATE LOST WITH',/,16X,'NUMBER',10X,'NAME',30X, B7900542^^ 356 . 'STATUS',8X,'INACTIVE TAPE ARCHIVE DATA',/) B7900543^^ 357 IPAGE = IPAGE+1 B7900544^^ 358 1200 CONTINUE B7900545^ ^ C INCREMENT LINE COUNTER B7900547^^ C AND WRITE DETAIL LINE B7900548^^ 359 ILINE = ILINE+1 B7900549^^ 360 WRITE (12,1220)(ISUREC(M),M=1,8),(ISUREC(M),M=12,27), B7900550^^ 360 . (ITYPE(M,N),M=1,6),(IINREC(M),M=10,12),ITPDTL B7900551^^ 361 1220 FORMAT (11X,8A2,4X,R1,14A2,A1,3X,6A2,5X,A2,'/',A2,'/',A2,4X,4A2) B7900552^ ^ C ACCUMULATE TOTALS B7900554^^ 362 ITOTS(N) = ITOTS(N)+1 B7900555^ ^ C CHECK FOR END OF PAGE B7900557^^ 363 IF(ILINE.EQ.50) ILINE = 0 B7900558^^ 364 GO TO 360 B7900559^t FTN 3.3B (OPT = LPC) MHUPDT PAGE 16 DATE: 08/29/84 TIME: 2224 t^ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCB7900591^^ C- B7900592^^ C- MODULE USED TO WRITE DATA TO TAPE (WRTAPE) B7900593^^ C- B7900594^^ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCB7900595^ ^ 365 2000 CONTINUE B7900597^^ 366 ASSIGN 2020 TO IOCOMP B7900598^^ 367 CALL FWRITE (ITLUN,IDLREC,INUM,IOCOMP,IFLAG,ITEMP) B7900599^^ 368 CALL DISP B7900600^ ^ C GET TAPE STATUS B7900602^^ 369 2020 CONTINUE B7900603^^ 370 ITPST=STATIT (ITLUN) B7900604^ ^ C CHECK FOR END OF TAPE B7900606^^ 371 IF (AND(ITPST,$200).EQ.$200) GO TO 2040 B7900607^^ 372 GO TO IRETRN B7900608^ ^ C END OF TAPE ENCOUNTERED B7900610^^ C WRITE FILE MARK/REWIND AND UNLOAD B7900611^^ 373 2040 CONTINUE B7900612^^ 374 CALL TAPMOT (ITLUN,2) B7900613^^ 375 CALL TAPMOT (ITLUN,4) B7900614^^ 376 2060 CONTINUE B7900615^^ 377 CALL WTREAD (LU,-1,MSG5,LMSG5,-1,IWORK(2),1,J) B7900616^^ 378 IF (J.NE.2) GO TO 2060 B7900617^^ 379 ASSIGN 2080 TO IOCOMP B7900618^^ 380 CALL FWRITE (ITLUN,ICURDT,3,IOCOMP,IFLAG,ITEMP) B7900619^^ 381 CALL DISP B7900620^ ^ C GET TAPE STATUS B7900622^^ 382 2080 CONTINUE B7900623^ ^ C CHECK FOR END OF TAPE B7900625^^ 383 ITPST = STATIT(ITLUN) B7900626^^ 384 IF (AND(ITPST,$200).EQ.$200) GO TO 2040 B7900627^^ 385 GO TO IRETRN B7900628^ ^ 386 2100 CONTINUE B7900630^^ 387 CALL PGMOUT B7900631^^ 388 END B7900632^t FTN 3.3B (OPT = LPC) MHUPDT PAGE 17 DATE: 08/29/84 TIME: 2224 t  PROGRAM LENGTH $0F2B ( 3883)   EXTERNALS 2 Q8STP Q8QINI Q8QX Q8QEND AMONTO ADAYTO AYERTO 22 STATIT PGMIN CCSCST CCSMVA OPENFL FILERR PGMOUT 22 CLOSFL READR WTREAD CCSGET ICALJL ICCSAD CCSBLK 22 GETS TAPMOT UPDREC DELREC WRITER ENCODE FWRITE 2 DISP  t FTN 3.3B (OPT = LPC) MHUPDT PAGE 18 DATE: 08/29/84 TIME: 2224 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < & 8010 (-32751) 0804 251,251&: 8100 (-32511) 07F4 157,157,190,224,270,290,322:" 8800 (-30719) 0803 245"6 FFFE (-1) 07E9 123,123,133,185,306,3776* FFFF (65535) 07EE 143,144,145*‚ 0000 (0) 0003 14,15,17,18,22,43,52,55,60,66,73,81,90,100,114,122,123,128,133,171,177,181,191,203,206,222,223,225 ‚l ,241,242,244,250,256,262,267,271,277,289,290,295,297,315,323,337,348,352,363 l€ 0001 (1) 0002 18,22,23,24,25,26,27,28,29,31,40,42,44,45,46,47,48,49,50,111,112,119,123,127,130,133,137,139,143,€€ 146,149,155,162,175,176,179,182,185,186,195,197,202,204,212,215,234,237,260,275,281,294,301,302, €^ 306,307,312,316,332,335,344,345,346,353,355,357,359,360,362,377^F 0002 (2) 07DE 42,112,138,144,167,238,355,374,377,378 Fv 0003 (3) 07E1 44,47,50,56,61,67,74,82,91,101,111,127,130,139,145,147,150,182,197,239,329,333,355,380 v* 0004 (4) 07F8 168,360,375*& 0005 (5) 07E7 119,129&D 0006 (6) 07E2 44,47,50,149,204,241,242,335,345,360 DJ 0008 (8) 07DF 42,44,45,46,47,48,49,50,186,215,303,320,360J> 000A (10) 07ED 138,163,202,204,212,234,238,360>> 000C (12) 07F5 158,212,240,252,349,353,355,360>: 000D (13) 07E6 115,192,226,257,272,291,324:* 000E (14) 07F7 162,162,172*6 000F (15) 07EB 137,138,139,207,263,3386N 0010 (16) 07F9 176,176,179,246,278,281,294,298,301,302,344,346N2 0011 (17) 07FB 180,195,196,335,3452& 0012 (18) 0802 242,301&" 0016 (22) 07F6 161"& 0028 (40) 07E8 119,119&" 002E (46) 080E 343"" 0064 (100) 07EC 137"" 00FA (250) 080B 304"& 00FB (251) 0808 285,315&& 00FF (255) 07FF 229,240&" 0132 (306) 07FD 195"" 016D (365) 07FE 212"& 01F4 (500) 0807 268,283&" 01F5 (501) 080C 315"B 0200 (512) 07E5 114,114,122,190,224,270,322,371,384B& 029A (666) 0805 260,260&* 03E8 (1000) 0800 231,305,323*& 0417 (1047) 0801 241,242&& 07D0 (2000) 07F1 148,311&& 2020 (8224) 0809 287,327&" 3531 (13617) 080A 303"t FTN 3.3B (OPT = LPC) MHUPDT PAGE 19 DATE: 08/29/84 TIME: 2224 t   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < j AND INTR.FN. 7FFF 114,122,137,138,139,143,144,145,157,190,224,229,240,251,270,290,322,371,384j( DATAC INTEGER 07CB 19,21,46 (( DATAD INTEGER 07C7 19,21,45 (( DATAS INTEGER 07CF 19,21,48 (( DATAT INTEGER 07D3 19,21,49 (: I INTEGER 07DC 41,127,128,129,137,138,139 :0 IACKEY INTEGER 076A 3,219,287,288,3010$ ICM INTEGER 07E0 42,43$( ICOKEY INTEGER 0762 3,217,269(6 ICOMP INTEGER 07FA 176,177,241,242,294,2956* ICOUNT INTEGER 07C5 18,155,175 *X ICURDT INTEGER 01D4 3,143,144,145,146,147,149,204,237,238,239,335,345,355,380X* ICURJL INTEGER 07EF 145,146,212** ICURYR INTEGER 07F0 146,147,212*& ID INTEGER 0006 3,41,42&4 IDATAA INTEGER 0097 3,25,47,72,74,291,29844 IDATAC INTEGER 0070 3,24,46,65,67,272,27848 IDATAD INTEGER 0049 3,23,45,59,61,192,226,24684 IDATAI INTEGER 0022 3,22,44,54,56,172,20748 IDATAS INTEGER 00BE 3,26,48,80,82,252,257,26388 IDATAT INTEGER 00E5 3,27,49,89,91,324,338,34984 IDATAU INTEGER 010C 3,28,42,50,99,101,1154" IDELE INTEGER 07C6 18 "0 IDLKEY INTEGER 0752 3,187,189,216,2220€ IDLREC INTEGER 01D7 3,17,148,149,161,162,189,195,222,229,235,241,242,243,255,260,261,268,269,276,281,283,288,294,296,€V 302,303,311,321,327,329,333,335,336,343,344,345,347,367V* IFLAG INTEGER 07C1 15,367,380 *& IFORM INTEGER 080D 327,329&( IFROM INTEGER 072C 3,29,235 (, IHDR INTEGER 0145 3,119,353,355,L IINREC INTEGER 05C1 3,156,176,179,180,195,196,202,204,205,212,360L( ILEN INTEGER 0736 3,30,235 (. ILINE INTEGER 07C3 17,352,359,363 .: INUM INTEGER 07F2 149,150,163,231,307,316,367:. IOCOMP INTEGER 080F 365,367,379,380.* IPAGE INTEGER 07C4 18,353,357 *& IR INTEGER 01D1 40,355 &* IRCT INTEGER 07BE 39,158,159 *2 IREAD INTEGER 07FC 180,181,185,222,22328 IREQBA INTEGER 007F 3,14,72,86,95,106,288,2968< IREQBC INTEGER 0058 3,14,65,77,85,94,105,269,276 <B IREQBD INTEGER 0031 3,14,59,69,76,84,93,104,189,222,243BB IREQBI INTEGER 000A 3,14,54,62,68,75,83,92,103,156,205 B: IREQBS INTEGER 00A6 3,15,80,96,107,249,255,261 :6 IREQBT INTEGER 00CD 3,15,89,108,321,336,3476> IREQBU INTEGER 00F4 3,15,99,113,116,121,124,134,142>: IRETRN INTEGER 07F3 151,164,230,308,317,372,385:t FTN 3.3B (OPT = LPC) MHUPDT PAGE 20 DATE: 08/29/84 TIME: 2224 t& IS INTEGER 01D2 40,355 &* ISCT INTEGER 07BF 40,158,159 *‚ ISTAT INTEGER 07E3 54,55,56,59,60,61,62,65,66,67,68,69,72,73,74,75,76,77,80,81,82,83,84,85,86,89,90,91,92,93,94,95,96 ‚€ ,99,100,101,103,104,105,106,107,108,113,114,115,116,121,122,124,134,142,156,157,171,172,189,190, €€ 191,192,205,206,207,222,224,225,226,243,244,245,246,249,250,251,252,255,256,257,261,262,263,269, €z 270,271,272,276,277,278,288,289,290,291,296,297,298,321,322,323,324,336,337,338,347,348,349z, ISUKEY INTEGER 075A 3,218,249,255,@ ISUREC INTEGER 05D2 3,235,237,238,239,240,249,260,360@X ISVKEY INTEGER 074A 3,176,179,187,216,217,218,219,220,281,294,301,302,344,346X0 ITAKEY INTEGER 0773 3,220,321,346,3470, ITEMP INTEGER 077F 3,17,367,380 ,B ITLUN INTEGER 07C2 15,167,168,367,370,374,375,380,383 B( ITO INTEGER 0740 3,31,235 (* ITOTS INTEGER 07BE 3,18,40,362*, ITPDTL INTEGER 077B 3,320,329,360,2 ITPST INTEGER 0810 369,370,371,383,3842( ITRLR INTEGER 0725 3,36,162 (( ITYPE INTEGER 07AC 3,19,360 (, IUTKY1 INTEGER 0721 3,16,112,113 ,( IUTKY2 INTEGER 0723 3,16,121 (0 IUTREC INTEGER 011B 3,113,119,121,1310& IW INTEGER 01D3 40,355 &* IWCT INTEGER 07C0 40,158,159 *8 IWORK INTEGER 01CE 3,180,183,196,198,240,3778: J INTEGER 07EA 128,129,131,234,235,377,378:8 JDAYS INTEGER 01D1 3,40,128,137,138,139,212 8, JSTAT INTEGER 05CF 3,17,183,198 ,‚ K INTEGER 07DD 41,52,123,131,132,133,137,138,139,156,158,159,186,187,202,203,215,216,217,218,219,220,285,288,294, ‚J 296,302,303,304,305,307,312,315,316,332,333J& LMSG1 INTEGER 07D7 31,123 && LMSG2 INTEGER 07D8 33,133 &" LMSG4 INTEGER 07D9 36 "& LMSG5 INTEGER 07DA 36,377 &€ LU INTEGER 07DB 41,56,61,67,74,82,91,101,115,123,133,172,192,207,226,246,252,257,263,272,278,291,298,324,338,349,€" 377"> M INTEGER 0806 266,267,275,306,315,353,355,360>( MSG1 INTEGER 0181 3,33,123 (( MSG2 INTEGER 0194 3,35,133 ( MSG3 INTEGER 01A9 3 ( MSG5 INTEGER 0787 3,39,377 (V N INTEGER 07E4 110,119,130,131,137,138,139,182,183,197,198,212,360,362V& Q8QX1 INTEGER 0004 355,360&8 WRTAPE INTEGER 0005 3,151,153,165,232,309,3188t FTN 3.3B (OPT = LPC) MHUPDT PAGE 21 DATE: 08/29/84 TIME: 2224 t   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < : CCSBLK SUBROUTINE 0D39 147,161,268,283,311,320,343:. CCSCST SUBROUTINE 0C6D 41,176,241,294 .* CCSGET SUBROUTINE 0A83 130,180,196*t CCSMVA SUBROUTINE 0D21 43,45,46,47,48,49,50,119,149,162,179,195,204,235,242,260,281,301,302,335,344,345,346 tt CLOSFL SUBROUTINE 0970 61,68,69,75,76,77,83,84,85,86,92,93,94,95,96,103,104,105,106,107,108,116,124,134,142 t* DELREC SUBROUTINE 0C2C 242,276,296*& DISP SUBROUTINE 0EF1 367,381&" ENCODE SUBROUTINE 0D04 327"t FILERR SUBROUTINE 0CF2 55,61,67,74,82,91,101,115,172,192,207,226,246,252,257,263,272,278,291,298,324,338,349t& FWRITE SUBROUTINE 0EE9 365,380&" GETS SUBROUTINE 09DA 155"* ICALJL INTEGER.FN. 0AE3 146,202,212*& ICCSAD INTEGER.FN. 0B06 147,212&4 OPENFL SUBROUTINE 08DD 53,59,65,72,80,89,99 4" PGMIN SUBROUTINE 0812 40 "8 PGMOUT SUBROUTINE 0F28 56,63,70,78,87,97,109,3878 Q8QEND INTEGER.FN. 0EBA Q8QINI INTEGER.FN. 0E6D . Q8QX SUBROUTINE 0E7A 159,353,355,360. Q8STP INTEGER.FN. 0F2A > READR SUBROUTINE 0CDC 112,121,189,222,255,269,288,321>( STATIT INTEGER.FN. 0EF3 3,370,383(. TAPMOT SUBROUTINE 0EFE 166,168,374,375.* UPDREC SUBROUTINE 0D29 204,261,336*& WRITER SUBROUTINE 0D52 248,347&* WTREAD SUBROUTINE 0F05 122,133,377*   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 5 0856 43,51$$ 20 085A 52,53$$ 40 086A 55,58$$ 60 087C 60,64$$ 80 088F 66,71$$ 100 08A5 73,79$$ 120 08BF 81,88$$ 140 08DC 90,98$n 160 08EB 101,117,125,135,169,173,193,208,227,247,253,258,264,273,279,292,299,325,339,350n& 180 0900 100,110&& 200 091D 114,118&& 220 092A 110,120&& 240 0949 122,126&& 260 0976 132,136&t FTN 3.3B (OPT = LPC) MHUPDT PAGE 22 DATE: 08/29/84 TIME: 2224 t& 280 0996 129,140&& 300 099B 126,141&F 360 09D7 151,154,177,190,200,210,213,224,229,364F& 400 0A00 158,160&& 410 0A54 163,166&& 420 0A5D 157,170&& 440 0A68 171,174&& 480 0A7B 175,178&& 500 0A95 181,184&& 520 0AA4 185,188&& 540 0AC8 191,194&& 560 0ADB 196,199&* 580 0AE2 183,198,201*" 600 0B03 208"* 620 0B05 203,206,211*& 640 0B1E 212,214&& 660 0B2E 214,221&* 680 0B5A 223,225,228*& 700 0B6C 229,233&& 710 0B87 233,236&* 720 0BCB 244,245,248*& 740 0BE1 251,254&& 760 0BF1 256,259&& 780 0C07 262,265&& 800 0C07 250,266&& 820 0C29 271,274&& 840 0C3B 277,280&& 860 0C44 270,283&& 870 0C47 281,284&. 880 0C4B 285,303,305,313.& 900 0C68 289,293&& 920 0C8C 297,300&& 940 0CBA 307,310&* 960 0CC2 290,295,314** 980 0CD8 315,317,319*& 1000 0CF9 323,326&& 1020 0D0A 327,330&& 1040 0D13 327,331&& 1060 0D1A 331,334&& 1080 0D37 337,340&& 1100 0D38 322,342&* 1140 0D61 340,348,351*& 1160 0D81 353,354&& 1180 0DD5 355,356&& 1200 0E6A 352,358&& 1220 0EBC 360,361&& 2000 0EE4 150,365&& 2020 0EF2 365,369&* 2040 0EFD 371,373,384*& 2060 0F04 375,378&& 2080 0F1E 378,382&" 2100 0F27 385" MHUPDT 0000 1 t FTN 3.3B (OPT = LPC) MOVDAT PAGE 1 DATE: 08/29/84 TIME: 2227 t^ 1 PROGRAM MOVDAT B8000001^^ 1 1 /B80 F CCS CCS 3.0 SL-149B8000002^^ C B8000003^^ C CYBERCREDIT SYSTEM VERSION 3 B8000004^^ C DATA SYSTEM - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B8000005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B8000006^^ C B8000007^^ C THIS PROGRAM COPIES ONE FILE TO ANOTHER FILE. B8000008^^ C THE MAXIMUM CHARACTERS TO BE COPIED IS 3000. BOTH FILES B8000009^^ C MUST HAVE THE SAME FILE DESCRIPTION. *** NOTE B8000010^^ C DELETED RECORDS ARE NOT COPIED TO THE OUTPUT FILE. B8000011^^ C B8000012^ ^ 2 INTEGER EOF,FCBI(96),FCBO(96),FMRDEL,FDEL B8000014^^ 3 INTEGER IDUSER(4),IBUF(5) B8000015^^ 4 INTEGER IDATA(15),INBUF(24),INREC(7502),KEY(50) B8000016^^ 5 INTEGER MSG1(17),MSG2(14),MSG3(8),MSG4(12),MSG5(7) B8000017^^ 6 INTEGER MSG10(19),MSG11(16),MSG12(17) B8000018^^ 7 INTEGER ODATA(15),OUTBUF(24),OUTREC(1502) B8000019^^ 8 INTEGER RECLEN,ZERO B8000020^^ 9 INTEGER INAMES(120),ONAMES(120),ASTRSK,BLANK(12) B8000021^^ C B8000022^^ 10 DATA INAMES/ B8000023^^ 10 1'DMACCAGE$$ DMACTVTB$$ DMCOSIGN$$ ', B8000024^^ 10 2'DMDECTBL$$ DMDLQMST$$ DMLTRDSC$$ ', B8000025^^ 10 3'DMLTRFIL$$ DMNEWS $$ DMRPTTBL$$ ', B8000026^^ 10 4'DMSCNDSC$$ DMSCNFIL$$ DMSUMHIS$$ ', B8000027^^ 10 5'DMTAPARC$$ DMUTIFIL$$ ** '/ B8000028^^ 11 DATA ONAMES/ B8000029^^ 11 1'ACCAGE CCS20 ACTVERTBCCS20 COSIGNERCCS20 ', B8000030^^ 11 2'DECTBL CCS20 DELQMST CCS20 LTRDESC CCS20 ', B8000031^^ 11 3'LTRFIL CCS20 NEWS CCS20 RPTTBL CCS20 ', B8000032^^ 11 4'SCRNDESCCCS20 SCRNFILECCS20 SUMHIST CCS20 ', B8000033^^ 11 5'TAPEARC CCS20 UTIFIL CCS20 ** '/ B8000034^^ C B8000035^^ 12 DATA BLANK/12*$2020/,ASTRSK/'**'/ B8000036^^ 13 DATA EOF/0/,ICNT/0/,ZERO/0/ B8000037^^ 14 DATA INBUF/24*0/,OUTBUF/24*0/ B8000038^ ^ 15 DATA IDATA/12*$2020,0,5,0/ B8000040^^ 16 DATA ODATA/12*$2020,0,1,-1/ B8000041^ ^ 17 DATA MSG1/$1800,'INDEX FILE COPY (MAX 3000 BYTES)'/ B8000043^^ 18 DATA MSG2/$0A0D,$0A0D,'FILE NAME TO COPY FROM '/ B8000044^^ 19 DATA MSG3/$0A0D,'VOLUME NAME '/ B8000045^^ 20 DATA MSG4/$0A0D,'FILE NAME TO COPY TO '/ B8000046^^ 21 DATA MSG5/$0A0D,'OWNER NAME '/ B8000047^^ 22 DATA MSG10/$0A0D,$0A0D,'XXXXXXXX FILE COULD NOT BE LOCATED'/ B8000048^^ 23 DATA MSG11/$0A0D,$0A0D,'XXXXXXXX FILE NOT INDEX FILE'/ B8000049^^ 24 DATA MSG12/$0A0D,$0A0D,'FILE DESCRIPTION NOT THE SAME '/ B8000050^ ^ 25 EXTERNAL FMRDEL B8000052^ ^ 26 CALL PGMIN(IDUSER,LUNIT,MODE,NOPORT) B8000054^t FTN 3.3B (OPT = LPC) MOVDAT PAGE 2 DATE: 08/29/84 TIME: 2227 t^ 27 ASSEM $C000,FMRDEL,$6800,FDEL B8000055^ ^ C B8000057^^ 28 K = 1 B8000058^^ 29 GO TO 100 B8000059^^ 30 90 K = K + 16 B8000060^^ 31 100 CALL CCSCST(INAMES,K,2,ASTRSK,1,2,ICMP) B8000061^^ 32 IF(ICMP.EQ.0) GO TO 990 B8000062^^ C B8000063^^ C B8000064^^ 33 110 CALL CCSMVA(INAMES,K,16,IDATA,1,16) B8000065^^ 34 CALL CCSMVA(BLANK,1,8,IDATA,17,8) B8000066^^ C B8000067^^ 35 CALL CCSMVA(ONAMES,K,16,ODATA,1,16) B8000068^^ 36 CALL CCSMVA(BLANK,1,8,ODATA,17,8) B8000069^^ C B8000070^^ 37 DO 120 M = 1,24 B8000071^^ 38 INBUF(M)= 0 B8000072^^ 39 OUTBUF(M) = 0 B8000073^^ 40 120 CONTINUE B8000074^^ C OPEN INPUT FILE B8000075^^ 41 200 CALL OPENFL(INBUF,IDATA,ISTAT) B8000076^^ 42 IF(AND(ISTAT,$8002).EQ.$8002) GO TO 320 B8000077^^ 43 IF(ISTAT.GE.0) GO TO 205 B8000078^^ 44 CALL FILERR(IDATA,3,ISTAT,LUNIT) B8000079^^ 45 GO TO 990 B8000080^ ^ C CLEAR THE OUTPUT FILE B8000082^^ 46 205 CALL CLEAR(OUTBUF,ODATA,ISTAT) B8000083^^ 47 IF(ISTAT.GE.0) GO TO 210 B8000084^^ 48 CALL FILERR(ODATA,1,ISTAT,LUNIT) B8000085^^ 49 GO TO 990 B8000086^ ^ C OPEN OUTPUT FILE B8000088^^ 50 210 CALL OPENFL(OUTBUF,ODATA,ISTAT) B8000089^^ 51 IF(AND(ISTAT,$8002).EQ.$8002) GO TO 340 B8000090^^ 52 IF(ISTAT.GE.0) GO TO 220 B8000091^^ 53 CALL FILERR(ODATA,3,ISTAT,LUNIT) B8000092^^ 54 GO TO 990 B8000093^ ^ C CHECK SEE IF FILES ARE INDEX FILES B8000095^^ 55 220 CALL GETFCB(INBUF,ZERO,0,FCBI,ISTAT) B8000096^^ 56 IF(ISTAT.GE.0) GO TO 230 B8000097^^ 57 CALL FILERR(IDATA,7,ISTAT,LUNIT) B8000098^^ 58 GO TO 950 B8000099^^ 59 230 CALL GETFCB(OUTBUF,ZERO,0,FCBO,ISTAT) B8000100^^ 60 IF(ISTAT.GE.0) GO TO 235 B8000101^^ 61 CALL FILERR(ODATA,7,ISTAT,LUNIT) B8000102^^ 62 GO TO 950 B8000103^ ^ C CHECK FCB'S FOR EQUIVLENCE B8000105^^ 63 235 IF(FCBI(1).NE.FCBO(1)) GO TO 400 B8000106^^ 64 IF(FCBI(6).NE.FCBO(6)) GO TO 400 B8000107^^ 65 DO 236 II=15,22 B8000108^t FTN 3.3B (OPT = LPC) MOVDAT PAGE 3 DATE: 08/29/84 TIME: 2227 t^ 66 IF(FCBI(II).NE.FCBO(II)) GO TO 400 B8000109^^ 67 236 CONTINUE B8000110^ ^ 68 RECLEN=FCBI(1)*2 B8000112^ ^ C READ THE INPUT FILE B8000114^^ 69 240 CALL CCSBLK(INREC,15000) B8000115^^ 70 CALL GETS(INBUF,INREC,INREC,ISTAT) B8000116^^ 71 IF(AND(ISTAT,$8100).EQ.$8100) GO TO 950 B8000117^^ 72 IF(AND(ISTAT,$100).EQ.$100) GO TO 250 B8000118^^ 73 IF(ISTAT.GE.0) GO TO 260 B8000119^^ 74 CALL FILERR(IDATA,13,ISTAT,LUNIT) B8000120^^ 75 GO TO 950 B8000121^^ 76 250 EOF=1 B8000122^ ^ C WRITE THE RECORD TO THE OUTPUT FILE B8000124^^ 75 GO TO 950 B8000121^^ 76 250 EOF=1 B8000122^ ^ C WRITE THE RECORD TO THE OUTPUT FILE B8000124^^ 77 260 NREC=INBUF(15) B8000125^^ 78 265 DO 300 I=1,NREC B8000126^^ 79 JW= FCBI(1) * (I-1) + 1 B8000127^^ 80 JB=(FCBI(1) * 2) * (I-1) B8000128^^ 81 IF(INREC(JW).EQ.FDEL) GO TO 300 B8000129^^ C B8000130^^ C CHECK IF ITS SEQUENTIAL B8000131^^ 82 IF(AND(FCBI(6),$0001).NE.$0001) GO TO 285 B8000132^ ^ C SET UP THE KEY B8000134^^ 83 270 CALL CCSBLK(KEY,100) B8000135^^ 84 CALL CCSMVA(INREC,FCBI(16)+JB,FCBI(15),KEY,1,FCBI(15)) B8000136^ ^ C SET UP OUTPUT RECORD B8000138^^ 85 280 CALL CCSMVA(INREC,JB+1,RECLEN,OUTREC,1,RECLEN) B8000139^^ 86 CALL WRITER(OUTBUF,OUTREC,KEY,ISTAT) B8000140^^ 87 IF(ISTAT.GE.0) GO TO 290 B8000141^^ 88 CALL FILERR(ODATA,12,ISTAT,LUNIT) B8000142^^ 89 GO TO 950 B8000143^^ C SEQUENTIAL PUTS B8000144^^ 90 285 CALL CCSMVA(INREC,JB+1,RECLEN,OUTREC,1,RECLEN) B8000145^^ 91 CALL PUTS(OUTBUF,OUTREC,1,ISTAT) B8000146^^ 92 IF(ISTAT.GE.0) GO TO 290 B8000147^^ 93 CALL FILERR(ODATA,11,ISTAT,LUNIT) B8000148^^ 94 GO TO 990 B8000149^ ^ C RECORD COUNT B8000151^^ 95 290 ICNT=ICNT+1 B8000152^^ 96 300 CONTINUE B8000153^ ^ 97 IF(EOF.EQ.1) GO TO 950 B8000155^^ 98 GO TO 240 B8000156^ ^ C ERROR MESSAGES B8000158^^ 99 320 CALL CCSMVA(IDATA,1,8,MSG10,5,8) B8000159^^ 100 CALL WTREAD(LUNIT,-1,MSG10,38,-1,IBUF,0,ITC) B8000160^^ 101 GO TO 950 B8000161^^ 102 340 CALL CCSMVA(ODATA,1,8,MSG10,5,8) B8000162^t FTN 3.3B (OPT = LPC) MOVDAT PAGE 4 DATE: 08/29/84 TIME: 2227 t^ 103 CALL WTREAD(LUNIT,-1,MSG10,38,-1,IBUF,0,ITC) B8000163^^ 104 GO TO 950 B8000164^^ 105 360 CALL CCSMVA(IDATA,1,8,MSG11,5,8) B8000165^^ 106 CALL WTREAD(LUNIT,-1,MSG11,32,-1,IBUF,0,ITC) B8000166^^ 107 GO TO 950 B8000167^^ 108 380 CALL CCSMVA(ODATA,1,8,MSG11,5,8) B8000168^^ 109 CALL WTREAD(LUNIT,-1,MSG11,32,-1,IBUF,0,ITC) B8000169^^ 110 GO TO 950 B8000170^^ 111 400 CALL WTREAD(LUNIT,-1,MSG12,34,-1,IBUF,0,ITC) B8000171^^ 112 GO TO 950 B8000172^ ^ C CLOSE THE FILES B8000174^^ 113 950 CALL CLOSFL(INBUF,ISTAT) B8000175^^ 114 CALL CLOSFL(OUTBUF,ISTAT) B8000176^^ 115 EOF = 0 B8000177^^ 116 GO TO 90 B8000178^^ 117 990 CALL PGMOUT B8000179^^ 118 STOP B8000180^^ 119 END B8000181^t FTN 3.3B (OPT = LPC) MOVDAT PAGE 5 DATE: 08/29/84 TIME: 2227 t  PROGRAM LENGTH $27CA ( 10186)   EXTERNALS 2 Q8STP FMRDEL PGMIN CCSCST CCSMVA OPENFL FILERR 22 CLEAR GETFCB CCSBLK GETS WRITER PUTS WTREAD 2 CLOSFL PGMOUT  t FTN 3.3B (OPT = LPC) MOVDAT PAGE 6 DATE: 08/29/84 TIME: 2227 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < ( 8002 (-32765) 25F4 42,42,51 ($ 8100 (-32511) 25F9 71,71$6 FFFE (-1) 2604 100,100,103,106,109,1116j 0000 (0) 0003 13,14,15,16,32,38,39,43,47,52,55,56,59,60,73,87,92,100,103,106,109,111,115 j€ 0001 (1) 0002 16,28,31,33,34,35,36,37,48,63,68,76,78,79,80,82,84,85,90,91,95,97,99,100,102,103,105,106,108,109,€" 111"* 0002 (2) 25EE 31,31,68,80*$ 0003 (3) 25F5 44,53$. 0005 (5) 2603 99,102,105,108 .$ 0007 (7) 25F6 57,61$6 0008 (8) 25F0 34,34,36,99,102,105,1086" 000B (11) 2602 93 "" 000C (12) 2601 88 "" 000D (13) 25FB 74 "* 0010 (16) 25ED 30,33,35,84*$ 0011 (17) 25F1 34,36$& 0020 (32) 2607 106,109&" 0022 (34) 2608 111"& 0026 (38) 2605 100,103&" 0064 (100) 2600 83 "$ 0100 (256) 25FA 72,72$" 3A98 (15000) 25F8 69 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < . AND INTR.FN. 7FFF 42,51,71,72,82 .& ASTRSK INTEGER 25DB 1,12,31&* BLANK INTEGER 25DC 1,12,34,36 *. EOF INTEGER 0004 1,13,76,97,115 .< FCBI INTEGER 0005 1,55,63,64,66,68,79,80,82,84 <, FCBO INTEGER 0065 1,59,63,64,66,& FDEL INTEGER 00C5 1,27,81&( I INTEGER 25FD 77,79,80 (4 IBUF INTEGER 00CA 1,100,103,106,109,1114$ ICMP INTEGER 25EF 31,32$$ ICNT INTEGER 25E8 13,95$< IDATA INTEGER 00CF 1,15,33,34,41,44,57,74,99,105<$ IDUSER INTEGER 00C6 1,26 $$ II INTEGER 25F7 64,66$* INAMES INTEGER 24EB 1,10,31,33 *6 INBUF INTEGER 00DE 1,14,38,41,55,70,77,11362 INREC INTEGER 00F6 1,69,70,81,84,85,902t FTN 3.3B (OPT = LPC) MOVDAT PAGE 7 DATE: 08/29/84 TIME: 2227 tz ISTAT INTEGER 25F3 41,42,43,44,46,47,48,50,51,52,53,55,56,57,59,60,61,70,71,72,73,74,86,87,88,91,92,93,113,114z2 ITC INTEGER 2606 100,103,106,109,1112. JB INTEGER 25FF 79,80,84,85,90 .( JW INTEGER 25FE 78,79,81 (0 K INTEGER 25EC 27,28,30,31,33,350* KEY INTEGER 1E44 1,83,84,86 *N LUNIT INTEGER 25E9 26,44,48,53,57,61,74,88,93,100,103,106,109,111 N( M INTEGER 25F2 36,38,39 (" MODE INTEGER 25EA 26 "$ MSG1 INTEGER 1E76 1,17 $2 MSG10 INTEGER 1EB0 1,22,99,100,102,10324 MSG11 INTEGER 1EC3 1,23,105,106,108,109 4( MSG12 INTEGER 1ED3 1,24,111 ($ MSG2 INTEGER 1E87 1,18 $$ MSG3 INTEGER 1E95 1,19 $$ MSG4 INTEGER 1E9D 1,20 $$ MSG5 INTEGER 1EA9 1,21 $" NOPORT INTEGER 25EB 26 "( NREC INTEGER 25FC 77,77,78 (F ODATA INTEGER 1EE4 1,16,35,36,46,48,50,53,61,88,93,102,108F& ONAMES INTEGER 2563 1,11,35&: OUTBUF INTEGER 1EF3 1,14,39,46,50,59,86,91,114 :, OUTREC INTEGER 1F0B 1,85,86,90,91,* RECLEN INTEGER 24E9 1,68,85,90 ** ZERO INTEGER 24EA 1,13,55,59 *   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < $ CCSBLK SUBROUTINE 26D3 68,83$" CCSCST SUBROUTINE 261A 31 "B CCSMVA SUBROUTINE 27A0 32,34,35,36,84,85,90,99,102,105,108B" CLEAR SUBROUTINE 2668 46 "& CLOSFL SUBROUTINE 27BC 113,114&6 FILERR SUBROUTINE 26EC 43,48,53,57,61,74,88,936$ GETFCB SUBROUTINE 268D 55,59$" GETS SUBROUTINE 26D7 69 "$ OPENFL SUBROUTINE 2652 40,50$" PGMIN SUBROUTINE 260A 25 "" PGMOUT SUBROUTINE 27C7 117"" PUTS SUBROUTINE 2752 90 " Q8STP INTEGER.FN. 27C9 " WRITER SUBROUTINE 2736 85 "2 WTREAD SUBROUTINE 2773 99,103,106,109,111 2t FTN 3.3B (OPT = LPC) MOVDAT PAGE 8 DATE: 08/29/84 TIME: 2227 t   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < & 90 2616 28,116 &$ 100 2619 28,31$" 110 2627 32 "$ 120 264C 36,40$" 200 2651 40 "$ 205 2667 43,46$$ 210 2676 47,50$$ 220 268C 52,55$$ 230 269D 56,59$$ 235 26AD 60,63$$ 236 26C9 64,67$$ 240 26D2 68,98$$ 250 26F3 72,76$$ 260 26F5 73,77$" 265 26F9 77 "" 270 271C 82 "" 280 272B 84 "$ 285 2747 82,90$( 290 2760 87,92,95 (( 300 2762 77,81,96 ($ 320 276B 42,99$& 340 277D 51,102 &" 360 278E 104"" 380 279F 107", 400 27B1 63,64,66,111 ,H 950 27BB 57,62,71,75,89,97,101,104,107,110,112,113H2 990 27C6 32,45,49,54,94,117 2 MOVDAT 0000 1 t FTN 3.3B (OPT = LPC) NEWS PAGE 1 DATE: 08/29/84 TIME: 2228 t^ 1 PROGRAM NEWS B8100001^^ 1 1 /B81 F CCS CCS 3.0 SL-149B8100002^^ C B8100003^^ C CYBERCREDIT SYSTEM VERSION 3 B8100004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B8100005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B8100006^^ C B8100007^ ^ C THIS PROGRAM DISPLAYS NEWS ITEMS ENTERED IN AN EDITOR FILE NEWS B8100009^^ C NO THE USERS TERMINAL. B8100010^ ^ C . *NEWS BEGINS A NEW NEWS ITEM. B8100012^^ C . 19 LINES OF TEXT ARE ALLOWED PER SCREEN B8100013^^ C . AT THE END OF EACH ITEM READY > IS DISPLAYED AND THE OPERATOR B8100014^^ C RESPONDS WITH A CARRIAGE RETURN. B8100015^^ C . A PERIOD IN THE FIRST COLUMN CAUSES THE READY > TO DISPLAY AND B8100016^^ C THE TEXT FOLLOWING THE PERIOD IS DISPLAYED ON A NEW SCREEN B8100017^ ^ 2 INTEGER ANS,BEG(3),CCS20(3),COLECT(4),CLS B8100019^^ 3 INTEGER DATE(3),DSPLY(37),EOF,EEOF,EXIT(4) B8100020^^ 4 INTEGER FDEL,IBUF(3),IDUSER(4),LA,LEGAL(4) B8100021^^ 5 INTEGER MSG1(37),MSG2(37),MSG3(8),MSG4(3) B8100022^^ 6 INTEGER NDATA(15),NEWSRQ(24),NEWSRC(802) B8100023^^ 7 INTEGER PERIOD,RECCT,SCRNCT,READY B8100024^ ^ 8 DATA BEG/'*NEWS '/,CCS20/'CCS20 '/,CLS/$1820/ B8100026^^ 9 DATA COLECT/'COLECT '/,EOF/0/,EXIT/'EX '/ B8100027^^ 10 DATA IBUF/3*$0000/,LA/'LA'/,LEGAL/'LEGAL '/ B8100028^^ 11 DATA MSG1/37*$2A2A/ B8100029^^ 12 DATA MSG2/12*$2A2A,' N E W S XX/XX/XX ',12*$2A2A/ B8100030^^ 13 DATA MSG3/'ANSWER 1,2,3(CR)'/ B8100031^^ 14 DATA MSG4/'READY '/ B8100032^^ 15 DATA NDATA/'NEWS ',$8*$2020,0,20,0/ B8100033^^ 16 DATA NEWSRQ/24*$0000/ B8100034^^ 17 DATA RECCT/0/,PERIOD/$2E00/,SCRNCT/0/ B8100035^ ^ 18 EXTERNAL AMONTO,ADAYTO,AYERTO,FMEOFC,FMRDEL B8100037^t FTN 3.3B (OPT = LPC) NEWS PAGE 2 DATE: 08/29/84 TIME: 2228 t^ 19 100 CALL PGMIN(IDUSER,LUNIT,MODE,NOPORT) B8100039^^ C BRING IN DATE, EOF CODE, DELETE CODE B8100040^^ 20 DATE(1)=AND(AMONTO,$FFFF) B8100041^^ 21 DATE(2)=AND(ADAYTO,$FFFF) B8100042^^ 22 DATE(3)=AND(AYERTO,$FFFF) B8100043^^ 23 ASSEM $C000,+FMEOFC,$6800,EEOF B8100044^^ 24 ASSEM $C000,FMRDEL,$6800,FDEL B8100045^ ^ C CHECK WHICH USER ID IS USED B8100047^^ 25 110 IF(IDUSER(1).NE.LA) GO TO 200 B8100048^ ^ C USERID IS LA, DISPLAY NEWS MENU B8100050^^ 26 120 WRITE(LUNIT,121)CLS B8100051^^ 27 121 FORMAT(A2,/,'CHOOSE ONE OF THE FOLLOWING OPTIONS:',//,2X, B8100052^^ 27 1'1) NEWS ONLY',/,2X,'2) DISPLAY NEWS THEN GO INTO LEGAL',/, B8100053^^ 27 12X,'3) SKIP NEWS GO INTO LEGAL',//) B8100054^ ^ C GET ANSWER B8100056^^ 28 130 IBUF(1)=0 B8100057^^ 29 CALL WTREAD(LUNIT,-1,MSG3,16,-1,IBUF,1,ITC) B8100058^^ 30 ANS=(IBUF(1)/$100)-$30 B8100059^^ 31 IF(ANS.LE.0.OR.ANS.GE.4) GO TO 120 B8100060^ ^ C CHECK IF SKIP NEWS B8100062^^ 32 IF(ANS.EQ.3) GO TO 550 B8100063^ ^ C OPEN THE LA NEWS FILE B8100065^^ 33 140 CALL CCSMVA(LA,1,2,NDATA,9,2) B8100066^^ 34 CALL OPENFL(NEWSRQ,NDATA,ISTAT) B8100067^^ 35 IF(ISTAT.GE.0) GO TO 250 B8100068^^ 36 IF(AND(ISTAT,$0002).EQ.$0002) GO TO 150 B8100069^^ 37 CALL FILERR(NDATA,3,ISTAT,LUNIT) B8100070^^ 38 GO TO 990 B8100071^ ^ C OPEN THE CCS20 NEWS FILE B8100073^^ 39 150 CALL CCSMVA(CCS20,1,5,NDATA,9,5) B8100074^^ 40 CALL OPENFL(NEWSRQ,NDATA,ISTAT) B8100075^^ 41 IF(ISTAT.GE.0) GO TO 250 B8100076^^ 42 IF(AND(ISTAT,$0002).EQ.$0002) GO TO 500 B8100077^^ 43 CALL FILERR(NDATA,3,ISTAT,LUNIT) B8100078^^ 44 GO TO 990 B8100079^ ^ C USERID IS NOT LA B8100081^^ 45 200 WRITE(LUNIT,201)CLS B8100082^^ 46 201 FORMAT(A2,/,'CHOOSE ONE OF THE FOLLOWING OPTIONS:',//,2X, B8100083^^ 46 1'1) NEWS ONLY',/,2X,'2) DISPLAY NEWS THEN GO INTO COLECT',/, B8100084^^ 46 12X,'3) SKIP NEWS GO INTO COLECT',//) B8100085^ ^ C GET ANSWER B8100087^^ 47 210 IBUF(1)=0 B8100088^^ 48 CALL WTREAD(LUNIT,-1,MSG3,16,-1,IBUF,1,ITC) B8100089^^ 49 ANS=(IBUF(1)/$100)-$30 B8100090^^ 50 IF(ANS.LE.0.OR.ANS.GE.4) GO TO 200 B8100091^ t FTN 3.3B (OPT = LPC) NEWS PAGE 3 DATE: 08/29/84 TIME: 2228 t^ C CHECK FOR SKIP OF NEWS B8100093^^ 51 IF(ANS.EQ.3) GO TO 550 B8100094^ ^ C OPEN THE CCS20 NEWS FILE B8100096^^ 52 220 CALL CCSMVA(CCS20,1,5,NDATA,9,5) B8100097^^ 53 CALL OPENFL(NEWSRQ,NDATA,ISTAT) B8100098^^ 54 IF(ISTAT.GE.0) GO TO 250 B8100099^^ 55 IF(AND(ISTAT,$0002).EQ.$0002) GO TO 500 B8100100^^ 56 CALL FILERR(NDATA,3,ISTAT,LUNIT) B8100101^^ 57 GO TO 990 B8100102^t FTN 3.3B (OPT = LPC) NEWS PAGE 4 DATE: 08/29/84 TIME: 2228 t^ C READ 20 RECORDS B8100104^^ 58 250 CALL CCSBLK(NEWSRC,1600) B8100105^^ 59 CALL GETS(NEWSRQ,NEWSRC,NEWSRC,ISTAT) B8100106^ ^ C CHECK FOR END OF FILE IN FIRST RECORD B8100108^^ 60 IF(NEWSRC(1).EQ.EEOF.AND.RECCT.EQ.0) GO TO 500 B8100109^ ^ C CHECK FOR END OF FILE STATUS B8100111^^ 61 IF(AND(ISTAT,$8100).EQ.$8100) GO TO 500 B8100112^^ 62 IF(AND(ISTAT,$100).EQ.$100) GO TO 260 B8100113^^ 63 IF(ISTAT.GE.0) GO TO 300 B8100114^^ 64 CALL FILERR(NDATA,14,ISTAT,LUNIT) B8100115^^ 65 GO TO 500 B8100116^ ^ C SET END OF FILE SWITCH B8100118^^ 66 260 EOF=1 B8100119^^ 67 300 NREC=NEWSRQ(15) B8100120^ ^ C PROCESS THE RECORDS B8100122^^ 68 DO 400 I=1,NREC B8100123^^ 69 JW=(I-1)*40 B8100124^^ 70 JB=(I-1)*80 B8100125^ ^ C CHECK FOR END OF FILE B8100127^^ 71 IF(NEWSRC(JW+1).EQ.EEOF) GO TO 500 B8100128^ ^ C CHECK FOR A DELETED RECORD B8100130^^ 72 320 IF(NEWSRC(JW+1).EQ.FDEL) GO TO 400 B8100131^ ^ C CHECK FOR BEGINNING OF NEWS ITEM B8100133^^ 73 330 CALL CCSCST(NEWSRC,JB+1,5,BEG,1,5,ICOMP) B8100134^^ 74 IF(ICOMP.NE.0) GO TO 360 B8100135^ ^ C NEW ITEM DISPLAY READY B8100137^^ 75 340 ASSIGN 450 TO READY B8100138^^ 76 ASSIGN 345 TO IRTN B8100139^^ 77 GO TO READY B8100140^ ^ C WRITE HEADER B8100142^^ 78 345 WRITE(LUNIT,341)(MSG1(K),K=1,37) B8100143^^ 79 341 FORMAT(1H ,37A2) B8100144^^ 80 CALL EDIT(DATE,1,MSG2,39,1) B8100145^^ 81 WRITE(LUNIT,341)(MSG2(K),K=1,37) B8100146^^ 82 WRITE(LUNIT,341)(MSG1(K),K=1,37) B8100147^^ 83 GO TO 400 B8100148^ ^ C SEE IF RECORD IS A PERIOD B8100150^^ 84 360 CALL CCSCST(NEWSRC,JB+1,1,PERIOD,1,1,ICOMP) B8100151^^ 85 IF(ICOMP.NE.0) GO TO 380 B8100152^ ^ C DISPLAY READY B8100154^^ 86 ASSIGN 450 TO READY B8100155^^ 87 ASSIGN 400 TO IRTN B8100156^^ 88 GO TO READY B8100157^t FTN 3.3B (OPT = LPC) NEWS PAGE 5 DATE: 08/29/84 TIME: 2228 t ^ C DISPLAY NEW LINE B8100159^^ 89 380 CALL CCSMVA(NEWSRC,JB+1,74,DSPLY,1,74) B8100160^^ 90 WRITE(LUNIT,381)(DSPLY(K),K=1,37) B8100161^^ 91 381 FORMAT(1H ,37A2) B8100162^^ 92 SCRNCT=SCRNCT+1 B8100163^^ 93 RECCT=RECCT+1 B8100164^^ C SEE IF SCREEN OVERFLOW B8100165^^ 94 IF(SCRNCT.NE.19) GO TO 400 B8100166^ ^ C SCREEN OVERFLOWED DISPLAY READY B8100168^^ 95 ASSIGN 450 TO READY B8100169^^ 96 ASSIGN 400 TO IRTN B8100170^^ 97 GO TO READY B8100171^ ^ 98 400 CONTINUE B8100173^ ^ C CHECK IF THERE ARE MORE RECORDS B8100175^^ 99 IF(EOF.EQ.1) GO TO 500 B8100176^^ 100 GO TO 250 B8100177^t FTN 3.3B (OPT = LPC) NEWS PAGE 6 DATE: 08/29/84 TIME: 2228 t^ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC B8100179^^ 101 450 CONTINUE B8100180^ ^ C DISPLAY READY AT THE BOTTOM. B8100182^^ C WAIT FOR CARRIAGE RETURN OUTPUT CLS B8100183^^ 102 460 IF(RECCT.EQ.0) GO TO 480 B8100184^ ^ C DISPLAY READY B8100186^^ 103 470 IBUF(1)=$2020 B8100187^^ 104 CALL WTREAD(LUNIT,$0017,MSG4,6,-1,IBUF,1,ITC) B8100188^^ 105 IF(ITC.NE.2) GO TO 470 B8100189^ ^ C CLEAR THE SCREEN B8100191^^ 106 480 WRITE(LUNIT,481)CLS B8100192^^ 107 481 FORMAT(A2) B8100193^^ 108 490 SCRNCT=0 B8100194^^ 109 495 GO TO IRTN B8100195^^ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC B8100196^t FTN 3.3B (OPT = LPC) NEWS PAGE 7 DATE: 08/29/84 TIME: 2228 t^ C CLOSE THE NEWS FILE B8100198^^ 110 500 ASSIGN 450 TO READY B8100199^^ 111 ASSIGN 510 TO IRTN B8100200^^ 112 GO TO READY B8100201^^ 113 510 CALL CLOSFL(NEWSRQ,ISTAT) B8100202^^ 114 IF(RECCT.NE.0) GO TO 530 B8100203^ ^ C DISPLAY NO NEWS TODAY, FOR NEWS ONLY B8100205^^ 115 520 WRITE(LUNIT,521)CLS B8100206^^ 116 521 FORMAT(A2,///,20X,'***** NO NEWS TODAY *****') B8100207^^ 117 RECCT=1 B8100208^^ 118 ASSIGN 450 TO READY B8100209^^ 119 ASSIGN 530 TO IRTN B8100210^^ 120 GO TO READY B8100211^ ^ C SEE IF NEWS ONLY B8100213^^ 121 530 IF(ANS.NE.1) GO TO 550 B8100214^ ^ C NEWS ONLY EXIT OUT B8100216^^ 122 540 CALL CHAIN(EXIT) B8100217^ ^ C CHECK FOR WHICH ONLINE TO CHAIN TO B8100219^^ 123 550 IF(IDUSER(1).NE.LA) GO TO 570 B8100220^ ^ C CHAIN TO LEGAL B8100222^^ 124 560 CALL CHAIN(LEGAL) B8100223^ ^ C CHAIN TO COLECT B8100225^^ 125 570 CALL CHAIN(COLECT) B8100226^ ^ 126 990 CALL PGMOUT B8100228^^ 127 END B8100229^t FTN 3.3B (OPT = LPC) NEWS PAGE 8 DATE: 08/29/84 TIME: 2228 t  PROGRAM LENGTH $0703 ( 1795)   EXTERNALS 2 Q8STP Q8QINI Q8QX Q8QEND AMONTO ADAYTO AYERTO 22 FMEOFC FMRDEL PGMIN WTREAD CCSMVA OPENFL FILERR 22 CCSBLK GETS CCSCST EDIT CLOSFL CHAIN PGMOUT 2 t FTN 3.3B (OPT = LPC) NEWS PAGE 9 DATE: 08/29/84 TIME: 2228 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < $ 8100 (-32511) 03FA 61,61$, FFFE (-1) 03F0 29,29,48,104 ,( FFFF (65535) 03EF 20,21,22 (‚ 0001 (1) 0002 20,25,28,29,30,33,39,47,48,49,52,60,66,68,69,70,71,72,73,78,80,81,82,84,89,90,92,93,99,103,104,117 ‚( ,121,123 (2 0002 (2) 03F5 33,33,36,42,55,105 2. 0003 (3) 03F4 32,37,43,51,56 .* 0005 (5) 03F8 39,39,52,73*" 0006 (6) 0409 104"( 0009 (9) 03F6 33,39,52 (" 000E (14) 03FB 64 "$ 0010 (16) 03F1 29,48$" 0017 (23) 0408 104"" 0027 (39) 0405 80 "" 0028 (40) 03FF 69 "$ 004A (74) 0406 89,89$" 0050 (80) 0401 70 "( 0100 (256) 03F3 30,49,62 (" 0640 (1600) 03F9 58 "" 2020 (8224) 0407 103"   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < 6 AND INTR.FN. 7FFF 20,21,22,36,42,55,61,6266 ANS INTEGER 0003 1,30,31,32,49,50,51,1216& BEG INTEGER 0004 1,8,73 &( CCS20 INTEGER 0007 1,8,39,52(0 CLS INTEGER 000E 1,8,26,45,106,1150& COLECT INTEGER 000A 1,9,125&, DATE INTEGER 000F 1,20,21,22,80,& DSPLY INTEGER 0012 1,89,90&* EEOF INTEGER 0038 1,23,60,71 *( EOF INTEGER 0037 1,9,66,99(& EXIT INTEGER 0039 1,9,122&& FDEL INTEGER 003D 1,24,72&( I INTEGER 03FD 67,69,70 (> IBUF INTEGER 003E 1,10,28,29,30,47,48,49,103,104 >* ICOMP INTEGER 0402 73,74,84,85** IDUSER INTEGER 0041 1,19,25,123*4 IRTN INTEGER 0403 75,87,96,109,111,119 4V ISTAT INTEGER 03F7 34,35,36,37,40,41,42,43,53,54,55,56,59,61,62,63,64,113 V, ITC INTEGER 03F2 29,48,104,105,t FTN 3.3B (OPT = LPC) NEWS PAGE 10 DATE: 08/29/84 TIME: 2228 t. JB INTEGER 0400 69,70,73,84,89 .* JW INTEGER 03FE 68,69,71,72*. K INTEGER 0404 78,78,81,82,90 .. LA INTEGER 0045 1,10,25,33,123 .( LEGAL INTEGER 0046 1,10,124 (R LUNIT INTEGER 03EC 19,26,29,37,43,45,48,56,64,78,81,82,90,104,106,115 R" MODE INTEGER 03ED 19 "* MSG1 INTEGER 004A 1,11,78,82 ** MSG2 INTEGER 006F 1,12,80,81 ** MSG3 INTEGER 0094 1,13,29,48 *( MSG4 INTEGER 009C 1,14,104 (B NDATA INTEGER 009F 1,15,33,34,37,39,40,43,52,53,56,64 B8 NEWSRC INTEGER 00C6 1,58,59,60,71,72,73,84,8986 NEWSRQ INTEGER 00AE 1,16,34,40,53,59,67,1136" NOPORT INTEGER 03EE 19 "( NREC INTEGER 03FC 67,67,68 (& PERIOD INTEGER 03E8 1,17,84&B READY INTEGER 03EB 1,75,77,86,88,95,97,110,112,118,120B6 RECCT INTEGER 03E9 1,17,60,93,102,114,117 6. SCRNCT INTEGER 03EA 1,17,92,94,108 .   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " CCSBLK SUBROUTINE 057A 58 "$ CCSCST SUBROUTINE 05D3 72,84$* CCSMVA SUBROUTINE 0651 32,39,52,89** CHAIN SUBROUTINE 06F3 121,124,125*" CLOSFL SUBROUTINE 06BF 113"" EDIT SUBROUTINE 0609 79 "* FILERR SUBROUTINE 0572 36,43,56,64*" GETS SUBROUTINE 057E 58 "( OPENFL SUBROUTINE 0562 33,40,53 (" PGMIN SUBROUTINE 040B 17 "" PGMOUT SUBROUTINE 0700 126" Q8QEND INTEGER.FN. 06AE Q8QINI INTEGER.FN. 06A5 8 Q8QX SUBROUTINE 06AB 26,45,78,81,82,90,106,1158 Q8STP INTEGER.FN. 0702 ( WTREAD SUBROUTINE 0696 28,48,104(t FTN 3.3B (OPT = LPC) NEWS PAGE 11 DATE: 08/29/84 TIME: 2228 t   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < " 100 040A 17 "" 110 0427 24 "$ 120 042F 25,31$$ 121 043B 26,27$" 130 0486 27 "" 140 04A5 32 "$ 150 04C5 36,39$( 200 04E2 25,45,50 ($ 201 04EE 45,46$" 210 053A 46 "" 220 0559 51 ". 250 0579 35,41,54,58,100.$ 260 05A5 62,66$$ 300 05A8 63,67$" 320 05C7 71 "" 330 05CF 72 "" 340 05E0 74 "* 341 0603 78,79,81,82*$ 345 05EB 75,78$$ 360 0636 74,84$$ 380 064D 85,89$$ 381 066C 90,91$4 400 0682 67,72,83,87,94,96,98 44 450 068D 74,86,95,101,110,118 4" 460 068D 101"& 470 0691 102,105&& 480 06A4 102,106&& 481 06B0 106,107&" 490 06B2 107"" 495 06B4 108"8 500 06B6 42,55,60,61,65,71,99,110 8& 510 06BE 110,113&" 520 06C6 114"& 521 06CF 115,116&* 530 06EE 114,119,121*" 540 06F2 121", 550 06F5 32,51,121,123," 560 06FB 123"& 570 06FD 123,125&, 990 06FF 37,44,57,126 , NEWS 0000 1  t FTN 3.3B (OPT = LPC) NMCHNG PAGE 1 DATE: 08/29/84 TIME: 2229 t^ 1 PROGRAM NMCHNG B8200001^^ 1 1 /B82 F CCS CCS 3.0 .LA PSR(05/83) SL-149********^^ C B8200003^^ C CYBERCREDIT SYSTEM VERSION 3 B8200004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B8200005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B8200006^^ C B8200007^ ^ C THIS PROGRAM TAKES ALL ACCOUNTS THAT HAVE A NAME CHANGE B8200009^^ C FROM EITHER THE UPDATE PROGRAM OR FROM COLECT, DETERMINED B8200010^^ C BY A RECORD IN THE ADDACT ACCOUNT FILE WITH A 'N' IN COLUMN B8200011^^ C 17, AND EXECUTES A DELREC REQUEST ON THE ORIGINAL RECORD B8200012^^ C FOLLOWED BY A WRITER REQUEST WITH THE NEW RECORD. B8200013^ ^ 2 INTEGER DEQREC(1000),DEQTMP(1002),DEQREQ(24),DDATA(15), B8200015^^ 2 2 ADATA(15),ADDREQ(24),ADDREC(10),STAT,N,HD(20,3), B8200016^^ 2 3 DT(3),USER(4),ACTSVE(8) B8200017^ ^ 3 INTEGER DDAT(4) ********^^ 4 DATA DDAT /'DELQMST '/ ********^^ 5 DATA DDATA/'LADLQMST', 8*$2020, 1, 1, 1 / ********^^ 6 DATA ADATA/'LAADDACT', 8*$2020, 0, 1, 0 / ********^^ 7 DATA DEQREQ, ADDREQ / 48*0 / B8200021^^ 8 INTEGER KYERR(29) ********^^ 9 DATA KYERR/$D0A,'NAME CHANGE KEY-INDEX ERROR *** ' ********^^ 9 1, 'PROGRAM CONTINUING..',$2E07/ ********^  ^ C ACCEPT ITOS LOG IN B8200023^^ 10 CALL PGMIN ( USER, LU, MODE, NPORT ) B8200024^^ 11 CALL CCSCST(ADATA,1,2,USER,1,8,ICM) ********^^ 12 IF(ICM.EQ.0) GO TO 5 ********^^ 13 CALL CCSMVA(DDAT,1,8,DDATA,1,8) ********^^ 14 CALL CCSMVA(ADATA,3,6,ADATA,1,8) ********^^ 15 5 CONTINUE ********^  ^ C OPEN THE FILES FOR USE B8200026^^ 16 CALL OPENFL ( ADDREQ, ADATA, ISTAT ) B8200027^^ 17 IF ( ISTAT .GE. 0 ) GO TO 100 B8200028^^ C REPORT THE ERROR AND EXIT B8200029^^ 18 CALL FILERR ( ADATA, 3, ISTAT, LU ) B8200030^^ 19 GO TO 300 B8200031^ ^ 20 100 CALL OPENFL ( DEQREQ, DDATA, ISTAT ) B8200033^^ 21 IF ( ISTAT .GE. 0 ) GO TO 200 B8200034^^ C REPORT THE ERROR AND EXIT B8200035^^ 22 CALL FILERR ( DDATA, 3, ISTAT, LU ) B8200036^^ 23 GO TO 300 B8200037^t FTN 3.3B (OPT = LPC) NMCHNG PAGE 2 DATE: 08/29/84 TIME: 2229 t^ C GET THE NEXT RECORD FROM THE ADDACT FILE B8200039^^ 24 200 CALL GETS ( ADDREQ, ADDREC, I, ISTAT ) B8200040^^ C EOF ? B8200041^^ 25 IF ( AND(ISTAT,$100) .EQ. $100 ) GO TO 300 B8200042^^ C FILE ERROR ? B8200043^^ 26 IF ( ISTAT .GE. 0 ) GO TO 210 B8200044^^ C REPORT AND EXIT B8200045^^ 27 CALL FILERR ( ADATA, 14, ISTAT, LU ) B8200046^^ 28 GO TO 300 B8200047^ ^ C IS THIS A NAME CHANGE ? B8200049^^ 29 210 CALL CCSGET ( ADDREC, 17, STAT ) B8200050^^ 30 IF ( STAT .NE. $4E ) GO TO 200 B8200051^ ^ C**************************************************** PSR(05/83) ********^^ C UPDATE ADDACT RECORD . SO WE DONT CHANGE NAME TWICE ********^ ^ 31 CALL CCSPUT( $5A, 17, ADDREC ) ********^^ 32 CALL UPDREC( ADDREQ, ADDREC, ISTAT ) ********^^ 33 IF (ISTAT.GE.0) GO TO 215 ********^^ 34 CALL FILERR(ADATA,15,ISTAT,LU) ********^^ 35 GOTO 300 ********^ ^ 36 215 CONTINUE ********^^ C THIS IS A NAME CHANGE, GET THE DELQMST RECORD B8200053^^ 37 CALL CCSMVA ( ADDREC, 1, 16, ACTSVE, 1, 16 ) B8200054^^ 38 CALL READR ( DEQREQ, DEQREC, ACTSVE, ISTAT ) B8200055^^ 39 IF ( ISTAT .GE. 0 ) GO TO 220 B8200056^^ C REPORT THE ERROR AND EXIT B8200057^^ 40 CALL FILERR ( DDATA, 13, ISTAT, LU ) B8200058^^ 41 GO TO 300 B8200059^ ^ C VERIFY THIS IS THE CORRECT ACCOUNT, THEN SAVE THE ACCOUNT B8200061^^ 42 220 CALL CCSCST ( DEQREC, 1, 16, ADDREC, 1, 16, ICOMP ) B8200062^^ 43 IF ( ICOMP .NE. 0 ) GO TO 200 B8200063^^ 44 CALL CCSMVA ( DEQREC, 1, 2000, DEQTMP, 1, 2000 ) B8200064^^ C**************************************************** PSR(05/83) ********^^ C CHECK IF OLD KEY AND NEW KEY ARE SAME IF SO THEN ********^^ C BLANK OUT OLD KEY AND UPDATE RECORD. ********^ ^ 45 CALL CCSCST(DEQREC,18,6,DEQREC,1047,6,ICOMP) ********^^ 46 IF(ICOMP.NE.0) GO TO 225 ********^ ^ 47 222 CALL CCSBLK(DEQREC(524),6) ********^^ 48 CALL UPDREC( DEQREQ, DEQREC, ISTAT ) ********^^ 49 IF (ISTAT.GE.0) GO TO 200 ********^^ 50 CALL FILERR(DDATA,15,ISTAT,LU) ********^^ 51 GO TO 200 ********^ ^ 52 225 CONTINUE ********^^ 53 CALL CCSMVA ( DEQREC, 1047,6,DEQREC,18,6 ) B8200065^ ^ C DELETE THE ORIGINAL RECORD B8200067^^ 54 CALL DELREC ( DEQREQ, DEQREC, ISTAT ) B8200068^t FTN 3.3B (OPT = LPC) NMCHNG PAGE 3 DATE: 08/29/84 TIME: 2229 t^ 55 IF ( ISTAT .GE. 0 ) GO TO 230 B8200069^^ 56 IF(ISTAT.EQ.$8800) GO TO 228 ********^^ C REPORT THE ERROR AND EXIT B8200070^^ 57 CALL FILERR ( DDATA, 16, ISTAT, LU ) B8200071^^ 58 GO TO 300 B8200072^ ^ C**************************************************** PSR(05/83) ********^^ C*** KEY INDEX ERROR - REPORT, THEN CONTINUE PROCESSING ********^ ^ 59 228 CONTINUE ********^^ C** CALL WTREAD(LU,-1,KYERR,58,0,0,0,ITC) ********^^ C STORE THE NEW RECORD B8200074^^ 60 230 CALL CCSBLK ( DEQTMP(524), 6 ) B8200075^^ 61 CALL WRITER ( DEQREQ, DEQTMP, ACTSVE, ISTAT ) B8200076^^ 62 IF ( ISTAT .GE. 0 ) GO TO 200 B8200077^^ 63 IF(ISTAT.EQ.$8010) GO TO 222 ********^^ C REPORT THE ERROR AND EXIT B8200078^^ 64 CALL FILERR ( DDATA, 12, ISTAT, LU ) B8200079^  ^ C CLOSE THE FILES AND TERMINATE THE JOB B8200081^^ 65 300 CALL CLOSFL ( DEQREQ, ISTAT ) B8200082^^ 66 CALL CLOSFL ( ADDREQ, ISTAT ) B8200083^^ 67 CALL PGMOUT B8200084^^ 68 END B8200085^t FTN 3.3B (OPT = LPC) NMCHNG PAGE 4 DATE: 08/29/84 TIME: 2229 t  PROGRAM LENGTH $09B1 ( 2481)   EXTERNALS 2 Q8STP PGMIN CCSCST CCSMVA OPENFL FILERR GETS 22 CCSGET CCSPUT UPDREC READR CCSBLK DELREC WRITER 2 CLOSFL PGMOUT  t FTN 3.3B (OPT = LPC) NMCHNG PAGE 5 DATE: 08/29/84 TIME: 2229 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " 8010 (-32751) 08B0 63 "" 8800 (-30719) 08AF 56 "4 0001 (1) 0002 5,6,11,13,14,37,42,444" 0002 (2) 089D 11 "( 0003 (3) 08A0 14,18,22 (. 0006 (6) 08A1 14,45,47,53,60 .( 0008 (8) 089E 11,13,14 (" 000C (12) 08B1 64 "" 000D (13) 08AA 40 "" 000E (14) 08A5 27 "$ 000F (15) 08A8 34,50$* 0010 (16) 08A9 37,37,42,57*$ 0011 (17) 08A6 29,31$$ 0012 (18) 08AD 45,53$" 005A (90) 08A7 30 "$ 0100 (256) 08A4 25,25$$ 0417 (1047) 08AE 45,53$$ 07D0 (2000) 08AC 44,44$   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < * ACTSVE INTEGER 0871 1,37,38,61 *4 ADATA INTEGER 07FC 1,6,11,14,16,18,27,3442 ADDREC INTEGER 0823 1,24,29,31,32,37,422. ADDREQ INTEGER 080B 1,7,16,24,32,66." AND INTR.FN. 7FFF 25 "& DDAT INTEGER 0879 1,4,13 &8 DDATA INTEGER 07ED 1,5,13,20,22,40,50,57,64 88 DEQREC INTEGER 0003 1,38,42,44,45,47,48,53,5484 DEQREQ INTEGER 07D5 1,7,20,38,48,54,61,654* DEQTMP INTEGER 03EB 1,44,60,61 * DT INTEGER 086A 1 HD INTEGER 082E 1 " I INTEGER 08A3 24 "$ ICM INTEGER 089F 11,12$* ICOMP INTEGER 08AB 42,43,45,46*v ISTAT INTEGER 08A2 16,17,18,20,21,22,24,25,26,27,32,33,34,38,39,40,48,49,50,54,55,56,57,61,62,63,64,65,66 v" KYERR INTEGER 087D 7,9": LU INTEGER 089A 10,18,22,27,34,40,50,57,64 :" MODE INTEGER 089B 10 "" NPORT INTEGER 089C 10 "& STAT INTEGER 082D 1,29,30&t FTN 3.3B (OPT = LPC) NMCHNG PAGE 6 DATE: 08/29/84 TIME: 2229 t& USER INTEGER 086D 1,10,11&   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < $ CCSBLK SUBROUTINE 095F 46,60$( CCSCST SUBROUTINE 093D 10,42,45 (" CCSGET SUBROUTINE 0908 29 ". CCSMVA SUBROUTINE 094B 12,14,37,44,53 ." CCSPUT SUBROUTINE 0912 30 "$ CLOSFL SUBROUTINE 09A7 65,66$" DELREC SUBROUTINE 097A 53 "6 FILERR SUBROUTINE 096B 17,22,27,34,40,50,57,646" GETS SUBROUTINE 08F2 24 "$ OPENFL SUBROUTINE 08D4 15,20$ PGMIN SUBROUTINE 08B3 9 " PGMOUT SUBROUTINE 09AE 66 " Q8STP INTEGER.FN. 09B0 " READR SUBROUTINE 092E 37 "$ UPDREC SUBROUTINE 0917 31,48$" WRITER SUBROUTINE 0990 60 "   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 5 08D3 12,15$$ 100 08E3 17,20$4 200 08F1 21,24,30,43,49,51,62 4$ 210 0907 26,29$$ 215 0926 33,36$$ 220 093C 39,42$$ 222 095E 46,63$$ 225 0972 46,52$$ 228 098C 56,59$$ 230 098C 55,60$6 300 09A6 18,23,25,28,35,41,58,656 NMCHNG 0000 1 t FTN 3.3B (OPT = LPC) NUMDT1 PAGE 1 DATE: 08/29/84 TIME: 2229 t^ 1 FUNCTION NUMDT1 (I) B8400001^^ 1 1 /B84 F CCS CCS 3.0 SL-149B8400002^^ C B8400003^^ C CYBERCREDIT SYSTEM VERSION 3 B8400004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B8400005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B8400006^^ C B8400007^^ C ROUTINE CHECKS 1 CHARACTER FOR NUMERIC RETURNING INTEGER 0 - 9 B8400008^^ C IF VALID AND $8001 IF NON-NUMERIC B8400009^^ 2 J = $8001 B8400010^^ 3 IF ( I .GE. $30 .AND. I .LE. $39) J = AND ($000F,I) B8400011^^ 4 NUMDT1 = J B8400012^^ 5 RETURN B8400013^^ 6 END B8400014^t FTN 3.3B (OPT = LPC) NUMDT1 PAGE 2 DATE: 08/29/84 TIME: 2229 t  PROGRAM LENGTH $0020 ( 32)   EXTERNALS  Q8PKUP Q8PREP  t FTN 3.3B (OPT = LPC) NUMDT1 PAGE 3 DATE: 08/29/84 TIME: 2229 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : <  8001 (-32766) 0002 2 000F (15) 0003 3    VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  AND INTR.FN. 7FFF 3 " I INTEGER 7FFF 1,3"& J INTEGER 0001 1,2,3,4&" NUMDT1 INTEGER 0000 1,4"   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  Q8PKUP INTEGER.FN. 001C Q8PREP INTEGER.FN. 0019    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : <  NUMDT1 0016  t FTN 3.3B (OPT = LPC) PGCNT1 PAGE 1 DATE: 08/29/84 TIME: 2229 t^ 1 PROGRAM PGCNT1 B8700001^^ 1 1 /B87 F CCS CCS 3.0 SL-149B8700002^  ^ C CYBERCREDIT SYSTEM VERSION 3 B8700004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B8700005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B8700006^  ^ C THIS PROGRAM CONTROLS THE FLOW OF THE MINI-RPG EXECUTION. B8700008^^ C . REMOVE THE ENTRIES FROM THE $$PGMNAM FILE B8700009^^ C . SET UP LINKAGE FOR SELECTION L ON RP MENU B8700010^^ C . DETERMINES WHEN THE TWO RPG PROGRAMS HAVE BEEN INSTALLED B8700011^^ C . PASS CONTROL CONTROL TO THE OPERATOR B8700012^^ C B8700013^^ C THIS PROGRAM IS CALLED FROM THE PROCEDURE FILE 'PRFRPTCNT' B8700014^^ C AND THEN PASS TO OPERATOR TO EXECUTE REPORT XX B8700015^^ C WHERE XX IS THE JOB IN PROGRESS WHICH IS CONTAINED IN THE B8700016^^ C UTILITY FILE RECORD 'RPTG'. B8700017^  ^ 2 INTEGER RDATA(24),RREQ(24),UDATA(15),HDATA(15),HREQ(24),UREQ(24), B8700019^^ 2 1 UREC(40),HREC(20),PDATA(15),PREQ(24),PREC(40),USER(4),HOST, B8700020^^ 2 2 JOBNO,NREQ(24),KTEMP(4),MENU(4),ASCZER,NNAME(12),NDATA(12) B8700021^^ 3 INTEGER LDATA(15),LREQ(24),LREC(10),LNAME1(3),LNAME2(3),LNAME(3) B8700022^^ 4 INTEGER RRN(2),MDATA(15),MREQ(24),MREC(40) B8700023^  ^ 5 DATA UDATA / 'UTIFIL ',1,1,0 / B8700025^^ 6 DATA MDATA / '$$RGMENU$$', 7*$2020, 0, 1, 1 / B8700026^^ 7 DATA PDATA / 'RPTPGM ',1,1,0 / B8700027^^ 8 DATA HDATA / '$$HOST $$ ',0,1,0 / B8700028^^ 9 DATA RDATA / '$$RPMENU$$', 7*$2020, 0, 1, 1,9*0 / B8700029^ ^ 10 DATA RREQ,UREQ,PREQ,HREQ,NREQ,LREQ,MREQ / 168*0 / B8700031^^ 11 DATA MENU / 'MNUPRO ' / , RRN / 0, 0 / B8700032^^ 12 DATA KTEMP / 'RPTG ' / , ASCZER / '00' / , HOST / 0 / B8700033^^ 13 DATA NDATA / 'PRCWRK ' / B8700034^^ 14 DATA NNAME / 'PRFPG000CCS20 ' , 5*$2020 / B8700035^^ 15 DATA LDATA / '$$PGMNAM$$ ',1,1,1 / B8700036^^ 16 DATA LNAME1 / 'RPTE00' / , LNAME2 / 'RPTP00' /, LNAME /'RPT000'/ B8700037^t FTN 3.3B (OPT = LPC) PGCNT1 PAGE 2 DATE: 08/29/84 TIME: 2229 t^ C ACCEPT THE ITOS LOG IN B8700039^^ 17 CALL PGMIN ( USER, LU, MODE, NPORT ) B8700040^  ^ C OPEN THE UTILITY FILE AND GET THE 'RPTG' RECORD TO B8700042^^ C WHICH NUMBER IS BEING PROCESSED B8700043^^ 18 100 CALL OPENFL ( UREQ, UDATA, ISTAT ) B8700044^^ 19 IF ( ISTAT .GE. 0 ) GO TO 150 B8700045^^ C FILE ERROR, REPORT AND EXIT B8700046^^ 20 CALL FILERR ( UDATA, 3, ISTAT, LU ) B8700047^^ 21 CALL CHAIN ( MENU ) B8700048^^ 22 150 CALL READR ( UREQ, UREC, KTEMP, ISTAT ) B8700049^^ 23 IF ( ISTAT .GE. 0 .AND. AND(ISTAT,$200) .NE. $200 ) GO TO 200 B8700050^^ C FILE ERROR OR WRONG RECORD, REPORT AND EXIT B8700051^^ 24 CALL FILERR ( UDATA, 13, ISTAT, LU ) B8700052^^ 25 CALL CLOSFL ( UREQ, ISTAT ) B8700053^^ 26 CALL CHAIN ( MENU ) B8700054^^ 27 200 JOBNO = UREC(9) B8700055^^ 28 CALL CLOSFL ( UREQ, ISTAT ) B8700056^  ^ C DELETE PRFPG000, NO CHECK ISTAT (MAY NOT BE PRESENT) B8700058^^ 29 DO 160 I=1,24 B8700059^^ 30 160 UREQ(I) = 0 B8700060^^ 31 CALL DELETE ( UREQ, NNAME, ISTAT ) B8700061^t FTN 3.3B (OPT = LPC) PGCNT1 PAGE 3 DATE: 08/29/84 TIME: 2229 t^ C IF THE JOB NUMBER IS '00' THEN THE ENTRY IN THE MENU B8700063^^ C IS NOT UPDATED. B8700064^^ 32 IF ( JOBNO .EQ. ASCZER ) GO TO 300 B8700065^^ C SET UP THE PROGRAM NAME IN THE MENU (SAVED REPORT) B8700066^ ^ 33 CALL OPENFL ( PREQ, PDATA, ISTAT ) B8700068^^ 34 IF ( ISTAT .GE. 0 ) GO TO 201 B8700069^^ 35 CALL FILERR ( PDATA, 3, ISTAT, LU ) B8700070^^ 36 CALL CHAIN ( MENU ) B8700071^^ 37 201 LNAME(3) = JOBNO B8700072^^ 38 CALL READR ( PREQ, PREC, LNAME, ISTAT ) B8700073^^ 39 IF ( ISTAT .GE. 0 .AND. AND(ISTAT,$200) .NE. $200 ) GO TO 202 B8700074^^ 40 CALL FILERR ( PDATA, 13, ISTAT, LU ) B8700075^^ 41 CALL CLOSFL ( PREQ, ISTAT ) B8700076^^ 42 CALL CHAIN ( MENU ) B8700077^^ 43 202 CALL CLOSFL ( PREQ, ISTAT ) B8700078^^ 44 CALL OPENFL ( MREQ, MDATA, ISTAT ) B8700079^^ 45 IF ( ISTAT .GE. 0 ) GO TO 203 B8700080^^ 46 CALL FILERR ( MDATA, 3, ISTAT, LU ) B8700081^^ 47 CALL CHAIN ( MENU ) B8700082^^ 48 203 RRN(2) = 10*AND(JOBNO,$F00)/$100 + AND(JOBNO,$F) + 2 B8700083^^ 49 CALL READR ( MREQ, MREC, RRN, ISTAT ) B8700084^^ 50 IF ( ISTAT .GE. 0 ) GO TO 204 B8700085^^ 51 CALL FILERR ( MDATA, 13, ISTAT, LU ) B8700086^^ 52 CALL CLOSFL ( MREQ, ISTAT ) B8700087^^ 53 CALL CHAIN ( MENU ) B8700088^^ 54 204 CALL CCSMVA ( PREC, 13, 30, MREC, 15, 58 ) B8700089^^ 55 CALL CCSMVA ( PREC, 7, 6, MREC, 67, 6 ) B8700090^^ 56 CALL UPDREC ( MREQ, MREC, ISTAT ) B8700091^^ 57 IF ( ISTAT .GE. 0 ) GO TO 205 B8700092^^ 58 CALL FILERR ( MDATA, 15, ISTAT, LU ) B8700093^^ 59 CALL CLOSFL ( MDATA, ISTAT ) B8700094^^ 60 CALL CHAIN ( MENU ) B8700095^^ 61 205 CALL CLOSFL ( MREQ, ISTAT ) B8700096^t FTN 3.3B (OPT = LPC) PGCNT1 PAGE 4 DATE: 08/29/84 TIME: 2229 t^ C REMOVE THE ENTRIES 'RPTEXX' AND 'RPTPXX' FROM THE B8700098^^ C $$PGMNAM FILE TO ALLOW CORRECT LINKAGE ON EXECUTION B8700099^^ 62 300 LNAME1(3) = JOBNO B8700100^^ 63 LNAME2(3) = JOBNO B8700101^^ 64 CALL OPENFL ( LREQ, LDATA, ISTAT ) B8700102^^ 65 IF ( ISTAT .GE. 0 ) GO TO 250 B8700103^^ 66 I = 3 B8700104^^ 67 GO TO 299 B8700105^^ 68 250 CALL READR ( LREQ, LREC, LNAME1, ISTAT ) B8700106^^ 69 IF (AND(ISTAT,$100).EQ.$100.OR.AND(ISTAT,$200).EQ.$200) GO TO 270 B8700107^^ 70 IF ( ISTAT .GE. 0 ) GO TO 260 B8700108^^ 71 I = 13 B8700109^^ 72 GO TO 299 B8700110^^ 73 260 CALL DELREC ( LREQ, LREC, ISTAT ) B8700111^^ 74 IF ( ISTAT .GE. 0 ) GO TO 270 B8700112^^ 75 I = 15 B8700113^^ 76 GO TO 299 B8700114^^ 77 270 CALL READR ( LREQ, LREC, LNAME2, ISTAT ) B8700115^^ 78 IF (AND(ISTAT,$100).EQ.$100.OR.AND(ISTAT,$200).EQ.$200) GO TO 290 B8700116^^ 79 IF ( ISTAT .GE. 0 ) GO TO 280 B8700117^^ 80 I = 13 B8700118^^ 81 GO TO 299 B8700119^^ 82 280 CALL DELREC ( LREQ, LREC, ISTAT ) B8700120^^ 83 IF ( ISTAT .GE. 0 ) GO TO 290 B8700121^^ 84 I = 15 B8700122^^ 85 299 CALL FILERR ( LDATA, I, ISTAT, LU ) B8700123^^ 86 CALL CLOSFL ( LREQ, ISTAT ) B8700124^^ 87 CALL CHAIN ( MENU ) B8700125^^ 88 290 CALL CLOSFL ( LREQ, ISTAT ) B8700126^t FTN 3.3B (OPT = LPC) PGCNT1 PAGE 5 DATE: 08/29/84 TIME: 2229 t^ C SET UP SELECTION L LINKAGE ON THE RP MENU B8700128^^ 89 RRN(1) = 0 B8700129^^ 90 RRN(2) = 0 B8700130^^ 91 CALL OPENFL ( RREQ, RDATA, ISTAT ) B8700131^^ 92 IF ( ISTAT .GE. 0 ) GO TO 330 B8700132^^ 93 CALL FILERR ( RDATA, 3, ISTAT, LU ) B8700133^^ 94 CALL CHAIN (MENU) B8700134^^ 95 330 CALL GETS ( RREQ, PREC,RRN,ISTAT) B8700135^^ 96 IF ( ISTAT .GE. 0 ) GO TO 340 B8700136^^ 97 CALL FILERR ( RDATA, 14, ISTAT , LU ) B8700137^^ 98 CALL CLOSFL ( RREQ, ISTAT ) B8700138^^ 99 CALL CHAIN (MENU) B8700139^^ 100 340 IF ( PREC(6) .NE. $4C20 ) GO TO 330 B8700140^^ 101 PREC(4) = JOBNO B8700141^^ 102 CALL UPDREC ( RREQ, PREC, ISTAT) B8700142^^ 103 CALL CLOSFL ( RREQ, ISTAT ) B8700143^  ^ C RENAME THE PROCEDURE WORK FILE TO THE CORRECT NAME B8700145^^ C FOR LINKAGE IN THE $$PROCED FILE B8700146^^ 104 320 NNAME(4) = JOBNO B8700147^^ 105 CALL RENAME ( NREQ, NDATA, NNAME, ISTAT ) B8700148^^ 106 IF ( ISTAT .GE. 0 ) GO TO 350 B8700149^^ C FILE ERROR, REPORT AND EXIT B8700150^^ 107 CALL FILERR ( NDATA, 9, ISTAT, LU ) B8700151^^ 108 CALL CHAIN ( MENU ) B8700152^t FTN 3.3B (OPT = LPC) PGCNT1 PAGE 6 DATE: 08/29/84 TIME: 2229 t^ C CHECK IF THE TWO BATCHED RPG PROGRAMS HAVE BEEN INSTALLED, B8700154^^ C WHEN THEY ARE PASS CONTROL TO THE PROCEDURE FOR EXECUTION B8700155^^ C OF THE PROCEDURE STREAM. THE COMPLETION OF THE INSTALLS B8700156^^ C IS DETERMINED BY CHECKING THE ENTRIES OF THE $$HOST FILE B8700157^^ C FOR THE HOST=LOCL, FOR ALL STATUS'S COMPLETE : B8700158^  ^ ********************* CAUTION ! *************************************** B8700160^^ ** ** B8700161^^ ** THERE SHOULD BE NO OTHER BATCH FILE PROCESSING BEING DONE ** B8700162^^ ** AT THE SAME TIME AS MINI-RPG; AS THIS SECTION WILL BE ** B8700163^^ ** LOCKED INTO EXECUTION FOR A LONG, LONG TIME; AND AT THE ** B8700164^^ ** COMPLETION OF THIS STREAM ALL JOB FILES ARE FLUSHED FROM ** B8700165^^ ** THE HOST SYSTEM. ** B8700166^^ ** ** B8700167^^ *********************************************************************** B8700168^  ^ 109 350 CALL OPENFL ( HREQ, HDATA, ISTAT ) B8700170^^ 110 IF ( ISTAT .GE. 0 ) GO TO 400 B8700171^^ C FILE ERROR, REPORT AND EXIT B8700172^^ 111 CALL FILERR ( HDATA, 3, ISTAT, LU ) B8700173^^ 112 CALL CHAIN ( MENU ) B8700174^^ C GET THE 'LOCL' HOST RECORD B8700175^^ 113 400 CALL GETS ( HREQ, HREC, HOST, ISTAT ) B8700176^^ 114 IF ( AND(ISTAT,$80) .EQ. $80 ) GO TO 400 B8700177^^ 115 IF ( ISTAT .GE. 0 ) GO TO 450 B8700178^^ C FILE ERROR, REPORT AND EXIT B8700179^^ 116 CALL FILERR ( HDATA, 14, ISTAT, LU ) B8700180^^ 117 CALL CLOSFL ( HREQ, ISTAT ) B8700181^^ 118 CALL CHAIN ( MENU ) B8700182^^ C CLOSE THE FILE, THEN SEARCH TO VERIFY ALL JOBS COMPLETE B8700183^^ 119 450 CALL CLOSFL ( HREQ, ISTAT ) B8700184^^ 120 DO 500 I = 4, 18 B8700185^^ 121 IF ( HREC(I) .EQ. 0 ) GO TO 500 B8700186^^ C LOCATED A ACTIVE JOB, CHECK IF COMPLETE B8700187^^ 122 I1 = AND(HREC(I),$F000) / $1000 B8700188^^ 123 I2 = AND(HREC(I),$0F00) / $100 B8700189^^ 124 I3 = AND(HREC(I),$00F0) / $10 B8700190^^ 125 I4 = AND(HREC(I),$000F) B8700191^^ 126 IF ( I1 .EQ. 0 .OR. I1 .GT. 3 .AND. B8700192^^ 126 1 I2 .EQ. 0 .OR. I2 .GT. 3 .AND. B8700193^^ 126 2 I3 .EQ. 0 .OR. I3 .GT. 3 .AND. B8700194^^ 126 3 I4 .EQ. 0 .OR. I4 .GT. 3 ) GO TO 500 B8700195^^ 127 GO TO 550 B8700196^^ 128 500 CONTINUE B8700197^^ C ALL JOBS ARE INACTIVE OR ARE COMPLETE, PASS CONTROL B8700198^^ C TO THE OPERATOR B8700199^^ 129 CALL PGMOUT B8700200^  ^ C NOT ALL JOBS ARE DONE, PAUSE THEN CHECK AGAIN B8700202^^ 130 550 DO 600 I = 1, 24 B8700203^^ 131 600 HREQ(I) = 0 B8700204^t FTN 3.3B (OPT = LPC) PGCNT1 PAGE 7 DATE: 08/29/84 TIME: 2229 t^ 132 HOST = 0 B8700205^^ 133 GO TO 350 B8700206^  ^ 134 CALL PGMOUT B8700208^^ 135 END B8700209^t FTN 3.3B (OPT = LPC) PGCNT1 PAGE 8 DATE: 08/29/84 TIME: 2229 t  PROGRAM LENGTH $03F3 ( 1011)   EXTERNALS 2 Q8STP PGMIN OPENFL FILERR CHAIN READR CLOSFL 22 DELETE CCSMVA UPDREC DELREC GETS RENAME PGMOUT 2 t FTN 3.3B (OPT = LPC) PGCNT1 PAGE 9 DATE: 08/29/84 TIME: 2229 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " F000 (-4095) 01EA 122"> 0003 (3) 01D9 20,35,37,46,62,63,66,93,111,126>( 0006 (6) 01E3 55,55,100(" 0007 (7) 01E2 55 "" 0009 (9) 01E7 107"0 000D (13) 01DB 24,40,51,54,71,800& 000E (14) 01E5 97,116 &2 000F (15) 01DF 48,54,58,75,84,125 2" 001E (30) 01E0 54 "" 003A (58) 01E1 54 "" 0043 (67) 01E4 55 "& 0080 (128) 01E8 114,114&" 00F0 (240) 01ED 124", 0100 (256) 01DE 48,69,78,123 ,. 0200 (512) 01DA 23,23,39,69,78 .& 0F00 (3840) 01DD 48,123 &" 4C20 (19488) 01E6 100"   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < B AND INTR.FN. 7FFF 23,39,48,69,78,114,122,123,124,125 B& ASCZER INTEGER 0131 1,12,32&. HDATA INTEGER 0041 1,8,109,111,116., HOST INTEGER 010F 1,12,113,132 ,8 HREC INTEGER 00A8 1,113,121,122,123,124,12588 HREQ INTEGER 0050 1,10,109,113,117,119,131 8V I INTEGER 01DC 28,30,66,71,75,80,84,85,120,121,122,123,124,125,130,131V* I1 INTEGER 01E9 121,122,126** I2 INTEGER 01EB 122,123,126** I3 INTEGER 01EC 123,124,126** I4 INTEGER 01EE 124,125,126*‚ ISTAT INTEGER 01D8 18,19,20,22,23,24,25,28,31,33,34,35,38,39,40,41,43,44,45,46,49,50,51,52,56,57,58,59,61,64,65,68,69 ‚‚ ,70,73,74,77,78,79,82,83,85,86,88,91,92,93,95,96,97,98,102,103,105,106,107,109,110,111,113,114,115 ‚, ,116,117,119 ,: JOBNO INTEGER 0110 1,27,32,37,48,62,63,101,104:& KTEMP INTEGER 0129 1,12,22&* LDATA INTEGER 014A 1,15,64,85 ** LNAME INTEGER 0181 1,16,37,38 ** LNAME1 INTEGER 017B 1,16,62,68 ** LNAME2 INTEGER 017E 1,16,63,77 *, LREC INTEGER 0171 1,68,73,77,82,8 LREQ INTEGER 0159 1,10,64,68,73,77,82,86,888t FTN 3.3B (OPT = LPC) PGCNT1 PAGE 10 DATE: 08/29/84 TIME: 2229 tL LU INTEGER 01D5 17,20,24,35,40,46,51,58,85,93,97,107,111,116 L2 MDATA INTEGER 0186 1,6,44,46,51,58,59 2N MENU INTEGER 012D 1,11,21,26,36,42,47,53,60,87,94,99,108,112,118 N" MODE INTEGER 01D6 17 ", MREC INTEGER 01AD 1,49,54,55,56,2 MREQ INTEGER 0195 1,10,44,49,52,56,612, NDATA INTEGER 013E 1,13,105,107 ,. NNAME INTEGER 0132 1,14,31,104,105." NPORT INTEGER 01D7 17 "( NREQ INTEGER 0111 1,10,105 (, PDATA INTEGER 00BC 1,7,33,35,40 ,8 PREC INTEGER 00E3 1,38,54,55,95,100,101,10280 PREQ INTEGER 00CB 1,10,33,38,41,43 0, RDATA INTEGER 0002 1,9,91,93,97 ,4 RREQ INTEGER 001A 1,10,91,95,98,102,10342 RRN INTEGER 0184 1,11,48,49,89,90,952, UDATA INTEGER 0032 1,5,18,20,24 ,& UREC INTEGER 0080 1,22,27&6 UREQ INTEGER 0068 1,10,18,22,25,28,30,31 6$ USER INTEGER 010B 1,17 $   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < $ CCSMVA SUBROUTINE 029C 54,55$H CHAIN SUBROUTINE 0398 20,26,36,42,47,53,60,87,94,99,108,112,118HH CLOSFL SUBROUTINE 0394 24,28,41,43,52,59,61,86,88,98,103,117,119H" DELETE SUBROUTINE 0231 30 "$ DELREC SUBROUTINE 02EC 73,82$H FILERR SUBROUTINE 038E 19,24,35,40,46,51,58,85,93,97,107,111,116H& GETS SUBROUTINE 0338 95,113 &2 OPENFL SUBROUTINE 0371 17,33,44,64,91,109 2" PGMIN SUBROUTINE 01F0 16 "& PGMOUT SUBROUTINE 03DF 128,134& Q8STP INTEGER.FN. 03F2 . READR SUBROUTINE 0286 22,38,49,68,77 ." RENAME SUBROUTINE 0361 104"& UPDREC SUBROUTINE 0356 55,102 &   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < " 100 01F5 17 "$ 150 0206 19,22$$ 160 0227 28,30$$ 200 021E 23,27$$ 201 024A 34,37$$ 202 0265 39,43$t FTN 3.3B (OPT = LPC) PGCNT1 PAGE 11 DATE: 08/29/84 TIME: 2229 t$ 203 0276 45,48$$ 204 029B 50,54$$ 205 02BC 57,61$$ 250 02D4 65,68$$ 260 02EB 70,73$( 270 02F6 69,74,77 ($ 280 030B 79,82$( 290 0321 78,83,88 (. 299 0314 66,72,76,81,85 .$ 300 02BF 32,62$" 320 035D 103"( 330 0337 92,95,100(& 340 034B 96,100 &* 350 0370 106,109,133** 400 037F 110,113,114*& 450 039A 115,119&. 500 03D9 119,121,126,128.& 550 03E0 126,130&& 600 03E2 130,131& PGCNT1 0000 1  t FTN 3.3B (OPT = LPC) PGCNT2 PAGE 1 DATE: 08/29/84 TIME: 2230 t^ 1 PROGRAM PGCNT2 B8800001^^ 1 1 /B88 F CCS CCS 3.0 SL-149B8800002^^ C B8800003^^ C CYBERCREDIT SYSTEM VERSION 3 B8800004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B8800005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B8800006^^ C B8800007^  ^ 2 INTEGER USER(4),MENU(4),UDATA(15),UREQ(24),UREC(42),RPTG(2) B8800009^^ 3 DATA RPTG / 'RPTG' /, MENU / 'MNUPRO ' /, UREQ / 24*0 / B8800010^^ 4 DATA UDATA / 'UTIFIL ', 8*$2020, 1, 1, 1 / B8800011^  ^ 5 CALL PGMIN ( USER, LU, MODE, NPORT ) B8800013^  ^ 6 I = 0 B8800015^^ 7 CALL OPENFL ( UREQ, UDATA, ISTAT ) B8800016^^ 8 IF ( ISTAT .GE. 0 ) GO TO 100 B8800017^^ 9 CALL FILERR ( UDATA, 3, ISTAT, LU ) B8800018^^ 10 CALL CHAIN ( MENU ) B8800019^  ^ 11 100 CALL READR ( UREQ, UREC, RPTG, ISTAT ) B8800021^^ 12 IF ( ISTAT.GE.0.AND.AND(ISTAT,$200).NE.$200) GO TO 200 B8800022^^ 13 CALL FILERR ( UDATA, 13, ISTAT, LU ) B8800023^^ 14 CALL CLOSFL ( UREQ, ISTAT ) B8800024^^ 15 CALL CHAIN ( MENU ) B8800025^  ^ 16 200 IF ( UREC(12) .EQ. $2020 ) GO TO 300 B8800027^^ 17 UREC(12) = $2020 B8800028^^ 18 CALL UPDREC ( UREQ, UREC, ISTAT ) B8800029^^ 19 I = 1 B8800030^  ^ 20 300 CALL CLOSFL ( UREQ, ISTAT ) B8800032^^ 21 IF ( I .EQ. 0 ) CALL CHAIN ( MENU ) B8800033^^ 22 CALL PGMOUT B8800034^^ 23 END B8800035^t FTN 3.3B (OPT = LPC) PGCNT2 PAGE 2 DATE: 08/29/84 TIME: 2230 t  PROGRAM LENGTH $00AE ( 174)   EXTERNALS 2 Q8STP PGMIN OPENFL FILERR CHAIN READR CLOSFL 2 UPDREC PGMOUT  t FTN 3.3B (OPT = LPC) PGCNT2 PAGE 3 DATE: 08/29/84 TIME: 2230 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : <  0003 (3) 0061 9 " 000D (13) 0063 13 "$ 0200 (512) 0062 12,12$$ 2020 (8224) 0064 16,17$   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " AND INTR.FN. 7FFF 12 "( I INTEGER 005F 5,6,19,21(6 ISTAT INTEGER 0060 7,8,9,11,12,13,14,18,206& LU INTEGER 005C 5,9,13 &, MENU INTEGER 0005 1,3,10,15,21 , MODE INTEGER 005D 5 NPORT INTEGER 005E 5 & RPTG INTEGER 005A 1,3,11 &* UDATA INTEGER 0009 1,4,7,9,13 *, UREC INTEGER 0030 1,11,16,17,18,0 UREQ INTEGER 0018 1,3,7,11,14,18,200" USER INTEGER 0001 1,5"   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < & CHAIN SUBROUTINE 007C 9,15,21&$ CLOSFL SUBROUTINE 0091 13,20$$ FILERR SUBROUTINE 0076 8,13 $ OPENFL SUBROUTINE 006E 6 PGMIN SUBROUTINE 0066 4 " PGMOUT SUBROUTINE 00AB 21 " Q8STP INTEGER.FN. 00AD " READR SUBROUTINE 007F 11 "" UPDREC SUBROUTINE 009C 17 "t FTN 3.3B (OPT = LPC) PGCNT2 PAGE 4 DATE: 08/29/84 TIME: 2230 t   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 100 007E 8,11 $$ 200 0096 12,16$$ 300 00A2 16,20$ PGCNT2 0000 1 t FTN 3.3B (OPT = LPC) Q8QBDS PAGE 1 DATE: 08/29/84 TIME: 2230 t^ 1 BLOCK DATA B8900001^^ 1 1 /B89 F CCS CCS 3.0 SL-149B8900002^^ C B8900003^^ C CYBERCRREDIT SYSTEM VERSION 3 B8900004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B8900005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B8900006^^ C B8900007^^ C B8900008^^ 2 COMMON /CBLK1/UTIFIL,DELQM,RPTTBL,RPTPGM,RPTWKE,UTIRQB,DLQRQB, B8900009^^ 2 2TBLRQB,PGMRQB,WKERQB,OPBUF,Q2SAVE,Q3SORT,Q4LVLB,Q5SLCT,Q6NAME, B8900010^^ 2 3Q6TOT,Q6EPOS,Q7RPT,Q5ANS,TBL,HPGMN,UTREC,PGMKEY,TBLKEY,BIN,ISTAT, B8900011^^ 2 4HPKEY,RADDR,TBLREC,OPHLD,D1TYPE,D1LNG,LRPGWK,IHOLD2,PGMREC,IND, B8900012^^ 2 5PRCREC,ERRMSG,UTEMSG,ABTMSG,XYN,TC,CS,PRCWRK,PRCRQB,LU B8900013^^ 3 COMMON /CBLK1/IMAXC,NLKEY,NNAME,NSKEY,NSLCT,NTFLDS,RPTWKP,WKPRQB B8900014^^ C B8900015^^ C B8900016^^ 4 INTEGER UTIFIL(15),DELQM(15),RPTTBL(15),RPTPGM(15),RPTWKE(15), B8900017^^ 4 2 UTIRQB(24),DLQRQB(24),TBLRQB(24),PGMRQB(24),WKERQB(24), B8900018^^ 4 3 PRCWRK(15),PRCRQB(24),RPTWKP(15),WKPRQB(24) B8900019^^ 5 INTEGER OPBUF(32),Q2SAVE(1),Q3SORT(60),Q4LVLB(9),Q5SLCT(170), B8900020^^ 5 2 Q6NAME(51),Q6TOT(77),Q6EPOS(102),Q7RPT(15),Q5ANS B8900021^^ 6 INTEGER XYN,TC,CS(2),TBL(4),PGMKEY(3),UTREC(42),ISTAT, B8900022^^ 6 2 TBLKEY(3),HPGMN(3),BIN(1),HPKEY(3),RADDR(1),TBLREC(42), B8900023^^ 6 3 D1LNG(2),LRPGWK(42),IHOLD2(2),PGMREC(42),IND(3), B8900024^^ 6 4 PRCREC(42),ERRMSG(23),UTEMSG(26),ABTMSG(7),OPHLD(1), B8900025^^ 6 5 D1TYPE(1) B8900026^^ 7 INTEGER IMAXC(1),NLKEY(1),NNAME(1),NSKEY(1),NSLCT(1),NTFLDS(1) B8900027^^ C B8900028^^ C FILE NAME,OWNER,NAME,VOLUME NAME,ACCESS INDIC,REC RTV,LOCK INDIC B8900029^^ 8 DATA UTIFIL / 'UTIFIL ' , 8*$2020 , 1 , 1 , 1 / B8900030^^ 9 DATA DELQM / 'DELQMST ' , 8*$2020 , 0 , 1 , 0 / B8900031^^ 10 DATA RPTTBL /'RPTTBL ',1,1,0/ B8900032^^ 11 DATA RPTPGM /'RPTPGM ',1,1,0/ B8900033^^ 12 DATA RPTWKE /'RPTWKE ',0,1,-1/ B8900034^^ 13 DATA RPTWKP /'RPTWKP ',0,1,-1/ B8900035^^ 14 DATA PRCWRK /'PRCWRK ',0,1,-1/ B8900036^^ C B8900037^^ C FILE BUFFERS--INITIALIZED TO BINARY 0 B8900038^^ 15 DATA UTIRQB /24*$0000/ B8900039^^ 16 DATA DLQRQB /24*$0000/ B8900040^^ 17 DATA TBLRQB /24*$0000/ B8900041^^ 18 DATA PGMRQB /24*$0000/ B8900042^^ 19 DATA WKERQB /24*$0000/ B8900043^^ 20 DATA WKPRQB /24*$0000/ B8900044^^ 21 DATA PRCRQB /24*$0000/ B8900045^^ C B8900046^^ 22 DATA ERRMSG/' ERROR IN FILE REQUEST, ISTAT = $ ',$D0A/ B8900047^^ 23 DATA UTEMSG/' ERROR IN UTIFIL--RPTG RECORD NOT FOUND OR INVALID', B8900048^^ 23 2$D0A/ B8900049^^ 24 DATA ABTMSG/' JOB ABORTED',$D0A/ B8900050^^ C B8900051^^ C MISCELLANEOUS B8900052^^ 25 DATA HPGMN/'RPT000'/,LRPGWK/42*$2020/,PRCREC/42*$2020/,XYN/-1/, B8900053^^ 25 2 CS/$18,$D0A/ B8900054^t FTN 3.3B (OPT = LPC) Q8QBDS PAGE 2 DATE: 08/29/84 TIME: 2230 t^ 26 DATA Q3SORT/60*$2020/,Q4LVLB/9*$2020/,Q5SLCT/170*$2020/, B8900055^^ 26 2 Q6NAME/51*$2020/,Q7RPT/15*$2020/,Q6TOT/77*$2020/, B8900056^^ 26 3 Q6EPOS/102*$2020/ B8900057^^ 27 END B8900058^t FTN 3.3B (OPT = LPC) Q8QBDS PAGE 3 DATE: 08/29/84 TIME: 2230 t COMMON  LABEL $0448 ( 1096)    PROGRAM LENGTH $0000 ( 0)   t FTN 3.3B (OPT = LPC) Q8QBDS PAGE 4 DATE: 08/29/84 TIME: 2230 t, ***** L I S T O F S Y M B O L S *****,   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < & ABTMSG INTEGER 03E8 D 1,6,24 &" BIN INTEGER 0300 D 1,6"& CS INTEGER 03F1 D 1,6,25 &" D1LNG INTEGER 0332 D 1,6"" D1TYPE INTEGER 0331 D 1,6"$ DELQM INTEGER 000F D 1,4,9$& DLQRQB INTEGER 0063 D 1,4,16 && ERRMSG INTEGER 03B7 D 1,6,22 && HPGMN INTEGER 02CD D 1,6,25 &" HPKEY INTEGER 0302 D 1,6"" IHOLD2 INTEGER 035E D 1,6"" IMAXC INTEGER 041B D 1,7"" IND INTEGER 038A D 1,6"" ISTAT INTEGER 0301 D 1,6"& LRPGWK INTEGER 0334 D 1,6,25 & LU INTEGER 041A D 1 " NLKEY INTEGER 041C D 1,7"" NNAME INTEGER 041D D 1,7"" NSKEY INTEGER 041E D 1,7"" NSLCT INTEGER 041F D 1,7"" NTFLDS INTEGER 0420 D 1,7"" OPBUF INTEGER 00C3 D 1,5"" OPHLD INTEGER 0330 D 1,6"" PGMKEY INTEGER 02FA D 1,6"" PGMREC INTEGER 0360 D 1,6"& PGMRQB INTEGER 0093 D 1,4,18 && PRCREC INTEGER 038D D 1,6,25 && PRCRQB INTEGER 0402 D 1,4,21 && PRCWRK INTEGER 03F3 D 1,4,14 &" Q2SAVE INTEGER 00E3 D 1,5"& Q3SORT INTEGER 00E4 D 1,5,26 && Q4LVLB INTEGER 0120 D 1,5,26 &" Q5ANS INTEGER 02C8 D 1,5"& Q5SLCT INTEGER 0129 D 1,5,26 && Q6EPOS INTEGER 0253 D 1,5,26 && Q6NAME INTEGER 01D3 D 1,5,26 && Q6TOT INTEGER 0206 D 1,5,26 && Q7RPT INTEGER 02B9 D 1,5,26 &" RADDR INTEGER 0305 D 1,6"& RPTPGM INTEGER 002D D 1,4,11 && RPTTBL INTEGER 001E D 1,4,10 && RPTWKE INTEGER 003C D 1,4,12 && RPTWKP INTEGER 0421 D 1,4,13 &" TBL INTEGER 02C9 D 1,6"" TBLKEY INTEGER 02FD D 1,6"" TBLREC INTEGER 0306 D 1,6"t FTN 3.3B (OPT = LPC) Q8QBDS PAGE 5 DATE: 08/29/84 TIME: 2230 t& TBLRQB INTEGER 007B D 1,4,17 &" TC INTEGER 03F0 D 1,6"& UTEMSG INTEGER 03CE D 1,6,23 &$ UTIFIL INTEGER 0000 D 1,4,8$& UTIRQB INTEGER 004B D 1,4,15 &" UTREC INTEGER 02D0 D 1,6"& WKERQB INTEGER 00AB D 1,4,19 && WKPRQB INTEGER 0430 D 1,4,20 && XYN INTEGER 03EF D 1,6,25 &   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : <  Q8QBDS 7FFF  t FTN 3.3B (OPT = LPC) PGGEN0 PAGE 1 DATE: 08/29/84 TIME: 2230 t^ 1 SUBROUTINE PGGEN0 B9000001^^ 1 1 /B90 F CCS CCS 3.0 POST 3.0 PSR 12/28/2 SL-149********^^ C B9000003^^ C CYBERCREDIT SYSTEM VERSION 3 B9000004^^ C DATA SYSTEMS LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B9000005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B9000006^^ C B9000007^^ C THIS PROGRAM FUNCTIONS AS A GENERAL REPORT PROGRAM GENERATOR. B9000008^^ C THERE ARE 4 BASIC STEPS: B9000009^^ C 1. OPERATOR COMMUNICATION - THE OPERATOR ENTERS THE REPORT B9000010^^ C REQUIREMENTS. THE PROGRAM PROMPTS THE OPERATOR AND B9000011^^ C EDITS THE RESPONSES. B9000012^^ C GENERATES SOURCE CODE - BASED ON THE OPERATOR'S B9000013^^ C RESPONSES, A FORTRAN EXTRACT PROGRAM AND AN RPG PRINT B9000014^^ C PROGRAM ARE CREATED B9000015^^ C 3. GENERATES A PROCEDURE STREAM TO BE USED IN EXECUTING B9000016^^ C THE RPG PROGRAM PRODUCED B9000017^^ C B9000018^^ C THE FOLLOWING SUBPROGRAMS/ROUTINES ARE CALLED: B9000019^^ C 1. ASCBIN--CONVERTS 1 WORD ASCII TO 1 WORD BINARY B9000020^^ C 2. CCSHXA--CONVERTS 1 WORD BINARY TO 2 WORD ASCII B9000021^^ C 3. PGSEDT--EDITS OPERATOR RESPONSE FOR: B9000022^^ C C -CONTINUE TO NEXT QUESTION B9000023^^ C A -ABORT JOB B9000024^^ C REPEAT -REPEAT THIS QUESTION B9000025^^ C XXXXXX -DATA RESPONSE, DOES NOT EDIT DATA AS B9000026^^ C THE VALIDITY VARIES B9000027^^ C 4. PGSJR --RIGHT JUSTIFIES DATA WITH LEADING ZEROS B9000028^^ C 5. PGSJL --LEFT JUSTIFIES DATA WITH TRAILING BLANKS B9000029^^ C 6. PGSLST --PRINTS A REPORT BASED ON THE CONTENTS OF THE B9000030^^ C RPTTBL FILE (DATE ELEMENT TABLE) B9000031^^ C 7. CCSGET--GET 1 CHARACTER FROM AN ARRAY & STORE IN RIGHTMOST B9000032^^ C BYTE OF A 1 WORD WORK AREA B9000033^^ C 8. CCSPUT--PUT RIGHTMOST BYTE OF A 1 WORD WORK AREA INTO GIVENB9000034^^ C POSITION OF AN ARRAY B9000035^^ C 9. PGGEN1--OPERATOR COMMUNICATION B9000036^^ C 10. PGGN2E--GENERATES RPG SOURCE CODE FOR EXTRACTION PGM B9000037^^ C 11. PGGN2P--GENERATES RPG SOURCE CODE FOR PRINT PGM B9000038^^ C 12. PGGEN3--GENERATES PROCEDURE STREAM FOR RPG PGMS & SORT B9000039^^ C 13. CCSCST--COMPARE 2 ASCII CHARACTER STRINGS B9000040^^ C B9000041^^ C 14. FILERR - INFORMS THE OPERATOR OF ERRORS B9000042^^ C B9000043^^ C B9000044^^ C**** COMMON BLOCK CBLK1 B9000045^^ C B9000046^^ 2 COMMON /CBLK1/UTIFIL,DELQM,RPTTBL,RPTPGM,RPTWKE,UTIRQB,DLQRQB, B9000047^^ 2 2TBLRQB,PGMRQB,WKERQB,OPBUF,Q2SAVE,Q3SORT,Q4LVLB,Q5SLCT,Q6NAME, B9000048^^ 2 3Q6TOT,Q6EPOS,Q7RPT,Q5ANS,TBL,HPGMN,UTREC,PGMKEY,TBLKEY,BIN,ISTAT, B9000049^^ 2 4HPKEY,RADDR,TBLREC,OPHLD,D1TYPE,D1LNG,LRPGWK,IHOLD2,PGMREC,IND, B9000050^^ 2 5PRCREC,ERRMSG,UTEMSG,ABTMSG,XYN,TC,CS,PRCWRK,PRCRQB,LU B9000051^^ 3 COMMON /CBLK1/IMAXC,NLKEY,NNAME,NSKEY,NSLCT,NTFLDS,RPTWKP,WKPRQB B9000052^^ C B9000053^^ C FILE RETRIEVAL B9000054^t FTN 3.3B (OPT = LPC) PGGEN0 PAGE 2 DATE: 08/29/84 TIME: 2230 t^ 4 INTEGER UTIFIL(15),DELQM(15),RPTTBL(15),RPTPGM(15),RPTWKE(15), B9000055^^ 4 2 UTIRQB(24),DLQRQB(24),TBLRQB(24),PGMRQB(24),WKERQB(24), B9000056^^ 4 3 PRCWRK(15),PRCRQB(24),RPTWKP(15),WKPRQB(24) B9000057^^ C B9000058^^ C OPERATOR RESPONSES B9000059^^ 5 INTEGER OPBUF(32),Q2SAVE,Q3SORT(60),Q4LVLB(9),Q5SLCT(170), B9000060^^ 5 2 Q6NAME(51),Q6TOT(77),Q6EPOS(102),Q7RPT(15),Q5ANS B9000061^^ C B9000062^^ C MISCELLANEOUS B9000063^^ 6 INTEGER XYN,TC,CS(2),TBL(4),HPGMN(3),RPTG(2),UTREC(42),ISTAT, B9000064^^ 6 2 ZERO,PGMKEY(3),TBLKEY(3),COMMA,BIN,HPKEY(3),RADDR,TBLREC(42), B9000065^^ 6 3 OPHLD,D1TYPE,D1LNG(2),LRPGWK(42),IHOLD2(2),PGMREC(42),IND(3), B9000066^^ 6 4 PRCREC(42),ERRMSG(23),UTEMSG(26),ABTMSG(7),FILREQ(24),MENU(4) B9000067^^ 7 INTEGER NT1MSG(26),NT2MSG(23) B9000068^^ C B9000069^^ C B9000070^^ C B9000071^^ C B9000072^^ C B9000073^^ C**** DATA STATEMENTS B9000074^^ C B9000075^^ 8 DATA RPTG/'RPTG'/,ZERO/0/,COMMA/$002C/ B9000076^^ 9 DATA NT1MSG/$D0A,'PLEASE NOTE ANY ERROR MESSAGES DISPLAYED ABOVE. B9000077^^ 9 1',$D0A/ B9000078^^ 10 DATA NT2MSG/'PRESS CARRIAGE RETURN WHEN READY TO CONTINUE',$D0A/ B9000079^^ 11 DATA MENU / 'MNUPRO ' / B9000080^^ C B9000081^^ C EXTERNALS B9000082^^ 12 EXTERNAL AVMHXA,AMONTO,ADAYTO,AYERTO B9000083^^ 13 EXTERNAL PGGEN1,PGGN2E,PGGN2P,PGGEN3 B9000084^^ C B9000085^^ C********* B9000086^^ C**** BEGIN PROCESSING B9000087^^ C********* B9000088^^ C B9000089^^ C LOGIN B9000090^^ C B9000091^^ 14 CALL PGMIN(TBL,LU,I,J) B9000092^^ C VERIFY MASTER CONSOLE ONLY, EXIT IF NOT B9000093^^ 15 IF (J.NE.0) GO TO 8900 B9000094^^ C B9000095^^ C B9000096^^ C B9000097^^ C OPEN FILES B9000098^^ C UTILITY FILE B9000099^^ 16 CALL OPENFL(UTIRQB,UTIFIL,ISTAT) B9000100^^ 17 IF(ISTAT.GE.0) GO TO 1000 B9000101^^ 18 CALL FILERR(UTIFIL,3,ISTAT,LU) B9000102^^ 19 GO TO 8200 B9000103^^ C DELINQUENT MASTER B9000104^^ 20 1000 CALL OPENFL(DLQRQB,DELQM,ISTAT) B9000105^^ 21 IF(ISTAT.GE.0) GO TO 1010 B9000106^^ 22 CALL FILERR(DELQM,3,ISTAT,LU) B9000107^^ 23 GO TO 8200 B9000108^t FTN 3.3B (OPT = LPC) PGGEN0 PAGE 3 DATE: 08/29/84 TIME: 2230 t^ C REPORT GENERATOR TABLE-OF-DATA-NAMES FILER B9000109^^ 24 1010 CALL OPENFL(TBLRQB,RPTTBL,ISTAT) B9000110^^ 25 IF(ISTAT.GE.0) GO TO 1020 B9000111^^ 26 CALL FILERR(RPTTBL,3,ISTAT,LU) B9000112^^ 27 GO TO 8200 B9000113^^ C PROCEDURE STREAM WORK FILE B9000114^^ 28 1020 CALL OPENFL(PRCRQB,PRCWRK,ISTAT) B9000115^^ 29 IF(ISTAT.GE.0) GO TO 1030 B9000116^^ 30 CALL FILERR(PRCWRK,3,ISTAT,LU) B9000117^^ 31 GO TO 8200 B9000118^^ C B9000119^^ C REPORT GENERATOR PROGRAM NAME FILE B9000120^^ 32 1030 CALL OPENFL(PGMRQB,RPTPGM,ISTAT) B9000121^^ 33 IF(ISTAT.GE.0) GO TO 1040 B9000122^^ 34 CALL FILERR(RPTPGM,3,ISTAT,LU) B9000123^^ 35 GO TO 8200 B9000124^^ C B9000125^^ C FORTRAN EXTRACT SOURCE CODE FILE B9000126^^ 36 1040 CALL OPENFL(WKERQB,RPTWKE,ISTAT) B9000127^^ 37 IF(ISTAT.GE.0) GO TO 1050 B9000128^^ 38 CALL FILERR(RPTWKE,3,ISTAT,LU) B9000129^^ 39 GO TO 8200 B9000130^^ C RPG PRINT SOURCE CODE FILE B9000131^^ 40 1050 CALL OPENFL(WKPRQB,RPTWKP,ISTAT) B9000132^^ 41 IF(ISTAT.GE.0) GO TO 2000 B9000133^^ 42 CALL FILERR(RPTWKP,3,ISTAT,LU) B9000134^^ 43 GO TO 8200 B9000135^^ C B9000136^^ C OPERATOR COMMUNICATION TO GET PARAMETERS B9000137^^ C B9000138^^ 44 2000 CALL PGGEN1 B9000139^^ C READR PGMREC B9000140^^ 45 IF(RADDR.EQ.$8010) GO TO 8000 B9000141^^ 46 IF (RADDR.EQ.$8100) GO TO 8100 B9000142^^ 47 IF (RADDR.EQ.$8900) GO TO 8900 B9000143^^ C B9000144^^ C GENERATE RPG SOURCE CODE--EXTRACTION PGM B9000145^^ C B9000146^^ 48 CALL PGGN2E B9000147^^ C READR TBLREC B9000148^^ 49 IF(RADDR.EQ.$8010) GO TO 8010 B9000149^^ C PUTS LRPGWK B9000150^^ 50 IF(RADDR.EQ.$8020) GO TO 8020 B9000151^^ C‚ B9000152^^ C GENERATE RPG SOURCE CODE--PRINT PGM B9000153^^ C B9000154^^ 51 CALL PGGN2P B9000155^^ C READR TBLREC B9000156^^ C***************************************************** ???*A??? ********^^ 52 IF(RADDR.EQ.$8010) GO TO 8010 ********^^ C***************************************************** ???*A??? ********^^ C PUTS LRPGWK B9000158^^ 53 IF(RADDR.EQ.$8020) GO TO 8030 B9000159^^ C B9000160^t FTN 3.3B (OPT = LPC) PGGEN0 PAGE 4 DATE: 08/29/84 TIME: 2230 t^ C GENERATE PROCEDURE STREAM B9000161^^ C B9000162^^ 54 CALL PGGEN3 B9000163^^ C PUTS PRCREC B9000164^^ 55 IF(RADDR.EQ.$8020) GO TO 8040 B9000165^^ C B9000166^^ C B9000167^^ C********* UPDATE UTIFIL, RPTPGM WITH B9000168^^ C********* NEW REPORT PROGRAM IF PROGRAM IS SAVED B9000169^^ C B9000170^^ C CURRENT RPT NAME B9000171^^ 56 UTREC(7)=HPGMN(1) B9000172^^ 57 UTREC(8)=HPGMN(2) B9000173^^ 58 UTREC(9)=HPGMN(3) B9000174^^ 59 UTREC(12) = $8010 B9000175^^ C IS PGM TO BE SAVED B9000176^^ 60 6000 IF (Q2SAVE.NE.$5900) GO TO 6050 B9000177^^ C YES B9000178^^ C NEXT AVAILABLE RPT NAME B9000179^^ 61 UTREC(4)=PGMKEY(1) B9000180^^ 62 UTREC(5)=PGMKEY(2) B9000181^^ 63 UTREC(6)=PGMKEY(3) B9000182^^ 64 6050 CALL UPDREC(UTIRQB,UTREC,ISTAT) B9000183^^ 65 IF (ISTAT.LT.0) GO TO 8050 B9000184^^ 66 IF (Q2SAVE.NE.$5900) GO TO 6190 B9000185^^ 67 6100 HPKEY(1)=HPGMN(1) B9000186^^ 68 HPKEY(2)=HPGMN(2) B9000187^^ 69 HPKEY(3)=HPGMN(3) B9000188^^ C CLEAR BUFFER AREA OF PGMREC B9000189^^ 70 CALL CCSBLK(PGMREC,84) B9000190^^ C B9000191^^ C PGM NAME B9000192^^ 71 PGMREC(1)=HPKEY(1) B9000193^^ 72 PGMREC(2)=HPKEY(2) B9000194^^ 73 PGMREC(3)=HPKEY(3) B9000195^^ C DATE CREATED B9000196^^ 74 PGMREC(4)=AND($FFFF,AMONTO) B9000197^^ 75 PGMREC(5)=AND($FFFF,ADAYTO) B9000198^^ 76 PGMREC(6)=AND($FFFF,AYERTO) B9000199^^ C REPORT TITLE B9000200^^ 77 CALL CCSMVA(Q7RPT,1,30,PGMREC,13,30) B9000201^^ C B9000202^^ C ADD RECORD TO RPTPGM FILE B9000203^^ 78 CALL WRITER(PGMRQB,PGMREC,HPKEY,ISTAT) B9000204^^ C WRITER PGMREC B9000205^^ 79 IF(ISTAT.LT.0) GO TO 8045 B9000206^^ C B9000207^^ C COMPLETED--GO CLOSE FILES + END JOB B9000208^^ 80 6190 GO TO 9000 B9000209^^ C B9000210^^ C********* FILE MANAGER ERROR PROCESSING B9000211^^ C B9000212^^ C B9000213^^ 81 8000 CALL FILERR(RPTPGM,13,ISTAT,LU) B9000214^t FTN 3.3B (OPT = LPC) PGGEN0 PAGE 5 DATE: 08/29/84 TIME: 2230 t^ 82 GO TO 8200 B9000215^^ C B9000216^^ 83 8010 CALL FILERR(RPTTBL,13,ISTAT,LU) B9000217^^ 84 GO TO 8200 B9000218^^ C B9000219^^ 85 8020 CALL FILERR(RPTWKE,11,ISTAT,LU) B9000220^^ 86 GO TO 8200 B9000221^^ C B9000222^^ 87 8030 CALL FILERR(RPTWKP,11,ISTAT,LU) B9000223^^ 88 GO TO 8200 B9000224^^ C B9000225^^ 89 8040 CALL FILERR(PRCWRK,11,ISTAT,LU) B9000226^^ 90 GO TO 8200 B9000227^^ C B9000228^^ 91 8045 CALL FILERR(RPTPGM,12,ISTAT,LU) B9000229^^ 92 GO TO 8200 B9000230^^ C B9000231^^ 93 8050 CALL FILERR(UTIFIL,15,ISTAT,LU) B9000232^^ 94 GO TO 8200 B9000233^^ C B9000234^^ C******** ERROR IN UTILITY FILE B9000235^^ C RPTG RECORD NOT FOUND OR B9000236^^ C REPORT PGM NAME IN RPTG RECORD INVALID, B9000237^^ C NOT RPT000-RPT019 B9000238^^ C B9000239^^ 95 8100 CALL WTREAD(LU,XYN,UTEMSG,52,ZERO,ZERO,ZERO,TC) B9000240^^ 96 GO TO 8200 B9000241^^ C B9000242^^ C DISPLAY MESSAGE AND WAIT FOR CARRIAGE RETURN B9000243^^ 97 8200 CALL WTREAD(LU,XYN,NT1MSG,52,0,0,0,TC) B9000244^^ 98 CALL WTREAD(LU,XYN,NT2MSG,46,XYN,OPBUF,30,TC) B9000245^^ 99 GO TO 8905 B9000246^^ C B9000247^^ C********* ABORT ERROR MESSAGE B9000248^^ C B9000249^^ C B9000250^^ 100 8900 CALL WTREAD(LU,XYN,ABTMSG,14,ZERO,ZERO,ZERO,TC) B9000251^^ C FORCE FILE CLOSURE ON ANY FILE OPEN B9000252^^ C BYPASS ANY ERROR B9000253^^ 101 8905 CALL CLOSFL(UTIRQB,ISTAT) B9000254^^ 102 CALL CLOSFL(DLQRQB,ISTAT) B9000255^^ 103 CALL CLOSFL(TBLRQB,ISTAT) B9000256^^ 104 CALL CLOSFL(PGMRQB,ISTAT) B9000257^^ 105 CALL CLOSFL(WKERQB,ISTAT) B9000258^^ 106 CALL CLOSFL(WKPRQB,ISTAT) B9000259^^ 107 CALL CLOSFL(PRCRQB,ISTAT) B9000260^^ 108 DO 8910 I = 1, 24 B9000261^^ 109 WKERQB(I) = 0 B9000262^^ 110 WKPRQB(I) = 0 B9000263^^ 111 8910 PRCRQB(I) = 0 B9000264^^ 112 CALL DELETE ( PRCRQB,PRCWRK,ISTAT ) B9000265^^ 113 CALL DELETE ( WKERQB,RPTWKE,ISTAT ) B9000266^^ 114 CALL DELETE ( WKPRQB,RPTWKP,ISTAT ) B9000267^^ 115 CALL CHAIN (MENU) B9000268^t FTN 3.3B (OPT = LPC) PGGEN0 PAGE 6 DATE: 08/29/84 TIME: 2230 t^ C B9000269^^ C B9000270^^ C********* NORMAL TERMINATION B9000271^^ C B9000272^^ 116 9000 CALL CLOSFL(UTIRQB,ISTAT) B9000273^^ 117 IF(ISTAT.GE.0) GO TO 9005 B9000274^^ 118 CALL FILERR(UTIFIL,4,ISTAT,LU) B9000275^^ 119 GO TO 8200 B9000276^^ 120 9005 CALL CLOSFL(DLQRQB,ISTAT) B9000277^^ 121 IF(ISTAT.GE.0) GO TO 9010 B9000278^^ 122 CALL FILERR(DELQM,4,ISTAT,LU) B9000279^^ 123 GO TO 8200 B9000280^^ 124 9010 CALL CLOSFL(TBLRQB,ISTAT) B9000281^^ 125 IF(ISTAT.GE.0) GO TO 9020 B9000282^^ 126 CALL FILERR(RPTTBL,4,ISTAT,LU) B9000283^^ 127 GO TO 8200 B9000284^^ 128 9020 CALL CLOSFL(PGMRQB,ISTAT) B9000285^^ 129 IF(ISTAT.GE.0) GO TO 9030 B9000286^^ 130 CALL FILERR(RPTPGM,4,ISTAT,LU) B9000287^^ 131 GO TO 8200 B9000288^^ 132 9030 CALL CLOSFL(WKERQB,ISTAT) B9000289^^ 133 IF(ISTAT.GE.0) GO TO 9040 B9000290^^ 134 CALL FILERR(RPTWKE,4,ISTAT,LU) B9000291^^ 135 GO TO 8200 B9000292^^ 136 9040 CALL CLOSFL(WKPRQB,ISTAT) B9000293^^ 137 IF(ISTAT.GE.0) GO TO 9050 B9000294^^ 138 CALL FILERR(RPTWKP,4,ISTAT,LU) B9000295^^ 139 GO TO 8200 B9000296^^ 140 9050 CALL CLOSFL(PRCRQB,ISTAT) B9000297^^ 141 IF(ISTAT.GE.0) GO TO 9100 B9000298^^ 142 CALL FILERR(PRCWRK,4,ISTAT,LU) B9000299^^ 143 GO TO 8200 B9000300^^ 144 9100 CALL PGMOUT B9000301^^ 145 END B9000302^t FTN 3.3B (OPT = LPC) PGGEN0 PAGE 7 DATE: 08/29/84 TIME: 2230 t COMMON  LABEL $0448 ( 1096)    PROGRAM LENGTH $0260 ( 608)   EXTERNALS 2 AMONTO ADAYTO AYERTO PGGEN1 PGGN2E PGGN2P PGGEN3 22 PGMIN OPENFL FILERR UPDREC CCSBLK CCSMVA WRITER 2& WTREAD CLOSFL DELETE CHAIN PGMOUT & t FTN 3.3B (OPT = LPC) PGGEN0 PAGE 8 DATE: 08/29/84 TIME: 2230 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < * 8010 (-32751) 0056 45,49,52,59*( 8020 (-32735) 0059 50,53,55 (" 8100 (-32511) 0057 46 "" 8900 (-30463) 0058 47 "( FFFF (65535) 005C 74,75,76 (j 0000 (0) 0001 8,15,17,21,25,29,33,37,41,65,79,97,109,110,111,117,121,125,129,133,137,141 j2 0001 (1) 0000 56,61,67,71,77,108 2@ 0003 (3) 0055 18,22,26,30,34,38,42,58,63,69,73 @: 0004 (4) 0065 118,122,126,130,134,138,142:( 000B (11) 005F 85,87,89 (" 000C (12) 0060 91 "( 000D (13) 005E 77,81,83 (" 000E (14) 0064 100"" 000F (15) 0061 93 "( 001E (30) 005D 77,77,98 (" 002E (46) 0063 98 "$ 0034 (52) 0062 95,97$" 0054 (84) 005B 70 "$ 5900 (22784) 005A 60,66$   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < & ABTMSG INTEGER 03E8 D 1,6,100&( AND INTR.FN. 7FFF 74,75,76 (" BIN INTEGER 0300 D 1,6"" COMMA INTEGER 0005 6,8"" CS INTEGER 03F1 D 1,6"" D1LNG INTEGER 0332 D 1,6"" D1TYPE INTEGER 0331 D 1,6", DELQM INTEGER 000F D 1,4,20,22,122,. DLQRQB INTEGER 0063 D 1,4,20,102,120 ." ERRMSG INTEGER 03B7 D 1,6" FILREQ INTEGER 0006 6 4 HPGMN INTEGER 02CD D 1,6,56,57,58,67,68,6948 HPKEY INTEGER 0302 D 1,6,67,68,69,71,72,73,78 82 I INTEGER 0053 14,108,109,110,111 2" IHOLD2 INTEGER 035E D 1,6" IMAXC INTEGER 041B D 1 " IND INTEGER 038A D 1,6"€ ISTAT INTEGER 0301 D 1,6,16,17,18,20,21,22,24,25,26,28,29,30,32,33,34,36,37,38,40,41,42,64,65,78,79,81,83,85,87,89,91,€‚ 93,101,102,103,104,105,106,107,112,113,114,116,117,118,120,121,122,124,125,126,128,129,130,132,133 ‚< ,134,136,137,138,140,141,142 <t FTN 3.3B (OPT = LPC) PGGEN0 PAGE 9 DATE: 08/29/84 TIME: 2230 t$ J INTEGER 0054 14,15$" LRPGWK INTEGER 0334 D 1,6"v LU INTEGER 041A D 1,14,18,22,26,30,34,38,42,81,83,85,87,89,91,93,95,97,98,100,118,122,126,130,134,138,142v( MENU INTEGER 001E 6,11,115 ( NLKEY INTEGER 041C D 1 NNAME INTEGER 041D D 1 NSKEY INTEGER 041E D 1 NSLCT INTEGER 041F D 1 & NT1MSG INTEGER 0022 6,9,97 && NT2MSG INTEGER 003C 6,10,98& NTFLDS INTEGER 0420 D 1 & OPBUF INTEGER 00C3 D 1,5,98 &" OPHLD INTEGER 0330 D 1,6", PGMKEY INTEGER 02FA D 1,6,61,62,63 ,> PGMREC INTEGER 0360 D 1,6,70,71,72,73,74,75,76,77,78 >0 PGMRQB INTEGER 0093 D 1,4,32,78,104,1280" PRCREC INTEGER 038D D 1,6"6 PRCRQB INTEGER 0402 D 1,4,28,107,111,112,140 64 PRCWRK INTEGER 03F3 D 1,4,28,30,89,112,142 4( Q2SAVE INTEGER 00E3 D 1,5,60,66(" Q3SORT INTEGER 00E4 D 1,5"" Q4LVLB INTEGER 0120 D 1,5"" Q5ANS INTEGER 02C8 D 1,5"" Q5SLCT INTEGER 0129 D 1,5"" Q6EPOS INTEGER 0253 D 1,5"" Q6NAME INTEGER 01D3 D 1,5"" Q6TOT INTEGER 0206 D 1,5"& Q7RPT INTEGER 02B9 D 1,5,77 &: RADDR INTEGER 0305 D 1,6,45,46,47,49,50,52,53,55:" RPTG INTEGER 0002 6,8"2 RPTPGM INTEGER 002D D 1,4,32,34,81,91,13020 RPTTBL INTEGER 001E D 1,4,24,26,83,126 04 RPTWKE INTEGER 003C D 1,4,36,38,85,113,134 44 RPTWKP INTEGER 0421 D 1,4,40,42,87,114,138 4& TBL INTEGER 02C9 D 1,6,14 &" TBLKEY INTEGER 02FD D 1,6"" TBLREC INTEGER 0306 D 1,6". TBLRQB INTEGER 007B D 1,4,24,103,124 .0 TC INTEGER 03F0 D 1,6,95,97,98,100 0& UTEMSG INTEGER 03CE D 1,6,95 &0 UTIFIL INTEGER 0000 D 1,4,16,18,93,118 00 UTIRQB INTEGER 004B D 1,4,16,64,101,1160: UTREC INTEGER 02D0 D 1,6,56,57,58,59,61,62,63,64:6 WKERQB INTEGER 00AB D 1,4,36,105,109,113,132 66 WKPRQB INTEGER 0430 D 1,4,40,106,110,114,136 60 XYN INTEGER 03EF D 1,6,95,97,98,100 0* ZERO INTEGER 0004 6,8,95,100 *t FTN 3.3B (OPT = LPC) PGGEN0 PAGE 10 DATE: 08/29/84 TIME: 2230 t   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " CCSBLK SUBROUTINE 0142 69 "" CCSMVA SUBROUTINE 015E 76 "" CHAIN SUBROUTINE 01FA 114"V CLOSFL SUBROUTINE 023D 101,102,103,104,105,106,107,116,120,124,128,132,136,140V* DELETE SUBROUTINE 01ED 111,113,114*d FILERR SUBROUTINE 0204 17,22,26,30,34,38,42,81,83,85,87,89,91,93,118,122,126,130,134,138,142d4 OPENFL SUBROUTINE 0072 15,20,24,28,32,36,40 4$ PGGEN1 SUBROUTINE 00D7 11,44$$ PGGEN3 SUBROUTINE 0104 11,54$$ PGGN2E SUBROUTINE 00EC 11,48$$ PGGN2P SUBROUTINE 00F9 11,51$" PGMIN SUBROUTINE 0067 11 "" PGMOUT SUBROUTINE 0258 144"" UPDREC SUBROUTINE 012B 64 "" WRITER SUBROUTINE 0166 77 ", WTREAD SUBROUTINE 019D 95,97,98,100 ,   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 1000 0082 17,20$$ 1010 0090 21,24$$ 1020 009E 25,28$$ 1030 00AC 29,32$$ 1040 00BA 33,36$$ 1050 00C8 37,40$$ 2000 00D6 41,44$" 6000 0119 59 "$ 6050 012A 60,64$" 6100 0138 66 "$ 6190 016F 66,80$$ 8000 0171 45,81$( 8010 0178 49,52,83 ($ 8020 017E 50,85$$ 8030 0184 53,87$$ 8040 018A 55,89$$ 8045 0190 79,91$$ 8050 0196 65,93$$ 8100 019C 46,95$j 8200 01A7 18,23,27,31,35,39,43,82,84,86,88,90,92,94,96,97,119,123,127,131,135,139,143j( 8900 01BB 15,47,100(& 8905 01C4 98,101 && 8910 01E3 107,111&& 9000 01FC 80,116 &t FTN 3.3B (OPT = LPC) PGGEN0 PAGE 11 DATE: 08/29/84 TIME: 2230 t& 9005 020A 117,120&& 9010 0216 121,124&& 9020 0222 125,128&& 9030 022F 129,132&& 9040 023C 133,136&& 9050 024A 137,140&& 9100 0257 141,144& PGGEN0 025B 1  t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 1 DATE: 08/29/84 TIME: 2231 t^ 1 SUBROUTINE PGGEN1 B9100001^^ 1 1 /B91 F CCS CCS 3.0 PSR 03/23/81 SL-149********^^ * B9100003^^ * CYBERCREDIT SYSTEM VERSION 3 B9100004^^ * DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B9100005^^ * COPYRIGHT CONTROL DATA CORPORATION, 1979 B9100006^^ * B9100007^^ C OPERATOR COMMUNICATION FOR GENERATED RPG PGM B9100008^^ C B9100009^^ 2 COMMON /CBLK1/UTIFIL,DELQM,RPTTBL,RPTPGM,RPTWKE,UTIRQB,DLQRQB, B9100010^^ 2 2TBLRQB,PGMRQB,WKERQB,OPBUF,Q2SAVE,Q3SORT,Q4LVLB,Q5SLCT,Q6NAME, B9100011^^ 2 3Q6TOT,Q6EPOS,Q7RPT,Q5ANS,TBL,HPGMN,UTREC,PGMKEY,TBLKEY,BIN,ISTAT, B9100012^^ 2 4HPKEY,RADDR,TBLREC,OPHLD,D1TYPE,D1LNG,LRPGWK,IHOLD2,PGMREC,IND, B9100013^^ 2 5PRCREC,ERRMSG,UTEMSG,ABTMSG,XYN,TC,CS,PRCWRK,PRCRQB,LU B9100014^^ 3 COMMON /CBLK1/IMAXC,NLKEY,NNAME,NSKEY,NSLCT,NTFLDS,RPTWKP,WKPRQB B9100015^^ C B9100016^^ C FILE RETRIEVAL B9100017^^ 4 INTEGER UTIFIL(15),DELQM(15),RPTTBL(15),RPTPGM(15),RPTWKE(15), B9100018^^ 4 2 UTIRQB(24),DLQRQB(24),TBLRQB(24),PGMRQB(24),WKERQB(24), B9100019^^ 4 3 PRCWRK(15),PRCRQB(24),RPTWKP(15),WKPRQB(24) B9100020^^ C B9100021^^ C OPERATOR RESPONSES B9100022^^ 5 INTEGER OPBUF(32),Q2SAVE,Q3SORT(60),Q4LVLB(9),Q5SLCT(170), B9100023^^ 5 2 Q6NAME(51),Q6TOT(77),Q6EPOS(102),Q7RPT(15),Q5ANS B9100024^^ C B9100025^^ C MISCELLANEOUS B9100026^^ 6 INTEGER XYN,TC,CS(2),TBL(4),HPGMN(3),RPTG(2),UTREC(42),ISTAT, B9100027^^ 6 2 ZERO,PGMKEY(3),TBLKEY(3),COMMA,BIN,HPKEY(3),RADDR,TBLREC(42), B9100028^^ 6 3 OPHLD,D1TYPE,D1LNG(2),LRPGWK(42),IHOLD2(2),PGMREC(42),IND(3), B9100029^^ 6 4 PRCREC(42),ERRMSG(23),UTEMSG(26),ABTMSG(7) B9100030^^ C B9100031^^ C****DIMENSION B9100032^^ C FOR OPERATOR MESSAGES B9100033^^ C B9100034^^ 7 DIMENSION MSG1(20),MSG2(24),MSG3(108),MSG4(71),MSG5(20), B9100035^^ CSPEC REVERSE DATES YYMMDD ********^^ 7 2 MSG5A(70),MSG5B(24),MSG5C(27),MSG5D(93),MSG6(83), ********^^ CSPEC END ********^^ 7 3 MSG7(21),MSG7A(43),MSGG1(4),MSG5A0(54) B9100037^^ 8 DIMENSION MSGE01(15),MSGE02(38),MSGE03(37),MSGE04(23),MSGE05(19), B9100038^^ 8 2 MSGE06(25),MSGE07(24),MSGE08(33),MSGE09(33),MSGE10(35),B9100039^^ 8 3 MSGE11(28),MSGE12(26),MSGE13(18),MSGE14(23),MSGE15(37),B9100040^^ 8 4 MSGE16(21),MSGE17(30),MSGE18(27) B9100041^^ C B9100042^^ C B9100043^^ C MESSAGES TO THE OPERATOR B9100044^^ 9 DATA MSG1 /$D0A,'PRINT DATA NAME LIST? ENTER Y OR N',$D0A/ B9100045^^ 10 DATA MSG2 /$D0A,'SAVE GENERATED REPORT PROGRAM? ENTER Y OR N', B9100046^^ 10 2$D0A/ B9100047^^ 11 DATA MSG3 /$D0A,'ENTER SORT FIELD NAME (KEY1,A,KEY2,D (CR)) ', B9100048^^ 11 2' ',$D0A,' MAJOR TO MINOR A(ASCENDING) OR D(DESCENDING)',$D0A,B9100049^^ 11 3' MAX OF 3 NAMES PER LINE',$D0A,'ENTER REPEAT TO REENTER ALL SORB9100050^^ 11 4T FIELDS OR',$D0A,'ENTER C TO CONTINUE OR',$D0A,'ENTER A TO ABORB9100051^^ 11 5T',$D0A/ B9100052^t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 2 DATE: 08/29/84 TIME: 2231 t^ 12 DATA MSG4 /$D0A,'ENTER LEVEL BREAK NAMES (LVL1,LVL2,LVL3 (CR)) ORB9100053^^ 12 2',$D0A,'ENTER REPEAT TO REENTER ALL LEVEL BREAKS OR',$D0A,'ENTER B9100054^^ 12 3C TO CONTINUE OR',$D0A,'ENTER A TO ABORT',$D0A/ B9100055^^ 13 DATA MSG5 /$D0A,'SELECT RECORDS. ENTER ALL OR (CR) ',$D0A/ B9100056^^ 14 DATA MSG5A0 /$D0A,'ENTER Y IF ALL CONDITIONS MUST BE MET FOR SELEB9100057^^ 14 2CTION',$D0A,'ENTER N IF 1 CONDITION IS SUFFICIENT FOR SELECTION', B9100058^^ 14 3$D0A/ B9100059^^ 15 DATA MSG5A /$D0A,'ENTER OPERATION (EQ,NE,GT,LT,GE,LE,RANGE (CR)) B9100060^^ 15 2OR ',$D0A,'ENTER REPEAT TO REENTER ALL SELECTIONS OR',$D0A,'ENTERB9100061^^ 15 3 C TO CONTINUE OR',$D0A,'ENTER A TO ABORT',$D0A/ B9100062^^ 16 DATA MSG5B /$D0A,'ENTER DATA NAME FOR COMPARISON (NAME1 (CR))', B9100063^^ 16 2$D0A/ B9100064^^ 17 DATA MSG5C /$D0A,'IS 2ND COMPARISON FIELD A DATA NAME? ENTER Y OB9100065^^ 17 2R N',$D0A/ B9100066^^ 18 DATA MSG5D /$D0A,'ENTER COMPARISON VALUE (VALUE1 (CR)) OR ',$D0A,B9100067^^ 18 2'ENTER RANGE (VALUE1,VALUE2 (CR)) OR',$D0A,'ENTER 2ND DATA NAME (B9100068^^ CPEC REVERSE DATES YYMMDD ********^^ 18 3NAME2 (CR) ',$D0A,' NOTE - DATE FIELDS MUST BE IN YEAR, MONTH, DA********^^ 18 4Y ORDER, I.E. YYMMDD ',$D0A/ ********^^ CSPEC END ********^^ 19 DATA MSG6 /$D0A,'ENTER DATA NAMES FOR RPT (NAME1,NAME2 (CR)) OR',B9100070^^ 19 2$D0A,' MAX OF 3 NAMES PER LINE',$D0A,'ENTER REPEAT TO REENTER ALB9100071^^ 19 3L DATA NAMES OR',$D0A,'ENTER C TO CONTINUE OR',$D0A, B9100072^^ 19 4'ENTER A TO ABORT',$D0A/ B9100073^^ 20 DATA MSG7 /$D0A,'ENTER REPORT TITLE - 30 CHARACTERS MAX',$D0A/ B9100074^^ 21 DATA MSG7A /$D0A,'ENTER REPEAT TO REENTER REPORT TITLE OR ', B9100075^^ 21 2$D0A,'ENTER C TO CONTINUE OR',$D0A,'ENTER A TO ABORT',$D0A/ B9100076^^ C B9100077^^ C ERROR MESSAGES TO THE OPERATOR B9100078^^ 22 DATA MSGE01 /$D0A,'INVALID RESPONSE REENTER',$D0A/ B9100079^^ 23 DATA MSGE02 /$D0A,'NO PGM NAMES AVAIL',$D0A,'CAN NOT SAVE UNTIL RPB9100080^^ 23 2TPGM IS PURGED',$D0A,'RPT000 IS USED',$D0A/ B9100081^^ 24 DATA MSGE03 /$D0A,'LAST PGM NAME AVAIL.',$D0A,'PURGE RPTPGM BEFORB9100082^^ 24 2E ANY OTHER PROGRAM IS SAVED',$D0A/ B9100083^^ 25 DATA MSGE04 /$D0A,'INVALID NAME XXXXXX',$D0A,'REENTER ENTIRE L', B9100084^^ 25 2'INE',$D0A/ B9100085^^ 26 DATA MSGE05 /$D0A,'NAME EXCEEDS 6 CHARACTERS REENTER',$D0A/ B9100086^^ 27 DATA MSGE06 /$D0A,'EXCEEDS MAX OF 3 PER LINE-1ST 3 ONLY PROCESS', B9100087^^ 27 2'ED',$D0A/ B9100088^^ 28 DATA MSGE07 /$D0A,'NAME MUST BE FOLLOWED BY AN A OR D REENTER', B9100089^^ 28 2$D0A/ B9100090^^ 29 DATA MSGE08 /$D0A,'# OF SORT FIELDS EXCEEDS THE MAX OF 10',$D0A,'EB9100091^^ 29 2NTER REPEAT OR C OR A',$D0A/ B9100092^^ 30 DATA MSGE09 /$D0A,'# OF LEVEL BREAKS EXCEEDS THE MAX OF 3',$D0A, B9100093^^ 30 2'ENTER REPEAT OR C OR A',$D0A/ B9100094^^ 31 DATA MSGE10 /$D0A,'# OF OPERATION CODES EXCEEDS THE MAX OF 10', B9100095^^ 31 2$D0A,'ENTER REPEAT OR C OR A',$D0A/ B9100096^^ 32 DATA MSGE11 /$D0A,'VALUE DOES NOT CORRESPOND TO DATA NAME DESC REB9100097^^ 32 2ENTER',$D0A/ B9100098^^ 33 DATA MSGE12 /$D0A,'VALUE EXCEEDS THE MAX OF 13 CHARACTERS REENTERB9100099^^ 33 2',$D0A/ B9100100^^ 34 DATA MSGE13 /$D0A,'INVALID OPERATION CODE REENTER',$D0A/ B9100101^^ 35 DATA MSGE14 /$D0A,'VALUE 2 NOT GREATER THAN VALUE 1 REENTER', B9100102^^ 35 2$D0A/ B9100103^t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 3 DATE: 08/29/84 TIME: 2231 t^ 36 DATA MSGE15 /$D0A,'DATA EXCEEDS PRINT POSITIONS AVAILABLE ON RPT B9100104^^ 36 2REENTER ALL DATA NAMES ',$D0A/ B9100105^^ 37 DATA MSGE16/$D0A,'QUOTE ILLEGAL IN REPORT TITLE REENTER',$D0A/ B9100106^^ 38 DATA MSGE17 /$D0A,'2 VALUES NOT VALID UNLESS OPERATION CODE IS RA B9100107^^ 38 2 REENTER',$D0A/ B9100108^^ 39 DATA MSGE18/$D0A,'MUST ENTER 2 VALUES FOR OPERATION CODE RA REENTB9100109^^ 39 2ER',$D0A/ B9100110^^ 40 DATA MSGG1 /$D0A,'NEXT',$D0A/ B9100111^^ C B9100112^^ C MESSAGE LENGTHS B9100113^^ 41 DATA LNG1/40/,LNG2/48/,LNG3/216/,LNG4/142/,LNG5/40/,LNG5A/140/, B9100114^^ 41 2 LNG5B/48/,LNG5C/54/,LNG6/166/,LNG7/42/,LNG7A/86/,LNGOP/56/, B9100115^^ CSPEC REVERSE DATES YYMMDD ********^^ 41 3 LNG5D/186/,LNG5A0/108/ ********^^ CSPEC END ********^^ 42 DATA LNGE01/30/,LNGE02/76/,LNGE03/74/,LNGE04/46/,LNGE05/38/, B9100117^^ 42 2 LNGE07/48/,LNGE08/66/,LNGE09/66/,LNGE10/70/, B9100118^^ 42 3 LNGE11/56/,LNGE12/52/,LNGE13/36/,LNGE14/46/,LNGE15/74/, B9100119^^ 42 4 LNGE06/50/,LNGG1/8/,LNGE16/42/,LNGE17/60/,LNGE18/54/ B9100120^^ C B9100121^^ 43 DATA RPTG/'RPTG'/,ZERO/0/,COMMA/$002C/ B9100122^^ C B9100123^^ 44 EXTERNAL PGSLST,PGSEDT,PGSJR,PGSJL,BINASC,ASCBIN B9100124^^ C********* B9100125^^ C BEGIN OPERATOR COMMUNICATION B9100126^^ C NEED 7 PARAMETERS FROM THE OPERATOR TO GENERATOR THE RPG PGM B9100127^^ 45 DO 1000 I=1,7 B9100128^^ 46 IF (I.EQ.1) GO TO 100 B9100129^^ 47 IF (I.EQ.2) GO TO 200 B9100130^^ 48 IF (I.EQ.3) GO TO 600 B9100131^^ 49 IF (I.EQ.4) GO TO 300 B9100132^^ 50 IF (I.EQ.5) GO TO 400 B9100133^^ 51 IF (I.EQ.6) GO TO 500 B9100134^^ 52 GO TO 700 B9100135^^ C B9100136^^ C B9100137^^ C B9100138^^ C B9100139^^ C B9100140^^ C**** IS A DATA NAME LIST REQUIRED? B9100141^^ C DISPLAY QUESTION/ACCEPT ANSWER B9100142^^ 53 100 CALL WTREAD(LU,XYN,MSG1,LNG1,XYN,OPBUF,5,TC) B9100143^^ C ANSWER IS N, GO TO NEXT QUESTION B9100144^^ 54 IF (AND($FF00,OPBUF(1)).EQ.$4E00) GO TO 1000 B9100145^^ C INVALID ANSWER-NEITHER Y NOR N-ASK AGAIN B9100146^^ 55 IF (AND($FF00,OPBUF(1)).NE.$5900) GO TO 100 B9100147^^ C ANSWER IS Y, CALL SUBROUTINE TO PRINT DATA LIST B9100148^^ 56 CALL PGSLST B9100149^^ 57 GO TO 1000 B9100150^^ C B9100151^^ C B9100152^^ C B9100153^^ C**** IS THE GENERATED PGM TO BE SAVED B9100154^^ C DISPLAY QUESTION/ACCEPT ANSWER B9100155^t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 4 DATE: 08/29/84 TIME: 2231 t^ 58 200 CALL WTREAD(LU,XYN,MSG2,LNG2,XYN,OPBUF,5,TC) B9100156^^ 59 CALL READR(UTIRQB,UTREC,RPTG,ISTAT) B9100157^^ C CHECK FOR FILE ERROR B9100158^^ 60 IF (ISTAT.LT.0) GO TO 1100 B9100159^^ 61 Q2SAVE=AND($FF00,OPBUF(1)) B9100160^^ C ANSWER IS N, GO TO NEXT QUESTION B9100161^^ 62 IF (Q2SAVE.EQ.$4E00) GO TO 1000 B9100162^^ C INVALID ANSWER-NEITHER Y NOR N-ASK AGAIN B9100163^^ 63 IF (Q2SAVE.NE.$5900) GO TO 200 B9100164^^ C ANSWER IS Y--GET NEXT AVAIL PGM NAME, IN UTIFIL B9100165^^ C CHECK FOR VALID PGM NAME--RPT000-RPT019 B9100166^^ 64 IF (UTREC(4).NE.$5250) GO TO 1100 B9100167^^ 65 IF (UTREC(5).NE.$5430) GO TO 1100 B9100168^^ 66 IF (UTREC(6).LT.$3030.OR.UTREC(6).GT.$3139) GO TO 1100 B9100169^^ C CHECK FOR PGM NAME OF RPT000 B9100170^^ 67 IF (UTREC(6).NE.$3030) GO TO 210 B9100171^^ C WRITE ERROR MSG--NO PGM NAMES AVAILABLE B9100172^^ 68 CALL WTREAD(LU,XYN,MSGE02,LNGE02,ZERO,ZERO,ZERO,TC) B9100173^^ 69 Q2SAVE=$4E00 B9100174^^ 70 GO TO 1000 B9100175^^ C SAVE NEW PGM NAME B9100176^^ 71 210 HPGMN(1)=UTREC(4) B9100177^^ 72 HPGMN(2)=UTREC(5) B9100178^^ 73 HPGMN(3)=UTREC(6) B9100179^^ C GET NEXT AVAIL PGM NAME B9100180^^ 74 PGMKEY(1)=HPGMN(1) B9100181^^ 75 PGMKEY(2)=HPGMN(2) B9100182^^ 76 PGMKEY(3)=HPGMN(3) B9100183^^ C SET UP LOOP TO READ RPTPGM FILE - MAX 19 RECORDS B9100184^^ C IF KEY NOT FOUND, PGM NAME IS AVAIL B9100185^^ C AND UTIFIL CAN BE UPDATED B9100186^^ 77 DO 220 K=1,19 B9100187^^ C FORCE PGM NAME TO RPT000 IF EQUALS RPT019 B9100188^^ 78 IF (PGMKEY(3).EQ.$3139) PGMKEY(3)=$3030 B9100189^^ C CONVERT TO BINARY AND INCREMENT B9100190^^ 79 CALL ASCBIN(PGMKEY(3),BIN) B9100191^^ 80 BIN=BIN+1 B9100192^^ C CONVERT BACK TO ASCII B9100193^^ 81 CALL BINASC(BIN,IHOLD2) B9100194^^ 82 PGMKEY(3)=IHOLD2(2) B9100195^^ C RETRIEVE RECORD IF IT EXISTS B9100196^^ 83 HPKEY(1)=PGMKEY(1) B9100197^^ 84 HPKEY(2)=PGMKEY(2) B9100198^^ 85 HPKEY(3)=PGMKEY(3) B9100199^^ 86 CALL READR(PGMRQB,PGMREC,HPKEY,ISTAT) B9100200^^ C CHECK FOR RECORD FOUND B9100201^^ C***********************************************************A040*??? ********^^ 87 IF(AND(ISTAT,$300).NE.0) GO TO 1000 ********^^ 88 IF(ISTAT.LT.0) GO TO 1010 ********^^ C**********************************************************A040*??? ********^^ 89 220 CONTINUE B9100203^^ C NO PGM NAMES AVAIL B9100204^^ 90 CALL WTREAD(LU,XYN,MSGE03,LNGE03,ZERO,ZERO,ZERO,TC) B9100205^^ 91 PGMKEY(2)=$5430 B9100206^t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 5 DATE: 08/29/84 TIME: 2231 t^ 92 PGMKEY(3)=$3030 B9100207^^ 93 Q2SAVE=$4E00 B9100208^^ 94 GO TO 1000 B9100209^^ C************** 3 LINES DELETED ***************************A040*??? ********^^ C B9100213^^ C B9100214^^ C B9100215^^ C**** GET SORT KEYS FROM THE OPERATOR B9100216^^ C DISPLAY QUESTION/ACCEPT ANSWER B9100217^^ C B9100218^^ 95 300 CALL CCSBLK(OPBUF,32) B9100219^^ 96 CALL WTREAD(LU,XYN,MSG3,LNG3,XYN,OPBUF,30,TC) B9100220^^ C CHECK FOR REPEAT, C OR A RESPONSE B9100221^^ 97 ASSIGN 300 TO RADDR B9100222^^ C INITIALIZE SORT PARAMETER HOLD AREA B9100223^^ 98 CALL CCSBLK(Q3SORT,120) B9100224^^ C SORT KEYS WERE ENTERED B9100225^^ 99 NSKEY=0 B9100226^^ 100 IR=0 B9100227^^ 101 CALL PGSEDT(IR,OPBUF) B9100228^^ 102 IF (IR.EQ.2) ASSIGN 1000 TO RADDR B9100229^^ 103 IF (IR.EQ.3) ASSIGN 1900 TO RADDR B9100230^^ 104 IF (IR.NE.0) GO TO RADDR B9100231^^ C NEW INPUT LINE B9100232^^ 105 308 N=0 B9100233^^ 106 L=0 B9100234^^ 107 OPHLD=OPBUF(16) B9100235^^ C NEW SORT KEY B9100236^^ C CHECK FOR CARRIAGE RETURN B9100237^^ 108 310 IF (OPHLD.LE.0) GO TO 380 B9100238^^ C CHECK # SORT FIELDS ALREADY ENTERED B9100239^^ 109 IF ((NSKEY+N).LT.10) GO TO 312 B9100240^^ C TOO MANY SORT FIELDS B9100241^^ 110 NSKEY=NSKEY+N+1 B9100242^^ 111 CALL CCSBLK(OPBUF,32) B9100243^^ 112 CALL WTREAD(LU,XYN,MSGE08,LNGE08,XYN,OPBUF,30,TC) B9100244^^ 113 GO TO 390 B9100245^^ C CHECK # SORT FIELDS THIS LINE B9100246^^ 114 312 IF (N.LT.3) GO TO 315 B9100247^^ C ERROR MORE THAN 3 SORT KEYS THIS LINE B9100248^^ 115 CALL WTREAD(LU,XYN,MSGE06,LNGE06,ZERO,ZERO,ZERO,TC) B9100249^^ 116 GO TO 380 B9100250^^ C SET UP KEY FOR RETRIEVE B9100251^^ 117 315 HPKEY(1)=$2020 B9100252^^ 118 HPKEY(2)=$2020 B9100253^^ 119 HPKEY(3)=$2020 B9100254^^ 120 DO 316 K=1,6 B9100255^^ 121 IPOS=K+L B9100256^^ 122 IHOLD=$0000 B9100257^^ 123 CALL CCSGET(OPBUF,IPOS,IHOLD) B9100258^^ 124 IF (IHOLD.EQ.COMMA) GO TO 317 B9100259^^ 125 CALL CCSPUT(IHOLD,K,HPKEY) B9100260^^ 126 316 CONTINUE B9100261^^ 127 317 KL=K B9100262^t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 6 DATE: 08/29/84 TIME: 2231 t^ C SAVE KEY FOR ERROR MSG IF NECESSARY B9100263^^ 128 MSGE04(9) =HPKEY(1) B9100264^^ 129 MSGE04(10)=HPKEY(2) B9100265^^ 130 MSGE04(11)=HPKEY(3) B9100266^^ C RETRIEVE RPTTBL RECORD B9100267^^ 131 CALL READR(TBLRQB,TBLREC,HPKEY,ISTAT) B9100268^^ C CHECK FOR FILE ERROR B9100269^^ 132 IF (ISTAT.EQ.0.AND.AND(TBLREC(40),$20FF).NE.$2044) GO TO 320 B9100270^^ C RECORD NOT FOUND B9100271^^ 133 CALL CCSBLK(OPBUF,32) B9100272^^ 134 CALL WTREAD(LU,XYN,MSGE04,LNGE04,XYN,OPBUF,30,TC) B9100273^^ 135 GO TO 390 B9100274^^ 136 320 CONTINUE B9100275^^ C CHECK--MUST BE A DATA NAME ENTERED FOR THE RPG RPT B9100276^^ 137 IPOS=1 B9100277^^ 138 DO 330 M=1,NNAME B9100278^^ 139 CALL CCSCST(Q6NAME,IPOS,6,MSGE04,17,6,IHOLD) B9100279^^ 140 IF (IHOLD.EQ.0) GO TO 335 B9100280^^ 141 IPOS=IPOS+6 B9100281^^ 142 330 CONTINUE B9100282^^ 143 CALL CCSBLK(OPBUF,32) B9100283^^ C ERROR MSG B9100284^^ 144 CALL WTREAD(LU,XYN,MSGE04,LNGE04,XYN,OPBUF,30,TC) B9100285^^ 145 GO TO 390 B9100286^^ C CHECK FOR A OR D B9100287^^ 146 335 K=L+KL+1 B9100288^^ 147 IHOLD=$0000 B9100289^^ 148 CALL CCSGET(OPBUF,K,IHOLD) B9100290^^ 149 IF (IHOLD.EQ.$0041.OR.IHOLD.EQ.$0044) GO TO 340 B9100291^^ C ERROR NOT AN A OR D B9100292^^ 150 CALL CCSBLK(OPBUF,32) B9100293^^ 151 CALL WTREAD(LU,XYN,MSGE07,LNGE07,XYN,OPBUF,30,TC) B9100294^^ 152 GO TO 390 B9100295^^ C STORE KEY IN Q3SORT A/D,KEYNAME ,A/D...B9100296^^ C CALCULATE POSITION IN Q3SORT 1ST B9100297^^ C B9100298^^ 153 340 IPOS=((NSKEY+N)*12)+1 B9100299^^ C A/D B9100300^^ 154 CALL CCSPUT(IHOLD,IPOS,Q3SORT) B9100301^^ 155 IPOS=IPOS+1 B9100302^^ C COMMA B9100303^^ 156 CALL CCSPUT(COMMA,IPOS,Q3SORT) B9100304^^ C STARTING POSITION,LENGTH B9100305^^ 157 DO 350 ICOL=1,6 B9100306^^ 158 CALL CCSGET(TBLREC,ICOL,IHOLD) B9100307^^ 159 IPOS=IPOS+1 B9100308^^ 160 CALL CCSPUT(IHOLD,IPOS,Q3SORT) B9100309^^ 161 350 CONTINUE B9100310^^ C PUT TRAILING COMMA IN Q3SORT B9100311^^ 162 IPOS=IPOS+4 B9100312^^ 163 CALL CCSPUT(COMMA,IPOS,Q3SORT) B9100313^^ C INCREMENT # SORT KEYS THE INPUT LINE B9100314^^ 164 N=N+1 B9100315^^ C INCREMENT INPUT BUFFER POINTER TO NEXT KEYB9100316^t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 7 DATE: 08/29/84 TIME: 2231 t^ 165 L=L+KL+2 B9100317^^ C CHECK NEXT SORT KEY B9100318^^ C SUBTRACT FROM CHAR COUNT FOR (CR) TEST B9100319^^ 166 OPHLD=OPHLD-KL-2 B9100320^^ 167 GO TO 310 B9100321^^ C GET NEXT INPUT LINE B9100322^^ 168 380 NSKEY=NSKEY+N B9100323^^ 169 CALL CCSBLK(OPBUF,32) B9100324^^ 170 CALL WTREAD(LU,XYN,MSGG1,LNGG1,XYN,OPBUF,30,TC) B9100325^^ C EDIT FOR REPEAT C OR A B9100326^^ C IF NONE--CHECK NEW INPUT LINE FOR KEYS B9100327^^ C C--GO TO NEXT MSG (1000) B9100328^^ C REPEAT--GO TO BEG OF MSG (300) B9100329^^ C A--ABORT B9100330^^ 171 390 CALL PGSEDT(IR,OPBUF) B9100331^^ 172 IF (IR.EQ.2) ASSIGN 1000 TO RADDR B9100332^^ 173 IF (IR.EQ.3) ASSIGN 1900 TO RADDR B9100333^^ 174 IF (IR.NE.0) GO TO RADDR B9100334^^ 175 GO TO 308 B9100335^^ C B9100336^^ C B9100337^^ C**** GET LEVEL BREAKS FROM OPERATOR B9100338^^ C DISPLAY QUESTION/ACCEPT ANSWER B9100339^^ C B9100340^^ 176 400 CALL CCSBLK(OPBUF,32) B9100341^^ 177 CALL WTREAD(LU,XYN,MSG4,LNG4,XYN,OPBUF,30,TC) B9100342^^ C INITIALIZE LEVEL BREAK PARAMETER B9100343^^ 178 CALL CCSBLK(Q4LVLB,18) B9100344^^ 179 NLKEY=0 B9100345^^ C CHECK FOR A REAPEAT, C OR A RESPONSE B9100346^^ 180 ASSIGN 400 TO RADDR B9100347^^ 181 IR=0 B9100348^^ 182 CALL PGSEDT(IR,OPBUF) B9100349^^ 183 IF (IR.EQ.2) ASSIGN 1000 TO RADDR B9100350^^ 184 IF (IR.EQ.3) ASSIGN 1900 TO RADDR B9100351^^ 185 IF (IR.NE.0) GO TO RADDR B9100352^^ C INITIALIZE-NEW INPUT LINE B9100353^^ 186 408 N=0 B9100354^^ 187 L=0 B9100355^^ 188 OPHLD=OPBUF(16) B9100356^^ C NEW LEVEL BREAK B9100357^^ 189 410 IF (OPHLD.LE.0) GO TO 480 B9100358^^ C CHECK # OF LEVEL FIELDS ALREADY ENTERED B9100359^^ 190 IF ((NLKEY+N).LT.3) GO TO 412 B9100360^^ C ERROR TOO MANY LEVEL BREAKS B9100361^^ 191 NLKEY=NLKEY+N+1 B9100362^^ 192 CALL CCSBLK(OPBUF,32) B9100363^^ 193 CALL WTREAD(LU,XYN,MSGE09,LNGE09,XYN,OPBUF,30,TC) B9100364^^ 194 GO TO 490 B9100365^^ C CHECK # OF LEVEL BREAKS THIS LINE B9100366^^ 195 412 IF (N.LT.3) GO TO 415 B9100367^^ C ERROR MORE THAN 3 LEVEL BREAKS THIS LINE B9100368^^ 196 CALL WTREAD(LU,XYN,MSGE06,LNGE06,ZERO,ZERO,ZERO,TC) B9100369^^ 197 GO TO 480 B9100370^t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 8 DATE: 08/29/84 TIME: 2231 t^ C SET UP KEY FOR RETRIEVE B9100371^^ 198 415 HPKEY(1)=$2020 B9100372^^ 199 HPKEY(2)=$2020 B9100373^^ 200 HPKEY(3)=$2020 B9100374^^ 201 DO 416 K=1,6 B9100375^^ 202 IPOS=K+L B9100376^^ 203 IHOLD=$0000 B9100377^^ 204 CALL CCSGET(OPBUF,IPOS,IHOLD) B9100378^^ 205 IF (IHOLD.EQ.COMMA) GO TO 417 B9100379^^ 206 CALL CCSPUT(IHOLD,K,HPKEY) B9100380^^ 207 416 CONTINUE B9100381^^ 208 417 KL=K B9100382^^ C SAVE KEY FOR ERROR MSG IF NECESSARY B9100383^^ 209 MSGE04(9) =HPKEY(1) B9100384^^ 210 MSGE04(10)=HPKEY(2) B9100385^^ 211 MSGE04(11)=HPKEY(3) B9100386^^ C RETRIEVE RPTTBL RECORD B9100387^^ 212 CALL READR(TBLRQB,TBLREC,HPKEY,ISTAT) B9100388^^ C CHECK FOR FILE ERROR B9100389^^ 213 IF (ISTAT.EQ.0.AND.AND(TBLREC(40),$20FF).NE.$2044) GO TO 420 B9100390^^ C RECORD NOT FOUND B9100391^^ 214 CALL CCSBLK(OPBUF,32) B9100392^^ 215 CALL WTREAD(LU,XYN,MSGE04,LNGE04,XYN,OPBUF,30,TC) B9100393^^ 216 GO TO 490 B9100394^^ 217 420 CONTINUE B9100395^^ C CHECK--MUST BE A DATA NAME FOR RPG RPT B9100396^^ 218 IPOS=1 B9100397^^ 219 DO 430 M=1,NNAME B9100398^^ 220 CALL CCSCST(Q6NAME,IPOS,6,MSGE04,17,6,IHOLD) B9100399^^ 221 IF (IHOLD.EQ.0) GO TO 435 B9100400^^ 222 IPOS=IPOS+6 B9100401^^ 223 430 CONTINUE B9100402^^ 224 CALL CCSBLK(OPBUF,32) B9100403^^ C ERROR MSG B9100404^^ 225 CALL WTREAD(LU,XYN,MSGE04,LNGE04,XYN,OPBUF,30,TC) B9100405^^ 226 GO TO 490 B9100406^^ C STORE LEVEL BREAK NAME IN Q4LVLB B9100407^^ C CALCULATE POSITION IN Q4LVLB B9100408^^ 227 435 IPOS=((NLKEY+N)*6) B9100409^^ 228 KLM=KL-1 B9100410^^ 229 DO 440 K=1,KLM B9100411^^ 230 ICOL=L+K B9100412^^ C GET CHAR OF LVL NAME FROM BUFFER B9100413^^ 231 CALL CCSGET(OPBUF,ICOL,IHOLD) B9100414^^ 232 IPOS=IPOS+1 B9100415^^ C PUT CHAR IN Q4LVLB B9100416^^ 233 CALL CCSPUT(IHOLD,IPOS,Q4LVLB) B9100417^^ 234 440 CONTINUE B9100418^^ C INCREMENT # OF LEVEL BRAKS THIS LINE B9100419^^ 235 N=N+1 B9100420^^ C INCREMENT INPUT BUFFER POINTER B9100421^^ 236 L=L+KL B9100422^^ C CHECK NEXT LEVEL BREAK B9100423^^ C SUBTRACT FROM CHAR COUNT FOR (CR) TEST B9100424^t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 9 DATE: 08/29/84 TIME: 2231 t^ 237 OPHLD=OPHLD-KL B9100425^^ 238 GO TO 410 B9100426^^ C GET NEXT INPUT LINE B9100427^^ 239 480 NLKEY=NLKEY+N B9100428^^ 240 IF (NLKEY.EQ.3) GO TO 1000 B9100429^^ 241 CALL CCSBLK(OPBUF,32) B9100430^^ 242 CALL WTREAD(LU,XYN,MSGG1,LNGG1,XYN,OPBUF,30,TC) B9100431^^ C EDIT FOR REPEAT, C OR A B9100432^^ C IF NONE, CHECK NEW LINE FOR LVL NAMES B9100433^^ C C--GO TO NEXT MSG 1000 B9100434^^ C A--ABORT B9100435^^ 243 490 CALL PGSEDT(IR,OPBUF) B9100436^^ 244 IF (IR.EQ.2) ASSIGN 1000 TO RADDR B9100437^^ 245 IF (IR.EQ.3) ASSIGN 1900 TO RADDR B9100438^^ 246 IF (IR.NE.0) GO TO RADDR B9100439^^ 247 GO TO 408 B9100440^^ C B9100441^^ C B9100442^^ C**** GET RECORD SELECTIONS FROM OPERATOR B9100443^^ C DISPLAY QUESTION/ACCEPT ANSWER B9100444^^ C B9100445^^ 248 500 CALL CCSBLK (OPBUF,32) B9100446^^ 249 CALL WTREAD(LU,XYN,MSG5,LNG5,XYN,OPBUF,30,TC) B9100447^^ 250 L=0 B9100448^^ 251 NSLCT=0 B9100449^^ C CHECK RESPONSE FOR ALL OR (CR) B9100450^^ C B9100451^^ C (CR), CONTINUE B9100452^^ 252 IF(OPBUF(16).LE.0) GO TO 505 B9100453^^ C INVALID--WRITE MSG AGAIN B9100454^^ 253 IF (OPBUF(1).NE.$414C) GO TO 500 B9100455^^ C ALL, GO TO NEXT MSG B9100456^^ 254 Q5SLCT(1)=OPBUF(1) B9100457^^ 255 GO TO 1000 B9100458^^ C B9100459^^ C CLEAR Q5SLCT PARAMETER HOLD AREA B9100460^^ 256 505 CALL CCSBLK(Q5SLCT,340) B9100461^^ C INITIALIZE B9100462^^ 257 ASSIGN 500 TO RADDR B9100463^^ 258 IR=0 B9100464^^ C DISPLAY NEXT PROMPT--ALL OR ANY CONDITION B9100465^^ 259 507 CALL CCSBLK(OPBUF,32) B9100466^^ 260 CALL WTREAD(LU,XYN,MSG5A0,LNG5A0,XYN,OPBUF,30,TC) B9100467^^ C CHECK FOR Y OR N RESPONSE B9100468^^ C STORE IN Q5ANS B9100469^^ 261 Q5ANS=AND($FF00,OPBUF(1)) B9100470^^ 262 IF (Q5ANS.EQ.$4E00.OR.Q5ANS.EQ.$5900) GO TO 508 B9100471^^ C INVALID RESPONSE, ASK AGAIN B9100472^^ 263 CALL WTREAD(LU,XYN,MSGE01,LNGE01,ZERO,ZERO,ZERO,TC) B9100473^^ 264 GO TO 507 B9100474^^ C DISPLAY NEXT PROMPT--OPERATION CODES B9100475^^ 265 508 CALL CCSBLK(OPBUF,32) B9100476^^ 266 CALL WTREAD(LU,XYN,MSG5A,LNG5A,XYN,OPBUF,30,TC) B9100477^^ C CHECK FOR REPEAT, C OR A RESPONSE B9100478^t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 10 DATE: 08/29/84 TIME: 2231 t^ 267 509 CALL PGSEDT(IR,OPBUF) B9100479^^ 268 IF (IR.EQ.2) ASSIGN 1000 TO RADDR B9100480^^ 269 IF (IR.EQ.3) ASSIGN 1900 TO RADDR B9100481^^ 270 IF (IR.NE.0) GO TO RADDR B9100482^^ C CHECK FOR VALID OPERATION CODE B9100483^^ C B9100484^^ C EQUAL EQ B9100485^^ 271 IF (OPBUF(1).EQ.$4551) GO TO 510 B9100486^^ C NOT EQUAL NE B9100487^^ 272 IF (OPBUF(1).EQ.$4E45) GO TO 510 B9100488^^ C GREATER THAN GT B9100489^^ 273 IF (OPBUF(1).EQ.$4754) GO TO 510 B9100490^^ C LESS THAN LT B9100491^^ 274 IF (OPBUF(1).EQ.$4C54) GO TO 510 B9100492^^ C GREATER THAN OR EQUAL TO GE B9100493^^ 275 IF (OPBUF(1).EQ.$4745) GO TO 510 B9100494^^ C LESS THAN OR EUAL TO LE B9100495^^ 276 IF (OPBUF(1).EQ.$4C45) GO TO 510 B9100496^^ C RANGE RA B9100497^^ 277 IF (OPBUF(1).EQ.$5241) GO TO 510 B9100498^^ C INVALID B9100499^^ 278 CALL CCSBLK(OPBUF,32) B9100500^^ 279 CALL WTREAD(LU,XYN,MSGE13,LNGE13,XYN,OPBUF,30,TC) B9100501^^ 280 GO TO 509 B9100502^^ C CHECK NUMBER OF OPERATION CODES B9100503^^ C CAN NOT EXCEED 10 B9100504^^ 281 510 IF (NSLCT.LT.10) GO TO 512 B9100505^^ C ERROR, EXCEEDS MAX OF 10 B9100506^^ 282 CALL CCSBLK(OPBUF,32) B9100507^^ 283 CALL WTREAD(LU,XYN,MSGE10,LNGE10,XYN,OPBUF,30,TC) B9100508^^ 284 GO TO 509 B9100509^^ C STORE OP CODE IN Q5SLCT B9100510^^ 285 512 Q5SLCT(L+1)=OPBUF(1) B9100511^^ C Q5SLCT OPERATION CODE IS 2 BYTES B9100512^^ C DATA NAME1 IS 6 BYTES B9100513^^ C VALUE1 OR NAME2 OR VALUE1,VALUE2 IS B9100514^^ C 26 BYTES B9100515^^ C 10 * 34 = 340 BYTES RESERVED B9100516^^ C B9100517^^ C B9100518^^ C DISPLAY NEXT PROMPT--DATA NAME 1 B9100519^^ 286 515 CALL CCSBLK(OPBUF,32) B9100520^^ 287 CALL WTREAD(LU,XYN,MSG5B,LNG5B,XYN,OPBUF,30,TC) B9100521^^ C SET UP KEY FOR RETRIEVE FROM RPTTBL B9100522^^ 288 516 HPKEY(1)=$2020 B9100523^^ 289 HPKEY(2)=$2020 B9100524^^ 290 HPKEY(3)=$2020 B9100525^^ 291 OPHLD=OPBUF(16) B9100526^^ 292 CALL CCSMVA(OPBUF,1,OPHLD,HPKEY,1,OPHLD) B9100527^^ C SAVE KEY FOR ERROR MSG IF INVALID B9100528^^ 293 MSGE04(9) =HPKEY(1) B9100529^^ 294 MSGE04(10)=HPKEY(2) B9100530^^ 295 MSGE04(11)=HPKEY(3) B9100531^^ C RETRIEVE RPTTBL RECORD B9100532^t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 11 DATE: 08/29/84 TIME: 2231 t^ 296 CALL READR(TBLRQB,TBLREC,HPKEY,ISTAT) B9100533^^ C CHECK FOR FILE ERROR B9100534^^ 297 IF (ISTAT.EQ.0.AND.AND(TBLREC(40),$20FF).NE.$2044) GO TO 520 B9100535^^ C RECORD NOT FOUND B9100536^^ 298 CALL CCSBLK(OPBUF,32) B9100537^^ 299 CALL WTREAD(LU,XYN,MSGE04,LNGE04,XYN,OPBUF,30,TC) B9100538^^ 300 GO TO 516 B9100539^^ 301 520 CONTINUE B9100540^^ C STORE DATA NAME1 B9100541^^ 302 525 Q5SLCT(L+2)=MSGE04(9) B9100542^^ 303 Q5SLCT(L+3)=MSGE04(10) B9100543^^ 304 Q5SLCT(L+4)=MSGE04(11) B9100544^^ 305 IF (Q5SLCT(L+1).EQ.$5241) GO TO 535 B9100545^^ C DISPLAY NEXT PROMPT-- B9100546^^ C IS 2ND COMPARISON FIELD A DATA NAME B9100547^^ C ENTER Y OR N B9100548^^ 306 530 CALL CCSBLK(OPBUF,32) B9100549^^ 307 CALL WTREAD(LU,XYN,MSG5C,LNG5C,XYN,OPBUF,30,TC) B9100550^^ C ANSWER IS N, GO TO NEXT PROMPT B9100551^^ 308 IF (AND($FF00,OPBUF(1)).EQ.$4E00) GO TO 535 B9100552^^ C INVALID ANSWER-NEITHER Y NOR N-ASK AGAIN B9100553^^ 309 IF (AND($FF00,OPBUF(1)).NE.$5900) GO TO 530 B9100554^^ C ANSWER IS Y B9100555^^ C PUT BINARY 0 IN 1ST WORD OF Q5SLCT NAME2 B9100556^^ C SLOT--DESIGNATES DATA NAME B9100557^^ 310 534 Q5SLCT(L+5)=$0000 B9100558^^ C B9100559^^ C DISPLAY NEXT PROMPT--2ND COMPARISON FIELD B9100560^^ C B9100561^^ 311 535 CALL CCSBLK(OPBUF,32) B9100562^^ 312 CALL WTREAD(LU,XYN,MSG5D,LNG5D,XYN,OPBUF,30,TC) B9100563^^ C SET UP DATA NAME 1 SPECS B9100564^^ C LENGTH,TYPE,EDIT CODE B9100565^^ 313 D1LNG(1)=TBLREC(6) B9100566^^ 314 D1LNG(2)=TBLREC(7) B9100567^^ 315 D1TYPE=TBLREC(8) B9100568^^ C CHECK IF 2ND COMPARISON FIELD IS B9100569^^ C DATA NAME OR VALUE B9100570^^ 316 536 OPHLD=OPBUF(16) B9100571^^ 317 IF (Q5SLCT(L+5).EQ.$0000) GO TO 570 B9100572^^ C EDIT VALUE FIELD 1 B9100573^^ 318 IHOLD=$0000 B9100574^^ 319 INUM=1 B9100575^^ 320 IPOS=(NSLCT*34)+8 B9100576^^ 321 DO 540 K=1,14 B9100577^^ 322 CALL CCSGET(OPBUF,K,IHOLD) B9100578^^ C IS CHARACTER A COMMA B9100579^^ 323 IF (IHOLD.EQ.$002C) GO TO 541 B9100580^^ C IS CHARACTER A CARRIAGE RETURN B9100581^^ 324 IF (OPHLD.LE.0) GO TO 560 B9100582^^ C IS THE CHARACTER NUMERIC B9100583^^ 325 IF (IHOLD.GE.$0030.AND.IHOLD.LE.$0039) GO TO 538 B9100584^^ C ALPHA B9100585^^ 326 INUM=0 B9100586^t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 12 DATE: 08/29/84 TIME: 2231 t^ C PUT CHAR IN Q5SLCT B9100587^^ 327 538 IPOS=IPOS+1 B9100588^^ 328 CALL CCSPUT(IHOLD,IPOS,Q5SLCT) B9100589^^ C IF 14TH CHAR WAS NOT A COMMA OR (CR) B9100590^^ C --ERROR, TOO LONG B9100591^^ 329 IF (K.NE.14) GO TO 540 B9100592^^ 330 539 CALL CCSBLK(OPBUF,32) B9100593^^ 331 CALL WTREAD(LU,XYN,MSGE12,LNGE12,XYN,OPBUF,30,TC) B9100594^^ 332 GO TO 536 B9100595^^ 333 540 OPHLD=OPHLD-1 B9100596^^ C************************ 2 VALUES ENTERD B9100597^^ C CHECK FOR OPERATION CODE OF RA B9100598^^ 334 541 IPOS=(NSLCT*17)+1 B9100599^^ 335 IF (Q5SLCT(IPOS).EQ.$5241) GO TO 542 B9100600^^ C ERROR--CAN NOT ENTER 2 VALUES B9100601^^ 336 CALL CCSBLK(OPBUF,32) B9100602^^ 337 CALL WTREAD(LU,XYN,MSGE17,LNGE17,XYN,OPBUF,30,TC) B9100603^^ 338 GO TO 536 B9100604^^ C EDIT 2ND VALUE OF RANGE B9100605^^ 339 542 K2=K+1 B9100606^^ 340 OPHLD=OPHLD-1 B9100607^^ 341 IPOS=(NSLCT*34)+21 B9100608^^ 342 DO 545 K1=1,14 B9100609^^ 343 CALL CCSGET(OPBUF,K2,IHOLD) B9100610^^ 344 K2=K2+1 B9100611^^ C CHECK FOR CARRIAGE RETURN B9100612^^ 345 IF (OPHLD.LE.0) GO TO 546 B9100613^^ C IS CHARACTER NUMERIC B9100614^^ 346 IF (IHOLD.GE.$0030.AND.IHOLD.LE.$0039) GO TO 543 B9100615^^ C ALPHA B9100616^^ 347 INUM=0 B9100617^^ C PUT CHARACTER IN Q5SLCT B9100618^^ 348 543 IPOS=IPOS+1 B9100619^^ 349 CALL CCSPUT(IHOLD,IPOS,Q5SLCT) B9100620^^ C IF 14TH CHAR NOT A (CR)--ERROR B9100621^^ 350 IF (K1.NE.14) GO TO 545 B9100622^^ C ERROR B9100623^^ 351 GO TO 539 B9100624^^ 352 545 OPHLD=OPHLD-1 B9100625^^ C EDIT VALUES--TYPE,LENGTH,VALUE2.GT.VALUE1 B9100626^^ C K = LENGTH OF VALUE1+1 B9100627^^ C K1= LENGTH OF VALUE2+1 B9100628^^ 353 546 K=K-1 B9100629^^ 354 K1=K1-1 B9100630^^ 355 CALL ASCBIN(D1LNG(2),BIN) B9100631^^ 356 IF (BIN.GT.13) BIN=13 B9100632^^ C CHECK TYPE B9100633^^ 357 IF (INUM.EQ.0.AND.AND(D1TYPE,$FF00).NE.$4100) GO TO 547 B9100634^^ 358 GO TO 548 B9100635^^ C TYPE ERROR/LENGTH ERROR B9100636^^ 359 547 CALL CCSBLK(OPBUF,32) B9100637^^ 360 CALL WTREAD(LU,XYN,MSGE11,LNGE11,XYN,OPBUF,30,TC) B9100638^^ 361 GO TO 536 B9100639^^ C CHECK LENGTH B9100640^t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 13 DATE: 08/29/84 TIME: 2231 t^ 362 548 IF (BIN.LT.K.OR.BIN.LT.K1) GO TO 547 B9100641^^ C RIGHT/LEFT JUSTIFY VALUE1+VALUE2 B9100642^^ 363 IPOS=(NSLCT*34)+9 B9100643^^ 364 IF (INUM.EQ.0) GO TO 550 B9100644^^ C RIGHT JUSTIFY--NUMERIC B9100645^^ 365 CALL PGSJR(Q5SLCT,IPOS,K,Q5SLCT,IPOS,BIN) B9100646^^ 366 IPOS=(NSLCT*34)+22 B9100647^^ 367 CALL PGSJR(Q5SLCT,IPOS,K1,Q5SLCT,IPOS,BIN) B9100648^^ 368 GO TO 552 B9100649^^ C LEFT JUSTIFY--ALPHA B9100650^^ 369 550 IPOS=(NSLCT*34)+9 B9100651^^ 370 CALL PGSJL(Q5SLCT,IPOS,K,Q5SLCT,IPOS,BIN) B9100652^^ 371 IPOS=(NSLCT*34)+22 B9100653^^ 372 CALL PGSJL(Q5SLCT,IPOS,K1,Q5SLCT,IPOS,BIN) B9100654^^ C CHECK VALUE2.GT.VALUE1 B9100655^^ 373 552 IV1=(NSLCT*34)+9 B9100656^^ 374 IV2=(NSLCT*34)+22 B9100657^^ 375 IHOLD1=$0000 B9100658^^ 376 IHOLD0=$0000 B9100659^^ 377 DO 554 K=1,BIN B9100660^^ 373 552 IV1=(NSLCT*34)+9 B9100656^^ 374 IV2=(NSLCT*34)+22 B9100657^^ 375 IHOLD1=$0000 B9100658^^ 376 IHOLD0=$0000 B9100659^^ 377 DO 554 K=1,BIN B9100660^^ 378 CALL CCSGET(Q5SLCT,IV1,IHOLD1) B9100661^^ 379 CALL CCSGET(Q5SLCT,IV2,IHOLD0) B9100662^^ C COMPARE CHARACTER BY CHARACTER B9100663^^ C GREATER--OK B9100664^^ 380 IF (IHOLD0.GT.IHOLD1) GO TO 556 B9100665^^ C LESS--ERROR B9100666^^ 381 IF (IHOLD0.LT.IHOLD1) GO TO 555 B9100667^^ 382 IV1=IV1+1 B9100668^^ 383 IV2=IV2+1 B9100669^^ 384 554 CONTINUE B9100670^^ C ERROR--VALUE2.LE.VALUE1 B9100671^^ 385 555 CALL CCSBLK(OPBUF,32) B9100672^^ 386 CALL WTREAD(LU,XYN,MSGE14,LNGE14,XYN,OPBUF,30,TC) B9100673^^ 387 GO TO 536 B9100674^^ C VALID VALUE--CONTINUE B9100675^^ 388 556 GO TO 580 B9100676^^ C B9100677^^ C************************ 1 VALUE ENTERED B9100678^^ C CHECK OPERATION CODE--NOT EQUAL RA B9100679^^ 389 560 K=K-1 B9100680^^ 390 IPOS=(NSLCT*17)+1 B9100681^^ 391 IF (Q5SLCT(IPOS).NE.$5241) GO TO 563 B9100682^^ C ERROR--MUST ENTER 2 VALUES B9100683^^ 392 CALL CCSBLK(OPBUF,32) B9100684^^ 393 CALL WTREAD(LU,XYN,MSGE18,LNGE18,XYN,OPBUF,30,TC) B9100685^^ 394 GO TO 536 B9100686^^ C EDIT VALUE--TYPE,LENGTH,JUSTIFY IN Q5SLCT B9100687^^ 395 563 CALL ASCBIN(D1LNG(2),BIN) B9100688^^ 396 IF (BIN.GT.13) BIN=13 B9100689^^ C CHECK TYPE B9100690^^ 397 IF (INUM.EQ.0.AND.AND(D1TYPE,$FF00).NE.$4100) GO TO 547 B9100691^^ C CHECK LENGTH B9100692^^ 398 564 IF (BIN.LT.K) GO TO 547 B9100693^^ C RIGHT/LEFT JUSTIFY VALUE B9100694^t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 14 DATE: 08/29/84 TIME: 2231 t^ 399 IPOS=(NSLCT*34)+9 B9100695^^ 400 IF (INUM.EQ.0) GO TO 566 B9100696^^ C RIGHT JUSTIFY B9100697^^ 401 CALL PGSJR(Q5SLCT,IPOS,K,Q5SLCT,IPOS,BIN) B9100698^^ 402 GO TO 580 B9100699^^ C LEFT JUSTIFY B9100700^^ 403 566 CALL PGSJL(Q5SLCT,IPOS,K,Q5SLCT,IPOS,BIN) B9100701^^ 404 GO TO 580 B9100702^^ C B9100703^^ C************************ DATA NAME ENTERED B9100704^^ C CHECK FOR VALID NAME, TYPE, LENGTH B9100705^^ C B9100706^^ C SET UP KEY FOR RETRIEVE B9100707^^ 405 570 HPKEY(1)=$2020 B9100708^^ 406 HPKEY(2)=$2020 B9100709^^ 407 HPKEY(3)=$2020 B9100710^^ 408 OPHLD=OPBUF(16) B9100711^^ 409 IF (OPHLD.GT.6) OPHLD=6 B9100712^^ 410 CALL CCSMVA(OPBUF,1,OPHLD,HPKEY,1,OPHLD) B9100713^^ C SAVE KEY FOR ERROR MSG IF INVALID B9100714^^ 411 MSGE04(9) =HPKEY(1) B9100715^^ 412 MSGE04(10)=HPKEY(2) B9100716^^ 413 MSGE04(11)=HPKEY(3) B9100717^^ C RETRIEVE RPTTBL RECORD B9100718^^ 414 CALL READR(TBLRQB,TBLREC,HPKEY,ISTAT) B9100719^^ C CHECK FOR FILE ERROR B9100720^^ 415 IF (ISTAT.EQ.0.AND.AND(TBLREC(40),$20FF).NE.$2044) GO TO 575 B9100721^^ C RECORD NOT FOUND B9100722^^ 416 CALL CCSBLK(OPBUF,32) B9100723^^ 417 CALL WTREAD(LU,XYN,MSGE04,LNGE04,XYN,OPBUF,30,TC) B9100724^^ 418 GO TO 536 B9100725^^ 419 575 CONTINUE B9100726^^ C CHECK TYPE,LENGTH,STORE IN Q5SLCT B9100727^^ 420 576 IF (AND(TBLREC(8),$FF00).EQ.AND(D1TYPE,$FF00)) GO TO 577 B9100728^^ C NOT EQUAL--ARE TYPES N + T B9100729^^ C B9100730^^ 421 IF (AND(TBLREC(8),$FF00).NE.$4100.AND.AND(D1TYPE,$FF00).NE.$4100) B9100731^^ 421 2 GO TO 577 B9100732^^ C ERROR--TYPES DONT MATCH B9100733^^ 422 GO TO 547 B9100734^^ C TYPES OK, CHECK LENGTH B9100735^^ 423 577 IF (D1LNG(1).EQ.TBLREC(6).AND.D1LNG(2).EQ.TBLREC(7)) GO TO 578 B9100736^^ C ERROR--LENGTHS DIFFER B9100737^^ 424 GO TO 547 B9100738^^ C STORE 2ND DATA NAME IN Q5SLCT B9100739^^ 425 578 Q5SLCT(L+6)=MSGE04(9) B9100740^^ 426 Q5SLCT(L+7)=MSGE04(10) B9100741^^ 427 Q5SLCT(L+8)=MSGE04(11) B9100742^^ C B9100743^^ C B9100744^^ C B9100745^^ C UPDATE POINTER FOR Q5SLCT B9100746^^ C UPDATE NUMBER OF SELECTIONS B9100747^^ C GET NEXT OPERATION CODE B9100748^t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 15 DATE: 08/29/84 TIME: 2231 t^ 428 580 L=L+17 B9100749^^ 429 NSLCT=NSLCT+1 B9100750^^ 430 GO TO 508 B9100751^^ C B9100752^^ C B9100753^^ C B9100754^^ C GET DATA NAMES FOR REPORT FROM OPERATOR B9100755^^ C DISPLAY QUESTION/ACCEPT ANSWER B9100756^^ C B9100757^^ 431 600 CALL CCSBLK(OPBUF,32) B9100758^^ 432 CALL WTREAD(LU,XYN,MSG6,LNG6,XYN,OPBUF,30,TC) B9100759^^ C INITIALIZE DATA NAME, TOTAL PARAMETER HOLD AREB9100760^^ 433 CALL CCSBLK(Q6NAME,102) B9100761^^ 434 CALL CCSBLK(Q6EPOS,204) B9100762^^ 435 CALL CCSBLK(Q6TOT,154) B9100763^^ 436 NNAME=0 B9100764^^ 437 NCHARS=0 B9100765^^ 438 NTFLDS=0 B9100766^^ C CHECK FOR REPEAT,C OR A RESPONSE B9100767^^ 439 ASSIGN 600 TO RADDR B9100768^^ 440 IR=0 B9100769^^ 441 CALL PGSEDT(IR,OPBUF) B9100770^^ 442 IF (IR.EQ.2) ASSIGN 1000 TO RADDR B9100771^^ 443 IF (IR.EQ.3) ASSIGN 1900 TO RADDR B9100772^^ 444 IF (IR.NE.0) GO TO RADDR B9100773^^ C NEW INPUT LINE B9100774^^ 445 608 N=0 B9100775^^ 446 L=0 B9100776^^ 447 NT=0 B9100777^^ 448 MCHARS=0 B9100778^^ 449 OPHLD=OPBUF(16) B9100779^^ C NEW DATA NAME B9100780^^ 450 610 IF (OPHLD.LE.0) GO TO 680 B9100781^^ C CHECK # OF NAMES ENTERED THIS LINE B9100782^^ 451 IF (N.LT.3) GO TO 615 B9100783^^ C ERROR MORE THAN 3 NAMES THIS LINE B9100784^^ 452 CALL WTREAD(LU,XYN,MSGE06,LNGE06,ZERO,ZERO,ZERO,TC) B9100785^^ 453 GO TO 680 B9100786^^ C SET UP KEY FOR RETRIEVE B9100787^^ 454 615 HPKEY(1)=$2020 B9100788^^ 455 HPKEY(2)=$2020 B9100789^^ 456 HPKEY(3)=$2020 B9100790^^ 457 DO 616 K=1,6 B9100791^^ 458 IPOS=K+L B9100792^^ 459 CALL CCSGET(OPBUF,IPOS,IHOLD) B9100793^^ 460 IF (IHOLD.EQ.COMMA) GO TO 617 B9100794^^ 461 CALL CCSPUT(IHOLD,K,HPKEY) B9100795^^ 462 616 CONTINUE B9100796^^ 463 617 KL=K B9100797^^ C SAVE KEY FOR ERROR MSG IF NECESSARY B9100798^^ 464 MSGE04(9) =HPKEY(1) B9100799^^ 465 MSGE04(10)=HPKEY(2) B9100800^^ 466 MSGE04(11)=HPKEY(3) B9100801^^ C RETRIEVE RPTTBL RECORD B9100802^t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 16 DATE: 08/29/84 TIME: 2231 t^ 467 CALL READR(TBLRQB,TBLREC,HPKEY,ISTAT) B9100803^^ C CHECK FOR FILE ERROR B9100804^^ 468 IF (ISTAT.EQ.0.AND.AND(TBLREC(40),$20FF).NE.$2044) GO TO 620 B9100805^^ C RECORD NOT FOUND B9100806^^ 469 CALL CCSBLK(OPBUF,32) B9100807^^ 470 CALL WTREAD(LU,XYN,MSGE04,LNGE04,XYN,OPBUF,30,TC) B9100808^^ C CLEAR INFO STORED FOR THIS LINE B9100809^^ 471 IF (N.EQ.0) GO TO 618 B9100810^^ 472 DO 618 K=1,N B9100811^^ 473 IPOS=((NNAME+K)*6) B9100812^^ 474 CALL CCSMVA(Q6NAME,IPOS,0,Q6NAME,IPOS,6) B9100813^^ 475 IF (NT.EQ.0) GO TO 618 B9100814^^ 476 IPOS=((NTFLDS+NT)*9) B9100815^^ 477 CALL CCSMVA(Q6TOT,IPOS,0,Q6TOT,IPOS,9) B9100816^^ 478 NT=NT-1 B9100817^^ 479 618 CONTINUE B9100818^^ 480 GO TO 690 B9100819^^ 481 620 CONTINUE B9100820^^ C CHECK # OF PRINT POSITIONS B9100821^^ C USED ON REPORT B9100822^^ C B9100823^^ C CONVERT LENGTH OF NAME FIELD TO BINARY B9100824^^ 482 630 CALL ASCBIN(TBLREC(6),BIN) B9100825^^ 483 M=BIN*100 B9100826^^ 484 CALL ASCBIN(TBLREC(7),BIN) B9100827^^ 485 M=M+BIN B9100828^^ 486 ICHARS=M B9100829^^ C LENGTH MUST BE AT LEAST 6 FOR EACH FIELD B9100830^^ C FOR HEADING DESCRIPTION B9100831^^ 487 IF (M.LT.6) M=6 B9100832^^ C ADD 2 FOR FIELD SEPARATERS B9100833^^ 488 M=M+2 B9100834^^ 489 ICODE=AND(TBLREC(8),$00FF) B9100835^^ C CHECK DATA TYPE B9100836^^ 490 IF (AND(TBLREC(8),$FF00).EQ.$4100) GO TO 640 B9100837^^ C NUMERIC--CHECK DECIMAL POSITIONS B9100838^^ C B9100839^^ 491 IPOS=AND(TBLREC(09),$00FF) B9100840^^ 492 CALL ASCBIN(IPOS,BIN) B9100841^^ 493 IF (BIN.GT.0) M=M+1 B9100842^^ C NUMERIC--CHECK EDIT CODE B9100843^^ C CODES 1,2,A,B,J,K HAVE COMMAS B9100844^^ C # OF COMMAS =(LENGTH-# DEC POS-1)/3 B9100845^^ 494 NCOMMA=(ICHARS-BIN-1)/3 B9100846^^ C CODES A,B,C,D HAVE 2 POS CR SIGN B9100847^^ C CODES J,K,L,M HAVE 1 POS - SIGN B9100848^^ 495 IF (ICODE.EQ.$0031.OR.ICODE.EQ.$0032) M=M+NCOMMA B9100849^^ 496 IF (ICODE.EQ.$0041.OR.ICODE.EQ.$0042) M=M+NCOMMA+2 B9100850^^ 497 IF (ICODE.EQ.$0043.OR.ICODE.EQ.$0044) M=M+2 B9100851^^ 498 IF (ICODE.EQ.$004A.OR.ICODE.EQ.$004B) M=M+NCOMMA+1 B9100852^^ 499 IF (ICODE.EQ.$004C.OR.ICODE.EQ.$004D) M=M+1 B9100853^^ C ALPHANUMERIC--CHECK FOR EDIT CODE Y--DATE B9100854^^ 500 640 IF (ICODE.EQ.$0059) M=M+2 B9100855^^ C CHECK TOTAL # CHARS FOR MAX PER PRINT B9100856^t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 17 DATE: 08/29/84 TIME: 2231 t^ C LINE- 132 B9100857^^ 501 ICHARS=NCHARS+MCHARS+M B9100858^^ 502 IF (ICHARS.LE.132) GO TO 650 B9100859^^ C ERROR--EXCEEDS MAX CHAR PER PRINT LINE B9100860^^ 503 CALL WTREAD(LU,XYN,MSGE15,LNGE15,ZERO,ZERO,ZERO,TC) B9100861^^ 504 GO TO 600 B9100862^^ C STORE DATA NAME IN Q6NAME:DNAME1DNAME2... B9100863^^ C CALCULATE POSITION IN Q6NAME B9100864^^ 505 650 IPOS=((NNAME+N)*6) B9100865^^ 506 KLM=KL-1 B9100866^^ 507 DO 655 K=1,KLM B9100867^^ 508 ICOL=L+K B9100868^^ C GET CHAR FROM BUFFER B9100869^^ 509 CALL CCSGET(OPBUF,ICOL,IHOLD) B9100870^^ 510 IPOS=IPOS+1 B9100871^^ C PUT CHAR IN Q6NAME B9100872^^ 511 CALL CCSPUT(IHOLD,IPOS,Q6NAME) B9100873^^ 512 655 CONTINUE B9100874^^ C CHECK IF DATA NAME IS T TYPE B9100875^^ C --TOTALS ON RPT GENERATED FOR THIS FIELD B9100876^^ 513 IF (AND(TBLREC(8),$FF00).NE.$5400) GO TO 665 B9100877^^ C B9100878^^ C STORE IN Q6TOT: TNAME1LLDTNAME2LLD B9100879^^ C NAME,LENGTH,DECIMAL POSITIONS B9100880^^ C CALCULATE POSITION IN Q6TOT B9100881^^ 514 IPOS=((NTFLDS+NT)*9) B9100882^^ 515 DO 660 K=1,KLM B9100883^^ 516 ICOL=L+K B9100884^^ 517 CALL CCSGET(OPBUF,ICOL,IHOLD) B9100885^^ 518 IPOS=IPOS+1 B9100886^^ 519 CALL CCSPUT(IHOLD,IPOS,Q6TOT) B9100887^^ 520 660 CONTINUE B9100888^^ 521 IPOS=((NTFLDS+NT)*9)+7 B9100889^^ C STORE LENGTH + DECIMAL POSITIONS B9100890^^ 522 CALL CCSMVA(TBLREC,13,2,Q6TOT,IPOS,2) B9100891^^ 523 IPOS=IPOS+2 B9100892^^ 524 CALL CCSGET(TBLREC,18,IHOLD) B9100893^^ 525 CALL CCSPUT(IHOLD,IPOS,Q6TOT) B9100894^^ 526 NT=NT+1 B9100895^^ C Q6EPOS STORE LENGTHS,ETC FOR RPG OUTPUT SOURCE B9100896^^ C L1L2TE... 1. LENGTH INCLUDING EDIT (BIN-1 WORD) B9100897^^ C 2. LENGTH INCLUDING EDIT MINUS CR,- (BIN)B9100898^^ C (1 WORD) B9100899^^ C 3. TYPE/EDIT CODES (1 WORD) B9100900^^ C 4. ACTUAL DATA LENGTH (ASC-2 WORDS) B9100901^^ C 5. CLASSIFIED/DECIMAL (ASC-1 WORD) B9100902^^ C B9100903^^ 527 665 IPOS=((NNAME+N)*6)+1 B9100904^^ 528 Q6EPOS(IPOS)=M-2 B9100905^^ 529 Q6EPOS(IPOS+1)=Q6EPOS(IPOS) B9100906^^ 530 IF (ICODE.GE.$0041.AND.ICODE.LE.$0044) B9100907^^ 530 1 Q6EPOS(IPOS+1)=Q6EPOS(IPOS+1)-$0002 B9100908^^ 531 IF (ICODE.GE.$004A.AND.ICODE.LE.$004D) B9100909^^ 531 1 Q6EPOS(IPOS+1)=Q6EPOS(IPOS+1)-$0001 B9100910^t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 18 DATE: 08/29/84 TIME: 2231 t^ 532 Q6EPOS(IPOS+2)=TBLREC(8) B9100911^^ 533 Q6EPOS(IPOS+5)=TBLREC(9) B9100912^^ 534 Q6EPOS(IPOS+3)=TBLREC(6) B9100913^^ 535 Q6EPOS(IPOS+4)=TBLREC(7) B9100914^^ C INCREMENT # OF DATA NAMES THIS LINE B9100915^^ 536 670 N=N+1 B9100916^^ C INCREMENT INPUT BUFFER POINTER B9100917^^ 537 L=L+KL B9100918^^ C CHECK NEXT DATA NAME B9100919^^ C SUBTRACT FROM CHAR COUNT FOR (CR) TEST B9100920^^ 538 OPHLD=OPHLD-KL B9100921^^ C ADD # CHARS THIS FLD TO # CHARS B9100922^^ C THIS LINE B9100923^^ 539 MCHARS=MCHARS+M B9100924^^ 540 GO TO 610 B9100925^^ C GET NEXT INPUT LINE B9100926^^ 541 680 NNAME=NNAME+N B9100927^^ 542 NCHARS=NCHARS+MCHARS B9100928^^ 543 NTFLDS=NTFLDS+NT B9100929^^ 544 CALL CCSBLK(OPBUF,32) B9100930^^ 545 CALL WTREAD(LU,XYN,MSGG1,LNGG1,XYN,OPBUF,30,TC) B9100931^^ C EDIT FOR REPEAT,C OR A B9100932^^ C IF NONE, CHECK NEW LINE FOR DATA NAMES B9100933^^ 546 690 IMAXC=ICHARS B9100934^^ 547 CALL PGSEDT(IR,OPBUF) B9100935^^ 548 IF (IR.EQ.2) ASSIGN 1000 TO RADDR B9100936^^ 549 IF (IR.EQ.3) ASSIGN 1900 TO RADDR B9100937^^ 550 IF (IR.NE.0) GO TO RADDR B9100938^^ 551 GO TO 608 B9100939^^ C B9100940^^ C B9100941^^ C B9100942^^ C GET REPORT TITLE FROM OPERATOR B9100943^^ C DISPLAY QUESTION/ACCEPT ANSWER B9100944^^ 552 700 CALL CCSBLK(OPBUF,32) B9100945^^ C B9100946^^ 553 CALL WTREAD(LU,XYN,MSG7,LNG7,XYN,OPBUF,30,TC) B9100947^^ C CLEAR REPORT TITLE PARAMETER HOLD AREA B9100948^^ 554 702 CALL CCSBLK(Q7RPT,30) B9100949^^ C STORE TITLE IN Q7RP7 B9100950^^ 555 OPHLD=OPBUF(16) B9100951^^ 556 IF (OPHLD.LE.0) GO TO 720 B9100952^^ 557 DO 715 K=1,OPHLD B9100954^^ 558 CALL CCSGET ( OPBUF , K , IHOLD ) B9100955^^ 559 IF ( IHOLD .EQ. $27 ) GO TO 730 B9100956^^ 560 CALL CCSPUT ( IHOLD, K, Q7RPT ) B9100957^^ 561 715 CONTINUE B9100958^^ C ASK OPERATOR TO VERIFY RPT TITLE B9100959^^ 562 720 CALL CCSBLK (OPBUF,32) B9100960^^ 563 CALL WTREAD(LU,XYN,MSG7A,LNG7A,XYN,OPBUF,30,TC) B9100961^^ 564 ASSIGN 700 TO RADDR B9100962^^ 565 IR=0 B9100963^^ C EDIT RESPONSE-- B9100964^^ C REPEAT C OR A, OTHERWISE INVALID B9100965^t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 19 DATE: 08/29/84 TIME: 2231 t^ 566 CALL PGSEDT(IR,OPBUF) B9100966^^ 567 IF (IR.EQ.2) ASSIGN 1000 TO RADDR B9100967^^ 568 IF (IR.EQ.3) ASSIGN 1900 TO RADDR B9100968^^ 569 IF (IR.NE.0) GO TO RADDR B9100969^^ C INVALID RESPONSE B9100970^^ 570 GO TO 720 B9100971^^ C ERROR--CANNOT HAVE QUOTE EMBEDDED IN RPT TITLE B9100972^^ 571 730 CALL CCSBLK(OPBUF,30) B9100973^^ 572 CALL WTREAD(LU,XYN,MSGE16,LNGE16,XYN,OPBUF,30,TC) B9100974^^ 573 GO TO 702 B9100975^^ C B9100976^^ C B9100977^^ C B9100978^^ C LOOP END--SEND NEXT QUESTION TO OPERATOR B9100979^^ C B9100980^^ 574 1000 CONTINUE B9100981^^ 575 RADDR=$0000 B9100982^^ 576 GO TO 1999 B9100983^^ 577 1010 RADDR=$8010 B9100984^^ 578 GO TO 1999 B9100985^^ 579 1100 RADDR=$8100 B9100986^^ 580 GO TO 1999 B9100987^^ 581 1900 RADDR=$8900 B9100988^^ C B9100989^^ C B9100990^^ C********* END OF OPERATOR COMMUNICATION B9100991^^ 582 1999 CONTINUE B9100992^^ 583 RETURN B9100993^^ 584 END B9100994^t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 20 DATE: 08/29/84 TIME: 2231 t COMMON  LABEL $0448 ( 1096)    PROGRAM LENGTH $0EA8 ( 3752)   EXTERNALS 2 PGSLST PGSEDT PGSJR PGSJL BINASC ASCBIN WTREAD 2, READR CCSBLK CCSGET CCSPUT CCSCST CCSMVA , t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 21 DATE: 08/29/84 TIME: 2231 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " 8010 (-32751) 04EA 577"" 8100 (-32511) 04EB 579"" 8900 (-30463) 04EC 581"L FF00 (-255) 04AE 54,55,61,261,308,309,357,397,420,421,490,513 L‚ 0000 (0) 0001 43,60,87,88,99,100,104,105,106,108,122,132,140,147,174,179,181,185,186,187,189,203,213,221,246,250 ‚€ ,251,252,258,270,297,310,317,318,324,326,345,347,357,364,375,376,397,400,415,436,437,438,440,444,€^ 445,446,447,448,450,468,471,474,475,477,493,550,556,565,569,575^‚ 0001 (1) 0000 45,46,54,55,61,71,74,77,80,83,110,117,120,128,137,138,146,153,155,157,159,164,191,198,201,209,218, ‚€ 219,228,229,232,235,253,254,261,271,272,273,274,275,276,277,285,288,292,293,305,308,309,313,319, €€ 321,327,333,334,339,340,342,344,348,352,353,354,377,382,383,389,390,405,410,411,423,429,454,457, €j 464,472,478,493,494,498,499,506,507,510,515,518,526,527,529,530,531,536,557j‚ 0002 (2) 04AA 47,72,75,82,84,91,102,118,129,165,166,172,183,199,210,244,268,289,294,302,314,355,395,406,412,423, ‚V 442,455,465,488,496,497,500,522,523,528,530,532,548,567V€ 0003 (3) 04AB 48,73,76,78,79,82,85,92,103,114,119,130,173,184,190,195,200,211,240,245,269,290,295,303,407,413, €> 443,451,456,466,494,534,549,568>: 0005 (5) 04AC 50,53,58,65,72,310,317,533 :z 0006 (6) 04AD 51,66,67,73,120,139,141,157,201,220,222,227,313,409,423,425,457,473,474,482,487,505,527,534zR 0009 (9) 04D8 363,369,373,399,411,425,464,476,477,491,514,521,533R" 000C (12) 04C5 153". 000D (13) 04D6 356,356,396,522.2 0011 (17) 04C4 139,220,334,390,4282& 0012 (18) 04C7 178,524&‚ 001E (30) 04B8 96,112,134,144,151,170,177,193,215,225,242,249,260,266,279,283,287,299,307,312,331,337,360,386,393 ‚D ,417,432,470,545,553,554,563,571,572 D‚ 0020 (32) 04B7 95,111,133,143,150,169,176,192,214,224,241,248,259,265,278,282,286,298,306,311,330,336,359,385,392 ‚8 ,416,431,469,544,552,562 8B 0022 (34) 04D3 320,341,363,366,369,371,373,374,399B" 0064 (100) 04E3 483"" 0066 (102) 04DD 433"" 0078 (120) 04B9 98 "" 0084 (132) 04E8 502"" 009A (154) 04DF 435"" 00CC (204) 04DE 434"& 00FF (255) 04E6 489,491&" 0154 (340) 04CA 256"" 0300 (768) 04B6 87 "Z 2020 (8224) 04BD 117,118,119,198,199,200,288,289,290,405,406,407,454,455,456Z2 2044 (8260) 04C2 132,213,297,415,46822 20FF (8447) 04C1 132,213,297,415,4682* 3030 (12336) 04B3 66,67,78,92*$ 3139 (12601) 04B4 66,78$. 4100 (16640) 04D7 357,397,421,490." 414C (16716) 04C9 253"" 4551 (17745) 04CB 271"" 4745 (18245) 04CF 275"" 4754 (18260) 04CD 273"t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 22 DATE: 08/29/84 TIME: 2231 t" 4C45 (19525) 04D0 276"" 4C54 (19540) 04CE 274"2 4E00 (19968) 04AF 54,62,69,93,262,3082" 4E45 (20037) 04CC 272". 5241 (21057) 04D1 277,305,335,391." 5250 (21072) 04B1 64 "" 5400 (21504) 04E9 513"$ 5430 (21552) 04B2 65,91$, 5900 (22784) 04B0 55,63,262,309,   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " ABTMSG INTEGER 03E8 D 1,6"j AND INTR.FN. 7FFF 54,55,61,87,132,213,261,297,308,309,357,397,415,420,421,468,489,490,491,513j| BIN INTEGER 0300 D 1,6,79,80,81,355,356,362,365,367,370,372,377,395,396,398,401,403,482,483,484,485,492,493,494 |8 COMMA INTEGER 0005 6,43,124,156,163,205,460 8" CS INTEGER 03F1 D 1,6"6 D1LNG INTEGER 0332 D 1,6,313,314,355,395,42366 D1TYPE INTEGER 0331 D 1,6,315,357,397,420,4216" DELQM INTEGER 000F D 1,4"" DLQRQB INTEGER 0063 D 1,4"" ERRMSG INTEGER 03B7 D 1,6"4 HPGMN INTEGER 02CD D 1,6,71,72,73,74,75,764€ HPKEY INTEGER 0302 D 1,6,83,84,85,86,117,118,119,125,128,129,130,131,198,199,200,206,209,210,211,212,288,289,290,292, €n 293,294,295,296,405,406,407,410,411,412,413,414,454,455,456,461,464,465,466,467n4 I INTEGER 04A9 43,46,47,48,49,50,51 46 ICHARS INTEGER 04E4 485,486,494,501,502,5466F ICODE INTEGER 04E5 488,489,495,496,497,498,499,500,530,531F> ICOL INTEGER 04C6 156,158,230,231,508,509,516,517>€ IHOLD INTEGER 04BF 121,122,123,124,125,139,140,147,148,149,154,158,160,203,204,205,206,220,221,231,233,318,322,323, €b 325,328,343,346,349,459,460,461,509,511,517,519,524,525,558,559,560b2 IHOLD0 INTEGER 04DC 375,376,379,380,38122 IHOLD1 INTEGER 04DB 374,375,378,380,3812( IHOLD2 INTEGER 035E D 1,6,81,82($ IMAXC INTEGER 041B D 1,546$" IND INTEGER 038A D 1,6"> INUM INTEGER 04D2 318,319,326,347,357,364,397,400>€ IPOS INTEGER 04BE 120,121,123,137,139,141,153,154,155,156,159,160,162,163,202,204,218,220,222,227,232,233,320,327, €€ 328,334,335,341,348,349,363,365,366,367,369,370,371,372,390,391,399,401,403,458,459,473,474,476, €v 477,491,492,505,510,511,514,518,519,521,522,523,525,527,528,529,530,531,532,533,534,535v‚ IR INTEGER 04BA 99,100,101,102,103,104,171,172,173,174,181,182,183,184,185,243,244,245,246,258,267,268,269,270,440 ‚T ,441,442,443,444,547,548,549,550,565,566,567,568,569 TZ ISTAT INTEGER 0301 D 1,6,59,60,86,87,88,131,132,212,213,296,297,414,415,467,468 Z. IV1 INTEGER 04D9 373,373,378,382.. IV2 INTEGER 04DA 373,374,379,383.‚ K INTEGER 04B5 76,120,121,125,127,146,148,201,202,206,208,229,230,321,322,329,339,353,362,365,370,377,389,398,401 ‚X ,403,457,458,461,463,472,473,507,508,515,516,557,558,560 X6 K1 INTEGER 04D5 341,350,354,362,367,3726. K2 INTEGER 04D4 339,339,343,344.R KL INTEGER 04C0 127,127,146,165,166,208,228,236,237,463,506,537,538Rt FTN 3.3B (OPT = LPC) PGGEN1 PAGE 23 DATE: 08/29/84 TIME: 2231 t6 KLM INTEGER 04C8 227,228,229,506,507,5156€ L INTEGER 04BC 105,106,121,146,165,187,202,230,236,250,285,302,303,304,305,310,317,425,426,427,428,446,458,508, €& 516,537&$ LNG1 INTEGER 0488 40,53$$ LNG2 INTEGER 0489 40,58$$ LNG3 INTEGER 048A 40,96$& LNG4 INTEGER 048B 40,177 && LNG5 INTEGER 048C 40,249 && LNG5A INTEGER 048D 40,266 && LNG5A0 INTEGER 0495 40,260 && LNG5B INTEGER 048E 40,287 && LNG5C INTEGER 048F 40,307 && LNG5D INTEGER 0494 40,312 && LNG6 INTEGER 0490 40,432 && LNG7 INTEGER 0491 40,553 && LNG7A INTEGER 0492 40,563 && LNGE01 INTEGER 0496 40,263 &$ LNGE02 INTEGER 0497 40,68$$ LNGE03 INTEGER 0498 40,90$> LNGE04 INTEGER 0499 40,134,144,215,225,299,417,470 >" LNGE05 INTEGER 049A 40 ". LNGE06 INTEGER 04A4 40,115,196,452 .& LNGE07 INTEGER 049B 40,151 && LNGE08 INTEGER 049C 40,112 && LNGE09 INTEGER 049D 40,193 && LNGE10 INTEGER 049E 40,283 && LNGE11 INTEGER 049F 40,360 && LNGE12 INTEGER 04A0 40,331 && LNGE13 INTEGER 04A1 40,279 && LNGE14 INTEGER 04A2 40,386 && LNGE15 INTEGER 04A3 40,503 && LNGE16 INTEGER 04A6 40,572 && LNGE17 INTEGER 04A7 40,337 && LNGE18 INTEGER 04A8 40,393 &. LNGG1 INTEGER 04A5 40,170,242,545 ." LNGOP INTEGER 0493 40 "" LRPGWK INTEGER 0334 D 1,6"€ LU INTEGER 041A D 1,53,58,68,90,96,112,115,134,144,151,170,177,193,196,215,225,242,249,260,263,266,279,283,287,299,€^ 307,312,331,337,360,386,393,417,432,452,470,503,545,553,563,572^b M INTEGER 04C3 137,219,483,485,486,487,488,493,495,496,497,498,499,500,501,528,539b2 MCHARS INTEGER 04E2 447,448,501,539,5422& MSG1 INTEGER 0006 6,9,53 && MSG2 INTEGER 001A 6,10,58&& MSG3 INTEGER 0032 6,11,96&( MSG4 INTEGER 009E 6,12,177 (( MSG5 INTEGER 00E5 6,13,249 (( MSG5A INTEGER 00F9 6,15,266 (( MSG5A0 INTEGER 0266 6,14,260 (( MSG5B INTEGER 013F 6,16,287 (( MSG5C INTEGER 0157 6,17,307 (( MSG5D INTEGER 0172 6,18,312 (( MSG6 INTEGER 01CF 6,19,432 (( MSG7 INTEGER 0222 6,20,553 (( MSG7A INTEGER 0237 6,21,563 (t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 24 DATE: 08/29/84 TIME: 2231 t( MSGE01 INTEGER 029C 6,22,263 (& MSGE02 INTEGER 02AB 6,23,68&& MSGE03 INTEGER 02D1 6,24,90&€ MSGE04 INTEGER 02F6 6,25,128,129,130,134,139,144,209,210,211,215,220,225,293,294,295,299,302,303,304,411,412,413,417,€: 425,426,427,464,465,466,470:$ MSGE05 INTEGER 030D 6,26 $0 MSGE06 INTEGER 0320 6,27,115,196,452 0( MSGE07 INTEGER 0339 6,28,151 (( MSGE08 INTEGER 0351 6,29,112 (( MSGE09 INTEGER 0372 6,30,193 (( MSGE10 INTEGER 0393 6,31,283 (( MSGE11 INTEGER 03B6 6,32,360 (( MSGE12 INTEGER 03D2 6,33,331 (( MSGE13 INTEGER 03EC 6,34,279 (( MSGE14 INTEGER 03FE 6,35,386 (( MSGE15 INTEGER 0415 6,36,503 (( MSGE16 INTEGER 043A 6,37,572 (( MSGE17 INTEGER 044F 6,38,337 (( MSGE18 INTEGER 046D 6,39,393 (0 MSGG1 INTEGER 0262 6,40,170,242,545 0z N INTEGER 04BB 104,105,109,110,114,153,164,168,186,190,191,195,227,235,239,445,451,471,472,505,527,536,541z. NCHARS INTEGER 04E0 436,437,501,542.2 NCOMMA INTEGER 04E7 493,494,495,496,49828 NLKEY INTEGER 041C D 1,179,190,191,227,239,2408< NNAME INTEGER 041D D 1,138,219,436,473,505,527,541<4 NSKEY INTEGER 041E D 1,99,109,110,153,168 4X NSLCT INTEGER 041F D 1,251,281,320,334,341,363,366,369,371,373,374,390,399,429XB NT INTEGER 04E1 446,447,475,476,478,514,521,526,543B4 NTFLDS INTEGER 0420 D 1,438,476,514,521,5434€ OPBUF INTEGER 00C3 D 1,5,53,54,55,58,61,95,96,101,107,111,112,123,133,134,143,144,148,150,151,169,170,171,176,177,182,€€ 188,192,193,204,214,215,224,225,231,241,242,243,248,249,252,253,254,259,260,261,265,266,267,271, €€ 272,273,274,275,276,277,278,279,282,283,285,286,287,291,292,298,299,306,307,308,309,311,312,316, €€ 322,330,331,336,337,343,359,360,385,386,392,393,408,410,416,417,431,432,441,449,459,469,470,509, €R 517,544,545,547,552,553,555,558,562,563,566,571,572R~ OPHLD INTEGER 0330 D 1,6,107,108,166,188,189,237,291,292,316,324,333,340,345,352,408,409,410,449,450,538,555,556,557~D PGMKEY INTEGER 02FA D 1,6,74,75,76,78,79,82,83,84,85,91,92 D& PGMREC INTEGER 0360 D 1,6,86 && PGMRQB INTEGER 0093 D 1,4,86 &" PRCREC INTEGER 038D D 1,6"" PRCRQB INTEGER 0402 D 1,4"" PRCWRK INTEGER 03F3 D 1,4"2 Q2SAVE INTEGER 00E3 D 1,5,61,62,63,69,93 26 Q3SORT INTEGER 00E4 D 1,5,98,154,156,160,163 6* Q4LVLB INTEGER 0120 D 1,5,178,233** Q5ANS INTEGER 02C8 D 1,5,261,262*€ Q5SLCT INTEGER 0129 D 1,5,254,256,285,302,303,304,305,310,317,328,335,349,365,367,370,372,378,379,391,401,403,425,426, €" 427"F Q6EPOS INTEGER 0253 D 1,5,434,528,529,530,531,532,533,534,535F6 Q6NAME INTEGER 01D3 D 1,5,139,220,433,474,51166 Q6TOT INTEGER 0206 D 1,5,435,477,519,522,5256* Q7RPT INTEGER 02B9 D 1,5,554,560*‚ RADDR INTEGER 0305 D 1,6,97,102,103,104,172,173,174,180,183,184,185,244,245,246,257,268,269,270,439,442,443,444,548,549 ‚D ,550,564,567,568,569,575,577,579,581 D& RPTG INTEGER 0002 6,43,59&t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 25 DATE: 08/29/84 TIME: 2231 t" RPTPGM INTEGER 002D D 1,4"" RPTTBL INTEGER 001E D 1,4"" RPTWKE INTEGER 003C D 1,4"" RPTWKP INTEGER 0421 D 1,4"" TBL INTEGER 02C9 D 1,6"" TBLKEY INTEGER 02FD D 1,6"€ TBLREC INTEGER 0306 D 1,6,131,132,158,212,213,296,297,313,314,315,414,415,420,421,423,467,468,482,484,489,490,491,513, €6 522,524,532,533,534,53566 TBLRQB INTEGER 007B D 1,4,131,212,296,414,4676‚ TC INTEGER 03F0 D 1,6,53,58,68,90,96,112,115,134,144,151,170,177,193,196,215,225,242,249,260,263,266,279,283,287,299 ‚` ,307,312,331,337,360,386,393,417,432,452,470,503,545,553,563,572 `" UTEMSG INTEGER 03CE D 1,6"" UTIFIL INTEGER 0000 D 1,4"& UTIRQB INTEGER 004B D 1,4,59 &: UTREC INTEGER 02D0 D 1,6,59,64,65,66,67,71,72,73:" WKERQB INTEGER 00AB D 1,4"" WKPRQB INTEGER 0430 D 1,4"‚ XYN INTEGER 03EF D 1,6,53,58,68,90,96,112,115,134,144,151,170,177,193,196,215,225,242,249,260,263,266,279,283,287,299 ‚` ,307,312,331,337,360,386,393,417,432,452,470,503,545,553,563,572 `> ZERO INTEGER 0004 6,43,68,90,115,196,263,452,503 >   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < 8 ASCBIN SUBROUTINE 0CAD 43,79,355,395,482,484,4928$ BINASC SUBROUTINE 0597 43,81$‚ CCSBLK SUBROUTINE 0C6F 95,98,111,133,143,150,169,176,178,192,214,224,241,248,256,259,265,278,282,286,298,306,311,330,336, ‚V 359,385,392,416,431,433,434,435,469,544,552,554,562,571V& CCSCST SUBROUTINE 07F5 138,220&V CCSGET SUBROUTINE 0C3C 122,148,158,204,231,322,343,378,379,459,509,517,524,558V2 CCSMVA SUBROUTINE 0C8C 291,410,474,477,5222V CCSPUT SUBROUTINE 0C47 124,154,156,160,163,206,233,328,349,461,511,519,525,560VB PGSEDT SUBROUTINE 0BF3 43,101,171,182,243,267,441,547,566 B. PGSJL SUBROUTINE 0B4C 43,370,372,403 .. PGSJR SUBROUTINE 0B43 43,365,367,401 .$ PGSLST SUBROUTINE 0524 43,56$8 READR SUBROUTINE 0C5D 58,86,131,212,296,414,4678‚ WTREAD SUBROUTINE 0C20 53,58,68,90,96,112,115,134,144,151,170,177,193,196,215,225,242,249,260,263,266,279,283,287,299,307 ‚\ ,312,331,337,360,386,393,417,432,452,470,503,545,553,563,572 \   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < ( 100 050D 46,53,55 (( 200 0527 47,58,63 ($ 210 0576 67,71$$ 220 05B8 76,89$( 300 05D1 49,95,97 (t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 26 DATE: 08/29/84 TIME: 2231 t& 308 0602 104,175&& 310 060B 107,167&& 312 0628 109,114&& 315 0636 114,117&& 316 0657 119,126&& 317 065C 124,127&& 320 068A 132,136&& 330 06A3 137,142&& 335 06B2 140,146&& 340 06D2 149,153&& 350 06F2 156,161&* 380 070B 108,116,168*2 390 071C 112,135,145,152,1712* 400 0738 50,176,180 *& 408 0766 185,247&& 410 076E 188,238&& 412 078B 190,195&& 415 079A 195,198&& 416 07BB 200,207&& 417 07C0 205,208&& 420 07EB 213,217&& 430 0804 218,223&& 435 0814 221,227&& 440 0837 228,234&* 480 0844 189,197,239*. 490 0857 193,216,226,243.. 500 0873 51,248,253,257 .& 505 0893 252,256&& 507 089B 258,264&* 508 08BE 262,265,430** 509 08CA 266,280,284*> 510 0914 271,272,273,274,275,276,277,281>& 512 0926 281,285&" 515 092B 285"& 516 0937 287,300&& 520 0972 297,301&" 525 0972 301"& 530 0981 305,309&" 534 099B 309"* 535 099F 305,308,311*: 536 09B8 315,332,338,361,387,394,418:& 538 09EA 325,327&& 539 09F3 329,351&* 540 0A00 320,329,333*& 541 0A08 323,334&& 542 0A21 335,339&& 543 0A44 346,348&* 545 0A4E 341,350,352*& 546 0A56 345,353&: 547 0A72 357,359,362,397,398,422,424:& 548 0A81 357,362&& 550 0AA9 364,369&& 552 0AC1 367,373&& 554 0AEB 376,384&t FTN 3.3B (OPT = LPC) PGGEN1 PAGE 27 DATE: 08/29/84 TIME: 2231 t& 555 0AED 381,385&& 556 0AFD 380,388&& 560 0AFF 324,389&& 563 0B1B 391,395&" 564 0B32 397"& 566 0B4B 400,403&& 570 0B54 317,405&& 575 0B98 415,419&" 576 0B98 419"* 577 0BAF 420,421,423*& 578 0BBD 423,425&. 580 0BC8 388,402,404,428.. 600 0BCF 48,431,439,504 .& 608 0C0A 444,551&& 610 0C16 449,540&& 615 0C2B 451,454&& 616 0C4B 456,462&& 617 0C50 460,463&. 618 0CA8 471,472,475,479.& 620 0CAC 468,481&" 630 0CAC 481"& 640 0D13 490,500&& 650 0D2F 502,505&& 655 0D53 506,512&& 660 0D78 514,520&& 665 0D94 513,527&" 670 0DC6 535"* 680 0DDA 450,453,541*& 690 0DFA 479,546&* 700 0E1D 51,552,564 *& 702 0E2B 553,573&& 715 0E4D 556,561&* 720 0E4F 556,562,570*& 730 0E7C 559,571&` 1000 0E8B 43,54,57,62,70,87,94,102,172,183,240,244,255,268,442,548,567,574 `& 1010 0E95 88,577 &. 1100 0E99 60,64,65,66,579.B 1900 0E9D 103,173,184,245,269,443,549,568,581B. 1999 0EA0 575,578,580,582. PGGEN1 0EA3 1  t FTN 3.3B (OPT = LPC) PGGEN3 PAGE 1 DATE: 08/29/84 TIME: 2240 t^ 1 SUBROUTINE PGGEN3 B9200001^^ 1 1 /B92 F CCS CCS 3.0 POST 3.0 PSR 12/28/2 SL-149********^^ C B9200003^^ C CYBERCREDIT SYSTEM VERSION 3 B9200004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B9200005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B9200006^^ C B9200007^^ C BUILD PROCEDURE STREAM FILE B9200008^^ 2 COMMON /CBLK1/UTIFIL,DELQM,RPTTBL,RPTPGM,RPTWKE,UTIRQB,DLQRQB, B9200009^^ 2 2TBLRQB,PGMRQB,WKERQB,OPBUF,Q2SAVE,Q3SORT,Q4LVLB,Q5SLCT,Q6NAME, B9200010^^ 2 3Q6TOT,Q6EPOS,Q7RPT,Q5ANS,TBL,HPGMN,UTREC,PGMKEY,TBLKEY,BIN,ISTAT, B9200011^^ 2 4HPKEY,RADDR,TBLREC,OPHLD,D1TYPE,D1LNG,LRPGWK,IHOLD2,PGMREC,IND, B9200012^^ 2 5PRCREC,ERRMSG,UTEMSG,ABTMSG,XYN,TC,CS,PRCWRK,PRCRQB,LU B9200013^^ 3 COMMON /CBLK1/IMAXC,NLKEY,NNAME,NSKEY,NSLCT,NTFLDS,RPTWKP,WKPRQB B9200014^^ C B9200015^^ C FILE RETRIEVAL B9200016^^ 4 INTEGER UTIFIL(15),DELQM(15),RPTTBL(15),RPTPGM(15),RPTWKE(15), B9200017^^ 4 2 UTIRQB(24),DLQRQB(24),TBLRQB(24),PGMRQB(24),WKERQB(24), B9200018^^ 4 3 PRCWRK(15),PRCRQB(24),RPTWKP(15),WKPRQB(24) B9200019^^ C B9200020^^ C OPERATOR RESPONSES B9200021^^ 5 INTEGER OPBUF(32),Q2SAVE,Q3SORT(60),Q4LVLB(9),Q5SLCT(170), B9200022^^ 5 2 Q6NAME(51),Q6TOT(77),Q6EPOS(102),Q7RPT(15),Q5ANS B9200023^^ C B9200024^^ C MISCELLANEOUS B9200025^^ 6 INTEGER XYN,TC,CS(2),TBL(4),HPGMN(3),RPTG(2),UTREC(42),ISTAT, B9200026^^ 6 2 ZERO,PGMKEY(3),TBLKEY(3),COMMA,BIN,HPKEY(3),RADDR,TBLREC(42), B9200027^^ 6 3 OPHLD,D1TYPE,D1LNG(2),LRPGWK(42),IHOLD2(2),PGMREC(42),IND(3), B9200028^^ 6 4 PRCREC(42),ERRMSG(23),UTEMSG(26),ABTMSG(7) B9200029^^ C B9200030^^ 7 INTEGER PRC012(07),PRC014(02),PRC016(08),PRC018(1) B9200031^^ 8 INTEGER PRC010(8),PRC020(3),PRC030(10),PRC040(7),PRC050(7), B9200032^^ C***************************************************** ???*A??? ********^^ 8 2 PRC060(3),PRC070(8),PRC080(8),PRC090(4),PRC100(37), ********^^ C***************************************************** ???*A??? ********^^ 8 3 PRC110(8),PRC120(7),PRC130(3),PRC140(9),PRC150(3), B9200034^^ 8 4 PRC105(2),PRC160(2),PRC170(9),PRC180(1),PRC190(3) B9200035^^ C B9200036^^ C SKELETON PROCEDURE JOB STREAM B9200037^^ 9 DATA PRC010 /' * BEGIN EXTRACT'/ B9200038^^ 10 DATA PRC012 /'INPUT=PRFPG0XX'/ B9200039^^ 11 DATA PRC014 /'UTIL'/ B9200040^^ 12 DATA PRC016 /'CLEAR,FN=PGEXTR '/ B9200041^^ 13 DATA PRC018 /'EX'/ B9200042^^ 14 DATA PRC020 /'RPTEXX'/ B9200043^^ 15 DATA PRC030 /' * EXTRACT COMPLETE '/ B9200044^^ 16 DATA PRC040 /' * BEGIN SORT '/ B9200045^^ 17 DATA PRC050 /'INPUT=PRFPG0XX'/ B9200046^^ 18 DATA PRC060 /'DSORT '/ B9200047^^ 19 DATA PRC070 /'FN=PGEXTR,CCS20 '/ B9200048^^ 20 DATA PRC080 /'F2=PGEXTR,CCS20,'/ B9200049^^ 21 DATA PRC090 /'OP=T,F,A'/ B9200050^^ C***************************************************** ???*A??? ********^^ 22 DATA PRC100 /'KF= ',35*$2020/ ********^t FTN 3.3B (OPT = LPC) PGGEN3 PAGE 2 DATE: 08/29/84 TIME: 2240 t^ C***************************************************** ???*A??? ********^^ 23 DATA PRC105 /'SL=I'/ B9200052^^ 24 DATA PRC110 /' * SORT COMPLETE'/ B9200053^^ 25 DATA PRC120 /' * BEGIN PRINT'/ B9200054^^ 26 DATA PRC130 /'RPTPXX'/ B9200055^^ 27 DATA PRC140 /' * PRINT COMPLETE '/ B9200056^^ 28 DATA PRC150 /'PGCNT2'/ B9200057^^ 29 DATA PRC160 / 'UTIL' / B9200058^^ 30 DATA PRC170 / 'FLUSH,HO=LOCL,DO=-' / B9200059^^ 31 DATA PRC180 / 'EX' / B9200060^^ 32 DATA PRC190 / 'MNUPRO' / B9200061^^ C B9200062^^ C LENGTHS FOR PROCEDURE STREAM CONSTANTS B9200063^^ 33 DATA LPC010/16/,LPC020/6/,LPC030/20/,LPC040/14/,LPC050/14/, B9200064^^ C***************************************************** ???A*??? ********^^ 33 2 LPC060/6/,LPC070/16/,LPC080/16/,LPC090/8/,LPC100/73/, ********^^ C***************************************************** ???A*??? ********^^ 33 3 LPC110/16/,LPC120/14/,LPC130/6/,LPC140/18/,LPC150/6/, B9200066^^ 33 4 LPC105/4/,LPC160/4/,LPC170/18/,LPC180/2/,LPC190/6/ B9200067^^ C B9200068^^ 34 DATA RPTG/'RPTG'/,ZERO/0/,COMMA/$002C/ B9200069^^ C B9200070^^ C B9200071^^ C B9200072^^ C********* WRITE RECORD TO PRCWRK FILE B9200073^^ C B9200074^^ 35 GO TO 5100 B9200075^^ 36 5000 CALL PUTS(PRCRQB,PRCREC,1,ISTAT) B9200076^^ 37 IF (ISTAT.LT.0) GO TO 5920 B9200077^^ C CLEAR BUFFER B9200078^^ 38 CALL CCSBLK(PRCREC,84) B9200079^^ 39 GO TO IRTN B9200080^^ C B9200081^^ C********* BUILD PROCEDURE STREAM B9200082^^ C********* FOR EXECUTION OF THE GENERATED RPG PROGRAM B9200083^^ C B9200084^^ C B9200085^^ 40 5100 CONTINUE B9200086^^ C B9200087^^ C‚ B9200088^^ 41 PRC020(3)=HPGMN(3) B9200089^^ 42 PRC050(7)=HPGMN(3) B9200090^^ 43 PRC130(3)=HPGMN(3) B9200091^^ 44 PRC012(7)=HPGMN(3) B9200092^^ C WRITE OUT BEGINNING ... EXTRACT PROGRAM B9200093^^ 45 5110 CALL CCSMVA(PRC010,1,LPC010,PRCREC,1,LPC010) B9200094^^ 46 ASSIGN 5120 TO IRTN B9200095^^ 47 GO TO 5000 B9200096^^ 48 5120 CALL CCSMVA(PRC012,1,14,PRCREC,1,14) B9200097^^ 49 ASSIGN 5130 TO IRTN B9200098^^ 50 GO TO 5000 B9200099^^ 51 5130 CALL CCSMVA(PRC014,1,4,PRCREC,1,4) B9200100^^ 52 ASSIGN 5140 TO IRTN B9200101^^ 53 GO TO 5000 B9200102^t FTN 3.3B (OPT = LPC) PGGEN3 PAGE 3 DATE: 08/29/84 TIME: 2240 t^ 54 5140 CALL CCSMVA(PRC016,1,16,PRCREC,1,16) B9200103^^ 55 ASSIGN 5150 TO IRTN B9200104^^ 56 GO TO 5000 B9200105^^ 57 5150 CALL CCSMVA(PRC018,1,2,PRCREC,1,2) B9200106^^ 58 ASSIGN 5211 TO IRTN B9200107^^ 59 GO TO 5000 B9200108^^ 60 5211 CALL CCSMVA(PRC020,1,LPC020,PRCREC,1,LPC020) B9200109^^ 61 ASSIGN 5212 TO IRTN B9200110^^ 62 GO TO 5000 B9200111^^ 63 5212 CALL CCSMVA(PRC030,1,LPC030,PRCREC,1,LPC030) B9200112^^ 64 ASSIGN 5220 TO IRTN B9200113^^ 65 GO TO 5000 B9200114^^ C B9200115^^ C CHECK FOR A SORT REQUIREMENT B9200116^^ 66 5220 IF (NSKEY.EQ.0) GO TO 5300 B9200117^^ C YES, SET UP SORT B9200118^^ 67 CALL CCSMVA(PRC040,1,LPC040,PRCREC,1,LPC040) B9200119^^ 68 ASSIGN 5221 TO IRTN B9200120^^ 69 GO TO 5000 B9200121^^ 70 5221 CALL CCSMVA(PRC050,1,LPC050,PRCREC,1,LPC050) B9200122^^ 71 ASSIGN 5222 TO IRTN B9200123^^ 72 GO TO 5000 B9200124^^ 73 5222 CALL CCSMVA(PRC060,1,LPC060,PRCREC,1,LPC060) B9200125^^ 74 ASSIGN 5223 TO IRTN B9200126^^ 75 GO TO 5000 B9200127^^ 76 5223 CALL CCSMVA(PRC070,1,LPC070,PRCREC,1,LPC070) B9200128^^ 77 ASSIGN 5224 TO IRTN B9200129^^ 78 GO TO 5000 B9200130^^ 79 5224 CALL CCSMVA(PRC080,1,LPC080,PRCREC,1,LPC080) B9200131^^ 80 ASSIGN 5225 TO IRTN B9200132^^ 81 GO TO 5000 B9200133^^ 82 5225 CALL CCSMVA(PRC090,1,LPC090,PRCREC,1,LPC090) B9200134^^ 83 ASSIGN 5230 TO IRTN B9200135^^ 84 GO TO 5000 B9200136^^ C SET UP SORT KEY POSITION AND LENGTH B9200137^^ C Q3SORT CONTAINS A/D,KEYNAME B9200138^^ C Q6EPOS CONTAINS LENGTH OF EACH DATA FIELD B9200139^^ C Q6NAME CONTAINS NAME OF EACH DATA FIELD FOR RPT B9200140^^ C BEG POS FOR SORT IS CALCULATED B9200141^^ C B9200142^^ 85 5230 CONTINUE B9200143^^ 86 IPOS=3 B9200144^^ 87 DO 5250 J=1,NSKEY B9200145^^ 88 BIN=0 B9200146^^ 89 IPW1=1 B9200147^^ 90 DO 5240 K=1,NNAME B9200148^^ 91 CALL CCSCST(Q3SORT,IPOS,6,Q6NAME,IPW1,6,IHOLD) B9200149^^ 92 IF (IHOLD.EQ.0) GO TO 5245 B9200150^^ C CALC STARTING POSITION FOR SORT FIELD B9200151^^ 93 CALL ASCBIN(Q6EPOS(IPW1+4),LNG) B9200152^^ 94 BIN=BIN+LNG B9200153^^ 95 IPW1=IPW1+6 B9200154^^ 96 5240 CONTINUE B9200155^^ C FOUND SORT KEY IN DATA NAME LIST B9200156^t FTN 3.3B (OPT = LPC) PGGEN3 PAGE 4 DATE: 08/29/84 TIME: 2240 t^ 97 5245 CONTINUE B9200157^^ C GET LENGTH OF DATA FIELD B9200158^^ 98 ICOL=IPOS+5 B9200159^^ 99 IPW1=(((K*6)-1)*2)-3 B9200160^^ 100 CALL CCSMVA(Q6EPOS,IPW1,4,Q3SORT,ICOL,4) B9200161^^ C GET STARTING POSITION B9200162^^ 101 BIN=BIN+1 B9200163^^ 102 CALL BINASC(BIN,IHOLD2) B9200164^^ 103 CALL CCSMVA(IHOLD2,1,4,Q3SORT,IPOS,4) B9200165^^ C SEPARATE FIELDS BY COMMA B9200166^^ 104 IHOLD=$002C B9200167^^ 105 ICOL=IPOS+4 B9200168^^ 106 CALL CCSPUT(IHOLD,ICOL,Q3SORT) B9200169^^ C BUMP COUNTER B9200170^^ 107 IPOS=IPOS+12 B9200171^^ 108 5250 CONTINUE B9200172^^ C CHECK TO SEE IF SORT KEYS FIT ON 1 RECORD B9200173^^ 109 L=(NSKEY*12)-1 B9200174^^ 110 IF (L.GT.69) L=69 B9200175^^ C ELEMINATE TRAILING COMMA WHEN MOVING FROM Q5SLCT B9200176^^ 111 CALL CCSMVA(Q3SORT,1,L,PRC100,4,L) B9200177^^ 112 CALL CCSMVA(PRC100,1,LPC100,PRCREC,1,LPC100) B9200178^^ 113 ASSIGN 5270 TO IRTN B9200179^^ 114 GO TO 5000 B9200180^^ 115 5270 L=(NSKEY*12)-1 B9200181^^ 116 IF (L.LE.69) GO TO 5275 B9200182^^ C SET UP 2ND KEY RECORD B9200183^^ 117 L=L-69 B9200184^^ 118 CALL CCSMVA(Q3SORT,70,L,PRCREC,1,L) B9200185^^ 119 ASSIGN 5275 TO IRTN B9200186^^ 120 GO TO 5000 B9200187^^ 121 5275 CALL CCSMVA(PRC105,1,LPC105,PRCREC,1,LPC105) B9200188^^ 122 ASSIGN 5280 TO IRTN B9200189^^ 123 GO TO 5000 B9200190^^ 124 5280 CALL CCSMVA(PRC110,1,LPC110,PRCREC,1,LPC110) B9200191^^ 125 ASSIGN 5300 TO IRTN B9200192^^ 126 GO TO 5000 B9200193^^ C SET UP RPG PRINT PROGRAM B9200194^^ 127 5300 CALL CCSMVA(PRC120,1,LPC120,PRCREC,1,LPC120) B9200195^^ 128 ASSIGN 5310 TO IRTN B9200196^^ 129 GO TO 5000 B9200197^^ 130 5310 CALL CCSMVA(PRC130,1,LPC130,PRCREC,1,LPC130) B9200198^^ 131 ASSIGN 5320 TO IRTN B9200199^^ 132 GO TO 5000 B9200200^^ 133 5320 CALL CCSMVA(PRC140,1,LPC140,PRCREC,1,LPC140) B9200201^^ 134 ASSIGN 5330 TO IRTN B9200202^^ 135 GO TO 5000 B9200203^^ 136 5330 CALL CCSMVA(PRC150,1,LPC150,PRCREC,1,LPC150) B9200204^^ 137 ASSIGN 5340 TO IRTN B9200205^^ 138 GO TO 5000 B9200206^^ 139 5340 CALL CCSMVA(PRC050,1,LPC050,PRCREC,1,LPC050) B9200207^^ 140 ASSIGN 5350 TO IRTN B9200208^^ 141 GO TO 5000 B9200209^^ 142 5350 CALL CCSMVA(PRC160,1,LPC160,PRCREC,1,LPC160) B9200210^t FTN 3.3B (OPT = LPC) PGGEN3 PAGE 5 DATE: 08/29/84 TIME: 2240 t^ 143 ASSIGN 5360 TO IRTN B9200211^^ 144 GO TO 5000 B9200212^^ 145 5360 CALL CCSMVA(PRC170,1,LPC170,PRCREC,1,LPC170) B9200213^^ 146 ASSIGN 5370 TO IRTN B9200214^^ 147 GO TO 5000 B9200215^^ 148 5370 CALL CCSMVA(PRC180,1,LPC180,PRCREC,1,LPC180) B9200216^^ 149 ASSIGN 5380 TO IRTN B9200217^^ 150 GO TO 5000 B9200218^^ 151 5380 CALL CCSMVA(PRC190,1,LPC190,PRCREC,1,LPC190) B9200219^^ 152 ASSIGN 5400 TO IRTN B9200220^^ 153 GO TO 5000 B9200221^^ C B9200222^^ C B9200223^^ C BUILD ENDING JCL FOR CATALOG OF PROCEDURE STREAM B9200224^^ C B9200225^^ C**** INSERT CODE B9200226^^ C B9200227^^ 154 5400 CONTINUE B9200228^^ 155 RADDR=$0000 B9200229^^ 156 GO TO 5999 B9200230^^ 157 5920 RADDR=$8020 B9200231^^ 158 5999 CONTINUE B9200232^^ 159 RETURN B9200233^^ 160 END B9200234^t FTN 3.3B (OPT = LPC) PGGEN3 PAGE 6 DATE: 08/29/84 TIME: 2240 t COMMON  LABEL $0448 ( 1096)    PROGRAM LENGTH $02B2 ( 690)   EXTERNALS 2 PUTS CCSBLK CCSMVA CCSCST ASCBIN BINASC CCSPUT 2 t FTN 3.3B (OPT = LPC) PGGEN3 PAGE 7 DATE: 08/29/84 TIME: 2240 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " 8020 (-32735) 00CA 157"‚ 0001 (1) 0000 7,8,36,45,48,51,54,57,60,63,67,70,73,76,79,82,87,89,90,99,101,103,109,111,112,115,118,121,124,127, ‚> 130,133,136,139,142,145,148,151>( 0002 (2) 00BE 57,57,99 (8 0004 (4) 00BC 51,51,93,100,103,105,111 8* 0006 (6) 00C3 91,91,95,99** 000C (12) 00C7 107,109,115*$ 000E (14) 00BB 48,48$$ 0010 (16) 00BD 54,54$" 0046 (70) 00C9 118"" 0054 (84) 00B9 38 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " ABTMSG INTEGER 03E8 D 1,6"0 BIN INTEGER 0300 D 1,6,88,94,101,1020$ COMMA INTEGER 0004 6,34 $" CS INTEGER 03F1 D 1,6"" D1LNG INTEGER 0332 D 1,6"" D1TYPE INTEGER 0331 D 1,6"" DELQM INTEGER 000F D 1,4"" DLQRQB INTEGER 0063 D 1,4"" ERRMSG INTEGER 03B7 D 1,6". HPGMN INTEGER 02CD D 1,6,41,42,43,44." HPKEY INTEGER 0302 D 1,6"0 ICOL INTEGER 00C6 97,98,100,105,1060, IHOLD INTEGER 00C4 91,92,104,106,* IHOLD2 INTEGER 035E D 1,6,102,103* IMAXC INTEGER 041B D 1 " IND INTEGER 038A D 1,6"6 IPOS INTEGER 00BF 85,86,91,98,103,105,10764 IPW1 INTEGER 00C1 88,89,91,93,95,99,1004| IRTN INTEGER 00BA 38,46,49,52,55,58,61,64,68,71,74,77,80,83,113,119,122,125,128,131,134,137,140,143,146,149,152|( ISTAT INTEGER 0301 D 1,6,36,37(" J INTEGER 00C0 86 "$ K INTEGER 00C2 89,99$> L INTEGER 00C8 108,109,110,111,115,116,117,118>$ LNG INTEGER 00C5 93,94$$ LPC010 INTEGER 00A5 32,45$$ LPC020 INTEGER 00A6 32,60$$ LPC030 INTEGER 00A7 32,63$$ LPC040 INTEGER 00A8 32,67$t FTN 3.3B (OPT = LPC) PGGEN3 PAGE 8 DATE: 08/29/84 TIME: 2240 t( LPC050 INTEGER 00A9 32,70,139($ LPC060 INTEGER 00AA 32,73$$ LPC070 INTEGER 00AB 32,76$$ LPC080 INTEGER 00AC 32,79$$ LPC090 INTEGER 00AD 32,82$& LPC100 INTEGER 00AE 32,112 && LPC105 INTEGER 00B4 32,121 && LPC110 INTEGER 00AF 32,124 && LPC120 INTEGER 00B0 32,127 && LPC130 INTEGER 00B1 32,130 && LPC140 INTEGER 00B2 32,133 && LPC150 INTEGER 00B3 32,136 && LPC160 INTEGER 00B5 32,142 && LPC170 INTEGER 00B6 32,145 && LPC180 INTEGER 00B7 32,148 && LPC190 INTEGER 00B8 32,151 &" LRPGWK INTEGER 0334 D 1,6" LU INTEGER 041A D 1 NLKEY INTEGER 041C D 1 $ NNAME INTEGER 041D D 1,90 $. NSKEY INTEGER 041E D 1,66,87,109,115. NSLCT INTEGER 041F D 1 NTFLDS INTEGER 0420 D 1 " OPBUF INTEGER 00C3 D 1,5"" OPHLD INTEGER 0330 D 1,6"" PGMKEY INTEGER 02FA D 1,6"" PGMREC INTEGER 0360 D 1,6"" PGMRQB INTEGER 0093 D 1,4"& PRC010 INTEGER 0017 7,9,45 &* PRC012 INTEGER 0005 6,10,44,48 *& PRC014 INTEGER 000C 6,11,51&& PRC016 INTEGER 000E 6,12,54&& PRC018 INTEGER 0016 6,13,57&* PRC020 INTEGER 001F 7,14,41,60 *& PRC030 INTEGER 0022 7,15,63&& PRC040 INTEGER 002C 7,16,67&. PRC050 INTEGER 0033 7,17,42,70,139 .& PRC060 INTEGER 003A 7,18,73&& PRC070 INTEGER 003D 7,19,76&& PRC080 INTEGER 0045 7,20,79&& PRC090 INTEGER 004D 7,21,82&, PRC100 INTEGER 0051 7,22,111,112 ,( PRC105 INTEGER 0094 7,23,121 (( PRC110 INTEGER 0076 7,24,124 (( PRC120 INTEGER 007E 7,25,127 (* PRC130 INTEGER 0085 7,26,43,130*( PRC140 INTEGER 0088 7,27,133 (( PRC150 INTEGER 0091 7,28,136 (( PRC160 INTEGER 0096 7,29,142 (( PRC170 INTEGER 0098 7,30,145 (( PRC180 INTEGER 00A1 7,31,148 (( PRC190 INTEGER 00A2 8,32,151 (€ PRCREC INTEGER 038D D 1,6,36,38,45,48,51,54,57,60,63,67,70,73,76,79,82,112,118,121,124,127,130,133,136,139,142,145,148,€" 151"t FTN 3.3B (OPT = LPC) PGGEN3 PAGE 9 DATE: 08/29/84 TIME: 2240 t& PRCRQB INTEGER 0402 D 1,4,36 &" PRCWRK INTEGER 03F3 D 1,4"" Q2SAVE INTEGER 00E3 D 1,5": Q3SORT INTEGER 00E4 D 1,5,91,100,103,106,111,118 :" Q4LVLB INTEGER 0120 D 1,5"" Q5ANS INTEGER 02C8 D 1,5"" Q5SLCT INTEGER 0129 D 1,5"* Q6EPOS INTEGER 0253 D 1,5,93,100 *& Q6NAME INTEGER 01D3 D 1,5,91 &" Q6TOT INTEGER 0206 D 1,5"" Q7RPT INTEGER 02B9 D 1,5"* RADDR INTEGER 0305 D 1,6,155,157*$ RPTG INTEGER 0001 6,34 $" RPTPGM INTEGER 002D D 1,4"" RPTTBL INTEGER 001E D 1,4"" RPTWKE INTEGER 003C D 1,4"" RPTWKP INTEGER 0421 D 1,4"" TBL INTEGER 02C9 D 1,6"" TBLKEY INTEGER 02FD D 1,6"" TBLREC INTEGER 0306 D 1,6"" TBLRQB INTEGER 007B D 1,4"" TC INTEGER 03F0 D 1,6"" UTEMSG INTEGER 03CE D 1,6"" UTIFIL INTEGER 0000 D 1,4"" UTIRQB INTEGER 004B D 1,4"" UTREC INTEGER 02D0 D 1,6"" WKERQB INTEGER 00AB D 1,4"" WKPRQB INTEGER 0430 D 1,4"" XYN INTEGER 03EF D 1,6"$ ZERO INTEGER 0003 6,34 $   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " ASCBIN SUBROUTINE 01AD 92 "" BINASC SUBROUTINE 01CD 101"" CCSBLK SUBROUTINE 00D9 37 "" CCSCST SUBROUTINE 019B 90 "‚ CCSMVA SUBROUTINE 0272 44,48,51,54,57,60,63,67,70,73,76,79,82,100,103,111,112,118,121,124,127,130,133,136,139,142,145,148 ‚$ ,151 $" CCSPUT SUBROUTINE 01DD 105"" PUTS SUBROUTINE 00CD 34 "t FTN 3.3B (OPT = LPC) PGGEN3 PAGE 10 DATE: 08/29/84 TIME: 2240 t   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < | 5000 00CC 34,47,50,53,56,59,62,65,69,72,75,78,81,84,114,120,123,126,129,132,135,138,141,144,147,150,153|$ 5100 00DD 34,40$" 5110 00E6 44 "$ 5120 00F2 45,48$$ 5130 00FD 48,51$$ 5140 0108 51,54$$ 5150 0113 54,57$$ 5211 011E 57,60$$ 5212 0129 60,63$$ 5220 0134 63,66$$ 5221 0146 67,70$$ 5222 0152 70,73$$ 5223 015E 73,76$$ 5224 016A 76,79$$ 5225 0177 79,82$$ 5230 0183 82,85$$ 5240 01B7 89,96$$ 5245 01B9 92,97$& 5250 01E4 86,108 && 5270 0207 112,115&* 5275 021D 116,119,121*& 5280 0229 121,124&* 5300 0235 66,125,127 *& 5310 0241 127,130&& 5320 024D 130,133&& 5330 0259 133,136&& 5340 0265 136,139&& 5350 0271 139,142&& 5360 027E 142,145&& 5370 028B 145,148&& 5380 0297 148,151&& 5400 02A3 151,154&& 5920 02A7 37,157 && 5999 02AA 155,158& PGGEN3 02AD 1 t FTN 3.3B (OPT = LPC) PGGN2E PAGE 1 DATE: 08/29/84 TIME: 2241 t^ 1 SUBROUTINE PGGN2E B9300001^^ 1 1 /B93 F CCS CCS 3.0 SPECIAL 12/29/82 SL-149********^^ C B9300003^^ C CYBERCREDIT SYSTEM VERSION 3 B9300004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B9300005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B9300006^^ C B9300007^^ C BUILD RPG SOURCE CODE B9300008^^ 2 COMMON /CBLK1/UTIFIL,DELQM,RPTTBL,RPTPGM,RPTWKE,UTIRQB,DLQRQB, B9300009^^ 2 2TBLRQB,PGMRQB,WKERQB,OPBUF,Q2SAVE,Q3SORT,Q4LVLB,Q5SLCT,Q6NAME, B9300010^^ 2 3Q6TOT,Q6EPOS,Q7RPT,Q5ANS,TBL,HPGMN,UTREC,PGMKEY,TBLKEY,BIN,ISTAT, B9300011^^ 2 4HPKEY,RADDR,TBLREC,OPHLD,D1TYPE,D1LNG,LRPGWK,IHOLD2,PGMREC,IND, B9300012^^ 2 5PRCREC,ERRMSG,UTEMSG,ABTMSG,XYN,TC,CS,PRCWRK,PRCRQB,LU B9300013^^ 3 COMMON /CBLK1/IMAXC,NLKEY,NNAME,NSKEY,NSLCT,NTFLDS,RPTWKP,WKPRQB B9300014^^ C B9300015^^ C FILE RETRIEVAL B9300016^^ 4 INTEGER UTIFIL(15),DELQM(15),RPTTBL(15),RPTPGM(15),RPTWKE(15), B9300017^^ 4 2 UTIRQB(24),DLQRQB(24),TBLRQB(24),PGMRQB(24),WKERQB(24), B9300018^^ 4 3 PRCWRK(15),PRCRQB(24),RPTWKP(15),WKPRQB(24) B9300019^^ C B9300020^^ C OPERATOR RESPONSES B9300021^^ 5 INTEGER OPBUF(32),Q2SAVE,Q3SORT(60),Q4LVLB(9),Q5SLCT(170), B9300022^^ 5 2 Q6NAME(51),Q6TOT(77),Q6EPOS(102),Q7RPT(15),Q5ANS B9300023^^ C B9300024^^ C MISCELLANEOUS B9300025^^ 6 INTEGER XYN,TC,CS(2),TBL(4),HPGMN(3),RPTG(2),UTREC(42),ISTAT, B9300026^^ 6 2 ZERO,PGMKEY(3),TBLKEY(3),COMMA,BIN,HPKEY(3),RADDR,TBLREC(42), B9300027^^ 6 3 OPHLD,D1TYPE,D1LNG(2),LRPGWK(42),IHOLD2(2),PGMREC(42),IND(3), B9300028^^ 6 4 PRCREC(42),ERRMSG(23),UTEMSG(26),ABTMSG(7) B9300029^^ 7 INTEGER GT,GE,LT,LE,EQ,NE,RA,YES,NO,ALL,TWO,THREE,WRPGWK(802) B9300030^^ 8 INTEGER KASC(2),KBIN,K4LEN,K5LEN,F1(04),F2(04) B9300031^^ C VARIABLE INTEGER STATEMENTS FOR THE PROGRAM BEING CREATED B9300032^^ 9 INTEGER IFICMP(12),INCCS(28),IVCCS(25),IBLK(16),IMVA(24) B9300033^^ 10 INTEGER IGOTO(5),IPOS(2),IWRK(2),IDATVL(14) B9300034^^ 11 INTEGER IASLU(2) ********^^ C*********************************************************** ???*A079********^^ 12 INTEGER RTTYPE ********^^ C*********************************************************** ???*A079********^^ C B9300035^^ CSPEC REVERSE DATES YYMMDD ********^^ 13 INTEGER KSBIN,KSASC(2),F010(11),ICHGYR(19),ICHGMO(19) ********^^ 14 DATA F010/' INTEGER SAVE(3) '/ ********^^ 15 DATA ICHGYR/'CALL CCSMVA(WRKMST,K+XXXX,2,SAVE,1,2) '/ ********^^ 16 DATA ICHGMO/'CALL CCSMVA(WRKMST,K+XXXX,4,SAVE,3,4) '/ ********^^ 17 INTEGER USEDT(18),ISDATE ********^^ 18 DATA USEDT/'CALL CCSCST(SAVE,1,6,IVLXX,1,6,ICMP)'/ ********^ ^ CSPEC END ********^^ C STARTING PROGRAM CONSTANTS B9300036^^ 19 INTEGER F1000(10),F1100(19),F1200(25),F1300(24),F1310(25) B9300037^^ C*********************************************************** ???*A079********^^ 20 INTEGER F1047(10), F2047(19) ********^^ C*********************************************************** ???*A079********^^ 21 INTEGER F1320(25),F1330(25),F1340(25),F1350(25),F1360(25) B9300038^t FTN 3.3B (OPT = LPC) PGGN2E PAGE 2 DATE: 08/29/84 TIME: 2241 t^ 22 INTEGER F1400(01),F1500(11) B9300039^^ 23 INTEGER F1600(01),F1700(21),F1800(28),F1900(27),F2000(10) B9300040^^ 24 INTEGER F2100(01) B9300041^^ 25 INTEGER F2200(17),F2300(18),F2400(19),F2500(15),F2600(18) B9300042^^ 26 INTEGER F2450(10) B9300043^^ 27 INTEGER F2700(08) B9300044^^ 28 INTEGER F2800(19),F2900(15),F3000(18),F3100(08) B9300045^^ 29 INTEGER F3200(01),F3300(19) B9300046^^ 30 INTEGER F3400(23),F3500(21),F3600(15),F3700(19),F3800(08) B9300047^^ 31 INTEGER F3900(01) B9300048^^ 32 INTEGER F4000(11),F4100(10),F4200(08),F4300(30) B9300049^^ C B9300050^^ C FINAL PROGRAM CONSTANTS B9300051^^ 33 INTEGER L1300(19),L1400(15),L1500(19),L1600(08) B9300052^^ 34 INTEGER L1650(07),L1700(14),L1800(16),L1900(08),L2000(16) B9300053^^ 35 INTEGER L2100(16),L2200(09),L2300(05) B9300054^^ C B9300055^^ C JCL CONSTANTS B9300056^^ 36 INTEGER J1000(3),J1100(3),J1200(2),J1300(2),J1400(4),J1500(5) ********^^ 37 INTEGER J1600(3),J1700(3),J1800(7),J1900(1) B9300058^^ 38 DATA F1/'DELQMST '/,F2/'PGEXTR '/ B9300059^^ C B9300060^^ 39 DATA GT/'GT'/,GE/'GE'/,LT/'LT'/,LE/'LE'/,EQ/'EQ'/,NE/'NE'/ B9300061^^ 40 DATA RA/'RA'/ B9300062^^ 41 DATA YES/$5900/,NO/$4E00/,ALL/$414C/,TWO/' 2'/,THREE/' 3'/ B9300063^^ C ***** B9300064^^ C VARIABLE DATA STATEMENTS B9300065^^ C B9300066^^ 42 DATA IFICMP/'IF(ICMP.XX.0) GO TO X00'/ B9300067^^ C B9300068^^ C*********************************************************** ???*A079********^^ 43 DATA INCCS/'CALL QCST(A,WRKMST,K+XXXX,XXXX,WRKMST,K+XXXX,XXXX,ICMP********^^ C*********************************************************** ???*A079********^^ C B9300070^^ 43 1) '/ B9300071^^ C B9300072^^ C*********************************************************** ???*A079********^^ 44 DATA IVCCS/'CALL QCST(A,WRKMST,K+XXXX,XXXX,IVLXX,1,XXXX,ICMP) '/ ********^^ C*********************************************************** ???*A079********^^ C B9300074^^ C B9300075^^ 45 DATA IBLK/' 200 CALL CCSBLK(EXTREC,132) '/ B9300076^^ C B9300077^^ 46 DATA IGOTO/'GO TO 300 '/ B9300078^^ C B9300079^^ 47 DATA IMVA/'CALL CCSMVA(WRKMST,K+XXXX,XXXX,EXTREC,XXXX,XXX)' / B9300080^^ C B9300081^^ 48 DATA IDATVL/'DATA IVLXX',$2F27,'XXXXXXXXXXXXX ',$272F/ B9300082^^ C************************************************************** ???*A044********^^ 49 INTEGER IRACMP(20) ********^^ 50 DATA IRACMP/'IF(ICMP.GE.0 .AND. JCMP.LE.0) GO TO 200 '/ ********^^ C************************************************************** ???*A044********^^ C ***** B9300083^^ C B9300084^t FTN 3.3B (OPT = LPC) PGGN2E PAGE 3 DATE: 08/29/84 TIME: 2241 t^ 51 DATA F1000/' PROGRAM RPTEXX'/ B9300085^^ C*********************************************************** ???*A079********^^ 52 DATA F1047/' INTEGER A,N,T '/ ********^^ C*********************************************************** ???*A079********^^ 53 DATA F1100/' INTEGER ID(4),LU,ISTAT,EFG,FDEL '/ B9300086^^ 54 DATA F1200/' INTEGER REQBFD(24),IDATDM(15),WRKMST(9000) '/ B9300087^^ 55 DATA F1300/' INTEGER REQBFE(24),IDATEX(15),EXTREC(68) '/ B9300088^^ 56 DATA F1310/' INTEGER IVL01(7),IVL02(7),IVL03(7),IVL04(7) '/ B9300089^^ 57 DATA F1320/' INTEGER IVL05(7),IVL06(7),IVL07(7),IVL08(7) '/ B9300090^^ 58 DATA F1330/' INTEGER IVL09(7),IVL10(7) '/ B9300091^^ 59 DATA F1340/' INTEGER IVL11(7),IVL12(7),IVL13(7),IVL14(7) '/ B9300092^^ 60 DATA F1350/' INTEGER IVL15(7),IVL16(7),IVL17(7),IVL18(7) '/ B9300093^^ 61 DATA F1360/' INTEGER IVL19(7),IVL20(7),I(8) '/ B9300094^^ 62 DATA F1400/'C '/ B9300095^^ 63 DATA F1500/' EXTERNAL FMRDEL '/ B9300096^^ 64 DATA F1600/'C '/ B9300097^^ 65 DATA F1700/' DATA REQBFD ',$202F,'24*0',$2F20,',REQBFE ',$202B9300098^^ 65 1F,'24*0',$2F20/ B9300099^^ 66 DATA F1800/' DATA IDATDM ',$2F27,'MMMMMMMMCCS20 ',$B9300100^^ C************************************************************** ???*AO45********^^ 66 12720,',0, 9,0 ',$2F20/ ********^^ C************************************************************** ???*AO45********^^ 67 DATA F1900/' DATA IDATEX ',$2F27,'MMMMMMMMCCS20 ',$B9300102^^ 67 12720,',0,1,0',$2F20/ B9300103^^ 68 DATA F2000/' DATA EFG',$202F,'0',$2F20/ B9300104^^ C*********************************************************** ???*A079********^^ 69 DATA F2047/' DATA A,N,T',$2F20,'$41,$4E,$54',$2F20,' '/ ********^^ C*********************************************************** ???*A079********^^ C DATA STATEMENTS FOR VALUES B9300105^^ C NEEDED IN THE COMPARE B9300106^^ C STATEMENTS ARE INSERTED HERE B9300107^^ 70 DATA F2100/'C '/ B9300108^^ 71 DATA F2200/' CALL PGMIN(ID,LU,MODE,NPORT)'/ B9300109^^ 72 DATA F2300/' ASSEM $C000,FMRDEL,$6400,+FDEL'/ B9300110^^ 73 DATA F2400/' CALL OPENFL(REQBFD,IDATDM,ISTAT)'/ B9300111^^ 74 DATA F2450/' REQBFD(23) = 1'/ B9300112^^ 75 DATA F2500/' IF(ISTAT.GE.0) GO TO 50 '/ B9300113^^ 76 DATA F2600/' CALL FILERR(IDATDM,3,ISTAT,LU)'/ B9300114^^ 77 DATA F2700/' GO TO 850 '/ B9300115^^ 78 DATA F2800/' 50 CALL OPENFL(REQBFE,IDATEX,ISTAT)'/ B9300116^^ 79 DATA F2900/' IF(ISTAT.GE.0) GO TO 100'/ B9300117^^ 80 DATA F3000/' CALL FILERR(IDATEX,3,ISTAT,LU)'/ B9300118^^ 81 DATA F3100/' GO TO 850 '/ B9300119^^ 82 DATA F3200/'C '/ B9300120^^ 83 DATA F3300/' 100 CALL GETS(REQBFD,WRKMST,I,ISTAT)'/ B9300121^^ 84 DATA F3400/' IF(AND(ISTAT,$8100).EQ.$8100) GO TO 850 '/ B9300122^^ 85 DATA F3500/' IF(AND(ISTAT,$100).EQ.$100) EFG = 1 '/ B9300123^^ 86 DATA F3600/' IF(ISTAT.GE.0) GO TO 115'/ B9300124^^ 87 DATA F3700/' CALL FILERR(IDATDM,14,ISTAT,LU) '/ B9300125^^ 88 DATA F3800/' GO TO 850 '/ B9300126^^ 89 DATA F3900/'C '/ B9300127^^ C*********************************************************** ???*A079********^^ 90 DATA F4000/' 115 DO 300 M = 1,9 '/ ********^^ 91 DATA F4100/' J = 1000*M-999'/ ********^t FTN 3.3B (OPT = LPC) PGGN2E PAGE 4 DATE: 08/29/84 TIME: 2241 t^ C*********************************************************** ???*A079********^^ 92 DATA F4200/' K = 2*J-1 '/ B9300130^^ 93 DATA F4300/' IF(WRKMST(J).EQ.$2020.OR.WRKMST(J).EQ.FDEL) GO TB9300131^^ 93 1O 300 '/ B9300132^^ C B9300133^^ C THE VARIABLE STATEMENTS ARE INSERTED HERE B9300134^^ C B9300135^^ 94 DATA L1300/' CALL PUTS(REQBFE,EXTREC,1,ISTAT)'/ B9300136^^ 95 DATA L1400/' IF(ISTAT.GE.0) GO TO 300'/ B9300137^^ 96 DATA L1500/' CALL FILERR(IDATEX,11,ISTAT,LU) '/ B9300138^^ 97 DATA L1600/' GO TO 850 '/ B9300139^^ 98 DATA L1650/' 300 CONTINUE'/ B9300140^^ 99 DATA L1700/' IF(EFG.EQ.1) GO TO 850'/ B9300141^^ 100 DATA L1800/' CALL CCSBLK(WRKMST,18000) '/ B9300142^^ 101 DATA L1900/' GO TO 100 '/ B9300143^^ 102 DATA L2000/' 850 CALL CLOSFL(REQBFD,ISTAT) '/ B9300144^^ 103 DATA L2100/' CALL CLOSFL(REQBFE,ISTAT) '/ B9300145^^ 104 DATA L2200/' 900 CALL PGMOUT '/ B9300146^^ 105 DATA L2300/' END '/ B9300147^^ C B9300148^^ 106 DATA J1000 /'*JOB, '/ B9300149^^ 107 DATA J1100/'*K,P2 '/ B9300150^^ 108 DATA J1200/'*FTN'/ B9300151^^ 109 DATA J1300/' MON'/ B9300152^^ 110 DATA J1400/'*LIBEDT '/ B9300153^^ 111 DATA J1500/'*K,I08,P08'/ ********^^ 112 DATA J1600/'*P,F,2'/ B9300155^^ 113 DATA J1700/'*K,I08'/ ********^^ 114 DATA J1800/'*N,RPTEXX,,,B '/ B9300157^^ 115 DATA J1900/'*Z'/ B9300158^^ C B9300159^^ 116 EXTERNAL BINASC,ASCBIN B9300160^^ C B9300161^^ C GET SCRATCH LOGICAL UNIT FROM SYSDAT;LOCATION $B3 . ********^^ 117 ASSEM $C0B3,$6800,ISCRLU ********^^ C CONVERT TO ASCII & STORE IN THE TWO JCL ARRAYS. ********^^ 118 CALL BINASC (ISCRLU, IASLU) ********^^ 119 J1500(3) = IASLU(2) ********^^ 120 J1500(5) = IASLU(2) ********^^ 121 J1700(3) = IASLU(2) ********^^ 122 GO TO 3010 B9300162^^ 123 3000 CALL PUTS(WKERQB,WRPGWK,J,ISTAT) B9300163^^ 124 IF(ISTAT.LT.0) GO TO 4020 B9300164^^ 125 CALL CCSBLK(WRPGWK,1604) B9300165^^ 126 J = 1 B9300166^^ 127 GO TO IRTN B9300167^^ C MOVE IN PROGRAM NAME B9300168^^ 128 3010 CALL CCSMVA(HPGMN,5,2,F1000,19,2) B9300169^^ C MOVE IN BEGINNING JCL TO BATCH B9300170^^ 129 L=1 B9300171^^ 130 CALL CCSBLK(WRPGWK,1604) B9300172^^ 131 CALL CCSMVA(J1000,1,06,WRPGWK,L,06) B9300173^^ 132 L=L+80 B9300174^^ 133 CALL CCSMVA(J1100,1,6,WRPGWK,L,6) B9300175^t FTN 3.3B (OPT = LPC) PGGN2E PAGE 5 DATE: 08/29/84 TIME: 2241 t^ 134 L=L+80 B9300176^^ 135 CALL CCSMVA(J1200,1,4,WRPGWK,L,4) B9300177^^ 136 L=L+80 B9300178^^ C MOVE IN BEGINNING CONSTANT STMTSB9300179^^ 137 CALL CCSMVA(F1000,1,20,WRPGWK,L,20) B9300180^^ CSPEC REVERSE DATE YYMMDD ********^^ 138 L = L + 80 ********^^ 139 CALL CCSMVA(F010,1,22,WRPGWK,L,22) ********^^ CSPEC END ********^^ 140 L=L+80 B9300181^^ C*********************************************************** ???*A079********^^ 141 CALL CCSMVA(F1047,1,20,WRPGWK,L,20) ********^^ 142 L = L + 80 ********^^ C*********************************************************** ???*A079********^^ 143 CALL CCSMVA(F1100,1,38,WRPGWK,L,38) B9300182^^ 144 L=L+80 B9300183^^ 145 CALL CCSMVA(F1200,1,50,WRPGWK,L,50) B9300184^^ 146 L=L+80 B9300185^^ 147 J=(L-1)/80 B9300186^^ 148 ASSIGN 3020 TO IRTN B9300187^^ 149 GO TO 3000 B9300188^^ 150 3020 L=1 B9300189^^ 151 CALL CCSMVA(F1300,1,48,WRPGWK,L,48) B9300190^^ 152 L=L+80 B9300191^^ 153 CALL CCSMVA(F1310,1,50,WRPGWK,L,50) B9300192^^ 154 L=L+80 B9300193^^ 155 CALL CCSMVA(F1320,1,50,WRPGWK,L,50) B9300194^^ 156 L=L+80 B9300195^^ 157 CALL CCSMVA(F1330,1,50,WRPGWK,L,50) B9300196^^ 158 L=L+80 B9300197^^ 159 CALL CCSMVA(F1340,1,50,WRPGWK,L,50) B9300198^^ 160 L=L+80 B9300199^^ 161 CALL CCSMVA(F1350,1,50,WRPGWK,L,50) B9300200^^ 162 L=L+80 B9300201^^ 163 CALL CCSMVA(F1360,1,50,WRPGWK,L,50) B9300202^^ 164 L=L+80 B9300203^^ 165 CALL CCSMVA(F1400,1,2,WRPGWK,L,2) B9300204^^ 166 L=L+80 B9300205^^ 167 CALL CCSMVA(F1500,1,22,WRPGWK,L,22) B9300206^^ 168 L=L+80 B9300207^^ 169 CALL CCSMVA(F1600,1,2,WRPGWK,L,2) B9300208^^ 170 L=L+80 B9300209^^ 171 CALL CCSMVA(F1700,1,42,WRPGWK,L,42) B9300210^^ 172 L=L+80 B9300211^^ C MOVE NAMES OF MASTER FILES TO B9300212^^ C DATA STATEMENTS B9300213^^ 173 CALL CCSMVA(F1,1,8,F1800,21,8) B9300214^^ 174 CALL CCSMVA(F2,1,8,F1900,21,8) B9300215^^ 175 CALL CCSMVA(F1800,1,56,WRPGWK,L,56) B9300216^^ 176 L=L+80 B9300217^^ 177 CALL CCSMVA(F1900,1,56,WRPGWK,L,56) B9300218^^ 178 L=L+80 B9300219^^ 179 CALL CCSMVA(F2000,1,20,WRPGWK,L,20) B9300220^^ 180 L=L+80 B9300221^t FTN 3.3B (OPT = LPC) PGGN2E PAGE 6 DATE: 08/29/84 TIME: 2241 t^ C*********************************************************** ???*A079********^^ 181 CALL CCSMVA(F2047,1,38,WRPGWK,L,38) ********^^ 182 L = L + 80 ********^^ C*********************************************************** ???*A079********^^ 183 J=(L-1)/80 B9300222^^ 184 ASSIGN 3030 TO IRTN B9300223^^ 185 GO TO 3000 B9300224^^ C IF ALL RECORDS ARE TO BE B9300225^^ C SELECTED-SKIP SETTING UP B9300226^^ C DATA VALUES B9300227^^ 186 3030 IF(Q5SLCT(1).EQ.ALL) GO TO 3070 B9300228^^ 187 M = 1 B9300229^^ 188 L = 1 B9300230^^ 189 DO 3050 K = 1,NSLCT B9300231^^ 190 MWD = (M+1)/2 B9300232^^ 191 IF(Q5SLCT(MWD+4).EQ.$0000) GO TO 3040 B9300233^^ 192 CALL BINASC(K,KASC) B9300234^^ 193 CALL CCSMVA(KASC,3,2,IDATVL,9,2) B9300235^^ 194 CALL CCSMVA(Q5SLCT,M+8,13,IDATVL,13,14) B9300236^^ 195 CALL CCSMVA(IDATVL,1,28,WRPGWK,L+6,28) B9300237^^ 196 L=L+80 B9300238^^ 197 IF(Q5SLCT(MWD).NE.RA) GO TO 3040 B9300239^^ C RANGE SECOND VALUES BEGIN AT B9300240^^ C DATA NAMES-IVL11 B9300241^^ 198 KRA = K+10 B9300242^^ 199 CALL BINASC(KRA,KASC) B9300243^^ 200 CALL CCSMVA(KASC,3,2,IDATVL,9,2) B9300244^^ 201 CALL CCSMVA(Q5SLCT,M+21,13,IDATVL,13,14) B9300245^^ 202 CALL CCSMVA(IDATVL,1,28,WRPGWK,L+6,28) B9300246^^ 203 L=L+80 B9300247^^ 204 3040 M=M+34 B9300248^^ 205 3050 CONTINUE B9300249^^ 206 J = (L-1)/80 B9300250^^ C ???*A085********^^ 207 IF(J.LE.0) GO TO 3070 ********^^ C ???*A085********^^ 208 ASSIGN 3070 TO IRTN B9300251^^ 209 GO TO 3000 B9300252^^ 210 3070 L = 1 B9300253^^ 211 CALL CCSMVA(F2100,1,2,WRPGWK,L,2) B9300254^^ 212 L=L+80 B9300255^^ 213 CALL CCSMVA(F2200,1,34,WRPGWK,L,34) B9300256^^ 214 L=L+80 B9300257^^ 215 CALL CCSMVA(F2300,1,39,WRPGWK,L,39) B9300258^^ 216 L=L+80 B9300259^^ 217 CALL CCSMVA(F2400,1,38,WRPGWK,L,38) B9300260^^ 218 L=L+80 B9300261^^ 219 CALL CCSMVA(F2450,1,20,WRPGWK,L,20) B9300262^^ 220 L=L+80 B9300263^^ 221 CALL CCSMVA(F2500,1,30,WRPGWK,L,30) B9300264^^ 222 L=L+80 B9300265^^ 223 CALL CCSMVA(F2600,1,36,WRPGWK,L,36) B9300266^^ 224 L=L+80 B9300267^^ 225 J = (L-1)/80 B9300268^t FTN 3.3B (OPT = LPC) PGGN2E PAGE 7 DATE: 08/29/84 TIME: 2241 t^ 226 ASSIGN 3100 TO IRTN B9300269^^ 227 GO TO 3000 B9300270^^ 228 3100 L=1 B9300271^^ 229 CALL CCSMVA(F2700,1,16,WRPGWK,L,16) B9300272^^ 230 L=L+80 B9300273^^ 231 CALL CCSMVA(F2800,1,38,WRPGWK,L,38) B9300274^^ 232 L=L+80 B9300275^^ 233 CALL CCSMVA(F2900,1,30,WRPGWK,L,30) B9300276^^ 234 L=L+80 B9300277^^ 235 CALL CCSMVA(F3000,1,36,WRPGWK,L,36) B9300278^^ 236 L=L+80 B9300279^^ 237 CALL CCSMVA(F3100,1,16,WRPGWK,L,16) B9300280^^ 238 L = L+80 B9300281^^ 239 CALL CCSMVA(F3200,1,2,WRPGWK,L,2) B9300282^^ 240 L=L+80 B9300283^^ 241 CALL CCSMVA(F3300,1,38,WRPGWK,L,38) B9300284^^ 242 L=L+80 B9300285^^ 243 CALL CCSMVA(F3400,1,46,WRPGWK,L,46) B9300286^^ 244 L=L+80 B9300287^^ 245 CALL CCSMVA(F3500,1,42,WRPGWK,L,42) B9300288^^ 246 L=L+80 B9300289^^ 247 CALL CCSMVA(F3600,1,30,WRPGWK,L,30) B9300290^^ 248 L=L+80 B9300291^^ 249 CALL CCSMVA(F3700,1,38,WRPGWK,L,38) B9300292^^ 250 L=L+80 B9300293^^ 251 CALL CCSMVA(F3800,1,16,WRPGWK,L,16) B9300294^^ 252 L=L+80 B9300295^^ 253 CALL CCSMVA(F3900,1,2,WRPGWK,L,2) B9300296^^ 254 L=L+80 B9300297^^ 255 CALL CCSMVA(F4000,1,22,WRPGWK,L,22) B9300298^^ 256 L=L+80 B9300299^^ 257 CALL CCSMVA(F4100,1,20,WRPGWK,L,20) B9300300^^ 258 L=L+80 B9300301^^ 259 CALL CCSMVA(F4200,1,16,WRPGWK,L,16) B9300302^^ 260 L=L+80 B9300303^^ 261 CALL CCSMVA(F4300,1,60,WRPGWK,L,60) B9300304^^ 262 L=L+80 B9300305^^ 263 J = (L-1)/80 B9300306^^ 264 ASSIGN 3150 TO IRTN B9300307^^ 265 GO TO 3000 B9300308^^ C IF ALL RECORDS ARE TO BE B9300309^^ C SELECTED-SKIP THE OPERATION B9300310^^ C CODES TESTING B9300311^^ 266 3150 IF(Q5SLCT(1).EQ.ALL) GO TO 3630 B9300312^^ 267 M = 1 B9300313^^ 268 MWD = 1 B9300314^^ 269 3160 DO 3600 K = 1,NSLCT B9300315^^ 270 CALL CCSMVA(Q5SLCT,M+2,6,TBLKEY,1,6) B9300316^^ 271 CALL READR(TBLRQB,TBLREC,TBLKEY,ISTAT) B9300317^^ 272 IF(ISTAT.LT.0) GO TO 4010 B9300318^^ C*********************************************************** ???*A079********^^ C ********^^ C--- SET DATA TYPE INTO CALLS TO STRING-COMPARE SUBROUTINE. ********^^ 273 CALL CCSGET(TBLREC,15,RTTYPE) ********^t FTN 3.3B (OPT = LPC) PGGN2E PAGE 8 DATE: 08/29/84 TIME: 2241 t^ 274 CALL CCSPUT(RTTYPE,11,INCCS) ********^^ 275 CALL CCSPUT(RTTYPE,11,IVCCS) ********^^ C***************************************************** ???*A079 ********^  ^ CSPEC REVERSE DATE YYMMDD ********^^ C CHECK IF A DATE FIELD BEING USED ********^^ 276 ISDATE = 0 ********^^ 277 IF(AND(TBLREC(8),$00FF).EQ.$0059) ISDATE = 1 ********^^ 278 IF(ISDATE.EQ.0) GO TO 3170 ********^^ 279 CALL ASCBIN(TBLREC(4),K4LEN) ********^^ 280 CALL ASCBIN(TBLREC(5),K5LEN) ********^^ 281 KBIN = K4LEN * 100 + K5LEN - 1 ********^^ 282 CALL BINASC(KBIN,KASC) ********^^ C NOW REVERSE THE DATE IN THE SAVE AREA FOR THE COMPARE ********^^ 283 3161 KSBIN = KBIN + 4 ********^^ 284 CALL BINASC(KSBIN,KSASC) ********^^ 285 CALL CCSMVA(KSASC,1,4,ICHGYR,22,4) ********^^ 286 CALL CCSMVA(ICHGYR,1,38,WRPGWK,7,38) ********^^ 287 ASSIGN 3162 TO IRTN ********^^ 288 GO TO 3000 ********^^ 289 3162 KSBIN = KBIN ********^^ 290 CALL BINASC(KSBIN,KSASC) ********^^ 291 CALL CCSMVA(KSASC,1,4,ICHGMO,22,4) ********^^ 292 CALL CCSMVA(ICHGMO,1,38,WRPGWK,7,38) ********^^ 293 ASSIGN 3170 TO IRTN ********^^ 294 GO TO 3000 ********^^ 295 3170 CONTINUE ********^^ CSPEC END ********^^ C CHECK SECOND COMPARE FIELD B9300319^^ C FOR DATA NAME OR VALUE B9300320^^ 296 IF(Q5SLCT(MWD+4).EQ.$0000) GO TO 3200 B9300321^^ C IT IS A VALUE B9300322^^ C ADJUST DISP IN MASTER REC BY -1 B9300323^^ C FIRST DATA NAME B9300324^^ CSPEC REVERSE DATES YYMMDD ********^^ C CHECK IF DATE FIELD ********^^ 297 IF(ISDATE.EQ.0) GO TO 3190 ********^^ 298 CALL BINASC(K,KASC) ********^^ 299 CALL CCSMVA(KASC,3,2,USEDT,25,2) ********^^ 300 CALL CCSMVA(USEDT,1,36,WRPGWK,7,36) ********^^ 301 J = 1 ********^^ 302 ASSIGN 3300 TO IRTN ********^^ 303 GO TO 3000 ********^^ 304 3190 CONTINUE ********^^ CSPEC END ********^^ 305 CALL ASCBIN(TBLREC(4),K4LEN) B9300325^^ 306 CALL ASCBIN(TBLREC(5),K5LEN) B9300326^^ 307 KBIN = K4LEN * 100 + K5LEN - 1 B9300327^^ 308 CALL BINASC(KBIN,KASC) B9300328^^ 309 CALL CCSMVA(KASC,1,4,IVCCS,22,4) B9300329^^ 310 CALL CCSMVA(TBLREC,11,4,IVCCS,27,4) B9300330^^ 311 CALL BINASC(K,KASC) B9300331^^ 312 CALL CCSMVA(KASC,3,2,IVCCS,35,2) B9300332^t FTN 3.3B (OPT = LPC) PGGN2E PAGE 9 DATE: 08/29/84 TIME: 2241 t^ 313 CALL CCSMVA(TBLREC,11,4,IVCCS,40,4) B9300333^^ 314 CALL CCSMVA(IVCCS,1,50,WRPGWK,7,50) B9300334^^ 315 J = 1 B9300335^^ 316 ASSIGN 3300 TO IRTN B9300336^^ 317 GO TO 3000 B9300337^^ C IT IS A DATA NAME-GET SPECS B9300338^^ C FROM RPTTBL FILE B9300339^^ C ADJUST DISP IN MASTER REC BY -1 B9300340^^ C FIRST DATA NAME B9300341^^ 318 3200 CALL ASCBIN(TBLREC(4),K4LEN) B9300342^^ 319 CALL ASCBIN(TBLREC(5),K5LEN) B9300343^^ 320 KBIN = K4LEN * 100 + K5LEN - 1 B9300344^^ 321 CALL BINASC(KBIN,KASC) B9300345^^ 322 CALL CCSMVA(KASC,1,4,INCCS,22,4) B9300346^^ 323 CALL CCSMVA(TBLREC,11,4,INCCS,27,4) B9300347^^ 324 CALL CCSMVA(Q5SLCT,M+10,6,TBLKEY,1,6) B9300348^^ 325 CALL READR(TBLRQB,TBLREC,TBLKEY,ISTAT) B9300349^^ 326 IF(ISTAT.LT.0) GO TO 4010 B9300350^^ C ADJUST DISP IN MASTER REC BY -1 B9300351^^ C SECOND DATA NAME B9300352^^ 327 CALL ASCBIN(TBLREC(4),K4LEN) B9300353^^ 328 CALL ASCBIN(TBLREC(5),K5LEN) B9300354^^ 329 KBIN = K4LEN * 100 + K5LEN - 1 B9300355^^ 330 CALL BINASC(KBIN,KASC) B9300356^^ 331 CALL CCSMVA(KASC,1,4,INCCS,41,4) B9300357^^ 332 CALL CCSMVA(TBLREC,11,4,INCCS,46,4) B9300358^^ 333 CALL CCSMVA(INCCS,1,56,WRPGWK,7,56) B9300359^^ 334 ASSIGN 3300 TO IRTN B9300360^^ 335 GO TO 3000 B9300361^^ C COMPARISON FOR OPERATION CODE- B9300362^^ C EACH CODE AND THE INCLUDE ALL (YB9300363^^ C OR ONLY ONE (N) B9300364^^ 336 3300 IF(Q5SLCT(MWD).NE.RA) GO TO 3400 B9300365^^ 337 IF(Q5ANS.EQ.YES) GO TO 3360 B9300366^^ C *** RANGE AND N B9300367^^ C***************** 11 LINES DELETED HERE ************* ???*A044 ********^^ 338 3330 KRA = K+10 B9300379^^ 339 CALL BINASC(KRA,KASC) B9300380^^ CSPEC REVERSE DATES YYMMDD ********^^ C CHECK IF DATE FIELD ********^^ 340 IF(ISDATE.EQ.0) GO TO 3335 ********^^ 341 CALL CCSMVA(KASC,3,2,USEDT,25,2) ********^^ C CHANGE THE RESULT FIELD TO A 'J'CMP FOR THIS COMPARE ONLY, IT IS ********^^ C CHANGED BACK RIGHT AFTER THE LINE IS WRITTEN ********^^ 342 CALL CCSPUT($4A,32,USEDT) ********^^ 343 CALL CCSMVA(USEDT,1,36,WRPGWK,7,36) ********^^ 344 ASSIGN 3332 TO IRTN ********^^ 345 GO TO 3000 ********^^ C CHANGE IT BACK TO AN 'I'CMP ********^^ 346 3332 CALL CCSPUT($49,32,USEDT) ********^^ 347 CALL CCSMVA(IRACMP,1,40,WRPGWK,7,40) ********^^ 348 ASSIGN 3550 TO IRTN ********^^ 349 GO TO 3000 ********^^ 350 3335 CONTINUE ********^t FTN 3.3B (OPT = LPC) PGGN2E PAGE 10 DATE: 08/29/84 TIME: 2241 t^ CSPEC END ********^^ 351 CALL CCSMVA(KASC,3,2,IVCCS,35,2) B9300381^^ 352 CALL CCSMVA(TBLREC,11,4,IVCCS,40,4) B9300382^^ C************************************************************** ???*A044********^^ C CHANGE THE RESULT FIELD TO A 'J'CMP FOR THIS COMPARE ONLY IT IS ********^^ C CHANGED BACK RIGHT AFTER THE LINE IS WRITTEN ********^^ 353 CALL CCSPUT($4A,45,IVCCS) ********^^ C************************************************************** ???*A044********^^ 354 CALL CCSMVA(IVCCS,1,50,WRPGWK,7,50) B9300383^^ 355 ASSIGN 3340 TO IRTN B9300384^^ 356 GO TO 3000 B9300385^^ C************************************************************** ???*A044********^^ C CHANGE IT BACK TO 'I'CMP ********^^ 357 3340 CALL CCSPUT($49,45,IVCCS) ********^^ 358 CALL CCSMVA(IRACMP,1,40,WRPGWK,7,40) ********^^ C************************************************************** ???*A044********^^ 359 ASSIGN 3550 TO IRTN B9300394^^ 360 GO TO 3000 B9300395^^ C *** RANGE AND Y B9300396^^ 361 3360 IFICMP(5) = LT B9300397^^ 362 IFICMP(11) = THREE B9300398^^ 363 CALL CCSMVA(IFICMP,1,24,WRPGWK,7,24) B9300399^^ 364 ASSIGN 3370 TO IRTN B9300400^^ C ***** B9300401^^ 365 GO TO 3000 B9300402^^ C MOVE IN THE 2ND VALUE OF RANGE B9300403^^ 366 3370 KRA = K+10 B9300404^^ 367 CALL BINASC(KRA,KASC) B9300405^^ CSPEC REVERSE DATES YYMMDD ********^^ C CHECK IF ITS A DATE FIELD ********^^ 368 IF(ISDATE.EQ.0) GO TO 3375 ********^^ 369 CALL CCSMVA(KASC,3,2,USEDT,25,2) ********^^ 370 CALL CCSMVA(USEDT,1,36,WRPGWK,7,36) ********^^ 371 ASSIGN 3380 TO IRTN ********^^ 372 GO TO 3000 ********^^ 373 3375 CONTINUE ********^^ CPEC END ********^^ 374 CALL CCSMVA(KASC,3,2,IVCCS,35,2) B9300406^^ 375 CALL CCSMVA(TBLREC,11,4,IVCCS,40,4) B9300407^^ 376 CALL CCSMVA(IVCCS,1,50,WRPGWK,7,50) B9300408^^ 377 ASSIGN 3380 TO IRTN B9300409^^ 378 GO TO 3000 B9300410^^ 379 3380 IFICMP(5) = GT B9300411^^ 380 IFICMP(11) = THREE B9300412^^ 381 CALL CCSMVA(IFICMP,1,24,WRPGWK,7,24) B9300413^^ 382 ASSIGN 3550 TO IRTN B9300414^^ 383 GO TO 3000 B9300415^^ C B9300416^^ 384 3400 IF(Q5SLCT(MWD).NE.GT) GO TO 3420 B9300417^^ 385 IF(Q5ANS.EQ.YES) GO TO 3410 B9300418^^ C *** GT AND N B9300419^^ 386 IFICMP(5) = GT B9300420^^ 387 IFICMP(11) = TWO B9300421^^ 388 CALL CCSMVA(IFICMP,1,24,WRPGWK,7,24) B9300422^t FTN 3.3B (OPT = LPC) PGGN2E PAGE 11 DATE: 08/29/84 TIME: 2241 t^ 389 ASSIGN 3550 TO IRTN B9300423^^ 390 GO TO 3000 B9300424^^ C *** GT AND Y B9300425^^ 391 3410 IFICMP(5) = LT B9300426^^ 392 IFICMP(11) = THREE B9300427^^ 393 CALL CCSMVA(IFICMP,1,24,WRPGWK,7,24) B9300428^^ 394 ASSIGN 3415 TO IRTN B9300429^^ 395 GO TO 3000 B9300430^^ 396 3415 IFICMP(5) = EQ B9300431^^ 397 IFICMP(11) = THREE B9300432^^ 398 CALL CCSMVA(IFICMP,1,24,WRPGWK,7,24) B9300433^^ 399 ASSIGN 3550 TO IRTN B9300434^^ 400 GO TO 3000 B9300435^^ C B9300436^^ 401 3420 IF(Q5SLCT(MWD).NE.GE) GO TO 3440 B9300437^^ 402 IF(Q5ANS.EQ.YES) GO TO 3430 B9300438^^ C *** GE AND N B9300439^^ 403 IFICMP(5) = GT B9300440^^ 404 IFICMP(11) = TWO B9300441^^ 405 CALL CCSMVA(IFICMP,1,24,WRPGWK,7,24) B9300442^^ 406 ASSIGN 3425 TO IRTN B9300443^^ 407 GO TO 3000 B9300444^^ 408 3425 IFICMP(5) = EQ B9300445^^ 409 IFICMP(11) = TWO B9300446^^ 410 CALL CCSMVA(IFICMP,1,24,WRPGWK,7,24) B9300447^^ 411 ASSIGN 3550 TO IRTN B9300448^^ 412 GO TO 3000 B9300449^^ C *** GE AND Y B9300450^^ 413 3430 IFICMP(5) = LT B9300451^^ 414 IFICMP(11) = THREE B9300452^^ 415 CALL CCSMVA(IFICMP,1,24,WRPGWK,7,24) B9300453^^ 416 ASSIGN 3550 TO IRTN B9300454^^ 417 GO TO 3000 B9300455^^ C B9300456^^ 418 3440 IF(Q5SLCT(MWD).NE.LT) GO TO 3460 B9300457^^ 419 IF(Q5ANS.EQ.YES) GO TO 3450 B9300458^^ C *** LT AND N B9300459^^ 420 IFICMP(5) = LT B9300460^^ 421 IFICMP(11) = TWO B9300461^^ 422 CALL CCSMVA(IFICMP,1,24,WRPGWK,7,24) B9300462^^ 423 ASSIGN 3550 TO IRTN B9300463^^ 424 GO TO 3000 B9300464^^ C *** LT AND Y B9300465^^ 425 3450 IFICMP(5) = GT B9300466^^ 426 IFICMP(11) = THREE B9300467^^ 427 CALL CCSMVA(IFICMP,1,24,WRPGWK,7,24) B9300468^^ 428 ASSIGN 3455 TO IRTN B9300469^^ 429 GO TO 3000 B9300470^^ 430 3455 IFICMP(5) = EQ B9300471^^ 431 IFICMP(11) = THREE B9300472^^ 432 CALL CCSMVA(IFICMP,1,24,WRPGWK,7,24) B9300473^^ 433 ASSIGN 3550 TO IRTN B9300474^^ 434 GO TO 3000 B9300475^^ C B9300476^t FTN 3.3B (OPT = LPC) PGGN2E PAGE 12 DATE: 08/29/84 TIME: 2241 t^ 435 3460 IF(Q5SLCT(MWD).NE.LE) GO TO 3480 B9300477^^ 436 IF(Q5ANS.EQ.YES) GO TO 3470 B9300478^^ C *** LE AND N B9300479^^ 437 IFICMP(5) = LT B9300480^^ 438 IFICMP(11) = TWO B9300481^^ 439 CALL CCSMVA(IFICMP,1,24,WRPGWK,7,24) B9300482^^ 440 ASSIGN 3465 TO IRTN B9300483^^ 441 GO TO 3000 B9300484^^ 442 3465 IFICMP(5) = EQ B9300485^^ 443 IFICMP(11) = TWO B9300486^^ 444 CALL CCSMVA(IFICMP,1,24,WRPGWK,7,24) B9300487^^ 445 ASSIGN 3550 TO IRTN B9300488^^ 446 GO TO 3000 B9300489^^ C *** LE AND Y B9300490^^ 447 3470 IFICMP(5) = GT B9300491^^ 448 IFICMP(11) = THREE B9300492^^ 449 CALL CCSMVA(IFICMP,1,24,WRPGWK,7,24) B9300493^^ 450 ASSIGN 3550 TO IRTN B9300494^^ 451 GO TO 3000 B9300495^^ C B9300496^^ 452 3480 IF(Q5SLCT(MWD).NE.EQ) GO TO 3500 B9300497^^ 453 IF(Q5ANS.EQ.YES) GO TO 3490 B9300498^^ C *** EQ AND N B9300499^^ 454 IFICMP(5) = EQ B9300500^^ 455 IFICMP(11) = TWO B9300501^^ 456 CALL CCSMVA(IFICMP,1,24,WRPGWK,7,24) B9300502^^ 457 ASSIGN 3550 TO IRTN B9300503^^ 458 GO TO 3000 B9300504^^ C *** EQ AND Y B9300505^^ 459 3490 IFICMP(5) = GT B9300506^^ 460 IFICMP(11) = THREE B9300507^^ 461 CALL CCSMVA(IFICMP,1,24,WRPGWK,7,24) B9300508^^ 462 ASSIGN 3495 TO IRTN B9300509^^ 463 GO TO 3000 B9300510^^ 464 3495 IFICMP(5) = LT B9300511^^ 465 IFICMP(11) = THREE B9300512^^ 466 CALL CCSMVA(IFICMP,1,24,WRPGWK,7,24) B9300513^^ 467 ASSIGN 3550 TO IRTN B9300514^^ 468 GO TO 3000 B9300515^^ C BY DEFAULT - NE B9300516^^ 469 3500 IF(Q5ANS.EQ.YES) GO TO 3520 B9300517^^ C *** NE AND N B9300518^^ 470 IFICMP(5) = LT B9300519^^ 471 IFICMP(11) = TWO B9300520^^ 472 CALL CCSMVA(IFICMP,1,24,WRPGWK,7,24) B9300521^^ 473 ASSIGN 3510 TO IRTN B9300522^^ 474 GO TO 3000 B9300523^^ 475 3510 IFICMP(5) = GT B9300524^^ 476 IFICMP(11) = TWO B9300525^^ 477 CALL CCSMVA(IFICMP,1,24,WRPGWK,7,24) B9300526^^ 478 ASSIGN 3550 TO IRTN B9300527^^ 479 GO TO 3000 B9300528^^ C *** NE AND Y B9300529^^ 480 3520 IFICMP(5) = EQ B9300530^t FTN 3.3B (OPT = LPC) PGGN2E PAGE 13 DATE: 08/29/84 TIME: 2241 t^ 481 IFICMP(11) = THREE B9300531^^ 482 CALL CCSMVA(IFICMP,1,24,WRPGWK,7,24) B9300532^^ 483 ASSIGN 3550 TO IRTN B9300533^^ 484 GO TO 3000 B9300534^^ 485 3550 M = M + 34 B9300535^^ 486 MWD = (M+1) / 2 B9300536^^ 487 3600 CONTINUE B9300537^^ 488 IF(Q5ANS.EQ.YES) GO TO 3630 B9300538^^ C 'GO TO 300' B9300539^^ 489 CALL CCSMVA(IGOTO,1,10,WRPGWK,7,10) B9300540^^ 490 ASSIGN 3630 TO IRTN B9300541^^ 491 GO TO 3000 B9300542^^ 492 3630 CALL CCSMVA(IBLK,1,32,WRPGWK,1,32) B9300543^^ 493 J = 1 B9300544^^ C J WILL STAY AT ONE FOR REMAINDERB9300545^^ 494 ASSIGN 3640 TO IRTN B9300546^^ 495 GO TO 3000 B9300547^^ 496 3640 M = 1 B9300548^^ 497 IPOS = 1 B9300549^^ 498 3645 DO 3650 K= 1,NNAME B9300550^^ 499 CALL CCSMVA(Q6NAME,M,6,TBLKEY,1,6) B9300551^^ 500 CALL READR(TBLRQB,TBLREC,TBLKEY,ISTAT) B9300552^^ 501 IF(ISTAT.LT.0) GO TO 4010 B9300553^^ C ADJUST DISP IN MASTER REC BY -1 B9300554^^ 502 CALL ASCBIN(TBLREC(4),K4LEN) B9300555^^ 503 CALL ASCBIN(TBLREC(5),K5LEN) B9300556^^ 504 KBIN = K4LEN * 100 + K5LEN - 1 B9300557^^ 505 CALL BINASC(KBIN,KASC) B9300558^^ 506 CALL CCSMVA(KASC,1,4,IMVA,22,4) B9300559^^ 507 CALL CCSMVA(TBLREC,11,4,IMVA,27,4) B9300560^^ 508 CALL CCSMVA(TBLREC,12,3,IMVA,44,3) B9300561^^ 509 CALL BINASC(IPOS,KASC) B9300562^^ 510 CALL CCSMVA(KASC,1,4,IMVA,39,4) B9300563^^ 511 CALL CCSMVA(IMVA,1,48,WRPGWK,7,48) B9300564^^ 512 ASSIGN 3647 TO IRTN B9300565^^ 513 GO TO 3000 B9300566^^ 514 3647 CALL ASCBIN(TBLREC(7),IWRK) B9300567^^ 515 IPOS = IPOS + IWRK B9300568^^ C POST 3.1 PSR ********^^ C ***** 5 COMMENT LINES DELETED HERE ***** ********^^ C END ********^^ 516 3649 M = M + 6 B9300574^^ 517 3650 CONTINUE B9300575^^ 518 L = 1 B9300576^^ 519 CALL CCSMVA(L1300,1,38,WRPGWK,L,38) B9300577^^ 520 L=L+80 B9300578^^ 521 CALL CCSMVA(L1400,1,30,WRPGWK,L,30) B9300579^^ 522 L=L+80 B9300580^^ 523 CALL CCSMVA(L1500,1,38,WRPGWK,L,38) B9300581^^ 524 L=L+80 B9300582^^ 525 CALL CCSMVA(L1600,1,16,WRPGWK,L,16) B9300583^^ 526 L=L+80 B9300584^^ 527 CALL CCSMVA(L1650,1,14,WRPGWK,L,14) B9300585^^ 528 L=L+80 B9300586^t FTN 3.3B (OPT = LPC) PGGN2E PAGE 14 DATE: 08/29/84 TIME: 2241 t^ 529 CALL CCSMVA(L1700,1,28,WRPGWK,L,28) B9300587^^ 530 L=L+80 B9300588^^ 531 CALL CCSMVA(L1800,1,32,WRPGWK,L,32) B9300589^^ 532 L=L+80 B9300590^^ 533 CALL CCSMVA(L1900,1,16,WRPGWK,L,16) B9300591^^ 534 L=L+80 B9300592^^ 535 CALL CCSMVA(L2000,1,32,WRPGWK,L,32) B9300593^^ 536 L=L+80 B9300594^^ 537 CALL CCSMVA(L2100,1,32,WRPGWK,L,32) B9300595^^ 538 L = L + 80 B9300596^^ 539 CALL CCSMVA(L2200,1,18,WRPGWK,L,18) B9300597^^ 540 L = L + 80 B9300598^^ 541 CALL CCSMVA(L2300,1,10,WRPGWK,L,10) B9300599^^ 542 L=L+80 B9300600^^ 543 J = (L-1)/80 B9300601^^ 544 ASSIGN 3990 TO IRTN B9300602^^ 545 GO TO 3000 B9300603^^ 546 3990 L=1 B9300604^^ 547 CALL CCSMVA(J1300,1,4,WRPGWK,L,4) B9300605^^ 548 L=L+80 B9300606^^ 549 CALL CCSMVA(J1400,1,8,WRPGWK,L,8) B9300607^^ 550 L=L+80 B9300608^^ 551 CALL CCSMVA(J1500,1,10,WRPGWK,L,10) ********^^ 552 L=L+80 B9300610^^ 553 CALL CCSMVA(J1600,1,6,WRPGWK,L,6) B9300611^^ 554 L=L+80 B9300612^^ 555 CALL CCSMVA(J1700,1,6,WRPGWK,L,6) B9300613^^ 556 L=L+80 B9300614^^ C MOVE IN NAME OF PROGRAM TO B9300615^^ C BE USED IN PROGRAM LIBRARY B9300616^^ 557 CALL CCSMVA(HPGMN,5,2,J1800,8,2) B9300617^^ 558 CALL CCSMVA(J1800,1,14,WRPGWK,L,14) B9300618^^ 559 L=L+80 B9300619^^ 560 CALL CCSMVA(J1900,1,2,WRPGWK,L,2) B9300620^^ 561 L=L+80 B9300621^^ 562 J=(L-1)/80 B9300622^^ 563 ASSIGN 4000 TO IRTN B9300623^^ 564 GO TO 3000 B9300624^^ 565 4000 CONTINUE B9300625^^ 566 RADDR=$0000 B9300626^^ 567 GO TO 4999 B9300627^^ 568 4010 RADDR=$8010 B9300628^^ 569 GO TO 4999 B9300629^^ 570 4020 RADDR=$8020 B9300630^^ 571 4999 CONTINUE B9300631^^ 572 RETURN B9300632^^ 573 END B9300633^t FTN 3.3B (OPT = LPC) PGGN2E PAGE 15 DATE: 08/29/84 TIME: 2241 t COMMON  LABEL $0448 ( 1096)    PROGRAM LENGTH $0FD0 ( 4048)   EXTERNALS 2 BINASC ASCBIN PUTS CCSBLK CCSMVA READR CCSGET 2 CCSPUT  t FTN 3.3B (OPT = LPC) PGGN2E PAGE 16 DATE: 08/29/84 TIME: 2241 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " 8010 (-32751) 07BC 568"" 8020 (-32735) 07BD 570"‚ 0001 (1) 0000 22,23,24,29,31,37,126,129,131,133,135,137,139,141,143,145,147,150,151,153,155,157,159,161,163,165, ‚€ 167,169,171,173,174,175,177,179,181,183,186,187,188,189,190,195,202,206,210,211,213,215,217,219, €€ 221,223,225,228,229,231,233,235,237,239,241,243,245,247,249,251,253,255,257,259,261,263,266,267, €€ 268,269,270,277,281,285,286,291,292,300,301,307,309,314,315,320,322,324,329,331,333,343,347,354, €€ 358,363,370,376,381,388,393,398,405,410,415,422,427,432,439,444,449,456,461,466,472,477,482,486, €€ 489,492,493,496,497,498,499,504,506,510,511,518,519,521,523,525,527,529,531,533,535,537,539,541, €F 543,546,547,549,551,553,555,558,560,562Fn 0002 (2) 078A 128,128,165,169,190,193,200,211,239,253,270,299,312,341,351,369,374,486,557,560nB 0003 (3) 079C 193,200,299,312,341,351,369,374,508B€ 0004 (4) 078F 135,135,191,279,283,285,291,296,305,309,310,313,318,322,323,327,331,332,352,375,502,506,507,510, €" 547"€ 0005 (5) 0789 128,280,306,319,328,361,379,386,391,396,403,408,413,420,425,430,437,442,447,454,459,464,470,475, €* 480,503,557*J 0006 (6) 078D 131,131,133,195,202,270,324,499,516,553,555J€ 0007 (7) 07AE 286,292,300,314,333,343,347,354,358,363,370,376,381,388,393,398,405,410,415,422,427,432,439,444, €F 449,456,461,466,472,477,482,489,511,514F: 0008 (8) 0796 173,173,174,194,277,549,557:& 0009 (9) 079D 193,200&: 000A (10) 07A2 198,324,338,366,489,541,551:€ 000B (11) 07AB 274,275,310,313,323,332,352,362,375,380,387,392,397,404,409,414,421,426,431,438,443,448,455,460, €2 465,471,476,481,5072" 000C (12) 07B9 508"* 000D (13) 079E 194,194,201*. 000E (14) 079F 194,201,527,558." 000F (15) 07AA 273": 0010 (16) 07A7 229,229,237,251,259,525,533:& 0012 (18) 07BB 539,539&" 0013 (19) 078B 128"6 0014 (20) 0790 137,137,141,179,219,2576* 0015 (21) 0797 173,174,201*B 0016 (22) 0791 139,139,167,255,285,291,309,322,506Br 0018 (24) 07B8 363,363,381,388,393,398,405,410,415,422,427,432,439,444,449,456,461,466,472,477,482r* 0019 (25) 07AF 299,341,369** 001B (27) 07B0 310,323,507*. 001C (28) 07A0 195,195,202,529.2 001E (30) 07A5 221,221,233,247,52126 0020 (32) 07B5 342,346,492,531,535,5376* 0022 (34) 07A3 204,213,485** 0023 (35) 07B1 312,351,374*6 0024 (36) 07A6 223,223,235,300,343,3706J 0026 (38) 0792 143,143,181,217,231,241,249,286,292,519,523J* 0027 (39) 07A4 215,215,510*2 0028 (40) 07B2 313,347,352,358,3752" 0029 (41) 07B3 331"t FTN 3.3B (OPT = LPC) PGGN2E PAGE 17 DATE: 08/29/84 TIME: 2241 t* 002A (42) 0795 171,171,245*" 002C (44) 07BA 508"& 002D (45) 07B7 353,357&* 002E (46) 07A8 243,243,332** 0030 (48) 0794 151,151,511*J 0032 (50) 0793 145,145,153,155,157,159,161,163,314,354,376J. 0038 (56) 0798 175,175,177,333.& 003C (60) 07A9 261,261&& 0049 (73) 07B6 346,357&& 004A (74) 07B4 342,353&€ 0050 (80) 078E 132,134,136,138,140,142,144,146,147,152,154,156,158,160,162,164,166,168,170,172,176,178,180,182, €€ 183,196,203,206,212,214,216,218,220,222,224,225,230,232,234,236,238,240,242,244,246,248,250,252, €€ 254,256,258,260,262,263,520,522,524,526,528,530,532,534,536,538,540,542,543,548,550,552,554,556, €* 559,561,562*2 0064 (100) 07AD 281,307,320,329,5042" 00FF (255) 07AC 277"& 0644 (1604) 0787 125,130&   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " ABTMSG INTEGER 03E8 D 1,6", ALL INTEGER 000C 6,41,186,266 ," AND INTR.FN. 7FFF 277"" BIN INTEGER 0300 D 1,6"" CS INTEGER 03F1 D 1,6"" D1LNG INTEGER 0332 D 1,6"" D1TYPE INTEGER 0331 D 1,6"" DELQM INTEGER 000F D 1,4"" DLQRQB INTEGER 0063 D 1,4"@ EQ INTEGER 0007 6,39,396,408,430,442,452,454,480 @" ERRMSG INTEGER 03B7 D 1,6"( F010 INTEGER 03C4 6,14,139 (( F1 INTEGER 0336 6,38,173 (, F1000 INTEGER 0408 18,51,128,137,( F1047 INTEGER 046F 18,52,141(( F1100 INTEGER 0412 18,53,143(( F1200 INTEGER 0425 18,54,145(( F1300 INTEGER 043E 18,55,151(( F1310 INTEGER 0456 18,56,153(( F1320 INTEGER 048C 18,57,155(( F1330 INTEGER 04A5 18,58,157(( F1340 INTEGER 04BE 18,59,159(( F1350 INTEGER 04D7 18,60,161(( F1360 INTEGER 04F0 18,61,163(( F1400 INTEGER 0509 18,62,165(( F1500 INTEGER 050A 22,63,167(( F1600 INTEGER 0515 22,64,169(( F1700 INTEGER 0516 23,65,171(, F1800 INTEGER 052B 23,66,173,175,, F1900 INTEGER 0547 23,67,174,177,t FTN 3.3B (OPT = LPC) PGGN2E PAGE 18 DATE: 08/29/84 TIME: 2241 t( F2 INTEGER 033A 6,38,174 (( F2000 INTEGER 0562 23,68,179(( F2047 INTEGER 0479 18,69,181(( F2100 INTEGER 056C 23,70,211(( F2200 INTEGER 056D 24,71,213(( F2300 INTEGER 057E 24,72,215(( F2400 INTEGER 0590 24,73,217(( F2450 INTEGER 05C4 24,74,219(( F2500 INTEGER 05A3 24,75,221(( F2600 INTEGER 05B2 24,76,223(( F2700 INTEGER 05CE 24,77,229(( F2800 INTEGER 05D6 24,78,231(( F2900 INTEGER 05E9 24,79,233(( F3000 INTEGER 05F8 24,80,235(( F3100 INTEGER 060A 24,81,237(( F3200 INTEGER 0612 24,82,239(( F3300 INTEGER 0613 29,83,241(( F3400 INTEGER 0626 29,84,243(( F3500 INTEGER 063D 29,85,245(( F3600 INTEGER 0652 29,86,247(( F3700 INTEGER 0661 29,87,249(( F3800 INTEGER 0674 29,88,251(( F3900 INTEGER 067C 29,89,253(( F4000 INTEGER 067D 31,90,255(( F4100 INTEGER 0688 31,91,257(( F4200 INTEGER 0692 31,92,259(( F4300 INTEGER 069A 31,93,261(( GE INTEGER 0004 6,39,401 (D GT INTEGER 0003 6,39,379,384,386,403,425,447,459,475 D* HPGMN INTEGER 02CD D 1,6,128,557*" HPKEY INTEGER 0302 D 1,6"0 IASLU INTEGER 03BE 6,118,119,120,1210( IBLK INTEGER 037F 6,45,492 (, ICHGMO INTEGER 03E2 6,16,291,292 ,, ICHGYR INTEGER 03CF 6,15,285,286 ,< IDATVL INTEGER 03B0 6,48,193,194,195,200,201,202 <€ IFICMP INTEGER 033E 6,42,361,362,363,379,380,381,386,387,388,391,392,393,396,397,398,403,404,405,408,409,410,413,414,€€ 415,420,421,422,425,426,427,430,431,432,437,438,439,442,443,444,447,448,449,454,455,456,459,460, €R 461,464,465,466,470,471,472,475,476,477,480,481,482R( IGOTO INTEGER 03A7 6,46,489 (" IHOLD2 INTEGER 035E D 1,6" IMAXC INTEGER 041B D 1 8 IMVA INTEGER 038F 6,47,506,507,508,510,511 8< INCCS INTEGER 034A 6,43,274,322,323,331,332,333 <" IND INTEGER 038A D 1,6", IPOS INTEGER 03AC 6,497,509,515,, IRACMP INTEGER 0771 48,50,347,358,€ IRTN INTEGER 0788 126,148,184,208,226,264,287,293,302,316,334,344,348,355,359,364,371,377,382,389,394,399,406,411, €f 416,423,428,433,440,445,450,457,462,467,473,478,483,490,494,512,544,563f& ISCRLU INTEGER 0785 115,118&: ISDATE INTEGER 0407 16,276,277,278,297,340,368 :B ISTAT INTEGER 0301 D 1,6,123,124,271,272,325,326,500,501B\ IVCCS INTEGER 0366 6,44,275,309,310,312,313,314,351,352,353,354,357,374,375,376 \( IWRK INTEGER 03AE 6,514,515(t FTN 3.3B (OPT = LPC) PGGN2E PAGE 19 DATE: 08/29/84 TIME: 2241 tR J INTEGER 0786 123,126,147,183,206,207,225,263,301,315,493,543,562R* J1000 INTEGER 0750 31,106,131 ** J1100 INTEGER 0753 31,107,133 ** J1200 INTEGER 0756 31,108,135 ** J1300 INTEGER 0758 31,109,547 ** J1400 INTEGER 075A 31,110,549 *2 J1500 INTEGER 075E 31,111,119,120,551 2* J1600 INTEGER 0763 31,112,553 *. J1700 INTEGER 0766 31,113,121,555 .. J1800 INTEGER 0769 31,114,557,558 .* J1900 INTEGER 0770 31,115,560 *B K INTEGER 079A 188,192,198,269,298,311,338,366,498BH K4LEN INTEGER 0334 6,279,281,305,307,318,320,327,329,502,504HH K5LEN INTEGER 0335 6,280,281,306,307,319,320,328,329,503,504H‚ KASC INTEGER 0331 6,192,193,199,200,282,298,299,308,309,311,312,321,322,330,331,339,341,351,367,369,374,505,506,509, ‚" 510"P KBIN INTEGER 0333 6,281,282,283,289,307,308,320,321,329,330,504,505P: KRA INTEGER 07A1 197,198,199,338,339,366,367:0 KSASC INTEGER 03C2 6,284,285,290,29100 KSBIN INTEGER 03C1 6,283,284,289,2900€ L INTEGER 078C 128,129,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,150,151,152,153,154, €€ 155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,175,176,177,178,179,180, €€ 181,182,183,188,195,196,202,203,206,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224, €€ 225,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250, €€ 251,252,253,254,255,256,257,258,259,260,261,262,263,518,519,520,521,522,523,524,525,526,527,528, €€ 529,530,531,532,533,534,535,536,537,538,539,540,541,542,543,546,547,548,549,550,551,552,553,554, €: 555,556,558,559,560,561,562:( L1300 INTEGER 06B8 31,94,519(( L1400 INTEGER 06CB 31,95,521(( L1500 INTEGER 06DA 31,96,523(( L1600 INTEGER 06ED 31,97,525(( L1650 INTEGER 06F5 31,98,527(( L1700 INTEGER 06FC 31,99,529(* L1800 INTEGER 070A 31,100,531 ** L1900 INTEGER 071A 31,101,533 ** L2000 INTEGER 0722 31,102,535 ** L2100 INTEGER 0732 31,103,537 ** L2200 INTEGER 0742 31,104,539 ** L2300 INTEGER 074B 31,105,541 *( LE INTEGER 0006 6,39,435 (" LRPGWK INTEGER 0334 D 1,6"D LT INTEGER 0005 6,39,361,391,413,418,420,437,464,470 D LU INTEGER 041A D 1 V M INTEGER 0799 186,187,190,194,201,204,267,270,324,485,486,496,499,516VR MWD INTEGER 079B 189,190,191,197,268,296,336,384,401,418,435,452,486R$ NE INTEGER 0008 6,39 $ NLKEY INTEGER 041C D 1 $ NNAME INTEGER 041D D 1,498$$ NO INTEGER 000B 6,41 $ NSKEY INTEGER 041E D 1 ( NSLCT INTEGER 041F D 1,189,269( NTFLDS INTEGER 0420 D 1 " OPBUF INTEGER 00C3 D 1,5"" OPHLD INTEGER 0330 D 1,6"t FTN 3.3B (OPT = LPC) PGGN2E PAGE 20 DATE: 08/29/84 TIME: 2241 t" PGMKEY INTEGER 02FA D 1,6"" PGMREC INTEGER 0360 D 1,6"" PGMRQB INTEGER 0093 D 1,4"" PRCREC INTEGER 038D D 1,6"" PRCRQB INTEGER 0402 D 1,4"" PRCWRK INTEGER 03F3 D 1,4"" Q2SAVE INTEGER 00E3 D 1,5"" Q3SORT INTEGER 00E4 D 1,5"" Q4LVLB INTEGER 0120 D 1,5"B Q5ANS INTEGER 02C8 D 1,5,337,385,402,419,436,453,469,488B^ Q5SLCT INTEGER 0129 D 1,5,186,191,194,197,201,266,270,296,324,336,384,401,418,435,452^" Q6EPOS INTEGER 0253 D 1,5"& Q6NAME INTEGER 01D3 D 1,5,499&" Q6TOT INTEGER 0206 D 1,5"" Q7RPT INTEGER 02B9 D 1,5", RA INTEGER 0009 6,40,197,336 ,. RADDR INTEGER 0305 D 1,6,566,568,570. RPTG INTEGER 0001 6 " RPTPGM INTEGER 002D D 1,4"" RPTTBL INTEGER 001E D 1,4"" RPTWKE INTEGER 003C D 1,4"" RPTWKP INTEGER 0421 D 1,4", RTTYPE INTEGER 03C0 6,273,274,275," TBL INTEGER 02C9 D 1,6": TBLKEY INTEGER 02FD D 1,6,270,271,324,325,499,500:€ TBLREC INTEGER 0306 D 1,6,271,273,277,279,280,305,306,310,313,318,319,323,325,327,328,332,352,375,500,502,503,507,508, €" 514". TBLRQB INTEGER 007B D 1,4,271,325,500." TC INTEGER 03F0 D 1,6"P THREE INTEGER 000E 6,41,362,380,392,397,414,426,431,448,460,465,481 PH TWO INTEGER 000D 6,41,387,404,409,421,438,443,455,471,476 HD USEDT INTEGER 03F5 16,18,299,300,341,342,343,346,369,370D" UTEMSG INTEGER 03CE D 1,6"" UTIFIL INTEGER 0000 D 1,4"" UTIRQB INTEGER 004B D 1,4"" UTREC INTEGER 02D0 D 1,6"& WKERQB INTEGER 00AB D 1,4,123&" WKPRQB INTEGER 0430 D 1,4"‚ WRPGWK INTEGER 000F 6,123,125,130,131,133,135,137,139,141,143,145,151,153,155,157,159,161,163,165,167,169,171,175,177, ‚€ 179,181,195,202,211,213,215,217,219,221,223,229,231,233,235,237,239,241,243,245,247,249,251,253, €€ 255,257,259,261,286,292,300,314,333,343,347,354,358,363,370,376,381,388,393,398,405,410,415,422, €€ 427,432,439,444,449,456,461,466,472,477,482,489,492,511,519,521,523,525,527,529,531,533,535,537, €B 539,541,547,549,551,553,555,558,560B" XYN INTEGER 03EF D 1,6"D YES INTEGER 000A 6,41,337,385,402,419,436,453,469,488 Dt FTN 3.3B (OPT = LPC) PGGN2E PAGE 21 DATE: 08/29/84 TIME: 2241 t   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < N ASCBIN SUBROUTINE 0E8C 115,279,280,305,306,318,319,327,328,502,503,514N^ BINASC SUBROUTINE 0E9C 115,118,192,199,282,284,290,298,308,311,321,330,339,367,505,509^& CCSBLK SUBROUTINE 07D8 124,130&" CCSGET SUBROUTINE 0AC2 272"€ CCSMVA SUBROUTINE 0F70 128,131,133,135,137,139,141,143,145,151,153,155,157,159,161,163,165,167,169,171,173,174,175,177, €€ 179,181,193,194,195,200,201,202,211,213,215,217,219,221,223,229,231,233,235,237,239,241,243,245, €€ 247,249,251,253,255,257,259,261,270,285,286,291,292,299,300,309,310,312,313,314,322,323,324,331, €€ 332,333,341,343,347,351,352,354,358,363,369,370,374,375,376,381,388,393,398,405,410,415,422,427, €€ 432,439,444,449,456,461,466,472,477,482,489,492,499,506,507,508,510,511,519,521,523,525,527,529, €V 531,533,535,537,539,541,547,549,551,553,555,557,558,560V6 CCSPUT SUBROUTINE 0C0F 273,275,342,346,353,3576" PUTS SUBROUTINE 07CC 121"* READR SUBROUTINE 0E80 270,325,500*   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < € 3000 07CB 121,149,185,209,227,265,288,294,303,317,335,345,349,356,360,365,372,378,383,390,395,400,407,412, €f 417,424,429,434,441,446,451,458,463,468,474,479,484,491,495,513,545,564f& 3010 07DE 121,128&& 3020 0848 147,150&& 3030 08FD 183,186&* 3040 096C 191,197,204*& 3050 096F 188,205&. 3070 0984 186,207,208,210.& 3100 09D8 225,228&& 3150 0A93 263,266&" 3160 0AA0 268"" 3161 0AF2 282"& 3162 0B0C 286,289&* 3170 0B25 278,293,295*& 3190 0B4A 297,304&& 3200 0B85 296,318&. 3300 0BE9 301,316,334,336." 3330 0BFA 337"& 3332 0C1F 343,346&& 3335 0C2F 340,350&& 3340 0C4D 354,357&& 3360 0C5E 337,361&& 3370 0C73 363,366&& 3375 0C91 368,373&* 3380 0CAB 370,377,379*& 3400 0CBC 336,384&& 3410 0CDD 385,391&t FTN 3.3B (OPT = LPC) PGGN2E PAGE 22 DATE: 08/29/84 TIME: 2241 t& 3415 0CF2 393,396&& 3420 0D03 384,401&& 3425 0D1F 405,408&& 3430 0D2F 402,413&& 3440 0D3F 401,418&& 3450 0D60 419,425&& 3455 0D75 427,430&& 3460 0D86 418,435&& 3465 0DA3 439,442&& 3470 0DB3 436,447&& 3480 0DC3 435,452&& 3490 0DE4 453,459&& 3495 0DF9 461,464&& 3500 0E09 452,469&& 3510 0E1E 472,475&& 3520 0E2E 469,480&^ 3550 0E3F 347,359,382,389,399,411,416,423,433,445,450,457,467,478,483,485^& 3600 0E47 268,487&. 3630 0E5D 266,488,490,492.& 3640 0E6D 493,496&" 3645 0E71 497"& 3647 0ECB 511,514&" 3649 0ED2 515"& 3650 0ED6 497,517&& 3990 0F62 543,546&& 4000 0FBD 562,565&. 4010 0FC1 272,326,501,568.& 4020 0FC5 124,570&* 4999 0FC8 566,569,571* PGGN2E 0FCB 1 t FTN 3.3B (OPT = LPC) PGGN2P PAGE 1 DATE: 08/29/84 TIME: 2245 t^ 1 SUBROUTINE PGGN2P B9400001^^ 1 1 /B94 F CCS CCS 3.0 SL-149B9400002^^ C B9400003^^ C CYBERCREDIT SYSTEM VERSION 3 B9400004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B9400005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B9400006^^ C B9400007^^ C BUILD RPG SOURCE CODE B9400008^^ 2 COMMON /CBLK1/UTIFIL,DELQM,RPTTBL,RPTPGM,RPTWKE,UTIRQB,DLQRQB, B9400009^^ 2 2TBLRQB,PGMRQB,WKERQB,OPBUF,Q2SAVE,Q3SORT,Q4LVLB,Q5SLCT,Q6NAME, B9400010^^ 2 3Q6TOT,Q6EPOS,Q7RPT,Q5ANS,TBL,HPGMN,UTREC,PGMKEY,TBLKEY,BIN,ISTAT, B9400011^^ 2 4HPKEY,RADDR,TBLREC,OPHLD,D1TYPE,D1LNG,LRPGWK,IHOLD2,PGMREC,IND, B9400012^^ 2 5PRCREC,ERRMSG,UTEMSG,ABTMSG,XYN,TC,CS,PRCWRK,PRCRQB,LU B9400013^^ 3 COMMON /CBLK1/IMAXC,NLKEY,NNAME,NSKEY,NSLCT,NTFLDS,RPTWKP,WKPRQB B9400014^^ C B9400015^^ C FILE RETRIEVAL B9400016^^ 4 INTEGER UTIFIL(15),DELQM(15),RPTTBL(15),RPTPGM(15),RPTWKE(15), B9400017^^ 4 2 UTIRQB(24),DLQRQB(24),TBLRQB(24),PGMRQB(24),WKERQB(24), B9400018^^ 4 3 PRCWRK(15),PRCRQB(24),RPTWKP(15),WKPRQB(24) B9400019^^ C B9400020^^ C OPERATOR RESPONSES B9400021^^ 5 INTEGER OPBUF(32),Q2SAVE,Q3SORT(60),Q4LVLB(9),Q5SLCT(170), B9400022^^ 5 2 Q6NAME(51),Q6TOT(77),Q6EPOS(102),Q7RPT(15),Q5ANS B9400023^^ C B9400024^^ C MISCELLANEOUS B9400025^^ 6 INTEGER XYN,TC,CS(2),TBL(4),HPGMN(3),RPTG(2),UTREC(42),ISTAT, B9400026^^ 6 2 ZERO,PGMKEY(3),TBLKEY(3),COMMA,BIN,HPKEY(3),RADDR,TBLREC(42), B9400027^^ 6 3 OPHLD,D1TYPE,D1LNG(2),LRPGWK(42),IHOLD2(2),PGMREC(42),IND(3), B9400028^^ 6 4 PRCREC(42),ERRMSG(23),UTEMSG(26),ABTMSG(7) B9400029^^ 7 INTEGER F1(20),F2(20),F3(20),FALL(60) B9400030^^ 8 INTEGER C1(25),C2(25),C3(25),C4(25),C5(25),C6(25),C7(25),C8(25), B9400031^^ 8 2 C9(25),C10(25),C11(25),C12(25),CAL(300) B9400032^^ 9 INTEGER IMOVE(3),ISETON(3),IZADD(3),ITAG(3),IADD(3),ISETOF(3), B9400033^^ 9 2 IMOVEL(3),ICOMP(3),IGOTO(3),IEXCPT(3) B9400034^^ C B9400035^^ C B9400036^^ C****EQUIVALENCE--FOR RPG SOURCE CODE GENERATION FILE + CALC SPECS B9400037^^ C B9400038^^ 10 EQUIVALENCE (C1(1),CAL(1)),(C2(1),CAL(26)),(C3(1),CAL(51)), B9400039^^ 10 2 (C4(1),CAL(76)),(C5(1),CAL(101)),(C6(1),CAL(126)), B9400040^^ 10 3 (C7(1),CAL(151)),(C8(1),CAL(176)),(C9(1),CAL(201)), B9400041^^ 10 4 (C10(1),CAL(226)),(C11(1),CAL(251)),(C12(1),CAL(276)) B9400042^^ 11 EQUIVALENCE (F1(1),FALL(1)),(F2(1),FALL(21)),(F3(1),FALL(41)) B9400043^^ C B9400044^^ C B9400045^^ C RPG FILE SPEC SOURCE CODE B9400046^^ 12 DATA F1/'UTIFIL IC F 80R04AI 1 DISK '/ B9400047^^ 13 DATA F2/'PGEXTR IPE F 132 DISK '/ B9400048^^ 14 DATA F3/'PRINT O F 132 PRINTER'/ B9400049^^ C B9400050^^ C RPG CALC SPEC SOURCE CODE B9400051^^ 15 DATA C1 /'C BEGIN TAG '/ B9400053^^ 16 DATA C2 /'C 50 GOTO AROUND '/ B9400054^^ 17 DATA C3 /'C MOVE HDR1 UTKEY 4 '/ B9400055^t FTN 3.3B (OPT = LPC) PGGN2P PAGE 2 DATE: 08/29/84 TIME: 2245 t^ 18 DATA C4 /'C UTKEY CHAINUTIFIL 11'/ B9400056^^ 19 DATA C5 /'C MOVEAHEADER HDR,1 '/ B9400057^^ 20 DATA C6 /'C MOVE HDR2 UTKEY 4 '/ B9400058^^ 21 DATA C7 /'C UTKEY CHAINUTIFIL 11'/ B9400059^^ 22 DATA C8 /'C MOVEAHEADER HDR,2 '/ B9400060^^ 23 DATA C9 /'C MOVE HDR3 UTKEY 4 '/ B9400061^^ 24 DATA C10/'C UTKEY CHAINUTIFIL '/ B9400062^^ 25 DATA C11/'C MOVEAHEADER HDR,3 '/ B9400063^^ 26 DATA C12/'C SETON 50'/ B9400064^^ C B9400065^^ 27 DATA IMOVE/' MOVE '/,ISETON/' SETON'/,IZADD/' Z-ADD'/, B9400066^^ 27 2 ITAG/' TAG '/,IADD/' ADD '/,ISETOF/' SETOF'/, B9400067^^ 27 3 IMOVEL/' MOVEL'/,ICOMP/' COMP '/,IGOTO/' GOTO '/, B9400068^^ 27 4 IEXCPT/' EXCPT'/ B9400069^^ 28 DATA RPTG/'RPTG'/,ZERO/0/,COMMA/$002C/ B9400070^^ 29 EXTERNAL BINASC,ASCBIN B9400071^^ C B9400072^^ C********* BUILD JOB STREAM UP TO RPG SOURCE PROGRAM B9400073^^ C B9400074^^ C***** INSERT CODE FOR RPG JCL B9400075^^ 30 2000 CONTINUE B9400076^^ 31 GO TO 3100 B9400077^^ C B9400078^^ C B9400079^^ C********* WRITE RECORD TO RPTWRK FILE B9400080^^ C B9400081^^ 32 3000 CALL PUTS(WKPRQB,LRPGWK,1,ISTAT) B9400082^^ 33 IF (ISTAT.LT.0) GO TO 4020 B9400083^^ C CLEAR BUFFER B9400084^^ 34 CALL CCSBLK(LRPGWK,84) B9400085^^ 35 GO TO IRTN B9400086^^ C B9400087^^ C B9400088^^ C********* GENERATE RPG SOURC CODE TO PRODUCE B9400089^^ C********* THE DESIRED REPORT B9400090^^ C B9400091^^ C TYPE H - HEADER SPECS B9400092^^ C B9400093^^ 36 3100 IHOLD=$48 B9400094^^ 37 CALL CCSPUT(IHOLD,6,LRPGWK) B9400095^^ 38 LRPGWK(38)=$5250 B9400096^^ 39 LRPGWK(39)=$5450 B9400097^^ 40 LRPGWK(40)=HPGMN(3) B9400098^^ 41 ASSIGN 3200 TO IRTN B9400099^^ 42 GO TO 3000 B9400100^^ C B9400101^^ C TYPE F - FILE SPECS B9400102^^ C B9400103^^ C FORMAT 3 F RECORDS--UTIFIL,PGEXTR,PRINT B9400104^^ 43 3200 ASSIGN 3230 TO IRTN B9400105^^ 44 DO 3230 L=1,3 B9400106^^ 45 LRPGWK(3)=$2046 B9400107^^ 46 ICOL=(20*L)-20 B9400108^^ 47 3215 DO 3220 L1=1,20 B9400109^t FTN 3.3B (OPT = LPC) PGGN2P PAGE 3 DATE: 08/29/84 TIME: 2245 t^ 48 IPOS=ICOL+L1 B9400110^^ 49 LRPGWK(L1+3)=FALL(IPOS) B9400111^^ 50 3220 CONTINUE B9400112^^ 51 GO TO 3000 B9400113^^ 52 3230 CONTINUE B9400114^^ C TYPE E - EXTENSION SPECS B9400115^^ 53 3240 ASSIGN 3250 TO IRTN B9400116^^ 54 LRPGWK(3) =$2045 B9400117^^ 55 LRPGWK(14)=$4844 B9400118^^ 56 LRPGWK(15)=$5220 B9400119^^ 57 LRPGWK(20)=$3320 B9400120^^ 58 LRPGWK(21)=$3430 B9400121^^ C E HDR 3 40 B9400122^^ 59 GO TO 3000 B9400123^^ 60 3250 CONTINUE B9400124^^ C B9400125^^ C TYPE I - INPUT SPECS B9400126^^ C B9400127^^ C FORMAT UTILITY FILE INPUT SPECS B9400128^^ 61 3300 ASSIGN 3310 TO IRTN B9400129^^ 62 LRPGWK(3)=$2049 B9400130^^ 63 LRPGWK(4)=$5554 B9400131^^ 64 LRPGWK(5)=$4946 B9400132^^ 65 LRPGWK(6)=$494C B9400133^^ 66 LRPGWK(8)=$4141 B9400134^^ 67 LRPGWK(10)=$3031 B9400135^^ C IUTIFIL AA 01 B9400136^^ 68 GO TO 3000 B9400137^^ 69 3310 ASSIGN 3315 TO IRTN B9400138^^ 70 LRPGWK(3)=$2049 B9400139^^ 71 LRPGWK(24)=$3520 B9400140^^ 72 LRPGWK(25)=$2034 B9400141^^ 73 LRPGWK(26)=$3420 B9400142^^ 74 LRPGWK(27)=$4845 B9400143^^ 75 LRPGWK(28)=$4144 B9400144^^ 76 LRPGWK(29)=$4552 B9400145^^ C I 5 44 HEADER B9400146^^ 77 GO TO 3000 B9400147^^ C FORMAT PGEXTR INPUT SPECS B9400148^^ 78 3315 ASSIGN 3320 TO IRTN B9400149^^ 79 LRPGWK(3)=$2049 B9400150^^ 80 CALL CCSMVA(F2,1,7,LRPGWK,7,7) B9400151^^ 81 LRPGWK(8)=$4242 B9400152^^ 82 LRPGWK(10)=$3032 B9400153^^ C IPGEXTR BB 02 B9400154^^ 83 GO TO 3000 B9400155^^ C INPUT SPECS COME FOROM Q6EPOS,Q6NAME B9400156^^ 84 3320 CONTINUE B9400157^^ 85 ASSIGN 3350 TO IRTN B9400158^^ 86 IPOS=1 B9400159^^ 87 IPW1=4 B9400160^^ 88 IBEG=1 B9400161^^ 89 IEND=0 B9400162^^ 90 DO 3350 L=1,NNAME B9400163^t FTN 3.3B (OPT = LPC) PGGN2P PAGE 4 DATE: 08/29/84 TIME: 2245 t^ 91 LRPGWK(3)=$2049 B9400164^^ C DATA NAME B9400165^^ 92 CALL CCSMVA(Q6NAME,IPOS,6,LRPGWK,53,6) B9400166^^ C DECIMAL POSITIONS B9400167^^ 93 ICOL=(IPW1*2)+4 B9400168^^ 94 CALL CCSMVA(Q6EPOS,ICOL,1,LRPGWK,52,1) B9400169^^ C BEGINNING POSITION B9400170^^ 95 CALL BINASC(IBEG,IHOLD2) B9400171^^ 96 CALL CCSMVA(IHOLD2,1,4,LRPGWK,44,4) B9400172^^ C ENDING POSITION B9400173^^ 97 CALL ASCBIN(Q6EPOS(IPW1+1),BIN) B9400174^^ 98 CALL ASCBIN(Q6EPOS(IPW1),M) B9400175^^ 99 BIN = BIN + (100*M) B9400176^^ 100 IEND=IEND+BIN ***00177^^ 101 CALL BINASC(IEND,IHOLD2) B9400178^^ 102 CALL CCSMVA(IHOLD2,1,4,LRPGWK,48,4) B9400179^^ C CALCULATE NEW BEG--IBEG+LENGTH B9400180^^ 103 IBEG=IBEG+BIN B9400181^^ C UPDATE POINTERS B9400182^^ 104 IPOS=IPOS+6 B9400183^^ 105 IPW1=IPW1+6 B9400184^^ 106 GO TO 3000 B9400185^^ 107 3350 CONTINUE B9400186^^ C FORMAT CALCULATION SECTION B9400187^^ C B9400188^^ C READ UTIFIL TO SET UP HEADINGS B9400189^^ C CONSTANT--SET UP IN DATA STMTS B9400190^^ 108 3400 ASSIGN 3410 TO IRTN B9400191^^ 109 IPOS=1 B9400192^^ 110 DO 3410 L=1,12 B9400193^^ 111 CALL CCSMVA(CAL,IPOS,50,LRPGWK,6,50) B9400194^^ 112 IF (L.EQ.3.OR.L.EQ.6.OR.L.EQ.9) GO TO 3405 B9400195^^ 113 GO TO 3406 B9400196^^ 114 3405 LRPGWK(17)=$2748 B9400197^^ 115 IHOLD=$0027 B9400198^^ 116 CALL CCSPUT(IHOLD,38,LRPGWK) B9400199^^ 117 3406 IPOS=IPOS+50 B9400200^^ 118 GO TO 3000 B9400201^^ 119 3410 CONTINUE B9400202^^ C INIT HOLD AREA FOR LEVEL BREAKS B9400203^^ 120 IF (NLKEY.EQ.0) GO TO 3430 B9400204^^ 121 ASSIGN 3420 TO IRTN B9400205^^ 122 DO 3420 L=1,NLKEY B9400206^^ 123 IPOS=(L*3)-2 B9400207^^ 124 TBLKEY(1)=Q4LVLB(IPOS) B9400208^^ 125 TBLKEY(2)=Q4LVLB(IPOS+1) B9400209^^ 126 TBLKEY(3)=Q4LVLB(IPOS+2) B9400210^^ 127 CALL READR(TBLRQB,TBLREC,TBLKEY,ISTAT) B9400211^^ 128 IF (ISTAT.LT.0) GO TO 4010 B9400212^^ 129 LRPGWK(3)=$2043 B9400213^^ C OPERATION MOVE B9400214^^ 130 CALL CCSMVA(IMOVE,2,5,LRPGWK,28,5) B9400215^^ C FACTOR 2 B9400216^^ 131 LRPGWK(17)=TBLREC(1) B9400217^t FTN 3.3B (OPT = LPC) PGGN2P PAGE 5 DATE: 08/29/84 TIME: 2245 t^ 132 LRPGWK(18)=TBLREC(2) B9400218^^ 133 LRPGWK(19)=TBLREC(3) B9400219^^ C RESULT HLB1,HLB2,HLB3 B9400220^^ 134 LRPGWK(22)=$484C B9400221^^ 135 LRPGWK(23)=$4230+L B9400222^^ C LENGTH + DECIMAL POSITIONS B9400223^^ 136 CALL CCSMVA(TBLREC,18,1,LRPGWK,52,1) B9400224^^ 137 CALL CCSMVA(TBLREC,12,3,LRPGWK,49,3) B9400225^^ 138 GO TO 3000 B9400226^^ 139 3420 CONTINUE B9400227^^ C ZERO FILL FINAL TOTAL ACCUMS B9400228^^ C SET LEVEL BREAK INDIC ON--CLEAR TOTALS B9400229^^ 140 3430 ASSIGN 3440 TO IRTN B9400230^^ 141 LRPGWK(3)=$2043 B9400231^^ 142 CALL CCSMVA(ISETON,2,5,LRPGWK,28,5) B9400232^^ 143 LRPGWK(27)=$2033 B9400233^^ 144 LRPGWK(28)=$3033 B9400234^^ 145 LRPGWK(29)=$3133 B9400235^^ 146 LRPGWK(30)=$3220 B9400236^^ C C SETON 303132 B9400237^^ 147 GO TO 3000 B9400238^^ 148 3440 ASSIGN 3450 TO IRTN B9400239^^ 149 IF (NTFLDS.EQ.0) GO TO 3450 B9400240^^ 150 DO 3450 L=1,NTFLDS B9400241^^ C C Z-ADD0 T0XX XXX B9400242^^ 151 LRPGWK(3)=$2043 B9400243^^ 152 CALL CCSMVA(IZADD,2,5,LRPGWK,28,5) B9400244^^ 153 LRPGWK(17)=$3020 B9400245^^ 154 LRPGWK(22)=$5430 B9400246^^ 155 CALL BINASC(L,IHOLD2) B9400247^^ 156 LRPGWK(23)=IHOLD2(2) B9400248^^ 157 IPOS=((L-1)*9)+7 B9400249^^ 158 CALL CCSMVA(Q6TOT,IPOS,2,IHOLD,1,2) B9400250^^ 159 CALL ASCBIN(IHOLD,BIN) B9400251^^ C ADD 2 POSITIONS FOR POSSIBLE 'CR' FOR DOLLAR SIGN B9400252^^ 160 BIN = BIN + 2 B9400253^^ 161 CALL BINASC(BIN,IHOLD2) B9400254^^ 162 CALL CCSMVA(IHOLD2,3,2,LRPGWK,50,2) B9400255^^ 163 IPOS=IPOS+2 B9400256^^ 164 CALL CCSMVA(Q6TOT,IPOS,1,LRPGWK,52,1) B9400257^^ 165 GO TO 3000 B9400258^^ 166 3450 CONTINUE B9400259^^ C INITAILIZE FINAL RECORD COUNT B9400260^^ 167 ASSIGN 3451 TO IRTN B9400261^^ 168 LRPGWK(3)=$2043 B9400262^^ 169 CALL CCSMVA(IZADD,2,5,LRPGWK,28,5) B9400263^^ 170 LRPGWK(17)=$3020 B9400264^^ 171 LRPGWK(22)=$5452 B9400265^^ 172 LRPGWK(23)=$434E B9400266^^ 173 LRPGWK(24)=$5430 B9400267^^ 174 LRPGWK(26)=$3530 B9400268^^ C C Z-ADD0 TRCNT0 50 B9400269^^ 175 GO TO 3000 B9400270^^ C B9400271^t FTN 3.3B (OPT = LPC) PGGN2P PAGE 6 DATE: 08/29/84 TIME: 2245 t^ 176 3451 CONTINUE B9400272^^ C INITIALIZE LINE COUNT TO 63 B9400273^^ 177 ASSIGN 3455 TO IRTN B9400274^^ 178 LRPGWK(3)=$2043 B9400275^^ 179 CALL CCSMVA(IZADD,2,5,LRPGWK,28,5) B9400276^^ 180 LRPGWK(17)=$3633 B9400277^^ 181 LRPGWK(22)=$4C4E B9400278^^ 182 LRPGWK(23)=$434E B9400279^^ 183 LRPGWK(24)=$5420 B9400280^^ 184 LRPGWK(26)=$3230 B9400281^^ C C Z-ADD63 LNCNT 20 B9400282^^ 185 GO TO 3000 B9400283^^ C B9400284^^ C 1. CLEAR TOTALS IF LEVEL BREAK OCCURRED B9400285^^ C ON PRECEDING RECORD B9400286^^ C 2. ADD PRECEDING RECORDS TOTALS TO LOWEST B9400287^^ C LEVEL B9400288^^ C 3. SETOF SELECT RECORD INDIC + LEVEL BREAK B9400289^^ C INDIC B9400290^^ 186 3455 ASSIGN 3456 TO IRTN B9400291^^ 187 LRPGWK(3)=$2043 B9400292^^ 188 LRPGWK(9) = $2041 B9400293^^ 189 LRPGWK(10)=$524F B9400294^^ 190 LRPGWK(11)=$554E B9400295^^ 191 LRPGWK(12)=$4420 B9400296^^ 192 CALL CCSMVA(ITAG,2,5,LRPGWK,28,5) B9400297^^ C C AROUND TAG B9400298^^ 193 GO TO 3000 B9400299^^ C CLEAR LINE COUNT IF PAGE OVERFLOW LAST CYCLE B9400300^^ 194 3456 ASSIGN 3460 TO IRTN B9400301^^ 195 LRPGWK(3)=$2043 B9400302^^ 196 LRPGWK(7)=$3430 B9400303^^ 197 CALL CCSMVA(IZADD,2,5,LRPGWK,28,5) B9400304^^ 198 LRPGWK(17)=$3020 B9400305^^ 199 LRPGWK(22)=$4C4E B9400306^^ 200 LRPGWK(23)=$434E B9400307^^ 201 LRPGWK(24)=$5420 B9400308^^ C C Z-ADD0 LNCNT B9400309^^ 202 GO TO 3000 B9400310^^ C CLEAR TOTALS B9400311^^ 203 3460 IF (NLKEY.LE.0) GO TO 3470 B9400312^^ 204 DO 3470 L=1,NLKEY B9400313^^ 205 INDIC=L-1+$3330 B9400314^^ 206 ITN1=$5430+L B9400315^^ C C XX Z-ADD0 TRCNTX 50 B9400316^^ 207 LRPGWK(3)=$2043 B9400317^^ 208 LRPGWK(7)=INDIC B9400318^^ 209 CALL CCSMVA(IZADD,2,5,LRPGWK,28,5) B9400319^^ 210 LRPGWK(17)=$3020 B9400320^^ 211 LRPGWK(22)=$5452 B9400321^^ 212 LRPGWK(23)=$434E B9400322^^ 213 LRPGWK(24)=ITN1 B9400323^^ 214 LRPGWK(26)=$3530 B9400324^^ 215 ASSIGN 3465 TO IRTN B9400325^t FTN 3.3B (OPT = LPC) PGGN2P PAGE 7 DATE: 08/29/84 TIME: 2245 t^ 216 GO TO 3000 B9400326^^ 217 3465 ASSIGN 3470 TO IRTN B9400327^^ 218 IF (NTFLDS.EQ.0) GO TO 3470 B9400328^^ 219 DO 3470 L1=1,NTFLDS B9400329^^ C C XX Z-ADD0 TXXX XXX B9400330^^ 220 LRPGWK(3)=$2043 B9400331^^ 221 LRPGWK(7)=INDIC B9400332^^ 222 CALL CCSMVA(IZADD,2,5,LRPGWK,28,5) B9400333^^ 223 LRPGWK(17)=$3020 B9400334^^ 224 LRPGWK(22)=ITN1 B9400335^^ 225 CALL BINASC(L1,IHOLD2) B9400336^^ 226 LRPGWK(23)=IHOLD2(2) B9400337^^ 227 IPOS=((L1-1)*9)+7 B9400338^^ 228 CALL CCSMVA(Q6TOT,IPOS,2,IHOLD,1,2) B9400339^^ 229 CALL ASCBIN(IHOLD,BIN) B9400340^^ C ADD 2 POSITIONS FOR POSSIBLE 'CR' FOR DOLLAR SIGN B9400341^^ 230 BIN = BIN + 2 B9400342^^ 231 CALL BINASC(BIN,IHOLD2) B9400343^^ 232 CALL CCSMVA(IHOLD2,3,2,LRPGWK,50,2) B9400344^^ 233 IPOS=IPOS+2 B9400345^^ 234 CALL CCSMVA(Q6TOT,IPOS,1,LRPGWK,52,1) B9400346^^ 235 GO TO 3000 B9400347^^ 236 3470 CONTINUE B9400348^^ C B9400349^^ C ADD PRECEDING RECORD TOTALS B9400350^^ 237 ITN1=NLKEY+$5430 B9400351^^ 238 ASSIGN 3475 TO IRTN B9400352^^ 239 LRPGWK(3)=$2043 B9400353^^ 240 LRPGWK(7)=$3132 B9400354^^ 241 CALL CCSMVA(IADD,2,5,LRPGWK,28,5) B9400355^^ 242 LRPGWK(17)=$3120 B9400356^^ 243 LRPGWK(22)=$5452 B9400357^^ 244 LRPGWK(23)=$434E B9400358^^ 245 LRPGWK(24)=ITN1 B9400359^^ 246 LRPGWK(9)=$2054 B9400360^^ 247 LRPGWK(10)=$5243 B9400361^^ 248 LRPGWK(11)=$4E54 B9400362^^ 249 CALL CCSMVA(ITN1,2,1,LRPGWK,23,1) B9400363^^ C C 12 TRCNTX ADD 1 TRCNTX B9400364^^ 250 GO TO 3000 B9400365^^ 251 3475 IF (NTFLDS.EQ.0) GO TO 3480 B9400366^^ 252 ASSIGN 3480 TO IRTN B9400367^^ 253 DO 3480 L=1,NTFLDS B9400368^^ 254 LRPGWK(3)=$2043 B9400369^^ 255 LRPGWK(7)=$3132 B9400370^^ 256 CALL CCSMVA(IADD,2,5,LRPGWK,28,5) B9400371^^ 257 LRPGWK(17)=$4854 B9400372^^ 258 CALL BINASC(L,IHOLD2) B9400373^^ 259 LRPGWK(18)=IHOLD2(2) B9400374^^ 260 LRPGWK(22)=ITN1 B9400375^^ 261 LRPGWK(23)=IHOLD2(2) B9400376^^ 262 LRPGWK(9)=$2054 B9400377^^ 263 CALL CCSMVA(ITN1,2,1,LRPGWK,19,1) B9400378^^ 264 CALL CCSMVA(IHOLD2,3,2,LRPGWK,20,2) B9400379^t FTN 3.3B (OPT = LPC) PGGN2P PAGE 8 DATE: 08/29/84 TIME: 2245 t^ C C 12 TXXX ADD HTXX TXXX B9400380^^ 265 GO TO 3000 B9400381^^ 266 3480 CONTINUE B9400382^^ C SETOF INDICATORS B9400383^^ 267 ASSIGN 3490 TO IRTN B9400384^^ 268 LRPGWK(3)=$2043 B9400385^^ 269 CALL CCSMVA(ISETOF,2,5,LRPGWK,28,5) B9400386^^ 270 IND(1)=$3139 B9400387^^ 271 IND(2)=$3330 B9400388^^ 272 IND(3)=$3331 B9400389^^ 273 CALL CCSMVA(IND,1,6,LRPGWK,54,6) B9400390^^ 274 GO TO 3000 B9400391^^ 275 3490 CONTINUE B9400392^^ 276 ASSIGN 3500 TO IRTN B9400393^^ 277 LRPGWK(3)=$2043 B9400394^^ 278 CALL CCSMVA(ISETOF,2,5,LRPGWK,28,5) B9400395^^ 279 IND(1)=$3332 B9400396^^ 280 IND(2)=$3430 B9400397^^ 281 IND(3)=$3132 B9400398^^ 282 CALL CCSMVA(IND,1,6,LRPGWK,54,6) B9400399^^ 283 GO TO 3000 B9400400^^ 284 3500 CONTINUE B9400401^^ C CHECK FOR LEVEL BREAKS B9400402^^ C ADD TO APPROPRIATE TOTALS B9400403^^ 285 LRPGWK(3)=$2043 B9400404^^ 286 LRPGWK(9)=$2043 B9400405^^ 287 LRPGWK(10)=$4B4C B9400406^^ 288 LRPGWK(11)=$564C B9400407^^ 289 CALL CCSMVA(ITAG,2,5,LRPGWK,28,5) B9400408^^ 290 ASSIGN 3600 TO IRTN B9400409^^ C C CKLVL TAG B9400410^^ 291 GO TO 3000 B9400411^^ C B9400412^^ C B9400413^^ 292 3600 IF (NLKEY.EQ.0) GO TO 3720 B9400414^^ C C HLBX COMP XXXXXX XXXX B9400416^^ 293 DO 3640 L=1,NLKEY B9400417^^ 294 LRPGWK(3)=$2043 B9400418^^ 295 LRPGWK(9)=$2048 B9400419^^ 296 LRPGWK(10)=$4C42 B9400420^^ 297 LRPGWK(11)=$2020 B9400421^^ 298 IHOLD=$0030+L B9400422^^ 299 CALL CCSPUT(IHOLD,21,LRPGWK) B9400423^^ 300 CALL CCSMVA(ICOMP,2,5,LRPGWK,28,5) B9400424^^ 301 ICOL=(L*6)-5 B9400425^^ 302 CALL CCSMVA(Q4LVLB,ICOL,6,LRPGWK,33,6) B9400426^^ 303 INDIC=$3330+L-1 B9400427^^ 304 IND(1)=INDIC B9400428^^ 305 IND(2)=INDIC B9400429^^ 306 CALL CCSMVA(IND,1,4,LRPGWK,54,4) B9400430^^ 307 ASSIGN 3610 TO IRTN B9400431^^ 308 GO TO 3000 B9400432^^ C XX MOVE XXXXXX HLBX B9400433^^ 309 3610 LRPGWK(3)=$2043 B9400434^t FTN 3.3B (OPT = LPC) PGGN2P PAGE 9 DATE: 08/29/84 TIME: 2245 t^ 310 LRPGWK(7)=INDIC B9400435^^ 311 CALL CCSMVA(IMOVE,2,5,LRPGWK,28,5) B9400436^^ 312 CALL CCSMVA(Q4LVLB,ICOL,6,LRPGWK,33,6) B9400437^^ 313 LRPGWK(22)=$484C B9400438^^ 314 LRPGWK(23)=$4230 + L B9400439^^ 315 ASSIGN 3620 TO IRTN B9400440^^ 316 GO TO 3000 B9400441^^ 317 3620 IF (L.EQ.NLKEY) GO TO 3640 B9400442^^ C SETON MINOR LEVEL BREAK INDIC IF MAJOR LEVEL BREAK B9400443^^ C OCCURRED B9400444^^ 318 LRPGWK(3)=$2043 B9400445^^ 319 LRPGWK(7)=$3330+L-1 B9400446^^ 320 CALL CCSMVA(ISETON,2,5,LRPGWK,28,5) B9400447^^ 321 IND(1)=$3330+L B9400448^^ 322 IND(2)=$3330+L+1 B9400449^^ 323 IF (L.EQ.2) IND(2)=$2020 B9400450^^ 324 CALL CCSMVA(IND,1,4,LRPGWK,54,4) B9400451^^ 325 ASSIGN 3625 TO IRTN B9400452^^ 326 GO TO 3000 B9400453^^ 327 3625 ICOL=(L*6)+1 B9400454^^ 328 LRPGWK(3)=$2043 B9400455^^ 329 LRPGWK(7)=$3330+L-1 B9400456^^ 330 CALL CCSMVA(IMOVE,2,5,LRPGWK,28,5) B9400457^^ 331 ICOLW=(ICOL/2)+1 B9400458^^ 332 IF (Q4LVLB(ICOLW).EQ.$2020) GO TO 3630 B9400459^^ 333 CALL CCSMVA(Q4LVLB,ICOL,6,LRPGWK,33,6) B9400460^^ 334 LRPGWK(22)=$484C B9400461^^ 335 LRPGWK(23)=$4230+L+1 B9400462^^ 336 ASSIGN 3628 TO IRTN B9400463^^ 337 GO TO 3000 B9400464^^ 338 3628 ICOL=(L*6)+7 B9400465^^ 339 IF (ICOL.GT.13) GO TO 3630 B9400466^^ 340 LRPGWK(3)=$2043 B9400467^^ 341 LRPGWK(7)=$3330+L-1 B9400468^^ 342 CALL CCSMVA(IMOVE,2,5,LRPGWK,28,5) B9400469^^ 343 ICOLW=(ICOL/2)+1 B9400470^^ 344 IF (Q4LVLB(ICOLW).EQ.$2020) GO TO 3630 B9400471^^ 345 CALL CCSMVA(Q4LVLB,ICOL,6,LRPGWK,33,6) B9400472^^ 346 LRPGWK(22)=$484C B9400473^^ 347 LRPGWK(23)=$4230+L+2 B9400474^^ 348 ASSIGN 3630 TO IRTN B9400475^^ 349 GO TO 3000 B9400476^^ 350 3630 ASSIGN 3640 TO IRTN B9400477^^ 351 LRPGWK(3)=$2043 B9400478^^ 352 LRPGWK(7)=$3330+L-1 B9400479^^ 353 CALL CCSMVA(IGOTO,2,5,LRPGWK,28,5) B9400480^^ 354 LRPGWK(17)=$4144 B9400481^^ 355 LRPGWK(18)=$4C56 B9400482^^ 356 LRPGWK(19)=$4C20 B9400483^^ 357 GO TO 3000 B9400484^^ 358 3640 CONTINUE B9400485^^ C B9400486^^ C B9400487^^ C B9400488^t FTN 3.3B (OPT = LPC) PGGN2P PAGE 10 DATE: 08/29/84 TIME: 2245 t^ C C ADLVL TAG B9400489^^ 359 ASSIGN 3645 TO IRTN B9400490^^ 360 LRPGWK(3)=$2043 B9400491^^ 361 LRPGWK(9)=$2041 B9400492^^ 362 LRPGWK(10)=$444C B9400493^^ 363 LRPGWK(11)=$564C B9400494^^ 364 CALL CCSMVA(ITAG,2,5,LRPGWK,28,5) B9400495^^ 365 GO TO 3000 B9400496^^ C ADD LEVEL BREAK TOTALS -- IF LEVEL BREAK B9400497^^ 366 3645 LL=NLKEY-0 B9400498^^ 367 IF (LL.LE.0) GO TO 3705 B9400499^^ 368 DO 3700 L=NLKEY,1,-1 B9400500^^ 369 INDIC=$3330+L-1 B9400501^^ 370 ITN1=$5430+L B9400502^^ 371 ITN2=$5430+L-1 B9400503^^ 372 LRPGWK(3)=$2043 B9400504^^ 373 LRPGWK(7)=INDIC B9400505^^ 374 CALL CCSMVA(IADD,2,5,LRPGWK,28,5) B9400506^^ 375 LRPGWK(17)=$5452 B9400507^^ 376 LRPGWK(18)=$434E B9400508^^ 377 LRPGWK(19)=ITN1 B9400509^^ 378 LRPGWK(22)=$5452 B9400510^^ 379 LRPGWK(23)=$434E B9400511^^ 380 LRPGWK(24)=ITN2 B9400512^^ 381 LRPGWK(9)=$2054 B9400513^^ 382 LRPGWK(10)=$5243 B9400514^^ 383 LRPGWK(11)=$4E54 B9400515^^ 384 IHOLD=$0030+L-1 B9400516^^ 385 CALL CCSMVA(IHOLD,2,1,LRPGWK,23,1) B9400517^^ 386 ASSIGN 3650 TO IRTN B9400518^^ 387 GO TO 3000 B9400519^^ 388 3650 ASSIGN 3660 TO IRTN B9400520^^ 389 IF (NTFLDS.EQ.0) GO TO 3660 B9400521^^ 390 DO 3690 L1=1,NTFLDS B9400522^^ 391 LRPGWK(3)=$2043 B9400523^^ 392 LRPGWK(7)=INDIC B9400524^^ 393 CALL CCSMVA(IADD,2,5,LRPGWK,28,5) B9400525^^ 394 LRPGWK(17)=ITN1 B9400526^^ 395 CALL BINASC(L1,IHOLD2) B9400527^^ 396 LRPGWK(18)=IHOLD2(2) B9400528^^ 397 LRPGWK(22)=ITN2 B9400529^^ 398 LRPGWK(23)=LRPGWK(18) B9400530^^ 399 LRPGWK(9)=$2054 B9400531^^ 400 IHOLD=$0030+L-1 B9400532^^ 401 CALL CCSMVA(IHOLD,2,1,LRPGWK,19,1) B9400533^^ 402 CALL CCSMVA(IHOLD2,3,2,LRPGWK,20,2) B9400534^^ 403 GO TO 3000 B9400535^^ C CHECK FOR ZERO RECORDS SELECTED B9400536^^ C SET INDIC ONLY IF NON-ZERO B9400537^^ 404 3660 CONTINUE B9400538^^ 405 IF (L.NE.NLKEY) GO TO 3690 B9400539^^ 406 ASSIGN 3690 TO IRTN B9400540^^ 407 LRPGWK(3)=$2043 B9400541^^ 408 LRPGWK(7)=INDIC B9400542^t FTN 3.3B (OPT = LPC) PGGN2P PAGE 11 DATE: 08/29/84 TIME: 2245 t^ 409 CALL CCSMVA(ICOMP,2,5,LRPGWK,28,5) B9400543^^ 410 LRPGWK(9)=$2054 B9400544^^ 411 LRPGWK(10)=$5243 B9400545^^ 412 LRPGWK(11)=$4E54 B9400546^^ 413 CALL CCSMVA(IHOLD,2,1,LRPGWK,23,1) B9400547^^ 414 LRPGWK(17)=$3020 B9400548^^ 415 IHOLD=$3133 B9400549^^ 416 CALL CCSMVA(IHOLD,1,2,LRPGWK,54,2) B9400550^^ 417 CALL CCSMVA(IHOLD,1,2,LRPGWK,56,2) B9400551^^ 418 GO TO 3000 B9400552^^ 419 3690 CONTINUE B9400553^^ 420 3700 CONTINUE B9400554^^ 421 ASSIGN 3701 TO IRTN B9400555^^ 422 LRPGWK(3)=$2043 B9400556^^ 423 CALL CCSMVA(IEXCPT,2,5,LRPGWK,28,5) B9400557^^ 424 GO TO 3000 B9400558^^ 425 3701 CONTINUE B9400559^^ 426 ASSIGN 3705 TO IRTN B9400560^^ 427 LL=NLKEY-1 B9400561^^ 428 IF (LL.LE.0) GO TO 3705 B9400562^^ 429 DO 3705 L=1,LL B9400563^^ 430 LRPGWK(3)=$2043 B9400564^^ 431 LRPGWK(5)=$2031 B9400565^^ 432 LRPGWK(6)=$3320 B9400566^^ 433 LRPGWK(7)=$3330+L B9400567^^ 434 LRPGWK(9)=$204C B9400568^^ 435 LRPGWK(10)=$4E43 B9400569^^ 436 LRPGWK(11)=$4E54 B9400570^^ 437 CALL CCSMVA(IADD,2,5,LRPGWK,28,5) B9400571^^ 438 LRPGWK(17)=$3520 B9400572^^ 439 LRPGWK(22)=$4C4E B9400573^^ 440 LRPGWK(23)=$434E B9400574^^ 441 LRPGWK(24)=$5420 B9400575^^ C C 13 3X LNCNT ADD 5 LNCNT B9400576^^ 442 GO TO 3000 B9400577^^ 443 3705 CONTINUE B9400578^^ C B9400579^^ C 1. SAVE TOTAL FIELDS B9400580^^ C 2. CHECK FOR PRINT OVERFLOW B9400581^^ C B9400582^^ C SAVE TOTAL FIELDS B9400583^^ 444 3720 IF (NTFLDS.EQ.0) GO TO 3730 B9400584^^ 445 IPOS=1 B9400585^^ 446 ASSIGN 3730 TO IRTN B9400586^^ 447 DO 3730 L=1,NTFLDS B9400587^^ 448 LRPGWK(3)=$2043 B9400588^^ 449 CALL CCSMVA(IMOVE,2,5,LRPGWK,28,5) B9400589^^ 450 CALL CCSMVA(Q6TOT,IPOS,6,LRPGWK,33,6) B9400590^^ 451 LRPGWK(22)=$4854 B9400591^^ 452 CALL BINASC(L,IHOLD2) B9400592^^ 453 LRPGWK(23)=IHOLD2(2) B9400593^^ 454 ICOL=IPOS+6 B9400594^^ 455 CALL CCSMVA(Q6TOT,ICOL,3,LRPGWK,50,3) B9400595^^ 456 IPOS=IPOS+9 B9400596^t FTN 3.3B (OPT = LPC) PGGN2P PAGE 12 DATE: 08/29/84 TIME: 2245 t^ C C MOVE XXXXXX HTXX XXX B9400597^^ 457 GO TO 3000 B9400598^^ 458 3730 CONTINUE B9400599^^ C B9400600^^ C TURN ON INDIC 12--OK TO ADD HTXX FIELDS B9400601^^ 459 ASSIGN 3735 TO IRTN B9400602^^ 460 LRPGWK(3)=$2043 B9400603^^ 461 CALL CCSMVA(ISETON,2,5,LRPGWK,28,5) B9400604^^ 462 LRPGWK(27)=$2031 B9400605^^ 463 LRPGWK(28)=$3220 B9400606^^ C C SETON 12 B9400607^^ 464 GO TO 3000 B9400608^^ C B9400609^^ C CHECK LINE COUNT FOR OVERFLOW B9400610^^ C TURN ON INDIC 40 IF NEED TOP-OF-PAGE B9400611^^ C 1. ADD 1 TO LNCNT B9400612^^ C 2. COMP LNCNT TO MAX PER PAGE B9400613^^ C 3. IF EXCEEDS MAX PER PAGE OR B9400614^^ C LEVEL BREAK, SET INDIC 40 B9400615^^ C TO FORCE TOP-OF-PAGE, ADD 1 TO PGCNT B9400616^^ C B9400617^^ 465 3735 ASSIGN 3740 TO IRTN B9400618^^ 466 LRPGWK(3)=$2043 B9400619^^ 467 CALL CCSMVA(IADD,2,5,LRPGWK,28,5) B9400620^^ 468 LRPGWK(17)=$3120 B9400621^^ 469 LRPGWK(22)=$4C4E B9400622^^ 470 LRPGWK(23)=$434E B9400623^^ 471 LRPGWK(24)=$5420 B9400624^^ 472 LRPGWK(9)=$204C B9400625^^ 473 LRPGWK(10)=$4E43 B9400626^^ 474 LRPGWK(11)=$4E54 B9400627^^ C C ADD 1 LNCNT B9400628^^ 475 GO TO 3000 B9400629^^ 476 3740 ASSIGN 3745 TO IRTN B9400630^^ 477 LRPGWK(3)=$2043 B9400631^^ 478 LRPGWK(9)=$204C B9400632^^ 479 LRPGWK(10)=$4E43 B9400633^^ 480 LRPGWK(11)=$4E54 B9400634^^ 481 CALL CCSMVA(ICOMP,2,5,LRPGWK,28,5) B9400635^^ 482 LRPGWK(17)=$3430 B9400636^^ 483 LRPGWK(27)=$2034 B9400637^^ 484 LRPGWK(28)=$3020 B9400638^^ C C LNCNT COMP 40 40 B9400639^^ 485 GO TO 3000 B9400640^^ C CHECK FOR LEVEL BREAK B9400641^^ 486 3745 ASSIGN 3750 TO IRTN B9400642^^ 487 LRPGWK(3)=$2043 B9400643^^ 488 LRPGWK(5)=$4E33 B9400644^^ 489 LRPGWK(6)=$3020 B9400645^^ 490 CALL CCSMVA(IGOTO,2,5,LRPGWK,28,5) B9400646^^ 491 LRPGWK(17)=$454E B9400647^^ 492 LRPGWK(18)=$4420 B9400648^^ C C N30 GOTO END B9400649^^ 493 GO TO 3000 B9400650^t FTN 3.3B (OPT = LPC) PGGN2P PAGE 13 DATE: 08/29/84 TIME: 2245 t^ C SET INDICATOR 40 B9400651^^ 494 3750 ASSIGN 3755 TO IRTN B9400652^^ 495 LRPGWK(3)=$2043 B9400653^^ 496 CALL CCSMVA(ISETON,2,5,LRPGWK,28,5) B9400654^^ 497 LRPGWK(27)=$2034 B9400655^^ 498 LRPGWK(28)=$3020 B9400656^^ C C SETON 40 B9400657^^ 499 GO TO 3000 B9400658^^ C SET UP END LABEL B9400659^^ 500 3755 ASSIGN 3760 TO IRTN B9400660^^ 501 LRPGWK(3)=$2043 B9400661^^ 502 LRPGWK(9)=$2045 B9400662^^ 503 LRPGWK(10)=$4E44 B9400663^^ 504 CALL CCSMVA(ITAG,2,5,LRPGWK,28,5) B9400664^^ C C END TAG B9400665^^ 505 GO TO 3000 B9400666^^ C B9400667^^ C SET UP LAST RECORD ROUTINE B9400668^^ C 1. CLEAR TOTALS IF LEVEL BREAK OCCURRED ON B9400669^^ C PRECEDING RECORD B9400670^^ C 2. ADD TOTALS--HT, T3, T2, T1 TO TO--GRAND TOTAL B9400671^^ C 3. SET INDIC 20-29 OFF, INDIC 30-32 ON B9400672^^ C B9400673^^ 506 3760 IF (NLKEY.EQ.0) GO TO 3770 B9400674^^ 507 DO 3770 L=1,NLKEY B9400675^^ 508 INDIC=L-1+$3330 B9400676^^ 509 ITN1=$5430+L B9400677^^ 510 ASSIGN 3765 TO IRTN B9400678^^ 511 LRPGWK(3)=$2043 B9400679^^ 512 LRPGWK(4)=$4C52 B9400680^^ 513 LRPGWK(7)=INDIC B9400681^^ 514 CALL CCSMVA(IZADD,2,5,LRPGWK,28,5) B9400682^^ 515 LRPGWK(17)=$3020 B9400683^^ 516 LRPGWK(22)=$5452 B9400684^^ 517 LRPGWK(23)=$434E B9400685^^ 518 LRPGWK(24)=ITN1 B9400686^^ 519 GO TO 3000 B9400687^^ 520 3765 IF (NTFLDS.EQ.0) GO TO 3770 B9400688^^ 521 DO 3770 L1=1,NTFLDS B9400689^^ C CLR XX Z-ADD0 TXXX B9400690^^ 522 LRPGWK(3)=$2043 B9400691^^ 523 LRPGWK(4)=$4C52 B9400692^^ 524 LRPGWK(7)=INDIC B9400693^^ 525 CALL CCSMVA(IZADD,2,5,LRPGWK,28,5) B9400694^^ 526 LRPGWK(17)=$3020 B9400695^^ 527 LRPGWK(22)=ITN1 B9400696^^ 528 CALL BINASC(L1,IHOLD2) B9400697^^ 529 LRPGWK(23)=IHOLD2(2) B9400698^^ 530 ASSIGN 3770 TO IRTN B9400699^^ 531 GO TO 3000 B9400700^^ 532 3770 CONTINUE B9400701^^ C B9400702^^ C ADD TOTALS B9400703^^ 533 LE=1+NLKEY B9400704^t FTN 3.3B (OPT = LPC) PGGN2P PAGE 14 DATE: 08/29/84 TIME: 2245 t^ 534 DO 3780 L=1,LE B9400705^^ 535 ITN1=$5430 + (LE-L+1) B9400706^^ 536 IF (L.EQ.1) ITN1=$4854 B9400707^^ 537 ITN2=$5430 + (LE-L) B9400708^^ 538 ASSIGN 3775 TO IRTN B9400709^^ 539 LRPGWK(3)=$2043 B9400710^^ 540 LRPGWK(4)=$4C52 B9400711^^ 541 IF (L.EQ.1) LRPGWK(7)=$3132 B9400712^^ 542 CALL CCSMVA(IADD,2,5,LRPGWK,28,5) B9400713^^ 543 LRPGWK(17)=$3120 B9400714^^ 544 IF (L.NE.1) LRPGWK(17)=$5452 B9400715^^ 545 IF (L.NE.1) LRPGWK(18)=$434E B9400716^^ 546 IF (L.NE.1) LRPGWK(19)=ITN1 B9400717^^ 547 LRPGWK(22)=$5452 B9400718^^ 548 LRPGWK(23)=$434E B9400719^^ 549 LRPGWK(24)=ITN2 B9400720^^ 550 LRPGWK(9)=$2054 B9400721^^ 551 LRPGWK(10)=$5243 B9400722^^ 552 LRPGWK(11)=$4E54 B9400723^^ 553 CALL CCSMVA(ITN2,2,1,LRPGWK,23,1) B9400724^^ 554 GO TO 3000 B9400725^^ 555 3775 IF (NTFLDS.EQ.0) GO TO 3780 B9400726^^ 556 ASSIGN 3780 TO IRTN B9400727^^ 557 DO 3780 L1=1,NTFLDS B9400728^^ 558 LRPGWK(3)=$2043 B9400729^^ 559 LRPGWK(4)=$4C52 B9400730^^ 560 IF (L.EQ.1) LRPGWK(7)=$3132 B9400731^^ 561 CALL CCSMVA(IADD,2,5,LRPGWK,28,5) B9400732^^ 562 LRPGWK(17)=ITN1 B9400733^^ 563 CALL BINASC(L1,IHOLD2) B9400734^^ 564 LRPGWK(18)=IHOLD2(2) B9400735^^ 565 LRPGWK(22)=ITN2 B9400736^^ 566 LRPGWK(23)=IHOLD2(2) B9400737^^ 567 LRPGWK(9)=$2054 B9400738^^ 568 CALL CCSMVA(ITN2,2,1,LRPGWK,19,1) B9400739^^ 569 CALL CCSMVA(IHOLD2,3,2,LRPGWK,20,2) B9400740^^ C CLR ADD XXXX TXXX B9400741^^ 570 GO TO 3000 B9400742^^ 571 3780 CONTINUE B9400743^^ C SET OF INDIC 12 B9400744^^ 572 ASSIGN 3781 TO IRTN B9400745^^ 573 LRPGWK(3)=$2043 B9400746^^ 574 LRPGWK(4)=$4C52 B9400747^^ 575 CALL CCSMVA(ISETOF,2,5,LRPGWK,28,5) B9400748^^ 576 INDIC=$3132 B9400749^^ 577 CALL CCSMVA(INDIC,1,2,LRPGWK,54,2) B9400750^^ 578 GO TO 3000 B9400751^^ 579 3781 CONTINUE B9400752^^ C B9400753^^ C SET INDICATORS ON 30-32 B9400754^^ 580 IF (NLKEY.EQ.0) GO TO 3790 B9400755^^ 581 ASSIGN 3790 TO IRTN B9400756^^ 582 DO 3790 L=1,NLKEY B9400757^^ 583 LRPGWK(3)=$2043 B9400758^t FTN 3.3B (OPT = LPC) PGGN2P PAGE 15 DATE: 08/29/84 TIME: 2245 t^ 584 LRPGWK(4)=$4C52 B9400759^^ 585 CALL CCSMVA(ISETON,2,5,LRPGWK,28,5) B9400760^^ 586 INDIC=$3330+L-1 B9400761^^ 587 CALL CCSMVA(INDIC,1,2,LRPGWK,54,2) B9400762^^ 588 IHOLD=$3133 B9400763^^ 589 CALL CCSMVA(IHOLD,1,2,LRPGWK,56,2) B9400764^^ 590 GO TO 3000 B9400765^^ 591 3790 CONTINUE B9400766^^ 592 ASSIGN 3795 TO IRTN B9400767^^ 593 LRPGWK(3)=$2043 B9400768^^ 594 LRPGWK(4)=$4C52 B9400769^^ 595 CALL CCSMVA(IEXCPT,2,5,LRPGWK,28,5) B9400770^^ 596 GO TO 3000 B9400771^^ 597 3795 CONTINUE B9400772^^ C B9400773^^ C END OF RPG CALCULATION SECTION B9400774^^ C BEGIN GENERATING RPG CODE FOR OUTPUT SECTION B9400775^^ C TOTALS-HEADINGS-DETAIL B9400776^^ C B9400777^^ C CALCULATE # OF SPACES BETWEEN FIELDS B9400778^^ 598 ISPACE=1+((132-IMAXC)/NNAME) B9400779^^ C B9400780^^ C SET UP TOTAL LINES B9400781^^ 599 LRPGWK(4)=$5052 B9400782^^ 600 LRPGWK(5)=$494E B9400783^^ C TOTAL LINE FOR EACH LEVEL BREAK + GRAND TOTAL LINE B9400784^^ C B9400785^^ C CHECK IF ANY LEVEL BREAKS B9400786^^ 601 LRPGWK(6)=$5420 B9400787^^ 602 IF (NLKEY.EQ.0) GO TO 3860 B9400788^^ C B9400789^^ C YES, SET UP TOTAL LINE FOR EACH LEVEL BREAK B9400790^^ 603 3810 DO 3850 L=1,NLKEY B9400791^^ 604 LRPGWK(3)=$204F B9400792^^ 605 LRPGWK(8)=$4520 B9400793^^ 606 LRPGWK(9)=$3131 B9400794^^ 607 INDIC=$3330+NLKEY-L B9400795^^ 608 LRPGWK(14)=INDIC B9400796^^ 609 ASSIGN 3815 TO IRTN B9400797^^ C O T 11 XX 3X B9400798^^ 610 IHOLD2(1)=$2031 B9400799^^ 611 IHOLD2(2)=$3320 B9400800^^ 612 CALL CCSMVA(IHOLD2,1,4,LRPGWK,23,4) B9400801^^ 613 GO TO 3000 B9400802^^ 614 3815 CONTINUE B9400803^^ 615 ASSIGN 3816 TO IRTN B9400804^^ 616 LRPGWK(3)=$204F B9400805^^ 617 LRPGWK(21)=$2031 B9400806^^ 618 LRPGWK(22)=$3320 B9400807^^ 619 IPOS=((NLKEY-L)*6)+1 B9400808^^ 620 LRPGWK(23)=$2720 B9400809^^ 621 LRPGWK(30)=$2720 B9400810^^ 622 CALL CCSMVA(Q4LVLB,IPOS,6,LRPGWK,46,6) B9400811^^ 623 LRPGWK(27)=$544F B9400812^t FTN 3.3B (OPT = LPC) PGGN2P PAGE 16 DATE: 08/29/84 TIME: 2245 t^ 624 LRPGWK(28)=$5441 B9400813^^ 625 LRPGWK(29)=$4C53 B9400814^^ 626 GO TO 3000 B9400815^^ 627 3816 ITN1=$5430+NLKEY B9400816^^ 628 IPW1=1 B9400817^^ 629 IPOS=1 B9400818^^ 630 IHOLD=$0000 B9400819^^ 631 BIN =0 B9400820^^ 632 IF (NTFLDS.EQ.0) GO TO 3840 B9400821^^ C SET UP ENDING POSITION FOR EACH TOTAL FIELD B9400822^^ 633 DO 3840 L1=1,NTFLDS B9400823^^ 634 LRPGWK(3)=$204F B9400824^^ 635 IHOLD=$5430+NLKEY-L+1 B9400825^^ 636 CALL CCSMVA(IHOLD,1,2,LRPGWK,32,2) B9400826^^ 637 CALL BINASC(L1,IHOLD2) B9400827^^ 638 CALL CCSMVA(IHOLD2,3,2,LRPGWK,34,2) B9400828^^ C GET LENGTH OF FIELD B9400829^^ 639 3820 BIN=Q6EPOS(IPW1)+BIN B9400830^^ 640 CALL BINASC(BIN,IHOLD2) B9400831^^ C ENDING POSITION B9400832^^ 641 CALL CCSMVA(IHOLD2,1,4,LRPGWK,40,4) B9400833^^ 642 BIN=BIN+1 B9400834^^ C INCREMENT LAST ENDING POSITION B9400835^^ C LENGTH+SPACES B9400836^^ C EDIT CODE B9400837^^ 643 ICOL=IPOS+5 B9400838^^ 644 CALL CCSMVA(Q6EPOS,ICOL,1,LRPGWK,38,1) B9400839^^ C CHECK IF TOTAL FIELD B9400840^^ 645 ICOL=IPOS+4 B9400841^^ 646 CALL CCSGET(Q6EPOS,ICOL,IHOLD) B9400842^^ 647 IF (IHOLD.EQ.$0054) GO TO 3830 B9400843^^ C NOT A TOTAL FIELD, DO NOT WRITE B9400844^^ 648 IPW1=IPW1+6 B9400845^^ 649 IPOS=IPOS+12 B9400846^^ 650 GO TO 3820 B9400847^^ C TOTAL FIELD--WRITE OUTPUT SPEC B9400848^^ 651 3830 IPW1=IPW1+6 B9400849^^ 652 ASSIGN 3840 TO IRTN B9400850^^ 653 IPOS=IPOS+12 B9400851^^ 654 GO TO 3000 B9400852^^ 655 3840 CONTINUE B9400853^^ 656 LRPGWK(3)=$204F B9400854^^ 657 LRPGWK(8)=$4520 B9400855^^ 658 LRPGWK(9)=$2032 B9400856^^ 659 LRPGWK(14)=INDIC B9400857^^ 660 ASSIGN 3845 TO IRTN B9400858^^ 661 IHOLD2(1)=$2031 B9400859^^ 662 IHOLD2(2)=$3320 B9400860^^ 663 CALL CCSMVA(IHOLD2,1,4,LRPGWK,23,4) B9400861^^ 664 GO TO 3000 B9400862^^ 665 3845 ASSIGN 3846 TO IRTN B9400863^^ 666 LRPGWK(3)=$204F B9400864^^ 667 LRPGWK(21)=$2031 B9400865^^ 668 LRPGWK(22)=$3220 B9400866^t FTN 3.3B (OPT = LPC) PGGN2P PAGE 17 DATE: 08/29/84 TIME: 2245 t^ 669 LRPGWK(23)=$2752 B9400867^^ 670 LRPGWK(24)=$4543 B9400868^^ 671 LRPGWK(25)=$4F52 B9400869^^ 672 LRPGWK(26)=$4420 B9400870^^ 673 LRPGWK(27)=$434F B9400871^^ 674 LRPGWK(28)=$554E B9400872^^ 675 LRPGWK(29)=$5427 B9400873^^ 676 GO TO 3000 B9400874^^ 677 3846 ASSIGN 3850 TO IRTN B9400875^^ 678 LRPGWK(3)=$204F B9400876^^ 679 LRPGWK(16)=$2054 B9400877^^ 680 LRPGWK(17)=$5243 B9400878^^ 681 LRPGWK(18)=$4E54 B9400879^^ 682 LRPGWK(19)=$205A B9400880^^ 683 IHOLD=$0030+NLKEY-L+1 B9400881^^ 684 CALL CCSMVA(IHOLD,2,1,LRPGWK,37,1) B9400882^^ 685 LRPGWK(21)=$2032 B9400883^^ 686 LRPGWK(22)=$3520 B9400884^^ 687 GO TO 3000 B9400885^^ 688 3850 CONTINUE B9400886^^ C B9400887^^ 689 3860 CONTINUE B9400888^^ C B9400889^^ C SET UP GRAND TOTAL LINE B9400890^^ C B9400891^^ 690 LRPGWK(3)=$204F B9400892^^ 691 LRPGWK(8)=$5420 B9400893^^ 692 LRPGWK(9)=$3220 B9400894^^ 693 LRPGWK(14)=$4C52 B9400895^^ 694 ASSIGN 3864 TO IRTN B9400896^^ 695 GO TO 3000 B9400897^^ 696 3864 CONTINUE B9400898^^ 697 ASSIGN 3865 TO IRTN B9400899^^ 698 LRPGWK(3)=$204F B9400900^^ 699 LRPGWK(21)=$2031 B9400901^^ 700 LRPGWK(22)=$3220 B9400902^^ 701 LRPGWK(23)=$2746 B9400903^^ 702 LRPGWK(24)=$494E B9400904^^ 703 LRPGWK(25)=$414C B9400905^^ 704 LRPGWK(26)=$2054 B9400906^^ 705 LRPGWK(27)=$4F54 B9400907^^ 706 LRPGWK(28)=$414C B9400908^^ 707 LRPGWK(29)=$5327 B9400909^^ 708 GO TO 3000 B9400910^^ 709 3865 CONTINUE B9400911^^ 710 IPOS=1 B9400912^^ 711 IPW1=1 B9400913^^ 712 IHOLD=$0000 B9400914^^ 713 BIN =0 B9400915^^ 714 IF (NTFLDS.EQ.0) GO TO 3880 B9400916^^ 715 DO 3880 L=1,NTFLDS B9400917^^ 716 LRPGWK(3)=$204F B9400918^^ 717 ITN1=$5430 B9400919^^ 718 CALL CCSMVA(ITN1,1,2,LRPGWK,32,2) B9400920^t FTN 3.3B (OPT = LPC) PGGN2P PAGE 18 DATE: 08/29/84 TIME: 2245 t^ 719 CALL BINASC(L,IHOLD2) B9400921^^ 720 CALL CCSMVA(IHOLD2,3,2,LRPGWK,34,2) B9400922^^ 721 3870 BIN=Q6EPOS(IPW1)+ BIN B9400923^^ 722 CALL BINASC(BIN,IHOLD2) B9400924^^ 723 CALL CCSMVA(IHOLD2,1,4,LRPGWK,40,4) B9400925^^ 724 BIN=BIN+1 B9400926^^ 725 ICOL=IPOS+5 B9400927^^ 726 CALL CCSMVA(Q6EPOS,ICOL,1,LRPGWK,38,1) B9400928^^ 727 ICOL=IPOS+4 B9400929^^ 728 CALL CCSGET(Q6EPOS,ICOL,IHOLD) B9400930^^ 729 IF (IHOLD.EQ.$0054) GO TO 3875 B9400931^^ 730 IPOS=IPOS+12 B9400932^^ 731 IPW1=IPW1+6 B9400933^^ 732 GO TO 3870 B9400934^^ 733 3875 ASSIGN 3880 TO IRTN B9400935^^ 734 IPOS=IPOS+12 B9400936^^ 735 IPW1=IPW1+6 B9400937^^ 736 GO TO 3000 B9400938^^ 737 3880 CONTINUE B9400939^^ 738 LRPGWK(3)=$204F B9400940^^ 739 LRPGWK(8)=$5420 B9400941^^ 740 LRPGWK(9)=$3120 B9400942^^ 741 LRPGWK(14)=$4C52 B9400943^^ 742 ASSIGN 3885 TO IRTN B9400944^^ 743 GO TO 3000 B9400945^^ 744 3885 LRPGWK(3)=$204F B9400946^^ 745 LRPGWK(21)=$2031 B9400947^^ 746 LRPGWK(22)=$3820 B9400948^^ 747 LRPGWK(23)=$2746 B9400949^^ 748 LRPGWK(24)=$494E B9400950^^ 749 LRPGWK(25)=$414C B9400951^^ 750 LRPGWK(26)=$2052 B9400952^^ 751 LRPGWK(27)=$4543 B9400953^^ 752 LRPGWK(28)=$4F52 B9400954^^ 753 LRPGWK(29)=$4420 B9400955^^ 754 LRPGWK(30)=$434F B9400956^^ 755 LRPGWK(31)=$554E B9400957^^ 756 LRPGWK(32)=$5427 B9400958^^ 757 ASSIGN 3886 TO IRTN B9400959^^ 758 GO TO 3000 B9400960^^ 759 3886 ASSIGN 3889 TO IRTN B9400961^^ 760 LRPGWK(3)=$204F B9400962^^ 761 LRPGWK(16)=$2054 B9400963^^ 762 LRPGWK(17)=$5243 B9400964^^ 763 LRPGWK(18)=$4E54 B9400965^^ 764 LRPGWK(19)=$305A B9400966^^ 765 LRPGWK(21)=$2032 B9400967^^ 766 LRPGWK(22)=$3520 B9400968^^ 767 GO TO 3000 B9400969^^ C B9400970^^ C SET UP RPG SOURCE CODE FOR HEADING OUTPUT LINES B9400971^^ C B9400972^^ C STD HEADING 1 B9400973^^ C B9400974^t FTN 3.3B (OPT = LPC) PGGN2P PAGE 19 DATE: 08/29/84 TIME: 2245 t^ 768 3889 CONTINUE B9400975^^ 769 LRPGWK(3)=$204F B9400976^^ 770 LRPGWK(8)=$4420 B9400977^^ 771 LRPGWK(9)=$2031 B9400978^^ 772 LRPGWK(10)=$3031 B9400979^^ 773 LRPGWK(14)=$3430 B9400980^^ 774 ASSIGN 3890 TO IRTN B9400981^^ 775 GO TO 3000 B9400982^^ 776 3890 LRPGWK(3)=$204F B9400983^^ 777 LRPGWK(16)=$2048 B9400984^^ 778 LRPGWK(17)=$4452 B9400985^^ 779 LRPGWK(18)=$2C31 B9400986^^ 780 LRPGWK(21)=$2034 B9400987^^ 781 LRPGWK(22)=$3020 B9400988^^ 782 ASSIGN 3891 TO IRTN B9400989^^ 783 GO TO 3000 B9400990^^ 784 3891 LRPGWK(3)=$204F B9400991^^ 785 LRPGWK(21)=$3131 B9400992^^ 786 LRPGWK(22)=$3820 B9400993^^ 787 LRPGWK(23)=$2750 B9400994^^ 788 LRPGWK(24)=$4147 B9400995^^ 789 LRPGWK(25)=$4527 B9400996^^ 790 ASSIGN 3892 TO IRTN B9400997^^ 791 GO TO 3000 B9400998^^ 792 3892 LRPGWK(3)=$204F B9400999^^ 793 LRPGWK(16)=$2050 B9401000^^ 794 LRPGWK(17)=$4147 B9401001^^ 795 LRPGWK(18)=$4520 B9401002^^ 796 LRPGWK(19)=$205A B9401003^^ 797 LRPGWK(21)=$3132 B9401004^^ 798 LRPGWK(22)=$3320 B9401005^^ 799 ASSIGN 3895 TO IRTN B9401006^^ 800 GO TO 3000 B9401007^^ C STD HEADING 2 B9401008^^ 801 3895 LRPGWK(3)=$204F B9401009^^ 802 LRPGWK(8)=$4420 B9401010^^ 803 LRPGWK(9)=$2031 B9401011^^ 804 LRPGWK(14)=$3430 B9401012^^ 805 ASSIGN 3900 TO IRTN B9401013^^ 806 GO TO 3000 B9401014^^ 807 3900 LRPGWK(3)=$204F B9401015^^ 808 LRPGWK(16)=$2048 B9401016^^ 809 LRPGWK(17)=$4452 B9401017^^ 810 LRPGWK(18)=$2C32 B9401018^^ 811 LRPGWK(21)=$2034 B9401019^^ 812 LRPGWK(22)=$3020 B9401020^^ 813 ASSIGN 3905 TO IRTN B9401021^^ 814 GO TO 3000 B9401022^^ 815 3905 LRPGWK(3)=$204F B9401023^^ 816 LRPGWK(21)=$3131 B9401024^^ 817 LRPGWK(22)=$3820 B9401025^^ 818 LRPGWK(23)=$2752 B9401026^^ 819 LRPGWK(24)=$554E B9401027^^ 820 LRPGWK(25)=$2044 B9401028^t FTN 3.3B (OPT = LPC) PGGN2P PAGE 20 DATE: 08/29/84 TIME: 2245 t^ 821 LRPGWK(26)=$4154 B9401029^^ 822 LRPGWK(27)=$4527 B9401030^^ 823 ASSIGN 3910 TO IRTN B9401031^^ 824 GO TO 3000 B9401032^^ 825 3910 LRPGWK(3)=$204F B9401033^^ 826 LRPGWK(16)=$2055 B9401034^^ 827 LRPGWK(17)=$4441 B9401035^^ 828 LRPGWK(18)=$5445 B9401036^^ 829 LRPGWK(19)=$2059 B9401037^^ 830 LRPGWK(21)=$3132 B9401038^^ 831 LRPGWK(22)=$3820 B9401039^^ 832 ASSIGN 3915 TO IRTN B9401040^^ 833 GO TO 3000 B9401041^^ C STD HEADING 3 B9401042^^ 834 3915 LRPGWK(3)=$204F B9401043^^ 835 LRPGWK(8)=$4420 B9401044^^ 836 LRPGWK(9)=$2031 B9401045^^ 837 LRPGWK(14)=$3430 B9401046^^ 838 ASSIGN 3920 TO IRTN B9401047^^ 839 GO TO 3000 B9401048^^ 840 3920 LRPGWK(3)=$204F B9401049^^ 841 LRPGWK(16)=$2048 B9401050^^ 842 LRPGWK(17)=$4452 B9401051^^ 843 LRPGWK(18)=$2C33 B9401052^^ 844 LRPGWK(21)=$2034 B9401053^^ 845 LRPGWK(22)=$3020 B9401054^^ 846 ASSIGN 3925 TO IRTN B9401055^^ 847 GO TO 3000 B9401056^^ C HEADING--REPORT TITLE B9401057^^ 848 3925 LRPGWK(3)=$204F B9401058^^ 849 LRPGWK(8)=$4420 B9401059^^ 850 LRPGWK(9)=$2032 B9401060^^ 851 LRPGWK(14)=$3430 B9401061^^ 852 ASSIGN 3930 TO IRTN B9401062^^ 853 GO TO 3000 B9401063^^ 854 3930 LRPGWK(3)=$204F B9401064^^ 855 LRPGWK(21)=$2037 B9401065^^ 856 LRPGWK(22)=$3020 B9401066^^ 857 LRPGWK(23)=$2720 B9401067^^ 858 LRPGWK(33)=$2027 B9401068^^ 859 CALL CCSMVA(Q7RPT,1,20,LRPGWK,46,20) B9401069^^ 860 ASSIGN 3935 TO IRTN B9401070^^ 861 GO TO 3000 B9401071^^ 862 3935 LRPGWK(3)=$204F B9401072^^ 863 LRPGWK(21)=$2038 B9401073^^ 864 LRPGWK(22)=$3020 B9401074^^ 865 LRPGWK(23)=$2720 B9401075^^ 866 LRPGWK(28)=$2027 B9401076^^ 867 CALL CCSMVA(Q7RPT,21,10,LRPGWK,46,10) B9401077^^ 868 ASSIGN 3940 TO IRTN B9401078^^ 869 GO TO 3000 B9401079^^ C HEADING--DATA COLUMN HEADINGS B9401080^^ 870 3940 LRPGWK(3)=$204F B9401081^^ 871 LRPGWK(8)=$4420 B9401082^t FTN 3.3B (OPT = LPC) PGGN2P PAGE 21 DATE: 08/29/84 TIME: 2245 t^ 872 LRPGWK(9)=$2032 B9401083^^ 873 LRPGWK(14)=$3430 B9401084^^ 874 ASSIGN 3945 TO IRTN B9401085^^ 875 GO TO 3000 B9401086^^ 876 3945 CONTINUE B9401087^^ 877 BIN =$0000 B9401088^^ 878 IPW1=1 B9401089^^ 879 ASSIGN 3960 TO IRTN B9401090^^ 880 DO 3960 L=1,NNAME B9401091^^ 881 LRPGWK(3)=$204F B9401092^^ 882 BIN=BIN +Q6EPOS(IPW1+1) B9401093^^ C CHECK TYPE--IF A, LEFT JUSTIFY COL HEADING B9401094^^ C ELSE RIGHT JUSTIFY COL HEADING B9401095^^ 883 IF (AND(Q6EPOS(IPW1+2),$FF00).NE.$4100) GO TO 3948 B9401096^^ C TYPE A--CHECK LENGTH OF DATA, IF LE 6 NOT NECESSARY B9401097^^ 884 CALL ASCBIN(Q6EPOS(IPW1+4),IDIF) B9401098^^ 885 IF (IDIF.LE.6) GO TO 3948 B9401099^^ C LEFT JUSTIFY - RECALCULATE POSITION B9401100^^ 886 IDIF=IDIF-6 B9401101^^ 887 IDIF=BIN-IDIF B9401102^^ 888 CALL BINASC(IDIF,IHOLD2) B9401103^^ 889 GO TO 3949 B9401104^^ 890 3948 CALL BINASC(BIN,IHOLD2) B9401105^^ 891 3949 CALL CCSMVA(IHOLD2,1,4,LRPGWK,40,4) B9401106^^ 892 IDIF=0 B9401107^^ 893 IF (Q6EPOS(IPW1).EQ.Q6EPOS(IPW1+1)) GO TO 3950 B9401108^^ 894 ICODE=AND(Q6EPOS(IPW1+2),$00FF) B9401109^^ 895 IF (ICODE.GE.$004A.AND.ICODE.LE.$004D) IDIF=1 B9401110^^ 896 IF (ICODE.GE.$0041.AND.ICODE.LE.$0044) IDIF=2 B9401111^^ 897 3950 CONTINUE B9401112^^ 898 BIN=BIN+IDIF+1 B9401113^^ 899 LRPGWK(23)=$2720 B9401114^^ 900 LRPGWK(26)=$2027 B9401115^^ 901 CALL CCSMVA(Q6NAME,IPW1,6,LRPGWK,46,6) B9401116^^ 902 IPW1=IPW1+6 B9401117^^ 903 GO TO 3000 B9401118^^ 904 3960 CONTINUE B9401119^^ C SET UP RPG SOURCE FOR DETAIL LINE OUTPUT B9401120^^ C B9401121^^ 905 LRPGWK(3)=$204F B9401122^^ 906 LRPGWK(8)=$4420 B9401123^^ 907 LRPGWK(9)=$2031 B9401124^^ 908 LRPGWK(14)=$3132 B9401125^^ C SET UP DETAIL OUTPUT LINE B9401126^^ 909 ASSIGN 3965 TO IRTN B9401127^^ 910 GO TO 3000 B9401128^^ 911 3965 CONTINUE B9401129^^ 912 IPW1=1 B9401130^^ 913 BIN =$0000 B9401131^^ 914 ASSIGN 3970 TO IRTN B9401132^^ 915 DO 3970 L=1,NNAME B9401133^^ 916 LRPGWK(3)=$204F B9401134^^ 917 BIN=BIN +Q6EPOS(IPW1) B9401135^^ 918 CALL BINASC(BIN,IHOLD2) B9401136^t FTN 3.3B (OPT = LPC) PGGN2P PAGE 22 DATE: 08/29/84 TIME: 2245 t^ 919 CALL CCSMVA(IHOLD2,1,4,LRPGWK,40,4) B9401137^^ 920 BIN=BIN+1 B9401138^^ 921 CALL CCSMVA(Q6NAME,IPW1,6,LRPGWK,32,6) B9401139^^ C GET EDIT CODE B9401140^^ 922 ICOL=(IPW1*2)+4 B9401141^^ 923 CALL CCSMVA(Q6EPOS,ICOL,1,LRPGWK,38,1) B9401142^^ 924 IF (AND(LRPGWK(19),$00FF).NE.$0059) GO TO 3966 B9401143^^ 925 IHOLD=$0020 B9401144^^ 926 CALL CCSMVA(IHOLD,2,1,LRPGWK,38,1) B9401145^^ 927 LRPGWK(23)=$2720 B9401146^^ 928 LRPGWK(24)=$202F B9401147^^ 929 LRPGWK(26)=$2F20 B9401148^^ 930 LRPGWK(27)=$2027 B9401149^^ 931 3966 IPW1=IPW1+6 B9401150^^ 932 GO TO 3000 B9401151^^ 933 3970 CONTINUE B9401152^^ C B9401153^^ C B9401154^^ C END OF GENERATION OF RPG SOURCE CODE B9401155^^ C --COMPLETE JOB STREAM CONTROL B9401156^^ C B9401157^^ C B9401158^^ C***** INSERT CODE FOR RPG JCL B9401159^^ 934 LRPGWK(1)=$2F2A B9401160^^ 935 ASSIGN 4000 TO IRTN B9401161^^ 936 GO TO 3000 B9401162^^ 937 4000 CONTINUE B9401163^^ 938 RADDR=$0000 B9401164^^ 939 GO TO 4999 B9401165^^ 940 4010 RADDR=$8010 B9401166^^ 941 GO TO 4999 B9401167^^ 942 4020 RADDR=$8020 B9401168^^ 943 4999 CONTINUE B9401169^^ 944 RETURN B9401170^^ 945 END B9401171^t FTN 3.3B (OPT = LPC) PGGN2P PAGE 23 DATE: 08/29/84 TIME: 2245 t COMMON  LABEL $0448 ( 1096)    PROGRAM LENGTH $1113 ( 4371)   EXTERNALS 2 BINASC ASCBIN PUTS CCSBLK CCSPUT CCSMVA READR 2 CCSGET  t FTN 3.3B (OPT = LPC) PGGN2P PAGE 24 DATE: 08/29/84 TIME: 2245 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " 8010 (-32751) 0230 940"" 8020 (-32735) 0231 942"" FF00 (-255) 0228 883"€ 0001 (1) 0000 10,11,32,44,47,80,86,88,90,94,96,97,102,109,110,122,124,125,131,136,150,157,158,164,204,205,219, €€ 227,228,234,249,253,263,270,273,279,282,293,303,304,306,319,321,322,324,327,329,331,335,341,343, €€ 352,368,369,371,384,385,390,400,401,413,416,417,427,429,445,447,507,508,521,533,534,535,536,541, €€ 544,545,546,553,557,560,568,577,582,586,587,589,598,603,610,612,619,628,629,633,635,636,641,642, €€ 644,661,663,683,684,710,711,715,718,723,724,726,859,878,880,882,891,893,895,898,912,915,919,920, €* 923,926,934*‚ 0002 (2) 01B1 93,123,125,126,130,132,142,152,156,158,160,162,163,169,179,192,197,209,222,226,228,230,232,233,241 ‚€ ,249,256,259,261,263,264,269,271,278,280,289,300,305,311,320,322,323,330,331,342,343,347,353,364,€€ 374,385,393,396,401,402,409,413,416,417,423,437,449,453,461,467,481,490,496,504,514,525,529,542, €~ 553,561,564,566,568,569,575,577,585,587,589,595,611,636,638,662,684,718,720,883,894,896,922,926~€ 0003 (3) 0192 44,45,49,54,62,70,79,91,112,123,126,129,133,137,141,151,162,168,178,187,195,207,220,232,239,254, €€ 264,268,272,277,281,285,294,309,318,328,340,351,360,372,391,402,407,422,430,448,455,460,466,477, €€ 487,495,501,511,522,539,558,569,573,583,593,604,616,634,638,656,666,678,690,698,716,720,738,744, €f 760,769,776,784,792,801,807,815,825,834,840,848,854,862,870,881,905,916f| 0004 (4) 01AD 87,93,96,102,306,324,512,523,540,559,574,584,594,599,612,641,645,663,723,727,884,891,919,922 |€ 0005 (5) 01BC 130,130,142,152,169,179,192,197,209,222,241,256,269,278,289,300,301,311,320,330,342,353,364,374, €z 393,409,423,431,437,449,461,467,481,488,490,496,504,514,525,542,561,575,585,595,600,643,725z€ 0006 (6) 018E 37,65,92,104,105,111,112,273,282,301,302,312,327,333,338,345,432,450,454,489,601,619,622,648,651,€> 731,735,885,886,901,902,921,931>x 0007 (7) 01A9 80,80,157,196,208,221,227,240,255,310,319,329,338,341,352,373,392,408,433,513,524,541,560x€ 0009 (9) 01B8 112,157,188,227,246,262,286,295,361,381,399,410,434,456,472,478,502,550,567,606,658,692,740,771, €2 803,836,850,872,9072& 000A (10) 0227 867,867&: 000C (12) 01B6 110,137,191,649,653,730,734:^ 0012 (18) 01C0 136,259,355,376,396,398,492,545,564,681,763,779,795,810,828,843^J 0013 (19) 01DD 263,356,377,401,546,568,682,764,796,829,924J: 0014 (20) 0195 46,46,47,57,264,402,569,859:b 0015 (21) 01E7 299,617,667,685,699,745,765,780,785,797,811,816,830,844,855,863,867b€ 0017 (23) 01DB 249,261,314,335,347,379,385,398,413,440,453,470,517,529,548,553,566,612,620,663,669,701,747,787, €2 818,857,865,899,9272€ 001C (28) 01BD 130,142,144,152,169,179,192,197,209,222,241,256,269,278,289,300,311,320,330,342,353,364,374,393, €€ 409,423,437,449,461,463,467,481,484,490,496,498,504,514,525,542,561,575,585,595,624,674,706,752, €" 866"2 0020 (32) 0204 636,718,756,921,92526 0021 (33) 01E8 302,312,333,345,450,8586& 0022 (34) 0205 638,720&" 0025 (37) 020E 684"2 0026 (38) 01BA 116,644,726,923,9262. 0028 (40) 0206 641,723,891,919." 002C (44) 01B3 96 ". 002E (46) 0200 622,859,867,901.2 0030 (48) 01B5 102,298,384,400,6832" 0031 (49) 01C1 137"t FTN 3.3B (OPT = LPC) PGGN2P PAGE 25 DATE: 08/29/84 TIME: 2245 t6 0032 (50) 01B7 111,111,117,162,232,4556. 0034 (52) 01B2 94,136,164,234 ." 0035 (53) 01B0 92 ": 0036 (54) 01E0 273,282,306,324,416,577,587:& 0038 (56) 01EF 417,589&* 0054 (84) 018B 34,647,729 *" 0084 (132) 01F9 598"& 00FF (255) 022C 894,924&. 2020 (8224) 01E6 297,323,332,344.. 2027 (8231) 0225 858,866,900,930." 202F (8239) 022D 928"N 2031 (8241) 01F0 431,462,610,617,661,667,699,745,771,803,836,907N2 2032 (8242) 0207 658,685,765,850,8722" 2033 (8243) 01C2 143"6 2034 (8244) 01A4 72,483,497,780,811,844 6" 2037 (8247) 0224 855"" 2038 (8248) 0226 863"& 2041 (8257) 01CF 188,361&€ 2043 (8259) 01BB 129,141,151,168,178,187,195,207,220,239,254,268,277,285,286,294,309,318,328,340,351,360,372,391, €b 407,422,430,448,460,466,477,487,495,501,511,522,539,558,573,583,593b" 2044 (8260) 021D 820"& 2045 (8261) 0198 54,502 &" 2046 (8262) 0193 45 ". 2048 (8264) 01E4 295,777,808,841.* 2049 (8265) 019D 62,70,79,91** 204C (8268) 01F1 434,472,478*€ 204F (8271) 01FC 604,616,634,656,666,678,690,698,716,738,744,760,769,776,784,792,801,807,815,825,834,840,848,854, €2 862,870,881,905,9162" 2050 (8272) 021B 793"" 2052 (8274) 0214 750"F 2054 (8276) 01D8 246,262,381,399,410,550,567,679,704,761F" 2055 (8277) 021F 826"" 2059 (8281) 0222 829"& 205A (8282) 020D 682,796&6 2720 (10016) 01FF 620,621,857,865,899,9276& 2746 (10054) 020F 701,747&" 2748 (10056) 01B9 114"" 2750 (10064) 0218 787"& 2752 (10066) 0208 669,818&" 2C31 (11313) 0217 779"" 2C32 (11314) 021C 810"" 2C33 (11315) 0223 843"" 2F20 (12064) 022E 929"" 2F2A (12074) 022F 934"^ 3020 (12320) 01C6 153,170,198,210,223,414,484,489,498,515,526,781,812,845,856,864^& 3031 (12337) 01A2 67,772 &" 3032 (12338) 01AB 82 "" 3033 (12339) 01C3 144"" 305A (12378) 0215 764". 3120 (12576) 01D7 242,468,543,740.* 3131 (12593) 01FE 606,785,816*B 3132 (12594) 01D6 240,255,281,541,560,576,797,830,908B* 3133 (12595) 01C4 145,415,588*" 3139 (12601) 01DE 270"t FTN 3.3B (OPT = LPC) PGGN2P PAGE 26 DATE: 08/29/84 TIME: 2245 t2 3220 (12832) 01C5 146,463,668,692,7002" 3230 (12848) 01CE 184"6 3320 (13088) 019B 57,432,611,618,662,798 6V 3330 (13104) 01D4 205,271,303,319,321,322,329,341,352,369,433,508,586,607V" 3331 (13105) 01DF 272"" 3332 (13106) 01E1 279"" 3420 (13344) 01A5 73 "B 3430 (13360) 019C 58,196,280,482,773,804,837,851,873 B. 3520 (13600) 01A3 71,438,686,766 .& 3530 (13616) 01CA 174,214&" 3633 (13875) 01CB 180". 3820 (14368) 0213 746,786,817,831." 4100 (16640) 0229 883"" 4141 (16705) 01A1 66 "& 4144 (16708) 01A7 75,354 && 4147 (16711) 0219 788,794&* 414C (16716) 0210 703,706,749*" 4154 (16724) 021E 821". 4230 (16944) 01BF 135,314,335,347." 4242 (16962) 01AA 81 "N 434E (17230) 01C9 172,182,200,212,244,376,379,440,470,517,545,548N& 434F (17231) 020B 673,754&F 4420 (17440) 01D2 191,492,672,753,770,802,835,849,871,906F" 4441 (17473) 0220 827"" 444C (17484) 01EC 362"* 4452 (17490) 0216 778,809,842** 4520 (17696) 01FD 605,657,795*& 4527 (17703) 021A 789,822&& 4543 (17731) 0209 670,751&" 454E (17742) 01F4 491"" 4552 (17746) 01A8 76 "" 4844 (18500) 0199 55 "" 4845 (18501) 01A6 74 ". 484C (18508) 01BE 134,313,334,346.* 4854 (18516) 01DC 257,451,536*" 4946 (18758) 019F 64 "" 494C (18764) 01A0 65 "* 494E (18766) 01FB 600,702,748*" 4B4C (19276) 01E2 287"" 4C20 (19488) 01EB 356"" 4C42 (19522) 01E5 296". 4C4E (19534) 01CC 181,199,439,469.B 4C52 (19538) 01F6 512,523,540,559,574,584,594,693,741B" 4C53 (19539) 0203 625"" 4C56 (19542) 01EA 355"" 4E33 (20019) 01F3 488"* 4E43 (20035) 01F2 435,473,479*" 4E44 (20036) 01F5 503"B 4E54 (20052) 01DA 248,383,412,436,474,480,552,681,763B& 4F52 (20306) 020A 671,752&" 4F54 (20308) 0211 705"" 5052 (20562) 01FA 599"" 5220 (21024) 019A 56 "6 5243 (21059) 01D9 247,382,411,551,680,7626t FTN 3.3B (OPT = LPC) PGGN2P PAGE 27 DATE: 08/29/84 TIME: 2245 t" 524F (21071) 01D0 189"" 5250 (21072) 018F 38 "" 5327 (21287) 0212 707": 5420 (21536) 01CD 183,201,441,471,601,691,739:& 5427 (21543) 020C 675,756&N 5430 (21552) 01C7 154,173,206,237,370,371,509,535,537,627,635,717N" 5441 (21569) 0202 624"" 5445 (21573) 0221 828"" 544F (21583) 0201 623"" 5450 (21584) 0190 39 "> 5452 (21586) 01C8 171,211,243,375,378,516,544,547>. 554E (21838) 01D1 190,674,755,819." 5554 (21844) 019E 63 "& 564C (22092) 01E3 288,363&   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " ABTMSG INTEGER 03E8 D 1,6"* AND INTR.FN. 7FFF 883,894,924*‚ BIN INTEGER 0300 D 1,6,97,99,100,103,159,160,161,229,230,231,631,639,640,642,713,721,722,724,877,882,887,890,898,913, ‚* 917,918,920*& C1 INTEGER 0041 6,10,15&& C10 INTEGER 0122 6,10,24&& C11 INTEGER 013B 6,10,25&& C12 INTEGER 0154 6,10,26&& C2 INTEGER 005A 6,10,16&& C3 INTEGER 0073 6,10,17&& C4 INTEGER 008C 6,10,18&& C5 INTEGER 00A5 6,10,19&& C6 INTEGER 00BE 6,10,20&& C7 INTEGER 00D7 6,10,21&& C8 INTEGER 00F0 6,10,22&& C9 INTEGER 0109 6,10,23&( CAL INTEGER 0041 6,10,111 ($ COMMA INTEGER 0004 6,28 $" CS INTEGER 03F1 D 1,6"" D1LNG INTEGER 0332 D 1,6"" D1TYPE INTEGER 0331 D 1,6"" DELQM INTEGER 000F D 1,4"" DLQRQB INTEGER 0063 D 1,4"" ERRMSG INTEGER 03B7 D 1,6"& F1 INTEGER 0005 6,11,12&* F2 INTEGER 0019 6,11,13,80 *& F3 INTEGER 002D 6,11,14&& FALL INTEGER 0005 6,11,49&& HPGMN INTEGER 02CD D 1,6,40 &" HPKEY INTEGER 0302 D 1,6"D IADD INTEGER 0179 6,27,241,256,374,393,437,467,542,561 D, IBEG INTEGER 01AE 87,88,95,103 ,. ICODE INTEGER 022B 893,894,895,896.t FTN 3.3B (OPT = LPC) PGGN2P PAGE 28 DATE: 08/29/84 TIME: 2245 t‚ ICOL INTEGER 0194 45,46,48,93,94,301,302,312,327,331,333,338,339,343,345,454,455,643,644,645,646,725,726,727,728,922 ‚$ ,923 $2 ICOLW INTEGER 01E9 330,331,332,343,34420 ICOMP INTEGER 0182 6,27,300,409,481 0B IDIF INTEGER 022A 884,885,886,887,888,892,895,896,898B, IEND INTEGER 01AF 88,89,100,101,, IEXCPT INTEGER 0188 6,27,423,595 ,, IGOTO INTEGER 0185 6,27,353,490 ,€ IHOLD INTEGER 018D 36,36,37,115,116,158,159,228,229,298,299,384,385,400,401,413,415,416,417,588,589,630,635,636,646,€> 647,683,684,712,728,729,925,926>‚ IHOLD2 INTEGER 035E D 1,6,95,96,101,102,155,156,161,162,225,226,231,232,258,259,261,264,395,396,402,452,453,528,529,563, ‚v 564,566,569,610,611,612,637,638,640,641,661,662,663,719,720,722,723,888,890,891,918,919v$ IMAXC INTEGER 041B D 1,598$8 IMOVE INTEGER 016D 6,27,130,311,330,342,449 8$ IMOVEL INTEGER 017F 6,27 $^ IND INTEGER 038A D 1,6,270,271,272,273,279,280,281,282,304,305,306,321,322,323,324^v INDIC INTEGER 01D3 204,205,208,221,303,304,305,310,369,373,392,408,508,513,524,576,577,586,587,607,608,659v‚ IPOS INTEGER 0197 47,48,49,86,92,104,109,111,117,123,124,125,126,157,158,163,164,227,228,233,234,445,450,454,456,619 ‚L ,622,629,643,645,649,653,710,725,727,730,734 L‚ IPW1 INTEGER 01AC 86,87,93,97,98,105,628,639,648,651,711,721,731,735,878,882,883,884,893,894,901,902,912,917,921,922 ‚$ ,931 $€ IRTN INTEGER 018C 34,41,43,53,61,69,78,85,108,121,140,148,167,177,186,194,215,217,238,252,267,276,290,307,315,325, €€ 336,348,350,359,386,388,406,421,426,446,459,465,476,486,494,500,510,530,538,556,572,581,592,609, €€ 615,652,660,665,677,694,697,733,742,757,759,774,782,790,799,805,813,823,832,838,846,852,860,868, €2 874,879,909,914,93520 ISETOF INTEGER 017C 6,27,269,278,575 08 ISETON INTEGER 0170 6,27,142,320,461,496,585 8& ISPACE INTEGER 01F8 597,598&0 ISTAT INTEGER 0301 D 1,6,32,33,127,12804 ITAG INTEGER 0176 6,27,192,289,364,504 4v ITN1 INTEGER 01D5 205,206,213,224,237,245,249,260,263,370,377,394,509,518,527,535,536,546,562,627,717,718vB ITN2 INTEGER 01EE 370,371,380,397,537,549,553,565,568BD IZADD INTEGER 0173 6,27,152,169,179,197,209,222,514,525 D€ L INTEGER 0191 44,46,90,110,112,122,123,135,150,155,157,204,205,206,253,258,293,298,301,303,314,317,319,321,322,€€ 323,327,329,335,338,341,347,352,368,369,370,371,384,400,405,429,433,447,452,507,508,509,534,535, €f 536,537,541,544,545,546,560,582,586,603,607,619,635,683,715,719,880,915fT L1 INTEGER 0196 46,48,49,219,225,227,390,395,521,528,557,563,633,637 T2 LE INTEGER 01F7 532,533,534,535,53726 LL INTEGER 01ED 366,366,367,427,428,4296€ LRPGWK INTEGER 0334 D 1,6,32,34,37,38,39,40,45,49,54,55,56,57,58,62,63,64,65,66,67,70,71,72,73,74,75,76,79,80,81,82,91,€€ 92,94,96,102,111,114,116,129,130,131,132,133,134,135,136,137,141,142,143,144,145,146,151,152,153,€€ 154,156,162,164,168,169,170,171,172,173,174,178,179,180,181,182,183,184,187,188,189,190,191,192, €€ 195,196,197,198,199,200,201,207,208,209,210,211,212,213,214,220,221,222,223,224,226,232,234,239, €€ 240,241,242,243,244,245,246,247,248,249,254,255,256,257,259,260,261,262,263,264,268,269,273,277, €€ 278,282,285,286,287,288,289,294,295,296,297,299,300,302,306,309,310,311,312,313,314,318,319,320, €€ 324,328,329,330,333,334,335,340,341,342,345,346,347,351,352,353,354,355,356,360,361,362,363,364, €€ 372,373,374,375,376,377,378,379,380,381,382,383,385,391,392,393,394,396,397,398,399,401,402,407, €€ 408,409,410,411,412,413,414,416,417,422,423,430,431,432,433,434,435,436,437,438,439,440,441,448, €€ 449,450,451,453,455,460,461,462,463,466,467,468,469,470,471,472,473,474,477,478,479,480,481,482, €€ 483,484,487,488,489,490,491,492,495,496,497,498,501,502,503,504,511,512,513,514,515,516,517,518, €€ 522,523,524,525,526,527,529,539,540,541,542,543,544,545,546,547,548,549,550,551,552,553,558,559, €€ 560,561,562,564,565,566,567,568,569,573,574,575,577,583,584,585,587,589,593,594,595,599,600,601, €€ 604,605,606,608,612,616,617,618,620,621,622,623,624,625,634,636,638,641,644,656,657,658,659,663, €€ 666,667,668,669,670,671,672,673,674,675,678,679,680,681,682,684,685,686,690,691,692,693,698,699, €t FTN 3.3B (OPT = LPC) PGGN2P PAGE 29 DATE: 08/29/84 TIME: 2245 t€ 700,701,702,703,704,705,706,707,716,718,720,723,726,738,739,740,741,744,745,746,747,748,749,750, €€ 751,752,753,754,755,756,760,761,762,763,764,765,766,769,770,771,772,773,776,777,778,779,780,781, €€ 784,785,786,787,788,789,792,793,794,795,796,797,798,801,802,803,804,807,808,809,810,811,812,815, €€ 816,817,818,819,820,821,822,825,826,827,828,829,830,831,834,835,836,837,840,841,842,843,844,845, €€ 848,849,850,851,854,855,856,857,858,859,862,863,864,865,866,867,870,871,872,873,881,891,899,900, €^ 901,905,906,907,908,916,919,921,923,924,926,927,928,929,930,934^ LU INTEGER 041A D 1 $ M INTEGER 01B4 98,99$€ NLKEY INTEGER 041C D 1,120,122,203,204,237,292,293,317,366,368,405,427,506,507,533,580,582,602,603,607,619,627,635,683€0 NNAME INTEGER 041D D 1,90,598,880,915 0 NSKEY INTEGER 041E D 1 NSLCT INTEGER 041F D 1 h NTFLDS INTEGER 0420 D 1,149,150,218,219,251,253,389,390,444,447,520,521,555,557,632,633,714,715h" OPBUF INTEGER 00C3 D 1,5"" OPHLD INTEGER 0330 D 1,6"" PGMKEY INTEGER 02FA D 1,6"" PGMREC INTEGER 0360 D 1,6"" PGMRQB INTEGER 0093 D 1,4"" PRCREC INTEGER 038D D 1,6"" PRCRQB INTEGER 0402 D 1,4"" PRCWRK INTEGER 03F3 D 1,4"" Q2SAVE INTEGER 00E3 D 1,5"" Q3SORT INTEGER 00E4 D 1,5"J Q4LVLB INTEGER 0120 D 1,5,124,125,126,302,312,332,333,344,345,622J" Q5ANS INTEGER 02C8 D 1,5"" Q5SLCT INTEGER 0129 D 1,5"` Q6EPOS INTEGER 0253 D 1,5,94,97,98,639,644,646,721,726,728,882,883,884,893,894,917,923 `. Q6NAME INTEGER 01D3 D 1,5,92,901,921 .: Q6TOT INTEGER 0206 D 1,5,158,164,228,234,450,455:* Q7RPT INTEGER 02B9 D 1,5,859,867*. RADDR INTEGER 0305 D 1,6,938,940,942.$ RPTG INTEGER 0001 6,28 $" RPTPGM INTEGER 002D D 1,4"" RPTTBL INTEGER 001E D 1,4"" RPTWKE INTEGER 003C D 1,4"" RPTWKP INTEGER 0421 D 1,4"" TBL INTEGER 02C9 D 1,6"2 TBLKEY INTEGER 02FD D 1,6,124,125,126,1272: TBLREC INTEGER 0306 D 1,6,127,131,132,133,136,137:& TBLRQB INTEGER 007B D 1,4,127&" TC INTEGER 03F0 D 1,6"" UTEMSG INTEGER 03CE D 1,6"" UTIFIL INTEGER 0000 D 1,4"" UTIRQB INTEGER 004B D 1,4"" UTREC INTEGER 02D0 D 1,6"" WKERQB INTEGER 00AB D 1,4"& WKPRQB INTEGER 0430 D 1,4,32 &" XYN INTEGER 03EF D 1,6"$ ZERO INTEGER 0003 6,28 $t FTN 3.3B (OPT = LPC) PGGN2P PAGE 30 DATE: 08/29/84 TIME: 2245 t   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < 4 ASCBIN SUBROUTINE 1004 28,97,98,159,229,884 4h BINASC SUBROUTINE 10A8 28,95,101,155,161,225,231,258,395,452,528,563,637,640,719,722,888,890,918h" CCSBLK SUBROUTINE 0240 33 "& CCSGET SUBROUTINE 0DA7 645,728&€ CCSMVA SUBROUTINE 10AC 79,92,94,96,102,111,130,136,137,142,152,158,162,164,169,179,192,197,209,222,228,232,234,241,249, €€ 256,263,264,269,273,278,282,289,300,302,306,311,312,320,324,330,333,342,345,353,364,374,385,393, €€ 401,402,409,413,416,417,423,437,449,450,455,461,467,481,490,496,504,514,525,542,553,561,568,569, €€ 575,577,585,587,589,595,612,622,636,638,641,644,663,684,718,720,723,726,859,867,891,901,919,921, €& 923,926&* CCSPUT SUBROUTINE 0651 36,116,299 *" PUTS SUBROUTINE 0234 28 "" READR SUBROUTINE 03A4 126"   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < " 2000 0232 28 "€ 3000 0233 28,42,51,59,68,77,83,106,118,138,147,165,175,185,193,202,216,235,250,265,274,283,291,308,316,326,€€ 337,349,357,365,387,403,418,424,442,457,464,475,485,493,499,505,519,531,554,570,578,590,596,613, €€ 626,654,664,676,687,695,708,736,743,758,767,775,783,791,800,806,814,824,833,839,847,853,861,869, €2 875,903,910,932,9362$ 3100 0245 28,36$$ 3200 025E 40,43$" 3215 026D 46 "$ 3220 0279 46,50$( 3230 027F 43,44,52 (" 3240 0284 52 "$ 3250 029B 52,60$" 3300 029B 60 "$ 3310 02B7 60,69$$ 3315 02D6 69,78$$ 3320 02EB 78,84$( 3350 0351 84,90,107(" 3400 0353 107"& 3405 036B 112,114&& 3406 0377 112,117&* 3410 037C 107,110,119** 3420 03DF 120,122,139*& 3430 03E1 120,140&& 3440 03FF 140,148&. 3450 044F 148,149,150,166.& 3451 0474 166,176&& 3455 0490 176,186&& 3456 04AE 186,194&t FTN 3.3B (OPT = LPC) PGGN2P PAGE 31 DATE: 08/29/84 TIME: 2245 t& 3460 04CA 194,203&& 3465 0509 214,217&6 3470 0558 203,204,217,218,219,2366& 3475 059B 237,251&. 3480 05D6 251,252,253,266.& 3490 05FA 266,275&& 3500 061A 275,284&& 3600 0633 289,292&& 3610 0680 306,309&& 3620 06A3 314,317&& 3625 06D0 324,327&& 3628 0700 335,338&2 3630 073A 332,339,344,348,3502. 3640 0759 292,317,350,358.& 3645 0777 358,366&& 3650 07CF 385,388&* 3660 0811 388,389,404*. 3690 0851 389,405,406,419.& 3700 0853 367,420&& 3701 0865 420,425&2 3705 08A9 367,426,428,429,4432& 3720 08AB 292,444&. 3730 08F0 444,446,447,458.& 3735 0909 458,465&& 3740 0934 465,476&& 3745 0959 476,486&& 3750 0979 486,494&& 3755 0991 494,500&& 3760 09AA 500,506&& 3765 09ED 509,520&6 3770 0A23 506,507,520,521,530,5326& 3775 0AA5 537,555&2 3780 0AF7 533,555,556,557,5712& 3781 0B1E 571,579&. 3790 0B59 580,581,582,591.& 3795 0B71 591,597&" 3810 0B8E 602"& 3815 0BC3 608,614&& 3816 0BF7 614,627&& 3820 0C35 638,650&& 3830 0C6E 647,651&. 3840 0C7E 632,633,652,655.& 3845 0CA6 659,665&& 3846 0CD4 665,677&* 3850 0D06 602,677,688*& 3860 0D0A 602,689&& 3864 0D20 693,696&& 3865 0D4E 696,709&& 3870 0D81 720,732&& 3875 0DBA 729,733&. 3880 0DCA 714,715,733,737.& 3885 0DE3 741,744&& 3886 0E1D 756,759&& 3889 0E3F 759,768&t FTN 3.3B (OPT = LPC) PGGN2P PAGE 32 DATE: 08/29/84 TIME: 2245 t& 3890 0E59 773,776&& 3891 0E77 781,784&& 3892 0E95 789,792&& 3895 0EB7 798,801&& 3900 0ECD 804,807&& 3905 0EEB 812,815&& 3910 0F11 822,825&& 3915 0F33 831,834&& 3920 0F49 837,840&& 3925 0F67 845,848&& 3930 0F7D 851,854&& 3935 0F9F 859,862&& 3940 0FC0 867,870&& 3945 0FD6 873,876&* 3948 101C 883,885,890*& 3949 101F 888,891&& 3950 1051 893,897&* 3960 106E 878,880,904*& 3965 1088 908,911&& 3966 10EA 924,931&* 3970 10F1 913,915,933*& 4000 10FE 934,937&& 4010 1102 128,940&& 4020 1107 33,942 &* 4999 110B 938,941,943* PGGN2P 110E 1 t FTN 3.3B (OPT = LPC) PGLTTB PAGE 1 DATE: 08/29/84 TIME: 2255 t^ 1 PROGRAM PGLTTB B9500001^^ 1 1 /B95 F CCS CCS 3.0 SL-149B9500002^^ C B9500003^^ C CYBERCREDIT SYSTEM VERSION 3 B9500004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B9500005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B9500006^^ C B9500007^^ C B9500008^^ C COPYRIGHT CONTROL DATA CORPORATION 1978 B9500009^^ C DATA SYSTEMS DIVISION, LA JOLLA, CALIFORNIA B9500010^^ C CYBERCOLL VERSION 2.0 B9500011^^ C B9500012^^ C PRINTS THE VALID DATA NAME LIST B9500013^^ C B9500014^^ C B9500015^^ C FILE RETRIEVAL B9500016^^ 2 INTEGER UTIFIL(15),RPTTBL(15),UTIRQB(24),TBLRQB(24) B9500017^^ C B9500018^^ C MISCELLANEOUS B9500019^^ 3 INTEGER XYN,TC,CS(2),TBL(4),RPTG(2),UTREC(42),TBLKEY(3), B9500020^^ 3 2 BIN,TBLREC(42),ERRMSG(23),ABTMSG(7),IHOLD2(2),FILREQ(24) B9500021^^ C B9500022^^ 4 INTEGER HDR1(2),HDR2(2),HDR3(2),HEAD1(66),HEAD2(66),HEAD3(66), B9500023^^ 4 2 LISTH1(66),LISTH2(55),LISTH3(55),PGCNT,ITEMP(8), B9500024^^ 4 3 IBUF(66) B9500025^^ C B9500026^^ 5 DATA UTIFIL / 'UTIFIL ', 8*$2020, 1, 1, 0 / B9500027^^ 6 DATA RPTTBL /'RPTTBL ',1,1,0/ B9500028^^ 7 DATA UTIRQB /24*$0000/ B9500029^^ 8 DATA TBLRQB /24*$0000/ B9500030^^ 9 DATA ERRMSG/'THIS IS A MASTER CONSOLE REQUEST ONLY ',$D0A/ B9500031^^ 10 DATA ABTMSG/' JOB ABORTED',$D0A/ B9500032^^ C‚ B9500033^^ 11 DATA LISTH1 /'PGLTTB',21*$2020,'REPORT GENERATOR DATA NAME LIST ',B9500034^^ 11 2 26*$2020/ B9500035^^ 12 DATA LISTH2 /3*$2020,'STARTING',4*$2020,'DATA EDIT DEC ', B9500036^^ 12 2 21*$2020,'SUB SUB SUB SUB SUB'/ B9500037^^ 13 DATA LISTH3/' NAME POSITION LENGTH TYPE CODE POS ',5*$2020, B9500038^^ 13 2'DESCRIPTION ',9*$2020,' NAME1 NAME2 NAME3 NAME4 NAME5'/ B9500039^^ 14 DATA HDR1/'HDR1'/,HDR2/'HDR2'/,HDR3/'HDR3'/ B9500040^^ 15 DATA HEAD1/$0C, 54*$2020,'PAGE 01',7*$2020/,HEAD2/52*$2020, B9500041^^ 15 2 'DATE RUN MM/DD/YY',5*$2020/,HEAD3/66*$2020/ B9500042^^ C B9500043^^ 16 EXTERNAL AMONTO,ADAYTO,AYERTO B9500044^^ C LOGIN B9500045^^ 17 CALL PGMIN(TBL,LU,I,J) B9500046^^ C VERIFY MASTER CONSOLE ONLY B9500047^^ 18 IF (J.NE.0) GO TO 8900 B9500048^^ C OPEN FILES B9500049^^ 19 CALL OPENFL(UTIRQB,UTIFIL,ISTAT) B9500050^^ 20 IF (ISTAT.LT.0) GO TO 8000 B9500051^^ 21 CALL OPENFL(TBLRQB,RPTTBL,ISTAT) B9500052^^ 22 IF(ISTAT.LT.0) GO TO 8010 B9500053^^ C B9500054^t FTN 3.3B (OPT = LPC) PGLTTB PAGE 2 DATE: 08/29/84 TIME: 2255 t^ C READ UTIFIL TO GET STANDARD HEADING INFORMATION B9500055^^ C STANDARD HEADING 1 B9500056^^ 23 CALL READR(UTIRQB,UTREC,HDR1,ISTAT) B9500057^^ C CHECK FOR ERROR, IF NOT FOUND--CONTINUE B9500058^^ 24 IF(ISTAT.LT.0) GO TO 8020 B9500059^^ 25 CALL CCSMVA(UTREC,5,40,HEAD1,3,40) B9500060^^ C STANDARD HEADING 2 B9500061^^ 26 CALL READR(UTIRQB,UTREC,HDR2,ISTAT) B9500062^^ C CHECK FOR ERROR, IF NOT FOUND--CONTINUE B9500063^^ 27 IF(ISTAT.LT.0) GO TO 8020 B9500064^^ 28 DO 30 K=1,20 B9500065^^ 29 HEAD2(K) =UTREC(K+2) B9500066^^ 30 30 CONTINUE B9500067^^ C STANDARD HEADING 3 B9500068^^ 31 CALL READR(UTIRQB,UTREC,HDR3,ISTAT) B9500069^^ C CHECK FOR ERROR, IF NOT FOUND--CONTINUE B9500070^^ 32 IF(ISTAT.LT.0) GO TO 8020 B9500071^^ 33 DO 40 K=1,20 B9500072^^ 34 HEAD3(K) =UTREC(K+2) B9500073^^ 35 40 CONTINUE B9500074^^ C SET UP RUN DATE AND INITIALIZE LINE AND PAGE COUNT B9500075^^ 36 LNCNT=58 B9500076^^ 37 PGCNT=0 B9500077^^ 38 HEAD2(58) =AND($FFFF,AMONTO) B9500078^^ 39 HEAD2(61) =AND($FFFF,AYERTO) B9500079^^ 40 IDAY=AND($FFFF,ADAYTO) B9500080^^ 41 IHOLD=$0000 B9500081^^ 42 CALL CCSGET(IDAY,1,IHOLD) B9500082^^ 43 CALL CCSPUT(IHOLD,118,HEAD2) B9500083^^ 44 CALL CCSPUT(IDAY,119,HEAD2) B9500084^^ 45 TBLKEY(1)=$0 B9500085^^ 46 TBLKEY(2)=$0 B9500086^^ 47 TBLKEY(3)=$0 B9500087^^ C READ RPTTBL FILE SEQUENTIALLY B9500088^^ 48 100 CALL GETS(TBLRQB,TBLREC,TBLKEY,ISTAT) B9500089^^ 49 IF(AND(ISTAT,$8100).EQ.$8100) GO TO 9100 B9500090^^ C CHECK FOR ERROR IN GETS B9500091^^ 50 IF(ISTAT.LT.0) GO TO 8030 B9500092^^ 51 IF (ISTAT.LT.0) GO TO 9100 B9500093^^ C CHECK FOR DELETED RECORD B9500094^^ 52 IF (AND(TBLREC(40),$20FF).EQ.$2044) GO TO 100 B9500095^^ C CHECK LINE COUNT TO DETERMINE IF HEADING IS NECESSRYB9500096^^ 53 IF (LNCNT.LT.58) GO TO 200 B9500097^^ C HEADING ROUTINE B9500098^^ 54 PGCNT=PGCNT+1 B9500099^^ 55 CALL BINASC(PGCNT,IHOLD2) B9500100^^ 56 HEAD1(59)=IHOLD2(2) B9500101^^ 57 IFLAG=0 B9500102^^ 58 ASSIGN 120 TO ICOMP B9500103^^ 59 DO 110 K=1,66 B9500104^^ 60 IBUF(K)=HEAD1(K) B9500105^^ 61 110 CONTINUE B9500106^^ 62 115 LNCNT=LNCNT+1 B9500107^^ 63 CALL FWRITE(9,IBUF,132,ICOMP,IFLAG,ITEMP) B9500108^t FTN 3.3B (OPT = LPC) PGLTTB PAGE 3 DATE: 08/29/84 TIME: 2255 t^ 64 CALL DISP B9500109^^ C STANDARD HEADING 2 B9500110^^ 65 120 ASSIGN 130 TO ICOMP B9500111^^ 66 DO 125 K=1,66 B9500112^^ 67 IBUF(K)=HEAD2(K) B9500113^^ 68 125 CONTINUE B9500114^^ 69 GO TO 115 B9500115^^ C STANDARD HEADING 3 B9500116^^ 70 130 ASSIGN 140 TO ICOMP B9500117^^ 71 DO 135 K=1,66 B9500118^^ 72 IBUF(K)=HEAD3(K) B9500119^^ 73 135 CONTINUE B9500120^^ 74 GO TO 115 B9500121^^ C REPORT HEADING 1 B9500122^^ 75 140 ASSIGN 150 TO ICOMP B9500123^^ 76 DO 145 K=1,66 B9500124^^ 77 IBUF(K)=LISTH1(K) B9500125^^ 78 145 CONTINUE B9500126^^ 79 GO TO 115 B9500127^^ C REPORT HEADING 2 B9500128^^ 80 150 ASSIGN 155 TO ICOMP B9500129^^ 81 CALL CCSBLK(IBUF,132) B9500130^^ 82 GO TO 115 B9500131^^ 83 155 ASSIGN 160 TO ICOMP B9500132^^ 84 DO 156 K=1,55 B9500133^^ 85 IBUF(K)=LISTH2(K) B9500134^^ 86 156 CONTINUE B9500135^^ 87 GO TO 115 B9500136^^ C REPORT HEADING 3 B9500137^^ 88 160 ASSIGN 165 TO ICOMP B9500138^^ 89 DO 161 K=1,55 B9500139^^ 90 IBUF(K)=LISTH3(K) B9500140^^ 91 161 CONTINUE B9500141^^ 92 GO TO 115 B9500142^^ 93 165 ASSIGN 170 TO ICOMP B9500143^^ 94 CALL CCSBLK(IBUF,132) B9500144^^ 95 GO TO 115 B9500145^^ 96 170 LNCNT=8 B9500146^^ C B9500147^^ C SET UP DETAIL REPORT LINE B9500148^^ C NAME B9500149^^ 97 200 IBUF(1)=TBLREC(1) B9500150^^ 98 IBUF(2)=TBLREC(2) B9500151^^ 99 IBUF(3)=TBLREC(3) B9500152^^ C STARTING POSITION B9500153^^ 100 IBUF(5)=TBLREC(4) B9500154^^ 101 IBUF(6)=TBLREC(5) B9500155^^ C DATA LENGTH B9500156^^ 102 IBUF(9) =TBLREC(6) B9500157^^ 103 IBUF(10)=TBLREC(7) B9500158^^ C DATA TYPE B9500159^^ 104 CALL CCSGET(TBLREC,15,IHOLD) B9500160^^ 105 CALL CCSPUT(IHOLD,24,IBUF) B9500161^^ C EDIT CODE B9500162^t FTN 3.3B (OPT = LPC) PGLTTB PAGE 4 DATE: 08/29/84 TIME: 2255 t^ 106 CALL CCSGET(TBLREC,16,IHOLD) B9500163^^ 107 CALL CCSPUT(IHOLD,29,IBUF) B9500164^^ C DECIMAL POSITIONS B9500165^^ 108 CALL CCSGET(TBLREC,18,IHOLD) B9500166^^ 109 CALL CCSPUT(IHOLD,34,IBUF) B9500167^^ C CLASSIFIED CODE B9500168^^ 110 CALL CCSGET(TBLREC,17,IHOLD) B9500169^^ 111 CALL CCSPUT(IHOLD,41,IBUF) B9500170^^ C DESCRIPTION B9500171^^ 112 K1=24 B9500172^^ 113 K2=10 B9500173^^ 114 DO 250 K=1,15 B9500174^^ 115 IBUF(K1)=TBLREC(K2) B9500175^^ 116 K1=K1+1 B9500176^^ 117 K2=K2+1 B9500177^^ 118 250 CONTINUE B9500178^^ C SUB DATA NAMES B9500179^^ 119 K1=77 B9500180^^ 120 K2=49 B9500181^^ 121 DO 280 K=1,5 B9500182^^ 122 CALL CCSMVA(TBLREC,K2,6,IBUF,K1,6) B9500183^^ 123 K1=K1+7 B9500184^^ 124 K2=K2+6 B9500185^^ 125 280 CONTINUE B9500186^^ C WRITE DETAIL LINE B9500187^^ 126 ASSIGN 100 TO ICOMP B9500188^^ 127 GO TO 115 B9500189^^ C ERROR PROCESSING B9500190^^ C OPEN FILE B9500191^^ 128 8000 CALL FILERR(UTIFIL,3,ISTAT,LU) B9500192^^ 129 GO TO 9100 B9500193^^ 130 8010 CALL FILERR(RPTTBL,3,ISTAT,LU) B9500194^^ 131 GO TO 9100 B9500195^^ 132 8020 CALL FILERR(UTIFIL,13,ISTAT,LU) B9500196^^ 133 GO TO 9100 B9500197^^ 134 8030 CALL FILERR(RPTTBL,14,ISTAT,LU) B9500198^^ 135 GO TO 9100 B9500199^^ 136 8900 CALL WTREAD(LU,XYN,ERRMSG,46,0,0,0,TC) B9500200^^ 137 CALL WTREAD(LU,XYN,ABTMSG,14,0,0,0,TC) B9500201^^ C CLOSE FILES B9500202^^ 138 9100 CALL CLOSFL(UTIRQB,ISTAT) B9500203^^ 139 CALL CLOSFL(TBLRQB,ISTAT) B9500204^^ 140 CALL PGMOUT B9500205^^ 141 END B9500206^t FTN 3.3B (OPT = LPC) PGLTTB PAGE 5 DATE: 08/29/84 TIME: 2255 t  PROGRAM LENGTH $04B2 ( 1202)   EXTERNALS 2 Q8STP AMONTO ADAYTO AYERTO PGMIN OPENFL READR 22 CCSMVA CCSGET CCSPUT GETS BINASC FWRITE DISP 2& CCSBLK FILERR WTREAD CLOSFL PGMOUT & t FTN 3.3B (OPT = LPC) PGLTTB PAGE 6 DATE: 08/29/84 TIME: 2255 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < $ 8100 (-32511) 02C0 49,49$( FFFF (65535) 02BB 38,39,40 (X 0000 (0) 0003 5,6,7,8,18,20,22,24,27,32,37,41,45,46,47,50,51,57,136,137XZ 0001 (1) 0002 5,6,28,33,42,45,54,59,62,66,71,76,84,89,97,114,116,117,121 Z0 0003 (3) 02B8 25,47,99,128,130 0. 0005 (5) 02B6 25,100,101,121 .* 0006 (6) 02D1 122,122,124*& 0009 (9) 02C5 62,102 &" 000D (13) 02D2 132"& 000E (14) 02D3 134,137&& 000F (15) 02C7 104,114&" 0010 (16) 02C9 106"" 0011 (17) 02CD 110"" 0012 (18) 02CB 108"& 0018 (24) 02C8 105,112&" 001D (29) 02CA 107"" 0022 (34) 02CC 109"( 0028 (40) 02B7 25,25,52 (" 0029 (41) 02CE 111"" 002E (46) 02D4 136"" 0076 (118) 02BE 43 "" 0077 (119) 02BF 44 "( 0084 (132) 02C6 63,81,94 (" 2044 (8260) 02C2 52 "" 20FF (8447) 02C1 52 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < ( ABTMSG INTEGER 00CA 1,10,137 (. AND INTR.FN. 7FFF 38,39,40,49,52 . CS INTEGER 0054 1 & ERRMSG INTEGER 00B3 1,9,136& FILREQ INTEGER 00D3 1 & HDR1 INTEGER 00EB 1,14,23&& HDR2 INTEGER 00ED 1,14,26&& HDR3 INTEGER 00EF 1,14,31&, HEAD1 INTEGER 00F1 1,15,25,56,60,6 HEAD2 INTEGER 0133 1,15,29,38,39,43,44,67 6* HEAD3 INTEGER 0175 1,15,34,72 *" I INTEGER 02B3 17 "l IBUF INTEGER 0270 1,60,63,67,72,77,81,85,90,94,97,98,99,100,101,102,103,105,107,109,111,115,122l> ICOMP INTEGER 02C4 57,63,65,70,75,80,83,88,93,126 >t FTN 3.3B (OPT = LPC) PGLTTB PAGE 7 DATE: 08/29/84 TIME: 2255 t* IDAY INTEGER 02BC 39,40,42,44*( IFLAG INTEGER 02C3 56,57,63 (J IHOLD INTEGER 02BD 40,41,42,43,104,105,106,107,108,109,110,111J& IHOLD2 INTEGER 00D1 1,55,56&` ISTAT INTEGER 02B5 19,20,21,22,23,24,26,27,31,32,48,49,50,51,128,130,132,134,138,139`$ ITEMP INTEGER 0268 1,63 $$ J INTEGER 02B4 17,18$V K INTEGER 02B9 27,29,33,34,59,60,66,67,71,72,76,77,84,85,89,90,114,121V: K1 INTEGER 02CF 111,112,115,116,119,122,123:: K2 INTEGER 02D0 112,113,115,117,120,122,124:& LISTH1 INTEGER 01B7 1,11,77&& LISTH2 INTEGER 01F9 1,12,85&& LISTH3 INTEGER 0230 1,13,90&. LNCNT INTEGER 02BA 35,36,53,62,96 .: LU INTEGER 02B2 17,128,130,132,134,136,137 :* PGCNT INTEGER 0267 1,37,54,55 * RPTG INTEGER 005A 1 . RPTTBL INTEGER 0013 1,6,21,130,134 .$ TBL INTEGER 0056 1,17 $, TBLKEY INTEGER 0086 1,45,46,47,48,X TBLREC INTEGER 0089 1,48,52,97,98,99,100,101,102,103,104,106,108,110,115,122 X, TBLRQB INTEGER 003A 1,8,21,48,139,( TC INTEGER 0053 1,136,137(. UTIFIL INTEGER 0004 1,5,19,128,132 .2 UTIRQB INTEGER 0022 1,7,19,23,26,31,13822 UTREC INTEGER 005C 1,23,25,26,29,31,342( XYN INTEGER 0052 1,136,137(   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " BINASC SUBROUTINE 0385 54 "$ CCSBLK SUBROUTINE 03DC 80,94$2 CCSGET SUBROUTINE 0425 41,104,106,108,110 2& CCSMVA SUBROUTINE 0463 24,122 &4 CCSPUT SUBROUTINE 042A 42,44,105,107,109,1114& CLOSFL SUBROUTINE 04A8 138,139&" DISP SUBROUTINE 03AA 63 ". FILERR SUBROUTINE 047C 128,130,132,134." FWRITE SUBROUTINE 03A2 62 "" GETS SUBROUTINE 035E 47 "$ OPENFL SUBROUTINE 02E1 18,21$" PGMIN SUBROUTINE 02D6 15 "" PGMOUT SUBROUTINE 04AF 139" Q8STP INTEGER.FN. 04B1 ( READR SUBROUTINE 02F4 22,26,31 (& WTREAD SUBROUTINE 0495 136,137&t FTN 3.3B (OPT = LPC) PGLTTB PAGE 8 DATE: 08/29/84 TIME: 2255 t   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 30 0317 27,30$$ 40 032C 32,35$( 100 035D 47,52,126($ 110 039B 57,61$: 115 03A0 61,69,74,79,82,87,92,95,127:$ 120 03AB 57,65$$ 125 03B4 65,68$$ 130 03BA 65,70$$ 135 03C3 70,73$$ 140 03C9 70,75$$ 145 03D2 75,78$$ 150 03D8 75,80$$ 155 03E0 80,83$$ 156 03E9 83,86$$ 160 03EF 83,88$$ 161 03F8 88,91$$ 165 03FE 88,93$$ 170 0405 93,96$$ 200 0408 53,97$& 250 0457 113,118&& 280 0470 120,125&& 8000 047B 20,128 && 8010 0482 22,130 &, 8020 0488 24,27,32,132 ,& 8030 048E 50,134 && 8900 0494 18,136 &8 9100 04A7 49,51,129,131,133,135,1388 PGLTTB 0000 1 t FTN 3.3B (OPT = LPC) PGPURG PAGE 1 DATE: 08/29/84 TIME: 2256 t^ 1 PROGRAM PGPURG B9500001^^ 1 1 /B96 F CCS CCS 3.0 SL-149B9500002^^ C B9500003^^ C CYBERCREDIT SYSTEM VERSION 3 B9500004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B9500005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B9500006^^ C B9500007^  ^ C THIS PROGRAM MAINTAINS THE REPORT GENERATOR SAVED PROGRAM B9500009^^ C FILE, ALLOWS FOR NO LONGER NEEDED ENTRIES TO BE REMOVED. B9500010^^ C THE NEXT AVAILABLE PROGRAM NUMBER IN THE UTIFIL FILE IS UPDATED B9500011^^ C ALL INPUT IS FROM THE CONSOLE B9500012^^ C THE RECORDS ARE DELETED FROM THE RPTPGM FILE B9500013^^ C THE RG MENU IS UPDATED (SHOWS REPORT NUMBER AVAILABLE) B9500014^  ^ 2 INTEGER USER(4),CURNUM,RELRNO(2),UDATA(15),UREQ(24),UREC(40), B9500016^^ 2 1 MDATA(15),MREQ(24),MREC(40),TDATA(15),TREQ(24),TREC(42), B9500017^^ 2 2 MSG1(43),MSG2(19),MSG3(50),MSG4(12),OK,NO,EN,INPUT(10), B9500018^^ 2 2 UKEY(2),TKEY(3),MMSG(11),MSG5(21) B9500019^^ 3 INTEGER PDATA(12),PREQ(24) B9500020^  ^ 4 DATA UDATA / 'UTIFIL ',8*$2020, 1, 1, 1 / B9500022^^ 5 DATA TDATA / 'RPTPGM ',8*$2020, 1, 1, 1 / B9500023^^ 6 DATA MDATA / '$$RGMENU$$',7*$2020,0,1,1 / B9500024^^ 7 DATA RELRNO / 0, 0 /, MREQ,UREQ,TREQ / 72*0 / B9500025^^ 8 DATA OK / 'OK' /, NO / 'NO' /, EN / 'EN' / B9500026^^ 9 DATA UKEY / 'RPTG' /, TKEY / 'RPT0XX' / B9500027^^ 10 DATA MMSG / 'REPORT XX AVAILABLE ' / B9500028^^ 11 DATA PREQ / 24*0 /, PDATA / 'PRFPG000CCS20 ' , 5*$2020 / B9500029^  ^ 12 DATA MSG1 / $D0A,'PLEASE ENTER: REPORT NUMBER (01-19)' , B9500031^^ 12 1 ' TO DELETE',$D0A,' OR "END" TO TERMINATE ',$D0A/ B9500032^ ^ 13 DATA MSG2 / $D0A,'INVALID RESPONSE - PLEASE REENTER ', $D0A/ B9500034^ ^ 14 DATA MSG3 / $D0A,'PROGRAM "',15*$2020,'" ',$D0A, B9500036^^ 14 1 ' ENTER: "OK" TO CONTINUE ',$D0A, B9500037^^ 14 2 ' OR "NO" TO BYPASS ', $D0A / B9500038^ ^ 15 DATA MSG4 / $D0A,'REPORT XX DELETED ',$D0A / B9500040^^ 16 DATA MSG5 / $D0A,'REPORT NUMBER IS ALREADY AVAILABLE',$D0A/ B9500041^t FTN 3.3B (OPT = LPC) PGPURG PAGE 2 DATE: 08/29/84 TIME: 2256 t^ C ACCEPT THE CCS LOGIN B9500043^^ 17 CALL PGMIN ( USER, LU, MODE, NPORT ) B9500044^  ^ C RETREIVE THE 'RPTG' RECORD FROM THE UTILITY FILE B9500046^^ 18 CALL OPENFL ( UREQ, UDATA, ISTAT ) B9500047^^ 19 IF (ISTAT .GE. 0 ) GO TO 100 B9500048^^ C REPORT ERROR AND EXIT B9500049^^ 20 CALL FILERR ( UDATA, 3, ISTAT, LU ) B9500050^^ 21 GO TO 900 B9500051^^ C GET THE RECORD B9500052^^ 22 100 CALL READR ( UREQ, UREC, UKEY, ISTAT ) B9500053^^ 23 IF ( ISTAT.GE.0.AND.AND(ISTAT,$200).NE.$200) GO TO 110 B9500054^^ 24 CALL FILERR ( UDATA, 13, ISTAT, LU ) B9500055^^ 25 GO TO 900 B9500056^^ C SAVE THE NEXT AVAILABLE REPORT NUMBER B9500057^^ 26 110 NXTNUM = UREC(6) B9500058^  ^ C OPEN THE MENU FILE AND THE RPTPGM FILE FOR USE B9500060^^ 27 CALL OPENFL ( MREQ, MDATA, ISTAT ) B9500061^^ 28 IF ( ISTAT .GE. 0 ) GO TO 200 B9500062^^ 29 CALL FILERR ( MDATA, 3, ISTAT, LU ) B9500063^^ 30 GO TO 900 B9500064^^ 31 200 CALL OPENFL ( TREQ, TDATA, ISTAT ) B9500065^^ 32 IF ( ISTAT .GE. 0 ) GO TO 300 B9500066^^ 33 CALL FILERR ( TDATA, 3, ISTAT, LU ) B9500067^^ 34 GO TO 900 B9500068^t FTN 3.3B (OPT = LPC) PGPURG PAGE 3 DATE: 08/29/84 TIME: 2256 t^ C PROMPT FOR REPORT NUMBER TO DELETE B9500070^^ 35 300 CALL WTREAD ( LU, -1, MSG1, 86, -1, INPUT, 6, ITC ) B9500071^^ 36 310 IF ( INPUT(1) .EQ. EN ) GO TO 800 B9500072^^ C DETERMINE WHICH REPORT IS TO BE DELETED B9500073^^ 37 RELRNO(2) = AND(INPUT(1),$F00)/$100*10 + B9500074^^ 37 1 AND(INPUT(1),$F) + 2 B9500075^^ 38 IF ( RELRNO(2) .GE. 1 .AND. RELRNO(2) .LE. 22 ) GO TO 330 B9500076^^ 39 320 CALL WTREAD ( LU, -1, MSG2, 38, -1, INPUT, 6, ITC ) B9500077^^ 40 GO TO 310 B9500078^^ 41 330 TKEY(3) = INPUT(1) B9500079^^ 42 CALL READR ( TREQ, TREC, TKEY, ISTAT ) B9500080^^ 43 IF(AND(ISTAT,$0200).EQ.$0200.OR.AND(ISTAT,$0100).EQ.$0100) B9500081^^ 43 1 GO TO 335 B9500082^^ 44 IF ( ISTAT .LT. 0 ) GO TO 320 B9500083^^ 45 IF(TREC(3) .EQ. INPUT(1)) GO TO 340 B9500084^^ C THE RECORD WAS NOT FOUND IN RPTPGM - TELL OPERATOR B9500085^^ 46 335 CALL CCSMVA(INPUT,1,2,MSG5,17,2) B9500086^^ 47 CALL WTREAD(LU, -1, MSG5,42,0,0,0,ITC) B9500087^^ 48 GO TO 300 B9500088^  ^ 49 340 CALL CCSMVA ( TREC, 13, 30, MSG3, 13, 30 ) B9500090^^ 50 345 CALL WTREAD ( LU, -1, MSG3, 100, -1, INPUT, 2, ITC ) B9500091^^ 51 IF ( INPUT(1) .EQ. OK ) GO TO 350 B9500092^^ 52 IF ( INPUT(1) .EQ. NO ) GO TO 300 B9500093^^ 53 GO TO 345 B9500094^^ 54 350 CALL DELREC ( TREQ, TREC, ISTAT ) B9500095^^ 55 IF(ISTAT.GE.0) GO TO 400 B9500096^^ 56 CALL FILERR(TDATA,16,ISTAT,LU) B9500097^^ 57 GO TO 900 B9500098^^ C NEW UTILITY FILE VALUE? B9500099^^ 58 400 IF ( TKEY(3) .LT. NXTNUM ) NXTNUM = TKEY(3) B9500100^^ C IF ALL 19 PROGRAMS WERE USED-FORCE NXTNUM TO DELETED NUMBER B9500101^^ 59 IF(NXTNUM.EQ.$3030) NXTNUM = TKEY(3) B9500102^ ^ 60 CALL READR ( MREQ, MREC, RELRNO, ISTAT ) B9500104^^ 61 IF ( ISTAT .LT. 0 ) GO TO 320 B9500105^^ 62 MMSG(5) = TKEY(3) B9500106^^ 63 CALL CCSMVA ( MMSG, 1, 22, MREC, 15, 58 ) B9500107^^ 64 CALL UPDREC ( MREQ, MREC, ISTAT ) B9500108^^ 65 IF(ISTAT.GE.0) GO TO 450 B9500109^^ 66 CALL FILERR(MDATA,15,ISTAT,LU) B9500110^^ 67 GO TO 900 B9500111^^ C DELETE THE PROCEDURE STREAM FILE B9500112^^ 68 450 PDATA(4) = TKEY(3) B9500113^^ 69 CALL DELETE ( PREQ, PDATA, ISTAT ) B9500114^^ 70 IF(ISTAT.GE.0) GO TO 500 B9500115^^ 71 CALL FILERR(PDATA,2,ISTAT,LU) B9500116^^ 72 GO TO 900 B9500117^^ 73 500 MSG4(6) = TKEY(3) B9500118^^ 74 CALL WTREAD ( LU, -1, MSG4, 24, -1, INPUT, 0, ITC ) B9500119^^ 75 GO TO 300 B9500120^  t FTN 3.3B (OPT = LPC) PGPURG PAGE 4 DATE: 08/29/84 TIME: 2256 t^ C UPDATE THE UTILITY FILE B9500122^^ 76 800 UREC(6) = NXTNUM B9500123^^ 77 CALL UPDREC ( UREQ, UREC, ISTAT) B9500124^^ 78 IF(ISTAT.GE.0) GO TO 900 B9500125^^ 79 CALL FILERR(UDATA,15,ISTAT,LU) B9500126^  ^ C CLOSE ALL FILES B9500128^^ 80 900 CALL CLOSFL ( UREQ, ISTAT ) B9500129^^ 81 CALL CLOSFL ( MREQ, ISTAT ) B9500130^^ 82 CALL CLOSFL ( TREQ, ISTAT ) B9500131^^ 83 CALL PGMOUT B9500132^^ 84 END B9500133^t FTN 3.3B (OPT = LPC) PGPURG PAGE 5 DATE: 08/29/84 TIME: 2256 t  PROGRAM LENGTH $0325 ( 805)   EXTERNALS 2 Q8STP PGMIN OPENFL FILERR READR WTREAD CCSMVA 2& DELREC UPDREC DELETE CLOSFL PGMOUT & t FTN 3.3B (OPT = LPC) PGPURG PAGE 6 DATE: 08/29/84 TIME: 2256 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < 0 FFFE (-1) 01D3 35,35,39,47,50,740J 0000 (0) 0003 6,7,11,19,23,28,32,44,47,55,61,65,70,74,78 JN 0001 (1) 0002 4,5,6,35,36,37,38,39,41,45,46,47,50,51,52,63,74N. 0002 (2) 01DB 37,38,46,50,71 .< 0003 (3) 01CF 20,29,33,41,45,58,59,62,68,73<* 0006 (6) 01D5 35,39,73,76*" 000A (10) 01D9 37 "$ 000D (13) 01D1 24,49$* 000F (15) 01DA 37,63,66,79*" 0010 (16) 01E2 56 "" 0011 (17) 01DE 46 "$ 0016 (22) 01DC 38,63$" 0018 (24) 01E5 74 "$ 001E (30) 01E0 49,49$" 0026 (38) 01DD 39 "" 002A (42) 01DF 47 "" 003A (58) 01E4 63 "" 0056 (86) 01D4 35 "" 0064 (100) 01E1 50 "$ 0100 (256) 01D8 37,43$( 0200 (512) 01D0 23,23,43 (" 0F00 (3840) 01D7 37 "" 3030 (12336) 01E3 59 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < ( AND INTR.FN. 7FFF 23,37,43 (& EN INTEGER 0177 1,8,36 &B INPUT INTEGER 0178 1,35,36,37,39,41,45,46,50,51,52,74 B~ ISTAT INTEGER 01CE 18,19,20,22,23,24,27,28,29,31,32,33,42,43,44,54,55,56,60,61,64,65,66,69,70,71,77,78,79,80,81,82~. ITC INTEGER 01D6 35,39,47,50,74 .H LU INTEGER 01CB 17,20,24,29,33,35,39,47,50,56,66,71,74,79H, MDATA INTEGER 0059 1,6,27,29,66 ,* MMSG INTEGER 0187 1,10,62,63 *" MODE INTEGER 01CC 17 "* MREC INTEGER 0080 1,60,63,64 *. MREQ INTEGER 0068 1,7,27,60,64,81.& MSG1 INTEGER 00F9 1,12,35&& MSG2 INTEGER 0124 1,13,39&* MSG3 INTEGER 0137 1,14,49,50 ** MSG4 INTEGER 0169 1,15,73,74 ** MSG5 INTEGER 0192 1,16,46,47 *t FTN 3.3B (OPT = LPC) PGPURG PAGE 7 DATE: 08/29/84 TIME: 2256 t& NO INTEGER 0176 1,8,52 &" NPORT INTEGER 01CD 17 ". NXTNUM INTEGER 01D2 26,26,58,59,76 .& OK INTEGER 0175 1,8,51 &, PDATA INTEGER 01A7 1,11,68,69,71,& PREQ INTEGER 01B3 1,11,69&, RELRNO INTEGER 0008 1,7,37,38,60 ,, TDATA INTEGER 00A8 1,5,31,33,56 ,8 TKEY INTEGER 0184 1,9,41,42,58,59,62,68,73 8, TREC INTEGER 00CF 1,42,45,49,54,. TREQ INTEGER 00B7 1,7,31,42,54,82.. UDATA INTEGER 000A 1,4,18,20,24,79.& UKEY INTEGER 0182 1,9,22 &, UREC INTEGER 0031 1,22,26,76,77,. UREQ INTEGER 0019 1,7,18,22,77,80.$ USER INTEGER 0004 1,17 $   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < ( CCSMVA SUBROUTINE 027B 46,49,63 (( CLOSFL SUBROUTINE 0318 80,81,82 (" DELETE SUBROUTINE 02EC 68 "" DELREC SUBROUTINE 02A9 54 "6 FILERR SUBROUTINE 02B1 19,24,29,33,56,66,71,796( OPENFL SUBROUTINE 01ED 17,27,31 (" PGMIN SUBROUTINE 01E7 16 "" PGMOUT SUBROUTINE 0322 82 " Q8STP INTEGER.FN. 0324 ( READR SUBROUTINE 02C5 22,42,60 ($ UPDREC SUBROUTINE 02DA 63,77$. WTREAD SUBROUTINE 02FD 35,39,47,50,74 .   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 100 01FC 19,22$$ 110 0210 23,26$$ 200 0221 28,31$. 300 022F 32,35,48,52,75 .$ 310 0239 35,40$( 320 0252 38,44,61 ($ 330 025D 38,41$$ 335 027A 43,46$$ 340 028C 45,49$$ 345 0293 49,53$$ 350 02A8 51,54$$ 400 02B7 55,58$t FTN 3.3B (OPT = LPC) PGPURG PAGE 8 DATE: 08/29/84 TIME: 2256 t$ 450 02E8 65,68$$ 500 02F9 70,73$$ 800 0308 36,76$: 900 0317 20,25,30,34,57,67,72,78,80 : PGPURG 0000 1 t FTN 3.3B (OPT = LPC) PGSEDT PAGE 1 DATE: 08/29/84 TIME: 2257 t^ 1 SUBROUTINE PGSEDT (IR,OPBUF) B9700001^^ 1 1 /B97 F CCS CCS 3.0 SL-149B9700002^^ C B9700003^^ C CYBERCREDIT SYSTEM VERSION 3 B9700004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B9700005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B9700006^^ C B9700007^^ C CHECKS FOR AN OPERATOR RESPONSE OF: REPEAT,C, OR A B9700008^^ C IF IT IS ONE OF THE ABOVE RESPONSES, IR IS SET TO 1,2 OR 3 B9700009^^ C C, RADDR IS ASSIGNED TO 1000, THE NEXT OPERATOR QUESTION B9700010^^ C A, RADDR IS ASSIGNED TO 9100, ABORTS THE JOB B9700011^^ C REPEAT, RADDR IS ASSIGNED PRIOR TO THE CALL B9700012^^ 2 INTEGER IR,OPBUF(32) B9700013^^ C B9700014^^ 3 IF (AND(OPBUF(16),$00FF).NE.1) GO TO 100 B9700015^^ C CHECK FOR C,A, OR REPEAT B9700016^^ 4 IF (AND(OPBUF(1),$FF00).EQ.$4300) GO TO 110 B9700017^^ 5 IF (AND(OPBUF(1),$FF00).EQ.$4100) GO TO 120 B9700018^^ 6 100 IF (OPBUF(1).NE.$5245) GO TO 200 B9700019^^ C REPEAT B9700020^^ 7 IF (OPBUF(2).EQ.$5045.AND.OPBUF(3).EQ.$4154) IR=1 B9700021^^ 8 GO TO 200 B9700022^^ C C B9700023^^ 9 110 IR=2 B9700024^^ 10 GO TO 200 B9700025^^ C A B9700026^^ 11 120 IR=3 B9700027^^ C RETURN B9700028^^ 12 200 RETURN B9700029^^ 13 END B9700030^t FTN 3.3B (OPT = LPC) PGSEDT PAGE 2 DATE: 08/29/84 TIME: 2257 t  PROGRAM LENGTH $0041 ( 65)   EXTERNALS  Q8PKUP Q8PREP  t FTN 3.3B (OPT = LPC) PGSEDT PAGE 3 DATE: 08/29/84 TIME: 2257 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " FF00 (-255) 0001 4,5" 00FF (255) 0000 3 4100 (16640) 0003 5 4154 (16724) 0006 7 4300 (17152) 0002 4 5045 (20549) 0005 7 5245 (21061) 0004 6    VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < $ AND INTR.FN. 7FFF 3,4,5$* IR INTEGER 7FFF 1,2,7,9,11 *, OPBUF INTEGER 7FFF 1,2,3,4,5,6,7,   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  Q8PKUP INTEGER.FN. 0035 Q8PREP INTEGER.FN. 0032    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < " 100 0015 3,6"" 110 0027 4,9"$ 120 002A 5,11 $( 200 002C 6,8,10,12( PGSEDT 002F 1  t FTN 3.3B (OPT = LPC) PGSJL PAGE 1 DATE: 08/29/84 TIME: 2257 t^ 1 SUBROUTINE PGSJL(IARRAY,IBPOS,ILNG,OARRAY,OBPOS,OLNG) B9800001^^ 1 1 /B98 F CCS CCS 3.0 SL-149B9800002^^ C B9800003^^ C CYBERCREDIT SYSTEM VERSION 3 B9800004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B9800005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B9800006^^ C B9800007^^ C LEFT JUSTIFY WITH TRAILING BLANKS THE CONTENTS OF AN ARRAY B9800008^^ C OF GIVEN LENGTH B9800009^^ C IARRAY = INPUT ARRAY B9800010^^ C IBPOS = BEGINNING POSITION WITHING THE INPUT ARRAY B9800011^^ C OF THE VALUE TO BE LEFT JUSTIFIED B9800012^^ C ILNG = LENGTH OF THE VALUE TO BE LEFT JUSTIFIED B9800013^^ C OARRAY = OUTPUT ARRAY (CAN BE SAME AS INPUT ARRAY) B9800014^^ C OBPSO = BEGINNING POSITION WITHIN THE OUTPUT ARRAY B9800015^^ C OLNG = LENGTH OF THE OUTPUT VALUE B9800016^^ 2 INTEGER IARRAY(170),OARRAY(170),IBPOS,OBPOS,ILNG,OLNG B9800017^^ 3 INTEGER WKARR(15) B9800018^^ C MAXIMUM LENGTH OF THE FIELD IS 30 POSITIONS B9800019^^ C MAXIMUM ARRAY SIZE IS 340 CHARACTERS B9800020^^ C B9800021^^ C CLEAR WORK ARRAY TO BLANKS B9800022^^ 4 CALL CCSBLK(WKARR,30) B9800023^^ C LEFT JUSTIFY VALUE IN WORK ARRAY B9800024^^ 5 IHOLD=$0000 B9800025^^ 6 IPOS=IBPOS B9800026^^ 7 DO 20 K=1,ILNG B9800027^^ 8 CALL CCSGET(IARRAY,IPOS,IHOLD) B9800028^^ 9 CALL CCSPUT(IHOLD,K,WKARR) B9800029^^ 10 IPOS=IPOS+1 B9800030^^ 11 20 CONTINUE B9800031^^ C TRANSFER WORK ARRAY TO OUTPUT ARRAY B9800032^^ 12 IPOS=OBPOS B9800033^^ 13 DO 30 K=1,OLNG B9800034^^ 14 CALL CCSGET(WKARR,K,IHOLD) B9800035^^ 15 CALL CCSPUT(IHOLD,IPOS,OARRAY) B9800036^^ 16 IPOS=IPOS+1 B9800037^^ 17 30 CONTINUE B9800038^^ C RETURN B9800039^^ 18 RETURN B9800040^^ 19 END B9800041^t FTN 3.3B (OPT = LPC) PGSJL PAGE 2 DATE: 08/29/84 TIME: 2257 t  PROGRAM LENGTH $005A ( 90)   EXTERNALS & Q8PKUP Q8PREP CCSBLK CCSGET CCSPUT & t FTN 3.3B (OPT = LPC) PGSJL PAGE 3 DATE: 08/29/84 TIME: 2257 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : <  001E (30) 000F 4    VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < $ IARRAY INTEGER 7FFF 1,2,8$$ IBPOS INTEGER 7FFF 1,2,6$, IHOLD INTEGER 0010 4,5,8,9,14,15,$ ILNG INTEGER 7FFF 1,2,7$0 IPOS INTEGER 0011 5,6,8,10,12,15,160( K INTEGER 0012 6,9,13,14(& OARRAY INTEGER 7FFF 1,2,15 && OBPOS INTEGER 7FFF 1,2,12 && OLNG INTEGER 7FFF 1,2,13 &( WKARR INTEGER 0000 2,4,9,14 (   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  CCSBLK SUBROUTINE 0014 2 $ CCSGET SUBROUTINE 0021 7,14 $$ CCSPUT SUBROUTINE 0026 8,15 $ Q8PKUP INTEGER.FN. 004C Q8PREP INTEGER.FN. 0049    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 20 002B 6,11 $$ 30 003F 12,17$ PGSJL 0046 1  t FTN 3.3B (OPT = LPC) PGSJR PAGE 1 DATE: 08/29/84 TIME: 2257 t^ 1 SUBROUTINE PGSJR(IARRAY,IBPOS,ILNG,OARRAY,OBPOS,OLNG) B9900001^^ 1 1 /B99 F CCS CCS 3.0 SL-149B9900002^^ C B9900003^^ C CYBERCREDIT SYSTEM VERSION 3 B9900004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA B9900005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 B9900006^^ C B9900007^^ C RIGHT JUSTIFY WITH LEADING ASCII ZEROS THE CONTENTS OF AN B9900008^^ C ARRAY OF GIVEN LENGTH B9900009^^ C IARRAY=INPUT ARRAY B9900010^^ C IBPOS = BEGINNING POSITION WITHIN THE INPUT ARRAY B9900011^^ C OF THE VALUE TO BE RIGHT JUSTIFIED B9900012^^ C ILNG =LENGTH OF THE INPUT VALUE B9900013^^ C OARRAY=OUTPUT ARRAY (CAN BE THE SAME AS INPUT ARRAY)B9900014^^ C OBPOS =BEGINNING POSITION WITHIN THE OUTPUT ARRAY B9900015^^ C OLNG =LENGTH OF OUTPUT B9900016^^ C B9900017^^ 2 INTEGER IARRAY(170),OARRAY(170),IBPOS,OBPOS,ILNG, OLNG B9900018^^ 3 INTEGER WKARR(15),WKPOS B9900019^^ C MAXIMUM LENGTH OF FIELD IS 30 POSITION B9900020^^ C MAXIMUM ARRAY SIZE IS 340 CHARACTERS B9900021^^ C B9900022^^ C CLEAR WORK ARRAY TO ZEROS B9900023^^ 4 DO 10 K=1,15 B9900024^^ 5 WKARR(K)=$3030 B9900025^^ 6 10 CONTINUE B9900026^^ C RIGHT JUSTIFY VALUE IN WORK ARRAY B9900027^^ C # LEADING ZEROS EQUALS OUTPUT LENGTH - INPUT LENGTH B9900028^^ 7 WKPOS=OLNG-ILNG+1 B9900029^^ 8 IHOLD=$0000 B9900030^^ 9 IPOS=IBPOS B9900031^^ 10 DO 20 K=1,ILNG B9900032^^ 11 CALL CCSGET(IARRAY,IPOS,IHOLD) B9900033^^ 12 CALL CCSPUT(IHOLD,WKPOS,WKARR) B9900034^^ 13 WKPOS=WKPOS+1 B9900035^^ 14 IPOS=IPOS+1 B9900036^^ 15 20 CONTINUE B9900037^^ C TRANSFER WORK ARRAY TO OUTPUT ARRAY B9900038^^ C OUTPUT ARRAY IS NOT USED INITIALLY AS IT CAN BE AT B9900039^^ C THE SAME ADDRESS AS THE INPUT B9900040^^ 16 WKPOS=1 B9900041^^ 17 IPOS=OBPOS B9900042^^ 18 DO 30 K=1,OLNG B9900043^^ 19 CALL CCSGET(WKARR,WKPOS,IHOLD) B9900044^^ 20 CALL CCSPUT(IHOLD,IPOS,OARRAY) B9900045^^ 21 WKPOS=WKPOS+1 B9900046^^ 22 IPOS=IPOS+1 B9900047^^ 23 30 CONTINUE B9900048^^ C RETURN B9900049^^ 24 RETURN B9900050^^ 25 END B9900051^t FTN 3.3B (OPT = LPC) PGSJR PAGE 2 DATE: 08/29/84 TIME: 2257 t  PROGRAM LENGTH $006A ( 106)   EXTERNALS  Q8PKUP Q8PREP CCSGET CCSPUT  t FTN 3.3B (OPT = LPC) PGSJR PAGE 3 DATE: 08/29/84 TIME: 2257 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : <  3030 (12336) 0011 5    VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < & IARRAY INTEGER 7FFF 1,2,11 &$ IBPOS INTEGER 7FFF 1,2,9$. IHOLD INTEGER 0012 7,8,11,12,19,20.( ILNG INTEGER 7FFF 1,2,7,10 (2 IPOS INTEGER 0013 8,9,11,14,17,20,22 2( K INTEGER 0010 2,5,10,18(& OARRAY INTEGER 7FFF 1,2,20 && OBPOS INTEGER 7FFF 1,2,17 &( OLNG INTEGER 7FFF 1,2,7,18 (( WKARR INTEGER 0000 2,5,12,19(2 WKPOS INTEGER 000F 2,7,12,13,16,19,21 2   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < $ CCSGET SUBROUTINE 002D 10,19$$ CCSPUT SUBROUTINE 0032 11,20$ Q8PKUP INTEGER.FN. 005C Q8PREP INTEGER.FN. 0059    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < " 10 0019 2,6"$ 20 0038 9,15 $$ 30 0050 17,23$ PGSJR 0056 1  t FTN 3.3B (OPT = LPC) PGSLST PAGE 1 DATE: 08/29/84 TIME: 2257 t^ 1 SUBROUTINE PGSLST C0100001^^ 1 1 /C01 F CCS CCS 3.0 SL-149C0100002^^ C C0100003^^ C CYBERCREDIT SYSTEM VERSION 3 C0100004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C0100005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C0100006^^ C C0100007^^ C PRINTS THE VALID DATA NAME LIST C0100008^^ C C0100009^^ 2 COMMON /CBLK1/UTIFIL,DELQM,RPTTBL,RPTPGM,RPTWKE,UTIRQB,DLQRQB, C0100010^^ 2 2TBLRQB,PGMRQB,WKERQB,OPBUF,Q2SAVE,Q3SORT,Q4LVLB,Q5SLCT,Q6NAME, C0100011^^ 2 3Q6TOT,Q6EPOS,Q7RPT,Q5ANS,TBL,HPGMN,UTREC,PGMKEY,TBLKEY,BIN,ISTAT, C0100012^^ 2 4HPKEY,RADDR,TBLREC,OPHLD,D1TYPE,D1LNG,LRPGWK,IHOLD2,PGMREC,IND, C0100013^^ 2 5PRCREC,ERRMSG,UTEMSG,ABTMSG,XYN,TC,CS,PRCWRK,PRCRQB,LU C0100014^^ 3 COMMON /CBLK1/ IMAXC,NLKEY,NNAME,NSKEY,NSLCT,NTFLDS,RPTWKP,WKPRQB C0100015^^ C C0100016^^ C FILE RETRIEVAL C0100017^^ 4 INTEGER UTIFIL(15),DELQM(15),RPTTBL(15),RPTPGM(15),RPTWKE(15), C0100018^^ 4 2 UTIRQB(24),DLQRQB(24),TBLRQB(24),PGMRQB(24),WKERQB(24), C0100019^^ 4 3 PRCWRK(15),PRCRQB(24),RPTWKP(15),WKPRQB(24) C0100020^^ C C0100021^^ C OPERATOR RESPONSES C0100022^^ 5 INTEGER OPBUF(32),Q2SAVE,Q3SORT(60),Q4LVLB(9),Q5SLCT(170), C0100023^^ 5 2 Q6NAME(51),Q6TOT(77),Q6EPOS(102),Q7RPT(15),Q5ANS C0100024^^ C C0100025^^ C MISCELLANEOUS C0100026^^ 6 INTEGER XYN,TC,CS(2),TBL(4),HPGMN(3),RPTG(2),UTREC(42),ISTAT, C0100027^^ 6 2 ZERO,PGMKEY(3),TBLKEY(3),COMMA,BIN,HPKEY(3),RADDR,TBLREC(42), C0100028^^ 6 3 OPHLD,D1TYPE,D1LNG(2),LRPGWK(42),IHOLD2(2),PGMREC(42),IND(3), C0100029^^ 6 4 PRCREC(42),ERRMSG(23),UTEMSG(26),ABTMSG(7) C0100030^^ C C0100031^^ 7 INTEGER HDR1(2),HDR2(2),HDR3(2),HEAD1(66),HEAD2(66),HEAD3(66), C0100032^^ 7 2 LISTH1(66),LISTH2(55),LISTH3(55),PGCNT,ITEMP(8), C0100033^^ 7 3 IBUF(66) C0100034^^ C C0100035^^ 8 DATA LISTH1 /'PGGEN ',21*$2020,'REPORT GENERATOR DATA NAME LIST ',C0100036^^ 8 2 26*$2020/ C0100037^^ 9 DATA LISTH2 /3*$2020,'STARTING',4*$2020,'DATA EDIT DEC ', C0100038^^ 9 2 21*$2020,'SUB SUB SUB SUB SUB'/ C0100039^^ 10 DATA LISTH3/' NAME POSITION LENGTH TYPE CODE POS ',5*$2020, C0100040^^ 10 2'DESCRIPTION ',9*$2020,' NAME1 NAME2 NAME3 NAME4 NAME5'/ C0100041^^ 11 DATA HDR1/'HDR1'/,HDR2/'HDR2'/,HDR3/'HDR3'/ C0100042^^ 12 DATA HEAD1/$0C, 54*$2020,'PAGE 01',7*$2020/,HEAD2/52*$2020, C0100043^^ 12 2 'DATE RUN MM/DD/YY',5*$2020/,HEAD3/66*$2020/ C0100044^^ C C0100045^^ 13 EXTERNAL AMONTO,ADAYTO,AYERTO,ASCBIN,BINASC C0100046^^ C C0100047^^ C READ UTIFIL TO GET STANDARD HEADING INFORMATION C0100048^^ C STANDARD HEADING 1 C0100049^^ 14 CALL READR(UTIRQB,UTREC,HDR1,ISTAT) C0100050^^ C CHECK FOR ERROR, IF NOT FOUND--CONTINUE C0100051^^ 15 IF(ISTAT.LT.0) GO TO 300 C0100052^^ 16 CALL CCSMVA(UTREC,5,40,HEAD1,3,40) C0100053^^ C STANDARD HEADING 2 C0100054^t FTN 3.3B (OPT = LPC) PGSLST PAGE 2 DATE: 08/29/84 TIME: 2257 t^ 17 CALL READR(UTIRQB,UTREC,HDR2,ISTAT) C0100055^^ C CHECK FOR ERROR, IF NOT FOUND--CONTINUE C0100056^^ 18 IF(ISTAT.LT.0) GO TO 300 C0100057^^ 19 DO 30 K=1,20 C0100058^^ 20 HEAD2(K) =UTREC(K+2) C0100059^^ 21 30 CONTINUE C0100060^^ C STANDARD HEADING 3 C0100061^^ 22 CALL READR(UTIRQB,UTREC,HDR3,ISTAT) C0100062^^ C CHECK FOR ERROR, IF NOT FOUND--CONTINUE C0100063^^ 23 IF(ISTAT.LT.0) GO TO 300 C0100064^^ 24 DO 40 K=1,20 C0100065^^ 25 HEAD3(K) =UTREC(K+2) C0100066^^ 26 40 CONTINUE C0100067^^ C SET UP RUN DATE AND INITIALIZE LINE AND PAGE COUNT C0100068^^ 27 LNCNT=58 C0100069^^ 28 PGCNT=0 C0100070^^ 29 HEAD2(58) =AND($FFFF,AMONTO) C0100071^^ 30 HEAD2(61) =AND($FFFF,AYERTO) C0100072^^ 31 IDAY=AND($FFFF,ADAYTO) C0100073^^ 32 IHOLD=$0000 C0100074^^ 33 CALL CCSGET(IDAY,1,IHOLD) C0100075^^ 34 CALL CCSPUT(IHOLD,118,HEAD2) C0100076^^ 35 CALL CCSPUT(IDAY,119,HEAD2) C0100077^^ 36 TBLKEY(1)=$0 C0100078^^ 37 TBLKEY(2)=$0 C0100079^^ 38 TBLKEY(3)=$0 C0100080^^ C READ RPTTBL FILE SEQUENTIALLY C0100081^^ 39 100 CALL GETS(TBLRQB,TBLREC,TBLKEY,ISTAT) C0100082^^ C CHECK FOR END OF FILE C0100083^^ 40 IF(AND(ISTAT,$8100).EQ.$8100) GO TO 400 C0100084^^ 41 IF(ISTAT.LT.0) GO TO 310 C0100085^^ C CHECK FOR DELETED RECORD C0100086^^ 42 IF (AND(TBLREC(40),$20FF).EQ.$2044) GO TO 100 C0100087^^ C CHECK LINE COUNT TO DETERMINE IF HEADING IS NECESSRYC0100088^^ 43 IF (LNCNT.LT.58) GO TO 200 C0100089^^ C HEADING ROUTINE C0100090^^ 44 PGCNT=PGCNT+1 C0100091^^ 45 CALL BINASC(PGCNT,IHOLD2) C0100092^^ 46 HEAD1(59)=IHOLD2(2) C0100093^^ 47 IFLAG=0 C0100094^^ 48 ASSIGN 120 TO ICOMP C0100095^^ 49 DO 110 K=1,66 C0100096^^ 50 IBUF(K)=HEAD1(K) C0100097^^ 51 110 CONTINUE C0100098^^ 52 115 LNCNT=LNCNT+1 C0100099^^ 53 CALL FWRITE(9,IBUF,132,ICOMP,IFLAG,ITEMP) C0100100^^ 54 CALL DISP C0100101^^ C STANDARD HEADING 2 C0100102^^ 55 120 ASSIGN 130 TO ICOMP C0100103^^ 56 DO 125 K=1,66 C0100104^^ 57 IBUF(K)=HEAD2(K) C0100105^^ 58 125 CONTINUE C0100106^^ 59 GO TO 115 C0100107^^ C STANDARD HEADING 3 C0100108^t FTN 3.3B (OPT = LPC) PGSLST PAGE 3 DATE: 08/29/84 TIME: 2257 t^ 60 130 ASSIGN 140 TO ICOMP C0100109^^ 61 DO 135 K=1,66 C0100110^^ 62 IBUF(K)=HEAD3(K) C0100111^^ 63 135 CONTINUE C0100112^^ 64 GO TO 115 C0100113^^ C REPORT HEADING 1 C0100114^^ 65 140 ASSIGN 150 TO ICOMP C0100115^^ 66 DO 145 K=1,66 C0100116^^ 67 IBUF(K)=LISTH1(K) C0100117^^ 68 145 CONTINUE C0100118^^ 69 GO TO 115 C0100119^^ C REPORT HEADING 2 C0100120^^ 70 150 ASSIGN 155 TO ICOMP C0100121^^ 71 CALL CCSBLK(IBUF,132) C0100122^^ 72 GO TO 115 C0100123^^ 73 155 ASSIGN 160 TO ICOMP C0100124^^ 74 DO 156 K=1,55 C0100125^^ 75 IBUF(K)=LISTH2(K) C0100126^^ 76 156 CONTINUE C0100127^^ 77 GO TO 115 C0100128^^ C REPORT HEADING 3 C0100129^^ 78 160 ASSIGN 165 TO ICOMP C0100130^^ 79 DO 161 K=1,55 C0100131^^ 80 IBUF(K)=LISTH3(K) C0100132^^ 81 161 CONTINUE C0100133^^ 82 GO TO 115 C0100134^^ 83 165 ASSIGN 170 TO ICOMP C0100135^^ 84 CALL CCSBLK(IBUF,132) C0100136^^ 85 GO TO 115 C0100137^^ 86 170 LNCNT=8 C0100138^^ C C0100139^^ C SET UP DETAIL REPORT LINE C0100140^^ C NAME C0100141^^ 87 200 IBUF(1)=TBLREC(1) C0100142^^ 88 IBUF(2)=TBLREC(2) C0100143^^ 89 IBUF(3)=TBLREC(3) C0100144^^ C STARTING POSITION C0100145^^ 90 IBUF(5)=TBLREC(4) C0100146^^ 91 IBUF(6)=TBLREC(5) C0100147^^ C DATA LENGTH C0100148^^ 92 IBUF(9) =TBLREC(6) C0100149^^ 93 IBUF(10)=TBLREC(7) C0100150^^ C DATA TYPE C0100151^^ 94 CALL CCSGET(TBLREC,15,IHOLD) C0100152^^ 95 CALL CCSPUT(IHOLD,24,IBUF) C0100153^^ C EDIT CODE C0100154^^ 96 CALL CCSGET(TBLREC,16,IHOLD) C0100155^^ 97 CALL CCSPUT(IHOLD,29,IBUF) C0100156^^ C DECIMAL POSITIONS C0100157^^ 98 CALL CCSGET(TBLREC,18,IHOLD) C0100158^^ 99 CALL CCSPUT(IHOLD,34,IBUF) C0100159^^ C CLASSIFIED CODE C0100160^^ 100 CALL CCSGET(TBLREC,17,IHOLD) C0100161^^ 101 CALL CCSPUT(IHOLD,41,IBUF) C0100162^t FTN 3.3B (OPT = LPC) PGSLST PAGE 4 DATE: 08/29/84 TIME: 2257 t^ C DESCRIPTION C0100163^^ 102 K1=24 C0100164^^ 103 K2=10 C0100165^^ 104 DO 250 K=1,15 C0100166^^ 105 IBUF(K1)=TBLREC(K2) C0100167^^ 106 K1=K1+1 C0100168^^ 107 K2=K2+1 C0100169^^ 108 250 CONTINUE C0100170^^ C SUB DATA NAMES C0100171^^ 109 K1=77 C0100172^^ 110 K2=49 C0100173^^ 111 DO 280 K=1,5 C0100174^^ 112 CALL CCSMVA(TBLREC,K2,6,IBUF,K1,6) C0100175^^ 113 K1=K1+7 C0100176^^ 114 K2=K2+6 C0100177^^ 115 280 CONTINUE C0100178^^ C WRITE DETAIL LINE C0100179^^ 116 ASSIGN 100 TO ICOMP C0100180^^ 117 GO TO 115 C0100181^^ C RETURN C0100182^^ 118 300 CALL FILERR(UTIFIL,13,ISTAT,LU) C0100183^^ 119 GO TO 400 C0100184^^ 120 310 CALL FILERR(RPTTBL,14,ISTAT,LU) C0100185^^ 121 400 RETURN C0100186^^ 122 END C0100187^t FTN 3.3B (OPT = LPC) PGSLST PAGE 5 DATE: 08/29/84 TIME: 2257 t COMMON  LABEL $0448 ( 1096)    PROGRAM LENGTH $037D ( 893)   EXTERNALS 2 AMONTO ADAYTO AYERTO BINASC READR CCSMVA CCSGET 2, CCSPUT GETS FWRITE DISP CCSBLK FILERR , t FTN 3.3B (OPT = LPC) PGSLST PAGE 6 DATE: 08/29/84 TIME: 2257 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < $ 8100 (-32511) 01D4 40,40$( FFFF (65535) 01CF 29,30,31 (V 0001 (1) 0000 19,24,33,36,44,49,52,56,61,66,74,79,87,104,106,107,111 V( 0003 (3) 01CC 16,38,89 (, 0005 (5) 01CA 16,90,91,111 ,* 0006 (6) 01E5 112,112,114*$ 0009 (9) 01D9 52,92$" 000D (13) 01E6 118"" 000E (14) 01E7 120"& 000F (15) 01DB 94,104 &" 0010 (16) 01DD 96 "" 0011 (17) 01E1 100"" 0012 (18) 01DF 98 "& 0018 (24) 01DC 95,102 &" 001D (29) 01DE 97 "" 0022 (34) 01E0 99 "( 0028 (40) 01CB 16,16,42 (" 0029 (41) 01E2 101"" 0076 (118) 01D2 34 "" 0077 (119) 01D3 35 "( 0084 (132) 01DA 53,71,84 (" 2044 (8260) 01D6 42 "" 20FF (8447) 01D5 42 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " ABTMSG INTEGER 03E8 D 1,6". AND INTR.FN. 7FFF 29,30,31,40,42 ." BIN INTEGER 0300 D 1,6"" CS INTEGER 03F1 D 1,6"" D1LNG INTEGER 0332 D 1,6"" D1TYPE INTEGER 0331 D 1,6"" DELQM INTEGER 000F D 1,4"" DLQRQB INTEGER 0063 D 1,4"" ERRMSG INTEGER 03B7 D 1,6"& HDR1 INTEGER 0003 6,11,14&& HDR2 INTEGER 0005 6,11,17&& HDR3 INTEGER 0007 6,11,22&, HEAD1 INTEGER 0009 6,12,16,46,50,6 HEAD2 INTEGER 004B 6,12,20,29,30,34,35,57 6* HEAD3 INTEGER 008D 6,12,25,62 *" HPGMN INTEGER 02CD D 1,6"t FTN 3.3B (OPT = LPC) PGSLST PAGE 7 DATE: 08/29/84 TIME: 2257 t" HPKEY INTEGER 0302 D 1,6"f IBUF INTEGER 0188 6,50,53,57,62,67,71,75,80,84,87,88,89,90,91,92,93,95,97,99,101,105,112 f> ICOMP INTEGER 01D8 47,53,55,60,65,70,73,78,83,116 >* IDAY INTEGER 01D0 30,31,33,35*( IFLAG INTEGER 01D7 46,47,53 (D IHOLD INTEGER 01D1 31,32,33,34,94,95,96,97,98,99,100,101D( IHOLD2 INTEGER 035E D 1,6,45,46( IMAXC INTEGER 041B D 1 " IND INTEGER 038A D 1,6"F ISTAT INTEGER 0301 D 1,6,14,15,17,18,22,23,39,40,41,118,120 F$ ITEMP INTEGER 0180 6,53 $V K INTEGER 01CD 18,20,24,25,49,50,56,57,61,62,66,67,74,75,79,80,104,111V: K1 INTEGER 01E3 101,102,105,106,109,112,113:: K2 INTEGER 01E4 102,103,105,107,110,112,114:& LISTH1 INTEGER 00CF 6,8,67 && LISTH2 INTEGER 0111 6,9,75 && LISTH3 INTEGER 0148 6,10,80&. LNCNT INTEGER 01CE 26,27,43,52,86 ." LRPGWK INTEGER 0334 D 1,6"( LU INTEGER 041A D 1,118,120(& LISTH3 INTEGER 0148 6,10,80&. LNCNT INTEGER 01CE 26,27,43,52,86 ." LRPGWK INTEGER 0334 D 1,6"( LU INTEGER 041A D 1,118,120( NLKEY INTEGER 041C D 1 NNAME INTEGER 041D D 1 NSKEY INTEGER 041E D 1 NSLCT INTEGER 041F D 1 NTFLDS INTEGER 0420 D 1 " OPBUF INTEGER 00C3 D 1,5"" OPHLD INTEGER 0330 D 1,6"* PGCNT INTEGER 017F 6,28,44,45 *" PGMKEY INTEGER 02FA D 1,6"" PGMREC INTEGER 0360 D 1,6"" PGMRQB INTEGER 0093 D 1,4"" PRCREC INTEGER 038D D 1,6"" PRCRQB INTEGER 0402 D 1,4"" PRCWRK INTEGER 03F3 D 1,4"" Q2SAVE INTEGER 00E3 D 1,5"" Q3SORT INTEGER 00E4 D 1,5"" Q4LVLB INTEGER 0120 D 1,5"" Q5ANS INTEGER 02C8 D 1,5"" Q5SLCT INTEGER 0129 D 1,5"" Q6EPOS INTEGER 0253 D 1,5"" Q6NAME INTEGER 01D3 D 1,5"" Q6TOT INTEGER 0206 D 1,5"" Q7RPT INTEGER 02B9 D 1,5"" RADDR INTEGER 0305 D 1,6" RPTG INTEGER 0001 6 " RPTPGM INTEGER 002D D 1,4"& RPTTBL INTEGER 001E D 1,4,120&" RPTWKE INTEGER 003C D 1,4"" RPTWKP INTEGER 0421 D 1,4"" TBL INTEGER 02C9 D 1,6". TBLKEY INTEGER 02FD D 1,6,36,37,38,39.R TBLREC INTEGER 0306 D 1,6,39,42,87,88,89,90,91,92,93,94,96,98,100,105,112R& TBLRQB INTEGER 007B D 1,4,39 &" TC INTEGER 03F0 D 1,6"t FTN 3.3B (OPT = LPC) PGSLST PAGE 8 DATE: 08/29/84 TIME: 2257 t" UTEMSG INTEGER 03CE D 1,6"& UTIFIL INTEGER 0000 D 1,4,118&, UTIRQB INTEGER 004B D 1,4,14,17,22 ,4 UTREC INTEGER 02D0 D 1,6,14,16,17,20,22,254" WKERQB INTEGER 00AB D 1,4"" WKPRQB INTEGER 0430 D 1,4"" XYN INTEGER 03EF D 1,6"   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < $ BINASC SUBROUTINE 0273 12,45$$ CCSBLK SUBROUTINE 02CA 70,84$. CCSGET SUBROUTINE 0313 32,94,96,98,100.& CCSMVA SUBROUTINE 0351 15,112 &2 CCSPUT SUBROUTINE 0318 33,35,95,97,99,101 2" DISP SUBROUTINE 0298 53 "& FILERR SUBROUTINE 036A 118,120&" FWRITE SUBROUTINE 0290 52 "" GETS SUBROUTINE 0252 38 "( READR SUBROUTINE 01E9 12,17,22 (   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 30 020D 18,21$$ 40 0222 23,26$( 100 0251 38,42,116($ 110 0289 47,51$: 115 028E 51,59,64,69,72,77,82,85,117:$ 120 0299 47,55$$ 125 02A2 55,58$$ 130 02A8 55,60$$ 135 02B1 60,63$$ 140 02B7 60,65$$ 145 02C0 65,68$$ 150 02C6 65,70$$ 155 02CE 70,73$$ 156 02D7 73,76$$ 160 02DD 73,78$$ 161 02E6 78,81$$ 165 02EC 78,83$$ 170 02F3 83,86$$ 200 02F6 43,87$& 250 0345 103,108&& 280 035E 110,115&, 300 0369 15,18,23,118 ,& 310 0370 41,120 &t FTN 3.3B (OPT = LPC) PGSLST PAGE 9 DATE: 08/29/84 TIME: 2257 t* 400 0375 40,119,121 * PGSLST 0378 1  t FTN 3.3B (OPT = LPC) PHDEL1 PAGE 1 DATE: 08/29/84 TIME: 2258 t^ 1 PROGRAM PHDEL1 C0200001^^ 1 1 /C02 F CCS CCS 3.0 &LA SL-149********^^ C C0200003^^ C CYBERCREDIT SYSTEM VERSION 3 C0200004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C0200005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C0200006^  ^ C THIS PROGRAM SEQUENTIALLY PROCESSES THE TAPEARC FILE LOOKING C0200014^^ C FOR ANY RECORD THAT HAS BEEN INACTIVE FOR GREATER THAN XX C0200015^^ C MONTHS. WHEN AN ACCOUNT HAS BEEN FOUND THAT RECORD IS C0200016^^ C DELETED. THIS PROGRAM IS USED WHEN THE FILE MUST BE REDUCED C0200017^^ C IN RECORD COUNT DUE TO STORAGE PROBLEMS. C0200018^ ^ 2 INTEGER REQBUF(24),RECBUF(23),IDATA(15),USER(4),HD(20,3),DT(3) C0200020^^ 3 INTEGER UTBUF(24),UTREC(40),UDATA(15),UKEY(2),MNTH(2),KEY(8) C0200021^ ^ 4 INTEGER IDAT(4) ********^ ^ 5 DATA REQBUF / 24*0 / C0200025^^ 6 DATA IDAT /'TAPEARC '/ ********^^ 7 DATA IDATA /'LATAPARC',8*$2020, 1, 1, -1 / ********^^ 8 DATA UDATA /'LAUTIFIL',8*$2020, 1, 1, 1 / ********^^ 9 DATA UTBUF / 24*0 / C0200027^^ 10 DATA UKEY / 'TMTH' /,KEY / 8*0 / C0200028^ ^ C THE FOLLOWING IS THE NUMBER OF MONTHS FOR REMOVAL C0200030^^ 11 DATA MNTH / $3030,$3030 / C0200031^ ^ 12 EXTERNAL MONTO,YERTO C0200033^ ^ C ACCEPT LOG ON FROM ITOS C0200035^^ 13 CALL PGMIN(USER,LU,MODE,NPORT) C0200036^^ 14 CALL CCSCST(UDATA,1,2,USER,1,8,ICM) ********^^ 15 IF(ICM.EQ.0) GO TO 5 ********^^ 16 CALL CCSMVA(UDATA,3,6,UDATA,1,8) ********^^ 17 CALL CCSMVA(IDAT ,1,8,IDATA,1,8) ********^^ 18 5 CONTINUE ********^^ C PICK UP SYSTEM DATE AND CONVERT C0200037^^ 19 IMTH=AND(MONTO,$FFFF) C0200038^^ 20 IYR=AND(YERTO,$FFFF) C0200039^^ C LOCATE THE REPORT HEADING INFORMATION C0200040^^ 21 CALL UTHEAD( HD, DT ) C0200041^^ C PRINT THE REPORT HEADING C0200042^^ 22 WRITE (12,1000)(HD(I,1),I=1,20),(HD(I,2),I=1,20),DT,(HD(I,3), C0200043^^ 22 1 I=1,20) C0200044^ ^ C OPEN UTIFIL FOR USE C0200046^^ 23 CALL OPENFL(UTBUF,UDATA,ISTAT) C0200047^^ 24 ITYPE=3 C0200048^^ 25 IF (ISTAT.LT.0) GO TO 910 C0200049^^ C_ OPEN TAPEARC FOR USE C0200050^^ 26 CALL OPENFL(REQBUF,IDATA,ISTAT) C0200051^^ 27 ITYPE=3 C0200052^t FTN 3.3B (OPT = LPC) PHDEL1 PAGE 2 DATE: 08/29/84 TIME: 2258 t^ 28 IF (ISTAT.LT.0) GO TO 900 C0200053^ ^ C GET THE UTIFIL RECORD C0200055^^ 29 CALL READR (UTBUF,UTREC,UKEY,ISTAT) C0200056^^ 30 ITYPE=13 C0200057^^ 31 IF (AND(ISTAT,$100).EQ.$100) GO TO 90 C0200058^^ 32 IF (ISTAT.LT.0) GO TO 910 C0200059^^ 33 90 IF (AND(ISTAT,$200).EQ.$200) GO TO 800 C0200060^^ 34 MTHCHK=AND(UTREC(3),$F00)/$100*100+AND(UTREC(3),$F)*10+ C0200061^^ 34 1 AND(UTREC(4),$F00)/$100 C0200062^ ^ C GET NEXT RECORD C0200064^^ 35 100 CALL GETS(REQBUF,RECBUF,KEY,ISTAT) C0200065^^ 36 ITYPE=14 C0200066^^ C END OF FILE? C0200067^^ 37 IF (AND(ISTAT,$100).EQ.$100) GO TO 950 C0200068^^ C ERROR? C0200069^^ 38 IF (ISTAT.LT.0) GO TO 900 C0200070^^ C CHECK RECORD AGE C0200071^^ 39 IRM=AND(RECBUF(9),$F00)/$100*10+AND(RECBUF(9),$F) C0200072^^ 40 IRY=AND(RECBUF(11),$F00)/$100*10+AND(RECBUF(11),$F) C0200073^^ 41 ITM=IMTH-IRM C0200074^^ 42 ITY=IYR-IRY C0200075^^ 43 ITM=ITM+12*ITY C0200076^^ 44 IF (ITM.LT.MTHCHK) GO TO 100 C0200077^^ C RECORD SHOULD BE REMOVED C0200078^^ 45 WRITE (12,1100)RECBUF C0200079^^ 46 CALL DELREC(REQBUF,RECBUF,ISTAT) C0200080^^ 47 ITYPE=16 C0200081^^ 48 IF (ISTAT.LT.0) GO TO 900 C0200082^^ 49 GO TO 100 C0200083^  ^ C FILE ERROR - REPORT AND EXIT C0200085^^ 50 800 WRITE (4,8000) C0200086^^ 51 WRITE (12,8000) C0200087^^ 52 GO TO 950 C0200088^^ 53 900 CALL FILERR (IDATA,ITYPE,ISTAT,LU) C0200089^^ 54 GO TO 950 C0200090^^ 55 910 CALL FILERR (UDATA,ITYPE,ISTAT,LU) C0200091^^ 56 950 WRITE (12,1200) C0200092^^ 57 CALL CLOSFL(REQBUF,ISTAT) C0200093^^ 58 CALL PGMOUT C0200094^^ 59 1000 FORMAT (1H1,20A2,6X,'ACCOUNTS BEING PURGED FROM THE TAPEARC ', C0200095^^ 59 A 'FILE',/,1X,20A2,14X,'RUN DATE: ',A2,'/',A2,'/',A2,/, C0200096^^ 59 B 1X,20A2,//,35X,'ACCOUNT NUMBER',10X,'ARCHIVE TAPE DATES',/) C0200097^^ 60 1100 FORMAT ( 34X,8A2,2X,A2,'/',A2,'/',A2,2X,A2,'/',A2,'/',A2,2X, C0200098^^ 60 1 A2,'/',A2,'/',A2,2X,A2,'/',A2,'/',A2,2X,A2,'/',A2,'/',A2) C0200099^^ 61 1200 FORMAT (//,52X,'*** END OF REPORT ***') C0200100^^ 62 8000 FORMAT (/,' ERROR WHEN UTIFIL RECORD NO FOUND') C0200101^^ 63 END C0200102^t FTN 3.3B (OPT = LPC) PHDEL1 PAGE 3 DATE: 08/29/84 TIME: 2258 t  PROGRAM LENGTH $02E9 ( 745)   EXTERNALS 2 Q8STP Q8QINI Q8QX Q8QEND MONTO YERTO PGMIN 22 CCSCST CCSMVA UTHEAD OPENFL READR GETS DELREC 2 FILERR CLOSFL PGMOUT  t FTN 3.3B (OPT = LPC) PHDEL1 PAGE 4 DATE: 08/29/84 TIME: 2258 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < $ FFFF (65535) 00ED 19,20$. 0001 (1) 0002 7,8,14,16,17,22.$ 0002 (2) 00E7 14,22$. 0003 (3) 00EA 16,22,24,27,34 ." 0006 (6) 00EB 16 "( 0008 (8) 00E8 14,16,17 (( 000A (10) 00F8 34,39,40 (( 000F (15) 00F7 34,39,40 (( 0064 (100) 00F6 34,44,49 (0 0100 (256) 00F2 31,31,34,37,39,400$ 0200 (512) 00F3 33,33$* 0F00 (3840) 00F5 34,34,39,40*   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < 6 AND INTR.FN. 7FFF 19,20,31,33,34,37,39,406& DT INTEGER 0082 1,21,22&& HD INTEGER 0046 1,21,22&$ I INTEGER 00EF 21,22$$ ICM INTEGER 00E9 14,15$& IDAT INTEGER 00E0 1,6,17 &, IDATA INTEGER 0033 1,7,17,26,53 ,( IMTH INTEGER 00EC 18,19,41 (( IRM INTEGER 00F9 38,39,41 (( IRY INTEGER 00FA 39,40,42 (N ISTAT INTEGER 00F0 23,25,26,28,29,31,32,33,35,37,38,46,48,53,55,57N* ITM INTEGER 00FB 40,41,43,44*( ITY INTEGER 00FC 41,42,43 (6 ITYPE INTEGER 00F1 23,24,27,30,36,47,53,556( IYR INTEGER 00EE 19,20,42 (& KEY INTEGER 00D8 1,10,35&( LU INTEGER 00E4 13,53,55 ($ MNTH INTEGER 00D6 1,11 $" MODE INTEGER 00E5 13 "( MTHCHK INTEGER 00F4 33,34,44 (" NPORT INTEGER 00E6 13 "$ Q8QX1 INTEGER 0003 22,45$0 RECBUF INTEGER 001C 1,35,39,40,45,46 0. REQBUF INTEGER 0004 1,5,26,35,46,57.. UDATA INTEGER 00C5 1,8,14,16,23,55.& UKEY INTEGER 00D4 1,10,29&& USER INTEGER 0042 1,13,14&t FTN 3.3B (OPT = LPC) PHDEL1 PAGE 5 DATE: 08/29/84 TIME: 2258 t( UTBUF INTEGER 0085 1,9,23,29(& UTREC INTEGER 009D 1,29,34&   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " CCSCST SUBROUTINE 0104 13 "$ CCSMVA SUBROUTINE 0110 15,17$" CLOSFL SUBROUTINE 022B 56 "" DELREC SUBROUTINE 0200 45 "$ FILERR SUBROUTINE 021A 53,55$" GETS SUBROUTINE 01B0 34 "$ OPENFL SUBROUTINE 0169 22,26$" PGMIN SUBROUTINE 00FE 11 "" PGMOUT SUBROUTINE 022F 57 " Q8QEND INTEGER.FN. 01FE Q8QINI INTEGER.FN. 01E9 $ Q8QX SUBROUTINE 01F6 22,45$ Q8STP INTEGER.FN. 02E8 " READR SUBROUTINE 0182 28 "" UTHEAD SUBROUTINE 0127 20 "   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 5 011E 15,18$$ 90 0193 31,33$( 100 01AF 34,44,49 ($ 800 020E 33,50$* 900 0219 28,38,48,53*( 910 0220 25,32,55 (* 950 0225 37,52,54,56*$ 1000 0231 21,59$$ 1100 0288 45,60$$ 1200 02C0 56,61$( 8000 02D2 50,51,62 ( PHDEL1 0000 1  t FTN 3.3B (OPT = LPC) PHDEL2 PAGE 1 DATE: 08/29/84 TIME: 2259 t^ 1 PROGRAM PHDEL2 C0300001^^ 1 1 /C03 F CCS CCS 3.0 &LA SL-149********^^ C C0300003^^ C CYBERCREDIT SYSTEM VERSION 3 C0300004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C0300005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C0300006^  ^ C THIS PROGRAM SEQUENTIALLY PROCESSES THE SUMHIST FILE LOOKING C0300014^^ C FOR ANY RECORD THAT HAS BEEN INACTIVE FOR GREATER THAN XX C0300015^^ C MONTHS. WHEN AN ACCOUNT HAS BEEN FOUND THAT RECORD IS C0300016^^ C DELETED. THIS PROGRAM IS USED WHEN THE FILE MUST BE REDUCED C0300017^^ C IN RECORD COUNT DUE TO STORAGE PROBLEMS. C0300018^ ^ 2 INTEGER REQBUF(24),RECBUF(333),IDATA(15),USER(4) C0300020^^ 3 INTEGER UTBUF(24),UTREC(40),UDATA(15),UKEY(2),MNTH(2) C0300021^^ 4 INTEGER RMTHCK,SMTHCK,WMTHCK,STC,ERSTC(7),MSG(7) C0300022^^ 5 INTEGER HD(20,3),DT(3),KEY(8) C0300023^ ^ 6 INTEGER IDAT(4) ********^ ^ 7 DATA REQBUF / 24*0 / C0300027^^ 8 DATA IDAT /'SUMHIST '/ ********^^ 9 DATA IDATA /'LASUMHST',8*$2020, 1, 1, -1 / ********^^ 10 DATA UDATA /'LAUTIFIL',8*$2020, 1, 1, 1 / ********^^ 11 DATA UTBUF / 24*0 /,KEY / 8*0 / C0300029^^ 12 DATA UKEY / 'SMTH' / C0300030^^ 13 DATA IR,IS,IW / 'R ','S ','W ' / C0300031^^ 14 DATA ERSTC / 'INVALID STATUS' / C0300032^^ 15 DATA MSG / 7*$2020 / C0300033^ ^ C THE FOLLOWING IS THE NUMBER OF MONTHS FOR REMOVAL C0300035^^ 16 DATA MNTH / $3030,$3030 / C0300036^ ^ 17 EXTERNAL MONTO,YERTO C0300038^ ^ C ACCEPT LOG ON FROM ITOS C0300040^^ 18 CALL PGMIN(USER,LU,MODE,NPORT) C0300041^^ 19 CALL CCSCST(UDATA,1,2,USER,1,8,ICM) ********^^ 20 IF(ICM.EQ.0) GO TO 5 ********^^ 21 CALL CCSMVA(UDATA,3,6,UDATA,1,8) ********^^ 22 CALL CCSMVA(IDAT ,1,8,IDATA,1,8) ********^^ 23 5 CONTINUE ********^^ C PICK UP SYSTEM DATE AND CONVERT C0300042^^ 24 IMTH=AND(MONTO,$FFFF) C0300043^^ 25 IYR=AND(YERTO,$FFFF) C0300044^^ C LOCATE THE REPORT HEADING INFORMATION C0300045^^ 26 CALL UTHEAD( HD, DT ) C0300046^ ^ C OPEN UTIFIL FOR USE C0300048^^ 27 CALL OPENFL(UTBUF,UDATA,ISTAT) C0300049^^ 28 ITYPE=3 C0300050^^ 29 IF (ISTAT.LT.0) GO TO 910 C0300051^^ C_ OPEN SUMHIST FOR USE C0300052^t FTN 3.3B (OPT = LPC) PHDEL2 PAGE 2 DATE: 08/29/84 TIME: 2259 t^ 30 CALL OPENFL(REQBUF,IDATA,ISTAT) C0300053^^ 31 ITYPE=3 C0300054^^ 32 IF (ISTAT.LT.0) GO TO 900 C0300055^ ^ C GET THE UTIFIL RECORD C0300057^^ 33 CALL READR (UTBUF,UTREC,UKEY,ISTAT) C0300058^^ 34 ITYPE=13 C0300059^^ 35 IF (AND(ISTAT,$100).EQ.$100) GO TO 90 C0300060^^ 36 IF (ISTAT.LT.0) GO TO 910 C0300061^^ 37 90 IF (AND(ISTAT,$200).EQ.$200) GO TO 800 C0300062^^ 38 RMTHCK=AND(UTREC(3),$F)*100+AND(UTREC(4),$F00)/$100*10+ C0300063^^ 38 1 AND(UTREC(4),$F) C0300064^^ 39 SMTHCK=AND(UTREC(6),$F00)/$100*100+AND(UTREC(6),$F)*10+ C0300065^^ 39 1 AND(UTREC(7),$F00)/$100 C0300066^^ 40 WMTHCK=AND(UTREC(8),$F)*100+AND(UTREC(9),$F00)/$100*10+ C0300067^^ 40 1 AND(UTREC(9),$F) C0300068^^ C C0300069^^ C ** PRINT HEADINGS C0300070^^ 41 N= 29 C0300071^^ 42 100 IF(N.LT.28) GOTO 200 C0300072^^ 43 WRITE (12,1000)(HD(I,1),I=1,20),(HD(I,2),I=1,20), C0300073^^ 43 1 DT,(HD(I,3),I=1,20) C0300074^^ 44 N = 1 C0300075^ ^ C GET NEXT RECORD C0300077^^ 45 200 CALL GETS(REQBUF,RECBUF,KEY,ISTAT) C0300078^^ 46 ITYPE=14 C0300079^^ C END OF FILE? C0300080^^ 47 IF (AND(ISTAT,$100).EQ.$100) GO TO 950 C0300081^^ C ERROR? C0300082^^ 48 IF (ISTAT.LT.0) GO TO 900 C0300083^^ C CHECK STATUS C0300084^^ 49 CALL CCSMVA (RECBUF(12),1,1,STC,1,2) C0300085^^ 50 MTHCHK= -1 C0300086^^ 51 IF (STC.EQ.IR) MTHCHK=RMTHCK C0300087^^ 52 IF (STC.EQ.IS) MTHCHK=SMTHCK C0300088^^ 53 IF (STC.EQ.IW) MTHCHK=WMTHCK C0300089^^ 54 IF (MTHCHK.EQ.-1) GO TO 700 C0300090^^ C CHECK RECORD AGE C0300091^^ 55 IRM=AND(RECBUF(9),$F00)/$100*10+AND(RECBUF(9),$F) C0300092^^ 56 IRY=AND(RECBUF(11),$F00)/$100*10+AND(RECBUF(11),$F) C0300093^^ 57 ITM=IMTH-IRM C0300094^^ 58 ITY=IYR-IRY C0300095^^ 59 ITM=ITM+12*ITY C0300096^^ 60 IF (ITM.LT.MTHCHK) GO TO 100 C0300097^^ C RECORD SHOULD BE REMOVED C0300098^^ 61 WRITE (12,1100)(RECBUF(I),I=1,11),RECBUF(12), C0300099^^ 61 1 (RECBUF(I),I=12,27),(MSG(I),I=1,7) C0300100^^ 62 N = N + 1 C0300101^^ 63 CALL DELREC(REQBUF,RECBUF,ISTAT) C0300102^^ 64 ITYPE=16 C0300103^^ 65 IF (ISTAT.LT.0) GO TO 900 C0300104^^ 66 GO TO 100 C0300105^^ 67 700 CALL CCSMVA (ERSTC,1,14,MSG,1,14) C0300106^t FTN 3.3B (OPT = LPC) PHDEL2 PAGE 3 DATE: 08/29/84 TIME: 2259 t^ 68 WRITE (12,1100) (RECBUF(I),I=1,11),RECBUF(12), C0300107^^ 68 1 (RECBUF(I),I=12,27),(MSG(I),I=1,7) C0300108^^ 69 N = N + 1 C0300109^^ 70 CALL CCSBLK (MSG,14) C0300110^^ 71 GO TO 100 C0300111^  ^ C FILE ERROR - REPORT AND EXIT C0300113^^ 72 800 WRITE (4,8000) C0300114^^ 73 WRITE (12,8000) C0300115^^ 74 GO TO 950 C0300116^^ 75 900 CALL FILERR (IDATA,ITYPE,ISTAT,LU) C0300117^^ 76 GO TO 950 C0300118^^ 77 910 CALL FILERR (UDATA,ITYPE,ISTAT,LU) C0300119^^ 78 950 WRITE (12,1200) C0300120^^ 79 CALL CLOSFL(REQBUF,ISTAT) C0300121^^ 80 CALL PGMOUT C0300122^^ 81 1000 FORMAT (1H1,20A2,12X,'ACCOUNTS BEING PURGED FROM THE SUMHIST ', C0300123^^ 81 A 'FILE',/,1X,20A2,20X,'RUN DATE: ',A2,'/',A2,'/',A2,/,1X,20A2, C0300124^^ 81 1 //,20X,'ACCOUNT NUMBER',5X,'INACTIVE DATE',5X,'STATUS',15X, C0300125^^ 81 2 'BORROWERS NAME',/) C0300126^^ 82 1100 FORMAT(20X,8A2,7X,A2,'/',A2,'/',A2,9X,A1,10X,R1,14A2,A1,10X,7A2) C0300127^^ 83 1200 FORMAT (//,54X,'*** END OF REPORT ***') C0300128^^ 84 8000 FORMAT (/,' ERROR WHEN UTIFIL RECORD NO FOUND') C0300129^^ 85 END C0300130^t FTN 3.3B (OPT = LPC) PHDEL2 PAGE 4 DATE: 08/29/84 TIME: 2259 t  PROGRAM LENGTH $04EA ( 1258)   EXTERNALS 2 Q8STP Q8QINI Q8QX Q8QEND MONTO YERTO PGMIN 22 CCSCST CCSMVA UTHEAD OPENFL READR GETS DELREC 2 CCSBLK FILERR CLOSFL PGMOUT  t FTN 3.3B (OPT = LPC) PHDEL2 PAGE 5 DATE: 08/29/84 TIME: 2259 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < $ FFFF (65535) 0238 24,25$J 0001 (1) 0002 9,10,19,21,22,43,44,49,50,54,61,62,67,68,69J( 0002 (2) 0232 19,43,49 (. 0003 (3) 0235 21,28,31,38,43 .$ 0006 (6) 0236 21,39$* 0008 (8) 0233 19,21,22,40*. 000A (10) 0241 38,39,40,55,56 .( 000E (14) 0244 46,67,70 (0 000F (15) 023E 38,38,39,40,55,5600 0064 (100) 023F 38,39,40,60,66,7106 0100 (256) 023C 35,35,38,39,40,47,55,566$ 0200 (512) 023D 37,37$. 0F00 (3840) 0240 38,39,40,55,56 .   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < < AND INTR.FN. 7FFF 24,25,35,37,38,39,40,47,55,56<& DT INTEGER 021D 1,26,43&& ERSTC INTEGER 01D3 1,14,67&& HD INTEGER 01E1 1,26,43&* I INTEGER 0243 42,43,61,68*$ ICM INTEGER 0234 19,20$& IDAT INTEGER 0228 1,8,22 &, IDATA INTEGER 0169 1,9,22,30,75 ,( IMTH INTEGER 0237 23,24,57 ($ IR INTEGER 022C 12,51$( IRM INTEGER 0246 54,55,57 (( IRY INTEGER 0247 55,56,58 ($ IS INTEGER 022D 12,52$N ISTAT INTEGER 023A 27,29,30,32,33,35,36,37,45,47,48,63,65,75,77,79N* ITM INTEGER 0248 56,57,59,60*( ITY INTEGER 0249 57,58,59 (6 ITYPE INTEGER 023B 27,28,31,34,46,64,75,776$ IW INTEGER 022E 12,53$( IYR INTEGER 0239 24,25,58 (& KEY INTEGER 0220 1,11,45&( LU INTEGER 022F 18,75,77 ($ MNTH INTEGER 01CD 1,16 $" MODE INTEGER 0230 18 "0 MSG INTEGER 01DA 1,15,61,67,68,70 04 MTHCHK INTEGER 0245 49,50,51,52,53,54,60 40 N INTEGER 0242 40,41,42,44,62,690t FTN 3.3B (OPT = LPC) PHDEL2 PAGE 6 DATE: 08/29/84 TIME: 2259 t" NPORT INTEGER 0231 18 "" Q8QX1 INTEGER 0003 43 "6 RECBUF INTEGER 001C 1,45,49,55,56,61,63,68 6. REQBUF INTEGER 0004 1,7,30,45,63,79.& RMTHCK INTEGER 01CF 1,38,51&& SMTHCK INTEGER 01D0 1,39,52&, STC INTEGER 01D2 1,49,51,52,53,0 UDATA INTEGER 01BC 1,10,19,21,27,77 0& UKEY INTEGER 01CB 1,12,33&& USER INTEGER 0178 1,18,19&* UTBUF INTEGER 017C 1,11,27,33 *, UTREC INTEGER 0194 1,33,38,39,40,& WMTHCK INTEGER 01D1 1,40,53&   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " CCSBLK SUBROUTINE 0412 69 "" CCSCST SUBROUTINE 0251 18 "* CCSMVA SUBROUTINE 03DA 20,22,49,67*" CLOSFL SUBROUTINE 0435 78 "" DELREC SUBROUTINE 03C9 62 "$ FILERR SUBROUTINE 0424 75,77$" GETS SUBROUTINE 032A 45 "$ OPENFL SUBROUTINE 0278 26,30$" PGMIN SUBROUTINE 024B 16 "" PGMOUT SUBROUTINE 0439 79 " Q8QEND INTEGER.FN. 03C5 Q8QINI INTEGER.FN. 0418 ( Q8QX SUBROUTINE 03A1 43,61,68 ( Q8STP INTEGER.FN. 04E9 " READR SUBROUTINE 028F 32 "" UTHEAD SUBROUTINE 0274 25 "   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 5 026B 20,23$$ 90 029F 35,37$* 100 02E4 41,60,66,71*$ 200 0329 42,45$$ 700 03D9 54,67$$ 800 0417 37,72$* 900 0423 32,48,65,75*( 910 042A 29,36,77 (* 950 042F 47,74,76,78*$ 1000 043B 42,81$( 1100 04A1 61,68,82 (t FTN 3.3B (OPT = LPC) PHDEL2 PAGE 7 DATE: 08/29/84 TIME: 2259 t$ 1200 04C0 78,83$( 8000 04D3 72,73,84 ( PHDEL2 0000 1  t FTN 3.3B (OPT = LPC) PMEDT1 PAGE 1 DATE: 08/29/84 TIME: 2259 t^ 1 SUBROUTINE PMEDT1 (INPUT, LPN, IOP, ICON, CONLIT, PA, PB, IND) C0500001^^ 1 1 /C05 F CCS CCS 3.0 SL-149C0500002^^ C C0500003^^ C CYBERCREDIT SYSTEM VERSION 3 C0500004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C0500005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C0500006^^ C C0500007^^ C ROUTINE EDITS PARAMETER INPUT C0500008^^ 2 INTEGER INPUT(1), CONLIT(1), PA(1), PB(1) C0500009^^ 3 INTEGER GOODOP (2,7), GOODCN(3,2) C0500010^^ 4 DATA GOODOP /'NULL.EQ..LE..GT..NE..WE..OS.'/ C0500011^^ 5 DATA GOODCN /'.AND. .OR. '/ C0500012^^ 6 INTEGER COMMA C0500013^^ 7 DATA COMMA /$002C/ C0500014^^ 8 DO 1 I = 1, 3 C0500015^^ 9 PA(I) = $2020 C0500016^^ 10 PB(I) = $2020 C0500017^^ 11 1 CONLIT(I) = $2020 C0500018^^ 12 IND = 0 C0500019^^ 13 ICON = 0 C0500020^    ^ C EDIT OPERATOR C0500022^^ 14 DO 100 I = 1, 7 C0500023^^ 15 IF ( INPUT(1) .NE. GOODOP(1,I)) GO TO 100 C0500024^^ 16 IF (INPUT(2) .EQ. GOODOP(2,I)) GO TO 200 C0500025^^ 17 100 CONTINUE C0500026^^ C ILLEGAL OPERATOR C0500027^^ 18 IND = $8001 C0500028^^ 19 RETURN C0500029^^ C GOOD OPERATOR, SET IOP AND CONTINUE C0500030^^ 20 200 IOP = I -1 C0500031^^ C RETURN IF NULL OPERATOR C0500032^^ 21 IF (IOP .EQ. 0) RETURN C0500033^    ^ C CCSGET AND EDIT PARAMETER VALUES C0500035^^ C ERROR IF 5TH BYTE NOT COMMA C0500036^^ 22 CALL CCSGET ( INPUT, 5, I) C0500037^^ 23 IF ( I .EQ. COMMA) GO TO 220 C0500038^^ C RETURN WITH SYNTAX ERROR C0500039^^ 24 IND = $8004 C0500040^^ 25 RETURN C0500041^^ C CCSGET PA C0500042^^ 26 220 DO 230 J = 6, 11 C0500043^^ 27 CALL CCSGET (INPUT, J, I) C0500044^^ 28 230 CALL CCSPUT ( I , J-5, PA) C0500045^^ C RETURN IF NO PB AND LAST PARAMETER C0500046^^ 29 IF (IOP .LT. 5 .AND. LPN .EQ. 1) RETURN C0500047^^ C ERROR IF 12TH BYTE NOT COMMA C0500048^t FTN 3.3B (OPT = LPC) PMEDT1 PAGE 2 DATE: 08/29/84 TIME: 2259 t^ 30 CALL CCSGET (INPUT, 12, I) C0500049^^ 31 IF ( I .EQ. COMMA) GO TO 240 C0500050^^ C RETURN WITH SYNTAX ERROR C0500051^^ 32 IND = $8004 C0500052^^ 33 RETURN C0500053^^ C IS A PB PRESENT C0500054^^ 34 240 LCON = 13 C0500055^^ 35 IF ( IOP .LT. 5) GO TO 300 C0500056^^ C YES CCSGET PB C0500057^^ 36 DO 250 J = 13, 18 C0500058^^ 37 CALL CCSGET (INPUT, J, I) C0500059^^ 38 250 CALL CCSPUT ( I, J-12, PB) C0500060^^ C CHECK RANGE IN CORRECT DIRECTION C0500061^^ 39 IF (PA(1) .LT. PB(1) ) GO TO 270 C0500062^^ 40 IF ( PA(1) .EQ. PB(1) .AND. C0500063^^ 40 1 PA(2) .LT. PB(2) ) GO TO 270 C0500064^^ 41 IF ( PA(1) .EQ. PB(1) .AND. C0500065^^ 41 1 PA(2) .EQ. PB(2) .AND. C0500066^^ 41 2 PA(3) .LT. PB(3) ) GO TO 270 C0500067^^ C RETURN WITH RANGE ERROR C0500068^^ 42 IND = $8003 C0500069^^ 43 RETURN C0500070^^ C RETURN IF LAST PARAMETER C0500071^^ 44 270 IF ( LPN .EQ. 1) RETURN C0500072^^ C CHECK POSITION 19 FOR COMMA C0500073^^ 45 CALL CCSGET (INPUT, 19, I) C0500074^^ 46 IF (I .EQ. COMMA ) GO TO 290 C0500075^^ C RETURN WITH ERROR, BAD SYNTAX C0500076^^ 47 IND = $8004 C0500077^^ 48 RETURN C0500078^^ 49 290 LCON = 20 C0500079^^ C CCSGET AND EDIT CONNECTOR C0500080^^ 50 300 DO 310 J = 1, 6 C0500081^^ 51 JJ = LCON -1 +J C0500082^^ 52 CALL CCSGET (INPUT, JJ, I) C0500083^^ 53 310 CALL CCSPUT ( I, J, CONLIT) C0500084^^ 54 DO 320 I = 1, 2 C0500085^^ 55 DO 315 J = 1, 3 C0500086^^ 56 IF ( CONLIT(J) .NE. GOODCN(J, I) ) GO TO 320 C0500087^^ 57 315 CONTINUE C0500088^^ C MATCHED OKAY C0500089^^ 58 GO TO 350 C0500090^^ 59 320 CONTINUE C0500091^^ C RETURN WITH ERROR C0500092^^ 60 IND = $8002 C0500093^^ 61 RETURN C0500094^^ C GOOD FINISH C0500095^^ 62 350 ICON = I - 1 C0500096^^ 63 RETURN C0500097^^ 64 END C0500098^t FTN 3.3B (OPT = LPC) PMEDT1 PAGE 3 DATE: 08/29/84 TIME: 2259 t  PROGRAM LENGTH $016C ( 364)   EXTERNALS  Q8PKUP Q8PREP CCSGET CCSPUT  t FTN 3.3B (OPT = LPC) PMEDT1 PAGE 4 DATE: 08/29/84 TIME: 2259 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " 8001 (-32766) 0017 18 "" 8002 (-32765) 0020 60 "" 8003 (-32764) 001D 42 "( 8004 (-32763) 0019 24,32,47 (* 0005 (5) 0018 22,28,29,35*$ 000C (12) 001B 30,38$" 0013 (19) 001E 45 "& 2020 (8224) 0016 9,10,11&   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < , COMMA INTEGER 0014 5,7,23,31,46 ,, CONLIT INTEGER 7FFF 1,2,11,53,56 ,& GOODCN INTEGER 000E 2,5,56 &( GOODOP INTEGER 0000 2,4,15,16(b I INTEGER 0015 7,9,10,11,14,15,16,20,22,23,27,28,30,31,37,38,45,46,52,53,54,56,62 b& ICON INTEGER 7FFF 1,13,62&6 IND INTEGER 7FFF 1,12,18,24,32,42,47,60 6: INPUT INTEGER 7FFF 1,2,15,16,22,27,30,37,45,52:, IOP INTEGER 7FFF 1,20,21,29,35,@ J INTEGER 001A 26,27,28,36,37,38,50,51,53,55,56 @( JJ INTEGER 001F 50,51,52 (* LCON INTEGER 001C 34,34,49,51*& LPN INTEGER 7FFF 1,29,44&0 PA INTEGER 7FFF 1,2,9,28,39,40,4102 PB INTEGER 7FFF 1,2,10,38,39,40,41 2   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < 0 CCSGET SUBROUTINE 00D8 21,27,30,37,45,520( CCSPUT SUBROUTINE 00F1 28,38,53 ( Q8PKUP INTEGER.FN. 0129 Q8PREP INTEGER.FN. 0126 t FTN 3.3B (OPT = LPC) PMEDT1 PAGE 5 DATE: 08/29/84 TIME: 2259 t   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 1 0027 7,11 $( 100 0045 13,15,17 ($ 200 0056 16,20$$ 220 006B 23,26$$ 230 0071 26,28$$ 240 0096 31,34$$ 250 00A4 35,38$* 270 00D3 39,40,41,44*$ 290 00E3 46,49$$ 300 00E5 35,50$$ 310 00F0 50,53$$ 315 010C 54,57$( 320 0113 53,56,59 ($ 350 011C 57,62$ PMEDT1 0123 1  t FTN 3.3B (OPT = LPC) PRETSR PAGE 1 DATE: 08/29/84 TIME: 2300 t^ 1 PROGRAM PRETSR C0600001^^ 1 1 /C06 F CCS CCS 3.0 .LA SL-149********^^ C C0600003^^ C CYBERCREDIT SYSTEM VERSION 3 C0600004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C0600005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C0600006^^ C C0600007^ ^ C THIS PROGRAM SETS THE SORT KEYS WITHIN TRNSFL, THIS ALLOWS C0600009^^ C FOR MULTIPLE ACTIVITIES AND MULTIPLE REVIEWS OF AN ACCOUNT C0600010^^ C TO APPEAR CORRECTLY ON THE TIME USAGE REPORT. C0600011^ ^ 2 INTEGER RECINP(69),RECOUT(69),REQINP(24),REQOUT(24),IDATA(15), C0600013^^ 2 1 STRTP(2),XEOF,USER(4) C0600014^ ^ 3 DATA MULACT / -1 /, C0600016^^ 3 1 RECOUT / 69*$2020 /, C0600017^^ 3 2 XEOF / 0 /, C0600018^^ 3 3 L / ' L' /, C0600019^^ 3 4 IFRST / 1 /, C0600020^^ 3 5 REQINP / 24*0 / C0600021^^ 4 DATA IDATA / 'LATRNSFL',8*$2020,0,1,-1/ ********^  ^ C ACCEPT LOG ON FROM ITOS C0600024^^ 5 CALL PGMIN ( USER, LU, MODE, NPORT ) C0600025^^ 6 CALL CCSCST(IDATA,1,2,USER,1,8,ICM) ********^^ 7 IF(ICM.NE.0)CALL CCSMVA(IDATA,3,6,IDATA,1,8) ********^ ^ C OPEN TRNSFL FOR USE C0600027^^ 8 CALL OPENFL ( REQINP, IDATA, ISTAT ) C0600028^^ 9 IF ( ISTAT .LT. 0 ) GO TO 900 C0600029^  ^ C READ AN ACTIVITY RECORD C0600031^^ 10 100 IF ( XEOF .NE. 0 ) GO TO 950 C0600032^^ 11 CALL GETS ( REQINP, RECINP, 0, ISTAT ) C0600033^^ C CHECK FOR END OF FILE C0600034^^ 12 IF ( RECINP(15) .NE. $3031 ) GO TO 500 C0600035^^ 13 IF ( AND(ISTAT,$100) .EQ. $100 ) GO TO 500 C0600036^^ 14 IF ( ISTAT .LT. 0 ) GO TO 900 C0600037^ ^ C THIS IS AN ACTIVISY RECORD - SAVE ACTIVITY COUNTER C0600039^^ 15 RECINP(61)=RECINP(69) C0600040^^ C BLANK OUT SORT CODE AREA C0600041^^ 16 CALL CCSMVA ( L, 1, 0, RECINP, 132, 7 ) C0600042^^ C CHECK FOR FIRST TIME C0600043^^ 17 IF ( IFRST .EQ. 1 ) GO TO 400 C0600044^ ^ C NOT FIRST - COMPARE ACCOUNT NUMBER C0600046^^ 18 DO 110 I = 1, 8 C0600047^^ 19 IF ( RECINP(I) .NE. RECOUT(I) ) GO TO 300 C0600048^^ 20 110 CONTINUE C0600049^ t FTN 3.3B (OPT = LPC) PRETSR PAGE 2 DATE: 08/29/84 TIME: 2300 t^ C SAME ACCOUNT NUMBER - COMPARE START TIME C0600051^^ 21 IF ( RECINP(11) .NE. RECOUT(11) .OR. C0600052^^ 21 2 RECINP(12) .NE. RECOUT(12)) GO TO 200 C0600053^ ^ C SAME START TIME (SESSION) - INCREMENT SESSION CNT AND SAVE C0600055^^ 22 MULACT = MULACT + 1 C0600056^^ 23 RECOUT(67) = AND(RECOUT(67),$FF00) + MULACT + $30 C0600057^ ^ C STORE THE OUTPUT RECORD C0600059^^ 24 120 CALL UPDREC ( REQOUT, RECOUT, ISTAT ) C0600060^^ 25 IF ( ISTAT .LT. 0 ) GO TO 900 C0600061^ ^ C MOVE THE INPUT RECORD TO THE OUTPUT RECORD C0600063^^ 26 130 DO 140 I = 1, 69 C0600064^^ 27 140 RECOUT(I) = RECINP(I) C0600065^^ C MOVE START TIME PRIME TO THE OUTPUT BUFFER C0600066^^ 28 RECOUT(68) = STRTP(1) C0600067^^ 29 RECOUT(69) = STRTP(2) C0600068^^ C SAVE THE REQUEST BUFFER FOR OUTPUT C0600069^^ 30 DO 150 I = 1, 24 C0600070^^ 31 150 REQOUT(I) = REQINP(I) C0600071^ ^ C GO GET NEXT RECORD TO PROCESS C0600073^^ 32 GO TO 100 C0600074^  ^ C SAME ACCT, NEW START TIME (SESSION) - C0600076^^ C CHECK IF WORKING ON A MULTIPLE ACTIVITY SESSION C0600077^^ 33 200 IF ( MULACT .EQ. -1 ) GO TO 120 C0600078^^ C YES - SET END OF SESION INDICATOR C0600079^^ 34 RECOUT(67) = AND(RECOUT(67),$FF00) + AND(L,$FF) C0600080^^ 35 MULACT = -1 C0600081^^ 36 GO TO 120 C0600082^  ^ C NEW ACCOUNT - SAVE NEW START TIME PRIME C0600084^^ 37 300 STRTP(1) = RECINP(11) C0600085^^ 38 STRTP(2) = RECINP(12) C0600086^^ 39 GO TO 200 C0600087^  ^ C FIRST TIME - INITIALIZE C0600089^^ 40 400 STRTP(1) = RECINP(11) C0600090^^ 41 STRTP(2) = RECINP(12) C0600091^^ 42 IFRST = 0 C0600092^^ 43 GO TO 130 C0600093^  ^ C EOF ENCOUNTERED - SET FLAG AND SAVE LAST RECORD C0600095^^ 44 500 XEOF = 1 C0600096^^ 45 GO TO 300 C0600097^  ^ C FILE ERROR OCCURED - REPORT AND EXIT C0600099^t FTN 3.3B (OPT = LPC) PRETSR PAGE 3 DATE: 08/29/84 TIME: 2300 t^ 46 900 CONTINUE C0600100^  ^ C CLOSE FILE AND STOP JOB C0600102^^ 47 950 CALL CLOSFL ( REQINP, ISTAT ) C0600103^^ 48 CALL PGMOUT C0600104^^ 49 END C0600105^t FTN 3.3B (OPT = LPC) PRETSR PAGE 4 DATE: 08/29/84 TIME: 2300 t  PROGRAM LENGTH $01AE ( 430)   EXTERNALS 2 Q8STP PGMIN CCSCST CCSMVA OPENFL GETS UPDREC 2 CLOSFL PGMOUT  t FTN 3.3B (OPT = LPC) PRETSR PAGE 5 DATE: 08/29/84 TIME: 2300 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < $ FF00 (-255) 00E5 23,34$8 0000 (0) 0003 3,4,7,9,10,11,14,16,25,428J 0001 (1) 0002 3,4,6,7,16,17,18,22,26,28,30,33,35,37,40,44J* 0002 (2) 00DA 6,29,38,41 * 0003 (3) 00DD 7 0006 (6) 00DE 7 " 0007 (7) 00E3 16 "& 0008 (8) 00DB 6,7,18 &" 0084 (132) 00E2 16 "" 00FF (255) 00E6 34 "$ 0100 (256) 00E1 13,13$" 3031 (12337) 00E0 12 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < ( AND INTR.FN. 7FFF 13,23,34 (0 I INTEGER 00E4 17,19,26,27,30,310" ICM INTEGER 00DC 6,7"( IDATA INTEGER 00BE 1,4,6,7,8(& IFRST INTEGER 00D6 3,17,42&4 ISTAT INTEGER 00DF 8,9,11,13,14,24,25,474& L INTEGER 00D5 3,16,34& LU INTEGER 00D7 5 MODE INTEGER 00D8 5 , MULACT INTEGER 00D4 1,22,23,33,35, NPORT INTEGER 00D9 5 B RECINP INTEGER 0004 1,11,12,15,16,19,21,27,37,38,40,41 B: RECOUT INTEGER 0049 1,3,19,21,23,24,27,28,29,34:. REQINP INTEGER 008E 1,3,8,11,31,47 .& REQOUT INTEGER 00A6 1,24,31&2 STRTP INTEGER 00CD 1,28,29,37,38,40,412$ USER INTEGER 00D0 1,5,6$( XEOF INTEGER 00CF 1,3,10,44(t FTN 3.3B (OPT = LPC) PRETSR PAGE 6 DATE: 08/29/84 TIME: 2300 t   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  CCSCST SUBROUTINE 00EE 5 $ CCSMVA SUBROUTINE 00FA 7,16 $" CLOSFL SUBROUTINE 01A7 47 "" GETS SUBROUTINE 0111 10 " OPENFL SUBROUTINE 0102 7 PGMIN SUBROUTINE 00E8 4 " PGMOUT SUBROUTINE 01AB 47 " Q8STP INTEGER.FN. 01AD " UPDREC SUBROUTINE 015B 23 "   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 100 010B 9,32 $$ 110 013F 17,20$( 120 015A 23,33,36 ($ 130 0164 25,43$$ 140 0167 25,27$$ 150 0179 29,31$( 200 0183 21,33,39 (( 300 0195 19,37,45 ($ 400 019A 17,40$( 500 01A2 12,13,44 (* 900 01A6 9,14,25,46 *$ 950 01A6 10,47$ PRETSR 0000 1 t FTN 3.3B (OPT = LPC) PRNTIT PAGE 1 DATE: 08/29/84 TIME: 2300 t^ 1 SUBROUTINE PRNTIT(RECORD,ACCTNO,DBLSP,SCNNAM,NAMLEN,SDEF) C0700001^^ 1 1 /C07 F CCS CCS 3.0 SL-149C0700002^^ C C0700003^^ C CYBERCREDIT SYSTEM VERSION 3 C0700004^^ C DATA SUYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C0700005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C0700006^^ C C0700007^^ C C0700008^^ C C0700009^^ C PRINT SCREEN TEMPLATES ON LINE PRINTER C0700010^^ C C0700011^^ C THIS MODULE USES FIELDS PASSED BY PRTSCN TO FORMAT AND PRINT THE C0700012^^ C SCREENS DEFINED ON SCRNFILE C0700013^^ 2 EXTERNAL AMONTO,AYERTO,ADAYTO C0700014^^ C INTEGER VARIABLES PASSED C0700015^^ 3 INTEGER RECORD(1),ACCTNO(1),DBLSP(1),SCNNAM(1),NAMLEN(1),SDEF(1) C0700016^^ C INTEGER VARIABLES FOR DELIMATORS C0700017^^ 4 INTEGER DELIM,SLASH,PAR1,PAR2,BRK1,BRK2,CAR1,CAR2 C0700018^^ C OTHER INTEGER VARIABLES C0700019^^ 5 INTEGER ASCNIN(5),ASCZER(8),ASTRSK,BLANK,COLSTR,FLAG C0700020^^ 6 INTEGER LENGTH,LINLEN,LP,ONE,PRTLNE(66),NXTBYT C0700021^^ 7 INTEGER STRPOS,TEMP(8),TIME(2),TOP,WRKTBL(960),HXA(3) C0700022^^ 8 INTEGER YES,ZERO,I,J,N,M,FSTACT(36),LMASBL(2) C0700023^^ 9 INTEGER DATE(3) C0700024^^ 10 INTEGER TWO,THREE,FOUR,SIX C0700025^^ C DATA VARIABLES FOR DELIMATORS C0700026^^ 11 DATA SLASH/$2F20/,PAR1/'( '/,PAR2/') '/,BRK1/'[ '/,BRK2/'] '/ C0700027^^ 12 DATA CAR1/'< '/,CAR2/'> '/,LMASBL/'0360'/ C0700028^^ 13 DATA ASCNIN/5*$3939/,ASCZER/8*$3030/,ASTRSK/$2A20/,BLANK/$2020/ C0700029^^ 14 DATA FLAG/0/,LINLEN/132/,LP/9/,ONE/1/ C0700030^^ 15 DATA TWO/2/,THREE/3/,FOUR/4/,SIX/6/ C0700031^^ 16 DATA TOP/$C00/,ZERO/0/ C0700032^^ C 94 IS THE LAST HALF OF THE COSIGNER SCREEN-SKIP HEADING C0700033^^ 17 IF(SDEF(1).EQ.94) GO TO 50 C0700034^  ^ C * HEADING ROUTINE * C0700036^^ C BLANK PRINT LINE C0700037^^ 18 CALL CCSBLK(PRTLNE,LINLEN) C0700038^^ C SET TOP OF PAGE C0700039^^ 19 PRTLNE(1) = TOP C0700040^^ 20 ASSIGN 15 TO IGOTO C0700041^^ 21 CALL FWRITE(LP,PRTLNE,LINLEN,IGOTO,FLAG,TEMP) C0700042^^ 22 CALL DISP C0700043^^ 23 15 PRTLNE(1) = BLANK C0700044^^ 24 CALL CCSGET(DBLSP,ONE,NDLSP) C0700045^^ C SPACE PAPER DOWN C0700046^^ 25 IF(NDLSP.EQ.$59) GO TO 22 C0700047^^ 26 IDWN = 11 C0700048^^ 27 DO 20 L=1,IDWN C0700049^^ 28 ASSIGN 20 TO IGOTO C0700050^^ 29 CALL FWRITE(LP,PRTLNE,LINLEN,IGOTO,FLAG,TEMP) C0700051^^ 30 CALL DISP C0700052^^ 31 20 CONTINUE C0700053^t FTN 3.3B (OPT = LPC) PRNTIT PAGE 2 DATE: 08/29/84 TIME: 2300 t^ C PRINT TOP ASTERISKS LINE C0700054^^ 32 22 DO 25 L=12,56 C0700055^^ 33 PRTLNE(L) = $2A20 C0700056^^ 34 25 CONTINUE C0700057^^ 35 ASSIGN 30 TO IGOTO C0700058^^ 36 CALL FWRITE(LP,PRTLNE,LINLEN,IGOTO,FLAG,TEMP) C0700059^^ 37 CALL DISP C0700060^^ C READY PRINT LINE WITH ASTERISKS C0700061^^ 38 30 CALL CCSBLK(PRTLNE,LINLEN) C0700062^^ 39 PRTLNE(12) = ASTRSK C0700063^^ 40 PRTLNE(56) = ASTRSK C0700064^^ C PRINT ASTERISK LINES TO SPACE PAPER FOR REPORT C0700065^^ 41 DO 40 I=1,2 C0700066^^ 42 ASSIGN 40 TO IGOTO C0700067^^ 43 CALL FWRITE(LP,PRTLNE,LINLEN,IGOTO,FLAG,TEMP) C0700068^^ 44 CALL DISP C0700069^^ 45 40 CONTINUE C0700070^^ 46 CALL CCSBLK(WRKTBL,1920) C0700071^^ C INITIALIZE INDEX PAST SCREEN NUMBER C0700072^^ 47 50 K = 2 C0700073^^ 48 GO TO 80 C0700074^^ C * C0700075^^ C RETURN HERE FOR NEXT SCREEN DEFINITION C0700076^^ C * C0700077^^ 49 70 K = SDEF(K+1) C0700078^^ 50 IF(K.NE.0) GO TO 80 C0700079^^ C NUMBERS 04 AND 94 ARE THE TWO PARTS OF THE COSIGNER SCREEN C0700080^^ 51 IF(SDEF(1).EQ.04) GO TO 710 C0700081^^ C END OF THIS SCREEN - GO FINISH PRINTING PAGE C0700082^^ 52 GO TO 650 C0700083^^ C CALCULATE LINE AND COLUMN NUMBERS TO BE USED IN POSITIONING IN THEC0700084^^ C PRINT ARRAY C0700085^^ C C0700086^^ C I = LINE C0700087^^ C J = COLUMN C0700088^^ C C0700089^^ 53 80 I = AND($00FF,SDEF(K))+1 C0700090^^ 54 J = AND(SDEF(K),$FF00) / $100 + 1 C0700091^^ 55 M = (I-1) * 80 + J C0700092^^ 56 LENGTH = SDEF(K+2) C0700093^^ 57 STRPOS = SDEF(K+3) C0700094^^ C MOVE DATA TO PRINT LINE ACCORDING TO TYPE C0700095^^ 58 200 L = SDEF(K+4) + 1 C0700096^^ C FIELD TYPE = 0 1 2 3 4 5 6 7 8 9 C0700097^^ 59 GO TO (500,250,250,250,250,300,250,460,500,310),L C0700098^^ C IF ACCOUNT NO IS ZERO GO TO PUTTING IN DELIMITOR INSTEAD OF DATA C0700099^^ 60 250 CALL CCSCST(ACCTNO,ONE,16,ASCZER,ONE,16,L) C0700100^^ 61 IF(L.LE.0) GO TO 600 C0700101^^ 62 IF(SDEF(K+4).EQ.2) GO TO 350 C0700102^^ 63 CALL CCSCST(RECORD,STRPOS,LENGTH,ASCZER,ONE,LENGTH,L) C0700103^^ C CHECK RETURN INDICATOR C0700104^^ 64 IF(L) 280,260,270 C0700105^^ C ALL ZEROS PRESENT - EDIT ONLY IF FIELD IS AN AMOUNT FIELD C0700106^^ 65 260 IF(SDEF(K+4).EQ.3) GO TO 450 C0700107^t FTN 3.3B (OPT = LPC) PRNTIT PAGE 3 DATE: 08/29/84 TIME: 2300 t^ C NOT AN AMOUNT FIELD, BYPASS EDIT AND OUTPUT C0700108^^ 66 GO TO 280 C0700109^^ C FIELD IS NOT ALL BLANK OR ZEROS-COMPARE AGAINST ALL NINE FIELD TO C0700110^^ C DETERMINE IF FIELD IS NUMERIC OR ALPHA C0700111^^ 67 270 CALL CCSCST(RECORD,STRPOS,LENGTH,ASCNIN,ONE,LENGTH,L) C0700112^^ C GO TO EDIT ROUTINE IF FIELD IS NUMERIC C0700113^^ 68 IF(L.LT.0) GO TO 450 C0700114^^ C FIELD IS ALPHA. EDIT AS ALPHA FIELD IF PHONE NUMBER OR SOC.SEC.NO.C0700115^^ 69 IF(SDEF(K+4).GE.4) GO TO 350 C0700116^^ C NO FIELD PRESENT TO EDIT OR UNUSED FIELD TYPE C0700117^^ 70 280 GO TO 70 C0700118^^ C PUT ACTIVITY HERE C0700119^^ 71 300 GO TO 70 C0700120^^ C 310 ISTAT=ASCZER(1)+1 C0700121^^ C CALL GETACF(FSTACT,RECORD(154),LMASBL,ISTAT) C0700122^^ C CALL ACTEDT(FSTACT,WRKTBL(M)) C0700123^^ 72 310 GO TO 70 C0700124^^ C NO EDIT TO PERFORM C0700125^^ C PERFORM THE MOVE C0700126^^ C ALPHANUMERIC FIELD FROM FILE C0700127^^ 73 350 CALL CCSMVA(RECORD,STRPOS,LENGTH,WRKTBL,M,LENGTH) C0700128^^ 74 GO TO 70 C0700129^^ C EDIT FIELDS C0700130^^ C TYPE C0700131^^ 75 450 CALL EDIT(RECORD,STRPOS,WRKTBL,M,SDEF(K+4)) C0700132^^ 76 GO TO 70 C0700133^^ C TIME REQUEST C0700134^^ 77 460 CALL CCSTIM(TIME) C0700135^^ 78 CALL CCSMVA(TIME,ONE,FOUR,WRKTBL,M,FOUR) C0700136^^ 79 GO TO 70 C0700137^^ C CONSTANT SCREEN FIELD FROM SCRNFILE C0700138^^ 80 500 CALL CCSMVA(SDEF(K+5),STRPOS,LENGTH,WRKTBL,M,LENGTH) C0700139^^ 81 GO TO 70 C0700140^^ C USE DELIMITORS INSTEAD OF ACTUAL DATA FROM MASTER RECORD C0700141^^ 82 600 IF(SDEF(K+4).EQ.ONE) DELIM = SLASH C0700142^^ 83 IF(SDEF(K+4).EQ.TWO) DELIM = PAR1 C0700143^^ 84 IF(SDEF(K+4).EQ.THREE.OR.SDEF(K+4).EQ.FOUR) DELIM = BRK1 C0700144^^ 85 IF(SDEF(K+4).EQ.SIX) DELIM = CAR1 C0700145^^ 86 CALL CCSMVA(DELIM,ONE,TWO,WRKTBL,M,TWO) C0700146^^ C IF THERE IS ROOM BETWEEN DELIMATORS-INSERT THE POSITION IN THE C0700147^^ C MASTER RECORD (K+4) THAT CONTAINS THE DATA WHICH WOULD PRINT. C0700148^^ C CALCULATE THAT PRINT POSITION- C0700149^^ 87 NXTBYT = (LENGTH - 4) / 2 + M C0700150^^ C IF THERE IS ROOM BETWEEN DELIMATORS PRINT THE POSITION NUMBER C0700151^^ 88 IF(NXTBYT.LE.M) GO TO 610 C0700152^^ 89 CALL HEXDEC(STRPOS,HXA) C0700153^^ 90 CALL CCSMVA(HXA,THREE,4,WRKTBL,NXTBYT,4) C0700154^^ C PUT IN LAST DELIMITOR C0700155^^ 91 610 M = M + LENGTH - 1 C0700156^^ 92 IF(DELIM.EQ.PAR1) DELIM = PAR2 C0700157^^ 93 IF(DELIM.EQ.BRK1) DELIM = BRK2 C0700158^^ 94 IF(DELIM.EQ.CAR1) DELIM = CAR2 C0700159^^ 95 CALL CCSMVA(DELIM,ONE,TWO,WRKTBL,M,TWO) C0700160^^ 96 GO TO 70 C0700161^t FTN 3.3B (OPT = LPC) PRNTIT PAGE 4 DATE: 08/29/84 TIME: 2300 t   ^ C MOVE TABLE ARRAY AND PRINT C0700163^^ 97 650 M = 1 C0700164^^ 98 N = 40 C0700165^^ C TO CENTER TO MIDDLE OF PAGE C0700166^^ 99 L = 14 C0700167^^ 100 DO 670 I=1,24 C0700168^^ 101 DO 653 M=M,N C0700169^^ 102 PRTLNE(L) = WRKTBL(M) C0700170^^ 103 L = L + 1 C0700171^^ 104 653 CONTINUE C0700172^^ 105 L = 14 C0700173^^ 106 N = N + 40 C0700174^^ 107 PRTLNE(12) = ASTRSK C0700175^^ 108 PRTLNE(56) = ASTRSK C0700176^^ 109 ASSIGN 655 TO IGOTO C0700177^^ 110 CALL FWRITE(LP,PRTLNE,LINLEN,IGOTO,FLAG,TEMP) C0700178^^ 111 CALL DISP C0700179^^ 112 655 IF(NDLSP.NE.$59)GO TO 670 C0700180^^ 113 CALL CCSBLK(PRTLNE,LINLEN) C0700181^^ 114 PRTLNE(12) = ASTRSK C0700182^^ 115 PRTLNE(56) = ASTRSK C0700183^^ 116 ASSIGN 670 TO IGOTO C0700184^^ 117 CALL FWRITE(LP,PRTLNE,LINLEN,IGOTO,FLAG,TEMP) C0700185^^ 118 CALL DISP C0700186^^ 119 670 CONTINUE C0700187^^ C SPACE DOWN A COUPLE LINES AND PRINT SCREEN TITLE AND DATE C0700188^^ 120 CALL CCSBLK(PRTLNE,LINLEN) C0700189^^ 121 PRTLNE(12)= ASTRSK C0700190^^ 122 PRTLNE(56) = ASTRSK C0700191^^ 123 DO 675 L=1,2 C0700192^^ 124 ASSIGN 675 TO IGOTO C0700193^^ 125 CALL FWRITE(LP,PRTLNE,LINLEN,IGOTO,FLAG,TEMP) C0700194^^ 126 CALL DISP C0700195^^ 127 675 CONTINUE C0700196^^ C PRINT BOTTOM ASTERISK LINE C0700197^^ 128 DO 680 L=12,56 C0700198^^ 129 PRTLNE(L) = ASTRSK C0700199^^ 130 680 CONTINUE C0700200^^ 131 ASSIGN 685 TO IGOTO C0700201^^ 132 CALL FWRITE(LP,PRTLNE,LINLEN,IGOTO,FLAG,TEMP) C0700202^^ 133 CALL DISP C0700203^^ 134 685 CALL CCSBLK(PRTLNE,LINLEN) C0700204^^ 135 ASSIGN 695 TO IGOTO C0700205^^ 136 CALL FWRITE(LP,PRTLNE,LINLEN,IGOTO,FLAG,TEMP) C0700206^^ 137 CALL DISP C0700207^^ C CENTER SCREEN NAME ON PAPER C0700208^^ 138 695 IF(NAMLEN.EQ.0) GO TO 700 C0700209^^ 139 STRPOS = (132-NAMLEN) / 2 C0700210^^ 140 CALL CCSMVA(SCNNAM,ONE,NAMLEN,PRTLNE,STRPOS,NAMLEN) C0700211^^ 141 ASSIGN 700 TO IGOTO C0700212^^ 142 CALL FWRITE(LP,PRTLNE,LINLEN,IGOTO,FLAG,TEMP) C0700213^t FTN 3.3B (OPT = LPC) PRNTIT PAGE 5 DATE: 08/29/84 TIME: 2300 t^ 143 CALL DISP C0700214^^ C CENTER AND PRINT CURRENT DATE C0700215^^ 144 700 CALL CCSBLK(PRTLNE,LINLEN) C0700216^^ 145 DATE(1)=AND($FFFF,AMONTO) C0700217^^ 146 DATE(2)=AND($FFFF,ADAYTO) C0700218^^ 147 DATE(3)=AND($FFFF,AYERTO) C0700219^^ 148 CALL CCSMVA(SLASH,ONE,TWO,PRTLNE,64,TWO) C0700220^^ 149 CALL CCSMVA(SLASH,ONE,TWO,PRTLNE,67,TWO) C0700221^^ 150 CALL CCSMVA(DATE,ONE,TWO,PRTLNE,62,TWO) C0700222^^ 151 CALL CCSMVA(DATE,THREE,TWO,PRTLNE,65,TWO) C0700223^^ 152 CALL CCSMVA(DATE,5,TWO,PRTLNE,68,TWO) C0700224^^ 153 ASSIGN 710 TO IGOTO C0700225^^ 154 CALL FWRITE(LP,PRTLNE,LINLEN,IGOTO,FLAG,TEMP) C0700226^^ 155 CALL DISP C0700227^^ C SCREEN PRINTED C0700228^^ 156 710 RETURN C0700229^^ 157 END C0700230^t FTN 3.3B (OPT = LPC) PRNTIT PAGE 6 DATE: 08/29/84 TIME: 2300 t  PROGRAM LENGTH $0720 ( 1824)   EXTERNALS 2 Q8PKUP Q8PREP AMONTO AYERTO ADAYTO CCSBLK FWRITE 22 DISP CCSGET CCSCST CCSMVA EDIT CCSTIM HEXDEC 2 t FTN 3.3B (OPT = LPC) PRNTIT PAGE 7 DATE: 08/29/84 TIME: 2300 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " FF00 (-255) 0469 54 "* FFFF (65535) 046D 145,146,147*B 0004 (4) 0467 51,58,62,65,69,75,82,83,84,85,87,90B" 0005 (5) 0472 152"$ 0010 (16) 046B 60,60$" 003E (62) 0470 150"" 0040 (64) 046E 148"" 0041 (65) 0471 151"" 0043 (67) 046F 149"" 0044 (68) 0473 152"" 0050 (80) 046A 55 "" 0084 (132) 046C 139"" 00FF (255) 0468 53 "" 0780 (1920) 0465 46 "" 2A20 (10784) 0464 33 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < & ACCTNO INTEGER 7FFF 1,3,60 &0 AND INTR.FN. 7FFF 53,54,145,146,1470& ASCNIN INTEGER 0008 3,13,67&* ASCZER INTEGER 000D 3,13,60,63 *F ASTRSK INTEGER 0015 3,13,39,40,107,108,114,115,121,122,129 F& BLANK INTEGER 0016 3,13,23&* BRK1 INTEGER 0004 3,11,84,93 *& BRK2 INTEGER 0005 3,11,93&* CAR1 INTEGER 0006 3,12,85,94 *& CAR2 INTEGER 0007 3,12,94&8 DATE INTEGER 0459 3,145,146,147,150,151,1528& DBLSP INTEGER 7FFF 1,3,24 &< DELIM INTEGER 0000 3,82,83,84,85,86,92,93,94,95 <L FLAG INTEGER 0017 3,14,21,29,36,43,110,117,125,132,136,142,154 L* FOUR INTEGER 045E 3,15,78,84 * FSTACT INTEGER 0433 3 & HXA INTEGER 042B 3,89,90&. I INTEGER 042F 3,41,53,55,100 .( IDWN INTEGER 0462 25,26,27 (n IGOTO INTEGER 0460 19,21,28,29,35,36,42,43,109,110,116,117,124,125,131,132,135,136,141,142,153,154n& J INTEGER 0430 3,54,55&T K INTEGER 0466 47,47,49,50,53,54,56,57,58,62,65,69,75,80,82,83,84,85TZ L INTEGER 0463 26,32,33,58,59,60,61,63,64,67,68,99,102,103,105,123,128,129Z6 LENGTH INTEGER 0018 3,56,63,67,73,80,87,91 6t FTN 3.3B (OPT = LPC) PRNTIT PAGE 8 DATE: 08/29/84 TIME: 2300 tb LINLEN INTEGER 0019 3,14,18,21,29,36,38,43,110,113,117,120,125,132,134,136,142,144,154 b$ LMASBL INTEGER 0457 3,12 $L LP INTEGER 001A 3,14,21,29,36,43,110,117,125,132,136,142,154 LJ M INTEGER 0432 3,55,73,75,78,80,86,87,88,91,95,97,101,102 J, N INTEGER 0431 3,98,101,106 ,. NAMLEN INTEGER 7FFF 1,3,138,139,140.( NDLSP INTEGER 0461 24,25,112(* NXTBYT INTEGER 005E 3,87,88,90 *L ONE INTEGER 001B 3,14,24,60,63,67,78,82,86,95,140,148,149,150 L* PAR1 INTEGER 0002 3,11,83,92 *& PAR2 INTEGER 0003 3,11,92&‚ PRTLNE INTEGER 001C 3,18,19,21,23,29,33,36,38,39,40,43,102,107,108,110,113,114,115,117,120,121,122,125,129,132,134,136 ‚D ,140,142,144,148,149,150,151,152,154 D. RECORD INTEGER 7FFF 1,3,63,67,73,75.& SCNNAM INTEGER 7FFF 1,3,140&V SDEF INTEGER 7FFF 1,3,17,49,51,53,54,56,57,58,62,65,69,75,80,82,83,84,85 V& SIX INTEGER 045F 3,15,85&. SLASH INTEGER 0001 3,11,82,148,149.> STRPOS INTEGER 005F 3,57,63,67,73,75,80,89,139,140 >H TEMP INTEGER 0060 3,21,29,36,43,110,117,125,132,136,142,154H. THREE INTEGER 045D 3,15,84,90,151 .& TIME INTEGER 0068 3,77,78&& TOP INTEGER 006A 3,16,19&@ TWO INTEGER 045C 3,15,83,86,95,148,149,150,151,152@< WRKTBL INTEGER 006B 3,46,73,75,78,80,86,90,95,102<$ ZERO INTEGER 042E 3,16 $   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < 8 CCSBLK SUBROUTINE 063A 17,38,46,113,120,134,144 8( CCSCST SUBROUTINE 052C 60,63,67 (" CCSGET SUBROUTINE 0491 23 "H CCSMVA SUBROUTINE 0696 73,78,80,86,90,95,140,148,149,150,151,152H" CCSTIM SUBROUTINE 057E 77 "F DISP SUBROUTINE 06EA 21,30,37,44,111,118,126,133,137,143,155F" EDIT SUBROUTINE 0575 75 "F FWRITE SUBROUTINE 06E2 19,29,36,43,110,117,125,132,136,142,154F" HEXDEC SUBROUTINE 05D5 88 " Q8PKUP INTEGER.FN. 06F4 Q8PREP INTEGER.FN. 06F1 t FTN 3.3B (OPT = LPC) PRNTIT PAGE 9 DATE: 08/29/84 TIME: 2300 t   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 15 048D 19,23$( 20 04AB 26,28,31 ($ 22 04AE 25,32$$ 25 04B4 32,34$$ 30 04C4 34,38$( 40 04DB 40,42,45 ($ 50 04E3 17,47$: 70 04E7 47,70,71,72,74,76,79,81,96 :( 80 04F3 47,50,53 (" 200 050E 57 "( 250 052B 58,59,60 ($ 260 054C 64,65$$ 270 0552 64,67$( 280 0563 64,66,70 ($ 300 0564 59,71$$ 310 0565 59,72$( 350 0567 62,69,73 (( 450 0571 65,68,75 ($ 460 057D 59,77$( 500 0589 58,59,80 ($ 600 0596 61,82$$ 610 05DF 88,91$$ 650 0602 51,97$& 653 0619 100,104&& 655 0634 108,112&. 670 064B 99,112,116,119 .* 675 0663 122,124,127*& 680 066D 127,130&& 685 067D 130,134&& 695 068B 134,138&* 700 06A8 138,141,144** 710 06EB 51,153,156 * PRNTIT 06EE 1  t FTN 3.3B (OPT = LPC) PRTDT1 PAGE 1 DATE: 08/29/84 TIME: 2301 t^ 1 SUBROUTINE PRTDT1 ( TABLE, PLU) C0800001^^ 1 1 /C08 F CCS CCS 3.0 SL-149C0800002^^ C C0800003^^ C CYBERCREDIT SYSTEM VERSION 3 C0800004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C0800005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C0800006^^ C C0800007^^ 2 EXTERNAL AYERTO, ADAYTO, AMONTO, HORMIN C0800008^^ 3 INTEGER S,ONP, COID(12) C0800009^^ 4 INTEGER TABLE(9), PLU, TESTNO,PO(2,9), V1(3,9), V2(3,9),CON(3,9) C0800010^^ 5 EQUIVALENCE ( ICPRM, TABLE(6)) C0800011^^ 6 INTEGER POT,CONT, POLIT(14), CONLIT(6) C0800012^^ 7 DATA POLIT /'NULL.EQ..LE..GT..NE..WE..OS.'/ C0800013^^ 8 DATA CONLIT /'.AND. .OR. '/ C0800014^^ 9 INTEGER HD (20,3), DT (3), BLANKS (5), COMPIN ***00015^^ 10 DATA BLANKS /5*$2020/ ***00016^^ 11 INTEGER COMMA C0800017^^ 12 DATA COMMA /',,'/ C0800018^^ 13 INTEGER LIT(5,2) C0800019^^ 14 DATA LIT /10*$2020/ C0800020^^ 15 EQUIVALENCE (ITY, TABLE(4)) C0800021^^ 16 DATA I1PS / 0/ ********^^ 17 TESTNO = 0 C0800022^^ C PRINT HEADING C0800023^^ 18 IF( I1PS.NE.0 ) GO TO 50 ********^^ 19 I1PS = 1 ********^^ 20 K1 = AND($FFFF,AYERTO) C0800024^^ 21 K2 = AND ($FFFF,ADAYTO) C0800025^^ 22 K3 = AND ($FFFF, AMONTO) C0800026^^ 23 K4 = AND ($FFFF, HORMIN) C0800027^^ C DETERMINE IF THIS REPORT IS FOR CCS DECTBL OR ***00028^^ C L/A DECTBL BY CALLING UTHEAD - IF THAT FAILS ***00029^^ C (HD = BLANKS), TRY LAHEAD. ***00030^^ 24 CALL UTHEAD ( HD, DT) ***00031^^ 25 CALL CCSCST (HD,1,10,BLANKS,1,10,COMPIN) ***00032^^ 26 IF (COMPIN .NE. 0) GO TO 50 ***00033^^ C UTHEAD DIDNT WORK; TRY LAHEAD ***00034^^ 27 CALL LAHEAD ( HD, DT) ***00035^^ 28 CALL CCSCST (HD,1,10,BLANKS,1,10,COMPIN) ***00036^^ 29 IF (COMPIN .NE. 0) GO TO 50 ***00037^^ C NEITHER WORKED, RETURN ***00038^^ 30 GO TO 7000 ***00039^^ 31 50 WRITE (PLU,9700) HD ***00040^^ 32 9700 FORMAT (1H1,3(/2X,20R2)) ***00041^^ 33 WRITE (PLU,9800) (LIT(I,ITY),I=1,5),K3,K2,K1,K4 ***00042^^ 34 9800 FORMAT (43X,5A2,' DECISION TABLE CONTENTS DATE ' ***00043^^ 34 1 , A2, '/', A2, '/', A2, I5) C0800044^^ C PRINT COLUMN HEADINGS C0800045^^ 35 WRITE (PLU,9900) C0800046^^ 36 9900 FORMAT ( 122H0 TEST LEVEL NEXT NO. OF PARAM PARAM PAC0800047^^ 36 1RAM PARAM PARAM NO. OF RETURN CURRENT RETURNED VAC0800048^^ 36 2LUES) C0800049^^ 37 WRITE (PLU,9901) C0800050^^ 38 9901 FORMAT ( 106H NO LEVEL PARAMS NO. OPERATOR VALC0800051^t FTN 3.3B (OPT = LPC) PRTDT1 PAGE 2 DATE: 08/29/84 TIME: 2301 t^ 38 1UE 1 VALUE 2 CONNECTOR VALUES RET VAL ) C0800052^^ C INCRAMENT TEST NUMBER C0800053^^ 39 100 TESTNO = TESTNO + 1 C0800054^^ 40 CALL GTSDT1 (TABLE, LVL, NLVL, NP) C0800055^^ C CHECK FOR END OF TABLE C0800056^^ 41 IF ( LVL .EQ. $8001) GO TO 7000 C0800057^^ C LOCALIZE ALL PARAMETERS FOR THIS TEST C0800058^^ 42 DO 200 I = 1,NP C0800059^^ 43 DO 195 J = 1,3 C0800060^^ 44 195 V2(J,I) = $2020 C0800061^^ 45 CALL GPMDT1 ( TABLE, POT, V1(1,I), V2(1,I), CONT) C0800062^^ 46 K = (POT+1) *2 - 1 C0800063^^ 47 PO(1,I) = POLIT (K) C0800064^^ 48 PO(2,I) = POLIT (K+1) C0800065^^ 49 K = (CONT+1) * 3 - 2 C0800066^^ 50 CON(1,I) = CONLIT(K) C0800067^^ 51 CON(2,I) = CONLIT(K+1) C0800068^^ 52 200 CON(3,I) = CONLIT(K+2) C0800069^^ C BLANK LAST CONNECTOR C0800070^^ 53 DO 202 J = 1, 3 C0800071^^ 54 202 CON(J,NP) = $2020 C0800072^   ^ C WRITE OUT NP DETAIL LINES FOR TEST C0800074^^ 55 S= 1 C0800075^^ 56 ONP = NP C0800076^^ 57 210 DO 500 I = S, NP C0800077^^ C MOVE RETURNED VALUES INTO LINE C0800078^^ C BLANK HOLD AREA C0800079^^ 58 DO 240 J = 1, 24 C0800080^^ 59 240 CALL CCSPUT ($2020, J, COID) C0800081^^ C BYPASS IF NOT FIRST LINE C0800082^^ 60 IF ( I .NE. 1) GO TO 280 C0800083^^ C CCSGET NUMBER OF VALUES C0800084^^ 61 IMAX = TABLE (ICPRM) C0800085^^ 62 II= (AND($0F00,IMAX) / $100) * 10 C0800086^^ 63 J = AND ($000F, IMAX) C0800087^^ C IWRK IS TOTAL NUMBER OF RETURNED VALUES C0800088^^ 64 IWRK = II + J C0800089^^ 65 IVAL = 1 C0800090^^ 66 IDONE = 0 C0800091^^ C CHECK TO SEE IF FINISHED WITH VALUES C0800092^^ 67 280 IF ( IDONE .EQ. 1) GO TO 350 C0800093^^ 68 ICAR = 1 C0800094^^ C NOT FINISHED, GRAB UP TO 5 VALUES C0800095^^ C CALCULATE START OF VALUE IN TABLE C0800096^^ 69 290 IPOS = ICPRM + IVAL * 2 C0800097^^ C IS A COMMA NEEDED, IE NOT FIRST ON LINE C0800098^^ 70 IF ( ICAR .EQ. 1) GO TO 300 C0800099^^ C YES C0800100^^ 71 CALL CCSPUT ( COMMA, ICAR, COID) C0800101^^ 72 ICAR = ICAR + 1 C0800102^^ C MOVE IN VALUE C0800103^t FTN 3.3B (OPT = LPC) PRTDT1 PAGE 3 DATE: 08/29/84 TIME: 2301 t^ 73 300 DO 320 J = 1, 4 C0800104^^ 74 CALL CCSGET (TABLE(IPOS), J, ITMP) C0800105^^ 75 CALL CCSPUT ( ITMP, ICAR, COID) C0800106^^ 76 320 ICAR = ICAR + 1 C0800107^^ C INCRAMENT VALUE AND SEE IF FINISHED C0800108^^ 77 IVAL = IVAL + 1 C0800109^^ 78 IF ( IVAL .GT. IWRK) GO TO 340 C0800110^^ C SEE IF DONE WITH LINE C0800111^^ 79 IF ( ICAR .LT. 25) GO TO 290 C0800112^^ 80 GO TO 350 C0800113^^ C DONE WITH ALL RETURN VALUES C0800114^^ 81 340 IDONE = 1 C0800115^^ C DONE WITH LINE, PRINT C0800116^  ^ C PRINT TIME. C0800118^^ C THERE ARE 3 TYPES OF DETAIL LINES C0800119^^ C 1. 1ST LINE IN TEST C0800120^^ C 2. NOT 1ST LINE IN TEST BUT CONTAINING PARAMETER INFO C0800121^^ C 3. NOT 1ST LINE IN TEST WITH NO PARAMETERS BUT RETURN VALUES C0800122^^ C CHECK FOR 1ST LINE C0800123^^ 82 350 IF (I.NE.1) GO TO 420 C0800124^^ C FORMAT 1ST LINE C0800125^^ 83 WRITE (PLU,9910) TESTNO, LVL, NLVL, NP, I,(PO(K1,I),K1=1,2), C0800126^^ 83 1 (V1(K2,I),K2=1,3) , (V2(K3,I),K3=1,3), C0800127^^ 83 2 (CON(K4,I),K4=1,3), TABLE(ICPRM),TABLE(ICPRM+1), C0800128^^ 83 3 (COID(K5),K5 = 1,12) C0800129^^ 84 9910 FORMAT (1H0,2X, I3, 5X, I1, 6X, I1, 6X, I1, 6X, I1, 6X,2A2, 5X, C0800130^^ 84 1 1H*,3A2,1H*, 2X, 1H*,3A2,1H*, 3X, 3A2, 9X, A2, 11X, A2, C0800131^^ 84 2 5X,12A2) C0800132^^ 85 GO TO 500 C0800133^^ C CHECK FOR REGULAR LINE WITH PARAMETER INFO C0800134^^ 86 420 IF ( I .GT. ONP) GO TO 450 C0800135^^ C NORMAL PARAMETER LINE C0800136^^ 87 WRITE (PLU,9920) I,(PO(K1,I),K1=1,2), C0800137^^ 87 1 (V1(K2,I),K2=1,3) , (V2(K3,I),K3=1,3), C0800138^^ 87 2 (CON(K4,I),K4=1,3), C0800139^^ 87 3 (COID(K5),K5 = 1,12) C0800140^^ 88 9920 FORMAT ( 32X, I1, 6X,2A2, 5X, C0800141^^ 88 1 1H*,3A2,1H*, 2X, 1H*,3A2,1H*, 3X, 3A2, 9X, 2X, 11X, 2X, C0800142^^ 88 2 5X,12A2) C0800143^^ 89 GO TO 500 C0800144^^ C RETURN VALUES ONLY LINE C0800145^^ 90 450 WRITE (PLU,9930) (COID(K5), K5 = 1, 12) C0800146^^ 91 9930 FORMAT (104X, 12A2) C0800147^^ 92 GO TO 500 C0800148^^ 93 500 CONTINUE C0800149^^ C DONE WITH ALL PARAMETERS C0800150^^ C CHECK IF MORE RETURN VALUES NEEDED C0800151^^ 94 IF (IDONE .EQ. 1) GO TO 1000 C0800152^^ C LOOP BACK TO PICK UP ADDITIONAL VALUES C0800153^^ 95 NP = NP +1 C0800154^^ 96 S = NP C0800155^^ 97 GO TO 210 C0800156^t FTN 3.3B (OPT = LPC) PRTDT1 PAGE 4 DATE: 08/29/84 TIME: 2301 t^ C OUTPUT NEXT TEST C0800157^^ 98 1000 GO TO 100 C0800158^^ C END OF REPORT C0800159^^ 99 7000 WRITE ( PLU, 9990) TABLE(2) , TABLE(9) C0800160^^ 100 9990 FORMAT (1H0, ' END OF TABLE ', ' TOTAL TABLE LENGTH =',I4 C0800161^^ 100 1 , ' MAXIMUM TABLE LENGTH =',I4) C0800162^^ 101 RETURN C0800163^^ 102 END C0800164^t FTN 3.3B (OPT = LPC) PRTDT1 PAGE 5 DATE: 08/29/84 TIME: 2301 t  PROGRAM LENGTH $04E0 ( 1248)   EXTERNALS 2 Q8PKUP Q8PREP Q8QINI Q8QX Q8QEND AYERTO ADAYTO 22 AMONTO HORMIN UTHEAD CCSCST LAHEAD GTSDT1 GPMDT1 2 CCSPUT CCSGET  t FTN 3.3B (OPT = LPC) PRTDT1 PAGE 6 DATE: 08/29/84 TIME: 2301 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " 8001 (-32766) 00E7 41 "* FFFF (65535) 00DD 20,21,22,23*‚ 0001 (1) 0000 19,25,28,33,39,42,43,45,46,47,48,49,50,51,53,55,58,60,65,67,68,70,72,73,76,77,81,82,83,87,90,94,95 ‚B 0003 (3) 00E2 31,43,44,45,49,50,51,52,53,54,83,87B* 000A (10) 00E1 25,25,28,62*" 000F (15) 00EE 63 "" 0F00 (3840) 00ED 62 "( 2020 (8224) 00E9 44,54,59 (   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < 0 AND INTR.FN. 7FFF 20,21,22,23,62,630* BLANKS INTEGER 00CA 8,10,25,28 *2 COID INTEGER 0005 1,59,71,75,83,87,902( COMMA INTEGER 00D0 10,12,71 (, COMPIN INTEGER 00CF 8,25,26,28,29,2 CON INTEGER 005A 4,50,51,52,54,83,872, CONLIT INTEGER 0085 5,8,50,51,52 ,& CONT INTEGER 0076 5,45,49&& DT INTEGER 00C7 8,24,27&0 HD INTEGER 008B 8,24,25,27,28,31 0N I INTEGER 00E3 33,33,42,44,45,47,48,50,51,52,57,60,82,83,86,87N( I1PS INTEGER 00DB 15,18,19 (6 ICAR INTEGER 00F2 67,68,70,71,72,75,76,796* ICPRM INTEGER 7FFF 4,61,69,83 *. IDONE INTEGER 00F1 65,66,67,81,94 .( II INTEGER 00EC 61,62,64 (* IMAX INTEGER 00EB 60,61,62,63*( IPOS INTEGER 00F3 68,69,74 ($ ITMP INTEGER 00F4 74,75$$ ITY INTEGER 7FFF 14,33$. IVAL INTEGER 00F0 64,65,69,77,78 .( IWRK INTEGER 00EF 63,64,78 (< J INTEGER 00E8 42,44,53,54,58,59,63,64,73,74<6 K INTEGER 00EA 45,46,47,48,49,50,51,526. K1 INTEGER 00DC 19,20,33,83,87 .. K2 INTEGER 00DE 20,21,33,83,87 .. K3 INTEGER 00DF 21,22,33,83,87 .. K4 INTEGER 00E0 22,23,33,83,87 .* K5 INTEGER 00F5 83,83,87,90*( LIT INTEGER 00D1 12,14,33 (( LVL INTEGER 00E4 40,41,83 (t FTN 3.3B (OPT = LPC) PRTDT1 PAGE 7 DATE: 08/29/84 TIME: 2301 t$ NLVL INTEGER 00E5 40,83$6 NP INTEGER 00E6 40,42,54,56,57,83,95,966& ONP INTEGER 0004 1,56,86&: PLU INTEGER 7FFF 1,4,31,33,35,37,83,87,90,99:, PO INTEGER 0012 4,47,48,83,87,( POLIT INTEGER 0077 5,7,47,48(& POT INTEGER 0075 5,45,46&" Q8QX1 INTEGER 0001 31 "" Q8QX2 INTEGER 0002 31 "* S INTEGER 0003 1,55,57,96 *: TABLE INTEGER 7FFF 1,4,5,15,40,45,61,74,83,99 :* TESTNO INTEGER 0011 4,17,39,83 ** V1 INTEGER 0024 4,45,83,87 *, V2 INTEGER 003F 4,44,45,83,87,   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < $ CCSCST SUBROUTINE 0114 24,28$" CCSGET SUBROUTINE 02FB 73 "( CCSPUT SUBROUTINE 02BB 59,71,75 (" GPMDT1 SUBROUTINE 0257 44 "" GTSDT1 SUBROUTINE 0227 39 "" LAHEAD SUBROUTINE 0121 26 " Q8PKUP INTEGER.FN. 04B7 Q8PREP INTEGER.FN. 04B4 Q8QEND INTEGER.FN. 041E Q8QINI INTEGER.FN. 0447 0 Q8QX SUBROUTINE 0453 31,33,83,87,90,990" UTHEAD SUBROUTINE 0110 23 "   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < * 50 0131 18,26,29,31*$ 100 0224 38,98$$ 195 023E 42,44$$ 200 028D 41,52$$ 202 029B 52,54$$ 210 02AF 56,97$$ 240 02BA 57,59$$ 280 02E1 60,67$$ 290 02E8 68,79$$ 300 02F5 70,73$$ 320 0303 73,76$$ 340 0315 78,81$( 350 0317 67,80,82 ($ 420 03BE 82,86$t FTN 3.3B (OPT = LPC) PRTDT1 PAGE 8 DATE: 08/29/84 TIME: 2301 t$ 450 0446 86,90$. 500 0463 56,85,89,92,93 .$ 1000 0472 94,98$( 7000 0474 29,41,99 ($ 9700 0153 31,32$$ 9800 017C 33,34$$ 9900 01A5 35,36$$ 9901 01EC 37,38$$ 9910 038A 83,84$$ 9920 0420 87,88$$ 9930 045C 90,91$& 9990 047F 99,100 & PRTDT1 04AF 1 t FTN 3.3B (OPT = LPC) PRTSCN PAGE 1 DATE: 08/29/84 TIME: 2302 t^ 1 PROGRAM PRTSCN C1000001^^ 1 1 /C10 F CCS CCS 3.0 PSR'D SL-149********^^ C C1000003^^ C C1000004^^ C CYBERCREDIT SYSTEM VERSION 3 C1000005^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C1000006^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C1000007^^ C C1000008^^ C PRINT SCREEN TEMPLATES ON THE LINE PRINTER C1000009^^ C C1000010^^ C THIS PROGRAM FORMATS THE CONSTANTS FROM SCRNFILE IN A 40X24 C1000011^^ C (40X48-IF DOUBLE-SPACED) ARRAY JUST AS IT WOULD APPEAR ON A SCREENC1000012^^ C IF NO ACCOUNT NUMBER IS INPUT, THE FIELDS WHICH WOULD CONTAIN DATAC1000013^^ C FROM THE MASTER FILES ARE INDICATED WITH STARTING AND ENDING C1000014^^ C DELIMATORS AND, IF THERE IS ROOM BETWEEN, THE STARTING POSITION C1000015^^ C IN THE MASTER FILE IS PRINTED. C1000016^^ C C1000017^^ C IF THERE IS AN ACCOUNT NUMBER INPUT, THE ACTUAL DATA FROM THE C1000018^^ C DELINQUENT MASTER OR COSIGNER FILE IS PRINTED C1000019^^ C C1000020^^ C INTEGER VARIABLES C1000021^^ C C1000022^^ 2 INTEGER ACCTNO(8),DBLSP,SCNNAM(20),NAMLEN C1000023^^ 3 INTEGER ID(4),LU,MODE,PORT,XYN,TC,ISTAT,CLRSCR,CLRLEN,ASC0(8) C1000024^^ 4 INTEGER EOF,WRONKY,IOBUF(41),EXIT,ISVSC C1000025^^ 5 INTEGER RECORD(1000),SDEF(1000) C1000026^^ 6 INTEGER IDATDM(15),IDATCS(15),IDATSC(15) C1000027^^ 7 INTEGER REQBDM(24),REQBCS(24),REQBSC(24) C1000028^^ 8 INTEGER MSCNNO(37),MNOSCN(20),MSCNNM(16),MDBLSP(27),MACCNO(48) C1000029^^ 9 INTEGER MNOMS(62),MNOCS(63) C1000030^^ C C1000031^^ C DATA VALUES C1000032^^ C C1000033^^ 10 DATA CLRLEN/1/,CLRSCR/$1800/,EOF/$100/,WRONKY/$200/,XYN/-1/ C1000034^^ 11 DATA EXIT/'EX'/,ASC0/8*$3030/ C1000035^^ 12 DATA REQBDM/24*0/,REQBCS/24*0/,REQBSC/24*0/ C1000036^^ 13 DATA IDATDM/'DELQMST CCS20 ',1,1,0/ C1000037^^ 14 DATA IDATCS/'COSIGNERCCS20 ',1,1,0/ C1000038^^ 15 DATA IDATSC/'SCRNFILECCS20 ',1,1,0/ C1000039^^ C C1000040^^ 16 DATA MSCNNO/$D0A,'ENTER THE NUMBER OF THE SCREEN YOU WISH PRINTED C1000041^^ 16 1OR EX TO EXIT ROUTINE ',$D0A/ C1000042^^ 17 DATA MNOSCN/$D0A,'THE SCREEN NUMBER ENTERED IS INVALID',$D0A/ C1000043^^ 18 DATA MSCNNM/$D0A,'ENTER THE NAME OF THE SCREEN',$D0A/ C1000044^^ 19 DATA MDBLSP/$D0A,'DO YOU WANT THE SCREEN TO BE DOUBLE SPACED? Y ORC1000045^^ 19 1 N',$D0A/ C1000046^^ 20 DATA MACCNO/$D0A,'ENTER THE ACCOUNT NUMBER IF DATA IS TO BE PRINTEC1000047^^ 20 1D ',$D0A,' OR ONLY IF NO DATA IS TO BE USED ',$D0A/ C1000048^^ 21 DATA MNOMS/$D0A,'THERE IS NO RECORD IN THE MASTER FILE FOR THE NUMC1000049^^ 21 1BER ENTERED',$D0A,'RE-ENTER ACCOUNT NUMBER OR ONLY OR EX TO EC1000050^^ 21 2XIT ROUTINE',$D0A/ C1000051^^ 22 DATA MNOCS/$D0A,'THERE IS NO RECORD IN THE COSIGNER FILE FOR THE NC1000052^^ 22 1UMBER ENTERED',$D0A,'THE SCREEN WILL BE PRINTED WITH THE FIELD DESC1000053^^ 22 2IGNATORS '$D0A/ C1000054^t FTN 3.3B (OPT = LPC) PRTSCN PAGE 2 DATE: 08/29/84 TIME: 2302 t^ C C1000055^^ C BEGINNING OF PROGRAM C1000056^^ C C1000057^^ 23 CALL PGMIN(ID,LU,MODE,PORT) C1000058^^ C OPEN THE FILES C1000059^^ 24 CALL OPENFL(REQBSC,IDATSC,ISTAT) C1000060^^ 25 IF(ISTAT.GE.0) GO TO 10 C1000061^^ 26 CALL FILERR(IDATSC,3,ISTAT,LU) C1000062^^ 27 GO TO 900 C1000063^^ 28 10 CALL OPENFL(REQBDM,IDATDM,ISTAT) C1000064^^ 29 IF(ISTAT.GE.0) GO TO 20 C1000065^^ 30 CALL FILERR(IDATDM,3,ISTAT,LU) C1000066^^ 31 GO TO 900 C1000067^^ 32 20 CALL OPENFL(REQBCS,IDATCS,ISTAT) C1000068^^ 33 IF(ISTAT.GE.0) GO TO 40 C1000069^^ 34 CALL FILERR(IDATCS,3,ISTAT,LU) C1000070^^ 35 GO TO 900 C1000071^^ C C1000072^^ C CLEAR THE SCREEN C1000073^^ 36 40 CALL WTREAD(LU,XYN,CLRSCR,CLRLEN,0,0,0,TC) C1000074^^ C C1000075^^ C PROMPT FOR SCREEN NUMBER C1000076^^ C C1000077^^ 37 50 CALL WTREAD(LU,XYN,MSCNNO,74,XYN,IOBUF,80,TC) C1000078^^ C CHECK FOR END OF ROUTINE C1000079^^ 38 60 IF(IOBUF(1).EQ.EXIT) GO TO 800 C1000080^^ C GET RECORD FROM SCREENFILE C1000081^^ 39 ISVSC = ICCSAD(IOBUF(1)) C1000082^^ C IF REQUEST IS FOR COSIGNER SCREEN(WHICH IS IN TWO PARTS) FORCE C1000083^^ C TO PRINT THE FIRST PART FIRST C1000084^^ 40 IF(ISVSC.EQ.94) ISVSC = 04 C1000085^^ 41 CALL READR(REQBSC,SDEF,ISVSC,ISTAT) C1000086^^ 42 IF(AND(ISTAT,WRONKY).EQ.WRONKY.OR.AND(ISTAT,EOF).EQ.EOF) GO TO 70 C1000087^^ C CHECK FOR OTHER ERROR C1000088^^ 43 IF(ISTAT.GE.0) GO TO 100 C1000089^^ 44 CALL FILERR(IDATSC,13,ISTAT,LU) C1000090^^ 45 GO TO 900 C1000091^^ C SCREEN NUMBER NOT IN SCREENFILE C1000092^^ 46 70 CALL WTREAD(LU,XYN,MNOSCN,40,0,0,0,TC) C1000093^^ 47 GO TO 50 C1000094^^ C C1000095^^ C PROMPT FOR SCREEN NAME C1000096^^ C C1000097^^ 48 100 CALL WTREAD(LU,XYN,MSCNNM,32,XYN,IOBUF,80,TC) C1000098^^ C THIS NAME WILL BE CENTERED BELOW THE SCREEN PRINTED C1000099^^ 49 NAMLEN = IOBUF(41) C1000100^^ 50 CALL CCSMVA(IOBUF,1,NAMLEN,SCNNAM,1,NAMLEN) C1000101^^ C C1000102^^ C PROMPT FOR DOUBLE SPACING C1000103^^ C C1000104^^ 51 CALL WTREAD(LU,XYN,MDBLSP,54,XYN,IOBUF,80,TC) C1000105^^ 52 DBLSP = IOBUF(1) C1000106^^ C C1000107^^ C PROMPT FOR ACCOUNT NUMBER C1000108^t FTN 3.3B (OPT = LPC) PRTSCN PAGE 3 DATE: 08/29/84 TIME: 2302 t^ C C1000109^^ 53 CALL WTREAD(LU,XYN,MACCNO,96,XYN,IOBUF,80,TC) C1000110^^ 54 IF(IOBUF(41).EQ.0) GO TO 120 C1000111^^ C ****************************************************** ???*A021********^^ 55 105 ILN = IOBUF(41) ********^^ 56 CALL CCSBLK (ACCTNO, 16) ********^^ 57 CALL CCSMVA (IOBUF, 1, ILN, ACCTNO, 1, 16) ********^^ C ****************************************************** ???*A021********^^ 58 CALL READR(REQBDM,RECORD,ACCTNO,ISTAT) C1000113^^ 59 IF(AND(ISTAT,WRONKY).EQ.WRONKY.OR.AND(ISTAT,EOF).EQ.EOF) GO TO 110C1000114^^ C CHECK FOR OTHER ERROR C1000115^^ 60 IF(ISTAT.GE.0) GO TO 150 C1000116^^ 61 CALL FILERR(IDATDM,13,ISTAT,LU) C1000117^^ 62 GO TO 900 C1000118^^ C C1000119^^ C ACCOUNT NOT FOUND C1000120^^ C C1000121^^ 63 110 CALL WTREAD(LU,XYN,MNOMS,124,XYN,IOBUF,80,TC) C1000122^^ 64 IF(IOBUF(1).EQ.EXIT) GO TO 800 C1000123^^ 65 IF(IOBUF(41).EQ.0) GO TO 120 C1000124^^ 66 GO TO 105 C1000125^^ 67 120 CALL CCSMVA(ASC0,1,16,ACCTNO,1,16) C1000126^^ 68 150 CALL PRNTIT(RECORD,ACCTNO,DBLSP,SCNNAM,NAMLEN,SDEF) C1000127^^ 69 IF(ISVSC.NE.04) GO TO 50 C1000128^^ C IS A COSIGNER SCREEN--- PRINT SECOND HALF C1000129^^ 70 ISVSC = 94 C1000130^^ C READ SCREENFILE C1000131^^ 71 CALL READR(REQBSC,SDEF,ISVSC,ISTAT) C1000132^^ 72 IF(AND(ISTAT,WRONKY).EQ.WRONKY.OR.AND(ISTAT,EOF).EQ.EOF) GO TO 160C1000133^^ C CHECK FOR OTHER ERROR C1000134^^ 73 IF(ISTAT.GE.0) GO TO 165 C1000135^^ 74 CALL FILERR(IDATSC,13,ISTAT,LU) C1000136^^ 75 GO TO 900 C1000137^^ C SCREEN NOT FOUND C1000138^^ 76 160 CALL WTREAD(LU,XYN,MNOSCN,40,0,0,0,TC) C1000139^^ 77 GO TO 60 C1000140^^ C GET RECORD FOR COSIGNER FILE IF ACCOUNT NUMBER ENTERED C1000141^^ 78 165 CALL CCSCST(ACCTNO,1,16,ASC0,1,16,L) C1000142^^ 79 IF(L.LE.0) GO TO 190 C1000143^^ 80 170 CALL READR(REQBCS,RECORD,ACCTNO,ISTAT) C1000144^^ 81 IF(AND(ISTAT,WRONKY).EQ.WRONKY.OR.AND(ISTAT,EOF).EQ.EOF) GO TO 175C1000145^^ C CHECK FOR OTHER ERROR C1000146^^ 82 IF(ISTAT.GE.0) GO TO 190 C1000147^^ 83 CALL FILERR(IDATSC,13,ISTAT,LU) C1000148^^ 84 GO TO 900 C1000149^^ C C1000150^^ C NO COSIGNER RECORD C1000151^^ C C1000152^^ 85 175 CALL WTREAD(LU,XYN,MNOCS,126,0,0,0,TC) C1000153^^ 86 CALL CCSMVA(ASC0,1,16,ACCTNO,1,16) C1000154^^ 87 190 CALL PRNTIT(RECORD,ACCTNO,DBLSP,SCNNAM,NAMLEN,SDEF) C1000155^^ 88 GO TO 50 C1000156^^ C C1000157^^ 89 800 CALL CLOSFL(REQBDM,ISTAT) C1000158^t FTN 3.3B (OPT = LPC) PRTSCN PAGE 4 DATE: 08/29/84 TIME: 2302 t^ 90 CALL CLOSFL(REQBSC,ISTAT) C1000159^^ 91 CALL CLOSFL(REQBCS,ISTAT) C1000160^^ 92 900 CALL PGMOUT C1000161^^ 93 END C1000162^t FTN 3.3B (OPT = LPC) PRTSCN PAGE 5 DATE: 08/29/84 TIME: 2302 t  PROGRAM LENGTH $0B47 ( 2887)   EXTERNALS 2 Q8STP PGMIN OPENFL FILERR WTREAD ICCSAD READR 2, CCSMVA CCSBLK PRNTIT CCSCST CLOSFL PGMOUT , t FTN 3.3B (OPT = LPC) PRTSCN PAGE 6 DATE: 08/29/84 TIME: 2302 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < T 0000 (0) 0003 12,13,14,15,25,29,33,36,43,46,54,60,65,73,76,79,82,85TF 0001 (1) 0002 10,13,14,15,38,39,50,52,57,64,67,78,86 F( 0003 (3) 09B9 26,30,34 (* 000D (13) 09BC 44,61,74,83*. 0010 (16) 09C2 56,57,67,78,86 ." 0020 (32) 09BE 48 "$ 0028 (40) 09BD 46,76$" 0036 (54) 09BF 51 "" 004A (74) 09BA 37 ". 0050 (80) 09BB 37,48,51,53,63 ." 0060 (96) 09C0 53 "" 007C (124) 09C3 63 "" 007E (126) 09C5 85 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < < ACCTNO INTEGER 0004 1,56,57,58,67,68,78,80,86,87 <. AND INTR.FN. 7FFF 42,42,59,72,81 ., ASC0 INTEGER 002E 1,11,67,78,86,& CLRLEN INTEGER 002D 1,10,36&& CLRSCR INTEGER 002C 1,10,36&* DBLSP INTEGER 000C 1,52,68,87 *0 EOF INTEGER 0036 1,10,42,59,72,81 0* EXIT INTEGER 0061 1,11,38,64 *$ ID INTEGER 0022 1,23 $* IDATCS INTEGER 0842 1,14,32,34 *, IDATDM INTEGER 0833 1,13,28,30,61,2 IDATSC INTEGER 0851 1,15,24,26,44,74,832( ILN INTEGER 09C1 54,55,57 (N IOBUF INTEGER 0038 1,37,38,39,48,49,50,51,52,53,54,55,57,63,64,65 Nt ISTAT INTEGER 002B 1,24,25,26,28,29,30,32,33,34,41,42,43,44,58,59,60,61,71,72,73,74,80,81,82,83,89,90,91t2 ISVSC INTEGER 0062 1,39,40,41,69,70,712$ L INTEGER 09C4 78,79$T LU INTEGER 0026 1,23,26,30,34,36,37,44,46,48,51,53,61,63,74,76,83,85 T& MACCNO INTEGER 090C 1,20,53&& MDBLSP INTEGER 08F1 1,19,51&& MNOCS INTEGER 097A 1,22,85&& MNOMS INTEGER 093C 1,21,63&* MNOSCN INTEGER 08CD 1,17,46,76 *$ MODE INTEGER 0027 1,23 $& MSCNNM INTEGER 08E1 1,18,48&& MSCNNO INTEGER 08A8 1,16,37&t FTN 3.3B (OPT = LPC) PRTSCN PAGE 7 DATE: 08/29/84 TIME: 2302 t, NAMLEN INTEGER 0021 1,49,50,68,87,$ PORT INTEGER 0028 1,23 $, RECORD INTEGER 0063 1,58,68,80,87,, REQBCS INTEGER 0878 1,12,32,80,91,, REQBDM INTEGER 0860 1,12,28,58,89,0 REQBSC INTEGER 0890 1,12,24,41,71,90 0* SCNNAM INTEGER 000D 1,50,68,87 *, SDEF INTEGER 044B 1,41,68,71,87,< TC INTEGER 002A 1,36,37,46,48,51,53,63,76,85 <0 WRONKY INTEGER 0037 1,10,42,59,72,81 0> XYN INTEGER 0029 1,10,36,37,46,48,51,53,63,76,85>   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " CCSBLK SUBROUTINE 0A77 55 "" CCSCST SUBROUTINE 0AF4 78 "* CCSMVA SUBROUTINE 0B29 49,57,67,86*( CLOSFL SUBROUTINE 0B3A 89,90,91 (4 FILERR SUBROUTINE 0B18 25,30,34,44,61,74,83 4" ICCSAD INTEGER.FN. 0A15 39 "( OPENFL SUBROUTINE 09CD 23,28,32 (" PGMIN SUBROUTINE 09C7 22 "" PGMOUT SUBROUTINE 0B44 92 "$ PRNTIT SUBROUTINE 0ABC 68,87$ Q8STP INTEGER.FN. 0B46 * READR SUBROUTINE 0ACC 40,58,71,80*: WTREAD SUBROUTINE 0B1F 36,37,46,48,51,53,63,76,85 :   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 10 09DD 25,28$$ 20 09EB 29,32$$ 40 09F9 33,36$* 50 0A03 36,47,69,88*$ 60 0A0C 37,77$$ 70 0A3B 42,46$$ 100 0A45 43,48$$ 105 0A73 54,66$$ 110 0A9E 59,63$( 120 0AB4 54,65,67 ($ 150 0ABB 60,68$$ 160 0AE8 72,76$$ 165 0AF3 73,78$" 170 0B02 79 "$ 175 0B1E 81,85$( 190 0B30 79,82,87 (t FTN 3.3B (OPT = LPC) PRTSCN PAGE 8 DATE: 08/29/84 TIME: 2302 t( 800 0B39 38,64,89 (6 900 0B43 26,31,35,45,62,75,84,926 PRTSCN 0000 1 t FTN 3.3B (OPT = LPC) QLOAD PAGE 1 DATE: 08/29/84 TIME: 2302 t^ 1 PROGRAM QLOAD C1100001^^ 1 1 /C11 F CCS CCS 3.0 .LA - PSRD SL-149********^^ C C1100003^^ C CYBERCREDIT SYSTEM VERSION 3 C1100004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C1100005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C1100006^^ C C1100007^ ^ C THIS PROGRAM COMPUTES THE AGE OF THE NEXT CONTACT DATES FROM C1100009^^ C THE DAILY ASSIGNMENT FILE (DLYASSN). A REPORT IS GENERATED C1100010^^ C TO REFLECT THE LOADING IN EACH QUEUE. C1100011^ ^ C THE DLYASSN FILE IS READ SEQUENTIALLY 20 RECORDS AT A TIME. FOR C1100013^^ C EACH RECORD, THE NEXT CONTACT AGE IS COMPUTED. AFTER A CHANGE C1100014^^ C IN QUEUE IS DETECTED, A RECORD IS PRINTED (IF THE PROGRAM WAS RAN C1100015^^ C FROM THE MASTER TERMINAL) OR DISPLAYED TO THE USERS CONSOLE (IF C1100016^^ C THE PROGRAM WAS RAN FROM A USER TERMINAL). TOTALS ARE GENERATED C1100017^^ C FOR EACH QUEUE AS WELL AS REPORT TOTALS FOR EACH NEXT CONTACT C1100018^^ C AGE CATAGORY. C1100019^ ^ 2 INTEGER AGE, AGE1, BLK, CLS, COUNT C1100021^^ 3 INTEGER DT(3), DLYREQ(24), DDATA(15), DLYREC(402) C1100022^^ 4 INTEGER EOF, HDR(60), IDUSER(4), IBUF(3) C1100023^^ 5 INTEGER MSG1(22), MSG2(6), PAGE, PRT, PRTSW C1100024^^ 6 INTEGER Q(7), QT(7), QUEUE(2), QPRT(28), ZERO C1100025^^ 7 INTEGER ALLDON C1100026^^ 8 INTEGER DT2(3) C1100027^^ 9 INTEGER LINCT ***00028^^ 10 DATA LINCT/0/ ***00029^ ^ 11 DATA BLK/$2020/, CLS/$1820/, COUNT/0/, DLYREQ/24*0/ C1100031^^ 12 INTEGER DDAT(4) ********^^ 13 DATA DDAT/'DLYASSN '/ ********^^ 14 DATA DDATA/'LADLYASN',8*$2020,0,20,0/, ITC/0/ ********^^ 15 DATA EOF/0/ C1100033^^ 16 DATA MSG1/$0A0D,'ENTER DATE (MMDDYY) OR CR FOR SYSTEM DATE '/ C1100034^^ 17 DATA MSG2/$000D,'READY (CR)'/ C1100035^^ 18 DATA PAGE/0/, PRT/$100C/, Q/7*0/, QT/7*0/, ZERO/$3030/ C1100036^^ 19 DATA ALLDON / 0 / C1100037^^ C********************************************************** ???*A001********^^ 20 INTEGER QTMSB(7) ********^^ 21 DATA QTMSB/7*0/ ********^^ C********************************************************** ???*A001********^t FTN 3.3B (OPT = LPC) QLOAD PAGE 2 DATE: 08/29/84 TIME: 2302 t^ 22 CALL PGMIN(IDUSER,LUNIT,MODE,NOPORT) C1100039^^ 23 CALL CCSCST(DDATA,1,2,IDUSER,1,8,ICM) ********^^ 24 IF(ICM.NE.0) CALL CCSMVA(DDAT,1,8,DDATA,1,8) ********^^ C TEST PORT NUMBER C1100040^^ 25 IF(NOPORT.EQ.0) PRTSW=1 C1100041^^ 26 IF(NOPORT.NE.0) PRTSW=0 C1100042^ ^ C OPEN THE DLYASSN FILE C1100044^^ 27 100 CALL OPENFL(DLYREQ,DDATA,ISTAT) C1100045^^ 28 IF(ISTAT.GE.0) GO TO 120 C1100046^^ 29 CALL FILERR(DDATA,3,ISTAT,LUNIT) C1100047^^ 30 GO TO 950 C1100048^ ^ C BRING IN HEADERS AND TODAYS DATE C1100050^^ 31 120 WRITE(LUNIT,121)CLS C1100051^^ 32 121 FORMAT(A2,2X,'QUEUE LOADING REPORT',//) C1100052^^ 33 CALL UTHEAD(HDR,DT) C1100053^^ 34 CALL CCSMVA(DT,1,6,DT2,1,6) C1100054^ ^ C GET DATE FROM USER C1100056^^ 35 130 IBUF(1)=$2020 C1100057^^ 36 CALL WTREAD(LUNIT,-1,MSG1,44,-1,IBUF,6,ITC) C1100058^^ 37 IF(IBUF(1).EQ.$2020.AND.ITC.EQ.2) GO TO 140 C1100059^^ 38 IF(IBUF(4).NE.6) GO TO 130 C1100060^^ 39 IF(IDATVR(IBUF,1).LT.0) GO TO 130 C1100061^^ 40 CALL CCSMVA(IBUF,1,6,DT,1,6) ***00062^^ 41 CALL CCSMVA(IBUF,1,6,DT2,1,6) C1100063^ ^ C CONVERT TO JULIAN AND VERIFY C1100065^^ 42 140 JLDT=ICALJL(DT2,1) C1100066^^ 43 IF(JLDT.LT.0) GO TO 130 C1100067^^ 44 JLDTYR=ICCSAD(DT2(3)) C1100068^t FTN 3.3B (OPT = LPC) QLOAD PAGE 3 DATE: 08/29/84 TIME: 2302 t^ C READ 20 RECORDS C1100070^^ 45 160 CALL CCSBLK(DLYREC,800) C1100071^^ 46 CALL GETS(DLYREQ,DLYREC,DLYREC,ISTAT) C1100072^ ^ C END OF FILE? C1100074^^ 47 IF(AND(ISTAT,$8100).EQ.$8100) GO TO 190 C1100075^^ 48 IF(AND(ISTAT,$100).EQ.$100) GO TO 180 C1100076^ ^ C ERROR? C1100078^^ 49 IF(ISTAT.GE.0) GO TO 200 C1100079^^ 50 CALL FILERR(DDATA,14,ISTAT,LUNIT) C1100080^^ 51 GO TO 950 C1100081^ ^ C SET END OF FILE SWITCH C1100083^^ 52 180 EOF=1 C1100084^^ 53 GO TO 200 C1100085^ ^ C PRINT LAST QUEUE C1100087^^ 54 190 EOF=2 C1100088^^ 55 GO TO 230 C1100089^ ^ C PROCESS A RECORD C1100091^^ 56 200 NREC=DLYREQ(15) C1100092^^ 57 DO 480 I=1,NREC C1100093^ ^ C SET UP POINTER TO BEGINNING OF RECORD -1 C1100095^^ 58 205 J=(I-1)*40 C1100096^^ 59 JJ=(I-1)*20 C1100097^^ 60 COUNT=COUNT+1 C1100098^^ C CHECK FOR END OF READ C1100099^^ 61 210 IF(DLYREC(JJ+1).EQ.BLK) GO TO 230 C1100100^ ^ C FIRST PASS- SET UP QUEUE WORK FIELD C1100102^^ 62 215 IF(COUNT.NE.1) GO TO 220 C1100103^^ 63 CALL CCSMVA(DLYREC,J+17,4,QUEUE,1,4) C1100104^ ^ C COMPARE FOR QUEUE CHANGE C1100106^^ 64 220 CALL CCSCST(DLYREC,J+17,4,QUEUE,1,4,ICOMP) C1100107^^ 65 IF(ICOMP.EQ.0) GO TO 440 C1100108^t FTN 3.3B (OPT = LPC) QLOAD PAGE 4 DATE: 08/29/84 TIME: 2302 t ^ C CHANGE OF QUEUE PRINT OF DISPLAY INFO C1100111^^ C EDIT QUEUE COUNTS AND TOTALS C1100112^^ 66 230 DO 250 II=1,7 C1100113^^ 67 IJ=II+((II-1)*2) C1100114^^ 68 CALL HEXDEC(Q(II),QPRT(IJ)) C1100115^^ 69 DO 240 III=1,7 C1100116^^ 70 CALL CCSCST(QPRT(IJ),III,1,ZERO,1,1,ICOMP) C1100117^^ 71 IF(ICOMP.NE.0) GO TO 250 C1100118^^ 72 CALL CCSMVA(BLK,1,1,QPRT(IJ),III,1) C1100119^^ 73 240 CONTINUE C1100120^^ 74 250 CONTINUE C1100121^ ^ C CHECK FOR PRINTER OR CONSOLE C1100123^^ 75 IF(PRTSW.EQ.0) GO TO 300 C1100124^ ^ C OUTPUT TO PRINTER C1100126^^ 76 IF(LINCT.NE.0.AND.LINCT.LT.56) GO TO 280 C1100127^ ^ C PRINT HEADINGS C1100129^^ 77 260 PAGE=PAGE+1 C1100130^^ 78 WRITE(PRT,261)(HDR(K),K=1,20) C1100131^^ 79 261 FORMAT(1H1,2X,20A2) C1100132^^ 80 WRITE(PRT,262)(HDR(K),K=21,40),PAGE C1100133^^ 81 262 FORMAT(1H ,2X,20A2,10X,'QUEUE LOADING REPORT',35X,'PAGE: ',I2) C1100134^^ 82 WRITE(PRT,263)(HDR(K),K=41,60),DT(1),DT(2),DT(3) C1100135^^ 83 263 FORMAT(1H ,2X,20A2,13X,'AS OF: ',A2,'/',A2,'/',A2,/) C1100136^^ 84 WRITE(PRT,264) C1100137^^ 85 264 FORMAT(1H ,48X,'NEXT CONTACT DATE AGE BY DAYS',/,10X,'QUEUE', ***00138^^ 85 115X,'-0',9X,'0',9X,'1',9X,'2',9X,'3',8X,'+3',9X,'TOTALS',/) ***00139^ ^ 86 LINCT=7 C1100141^ ^ C PRINT DETAIL LINE C1100143^^ 87 280 WRITE(PRT,281)QUEUE(1),QUEUE(2),(QPRT(K),K=1,21) C1100144^^ 88 281 FORMAT(1H ,9X,2A2,12X,6(3A2,4X),4X,3A2) C1100145^^ 89 LINCT=LINCT+1 C1100146^^ 90 GO TO 400 C1100147^  ^ C DISPLAY TO CONSOLE C1100150^^ 91 300 IF(LINCT.NE.0.AND.LINCT.LE.14) GO TO 340 C1100151^ ^ C DISPLAY HEADINGS C1100153^^ 92 PAGE=PAGE+1 C1100154^^ 93 320 WRITE(LUNIT,321)CLS,PAGE,DT(1),DT(2),DT(3) C1100155^^ 94 321 FORMAT(1H ,A2,28X,'QUEUE LOADING REPORT',16X,'PAGE: ',I2,/,32X, C1100156^^ 94 .'AS OF: ',A2,'/',A2,'/',A2,/) C1100157^^ 95 WRITE(LUNIT,322) C1100158^^ 96 322 FORMAT(1H ,24X,'NEXT CONTACT DATE AGE BY DAYS') ***00159^^ 97 WRITE(LUNIT,323) C1100160^^ 98 323 FORMAT(1H ,4X,'QUEUE',7X,'-0',6X,'0',6X,'1',6X,'2',6X,'3',5X, ***00161^^ 98 1'+3',5X,'TOTALS',/) ***00162^ t FTN 3.3B (OPT = LPC) QLOAD PAGE 5 DATE: 08/29/84 TIME: 2302 t^ 99 LINCT=6 C1100164^ ^ C DISPLAY DETAIL LINE C1100166^^ 100 340 WRITE(LUNIT,341)QUEUE(1),QUEUE(2),(QPRT(K),K=1,21) C1100167^^ 101 341 FORMAT(1H ,4X,2A2,4X,6(3A2,1X),3X,3A2,/) C1100168^^ 102 LINCT=LINCT+1 C1100169^ ^ C PAUSE UNTIL CARRIAGE RETURN C1100171^^ 103 350 IF(LINCT.LE.14) GO TO 400 C1100172^ ^ C SEE IF READY C1100174^^ 104 390 IBUF(1)=$2020 C1100175^^ 105 CALL WTREAD(LUNIT,-1,MSG2,12,-1,IBUF,1,ITC) C1100176^^ 106 IF(ITC.NE.2) GO TO 390 C1100177^^ 107 LINCT=0 C1100178^ ^ C CLEAR Q COUNTS FOR NEXT QUEUE C1100180^^ 108 400 DO 420 II=1,7 C1100181^^ 109 Q(II)=0 C1100182^^ 110 420 CONTINUE C1100183^ ^ C SET UP QUEUE WORK AREA C1100185^^ 111 CALL CCSMVA(DLYREC,J+17,4,QUEUE,1,4) C1100186^^ 112 430 IF(EOF.EQ.2.OR.ALLDON.NE.0) GO TO 510 C1100187^t FTN 3.3B (OPT = LPC) QLOAD PAGE 6 DATE: 08/29/84 TIME: 2302 t^ C COMPUTE AGE C1100189^^ 113 440 JLNXTC=ICALJL(DLYREC,J+21) C1100190^^ 114 JLNXYR=ICCSAD(DLYREC(JJ+13)) C1100191^ ^ C CHECK FOR INVALID NEXT CONTACT DATE C1100193^^ 115 IF(JLNXTC.LT.0) GO TO 480 C1100194^^ 116 IJLDT = JLDT ***00195^^ 117 IF (JLDTYR.GT.JLNXYR)IJLDT =IJLDT+((JLDTYR-JLNXYR)*365) ***00196^^ 118 IF (JLNXYR.GT.JLDTYR) JLNXTC =JLNXTC+((JLNXYR-JLDTYR)*365) ***00197^^ 119 AGE=JLNXTC-IJLDT ***00198^ ^ C FIND WHERE AGE GOES IN Q ARRAY C1100200^^ 120 460 IF(AGE.GE.0.AND.AGE.LE.3) AGE1=AGE+2 C1100201^^ 121 IF(AGE.LT.0) AGE1=1 C1100202^^ 122 IF(AGE.GT.3) AGE1=6 C1100203^ ^ C ADD 1 TO CORRECT Q ARRAY ELEMENT C1100205^^ 123 Q(AGE1)=Q(AGE1)+1 C1100206^ ^ C ADD 1 TO TOTALS C1100208^^ 124 Q(7)=Q(7)+1 C1100209^^ 125 QT(AGE1)=QT(AGE1)+1 C1100210^^ C********************************************************** ???*A001********^^ C........USE MSB MODULO 30000 TO IMPLEMENT DOUBLE PRCISION ARITHMETIC ********^^ 126 IF (QT(AGE1) .LT. 30000) GO TO 470 ********^^ 127 QT(AGE1) = 0 ********^^ 128 QTMSB(AGE1) = QTMSB(AGE1) + 1 ********^^ 129 470 QT(7) = QT(7) + 1 ********^^ 130 IF (QT(7) .LT. 30000) GO TO 474 ********^^ 131 QT(7) = 0 ********^^ 132 QTMSB(7) = QTMSB(7) + 1 ********^^ 133 474 CONTINUE ********^^ C********************************************************** ???*A001********^ ^ 134 480 CONTINUE C1100213^t FTN 3.3B (OPT = LPC) QLOAD PAGE 7 DATE: 08/29/84 TIME: 2302 t^ C CHECK IF EOF WAS READ LAST RUN C1100215^^ 135 500 IF(EOF.EQ.0) GO TO 160 C1100216^ ^ C END OF FILE SEND BACK TO PRINT LAST QUEUE C1100218^^ 136 IF(EOF.NE.1) GO TO 510 C1100219^^ 137 ALLDON = 1 C1100220^^ 138 GO TO 230 C1100221^ ^ C PRINT TOTALS C1100223^^ 139 510 DO 530 II=1,7 C1100224^^ 140 IJ=II+((II-1)*2) C1100225^^ 141 CALL HEXDEC(QT(II),QPRT(IJ)) C1100226^^ C********************************************************** ???*A001********^^ 142 IF (QTMSB(II) .EQ. 0) GO TO 515 ********^^ C.........'QTMSB' = NO. OF MULTIPLES OF 30000. ********^^ C......... (ADJUST 10**4 DIGIT ONLY) ********^^ 143 QPRT(IJ) = $2030 + QTMSB(II)*3 + AND(QPRT(IJ),$F) ********^^ 144 515 CONTINUE ********^^ C********************************************************** ???*A001********^^ 145 DO 520 III=1,7 C1100227^^ 146 CALL CCSCST(QPRT(IJ),III,1,ZERO,1,1,ICOMP) C1100228^^ 147 IF(ICOMP.NE.0) GO TO 530 C1100229^^ 148 CALL CCSMVA(BLK,1,1,QPRT(IJ),III,1) C1100230^^ 149 520 CONTINUE C1100231^^ 150 530 CONTINUE C1100232^ ^ C PRINT OR DISPLAY? C1100234^^ 151 IF(PRTSW.EQ.0) GO TO 560 C1100235^ ^ C PRINT C1100237^^ 152 540 WRITE(PRT,541)(QPRT(K),K=1,21) C1100238^^ 153 541 FORMAT(1H ,/,10X,'TOTALS',10X,6(3A2,4X),4X,3A2) C1100239^^ 154 GO TO 950 C1100240^ ^ C DISPLAY C1100242^^ 155 560 WRITE(LUNIT,561)(QPRT(K),K=1,21) C1100243^^ 156 561 FORMAT(1H ,4X,'TOTALS',2X,6(3A2,1X),3X,3A2,//) C1100244^^ 157 GO TO 950 C1100245^ ^ C END CLOSE DLYASSN FILE C1100247^^ 158 950 CALL CLOSFL(DLYREQ,ISTAT) C1100248^^ 159 990 CALL PGMOUT C1100249^^ 160 STOP C1100250^^ 161 END C1100251^t FTN 3.3B (OPT = LPC) QLOAD PAGE 8 DATE: 08/29/84 TIME: 2302 t  PROGRAM LENGTH $06F7 ( 1783)   EXTERNALS 2 Q8STP Q8QINI Q8QX Q8QEND PGMIN CCSCST CCSMVA 22 OPENFL FILERR UTHEAD WTREAD IDATVR ICALJL ICCSAD 2& CCSBLK GETS HEXDEC CLOSFL PGMOUT & t FTN 3.3B (OPT = LPC) QLOAD PAGE 9 DATE: 08/29/84 TIME: 2302 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < $ 8100 (-32511) 0274 47,47$( FFFE (-1) 026F 36,36,105(€ 0001 (1) 0002 23,24,25,34,35,36,37,39,40,41,42,52,57,58,59,60,61,62,63,64,66,67,69,70,72,77,78,82,87,89,92,93, €v 100,102,104,105,108,111,121,123,124,125,128,129,132,136,137,139,140,145,146,148,152,155vH 0002 (2) 0268 23,37,54,67,82,87,93,100,106,112,120,140 H6 0003 (3) 026C 29,44,82,93,120,122,1436, 0004 (4) 027D 63,63,64,111 ,8 0006 (6) 026D 34,34,36,38,40,41,99,122 8$ 0008 (8) 0269 23,24$" 000C (12) 0283 105"( 000E (14) 0276 50,91,103(" 000F (15) 028A 143"$ 0014 (20) 027C 59,78$$ 0028 (40) 027A 58,80$" 002C (44) 0270 36 "$ 0100 (256) 0275 48,48$& 016D (365) 0287 117,118&" 0320 (800) 0273 45 "( 2020 (8224) 026E 35,37,104(" 2030 (8240) 0289 143"& 7530 (30000) 0288 126,130&   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < 0 AGE INTEGER 0003 1,119,120,121,1220@ AGE1 INTEGER 0004 1,120,121,122,123,125,126,127,128@, ALLDON INTEGER 0254 1,19,112,137 ,( AND INTR.FN. 7FFF 47,48,143(. BLK INTEGER 0005 1,11,61,72,148 .* CLS INTEGER 0006 1,11,31,93 ** COUNT INTEGER 0007 1,11,60,62 *( DDAT INTEGER 0259 11,13,24 (2 DDATA INTEGER 0023 1,14,23,24,27,29,502< DLYREC INTEGER 0032 1,45,46,61,63,64,111,113,114 <0 DLYREQ INTEGER 000B 1,11,27,46,56,15800 DT INTEGER 0008 1,33,34,40,82,93 0, DT2 INTEGER 0255 1,34,41,42,44,6 EOF INTEGER 01C4 1,15,52,54,112,135,136 6, HDR INTEGER 01C5 1,33,78,80,82,( I INTEGER 0278 56,58,59 (> IBUF INTEGER 0205 1,35,36,37,38,39,40,41,104,105 >$ ICM INTEGER 026A 23,24$t FTN 3.3B (OPT = LPC) QLOAD PAGE 10 DATE: 08/29/84 TIME: 2302 t2 ICOMP INTEGER 027E 64,65,70,71,146,1472& IDUSER INTEGER 0201 1,22,23&D II INTEGER 027F 66,67,68,108,109,139,140,141,142,143 D4 III INTEGER 0281 68,70,72,145,146,148 4B IJ INTEGER 0280 66,67,68,70,72,140,141,143,146,148 B. IJLDT INTEGER 0286 115,116,117,119.: ISTAT INTEGER 026B 27,28,29,46,47,48,49,50,158:0 ITC INTEGER 025D 14,36,37,105,106 02 J INTEGER 0279 57,58,63,64,111,1132, JJ INTEGER 027B 58,59,61,114 ,, JLDT INTEGER 0271 42,42,43,116 ,, JLDTYR INTEGER 0272 43,44,117,118,2 JLNXTC INTEGER 0284 113,113,115,118,1192. JLNXYR INTEGER 0285 113,114,117,118.: K INTEGER 0282 78,78,80,82,87,100,152,155 :> LINCT INTEGER 0258 1,10,76,86,89,91,99,102,103,107>B LUNIT INTEGER 0265 22,29,31,36,50,93,95,97,100,105,155B" MODE INTEGER 0266 22 "& MSG1 INTEGER 0208 1,16,36&( MSG2 INTEGER 021E 1,17,105 (( NOPORT INTEGER 0267 22,25,26 (( NREC INTEGER 0277 56,56,57 (0 PAGE INTEGER 0224 1,18,77,80,92,93 06 PRT INTEGER 0225 1,18,78,80,82,84,87,1526. PRTSW INTEGER 0226 1,25,26,75,151 .2 Q INTEGER 0227 1,18,68,109,123,1242H QPRT INTEGER 0237 1,68,70,72,87,100,141,143,146,148,152,155H@ QT INTEGER 022E 1,18,125,126,127,129,130,131,141 @4 QTMSB INTEGER 025E 19,21,128,132,142,14342 QUEUE INTEGER 0235 1,63,64,87,100,111 2* ZERO INTEGER 0253 1,18,70,146*   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " CCSBLK SUBROUTINE 0327 44 ", CCSCST SUBROUTINE 0670 22,64,70,146 ,8 CCSMVA SUBROUTINE 0682 24,34,40,41,63,72,111,1488" CLOSFL SUBROUTINE 06F0 158"$ FILERR SUBROUTINE 0340 28,50$" GETS SUBROUTINE 032B 45 "& HEXDEC SUBROUTINE 0650 67,141 && ICALJL INTEGER.FN. 05D4 42,113 && ICCSAD INTEGER.FN. 05DF 44,114 &" IDATVR INTEGER.FN. 0304 39 "" OPENFL SUBROUTINE 02B1 26 "" PGMIN SUBROUTINE 028C 21 "" PGMOUT SUBROUTINE 06F4 158" Q8QEND INTEGER.FN. 06AE Q8QINI INTEGER.FN. 0699 < Q8QX SUBROUTINE 06A6 31,78,80,82,87,93,100,152,155<t FTN 3.3B (OPT = LPC) QLOAD PAGE 11 DATE: 08/29/84 TIME: 2302 t Q8STP INTEGER.FN. 06F6 " UTHEAD SUBROUTINE 02DE 32 "& WTREAD SUBROUTINE 059D 35,105 &   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < " 100 02B0 26 "$ 120 02C0 28,31$$ 121 02CC 31,32$* 130 02E8 34,38,39,43*$ 140 0318 37,42$& 160 0326 44,135 &$ 180 0347 48,52$$ 190 034B 47,54$( 200 034E 49,53,56 (" 205 035A 57 "" 210 0368 60 "" 215 0370 61 "$ 220 037F 62,64$, 230 0391 54,61,66,138 ,$ 240 03C3 68,73$( 250 03C8 66,71,74 (" 260 03DC 76 "$ 261 03F7 78,79$$ 262 0414 80,81$$ 263 044B 82,83$$ 264 0469 84,85$$ 280 04A6 76,87$$ 281 04C1 87,88$$ 300 04D5 75,91$" 320 04DF 92 "$ 321 04F1 93,94$$ 322 0523 95,96$$ 323 053E 97,98$& 340 0566 91,100 && 341 0582 100,101&" 350 0594 102"& 390 0598 103,106&* 400 05AD 89,103,108 *& 420 05B4 108,110&" 430 05C6 111"& 440 05D0 65,113 &" 460 0603 119"& 470 0625 126,129&& 474 062E 130,133&* 480 062E 56,115,134 *" 500 0632 134"* 510 063F 112,136,139*& 515 0668 142,144&& 520 0689 144,149&t FTN 3.3B (OPT = LPC) QLOAD PAGE 12 DATE: 08/29/84 TIME: 2302 t* 530 068E 139,147,150*" 540 0698 151"& 541 06B0 152,153&& 560 06C6 151,155&& 561 06DA 155,156&0 950 06EF 29,51,154,157,1580" 990 06F3 158" QLOAD 0000 1 t FTN 3.3B (OPT = LPC) R9BASE PAGE 1 DATE: 08/29/84 TIME: 2304 t^ 1 SUBROUTINE R9BASE C1200001^^ 1 1 /C12 F CCS CCS 3.0 SL-149C1200002^^ C C1200003^^ C CYBERCREDIT SYSTEM VERSION 3 C1200004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C1200005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C1200006^^ C C1200007^^ 2 RETURN C1200008^^ 3 END C1200009^t FTN 3.3B (OPT = LPC) R9BASE PAGE 2 DATE: 08/29/84 TIME: 2304 t  PROGRAM LENGTH $0007 ( 7)   t FTN 3.3B (OPT = LPC) R9BASE PAGE 3 DATE: 08/29/84 TIME: 2304 t, ***** L I S T O F S Y M B O L S *****,   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : <  R9BASE 0003 1  t FTN 3.3B (OPT = LPC) R9FLDL PAGE 1 DATE: 08/29/84 TIME: 2304 t^ 1 SUBROUTINE R9FLDL C1300001^^ 1 1 /C13 F CCS CCS 3.0 SL-149C1300002^^ C C1300003^^ C CYBERCREDIT SYSTEM VERSION 3 C1300004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C1300005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C1300006^^ C C1300007^^ 2 RETURN C1300008^^ 3 END C1300009^t FTN 3.3B (OPT = LPC) R9FLDL PAGE 2 DATE: 08/29/84 TIME: 2304 t  PROGRAM LENGTH $0007 ( 7)   t FTN 3.3B (OPT = LPC) R9FLDL PAGE 3 DATE: 08/29/84 TIME: 2304 t, ***** L I S T O F S Y M B O L S *****,   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : <  R9FLDL 0003 1  t FTN 3.3B (OPT = LPC) RESDT1 PAGE 1 DATE: 08/29/84 TIME: 2304 t^ 1 SUBROUTINE RESDT1 (INPUT, RESLIT, IRE5, IND) C1500001^^ 1 1 /C15 F CCS CCS 3.0 SL-149C1500002^^ C C1500003^^ C CYBERCREDIT SYSTEM VERSION 3 C1500004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C1500005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C1500006^^ C C1500007^^ C SUBROUTINE BREAKS INPUT STRING INTO RESULT VALUES (UP TO 5) C1500008^^ C INPUT EXPECTED AS (XXXX,XXXX,XXXX,XXXX,XXXX) C1500009^^ 2 INTEGER INPUT(1), RESLIT(2,5), COMMA C1500010^^ 3 DATA COMMA / $002C / C1500011^^ C CHECK FOR BLANK CHARACTER FOLLOWING CALCULATED LENGTH OF STRING C1500012^^ 4 IL = IRE5 - ((IRE5-1)/5)*5 C1500013^^ 5 IP = (IL-1)*5 + 4 + 1 C1500014^^ 6 I = 0 C1500015^^ 7 CALL CCSGET ( INPUT , IP, I) C1500016^^ 8 IF ( I .NE. $0020) GO TO 8000 C1500017^^ C CHECK FOR COMMA IN WRONG SPOT C1500018^^ 9 K = 0 C1500019^^ 10 IP1 = IP - 1 C1500020^^ 11 DO 100 J = 1, IP1 C1500021^^ 12 I = 0 C1500022^^ 13 CALL CCSGET (INPUT, J, I) C1500023^^ 14 IF ( J .EQ. 5 .OR. J .EQ. 10 .OR. J .EQ. 15 .OR. J .EQ. 20 ) C1500024^^ 14 1 GO TO 50 C1500025^^ C DATA FIELD, MAKE SURE NOT COMMA C1500026^^ 15 IF ( I .EQ. COMMA) GO TO 8000 C1500027^^ 16 K = K + 1 C1500028^^ 17 CALL CCSPUT ( I, K, RESLIT) C1500029^^ 18 GO TO 100 C1500030^^ C VERIFY COMMA IN CORRECT PLACE C1500031^^ 19 50 IF ( I .NE. COMMA) GO TO 8000 C1500032^^ 20 100 CONTINUE C1500033^^ 21 IND = 0 C1500034^^ 22 RETURN C1500035^^ C ERROR RETURNS C1500036^^ 23 8000 IND = $8001 C1500037^^ 24 RETURN C1500038^^ 25 END C1500039^t FTN 3.3B (OPT = LPC) RESDT1 PAGE 2 DATE: 08/29/84 TIME: 2304 t  PROGRAM LENGTH $006F ( 111)   EXTERNALS  Q8PKUP Q8PREP CCSGET CCSPUT  t FTN 3.3B (OPT = LPC) RESDT1 PAGE 3 DATE: 08/29/84 TIME: 2304 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " 8001 (-32766) 0008 23 "( 0005 (5) 0002 4,4,5,14 (   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < ( COMMA INTEGER 0000 2,3,15,19(6 I INTEGER 0004 5,6,7,8,12,13,15,17,19 6$ IL INTEGER 0001 3,4,5$& IND INTEGER 7FFF 1,21,23&( INPUT INTEGER 7FFF 1,2,7,13 (( IP INTEGER 0003 4,5,7,10 (& IP1 INTEGER 0006 9,10,11&" IRE5 INTEGER 7FFF 1,4"( J INTEGER 0007 10,13,14 (( K INTEGER 0005 8,9,16,17(& RESLIT INTEGER 7FFF 1,2,17 &   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < $ CCSGET SUBROUTINE 001A 6,13 $" CCSPUT SUBROUTINE 0049 16 " Q8PKUP INTEGER.FN. 0064 Q8PREP INTEGER.FN. 0061    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 50 004F 14,19$( 100 0053 10,18,20 (* 8000 0059 8,15,19,23 * RESDT1 005E 1  t FTN 3.3B (OPT = LPC) RTVDT1 PAGE 1 DATE: 08/29/84 TIME: 2304 t^ 1 SUBROUTINE RTVDT1 (ITY, TABLE, IND) C1700001^^ 1 1 /C17 F CCS CCS 3.0 SL-149C1700002^^ C C1700003^^ C CYBERCREDIT SYSTEM VERSION 3 C1700004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C1700005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C1700006^^ C C1700007^^ C RETRIEVES APPROPRIATE DECISION TABLE FROM FILE - DECTBL C1700008^^ 2 INTEGER TABLE(10),REQBUF(24),IDATA(15) C1700009^^ 3 DATA REQBUF / 24*0 /, IDATA / 'DECTBL',9*$2020,0,1,0 / C1700010^^ 4 DO 50 IND=1,24 C1700011^^ 5 50 REQBUF(IND)=0 C1700012^^ 6 ILN = TABLE(2) C1700013^^ 7 IND = 0 C1700014^^ 8 CALL OPENFL(REQBUF,IDATA,ISTAT) C1700015^^ 9 IF (ISTAT.LT.0) GO TO 8010 C1700016^^ 10 CALL GETS (REQBUF,TABLE,ITY,ISTAT) C1700017^^ 11 IF (ISTAT.LT.0) GO TO 8010 C1700018^^ 12 CALL CLOSFL(REQBUF,ISTAT) C1700019^^ C CHECK TOO-SHORT TABLE SPACE C1700020^^ 13 IF ( TABLE(2) .GT. ILN) GO TO 8020 C1700021^^ C CHECK FOR CORRECT TABLE C1700022^^ 14 IF (TABLE(4) .NE. ITY) GO TO 8030 C1700023^^ C C1700024^^ C GOOD RETRIEVAL C1700025^^ C C1700026^^ C ZERO OUT TABLE AREA BEYOND END C1700027^^ 15 J = TABLE(2) + 1 C1700028^^ 16 DO 100 I = J, ILN C1700029^^ 17 100 TABLE(I) = 0 C1700030^^ 18 RETURN C1700031^  ^ C ERROR SECTION C1700033^^ 19 8010 IND = ISTAT C1700034^^ 20 GO TO 8999 C1700035^^ 21 8020 IND = $8222 C1700036^^ 22 GO TO 8999 C1700037^^ 23 8030 IND = $8333 C1700038^^ 24 GO TO 8999 C1700039^^ 25 8999 RETURN C1700040^^ 26 END C1700041^t FTN 3.3B (OPT = LPC) RTVDT1 PAGE 2 DATE: 08/29/84 TIME: 2304 t  PROGRAM LENGTH $008E ( 142)   EXTERNALS & Q8PKUP Q8PREP OPENFL GETS CLOSFL & t FTN 3.3B (OPT = LPC) RTVDT1 PAGE 3 DATE: 08/29/84 TIME: 2304 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " 8222 (-32221) 002B 21 "" 8333 (-31948) 002C 23 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < $ I INTEGER 002A 15,17$$ IDATA INTEGER 0018 2,3,8$( ILN INTEGER 0027 5,6,13,16(0 IND INTEGER 7FFF 1,4,5,7,19,21,23 0. ISTAT INTEGER 0028 8,9,10,11,12,19.& ITY INTEGER 7FFF 1,10,14&( J INTEGER 0029 14,15,16 (, REQBUF INTEGER 0000 2,3,5,8,10,12,4 TABLE INTEGER 7FFF 1,2,6,10,13,14,15,17 4   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " CLOSFL SUBROUTINE 004F 11 " GETS SUBROUTINE 0045 9 OPENFL SUBROUTINE 003C 7 Q8PKUP INTEGER.FN. 007F Q8PREP INTEGER.FN. 007C    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < " 50 002F 3,5"$ 100 0063 15,17$& 8010 006D 9,11,19&$ 8020 0070 13,21$$ 8030 0073 14,23$* 8999 0076 19,22,24,25* RTVDT1 0079 1  t FTN 3.3B (OPT = LPC) SEEIT PAGE 1 DATE: 08/29/84 TIME: 2304 t^ 1 SUBROUTINE SEEIT (LU, BUFFER, BLEN, MODE) C1900001^^ 1 1 /C19 F CCS CCS 3.0 SL-149C1900002^^ C C1900003^^ C CYBERCREDIT SYSTEM VERSION 3 C1900004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C1900005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C1900006^^ C C1900007^^ 2 INTEGER BUFFER(1), BLEN, VIEW(40), LINE(65), IWORK(3) C1900008^^ 3 DATA LINE(1)/'0 '/ C1900009^ ^ C BUFFER LENGTH TO WORDS AND POSSIBLE BLANK FILL C1900012^^ 4 IWD = BLEN C1900013^ ^ 5 100 WRITE ( LU, 9000) C1900015^^ 6 9000 FORMAT( '0 1 C1900016^^ 6 *2 3 1 2 C1900017^^ 6 * 3 ' ) C1900018^^ 7 WRITE (LU, 9001) C1900019^^ 8 9001 FORMAT( ' OFFSET 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 C1900020^^ 8 *0 1 2 3 4 5 6 7 8 9 0 OFFSET 1234567890123456789012345678C1900021^^ 8 *90 ' ) C1900022^^ 9 DO 1000 I = 1, IWD, 15 C1900023^^ 10 J = I + 14 C1900024^^ 11 IF ( J .GT. IWD) J = IWD C1900025^^ 12 K = (I - 1) * 2 C1900026^^ 13 CALL XLAT ( BUFFER(I), VIEW, 30, MODE) C1900027^^ C BUILD DETAIL LINE C1900028^^ 14 CALL CCSMVA ($2020, 1, 1, LINE, 3, 128) C1900029^^ 15 CALL HEXDEC (K,IWORK) C1900030^^ 16 CALL CCSMVA (IWORK, 3, 4, LINE, 3, 4) C1900031^^ 17 CALL CCSMVA (IWORK, 3, 4, LINE, 87, 4) C1900032^^ 18 IPOS = 10 C1900033^^ 19 JPOS = 96 C1900034^^ 20 II = 1 C1900035^^ 21 DO 200 L = I, J C1900036^^ 22 CALL HEXASC (BUFFER(L), IWORK) C1900037^^ 23 CALL CCSMVA ( IWORK, 1, 4, LINE, IPOS, 5) C1900038^^ 24 CALL CCSMVA (VIEW, II, 2, LINE, JPOS, 2) C1900039^^ 25 IPOS = IPOS + 5 C1900040^^ 26 JPOS = JPOS + 2 C1900041^^ 27 II = II + 2 C1900042^^ 28 200 CONTINUE C1900043^^ 29 CALL CCSPUT ($28, 95, LINE) C1900044^^ 30 CALL CCSPUT ($29, 126, LINE) C1900045^^ 31 WRITE ( LU, 9002) LINE C1900046^^ 32 9002 FORMAT (65A2) C1900047^^ 33 1000 CONTINUE C1900048^^ 34 RETURN C1900049^^ 35 END C1900050^t FTN 3.3B (OPT = LPC) SEEIT PAGE 2 DATE: 08/29/84 TIME: 2304 t  PROGRAM LENGTH $01C4 ( 452)   EXTERNALS 2 Q8PKUP Q8PREP Q8QINI Q8QX Q8QEND XLAT CCSMVA 2 HEXDEC HEXASC CCSPUT  t FTN 3.3B (OPT = LPC) SEEIT PAGE 3 DATE: 08/29/84 TIME: 2304 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < 0 0001 (1) 0000 2,3,9,12,14,20,230* 0002 (2) 0072 12,24,26,27*( 0003 (3) 0075 14,16,17 (* 0004 (4) 0077 16,16,17,23*$ 0005 (5) 007D 23,25$" 001E (30) 0073 13 "" 0028 (40) 007E 28 "" 0029 (41) 0080 30 "" 0057 (87) 0078 17 "" 005F (95) 007F 28 "" 007E (126) 0081 30 "" 0080 (128) 0076 14 "" 2020 (8224) 0074 13 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < $ BLEN INTEGER 7FFF 1,2,4$( BUFFER INTEGER 7FFF 1,2,13,22(, I INTEGER 006F 8,10,12,13,21,* II INTEGER 007B 19,20,24,27** IPOS INTEGER 0079 17,18,23,25*( IWD INTEGER 006E 3,4,9,11 (0 IWORK INTEGER 006B 2,15,16,17,22,23 0* J INTEGER 0070 9,10,11,21 ** JPOS INTEGER 007A 18,19,24,26*( K INTEGER 0071 11,12,15 ($ L INTEGER 007C 20,22$: LINE INTEGER 002A 2,3,14,16,17,23,24,29,30,31:( LU INTEGER 7FFF 1,5,7,31 ($ MODE INTEGER 7FFF 1,13 $" Q8QX1 INTEGER 0001 31 "& VIEW INTEGER 0002 2,13,24&t FTN 3.3B (OPT = LPC) SEEIT PAGE 4 DATE: 08/29/84 TIME: 2304 t   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < . CCSMVA SUBROUTINE 0138 13,16,17,23,24 .$ CCSPUT SUBROUTINE 0181 28,30$" HEXASC SUBROUTINE 0165 21 "" HEXDEC SUBROUTINE 0140 14 " Q8PKUP INTEGER.FN. 01B2 Q8PREP INTEGER.FN. 01AF Q8QEND INTEGER.FN. 019F Q8QINI INTEGER.FN. 018A " Q8QX SUBROUTINE 0197 31 "" XLAT SUBROUTINE 0132 12 "   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : <  100 0084 4 $ 200 017D 20,28$$ 1000 01A4 8,33 $" 9000 008C 5,6"" 9001 00D4 7,8"$ 9002 01A1 31,32$ SEEIT 01AC 1 t FTN 3.3B (OPT = LPC) SUMACL PAGE 1 DATE: 08/29/84 TIME: 2305 t^ 1 PROGRAM SUMACL C2000001^^ 1 1 /C20 F CCS CCS 3.0 .LA - PSRD SL-149********^^ C C2000003^^ C CYBERCREDIT SYSTEM VERSION 3 C2000004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C2000005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C2000006^^ C C2000007^^ C THIS PROGRAM IS DESIGNED TO READ THE DELQMST AND PRINT OUT A C2000008^^ C REPORT CONTAINING A LIST OF CURRENT DELINQUENT ACCOUNTS. THOSEC2000009^^ C ACCOUNTS THAT ARE DELETED, BUT STILL PHYSICALLY PRESENT AND C2000010^^ C THOSE THAT HAVE OTHER THEN A BLANK IN THE FIELD STATUS CODE C2000011^^ C ARE NOT PROCESSED. FIVE RECORDS ARE READ EACH TIME. NUMBER C2000012^^ C OF RECORDS READ EACH TIME MAY BE CHANGED BY INCREASING RECBUF. C2000013^^ C FILE MANAGER BUFFERS. C2000014^ ^ 2 INTEGER IDATA(15),MSG1(3),MSG2(9),MSG3(9),MSG4(8),MSG5(10) C2000016^^ 3 INTEGER OBUF(132), ID(4), RECBUF(7000),KEY(8),PRT C2000017^^ 4 INTEGER HDR(60),DT(3) C2000018^^ 5 INTEGER TCNT(6),ONE(5) C2000019^^ 6 INTEGER TOTDA(6),TOTCP(6) C2000020^^ 7 INTEGER ITEMP(8),LCNTL2 C2000021^^ 8 INTEGER JBUF(24),NREC,LINCNT,ZERO C2000022^^ 9 INTEGER TOTDE(7),TOTCE(7),PAGCNT,BLANK(10) C2000023^ ^ 10 EQUIVALENCE (NREC,JBUF(15)) C2000025^^ 11 EQUIVALENCE (MAXREC,IDATA(14)) C2000026^^ 12 EQUIVALENCE (LOKORF,JBUF(23)) C2000027^ ^ C ****************************************************** ???*A011********^^ C ********^^ C FIX FOR PSR GENERATED 7-10-80 DO NOT PRINT DELETED RECORDS ********^^ 13 INTEGER FDEL ********^^ 14 EXTERNAL FMRDEL ********^^ C ******************************************************* ???*A011********^^ 15 DATA JBUF/24*0/,TOTDE/7*0/,TOTCE/7*0/ C2000029^^ 16 DATA TOTCP/6*0/,TOTDA/6*0/,PAGCNT/0/ C2000030^^ 17 DATA IFLAG/0/,LCNTL2/$0A0D/,BLANK/10*$2020/ C2000031^^ 18 DATA PRT/9/,LINCNT/0/ C2000032^^ 19 DATA ZERO/$3030/ C2000033^^ 20 INTEGER IDAT(4) ********^^ 21 DATA IDAT /'DELQMST '/ ********^^ 22 DATA IDATA/'LADLQMST',8*$2020,1,7,0/ ********^^ 23 DATA ONE/4*$3030,$3130/,TCNT/6*$3030/ C2000035^^ 24 DATA MSG1 / 'TOTALS'/ C2000036^^ 25 DATA MSG2 / 'NUMBER OF ACCOUNTS' / C2000037^^ 26 DATA MSG3 / 'DELINQUENT AMOUNT' / C2000038^^ 27 DATA MSG4 / 'CURRENT PAY OFF' / C2000039^^ 28 DATA MSG5 / '***END OF REPORT***' / C2000040^^ C PREPARE FOR PROCESSING. C2000041^^ 29 30 CALL PGMIN (ID , LU , MODE , NOPORT ) C2000043^^ 30 CALL CCSCST(IDATA,1,2,ID,1,8,ICM) ********^^ 31 IF(ICM.NE.0) CALL CCSMVA(IDAT,1,8,IDATA,1,8) ********^ ^ C ****************************************************** ???*A011********^t FTN 3.3B (OPT = LPC) SUMACL PAGE 2 DATE: 08/29/84 TIME: 2305 t^ C FIX FOR PSR GENERATED 7-10-80 DO NOT PRINT DELETED RECORDS ********^^ 32 ASSEM $C000,FMRDEL,$6800,FDEL ********^^ C ****************************************************** ???*A011********^^ C ********^^ C CALL HEADING ROUTINE. C2000045^^ 33 37 CALL UTHEAD( HDR, DT ) C2000046^^ 34 PAGCNT=PAGCNT+1 C2000047^^ 35 CALL SUMHD(PAGCNT,DT,HDR) C2000048^^ C OPEN FILE - DELQMST C2000049^^ 36 40 CALL OPENFL ( JBUF , IDATA , ISTAT ) C2000050^^ C SET LOCKED RECORD OVERRIDE FLAG - NO REJECT ON LOCKED RECORD. C2000051^^ 37 LOKORF = 1 C2000052^^ C CHECK FOR FAILURE TO OPEN FILE. C2000053^^ 38 45 IF ( ISTAT .GE. 0 ) GO TO 70 C2000054^^ C ISTAT IS NEG - OPENFL FAILED- CALL ERROR ROUTINE AND EXIT. C2000055^^ 39 50 CALL FILERR ( IDATA , 3 , ISTAT , LU ) C2000056^^ 40 55 GO TO 340 C2000057^^ C READ NEXT 7 RECORDS - 14000 CHARACTERS TOTAL. C2000058^^ 41 70 CALL GETS (JBUF , RECBUF , KEY , ISTAT ) C2000059^^ 42 IF(AND(ISTAT,$8100) .EQ. $8100) GO TO 300 C2000060^^ 43 IF(ISTAT.GE.0) GO TO 100 C2000061^^ 44 CALL FILERR( IDATA, 14, ISTAT, LU ) C2000062^^ 45 GO TO 330 C2000063^t FTN 3.3B (OPT = LPC) SUMACL PAGE 3 DATE: 08/29/84 TIME: 2305 t^ C IF STATUS CODE IS BLANK, WILL CALCULATE GRAND TOTALS. IF NOT C2000065^^ C BLANK WILL BRANCH TO NEXT RECORD IN BUFFER. C2000066^^ 46 100 DO 250 I=1,NREC C2000067^^ 47 CALL CCSBLK(OBUF,132) C2000068^ ^ C GO TO 110 IF THERE ARE NOT 36 RECORDS PRINTED ON THE PAGE. C2000070^^ 48 IF(LINCNT .NE. 50) GO TO 110 C2000071^ ^ C ELSE PRINT HEADING AT TOP OF NEW PAGE. C2000073^^ 49 PAGCNT=PAGCNT+1 C2000074^^ 50 CALL SUMHD(PAGCNT,DT,HDR) C2000075^^ 51 LINCNT=0 C2000076^ ^ C CALCULATE POINTER TO START BYTE OF NEXT RECORD. C2000078^^ 52 110 IW=(2000*(I-1))+1 C2000079^ ^ C ****************************************************** ???*A011********^^ C FIX FOR PSR GENERATED 7-10-80 DO NOT PRINT DELETED RECORDS ********^^ 53 CALL CCSCST(RECBUF,IW,2,FDEL,1,2,ICOMP) ********^^ 54 IF(ICOMP.EQ.0) GO TO 250 ********^^ C ****************************************************** ???*A011********^^ C IF ACCOUNT NOT ACTIVE (STATUS CODE NOT BLANK), CONTINUE WITH NEXT C2000081^^ C ACCOUNT. C2000082^^ 55 130 CALL CCSGET ( RECBUF, IW+305, ICOMP ) C2000083^^ 56 IF ( ICOMP .NE. $20 ) GO TO 250 C2000084^^ C ADD AMOUNT DELINQUENT TO TOTALS. C2000085^^ 57 140 CALL CCSADD ( RECBUF, IW+886, TOTDA, 1, TOTDA, 1 ) C2000086^^ C ADD CURRENT PAYOFF TO TOTALS. C2000087^^ 58 CALL CCSADD ( RECBUF, IW+904, TOTCP, 1, TOTCP, 1 ) C2000088^^ C SET UP DETAIL LINE FOR OUTPUT C2000089^^ C ACCOUNT NUMBER C2000090^^ 59 160 CALL CCSMVA ( RECBUF, IW, 16, OBUF, 3, 16 ) C2000091^^ C NAME. C2000092^^ 60 CALL CCSMVA ( RECBUF, IW+17, 30, OBUF, 21, 30 ) C2000093^^ C DELINQUENT DATE. C2000094^^ 61 CALL EDIT ( RECBUF, IW+874, OBUF, 54, 1 ) C2000095^^ C AMOUNT DELINQUENT. C2000096^^ 62 CALL EDIT ( RECBUF, IW+886, OBUF, 64, 3 ) C2000097^^ C CURRENT PAYOFF. C2000098^^ 63 CALL EDIT ( RECBUF, IW+904, OBUF, 75, 3 ) C2000099^^ C QUEUE. C2000100^^ 64 CALL CCSMVA ( RECBUF, IW+270, 4, OBUF, 88, 4 ) C2000101^^ C PROMISE TO PAY DATE, AMOUNT - IF PRESENT. C2000102^^ 65 IF ( IDATVR(RECBUF,IW+1015) .LT. 0 ) GO TO 165 C2000103^^ 66 CALL EDIT ( RECBUF, IW+1015, OBUF, 95, 1 ) C2000104^^ 67 CALL EDIT ( RECBUF, IW+1021, OBUF, 104, 3 ) C2000105^^ C NEXT CONTACT DATE. C2000106^^ 68 165 CALL EDIT ( RECBUF, IW+274, OBUF, 117, 1 ) C2000107^^ C ACCOUNT REVIEW CODE. C2000108^^ 69 CALL CCSMVA ( RECBUF, IW+290, 1, OBUF, 129, 1 ) C2000109^^ 70 180 ASSIGN 250 TO ICOMP C2000110^^ 71 CALL CCSADD(ONE,1,TCNT,1,TCNT,1) C2000111^^ 72 LINCNT=LINCNT+1 C2000112^^ 73 CALL FWRITE(PRT,OBUF,132,ICOMP,IFLAG,ITEMP) C2000113^t FTN 3.3B (OPT = LPC) SUMACL PAGE 4 DATE: 08/29/84 TIME: 2305 t^ 74 CALL DISP C2000114^^ 75 250 CONTINUE C2000115^^ 76 IF(NREC.EQ.MAXREC) GO TO 70 C2000117^t FTN 3.3B (OPT = LPC) SUMACL PAGE 5 DATE: 08/29/84 TIME: 2305 t^ C PRINT FINAL TOTALS. C2000119^^ 77 300 IF(LINCNT.LT.46) GO TO 305 C2000120^^ 78 PAGCNT=PAGCNT+1 C2000121^^ 79 CALL SUMHD(PAGCNT,DT,HDR) C2000122^^ 80 305 ASSIGN 310 TO ICOMP C2000123^^ 81 CALL CCSBLK ( OBUF, 132 ) C2000124^^ 82 CALL CCSMVA(LCNTL2,1,2,OBUF,1,2) C2000125^^ 83 CALL CCSMVA ( MSG1, 1, 6, OBUF, 19, 6 ) C2000126^^ 81 CALL CCSBLK ( OBUF, 132 ) C2000124^^ 82 CALL CCSMVA(LCNTL2,1,2,OBUF,1,2) C2000125^^ 83 CALL CCSMVA ( MSG1, 1, 6, OBUF, 19, 6 ) C2000126^^ 84 CALL FWRITE ( PRT, OBUF, 132, ICOMP, IFLAG, ITEMP ) C2000127^^ 85 CALL DISP C2000128^^ 86 310 CONTINUE C2000129^^ 87 CALL CCSBLK ( OBUF, 132 ) C2000130^^ 88 CALL CCSMVA ( MSG2, 1, 18, OBUF, 17, 18 ) C2000131^^ 89 DO 312 I=1,11 C2000132^^ 90 CALL CCSCST(TCNT,I,1,ZERO,1,1,ICOMP) C2000133^^ 91 IF(ICOMP.NE.0) GO TO 313 C2000134^^ 92 CALL CCSMVA(BLANK,1,1,TCNT,I,1) C2000135^^ 93 312 CONTINUE C2000136^^ 94 313 CALL CCSMVA(TCNT,1,12,OBUF,49,12) C2000137^^ 95 ASSIGN 315 TO ICOMP C2000138^^ 96 CALL FWRITE ( PRT, OBUF, 132, ICOMP, IFLAG, ITEMP ) C2000139^^ 97 CALL DISP C2000140^^ 98 315 ASSIGN 320 TO ICOMP C2000141^^ 99 CALL CCSBLK ( OBUF, 132 ) C2000142^^ 100 CALL CCSMVA ( MSG3, 1, 17, OBUF, 17, 17 ) C2000143^^ 101 CALL TOTEDT(TOTDA,TOTDE) C2000144^^ 102 CALL CCSMVA(TOTDE,1,13,OBUF,48,13) C2000145^^ 103 CALL FWRITE ( PRT, OBUF, 132, ICOMP, IFLAG, ITEMP ) C2000146^^ 104 CALL DISP C2000147^^ 105 320 ASSIGN 325 TO ICOMP C2000148^^ 106 CALL CCSBLK ( OBUF, 132 ) C2000149^^ 107 CALL CCSMVA ( MSG4, 1, 15, OBUF, 17, 15 ) C2000150^^ 108 CALL TOTEDT ( TOTCP, TOTCE) C2000151^^ 109 CALL CCSMVA(TOTCE,1,13,OBUF,48,13) C2000152^^ 110 CALL FWRITE ( PRT, OBUF, 132, ICOMP, IFLAG, ITEMP ) C2000153^^ 111 CALL DISP C2000154^^ 112 325 ASSIGN 330 TO ICOMP C2000155^^ 113 CALL CCSBLK ( OBUF, 132 ) C2000156^^ 114 CALL CCSMVA(LCNTL2,1,2,OBUF,1,2) C2000157^^ 115 CALL CCSMVA ( MSG5, 1, 19, OBUF, 51, 19 ) C2000158^^ 116 CALL FWRITE ( PRT, OBUF, 132, ICOMP, IFLAG, ITEMP ) C2000159^^ 117 CALL DISP C2000160^^ 118 330 CALL CLOSFL ( JBUF, ISTAT ) C2000161^^ 119 340 CALL PGMOUT C2000162^^ 120 END C2000163^t FTN 3.3B (OPT = LPC) SUMACL PAGE 6 DATE: 08/29/84 TIME: 2305 t  PROGRAM LENGTH $1EE9 ( 7913)   EXTERNALS 2 Q8STP FMRDEL PGMIN CCSCST CCSMVA UTHEAD SUMHD 22 OPENFL FILERR GETS CCSBLK CCSGET CCSADD EDIT 2, IDATVR FWRITE DISP TOTEDT CLOSFL PGMOUT , t FTN 3.3B (OPT = LPC) SUMACL PAGE 7 DATE: 08/29/84 TIME: 2305 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < $ 8100 (-32511) 1CC2 42,42$‚ 0001 (1) 0002 22,30,31,34,37,46,49,52,53,57,58,61,66,68,69,71,72,78,82,83,88,89,90,92,94,100,102,107,109,114,115 ‚, 0002 (2) 1CBD 30,53,82,114 ,. 0003 (3) 1CC1 39,59,62,63,67 .$ 0004 (4) 1CD5 64,64$$ 0006 (6) 1CDF 83,83$$ 0008 (8) 1CBE 30,31$$ 000C (12) 1CE2 94,94$* 000D (13) 1CE4 102,102,109*" 000E (14) 1CC3 44 "& 000F (15) 1CE6 107,107&$ 0010 (16) 1CCC 59,59$, 0011 (17) 1CCD 60,88,100,107,$ 0012 (18) 1CE1 88,88$& 0013 (19) 1CE0 83,115 &" 0015 (21) 1CCF 60 "$ 001E (30) 1CCE 60,60$& 0030 (48) 1CE5 102,109&" 0031 (49) 1CE3 94 "" 0033 (51) 1CE7 115"" 0036 (54) 1CD1 61 "" 0040 (64) 1CD2 62 "" 004B (75) 1CD3 63 "" 0058 (88) 1CD6 64 "" 005F (95) 1CD8 66 "" 0068 (104) 1CDA 67 "" 0075 (117) 1CDC 68 "" 0081 (129) 1CDE 69 "H 0084 (132) 1CC5 47,73,81,84,87,96,99,103,106,110,113,116 H" 010E (270) 1CD4 64 "" 0112 (274) 1CDB 68 "" 0122 (290) 1CDD 69 "$ 0131 (305) 1CC9 55,77$" 036A (874) 1CD0 61 "$ 0376 (886) 1CCA 57,62$$ 0388 (904) 1CCB 58,63$$ 03F7 (1015) 1CD7 65,66$" 03FD (1021) 1CD9 67 "" 07D0 (2000) 1CC7 52 "t FTN 3.3B (OPT = LPC) SUMACL PAGE 8 DATE: 08/29/84 TIME: 2305 t   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " AND INTR.FN. 7FFF 42 "& BLANK INTEGER 1CAA 1,17,92&, DT INTEGER 1C5E 1,33,35,50,79,( FDEL INTEGER 1CB4 12,32,53 (, HDR INTEGER 1C22 1,33,35,50,79,. I INTEGER 1CC4 46,52,89,90,92 .$ ICM INTEGER 1CBF 30,31$Z ICOMP INTEGER 1CC8 53,54,55,56,70,73,80,84,90,91,95,96,98,103,105,110,112,116 Z& ID INTEGER 00BD 1,29,30&( IDAT INTEGER 1CB6 19,21,31 (6 IDATA INTEGER 0003 1,11,22,30,31,36,39,44 66 IFLAG INTEGER 1CB5 16,73,84,96,103,110,11668 ISTAT INTEGER 1CC0 36,38,39,41,42,43,44,118 86 ITEMP INTEGER 1C78 1,73,84,96,103,110,116 6R IW INTEGER 1CC6 52,52,53,55,57,58,59,60,61,62,63,64,65,66,67,68,69 R4 JBUF INTEGER 1C81 1,10,12,15,36,41,118 4$ KEY INTEGER 1C19 1,41 $* LCNTL2 INTEGER 1C80 1,17,82,114*0 LINCNT INTEGER 1C99 1,18,48,51,72,77 0$ LOKORF INTEGER 1C97 11,37$( LU INTEGER 1CBA 29,39,44 ($ MAXREC INTEGER 0010 10,76$" MODE INTEGER 1CBB 29 "& MSG1 INTEGER 0012 1,24,83&& MSG2 INTEGER 0015 1,25,88&( MSG3 INTEGER 001E 1,26,100 (( MSG4 INTEGER 0027 1,27,107 (( MSG5 INTEGER 002F 1,28,115 (" NOPORT INTEGER 1CBC 29 "* NREC INTEGER 1C8F 1,10,46,76 *€ OBUF INTEGER 0039 1,47,59,60,61,62,63,64,66,67,68,69,73,81,82,83,84,87,88,94,96,99,100,102,103,106,107,109,110,113,€* 114,115,116*& ONE INTEGER 1C67 1,23,71&6 PAGCNT INTEGER 1CA9 1,16,34,35,49,50,78,79 68 PRT INTEGER 1C21 1,18,73,84,96,103,110,1168P RECBUF INTEGER 00C1 1,41,53,55,57,58,59,60,61,62,63,64,65,66,67,68,69P0 TCNT INTEGER 1C61 1,23,71,90,92,94 0, TOTCE INTEGER 1CA2 1,15,108,109 ,* TOTCP INTEGER 1C72 1,16,58,108** TOTDA INTEGER 1C6C 1,16,57,101*, TOTDE INTEGER 1C9B 1,15,101,102 ,& ZERO INTEGER 1C9A 1,19,90&t FTN 3.3B (OPT = LPC) SUMACL PAGE 9 DATE: 08/29/84 TIME: 2305 t   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < ( CCSADD SUBROUTINE 1E03 56,58,71 (2 CCSBLK SUBROUTINE 1EC8 46,81,87,99,106,1132( CCSCST SUBROUTINE 1E58 29,53,90 (" CCSGET SUBROUTINE 1D6D 54 "T CCSMVA SUBROUTINE 1EB5 31,59,60,64,69,82,83,88,92,94,100,102,107,109,114,115T" CLOSFL SUBROUTINE 1EE2 118"4 DISP SUBROUTINE 1EA3 73,85,97,104,111,117 40 EDIT SUBROUTINE 1DA7 60,62,63,66,67,680$ FILERR SUBROUTINE 1D1C 38,44$4 FWRITE SUBROUTINE 1E9B 72,84,96,103,110,116 4" GETS SUBROUTINE 1D24 41 "" IDATVR INTEGER.FN. 1DCF 65 "" OPENFL SUBROUTINE 1D11 35 "" PGMIN SUBROUTINE 1CE9 28 "" PGMOUT SUBROUTINE 1EE6 119" Q8STP INTEGER.FN. 1EE8 ( SUMHD SUBROUTINE 1E29 34,50,79 (& TOTEDT SUBROUTINE 1E90 100,108&" UTHEAD SUBROUTINE 1D07 32 "   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < " 30 1CE8 28 "" 37 1D06 32 "" 40 1D10 35 "" 45 1D18 37 "" 50 1D1B 38 "" 55 1D21 39 "( 70 1D23 38,41,76 ($ 100 1D39 43,46$$ 110 1D51 48,52$" 130 1D67 54 "" 140 1D76 56 "" 160 1D8F 58 "$ 165 1DE9 65,68$" 180 1DFE 69 ". 250 1E16 46,54,56,70,75 .$ 300 1E23 42,77$$ 305 1E2D 77,80$$ 310 1E4B 80,86$$ 312 1E6A 88,93$$ 313 1E6F 91,94$$ 315 1E81 94,98$t FTN 3.3B (OPT = LPC) SUMACL PAGE 10 DATE: 08/29/84 TIME: 2305 t& 320 1EA4 98,105 && 325 1EC4 105,112&* 330 1EE1 44,112,118 *& 340 1EE5 39,119 & SUMACL 0000 1 t FTN 3.3B (OPT = LPC) SUMHD PAGE 1 DATE: 08/29/84 TIME: 2305 t^ 1 SUBROUTINE SUMHD(PAGCNT,DT,HDR) C2100001^^ 1 1 /C21 F CCS CCS 3.0 SL-149C2100002^^ C C2100003^^ C CYBERCREDIT SYSTEM VERSION 3 C2100004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C2100005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C2100006^^ C C2100007^^ C CALLING SEQUENCE: C2100008^^ C CALL SUMHD(PAGCNT,DT,HDR) C2100009^^ C WHERE THE PARAMETERS HAVE THE FOLLOWING DEFINITIONS: C2100010^^ C PAGCNT = THE PAGE NUMBER PASSED FROM MAIN PROGRAM. C2100011^^ C DT = SYSTEM DATE THAT IS PICKED UP BY SUBROUTINE UTHEAD THAT C2100012^^ C IS CALLED BY MAIN PROGRAM. C2100013^ ^ 2 INTEGER HDNG1(14),HDNG2(2),HDNG3(3),HDNG4(16),HDNG5(38),HDNG4A(21)C2100015^^ 3 INTEGER LCNTL1,LCNTL2,HDNG4B(19) C2100016^^ 4 INTEGER OBUF(132),PRT,ITEMP(8),ICOMP,IFLAG C2100017^^ 5 INTEGER PAGOUT(2),PAGCNT,DT(3),HDR(60) C2100018^^ 6 INTEGER A1,A2,A3,A4,RE C2100019^^ 7 INTEGER ZERO, BLANK C2100020^ ^ 8 DATA PAGOUT/2*$0000/,IFLAG/0/,LCNTL1/$0D0C/,LCNTL2/$0A0D/ C2100022^^ 9 DATA PRT/$0009/,ZERO/$3030/,BLANK/$2020/ C2100023^^ 10 DATA HDNG1/'ACCOUNT SUMMARY LIST REPORT'/ C2100024^^ 11 DATA HDNG2/'PAGE'/ C2100025^^ 12 DATA HDNG3/'AS OF:'/ C2100026^^ 13 DATA HDNG4/ 'ACCOUNT NUMBER BORROWERS NAME'/ C2100027^^ 14 DATA HDNG4A / 'DELINQUENT DELINQUENT CURRENT QUEUE ' / C2100028^^ 15 DATA HDNG4B / 'PROMISED TO PAY NEXT REVIEW ' / C2100029^^ 16 DATA HDNG5/'DATE AMOUNT PAYOFF DATE ', C2100030^^ 16 1 'AMOUNT CONTACT CODE'/ C2100031^ ^ C CONVERT PAGCNT TO ASCII AND PLACE IN PAGOUT. C2100033^^ 17 A1=PAGCNT/$3E8 C2100034^^ 18 RE=PAGCNT-(A1*$3E8) C2100035^^ 19 A2=RE/$64 C2100036^^ 20 RE=RE-(A2*$64) C2100037^^ 21 A3=RE/$A C2100038^^ 22 RE=RE-(A3*$A) C2100039^^ 23 A4=RE C2100040^ ^ C MOVE TO PAGE OUT IN PRINTABLE FORM. C2100042^^ 24 PAGOUT(2)=((A3+$30)*$100)+(A4+$30) C2100043^^ 25 PAGOUT(1)=((A1+$30)*$100)+(A2+$30) C2100044^ ^ C BUILD HEADING LINE 1 C2100046^^ 26 CALL CCSBLK(OBUF,132) C2100047^^ 27 CALL CCSMVA(LCNTL1,1,2,OBUF,1,2) C2100048^^ 28 CALL CCSMVA(HDR,1,40,OBUF,5,40) C2100049^^ 29 CALL CCSMVA(HDNG1,1,28,OBUF,53,28) C2100050^^ 30 CALL CCSMVA(HDNG2,1,4,OBUF,122,4) C2100051^^ 31 4 DO 5 I=1,3 C2100052^^ 32 CALL CCSCST(PAGOUT,I,1,ZERO,1,1,ICOMP) C2100053^^ 33 IF(ICOMP.NE.0) GO TO 6 C2100054^t FTN 3.3B (OPT = LPC) SUMHD PAGE 2 DATE: 08/29/84 TIME: 2305 t^ 34 CALL CCSMVA(BLANK,1,1,PAGOUT,I,1) C2100055^^ 35 5 CONTINUE C2100056^^ 36 6 CALL CCSMVA(PAGOUT,1,4,OBUF,127,4) C2100057^ ^ C PRINT HEADING LINE 1 C2100059^^ 37 10 ASSIGN 20 TO ICOMP C2100060^^ 38 CALL FWRITE(PRT,OBUF,132,ICOMP,IFLAG,ITEMP) C2100061^^ 39 CALL DISP C2100062^ ^ C BUILD HEADING LINE 2 C2100064^^ 40 20 CALL CCSBLK(OBUF,132) C2100065^^ 41 CALL CCSMVA(HDR,41,40,OBUF,3,40) C2100066^^ 42 CALL CCSMVA(HDNG3,1,6,OBUF,57,6) C2100067^^ 43 CALL EDIT(DT,1,OBUF,64,1) C2100068^ ^ C PRINT HEADING LINE 2 C2100070^^ 44 30 ASSIGN 40 TO ICOMP C2100071^^ 45 CALL FWRITE(PRT,OBUF,132,ICOMP,IFLAG,ITEMP) C2100072^^ 46 CALL DISP C2100073^ ^ C BUILD HEADING LIN 3 C2100075^^ 47 40 CALL CCSBLK(OBUF,132) C2100076^^ 48 CALL CCSMVA(HDR,81,40,OBUF,3,40) C2100077^ ^ C PRINT HEADING LINE 3 C2100079^^ 49 ASSIGN 70 TO ICOMP C2100080^^ 50 CALL FWRITE(PRT,OBUF,132,ICOMP,IFLAG,ITEMP) C2100081^^ 51 CALL DISP C2100082^ ^ C BUILD HEADING LINE 4 C2100084^^ 52 70 CALL CCSBLK(OBUF,132) C2100085^^ 53 CALL CCSMVA(LCNTL2,1,2,OBUF,1,2) C2100086^^ 54 CALL CCSMVA(HDNG4,1,32,OBUF,5,32) C2100087^^ 55 CALL CCSMVA(HDNG4A,1,42,OBUF,55,42) C2100088^^ 56 CALL CCSMVA(HDNG4B,1,38,OBUF,98,38) C2100089^ ^ C PRINT HEADING LIN 4 C2100091^^ 57 ASSIGN 80 TO ICOMP C2100092^^ 58 CALL FWRITE(PRT,OBUF,132,ICOMP,IFLAG,ITEMP) C2100093^^ 59 CALL DISP C2100094^ ^ C BUILD HEADING LINE 5 C2100096^^ 60 80 CALL CCSBLK(OBUF,132) C2100097^^ 61 CALL CCSMVA(HDNG5,1,75,OBUF,56,130) C2100098^ ^ C PRINT HEADING LINE 5 C2100100^^ 62 ASSIGN 90 TO ICOMP C2100101^^ 63 CALL FWRITE(PRT,OBUF,132,ICOMP,IFLAG,ITEMP) C2100102^^ 64 CALL DISP C2100103^ ^ C PRINT BLANK LINE C2100105^^ 65 90 CALL CCSBLK(OBUF,132) C2100106^^ 66 ASSIGN 100 TO ICOMP C2100107^^ 67 CALL FWRITE(PRT,OBUF,132,ICOMP,IFLAG,ITEMP) C2100108^t FTN 3.3B (OPT = LPC) SUMHD PAGE 3 DATE: 08/29/84 TIME: 2305 t^ 68 CALL DISP C2100109^^ 69 100 RETURN C2100110^^ 70 END C2100111^t FTN 3.3B (OPT = LPC) SUMHD PAGE 4 DATE: 08/29/84 TIME: 2305 t  PROGRAM LENGTH $0249 ( 585)   EXTERNALS 2 Q8PKUP Q8PREP CCSBLK CCSMVA CCSCST FWRITE DISP 2 EDIT  t FTN 3.3B (OPT = LPC) SUMHD PAGE 5 DATE: 08/29/84 TIME: 2305 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < N 0001 (1) 0000 25,27,28,29,30,31,32,34,36,42,43,53,54,55,56,61N( 0002 (2) 0110 27,27,53 (( 0003 (3) 0118 31,41,48 (( 0004 (4) 0115 30,30,36 ($ 0005 (5) 0112 28,54$$ 0006 (6) 011B 42,42$$ 000A (10) 010E 21,22$$ 001C (28) 0113 29,29$$ 0020 (32) 011F 54,54$$ 0026 (38) 0122 56,56$* 0028 (40) 0111 28,28,41,48*" 0029 (41) 011A 41 "$ 002A (42) 0120 55,55$" 0035 (53) 0114 29 "" 0037 (55) 0121 55 "" 0038 (56) 0125 61 "" 0039 (57) 011C 42 "" 0040 (64) 011D 43 "" 004B (75) 0124 61 "" 0051 (81) 011E 48 "" 0062 (98) 0123 56 "$ 0064 (100) 010D 19,20$" 007A (122) 0116 30 "" 007F (127) 0119 36 "" 0082 (130) 0126 61 "B 0084 (132) 010F 26,38,40,45,47,50,52,58,60,63,65,67B$ 03E8 (1000) 010C 17,18$   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < * A1 INTEGER 0105 5,17,18,25 ** A2 INTEGER 0106 5,19,20,25 ** A3 INTEGER 0107 5,21,22,24 *& A4 INTEGER 0108 5,23,24&& BLANK INTEGER 010B 5,9,34 && DT INTEGER 7FFF 1,5,43 && HDNG1 INTEGER 0001 1,10,29&& HDNG2 INTEGER 000F 1,11,30&& HDNG3 INTEGER 0011 1,12,42&& HDNG4 INTEGER 0014 1,13,54&& HDNG4A INTEGER 004A 1,14,55&& HDNG4B INTEGER 0061 1,15,56&t FTN 3.3B (OPT = LPC) SUMHD PAGE 6 DATE: 08/29/84 TIME: 2305 t& HDNG5 INTEGER 0024 1,16,61&, HDR INTEGER 7FFF 1,5,28,41,48 ,( I INTEGER 0117 30,32,34 (J ICOMP INTEGER 0101 1,32,33,37,38,44,45,49,50,57,58,62,63,66,67J4 IFLAG INTEGER 0102 1,8,38,45,50,58,63,6742 ITEMP INTEGER 00F9 1,38,45,50,58,63,672& LCNTL1 INTEGER 005F 1,8,27 && LCNTL2 INTEGER 0060 1,8,53 &n OBUF INTEGER 0074 1,26,27,28,29,30,36,38,40,41,42,43,45,47,48,50,52,53,54,55,56,58,60,61,63,65,67n( PAGCNT INTEGER 7FFF 1,5,17,18(2 PAGOUT INTEGER 0103 1,8,24,25,32,34,36 24 PRT INTEGER 00F8 1,9,38,45,50,58,63,6742 RE INTEGER 0109 5,18,19,20,21,22,232& ZERO INTEGER 010A 5,9,32 &   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < 0 CCSBLK SUBROUTINE 01DE 25,40,47,52,60,650" CCSCST SUBROUTINE 0179 31 "H CCSMVA SUBROUTINE 01E2 26,28,29,30,34,36,41,42,48,53,54,55,56,61H0 DISP SUBROUTINE 022E 38,46,51,59,64,680" EDIT SUBROUTINE 01B7 42 "0 FWRITE SUBROUTINE 0226 37,45,50,58,63,670 Q8PKUP INTEGER.FN. 023A Q8PREP INTEGER.FN. 0237    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < " 4 0176 30 "$ 5 018C 30,35$$ 6 0191 33,36$" 10 0198 36 "$ 20 01A5 36,40$" 30 01BD 43 "$ 40 01C8 43,47$$ 70 01DD 48,52$$ 80 020A 56,60$$ 90 021F 61,65$$ 100 022F 65,69$ SUMHD 0234 1 t FTN 3.3B (OPT = LPC) TAPE PAGE 1 DATE: 08/29/84 TIME: 2306 t^ 1 SUBROUTINE TAPE ( PLU, BUFFER, LUNIT) C2200001^^ 1 1 /C22 F CCS CCS 3.0 SL-149C2200002^^ C C2200003^^ C CYBERCREDIT SYSTEM VERSION 3 C2200004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C2200005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C2200006^^ C C2200007^^ 2 INTEGER PLU, BUFFER(2000), TEMP(8), C, R, E, TLU C2200008^^ 3 DATA C/$43/, R/$52/, E/$45/, TLU/6/, IFLG/0/ C2200009^  ^ 4 1 WRITE (LUNIT, 9000) C2200012^^ 5 9000 FORMAT ( ' MOUNT TAPE TO BE DUMPED ON UNIT 0.',/, C2200013^^ 5 * ' ENTER C/R/E (CR) TO CONTINUE, REWIND AND CONTINUE, OR EC2200014^^ 5 *XIT TAPE DUMPING.',/, C2200015^^ 5 * ' IF EBCDIC TAPE FOLLOW C/R WITH E, SUCH AS RE (CR).' ) C2200016^^ 6 IRWD = 0 C2200017^^ 7 BUFFER(1) = 0 C2200018^^ 8 MODE = 0 C2200019^^ 9 CALL INPUT (LUNIT, BUFFER, NCH) C2200020^^ 10 IF (NCH .EQ. 0) GO TO 8000 C2200021^^ 11 CALL CCSGET ( BUFFER, 2, I) C2200022^^ 12 IF ( I .EQ. E) MODE = 1 C2200023^^ 13 CALL CCSGET (BUFFER, 1, I) C2200024^^ 14 IF ( I .EQ. C) GO TO 200 C2200025^^ 15 IF ( I .EQ. R) GO TO 100 C2200026^^ 16 IF ( I .EQ. E) GO TO 8000 C2200027^^ 17 100 CALL TAPMOT (TLU, 3) C2200028^^ 18 IRWD = 1 C2200029^^ 19 WRITE ( PLU, 9101) C2200030^^ 20 9101 FORMAT ('1 TAPE REWOUND ') C2200031^ ^ C PROMPT FOR FILE SKIPPING C2200033^^ 21 200 WRITE (LUNIT, 9001) C2200034^^ 22 9001 FORMAT ( ' ENTER NUMBER OF FILES TO SKIP.' ) C2200035^^ 23 NF = 0 C2200036^^ 24 CALL INPUT (LUNIT, BUFFER, NCH) C2200037^^ 25 IF (NCH .GT. 3) GO TO 200 C2200038^^ 26 IF ( NCH .EQ. 0) GO TO 300 C2200039^^ 27 CALL INTGR (BUFFER, NCH, NF) C2200040^^ 28 IF (NF .EQ. 0) GO TO 300 C2200041^^ 29 WRITE (LUNIT,9002) NF C2200042^^ 30 9002 FORMAT ( I5, ' FILES BEING SKIPPED.' ) C2200043^^ 31 DO 250 I = 1, NF C2200044^^ 32 250 CALL TAPMOT (TLU, 5) C2200045^^ 33 WRITE (LUNIT, 9003) C2200046^^ 34 9003 FORMAT ( ' FILE SKIPPING COMPLETE.' ) C2200047^^ 35 WRITE (PLU, 9102) NF C2200048^^ 36 9102 FORMAT ('0', I4, ' FILES SKIPPED' ) C2200049^ ^ 37 300 NF = NF +1 C2200051^^ C PROMPT FOR NUMBER OF RECORDS TO SKIP C2200052^^ 38 301 WRITE (LUNIT, 9004) C2200053^^ 39 9004 FORMAT ( ' ENTER NUMBER OF RECORDS TO SKIP.' ) C2200054^t FTN 3.3B (OPT = LPC) TAPE PAGE 2 DATE: 08/29/84 TIME: 2306 t^ 40 NR = 0 C2200055^^ 41 CALL INPUT ( LUNIT, BUFFER, NCH) C2200056^^ 42 IF (NCH .GT. 4) GO TO 301 C2200057^^ 43 IF (NCH .EQ. 0) GO TO 500 C2200058^^ 44 CALL INTGR ( BUFFER, NCH, NR) C2200059^^ 45 IF (NR .EQ. 0) GO TO 500 C2200060^^ 46 WRITE (LUNIT, 9005) NR C2200061^^ 47 9005 FORMAT ( I5, ' RECORDS BEING SKIPPED. ' ) C2200062^^ 48 ASSIGN 350 TO ICMP C2200063^^ 49 DO 400 I = 1, NR C2200064^^ 50 CALL FREAD (TLU, BUFFER, 2000, ICMP, IFLG, TEMP) C2200065^^ 51 CALL DISP C2200066^^ 52 350 IF (LINK(0) .LT. 0) GO TO 450 C2200067^^ 53 400 CONTINUE C2200068^^ 54 WRITE (LUNIT, 9006) C2200069^^ 55 9006 FORMAT ( ' RECORD SKIPPING COMPLETE.' ) C2200070^^ 56 WRITE (PLU, 9103) NR C2200071^^ 57 9103 FORMAT('0', I4, ' RECORDS SKIPPED' ) C2200072^^ 58 GO TO 500 C2200073^^ C ERROR OR EOF IN SKIPPING RECORDS, ASSUME EOF C2200074^^ 59 450 WRITE (LUNIT, 9007) I C2200075^^ 60 9007 FORMAT ( ' EOF DETECTED WHILE SKIPPING THE ',I4,'TH RECORD',/, C2200076^^ 60 * ' ACTION IDENTICAL TO SKIPPING 1 FILE. ' ) C2200077^^ 61 INF = 1 C2200078^^ 62 WRITE (PLU, 9102) INF C2200079^^ 63 NF = NF + 1 C2200080^^ 64 NR = 0 C2200081^  ^ 65 500 NR = NR +1 C2200083^^ C PROMPT FOR NUMBER OF RECORDS TO DUMP C2200084^^ 66 501 WRITE ( LUNIT, 9008) C2200085^^ 67 9008 FORMAT ( ' ENTER NUMBER OF RECORDS TO DUMP.') C2200086^^ 68 CALL INPUT (LUNIT, BUFFER, NCH) C2200087^^ 69 IF ( NCH .EQ. 0) GO TO 1 C2200088^^ 70 IF ( NCH .GT. 3) GO TO 501 C2200089^^ 71 CALL INTGR ( BUFFER, NCH, ND) C2200090^^ 72 IF ( ND .EQ. 0) GO TO 1 C2200091^  ^ C FINALLY, WE ARE DUMPING RECORDS C2200093^^ 73 ASSIGN 600 TO ICMP C2200094^^ 74 DO 1000 I = 1, ND C2200095^^ 75 550 CALL FREAD(TLU,BUFFER,2000,ICMP,IFLG,TEMP) C2200096^^ 76 CALL DISP C2200097^^ 77 600 IF ( LINK (0) .LT. 0) GO TO 1200 C2200098^^ C CALCULATE NUMBER OF WORDS READ C2200099^^ 78 NWDS=BUFFER(1001)/2 C2200100^^ 79 650 IF(NWDS.GT.1000) NWDS=1000 C2200101^^ 80 WRITE (PLU, 9009) I C2200102^^ 81 9009 FORMAT (//,'0 RELATIVE TAPE RECORD NUMBER =' , I5 ) C2200103^   t FTN 3.3B (OPT = LPC) TAPE PAGE 3 DATE: 08/29/84 TIME: 2306 t^ 82 CALL SEEIT (PLU, BUFFER, NWDS, MODE) C2200105^^ 83 1000 CONTINUE C2200106^^ 84 GO TO 1 C2200107^  ^ C EOF OR ERROR WHILE DUMPING RECORDS C2200109^^ 85 1200 WRITE (LUNIT, 9010) I C2200110^^ 86 9010 FORMAT ( ' EOF OR ERROR DETECTED DURING ACCESS OF RELATIVE RECORC2200111^^ 86 *D NUMBER', I5 ) C2200112^^ 87 GO TO 1 C2200113^^ 88 8000 RETURN C2200118^^ 89 END C2200119^t FTN 3.3B (OPT = LPC) TAPE PAGE 4 DATE: 08/29/84 TIME: 2306 t  PROGRAM LENGTH $0339 ( 825)   EXTERNALS 2 Q8PKUP Q8PREP Q8QINI Q8QX Q8QEND INPUT CCSGET 2, TAPMOT INTGR FREAD DISP LINK SEEIT , t FTN 3.3B (OPT = LPC) TAPE PAGE 5 DATE: 08/29/84 TIME: 2306 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < J 0000 (0) 0001 3,6,7,8,10,23,26,28,40,43,45,52,64,69,72,77JJ 0001 (1) 0000 7,12,13,18,31,37,49,61,63,65,69,72,74,84,87J$ 0002 (2) 0012 11,78$( 0003 (3) 0014 17,25,70 (" 0005 (5) 0016 32 "$ 03E8 (1000) 001D 79,79$$ 07D0 (2000) 0019 50,75$   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < J BUFFER INTEGER 7FFF 1,2,7,9,11,13,24,27,41,44,50,68,71,75,78,82J& C INTEGER 000A 2,3,14 &( E INTEGER 000C 2,3,12,16(B I INTEGER 0013 11,12,13,14,15,16,31,49,59,74,80,85B* ICMP INTEGER 0018 47,50,73,75*& IFLG INTEGER 000E 3,50,75&( INF INTEGER 001A 60,61,62 (& IRWD INTEGER 000F 5,6,18 &H LUNIT INTEGER 7FFF 1,4,9,21,24,29,33,38,41,46,54,59,66,68,85H( MODE INTEGER 0010 7,8,12,82(H NCH INTEGER 0011 9,10,24,25,26,27,41,42,43,44,68,69,70,71 H( ND INTEGER 001B 71,72,74 (: NF INTEGER 0015 22,23,27,28,29,31,35,37,63 :: NR INTEGER 0017 39,40,44,45,46,49,56,64,65 :* NWDS INTEGER 001C 77,78,79,82*4 PLU INTEGER 7FFF 1,2,19,35,56,62,80,824& R INTEGER 000B 2,3,15 && TEMP INTEGER 0002 2,50,75&. TLU INTEGER 000D 2,3,17,32,50,75.   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < $ CCSGET SUBROUTINE 008D 10,13$$ DISP SUBROUTINE 027C 50,76$$ FREAD SUBROUTINE 0274 49,75$* INPUT SUBROUTINE 024F 8,24,41,68 *( INTGR SUBROUTINE 025E 26,44,71 ($ LINK INTEGER.FN. 027E 52,77$t FTN 3.3B (OPT = LPC) TAPE PAGE 6 DATE: 08/29/84 TIME: 2306 t Q8PKUP INTEGER.FN. 02F2 Q8PREP INTEGER.FN. 02EF Q8QEND INTEGER.FN. 02C1 Q8QINI INTEGER.FN. 028E 6 Q8QX SUBROUTINE 02BE 29,35,46,56,59,62,80,856" SEEIT SUBROUTINE 02AF 81 "$ TAPMOT SUBROUTINE 00B0 17,32$   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < , 1 001E 3,69,72,84,87,$ 100 00AF 15,17$( 200 00C9 14,21,25 ($ 250 011A 30,32$( 300 014B 26,28,37 ($ 301 014C 37,42$$ 350 01B1 47,52$$ 400 01B7 47,53$$ 450 01E8 52,59$* 500 0234 43,45,58,65*$ 501 0235 65,70$" 550 0273 74 "$ 600 027D 72,77$" 650 0287 78 "$ 1000 02B4 73,83$$ 1200 02B8 77,85$( 8000 02E9 10,16,88 (" 9000 0025 4,5"$ 9001 00CF 21,22$$ 9002 0105 29,30$$ 9003 0125 33,34$$ 9004 0152 38,39$$ 9005 018C 46,47$$ 9006 01C0 54,55$$ 9007 01F1 59,60$$ 9008 023B 66,67$$ 9009 0298 80,81$$ 9010 02C3 85,86$$ 9101 00BD 19,20$( 9102 013E 35,36,62 ($ 9103 01D9 56,57$ TAPE 02EC 1 t FTN 3.3B (OPT = LPC) TOTEDT PAGE 1 DATE: 08/29/84 TIME: 2306 t^ 1 SUBROUTINE TOTEDT(NUMIN,NUMED) C2400001^^ 1 1 /C24 F CCS CCS 3.0 SL-149C2400002^^ C C2400003^^ C CYBERCREDIT SYSTEM VERSION 3 C2400004^^ C DATA SYSTEMS.-LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C2400005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C2400006^^ C C2400007^^ C C2400008^^ C CALLING SEQUENCE: C2400009^^ C WHERE THE PARAMETERS HAVE THE FOLLOWING DEFINITIONS: C2400010^^ C C2400011^^ C NUMIN = UNEDITED NUMERICAL DATA C2400012^^ C NUMED = EDITED DATA OUT C2400013^^ C SEARCH FOR LEADING ZEROES C2400014^^ C C2400015^^ 2 INTEGER NUMED(7),NUMIN(6),BLANK,FF,PERIOD,ZERO,COMPAR C2400016^^ C C2400017^^ 3 DATA BLANK/$2020/,PERIOD/$002E/,ZERO/$0000/,FF/$FF/,COMPAR/$3000/ C2400018^^ C C2400019^^ 4 CALL CCSBLK(NUMED,14) C2400020^^ 5 IFND = 0 C2400021^^ 6 10 DO 130 I = 1, 12 C2400022^^ 7 IF(I.GE.10) GO TO 120 C2400023^^ 8 IF(IFND .EQ. 1) GO TO 120 C2400024^^ C COMPARE EACH CHARACTER FROM NUMIN TO ZERO - ZERO SUPPRESS C2400025^^ 9 15 CALL CCSCST(NUMIN,I,1,COMPAR,1,1,ICOMP) C2400026^^ 10 IF(ICOMP .NE. 0) GO TO 120 C2400027^^ C MOVE IN A BLANK C2400028^^ 11 CALL CCSMVA(BLANK,1,1,NUMED,I,1) C2400029^^ 12 GO TO 130 C2400030^^ C CHARACTER IS NOT ZERO - MOVE TO NUMED - SET I FOUND SWITCH C2400032^^ 13 120 CALL CCSMVA(NUMIN,I,1,NUMED,I,1) C2400033^^ 14 IFND = 1 C2400034^^ 15 130 CONTINUE C2400035^^ C MOVE CHARACTER DOWN 1 BYTE, MOVE IN PERIOD C2400037^^ 16 140 CALL CCSMVA ( NUMED, 12, 1, NUMED, 13, 1 ) C2400038^^ 17 CALL CCSMVA ( NUMED, 11, 1, NUMED, 12, 1 ) C2400039^^ 18 150 CALL CCSMVA(PERIOD,2,1,NUMED,11,1) C2400040^^ 19 160 RETURN C2400041^^ 20 END C2400042^t FTN 3.3B (OPT = LPC) TOTEDT PAGE 2 DATE: 08/29/84 TIME: 2306 t  PROGRAM LENGTH $006D ( 109)   EXTERNALS & Q8PKUP Q8PREP CCSBLK CCSCST CCSMVA & t FTN 3.3B (OPT = LPC) TOTEDT PAGE 3 DATE: 08/29/84 TIME: 2306 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < 6 0001 (1) 0000 6,8,9,11,13,14,16,17,186" 0002 (2) 000D 18 "$ 000B (11) 000C 17,18$& 000C (12) 0009 6,16,17&" 000D (13) 000B 16 " 000E (14) 0006 4    VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < & BLANK INTEGER 0001 2,3,11 &$ COMPAR INTEGER 0005 2,3,9$" FF INTEGER 0002 2,3"* I INTEGER 0008 5,7,9,11,13*$ ICOMP INTEGER 000A 9,10 $( IFND INTEGER 0007 4,5,8,14 (4 NUMED INTEGER 7FFF 1,2,4,11,13,16,17,18 4( NUMIN INTEGER 7FFF 1,2,9,13 (& PERIOD INTEGER 0003 2,3,18 &" ZERO INTEGER 0004 2,3"   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  CCSBLK SUBROUTINE 000F 3 CCSCST SUBROUTINE 001F 8 . CCSMVA SUBROUTINE 002B 10,13,16,17,18 . Q8PKUP INTEGER.FN. 005F Q8PREP INTEGER.FN. 005C t FTN 3.3B (OPT = LPC) TOTEDT PAGE 4 DATE: 08/29/84 TIME: 2306 t   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : <  10 0014 5 15 001E 8 ( 120 0033 7,8,10,13(& 130 003C 5,12,15&" 140 0041 15 "" 150 004F 17 "" 160 0056 18 " TOTEDT 0059 1 t FTN 3.3B (OPT = LPC) TRENDF PAGE 1 DATE: 08/29/84 TIME: 2306 t^ 1 PROGRAM TRENDF C2500001^^ 1 1 /C25 F CCS CCS 3.0 .LA - PSRD RWE 10/82 SL-XXX********^^ C C2500003^^ C CYBERCREDIT SYSTEM VERSION 3 C2500004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C2500005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C2500006^^ C C2500007^^ C THIS PROGRAM COMBINES TRENDD AND TRENDE INTO ONE FORTRAN PROGRAM C2500008^^ C THIS PROGRAM CREATES OR UPDATES THE EXTRACT FILE (ACCAGE) USED C2500009^^ C IN THE TREND ANALYSIS REPORT. C2500010^^ C C2500011^^ C IF THE ACCAGE FILE IS EMPTY, THE DELINQUENT MASTER FILE(DELQMST) C2500012^^ C IS READ SEQUENTIALLY AND A RECORD IS CREATED FOR EACH DELQMST C2500013^^ C RECORD. IF THE DELQMST RECORD HAS AN INACTIVE STATUS OF R,S,OR W,C2500014^^ C A RECORD IS CREATED IN THE RSWFIL. IF A RECORD HAS A ACTIVE C2500015^^ C STATUS, A RECORD IS CREATED TO THE ACCAGE FILE. AFTER THE ACCAGE C2500016^^ C FILE IS CREATED, IT IS UPDATED DURING THE HOST UPDATE. C2500017^^ C C2500018^^ C IF THE ACCAGE FILE IS NOT EMPTY, THE ACCAGE FILE IS READ C2500019^^ C SEQUENTAILLY AND UPDATED BY RANDOMLY READING THE DELQMST FILE. C2500020^ ^ C UPDAT1 SWITCH(WORD 13 OF ACCAGE FILE)- IF THE ACCAGE FILE IS EMPTYC2500022^^ C THE CURRENT FIELDS MUST BE MOVED TO THE PREVIOUS FIELDS NEXT TIME C2500023^^ C TRENDF IS RUN. UPDAT1 IS SET TO 1 IF THE FILE IS EMPTY. IF THE C2500024^^ C UPDAT1 SWITCH IS SET TO 1 THE CURRENT FIELDS WILL BE MOVED TO THE C2500025^^ C PREVIOUS FIELDS NEXT TIME TRENDF IS RUN. DURING THIS RUN THE UPDATC2500026^^ C SWITCH IS RESET TO 0. C2500027^ ^ C UPDAT2 SWITCH(WORD 14 OF ACCAGE FILE)-THIS IS SET ONLY BY THE C2500029^^ C OPERATOR TO THE UPDATE PROMPT. IF THE OPERATOR ANSWERS YES THE C2500030^^ C FIELDS FILL BE UPDATED DURING THE EXTRACT. IF THE OPERATOR C2500031^^ C ANSWERS NO THE PREVIOUS FIELDS STAY THE SAME. THIS PROMPT IS IN THC2500032^^ C TRENDU PROGRAM. C2500033^ ^ C**** TRENDF - MODIFIED TO USE RECORD BLOCKING. ********^^ C DON'T DO DELETE FROM ACCAGE. JUST FLAG RECORD SO IT ********^^ C CAN BE REMOVED BY DSORT. ********^^ C FIXED TO CLEAR AND CREATE RSWFIL IF BUILDING ACCAGE. ********^^ C AND ALSO WHEN OUTPUTTING TO RSWFIL DURING UPDATE OF ********^^ C ACCAGE TO MOVE CURRENT TO PREVIOUS ON RSWFIL RECORD. ********^ t FTN 3.3B (OPT = LPC) TRENDF PAGE 2 DATE: 08/29/84 TIME: 2306 t ^ 2 INTEGER AMONTO,ADAYTO,AYERTO,RSWREQ(24),RDATA(15) C2500037^^ 3 INTEGER ACCREQ(24),ACCREC(45),ACDATA(15),ACCKEY(8),DAYDLQ C2500038^^ 4 INTEGER DELREQ(24),DELQRC(15004),DDATA(15),DELKEY(8) ********^^ 5 INTEGER DT(3),RDT(7),LRDT(4),READA,READD,EOFA,EOFD ********^^ 6 INTEGER MSG2(61),IDUSER(4),DELETE,WRTRSW,HDAYS C2500041^^ 7 INTEGER DELQDT(3),DAYS(2),APOS(8),ALEN(4),DPOS(12),DLEN(6) C2500042^^ 8 INTEGER FMRDEL,FDEL,UPDAT1,UPDAT2 C2500043^^ 9 INTEGER RSWB(2),RSW9(2,3),ACCRC1(1),RSWREC(620),RSWF ********^^ 10 EQUIVALENCE (DELQRC(1005),ACCRC1(1)) ********^^ 11 INTEGER IBUF(3),MSG1(24),YES(2),NO C2500045^  ^ 12 DATA ACCREQ/24*0/,ACCREC/45*0/,ACCKEY/8*$2020/ C2500047^^ 13 DATA DELREQ/24*0/,DELQRC/15004*$2020/,DELKEY/8*$2020/ ********^^ 14 DATA RSWB/'RSW '/,RSW9/'998 999 997 '/,IFIRST/0/,RSWF/0/ ********^^ 15 DATA IOF/0/,IEND/0/,NUMPUT/0/,NUMHI/15/,LNDLQB/15000/ ********^^ 16 DATA RSWREQ/24*0/,WRTRSW/0/ C2500049^^ 17 DATA INIT/1/, EOFD/0/, ICNT/0/ C2500050^^ 18 DATA DT/3*$2020/,RDT/7*$2020/,LRDT/4*$2020/ ********^^ 19 DATA YES/'YES '/,NO/'NO'/ C2500053^ ^ C POSTITIONS IN ACCAGE C2500055^^ C MQUE 17 C2500056^^ C DAYS DELQ 35 C2500057^^ C MPYOF 41 C2500058^^ C MALDQ 59 C2500059^^ C LAST MQUE 21 C2500060^^ C LAST DAYS 38 C2500061^^ C LAST MPYOF 50 C2500062^^ C LAST MADLQ 68 C2500063^^ 20 DATA APOS/17,35,41,59,21,38,50,68/ C2500064^^ 21 DATA ALEN/4,3,9,9/ C2500065^ ^ C POSITIONS IN DELQMST AND ACCAGE C2500067^^ C MQUE 271 17 C2500068^^ C MTCD 963 25 C2500069^^ C MDLDT 875 29 C2500070^^ C MPYOF 905 41 C2500071^^ C MADLQ 887 59 C2500072^^ C MSTC 306 77 C2500073^^ 22 DATA DPOS/271,963,875,905,887,306,17,25,29,41,59,77/ C2500074^^ 23 DATA DLEN/4,4,6,9,9,1/ C2500075^ ^ 24 DATA MSG1/$0A0D,'AS OF DATE WAS NOT GREATER THAN LAST', C2500077^^ 24 1 ' RUN DATE '/ C2500078^^ 25 DATA MSG2/$0A0D,$0A0D,'PLEASE ENTER "AS OF" DATE FOR TREND', C2500079^^ 25 1'ANALYSIS CALCULATION -',$0A0D,' ENTER : MMDDYY OR ', C2500080^^ 25 2'CARRIAGE RETURN TO USE SYSTEM DATE',$0A0D/ C2500081^ ^ C************************************************************** ???*A046********^^ 26 DATA ACDATA/'LAACCAGE',8*$2020,1,1,-1/ ********^^ 27 DATA DDATA /'LADLQMST',8*$2020,1,1,0/ ********^^ 28 DATA RDATA /'LARSWFIL',8*$2020,0,1,0/ ********^t FTN 3.3B (OPT = LPC) TRENDF PAGE 3 DATE: 08/29/84 TIME: 2306 t^ 29 INTEGER DDAT(4) ********^^ 30 DATA DDAT/'DELQMST '/ ********^ ^ C************************************************************** ???*A043********^^ 31 INTEGER DTMSG(32),DTINP(2) ********^^ 32 DATA DTMSG/$0A0D,'THE DATE ENTERED IS . IS THIS THE CORRECT ********^^ 32 1DATE? Y OR N',$0A0D/ ********^^ C************************************************************** ???*A043********^^ C C2500087^^ 33 EXTERNAL AMONTO,AYERTO,ADAYTO,FMRDEL C2500088^ ^ C LOG IN C2500090^^ 34 CALL PGMIN(IDUSER,LUNIT,MODE,NOPORT) C2500091^ ^ 35 CALL CCSCST(RDATA,1,2,IDUSER,1,8,ICM) ********^^ 36 IF(ICM.EQ.0) GO TO 5 ********^^ 37 CALL CCSMVA(RDATA,3,6,RDATA,1,8) ********^^ 38 CALL CCSMVA(ACDATA,3,6,ACDATA,1,8) ********^^ 39 CALL CCSMVA(DDAT ,1,8,DDATA,1,8) ********^^ 40 5 CONTINUE ********^  ^ C OPEN THE ACCAGE FILE C2500097^^ 41 100 CALL OPENFL(ACCREQ,ACDATA,ISTAT) C2500098^^ 42 IF(ISTAT.GE.0) GO TO 110 C2500100^^ 43 CALL FILERR(ACDATA,3,ISTAT,LUNIT) C2500101^^ 44 GO TO 990 C2500102^ ^ C BRING IN SYSTEM DATE C2500104^^ 45 110 DT(1)=AND($FFFF,AMONTO) C2500105^^ 46 DT(2)=AND($FFFF,ADAYTO) C2500106^^ 47 DT(3)=AND($FFFF,AYERTO) C2500107^^ 48 ASSEM $C000,FMRDEL,$6800,FDEL C2500108^ ^ C READ HEADER FROM ACCAGE FILE C2500110^^ 49 120 CALL CCSBLK(ACCKEY,16) C2500111^^ 50 CALL GETS(ACCREQ,ACCREC,ACCKEY,ISTAT) ***00112^^ C EOF ? INIT=0, IF NO HEADER IS FOUND C2500113^^ 51 IF(AND(ISTAT,$0100).EQ.$0100) INIT = 0 C2500114^^ 52 IF(INIT.EQ.0) GO TO 150 C2500115^^ C NOT EOF C2500116^^ 53 IF(ISTAT.GE.0) GO TO 140 C2500117^^ 54 CALL FILERR(ACDATA,14,ISTAT,LUNIT) ***00118^^ 55 GO TO 900 C2500119^ ^ C HEADER WAS FOUND C2500121^^ 56 140 CALL CCSBLK(ACCKEY,16) C2500122^^ C VERIFY ACCOUNT WAS THE HEADER C2500123^^ 57 CALL CCSCST(ACCKEY,1,16,ACCREC,1,16,ICOMP) C2500124^^ 58 IF(ICOMP.NE.0) GO TO 150 C2500125^^ C RECORD WAS HEADER. C2500126^^ C SET UP UPDATE SWITCHES C2500127^^ 59 UPDAT1=ACCREC(13) C2500128^^ 60 UPDAT2=ACCREC(14) C2500129^t FTN 3.3B (OPT = LPC) TRENDF PAGE 4 DATE: 08/29/84 TIME: 2306 t^ 61 ACCREC(13)=0 C2500130^^ 62 ACCREC(14)=0 C2500131^ ^ C*** BLANK OUT RSW FLAG ON HEADER IN CASE NO INACTIVE RECORDS FOUND ! ********^^ 63 CALL CCSMVA(ACCREC,1,0,ACCREC,50,3) ********^^ 64 GO TO 160 C2500132^ ^ C HEADER WAS NOT FOUND. CREATE HEADER. C2500134^^ 65 150 CALL CCSBLK(ACCKEY,16) C2500135^^ 66 CALL CCSBLK(ACCREC,84) C2500136^ ^ C INITIALIZE UPDATE SWITCHES IN ACCAGE C2500138^^ 67 UPDAT1=1 C2500139^^ 68 UPDAT2=0 C2500140^^ 69 ACCREC(13)=1 C2500141^^ 70 ACCREC(14)=0 C2500142^^ 71 GO TO 160 C2500143^ ^ 72 155 CALL WTREAD(LUNIT,-1,MSG1,48,-1,RDT,0,ITC) C2500145^^ C PROMPT THE OPERATOR FOR RUN DATE C2500146^^ 73 160 CALL CCSMVA(RDT,1,0,RDT,1,14) ********^^ 74 CALL WTREAD(LUNIT,-1,MSG2,122,-1,RDT,12,ITC) ********^^ C VERIFY THE INPUT FOR TERMINATOR C2500149^^ 75 IF(ITC.NE.2) GO TO 160 C2500150^^ C************************************************************** ???*A043********^^ C DATE CHECKING ********^^ 76 IF(RDT(1).EQ.$2020) CALL CCSMVA(DT,1,6,DTMSG,23,6) ********^^ 77 IF(RDT(1).NE.$2020) CALL CCSMVA(RDT,1,6,DTMSG,23,6) ********^^ C ASK IF IT IS THE CORRECT DATE ********^^ 78 165 DTINP(1) = $2020 ********^^ 79 CALL WTREAD(LUNIT,-1,DTMSG,64,-1,DTINP,2,ITC) ********^^ C CHECK FOR AN 'N' AND IF SO GO REDO PROMPT FOR DATE ********^^ 80 IF(DTINP(1).EQ.$4E4F.OR.DTINP(1).EQ.$4E20) GO TO 160 ********^^ C CHECK FOR 'Y' AND IF NOT GO REDO PROMPT FOR Y OR N ********^^ 81 IF(DTINP(1).EQ.YES(1).OR.DTINP(1).EQ.$5920) GO TO 167 ********^^ C DATE WAS VERIFIED-CONTINUE ********^^ C************************************************************** ???*A043********^^ 82 167 CONTINUE ********^^ C CHECK FOR DEFAULT C2500151^^ 83 IF(RDT(1).EQ.$2020) GO TO 170 C2500152^^ C VERIFY THAT IT IS VALID DATE C2500153^^ 84 IF(RDT(7).NE.6) GO TO 160 ********^^ 85 IF(IDATVR(RDT,1).LT.0) GO TO 160 C2500155^^ 86 GO TO 180 C2500156^ ^ C DEFAULT TO SYSTEM DATE C2500158^^ 87 170 CALL CCSMVA(DT,1,6,RDT,1,6) C2500159^ ^ C CHECK FOR UPDATE OF LAST FIELDS C2500161^^ 88 180 IF(INIT.EQ.0) GO TO 200 C2500162^^ 89 ACCREC(13)=0 C2500163^ ^ C UPDATE PREVIOUS FIELDS C2500165^^ C VERIFY LAST RUN DATE IS LESS THAN RUN DATEC2500166^t FTN 3.3B (OPT = LPC) TRENDF PAGE 5 DATE: 08/29/84 TIME: 2306 t^ 90 190 CALL CCSMVA(ACCREC,29,6,LRDT,1,6) C2500167^^ 91 IF(RDT(3)-LRDT(3)) 155,194,195 C2500168^^ 92 194 JLRDT=ICALJL(LRDT,1) C2500169^^ 93 JRDT=ICALJL(RDT,1) C2500170^^ 94 IF(JRDT.LT.JLRDT) GO TO 155 C2500171^ ^ C RUN DATE IS GOOD. UPDATE LAST RUN DATE. C2500173^^ 95 195 IF(UPDAT1.EQ.0.AND.UPDAT2.EQ.0) GO TO 200 C2500174^^ 96 CALL CCSMVA(LRDT,1,6,ACCREC,35,6) C2500175^ ^ C MOVE IN NEW RUN DATE C2500177^^ 97 200 CALL CCSMVA(RDT,1,6,ACCREC,29,6) C2500178^ ^ C UPDATE OR WRITE HEADER C2500180^^ 98 IF(INIT.EQ.0) CALL WRITER(ACCREQ,ACCREC,ACCKEY,ISTAT) C2500181^^ 99 IF(INIT.EQ.1) CALL UPDREC(ACCREQ,ACCREC,ISTAT) C2500182^^ 100 IF(ISTAT.GE.0) GO TO 220 C2500183^^ 101 IF(INIT.EQ.0) K=12 C2500184^^ 102 IF(INIT.EQ.1) K=15 C2500185^^ 103 CALL FILERR(ACDATA,K,ISTAT,LUNIT) C2500186^^ 104 GO TO 900 C2500187^ ^ 105 220 CONTINUE ********^^ 106 CALL CLOSFL(ACCREQ,ISTAT) ********^^ 107 NUMACC = (LNDLQB-1005)/42 ********^^ 108 NUMDLQ = LNDLQB/1000 ********^^ 109 ACDATA(13) = 0 ********^^ 110 ACDATA(14) = NUMACC ********^^ 111 IF (INIT.NE.0) GO TO 225 ********^^ 112 DDATA(13) = 0 ********^^ 113 DDATA(14) = NUMDLQ ********^^ 114 ACDATA(13) = 1 ********^^ 115 ACDATA(14) = 1 ********^^ 116 CALL CLEAR(RSWREQ,RDATA,ISTAT) ********^^ 117 IF(ISTAT.GE.0) GO TO 225 ********^^ 118 CALL FILERR(RDATA,01,ISTAT,LUNIT) ********^^ 119 GO TO 950 ********^^ 120 225 CONTINUE ********^^ 121 DO 226 I = 1,24 ********^^ 122 ACCREQ(I) = 0 ********^^ 123 226 RSWREQ(I) = 0 ********^^ 124 CALL OPENFL(ACCREQ,ACDATA,ISTAT) ********^^ 125 IF (ISTAT.GE.0) GO TO 228 ********^^ 126 CALL FILERR(ACDATA,3,ISTAT,LUNIT) ********^^ 127 GO TO 950 ********^^ 128 228 CONTINUE ********^^ 129 CALL OPENFL(DELREQ,DDATA,ISTAT) C2500191^^ 130 IF(ISTAT.GE.0) GO TO 230 C2500192^^ 131 CALL FILERR(DDATA,3,ISTAT,LUNIT) C2500193^^ 132 GO TO 900 C2500194^^ 133 230 CALL OPENFL(RSWREQ,RDATA,ISTAT) C2500195^^ 134 IF(ISTAT.GE.0) GO TO 235 C2500196^^ 135 CALL FILERR(RDATA,3,ISTAT,LUNIT) C2500197^^ 136 GO TO 900 C2500198^t FTN 3.3B (OPT = LPC) TRENDF PAGE 6 DATE: 08/29/84 TIME: 2306 t ^ C IF ACCAGE IS EMPTY-CREATE THE ACCAGE FILE C2500200^^ 137 235 DELREQ(23)=1 C2500201^^ 138 IF(INIT.EQ.0) GO TO 500 C2500202^t FTN 3.3B (OPT = LPC) TRENDF PAGE 7 DATE: 08/29/84 TIME: 2306 t^ C ACCAGE IS NOT EMPTY, UPDATE ACCAGE FROM C2500204^^ C THE DELQMST FILE C2500205^^ 139 240 CONTINUE ********^^ 140 CALL GETS(ACCREQ,ACCRC1,ACCKEY,ISTAT) ********^^ 141 IF(AND(ISTAT,$100).EQ.$100) IOF = 1 ********^^ 142 IF(IOF.EQ.1) GO TO 250 ********^^ 143 IF(ISTAT.GE.0) GO TO 250 ********^^ 144 CALL FILERR(ACDATA,14,ISTAT,LUNIT) ********^^ 145 GO TO 950 ********^^ 146 250 CONTINUE ********^^ 147 NUMRED = ACCREQ(15) ********^^ 148 IF (NUMRED.LE.0) GO TO 400 ********^^ 149 DO 400 IL = 1,NUMRED ********^^ 150 IPT = IL*41-40 ********^^ 151 IF (IFIRST.EQ.0) GO TO 395 ********^^ 152 IF (ACCRC1(IPT).EQ.FDEL) GO TO 400 ********^^ 153 CALL CCSMVA(ACCRC1(IPT),1,16,DELKEY,1,16) ********^^ 154 CALL READR(DELREQ,DELQRC,DELKEY,ISTAT) ********^^ 155 IF(AND(ISTAT,$200).EQ.$200.OR.AND(ISTAT,$100).EQ.$100)GO TO 390 ********^^ 156 IF(ISTAT.GE.0) GO TO 300 C2500224^^ 157 280 CALL FILERR(DDATA,13,ISTAT,LUNIT) C2500225^^ 158 GO TO 950 C2500226^ ^ 159 300 CONTINUE ********^^ 160 CALL CCSGET(DELQRC,306,MSTC) ********^^ 161 DO 305 I1 = 1,4 ********^^ 162 CALL CCSGET(RSWB,I1,ICH) ********^^ 163 IF (ICH.NE.MSTC) GO TO 305 ********^^ 164 GO TO 310 ********^^ 165 305 CONTINUE ********^^ 166 310 IF (I1.LT.4) GO TO 315 ********^^ 167 IF (UPDAT1.EQ.0.AND.UPDAT2.EQ.0) GO TO 340 ********^^ 168 315 CONTINUE ********^ ^ C MOVE CURRENT FIELDS TO LAST RUN FIELDS C2500231^^ 169 DO 320 I=1,4 C2500232^^ 170 CALL CCSMVA(ACCRC1(IPT),APOS(I),ALEN(I), ********^^ 170 + ACCRC1(IPT),APOS(I+4),ALEN(I)) ********^^ 171 320 CONTINUE C2500234^ ^ C MOVE DELQMST FIELDS TO CURRENT FIELDS C2500236^^ 172 340 DO 360 I=1,6 C2500237^^ 173 CALL CCSMVA(DELQRC,DPOS(I),DLEN(I), ********^^ 173 + ACCRC1(IPT),DPOS(I+6),DLEN(I)) ********^^ 174 360 CONTINUE C2500239^^ 175 CALL CCSMVA(DELQRC,875,6,DELQDT,1,6) C2500240^ ^ 176 IF (I1.GE.4) GO TO 380 ********^^ 177 CALL CCSCST(ACCRC1(IPT),35,3,RSWB,1,3,ICM) ********^^ 178 IF (ICM.EQ.0) GO TO 390 ********^^ 179 NUMPUT = NUMPUT+1 ********^^ 180 RSWF = 1 ********^^ 181 IP1 = NUMPUT*41-40 ********^^ 182 CALL CCSMVA(ACCRC1(IPT),1,82,RSWREC(IP1),1,82) ********^t FTN 3.3B (OPT = LPC) TRENDF PAGE 8 DATE: 08/29/84 TIME: 2306 t^ 183 CALL CCSMVA(RSW9(1,I1),1,3,RSWREC(IP1),35,3) ********^^ 184 CALL CCSMVA(RSWB,1,3,ACCRC1(IPT),35,3) ********^^ 185 IF (NUMPUT.LT.NUMHI) GO TO 375 ********^^ 186 370 CALL PUTS(RSWREQ,RSWREC,NUMPUT,ISTAT) ********^^ 187 IF(ISTAT.GE.0) GO TO 375 ********^^ 188 CALL FILERR(RDATA,11,ISTAT,LUNIT) ********^^ 189 GO TO 950 ********^^ 190 375 CONTINUE ********^^ 191 NUMPUT = 0 ********^^ 192 IF (IEND.EQ.1) GO TO 420 ********^^ 193 GO TO 400 ********^^ 194 380 CONTINUE ********^^ 195 ASSIGN 385 TO IRTN ********^^ 196 GO TO 700 ********^^ 197 385 CALL CCSMVA(DAYS,1,3,ACCRC1(IPT),35,3) ********^^ 198 GO TO 400 ********^^ 199 390 CONTINUE ********^^ 200 CALL CCSMVA(RSWB,1,3,ACCRC1(IPT),35,3) ********^^ 201 RSWF = 1 ********^^ 202 395 IFIRST = 1 ********^^ 203 400 CONTINUE ********^^ 204 CALL UPDREC(ACCREQ,ACCRC1,ISTAT) ********^^ 205 IF (ISTAT.GE.0) GO TO 410 ********^^ 206 CALL FILERR(ACDATA,15,ISTAT,LUNIT) ********^^ 207 GO TO 950 ********^^ 208 410 CONTINUE ********^^ 209 IF (IOF.NE.1) GO TO 240 ********^^ 210 IEND = 1 ********^^ 211 IF (NUMPUT.GT.0) GO TO 370 ********^^ 212 420 CONTINUE ********^^ 213 IF (RSWF.NE.1) GO TO 950 ********^ ^ C*** UPDATE HEADER RECORD TO REFLECT INACTIVE RECORDS ENCOUNTERED. ********^ ^ 214 ACCKEY(1) = 0 ********^^ 215 ACCKEY(2) = 1 ********^ ^ 216 CALL READR(ACCREQ,ACCRC1,ACCKEY,ISTAT) ********^^ 217 IF (ISTAT.GE.0) GO TO 430 ********^^ 218 CALL FILERR(ACDATA,13,ISTAT,LUNIT) ********^^ 219 GO TO 950 ********^^ 220 430 CONTINUE ********^^ 221 CALL CCSMVA(RSWB,1,3,ACCRC1,50,3) ********^^ 222 CALL UPDREC(ACCREQ,ACCRC1,ISTAT) ********^^ 223 IF (ISTAT.GE.0) GO TO 950 ********^^ 224 CALL FILERR(ACDATA,15,ISTAT,LUNIT) ********^^ 225 GO TO 950 ********^t FTN 3.3B (OPT = LPC) TRENDF PAGE 9 DATE: 08/29/84 TIME: 2306 t^ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC2500283^^ C CREATE ACCAGE FILE FROM DELQMST C2500284^ ^ C READ THE DELQMST AND BUILD ACCAGE REC C2500286^^ 226 500 CONTINUE ********^^ 227 CALL GETS(DELREQ,DELQRC,DELKEY,ISTAT) ********^^ 228 IF(AND(ISTAT,$100).EQ.$100) IOF = 1 ********^^ 229 IF (IOF.EQ.1) GO TO 530 ********^^ 230 IF (ISTAT.GE.0) GO TO 530 ********^^ 231 CALL FILERR(DDATA,14,ISTAT,LUNIT) ********^^ 232 GO TO 950 ********^^ 233 530 CONTINUE ********^^ 234 NUMRED = DELREQ(15) ********^^ 235 IF (NUMRED.EQ.0) GO TO 590 ********^^ 236 DO 590 IL = 1,NUMRED ********^^ 237 IPT = IL*1000-999 ********^^ 238 IF(DELQRC(IPT).EQ.FDEL) GO TO 590 ********^^ 239 CALL CCSBLK(ACCREC,82) ********^ ^ C BUILD ACCAGE RECORD C2500312^^ C FROM THE DELQMST FILE C2500313^^ 240 538 DO 540 K=1,6 C2500314^^ 241 CALL CCSMVA(DELQRC(IPT),DPOS(K),DLEN(K), ********^^ 241 + ACCREC,DPOS(K+6),DLEN(K)) ********^^ 242 540 CONTINUE ********^^ 243 CALL CCSMVA(DELQRC(IPT),875,6,DELQDT,1,6) ********^^ 244 CALL CCSMVA(DELQRC(IPT),1,16,ACCREC,1,16) ********^ ^ 245 CALL CCSGET(DELQRC(IPT),306,MSTC) ********^^ 246 DO 545 I1 = 1,4 ********^^ 247 CALL CCSGET(RSWB,I1,ICH) ********^^ 248 IF (ICH.NE.MSTC) GO TO 545 ********^^ 249 GO TO 547 ********^^ 250 545 CONTINUE ********^^ 251 547 IF (I1.LT.4) GO TO 570 ********^^ C COMPUTE DAYS DELQ C2500320^^ 252 550 ASSIGN 555 TO IRTN C2500321^^ 253 ASSIGN 700 TO DAYDLQ C2500322^^ 254 GO TO DAYDLQ C2500323^^ 255 555 CALL CCSMVA(DAYS,1,3,ACCREC,35,3) C2500324^ ^ C WRITE NEW ACCAGE RECORD C2500326^^ 256 560 ICNT=ICNT+1 C2500327^^ 257 CALL WRITER(ACCREQ,ACCREC,ACCREC,ISTAT) C2500328^^ 258 IF(ISTAT.GE.0) GO TO 590 C2500329^^ 259 CALL FILERR(ACDATA,12,ISTAT,LUNIT) C2500330^^ 260 GO TO 950 C2500331^  ^ 261 570 CONTINUE ********^^ 262 NUMPUT = NUMPUT+1 ********^^ 263 IP1 = NUMPUT*41-40 ********^^ 264 CALL CCSMVA(RSW9(1,I1),1,3,ACCREC,35,3) ********^^ 265 CALL CCSMVA(ACCREC,1,82,RSWREC(IP1),1,82) ********^t FTN 3.3B (OPT = LPC) TRENDF PAGE 10 DATE: 08/29/84 TIME: 2306 t^ 266 IF (NUMPUT.LT.NUMHI) GO TO 590 ********^^ 267 575 CALL PUTS(RSWREQ,RSWREC,NUMPUT,ISTAT) ********^^ 268 IF (ISTAT.GE.0) GO TO 580 ********^^ 269 CALL FILERR(RDATA,11,ISTAT,LUNIT) ********^^ 270 GO TO 950 ********^^ 271 580 CONTINUE ********^^ 272 NUMPUT = 0 ********^^ 273 IF (IEND.EQ.1) GO TO 600 ********^^ 274 590 CONTINUE ********^^ 275 IF (IOF.NE.1) GO TO 500 ********^^ 276 IEND = 1 ********^^ 277 IF (NUMPUT.GT.0) GO TO 575 ********^^ 278 600 CONTINUE ********^^ 279 GO TO 950 ********^t FTN 3.3B (OPT = LPC) TRENDF PAGE 11 DATE: 08/29/84 TIME: 2306 t^ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C2500358^^ C ROUTINE DAYDLQ C2500359^ ^ 280 700 CONTINUE C2500361^ ^ C THIS ROUTINE COMPUTES THE DAYS DELQ FROM THE RUN DATE AND C2500363^^ C THE DATE DELINQUENT AND PASSES IT BACK IN DAYS. C2500364^ ^ C GET JULIAN DATES C2500366^^ 281 710 HDAYS=0 C2500367^^ 282 DAYS(1)=$0000 C2500368^^ 283 DAYS(2)=$0000 C2500369^^ 284 JRDT=ICALJL(RDT,1) C2500370^^ 285 JDELDT=ICALJL(DELQDT,1) C2500371^^ C CHECK FOR DIFFERENT YEARS C2500372^^ 286 720 IF((RDT(3)-DELQDT(3)) .EQ. 0) GO TO 800 C2500373^^ C YEARS ARE DIFFERENT C2500374^^ 287 730 J=DELQDT(3)/4 C2500375^^ 288 J1=J*4 C2500376^^ 289 IF(J1.EQ.DELQDT(3)) HDAYS = (RDT(3)-DELQDT(3))*366 C2500377^^ 290 IF(J1.NE.DELQDT(3)) HDAYS = (RDT(3)-DELQDT(3))*365 C2500378^ ^ C SUBTRACT TO GET DAYS DELQ IN HEX C2500380^^ 291 800 HDAYS = (HDAYS + JRDT) - JDELDT C2500381^ ^ C ZERO DAYS DELQ IF DAYS DELQ ARE NEGATIVE C2500383^^ 292 IF(HDAYS.GE.0) GO TO 810 C2500384^^ 293 DAYS(1)=$3030 C2500385^^ 294 DAYS(2)=$3020 C2500386^^ 295 GO TO 820 C2500387^ ^ C CONVERT HEX TO DECIMAL C2500389^^ 296 810 IF(HDAYS.GT.180) HDAYS=180 C2500390^^ 297 IH1=HDAYS/100 C2500391^^ 298 IR=HDAYS - (IH1 * 100) C2500392^^ 299 IH2=IR/10 C2500393^^ 300 IH3=IR - (IH2 * 10) C2500394^^ 301 DAYS(1)=((IH1 + $0030) * $100) + (IH2 + $0030) C2500395^^ 302 DAYS(2)=((IH3 + $0030) * $100) + $0020 C2500396^ ^ 303 820 GO TO IRTN C2500398^^ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C2500399^t FTN 3.3B (OPT = LPC) TRENDF PAGE 12 DATE: 08/29/84 TIME: 2306 t^ C CLOSE ONLY ACCAGE C2500401^^ 304 900 CALL CLOSFL(ACCREQ,ISTAT) C2500402^^ 305 GO TO 990 C2500403^ ^ C CLOSE FILES C2500405^^ 306 950 CALL CLOSFL(ACCREQ,ISTAT) C2500406^^ 307 CALL CLOSFL(DELREQ,ISTAT) C2500407^^ 308 CALL CLOSFL(RSWREQ,ISTAT) C2500408^ ^ 309 990 CALL PGMOUT C2500410^^ 310 END C2500411^t FTN 3.3B (OPT = LPC) TRENDF PAGE 13 DATE: 08/29/84 TIME: 2306 t  PROGRAM LENGTH $4411 ( 17425)   EXTERNALS 2 Q8STP AMONTO ADAYTO AYERTO FMRDEL PGMIN CCSCST 22 CCSMVA OPENFL FILERR CCSBLK GETS WTREAD IDATVR 22 ICALJL WRITER UPDREC CLOSFL CLEAR READR CCSGET 2 PUTS PGMOUT  t FTN 3.3B (OPT = LPC) TRENDF PAGE 14 DATE: 08/29/84 TIME: 2306 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < * FFFE (-1) 3E9C 72,72,74,79*( FFFF (65535) 3E95 45,46,47 (‚ 0000 (0) 0003 12,13,14,15,16,17,27,28,36,42,51,52,53,58,61,62,63,68,70,72,73,85,88,89,95,98,100,101,109,111,112, ‚€ 117,122,123,125,130,134,138,143,148,151,156,167,178,187,191,205,211,214,217,223,230,235,258,268, €: 272,277,281,282,283,286,292:‚ 0001 (1) 0002 9,10,17,23,26,27,28,35,37,38,39,45,57,63,67,69,72,73,74,76,77,78,79,80,81,83,85,87,90,92,93,96,97, ‚‚ 99,102,114,115,118,121,137,141,142,149,153,161,169,172,175,177,179,180,182,183,184,192,197,200,201 ‚€ ,202,209,210,213,214,215,221,228,229,236,240,243,244,246,255,256,262,264,265,273,275,276,282,284,€* 285,293,301*B 0002 (2) 3E8F 35,46,75,79,183,215,264,283,294,302Bl 0003 (3) 3E92 37,38,43,47,63,91,126,131,135,177,183,184,197,200,221,255,264,286,287,289,290lR 0006 (6) 3E93 37,38,76,77,84,87,90,96,97,172,173,175,240,241,243 R* 0008 (8) 3E90 35,37,38,39*& 000A (10) 3ECF 299,300&& 000B (11) 3EC0 188,269&* 000C (12) 3EA0 74,101,259 *& 000D (13) 3EB8 157,218&B 000E (14) 3E98 54,60,62,70,73,110,113,115,144,231 B2 000F (15) 3EAC 102,147,206,224,23422 0010 (16) 3E96 49,56,57,65,153,2442( 0017 (23) 3EA2 76,77,137($ 001D (29) 3EA7 90,97$> 0023 (35) 3EAA 96,177,183,184,197,200,255,264 >* 0029 (41) 3EB6 150,181,263*" 002A (42) 3EAF 107"* 0030 (48) 3E9D 72,301,302 *& 0032 (50) 3E9A 63,221 &" 0040 (64) 3EA3 79 ". 0052 (82) 3EBF 182,182,239,265." 0054 (84) 3E9B 66 "& 0064 (100) 3ECC 297,298&" 007A (122) 3E9F 74 "& 00B4 (180) 3ECA 296,296&8 0100 (256) 3E97 51,51,141,155,228,301,3028& 0132 (306) 3EB9 160,245&" 016D (365) 3EC7 290"" 016E (366) 3EC6 289"& 0200 (512) 3EB7 155,155&& 036B (875) 3EBD 175,243&" 03E7 (999) 3EC2 237"& 03E8 (1000) 3EB1 108,237&" 03ED (1005) 3EAE 107"* 2020 (8224) 3EA1 76,77,78,83*" 3020 (12320) 3EC9 294"" 3030 (12336) 3EC8 293"" 4E20 (20000) 3EA5 80 "t FTN 3.3B (OPT = LPC) TRENDF PAGE 15 DATE: 08/29/84 TIME: 2306 t" 4E4F (20047) 3EA4 80 "" 5920 (22816) 3EA6 81 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < F ACCKEY INTEGER 007F 1,12,49,50,56,57,65,98,140,214,215,216 F\ ACCRC1 INTEGER 048C 1,10,140,152,153,170,173,177,182,184,197,200,204,216,221,222 \p ACCREC INTEGER 0043 1,12,50,57,59,60,61,62,63,66,69,70,89,90,96,97,98,99,239,241,244,255,257,264,265 p\ ACCREQ INTEGER 002B 1,12,41,50,98,99,106,122,124,140,147,204,216,222,257,304,306 \` ACDATA INTEGER 0070 1,26,38,41,43,54,103,109,110,114,115,124,126,144,206,218,224,259 `( ALEN INTEGER 3BB2 1,21,170 (6 AND INTR.FN. 7FFF 45,46,47,51,141,155,2286( APOS INTEGER 3BAA 1,20,170 (( DAYDLQ INTEGER 0087 1,253,254(@ DAYS INTEGER 3BA8 1,197,255,282,283,293,294,301,302@( DDAT INTEGER 3E66 28,30,39 (> DDATA INTEGER 3B3C 1,27,39,112,113,129,131,157,231>0 DELKEY INTEGER 3B4B 1,13,153,154,227 0< DELQDT INTEGER 3BA5 1,175,243,285,286,287,289,290<N DELQRC INTEGER 00A0 1,10,13,154,160,173,175,227,238,241,243,244,245N< DELREQ INTEGER 0088 1,13,129,137,154,227,234,307 <, DLEN INTEGER 3BC2 1,23,173,241 ,, DPOS INTEGER 3BB6 1,22,173,241 ,2 DT INTEGER 3B53 1,18,45,46,47,76,872. DTINP INTEGER 3E8A 30,78,79,80,81 .. DTMSG INTEGER 3E6A 30,32,76,77,79 .$ EOFD INTEGER 3B61 1,17 $, FDEL INTEGER 3BC8 1,48,152,238 ,@ HDAYS INTEGER 3BA4 1,281,289,290,291,292,296,297,298@: I INTEGER 3EB2 120,122,123,169,170,172,173:B I1 INTEGER 3EBB 160,162,166,176,183,246,247,251,264B" IBUF INTEGER 3E40 10 ". ICH INTEGER 3EBC 162,163,247,248., ICM INTEGER 3E91 35,36,177,178,& ICNT INTEGER 3E65 17,256 &$ ICOMP INTEGER 3E99 57,58$& IDUSER INTEGER 3B9F 1,34,35&2 IEND INTEGER 3E60 15,192,210,273,276 2* IFIRST INTEGER 3E5E 14,151,202 *. IH1 INTEGER 3ECB 296,297,298,301.. IH2 INTEGER 3ECE 298,299,300,301.* IH3 INTEGER 3ED0 299,300,302*. IL INTEGER 3EB4 149,150,236,237.@ INIT INTEGER 3E64 16,51,52,88,98,99,101,102,111,138@: IOF INTEGER 3E5F 14,141,142,209,228,229,275 :6 IP1 INTEGER 3EBE 180,181,182,183,263,2656b IPT INTEGER 3EB5 149,150,152,153,170,173,177,182,184,197,200,237,238,241,243,244,245b. IR INTEGER 3ECD 297,298,299,300.* IRTN INTEGER 3EC1 194,252,303*‚ ISTAT INTEGER 3E94 41,42,43,50,51,53,54,98,99,100,103,106,116,117,118,124,125,126,129,130,131,133,134,135,140,141,143 ‚t FTN 3.3B (OPT = LPC) TRENDF PAGE 16 DATE: 08/29/84 TIME: 2306 t€ ,144,154,155,156,157,186,187,188,204,205,206,216,217,218,222,223,224,227,228,230,231,257,258,259,€: 267,268,269,304,306,307,308:* ITC INTEGER 3E9E 72,74,75,79** J INTEGER 3EC4 286,287,288*. J1 INTEGER 3EC5 287,288,289,290.* JDELDT INTEGER 3EC3 284,285,291*( JLRDT INTEGER 3EA8 92,92,94 (0 JRDT INTEGER 3EA9 92,93,94,284,291 06 K INTEGER 3EAB 101,101,102,103,240,2416* LNDLQB INTEGER 3E63 15,107,108 *0 LRDT INTEGER 3B5D 1,18,90,91,92,96 0h LUNIT INTEGER 3E8C 34,43,54,72,74,79,103,118,126,131,135,144,157,188,206,218,224,231,259,269h" MODE INTEGER 3E8D 34 "( MSG1 INTEGER 3E43 10,24,72 (& MSG2 INTEGER 3B62 1,25,74&. MSTC INTEGER 3EBA 160,163,245,248.$ NO INTEGER 3E5D 10,19$" NOPORT INTEGER 3E8E 34 "* NUMACC INTEGER 3EAD 106,107,110** NUMDLQ INTEGER 3EB0 107,108,113** NUMHI INTEGER 3E62 15,185,266 *R NUMPUT INTEGER 3E61 15,179,181,185,186,191,211,262,263,266,267,272,277 R: NUMRED INTEGER 3EB3 146,147,148,149,234,235,236:B RDATA INTEGER 001C 1,28,35,37,116,118,133,135,188,269 BX RDT INTEGER 3B56 1,18,72,73,74,76,77,83,84,85,87,91,93,97,284,286,289,290 X, RSW9 INTEGER 3BCD 1,14,183,264 ,< RSWB INTEGER 3BCB 1,14,162,177,184,200,221,247 <0 RSWF INTEGER 3E3F 9,14,180,201,213 04 RSWREC INTEGER 3BD3 9,182,183,186,265,2674< RSWREQ INTEGER 0004 1,16,116,123,133,186,267,308 <. UPDAT1 INTEGER 3BC9 1,59,67,95,167 .. UPDAT2 INTEGER 3BCA 1,60,68,95,167 .$ WRTRSW INTEGER 3BA3 1,16 $( YES INTEGER 3E5B 10,19,81 (   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < . CCSBLK SUBROUTINE 42C2 48,56,65,66,239.( CCSCST SUBROUTINE 41AD 34,57,177(. CCSGET SUBROUTINE 4304 159,162,245,247.€ CCSMVA SUBROUTINE 4353 36,38,39,63,73,76,77,87,90,96,97,153,170,173,175,182,183,184,197,200,221,241,243,244,255,264,265 €" CLEAR SUBROUTINE 406F 115"2 CLOSFL SUBROUTINE 43FF 105,304,306,307,3082\ FILERR SUBROUTINE 433E 42,54,103,118,126,131,135,144,157,188,206,218,224,231,259,269\* GETS SUBROUTINE 4288 49,140,227 *, ICALJL INTEGER.FN. 439C 92,93,284,285," IDATVR INTEGER.FN. 3FCF 85 ". OPENFL SUBROUTINE 408E 40,124,129,133 ." PGMIN SUBROUTINE 3ED2 33 "" PGMOUT SUBROUTINE 440E 309"t FTN 3.3B (OPT = LPC) TRENDF PAGE 17 DATE: 08/29/84 TIME: 2306 t& PUTS SUBROUTINE 436C 185,267& Q8STP INTEGER.FN. 4410 & READR SUBROUTINE 4260 153,216&* UPDREC SUBROUTINE 4237 99,204,222 *& WRITER SUBROUTINE 4333 98,257 &( WTREAD SUBROUTINE 3F71 71,74,79 (   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 5 3EFA 36,40$" 100 3EFA 40 "$ 110 3F0A 42,45$" 120 3F1D 48 "$ 140 3F3E 53,56$( 150 3F61 52,58,65 (( 155 3F70 71,91,94 (4 160 3F7A 63,71,73,75,80,84,85 4" 165 3FA6 77 "$ 167 3FC6 81,82$$ 170 3FD6 83,87$$ 180 3FDD 85,88$" 190 3FE5 89 "$ 194 3FF6 91,92$$ 195 4006 91,95$( 200 4016 88,95,97 (& 220 4046 100,105&* 225 407D 111,117,120*& 226 4084 120,123&& 228 409C 125,128&& 230 40AA 130,133&& 235 40B9 134,137&& 240 40C1 138,209&* 250 40DD 142,143,146*" 280 4126 156"& 300 412D 156,159&* 305 4140 160,163,165*& 310 4145 163,166&& 315 4151 166,168&& 320 4174 168,171&& 340 4179 167,172&& 360 4197 172,174&& 370 41F5 185,211&* 375 4207 185,187,190*& 380 420F 176,194&& 385 4215 194,197&* 390 4222 155,178,199*& 395 422F 151,202&6 400 4232 148,149,152,193,198,2036& 410 4245 205,208&& 420 4253 192,212&t FTN 3.3B (OPT = LPC) TRENDF PAGE 18 DATE: 08/29/84 TIME: 2306 t& 430 426F 217,220&* 500 4287 138,226,275** 530 42A1 229,230,233*" 538 42C5 239"& 540 42E4 239,242&* 545 4316 245,248,250*& 547 431B 248,251&" 550 431F 251"& 555 4329 251,255&" 560 4330 255"& 570 4345 251,261&& 575 436B 266,277&& 580 437B 268,271&6 590 4382 235,236,238,258,266,2746& 600 4393 273,278&* 700 4394 194,253,280*" 710 4394 280"" 720 43A6 285"" 730 43AD 286"& 800 43C5 286,291&& 810 43D2 292,296&& 820 43FB 294,303&2 900 43FE 54,104,132,136,304 2Z 950 4404 118,127,145,158,189,207,213,219,223,225,232,260,270,279,306Z* 990 440D 43,305,309 * TRENDF 0000 1 t FTN 3.3B (OPT = LPC) TRENDU PAGE 1 DATE: 08/29/84 TIME: 2310 t^ 1 PROGRAM TRENDU C2600001^^ 1 1 /C26 F CCS CCS 3.0 SL-149C2600002^^ C C2600003^^ C CYBERCREDIT SYSTEM VERSION 3 C2600004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C2600005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C2600006^^ C C2600007^ ^ C THIS PROGRAM ASKS THE OPERATOR IF THE NEXT RUN OF TRENDF IS TO C2600009^^ C UPDATE THE PREVIOUS FIELDS WITH THE CURRENT FIELDS. IF THE C2600010^^ C OPERATOR WISHES TO UPDATE, A 1 IS PUT IN WORD 14 OF THE ACCAGE C2600011^^ C HEADER RECORD. IF NO UPDATE IS REQUESTED, A 0 REMAINS IN WORD 14. C2600012^  ^ 2 INTEGER IDUSER(4),IBUF(3),ACCBUF(24),ADATA(15) C2600015^^ 3 INTEGER ACCREC(84),MSG(37),YES(2),NO,KEY(8),UPDATE C2600016^ ^ 4 DATA ACCBUF/24*0/,YES/'YES '/,NO/'NO'/ C2600018^^ 5 DATA ADATA/'ACCAGE ',8*$2020,1,1,-1/ C2600019^^ 6 DATA MSG/$0A0D,$0A0D,'DO YOU WANT TO UPDATE PREVIOUS TREND', C2600020^^ 6 1' DATA FOR NEXT TREND RUN (YES/NO) '/ C2600021^ ^ 7 100 CALL PGMIN(IDUSER,LUNIT,MODE,NOPORT) C2600023^^ C IF(NOPORT.NE.0) GO TO 990 C2600024^ ^ 8 110 UPDATE=1 C2600026^ ^ C OPEN THE ACCAGE FILE C2600028^^ 9 120 CALL OPENFL(ACCBUF,ADATA,ISTAT) C2600029^^ 10 IF(ISTAT.GE.0) GO TO 130 C2600030^^ 11 CALL FILERR(ADATA,3,ISTAT,LUNIT) C2600031^^ 12 GO TO 990 C2600032^ ^ C READ THE HEADER RECORD C2600034^^ 13 130 CALL CCSBLK(KEY,16) C2600035^^ 14 CALL READR(ACCBUF,ACCREC,KEY,ISTAT) C2600036^^ 15 IF(ISTAT.GE.0) GO TO 160 C2600037^^ 16 CALL FILERR(ADATA,13,ISTAT,LUNIT) C2600038^^ 17 GO TO 990 C2600039^ ^ C COMPARE TO SEE IF HEADER WAS FOUND C2600041^^ 18 140 CALL CCSCST(ACCREC,1,16,KEY,1,16,ICOMP) C2600042^^ 19 IF(ICOMP.EQ.0) GO TO 160 C2600043^ ^ C NUMBERS NOT THE SAME C2600045^^ 20 ISTAT=$8200 C2600046^^ 21 GO TO 200 C2600047^ ^ C UPDATE HEADER C2600049^^ 22 160 ACCREC(14)=UPDATE C2600050^^ 23 CALL UPDREC(ACCBUF,ACCREC,ISTAT) C2600051^^ 24 IF(ISTAT.GE.0) GO TO 170 C2600052^^ 25 CALL FILERR(ADATA,15,ISTAT,LUNIT) C2600053^^ 26 GO TO 170 C2600054^t FTN 3.3B (OPT = LPC) TRENDU PAGE 2 DATE: 08/29/84 TIME: 2310 t ^ C CLOSE THE FILE C2600056^^ 27 170 CALL CLOSFL(ACCBUF,ISTAT) C2600057^^ 28 IF(ISTAT.GE.0) GO TO 990 C2600058^^ 29 CALL FILERR(ADATA,4,ISTAT,LUNIT) C2600059^^ 30 GO TO 990 C2600060^ ^ C DID NOT FIND HEADER C2600062^^ 31 200 CALL FILERR(ADATA,13,ISTAT,LUNIT) C2600063^ ^ 32 990 CALL PGMOUT C2600065^^ 33 STOP C2600066^^ 34 END C2600067^t FTN 3.3B (OPT = LPC) TRENDU PAGE 3 DATE: 08/29/84 TIME: 2310 t  PROGRAM LENGTH $0122 ( 290)   EXTERNALS 2 Q8STP PGMIN OPENFL FILERR CCSBLK READR CCSCST 2 UPDREC CLOSFL PGMOUT  t FTN 3.3B (OPT = LPC) TRENDU PAGE 4 DATE: 08/29/84 TIME: 2310 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < " 8200 (-32255) 00BE 20 "& 0001 (1) 0002 5,8,18 &" 0003 (3) 00BA 11 "" 0004 (4) 00C0 29 "$ 000D (13) 00BC 16,31$" 000F (15) 00BF 25 "$ 0010 (16) 00BB 13,18$   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < . ACCBUF INTEGER 000A 1,4,9,14,23,27 ., ACCREC INTEGER 0031 1,14,18,22,23,4 ADATA INTEGER 0022 1,5,9,11,16,25,29,31 4 IBUF INTEGER 0007 1 $ ICOMP INTEGER 00BD 18,19$" IDUSER INTEGER 0003 1,7"H ISTAT INTEGER 00B9 9,10,11,14,15,16,20,23,24,25,27,28,29,31 H* KEY INTEGER 00AD 1,13,14,18 *0 LUNIT INTEGER 00B6 7,11,16,25,29,31 0 MODE INTEGER 00B7 7 " MSG INTEGER 0085 1,6"" NO INTEGER 00AC 1,4" NOPORT INTEGER 00B8 7 & UPDATE INTEGER 00B5 1,8,22 &" YES INTEGER 00AA 1,4"   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " CCSBLK SUBROUTINE 00D9 13 "" CCSCST SUBROUTINE 00ED 17 "" CLOSFL SUBROUTINE 010D 27 ". FILERR SUBROUTINE 00D2 10,16,25,29,31 . OPENFL SUBROUTINE 00CA 8 PGMIN SUBROUTINE 00C2 6 " PGMOUT SUBROUTINE 011F 32 " Q8STP INTEGER.FN. 0121 " READR SUBROUTINE 00DD 13 "" UPDREC SUBROUTINE 00FF 22 "t FTN 3.3B (OPT = LPC) TRENDU PAGE 5 DATE: 08/29/84 TIME: 2310 t   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : <  100 00C1 6 110 00C7 7 120 00C9 8 $ 130 00D8 10,13$" 140 00EC 17 "( 160 00FB 15,19,22 (( 170 010C 24,26,27 ($ 200 0119 20,31$. 990 011E 11,17,28,30,32 . TRENDU 0000 1  t FTN 3.3B (OPT = LPC) TRHDT1 PAGE 1 DATE: 08/29/84 TIME: 2311 t^ 1 SUBROUTINE TRHDT1 (TRUTH, NP, IBOOL) C2700001^^ 1 1 /C27 F CCS CCS 3.0 SL-149C2700002^^ C C2700003^^ C CYBERCREDIT SYSTEM VERSION 3 C2700004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C2700005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C2700006^^ C C2700007^^ 2 INTEGER OORR C2700008^^ 3 DATA OORR /1/ C2700009^^ 4 INTEGER TRUTH(2,10) C2700010^^ C INITIALIZE TO 1ST PARAMETER C2700011^^ 5 IBOOL = TRUTH(1,1) C2700012^^ C CHECK FOR SINGLE PARAMETER C2700013^^ 6 IF ( NP .EQ. 1) RETURN C2700014^^ C MULTIPLE PARAMETERS C2700015^^ 7 NNP = NP-1 C2700016^^ 8 DO 200 I = 1, NNP C2700017^^ 9 IF (TRUTH(2,I) .EQ. OORR) GO TO 150 C2700018^^ C AND C2700019^^ 10 IBOOL = AND(IBOOL, TRUTH(1,I+1)) C2700020^^ 11 GO TO 200 C2700021^^ C OR C2700022^^ 12 150 IBOOL = OR(IBOOL,TRUTH(1,I+1)) C2700023^^ 13 200 CONTINUE C2700024^^ 14 RETURN C2700025^^ 15 END C2700026^t FTN 3.3B (OPT = LPC) TRHDT1 PAGE 2 DATE: 08/29/84 TIME: 2311 t  PROGRAM LENGTH $0048 ( 72)   EXTERNALS  Q8PKUP Q8PREP  t FTN 3.3B (OPT = LPC) TRHDT1 PAGE 3 DATE: 08/29/84 TIME: 2311 t, ***** L I S T O F S Y M B O L S *****,   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " AND INTR.FN. 7FFF 10 "( I INTEGER 0002 7,9,10,12(( IBOOL INTEGER 7FFF 1,5,10,12($ NNP INTEGER 0001 6,7,8$$ NP INTEGER 7FFF 1,6,7$$ OORR INTEGER 0000 1,3,9$" OR INTR.FN. 7FFF 12 ", TRUTH INTEGER 7FFF 1,4,5,9,10,12,   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  Q8PKUP INTEGER.FN. 003D Q8PREP INTEGER.FN. 003A    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 150 0028 9,12 $& 200 0032 7,11,13& TRHDT1 0037 1  t FTN 3.3B (OPT = LPC) TRNPLY PAGE 1 DATE: 08/29/84 TIME: 2311 t^ 1 PROGRAM TRNPLY C2800001^^ 1 1 /C28 F CCS CCS 3.0 .LA - LKL07 SL-149********^^ C C2800003^^ C CYBERCREDIT SYSTEM VERSION 3 C2800004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C2800005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C2800006^  ^ * TRANSACTION RE-PLAY PROGRAM C2800014^^ * C2800015^^ * FUNCTION: TO SIMULATE 'COLECT' BY PERFORMING AN UPDATE TO C2800016^^ * THE 'DELQMST' AND 'COSIGNER' FILES FOR A DAY, IN C2800017^^ * THE EVENT A SYSTEM CRASH OCCURRED. C2800018^   ^ * GENERAL DESCRIPTION: C2800020^^ * THE PROGRAM SEQUENTIALLY READS 'TRANFL' AND PERFORMS THE C2800021^^ * FOLLOWING BASED ON RECORD TYPE. C2800022^  ^ * 1-ACTIVITY RECORD (TKEY=01): C2800024^^ * -MAINTAINS A COUNT OF ACTIVITIES UPDATED. C2800025^^ * -BUILDS THE ACTIVITY STRING AND INSERTS IT IN THE C2800026^^ * 'DELQMST' VIA 'PUTACF'. C2800027^^ * -DETERMINES IF A LETTER WAS REQUESTED AND UPDATES THE C2800028^^ * LETTER AMOUNT AND DATE IN 'DELQMST'. C2800029^^ * -UPDATES NEXT CONTACT DATE WITH ACTIVITY DATE IN 'TRANFL' C2800030^^ * -DETERMINES IF RESULT CODE WAS PP AND INSERTS PP AMOUNT C2800031^^ * DATE AND FLAG IN 'DELQMST'. C2800032^^ * -UPDATES 'DELQMST' RECORD ON DISK. C2800033^  ^ * 2-CHANGE RECORD (TKEY=02): C2800035^^ * -MAINTAINS A COUNT OF CHANGES UPDATED. C2800036^^ * -DETERMINES TYPE CHANGE(BORROWER,COSIGNER,SUPERVISOR OR C2800037^^ * PERMANENT COMMENTS). C2800038^^ * -BORROWER CHANGE RECORD: C2800039^^ * -UPDATES APPROPRIATE FIELD IN 'DELQMST' FILE RECORD. C2800040^^ * -DETERMINES IF PREVIOUS VALUE OR DATE OF CHANGE FIELDS C2800041^^ * SHOULD BE UPDATED. C2800042^^ * -UPDATES DATE OF LAST CHANGE(POS 863) AND CHANGE FLAG C2800043^^ * (POS 295) IN 'DELQMST'. C2800044^^ * -DETERMINES IF NAME CHANGE AND WRITES A RECORD TO THE C2800045^^ * 'ADDACT' FILE. C2800046^^ * -UPDATES 'DELQMST' RECORD ON DISK. C2800047^^ * -COSIGNER CHANGE: C2800048^^ * -UPDATES APPROPRIATE FIELD IN 'COSIGNER' FILE RECORD. C2800049^^ * -UPDATES 'COSIGNER' RECORD ON DISK. C2800050^^ * -SUPERVISOR/PERMANENT COMMENT CHANGE: C2800051^^ * -UPDATES APPROPRIATE FIELD IN 'DELQMST' FILE RECORD. C2800052^^ * -DETERMINES IF PREVIOUS VALUE OR DATE OF CHANGE FIELDS C2800053^^ * SHOULD BE UPDATED. C2800054^^ * -UPDATES 'DELQMST' RECORD ON DISK. C2800055^t FTN 3.3B (OPT = LPC) TRNPLY PAGE 2 DATE: 08/29/84 TIME: 2311 t  ^ * 3-MISCELLANEOUS RECORD (TKEY=XX): C2800057^^ * -MAINTAINS A COUNT OF 'OTHER' RECORDS. C2800058^   ^ * TERMINATION OF THE PROGRAM CAN OCCUR NORMALLY UPON REACHING AN C2800060^^ * END-OF-FILE CONDITION FROM 'TRANFL'; IF THE NEEDED FILES CAN'T C2800061^^ * BE ACCESSED; OR IF MORE THAN THE 'LIMIT' VALUE OF FILE ERRORS C2800062^^ * HAVE OCCURRED('LIMIT' IS PRESENTLY SET TO TEN, BUT IT CAN BE C2800063^^ * MODIFIED). C2800064^^ * IF AN ERROR CONDITION IS ENCOUNTERED, THE ACCOUNT NUMBER AND C2800065^^ * UPDATE CODE ARE REPORTED ON THE PRINTER WITH A FILE ERROR C2800066^^ * INDICATION AT THE CONSOLE. C2800067^^ * UPON TERMINATION, THE FOLLOWING IS PRINTED AT THE CONSOLE: C2800068^^ * TOTAL ACTIVITIES UPDATED XXXX C2800069^^ * TOTAL CHANGES UPDATED XXXX C2800070^^ * TOTAL OTHER RECORDS XXXX C2800071^^ * TOTAL NOT UPDATED XXXX C2800072^   ^ * EXTERNALS: C2800074^^ * -SYSTEM DATE C2800075^^ * -SUBROUTINE PUTACF-ADDS AN ACTIVITY STRING TO THE ACTIVITY C2800076^^ * BLOCK IN THE 'DELQMST'. C2800077^^ * -SUBROUTINE CCSMVA-MOVES A BYTE STRING. C2800078^^ * -SUBROUTINE FILERR-REPORTS A FILE MANAGER ERROR ON THE C2800079^^ * MASTER CONSOLE. C2800080^^ * -SUBROUTINE GETCHF-EXTRACTS THE CHANGE FIELD INFORMATION C2800081^^ * GIVEN THE SCREEN RECORD FROM 'SCRNFIL'. C2800082^^ * -FUNCTION ICCSAD-CONVERTS A ONE WORD ASCII NUMBER TO ITS C2800083^^ * EQUIVALENT ONE WORD INTEGER VALUE. C2800084^^ C***************************************************************138*A002C2800085^^ * -SUBROUTINE CCSCST-COMPARE STRING REQUEST FOR LESS THAN, C2800086^^ * EQUALITY, AND GREATER THAN. C2800087^^ C***************************************************************138*A002C2800088^ ^ ***** FOR FURTHER DOCUMENTATION OF THE ABOVE ROUTINES, REFER TO THE C2800090^^ * APPROPRIATE PROGRAM DOCUMENTS. C2800091^   ^ 2 INTEGER DEQREQ(24),DDATA(15),COSREQ(24),CDATA(15), C2800093^^ 2 1 TRNREQ(24),TDATA(15),SCNREQ(24),SDATA(15), C2800094^^ C***************************************************************138*A002C2800095^^ 2 1 ADDREQ(24),ADATA(15),DPOS,BLANKS(3),COMPIN, C2800096^^ C***************************************************************138*A002C2800097^^ 2 1 CUSCHG(91),COSCHG(91),SUPCHG(61),SDEF(1000),WRONKY C2800098^ ^ 3 INTEGER KEY,TRNBUF(70),STRING(36),COID(2),ACCT(8),RESULT, C2800100^^ 3 1 ACTLEN(2),Y,DATE(3),OSW,UPDCOD,KEYSAV(8), C2800101^^ 3 1 AS1,AS30,AS60,AS90,AS91,AS93,COUNTB,COUNTO,COUNT1, C2800102^t FTN 3.3B (OPT = LPC) TRNPLY PAGE 3 DATE: 08/29/84 TIME: 2311 t^ 3 1 PCOM(3),TKEY,PP,OPOS,RKEY,COUNT2,ONE,AFLAG C2800103^^ C***************************************************************???*0022********^^ C ********^^ C SET UP UTILITY FILE DATA TO BE USED FOR RETRIEVING COLLECTORS ********^^ C LAST NAME AND PUTTING IT IN ACTIVITY STRING INSTEAD OF COLLECTOR ********^^ C LOG ON ID ********^ ^ 4 INTEGER UDATA(15),UTIREQ(24),UTIREC(40),HST(2),ID(4) ********^^ 5 DATA UDATA/'LAUTIFIL',8*$2020,1,1,0/ ********^^ 6 DATA UTIREQ/24*0/, HST/'HOST'/,IFG/0/ ********^^ C***************************************************************???*0022********^^ * C2800104^^ 7 DATA DEQREQ,COSREQ,TRNREQ,SCNREQ,ADDREQ/120*0/ C2800105^^ 8 EXTERNAL AMONTO,ADAYTO,AYERTO C2800106^^ 9 INTEGER DDAT(4),CDAT(4),SDAT(4),IN1(4) ********^^ 10 DATA DDAT/'DELQMST '/,CDAT/'COSIGNER'/,SDAT/'SCRNFILE'/ ********^^ 11 DATA DDATA/'LADLQMST',8*$2020,1,1,1/ ********^^ 12 DATA CDATA/'LACOSIGN',8*$2020,1,1,1/ ********^^ 13 DATA TDATA/'LATRANFL',8*$2020,0,1,0/ ********^^ 14 DATA CUSCHG/-30,90*0/ C2800110^^ 15 DATA COSCHG/-30,90*0/ C2800111^^ 16 DATA SUPCHG/-20,60*0/ C2800112^^ 17 DATA SDATA/'LASCNFIL',8*$2020,1,1,0/ ********^^ 18 DATA ADATA/'LAADDACT',8*$2020,0,1,0/ ********^^ 19 DATA WRONKY/$200/,TKEY/0/,ACTLEN/'0360'/,NAMPOS/18/ C2800115^^ 20 DATA Y/'Y '/,OSW/1/,PP/'PP'/,AS1/'01'/,AS30/'30'/ C2800116^^ 21 DATA AS60/'60'/,AS90/'90'/,AS91/'91'/,AS93/'93'/ C2800117^^ 22 DATA PCOM/667,697,727/,LU/0/,LIMIT/10/,ONE/'1 '/,AFLAG/'N '/ C2800118^^ 23 DATA COUNT1,COUNT2,COUNTB,COUNTO/4*0/ C2800119^^ C***************************************************************138*A002C2800120^^ 24 DATA NPOS/33/,OPOS/63/,BLANKS/3*$2020/ C2800121^^ C***************************************************************138*A002C2800122^^ ************************************************************************C2800123^^ * EACH ITEM ON THE BORROWER'S CHANGE SCREEN AND SUPERVISOR'S SCREEC2800124^^ * CAN HAVE A PREVIOUS VALUE FIELD AND/OR DATE OF LAST CHANGE FIELDC2800125^^ * ASSOCIATED WITH IT. THE ARRAY 'PRFLD' CONTAINS THE NECESSARY INC2800126^^ * TO PERFORM THESE UPDATE TASKS. THE INFORMATION IN 'PRFLD' C2800127^^ * IS BY GROUPS OF THREE WORDS FOR EACH ITEM WITH THE FOLLOWING C2800128^^ * DEFINITION: C2800129^^ * WORD MEANING C2800130^^ * I STARTING POSITION IN FILE FOR THE ITEM ON THE CHANGE C2800131^^ * SCREEN. C2800132^^ * I+1 STARTING POSITION IN FILE OF THE PREVIOUS VALUE FIELD C2800133^^ * FOR THIS ITEM. A VALUE OF ZERO INDICATES NO C2800134^^ * PREVIOUS VALUE FIELD EXISTS FOR THIS ITEM. C2800135^^ * I+2 STARTING POSITION IN FILE OF DATE OF LAST CHANGE FIELD C2800136^^ * TO BE UPDATED WHEN THIS ITEM IS CHANGED. DO NOT CONFUSEC2800137^^ * THIS DATE WITH POSITION 863 IN THE MASTER FILE. THE DATEC2800138^^ * THE ACCOUNT LAST CHANGED VIA CHANGE SCREEN, OR POSITION C2800139^^ * 300 IN THE MASTER FILE, DATE QUEUE CHANGED. THESE C2800140^^ * FIELDS ARE AUTOMATICALLY UPDATED WHEN A CHANGE OCCURS C2800141^^ * A VALUE OF ZERO INDICATES NO DATE OF LAST CHANGE FIELD IC2800142^^ * ASSOCIATED WITH THIS ITEM. C2800143^^ * C2800144^t FTN 3.3B (OPT = LPC) TRNPLY PAGE 4 DATE: 08/29/84 TIME: 2311 t^ * 'NITEM' IS THE NUMBER OF ITEMS HAVING THESE PREVIOUS VALUE C2800145^^ * OR DATE OF LAST UPDATE FIELDS. C2800146^^ * ITEMS WITH PREVIOUS VALUE OR DATE OF LAST CHANGE FIELDS IN C2800147^^ * THIS VERSION ARE: (IN THE ORDER THEY APPEAR IN 'PRFLD') C2800148^^ * 1. BORROWER'S ADDRESS LINE 1 C2800149^^ * 2. BORROWER'S ADDRESS LINE 2 C2800150^^ * 3. BORROWER'S CITY/STATE C2800151^^ * 4. BORROWER'S ZIP C2800152^^ * 5. QUEUE ACCOUNT ASSIGNED C2800153^^ * C2800154^^ 25 INTEGER PRFLD(15),NITEM C2800155^^ 26 DATA PRFLD/48,757,0,78,787,0,108,817,0,128,837,0,271,296,0/ C2800156^^ 27 DATA NITEM/5/ C2800157^^ ************************************************************************C2800158^   ^ 28 EQUIVALENCE (TRNBUF(15),KEY),(TRNBUF(21),LTRCOD), C2800160^^ 28 1 (TRNBUF(20),RESULT), ********^^ 28 1 (TRNBUF(16),UPDCOD) C2800162^^ * C2800163^t FTN 3.3B (OPT = LPC) TRNPLY PAGE 5 DATE: 08/29/84 TIME: 2311 t ^ 29 CALL PGMIN(ID,ISTAT,ISTAT,ISTAT) ********^^ 30 CALL CCSCST(UDATA,1,2,ID,1,8,ISTAT) ********^^ 31 IF(ISTAT.EQ.0) GO TO 5 ********^^ 32 CALL CCSMVA(UDATA,3,6,UDATA,1,8) ********^^ 33 CALL CCSMVA(TDATA,3,6,TDATA,1,8) ********^^ 34 CALL CCSMVA(ADATA,3,6,ADATA,1,8) ********^^ 35 CALL CCSMVA(DDAT ,1,8,DDATA,1,8) ********^^ 36 CALL CCSMVA(CDAT ,1,8,CDATA,1,8) ********^^ 37 CALL CCSMVA(SDAT ,1,8,SDATA,1,8) ********^^ 38 5 CONTINUE ********^^ 39 WRITE(5,6)ID ********^^ 40 6 FORMAT(/,'USERID =',4A2,' TYPE OK TO CONTINUE, OR EX TO EXIT',/)********^^ 41 CALL WTREAD(5,-1,0,0,-1,IN1,6,ITC) ********^^ 42 IF(ITC.NE.2) GO TO 5 ********^^ 43 IF(IN1.EQ.2HEX) GO TO 991 ********^^ 44 IF(IN1.NE.2HOK) GO TO 5 ********^^ * OPEN FILES C2800165^^ 45 CALL OPENFL(DEQREQ,DDATA,ISTAT) C2800166^^ 46 IF(ISTAT.GE.0)GOTO 10 C2800167^^ 47 CALL FILERR(DDATA,3,ISTAT,LU) C2800168^^ 48 GOTO 991 C2800169^^ * C2800170^^ 49 10 CALL OPENFL(COSREQ,CDATA,ISTAT) C2800171^^ 50 IF(ISTAT.GE.0)GO TO 20 C2800172^^ 51 CALL FILERR(CDATA,3,ISTAT,LU) C2800173^^ 52 GOTO 991 C2800174^^ * C2800175^^ 53 20 CALL OPENFL(TRNREQ,TDATA,ISTAT) C2800176^^ 54 IF(ISTAT.GE.0)GO TO 30 C2800177^^ 55 CALL FILERR(TDATA,3,ISTAT,LU) C2800178^^ 56 GOTO 991 C2800179^^ * C2800180^^ 57 30 CALL OPENFL(SCNREQ,SDATA,ISTAT) C2800181^^ 58 IF(ISTAT.GE.0)GOTO 40 C2800182^^ 59 CALL FILERR(SDATA,3,ISTAT,LU) C2800183^^ 60 GOTO 991 C2800184^^ * C2800185^^ 61 40 CALL OPENFL(ADDREQ,ADATA,ISTAT) C2800186^^ C***************************************************************???*0022********^^ 62 IF(ISTAT.GE.0) GO TO 45 ********^^ C***************************************************************???*0022********^^ 63 CALL FILERR(ADATA,3,ISTAT,LU) C2800188^^ 64 GOTO 991 C2800189^^ C***************************************************************???*0022********^ ^ 65 45 CALL OPENFL(UTIREQ,UDATA,ISTAT) ********^^ 66 IF(ISTAT.GE.0) GO TO 50 ********^^ 67 CALL FILERR(UDATA,3,ISTAT,LU) ********^^ 68 GO TO 991 ********^^ C***************************************************************???*0022********^t FTN 3.3B (OPT = LPC) TRNPLY PAGE 6 DATE: 08/29/84 TIME: 2311 t^ * RETRIEVE CUSTOMER CHANGE SCREEN FROM FILE C2800191^^ * C2800192^^ 69 50 CALL READR(SCNREQ,SDEF,33,ISTAT) C2800193^^ * CHECK FOR SCREEN NOT PRESENT OR ERROR CONDITION C2800194^^ 70 IF(ISTAT.LT.0.OR.AND(ISTAT,WRONKY).EQ.WRONKY)GOTO 999 C2800195^^ * RETRIEVE CHANGE FIELD ITEM INFORMATION C2800196^^ 71 CALL GETCHF(SDEF,CUSCHG) C2800197^^ * C2800198^^ * RETRIEVE COSIGNOR CHANGE SCREEN C2800199^^ 72 CALL READR(SCNREQ,SDEF,94,ISTAT) C2800200^^ * CHECK FOR SCREEN NOT PRESENT OR ERROR CONDITION C2800201^^ 73 IF(ISTAT.LT.0.OR.AND(ISTAT,WRONKY).EQ.WRONKY) GO TO 999 C2800202^^ * RETRIEVE CHANGE SCREEN ITEM INFORMATION C2800203^^ 74 CALL GETCHF(SDEF,COSCHG) C2800204^^ * C2800205^^ * RETRIEVE SUPERVISOR CHANGE SCREEN FROM FILE C2800206^^ 75 CALL READR(SCNREQ,SDEF,35,ISTAT) C2800207^^ * CHECK FOR SCREEN NOT PRESENT OR ERROR CONDITION C2800208^^ 76 IF(ISTAT.LT.0.OR.AND(ISTAT,WRONKY).EQ.WRONKY) GO TO 999 C2800209^^ * RETRIEVE CHANGE SCREEN FIELD ITEM INFORMATION C2800210^^ 77 CALL GETCHF(SDEF,SUPCHG) C2800211^^ 78 CALL CLOSFL(SCNREQ,ISTAT) C2800212^   ^ * ACCESS SYSTEM DATE FOR DATE ACCOUNT LAST UPDATED C2800214^^ * VIA CHANGE SCREEN C2800215^^ * C2800216^^ 79 DATE(1)=AND($FFFF,AMONTO) C2800217^^ 80 DATE(2)=AND($FFFF,ADAYTO) C2800218^^ 81 DATE(3)=AND($FFFF,AYERTO) C2800219^^ * C2800220^^ * RETRIEVE RECORDS SEQUENTIALLY FROM START OF TRANFL C2800221^^ 82 100 CALL GETS(TRNREQ,TRNBUF,TKEY,ISTAT) C2800222^^ * EOF C2800223^^ 83 IF(AND(ISTAT,$100).EQ.$100) GO TO 99 ********^^ * ERROR CONDITION C2800225^^ 84 IF(ISTAT.LT.0) GOTO 103 C2800226^^ 85 CALL CCSMVA(TRNBUF,1,16,ACCT,1,16) ********^^ * CHECK IF VALID KEY C2800227^^ 86 IF(KEY.EQ.$3031) GOTO 105 C2800228^^ 87 IF(KEY.EQ.$3032) GOTO 205 C2800229^^ * OTHER KEY C2800230^^ 88 COUNTO=COUNTO+1 C2800231^^ 89 GOTO 100 C2800232^^ 90 103 CALL FILERR(TDATA,14,ISTAT,LU) C2800233^^ 91 COUNTB=COUNTB+1 C2800234^^ 92 GOTO 991 C2800236^t FTN 3.3B (OPT = LPC) TRNPLY PAGE 7 DATE: 08/29/84 TIME: 2311 t^ * ACTIVITY RECORD C2800238^^ * RETRIEVE ACCOUNT RECORD FROM DELQMST C2800239^^ C ****************************************************** ???*A020********^^ 93 105 COUNT1 = COUNT1 + 1 ********^^ 94 CALL READR (DEQREQ, SDEF, ACCT, ISTAT) ********^^ 95 IF(AND(ISTAT,$100).EQ.$100.OR.AND(ISTAT,WRONKY).EQ.WRONKY)GOTO 996********^^ 96 IF(ISTAT.LT.0) GOTO 990 ********^^ C INCREMENT COUNT OF ACTIVITIES PROCESSED ********^^ C ****************************************************** ???*A020********^^ * SET UP STRING BUFFER FOR PUTACF C2800243^^ * MOVE ACTIVITY DATE,ACTION CODE,RESULT CODE,LETTER CODE C2800244^^ 97 CALL CCSMVA(TRNBUF,31,12,STRING,1,12) C2800245^^ * MOVE COLLECTER ID C2800246^^ C***************************************************************???*0022********^^ C READ UTIFIL AND MOVE IN FIRST 4 CHARACTERS OF LAST NAME ********^^ C INSTEAD OF COLLECTOR ID ********^ ^ 98 CALL CCSMVA(TRNBUF,17,4,UTIREC,1,4) ********^^ 99 CALL READR(UTIREQ,UTIREC,UTIREC,ISTAT) ********^^ 100 IF(ISTAT.LT.0.OR.AND(ISTAT,WRONKY).EQ.WRONKY) GO TO 993 ********^^ C RECORD RETRIEVED-MOVE IN THE NAME ********^^ 101 107 CALL CCSMVA(UTIREC,5,4,STRING,13,4) ********^^ C***************************************************************???*0022********^^ * MOVE COMMENT C2800248^^ 102 CALL CCSMVA(TRNBUF,43,56,STRING,17,56) C2800249^^ C***************************************************************138*A002C2800250^^ C RESET OSW TO FORCE ACTIVITY INTO BLOCK. C2800251^^ 103 OSW = $3031 C2800252^^ C***************************************************************138*A002C2800253^^ 104 CALL PUTACF(STRING,SDEF(154),ACTLEN,OSW) C2800254^^ * CHECK IF LETTER REQUESTED C2800255^^ 105 IF(LTRCOD.EQ.$2020)GOTO 110 C2800256^^ * MOVE LETTER REQUEST AMOUNT, DATE, AND NEXT CONTACT DATE C2800257^^ 106 CALL CCSMVA(TRNBUF,106,6,SDEF,842,6) C2800258^^ 107 CALL CCSMVA(TRNBUF,112,9,SDEF,848,9) C2800259^^ 108 110 CALL CCSMVA(TRNBUF,99,6,SDEF,275,6) C2800260^^ * CHECK IF RESULT = PP FOR SPECIAL PROCESSING C2800261^^ 109 IF(RESULT.NE.PP)GOTO 500 C2800262^^ * MOVE PP AMOUNT, DATE AND FLAG C2800263^^ 110 CALL CCSMVA(TRNBUF,121,6,SDEF,1016,6) C2800264^^ 111 CALL CCSMVA(TRNBUF,127,9,SDEF,1022,9) C2800265^^ 112 CALL CCSMVA(Y,1,1,SDEF,285,1) C2800266^^ * SAVE THE COMMITMENT DATE C2800267^^ 113 CALL CCSMVA ( TRNBUF, 31, 6, SDEF, 1041, 6 ) C2800268^^ 114 GOTO 500 C2800269^t FTN 3.3B (OPT = LPC) TRNPLY PAGE 8 DATE: 08/29/84 TIME: 2311 t^ * CHANGE RECORD C2800271^^ * DETERMINE SCREEN TYPE CHANGE C2800272^^ * UPDATE CODES ARE CUSTOMER 01-30 C2800273^^ * COSIGNER 31-60 C2800274^^ * SUPERVISOR 61-90 C2800275^^ * PERM CMTS 91,92,93 C2800276^   ^ 115 205 CONTINUE ********^^ 116 IF(UPDCOD.LT.AS1)GOTO 210 C2800279^^ 117 IF(UPDCOD.LE.AS30)GOTO 250 C2800280^^ 118 IF(UPDCOD.LE.AS60)GOTO 300 C2800281^^ 119 IF(UPDCOD.LE.AS90)GOTO 350 C2800282^^ 120 IF(UPDCOD.LE.AS93)GOTO 400 C2800283^^ 121 210 COUNTO=COUNTO+1 C2800284^^ 122 GOTO 100 C2800285^t FTN 3.3B (OPT = LPC) TRNPLY PAGE 9 DATE: 08/29/84 TIME: 2311 t^ * CUSTOMER CHANGE SCREEN C2800287^^ 123 250 J=ICCSAD(UPDCOD) C2800288^^ 124 LENGTH=CUSCHG(3*J)/$10 C2800289^^ 125 DPOS=CUSCHG(3*J+1) C2800290^^ 126 K=1 C2800291^^ 127 GOTO 450 C2800292^   ^ * COSIGNOR CHANGE SCREEN C2800294^^ 128 300 J=ICCSAD(UPDCOD)-30 C2800295^^ 129 LENGTH=COSCHG(3*J)/$10 C2800296^^ 130 DPOS=COSCHG(3*J+1) C2800297^^ * SAVE ACCOUNT NUMBER AND READ COSIGNER FILE FOR ACCOUNT RECORD C2800298^^ 131 CALL CCSMVA(ACCT,1,16,KEYSAV,1,16) C2800299^^ 132 CALL READR(COSREQ,SDEF,ACCT,ISTAT) C2800300^^ * ZERO ISTAT MEANS COSIGNER RECORD EXISTS; UPDATE IT! C2800301^^ 133 IF(ISTAT.GE.0.AND.AND(ISTAT,$200).EQ.0) GO TO 315 C2800302^^ * IF COSIGNER RECORD DOESN'T EXIST OR WE REACHED EOF, CREATE ONE. C2800303^^ 134 IF(AND(ISTAT,$200).NE.0.OR.AND(ISTAT,$100).NE.0) GO TO 305 C2800304^^ * OTHERWISE IT MUST BE A FATAL ERROR, SO REPORT IT. C2800305^^ 135 GOTO 995 C2800306^^ * GUESS IT DOESN'T EXIST. CLEAR OUT BUFFER BEFORE BUILDING RECORD C2800307^^ 136 305 CALL CCSBLK(SDEF,362) C2800308^^ * PLUG IN ACCOUNT NUMBER FROM KEYSAV C2800309^^ 137 CALL CCSMVA (KEYSAV,1,16,SDEF,1,16) C2800310^^ * PERFORM COSIGNER RECORD CHANGES C2800311^^ 138 CALL CCSMVA (TRNBUF,NPOS,30,SDEF,DPOS,LENGTH) C2800312^^ * WRITE OUT NEW COSIGNER RECORD C2800313^^ 139 CALL WRITER (COSREQ,SDEF,KEYSAV,ISTAT) C2800314^^ * REPORT FATAL ERRORS C2800315^^ 140 IF (ISTAT .LT. 0) GOTO 995 C2800316^^ 141 COUNT2 = COUNT2 + 1 ********^^ 142 GOTO 100 C2800317^^ * UPDATE RECORD IF IT ALREADY EXISTS C2800318^^ 143 315 CALL CCSMVA (TRNBUF,NPOS,30,SDEF,DPOS,LENGTH) C2800319^^ * RE-WRITE UPDATED RECORD C2800320^^ 144 CALL UPDREC(COSREQ,SDEF,ISTAT) C2800321^^ 145 IF(ISTAT.LT.0) GOTO 995 C2800322^^ 146 COUNT2 = COUNT2 + 1 ********^^ 147 GOTO 100 C2800323^^ * C2800324^^ * SUPERVISOR CHANGE SCREEN C2800325^^ 148 350 J=ICCSAD(UPDCOD)-60 C2800326^^ 149 LENGTH=SUPCHG(3*J)/$10 C2800327^^ 150 DPOS=SUPCHG(3*J+1) C2800328^^ 151 K=2 C2800329^^ 152 GOTO 450 C2800330^^ * C2800331^^ * PERMANENT COMMENTS UPDATE C2800332^^ 153 400 J=ICCSAD(UPDCOD)-90 C2800333^^ 154 LENGTH= 30 C2800334^^ 155 DPOS=PCOM(J) C2800335^^ 156 K=0 C2800336^t FTN 3.3B (OPT = LPC) TRNPLY PAGE 10 DATE: 08/29/84 TIME: 2311 t^ * RETRIEVE ACCOUNT RECORD FROM DELQMST C2800338^^ 157 450 COUNT2 = COUNT2 + 1 ********^^ 158 CALL READR(DEQREQ,SDEF,ACCT,ISTAT) ********^^ 159 IF(AND(ISTAT,WRONKY).EQ.WRONKY.OR.AND(ISTAT,$100).EQ.$100)GOTO 996********^^ 160 IF(ISTAT.LT.0) GO TO 990 ********^^ * BYPASS THIS NEXT SECTION IF THIS A PERM COMMENT UPDATE C2800341^^ 161 IF(K.EQ.0)GOTO 455 C2800342^^ * IF THIS IS A NAME CHANGE FROM A BORROWER OR SUPERVISOR CHANGE C2800343^^ * SCREEN MUST SAVE FIRST 6 CHAR OF OLD NAME IN POSITION 1047 OF MAC2800344^^ * RECORD. C2800345^^ C***************************************************************138*A002C2800346^^ 162 IF(DPOS.NE.NAMPOS) GO TO 455 C2800347^^ 163 CALL CCSCST(SDEF,1047,6,BLANKS,1,6,COMPIN) C2800348^^ 164 IF(COMPIN.NE.0) GO TO 455 C2800349^^ 165 CALL CCSMVA(SDEF,18,6,SDEF,1047,6) C2800350^^ C***************************************************************138*A002C2800351^^ * MOVE CHANGED FIELD IN C2800352^^ 166 455 CALL CCSMVA(TRNBUF,NPOS,30,SDEF,DPOS,LENGTH) C2800353^^ * CHECK IF THERE IS PREVIOUS VALUE OR DATE OF LAST C2800354^^ * CHANGE FIELDS TO BE UPDATED C2800355^^ 167 J=3*NITEM-2 C2800356^^ 168 DO 460 I=1,J,3 C2800357^^ 169 IF(DPOS.NE.PRFLD(I))GOTO460 C2800358^^ * FOUND ITEM CHANGED IN 'PRFLD'. UPDATE PREVIOUS VALUE C2800359^^ * AND DATE OF LAST CHANGE IF REQUIRED C2800360^^ 170 IF(PRFLD(I+1).GT.0) C2800361^^ 170 1 CALL CCSMVA(TRNBUF,OPOS,30,SDEF,PRFLD(I+1),LENGTH) C2800362^^ 171 IF(PRFLD(I+2).GT.0) C2800363^^ 171 1 CALL CCSMVA(DATE,1,6,SDEF,PRFLD(I+2),6) C2800364^^ 172 GOTO 470 C2800365^^ 173 460 CONTINUE C2800366^^ 174 470 IF(K.EQ.0)GOTO 500 C2800367^^ * UPDATE DATE OF LAST CHANGE AND FLAG FOR BORROWER CHANGE C2800368^^ * SCREEN ONLY. C2800369^^ 175 IF(K.EQ.2)GOTO 480 C2800370^^ 176 CALL CCSMVA(DATE,1,6,SDEF,863,6) C2800371^^ 177 CALL CCSMVA(ONE,1,1,SDEF,295,1) C2800372^^ * C2800373^^ * IF NAME CHANGE, ADD ENTRY IN ADDACT FILE C2800374^^ * C2800375^^ C***************************************************************138*A002C2800376^^ 178 480 IF(DPOS.NE.NAMPOS.OR.COMPIN.NE.0)GOTO 500 C2800377^^ C***************************************************************138*A002C2800378^^ 179 CALL CCSMVA(ACCT,1,16,STRING,1,16) C2800379^^ 180 CALL CCSMVA(AFLAG,1,2,STRING,17,2) C2800380^^ 181 CALL PUTS(ADDREQ,STRING,1,ISTAT) C2800381^^ 182 IF(ISTAT.LT.0) GOTO 992 C2800382^^ * UPDATE RECORD IN DELQMST C2800383^^ 183 500 CALL UPDREC(DEQREQ,SDEF,ISTAT) C2800384^^ 184 IF(ISTAT.LT.0)GOTO 990 C2800385^^ 185 GOTO 100 C2800386^t FTN 3.3B (OPT = LPC) TRNPLY PAGE 11 DATE: 08/29/84 TIME: 2311 t^ * ERROR PROCESSING C2800388^^ 186 990 CALL FILERR(DDATA,13,ISTAT,LU) C2800389^^ 187 GO TO 991 ********^^ C ****************************************************** ???*0022********^^ 188 996 COUNTB = COUNTB+1 ********^^ 189 IF(IFG.EQ.0)WRITE(12,551) ********^^ 190 551 FORMAT( 1H1,/,20X,'TRANSACTION REPLAY -- REPORT',/, ********^^ 190 + 39X,'NEW DATA OR',/,5X,'ACCOUNT #',7X, ********^^ 190 + 'TYPE UPCD AC RC LT COMMENT') ********^^ 191 IFG = 1 ********^^ 192 IF(KEY.EQ.2H01) GO TO 997 ********^^ 193 WRITE(12,555)(TRNBUF(L),L=1,8),KEY,UPDCOD,(TRNBUF(M),M=17,31) ********^^ 194 555 FORMAT(2X,8A2,4X,A2,6X,A2,5X,15A2,4X,' NOT UPDATED***') ********^^ 195 COUNT2 = COUNT2 - 1 ********^^ 196 GO TO 100 ********^^ 197 997 WRITE(12,552)(TRNBUF(L),L=1,8),KEY,(TRNBUF(M),M=19,21), ********^^ 197 + (TRNBUF(N),N=22,50) ********^^ 198 552 FORMAT(2X,8A2,4X,A2,11X,3(2X,A2),3X,28A2,4X,' NOT UPDATED***') ********^^ 199 COUNT1 = COUNT1 - 1 ********^^ 200 GO TO 100 ********^^ C ****************************************************** ???*0022********^^ * C2800395^^ 201 999 CALL FILERR(SDATA,13,ISTAT,LU) C2800396^^ 202 WRITE(04,556) C2800397^^ 203 556 FORMAT('REPLACE SCREEN FILE AND RESTART PROGRAM') C2800398^^ 204 CALL PGMOUT C2800399^^ * C2800400^^ 205 991 WRITE(04,557) C2800401^^ 206 557 FORMAT(' ...PROGRAM ABORTED. - RUN NOT COMPLETE') ********^^ 207 GOTO 99 C2800403^^ * C2800404^^ 208 995 CALL FILERR(CDATA,13,ISTAT,LU) C2800405^^ 209 GOTO 991 ********^^ * C2800407^^ 210 992 CALL FILERR(ADATA,11,ISTAT,LU) C2800408^^ 211 GOTO 991 ********^^ C***************************************************************???*0022********^^ C FILE ERROR ON READ OF UTIFIL ********^^ 212 993 WRITE(5,559) TRNBUF(9),TRNBUF(10) ********^^ 213 559 FORMAT(' COID : ',2A2,' NOT IN UTIFIL - USING HOST ID ') ********^^ 214 CALL CCSMVA(HST,1,4,UTIREC,5,4) ********^^ 215 GO TO 107 ********^^ C***************************************************************???*0022********^^ * C2800410^^ 216 99 CALL CLOSFL(TRNREQ,ISTAT) C2800411^^ 217 CALL CLOSFL(DEQREQ,ISTAT) C2800412^^ 218 CALL CLOSFL(COSREQ,ISTAT) C2800413^^ 219 CALL CLOSFL(ADDREQ,ISTAT) C2800414^^ C***************************************************************???*0022********^^ 220 CALL CLOSFL(UTIREQ,ISTAT) ********^^ C***************************************************************???*0022********^^ 221 WRITE(04,558)COUNT1,COUNT2,COUNTO,COUNTB C2800415^^ 222 558 FORMAT('TOTAL ACTIVITIES UPDATED ',I4,/,'TOTAL CHANGES UPDATED C2800416^^ 222 1 ',I4,/,'TOTAL OTHER RECORDS ',I4,/, ********^t FTN 3.3B (OPT = LPC) TRNPLY PAGE 12 DATE: 08/29/84 TIME: 2311 t^ 222 1'TOTAL NOT UPDATED ',I4) C2800418^^ 223 CALL PGMOUT C2800419^^ 224 END C2800420^t FTN 3.3B (OPT = LPC) TRNPLY PAGE 13 DATE: 08/29/84 TIME: 2311 t  PROGRAM LENGTH $0C64 ( 3172)   EXTERNALS 2 Q8STP Q8QINI Q8QX Q8QEND AMONTO ADAYTO AYERTO 22 PGMIN CCSCST CCSMVA WTREAD OPENFL FILERR READR 22 GETCHF CLOSFL GETS PUTACF ICCSAD CCSBLK WRITER 2 UPDREC PUTS PGMOUT  t FTN 3.3B (OPT = LPC) TRNPLY PAGE 14 DATE: 08/29/84 TIME: 2311 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < $ FFFE (-1) 06BF 41,41$( FFFF (65535) 06C6 79,80,81 (‚ 0000 (0) 0003 5,6,7,13,14,15,16,17,18,19,22,23,26,31,41,46,50,54,58,62,66,70,73,76,84,96,100,133,134,140,145,156 ‚H ,160,161,164,170,171,174,178,182,184,189 H€ 0001 (1) 0002 5,11,12,13,17,18,20,30,32,33,34,35,36,37,41,79,85,88,91,93,97,98,112,121,125,126,130,131,137,141,€j 146,150,157,163,168,170,171,176,177,179,180,181,188,191,193,195,197,199,214j< 0002 (2) 06B9 30,42,80,151,167,171,175,180 <\ 0003 (3) 06BB 32,33,34,47,51,55,59,63,67,81,124,125,129,130,149,150,167,168\8 0004 (4) 06BE 39,98,101,202,205,214,22186 0005 (5) 06BD 38,41,42,44,101,212,2146J 0006 (6) 06BC 32,33,34,41,106,108,110,113,163,165,171,176J< 0008 (8) 06BA 30,32,33,34,35,36,37,193,197 <. 0009 (9) 06D6 107,107,111,212." 000B (11) 06EE 210"0 000C (12) 06CD 97,97,189,193,1970. 000D (13) 06CF 101,186,201,208." 000E (14) 06CB 90 "< 0010 (16) 06C8 85,85,124,129,131,137,149,179<. 0011 (17) 06CE 98,102,180,193 ." 0012 (18) 06E7 165"2 001E (30) 06E5 138,143,154,166,1702* 001F (31) 06CC 97,113,193 *" 0021 (33) 06C3 69 "" 0023 (35) 06C5 75 "" 002B (43) 06D0 102"& 0038 (56) 06D1 102,102&" 005E (94) 06C4 72 "& 0063 (99) 06D8 108,207&" 006A (106) 06D3 106"" 0070 (112) 06D5 107"" 0079 (121) 06DA 110"" 007F (127) 06DC 111"0 0100 (256) 06C7 83,83,95,134,159 0" 0113 (275) 06D9 108"" 011D (285) 06DE 112"" 0127 (295) 06EA 177"" 016A (362) 06E4 136"& 0200 (512) 06E3 133,134&" 034A (842) 06D4 106"" 0350 (848) 06D7 107"" 035F (863) 06E9 176"" 03F8 (1016) 06DB 110"" 03FE (1022) 06DD 111"" 0411 (1041) 06DF 113"& 0417 (1047) 06E6 163,165&" 2020 (8224) 06D2 105"t FTN 3.3B (OPT = LPC) TRNPLY PAGE 15 DATE: 08/29/84 TIME: 2311 t* 3031 (12337) 06C9 86,103,192 *" 3032 (12338) 06CA 87 "" 4558 (17752) 06C1 43 "" 4F4B (20299) 06C2 44 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < 6 ACCT INTEGER 0615 1,85,94,131,132,158,1796( ACTLEN INTEGER 061D 1,19,104 (0 ADATA INTEGER 00B9 1,18,34,61,63,2100. ADDREQ INTEGER 00A1 1,7,61,181,219 .( AFLAG INTEGER 063D 1,22,180 (F AND INTR.FN. 7FFF 70,73,76,79,80,81,83,95,100,133,134,159F( AS1 INTEGER 062C 1,20,116 (( AS30 INTEGER 062D 1,20,117 (( AS60 INTEGER 062E 1,21,118 (( AS90 INTEGER 062F 1,21,119 ($ AS91 INTEGER 0630 1,21 $( AS93 INTEGER 0631 1,21,120 (( BLANKS INTEGER 00C9 1,24,163 (& CDAT INTEGER 0698 7,10,36&0 CDATA INTEGER 0044 1,12,36,49,51,2080 COID INTEGER 0613 1 , COMPIN INTEGER 00CC 1,163,164,178,. COSCHG INTEGER 0128 1,15,74,129,130.6 COSREQ INTEGER 002C 1,7,49,132,139,144,218 6. COUNT1 INTEGER 0634 1,23,93,199,221.8 COUNT2 INTEGER 063B 1,23,141,146,157,195,221 8. COUNTB INTEGER 0632 1,23,91,188,221.. COUNTO INTEGER 0633 1,23,88,121,221.. CUSCHG INTEGER 00CD 1,14,71,124,125.2 DATE INTEGER 0620 1,79,80,81,171,176 2& DDAT INTEGER 0694 7,10,35&0 DDATA INTEGER 001D 1,11,35,45,47,18604 DEQREQ INTEGER 0005 1,7,45,94,158,183,2174H DPOS INTEGER 00C8 1,125,130,138,143,150,155,162,166,169,178H& HST INTEGER 068D 1,6,214&. I INTEGER 06E8 167,169,170,171.* ID INTEGER 068F 1,29,30,39 *( IFG INTEGER 0693 6,189,191(* IN1 INTEGER 06A0 7,41,43,44 *‚ ISTAT INTEGER 06B8 29,29,30,31,45,46,47,49,50,51,53,54,55,57,58,59,61,62,63,65,66,67,69,70,72,73,75,76,78,82,83,84,90 ‚€ ,94,95,96,99,100,132,133,134,139,140,144,145,158,159,160,181,182,183,184,186,201,208,210,216,217,€* 218,219,220*$ ITC INTEGER 06C0 41,42$V J INTEGER 06E0 123,123,124,125,128,129,130,148,149,150,153,155,167,168V: K INTEGER 06E2 125,126,151,156,161,174,175:6 KEY INTEGER 05B7 1,28,86,87,192,193,197 6, KEYSAV INTEGER 0624 1,131,137,139,* L INTEGER 06EB 193,193,197*t FTN 3.3B (OPT = LPC) TRNPLY PAGE 16 DATE: 08/29/84 TIME: 2311 tB LENGTH INTEGER 06E1 123,124,129,138,143,149,154,166,170B" LIMIT INTEGER 06A6 22 "& LTRCOD INTEGER 05BD 28,105 &F LU INTEGER 06A5 22,47,51,55,59,63,67,90,186,201,208,210F* M INTEGER 06EC 193,193,197*& N INTEGER 06ED 197,197&* NAMPOS INTEGER 06A4 19,162,178 *( NITEM INTEGER 06B7 24,27,167(. NPOS INTEGER 06A7 23,138,143,166 .( ONE INTEGER 063C 1,22,177 (( OPOS INTEGER 063A 1,24,170 (, OSW INTEGER 0623 1,20,103,104 ,( PCOM INTEGER 0635 1,22,155 (( PP INTEGER 0639 1,20,109 (0 PRFLD INTEGER 06A8 24,26,169,170,1710" Q8QX1 INTEGER 0004 39 "( RESULT INTEGER 05BC 1,28,109 (2 SCNREQ INTEGER 007A 1,7,57,69,72,75,78 2& SDAT INTEGER 069C 7,10,37&0 SDATA INTEGER 0092 1,17,37,57,59,2010‚ SDEF INTEGER 01C0 1,69,71,72,74,75,77,94,104,106,107,108,110,111,112,113,132,136,137,138,139,143,144,158,163,165,166 ‚4 ,170,171,176,177,183 4< STRING INTEGER 05EF 1,97,101,102,104,179,180,181 <. SUPCHG INTEGER 0183 1,16,77,149,150.0 TDATA INTEGER 006B 1,13,33,53,55,90 0& TKEY INTEGER 0638 1,19,82&h TRNBUF INTEGER 05A9 1,28,82,85,97,98,102,106,107,108,110,111,113,138,143,166,170,193,197,212 h, TRNREQ INTEGER 0053 1,7,53,82,216,. UDATA INTEGER 063E 1,5,30,32,65,67.L UPDCOD INTEGER 05B8 1,28,116,117,118,119,120,123,128,148,153,193 L. UTIREC INTEGER 0665 1,98,99,101,214., UTIREQ INTEGER 064D 1,6,65,99,220,8 WRONKY INTEGER 05A8 1,19,70,73,76,95,100,159 8( Y INTEGER 061F 1,20,112 (   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " CCSBLK SUBROUTINE 0966 136"& CCSCST SUBROUTINE 09E8 29,163 &‚ CCSMVA SUBROUTINE 0BF2 31,33,34,35,36,37,85,97,98,101,102,106,107,108,110,111,112,113,131,137,138,143,165,166,170,171,176 ‚0 ,177,179,180,214 06 CLOSFL SUBROUTINE 0BFC 77,216,217,218,219,220 6D FILERR SUBROUTINE 0B7B 46,51,55,59,63,67,90,186,201,208,210 D( GETCHF SUBROUTINE 07EA 70,74,77 (" GETS SUBROUTINE 082A 81 ". ICCSAD INTEGER.FN. 099B 123,128,148,153.0 OPENFL SUBROUTINE 0780 44,49,53,57,61,650" PGMIN SUBROUTINE 06F0 28 "& PGMOUT SUBROUTINE 0C61 203,223&" PUTACF SUBROUTINE 08A8 103"t FTN 3.3B (OPT = LPC) TRNPLY PAGE 17 DATE: 08/29/84 TIME: 2311 t" PUTS SUBROUTINE 0A6C 180" Q8QEND INTEGER.FN. 0BD4 Q8QINI INTEGER.FN. 0B9F 2 Q8QX SUBROUTINE 0BCF 39,193,197,212,221 2 Q8STP INTEGER.FN. 0C63 6 READR SUBROUTINE 09C4 69,72,75,94,99,132,158 6& UPDREC SUBROUTINE 0A78 143,183&" WRITER SUBROUTINE 0978 138"" WTREAD SUBROUTINE 0765 40 "   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < * 5 072D 31,38,42,44*$ 6 0745 38,40$$ 10 0790 46,49$$ 20 079E 50,53$$ 30 07AC 54,57$$ 40 07BA 58,61$$ 45 07C8 62,65$$ 50 07D6 66,69$* 99 0BFB 83,207,216 *< 100 0829 81,89,122,142,147,185,196,200<$ 103 0851 84,90$$ 105 085B 86,93$& 107 0896 100,215&& 110 08C1 105,108&& 205 08EE 87,115 && 210 090F 116,121&& 250 0913 117,123&& 300 092F 118,128&& 305 0965 134,136&& 315 0986 133,143&& 350 099A 119,148&& 400 09B6 120,153&* 450 09C2 126,152,157*. 455 09FC 161,162,164,166.* 460 0A39 167,169,173*& 470 0A3C 171,174&& 480 0A52 175,178&2 500 0A77 109,114,174,178,1832& 551 0A96 189,190&& 552 0B57 197,198&& 555 0B06 193,194&& 556 0B86 202,203&& 557 0BA5 205,206&& 558 0C1A 221,222&& 559 0BD6 212,213&. 990 0A81 96,160,184,186 .F 991 0B9E 43,48,52,56,60,64,68,92,187,205,209,211F& 992 0BC3 182,210&t FTN 3.3B (OPT = LPC) TRNPLY PAGE 18 DATE: 08/29/84 TIME: 2311 t& 993 0BC9 100,212&. 995 0BBD 134,140,145,208.* 996 0A89 95,159,188 *& 997 0B25 192,197&, 999 0B7A 70,73,76,201 , TRNPLY 0000 1 t FTN 3.3B (OPT = LPC) TVPDT1 PAGE 1 DATE: 08/29/84 TIME: 2313 t^ 1 SUBROUTINE TVPDT1 ( PO, P, V1, V2, IBOOL) C2900001^^ 1 1 /C29 F CCS CCS 3.0 SL-149C2900002^^ C C2900003^^ C CYBERCREDIT SYSTEM VERSION 3 C2900004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C2900005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C2900006^^ C C2900007^^ 2 INTEGER PO, P(3), V1(3), V2(3), EQUAL C2900008^^ 3 INTEGER BETWEN C2900009^^ 4 DATA EQUAL/1/, LESTHN /2/ C2900010^^ 5 DATA BETWEN/5/ C2900011^^ C INITIALIZE TO TRUE C2900012^^ 6 IBOOL = 1 C2900013^^ C***************************************************************138*0001C2900014^^ 7 GO TO ( 100, 200, 200, 100, 300, 400), PO C2900015^^ C***************************************************************138*0001C2900016^  ^ C TEST EQUAL C2900018^^ 8 100 DO 110 I = 1,3 C2900019^^ 9 IF ( P(I) .NE. V1(I) ) GO TO 150 C2900020^^ 10 110 CONTINUE C2900021^^ C EQUAL, SET FALSE IF TEST WAS FOR .NE. C2900022^^ 11 IF (PO .NE. EQUAL) IBOOL = 0 C2900023^^ 12 GO TO 9500 C2900024^^ C NOT EQUAL, SET FALSE IF TEST WAS FOR .EQ. C2900025^^ 13 150 IF ( PO.EQ.EQUAL) IBOOL = 0 C2900026^^ 14 GO TO 9500 C2900027^  ^ C TEST LESS THAN OR EQUAL TO - STATEMENT TRUE IF .GT. C2900029^^ 15 200 IF ( P(1).GT. V1(1) C2900030^^ 15 * .OR. ( P(1) .EQ. V1(1) .AND. P(2) .GT. V1(2) ) C2900031^^ 15 * .OR. ( P(1) .EQ. V1(1) .AND. P(2) .EQ. V1(2) C2900032^^ 15 * .AND. P(3) .GT. V1(3) ) ) GO TO 250 C2900033^^ C .LE., SET FALSE IF .GT. TEST C2900034^^ 16 IF (PO .NE. LESTHN) IBOOL = 0 C2900035^^ 17 GO TO 9500 C2900036^^ C .GT., SET FALSE IF .LE. TEST C2900037^^ 18 250 IF (PO .EQ. LESTHN) IBOOL = 0 C2900038^^ 19 GO TO 9500 C2900039^  ^ C***************************************************************138*0001C2900041^^ C TEST FOR BETWEEN (EQUAL TO OR WITHIN BOUNDS). C2900042^^ 20 300 IF (P(1) .GT. V1(1) C2900043^^ C***************************************************************138*0001C2900044^^ 20 * .OR. (P(1) .EQ. V1(1) .AND. P(2) .GT. V1(2)) C2900045^^ 20 * .OR. (P(1) .EQ. V1(1) .AND. P(2) .EQ. V1(2) C2900046^^ C***************************************************************138*0001C2900047^^ 20 * .AND. P(3) .GE. V1(3))) GO TO 350 C2900048^^ C LESS THAN FIRST BOUND, MARK FALSE AND RETURN C2900049^^ C***************************************************************138*0001C2900050^^ 21 IBOOL = 0 C2900051^t FTN 3.3B (OPT = LPC) TVPDT1 PAGE 2 DATE: 08/29/84 TIME: 2313 t^ 22 GO TO 9500 C2900052^^ C LESS THAN FIRST BOUND, MARK FALSE AND RETURN C2900049^^ C***************************************************************138*0001C2900050^^ 21 IBOOL = 0 C2900051^t FTN 3.3B (OPT = LPC) TVPDT1 PAGE 2 DATE: 08/29/84 TIME: 2313 t^ 22 GO TO 9500 C2900052^^ C***************************************************************138*0001C2900053^^ C FIVE CARDS DELETED. C2900054^^ C***************************************************************138*0001C2900055^^ C TEST 2ND PARAMETER FOR .LE. C2900056^^ 23 350 IF ( P(1) .LT. V2(1) C2900057^^ 23 * .OR.(P(1) .EQ. V2(1) .AND. P(2) .LT. V2(2) ) C2900058^^ 23 * .OR.(P(1) .EQ. V2(1) .AND. P(2) .EQ. V2(2) C2900059^^ C***************************************************************138*0001C2900060^^ 23 * .AND. P(3) .LE. V2(3))) GOTO 9500 C2900061^^ C GREATER THAN SECOND BOUND, MARK FALSE AND RETURN C2900062^^ 24 IBOOL = 0 C2900063^^ 25 GO TO 9500 C2900064^^ C CHECK OUT OF BOUNDS TEST C2900065^^ 26 400 IF ((P(1) .LT. V1(1)) .OR. (P(1) .GT. V2(1))) GO TO 9500 C2900066^^ 27 IF ((P(1) .EQ. V1(1)) .OR. (P(1) .GT. V2(1))) GO TO 425 C2900067^^ C 1ST 2 BYTES FAILED TEST, MARK FALSE AND RETURN C2900068^^ 28 GO TO 9000 C2900069^^ 29 425 IF ((P(2) .LT. V1(2)) .OR. (P(2) .GT. V2(2))) GO TO 9500 C2900070^^ 30 IF ((P(2) .EQ. V1(2)) .OR. (P(2) .GT. V2(2))) GO TO 450 C2900071^^ C 2ND 2 BYTES FAILED, MARK FALSE AND RETURN C2900072^^ 31 GO TO 9000 C2900073^^ 32 450 IF ((P(3) .LT. V1(3)) .OR. (P(3) .GT. V2(3))) GO TO 9500 C2900074^^ C LAST 2 BYTES FAILED, MARK FALSE AND RETURN C2900075^^ 33 GO TO 9000 C2900076^^ 34 9000 IBOOL = 0 C2900077^^ 35 9500 RETURN C2900078^^ C***************************************************************138*0001C2900079^^ 36 END C2900080^t FTN 3.3B (OPT = LPC) TVPDT1 PAGE 3 DATE: 08/29/84 TIME: 2313 t  PROGRAM LENGTH $0119 ( 281)   EXTERNALS  Q8PKUP Q8PREP  t FTN 3.3B (OPT = LPC) TVPDT1 PAGE 4 DATE: 08/29/84 TIME: 2313 t, ***** L I S T O F S Y M B O L S *****,   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " BETWEN INTEGER 0001 2,5"( EQUAL INTEGER 0000 2,4,11,13(" I INTEGER 0003 8,9"8 IBOOL INTEGER 7FFF 1,6,11,13,16,18,21,24,34 8& LESTHN INTEGER 0002 4,16,18&< P INTEGER 7FFF 1,2,9,15,20,23,26,27,29,30,32<0 PO INTEGER 7FFF 1,2,7,11,13,16,180: V1 INTEGER 7FFF 1,2,9,15,20,26,27,29,30,32 :4 V2 INTEGER 7FFF 1,2,23,26,27,29,30,324   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  Q8PKUP INTEGER.FN. 00E8 Q8PREP INTEGER.FN. 00E5    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 100 001A 6,7,8$$ 110 0022 8,10 $$ 150 0031 9,13 $& 200 0039 6,7,15 &$ 250 0063 15,18$$ 300 006C 7,20 $$ 350 0089 20,23$$ 400 00AA 7,26 $$ 425 00BD 27,29$$ 450 00D2 30,32$* 9000 00DD 27,31,33,34*@ 9500 00DF 11,14,17,19,22,23,25,26,29,32,35 @ TVPDT1 00E2 1 t FTN 3.3B (OPT = LPC) UIDMTN PAGE 1 DATE: 08/29/84 TIME: 2313 t^ 1 PROGRAM UIDMTN C3000001^^ 1 1 /C30 F CCS CCS 3.0 SL-149C3000002^^ C C3000003^^ C CYBERCREDIT SYSTEM VERSION 3 C3000004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C3000005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C3000006^^ C C3000007^ ^ C***************************************************************138*A016C3000009^^ C $$USERID MAINTENCE PROGRAM. THIS PROGRAM PROCESSES REQUESTS C3000010^^ C TO ADD, DELETE, AND UPDATE ENTRIES IN THE INDEXED $$USERID C3000011^^ C FILE. C3000012^   ^ C FILE MANAGER BUFFERS. C3000014^^ 2 INTEGER REQBUF(24) , IDATA(15) , RECBUF(14) , KEY(5) , SKEY(5) C3000015^^ 3 INTEGER KEY1(4),KEY2(1) C3000016^^ 4 DATA REQBUF / 24*0 / C3000017^^ 5 DATA IDATA / '$$USERID ' , 4*$2020 , 1 , 1 , 1 / C3000018^^ 6 EQUIVALENCE ( KEY(1), KEY1(1) ), ( KEY(5), KEY2(1) ) C3000019^  ^ C MESSAGE BUFFERS. C3000021^^ 7 INTEGER CS C3000022^^ 8 DATA CS / $18 / C3000023^^ 9 INTEGER PGINOU(21) C3000024^^ 10 DATA PGINOU / $D0A , '$$USERID FILE MODIFICATION PROGRAM IN ' , C3000025^^ 10 1 $D0A / C3000026^^ 11 INTEGER INOPER(37) C3000027^^ 12 DATA INOPER / $D0A , 'ENTER "UPD" TO ADD/UPDATE, "DEL" TO DELETE',C3000028^^ 12 1 ', OR CARRIAGE RETURN TO EXIT' , $D0A / C3000029^^ 13 INTEGER INVREQ(10) C3000030^^ 14 DATA INVREQ / $D0A , 'INVALID REQUEST ' , $D0A / C3000031^^ 15 INTEGER INKEY(29),PTKEY(10) C3000032^^ 16 DATA INKEY / $D0A , 'ENTER KEY OF RECORD TO XXXXXXXXXX ' , $D0A , C3000033^^ 16 1 'XXXXXXXX - USER ID' , $D0A / C3000034^^ 17 DATA PTKEY / $D0A ,'XX - PORT NO. ', $D0A / C3000035^^ 18 INTEGER NOREC(29) C3000036^^ 19 DATA NOREC / $D0A , 'RECORD -XXXXXXXXXX- DOES NOT EXIST, CANNOT' ,C3000037^^ 19 1 ' BE DELETED ' ,$D0A / C3000038^^ 20 INTEGER ADDSUC(21) , DELSUC(22) , UPDSUC(22) C3000039^^ 21 DATA ADDSUC /$D0A, 'RECORD -XXXXXXXXXX- ADDED SUCCESSFULLY',$D0A/ C3000040^^ 22 DATA DELSUC /$D0A,'RECORD -XXXXXXXXXX- DELETED SUCCESSFULLY',$D0A/C3000041^^ 23 DATA UPDSUC /$D0A,'RECORD -XXXXXXXXXX- UPDATED SUCCESSFULLY',$D0A/C3000042^  ^ C INPUT BUFFER FOR UPDATE AND OPERATION REQUESTS. C3000044^^ 24 INTEGER INBUF(5) C3000045^^ 25 EQUIVALENCE ( INCHAR , INBUF(5) ) C3000046^  ^ C BUFFER FOR FORMAT LINE OUTPUT. C3000048^^ 26 INTEGER FOROUT(12) C3000049^t FTN 3.3B (OPT = LPC) UIDMTN PAGE 2 DATE: 08/29/84 TIME: 2313 t^ 27 DATA FOROUT / $D0A , 'USER ID P# REQUEST ' , $D0A / C3000050^  ^ C LOGIN VARIABLES. C3000052^^ 28 INTEGER ID(4) , LU C3000053^ ^ C OPERATION CODE TABLES. C3000055^^ 29 INTEGER VALOP(4) , OPOUT(10) C3000056^^ 30 DATA VALOP / 'UPD DEL ' / C3000057^^ 31 DATA OPOUT / 'ADD/UPDATEDELETE ' / C3000058^ ^ C OTHER SMALL VARIABLES AND CONSTANTS. C3000060^^ 32 INTEGER OP , EOF , WRONKY , BLANK , TC , UPDFLG C3000061^^ 33 DATA EOF / $8100 / , WRONKY / $200 / C3000062^^ 34 DATA BLANK / $2020 / C3000063^   ^ C FORMAT MESSAGE. C3000065^^ 35 INTEGER DASH(4), BAKSP(4) C3000066^^ 36 DATA DASH / 4*'--' / C3000067^^ 37 DATA BAKSP / 4*$808 / C3000068^t FTN 3.3B (OPT = LPC) UIDMTN PAGE 3 DATE: 08/29/84 TIME: 2313 t^ C SET UP FOR PROCESSING. RETRIEVE PROGRAM INFORMATION AND C3000070^^ C OPEN UTILITY FILE. C3000071^^ 38 50 CALL PGMIN ( ID , LU , I , J ) C3000072^^ 39 CALL OPENFL ( REQBUF , IDATA , ISTAT ) C3000073^^ C OPEN REQUEST SUCCESSFUL? C3000074^^ 40 IF ( ISTAT .LT. 0 ) GO TO 800 C3000075^^ C YES. CLEAR SCREEN AND WRITE PROGRAM IN MESSAGE. C3000076^^ 41 CALL WTREAD ( LU , -1 , CS , 2 , 0 , 0 , 0 , TC ) C3000077^^ 42 CALL WTREAD ( LU , -1 , PGINOU , 42 , 0 , 0 , 0 , TC ) C3000078^ ^ C RETRIEVE NEXT OPERATION REQUEST. C3000080^^ 43 100 INBUF(1) = BLANK C3000081^^ 44 INBUF(2) = BLANK C3000082^^ 45 CALL WTREAD ( LU , -1 , INOPER , 74 , -1 , INBUF , 3 , TC ) C3000083^^ C IF RUBOUT, REPEAT INPUT REQUEST. C3000084^^ 46 IF ( TC .EQ. 4 ) GO TO 100 C3000085^^ C VALIDATE OPERATION REQUEST. MUST BE 'UPD', 'DEL', OR C3000086^^ C JUST A CARRIAGE RETURN (TERMINATES). C3000087^^ 47 IF( INBUF(3) .EQ. 0 ) GO TO 900 C3000088^^ C SCAN TABLE OF VALID OPERATION CODES. C3000089^^ 48 DO 110 OP = 1 , 2 C3000090^^ 49 J = 2*OP - 1 C3000091^^ 50 IF ( VALOP(J) .EQ. INBUF(1) .AND. C3000092^^ 50 1 VALOP(J+1) .EQ. INBUF(2) ) GO TO 120 C3000093^^ 51 110 CONTINUE C3000094^ ^ C INVALID OPERATION REQUESTED. REPORT ERROR AND PROMPT AGAIN. C3000096^^ 52 CALL WTREAD ( LU , -1 , INVREQ , 20 , 0 , 0 , 0 , TC ) C3000097^^ 53 GO TO 100 C3000098^ ^ C VALID OPERATION. PROMPT FOR KEY. C3000100^^ 54 120 J = 10*OP - 9 C3000101^^ 55 CALL CCSMVA ( OPOUT , J , 10 , INKEY , 26 , 10 ) C3000102^^ 56 CALL CCSBLK ( KEY, 10 ) C3000103^^ 57 125 CALL WTREAD ( LU , -1 , INKEY , 58 , -1 , KEY1, 8 , TC ) C3000104^^ C IF RUBOUT, REPEAT ENTER REQUEST. C3000105^^ 58 IF ( TC .EQ. 4 ) GO TO 125 C3000106^^ 59 130 CALL WTREAD ( LU, -1, PTKEY, 20, -1, KEY2, 2, TC ) C3000107^^ C IF RUBOUT, REPEAT ENTER REQUEST. C3000108^^ 60 IF ( TC.EQ.4 ) GO TO 130 C3000109^ ^ C ATTEMPT RECORD RETRIEVAL WITH KEY GIVEN. C3000111^^ 61 CALL CCSMVA ( KEY, 1, 10, SKEY, 1, 10 ) C3000112^^ 62 CALL READR ( REQBUF , RECBUF , SKEY , ISTAT ) C3000113^^ C FATAL FILE ERROR? C3000114^^ 63 IF ( ISTAT .LT. 0 .AND. AND( ISTAT , EOF ) .NE. EOF ) C3000115^^ 63 1 GO TO 810 C3000116^^ C NO ERROR. JUMP TO PROCESS ON THE BASIS OF OPERATION ENTRY. C3000117^^ 64 220 IF ( OP .EQ. 1 ) GO TO 400 C3000118^t FTN 3.3B (OPT = LPC) UIDMTN PAGE 4 DATE: 08/29/84 TIME: 2313 t^ C DELETE OPERATION. C3000120^  ^ C CANNOT DELETE IF RECORD DOES NOT EXIST. C3000122^^ C DOES RECORD EXIST? C3000123^^ 65 300 IF ( AND( ISTAT , EOF ) .NE. EOF .AND. C3000124^^ 65 1 AND( ISTAT , WRONKY ) .NE. WRONKY ) GO TO 310 C3000125^^ C NO, RECORD NOT FOUND. REPORT ERROR AND GET NEXT REQUEST. C3000126^^ 66 CALL CCSMVA ( KEY, 1, 10, NOREC, 11, 10 ) C3000127^^ 67 CALL WTREAD ( LU , -1 , NOREC , 58 , 0 , 0 , 0 , TC ) C3000128^^ 68 GO TO 100 C3000129^  ^ C RECORD FOUND, DELETE. C3000131^^ 69 310 CALL DELREC ( REQBUF , RECBUF , ISTAT ) C3000132^^ C DELETE SUCCESSFUL? C3000133^^ 70 IF ( ISTAT .LT. 0 ) GO TO 830 C3000134^^ C YES, REPORT SUCCESSFUL DELETE AND GET NEXT REQUEST. C3000135^^ 71 CALL CCSMVA ( KEY, 1, 10, DELSUC, 11, 10 ) C3000136^^ 72 CALL WTREAD ( LU , -1 , DELSUC , 44 , 0 , 0 , 0 , TC ) C3000137^^ 73 GO TO 100 C3000138^t FTN 3.3B (OPT = LPC) UIDMTN PAGE 5 DATE: 08/29/84 TIME: 2313 t^ C ADD/UPDATE OPERATION. C3000140^  ^ C IF RECORD IS NOT PRESENT IN FILE, THEN REQUEST IS AN ADD. IF C3000142^^ C RECORD IS PRESENT, REQUEST IS AN UPDATE. C3000143^^ C SET FLAG FOR UPDATE REQUEST AND CHECK IF RECORD FOUND. C3000144^^ 74 400 UPDFLG = 1 C3000145^^ 75 IF ( AND( ISTAT , EOF ) .NE. EOF .AND. C3000146^^ 75 1 AND( ISTAT , WRONKY ) .NE. WRONKY ) GO TO 410 C3000147^^ C NO, RECORD NOT FOUND. SET FLAG TO INDICATE ADD OPERATION AND C3000148^^ C SET UP RECORD BUFFER FOR ADD. (BLANK AND MOVE IN KEY). C3000149^^ 76 UPDFLG = 0 C3000150^^ 77 CALL CCSMVA ( DASH, 1, 8, RECBUF, 13, 8 ) C3000151^^ 78 CALL CCSMVA ( KEY, 1, 10, RECBUF, 1, 12 ) C3000152^  ^ C PRINT FORMAT LINE AND OLD RECORD CONTENTS AND RECEIVE C3000154^^ C INPUT FOR CHANGES TO RECORD. C3000155^^ 79 410 CALL WTREAD ( LU , -1 , FOROUT , 24 , 0 , 0 , 0 , TC ) C3000156^^ 80 CALL CCSMVA ( BAKSP, 1, 8, RECBUF, 21, 8 ) C3000157^^ 81 415 CALL WTREAD ( LU, -1, RECBUF, 28, -1, INBUF, 8, TC ) C3000158^^ C IF RUBOUT, REPEAT ENTER REQUEST. C3000159^^ 82 IF (TC .EQ. 4) GO TO 410 C3000160^ ^ C IF NO INPUT, ADD/UPDATE OPERATION ABORTED. DO NOT PERFORM C3000162^^ C FILE WRITE OR OUTPUT COMPLETED MESSAGE. INSTEAD, GET NEXT C3000163^^ C REQUEST. C3000164^^ 83 IF ( INCHAR .EQ. 0 ) GO TO 100 C3000165^^ 84 CALL CCSBLK ( RECBUF(6), 10 ) C3000166^ ^ C INPUT CHANGES RECEIVED. MERGE INTO FILE RECORD BUFFER, WITH C3000168^^ C ANY ENTRY <$20 OR >$5A FROM INBUF NOT OVERLAYING CONTENTS C3000169^^ C OF RECORD BUFFER. C3000170^^ 85 DO 420 I = 1 , INCHAR C3000171^^ 86 CALL CCSGET ( INBUF , I , J ) C3000172^^ 87 IF ( J .GE. $ 20 .AND. J .LE. $5B ) C3000173^^ 87 1 CALL CCSPUT ( J , I , RECBUF(7) ) C3000174^^ 88 420 CONTINUE C3000175^ ^ C MERGE COMPLETE. PERFORM WRITER/UPDREC REQUEST DEPENDING ON C3000177^^ C OPERATION. CHECK FOR ADD. C3000178^^ 89 IF ( UPDFLG .EQ. 0 ) GO TO 430 C3000179^ ^ C UPDATE OPERATION. UPDATE RECORD IN FILE. C3000181^^ 90 CALL UPDREC ( REQBUF , RECBUF , ISTAT ) C3000182^^ C UPDATE SUCCESSFUL? C3000183^^ 91 IF ( ISTAT .LT. 0 ) GO TO 840 C3000184^^ C YES, REPORT AND GET NEXT REQUEST. C3000185^^ 92 CALL CCSMVA ( KEY, 1, 10, UPDSUC, 11, 10 ) C3000186^^ 93 CALL WTREAD ( LU , -1 , UPDSUC , 44 , 0 , 0 , 0 , TC ) C3000187^^ 94 GO TO 100 C3000188^ ^ C ADD OPERATION. ADD RECORD TO FILE. C3000190^^ 95 430 CALL WRITER ( REQBUF , RECBUF , KEY , ISTAT ) C3000191^t FTN 3.3B (OPT = LPC) UIDMTN PAGE 6 DATE: 08/29/84 TIME: 2313 t^ C FILE ERROR? C3000192^^ 96 IF ( ISTAT .LT. 0 ) GO TO 820 C3000193^^ C NO. REPORT SUCCESSFUL ADD AND GET NEXT REQUEST. C3000194^^ 97 CALL CCSMVA ( KEY, 1, 10, ADDSUC, 11, 10 ) C3000195^^ 98 CALL WTREAD ( LU , -1 , ADDSUC , 42 , 0 , 0 , 0 , TC ) C3000196^^ 99 GO TO 100 C3000197^t FTN 3.3B (OPT = LPC) UIDMTN PAGE 7 DATE: 08/29/84 TIME: 2313 t^ C FILE ERROR PROCESSING. C3000199^ ^ C OPENFL REQUEST. C3000201^^ 100 800 J = 3 C3000202^^ 101 GO TO 850 C3000203^ ^ C READR REQUEST. C3000205^^ 102 810 J = 13 C3000206^^ 103 GO TO 850 C3000207^ ^ C WRITER REQUEST. C3000209^^ 104 820 J = 12 C3000210^^ 105 GO TO 850 C3000211^ ^ C DELREC REQUEST. C3000213^^ 106 830 J = 16 C3000214^^ 107 GO TO 850 C3000215^ ^ C UPDREC REQUEST. C3000217^^ 108 840 J = 15 C3000218^ ^ C OUTPUT ERROR MESSAGE. C3000220^^ 109 850 CALL FILERR ( IDATA , J , ISTAT , LU ) C3000221^   ^ C WRITE PROGRAM OUT MESSAGE, CLOSE UTILITY FILE, AND EXIT. C3000223^^ 110 900 PGINOU(19) = PGINOU(19) + $6 C3000224^^ 111 PGINOU(20) = PGINOU(20) + $734 C3000225^^ 112 CALL WTREAD ( LU , -1 , PGINOU , 42 , 0 , 0 , 0 , TC ) C3000226^^ 113 CALL CLOSFL ( REQBUF , ISTAT ) C3000227^^ 114 CALL PGMOUT C3000228^  ^ C***************************************************************138*A016C3000230^^ 115 END C3000231^t FTN 3.3B (OPT = LPC) UIDMTN PAGE 8 DATE: 08/29/84 TIME: 2313 t  PROGRAM LENGTH $02FD ( 765)   EXTERNALS 2 Q8STP PGMIN OPENFL WTREAD CCSMVA CCSBLK READR 22 DELREC CCSGET CCSPUT UPDREC WRITER FILERR CLOSFL 2 PGMOUT  t FTN 3.3B (OPT = LPC) UIDMTN PAGE 9 DATE: 08/29/84 TIME: 2313 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < F FFFE (-1) 0142 41,42,45,52,57,59,67,72,79,81,93,98,112FX 0000 (0) 0003 4,40,41,42,47,52,63,67,70,72,76,79,83,89,91,93,96,98,112 Xz 0001 (1) 0002 3,5,6,41,42,43,45,48,49,50,52,57,59,61,64,66,67,71,72,74,77,78,79,80,81,85,92,93,97,98,112 z0 0002 (2) 0143 41,44,48,49,50,590( 0003 (3) 0146 45,47,100(* 0008 (8) 014B 57,77,80,81*< 000A (10) 0148 54,55,56,61,66,71,78,84,92,97<* 000B (11) 014C 66,71,92,97*& 000C (12) 014F 78,104 && 000D (13) 014E 77,102 &( 0014 (20) 0147 52,59,111(" 0015 (21) 0151 80 "" 0018 (24) 0150 79 "" 001A (26) 0149 55 "" 001C (28) 0152 81 "( 002A (42) 0144 42,98,112($ 002C (44) 014D 72,93$$ 003A (58) 014A 57,67$" 004A (74) 0145 45 "" 0734 (1844) 0153 111"   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < * ADDSUC INTEGER 00CC 19,21,97,98*( AND INTR.FN. 7FFF 63,65,75 (( BAKSP INTEGER 013B 34,37,80 (* BLANK INTEGER 0134 31,34,43,44*& CS INTEGER 0043 6,8,41 &( DASH INTEGER 0137 34,36,77 (* DELSUC INTEGER 00E1 19,22,71,72*. EOF INTEGER 0132 31,33,63,65,75 .( FOROUT INTEGER 0112 25,27,79 (* I INTEGER 013F 38,85,86,87*$ ID INTEGER 011E 27,38$* IDATA INTEGER 001C 1,5,39,109 *: INBUF INTEGER 010D 23,25,43,44,45,47,50,81,86 :( INCHAR INTEGER 0111 23,83,85 (* INKEY INTEGER 0088 14,16,55,57*( INOPER INTEGER 0059 10,12,45 (( INVREQ INTEGER 007E 12,14,52 (J ISTAT INTEGER 0141 39,40,62,63,65,69,70,75,90,91,95,96,109,113JL J INTEGER 0140 38,49,50,54,55,86,87,100,102,104,106,108,109 Lt FTN 3.3B (OPT = LPC) UIDMTN PAGE 10 DATE: 08/29/84 TIME: 2313 t: KEY INTEGER 0039 1,6,56,61,66,71,78,92,95,97:& KEY1 INTEGER 0039 1,6,57 && KEY2 INTEGER 003D 1,6,59 &P LU INTEGER 0122 27,38,41,42,45,52,57,59,67,72,79,81,93,98,109,112P* NOREC INTEGER 00AF 17,19,66,67*. OP INTEGER 0131 31,48,49,54,64 .( OPOUT INTEGER 0127 27,31,55 (2 PGINOU INTEGER 0044 8,10,42,110,111,1122( PTKEY INTEGER 00A5 14,17,59 (> RECBUF INTEGER 002B 1,62,69,77,78,80,81,84,87,90,95>6 REQBUF INTEGER 0004 1,4,39,62,69,90,95,113 6& SKEY INTEGER 003E 1,61,62&V TC INTEGER 0135 31,41,42,45,46,52,57,58,59,60,67,72,79,81,82,93,98,112 V* UPDFLG INTEGER 0136 31,74,76,89** UPDSUC INTEGER 00F7 19,23,92,93*( VALOP INTEGER 0123 27,30,50 (* WRONKY INTEGER 0133 31,33,65,75*   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < $ CCSBLK SUBROUTINE 0274 55,84$" CCSGET SUBROUTINE 027F 85 ": CCSMVA SUBROUTINE 02BD 54,61,66,71,77,78,80,92,97 :" CCSPUT SUBROUTINE 028B 87 "" CLOSFL SUBROUTINE 02F6 112"" DELREC SUBROUTINE 0215 69 "" FILERR SUBROUTINE 02DE 109"" OPENFL SUBROUTINE 015B 38 "" PGMIN SUBROUTINE 0155 37 "" PGMOUT SUBROUTINE 02FA 113" Q8STP INTEGER.FN. 02FC " READR SUBROUTINE 01E0 61 "" UPDREC SUBROUTINE 0296 89 "" WRITER SUBROUTINE 02B3 95 "F WTREAD SUBROUTINE 02A7 40,42,45,52,57,59,67,72,79,81,93,98,112F   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < " 50 0154 37 "6 100 0177 42,46,53,68,73,83,94,996$ 110 019D 47,51$$ 120 01AC 50,54$$ 125 01BD 56,58$$ 130 01CB 58,60$" 220 01F1 63 "" 300 01F5 64 "t FTN 3.3B (OPT = LPC) UIDMTN PAGE 11 DATE: 08/29/84 TIME: 2313 t$ 310 0214 65,69$$ 400 0230 64,74$( 410 024F 75,79,82 (" 415 025F 80 "$ 420 028F 84,88$$ 430 02B2 89,95$& 800 02CF 40,100 && 810 02D2 63,102 && 820 02D5 96,104 && 830 02D8 70,106 && 840 02DB 91,108 &2 850 02DD 100,103,105,107,1092& 900 02E3 47,110 & UIDMTN 0000 1  t FTN 3.3B (OPT = LPC) USEMTN PAGE 1 DATE: 08/29/84 TIME: 2314 t^ 1 PROGRAM USEMTN C5000001^^ 1 1 /C50 F CCS CCS 3.0 PSR CCS/LA 02/83 SL-149********^^ C C5000003^^ C CYBERCREDIT SYSTEM VERSION 3 C5000004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C5000005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C5000006^^ C C5000007^ ^ C THIS PROGRAM GENERATES A REPORT SHOWING ALL USERS C5000009^^ C LOGGED ON TO COLECT, IT ALSO ALWAYS USERS TO BE C5000010^^ C DELETED (IN THE EVENT OF A SINGLE TERMINAL FAILURE). C5000011^ ^ 2 INTEGER ADATA(15),ABUF(6),AREQ(24),USER(4),KEY(2),MSG(24),M2(21) C5000013^ ^ 3 DATA AREQ / 24*0 / , KEY / 0 , 0 / C5000015^^ 4 DATA MSG/ $D0A, C5000016^^ 4 1 'RESPOND WITH "YES" IF ANY DELETES,ELSE (CR) ',$D0A/ C5000017^^ 5 DATA ADATA /'LAACTIVE',8*$2020,1,1,1/ ********^^ 6 DATA M2 / $D0A, C5000019^^ 6 1 'ENTER COLLECTOR ID TO DELETE OR "END" ',$D0A/ C5000020^^ 7 CALL PGMIN ( USER, LU, MODE, NPORT ) C5000021^^ C**** SET FILENAME ACCORDING TO OWNER ID. ********^^ 8 CALL CCSCST(ADATA,1,2,USER,1,8,ICM) ********^^ 9 IF ( ICM.NE.0 )CALL CCSMVA(ADATA,3,6,ADATA,1,8) ********^ ^ C OPEN 'ACTIVE' FILE FOR USE C5000023^^ 10 CALL OPENFL ( AREQ, ADATA, ISTAT ) C5000024^^ 11 IF ( ISTAT .GE. 0 ) GO TO 100 C5000025^^ 12 CALL FILERR ( ADATA, 3, ISTAT, LU ) C5000026^^ 13 GO TO 900 C5000027^ ^ C WRITE REPORT HEADERS C5000029^^ 14 100 ICLR=$1820 ********^^ 15 WRITE(LU,4000)ICLR ********^^ 16 4000 FORMAT(A2) ********^^ 17 WRITE (LU,1001) C5000031^ ^ C LOOP THRU ACTIVE AND PRINT USERS C5000033^^ 18 200 CALL GETS ( AREQ, ABUF, KEY, ISTAT ) C5000034^^ 19 IF ( AND($100,ISTAT) .EQ. $100 ) GO TO 300 C5000035^^ 20 IF ( ISTAT .GE. 0 ) GO TO 250 C5000036^^ 21 CALL FILERR ( ADATA, 14, ISTAT, LU ) C5000037^^ 22 GO TO 900 C5000038^ ^ C WRITE DETAIL USER LINE C5000040^^ 23 250 CONTINUE ********^^ 24 WRITE (LU,2001)(ABUF(I),I=1,5) C5000042^^ C GET NEXT USER C5000043^^ 25 GO TO 200 C5000044^ ^ C PROMPT FOR ANY DELETES C5000046^^ 26 300 CALL WTREAD ( LU, -1, MSG, 48, -1, USER, 2, IC ) C5000047^^ 27 IF (USER(1).NE.$5945) GO TO 900 C5000048^ t FTN 3.3B (OPT = LPC) USEMTN PAGE 2 DATE: 08/29/84 TIME: 2314 t^ C PROCESS RECORD DELETES C5000050^^ 28 400 USER(1)=$2020 C5000051^^ 29 USER(2)=$2020 C5000052^^ 30 CALL WTREAD (LU,-1,M2,42,-1,USER,4,IC) C5000053^^ 31 IF (USER(1).EQ.$454E.AND.USER(2).EQ.$4420) GO TO 900 C5000054^^ C SAVE THE KEY C5000055^^ 32 KEY(1)=USER(1) C5000056^^ 33 KEY(2)=USER(2) C5000057^^ C GET THE RECORD C5000058^^ 34 CALL READR ( AREQ, ABUF, USER, ISTAT ) C5000059^^ 35 IF(AND(ISTAT,$100).EQ.$100.OR.AND(ISTAT,$200).EQ.$200) GO TO 430 C5000060^^ 36 IF(ISTAT.GE.0) GO TO 440 C5000061^^ 37 IF (ISTAT.GE.0) GO TO 450 C5000062^^ 38 CALL FILERR ( ADATA, 13, ISTAT, LU ) C5000063^^ 39 GO TO 400 C5000064^^ C KEY NOT FOUND C5000065^^ 40 430 WRITE(LU,3000)KEY(1),KEY(2) C5000066^^ 41 GO TO 400 C5000067^^ C COMPARE KEYS TO SEE IF THEY ARE THE SAME C5000068^^ 42 440 CALL CCSCST(KEY,1,4,ABUF,1,4,ICOMP) C5000069^^ 43 IF(ICOMP.EQ.0) GO TO 450 C5000070^^ 44 GO TO 430 C5000071^^ C DELETE THE RECORD AND CONTINUE C5000072^^ 45 450 CALL DELREC ( AREQ, ABUF, ISTAT ) C5000073^^ 46 IF (ISTAT.GE.0) GO TO 400 C5000074^^ 47 CALL FILERR ( ADATA, 16, ISTAT, LU ) C5000075^^ 48 GO TO 400 C5000076^^ C CLOSE THE FILE AND STOP C5000077^^ 49 900 CALL CLOSFL (AREQ,ISTAT) C5000078^^ 50 CALL PGMOUT C5000079^^ 51 1000 FORMAT (1H1,5X,'USERS OF COLECT',/,3X,'ID',3X,'PORT',3X,'TIME'/) C5000080^^ 52 1001 FORMAT (20X,'USERS OF COLECT',/,10X,'ID',5X,'PORT',5X,'TIME') C5000081^^ 53 2000 FORMAT (2X,2A2,3X,I4,4X,A2,':',A2) C5000082^^ 54 2001 FORMAT (9X,2A2,5X,I4,6X,A2,':',A2) C5000083^^ 55 3000 FORMAT(5X,'USER ',A2,A2,' NOT FOUND') C5000084^^ 56 END C5000085^t FTN 3.3B (OPT = LPC) USEMTN PAGE 3 DATE: 08/29/84 TIME: 2314 t  PROGRAM LENGTH $01D4 ( 468)   EXTERNALS 2 Q8STP Q8QINI Q8QX Q8QEND PGMIN CCSCST CCSMVA 22 OPENFL FILERR GETS WTREAD READR DELREC CLOSFL 2 PGMOUT  t FTN 3.3B (OPT = LPC) USEMTN PAGE 4 DATE: 08/29/84 TIME: 2314 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < ( FFFE (-1) 0070 26,26,30 (@ 0001 (1) 0001 5,8,9,24,26,27,28,30,31,32,40,42 @0 0002 (2) 0065 8,26,29,31,33,40 0$ 0003 (3) 0068 9,12 $$ 0004 (4) 0076 30,42$ 0006 (6) 0069 9 " 0008 (8) 0066 8,9"" 000D (13) 007A 38 "" 000E (14) 006E 21 "" 0010 (16) 007C 47 "" 002A (42) 0075 30 "" 0030 (48) 0071 26 "( 0100 (256) 006D 19,19,35 ($ 0200 (512) 0079 35,35$" 1820 (6176) 006C 14 "$ 2020 (8224) 0074 28,29$" 4420 (17440) 0078 31 "" 454E (17742) 0077 31 "" 5945 (22853) 0073 27 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < 0 ABUF INTEGER 0011 1,18,24,34,42,45 06 ADATA INTEGER 0002 1,5,8,9,10,12,21,38,47 6$ AND INTR.FN. 7FFF 19,35$2 AREQ INTEGER 0017 1,3,10,18,34,45,49 2$ I INTEGER 006F 24,24$$ IC INTEGER 0072 26,30$( ICLR INTEGER 006B 14,14,15 (" ICM INTEGER 0067 8,9"$ ICOMP INTEGER 007B 42,43$N ISTAT INTEGER 006A 10,11,12,18,19,20,21,34,35,36,37,38,45,46,47,49N2 KEY INTEGER 0033 1,3,18,32,33,40,42 2> LU INTEGER 0062 7,12,15,17,21,24,26,30,38,40,47>& M2 INTEGER 004D 1,6,30 & MODE INTEGER 0063 7 & MSG INTEGER 0035 1,4,26 & NPORT INTEGER 0064 7 @ USER INTEGER 002F 1,7,8,26,27,28,29,30,31,32,33,34 @t FTN 3.3B (OPT = LPC) USEMTN PAGE 5 DATE: 08/29/84 TIME: 2314 t   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < $ CCSCST SUBROUTINE 0143 7,42 $ CCSMVA SUBROUTINE 0090 9 " CLOSFL SUBROUTINE 0160 49 "" DELREC SUBROUTINE 0151 45 "* FILERR SUBROUTINE 012E 11,21,38,47*" GETS SUBROUTINE 00BD 17 " OPENFL SUBROUTINE 0098 9 PGMIN SUBROUTINE 007E 6 " PGMOUT SUBROUTINE 0164 49 " Q8QEND INTEGER.FN. 0140 Q8QINI INTEGER.FN. 0135 ( Q8QX SUBROUTINE 013B 15,24,40 ( Q8STP INTEGER.FN. 01D3 " READR SUBROUTINE 0113 33 "$ WTREAD SUBROUTINE 00E6 26,30$   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 100 00A7 11,14$$ 200 00BC 17,25$$ 250 00D1 20,23$$ 300 00E5 19,26$. 400 00F5 27,39,41,46,48 .( 430 0134 35,40,44 ($ 440 0142 36,42$( 450 0150 37,43,45 (. 900 015F 12,22,27,31,49 ." 1000 0166 49 "$ 1001 0185 17,52$" 2000 01A3 52 "$ 2001 01B3 24,54$$ 3000 01C2 40,55$$ 4000 00B5 15,16$ USEMTN 0000 1  t FTN 3.3B (OPT = LPC) UTFMTN PAGE 1 DATE: 08/29/84 TIME: 2314 t^ 1 PROGRAM UTFMTN C5100001^^ 1 1 /F51 F CCS CCS 3.1 LKL07 02-84 SL-149********^^ C C5100003^^ C CYBERCREDIT SYSTEM VERSION 3 C5100004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C5100005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C5100006^^ C C5100007^^ C C5100008^^ C***************************************************************138*A019C5100009^^ C C5100010^^ C C5100011^^ C UTILITY FILE MAINTENENCE PROGRAM. THIS PROGRAM PROCESSES C5100012^^ C REQUESTS TO ADD, DELETE, AND UPDATE ENTRIES IN THE INDEXED C5100013^^ C UTILITY FILE. THERE ARE THREE CLASSES OF RECORDS KEPT IN C5100014^^ C THE UTILITY FILE: C5100015^^ C 1) RECORDS NOT TO BE MODIFIED OR DELETED BY THIS UTILITY. C5100016^^ C AN EXAMPLE OF THIS TYPE OF RECORD IS THE 'ACTC' RECORD C5100017^^ C CONSTRUCTED BY AVMCON. C5100018^^ C 2) RECORDS WHICH ARE REQUIRED FOR OPERATION OF PORTIONS C5100019^^ C OF THE SYSTEM. ABSENCE OF THESE RECORDS ABNORMALLY C5100020^^ C TERMINATE OPERATION. AN EXAMPLE OF THIS WOULD BE THE C5100021^^ C 'OLPM' RECORD. WITHOUT IT, COLECT WOULD NOT RUN. C5100022^^ C 3) RECORDS WHICH ARE NEITHER PROTECTED OR REQUIRED AND C5100023^^ C CAN FREELY BE MODIFIED OR DELETED BY THIS UTILITY. C5100024^^ C THESE RECORDS ARE, OF COURSE, THE COLLECTOR IDENTIFI- C5100025^^ C CATION RECORDS. C5100026^^ C C5100027^^ C THE FOLLOWING TABLE WILL CLARIFY THE ALLOWED OPERATIONS FOR C5100028^^ C EACH CLASS OF RECORD: C5100029^^ C PERMITTED C5100030^^ C ADDITION DELETION UPDATE OPERATIONS C5100031^^ C TYPE ALLOWED ALLOWED ALLOWED INDICATOR (POP) C5100032^^ C ---- -------- -------- -------- --------------- C5100033^^ C C5100034^^ C 1 NO NO NO < 0 C5100035^^ C 2 YES NO YES = 0 C5100036^^ C 3 YES YES YES > 0 C5100037^  ^ C THE INFORMATION REGARDING RECORD KEYS HAVING RESTRICTIONS ARE C5100039^^ C KEPT IN THE TABLE 'KEYTAB'. EVERY KEY IN THE TABLE HAS C5100040^^ C THE FOLLOWING FOUR WORD ENTRY ASSOCIATED WITH IT. C5100041^^ C C5100042^^ C WORD MEANING C5100043^^ C ---- -------------------------- C5100044^^ C 1 FIRST TWO BYTES OF KEY C5100045^^ C 2 SECOND TWO BYTES OF KEY C5100046^^ C 3 PERMITTED OPERATIONS INDICATOR (POP) C5100047^^ C 4 ASSOCIATED FORMAT PROMPT FOR RECORD ENTRY C5100048^ ^ C THE LAST ENTRY REFERS TO THE INDEX IN A TABLE OF FORMATS C5100050^^ C WHICH IS TO BE OUTPUT FOR ADDITION AND UPDATES OF RECORDS C5100051^^ C AS A GUIDING PROMPT. THIS FORMAT LINE WILL APPEAR ABOVE ANY C5100052^^ C DATA ENTRY TO GUIDE THE USER AS TO FIELD FORMAT WITHIN THE C5100053^t FTN 3.3B (OPT = LPC) UTFMTN PAGE 2 DATE: 08/29/84 TIME: 2314 t^ C RECORD. FOR EXAMPLE, FOR THE 'OLPM' RECORD, THE FORMAT PROMPT C5100054^^ C WOULD BE: C5100055^^ C ' RL--,P--,C-- ' C5100056^^ C SHOWING THE USER WHICH COLUMNS THE DATA IS TO BE INPUT IN. C5100057^ ^ C FOR UPDATES, THE ENTRY OF DATA INTO THE RECORD WILL BE OVER C5100059^^ C THE EXISTING RECORD (WHICH IS DISPLAYED UNDER THE FORMAT LINE)C5100060^^ C SO THE USER NEED ONLY ENTER THE CHANGED INFORMATION. C5100061^   ^ C FILE MANAGER BUFFERS. C5100063^^ 2 INTEGER REQBUF(24) , IDATA(15) , RECBUF(42) , KEY(2) , SKEY(2) C5100064^^ 3 DATA REQBUF / 24*0 / C5100065^^ 4 DATA IDATA / 'UTIFIL ' , 4*$2020 , 1 , 1 , 1 / C5100066^  ^ C MESSAGE BUFFERS. C5100068^^ 5 INTEGER CS C5100069^^ 6 DATA CS / $1820 / ********^^ 7 INTEGER PGINOU(21) C5100071^^ 8 DATA PGINOU / $D0A , 'UTILITY FILE MODIFICATION PROGRAM IN ' , C5100072^^ 8 1 $D0A / C5100073^^ 9 INTEGER INOPER(37) C5100074^^ 10 DATA INOPER / $D0A , 'ENTER "UPD" TO ADD/UPDATE, "DEL" TO DELETE',C5100075^^ 10 1 ', OR CARRIAGE RETURN TO EXIT' , $D0A / C5100076^^ 11 INTEGER INVREQ(10) C5100077^^ 12 DATA INVREQ / $D0A , 'INVALID REQUEST ' , $D0A / C5100078^^ 13 INTEGER INKEY(19) C5100079^^ 14 DATA INKEY / $D0A , 'ENTER KEY OF RECORD TO XXXXXXXXXX ' , $D0A / C5100080^^ 15 INTEGER NOMOD(37) C5100081^^ 16 DATA NOMOD / $D0A , 'RECORD -XXXX- NOT FOR ADDITION, DELETION, ' ,C5100082^^ 16 1 'OR UPDATE THRU THIS PROGRAM ' , $D0A / C5100083^^ 17 INTEGER NODEL(24) C5100084^^ 18 DATA NODEL / $D0A , 'RECORD -XXXX- IS REQUIRED, CANNOT BE', C5100085^^ 18 1 ' DELETED' , $D0A / C5100086^^ 19 INTEGER NOREC(26) C5100087^^ 20 DATA NOREC / $D0A , 'RECORD -XXXX- DOES NOT EXIST, CANNOT BE ' , C5100088^^ 20 1 'DELETED ' , $D0A / C5100089^^ 21 INTEGER ADDSUC(18) , DELSUC(19) , UPDSUC(19) C5100090^^ 22 DATA ADDSUC / $D0A , 'RECORD -XXXX- ADDED SUCCESSFULLY' , $D0A / C5100091^^ 23 DATA DELSUC / $D0A , 'RECORD -XXXX- DELETED SUCCESSFULLY' , $D0A /C5100092^^ 24 DATA UPDSUC / $D0A , 'RECORD -XXXX- UPDATED SUCCESSFULLY' , $D0A /C5100093^  ^ C INPUT BUFFER FOR UPDATE AND OPERATION REQUESTS. C5100095^^ 25 INTEGER INBUF(39) C5100096^^ 26 EQUIVALENCE ( INCHAR , INBUF(39) ) C5100097^  ^ C BUFFER FOR FORMAT LINE OUTPUT. C5100099^^ 27 INTEGER FOROUT(40) C5100100^^ 28 DATA FOROUT / $D0A , 38*$2020 , $D0A / C5100101^ t FTN 3.3B (OPT = LPC) UTFMTN PAGE 3 DATE: 08/29/84 TIME: 2314 t ^ C LOGIN VARIABLES. C5100103^^ 29 INTEGER ID(4) , LU C5100104^ ^ C OPERATION CODE TABLES. C5100106^^ 30 INTEGER VALOP(4) , OPOUT(10) C5100107^^ 31 DATA VALOP / 'UPD DEL ' / C5100108^^ 32 DATA OPOUT / 'ADD/UPDATEDELETE ' / C5100109^ ^ C OTHER SMALL VARIABLES AND CONSTANTS. C5100111^^ 33 INTEGER OP , SVW23 , EOF , WRONKY , EOTAB , BLANK , TC , UPDFLG C5100112^^ 34 DATA EOF / $8100 / , WRONKY / $200 / , EOTAB / $2A2A / C5100113^^ C EOTAB IS END-OF-TABLE CODE FOR KEY TABLE. C5100114^^ 35 DATA BLANK / $2020 / C5100115^t FTN 3.3B (OPT = LPC) UTFMTN PAGE 4 DATE: 08/29/84 TIME: 2314 t^ C KEY TABLE CONTAINING RESTRICTED KEYS, POP, AND FORMAT C5100117^^ C INDICES. C5100118^^ 36 INTEGER KEYTAB(200) C5100119^^ 37 INTEGER KEY1(4) , KEY2(4) , KEY3(4) , KEY4(4) , KEY5(4) , C5100120^^ 37 1 KEY6(4) , KEY7(4) , KEY8(4) , KEY9(4) , KEY10(4) , C5100121^^ 37 2 KEY11(4) , KEY12(4) , KEY13(4) , KEY14(4) , KEY15(4) , C5100122^^ 37 3 KEY16(4) , KEY17(4) , KEY18(4) , KEY19(4) , KEY20(4) , C5100123^^ 37 4 KEY21(4) , KEY22(4) , KEY23(4) , KEY24(4) , KEY25(4) C5100124^^ 38 EQUIVALENCE ( KEYTAB( 1) , KEY1(1) ) , ( KEYTAB( 5) , KEY2(1) ),C5100125^^ 38 1 ( KEYTAB( 9) , KEY3(1) ) , ( KEYTAB(13) , KEY4(1) ),C5100126^^ 38 2 ( KEYTAB(17) , KEY5(1) ) , ( KEYTAB(21) , KEY6(1) ),C5100127^^ 38 3 ( KEYTAB(25) , KEY7(1) ) , ( KEYTAB(29) , KEY8(1) ),C5100128^^ 38 4 ( KEYTAB(33) , KEY9(1) ) , ( KEYTAB(37) , KEY10(1) ),C5100129^^ 38 5 ( KEYTAB(41) , KEY11(1) ) , ( KEYTAB(45) , KEY12(1) ),C5100130^^ 39 EQUIVALENCE ( KEYTAB(49) , KEY13(1) ) , ( KEYTAB(53) , KEY14(1) ),C5100131^^ 39 1 ( KEYTAB(57) , KEY15(1) ) , ( KEYTAB(61) , KEY16(1) ),C5100132^^ 39 2 ( KEYTAB(65) , KEY17(1) ) , ( KEYTAB(69) , KEY18(1) ),C5100133^^ 39 3 ( KEYTAB(73) , KEY19(1) ) , ( KEYTAB(77) , KEY20(1) ),C5100134^^ 39 4 ( KEYTAB(81) , KEY21(1) ) , ( KEYTAB(85) , KEY22(1) ),C5100135^^ 39 5 ( KEYTAB(89) , KEY23(1) ) , ( KEYTAB(93) , KEY24(1) ) C5100136^^ 40 EQUIVALENCE ( KEYTAB(97) , KEY25(1) ) C5100137^ ^ C KEY POP FORMAT C5100139^^ 41 DATA KEY1 / 'COID' , 1 , 1 / C5100140^^ C KEY1 IS DEFAULT WHEN KEY NOT FOUND ELSEWHERE IN TABLE. THIS C5100141^^ C IS THE COLLECTOR RECORDS IN THE FILE. C5100142^^ 42 DATA KEY2 / 'HDR1' , 0 , 2 / C5100143^^ 43 DATA KEY3 / 'HDR2' , 0 , 2 / C5100144^^ 44 DATA KEY4 / 'HDR3' , 0 , 2 / C5100145^^ 45 DATA KEY5 / 'RSW1' , 0 , 3 / C5100146^^ 46 DATA KEY6 / 'ACTC' , -1, 0 / C5100147^^ 47 DATA KEY7 / 'RESC' , -1, 0 / C5100148^^ 48 DATA KEY8 / 'SALC' , 0 , 4 / C5100149^^ 49 DATA KEY9 / 'DALT' , 0 , 5 / C5100150^^ 50 DATA KEY10 / 'SMTH' , 0 , 3 / C5100151^^ 51 DATA KEY11 / 'TMTH' , 0 , 6 / C5100152^^ 52 DATA KEY12 / 'UPDY' , 0 , 6 / C5100153^^ 53 DATA KEY13 / 'OLPM' , 0 , 7 / C5100154^^ 54 DATA KEY14 / 'LTRF' , 0 , 8 / C5100155^^ 55 DATA KEY15 / 'RPTG' , -1, 0 / C5100156^^ 56 DATA KEY16 / 'LTR1' , -1, 0 / C5100157^^ 57 DATA KEY17 / 'LTR2' , -1, 0 / C5100158^^ C ADD 'HOST,TRND,LTR3&4 RECORDS TO UTIFIL AND MAKE THEM PROTECTED... ********^^ 58 DATA KEY18 / 'LTR3' , -1, 0 / ********^^ 59 DATA KEY19 / 'LTR4' , -1, 0 / ********^^ 60 DATA KEY20 / 'HOST' , 0, 2 / ********^^ 61 DATA KEY21 / 'TRND' , 0, 2 / ********^^ 62 DATA KEY22 / '** ' , 0, 0 / ********^^ C REMAINING KEYS ARE OPEN AND AVAILABLE FOR FUTURE USE. C5100159^^ C NEXT TABLE ENTRY AFTER LAST ENTRY USED SHOULD HAVE THE END- C5100160^^ C OF-TABLE CODE (EOTAB) IN FIRST WORD. C5100161^^ C **** ********^^ 63 DATA KEY23 / ' ' , 0 , 0 / C5100167^^ 64 DATA KEY24 / ' ' , 0 , 0 / C5100168^t FTN 3.3B (OPT = LPC) UTFMTN PAGE 5 DATE: 08/29/84 TIME: 2314 t^ 65 DATA KEY25 / ' ' , 0 , 0 / C5100169^t FTN 3.3B (OPT = LPC) UTFMTN PAGE 6 DATE: 08/29/84 TIME: 2314 t^ C FORMAT TABLE AND POINTER. C5100171^^ 66 INTEGER FORMAT(950) , FPTR C5100172^^ 67 INTEGER FM1(38) , FM2(38) , FM3(38) , FM4(38) , FM5(38) , C5100173^^ 67 1 FM6(38) , FM7(38) , FM8(38) , FM9(38) , FM10(38) , C5100174^^ 67 2 FM11(38) , FM12(38) , FM13(38) , FM14(38) , FM15(38) , C5100175^^ 67 3 FM16(38) , FM17(38) , FM18(38) , FM19(38) , FM20(38) , C5100176^^ 67 4 FM21(38) , FM22(38) , FM23(38) , FM24(38) , FM25(38) C5100177^ ^ 68 EQUIVALENCE ( FORMAT( 1) , FM1(1) ) , ( FORMAT( 39) , FM2(1) ),C5100179^^ 68 1 ( FORMAT( 77) , FM3(1) ) , ( FORMAT(115) , FM4(1) ),C5100180^^ 68 2 ( FORMAT(153) , FM5(1) ) , ( FORMAT(191) , FM6(1) ),C5100181^^ 68 3 ( FORMAT(229) , FM7(1) ) , ( FORMAT(267) , FM8(1) ),C5100182^^ 68 4 ( FORMAT(305) , FM9(1) ) , ( FORMAT(343) , FM10(1) ),C5100183^^ 68 5 ( FORMAT(381) , FM11(1) ) , ( FORMAT(419) , FM12(1) ),C5100184^^ 69 EQUIVALENCE ( FORMAT(457) , FM13(1) ) , ( FORMAT(495) , FM14(1) ),C5100185^^ 69 1 ( FORMAT(533) , FM15(1) ) , ( FORMAT(571) , FM16(1) ),C5100186^^ 69 2 ( FORMAT(609) , FM17(1) ) , ( FORMAT(647) , FM18(1) ),C5100187^^ 69 3 ( FORMAT(685) , FM19(1) ) , ( FORMAT(723) , FM20(1) ),C5100188^^ 69 4 ( FORMAT(761) , FM21(1) ) , ( FORMAT(799) , FM22(1) ),C5100189^^ 69 5 ( FORMAT(837) , FM23(1) ) , ( FORMAT(875) , FM24(1) ),C5100190^^ 70 EQUIVALENCE ( FORMAT(913) , FM25(1) ) C5100191^ ^ 71 DATA FM1 / 'NAME ISPHONE EXT CSUP QUEUES... ' , C5100193^^ 71 1 15*$2020 / C5100194^^ C FM1 IS DEFAULT FORMAT FOR KEYS NOT FOUND IN TABLE. IT IS C5100195^^ C THE COLLECTOR RECORD FORMAT. C5100196^^ 72 DATA FM2 / 20*'--' , 18*$2020 / C5100197^^ 73 DATA FM3 / 'R---,S---,W---' , 31*$2020 / C5100198^^ 74 DATA FM4 / 'CODE1 CODE2 CODE3 CODE4 CODE5 CODE6 ' , C5100199^^ 74 1 'CODE7 CODE8 CODE9 ' , 3*$2020 / C5100200^^ 75 DATA FM5 / '---,QUE =---,QUE =---,QUE =---,QUE =---,QUE =---,Q' ,C5100201^^ 75 2 'UE =--- ' , 9*$2020 / C5100202^^ 76 DATA FM6 / '--- ' , 36*$2020 / C5100203^^ 77 DATA FM7 / 'RL--,P--,C--,NA-', 30*$2020 / C5100204^^ 78 DATA FM8 / 'N-------------------------' , 25*$2020 / C5100205^^ C REMAINING FORMAT DEFINITIONS ARE AVAILABLE FOR FUTURE USE. C5100206^^ 79 DATA FM9 / 38*$2020 / C5100207^^ 80 DATA FM10 / 38*$2020 / C5100208^^ 81 DATA FM11 / 38*$2020 / C5100209^^ 82 DATA FM12 / 38*$2020 / C5100210^^ 83 DATA FM13 / 38*$2020 / C5100211^^ 84 DATA FM14 / 38*$2020 / C5100212^^ 85 DATA FM15 / 38*$2020 / C5100213^^ 86 DATA FM16 / 38*$2020 / C5100214^^ 87 DATA FM17 / 38*$2020 / C5100215^^ 88 DATA FM18 / 38*$2020 / C5100216^^ 89 DATA FM19 / 38*$2020 / C5100217^^ 90 DATA FM20 / 38*$2020 / C5100218^^ 91 DATA FM21 / 38*$2020 / C5100219^^ 92 DATA FM22 / 38*$2020 / C5100220^^ 93 DATA FM23 / 38*$2020 / C5100221^^ 94 DATA FM24 / 38*$2020 / C5100222^^ 95 DATA FM25 / 38*$2020 / C5100223^t FTN 3.3B (OPT = LPC) UTFMTN PAGE 7 DATE: 08/29/84 TIME: 2314 t^ C SET UP FOR PROCESSING. RETRIEVE PROGRAM INFORMATION AND C5100225^^ C OPEN UTILITY FILE. C5100226^^ 96 50 CALL PGMIN ( ID , LU , I , J ) C5100227^^ 97 CALL OPENFL ( REQBUF , IDATA , ISTAT ) C5100228^^ C OPEN REQUEST SUCCESSFUL? C5100229^^ 98 IF ( ISTAT .LT. 0 ) GO TO 800 C5100230^^ C YES. CLEAR SCREEN AND WRITE PROGRAM IN MESSAGE. C5100231^^ 99 CALL WTREAD ( LU , -1 , CS , 2 , 0 , 0 , 0 , TC ) C5100232^^ 100 CALL WTREAD ( LU , -1 , PGINOU , 42 , 0 , 0 , 0 , TC ) C5100233^ ^ C RETRIEVE NEXT OPERATION REQUEST. C5100235^^ 101 100 CALL CCSBLK( INBUF, 76 ) ********^^ 102 CALL WTREAD( LU, -1, INOPER, 74, -1, INBUF, 76, TC ) ********^^ C ** CHECK FOR RUBOUT IF IT IS REPEAT REQUEST. ********^^ 103 IF ( TC.EQ.04 ) GO TO 100 ********^^ C ** CHECK IF NO CHARS ENTERED ********^^ 104 IF ( INCHAR.EQ.0 ) GO TO 900 ********^^ C SCAN TABLE OF VALID OPERATION CODES. C5100244^^ 105 DO 110 OP = 1 , 2 C5100245^^ 106 J = 2*OP - 1 C5100246^^ 107 IF ( VALOP(J) .EQ. INBUF(1) .AND. C5100247^^ 107 1 VALOP(J+1) .EQ. INBUF(2) ) GO TO 120 C5100248^^ 108 110 CONTINUE C5100249^ ^ C INVALID OPERATION REQUESTED. REPORT ERROR AND PROMPT AGAIN. C5100251^^ 109 CALL WTREAD ( LU , -1 , INVREQ , 20 , 0 , 0 , 0 , TC ) C5100252^^ 110 GO TO 100 C5100253^ ^ C VALID OPERATION. PROMPT FOR KEY. C5100255^^ 111 120 J = 10*OP - 9 C5100256^^ 112 CALL CCSMVA ( OPOUT , J , 10 , INKEY , 26 , 10 ) C5100257^^ 113 125 CALL CCSBLK( INBUF, 76 ) ********^^ 114 CALL WTREAD( LU, -1, INKEY, 38, -1, INBUF,76, TC ) ********^^ 115 IF ( TC.EQ.04 ) GO TO 125 ********^^ 116 CALL CCSMVA( INBUF,1,4,KEY,1,4 ) ********^ ^ C SCAN TABLE FOR THIS KEY. START SEARCH WITH SECOND ENTRY IN C5100264^^ C TABLE SINCE FIRST IS DEFAULT FOR COLLECTOR RECORD ENTRIES. C5100265^^ 117 DO 130 KINDEX = 5 , 100 , 4 C5100266^^ C END-OF-TABLE? C5100267^^ 118 IF ( KEYTAB(KINDEX) .EQ. EOTAB ) GO TO 140 C5100268^^ C NO, CHECK FOR A MATCH. C5100269^^ 119 IF ( KEYTAB(KINDEX) .EQ. KEY(1) .AND. C5100270^^ 119 1 KEYTAB(KINDEX+1) .EQ. KEY(2) ) GO TO 200 C5100271^^ C NO MATCH, CONTINUE SCAN. C5100272^^ 120 130 CONTINUE C5100273^ ^ C ENTRY NOT FOUND IN TABLE. TREAT AS COLLECTOR RECORD. C5100275^^ 121 140 KINDEX = 1 C5100276^^ 122 GO TO 220 C5100277^t FTN 3.3B (OPT = LPC) UTFMTN PAGE 8 DATE: 08/29/84 TIME: 2314 t^ C MATCH FOR KEY FOUND IN TABLE. VERIFY OPERATION REQUESTED IS C5100279^^ C VALID ACCORDING TO PERMITTED OPERATIONS WORD (POP) FOR THIS C5100280^^ C KEY. C5100281^ ^ C NO OPERATIONS ALLOWED IF RECORD USAGE NOT ALLOWED THRU THIS C5100283^^ C PROGRAM ( POP < 0 ). C5100284^^ 123 200 IF ( KEYTAB(KINDEX+2) .GE. 0 ) GO TO 210 C5100285^^ C NO OPERATIONS ALLOWED. C5100286^^ 124 NOMOD(6) = KEY(1) C5100287^^ 125 NOMOD(7) = KEY(2) C5100288^^ 126 CALL WTREAD ( LU , -1 , NOMOD , 74 , 0 , 0 , 0 , TC ) C5100289^^ 127 GO TO 100 C5100290^ ^ C NO DELETE OPERATION ALLOWED IF RECORD REQUIRED TO BE PRESENT C5100292^^ C IN FILE AND MODIFIABLE THRU THIS PROGRAM ( POP = 0 ). C5100293^^ 128 210 IF ( KEYTAB(KINDEX+2) .NE. 0 .OR. OP .NE. 2 ) GO TO 220 C5100294^^ C DELETION NOT ALLOWED. C5100295^^ 129 NODEL(6) = KEY(1) C5100296^^ 130 NODEL(7) = KEY(2) C5100297^^ 131 CALL WTREAD ( LU , -1 , NODEL , 48 , 0 , 0 , 0 , TC ) C5100298^^ 132 GO TO 100 C5100299^ ^ C HAVE VALID OPERATION ON KEY RECORD SUPPLIED. ATTEMPT C5100301^^ C RETRIEVAL OF THAT RECORD. C5100302^^ 133 220 SKEY(1) = KEY(1) C5100303^^ 134 SKEY(2) = KEY(2) C5100304^^ 135 CALL READR ( REQBUF , RECBUF , SKEY , ISTAT ) C5100305^^ C FATAL FILE ERROR? C5100306^^ 136 IF ( ISTAT .LT. 0 .AND. AND( ISTAT , EOF ) .NE. EOF ) C5100307^^ 136 1 GO TO 810 C5100308^ ^ C NO ERROR. JUMP TO PROCESS ON THE BASIS OF OPERATION ENTRY. C5100310^^ 137 IF ( OP .EQ. 1 ) GO TO 400 C5100311^t FTN 3.3B (OPT = LPC) UTFMTN PAGE 9 DATE: 08/29/84 TIME: 2314 t^ C DELETE OPERATION. C5100313^  ^ C CANNOT DELETE IF RECORD DOES NOT EXIST. C5100315^^ C DOES RECORD EXIST? C5100316^^ 138 300 IF ( AND( ISTAT , EOF ) .NE. EOF .AND. C5100317^^ 138 1 AND( ISTAT , WRONKY ) .NE. WRONKY ) GO TO 310 C5100318^^ C NO, RECORD NOT FOUND. REPORT ERROR AND GET NEXT REQUEST. C5100319^^ 139 NOREC(6) = KEY(1) C5100320^^ 140 NOREC(7) = KEY(2) C5100321^^ 141 CALL WTREAD ( LU , -1 , NOREC , 52 , 0 , 0 , 0 , TC ) C5100322^^ 142 GO TO 100 C5100323^  ^ C RECORD FOUND, DELETE. C5100325^^ 143 310 CALL DELREC ( REQBUF , RECBUF , ISTAT ) C5100326^^ C DELETE SUCCESSFUL? C5100327^^ 144 IF ( ISTAT .LT. 0 ) GO TO 830 C5100328^^ C YES, REPORT SUCCESSFUL DELETE AND GET NEXT REQUEST. C5100329^^ 145 DELSUC(6) = KEY(1) C5100330^^ 146 DELSUC(7) = KEY(2) C5100331^^ 147 CALL WTREAD ( LU , -1 , DELSUC , 38 , 0 , 0 , 0 , TC ) C5100332^^ 148 GO TO 100 C5100333^t FTN 3.3B (OPT = LPC) UTFMTN PAGE 10 DATE: 08/29/84 TIME: 2314 t^ C ADD/UPDATE OPERATION. C5100335^  ^ C IF RECORD IS NOT PRESENT IN FILE, THEN REQUEST IS AN ADD. IF C5100337^^ C RECORD IS PRESENT, REQUEST IS AN UPDATE. C5100338^^ C SET FLAG FOR UPDATE REQUEST AND CHECK IF RECORD FOUND. C5100339^^ 149 400 UPDFLG = 1 C5100340^^ 150 IF ( AND( ISTAT , EOF ) .NE. EOF .AND. C5100341^^ 150 1 AND( ISTAT , WRONKY ) .NE. WRONKY ) GO TO 410 C5100342^^ C NO, RECORD NOT FOUND. SET FLAG TO INDICATE ADD OPERATION AND C5100343^^ C SET UP RECORD BUFFER FOR ADD. (BLANK AND MOVE IN KEY). C5100344^^ 151 UPDFLG = 0 C5100345^^ 152 CALL CCSBLK ( RECBUF(3) , 76 ) C5100346^^ 153 RECBUF(1) = KEY(1) C5100347^^ 154 RECBUF(2) = KEY(2) C5100348^  ^ C DETERMINE FORMAT FOR RECORD PROMPT (POINTER C5100350^^ C INTO FORMAT ARRAY). PRINT FORMAT LINE AND OLD RECORD C5100351^^ C CONTENTS AND RECEIVE INPUT FOR CHANGES TO RECORD. C5100352^^ 155 410 FPTR = 76*KEYTAB(KINDEX+3) - 75 C5100353^^ 156 CALL CCSMVA ( FORMAT , FPTR , 76 , FOROUT , 3 , 76 ) C5100354^^ 157 CALL WTREAD ( LU , -1 , FOROUT , 80 , 0 , 0 , 0 , TC ) C5100355^^ 158 RECBUF(41) = $D C5100356^^ 159 415 CALL WTREAD ( LU , -1 , RECBUF(3) , 78 , -1 , INBUF , 76 , TC ) C5100357^^ C IF RUBOUT, REPEAT ENTER REQUEST. C5100358^^ 160 IF ( TC .EQ. 4 ) GO TO 410 C5100359^ ^ C IF NO INPUT, ADD/UPDATE OPERATION ABORTED. DO NOT PERFORM C5100361^^ C FILE WRITE OR OUTPUT COMPLETED MESSAGE. INSTEAD, GET NEXT C5100362^^ C REQUEST. C5100363^^ 161 IF ( INCHAR .EQ. 0 ) GO TO 100 C5100364^ ^ C INPUT CHANGES RECEIVED. MERGE INTO FILE RECORD BUFFER, WITH C5100366^^ C ANY ENTRY <$20 OR >$5A FROM INBUF NOT OVERLAYING CONTENTS C5100367^^ C OF RECORD BUFFER. C5100368^^ 162 DO 420 I = 1 , INCHAR C5100369^^ 163 CALL CCSGET ( INBUF , I , J ) C5100370^^ 164 IF ( J .GE. $ 20 .AND. J .LE. $5B ) C5100371^^ 164 1 CALL CCSPUT ( J , I , RECBUF(3) ) C5100372^^ 165 420 CONTINUE C5100373^ ^ C MERGE COMPLETE. PERFORM WRITER/UPDREC REQUEST DEPENDING ON C5100375^^ C OPERATION. CHECK FOR ADD. C5100376^^ 166 IF ( UPDFLG .EQ. 0 ) GO TO 430 C5100377^ ^ C UPDATE OPERATION. UPDATE RECORD IN FILE. C5100379^^ 167 CALL UPDREC ( REQBUF , RECBUF , ISTAT ) C5100380^^ C UPDATE SUCCESSFUL? C5100381^^ 168 IF ( ISTAT .LT. 0 ) GO TO 840 C5100382^^ C YES, REPORT AND GET NEXT REQUEST. C5100383^^ 169 UPDSUC(6) = KEY(1) C5100384^^ 170 UPDSUC(7) = KEY(2) C5100385^^ 171 CALL WTREAD ( LU , -1 , UPDSUC , 38 , 0 , 0 , 0 , TC ) C5100386^t FTN 3.3B (OPT = LPC) UTFMTN PAGE 11 DATE: 08/29/84 TIME: 2314 t^ 172 GO TO 100 C5100387^ ^ C ADD OPERATION. ADD RECORD TO FILE. C5100389^^ 173 430 CALL WRITER ( REQBUF , RECBUF , KEY , ISTAT ) C5100390^^ C FILE ERROR? C5100391^^ 174 IF ( ISTAT .LT. 0 ) GO TO 820 C5100392^^ C NO. REPORT SUCCESSFUL ADD AND GET NEXT REQUEST. C5100393^^ 175 ADDSUC(6) = KEY(1) C5100394^^ 176 ADDSUC(7) = KEY(2) C5100395^^ 177 CALL WTREAD ( LU , -1 , ADDSUC , 36 , 0 , 0 , 0 , TC ) C5100396^^ 178 GO TO 100 C5100397^t FTN 3.3B (OPT = LPC) UTFMTN PAGE 12 DATE: 08/29/84 TIME: 2314 t^ C FILE ERROR PROCESSING. C5100399^ ^ C OPENFL REQUEST. C5100401^^ 179 800 J = 3 C5100402^^ 180 GO TO 850 C5100403^ ^ C READR REQUEST. C5100405^^ 181 810 J = 13 C5100406^^ 182 GO TO 850 C5100407^ ^ C WRITER REQUEST. C5100409^^ 183 820 J = 12 C5100410^^ 184 GO TO 850 C5100411^ ^ C DELREC REQUEST. C5100413^^ 185 830 J = 16 C5100414^^ 186 GO TO 850 C5100415^ ^ C UPDREC REQUEST. C5100417^^ 187 840 J = 15 C5100418^ ^ C OUTPUT ERROR MESSAGE. C5100420^^ 188 850 CALL FILERR ( IDATA , J , ISTAT , LU ) C5100421^   ^ C WRITE PROGRAM OUT MESSAGE, CLOSE UTILITY FILE, AND EXIT. C5100423^^ 189 900 PGINOU(19) = $4F55 ********^^ 190 PGINOU(20) = $5420 ********^^ 191 CALL WTREAD ( LU , -1 , PGINOU , 42 , 0 , 0 , 0 , TC ) C5100426^^ 192 CALL CLOSFL ( REQBUF , ISTAT ) C5100427^^ 193 CALL PGMOUT C5100428^^ 194 STOP C5100429^^ 195 END C5100430^t FTN 3.3B (OPT = LPC) UTFMTN PAGE 13 DATE: 08/29/84 TIME: 2314 t  PROGRAM LENGTH $0837 ( 2103)   EXTERNALS 2 Q8STP PGMIN OPENFL WTREAD CCSBLK CCSMVA READR 22 DELREC CCSGET CCSPUT UPDREC WRITER FILERR CLOSFL 2 PGMOUT  t FTN 3.3B (OPT = LPC) UTFMTN PAGE 14 DATE: 08/29/84 TIME: 2314 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < V FFFE (-1) 062B 99,100,102,109,114,126,131,141,147,157,159,171,177,191 V€ 0000 (0) 0003 3,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,98,99,100,104,109,123, €^ 126,128,131,136,141,144,147,151,157,161,166,168,171,174,177,191^‚ 0001 (1) 0002 4,38,39,40,41,46,47,55,56,57,58,59,68,69,70,99,100,102,105,106,107,109,114,116,119,121,124,126,129 ‚d ,131,133,137,139,141,145,147,149,153,157,159,162,169,171,175,177,191 dZ 0002 (2) 062C 99,105,106,107,119,123,125,128,130,134,140,146,154,170,176 Z. 0003 (3) 0638 156,159,164,179.2 0004 (4) 0630 103,115,116,117,1602& 000A (10) 0632 111,112&& 0014 (20) 0631 109,190&" 001A (26) 0633 112"" 0024 (36) 063B 177"* 0026 (38) 0634 114,147,171*& 002A (42) 062D 100,191&" 0030 (48) 0636 131"" 0034 (52) 0637 141"& 004A (74) 062F 102,126&> 004C (76) 062E 101,102,113,114,152,155,156,159>" 004E (78) 063A 159"" 0050 (80) 0639 157"" 4F55 (20309) 063C 189"" 5420 (21536) 063D 190"   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < 0 ADDSUC INTEGER 0108 20,22,175,176,1770* AND INTR.FN. 7FFF 136,138,150*$ BLANK INTEGER 01A6 32,35$& CS INTEGER 0059 4,6,99 &0 DELSUC INTEGER 011A 20,23,145,146,14700 EOF INTEGER 01A3 32,34,136,138,1500( EOTAB INTEGER 01A5 32,34,118(( FM1 INTEGER 0271 65,68,71 (( FM10 INTEGER 03C7 65,68,80 (( FM11 INTEGER 03ED 65,68,81 (( FM12 INTEGER 0413 65,68,82 (( FM13 INTEGER 0439 65,69,83 (( FM14 INTEGER 045F 65,69,84 (( FM15 INTEGER 0485 65,69,85 (( FM16 INTEGER 04AB 65,69,86 (( FM17 INTEGER 04D1 65,69,87 (( FM18 INTEGER 04F7 65,69,88 (t FTN 3.3B (OPT = LPC) UTFMTN PAGE 15 DATE: 08/29/84 TIME: 2314 t( FM19 INTEGER 051D 65,69,89 (( FM2 INTEGER 0297 65,68,72 (( FM20 INTEGER 0543 65,69,90 (( FM21 INTEGER 0569 65,69,91 (( FM22 INTEGER 058F 65,69,92 (( FM23 INTEGER 05B5 65,69,93 (( FM24 INTEGER 05DB 65,69,94 (( FM25 INTEGER 0601 65,70,95 (( FM3 INTEGER 02BD 65,68,73 (( FM4 INTEGER 02E3 65,68,74 (( FM5 INTEGER 0309 65,68,75 (( FM6 INTEGER 032F 65,68,76 (( FM7 INTEGER 0355 65,68,77 (( FM8 INTEGER 037B 65,68,78 (( FM9 INTEGER 03A1 65,68,79 (. FORMAT INTEGER 0271 65,68,69,70,156., FOROUT INTEGER 0167 26,28,156,157,* FPTR INTEGER 0627 65,155,156 *. I INTEGER 0628 96,162,163,164 .$ ID INTEGER 018F 28,96$* IDATA INTEGER 001C 1,4,97,188 *D INBUF INTEGER 0140 24,26,101,102,107,113,114,116,159,163D. INCHAR INTEGER 0166 24,104,161,162 ., INKEY INTEGER 009E 12,14,112,114,( INOPER INTEGER 006F 8,10,102 (( INVREQ INTEGER 0094 10,12,109(T ISTAT INTEGER 062A 97,98,135,136,138,143,144,150,167,168,173,174,188,192TR J INTEGER 0629 96,106,107,111,112,163,164,179,181,183,185,187,188 Rl KEY INTEGER 0055 1,116,119,124,125,129,130,133,134,139,140,145,146,153,154,169,170,173,175,176l( KEY1 INTEGER 01A9 35,38,41 (( KEY10 INTEGER 01CD 35,38,50 (( KEY11 INTEGER 01D1 35,38,51 (( KEY12 INTEGER 01D5 35,38,52 (( KEY13 INTEGER 01D9 35,39,53 (( KEY14 INTEGER 01DD 35,39,54 (( KEY15 INTEGER 01E1 35,39,55 (( KEY16 INTEGER 01E5 35,39,56 (( KEY17 INTEGER 01E9 35,39,57 (( KEY18 INTEGER 01ED 35,39,58 (( KEY19 INTEGER 01F1 35,39,59 (( KEY2 INTEGER 01AD 35,38,42 (( KEY20 INTEGER 01F5 35,39,60 (( KEY21 INTEGER 01F9 35,39,61 (( KEY22 INTEGER 01FD 35,39,62 (( KEY23 INTEGER 0201 35,39,63 (( KEY24 INTEGER 0205 35,39,64 (( KEY25 INTEGER 0209 35,40,65 (( KEY3 INTEGER 01B1 35,38,43 (( KEY4 INTEGER 01B5 35,38,44 (( KEY5 INTEGER 01B9 35,38,45 (( KEY6 INTEGER 01BD 35,38,46 (( KEY7 INTEGER 01C1 35,38,47 (( KEY8 INTEGER 01C5 35,38,48 (( KEY9 INTEGER 01C9 35,38,49 (t FTN 3.3B (OPT = LPC) UTFMTN PAGE 16 DATE: 08/29/84 TIME: 2314 t> KEYTAB INTEGER 01A9 35,38,39,40,118,119,123,128,155>: KINDEX INTEGER 0635 116,118,119,121,123,128,155:` LU INTEGER 0193 28,96,99,100,102,109,114,126,131,141,147,157,159,171,177,188,191 `0 NODEL INTEGER 00D6 16,18,129,130,13100 NOMOD INTEGER 00B1 14,16,124,125,12600 NOREC INTEGER 00EE 18,20,139,140,14106 OP INTEGER 01A2 32,105,106,111,128,137 6( OPOUT INTEGER 0198 28,32,112(2 PGINOU INTEGER 005A 6,8,100,189,190,1912H RECBUF INTEGER 002B 1,135,143,152,153,154,158,159,164,167,173H: REQBUF INTEGER 0004 1,3,97,135,143,167,173,192 :, SKEY INTEGER 0057 1,133,134,135,d TC INTEGER 01A7 32,99,100,102,103,109,114,115,126,131,141,147,157,159,160,171,177,191d. UPDFLG INTEGER 01A8 32,149,151,166 .0 UPDSUC INTEGER 012D 20,24,169,170,1710( VALOP INTEGER 0194 28,31,107(, WRONKY INTEGER 01A4 32,34,138,150,   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < * CCSBLK SUBROUTINE 0779 100,113,152*" CCSGET SUBROUTINE 07BB 162"* CCSMVA SUBROUTINE 078B 111,116,156*" CCSPUT SUBROUTINE 07C7 164"" CLOSFL SUBROUTINE 0830 191"" DELREC SUBROUTINE 074D 143"" FILERR SUBROUTINE 0818 188"" OPENFL SUBROUTINE 0645 96 "" PGMIN SUBROUTINE 063F 95 "" PGMOUT SUBROUTINE 0834 192" Q8STP INTEGER.FN. 0836 " READR SUBROUTINE 071A 134"" UPDREC SUBROUTINE 07D2 166"" WRITER SUBROUTINE 07EF 173"V WTREAD SUBROUTINE 0826 98,100,102,109,114,126,131,141,147,157,159,171,177,191 V   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < " 50 063E 95 "F 100 0661 100,103,110,127,132,142,148,161,172,178F& 110 068D 104,108&& 120 069C 107,111&& 125 06A8 112,115&& 130 06D6 116,120&& 140 06DD 118,121&& 200 06E0 119,123&t FTN 3.3B (OPT = LPC) UTFMTN PAGE 17 DATE: 08/29/84 TIME: 2314 t& 210 06F8 123,128&* 220 0713 121,128,133*" 300 072F 137"& 310 074C 138,143&& 400 0769 137,149&* 410 0782 150,155,160*" 415 079F 158"& 420 07CB 161,165&& 430 07EE 166,173&& 800 0809 98,179 && 810 080C 136,181&& 820 080F 174,183&& 830 0812 144,185&& 840 0815 168,187&2 850 0817 179,182,184,186,1882& 900 081D 104,189& UTFMTN 0000 1  t FTN 3.3B (OPT = LPC) UTHEAD PAGE 1 DATE: 08/29/84 TIME: 2316 t^ 1 SUBROUTINE UTHEAD ( HD , DATE ) C5200001^^ 1 1 /C52 F CCS CCS 3.0 .LA SL-149********^^ C C5200003^^ C CYBERCREDIT SYSTEM VERSION 3 C5200004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C5200005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C5200006^^ C C5200007^ ^ C THIS SUBROUTINE PICKS UP THE THREE LINES OF CUSTOMER C5200009^^ C INFORMATION FOR REPORT HEADINGS AND RETURNS THEM IN THE C5200010^^ C ARRAY 'HD'. IF AN ERROR OCCURS THEY ARE RETURNED BLANK C5200011^^ C FILLED. C5200012^^ C IT ALSO PICKS UP THE SYSTEM DATE IN ASCII AND RETURNS IT C5200013^ ^ 2 INTEGER HD(20,3),UDATA(15),UREQ(24),UREC(40),KEY(2),DATE(3) C5200015^^ 3 INTEGER KEYVAL(2) ***00016^ ^ 4 EXTERNAL AYERTO,AMONTO,ADAYTO C5200018^ ^ 5 DATA KEY / 'HDR0' / C5200020^^ 6 DATA KEYVAL /'HDR0'/ ***00021^^ 7 DATA UDATA / 'LAUTIFIL', 8*$2020, 1, 1, 0 / ********^^ 8 DATA I1PS /0/ ********^ ^ 9 IF( I1PS.NE.0 ) RETURN ********^^ 10 I1PS = 1 ********^^ 11 CALL PGMIN(UREC,ISTAT,ISTAT,ISTAT) ********^^ 12 CALL CCSCST(UDATA,1,2,UREC,1,8,ISTAT) ********^^ 13 IF(ISTAT.NE.0) CALL CCSMVA(UDATA,3,6,UDATA,1,8) ********^ ^ C PICK UP AND SAVE THE SYSTEM DATE C5200024^^ 14 DATE(1)=AND(AMONTO,$FFFF) C5200025^^ 15 DATE(2)=AND(ADAYTO,$FFFF) C5200026^^ 16 DATE(3)=AND(AYERTO,$FFFF) C5200027^^ C INITIALIZE UREQ TO ZEROS ***00028^^ 17 DO 50 I = 1,24 ***00029^^ 18 UREQ(I) = 2*0 ***00030^^ 19 50 CONTINUE ***00031^^ C INITIALIZE KEY FIELD TO HDR0 (FOR MULTIPLE CALLS) ***00032^^ 20 CALL CCSMVA (KEYVAL,1,2,KEY,1,4) ***00033^ ^ C BLANK OUT THE HEADING ARRAY C5200035^^ 21 DO 100 I=1,20 C5200036^^ 22 HD(I,1)=$2020 C5200037^^ 23 HD(I,2)=$2020 C5200038^^ 24 100 HD(I,3)=$2020 C5200039^ ^ C OPEN THE UTIFIL FILE FOR USE C5200041^^ 25 CALL OPENFL (UREQ,UDATA,ISTAT) C5200042^^ 26 IF (ISTAT.LT.0) RETURN C5200043^ ^ C RETREIVE THE HEADINGS C5200045^^ 27 DO 200 I=1,3 C5200046^^ 28 KEY(2)=KEY(2)+1 C5200047^t FTN 3.3B (OPT = LPC) UTHEAD PAGE 2 DATE: 08/29/84 TIME: 2316 t^ 29 CALL READR (UREQ,UREC,KEY,ISTAT) C5200048^^ 30 IF (ISTAT.LT.0) GO TO 250 C5200049^^ 31 DO 150 J=1,20 C5200050^^ 32 150 HD(J,I)=UREC(J+2) C5200051^^ 33 200 CONTINUE C5200052^^ C CLOSE THE FILE AND RETURN C5200053^^ 34 250 CALL CLOSFL (UREQ,ISTAT) C5200054^^ 35 RETURN C5200055^^ 36 END C5200056^t FTN 3.3B (OPT = LPC) UTHEAD PAGE 3 DATE: 08/29/84 TIME: 2316 t  PROGRAM LENGTH $0103 ( 259)   EXTERNALS 2 Q8PKUP Q8PREP AYERTO AMONTO ADAYTO PGMIN CCSCST 2 CCSMVA OPENFL READR CLOSFL  t FTN 3.3B (OPT = LPC) UTHEAD PAGE 4 DATE: 08/29/84 TIME: 2316 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < ( FFFF (65535) 005B 14,15,16 (0 0000 (0) 0001 7,8,9,13,18,26,300B 0001 (1) 0000 7,10,12,13,14,17,20,21,22,27,28,31 B4 0002 (2) 0057 12,15,18,20,23,28,32 4* 0003 (3) 0059 13,16,24,27*" 0004 (4) 005D 20 "" 0006 (6) 005A 13 "$ 0008 (8) 0058 12,13$( 2020 (8224) 005E 22,23,24 (   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < ( AND INTR.FN. 7FFF 14,15,16 (, DATE INTEGER 7FFF 1,2,14,15,16 ,. HD INTEGER 7FFF 1,2,22,23,24,32.6 I INTEGER 005C 16,18,21,22,23,24,27,326& I1PS INTEGER 0055 7,9,10 &: ISTAT INTEGER 0056 11,11,12,13,25,26,29,30,34 :$ J INTEGER 005F 30,32$, KEY INTEGER 0051 2,5,20,28,29 ,& KEYVAL INTEGER 0053 2,6,20 &, UDATA INTEGER 0002 2,7,12,13,25 ,, UREC INTEGER 0029 2,11,12,29,32,, UREQ INTEGER 0011 2,18,25,29,34,   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < " CCSCST SUBROUTINE 006E 11 "$ CCSMVA SUBROUTINE 007A 13,20$" CLOSFL SUBROUTINE 00DD 34 "" OPENFL SUBROUTINE 00B0 24 "" PGMIN SUBROUTINE 0068 10 " Q8PKUP INTEGER.FN. 00F1 Q8PREP INTEGER.FN. 00EE " READR SUBROUTINE 00BC 28 "t FTN 3.3B (OPT = LPC) UTHEAD PAGE 5 DATE: 08/29/84 TIME: 2316 t   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 50 0095 16,19$$ 100 00A7 20,24$$ 150 00C7 30,32$$ 200 00D6 26,33$$ 250 00DC 30,34$ UTHEAD 00EB 1  t FTN 3.3B (OPT = LPC) VALDT1 PAGE 1 DATE: 08/29/84 TIME: 2316 t^ 1 SUBROUTINE VALDT1 (TABLE, COID) C5300001^^ 1 1 /C53 F CCS CCS 3.0 SL-149C5300002^^ C C5300003^^ C CYBERCREDIT SYSTEM VERSION 3 C5300004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C5300005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C5300006^^ C C5300007^^ C RETURN COLLECTOR ID C5300008^^ 2 INTEGER TABLE(10), COID(2), ONE C5300009^^ C EQU FIRST 10 WORDS OF TABLE FOR GLOBAL INDICATORS C5300010^^ 3 EQUIVALENCE (INIT,TABLE(3)), (ITBLEN,TABLE(2)), C5300011^^ 3 * (ITYP,TABLE(4)), (ICTST,TABLE(5)), C5300012^^ 3 * (ICPRM,TABLE(6)) C5300013^^ 4 DATA ONE/'01'/ C5300014^^ 5 IWRK = 0 C5300015^^ 6 IMAX = TABLE(ICPRM) C5300016^^ 7 ICUR = TABLE (ICPRM+1) C5300017^^ C CHECK FOR MULTIPLE COLLECTOR ROTATION C5300018^^ 8 IF (IMAX .EQ. ONE) GO TO 200 C5300019^  ^ C ROTATION, IF CURRENT .EQ. MAX RESET TO 1 C5300021^^ 9 IF (ICUR .EQ. IMAX) GO TO 200 C5300022^^ C OTHERWISE MAKE CURRENT COUNT AN INTEGER C5300023^^ 10 I = (AND($0F00,ICUR) / $100) * 10 C5300024^^ 11 J = AND ($000F, ICUR) C5300025^^ 12 IWRK = I + J C5300026^  ^ C CALCULATE POSITION IN TABLE FOR APPROPRIATE COLLECTOR C5300028^^ 13 200 IWRK = IWRK + 1 C5300029^^ 14 K = ICPRM + IWRK*2 C5300030^^ 15 COID(1) = TABLE(K) C5300031^^ 16 COID(2) = TABLE(K+1) C5300032^^ C RETURN IF NO ROTATION (MULTIPLE COLLECTORS) C5300033^^ 17 IF ( IMAX .EQ. ONE) RETURN C5300034^^ C OTHERWISE RESTORE CURRENT VALUE IN TABLE AND RETURN C5300035^^ 18 I = ((IWRK/10) + $30) * $100 C5300036^^ 19 J = IWRK - ((IWRK/10)*10) + $30 C5300037^^ 20 TABLE(ICPRM+1) = I + J C5300038^^ 21 RETURN C5300039^^ 22 END C5300040^t FTN 3.3B (OPT = LPC) VALDT1 PAGE 2 DATE: 08/29/84 TIME: 2316 t  PROGRAM LENGTH $0061 ( 97)   EXTERNALS  Q8PKUP Q8PREP  t FTN 3.3B (OPT = LPC) VALDT1 PAGE 3 DATE: 08/29/84 TIME: 2316 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < ( 000A (10) 0006 10,18,19 (" 000F (15) 0008 11 "" 0F00 (3840) 0005 10 "   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < $ AND INTR.FN. 7FFF 10,11$( COID INTEGER 7FFF 1,2,15,16(, I INTEGER 0004 9,10,12,18,20,* ICPRM INTEGER 7FFF 3,6,7,14,20* ICTST INTEGER 7FFF 3 * ICUR INTEGER 0003 6,7,9,10,11** IMAX INTEGER 0002 5,6,8,9,17 * INIT INTEGER 7FFF 2 ITBLEN INTEGER 7FFF 3 ITYP INTEGER 7FFF 3 2 IWRK INTEGER 0001 4,5,12,13,14,18,19 2. J INTEGER 0007 10,11,12,19,20 .* K INTEGER 0009 13,14,15,16*( ONE INTEGER 0000 2,4,8,17 (2 TABLE INTEGER 7FFF 1,2,3,6,7,15,16,20 2   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : <  Q8PKUP INTEGER.FN. 0054 Q8PREP INTEGER.FN. 0051    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < & 200 0025 8,9,13 & VALDT1 004E 1  t FTN 3.3B (OPT = LPC) WRTOFE PAGE 1 DATE: 08/29/84 TIME: 2316 t^ 1 PROGRAM WRTOFE C5400001^^ 1 1 /C54 F CCS CCS 3.0 PSR(08-22-84) SL-149********^^ C C5400003^^ C CYBERCREDIT SYSTEM VERSION 3 C5400004^^ C DATA SYSTEM - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C5400005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C5400006^^ C C5400007^ ^ C THIS PROGRAM CREATES THE WOEF FILE FROM THE DELQMST FILE. C5400009^^ C TWO DIFFERENT REPORTS CAN BE CREATED FROM THIS REPORT, THE C5400010^^ C ELIGIBLE FOR WRITE OFF AND THE ACTUAL WRITE OFF REPORTS. C5400011^ ^ C THE REPORT MAY BE SORTED BY ACCOUNT TYPE, QUEUE OR A STRAIGHT C5400013^^ C LISTING. THE PROGRAM PROMPTS THE OPERATOR FOR THE SORT CODE. C5400014^^ C THE OPERATOR IS ALSO PROMPTED FOR SUBTOTALS. C5400015^ ^ 2 INTEGER ADAYS(3),ANS(3),ASOFDT(4),BLANK,CREATE,COUNT C5400017^^ 3 INTEGER DATE(3),NDAYS,DDAYS,EOF,FDEL,FMRDEL ********^^ 4 INTEGER IBUF(6),IDUSER(4),MDLDT(3),MSTDT(3),MLEN(11) ********^^ 5 INTEGER MPOS(11),NINE,NO,NREC,OCNT(6),ONE(5) C5400020^^ 6 INTEGER RETURN,RCNT(6),SCNT(6),STAT(2),SUB C5400021^^ 7 INTEGER WCNT(6),WFG1,WFG2,WPOS(11),YES(2),ZERO(2) C5400022^ ^ 8 INTEGER DELQBF(24),DELQRC(10000),DDATA(15) ********^^ 9 INTEGER WOEFBF(24),WOEFRC(60),WDATA(15),WEFREC(874) ********^ ^ 10 INTEGER DSP1(9),DSP2(15),DSP3(21),DSP4(20),DSP5(10) C5400027^^ 11 INTEGER DSP6(17),DSP7(22),DSP8(22),DSP9(22),DSP10(23) C5400028^^ 12 INTEGER DSP11(19),DSP12(20),DSP13(17),DSP14(33),DSP15(30) C5400029^^ 13 INTEGER DSP16(29),DSP17(22) C5400030^ ^ 14 DATA BLANK/$2020/,DELQBF/24*0/,EOF/0/,NINE/$3939/,NO/'NO'/ C5400032^^ 15 DATA OCNT/6*$3030/,RCNT/6*$3030/,SCNT/6*$3030/,ADAYS/3*$3030/ C5400033^^ 16 DATA STAT/'WRS '/,WCNT/6*$3030/,ONE/4*$3030,$3130/ C5400034^^ 17 DATA YES/'YES '/,WOEFBF/24*0/,ZERO/$3030,$3030/ C5400035^ ^ 18 INTEGER DDAT(4) ********^^ 19 DATA DDATA/'LADLQMST',8*$2020,0,10,0/,SUB/0/,IFG/0/,NUMPUT/0/ ********^^ 20 DATA WDATA/'LAWOEF ',8*$2020,0,1,0/,DDAT/'DELQMST '/ ********^ ^ 21 DATA DSP1/$0A0D,'ANSWER (1 OR 2) '/ C5400040^^ 22 DATA DSP2/$0A0D,$0A0D,'ENTER AS-OF-DATE (MMDDYY) '/ C5400041^^ 23 DATA DSP3/$0A0D,$0A0D,'ENTER NUMBER OF DAYS DELINQUENT (NNN) '/ C5400042^^ 24 DATA DSP4/$0A0D,$0A0D,'ENTER WRITE-OFFS SINCE DATE (MMDDYY)'/ C5400043^^ 25 DATA DSP5/$0A0D,'ANSWER (1,2,OR 3) '/ C5400044^^ 26 DATA DSP6/$0A0D,$0A0D,'ARE SUBTOTALS DESIRED (YES/NO)'/ C5400045^^ 27 DATA DSP7/$180A,' RECORD COUNT--R RECORDS 000000000000'/ C5400046^^ 28 DATA DSP8/$0A0D,' RECORD COUNT--S RECORDS 000000000000'/ C5400047^^ 29 DATA DSP9/$0A0D,' RECORD COUNT--W RECORDS 000000000000'/ C5400048^^ 30 DATA DSP10/$A0D,' RECORD COUNT--OTHER RECORDS 000000000000', C5400049^^ 30 1$0A0D/ C5400050^^ 31 DATA DSP11/$180A,'CHOOSE ONE OF THE FOLLOWING REPORTS:'/ C5400051^^ 32 DATA DSP12/$0A0D,$0A0D,' 1) ELIGIBLE FOR WRITE-OFF REPORT'/ C5400052^^ 33 DATA DSP13/$0A0D,' 2) ACTUAL WRITE-OFF REPORT',$0A0D/ C5400053^t FTN 3.3B (OPT = LPC) WRTOFE PAGE 2 DATE: 08/29/84 TIME: 2316 t^ 34 DATA DSP14/$180A,'CHOOSE ONE OF THE FOLLOWING WAYS TO PRINT ', C5400054^^ 34 1'THE WRITE-OFF REPORT: '/ C5400055^^ 35 DATA DSP15/$0A0D,$0A0D,' 1) PRINT THE REPORT BY ACCOUNT TYP', C5400056^^ 35 1'E, QUEUE ASSIGNED'/ C5400057^^ 36 DATA DSP16/$0A0D,' 2) PRINT THE REPORT BY QUEUE ASSIGNED,', C5400058^^ 36 1' ACCOUNT TYPE '/ C5400059^^ 37 DATA DSP17/$0A0D,' 3) PRINT THE REPORT BY STRAIGHT LIST', C5400060^^ 37 1$0A0D/ C5400061^ ^ C FIELD NAME DELQMST WOEF C5400063^^ C MACCT 1 1 C5400064^^ C MNAM 18 34 C5400065^^ C MQUE 271 26 C5400066^^ C MSCD 292 114 C5400067^^ C MSTC 306 25 C5400068^^ C MSTDT 857 97 C5400069^^ C MDLDT 875 64 C5400070^^ C MADLQ 887 70 C5400071^^ C MCBAL 896 103 C5400072^^ C MPYOF 905 79 C5400073^^ C MTCD 963 30 C5400074^ ^ 38 DATA MPOS/1,18,271,292,306,857,875,887,896,905,963/ C5400076^^ 39 DATA WPOS/1,34,26,114,25,97,64,70,103,79,30/ C5400077^^ 40 DATA MLEN/16,30,4,2,1,6,6,9,9,9,4/ C5400078^ ^ 41 EXTERNAL AMONTO,ADAYTO,AYERTO,FMRDEL C5400080^t FTN 3.3B (OPT = LPC) WRTOFE PAGE 3 DATE: 08/29/84 TIME: 2316 t^ 42 CALL PGMIN(IDUSER,LUNIT,MODE,NOPORT) C5400082^^ 43 CALL CCSCST(WDATA,1,2,IDUSER,1,8,ICM) ********^^ 44 IF(ICM.EQ.0) GO TO 5 ********^^ 45 CALL CCSMVA(WDATA,3,6,WDATA,1,8) ********^^ 46 CALL CCSMVA(DDAT ,1,8,DDATA,1,8) ********^^ 47 5 CONTINUE ********^^ 48 ASSIGN 1000 TO CREATE ********^^ 49 ASSIGN 1500 TO COUNT ********^ ^ C BRING IN SYSTEM DATE AND DELETE CODE C5400085^^ 50 100 DATE(1)=AND(AMONTO,$FFFF) C5400086^^ 51 DATE(2)=AND(ADAYTO,$FFFF) C5400087^^ 52 DATE(3)=AND(AYERTO,$FFFF) C5400088^^ 53 JDATE=ICALJL(DATE,1) C5400089^^ 54 ASSEM $C000,FMRDEL,$6800,FDEL C5400090^ ^ C FIND OUT WHICH REPORT-ELIGIBLE/ACTUAL C5400092^^ 55 120 CALL WTREAD(LUNIT,-1,DSP11,38,-1,IBUF,0,ITC) C5400093^^ 56 CALL WTREAD(LUNIT,-1,DSP12,40,-1,IBUF,0,ITC) C5400094^^ 57 CALL WTREAD(LUNIT,-1,DSP13,34,-1,IBUF,0,ITC) C5400095^ ^ C INPUT ANSWER C5400097^^ 58 140 IBUF(1)=0 C5400098^^ 59 CALL WTREAD(LUNIT,-1,DSP1,18,-1,IBUF,10,ITC) ********^^ 60 IF(IBUF(6).NE.1) GO TO 120 ********^^ 61 ANS=IBUF(1)/$100 C5400101^^ 62 IF(ANS.LT.$31.OR.ANS.GT.$32) GO TO 120 C5400102^^ 63 WFG1=ANS C5400103^ ^ C PROMPT FOR AS-OF-DATE FOR ELIGIBLE REPORT C5400105^^ C PROMPT FOR WRITE-OFF SINCE DATE FOR ACTUALC5400106^^ 64 220 CALL CCSMVA(IBUF,1,0,IBUF,1,12) ********^^ 65 IF(WFG1.NE.$32)CALL WTREAD(LUNIT,-1,DSP2,30,-1,IBUF,10,ITC) ********^^ 66 IF(WFG1.EQ.$32)CALL WTREAD(LUNIT,-1,DSP4,40,-1,IBUF,10,ITC) ********^ ^ 67 IF(ITC.NE.2) GO TO 220 ********^^ 68 IF(IBUF(6).NE.6) GO TO 220 ********^^ 69 CALL CCSMVA(IBUF,1,6,ASOFDT,1,8) ********^^ 70 IF(IDATVR(ASOFDT,1).LT.0) GO TO 220 ********^^ 71 IF(WFG1.EQ.$32) GO TO 300 ********^ ^ C PROMPT FOR DAYS DELQ C5400131^^ 72 260 CALL CCSMVA(IBUF,1,0,IBUF,1,12) ********^^ 73 CALL WTREAD(LUNIT,-1,DSP3,42,-1,IBUF,10,ITC) ********^^ 74 IF(ITC.NE.2) GO TO 260 ********^^ 75 NCH = IBUF(6) ********^^ 76 IF(NCH.LT.1 .OR. NCH.GT.3) GO TO 260 ********^ ^ C CHECK FOR NUMERICS ********^^ 77 DO 280 II=1,NCH ********^^ 78 CALL CCSCST(IBUF,II,1,ZERO,1,1,ICOMP) C5400140^^ 79 IF(ICOMP.LT.0) GO TO 260 C5400141^^ 80 CALL CCSCST(IBUF,II,1,NINE,1,1,ICOMP) C5400142^^ 81 IF(ICOMP.GT.0) GO TO 260 C5400143^t FTN 3.3B (OPT = LPC) WRTOFE PAGE 4 DATE: 08/29/84 TIME: 2316 t^ 82 280 CONTINUE C5400144^ ^ 83 290 CALL INTGR(IBUF,NCH,NDAYS) ********^ ^ C HOW IS REPORT TO BE LISTED C5400153^^ 84 300 CALL WTREAD(LUNIT,-1,DSP14,66,-1,IBUF,0,ITC) C5400154^^ 85 CALL WTREAD(LUNIT,-1,DSP15,60,-1,IBUF,0,ITC) C5400155^^ 86 CALL WTREAD(LUNIT,-1,DSP16,58,-1,IBUF,0,ITC) C5400156^^ 87 CALL WTREAD(LUNIT,-1,DSP17,44,-1,IBUF,0,ITC) C5400157^ ^ C INPUT ANSWER C5400159^^ 88 320 CALL CCSMVA(IBUF,1,0,IBUF,1,12) ********^^ 89 CALL WTREAD(LUNIT,-1,DSP5,20,-1,IBUF,10,ITC) ********^^ 90 IF(ITC.NE.2) GO TO 300 ********^^ 91 IF(IBUF(6).NE.1)GO TO 300 ********^^ 92 ANS=IBUF(1)/$100-$30 C5400163^^ 93 IF(ANS.LT.1.OR.ANS.GT.3) GO TO 300 C5400164^^ 94 IF(ANS.EQ.3) GO TO 380 C5400165^ ^ C CHECK FOR SUBTOTALS C5400167^^ 95 340 CALL CCSMVA(IBUF,1,0,IBUF,1,12) ********^^ 96 CALL WTREAD(LUNIT,-1,DSP6,34,-1,IBUF,10,ITC) ********^^ 97 IF(ITC.NE.2) GO TO 340 ********^^ 98 CALL CCSCST(IBUF,1,3,YES,1,3,ICOMP) C5400172^^ 99 IF(ICOMP.EQ.0) GO TO 360 C5400173^^ 100 CALL CCSCST(IBUF,1,2,NO,1,2,ICOMP) C5400174^^ 101 IF(ICOMP.NE.0) GO TO 340 C5400175^^ 102 SUB=0 C5400176^^ 103 GO TO 380 C5400177^^ 104 360 SUB=1 C5400178^ ^ C SET UP PROGRAM FLAG 2 C5400180^^ 105 380 IF(ANS.EQ.1.AND.SUB.EQ.1) WFG2=$0031 C5400181^^ 106 IF(ANS.EQ.2.AND.SUB.EQ.1) WFG2=$0032 C5400182^^ 107 IF(ANS.EQ.3) WFG2=$0033 C5400183^^ 108 IF(ANS.EQ.1.AND.SUB.EQ.0) WFG2=$0034 C5400184^^ 109 IF(ANS.EQ.2.AND.SUB.EQ.0) WFG2=$0035 C5400185^ ^ C OPEN THE FILES C5400187^^ 110 CALL OPENFL(DELQBF,DDATA,ISTAT) C5400188^^ 111 IF(ISTAT.GE.0) GO TO 390 C5400189^^ 112 CALL FILERR(DDATA,3,ISTAT,LUNIT) C5400190^^ 113 GO TO 9999 C5400191^^ 114 390 CALL OPENFL(WOEFBF,WDATA,ISTAT) C5400192^^ 115 IF(ISTAT.GE.0) GO TO 400 C5400193^^ 116 CALL FILERR(WDATA,3,ISTAT,LUNIT) C5400194^^ 117 GO TO 9999 C5400195^t FTN 3.3B (OPT = LPC) WRTOFE PAGE 5 DATE: 08/29/84 TIME: 2316 t^ C SEE WHAT TYPE OF REPORT IS TO BE CREATED C5400197^^ 118 400 DELQBF(23)=1 C5400198^^ 119 IF(WFG1.EQ.$32) GO TO 700 C5400199^ ^ C ELIGIBLE WRITE OFF REPORT C5400201^ ^ C RECORDS EXTRACTED IF C5400203^^ C --MSTC IS NOT W,R,S AND C5400204^^ C --DAYS DELQ IS GREATER THAN OR EQUAL TO THC5400205^^ C NUMBER OF DAYS DELQ, MDLDT, IN DELQMST C5400206^^ C (ASOFDT-MDLDT) C5400207^ ^ C READ THE DELQMST C5400209^^ 120 420 CONTINUE ********^^ 121 CALL GETS(DELQBF,DELQRC,DELQRC,ISTAT) C5400211^ ^ C EOF? C5400213^^ 122 IF(AND(ISTAT,$8100).EQ.$8100) GO TO 9000 C5400214^^ 123 IF(AND(ISTAT,$100).EQ.$100) GO TO 430 C5400215^^ 124 IF(ISTAT.GE.0) GO TO 440 C5400216^^ 125 CALL FILERR(DDATA,13,ISTAT,LUNIT) C5400217^^ 126 GO TO 9500 C5400218^ ^ C SET EOF SWITCH C5400220^^ 127 430 EOF=1 C5400221^^ 128 440 NREC=DELQBF(15) C5400222^ ^ 129 DO 600 I=1,NREC C5400224^^ 130 JW=(I-1)*1000 C5400225^^ 131 JB=(I-1)*2000 C5400226^ ^ C CHECK FOR END OF READ OR DELETED RECORD C5400228^^ 132 450 CONTINUE ********^^ 133 IF(DELQRC(JW+1).EQ.FDEL) GO TO 580 C5400230^ ^ C CHECK FOR W,R OR S STATUS C5400232^^ 134 460 DO 480 II=1,3 C5400233^^ 135 CALL CCSCST(DELQRC,JB+306,1,STAT,II,1,ICOMP) C5400234^^ 136 IF(ICOMP.EQ.0) GO TO 580 C5400235^^ 137 480 CONTINUE C5400236^ ^ C RECORD WAS NOT W,R,S C5400238^^ C COMPUTE DAYS DELQ C5400239^ ^ 138 500 CALL DAYS(DELQRC(JW+1),875,ASOFDT,1,ADAYS,0) ********^^ 139 CALL CCSGET( ADAYS,1,ICM ) ********^^ 140 CALL INTGR(ADAYS(2),4,DDAYS) ********^^ 141 IF( ICM.EQ.$2D ) DDAYS = -1 ********^ ^ C SEE IF DAYS DELQ IS GREATER THAN OR EQUAL C5400251^^ C TO THE DAYS ENTERED IN BY THE CONSOLE C5400252^^ 142 540 IF(DDAYS.LT.NDAYS) GO TO 580 ********^ ^ C CREATE A WOEF RECORD C5400255^t FTN 3.3B (OPT = LPC) WRTOFE PAGE 6 DATE: 08/29/84 TIME: 2316 t^ 143 560 CALL CCSBLK(WOEFRC,120) C5400256^^ 144 CALL CCSMVA(ASOFDT,1,6,WOEFRC,88,6) C5400257^^ 145 CALL CCSMVA(ADAYS,4,3,WOEFRC,94,3) C5400259^ ^ C GO TO MOVE IN THE REST OF THE DELQMST C5400261^^ C FIELDS IN TO WOEF RECORD C5400262^^ 146 ASSIGN 580 TO RETURN C5400263^^ 147 GO TO CREATE C5400265^ ^ C GO TO RECORD COUNTING ROUTINE C5400267^^ 148 580 ASSIGN 600 TO RETURN C5400268^^ 149 GO TO COUNT C5400270^ ^ 150 600 CONTINUE C5400272^^ 151 IF(EOF.EQ.1) GO TO 9000 C5400273^^ 152 GO TO 420 C5400274^t FTN 3.3B (OPT = LPC) WRTOFE PAGE 7 DATE: 08/29/84 TIME: 2316 t^ C ACTUAL WRITE-OFF REPORT C5400276^ ^ C RECORDS ARE EXTRACTED IF C5400278^^ C --STATUS OF MSTC IS W AND C5400279^^ C --THE DATE THE ACCOUNT WAS LAST UPDATED C5400280^^ C FROM THE A/R SYSTEM (MSTDT) IS GREATER C5400281^^ C THAN OR EQUAL TO THE WRITE-OFF SINCE C5400282^^ C DATE ENTERED THROUGH THE CONSOLE(ASOFDT)C5400283^ ^ C READ THE DELQMST FILE C5400285^^ 153 700 CONTINUE ********^^ 154 CALL GETS(DELQBF,DELQRC,DELQRC,ISTAT) C5400287^ ^ C EOF C5400289^^ 155 IF(AND(ISTAT,$8100).EQ.$8100) GO TO 9000 C5400290^^ 156 IF(AND(ISTAT,$100).EQ.$100) GO TO 710 C5400291^^ 157 IF(ISTAT.GE.0) GO TO 720 C5400292^^ 158 CALL FILERR(DDATA,14,ISTAT,LUNIT) C5400293^^ 159 GO TO 9500 C5400294^ ^ C SET EOF SWITCH C5400296^^ 160 710 EOF=1 C5400297^^ 161 720 NREC=DELQBF(15) C5400298^ ^ 162 DO 800 I=1,NREC C5400300^^ 163 JW=(I-1)*1000 C5400301^^ 164 JB=(I-1)*2000 C5400302^ ^ C CHECK FOR END OF READ OR DELETED RECORDS C5400304^^ 165 730 CONTINUE ********^^ 166 IF(DELQRC(JW+1).EQ.FDEL) GO TO 800 C5400306^ ^ C CHECK FOR STATUS OF W C5400308^^ 167 CALL CCSCST(DELQRC,JB+306,1,STAT,1,1,ICOMP) C5400309^^ 168 IF(ICOMP.NE.0) GO TO 780 C5400310^ ^ C RECORD WAS A WRITE-OFF CHECK TO SEE IF C5400312^^ C MSTDT IS GREATER THAN OR EQUAL TO THE C5400313^^ C WRITE-OFF DATE (ASOFDT) C5400314^^ 169 740 DDAYS=0 C5400315^^ 170 CALL DAYS(DELQRC(JW+1),857,ASOFDT,1,ADAYS,0) ********^^ 171 CALL CCSGET( ADAYS,1,ICM ) ********^^ 172 IF(ICM.NE.$2D) GO TO 780 ********^  ^ C RECORD WAS GREATER THAN OR EQUAL TO ASOFDTC5400333^^ C CREATE A WOEF RECORD C5400334^^ 173 CALL CCSBLK(WOEFRC,120) C5400335^^ 174 CALL CCSMVA(ASOFDT,1,6,WOEFRC,88,6) C5400336^^ 175 CALL CCSMVA(ZERO,1,3,WOEFRC,94,3) C5400337^ ^ C GO TO CREATE THE REST OF THE WOEF RECORD C5400339^^ 176 ASSIGN 780 TO RETURN C5400341^^ 177 GO TO CREATE C5400342^t FTN 3.3B (OPT = LPC) WRTOFE PAGE 8 DATE: 08/29/84 TIME: 2316 t ^ C GO TO RECORD COUNTING ROUTINE C5400344^^ 178 780 ASSIGN 800 TO RETURN ********^^ 179 GO TO COUNT C5400347^ ^ 180 800 CONTINUE C5400349^^ 181 IF(EOF.EQ.1) GO TO 9000 C5400350^^ 182 GO TO 700 C5400351^t FTN 3.3B (OPT = LPC) WRTOFE PAGE 9 DATE: 08/29/84 TIME: 2316 t^ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC5400353^^ C CC5400354^^ C CREATE THE WOEF RECORD FROM THE DELQMST CC5400355^^ C CC5400356^^ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC5400357^ ^ C MOVE IN THE DELQMST FIELDS C5400359^^ 183 1000 DO 1020 II=1,11 C5400360^^ 184 IJ=MPOS(II)+JB C5400361^^ 185 CALL CCSMVA(DELQRC,IJ,MLEN(II),WOEFRC,WPOS(II),MLEN(II)) C5400362^^ 186 1020 CONTINUE C5400363^ ^ C MOVE IN THE SORT FIELDS C5400365^^ 187 IF(WFG2.EQ.$33) GO TO 1040 C5400366^^ 188 IF(WFG2.EQ.$31.OR.WFG2.EQ.$34) GO TO 1030 C5400367^^ 189 CALL CCSMVA(DELQRC,JB+271,4,WOEFRC,17,4) C5400368^^ 190 CALL CCSMVA(DELQRC,JB+963,4,WOEFRC,21,4) C5400369^^ 191 GO TO 1040 C5400370^^ 192 1030 CALL CCSMVA(DELQRC,JB+963,4,WOEFRC,17,4) C5400371^^ 193 CALL CCSMVA(DELQRC,JB+271,4,WOEFRC,21,4) C5400372^ ^ C MOVE IN PROGRAM FLAGS C5400374^^ 194 1040 CALL CCSMVA(WFG1,2,1,WOEFRC,112,1) C5400375^^ 195 CALL CCSMVA(WFG2,2,1,WOEFRC,113,1) C5400376^ ^ C WRITE THE RECORD TO FILE C5400378^^ C IF BUFFER IS FULL. ********^ ^ 196 1060 CONTINUE ********^^ 197 NUMPUT = NUMPUT + 1 ********^^ 198 IWW = NUMPUT * 58 - 57 ********^ ^ 199 CALL CCSMVA(WOEFRC,1,115,WEFREC(IWW),1,115) ********^^ 200 IF(NUMPUT.LT.15) GO TO 1070 ********^ ^ 201 1065 CALL PUTS(WOEFBF,WEFREC,NUMPUT,ISTAT) ********^^ 202 IF(ISTAT.GE.0) GO TO 1068 ********^^ 203 CALL FILERR(WDATA,11,ISTAT,LUNIT) ********^^ 204 GO TO 9500 ********^ ^ 205 1068 NUMPUT = 0 ********^^ 206 IF(IFG.EQ.1) GO TO 9000 ********^ ^ C RETURN C5400384^^ 207 1070 GO TO RETURN C5400385^t FTN 3.3B (OPT = LPC) WRTOFE PAGE 10 DATE: 08/29/84 TIME: 2316 t^ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC5400387^^ C CC5400388^^ C COUNT ROUTINE-COUNT THE W,R,S AND CC5400389^^ C OTHER RECORDS CC5400390^^ C CC5400391^^ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC5400392^ ^ 208 1500 DO 1520 II=1,3 C5400394^^ 209 CALL CCSCST(DELQRC,JB+306,1,STAT,II,1,ICOMP) C5400395^^ 210 IF(ICOMP.EQ.0) GO TO 1540 C5400396^^ 211 1520 CONTINUE C5400397^^ C RECORD WAS OTHER C5400398^^ 212 CALL CCSADD(ONE,1,OCNT,1,OCNT,1) C5400399^^ 213 GO TO 1560 C5400400^^ C ADD TO COUNTER DEPENDING ON STATUS C5400401^^ 214 1540 IF(II.EQ.1) CALL CCSADD(ONE,1,WCNT,1,WCNT,1) C5400402^^ 215 IF(II.EQ.2) CALL CCSADD(ONE,1,RCNT,1,RCNT,1) C5400403^^ 216 IF(II.EQ.3) CALL CCSADD(ONE,1,SCNT,1,SCNT,1) C5400404^ ^ C RETURN C5400406^^ 217 1560 GO TO RETURN C5400407^t FTN 3.3B (OPT = LPC) WRTOFE PAGE 11 DATE: 08/29/84 TIME: 2316 t^ C EDIT THE COUNTS C5400409^^ 218 9000 CONTINUE ********^^ 219 IFG = 1 ********^^ 220 IF(NUMPUT.NE.0) GO TO 1065 ********^ ^ C DISPLAY RECORD CONTENTS C5400431^^ 221 9050 DO 9060 I=1,11 C5400432^^ 222 CALL CCSCST(RCNT,I,1,ZERO,1,1,ICOMP) C5400433^^ 223 IF(ICOMP.NE.0) GO TO 9070 C5400434^^ 224 CALL CCSMVA(BLANK,1,1,RCNT,I,1) C5400435^^ 225 9060 CONTINUE C5400436^^ 226 9070 DO 9080 I=1,11 C5400437^^ 227 CALL CCSCST(SCNT,I,1,ZERO,1,1,ICOMP) C5400438^^ 228 IF(ICOMP.NE.0) GO TO 9090 C5400439^^ 229 CALL CCSMVA(BLANK,1,1,SCNT,I,1) C5400440^^ 230 9080 CONTINUE C5400441^^ 231 9090 DO 9100 I=1,11 C5400442^^ 232 CALL CCSCST(WCNT,I,1,ZERO,1,1,ICOMP) C5400443^^ 233 IF(ICOMP.NE.0) GO TO 9110 C5400444^^ 234 CALL CCSMVA(BLANK,1,1,WCNT,I,1) C5400445^^ 235 9100 CONTINUE C5400446^^ 236 9110 DO 9120 I=1,11 C5400447^^ 237 CALL CCSCST(OCNT,I,1,ZERO,1,1,ICOMP) C5400448^^ 238 IF(ICOMP.NE.0) GO TO 9130 C5400449^^ 239 CALL CCSMVA(BLANK,1,1,OCNT,I,1) C5400450^^ 240 9120 CONTINUE C5400451^^ 241 9130 CALL CCSMVA(RCNT,1,12,DSP7,33,12) C5400452^^ 242 CALL CCSMVA(SCNT,1,12,DSP8,33,12) C5400453^^ 243 CALL CCSMVA(WCNT,1,12,DSP9,33,12) C5400454^^ 244 CALL CCSMVA(OCNT,1,12,DSP10,33,12) C5400455^^ 245 CALL WTREAD(LUNIT,-1,DSP7,44,-1,IBUF,0,ITC) C5400456^^ 246 CALL WTREAD(LUNIT,-1,DSP8,44,-1,IBUF,0,ITC) C5400457^^ 247 CALL WTREAD(LUNIT,-1,DSP9,44,-1,IBUF,0,ITC) C5400458^^ 248 CALL WTREAD(LUNIT,-1,DSP10,46,-1,IBUF,0,ITC) C5400459^ ^ C CLOSE THE FILES C5400461^^ 249 9500 CALL CLOSFL(DELQBF,ISTAT) C5400462^^ 250 CALL CLOSFL(WOEFBF,ISTAT) C5400463^^ 251 9999 CALL PGMOUT C5400464^^ 252 STOP C5400465^^ 253 END C5400466^t FTN 3.3B (OPT = LPC) WRTOFE PAGE 12 DATE: 08/29/84 TIME: 2316 t  PROGRAM LENGTH $31B9 ( 12729)   EXTERNALS 2 Q8STP FMRDEL AMONTO ADAYTO AYERTO PGMIN CCSCST 22 CCSMVA ICALJL WTREAD IDATVR INTGR OPENFL FILERR 22 GETS DAYS CCSGET CCSBLK PUTS CCSADD CLOSFL 2 PGMOUT  t FTN 3.3B (OPT = LPC) WRTOFE PAGE 13 DATE: 08/29/84 TIME: 2316 t, ***** L I S T O F S Y M B O L S *****,   CONSTANTS : ---------  < VALUE ADDRESS REFERENCED BY STATEMENT NB : < * 8100 (-32511) 2CFA 122,122,155*\ FFFE (-1) 2CE6 55,55,56,57,59,65,66,73,84,85,86,87,89,96,141,245,246,247,248\( FFFF (65535) 2CE4 50,51,52 (‚ 0000 (0) 0003 14,17,19,20,44,55,56,57,58,64,70,72,79,81,84,85,86,87,88,95,99,101,102,108,109,111,115,124,136,138 ‚` ,157,168,169,170,202,205,210,220,223,228,233,238,245,246,247,248 `‚ 0001 (1) 0002 20,38,39,40,43,45,46,50,53,55,56,57,58,59,60,61,64,65,66,69,70,72,73,76,77,78,80,84,85,86,87,88,89 ‚‚ ,91,92,93,95,96,98,100,104,105,106,108,118,127,129,130,131,133,134,135,138,139,141,144,151,160,162 ‚€ ,163,164,166,167,170,171,174,175,181,183,194,195,197,199,206,208,209,212,214,215,216,219,221,222,€f 224,226,227,229,231,232,234,236,237,239,241,242,243,244,245,246,247,248fL 0002 (2) 2CDF 43,51,67,74,90,97,100,106,109,140,194,195,215LP 0003 (3) 2CE2 45,52,76,93,94,98,107,112,116,134,145,175,208,216P6 0004 (4) 2D03 140,145,189,190,192,19368 0006 (6) 2CE3 45,60,68,69,75,91,144,1748* 0008 (8) 2CE0 43,45,46,69*0 000A (10) 2CEC 59,65,66,73,89,9606 000B (11) 2D09 183,203,221,226,231,2366: 000C (12) 2CEE 64,72,88,95,241,242,243,244:" 000D (13) 2CFB 125"" 000E (14) 2D07 158"& 0011 (17) 2D0C 189,192&" 0012 (18) 2CEB 59 "" 0014 (20) 2CF8 89 "& 0015 (21) 2D0E 190,193&" 001E (30) 2CEF 65 ". 0021 (33) 2D13 241,242,243,244.$ 0022 (34) 2CEA 57,96$" 0026 (38) 2CE7 55 "$ 0028 (40) 2CE9 56,66$" 002A (42) 2CF0 73 ". 002C (44) 2CF7 87,245,246,247 ." 002E (46) 2D14 248"& 003A (58) 2CF6 86,198 &" 003C (60) 2CF5 85 "" 0042 (66) 2CF4 84 "& 0058 (88) 2D05 144,174&& 005E (94) 2D06 145,175&" 0070 (112) 2D0F 194"" 0071 (113) 2D10 195"& 0073 (115) 2D12 199,199&& 0078 (120) 2D04 143,173&, 0100 (256) 2CED 61,92,123,156,& 010F (271) 2D0B 189,193&* 0132 (306) 2D01 135,167,209*" 0359 (857) 2D08 170"" 036B (875) 2D02 138"& 03C3 (963) 2D0D 190,192&t FTN 3.3B (OPT = LPC) WRTOFE PAGE 14 DATE: 08/29/84 TIME: 2316 t& 03E8 (1000) 2CFE 130,163&& 07D0 (2000) 2D00 131,164&   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < < ADAYS INTEGER 0004 1,15,138,139,140,145,170,171 <8 AND INTR.FN. 7FFF 50,51,52,122,123,155,156 8F ANS INTEGER 0007 1,61,62,63,92,93,94,105,106,107,108,109F6 ASOFDT INTEGER 000A 1,69,70,138,144,170,17464 BLANK INTEGER 000E 1,14,224,229,234,239 4, COUNT INTEGER 0010 1,49,149,179 ,, CREATE INTEGER 000F 1,48,147,177 ,, DATE INTEGER 0011 1,50,51,52,53,( DDAT INTEGER 2CD6 17,20,46 (6 DDATA INTEGER 279B 1,19,46,110,112,125,15860 DDAYS INTEGER 0015 1,140,141,142,1690@ DELQBF INTEGER 0073 1,14,110,118,121,128,154,161,249 @X DELQRC INTEGER 008B 1,121,133,135,138,154,166,167,170,185,189,190,192,193,209X& DSP1 INTEGER 2B77 1,21,59&, DSP10 INTEGER 2C15 1,30,244,248 ,& DSP11 INTEGER 2C2C 1,31,55&& DSP12 INTEGER 2C3F 1,32,56&& DSP13 INTEGER 2C53 1,33,57&& DSP14 INTEGER 2C64 1,34,84&& DSP15 INTEGER 2C85 1,35,85&& DSP16 INTEGER 2CA3 1,36,86&& DSP17 INTEGER 2CC0 1,37,87&& DSP2 INTEGER 2B80 1,22,65&& DSP3 INTEGER 2B8F 1,23,73&& DSP4 INTEGER 2BA4 1,24,66&& DSP5 INTEGER 2BB8 1,25,89&& DSP6 INTEGER 2BC2 1,26,96&, DSP7 INTEGER 2BD3 1,27,241,245 ,, DSP8 INTEGER 2BE9 1,28,242,246 ,, DSP9 INTEGER 2BFF 1,29,243,247 ,4 EOF INTEGER 0016 1,14,127,151,160,181 4, FDEL INTEGER 0017 1,54,133,166 ,f I INTEGER 2CFC 128,130,131,162,163,164,221,222,224,226,227,229,231,232,234,236,237,239f€ IBUF INTEGER 0018 1,55,56,57,58,59,60,61,64,65,66,68,69,72,73,75,78,80,83,84,85,86,87,88,89,91,92,95,96,98,100,245,€* 246,247,248*4 ICM INTEGER 2CE1 43,44,139,141,171,1724p ICOMP INTEGER 2CF3 78,79,80,81,98,99,100,101,135,136,167,168,209,210,222,223,227,228,232,233,237,238p& IDUSER INTEGER 001E 1,42,43&* IFG INTEGER 2CDA 19,206,219 *P II INTEGER 2CF2 76,78,80,134,135,183,184,185,208,209,214,215,216 P* IJ INTEGER 2D0A 183,184,185*r ISTAT INTEGER 2CF9 110,111,112,114,115,116,121,122,123,124,125,154,155,156,157,158,201,202,203,249,250rb ITC INTEGER 2CE8 55,56,57,59,65,66,67,73,74,84,85,86,87,89,90,96,97,245,246,247,248 b* IWW INTEGER 2D11 197,198,199*J JB INTEGER 2CFF 130,131,135,164,167,184,189,190,192,193,209Jt FTN 3.3B (OPT = LPC) WRTOFE PAGE 15 DATE: 08/29/84 TIME: 2316 t$ JDATE INTEGER 2CE5 52,53$: JW INTEGER 2CFD 129,130,133,138,163,166,170:l LUNIT INTEGER 2CDC 42,55,56,57,59,65,66,73,84,85,86,87,89,96,112,116,125,158,203,245,246,247,248l MDLDT INTEGER 0022 1 ( MLEN INTEGER 0028 1,40,185 (" MODE INTEGER 2CDD 42 "( MPOS INTEGER 0033 1,38,184 ( MSTDT INTEGER 0025 1 . NCH INTEGER 2CF1 74,75,76,77,83 .( NDAYS INTEGER 0014 1,83,142 (& NINE INTEGER 003E 1,14,80&( NO INTEGER 003F 1,14,100 (" NOPORT INTEGER 2CDE 42 "0 NREC INTEGER 0040 1,128,129,161,1620: NUMPUT INTEGER 2CDB 19,197,198,200,201,205,220 :4 OCNT INTEGER 0041 1,15,212,237,239,244 44 ONE INTEGER 0047 1,16,212,214,215,216 44 RCNT INTEGER 004D 1,15,215,222,224,241 48 RETURN INTEGER 004C 1,146,148,176,178,207,21784 SCNT INTEGER 0053 1,15,216,227,229,242 40 STAT INTEGER 0059 1,16,135,167,209 0< SUB INTEGER 005B 1,19,102,104,105,106,108,109 <4 WCNT INTEGER 005C 1,16,214,232,234,243 46 WDATA INTEGER 27FE 1,20,43,45,114,116,203 6( WEFREC INTEGER 280D 1,199,201(4 WFG1 INTEGER 0062 1,63,65,66,71,119,1944@ WFG2 INTEGER 0063 1,105,106,107,108,109,187,188,195@0 WOEFBF INTEGER 27AA 1,17,114,201,250 0X WOEFRC INTEGER 27C2 1,143,144,145,173,174,175,185,189,190,192,193,194,195,199X( WPOS INTEGER 0064 1,39,185 (& YES INTEGER 006F 1,17,98&: ZERO INTEGER 0071 1,17,78,175,222,227,232,237:   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < . CCSADD SUBROUTINE 30D5 211,214,215,216.& CCSBLK SUBROUTINE 2FF9 142,173&J CCSCST SUBROUTINE 313B 42,78,80,98,100,135,167,209,222,227,232,237J& CCSGET SUBROUTINE 2FEF 138,171&€ CCSMVA SUBROUTINE 3113 44,46,64,69,72,88,95,144,145,174,175,185,189,190,192,193,194,195,199,224,229,234,239,241,242,243,€" 244"& CLOSFL SUBROUTINE 31AF 249,250&& DAYS SUBROUTINE 2FE7 137,170&2 FILERR SUBROUTINE 30AB 111,116,125,158,2032& GETS SUBROUTINE 2F8F 119,154&" ICALJL INTEGER.FN. 2D4E 53 "" IDATVR INTEGER.FN. 2DC3 70 "& INTGR SUBROUTINE 2F54 82,140 && OPENFL SUBROUTINE 2EC3 109,114&" PGMIN SUBROUTINE 2D16 41 "t FTN 3.3B (OPT = LPC) WRTOFE PAGE 16 DATE: 08/29/84 TIME: 2316 t" PGMOUT SUBROUTINE 31B6 251"" PUTS SUBROUTINE 30A1 200" Q8STP INTEGER.FN. 31B8 V WTREAD SUBROUTINE 318A 54,56,57,59,65,66,73,84,85,86,87,89,96,245,246,247,248 V   LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 5 2D36 44,47$" 100 2D3E 49 "( 120 2D56 54,60,62 (" 140 2D72 57 "* 220 2D92 63,67,68,70*. 260 2DCD 71,74,76,79,81 .$ 280 2E0F 76,82$" 290 2E11 82 ". 300 2E16 71,84,90,91,93 ." 320 2E3A 87 "( 340 2E67 94,97,101(& 360 2E9A 99,104 &* 380 2E9C 94,103,105 *& 390 2ED3 111,114&& 400 2EE1 115,118&& 420 2EEA 119,152&& 430 2F06 123,127&& 440 2F09 124,128&" 450 2F20 131"" 460 2F28 133"& 480 2F3D 133,137&" 500 2F42 137"" 540 2F5F 141"" 560 2F65 142"2 580 2F7F 133,136,142,146,1482* 600 2F84 128,148,150** 700 2F8E 119,153,182*& 710 2FAC 156,160&& 720 2FAE 157,161&" 730 2FC5 164"" 740 2FDF 168". 780 3011 168,172,176,178.. 800 3016 161,166,178,180.& 1000 3020 47,183 && 1020 303C 183,186&& 1030 3067 188,192&* 1040 307B 187,191,194*" 1060 308A 195"& 1065 30A0 200,220&& 1068 30B2 202,205&& 1070 30B9 200,207&& 1500 30BB 48,208 && 1520 30CF 208,211&t FTN 3.3B (OPT = LPC) WRTOFE PAGE 17 DATE: 08/29/84 TIME: 2316 t& 1540 30DD 210,214&& 1560 30FB 212,217&6 9000 30FD 122,151,155,181,206,2186" 9050 3104 220"& 9060 311A 220,225&& 9070 311F 223,226&& 9080 3133 226,230&& 9090 3138 228,231&& 9100 314E 231,235&& 9110 3153 233,236&& 9120 3167 236,240&& 9130 316D 238,241&. 9500 31AE 125,159,204,249.* 9999 31B5 112,117,251* WRTOFE 0000 1  t FTN 3.3B (OPT = LPC) XLAT PAGE 1 DATE: 08/29/84 TIME: 2318 t^ 1 SUBROUTINE XLAT (EBC, ASC, EALNG, MD) C5500001^^ 1 1 /C55 F CCS CCS 3.0 SL-149C5500002^^ C C5500003^^ C CYBERCREDIT SYSTEM VERSION 3 C5500004^^ C DATA SYSTEMS - LA JOLLA DIVISION, LA JOLLA, CALIFORNIA C5500005^^ C COPYRIGHT CONTROL DATA CORPORATION, 1979 C5500006^^ C C5500007^^ 2 INTEGER EBC(1), ASC(1), EALNG, ASCTAB(29), EBCTAB(29) C5500008^^ 3 INTEGER PERIOD C5500009^^ 4 DATA PERIOD /$2E/ C5500010^^ 5 DATA ASCTAB/' <.(+&$*)>-/,%?: ',$4027,'="ABCDEFGHIJKLMNOPQRSTUVWXYC5500011^^ 5 *Z0123456789'/ C5500012^^ 6 DATA EBCTAB/$404A,$4B4D,$4E50,$5B5C,$5D5E,$6061,$6B6C,$6D6F,$7A7B,C5500013^^ 6 *$7C7D,$7E7F,$C1C2,$C3C4,$C5C6,$C7C8,$C9D1,$D2D3,$D4D5,$D6D7,$D8D9,C5500014^^ 6 * $E2E3,$E4E5,$E6E7,$E8E9,$F0F1,$F2F3,$F4F5,$F6F7,$F8F9/ C5500015^  ^ C TRANSLATE EBCDIC IF REQUIRED C5500017^^ 7 IF (MD .EQ. 0) GO TO 100 C5500018^^ C EBCDIC TRANSLATION C5500019^^ 8 K = 0 C5500020^^ 9 ITEMP = 0 C5500021^^ 10 IEA = 0 C5500022^^ 11 10 IEA = IEA + 1 C5500024^^ 12 CALL CCSGET (EBC, IEA, ITEMP) C5500025^^ 13 DO 20 J = 1,58 C5500026^^ 14 CALL CCSGET ( EBCTAB,J,K) C5500027^^ 15 IF ( K - ITEMP) 20,30,20 C5500028^^ 16 20 CONTINUE C5500029^^ 17 J = 3 C5500030^^ 18 30 CALL CCSGET ( ASCTAB, J, K) C5500031^^ 19 CALL CCSPUT (K, IEA, ASC) C5500032^^ 20 IF (IEA .LT. EALNG) GO TO 10 C5500033^^ C DONE WITH EBCDIC CONVERSION, NOW EDIT C5500034^^ 21 100 DO 110 I = 1, EALNG C5500035^^ 22 CALL CCSGET ( EBC,I, K) C5500036^^ 23 IF (MD .NE. 0) CALL CCSGET (ASC, I, K) C5500037^^ 24 IF ( K .LT. $20) K = PERIOD C5500038^^ 25 IF ( K .GT. $5D) K = PERIOD C5500039^^ 26 CALL CCSPUT ( K, I, ASC) C5500040^^ 27 110 CONTINUE C5500041^^ 23 IF (MD .NE. 0) CALL CCSGET (ASC, I, K) C5500037^^ 24 IF ( K .LT. $20) K = PERIOD C5500038^^ 25 IF ( K .GT. $5D) K = PERIOD C5500039^^ 26 CALL CCSPUT ( K, I, ASC) C5500040^^ 27 110 CONTINUE C5500041^^ 28 RETURN C5500042^^ 29 END C5500043^t FTN 3.3B (OPT = LPC) XLAT PAGE 2 DATE: 08/29/84 TIME: 2318 t  PROGRAM LENGTH $00A6 ( 166)   EXTERNALS  Q8PKUP Q8PREP CCSGET CCSPUT  t FTN 3.3B (OPT = LPC) XLAT PAGE 3 DATE: 08/29/84 TIME: 2318 t, ***** L I S T O F S Y M B O L S *****,   VARIABLES : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < , ASC INTEGER 7FFF 1,2,19,23,26 ,& ASCTAB INTEGER 0000 2,5,18 &( EALNG INTEGER 7FFF 1,2,20,21(( EBC INTEGER 7FFF 1,2,12,22(& EBCTAB INTEGER 001D 2,6,14 &* I INTEGER 003F 21,22,23,26*0 IEA INTEGER 003D 9,10,11,12,19,20 0( ITEMP INTEGER 003C 8,9,12,15(* J INTEGER 003E 12,14,17,18*> K INTEGER 003B 7,8,14,15,18,19,22,23,24,25,26 >& MD INTEGER 7FFF 1,7,23 &( PERIOD INTEGER 003A 2,4,24,25(   EXTERNALS : ---------  < NAME TYPE ADDRESS REFERENCED BY STATEMENT NB : < . CCSGET SUBROUTINE 004A 11,14,18,22,23 .$ CCSPUT SUBROUTINE 0064 18,26$ Q8PKUP INTEGER.FN. 0099 Q8PREP INTEGER.FN. 0096    LABELED STATEMENTS :  ------------------  < LABEL ADDRESS REFERENCED BY STATEMENT NB : < $ 10 0048 10,20$( 20 0058 12,15,16 ($ 30 005F 15,18$$ 100 006D 7,21 $$ 110 008C 21,27$ XLAT 0093 1   H*K,L14,P06˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙H