UTABLE LSTBL 50000 LNTBL 1400
* --------------------------------------------------------------- *
* Download user requested data to a spreadsheet.                  *
*                                                                 *
* Deprecated!!!  This routine should still work, and it shows     *
* how the basic $Web functions work.  But there are better ways   *
* to get data from 204/Janus into an Excel spreadsheet.  This     *
* demo produces output in .csv, .tab and .dif formats.  The       *
* demo here: http://sirius-software.com/demo/demo_sirmonitor      *
* produces a spreadsheet in Excel XML format, which is much more  *
* sophisticated and flexible.  Also, the newer demos have the     *
* code in OO syntax, as well as in mixed-case.                    *
*                                                                 *
* --------------------------------------------------------------- *

Begin

       %DT       IS FLOAT          COMMON
       %I        IS FLOAT
       %J        IS FLOAT
       %LIST     IS FLOAT
       %MAXFIELD IS FLOAT
       %SUBLIST  IS FLOAT
       %RC       IS FLOAT          COMMON
       %RTRNLIST IS FLOAT
       %X        IS FLOAT          COMMON
       %Y        IS FLOAT          COMMON

       %CAP      IS STRING LEN   3
       %COMMAND  IS STRING LEN 120
       %FGNAME   IS STRING LEN  30 COMMON
       %FIELD    IS STRING LEN 255 COMMON
       %FORMAT   IS STRING LEN  10 COMMON
       %IMAGE    IS STRING LEN 255 COMMON
       %METHOD   IS STRING LEN  10 COMMON
       %PASSWORD IS STRING LEN   8 COMMON
       %TYPE     IS STRING LEN  30 COMMON
       %URL      IS STRING LEN 255 COMMON
       %USGUYS   IS STRING LEN 255 COMMON
       %USERID   IS STRING LEN  10 COMMON

       %FX       IS STRING LEN  50 ARRAY (200)

* Web session setup.

       %DT     = $WEB_DATE + (30 * 24 * 60 * 60)
       %RC     = $WEB_ON
       %RC     = $WEB_TYPE('text/html')
       %RC     = $WEB_SUB('@@')
       %RC     = $WEB_EXPIRE($WEB_DATE - 1)
*      %RC     = $WEB_RESPONSE('PRAGMA', 'NO-CACHE')
       %USERID = $USERID
       %USGUYS = 'ALAN/ALEX/DARREN/DME/GARY/JEFF/PETER/TOM'

* If form was "posted" capture the input and reset cookie.

       %CAP    = $UPCASE($WEB_FORM_PARM('cap'))
       %URL    = $UPCASE($WEB_HDR_PARM('URL'))
       %METHOD = $UPCASE($WEB_HDR_PARM('METHOD'))

       IF %METHOD EQ 'POST' THEN

          %CAP      = $UPCASE($WEB_FORM_PARM('cap'))
          %TYPE     = $UPCASE($WEB_FORM_PARM('type'))
          %FGNAME   = $UPCASE($WEB_FORM_PARM('fgname'))
          %PASSWORD = $UPCASE($WEB_FORM_PARM('password'))
          %RC       = $WEB_SET_COOKIE('CAP',    %TYPE,   %DT )
          %RC       = $WEB_SET_COOKIE('TYPE',   %TYPE,   %DT )
          %RC       = $WEB_SET_COOKIE('FGNAME', %FGNAME, %DT )

          CALL OPENFILE(%RC, %TYPE, %FGNAME, $X2D('0041') )

          IF $INDEX(%URL,'FIELDNAMES') THEN
             CALL FIELDNAMES
          ELSE
             CALL EXTRACT
          END IF

       ELSE
          %TYPE     = $WEB_COOKIE_PARM('TYPE')
          %FGNAME   = $WEB_COOKIE_PARM('FGNAME')
       END IF

* Build the html page.

       %RC = $SETG('TITLE','Model 204 field extraction to spreadsheet')
       %RC = $SETG('SUBHEAD','<i><h3>Model 204 Field Extraction' WITH -
             '</h2></i>' )
       In JANWEB Include WEB/TEMPLATE_TOP

       PRINT '<form name="selectfile"'
       PRINT '      method="post"'
       PRINT '      action="' WITH $WEB_HDR_PARM('URL') WITH -
             'fieldnames">'

       PRINT '  <center>'
       PRINT '  <table>'

       PRINT '    <tr><td colspan=2>'
       SKIP 1 LINE
       PRINT 'Extract M204 field definitions from a file or group and'
       PRINT 'format them into a spreadsheet.<p>'
       PRINT 'Note that in this sample application, the "AUTHORS"'
       PRINT 'file contains the most interesting data.<p>'
       PRINT '<hr>'
       PRINT '</td>'
       SKIP 1 LINE
       SKIP 1 LINE
       PRINT '    </tr><tr><td>Extract from:</td><td>'
       PRINT '         <select name="type">'

       IF %TYPE EQ 'GROUP' THEN
          PRINT '              <option>File</option>'
          PRINT '              <option selected>Group</option>'
       ELSE
          PRINT '              <option>File</option>'
          PRINT '              <option>Group</option>'
       END IF

       PRINT '         </select>'

       PRINT '         <select name="fgname">'
       IF $ONEOF(%USGUYS,%USERID,'/') THEN
          PRINT ' <option selected value="PUBS2">AUTHORS</option>'
          PRINT ' <option>CCASYS</option>'
          PRINT ' <option>CUSTOMER</option>'
          PRINT ' <option>DATALINK</option>'
          PRINT ' <option>JANCAT</option>'
          PRINT ' <option>METADATA</option>'
          PRINT ' <option>ZIP</option>'
       ELSE
          PRINT ' <option selected value="PUBS2">AUTHORS</option>'
          PRINT ' <option>JANCAT</option>'
          PRINT ' <option>DATALINK</option>'
          PRINT ' <option>METADATA</option>'
       END IF
       PRINT '         </select>'

       PRINT '    </tr><tr><td>'

       PRINT '    </tr><tr><td>Password:</td><td>'
       PRINT '         <input type="password" name="password" value="' -
        WITH %PASSWORD WITH '"></td>'

       PRINT '    </tr><tr><td>'

       PRINT '    </tr><tr><td></td><td>'
       PRINT '         <input type="submit" value="Extract Fields"' -
        WITH ' width=30></td></tr>'

       PRINT '  </table>'
       PRINT '  </center>'
       PRINT '</form>'

       PRINT '<br><hr>'

        HTML
        <table cellpadding="0" cellspacing="0" border="0" width="300" height="300">
          <tr><td>&nbsp;</td></tr>
        </table>
        END HTML
       In JANWEB Include WEB/TEMPLATE_BOTTOM

* End of mainline routine.

SUBROUTINE OPENFILE( %STATUS IS FLOAT OUTPUT,                  -
                     %ITYPE  IS STRING LEN 5,                  -
                     %INAME  IS STRING LEN 8,                  -
                     %PRIV   IS FIXED)

       %CONTEXT       IS STRING LEN  20
       %CURPRIV       IS FIXED
       %DT            IS FLOAT          COMMON
       %FGNAME        IS STRING LEN  30 COMMON
       %FORMAT        IS STRING LEN  10 COMMON
       %ITSOPEN       IS FIXED
       %MSG           IS STRING LEN 255
       %NAME          IS STRING LEN   8
       %PASSWORD      IS STRING LEN   8 COMMON
       %TITLE.HOLD    IS STRING LEN  80
       %TYPE          IS STRING LEN  30 COMMON
       %RC            IS FLOAT

       %TYPE           = %ITYPE
       %NAME           = %INAME
       IF %TYPE EQ '' THEN
          %TYPE = 'FILE'
       END IF

CHK:   IF %TYPE EQ 'GROUP' THEN
          %CONTEXT = 'PERM GROUP ' WITH %NAME
       ELSE
          %CONTEXT = 'FILE ' WITH %NAME
       END IF

       %RC = $WEB_OFF

       %ITSOPEN = $CONTEXT(%CONTEXT)

       IF %PASSWORD EQ '' THEN
          IF NOT %ITSOPEN THEN
             IF %TYPE EQ 'GROUP' THEN
                OPENC PERM GROUP %NAME
             ELSE
                OPENC FILE %NAME
             END IF
          END IF
       ELSE
          IF %TYPE EQ 'GROUP' THEN
             OPENC PERM GROUP %NAME PASSWORD %PASSWORD
          ELSE
             OPENC FILE %NAME PASSWORD %PASSWORD
          END IF
       END IF

       %RC = $WEB_ON

*-> See if user was given the requested access to the file/group

       %CURPRIV          = $VIEW('CURPRIV', %CONTEXT)
       %RC               = $ERRSET('')
       %RC               = $SETG('ERROR','')
       IF $STATUS AND NOT %CURPRIV THEN
          %MSG = 'Couldn''t open the requested file.'
          JUMP TO ERRX
       END IF

       IF %PRIV NE $BITAND(%PRIV, %CURPRIV) THEN
          %MSG = 'Insufficient file privileges to load procedure.'
          JUMP TO ERRX
       END IF

       %STATUS = 0
       RETURN

ERRX:  %RC = $WEB_FLUSH
       %RC = $WEB_TYPE('text/html')
       %RC = $WEB_SET_COOKIE('TYPE',   %TYPE,   ,, %DT )
       %RC = $WEB_SET_COOKIE('FGNAME', %FGNAME, ,, %DT )
       PRINT '<html><head><title>System error</title></head>'
       PRINT '<body><h2>System error</h2>'
       PRINT 'System terminated due to error.<br>'
       PRINT 'Procedure causing error: EXCEL.UL'
       PRINT 'Error message:<br>'
       PRINT '<xmp>'
       PRINT %MSG
       PRINT '</xmp>'
       PRINT '</body></html>'
       %RC = $WEB_DONE
       STOP

END SUBROUTINE OPENFILE

* This routine prints a field name selection form.

FIELDNAMES: SUBROUTINE

       %FGNAME = %TYPE WITH ' ' WITH %FGNAME
       %IMAGE  = 'IN ' WITH %FGNAME WITH ' D FIELD (ABBREV) ALL'
       %LIST   = $LISTNEW
       %RC     = $COMMNDL(%IMAGE,,%LIST,%FGNAME)
       %RC     = $WEB_ON

       %RC = $SETG('TITLE','Model 204 field extraction to spreadsheet')
       %RC = $SETG('SUBHEAD','<i><h3>Select fields to download' WITH -
             ' from ' WITH %FGNAME WITH '</h2></i>' )
* ------- Unfortunately we can't include WEB/TEMPLATE_TOP, so here it is, inline -------- *
       If %Printing Then
          in JANWEB include WEB/PRINTTOP.HTML
       ElseIf $Index($Web_Hdr_Parm('USER-AGENT'),'MSIE') and -
             $index($upcase($Web_Hdr_Parm('USER-AGENT')),'WINDOWS') Then
          in JANWEB include WEB/FLOAT_PAGE_TOP.HTML
          in JANWEB include WEB/FLOAT_NAVBAR_MAIN.HTML
          in JANWEB include WEB/FLOAT_NAVBAR_BOTTOM.HTML
       Else
          in JANWEB include WEB/PAGETOP.HTML
          in JANWEB include WEB/NAV.HTML
          in JANWEB include WEB/NAV_BOTTOM.HTML
       End If
* ----------------------------- End WEB/TEMPLATE_TOP, ----------------------------------- *

       PRINT '<form name="extract"'
       PRINT '      method="post"'
       PRINT '      action="excel/m204.csv">'

       PRINT 'Enter up to 3 selection criteria.  You should use'
       PRINT 'the following text entry fields exactly as if they'
       PRINT 'were lines in a FIND statement (which is exactly what'
       PRINT 'they''re going to be).  For instance if you want to select'
       PRINT 'all records in the file containing RECTYPE A or C, you'
       PRINT 'should fill in the criteria as: <p><center>'
       PRINT '<kbd>RECTYPE = ('A' OR 'C')</kbd></center><p>'
       PRINT 'If you''re looking at the "AUTHORS" database you can select'
       PRINT 'RECTYPE=''AUTHORS'' to view only information on the'
       PRINT 'authors records.'
       PRINT 'You can also leave these blank, and the find will execute'
       PRINT 'against the entire file.'

       PRINT '<p>FIND Criteria 1: ' WITH -
             '<input type="text" width="80" name="sel1">'
       PRINT '<br>FIND Criteria 2: ' WITH -
             '<input type="text" width="80" name="sel2">'
       PRINT '<br>FIND Criteria 3: ' WITH -
             '<input type="text" width="80" name="sel3">'

       PRINT '<p>Number of records to extract: ' WITH -
             '<input type="text" width="10" name="cap"><p>'

       PRINT '  <center>'
       PRINT '  <table cellpadding=1 cellspacing=1 border=0>'

       PRINT '    <thead><th colspan=3>'
       PRINT 'Field names from ' WITH %FGNAME WITH '. ' WITH -
             'Check the fields you want included in the download.'

       PRINT '</th></thead>'

       PRINT '<tr>'

       %Y = 0

       FOR %X FROM 1 TO $LISTCNT(%LIST) BY 2

          %Y = %Y + 1
          IF NOT $MOD(%Y,3) THEN
             PRINT '</tr><tr>'
          END IF

          %FIELD = $DEBLANK($LISTINF(%LIST,%X),1)

          PRINT '<td>'
          PRINT '<input type="checkbox" name="FX_' WITH %FIELD WITH -
                '" value=1 unchecked> ' WITH %FIELD
          PRINT '</td>'

       END FOR

       PRINT '</tr>'
       PRINT '</table>'

* Submit method.

       PRINT '<p><input type="submit" value="Retrieve" width=180>'
       PRINT '</center>'

* Carry along the file info, though the user doesn't need to see it.

       PRINT '<input type="hidden" name="type" value="' -
        WITH $PARSE( %FGNAME, ' ' ) WITH '">'
       PRINT '<input type="hidden" name="fgname" value="' -
        WITH $PARSEX( %FGNAME, ' ' ) WITH '">'
       PRINT '<input type="hidden" name="password" value="' -
        WITH %PASSWORD WITH '">'

       PRINT '</form>'
       In JANWEB Include WEB/TEMPLATE_BOTTOM

       %RC       = $WEB_DONE

END SUBROUTINE FIELDNAMES

EXTRACT: SUBROUTINE

       %MAXFIELD = 0
       FOR %X FROM 1 TO $WEB_NUM_FORM
          IF $INDEX($WEB_FORM_NAME(%X),'FX_') THEN
             IF $WEB_FORM_PARM($WEB_FORM_NAME(%X)) THEN
               %MAXFIELD = %MAXFIELD + 1
               %FX(%MAXFIELD) = $PARSEX($WEB_FORM_NAME(%X),'_')
             END IF
          END IF
       END FOR

       %SUBLIST  = $LISTNEW
       %RTRNLIST = $LISTNEW

* Build the proc to submit to the SDAEMON.

       %RC       = $LISTADD( %SUBLIST, 'BEGIN'  )
       %COMMAND  = 'FD1: IN ' WITH %FGNAME WITH ' FDWOL'
       %RC       = $LISTADD( %SUBLIST, %COMMAND )

       IF $DEBLANK($WEB_FORM_PARM('sel1'),1) NE '' THEN
          %RC    = $LISTADD( %SUBLIST, $UPCASE($WEB_FORM_PARM('sel1')))
       END IF

       IF $DEBLANK($WEB_FORM_PARM('sel2'),1) NE '' THEN
          %RC    = $LISTADD( %SUBLIST, $UPCASE($WEB_FORM_PARM('sel2')))
       END IF

       IF $DEBLANK($WEB_FORM_PARM('sel3'),1) NE '' THEN
          %RC    = $LISTADD( %SUBLIST, $UPCASE($WEB_FORM_PARM('sel3')))
       END IF

       IF $VNUM(%CAP) AND %CAP LE 100 THEN
          %COMMAND  = 'FR1: FOR ' WITH %CAP WITH ' RECORDS IN FD1'
       ELSE
          %COMMAND  = 'FR1: FOR 100 RECORDS IN FD1'
       END IF
       %RC       = $LISTADD( %SUBLIST, %COMMAND )

       FOR %X FROM 1 TO %MAXFIELD
          IF %X NE %MAXFIELD THEN
             %COMMAND  = -
               '   PRINT ' WITH %FX(%X) WITH ' WITH '', ''' WITH -
               ' WITH ...'
          ELSE
             %COMMAND  = '   PRINT ' WITH %FX(%X)
          END IF
          %RC       = $LISTADD( %SUBLIST, %COMMAND )
       END FOR

       %RC       = $LISTADD( %SUBLIST, 'END FOR' )
       %RC       = $LISTADD( %SUBLIST, 'END'     )

* Send it.

       %RC       = $COMMBG(%SUBLIST,%FGNAME,,%RTRNLIST)
       IF %RC THEN
          PRINT '$COMMBG failure.  Return code = ' WITH %RC
          PRINT 'You probably entered an invalid "FIND" criteria,'
          PRINT 'or perhaps a non-numeric value for the record limit.'
          STOP
       END IF

* Send the output in comma-separated format.

       %RC     = $WEB_ON
       %RC     = $WEB_TYPE('application/excel')

* The first print line is the labels.

       FOR %X FROM 1 TO %MAXFIELD
          IF %X NE %MAXFIELD THEN
             PRINT %FX(%X) WITH ', ' WITH ...
          ELSE
             PRINT %FX(%X)
          END IF
       END FOR

* Print the comma-delimited field values.

       IF NOT $LISTCNT(%RTRNLIST) THEN
          PRINT 'No data found for your request.'
       ELSE
          FOR %X FROM 1 TO $LISTCNT(%RTRNLIST)
             PRINT $LISTINF(%RTRNLIST,%X)
          END FOR
       END IF

       %RC       = $WEB_DONE

       %RC       = $LISTDEL(%SUBLIST)
       %RC       = $LISTDEL(%RTRNLIST)

END SUBROUTINE EXTRACT
END