|
midrange.com
Here is the source for the RPGILE program IT IS NOT CORRECT I had to use
cut & paste to get it into this message so it might look a little odd
Sorry
*************** Beginning of data
*********************************************************
0001.00 F**************************************************************/
0002.00 F* */
0003.00 F* Program Name: AP724R */
0004.00 F* Title : CHILD CASES LETTERS (BUILD LETTERS FILE) */
0005.00 F* Author : JOHN FORTWENGLER */
0006.00 F* REDESIGN : */
0007.00 F* Program Modification History */
0008.00 F* Code Date Pgmr Description */
0009.00 F* Mxxx xx/xx/xx xxx Change explanation.... */
0010.00 F* 01/07/04 JAF START THE DESIGN OF THIS REPORT */
0011.00 F* 02/29/04 JAF END OF THE DESIGN OF THIS REPORT */
0012.00 F* */
0013.00 ****************************************************************
0014.00 ** DEFINITIONS--USED IN PROGRAM
0015.00 **
0016.00 *****************************************************************
0017.00 **
0018.00 ** APPEALS HISTORY FILE CAUSE# & NATURE OF CASE
0019.00 **
FMT FX
FFilename++IPEASF.....L.....A.Device+.Keywords+++++++++++++++++++++++++++++Comments++
0020.00 FAPHISTP IF E K DISK
0021.00 **
0022.00 ** CLERK ATTORNEY FILE PRE FNAM MNAM LNAM ADR CTY ST ZIP
0023.00 ** CAT PRE & LNAM = SALUTE
0024.00 **
0025.00 FCLATTRNP IF E K DISK
0026.00 **
0027.00 ** CLERK ATTORNEY FILE LINK TO CLATTRNP
0028.00 **
0029.00 FCLATTNP IF E K DISK
0030.00 **
0031.00 ** CLERK ATTORNEY LITITGANT FILE CAPTION NAMES
0032.00 **
0033.00 FCLLITGP IF E K DISK
0034.00 **
0035.00 ** CHILD CASE LETTERS FILE (USED IN WORD TO MAKE LETTERS)
0036.00 **
0037.00 FAP724PR UF A E K DISK
0038.00 **
0039.00 **
0040.00 ** CHILD CASE LETTERS FILE (USED TO SELECT WHITCH RECORDS TO
PRINT)
0041.00 **
0042.00 FAP724PO IF A E K DISK
0043.00 F RENAME(AP724PF:CKREC)
0044.00 **
0045.00 ** CHILD CASE CODES FROM NATURE OF CASE
0046.00 **
0047.00 FAPCKIDP IT F 50 DISK
0048.00 D$FirstCap PR 67A
0049.00 DFC#Text 67A const
0049.01 DWrk#Text S 67A
0049.02 DWrk#Char S 1A
0049.03 DIdx S 3P 0
0050.00 D KID S 5 DIM(10) FROMFILE(APCKIDP)
PERRCD(10)
0051.00 **
0052.00 D TABNBR S 2 0 DIM(12) CTDATA PERRCD(2)
ASCEND MTH #S & NAMES
0053.00 D TABNAM S 9 DIM(12) ALT(TABNBR)
0054.00 *****************************************************************
0055.00 ***
0056.00 D WRKSTG DS
FMT D
DName+++++++++++ETDsFrom+++To/L+++IDc.Keywords+++++++++++++++++++++++++++++Comments++++++++++
0057.00 D DATIN 1 8 0 INZ
0058.00 D DATOUT 9 16 0 INZ
0059.00 D FMTIN 17 17 INZ
0060.00 D FMTOUT 18 18 INZ
0061.00 ***
0062.00 D DS
0063.00 D TODAY 1 7 0 INZ
0064.00 D THISYR 1 4 0
0065.00 D THISDY 5 7 0
0066.00 *REPORT DATE
0067.00 D DS
0068.00 D WSYEAR 1 4 0 INZ
0069.00 D WSYY 3 4 0
0070.00
**************************************************************************
0071.00 **
0072.00 *WORKING FIELDS NUMERIC OF DIST & COURT ABOVE
0073.00 D DS
0074.00 D DC 1 6
0075.00 D DD 1 3 INZ('D01')
0076.00 D CD 4 6 INZ('C01')
FMT * *. 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+...
7 ...+... 8
0077.00 **
0078.00 D DS
0079.00 D WKASSN 1 8 0 INZ
0080.00 D ASSNMM 1 2 0
0081.00 D ASSNDD 3 4 0
0082.00 D ASSNYY 5 8 0
0083.00 **
0084.00 ** REPORT DATE BEGIN RANGE
0085.00 D DS
0086.00 D BDATE 1 7 0 INZ
0087.00 D BYEAR 1 4 0
0088.00 D BDAY 5 7 0
0089.00 ** REPORT DATE END RANGE
0090.00 D DS
0091.00 D EDATE 1 7 0 INZ
0092.00 D EYEAR 1 4 0
0093.00 D EDAY 5 7 0
0094.00 *** UPPER CASE TO LOWER CASE XLATE UC:LC
0095.00 *** LOWER CASE TO UPPER CASE XLATE LC:UC
0096.00 D UC C CONST('ABCDEFGHIJKLMNOPQRST-
Columns . . . : 6 100
0097.00 D UVWXYZ')
0098.00 D LC C CONST('abcdefghijklmnoporst-
0099.00 D uvwxyz')
0100.00 ***
0101.00 /* KEY LIST FOR CLERK MASTER FILE (TO GET CASE CAPTION)
0102.00 C KEY1 KLIST
0103.00 C KFLD HSCNTY
COUNTY
0104.00 C KFLD HSCORT
COURT TYPE
0105.00 C KFLD HSDIST
DISTRICT
0106.00 C KFLD HSDATE
DATE
0107.00 C KFLD HSCASE
CASE TYPE
0108.00 C KFLD HSSEQ#
SEQUENCE NUMB
0109.00 ***
0110.00 *** ATTORNEY KEY FOR CLATTRNP FILE
0111.00 ***
0112.00 C KEY2 KLIST
0113.00 C KFLD ATTRN#
ATTORNEY #
0114.00 C KFLD ATCNTY
ATTORNEY COUNTY
0115.00 C KFLD ATSUFX
ATTORNEY SUFX
0116.00 ***
FMT C
CL0N01Factor1+++++++Opcode&ExtFactor2+++++++Result++++++++Len++D+HiLoEq....Comments+++++++
0117.00 C *ENTRY PLIST
0118.00 C PARM STDTE8 8
0119.00 C PARM SPDTE8 8
0120.00 **
0121.00 C MOVEL STDTE8 BDTE8 8 0
0122.00 C MOVEL SPDTE8 EDTE8 8 0
0123.00 **
0124.00 **
0125.00 ****CONVERT TODAY'S DATE TO JULIAN
0126.00 C Z-ADD 0 DATOUT
0127.00 C MOVE '8' FMTIN
0128.00 C MOVE '7' FMTOUT
0129.00 C Z-ADD *DATE DATIN
File Date
0130.00 ***
0131.00 *** CALL DATE CONVERSION PGM WITH DATE TO CONVERT
0132.00 C CALL 'DATER '
0133.00 C PARM DATIN
0134.00 C PARM DATOUT
0135.00 C PARM FMTIN
0136.00 C PARM FMTOUT
FMT C
CL0N01Factor1+++++++Opcode&ExtFactor2+++++++Result++++++++Len++D+HiLoEq....Comments++++++++++++
0137.00 C Z-ADD DATOUT TODAY 7 0
0138.00 ***
0139.00 C Z-ADD 0 DATOUT
0140.00 C MOVE '8' FMTIN
0141.00 C MOVE '7' FMTOUT
0142.00 C Z-ADD BDTE8 DATIN
File Date
0143.00 ***
0144.00 *** CALL DATE CONVERSION PGM WITH DATE TO CONVERT
0145.00 C CALL 'DATER '
0146.00 C PARM DATIN
0147.00 C PARM DATOUT
0148.00 C PARM FMTIN
0149.00 C PARM FMTOUT
0150.00 C Z-ADD DATOUT BDATE
0151.00 ***
0152.00 C Z-ADD 0 DATOUT
0153.00 C MOVE '8' FMTIN
0154.00 C MOVE '7' FMTOUT
0155.00 C Z-ADD EDTE8 DATIN
File Date
0156.00 ***
FMT * *. 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+...
7 ...+... 8 .
0157.00 *** CALL DATE CONVERSION PGM WITH DATE TO CONVERT
0158.00 C CALL 'DATER '
0159.00 C PARM DATIN
0160.00 C PARM DATOUT
0161.00 C PARM FMTIN
0162.00 C PARM FMTOUT
0163.00 C Z-ADD DATOUT EDATE
0164.00 ***
0165.00 C MOVE EYEAR EYRA 4
0166.00 **
0167.00 C EXSR $LEAP
0168.00 ***
0169.00 * ****************************
0170.00 * MAIN CALCULATIONS
0171.00 * ****************************
0172.00 ******************************************************************
0173.00 ***
0174.00 *** THIS IS THE ROUTINE THAT DOES THE READ OF THE HISTORY FILE
0175.00 ***
0176.00 ***
FMT C
CL0N01Factor1+++++++Opcode&ExtFactor2+++++++Result++++++++Len++D+HiLoEq....Commen
0177.00 C EXSR $SCRN1
0178.00 ******************************************************************
0179.00 ***
0180.00 *** END PROGRAM
0181.00 ***
0182.00 C ENDIT TAG
0183.00 C MOVE *ON *INLR
0184.00 ******************************************************************
0185.00 ** SCREEN 1 SUBROUTINE
0186.00 *****************************************************************
0187.00 C $SCRN1 BEGSR
0188.00 C SETOFF
2698
0189.00 C *LOVAL SETLL APHISTP
0190.00 C *IN98 DOWEQ *OFF
0191.00 C READ APHISTP
98
0192.00 ***
0193.00 C *IN98 CABEQ *ON DONE
0194.00 ***
0195.00 C HSAREC IFNE 'D'
0196.00 ***
FMT C
CL0N01Factor1+++++++Opcode&ExtFactor2+++++++Result++++++++Len++D+HiLoEq....Comments+++++++++++
0197.00 C HSNATE IFNE ' '
0198.00 C HSNATE LOOKUP KID
33
0199.00 C *IN33 IFEQ *ON
0200.00 ***
0201.00 C HSCORT IFEQ 'S'
0202.00 C MOVE HSCORT SVCORT 1
0203.00 C MOVE HSP1AS SVP1AS 7 0
0204.00 C MOVE 'A' HSCORT
0205.00 C END
0206.00 ***
0207.00 C Z-ADD 0 DATIN
0208.00 C MOVE '7' FMTIN
0209.00 C MOVE '8' FMTOUT
0210.00 C Z-ADD HSP1AS DATIN
File Date
0211.00 ***. CALL DATE CONVERSION PGM WITH DATE TO CONVERT
0212.00 C CALL 'DATER '
0213.00 C PARM DATIN
0214.00 C PARM DATOUT
0215.00 C PARM FMTIN
0216.00 C PARM FMTOUT
SEU==>
FMT C
CL0N01Factor1+++++++Opcode&ExtFactor2+++++++Result++++++++Len++D+HiLoEq....Comments++++++++++++
0217.00 C Z-ADD DATOUT WKASSN
0218.00 ***
0219.00 C HSP1AS IFEQ *ZEROS
0220.00 C KEY1 CHAIN AP724PO 26
0221.00 C *IN26 IFEQ *ON
NRF
0222.00 C BDATE ANDEQ *ZEROS
0223.00 C EDATE ANDEQ *ZEROS
0224.00 C EXSR $H2F
0225.00 C EXSR $A2F
0226.00 C EXSR $L2F
0227.00 C SVP1AS IFNE *ZEROS
0228.00 C MOVE SVCORT HSCORT
0229.00 C CLEAR SVP1AS
0230.00 C CLEAR SVCORT
0231.00 C END
0232.00 C MOVE TODAY CCLTDT 7 0
0233.00 C WRITE AP724PF
0234.00 C WRITE CKREC
0235.00 C EXSR $CLR
0236.00 C ELSE
*IN26 = ON
Columns . . . : 6 100 Browse
SEU==>
FMT C
CL0N01Factor1+++++++Opcode&ExtFactor2+++++++Result++++++++Len++D+HiLoEq....Comments++++
0237.00 C *IN26 IFEQ *OFF
FOUND
0238.00 C CCLTDT ANDGE BDATE
0239.00 C CCLTDT ANDLE EDATE
0240.00 C BDATE ANDNE *ZEROS
0241.00 C EDATE ANDNE *ZEROS
0242.00 C EXSR $H2F
0243.00 C EXSR $A2F
0244.00 C EXSR $L2F
0245.00 C SVP1AS IFNE *ZEROS
0246.00 C MOVE SVCORT HSCORT
0247.00 C CLEAR SVP1AS
0248.00 C CLEAR SVCORT
0249.00 C END
0250.00 ***
0251.00 *** DATE FOR LETTER IE SEPTEMBER 31, 2004
0252.00 ***
0253.00 C EXSR $LTRDT
0254.00 ***
0255.00 C*** WRITEAP724PF
0256.00 C EXSR $CLR
FMT C
CL0N01Factor1+++++++Opcode&ExtFactor2+++++++Result++++++++Len++D+HiLoEq....Comments++++++++++++
0257.00 C END
*IN26 = OFF
0258.00 C END
*IN26 = ON
0259.00 C END
0260.00 C 33 SETOFF 33
0261.00 C END
33END
0262.00 C END
HSNATC <> ' '
0263.00 C CLEAR SVP1AS
0264.00 C CLEAR SVCORT
0265.00 C END
NOT DELETED
0266.00 C EXSR $CLR
0267.00 C END
*IN98 ENDDO
0268.00 **
0269.00 C DONE TAG
0270.00 C #SCRN1 ENDSR
0271.00
**************************************************************************
0272.00 *** LEAP YEAR SUBROUTINE
0273.00 ************************************************************
0274.00 C $LEAP BEGSR
0275.00 ***
0276.00 *** DETERMINE IF YEAR OF REPORT IS A LEAP YEAR.
SEU==>
FMT * *. 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7
...+... 8 ...+... 9 ...+
0277.00 ***
0278.00 C BYEAR IFNE 2000
0279.00 C BYEAR DIV 4 HOLDB 1 0
0280.00 C MVR HOLDB
0281.00 C ELSE
0282.00 C BYEAR IFEQ 2000
0283.00 C DIV 4 HOLDB
0284.00 C MVR HOLDB
0285.00 C END
0286.00 C END
0287.00 C HOLDB IFEQ 0
0288.00 C MOVE 366 YDDD 3 0
0289.00 C END
0290.00 C EYEAR IFNE 2000
0291.00 C EYEAR DIV 4 HOLDE 1 0
0292.00 C MVR HOLDE
0293.00 C ELSE
0294.00 C EYEAR IFEQ 2000
0295.00 C DIV 4 HOLDE
0296.00 C MVR HOLDE
FMT C
CL0N01Factor1+++++++Opcode&ExtFactor2+++++++Result++++++++Len++D+HiLoEq....Co
0297.00 C END
0298.00 C END
0299.00 C HOLDE IFEQ 0
0300.00 C MOVE 366 YDDD 3 0
0301.00 C ELSE
0302.00 C MOVE 365 YDDD 3 0
0303.00 C END
0304.00 C #LEAP ENDSR
0305.00
**************************************************************************
0306.00 *** HISTORY FILE INFO TO CHILD CASE LETTERS FILE
0307.00
**************************************************************************
0308.00 C $H2F BEGSR
0309.00 C MOVE HSCNTY CCCNTY
0310.00 C MOVE HSCORT CCCORT
0311.00 C MOVE HSDIST CCDIST
0312.00 C MOVE HSDATE CCDATE
0313.00 C MOVE HSCASE CCCASE
0314.00 C MOVE HSSEQ# CCSEQ#
0315.00 C MOVE HSNATE CCNATE
0316.00 C MOVEL CCCNTY ACNTY 2
Columns . . . : 6 100 Browse
SEU==>
FMT C
CL0N01Factor1+++++++Opcode&ExtFactor2+++++++Result++++++++Len++D+HiLoEq....Comments++++++
0317.00 C MOVEL CCDIST ADIST 2
0318.00 C MOVEL CCDATE ADATE 4
0319.00 C MOVEL CCSEQ# ASEQ# 5
0320.00 C ACNTY CAT(P) CCCORT:0 TEMP21 19
0321.00 C CAT ADIST:0 TEMP21
0322.00 C CAT '-':0 TEMP21
0323.00 C CAT ADATE:0 TEMP21
0324.00 C CAT '-':0 TEMP21
0325.00 C CAT CCCASE:0 TEMP21
0326.00 C CAT '-':0 TEMP21
0327.00 C CAT ASEQ#:0 TEMP21
0328.00 C MOVEL TEMP21 CAUSE#
0329.00 C #H2F ENDSR
0330.00
**************************************************************************
0331.00 *** ATTORNEY FILE INFO TO CHILD CASE LETTERS FILE CLATTRNP
0332.00
**************************************************************************
0333.00 C $A2F begsr
0334.00 C KEY1 CHAIN CLATTNP 95
0335.00 C *IN95 ifeq *off
0337.00 C KEY2 CHAIN CLATTRNP 94
SEU==>
FMT C CL0N01Factor1+++++++Opcode&ExtFactor2+++++++Result++++++++Len++D+Hi
0338.00 C *IN94 ifeq *off
0340.00 C MOVEL SUFFIX CCSUFX
0342.00 C UC:LC XLATE CCSUFX:2 CCSUFX
0343.00 ***
0343.01 C MOVEL NPREFX CCPRFX
0343.02 C UC:LC XLATE CCPRFX:2 CCPRFX
0343.03 ***
0343.04 C MOVEL FNAME CCFNAM
0343.05 C UC:LC XLATE CCFNAM:2 CCFNAM
0343.06 ***
0343.07 C MOVEL MNAME CCMNAM
0343.08 C UC:LC XLATE CCMNAM:2 CCMNAM
0343.09 ***
0343.10 C MOVEL LNAME CCLNAM
0343.11 C UC:LC XLATE CCLNAM:2 CCLNAM
0343.12 ***
0343.13 C MOVEL NSUFFX CCNSFX
0343.14 C UC:LC XLATE CCNSFX:2 CCNSFX
0343.15 ***
0343.16 C MOVEL BADDR1 CCBAD1
FMT C
CL0N01Factor1+++++++Opcode&ExtFactor2+++++++Result++++++++Len++D+HiLoEq....Comm
0343.17 C UC:LC XLATE CCBAD1:2 CCBAD1
0343.18 c movel CCBAD1 Wrk#Text
0343.19 c Call '$FirstCap'
0343.20 c parm FC#Text 67
0343.21 c parm Wrk#Text
0343.22 c parm Wrk#Char
0343.23 c parm Idx
0343.24 C MOVEL Wrk#Text CCBAD1
0343.25 ***
0343.26 C MOVEL BADDR2 CCBAD2
0343.27 C UC:LC XLATE CCBAD2:2 CCBAD2
0343.28 c movel CCBAD2 Wrk#Text
0343.29 c Call '$FirstCap'
0343.30 c parm FC#Text
0343.31 c parm Wrk#Text
0343.32 c parm Wrk#Char
0343.33 c parm Idx
0343.35 C MOVEL Wrk#Text CCBAD2
0343.36 ***
0343.37 C MOVEL BCITY CCBCTY
FMT C
CL0N01Factor1+++++++Opcode&ExtFactor2+++++++Result++++++++Len++D+HiLoEq....Co
0343.38 C UC:LC XLATE CCBCTY:2 CCBCTY
0343.39 c movel CCBCTY Wrk#Text
0343.40 c Call '$FirstCap'
0343.41 c parm FC#Text
0343.42 c parm Wrk#Text
0343.43 c parm Wrk#Char
0343.44 c parm Idx
0343.47 C MOVEL Wrk#Text CCBCTY
0343.48 ***
0343.49 C MOVEL BSTATE CCBST
0343.50 C UC:LC XLATE CCBST:2 CCBST
0343.51 c movel CCBST Wrk#Text
0343.52 c Call '$FirstCap'
0343.53 c parm FC#Text
0343.54 c parm Wrk#Text
0343.55 c parm Wrk#Char
0343.56 c parm Idx
0343.59 C MOVEL Wrk#Text CCBST
0343.60 ***
0343.61 C MOVEL BZIP CCBZIP
SEU==>
FMT * *. 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7
...+... 8 ...+... 9
0343.62 ***
0343.63 C CCPRFX CAT '.':0 TCSALU 25
0343.64 C CAT CCLNAM:1 TCSALU
0343.65 C CAT ':':0 TCSALU
0343.66 C MOVEL TCSALU CCSALU
0343.67 C CCPRFX CAT CCFNAM:1 TNAM 67
0343.68 C CAT CCMNAM:1 TNAM
0343.69 C CAT CCLNAM:1 TNAM
0343.70 C CAT CCNSFX:1 TNAM
0343.71 C MOVEL TNAM CCNAM 67
0343.72 C CCBCTY CAT ',':0 TCSZ 39
0343.73 C CAT CCBST:1 TCSZ 39
0343.74 C MOVEL CCBZIP CCCZIP 9
0343.75 C CAT CCCZIP:1 TCSZ
0343.76 C MOVEL TCSZ CCCSZ 39
0343.77 C END
0343.78 C END
0343.79 C #A2F ENDSR
0414.00
**************************************************************************
0415.00 *** LITIGANT FILE INFO TO CHILD CASE LETTERS FILE CLLITGP
FMT * *. 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6
...+... 7 ...+... 8 ...+...
0416.00
**************************************************************************
0417.00 C $L2F BEGSR
0417.01 ***
0418.00 C SETOFF 96
0419.00 C KEY1 SETLL CLLITGP
0420.00 C *IN96 DOWEQ *OFF
0421.00 C KEY1 READE CLLITGP
96
0422.00 C *IN96 IFEQ *OFF
0423.00 C ADD 1 X 2 0
0424.00 C ' ' SCAN LTNAME:1 SP 3 0
0425.00 C SP IFGT 1
0426.00 C SUB 2 SP
0427.00 C SP SUBST(P) LTNAME:1 LAST 20
0428.00 C ADD 2 SP
0429.00 ***
0430.00 C SUBST(P) LTNAME:SP FIRST 20
0431.00 C END
0432.00 C UC:LC XLATE FIRST:2 FIRST
0433.00 C UC:LC XLATE LAST:2 LAST
0434.00 C FIRST CAT(P) LAST:1 TEMP 41
FMT C
CL0N01Factor1+++++++Opcode&ExtFactor2+++++++Result++++++++Len++D+HiLoEq....Comments+++
0434.01 C UC:LC XLATE TEMP:1 TEMP
0434.02 c movel TEMP Wrk#Text
0434.03 c Call '$FirstCap'
0434.04 c parm FC#Text
0434.05 c parm Wrk#Text
0434.06 c parm Wrk#Char
0434.07 c parm Idx
0434.09 C MOVEL Wrk#Text TEMP
0434.10 ***
0434.11 C X IFEQ 1
0434.12 C MOVEL TEMP CCLIT1
0434.13 C ELSE
0434.14 C MOVEL TEMP CCLIT2
0434.15 C END
0434.16 ***
0434.17 C END
0434.18 C ENDDO
0434.19 ***
0434.20 C #L2F ENDSR
0451.00
**************************************************************************
FMT * *. 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+...
7 ...+... 8 .
0452.00 *** CLEAR OUT FIELDS AFTER A WRITE
0453.00
**************************************************************************
0454.00 C $CLR BEGSR
0455.00 C CLEAR CCCNTY
0456.00 C CLEAR CCCORT
0457.00 C CLEAR CCDIST
0458.00 C CLEAR CCDATE
0459.00 C CLEAR CCCASE
0460.00 C CLEAR CCSEQ#
0461.00 C CLEAR CCNATE
0462.00 C CLEAR ACNTY
0463.00 C CLEAR ADIST
0464.00 C CLEAR ADATE
0465.00 C CLEAR ASEQ#
0466.00 C CLEAR CAUSE#
0467.00 C CLEAR CCSUFX
0468.00 C CLEAR CCPRFX
0469.00 C CLEAR CCFNAM
0470.00 C CLEAR CCMNAM
0471.00 C CLEAR CCLNAM
FMT C
CL0N01Factor1+++++++Opcode&ExtFactor2+++++++Result++++++++Len++D+HiLoEq....Comments++++
0472.00 C CLEAR CCNSFX
0473.00 C CLEAR CCBAD1
0474.00 C CLEAR CCBAD2
0475.00 C CLEAR CCBCTY
0476.00 C CLEAR CCBST
0477.00 C CLEAR CCBZIP
0478.00 C CLEAR TCSALU
0479.00 C CLEAR CCSALU
0480.00 C CLEAR CCLIT1
0481.00 C CLEAR CCLIT2
0482.00 C CLEAR TCSZ
0483.00 C CLEAR CCCSZ
0484.00 C #CLR ENDSR
0558.00
**************************************************************************
0558.02 *** DATE AT THE TOP OF THE LETTER LIKE September 31, 2004
0558.03
**************************************************************************
0558.04 C $LTRDT BEGSR
0558.05 ***
0558.06 C KEY1 CHAIN AP724PR 58
0558.07 C *IN58 IFEQ *OFF
FMT C
CL0N01Factor1+++++++Opcode&ExtFactor2+++++++Result++++++++Len++D+HiLoEq....Comments+++++++++++
0558.08 C MOVEL *MONTH WSMNTH 2 0
0558.09 C MOVEL *YEAR WSYEAR 4 0
0558.10 C WSMNTH LOOKUP TABNBR TABNAM
88
0558.11 C MOVEL *BLANKS TEMP2 20
0558.12 C MOVEL TABNAM TEMP2
0558.13 C MOVEL *DAY DAYZ 2
0558.14 C TEMP2 CAT DAYZ:1 TEMP2
0558.15 C CAT ',':0 TEMP2
0558.16 C MOVEL WSYEAR CYEAR 4
0558.17 C TEMP2 CAT CYEAR:1 TEMP2
0558.18 C MOVEL TEMP2 CCDTZY 20
0558.19 C UC:LC XLATE CCDTZY:2 CCDTZY
0558.20 C UPDATE AP724PF
0558.21 C ELSE
0558.22 C WRITE AP724PF
0558.23 C END
0558.24 ***
0558.25 C #LTRDT ENDSR
0558.26 ** TABNBR
FMT ** ... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5
...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+...
0558.28 01January 02February
0558.29 03March 04April
0558.30 05May 06June
0558.31 07July 08August
0558.32 09September10October
0558.33 11November 12December
0558.34
**************************************************************************
0558.35 *** Captialize first letter of each word
0558.36
**************************************************************************
0558.37 P$FirstCap B Export
0558.38 ***
0558.39 D$FirstCap PI 67A
0558.40 DFC#Text 67A Const
0558.41 ***
0558.42 *** UPPER CASE TO LOWER CASE XLATE UC:LC
0558.43 *** LOWER CASE TO UPPER CASE XLATE LC:UC
0558.44 ***
0558.45 DUC C
Const('ABCDEFGHIJKLMNOPQRSTUVWXYZ')
0558.46 DLC C
Const('abcdefghijklmnoporstuvwxyz')
0558.47 ***
FMT D
DName+++++++++++ETDsFrom+++To/L+++IDc.Keywords+++++++++++++++++++++++++++++Comments+
0558.48 DWrk#Text S 67A
0558.49 DWrk#Char S 1A
0558.50 DIdx S 3P 0
0558.51
**************************************************************************
0558.52 *** Captialize the first character
0558.53
**************************************************************************
0558.54 c eval Wrk#text = %trim(FC#Text)
0558.55 C UC:LC xlate Wrk#Text Wrk#Text
0558.56 c eval Wrk#Char = %subst (Wrk#Text:1:1)
0558.57 C
0558.58 C LC:UC xlate Wrk#Char Wrk#Char
0558.59 c eval %subst (Wrk#Text:1:1) = Wrk#Char
0558.60 ***
0558.61
**************************************************************************
0558.62 *** Captialize any character after ' ' - ' .
0558.63
**************************************************************************
0558.64 c 2 Do 66 Idx
0558.65 c If %subst (Wrk#Text:Idx:1) = ' ' OR
0558.66 c %subst (Wrk#Text:Idx:1) = '-' OR
0558.67 c %subst (Wrk#Text:Idx:1) = '/' OR
FMT CX
CL0N01Factor1+++++++Opcode&ExtExtended-factor2+++++++++++++++++++++++++++++Comments++++++++++++
0558.68 c %subst (Wrk#Text:Idx:1) = '''' OR
0558.69 c %subst (Wrk#Text:Idx:1) = '.'
0558.70 c
0558.71 c eval Wrk#Char = %subst
(Wrk#Text:Idx+1:1)
0558.72 C LC:UC xlate Wrk#Char Wrk#Char
0558.73 c eval %subst (Wrk#Text:Idx+1:1) =
Wrk#Char
0558.74 c endIf
0558.75 c EndDo
0558.76 c return Wrk#Text
0558.77 ***
0558.78 P$FirstCap E
0559.00
**************************************************************************
0560.00 ***
0561.00 *** END OF SOURCE--- TABLE ENTRIES FOLLOW
0562.00 ***
0562.01
**************************************************************************
As an Amazon Associate we earn from qualifying purchases.
This mailing list archive is Copyright 1997-2025 by midrange.com and David Gibbs as a compilation work. Use of the archive is restricted to research of a business or technical nature. Any other uses are prohibited. Full details are available on our policy page. If you have questions about this, please contact [javascript protected email address].
Operating expenses for this site are earned using the Amazon Associate program and Google Adsense.
