      $set ans85 comp noqual noosvs
      ******************************************************************
      *
      * Dialog System Example User Format Program
      *
      * This program is an example of how to write a user format routine
      * to be used with Dialog System. Four user formats are implemented:
      *
      * 1. Horizontal scrolling fields
      * 2. Blank when zero numeric field
      * 3. Clear a numeric field after the first keystroke
      * 4. right justify input into an alphanumeric field
      *
      * This program does not attempt to implement the above in a
      * comprehensive manner or to implement any feature in the most
      * efficient way. The routines are given as an example of what is
      * possible with the user format feature.
      *
      * This module should be used in conjuntion with the screenset
      * DSUSRFMT.S.
      *
      ******************************************************************

       WORKING-STORAGE SECTION.

       COPY "DS-KEY.CPY".

      *

       01 Buffer-Position                   PIC 9(4) COMP.
       01 Source-Ind                        PIC 9(4) COMP.
       01 Target-Ind                        PIC 9(4) COMP.
       01 Move-Length                       PIC 9(4) COMP.

       01 Expect-First-Keystroke            PIC 9(2) COMP.

      *

       LINKAGE SECTION.

       COPY "DS-USER.CPY".

       01 Ds-Field-Buffer.
         03 Field-Buffer-Comp              PIC 9(2) COMP OCCURS 9999.

       01 DS-Data-Block                    pic x.
      *

       PROCEDURE DIVISION USING Ds-User-Linkage Ds-Field-Buffer
                                       DS-Data-Block.
       Main-Section.
           EVALUATE Ds-User-Format-Number

             When Ds-User-Fmt-1

               PERFORM Process-Horizontal-Scrolling

             When Ds-User-Fmt-2

               PERFORM Process-Blank-When-Zero

             When Ds-User-Fmt-3

               PERFORM Process-Clear-After-Key

             When Ds-User-Fmt-4

               PERFORM Process-Right-Justification

           END-EVALUATE

           EXIT PROGRAM.

      /*****************************************************************
      * Horizontal scrolling routines.
      *
      * Gives basic field scrolling for alphanumeric and numeric fields.
      *
      ******************************************************************

       Process-Horizontal-Scrolling SECTION.

           EVALUATE Ds-Access-flag

             WHEN Ds-Initialise-Field

               MOVE 1 TO Ds-Buffer-Screen-Offset
               MOVE 1 TO Ds-Cursor-Position

             WHEN Ds-Normal-Access

               MOVE 0 TO Ds-Do-Internal-Formatting
               MOVE 1 TO Ds-Display-Field-Flag
               MOVE 1 TO Ds-Display-Cursor-Flag

               MOVE Ds-Buffer-Screen-Offset TO Buffer-Position
               ADD Ds-Cursor-Position TO Buffer-Position
               SUBTRACT 1 FROM Buffer-Position

               EVALUATE Ds-Screen-Format

                 WHEN Ds-Screen-Alphanumeric

                   PERFORM Process-Alpha-Scrolling

                 WHEN Ds-Screen-Numeric

                   PERFORM Process-Numeric-Scrolling

               END-EVALUATE

           END-EVALUATE.

      ******************************************************************

       Process-Alpha-Scrolling SECTION.

           EVALUATE Ds-Key-Type

             WHEN Ds-Function-Key

               EVALUATE Ds-Key-Description

                 WHEN Cursor-Left-Key

                   PERFORM Move-Cursor-Left

                 WHEN Cursor-Right-Key

                   PERFORM Move-Cursor-Right

                 WHEN Del-Key

                   PERFORM VARYING Target-Ind FROM buffer-Position BY 1
                           UNTIL Target-Ind = Ds-Buffer-Length

                      MOVE Target-Ind TO Source-Ind
                      ADD 1 TO Source-Ind
                      MOVE Ds-Field-Buffer(Source-Ind : 1) TO
                                        Ds-Field-Buffer(Target-Ind : 1)

                   END-PERFORM
                   MOVE SPACE TO Ds-Field-Buffer(Ds-Buffer-Length : 1)

               END-EVALUATE

             WHEN Ds-Data-Key

               IF Ds-Lock-State > 7
                 PERFORM VARYING Target-Ind FROM dS-buffer-Length BY -1
                         UNTIL Target-Ind = Buffer-Position

                    MOVE Target-Ind TO Source-Ind
                    SUBTRACT 1 FROM Source-Ind
                    MOVE Ds-Field-Buffer(Source-Ind : 1) TO
                                         Ds-Field-Buffer(Target-Ind : 1)

                 END-PERFORM
               END-IF
               MOVE Ds-Key-Description-X TO
                             Ds-Field-Buffer(Buffer-Position : 1)
               PERFORM Move-Cursor-Right


           END-EVALUATE.


      ******************************************************************

       Process-Numeric-Scrolling SECTION.

           EVALUATE Ds-Key-Type

             WHEN Ds-Function-Key

               EVALUATE Ds-Key-Description

                 WHEN Cursor-Left-Key

                   PERFORM Move-Cursor-Left
                   IF Buffer-Position > 1
                       SUBTRACT 1 FROM Buffer-Position
                       IF Ds-Field-Buffer(Buffer-Position : 1) = "."
                         PERFORM Move-Cursor-Left
                       END-IF
                   END-IF

                 WHEN Cursor-Right-Key

                   PERFORM Move-Cursor-Right
                   IF Buffer-Position < DS-Buffer-Length
                       ADD 1 TO Buffer-Position
                       IF Ds-Field-Buffer(Buffer-Position : 1) = "."
                           PERFORM Move-Cursor-Right
                       END-IF
                   END-IF

                 WHEN Del-Key

                   MOVE "0" TO Ds-Field-Buffer(Buffer-Position : 1)

               END-EVALUATE

             WHEN Ds-Data-Key

               EVALUATE Ds-Key-Description-X

                 WHEN "-"

                   MOVE ZERO TO Ds-Sign-Value

                 WHEN "+"

                   MOVE 1 TO Ds-Sign-Value

                 WHEN OTHER

                   IF Ds-Key-Description < 48 OR Ds-Key-Description > 57
                     CALL X"E5"
                   ELSE
                     IF Ds-Field-Buffer(Buffer-Position : 1) = "."
                       PERFORM Move-Cursor-Right
                       ADD 1 TO Buffer-Position
                     END-IF
                     MOVE Ds-Key-Description-X TO
                                 Ds-Field-Buffer(Buffer-Position : 1)
                     PERFORM Move-Cursor-Right
                   END-IF

               END-EVALUATE

           END-EVALUATE.

      ******************************************************************

       Move-Cursor-Left SECTION.

           IF Ds-Cursor-Position = 1
             IF Ds-Buffer-Screen-Offset = 1
               MOVE 1 TO Ds-Autoskip-Left
             ELSE
               SUBTRACT 1 FROM Ds-Buffer-Screen-Offset
             END-IF
           ELSE
             SUBTRACT 1 FROM Ds-Cursor-Position
           END-IF.

      ******************************************************************

       Move-Cursor-Right SECTION.

           IF Ds-Cursor-Position = Ds-Field-Screen-Length
             IF Buffer-Position = Ds-Buffer-Length
               MOVE 1 TO Ds-Autoskip-Right
             ELSE
               ADD 1 TO Ds-Buffer-Screen-Offset
             END-IF
           ELSE
             ADD 1 TO Ds-Cursor-Position
           END-IF.

      /*****************************************************************
      * Blank when zero routines
      *
      * Gives blank when zero facility for a numeric field
      *
      ******************************************************************

       Process-Blank-When-Zero SECTION.

           EVALUATE Ds-Access-flag

             WHEN Ds-Terminate-Field
             WHEN Ds-Initialise-Field

               PERFORM Check-For-Zero-And-Blank

             WHEN Ds-Normal-Access

               CONTINUE

           END-EVALUATE.

      ******************************************************************

       Check-For-Zero-And-Blank SECTION.

           IF Ds-Field-Buffer(1 : Ds-Buffer-Length) NOT = SPACES
             MOVE 1 TO Source-Ind
             PERFORM UNTIL
                       (Source-Ind > Ds-Buffer-Length) OR
                       ((Ds-Field-Buffer(Source-Ind : 1) NOT = "." AND
                         Ds-Field-Buffer(Source-Ind : 1) NOT = SPACE AND
                         Ds-Field-Buffer(Source-Ind : 1) NOT = "0"))

               ADD 1 TO Source-Ind

             END-PERFORM
             IF Source-Ind > Ds-Buffer-Length
               MOVE 1 TO Ds-Sign-Value
               MOVE SPACES TO Ds-Field-Buffer(1 : Ds-Buffer-Length)
             ELSE
               PERFORM VARYING Source-Ind FROM 1 BY 1 UNTIL
                                          Source-Ind > Ds-Buffer-Length

                 IF Ds-Field-Buffer(Source-Ind : 1) = SPACE
                   MOVE "0" TO Ds-Field-Buffer(Source-Ind : 1)
                 END-IF

               END-PERFORM
               IF Ds-Decimal-Length > ZERO
                 MOVE Ds-Length TO Source-Ind
                 ADD 1 TO Source-Ind
                 MOVE "." TO Ds-Field-Buffer(Source-Ind : 1)
               END-IF
             END-IF
             MOVE 1 TO Ds-Display-Field-Flag
             MOVE 1 TO Ds-Display-Cursor-Flag.

      /*****************************************************************
      *
      * Clear field after first data key stroke on a numeric field
      *
      ******************************************************************

       Process-Clear-After-Key SECTION.

           EVALUATE Ds-Access-flag

             WHEN Ds-Initialise-Field

               MOVE 1 TO Expect-First-Keystroke

             WHEN Ds-Normal-Access

               IF (Expect-First-Keystroke = 1) AND
                  (Ds-Key-Type = Ds-Data-Key) AND
                  (Ds-Key-Description NOT < 48) AND
                  (Ds-Key-Description NOT > 57)
                 PERFORM Clear-Field
                 MOVE 0 TO Expect-First-Keystroke
               END-IF

           END-EVALUATE.

      ******************************************************************

       Clear-Field SECTION.

           MOVE ALL ZEROS TO Ds-Field-Buffer(1 : Ds-Buffer-Length)
           IF Ds-Decimal-Length > 0
             MOVE Ds-Length TO Source-Ind
             ADD 1 TO Source-Ind
             MOVE "." TO Ds-Field-Buffer(Source-Ind : 1)
           END-IF
           MOVE 1 TO Ds-Sign-Value
           MOVE 1 TO Ds-Cursor-Position
           MOVE 1 TO Ds-Display-Field-Flag
           MOVE 1 TO Ds-Display-Cursor-Flag.

      /*****************************************************************
      *
      * Right justify input into an alphanumeric field.
      *
      ******************************************************************

       Process-Right-Justification SECTION.

           EVALUATE Ds-Access-flag

             WHEN Ds-Initialise-Field
             WHEN Ds-Terminate-Field

               IF Ds-Field-Buffer(1 : Ds-Buffer-Length) NOT = SPACES
                     AND Ds-Field-Buffer(Ds-Buffer-Length:1) = SPACE
                 PERFORM Justify-Field
               END-IF

           END-EVALUATE.

      ******************************************************************

       Justify-Field SECTION.

           PERFORM VARYING Source-Ind FROM Ds-Buffer-Length BY -1 UNTIL
                            Ds-Field-Buffer(Source-Ind : 1) NOT = SPACE

             CONTINUE

           END-PERFORM
           MOVE Source-Ind TO Move-Length
           MOVE Ds-Buffer-Length TO Target-Ind
           PERFORM Move-Length TIMES

             MOVE Ds-Field-Buffer(Source-Ind : 1) TO
                             Ds-Field-Buffer(Target-Ind : 1)
             SUBTRACT 1 FROM Source-Ind
             SUBTRACT 1 FROM Target-Ind

           END-PERFORM
           MOVE Move-Length TO Source-Ind
           MOVE Ds-Buffer-Length TO Move-Length
           SUBTRACT Source-Ind FROM Move-Length
           MOVE SPACES TO Ds-Field-Buffer(1 : Move-Length)
           MOVE 1 TO Ds-Display-Field-Flag
           MOVE 1 TO Ds-Display-Cursor-Flag.


