000100$$ FEDLEVEL=5 000200$$ SET LINEINFO BINDINFO 000300$$ SET LISTOMITTED 000320$$ SET LOGGING 001000 001100 IDENTIFICATION DIVISION. 001310 PROGRAM-ID. UNITE-AS4026-WEBPCM-DEMO. 021101PK 001320 AUTHOR. P.KIMPEL. 021101PK 001340 INSTALLATION. PARADIGM CORPORATION, SAN DIEGO. 021101PK 001360 DATE-WRITTEN. NOVEMBER 2002. 021101PK 001400 DATE-COMPILED. 002000 002100****************************************************************** 002110* * 002120* UNITE/AS4026/WEBPCM/DEMO *021101PK 002130* * 002140****************************************************************** 002150* * 002160* Copyright (C) 2001,2002: *020120PK 002170* Paradigm Corporation * 002180* 9625 Black Mountain Road, Suite 218 *021118PK 002190* San Diego, California 92126-4598 USA *021118PK 002200* voice +1-858-536-5533; fax 858-536-5545 *021118PK 002210* http://www.digm.com * 002220* * 002230* This material may be copied and used for any purpose *021101PK 002240* providing this copyright notice is preserved and that *021101PK 002250* appropriate credit is given. *021101PK 002260* *021101PK 002270* This material is offered AS-IS WITH NO WARRANTY. *021101PK 002280* Paradigm hereby disclaims all warranties respecting this *021101PK 002290* material, expressed or implied, including without limita- *021101PK 002300* tion warranty of design, merchantability, fitness for a *021101PK 002310* particular purpose and against infringement. *021101PK 002360* * 002380****************************************************************** 002400* 002500* UNITE/AS4026/WEBPCM/DEMO illustrates the WEBPCM module for 021101PK 002600* the Custom Connect Facility (CCF) on Unisys ClearPath MCP 021101PK 002700* systems. The WEBPCM serves as a bridge between the ClearPath 021101PK 002800* Web Transaction Server (Atlas) and the Transaction Server 021101PK 002900* (COMS). 021101PK 003000* 021101PK 003100* This sample program has been cloned from a larger and much 021101PK 003200* more complex application for the WEBPCM. Much of the infra- 021101PK 003300* structure has been left in, however, to illustrate several 021101PK 003400* techniques for COMS and the WEBPCM. In particular, this 021101PK 003500* program illustrates the use of cookies, application-level 021118PK 003600* user authentication, and HTTP chunked output. The program 021118PK 003700* originally made use of several COPY modules; these have been 021118PK 003800* included in-line so there would be only one source file for 021118PK 003810* you to deal with. 021118PK 003900* 021101PK 004000* This program is a fairly complete COMS direct window shell. 021101PK 004100* The coding that deals primarily with the WEBPCM interface 021101PK 004200* starts at line 600000 with routine 1000-HTTP-ROUTE-INPUT-MSG.021101PK 004300* The determination whether a message is from the WEBPCM or a 021118PK 004400* regular COMS station is made in routine 0160-COMS-ROUTE- 021118PK 004500* USER-MSG. Any processing for normal COMS messages can be 021118PK 004600* routed from there. 021118PK 010000* 021101PK 010100* To use this program, you need to create a virtual directory 021101PK 010200* in the Atlas configuration with a name of "/UNITEdemo/". You 021118PK 010300* then need to define a WEBPCM Service in the CCF PARAMS file 021101PK 010400* as follows: 021101PK 010500* 021101PK 010600* [WEBPCM] 021101PK 010700* ADD SERVICE UNITEDEMO 021101PK 010800* PATH = "/UNITEDEMO/", 021101PK 010900* CHECKUSERAUTH = FALSE, 021101PK 011000* PROGRAMID = "UNITE WEBPCM Demo", 021101PK 011100* SERVICE = CUCIWEBSERVICE, 021101PK 011200* SHOWPW = TRUE, 021101PK 011300* STATIONCONTROL = PERMANENT, 021101PK 011400* STATIONNAME = WEBPCM/UNITE/DEMO, 021101PK 011500* DYNAMIC = FALSE, 021101PK 011600* INACTIVITYTIMEOUT = 0, % INFINITE 021101PK 011700* STRINGTERMINATE = FALSE, 021101PK 011800* TRANCODE = "UDEMO", 021101PK 011900* TRANSLATE = TRUE, 021101PK 012000* USERCODE = , 021101PK 012100* WINDOW = UNITE_DEMO; 021101PK 012200* ENABLE SERVICE UNITEDEMO; 021101PK 012300* 021101PK 012400* You also need to define corresponding TRANCODE and WINDOW 021101PK 012500* entities in your COMS CFILE, along with a suitable PROGRAM 021101PK 012600* and AGENDA for this program. 021101PK 012700* 021101PK 012800* The specific values of the PROGRAMID, STATIONNAME, TRANCODE, 021101PK 012900* USERCODE, and WINDOW attributes are not critical as long as 021101PK 013000* they are consistent with your COMS configuration. You might 021101PK 013100* also consider setting an INACTIVITYTIMEOUT and changing 021101PK 013200* DYNAMIC to TRUE. 021101PK 020000* 021101PK 020100* To use the program, enter a URL in a browser of this form: 021101PK 020200* 021101PK 020300* http://ourhost.ourdomain.com/unitedemo/ 021101PK 020400* 021101PK 020500* The following values are implemented: 021101PK 020600* 021101PK 020700* home displays the program's home page. 021101PK 020800* 021101PK 020900* echo displays a page of information about the HTTP 021101PK 021000* request you entered. 021101PK 021100* 021101PK 021200* cal displays a simple HTML form where you can enter 021101PK 021300* a month and year, from which it will display 021101PK 021400* a standard format calendar page for that month. 021101PK 025000* 021101PK 025100* If you leave the (and optionally, its preceding 021101PK 025200* slash) out of the URL, the "home" function is performed by 021101PK 025300* default. 021101PK 025400* 021101PK 025500* The first time you enter a URL for this program during a 021101PK 025600* browser session, the program will ask you to provide a 021101PK 025700* usercode and password. You can enter anything in response to 021101PK 025800* this -- the program does not validate these credentials. It's021101PK 025900* done only to illustrate HTTP authentication. The "echo" 021101PK 026000* function can be performed before logging in, even though it 021118PK 026100* will request credentials first. 021118PK 026200* 021118PK 026300* This program write a message trace file if the compile-time 021118PK 026400* option $LOGGING is set. The layout of this file is defined 021118PK 026500* by the FD TLF-TRAFFIC-LOG and the working storage area 021118PK 026600* WTL-TRAFFIC-LOG-AREA. The trace data is written to a disk 021118PK 026700* file, DATA/UNITE/WEBPCMDEMO/TRAFFIC/yyyymmdd. The records 021118PK 026800* normally have mixed EBCDIC, ASCII, and binary data; you can 021118PK 026900* read this file and examine the records with SYSTEM/DUMPALL. 021118PK 045000* 021101PK 045100* Questions and comments on this program, the WEBPCM, and web 021101PK 045200* programming in general are welcome. Please contact me at 021101PK 045300* paul.kimpel@digm.com or telephone +1-858-536-5533. 021101PK 050000* 050010****************************************************************** 050020* MODIFICATION LOG. 050030* ----------------- 050040* 2002-11-01 P.KIMPEL 021101PK 050041* ORIGINAL VERSION, FROM NYSPIN/WEBUSER OF 20020214 AS A BASE. 021101PK 050050* 2002-11-18 P.KIMPEL 021118PK 050051* MINOR ENHANCMENTS AND CORRECTIONS. 021118PK 099900****************************************************************** 100000/ 100100 ENVIRONMENT DIVISION. 100200****************************************************************** 100300 CONFIGURATION SECTION. 100400****************************************************************** 100500 SOURCE-COMPUTER. UNISYS-MCP. 021101PK 100700 OBJECT-COMPUTER. UNISYS-MCP. 021101PK 120000 120100****************************************************************** 120200 INPUT-OUTPUT SECTION. 120300****************************************************************** 120400 FILE-CONTROL. 121100 SELECT TLF-TRAFFIC-LOG 121200 ASSIGN TO DISK 121300 ORGANIZATION SEQUENTIAL 011009PK 121500 ACCESS MODE SEQUENTIAL 011009PK 121600 FILE STATUS WTL-FILE-STATUS. 150000 021101PK 150100 DATA DIVISION. 150200****************************************************************** 150300 FILE SECTION. 150400****************************************************************** 160000 160100 FD TLF-TRAFFIC-LOG 160200* COPY "(PAUL)COPY/UTIL/TRAFFIC/LOGFILE ON OPS". 021101PK 160210 VALUE OF AREAS 20 021101PK 160220 VALUE OF AREALENGTH 540000 021101PK 160230 VALUE OF FLEXIBLE TRUE 021101PK 160240 VALUE OF SECURITYTYPE PUBLIC 021101PK 160250 VALUE OF SECURITYUSE IN 021101PK 160260 VALUE OF PROTECTION PROTECTED 021101PK 160270 RECORD CONTAINS 36 TO 8338 CHARACTERS 021101PK 160280 DEPENDING ON TLF-REC-SIZE 021101PK 160290 BLOCK CONTAINS 36 TO 9000 CHARACTERS 021101PK 160300 LABEL RECORDS STANDARD. 021101PK 160310 01 TLF-REC. 021101PK 160320 05 TLF-REC-SIZE PIC 9(4). 021101PK 160330 05 TLF-DATE PIC 9(8). 021101PK 160340 05 TLF-TIME PIC 9(8). 021101PK 160350 05 TLF-SEQ PIC 9(1). 021101PK 160360 05 TLF-TYPE PIC X(12). 021101PK 160370 05 TLF-FORMAT PIC X(1). 021101PK 160380 05 TLF-HEADER PIC X(112). 021101PK 160390 05 TLF-COMS-HEADER REDEFINES TLF-HEADER. 021101PK 160400 10 TLF-COMS-STATE PIC 9(2). 021101PK 160410 10 TLF-COMS-STEP PIC 9(2). 021101PK 160420 10 TLF-COMS-MSG-SIZE PIC 9(4). 021101PK 160430 10 TLF-COMS-STATUS PIC S9(4). 021101PK 160440 10 TLF-COMS-STATION-NAME 021101PK 160450 PIC X(18). 021101PK 160460 10 TLF-COMS-USER-NAME PIC X(18). 021101PK 160470 10 TLF-COMS-DETAIL PIC X(64). 021101PK 160480 10 TLF-COMS-INPUT-DETAIL REDEFINES TLF-COMS-DETAIL. 021101PK 160490 15 TLF-CDI-FUNCTION PIC S9(4). 021101PK 160500 15 TLF-CDI-FCN-STATUS PIC S9(4). 021101PK 160510 15 TLF-CDI-MSG-COUNT PIC S9(4). 021101PK 160520 15 TLF-CDI-TIMESTAMP REAL. 021101PK 160530 15 TLF-CDI-STATION REAL. 021101PK 160540 15 TLF-CDI-PROGRAM REAL. 021101PK 160550 15 TLF-CDI-USER REAL. 021101PK 160560 15 FILLER PIC X(28). 021101PK 160570 10 TLF-COMS-OUTPUT-DETAIL REDEFINES TLF-COMS-DETAIL. 021101PK 160580 15 TLF-CDO-DEST-COUNT PIC 9(4). 021101PK 160590 15 TLF-CDO-RETAIN-TXN PIC 9(1). 021101PK 160600 15 TLF-CDO-SET-AGENDA PIC 9(1). 021101PK 160610 15 TLF-CDO-CONFIRM-FLAG PIC 9(1). 021101PK 160620 15 TLF-CDO-CONFIRM-KEY PIC X(3). 021101PK 160630 15 TLF-CDO-DESTINATION REAL. 021101PK 160640 15 TLF-CDO-NEXT-AGENDA REAL. 021101PK 160650 15 FILLER PIC X(42). 021101PK 160660 05 TLF-PORT-HEADER REDEFINES TLF-HEADER. 021101PK 160670 10 TLF-PORT-INDEX PIC 9(2). 021101PK 160680 10 FILLER PIC X(1). 021101PK 160690 10 TLF-PORT-IP-ADDR PIC X(18). 021101PK 160700 10 FILLER PIC X(1). 021101PK 160710 10 TLF-PORT-NR PIC X(6). 021101PK 160720 10 FILLER PIC X(1). 021101PK 160730 10 TLF-PORT-STATE PIC 9(2). 021101PK 160740 10 FILLER PIC X(1). 021101PK 160750 10 TLF-PORT-STEP PIC 9(2). 021101PK 160760 10 FILLER PIC X(1). 021101PK 160770 10 TLF-PORT-OLD-FILESTATE PIC 9(2). 021101PK 160780 10 FILLER PIC X(1). 021101PK 160790 10 TLF-PORT-NEW-FILESTATE PIC 9(2). 021101PK 160800 10 FILLER PIC X(1). 021101PK 160810 10 TLF-PORT-SUBFILEERROR PIC 9(4). 021101PK 160820 10 FILLER PIC X(1). 021101PK 160830 10 TLF-PORT-FILE-STATUS PIC X(2). 021101PK 160840 10 FILLER PIC X(1). 021101PK 160850 10 TLF-PORT-MSG-SIZE PIC 9(5). 021101PK 160860 10 FILLER PIC X(2). 021101PK 160870 10 TLF-PORT-TEXT PIC X(56). 021101PK 160880 05 TLF-TASK-HEADER REDEFINES TLF-HEADER. 021101PK 160890 10 TLF-TASK-MIX-NR PIC 9(5). 021101PK 160900 10 FILLER PIC X(1). 021101PK 160910 10 TLF-TASK-STATUS PIC S9(2). 021101PK 160920 10 FILLER PIC X(1). 021101PK 160930 10 TLF-TASK-HIST-TYPE PIC 9(4). 021101PK 160940 10 FILLER PIC X(1). 021101PK 160950 10 TLF-TASK-HIST-CAUSE PIC 9(4). 021101PK 160960 10 FILLER PIC X(1). 021101PK 160970 10 TLF-TASK-HIST-REASON PIC 9(4). 021101PK 160980 10 FILLER PIC X(1). 021101PK 160990 10 TLF-TASK-NAME PIC X(88). 021101PK 161000 05 TLF-SEGMENT-HEADER REDEFINES TLF-HEADER. 021101PK 161010 10 TLF-SEG-LENGTH PIC 9(5). 021101PK 161020 10 FILLER PIC X(1). 021101PK 161030 10 TLF-SEG-TYPE PIC X(1). 021101PK 161040 10 FILLER PIC X(1). 021101PK 161050 10 TLF-SEG-SUBTYPE PIC 9(3). 021101PK 161060 10 FILLER PIC X(1). 021101PK 161070 10 TLF-SEG-NR PIC 9(5). 021101PK 161080 10 FILLER PIC X(1). 021101PK 161090 10 TLF-SEG-INDICATOR PIC X(1). 021101PK 161100 10 FILLER PIC X(1). 021101PK 161110 10 TLF-SEG-CONN-SEQ PIC 9(3). 021101PK 161120 10 FILLER PIC X(1). 021101PK 161130 10 TLF-SEG-IMAGE-TYPE PIC X(1). 021101PK 161140 10 FILLER PIC X(1). 021101PK 161150 10 TLF-SEG-IMAGE-OFFSET PIC 9(5). 021101PK 161160 10 FILLER PIC X(1). 021101PK 161170 10 TLF-SEG-IMAGE-LENGTH PIC 9(5). 021101PK 161180 10 FILLER PIC X(1). 021101PK 161190 10 TLF-SEG-WS-DEST PIC X(1). 021101PK 161200 10 FILLER PIC X(1). 021101PK 161210 10 TLF-SEG-PRIORITY PIC X(1). 021101PK 161220 10 FILLER PIC X(1). 021101PK 161230 10 TLF-SEG-HEADER-VERSION PIC X(1). 021101PK 161240 10 FILLER PIC X(1). 021101PK 161250 10 TLF-SEG-STATE-INDEX PIC 9(5). 021101PK 161260 10 FILLER PIC X(1). 021101PK 161270 10 TLF-SEG-SUPV-MSG-INDEX PIC 9(3). 021101PK 161280 10 FILLER PIC X(59). 021101PK 161290 021101PK 161300 05 TLF-TEXT. 021101PK 161310 10 TLF-C PIC X(1) 021101PK 161320 OCCURS 8192 INDEXED TLF-CX. 021101PK 290000 021101PK 290100****************************************************************** 290200 DATA-BASE SECTION. 290300****************************************************************** 291000*DB WEBPCMDB... 021101PK 300000/ 300100****************************************************************** 300200 WORKING-STORAGE SECTION. 300300****************************************************************** 300400 77 W-PROGRAM-NAME PIC X(30) VALUE 300500 "UNITE/AS4026/WEBPCM/DEMO". 021101PK 300600 77 W-PROGRAM-ID PIC X(18) VALUE 300620 "WEBPCM/DEMO". 021101PK 300700 77 W-COPYRIGHT PIC X(60) VALUE 300720 "[Copyright (C) 2002, Paradigm Corporation]". 021101PK 300800 77 W-ZERO PIC 9(1) VALUE ZERO BINARY. 300820 77 W-ONE PIC 9(1) VALUE 1 BINARY. 301000 77 W-FALSE PIC 9(1) VALUE ZERO BINARY. 301010 77 W-TRUE PIC 9(1) VALUE 1 BINARY. 301100 77 W-SERVER-ACTIVE PIC 9(1) VALUE 1 BINARY. 301200 77 W-STATION-MODULUS PIC 9(4) VALUE 47 BINARY. 301300 77 W-SHORT-MSG-SIZE PIC 9(2) BINARY. 301400 77 W-DATA-BASE-OPEN PIC 9(1) VALUE ZERO BINARY. 301420 77 W-MIX-NR PIC 9(6) BINARY.011009PK 303000 303020* -- TIMESTAMP MANAGEMENT -- 010920PK 303080 77 W-TICKLER-PERIOD REAL VALUE 300. 010921PK 303200 77 W-WAIT-DELTA REAL. 010930PK 304000 304020* -- COMS VARIABLES -- 010920PK 304100 77 W-COMS-RESULT PIC S9(11) BINARY. 304120 77 W-COMS-DESIG REAL. 011015PK 304140 01 W-COMS-NAME PIC X(30). 011015PK 304160 77 W-ID-DESIG REAL. 011015PK 304500 77 W-STA-DESIG REAL. 304600 77 W-USER-DESIG REAL. 307000 307020* -- MISCELLANEOUS VARIABLES -- 010920PK 307100 77 W-RESULT PIC S9(11) BINARY. 307200 77 W-TASKVALUE PIC S9(11) BINARY. 307280 77 W-X PIC S9(11) BINARY.020109PK 307300 77 W-L PIC S9(11) BINARY.020109PK 307320 77 W-WORD REAL. 020109PK 307340 77 W-INT-1 PIC S9(11) BINARY.020109PK 307360 77 W-INT-2 PIC S9(11) BINARY.020109PK 307500 307510 01 W-NULL PIC X(6) VALUE SPACE. 020109PK 307520 01 W-NAME PIC X(18). 307540 01 W-VALUE. 020120PK 307560 05 W-VALUE-C PIC X(1) 020120PK 307580 OCCURS 90 INDEXED W-VCX. 020120PK 311000 311010 01 WM-MESSAGE-DISPLAY-AREA. 311020 05 WM-DISPLAY. 311030 10 FILLER PIC X(8) VALUE "AS4026:". 021101PK 311040 10 WM-TEXT. 311060 15 WM-STATUS-VALUE PIC -----9BB. 020120PK 311080 15 WM-STATUS-TEXT PIC X(72). 020120PK 318000 318020 01 WAX-ODT-ACCEPT-AREA. 318040 05 WAX-TOKEN PIC X(12). 318060 05 WAX-MESSAGE PIC X(80). 320000 320020 01 WST-STATION-HASH REAL. 320040 05 WST-HASH-DESIG REAL OCCURS 100. 321000 321020 01 WST-STATION-TABLE. 321040 05 WST-MAX-STATION PIC 9(4) VALUE 100 BINARY. 321080 05 WST-STATION-ENTRY OCCURS 100 INDEXED WST-SX. 321100 10 WST-STATION-DESIG REAL. 321120 10 WST-STATION-NAME PIC X(18). 321140 10 WST-USER-DESIG REAL. 321160 10 WST-USER-NAME PIC X(18). 325000 021101PK 325020 77 WCS-XLATE-LOWTOUPCASE PIC S9(11) VALUE 7 BINARY.021101PK 325040 77 WCS-USE-HOST-CCS PIC S9(11) VALUE -2 BINARY.021118PK 350000 350020 01 WHM-HTTP-MSG-CTL. 020109PK 350040 05 WHM-CONTENT-MAX PIC 9(6) VALUE 8100 BINARY.020120PK 350060 05 WHM-CHUNK-THRESHHOLD PIC 9(6) VALUE 700 BINARY.020207PK 350100 05 WHM-REMOTE-ADDR-MAX PIC 9(2) VALUE 18 BINARY.020109PK 350120 05 WHM-SESSION-TIMEOUT PIC 9(4) VALUE 1200 BINARY.020109PK 350140 05 WHM-LOGON-RETRY-MAX PIC 9(1) VALUE 3 BINARY.020109PK 350160 05 WHM-CHUNK-HEX-MAX PIC 9(1) VALUE 4 BINARY.020120PK 350300 05 WHM-ASCII-CHARACTERS. 021101PK 350340 10 WHM-CRLF. 021101PK 350342 15 WHM-CR PIC X(1) VALUE @0D@. 021101PK 350344 15 WHM-LF PIC X(1) VALUE @25@. 021101PK 350400 05 WHM-HEX-VALUES PIC X(16) VALUE 020120PK 350420 "0123456789ABCDEF". 020120PK 350440 05 WHM-HEX-DIGITS REDEFINES WHM-HEX-VALUES. 020120PK 350460 10 WHM-HEXIT PIC X(1) 020120PK 350480 OCCURS 16 INDEXED WHM-HXX. 020120PK 350500 05 WHM-HTTP-TRANCODE PIC X(17) VALUE "UDEMO". 021101PK 350520 05 WHM-HTTP-WEBPCM-VDIR PIC X(10) VALUE "/UNITEDEMO". 021101PK 350522 05 WHM-HOME-URL PIC X(15) VALUE 021101PK 350524 "/UNITEDEMO/HOME". 021101PK 350540 05 WHM-COOKIE-NAME PIC X(12) VALUE "UDEMO". 021101PK 350560 05 WHM-COOKIE-TAG PIC X(3) VALUE "UWD". 021101PK 350580 05 WHM-COOKIE-VERSION PIC X(1) VALUE "0". 020109PK 350600 05 WHM-COOKIE-STATES. 020109PK 350610 10 WHM-STATE-LOGON PIC 9(2) VALUE ZERO COMP. 020109PK 350620 10 WHM-STATE-DENIED PIC 9(2) VALUE 1 COMP. 020109PK 350630 10 WHM-STATE-LOGOFF PIC 9(2) VALUE 2 COMP. 020109PK 350640 10 WHM-STATE-IDLE PIC 9(2) VALUE 3 COMP. 020109PK 350700 05 WHM-MESSAGE-FLAGS. 020120PK 350720 10 WHM-SESSION-VALID PIC 9(1) COMP. 020109PK 350740 10 WHM-COOKIE-VALID PIC 9(1) COMP. 020109PK 350760 10 WHM-CHUNKED-OUTPUT PIC 9(1) COMP. 020120PK 350780 10 WHM-FINAL-CHUNK PIC 9(1) COMP. 020120PK 350800 10 WHM-COOKIE-NEEDED PIC 9(1) COMP. 020120PK 350820 10 FILLER PIC 9(1) COMP. 020120PK 350980 05 FILLER REAL SYNC. 020120PK 351000 05 WHM-HTTP-HEADER. 351010 10 WHM-H-REMOTE-HOST PIC X(60). 020109PK 351020 10 WHM-H-REMOTE-USER PIC X(40). 020109PK 351030 10 WHM-H-METHOD PIC X(8). 020109PK 351040 10 WHM-H-REMOTE-ADDRESS. 020109PK 351050 15 WHM-H-RAC OCCURS 18 INDEXED WHM-H-RAX. 020109PK 351060 20 WHM-H-RAN PIC 9(1). 020109PK 351080 10 WHM-H-APP-PATH. 351100 15 WHM-H-APP-VDIR PIC X(10). 021101PK 351140 15 WHM-H-APP-FUNCTION. 351160 20 FILLER PIC X(1). 351180 20 WHM-H-APP-TRANCODE PIC X(10). 351500 05 WHM-AUTH-CHALLENGE. 020109PK 351520 10 WHM-AUTH-SCHEME PIC X(6) VALUE "Basic". 020120PK 351540 10 FILLER PIC X(7) VALUE "realm=""". 021101PK 351560 10 WHM-AUTH-REALM PIC X(60) VALUE SPACE. 021101PK 351580 10 FILLER PIC X(1) VALUE """". 021101PK 352000 05 WHM-IDENTIFICATION. 020109PK 352020 10 WHM-ID-HOST-NAME PIC X(18). 020120PK 352120 10 WHM-ID-USER-ID PIC X(18). 020109PK 352140 10 WHM-ID-PASSWORD PIC X(18). 020109PK 352160 10 WHM-ID-IP-ADDRESS. 020109PK 352180 15 WHM-ID-IP-ADDR-1 PIC 9(3). 021101PK 352200 15 WHM-ID-IP-ADDR-2 PIC 9(3). 021101PK 352220 15 WHM-ID-IP-ADDR-3 PIC 9(3). 021101PK 352240 15 WHM-ID-IP-ADDR-4 PIC 9(3). 021101PK 352500 05 WHM-HTTP-STATUS-RESULT. 020109PK 352520 10 WHM-STATUS-CODE PIC 9(3). 020109PK 352540 10 WHM-STATUS-SUBCODE PIC 9(3). 020109PK 352560 10 WHM-STATUS-TEXT PIC X(80). 020120PK 353000 05 WHM-COOKIE-LAYOUT. 020109PK 353020 10 WHM-C-HEADER. 020109PK 353040 15 WHM-C-COOKIE-TAG PIC X(3). 020109PK 353060 15 WHM-C-COOKIE-VERSION PIC X(1). 020109PK 353080 15 WHM-C-IP-ADDRESS. 021101PK 353082 20 WHM-C-IP-ADDR1 PIC 9(3). 021101PK 353084 20 WHM-C-IP-ADDR2 PIC 9(3). 021101PK 353086 20 WHM-C-IP-ADDR3 PIC 9(3). 021101PK 353088 20 WHM-C-IP-ADDR4 PIC 9(3). 021101PK 353100 15 WHM-C-STATE PIC 9(2). 021101PK 353120 15 WHM-C-STEP PIC 9(2). 021101PK 353140 15 WHM-C-EXPIRE-STAMP PIC 9(12). 021101PK 353400 10 WHM-C-STATE-DATA. 020109PK 353440 15 WHM-C-REFRESH-SECS PIC 9(4). 021101PK 353500 15 WHM-C-DATA PIC X(30). 021101PK 354000 05 WHM-STD-HEADER-1. 354020 10 FILLER PIC X(22) VALUE "". 354080 10 FILLER PIC X(2) VALUE @0D25@. 354100 10 FILLER PIC X(19) VALUE "". 354120 10 FILLER PIC X(26) VALUE "UNITE AS4026 WEBPCM Demo: ". 021101PK 354140 10 WHM-SH1-TITLE PIC X(72) VALUE SPACE. 021101PK 354160 10 FILLER PIC X(8) VALUE "". 354180 10 FILLER PIC X(2) VALUE @0D25@. 354200*--> 10 FILLER PIC X(21) VALUE " 10 FILLER PIC X(2) VALUE """>". 021101PK 354280 05 WHM-STD-HEADER-2. 354300 10 FILLER PIC X(13) VALUE "". 020120PK 354320 10 FILLER PIC X(2) VALUE @0D25@. 355000 05 WHM-LOGOFF-BODY. 020120PK 355010 10 FILLER PIC X(30) VALUE "

Goodbye.

 

".020120PK 355020 10 FILLER PIC X(21) VALUE "". 021101PK 355050 10 FILLER PIC X(25) VALUE "Log back in to the UNITE ". 021101PK 355060 10 FILLER PIC X(15) VALUE "WEBPCM Demo". 021101PK 357000 05 WHM-CHUNK-HEADER. 020120PK 357010 10 WHM-CHUNK-SIZE. 020120PK 357020 15 WHM-CHUNK-HEXIT PIC X(1) 020120PK 357030 OCCURS 4 INDEXED WHM-CHX. 020120PK 357040 10 FILLER PIC X(2) VALUE @0D25@. 020120PK 357060 05 WHM-CHUNK-TRAILER. 020120PK 357080 10 FILLER PIC X(1) VALUE ZERO. 020120PK 357100 10 FILLER PIC X(2) VALUE @0D25@. 020120PK 357120 10 FILLER PIC X(2) VALUE @0D25@. 020120PK 358000 358020 77 WHC-INDEX PIC S9(11) BINARY.020207PK 358040 77 WHC-LIMIT PIC S9(11) BINARY.020207PK 358100 358120 01 WHC-HTTP-CONTENT. 358140 05 WHC-C PIC X(1) 358160 OCCURS 8100 INDEXED WHC-X. 020120PK 370000 370020 01 WEA-EDIT-AREA. 370040 05 WEA-NUMBER-DIGITS-MAX PIC 9(2) VALUE 11 BINARY.021101PK 370300 05 WEA-EDIT-ERROR PIC 9(1) BINARY.021101PK 370500 05 WEA-WORD REAL SYNC. 020120PK 370510 05 WEA-INTEGER REDEFINES WEA-WORD 370520 PIC S9(11) BINARY. 370530 05 WEA-WORD-OCTETS REDEFINES WEA-WORD. 020109PK 370540 10 FILLER PIC X(1). 370550 10 WEA-5-BYTES. 011009PK 370560 15 FILLER PIC X(1). 370570 15 WEA-4-BYTES. 011009PK 370580 20 FILLER PIC X(1). 370590 20 WEA-3-BYTES. 011009PK 370600 25 FILLER PIC X(1). 370610 25 WEA-2-BYTES. 011009PK 370620 30 FILLER PIC X(1). 370630 30 WEA-1-BYTE PIC X(1). 011009PK 370640 05 WEA-BYTES REDEFINES WEA-WORD. 020109PK 370650 10 WEA-BYTE PIC X(1) 020109PK 370660 OCCURS 6 INDEXED WEA-BX. 020109PK 371000 05 WEA-IP-ADDR. 020109PK 371020 10 WEA-IP-ADDR-BYTE PIC 9(3) 020109PK 371040 OCCURS 4 INDEXED WEA-IPX. 020109PK 371340 05 WEA-REFRESH-PARAM. 020207PK 371360 10 WEA-REFRESH-SECS PIC 9(4). 020207PK 371500 05 WEA-DATE-MMDDYYYY PIC 9(8). 020205PK 371510 05 WEA-DATE-MMDDYYYY-FIELDS REDEFINES WEA-DATE-MMDDYYYY. 020205PK 371520 10 WEA-DATE-MMDD PIC 9(4). 020205PK 371530 10 WEA-DATE-MMDD-FIELDS REDEFINES WEA-DATE-MMDD. 020205PK 371540 15 WEA-DATE-MM PIC 9(2). 020205PK 371550 15 WEA-DATE-DD PIC 9(2). 020205PK 371560 10 WEA-DATE-YYYY PIC 9(4). 020205PK 371570 10 WEA-DATE-YYYY-FIELDS REDEFINES WEA-DATE-YYYY. 020205PK 371580 15 WEA-DATE-CC PIC 9(2). 020205PK 371590 15 WEA-DATE-YY PIC 9(2). 020205PK 371600 05 WEA-DATE-MMDDYYYY-CHARS REDEFINES WEA-DATE-MMDDYYYY. 020205PK 371610 10 WEA-DC PIC X(1) 020205PK 371620 OCCURS 8 INDEXED WEA-DCX. 020205PK 371700 05 WEA-FORMAT-TIMESTAMP. 020214PK 371710 10 WEA-STAMP-HOUR PIC 9(2). 020214PK 371720 10 FILLER PIC X(1) VALUE ":". 020214PK 371730 10 WEA-STAMP-MINUTE PIC 9(2). 020214PK 372000 05 WEA-NUMBER-AREA. 021101PK 372020 10 WEA-NUMBER-VALID PIC 9(1). 021101PK 372040 10 WEA-NUMBER-NEG PIC 9(1). 021101PK 372060 10 WEA-NUMBER-IN. 021101PK 372080 15 WEA-NIC OCCURS 11 021101PK 372100 INDEXED WEA-NICX, WEA-NIEX. 021101PK 372120 20 WEA-NIN PIC 9(1). 021101PK 372140 10 WEA-NUMBER-OUT PIC S9(11). 021101PK 372160 10 WEA-NUMBER-OUT-DIGITS REDEFINES WEA-NUMBER-OUT. 372180 15 WEA-NOC OCCURS 11 INDEXED WEA-NOCX. 021101PK 372200 20 WEA-NON PIC 9(1). 021101PK 375000 020109PK 375020* -- COOKIE PARSING AREA -- 020109PK 375030 77 WCJ-COOKIE-MAX PIC 9(4) VALUE 40 BINARY.020120PK 375040 77 WCJ-NAME-VALUE-MAX PIC 9(4) VALUE 88 BINARY.020120PK 375050 77 WCJ-SELECTION-MAX PIC 9(4) VALUE 330 BINARY.020120PK 375060 77 WCJ-NAME-LEN PIC 9(4) VALUE 12 BINARY.020120PK 375070 77 WCJ-VALUE-LEN PIC 9(4) VALUE 78 BINARY.020120PK 375080 77 WCJ-SEL-LEN PIC 9(4) VALUE 12 BINARY.020120PK 375090 77 WCJ-COOKIE-LEN PIC 9(4) VALUE 120 BINARY.020120PK 375100 77 WCJ-PATH-LEN PIC 9(4) VALUE 30 BINARY.020109PK 375120 77 WCJ-DOMAIN-LEN PIC 9(4) VALUE 30 BINARY.020109PK 375140 77 WCJ-PORT-LEN PIC 9(4) VALUE 6 BINARY.020109PK 375160 77 WCJ-COOKIE-VERSION PIC S9(4) BINARY.020109PK 375180 77 WCJ-ENTRIES PIC S9(4) BINARY.020120PK 375190 77 WCJ-INDEX PIC S9(4) BINARY.020120PK 375200 020109PK 375220 01 WCJ-CONTENT-JAR. 020120PK 375240 05 WCJ-CONTENT-DATA PIC X(7920). 020120PK 375260 05 WCJ-COOKIE-JAR REDEFINES WCJ-CONTENT-DATA. 020120PK 375280 10 WCJ-COOKIE-TABLE OCCURS 40 INDEXED WCJ-CX. 020120PK 375300 15 WCJ-COOKIE-ENTRY. 020120PK 375320 20 WCJ-COOKIE-NAME PIC X(12). 020120PK 375340 20 WCJ-COOKIE-VALUE PIC X(120). 020120PK 375360 20 WCJ-COOKIE-PATH PIC X(30). 020120PK 375380 20 WCJ-COOKIE-DOMAIN PIC X(30). 020120PK 375400 20 WCJ-COOKIE-PORT PIC X(6). 020120PK 375420 05 WCJ-NAME-VALUE-PAIRS REDEFINES WCJ-CONTENT-DATA. 020120PK 375440 10 WCJ-NAME-VALUE-TABLE OCCURS 88 INDEXED WCJ-VX. 020120PK 375460 15 WCJ-NAME-VALUE-ENTRY. 020120PK 375480 20 WCJ-NAME PIC X(12). 020120PK 375482 20 WCJ-NAME-2-FIELDS REDEFINES WCJ-NAME. 020205PK 375484 25 WCJ-NAME-2 PIC X(2). 020205PK 375486 25 WCJ-NAME-2R PIC X(10). 020205PK 375488 20 WCJ-NAME-3-FIELDS REDEFINES WCJ-NAME. 020205PK 375490 25 WCJ-NAME-3 PIC X(3). 020205PK 375492 25 WCJ-NAME-3R PIC X(9). 020205PK 375500 20 WCJ-VALUE. 020205PK 375502 25 WCJ-VC PIC X(1) 020205PK 375504 OCCURS 78 INDEXED WCJ-VCX. 020205PK 375520 20 WCJ-VALUE-FIELDS REDEFINES WCJ-VALUE. 020120PK 375540 25 WCJ-VALUE-30. 020120PK 375560 30 WCJ-VALUE-12. 020120PK 375580 35 WCJ-VALUE-6 PIC X(6). 020120PK 375600 35 WCJ-VALUE-6R PIC X(6). 020205PK 375620 30 WCJ-VALUE-12R PIC X(18). 020205PK 375640 25 WCJ-VALUE-30R PIC X(48). 020205PK 375660 05 WCJ-SELECTION-PAIRS REDEFINES WCJ-CONTENT-DATA. 020120PK 375680 10 WCJ-SEL-TABLE OCCURS 330 INDEXED WCJ-SX. 020120PK 375700 15 WCJ-SEL-ENTRY. 020120PK 375720 20 WCJ-SEL-NAME PIC X(12). 020120PK 375740 20 WCJ-SEL-VALUE PIC X(12). 020120PK 380000 021101PK 380010 01 WHS-HTML-STRINGS. 021101PK 380020 05 WHS-HOME-PAGE. 021101PK 380030 10 FILLER PIC X(15) VALUE "

Welcome to ". 021101PK 380040 10 FILLER PIC X(27) VALUE "the AS4026 WEBPCM Demo

". 021101PK 380050 10 FILLER PIC X(11) VALUE "
". 021101PK 380060 10 FILLER PIC X(20) VALUE "
". 021101PK 380070 10 WHS-HOME-HEAD-HOUR PIC 9(2). 021101PK 380080 10 FILLER PIC X(1) VALUE ":". 021101PK 380090 10 WHS-HOME-HEAD-MINUTE PIC 9(2). 021101PK 380100 10 FILLER PIC X(11) VALUE " on ". 021101PK 380110 10 WHS-HOME-HEAD-DATE PIC X(11). 021101PK 380120 10 FILLER PIC X(13) VALUE "

". 021101PK 380130 10 FILLER PIC X(31) VALUE "This program demonstrates some".021101PK 380140 10 FILLER PIC X(28) VALUE "of the basic techniques for ". 021101PK 380150 10 FILLER PIC X(30) VALUE "using the WEBPCM interface to ".021101PK 380160 10 FILLER PIC X(31) VALUE "the MCP Web Transaction Server".021101PK 380170 10 FILLER PIC X(11) VALUE "(Atlas).

". 021101PK 380180 10 FILLER PIC X(26) VALUE "". 021101PK 380190 10 FILLER PIC X(27) VALUE "Perform an ""echo"" function.". 021101PK 380200 10 FILLER PIC X(07) VALUE "

". 021101PK 380210 10 FILLER PIC X(25) VALUE "". 021101PK 380220 10 FILLER PIC X(28) VALUE "Show a calendar page.

". 021101PK 380230 10 FILLER PIC X(28) VALUE "".021101PK 380240 10 FILLER PIC X(29) VALUE "Log off the demo program.". 021101PK 380250 10 FILLER PIC X(28) VALUE "

". 021101PK 380500 05 WHS-HOME-LINK. 021101PK 380510 10 FILLER PIC X(25) VALUE "Home". 021101PK 380520 10 FILLER PIC X(04) VALUE "". 021101PK 381000 05 WHS-CAL-FORM-TAG. 021101PK 381010 10 FILLER PIC X(25) VALUE "
". 021101PK 381030 05 WHS-CAL-HEAD. 021101PK 381040 10 FILLER PIC X(11) VALUE "

AS4026 ". 021101PK 381050 10 FILLER PIC X(29) VALUE "Calendar Demo

". 021101PK 381060 10 FILLER PIC X(17) VALUE "
". 021101PK 381070 10 WHS-CAL-HEAD-HOUR PIC 9(2). 021101PK 381080 10 FILLER PIC X(1) VALUE ":". 021101PK 381090 10 WHS-CAL-HEAD-MINUTE PIC 9(2). 021101PK 381100 10 FILLER PIC X(4) VALUE " on ". 021101PK 381110 10 WHS-CAL-HEAD-DATE PIC X(11). 021101PK 381120 10 FILLER PIC X(06) VALUE "
". 021101PK 381130 05 WHS-MONTH-SEL-TAG. 021101PK 381140 10 FILLER PIC X(29) VALUE "

". 021101PK 381260 05 WHS-CAL-TABLE-HEAD. 021101PK 381270 10 FILLER PIC X(24) VALUE "

". 021101PK 381290 10 FILLER PIC X(25) VALUE "" DELIMITED BY SIZE 021101PK 663140 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX. 021101PK 663160 021101PK 663180 MOVE 1 TO WDA-IN-DD. 021101PK 663200 PERFORM Q124-WEEK-DAY THRU Q124-EXIT. 021101PK 663220 MOVE 1 TO W-X. 021101PK 663240 021101PK 663260 1630-FILL-PRE-DAY-LOOP. 021101PK 663280 IF W-X < WDA-WEEK-DAY 021101PK 663300 STRING "" DELIMITED BY SIZE 021101PK 663480 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX. 021101PK 663500 021101PK 663520 MOVE WDA-IN-DD TO WHS-CAL-DAY-CELL-VALUE. 021101PK 663540 STRING WHS-CAL-DAY-CELL DELIMITED BY SIZE 021101PK 663560 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX. 021101PK 663580 ADD 1 TO WDA-WEEK-DAY. 021101PK 663600 MOVE 1 TO WDA-INCREMENT. 021101PK 663620 PERFORM Q120-INCREMENT-DATE THRU Q120-EXIT. 021101PK 663640 IF WDA-IN-MM = WDA-OUT-MM 021101PK 663660 MOVE WDA-OUT-DATE TO WDA-IN-DATE 021101PK 663680 GO TO 1630-FILL-MONTH-DAY-LOOP. 021101PK 663700 021101PK 663720 1630-FILL-POST-DAY-LOOP. 021101PK 663740 IF WDA-WEEK-DAY NOT > 7 021101PK 663760 STRING "
SunMonTue". 021101PK 381300 10 FILLER PIC X(28) VALUE "WedThuFriSat". 021101PK 381310 05 WHS-CAL-DAY-CELL. 021101PK 381320 10 FILLER PIC X(17) VALUE "". 381330 10 WHS-CAL-DAY-CELL-VALUE PIC Z9. 021101PK 400000 021101PK 400020 01 WIV-INPUT-VALUES. 021101PK 400040 05 WIV-CALENDAR-FIELDS. 021101PK 400060 10 WIV-CAL-MONTH PIC X(2). 021101PK 400080 10 WIV-CAL-YEAR. 021101PK 400100 15 WIV-CAL-YEAR-N PIC ZZZ9. 021101PK 470000 470010 01 WDA-DATE-AREA. 470020* COPY "(PAUL)COPY/UTIL/DATE/WORKAREA ON OPS". 021101PK 470030 05 WDA-TIME-6-FACTOR VALUE 0.00003840 REAL. 021101PK 470040 05 WDA-SEC-PER-TICK VALUE 0.0000024 REAL. 021101PK 470050 05 WDA-SEC-PER-DAY VALUE 86400 REAL. 021101PK 470060 05 WDA-MIN-DATE PIC 9(8) VALUE 19000301. 021101PK 470070 05 WDA-MAX-DATE PIC 9(8) VALUE 21000228. 021101PK 470080 05 WDA-CENTURY-BIAS PIC 9(4) VALUE 95. 021101PK 470090 05 WDA-YEAR-BASIS PIC 9(4) VALUE 1900. 021101PK 470100 021101PK 470110 05 WDA-IN-DATE PIC 9(8). 021101PK 470120 05 WDA-IN-FIELDS REDEFINES WDA-IN-DATE. 021101PK 470130 10 WDA-IN-YYMM PIC 9(6). 021101PK 470140 10 FILLER PIC 9(2). 021101PK 470150 05 WDA-IN-YYMM-FIELDS REDEFINES WDA-IN-DATE. 021101PK 470160 10 WDA-IN-YY PIC 9(4). 021101PK 470170 10 WDA-IN-MMDD PIC 9(4). 021101PK 470180 05 WDA-IN-CCYYMMDD REDEFINES WDA-IN-DATE. 021101PK 470190 10 WDA-IN-CC PIC 9(2). 021101PK 470200 10 WDA-IN-YYMMDD PIC 9(6). 021101PK 470210 10 WDA-IN-YYMMDD-FIELDS REDEFINES WDA-IN-YYMMDD. 021101PK 470220 15 WDA-IN-CY PIC 9(2). 021101PK 470230 15 WDA-IN-MM PIC 9(2). 021101PK 470240 15 WDA-IN-DD PIC 9(2). 021101PK 470250 021101PK 470260 05 WDA-TIME-IN PIC 9(8). 021101PK 470270 05 WDA-TIME-HHMMSS-IN REDEFINES WDA-TIME-IN 021101PK 470280 PIC 9(6)V99. 021101PK 470290 05 WDA-TIME-IN-FIELDS REDEFINES WDA-TIME-IN. 021101PK 470300 10 WDA-TIME-IN-HHMM PIC 9(4). 021101PK 470310 10 WDA-TIME-IN-HHMM-FIELDS REDEFINES WDA-TIME-IN-HHMM. 021101PK 470320 15 WDA-TIME-IN-HOUR PIC 9(2). 021101PK 470330 15 WDA-TIME-IN-MINUTE PIC 9(2). 021101PK 470340 10 WDA-TIME-IN-SECOND PIC 9(2)V99. 021101PK 470350 021101PK 470360 05 WDA-OUT-DATE PIC 9(8). 021101PK 470370 05 WDA-OUT-FIELDS REDEFINES WDA-OUT-DATE. 021101PK 470380 10 WDA-OUT-YYMM PIC 9(6). 021101PK 470390 10 FILLER PIC 9(2). 021101PK 470400 05 WDA-OUT-YYMM-FIELDS REDEFINES WDA-OUT-DATE. 021101PK 470410 10 WDA-OUT-YY PIC 9(4). 021101PK 470420 10 WDA-OUT-MMDD PIC 9(4). 021101PK 470430 05 WDA-OUT-CCYYMMDD REDEFINES WDA-OUT-DATE. 021101PK 470440 10 WDA-OUT-CC PIC 9(2). 021101PK 470450 10 WDA-OUT-YYMMDD PIC 9(6). 021101PK 470460 10 WDA-OUT-YYMMDD-FIELDS REDEFINES WDA-OUT-YYMMDD. 021101PK 470470 15 WDA-OUT-CY PIC 9(2). 021101PK 470480 15 WDA-OUT-MM PIC 9(2). 021101PK 470490 15 WDA-OUT-DD PIC 9(2). 021101PK 470500 021101PK 470510 05 WDA-TIME-OUT PIC 9(8). 021101PK 470520 05 WDA-TIME-HHMMSS-OUT REDEFINES WDA-TIME-OUT 021101PK 470530 PIC 9(6)V99. 021101PK 470540 05 WDA-TIME-OUT-FIELDS REDEFINES WDA-TIME-OUT. 021101PK 470550 10 WDA-TIME-OUT-HHMM PIC 9(4). 021101PK 470560 10 WDA-TIME-OUT-HHMM-FIELDS REDEFINES WDA-TIME-OUT-HHMM. 021101PK 470570 15 WDA-TIME-OUT-HOUR PIC 9(2). 021101PK 470580 15 WDA-TIME-OUT-MINUTE PIC 9(2). 021101PK 470590 10 WDA-TIME-OUT-SECOND PIC 9(2)V99. 021101PK 470680 021101PK 470690 05 WDA-TIME-6-IN SYNC REAL. 021101PK 470700 05 WDA-TIME-6-OUT REAL. 021101PK 470710 05 WDA-TIMESTAMP-IN PIC S9(11) BINARY.021101PK 470720 05 WDA-TIMESTAMP-OUT PIC S9(11) BINARY.021101PK 470730 05 WDA-JULIAN PIC S9(11) BINARY.021101PK 470740 05 WDA-INCREMENT PIC S9(11) BINARY.021101PK 470750 05 WDA-WEEK-DAY PIC 9(1) BINARY.021101PK 470760 05 WDA-WORK-DAY PIC S9(11) BINARY.021101PK 470770 05 WDA-WORK-YY PIC 9(4) BINARY.021101PK 470780 05 WDA-WORK-MM PIC 9(2) BINARY.021101PK 470790 05 WDA-WORK-DD PIC 9(2) BINARY.021101PK 470800 05 WDA-VALID-DATE PIC 9(1) BINARY.021101PK 470810 05 WDA-TIME-6-TIME PIC S9(11) BINARY.021101PK 470820 05 WDA-TIME-6-DATE PIC S9(11) BINARY.021101PK 470830 05 WDA-TIME-6-YEAR PIC S9(11) BINARY.021101PK 470840 05 WDA-TIME-6-DAY PIC S9(11) BINARY.021101PK 470850 05 WDA-SYS-TIMER REAL. 021101PK 470860 05 WDA-SYS-TOD REAL. 021101PK 470870 05 WDA-SYS-TIMESTAMP REAL. 021101PK 470880 05 WDA-BOD-TIMESTAMP REAL. 021101PK 470890 05 WDA-EOD-TIMESTAMP REAL. 021101PK 470900 021101PK 470910 05 WDA-SAVE-DATE PIC 9(8). 021101PK 470920 05 WDA-SAVE-DATE-FIELDS REDEFINES WDA-SAVE-DATE. 021101PK 470930 10 WDA-SAVE-YY PIC 9(4). 021101PK 470940 10 WDA-SAVE-MM PIC 9(2). 021101PK 470950 10 WDA-SAVE-DD PIC 9(2). 021101PK 470960 021101PK 470970 05 WDA-SYS-DATE PIC 9(8). 021101PK 470980 05 WDA-SYS-DATE-FIELDS REDEFINES WDA-SYS-DATE. 021101PK 470990 10 WDA-SYS-YY PIC 9(4). 021101PK 471000 10 WDA-SYS-MM PIC 9(2). 021101PK 471010 10 WDA-SYS-DD PIC 9(2). 021101PK 471020 021101PK 471030 05 WDA-SYS-TIME PIC 9(8). 021101PK 471040 05 WDA-SYS-HHMMSS REDEFINES WDA-SYS-TIME 021101PK 471050 PIC 9(6)V9(2). 021101PK 471060 05 WDA-SYS-HHMM-SS REDEFINES WDA-SYS-TIME. 021101PK 471070 10 WDA-SYS-HHMM PIC 9(4). 021101PK 471080 10 WDA-SYS-HH-MM REDEFINES WDA-SYS-HHMM. 021101PK 471090 15 WDA-SYS-HOUR PIC 9(2). 021101PK 471100 15 WDA-SYS-MIN PIC 9(2). 021101PK 471110 10 WDA-SYS-SEC PIC 9(2)V9(2). 021101PK 471120 021101PK 471130 05 WDA-MM-DD-YYYY. 021101PK 471140 10 WDA-MDY-MM PIC 9(2). 021101PK 471150 10 WDA-MDY-D1 PIC X(1). 021101PK 471160 10 WDA-MDY-DD PIC 9(2). 021101PK 471170 10 WDA-MDY-D2 PIC X(1). 021101PK 471180 10 WDA-MDY-YYYY PIC 9(4). 021101PK 471190 05 WDA-YYYY-MM-DD. 021101PK 471200 10 WDA-YMD-YYYY PIC 9(4). 021101PK 471210 10 WDA-YMD-D1 PIC X(1). 021101PK 471220 10 WDA-YMD-MM PIC 9(2). 021101PK 471230 10 WDA-YMD-D2 PIC X(1). 021101PK 471240 10 WDA-YMD-DD PIC 9(2). 021101PK 471250 05 WDA-DD-MMM-YYYY. 021101PK 471260 10 WDA-DMY-DD PIC 9(2). 021101PK 471270 10 WDA-DMY-D1 PIC X(1). 021101PK 471280 10 WDA-DMY-MMM PIC X(3). 021101PK 471290 10 WDA-DMY-D2 PIC X(1). 021101PK 471300 10 WDA-DMY-YYYY PIC 9(4). 021101PK 471310 05 WDA-DOW-VALUES. 021101PK 471320 10 WDA-SUNDAY PIC 9(1) VALUE 1. 021101PK 471330 10 FILLER PIC X(9) VALUE "Sunday". 021101PK 471340 10 WDA-MONDAY PIC 9(1) VALUE 2. 021101PK 471350 10 FILLER PIC X(9) VALUE "Monday". 021101PK 471360 10 WDA-TUESDAY PIC 9(1) VALUE 3. 021101PK 471370 10 FILLER PIC X(9) VALUE "Tuesday". 021101PK 471380 10 WDA-WEDNESDAY PIC 9(1) VALUE 4. 021101PK 471390 10 FILLER PIC X(9) VALUE "Wednesday". 021101PK 471400 10 WDA-THURSDAY PIC 9(1) VALUE 5. 021101PK 471410 10 FILLER PIC X(9) VALUE "Thursday". 021101PK 471420 10 WDA-FRIDAY PIC 9(1) VALUE 6. 021101PK 471430 10 FILLER PIC X(9) VALUE "Friday". 021101PK 471440 10 WDA-SATURDAY PIC 9(1) VALUE 7. 021101PK 471450 10 FILLER PIC X(9) VALUE "Saturday". 021101PK 471460 05 WDA-DOW-TABLE REDEFINES WDA-DOW-VALUES 021101PK 471470 OCCURS 7 INDEXED WDA-DWX. 021101PK 471480 10 WDA-DOW-INDEX PIC 9(1). 021101PK 471490 10 WDA-DOW-NAME. 021101PK 471500 15 WDA-DOW-NAME-3 PIC X(3). 021101PK 471510 15 FILLER PIC X(6). 021101PK 471520 05 WDA-MONTH-VALUES. 021101PK 471530 10 WDA-JANUARY PIC 9(2) VALUE 1. 021101PK 471540 10 FILLER PIC X(9) VALUE "January". 021101PK 471550 10 WDA-FEBRUARY PIC 9(2) VALUE 2. 021101PK 471560 10 FILLER PIC X(9) VALUE "February". 021101PK 471570 10 WDA-MARCH PIC 9(2) VALUE 3. 021101PK 471580 10 FILLER PIC X(9) VALUE "March". 021101PK 471590 10 WDA-APRIL PIC 9(2) VALUE 4. 021101PK 471600 10 FILLER PIC X(9) VALUE "April". 021101PK 471610 10 WDA-MAY PIC 9(2) VALUE 5. 021101PK 471620 10 FILLER PIC X(9) VALUE "May". 021101PK 471630 10 WDA-JUNE PIC 9(2) VALUE 6. 021101PK 471640 10 FILLER PIC X(9) VALUE "June". 021101PK 471650 10 WDA-JULY PIC 9(2) VALUE 7. 021101PK 471660 10 FILLER PIC X(9) VALUE "July". 021101PK 471670 10 WDA-AUGUST PIC 9(2) VALUE 8. 021101PK 471680 10 FILLER PIC X(9) VALUE "August". 021101PK 471690 10 WDA-SEPTEMBER PIC 9(2) VALUE 9. 021101PK 471700 10 FILLER PIC X(9) VALUE "September". 021101PK 471710 10 WDA-OCTOBER PIC 9(2) VALUE 10. 021101PK 471720 10 FILLER PIC X(9) VALUE "October". 021101PK 471730 10 WDA-NOVEMBER PIC 9(2) VALUE 11. 021101PK 471740 10 FILLER PIC X(9) VALUE "November". 021101PK 471750 10 WDA-DECEMBER PIC 9(2) VALUE 12. 021101PK 471760 10 FILLER PIC X(9) VALUE "December". 021101PK 471770 05 WDA-MONTH-TABLE REDEFINES WDA-MONTH-VALUES 021101PK 471780 OCCURS 12 INDEXED WDA-DMX. 021101PK 471790 10 WDA-MONTH-INDEX PIC 9(2). 021101PK 471800 10 WDA-MONTH-NAME. 021101PK 471810 15 WDA-MONTH-NAME-3 PIC X(3). 021101PK 471820 15 FILLER PIC X(6). 021101PK 472600 472620 01 WTL-TRAFFIC-LOG-AREA. 472640* COPY "(PAUL)COPY/UTIL/TRAFFIC/LOGVALUES ON OPS". 021101PK 472650 05 WTL-HEADER-SIZE PIC 9(4) VALUE 146 BINARY.021101PK 472660 05 WTL-PREFIX-SIZE PIC 9(4) VALUE 34 BINARY.021101PK 472670 05 WTL-MAX-TEXT-SIZE PIC 9(4) VALUE 8192 BINARY.021101PK 472680 05 WTL-MIN-REC-SIZE PIC 9(4) VALUE 36 BINARY.021101PK 472690 05 WTL-MAX-REC-SIZE PIC 9(4) VALUE 8338 BINARY.021101PK 472700 05 WTL-TEXT-INDEX PIC S9(6) BINARY.021101PK 472710 05 WTL-TEXT-LENGTH PIC S9(6) BINARY.021101PK 472720 05 WTL-LOGGING PIC 9(1) VALUE ZERO. 021101PK 472730 05 WTL-CLOSE-FINAL PIC 9(1) VALUE ZERO. 021101PK 472740 05 WTL-FILE-STATUS. 021101PK 472750 10 WTL-FILE-STATUS-1 PIC X(1). 021101PK 472760 10 WTL-FILE-STATUS-2 PIC X(1). 021101PK 472770 05 WTL-LOG-FORMATS. 021101PK 472780 10 WTL-FORMAT-DEFAULT PIC X(1) VALUE ZERO. 021101PK 472790 10 WTL-FORMAT-CDI PIC X(1) VALUE "1". 021101PK 472800 10 WTL-FORMAT-CDO PIC X(1) VALUE "2". 021101PK 472810 10 WTL-FORMAT-TASK PIC X(1) VALUE "3". 021101PK 472820 10 WTL-FORMAT-DISPLAY PIC X(1) VALUE "4". 021101PK 472830 10 WTL-FORMAT-PORT PIC X(1) VALUE "5". 021101PK 472840 10 WTL-FORMAT-SEGMENT PIC X(1) VALUE "6". 021101PK 472850 05 WTL-LOG-TITLE. 021101PK 472860 10 FILLER PIC X(5) VALUE "DATA/". 021101PK 472870 10 FILLER PIC X(6) VALUE "UNITE/". 021101PK 472880 10 WTL-TITLE-MODULE PIC X(17) VALUE "WEBPCMDEMO". 021101PK 472890 10 FILLER PIC X(9) VALUE "/TRAFFIC/". 021101PK 472900 10 WTL-TITLE-DATE PIC 9(8) VALUE ZERO. 021101PK 472910 10 FILLER PIC X(4) VALUE " ON ". 021101PK 472920 10 WTL-TITLE-FAMILY PIC X(17) VALUE "DISK". 021101PK 472930 10 FILLER PIC X(1) VALUE ".". 021101PK 480000/ 480020 01 WMA-MISC-AREA. 020109PK 480040 05 WMA-MC PIC X(1) 480060 OCCURS 300 INDEXED WMA-MX. 480080 480100 01 FCM-COMS-MSG. 020109PK 480120 05 FCM-COMS-MSG-TEXT. 480220 10 FCM-MC PIC X(1) 480240 OCCURS 9168 INDEXED FCM-MCX. 011009PK 481020 01 FCM-HTTP-TXN REDEFINES FCM-COMS-MSG. 020109PK 481040 05 FCM-HTTP-TXN-HEADER. 481060 10 FCM-HTTP-TRANCODE PIC X(17). 481100 05 FCM-HTTP-TXN-BODY PIC X(9151). 483000 483020 01 FHM-HTTP-MSG. 020109PK 483040 05 FHM-HTTP-TXN-HEADER. 483060 10 FHM-HTTP-TRANCODE PIC X(17). 483080 05 FHM-HTTP-TXN-BODY PIC X(9151). 498000/ 498100****************************************************************** 498200 COMMUNICATION SECTION. 498300****************************************************************** 498500 INPUT HEADER CDI-COMS 498510 AGENDA IS CDI-AGENDA 498520 FUNCTIONINDEX IS CDI-FUNCTION 498530 FUNCTIONSTATUS IS CDI-FUNCTION-STATUS 498540 MESSAGECOUNT IS CDI-MESSAGE-COUNT 498550 PROGRAMDESG IS CDI-PROGRAM 498560 RESTART IS CDI-RESTART 498570 SECURITYDESG IS CDI-SECURITY 498580 STATION IS CDI-STATION 498590 STATUSVALUE IS CDI-STATUS 498600 TEXTLENGTH IS CDI-MSG-SIZE 498610 TIMESTAMP IS CDI-TIMESTAMP 498620 TRANSPARENT IS CDI-TRANSPARENT 498630 USERCODE IS CDI-USER 498640 VTFLAG IS CDI-VTFLAG 498650 CONVERSATION AREA. 498660 02 CDI-CONVERSATION. 498662 05 FILLER PIC X(6). 498664 05 CDI-STATION-NAME PIC X(18). 498666 05 CDI-USER-NAME PIC X(18). 498670 05 FILLER PIC X(30). 498700 498800 OUTPUT HEADER CDO-COMS 498810 AGENDA IS CDO-AGENDA 498820 CASUALOUTPUT IS CDO-CASUAL-OUTPUT 498830 CONFIRMFLAG IS CDO-CONFIRM-FLAG 498840 CONFIRMKEY IS CDO-CONFIRM-KEY 498850 DESTCOUNT IS CDO-DEST-COUNT 498860 DESTINATIONDESG IS CDO-DESTINATION 498870 NEXTINPUTAGENDA IS CDO-NEXT-AGENDA 498880 RETAINTRANSACTIONMODE IS CDO-RETAIN-TXN-MODE 498890 SETNEXTINPUTAGENDA IS CDO-SET-NEXT-AGENDA 498900 STATUSVALUE IS CDO-STATUS 498910 TEXTLENGTH IS CDO-MSG-SIZE 498920 TRANSPARENT IS CDO-TRANSPARENT 498930 VTFLAG IS CDO-VTFLAG 498940 CONVERSATION AREA. 498950 02 CDO-CONVERSATION. 498952 05 FILLER PIC X(6). 498954 05 CDO-STATION-NAME PIC X(18). 498956 05 CDO-USER-NAME PIC X(18). 498960 05 FILLER PIC X(30). 500000/ 500100 PROCEDURE DIVISION. 510100****************************************************************** 510120 0000-SECTION SECTION. 510140****************************************************************** 510160 0000-MAIN. 510180* MAIN DRIVER FOR THE WEBPCM WEB USER INTERFACE MODULE. 021101PK 510200 510220 PERFORM 0010-INITIALIZE THRU 0010-EXIT. 510240 PERFORM 0040-OPEN-DATA-BASE THRU 0040-EXIT. 510260 PERFORM 0020-OPEN-COMS THRU 0020-EXIT. 510300 510320 PERFORM 0100-EVENT-DISPATCH THRU 0100-EXIT. 010930PK 510340 510360 PERFORM 0030-TERMINATE THRU 0030-EXIT. 510380 510400 0000-EXIT. 510420 STOP RUN. 511000 511020****************************************************************** 511040 0010-INITIALIZE. 511060* INITIALIZES THE COMS MODULE. 511080 511100 PERFORM Q110-READ-SYSTEM-DATE THRU Q110-EXIT. 511120 MOVE WDA-SYS-DATE TO WDA-IN-DATE. 511125 MOVE ZERO TO WDA-TIME-IN. 511130 PERFORM Q162-DATETIME-TIMESTAMP THRU Q162-EXIT. 511132 MOVE WDA-TIMESTAMP-OUT TO WDA-BOD-TIMESTAMP. 011206PK 511134 COMPUTE WDA-EOD-TIMESTAMP = 011206PK 511136 WDA-BOD-TIMESTAMP + WDA-SEC-PER-DAY. 011206PK 511138 PERFORM Q116-READ-SYSTEM-TIMER THRU Q116-EXIT. 011206PK 511180 511190 MOVE ATTRIBUTE MIXNUMBER OF MYSELF TO W-MIX-NR. 511200 CHANGE ATTRIBUTE LIBACCESS OF "CENTRALSUPPORT" TO BYFUNCTION.021101PK 511300 511302$$ SET OMIT = NOT LOGGING 511304 MOVE W-TRUE TO WTL-LOGGING. 511306$$ POP OMIT 511308 511320 IF WTL-LOGGING = W-TRUE 511340 PERFORM 9828-OPEN-TRAFFIC-LOG THRU 9828-EXIT 511360 MOVE "TP BOT" TO TLF-TYPE 511380 MOVE WTL-HEADER-SIZE TO TLF-REC-SIZE 511400 MOVE WTL-FORMAT-TASK TO TLF-FORMAT 511420 MOVE SPACE TO TLF-TASK-HEADER 511422 MOVE W-MIX-NR TO TLF-TASK-MIX-NR 511424 MOVE ZERO TO TLF-TASK-STATUS 511426 MOVE ZERO TO TLF-TASK-HIST-TYPE, 511428 TLF-TASK-HIST-CAUSE, TLF-TASK-HIST-REASON 511440 MOVE ATTRIBUTE NAME OF MYSELF TO TLF-TASK-NAME 511500 PERFORM 9800-WRITE-TRAFFIC-LOG THRU 9800-EXIT. 511680 511700 0010-EXIT. 511720 EXIT. 512000 512020****************************************************************** 512040 0020-OPEN-COMS. 512060* OPENS THE COMS INTERFACE AND INITIALIZES THE STATION TABLE. 512080 512100 CHANGE ATTRIBUTE LIBACCESS OF "DCILIBRARY" TO BYINITIATOR. 512120 CHANGE ATTRIBUTE LIBACCESS OF "WEBAPPSUPPORT" TO BYFUNCTION. 512130 CALL "SET_TRACING IN WEBAPPSUPPORT" USING 020109PK 512132 W-FALSE 020109PK 512134 GIVING W-RESULT. 020109PK 512160 512180 ENABLE INPUT CDI-COMS KEY "ONLINE". 512200 512220 CALL "STATION_TABLE_INITIALIZE IN DCILIBRARY" USING 512240 WST-STATION-HASH, W-STATION-MODULUS. 512900 020205PK 512910 0020-EXIT. 020205PK 512920 EXIT. 020205PK 513000 513020****************************************************************** 513040 0030-TERMINATE. 513060* HANDLES TERMINATION CHORES FOR THE TP MODULE. 513080 513090 IF W-DATA-BASE-OPEN = W-TRUE 020109PK 513100*----> CLOSE WEBPCMDB 021101PK 513110 MOVE W-FALSE TO W-DATA-BASE-OPEN. 513120 513140 IF WTL-LOGGING = W-TRUE 513160 MOVE "TP EOT" TO TLF-TYPE 513180 MOVE WTL-HEADER-SIZE TO TLF-REC-SIZE 513200 MOVE WTL-FORMAT-TASK TO TLF-FORMAT 513220 MOVE SPACE TO TLF-TASK-HEADER 513240 MOVE W-MIX-NR TO TLF-TASK-MIX-NR 513245 MOVE ZERO TO TLF-TASK-STATUS 513250 MOVE ZERO TO TLF-TASK-HIST-TYPE, 513255 TLF-TASK-HIST-CAUSE, TLF-TASK-HIST-REASON 513260 MOVE ATTRIBUTE NAME OF MYSELF TO TLF-TASK-NAME 513300 PERFORM 9800-WRITE-TRAFFIC-LOG THRU 9800-EXIT 513320 PERFORM 9829-CLOSE-TRAFFIC-LOG THRU 9829-EXIT. 513340 513360 0030-EXIT. 513380 EXIT. 514000 514020****************************************************************** 514040 0040-OPEN-DATA-BASE. 514060* THIS ROUTINE NORMALLY OPENS THE DATA BASE FOR THE APPLICATION021118PK 514070* (WHICH IN THIS SAMPLE PROGRAM, WE DON'T HAVE). 021118PK 514080 514100*--> OPEN UPDATE WEBPCMDB ON EXCEPTION 021101PK 514120* MOVE DMSTATUS(DMERRORTYPE) TO WM-STATUS-VALUE 021101PK 514140* MOVE "WEBPCMDB open error (0040)" TO WM-STATUS-TEXT 021101PK 514160* PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 021101PK 514180*--> GO TO 0040-EXIT. 021101PK 514200 020109PK 514220*--> CREATE RDS-RESTART. 021101PK 514240* MOVE W-PROGRAM-ID TO R-JOB-NAME. 021101PK 514260* MOVE W-MIX-NR TO R-RUN-NUMBER. 021101PK 514280*--> MOVE "NYSTCP" TO R-COMS-ID. 021101PK 514420 020109PK 514440 MOVE W-TRUE TO W-DATA-BASE-OPEN. 020109PK 514460 IF ATTRIBUTE MAXWAIT OF MYSELF = ZERO 020109PK 514480 CHANGE ATTRIBUTE MAXWAIT OF MYSELF TO 5. 020109PK 514500 020109PK 514520 0040-EXIT. 020109PK 514540 EXIT. 020109PK 520000/ 520020****************************************************************** 520040 0100-SECTION SECTION. 520060****************************************************************** 520080 0100-EVENT-DISPATCH. 010930PK 520100* RECEIVES AND DISPATCHES INPUT MESSAGES FROM COMS. IT ALSO 021101PK 520102* WAKES UP EVERY W-TICKLER-PERIOD SECONDS TO HANDLE ANY TIME- 021101PK 520104* DELAY FUNCTIONS THE PROGRAM MAY SUPPORT. 021101PK 520110 520120 MOVE W-TRUE TO W-SERVER-ACTIVE. 520130 520140 0100-EVENT-LOOP. 520200 PERFORM Q116-READ-SYSTEM-TIMER THRU Q116-EXIT. 011206PK 520210 COMPUTE W-WAIT-DELTA = WDA-EOD-TIMESTAMP - WDA-SYS-TIMESTAMP.011206PK 520220 IF W-WAIT-DELTA > W-TICKLER-PERIOD 520230 MOVE W-TICKLER-PERIOD TO W-WAIT-DELTA 520240 ELSE IF W-WAIT-DELTA < ZERO 520260 MOVE ZERO TO W-WAIT-DELTA. 010930PK 520340 020120PK 520350 WAIT W-WAIT-DELTA, 010930PK 520390 ATTRIBUTE DCIINPUTEVENT OF MYSELF, 520400 ATTRIBUTE DCITASKEVENT OF MYSELF 520410 GIVING W-RESULT. 520420 520430 PERFORM Q116-READ-SYSTEM-TIMER THRU Q116-EXIT. 011206PK 520440 GO TO 520450 0100-01-TIMEOUT-EVENT 010921PK 520490 0100-02-DCIINPUTEVENT 520500 0100-03-DCITASKEVENT 520510 DEPENDING ON W-RESULT. 520520 520530 0100-00-INVALID-EVENT. 520540 MOVE W-RESULT TO WM-STATUS-VALUE 520550 MOVE "Invalid WAIT result (0100)" TO WM-STATUS-TEXT 520560 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 520570 CHANGE ATTRIBUTE STATUS OF MYSELF TO TERMINATED. 520580 520590 0100-01-TIMEOUT-EVENT. 010921PK 520600 PERFORM 0800-TIMEOUT-EVENT THRU 0800-EXIT. 010921PK 520610 GO TO 0100-NEXT-EVENT. 520740 520750 0100-02-DCIINPUTEVENT. 520760 0100-03-DCITASKEVENT. 520770 PERFORM 0110-COMS-RECEIVE-MESSAGE THRU 0110-EXIT. 520780 GO TO 0100-NEXT-EVENT. 520790 520800 0100-NEXT-EVENT. 520810 IF W-SERVER-ACTIVE = W-TRUE 520820 GO TO 0100-EVENT-LOOP. 520830 520840 0100-EXIT. 520850 EXIT. 521000 521020****************************************************************** 521040 0110-COMS-RECEIVE-MESSAGE. 521060* RECEIVES AND ROUTES A MESSAGE FROM COMS. 521080 521100 MOVE SPACE TO FCM-HTTP-TXN-HEADER. 021101PK 521120 RECEIVE CDI-COMS MESSAGE INTO FCM-COMS-MSG NO DATA 020109PK 521140 MOVE "Spurrious COMS DCI event (0110)" TO WM-TEXT 521160 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 521180 GO TO 0110-EXIT. 010920PK 521200 521220* -- AT THIS POINT WE HAVE A MESSAGE FROM COMS -- 010920PK 521240 521260 PERFORM 0120-COMS-DETERMINE-MSG-SOURCE THRU 0120-EXIT. 010930PK 521270 MOVE CDI-CONVERSATION TO CDO-CONVERSATION. 020205PK 521280 521300 IF WTL-LOGGING = W-TRUE 521360 PERFORM 9802-LOG-CDI-TRAFFIC THRU 9802-EXIT. 521362 011015PK 521364 MOVE ZERO TO CDO-AGENDA. 011015PK 521366 MOVE 1 TO CDO-DEST-COUNT. 011015PK 521368 MOVE ZERO TO CDO-DESTINATION. 011015PK 521380 521400 IF CDI-STATUS = ZERO 521420 PERFORM 0150-COMS-ROUTE-MESSAGE THRU 0150-EXIT 010930PK 521440 ELSE 521460 PERFORM 0112-COMS-DECODE-STATUS THRU 0112-EXIT. 010930PK 521480 521500 0110-EXIT. 521520 EXIT. 522000 522020****************************************************************** 522040 0112-COMS-DECODE-STATUS. 010930PK 522060* PROCESSES A COMS INPUT MESSAGE WITH CDI-STATUS NOT = ZERO. 522080 522180* -- RESUBMISSION OF ABORTED MESSAGE -- 020120PK 522200 IF CDI-STATUS = 93 522240 MOVE CDI-STATUS TO WM-STATUS-VALUE 522260 MOVE "Message caused abort (0112)" TO WM-STATUS-TEXT 522270 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 522280 MOVE FCM-COMS-MSG TO WM-TEXT 020109PK 522300 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 522360 522380* -- MESSAGE FROM SYNCHRONIZED RECOVERY -- 020120PK 522400 ELSE IF CDI-STATUS = 92 522420 PERFORM 0150-COMS-ROUTE-MESSAGE THRU 0150-EXIT 010930PK 522440 522460* -- MESSAGE TOO LARGE, TRUNCATED -- 020120PK 522480 ELSE IF CDI-STATUS = 89 522490 MOVE CDI-STATUS TO WM-STATUS-VALUE 522500 MOVE "Truncated message ignored (0112)" TO WM-STATUS-TEXT 522505 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 522510 MOVE FCM-COMS-MSG TO WM-TEXT 020109PK 522520 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 522525 522530* -- COMS TP TERMINATION -- 020120PK 522535 ELSE IF CDI-STATUS = 99 522540 MOVE W-FALSE TO W-SERVER-ACTIVE 522560 522580* -- SOMETHING ELSE -- 020120PK 522600 ELSE 522640 MOVE CDI-STATUS TO WM-STATUS-VALUE 522660 MOVE "Unknown receive status key (0112)" TO WM-STATUS-TEXT 522670 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 522680 MOVE FCM-COMS-MSG TO WM-TEXT 020109PK 522700 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT. 522720 522740 0112-EXIT. 522760 EXIT. 523000 523020****************************************************************** 523030 0120-COMS-DETERMINE-MSG-SOURCE. 010930PK 523040* DETERMINES THE SOURCE OF A MESSAGE FROM COMS -- PROGRAM OR 523050* STATION. IF FROM A STATION, DETERMINES THE NAME AND USER. 523060 523070 IF CDI-PROGRAM = ZERO 523080 IF CDI-STATION = ZERO 523090 MOVE "" TO CDI-STATION-NAME, CDI-USER-NAME 523100 SET WST-SX TO ZERO 523110 ELSE 523120 PERFORM 0124-COMS-DETERMINE-STA-SOURCE THRU 0124-EXIT 010930PK 523130 ELSE 523140 PERFORM 0122-COMS-DETERMINE-PGM-SOURCE THRU 0122-EXIT. 010930PK 523150 523160 0120-EXIT. 523170 EXIT. 523200 523210****************************************************************** 523220 0122-COMS-DETERMINE-PGM-SOURCE. 010930PK 523230* DETERMINES THE COMS PROGRAM FROM WHICH THE MESSAGE CAME. 523240 523242*--> IF CDI-PROGRAM = W-TCPIP-INTERFACE-DESIG 021101PK 523244* MOVE W-TCPIP-INTERFACE-NAME TO CDI-STATION-NAME 021101PK 523246* MOVE "*WEBUSER" TO CDI-USER-NAME 021118PK 523248*--> ELSE 021101PK 523250 MOVE "" TO CDI-STATION-NAME 020205PK 523260 MOVE "" TO CDI-USER-NAME. 020205PK 523270 523280 0122-EXIT. 523290 EXIT. 523400 523410****************************************************************** 523420 0124-COMS-DETERMINE-STA-SOURCE. 010930PK 523430* DETERMINES THE COMS STATION FROM WHICH THE MESSAGE CAME. IF 523440* NECESSARY, ADDS A NEW STATION TO THE WST TABLE. 523450 523455 MOVE CDI-STATION TO W-STA-DESIG. 523460 CALL "STATION_TABLE_SEARCH IN DCILIBRARY" USING 523470 WST-STATION-HASH, W-STA-DESIG 523480 GIVING W-RESULT. 523490 IF W-RESULT > ZERO 523500 SET WST-SX TO W-RESULT 523510 ELSE 523520 PERFORM 0126-COMS-ADD-STA-SOURCE THRU 0126-EXIT. 010930PK 523550 523560 IF WST-USER-DESIG (WST-SX) NOT = CDI-USER 523580 PERFORM 0128-COMS-DETERMINE-USER THRU 0128-EXIT. 010930PK 523600 523620 MOVE WST-STATION-NAME (WST-SX) TO CDI-STATION-NAME. 523640 MOVE WST-USER-NAME (WST-SX) TO CDI-USER-NAME. 523710 523720 0124-EXIT. 523730 EXIT. 523740 523750****************************************************************** 523760 0126-COMS-ADD-STA-SOURCE. 010930PK 523770* ADDS A NEW STATION TO THE WST TABLE. ON OVERFLOW, SIMPLY 523780* OVERWRITES THE LAST ENTRY IN THE TABLE. EXITS WITH THE NEW 523790* ENTRY AT WST-SX SET UP. 523800 523805 MOVE CDI-STATION TO W-STA-DESIG. 523810 CALL "STATION_TABLE_ADD IN DCILIBRARY" USING 523820 WST-STATION-HASH, W-STA-DESIG 523830 GIVING W-RESULT. 523840 IF W-RESULT > WST-MAX-STATION 523850 SET WST-SX TO WST-MAX-STATION 523860 MOVE W-RESULT TO WM-STATUS-VALUE 523870 MOVE "WST station table overflow (0126)" TO WM-STATUS-TEXT 523890 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 523900 ELSE 523910 SET WST-SX TO W-RESULT. 523920 523930 MOVE CDI-STATION TO W-STA-DESIG, WST-STATION-DESIG (WST-SX). 523940 CALL "GET_NAME_USING_DESIGNATOR IN DCILIBRARY" USING 523950 W-STA-DESIG, WMA-MISC-AREA GIVING W-COMS-RESULT. 020109PK 523970 IF W-COMS-RESULT = ZERO 523980 MOVE WMA-MISC-AREA TO WST-STATION-NAME (WST-SX) 020109PK 523990 ELSE 524000 MOVE "" TO WST-STATION-NAME (WST-SX) 524010 MOVE W-COMS-RESULT TO WM-STATUS-VALUE 524020 MOVE "Invalid Station Desig (0126)" TO WM-STATUS-TEXT 524040 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT. 524050 524060 MOVE ZERO TO WST-USER-DESIG (WST-SX). 524070 MOVE "" TO WST-USER-NAME (WST-SX). 524080 524090 0126-EXIT. 524100 EXIT. 524120 524140****************************************************************** 524160 0128-COMS-DETERMINE-USER. 010930PK 524180* TRANSLATES THE USER DESIGNATOR IN CDI-COMS TO A NAME AND 524200* STORES IT IN THE CURRENT WST TABLE ENTRY. 524220 524240 MOVE CDI-USER TO WST-USER-DESIG (WST-SX). 524260 IF CDI-USER = ZERO 524280 MOVE "" TO WST-USER-NAME (WST-SX) 524300 ELSE 524320 MOVE CDI-USER TO W-USER-DESIG 524340 CALL "GET_NAME_USING_DESIGNATOR IN DCILIBRARY" USING 524360 W-USER-DESIG, WMA-MISC-AREA GIVING W-COMS-RESULT 020109PK 524400 IF W-COMS-RESULT = ZERO 524420 MOVE WMA-MISC-AREA TO WST-USER-NAME (WST-SX) 020109PK 524440 ELSE 524460 MOVE "" TO WST-USER-NAME (WST-SX) 524480 MOVE W-COMS-RESULT TO WM-STATUS-VALUE 524500 MOVE "Invalid User Desig (0128)" TO WM-STATUS-TEXT 524520 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT. 524540 524560 MOVE WST-USER-NAME (WST-SX) TO CDI-USER-NAME. 524580 524600 0128-EXIT. 524620 EXIT. 525000 525010****************************************************************** 525020 0130-COMS-DECODE-FCN-STATUS. 010930PK 525030* PROCESSES SPECIAL COMS MESSAGES, INDICATED BY NEGATIVE 525040* CDI-FUNCTION-STATUS VALUES. 525050 525060* -- GOOD RESULT MESSAGE -- 020120PK 525070 IF CDI-FUNCTION-STATUS = -12 525080 MOVE CDI-FUNCTION-STATUS TO WM-STATUS-VALUE 525090 MOVE "Good result received (0130)" TO WM-STATUS-TEXT 525110 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 525120 525130* -- BREAK -- 020120PK 525140 ELSE IF CDI-FUNCTION-STATUS = -13 525150 MOVE CDI-FUNCTION-STATUS TO WM-STATUS-VALUE 525160 MOVE "Break received (0130)" TO WM-STATUS-TEXT 525180 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 525190 525200* -- BAD DELIVERY -- 020120PK 525210 ELSE IF CDI-FUNCTION-STATUS = -14 525220 MOVE CDI-FUNCTION-STATUS TO WM-STATUS-VALUE 525230 MOVE "Bad-Delivery received (0130)" TO WM-STATUS-TEXT 525250 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 525260 525270* -- MESSAGE REJECTED -- 020120PK 525280 ELSE IF CDI-FUNCTION-STATUS = -15 525290 MOVE CDI-FUNCTION-STATUS TO WM-STATUS-VALUE 525300 MOVE "Message-Rejected received (0130)" TO WM-STATUS-TEXT 525320 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 525330 525340* -- INVALID TRANCODE -- 020120PK 525350 ELSE IF CDI-FUNCTION-STATUS = -4 525360 MOVE "Invalid TRANCODE (0130)" TO WM-TEXT 525362 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 525364 MOVE FCM-COMS-MSG TO WM-TEXT 020109PK 525370 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 525380 525390* -- NO TRANCODE -- 020120PK 525400 ELSE IF CDI-FUNCTION-STATUS = -5 525410 MOVE "No TRANCODE in message (0130)" TO WM-TEXT 525412 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 525414 MOVE FCM-COMS-MSG TO WM-TEXT 020109PK 525420 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 525430 525440* -- TRANCODE SECURITY ERROR -- 020120PK 525450 ELSE IF CDI-FUNCTION-STATUS = -9 525460 MOVE "TRANCODE Security error (0130)" TO WM-TEXT 525462 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 525464 MOVE FCM-COMS-MSG TO WM-TEXT 020109PK 525470 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 525480 525490* -- PROCESSING ITEM LIST ERROR -- 020120PK 525500 ELSE IF CDI-FUNCTION-STATUS = -10 525510 MOVE "Processing-Item list error (0130)" TO WM-TEXT 525512 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 525514 MOVE FCM-COMS-MSG TO WM-TEXT 020109PK 525520 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 525530 525540* -- OPEN-WINDOW NOTIFICATION -- 020120PK 525550 ELSE IF CDI-FUNCTION-STATUS = -16 525560 PERFORM 0310-COMS-OPEN-WINDOW THRU 0310-EXIT 010930PK 525570 525580* -- ON-WINDOW NOTIFICATION -- 020120PK 525590 ELSE IF CDI-FUNCTION-STATUS = -17 525600 PERFORM 0320-COMS-ON-WINDOW THRU 0320-EXIT 010930PK 525610 525620* -- CLOSE-WINDOW NOTIFICATION -- 020120PK 525630 ELSE IF CDI-FUNCTION-STATUS = -50 525640 PERFORM 0330-COMS-CLOSE-WINDOW THRU 0330-EXIT 010930PK 525650 525660* -- SOMETHING ELSE -- 020120PK 525670 ELSE 525680 MOVE CDI-FUNCTION-STATUS TO WM-STATUS-VALUE 525690 MOVE SPACE TO WM-STATUS-TEXT 525700 STRING "Unknown FCN-STATUS (0130): ", CDI-STATION-NAME 525710 DELIMITED BY SIZE INTO WM-STATUS-TEXT 525715 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 525720 MOVE FCM-COMS-MSG TO WM-TEXT 020109PK 525730 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT. 525740 525750 0130-EXIT. 525760 EXIT. 526000 526020****************************************************************** 526040 0150-COMS-ROUTE-MESSAGE. 010930PK 526060* PARSES AN INCOMING TEXT MESSAGE FROM COMS TO DETERMINE THE 526080* INTERNAL COMMAND. 526100 526120 IF W-DATA-BASE-OPEN NOT = W-TRUE 526140 MOVE ">>> Database Failed Open <<< (0150)" TO WM-TEXT 526160 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 526180 CHANGE ATTRIBUTE STATUS OF MYSELF TO TERMINATED 526200 GO TO 0150-EXIT. 526220 526240 IF CDI-FUNCTION-STATUS < ZERO 526260 PERFORM 0130-COMS-DECODE-FCN-STATUS THRU 0130-EXIT 010930PK 526280 GO TO 0150-EXIT. 526300 011015PK 526320 IF CDI-PROGRAM = ZERO 526340 PERFORM 0160-COMS-ROUTE-USER-MSG THRU 0160-EXIT 526360 ELSE 526380 PERFORM 0180-COMS-ROUTE-PROGRAM-MSG THRU 0180-EXIT. 526620 011015PK 526640 0150-EXIT. 011015PK 526660 EXIT. 011015PK 527000 527020****************************************************************** 527040 0160-COMS-ROUTE-USER-MSG. 527060* ANALYZES AND ROUTES MESSAGES RECEIVED FROM NON-PROGRAM 527080* SOURCES. IF THE HTTP TRANCODE IS VALID, FORMATS THE MESSAGE 527100* FOR SUBMISSION TO THE WEBPCM TCPIP INTERFACE. 021101PK 527120 527140 IF FCM-HTTP-TRANCODE = WHM-HTTP-TRANCODE 020109PK 527160 PERFORM 1000-HTTP-ROUTE-INPUT-MSG THRU 1000-EXIT 527180 GO TO 0160-EXIT. 527200 527220 MOVE "COMS user message received (0160)" TO WM-TEXT. 527240 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT. 527260 MOVE FCM-COMS-MSG TO WM-TEXT. 020109PK 527280 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT. 527285 021101PK 527290* --- Any processing for non-WEBPCM messages can be driven 021101PK 527295* from here --- 021101PK 527300 527320 0160-EXIT. 527340 EXIT. 527500 527520****************************************************************** 527540 0180-COMS-ROUTE-PROGRAM-MSG. 527560* ANALYZES AND ROUTES MESSAGES RECEIVED DIRECTLY FROM OTHER 527580* COMS PROGRAMS. IF THE MESSAGE IS FROM THE WEBPCM TCPIP 021101PK 527600* INTERFACE PROGRAM, IT IS IGNORED. 020205PK 527620 527640*--> IF FCM-WEBPCM-TRANCODE = WNM-FROM-WEBPCM-TRANCODE 021101PK 527660* -- A MESSAGE FROM WEBPCM/TCPIP/INTERFACE -- 021101PK 527760* GO TO 0180-EXIT 021101PK 527780*--> ELSE 021101PK 527800 MOVE "COMS unknown program message (0180)" TO WM-TEXT 527820 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 527840 MOVE FCM-COMS-MSG TO WM-TEXT 020109PK 527860 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 527880 GO TO 0180-EXIT. 527900 527920 0180-EXIT. 527940 EXIT. 528000 528020****************************************************************** 528040 0200-SECTION SECTION. 528060****************************************************************** 528080 0200-COMS-SEND-MESSAGE. 010930PK 528100* SENDS A MESSAGE FROM FCM-COMS-MSG USING CDO-COMS. ASSUMES 020109PK 528120* LENGTH, DESTINATION, ETC. ARE ALREADY SET UP IN THE HEADER. 528140 528160 SEND CDO-COMS FROM FCM-COMS-MSG WITH EMI BEFORE 0 LINES. 020109PK 528180 528200 IF WTL-LOGGING = W-TRUE 528220 PERFORM 9804-LOG-CDO-TRAFFIC THRU 9804-EXIT. 528240 528260 IF CDO-STATUS NOT = ZERO 528280 MOVE CDO-STATUS TO WM-STATUS-VALUE 528300 MOVE SPACE TO WM-STATUS-TEXT 528320 STRING "Send-COMS status (0200): ", CDO-STATION-NAME 020205PK 528340 DELIMITED BY SIZE INTO WM-STATUS-TEXT 528360 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT. 528380 528400 0200-EXIT. 528420 EXIT. 530000/ 530020****************************************************************** 530040 0300-SECTION SECTION. 531020****************************************************************** 531040 0310-COMS-OPEN-WINDOW. 010930PK 531060* HANDLES AN OPEN-WINDOW NOTIFICATION FROM COMS, INITIALIZING 531080* THE SESSION STATE. 021101PK 531120 531140 IF WTL-LOGGING = W-TRUE 531160 MOVE "OPEN WINDOW" TO TLF-TYPE 531180 MOVE SPACE TO TLF-COMS-HEADER 531185 MOVE CDI-STATION-NAME TO TLF-COMS-STATION-NAME 531190 MOVE CDI-USER-NAME TO TLF-COMS-USER-NAME 531200 MOVE WTL-HEADER-SIZE TO TLF-REC-SIZE 531220 MOVE WTL-FORMAT-DEFAULT TO TLF-FORMAT 531240 PERFORM 9800-WRITE-TRAFFIC-LOG THRU 9800-EXIT. 531260 531280 MOVE SPACE TO WM-TEXT. 531300 STRING "Open Window: " DELIMITED BY SIZE, 531320 CDI-STATION-NAME DELIMITED BY SPACE, 531340 " for " DELIMITED BY SIZE, 531360 CDI-USER-NAME DELIMITED BY SPACE INTO WM-TEXT. 531380 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT. 531540 531560 0310-EXIT. 531580 EXIT. 532000 532020****************************************************************** 532040 0320-COMS-ON-WINDOW. 010930PK 532060* HANDLES AN ON-WINDOW NOTIFICATION FROM COMS. 532080 532100 IF WTL-LOGGING = W-TRUE 532120 MOVE "ON WINDOW" TO TLF-TYPE 532140 MOVE SPACE TO TLF-COMS-HEADER 532145 MOVE CDI-STATION-NAME TO TLF-COMS-STATION-NAME 532150 MOVE CDI-USER-NAME TO TLF-COMS-USER-NAME 532160 MOVE WTL-HEADER-SIZE TO TLF-REC-SIZE 532180 MOVE WTL-FORMAT-DEFAULT TO TLF-FORMAT 532200 PERFORM 9800-WRITE-TRAFFIC-LOG THRU 9800-EXIT. 532220 532240 MOVE SPACE TO WM-TEXT. 532260 STRING "On Window: " DELIMITED BY SIZE, 532280 CDI-STATION-NAME DELIMITED BY SPACE, 532300 " for " DELIMITED BY SIZE, 532320 CDI-USER-NAME DELIMITED BY SPACE INTO WM-TEXT. 532340 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT. 532500 532520 0320-EXIT. 532540 EXIT. 533000 533020****************************************************************** 533040 0330-COMS-CLOSE-WINDOW. 010930PK 533060* HANDLES CLEANUP CHORES FOR A CLOSE-WINDOW MESSAGE. 533080 533100 MOVE SPACE TO WM-TEXT. 533120 STRING "Close Window: " DELIMITED BY SIZE, 533140 CDI-STATION-NAME DELIMITED BY SPACE, 533160 " for " DELIMITED BY SIZE, 533180 CDI-USER-NAME DELIMITED BY SPACE INTO WM-TEXT. 533200 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT. 533400 533420 IF WTL-LOGGING = W-TRUE 533440 MOVE "CLOSE WINDOW" TO TLF-TYPE 533460 MOVE SPACE TO TLF-COMS-HEADER 533465 MOVE CDI-STATION-NAME TO TLF-COMS-STATION-NAME 533470 MOVE CDI-USER-NAME TO TLF-COMS-USER-NAME 533480 MOVE WTL-HEADER-SIZE TO TLF-REC-SIZE 533500 MOVE WTL-FORMAT-DEFAULT TO TLF-FORMAT 533520 PERFORM 9800-WRITE-TRAFFIC-LOG THRU 9800-EXIT. 533540 533560 0330-EXIT. 533580 EXIT. 580000 580020****************************************************************** 580040 0800-SECTION SECTION. 580060****************************************************************** 580080 0800-TIMEOUT-EVENT. 010921PK 580100* HANDLES PROCESSING FOR THE CENTRAL TIMEOUT EVENT. 010921PK 580120 580180 IF WDA-SYS-TIMESTAMP < WDA-EOD-TIMESTAMP 011206PK 580200 PERFORM 0820-TIMEOUT-TICKLER-EVENT THRU 0820-EXIT 580500 ELSE 580520 PERFORM 0850-CHECK-MIDNIGHT THRU 0850-EXIT. 580940 010921PK 580960 0800-EXIT. 010921PK 580980 EXIT. 010921PK 582000 582020****************************************************************** 582040 0820-TIMEOUT-TICKLER-EVENT. 010921PK 582060* HANDLES THE PERIODIC TICKLER EVENT. 010921PK 582100 582200* --- Any periodic processing can be implemented here. This 021101PK 582300* routine will be called every W-TICKLER-PERIOD seconds ---021101PK 582400 582420 0820-EXIT. 582440 EXIT. 585000 585010****************************************************************** 585020 0850-SECTION SECTION. 585030****************************************************************** 585040 0850-CHECK-MIDNIGHT. 585060* HANDLES END-OF-DAY CHORES AT MIDNIGHT. 585080 585100 PERFORM Q110-READ-SYSTEM-DATE THRU Q110-EXIT. 585120 MOVE WDA-EOD-TIMESTAMP TO WDA-BOD-TIMESTAMP. 011206PK 585140 COMPUTE WDA-EOD-TIMESTAMP = 011206PK 585160 WDA-BOD-TIMESTAMP + WDA-SEC-PER-DAY. 011206PK 585260 585280 IF WTL-LOGGING = W-TRUE 585300 MOVE W-TRUE TO WTL-CLOSE-FINAL 585320 PERFORM 9829-CLOSE-TRAFFIC-LOG THRU 9829-EXIT 585340 PERFORM 9828-OPEN-TRAFFIC-LOG THRU 9828-EXIT. 585360 585380 MOVE "Good Morning!" TO WM-TEXT. 585400 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT. 585420 585440 0850-EXIT. 585460 EXIT. 600000/ 600010***************************************************************** 020109PK 600020 1000-SECTION SECTION. 020109PK 600030***************************************************************** 020109PK 600040 1000-HTTP-ROUTE-INPUT-MSG. 020109PK 600050* ANALYZES AND ROUTES INPUT MESSAGES FROM THE WEBPCM. 020109PK 600060 020109PK 600070 MOVE CDI-STATION TO CDO-DESTINATION. 020109PK 600090 MOVE FCM-COMS-MSG TO FHM-HTTP-MSG. 021101PK 600110 020109PK 600120 MOVE W-FALSE TO WHM-SESSION-VALID, WHM-COOKIE-VALID. 020109PK 600125 MOVE W-FALSE TO WHM-CHUNKED-OUTPUT. 020120PK 600130 MOVE LOW-VALUE TO WHM-IDENTIFICATION. 020109PK 600135 MOVE W-TRUE TO WHM-COOKIE-NEEDED. 020120PK 600140 MOVE LOW-VALUE TO WHM-COOKIE-LAYOUT. 020109PK 600150 020109PK 600160* -- GET SELECTED HTTP HEADERS, CHECK FOR LEGAL METHOD & PATH. 020109PK 600170 PERFORM 1010-HTTP-GET-MSG-HEADERS THRU 1010-EXIT. 020109PK 600180 IF NOT (WHM-H-METHOD = "GET" OR "POST") 020109PK 600190 MOVE 501 TO WHM-STATUS-CODE 020109PK 600200 MOVE 1 TO WHM-STATUS-SUBCODE 020109PK 600210 MOVE "HTTP method is not GET or POST" TO WHM-STATUS-TEXT 021101PK 600220 PERFORM 1090-HTTP-SET-STATUS-CODE THRU 1090-EXIT 020109PK 600230 PERFORM 1100-HTTP-SEND-MESSAGE THRU 1100-EXIT 020109PK 600240 GO TO 1000-FINISH. 020109PK 600250 020109PK 600260 IF WHM-H-APP-VDIR NOT = WHM-HTTP-WEBPCM-VDIR 021101PK 600270 MOVE 404 TO WHM-STATUS-CODE 020109PK 600280 MOVE "Path Virtual Directory mismatch" TO WHM-STATUS-TEXT 021101PK 600290 PERFORM 1090-HTTP-SET-STATUS-CODE THRU 1090-EXIT 020109PK 600300 PERFORM 1100-HTTP-SEND-MESSAGE THRU 1100-EXIT 020109PK 600310 GO TO 1000-FINISH. 020109PK 600320 020109PK 600330* -- ATTEMPT TO VALIDATE THE USER, STATION, COOKIE, & SESSION. 020109PK 600340 PERFORM 1030-HTTP-VALIDATE-SESSION THRU 1030-EXIT. 020109PK 600342 IF WHM-H-APP-FUNCTION = "/ECHO" 020214PK 600344 PERFORM 1200-USER-SEND-ECHO THRU 1200-EXIT 020214PK 600346 GO TO 1000-FINISH. 020214PK 600348 020214PK 600350 IF WHM-SESSION-VALID NOT = W-TRUE 020109PK 600355 PERFORM 1048-HTTP-SET-COOKIE THRU 1048-EXIT 020109PK 600360 PERFORM 1100-HTTP-SEND-MESSAGE THRU 1100-EXIT 020109PK 600370 GO TO 1000-FINISH. 020109PK 600380 020109PK 600390 MOVE WHM-H-APP-TRANCODE TO WHM-SH1-TITLE. 020120PK 600392 MOVE LOW-VALUE TO WHM-ID-PASSWORD, WHM-H-REMOTE-USER. 020109PK 600400 020109PK 600410* -- ROUTE THE REQUEST BASED ON SECOND NODE OF APP PATH -- 020109PK 600420 IF WHM-H-APP-FUNCTION = "/CAL" 021101PK 600430 PERFORM 1600-USER-CAL-SHOW THRU 1600-EXIT 021101PK 600700 ELSE IF WHM-H-APP-FUNCTION = SPACE OR "/HOME" OR "/" 020120PK 600710 PERFORM 1500-USER-SEND-HOME THRU 1500-EXIT 020120PK 600720 ELSE IF WHM-H-APP-FUNCTION = "/LOGOUT" 021101PK 600730 PERFORM 1530-USER-LOGOUT THRU 1530-EXIT 021101PK 600800 ELSE 600810 MOVE 404 TO WHM-STATUS-CODE 020109PK 600820 MOVE SPACE TO WHM-STATUS-TEXT 020120PK 600830 STRING "Invalid Trancode: """ DELIMITED BY SIZE, 021101PK 600840 WHM-H-APP-FUNCTION DELIMITED BY SPACE, 020120PK 600850 """" DELIMITED BY SIZE INTO WHM-STATUS-TEXT 020120PK 600860 PERFORM 1090-HTTP-SET-STATUS-CODE THRU 1090-EXIT 020120PK 600870 PERFORM 1048-HTTP-SET-COOKIE THRU 1048-EXIT 020120PK 600880 PERFORM 1100-HTTP-SEND-MESSAGE THRU 1100-EXIT. 020120PK 600900 020109PK 600910 1000-FINISH. 020109PK 600920 MOVE LOW-VALUE TO WHM-ID-PASSWORD, WHM-H-REMOTE-USER. 020109PK 600930 020109PK 600940 1000-EXIT. 020109PK 600950 EXIT. 020109PK 601000 020109PK 601010******************************************************************020109PK 601020 1010-HTTP-GET-MSG-HEADERS. 020109PK 601030* EXTRACTS SELECTED MESSAGE HEADERS FROM THE HTTP MESSAGE AND 020109PK 601040* LOADS THE WHM-HEADER STRUCTURE. 020109PK 601050 020109PK 601060 MOVE "$REMOTE-ADDRESS" TO W-NAME. 020109PK 601070 CALL "GET_HEADER IN WEBAPPSUPPORT" USING 020109PK 601080 FHM-HTTP-MSG, W-NAME, W-VALUE GIVING W-RESULT. 020109PK 601082 IF W-RESULT = 1 020214PK 601084 MOVE W-VALUE TO WHM-H-REMOTE-ADDRESS 020214PK 601086 ELSE 020214PK 601088 MOVE SPACE TO WHM-H-REMOTE-ADDRESS. 020214PK 601100 020109PK 601110 MOVE "$REMOTE-HOST" TO W-NAME. 020109PK 601120 CALL "GET_HEADER IN WEBAPPSUPPORT" USING 020109PK 601130 FHM-HTTP-MSG, W-NAME, W-VALUE GIVING W-RESULT. 020109PK 601132 IF W-RESULT = 1 020214PK 601134 MOVE W-VALUE TO WHM-H-REMOTE-HOST 020214PK 601136 ELSE 020214PK 601138 MOVE SPACE TO WHM-H-REMOTE-HOST. 020214PK 601150 020109PK 601160 MOVE "$REMOTE-USER" TO W-NAME. 020109PK 601170 CALL "GET_HEADER IN WEBAPPSUPPORT" USING 020109PK 601180 FHM-HTTP-MSG, W-NAME, W-VALUE GIVING W-RESULT. 020109PK 601190 IF W-RESULT = 1 020109PK 601200 MOVE W-VALUE TO WHM-H-REMOTE-USER 020109PK 601210 ELSE 020109PK 601220 MOVE SPACE TO WHM-H-REMOTE-USER. 020214PK 601230 020109PK 601240 MOVE "$METHOD" TO W-NAME. 020109PK 601250 CALL "GET_HEADER IN WEBAPPSUPPORT" USING 020109PK 601260 FHM-HTTP-MSG, W-NAME, W-VALUE GIVING W-RESULT. 020109PK 601262 IF W-RESULT = 1 020214PK 601264 MOVE W-VALUE TO WHM-H-METHOD 020214PK 601266 ELSE 020214PK 601268 MOVE SPACE TO WHM-H-METHOD. 020214PK 601280 020109PK 601290 MOVE "$APPLICATION-PATH" TO W-NAME. 020109PK 601300 CALL "GET_HEADER IN WEBAPPSUPPORT" USING 020109PK 601310 FHM-HTTP-MSG, W-NAME, W-VALUE GIVING W-RESULT. 020109PK 601312 IF W-RESULT = 1 020214PK 601314 MOVE W-VALUE TO WHM-H-APP-PATH 020214PK 601316 ELSE 020214PK 601318 MOVE SPACE TO WHM-H-APP-PATH. 020214PK 601330 020109PK 601340 COMPUTE W-X = OFFSET (WHM-HTTP-HEADER) + 1. 020109PK 601342 COMPUTE W-L = FUNCTION FORMATTED-SIZE (WHM-HTTP-HEADER). 020109PK 601346 CALL "VSNTRANS_TEXT IN CENTRALSUPPORT" USING 021101PK 601348 WCS-USE-HOST-CCS, WHM-HTTP-MSG-CTL, W-X, 021118PK 601350 WHM-HTTP-MSG-CTL, W-X, W-L, WCS-XLATE-LOWTOUPCASE 021118PK 601352 GIVING W-RESULT. 021101PK 601354 IF W-RESULT NOT < 1000 021101PK 601356 MOVE W-RESULT TO WM-STATUS-VALUE 021101PK 601358 MOVE "Error calling VSNTRANS_TEXT (1010)" TO WM-STATUS-TEXT021101PK 601360 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT 021101PK 601362 CHANGE ATTRIBUTE STATUS OF MYSELF TO TERMINATED. 021101PK 601380 020109PK 601390 IF WHM-H-REMOTE-HOST = SPACE 020109PK 601400 MOVE WHM-H-REMOTE-ADDRESS TO WHM-ID-HOST-NAME 020120PK 601410 ELSE 020109PK 601420 UNSTRING WHM-H-REMOTE-HOST DELIMITED BY "." 020109PK 601430 INTO WHM-ID-HOST-NAME. 020120PK 601440 020109PK 601470 MOVE SPACE TO WHM-ID-USER-ID, WHM-ID-PASSWORD. 020214PK 601480 IF WHM-H-REMOTE-USER NOT = SPACE 020214PK 601490 UNSTRING WHM-H-REMOTE-USER DELIMITED BY ":" 020109PK 601500 INTO WHM-ID-USER-ID, WHM-ID-PASSWORD. 020109PK 601510 020109PK 601520 PERFORM 1020-HTTP-PARSE-IP-ADDRESS THRU 1020-EXIT. 020109PK 601530 020109PK 601540 1010-EXIT. 020109PK 601550 EXIT. 020109PK 602000 020109PK 602010******************************************************************020109PK 602020 1020-HTTP-PARSE-IP-ADDRESS. 020109PK 602030* PARSES THE IP ADDRESS IN DOTTED-DECIMAL NOTATION FROM 020109PK 602040* WHM-H-REMOTE-ADDRESS TO FIXED-DECIMAL INTO WEA-IP-ADDR AND 020109PK 602050* WHM-ID-IP-ADDRESS. 021101PK 602060 020109PK 602070 MOVE ZERO TO WEA-IP-ADDR. 020109PK 602080 SET WEA-IPX, WHM-H-RAX TO 1. 020109PK 602090 020109PK 602100 1020-CHAR-LOOP. 020109PK 602110 IF WHM-H-RAC (WHM-H-RAX) IS NUMERIC 020109PK 602120 COMPUTE WEA-IP-ADDR-BYTE (WEA-IPX) = 020109PK 602130 WEA-IP-ADDR-BYTE (WEA-IPX) * 10 + 020109PK 602140 WHM-H-RAN (WHM-H-RAX) 020109PK 602150 ELSE IF WHM-H-RAC (WHM-H-RAX) = "." 020109PK 602160 IF WEA-IPX < 4 020109PK 602170 SET WEA-IPX UP BY 1 020109PK 602180 ELSE 020109PK 602190 GO TO 1020-FORMAT-FINAL-IP 021118PK 602200 ELSE 020109PK 602210 GO TO 1020-FORMAT-FINAL-IP. 021118PK 602220 020109PK 602230 IF WHM-H-RAX < WHM-REMOTE-ADDR-MAX 020109PK 602240 SET WHM-H-RAX UP BY 1 020109PK 602250 GO TO 1020-CHAR-LOOP. 020109PK 602260 020109PK 602270 1020-FORMAT-FINAL-IP. 021118PK 602280 MOVE WEA-IP-ADDR-BYTE (1) TO WHM-ID-IP-ADDR-1. 021101PK 602300 MOVE WEA-IP-ADDR-BYTE (2) TO WHM-ID-IP-ADDR-2. 021101PK 602320 MOVE WEA-IP-ADDR-BYTE (3) TO WHM-ID-IP-ADDR-3. 021101PK 602340 MOVE WEA-IP-ADDR-BYTE (4) TO WHM-ID-IP-ADDR-4. 021101PK 602360 020109PK 602370 1020-EXIT. 020109PK 602380 EXIT. 020109PK 603000 020109PK 603010******************************************************************020109PK 603020 1030-HTTP-VALIDATE-SESSION. 020109PK 603030* VALIDATES THE HTTP COOKIE, SESSION, USER, AND STATION FOR 020109PK 603040* THE CURRENT MESSAGE. IF VALID, RETURNS TRUE IN 020109PK 603050* WHM-SESSION-VALID. 020109PK 603060 020109PK 603070 PERFORM 1040-HTTP-VALIDATE-COOKIE THRU 1040-EXIT. 020109PK 603080 IF WHM-COOKIE-VALID = W-TRUE 020109PK 603090 IF WHM-C-STATE NOT < WHM-STATE-IDLE 020109PK 603100 GO TO 1030-AUTHENTICATED. 020109PK 603110 020109PK 603118* -- IF THEY'VE BEEN DENIED, WE DON'T EVEN THINK ABOUT IT -- 020109PK 603120 IF WHM-C-STATE = WHM-STATE-DENIED 020109PK 603130 MOVE 403 TO WHM-STATUS-CODE 020109PK 603140 MOVE "Logon denied - quit your browser to retry" TO 021101PK 603145 WHM-STATUS-TEXT 021101PK 603150 PERFORM 1090-HTTP-SET-STATUS-CODE THRU 1090-EXIT 020109PK 603160 GO TO 1030-EXIT. 020109PK 603290 020109PK 603300* -- NOW CHECK THE USER CREDENTIALS -- 021101PK 603320 IF WHM-ID-USER-ID = SPACE 020214PK 603322 MOVE ZERO TO WHM-C-STEP. 021101PK 603330 020109PK 603360 IF WHM-C-STEP = ZERO 020109PK 603370 GO TO 1030-REQUEST-CREDENTIALS. 020109PK 603380 020109PK 603390* --- AT THIS POINT YOU COULD VALIDATE THE USER'S USERCODE 603392* AND PASSWORD. THEY ARE IN WHM-ID-USER-ID AND 603394* WHM-ID-PASSWORD. WE AREN'T DOING THAT IN THIS CASE, SO 603396* WE'LL JUST CONTINUE ON. SOMETHING LIKE THE ORIGINAL 603398* CODE (WHICH USED A DMSII LOOKUP FROM A COPY MODULE) IS 603400* INCLUDED BELOW AS A COMMENT --- 603402 603404*--> PERFORM YS72-XXX-USER-X-FIND THRU YS72-EXIT. 603410* IF DMSTATUS(DMERROR) 603420* GO TO 1030-REQUEST-CREDENTIALS. 603430* 603440* IF XXX-PASSWORD NOT = WHM-ID-PASSWORD 603450* GO TO 1030-REQUEST-CREDENTIALS. 603460* 603470* IF XXX-USER-STATUS NOT = WYUF-STATUS-ACTIVE 603480* MOVE "You are not in active status" TO 021101PK 603485* WHM-STATUS-TEXT 603490* GO TO 1030-DENY-ACCESS. 603500* 603510* IF NOT XXX-WEBPCM-AUTH 603520* MOVE "You are not authorized for web access" TO 021101PK 603525* WHM-STATUS-TEXT 021101PK 603530*--> GO TO 1030-DENY-ACCESS. 603540 020109PK 603550* -- THE USER AND STATION ARE OKAY -- START SESSION -- 020109PK 603570 PERFORM 1050-HTTP-START-SESSION THRU 1050-EXIT. 020109PK 603590 GO TO 1030-AUTHENTICATED. 020109PK 603600 020109PK 603610 1030-REQUEST-CREDENTIALS. 020109PK 603620 IF WHM-C-STEP < WHM-LOGON-RETRY-MAX 020109PK 603630 ADD 1 TO WHM-C-STEP 020109PK 603640 PERFORM 1032-HTTP-ISSUE-CHALLENGE THRU 1032-EXIT 020109PK 603660 GO TO 1030-EXIT 020109PK 603670 ELSE 020109PK 603680 MOVE "Too many logon attempts -- ACCESS IS DENIED" TO 603685 WHM-STATUS-TEXT. 603690 020109PK 603700 1030-DENY-ACCESS. 020109PK 603710 PERFORM 1052-HTTP-DENY-ACCESS THRU 1052-EXIT. 020109PK 603730 GO TO 1030-EXIT. 020109PK 603740 020109PK 603750 1030-AUTHENTICATED. 020109PK 603770 MOVE W-TRUE TO WHM-SESSION-VALID. 020109PK 603790 020109PK 603792 1030-EXIT. 020109PK 603794 EXIT. 020109PK 603800 020109PK 603810******************************************************************020109PK 603820 1032-HTTP-ISSUE-CHALLENGE. 020109PK 603830* ISSUES A WWW-Authenticate HEADER TO CHALLENGE THE USER AGENT 020109PK 603840* FOR CREDENTIALS. 020109PK 603850 020109PK 603860 MOVE "WEBPCM demo -- credentials are not checked" TO 021101PK 603870 WHM-AUTH-REALM. 021101PK 603890 MOVE "WWW-Authenticate" TO W-NAME. 020109PK 603900 MOVE WHM-AUTH-CHALLENGE TO W-VALUE. 020109PK 603910 CALL "SET_HEADER IN WEBAPPSUPPORT" USING 020109PK 603920 FHM-HTTP-MSG, W-NAME, W-VALUE GIVING W-RESULT. 020109PK 603930 MOVE 401 TO WHM-STATUS-CODE. 020109PK 603940 MOVE "Enter user name and password (not required for demo)" 603950 TO WHM-STATUS-TEXT. 603960 PERFORM 1090-HTTP-SET-STATUS-CODE THRU 1090-EXIT. 020109PK 603970 020109PK 603980 1032-EXIT. 020109PK 603990 EXIT. 020109PK 604000 020109PK 604010******************************************************************020109PK 604020 1040-HTTP-VALIDATE-COOKIE. 020109PK 604030* OBTAINS THE HTTP COOKIE HEADER FOR THIS PROGRAM (IF ANY) AND 020109PK 604040* VALIDATES THE CONTENTS. IF VALID, RETURNS TRUE IN 020109PK 604050* WHM-COOKIE-VALID. 020109PK 604060 020109PK 604070 PERFORM 1046-HTTP-GET-COOKIE THRU 1046-EXIT. 020109PK 604080 IF WCJ-INDEX = ZERO 020120PK 604090 GO TO 1040-NEW-COOKIE. 020109PK 604100 020109PK 604110 IF WHM-C-COOKIE-TAG NOT = WHM-COOKIE-TAG 020109PK 604120 MOVE "Invalid cookie tag" TO WHM-STATUS-TEXT 604130 GO TO 1040-NEW-COOKIE. 020109PK 604140 020109PK 604150 IF WHM-C-COOKIE-VERSION NOT = WHM-COOKIE-VERSION 020109PK 604160 MOVE "Unrecognized cookie version" TO WHM-STATUS-TEXT 604170 GO TO 1040-NEW-COOKIE. 020109PK 604240 020109PK 604250 IF WHM-C-IP-ADDRESS NOT = WHM-ID-IP-ADDRESS 020109PK 604260 MOVE "Cookie IP address does not match" TO WHM-STATUS-TEXT 021101PK 604270 GO TO 1040-NEW-COOKIE. 020109PK 604280 020109PK 604290 IF (WHM-C-EXPIRE-STAMP - WHM-SESSION-TIMEOUT) > 020109PK 604300 WDA-SYS-TIMESTAMP 020109PK 604310 MOVE "Inactive session timeout" TO WHM-STATUS-TEXT 021101PK 604320 GO TO 1040-NEW-COOKIE. 020109PK 604450 020109PK 604460 IF WHM-C-EXPIRE-STAMP < WDA-SYS-TIMESTAMP 020109PK 604470 MOVE "Cookie expired" TO WHM-STATUS-TEXT 021101PK 604480 MOVE WHM-STATE-LOGOFF TO WHM-C-STATE 020109PK 604490 MOVE ZERO TO WHM-C-STEP 020109PK 604500 GO TO 1040-EXIT. 020109PK 604510 020109PK 604520 MOVE W-TRUE TO WHM-COOKIE-VALID. 020109PK 604530 GO TO 1040-EXIT. 020109PK 604540 020109PK 604550 1040-NEW-COOKIE. 020109PK 604560 PERFORM 1047-HTTP-INITIALIZE-COOKIE THRU 1047-EXIT. 020109PK 604570 020109PK 604580 1040-EXIT. 020109PK 604590 EXIT. 020109PK 605000 020109PK 605010******************************************************************020109PK 605020 1046-HTTP-GET-COOKIE. 020109PK 605030* OBTAINS COOKIES FROM THE HTTP HEADER AND SEARCHES FOR OURS. 020109PK 605040* IF FOUND, MOVES INTO WHM-COOKIE-LAYOUT AND RETURNS 021101PK 605050* WCJ-INDEX AND WCJ-CX SET TO THE COOKIE ENTRY; IF NOT FOUND, 020120PK 605060* INITIALIZES THE COOKIE AREA AND RETURNS WCJ-INDEX=0. 020120PK 605070 020109PK 605080 MOVE LOW-VALUE TO WHM-COOKIE-LAYOUT. 020109PK 605085 MOVE ZERO TO WCJ-INDEX. 020120PK 605090 CALL "PARSE_COOKIES IN WEBAPPSUPPORT" USING 020109PK 605100 FHM-HTTP-MSG, WCJ-NAME-LEN, WCJ-COOKIE-LEN, 020120PK 605110 WCJ-PATH-LEN, WCJ-DOMAIN-LEN, WCJ-PORT-LEN, 020109PK 605120 WCJ-COOKIE-VERSION, WCJ-CONTENT-JAR, WCJ-ENTRIES 020120PK 605130 GIVING W-RESULT. 020109PK 605140 IF W-RESULT NOT = 1 020109PK 605150 MOVE "Cannot obtain cookie headers" TO WHM-STATUS-TEXT 021101PK 605160 GO TO 1046-EXIT. 020109PK 605170 020109PK 605180 IF WCJ-ENTRIES < 1 020120PK 605190 MOVE "No cookies available" TO WHM-STATUS-TEXT 021101PK 605200 GO TO 1046-EXIT. 020109PK 605210 020109PK 605220 IF WCJ-ENTRIES > WCJ-COOKIE-MAX 020120PK 605230 MOVE WCJ-COOKIE-MAX TO WCJ-ENTRIES. 020120PK 605240 020120PK 605250 SET WCJ-CX TO 1. 021118PK 605260 020109PK 605270 1046-FIND-COOKIE-LOOP. 020109PK 605280 IF WCJ-COOKIE-NAME (WCJ-CX) NOT = WHM-COOKIE-NAME 020109PK 605290 IF WCJ-CX < WCJ-ENTRIES 021118PK 605300 SET WCJ-CX UP BY 1 021118PK 605310 GO TO 1046-FIND-COOKIE-LOOP 020109PK 605320 ELSE 020109PK 605340 MOVE "Cookie header not found" TO WHM-STATUS-TEXT 021101PK 605350 GO TO 1046-EXIT. 020109PK 605360 020109PK 605370 SET WCJ-INDEX TO WCJ-CX. 020120PK 605380 MOVE WCJ-COOKIE-VALUE (WCJ-CX) TO WMA-MISC-AREA. 021101PK 605390 CALL "HTTP_UNESCAPE IN WEBAPPSUPPORT" USING 021101PK 605400 W-ZERO, W-ZERO, WMA-MISC-AREA, W-VALUE 021101PK 605410 GIVING W-RESULT. 021101PK 605420 MOVE W-VALUE TO WHM-COOKIE-LAYOUT. 021101PK 605440 020109PK 605450 1046-EXIT. 020109PK 605460 EXIT. 020109PK 605470 020109PK 605480******************************************************************020109PK 605490 1047-HTTP-INITIALIZE-COOKIE. 020109PK 605500* INITIALIZES THE COOKIE LAYOUT TO START A NEW SESSION LOGON. 020109PK 605510 020109PK 605530 MOVE LOW-VALUE TO WHM-COOKIE-LAYOUT. 020109PK 605540 MOVE WHM-STATE-LOGON TO WHM-C-STATE. 020109PK 605550 MOVE ZERO TO WHM-C-STEP. 020109PK 605560 020109PK 605570 1047-EXIT. 020109PK 605580 EXIT. 020109PK 605600 020109PK 605610******************************************************************020109PK 605620 1048-HTTP-SET-COOKIE. 020109PK 605630* FORMATS THE HTTP COOKIE HEADER VALUE AND SETS THE COOKIE 020109PK 605632* IN THE OUTPUT MESSAGE HEADER IF IT HASN'T BEEN ALREADY. 020120PK 605634 020120PK 605636 IF WHM-COOKIE-NEEDED = W-TRUE 020120PK 605638 MOVE W-FALSE TO WHM-COOKIE-NEEDED 020120PK 605640 ELSE 020120PK 605642 GO TO 1048-EXIT. 020120PK 605650 020109PK 605660 MOVE WHM-COOKIE-TAG TO WHM-C-COOKIE-TAG. 020109PK 605670 MOVE WHM-COOKIE-VERSION TO WHM-C-COOKIE-VERSION. 020109PK 605690 MOVE WHM-ID-IP-ADDRESS TO WHM-C-IP-ADDRESS. 020109PK 605700 COMPUTE WHM-C-EXPIRE-STAMP = 020109PK 605710 WDA-SYS-TIMESTAMP + WHM-SESSION-TIMEOUT. 020109PK 605730 020109PK 605740 MOVE WHM-COOKIE-LAYOUT TO W-VALUE. 021101PK 605750 CALL "HTTP_ESCAPE IN WEBAPPSUPPORT" USING 021101PK 605760 W-ZERO, W-ZERO, W-VALUE, WMA-MISC-AREA 021101PK 605770 GIVING W-RESULT. 021101PK 605780 020109PK 605790 MOVE WHM-COOKIE-NAME TO W-NAME. 020109PK 605800 CALL "SET_COOKIE IN WEBAPPSUPPORT" USING 020109PK 605810 FHM-HTTP-MSG, W-NAME, WMA-MISC-AREA, 021101PK 605820 W-NULL, W-NULL, W-NULL, W-FALSE, GIVING W-RESULT. 020109PK 605830 IF W-RESULT NOT = 1 020109PK 605840 MOVE W-RESULT TO WM-STATUS-VALUE 020109PK 605850 MOVE "SET_COOKIE failed (1048)" TO WM-STATUS-TEXT 020109PK 605860 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT. 020109PK 605870 020109PK 605880 1048-EXIT. 020109PK 605890 EXIT. 020109PK 606000 020109PK 606010******************************************************************020109PK 606020 1050-HTTP-START-SESSION. 020109PK 606030* SETS UP THE SESSION STATE AND COOKIE FOR A NEW SESSION. 020109PK 606040* ASSUMES THE STATION-DS AND NYS-USER RECORDS FOR THIS USER 020109PK 606042* ARE CURRENT. 020109PK 606050 020109PK 606060 MOVE LOW-VALUE TO WHM-C-STATE-DATA. 020109PK 606062 MOVE WHM-STATE-IDLE TO WHM-C-STATE. 020109PK 606064 MOVE ZERO TO WHM-C-STEP. 020109PK 606066 MOVE ZERO TO WHM-C-REFRESH-SECS. 020109PK 606140 MOVE SPACE TO WM-TEXT. 020109PK 606150 STRING "Logged in " DELIMITED BY SIZE, 020109PK 606160 WHM-ID-USER-ID DELIMITED BY SPACE, 020109PK 606170 " ON " DELIMITED BY SIZE, 020109PK 606180 WHM-ID-HOST-NAME DELIMITED BY SPACE, 020120PK 606190 " (" DELIMITED BY SIZE, 020109PK 606200 WHM-H-REMOTE-ADDRESS DELIMITED BY SPACE, 020109PK 606210 ")" DELIMITED BY SIZE INTO WM-TEXT. 020109PK 606220 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT. 020109PK 606230 020109PK 606240 1050-EXIT. 020109PK 606250 EXIT. 020109PK 606500 020109PK 606510******************************************************************020109PK 606520 1052-HTTP-DENY-ACCESS. 020109PK 606530* DENIES ACCESS TO THE CURRENT STATION AND "POISONS" THE 020109PK 606540* COOKIE SO FURTHER LOGON ATTEMPTS ARE REFUSED. 020109PK 606550 020109PK 606560 MOVE 403 TO WHM-STATUS-CODE. 020109PK 606570 PERFORM 1090-HTTP-SET-STATUS-CODE THRU 1090-EXIT. 020109PK 606580 MOVE LOW-VALUE TO WHM-C-STATE-DATA. 020109PK 606590 MOVE WHM-STATE-DENIED TO WHM-C-STATE. 020109PK 606600 MOVE ZERO TO WHM-C-STEP. 020109PK 606610 MOVE SPACE TO WM-TEXT. 020109PK 606620 STRING "Denied " DELIMITED BY SIZE, 020109PK 606630 WHM-ID-USER-ID DELIMITED BY SPACE, 020109PK 606640 " ON " DELIMITED BY SIZE, 020109PK 606650 WHM-ID-HOST-NAME DELIMITED BY SPACE, 020120PK 606660 " (" DELIMITED BY SIZE, 020109PK 606670 WHM-H-REMOTE-ADDRESS DELIMITED BY SPACE, 020109PK 606680 ")" DELIMITED BY SIZE INTO WM-TEXT. 020109PK 606690 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT. 020109PK 606700 020109PK 606710 1052-EXIT. 020109PK 606720 EXIT. 020109PK 608000 020120PK 608010******************************************************************020120PK 608020 1080-HTTP-SET-NO-CACHE. 020120PK 608030* SETS THE Cache-Control: no-cache HEADER (PLUS THE RELATED 021101PK 608035* PRAGMA FOR OLDER BROWSERS). 021101PK 608040 020120PK 608050 MOVE "Cache-Control" TO W-NAME. 020120PK 608060 MOVE "no-cache" TO W-VALUE. 020120PK 608070 CALL "SET_HEADER IN WEBAPPSUPPORT" USING 020120PK 608080 FHM-HTTP-MSG, W-NAME, W-VALUE GIVING W-RESULT. 020120PK 608090 MOVE "Pragma" TO W-NAME. 020120PK 608100 CALL "SET_HEADER IN WEBAPPSUPPORT" USING 020120PK 608110 FHM-HTTP-MSG, W-NAME, W-VALUE GIVING W-RESULT. 020120PK 608120 020120PK 608130 1080-EXIT. 020120PK 608140 EXIT. 020120PK 609000 020109PK 609020******************************************************************020109PK 609040 1090-HTTP-SET-STATUS-CODE. 020109PK 609060* FORMATS THE HTTP STATUS CODE AND SETS THE STATUS CODE IN THE 020109PK 609080* OUTPUT MESSAGE HEADER. 020109PK 609100 020109PK 609120 MOVE WHM-STATUS-CODE TO W-INT-1. 020109PK 609140 MOVE WHM-STATUS-SUBCODE TO W-INT-2. 020109PK 609160 MOVE WHM-STATUS-TEXT TO W-VALUE. 020109PK 609180 COMPUTE W-L = FUNCTION FORMATTED-SIZE (W-VALUE). 020109PK 609200 CALL "SET_STATUS_CODE IN WEBAPPSUPPORT" USING 020109PK 609220 FHM-HTTP-MSG, W-INT-1, W-INT-2, W-VALUE, W-L 020109PK 609240 GIVING W-RESULT. 020109PK 609260 MOVE ZERO TO WHM-STATUS-CODE, WHM-STATUS-SUBCODE. 020109PK 609280 MOVE SPACE TO WHM-STATUS-TEXT. 020109PK 609300 020109PK 609320 1090-EXIT. 020109PK 609340 EXIT. 020109PK 610000 020109PK 610020******************************************************************020109PK 610022 1100-SECTION SECTION. 020214PK 610024******************************************************************020214PK 610040 1100-HTTP-SEND-MESSAGE. 020109PK 610060* SENDS THE CURRENT MESSAGE IN FHM-HTTP-MSG BACK TO WEBPCM. 020109PK 610080 020109PK 610100 CALL "GET_MESSAGE_LENGTH IN WEBAPPSUPPORT" USING 020109PK 610120 FHM-HTTP-MSG, W-L GIVING W-RESULT. 020109PK 610140 MOVE W-L TO CDO-MSG-SIZE. 020109PK 610160 020109PK 610180 SEND CDO-COMS FROM FHM-HTTP-MSG WITH EMI BEFORE 0 LINES. 020109PK 610200 020109PK 610220 IF WTL-LOGGING = W-TRUE 020109PK 610225 STRING FHM-HTTP-MSG FOR W-L INTO FCM-COMS-MSG 021101PK 610240 PERFORM 9804-LOG-CDO-TRAFFIC THRU 9804-EXIT. 020109PK 610260 020109PK 610280 IF CDO-STATUS NOT = ZERO 020109PK 610300 MOVE CDO-STATUS TO WM-STATUS-VALUE 020109PK 610320 MOVE "Send-HTTP status (1100): " TO WM-STATUS-TEXT 020109PK 610340 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT. 020109PK 610360 020109PK 610380 1100-EXIT. 020109PK 610400 EXIT. 020109PK 612000 020109PK 612020******************************************************************020109PK 612040 1120-HTTP-SEND-REPLY. 020109PK 612060* FINALIZES THE MESSAGE, SETS THE CONTENT, AND SENDS THE 020109PK 612080* FINAL HTTP REPLY SEGMENT BACK TO THE WEBPCM. IF THE OUTPUT 020120PK 612090* IS CHUNKED, FORMATS THE CHUNK ENVELOPE. 020120PK 612100 020109PK 612110 PERFORM 1048-HTTP-SET-COOKIE THRU 1048-EXIT. 021118PK 612120 IF WHM-CHUNKED-OUTPUT NOT = W-TRUE OR 020120PK 612122 WHM-FINAL-CHUNK = W-TRUE 020120PK 612124 STRING WHM-CRLF, "" DELIMITED BY SIZE 021101PK 612126 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX. 020120PK 612130 020120PK 612132 IF WHM-CHUNKED-OUTPUT = W-TRUE 020120PK 612134 PERFORM 1134-HTTP-FORMAT-CHUNK THRU 1134-EXIT 020120PK 612136 MOVE WHM-FINAL-CHUNK TO W-X 020120PK 612138 ELSE 020120PK 612140 MOVE W-TRUE TO W-X. 020120PK 612150 020120PK 612160 SUBTRACT 1 FROM WHC-INDEX. 020109PK 612180 CALL "SET_CONTENT IN WEBAPPSUPPORT" USING 020109PK 612200 FHM-HTTP-MSG, WHC-HTTP-CONTENT, W-ONE, WHC-INDEX, 020109PK 612220 W-X GIVING W-RESULT. 020120PK 612240 IF W-RESULT < ZERO 020109PK 612250 CALL SYSTEM DUMP 020120PK 612260 MOVE W-RESULT TO WM-STATUS-VALUE 020109PK 612280 MOVE "SET_CONTENT error (1120)" TO WM-STATUS-TEXT 020109PK 612300 PERFORM 9806-LOG-DISPLAY THRU 9806-EXIT. 020109PK 612320 020109PK 612340 PERFORM 1100-HTTP-SEND-MESSAGE THRU 1100-EXIT. 020109PK 612350 020120PK 612352 IF WHM-CHUNKED-OUTPUT = W-TRUE 020120PK 612354 IF WHM-FINAL-CHUNK NOT = W-TRUE 020120PK 612356 CALL "SET_CONTENT IN WEBAPPSUPPORT" USING 020120PK 612358 FHM-HTTP-MSG, WHC-HTTP-CONTENT, W-ONE, W-ZERO, 020120PK 612360 W-FALSE GIVING W-RESULT 020120PK 612362 COMPUTE WHC-INDEX = 020120PK 612364 FUNCTION FORMATTED-SIZE (WHM-CHUNK-HEADER) + 1 020207PK 612366 PERFORM 1136-HTTP-CALC-CONTENT-SIZE THRU 1136-EXIT. 020207PK 612370 020120PK 612380 1120-EXIT. 020109PK 612400 EXIT. 020109PK 613000 020109PK 613020******************************************************************020109PK 613040 1130-HTTP-START-REPLY-HEADER. 020109PK 613060* INITIALIZES THE OUTPUT AREA FOR HTTP MESSAGES AND FORMATS 020109PK 613080* THE PAGE HEADER. ASSUMES WHM-SH1-TITLE IS ALREADY SET. 020109PK 613082* NOTE: THE WEBPCM DOESN'T SEEM ABLE TO RECOGNIZE CHUNKED 020207PK 613084* OUTPUT, BUT PUTTING A DUMMY CONTENT-LENGTH HEADER IN THE 020207PK 613086* HTTP MESSAGE SEEMS TO ALLOW THIS TO WORK. 020207PK 613100 020109PK 613120 MOVE W-FALSE TO WHM-FINAL-CHUNK. 020120PK 613140 IF WHM-CHUNKED-OUTPUT = W-TRUE 020120PK 613150 MOVE "Content-Length" TO W-NAME 020207PK 613152 MOVE "99999999" TO W-VALUE 021101PK 613154 CALL "SET_HEADER IN WEBAPPSUPPORT" USING 020207PK 613156 FHM-HTTP-MSG, W-NAME, W-VALUE GIVING W-RESULT 020207PK 613160 MOVE "Transfer-Encoding" TO W-NAME 020120PK 613180 MOVE "chunked" TO W-VALUE 020120PK 613200 CALL "SET_HEADER IN WEBAPPSUPPORT" USING 020120PK 613220 FHM-HTTP-MSG, W-NAME, W-VALUE GIVING W-RESULT 020120PK 613240 COMPUTE WHC-INDEX = 020120PK 613260 FUNCTION FORMATTED-SIZE (WHM-CHUNK-HEADER) + 1 020120PK 613280 ELSE 020120PK 613300 MOVE 1 TO WHC-INDEX. 020120PK 613320 020120PK 613330 PERFORM 1136-HTTP-CALC-CONTENT-SIZE THRU 1136-EXIT. 020207PK 613340 STRING WHM-STD-HEADER-1 DELIMITED BY SIZE 020120PK 613360 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX. 020120PK 613380 020120PK 613400 1130-EXIT. 020120PK 613420 EXIT. 020120PK 613500 020109PK 613520******************************************************************020109PK 613540 1132-HTTP-END-REPLY-HEADER. 020109PK 613560* APPENDS THE END OF THE HEADER TO THE HTTP REPLY MESSAGE. 020109PK 613600 020109PK 613740 STRING WHM-STD-HEADER-2 DELIMITED BY SIZE 020109PK 613760 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX. 020109PK 613780 020109PK 613800 1132-EXIT. 020109PK 613820 EXIT. 020109PK 614000 020120PK 614020******************************************************************020120PK 614040 1134-HTTP-FORMAT-CHUNK. 020120PK 614060* FORMATS A CHUNK HEADER AND PREPENDS IT TO THE MESSAGE TEXT 020120PK 614080* (ASSUMES SPACE HAS BEEN LEFT FOR IT IN THE FRONT OF WHC- 020120PK 614100* HTTP-CONTENT), AND APPENDS A CR-LF TO THE TEXT. IF THE 020120PK 614120* WHM-FINAL-CHUNK FLAG IS SET, APPENDS A LAST-CHUNK TRAILER. 020120PK 614140 020120PK 614160 MOVE ZERO TO WHM-CHUNK-SIZE. 020120PK 614180 SET WHM-CHX TO WHM-CHUNK-HEX-MAX. 020120PK 614200 MOVE 3 TO W-X. 020120PK 614220 MOVE ZERO TO W-L. 020120PK 614240 COMPUTE WEA-INTEGER = WHC-INDEX - 1 - 020120PK 614260 FUNCTION FORMATTED-SIZE (WHM-CHUNK-HEADER). 020120PK 614280 020120PK 614300 1134-HEX-XLATE-LOOP. 020120PK 614320 MOVE WEA-INTEGER TO W-L [W-X:3:4]. 020120PK 614340 IF W-L NOT = ZERO 020120PK 614360 MOVE WHM-HEXIT (W-L + 1) TO WHM-CHUNK-HEXIT (WHM-CHX). 020120PK 614380 020120PK 614400 IF WHM-CHX > 1 020120PK 614420 SET WHM-CHX DOWN BY 1 020120PK 614440 ADD 4 TO W-X 020120PK 614460 GO TO 1134-HEX-XLATE-LOOP. 020120PK 614480 020120PK 614500 STRING WHM-CHUNK-HEADER DELIMITED BY SIZE 020120PK 614520 INTO WHC-HTTP-CONTENT. 020120PK 614540 STRING WHM-CRLF DELIMITED BY SIZE 021101PK 614560 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX. 020120PK 614580 IF WHM-FINAL-CHUNK = W-TRUE 020120PK 614600 STRING WHM-CHUNK-TRAILER DELIMITED BY SIZE 020120PK 614620 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX. 020120PK 614640 020120PK 614660 1134-EXIT. 020120PK 614680 EXIT. 020120PK 614700 020207PK 614710******************************************************************020207PK 614720 1136-HTTP-CALC-CONTENT-SIZE. 020207PK 614730* COMPUTES THE AMOUNT OF SPACE AVAILABLE IN THE WEBPCM 020207PK 614740* MESSAGE OBJECT AND STORES IT IN WHC-LIMIT. 020207PK 614750 020207PK 614760 CALL "GET_MESSAGE_LENGTH IN WEBAPPSUPPORT" USING 020207PK 614770 FHM-HTTP-MSG, WHC-LIMIT GIVING W-RESULT. 020207PK 614780 COMPUTE WHC-LIMIT = 020207PK 614790 FUNCTION FORMATTED-SIZE (WHC-HTTP-CONTENT) - 020207PK 614800 WHC-LIMIT - 512. 020207PK 614810 020207PK 614820 1136-EXIT. 020207PK 614830 EXIT. 020207PK 615000 020120PK 615020******************************************************************020120PK 615040 1150-HTTP-FIND-NAME-VALUE. 020120PK 615060* SEARCHES WCJ-NAME-VALUE-TABLE FOR A NAME ENTRY MATCHING 020120PK 615080* W-NAME. ASSUMES TABLE HAS ALREADY BEEN LOADED WITH THE NAME- 020120PK 615100* VALUE PAIRS AND THE NUMBER OF ENTRIES IS IN WCJ-ENTRIES. 020120PK 615120* IF NAME IS FOUND, RETURNS WITH WCJ-INDEX AND WCJ-VX SET TO 020120PK 615140* THE NAME-VALUE ENTRY; IF NOT FOUND, RETURNS WITH WCJ-INDEX 020120PK 615160* SET TO ZERO. 020120PK 615180 020120PK 615200 IF WCJ-ENTRIES < 1 020120PK 615220 MOVE ZERO TO WCJ-INDEX 020120PK 615240 GO TO 1150-EXIT. 020120PK 615260 020120PK 615280 IF WCJ-ENTRIES > WCJ-NAME-VALUE-MAX 020120PK 615300 SET WCJ-VX TO WCJ-NAME-VALUE-MAX 020120PK 615320 ELSE 020120PK 615340 SET WCJ-VX TO WCJ-ENTRIES. 020120PK 615360 020120PK 615380 1150-FIND-NAME-VALUE-LOOP. 020120PK 615400 IF WCJ-NAME (WCJ-VX) = W-NAME 020120PK 615420 SET WCJ-INDEX TO WCJ-VX 020120PK 615440 ELSE 020120PK 615460 IF WCJ-VX > 1 020120PK 615480 SET WCJ-VX DOWN BY 1 020120PK 615500 GO TO 1150-FIND-NAME-VALUE-LOOP 020120PK 615520 ELSE 020120PK 615540 MOVE ZERO TO WCJ-INDEX. 020120PK 615580 020120PK 615600 1150-EXIT. 020120PK 615620 EXIT. 020120PK 616000 020120PK 616020******************************************************************020120PK 616040 1152-HTTP-FIND-SEL-VALUE. 020120PK 616060* SEARCHES WCJ-SELECTION-TABLE FOR A NAME ENTRY MATCHING 020120PK 616080* W-NAME. ASSUMES TABLE HAS ALREADY BEEN LOADED WITH THE NAME- 020120PK 616100* VALUE PAIRS AND THE NUMBER OF ENTRIES IS IN WCJ-ENTRIES. 020120PK 616120* IF NAME IS FOUND, RETURNS WITH WCJ-INDEX AND WCJ-SX SET TO 020120PK 616140* THE NAME-VALUE ENTRY; IF NOT FOUND, RETURNS WITH WCJ-INDEX 020120PK 616160* SET TO ZERO. 020120PK 616180 020120PK 616200 IF WCJ-ENTRIES < 1 020120PK 616220 MOVE ZERO TO WCJ-INDEX 020120PK 616240 GO TO 1152-EXIT. 020120PK 616260 020120PK 616280 IF WCJ-ENTRIES > WCJ-SELECTION-MAX 020120PK 616300 SET WCJ-SX TO WCJ-SELECTION-MAX 020120PK 616320 ELSE 020120PK 616340 SET WCJ-SX TO WCJ-ENTRIES. 020120PK 616360 020120PK 616380 1152-FIND-SELECTION-LOOP. 020120PK 616400 IF WCJ-SEL-NAME (WCJ-SX) = W-NAME 020120PK 616420 SET WCJ-INDEX TO WCJ-SX 020120PK 616440 ELSE 020120PK 616460 IF WCJ-SX > 1 020120PK 616480 SET WCJ-SX DOWN BY 1 020120PK 616500 GO TO 1152-FIND-SELECTION-LOOP 020120PK 616520 ELSE 020120PK 616540 MOVE ZERO TO WCJ-INDEX. 020120PK 616560 020120PK 616580 1152-EXIT. 020120PK 616600 EXIT. 020120PK 620000 020214PK 620010******************************************************************020214PK 620020 1200-SECTION SECTION. 020214PK 620030******************************************************************020214PK 620040 1200-USER-SEND-ECHO. 020214PK 620050* FORMATS AND SENDS AN ECHO PAGE TO THE ORIGINATOR. THIS IS 020214PK 620060* ABOUT THE ONLY THING THAT CAN BE DONE WITHOUT SIGNING ON. 020214PK 620070 020214PK 620080 PERFORM 1080-HTTP-SET-NO-CACHE THRU 1080-EXIT. 020214PK 620090 PERFORM 1130-HTTP-START-REPLY-HEADER THRU 1130-EXIT. 020214PK 620100 PERFORM 1132-HTTP-END-REPLY-HEADER THRU 1132-EXIT. 020214PK 620110 020214PK 620120 PERFORM Q112-READ-SYSTEM-TIME THRU Q112-EXIT. 020214PK 620130 MOVE WDA-SYS-HOUR TO WEA-STAMP-HOUR. 020214PK 620140 MOVE WDA-SYS-MIN TO WEA-STAMP-MINUTE. 020214PK 620150 MOVE WDA-SYS-DATE TO WDA-IN-DATE. 020214PK 620160 PERFORM Q150-FORMAT-MMDDYYYY THRU Q150-EXIT. 020214PK 620170 020214PK 620180 STRING "

AS4026 WEBPCM Demo Echo Result

", 021101PK 620185 "

", 021101PK 620190 "
ItemValue", 020214PK 620200 "
Time", 020214PK 620210 WEA-FORMAT-TIMESTAMP, SPACE, WDA-MM-DD-YYYY, 020214PK 620212 "
Method" DELIMITED BY SIZE, 021101PK 620214 WHM-H-METHOD DELIMITED BY SPACE, 021101PK 620220 "
App Path" DELIMITED BY SIZE, 020214PK 620230 WHM-H-APP-PATH DELIMITED BY SIZE, 020214PK 620240 "
IP Address" DELIMITED BY SIZE, 020214PK 620250 WHM-H-REMOTE-ADDRESS DELIMITED BY SPACE, 020214PK 620260 "
Remote Host" DELIMITED BY SIZE 020214PK 620270 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX. 020214PK 620280 020214PK 620290 IF WHM-H-REMOTE-HOST = SPACE 020214PK 620300 STRING "(none)" DELIMITED BY SIZE 020214PK 620310 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX 020214PK 620320 ELSE 020214PK 620330 STRING WHM-H-REMOTE-HOST DELIMITED BY SPACE, 020214PK 620340 "
Term-ID", 020214PK 620350 WHM-ID-HOST-NAME DELIMITED BY SIZE 020214PK 620360 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX. 020214PK 620370 020214PK 620380 STRING "
Remote User" DELIMITED BY SIZE020214PK 620390 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX. 020214PK 620400 IF WHM-H-REMOTE-USER = SPACE 020214PK 620410 STRING "(none)" DELIMITED BY SIZE 020214PK 620420 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX 020214PK 620430 ELSE 020214PK 620440 STRING WHM-H-REMOTE-USER DELIMITED BY SIZE, 020214PK 620450 "
User Name", WHM-ID-USER-ID, 020214PK 620460 "
Password", WHM-ID-PASSWORD, 020214PK 620470 " " DELIMITED BY SIZE 020214PK 620480 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX. 020214PK 620500 021101PK 620520 STRING "
Cookie", 021101PK 620540 WHM-COOKIE-LAYOUT DELIMITED BY SIZE 021101PK 620560 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX. 021101PK 620570 SET WCJ-CX TO 1. 021101PK 620580 021101PK 620590 1200-ECHO-COOKIE-LOOP. 021101PK 620600 IF WCJ-CX NOT > WCJ-ENTRIES 021101PK 620610 STRING "
Raw cookie", 021101PK 620620 WCJ-COOKIE-NAME (WCJ-CX), " = ", 021101PK 620630 WCJ-COOKIE-VALUE (WCJ-CX) DELIMITED BY SIZE 021101PK 620640 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX 021101PK 620650 SET WCJ-CX UP BY 1 021101PK 620660 GO TO 1200-ECHO-COOKIE-LOOP. 021101PK 620720 020214PK 620730 STRING "

", WHS-HOME-LINK DELIMITED BY SIZE 021101PK 620750 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX. 020214PK 620760 020214PK 620770 PERFORM 1120-HTTP-SEND-REPLY THRU 1120-EXIT. 020214PK 620780 020214PK 620790 1200-EXIT. 020214PK 620800 EXIT. 020214PK 650000 020120PK 650020******************************************************************020120PK 650040 1500-SECTION SECTION. 020120PK 650060******************************************************************020120PK 650080 1500-USER-SEND-HOME. 020120PK 650100* FORMATS AND SENDS THE WEBPCM WEB USER HOME PAGE TO THE 021101PK 650120* ORIGINATOR. 020120PK 650140 020120PK 650150 PERFORM 1130-HTTP-START-REPLY-HEADER THRU 1130-EXIT. 021101PK 650160 PERFORM 1132-HTTP-END-REPLY-HEADER THRU 1132-EXIT. 021101PK 650210 PERFORM 1080-HTTP-SET-NO-CACHE THRU 1080-EXIT. 020120PK 650300 020120PK 650320 PERFORM Q112-READ-SYSTEM-TIME THRU Q112-EXIT. 020214PK 650340 MOVE WDA-SYS-HOUR TO WHS-HOME-HEAD-HOUR. 021101PK 650360 MOVE WDA-SYS-MIN TO WHS-HOME-HEAD-MINUTE. 021101PK 650380 MOVE WDA-SYS-DATE TO WDA-IN-DATE. 021101PK 650400 PERFORM Q152-FORMAT-DDMMMYYYY THRU Q152-EXIT. 021101PK 650420 MOVE WDA-DD-MMM-YYYY TO WHS-HOME-HEAD-DATE. 021101PK 650440 021101PK 650460 STRING WHS-HOME-PAGE DELIMITED BY SIZE 021101PK 650480 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX. 021101PK 650500 PERFORM 1120-HTTP-SEND-REPLY THRU 1120-EXIT. 021101PK 650520 020120PK 650540 1500-EXIT. 020120PK 650560 EXIT. 020120PK 653000 020120PK 653020******************************************************************020120PK 653040 1530-USER-LOGOUT. 021101PK 653060* LOGS THE USER OFF THE CURRENT PSEUDO-SESSION. 021101PK 653100 020120PK 653120 PERFORM 1130-HTTP-START-REPLY-HEADER THRU 1130-EXIT. 020120PK 653130 PERFORM 1132-HTTP-END-REPLY-HEADER THRU 1132-EXIT. 020120PK 653200 021101PK 653350 MOVE WHM-STATE-LOGOFF TO WHM-C-STATE. 021101PK 653360 MOVE ZERO TO WHM-C-STEP. 021101PK 653400 STRING WHM-LOGOFF-BODY DELIMITED BY SIZE 020120PK 653410 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX. 021101PK 653420 PERFORM 1080-HTTP-SET-NO-CACHE THRU 1080-EXIT. 021101PK 653790 PERFORM 1120-HTTP-SEND-REPLY THRU 1120-EXIT. 020120PK 653800 020120PK 653810 1530-EXIT. 020120PK 653820 EXIT. 020120PK 660000 020120PK 660010******************************************************************020207PK 660020 1600-SECTION SECTION. 020207PK 660030******************************************************************020207PK 660040 1600-USER-CAL-SHOW. 021101PK 660060* FORMATS THE DEMO CALENDAR PAGE. 021101PK 660080 020120PK 660100 PERFORM 1080-HTTP-SET-NO-CACHE THRU 1080-EXIT. 020120PK 660110 MOVE W-TRUE TO WHM-CHUNKED-OUTPUT. 020120PK 660120 PERFORM 1130-HTTP-START-REPLY-HEADER THRU 1130-EXIT. 020120PK 660140 PERFORM 1132-HTTP-END-REPLY-HEADER THRU 1132-EXIT. 021101PK 660160 MOVE W-FALSE TO WEA-EDIT-ERROR. 021101PK 660340 020120PK 660360 PERFORM Q112-READ-SYSTEM-TIME THRU Q112-EXIT. 020214PK 660380 MOVE WDA-SYS-HOUR TO WHS-CAL-HEAD-HOUR. 021101PK 660400 MOVE WDA-SYS-MIN TO WHS-CAL-HEAD-MINUTE. 021101PK 660420 MOVE WDA-SYS-DATE TO WDA-IN-DATE. 021101PK 660440 PERFORM Q152-FORMAT-DDMMMYYYY THRU Q152-EXIT. 021101PK 660460 MOVE WDA-DD-MMM-YYYY TO WHS-CAL-HEAD-DATE. 021101PK 660480 STRING WHS-CAL-HEAD DELIMITED BY SIZE 021101PK 660500 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX. 021101PK 660520 021101PK 660540 STRING WHS-CAL-FORM-TAG DELIMITED BY SIZE 021101PK 660560 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX. 021101PK 660580 PERFORM 1620-USER-CAL-PARSE-PARAM THRU 1620-EXIT. 021101PK 660600 021101PK 660620 PERFORM 1610-USER-MONTH-LIST-GEN THRU 1610-EXIT. 021101PK 660640 MOVE WIV-CAL-YEAR TO WHS-YEAR-TEXT-VALUE. 021101PK 660660 STRING WHS-YEAR-TEXT-TAG, WHS-GO-BUTTON-TAG DELIMITED BY SIZE021101PK 660680 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX. 021101PK 660700 STRING "" DELIMITED BY SIZE 021101PK 660720 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX. 021101PK 660740 021101PK 660760 IF WEA-EDIT-ERROR NOT = W-TRUE 021101PK 660780 PERFORM 1630-USER-CAL-FORMAT THRU 1630-EXIT. 021101PK 660800 020120PK 660820 STRING "

", WHS-HOME-LINK DELIMITED BY SIZE 021101PK 660840 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX. 021101PK 660860 MOVE W-TRUE TO WHM-FINAL-CHUNK. 020120PK 660880 PERFORM 1120-HTTP-SEND-REPLY THRU 1120-EXIT. 020120PK 660900 020120PK 660920 1600-EXIT. 020120PK 660940 EXIT. 020120PK 661000 021101PK 661020******************************************************************021101PK 661040 1610-USER-MONTH-LIST-GEN. 661060* GENERATES AN HTML " DELIMITED BY SIZE 021101PK 661540 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX. 021101PK 661560 021101PK 661580 1610-EXIT. 021101PK 661600 EXIT. 021101PK 662000 021101PK 662010******************************************************************021101PK 662020 1620-USER-CAL-PARSE-PARAM. 021101PK 662030* PARSES THE MONTH AND YEAR PARAMETERS FOR THE CALENDAR FORM. 021101PK 662040* IF THERE ARE ERRORS IN THE PARAMETERS, WEA-EDIT-ERROR IS SET 021101PK 662050* TO TRUE. IF NO PARAMETERS ARE SPECIFIED, THE MONTH AND YEAR 021101PK 662060* ARE SET TO THE CURRENT DATE. RESULTS ARE RETURNED IN 021101PK 662070* WDA-IN-DATE. 021101PK 662080 021101PK 662090 CALL "PARSE_QUERY_STRING IN WEBAPPSUPPORT" USING 021101PK 662100 FHM-HTTP-MSG, WCJ-NAME-LEN, WCJ-VALUE-LEN, 021101PK 662110 WCJ-CONTENT-JAR, WCJ-ENTRIES GIVING W-RESULT. 021101PK 662120 021101PK 662130 MOVE SPACE TO WIV-CAL-MONTH, WIV-CAL-YEAR. 021101PK 662140 MOVE "Month" TO W-NAME. 021101PK 662150 PERFORM 1150-HTTP-FIND-NAME-VALUE THRU 1150-EXIT. 021101PK 662160 IF WCJ-INDEX > ZERO 021101PK 662170 MOVE WCJ-VALUE (WCJ-VX) TO WIV-CAL-MONTH, WEA-NUMBER-IN 021101PK 662180 PERFORM 9500-PARSE-NUMBER THRU 9500-EXIT 021101PK 662190 IF WEA-NUMBER-VALID = W-TRUE 021101PK 662200 IF WEA-NUMBER-OUT = ZERO 021101PK 662210 MOVE WDA-SYS-MM TO WDA-IN-MM 021101PK 662220 ELSE 021101PK 662230 MOVE WEA-NUMBER-OUT TO WDA-IN-MM 021101PK 662240 ELSE 021101PK 662250 MOVE W-TRUE TO WEA-EDIT-ERROR 021101PK 662260 MOVE ZERO TO WDA-IN-MM 021101PK 662270 STRING "

", 021118PK 662280 "Invalid month value" DELIMITED BY SIZE 021101PK 662290 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX 021101PK 662300 ELSE 021101PK 662310 MOVE WDA-SYS-MM TO WDA-IN-MM. 021101PK 662320 021101PK 662330 MOVE "Year" TO W-NAME. 021101PK 662340 PERFORM 1150-HTTP-FIND-NAME-VALUE THRU 1150-EXIT. 021101PK 662350 IF WCJ-INDEX > ZERO 021101PK 662360 MOVE WCJ-VALUE (WCJ-VX) TO WIV-CAL-YEAR, WEA-NUMBER-IN 021101PK 662370 PERFORM 9500-PARSE-NUMBER THRU 9500-EXIT 021101PK 662380 IF WEA-NUMBER-VALID = W-TRUE 021101PK 662390 IF WEA-NUMBER-OUT = ZERO 021101PK 662400 MOVE WDA-SYS-YY TO WDA-IN-YY, WIV-CAL-YEAR-N 021101PK 662410 ELSE 021101PK 662420 MOVE WEA-NUMBER-OUT TO WDA-IN-YY, WIV-CAL-YEAR-N 021101PK 662430 ELSE 021101PK 662440 MOVE W-TRUE TO WEA-EDIT-ERROR 021101PK 662450 MOVE ZERO TO WDA-IN-YY 021101PK 662460 STRING "

", 021118PK 662470 "Invalid year value" DELIMITED BY SIZE 021101PK 662480 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX 021101PK 662490 ELSE 021101PK 662500 MOVE WDA-SYS-YY TO WDA-IN-YY, WIV-CAL-YEAR-N. 021101PK 662510 021101PK 662520 IF WEA-EDIT-ERROR NOT = W-TRUE 021101PK 662530 PERFORM Q140-DEDUCE-CENTURY THRU Q140-EXIT 021101PK 662540 MOVE WDA-OUT-DATE TO WDA-IN-DATE 021101PK 662550 MOVE WDA-IN-YY TO WIV-CAL-YEAR-N 021101PK 662560 IF WDA-IN-YY < 1900 OR WDA-IN-YY > 2099 021101PK 662570 MOVE W-TRUE TO WEA-EDIT-ERROR 021101PK 662580 STRING "

", 021118PK 662590 "Year must be in range 1900-2099" 021118PK 662600 DELIMITED BY SIZE 021101PK 662610 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX. 021101PK 662620 021101PK 662630 1620-EXIT. 021101PK 662640 EXIT. 021101PK 663000 021101PK 663020******************************************************************021101PK 663040 1630-USER-CAL-FORMAT. 021101PK 663060* FORMATS A STANDARD MONTH CALENDAR TABLE FOR THE MONTH AND 021101PK 663080* YEAR IN WDA-IN-DATE. 021101PK 663100 021101PK 663120 STRING WHS-CAL-TABLE-HEAD, "

 " DELIMITED BY SIZE 021101PK 663320 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX 021101PK 663340 ADD 1 TO W-X 021101PK 663360 GO TO 1630-FILL-PRE-DAY-LOOP. 021101PK 663380 021101PK 663400 1630-FILL-MONTH-DAY-LOOP. 021101PK 663420 IF WDA-WEEK-DAY > 7 021101PK 663440 MOVE 1 TO WDA-WEEK-DAY 021101PK 663460 STRING "
 " DELIMITED BY SIZE 021101PK 663780 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX 021101PK 663800 ADD 1 TO WDA-WEEK-DAY 021101PK 663820 GO TO 1630-FILL-POST-DAY-LOOP. 021101PK 663840 021101PK 663860 STRING "
" DELIMITED BY SIZE 021101PK 663880 INTO WHC-HTTP-CONTENT POINTER WHC-INDEX. 021101PK 663900 021101PK 663920 1630-EXIT. 021101PK 663940 EXIT. 021101PK 950000/ 021101PK 950020******************************************************************021101PK 950040 9500-SECTION SECTION. 021101PK 950060******************************************************************021101PK 950080 9500-PARSE-NUMBER. 950100* PARSES THE STRING IN WEA-NUMBER-IN, TRANSLATING IT TO A 021101PK 950120* DECIMAL WHOLE NUMBER IN WEA-NUMBER-OUT. IF THE INPUT STRING 021101PK 950140* IS NOT VALID, WEA-NUMBER-VALID WILL BE FALSE (ZERO) AND THE 021101PK 950160* VALUE OF WEA-NUMBER-OUT WILL BE UNDEFINED. THE NUMBER MAY 021101PK 950180* BE PRECEDED BY SPACES, DOLLAR-SIGNS, OR A HYPHEN (FOR A 021101PK 950200* NEGATIVE VALUE); IT MAY BE FOLLOWED BY SPACES OR A HYPHEN. 021101PK 950220* THE NUMBER MAY CONTAIN COMMAS, BUT NO SPACES, DECIMAL POINT, 021101PK 950240* OR OTHER NON-NUMERIC CHARACTERS. 021101PK 950260 021101PK 950280 MOVE ZERO TO WEA-NUMBER-OUT. 021101PK 950300 MOVE W-FALSE TO WEA-NUMBER-VALID, WEA-NUMBER-NEG. 021101PK 950320 SET WEA-NICX TO 1. 021101PK 950340 SET WEA-NIEX, WEA-NOCX TO WEA-NUMBER-DIGITS-MAX. 021101PK 950360 021101PK 950380 9500-NUMBER-TRIM-LOOP. 021101PK 950400 IF WEA-NIC (WEA-NIEX) = SPACE 021101PK 950420 NEXT SENTENCE 021101PK 950440 ELSE IF WEA-NIC (WEA-NIEX) = "-" 021101PK 950460 MOVE W-TRUE TO WEA-NUMBER-NEG 021101PK 950480 ELSE 021101PK 950500 GO TO 9500-NUMBER-DEBLANK-LOOP. 021101PK 950520 021101PK 950540 IF WEA-NIEX > 1 021101PK 950560 SET WEA-NIEX DOWN BY 1 021101PK 950580 GO TO 9500-NUMBER-TRIM-LOOP 021101PK 950600 ELSE 021101PK 950620 MOVE W-TRUE TO WEA-NUMBER-VALID 021101PK 950640 GO TO 9500-EXIT. 021101PK 950660 021101PK 950680 9500-NUMBER-DEBLANK-LOOP. 021101PK 950700 IF WEA-NIC (WEA-NICX) = SPACE 021101PK 950720 NEXT SENTENCE 021101PK 950740 ELSE IF WEA-NIC (WEA-NICX) = "-" 021101PK 950760 MOVE W-TRUE TO WEA-NUMBER-NEG 021101PK 950780 ELSE IF WEA-NIC (WEA-NICX) = "$" 021101PK 950800 NEXT SENTENCE 021101PK 950820 ELSE 021101PK 950840 GO TO 9500-NUMBER-PARSE-LOOP. 021101PK 950860 021101PK 950880 IF WEA-NICX < WEA-NIEX 021101PK 950900 SET WEA-NICX UP BY 1 021101PK 950920 GO TO 9500-NUMBER-DEBLANK-LOOP 021101PK 950940 ELSE 021101PK 950960 MOVE W-TRUE TO WEA-NUMBER-VALID 021101PK 950980 GO TO 9500-EXIT. 021101PK 951000 021101PK 951020 9500-NUMBER-PARSE-LOOP. 021101PK 951040 IF WEA-NIC (WEA-NIEX) IS NUMERIC 021101PK 951060 MOVE WEA-NIN (WEA-NIEX) TO WEA-NON (WEA-NOCX) 021101PK 951080 ELSE IF WEA-NIC (WEA-NIEX) = "," 021101PK 951100 NEXT SENTENCE 021101PK 951120 ELSE 021101PK 951140 GO TO 9500-EXIT. 021101PK 951160 021101PK 951180 IF WEA-NIEX > WEA-NICX 021101PK 951200 SET WEA-NIEX, WEA-NOCX DOWN BY 1 021101PK 951220 GO TO 9500-NUMBER-PARSE-LOOP. 021101PK 951240 021101PK 951260 MOVE W-TRUE TO WEA-NUMBER-VALID. 021101PK 951280 IF WEA-NUMBER-NEG = W-TRUE 021101PK 951300 COMPUTE WEA-NUMBER-OUT = - WEA-NUMBER-OUT. 021101PK 951320 021101PK 951340 9500-EXIT. 021101PK 951360 EXIT. 021101PK 970000/ 970020****************************************************************** 970040 9800-SECTION SECTION. 970060****************************************************************** 970080 9800-WRITE-TRAFFIC-LOG. 970100* WRITES THE CURRENT RECORD TO THE TLF-TRAFFIC-LOG FILE. 970120 970140 MOVE WDA-SYS-DATE TO TLF-DATE. 970160 ACCEPT TLF-TIME FROM TIME. 970180 IF TLF-REC-SIZE < WTL-MIN-REC-SIZE 970200 MOVE WTL-MIN-REC-SIZE TO TLF-REC-SIZE 970202 ELSE 970204 IF TLF-REC-SIZE > WTL-MAX-REC-SIZE 970206 MOVE TLF-REC-SIZE TO WM-STATUS-VALUE 970208 MOVE "TLF recsize overflow (9800)" TO WM-STATUS-TEXT 970212 DISPLAY WM-TEXT 970214 MOVE WTL-MAX-REC-SIZE TO TLF-REC-SIZE. 970220 970240 WRITE TLF-REC. 970260 IF WTL-FILE-STATUS NOT = ZERO 970280 MOVE SPACE TO WM-TEXT 970300 STRING "TLF write status (9800): ", WTL-FILE-STATUS 970320 DELIMITED BY SIZE INTO WM-TEXT 970340 DISPLAY WM-DISPLAY. 970360 970380 MOVE ZERO TO TLF-REC-SIZE. 970400 970420 9800-EXIT. 970440 EXIT. 971000 971020****************************************************************** 971040 9802-LOG-CDI-TRAFFIC. 971060* FORMATS AN INPUT MESSAGE AND HEADER FROM CDI-COMS. 971080* ASSUMES THE TEXT OF THE MESSAGE IS IN FCM-COMS-MSG WITH 020109PK 971100* LENGTH IN CDI-MSG-SIZE. 011009PK 971120 971140 MOVE SPACE TO TLF-COMS-HEADER. 971150 MOVE ZERO TO TLF-COMS-STATE. 971155 MOVE ZERO TO TLF-COMS-STEP. 971160 MOVE CDI-STATUS TO TLF-COMS-STATUS. 971200 MOVE CDI-MSG-SIZE TO TLF-COMS-MSG-SIZE. 971208 MOVE CDI-STATION-NAME TO TLF-COMS-STATION-NAME. 971210 MOVE CDI-USER-NAME TO TLF-COMS-USER-NAME. 971220 MOVE CDI-FUNCTION TO TLF-CDI-FUNCTION. 971240 MOVE CDI-FUNCTION-STATUS TO TLF-CDI-FCN-STATUS. 971260 MOVE ZERO TO TLF-CDI-MSG-COUNT. 971280 MOVE CDI-TIMESTAMP TO TLF-CDI-TIMESTAMP. 971300 MOVE CDI-STATION TO TLF-CDI-STATION. 971320 MOVE CDI-PROGRAM TO TLF-CDI-PROGRAM. 971340 MOVE CDI-USER TO TLF-CDI-USER. 971360 MOVE ZERO TO TLF-SEQ. 011009PK 971380 MOVE "COMS RCV" TO TLF-TYPE. 011009PK 971400 MOVE WTL-FORMAT-CDI TO TLF-FORMAT. 011009PK 971420 MOVE 1 TO WTL-TEXT-INDEX. 011009PK 971500 011009PK 971520 9802-WRITE-CDI-LOOP. 011009PK 971540 COMPUTE WTL-TEXT-LENGTH = 011009PK 971560 CDI-MSG-SIZE - WTL-TEXT-INDEX + 1. 011009PK 971580 IF WTL-TEXT-LENGTH > WTL-MAX-TEXT-SIZE 011009PK 971600 MOVE WTL-MAX-TEXT-SIZE TO WTL-TEXT-LENGTH. 011009PK 971620 011009PK 971640 UNSTRING FCM-COMS-MSG INTO TLF-TEXT FOR WTL-TEXT-LENGTH 020109PK 971660 POINTER WTL-TEXT-INDEX. 011009PK 971680 COMPUTE TLF-REC-SIZE = WTL-TEXT-LENGTH + WTL-HEADER-SIZE. 011009PK 971700 PERFORM 9800-WRITE-TRAFFIC-LOG THRU 9800-EXIT. 011009PK 971720 ADD WTL-TEXT-LENGTH TO WTL-TEXT-INDEX. 011009PK 971740 IF WTL-TEXT-INDEX NOT > CDI-MSG-SIZE 011009PK 971760 ADD 1 TO TLF-SEQ 011009PK 971780 GO TO 9802-WRITE-CDI-LOOP. 011009PK 971800 011009PK 971820 9802-EXIT. 011009PK 971840 EXIT. 011009PK 972000 972020****************************************************************** 972040 9804-LOG-CDO-TRAFFIC. 972060* FORMATS AN OUTPUT MESSAGE AND HEADER FROM CDO-COMS. 972080* ASSUMES THE TEXT OF THE MESSAGE IS IN FCM-COMS-MSG WITH 020109PK 972100* LENGTH IN CDO-MSG-SIZE. 011009PK 972120 972140 MOVE SPACE TO TLF-COMS-HEADER. 972150 MOVE ZERO TO TLF-COMS-STATE. 010920PK 972155 MOVE ZERO TO TLF-COMS-STEP. 010920PK 972160 MOVE CDO-STATUS TO TLF-COMS-STATUS. 972200 MOVE CDO-MSG-SIZE TO TLF-COMS-MSG-SIZE. 972208 MOVE CDO-STATION-NAME TO TLF-COMS-STATION-NAME. 972210 MOVE CDO-USER-NAME TO TLF-COMS-USER-NAME. 972220 MOVE CDO-DEST-COUNT TO TLF-CDO-DEST-COUNT. 972240 MOVE CDO-DESTINATION TO TLF-CDO-DESTINATION. 972260 MOVE CDO-NEXT-AGENDA TO TLF-CDO-NEXT-AGENDA. 972280 IF CDO-SET-NEXT-AGENDA 972300 MOVE 1 TO TLF-CDO-SET-AGENDA 972320 ELSE 972340 MOVE ZERO TO TLF-CDO-SET-AGENDA. 972360 972380 MOVE CDO-CONFIRM-KEY TO TLF-CDO-CONFIRM-KEY. 972400 IF CDO-CONFIRM-FLAG 972420 MOVE 1 TO TLF-CDO-CONFIRM-FLAG 972440 ELSE 972460 MOVE ZERO TO TLF-CDO-CONFIRM-FLAG. 972480 972500 IF CDO-RETAIN-TXN-MODE 972520 MOVE 1 TO TLF-CDO-RETAIN-TXN 972540 ELSE 972560 MOVE ZERO TO TLF-CDO-RETAIN-TXN. 972580 972600 MOVE ZERO TO TLF-SEQ. 011009PK 972620 MOVE "COMS SEND" TO TLF-TYPE. 011009PK 972640 MOVE WTL-FORMAT-CDO TO TLF-FORMAT. 011009PK 972660 MOVE 1 TO WTL-TEXT-INDEX. 011009PK 972700 011009PK 972710 9804-WRITE-CDO-LOOP. 011009PK 972720 COMPUTE WTL-TEXT-LENGTH = 011009PK 972730 CDO-MSG-SIZE - WTL-TEXT-INDEX + 1. 011009PK 972740 IF WTL-TEXT-LENGTH > WTL-MAX-TEXT-SIZE 011009PK 972750 MOVE WTL-MAX-TEXT-SIZE TO WTL-TEXT-LENGTH. 011009PK 972760 011009PK 972770 UNSTRING FCM-COMS-MSG INTO TLF-TEXT FOR WTL-TEXT-LENGTH 020109PK 972780 POINTER WTL-TEXT-INDEX. 011009PK 972790 COMPUTE TLF-REC-SIZE = WTL-TEXT-LENGTH + WTL-HEADER-SIZE. 011009PK 972800 PERFORM 9800-WRITE-TRAFFIC-LOG THRU 9800-EXIT. 011009PK 972810 ADD WTL-TEXT-LENGTH TO WTL-TEXT-INDEX. 011009PK 972820 IF WTL-TEXT-INDEX NOT > CDO-MSG-SIZE 011009PK 972830 ADD 1 TO TLF-SEQ 011009PK 972840 GO TO 9804-WRITE-CDO-LOOP. 011009PK 972850 011009PK 972860 9804-EXIT. 011009PK 972870 EXIT. 011009PK 973000 973020****************************************************************** 973040 9806-LOG-DISPLAY. 973060* DISPLAYS, THEN LOGS THE MESSAGE IN WM-DISPLAY. 973080 973100 DISPLAY WM-DISPLAY. 973120 973140 IF WTL-LOGGING = W-TRUE 973160 MOVE SPACE TO TLF-HEADER 973220 MOVE 1 TO TLF-REC-SIZE 973240 STRING WM-DISPLAY DELIMITED BY SIZE INTO TLF-HEADER 973260 POINTER TLF-REC-SIZE 973300 COMPUTE TLF-REC-SIZE = TLF-REC-SIZE - 1 + WTL-PREFIX-SIZE 973320 MOVE "DISPLAY" TO TLF-TYPE 973330 MOVE ZERO TO TLF-SEQ 011009PK 973340 MOVE WTL-FORMAT-DISPLAY TO TLF-FORMAT 973360 PERFORM 9800-WRITE-TRAFFIC-LOG THRU 9800-EXIT. 973380 973400 9806-EXIT. 973420 EXIT. 973500 973520****************************************************************** 973540 9807-MARK-TRAFFIC-LOG. 973560* OPENS AND CLOSES THE TLF TO UPDATE THE DISK HEADER EOF. 973580* THIS ALLOWS THE TRAFFIC/DUMP PROGRAM TO SEE ALL RECORDS UP 973600* TO THE TIME OF THE MARK. 973620 973640 CLOSE TLF-TRAFFIC-LOG WITH SAVE. 973660 OPEN EXTEND TLF-TRAFFIC-LOG. 973680 973700 9807-EXIT. 973720 EXIT. 978000 978020****************************************************************** 978040 9828-SECTION SECTION. 978060****************************************************************** 978080 9828-OPEN-TRAFFIC-LOG. 978100* OPENS THE TLF-TRAFFIC-LOG FILE AND WRITES AN INITIAL RECORD. 978120 978140 MOVE WDA-SYS-DATE TO WTL-TITLE-DATE. 978160 CHANGE ATTRIBUTE TITLE OF TLF-TRAFFIC-LOG TO WTL-LOG-TITLE. 978180 OPEN AVAILABLE TLF-TRAFFIC-LOG. 978200 IF WTL-FILE-STATUS = ZERO 978205 CLOSE TLF-TRAFFIC-LOG 978210 OPEN EXTEND TLF-TRAFFIC-LOG 978215 ELSE 978220 OPEN OUTPUT TLF-TRAFFIC-LOG. 978230 978240 IF WTL-FILE-STATUS NOT = ZERO 978250 MOVE SPACE TO WM-TEXT 978260 STRING "Cannot open TLF (9828): ", WTL-FILE-STATUS 978270 DELIMITED BY SIZE INTO WM-TEXT 978280 DISPLAY WM-DISPLAY. 978300 978320 MOVE SPACE TO TLF-REC. 978340 MOVE "OPEN LOG" TO TLF-TYPE. 978360 MOVE ALL "+" TO TLF-HEADER. 978380 MOVE WTL-HEADER-SIZE TO TLF-REC-SIZE. 978390 MOVE WTL-FORMAT-DEFAULT TO TLF-FORMAT. 978400 PERFORM 9800-WRITE-TRAFFIC-LOG THRU 9800-EXIT. 978420 978440 9828-EXIT. 978460 EXIT. 978480 978500****************************************************************** 978520 9829-CLOSE-TRAFFIC-LOG. 978540* WRITES A FINAL RECORD AND CLOSES THE TLF-TRAFFIC-LOG FILE. 978560 978580 MOVE SPACE TO TLF-REC. 978600 MOVE "CLOSE LOG" TO TLF-TYPE. 978620 MOVE ALL "-" TO TLF-HEADER. 978640 MOVE WTL-HEADER-SIZE TO TLF-REC-SIZE. 978650 MOVE WTL-FORMAT-DEFAULT TO TLF-FORMAT. 978660 PERFORM 9800-WRITE-TRAFFIC-LOG THRU 9800-EXIT. 978680 978682 IF WTL-CLOSE-FINAL = W-TRUE 978684 CLOSE TLF-TRAFFIC-LOG WITH CRUNCH 978686 MOVE W-FALSE TO WTL-CLOSE-FINAL 978688 ELSE 978700 CLOSE TLF-TRAFFIC-LOG WITH SAVE. 978710 978720 IF WTL-FILE-STATUS NOT = ZERO 978730 MOVE SPACE TO WM-TEXT 978740 STRING "Cannot close TLF (9829): ", WTL-FILE-STATUS 978750 DELIMITED BY SIZE INTO WM-TEXT 978760 DISPLAY WM-DISPLAY. 978780 978800 9829-EXIT. 978820 EXIT. 990000/ 990020****************************************************************** 990040 Q100-SECTION SECTION. 990060****************************************************************** 990080* COPY "(PAUL)COPY/UTIL/DATE/PROCEDURE ON OPS". 021101PK 990090******************************************************************021101PK 990100 Q100-KDAY. 021101PK 990110* CONVERTS THE GREGORIAN DATE (YYYYMMDD) IN WDA-IN-DATE TO 021101PK 990120* A JULIAN DAY NUMBER, LEAVING THE RESULT IN WDA-JULIAN. 021101PK 990130* ADAPTED FROM CACM ALGORITHM 199, R.G. TANTZEN, COMM. ACM., 021101PK 990140* VOL.8, AUG.1963, P.444. 021101PK 990150* NOTE THAT THE DIVISIONS MUST BE DONE IN SEPARATE STATEMENTS 021101PK 990160* TO GET INTEGER TRUNCATION. 021101PK 990170 021101PK 990180 IF WDA-IN-YY < 100 021101PK 990190 PERFORM Q140-DEDUCE-CENTURY THRU Q140-EXIT 021101PK 990200 COMPUTE WDA-WORK-YY = WDA-OUT-YY - WDA-YEAR-BASIS 021101PK 990210 ELSE 021101PK 990220 COMPUTE WDA-WORK-YY = WDA-IN-YY - WDA-YEAR-BASIS. 021101PK 990230 021101PK 990240 IF WDA-IN-MM > 2 021101PK 990250 COMPUTE WDA-WORK-MM = WDA-IN-MM - 3 021101PK 990260 ELSE 021101PK 990270 COMPUTE WDA-WORK-MM = WDA-IN-MM + 9 021101PK 990280 SUBTRACT 1 FROM WDA-WORK-YY. 021101PK 990290 021101PK 990300 COMPUTE WDA-JULIAN = (1461 * WDA-WORK-YY) / 4. 021101PK 990310 COMPUTE WDA-JULIAN = 021101PK 990320 WDA-JULIAN + (153 * WDA-WORK-MM + 2) / 5. 021101PK 990330 ADD WDA-IN-DD TO WDA-JULIAN. 021101PK 990340 021101PK 990350 Q100-EXIT. 021101PK 990360 EXIT. 021101PK 990370 021101PK 990380******************************************************************021101PK 990390 Q102-KDATE. 021101PK 990400* CONVERTS THE JULIAN DAY NUMBER IN WDA-JULIAN TO A GREGORIAN 021101PK 990410* DATE (YYYYMMDD), LEAVING THE RESULT IN WDA-OUT-DATE. 021101PK 990420* ADAPTED FROM CACM ALGORITHM 199, R.G. TANTZEN, COMM. ACM., 021101PK 990430* VOL.8, AUG.1963, P.444. 021101PK 990440 021101PK 990450 COMPUTE WDA-WORK-YY = (4 * WDA-JULIAN - 1) / 1461. 021101PK 990460 COMPUTE WDA-WORK-DAY = 021101PK 990470 (4 * WDA-JULIAN - 1 - 1461 * WDA-WORK-YY + 4) / 4. 021101PK 990480 COMPUTE WDA-WORK-MM = (5 * WDA-WORK-DAY - 3) / 153. 021101PK 990490 COMPUTE WDA-OUT-DD = 021101PK 990500 (5 * WDA-WORK-DAY - 3 - 153 * WDA-WORK-MM + 5) / 5. 021101PK 990510 IF WDA-WORK-MM < 10 021101PK 990520 COMPUTE WDA-OUT-MM = WDA-WORK-MM + 3 021101PK 990530 COMPUTE WDA-OUT-YY = WDA-WORK-YY + WDA-YEAR-BASIS 021101PK 990540 ELSE 021101PK 990550 COMPUTE WDA-OUT-MM = WDA-WORK-MM - 9 021101PK 990560 COMPUTE WDA-OUT-YY = WDA-WORK-YY + WDA-YEAR-BASIS + 1. 021101PK 990570 021101PK 990580 Q102-EXIT. 021101PK 990590 EXIT. 021101PK 990600 021101PK 990610******************************************************************021101PK 990620 Q110-READ-SYSTEM-DATE. 021101PK 990630* READS THE SYSTEM DATE INTO WDA-SYS-DATE. 021101PK 990640 021101PK 990650 ACCEPT WDA-SYS-DATE FROM DATE YYYYMMDD. 021101PK 990690 021101PK 990700 Q110-EXIT. 021101PK 990710 EXIT. 021101PK 990720 021101PK 990730******************************************************************021101PK 990740 Q112-READ-SYSTEM-TIME. 021101PK 990750* READS THE SYSTEM TIME INTO WDA-SYS-TIME. 021101PK 990760 021101PK 990770 ACCEPT WDA-SYS-TIME FROM TIME. 021101PK 990780 021101PK 990790 Q112-EXIT. 021101PK 990800 EXIT. 021101PK 990810 021101PK 990820******************************************************************021101PK 990830 Q114-READ-SYSTEM-TIMESTAMP. 021101PK 990840* READS THE SYSTEM DATE AND TIME, FORMATTING A TIMESTAMP IN 021101PK 990850* SECONDS SINCE 00:00:00 ON 1970-01-01 IN WDA-TIMESTAMP-OUT. 021101PK 990860 021101PK 990870 PERFORM Q110-READ-SYSTEM-DATE THRU Q110-EXIT. 021101PK 990880 PERFORM Q112-READ-SYSTEM-TIME THRU Q112-EXIT. 021101PK 990890 MOVE WDA-SYS-TIME TO WDA-TIME-IN. 021101PK 990900 MOVE WDA-SYS-DATE TO WDA-IN-DATE. 021101PK 990910 PERFORM Q162-DATETIME-TIMESTAMP THRU Q162-EXIT. 021101PK 990920 021101PK 990930 Q114-EXIT. 021101PK 990940 EXIT. 021101PK 990950 021101PK 990960******************************************************************021101PK 990970 Q116-READ-SYSTEM-TIMER. 021101PK 990980* READS THE SYSTEM TIMER (2.4 MICROSEC CLOCK) AND COMPUTES 021101PK 990990* WDA-SYS-TIME-OF-DAY (IN SECONDS) AND WDA-SYS-TIMESTAMP 021101PK 991000* (SECONDS SINCE 1970-01-01). ASSUMES TIMESTAMP OF THE PRIOR 021101PK 991010* MIDNIGHT HAS BEEN SET UP IN WDA-BOD-TIMESTAMP. THIS IS MUCH 021101PK 991020* FASTER AND MORE PRECISE THAN CALLING Q114. 021101PK 991030 021101PK 991040 ACCEPT WDA-SYS-TIMER FROM TIMER. 021101PK 991050 COMPUTE WDA-SYS-TOD = WDA-SYS-TIMER * WDA-SEC-PER-TICK. 021101PK 991060 COMPUTE WDA-SYS-TIMESTAMP = WDA-SYS-TOD + WDA-BOD-TIMESTAMP. 021101PK 991070 021101PK 991080 Q116-EXIT. 021101PK 991090 EXIT. 021101PK 991100 021101PK 991110******************************************************************021101PK 991120 Q120-INCREMENT-DATE. 021101PK 991130* ADDS WDA-INCREMENT DAYS TO THE GREGORIAN DATE (YYMMDD) IN 021101PK 991140* WDA-IN-DATE, LEAVING THE RESULTANT GREGORIAN DATE IN 021101PK 991150* WDA-OUT-DATE. 021101PK 991160 021101PK 991170 PERFORM Q100-KDAY THRU Q100-EXIT. 021101PK 991180 ADD WDA-INCREMENT TO WDA-JULIAN. 021101PK 991190 PERFORM Q102-KDATE THRU Q102-EXIT. 021101PK 991200 021101PK 991210 Q120-EXIT. 021101PK 991220 EXIT. 021101PK 991230 021101PK 991240******************************************************************021101PK 991250 Q122-DELTA-DATE. 021101PK 991260* COMPUTES THE NUMBER OF DAYS BETWEEN TWO GREGORIAN DATES. 021101PK 991270* ON ENTRY, ONE DATE IS IN WDA-IN-DATE AND THE OTHER IS IN 021101PK 991280* WDA-OUT-DATE. ON EXIT, THE NUMBER OF DAYS BETWEEN THE 021101PK 991290* TWO DATES IS STORED IN WDA-INCREMENT. IF WDA-IN-DATE IS 021101PK 991300* LATER THAN WDA-OUT-DATE, WDA-INCREMENT WILL BE NEGATIVE. 021101PK 991310 021101PK 991320 MOVE WDA-IN-DATE TO WDA-SAVE-DATE. 021101PK 991330 MOVE WDA-OUT-DATE TO WDA-IN-DATE. 021101PK 991340 PERFORM Q100-KDAY THRU Q100-EXIT. 021101PK 991350 MOVE WDA-JULIAN TO WDA-INCREMENT. 021101PK 991360 MOVE WDA-SAVE-DATE TO WDA-IN-DATE. 021101PK 991370 PERFORM Q100-KDAY THRU Q100-EXIT. 021101PK 991380 SUBTRACT WDA-JULIAN FROM WDA-INCREMENT. 021101PK 991390 021101PK 991400 Q122-EXIT. 021101PK 991410 EXIT. 021101PK 991420 021101PK 991430******************************************************************021101PK 991440 Q124-WEEK-DAY. 021101PK 991450* COMPUTES THE DAY-OF-WEEK (DOW) FROM WDA-IN-DATE (YYYYMMDD) 021101PK 991460* AND PLACES THE RESULT IN WDA-WEEK-DAY (1=SUN, 7=SAT). 021101PK 991470 021101PK 991480 PERFORM Q100-KDAY THRU Q100-EXIT. 021101PK 991490 COMPUTE WDA-WORK-DAY = WDA-JULIAN + 3. 021101PK 991500 DIVIDE WDA-WORK-DAY BY 7 GIVING WDA-WORK-DAY 021101PK 991510 REMAINDER WDA-WEEK-DAY. 021101PK 991520 ADD 1 TO WDA-WEEK-DAY. 021101PK 991530 021101PK 991540 Q124-EXIT. 021101PK 991550 EXIT. 021101PK 991790 021101PK 991800******************************************************************021101PK 991810 Q132-MMDDYY-YYYYMMDD. 021101PK 991820* CONVERTS THE GREGORIAN DATE IN WDA-IN-DATE FROM MMDDYY TO 021101PK 991830* YYYYMMDD FORMAT, LEAVING THE RESULT IN WDA-OUT-DATE. 021101PK 991840 021101PK 991850 IF WDA-IN-DATE = ZERO 021101PK 991860 MOVE ZERO TO WDA-OUT-DATE 021101PK 991870 GO TO Q132-EXIT. 021101PK 991880 021101PK 991890 MOVE WDA-IN-DATE TO WDA-SAVE-DATE. 021101PK 991900 MOVE WDA-SAVE-YY TO WDA-IN-MM. 021101PK 991910 MOVE WDA-SAVE-MM TO WDA-IN-DD. 021101PK 991920 MOVE WDA-SAVE-DD TO WDA-IN-YY. 021101PK 991930 PERFORM Q140-DEDUCE-CENTURY THRU Q140-EXIT. 021101PK 991940 MOVE WDA-SAVE-DATE TO WDA-IN-DATE. 021101PK 991950 021101PK 991960 Q132-EXIT. 021101PK 991970 EXIT. 021101PK 991980 021101PK 991990******************************************************************021101PK 992000 Q134-VALIDATE-DATE. 021101PK 992010* EDITS THE DATE IN WDA-IN-DATE FOR VALID MONTH AND DAY 021101PK 992020* VALUES. IF THE DATE IS VALID, WDA-VALID-DATE WILL HAVE A 021101PK 992030* VALUE OF 1, OTHERWISE IT WILL HAVE A VALUE OF ZERO. 021101PK 992040* AN INPUT VALUE OF ZERO IS CONSIDERED TO BE A VALID DATE. 021101PK 992050 021101PK 992060 IF WDA-IN-DATE = ZERO 021101PK 992070 MOVE 1 TO WDA-VALID-DATE 021101PK 992080 GO TO Q134-EXIT 021101PK 992090 ELSE 021101PK 992100 IF WDA-IN-DATE NOT < WDA-MIN-DATE AND 021101PK 992110 WDA-IN-DATE NOT > WDA-MAX-DATE 021101PK 992120 IF WDA-IN-MM > ZERO 021101PK 992130 IF WDA-IN-MM NOT > 12 021101PK 992140 IF WDA-IN-DD > ZERO 021101PK 992150 IF WDA-IN-DD NOT > 28 021101PK 992160 MOVE 1 TO WDA-VALID-DATE 021101PK 992170 GO TO Q134-EXIT 021101PK 992180 ELSE 021101PK 992190 PERFORM Q100-KDAY THRU Q100-EXIT 021101PK 992200 PERFORM Q102-KDATE THRU Q102-EXIT 021101PK 992210 IF WDA-IN-DATE = WDA-OUT-DATE 021101PK 992220 MOVE 1 TO WDA-VALID-DATE 021101PK 992230 GO TO Q134-EXIT. 021101PK 992240 021101PK 992250 MOVE ZERO TO WDA-VALID-DATE. 021101PK 992260 021101PK 992270 Q134-EXIT. 021101PK 992280 EXIT. 021101PK 992890 021101PK 992900******************************************************************021101PK 992910 Q137-NORMALIZE-MONDAY. 021101PK 992920* NORMALIZES THE DATE IN WDA-IN-DATE TO A MONDAY DATE, LEAVING 021101PK 992930* THE RESULT IN WDA-OUT-DATE. IF THE INPUT DATE IS MONDAY, 021101PK 992940* THEN THAT DATE IS RETURNED. OTHERWISE, THE PRIOR MONDAY 021101PK 992950* DATE IS RETURNED. 021101PK 992980 021101PK 992990 PERFORM Q124-WEEK-DAY THRU Q124-EXIT. 021101PK 993000 IF WDA-WEEK-DAY = WDA-MONDAY 021101PK 993010 MOVE WDA-IN-DATE TO WDA-OUT-DATE 021101PK 993020 GO TO Q137-EXIT. 021101PK 993030 021101PK 993040 IF WDA-WEEK-DAY = WDA-SUNDAY 021101PK 993050 MOVE -6 TO WDA-INCREMENT 021101PK 993060 ELSE 021101PK 993070 COMPUTE WDA-INCREMENT = WDA-MONDAY - WDA-WEEK-DAY. 021101PK 993080 021101PK 993090 PERFORM Q120-INCREMENT-DATE THRU Q120-EXIT. 021101PK 993100 021101PK 993110 Q137-EXIT. 021101PK 993120 EXIT. 021101PK 993130 021101PK 993140******************************************************************021101PK 993150 Q140-DEDUCE-CENTURY. 021101PK 993160* DETERMINES THE CENTURY FOR THE YYMMDD DATE IN WDA-IN-DATE, 021101PK 993170* LEAVING THE RESULT IN WDA-OUT-DATE. 021101PK 993180 021101PK 993190 MOVE WDA-IN-DATE TO WDA-OUT-DATE. 021101PK 993200 IF WDA-IN-YY < 100 021101PK 993210 ADD WDA-YEAR-BASIS TO WDA-OUT-YY 021101PK 993220 PERFORM Q110-READ-SYSTEM-DATE THRU Q110-EXIT 021101PK 993230 COMPUTE WDA-INCREMENT = WDA-SYS-YY - WDA-OUT-YY 021101PK 993240 IF WDA-INCREMENT > WDA-CENTURY-BIAS 021101PK 993250 ADD 100 TO WDA-OUT-YY. 021101PK 993260 021101PK 993270 Q140-EXIT. 021101PK 993280 EXIT. 021101PK 993290 021101PK 993300******************************************************************021101PK 993310 Q142-DEDUCE-YEAR. 021101PK 993320* GIVEN A 4-DIGIT DATE IN 0000MMDD FORMAT IN WDA-IN-DATE, THIS 021101PK 993330* PROCEDURE DETERMINES THE YEAR, AND RETURNS A FULL YYYYMMDD 021101PK 993340* DATE IN WDA-OUT-DATE. 021101PK 993350 021101PK 993360 PERFORM Q110-READ-SYSTEM-DATE THRU Q110-EXIT. 021101PK 993370 MOVE WDA-IN-DATE TO WDA-OUT-DATE. 021101PK 993380 IF WDA-SYS-MM > WDA-IN-MM 021101PK 993390 IF WDA-SYS-MM - WDA-IN-MM < 7 021101PK 993400 MOVE WDA-SYS-YY TO WDA-OUT-YY 021101PK 993410 ELSE 021101PK 993420 COMPUTE WDA-OUT-YY = WDA-SYS-YY + 1 021101PK 993430 ELSE 021101PK 993440 IF WDA-IN-MM - WDA-SYS-MM < 7 021101PK 993450 MOVE WDA-SYS-YY TO WDA-OUT-YY 021101PK 993460 ELSE 021101PK 993470 COMPUTE WDA-OUT-YY = WDA-SYS-YY - 1. 021101PK 993480 021101PK 993490 Q142-EXIT. 021101PK 993500 EXIT. 021101PK 993790 021101PK 993800******************************************************************021101PK 993810 Q150-FORMAT-MMDDYYYY. 021101PK 993820* FORMATS THE DATE IN WDA-IN-DATE TO WDA-MM-DD-YYYY IN THE 021101PK 993830* FORMAT MM/DD/YYYY. 021101PK 993840 021101PK 993850 MOVE WDA-IN-MM TO WDA-MDY-MM. 021101PK 993860 MOVE WDA-IN-DD TO WDA-MDY-DD. 021101PK 993870 MOVE WDA-IN-YY TO WDA-MDY-YYYY. 021101PK 993880 MOVE "/" TO WDA-MDY-D1, WDA-MDY-D2. 021101PK 993890 021101PK 993900 Q150-EXIT. 021101PK 993910 EXIT. 021101PK 993920 021101PK 993930******************************************************************021101PK 993940 Q151-FORMAT-YYYYMMDD. 021101PK 993950* FORMATS THE DATE IN WDA-IN-DATE TO WDA-YYYY-MM-DD IN THE 021101PK 993960* FORMAT YYYY-MM-DD (ISO 8601:1998 FORMAT). 021101PK 993970 021101PK 993980 MOVE WDA-IN-YY TO WDA-YMD-YYYY. 021101PK 993990 MOVE WDA-IN-MM TO WDA-YMD-MM. 021101PK 994000 MOVE WDA-IN-DD TO WDA-YMD-DD. 021101PK 994010 MOVE "-" TO WDA-YMD-D1, WDA-YMD-D2. 021101PK 994020 021101PK 994030 Q151-EXIT. 021101PK 994040 EXIT. 021101PK 994050 021101PK 994060******************************************************************021101PK 994070 Q152-FORMAT-DDMMMYYYY. 021101PK 994080* FORMATS THE DATE IN WDA-IN-DATE TO WDA-DD-MMM-YYYY IN THE 021101PK 994090* FORMAT DD MMM YYYY. 021101PK 994100 021101PK 994110 MOVE WDA-IN-DD TO WDA-DMY-DD. 021101PK 994120 MOVE WDA-IN-YY TO WDA-DMY-YYYY. 021101PK 994130 MOVE SPACE TO WDA-DMY-D1, WDA-DMY-D2. 021101PK 994140 IF WDA-IN-MM < 1 021101PK 994150 MOVE "*0*" TO WDA-DMY-MMM 021101PK 994160 ELSE IF WDA-IN-MM > 12 021101PK 994170 MOVE WDA-IN-MM TO WDA-DMY-MMM 021101PK 994180 ELSE 021101PK 994190 MOVE WDA-MONTH-NAME-3 (WDA-IN-MM) TO WDA-DMY-MMM. 021101PK 994200 021101PK 994210 Q152-EXIT. 021101PK 994220 EXIT. 021101PK 994230 021101PK 994240******************************************************************021101PK 994250 Q160-TIME-6-TIMESTAMP. 021101PK 994260* CONVERTS WDA-TIME-6-IN TO A TIMESTAMP IN SECONDS SINCE 021101PK 994270* 00:00:00 ON 1970-01-01, LEAVING RESULT IN WDA-TIMESTAMP-OUT. 021101PK 994280 021101PK 994290 MOVE ZERO TO WDA-TIME-6-DATE, WDA-TIME-6-TIME. 021101PK 994300 MOVE WDA-TIME-6-IN TO WDA-TIME-6-DATE [47:15:16]. 021101PK 994310 MOVE WDA-TIME-6-IN TO WDA-TIME-6-TIME [31:31:32]. 021101PK 994320 DIVIDE WDA-TIME-6-DATE BY 1000 GIVING WDA-TIME-6-YEAR 021101PK 994330 REMAINDER WDA-TIME-6-DAY. 021101PK 994340 MOVE 19691231 TO WDA-IN-DATE. 021101PK 994350 ADD WDA-TIME-6-YEAR TO WDA-IN-YY. 021101PK 994360 PERFORM Q100-KDAY THRU Q100-EXIT. 021101PK 994370 ADD WDA-JULIAN TO WDA-TIME-6-DAY. 021101PK 994380 MOVE 19700101 TO WDA-IN-DATE. 021101PK 994390 PERFORM Q100-KDAY THRU Q100-EXIT. 021101PK 994400 SUBTRACT WDA-JULIAN FROM WDA-TIME-6-DAY. 021101PK 994410 021101PK 994420 COMPUTE WDA-TIMESTAMP-OUT = 021101PK 994430 (WDA-TIME-6-DAY * WDA-SEC-PER-DAY) + 021101PK 994440 (WDA-TIME-6-TIME * WDA-TIME-6-FACTOR). 021101PK 994450 021101PK 994460 Q160-EXIT. 021101PK 994470 EXIT. 021101PK 994480 021101PK 994490******************************************************************021101PK 994500 Q162-DATETIME-TIMESTAMP. 021101PK 994510* CONVERTS WDA-IN-DATE AND WDA-TIME-IN TO A TIMESTAMP IN 021101PK 994520* SECONDS SINCE 00:00:00 ON 1970-01-01 IN WDA-TIMESTAMP-OUT. 021101PK 994530 021101PK 994540 MOVE 19700101 TO WDA-OUT-DATE. 021101PK 994550 PERFORM Q122-DELTA-DATE THRU Q122-EXIT. 021101PK 994560 COMPUTE WDA-TIMESTAMP-OUT = 021101PK 994570 ((WDA-TIME-IN-HOUR - (WDA-INCREMENT * 24)) * 60 + 021101PK 994580 WDA-TIME-IN-MINUTE) * 60 + WDA-TIME-IN-SECOND. 021101PK 994590 021101PK 994600 Q162-EXIT. 021101PK 994610 EXIT. 021101PK 994620 021101PK 994630******************************************************************021101PK 994640 Q163-TIMESTAMP-DATETIME. 021101PK 994650* CONVERTS THE TIMESTAMP (SINCE 00:00:00 ON 1970-01-01) IN 021101PK 994660* WDA-TIMESTAMP-IN TO WDA-OUT-DATE AND WDA-TIME-OUT. 021101PK 994670 021101PK 994680 DIVIDE WDA-TIMESTAMP-IN BY 60 GIVING WDA-TIME-6-DATE 021101PK 994690 REMAINDER WDA-TIME-OUT-SECOND. 021101PK 994700 DIVIDE WDA-TIME-6-DATE BY 60 GIVING WDA-TIME-6-DATE 021101PK 994710 REMAINDER WDA-TIME-OUT-MINUTE. 021101PK 994720 DIVIDE WDA-TIME-6-DATE BY 24 GIVING WDA-INCREMENT 021101PK 994730 REMAINDER WDA-TIME-OUT-HOUR. 021101PK 994740 MOVE 19700101 TO WDA-IN-DATE. 021101PK 994750 PERFORM Q120-INCREMENT-DATE THRU Q120-EXIT. 021101PK 994760 021101PK 994770 Q163-EXIT. 021101PK 994780 EXIT. 021101PK