REC625.cobol.txt 34.2 KB
Newer Older
Bruno Drouet's avatar
Bruno Drouet committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
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
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
 IDENTIFICATION DIVISION.                                                *
 PROGRAM-ID.    REC625.                                                  *
*SECURITY.                                                               *
*    95014 LIQUIDATION ET EDITION DES ACOMPTES DE TP.                    *
*    96012 LIQUIDATION ET PREPARATION EDITION ACOMPTES DE TP.            *
*    10001 DIMINUTION DU TAUX DE L AP TP DE 50 A 10.                     *
*    18001 TRANSPORT DE LA DONNEE ROF SUR FICHIER ROLATP.         18/03/08
 ENVIRONMENT DIVISION.                                                   *
 CONFIGURATION SECTION.                                                  *
 SOURCE-COMPUTER. LEVEL-64.                                              *
 OBJECT-COMPUTER. LEVEL-64.                                              *
 INPUT-OUTPUT SECTION.                                                   *
 FILE-CONTROL.                                                           *
     SELECT RDOCUM ASSIGN TO RDOCUM.                                     *
     SELECT RCORTP ASSIGN TO RCORTP.                                     *
     SELECT ROLECP ASSIGN TO ROLECP.                                     *
     SELECT ROLATP ASSIGN TO ROLATP.                                     *
     SELECT BILAN ASSIGN TO BILAN ASA.                                   *
     SELECT STATDGI ASSIGN TO STATDGI.                                   *
     SELECT RDOCANO ASSIGN TO RDOCANO.                                   *
     SELECT PSNNOMEN ASSIGN TO PSNOMEN ACCESS RANDOM ORGANIZATION        *
        INDEXED RECORD KEY PSN-NUMPOS.                                   *
     SELECT RFLIUC ASSIGN TO RFLIUC ACCESS DYNAMIC ORGANIZATION          *
        INDEXED RECORD KEY IU00-NFACTX ALTERNATE RECORD KEY              *
        IU00-ITAX DUPLICATES ALTERNATE RECORD KEY IU00-CONTRAX           *
        DUPLICATES ALTERNATE RECORD KEY IU00-IUCX DUPLICATES             *
        ALTERNATE RECORD KEY IU00-POSIUC DUPLICATES ALTERNATE            *
        RECORD KEY IU00-DIIUC DUPLICATES.                                *
     SELECT PARAM ASSIGN TO PARAM ACCESS DYNAMIC ORGANIZATION            *
        INDEXED RECORD KEY IDPAR.                                        *
 DATA DIVISION.                                                          *
 FILE SECTION.                                                           *
 FD  RDOCUM.                                                             *
     COPY RD15.                                                          *
 FD  RCORTP.                                                             *
     COPY RP01.                                                          *
 FD  ROLECP.                                                             *
     COPY RO01.                                                          *
 FD  ROLATP.                                                             *
     COPY TP00.                                                          *
 FD  RFLIUC.                                                             *
     COPY IU00.                                                          *
 FD  RDOCANO.                                                            *
     COPY RD15 REPLACING LEADING "RD15" BY "RD16".                       *
 FD  STATDGI.                                                            *
 01 ART-DGI.                                                             *
   02 DGI-DEPDIR              PIC X(3).                                  *
   02 DGI-AVI                 PIC 9(6).                                  *
   02 DGI-MONT                PIC Z9(9),99.                              *
 FD  BILAN.                                                              *
 01 LIG-IMP.                                                             *
   02 SAUT                    PIC X.                                     *
   02 ZIMP                    PIC X(132).                                *
 01 BIL2.                                                                *
   02 ST2BIL                  PIC X.                                     *
   02 EDIPAR-ANC              PIC X(65).                                 *
*  02 FILLER                  PIC X(3).                                  *
   02 EDIPAR-M                PIC X.                                     *
   02 EDIPAR-NOU              PIC X(65).                                 *
*  02 FILLER                  PIC X(3).                                  *
     COPY PSNNOM.                                                        *
 FD  PARAM.                                                              *
 01 ARTPAR1.                                                             *
   02 FILLER                  PIC XXX.                                   *
   02 IDPAR.                                                             *
     03 NOMPARC1              PIC X(10).                                 *
     03 NOARTC1               PIC 999.                                   *
   02 FILLER                  PIC X.                                     *
   02 DATDERPAR               PIC X(6).                                  *
   02 DATDERPAR9 REDEFINES DATDERPAR                                     *
                              PIC 9(6).                                  *
   02 FILLER                  PIC X(55).                                 *
 01 ARTPAR2.                                                             *
   02 ZONART2.                                                           *
     03 FILLER                PIC XXX.                                   *
     03 IDPAR2.                                                          *
       04 NOMPARC2            PIC X(10).                                 *
       04 NOARTC2             PIC 999.                                   *
     03 CONTPAR2.                                                        *
       04 PAR2ZON OCCURS 2.                                              *
         05 PAR2-DEPF         PIC XX.                                    *
         05 PAR2-DOM          PIC X.                                     *
         05 PAR2-PNF          PIC 9(7).                                  *
         05 PAR2-DNFP         PIC 9(7).                                  *
         05 PAR2-DNF          PIC 9(7).                                  *
       04 FILLER              PIC X(14).                                 *
     03 CONTPAR2R REDEFINES CONTPAR2.                                    *
       04 PAR2R-EXER          PIC X(4).                                  *
       04 PAR2R-UPORI         PIC X(7).                                  *
       04 PAR2R-DATORI        PIC X(8).                                  *
       04 PAR2R-UTI           PIC X.                                     *
       04 FILLER              PIC X(42).                                 *
     03 CONTPAR3R REDEFINES CONTPAR2.                                    *
       04 PAR2-DEP-DIDS       PIC XXX.                                   *
       04 PAR2-PIDS           PIC 9(10).                                 *
       04 PAR2-DIDS           PIC 9(10).                                 *
       04 PAR2-IDSDER         PIC 9(10).                                 *
       04 PAR2-IDSDERP        PIC 9(10).                                 *
       04 FILLER              PIC X(19).                                 *
 WORKING-STORAGE SECTION.                                                *
 01 TABPAR.                                                              *
   02 FILLER                  PIC X(10)        VALUE "RECDATPB ".        *
   02 FILLER                  PIC X(10)        VALUE "RECDEPDIN".        *
   02 FILLER                  PIC X(10)        VALUE "RECEN    ".        *
   02 FILLER                  PIC X(10)        VALUE "RECFACC  ".        *
   02 FILLER                  PIC X(10)        VALUE "RECIDS   ".        *
   02 FILLER                  PIC X(10)        VALUE "RECTADEC2N".       *
   02 FILLER                  PIC X(10)        VALUE "RECTADEP1N".       *
   02 FILLER                  PIC X(10)        VALUE "RECTAUN   ".       *
   02 FILLER                  PIC X(10)        VALUE "RECTRIPOT ".       *
   02 FILLER                  PIC X(10)        VALUE ALL "9".            *
 COPY RECDATPB.                                                          *
 COPY RDEPDIN.                                                           *
 COPY RECEN.                                                             *
 COPY RECFACC.                                                           *
 COPY RECIDS.                                                            *
 COPY RTADEC2N.                                                          *
 COPY RTADEP1N.                                                          *
 COPY RECTAUN.                                                           *
 COPY RTRIPOT.                                                           *
 01 FINTAB                    PIC X            VALUE "*".                *
****    IND = INDICE DE LA PARTIE VARIABLE DU RDOCUM  ***                *
 77 IND                       PIC 99           VALUE 0.                  *
****    INDTP = INDICATEUR DU MONTANT DE LA BASE TP   ***                *
****            INDTP = 0 BASE < SEUILTP              ***                *
****            INDTP = 1 BASE > SEUILTP              ***                *
 77 INDTP                     PIC 9            VALUE 0.                  *
****   INDDOUB = INDICATEUR D'ARTICLE DOCUM EN DOUBLE ***                *
****         INDDOUB = 1 SI ARTICLE DOCUM EN DOUBLE   ***                *
 77 INDDOUB                   PIC 9            VALUE 0.                  *
 77 INDRO01                   PIC 9            VALUE 0.                  *
 77 NBCREFAC                  PIC 9(7)         VALUE 0.                  *
 77 NBRDOCUM                  PIC 9(7)         VALUE 0.                  *
 77 NBRCORTP                  PIC 9(7)         VALUE 0.                  *
 77 NBDOCINF                  PIC 9(7)         VALUE 0.                  *
 77 NBCORINF                  PIC 9(7)         VALUE 0.                  *
 77 NBNARP                    PIC 9(7)         VALUE 0.                  *
 77 NBNARD                    PIC 9(7)         VALUE 0.                  *
 77 NBROLECP                  PIC 9(7)         VALUE 0.                  *
 77 NBCPDOUB                  PIC 9(7)         VALUE 0.                  *
 77 NBDOCANO                  PIC 9(7)         VALUE 0.                  *
 77 NBDGE                     PIC 9(7)         VALUE 0.                  *
 77 PRESENT                   PIC 9            VALUE 0.                  *
                                                                         *
 77 NBCOL                     PIC 9(7)         VALUE 0.                  *
 77 NBMEN                     PIC 9(7)         VALUE 0.                  *
 77 NBEXMEN                   PIC 9(7)         VALUE 0.                  *
 77 NBROLATP                  PIC 9(7)         VALUE 0.                  *
 77 NBRAPREL                  PIC 9(7)         VALUE 0.                  *
 77 NBACPTE                   PIC 9(7)         VALUE 0.                  *
 77 TOTACPTE                  PIC 9(12)        VALUE 0.                  *
 77 NBNAPSNOMEN               PIC 9(7)         VALUE 0.                  *
                                                                         *
 77 W-CALCUL                  PIC 9(12)        VALUE 0.                  *
 77 W-CALCULD                 PIC 9(12)        VALUE 0.                  *
 77 W-CALCULI                 PIC 9(12)        VALUE 0.                  *
 77 QUOTIENT                  PIC 9(9)         VALUE 0.                  *
 77 RESTE                     PIC 99           VALUE 0.                  *
 77 BIDON                     PIC 9(10)        VALUE 0.                  *
 77 TRAVDER                   PIC 9(10)        VALUE 0.                  *
 77 W-IDSDERPLUS1             PIC 9(10)        VALUE 0.                  *
 77 CLE-IDS                   PIC 9(3)         VALUE 0.                  *
 77 SAUT-P                    PIC X            VALUE "1".                *
 77 SAUT-0                    PIC X            VALUE " ".                *
 77 SAUT-1                    PIC X            VALUE "0".                *
 77 SAUT-2                    PIC X            VALUE "-".                *
 77 TROUVE                    PIC 9            VALUE ZERO.               *
 77 INDL                      PIC 99           VALUE ZERO.               *
 77 INDO                      PIC 9            VALUE ZERO.               *
 77 INDDIP                    PIC 9(3)         VALUE ZERO.               *
 77 INDAPP                    PIC 9            VALUE ZERO.               *
 77 NFAC                      PIC 9(6)         VALUE ZERO.               *
 77 NIDS                      PIC 9(6)         VALUE ZERO.               *
 77 WNOART                    PIC 99           VALUE ZERO.               *
 77 RECHDEP                   PIC X(3).                                  *
/                                                                        *
 01  WIUCX PIC X(13).
 01  WIUC9 REDEFINES WIUCX PIC 9(13).
 01 OCCURENCE                 PIC 9            VALUE 2.                  *
    88 OCCURS1                                 VALUE 1.                  *
    88 OCCURS2                                 VALUE 2.                  *
 01 R-DEP.                                                               *
    02 DEP1-3.                                                           *
       03 FILLER              PIC X.                                     *
       03 DEP2-3              PIC XX.                                    *
    02 DEPDOM REDEFINES DEP1-3.                                          *
       03 DEP97               PIC XX.                                    *
       03 DEP3                PIC X.                                     *
 01 WRECFACC.                                                            *
   02 WRECATFACT.                                                        *
     03 WDETATFACT1.                                                     *
       04 WEXERIF             PIC XXXX.                                  *
       04 WUPORIF             PIC X(7).                                  *
       04 WDATORIF            PIC X(8).                                  *
       04 WUTIATFAC           PIC X.                                     *
       04 FILLER              PIC X(42).                                 *
     03 WDETATFACT OCCURS 25.                                            *
       04 WELEMATFACT OCCURS 2.                                          *
         05 WDEPDOMF.                                                    *
           06 WDEPF           PIC XX.                                    *
           06 WDOMF           PIC X.                                     *
         05 WPNF              PIC 9(7).                                  *
         05 WDNF              PIC 9(7).                                  *
         05 WDNFP             PIC 9(7).                                  *
       04 FILLER              PIC X(14).                                 *
 01 FACT11                    PIC 9(11)        VALUE ZERO.               *
 01 FACT13.                                                              *
    02 EXFACT                 PIC 99.                                    *
    02 DEPFACT                PIC 99.                                    *
    02 REFFACT                PIC 9(7).                                  *
    02 CLEFACT                PIC 99.                                    *
 01 CONTENU-PAR.                                                         *
   02 W-DEP-DIDS              PIC XXX.                                   *
   02 W-PIDS                  PIC 9(10).                                 *
   02 W-DIDS                  PIC 9(10).                                 *
   02 W-IDSDER                PIC 9(10).                                 *
   02 W-IDSDERP               PIC 9(10).                                 *
   02 FILLER                  PIC X(19).                                 *
 01 MEMO-PAR.                                                            *
   02 X-DEP-DIDS              PIC XXX.                                   *
   02 X-PIDS                  PIC 9(10).                                 *
   02 X-DIDS                  PIC 9(10).                                 *
   02 X-IDSDER                PIC 9(10).                                 *
   02 X-IDSDERP               PIC 9(10).                                 *
   02 FILLER                  PIC X(19).                                 *
 01 WW-IDSMAN.                                                           *
   02 IDSMAN10                PIC 9(10).                                 *
   02 CLEMAN3                 PIC 999.                                   *
   02 POSIT14                 PIC X.                                     *
**** DEFINITIONS DES DIFFERENTS IDENTIFIANTS DE TAXATION ****            *
 01 IDENTAX.                                                             *
   02 DEPTAX                  PIC XX.                                    *
   02 DIRTAX                  PIC X.                                     *
**** IR ****                                                             *
   02 TAXIR.                                                             *
     03 CNIR                  PIC X.                                     *
     03 SPIIR                 PIC X(10).                                 *
     03 FILLER                PIC XXX.                                   *
**** TH ****                                                             *
   02 TAXTH REDEFINES TAXIR.                                             *
     03 COMTH                 PIC XXX.                                   *
     03 CNTH                  PIC X.                                     *
     03 SPITH                 PIC X(10).                                 *
**** TF ****                                                             *
   02 TAXTF REDEFINES TAXIR.                                             *
     03 COMTF                 PIC XXX.                                   *
     03 LGTF                  PIC X.                                     *
     03 NORDTF                PIC X(5).                                  *
     03 FILLER                PIC X(5).                                  *
**** TP ****                                                             *
   02 TAXTP REDEFINES TAXIR.                                             *
     03 PGEST                 PIC X(6).                                  *
     03 PSDOS                 PIC X.                                     *
     03 PGEST2                PIC X.                                     *
     03 FILLER                PIC X(6).                                  *
**** TB ****                                                             *
   02 TAXTB REDEFINES TAXIR.                                             *
     03 ARR                   PIC XXX.                                   *
     03 QUAR                  PIC X(4).                                  *
     03 BVIL                  PIC X(5).                                  *
     03 FILLER                PIC XX.                                    *
**** ****                                                                *
 01 W-ACPTE.                                                             *
   02 W-ACPTE1                PIC 9(10).                                 *
   02 W-ACPTE2                PIC 9(2).                                  *
 01 W-ACPTE9 REDEFINES W-ACPTE                                           *
                              PIC 9(12).                                 *
 01 W-MTROLCP                 PIC 9(14)        VALUE 0.                  *
 01 P-POSIUC                  PIC X(19).                                 *
 01 D-POSIUC                  PIC X(19).                                 *
 01 W-FAC.                                                               *
   02 W-FACE                  PIC 9(11)        VALUE 0.                  *
   02 W-CLEFAC                PIC 99           VALUE 0.                  *
 01 W-FAC9 REDEFINES W-FAC    PIC 9(13).                                 *
 01 W-PREMFAC                 PIC 9(13).                                 *
 01 W-DERFAC                  PIC 9(13).                                 *
 01 W-DATADR                  PIC 9(8).                                  *
 01 W1-DATADR.                                                           *
   02 AA-ADR                  PIC 9999.                                  *
   02 MM-ADR                  PIC 99           VALUE 02.                 *
   02 JJ-ADR                  PIC 99           VALUE 01.                 *
 01 W1-DATADR9 REDEFINES W1-DATADR                                       *
                              PIC 9(8).                                  *
 01 W-MER.                                                               *
   02 MER-SSAA                PIC XXXX.                                  *
   02 MER-MMJJ                PIC X(4).                                  *
 01 W-MER9 REDEFINES W-MER    PIC 9(8).                                  *
 01 W-MAJ1.                                                              *
   02 MAJ-MM                  PIC 99.                                    *
   02 MAJ-JJ                  PIC 99.                                    *
 01 W-MAJ2.                                                              *
   02 MAJ-JJ                  PIC 99.                                    *
   02 MAJ-MM                  PIC 99.                                    *
   02 MAJ-AA                  PIC 9999.                                  *
 01 W-MAJ92 REDEFINES W-MAJ2  PIC 9(8).                                  *
 01 W-MAJ3.                                                              *
   02 MAJ-AA                  PIC 9999.                                  *
   02 MAJ-MM                  PIC 99.                                    *
   02 MAJ-JJ                  PIC 99.                                    *
 01 W-MAJ93 REDEFINES W-MAJ3  PIC 9(8).                                  *
 01 W-CURRENTDATE.                                                       *
   02 W-SSAA.                                                            *
     03 W-SS                  PIC 99.                                    *
     03 W-AA                  PIC 99.                                    *
   02 W-EX REDEFINES W-SSAA   PIC 9(4).                                  *
   02 W-MM                    PIC 99.                                    *
   02 W-JJ                    PIC 99.                                    *
 01 DATJ REDEFINES W-CURRENTDATE                                         *
                              PIC 9(8).                                  *
 01 DATRET.                                                              *
   02 JJR                     PIC 99.                                    *
   02 MMR                     PIC 99.                                    *
   02 SSAAR.                                                             *
     03 SSR                   PIC 99.                                    *
     03 AAR                   PIC 99.                                    *
   02 EXR REDEFINES SSAAR     PIC 9(4).                                  *
 01 DATED REDEFINES DATRET    PIC 9(8).                                  *
 01 W-DDAC.                                                              *
   02 DDAC-AA                 PIC 9999.                                  *
   02 DDAC-MM                 PIC 9999.                                  *
 01 W-DDAC9 REDEFINES W-DDAC  PIC 9(8).                                  *
 01 W-POST                    PIC X(5)         VALUE SPACES.             *
 01 W-DEP                     PIC X(2)         VALUE SPACES.             *
 01 W-LIBDEP                  PIC X(30)        VALUE SPACES.             *
 01 LIBPOST.                                                             *
   02 DEBLIBPOST              PIC X(6)         VALUE SPACES.             *
   02 FINLIBPOST              PIC X(30)        VALUE SPACES.             *
 01 ZONLIB                    PIC X(30).                                 *
 01 ZONRUE                    PIC X(30).                                 *
 01 ZONVIL                    PIC X(30).                                 *
 01 ZONTEL                    PIC X(20).                                 *
 01 W-DETDGI.                                                            *
   02 W-DEPDIR.                                                          *
     03 DEPDGI                PIC X(2)         VALUE SPACES.             *
     03 DIRDGI                PIC X            VALUE SPACE.              *
   02 W-AVIDIR                PIC 9(6)         VALUE 0.                  *
   02 W-MONTDIR               PIC 9(12)        VALUE 0.                  *
 01 W-TOTDGI.                                                            *
   02 W-TOTDIR                PIC X(3)         VALUE "999".              *
   02 W-AVITOT                PIC 9(6)         VALUE 0.                  *
   02 W-MONTOT                PIC 9(12)        VALUE 0.                  *
 01 LPAR-NUM.                                                            *
   02 FILLER                  PIC X(45)        VALUE SPACES.             *
   02 CONT-TRAN.                                                         *
     03 Z-PIDS                PIC 9(10).                                 *
     03 FILLER                PIC XXX          VALUE SPACES.             *
     03 Z-DIDS                PIC 9(10).                                 *
     03 FILLER                PIC X(10)        VALUE SPACES.             *
   02 ZIDS-DER                PIC 9(10)        VALUE 0.                  *
   02 FILLER                  PIC X(12)        VALUE SPACES.             *
   02 ZIDS-DERP               PIC 9(10)        VALUE 0.                  *
   02 FILLER                  PIC X(22)        VALUE SPACES.             *
...........................................................
 PROCEDURE DIVISION.                                                     *
 DEBUT.                                                                  *
     MOVE FUNCTION CURRENT-DATE TO W-CURRENTDATE                         *
     MOVE W-JJ TO JJR                                                    *
     MOVE W-MM TO MMR                                                    *
     MOVE W-EX TO EXR                                                    *
     MOVE DATED TO DAT-E                                                 *
     OPEN INPUT RDOCUM RCORTP PSNNOMEN RFLIUC OUTPUT ROLECP              *
        RDOCANO BILAN ROLATP STATDGI INITIALIZE CONTENU-PAR              *
        MEMO-PAR                                                         *
     CALL "SPPAR" USING TABPAR RECDATPB RECDEPDIN RECEN RECFACC          *
        RECIDS RECTADEC2N RECTADEP1N RECTAUN RECTRIPOT FINTAB            *
     MOVE CEN TO CENTRE.                                                 *
................................................................
 LEC-RDOCUM.                                                             *
     READ RDOCUM                                                         *
      END                                                                *
      MOVE HIGH-VALUE TO RD15-POSIUC                                     *
                 NOT                                                     *
       END                                                               *
        ADD 1 TO NBRDOCUM                                                *
                 END-READ.                                               *
     MOVE 0 TO INDDOUB.                                                  *
     IF RD15-POSIUC = HIGH-VALUE                                         *
      GO TO FIN.                                                         *
     IF RD15-POSIUC = D-POSIUC                                           *
      MOVE 1 TO INDDOUB                                                  *
      GO TO COMPAR.                                                      *
     MOVE RD15-POSIUC TO D-POSIUC.                                       *
     IF INDAPP = 1                                                       *
        GO TO COMPAR.                                                    *
 LEC-RCORTP.                                                             *
     IF P-POSIUC = HIGH-VALUE                                            *
        GO TO COMPAR.                                                    *
     READ RCORTP                                                         *
      END                                                                *
      MOVE HIGH-VALUE TO RP01-POSIUC                                     *
                 NOT                                                     *
       END                                                               *
       ADD 1 TO NBRCORTP.                                                *
                                                                         *
     MOVE RP01-POSIUC TO P-POSIUC.                                       *
 COMPAR.                                                                 *
     MOVE 0 TO INDAPP                                                    *
     IF D-POSIUC = P-POSIUC                                              *
       AND                                                               *
        D-POSIUC = HIGH-VALUE                                            *
      GO TO FIN.                                                         *
     IF D-POSIUC = P-POSIUC                                              *
      GO TO LIQUID-ACPTE.                                                *
     IF D-POSIUC > P-POSIUC                                              *
      ADD 1 TO NBNARP                                                    *
      GO TO LEC-RCORTP.                                                  *
     IF D-POSIUC < P-POSIUC                                              *
      MOVE 1 TO INDAPP                                                   *
      ADD 1 TO NBNARD                                                    *
             END-IF.                                                     *
 LIQUID-ACPTE.                                                           *
       IF (RD15-POST NOT = "96030" AND RD15-DGE = "D")                   *
           ADD 1 TO NBDGE                                                *
        GO TO LEC-RDOCUM.                                                *
       IF RD15-ARTCOL = "C"                                              *
           ADD 1 TO NBCOL                                                *
        GO TO LEC-RDOCUM.                                                *
       IF (RD15-MENV (1) NOT = SPACE                                     *
              AND RD15-MENV (1) NOT = "H")                               *
              AND INDAPP = 1                                             *
              ADD 1 TO NBMEN                                             *
        GO TO LEC-RDOCUM.                                                *
*      IF (RD15-PTHV (1) NOT = SPACE                                     *
*         AND RD15-PTHV (1) = "P")                                       *
*             ADD 1 TO NBEXMEN                                           *
*       GO TO LEC-RDOCUM.                                                *
     MOVE 0 TO IND                                                       *
     MOVE 0 TO INDTP                                                     *
     MOVE 0 TO W-CALCUL W-CALCULD W-CALCULI.                             *
 TEST-ROLE-VARIABLE.                                                     *
     ADD 1 TO IND                                                        *
     IF IND > RD15-CPT                                                   *
      GO TO CALCUL-ACPTE.                                                *
     IF RD15-ROLV (IND) NOT = "092"                                      *
      GO TO TEST-ROLE-VARIABLE.                                          *
     IF RD15-CODE (IND) = "I"                                            *
      ADD RD15-DBTV (IND) TO W-CALCULI.                                  *
     IF RD15-CODE (IND) = "D"                                            *
      ADD RD15-DBTV (IND) TO W-CALCULD.                                  *
     GO TO TEST-ROLE-VARIABLE.                                           *
 CALCUL-ACPTE.                                                           *
     IF W-CALCULD > W-CALCULI                                     09/04/08
        IF W-CALCULI >= SEUILTP                                   14/06/18
           IF DITIP = "L" DISPLAY "D > I POUR POSIUC : " D-POSIUC 09/04/10
           END-IF                                                 09/04/10
        END-IF                                                    09/04/10
        CONTINUE                                                  09/04/08
        ELSE                                                      09/04/08
        COMPUTE W-CALCUL = W-CALCULI - W-CALCULD                  09/04/08
     END-IF                                                       09/04/08
     IF INDAPP = 1                                                       *
        IF W-CALCUL >= SEUILTP                                    14/06/18
           PERFORM ECR-RDOCANO                                           *
        END-IF                                                           *
           GO TO LEC-RDOCUM                                              *
      END-IF.                                                            *
     IF W-CALCUL >= SEUILTP                                       14/06/18
      COMPUTE W-ACPTE9 = (W-CALCUL * 50) / 100                           *
      IF W-ACPTE2 > 49                                                   *
         ADD 1 TO W-ACPTE1                                               *
         MOVE 0 TO W-ACPTE2                                              *
      END-IF                                                             *
      IF W-ACPTE2 < 50                                                   *
         MOVE 0 TO W-ACPTE2                                              *
      END-IF                                                             *
      MOVE 1 TO INDTP                                                    *
      ADD 1 TO NBACPTE                                                   *
      ADD W-ACPTE9 TO TOTACPTE.                                          *
 FIN-LIQUID-ACPTE.