Quellcode-Bibliothek

^© Kompilation durch diese Firma

[Weder Korrektheit noch Funktionsfähigkeit der Software werden zugesichert.]

Datei: de027.cob.org.txt Sprache: Text

Original von: verschiedene^©

      * DATA SET: X2H100.PRO.COBOL MEMBER:DE027
      * DATE: 03/03/28 TIME: 18:07:00 PAGE: 1
      * USERID: X2H100
      *PARMMVS ENV=DB2
      *PARMMVS DBRMNAME=DE027
      *PARMMVS COMPILER=COBOL2
      *PARMMVS PARM.DB2=(SOURCE,VERSION(AUTO)
      *PARMMVS PARM.COB=(NOADV,
      *PARMMVS DATA(31),
      *PARMMVS NODYN,
      *PARMMVS MAP, "
      *PARMMVS OFFSET,
      *PARMMVS OPT,
      *PARMMVS RENT,
      *PARMMVS RES,
      *PARMMVS NOTEST,
      *PARMMVS TRUNC(BIN»
      *PARMMVS PARM.LNK=(MAP,RENT,LIST, 'AMODE=31', 'RMODE=ANY')
      *PARMMVS LNK.IN ENTRY DE027
       identification division.
       program-id. de027.
       author. pcam-gt-pbs-credit decisions & surveillance -jd.
       date-written. 7.7.2002.
       date-compiled.
       data division.
       working-storage section.
       77 i pic 9(4).
       77 j pic 9(4).
       77 k pic 9(4).
       77 ind pic 9(4).
       77 pic 9.
         88 nongood-found value 1.
         88 good-found value 0.
       77 pic 9.
         88 nonblank-found value 1.
         88 blank-found value 0.
       77 zeile pic x(132).
       77 ausgabe pic x(132).
       77 aus-ll pic 9(4).
       77 adresse pic 9(12).

       01 kt1240-dummy-dfheiblk pic x.
       01 kt1240-dummy-dfhcommarea pic x.
       01 kt1240-in-interface.
       05 kt1240-h-aufruf-pgm pic x(6).
       05 kt1240-h-count pic 9(3).
       05 filler redefines kt1240-h-count.
         10 kt1240-h-count-x pic x(3).
       05 kt1240-h-text pic x(900).
       05 filler redefines kt1240-h-text.
         10 kt1240-h-tab occurs 9 pic x(100).
       01 kt1240-pgm pic x(8).
       01 kt1240-s9 pic 9(8).
       01 kt1240-s9-1 pic -9(8).
       01 kt1240-s9-2 pic -9(8).
       01 kt1240-s9-tab.
         05 kt1240-s9-ind occurs 256 pic -9(4).
       01 adressfeld-x pic 9(9).
       01 adressfeld-zeile1 pic 9(9).
       01 dummy.
         10 adressfeld   pointer.
         10 adressfeld-c redefines adressfeld
                         pic s9(9) comp.
       01 de026-pgm pic x(8).

       exec sql include sqlca end-exec.

       01 umgebung.
         10 u pic 9.
           88 online value 1.
           88 batch value 2.
         10 db2server pic x(16) value space.
           88 testserver value 'TOOO01'.
           88 abnahmeserver value 'TOOO06'.
           88 produktionsserver value 'POOO04'.
         10 pic 9.
           88 testsystem value 1.
           88 abnahme value 2.
           88 produktion value 3.

       linkage section.

       01 zeile1 pic x(132).
       01 zeile2 pic x(132).
       01 zeile3 pic x(132).
       01 zeile4 pic x(132).
       01 zeile5 pic x(132).

       procedure division using zeile1
                                zeile2
                                zeile3
                                zeile4
                                zeile5.
      * vorsicht: parameterübergabe soll nur "by content" erfolgen, weil
      * der pufferbereich auf blank gesetzt wird!

       main.
       perform init
       move space to ausgabe
       move zero to aus-ll
       set adressfeld to address of zeile1
       move adressfeld-c to adressfeld-zeile1
      *
       move zeile1 to zeile
       perform check
       if k > 0 then move space to zeile1(1:k) end-if
      *
       set adressfeld to address of zeile2
       move adressfeld-c to adressfeld-x
       if adressfeld-x(1:4) = adressfeld-zeile1(1:4)
       and zeile2(1:1) > space and <= '9' then
         move zeile2 to zeile
         perform check
         if k > 0 then move space to zeile2(1:k) end-if
       end-if
      *
       set adressfeld to address of zeile3
       move adressfeld-c to adressfeld-x
       if adressfeld-x(1:4) = adressfeld-zeile1(1:4)
       and zeile3(1:1) > space and <= '9' then
         move zeile3 to zeile
         perform check
         if k > 0 then move space to zeile3(1:k) end-if
       end-if
      *
       set adressfeld to address of zeile4
       move adressfeld-c to adressfeld-x
       if adressfeld-x(1:4) = adressfeld-zeile1(1:4)
       and zeile4(1:1) > space and <= '9' then
         move zeile4 to zeile
         perform check
         if k > 0 then move space to zeile4(1:k) end-if
       end-if
      *
       set adressfeld to address of zeile5
       move adressfeld-c to adressfeld-x
       if adressfeld-x(1:4) = adressfeld-zeile1(1:4)
       and zeile5(1:1) > space and <= '9' then
         move zeile5 to zeile
         perform check
         if k > 0 then move space to zeile5(1:k) end-if
       end-if
      *
       move space to kt1240-h-text
       perform wri-que.
       goback
       .

       init.
       exec sql
         set :db2server = CURRENT SERVER
       end-exec
       move 'de026' to de026-pgm
       call de026-pgm
         on exception goback
       end-call
       if return-code = zero then set batch to true end-if
       if return-code = 16 then set online to true end-if
       .

       check.
       set good-found to true
       perform varying i from 1 by 1 until i > 131
       or nongood-found
         if zeile(i:1) < space then
           set nongood-found to true
           compute j = i -1
           if j < 1 then move 1 to j end-if
         end-if
       end-perform
       if good-found then move 132 to j end-if
       set blank-found to true
       perform varying i from j by -1
               until i < 2 or nonblank-found
         if zeile(i:1) not = space then
           set nonblank-found to true
           compute k = i
           if k <= 1 then move 1 to k end-if
         end-if
       end-perform
       if blank-found then move j to k end-if
       if aus-ll> 0 and< length of ausgabe then
         string ausgabe(1:aus-ll) zeile(1:k)
         delimited by size into ausgabe
         add k to aus-ll
         else
         if aus-ll = zero then
           string zeile(1:k)
           delimited by size into ausgabe
           move k to aus-ll
         end-if
       end-if
       .
       wri-que.
       if batch then
         display ausgabe
       else
         move 1 to kt1240-h-count
         move ausgabe to kt1240-h-tab(1)
         move 'KT1240' to kt1240-pgm
         move 'de027' to kt1240-h-aufruf-pgm

         call kt1240-pgm using kt1240-dummy-dfheiblk
                               kt1240-dummy-dfhcommarea
                               kt1240-in-interface
       end-if
       .
       end-program de027.

¤ Dauer der Verarbeitung: 0.16 Sekunden (vorverarbeitet) ¤

Download des Quellennavigators
Download des sprechenden Kalenders
in der Quellcodebibliothek suchen

Haftungshinweis

Die Informationen auf dieser Webseite wurden nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit, noch Qualität der bereit gestellten Informationen zugesichert.

Bemerkung:

Die farbliche Syntaxdarstellung ist noch experimentell.