RPG Writing XML

Before XML-INTO RPG and a database could generate XML documents.

This is an example of an XML document being prepared by an application written in RPG. The XML tags are stored in a database file keyed by trading partner and form. The program reads the records, parsing the tags and scanning for replacement variables.

     H/TITLE ** ADM275RP Format 856 XML **
     H DEBUG(*YES)
     H OPTION(*SRCSTMT : *NODEBUGIO) DFTACTGRP(*NO) ACTGRP('QILE')
     H BNDDIR('SOFTCODE')
      ****************************************************************
      * PROGRAM NAME - ADM275RP                                      *
      *                                                              *
      * FUNCTION     - This program prepares an ASN for EDI trading  *
      *                partners through FurnishNet.                  *
      *                                                              *
      * PROGRAMMER   - STEVE CROY 05/05/2009                         *
      ****************************************************************
      ****************************************************************
      *                   MODIFICATION LOG                           *
      *                                                              *
      *    DATE   PROGRAMMER      DESCRIPTION                        *
      *                                                              *
      ****************************************************************
     FGPORTAFL  UF   E           K DISK
     FGPORPCFH  UF   E           K DISK
     FADMTPDL2  IF   E           K DISK
     FEDPHDRLG  IF   E           K DISK
     FEDPDTLLA  IF   E           K DISK
     FADMTPCPF  IF   E           K DISK
     FADMXMLPF  IF   E           K DISK
     FEDP025L3  IF   E           K DISK
     FtermspPF  IF   E           K DISK
     FFRCHDESC  IF   E           K DISK
     FEDP020l09 IF   E           K DISK
     Fp4010sach iF   E           K DISK    prefix(IN_)
     F                                     RENAME(sac:sach)
     Fedp915l1  if   e           K DISK
     Fedp850L3  UF   E           K DISK
     FEDPCUSTMl1IF   E           K DISK
     FEDP010    IF   E           K DISK    prefix(C_)
     FCMNTPEPF  IF   E           K DISK
     FSHPVIAPA  IF   E           K DISK
     FADM856PF  O    F  500        DISK


    ‚ /copy qrpglesrc,swcmmn_PR

     D CheckContact    PR

     **************************
      ** Define Data Structures
     **************************
     D PGMDS         ESDS                  EXTNAME(SWPSTSP)

     DSAVREC         E DS                  Extname(ADMXMLPF) INZ PREFIX(S_)
     DTAGREC         E DS                  Extname(ADMXMLPF) INZ

     D OutRec          DS
     D  DataOut                1    500

     D                 DS
     D  DESC                   1     24
     D  DESC1                  1     12
     D  DESC2                 13     24
     D                 DS
     D  VNDR#                  1      9
     D  VNDR1                  1      3
     D  VNDR2                  4      9
     D                 DS
     D  DUNS                   1     13
     D  DUNS1                  1      9
     D  STOR2                 10     13
     **************************
      *  Define Stand Alone Fields
     **************************
      *
     D ASNMethod       S             10a   inz('Motor')
     D ASNFrtTerms     S             10a
     D ASNCarrier      S             25a
     D ASNDays         S             10a
     DKEYGRP           S             48
     Dgrpflag          S              1    INZ(' ')
     D x               S              2  0
     D y               S              2  0
     D@huccea          S             15
     D PO850           S              1
      *
     D Department      S             30a
     D MercType        S             30a
     D intID           S             15a
     D tradID          S              9a
     D in_pono         S             22a
     D discgiven       S              4  2
     D ThisDate        S              8  0
     D ThisTime        S              6  0
     D DataString      S            500
     D NewValue        S            128
     d qt              s              1a   inz(X'7D')
     d dqt             s              1a   inz(X'7F')
     D r               S              5  0
     D UCCEA           S             15A
     D gotpo           S             10A
     D wrkpo#          S             22A

     D XMLVersion      s              5S 2 inz(1.0)
     D XMLDoc          s              3a   inz('856')
     D XMLHdr          s              3a   inz('HDR')
     D XMLDtl          s              3a   inz('ITM')
     D XMLTot          s              3a   inz('TOT')
     D XMLTagID        s             10a
     D EndXMLtag       s            128a
     D upcitm          s             10a   inz('ITEM')
     D upcqlf          s              2a   inz('UP')
     D wrk6            s              6a

      ** inicators
     D Set856Found     S               n
     D ShipToStore     S               n
     D CreateNewASN    s               n
     D ShipViaFound    s               n
     D UseTag          s               n
     D WriteXML        s               n
      ** dates
     D ASNDate         S               d
     D InvoiceDate     S               d
     D InvoiceDue      S               d
     D DueDate         S              8  0
     D ItemTotal       S             11  2
     D ItemsInvoiced   S              9  0
     D SPInstructions  S             74a
     D SPIrec          S              2  0 inz(33)
     D ItemsShipped    S              5  0
     D ThisVia         S              4  0
     D PartialShip     S              1
     D OriginalInv     S              8  0
     D Work8a          S              8a
     D pieceID         S             20a
     D seller          S             20a   inz('ISOFTWERKS')
     D ThisFrame       S             10a

      ** DUNS NUMBERS
     DCO1RM2           S              9    INZ('000000000')
     DCO2RM2           S              9    INZ('000000001')
     DCO3RM2           S              9    INZ('000000002')
     DCO4RM2           S              9    INZ('000000003')
     DCO5RM2           S              9    INZ('000000004')
     DCO6RM2           S              9    INZ('000000005')

     d formatXML       PR           500
     d formatString    PR
     d   NewValue                   128
     D ADM275RP        PR
     D  p_CMP                         2    CONST
     D  p_OID                         8  0 CONST

     D ADM275RP        PI
     D  p_CMP                         2    CONST
     D  p_OID                         8  0 CONST
      *------------------------------*
      *    MAIN PROCESSING LOOP
      *------------------------------*

         ThisDate = DateToday()                                     ;
         ThisTime = TimeNow()                                       ;
         Department = *blanks                                       ;
         MercType = *blanks                                         ;
         uccea = *blanks                                            ;
         Set856Found = *off                                         ;
         ShipToStore = *off                                         ;

         //*----------------------------------------------------------        
         //*- Skip invoice if it was not transmitted via EDI.
         //*----------------------------------------------------------       
         CHAIN (p_CMP:p_OID) GPORTAFL;

         IF %found(GPORTAFL);
            uccea = shpnoh;
         IF uccea <> *blanks;
            CHAIN (EXW10HOE:uccea) EDPCUSTML1;  // find store
            ShipToStore = %found(EDPCUSTML1);
         ENDIF;

         evalr gotpo = cstorz;
         wrkpo# = gotpo;
         PO850 = 'N';
         intid = EXW10HOE;
         tradid = EXW10HOE;
         CreateNewASN  = *off;
         CHAIN (compnz:extw1h) EDPHDRLG;
         IF %found(EDPHDRLG);
            CreateNewASN  = *on;
         ENDIF;
         IF CreateNewASN ;
            department = '0' + hdptno;
            evalr merctype = hmctyp;

            CHAIN (intid:compnz) ADMTPCPF;
            CHAIN (compnz:SPIrec:invnoz) CMNTPEPF;
            IF %found(CMNTPEPF);
               SPInstructions = cmntle;
            ELSE;
               SPInstructions = '*NONE';
            ENDIF;
            ThisVia = shpvaz;
            CHAIN ThisVia SHPVIAPA;
            IF %found(SHPVIAPA);
               ShipViaFound = *ON;
               ASNDays = exsw1s;
               IF ASNDays = *blank;
                  ASNDays = '2';
               ENDIF;
               ASNCarrier = shpdss;
               IF shpvas = 22;
                  ASNMethod = *blanks;
               ELSE;
                  ASNMethod = 'Motor';
               ENDIF;
               SELECT;
                 WHEN mthpms = 'PP';
                      ASNFrtTerms = 'PrePaid';
                 WHEN mthpms = 'CC';
                      ASNFrtTerms = 'Collect';
                 OTHER;
                      ASNFrtTerms = *BLANK;
               ENDSL;
            ELSE;
               ShipViaFound = *off;
            ENDIF;
            CHAIN compnz EDP010;
            CHAIN termsz TERMSPPF;
            IF extd3h = 0;
               extd3h = ThisDate;
            ENDIF;
            IF sdateh = 0;
               sdateh = ThisDate;
            ENDIF;
            InvoiceDate = %date(extd3h:*ISO);
            InvoiceDue = InvoiceDate + %days(trmda9);
            DueDate = %dec(InvoiceDue:*ISO);
            ASNDate = %date(ThisDate:*ISO);
            ItemsShipped = orqtyz - boqtyz;
         //*----------------------------------------------------------        
         //*- Get header tags: Buyer/seller/ship-to XML tags
         //*----------------------------------------------------------       
               XMLtagID = '856DOC'                                   ;
               SETLL (intid:XMLdoc:XMLhdr) ADMTPDL2                  ;
               DOU %eof(ADMTPDL2)                                    ;
                   READE ( intid:XMLdoc:XMLhdr) ADMTPDL2             ;
                   IF not %eof(ADMTPDL2)                             ;
                   SETLL (docver:doctag) ADMXMLPF                    ;
                   DOU %eof(ADMXMLPF)                                ;
                       READE (docver:doctag) ADMXMLPF                ;
                       IF not %eof(ADMXMLPF)                         ;
                          UseTag = *ON                               ;
                          IF XMLTAG = '810SHPE'                      ; // Check for Contact
                             IF xcntnq <> *BLANKS                    ;
                                savrec = tagrec                      ;
                                CheckContact()                       ;
                                tagrec = savrec                      ;
                             ENDIF                                   ;
                          ENDIF                                      ;
                          IF UseTag;
                             DataOut = formatXML()                   ;
                             IF WriteXML                             ;
                                WRITE ADM856PF OutRec                ;
                             ENDIF                                   ;
                          ENDIF                                      ;
                       ENDIF                                         ;
                   ENDDO                                             ;
                   ENDIF                                             ;
               ENDDO                                                 ;
         //*----------------------------------------------------------      
         //*- Get detail tags: Read order detail and item tags
         //*----------------------------------------------------------                      ItemTotal = 0                                         ;
               ItemsInvoiced = 0                                     ;
               SETLL (p_CMP:p_OID) GPORPCFH                          ;
               DOU %eof(GPORPCFH)                                    ;
                   READE (p_cmp:p_OID) GPORPCFH                      ;
                   IF not %eof(GPORPCFH)                             ;
                      thisFrame = %char(framec)                      ;
                      ItemTotal = ItemTotal + (slprcc * orqtyc)      ;
                      ItemsInvoiced = ItemsInvoiced + orqtyc         ;
                      CHAIN (extw1h:thisFrame:covr1c:
                             colr1c:covr2c:colr2c) EDPDTLLA          ;
                      CHAIN (tradid:framec:covr1c:
                             colr1c:covr2c:colr2c) EDP025L3          ;
                      SETLL ( intid:XMLdoc:XMLdtl) ADMTPDL2          ;
                      DOU %eof(ADMTPDL2)                             ;
                          READE ( intid:XMLdoc:XMLdtl) ADMTPDL2      ;
                          IF not %eof(ADMTPDL2)                      ;
                          SETLL (docver:doctag) ADMXMLPF             ;
                          DOU %eof(ADMXMLPF)                         ;
                              READE (docver:doctag) ADMXMLPF         ;
                              IF not %eof(ADMXMLPF)                  ;
                                 UseTag = *ON                        ;
                                 IF UseTag                           ;
                                     DataOut = formatXML()           ;
                                    IF WriteXML                      ;
                                       WRITE ADM856PF OutRec         ;
                                    ENDIF                            ;
                                 ENDIF                               ;
                              ENDIF                                  ;
                          ENDDO                                      ;
                          ENDIF                                      ;
                      ENDDO                                          ;
                   ENDIF                                             ;
               ENDDO                                                 ;
         //*----------------------------------------------------------        
         //*- Prepare summary tags
         //*----------------------------------------------------------      
               XMLtagID = '856DOC'                                   ;
               SETLL ( intid:XMLdoc:XMLtot) ADMTPDL2                 ;
               DOU %eof(ADMTPDL2)                                    ;
                   READE ( intid:XMLdoc:XMLtot) ADMTPDL2             ;
                   IF not %eof(ADMTPDL2)                             ;
                   SETLL (docver:doctag) ADMXMLPF                    ;
                   DOU %eof(ADMXMLPF)                                ;
                       READE (docver:doctag) ADMXMLPF                ;
                       IF not %eof(ADMXMLPF)                         ;
                          UseTag = *ON                               ;
                          IF UseTag                                  ;
                             DataOut = formatXML()                   ;
                             IF WriteXML                             ;
                                WRITE ADM856PF OutRec                ;
                             ENDIF                                   ;
                          ENDIF                                      ;
                       ENDIF                                         ;
                   ENDDO                                             ;
                   ENDIF                                             ;
               ENDDO                                                 ;

                IF ItemsShipped <> orqtyc                            ;
                   PartialShip = 'Y'                                 ;
                ELSE                                                 ;
                   PartialShip = 'N'                                 ;
                ENDIF                                                ;
           ENDIF;

         ENDIF;
         *INLR = *ON;
         RETURN;

      *---------------------------------------------------------------------
      * Parse the XML Statement
      *---------------------------------------------------------------------
     p formatXML       B                   
     d formatXML       PI           500
     D e               s              3  0
     D o               s              3  0
     D l               s              3  0
     D x               s              3  0
     D s               s              3  0
     D i               s              3  0
     D workString      s            128
     D Replacement     s             10
     D DateValue       s             10
     D Attribute       s            128
     D tagEnd          s            128
     D QuoteString     s              1

      /free

        WriteXML = *ON                                               ;
        DataString = *blanks                                         ;
        r = %scan('&':xmldta:1)                                      ;
        IF r > 0                                                     ;
        DataString = %subst(xmldta:1:r-1)                            ; // get XML
        WorkString = %subst(xmldta:r)                                ;
        DOU r = 0                                                    ;
           s = %scan(' ':workString)                                 ; // scan for space
           l = (s - 1)                                               ;
           Replacement = %subst(workString:1:l)                      ;
           NewValue = *blanks                                        ;
           SELECT                                                    ;
           WHEN Replacement = '&NOTUSED'                             ;
                WriteXML = *OFF                                      ;  // invoice number
           WHEN Replacement = '&ASNREF'                              ;
                NewValue = %trim(%char(invnoz))                      ;
           WHEN Replacement = '&ASNORD'                              ;
                NewValue = %trim(%char(invnoz))                      ;
           WHEN Replacement = '&DOCTYP'                              ;
                NewValue = 'Original'                                ;
           WHEN Replacement = '&ASNDTE'                              ;
                NewValue  = %editw(ThisDate:'    -  -  ')            ;
           WHEN Replacement = '&ASNTIM'                              ;
                wrk6 = %editc(ThisTime:'X')                          ;
                NewValue = %subst(wrk6:1:2) + ':' + %subst(wrk6:3:2) +
                            ':' + %subst(wrk6:5:2)                   ;
           WHEN Replacement = '&INVDTE'                              ;
                NewValue  = %editw(extd3h:'    -  -  ')              ;  // invoice date
           WHEN Replacement = '&SHPDTE'                              ;
                NewValue  = %editw(sdateh:'    -  -  ')              ;  // ship date
           WHEN Replacement = '&PARTNER'                             ;
                NewValue = %trim( intid)                             ;
          //---------------------------------------------------------> Bill to
           WHEN Replacement = '&BTNAM'                               ;
                NewValue = %trim(bllnmz)                             ;
           WHEN Replacement = '&BSTORE'                              ;
                NewValue = %trim( intid)                             ;
           WHEN Replacement = '&BYRPO'                               ;
                NewValue = %trim(cstorz)                             ;
           WHEN Replacement = '&REFDTE'                              ;
                NewValue  = %editw(hpopdt:'    -  -  ')              ;
           WHEN Replacement = '&LINE'                                ;
                NewValue = %trim(%char(recnoc))                      ;
           WHEN Replacement = '&ITEM'                                ;
                NewValue = %trim(dcitem)                             ;
           WHEN Replacement = '&UOM'                                 ;
                NewValue = 'Each'                                    ;
           WHEN Replacement = '&QTY'                                 ;
                NewValue = %trim(%editC(orqtyc:'3'))                 ;
           WHEN Replacement = '&UNTSHP'                              ;
                NewValue = %trim(%editC(skunoc:'3'))                 ;
           WHEN Replacement = '&PRICE'                               ;
                NewValue = %trim(%editC(slprcc:'3'))                 ;
           WHEN Replacement = '&LSTUPD'                              ;
                IF exdt7h = 0                                        ;
                   WriteXML = *OFF                                   ;
                ELSE;
                   NewValue  = %editw(exdt7h:'    -  -  ')           ;
                ENDIF;
           WHEN Replacement = '&BOLDTE'                              ;
                   WriteXML = *OFF                                   ;
           WHEN Replacement = '&BOL'                                 ;
                   WriteXML = *OFF                                   ;
           WHEN Replacement = '&INVNBR'                              ;
                NewValue = %trim(%char(invnoz))                      ;  // invoice number
           WHEN Replacement = '&REFDTE'                              ;
                NewValue  = %editw(extd3h:'    -  -  ')              ;
           WHEN Replacement = '&INVLIN'                              ; //Seller line number
                NewValue = %trim(%char(recnoc))                      ;
           WHEN Replacement = '&ORDLIN'                              ; //Buyer line number
                NewValue = %trim(%char(recnoc))                      ;
           WHEN Replacement = '&ALWNBR'                              ;
                IF advcdh <> *blanks                                 ;
                NewValue = %trim(advcdh)                             ;
                ELSE                                                 ;
                   WriteXML = *OFF                                   ;
                ENDIF                                                ;
           //--------------------------------------------------------> Buyer
           WHEN Replacement = '&BYNAM'                               ;
                NewValue = %trim(bllnmz)                             ;
           WHEN Replacement = '&BYPART'                              ;
                NewValue = %trim( intid)                             ;
           WHEN Replacement = '&BSTORE'                              ;
                NewValue = %trim(%char(cstnoh))                      ;
           WHEN Replacement = '&BYAD1'                               ;
                NewValue = %trim(blad1z)                             ;
           WHEN Replacement = '&BYAD2'                               ;
                   WriteXML = *OFF                                   ;
           WHEN Replacement = '&BYCTY'                               ;
                NewValue = %trim(blctyz)                             ;
           WHEN Replacement = '&BYST'                                ;
                NewValue = %trim(blstaz)                             ;
           WHEN Replacement = '&BYZIP'                               ;
                NewValue = %editc(blzipz:'X')                        ;
           WHEN Replacement = '&BYCTRY'                              ;
                WriteXML = *off                                      ;
           WHEN Replacement = '&NOTE1'                               ;
                NewValue = %trim(hnote1)                             ;
           WHEN Replacement = '&BTID'                                ;
                NewValue = %trim(hintid)                             ;
           WHEN Replacement = '&BSTORE'                              ;
                NewValue = %char(cstnoh)                             ;
           WHEN Replacement = '&BTAD1'                               ;
                NewValue = %trim(blad1z)                             ;
           WHEN Replacement = '&BTAD2'                               ;
                   WriteXML = *OFF                                   ;
           WHEN Replacement = '&BTCTY'                               ;
                NewValue = %trim(blctyz)                             ;
           WHEN Replacement = '&BTSTA'                               ;
                NewValue = %trim(blstaz)                             ;
           WHEN Replacement = '&BTZIP'                               ;
                NewValue = %editc(blzipz:'X')                        ;
           WHEN Replacement = '&BTCTRY'                              ;
                NewValue = 'USA'                                     ;
           //*-------------------------------------------------------> Order qty
           WHEN Replacement = '&CARNAM'                              ;
                NewValue = %trim(ASNCarrier)                         ;
           WHEN Replacement = '&ASNMTD'                              ;
                NewValue = %trim(ASNMethod)                          ;
                IF NewValue = *blanks                                ;
                      WriteXML = *OFF                                ;
                ENDIF                                                ;
           WHEN Replacement = '&TRNDAY'                              ;
                NewValue = %trim(ASNDays)                            ;
           WHEN Replacement = '&ASNFRT'                              ;
                NewValue = %trim(ASNFrtTerms)                        ;
                IF NewValue = *blanks                                ;
                      WriteXML = *OFF                                ;
                ENDIF                                                ;
           WHEN Replacement = '&QTYSHP'                              ;
                NewValue = %trim(%editC(ItemsShipped:'3'))           ;
           WHEN Replacement = '&QTYORD'                              ;
                NewValue = %trim(%editC(orqtyz:'3'))                 ;
           WHEN Replacement = '&PRTSHP'                              ;
                IF ItemsShipped <> orqtyz                            ;
                   NewValue = '1'                                    ;
                ELSE                                                 ;
                   NewValue = '0'                                    ;
                ENDIF                                                ;
           //*-------------------------------------------------------> Seller
           WHEN Replacement = '&IAVND'                               ;
                NewValue =  %trim(tpinpi)                            ;
           WHEN Replacement = '&SLRID'                               ;
                NewValue =  %trim(tpinpi)                            ;
           WHEN Replacement = '&SLRNAM'                              ;
                NewValue =  %trim(c_stnam)                           ;
           WHEN Replacement = '&SLRAD1'                              ;
                NewValue =  %trim(c_stad1)                           ;
           WHEN Replacement = '&SLRCTY'                              ;
                NewValue =  %trim(c_stcty)                           ;
           WHEN Replacement = '&SLRSTA'                              ;
                NewValue =  %trim(c_ststa)                           ;
           WHEN Replacement = '&SLRZIP'                              ;
                NewValue =  %trim(c_stzip)                           ;
           //*-------------------------------------------------------> Ship-to
           WHEN Replacement = '&CMNT'                                ;
                NewValue = %trim(SPInstructions)                     ;
           WHEN Replacement = '&STRID'                               ; // store
                   NewValue = %trim(hshpno)                          ;
           WHEN Replacement = '&SHPSTR'                              ;
                NewValue =  %trim(hshpno)                            ;
           WHEN Replacement = '&SHPNAM'                              ;
                NewValue =  %trim(shplnh)                            ;
           WHEN Replacement = '&SHPAD1'                              ;
                NewValue =  %trim(shpadh)                            ;
           WHEN Replacement = '&SHPAD2'                              ;
                IF shpa2h <> *blanks                                 ;
                   NewValue =  %trim(shpa2h)                         ;
                ELSE                                                 ;
                   WriteXML = *OFF                                   ;
                ENDIF                                                ;
           WHEN Replacement = '&SHPCTY'                              ;
                NewValue =  %trim(shpcth)                            ;
           WHEN Replacement = '&SHPSTA'                              ;
                NewValue =  %trim(shpsth)                            ;
           WHEN Replacement = '&SHPZIP'                              ;
                NewValue =  %trim(extr5h)                            ;
           WHEN Replacement = '&SHPCCD'                              ;
                NewValue =  'USA'                                    ;
           //*-------------------------------------------------------> Terms
           WHEN Replacement = '&TRMDSC'                              ; //Terms description
                NewValue = %trim(trmact)                             ;
           WHEN Replacement = '&TRMDUE'                              ; //Net due date
                NewValue  = %editw(DueDate:'    -  -  ')             ;
           WHEN Replacement = '&TRMDAY'                              ; //Terms description
                NewValue = %trim(%char(trmda9))                      ;
           WHEN Replacement = '&DSC1'                                ; //Discount
                   NewValue =%trim(%editc(dsgvnz:'3'))               ;
           WHEN Replacement = '&ADD1'                                ; //Additional charge
           WHEN Replacement = '&REFITM'                              ; // Buyer item
                NewValue = %trim(dcitem)                             ;
           WHEN Replacement = '&UPC'                                 ; // UPC code
                SELECT                                               ; // if not mapped do not
                   WHEN upcno <> *blanks                             ; // inlcude the UPC
                      NewValue = %trim(upcno)                        ;
                   OTHER                                             ;
                      WriteXML = *OFF                                ;
                ENDSL                                                ;
           WHEN Replacement = '&EAN'                                 ; // EAN code
                   WriteXML = *OFF                                   ;
           //--------------------------------------------------------> Totals
           WHEN Replacement = '&ITMAMT'                              ; // Item amount
                NewValue =   %trim(%editc(ItemTotal:'3'))            ;
           WHEN Replacement = '&ADDCHG'                              ; //Additional charge
                   WriteXML = *OFF                                   ;
           WHEN Replacement = '&INVGRS'                              ; // Invoice gross
                NewValue =    %trim(%editc(slprcz:'3'))              ;
           WHEN Replacement = '&INVTOT'                              ; // Invoice total
                NewValue =   %trim(%editc(slprcz:'3'))               ;
           WHEN Replacement = '&INVFRT'                              ; // Invoice Freight
                IF framtz <> 0                                       ;
                   NewValue =%trim(%editc(framtz:'3'))               ;
                ELSE                                                 ;
                   WriteXML = *OFF                                   ;
                ENDIF                                                ;
           WHEN Replacement = '&INVTAX'                              ; // Invoice tax
                   WriteXML = *OFF                                   ; // tax not used
           WHEN Replacement = '&INVALW'                              ; // Invoice allowance
                IF advalz <> 0                                       ; // Ad allowance
                   NewValue = %trim(%editc(advalz:'3'))              ;
                ELSE                                                 ;
                   WriteXML = *OFF                                   ;
                ENDIF                                                ;
           WHEN Replacement = '&DSCAMT'                              ; // Invoice discount
                IF dsgvnz <> 0                                       ; // discount given
                   NewValue =%trim(%editc(dsgvnz:'3'))               ;
                ELSE                                                 ;
                   WriteXML = *OFF                                   ;
                ENDIF                                                ;
           WHEN Replacement = '&QTYINV'                              ; // Invoice total
                NewValue =   %trim(%editc(ItemsInvoiced:'3'))        ;
           WHEN Replacement = '&PIECE'                               ; // Invoice total
                NewValue =   %trim(pieceID)                          ;
           WHEN Replacement = '&REFLIN'                              ; // Invoice total
                NewValue =   %trim(%editc(recnoc:'3'))               ;
           WHEN Replacement = '&JACK'                                ; // Invoice total
                NewValue =   %trim(seller)                           ;
           OTHER                                                     ;
                   WriteXML = *OFF                                   ;
           ENDSL                                                     ;

           IF NewValue <> *blanks                                    ;
           formatString(NewValue)                                    ;
           ENDIF                                                     ;

           workString = %trim(%subst(workstring:s))                  ;
           r = %scan('&':workString)                                 ; // scan for replacment
           IF r > 0                                                  ;
                DataString = %trim(DataString) + ' ' +
                             %trim(%subst(workstring:1:r-1))         ;
              workString = %trim(%subst(workstring:r))               ; // left adjust string
           ENDIF                                                     ;
        ENDDO                                                        ;
        ELSE                                                         ;
           DataString = %trim(XMLdta)                                ;
        ENDIF                                                        ;

        IF xmluet <> *blanks                                         ;
           DataString = %trim(DataString) + xmlEnd                   ; // add tag end if required
        ENDIF                                                        ;

        r = %scan('pieceIdentification':DataString:1)                ;
        IF r > 0 and pieceID = *blank                                ;
           WriteXML = *OFF                                           ;
        ENDIF                                                        ;

        return DataString                                            ;
      /end-free
     p formatXML       e
      *---------------------------------------------------------------------
      * Parse the XML Statement
      *---------------------------------------------------------------------
     p formatString    B                   
     d formatString    PI
     d    NewValue                  128
      /free
       IF xmlqts = 'Y'                                               ;
          DataString= %trim(DataString) + dqt + %trim(NewValue) + dqt;
       ELSE                                                          ;
          DataString= %trim(DataString) + %trim(NewValue)            ;
       ENDIF                                                         ;
      /end-free
     p formatString    e
      *---------------------------------------------------------------------
      * Check to see if Ship-to contact information is to be written
      *---------------------------------------------------------------------
     p CheckContact    B                   
     d CheckContact    PI
     d  shpcon         S             10a   inz('810SHPC')
      /free

         SETLL (docver:shpcon) ADMXMLPF                              ;
         DOU %eof(ADMXMLPF)                                          ;
             READE (docver:shpcon) ADMXMLPF                          ;
             IF not %eof(ADMXMLPF)                                   ;
                DataOut = formatXML()                                ;
                IF WriteXML                                          ;
                   WRITE ADM856PF OutRec                             ;
                ENDIF                                                ;
             ENDIF                                                   ;
         ENDDO                                                       ;
      /end-free
     p CheckContact    e


XML Test Output

 <?xml version="1.0" encoding="utf-8"?>
 <tns:advanceShipNotice xmlns:tns="http://support.furnishnet.com/xml/schemas/fnASN_v1.9" xmlns:tnsa="http://support.furnishnet.com/xml/schemas/fnBase_v1.6" xmlns:tnsb="http://support.furnishnet.com/xml/schemas/fnItem_v1.6"
xmlns:tnsc="http://support.furnishnet.com/xml/schemas/fnParty_v1.4" xmlns:tnsd="http://support.furnishnet.com/xml/schemas/fnBase
v1.4" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:schemaLocation="http://support.furnishnet.com/xml/schemas/fnASN_v1.9">
 <shipment>

 <document id=&ASNORD status="Original">
 <creationDate>&ASNDTE </creationDate>
 <creationTime>&ASNTIM
 </document>

 <shipmentReferenceNumber referenceNumberValue=&ASNREF referenceNumberQualifier="ShipNoticeNumber" />
 <shipmentReferenceNumber referenceDocumentDate=&REFDTE referenceNumberValue=&BYRPO  referenceNumberQualifier="BuyerSalesOrderNumber" />
 <shipDate shipDateQualifier="Actual" shipDate=&SHPDTE />
 <seller>
 <sellerIdentification xsi:type="tnsc:shipToPartyType" shippingInstructions="string">
 </shipFrom>
 <tnsc:partyIdentifier partyIdentifierCode="string" partyIdentifierQualifierCode="SenderAssigned" />
 </sellerIdentification>
 </seller>
 <shipFrom>
 <tnsc:partyIdentifier partyIdentifierCode="string" partyIdentifierQualifierCode="SenderAssigned" />
 <tnsc:addressLine>string </tnsc:addressLine>
 <tnsc:addressLine>string </tnsc:addressLine>
 <tnsc:addressLine>string </tnsc:addressLine>
 <tnsc:addressLine>string </tnsc:addressLine>
 <tnsc:county>string </tnsc:county>
 <tnsc:postalCode>string </tnsc:postalCode>
 <partyContact />
 <tnsc:FOBPoint>&FOB </tnsc:FOBPoint>
 <shipTo description="endConsumer" shippingInstructions="string" id="string">
 <tnsc:partyIdentifier partyIdentifierCode="string" partyIdentifierQualifierCode="SenderAssigned" />
 <tnsc:partyIdentifier partyIdentifierCode="string" partyIdentifierQualifierCode="GLN" />
 <tnsc:partyIdentifier partyIdentifierCode="string" partyIdentifierQualifierCode="DUNS" />
 <tnsc:partyName>string </tnsc:partyName>
 <tnsc:addressLine>string </tnsc:addressLine>
 <tnsc:addressLine>string </tnsc:addressLine>
 <tnsc:addressLine>string </tnsc:addressLine>
 <tnsc:postalCode>string </tnsc:postalCode>
 <partyContact />
 </shipTo>
 <markFor description="warehouse">
 <tnsc:partyIdentifier partyIdentifierCode="string" partyIdentifierQualifierCode="DUNS" />
 <tnsc:partyIdentifier partyIdentifierCode="string" partyIdentifierQualifierCode="ReceiverAssigned" />
 <tnsc:partyIdentifier partyIdentifierCode="string" partyIdentifierQualifierCode="ReceiverAssigned" />
 <tnsc:partyIdentifier partyIdentifierCode="string" partyIdentifierQualifierCode="SenderAssigned" />
 <tnsc:partyName>string </tnsc:partyName>
 <tnsc:county>string </tnsc:county>
 <tnsc:stateOrProvince>string </tnsc:stateOrProvince>
 <tnsc:country>string </tnsc:country>
 <tnsc:postalCode>string </tnsc:postalCode>
 </markFor>
 <productCategory>&ASNCAT </productCategory>
 <shipmentMethod>&ASNMTD </shipmentMethod>
 <freightTerms>&ASNFRT </freightTerms>
 <order>
 <orderSystemReference>
 <systemReferenceDescription>string </systemReferenceDescription>
 <systemReferenceValue>string </systemReferenceValue>
 </orderSystemReference>
 <pack />
 <pack />
 </order>
 <order>
 <orderQuantity />
 </order>
 <order>
 <orderReferenceNumber referenceDocumentDate="1979-04-23" referenceNumberValue="string" referenceNumberQualifier="BuyerSalesOrderNumber" />
 <orderReferenceNumber referenceNumberValue="string" referenceNumberQualifier="WaybillNumber" />
 <orderReferenceNumber referenceNumberValue="string" referenceNumberQualifier="ParentInvoiceNumber" />
 <orderSystemReference>
 <systemReferenceDescription>string </systemReferenceDescription>
 <systemReferenceValue>string </systemReferenceValue>
 </orderSystemReference>
 <orderSystemReference>
 <systemReferenceDescription>string </systemReferenceDescription>
 <systemReferenceValue>string </systemReferenceValue>
 </orderSystemReference>
 <pack />
 <pack />
 <pack />
 <pack />
 </order>
 <order>
 <orderReferenceNumber referenceNumberValue="string" referenceNumberQualifier="SellerSalesOrderLineNumber" />
 <orderReferenceNumber referenceNumberValue="string" referenceNumberQualifier="AllowanceNumber" />
 <orderReferenceNumber referenceNumberValue="string" referenceNumberQualifier="AllowanceNumber" />
 <orderQuantity />
 <orderSystemReference>
 <systemReferenceDescription>string </systemReferenceDescription>
 <systemReferenceValue>string </systemReferenceValue>
 </orderSystemReference>
 <orderSystemReference>
 <systemReferenceDescription>string </systemReferenceDescription>
 <systemReferenceValue>string </systemReferenceValue>
 </orderSystemReference>
 <orderSystemReference>
 <systemReferenceDescription>string </systemReferenceDescription>
 <systemReferenceValue>string </systemReferenceValue>
 </orderSystemReference>
 <orderSystemReference>
 <systemReferenceDescription>string </systemReferenceDescription>
 <systemReferenceValue>string </systemReferenceValue>
 </orderSystemReference>
 <pack />
 <pack />
 </order>
 </shipment>
 </tns:advanceShipNotice>