Como já não aceitava mais vai neste Post o código para a "New Procedure" GETXMLFIELD":
Código COBOL:
ENVIRONMENT DIVISION.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 WFIELDSEARCH PIC X(0128).
01 WFIELDSEARCHEND PIC X(0128).
01 XMLIDX.
03 XMLIDX1 PIC S9(009).
03 XMLIDX2 PIC S9(009).
03 XMLIDX3 PIC S9(009).
03 XMLIDX8 PIC S9(009).
03 XMLIDX9 PIC S9(009).
*
PROCEDURE DIVISION.
MAIN SECTION.
MAIN-00.
*
INITIALIZE XMLIDX WFIELDSEARCH WFIELDSEARCHEND XMLFIELDRESULT.
IF XMLLINHA = SPACE GO TO MAIN-99-EXIT.
IF XMLFIELDSEARCH = SPACE GO TO MAIN-99-EXIT.
MOVE "<" TO WFIELDSEARCH.
MOVE XMLFIELDSEARCH TO WFIELDSEARCH(2:)
PERFORM VARYING XMLIDX8 FROM 128 BY -1 UNTIL XMLIDX8 < 1
IF WFIELDSEARCH(XMLIDX8:1) NOT = SPACE
ADD 1 TO XMLIDX8
MOVE ">" TO WFIELDSEARCH(XMLIDX8:1)
EXIT PERFORM
END-IF
END-PERFORM.
* SUBTRACT XMLIDX8 FROM 128 GIVING XMLIDX8.
MOVE "</" TO WFIELDSEARCHEND.
MOVE WFIELDSEARCH(2:) TO WFIELDSEARCHEND(3:).
MOVE XMLIDX8 TO XMLIDX9.
ADD 1 TO XMLIDX9.
MAIN-05.
PERFORM VARYING XMLIDX1 FROM 1 BY 1 UNTIL XMLIDX1 > 8196
IF XMLLINHA(XMLIDX1:XMLIDX8) = WFIELDSEARCH
ADD XMLIDX8 TO XMLIDX1
EXIT PERFORM
END-IF
END-PERFORM
IF XMLIDX1 > 8195 GO TO MAIN-99-EXIT.
PERFORM VARYING XMLIDX2 FROM XMLIDX1 BY 1 UNTIL XMLIDX2 > 8196
IF XMLLINHA(XMLIDX2:XMLIDX9) = WFIELDSEARCHEND
ADD 1 TO XMLIDX2
EXIT PERFORM
END-IF
IF XMLLINHA(XMLIDX2:1) = "<"
MOVE "<" TO XMLFIELDRESULT
MOVE 8186 TO XMLIDX2
EXIT PERFORM
END-IF
END-PERFORM
IF XMLIDX2 > 8195 GO TO MAIN-99-EXIT.
SUBTRACT 1 FROM XMLIDX2.
SUBTRACT XMLIDX1 FROM XMLIDX2 GIVING XMLIDX3.
MOVE XMLLINHA(XMLIDX1:XMLIDX3) TO XMLFIELDRESULT.
MAIN-99-EXIT.
EXIT PROGRAM.