I had the great fortune to begin my career as an Assembler Programmer/Consultant at a large IBM MVS/370 mainframe data center. Designing & developing applications at the machine code level was invaluable in sharpening my skills. Here I'll provide a brief glimpse into the "ancient" 370 Assembler realm along with a fun PC/370 Object Code Translator I described in my initial blog post. This is it below - the animated GIF shows how instructions (in object code) are evaluated one-by-one by pressing the <Enter Key>. The program is loaded into memory & then it "translates itself" starting with offset x"0000". Each opcode is evaluated & the correct source code translation is displayed before bumping to the next opcode. When I shared this on an Assembler 370 Usenet Group there were several professors that asked if they could use this as an instructional aid in their classrooms - some as far as Bangalore.
The program is extremely precise in it's design & coding - the only blunder was the misspelling of "Translater" in the footing line of the distributed object code!
Below is a small pamphlet known as the "Yellow Card" - I still have mine tucked safely away. It's jam-packed with everything you need. With all the 2:00am core dumps I worked on it didn't take me long to know this pamphlet inside & out. Working on other programmer's abends made me extremely committed to developing neat, concise & efficient code that is virtually bug-free... my trademark.
Here's a closer look at the "Yellow Card". This section displays the 370 Instruction Set from x'00' thru x'FF' with pertinent information such as the source code mnemonic, instruction format, etc...
The machine formats describe how many bytes the instruction takes & the required operands, bit masks, registers & addresses. The machine instructions take up 2, 4 or 6 bytes.
I originally created my Object Code Translator in CICS (1991) then modified it to run on a Windows 486 PC (1996) using PC/370 (an ASM/370 Emulator written by Donald Higgins & eventually sold to Micro Focus - renamed as MF/370). It's just a fun exercise created in my spare time - having a neat, well-thought out programming style enables me to build complex applications very rapidly.
The major difference between the PC/370 (left) & CICS (right) versions are the screen & keyboard controls. The mainframe uses a dumb terminal that relays activity once all data entry is complete & a control key is pressed. The PC is more interactive with 100% control given to the programmer with every press of a key. CICS has special commands to SEND & RECEIVE maps/data/actions while in PC/370 I need to explicitly code the routines for keyboard handling & video screen display.
Below shows key handling for PC/370 (left) & CICS (right). I coded the routine KBGET to retrieve keystrokes which are then evaluated (using a copybook of key values I created - @K#ESC, @K#F1, etc...). CICS maps the keys in the HANDLE AID command prior to issuing a RECEIVE MAP (ENTER, PF1, etc.) & control is passed to the corresponding address upon return to the program.
This is the routine that constructs the screen output. PC/370 allows a more versatile display with colors (the CICS version was a dull green monochrome).
***********************************************************************
* BUILD DUMP FORMATTED SCREEN DISPLAY *
***********************************************************************
CNOP 0,4 SUBROUTINE ALIGNMENT
BUILD EQU *
ST 6,BUILD@ SAVE RETURN ADDRESS
*
LA 4,MAP1I POINT TO MAP1 AREA
LH 5,=Y(L'MAP1I) LOAD MAP1 LENGTH
LA 6,=C' ' POINT TO HEX00
LH 7,=Y(1) LOAD LENGTH OF 1
ICM 7,B'1000',=C' ' PAD CHAR = LOW-VALUES
MVCL 4,6 CLEAR MAP1 AREA (ORIG)
*
MVC ARG,OFFARG MOVE OFFARG BYTE 1
BAL 6,XLATE TRANSLATE ARGUMENT
MVC M1OFFO(1),ARGZ MOVE ARGUMENT ZONE
MVC M1OFFO+1(1),ARGN MOVE ARGUMENT NUMERIC
MVC ARG,OFFARG+1 MOVE OFFARG BYTE 2
BAL 6,XLATE TRANSLATE ARGUMENT
MVC M1OFFO+2(1),ARGZ MOVE ARGUMENT ZONE
MVC M1OFFO+3(1),ARGN MOVE ARGUMENT NUMERIC
*
MVC ARG,LEN MOVE LENGTH BYTE 1
BAL 6,XLATE TRANSLATE ARGUMENT
MVC M1LENO(1),ARGZ MOVE ARGUMENT ZONE
MVC M1LENO+1(1),ARGN MOVE ARGUMENT NUMERIC
MVC ARG,LEN+1 MOVE LENGTH BYTE 2
BAL 6,XLATE TRANSLATE ARGUMENT
MVC M1LENO+2(1),ARGZ MOVE ARGUMENT ZONE
MVC M1LENO+3(1),ARGN MOVE ARGUMENT NUMERIC
*
LA 6,16 SET LOOP COUNTER
LA 7,M1LND POINT TO MAP LINE 1
ST 7,MAPADDR SAVE MAP LINE ADDRESS
BCLEAR EQU *
MVI 3(7),C' ' MOVE SPACE TO 1ST BYTE
MVC 4(78,7),3(7) PROPAGATE THRU LINE
BCT 6,BCLEAR LOOP TIL ALL CLEAR
*
LH 6,OFFSET LOAD OFFSET VALUE
LH 7,LEN LOAD MODULE LENGTH
CVD 6,DISP CONVERT TO DECIMAL
ZAP PLO,DISP+5(3) XFER TO LO POSITION
ZAP PHI,PLO INIT HI TO LO COUNTER
SR 7,6 SUB OFFSET FROM LENGTH
STH 7,REM STORE REMAINING LENGTH
L 7,PTR POINT TO LOAD MODULE
AR 7,6 ADD OFFSET VALUE
ST 7,STARTPT SAVE STARTING POINT
LH 6,REM LOAD REMAINING LENGTH
ZAP LINES,=P'0' INIT LINE COUNTER
BLOOP EQU *
AP LINES,=P'1' ADD +1 TO LINE COUNTER
ZAP PLO,PHI SET NEW LO TO PREV HI
AP PLO,=P'1' INCREMENT LO BY +1
CH 6,=H'16' COMPARE REMAINING TO 16
BL BLOW LOW - ALTERNATE ROUTINE
LH 5,=H'16' SET LOOP COUNTER = 16
SH 6,=H'16' DECREMENT LENGTH CTR
B BSTH STORE NEW LENGTH
BLOW EQU *
LR 5,6 SET LOOP CTR = REM.LEN
SR 6,6 REMAINING LENGTH = 0
BSTH EQU *
STH 6,REM SAVE REMAINING LENGTH
L 3,MAPADDR POINT TO NEXT MAP LINE
LA 3,3(,3) BUMP PAST LENGTH/ATTRIB.
CVB 6,DISP CONVERT DISPLACEMENT
STH 6,HALF STORE DISP IN HALF-WORD
MVC ARG,HALF MOVE OFFSET BYTE 1
BAL 6,XLATE TRANSLATE ARGUMENT
MVC 0(1,3),ARGZ MOVE ARGUMENT ZONE
MVC 1(1,3),ARGN MOVE ARGUMENT NUMERIC
MVC ARG,HALF+1 MOVE OFFSET BYTE 2
BAL 6,XLATE TRANSLATE ARGUMENT
MVC 2(1,3),ARGZ MOVE ARGUMENT ZONE
MVC 3(1,3),ARGN MOVE ARGUMENT NUMERIC
LA 3,9(,3) POINT TO HEX DUMP AREA
LA 4,40(,3) POINT TO CHARACTER AREA
BDUMP EQU *
MVC ARG,0(7) MOVE LOAD MODULE BYTE
BAL 6,XLATE TRANSLATE ARGUMENT
MVC 0(1,3),ARGZ MOVE ZONE PORTION
MVC 1(1,3),ARGN MOVE NUMERIC PORTION
MVC 0(1,4),ARGT MOVE CHARACTER PORTION
LA 4,1(,4) BUMP MAP LINE (CHAR-FMT)
LA 3,2(,3) BUMP MAP LINE (HEX-FMT)
LA 7,1(,7) BUMP LOAD MODULE PTR
AP PHI,=P'1' ADD +1 TO HI POSITION
CVB 6,DISP CONVERT DISP TO BINARY
STH 6,HALF STORE IN HALF-WORD
TM HALF+1,X'01' SKIP SPACE EVERY 4 HEX
BNO BSKIP NOT 4TH - SKIP THIS
TM HALF+1,X'02' SKIP SPACE EVERY 4 HEX
BNO BSKIP NOT 4TH - SKIP THIS
LA 3,1(,3) SKIP EXTRA SPACE PLEASE
BSKIP EQU *
AP DISP,=P'1' ADD +1 TO DISPLACEMENT
BCT 5,BDUMP LOOP TIL LINE FINISHED
*
L 3,MAPADDR RELOAD MAP LINE ADDRESS
LA 3,71(,3) POINT TO LO/HI AREA
UNPK 0(5,3),PLO UNPACK LO POSITION
OI 4(3),X'F0' MAKE LAST DIGIT CHAR.
CP PLO,PHI IS LO EQUAL TO HI ???
BNL *+18 YES - THEN DON'T PUT HI!!
MVI 5(3),C'-' NO - MOVE DASH
UNPK 6(5,3),PHI UNPACK HI POSITION
OI 10(3),X'F0' MAKE LAST DIGIT CHAR.
*
L 3,MAPADDR LOAD MAP LINE ADDR AGAIN
LA 3,82(,3) BUMP TO NEXT POSITION
ST 3,MAPADDR SAVE NEW FMTARR ADDRESS
CP LINES,=P'16' MAP AREA FILLED ???
BNL BUILDX YES - EXIT PLEASE
LH 6,REM LOAD REMAINING LENGTH
CH 6,=H'0' GREATER THAN ZERO ???
BH BLOOP YES - MORE LINES TO FILL
BUILDX EQU *
L 6,BUILD@ RESTORE LINK REGISTER
BR 6 BRANCH ON LINK REGISTER
***********************************************************************
EJECT
This routine searches for the current opcode & builds the instruction based on the associated format:
***********************************************************************
* TRANSLATE OBJECT CODE TO SOURCE CODE *
***********************************************************************
CNOP 0,4 SUBROUTINE ALIGNMENT
OPXLAT EQU *
ST 6,OPXLAT@ SAVE RETURN ADDRESS
*
MVC M1XLTO,BLANKS CLEAR XLATE LINE
LH 6,OFFARG LOAD OFFSET ARGUMENT
L 7,PTR LOAD MODULE ADDRESS
AR 7,6 POINT TO OP-CODE OFFSET
*
LA 6,OPTABLE POINT TO OPCODE TABLE
OPXLOOP EQU *
CLI 0(6),X'FF' END OF TABLE ???
BE OPXFND YES - USE DUMMY ENTRY
CLC 0(1,6),0(7) TABLE OPCODE MATCH ???
BE OPXFND YES - CONTINUE PLEASE
LA 6,12(,6) BUMP TABLE ENTRY
B OPXLOOP TEST NEXT TABLE ENTRY
OPXFND EQU *
MVC OPENTRY,0(6) MOVE TABLE ENTRY
XC HALF,HALF CLEAR HALF-WORD AREA
MVC HALF+1(1),OPLEN MOVE INSTRUCTION LENGTH
LH 6,OFFARG LOAD INSTRUCTION OFFSET
AH 6,HALF ADD INSTRUCTION LENGTH
CH 6,LEN OFFSET MORE THAN LENGTH??
BNH *+16 NO - CONTINUE PLEASE
MVC OPENTRY,OPTABLEX MOVE TABLE ENTRY (DUMMY)
MVC HALF+1(1),OPLEN MOVE INSTRUCTION LENGTH
*
SR 3,3 INIT INSTRUCTION LENGTH
LH 3,HALF LOAD INSTRUCTION LENGTH
SRA 3,1 DIVIDE LENGTH BY 2
LA 4,M1XLTO POINT TO MAP AREA
LR 5,7 POINT TO INSTRUCTION
OPXOBJ EQU *
MVC ARG,0(5) MOVE 1ST BYTE TO ARGUMENT
BAL 6,XLATE TRANSLATE ARGUMENT
MVC 0(1,4),ARGZ MOVE ARGUMENT ZONE
MVC 1(1,4),ARGN MOVE ARGUMENT NUMERIC
MVC ARG,1(5) MOVE 2ND BYTE TO ARGUMENT
BAL 6,XLATE TRANSLATE ARGUMENT
MVC 2(1,4),ARGZ MOVE ARGUMENT ZONE
MVC 3(1,4),ARGN MOVE ARGUMENT NUMERIC
LA 4,5(,4) BUMP MAP POINTER
LA 5,2(,5) BUMP OBJ POINTER
BCT 3,OPXOBJ PRINT INSTRUCTION OBJECT
*
MVC M1XLTO+23(6),OPMNE MOVE MNEMONIC TO MAP
LA 5,M1XLTO+34 POINT TO OPERAND MAP AREA
L 4,OPRTN LOAD FORMAT ROUTINE ADDR
BALR 6,4 GOTO FORMAT ROUTINE NOW...
OPXLATX EQU *
L 6,OPXLAT@ RESTORE LINK REGISTER
BR 6 BRANCH ON LINK REGISTER
***********************************************************************
EJECT
Below is a small portion of the opcode table named "OPTABLE". It contains the opcode, instruction length in bytes, source code mnemonic & machine code format (actually the address of the machine code format routine).
***********************************************************************
* OP-CODE TABLE *
***********************************************************************
CNOP 0,4 FULL-WORD ALIGNMENT
OPTABLE EQU *
DC X'04',AL1(2),CL6'SPM ',A(RR1)
DC X'05',AL1(2),CL6'BALR ',A(RR1)
DC X'06',AL1(2),CL6'BCTR ',A(RR1)
DC X'07',AL1(2),CL6'BCR ',A(RR2)
DC X'0A',AL1(2),CL6'SVC ',A(RR3)
DC X'0B',AL1(2),CL6'BSM ',A(RR1)
DC X'0C',AL1(2),CL6'BASSM ',A(RR1)
DC X'0D',AL1(2),CL6'BASR ',A(RR1)
DC X'0E',AL1(2),CL6'MVCL ',A(RR1)
...
<SNIP>
...
DC X'F1',AL1(6),CL6'MVO ',A(SSA)
DC X'F2',AL1(6),CL6'PACK ',A(SSA)
DC X'F3',AL1(6),CL6'UNPK ',A(SSA)
DC X'F8',AL1(6),CL6'ZAP ',A(SSA)
DC X'F9',AL1(6),CL6'CP ',A(SSA)
DC X'FA',AL1(6),CL6'AP ',A(SSA)
DC X'FB',AL1(6),CL6'SP ',A(SSA)
DC X'FC',AL1(6),CL6'MP ',A(SSA)
DC X'FD',AL1(6),CL6'DP ',A(SSA)
OPTABLEX EQU *
DC X'FF',AL1(2),CL6'*** ',A(OPXLATX)
***********************************************************************
EJECT
And here's a sample of a machine code format routine. This one is RR2 format which is typically a Register-to-Register instruction but in this case it's more of a Bitmask-to-Register format - that's why I deemed it RR2.
***********************************************************************
* RR2 FORMAT: B'1111',R1 *
***********************************************************************
CNOP 0,4 FULL-WORD ALIGNMENT
RR2 EQU *
ST 6,SAVE@ SAVE RETURN ADDRESS
*
MVC M1XLTO+17(3),=C'RR2' MOVE FORMAT TO MAP
*
MVO RR(3),1(1,7) ISOLATE MASK1
BAL 6,FMTBITS CONVERT/MOVE TO MAP
MVI 0(5),C',' MOVE COMMA TO MAP
LA 5,1(,5) BUMP MAP 1 POSITION
XC RR,RR CLEAR REGISTER AREA
MVC RR+1(1),1(7) MOVE REG1/REG2
NI RR+1,X'0F' ISOLATE REG2
BAL 6,FMTR CONVERT/MOVE TO MAP
*
L 6,SAVE@ RESTORE LINK REGISTER
BR 6 BRANCH ON LINK REGISTER
***********************************************************************
EJECT
This was an interesting & fun exercise... a complex technical challenge that was quickly brought to life without the slightest problem. I miss the good old Assembler days...
Tony DeLia - PeopleSoft Developer | Technical Consultant. Enjoying a productive career in the Information Technology profession, with significant expertise developing pc, client-server, mainframe, relational database & ERP package solutions (PeopleSoft/Oracle). Welcome to my Blog... enjoy the smattering of bits, bytes, & words (that's lo-level machine code lingo)... This blog will serve as a historical monument to some of my past work.
Thursday, March 14, 2019
WinBatch - Hyper-Extreme Numeric to Literal Translation Overkill
Here's a fun little WinBatch exercise that converts a numeric value to a literal English translation. The GUI is designed to simulate a paycheck. When you enter an amount & press the XLATE button the literal nomenclature is presented. The system date & LDAP name (based on the current userid) is also filled in on the check. I added the verbage "*** For Entertainment ONLY ***" to discourage anyone from printing the simulated check & trying to cash it. You will not get away with it...
The reason this blog post has "Hyper-", "Extreme" & "Overkill" in the title is due to the level of precision to the left of the decimal point. It would be a fair expectation, at least for a check, to translate to millions or even billions... or trillions (to write a check to resolve the national debt). But I figured why stop there... quadrillion, quintillion, sextillion... not even close... How about "Vigintillion"? 10^63 seems extreme enough... at least for now. With hyperinflation looming across the globe - particularly those societies devastated by socialism - I may have to revisit this...
Winbatch provides a slick little GUI Dialog Builder that allows you to design your page - edit/text boxes, buttons, checkboxes, images, etc. Below is the layout of the simulated check.
Now to test the "Simulated Check". Below I entered a simple amount of 10546.53 - a fairly modest first attempt. The verbage "Ten-Thousand Five-Hundred Forty-Six and 53/100" is displayed.
Time to get a little crazy with testing... $1,989,745,123.02 makes a nice payday!
Here's an extreme version that blows out the text box completely! I prefixed the result on the page with [***TOO BIG***] to indicate that the result is... too big.
An error box is triggered explaining the issue & contains the full literal translation... this example is the maximum translation I accounted for...
The full literal translation is also pasted to the clipboard to use any way you seem fit:
Nine Hundred Ninety-Nine Vigintillion Nine Hundred Ninety-Nine Novemdecillion Nine Hundred Ninety-Nine Octodecillion Nine Hundred Ninety-Nine Septendecillion Nine Hundred Ninety-Nine Sexdecillion Nine Hundred Ninety-Nine Quindecillion Nine Hundred Ninety-Nine Quatuordecillion Nine Hundred Ninety-Nine Tredecillion Nine Hundred Ninety-Nine Duodecillion Nine Hundred Ninety-Nine Undecillion Nine Hundred Ninety-Nine Decillion Nine Hundred Ninety-Nine Nonillion Nine Hundred Ninety-Nine Octillion Nine Hundred Ninety-Nine Septillion Nine Hundred Ninety-Nine Sextillion Nine Hundred Ninety-Nine Quintillion Nine Hundred Ninety-Nine Quadrillion Nine Hundred Ninety-Nine Trillion Nine Hundred Ninety-Nine Billion Nine Hundred Ninety-Nine Million Nine Hundred Ninety-Nine Thousand Nine Hundred Ninety-Nine and 99/100
Here's a glimpse into the WinBatch code - the main routine handles the page input - the entered amount & the button pressed. It then calls my translation function TDFUN_Num_To_Lit().
;**********************************************************************
;* Display Dialog Box *
;**********************************************************************
IntControl(4,0,0,0,0)
gosub TDInit
sw = @YES
while sw == @YES ; CANCEL Button exits loop
ButtonPushed = Dialog("TD")
Select ButtonPushed
Case 1
TDlit = TDFUN_Num_To_Lit(TDpay)
TDamt = TDpay
TDlen = StrLen(TDlit)
ClipPut(TDlit)
if TDlen > 256
Message("Literal String Exceeds Panel Capacity (256B)",TDlit)
TDlit = StrCat("[***TOO BIG***] ",TDlit)
endif
break
Case 2
gosub TDhelp
break
EndSelect
endwhile
Exit
;**********************************************************************
And here is the TDFUN_Num_To_Lit() function... one of the most fun aspects of programming is dealing with arrays, indexes, pointers, segments & loops. This example has all of that...
;**********************************************************************
;* NUMBER-TO-LITERAL FUNCTION *
;**********************************************************************
;* *
;* INPUT: I_num - Numeric Value *
;* FORMAT: O_lit - Literal Interpretation *
;* *
;**********************************************************************
#DefineFunction TDFUN_Num_To_Lit(I_num)
O_lit = ""
if ~ IsDefined(NLmtx)
NLmtx = ArrDimension(28)
; Direct Indexing Literals
NLmtx[1] = "One"
NLmtx[2] = "Two"
NLmtx[3] = "Three"
NLmtx[4] = "Four"
NLmtx[5] = "Five"
NLmtx[6] = "Six"
NLmtx[7] = "Seven"
NLmtx[8] = "Eight"
NLmtx[9] = "Nine"
NLmtx[10] = "Ten"
NLmtx[11] = "Eleven"
NLmtx[12] = "Twelve"
NLmtx[13] = "Thirteen"
NLmtx[14] = "Fourteen"
NLmtx[15] = "Fifteen"
NLmtx[16] = "Sixteen"
NLmtx[17] = "Seventeen"
NLmtx[18] = "Eighteen"
NLmtx[19] = "Nineteen"
NLmtx[20] = "Twenty"
; Combination Indexing Literals
NLmtx[21] = "Thirty"
NLmtx[22] = "Forty"
NLmtx[23] = "Fifty"
NLmtx[24] = "Sixty"
NLmtx[25] = "Seventy"
NLmtx[26] = "Eighty"
NLmtx[27] = "Ninety"
NLmax = 27
endif
; Set Level Parameters (Element String, Length, Occurs)
L_str = ""
L_str = StrCat(L_str,"~Vigintillion~$$$$$$") ; 10^63
L_str = StrCat(L_str,"~Novemdecillion~$$$$") ; 10^60
L_str = StrCat(L_str,"~Octodecillion~$$$$$") ; 10^57
L_str = StrCat(L_str,"~Septendecillion~$$$") ; 10^54
L_str = StrCat(L_str,"~Sexdecillion~$$$$$$") ; 10^51
L_str = StrCat(L_str,"~Quindecillion~$$$$$") ; 10^48
L_str = StrCat(L_str,"~Quatuordecillion~$$") ; 10^45
L_str = StrCat(L_str,"~Tredecillion~$$$$$$") ; 10^42
L_str = StrCat(L_str,"~Duodecillion~$$$$$$") ; 10^39
L_str = StrCat(L_str,"~Undecillion~$$$$$$$") ; 10^36
L_str = StrCat(L_str,"~Decillion~$$$$$$$$$") ; 10^33
L_str = StrCat(L_str,"~Nonillion~$$$$$$$$$") ; 10^30
L_str = StrCat(L_str,"~Octillion~$$$$$$$$$") ; 10^27
L_str = StrCat(L_str,"~Septillion~$$$$$$$$") ; 10^24
L_str = StrCat(L_str,"~Sextillion~$$$$$$$$") ; 10^21
L_str = StrCat(L_str,"~Quintillion~$$$$$$$") ; 10^18
L_str = StrCat(L_str,"~Quadrillion~$$$$$$$") ; 10^15
L_str = StrCat(L_str,"~Trillion~$$$$$$$$$$") ; 10^12
L_str = StrCat(L_str,"~Billion~$$$$$$$$$$$") ; 10^9
L_str = StrCat(L_str,"~Million~$$$$$$$$$$$") ; 10^6
L_str = StrCat(L_str,"~Thousand~$$$$$$$$$$") ; 10^3
L_str = StrCat(L_str,"$$$$$$$$$$$$$$$$$$$$") ; Hundred
L_str = StrCat(L_str,"$$$$$$$$$$$$$$$$$$$$") ; Cents
L_str = StrReplace(L_str, "$", " ")
L_pos = 1
L_len = 20
L_occ = StrLen(L_str) / L_len
L_tot = (L_occ * 3)
L_int = (L_occ * 3) - 3
L_dec = (L_occ * 3) - 1
; Format Numeric String
ptr = StrIndex(I_num,".",1,@FWDSCAN)
if ptr == 0
I_num = StrCat(I_num, ".")
ptr = StrLen(I_num)
endif
I_num = StrCat(I_num,"00")
ptr = ptr + 2
I_num = StrSub(I_num, 1, ptr)
I_num = StrFixLeft(I_num, "0", L_tot)
W_num = I_num
W_int = StrSub(I_num, 1, L_int)
W_dec = StrSub(I_num,L_dec, 2)
pos = 1
lev = 1
O_lit = ""
while lev <= (L_occ - 1)
seg = StrSub(W_num, pos, 3)
if seg > '000'
str = StrTrim(StrSub(L_str, L_pos, L_len))
str = StrReplace(str, "~", " ")
segHi = StrSub(seg, 1, 1)
segLo = StrSub(seg, 2, 2)
hi = %segHi%
lo = %segLo%
if hi > 0
NLtxt = NLmtx[hi]
O_lit = StrCat(O_lit, NLtxt, " Hundred")
if lo > 0
O_lit = StrCat(O_lit," ")
endif
endif
; Combination Indexing
if lo > 20
adj = Abs(lo/10) + 18
NLtxt = NLmtx[adj]
O_lit = StrCat(O_lit, NLtxt)
lo = lo mod 10
if lo > 0
O_lit = StrCat(O_lit,"-")
endif
endif
; Direct Indexing
if lo > 0
NLtxt = NLmtx[lo]
O_lit = StrCat(O_lit,NLtxt)
endif
O_lit = StrCat(O_lit,str)
endif
lev = lev + 1
pos = pos + 3
L_pos = L_pos + L_len
endwhile
if O_lit == ""
O_lit = "Zero"
endif
; Now process the cents portion
if W_dec <> '00'
O_lit = StrCat(O_lit," and ",W_dec, "/100")
endif
Return O_lit
#EndFunction
;**********************************************************************
I hope you enjoyed this post... and once again, please do not try to cash the simulated check output! This is your final warning...
The reason this blog post has "Hyper-", "Extreme" & "Overkill" in the title is due to the level of precision to the left of the decimal point. It would be a fair expectation, at least for a check, to translate to millions or even billions... or trillions (to write a check to resolve the national debt). But I figured why stop there... quadrillion, quintillion, sextillion... not even close... How about "Vigintillion"? 10^63 seems extreme enough... at least for now. With hyperinflation looming across the globe - particularly those societies devastated by socialism - I may have to revisit this...
Winbatch provides a slick little GUI Dialog Builder that allows you to design your page - edit/text boxes, buttons, checkboxes, images, etc. Below is the layout of the simulated check.
The GUI input is used to formulate the precise code for the page - the code can then be utilized in the main Winbatch program.
Now to test the "Simulated Check". Below I entered a simple amount of 10546.53 - a fairly modest first attempt. The verbage "Ten-Thousand Five-Hundred Forty-Six and 53/100" is displayed.
Time to get a little crazy with testing... $1,989,745,123.02 makes a nice payday!
Here's an extreme version that blows out the text box completely! I prefixed the result on the page with [***TOO BIG***] to indicate that the result is... too big.
An error box is triggered explaining the issue & contains the full literal translation... this example is the maximum translation I accounted for...
The full literal translation is also pasted to the clipboard to use any way you seem fit:
Nine Hundred Ninety-Nine Vigintillion Nine Hundred Ninety-Nine Novemdecillion Nine Hundred Ninety-Nine Octodecillion Nine Hundred Ninety-Nine Septendecillion Nine Hundred Ninety-Nine Sexdecillion Nine Hundred Ninety-Nine Quindecillion Nine Hundred Ninety-Nine Quatuordecillion Nine Hundred Ninety-Nine Tredecillion Nine Hundred Ninety-Nine Duodecillion Nine Hundred Ninety-Nine Undecillion Nine Hundred Ninety-Nine Decillion Nine Hundred Ninety-Nine Nonillion Nine Hundred Ninety-Nine Octillion Nine Hundred Ninety-Nine Septillion Nine Hundred Ninety-Nine Sextillion Nine Hundred Ninety-Nine Quintillion Nine Hundred Ninety-Nine Quadrillion Nine Hundred Ninety-Nine Trillion Nine Hundred Ninety-Nine Billion Nine Hundred Ninety-Nine Million Nine Hundred Ninety-Nine Thousand Nine Hundred Ninety-Nine and 99/100
Here's a glimpse into the WinBatch code - the main routine handles the page input - the entered amount & the button pressed. It then calls my translation function TDFUN_Num_To_Lit().
;**********************************************************************
;* Display Dialog Box *
;**********************************************************************
IntControl(4,0,0,0,0)
gosub TDInit
sw = @YES
while sw == @YES ; CANCEL Button exits loop
ButtonPushed = Dialog("TD")
Select ButtonPushed
Case 1
TDlit = TDFUN_Num_To_Lit(TDpay)
TDamt = TDpay
TDlen = StrLen(TDlit)
ClipPut(TDlit)
if TDlen > 256
Message("Literal String Exceeds Panel Capacity (256B)",TDlit)
TDlit = StrCat("[***TOO BIG***] ",TDlit)
endif
break
Case 2
gosub TDhelp
break
EndSelect
endwhile
Exit
;**********************************************************************
And here is the TDFUN_Num_To_Lit() function... one of the most fun aspects of programming is dealing with arrays, indexes, pointers, segments & loops. This example has all of that...
;**********************************************************************
;* NUMBER-TO-LITERAL FUNCTION *
;**********************************************************************
;* *
;* INPUT: I_num - Numeric Value *
;* FORMAT: O_lit - Literal Interpretation *
;* *
;**********************************************************************
#DefineFunction TDFUN_Num_To_Lit(I_num)
O_lit = ""
if ~ IsDefined(NLmtx)
NLmtx = ArrDimension(28)
; Direct Indexing Literals
NLmtx[1] = "One"
NLmtx[2] = "Two"
NLmtx[3] = "Three"
NLmtx[4] = "Four"
NLmtx[5] = "Five"
NLmtx[6] = "Six"
NLmtx[7] = "Seven"
NLmtx[8] = "Eight"
NLmtx[9] = "Nine"
NLmtx[10] = "Ten"
NLmtx[11] = "Eleven"
NLmtx[12] = "Twelve"
NLmtx[13] = "Thirteen"
NLmtx[14] = "Fourteen"
NLmtx[15] = "Fifteen"
NLmtx[16] = "Sixteen"
NLmtx[17] = "Seventeen"
NLmtx[18] = "Eighteen"
NLmtx[19] = "Nineteen"
NLmtx[20] = "Twenty"
; Combination Indexing Literals
NLmtx[21] = "Thirty"
NLmtx[22] = "Forty"
NLmtx[23] = "Fifty"
NLmtx[24] = "Sixty"
NLmtx[25] = "Seventy"
NLmtx[26] = "Eighty"
NLmtx[27] = "Ninety"
NLmax = 27
endif
; Set Level Parameters (Element String, Length, Occurs)
L_str = ""
L_str = StrCat(L_str,"~Vigintillion~$$$$$$") ; 10^63
L_str = StrCat(L_str,"~Novemdecillion~$$$$") ; 10^60
L_str = StrCat(L_str,"~Octodecillion~$$$$$") ; 10^57
L_str = StrCat(L_str,"~Septendecillion~$$$") ; 10^54
L_str = StrCat(L_str,"~Sexdecillion~$$$$$$") ; 10^51
L_str = StrCat(L_str,"~Quindecillion~$$$$$") ; 10^48
L_str = StrCat(L_str,"~Quatuordecillion~$$") ; 10^45
L_str = StrCat(L_str,"~Tredecillion~$$$$$$") ; 10^42
L_str = StrCat(L_str,"~Duodecillion~$$$$$$") ; 10^39
L_str = StrCat(L_str,"~Undecillion~$$$$$$$") ; 10^36
L_str = StrCat(L_str,"~Decillion~$$$$$$$$$") ; 10^33
L_str = StrCat(L_str,"~Nonillion~$$$$$$$$$") ; 10^30
L_str = StrCat(L_str,"~Octillion~$$$$$$$$$") ; 10^27
L_str = StrCat(L_str,"~Septillion~$$$$$$$$") ; 10^24
L_str = StrCat(L_str,"~Sextillion~$$$$$$$$") ; 10^21
L_str = StrCat(L_str,"~Quintillion~$$$$$$$") ; 10^18
L_str = StrCat(L_str,"~Quadrillion~$$$$$$$") ; 10^15
L_str = StrCat(L_str,"~Trillion~$$$$$$$$$$") ; 10^12
L_str = StrCat(L_str,"~Billion~$$$$$$$$$$$") ; 10^9
L_str = StrCat(L_str,"~Million~$$$$$$$$$$$") ; 10^6
L_str = StrCat(L_str,"~Thousand~$$$$$$$$$$") ; 10^3
L_str = StrCat(L_str,"$$$$$$$$$$$$$$$$$$$$") ; Hundred
L_str = StrCat(L_str,"$$$$$$$$$$$$$$$$$$$$") ; Cents
L_str = StrReplace(L_str, "$", " ")
L_pos = 1
L_len = 20
L_occ = StrLen(L_str) / L_len
L_tot = (L_occ * 3)
L_int = (L_occ * 3) - 3
L_dec = (L_occ * 3) - 1
; Format Numeric String
ptr = StrIndex(I_num,".",1,@FWDSCAN)
if ptr == 0
I_num = StrCat(I_num, ".")
ptr = StrLen(I_num)
endif
I_num = StrCat(I_num,"00")
ptr = ptr + 2
I_num = StrSub(I_num, 1, ptr)
I_num = StrFixLeft(I_num, "0", L_tot)
W_num = I_num
W_int = StrSub(I_num, 1, L_int)
W_dec = StrSub(I_num,L_dec, 2)
pos = 1
lev = 1
O_lit = ""
while lev <= (L_occ - 1)
seg = StrSub(W_num, pos, 3)
if seg > '000'
str = StrTrim(StrSub(L_str, L_pos, L_len))
str = StrReplace(str, "~", " ")
segHi = StrSub(seg, 1, 1)
segLo = StrSub(seg, 2, 2)
hi = %segHi%
lo = %segLo%
if hi > 0
NLtxt = NLmtx[hi]
O_lit = StrCat(O_lit, NLtxt, " Hundred")
if lo > 0
O_lit = StrCat(O_lit," ")
endif
endif
; Combination Indexing
if lo > 20
adj = Abs(lo/10) + 18
NLtxt = NLmtx[adj]
O_lit = StrCat(O_lit, NLtxt)
lo = lo mod 10
if lo > 0
O_lit = StrCat(O_lit,"-")
endif
endif
; Direct Indexing
if lo > 0
NLtxt = NLmtx[lo]
O_lit = StrCat(O_lit,NLtxt)
endif
O_lit = StrCat(O_lit,str)
endif
lev = lev + 1
pos = pos + 3
L_pos = L_pos + L_len
endwhile
if O_lit == ""
O_lit = "Zero"
endif
; Now process the cents portion
if W_dec <> '00'
O_lit = StrCat(O_lit," and ",W_dec, "/100")
endif
Return O_lit
#EndFunction
;**********************************************************************
I hope you enjoyed this post... and once again, please do not try to cash the simulated check output! This is your final warning...
Monday, March 11, 2019
SQL*Engine - Dynamic SQL Script Processor - Part 1
From my LinkedIn Projects: Designed/Developed Powerful Multi-Purpose SQL-Based Scripting Language.
Conditional Step Driven Logic, Variable Substitution, Error Handling,
Commit/Rollback, Math/String/Binary Functions, Script Library Support,
Reporting, Step Status/Row Count Summary & more. Also, Process
Scheduler Integrated, Audit Inquiry Page, Custom File
Watcher/Auto-Script Archiving - Frequently used for Production
Administration/SQL Updates/Etc. - Safer & more reliable than
standard SQL scripting (due to conditional step execution).
SQL*Engine is a custom scripting language I developed that is powered by a single SQR source module named XX_TDSQL.SQR. The language itself is best described as a cross between SQL*Plus, Application Engine & JCL (Job Control Language). Originally developed in 1999 I've been adding considerable functionality - the latest being full integration with PeopleSoft Process Scheduler, Automatic Script Detection/Security/Execution/Archiving & a Script Result Audit Page (as well as full reporting history).
Below is a sample of the SQL*Engine Audit Page - Each step is displayed in the scroll bar with the resolved SQL along with the associated results - Step Name, Status, Counts, Timings & Condition (if applicable). This particular example is deleting run control records from 5 different tables. The full set of expected results must match the actual counts for the COMMIT to be performed - otherwise a ROLLBACK is issued.
Below is the raw executable script - XXSQI_RC_DELETE.SQX - the OPRID "PSBATCH" & RUN_CONTROL_ID pattern "AP_XXACH_R2_%" are assigned to dynamic variables &&OPRID and &&RUNCONTROL which will be utilized in each DELETE statement. Variables are also set for 5 expected results & initialized for the related SQL results. Notice the steps are given an optional "Step Name". The steps are named as follows:
*****************************************************************
* *
* MODULE: XXSQI_RC_DELETE.SQX *
* AUTHOR: TONY DELIA. *
* DATE: 10/28/2015. *
* DESC: SQL*ENGINE SCRIPT - RUN CONTROL DELETE. *
* *
*****************************************************************
* STANDARD SQL*ENGINE DIRECTIVES *
*****************************************************************
@ON_ERROR=CONTINUE
@DELIMITER=|
@TIMING=ON
@SAFETY=ON
@SPOOL=OFF
*****************************************************************
* PROGRAM VARIABLES *
*****************************************************************
@HDR_REF=CRM_1210301
@HDR_DESCR=Delete Run Controls AP_XXACH_R2_<BU>
*****************************************************************
* SET OPRID/RUNCONTROL VARIABLES *
*****************************************************************
@SET=&&OPRID=PSBATCH
@SET=&&RUNCONTROL=AP_XXACH_R2_%
*****************************************************************
* SET EXPECTED RESULTS / INITIALIZE COUNTS TO ZERO *
*****************************************************************
@SET=&&EXP_A=47
@SET=&&EXP_B=361
@SET=&&EXP_C=44
@SET=&&EXP_D=47
@SET=&&EXP_E=47
@SET=&&CTR_A=0
@SET=&&CTR_B=0
@SET=&&CTR_C=0
@SET=&&CTR_D=0
@SET=&&CTR_E=0
*****************************************************************
* A - DELETE XX_RUN_CNTL_AP *
*****************************************************************
@STEP=DELETE_XX_RUN_CNTL_AP
delete
from ps_xx_run_cntl_ap
where oprid = '&&OPRID'
and run_cntl_id like '&&RUNCONTROL'
/
@SET=&&CTR_A=@ROWS
*****************************************************************
* B - DELETE PRCSRUNCNTLDIST *
*****************************************************************
@STEP=DELETE_PRCSRUNCNTLDIST
delete
from ps_prcsruncntldist
where oprid = '&&OPRID'
and runcntlid like '&&RUNCONTROL'
/
@SET=&&CTR_B=@ROWS
*****************************************************************
* C - DELETE PRCSRUNCNTLEOPT *
*****************************************************************
@STEP=DELETE_PRCSRUNCNTLEOPT
delete
from ps_prcsruncntleopt
where oprid = '&&OPRID'
and runcntlid like '&&RUNCONTROL'
/
@SET=&&CTR_C=@ROWS
*****************************************************************
* D - DELETE PRCSRUNCNTLDTL *
*****************************************************************
@STEP=DELETE_PRCSRUNCNTLDTL
delete
from ps_prcsruncntldtl
where oprid = '&&OPRID'
and runcntlid like '&&RUNCONTROL'
/
@SET=&&CTR_D=@ROWS
*****************************************************************
* E - DELETE PRCSRUNCNTL *
*****************************************************************
@STEP=DELETE_PRCSRUNCNTL
delete
from ps_prcsruncntl
where oprid = '&&OPRID'
and run_cntl_id like '&&RUNCONTROL'
/
@SET=&&CTR_E=@ROWS
*****************************************************************
* COMPARE ROW COUNTS VS. EXPECTED *
*****************************************************************
@STEP=COMPARE_COUNTS
@COUNT=PSCLOCK
WHERE TO_NUMBER('&&EXP_A') = TO_NUMBER('&&CTR_A')
AND TO_NUMBER('&&EXP_B') = TO_NUMBER('&&CTR_B')
AND TO_NUMBER('&&EXP_C') = TO_NUMBER('&&CTR_C')
AND TO_NUMBER('&&EXP_D') = TO_NUMBER('&&CTR_D')
AND TO_NUMBER('&&EXP_E') = TO_NUMBER('&&CTR_E')
/
*****************************************************************
* COMMIT *
*****************************************************************
@STEP=COMMIT
@COND=SOME.COMPARE_COUNTS
commit
/
*****************************************************************
* ROLLBACK *
*****************************************************************
@STEP=ROLLBACK
@COND=SKIP.COMMIT
rollback
/
*****************************************************************
* END OF SQL*ENGINE SCRIPT *
*****************************************************************
After each SQL Execution (/) the assigned variable is set with the Row Count (@ROWS). For example @SET=&&CTR_A=@ROWS populates the &&CTR_A variable with the result of the first delete step (DELETE_XX_RUN_CNTL_AP) - 47 rows (See Audit Page for Step 1).
SQL*Engine assigns results to each step - the STEP Status will be set to PASS, SKIP or FAIL while the Row Status will be set to SOME or ZERO (or blank in the event of SKIP/FAIL). These step status values may be used to control subsequent SQL execution. In this example the COMPARE_COUNTS step has produced the expected results for each step. The SELECT COUNT construct (@COUNT) sets the Row Status to SOME (the Step Status is set to PASS).
The COMMIT step is performed depending on the condition setting - @COND=SOME.COMPARE_COUNTS - The condition matches & commit is executed.
The ROLLBACK step has the condition of @COND=SKIP.COMMIT - the COMMIT step wasn't skipped - it has a step status of PASS - so the ROLLBACK step is not executed (set to SKIP).
Report Snippets:
The generated report displays the resolved SQL statements, directives, variable assignments, messages, begin/end/elapsed times & more...
A closer look at how the SQL*Engine directives control the flow of the process...
At the end of the report, a summary of each step is presented with the results & pertinent information.
This was a very simple application but a good example of how SQL*Engine works. This is a slick, high quality utility so I'll be posting more brief articles about this.
SQL*Engine is a custom scripting language I developed that is powered by a single SQR source module named XX_TDSQL.SQR. The language itself is best described as a cross between SQL*Plus, Application Engine & JCL (Job Control Language). Originally developed in 1999 I've been adding considerable functionality - the latest being full integration with PeopleSoft Process Scheduler, Automatic Script Detection/Security/Execution/Archiving & a Script Result Audit Page (as well as full reporting history).
Below is a sample of the SQL*Engine Audit Page - Each step is displayed in the scroll bar with the resolved SQL along with the associated results - Step Name, Status, Counts, Timings & Condition (if applicable). This particular example is deleting run control records from 5 different tables. The full set of expected results must match the actual counts for the COMMIT to be performed - otherwise a ROLLBACK is issued.
Below is the raw executable script - XXSQI_RC_DELETE.SQX - the OPRID "PSBATCH" & RUN_CONTROL_ID pattern "AP_XXACH_R2_%" are assigned to dynamic variables &&OPRID and &&RUNCONTROL which will be utilized in each DELETE statement. Variables are also set for 5 expected results & initialized for the related SQL results. Notice the steps are given an optional "Step Name". The steps are named as follows:
- @STEP=DELETE_XX_RUN_CNTL_AP
- @STEP=DELETE_PRCSRUNCNTLDIST
- @STEP=DELETE_PRCSRUNCNTLEOPT
- @STEP=DELETE_PRCSRUNCNTLDTL
- @STEP=DELETE_PRCSRUNCNTL
- @STEP=COMPARE_COUNTS - Sets the Comparison Result
- @STEP=COMMIT - Conditional depending on COMPARE_COUNTS results [@COND=SOME.COMPARE_COUNTS]
- @STEP=ROLLBACK - Conditional - Executes Rollback if Commit is skipped [@COND=SKIP.COMMIT]
*****************************************************************
* *
* MODULE: XXSQI_RC_DELETE.SQX *
* AUTHOR: TONY DELIA. *
* DATE: 10/28/2015. *
* DESC: SQL*ENGINE SCRIPT - RUN CONTROL DELETE. *
* *
*****************************************************************
* STANDARD SQL*ENGINE DIRECTIVES *
*****************************************************************
@ON_ERROR=CONTINUE
@DELIMITER=|
@TIMING=ON
@SAFETY=ON
@SPOOL=OFF
*****************************************************************
* PROGRAM VARIABLES *
*****************************************************************
@HDR_REF=CRM_1210301
@HDR_DESCR=Delete Run Controls AP_XXACH_R2_<BU>
*****************************************************************
* SET OPRID/RUNCONTROL VARIABLES *
*****************************************************************
@SET=&&OPRID=PSBATCH
@SET=&&RUNCONTROL=AP_XXACH_R2_%
*****************************************************************
* SET EXPECTED RESULTS / INITIALIZE COUNTS TO ZERO *
*****************************************************************
@SET=&&EXP_A=47
@SET=&&EXP_B=361
@SET=&&EXP_C=44
@SET=&&EXP_D=47
@SET=&&EXP_E=47
@SET=&&CTR_A=0
@SET=&&CTR_B=0
@SET=&&CTR_C=0
@SET=&&CTR_D=0
@SET=&&CTR_E=0
*****************************************************************
* A - DELETE XX_RUN_CNTL_AP *
*****************************************************************
@STEP=DELETE_XX_RUN_CNTL_AP
delete
from ps_xx_run_cntl_ap
where oprid = '&&OPRID'
and run_cntl_id like '&&RUNCONTROL'
/
@SET=&&CTR_A=@ROWS
*****************************************************************
* B - DELETE PRCSRUNCNTLDIST *
*****************************************************************
@STEP=DELETE_PRCSRUNCNTLDIST
delete
from ps_prcsruncntldist
where oprid = '&&OPRID'
and runcntlid like '&&RUNCONTROL'
/
@SET=&&CTR_B=@ROWS
*****************************************************************
* C - DELETE PRCSRUNCNTLEOPT *
*****************************************************************
@STEP=DELETE_PRCSRUNCNTLEOPT
delete
from ps_prcsruncntleopt
where oprid = '&&OPRID'
and runcntlid like '&&RUNCONTROL'
/
@SET=&&CTR_C=@ROWS
*****************************************************************
* D - DELETE PRCSRUNCNTLDTL *
*****************************************************************
@STEP=DELETE_PRCSRUNCNTLDTL
delete
from ps_prcsruncntldtl
where oprid = '&&OPRID'
and runcntlid like '&&RUNCONTROL'
/
@SET=&&CTR_D=@ROWS
*****************************************************************
* E - DELETE PRCSRUNCNTL *
*****************************************************************
@STEP=DELETE_PRCSRUNCNTL
delete
from ps_prcsruncntl
where oprid = '&&OPRID'
and run_cntl_id like '&&RUNCONTROL'
/
@SET=&&CTR_E=@ROWS
*****************************************************************
* COMPARE ROW COUNTS VS. EXPECTED *
*****************************************************************
@STEP=COMPARE_COUNTS
@COUNT=PSCLOCK
WHERE TO_NUMBER('&&EXP_A') = TO_NUMBER('&&CTR_A')
AND TO_NUMBER('&&EXP_B') = TO_NUMBER('&&CTR_B')
AND TO_NUMBER('&&EXP_C') = TO_NUMBER('&&CTR_C')
AND TO_NUMBER('&&EXP_D') = TO_NUMBER('&&CTR_D')
AND TO_NUMBER('&&EXP_E') = TO_NUMBER('&&CTR_E')
/
*****************************************************************
* COMMIT *
*****************************************************************
@STEP=COMMIT
@COND=SOME.COMPARE_COUNTS
commit
/
*****************************************************************
* ROLLBACK *
*****************************************************************
@STEP=ROLLBACK
@COND=SKIP.COMMIT
rollback
/
*****************************************************************
* END OF SQL*ENGINE SCRIPT *
*****************************************************************
After each SQL Execution (/) the assigned variable is set with the Row Count (@ROWS). For example @SET=&&CTR_A=@ROWS populates the &&CTR_A variable with the result of the first delete step (DELETE_XX_RUN_CNTL_AP) - 47 rows (See Audit Page for Step 1).
SQL*Engine assigns results to each step - the STEP Status will be set to PASS, SKIP or FAIL while the Row Status will be set to SOME or ZERO (or blank in the event of SKIP/FAIL). These step status values may be used to control subsequent SQL execution. In this example the COMPARE_COUNTS step has produced the expected results for each step. The SELECT COUNT construct (@COUNT) sets the Row Status to SOME (the Step Status is set to PASS).
The COMMIT step is performed depending on the condition setting - @COND=SOME.COMPARE_COUNTS - The condition matches & commit is executed.
The ROLLBACK step has the condition of @COND=SKIP.COMMIT - the COMMIT step wasn't skipped - it has a step status of PASS - so the ROLLBACK step is not executed (set to SKIP).
Report Snippets:
The generated report displays the resolved SQL statements, directives, variable assignments, messages, begin/end/elapsed times & more...
A closer look at how the SQL*Engine directives control the flow of the process...
At the end of the report, a summary of each step is presented with the results & pertinent information.
This was a very simple application but a good example of how SQL*Engine works. This is a slick, high quality utility so I'll be posting more brief articles about this.
Custom nVision Report Book Manager - "Single-Click" Execution
From my LinkedIn Projects: nVision/Report Book Manager – Created “Single-Click” Report Book
Execution Tool for Month End Close. Unlimited Report Books containing
hundreds of report/scopes managed, queued & executed automatically.
Up to 3 processing threads managed (NT1/NT2) & report books queued
"until all have completed". Each instance execution relays a status email
to users showing which books have completed, are processing and/or still
pending. I created this upon discovering the finance team was spending
nights running reports manually one after another. *To be clear,
PeopleSoft does not provide this functionality - it only allows a single
report book to be scheduled at a "predetermined static time".
I created the XXRBKMGR process to maximize the efficiency of our Month End GL Close Reporting. We have approximately 250 nVision Report Templates that generate over 2,500 individual xls report files. To alleviate running each report manually the obvious first step is to group them into report books. Now we have 25 report books - run controls SP_RB_GRP01 thru SP_RB_GRP25. They are divided & sequenced based on how long the reports run & the priority of availability. As mentioned in the introduction, PeopleSoft does allow you to schedule a report book at a specific date/time - but there is no flexibility. Month End close is typically a stress filled exercise that requires last minute postings & possible time extensions - there is NO static schedule for running the close. Furthermore, a mindless static schedule could potentially take up threads that would interfere with normal nightly batch processing - queuing jobs indiscriminately can have adverse effects. Also, when a report book ends another one isn't queued up to run when the thread is available - it sticks to the schedule.
Sample Report Book Definition:
The dilemna is multi-faceted:
The Solution:
That's it - execute XXRBKMGR.SQR - a "Single-Click" to handle everything... Automatic queuing, notifications, parameter settings, load balancing, etc...
Once XXRBKMGR is initially invoked it will requeue itself automatically every X minutes (currently set to 30) as long as there are report books running and/or pending. When all are complete the process ends.
Notification Samples:
The first occurrence of XXRBKMGR produces this email - it launched report books 6, 10 & 7 with the other 22 still pending. The numbers represent report book SP_RB_GRP<xx>.
Now all Report Books have completed. This is the ***FINAL*** notification.
XXRBKMGR report sample - Accessed via Process Monitor or click the URL provided in the email:
*Notice Report Book SP_RB_GRP08 is still running & accounted for in this example.
Here's some code snippets... it's a very tight streamlined process.
!**********************************************************************
!* *
!* MODULE: XXRBKMGR.SQR *
!* AUTHOR: TONY DELIA. *
!* DATE: 03/17/2016. *
!* SYSTEM: NSS/ADVANCE PUBLICATIONS - PSOFT 8.8 FINANCIALS. *
!* DESC: NVISION REPORTBOOK MANAGER. *
!* *
!**********************************************************************
!* *
!* TABLES: ps_xx_run_cntl_gl - Select *
!* ps_xx_rb_map - Select *
!* ps_xx_rb_hdr - Select, Update, Insert *
!* ps_xx_rb_run - Select, Update, Insert *
!* psprcsrqst - Select *
!* psnvsbook - Select, Update *
!* psnvsbookrequst - Select *
!* ps_nvs_report - Select, Update *
!* psserverstat - Select *
!* *
!**********************************************************************
The number of threads & the time increment between recurring XXRBKMGR executions are defined here:
#define RB_THREADS 3 ! Maximum Open Threads
#define RB_MINS 30 ! ReportBook Manager Increment
Below is the core logic for evaluating Complete, Running & Pending items and, if needed, will queue another report book with the proper load balancing. I'm acutely aware that this sample is a "teaser" - the RUN_Init function does all the heavy lifting. I created this years ago (XX_RUN.SQC) to load Process Requests for SQR, Application Engine, COBOL, Crystal Reports, nVision Report Books, etc.
evaluate $A_process_status
when = 'P'
if #THREADS < {RB_THREADS}
if #PRI_ctr < 2
let $B_server = $SVR_pri
let #PRI_ctr = #PRI_ctr + 1
else
let $B_server = $SVR_alt
end-if
let $RCX_svr = $B_server
let $RUN_type = '7'
let $RUN_prcs = 'RPTBOOK'
let $RUN_oprid = $A_oprid
let $RUN_cntl = $A_run_cntl_id
do RUN_Init($RUN_type, $RUN_prcs, $RUN_oprid, $RUN_cntl, #RUN_pi)
let $A_process_status = 'R'
let #A_process_instance = #RUN_pi
let #A_process_inst_stg = #prcs_process_instance
do Update_XX_RB_RUN
let #THREADS = #THREADS + 1
end-if
break
when = 'R'
let #A_active = instr('*5*6*7*16*', $B_runstatus, 1)
if #A_active > 0
let #THREADS = #THREADS + 1
if $B_server = $SVR_pri
let #PRI_ctr = #PRI_ctr + 1
end-if
else
let $A_process_status = 'C'
do Update_XX_RB_RUN
end-if
end-evaluate
Below is a snippet of the dynamic requeuing of XXRBKMGR - as long as there are Running or Pending report books it will queue itself in 30 minutes {RB_MINS}. There's the RUN_Init() teaser again... extremely powerful & useful utility I created. It's used extensively here at NSS/ACSI for a variety of applications.
let #PR_ctr = #P_ctr + #R_ctr
if #PR_ctr > 0
let $RCX_dttm = DateToStr(DateAdd(DateNow(),'minute',{RB_MINS}),'YYYYMMDD_HH24:MI')
let $SAV_dttm = $RCX_dttm
let $RCX_svr = 'PSUNX'
let $RUN_type = '1'
let $RUN_name = 'XXRBKMGR'
let $RUN_id = 'PSBATCH'
let $RUN_cntl = $prcs_run_cntl_id
if $RUN_cntl = ''
let $RUN_cntl = 'SP_RPTBOOK_MGR'
end-if
do RUN_Init($RUN_type, $RUN_name, $RUN_id, $RUN_cntl, #RUN_pi)
show ' '
show 'PI#: ' #RUN_pi edit 99999999 ' RC: ' $RUN_cntl ' Date/Time: ' $SAV_dttm
show ' '
else
let $HDR_status = 'C'
do Update_Report_Books_POST
end-if
do Update_XX_RB_HDR
do Send_Email
Once all reporting is complete & thoroughly reviewed by the GL team I have another process, written in PowerShell, that uploads the reports to SharePoint (another "Single-Click" solution).
This concludes my Custom Report Book Manager post... I hope you found it interesting.
I created the XXRBKMGR process to maximize the efficiency of our Month End GL Close Reporting. We have approximately 250 nVision Report Templates that generate over 2,500 individual xls report files. To alleviate running each report manually the obvious first step is to group them into report books. Now we have 25 report books - run controls SP_RB_GRP01 thru SP_RB_GRP25. They are divided & sequenced based on how long the reports run & the priority of availability. As mentioned in the introduction, PeopleSoft does allow you to schedule a report book at a specific date/time - but there is no flexibility. Month End close is typically a stress filled exercise that requires last minute postings & possible time extensions - there is NO static schedule for running the close. Furthermore, a mindless static schedule could potentially take up threads that would interfere with normal nightly batch processing - queuing jobs indiscriminately can have adverse effects. Also, when a report book ends another one isn't queued up to run when the thread is available - it sticks to the schedule.
Sample Report Book Definition:
The dilemna is multi-faceted:
- The GL Closing is not on a predetermined schedule but rather a verbal command to begin once all postings & last minute adjustments have been made.
- Report Books must be processed by a limited group of threads so they don't effect the nightly batch. Long running nVision reports can potentially consume all processing threads & bring production to a halt.
- For increased efficiency load balancing must occur between our NT1/NT2 servers - a real-time assessment must be made to assign the server effectively.
- When a report book completes there is no time to waste - the next book must be quickly queued for execution. An idle thread translates to delays in final report delivery.
- Run Control dates for all report books must be maintained on a monthly basis.
- Periodic Status Notifications showing the report books that have Completed, are Running & still Pending would be useful.
The Solution:
That's it - execute XXRBKMGR.SQR - a "Single-Click" to handle everything... Automatic queuing, notifications, parameter settings, load balancing, etc...
Once XXRBKMGR is initially invoked it will requeue itself automatically every X minutes (currently set to 30) as long as there are report books running and/or pending. When all are complete the process ends.
Notification Samples:
The first occurrence of XXRBKMGR produces this email - it launched report books 6, 10 & 7 with the other 22 still pending. The numbers represent report book SP_RB_GRP<xx>.
Now all Report Books have completed. This is the ***FINAL*** notification.
XXRBKMGR report sample - Accessed via Process Monitor or click the URL provided in the email:
*Notice Report Book SP_RB_GRP08 is still running & accounted for in this example.
Here's some code snippets... it's a very tight streamlined process.
!**********************************************************************
!* *
!* MODULE: XXRBKMGR.SQR *
!* AUTHOR: TONY DELIA. *
!* DATE: 03/17/2016. *
!* SYSTEM: NSS/ADVANCE PUBLICATIONS - PSOFT 8.8 FINANCIALS. *
!* DESC: NVISION REPORTBOOK MANAGER. *
!* *
!**********************************************************************
!* *
!* TABLES: ps_xx_run_cntl_gl - Select *
!* ps_xx_rb_map - Select *
!* ps_xx_rb_hdr - Select, Update, Insert *
!* ps_xx_rb_run - Select, Update, Insert *
!* psprcsrqst - Select *
!* psnvsbook - Select, Update *
!* psnvsbookrequst - Select *
!* ps_nvs_report - Select, Update *
!* psserverstat - Select *
!* *
!**********************************************************************
The number of threads & the time increment between recurring XXRBKMGR executions are defined here:
#define RB_THREADS 3 ! Maximum Open Threads
#define RB_MINS 30 ! ReportBook Manager Increment
Below is the core logic for evaluating Complete, Running & Pending items and, if needed, will queue another report book with the proper load balancing. I'm acutely aware that this sample is a "teaser" - the RUN_Init function does all the heavy lifting. I created this years ago (XX_RUN.SQC) to load Process Requests for SQR, Application Engine, COBOL, Crystal Reports, nVision Report Books, etc.
evaluate $A_process_status
when = 'P'
if #THREADS < {RB_THREADS}
if #PRI_ctr < 2
let $B_server = $SVR_pri
let #PRI_ctr = #PRI_ctr + 1
else
let $B_server = $SVR_alt
end-if
let $RCX_svr = $B_server
let $RUN_type = '7'
let $RUN_prcs = 'RPTBOOK'
let $RUN_oprid = $A_oprid
let $RUN_cntl = $A_run_cntl_id
do RUN_Init($RUN_type, $RUN_prcs, $RUN_oprid, $RUN_cntl, #RUN_pi)
let $A_process_status = 'R'
let #A_process_instance = #RUN_pi
let #A_process_inst_stg = #prcs_process_instance
do Update_XX_RB_RUN
let #THREADS = #THREADS + 1
end-if
break
when = 'R'
let #A_active = instr('*5*6*7*16*', $B_runstatus, 1)
if #A_active > 0
let #THREADS = #THREADS + 1
if $B_server = $SVR_pri
let #PRI_ctr = #PRI_ctr + 1
end-if
else
let $A_process_status = 'C'
do Update_XX_RB_RUN
end-if
end-evaluate
Below is a snippet of the dynamic requeuing of XXRBKMGR - as long as there are Running or Pending report books it will queue itself in 30 minutes {RB_MINS}. There's the RUN_Init() teaser again... extremely powerful & useful utility I created. It's used extensively here at NSS/ACSI for a variety of applications.
let #PR_ctr = #P_ctr + #R_ctr
if #PR_ctr > 0
let $RCX_dttm = DateToStr(DateAdd(DateNow(),'minute',{RB_MINS}),'YYYYMMDD_HH24:MI')
let $SAV_dttm = $RCX_dttm
let $RCX_svr = 'PSUNX'
let $RUN_type = '1'
let $RUN_name = 'XXRBKMGR'
let $RUN_id = 'PSBATCH'
let $RUN_cntl = $prcs_run_cntl_id
if $RUN_cntl = ''
let $RUN_cntl = 'SP_RPTBOOK_MGR'
end-if
do RUN_Init($RUN_type, $RUN_name, $RUN_id, $RUN_cntl, #RUN_pi)
show ' '
show 'PI#: ' #RUN_pi edit 99999999 ' RC: ' $RUN_cntl ' Date/Time: ' $SAV_dttm
show ' '
else
let $HDR_status = 'C'
do Update_Report_Books_POST
end-if
do Update_XX_RB_HDR
do Send_Email
Once all reporting is complete & thoroughly reviewed by the GL team I have another process, written in PowerShell, that uploads the reports to SharePoint (another "Single-Click" solution).
This concludes my Custom Report Book Manager post... I hope you found it interesting.
Sunday, March 10, 2019
PC/370 Assembler Creation - Stars & Stripes Forever
While perusing through my archives I came across a fun PC/370 Assembler program I created. PC/370 is a freeware application (developed by Donald Higgins) that allows you to write IBM 370 Mainframe Assembler programs on the PC (particularly 286 thru 486 models - Windows 10 requires the free DOSBox shell application to run). Mainframe supervisor calls are emulated by DOS interrupts to handle keyboard, video, I/O, etc. - CPU 370 registers are mapped to the DOS registers, flags & stack pointers along with the appropriate supervisor to interrupt codes.
This is a patriotic example of keyboard/video screen handling. I admit this is embarrassingly inaccurate - it was a very quick lunch break exercise & I didn't have time to map out 50 stars & 13 stripes. Nonetheless, the program demonstrates the formation of blue, red & white blocks along with blinking stars activated by pressing the F1 key. Source code to follow. Take note of the style, neatness & efficiency of the code. It doesn't matter if I'm coding for a client project or creating a quick demo - every line must be professional, concise & worthy of presentation - always...
Sample GIF of the TDFLAG program with toggling stars:
The TDFLAG.ALC program begins with the standard IBM linkage conventions - the PC/370 application ensures the required elements are set properly from the operating system. R15 contains the program entry point address, R14 contains the return address (back to the O/S) & R13 is pointed to the external 18 fullword save area of the O/S.
TITLE 'TDFLAG - PC/370 4.2 DISPLAY FLAG // DELIA'
***********************************************************************
* *
* MODULE: TDFLAG. *
* AUTHOR: TONY DELIA. *
* DATE: 10/18/96. *
* DESC: DISPLAY FLAG. *
* NOTE: PC/370 RELEASE 4.2 *
* *
***********************************************************************
EJECT
***********************************************************************
* T D F L A G P R O G R A M *
***********************************************************************
TDFLAG START 0 START PROGRAM
STM 14,12,12(13) SAVE REGISTERS
LR 12,15 LOAD PROGRAM ENTRY POINT
USING TDFLAG+0*4096,12 BASE REGISTER 1
L 11,BASE2 LOAD BASE REGISTER 2
USING TDFLAG+1*4096,11 TELL ASSEMBLER ABOUT BASE2
L 10,BASE3 LOAD BASE REGISTER 3
USING TDFLAG+2*4096,10 TELL ASSEMBLER ABOUT BASE3
ST 13,SAVE+4 SAVE EXTERNAL SAVE ADDRESS
LR 14,13 XFER ADDRESS TO TEMP R14
LA 13,SAVE LOAD INTERNAL SAVE ADDRESS
ST 13,8(14) SAVE IN EXTERNAL SAVE AREA
B GO BRANCH TO PROCESSING RTN
***********************************************************************
RETURN EQU * TIME TO RETURN
L 13,SAVE+4 RESTORE REGISTER 13
LM 14,12,12(13) RESTORE REMAINING REGS
SR 15,15 CLEAR RETURN CODE
BR 14 BRANCH TO CALLING PROGRAM
***********************************************************************
SAVE DC 18F'0' S A V E A R E A
***********************************************************************
BASE2 DC A(TDFLAG+1*4096) BASE2 DISPLACEMENT
BASE3 DC A(TDFLAG+2*4096) BASE2 DISPLACEMENT
***********************************************************************
GO EQU * BEGIN PROCESSING ...
***********************************************************************
EJECT
The main procedure reads a table that defines the areas of blue, red & white along with the positions of the stars. It also accepts & interrogates keyboard input. If the F1 key is pressed it will toggle the stars blinking on or off... if any other key is pressed the program is stopped.
***********************************************************************
* MAINLINE PROCEDURE *
***********************************************************************
PRINT NOGEN
SVC @TRACE ISSUE SUPERVISOR CALL
DC CL4'IOF ' KEYBOARD INTERRUPT OFF
*
MVI VBITS,@BKWH SET BACKGROUND/FOREGROUND
BAL 6,VRESET CHANGE SCREEN ATTRIBUTES
*
LA 5,FLAG LOAD TABLE ADDRESS
LOOP EQU *
CLI 0(5),X'FF' END OF TABLE ???
BE LOOPX YES - EXIT PLEASE
*
MVC VXYS,0(5) MOVE CURSOR POSITION
BAL 6,VXYSET SET CURSOR POSITION
MVC VPUTL,4(5) MOVE LINE LENGTH
MVC VBITS,6(5) SET BACKGROUND/FOREGROUND
*
TM 7(5),X'01' ANY STARS ???
BNO *+10 NO - CONTINUE PLEASE
OC VBITS,BLINK YES - SET BLINK/TOGGLE
*
BAL 6,VPUT WRITE DUMMY LINE
*
TM 7(5),X'01' ANY STARS ???
BNO BUMP NO - CONTINUE PLEASE
*
MVC VXYS,0(5) MOVE CURSOR POSITION
BAL 6,VXYSET SET CURSOR POSITION
*
LA 2,STAR1 LOAD STAR 1 ADDRESS
TM 7(5),X'02' STAR LINE 2 ???
BNO *+8 NO - CONTINUE PLEASE
LA 2,STAR2 LOAD STAR 2 ADDRESS
*
SVC @WTO ISSUE SUPERVISOR CALL
BUMP EQU *
LA 5,8(,5) BUMP TABLE POINTER
B LOOP TEST NEXT TABLE ENTRY
LOOPX EQU *
MVC VXYS,=AL1(0,0,23,30) MOVE CURSOR POSITION
BAL 6,VXYSET SET CURSOR POSITION
MVC VPUTL,=Y(L'F1MSG) MOVE LINE LENGTH
MVI VBITS,@BKWT SET BACKGROUND/FOREGROUND
BAL 6,VPUT WRITE DUMMY LINE
LA 2,F1MSG LOAD MESSAGE ADDRESS
SVC @WTO ISSUE SUPERVISOR CALL
BAL 6,KBGET READ KEYBOARD INPUT
MVC KEY,KBCHR STORE KEYSTROKE
CLI KEY,@K#F1 KEY = F1 ???
BNE RETURN NO - EXIT PROGRAM
XC BLINK,TOGGLE ISOLATE UNIQUE BITS
XC TOGGLE,BLINK REPLACE TOGGLE W/BLINK
XC BLINK,TOGGLE REPLACE BLINK W/TOGGLE
LA 5,FLAG LOAD TABLE ADDRESS
B LOOP START OVER AGAIN...
***********************************************************************
BLINK DC XL1'00' BLINK ATTRIBUTE SETTING
TOGGLE DC XL1'80' TOGGLE BLINK SETTING
***********************************************************************
EJECT
I created various copybooks that contain routines for different purposes - this program uses the ones for video & keyboard along with the equate values for keystrokes, colors & supervisor/interrupt calls. The table named "FLAG" contains the block definitions for the blue, red & white areas as well as the bit settings to indicate stars.
***********************************************************************
* WORKING STORAGE *
***********************************************************************
KEY DC CL1' ' KEY STROKE (@RDKEY)
***********************************************************************
LTORG LITERAL POOL
***********************************************************************
@YES EQU C'Y' YES
@NO EQU C'N' NO
@ESC EQU 27 ESCAPE KEY
@CR EQU 13 CARRIAGE RETURN
@LF EQU 10 LINE FEED
@KEYLO EQU 32 ASCII KEY - LO VALUE
@KEYHI EQU 126 ASCII KEY - HI VALUE
***********************************************************************
* COPYBOOKS *
***********************************************************************
COPY CPY/TDVID.CPY COPYBOOK - VIDEO UTILITY
COPY CPY/TDKBD.CPY COPYBOOK - KEYBOARD INPUT
COPY CPY/TDKEY.CPY COPYBOOK - KEYSTROKES
COPY CPY/TDCLR.CPY COPYBOOK - COLORS
COPY CPY/TDSVC.CPY COPYBOOK - SUPERVISOR
***********************************************************************
F1MSG DC C'Press F1 to Toggle Blinking Stars... $'
***********************************************************************
STAR1 DC C' * * * * * $'
STAR2 DC C' * * * * $'
***********************************************************************
FLAG DS 0F
DC AL1(0,0,3,2),AL2(67),AL1(@RDWH,0)
DC AL1(0,0,5,2),AL2(67),AL1(@RDWH,0)
DC AL1(0,0,7,2),AL2(67),AL1(@RDWH,0)
DC AL1(0,0,9,2),AL2(67),AL1(@RDWH,0)
DC AL1(0,0,11,2),AL2(67),AL1(@RDWH,0)
DC AL1(0,0,13,2),AL2(67),AL1(@RDWH,0)
DC AL1(0,0,15,2),AL2(67),AL1(@RDWH,0)
DC AL1(0,0,17,2),AL2(67),AL1(@RDWH,0)
DC AL1(0,0,19,2),AL2(67),AL1(@RDWH,0)
DC AL1(0,0,21,2),AL2(67),AL1(@RDWH,0)
*
DC AL1(0,0,4,2),AL2(67),AL1(@WHWH,0)
DC AL1(0,0,6,2),AL2(67),AL1(@WHWH,0)
DC AL1(0,0,8,2),AL2(67),AL1(@WHWH,0)
DC AL1(0,0,10,2),AL2(67),AL1(@WHWH,0)
DC AL1(0,0,12,2),AL2(67),AL1(@WHWH,0)
DC AL1(0,0,14,2),AL2(67),AL1(@WHWH,0)
DC AL1(0,0,16,2),AL2(67),AL1(@WHWH,0)
DC AL1(0,0,18,2),AL2(67),AL1(@WHWH,0)
DC AL1(0,0,20,2),AL2(67),AL1(@WHWH,0)
*
DC AL1(0,0,3,2),AL2(21),AL1(@BLWH,0)
DC AL1(0,0,4,2),AL2(21),AL1(@BLWH,1)
DC AL1(0,0,5,2),AL2(21),AL1(@BLWH,3)
DC AL1(0,0,6,2),AL2(21),AL1(@BLWH,1)
DC AL1(0,0,7,2),AL2(21),AL1(@BLWH,3)
DC AL1(0,0,8,2),AL2(21),AL1(@BLWH,1)
DC AL1(0,0,9,2),AL2(21),AL1(@BLWH,3)
DC AL1(0,0,10,2),AL2(21),AL1(@BLWH,1)
DC AL1(0,0,11,2),AL2(21),AL1(@BLWH,3)
DC AL1(0,0,12,2),AL2(21),AL1(@BLWH,0)
*
DC X'FF'
***********************************************************************
END TDFLAG
I hope you enjoyed this post... it's somewhat of a relic from the past but clearly demonstrates precision coding, efficiency & fun.
FYI - Old Glory as it should be presented - 50 stars/13 stripes:
This is a patriotic example of keyboard/video screen handling. I admit this is embarrassingly inaccurate - it was a very quick lunch break exercise & I didn't have time to map out 50 stars & 13 stripes. Nonetheless, the program demonstrates the formation of blue, red & white blocks along with blinking stars activated by pressing the F1 key. Source code to follow. Take note of the style, neatness & efficiency of the code. It doesn't matter if I'm coding for a client project or creating a quick demo - every line must be professional, concise & worthy of presentation - always...
Sample GIF of the TDFLAG program with toggling stars:
The TDFLAG.ALC program begins with the standard IBM linkage conventions - the PC/370 application ensures the required elements are set properly from the operating system. R15 contains the program entry point address, R14 contains the return address (back to the O/S) & R13 is pointed to the external 18 fullword save area of the O/S.
TITLE 'TDFLAG - PC/370 4.2 DISPLAY FLAG // DELIA'
***********************************************************************
* *
* MODULE: TDFLAG. *
* AUTHOR: TONY DELIA. *
* DATE: 10/18/96. *
* DESC: DISPLAY FLAG. *
* NOTE: PC/370 RELEASE 4.2 *
* *
***********************************************************************
EJECT
***********************************************************************
* T D F L A G P R O G R A M *
***********************************************************************
TDFLAG START 0 START PROGRAM
STM 14,12,12(13) SAVE REGISTERS
LR 12,15 LOAD PROGRAM ENTRY POINT
USING TDFLAG+0*4096,12 BASE REGISTER 1
L 11,BASE2 LOAD BASE REGISTER 2
USING TDFLAG+1*4096,11 TELL ASSEMBLER ABOUT BASE2
L 10,BASE3 LOAD BASE REGISTER 3
USING TDFLAG+2*4096,10 TELL ASSEMBLER ABOUT BASE3
ST 13,SAVE+4 SAVE EXTERNAL SAVE ADDRESS
LR 14,13 XFER ADDRESS TO TEMP R14
LA 13,SAVE LOAD INTERNAL SAVE ADDRESS
ST 13,8(14) SAVE IN EXTERNAL SAVE AREA
B GO BRANCH TO PROCESSING RTN
***********************************************************************
RETURN EQU * TIME TO RETURN
L 13,SAVE+4 RESTORE REGISTER 13
LM 14,12,12(13) RESTORE REMAINING REGS
SR 15,15 CLEAR RETURN CODE
BR 14 BRANCH TO CALLING PROGRAM
***********************************************************************
SAVE DC 18F'0' S A V E A R E A
***********************************************************************
BASE2 DC A(TDFLAG+1*4096) BASE2 DISPLACEMENT
BASE3 DC A(TDFLAG+2*4096) BASE2 DISPLACEMENT
***********************************************************************
GO EQU * BEGIN PROCESSING ...
***********************************************************************
EJECT
The main procedure reads a table that defines the areas of blue, red & white along with the positions of the stars. It also accepts & interrogates keyboard input. If the F1 key is pressed it will toggle the stars blinking on or off... if any other key is pressed the program is stopped.
***********************************************************************
* MAINLINE PROCEDURE *
***********************************************************************
PRINT NOGEN
SVC @TRACE ISSUE SUPERVISOR CALL
DC CL4'IOF ' KEYBOARD INTERRUPT OFF
*
MVI VBITS,@BKWH SET BACKGROUND/FOREGROUND
BAL 6,VRESET CHANGE SCREEN ATTRIBUTES
*
LA 5,FLAG LOAD TABLE ADDRESS
LOOP EQU *
CLI 0(5),X'FF' END OF TABLE ???
BE LOOPX YES - EXIT PLEASE
*
MVC VXYS,0(5) MOVE CURSOR POSITION
BAL 6,VXYSET SET CURSOR POSITION
MVC VPUTL,4(5) MOVE LINE LENGTH
MVC VBITS,6(5) SET BACKGROUND/FOREGROUND
*
TM 7(5),X'01' ANY STARS ???
BNO *+10 NO - CONTINUE PLEASE
OC VBITS,BLINK YES - SET BLINK/TOGGLE
*
BAL 6,VPUT WRITE DUMMY LINE
*
TM 7(5),X'01' ANY STARS ???
BNO BUMP NO - CONTINUE PLEASE
*
MVC VXYS,0(5) MOVE CURSOR POSITION
BAL 6,VXYSET SET CURSOR POSITION
*
LA 2,STAR1 LOAD STAR 1 ADDRESS
TM 7(5),X'02' STAR LINE 2 ???
BNO *+8 NO - CONTINUE PLEASE
LA 2,STAR2 LOAD STAR 2 ADDRESS
*
SVC @WTO ISSUE SUPERVISOR CALL
BUMP EQU *
LA 5,8(,5) BUMP TABLE POINTER
B LOOP TEST NEXT TABLE ENTRY
LOOPX EQU *
MVC VXYS,=AL1(0,0,23,30) MOVE CURSOR POSITION
BAL 6,VXYSET SET CURSOR POSITION
MVC VPUTL,=Y(L'F1MSG) MOVE LINE LENGTH
MVI VBITS,@BKWT SET BACKGROUND/FOREGROUND
BAL 6,VPUT WRITE DUMMY LINE
LA 2,F1MSG LOAD MESSAGE ADDRESS
SVC @WTO ISSUE SUPERVISOR CALL
BAL 6,KBGET READ KEYBOARD INPUT
MVC KEY,KBCHR STORE KEYSTROKE
CLI KEY,@K#F1 KEY = F1 ???
BNE RETURN NO - EXIT PROGRAM
XC BLINK,TOGGLE ISOLATE UNIQUE BITS
XC TOGGLE,BLINK REPLACE TOGGLE W/BLINK
XC BLINK,TOGGLE REPLACE BLINK W/TOGGLE
LA 5,FLAG LOAD TABLE ADDRESS
B LOOP START OVER AGAIN...
***********************************************************************
BLINK DC XL1'00' BLINK ATTRIBUTE SETTING
TOGGLE DC XL1'80' TOGGLE BLINK SETTING
***********************************************************************
EJECT
I created various copybooks that contain routines for different purposes - this program uses the ones for video & keyboard along with the equate values for keystrokes, colors & supervisor/interrupt calls. The table named "FLAG" contains the block definitions for the blue, red & white areas as well as the bit settings to indicate stars.
***********************************************************************
* WORKING STORAGE *
***********************************************************************
KEY DC CL1' ' KEY STROKE (@RDKEY)
***********************************************************************
LTORG LITERAL POOL
***********************************************************************
@YES EQU C'Y' YES
@NO EQU C'N' NO
@ESC EQU 27 ESCAPE KEY
@CR EQU 13 CARRIAGE RETURN
@LF EQU 10 LINE FEED
@KEYLO EQU 32 ASCII KEY - LO VALUE
@KEYHI EQU 126 ASCII KEY - HI VALUE
***********************************************************************
* COPYBOOKS *
***********************************************************************
COPY CPY/TDVID.CPY COPYBOOK - VIDEO UTILITY
COPY CPY/TDKBD.CPY COPYBOOK - KEYBOARD INPUT
COPY CPY/TDKEY.CPY COPYBOOK - KEYSTROKES
COPY CPY/TDCLR.CPY COPYBOOK - COLORS
COPY CPY/TDSVC.CPY COPYBOOK - SUPERVISOR
***********************************************************************
F1MSG DC C'Press F1 to Toggle Blinking Stars... $'
***********************************************************************
STAR1 DC C' * * * * * $'
STAR2 DC C' * * * * $'
***********************************************************************
FLAG DS 0F
DC AL1(0,0,3,2),AL2(67),AL1(@RDWH,0)
DC AL1(0,0,5,2),AL2(67),AL1(@RDWH,0)
DC AL1(0,0,7,2),AL2(67),AL1(@RDWH,0)
DC AL1(0,0,9,2),AL2(67),AL1(@RDWH,0)
DC AL1(0,0,11,2),AL2(67),AL1(@RDWH,0)
DC AL1(0,0,13,2),AL2(67),AL1(@RDWH,0)
DC AL1(0,0,15,2),AL2(67),AL1(@RDWH,0)
DC AL1(0,0,17,2),AL2(67),AL1(@RDWH,0)
DC AL1(0,0,19,2),AL2(67),AL1(@RDWH,0)
DC AL1(0,0,21,2),AL2(67),AL1(@RDWH,0)
*
DC AL1(0,0,4,2),AL2(67),AL1(@WHWH,0)
DC AL1(0,0,6,2),AL2(67),AL1(@WHWH,0)
DC AL1(0,0,8,2),AL2(67),AL1(@WHWH,0)
DC AL1(0,0,10,2),AL2(67),AL1(@WHWH,0)
DC AL1(0,0,12,2),AL2(67),AL1(@WHWH,0)
DC AL1(0,0,14,2),AL2(67),AL1(@WHWH,0)
DC AL1(0,0,16,2),AL2(67),AL1(@WHWH,0)
DC AL1(0,0,18,2),AL2(67),AL1(@WHWH,0)
DC AL1(0,0,20,2),AL2(67),AL1(@WHWH,0)
*
DC AL1(0,0,3,2),AL2(21),AL1(@BLWH,0)
DC AL1(0,0,4,2),AL2(21),AL1(@BLWH,1)
DC AL1(0,0,5,2),AL2(21),AL1(@BLWH,3)
DC AL1(0,0,6,2),AL2(21),AL1(@BLWH,1)
DC AL1(0,0,7,2),AL2(21),AL1(@BLWH,3)
DC AL1(0,0,8,2),AL2(21),AL1(@BLWH,1)
DC AL1(0,0,9,2),AL2(21),AL1(@BLWH,3)
DC AL1(0,0,10,2),AL2(21),AL1(@BLWH,1)
DC AL1(0,0,11,2),AL2(21),AL1(@BLWH,3)
DC AL1(0,0,12,2),AL2(21),AL1(@BLWH,0)
*
DC X'FF'
***********************************************************************
END TDFLAG
I hope you enjoyed this post... it's somewhat of a relic from the past but clearly demonstrates precision coding, efficiency & fun.
FYI - Old Glory as it should be presented - 50 stars/13 stripes:
Subscribe to:
Posts (Atom)





















