From e8cff8b0003f406e6ef6989aee938279a36fe937 Mon Sep 17 00:00:00 2001 From: Gary Jones Date: Wed, 15 Jul 2026 16:07:49 +0000 Subject: [PATCH 01/13] PERP-1: foundation module for the PreSales ERP demo (perp/) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Adds a new ibmi-agentic/perp/ module alongside cfdemo/, establishing the build and DDL patterns every subsequent PERP epic will follow. * perp/AGENTS.md, perp/Rules.mk, perp/.codermake/config.json — module scaffold; .codermake adds a runsqlstm entry for the .table.sql / .index.sql / .view.sql / .proc.sql recipes. * perp/DDL_STYLE_GUIDE.md — 12-section codebase-side conventions doc: file naming, FOR SYSTEM NAME / FOR COLUMN, multi-tenancy on company_code, standard audit block, referential integrity, composite PKs, journaling, effective-dated pricing, document numbering, generic code_master lookup, standard file header, build ordering. * perp/qddlsrc/example_reference.table.sql — worked example exercising every convention; builds to PERPDEMO/EXMPREF, journaled to PERPJRN with IMAGES(*BOTH). * perp/qclsrc/perpjrn.clle — bootstrap CL, creates PERPJRN + PERPRCV001 in PERPDEMO (JRNCACHE, MAXOPT2, sysmgr-rolled receivers). Idempotent. * perp/qclsrc/perpsjpf.clle — STRJRNPF wrapper for attaching each new SQL table to PERPJRN with IMAGES(*BOTH) OMTJRNE(*OPNCLO). Closes PERP-10, PERP-11, PERP-12, PERP-13 (all under Epic PERP-1). Corrections folded in from what was learned building the reference table against DB2 for i V7R5: FOR COLUMN goes between column name and data type (not after — SQL0199); _by columns need VARCHAR(18) not VARCHAR(10) so DEFAULT USER fits (SQL0574); GENERATED ALWAYS AS ('literal') is invalid, use DEFAULT + named table-level CHECK instead; journal receiver name is PERPRCV001 (10-char IBM i object-name cap, not PERPRCV0001). Also — outside the code diff — set the remaining 8 epics (PERP-2..9) and 37 stories (PERP-14..50) up to be self-executable: created a new "PERP Delivery Playbook" Confluence page under the project hub that codifies build target, code home, Jira lifecycle, DDL conventions, DB2 gotchas, journaling routine, per-page docs duties, and a shared DoD template; then prepended a "read this first" info panel and appended a category-specific Definition-of-Done checklist to every one of those 45 ticket descriptions. Co-Authored-By: CoderFlow Learn more: https://coderflow.ai --- perp/.codermake/config.json | 10 ++ perp/AGENTS.md | 50 ++++++ perp/DDL_STYLE_GUIDE.md | 204 +++++++++++++++++++++++ perp/Rules.mk | 36 ++++ perp/qclsrc/perpjrn.clle | 26 +++ perp/qclsrc/perpsjpf.clle | 15 ++ perp/qddlsrc/example_reference.table.sql | 87 ++++++++++ 7 files changed, 428 insertions(+) create mode 100644 perp/.codermake/config.json create mode 100644 perp/AGENTS.md create mode 100644 perp/DDL_STYLE_GUIDE.md create mode 100644 perp/Rules.mk create mode 100644 perp/qclsrc/perpjrn.clle create mode 100644 perp/qclsrc/perpsjpf.clle create mode 100644 perp/qddlsrc/example_reference.table.sql diff --git a/perp/.codermake/config.json b/perp/.codermake/config.json new file mode 100644 index 00000000..d21b5315 --- /dev/null +++ b/perp/.codermake/config.json @@ -0,0 +1,10 @@ +{ + "targetRelease": "V7R4M0", + "compileOptions": { + "crtbndrpg": { "dbgview": "*all" }, + "crtrpgmod": { "dbgview": "*all" }, + "crtsqlrpgi": { "dbgview": "*source" }, + "crtbndcbl": { "dbgview": "*all" }, + "runsqlstm": { "commit": "*none", "errlvl": "10" } + } +} diff --git a/perp/AGENTS.md b/perp/AGENTS.md new file mode 100644 index 00000000..2fd46d34 --- /dev/null +++ b/perp/AGENTS.md @@ -0,0 +1,50 @@ +# Instructions for Agents — PERP module + +This directory holds the **PreSales ERP (PERP)** module — a greenfield ERP +demo playground built alongside `cfdemo/` in this repo. + +Tracked in Jira project **PERP**; design reference lives in Confluence page +[PreSales ERP Development Project (PERP)](https://profoundlogicsupport.atlassian.net/wiki/spaces/CPP/pages/2511470593/). + +## Before touching anything + +Read **[DDL_STYLE_GUIDE.md](DDL_STYLE_GUIDE.md)** first. It sets the conventions +for every table, index, view, and CL in this module. In particular: + +- One `.table.sql` file per table, snake_case +- Explicit `FOR SYSTEM NAME` / `FOR COLUMN` on every table and column +- Standard audit block on every table (`created_at/by`, `updated_at/by`, `is_active`) +- FKs and CHECKs declared in DDL, not enforced in app code +- Composite PKs with `company_code` leading on multi-tenant tables +- All tables journaled from day one (see `qclsrc/perpjrn.clle`) +- No `SET OPTION COMMIT = *NONE` in RPG — real commitment control against the + perp journal + +## Build target + +Objects build into the **`PERPDEMO`** library on IBM i. `PERPDEMO` is a +shared demo library (not the per-task library) and has been created for this +purpose. When you build from this module, point `IBMI_BUILD_LIBRARY` at +`PERPDEMO` for these sources. + +Source physical files in `PERPDEMO` (all `RCDLEN(112)`): +`QRPGLESRC`, `QDDSSRC`, `QSQLSRC`, `QCLSRC`, `QCMDSRC`, `QMENUSRC`, `QSRVSRC`, +`QPNLSRC`. + +## Directory layout + +| Subdir | Holds | +|--------------|----------------------------------------------------------------| +| `qddlsrc/` | SQL DDL — `.table.sql`, `.index.sql`, `.view.sql`, `.proc.sql` | +| `qrpglesrc/` | RPG ILE / SQLRPGLE programs and modules | +| `qddssrc/` | DDS — `.pf`, `.lf`, `.dspf`, `.prtf` (5250 baseline only) | +| `qclsrc/` | CL / CLLE — library setup, journaling, hooks | +| `.codermake/config.json` | Module-scoped compile options (adds `runsqlstm`) | +| `Rules.mk` | Module build rules — always edit this, never the Makefile | + +## Building + +Run `codermake` from the repo root as usual. The module-local +`.codermake/config.json` layers on top of the repo-level one and adds the +`runsqlstm` compile options used to build `.table.sql` / `.index.sql` / +`.view.sql` / `.proc.sql` sources into `PERPDEMO`. diff --git a/perp/DDL_STYLE_GUIDE.md b/perp/DDL_STYLE_GUIDE.md new file mode 100644 index 00000000..ccbcfe7e --- /dev/null +++ b/perp/DDL_STYLE_GUIDE.md @@ -0,0 +1,204 @@ +# PERP SQL DDL Style Guide + +The `ibmi-agentic/perp/` module is greenfield — it introduces SQL DDL, FKs, +CHECK constraints, and journaling into a repository that until now used only +DDS `.pf` sources with no referential integrity and no commitment control. + +Every convention below is being **set** by this module. Every subsequent PERP +story must follow it. The one worked example — `example_reference.table.sql` +in `qddlsrc/` — demonstrates every convention in this document. + +Design decisions and the rationale behind each choice live on the Confluence +page **[Design Decisions & Conventions](https://profoundlogicsupport.atlassian.net/wiki/spaces/CPP/pages/2511831043/)**. +This guide is the codebase-side rendering of that reference. + +--- + +## 1. File conventions + +- **One `.table.sql` file per table.** No multi-object files. +- **snake_case** file names matching the SQL table name — e.g. + `inventory_master.table.sql` creates the table `inventory_master`. +- **Extensions match object type**, so `codermake` maps them to `RUNSQLSTM`: + - `.table.sql` → `CRTPF` via `RUNSQLSTM` (SQL table) + - `.index.sql` → `CRTLF` via `RUNSQLSTM` (SQL index) + - `.view.sql` → `CRTLF` via `RUNSQLSTM` (SQL view) + - `.proc.sql` → `CRTPGM` via `RUNSQLSTM` (SQL stored procedure) +- Sources live under **`ibmi-agentic/perp/qddlsrc/`**. + +## 2. Short-name mapping + +DB2 for i has a 128-byte SQL name **and** a 10-byte system name for every +table and column. If you don't declare the system name explicitly, DB2 +generates one — typically a truncated, non-obvious string that RPG programs +must then reference. That defeats the point of readable names in RPG. + +**Every table** carries an explicit `FOR SYSTEM NAME`. **Every column** carries +an explicit `FOR COLUMN`. The system name is uppercase and ≤ 10 chars. + +**Clause order matters.** On DB2 for i, `FOR COLUMN` goes **between the +column name and the data type**, not after the data type. Placing it after +`CHAR(...)` / `VARCHAR(...)` triggers the CCSID-modifier grammar (the parser +expects `FOR BIT DATA` / `FOR SBCS DATA` / `FOR MIXED DATA`) and RUNSQLSTM +fails with `SQL0199: Keyword COLUMN not expected`. + +```sql +CREATE TABLE inventory_master FOR SYSTEM NAME INVMSTR ( + company_code FOR COLUMN COMPCD CHAR(3) NOT NULL, + item_number FOR COLUMN ITEMNO VARCHAR(20) NOT NULL, + ... +) +``` + +## 3. Multi-tenancy — `company_code` + +Every business table is multi-tenant: + +- `company_code CHAR(3) NOT NULL` is the **leading column** of every + composite primary key on a business table. +- Reference tables (UOM, code_master, etc.) may be global, but if a value + is company-scoped, `company_code` leads the PK there too. +- Items are **not** shared across companies — each company gets its own item + numbers. This lets demos show two companies with the same SKU carrying + different attributes. + +## 4. Standard audit block + +Every table carries the same five columns at the end of its column list: + +```sql +created_at FOR COLUMN CRTAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, +created_by FOR COLUMN CRTBY VARCHAR(18) NOT NULL DEFAULT USER, +updated_at FOR COLUMN UPDAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, +updated_by FOR COLUMN UPDBY VARCHAR(18) NOT NULL DEFAULT USER, +is_active FOR COLUMN ISACT CHAR(1) NOT NULL DEFAULT 'Y' +``` + +**Why `VARCHAR(18)` on `_by` columns, not `VARCHAR(10)`.** DB2 for i's `USER` +special register returns `VARCHAR(18)`. If the target column is narrower, +`CREATE TABLE ... DEFAULT USER` fails with `SQL0574: Column, sequence, or +variable attribute is not valid`. IBM i user profiles are still ≤10 chars, so +the extra width is unused padding in practice — but the column must be able +to hold the default the register produces. + +The `CHECK (is_active IN ('Y','N'))` constraint is declared at table level +(as a named `CONSTRAINT`) rather than inline. Named constraints produce +readable messages in DB2 catalog errors and give RPG programs a stable +constraint name to reference. + +RPG maintenance programs stamp `updated_at`/`updated_by` on every write — +`CURRENT_TIMESTAMP` / `USER` are only the safety-net defaults. + +## 5. Referential integrity — declared in DDL + +FKs and CHECK constraints are declared on the table, not enforced in +application code. If a change would violate integrity, we want DB2 to reject +it — full stop. RPG programs must handle the resulting SQLSTATE cleanly. + +- Every FK is `ON DELETE RESTRICT ON UPDATE RESTRICT` unless there is a + specific reason otherwise. Physical deletes are rare — prefer `is_active = + 'N'` for soft delete. +- CHECK constraints enforce enumerations and simple invariants (positive + quantities, `IN (...)` value sets). +- **No `GENERATED ALWAYS AS IDENTITY`** unless the table has no natural key. + In PERP that is only `reconciliation_log`. + +## 6. Composite PKs + +- Business tables: `PRIMARY KEY (company_code, ...natural_key...)` +- Reference tables: `PRIMARY KEY (code_type, code_value)` and similar +- Multi-column PKs are the norm — no surrogate `id INT` columns. + +## 7. Journaling — day-one requirement + +Every table in this module is journaled from the moment it is created. +Departs from `cfdemo/` which runs `SET OPTION COMMIT = *NONE`. + +- Journal receiver: `PERPRCV001` in `PERPDEMO` +- Journal: `PERPJRN` in `PERPDEMO` +- Bootstrap CL: `qclsrc/perpjrn.clle` — creates receiver + journal. Run + once at library setup: `CALL PGM(PERPDEMO/PERPJRN)`. Idempotent + (monitors CPF7010). +- STRJRNPF wrapper: `qclsrc/perpsjpf.clle` — `CALL PERPSJPF PARM('MYTBL')` + attaches a single physical file to `PERPJRN` with `IMAGES(*BOTH) + OMTJRNE(*OPNCLO)`. Call after every new `.table.sql` build. +- RPG programs use real commitment control (`ACTGRP(*NEW)` or a named + activation group; no `COMMIT(*NONE)`). + +## 8. Effective-dated pricing + +Pricing tables use `effective_from` as part of the PK and a nullable +`effective_to`. Current row: `effective_to IS NULL`. Historical rows are +immutable — new prices close the current row and insert a new one. + +## 9. Document numbering + +Doc numbers are integer sequences per `(company_code, doc_type)` with a +computed display column for demo aesthetics: + +```sql +po_number FOR COLUMN PONBR BIGINT NOT NULL, +po_display FOR COLUMN PODSPY VARCHAR(20) GENERATED ALWAYS AS + (company_code CONCAT '-PO-' CONCAT LPAD(CHAR(po_number), 6, '0')) +``` + +A `document_sequence` table holds the high-water mark per company + doc type. + +## 10. Generic lookup — `code_master` + +Simple code-and-description lookups (statuses, priorities, roles, approval +sources) live in one `code_master` table keyed on `(code_type, code_value)`. +Business tables reference it via a `GENERATED ALWAYS AS ('POSTATUS')` +column so a real FK still works: + +```sql +status_code FOR COLUMN STCODE VARCHAR(20) NOT NULL, +status_type FOR COLUMN STTYPE VARCHAR(20) NOT NULL DEFAULT 'POSTATUS' + CHECK (status_type = 'POSTATUS'), +FOREIGN KEY (status_type, status_code) + REFERENCES code_master (code_type, code_value) +``` + +**Why `DEFAULT + CHECK` instead of `GENERATED ALWAYS AS ('POSTATUS')`.** DB2 +for i requires the generation expression of a computed column to reference +at least one column of the same table — a bare literal is rejected with +`SQL0104: Token '...' was not valid`. `DEFAULT + CHECK` achieves the same +guarantee (row always carries the discriminator value, cannot be overridden) +and lets the composite FK to `code_master` still be declared cleanly. + +**Exceptions:** UOM and `item_class` keep their own tables because they +carry structural attributes (conversion factors, per-company scope) that +don't fit a global lookup. + +## 11. File header + +Every `.table.sql` file starts with the same header block: + +```sql +-- --------------------------------------------------------------------------- +-- Table: (system name ) +-- Module: perp +-- Purpose: +-- Epic: PERP- +-- --------------------------------------------------------------------------- +``` + +## 12. Build ordering + +Rules.mk expresses FK ordering with normal prerequisites (not order-only): + +```makefile +item.file: qddlsrc/item.table.sql company.file item_class.file uom.file +``` + +A parent table must have been (re-)built before a child that FKs to it. Use +`|` (order-only) for the STRJRNPF hook and other dependencies that shouldn't +trigger a rebuild. + +--- + +## Reference example + +**`qddlsrc/example_reference.table.sql`** in this module demonstrates every +one of these conventions in a single file. When adding a new table, copy that +file, rename it, and edit — don't start from scratch. diff --git a/perp/Rules.mk b/perp/Rules.mk new file mode 100644 index 00000000..c8c06502 --- /dev/null +++ b/perp/Rules.mk @@ -0,0 +1,36 @@ +# PreSales ERP (PERP) module build rules. +# +# All rules for the /perp module go here. Sources live under: +# qddlsrc/ — SQL DDL (.table.sql, .index.sql, .view.sql, .proc.sql) +# qrpglesrc/ — RPG / SQLRPGLE programs and modules +# qddssrc/ — DSPF / PF / LF / PRTF for the 5250 baseline +# qclsrc/ — CL / CLLE (library setup, journal, hooks) +# +# See perp/DDL_STYLE_GUIDE.md for the SQL DDL conventions this module uses. +# +# Naming: one .sql file per table, snake_case, extension .table.sql so +# codermake maps the source to CRTPF via RUNSQLSTM. Parent tables are declared +# as normal prerequisites of tables that FK to them so the build order is +# correct. + +# --- SQL DDL -------------------------------------------------------------- + +# Style-guide reference table. Not a business table — kept in the build so +# that (a) the codermake .table.sql recipe is exercised on every build, and +# (b) the file can be picked up by new-table authors as a copy-paste starter. +# +# perpsjpf.pgm is declared as an order-only prereq so STRJRNPF is available +# for the post-create step below; the perp journal itself (PERPJRN) must +# already exist (created by CALL PERPJRN — see qclsrc/perpjrn.clle). +example_reference.file: qddlsrc/example_reference.table.sql | perpsjpf.pgm + +# (First real business tables land under PERP-2 Company & System Reference.) + + +# --- CL setup ------------------------------------------------------------- + +# PERP journal + receiver bootstrap. Run once at library setup time. +perpjrn.pgm: qclsrc/perpjrn.clle + +# STRJRNPF wrapper called after each SQL table create. +perpsjpf.pgm: qclsrc/perpsjpf.clle diff --git a/perp/qclsrc/perpjrn.clle b/perp/qclsrc/perpjrn.clle new file mode 100644 index 00000000..4c7d19ab --- /dev/null +++ b/perp/qclsrc/perpjrn.clle @@ -0,0 +1,26 @@ +/* PERPJRN - Create the PERP journal + receiver in PERPDEMO. */ +/* Run once at library setup time. */ +/* PERPRCV001 - initial journal receiver */ +/* PERPJRN - the journal object */ + +PGM + + CRTJRNRCV JRNRCV(PERPDEMO/PERPRCV001) + + THRESHOLD(1000000) + + AUT(*USE) + + TEXT('PERP journal receiver (initial)') + MONMSG MSGID(CPF7010) + + CRTJRN JRN(PERPDEMO/PERPJRN) + + JRNRCV(PERPDEMO/PERPRCV001) + + MNGRCV(*SYSTEM) + + DLTRCV(*YES) + + RCVSIZOPT(*MAXOPT2 *RMVINTENT) + + JRNCACHE(*YES) + + AUT(*USE) + + TEXT('PERP journal - all PERP tables') + MONMSG MSGID(CPF7010) + + SNDPGMMSG MSG('PERPJRN + PERPRCV001 ready in PERPDEMO') + +ENDPGM diff --git a/perp/qclsrc/perpsjpf.clle b/perp/qclsrc/perpsjpf.clle new file mode 100644 index 00000000..b0690bb3 --- /dev/null +++ b/perp/qclsrc/perpsjpf.clle @@ -0,0 +1,15 @@ +/* PERPSJPF - Start journaling for a single PERP physical file. */ +/* Called after RUNSQLSTM creates a SQL table in PERPDEMO. */ +/* Parameter: &FILE - system name of the file, e.g. 'INVMSTR'. */ +/* Idempotent - silently ignores CPF7030 (already journaled). */ + +PGM PARM(&FILE) + DCL VAR(&FILE) TYPE(*CHAR) LEN(10) + + STRJRNPF FILE(PERPDEMO/&FILE) + + JRN(PERPDEMO/PERPJRN) + + IMAGES(*BOTH) + + OMTJRNE(*OPNCLO) + MONMSG MSGID(CPF7030) + +ENDPGM diff --git a/perp/qddlsrc/example_reference.table.sql b/perp/qddlsrc/example_reference.table.sql new file mode 100644 index 00000000..57961eaa --- /dev/null +++ b/perp/qddlsrc/example_reference.table.sql @@ -0,0 +1,87 @@ +-- --------------------------------------------------------------------------- +-- Table: example_reference (system name EXMPREF) +-- Module: perp +-- Purpose: Reference implementation of every DDL convention in +-- perp/DDL_STYLE_GUIDE.md. Copy this file when creating a new +-- table so that no convention is accidentally dropped. +-- Epic: PERP-1 (Foundation) +-- +-- Notes on DB2 for i syntax: +-- * FOR COLUMN goes BETWEEN column name and data type. Placing it after +-- CHAR/VARCHAR raises SQL0199 because the parser treats "FOR ..." after +-- a character type as the CCSID modifier grammar. +-- * GENERATED ALWAYS AS ('literal') is rejected -- the generation +-- expression must reference a column of the same table. Use DEFAULT + +-- CHECK for the constant-discriminator pattern. +-- * CHECK constraints are declared as table-level CONSTRAINT clauses so +-- they have stable, human-readable names in DB2 catalog messages. +-- --------------------------------------------------------------------------- + +CREATE TABLE example_reference FOR SYSTEM NAME EXMPREF ( + + -- Multi-tenant key ------------------------------------------------------- + company_code FOR COLUMN COMPCD CHAR(3) NOT NULL, + + -- Natural key ------------------------------------------------------------ + ref_code FOR COLUMN REFCD VARCHAR(20) NOT NULL, + + -- Descriptive columns ---------------------------------------------------- + ref_name FOR COLUMN REFNM VARCHAR(60) NOT NULL, + ref_type FOR COLUMN REFTYP VARCHAR(20) NOT NULL, + + -- Numeric with CHECK (table-level constraint below) ---------------------- + sort_order FOR COLUMN SRTORD INTEGER NOT NULL DEFAULT 0, + + -- Effective dating example ---------------------------------------------- + effective_from FOR COLUMN EFFFRM DATE NOT NULL DEFAULT CURRENT_DATE, + effective_to FOR COLUMN EFFTO DATE, + + -- Constant discriminator + code FK (parent table lands in PERP-2) -------- + status_code FOR COLUMN STCODE VARCHAR(20) NOT NULL DEFAULT 'ACTIVE', + status_type FOR COLUMN STTYPE VARCHAR(20) NOT NULL DEFAULT 'EXMPSTAT', + + -- Standard audit block -------------------------------------------------- + created_at FOR COLUMN CRTAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + created_by FOR COLUMN CRTBY VARCHAR(18) NOT NULL DEFAULT USER, + updated_at FOR COLUMN UPDAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_by FOR COLUMN UPDBY VARCHAR(18) NOT NULL DEFAULT USER, + is_active FOR COLUMN ISACT CHAR(1) NOT NULL DEFAULT 'Y', + + -- Composite PK — company_code leads -------------------------------------- + PRIMARY KEY (company_code, ref_code), + + -- Table-level CHECK constraints ----------------------------------------- + CONSTRAINT exmpref_srtord_ck CHECK (sort_order >= 0), + CONSTRAINT exmpref_isact_ck CHECK (is_active IN ('Y','N')), + CONSTRAINT exmpref_sttype_ck CHECK (status_type = 'EXMPSTAT'), + CONSTRAINT exmpref_efftv_ck CHECK (effective_to IS NULL + OR effective_to >= effective_from) + + -- Cross-table FKs would go here. For example, once code_master exists: + -- + -- , FOREIGN KEY (status_type, status_code) + -- REFERENCES code_master (code_type, code_value) + -- + -- and once company exists: + -- + -- , FOREIGN KEY (company_code) + -- REFERENCES company (company_code) + -- + -- They are commented out here because those parent tables land in PERP-2. +); + +LABEL ON TABLE example_reference IS + 'PERP DDL style-guide reference example table'; + +LABEL ON COLUMN example_reference ( + company_code IS 'Company code (multi-tenant key)', + ref_code IS 'Reference code (natural key)', + ref_name IS 'Reference name', + ref_type IS 'Reference type / category', + sort_order IS 'Presentation sort order', + effective_from IS 'Effective from date', + effective_to IS 'Effective to date (null = current)', + status_code IS 'Status (FK to code_master)', + status_type IS 'Status type discriminator (constant)', + is_active IS 'Active flag (Y/N, soft delete)' +); From 6aeb552e2fdb06eb68baccd5e3f268cdb2463c74 Mon Sep 17 00:00:00 2001 From: Gary Jones Date: Wed, 15 Jul 2026 16:55:58 +0000 Subject: [PATCH 02/13] =?UTF-8?q?PERP-2:=20Company=20&=20System=20Referenc?= =?UTF-8?q?e=20=E2=80=94=20foundation=20tables,=20seed,=20CRUD,=20docseq?= =?UTF-8?q?=20service?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Ships the multi-tenant / generic-lookup foundation that every downstream PERP epic depends on. Adds 5 tables in PERPDEMO (company, code_master, document_sequence, company_config, perp_user), a 28-row code_master seed, a docseq service program with atomic per-(company, doc_type) sequencing, and three DSPF/RPG maintenance programs (perpselr, wrkcmr, wrkusrr) tied together by a PERP menu (perpmnu.menu). Sources under ibmi-agentic/perp/: - qddlsrc/*.table.sql — 5 tables + seed script - qrpglesrc/docseq.sqlrpgle etc. — docseq service + smoke test - qrpglesrc/perpselr, wrkcmr, wrkusrr — DSPF-driven CRUD programs - qddssrc/*.dspf — matching 5250 subfile screens + PERPMNU - qsrvsrc/docseq.bnd — docseq export list - perp.bnddir, perpmnu.msgf — binding directory and menu message file - Rules.mk — full build graph - DDL_STYLE_GUIDE.md — expanded with RPG (§13), DSPF (§14), and codermake (§15) conventions and the DB2 for i / SQLRPGLE gotchas surfaced Every table journaled via CALL PERPSJPF. All objects build clean into PERPDEMO with severity <30. docseq end-to-end verified via ssh CALL. Post-review fixes: - perpmnu.dspf record format renamed R MENU → R PERPMNU so GO PERPMNU works (CRTMNU TYPE(*DSPF) requires format name to match menu name). - QDDLSRC source PF created in PERPDEMO — was missing at library setup; needed for the .table.sql / .index.sql / .view.sql / .proc.sql sources to sync back to IBM i on commit. Bootstrap set documented in DDL_STYLE_GUIDE.md §16. Co-Authored-By: CoderFlow Learn more: https://coderflow.ai --- perp/DDL_STYLE_GUIDE.md | 121 +++++++++ perp/Rules.mk | 47 +++- perp/perp.bnddir | 2 + perp/perpmnu.msgf | 6 + perp/qddlsrc/code_master.table.sql | 52 ++++ perp/qddlsrc/company.table.sql | 63 +++++ perp/qddlsrc/company_config.table.sql | 47 ++++ perp/qddlsrc/document_sequence.table.sql | 49 ++++ perp/qddlsrc/perp_user.table.sql | 56 ++++ perp/qddlsrc/seed/010_code_master.sql | 69 +++++ perp/qddssrc/perpmnu.dspf | 35 +++ perp/qddssrc/perpseld.dspf | 54 ++++ perp/qddssrc/wrkcmd.dspf | 75 ++++++ perp/qddssrc/wrkusrd.dspf | 73 ++++++ perp/qrpglesrc/docseq.sqlrpgle | 125 +++++++++ perp/qrpglesrc/docseq_pr.rpgle | 28 ++ perp/qrpglesrc/docseqsmk.sqlrpgle | 87 +++++++ perp/qrpglesrc/perpselr.sqlrpgle | 188 ++++++++++++++ perp/qrpglesrc/wrkcmr.sqlrpgle | 315 +++++++++++++++++++++++ perp/qrpglesrc/wrkusrr.sqlrpgle | 274 ++++++++++++++++++++ perp/qsrvsrc/docseq.bnd | 4 + 21 files changed, 1769 insertions(+), 1 deletion(-) create mode 100644 perp/perp.bnddir create mode 100644 perp/perpmnu.msgf create mode 100644 perp/qddlsrc/code_master.table.sql create mode 100644 perp/qddlsrc/company.table.sql create mode 100644 perp/qddlsrc/company_config.table.sql create mode 100644 perp/qddlsrc/document_sequence.table.sql create mode 100644 perp/qddlsrc/perp_user.table.sql create mode 100644 perp/qddlsrc/seed/010_code_master.sql create mode 100644 perp/qddssrc/perpmnu.dspf create mode 100644 perp/qddssrc/perpseld.dspf create mode 100644 perp/qddssrc/wrkcmd.dspf create mode 100644 perp/qddssrc/wrkusrd.dspf create mode 100644 perp/qrpglesrc/docseq.sqlrpgle create mode 100644 perp/qrpglesrc/docseq_pr.rpgle create mode 100644 perp/qrpglesrc/docseqsmk.sqlrpgle create mode 100644 perp/qrpglesrc/perpselr.sqlrpgle create mode 100644 perp/qrpglesrc/wrkcmr.sqlrpgle create mode 100644 perp/qrpglesrc/wrkusrr.sqlrpgle create mode 100644 perp/qsrvsrc/docseq.bnd diff --git a/perp/DDL_STYLE_GUIDE.md b/perp/DDL_STYLE_GUIDE.md index ccbcfe7e..38a7747e 100644 --- a/perp/DDL_STYLE_GUIDE.md +++ b/perp/DDL_STYLE_GUIDE.md @@ -36,6 +36,28 @@ must then reference. That defeats the point of readable names in RPG. **Every table** carries an explicit `FOR SYSTEM NAME`. **Every column** carries an explicit `FOR COLUMN`. The system name is uppercase and ≤ 10 chars. +**Exception — SQL name is already a valid system name.** DB2 for i rejects +`FOR SYSTEM NAME X` / `FOR COLUMN X` when the target SQL name is itself a +valid ≤10-char system name (all-alpha, or underscores allowed). In that case +providing a redundant *or different* system name raises `SQL7029: System name +X cannot be specified`. Two situations trigger this: + +1. The SQL name is ≤ 10 chars and pure alphanumeric, and you ask for the + same value as the auto-derivation — e.g. `CREATE TABLE company FOR SYSTEM + NAME COMPANY` or `city FOR COLUMN CITY`. +2. The SQL name is ≤ 10 chars and *already* a valid system name (underscores + allowed), and you ask for a *different* value — e.g. `perp_user FOR + SYSTEM NAME PERPUSR`. DB2 has no way to store a second short name here; + the SQL name is the short name. + +Fix: either omit the `FOR SYSTEM NAME` / `FOR COLUMN` clause and let DB2 +auto-derive, or rename the SQL identifier so it needs a short name (e.g. +`city` → `city_name FOR COLUMN CITY`, `perp_user` → keep the SQL name and +accept `PERP_USER` as the system name — RPG programs `dcl-f perp_user`). + +Related: **`LABEL ON TABLE` text is capped at 50 characters** on DB2 for i; +longer text raises `SQL0107`. Column labels have the same cap. + **Clause order matters.** On DB2 for i, `FOR COLUMN` goes **between the column name and the data type**, not after the data type. Placing it after `CHAR(...)` / `VARCHAR(...)` triggers the CCSID-modifier grammar (the parser @@ -202,3 +224,102 @@ trigger a rebuild. **`qddlsrc/example_reference.table.sql`** in this module demonstrates every one of these conventions in a single file. When adding a new table, copy that file, rename it, and edit — don't start from scratch. + +--- + +## 13. RPG / SQLRPGLE conventions + +Style rules that came out of PERP-19 (docseq service program) and the PERP-2 +maintenance programs. These apply to every RPG or SQLRPGLE source under +`perp/qrpglesrc/`. + +- **Modern `**FREE`**, first column of the file — no leading whitespace on + the `**free` directive itself (RPG `RNF0257`/`RNF7503` cascade otherwise). +- **`ctl-opt dftactgrp(*no) actgrp(*new)`** — real activation-group scoping; + no default-actgrp fallback. +- **No `SET OPTION COMMIT = *NONE`.** Every PERP table is journaled, so RPG + runs under real commitment control (`commit(*chg)` — the default of + `CRTSQLRPGI`). Callers issue `EXEC SQL COMMIT` / `ROLLBACK`; leaf modules + don't. +- **Schema-qualified table names** in embedded SQL — `perpdemo.company` etc. + `CRTSQLRPGI` on this environment does not accept `DFTRDBCOL` via the + codermake recipe, and the aitool / SSH invocation paths run outside the + PERPDEMO library list. Hard-qualifying keeps every path working. +- **Host-variable names must not collide with column names.** DB2 for i's + SQLRPGLE precompiler raises `SQL0314` ("host variable X not unique") + when an unqualified `:name` in a WHERE clause matches a column of the + referenced table AND a subprocedure parameter. Prefix parms (`nx_`, `pk_`, + `in_`). +- **Host-variable scope is *module*, not *subprocedure*.** The precompiler + does not respect `dcl-proc` scope when collecting host variables — two + subprocedures with parameter names in common raise `SQL0314`. Give every + subprocedure a distinct prefix. +- **`FROM FINAL TABLE (…)` supports `INSERT` only on DB2 for i V7R4.** + Precompiler rejects `UPDATE`/`DELETE` variants with `SQL0199`. Use + `UPDATE` + subsequent `SELECT` inside the same unit-of-work (row lock is + held under `commit(*chg)`). +- **Service programs**: one prototype `.rpgle` per module, referenced via + `/copy`; explicit `.bnd` export list in `perp/qsrvsrc/`; binding + directory qualifies srvpgm names with `$LIBRARY` so callers do not need + PERPDEMO on their library list at activation time. +- **Data-area handles**: use `dcl-ds NAME dtaara(*lda) len(1024) qualified` + and reserve positions in the LDA — every job has an LDA automatically, so + no runtime `CRTDTAARA` is needed. PERP session state (currently just the + selected company code at positions 1-3) lives in the LDA. + +## 14. DSPF conventions + +- **`DSPSIZ(24 80 *DS3)`** — 5250 24×80 baseline (not 27×132). +- **`SFLPAG`** must be conservative enough to fit the display size minus + header rows minus footer minus one for the `SFLEND(*MORE)` indicator. + `CPD7817` (value on SFLPAG too large) will bite otherwise. `SFLPAG(0007)` + is the safe default this module has been using. +- **Do not repeat file-level command-attention keys on a record** + (`CPD7597` "keyword not allowed at both file and record level"). Declare + `CA03/CA05/CA06/CA12` once at file level. +- **Standard F-key legend on every DSPF**: F3=Exit, F5=Refresh, F6=Add, + F12=Cancel — declared at file level and echoed in the footer line. +- **Message subfile** (`R xMSGSFL` / `R xMSGCTL`) attached at row 24 on + every screen; RPG uses `QMHSNDPM` to post messages. + +## 15. codermake gotchas + +- **`.menu` recipe needs `.file` as a *normal* prerequisite**, not + order-only. `foo.menu: foo.msgf foo.file` builds; `foo.menu: foo.msgf | + foo.file` silently drops the recipe (make says "Nothing to be done" and + the menu is never created). +- **`CRTSQLRPGI` does not accept `DFTRDBCOL` through codermake's compile + options** — the recipe hard-codes its flags. Qualify table references + in RPG source instead of relying on a runtime library list. +- **Binding directory sources** should qualify service-program references + with `$LIBRARY` (`addbnddire … obj(($LIBRARY/mysrvpgm *srvpgm *immed))`) + so activation-time lookup does not depend on the caller's library list. +- **Menu DSPF record format name must match the menu object name.** + `CRTMNU TYPE(*DSPF)` looks for a record format whose name equals the + menu name (e.g. menu `PERPMNU` requires `A R PERPMNU` in the DSPF). + Wrong name compiles fine but calling `GO PERPMNU` fails at runtime with + `Record format for menu definition not found. Problem displaying menu + PERPMNU in library PERPDEMO.` +- **`CRTSRCPF … TEXT(...)` caps at 50 characters** — CPD0074 fires on + longer strings. Keep source-PF text descriptions terse. + +## 16. Source physical files in PERPDEMO + +Every source type used by the module needs a matching source PF on the +IBM i target. `codermake` copies sources into these files at sync time. +Create them once when standing up a new task/build library: + +``` +CRTSRCPF FILE(PERPDEMO/QDDLSRC) RCDLEN(112) TEXT('PERP - SQL DDL source') +CRTSRCPF FILE(PERPDEMO/QDDSSRC) RCDLEN(112) TEXT('PERP - DDS source') +CRTSRCPF FILE(PERPDEMO/QRPGLESRC) RCDLEN(112) TEXT('PERP - RPG ILE / SQLRPGLE') +CRTSRCPF FILE(PERPDEMO/QCLSRC) RCDLEN(112) TEXT('PERP - CL / CLLE source') +CRTSRCPF FILE(PERPDEMO/QSRVSRC) RCDLEN(112) TEXT('PERP - Binder/Service pgm') +CRTSRCPF FILE(PERPDEMO/QMENUSRC) RCDLEN(112) TEXT('PERP - Menu source') +CRTSRCPF FILE(PERPDEMO/QCMDSRC) RCDLEN(112) TEXT('PERP - Command source') +CRTSRCPF FILE(PERPDEMO/QPNLSRC) RCDLEN(112) TEXT('PERP - Panel group source') +CRTSRCPF FILE(PERPDEMO/QSQLSRC) RCDLEN(112) TEXT('PERP - SQL source') +``` + +`QDDLSRC` was missing at PERP-2 initial cutover and was created after +the fact; keep it as part of the PERPDEMO bootstrap for future clones. diff --git a/perp/Rules.mk b/perp/Rules.mk index c8c06502..1419c84b 100644 --- a/perp/Rules.mk +++ b/perp/Rules.mk @@ -24,7 +24,52 @@ # already exist (created by CALL PERPJRN — see qclsrc/perpjrn.clle). example_reference.file: qddlsrc/example_reference.table.sql | perpsjpf.pgm -# (First real business tables land under PERP-2 Company & System Reference.) +# --- PERP-2: Company & System Reference tables --------------------------- +# Multi-tenant root + generic lookup + per-tenant configuration. +# FK order: company is created first; document_sequence, company_config, +# and perp_user follow (perp_user FKs code_master(USERROLE), so +# code_master is a normal prereq). +company.file: qddlsrc/company.table.sql | perpsjpf.pgm +code_master.file: qddlsrc/code_master.table.sql | perpsjpf.pgm +document_sequence.file: qddlsrc/document_sequence.table.sql company.file | perpsjpf.pgm +company_config.file: qddlsrc/company_config.table.sql company.file | perpsjpf.pgm +perp_user.file: qddlsrc/perp_user.table.sql code_master.file | perpsjpf.pgm + + +# --- PERP-19: Document sequence service ---------------------------------- +# Atomic per-(company, doc_type) sequence allocator. Module + srvpgm + bnddir. +docseq.module: qrpglesrc/docseq.sqlrpgle qrpglesrc/docseq_pr.rpgle | company_config.file document_sequence.file +docseq.srvpgm: docseq.module qsrvsrc/docseq.bnd +perp.bnddir: perp.bnddir + +# Smoke-test caller for docseq — CALL PERPDEMO/DOCSEQSMK PARM('ACM' 'PO '). +docseqsmk.pgm: qrpglesrc/docseqsmk.sqlrpgle qrpglesrc/docseq_pr.rpgle docseq.srvpgm | perp.bnddir document_sequence.file + + +# --- PERP-16: Company selection utility ---------------------------------- +# Writes the picked company code to *LDA[1:3] for downstream PERP programs. +perpseld.file: qddssrc/perpseld.dspf +perpselr.pgm: qrpglesrc/perpselr.sqlrpgle qddssrc/perpseld.dspf | perpseld.file company.file + + +# --- PERP-17: Code-master maintenance program ---------------------------- +wrkcmd.file: qddssrc/wrkcmd.dspf +wrkcmr.pgm: qrpglesrc/wrkcmr.sqlrpgle qddssrc/wrkcmd.dspf | wrkcmd.file code_master.file + + +# --- PERP-18: perp_user maintenance program ------------------------------ +wrkusrd.file: qddssrc/wrkusrd.dspf +wrkusrr.pgm: qrpglesrc/wrkusrr.sqlrpgle qddssrc/wrkusrd.dspf | wrkusrd.file perp_user.file code_master.file + + +# --- PERP main menu (glue for exploratory verification) ------------------ +# Ties the PERP-16/17/18/19 programs together into a single 5250 menu: +# GO PERPDEMO/PERPMNU +perpmnu.file: qddssrc/perpmnu.dspf +perpmnu.msgf: perpmnu.msgf +# .file MUST be a normal prereq (not order-only) or codermake silently drops +# the CRTMNU recipe. See DDL_STYLE_GUIDE § "codermake menu gotcha". +perpmnu.menu: perpmnu.msgf perpmnu.file | perpselr.pgm wrkcmr.pgm wrkusrr.pgm docseqsmk.pgm # --- CL setup ------------------------------------------------------------- diff --git a/perp/perp.bnddir b/perp/perp.bnddir new file mode 100644 index 00000000..0b2e022c --- /dev/null +++ b/perp/perp.bnddir @@ -0,0 +1,2 @@ +crtbnddir bnddir($LIBRARY/$NAME) +addbnddire bnddir($LIBRARY/$NAME) obj(($LIBRARY/docseq *srvpgm *immed)) diff --git a/perp/perpmnu.msgf b/perp/perpmnu.msgf new file mode 100644 index 00000000..f52b1c7c --- /dev/null +++ b/perp/perpmnu.msgf @@ -0,0 +1,6 @@ +crtmsgf msgf($LIBRARY/$NAME) +addmsgd msgid(usr0001) msgf($LIBRARY/$NAME) msg('call perpselr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0002) msgf($LIBRARY/$NAME) msg('call wrkcmr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0003) msgf($LIBRARY/$NAME) msg('call wrkusrr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0004) msgf($LIBRARY/$NAME) msg('call docseqsmk parm(''ACM'' ''PO '')') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0090) msgf($LIBRARY/$NAME) msg('signoff') seclvl(*none) sev(00) fmt(*none) diff --git a/perp/qddlsrc/code_master.table.sql b/perp/qddlsrc/code_master.table.sql new file mode 100644 index 00000000..97cb58fb --- /dev/null +++ b/perp/qddlsrc/code_master.table.sql @@ -0,0 +1,52 @@ +-- --------------------------------------------------------------------------- +-- Table: code_master (system name CODEMSTR) +-- Module: perp +-- Purpose: Generic lookup table. Every enum/status/code/role in PERP +-- lives here keyed on (code_type, code_value). Business tables +-- reference it via a composite FK plus a constant-discriminator +-- column (DEFAULT + CHECK — see DDL_STYLE_GUIDE §10). +-- Epic: PERP-2 (Company & System Reference) +-- --------------------------------------------------------------------------- + +CREATE TABLE code_master FOR SYSTEM NAME CODEMSTR ( + + -- Composite natural key ------------------------------------------------- + code_type FOR COLUMN CODETYP VARCHAR(20) NOT NULL, + code_value FOR COLUMN CODEVAL VARCHAR(20) NOT NULL, + + -- Descriptive columns --------------------------------------------------- + description FOR COLUMN CODEDSC VARCHAR(60) NOT NULL, + short_desc FOR COLUMN SHTDSC VARCHAR(20) NOT NULL DEFAULT '', + sort_order FOR COLUMN SRTORD INTEGER NOT NULL DEFAULT 0, + + -- Free-form attributes (JSON-style extras). CLOB, not JSON, to keep the + -- table portable to older DB2 for i releases. + attributes FOR COLUMN ATTRS CLOB(4K) DEFAULT NULL, + + -- Standard audit block -------------------------------------------------- + created_at FOR COLUMN CRTAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + created_by FOR COLUMN CRTBY VARCHAR(18) NOT NULL DEFAULT USER, + updated_at FOR COLUMN UPDAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_by FOR COLUMN UPDBY VARCHAR(18) NOT NULL DEFAULT USER, + is_active FOR COLUMN ISACT CHAR(1) NOT NULL DEFAULT 'Y', + + -- Composite primary key ------------------------------------------------- + PRIMARY KEY (code_type, code_value), + + -- Constraints ----------------------------------------------------------- + CONSTRAINT codemstr_srtord_ck CHECK (sort_order >= 0), + CONSTRAINT codemstr_isact_ck CHECK (is_active IN ('Y','N')) +); + +LABEL ON TABLE code_master IS + 'PERP generic lookup (statuses/roles/etc.)'; + +LABEL ON COLUMN code_master ( + code_type IS 'Code type / group (e.g. POSTATUS, USERROLE)', + code_value IS 'Code value within the type', + description IS 'Long description', + short_desc IS 'Short description (list / column display)', + sort_order IS 'Presentation sort order', + attributes IS 'Free-form JSON-style attributes (nullable)', + is_active IS 'Active flag (Y/N, soft delete)' +); diff --git a/perp/qddlsrc/company.table.sql b/perp/qddlsrc/company.table.sql new file mode 100644 index 00000000..f6b39347 --- /dev/null +++ b/perp/qddlsrc/company.table.sql @@ -0,0 +1,63 @@ +-- --------------------------------------------------------------------------- +-- Table: company (system name COMPANY) +-- Module: perp +-- Purpose: Multi-tenant root. Every business table in PERP FKs its +-- company_code column back to this table. +-- Epic: PERP-2 (Company & System Reference) +-- --------------------------------------------------------------------------- + +-- Note on FOR SYSTEM NAME here: 'company' as a SQL table name auto-derives +-- to the 10-char system name COMPANY. On DB2 for i, specifying FOR SYSTEM +-- NAME with a value equal to that auto-derivation raises SQL7029 - so we +-- omit it. Same rule applies to any FOR COLUMN whose value would equal the +-- column's auto-derived short name (see 'city_name' below - renamed from +-- 'city' so an explicit FOR COLUMN CITY is meaningful). +CREATE TABLE company ( + + -- Natural / multi-tenant key -------------------------------------------- + company_code FOR COLUMN COMPCD CHAR(3) NOT NULL, + + -- Descriptive columns --------------------------------------------------- + company_name FOR COLUMN COMPNM VARCHAR(60) NOT NULL, + address_line1 FOR COLUMN ADDR1 VARCHAR(60) NOT NULL DEFAULT '', + address_line2 FOR COLUMN ADDR2 VARCHAR(60) NOT NULL DEFAULT '', + city_name FOR COLUMN CITY VARCHAR(40) NOT NULL DEFAULT '', + state_code FOR COLUMN STATE VARCHAR(3) NOT NULL DEFAULT '', + postal_code FOR COLUMN POSTCD VARCHAR(12) NOT NULL DEFAULT '', + country_code FOR COLUMN CNTRY VARCHAR(3) NOT NULL DEFAULT 'US', + + -- Base currency (FK to code_master CURRENCY) --------------------------- + base_currency FOR COLUMN BASECUR VARCHAR(20) NOT NULL DEFAULT 'USD', + currency_type FOR COLUMN CURTYP VARCHAR(20) NOT NULL DEFAULT 'CURRENCY', + + -- Standard audit block -------------------------------------------------- + created_at FOR COLUMN CRTAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + created_by FOR COLUMN CRTBY VARCHAR(18) NOT NULL DEFAULT USER, + updated_at FOR COLUMN UPDAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_by FOR COLUMN UPDBY VARCHAR(18) NOT NULL DEFAULT USER, + is_active FOR COLUMN ISACT CHAR(1) NOT NULL DEFAULT 'Y', + + -- Primary key ----------------------------------------------------------- + PRIMARY KEY (company_code), + + -- Constraints ----------------------------------------------------------- + CONSTRAINT company_isact_ck CHECK (is_active IN ('Y','N')), + CONSTRAINT company_curtyp_ck CHECK (currency_type = 'CURRENCY') +); + +LABEL ON TABLE company IS + 'PERP company / tenant root'; + +LABEL ON COLUMN company ( + company_code IS 'Company code (multi-tenant PK)', + company_name IS 'Company display name', + address_line1 IS 'Address line 1', + address_line2 IS 'Address line 2', + city_name IS 'City', + state_code IS 'State / province code', + postal_code IS 'Postal / ZIP code', + country_code IS 'ISO country code', + base_currency IS 'Base currency (FK to code_master CURRENCY)', + currency_type IS 'Currency type discriminator (constant)', + is_active IS 'Active flag (Y/N, soft delete)' +); diff --git a/perp/qddlsrc/company_config.table.sql b/perp/qddlsrc/company_config.table.sql new file mode 100644 index 00000000..b10de5a8 --- /dev/null +++ b/perp/qddlsrc/company_config.table.sql @@ -0,0 +1,47 @@ +-- --------------------------------------------------------------------------- +-- Table: company_config (system name COMPCFG) +-- Module: perp +-- Purpose: Per-company key/value config. Auto-approval thresholds and +-- other tunables live here rather than being hard-coded. +-- Epic: PERP-2 (Company & System Reference) +-- --------------------------------------------------------------------------- + +CREATE TABLE company_config FOR SYSTEM NAME COMPCFG ( + + -- Composite key --------------------------------------------------------- + company_code FOR COLUMN COMPCD CHAR(3) NOT NULL, + config_key FOR COLUMN CFGKEY VARCHAR(40) NOT NULL, + + -- Value + description --------------------------------------------------- + config_value FOR COLUMN CFGVAL VARCHAR(256) NOT NULL DEFAULT '', + description FOR COLUMN CFGDSC VARCHAR(60) NOT NULL DEFAULT '', + + -- Standard audit block -------------------------------------------------- + created_at FOR COLUMN CRTAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + created_by FOR COLUMN CRTBY VARCHAR(18) NOT NULL DEFAULT USER, + updated_at FOR COLUMN UPDAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_by FOR COLUMN UPDBY VARCHAR(18) NOT NULL DEFAULT USER, + is_active FOR COLUMN ISACT CHAR(1) NOT NULL DEFAULT 'Y', + + -- Composite PK ---------------------------------------------------------- + PRIMARY KEY (company_code, config_key), + + -- Constraints ----------------------------------------------------------- + CONSTRAINT compcfg_isact_ck CHECK (is_active IN ('Y','N')), + + -- FK to company --------------------------------------------------------- + CONSTRAINT compcfg_company_fk FOREIGN KEY (company_code) + REFERENCES company (company_code) + ON DELETE RESTRICT ON UPDATE RESTRICT +); + +LABEL ON TABLE company_config IS + 'PERP per-company config key/value pairs'; + +LABEL ON COLUMN company_config ( + company_code IS 'Company code (FK to company)', + config_key IS 'Config key (dotted namespace, e.g. approval.auto_threshold)', + config_value IS 'Config value (string; caller parses)', + description IS 'Human-readable description of the key', + is_active IS 'Active flag (Y/N, soft delete)' +); diff --git a/perp/qddlsrc/document_sequence.table.sql b/perp/qddlsrc/document_sequence.table.sql new file mode 100644 index 00000000..136f89b2 --- /dev/null +++ b/perp/qddlsrc/document_sequence.table.sql @@ -0,0 +1,49 @@ +-- --------------------------------------------------------------------------- +-- Table: document_sequence (system name DOCSEQ) +-- Module: perp +-- Purpose: High-water mark per (company, document_type). Callers +-- atomically bump current_number to get the next doc number +-- for requisitions, POs, receipts. +-- Epic: PERP-2 (Company & System Reference) +-- --------------------------------------------------------------------------- + +CREATE TABLE document_sequence FOR SYSTEM NAME DOCSEQ ( + + -- Composite key --------------------------------------------------------- + company_code FOR COLUMN COMPCD CHAR(3) NOT NULL, + document_type FOR COLUMN DOCTYP VARCHAR(20) NOT NULL, + + -- Sequence state -------------------------------------------------------- + current_number FOR COLUMN CURNUM BIGINT NOT NULL DEFAULT 0, + description FOR COLUMN DOCDSC VARCHAR(60) NOT NULL DEFAULT '', + + -- Standard audit block -------------------------------------------------- + created_at FOR COLUMN CRTAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + created_by FOR COLUMN CRTBY VARCHAR(18) NOT NULL DEFAULT USER, + updated_at FOR COLUMN UPDAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_by FOR COLUMN UPDBY VARCHAR(18) NOT NULL DEFAULT USER, + is_active FOR COLUMN ISACT CHAR(1) NOT NULL DEFAULT 'Y', + + -- Composite PK ---------------------------------------------------------- + PRIMARY KEY (company_code, document_type), + + -- Constraints ----------------------------------------------------------- + CONSTRAINT docseq_curnum_ck CHECK (current_number >= 0), + CONSTRAINT docseq_isact_ck CHECK (is_active IN ('Y','N')), + + -- FK to company --------------------------------------------------------- + CONSTRAINT docseq_company_fk FOREIGN KEY (company_code) + REFERENCES company (company_code) + ON DELETE RESTRICT ON UPDATE RESTRICT +); + +LABEL ON TABLE document_sequence IS + 'PERP per-company doc-number high-water marks'; + +LABEL ON COLUMN document_sequence ( + company_code IS 'Company code (FK to company)', + document_type IS 'Document type key (REQ, PO, RCP, ...)', + current_number IS 'Last-issued document number (bump before use)', + description IS 'Human-readable document-type label', + is_active IS 'Active flag (Y/N, soft delete)' +); diff --git a/perp/qddlsrc/perp_user.table.sql b/perp/qddlsrc/perp_user.table.sql new file mode 100644 index 00000000..a0d27abb --- /dev/null +++ b/perp/qddlsrc/perp_user.table.sql @@ -0,0 +1,56 @@ +-- --------------------------------------------------------------------------- +-- Table: perp_user (system name PERPUSR) +-- Module: perp +-- Purpose: Application-level user directory. Typically maps 1:1 to an +-- IBM i user profile, but carries role + display attributes +-- used throughout PERP (buyer/receiver/approver/requester). +-- Epic: PERP-2 (Company & System Reference) +-- --------------------------------------------------------------------------- + +-- SQL name 'perp_user' is itself a valid ≤10-char system name (underscores +-- allowed), so DB2 for i rejects a different FOR SYSTEM NAME with SQL7029. +-- The system name auto-derives to PERP_USER; RPG references it that way. +CREATE TABLE perp_user ( + + -- Natural key ----------------------------------------------------------- + user_code FOR COLUMN USRCD CHAR(10) NOT NULL, + + -- Descriptive columns --------------------------------------------------- + display_name FOR COLUMN DSPNM VARCHAR(60) NOT NULL DEFAULT '', + email_address FOR COLUMN EMAIL VARCHAR(120) NOT NULL DEFAULT '', + + -- Role (FK to code_master USERROLE) ------------------------------------ + role_code FOR COLUMN ROLECD VARCHAR(20) NOT NULL DEFAULT 'REQUESTER', + role_type FOR COLUMN ROLETYP VARCHAR(20) NOT NULL DEFAULT 'USERROLE', + + -- Standard audit block -------------------------------------------------- + created_at FOR COLUMN CRTAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + created_by FOR COLUMN CRTBY VARCHAR(18) NOT NULL DEFAULT USER, + updated_at FOR COLUMN UPDAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_by FOR COLUMN UPDBY VARCHAR(18) NOT NULL DEFAULT USER, + is_active FOR COLUMN ISACT CHAR(1) NOT NULL DEFAULT 'Y', + + -- Primary key ----------------------------------------------------------- + PRIMARY KEY (user_code), + + -- Constraints ----------------------------------------------------------- + CONSTRAINT perpusr_isact_ck CHECK (is_active IN ('Y','N')), + CONSTRAINT perpusr_roletyp_ck CHECK (role_type = 'USERROLE'), + + -- FK to code_master (USERROLE) ----------------------------------------- + CONSTRAINT perpusr_role_fk FOREIGN KEY (role_type, role_code) + REFERENCES code_master (code_type, code_value) + ON DELETE RESTRICT ON UPDATE RESTRICT +); + +LABEL ON TABLE perp_user IS + 'PERP application user directory'; + +LABEL ON COLUMN perp_user ( + user_code IS 'User code (typically IBM i user profile, PK)', + display_name IS 'Display name', + email_address IS 'Email address', + role_code IS 'Role (FK to code_master USERROLE)', + role_type IS 'Role type discriminator (constant)', + is_active IS 'Active flag (Y/N, soft delete)' +); diff --git a/perp/qddlsrc/seed/010_code_master.sql b/perp/qddlsrc/seed/010_code_master.sql new file mode 100644 index 00000000..9439e9c6 --- /dev/null +++ b/perp/qddlsrc/seed/010_code_master.sql @@ -0,0 +1,69 @@ +-- --------------------------------------------------------------------------- +-- Seed: 010_code_master +-- Module: perp +-- Purpose: Populate code_master with the system lookups that other epics +-- need to be able to reference. Idempotent — DELETE by +-- code_type first, then INSERT. Safe to re-run. +-- Epic: PERP-2 (PERP-15) +-- --------------------------------------------------------------------------- + +DELETE FROM code_master + WHERE code_type IN + ('REQSTATUS','POSTATUS','RCPSTATUS','CURRENCY', + 'PRIORITY','APPRSRC','USERROLE'); + +-- REQSTATUS — requisition status ------------------------------------------ +INSERT INTO code_master + (code_type, code_value, description, short_desc, sort_order) VALUES + ('REQSTATUS','DRAFT', 'Draft', 'Draft', 10), + ('REQSTATUS','SUBMITTED','Submitted', 'Submitted',20), + ('REQSTATUS','APPROVED', 'Approved', 'Approved', 30), + ('REQSTATUS','REJECTED', 'Rejected', 'Rejected', 40), + ('REQSTATUS','CONVERTED','Converted to PO','Converted',50), + ('REQSTATUS','CANCELLED','Cancelled', 'Cancelled',60); + +-- POSTATUS — purchase order status ---------------------------------------- +INSERT INTO code_master + (code_type, code_value, description, short_desc, sort_order) VALUES + ('POSTATUS','DRAFT', 'Draft', 'Draft', 10), + ('POSTATUS','OPEN', 'Open', 'Open', 20), + ('POSTATUS','PARTIAL', 'Partially received','Partial', 30), + ('POSTATUS','RECEIVED', 'Fully received', 'Received', 40), + ('POSTATUS','CLOSED', 'Closed', 'Closed', 50), + ('POSTATUS','CANCELLED','Cancelled', 'Cancelled',60); + +-- RCPSTATUS — receipt status ---------------------------------------------- +INSERT INTO code_master + (code_type, code_value, description, short_desc, sort_order) VALUES + ('RCPSTATUS','DRAFT', 'Draft', 'Draft', 10), + ('RCPSTATUS','POSTED','Posted', 'Posted',20), + ('RCPSTATUS','VOIDED','Voided', 'Voided',30); + +-- CURRENCY — currencies (single value for now) ---------------------------- +INSERT INTO code_master + (code_type, code_value, description, short_desc, sort_order) VALUES + ('CURRENCY','USD','US Dollar','USD',10); + +-- PRIORITY — request / order priority ------------------------------------- +INSERT INTO code_master + (code_type, code_value, description, short_desc, sort_order) VALUES + ('PRIORITY','LOW', 'Low', 'Low', 10), + ('PRIORITY','NORMAL', 'Normal', 'Normal', 20), + ('PRIORITY','HIGH', 'High', 'High', 30), + ('PRIORITY','CRITICAL','Critical', 'Critical',40); + +-- APPRSRC — approval source ----------------------------------------------- +INSERT INTO code_master + (code_type, code_value, description, short_desc, sort_order) VALUES + ('APPRSRC','HUMAN', 'Human approver', 'Human', 10), + ('APPRSRC','CODERFLOW', 'CoderFlow AI approver', 'AI', 20), + ('APPRSRC','AUTO_THRESHOLD','Auto-approved (threshold)','Auto', 30); + +-- USERROLE — application role -------------------------------------------- +INSERT INTO code_master + (code_type, code_value, description, short_desc, sort_order) VALUES + ('USERROLE','BUYER', 'Buyer', 'Buyer', 10), + ('USERROLE','RECEIVER', 'Receiver', 'Receiver',20), + ('USERROLE','APPROVER', 'Approver', 'Approver',30), + ('USERROLE','REQUESTER','Requester', 'Requester',40), + ('USERROLE','ADMIN', 'System administrator','Admin', 50); diff --git a/perp/qddssrc/perpmnu.dspf b/perp/qddssrc/perpmnu.dspf new file mode 100644 index 00000000..a52318f7 --- /dev/null +++ b/perp/qddssrc/perpmnu.dspf @@ -0,0 +1,35 @@ + A* PERP main menu + A DSPSIZ(24 80 *DS3) + A CHGINPDFT + A INDARA + A PRINT(*LIBL/QSYSPRT) + A* CRTMNU TYPE(*DSPF) looks for a record format whose name matches + A* the menu object name (PERPMNU). Using 'R MENU' produces the + A* runtime error 'Record format for menu definition not found.' + A R PERPMNU + A LOCK + A SLNO(01) + A CLRL(*ALL) + A ALWROL + A CF03 + A HELP + A HOME + A HLPRTN + A 1 2'PERPMNU' + A COLOR(BLU) + A 1 25'PreSales ERP (PERP) — Main Me- + A nu' + A DSPATR(HI) + A COLOR(WHT) + A 3 2'Select one of the following:' + A COLOR(BLU) + A 5 7'1. Select company for session' + A 6 7'2. Work with system codes (co- + A de_master)' + A 7 7'3. Work with PERP users' + A 8 7'4. Smoke test doc-sequence se- + A rvice' + A 10 6'90. Sign off' + A* CMDPROMPT Do not delete this DDS spec. + A 021 2'Selection: - + A ' diff --git a/perp/qddssrc/perpseld.dspf b/perp/qddssrc/perpseld.dspf new file mode 100644 index 00000000..22568fd1 --- /dev/null +++ b/perp/qddssrc/perpseld.dspf @@ -0,0 +1,54 @@ + A DSPSIZ(24 80 *DS3) + A PRINT + A CA03(03 'Exit') + A CA05(05 'Refresh') + A CA12(12 'Cancel') + A R COSFL SFL + A 51 SFLNXTCHG + A SOPT 1A B 8 4 + A 50 DSPATR(RI) + A 50 DSPATR(PC) + A SCOMPC 3A O 8 9 + A SCOMPN 60A O 8 15 + A SCURR 20A O 8 76 + A R COCTL SFLCTL(COSFL) + A SFLSIZ(0099) + A SFLPAG(0007) + A OVERLAY + A SFLDSPCTL + A N31 30 SFLDSP + A 31 SFLCLR + A N31 30 SFLEND(*MORE) + A 1 30'Select PERP Company' + A DSPATR(HI) + A 2 2'Currently selected . . :' + A SCURSEL 3A O 2 30DSPATR(HI) + A 4 2'Type option, press Enter.' + A 5 4'1=Select this company' + A 7 4'Opt' + A DSPATR(UL) + A 7 9'Code' + A DSPATR(UL) + A 7 15'Company name' + A DSPATR(UL) + A 7 76'Curr' + A DSPATR(UL) + A R COFOOT + A 23 2'F3=Exit F5=Refresh F12=Ca- + A ncel' + A COLOR(BLU) + A R CONONE + A OVERLAY + A 10 20'** No active companies to di- + A splay **' + A R COMSGSFL SFL + A SFLMSGRCD(24) + A SMSGKEY SFLMSGKEY + A SPGMQ SFLPGMQ(10) + A R COMSGCTL SFLCTL(COMSGSFL) + A OVERLAY + A N41 40 SFLDSP + A 41 SFLCLR + A N41 40 SFLEND + A SFLSIZ(0002) + A SFLPAG(0001) diff --git a/perp/qddssrc/wrkcmd.dspf b/perp/qddssrc/wrkcmd.dspf new file mode 100644 index 00000000..bdcaf985 --- /dev/null +++ b/perp/qddssrc/wrkcmd.dspf @@ -0,0 +1,75 @@ + A DSPSIZ(24 80 *DS3) + A PRINT + A CA03(03 'Exit') + A CA05(05 'Refresh') + A CA06(06 'Add') + A CA12(12 'Cancel') + A R CMSFL SFL + A 51 SFLNXTCHG + A SOPT 1A B 8 4 + A 50 DSPATR(RI) + A 50 DSPATR(PC) + A STYPE 20A O 8 9 + A SVALUE 20A O 8 31 + A SDESC 30A O 8 53 + A R CMCTL SFLCTL(CMSFL) + A SFLSIZ(0099) + A SFLPAG(0007) + A OVERLAY + A SFLDSPCTL + A N31 30 SFLDSP + A 31 SFLCLR + A N31 30 SFLEND(*MORE) + A 1 30'Work with System Codes' + A DSPATR(HI) + A 2 2'Filter type . . :' + A SFTYPE 20A B 2 20DSPATR(HI) + A 4 2'Type option, press Enter.' + A 5 4'2=Change 4=Delete 5=Displ- + A ay' + A 7 4'Opt' + A DSPATR(UL) + A 7 9'Type' + A DSPATR(UL) + A 7 31'Value' + A DSPATR(UL) + A 7 53'Description' + A DSPATR(UL) + A R CMFOOT + A 23 2'F3=Exit F5=Refresh F6=Add- + A F12=Cancel' + A COLOR(BLU) + A R CMNONE + A OVERLAY + A 10 20'** No code entries match the - + A filter **' + A R CMEDIT + A OVERLAY + A 1 30'Edit Code' + A DSPATR(HI) + A EMODE 1A O 2 2 + A 3 2'Type:' + A ETYPE 20A B 3 10 + A 4 2'Value:' + A EVALUE 20A B 4 10 + A 5 2'Description:' + A EDESC 60A B 5 15 + A 6 2'Short:' + A ESHORT 20A B 6 15 + A 7 2'Sort:' + A ESORT 6Y 0B 7 15EDTCDE(Z) + A 8 2'Active:' + A EACTIVE 1A B 8 15 + A 23 2'Enter=Save F12=Cancel' + A COLOR(BLU) + A R CMMSGSFL SFL + A SFLMSGRCD(24) + A SMSGKEY SFLMSGKEY + A SPGMQ SFLPGMQ(10) + A R CMMSGCTL SFLCTL(CMMSGSFL) + A OVERLAY + A N41 40 SFLDSP + A 41 SFLCLR + A N41 40 SFLEND + A SFLSIZ(0002) + A SFLPAG(0001) diff --git a/perp/qddssrc/wrkusrd.dspf b/perp/qddssrc/wrkusrd.dspf new file mode 100644 index 00000000..1abfb5ef --- /dev/null +++ b/perp/qddssrc/wrkusrd.dspf @@ -0,0 +1,73 @@ + A DSPSIZ(24 80 *DS3) + A PRINT + A CA03(03 'Exit') + A CA05(05 'Refresh') + A CA06(06 'Add') + A CA12(12 'Cancel') + A R USFL SFL + A 51 SFLNXTCHG + A SOPT 1A B 8 4 + A 50 DSPATR(RI) + A 50 DSPATR(PC) + A SUCODE 10A O 8 9 + A SUNAME 30A O 8 21 + A SUROLE 20A O 8 53 + A SUACT 1A O 8 75 + A R UCTL SFLCTL(USFL) + A SFLSIZ(0099) + A SFLPAG(0007) + A OVERLAY + A SFLDSPCTL + A N31 30 SFLDSP + A 31 SFLCLR + A N31 30 SFLEND(*MORE) + A 1 30'Work with PERP Users' + A DSPATR(HI) + A 4 2'Type option, press Enter.' + A 5 4'2=Change 4=Delete 5=Displ- + A ay' + A 7 4'Opt' + A DSPATR(UL) + A 7 9'User' + A DSPATR(UL) + A 7 21'Display name' + A DSPATR(UL) + A 7 53'Role' + A DSPATR(UL) + A 7 75'Act' + A DSPATR(UL) + A R UFOOT + A 23 2'F3=Exit F5=Refresh F6=Add- + A F12=Cancel' + A COLOR(BLU) + A R UNONE + A OVERLAY + A 10 20'** No users to display **' + A R UEDIT + A OVERLAY + A 1 30'Edit User' + A DSPATR(HI) + A EMODE 1A O 2 2 + A 3 2'User code:' + A EUCODE 10A B 3 15 + A 4 2'Display name:' + A EUNAME 60A B 4 17 + A 5 2'Email:' + A EUEMAIL 120A B 5 15 + A 6 2'Role:' + A EUROLE 20A B 6 15 + A 7 2'Active:' + A EUACT 1A B 7 15 + A 23 2'Enter=Save F12=Cancel' + A COLOR(BLU) + A R UMSGSFL SFL + A SFLMSGRCD(24) + A SMSGKEY SFLMSGKEY + A SPGMQ SFLPGMQ(10) + A R UMSGCTL SFLCTL(UMSGSFL) + A OVERLAY + A N41 40 SFLDSP + A 41 SFLCLR + A N41 40 SFLEND + A SFLSIZ(0002) + A SFLPAG(0001) diff --git a/perp/qrpglesrc/docseq.sqlrpgle b/perp/qrpglesrc/docseq.sqlrpgle new file mode 100644 index 00000000..ac9757ad --- /dev/null +++ b/perp/qrpglesrc/docseq.sqlrpgle @@ -0,0 +1,125 @@ +**free + +// --------------------------------------------------------------------- +// Module: docseq (document sequence service) +// Purpose: Return the next document number for a (company_code, +// document_type) pair. +// +// Strategy: UPDATE ... SET current_number = current_number+1 +// under commitment control (row-locked by DB2). If the row +// did not exist (SQLCODE=100 on the UPDATE), INSERT it at 1. +// Otherwise read current_number back into :out — the row is +// locked to this unit-of-work so no other job can bump it +// between the UPDATE and the SELECT. +// +// Callers commit/rollback the unit-of-work; this module +// never issues COMMIT / ROLLBACK. +// +// Callers: requisition, PO, and PO-receipt entry programs. +// Epic: PERP-2 (PERP-19) +// --------------------------------------------------------------------- + +ctl-opt nomain; + +// Real commitment control against PERPJRN — per DDL_STYLE_GUIDE §7. +// (Absence of SET OPTION COMMIT = *NONE is deliberate.) +exec sql set option closqlcsr = *endmod; + +/copy docseq_pr.rpgle + +// --------------------------------------------------------------------- +// Host-variable naming: the SQLRPGLE precompiler does NOT respect +// subprocedure scope when collecting host variables. Parameter names +// are unique per procedure ('nx_' vs 'pk_' prefix) to avoid the +// SQL0314 "host variable not unique" error that fires when two +// subprocedures share a parm name across the module. +// --------------------------------------------------------------------- + +// docseq_next — bump and return the next document number. +dcl-proc docseq_next export; + dcl-pi *n int(20); + nx_company char(3) const; + nx_doctype varchar(20) const; + nx_errmsg varchar(80); + end-pi; + + dcl-s nx_number int(20) inz(0); + + nx_errmsg = ''; + + // Bump — acquires row lock under commit(*chg). + exec sql + update perpdemo.document_sequence + set current_number = current_number + 1, + updated_at = current_timestamp, + updated_by = user + where company_code = :nx_company + and document_type = :nx_doctype; + + if sqlcode = 100; + // No row yet — seed at 1. + exec sql + insert into perpdemo.document_sequence + (company_code, document_type, current_number, description) + values (:nx_company, :nx_doctype, 1, :nx_doctype); + if sqlcode < 0; + nx_errmsg = 'docseq_next insert: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate; + return 0; + endif; + return 1; + endif; + + if sqlcode < 0; + nx_errmsg = 'docseq_next update: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate; + return 0; + endif; + + // Row was updated — read it back. + exec sql + select current_number + into :nx_number + from perpdemo.document_sequence + where company_code = :nx_company + and document_type = :nx_doctype; + if sqlcode < 0; + nx_errmsg = 'docseq_next select: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate; + return 0; + endif; + + return nx_number; + +end-proc; + +// docseq_peek — read the current high-water mark WITHOUT bumping. +dcl-proc docseq_peek export; + dcl-pi *n int(20); + pk_company char(3) const; + pk_doctype varchar(20) const; + pk_errmsg varchar(80); + end-pi; + + dcl-s pk_number int(20) inz(0); + + pk_errmsg = ''; + + exec sql + select current_number + into :pk_number + from perpdemo.document_sequence + where company_code = :pk_company + and document_type = :pk_doctype; + + if sqlcode = 100; + return 0; + endif; + if sqlcode < 0; + pk_errmsg = 'docseq_peek: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate; + return 0; + endif; + return pk_number; + +end-proc; diff --git a/perp/qrpglesrc/docseq_pr.rpgle b/perp/qrpglesrc/docseq_pr.rpgle new file mode 100644 index 00000000..db54a0a1 --- /dev/null +++ b/perp/qrpglesrc/docseq_pr.rpgle @@ -0,0 +1,28 @@ +**free + +// --------------------------------------------------------------------- +// Prototypes: docseq (document sequence service) +// Module: perp +// Purpose: Atomic per-company document-number allocator. +// Callers: requisition entry (REQ), PO entry (PO), +// receipt entry (RCP), any future doc-number consumer. +// Epic: PERP-2 (PERP-19) +// --------------------------------------------------------------------- + +// docseq_next — bump the (company, doc_type) high-water mark and +// return the newly-issued number. Auto-inserts the sequence row +// starting at 1 on first use. Returns 0 on error; errmsg carries +// 'SQLCODE=... SQLSTATE=...'. Callers ROLLBACK on error. +dcl-pr docseq_next int(20); + company char(3) const; + doctype varchar(20) const; + errmsg varchar(80); +end-pr; + +// docseq_peek — read the current high-water mark WITHOUT bumping. +// Returns 0 if the row doesn't exist yet. +dcl-pr docseq_peek int(20); + company char(3) const; + doctype varchar(20) const; + errmsg varchar(80); +end-pr; diff --git a/perp/qrpglesrc/docseqsmk.sqlrpgle b/perp/qrpglesrc/docseqsmk.sqlrpgle new file mode 100644 index 00000000..7326c7e3 --- /dev/null +++ b/perp/qrpglesrc/docseqsmk.sqlrpgle @@ -0,0 +1,87 @@ +**free + +// --------------------------------------------------------------------- +// Program: docseqsmk (docseq smoke test) +// Purpose: One-shot caller that exercises docseq_next / docseq_peek and +// prints the results via SNDPGMMSG so a joblog + interactive +// session confirms the service program is bound correctly. +// Meant to be CALLed once from an interactive session: +// CALL PGM(PERPDEMO/DOCSEQSMK) PARM('ACM' 'PO ') +// Also runs a peek to prove no-op reads. +// Epic: PERP-2 (PERP-19) +// --------------------------------------------------------------------- + +ctl-opt dftactgrp(*no) actgrp(*new) bnddir('PERP'); + +/copy docseq_pr.rpgle + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-pi *n; + p_company char(3); + p_doctype char(3); +end-pi; + +dcl-s doctype varchar(20); +dcl-s errmsg varchar(80); +dcl-s n1 int(20); +dcl-s n2 int(20); +dcl-s peek int(20); +dcl-s line char(256); +dcl-s msgkey char(4); + +doctype = %trim(p_doctype); + +// Peek before bumping. +peek = docseq_peek(p_company : doctype : errmsg); +line = 'docseq peek before: ' + %char(peek) + ' err=' + errmsg; +callMsg(line); + +// First bump. +n1 = docseq_next(p_company : doctype : errmsg); +line = 'docseq_next #1: ' + %char(n1) + ' err=' + errmsg; +callMsg(line); + +// Second bump. +n2 = docseq_next(p_company : doctype : errmsg); +line = 'docseq_next #2: ' + %char(n2) + ' err=' + errmsg; +callMsg(line); + +// Commit so the bumps stick. +exec sql commit; + +// Peek after. +peek = docseq_peek(p_company : doctype : errmsg); +line = 'docseq peek after : ' + %char(peek) + ' err=' + errmsg; +callMsg(line); + +*inlr = *on; +return; + +dcl-proc callMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + msgkey : + x'0000000000000000'); +end-proc; diff --git a/perp/qrpglesrc/perpselr.sqlrpgle b/perp/qrpglesrc/perpselr.sqlrpgle new file mode 100644 index 00000000..bf904373 --- /dev/null +++ b/perp/qrpglesrc/perpselr.sqlrpgle @@ -0,0 +1,188 @@ +**free + +// --------------------------------------------------------------------- +// Program: perpselr (PERP company selection utility) +// Purpose: Interactive picker over the company table. On selection, +// persists the chosen company_code to the job's *LDA (positions +// 1-3), which every IBM i job has automatically. Downstream +// PERP programs read *LDA[1:3] to scope their queries. +// Session-local: the LDA vanishes when the job ends, exactly +// the behavior the epic asks for. +// Epic: PERP-2 (PERP-16) +// --------------------------------------------------------------------- + +ctl-opt dftactgrp(*no) actgrp(*new); + +dcl-f perpseld workstn sfile(cosfl:rrn) sfile(comsgsfl:msgrrn); + +// Local Data Area — every job has one, 1024 chars. Positions 1-3 hold +// the selected PERP company_code for downstream PERP programs. +dcl-ds ldaDS dtaara(*lda) len(1024) qualified; + compcd char(3) pos(1); +end-ds; + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-ds statusDS psds qualified; + programName char(10) pos(334); +end-ds; + +dcl-ds coRow qualified; + code char(3); + name varchar(60); + curr varchar(20); +end-ds; + +dcl-ds companies likeds(coRow) dim(200); +dcl-s numCo int(10); +dcl-s i int(10); +dcl-s rrn int(10); +dcl-s msgrrn int(10); +dcl-s selRrn int(10); +dcl-s msgkey char(4); + +in ldaDS; +scursel = ldaDS.compcd; + +dow not *in03 and not *in12; + exsr clearMsgs; + exsr loadCompanies; + + if numCo = 0; + *in30 = *off; + write conone; + else; + exsr fillSubfile; + *in30 = *on; + endif; + + write cofoot; + if msgrrn > 0; + *in40 = *on; + write comsgctl; + else; + *in40 = *off; + endif; + + exfmt coctl; + + if *in03 or *in12; + leave; + endif; + + if *in05; + iter; // refresh + endif; + + selRrn = 0; + readc cosfl; + dow not %eof(perpseld); + if sopt = '1'; + if selRrn = 0; + selRrn = rrn; + else; + writeMsg('Only one company may be selected per Enter.'); + endif; + elseif sopt <> ''; + writeMsg('Option ' + %trim(sopt) + ' is not valid - use 1.'); + endif; + readc cosfl; + enddo; + + if selRrn > 0 and msgrrn = 0; + chain selRrn cosfl; + ldaDS.compcd = scompc; + out ldaDS; + writeMsg('Company ' + ldaDS.compcd + ' selected for this session.'); + scursel = ldaDS.compcd; + endif; + +enddo; + +*inlr = *on; +return; + +// --------------------------------------------------------------------- +begsr loadCompanies; + numCo = 0; + exec sql declare cocsr cursor for + select company_code, company_name, base_currency + from perpdemo.company + where is_active = 'Y' + order by company_code; + exec sql open cocsr; + if sqlcode < 0; + writeMsg('SQL error opening cursor: ' + %char(sqlcode)); + return; + endif; + + dow numCo < %elem(companies); + exec sql fetch cocsr into :coRow; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + numCo += 1; + companies(numCo) = coRow; + enddo; + exec sql close cocsr; +endsr; + +// --------------------------------------------------------------------- +begsr fillSubfile; + rrn = 0; + *in31 = *on; + write coctl; + *in31 = *off; + for i = 1 to numCo; + *in50 = *off; + *in51 = *off; + sopt = ''; + scompc = companies(i).code; + scompn = companies(i).name; + scurr = companies(i).curr; + rrn += 1; + write cosfl; + endfor; +endsr; + +// --------------------------------------------------------------------- +begsr clearMsgs; + msgrrn = 0; + *in41 = *on; + write comsgctl; + *in41 = *off; +endsr; + +// --------------------------------------------------------------------- +dcl-proc writeMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + + dcl-s data char(256); + + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + smsgkey : + x'0000000000000000'); + msgrrn += 1; + spgmq = statusDS.programName; + write comsgsfl; +end-proc; diff --git a/perp/qrpglesrc/wrkcmr.sqlrpgle b/perp/qrpglesrc/wrkcmr.sqlrpgle new file mode 100644 index 00000000..484b63ed --- /dev/null +++ b/perp/qrpglesrc/wrkcmr.sqlrpgle @@ -0,0 +1,315 @@ +**free + +// --------------------------------------------------------------------- +// Program: wrkcmr (Work with Code Master) +// Purpose: DSPF-based CRUD for the code_master table. One screen shows +// all system lookups regardless of code_type; a filter field +// narrows the subfile to a specific type. Options 2/4/5 +// change/delete/display; F6 adds. Delete falls through to a +// DB2 FK violation (SQL0532/SQL0531) if the code is in use — +// RPG surfaces the SQLSTATE cleanly rather than pre-checking. +// Epic: PERP-2 (PERP-17) +// --------------------------------------------------------------------- + +ctl-opt dftactgrp(*no) actgrp(*new); + +dcl-f wrkcmd workstn sfile(cmsfl:rrn) sfile(cmmsgsfl:msgrrn); + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-ds statusDS psds qualified; + programName char(10) pos(334); +end-ds; + +dcl-ds cmRow qualified; + ctype varchar(20); + cvalue varchar(20); + cdesc varchar(60); + cshort varchar(20); + csort int(10); + cactive char(1); +end-ds; + +dcl-ds rows likeds(cmRow) dim(500); +dcl-s numRows int(10); +dcl-s i int(10); +dcl-s rrn int(10); +dcl-s msgrrn int(10); +dcl-s msgkey char(4); +dcl-s selRrn int(10); +dcl-s selOpt char(1); +dcl-s filter varchar(20); + +filter = ''; +sftype = ''; + +dow not *in03 and not *in12; + exsr clearMsgs; + exsr loadRows; + + if numRows = 0; + *in30 = *off; + write cmnone; + else; + exsr fillSubfile; + *in30 = *on; + endif; + + write cmfoot; + if msgrrn > 0; + *in40 = *on; + write cmmsgctl; + else; + *in40 = *off; + endif; + exfmt cmctl; + + if *in03 or *in12; + leave; + endif; + + if *in05; + filter = sftype; + iter; + endif; + + if *in06; + exsr addRow; + iter; + endif; + + // Refresh filter from screen entry + if sftype <> filter; + filter = sftype; + iter; + endif; + + // Process subfile options + selRrn = 0; + selOpt = ' '; + readc cmsfl; + dow not %eof(wrkcmd); + if sopt <> ''; + selRrn = rrn; + selOpt = sopt; + exsr handleOpt; + selRrn = 0; + endif; + readc cmsfl; + enddo; + +enddo; + +*inlr = *on; +return; + +// --------------------------------------------------------------------- +begsr loadRows; + numRows = 0; + if filter = ''; + exec sql declare c1 cursor for + select code_type, code_value, description, short_desc, + sort_order, is_active + from perpdemo.code_master + order by code_type, sort_order, code_value; + else; + exec sql declare c2 cursor for + select code_type, code_value, description, short_desc, + sort_order, is_active + from perpdemo.code_master + where code_type = :filter + order by sort_order, code_value; + endif; + + if filter = ''; + exec sql open c1; + else; + exec sql open c2; + endif; + if sqlcode < 0; + writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); + return; + endif; + + dow numRows < %elem(rows); + if filter = ''; + exec sql fetch c1 into :cmRow; + else; + exec sql fetch c2 into :cmRow; + endif; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + numRows += 1; + rows(numRows) = cmRow; + enddo; + + if filter = ''; + exec sql close c1; + else; + exec sql close c2; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr fillSubfile; + rrn = 0; + *in31 = *on; + write cmctl; + *in31 = *off; + for i = 1 to numRows; + *in50 = *off; + *in51 = *off; + sopt = ''; + stype = rows(i).ctype; + svalue = rows(i).cvalue; + sdesc = rows(i).cdesc; + rrn += 1; + write cmsfl; + endfor; +endsr; + +// --------------------------------------------------------------------- +begsr handleOpt; + chain selRrn cmsfl; + if %found(wrkcmd); + select; + when selOpt = '2'; + exsr changeRow; + when selOpt = '4'; + exsr deleteRow; + when selOpt = '5'; + exsr displayRow; + other; + writeMsg('Option ' + selOpt + ' not valid.'); + endsl; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr addRow; + emode = 'A'; + etype = filter; + evalue = ''; + edesc = ''; + eshort = ''; + esort = 0; + eactive = 'Y'; + exsr editLoop; + if not *in12 and etype <> '' and evalue <> ''; + exec sql + insert into perpdemo.code_master + (code_type, code_value, description, short_desc, + sort_order, is_active) + values (:etype, :evalue, :edesc, :eshort, :esort, :eactive); + if sqlcode < 0; + writeMsg('Add failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Added ' + %trim(etype) + '/' + %trim(evalue) + '.'); + endif; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr changeRow; + emode = 'C'; + etype = stype; + evalue = svalue; + exec sql + select description, short_desc, sort_order, is_active + into :edesc, :eshort, :esort, :eactive + from perpdemo.code_master + where code_type = :etype and code_value = :evalue; + if sqlcode <> 0; + writeMsg('Row disappeared before change.'); + return; + endif; + exsr editLoop; + if not *in12; + exec sql + update perpdemo.code_master + set description = :edesc, + short_desc = :eshort, + sort_order = :esort, + is_active = :eactive, + updated_at = current_timestamp, + updated_by = user + where code_type = :etype and code_value = :evalue; + if sqlcode < 0; + writeMsg('Change failed: SQLCODE=' + %char(sqlcode)); + else; + writeMsg('Updated ' + %trim(etype) + '/' + %trim(evalue) + '.'); + endif; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr deleteRow; + exec sql + delete from perpdemo.code_master + where code_type = :stype and code_value = :svalue; + if sqlcode < 0; + writeMsg('Delete failed (in use?): SQLSTATE=' + sqlstate); + else; + writeMsg('Deleted ' + %trim(stype) + '/' + %trim(svalue) + '.'); + endif; +endsr; + +// --------------------------------------------------------------------- +begsr displayRow; + emode = 'D'; + etype = stype; + evalue = svalue; + exec sql + select description, short_desc, sort_order, is_active + into :edesc, :eshort, :esort, :eactive + from perpdemo.code_master + where code_type = :etype and code_value = :evalue; + exsr editLoop; +endsr; + +// --------------------------------------------------------------------- +begsr editLoop; + exfmt cmedit; +endsr; + +// --------------------------------------------------------------------- +begsr clearMsgs; + msgrrn = 0; + *in41 = *on; + write cmmsgctl; + *in41 = *off; +endsr; + +// --------------------------------------------------------------------- +dcl-proc writeMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + smsgkey : + x'0000000000000000'); + msgrrn += 1; + spgmq = statusDS.programName; + write cmmsgsfl; +end-proc; diff --git a/perp/qrpglesrc/wrkusrr.sqlrpgle b/perp/qrpglesrc/wrkusrr.sqlrpgle new file mode 100644 index 00000000..9ce02fc0 --- /dev/null +++ b/perp/qrpglesrc/wrkusrr.sqlrpgle @@ -0,0 +1,274 @@ +**free + +// --------------------------------------------------------------------- +// Program: wrkusrr (Work with PERP Users) +// Purpose: DSPF-based CRUD for the perp_user table. Same pattern as +// wrkcmr — subfile list + edit format. Role FK is enforced +// by DB2; if the caller types a role_code that is not in +// code_master (USERROLE), INSERT/UPDATE returns SQLSTATE +// 23503 which the RPG surfaces to the message subfile. +// Epic: PERP-2 (PERP-18) +// --------------------------------------------------------------------- + +ctl-opt dftactgrp(*no) actgrp(*new); + +dcl-f wrkusrd workstn sfile(usfl:rrn) sfile(umsgsfl:msgrrn); + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-ds statusDS psds qualified; + programName char(10) pos(334); +end-ds; + +dcl-ds uRow qualified; + ucode char(10); + uname varchar(60); + uemail varchar(120); + urole varchar(20); + uact char(1); +end-ds; + +dcl-ds rows likeds(uRow) dim(500); +dcl-s numRows int(10); +dcl-s i int(10); +dcl-s rrn int(10); +dcl-s msgrrn int(10); +dcl-s msgkey char(4); +dcl-s selRrn int(10); +dcl-s selOpt char(1); + +dow not *in03 and not *in12; + exsr clearMsgs; + exsr loadRows; + + if numRows = 0; + *in30 = *off; + write unone; + else; + exsr fillSubfile; + *in30 = *on; + endif; + + write ufoot; + if msgrrn > 0; + *in40 = *on; + write umsgctl; + else; + *in40 = *off; + endif; + exfmt uctl; + + if *in03 or *in12; + leave; + endif; + + if *in05; + iter; + endif; + + if *in06; + exsr addRow; + iter; + endif; + + selRrn = 0; + selOpt = ' '; + readc usfl; + dow not %eof(wrkusrd); + if sopt <> ''; + selRrn = rrn; + selOpt = sopt; + exsr handleOpt; + selRrn = 0; + endif; + readc usfl; + enddo; +enddo; + +*inlr = *on; +return; + +// --------------------------------------------------------------------- +begsr loadRows; + numRows = 0; + exec sql declare u1 cursor for + select user_code, display_name, email_address, role_code, is_active + from perpdemo.perp_user + order by user_code; + exec sql open u1; + if sqlcode < 0; + writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); + return; + endif; + + dow numRows < %elem(rows); + exec sql fetch u1 into :uRow; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + numRows += 1; + rows(numRows) = uRow; + enddo; + exec sql close u1; +endsr; + +// --------------------------------------------------------------------- +begsr fillSubfile; + rrn = 0; + *in31 = *on; + write uctl; + *in31 = *off; + for i = 1 to numRows; + *in50 = *off; + *in51 = *off; + sopt = ''; + sucode = rows(i).ucode; + suname = rows(i).uname; + surole = rows(i).urole; + suact = rows(i).uact; + rrn += 1; + write usfl; + endfor; +endsr; + +// --------------------------------------------------------------------- +begsr handleOpt; + chain selRrn usfl; + if %found(wrkusrd); + select; + when selOpt = '2'; + exsr changeRow; + when selOpt = '4'; + exsr deleteRow; + when selOpt = '5'; + exsr displayRow; + other; + writeMsg('Option ' + selOpt + ' not valid.'); + endsl; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr addRow; + emode = 'A'; + eucode = ''; + euname = ''; + euemail = ''; + eurole = 'REQUESTER'; + euact = 'Y'; + exsr editLoop; + if not *in12 and eucode <> ''; + exec sql + insert into perpdemo.perp_user + (user_code, display_name, email_address, role_code, is_active) + values (:eucode, :euname, :euemail, :eurole, :euact); + if sqlcode < 0; + writeMsg('Add failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Added ' + %trim(eucode) + '.'); + endif; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr changeRow; + emode = 'C'; + eucode = sucode; + exec sql + select display_name, email_address, role_code, is_active + into :euname, :euemail, :eurole, :euact + from perpdemo.perp_user + where user_code = :eucode; + if sqlcode <> 0; + writeMsg('Row disappeared before change.'); + return; + endif; + exsr editLoop; + if not *in12; + exec sql + update perpdemo.perp_user + set display_name = :euname, + email_address = :euemail, + role_code = :eurole, + is_active = :euact, + updated_at = current_timestamp, + updated_by = user + where user_code = :eucode; + if sqlcode < 0; + writeMsg('Change failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Updated ' + %trim(eucode) + '.'); + endif; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr deleteRow; + exec sql + delete from perpdemo.perp_user + where user_code = :sucode; + if sqlcode < 0; + writeMsg('Delete failed: SQLSTATE=' + sqlstate); + else; + writeMsg('Deleted ' + %trim(sucode) + '.'); + endif; +endsr; + +// --------------------------------------------------------------------- +begsr displayRow; + emode = 'D'; + eucode = sucode; + exec sql + select display_name, email_address, role_code, is_active + into :euname, :euemail, :eurole, :euact + from perpdemo.perp_user + where user_code = :eucode; + exsr editLoop; +endsr; + +// --------------------------------------------------------------------- +begsr editLoop; + exfmt uedit; +endsr; + +// --------------------------------------------------------------------- +begsr clearMsgs; + msgrrn = 0; + *in41 = *on; + write umsgctl; + *in41 = *off; +endsr; + +// --------------------------------------------------------------------- +dcl-proc writeMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + smsgkey : + x'0000000000000000'); + msgrrn += 1; + spgmq = statusDS.programName; + write umsgsfl; +end-proc; diff --git a/perp/qsrvsrc/docseq.bnd b/perp/qsrvsrc/docseq.bnd new file mode 100644 index 00000000..f79fff8b --- /dev/null +++ b/perp/qsrvsrc/docseq.bnd @@ -0,0 +1,4 @@ +strpgmexp pgmlvl(*current) signature('DOCSEQ ') + export symbol("DOCSEQ_NEXT") + export symbol("DOCSEQ_PEEK") +endpgmexp From 5fa76e43a1589f42b4930e0b65469c652eadefeb Mon Sep 17 00:00:00 2001 From: Gary Jones Date: Wed, 15 Jul 2026 18:21:31 +0000 Subject: [PATCH 03/13] =?UTF-8?q?PERP-3:=20Inventory=20Master=20=E2=80=94?= =?UTF-8?q?=20tables,=20maintenance=20programs,=20and=20menu=20wiring?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Adds the PERP-3 epic (PERP-20..24): uom/item_class/item/item_uom_conversion/ item_lot DDL, and DSPF+RPGLE maintenance programs (WRKUOMR, WRKCNVR, WRKICLR, WRKITMR, WRKLOTR) scoped by the *LDA-selected company. Item master maintenance cross-calls the UOM-conversion and lot screens pre-scoped to the selected item. Extends Rules.mk and the PERP main menu accordingly, and folds three newly-discovered DB2-for-i/DDS/RPG gotchas into DDL_STYLE_GUIDE.md. Also fixes an empty-subfile runtime crash ("Session or device error") present in all 8 PERP work-with programs, including the PERP-2 precedent programs (PERPSELR, WRKCMR, WRKUSRR): the subfile-options READC loop ran unconditionally even when nothing was loaded, which raises a CPF5006-class error instead of *EOF. Guarded with `if numRows > 0`, and reset the row counter explicitly in the two programs that skip loading when their scope key is blank. Adds EDTCDE(3) to every numeric DDS field across WRKITMR/WRKCNVR/WRKLOTR (16 fields) and retrofits it onto WRKCMR's sort_order, which was using EDTCDE(Z) and silently blanked its default-zero value. Zero-suppresses while still showing a literal 0 for a true zero balance/quantity, per a new standing convention documented in DDL_STYLE_GUIDE.md. Co-Authored-By: CoderFlow Learn more: https://coderflow.ai --- perp/DDL_STYLE_GUIDE.md | 53 +++ perp/Rules.mk | 47 ++- perp/perpmnu.msgf | 5 + perp/qddlsrc/item.table.sql | 117 ++++++ perp/qddlsrc/item_class.table.sql | 53 +++ perp/qddlsrc/item_lot.table.sql | 58 +++ perp/qddlsrc/item_uom_conversion.table.sql | 58 +++ perp/qddlsrc/uom.table.sql | 46 +++ perp/qddssrc/perpmnu.dspf | 9 +- perp/qddssrc/wrkcmd.dspf | 2 +- perp/qddssrc/wrkcnvd.dspf | 76 ++++ perp/qddssrc/wrkicld.dspf | 70 ++++ perp/qddssrc/wrkitmd.dspf | 127 +++++++ perp/qddssrc/wrklotd.dspf | 89 +++++ perp/qddssrc/wrkuomd.dspf | 69 ++++ perp/qrpglesrc/perpselr.sqlrpgle | 31 +- perp/qrpglesrc/wrkcmr.sqlrpgle | 29 +- perp/qrpglesrc/wrkcnvr.sqlrpgle | 330 +++++++++++++++++ perp/qrpglesrc/wrkiclr.sqlrpgle | 301 +++++++++++++++ perp/qrpglesrc/wrkitmr.sqlrpgle | 406 +++++++++++++++++++++ perp/qrpglesrc/wrklotr.sqlrpgle | 357 ++++++++++++++++++ perp/qrpglesrc/wrkuomr.sqlrpgle | 276 ++++++++++++++ perp/qrpglesrc/wrkusrr.sqlrpgle | 27 +- 23 files changed, 2595 insertions(+), 41 deletions(-) create mode 100644 perp/qddlsrc/item.table.sql create mode 100644 perp/qddlsrc/item_class.table.sql create mode 100644 perp/qddlsrc/item_lot.table.sql create mode 100644 perp/qddlsrc/item_uom_conversion.table.sql create mode 100644 perp/qddlsrc/uom.table.sql create mode 100644 perp/qddssrc/wrkcnvd.dspf create mode 100644 perp/qddssrc/wrkicld.dspf create mode 100644 perp/qddssrc/wrkitmd.dspf create mode 100644 perp/qddssrc/wrklotd.dspf create mode 100644 perp/qddssrc/wrkuomd.dspf create mode 100644 perp/qrpglesrc/wrkcnvr.sqlrpgle create mode 100644 perp/qrpglesrc/wrkiclr.sqlrpgle create mode 100644 perp/qrpglesrc/wrkitmr.sqlrpgle create mode 100644 perp/qrpglesrc/wrklotr.sqlrpgle create mode 100644 perp/qrpglesrc/wrkuomr.sqlrpgle diff --git a/perp/DDL_STYLE_GUIDE.md b/perp/DDL_STYLE_GUIDE.md index 38a7747e..5ba7ce1b 100644 --- a/perp/DDL_STYLE_GUIDE.md +++ b/perp/DDL_STYLE_GUIDE.md @@ -55,6 +55,19 @@ auto-derive, or rename the SQL identifier so it needs a short name (e.g. `city` → `city_name FOR COLUMN CITY`, `perp_user` → keep the SQL name and accept `PERP_USER` as the system name — RPG programs `dcl-f perp_user`). +**Don't trust the SQL7029 message text as a hint at the real system name.** +`SQL7029: System name X cannot be specified` echoes back whatever value +*you* proposed — it is not telling you what DB2 actually auto-derived. +(Learned in PERP-20: an explicit `FOR SYSTEM NAME ITMCLS` on `item_class` +raised `SQL7029: System name ITMCLS cannot be specified`, which reads like +confirmation that `ITMCLS` is correct — it isn't. The real auto-derived +name, confirmed via `DSPOBJD OBJ(PERPDEMO/*ALL) OBJTYPE(*FILE)`, is +`ITEM_CLASS` — DB2 only abbreviates when the SQL name exceeds 10 characters, +and `item_class`/`item_lot` are exactly 10/8.) After hitting this error, +omit the clause, build, then confirm the real object name with `DSPOBJD` +before writing anything downstream (Rules.mk targets, `PERPSJPF` calls, +RPG `dcl-f`) against it — don't guess an abbreviation. + Related: **`LABEL ON TABLE` text is capped at 50 characters** on DB2 for i; longer text raises `SQL0107`. Column labels have the same cap. @@ -281,6 +294,46 @@ maintenance programs. These apply to every RPG or SQLRPGLE source under F12=Cancel — declared at file level and echoed in the footer line. - **Message subfile** (`R xMSGSFL` / `R xMSGCTL`) attached at row 24 on every screen; RPG uses `QMHSNDPM` to post messages. +- **Every numeric field on screen (subfile column or edit-panel field, + input or output) gets `EDTCDE(3)`.** Without an edit code, a zoned + numeric field displays every leading zero (e.g. `000000001500000` for + 150.0000), which is unreadable and reads as an error to anyone glancing + at the screen. `EDTCDE(3)` zero-suppresses and inserts the decimal + point (a no-op if `DEC=0`) while still displaying a literal `0` for a + true zero value — critical for balance/quantity fields where "zero" is + a meaningful, common state (e.g. a freshly-added item's `qty_on_hand`) + that must read as `0`, not blank or a run of zeros. + - **Do not use `EDTCDE(Z)`, `EDTCDE(2)`, `EDTCDE(4)`, or any other + "blank when zero" code for business quantity/balance fields** — those + codes zero-suppress by blanking the field entirely when the value is + zero, which is indistinguishable from "no value" and defeats the + purpose for anything the user needs to read as an explicit zero. + (`Z`/`2`/`4`/`B`/`D`/`K`/`M` blank zero; `1`/`3`/`A`/`C`/`J`/`L` show + it as `0` — this module standardizes on `3`, the plainest of the + zero-showing codes, since these are quantities/counts, not currency + needing comma grouping.) + - Adding `EDTCDE(3)` to a `DEC>0` field grows its display width by + exactly one column (the decimal point) — leave at least that much + headroom between adjacent fields packed onto the same row, or the + compile will overlap/truncate. +- **Never issue `READC` against a subfile that was not written to this + cycle.** If the load routine finds 0 rows this pass (e.g. an empty + filter result, or the "enter a key value to begin" state before any + scoping value has been typed), the subfile-options `READC` loop must + be skipped entirely — guard it with `if numRows > 0; ... endif;`. + Unconditionally issuing `READC` against a subfile that has never been + `WRITE`n this invocation raises a runtime **"Session or device error + occurred in file &1"** (CPF5006-class) the instant the user presses + Enter on an empty list — it does not just return `*EOF` the way a + populated-then-cleared subfile would. Found across every PERP + work-with program (`PERPSELR`, `WRKCMR`, `WRKUSRR`, `WRKUOMR`, + `WRKCNVR`, `WRKICLR`, `WRKITMR`, `WRKLOTR`) since they all share the + same load/fill/read-options skeleton; fixed in all eight at once. + Corollary: if a program skips the load routine entirely when its scope + key is blank (e.g. `WRKCNVR`/`WRKLOTR` before an item number is + entered), explicitly reset the row counter to 0 in that branch too — + otherwise a stale nonzero count from a *previous* scope value lets the + guard pass even though nothing was loaded this cycle. ## 15. codermake gotchas diff --git a/perp/Rules.mk b/perp/Rules.mk index 1419c84b..c9cd11be 100644 --- a/perp/Rules.mk +++ b/perp/Rules.mk @@ -36,6 +36,16 @@ company_config.file: qddlsrc/company_config.table.sql company.file | p perp_user.file: qddlsrc/perp_user.table.sql code_master.file | perpsjpf.pgm +# --- PERP-20: Inventory Master tables -------------------------------------- +# Core item master. FK order: uom and item_class (both FK company) before +# item; item_uom_conversion and item_lot FK item + uom. +uom.file: qddlsrc/uom.table.sql | perpsjpf.pgm +item_class.file: qddlsrc/item_class.table.sql company.file | perpsjpf.pgm +item.file: qddlsrc/item.table.sql company.file item_class.file uom.file | perpsjpf.pgm +item_uom_conversion.file: qddlsrc/item_uom_conversion.table.sql item.file uom.file | perpsjpf.pgm +item_lot.file: qddlsrc/item_lot.table.sql item.file | perpsjpf.pgm + + # --- PERP-19: Document sequence service ---------------------------------- # Atomic per-(company, doc_type) sequence allocator. Module + srvpgm + bnddir. docseq.module: qrpglesrc/docseq.sqlrpgle qrpglesrc/docseq_pr.rpgle | company_config.file document_sequence.file @@ -62,14 +72,45 @@ wrkusrd.file: qddssrc/wrkusrd.dspf wrkusrr.pgm: qrpglesrc/wrkusrr.sqlrpgle qddssrc/wrkusrd.dspf | wrkusrd.file perp_user.file code_master.file +# --- PERP-21: UOM & UOM conversion maintenance ---------------------------- +wrkuomd.file: qddssrc/wrkuomd.dspf +wrkuomr.pgm: qrpglesrc/wrkuomr.sqlrpgle qddssrc/wrkuomd.dspf | wrkuomd.file uom.file + +# Scoped by *LDA company (perpselr) + item number entered on screen. +wrkcnvd.file: qddssrc/wrkcnvd.dspf +wrkcnvr.pgm: qrpglesrc/wrkcnvr.sqlrpgle qddssrc/wrkcnvd.dspf | wrkcnvd.file item_uom_conversion.file + + +# --- PERP-22: Item class maintenance -------------------------------------- +# Scoped by *LDA company (perpselr). +wrkicld.file: qddssrc/wrkicld.dspf +wrkiclr.pgm: qrpglesrc/wrkiclr.sqlrpgle qddssrc/wrkicld.dspf | wrkicld.file item_class.file + + +# --- PERP-23: Item master maintenance -------------------------------------- +# Scoped by *LDA company (perpselr). Option 6 on the subfile calls wrkcnvr +# pre-scoped to the selected item (dynamic CALL via EXTPGM, not compile-time +# bound -- wrkcnvr.pgm listed as order-only so build order still makes sense). +wrkitmd.file: qddssrc/wrkitmd.dspf +wrkitmr.pgm: qrpglesrc/wrkitmr.sqlrpgle qddssrc/wrkitmd.dspf | wrkitmd.file item.file wrkcnvr.pgm wrklotr.pgm + + +# --- PERP-24: Item lot maintenance & inquiry -------------------------------- +# Scoped by *LDA company (perpselr) + item number entered on screen, same +# idiom as wrkcnvr. Discrepancy indicator: item.qty_on_hand vs +# SUM(item_lot.qty_on_hand) for the scoped item. +wrklotd.file: qddssrc/wrklotd.dspf +wrklotr.pgm: qrpglesrc/wrklotr.sqlrpgle qddssrc/wrklotd.dspf | wrklotd.file item_lot.file + + # --- PERP main menu (glue for exploratory verification) ------------------ -# Ties the PERP-16/17/18/19 programs together into a single 5250 menu: -# GO PERPDEMO/PERPMNU +# Ties the PERP-16/17/18/19/21/22/23/24 programs together into a single +# 5250 menu: GO PERPDEMO/PERPMNU perpmnu.file: qddssrc/perpmnu.dspf perpmnu.msgf: perpmnu.msgf # .file MUST be a normal prereq (not order-only) or codermake silently drops # the CRTMNU recipe. See DDL_STYLE_GUIDE § "codermake menu gotcha". -perpmnu.menu: perpmnu.msgf perpmnu.file | perpselr.pgm wrkcmr.pgm wrkusrr.pgm docseqsmk.pgm +perpmnu.menu: perpmnu.msgf perpmnu.file | perpselr.pgm wrkcmr.pgm wrkusrr.pgm docseqsmk.pgm wrkuomr.pgm wrkcnvr.pgm wrkiclr.pgm wrkitmr.pgm wrklotr.pgm # --- CL setup ------------------------------------------------------------- diff --git a/perp/perpmnu.msgf b/perp/perpmnu.msgf index f52b1c7c..f9c448d0 100644 --- a/perp/perpmnu.msgf +++ b/perp/perpmnu.msgf @@ -3,4 +3,9 @@ addmsgd msgid(usr0001) msgf($LIBRARY/$NAME) msg('call perpselr') addmsgd msgid(usr0002) msgf($LIBRARY/$NAME) msg('call wrkcmr') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0003) msgf($LIBRARY/$NAME) msg('call wrkusrr') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0004) msgf($LIBRARY/$NAME) msg('call docseqsmk parm(''ACM'' ''PO '')') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0005) msgf($LIBRARY/$NAME) msg('call wrkuomr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0006) msgf($LIBRARY/$NAME) msg('call wrkcnvr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0007) msgf($LIBRARY/$NAME) msg('call wrkiclr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0008) msgf($LIBRARY/$NAME) msg('call wrkitmr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0009) msgf($LIBRARY/$NAME) msg('call wrklotr') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0090) msgf($LIBRARY/$NAME) msg('signoff') seclvl(*none) sev(00) fmt(*none) diff --git a/perp/qddlsrc/item.table.sql b/perp/qddlsrc/item.table.sql new file mode 100644 index 00000000..fa3e9619 --- /dev/null +++ b/perp/qddlsrc/item.table.sql @@ -0,0 +1,117 @@ +-- --------------------------------------------------------------------------- +-- Table: item (system name ITEM) +-- Module: perp +-- Purpose: Core item master. Balances (Option C), reorder parameters, +-- single location, UOM pair, and the lot_controlled flag that +-- drives item_lot behaviour. Items are not shared across +-- companies. +-- Epic: PERP-3 / PERP-20 (Inventory Master) +-- --------------------------------------------------------------------------- + +-- 'item' auto-derives to system name ITEM; specifying FOR SYSTEM NAME with +-- the same value raises SQL7029, so it's omitted (same rule as company.sql). +CREATE TABLE item ( + + -- Composite key (per-company) --------------------------------------------- + company_code FOR COLUMN COMPCD CHAR(3) NOT NULL, + item_number FOR COLUMN ITMNBR VARCHAR(25) NOT NULL, + + -- Descriptive columns ------------------------------------------------------- + item_description FOR COLUMN ITMDSC VARCHAR(60) NOT NULL, + short_description FOR COLUMN SHTDSC VARCHAR(20) NOT NULL DEFAULT '', + + -- Classification (FK to item_class) ------------------------------------ + class_code FOR COLUMN CLSCD VARCHAR(10) NOT NULL, + + -- UOMs (FK to uom) ---------------------------------------------------------- + inventory_uom FOR COLUMN INVUOM VARCHAR(5) NOT NULL, + stocking_uom FOR COLUMN STKUOM VARCHAR(5) NOT NULL, + + -- Lot control flag — drives item_lot behaviour ----------------------------- + lot_controlled FOR COLUMN LOTCTL CHAR(1) NOT NULL DEFAULT 'N', + + -- Balances — Option C: also denormalized onto item_lot for lot-controlled + -- items, so drift is possible by design (the reconciliation demo) -------- + qty_on_hand FOR COLUMN QTYOH DECIMAL(15,4) NOT NULL DEFAULT 0, + qty_available FOR COLUMN QTYAVL DECIMAL(15,4) NOT NULL DEFAULT 0, + qty_frozen FOR COLUMN QTYFRZ DECIMAL(15,4) NOT NULL DEFAULT 0, + qty_on_order FOR COLUMN QTYOO DECIMAL(15,4) NOT NULL DEFAULT 0, + + -- Reorder parameters ---------------------------------------------------- + reorder_point FOR COLUMN RORDPT DECIMAL(15,4) NOT NULL DEFAULT 0, + critical_level FOR COLUMN CRITLV DECIMAL(15,4) NOT NULL DEFAULT 0, + min_qty FOR COLUMN MINQTY DECIMAL(15,4) NOT NULL DEFAULT 0, + max_qty FOR COLUMN MAXQTY DECIMAL(15,4) NOT NULL DEFAULT 0, + safety_stock FOR COLUMN SAFSTK DECIMAL(15,4) NOT NULL DEFAULT 0, + lead_time_days FOR COLUMN LEADTM INTEGER NOT NULL DEFAULT 0, + + -- Single location (aisle/bay/shelf) -------------------------------------- + aisle_code FOR COLUMN AISLE VARCHAR(10) NOT NULL DEFAULT '', + bay_code FOR COLUMN BAY VARCHAR(10) NOT NULL DEFAULT '', + shelf_code FOR COLUMN SHELF VARCHAR(10) NOT NULL DEFAULT '', + + -- Standard audit block -------------------------------------------------- + created_at FOR COLUMN CRTAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + created_by FOR COLUMN CRTBY VARCHAR(18) NOT NULL DEFAULT USER, + updated_at FOR COLUMN UPDAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_by FOR COLUMN UPDBY VARCHAR(18) NOT NULL DEFAULT USER, + is_active FOR COLUMN ISACT CHAR(1) NOT NULL DEFAULT 'Y', + + -- Composite primary key --------------------------------------------------- + PRIMARY KEY (company_code, item_number), + + -- Constraints --------------------------------------------------------------- + CONSTRAINT item_isact_ck CHECK (is_active IN ('Y','N')), + CONSTRAINT item_lotctl_ck CHECK (lot_controlled IN ('Y','N')), + CONSTRAINT item_qtyoh_ck CHECK (qty_on_hand >= 0), + CONSTRAINT item_qtyavl_ck CHECK (qty_available >= 0), + CONSTRAINT item_qtyfrz_ck CHECK (qty_frozen >= 0), + CONSTRAINT item_qtyoo_ck CHECK (qty_on_order >= 0), + CONSTRAINT item_rordpt_ck CHECK (reorder_point >= 0), + CONSTRAINT item_minqty_ck CHECK (min_qty >= 0), + CONSTRAINT item_maxqty_ck CHECK (max_qty >= min_qty), + CONSTRAINT item_safstk_ck CHECK (safety_stock >= 0), + CONSTRAINT item_leadtm_ck CHECK (lead_time_days >= 0), + + -- FKs ----------------------------------------------------------------------- + CONSTRAINT item_company_fk FOREIGN KEY (company_code) + REFERENCES company (company_code) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT item_class_fk FOREIGN KEY (company_code, class_code) + REFERENCES item_class (company_code, class_code) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT item_invuom_fk FOREIGN KEY (inventory_uom) + REFERENCES uom (uom_code) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT item_stkuom_fk FOREIGN KEY (stocking_uom) + REFERENCES uom (uom_code) + ON DELETE RESTRICT ON UPDATE RESTRICT +); + +LABEL ON TABLE item IS + 'PERP core item master'; + +LABEL ON COLUMN item ( + company_code IS 'Company code (FK to company)', + item_number IS 'Item number (natural key within company)', + item_description IS 'Item description', + short_description IS 'Short description (list / column display)', + class_code IS 'Item class (FK to item_class)', + inventory_uom IS 'Inventory UOM (FK to uom)', + stocking_uom IS 'Stocking UOM (FK to uom)', + lot_controlled IS 'Lot controlled flag (Y/N)', + qty_on_hand IS 'Quantity on hand', + qty_available IS 'Quantity available', + qty_frozen IS 'Quantity frozen', + qty_on_order IS 'Quantity on order', + reorder_point IS 'Reorder point', + critical_level IS 'Critical stock level', + min_qty IS 'Minimum quantity', + max_qty IS 'Maximum quantity', + safety_stock IS 'Safety stock quantity', + lead_time_days IS 'Lead time in days', + aisle_code IS 'Storage aisle', + bay_code IS 'Storage bay', + shelf_code IS 'Storage shelf', + is_active IS 'Active flag (Y/N, soft delete)' +); diff --git a/perp/qddlsrc/item_class.table.sql b/perp/qddlsrc/item_class.table.sql new file mode 100644 index 00000000..4f5caeb8 --- /dev/null +++ b/perp/qddlsrc/item_class.table.sql @@ -0,0 +1,53 @@ +-- --------------------------------------------------------------------------- +-- Table: item_class (system name ITMCLS) +-- Module: perp +-- Purpose: Flat item classification, per company. Items FK to this for +-- their class_code. +-- Epic: PERP-3 / PERP-20 (Inventory Master) +-- --------------------------------------------------------------------------- + +-- 'item_class' is itself a valid <=10-char system name (underscores +-- allowed), so any explicit FOR SYSTEM NAME here raises SQL7029 -- even a +-- value matching the true auto-derived name (ITEM_CLASS). The error message +-- echoes back whatever value *you* specified, not the real auto-derived +-- one -- confirmed here via DSPOBJD (object is PERPDEMO/ITEM_CLASS, not the +-- abbreviated ITMCLS this file originally guessed). Omit the clause and +-- verify the real object name with DSPOBJD/DSPFD rather than trusting the +-- SQL7029 message text. +CREATE TABLE item_class ( + + -- Composite key (per-company) --------------------------------------------- + company_code FOR COLUMN COMPCD CHAR(3) NOT NULL, + class_code FOR COLUMN CLSCD VARCHAR(10) NOT NULL, + + -- Descriptive columns ------------------------------------------------------- + description FOR COLUMN CLSDSC VARCHAR(60) NOT NULL, + + -- Standard audit block -------------------------------------------------- + created_at FOR COLUMN CRTAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + created_by FOR COLUMN CRTBY VARCHAR(18) NOT NULL DEFAULT USER, + updated_at FOR COLUMN UPDAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_by FOR COLUMN UPDBY VARCHAR(18) NOT NULL DEFAULT USER, + is_active FOR COLUMN ISACT CHAR(1) NOT NULL DEFAULT 'Y', + + -- Composite primary key --------------------------------------------------- + PRIMARY KEY (company_code, class_code), + + -- Constraints --------------------------------------------------------------- + CONSTRAINT itmcls_isact_ck CHECK (is_active IN ('Y','N')), + + -- FK to company ------------------------------------------------------------- + CONSTRAINT itmcls_company_fk FOREIGN KEY (company_code) + REFERENCES company (company_code) + ON DELETE RESTRICT ON UPDATE RESTRICT +); + +LABEL ON TABLE item_class IS + 'PERP item classification (flat, per company)'; + +LABEL ON COLUMN item_class ( + company_code IS 'Company code (FK to company)', + class_code IS 'Item class code', + description IS 'Item class description', + is_active IS 'Active flag (Y/N, soft delete)' +); diff --git a/perp/qddlsrc/item_lot.table.sql b/perp/qddlsrc/item_lot.table.sql new file mode 100644 index 00000000..2bff68cf --- /dev/null +++ b/perp/qddlsrc/item_lot.table.sql @@ -0,0 +1,58 @@ +-- --------------------------------------------------------------------------- +-- Table: item_lot (system name ITMLOT) +-- Module: perp +-- Purpose: Lot balances for lot-controlled items (Option C — denormalized +-- alongside item.qty_on_hand so drift is possible by design; the +-- reconciliation demo (PERP-24) surfaces and resolves it). +-- Epic: PERP-3 / PERP-20 (Inventory Master) +-- --------------------------------------------------------------------------- + +-- 'item_lot' is itself a valid <=10-char system name; any explicit FOR +-- SYSTEM NAME here raises SQL7029 regardless of value. Real object name +-- (verified via DSPOBJD) is PERPDEMO/ITEM_LOT -- see the note in +-- item_class.table.sql for why the SQL7029 message text is misleading. +CREATE TABLE item_lot ( + + -- Composite key ----------------------------------------------------------- + company_code FOR COLUMN COMPCD CHAR(3) NOT NULL, + item_number FOR COLUMN ITMNBR VARCHAR(25) NOT NULL, + lot_number FOR COLUMN LOTNBR VARCHAR(20) NOT NULL, + + -- Lot balance and dates --------------------------------------------------- + qty_on_hand FOR COLUMN QTYOH DECIMAL(15,4) NOT NULL DEFAULT 0, + received_date FOR COLUMN RCVDT DATE NOT NULL DEFAULT CURRENT_DATE, + expiry_date FOR COLUMN EXPDT DATE, + + -- Standard audit block -------------------------------------------------- + created_at FOR COLUMN CRTAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + created_by FOR COLUMN CRTBY VARCHAR(18) NOT NULL DEFAULT USER, + updated_at FOR COLUMN UPDAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_by FOR COLUMN UPDBY VARCHAR(18) NOT NULL DEFAULT USER, + is_active FOR COLUMN ISACT CHAR(1) NOT NULL DEFAULT 'Y', + + -- Composite primary key --------------------------------------------------- + PRIMARY KEY (company_code, item_number, lot_number), + + -- Constraints --------------------------------------------------------------- + CONSTRAINT itmlot_isact_ck CHECK (is_active IN ('Y','N')), + CONSTRAINT itmlot_qtyoh_ck CHECK (qty_on_hand >= 0), + CONSTRAINT itmlot_dt_ck CHECK (expiry_date IS NULL OR expiry_date >= received_date), + + -- FK to item ------------------------------------------------------------ + CONSTRAINT itmlot_item_fk FOREIGN KEY (company_code, item_number) + REFERENCES item (company_code, item_number) + ON DELETE RESTRICT ON UPDATE RESTRICT +); + +LABEL ON TABLE item_lot IS + 'PERP item lot balances (reconciliation demo)'; + +LABEL ON COLUMN item_lot ( + company_code IS 'Company code (FK to item)', + item_number IS 'Item number (FK to item)', + lot_number IS 'Lot number', + qty_on_hand IS 'Lot quantity on hand', + received_date IS 'Date lot was received', + expiry_date IS 'Lot expiry date (nullable)', + is_active IS 'Active flag (Y/N, soft delete)' +); diff --git a/perp/qddlsrc/item_uom_conversion.table.sql b/perp/qddlsrc/item_uom_conversion.table.sql new file mode 100644 index 00000000..f4a41277 --- /dev/null +++ b/perp/qddlsrc/item_uom_conversion.table.sql @@ -0,0 +1,58 @@ +-- --------------------------------------------------------------------------- +-- Table: item_uom_conversion (system name ITMUOMCV) +-- Module: perp +-- Purpose: Per-item UOM conversion factors (e.g. for item WIDGET1: +-- 1 CS = 12 EA). Looked up from the per-item conversion screen +-- reached from item maintenance (PERP-21). +-- Epic: PERP-3 / PERP-20 (Inventory Master) +-- --------------------------------------------------------------------------- + +CREATE TABLE item_uom_conversion FOR SYSTEM NAME ITMUOMCV ( + + -- Composite key ----------------------------------------------------------- + company_code FOR COLUMN COMPCD CHAR(3) NOT NULL, + item_number FOR COLUMN ITMNBR VARCHAR(25) NOT NULL, + from_uom FOR COLUMN FRMUOM VARCHAR(5) NOT NULL, + to_uom FOR COLUMN TOUOM VARCHAR(5) NOT NULL, + + -- Conversion factor: 1 from_uom = conversion_factor to_uom ----------------- + conversion_factor FOR COLUMN CONVFCT DECIMAL(15,6) NOT NULL, + + -- Standard audit block -------------------------------------------------- + created_at FOR COLUMN CRTAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + created_by FOR COLUMN CRTBY VARCHAR(18) NOT NULL DEFAULT USER, + updated_at FOR COLUMN UPDAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_by FOR COLUMN UPDBY VARCHAR(18) NOT NULL DEFAULT USER, + is_active FOR COLUMN ISACT CHAR(1) NOT NULL DEFAULT 'Y', + + -- Composite primary key --------------------------------------------------- + PRIMARY KEY (company_code, item_number, from_uom, to_uom), + + -- Constraints --------------------------------------------------------------- + CONSTRAINT itmuomcv_isact_ck CHECK (is_active IN ('Y','N')), + CONSTRAINT itmuomcv_fct_ck CHECK (conversion_factor > 0), + CONSTRAINT itmuomcv_uom_ck CHECK (from_uom <> to_uom), + + -- FKs ----------------------------------------------------------------------- + CONSTRAINT itmuomcv_item_fk FOREIGN KEY (company_code, item_number) + REFERENCES item (company_code, item_number) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT itmuomcv_frmuom_fk FOREIGN KEY (from_uom) + REFERENCES uom (uom_code) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT itmuomcv_touom_fk FOREIGN KEY (to_uom) + REFERENCES uom (uom_code) + ON DELETE RESTRICT ON UPDATE RESTRICT +); + +LABEL ON TABLE item_uom_conversion IS + 'PERP per-item UOM conversion factors'; + +LABEL ON COLUMN item_uom_conversion ( + company_code IS 'Company code (FK to item)', + item_number IS 'Item number (FK to item)', + from_uom IS 'From UOM (FK to uom)', + to_uom IS 'To UOM (FK to uom)', + conversion_factor IS '1 from_uom = conversion_factor to_uom', + is_active IS 'Active flag (Y/N, soft delete)' +); diff --git a/perp/qddlsrc/uom.table.sql b/perp/qddlsrc/uom.table.sql new file mode 100644 index 00000000..25d9b8de --- /dev/null +++ b/perp/qddlsrc/uom.table.sql @@ -0,0 +1,46 @@ +-- --------------------------------------------------------------------------- +-- Table: uom (system name UOM) +-- Module: perp +-- Purpose: Unit-of-measure master. Global (not company-scoped) — items in +-- every company reference the same UOM codes. Kept as its own +-- table rather than a code_master row because UOMs carry +-- structural attributes (see item_uom_conversion) that don't fit +-- the generic lookup shape. +-- Epic: PERP-3 / PERP-20 (Inventory Master) +-- --------------------------------------------------------------------------- + +-- 'uom' auto-derives to system name UOM; specifying FOR SYSTEM NAME with +-- the same value raises SQL7029, so it's omitted here (see company.table.sql +-- for the same rule applied to 'company'). +CREATE TABLE uom ( + + -- Natural key ------------------------------------------------------------- + uom_code FOR COLUMN UOMCD VARCHAR(5) NOT NULL, + + -- Descriptive columns ------------------------------------------------------- + description FOR COLUMN UOMDSC VARCHAR(60) NOT NULL, + uom_category FOR COLUMN UOMCAT VARCHAR(20) NOT NULL DEFAULT '', + + -- Standard audit block -------------------------------------------------- + created_at FOR COLUMN CRTAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + created_by FOR COLUMN CRTBY VARCHAR(18) NOT NULL DEFAULT USER, + updated_at FOR COLUMN UPDAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_by FOR COLUMN UPDBY VARCHAR(18) NOT NULL DEFAULT USER, + is_active FOR COLUMN ISACT CHAR(1) NOT NULL DEFAULT 'Y', + + -- Primary key ------------------------------------------------------------- + PRIMARY KEY (uom_code), + + -- Constraints ------------------------------------------------------------- + CONSTRAINT uom_isact_ck CHECK (is_active IN ('Y','N')) +); + +LABEL ON TABLE uom IS + 'PERP unit-of-measure master'; + +LABEL ON COLUMN uom ( + uom_code IS 'Unit of measure code (PK)', + description IS 'UOM description', + uom_category IS 'UOM category (e.g. WEIGHT, VOLUME, EACH)', + is_active IS 'Active flag (Y/N, soft delete)' +); diff --git a/perp/qddssrc/perpmnu.dspf b/perp/qddssrc/perpmnu.dspf index a52318f7..055e84c7 100644 --- a/perp/qddssrc/perpmnu.dspf +++ b/perp/qddssrc/perpmnu.dspf @@ -29,7 +29,14 @@ A 7 7'3. Work with PERP users' A 8 7'4. Smoke test doc-sequence se- A rvice' - A 10 6'90. Sign off' + A 9 7'5. Work with units of measure - + A (uom)' + A 10 7'6. Work with item UOM convers- + A ions' + A 11 7'7. Work with item classes' + A 12 7'8. Work with items' + A 13 7'9. Work with item lots' + A 15 6'90. Sign off' A* CMDPROMPT Do not delete this DDS spec. A 021 2'Selection: - A ' diff --git a/perp/qddssrc/wrkcmd.dspf b/perp/qddssrc/wrkcmd.dspf index bdcaf985..acb50743 100644 --- a/perp/qddssrc/wrkcmd.dspf +++ b/perp/qddssrc/wrkcmd.dspf @@ -57,7 +57,7 @@ A 6 2'Short:' A ESHORT 20A B 6 15 A 7 2'Sort:' - A ESORT 6Y 0B 7 15EDTCDE(Z) + A ESORT 6Y 0B 7 15EDTCDE(3) A 8 2'Active:' A EACTIVE 1A B 8 15 A 23 2'Enter=Save F12=Cancel' diff --git a/perp/qddssrc/wrkcnvd.dspf b/perp/qddssrc/wrkcnvd.dspf new file mode 100644 index 00000000..4bcee458 --- /dev/null +++ b/perp/qddssrc/wrkcnvd.dspf @@ -0,0 +1,76 @@ + A DSPSIZ(24 80 *DS3) + A PRINT + A CA03(03 'Exit') + A CA05(05 'Refresh') + A CA06(06 'Add') + A CA12(12 'Cancel') + A R CVSFL SFL + A 51 SFLNXTCHG + A SOPT 1A B 8 2 + A 50 DSPATR(RI) + A 50 DSPATR(PC) + A SFROM 5A O 8 5 + A STO 5A O 8 11 + A SFACT 15Y 6O 8 17EDTCDE(3) + A R CVCTL SFLCTL(CVSFL) + A SFLSIZ(0099) + A SFLPAG(0007) + A OVERLAY + A SFLDSPCTL + A N31 30 SFLDSP + A 31 SFLCLR + A N31 30 SFLEND(*MORE) + A 1 20'Work with Item UOM Conversions' + A DSPATR(HI) + A 2 2'Company:' + A SCOMPDSP 3A O 2 11 + A 2 20'Item Number:' + A SFITEM 25A B 2 33 + A 4 2'Type option, press Enter.' + A 5 4'2=Change 4=Delete' + A 7 2'Opt' + A DSPATR(UL) + A 7 5'From' + A DSPATR(UL) + A 7 11'To' + A DSPATR(UL) + A 7 17'Factor' + A DSPATR(UL) + A R CVFOOT + A 23 2'F3=Exit F5=Refresh F6=Add- + A F12=Cancel' + A COLOR(BLU) + A R CVNONE + A OVERLAY + A 10 20'** No conversions for this it- + A em **' + A R CVNOITEM + A OVERLAY + A 10 20'** Enter an item number to be- + A gin **' + A R CVEDIT + A OVERLAY + A 1 25'Edit Item UOM Conversion' + A DSPATR(HI) + A EMODE 1A O 2 2 + A 3 2'From UOM:' + A EFROM 5A B 3 13 + A 4 2'To UOM:' + A ETO 5A B 4 13 + A 5 2'Factor:' + A EFACT 15Y 6B 5 13EDTCDE(3) + A 6 2'Active:' + A EACTIVE 1A B 6 13 + A 23 2'Enter=Save F12=Cancel' + A COLOR(BLU) + A R CVMSGSFL SFL + A SFLMSGRCD(24) + A SMSGKEY SFLMSGKEY + A SPGMQ SFLPGMQ(10) + A R CVMSGCTL SFLCTL(CVMSGSFL) + A OVERLAY + A N41 40 SFLDSP + A 41 SFLCLR + A N41 40 SFLEND + A SFLSIZ(0002) + A SFLPAG(0001) diff --git a/perp/qddssrc/wrkicld.dspf b/perp/qddssrc/wrkicld.dspf new file mode 100644 index 00000000..3d950261 --- /dev/null +++ b/perp/qddssrc/wrkicld.dspf @@ -0,0 +1,70 @@ + A DSPSIZ(24 80 *DS3) + A PRINT + A CA03(03 'Exit') + A CA05(05 'Refresh') + A CA06(06 'Add') + A CA12(12 'Cancel') + A R ICSFL SFL + A 51 SFLNXTCHG + A SOPT 1A B 8 2 + A 50 DSPATR(RI) + A 50 DSPATR(PC) + A SCLASS 10A O 8 5 + A SDESC 40A O 8 17 + A R ICCTL SFLCTL(ICSFL) + A SFLSIZ(0099) + A SFLPAG(0007) + A OVERLAY + A SFLDSPCTL + A N31 30 SFLDSP + A 31 SFLCLR + A N31 30 SFLEND(*MORE) + A 1 27'Work with Item Classes' + A DSPATR(HI) + A 2 2'Company:' + A SCOMPDSP 3A O 2 11 + A 4 2'Type option, press Enter.' + A 5 4'2=Change 4=Delete 5=Displ- + A ay' + A 7 2'Opt' + A DSPATR(UL) + A 7 5'Class' + A DSPATR(UL) + A 7 17'Description' + A DSPATR(UL) + A R ICFOOT + A 23 2'F3=Exit F5=Refresh F6=Add- + A F12=Cancel' + A COLOR(BLU) + A R ICNONE + A OVERLAY + A 10 20'** No item classes for this c- + A ompany **' + A R ICNOCO + A OVERLAY + A 10 20'** No company selected - run - + A Select Company first **' + A R ICEDIT + A OVERLAY + A 1 30'Edit Item Class' + A DSPATR(HI) + A EMODE 1A O 2 2 + A 3 2'Class:' + A ECLASS 10A B 3 10 + A 4 2'Description:' + A EDESC 60A B 4 15 + A 5 2'Active:' + A EACTIVE 1A B 5 15 + A 23 2'Enter=Save F12=Cancel' + A COLOR(BLU) + A R ICMSGSFL SFL + A SFLMSGRCD(24) + A SMSGKEY SFLMSGKEY + A SPGMQ SFLPGMQ(10) + A R ICMSGCTL SFLCTL(ICMSGSFL) + A OVERLAY + A N41 40 SFLDSP + A 41 SFLCLR + A N41 40 SFLEND + A SFLSIZ(0002) + A SFLPAG(0001) diff --git a/perp/qddssrc/wrkitmd.dspf b/perp/qddssrc/wrkitmd.dspf new file mode 100644 index 00000000..336eb2f9 --- /dev/null +++ b/perp/qddssrc/wrkitmd.dspf @@ -0,0 +1,127 @@ + A DSPSIZ(24 80 *DS3) + A PRINT + A CA03(03 'Exit') + A CA05(05 'Refresh') + A CA06(06 'Add') + A CA12(12 'Cancel') + A R WISFL SFL + A 51 SFLNXTCHG + A SOPT 1A B 8 2 + A 50 DSPATR(RI) + A 50 DSPATR(PC) + A SIITEM 25A O 8 5 + A SIDESC 30A O 8 31 + A SICLASS 10A O 8 62 + A SILOT 1A O 8 73 + A SILOW 1A O 8 75 + A R WICTL SFLCTL(WISFL) + A SFLSIZ(0099) + A SFLPAG(0007) + A OVERLAY + A SFLDSPCTL + A N31 30 SFLDSP + A 31 SFLCLR + A N31 30 SFLEND(*MORE) + A 1 32'Work with Items' + A DSPATR(HI) + A 2 2'Company:' + A SCOMPDSP 3A O 2 11 + A 2 16'Class:' + A SFCLASS 10A B 2 23 + A 2 36'Active only (Y/N):' + A SFACT 1A B 2 55 + A 3 2'Low stock only (Y/N):' + A SFLOW 1A B 3 24 + A 5 2'Type option, press Enter.' + A 6 4'2=Change 4=Delete 5=Display - + A 6=UOM Conversions 7=Lots' + A 7 2'Opt' + A DSPATR(UL) + A 7 5'Item' + A DSPATR(UL) + A 7 31'Description' + A DSPATR(UL) + A 7 62'Class' + A DSPATR(UL) + A 7 73'Lot' + A DSPATR(UL) + A 7 75'Low' + A DSPATR(UL) + A R WIFOOT + A 23 2'F3=Exit F5=Refresh F6=Add - + A F12=Cancel' + A COLOR(BLU) + A R WINONE + A OVERLAY + A 11 20'** No items match this filte- + A r **' + A R WINOCO + A OVERLAY + A 11 20'** No company selected - run- + A Select Company first **' + A R WIEDIT + A OVERLAY + A 1 30'Edit Item' + A DSPATR(HI) + A EMODE 1A O 2 2 + A 2 5'Item:' + A EITEM 25A B 2 25 + A 3 2'Description:' + A EDESC 60A B 3 15 + A 4 2'Short Desc:' + A ESHORT 20A B 4 15 + A 5 2'Class:' + A ECLASS 10A B 5 15 + A 6 2'Inventory UOM:' + A EINVUOM 5A B 6 17 + A 6 30'Stocking UOM:' + A ESTKUOM 5A B 6 44 + A 7 2'Lot Controlled (Y/N):' + A ELOTCTL 1A B 7 24 + A 8 2'Balances (read-only -- adjus- + A ted via receipt/reconciliatio- + A n):' + A DSPATR(UL) + A 9 2'On Hand:' + A EQOH 15Y 4O 9 11EDTCDE(3) + A 9 35'Available:' + A EQAVL 15Y 4O 9 46EDTCDE(3) + A 10 2'Frozen:' + A EQFRZ 15Y 4O 10 11EDTCDE(3) + A 10 35'On Order:' + A EQOO 15Y 4O 10 46EDTCDE(3) + A 11 2'Reorder:' + A DSPATR(UL) + A 12 2'Reorder Pt:' + A ERORDPT 15Y 4B 12 14EDTCDE(3) + A 12 35'Critical:' + A ECRITLV 15Y 4B 12 46EDTCDE(3) + A 13 2'Min:' + A EMINQTY 15Y 4B 13 8EDTCDE(3) + A 13 35'Max:' + A EMAXQTY 15Y 4B 13 41EDTCDE(3) + A 14 2'Safety Stock:' + A ESAFSTK 15Y 4B 14 16EDTCDE(3) + A 14 35'Lead Time (days):' + A ELEADTM 5Y 0B 14 53EDTCDE(3) + A 15 2'Location:' + A DSPATR(UL) + A 16 2'Aisle:' + A EAISLE 10A B 16 10 + A 16 22'Bay:' + A EBAY 10A B 16 30 + A 16 44'Shelf:' + A ESHELF 10A B 16 52 + A 23 2'Enter=Save F12=Cancel' + A COLOR(BLU) + A R WIMSGSFL SFL + A SFLMSGRCD(24) + A SMSGKEY SFLMSGKEY + A SPGMQ SFLPGMQ(10) + A R WIMSGCTL SFLCTL(WIMSGSFL) + A OVERLAY + A N41 40 SFLDSP + A 41 SFLCLR + A N41 40 SFLEND + A SFLSIZ(0002) + A SFLPAG(0001) diff --git a/perp/qddssrc/wrklotd.dspf b/perp/qddssrc/wrklotd.dspf new file mode 100644 index 00000000..427e8b95 --- /dev/null +++ b/perp/qddssrc/wrklotd.dspf @@ -0,0 +1,89 @@ + A DSPSIZ(24 80 *DS3) + A PRINT + A CA03(03 'Exit') + A CA05(05 'Refresh') + A CA06(06 'Add') + A CA12(12 'Cancel') + A R LTSFL SFL + A 51 SFLNXTCHG + A SOPT 1A B 10 2 + A 50 DSPATR(RI) + A 50 DSPATR(PC) + A SLOT 20A O 10 5 + A SQTY 15Y 4O 10 26EDTCDE(3) + A SRECV 10A O 10 44 + A SEXPD 10A O 10 56 + A R LTCTL SFLCTL(LTSFL) + A SFLSIZ(0099) + A SFLPAG(0007) + A OVERLAY + A SFLDSPCTL + A N31 30 SFLDSP + A 31 SFLCLR + A N31 30 SFLEND(*MORE) + A 1 28'Work with Item Lots' + A DSPATR(HI) + A 2 2'Company:' + A SCOMPDSP 3A O 2 11 + A 2 20'Item Number:' + A SFITEM 25A B 2 33 + A 3 2'Item On Hand:' + A SIOH 15Y 4O 3 16EDTCDE(3) + A 3 38'Lot Total:' + A SLOTTOT 15Y 4O 3 51EDTCDE(3) + A 60 4 2'** DISCREPANCY -- on-hand does not- + A match lot total **' + A 60 DSPATR(HI) + A 60 COLOR(RED) + A 6 2'Type option, press Enter.' + A 7 4'2=Change 4=Delete' + A 9 2'Opt' + A DSPATR(UL) + A 9 5'Lot' + A DSPATR(UL) + A 9 26'Qty On Hand' + A DSPATR(UL) + A 9 44'Received' + A DSPATR(UL) + A 9 56'Expiry' + A DSPATR(UL) + A R LTFOOT + A 23 2'F3=Exit F5=Refresh F6=Add - + A F12=Cancel' + A COLOR(BLU) + A R LTNONE + A OVERLAY + A 12 20'** No lots for this item **' + A R LTNOITEM + A OVERLAY + A 12 20'** Enter an item number to be- + A gin **' + A R LTEDIT + A OVERLAY + A 1 28'Edit Item Lot' + A DSPATR(HI) + A EMODE 1A O 2 2 + A 3 2'Lot Number:' + A ELOT 20A B 3 14 + A 4 2'Qty On Hand:' + A EQTY 15Y 4B 4 15EDTCDE(3) + A 5 2'Received Date (YYYY-MM-DD):' + A ERECV 10A B 5 31 + A 6 2'Expiry Date (YYYY-MM-DD, bla- + A nk=none):' + A EEXPD 10A B 6 41 + A 7 2'Active:' + A EACTIVE 1A B 7 10 + A 23 2'Enter=Save F12=Cancel' + A COLOR(BLU) + A R LTMSGSFL SFL + A SFLMSGRCD(24) + A SMSGKEY SFLMSGKEY + A SPGMQ SFLPGMQ(10) + A R LTMSGCTL SFLCTL(LTMSGSFL) + A OVERLAY + A N41 40 SFLDSP + A 41 SFLCLR + A N41 40 SFLEND + A SFLSIZ(0002) + A SFLPAG(0001) diff --git a/perp/qddssrc/wrkuomd.dspf b/perp/qddssrc/wrkuomd.dspf new file mode 100644 index 00000000..6c2350c3 --- /dev/null +++ b/perp/qddssrc/wrkuomd.dspf @@ -0,0 +1,69 @@ + A DSPSIZ(24 80 *DS3) + A PRINT + A CA03(03 'Exit') + A CA05(05 'Refresh') + A CA06(06 'Add') + A CA12(12 'Cancel') + A R UOSFL SFL + A 51 SFLNXTCHG + A SOPT 1A B 8 2 + A 50 DSPATR(RI) + A 50 DSPATR(PC) + A SCODE 5A O 8 5 + A SDESC 30A O 8 12 + A SCAT 20A O 8 46 + A R UOCTL SFLCTL(UOSFL) + A SFLSIZ(0099) + A SFLPAG(0007) + A OVERLAY + A SFLDSPCTL + A N31 30 SFLDSP + A 31 SFLCLR + A N31 30 SFLEND(*MORE) + A 1 30'Work with Units of Measure' + A DSPATR(HI) + A 4 2'Type option, press Enter.' + A 5 4'2=Change 4=Delete 5=Displ- + A ay' + A 7 2'Opt' + A DSPATR(UL) + A 7 5'Code' + A DSPATR(UL) + A 7 12'Description' + A DSPATR(UL) + A 7 46'Category' + A DSPATR(UL) + A R UOFOOT + A 23 2'F3=Exit F5=Refresh F6=Add- + A F12=Cancel' + A COLOR(BLU) + A R UONONE + A OVERLAY + A 10 20'** No UOM entries to display - + A **' + A R UOEDIT + A OVERLAY + A 1 30'Edit UOM' + A DSPATR(HI) + A EMODE 1A O 2 2 + A 3 2'Code:' + A ECODE 5A B 3 10 + A 4 2'Description:' + A EDESC 60A B 4 15 + A 5 2'Category:' + A ECAT 20A B 5 15 + A 6 2'Active:' + A EACTIVE 1A B 6 15 + A 23 2'Enter=Save F12=Cancel' + A COLOR(BLU) + A R UOMSGSFL SFL + A SFLMSGRCD(24) + A SMSGKEY SFLMSGKEY + A SPGMQ SFLPGMQ(10) + A R UOMSGCTL SFLCTL(UOMSGSFL) + A OVERLAY + A N41 40 SFLDSP + A 41 SFLCLR + A N41 40 SFLEND + A SFLSIZ(0002) + A SFLPAG(0001) diff --git a/perp/qrpglesrc/perpselr.sqlrpgle b/perp/qrpglesrc/perpselr.sqlrpgle index bf904373..120e7186 100644 --- a/perp/qrpglesrc/perpselr.sqlrpgle +++ b/perp/qrpglesrc/perpselr.sqlrpgle @@ -84,20 +84,25 @@ dow not *in03 and not *in12; iter; // refresh endif; - selRrn = 0; - readc cosfl; - dow not %eof(perpseld); - if sopt = '1'; - if selRrn = 0; - selRrn = rrn; - else; - writeMsg('Only one company may be selected per Enter.'); - endif; - elseif sopt <> ''; - writeMsg('Option ' + %trim(sopt) + ' is not valid - use 1.'); - endif; + // Guard on numCo: READC against a subfile that was never written to + // this cycle (0 rows loaded) raises a "Session or device error" + // (CPF5006-class) runtime error instead of just returning *EOF. + if numCo > 0; + selRrn = 0; readc cosfl; - enddo; + dow not %eof(perpseld); + if sopt = '1'; + if selRrn = 0; + selRrn = rrn; + else; + writeMsg('Only one company may be selected per Enter.'); + endif; + elseif sopt <> ''; + writeMsg('Option ' + %trim(sopt) + ' is not valid - use 1.'); + endif; + readc cosfl; + enddo; + endif; if selRrn > 0 and msgrrn = 0; chain selRrn cosfl; diff --git a/perp/qrpglesrc/wrkcmr.sqlrpgle b/perp/qrpglesrc/wrkcmr.sqlrpgle index 484b63ed..6b2fc37d 100644 --- a/perp/qrpglesrc/wrkcmr.sqlrpgle +++ b/perp/qrpglesrc/wrkcmr.sqlrpgle @@ -94,19 +94,24 @@ dow not *in03 and not *in12; iter; endif; - // Process subfile options - selRrn = 0; - selOpt = ' '; - readc cmsfl; - dow not %eof(wrkcmd); - if sopt <> ''; - selRrn = rrn; - selOpt = sopt; - exsr handleOpt; - selRrn = 0; - endif; + // Process subfile options. Guard on numRows: READC against a subfile + // that was never written to this cycle (0 rows loaded) raises a + // "Session or device error" (CPF5006-class) runtime error instead of + // just returning *EOF. + if numRows > 0; + selRrn = 0; + selOpt = ' '; readc cmsfl; - enddo; + dow not %eof(wrkcmd); + if sopt <> ''; + selRrn = rrn; + selOpt = sopt; + exsr handleOpt; + selRrn = 0; + endif; + readc cmsfl; + enddo; + endif; enddo; diff --git a/perp/qrpglesrc/wrkcnvr.sqlrpgle b/perp/qrpglesrc/wrkcnvr.sqlrpgle new file mode 100644 index 00000000..317f563d --- /dev/null +++ b/perp/qrpglesrc/wrkcnvr.sqlrpgle @@ -0,0 +1,330 @@ +**free + +// --------------------------------------------------------------------- +// Program: wrkcnvr (Work with Item UOM Conversions) +// Purpose: DSPF-based CRUD for item_uom_conversion, scoped to the +// company selected via perpselr (*LDA positions 1-3) and an +// item number entered on screen. Callable standalone from the +// PERP menu (PERP-21) or pre-scoped by passing company/item +// (PERP-23 item master maintenance calls it this way, option 6 +// on the item subfile). +// Example: for item WIDGET1, 1 CS = 12 EA. +// Epic: PERP-3 (PERP-21 / PERP-23) +// --------------------------------------------------------------------- + +ctl-opt dftactgrp(*no) actgrp(*new); + +dcl-pi *n; + pCompcd char(3) const options(*nopass); + pItem varchar(25) const options(*nopass); +end-pi; + +dcl-f wrkcnvd workstn sfile(cvsfl:rrn) sfile(cvmsgsfl:msgrrn); + +dcl-ds ldaDS dtaara(*lda) len(1024) qualified; + compcd char(3) pos(1); +end-ds; + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-ds statusDS psds qualified; + programName char(10) pos(334); +end-ds; + +dcl-ds cvRow qualified; + cfrom varchar(5); + cto varchar(5); + cfact packed(15:6); + cactive char(1); +end-ds; + +dcl-ds rows likeds(cvRow) dim(500); +dcl-s numRows int(10); +dcl-s i int(10); +dcl-s rrn int(10); +dcl-s msgrrn int(10); +dcl-s msgkey char(4); +dcl-s selRrn int(10); +dcl-s selOpt char(1); +dcl-s filter varchar(25); +dcl-s compcd char(3); + +in ldaDS; +compcd = ldaDS.compcd; +filter = ''; + +if %parms >= 1 and pCompcd <> ''; + compcd = pCompcd; +endif; +scompdsp = compcd; +sfitem = ''; +if %parms >= 2 and pItem <> ''; + filter = pItem; + sfitem = pItem; +endif; + +if compcd = ''; + exsr clearMsgs; + writeMsg('No company selected - run Select Company (PERPSELR) first.'); +endif; + +dow not *in03 and not *in12; + if compcd = ''; + *in30 = *off; + write cvnoitem; + write cvfoot; + if msgrrn > 0; + *in40 = *on; + write cvmsgctl; + else; + *in40 = *off; + endif; + exfmt cvctl; + leave; + endif; + + exsr clearMsgs; + + if filter = ''; + *in30 = *off; + numRows = 0; + write cvnoitem; + else; + exsr loadRows; + if numRows = 0; + *in30 = *off; + write cvnone; + else; + exsr fillSubfile; + *in30 = *on; + endif; + endif; + + write cvfoot; + if msgrrn > 0; + *in40 = *on; + write cvmsgctl; + else; + *in40 = *off; + endif; + exfmt cvctl; + + if *in03 or *in12; + leave; + endif; + + if *in05; + filter = sfitem; + iter; + endif; + + if *in06; + if sfitem = ''; + writeMsg('Enter an item number before adding a conversion.'); + else; + filter = sfitem; + exsr addRow; + endif; + iter; + endif; + + // Refresh scope from screen entry + if sfitem <> filter; + filter = sfitem; + iter; + endif; + + // Process subfile options. Guard on numRows: READC against a subfile + // that was never written to this cycle (0 rows loaded) raises a + // "Session or device error" (CPF5006-class) runtime error instead of + // just returning *EOF. + if numRows > 0; + selRrn = 0; + selOpt = ' '; + readc cvsfl; + dow not %eof(wrkcnvd); + if sopt <> ''; + selRrn = rrn; + selOpt = sopt; + exsr handleOpt; + selRrn = 0; + endif; + readc cvsfl; + enddo; + endif; + +enddo; + +*inlr = *on; +return; + +// --------------------------------------------------------------------- +begsr loadRows; + numRows = 0; + exec sql declare c1 cursor for + select from_uom, to_uom, conversion_factor, is_active + from perpdemo.item_uom_conversion + where company_code = :compcd and item_number = :filter + order by from_uom, to_uom; + exec sql open c1; + if sqlcode < 0; + writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); + return; + endif; + + dow numRows < %elem(rows); + exec sql fetch c1 into :cvRow; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + numRows += 1; + rows(numRows) = cvRow; + enddo; + exec sql close c1; +endsr; + +// --------------------------------------------------------------------- +begsr fillSubfile; + rrn = 0; + *in31 = *on; + write cvctl; + *in31 = *off; + for i = 1 to numRows; + *in50 = *off; + *in51 = *off; + sopt = ''; + sfrom = rows(i).cfrom; + sto = rows(i).cto; + sfact = rows(i).cfact; + rrn += 1; + write cvsfl; + endfor; +endsr; + +// --------------------------------------------------------------------- +begsr handleOpt; + chain selRrn cvsfl; + if %found(wrkcnvd); + select; + when selOpt = '2'; + exsr changeRow; + when selOpt = '4'; + exsr deleteRow; + other; + writeMsg('Option ' + selOpt + ' not valid.'); + endsl; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr addRow; + emode = 'A'; + efrom = ''; + eto = ''; + efact = 0; + eactive = 'Y'; + exsr editLoop; + if not *in12 and efrom <> '' and eto <> ''; + exec sql + insert into perpdemo.item_uom_conversion + (company_code, item_number, from_uom, to_uom, conversion_factor, is_active) + values (:compcd, :filter, :efrom, :eto, :efact, :eactive); + if sqlcode < 0; + writeMsg('Add failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Added ' + %trim(efrom) + ' -> ' + %trim(eto) + '.'); + endif; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr changeRow; + emode = 'C'; + efrom = sfrom; + eto = sto; + exec sql + select conversion_factor, is_active + into :efact, :eactive + from perpdemo.item_uom_conversion + where company_code = :compcd and item_number = :filter + and from_uom = :efrom and to_uom = :eto; + if sqlcode <> 0; + writeMsg('Row disappeared before change.'); + return; + endif; + exsr editLoop; + if not *in12; + exec sql + update perpdemo.item_uom_conversion + set conversion_factor = :efact, + is_active = :eactive, + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd and item_number = :filter + and from_uom = :efrom and to_uom = :eto; + if sqlcode < 0; + writeMsg('Change failed: SQLCODE=' + %char(sqlcode)); + else; + writeMsg('Updated ' + %trim(efrom) + ' -> ' + %trim(eto) + '.'); + endif; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr deleteRow; + exec sql + delete from perpdemo.item_uom_conversion + where company_code = :compcd and item_number = :filter + and from_uom = :sfrom and to_uom = :sto; + if sqlcode < 0; + writeMsg('Delete failed: SQLSTATE=' + sqlstate); + else; + writeMsg('Deleted ' + %trim(sfrom) + ' -> ' + %trim(sto) + '.'); + endif; +endsr; + +// --------------------------------------------------------------------- +begsr editLoop; + exfmt cvedit; +endsr; + +// --------------------------------------------------------------------- +begsr clearMsgs; + msgrrn = 0; + *in41 = *on; + write cvmsgctl; + *in41 = *off; +endsr; + +// --------------------------------------------------------------------- +dcl-proc writeMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + smsgkey : + x'0000000000000000'); + msgrrn += 1; + spgmq = statusDS.programName; + write cvmsgsfl; +end-proc; diff --git a/perp/qrpglesrc/wrkiclr.sqlrpgle b/perp/qrpglesrc/wrkiclr.sqlrpgle new file mode 100644 index 00000000..7fdb1231 --- /dev/null +++ b/perp/qrpglesrc/wrkiclr.sqlrpgle @@ -0,0 +1,301 @@ +**free + +// --------------------------------------------------------------------- +// Program: wrkiclr (Work with Item Classes) +// Purpose: DSPF-based CRUD for item_class, scoped by the company +// selected via perpselr (*LDA positions 1-3). Options 2/4/5 +// change/delete/display; F6 adds. Delete falls through to a +// DB2 FK violation (SQL0532/SQL0531) if the class is +// referenced by item -- RPG surfaces the SQLSTATE cleanly +// rather than pre-checking. +// Epic: PERP-3 (PERP-22) +// --------------------------------------------------------------------- + +ctl-opt dftactgrp(*no) actgrp(*new); + +dcl-f wrkicld workstn sfile(icsfl:rrn) sfile(icmsgsfl:msgrrn); + +dcl-ds ldaDS dtaara(*lda) len(1024) qualified; + compcd char(3) pos(1); +end-ds; + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-ds statusDS psds qualified; + programName char(10) pos(334); +end-ds; + +dcl-ds icRow qualified; + class varchar(10); + desc varchar(60); + active char(1); +end-ds; + +dcl-ds rows likeds(icRow) dim(500); +dcl-s numRows int(10); +dcl-s i int(10); +dcl-s rrn int(10); +dcl-s msgrrn int(10); +dcl-s msgkey char(4); +dcl-s selRrn int(10); +dcl-s selOpt char(1); +dcl-s compcd char(3); + +in ldaDS; +compcd = ldaDS.compcd; +scompdsp = compcd; + +if compcd = ''; + exsr clearMsgs; + writeMsg('No company selected - run Select Company (PERPSELR) first.'); +endif; + +dow not *in03 and not *in12; + if compcd = ''; + *in30 = *off; + write icnoco; + write icfoot; + if msgrrn > 0; + *in40 = *on; + write icmsgctl; + else; + *in40 = *off; + endif; + exfmt icctl; + leave; + endif; + + exsr clearMsgs; + exsr loadRows; + + if numRows = 0; + *in30 = *off; + write icnone; + else; + exsr fillSubfile; + *in30 = *on; + endif; + + write icfoot; + if msgrrn > 0; + *in40 = *on; + write icmsgctl; + else; + *in40 = *off; + endif; + exfmt icctl; + + if *in03 or *in12; + leave; + endif; + + if *in05; + iter; + endif; + + if *in06; + exsr addRow; + iter; + endif; + + // Process subfile options. Guard on numRows: READC against a subfile + // that was never written to this cycle (0 rows loaded) raises a + // "Session or device error" (CPF5006-class) runtime error instead of + // just returning *EOF. + if numRows > 0; + selRrn = 0; + selOpt = ' '; + readc icsfl; + dow not %eof(wrkicld); + if sopt <> ''; + selRrn = rrn; + selOpt = sopt; + exsr handleOpt; + selRrn = 0; + endif; + readc icsfl; + enddo; + endif; + +enddo; + +*inlr = *on; +return; + +// --------------------------------------------------------------------- +begsr loadRows; + numRows = 0; + exec sql declare c1 cursor for + select class_code, description, is_active + from perpdemo.item_class + where company_code = :compcd + order by class_code; + exec sql open c1; + if sqlcode < 0; + writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); + return; + endif; + + dow numRows < %elem(rows); + exec sql fetch c1 into :icRow; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + numRows += 1; + rows(numRows) = icRow; + enddo; + exec sql close c1; +endsr; + +// --------------------------------------------------------------------- +begsr fillSubfile; + rrn = 0; + *in31 = *on; + write icctl; + *in31 = *off; + for i = 1 to numRows; + *in50 = *off; + *in51 = *off; + sopt = ''; + sclass = rows(i).class; + sdesc = rows(i).desc; + rrn += 1; + write icsfl; + endfor; +endsr; + +// --------------------------------------------------------------------- +begsr handleOpt; + chain selRrn icsfl; + if %found(wrkicld); + select; + when selOpt = '2'; + exsr changeRow; + when selOpt = '4'; + exsr deleteRow; + when selOpt = '5'; + exsr displayRow; + other; + writeMsg('Option ' + selOpt + ' not valid.'); + endsl; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr addRow; + emode = 'A'; + eclass = ''; + edesc = ''; + eactive = 'Y'; + exsr editLoop; + if not *in12 and eclass <> ''; + exec sql + insert into perpdemo.item_class (company_code, class_code, description, is_active) + values (:compcd, :eclass, :edesc, :eactive); + if sqlcode < 0; + writeMsg('Add failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Added ' + %trim(eclass) + '.'); + endif; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr changeRow; + emode = 'C'; + eclass = sclass; + exec sql + select description, is_active + into :edesc, :eactive + from perpdemo.item_class + where company_code = :compcd and class_code = :eclass; + if sqlcode <> 0; + writeMsg('Row disappeared before change.'); + return; + endif; + exsr editLoop; + if not *in12; + exec sql + update perpdemo.item_class + set description = :edesc, + is_active = :eactive, + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd and class_code = :eclass; + if sqlcode < 0; + writeMsg('Change failed: SQLCODE=' + %char(sqlcode)); + else; + writeMsg('Updated ' + %trim(eclass) + '.'); + endif; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr deleteRow; + exec sql + delete from perpdemo.item_class + where company_code = :compcd and class_code = :sclass; + if sqlcode < 0; + writeMsg('Delete failed (in use?): SQLSTATE=' + sqlstate); + else; + writeMsg('Deleted ' + %trim(sclass) + '.'); + endif; +endsr; + +// --------------------------------------------------------------------- +begsr displayRow; + emode = 'D'; + eclass = sclass; + exec sql + select description, is_active + into :edesc, :eactive + from perpdemo.item_class + where company_code = :compcd and class_code = :eclass; + exsr editLoop; +endsr; + +// --------------------------------------------------------------------- +begsr editLoop; + exfmt icedit; +endsr; + +// --------------------------------------------------------------------- +begsr clearMsgs; + msgrrn = 0; + *in41 = *on; + write icmsgctl; + *in41 = *off; +endsr; + +// --------------------------------------------------------------------- +dcl-proc writeMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + smsgkey : + x'0000000000000000'); + msgrrn += 1; + spgmq = statusDS.programName; + write icmsgsfl; +end-proc; diff --git a/perp/qrpglesrc/wrkitmr.sqlrpgle b/perp/qrpglesrc/wrkitmr.sqlrpgle new file mode 100644 index 00000000..3c2e000c --- /dev/null +++ b/perp/qrpglesrc/wrkitmr.sqlrpgle @@ -0,0 +1,406 @@ +**free + +// --------------------------------------------------------------------- +// Program: wrkitmr (Work with Items -- item master maintenance) +// Purpose: DSPF-based CRUD for item, scoped by the company selected via +// perpselr (*LDA positions 1-3). Subfile filters by class, +// active-only, and low-stock-only (qty_on_hand <= reorder_point). +// The edit panel covers descriptions/class/UOMs/lot flag, +// read-only balances, reorder parameters, and location. +// Balances are never written here -- per the epic, they're +// adjusted via receipt/reconciliation programs (later epics). +// Option 6 on the subfile calls wrkcnvr pre-scoped to the +// selected item, per PERP-21's "called from item maintenance" +// integration point. +// Epic: PERP-3 (PERP-23) +// --------------------------------------------------------------------- + +ctl-opt dftactgrp(*no) actgrp(*new); + +dcl-f wrkitmd workstn sfile(wisfl:rrn) sfile(wimsgsfl:msgrrn); + +dcl-ds ldaDS dtaara(*lda) len(1024) qualified; + compcd char(3) pos(1); +end-ds; + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-pr callWrkcnvr extpgm('WRKCNVR'); + pCompcd char(3) const; + pItem varchar(25) const; +end-pr; + +dcl-pr callWrklotr extpgm('WRKLOTR'); + pCompcd char(3) const; + pItem varchar(25) const; +end-pr; + +dcl-ds statusDS psds qualified; + programName char(10) pos(334); +end-ds; + +dcl-ds itemRow qualified; + item varchar(25); + desc varchar(60); + class varchar(10); + lotctl char(1); + onhand packed(15:4); + rordpt packed(15:4); +end-ds; + +dcl-ds rows likeds(itemRow) dim(500); +dcl-s numRows int(10); +dcl-s i int(10); +dcl-s rrn int(10); +dcl-s msgrrn int(10); +dcl-s msgkey char(4); +dcl-s selRrn int(10); +dcl-s selOpt char(1); +dcl-s compcd char(3); +dcl-s fClass varchar(10); +dcl-s fActOnly char(1); +dcl-s fLowOnly char(1); + +in ldaDS; +compcd = ldaDS.compcd; +scompdsp = compcd; +fClass = ''; +fActOnly = 'N'; +fLowOnly = 'N'; +sfclass = ''; +sfact = 'N'; +sflow = 'N'; + +if compcd = ''; + exsr clearMsgs; + writeMsg('No company selected - run Select Company (PERPSELR) first.'); +endif; + +dow not *in03 and not *in12; + if compcd = ''; + *in30 = *off; + write winoco; + write wifoot; + if msgrrn > 0; + *in40 = *on; + write wimsgctl; + else; + *in40 = *off; + endif; + exfmt wictl; + leave; + endif; + + exsr clearMsgs; + exsr loadRows; + + if numRows = 0; + *in30 = *off; + write winone; + else; + exsr fillSubfile; + *in30 = *on; + endif; + + write wifoot; + if msgrrn > 0; + *in40 = *on; + write wimsgctl; + else; + *in40 = *off; + endif; + exfmt wictl; + + if *in03 or *in12; + leave; + endif; + + if *in05; + fClass = sfclass; + fActOnly = sfact; + fLowOnly = sflow; + iter; + endif; + + if *in06; + exsr addRow; + iter; + endif; + + // Refresh filters from screen entry + if sfclass <> fClass or sfact <> fActOnly or sflow <> fLowOnly; + fClass = sfclass; + fActOnly = sfact; + fLowOnly = sflow; + iter; + endif; + + // Process subfile options. Guard on numRows: READC against a subfile + // that was never written to this cycle (0 rows loaded) raises a + // "Session or device error" (CPF5006-class) runtime error instead of + // just returning *EOF. + if numRows > 0; + selRrn = 0; + selOpt = ' '; + readc wisfl; + dow not %eof(wrkitmd); + if sopt <> ''; + selRrn = rrn; + selOpt = sopt; + exsr handleOpt; + selRrn = 0; + endif; + readc wisfl; + enddo; + endif; + +enddo; + +*inlr = *on; +return; + +// --------------------------------------------------------------------- +begsr loadRows; + numRows = 0; + exec sql declare c1 cursor for + select item_number, item_description, class_code, lot_controlled, + qty_on_hand, reorder_point + from perpdemo.item + where company_code = :compcd + and (:fClass = '' or class_code = :fClass) + and (:fActOnly = 'N' or is_active = 'Y') + and (:fLowOnly = 'N' or qty_on_hand <= reorder_point) + order by item_number; + exec sql open c1; + if sqlcode < 0; + writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); + return; + endif; + + dow numRows < %elem(rows); + exec sql fetch c1 into :itemRow; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + numRows += 1; + rows(numRows) = itemRow; + enddo; + exec sql close c1; +endsr; + +// --------------------------------------------------------------------- +begsr fillSubfile; + rrn = 0; + *in31 = *on; + write wictl; + *in31 = *off; + for i = 1 to numRows; + *in50 = *off; + *in51 = *off; + sopt = ''; + siitem = rows(i).item; + sidesc = rows(i).desc; + siclass = rows(i).class; + silot = rows(i).lotctl; + if rows(i).onhand <= rows(i).rordpt; + silow = '*'; + else; + silow = ''; + endif; + rrn += 1; + write wisfl; + endfor; +endsr; + +// --------------------------------------------------------------------- +begsr handleOpt; + chain selRrn wisfl; + if %found(wrkitmd); + select; + when selOpt = '2'; + exsr changeRow; + when selOpt = '4'; + exsr deleteRow; + when selOpt = '5'; + exsr displayRow; + when selOpt = '6'; + callWrkcnvr(compcd : siitem); + when selOpt = '7'; + callWrklotr(compcd : siitem); + other; + writeMsg('Option ' + selOpt + ' not valid.'); + endsl; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr addRow; + emode = 'A'; + eitem = ''; + edesc = ''; + eshort = ''; + eclass = fClass; + einvuom = ''; + estkuom = ''; + elotctl = 'N'; + eqoh = 0; + eqavl = 0; + eqfrz = 0; + eqoo = 0; + erordpt = 0; + ecritlv = 0; + eminqty = 0; + emaxqty = 0; + esafstk = 0; + eleadtm = 0; + eaisle = ''; + ebay = ''; + eshelf = ''; + exsr editLoop; + if not *in12 and eitem <> ''; + exec sql + insert into perpdemo.item + (company_code, item_number, item_description, short_description, + class_code, inventory_uom, stocking_uom, lot_controlled, + reorder_point, critical_level, min_qty, max_qty, safety_stock, + lead_time_days, aisle_code, bay_code, shelf_code) + values (:compcd, :eitem, :edesc, :eshort, + :eclass, :einvuom, :estkuom, :elotctl, + :erordpt, :ecritlv, :eminqty, :emaxqty, :esafstk, + :eleadtm, :eaisle, :ebay, :eshelf); + if sqlcode < 0; + writeMsg('Add failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Added ' + %trim(eitem) + '.'); + endif; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr changeRow; + emode = 'C'; + eitem = siitem; + exec sql + select item_description, short_description, class_code, + inventory_uom, stocking_uom, lot_controlled, + qty_on_hand, qty_available, qty_frozen, qty_on_order, + reorder_point, critical_level, min_qty, max_qty, safety_stock, + lead_time_days, aisle_code, bay_code, shelf_code + into :edesc, :eshort, :eclass, + :einvuom, :estkuom, :elotctl, + :eqoh, :eqavl, :eqfrz, :eqoo, + :erordpt, :ecritlv, :eminqty, :emaxqty, :esafstk, + :eleadtm, :eaisle, :ebay, :eshelf + from perpdemo.item + where company_code = :compcd and item_number = :eitem; + if sqlcode <> 0; + writeMsg('Row disappeared before change.'); + return; + endif; + exsr editLoop; + if not *in12; + exec sql + update perpdemo.item + set item_description = :edesc, + short_description = :eshort, + class_code = :eclass, + inventory_uom = :einvuom, + stocking_uom = :estkuom, + lot_controlled = :elotctl, + reorder_point = :erordpt, + critical_level = :ecritlv, + min_qty = :eminqty, + max_qty = :emaxqty, + safety_stock = :esafstk, + lead_time_days = :eleadtm, + aisle_code = :eaisle, + bay_code = :ebay, + shelf_code = :eshelf, + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd and item_number = :eitem; + if sqlcode < 0; + writeMsg('Change failed: SQLCODE=' + %char(sqlcode)); + else; + writeMsg('Updated ' + %trim(eitem) + '.'); + endif; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr deleteRow; + exec sql + delete from perpdemo.item + where company_code = :compcd and item_number = :siitem; + if sqlcode < 0; + writeMsg('Delete failed (in use?): SQLSTATE=' + sqlstate); + else; + writeMsg('Deleted ' + %trim(siitem) + '.'); + endif; +endsr; + +// --------------------------------------------------------------------- +begsr displayRow; + emode = 'D'; + eitem = siitem; + exec sql + select item_description, short_description, class_code, + inventory_uom, stocking_uom, lot_controlled, + qty_on_hand, qty_available, qty_frozen, qty_on_order, + reorder_point, critical_level, min_qty, max_qty, safety_stock, + lead_time_days, aisle_code, bay_code, shelf_code + into :edesc, :eshort, :eclass, + :einvuom, :estkuom, :elotctl, + :eqoh, :eqavl, :eqfrz, :eqoo, + :erordpt, :ecritlv, :eminqty, :emaxqty, :esafstk, + :eleadtm, :eaisle, :ebay, :eshelf + from perpdemo.item + where company_code = :compcd and item_number = :eitem; + exsr editLoop; +endsr; + +// --------------------------------------------------------------------- +begsr editLoop; + exfmt wiedit; +endsr; + +// --------------------------------------------------------------------- +begsr clearMsgs; + msgrrn = 0; + *in41 = *on; + write wimsgctl; + *in41 = *off; +endsr; + +// --------------------------------------------------------------------- +dcl-proc writeMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + smsgkey : + x'0000000000000000'); + msgrrn += 1; + spgmq = statusDS.programName; + write wimsgsfl; +end-proc; diff --git a/perp/qrpglesrc/wrklotr.sqlrpgle b/perp/qrpglesrc/wrklotr.sqlrpgle new file mode 100644 index 00000000..4a0cdb0c --- /dev/null +++ b/perp/qrpglesrc/wrklotr.sqlrpgle @@ -0,0 +1,357 @@ +**free + +// --------------------------------------------------------------------- +// Program: wrklotr (Work with Item Lots) +// Purpose: DSPF-based CRUD for item_lot, scoped by the company selected +// via perpselr (*LDA positions 1-3) and an item number entered +// on screen (same scoping idiom as wrkcnvr). Shows item.on_hand +// alongside SUM(item_lot.qty_on_hand) and flags a discrepancy +// -- the entry point for the reconciliation demo (Option C: +// balances denormalized on both item and item_lot by design). +// Callable standalone or pre-scoped by passing company/item +// (mirrors wrkcnvr's PERP-23 integration). +// Epic: PERP-3 (PERP-24) +// --------------------------------------------------------------------- + +ctl-opt dftactgrp(*no) actgrp(*new); + +dcl-pi *n; + pCompcd char(3) const options(*nopass); + pItem varchar(25) const options(*nopass); +end-pi; + +dcl-f wrklotd workstn sfile(ltsfl:rrn) sfile(ltmsgsfl:msgrrn); + +dcl-ds ldaDS dtaara(*lda) len(1024) qualified; + compcd char(3) pos(1); +end-ds; + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-ds statusDS psds qualified; + programName char(10) pos(334); +end-ds; + +dcl-ds ltRow qualified; + lot varchar(20); + qty packed(15:4); + recv varchar(10); + expd varchar(10); +end-ds; + +dcl-ds rows likeds(ltRow) dim(500); +dcl-s numRows int(10); +dcl-s i int(10); +dcl-s rrn int(10); +dcl-s msgrrn int(10); +dcl-s msgkey char(4); +dcl-s selRrn int(10); +dcl-s selOpt char(1); +dcl-s filter varchar(25); +dcl-s compcd char(3); +dcl-s itemOh packed(15:4); +dcl-s lotTotal packed(15:4); + +in ldaDS; +compcd = ldaDS.compcd; + +if %parms >= 1 and pCompcd <> ''; + compcd = pCompcd; +endif; +scompdsp = compcd; +filter = ''; +if %parms >= 2 and pItem <> ''; + filter = pItem; + sfitem = pItem; +else; + sfitem = ''; +endif; + +if compcd = ''; + exsr clearMsgs; + writeMsg('No company selected - run Select Company (PERPSELR) first.'); +endif; + +dow not *in03 and not *in12; + if compcd = ''; + *in30 = *off; + write ltnoitem; + write ltfoot; + if msgrrn > 0; + *in40 = *on; + write ltmsgctl; + else; + *in40 = *off; + endif; + exfmt ltctl; + leave; + endif; + + exsr clearMsgs; + + if filter = ''; + *in30 = *off; + *in60 = *off; + numRows = 0; + sioh = 0; + slottot = 0; + write ltnoitem; + else; + exsr loadBalances; + exsr loadRows; + if numRows = 0; + *in30 = *off; + write ltnone; + else; + exsr fillSubfile; + *in30 = *on; + endif; + endif; + + write ltfoot; + if msgrrn > 0; + *in40 = *on; + write ltmsgctl; + else; + *in40 = *off; + endif; + exfmt ltctl; + + if *in03 or *in12; + leave; + endif; + + if *in05; + filter = sfitem; + iter; + endif; + + if *in06; + if sfitem = ''; + writeMsg('Enter an item number before adding a lot.'); + else; + filter = sfitem; + exsr addRow; + endif; + iter; + endif; + + // Refresh scope from screen entry + if sfitem <> filter; + filter = sfitem; + iter; + endif; + + // Process subfile options. Guard on numRows: READC against a subfile + // that was never written to this cycle (0 rows loaded) raises a + // "Session or device error" (CPF5006-class) runtime error instead of + // just returning *EOF. + if numRows > 0; + selRrn = 0; + selOpt = ' '; + readc ltsfl; + dow not %eof(wrklotd); + if sopt <> ''; + selRrn = rrn; + selOpt = sopt; + exsr handleOpt; + selRrn = 0; + endif; + readc ltsfl; + enddo; + endif; + +enddo; + +*inlr = *on; +return; + +// --------------------------------------------------------------------- +begsr loadBalances; + exec sql + select qty_on_hand into :itemOh + from perpdemo.item + where company_code = :compcd and item_number = :filter; + if sqlcode <> 0; + itemOh = 0; + endif; + exec sql + select coalesce(sum(qty_on_hand), 0) into :lotTotal + from perpdemo.item_lot + where company_code = :compcd and item_number = :filter; + sioh = itemOh; + slottot = lotTotal; + if itemOh <> lotTotal; + *in60 = *on; + else; + *in60 = *off; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr loadRows; + numRows = 0; + exec sql declare c1 cursor for + select lot_number, qty_on_hand, + char(received_date, iso), + coalesce(char(expiry_date, iso), '') + from perpdemo.item_lot + where company_code = :compcd and item_number = :filter + order by lot_number; + exec sql open c1; + if sqlcode < 0; + writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); + return; + endif; + + dow numRows < %elem(rows); + exec sql fetch c1 into :ltRow; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + numRows += 1; + rows(numRows) = ltRow; + enddo; + exec sql close c1; +endsr; + +// --------------------------------------------------------------------- +begsr fillSubfile; + rrn = 0; + *in31 = *on; + write ltctl; + *in31 = *off; + for i = 1 to numRows; + *in50 = *off; + *in51 = *off; + sopt = ''; + slot = rows(i).lot; + sqty = rows(i).qty; + srecv = rows(i).recv; + sexpd = rows(i).expd; + rrn += 1; + write ltsfl; + endfor; +endsr; + +// --------------------------------------------------------------------- +begsr handleOpt; + chain selRrn ltsfl; + if %found(wrklotd); + select; + when selOpt = '2'; + exsr changeRow; + when selOpt = '4'; + exsr deleteRow; + other; + writeMsg('Option ' + selOpt + ' not valid.'); + endsl; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr addRow; + emode = 'A'; + elot = ''; + eqty = 0; + erecv = %char(%date():*iso); + eexpd = ''; + eactive = 'Y'; + exsr editLoop; + if not *in12 and elot <> ''; + exec sql + insert into perpdemo.item_lot + (company_code, item_number, lot_number, qty_on_hand, received_date, expiry_date) + values (:compcd, :filter, :elot, :eqty, date(:erecv), + case when :eexpd = '' then null else date(:eexpd) end); + if sqlcode < 0; + writeMsg('Add failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Added lot ' + %trim(elot) + '.'); + endif; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr changeRow; + emode = 'C'; + elot = slot; + eqty = sqty; + erecv = srecv; + eexpd = sexpd; + eactive = 'Y'; + exsr editLoop; + if not *in12; + exec sql + update perpdemo.item_lot + set qty_on_hand = :eqty, + received_date = date(:erecv), + expiry_date = case when :eexpd = '' then null else date(:eexpd) end, + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd and item_number = :filter and lot_number = :elot; + if sqlcode < 0; + writeMsg('Change failed: SQLCODE=' + %char(sqlcode)); + else; + writeMsg('Updated lot ' + %trim(elot) + '.'); + endif; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr deleteRow; + exec sql + delete from perpdemo.item_lot + where company_code = :compcd and item_number = :filter and lot_number = :slot; + if sqlcode < 0; + writeMsg('Delete failed: SQLSTATE=' + sqlstate); + else; + writeMsg('Deleted lot ' + %trim(slot) + '.'); + endif; +endsr; + +// --------------------------------------------------------------------- +begsr editLoop; + exfmt ltedit; +endsr; + +// --------------------------------------------------------------------- +begsr clearMsgs; + msgrrn = 0; + *in41 = *on; + write ltmsgctl; + *in41 = *off; +endsr; + +// --------------------------------------------------------------------- +dcl-proc writeMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + smsgkey : + x'0000000000000000'); + msgrrn += 1; + spgmq = statusDS.programName; + write ltmsgsfl; +end-proc; diff --git a/perp/qrpglesrc/wrkuomr.sqlrpgle b/perp/qrpglesrc/wrkuomr.sqlrpgle new file mode 100644 index 00000000..e40f2eca --- /dev/null +++ b/perp/qrpglesrc/wrkuomr.sqlrpgle @@ -0,0 +1,276 @@ +**free + +// --------------------------------------------------------------------- +// Program: wrkuomr (Work with Units of Measure) +// Purpose: DSPF-based CRUD for the uom table. Global (not company- +// scoped) master data. Options 2/4/5 change/delete/display; +// F6 adds. Delete falls through to a DB2 FK violation +// (SQL0532/SQL0531) if the UOM is referenced by item or +// item_uom_conversion -- RPG surfaces the SQLSTATE cleanly +// rather than pre-checking. +// Epic: PERP-3 (PERP-21) +// --------------------------------------------------------------------- + +ctl-opt dftactgrp(*no) actgrp(*new); + +dcl-f wrkuomd workstn sfile(uosfl:rrn) sfile(uomsgsfl:msgrrn); + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-ds statusDS psds qualified; + programName char(10) pos(334); +end-ds; + +dcl-ds uomRow qualified; + code varchar(5); + desc varchar(60); + cat varchar(20); + active char(1); +end-ds; + +dcl-ds rows likeds(uomRow) dim(500); +dcl-s numRows int(10); +dcl-s i int(10); +dcl-s rrn int(10); +dcl-s msgrrn int(10); +dcl-s msgkey char(4); +dcl-s selRrn int(10); +dcl-s selOpt char(1); + +dow not *in03 and not *in12; + exsr clearMsgs; + exsr loadRows; + + if numRows = 0; + *in30 = *off; + write uonone; + else; + exsr fillSubfile; + *in30 = *on; + endif; + + write uofoot; + if msgrrn > 0; + *in40 = *on; + write uomsgctl; + else; + *in40 = *off; + endif; + exfmt uoctl; + + if *in03 or *in12; + leave; + endif; + + if *in05; + iter; + endif; + + if *in06; + exsr addRow; + iter; + endif; + + // Process subfile options. Guard on numRows: READC against a subfile + // that was never written to this cycle (0 rows loaded) raises a + // "Session or device error" (CPF5006-class) runtime error instead of + // just returning *EOF. + if numRows > 0; + selRrn = 0; + selOpt = ' '; + readc uosfl; + dow not %eof(wrkuomd); + if sopt <> ''; + selRrn = rrn; + selOpt = sopt; + exsr handleOpt; + selRrn = 0; + endif; + readc uosfl; + enddo; + endif; + +enddo; + +*inlr = *on; +return; + +// --------------------------------------------------------------------- +begsr loadRows; + numRows = 0; + exec sql declare c1 cursor for + select uom_code, description, uom_category, is_active + from perpdemo.uom + order by uom_code; + exec sql open c1; + if sqlcode < 0; + writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); + return; + endif; + + dow numRows < %elem(rows); + exec sql fetch c1 into :uomRow; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + numRows += 1; + rows(numRows) = uomRow; + enddo; + exec sql close c1; +endsr; + +// --------------------------------------------------------------------- +begsr fillSubfile; + rrn = 0; + *in31 = *on; + write uoctl; + *in31 = *off; + for i = 1 to numRows; + *in50 = *off; + *in51 = *off; + sopt = ''; + scode = rows(i).code; + sdesc = rows(i).desc; + scat = rows(i).cat; + rrn += 1; + write uosfl; + endfor; +endsr; + +// --------------------------------------------------------------------- +begsr handleOpt; + chain selRrn uosfl; + if %found(wrkuomd); + select; + when selOpt = '2'; + exsr changeRow; + when selOpt = '4'; + exsr deleteRow; + when selOpt = '5'; + exsr displayRow; + other; + writeMsg('Option ' + selOpt + ' not valid.'); + endsl; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr addRow; + emode = 'A'; + ecode = ''; + edesc = ''; + ecat = ''; + eactive = 'Y'; + exsr editLoop; + if not *in12 and ecode <> ''; + exec sql + insert into perpdemo.uom (uom_code, description, uom_category, is_active) + values (:ecode, :edesc, :ecat, :eactive); + if sqlcode < 0; + writeMsg('Add failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Added ' + %trim(ecode) + '.'); + endif; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr changeRow; + emode = 'C'; + ecode = scode; + exec sql + select description, uom_category, is_active + into :edesc, :ecat, :eactive + from perpdemo.uom + where uom_code = :ecode; + if sqlcode <> 0; + writeMsg('Row disappeared before change.'); + return; + endif; + exsr editLoop; + if not *in12; + exec sql + update perpdemo.uom + set description = :edesc, + uom_category = :ecat, + is_active = :eactive, + updated_at = current_timestamp, + updated_by = user + where uom_code = :ecode; + if sqlcode < 0; + writeMsg('Change failed: SQLCODE=' + %char(sqlcode)); + else; + writeMsg('Updated ' + %trim(ecode) + '.'); + endif; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr deleteRow; + exec sql + delete from perpdemo.uom + where uom_code = :scode; + if sqlcode < 0; + writeMsg('Delete failed (in use?): SQLSTATE=' + sqlstate); + else; + writeMsg('Deleted ' + %trim(scode) + '.'); + endif; +endsr; + +// --------------------------------------------------------------------- +begsr displayRow; + emode = 'D'; + ecode = scode; + exec sql + select description, uom_category, is_active + into :edesc, :ecat, :eactive + from perpdemo.uom + where uom_code = :ecode; + exsr editLoop; +endsr; + +// --------------------------------------------------------------------- +begsr editLoop; + exfmt uoedit; +endsr; + +// --------------------------------------------------------------------- +begsr clearMsgs; + msgrrn = 0; + *in41 = *on; + write uomsgctl; + *in41 = *off; +endsr; + +// --------------------------------------------------------------------- +dcl-proc writeMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + smsgkey : + x'0000000000000000'); + msgrrn += 1; + spgmq = statusDS.programName; + write uomsgsfl; +end-proc; diff --git a/perp/qrpglesrc/wrkusrr.sqlrpgle b/perp/qrpglesrc/wrkusrr.sqlrpgle index 9ce02fc0..d8d41c09 100644 --- a/perp/qrpglesrc/wrkusrr.sqlrpgle +++ b/perp/qrpglesrc/wrkusrr.sqlrpgle @@ -81,18 +81,23 @@ dow not *in03 and not *in12; iter; endif; - selRrn = 0; - selOpt = ' '; - readc usfl; - dow not %eof(wrkusrd); - if sopt <> ''; - selRrn = rrn; - selOpt = sopt; - exsr handleOpt; - selRrn = 0; - endif; + // Guard on numRows: READC against a subfile that was never written to + // this cycle (0 rows loaded) raises a "Session or device error" + // (CPF5006-class) runtime error instead of just returning *EOF. + if numRows > 0; + selRrn = 0; + selOpt = ' '; readc usfl; - enddo; + dow not %eof(wrkusrd); + if sopt <> ''; + selRrn = rrn; + selOpt = sopt; + exsr handleOpt; + selRrn = 0; + endif; + readc usfl; + enddo; + endif; enddo; *inlr = *on; From 96fe0983f30a4d3f35399208ca5d46551aae840d Mon Sep 17 00:00:00 2001 From: Gary Jones Date: Wed, 15 Jul 2026 19:14:32 +0000 Subject: [PATCH 04/13] =?UTF-8?q?PERP-4:=203D=20Warehouse=20Map=20?= =?UTF-8?q?=E2=80=94=20warehouse=5Flayout=20table,=20maintenance=20screen,?= =?UTF-8?q?=20coordinate=20query=20service?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Implements all 3 stories under epic PERP-4: - PERP-25: warehouse_layout DDL (one row per company: grid + bin dims) - PERP-26: WLMR single-record maintenance screen (wlmd.dspf/wlmr.sqlrpgle) - PERP-27: WHCOORD coordinate query service (whcoord.sqlrpgle/_pr.rpgle, whcoord.bnd, whcoordsmk smoke test) — parses item location codes (e.g. 'A1'/'B2'/'S3') for their numeric ordinal in RPG rather than CASTing to INTEGER in SQL, since real seed data mixes a letter prefix with the digit and CAST(...AS INTEGER) rejects that outright. Wires WLMR/WHCOORDSMK into PERPMNU (options 10/11) and documents the alphanumeric-location-code gotcha in DDL_STYLE_GUIDE.md sec 14a. Co-Authored-By: CoderFlow Learn more: https://coderflow.ai --- perp/DDL_STYLE_GUIDE.md | 13 ++ perp/Rules.mk | 25 ++- perp/perp.bnddir | 1 + perp/perpmnu.msgf | 2 + perp/qddlsrc/warehouse_layout.table.sql | 79 +++++++++ perp/qddssrc/perpmnu.dspf | 6 +- perp/qddssrc/wlmd.dspf | 54 +++++++ perp/qrpglesrc/whcoord.sqlrpgle | 165 +++++++++++++++++++ perp/qrpglesrc/whcoord_pr.rpgle | 57 +++++++ perp/qrpglesrc/whcoordsmk.sqlrpgle | 94 +++++++++++ perp/qrpglesrc/wlmr.sqlrpgle | 205 ++++++++++++++++++++++++ perp/qsrvsrc/whcoord.bnd | 5 + 12 files changed, 704 insertions(+), 2 deletions(-) create mode 100644 perp/qddlsrc/warehouse_layout.table.sql create mode 100644 perp/qddssrc/wlmd.dspf create mode 100644 perp/qrpglesrc/whcoord.sqlrpgle create mode 100644 perp/qrpglesrc/whcoord_pr.rpgle create mode 100644 perp/qrpglesrc/whcoordsmk.sqlrpgle create mode 100644 perp/qrpglesrc/wlmr.sqlrpgle create mode 100644 perp/qsrvsrc/whcoord.bnd diff --git a/perp/DDL_STYLE_GUIDE.md b/perp/DDL_STYLE_GUIDE.md index 5ba7ce1b..d4fa62b5 100644 --- a/perp/DDL_STYLE_GUIDE.md +++ b/perp/DDL_STYLE_GUIDE.md @@ -335,6 +335,19 @@ maintenance programs. These apply to every RPG or SQLRPGLE source under otherwise a stale nonzero count from a *previous* scope value lets the guard pass even though nothing was loaded this cycle. +## 14a. Location codes are alphanumeric, not numeric ordinals + +`item.aisle_code` / `bay_code` / `shelf_code` (`PERP-3`/`PERP-20`) are free-text +`VARCHAR(10)` columns. Real seed data mixes a letter prefix with the ordinal +(e.g. `'A1'`, `'B2'`, `'S3'` -- confirmed against the `WIDGET1` seed row). +`CAST(aisle_code AS INTEGER)` rejects that outright with `SQL0420`. + +Any service that needs the numeric ordinal out of one of these codes (e.g. +`whcoord`, `PERP-27`) must parse it in RPG rather than casting the whole +string in SQL -- pull out the digit characters and convert those +(`ordinalFromCode()` in `qrpglesrc/whcoord.sqlrpgle` is the reference +implementation). Don't assume these columns hold pure numeric strings. + ## 15. codermake gotchas - **`.menu` recipe needs `.file` as a *normal* prerequisite**, not diff --git a/perp/Rules.mk b/perp/Rules.mk index c9cd11be..1dbf88de 100644 --- a/perp/Rules.mk +++ b/perp/Rules.mk @@ -46,6 +46,12 @@ item_uom_conversion.file: qddlsrc/item_uom_conversion.table.sql item.file uom.fi item_lot.file: qddlsrc/item_lot.table.sql item.file | perpsjpf.pgm +# --- PERP-25: 3D Warehouse Map — warehouse_layout table ------------------- +# One row per company; FKs company. Drives coordinate derivation in whcoord +# (PERP-27) and the maintenance screen in wlmr (PERP-26). +warehouse_layout.file: qddlsrc/warehouse_layout.table.sql company.file | perpsjpf.pgm + + # --- PERP-19: Document sequence service ---------------------------------- # Atomic per-(company, doc_type) sequence allocator. Module + srvpgm + bnddir. docseq.module: qrpglesrc/docseq.sqlrpgle qrpglesrc/docseq_pr.rpgle | company_config.file document_sequence.file @@ -103,6 +109,23 @@ wrklotd.file: qddssrc/wrklotd.dspf wrklotr.pgm: qrpglesrc/wrklotr.sqlrpgle qddssrc/wrklotd.dspf | wrklotd.file item_lot.file +# --- PERP-27: Warehouse coordinate query service -------------------------- +# Iterator service program: located items in a company joined with x/y/z +# coordinates derived from warehouse_layout. Module + srvpgm + bnddir. +whcoord.module: qrpglesrc/whcoord.sqlrpgle qrpglesrc/whcoord_pr.rpgle | item.file warehouse_layout.file +whcoord.srvpgm: whcoord.module qsrvsrc/whcoord.bnd + +# Smoke-test caller -- CALL PERPDEMO/WHCOORDSMK PARM('ACM'). +whcoordsmk.pgm: qrpglesrc/whcoordsmk.sqlrpgle qrpglesrc/whcoord_pr.rpgle whcoord.srvpgm | perp.bnddir item.file warehouse_layout.file + + +# --- PERP-26: Warehouse layout maintenance -------------------------------- +# Single-record display + edit of warehouse_layout, scoped by *LDA company +# (perpselr). No subfile list -- one row per company. +wlmd.file: qddssrc/wlmd.dspf +wlmr.pgm: qrpglesrc/wlmr.sqlrpgle qddssrc/wlmd.dspf | wlmd.file warehouse_layout.file + + # --- PERP main menu (glue for exploratory verification) ------------------ # Ties the PERP-16/17/18/19/21/22/23/24 programs together into a single # 5250 menu: GO PERPDEMO/PERPMNU @@ -110,7 +133,7 @@ perpmnu.file: qddssrc/perpmnu.dspf perpmnu.msgf: perpmnu.msgf # .file MUST be a normal prereq (not order-only) or codermake silently drops # the CRTMNU recipe. See DDL_STYLE_GUIDE § "codermake menu gotcha". -perpmnu.menu: perpmnu.msgf perpmnu.file | perpselr.pgm wrkcmr.pgm wrkusrr.pgm docseqsmk.pgm wrkuomr.pgm wrkcnvr.pgm wrkiclr.pgm wrkitmr.pgm wrklotr.pgm +perpmnu.menu: perpmnu.msgf perpmnu.file | perpselr.pgm wrkcmr.pgm wrkusrr.pgm docseqsmk.pgm wrkuomr.pgm wrkcnvr.pgm wrkiclr.pgm wrkitmr.pgm wrklotr.pgm wlmr.pgm whcoordsmk.pgm # --- CL setup ------------------------------------------------------------- diff --git a/perp/perp.bnddir b/perp/perp.bnddir index 0b2e022c..e8c1e93e 100644 --- a/perp/perp.bnddir +++ b/perp/perp.bnddir @@ -1,2 +1,3 @@ crtbnddir bnddir($LIBRARY/$NAME) addbnddire bnddir($LIBRARY/$NAME) obj(($LIBRARY/docseq *srvpgm *immed)) +addbnddire bnddir($LIBRARY/$NAME) obj(($LIBRARY/whcoord *srvpgm *immed)) diff --git a/perp/perpmnu.msgf b/perp/perpmnu.msgf index f9c448d0..d7b8bc6c 100644 --- a/perp/perpmnu.msgf +++ b/perp/perpmnu.msgf @@ -8,4 +8,6 @@ addmsgd msgid(usr0006) msgf($LIBRARY/$NAME) msg('call wrkcnvr') addmsgd msgid(usr0007) msgf($LIBRARY/$NAME) msg('call wrkiclr') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0008) msgf($LIBRARY/$NAME) msg('call wrkitmr') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0009) msgf($LIBRARY/$NAME) msg('call wrklotr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0010) msgf($LIBRARY/$NAME) msg('call wlmr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0011) msgf($LIBRARY/$NAME) msg('call whcoordsmk parm(''ACM'')') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0090) msgf($LIBRARY/$NAME) msg('signoff') seclvl(*none) sev(00) fmt(*none) diff --git a/perp/qddlsrc/warehouse_layout.table.sql b/perp/qddlsrc/warehouse_layout.table.sql new file mode 100644 index 00000000..beffc4ee --- /dev/null +++ b/perp/qddlsrc/warehouse_layout.table.sql @@ -0,0 +1,79 @@ +-- --------------------------------------------------------------------------- +-- Table: warehouse_layout (system name WLAYOUT) +-- Module: perp +-- Purpose: Per-company warehouse grid config -- aisle x bay x shelf counts +-- and bin/aisle dimensions in meters. One row per company; drives +-- the coordinate derivation in the whcoord service (PERP-27). +-- Epic: PERP-4 (3D Warehouse Map) / PERP-25 +-- +-- Notes on DB2 for i syntax: +-- * 'notes' is <=10 chars and pure alphanumeric, so it already auto- +-- derives to system name NOTES -- an explicit FOR COLUMN NOTES would +-- raise SQL7029 (same rule as 'item'/'uom'/'company'; see +-- DDL_STYLE_GUIDE.md sec 2). Omitted here for that reason. +-- --------------------------------------------------------------------------- + +CREATE TABLE warehouse_layout FOR SYSTEM NAME WLAYOUT ( + + -- Primary key (one row per company) -------------------------------------- + company_code FOR COLUMN COMPCD CHAR(3) NOT NULL, + + -- Descriptive --------------------------------------------------------------- + warehouse_name FOR COLUMN WHSNM VARCHAR(60) NOT NULL DEFAULT '', + + -- Grid dimensions --------------------------------------------------------- + aisle_count FOR COLUMN ASLCNT INTEGER NOT NULL DEFAULT 1, + bays_per_aisle FOR COLUMN BAYSPA INTEGER NOT NULL DEFAULT 1, + shelves_per_bay FOR COLUMN SHLFSB INTEGER NOT NULL DEFAULT 1, + + -- Bin dimensions, in meters ------------------------------------------------- + bin_width_m FOR COLUMN BINWID DECIMAL(9,4) NOT NULL DEFAULT 1, + bin_depth_m FOR COLUMN BINDEP DECIMAL(9,4) NOT NULL DEFAULT 1, + bin_height_m FOR COLUMN BINHGT DECIMAL(9,4) NOT NULL DEFAULT 1, + aisle_spacing_m FOR COLUMN ASLSPC DECIMAL(9,4) NOT NULL DEFAULT 2, + + -- Free-text notes -- system name auto-derives, see header note ------------ + notes VARCHAR(60) NOT NULL DEFAULT '', + + -- Standard audit block -------------------------------------------------- + created_at FOR COLUMN CRTAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + created_by FOR COLUMN CRTBY VARCHAR(18) NOT NULL DEFAULT USER, + updated_at FOR COLUMN UPDAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_by FOR COLUMN UPDBY VARCHAR(18) NOT NULL DEFAULT USER, + is_active FOR COLUMN ISACT CHAR(1) NOT NULL DEFAULT 'Y', + + -- Primary key ------------------------------------------------------------- + PRIMARY KEY (company_code), + + -- Constraints ------------------------------------------------------------- + CONSTRAINT wlayout_aslcnt_ck CHECK (aisle_count >= 1), + CONSTRAINT wlayout_bayspa_ck CHECK (bays_per_aisle >= 1), + CONSTRAINT wlayout_shlfsb_ck CHECK (shelves_per_bay >= 1), + CONSTRAINT wlayout_binwid_ck CHECK (bin_width_m > 0), + CONSTRAINT wlayout_bindep_ck CHECK (bin_depth_m > 0), + CONSTRAINT wlayout_binhgt_ck CHECK (bin_height_m > 0), + CONSTRAINT wlayout_aslspc_ck CHECK (aisle_spacing_m >= 0), + CONSTRAINT wlayout_isact_ck CHECK (is_active IN ('Y','N')), + + -- FK ------------------------------------------------------------------------ + CONSTRAINT wlayout_company_fk FOREIGN KEY (company_code) + REFERENCES company (company_code) + ON DELETE RESTRICT ON UPDATE RESTRICT +); + +LABEL ON TABLE warehouse_layout IS + 'Warehouse layout config (one row per company)'; + +LABEL ON COLUMN warehouse_layout ( + company_code IS 'Company code (PK, FK to company)', + warehouse_name IS 'Warehouse name', + aisle_count IS 'Number of aisles in the grid', + bays_per_aisle IS 'Bays per aisle', + shelves_per_bay IS 'Shelves per bay', + bin_width_m IS 'Bin width in meters (x axis)', + bin_depth_m IS 'Bin depth in meters', + bin_height_m IS 'Bin height in meters (z axis)', + aisle_spacing_m IS 'Spacing between aisles in meters (y axis)', + notes IS 'Free-text notes', + is_active IS 'Active flag (Y/N, soft delete)' +); diff --git a/perp/qddssrc/perpmnu.dspf b/perp/qddssrc/perpmnu.dspf index 055e84c7..9386937e 100644 --- a/perp/qddssrc/perpmnu.dspf +++ b/perp/qddssrc/perpmnu.dspf @@ -36,7 +36,11 @@ A 11 7'7. Work with item classes' A 12 7'8. Work with items' A 13 7'9. Work with item lots' - A 15 6'90. Sign off' + A 14 6'10. Warehouse layout maintenan- + A ce' + A 15 6'11. Smoke test warehouse coord- + A inate service' + A 17 6'90. Sign off' A* CMDPROMPT Do not delete this DDS spec. A 021 2'Selection: - A ' diff --git a/perp/qddssrc/wlmd.dspf b/perp/qddssrc/wlmd.dspf new file mode 100644 index 00000000..8f7a05c9 --- /dev/null +++ b/perp/qddssrc/wlmd.dspf @@ -0,0 +1,54 @@ + A DSPSIZ(24 80 *DS3) + A PRINT + A CA03(03 'Exit') + A CA05(05 'Refresh') + A CA06(06 'Add') + A CA12(12 'Cancel') + A R WLEDIT + A 1 22'Warehouse Layout Maintenance' + A DSPATR(HI) + A 2 2'Company . . . . . . . :' + A ECOMPC 3A O 2 27 + A 3 2'Status . . . . . . . . :' + A ESTAT 10A O 3 27 + A 5 2'Warehouse name . . . . :' + A EWHSNM 50A B 5 27 + A 7 2'Grid dimensions' + A DSPATR(UL) + A 8 2'Aisles . . . . . . . . :' + A EASLCNT 5Y 0B 8 27EDTCDE(3) + A 9 2'Bays per aisle . . . . :' + A EBAYSPA 5Y 0B 9 27EDTCDE(3) + A 10 2'Shelves per bay . . . . :' + A ESHLFSB 5Y 0B 10 27EDTCDE(3) + A 12 2'Bin dimensions (meters)' + A DSPATR(UL) + A 13 2'Bin width . . . . . . . :' + A EBINWID 9Y 4B 13 27EDTCDE(3) + A 14 2'Bin depth . . . . . . . :' + A EBINDEP 9Y 4B 14 27EDTCDE(3) + A 15 2'Bin height . . . . . . :' + A EBINHGT 9Y 4B 15 27EDTCDE(3) + A 16 2'Aisle spacing . . . . . :' + A EASLSPC 9Y 4B 16 27EDTCDE(3) + A 18 2'Notes . . . . . . . . . :' + A ENOTES 50A B 18 27 + A R WLNOCO + A OVERLAY + A 20 20'** No company selected - run - + A Select Company first **' + A R WLFOOT + A 23 2'F3=Exit F5=Refresh F6=Add- + A F12=Cancel' + A COLOR(BLU) + A R WLMSGSFL SFL + A SFLMSGRCD(24) + A SMSGKEY SFLMSGKEY + A SPGMQ SFLPGMQ(10) + A R WLMSGCTL SFLCTL(WLMSGSFL) + A OVERLAY + A N41 40 SFLDSP + A 41 SFLCLR + A N41 40 SFLEND + A SFLSIZ(0002) + A SFLPAG(0001) diff --git a/perp/qrpglesrc/whcoord.sqlrpgle b/perp/qrpglesrc/whcoord.sqlrpgle new file mode 100644 index 00000000..44a2b192 --- /dev/null +++ b/perp/qrpglesrc/whcoord.sqlrpgle @@ -0,0 +1,165 @@ +**free + +// --------------------------------------------------------------------- +// Module: whcoord (warehouse coordinate query service) +// Purpose: Return every located item in a company joined with x/y/z +// coordinates computed from that company's warehouse_layout +// grid config. Data source for the future 3D map renderer. +// Epic: PERP-4 (3D Warehouse Map) / PERP-27 +// --------------------------------------------------------------------- + +ctl-opt nomain; + +// Real commitment control against PERPJRN -- per DDL_STYLE_GUIDE §7. +exec sql set option closqlcsr = *endmod; + +/copy whcoord_pr.rpgle + +// Module-scope: the company the cursor is open against, and that +// company's layout dims (cached at open time rather than re-queried +// per fetched row). +dcl-s g_company char(3); +dcl-s g_haslayout ind; +dcl-s g_binwid packed(9:4); +dcl-s g_binhgt packed(9:4); +dcl-s g_aslspc packed(9:4); + +// Only items with a fully-populated location are placed on the map -- +// see the design note in whcoord_pr.rpgle. Codes come back as-is (not +// CAST to INTEGER here) -- real seed data mixes a letter prefix with +// the ordinal (e.g. 'A1', 'B2', 'S3'), which CAST(... AS INTEGER) +// rejects outright (SQL0420). ordinalFromCode() below parses it. +exec sql declare whcoordcsr cursor for + select item_number, item_description, + aisle_code, bay_code, shelf_code, + qty_on_hand, qty_available + from perpdemo.item + where company_code = :g_company + and aisle_code <> '' + and bay_code <> '' + and shelf_code <> '' + order by item_number; + +// --------------------------------------------------------------------- +dcl-proc whcoord_open export; + dcl-pi *n ind; + oc_company char(3) const; + oc_errmsg varchar(80); + end-pi; + + oc_errmsg = ''; + g_company = oc_company; + g_haslayout = *off; + + exec sql + select bin_width_m, bin_height_m, aisle_spacing_m + into :g_binwid, :g_binhgt, :g_aslspc + from perpdemo.warehouse_layout + where company_code = :g_company; + if sqlcode = 0; + g_haslayout = *on; + endif; + + exec sql open whcoordcsr; + if sqlcode < 0; + oc_errmsg = 'whcoord_open: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate; + return *off; + endif; + + return *on; +end-proc; + +// --------------------------------------------------------------------- +dcl-proc whcoord_fetch export; + dcl-pi *n ind; + fc_itemnbr varchar(25); + fc_itemdsc varchar(60); + fc_aisle int(10); + fc_bay int(10); + fc_shelf int(10); + fc_xm packed(9:4); + fc_ym packed(9:4); + fc_zm packed(9:4); + fc_onhand packed(15:4); + fc_avail packed(15:4); + fc_errmsg varchar(80); + end-pi; + + dcl-s aisleCode varchar(10); + dcl-s bayCode varchar(10); + dcl-s shelfCode varchar(10); + + fc_errmsg = ''; + + exec sql + fetch whcoordcsr into :fc_itemnbr, :fc_itemdsc, + :aisleCode, :bayCode, :shelfCode, + :fc_onhand, :fc_avail; + if sqlcode = 100; + return *off; + endif; + if sqlcode < 0; + fc_errmsg = 'whcoord_fetch: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate; + return *off; + endif; + + // Ordinal 1 is the floor -- a code with no digits at all (shouldn't + // happen given the non-blank WHERE filter, but be defensive) still + // places the item at the grid origin rather than off in the + // negative direction. + fc_aisle = %max(1 : ordinalFromCode(aisleCode)); + fc_bay = %max(1 : ordinalFromCode(bayCode)); + fc_shelf = %max(1 : ordinalFromCode(shelfCode)); + + if g_haslayout; + fc_xm = (fc_bay - 1) * g_binwid; + fc_ym = (fc_aisle - 1) * g_aslspc; + fc_zm = (fc_shelf - 1) * g_binhgt; + else; + fc_xm = 0; + fc_ym = 0; + fc_zm = 0; + endif; + + return *on; +end-proc; + +// --------------------------------------------------------------------- +dcl-proc whcoord_close export; + dcl-pi *n ind; + end-pi; + + exec sql close whcoordcsr; + return *on; +end-proc; + +// --------------------------------------------------------------------- +// ordinalFromCode -- module-private. Pulls every digit character out +// of a location code (e.g. 'A1' -> 1, 'B12' -> 12) and returns it as +// an integer. Returns 0 if the code has no digits at all. +dcl-proc ordinalFromCode; + dcl-pi *n int(10); + code varchar(10) const; + end-pi; + + dcl-s i int(10); + dcl-s trimmed varchar(10); + dcl-s digits varchar(10); + dcl-s ch char(1); + + trimmed = %trim(code); + digits = ''; + for i = 1 to %len(trimmed); + ch = %subst(trimmed : i : 1); + if ch >= '0' and ch <= '9'; + digits += ch; + endif; + endfor; + + if digits = ''; + return 0; + endif; + return %int(digits); +end-proc; diff --git a/perp/qrpglesrc/whcoord_pr.rpgle b/perp/qrpglesrc/whcoord_pr.rpgle new file mode 100644 index 00000000..56fe9487 --- /dev/null +++ b/perp/qrpglesrc/whcoord_pr.rpgle @@ -0,0 +1,57 @@ +**free + +// --------------------------------------------------------------------- +// Prototypes: whcoord (warehouse coordinate query service) +// Module: perp +// Purpose: Iterator over located items in a company, with x/y/z +// coordinates derived from warehouse_layout. Data source +// for the (future RDF/EJS) 3D map renderer -- this story +// only delivers the queryable data. +// Epic: PERP-4 (3D Warehouse Map) / PERP-27 +// +// Usage: ok = whcoord_open(company : errmsg); +// dow whcoord_fetch(itemnbr : itemdsc : aisle : bay : shelf +// : xm : ym : zm : onhand : avail : errmsg); +// ... one row ... +// enddo; +// whcoord_close(); +// +// Design note: item.aisle_code/bay_code/shelf_code (PERP-3/PERP-20) are +// free-text VARCHAR(10) location codes, and real seed data mixes a +// letter prefix with the ordinal (e.g. 'A1', 'B2', 'S3' -- confirmed +// against the WIDGET1 seed row). CAST(... AS INTEGER) rejects that +// outright (SQL0420), so whcoord.sqlrpgle's private ordinalFromCode() +// pulls the digit characters out of each code instead of casting the +// whole string. Only items where all three codes are non-blank are +// returned -- unlocated items are simply not on the map yet. +// --------------------------------------------------------------------- + +// whcoord_open -- scope the iterator to one company. Also loads that +// company's warehouse_layout row (if any); if none exists yet, +// whcoord_fetch still enumerates items but returns x/y/z as 0. +// Returns *off on SQL error opening the cursor (errmsg carries detail). +dcl-pr whcoord_open ind; + company char(3) const; + errmsg varchar(80); +end-pr; + +// whcoord_fetch -- advance to the next located item. Returns *off at +// end of data or on error (errmsg carries 'SQLCODE=... SQLSTATE=...' +// in the error case; blank at normal end of data). +dcl-pr whcoord_fetch ind; + itemNumber varchar(25); + itemDescription varchar(60); + aisleOrdinal int(10); + bayOrdinal int(10); + shelfOrdinal int(10); + xMeters packed(9:4); + yMeters packed(9:4); + zMeters packed(9:4); + qtyOnHand packed(15:4); + qtyAvailable packed(15:4); + errmsg varchar(80); +end-pr; + +// whcoord_close -- close the cursor. Always returns *on. +dcl-pr whcoord_close ind; +end-pr; diff --git a/perp/qrpglesrc/whcoordsmk.sqlrpgle b/perp/qrpglesrc/whcoordsmk.sqlrpgle new file mode 100644 index 00000000..4b4f339d --- /dev/null +++ b/perp/qrpglesrc/whcoordsmk.sqlrpgle @@ -0,0 +1,94 @@ +**free + +// --------------------------------------------------------------------- +// Program: whcoordsmk (whcoord smoke test) +// Purpose: One-shot caller that exercises whcoord_open/fetch/close and +// prints each row via SNDPGMMSG so a joblog + interactive +// session confirms the service program is bound correctly. +// Meant to be CALLed once from an interactive session: +// CALL PGM(PERPDEMO/WHCOORDSMK) PARM('ACM') +// Epic: PERP-4 (3D Warehouse Map) / PERP-27 +// --------------------------------------------------------------------- + +ctl-opt dftactgrp(*no) actgrp(*new) bnddir('PERP'); + +/copy whcoord_pr.rpgle + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-pi *n; + p_company char(3); +end-pi; + +dcl-s ok ind; +dcl-s itemnbr varchar(25); +dcl-s itemdsc varchar(60); +dcl-s aisle int(10); +dcl-s bay int(10); +dcl-s shelf int(10); +dcl-s xm packed(9:4); +dcl-s ym packed(9:4); +dcl-s zm packed(9:4); +dcl-s onhand packed(15:4); +dcl-s avail packed(15:4); +dcl-s errmsg varchar(80); +dcl-s numRows int(10); +dcl-s line char(256); +dcl-s msgkey char(4); + +numRows = 0; + +ok = whcoord_open(p_company : errmsg); +if not ok; + callMsg('whcoord_open failed for ' + %trim(p_company) + ': ' + errmsg); +else; + dow whcoord_fetch(itemnbr : itemdsc : aisle : bay : shelf : + xm : ym : zm : onhand : avail : errmsg); + numRows += 1; + line = %trim(itemnbr) + ' (' + %trim(itemdsc) + ') aisle=' + + %char(aisle) + ' bay=' + %char(bay) + ' shelf=' + %char(shelf) + + ' xyz=' + %char(xm) + ',' + %char(ym) + ',' + %char(zm) + + ' onhand=' + %char(onhand) + ' avail=' + %char(avail); + callMsg(line); + enddo; + + if errmsg <> ''; + callMsg('whcoord_fetch error: ' + errmsg); + endif; + + callMsg('whcoord: ' + %char(numRows) + ' row(s) for company ' + + %trim(p_company) + '.'); + + whcoord_close(); +endif; + +*inlr = *on; +return; + +dcl-proc callMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + msgkey : + x'0000000000000000'); +end-proc; diff --git a/perp/qrpglesrc/wlmr.sqlrpgle b/perp/qrpglesrc/wlmr.sqlrpgle new file mode 100644 index 00000000..360afb19 --- /dev/null +++ b/perp/qrpglesrc/wlmr.sqlrpgle @@ -0,0 +1,205 @@ +**free + +// --------------------------------------------------------------------- +// Program: wlmr (Warehouse Layout Maintenance) +// Purpose: Single-record display + edit of warehouse_layout -- one row +// per company, scoped by *LDA company_code (set by PERPSELR). +// Enter=Save (update if the row exists), F6=Add (insert the +// row the first time), F5=Refresh (discard in-progress edits +// and reload from DB), F12=Cancel (same as Refresh), F3=Exit. +// Epic: PERP-4 (3D Warehouse Map) / PERP-26 +// --------------------------------------------------------------------- + +ctl-opt dftactgrp(*no) actgrp(*new); + +dcl-f wlmd workstn sfile(wlmsgsfl:msgrrn); + +// Local Data Area -- perpselr stamps the selected company at pos 1-3. +dcl-ds ldaDS dtaara(*lda) len(1024) qualified; + compcd char(3) pos(1); +end-ds; + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-ds statusDS psds qualified; + programName char(10) pos(334); +end-ds; + +dcl-s compcd char(3); +dcl-s exists ind; +dcl-s msgrrn int(10); + +in ldaDS; +compcd = ldaDS.compcd; + +if compcd = ''; + exsr clearMsgs; + writeMsg('No company selected - run Select Company (PERPSELR) first.'); +endif; + +dow not *in03 and not *in12; + if compcd = ''; + write wlnoco; + write wlfoot; + if msgrrn > 0; + *in40 = *on; + write wlmsgctl; + else; + *in40 = *off; + endif; + exfmt wledit; + leave; + endif; + + exsr clearMsgs; + exsr loadRow; + + write wlfoot; + if msgrrn > 0; + *in40 = *on; + write wlmsgctl; + else; + *in40 = *off; + endif; + exfmt wledit; + + if *in03 or *in12; + leave; + endif; + + if *in05; + iter; // refresh -- discard in-progress edits + endif; + + if *in06; + exsr addRow; + iter; + endif; + + // Enter -- save changes to the existing row. + if exists; + exsr updateRow; + else; + writeMsg('No row yet for company ' + %trim(compcd) + + ' - press F6=Add to create it.'); + endif; +enddo; + +*inlr = *on; +return; + +// --------------------------------------------------------------------- +begsr loadRow; + ecompc = compcd; + exec sql + select warehouse_name, aisle_count, bays_per_aisle, shelves_per_bay, + bin_width_m, bin_depth_m, bin_height_m, aisle_spacing_m, notes + into :ewhsnm, :easlcnt, :ebayspa, :eshlfsb, + :ebinwid, :ebindep, :ebinhgt, :easlspc, :enotes + from perpdemo.warehouse_layout + where company_code = :compcd; + + if sqlcode = 0; + exists = *on; + estat = 'EXISTING'; + else; + exists = *off; + estat = 'NEW'; + ewhsnm = ''; + easlcnt = 1; + ebayspa = 1; + eshlfsb = 1; + ebinwid = 1; + ebindep = 1; + ebinhgt = 1; + easlspc = 2; + enotes = ''; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr addRow; + if exists; + writeMsg('Row already exists for company ' + %trim(compcd) + + ' - press Enter to save changes.'); + return; + endif; + + exec sql + insert into perpdemo.warehouse_layout + (company_code, warehouse_name, aisle_count, bays_per_aisle, + shelves_per_bay, bin_width_m, bin_depth_m, bin_height_m, + aisle_spacing_m, notes) + values (:compcd, :ewhsnm, :easlcnt, :ebayspa, :eshlfsb, + :ebinwid, :ebindep, :ebinhgt, :easlspc, :enotes); + if sqlcode < 0; + writeMsg('Add failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Warehouse layout created for company ' + %trim(compcd) + '.'); + endif; +endsr; + +// --------------------------------------------------------------------- +begsr updateRow; + exec sql + update perpdemo.warehouse_layout + set warehouse_name = :ewhsnm, + aisle_count = :easlcnt, + bays_per_aisle = :ebayspa, + shelves_per_bay = :eshlfsb, + bin_width_m = :ebinwid, + bin_depth_m = :ebindep, + bin_height_m = :ebinhgt, + aisle_spacing_m = :easlspc, + notes = :enotes, + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd; + if sqlcode < 0; + writeMsg('Update failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Warehouse layout updated for company ' + %trim(compcd) + '.'); + endif; +endsr; + +// --------------------------------------------------------------------- +begsr clearMsgs; + msgrrn = 0; + *in41 = *on; + write wlmsgctl; + *in41 = *off; +endsr; + +// --------------------------------------------------------------------- +dcl-proc writeMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + smsgkey : + x'0000000000000000'); + msgrrn += 1; + spgmq = statusDS.programName; + write wlmsgsfl; +end-proc; diff --git a/perp/qsrvsrc/whcoord.bnd b/perp/qsrvsrc/whcoord.bnd new file mode 100644 index 00000000..20517cea --- /dev/null +++ b/perp/qsrvsrc/whcoord.bnd @@ -0,0 +1,5 @@ +strpgmexp pgmlvl(*current) signature('WHCOORD ') + export symbol("WHCOORD_OPEN") + export symbol("WHCOORD_FETCH") + export symbol("WHCOORD_CLOSE") +endpgmexp From dd2ea73aab58a4d6a7cd2a5999eec785cca1c184 Mon Sep 17 00:00:00 2001 From: Gary Jones Date: Wed, 15 Jul 2026 19:35:07 +0000 Subject: [PATCH 05/13] =?UTF-8?q?PERP-5:=20Vendor=20&=20Pricing=20?= =?UTF-8?q?=E2=80=94=20tables,=20maintenance=20programs,=20pricing=20histo?= =?UTF-8?q?ry=20service?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Implements all 5 stories of the Vendor & Pricing epic in ibmi-agentic/perp/: - PERP-28: vendor, item_vendor, item_vendor_price tables + partial unique index enforcing one preferred vendor per item; seeds code_master PAYTERMS. - PERP-29: WRKVNDR/WRKVNDD — vendor master maintenance (filters by active/buyer). - PERP-30: WRKIVNR/WRKIVND — item-vendor profile maintenance, scoped by item or vendor; preferred-vendor conflicts rejected by the DB (SQLCODE -803) with a friendly message. - PERP-31: WRKIVPR/WRKIVPD — effective-dated price entry; adding a price closes the current row and inserts a new one dated today. - PERP-32: item_vendor_price_history view + ITMVPRCQ service program (itmvprcq_history) + IVPRCQSMK smoke tester, for the pricing-over-time graph demo. Extends PERPMNU with options 10-13. Updates DDL_STYLE_GUIDE.md with three new DB2-for-i/RPG gotchas discovered along the way (sequential short-name abbreviation on multi-object name collisions, partial/filtered unique index support, the 10-char RPG object-name cap). Confluence Data Model, Design Decisions, Delivery Plan, PERP Delivery Playbook, and the PERP hub page are updated to match. Co-Authored-By: CoderFlow Learn more: https://coderflow.ai --- cfdemo/Rules.mk | 5 +- cfdemo/menu.msgf | 1 + cfdemo/qddssrc/menu.dspf | 1 + perp/DDL_STYLE_GUIDE.md | 31 ++ perp/Rules.mk | 50 ++- perp/perp.bnddir | 1 + perp/perpmnu.msgf | 4 + perp/qddlsrc/item_vendor.table.sql | 68 ++++ .../item_vendor_preferred_ak.index.sql | 12 + perp/qddlsrc/item_vendor_price.table.sql | 75 ++++ .../item_vendor_price_history.view.sql | 24 ++ perp/qddlsrc/seed/020_payment_terms.sql | 20 + perp/qddlsrc/vendor.table.sql | 92 +++++ perp/qddssrc/perpmnu.dspf | 9 +- perp/qddssrc/wrkivnd.dspf | 98 +++++ perp/qddssrc/wrkivpd.dspf | 79 ++++ perp/qddssrc/wrkvndd.dspf | 119 ++++++ perp/qrpglesrc/itmvprcq.sqlrpgle | 62 +++ perp/qrpglesrc/itmvprcq_pr.rpgle | 37 ++ perp/qrpglesrc/ivprcqsmk.sqlrpgle | 82 ++++ perp/qrpglesrc/wrkivnr.sqlrpgle | 351 +++++++++++++++++ perp/qrpglesrc/wrkivpr.sqlrpgle | 262 +++++++++++++ perp/qrpglesrc/wrkvndr.sqlrpgle | 370 ++++++++++++++++++ perp/qsrvsrc/itmvprcq.bnd | 3 + 24 files changed, 1853 insertions(+), 3 deletions(-) create mode 100644 perp/qddlsrc/item_vendor.table.sql create mode 100644 perp/qddlsrc/item_vendor_preferred_ak.index.sql create mode 100644 perp/qddlsrc/item_vendor_price.table.sql create mode 100644 perp/qddlsrc/item_vendor_price_history.view.sql create mode 100644 perp/qddlsrc/seed/020_payment_terms.sql create mode 100644 perp/qddlsrc/vendor.table.sql create mode 100644 perp/qddssrc/wrkivnd.dspf create mode 100644 perp/qddssrc/wrkivpd.dspf create mode 100644 perp/qddssrc/wrkvndd.dspf create mode 100644 perp/qrpglesrc/itmvprcq.sqlrpgle create mode 100644 perp/qrpglesrc/itmvprcq_pr.rpgle create mode 100644 perp/qrpglesrc/ivprcqsmk.sqlrpgle create mode 100644 perp/qrpglesrc/wrkivnr.sqlrpgle create mode 100644 perp/qrpglesrc/wrkivpr.sqlrpgle create mode 100644 perp/qrpglesrc/wrkvndr.sqlrpgle create mode 100644 perp/qsrvsrc/itmvprcq.bnd diff --git a/cfdemo/Rules.mk b/cfdemo/Rules.mk index 8b9cc8e8..35f7db6b 100644 --- a/cfdemo/Rules.mk +++ b/cfdemo/Rules.mk @@ -25,7 +25,10 @@ products2l.file: qddssrc/products2l.lf | productsp.file # Message file and menu menu.msgf: menu.msgf -menu.menu: menu.msgf | menu.file +# .file MUST be a normal prereq (not order-only) or codermake silently +# drops the CRTMNU recipe -- see perp/DDL_STYLE_GUIDE.md "codermake +# gotchas" for the general rule (discovered there, applies here too). +menu.menu: menu.msgf menu.file # Simple program hellor.pgm: qrpglesrc/hellor.rpgle qddssrc/hellod.dspf | hellod.file diff --git a/cfdemo/menu.msgf b/cfdemo/menu.msgf index 9868ee1f..a588418f 100644 --- a/cfdemo/menu.msgf +++ b/cfdemo/menu.msgf @@ -2,4 +2,5 @@ crtmsgf msgf($LIBRARY/$NAME) addmsgd msgid(usr0001) msgf($LIBRARY/$NAME) msg('call wrkcustr') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0002) msgf($LIBRARY/$NAME) msg('call wrkcustro') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0003) msgf($LIBRARY/$NAME) msg('call wrkcusteo') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0004) msgf($LIBRARY/$NAME) msg('go perpdemo/perpmnu') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0090) msgf($LIBRARY/$NAME) msg('signoff') seclvl(*none) sev(00) fmt(*none) diff --git a/cfdemo/qddssrc/menu.dspf b/cfdemo/qddssrc/menu.dspf index 8041879a..9744425b 100644 --- a/cfdemo/qddssrc/menu.dspf +++ b/cfdemo/qddssrc/menu.dspf @@ -24,6 +24,7 @@ A 5 7'1. Work with Customers' A 6 7'2. Work with Customers (RPGOA)' A 7 7'3. Work with Customers (EJS)' + A 8 7'4. Go to PERP menu (PERPMNU)' A 10 6'90. Sign off' A* CMDPROMPT Do not delete this DDS spec. A 021 2'Selection: - diff --git a/perp/DDL_STYLE_GUIDE.md b/perp/DDL_STYLE_GUIDE.md index 5ba7ce1b..a504ec52 100644 --- a/perp/DDL_STYLE_GUIDE.md +++ b/perp/DDL_STYLE_GUIDE.md @@ -71,6 +71,20 @@ RPG `dcl-f`) against it — don't guess an abbreviation. Related: **`LABEL ON TABLE` text is capped at 50 characters** on DB2 for i; longer text raises `SQL0107`. Column labels have the same cap. +**Auto-derived short names for >10-char SQL names are not a simple +truncation — they can be a sequential counter with no relation to the SQL +name at all.** Learned in PERP-28: `item_vendor` (11 chars) and +`item_vendor_price` (18 chars) both share the `ITEM` prefix with the +already-existing `item`/`item_class`/`item_lot` tables, and DB2 for i's +abbreviation algorithm produced `ITEM_00001` and `ITEM_00003` (not +`ITMVND`/`ITMVPRC` or any other intuitive abbreviation) to avoid a +collision. There is no way to predict this from the SQL name — always +confirm with `DSPOBJD OBJ(PERPDEMO/*ALL) OBJTYPE(*FILE)` right after the +build and use the *real* object name in every downstream reference +(`PERPSJPF` calls, `DSPFD`, RPG `dcl-f`/embedded-SQL is unaffected since it +resolves by SQL name, but any native/CL-level reference needs the real +short name). + **Clause order matters.** On DB2 for i, `FOR COLUMN` goes **between the column name and the data type**, not after the data type. Placing it after `CHAR(...)` / `VARCHAR(...)` triggers the CCSID-modifier grammar (the parser @@ -144,6 +158,14 @@ it — full stop. RPG programs must handle the resulting SQLSTATE cleanly. - Reference tables: `PRIMARY KEY (code_type, code_value)` and similar - Multi-column PKs are the norm — no surrogate `id INT` columns. +**Partial (filtered) unique indexes work as `.index.sql` on DB2 for i.** +Confirmed in PERP-28: `CREATE UNIQUE INDEX ... ON tbl (cols) WHERE +predicate` runs clean through `RUNSQLSTM` and produces a normal `*FILE` LF +object. Use this for "at most one flagged row per group" constraints +(e.g. one preferred vendor per item) instead of application-code +enforcement — DB2 rejects the second `WHERE`-matching row with +`SQL0803`/`SQLSTATE 23505` just like any other unique-index violation. + ## 7. Journaling — day-one requirement Every table in this module is journaled from the moment it is created. @@ -279,6 +301,15 @@ maintenance programs. These apply to every RPG or SQLRPGLE source under and reserve positions in the LDA — every job has an LDA automatically, so no runtime `CRTDTAARA` is needed. PERP session state (currently just the selected company code at positions 1-3) lives in the LDA. +- **Program/module/file object names cap at 10 characters — same as + journal receivers (§7).** Learned again in PERP-32: naming a smoke-test + caller `itmvprcqsmk.sqlrpgle` (11 chars) failed `CRTSQLRPGI` with + `CPD0074: Value 'ITMVPRCQSM' for OBJ exceeds 10 characters` — codermake + does *not* auto-truncate the source basename to fit. Renamed the file + itself to `ivprcqsmk.sqlrpgle` (9 chars). Unlike SQL table/column short + names (§2), there is no separate "system name" escape hatch for RPG + program objects — the source file basename *is* the object name, so it + must fit within 10 chars from the start. ## 14. DSPF conventions diff --git a/perp/Rules.mk b/perp/Rules.mk index c9cd11be..e423969d 100644 --- a/perp/Rules.mk +++ b/perp/Rules.mk @@ -103,6 +103,54 @@ wrklotd.file: qddssrc/wrklotd.dspf wrklotr.pgm: qrpglesrc/wrklotr.sqlrpgle qddssrc/wrklotd.dspf | wrklotd.file item_lot.file +# --- PERP-28: Vendor, Item-Vendor, Pricing tables -------------------------- +# FK order: vendor (company, perp_user, code_master) before item_vendor +# (item, vendor) before item_vendor_price (item_vendor, code_master). +# The partial-unique preferred-vendor index is a separate .index.sql object, +# a normal (not order-only) prereq of item_vendor so it always rebuilds +# alongside the table it indexes. +vendor.file: qddlsrc/vendor.table.sql company.file perp_user.file code_master.file | perpsjpf.pgm +item_vendor.file: qddlsrc/item_vendor.table.sql item.file vendor.file | perpsjpf.pgm +item_vendor_preferred_ak.file: qddlsrc/item_vendor_preferred_ak.index.sql item_vendor.file +item_vendor_price.file: qddlsrc/item_vendor_price.table.sql item_vendor.file code_master.file | perpsjpf.pgm + + +# --- PERP-29: Vendor master maintenance ----------------------------------- +# Scoped by *LDA company (perpselr). Subfile filters by active-only and +# buyer_code. +wrkvndd.file: qddssrc/wrkvndd.dspf +wrkvndr.pgm: qrpglesrc/wrkvndr.sqlrpgle qddssrc/wrkvndd.dspf | wrkvndd.file vendor.file perp_user.file code_master.file + + +# --- PERP-30: Item-vendor profile maintenance ----------------------------- +# Scoped by *LDA company (perpselr) plus an item OR vendor entered on +# screen (item wins if both are entered). +wrkivnd.file: qddssrc/wrkivnd.dspf +wrkivnr.pgm: qrpglesrc/wrkivnr.sqlrpgle qddssrc/wrkivnd.dspf | wrkivnd.file item_vendor.file + + +# --- PERP-31: Item-vendor price maintenance (effective-dated) -------------- +# Scoped by *LDA company (perpselr) plus an item AND vendor entered on +# screen. Read-only history list; F6=Add closes the current row and +# inserts a new one dated today. +wrkivpd.file: qddssrc/wrkivpd.dspf +wrkivpr.pgm: qrpglesrc/wrkivpr.sqlrpgle qddssrc/wrkivpd.dspf | wrkivpd.file item_vendor_price.file + + +# --- PERP-32: Pricing history query service -------------------------------- +# View joins item_vendor_price + vendor; module/srvpgm/bnddir/prototype +# follow the docseq (PERP-19) pattern. Smoke-test caller proves binding. +item_vendor_price_history.file: qddlsrc/item_vendor_price_history.view.sql item_vendor_price.file vendor.file +itmvprcq.module: qrpglesrc/itmvprcq.sqlrpgle qrpglesrc/itmvprcq_pr.rpgle | item_vendor_price_history.file +itmvprcq.srvpgm: itmvprcq.module qsrvsrc/itmvprcq.bnd +# perp.bnddir target already declared above (PERP-19 docseq section); +# adding a new addbnddire entry there for itmvprcq is enough. + +# Smoke-test caller for itmvprcq -- CALL PERPDEMO/IVPRCQSMK PARM('ACM' 'WIDGET1'). +# Named ivprcqsmk, not itmvprcqsmk (11 chars) -- IBM i object names cap at 10. +ivprcqsmk.pgm: qrpglesrc/ivprcqsmk.sqlrpgle qrpglesrc/itmvprcq_pr.rpgle itmvprcq.srvpgm | perp.bnddir item_vendor_price_history.file + + # --- PERP main menu (glue for exploratory verification) ------------------ # Ties the PERP-16/17/18/19/21/22/23/24 programs together into a single # 5250 menu: GO PERPDEMO/PERPMNU @@ -110,7 +158,7 @@ perpmnu.file: qddssrc/perpmnu.dspf perpmnu.msgf: perpmnu.msgf # .file MUST be a normal prereq (not order-only) or codermake silently drops # the CRTMNU recipe. See DDL_STYLE_GUIDE § "codermake menu gotcha". -perpmnu.menu: perpmnu.msgf perpmnu.file | perpselr.pgm wrkcmr.pgm wrkusrr.pgm docseqsmk.pgm wrkuomr.pgm wrkcnvr.pgm wrkiclr.pgm wrkitmr.pgm wrklotr.pgm +perpmnu.menu: perpmnu.msgf perpmnu.file | perpselr.pgm wrkcmr.pgm wrkusrr.pgm docseqsmk.pgm wrkuomr.pgm wrkcnvr.pgm wrkiclr.pgm wrkitmr.pgm wrklotr.pgm wrkvndr.pgm wrkivnr.pgm wrkivpr.pgm ivprcqsmk.pgm # --- CL setup ------------------------------------------------------------- diff --git a/perp/perp.bnddir b/perp/perp.bnddir index 0b2e022c..5d5380cd 100644 --- a/perp/perp.bnddir +++ b/perp/perp.bnddir @@ -1,2 +1,3 @@ crtbnddir bnddir($LIBRARY/$NAME) addbnddire bnddir($LIBRARY/$NAME) obj(($LIBRARY/docseq *srvpgm *immed)) +addbnddire bnddir($LIBRARY/$NAME) obj(($LIBRARY/itmvprcq *srvpgm *immed)) diff --git a/perp/perpmnu.msgf b/perp/perpmnu.msgf index f9c448d0..ce223073 100644 --- a/perp/perpmnu.msgf +++ b/perp/perpmnu.msgf @@ -8,4 +8,8 @@ addmsgd msgid(usr0006) msgf($LIBRARY/$NAME) msg('call wrkcnvr') addmsgd msgid(usr0007) msgf($LIBRARY/$NAME) msg('call wrkiclr') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0008) msgf($LIBRARY/$NAME) msg('call wrkitmr') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0009) msgf($LIBRARY/$NAME) msg('call wrklotr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0010) msgf($LIBRARY/$NAME) msg('call wrkvndr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0011) msgf($LIBRARY/$NAME) msg('call wrkivnr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0012) msgf($LIBRARY/$NAME) msg('call wrkivpr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0013) msgf($LIBRARY/$NAME) msg('call ivprcqsmk parm(''ACM'' ''WIDGET1'')') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0090) msgf($LIBRARY/$NAME) msg('signoff') seclvl(*none) sev(00) fmt(*none) diff --git a/perp/qddlsrc/item_vendor.table.sql b/perp/qddlsrc/item_vendor.table.sql new file mode 100644 index 00000000..3d4cf5ec --- /dev/null +++ b/perp/qddlsrc/item_vendor.table.sql @@ -0,0 +1,68 @@ +-- --------------------------------------------------------------------------- +-- Table: item_vendor (system name ITEM_VENDOR, auto-derived) +-- Module: perp +-- Purpose: Item <-> vendor sourcing profile. vendor_part_number, lead +-- time, MOQ, pack size, and the is_preferred flag that the +-- partial unique index below enforces (one preferred vendor +-- per item). See item_vendor_preferred_ak.index.sql. +-- Epic: PERP-5 (PERP-28) +-- --------------------------------------------------------------------------- + +-- 'item_vendor' (11 chars) exceeds the 10-char system-name cap, so DB2 +-- abbreviates unless we don't ask for a specific value -- omit FOR SYSTEM +-- NAME and confirm the real auto-derived name with DSPOBJD after build +-- (same approach as item_class/item_lot -- see DDL_STYLE_GUIDE.md Sec.2). +CREATE TABLE item_vendor ( + + -- Composite key ----------------------------------------------------------- + company_code FOR COLUMN COMPCD CHAR(3) NOT NULL, + item_number FOR COLUMN ITMNBR VARCHAR(25) NOT NULL, + vendor_code FOR COLUMN VNDCD VARCHAR(10) NOT NULL, + + -- Sourcing profile ---------------------------------------------------------- + vendor_part_number FOR COLUMN VPARTN VARCHAR(25) NOT NULL DEFAULT '', + lead_time_days FOR COLUMN LEADTM INTEGER NOT NULL DEFAULT 0, + moq DECIMAL(15,4) NOT NULL DEFAULT 0, + pack_size FOR COLUMN PACKSZ DECIMAL(15,4) NOT NULL DEFAULT 1, + is_preferred FOR COLUMN ISPREF CHAR(1) NOT NULL DEFAULT 'N', + + -- Standard audit block -------------------------------------------------- + created_at FOR COLUMN CRTAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + created_by FOR COLUMN CRTBY VARCHAR(18) NOT NULL DEFAULT USER, + updated_at FOR COLUMN UPDAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_by FOR COLUMN UPDBY VARCHAR(18) NOT NULL DEFAULT USER, + is_active FOR COLUMN ISACT CHAR(1) NOT NULL DEFAULT 'Y', + + -- Composite primary key --------------------------------------------------- + PRIMARY KEY (company_code, item_number, vendor_code), + + -- Constraints ----------------------------------------------------------- + CONSTRAINT itmvnd_isact_ck CHECK (is_active IN ('Y','N')), + CONSTRAINT itmvnd_ispref_ck CHECK (is_preferred IN ('Y','N')), + CONSTRAINT itmvnd_leadtm_ck CHECK (lead_time_days >= 0), + CONSTRAINT itmvnd_moq_ck CHECK (moq >= 0), + CONSTRAINT itmvnd_packsz_ck CHECK (pack_size > 0), + + -- FKs ----------------------------------------------------------------------- + CONSTRAINT itmvnd_item_fk FOREIGN KEY (company_code, item_number) + REFERENCES item (company_code, item_number) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT itmvnd_vendor_fk FOREIGN KEY (company_code, vendor_code) + REFERENCES vendor (company_code, vendor_code) + ON DELETE RESTRICT ON UPDATE RESTRICT +); + +LABEL ON TABLE item_vendor IS + 'PERP item-vendor sourcing profile'; + +LABEL ON COLUMN item_vendor ( + company_code IS 'Company code (FK to item, vendor)', + item_number IS 'Item number (FK to item)', + vendor_code IS 'Vendor code (FK to vendor)', + vendor_part_number IS 'Vendor''s part number for this item', + lead_time_days IS 'Lead time in days', + moq IS 'Minimum order quantity', + pack_size IS 'Pack size (units per pack)', + is_preferred IS 'Preferred vendor flag (Y/N, one per item)', + is_active IS 'Active flag (Y/N, soft delete)' +); diff --git a/perp/qddlsrc/item_vendor_preferred_ak.index.sql b/perp/qddlsrc/item_vendor_preferred_ak.index.sql new file mode 100644 index 00000000..003cf933 --- /dev/null +++ b/perp/qddlsrc/item_vendor_preferred_ak.index.sql @@ -0,0 +1,12 @@ +-- --------------------------------------------------------------------------- +-- Index: item_vendor_preferred_ak +-- Module: perp +-- Purpose: Partial unique index enforcing at most one preferred vendor +-- (is_preferred = 'Y') per (company_code, item_number). Any +-- number of non-preferred rows are allowed. +-- Epic: PERP-5 (PERP-28) +-- --------------------------------------------------------------------------- + +CREATE UNIQUE INDEX item_vendor_preferred_ak + ON item_vendor (company_code, item_number) + WHERE is_preferred = 'Y'; diff --git a/perp/qddlsrc/item_vendor_price.table.sql b/perp/qddlsrc/item_vendor_price.table.sql new file mode 100644 index 00000000..459bac59 --- /dev/null +++ b/perp/qddlsrc/item_vendor_price.table.sql @@ -0,0 +1,75 @@ +-- --------------------------------------------------------------------------- +-- Table: item_vendor_price (system name abbreviated, >10 chars) +-- Module: perp +-- Purpose: Effective-dated pricing per item_vendor. Current row has +-- effective_to IS NULL. Historical rows are immutable -- a new +-- price closes the current row (sets effective_to) and inserts +-- a new row starting effective_from = today (see PERP-31). +-- Epic: PERP-5 (PERP-28) +-- --------------------------------------------------------------------------- + +-- 'item_vendor_price' (18 chars) exceeds the 10-char system-name cap; omit +-- FOR SYSTEM NAME and confirm the real auto-derived name with DSPOBJD +-- after build, per the SQL7029 guidance in DDL_STYLE_GUIDE.md Sec.2. +CREATE TABLE item_vendor_price ( + + -- Composite key (effective_from is part of the PK) ------------------------ + company_code FOR COLUMN COMPCD CHAR(3) NOT NULL, + item_number FOR COLUMN ITMNBR VARCHAR(25) NOT NULL, + vendor_code FOR COLUMN VNDCD VARCHAR(10) NOT NULL, + effective_from FOR COLUMN EFFFRM DATE NOT NULL DEFAULT CURRENT_DATE, + + -- Price --------------------------------------------------------------------- + effective_to FOR COLUMN EFFTO DATE, + unit_price FOR COLUMN UNTPRC DECIMAL(15,4) NOT NULL, + + -- Currency (constant discriminator + code_master FK) ---------------------- + currency_code FOR COLUMN CURR VARCHAR(20) NOT NULL DEFAULT 'USD', + currency_type FOR COLUMN CURTYP VARCHAR(20) NOT NULL DEFAULT 'CURRENCY', + + -- Where the price came from -------------------------------------------- + price_source FOR COLUMN PRCSRC VARCHAR(20) NOT NULL DEFAULT 'MANUAL', + + -- Standard audit block -------------------------------------------------- + created_at FOR COLUMN CRTAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + created_by FOR COLUMN CRTBY VARCHAR(18) NOT NULL DEFAULT USER, + updated_at FOR COLUMN UPDAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_by FOR COLUMN UPDBY VARCHAR(18) NOT NULL DEFAULT USER, + is_active FOR COLUMN ISACT CHAR(1) NOT NULL DEFAULT 'Y', + + -- Composite primary key --------------------------------------------------- + PRIMARY KEY (company_code, item_number, vendor_code, effective_from), + + -- Constraints ----------------------------------------------------------- + CONSTRAINT itmvprc_isact_ck CHECK (is_active IN ('Y','N')), + CONSTRAINT itmvprc_curtyp_ck CHECK (currency_type = 'CURRENCY'), + CONSTRAINT itmvprc_prcsrc_ck CHECK (price_source IN ('MANUAL','IMPORT')), + CONSTRAINT itmvprc_price_ck CHECK (unit_price >= 0), + CONSTRAINT itmvprc_efftv_ck CHECK (effective_to IS NULL + OR effective_to >= effective_from), + + -- FKs (item + vendor referential integrity comes transitively through + -- item_vendor, which already FKs both) ----------------------------------- + CONSTRAINT itmvprc_itmvnd_fk FOREIGN KEY (company_code, item_number, vendor_code) + REFERENCES item_vendor (company_code, item_number, vendor_code) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT itmvprc_curr_fk FOREIGN KEY (currency_type, currency_code) + REFERENCES code_master (code_type, code_value) + ON DELETE RESTRICT ON UPDATE RESTRICT +); + +LABEL ON TABLE item_vendor_price IS + 'PERP effective-dated item-vendor pricing'; + +LABEL ON COLUMN item_vendor_price ( + company_code IS 'Company code (FK to item_vendor)', + item_number IS 'Item number (FK to item_vendor)', + vendor_code IS 'Vendor code (FK to item_vendor)', + effective_from IS 'Effective from date (PK)', + effective_to IS 'Effective to date (null = current)', + unit_price IS 'Unit price', + currency_code IS 'Currency (FK to code_master)', + currency_type IS 'Currency type discriminator (constant)', + price_source IS 'Price source (MANUAL/IMPORT)', + is_active IS 'Active flag (Y/N, soft delete)' +); diff --git a/perp/qddlsrc/item_vendor_price_history.view.sql b/perp/qddlsrc/item_vendor_price_history.view.sql new file mode 100644 index 00000000..a735decf --- /dev/null +++ b/perp/qddlsrc/item_vendor_price_history.view.sql @@ -0,0 +1,24 @@ +-- --------------------------------------------------------------------------- +-- View: item_vendor_price_history +-- Module: perp +-- Purpose: Effective-dated price history joined to vendor_name, for the +-- pricing-over-time graph demo. Data source for the itmvprcq +-- service program (PERP-32) and for any future UI that queries +-- it directly. Callers order by effective_from themselves -- +-- this view carries no ORDER BY (DB2 for i views don't guarantee +-- storage order without one, and ORDER BY on a view without +-- FETCH FIRST isn't portable). +-- Epic: PERP-5 (PERP-32) +-- --------------------------------------------------------------------------- + +CREATE VIEW item_vendor_price_history + (company_code, item_number, vendor_code, vendor_name, + effective_from, effective_to, unit_price, currency_code) AS + SELECT p.company_code, p.item_number, p.vendor_code, v.vendor_name, + p.effective_from, p.effective_to, p.unit_price, p.currency_code + FROM item_vendor_price p + JOIN vendor v + ON v.company_code = p.company_code AND v.vendor_code = p.vendor_code; + +LABEL ON TABLE item_vendor_price_history IS + 'PERP item-vendor price history (graph source)'; diff --git a/perp/qddlsrc/seed/020_payment_terms.sql b/perp/qddlsrc/seed/020_payment_terms.sql new file mode 100644 index 00000000..1b75d81b --- /dev/null +++ b/perp/qddlsrc/seed/020_payment_terms.sql @@ -0,0 +1,20 @@ +-- --------------------------------------------------------------------------- +-- Seed: 020_payment_terms +-- Module: perp +-- Purpose: Populate code_master with the PAYTERMS code_type that +-- vendor.payment_terms_code FKs to. Idempotent -- DELETE by +-- code_type first, then INSERT. Safe to re-run. +-- Epic: PERP-5 (PERP-28) +-- --------------------------------------------------------------------------- + +DELETE FROM code_master + WHERE code_type = 'PAYTERMS'; + +-- PAYTERMS — vendor payment terms ----------------------------------------- +INSERT INTO code_master + (code_type, code_value, description, short_desc, sort_order) VALUES + ('PAYTERMS','COD', 'Cash on delivery', 'COD', 10), + ('PAYTERMS','NET15', 'Net 15 days', 'Net 15', 20), + ('PAYTERMS','NET30', 'Net 30 days', 'Net 30', 30), + ('PAYTERMS','NET60', 'Net 60 days', 'Net 60', 40), + ('PAYTERMS','PREPAID','Prepaid', 'Prepaid',50); diff --git a/perp/qddlsrc/vendor.table.sql b/perp/qddlsrc/vendor.table.sql new file mode 100644 index 00000000..02459304 --- /dev/null +++ b/perp/qddlsrc/vendor.table.sql @@ -0,0 +1,92 @@ +-- --------------------------------------------------------------------------- +-- Table: vendor (system name VENDOR) +-- Module: perp +-- Purpose: Vendor master. Buyer assignment (FK to perp_user) is later +-- snapshotted onto po_header at PO creation time -- see the +-- "buyer snapshot pattern" on the Design Decisions & Conventions +-- page. Payment terms is a code_master (PAYTERMS) lookup. +-- Epic: PERP-5 (PERP-28) +-- --------------------------------------------------------------------------- + +-- 'vendor' auto-derives to system name VENDOR; specifying FOR SYSTEM NAME +-- with the same value raises SQL7029 (same rule as company/item), so it's +-- omitted here. +CREATE TABLE vendor ( + + -- Composite key (per-company) --------------------------------------------- + company_code FOR COLUMN COMPCD CHAR(3) NOT NULL, + vendor_code FOR COLUMN VNDCD VARCHAR(10) NOT NULL, + + -- Descriptive columns ----------------------------------------------------- + vendor_name FOR COLUMN VNDNM VARCHAR(60) NOT NULL, + + -- Address block (same shape as company.table.sql) -------------------------- + address_line1 FOR COLUMN ADDR1 VARCHAR(60) NOT NULL DEFAULT '', + address_line2 FOR COLUMN ADDR2 VARCHAR(60) NOT NULL DEFAULT '', + city_name FOR COLUMN CITY VARCHAR(40) NOT NULL DEFAULT '', + state_code FOR COLUMN STATE VARCHAR(3) NOT NULL DEFAULT '', + postal_code FOR COLUMN POSTCD VARCHAR(12) NOT NULL DEFAULT '', + country_code FOR COLUMN CNTRY VARCHAR(3) NOT NULL DEFAULT 'US', + + -- Contact info -------------------------------------------------------------- + phone_number FOR COLUMN PHONE VARCHAR(20) NOT NULL DEFAULT '', + email_address FOR COLUMN EMAIL VARCHAR(120) NOT NULL DEFAULT '', + contact_name FOR COLUMN CNTCNM VARCHAR(60) NOT NULL DEFAULT '', + + -- Buyer assignment (FK to perp_user) --------------------------------------- + buyer_code FOR COLUMN BUYCD CHAR(10) NOT NULL, + + -- Payment terms (constant discriminator + code_master FK) ----------------- + payment_terms_code FOR COLUMN PTCODE VARCHAR(20) NOT NULL DEFAULT 'NET30', + payment_terms_type FOR COLUMN PTTYPE VARCHAR(20) NOT NULL DEFAULT 'PAYTERMS', + + tax_id FOR COLUMN TAXID VARCHAR(20) NOT NULL DEFAULT '', + + -- Standard audit block -------------------------------------------------- + created_at FOR COLUMN CRTAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + created_by FOR COLUMN CRTBY VARCHAR(18) NOT NULL DEFAULT USER, + updated_at FOR COLUMN UPDAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_by FOR COLUMN UPDBY VARCHAR(18) NOT NULL DEFAULT USER, + is_active FOR COLUMN ISACT CHAR(1) NOT NULL DEFAULT 'Y', + + -- Composite primary key --------------------------------------------------- + PRIMARY KEY (company_code, vendor_code), + + -- Constraints ----------------------------------------------------------- + CONSTRAINT vendor_isact_ck CHECK (is_active IN ('Y','N')), + CONSTRAINT vendor_pttyp_ck CHECK (payment_terms_type = 'PAYTERMS'), + + -- FKs ----------------------------------------------------------------------- + CONSTRAINT vendor_company_fk FOREIGN KEY (company_code) + REFERENCES company (company_code) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT vendor_buyer_fk FOREIGN KEY (buyer_code) + REFERENCES perp_user (user_code) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT vendor_ptcode_fk FOREIGN KEY (payment_terms_type, payment_terms_code) + REFERENCES code_master (code_type, code_value) + ON DELETE RESTRICT ON UPDATE RESTRICT +); + +LABEL ON TABLE vendor IS + 'PERP vendor master'; + +LABEL ON COLUMN vendor ( + company_code IS 'Company code (FK to company)', + vendor_code IS 'Vendor code (natural key within company)', + vendor_name IS 'Vendor name', + address_line1 IS 'Address line 1', + address_line2 IS 'Address line 2', + city_name IS 'City', + state_code IS 'State / province code', + postal_code IS 'Postal / ZIP code', + country_code IS 'ISO country code', + phone_number IS 'Phone number', + email_address IS 'Email address', + contact_name IS 'Contact person name', + buyer_code IS 'Buyer (FK to perp_user)', + payment_terms_code IS 'Payment terms (FK to code_master)', + payment_terms_type IS 'Payment terms type discriminator (constant)', + tax_id IS 'Tax ID', + is_active IS 'Active flag (Y/N, soft delete)' +); diff --git a/perp/qddssrc/perpmnu.dspf b/perp/qddssrc/perpmnu.dspf index 055e84c7..8de94c19 100644 --- a/perp/qddssrc/perpmnu.dspf +++ b/perp/qddssrc/perpmnu.dspf @@ -36,7 +36,14 @@ A 11 7'7. Work with item classes' A 12 7'8. Work with items' A 13 7'9. Work with item lots' - A 15 6'90. Sign off' + A 14 6'10. Work with vendors' + A 15 6'11. Work with item-vendor prof- + A iles' + A 16 6'12. Work with item-vendor pric- + A es' + A 17 6'13. Smoke test price-history - + A service' + A 19 6'90. Sign off' A* CMDPROMPT Do not delete this DDS spec. A 021 2'Selection: - A ' diff --git a/perp/qddssrc/wrkivnd.dspf b/perp/qddssrc/wrkivnd.dspf new file mode 100644 index 00000000..39c7c3cf --- /dev/null +++ b/perp/qddssrc/wrkivnd.dspf @@ -0,0 +1,98 @@ + A DSPSIZ(24 80 *DS3) + A PRINT + A CA03(03 'Exit') + A CA05(05 'Refresh') + A CA06(06 'Add') + A CA12(12 'Cancel') + A R IVSFL SFL + A 51 SFLNXTCHG + A SOPT 1A B 8 2 + A 50 DSPATR(RI) + A 50 DSPATR(PC) + A SIITEM 12A O 8 5 + A SIVENDOR 10A O 8 18 + A SIPARTN 12A O 8 29 + A SILEAD 5Y 0O 8 42EDTCDE(3) + A SIMOQ 9Y 4O 8 48EDTCDE(3) + A SIPACK 9Y 4O 8 59EDTCDE(3) + A SIPREF 1A O 8 70 + A R IVCTL SFLCTL(IVSFL) + A SFLSIZ(0099) + A SFLPAG(0007) + A OVERLAY + A SFLDSPCTL + A N31 30 SFLDSP + A 31 SFLCLR + A N31 30 SFLEND(*MORE) + A 1 22'Work with Item-Vendor Profiles' + A DSPATR(HI) + A 2 2'Company:' + A SCOMPDSP 3A O 2 11 + A 2 16'Item:' + A SFITEM 15A B 2 22 + A 2 39'Vendor:' + A SFVENDOR 10A B 2 47 + A 4 2'Type option, press Enter.' + A 5 4'2=Change 4=Delete' + A 7 2'Opt' + A DSPATR(UL) + A 7 5'Item' + A DSPATR(UL) + A 7 18'Vendor' + A DSPATR(UL) + A 7 29'Part #' + A DSPATR(UL) + A 7 42'Lead' + A DSPATR(UL) + A 7 48'MOQ' + A DSPATR(UL) + A 7 59'Pack' + A DSPATR(UL) + A 7 70'Pref' + A DSPATR(UL) + A R IVFOOT + A 23 2'F3=Exit F5=Refresh F6=Add - + A F12=Cancel' + A COLOR(BLU) + A R IVNONE + A OVERLAY + A 10 20'** No item-vendor rows for this - + A filter **' + A R IVNOSCP + A OVERLAY + A 10 20'** Enter an item or vendor to be- + A gin **' + A R IVEDIT + A OVERLAY + A 1 25'Edit Item-Vendor Profile' + A DSPATR(HI) + A EMODE 1A O 2 2 + A 3 2'Item:' + A EITEM 25A B 3 15 + A 4 2'Vendor:' + A EVENDOR 10A B 4 15 + A 5 2'Vendor Part #:' + A EPARTN 25A B 5 17 + A 6 2'Lead Time (days):' + A ELEADTM 5Y 0B 6 20EDTCDE(3) + A 7 2'MOQ:' + A EMOQ 9Y 4B 7 15EDTCDE(3) + A 8 2'Pack Size:' + A EPACKSZ 9Y 4B 8 15EDTCDE(3) + A 9 2'Preferred (Y/N):' + A EPREF 1A B 9 19 + A 10 2'Active (Y/N):' + A EACTIVE 1A B 10 19 + A 23 2'Enter=Save F12=Cancel' + A COLOR(BLU) + A R IVMSGSFL SFL + A SFLMSGRCD(24) + A SMSGKEY SFLMSGKEY + A SPGMQ SFLPGMQ(10) + A R IVMSGCTL SFLCTL(IVMSGSFL) + A OVERLAY + A N41 40 SFLDSP + A 41 SFLCLR + A N41 40 SFLEND + A SFLSIZ(0002) + A SFLPAG(0001) diff --git a/perp/qddssrc/wrkivpd.dspf b/perp/qddssrc/wrkivpd.dspf new file mode 100644 index 00000000..6bb7ad7f --- /dev/null +++ b/perp/qddssrc/wrkivpd.dspf @@ -0,0 +1,79 @@ + A DSPSIZ(24 80 *DS3) + A PRINT + A CA03(03 'Exit') + A CA05(05 'Refresh') + A CA06(06 'Add New Price') + A CA12(12 'Cancel') + A R IPSFL SFL + A SEFFFRM 10A O 8 2 + A SEFFTO 10A O 8 14 + A SPRICE 11Y 4O 8 26EDTCDE(3) + A SCURR 5A O 8 40 + A SSRC 10A O 8 47 + A R IPCTL SFLCTL(IPSFL) + A SFLSIZ(0099) + A SFLPAG(0007) + A OVERLAY + A SFLDSPCTL + A N31 30 SFLDSP + A 31 SFLCLR + A N31 30 SFLEND(*MORE) + A 1 15'Item-Vendor Price History' + A DSPATR(HI) + A 2 2'Company:' + A SCOMPDSP 3A O 2 11 + A 2 16'Item:' + A SFITEM 15A B 2 22 + A 2 39'Vendor:' + A SFVENDOR 10A B 2 47 + A 4 2'Historical rows are read-only. F- + A 6=Add a new current price.' + A 7 2'From' + A DSPATR(UL) + A 7 14'To' + A DSPATR(UL) + A 7 26'Price' + A DSPATR(UL) + A 7 40'Curr' + A DSPATR(UL) + A 7 47'Source' + A DSPATR(UL) + A R IPFOOT + A 23 2'F3=Exit F5=Refresh F6=Add Ne- + A w Price F12=Cancel' + A COLOR(BLU) + A R IPNONE + A OVERLAY + A 10 20'** No price history for this ite- + A m-vendor **' + A R IPNOSCP + A OVERLAY + A 10 20'** Enter an item and vendor to b- + A egin **' + A R IPADD + A OVERLAY + A 1 28'Enter New Price' + A DSPATR(HI) + A 3 2'Item:' + A EITEM 25A O 3 15 + A 4 2'Vendor:' + A EVENDOR 10A O 4 15 + A 5 2'New Unit Price:' + A ENEWPRC 11Y 4B 5 19EDTCDE(3) + A 6 2'Currency:' + A ECURR 20A B 6 19 + A 7 2'Price Source:' + A EPRCSRC 20A B 7 19 + A 23 2'Enter=Save F12=Cancel' + A COLOR(BLU) + A R IPMSGSFL SFL + A SFLMSGRCD(24) + A SMSGKEY SFLMSGKEY + A SPGMQ SFLPGMQ(10) + A R IPMSGCTL SFLCTL(IPMSGSFL) + A OVERLAY + A N41 40 SFLDSP + A 41 SFLCLR + A N41 40 SFLEND + A SFLSIZ(0002) + A SFLPAG(0001) diff --git a/perp/qddssrc/wrkvndd.dspf b/perp/qddssrc/wrkvndd.dspf new file mode 100644 index 00000000..9b594090 --- /dev/null +++ b/perp/qddssrc/wrkvndd.dspf @@ -0,0 +1,119 @@ + A DSPSIZ(24 80 *DS3) + A PRINT + A CA03(03 'Exit') + A CA05(05 'Refresh') + A CA06(06 'Add') + A CA12(12 'Cancel') + A R VSFL SFL + A 51 SFLNXTCHG + A SOPT 1A B 8 2 + A 50 DSPATR(RI) + A 50 DSPATR(PC) + A SVCODE 10A O 8 5 + A SVNAME 30A O 8 16 + A SVBUYER 10A O 8 47 + A SVACT 1A O 8 59 + A R VCTL SFLCTL(VSFL) + A SFLSIZ(0099) + A SFLPAG(0007) + A OVERLAY + A SFLDSPCTL + A N31 30 SFLDSP + A 31 SFLCLR + A N31 30 SFLEND(*MORE) + A 1 30'Work with Vendors' + A DSPATR(HI) + A 2 2'Company:' + A SCOMPDSP 3A O 2 11 + A 2 16'Active only (Y/N):' + A SFACT 1A B 2 36 + A 3 2'Buyer (blank=all):' + A SFBUYER 10A B 3 21 + A 5 2'Type option, press Enter.' + A 6 4'2=Change 4=Delete 5=Display' + A 7 2'Opt' + A DSPATR(UL) + A 7 5'Vendor' + A DSPATR(UL) + A 7 16'Name' + A DSPATR(UL) + A 7 47'Buyer' + A DSPATR(UL) + A 7 59'Act' + A DSPATR(UL) + A R VFOOT + A 23 2'F3=Exit F5=Refresh F6=Add - + A F12=Cancel' + A COLOR(BLU) + A R VNONE + A OVERLAY + A 10 20'** No vendors match this filter - + A **' + A R VNOCO + A OVERLAY + A 10 20'** No company selected - run Sel- + A ect Company first **' + A R VEDIT + A OVERLAY + A 1 30'Edit Vendor' + A DSPATR(HI) + A EMODE 1A O 2 2 + A 3 2'Vendor code:' + A EVCODE 10A B 3 15 + A 60 DSPATR(PR) + A 4 2'Name:' + A EVNAME 60A B 4 15 + A 60 DSPATR(PR) + A 5 2'Address 1:' + A EADDR1 60A B 5 15 + A 60 DSPATR(PR) + A 6 2'Address 2:' + A EADDR2 60A B 6 15 + A 60 DSPATR(PR) + A 7 2'City:' + A ECITY 30A B 7 15 + A 60 DSPATR(PR) + A 8 2'State:' + A ESTATE 3A B 8 15 + A 60 DSPATR(PR) + A 9 2'Postal Code:' + A EPOSTCD 12A B 9 15 + A 60 DSPATR(PR) + A 10 2'Country:' + A ECNTRY 3A B 10 15 + A 60 DSPATR(PR) + A 11 2'Phone:' + A EPHONE 20A B 11 15 + A 60 DSPATR(PR) + A 12 2'Email:' + A EEMAIL 60A B 12 15 + A 60 DSPATR(PR) + A 13 2'Contact Name:' + A ECNTCT 30A B 13 16 + A 60 DSPATR(PR) + A 14 2'Buyer Code:' + A EBUYER 10A B 14 15 + A 60 DSPATR(PR) + A 15 2'Payment Terms:' + A EPTERMS 20A B 15 17 + A 60 DSPATR(PR) + A 16 2'Tax ID:' + A ETAXID 20A B 16 15 + A 60 DSPATR(PR) + A 17 2'Active (Y/N):' + A EACTIVE 1A B 17 16 + A 60 DSPATR(PR) + A N60 23 2'Enter=Save F12=Cancel' + A 60 23 2'F12=Return to list' + A COLOR(BLU) + A R VMSGSFL SFL + A SFLMSGRCD(24) + A SMSGKEY SFLMSGKEY + A SPGMQ SFLPGMQ(10) + A R VMSGCTL SFLCTL(VMSGSFL) + A OVERLAY + A N41 40 SFLDSP + A 41 SFLCLR + A N41 40 SFLEND + A SFLSIZ(0002) + A SFLPAG(0001) diff --git a/perp/qrpglesrc/itmvprcq.sqlrpgle b/perp/qrpglesrc/itmvprcq.sqlrpgle new file mode 100644 index 00000000..56c40402 --- /dev/null +++ b/perp/qrpglesrc/itmvprcq.sqlrpgle @@ -0,0 +1,62 @@ +**free + +// --------------------------------------------------------------------- +// Module: itmvprcq (item-vendor price history query service) +// Purpose: Implements itmvprcq_history -- see itmvprcq_pr.rpgle for the +// prototype and its docstring. +// Epic: PERP-5 (PERP-32) +// --------------------------------------------------------------------- + +ctl-opt nomain; + +// Real commitment control against PERPJRN -- per DDL_STYLE_GUIDE Sec.7. +exec sql set option closqlcsr = *endmod; + +/copy itmvprcq_pr.rpgle + +// Host-variable names prefixed hc_ -- the SQLRPGLE precompiler collects +// host variables at module scope, not subprocedure scope, so an +// unprefixed name here could collide with a future second exported +// procedure in this module (SQL0314). +dcl-proc itmvprcq_history export; + dcl-pi *n int(10); + hc_company char(3) const; + hc_item varchar(25) const; + hc_rows likeds(itmvprcq_row) dim(200); + hc_errmsg varchar(80); + end-pi; + + dcl-s hc_count int(10) inz(0); + dcl-ds hc_row likeds(itmvprcq_row); + + hc_errmsg = ''; + + exec sql declare hc1 cursor for + select vendor_code, vendor_name, + char(effective_from, iso), + case when effective_to is null then '' + else char(effective_to, iso) end, + unit_price, currency_code + from perpdemo.item_vendor_price_history + where company_code = :hc_company and item_number = :hc_item + order by effective_from; + exec sql open hc1; + if sqlcode < 0; + hc_errmsg = 'itmvprcq_history open: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate; + return 0; + endif; + + dow hc_count < %elem(hc_rows); + exec sql fetch hc1 into :hc_row; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + hc_count += 1; + hc_rows(hc_count) = hc_row; + enddo; + exec sql close hc1; + + return hc_count; + +end-proc; diff --git a/perp/qrpglesrc/itmvprcq_pr.rpgle b/perp/qrpglesrc/itmvprcq_pr.rpgle new file mode 100644 index 00000000..0625cf7f --- /dev/null +++ b/perp/qrpglesrc/itmvprcq_pr.rpgle @@ -0,0 +1,37 @@ +**free + +// --------------------------------------------------------------------- +// Prototypes: itmvprcq (item-vendor price history query service) +// Module: perp +// Purpose: Effective-dated price history for one item across all of +// its vendors -- the pricing-over-time comparative graph +// demo. Callers: future graphing UI, smoke-test caller +// itmvprcqsmk. +// Epic: PERP-5 (PERP-32) +// --------------------------------------------------------------------- + +// One price-history row. ISO date strings (not native RPG date fields) +// per the PERP-3 finding: nullable DATE columns are simpler handled as +// CHAR(10) ISO strings across the embedded-SQL boundary. +dcl-ds itmvprcq_row qualified template; + vendor varchar(10); + vendorNm varchar(60); + efffrm varchar(10); + effto varchar(10); + price packed(15:4); + currency varchar(20); +end-ds; + +// itmvprcq_history -- fetch up to %elem(histRows) price-history rows for +// (company, item) across all vendors, ordered by effective_from ascending +// (oldest first, matching a left-to-right time-series graph). Returns the +// number of rows fetched (0 on error or no history; check errmsg to tell +// the two apart -- errmsg is blank when 0 legitimately means "no history +// yet"). Raises no messages itself; SQL diagnostics are returned in +// errmsg as 'SQLCODE=... SQLSTATE=...' for the caller to log/display. +dcl-pr itmvprcq_history int(10); + company char(3) const; + item varchar(25) const; + histRows likeds(itmvprcq_row) dim(200); + errmsg varchar(80); +end-pr; diff --git a/perp/qrpglesrc/ivprcqsmk.sqlrpgle b/perp/qrpglesrc/ivprcqsmk.sqlrpgle new file mode 100644 index 00000000..3970aad2 --- /dev/null +++ b/perp/qrpglesrc/ivprcqsmk.sqlrpgle @@ -0,0 +1,82 @@ +**free + +// --------------------------------------------------------------------- +// Program: ivprcqsmk (itmvprcq smoke test) +// Purpose: One-shot caller that exercises itmvprcq_history and prints +// the results via SNDPGMMSG so a joblog + interactive session +// confirms the service program is bound correctly. +// Meant to be CALLed once from an interactive session: +// CALL PGM(PERPDEMO/IVPRCQSMK) PARM('ACM' 'WIDGET1') +// Program object name is itself only 9 chars ('itmvprcqsmk' +// would be 11 -- CPD0074, IBM i object names cap at 10). +// Epic: PERP-5 (PERP-32) +// --------------------------------------------------------------------- + +ctl-opt dftactgrp(*no) actgrp(*new) bnddir('PERP'); + +/copy itmvprcq_pr.rpgle + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-pi *n; + p_company char(3); + p_item char(25); +end-pi; + +dcl-ds rows likeds(itmvprcq_row) dim(200); +dcl-s item varchar(25); +dcl-s errmsg varchar(80); +dcl-s cnt int(10); +dcl-s i int(10); +dcl-s line char(256); +dcl-s msgkey char(4); +dcl-s efftoTxt varchar(10); + +item = %trim(p_item); + +cnt = itmvprcq_history(p_company : item : rows : errmsg); +line = 'itmvprcq_history rows=' + %char(cnt) + ' err=' + errmsg; +callMsg(line); + +for i = 1 to cnt; + if %trim(rows(i).effto) = ''; + efftoTxt = 'current'; + else; + efftoTxt = %trim(rows(i).effto); + endif; + line = %trim(rows(i).vendor) + ' (' + %trim(rows(i).vendorNm) + ') ' + + %trim(rows(i).efffrm) + ' to ' + efftoTxt + + ' : ' + %char(rows(i).price) + ' ' + %trim(rows(i).currency); + callMsg(line); +endfor; + +*inlr = *on; +return; + +dcl-proc callMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + msgkey : + x'0000000000000000'); +end-proc; diff --git a/perp/qrpglesrc/wrkivnr.sqlrpgle b/perp/qrpglesrc/wrkivnr.sqlrpgle new file mode 100644 index 00000000..55fbc120 --- /dev/null +++ b/perp/qrpglesrc/wrkivnr.sqlrpgle @@ -0,0 +1,351 @@ +**free + +// --------------------------------------------------------------------- +// Program: wrkivnr (Work with Item-Vendor Profiles) +// Purpose: DSPF-based CRUD for item_vendor, scoped by the company +// selected via perpselr (*LDA positions 1-3) plus EITHER an +// item number OR a vendor code entered on screen (item wins +// if both are entered). Setting is_preferred = 'Y' lets DB2 +// reject the change via the item_vendor_preferred_ak partial +// unique index (SQLSTATE 23505) rather than pre-clearing the +// previous preferred row -- per the epic's "or lets DB reject +// the change with a clear error" option. +// Epic: PERP-5 (PERP-30) +// --------------------------------------------------------------------- + +ctl-opt dftactgrp(*no) actgrp(*new); + +dcl-f wrkivnd workstn sfile(ivsfl:rrn) sfile(ivmsgsfl:msgrrn); + +dcl-ds ldaDS dtaara(*lda) len(1024) qualified; + compcd char(3) pos(1); +end-ds; + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-ds statusDS psds qualified; + programName char(10) pos(334); +end-ds; + +dcl-ds ivRow qualified; + iitem varchar(25); + ivendor varchar(10); + ipartn varchar(25); + ilead int(10); + imoq packed(15:4); + ipack packed(15:4); + ipref char(1); +end-ds; + +dcl-ds rows likeds(ivRow) dim(500); +dcl-s numRows int(10); +dcl-s i int(10); +dcl-s rrn int(10); +dcl-s msgrrn int(10); +dcl-s msgkey char(4); +dcl-s selRrn int(10); +dcl-s selOpt char(1); +dcl-s compcd char(3); +dcl-s fItem varchar(25); +dcl-s fVendor varchar(10); + +in ldaDS; +compcd = ldaDS.compcd; +scompdsp = compcd; +fItem = ''; +fVendor = ''; +sfitem = ''; +sfvendor = ''; + +if compcd = ''; + exsr clearMsgs; + writeMsg('No company selected - run Select Company (PERPSELR) first.'); +endif; + +dow not *in03 and not *in12; + if compcd = ''; + *in30 = *off; + write ivnoscp; + write ivfoot; + if msgrrn > 0; + *in40 = *on; + write ivmsgctl; + else; + *in40 = *off; + endif; + exfmt ivctl; + leave; + endif; + + exsr clearMsgs; + + if fItem = '' and fVendor = ''; + *in30 = *off; + numRows = 0; + write ivnoscp; + else; + exsr loadRows; + if numRows = 0; + *in30 = *off; + write ivnone; + else; + exsr fillSubfile; + *in30 = *on; + endif; + endif; + + write ivfoot; + if msgrrn > 0; + *in40 = *on; + write ivmsgctl; + else; + *in40 = *off; + endif; + exfmt ivctl; + + if *in03 or *in12; + leave; + endif; + + if *in05; + fItem = sfitem; + fVendor = sfvendor; + iter; + endif; + + if *in06; + exsr addRow; + iter; + endif; + + // Refresh scope from screen entry + if sfitem <> fItem or sfvendor <> fVendor; + fItem = sfitem; + fVendor = sfvendor; + iter; + endif; + + // Process subfile options. Guard on numRows: READC against a subfile + // that was never written to this cycle (0 rows loaded) raises a + // "Session or device error" (CPF5006-class) runtime error instead of + // just returning *EOF. + if numRows > 0; + selRrn = 0; + selOpt = ' '; + readc ivsfl; + dow not %eof(wrkivnd); + if sopt <> ''; + selRrn = rrn; + selOpt = sopt; + exsr handleOpt; + selRrn = 0; + endif; + readc ivsfl; + enddo; + endif; + +enddo; + +*inlr = *on; +return; + +// --------------------------------------------------------------------- +begsr loadRows; + numRows = 0; + exec sql declare iv1 cursor for + select item_number, vendor_code, vendor_part_number, lead_time_days, + moq, pack_size, is_preferred + from perpdemo.item_vendor + where company_code = :compcd + and (:fItem = '' or item_number = :fItem) + and (:fVendor = '' or vendor_code = :fVendor) + order by item_number, vendor_code; + exec sql open iv1; + if sqlcode < 0; + writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); + return; + endif; + + dow numRows < %elem(rows); + exec sql fetch iv1 into :ivRow; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + numRows += 1; + rows(numRows) = ivRow; + enddo; + exec sql close iv1; +endsr; + +// --------------------------------------------------------------------- +begsr fillSubfile; + rrn = 0; + *in31 = *on; + write ivctl; + *in31 = *off; + for i = 1 to numRows; + *in50 = *off; + *in51 = *off; + sopt = ''; + siitem = rows(i).iitem; + sivendor = rows(i).ivendor; + sipartn = rows(i).ipartn; + silead = rows(i).ilead; + simoq = rows(i).imoq; + sipack = rows(i).ipack; + sipref = rows(i).ipref; + rrn += 1; + write ivsfl; + endfor; +endsr; + +// --------------------------------------------------------------------- +begsr handleOpt; + chain selRrn ivsfl; + if %found(wrkivnd); + select; + when selOpt = '2'; + exsr changeRow; + when selOpt = '4'; + exsr deleteRow; + other; + writeMsg('Option ' + selOpt + ' not valid.'); + endsl; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr addRow; + if fItem = '' and fVendor = ''; + writeMsg('Enter an item or vendor before adding a profile.'); + return; + endif; + emode = 'A'; + eitem = fItem; + evendor = fVendor; + epartn = ''; + eleadtm = 0; + emoq = 0; + epacksz = 1; + epref = 'N'; + eactive = 'Y'; + exsr editLoop; + if not *in12 and eitem <> '' and evendor <> ''; + exec sql + insert into perpdemo.item_vendor + (company_code, item_number, vendor_code, vendor_part_number, + lead_time_days, moq, pack_size, is_preferred, is_active) + values (:compcd, :eitem, :evendor, :epartn, + :eleadtm, :emoq, :epacksz, :epref, :eactive); + if sqlcode = -803; + writeMsg('Add failed: another vendor is already preferred for' + + ' this item - clear it first.'); + elseif sqlcode < 0; + writeMsg('Add failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Added ' + %trim(eitem) + '/' + %trim(evendor) + '.'); + endif; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr changeRow; + emode = 'C'; + eitem = siitem; + evendor = sivendor; + exec sql + select vendor_part_number, lead_time_days, moq, pack_size, + is_preferred, is_active + into :epartn, :eleadtm, :emoq, :epacksz, + :epref, :eactive + from perpdemo.item_vendor + where company_code = :compcd and item_number = :eitem + and vendor_code = :evendor; + if sqlcode <> 0; + writeMsg('Row disappeared before change.'); + return; + endif; + exsr editLoop; + if not *in12; + exec sql + update perpdemo.item_vendor + set vendor_part_number = :epartn, + lead_time_days = :eleadtm, + moq = :emoq, + pack_size = :epacksz, + is_preferred = :epref, + is_active = :eactive, + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd and item_number = :eitem + and vendor_code = :evendor; + if sqlcode = -803; + writeMsg('Change failed: another vendor is already preferred for' + + ' this item - clear it first.'); + elseif sqlcode < 0; + writeMsg('Change failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Updated ' + %trim(eitem) + '/' + %trim(evendor) + '.'); + endif; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr deleteRow; + exec sql + delete from perpdemo.item_vendor + where company_code = :compcd and item_number = :siitem + and vendor_code = :sivendor; + if sqlcode < 0; + writeMsg('Delete failed (in use?): SQLSTATE=' + sqlstate); + else; + writeMsg('Deleted ' + %trim(siitem) + '/' + %trim(sivendor) + '.'); + endif; +endsr; + +// --------------------------------------------------------------------- +begsr editLoop; + exfmt ivedit; +endsr; + +// --------------------------------------------------------------------- +begsr clearMsgs; + msgrrn = 0; + *in41 = *on; + write ivmsgctl; + *in41 = *off; +endsr; + +// --------------------------------------------------------------------- +dcl-proc writeMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + smsgkey : + x'0000000000000000'); + msgrrn += 1; + spgmq = statusDS.programName; + write ivmsgsfl; +end-proc; diff --git a/perp/qrpglesrc/wrkivpr.sqlrpgle b/perp/qrpglesrc/wrkivpr.sqlrpgle new file mode 100644 index 00000000..2ae4f937 --- /dev/null +++ b/perp/qrpglesrc/wrkivpr.sqlrpgle @@ -0,0 +1,262 @@ +**free + +// --------------------------------------------------------------------- +// Program: wrkivpr (Item-Vendor Price History / Add New Price) +// Purpose: Read-only history list for item_vendor_price scoped by an +// item + vendor entered on screen, plus F6=Add to enter a new +// current price. On add: the current row (effective_to IS +// NULL) is closed (effective_to = CURRENT_DATE) and a new row +// is inserted (effective_from = CURRENT_DATE, effective_to = +// NULL, unit_price = entered value). Historical rows are +// never updated or deleted here -- no subfile options exist. +// A second price entered the same day hits the table's own +// PRIMARY KEY (company_code, item_number, vendor_code, +// effective_from) and is rejected by DB2 (SQLCODE -803) -- +// "one price change per day" falls out of the PK for free. +// Epic: PERP-5 (PERP-31) +// --------------------------------------------------------------------- + +ctl-opt dftactgrp(*no) actgrp(*new); + +dcl-f wrkivpd workstn sfile(ipsfl:rrn) sfile(ipmsgsfl:msgrrn); + +dcl-ds ldaDS dtaara(*lda) len(1024) qualified; + compcd char(3) pos(1); +end-ds; + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-ds statusDS psds qualified; + programName char(10) pos(334); +end-ds; + +dcl-ds prcRow qualified; + efffrm char(10); + effto char(10); + price packed(15:4); + curr varchar(20); + src varchar(20); +end-ds; + +dcl-ds rows likeds(prcRow) dim(500); +dcl-s numRows int(10); +dcl-s i int(10); +dcl-s rrn int(10); +dcl-s msgrrn int(10); +dcl-s msgkey char(4); +dcl-s compcd char(3); +dcl-s fItem varchar(25); +dcl-s fVendor varchar(10); + +in ldaDS; +compcd = ldaDS.compcd; +scompdsp = compcd; +fItem = ''; +fVendor = ''; +sfitem = ''; +sfvendor = ''; + +if compcd = ''; + exsr clearMsgs; + writeMsg('No company selected - run Select Company (PERPSELR) first.'); +endif; + +dow not *in03 and not *in12; + if compcd = ''; + *in30 = *off; + write ipnoscp; + write ipfoot; + if msgrrn > 0; + *in40 = *on; + write ipmsgctl; + else; + *in40 = *off; + endif; + exfmt ipctl; + leave; + endif; + + exsr clearMsgs; + + if fItem = '' or fVendor = ''; + *in30 = *off; + numRows = 0; + write ipnoscp; + else; + exsr loadRows; + if numRows = 0; + *in30 = *off; + write ipnone; + else; + exsr fillSubfile; + *in30 = *on; + endif; + endif; + + write ipfoot; + if msgrrn > 0; + *in40 = *on; + write ipmsgctl; + else; + *in40 = *off; + endif; + exfmt ipctl; + + if *in03 or *in12; + leave; + endif; + + if *in05; + fItem = sfitem; + fVendor = sfvendor; + iter; + endif; + + if *in06; + if fItem = '' or fVendor = ''; + writeMsg('Enter an item and vendor before adding a price.'); + else; + exsr addPrice; + endif; + iter; + endif; + + // Refresh scope from screen entry + if sfitem <> fItem or sfvendor <> fVendor; + fItem = sfitem; + fVendor = sfvendor; + iter; + endif; +enddo; + +*inlr = *on; +return; + +// --------------------------------------------------------------------- +begsr loadRows; + numRows = 0; + exec sql declare p1 cursor for + select char(effective_from, iso), + case when effective_to is null then '' else char(effective_to, iso) end, + unit_price, currency_code, price_source + from perpdemo.item_vendor_price + where company_code = :compcd and item_number = :fItem + and vendor_code = :fVendor + order by effective_from desc; + exec sql open p1; + if sqlcode < 0; + writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); + return; + endif; + + dow numRows < %elem(rows); + exec sql fetch p1 into :prcRow; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + numRows += 1; + rows(numRows) = prcRow; + enddo; + exec sql close p1; +endsr; + +// --------------------------------------------------------------------- +begsr fillSubfile; + rrn = 0; + *in31 = *on; + write ipctl; + *in31 = *off; + for i = 1 to numRows; + sefffrm = rows(i).efffrm; + seffto = rows(i).effto; + sprice = rows(i).price; + scurr = rows(i).curr; + ssrc = rows(i).src; + rrn += 1; + write ipsfl; + endfor; +endsr; + +// --------------------------------------------------------------------- +begsr addPrice; + eitem = fItem; + evendor = fVendor; + enewprc = 0; + ecurr = 'USD'; + eprcsrc = 'MANUAL'; + exfmt ipadd; + if *in12 or enewprc <= 0; + return; + endif; + + // Close the current row, if one exists (no current row is fine -- + // this is the very first price for this item-vendor). + exec sql + update perpdemo.item_vendor_price + set effective_to = current_date, + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd and item_number = :fItem + and vendor_code = :fVendor and effective_to is null; + if sqlcode < 0; + writeMsg('Close of prior price failed: SQLCODE=' + %char(sqlcode)); + return; + endif; + + exec sql + insert into perpdemo.item_vendor_price + (company_code, item_number, vendor_code, effective_from, + unit_price, currency_code, price_source) + values (:compcd, :fItem, :fVendor, current_date, + :enewprc, :ecurr, :eprcsrc); + if sqlcode = -803; + writeMsg('Add failed: a price was already entered today for this' + + ' item-vendor - only one price change per day.'); + elseif sqlcode < 0; + writeMsg('Add failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('New price ' + %char(enewprc) + ' ' + %trim(ecurr) + + ' effective today.'); + endif; +endsr; + +// --------------------------------------------------------------------- +begsr clearMsgs; + msgrrn = 0; + *in41 = *on; + write ipmsgctl; + *in41 = *off; +endsr; + +// --------------------------------------------------------------------- +dcl-proc writeMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + smsgkey : + x'0000000000000000'); + msgrrn += 1; + spgmq = statusDS.programName; + write ipmsgsfl; +end-proc; diff --git a/perp/qrpglesrc/wrkvndr.sqlrpgle b/perp/qrpglesrc/wrkvndr.sqlrpgle new file mode 100644 index 00000000..18b9713b --- /dev/null +++ b/perp/qrpglesrc/wrkvndr.sqlrpgle @@ -0,0 +1,370 @@ +**free + +// --------------------------------------------------------------------- +// Program: wrkvndr (Work with Vendors -- vendor master maintenance) +// Purpose: DSPF-based CRUD for vendor, scoped by the company selected +// via perpselr (*LDA positions 1-3). Subfile filters by +// active-only and buyer_code. buyer_code FK is enforced by +// DB2 against perp_user; payment_terms_code FK against +// code_master (PAYTERMS) -- typos surface as SQLSTATE 23503 +// on the message subfile. +// Epic: PERP-5 (PERP-29) +// --------------------------------------------------------------------- + +ctl-opt dftactgrp(*no) actgrp(*new); + +dcl-f wrkvndd workstn sfile(vsfl:rrn) sfile(vmsgsfl:msgrrn); + +dcl-ds ldaDS dtaara(*lda) len(1024) qualified; + compcd char(3) pos(1); +end-ds; + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-ds statusDS psds qualified; + programName char(10) pos(334); +end-ds; + +dcl-ds vndRow qualified; + vcode varchar(10); + vname varchar(60); + vbuyer char(10); + vact char(1); +end-ds; + +dcl-ds rows likeds(vndRow) dim(500); +dcl-s numRows int(10); +dcl-s i int(10); +dcl-s rrn int(10); +dcl-s msgrrn int(10); +dcl-s msgkey char(4); +dcl-s selRrn int(10); +dcl-s selOpt char(1); +dcl-s compcd char(3); +dcl-s fActOnly char(1); +dcl-s fBuyer char(10); + +in ldaDS; +compcd = ldaDS.compcd; +scompdsp = compcd; +fActOnly = 'N'; +fBuyer = ''; +sfact = 'N'; +sfbuyer = ''; + +if compcd = ''; + exsr clearMsgs; + writeMsg('No company selected - run Select Company (PERPSELR) first.'); +endif; + +dow not *in03 and not *in12; + if compcd = ''; + *in30 = *off; + write vnoco; + write vfoot; + if msgrrn > 0; + *in40 = *on; + write vmsgctl; + else; + *in40 = *off; + endif; + exfmt vctl; + leave; + endif; + + exsr clearMsgs; + exsr loadRows; + + if numRows = 0; + *in30 = *off; + write vnone; + else; + exsr fillSubfile; + *in30 = *on; + endif; + + write vfoot; + if msgrrn > 0; + *in40 = *on; + write vmsgctl; + else; + *in40 = *off; + endif; + exfmt vctl; + + if *in03 or *in12; + leave; + endif; + + if *in05; + fActOnly = sfact; + fBuyer = sfbuyer; + iter; + endif; + + if *in06; + exsr addRow; + iter; + endif; + + // Refresh filters from screen entry + if sfact <> fActOnly or sfbuyer <> fBuyer; + fActOnly = sfact; + fBuyer = sfbuyer; + iter; + endif; + + // Process subfile options. Guard on numRows: READC against a subfile + // that was never written to this cycle (0 rows loaded) raises a + // "Session or device error" (CPF5006-class) runtime error instead of + // just returning *EOF. + if numRows > 0; + selRrn = 0; + selOpt = ' '; + readc vsfl; + dow not %eof(wrkvndd); + if sopt <> ''; + selRrn = rrn; + selOpt = sopt; + exsr handleOpt; + selRrn = 0; + endif; + readc vsfl; + enddo; + endif; + +enddo; + +*inlr = *on; +return; + +// --------------------------------------------------------------------- +begsr loadRows; + numRows = 0; + exec sql declare v1 cursor for + select vendor_code, vendor_name, buyer_code, is_active + from perpdemo.vendor + where company_code = :compcd + and (:fActOnly = 'N' or is_active = 'Y') + and (:fBuyer = '' or buyer_code = :fBuyer) + order by vendor_code; + exec sql open v1; + if sqlcode < 0; + writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); + return; + endif; + + dow numRows < %elem(rows); + exec sql fetch v1 into :vndRow; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + numRows += 1; + rows(numRows) = vndRow; + enddo; + exec sql close v1; +endsr; + +// --------------------------------------------------------------------- +begsr fillSubfile; + rrn = 0; + *in31 = *on; + write vctl; + *in31 = *off; + for i = 1 to numRows; + *in50 = *off; + *in51 = *off; + sopt = ''; + svcode = rows(i).vcode; + svname = rows(i).vname; + svbuyer = rows(i).vbuyer; + svact = rows(i).vact; + rrn += 1; + write vsfl; + endfor; +endsr; + +// --------------------------------------------------------------------- +begsr handleOpt; + chain selRrn vsfl; + if %found(wrkvndd); + select; + when selOpt = '2'; + exsr changeRow; + when selOpt = '4'; + exsr deleteRow; + when selOpt = '5'; + exsr displayRow; + other; + writeMsg('Option ' + selOpt + ' not valid.'); + endsl; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr addRow; + emode = 'A'; + evcode = ''; + evname = ''; + eaddr1 = ''; + eaddr2 = ''; + ecity = ''; + estate = ''; + epostcd = ''; + ecntry = 'US'; + ephone = ''; + eemail = ''; + ecntct = ''; + ebuyer = fBuyer; + epterms = 'NET30'; + etaxid = ''; + eactive = 'Y'; + exsr editLoop; + if not *in12 and evcode <> ''; + exec sql + insert into perpdemo.vendor + (company_code, vendor_code, vendor_name, address_line1, address_line2, + city_name, state_code, postal_code, country_code, phone_number, + email_address, contact_name, buyer_code, payment_terms_code, tax_id, + is_active) + values (:compcd, :evcode, :evname, :eaddr1, :eaddr2, + :ecity, :estate, :epostcd, :ecntry, :ephone, + :eemail, :ecntct, :ebuyer, :epterms, :etaxid, + :eactive); + if sqlcode < 0; + writeMsg('Add failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Added ' + %trim(evcode) + '.'); + endif; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr changeRow; + emode = 'C'; + evcode = svcode; + exec sql + select vendor_name, address_line1, address_line2, city_name, state_code, + postal_code, country_code, phone_number, email_address, + contact_name, buyer_code, payment_terms_code, tax_id, is_active + into :evname, :eaddr1, :eaddr2, :ecity, :estate, + :epostcd, :ecntry, :ephone, :eemail, + :ecntct, :ebuyer, :epterms, :etaxid, :eactive + from perpdemo.vendor + where company_code = :compcd and vendor_code = :evcode; + if sqlcode <> 0; + writeMsg('Row disappeared before change.'); + return; + endif; + exsr editLoop; + if not *in12; + exec sql + update perpdemo.vendor + set vendor_name = :evname, + address_line1 = :eaddr1, + address_line2 = :eaddr2, + city_name = :ecity, + state_code = :estate, + postal_code = :epostcd, + country_code = :ecntry, + phone_number = :ephone, + email_address = :eemail, + contact_name = :ecntct, + buyer_code = :ebuyer, + payment_terms_code = :epterms, + tax_id = :etaxid, + is_active = :eactive, + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd and vendor_code = :evcode; + if sqlcode < 0; + writeMsg('Change failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Updated ' + %trim(evcode) + '.'); + endif; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr deleteRow; + exec sql + delete from perpdemo.vendor + where company_code = :compcd and vendor_code = :svcode; + if sqlcode < 0; + writeMsg('Delete failed (in use?): SQLSTATE=' + sqlstate); + else; + writeMsg('Deleted ' + %trim(svcode) + '.'); + endif; +endsr; + +// --------------------------------------------------------------------- +begsr displayRow; + emode = 'D'; + evcode = svcode; + exec sql + select vendor_name, address_line1, address_line2, city_name, state_code, + postal_code, country_code, phone_number, email_address, + contact_name, buyer_code, payment_terms_code, tax_id, is_active + into :evname, :eaddr1, :eaddr2, :ecity, :estate, + :epostcd, :ecntry, :ephone, :eemail, + :ecntct, :ebuyer, :epterms, :etaxid, :eactive + from perpdemo.vendor + where company_code = :compcd and vendor_code = :evcode; + exsr editLoop; +endsr; + +// --------------------------------------------------------------------- +// *in60 conditions DSPATR(PR) on every entry field in VEDIT -- protect +// them in Display mode so 5=Display can't be mistaken for an editable +// screen (it never saves regardless, but the fields must not look +// enterable). +begsr editLoop; + if emode = 'D'; + *in60 = *on; + else; + *in60 = *off; + endif; + exfmt vedit; +endsr; + +// --------------------------------------------------------------------- +begsr clearMsgs; + msgrrn = 0; + *in41 = *on; + write vmsgctl; + *in41 = *off; +endsr; + +// --------------------------------------------------------------------- +dcl-proc writeMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + smsgkey : + x'0000000000000000'); + msgrrn += 1; + spgmq = statusDS.programName; + write vmsgsfl; +end-proc; diff --git a/perp/qsrvsrc/itmvprcq.bnd b/perp/qsrvsrc/itmvprcq.bnd new file mode 100644 index 00000000..55da5fe8 --- /dev/null +++ b/perp/qsrvsrc/itmvprcq.bnd @@ -0,0 +1,3 @@ +strpgmexp pgmlvl(*current) signature('ITMVPRCQ ') + export symbol("ITMVPRCQ_HISTORY") +endpgmexp From 536a900ed0a05d72dba0ade16e4a2cfa9dabd171 Mon Sep 17 00:00:00 2001 From: Gary Jones Date: Wed, 15 Jul 2026 19:57:59 +0000 Subject: [PATCH 06/13] PERP-5 follow-up: restructure PERPMNU into child menus, add missing UI polish Splits the flat 13-option PERPMNU into a slim top-level menu (Select company, System Maintenance, Inventory Master Data, Vendor & Pricing, Diagnostics/Smoke Tests, Sign off) with 4 new child menus (PERPSYSM, PERPINVM, PERPVNDM, PERPDIAG) grouping the actual maintenance/diagnostic programs, so the menu scales cleanly as PERP-6/7/8 land instead of growing one line per story. Also fixes UI issues found during review: - WRKVNDR's 5=Display no longer shows an editable panel (fields protected via a display-mode indicator). - The unlabeled EMODE mode indicator ('A'/'C'/'D') gets a 'Mode:' label across all 9 affected work-with screens. - All 5 PERPMNU/child menus get an F3=Exit legend at line 23, matching every work-with screen's existing F-key footer. --- perp/Rules.mk | 41 ++++++++++++++++++++++++++++++++------ perp/perpdiag.msgf | 3 +++ perp/perpinvm.msgf | 6 ++++++ perp/perpmnu.msgf | 16 ++++----------- perp/perpsysm.msgf | 3 +++ perp/perpvndm.msgf | 4 ++++ perp/qddssrc/perpdiag.dspf | 31 ++++++++++++++++++++++++++++ perp/qddssrc/perpinvm.dspf | 34 +++++++++++++++++++++++++++++++ perp/qddssrc/perpmnu.dspf | 36 ++++++++++----------------------- perp/qddssrc/perpsysm.dspf | 30 ++++++++++++++++++++++++++++ perp/qddssrc/perpvndm.dspf | 31 ++++++++++++++++++++++++++++ perp/qddssrc/wrkcmd.dspf | 3 ++- perp/qddssrc/wrkcnvd.dspf | 3 ++- perp/qddssrc/wrkicld.dspf | 3 ++- perp/qddssrc/wrkitmd.dspf | 3 ++- perp/qddssrc/wrkivnd.dspf | 3 ++- perp/qddssrc/wrklotd.dspf | 3 ++- perp/qddssrc/wrkuomd.dspf | 3 ++- perp/qddssrc/wrkusrd.dspf | 3 ++- perp/qddssrc/wrkvndd.dspf | 3 ++- 20 files changed, 209 insertions(+), 53 deletions(-) create mode 100644 perp/perpdiag.msgf create mode 100644 perp/perpinvm.msgf create mode 100644 perp/perpsysm.msgf create mode 100644 perp/perpvndm.msgf create mode 100644 perp/qddssrc/perpdiag.dspf create mode 100644 perp/qddssrc/perpinvm.dspf create mode 100644 perp/qddssrc/perpsysm.dspf create mode 100644 perp/qddssrc/perpvndm.dspf diff --git a/perp/Rules.mk b/perp/Rules.mk index e423969d..7aa53d52 100644 --- a/perp/Rules.mk +++ b/perp/Rules.mk @@ -151,14 +151,43 @@ itmvprcq.srvpgm: itmvprcq.module qsrvsrc/itmvprcq.bnd ivprcqsmk.pgm: qrpglesrc/ivprcqsmk.sqlrpgle qrpglesrc/itmvprcq_pr.rpgle itmvprcq.srvpgm | perp.bnddir item_vendor_price_history.file -# --- PERP main menu (glue for exploratory verification) ------------------ -# Ties the PERP-16/17/18/19/21/22/23/24 programs together into a single -# 5250 menu: GO PERPDEMO/PERPMNU +# --- PERP menus (glue for exploratory verification) ----------------------- +# GO PERPDEMO/PERPMNU is the single entry point. PERPMNU itself only holds +# "Select company" + one option per child menu + Sign off -- the child +# menus group the actual maintenance/diagnostic programs so the top level +# doesn't grow one line per story as new epics land (PERP-6/7/8 +# Requisitioning/Purchasing/Receiving will each get their own child menu +# under PERPMNU the same way, instead of more top-level numbers). +# +# .file MUST be a normal prereq (not order-only) or codermake silently drops +# the CRTMNU recipe. See DDL_STYLE_GUIDE § "codermake menu gotcha" -- this +# bit cfdemo/menu.menu too (fixed there in the same commit as this section). + +# PERP-16/17/18: company selector + system maintenance (code_master, users) +perpsysm.file: qddssrc/perpsysm.dspf +perpsysm.msgf: perpsysm.msgf +perpsysm.menu: perpsysm.msgf perpsysm.file | wrkcmr.pgm wrkusrr.pgm + +# PERP-20/21/22/23/24: inventory master data +perpinvm.file: qddssrc/perpinvm.dspf +perpinvm.msgf: perpinvm.msgf +perpinvm.menu: perpinvm.msgf perpinvm.file | wrkuomr.pgm wrkcnvr.pgm wrkiclr.pgm wrkitmr.pgm wrklotr.pgm + +# PERP-28/29/30/31: vendor & pricing master data +perpvndm.file: qddssrc/perpvndm.dspf +perpvndm.msgf: perpvndm.msgf +perpvndm.menu: perpvndm.msgf perpvndm.file | wrkvndr.pgm wrkivnr.pgm wrkivpr.pgm + +# PERP-19/32: service-program smoke testers +perpdiag.file: qddssrc/perpdiag.dspf +perpdiag.msgf: perpdiag.msgf +perpdiag.menu: perpdiag.msgf perpdiag.file | docseqsmk.pgm ivprcqsmk.pgm + +# Top-level menu. Order-only on perpselr.pgm (called directly) and on the +# 4 child .menu targets (routed to via GO PERPDEMO/, not CALLed). perpmnu.file: qddssrc/perpmnu.dspf perpmnu.msgf: perpmnu.msgf -# .file MUST be a normal prereq (not order-only) or codermake silently drops -# the CRTMNU recipe. See DDL_STYLE_GUIDE § "codermake menu gotcha". -perpmnu.menu: perpmnu.msgf perpmnu.file | perpselr.pgm wrkcmr.pgm wrkusrr.pgm docseqsmk.pgm wrkuomr.pgm wrkcnvr.pgm wrkiclr.pgm wrkitmr.pgm wrklotr.pgm wrkvndr.pgm wrkivnr.pgm wrkivpr.pgm ivprcqsmk.pgm +perpmnu.menu: perpmnu.msgf perpmnu.file | perpselr.pgm perpsysm.menu perpinvm.menu perpvndm.menu perpdiag.menu # --- CL setup ------------------------------------------------------------- diff --git a/perp/perpdiag.msgf b/perp/perpdiag.msgf new file mode 100644 index 00000000..a0116eb3 --- /dev/null +++ b/perp/perpdiag.msgf @@ -0,0 +1,3 @@ +crtmsgf msgf($LIBRARY/$NAME) +addmsgd msgid(usr0001) msgf($LIBRARY/$NAME) msg('call docseqsmk parm(''ACM'' ''PO '')') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0002) msgf($LIBRARY/$NAME) msg('call ivprcqsmk parm(''ACM'' ''WIDGET1'')') seclvl(*none) sev(00) fmt(*none) diff --git a/perp/perpinvm.msgf b/perp/perpinvm.msgf new file mode 100644 index 00000000..72719768 --- /dev/null +++ b/perp/perpinvm.msgf @@ -0,0 +1,6 @@ +crtmsgf msgf($LIBRARY/$NAME) +addmsgd msgid(usr0001) msgf($LIBRARY/$NAME) msg('call wrkuomr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0002) msgf($LIBRARY/$NAME) msg('call wrkcnvr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0003) msgf($LIBRARY/$NAME) msg('call wrkiclr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0004) msgf($LIBRARY/$NAME) msg('call wrkitmr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0005) msgf($LIBRARY/$NAME) msg('call wrklotr') seclvl(*none) sev(00) fmt(*none) diff --git a/perp/perpmnu.msgf b/perp/perpmnu.msgf index ce223073..48042a92 100644 --- a/perp/perpmnu.msgf +++ b/perp/perpmnu.msgf @@ -1,15 +1,7 @@ crtmsgf msgf($LIBRARY/$NAME) addmsgd msgid(usr0001) msgf($LIBRARY/$NAME) msg('call perpselr') seclvl(*none) sev(00) fmt(*none) -addmsgd msgid(usr0002) msgf($LIBRARY/$NAME) msg('call wrkcmr') seclvl(*none) sev(00) fmt(*none) -addmsgd msgid(usr0003) msgf($LIBRARY/$NAME) msg('call wrkusrr') seclvl(*none) sev(00) fmt(*none) -addmsgd msgid(usr0004) msgf($LIBRARY/$NAME) msg('call docseqsmk parm(''ACM'' ''PO '')') seclvl(*none) sev(00) fmt(*none) -addmsgd msgid(usr0005) msgf($LIBRARY/$NAME) msg('call wrkuomr') seclvl(*none) sev(00) fmt(*none) -addmsgd msgid(usr0006) msgf($LIBRARY/$NAME) msg('call wrkcnvr') seclvl(*none) sev(00) fmt(*none) -addmsgd msgid(usr0007) msgf($LIBRARY/$NAME) msg('call wrkiclr') seclvl(*none) sev(00) fmt(*none) -addmsgd msgid(usr0008) msgf($LIBRARY/$NAME) msg('call wrkitmr') seclvl(*none) sev(00) fmt(*none) -addmsgd msgid(usr0009) msgf($LIBRARY/$NAME) msg('call wrklotr') seclvl(*none) sev(00) fmt(*none) -addmsgd msgid(usr0010) msgf($LIBRARY/$NAME) msg('call wrkvndr') seclvl(*none) sev(00) fmt(*none) -addmsgd msgid(usr0011) msgf($LIBRARY/$NAME) msg('call wrkivnr') seclvl(*none) sev(00) fmt(*none) -addmsgd msgid(usr0012) msgf($LIBRARY/$NAME) msg('call wrkivpr') seclvl(*none) sev(00) fmt(*none) -addmsgd msgid(usr0013) msgf($LIBRARY/$NAME) msg('call ivprcqsmk parm(''ACM'' ''WIDGET1'')') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0002) msgf($LIBRARY/$NAME) msg('go perpdemo/perpsysm') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0003) msgf($LIBRARY/$NAME) msg('go perpdemo/perpinvm') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0004) msgf($LIBRARY/$NAME) msg('go perpdemo/perpvndm') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0005) msgf($LIBRARY/$NAME) msg('go perpdemo/perpdiag') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0090) msgf($LIBRARY/$NAME) msg('signoff') seclvl(*none) sev(00) fmt(*none) diff --git a/perp/perpsysm.msgf b/perp/perpsysm.msgf new file mode 100644 index 00000000..3f3b7e33 --- /dev/null +++ b/perp/perpsysm.msgf @@ -0,0 +1,3 @@ +crtmsgf msgf($LIBRARY/$NAME) +addmsgd msgid(usr0001) msgf($LIBRARY/$NAME) msg('call wrkcmr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0002) msgf($LIBRARY/$NAME) msg('call wrkusrr') seclvl(*none) sev(00) fmt(*none) diff --git a/perp/perpvndm.msgf b/perp/perpvndm.msgf new file mode 100644 index 00000000..d17c0bc9 --- /dev/null +++ b/perp/perpvndm.msgf @@ -0,0 +1,4 @@ +crtmsgf msgf($LIBRARY/$NAME) +addmsgd msgid(usr0001) msgf($LIBRARY/$NAME) msg('call wrkvndr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0002) msgf($LIBRARY/$NAME) msg('call wrkivnr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0003) msgf($LIBRARY/$NAME) msg('call wrkivpr') seclvl(*none) sev(00) fmt(*none) diff --git a/perp/qddssrc/perpdiag.dspf b/perp/qddssrc/perpdiag.dspf new file mode 100644 index 00000000..b9290f7f --- /dev/null +++ b/perp/qddssrc/perpdiag.dspf @@ -0,0 +1,31 @@ + A* PERPDIAG menu + A DSPSIZ(24 80 *DS3) + A CHGINPDFT + A INDARA + A PRINT(*LIBL/QSYSPRT) + A* CRTMNU TYPE(*DSPF) requires a record format named PERPDIAG + A R PERPDIAG + A LOCK + A SLNO(01) + A CLRL(*ALL) + A ALWROL + A CF03 + A HELP + A HOME + A HLPRTN + A 1 2'PERPDIAG' + A COLOR(BLU) + A 1 25'PERP - Diagnostics / Smoke Tests' + A DSPATR(HI) + A COLOR(WHT) + A 3 2'Select one of the following:' + A COLOR(BLU) + A 5 7'1. Smoke test doc-sequence servi- + A ce' + A 6 7'2. Smoke test price-history serv- + A ice' + A 23 2'F3=Exit' + A COLOR(BLU) + A* CMDPROMPT Do not delete this DDS spec. + A 021 2'Selection: - + A ' diff --git a/perp/qddssrc/perpinvm.dspf b/perp/qddssrc/perpinvm.dspf new file mode 100644 index 00000000..cdb80fa8 --- /dev/null +++ b/perp/qddssrc/perpinvm.dspf @@ -0,0 +1,34 @@ + A* PERPINVM menu + A DSPSIZ(24 80 *DS3) + A CHGINPDFT + A INDARA + A PRINT(*LIBL/QSYSPRT) + A* CRTMNU TYPE(*DSPF) requires a record format named PERPINVM + A R PERPINVM + A LOCK + A SLNO(01) + A CLRL(*ALL) + A ALWROL + A CF03 + A HELP + A HOME + A HLPRTN + A 1 2'PERPINVM' + A COLOR(BLU) + A 1 25'PERP - Inventory Master Data' + A DSPATR(HI) + A COLOR(WHT) + A 3 2'Select one of the following:' + A COLOR(BLU) + A 5 7'1. Work with units of measure (u- + A om)' + A 6 7'2. Work with item UOM conversion- + A s' + A 7 7'3. Work with item classes' + A 8 7'4. Work with items' + A 9 7'5. Work with item lots' + A 23 2'F3=Exit' + A COLOR(BLU) + A* CMDPROMPT Do not delete this DDS spec. + A 021 2'Selection: - + A ' diff --git a/perp/qddssrc/perpmnu.dspf b/perp/qddssrc/perpmnu.dspf index 8de94c19..2c3fbade 100644 --- a/perp/qddssrc/perpmnu.dspf +++ b/perp/qddssrc/perpmnu.dspf @@ -1,11 +1,9 @@ - A* PERP main menu + A* PERPMNU menu A DSPSIZ(24 80 *DS3) A CHGINPDFT A INDARA A PRINT(*LIBL/QSYSPRT) - A* CRTMNU TYPE(*DSPF) looks for a record format whose name matches - A* the menu object name (PERPMNU). Using 'R MENU' produces the - A* runtime error 'Record format for menu definition not found.' + A* CRTMNU TYPE(*DSPF) requires a record format named PERPMNU A R PERPMNU A LOCK A SLNO(01) @@ -17,33 +15,19 @@ A HLPRTN A 1 2'PERPMNU' A COLOR(BLU) - A 1 25'PreSales ERP (PERP) — Main Me- - A nu' + A 1 25'PreSales ERP (PERP) - Main Menu' A DSPATR(HI) A COLOR(WHT) A 3 2'Select one of the following:' A COLOR(BLU) A 5 7'1. Select company for session' - A 6 7'2. Work with system codes (co- - A de_master)' - A 7 7'3. Work with PERP users' - A 8 7'4. Smoke test doc-sequence se- - A rvice' - A 9 7'5. Work with units of measure - - A (uom)' - A 10 7'6. Work with item UOM convers- - A ions' - A 11 7'7. Work with item classes' - A 12 7'8. Work with items' - A 13 7'9. Work with item lots' - A 14 6'10. Work with vendors' - A 15 6'11. Work with item-vendor prof- - A iles' - A 16 6'12. Work with item-vendor pric- - A es' - A 17 6'13. Smoke test price-history - - A service' - A 19 6'90. Sign off' + A 6 7'2. System Maintenance' + A 7 7'3. Inventory Master Data' + A 8 7'4. Vendor & Pricing' + A 9 7'5. Diagnostics / Smoke Tests' + A 12 6'90. Sign off' + A 23 2'F3=Exit' + A COLOR(BLU) A* CMDPROMPT Do not delete this DDS spec. A 021 2'Selection: - A ' diff --git a/perp/qddssrc/perpsysm.dspf b/perp/qddssrc/perpsysm.dspf new file mode 100644 index 00000000..9342dfc2 --- /dev/null +++ b/perp/qddssrc/perpsysm.dspf @@ -0,0 +1,30 @@ + A* PERPSYSM menu + A DSPSIZ(24 80 *DS3) + A CHGINPDFT + A INDARA + A PRINT(*LIBL/QSYSPRT) + A* CRTMNU TYPE(*DSPF) requires a record format named PERPSYSM + A R PERPSYSM + A LOCK + A SLNO(01) + A CLRL(*ALL) + A ALWROL + A CF03 + A HELP + A HOME + A HLPRTN + A 1 2'PERPSYSM' + A COLOR(BLU) + A 1 25'PERP - System Maintenance' + A DSPATR(HI) + A COLOR(WHT) + A 3 2'Select one of the following:' + A COLOR(BLU) + A 5 7'1. Work with system codes (code_- + A master)' + A 6 7'2. Work with PERP users' + A 23 2'F3=Exit' + A COLOR(BLU) + A* CMDPROMPT Do not delete this DDS spec. + A 021 2'Selection: - + A ' diff --git a/perp/qddssrc/perpvndm.dspf b/perp/qddssrc/perpvndm.dspf new file mode 100644 index 00000000..b3f8b0bc --- /dev/null +++ b/perp/qddssrc/perpvndm.dspf @@ -0,0 +1,31 @@ + A* PERPVNDM menu + A DSPSIZ(24 80 *DS3) + A CHGINPDFT + A INDARA + A PRINT(*LIBL/QSYSPRT) + A* CRTMNU TYPE(*DSPF) requires a record format named PERPVNDM + A R PERPVNDM + A LOCK + A SLNO(01) + A CLRL(*ALL) + A ALWROL + A CF03 + A HELP + A HOME + A HLPRTN + A 1 2'PERPVNDM' + A COLOR(BLU) + A 1 25'PERP - Vendor & Pricing' + A DSPATR(HI) + A COLOR(WHT) + A 3 2'Select one of the following:' + A COLOR(BLU) + A 5 7'1. Work with vendors' + A 6 7'2. Work with item-vendor profile- + A s' + A 7 7'3. Work with item-vendor prices' + A 23 2'F3=Exit' + A COLOR(BLU) + A* CMDPROMPT Do not delete this DDS spec. + A 021 2'Selection: - + A ' diff --git a/perp/qddssrc/wrkcmd.dspf b/perp/qddssrc/wrkcmd.dspf index acb50743..ac642879 100644 --- a/perp/qddssrc/wrkcmd.dspf +++ b/perp/qddssrc/wrkcmd.dspf @@ -47,7 +47,8 @@ A OVERLAY A 1 30'Edit Code' A DSPATR(HI) - A EMODE 1A O 2 2 + A 2 2'Mode:' + A EMODE 1A O 2 8 A 3 2'Type:' A ETYPE 20A B 3 10 A 4 2'Value:' diff --git a/perp/qddssrc/wrkcnvd.dspf b/perp/qddssrc/wrkcnvd.dspf index 4bcee458..9f935b81 100644 --- a/perp/qddssrc/wrkcnvd.dspf +++ b/perp/qddssrc/wrkcnvd.dspf @@ -52,7 +52,8 @@ A OVERLAY A 1 25'Edit Item UOM Conversion' A DSPATR(HI) - A EMODE 1A O 2 2 + A 2 2'Mode:' + A EMODE 1A O 2 8 A 3 2'From UOM:' A EFROM 5A B 3 13 A 4 2'To UOM:' diff --git a/perp/qddssrc/wrkicld.dspf b/perp/qddssrc/wrkicld.dspf index 3d950261..3a712922 100644 --- a/perp/qddssrc/wrkicld.dspf +++ b/perp/qddssrc/wrkicld.dspf @@ -48,7 +48,8 @@ A OVERLAY A 1 30'Edit Item Class' A DSPATR(HI) - A EMODE 1A O 2 2 + A 2 2'Mode:' + A EMODE 1A O 2 8 A 3 2'Class:' A ECLASS 10A B 3 10 A 4 2'Description:' diff --git a/perp/qddssrc/wrkitmd.dspf b/perp/qddssrc/wrkitmd.dspf index 336eb2f9..1e3d676c 100644 --- a/perp/qddssrc/wrkitmd.dspf +++ b/perp/qddssrc/wrkitmd.dspf @@ -63,7 +63,8 @@ A OVERLAY A 1 30'Edit Item' A DSPATR(HI) - A EMODE 1A O 2 2 + A 2 2'Mode:' + A EMODE 1A O 2 8 A 2 5'Item:' A EITEM 25A B 2 25 A 3 2'Description:' diff --git a/perp/qddssrc/wrkivnd.dspf b/perp/qddssrc/wrkivnd.dspf index 39c7c3cf..5c6cc083 100644 --- a/perp/qddssrc/wrkivnd.dspf +++ b/perp/qddssrc/wrkivnd.dspf @@ -66,7 +66,8 @@ A OVERLAY A 1 25'Edit Item-Vendor Profile' A DSPATR(HI) - A EMODE 1A O 2 2 + A 2 2'Mode:' + A EMODE 1A O 2 8 A 3 2'Item:' A EITEM 25A B 3 15 A 4 2'Vendor:' diff --git a/perp/qddssrc/wrklotd.dspf b/perp/qddssrc/wrklotd.dspf index 427e8b95..18e902d7 100644 --- a/perp/qddssrc/wrklotd.dspf +++ b/perp/qddssrc/wrklotd.dspf @@ -62,7 +62,8 @@ A OVERLAY A 1 28'Edit Item Lot' A DSPATR(HI) - A EMODE 1A O 2 2 + A 2 2'Mode:' + A EMODE 1A O 2 8 A 3 2'Lot Number:' A ELOT 20A B 3 14 A 4 2'Qty On Hand:' diff --git a/perp/qddssrc/wrkuomd.dspf b/perp/qddssrc/wrkuomd.dspf index 6c2350c3..c70260c7 100644 --- a/perp/qddssrc/wrkuomd.dspf +++ b/perp/qddssrc/wrkuomd.dspf @@ -45,7 +45,8 @@ A OVERLAY A 1 30'Edit UOM' A DSPATR(HI) - A EMODE 1A O 2 2 + A 2 2'Mode:' + A EMODE 1A O 2 8 A 3 2'Code:' A ECODE 5A B 3 10 A 4 2'Description:' diff --git a/perp/qddssrc/wrkusrd.dspf b/perp/qddssrc/wrkusrd.dspf index 1abfb5ef..22eec740 100644 --- a/perp/qddssrc/wrkusrd.dspf +++ b/perp/qddssrc/wrkusrd.dspf @@ -47,7 +47,8 @@ A OVERLAY A 1 30'Edit User' A DSPATR(HI) - A EMODE 1A O 2 2 + A 2 2'Mode:' + A EMODE 1A O 2 8 A 3 2'User code:' A EUCODE 10A B 3 15 A 4 2'Display name:' diff --git a/perp/qddssrc/wrkvndd.dspf b/perp/qddssrc/wrkvndd.dspf index 9b594090..4e9e6028 100644 --- a/perp/qddssrc/wrkvndd.dspf +++ b/perp/qddssrc/wrkvndd.dspf @@ -57,7 +57,8 @@ A OVERLAY A 1 30'Edit Vendor' A DSPATR(HI) - A EMODE 1A O 2 2 + A 2 2'Mode:' + A EMODE 1A O 2 8 A 3 2'Vendor code:' A EVCODE 10A B 3 15 A 60 DSPATR(PR) From 70b06c516af0585707ce0a4aeaf0aca115b73bb7 Mon Sep 17 00:00:00 2001 From: Gary Jones Date: Thu, 16 Jul 2026 12:57:15 +0000 Subject: [PATCH 07/13] =?UTF-8?q?PERP-6:=20Requisitioning=20=E2=80=94=20ta?= =?UTF-8?q?bles,=20entry/approval=20programs,=20CoderFlow=20auto-approval?= =?UTF-8?q?=20hook?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Implements the full Requisitioning epic (PERP-33 through PERP-36): - requisition_header / requisition_line DDL (REQUI00001/REQUI00002), with confidence_pct and a full approval audit block (approved_by/approved_at/ approval_source_code+type/approval_notes, all-or-nothing via CHECK), journaled to PERPJRN - REQENTR: requisition entry (header + line subfile), doc-numbered via docseq_next('REQ'), UOM/cost defaulted from item master + preferred vendor pricing - REQAPRR: requisition approval (SUBMITTED list -> detail w/ lines + confidence badge -> approve/reject, human-stamped) - REQAUTO: CoderFlow auto-approval hook (skeleton scorer + threshold-gated auto-approve against company_config), smoke-tested via REQAUTOSMK - New PERPREQM child menu under PERPMNU; REQAUTOSMK added to PERPDIAG - perp/qddlsrc/seed/025_approval_thresholds.sql: seeds company_config auto-approval thresholds for both demo companies (numbered 025, not 030, to avoid colliding with PERP-9's planned 030_items.sql) - perp/DDL_STYLE_GUIDE.md: documents that GENERATED ALWAYS AS (expression) computed columns don't build on this target, and the FOR COLUMN duplicate-name gotcha on short SQL names Also updates Confluence (Design Decisions & Conventions, Data Model — Transactional & Audit, Delivery Plan — Epics & Roadmap, PERP hub, ACME Seed Dataset Spec) to reflect the shipped schema and epic status. Post-close fixes (found via live user testing after the epic closed): - reqentr.sqlrpgle / reqaprr.sqlrpgle: writeMsg passed a private msgkey variable to QMHSNDPM instead of the DDS SFLMSGKEY field (smsgkey), crashing every message the programs tried to show ("The call to WRITEMSG ended in error"). Fixed to pass smsgkey; removed the dead msgkey variable. - reqentd.dspf: RHEAD (header-entry format) was missing OVERLAY, which would have hidden the "no company selected" message even after the crash was fixed. - perp/qddlsrc/seed/025_approval_thresholds.sql (renamed from 030 to avoid colliding with PERP-9's planned 030_items.sql). - reqentr.sqlrpgle: deferred the "2=Change" line option's EXFMT RLEDIT until after its driving READC loop drains (defensive, matches perpselr.sqlrpgle's pattern), reading from the RPG array snapshot instead of the live subfile buffer once deferred. - reqaprr/reqaprd: reqaprr crashed live with CPF5006 "Session or device error" / unmonitored RNX1255 at EXFMT ALCTL when it held two subfiles (ASFL/ASCTL list + ALSFL/ALCTL review-detail) in one device file. Took four rounds to actually resolve: 1. Deferring the format switch past the driving READC loop -- did not fix it. 2. Splitting the detail screen into a separately-called program (REQAPDTL) with its own device file -- also crashed, cascading across both files. REQAPDTL later removed entirely (orphaned PERPDEMO objects/source deleted, removed from Rules.mk). 3. Diagnosed (via community references on this exact error) that SFLDSP-on with 0 device-visible rows -- caused by RDFOOT (a footer written every loop iteration right before EXFMT ALCTL) missing OVERLAY -- was the root cause. Rebuilt with two real subfiles (ASFL/ASCTL + ALSFL/ALCTL, header fields combined onto ALCTL per reqentd.dspf's RLCTL pattern), separate SFLCLR/SFLDSP indicators, RDFOOT with OVERLAY. Compiled clean, reported fixed. 4. Disproven by the user's own fresh-session retest: identical crash, identical statement. Reverted reqaprr/reqaprd.dspf to the only design ever confirmed to actually render: one real subfile (ASFL/ASCTL) for the list, and a plain non-subfile RDETAIL record for the review/approve screen, with up to 6 line-item fields conditioned on indicators (*in60-*in65) so unused rows are blank instead of showing 0.0000. This is a scoped, deliberate deviation from this module's usual two-subfile pattern, kept only for reqaprr; the true root cause of why a second subfile fails here remains unconfirmed. Also fixed a related DDS compile-time bug hit along the way (SFLDSPCTL + an input field below a subfile's anchor row raises CPD7812) and a free-form RPG syntax issue (no multiple semicolon-separated statements per source line on this compiler). DDL_STYLE_GUIDE.md Sec.14, the Design Decisions & Conventions Confluence page, and persistent memory were each corrected multiple times as understanding evolved -- final state documents all four attempts and outcomes plainly rather than presenting another unconfirmed theory as settled. Co-Authored-By: CoderFlow Learn more: https://coderflow.ai --- perp/DDL_STYLE_GUIDE.md | 139 ++++- perp/Rules.mk | 54 +- perp/perp.bnddir | 1 + perp/perpdiag.msgf | 1 + perp/perpmnu.msgf | 1 + perp/perpreqm.msgf | 3 + perp/qddlsrc/requisition_header.table.sql | 139 +++++ perp/qddlsrc/requisition_line.table.sql | 82 +++ perp/qddlsrc/seed/025_approval_thresholds.sql | 28 + perp/qddssrc/perpdiag.dspf | 2 + perp/qddssrc/perpmnu.dspf | 1 + perp/qddssrc/perpreqm.dspf | 29 + perp/qddssrc/reqaprd.dspf | 117 ++++ perp/qddssrc/reqentd.dspf | 108 ++++ perp/qrpglesrc/reqaprr.sqlrpgle | 441 +++++++++++++++ perp/qrpglesrc/reqauto.sqlrpgle | 154 ++++++ perp/qrpglesrc/reqauto_pr.rpgle | 40 ++ perp/qrpglesrc/reqautosmk.sqlrpgle | 77 +++ perp/qrpglesrc/reqentr.sqlrpgle | 514 ++++++++++++++++++ perp/qsrvsrc/reqauto.bnd | 4 + 20 files changed, 1926 insertions(+), 9 deletions(-) create mode 100644 perp/perpreqm.msgf create mode 100644 perp/qddlsrc/requisition_header.table.sql create mode 100644 perp/qddlsrc/requisition_line.table.sql create mode 100644 perp/qddlsrc/seed/025_approval_thresholds.sql create mode 100644 perp/qddssrc/perpreqm.dspf create mode 100644 perp/qddssrc/reqaprd.dspf create mode 100644 perp/qddssrc/reqentd.dspf create mode 100644 perp/qrpglesrc/reqaprr.sqlrpgle create mode 100644 perp/qrpglesrc/reqauto.sqlrpgle create mode 100644 perp/qrpglesrc/reqauto_pr.rpgle create mode 100644 perp/qrpglesrc/reqautosmk.sqlrpgle create mode 100644 perp/qrpglesrc/reqentr.sqlrpgle create mode 100644 perp/qsrvsrc/reqauto.bnd diff --git a/perp/DDL_STYLE_GUIDE.md b/perp/DDL_STYLE_GUIDE.md index d8db20cd..7c65f68c 100644 --- a/perp/DDL_STYLE_GUIDE.md +++ b/perp/DDL_STYLE_GUIDE.md @@ -71,6 +71,14 @@ RPG `dcl-f`) against it — don't guess an abbreviation. Related: **`LABEL ON TABLE` text is capped at 50 characters** on DB2 for i; longer text raises `SQL0107`. Column labels have the same cap. +**A short column name can trip the same rule with a different error.** +Learned in PERP-33: `notes FOR COLUMN NOTES CLOB(16K)` raises `SQL0612: +NOTES is a duplicate column name`, not the `SQL7029` shown above for tables +— same root cause (the SQL name `notes` is already a valid ≤10-char system +name, so the explicit `FOR COLUMN NOTES` collides with the auto-derivation), +just a different diagnostic at the column level. Fix is identical: drop the +redundant `FOR COLUMN` clause and let it auto-derive. + **Auto-derived short names for >10-char SQL names are not a simple truncation — they can be a sequential counter with no relation to the SQL name at all.** Learned in PERP-28: `item_vendor` (11 chars) and @@ -190,16 +198,38 @@ immutable — new prices close the current row and insert a new one. ## 9. Document numbering -Doc numbers are integer sequences per `(company_code, doc_type)` with a -computed display column for demo aesthetics: +Doc numbers are integer sequences per `(company_code, doc_type)`: ```sql -po_number FOR COLUMN PONBR BIGINT NOT NULL, -po_display FOR COLUMN PODSPY VARCHAR(20) GENERATED ALWAYS AS - (company_code CONCAT '-PO-' CONCAT LPAD(CHAR(po_number), 6, '0')) +requisition_number FOR COLUMN REQNBR BIGINT NOT NULL, ``` -A `document_sequence` table holds the high-water mark per company + doc type. +A `document_sequence` table holds the high-water mark per company + doc type +(bumped via the `docseq` service program, PERP-19). + +**No computed display column.** An earlier draft of this section showed a +`GENERATED ALWAYS AS (expression)` computed column for demo-friendly display +numbers (e.g. `ACM-PO-000123`). That pattern **does not build on this +target** — confirmed in PERP-33. Every variant tried raised a parser error +pointing at the open paren or the first identifier inside it, with the same +oddly specific hint list (`Valid tokens: . ACCTNG USERID APPLNAME PROGRAMID +WRKSTNNAME`) regardless of what the expression contained: + +| Attempt | Error | +|---|---| +| `company_code CONCAT '-REQ-' CONCAT LPAD(...)` | SQL0199 at the first `CONCAT` | +| `company_code \|\| '-REQ-' \|\| LPAD(...)` | SQL0104 at the first `\|\|` | +| `(company_code)` — bare column reference | SQL0104 at the closing `)` | +| `(UPPER(company_code))` | SQL0104 at `(` after `UPPER` | +| `(tablename.company_code)` | SQL0104, hinted `QSYS2 SYSIBM` | +| IBM's own reference example, `bonus DEC(9,2) GENERATED ALWAYS AS (salary * .10)` | SQL0104 at `*` | + +`GENERATED ALWAYS AS IDENTITY` (no expression) works fine on this target — +only the computed-column expression form fails, on every shape tested. If a +future story needs a demo-friendly display number, build it in RPG/DSPF (or +a view) instead of a generated column; don't re-attempt this in DDL without +budgeting time to re-verify it against whatever DB2 for i PTF/config is live +at the time. ## 10. Generic lookup — `code_master` @@ -325,6 +355,103 @@ maintenance programs. These apply to every RPG or SQLRPGLE source under F12=Cancel — declared at file level and echoed in the footer line. - **Message subfile** (`R xMSGSFL` / `R xMSGCTL`) attached at row 24 on every screen; RPG uses `QMHSNDPM` to post messages. +- **`QMHSNDPM`'s message-key output parameter must be the DDS field bound + to `SFLMSGKEY`** (e.g. `SMSGKEY`), not a separate RPG variable of your + own — even one also named `msgkey`. Found in PERP-34/PERP-35 (`reqentr`/ + `reqaprr`): a `writeMsg` helper passed its own local `msgkey` to + `QMHSNDPM` instead of the DDS field `smsgkey`, so `smsgkey` stayed + uninitialized; the subsequent `WRITE` to the message subfile record then + crashed at runtime (`CPF9999`-class exception, "The call to ended + in error") because the device driver couldn't resolve a message using a + garbage key. Caught only by a live user hitting the very first + `writeMsg` call in a fresh program (the "no company selected" guard) — + it reproduces on *every* call, not just that one path, so a single typo + here breaks every message the program ever shows. Always pass the + record's own `SFLMSGKEY` field, and double-check this any time you + copy the `writeMsg`/`clearMsgs` boilerplate into a new program. +- **The record format shown alongside (or right before) the message + subfile must have `OVERLAY`**, or displaying/writing it clears the + screen and erases the just-written message subfile before the user + ever sees it. Every PERP work-with screen's primary `SFLCTL` format + has had `OVERLAY` since PERP-3, but a plain (non-subfile) entry screen + — e.g. `reqentd.dspf`'s header-entry format `RHEAD` (PERP-34) — is easy + to miss since there's no subfile keyword nearby as a reminder. Give + every format that gets `WRITE`/`EXFMT`'d `OVERLAY`, subfile or not. +- **A second real subfile in `reqaprr`/`reqaprd.dspf` (list `ASFL`/`ASCTL` + plus a review-detail `ALSFL`/`ALCTL`) reliably crashed live with + "Session or device error occurred in file &1" (`CPF5006`) / an + unmonitored `RNX1255` at `EXFMT ALCTL`, on this environment + (Profound UI Genie, "classic" skin) — across **four** independent, + each-textbook-correct implementations, and the true cause is still + not confirmed. Recorded here in full because the investigation + produced two plausible-looking "root causes" in a row that both + turned out to be wrong once retested live; don't repeat either as a + first assumption. + 1. `ASFL`/`ASCTL` (list) + `ALSFL`/`ALCTL` (detail), format switch + issued from inside the driving `READC asfl` loop — crashed. + 2. Same design, format switch deferred until after the `READC` loop + fully drains — crashed identically. + 3. Detail screen split into a separately called program (`reqapdtl`) + with its own device file, the same pattern `wrkitmr` uses calling + `wrkcnvr`/`wrklotr` — crashed too, cascading errors across both + files. (This attempt did surface one real, unrelated, independently + confirmed DDS compile-time bug, kept below: `SFLDSPCTL` combined + with a below-anchor input field raises `CPD7812`.) + 4. Same two-subfile design as #1, this time built carefully against + the documented `CPF5006`/`RNX1255` failure mode (see + [code400.com](https://code400.com/forum/forum/iseries-programming-languages/rpg-rpgle/7971-session-or-device-error) + and [midrangenews.com](http://www.midrangenews.com/view?id=1788): + the error fires when `SFLDSP` is on but the subfile has 0 rows from + the *device's* perspective, typically because a non-`OVERLAY` + `WRITE` in between cleared the screen) — `OVERLAY` added to every + format including the `RDFOOT` footer, separate `SFLCLR`/`SFLDSP` + indicator pairs per subfile, no `SFLDSPCTL`. This looked like a + confirmed fix (compiled clean, matched every documented rule) and + was reported as such — but a genuine fresh-session live retest by + the user showed the **identical crash at the identical statement**. + The "missing `OVERLAY`" theory is therefore wrong, or at least + incomplete, as an explanation for this specific crash. + Every one of these four is standard, previously-working RPG/DDS — + #4 in particular matches the exact pattern every other PERP work-with + screen (`PERPSELR`, `WRKCMR`, `WRKITMR`, etc.) already uses safely for + a single subfile. The one common thread across every failure is + *two subfiles in this one program*; the one design that has ever + rendered successfully for the user is `reqaprr`'s current shape: + **one real subfile (`ASFL`/`ASCTL`) for the list, and a plain + (non-subfile) `RDETAIL` record for the review/approve screen**, with + up to `MAXDTLLINES` (6) line-item rows represented as individually + named fields (`L1ITEM`/`L1QTY`/`L1UOM`/`L1COST` through `L6...`), each + group conditioned on its own indicator (`*in60`-`*in65`) so an unused + row is genuinely blank rather than a confusing `0.0000` (do not use + indicators as a stand-in for real subfile scrolling in general — this + is a workaround for a shape that is known to fail here, not a new + default pattern to reach for elsewhere). This is a deliberate + deviation from the two-subfile pattern used everywhere else in this + module, kept **only** for `reqaprr`, and it caps review detail at 6 + lines with no scrolling — acceptable for now since requisition line + counts are small, but revisit if that stops being true or if the + underlying cause is ever identified. **Do not re-attempt a second + business subfile in `reqaprr` without an actual interactive retest on + this environment proving it renders** — a clean compile and a + textbook-correct design have both already failed to predict this. +- **A `SFLCTL` record's `SFLDSPCTL` keyword combined with an + input-capable (`B`) field positioned *below* the subfile's anchor row + raises `CPD7812`: "Subfile control record overlaps subfile record"** + at DDS compile time — even though the field's row/col is nowhere near + the subfile's visible `SFLPAG` rows. Confirmed empirically while + building `reqapdtl.dspf` (PERP-35 follow-up): the same field + (`ENOTES2`, an entry field at row 15, well below `SFLPAG(0005)`'s + visible rows 10-14) compiled clean once `SFLDSPCTL` was removed and + the field was repositioned *above* the subfile's anchor row instead. + The overlap check appears to reserve rows through `SFLSIZ` (which can + be much larger than `SFLPAG`, e.g. `50` vs `5` here), not just the + visible page, for any input-capable control-record field, when + `SFLDSPCTL` is present. Fix: position input-capable fields on a + `SFLCTL` record *above* the subfile's anchor row (matching every + other PERP `SFLCTL` record, e.g. `RLCTL` in `reqentd.dspf`, none of + which have `SFLDSPCTL` combined with a below-anchor input field), or + omit `SFLDSPCTL` if it isn't actually needed (it wasn't, here — the + existing `SFLDSP` conditioning indicator already controls visibility). - **Every numeric field on screen (subfile column or edit-panel field, input or output) gets `EDTCDE(3)`.** Without an edit code, a zoned numeric field displays every leading zero (e.g. `000000001500000` for diff --git a/perp/Rules.mk b/perp/Rules.mk index 654a278c..820632e1 100644 --- a/perp/Rules.mk +++ b/perp/Rules.mk @@ -174,6 +174,47 @@ itmvprcq.srvpgm: itmvprcq.module qsrvsrc/itmvprcq.bnd ivprcqsmk.pgm: qrpglesrc/ivprcqsmk.sqlrpgle qrpglesrc/itmvprcq_pr.rpgle itmvprcq.srvpgm | perp.bnddir item_vendor_price_history.file +# --- PERP-6: Requisitioning — requisition_header / requisition_line ------- +# FK order: requisition_header (company, perp_user, code_master -- all +# already built in PERP-2) before requisition_line (requisition_header, +# item, uom). +requisition_header.file: qddlsrc/requisition_header.table.sql company.file perp_user.file code_master.file | perpsjpf.pgm +requisition_line.file: qddlsrc/requisition_line.table.sql requisition_header.file item.file uom.file | perpsjpf.pgm + +# Requisition entry program (header + line subfile). Calls docseq_next('REQ') +# for numbering; defaults line UOM from item, est_unit_cost from the +# preferred vendor's current item_vendor_price row. +reqentd.file: qddssrc/reqentd.dspf +reqentr.pgm: qrpglesrc/reqentr.sqlrpgle qrpglesrc/docseq_pr.rpgle qddssrc/reqentd.dspf | reqentd.file perp.bnddir requisition_header.file requisition_line.file item.file item_vendor.file item_vendor_price.file uom.file perp_user.file + +# Requisition approval program (list of SUBMITTED reqs -> detail w/ up to +# 6 lines as plain fields + confidence badge -> Approve/Reject stamping +# approved_by/approved_at/approval_source=HUMAN/approval_notes). Detail +# is a single plain (non-subfile) record in this SAME file/program -- +# two earlier designs (a second SFLCTL subfile in this file; a separate +# called program with its own device file) both crashed at runtime with +# "Session or device error" the moment the detail screen was reached, +# even though both compiled clean and matched seemingly-reasonable RPG +# patterns. This shape -- one subfile (ASFL) plus plain output/entry +# fields, all in one program -- is the simplest one that's actually +# proven not to crash (matches reqentr's own header/line-edit panels). +reqaprd.file: qddssrc/reqaprd.dspf +reqaprr.pgm: qrpglesrc/reqaprr.sqlrpgle qddssrc/reqaprd.dspf | reqaprd.file requisition_header.file requisition_line.file + +# CoderFlow auto-approval hook. Skeleton service program: no-op scorer, +# reads company_config thresholds, auto-approves (status/approved_by= +# CODERFLOW/approved_at/approval_source_code=CODERFLOW/approval_notes) +# when both the confidence and total-cost thresholds pass. Module + +# srvpgm + bnddir + prototype, same pattern as docseq (PERP-19). +reqauto.module: qrpglesrc/reqauto.sqlrpgle qrpglesrc/reqauto_pr.rpgle | requisition_header.file company_config.file +reqauto.srvpgm: reqauto.module qsrvsrc/reqauto.bnd +# perp.bnddir target already declared above (PERP-19 docseq section); +# adding a new addbnddire entry there for reqauto is enough. + +# Smoke-test caller for reqauto -- CALL PERPDEMO/REQAUTOSMK PARM('ACM' '3 '). +reqautosmk.pgm: qrpglesrc/reqautosmk.sqlrpgle qrpglesrc/reqauto_pr.rpgle reqauto.srvpgm | perp.bnddir requisition_header.file + + # --- PERP menus (glue for exploratory verification) ----------------------- # GO PERPDEMO/PERPMNU is the single entry point. PERPMNU itself only holds # "Select company" + one option per child menu + Sign off -- the child @@ -204,13 +245,20 @@ perpvndm.menu: perpvndm.msgf perpvndm.file | wrkvndr.pgm wrkivnr.pgm wrkivpr.pgm # PERP-19/27/32: service-program smoke testers perpdiag.file: qddssrc/perpdiag.dspf perpdiag.msgf: perpdiag.msgf -perpdiag.menu: perpdiag.msgf perpdiag.file | docseqsmk.pgm ivprcqsmk.pgm whcoordsmk.pgm +perpdiag.menu: perpdiag.msgf perpdiag.file | docseqsmk.pgm ivprcqsmk.pgm whcoordsmk.pgm reqautosmk.pgm + +# PERP-6/7/8: Requisitioning / Purchasing / Receiving each get their own +# child menu under PERPMNU (see codermake menu note below). PERP-34 adds +# option 1 (reqentr); PERP-35 adds option 2 (reqaprr) once it lands. +perpreqm.file: qddssrc/perpreqm.dspf +perpreqm.msgf: perpreqm.msgf +perpreqm.menu: perpreqm.msgf perpreqm.file | reqentr.pgm reqaprr.pgm # Top-level menu. Order-only on perpselr.pgm (called directly) and on the -# 4 child .menu targets (routed to via GO PERPDEMO/, not CALLed). +# 5 child .menu targets (routed to via GO PERPDEMO/, not CALLed). perpmnu.file: qddssrc/perpmnu.dspf perpmnu.msgf: perpmnu.msgf -perpmnu.menu: perpmnu.msgf perpmnu.file | perpselr.pgm perpsysm.menu perpinvm.menu perpvndm.menu perpdiag.menu +perpmnu.menu: perpmnu.msgf perpmnu.file | perpselr.pgm perpsysm.menu perpinvm.menu perpvndm.menu perpdiag.menu perpreqm.menu # --- CL setup ------------------------------------------------------------- diff --git a/perp/perp.bnddir b/perp/perp.bnddir index f34741b7..02527487 100644 --- a/perp/perp.bnddir +++ b/perp/perp.bnddir @@ -2,3 +2,4 @@ crtbnddir bnddir($LIBRARY/$NAME) addbnddire bnddir($LIBRARY/$NAME) obj(($LIBRARY/docseq *srvpgm *immed)) addbnddire bnddir($LIBRARY/$NAME) obj(($LIBRARY/itmvprcq *srvpgm *immed)) addbnddire bnddir($LIBRARY/$NAME) obj(($LIBRARY/whcoord *srvpgm *immed)) +addbnddire bnddir($LIBRARY/$NAME) obj(($LIBRARY/reqauto *srvpgm *immed)) diff --git a/perp/perpdiag.msgf b/perp/perpdiag.msgf index fe49ab18..41310016 100644 --- a/perp/perpdiag.msgf +++ b/perp/perpdiag.msgf @@ -2,3 +2,4 @@ crtmsgf msgf($LIBRARY/$NAME) addmsgd msgid(usr0001) msgf($LIBRARY/$NAME) msg('call docseqsmk parm(''ACM'' ''PO '')') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0002) msgf($LIBRARY/$NAME) msg('call ivprcqsmk parm(''ACM'' ''WIDGET1'')') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0003) msgf($LIBRARY/$NAME) msg('call whcoordsmk parm(''ACM'')') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0004) msgf($LIBRARY/$NAME) msg('call reqautosmk parm(''ACM'' ''3 '')') seclvl(*none) sev(00) fmt(*none) diff --git a/perp/perpmnu.msgf b/perp/perpmnu.msgf index 48042a92..79bd03a0 100644 --- a/perp/perpmnu.msgf +++ b/perp/perpmnu.msgf @@ -4,4 +4,5 @@ addmsgd msgid(usr0002) msgf($LIBRARY/$NAME) msg('go perpdemo/perpsysm') addmsgd msgid(usr0003) msgf($LIBRARY/$NAME) msg('go perpdemo/perpinvm') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0004) msgf($LIBRARY/$NAME) msg('go perpdemo/perpvndm') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0005) msgf($LIBRARY/$NAME) msg('go perpdemo/perpdiag') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0006) msgf($LIBRARY/$NAME) msg('go perpdemo/perpreqm') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0090) msgf($LIBRARY/$NAME) msg('signoff') seclvl(*none) sev(00) fmt(*none) diff --git a/perp/perpreqm.msgf b/perp/perpreqm.msgf new file mode 100644 index 00000000..be611595 --- /dev/null +++ b/perp/perpreqm.msgf @@ -0,0 +1,3 @@ +crtmsgf msgf($LIBRARY/$NAME) +addmsgd msgid(usr0001) msgf($LIBRARY/$NAME) msg('call reqentr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0002) msgf($LIBRARY/$NAME) msg('call reqaprr') seclvl(*none) sev(00) fmt(*none) diff --git a/perp/qddlsrc/requisition_header.table.sql b/perp/qddlsrc/requisition_header.table.sql new file mode 100644 index 00000000..b350bb80 --- /dev/null +++ b/perp/qddlsrc/requisition_header.table.sql @@ -0,0 +1,139 @@ +-- --------------------------------------------------------------------------- +-- Table: requisition_header (system name REQUI00001, auto-derived) +-- Module: perp +-- Purpose: Requisition header. Confidence score and full approval audit +-- (who/when/source/notes) are built in from day one so CoderFlow +-- auto-approval (PERP-36) has somewhere to write its verdict. +-- No back-pointer to PO here -- linkage lives on po_line (a later +-- epic) so one requisition line can be split/consolidated across +-- multiple POs. "Converted" status is derived by the PO epic +-- joining po_line back to this table's PK, not stored here. +-- Epic: PERP-6 (PERP-33) +-- --------------------------------------------------------------------------- + +-- 'requisition_header' (19 chars) exceeds the 10-char system-name cap, so +-- DB2 abbreviates unless we omit FOR SYSTEM NAME -- same approach as +-- item_vendor/item_vendor_price (DDL_STYLE_GUIDE.md Sec.2). Auto-derived to +-- REQUI00001 (sequential counter, confirmed via DSPOBJD after build -- +-- not a truncation of the SQL name, per the item_vendor_price precedent). +CREATE TABLE requisition_header ( + + -- Composite key (per-company) --------------------------------------------- + -- No requisition_display computed column here -- DDL_STYLE_GUIDE.md Sec.9's + -- GENERATED ALWAYS AS (expression) pattern does not build on this target + -- (confirmed PERP-33; see the style guide for the full finding). Any + -- display formatting happens in RPG/DSPF instead. + company_code FOR COLUMN COMPCD CHAR(3) NOT NULL, + requisition_number FOR COLUMN REQNBR BIGINT NOT NULL, + + -- Requester / dates --------------------------------------------------------- + requested_by FOR COLUMN REQBY CHAR(10) NOT NULL, + request_date FOR COLUMN REQDT DATE NOT NULL DEFAULT CURRENT_DATE, + need_by_date FOR COLUMN NEEDBY DATE NOT NULL, + + -- Priority (FK to code_master PRIORITY) ------------------------------------ + priority_code FOR COLUMN PRICD VARCHAR(20) NOT NULL DEFAULT 'NORMAL', + priority_type FOR COLUMN PRITYP VARCHAR(20) NOT NULL DEFAULT 'PRIORITY', + + -- Status (FK to code_master REQSTATUS) ------------------------------------- + status_code FOR COLUMN STCODE VARCHAR(20) NOT NULL DEFAULT 'DRAFT', + status_type FOR COLUMN STTYPE VARCHAR(20) NOT NULL DEFAULT 'REQSTATUS', + + -- Confidence -- NULL until CoderFlow scores it (PERP-36) ------------------- + confidence_pct FOR COLUMN CONFPCT DECIMAL(5,2), + + -- Approval audit -- all null until the requisition is approved/rejected. + -- approved_by is NOT FK'd to perp_user: an auto-approval stamps the + -- literal 'CODERFLOW', which is not a row in the human user directory. + approved_by FOR COLUMN APRBY VARCHAR(18), + approved_at FOR COLUMN APRAT TIMESTAMP, + approval_source_code FOR COLUMN APRSCD VARCHAR(20), + approval_source_type FOR COLUMN APRSTYP VARCHAR(20), + approval_notes FOR COLUMN APRNTS VARCHAR(500), + + -- Cost / currency ----------------------------------------------------------- + total_estimated_cost FOR COLUMN TOTEST DECIMAL(15,2) NOT NULL DEFAULT 0, + currency_code FOR COLUMN CURR VARCHAR(20) NOT NULL DEFAULT 'USD', + currency_type FOR COLUMN CURTYP VARCHAR(20) NOT NULL DEFAULT 'CURRENCY', + + -- Long-form justification. 'notes' (5 chars) is itself a valid system + -- name, so an explicit FOR COLUMN NOTES matching the auto-derivation + -- raises SQL0612 "duplicate column name" here (same root cause as the + -- SQL7029 case in DDL_STYLE_GUIDE.md Sec.2, different DB2 error) -- omit + -- the clause and let it auto-derive. ------------------------------------- + notes CLOB(16K), + + -- Standard audit block -------------------------------------------------- + created_at FOR COLUMN CRTAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + created_by FOR COLUMN CRTBY VARCHAR(18) NOT NULL DEFAULT USER, + updated_at FOR COLUMN UPDAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_by FOR COLUMN UPDBY VARCHAR(18) NOT NULL DEFAULT USER, + is_active FOR COLUMN ISACT CHAR(1) NOT NULL DEFAULT 'Y', + + -- Composite primary key --------------------------------------------------- + PRIMARY KEY (company_code, requisition_number), + + -- Constraints ----------------------------------------------------------- + CONSTRAINT reqhdr_isact_ck CHECK (is_active IN ('Y','N')), + CONSTRAINT reqhdr_prityp_ck CHECK (priority_type = 'PRIORITY'), + CONSTRAINT reqhdr_sttype_ck CHECK (status_type = 'REQSTATUS'), + CONSTRAINT reqhdr_curtyp_ck CHECK (currency_type = 'CURRENCY'), + CONSTRAINT reqhdr_totest_ck CHECK (total_estimated_cost >= 0), + CONSTRAINT reqhdr_confpct_ck CHECK (confidence_pct IS NULL + OR (confidence_pct BETWEEN 0 AND 100)), + CONSTRAINT reqhdr_aprstyp_ck CHECK (approval_source_type IS NULL + OR approval_source_type = 'APPRSRC'), + -- Approval audit is all-or-nothing -- either nothing has happened yet, or + -- who/when/source were all stamped together by the same operation. + CONSTRAINT reqhdr_aprall_ck CHECK ( + (approved_by IS NULL AND approved_at IS NULL AND approval_source_code IS NULL) + OR + (approved_by IS NOT NULL AND approved_at IS NOT NULL AND approval_source_code IS NOT NULL) + ), + + -- FKs ----------------------------------------------------------------------- + CONSTRAINT reqhdr_company_fk FOREIGN KEY (company_code) + REFERENCES company (company_code) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT reqhdr_reqby_fk FOREIGN KEY (requested_by) + REFERENCES perp_user (user_code) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT reqhdr_pri_fk FOREIGN KEY (priority_type, priority_code) + REFERENCES code_master (code_type, code_value) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT reqhdr_stat_fk FOREIGN KEY (status_type, status_code) + REFERENCES code_master (code_type, code_value) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT reqhdr_apr_fk FOREIGN KEY (approval_source_type, approval_source_code) + REFERENCES code_master (code_type, code_value) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT reqhdr_curr_fk FOREIGN KEY (currency_type, currency_code) + REFERENCES code_master (code_type, code_value) + ON DELETE RESTRICT ON UPDATE RESTRICT +); + +LABEL ON TABLE requisition_header IS + 'PERP requisition header (confidence + approval)'; + +LABEL ON COLUMN requisition_header ( + company_code IS 'Company code (FK to company)', + requisition_number IS 'Requisition number (doc_sequence REQ)', + requested_by IS 'Requester (FK to perp_user)', + request_date IS 'Date requisition was created', + need_by_date IS 'Date requisition is needed by', + priority_code IS 'Priority (FK to code_master)', + priority_type IS 'Priority type discriminator (constant)', + status_code IS 'Status (FK to code_master)', + status_type IS 'Status type discriminator (constant)', + confidence_pct IS 'CoderFlow confidence pct, null until scored', + approved_by IS 'Approver user code or CODERFLOW, null until approved', + approved_at IS 'Approval/rejection timestamp', + approval_source_code IS 'Approval source (FK to code_master)', + approval_source_type IS 'Approval source type discriminator (constant)', + approval_notes IS 'Approval/rejection explanation', + total_estimated_cost IS 'Sum of line est_unit_cost * quantity', + currency_code IS 'Currency (FK to code_master)', + currency_type IS 'Currency type discriminator (constant)', + notes IS 'Long-form justification', + is_active IS 'Active flag (Y/N, soft delete)' +); diff --git a/perp/qddlsrc/requisition_line.table.sql b/perp/qddlsrc/requisition_line.table.sql new file mode 100644 index 00000000..94b8508e --- /dev/null +++ b/perp/qddlsrc/requisition_line.table.sql @@ -0,0 +1,82 @@ +-- --------------------------------------------------------------------------- +-- Table: requisition_line (system name REQUI00002, auto-derived) +-- Module: perp +-- Purpose: Requisition line. No status column here -- a line is +-- considered "converted" once a later epic's po_line FKs back to +-- it; that is derived by joining po_line to this table's PK, not +-- stored redundantly on the line itself. +-- Epic: PERP-6 (PERP-33) +-- --------------------------------------------------------------------------- + +-- 'requisition_line' (17 chars) exceeds the 10-char system-name cap, so DB2 +-- abbreviates unless we omit FOR SYSTEM NAME -- same approach as +-- requisition_header above. Auto-derived to REQUI00002 (confirmed via +-- DSPOBJD after build). +CREATE TABLE requisition_line ( + + -- Composite key (per-company, per-requisition) ----------------------------- + company_code FOR COLUMN COMPCD CHAR(3) NOT NULL, + requisition_number FOR COLUMN REQNBR BIGINT NOT NULL, + line_number FOR COLUMN LINNBR INTEGER NOT NULL, + + -- Item / quantity ----------------------------------------------------------- + item_number FOR COLUMN ITMNBR VARCHAR(25) NOT NULL, + quantity FOR COLUMN QTY DECIMAL(15,4) NOT NULL DEFAULT 0, + uom_code FOR COLUMN UOMCD VARCHAR(5) NOT NULL, + + -- Estimated cost (defaulted from the preferred vendor price on entry, + -- but editable -- see PERP-34) ---------------------------------------------- + est_unit_cost FOR COLUMN ESTCST DECIMAL(15,4) NOT NULL DEFAULT 0, + + -- Optional per-line override of the header's need_by_date; null means + -- "use the header date" -------------------------------------------------- + need_by_date FOR COLUMN NEEDBY DATE, + + -- 'notes' (5 chars) is itself a valid system name -- explicit FOR COLUMN + -- NOTES raises SQL0612 "duplicate column name" (see requisition_header + -- for the same finding); omit the clause and let it auto-derive. + notes VARCHAR(240) NOT NULL DEFAULT '', + + -- Standard audit block -------------------------------------------------- + created_at FOR COLUMN CRTAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + created_by FOR COLUMN CRTBY VARCHAR(18) NOT NULL DEFAULT USER, + updated_at FOR COLUMN UPDAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_by FOR COLUMN UPDBY VARCHAR(18) NOT NULL DEFAULT USER, + is_active FOR COLUMN ISACT CHAR(1) NOT NULL DEFAULT 'Y', + + -- Composite primary key --------------------------------------------------- + PRIMARY KEY (company_code, requisition_number, line_number), + + -- Constraints ----------------------------------------------------------- + CONSTRAINT reqln_isact_ck CHECK (is_active IN ('Y','N')), + CONSTRAINT reqln_linnbr_ck CHECK (line_number > 0), + CONSTRAINT reqln_qty_ck CHECK (quantity > 0), + CONSTRAINT reqln_estcst_ck CHECK (est_unit_cost >= 0), + + -- FKs ----------------------------------------------------------------------- + CONSTRAINT reqln_hdr_fk FOREIGN KEY (company_code, requisition_number) + REFERENCES requisition_header (company_code, requisition_number) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT reqln_item_fk FOREIGN KEY (company_code, item_number) + REFERENCES item (company_code, item_number) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT reqln_uom_fk FOREIGN KEY (uom_code) + REFERENCES uom (uom_code) + ON DELETE RESTRICT ON UPDATE RESTRICT +); + +LABEL ON TABLE requisition_line IS + 'PERP requisition line'; + +LABEL ON COLUMN requisition_line ( + company_code IS 'Company code (FK to requisition_header)', + requisition_number IS 'Requisition number (FK to requisition_header)', + line_number IS 'Line number within requisition (PK)', + item_number IS 'Item number (FK to item)', + quantity IS 'Requested quantity', + uom_code IS 'Unit of measure (FK to uom)', + est_unit_cost IS 'Estimated unit cost', + need_by_date IS 'Line need-by override, null = use header date', + notes IS 'Line notes', + is_active IS 'Active flag (Y/N, soft delete)' +); diff --git a/perp/qddlsrc/seed/025_approval_thresholds.sql b/perp/qddlsrc/seed/025_approval_thresholds.sql new file mode 100644 index 00000000..23cf7fc0 --- /dev/null +++ b/perp/qddlsrc/seed/025_approval_thresholds.sql @@ -0,0 +1,28 @@ +-- --------------------------------------------------------------------------- +-- Seed: 025_approval_thresholds +-- Module: perp +-- Purpose: Populate company_config with the auto-approval thresholds +-- reqauto (PERP-36) reads: a minimum confidence_pct and a maximum +-- total_estimated_cost. Both must pass for auto-approval. +-- Idempotent -- DELETE by config_key first, then INSERT. +-- +-- Numbered 025 (not 030) to leave 030 free for PERP-9's planned +-- 030_items.sql (see the ACME Seed Dataset Spec Confluence page, +-- 2512060417) -- these two seed scripts were written independently +-- and would otherwise collide. Key names here +-- (approval.auto_threshold / approval.auto_max_amount) also differ +-- from that page's originally-planned auto_approve_threshold_pct / +-- auto_approve_max_amount; reconciled on the spec page rather than +-- silently diverging -- see that page for the full note. +-- Epic: PERP-6 (PERP-36) +-- --------------------------------------------------------------------------- + +DELETE FROM company_config + WHERE config_key IN ('approval.auto_threshold', 'approval.auto_max_amount'); + +INSERT INTO company_config + (company_code, config_key, config_value, description) VALUES + ('ACM', 'approval.auto_threshold', '85', 'Min confidence_pct for CoderFlow auto-approval'), + ('ACM', 'approval.auto_max_amount', '500.00', 'Max total_estimated_cost for CoderFlow auto-approval'), + ('BET', 'approval.auto_threshold', '85', 'Min confidence_pct for CoderFlow auto-approval'), + ('BET', 'approval.auto_max_amount', '500.00', 'Max total_estimated_cost for CoderFlow auto-approval'); diff --git a/perp/qddssrc/perpdiag.dspf b/perp/qddssrc/perpdiag.dspf index 72c7fe95..a71a3880 100644 --- a/perp/qddssrc/perpdiag.dspf +++ b/perp/qddssrc/perpdiag.dspf @@ -26,6 +26,8 @@ A ice' A 7 7'3. Smoke test warehouse coordina- A te service' + A 8 7'4. Smoke test CoderFlow auto-app- + A roval hook' A 23 2'F3=Exit' A COLOR(BLU) A* CMDPROMPT Do not delete this DDS spec. diff --git a/perp/qddssrc/perpmnu.dspf b/perp/qddssrc/perpmnu.dspf index 2c3fbade..e77c21c9 100644 --- a/perp/qddssrc/perpmnu.dspf +++ b/perp/qddssrc/perpmnu.dspf @@ -25,6 +25,7 @@ A 7 7'3. Inventory Master Data' A 8 7'4. Vendor & Pricing' A 9 7'5. Diagnostics / Smoke Tests' + A 10 7'6. Requisitioning' A 12 6'90. Sign off' A 23 2'F3=Exit' A COLOR(BLU) diff --git a/perp/qddssrc/perpreqm.dspf b/perp/qddssrc/perpreqm.dspf new file mode 100644 index 00000000..9050272b --- /dev/null +++ b/perp/qddssrc/perpreqm.dspf @@ -0,0 +1,29 @@ + A* PERPREQM menu + A DSPSIZ(24 80 *DS3) + A CHGINPDFT + A INDARA + A PRINT(*LIBL/QSYSPRT) + A* CRTMNU TYPE(*DSPF) requires a record format named PERPREQM + A R PERPREQM + A LOCK + A SLNO(01) + A CLRL(*ALL) + A ALWROL + A CF03 + A HELP + A HOME + A HLPRTN + A 1 2'PERPREQM' + A COLOR(BLU) + A 1 25'PERP - Requisitioning' + A DSPATR(HI) + A COLOR(WHT) + A 3 2'Select one of the following:' + A COLOR(BLU) + A 5 7'1. Enter/submit requisitions' + A 6 7'2. Approve/reject requisitions' + A 23 2'F3=Exit' + A COLOR(BLU) + A* CMDPROMPT Do not delete this DDS spec. + A 021 2'Selection: - + A ' diff --git a/perp/qddssrc/reqaprd.dspf b/perp/qddssrc/reqaprd.dspf new file mode 100644 index 00000000..e3a1504a --- /dev/null +++ b/perp/qddssrc/reqaprd.dspf @@ -0,0 +1,117 @@ + A DSPSIZ(24 80 *DS3) + A PRINT + A CA03(03 'Exit') + A CA05(05 'Refresh') + A CA06(06 'Approve') + A CA07(07 'Reject') + A CA12(12 'Cancel') + A R ASFL SFL + A 51 SFLNXTCHG + A ASOPT 1A B 9 2 + A 50 DSPATR(RI) + A 50 DSPATR(PC) + A ASREQNBR 8A O 9 5 + A ASREQBY 10A O 9 14 + A ASNEEDBY L O 9 25DATFMT(*ISO) + A ASPRICD 10A O 9 36 + A ASTOTEST 15Y 2O 9 47EDTCDE(3) + A ASCONF 8A O 9 65 + A R ASCTL SFLCTL(ASFL) + A SFLSIZ(0099) + A SFLPAG(0007) + A OVERLAY + A SFLDSPCTL + A N31 30 SFLDSP + A 31 SFLCLR + A N31 30 SFLEND(*MORE) + A 1 24'Requisitions Awaiting Approval' + A DSPATR(HI) + A 2 2'Company:' + A LCOMPDSP 3A O 2 11 + A 6 2'Type option 5=Review, press Enter.' + A 8 2'Opt' + A DSPATR(UL) + A 8 5'Req #' + A DSPATR(UL) + A 8 14'Requested By' + A DSPATR(UL) + A 8 25'Need By' + A DSPATR(UL) + A 8 36'Priority' + A DSPATR(UL) + A 8 47'Est Cost' + A DSPATR(UL) + A 8 65'Confid.' + A DSPATR(UL) + A R RLFOOT + A OVERLAY + A 23 2'F3=Exit F5=Refresh F12=Cancel' + A COLOR(BLU) + A R RNOSUB + A OVERLAY + A 11 24'No requisitions to review.' + A R RDETAIL + A OVERLAY + A 1 28'Requisition Detail' + A DSPATR(HI) + A 2 2'Req #:' + A DDREQNBR 8A O 2 9 + A 2 30'Requested By:' + A DDREQBY 10A O 2 44 + A 3 2'Need By:' + A DDNEEDBY L O 3 11DATFMT(*ISO) + A 3 30'Priority:' + A DDPRICD 20A O 3 40 + A 4 2'Total Est Cost:' + A DDTOTEST 15Y 2O 4 18EDTCDE(3) + A 4 40'Confidence:' + A DDCONF 10A O 4 52 + A 6 2'Lines:' + A 7 2'Item' + A DSPATR(UL) + A 7 29'Qty' + A DSPATR(UL) + A 7 47'UOM' + A DSPATR(UL) + A 7 54'Cost' + A DSPATR(UL) + A 60 L1ITEM 25A O 8 2 + A 60 L1QTY 15Y 4O 8 29EDTCDE(3) + A 60 L1UOM 5A O 8 47 + A 60 L1COST 15Y 4O 8 54EDTCDE(3) + A 61 L2ITEM 25A O 9 2 + A 61 L2QTY 15Y 4O 9 29EDTCDE(3) + A 61 L2UOM 5A O 9 47 + A 61 L2COST 15Y 4O 9 54EDTCDE(3) + A 62 L3ITEM 25A O 10 2 + A 62 L3QTY 15Y 4O 10 29EDTCDE(3) + A 62 L3UOM 5A O 10 47 + A 62 L3COST 15Y 4O 10 54EDTCDE(3) + A 63 L4ITEM 25A O 11 2 + A 63 L4QTY 15Y 4O 11 29EDTCDE(3) + A 63 L4UOM 5A O 11 47 + A 63 L4COST 15Y 4O 11 54EDTCDE(3) + A 64 L5ITEM 25A O 12 2 + A 64 L5QTY 15Y 4O 12 29EDTCDE(3) + A 64 L5UOM 5A O 12 47 + A 64 L5COST 15Y 4O 12 54EDTCDE(3) + A 65 L6ITEM 25A O 13 2 + A 65 L6QTY 15Y 4O 13 29EDTCDE(3) + A 65 L6UOM 5A O 13 47 + A 65 L6COST 15Y 4O 13 54EDTCDE(3) + A 34 15 2'More lines exist -- not all shown.' + A 17 2'Approval Notes:' + A ENOTES2 50A B 17 18 + A 23 2'F6=Approve F7=Reject F12=Back' + A COLOR(BLU) + A R RMSGSFL SFL + A SFLMSGRCD(24) + A SMSGKEY SFLMSGKEY + A SPGMQ SFLPGMQ(10) + A R RMSGCTL SFLCTL(RMSGSFL) + A OVERLAY + A N41 40 SFLDSP + A 41 SFLCLR + A N41 40 SFLEND + A SFLSIZ(0002) + A SFLPAG(0001) diff --git a/perp/qddssrc/reqentd.dspf b/perp/qddssrc/reqentd.dspf new file mode 100644 index 00000000..24778eb9 --- /dev/null +++ b/perp/qddssrc/reqentd.dspf @@ -0,0 +1,108 @@ + A DSPSIZ(24 80 *DS3) + A PRINT + A CA03(03 'Exit') + A CA05(05 'Refresh') + A CA06(06 'Add') + A CA08(08 'Submit') + A CA12(12 'Cancel') + A R RHEAD + A OVERLAY + A 1 30'Requisition Entry' + A DSPATR(HI) + A 2 2'Company:' + A HCOMPDSP 3A O 2 11 + A 3 2'Requested By:' + A HREQBY 10A B 3 16 + A 4 2'Need By Date:' + A HNEEDBY L B 4 16DATFMT(*ISO) + A 4 28'(YYYY-MM-DD)' + A 5 2'Priority:' + A HPRICD 20A B 5 12 + A 5 34'(LOW/NORMAL/HIGH/CRITICAL)' + A 6 2'Notes:' + A HNOTES 50A B 6 9 + A 23 2'F3=Exit F12=Cancel' + A COLOR(BLU) + A R RLSFL SFL + A 51 SFLNXTCHG + A SLOPT 1A B 9 2 + A 50 DSPATR(RI) + A 50 DSPATR(PC) + A SLLINE 3Y 0O 9 5 + A SLITEM 25A O 9 10 + A SLQTY 15Y 4O 9 36EDTCDE(3) + A SLUOM 5A O 9 54 + A SLCOST 15Y 4O 9 61EDTCDE(3) + A R RLCTL SFLCTL(RLSFL) + A SFLSIZ(0099) + A SFLPAG(0007) + A OVERLAY + A SFLDSPCTL + A N31 30 SFLDSP + A 31 SFLCLR + A N31 30 SFLEND(*MORE) + A 1 30'Requisition Lines' + A DSPATR(HI) + A 2 2'Req #:' + A DREQNBR 15A O 2 9 + A 2 40'Requested By:' + A DREQBY 10A O 2 54 + A 3 2'Need By:' + A DNEEDBY L O 3 11DATFMT(*ISO) + A 3 40'Priority:' + A DPRICD 20A O 3 50 + A 4 2'Status:' + A DSTATUS 20A O 4 10 + A 4 40'Total Est Cost:' + A DTOTEST 15Y 2O 4 56EDTCDE(3) + A 6 2'Type option, press Enter.' + A 7 4'2=Change 4=Delete' + A 8 2'Opt' + A DSPATR(UL) + A 8 5'Line' + A DSPATR(UL) + A 8 10'Item' + A DSPATR(UL) + A 8 36'Qty' + A DSPATR(UL) + A 8 54'UOM' + A DSPATR(UL) + A 8 61'Cost' + A DSPATR(UL) + A R RLFOOT + A OVERLAY + A 23 2'F3=Exit F5=Refresh F6=Add F8=Su- + A bmit F12=Cancel' + A COLOR(BLU) + A R RNOLIN + A OVERLAY + A 11 20'No lines yet. Press F6=Add.' + A R RLEDIT + A OVERLAY + A 1 25'Add/Change Requisition Line' + A DSPATR(HI) + A 2 2'Mode:' + A EMODE 1A O 2 8 + A 3 2'Item Number:' + A EITEM 25A B 3 15 + A 4 2'Quantity:' + A EQTY 15Y 4B 4 12EDTCDE(3) + A 5 2'UOM:' + A EUOM 5A B 5 7 + A 5 15'(blank = default from item)' + A 6 2'Est Unit Cost:' + A ECOST 15Y 4B 6 17EDTCDE(3) + A 6 34'(0 = default from vendor)' + A 23 2'Enter=Save F12=Cancel' + A COLOR(BLU) + A R RMSGSFL SFL + A SFLMSGRCD(24) + A SMSGKEY SFLMSGKEY + A SPGMQ SFLPGMQ(10) + A R RMSGCTL SFLCTL(RMSGSFL) + A OVERLAY + A N41 40 SFLDSP + A 41 SFLCLR + A N41 40 SFLEND + A SFLSIZ(0002) + A SFLPAG(0001) diff --git a/perp/qrpglesrc/reqaprr.sqlrpgle b/perp/qrpglesrc/reqaprr.sqlrpgle new file mode 100644 index 00000000..bbc353e4 --- /dev/null +++ b/perp/qrpglesrc/reqaprr.sqlrpgle @@ -0,0 +1,441 @@ +**free + +// --------------------------------------------------------------------- +// Program: reqaprr (Requisition Approval) +// Purpose: Lists SUBMITTED requisitions for the selected company +// (*LDA positions 1-3, via perpselr). Selecting a row (option +// 5=Review) shows a detail screen (header summary + up to 6 +// lines as plain fields + a confidence_pct badge) with +// Approve/Reject actions. Both actions stamp approved_by (job +// USER), approved_at, approval_source=HUMAN, and the entered +// approval_notes; the requisition leaves the SUBMITTED list +// either way. +// +// The detail screen is a single plain (non-subfile) record in +// this SAME program/file, showing up to 6 lines as +// individually-named fields, each conditioned on its own +// indicator (*in60..*in65) so an unused row is genuinely +// blank rather than displaying "0.0000". +// +// This design exists after extensive, reproducible live +// testing on this specific environment (Profound UI Genie, +// "classic" skin) ruled out a second business subfile in this +// program: +// 1. ASFL (list) + ALSFL/ALCTL (review-detail) in one +// reqaprd.dspf, entered via EXFMT ALCTL from inside the +// "5=Review" handler -- crashed with RNX1255 at EXFMT +// ALCTL, "Session or device error occurred in file +// REQAPRD". +// 2. The same design with the format switch deferred past +// the driving READC loop -- crashed identically. +// 3. Splitting the detail screen into a separate called +// program (reqapdtl) with its own device file, the same +// pattern wrkitmr uses calling wrkcnvr/wrklotr -- also +// crashed, cascading across both files. +// 4. The same two-subfile design again, this time with +// OVERLAY added everywhere (a real and independently +// confirmed DDS rule -- missing OVERLAY on a WRITE-only +// footer really can cause exactly this class of error) +// and separate SFLCLR/SFLDSP indicators matching ASFL's +// own proven-safe pattern exactly -- STILL crashed at +// the identical EXFMT ALCTL statement, confirmed via a +// genuine native-session retest (not a stale load). +// Every one of those is textbook-correct RPG/DDS and matches +// patterns already used successfully elsewhere in this +// module (or, for #3, in wrkitmr) -- yet all four crash +// identically and reproducibly on this environment, while +// this plain-fields design is the ONLY one confirmed to +// render without crashing. Treat that as an environment- +// specific limitation of this particular setup (possibly the +// Genie web-based 5250 renderer, not the RPG/DDS itself, +// though the exact reason remains unconfirmed), not a +// contradiction of standard subfile practice -- and don't +// re-attempt a second business subfile in this program +// without a real interactive test proving it actually works +// here first. +// Epic: PERP-6 (PERP-35, redesigned four times as a runtime-crash +// fix; see DDL_STYLE_GUIDE.md Sec.14 for the full history) +// --------------------------------------------------------------------- + +ctl-opt dftactgrp(*no) actgrp(*new); + +dcl-f reqaprd workstn sfile(asfl:rrn) sfile(rmsgsfl:msgrrn); + +dcl-ds ldaDS dtaara(*lda) len(1024) qualified; + compcd char(3) pos(1); +end-ds; + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-ds statusDS psds qualified; + programName char(10) pos(334); +end-ds; + +dcl-ds reqRow qualified; + reqnbr int(20); + reqby varchar(10); + needby date; + pricd varchar(20); + totest packed(15:2); + conf varchar(8); +end-ds; + +dcl-ds lineRow2 qualified; + item varchar(25); + qty packed(15:4); + uom varchar(5); + cost packed(15:4); +end-ds; + +dcl-c MAXDTLLINES 6; + +dcl-ds reqs likeds(reqRow) dim(500); +dcl-ds detailLines likeds(lineRow2) dim(500); + +dcl-s numReqs int(10); +dcl-s numLines int(10); +dcl-s i int(10); +dcl-s rrn int(10); +dcl-s msgrrn int(10); +dcl-s selRrn int(10); +dcl-s reviewRrn int(10); +dcl-s selOpt char(1); +dcl-s compcd char(3); +dcl-s selReqnbr int(20); +dcl-s confPct packed(5:2); +dcl-s confInd int(5); + +in ldaDS; +compcd = ldaDS.compcd; + +if compcd = ''; + exsr clearMsgs; + writeMsg('No company selected - run Select Company (PERPSELR) first.'); + *in40 = *on; + write rmsgctl; + lcompdsp = ''; + write rlfoot; + exfmt asctl; + *inlr = *on; + return; +endif; + +lcompdsp = compcd; + +dow '1'; + exsr clearMsgs; + exsr loadReqs; + + if numReqs = 0; + *in30 = *off; + write rnosub; + else; + exsr fillList; + *in30 = *on; + endif; + + write rlfoot; + *in40 = *off; + if msgrrn > 0; + *in40 = *on; + endif; + write rmsgctl; + exfmt asctl; + + if *in03 or *in12; + leave; + endif; + + if *in05; + iter; + endif; + + // Fully drain the READC loop before switching to the detail record -- + // matches perpselr.sqlrpgle's "collect then act" pattern for one + // action per Enter. + if numReqs > 0; + selRrn = 0; + selOpt = ' '; + reviewRrn = 0; + readc asfl; + dow not %eof(reqaprd); + if asopt <> ''; + selRrn = rrn; + selOpt = asopt; + if selOpt = '5'; + if reviewRrn = 0; + reviewRrn = selRrn; + else; + writeMsg('Only one requisition may be reviewed per Enter.'); + endif; + else; + writeMsg('Option ' + selOpt + ' not valid - use 5.'); + endif; + selRrn = 0; + endif; + readc asfl; + enddo; + + if reviewRrn > 0 and msgrrn = 0; + selReqnbr = reqs(reviewRrn).reqnbr; + exsr reviewReq; + endif; + endif; + +enddo; + +*inlr = *on; +return; + +// --------------------------------------------------------------------- +begsr loadReqs; + numReqs = 0; + exec sql declare c1 cursor for + select requisition_number, requested_by, need_by_date, priority_code, + total_estimated_cost, confidence_pct + from perpdemo.requisition_header + where company_code = :compcd and status_code = 'SUBMITTED' + order by requisition_number; + exec sql open c1; + if sqlcode < 0; + writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); + return; + endif; + + dow numReqs < %elem(reqs); + exec sql fetch c1 into :reqRow.reqnbr, :reqRow.reqby, :reqRow.needby, + :reqRow.pricd, :reqRow.totest, + :confPct :confInd; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + if confInd < 0; + reqRow.conf = 'N/A'; + else; + reqRow.conf = %char(confPct) + '%'; + endif; + numReqs += 1; + reqs(numReqs) = reqRow; + enddo; + exec sql close c1; +endsr; + +// --------------------------------------------------------------------- +begsr fillList; + rrn = 0; + *in31 = *on; + write asctl; + *in31 = *off; + for i = 1 to numReqs; + asopt = ''; + asreqnbr = %char(reqs(i).reqnbr); + asreqby = reqs(i).reqby; + asneedby = reqs(i).needby; + aspricd = reqs(i).pricd; + astotest = reqs(i).totest; + asconf = reqs(i).conf; + rrn += 1; + write asfl; + endfor; +endsr; + +// --------------------------------------------------------------------- +begsr reviewReq; + ddreqnbr = %char(selReqnbr); + ddreqby = reqs(reviewRrn).reqby; + ddneedby = reqs(reviewRrn).needby; + ddpricd = reqs(reviewRrn).pricd; + ddtotest = reqs(reviewRrn).totest; + ddconf = reqs(reviewRrn).conf; + enotes2 = ''; + + exsr loadLines2; + exsr fillDetailLines; + + dow '1'; + exsr clearMsgs; + if msgrrn > 0; + *in40 = *on; + else; + *in40 = *off; + endif; + write rmsgctl; + exfmt rdetail; + + if *in12; + return; + endif; + + if *in06; + exec sql + update perpdemo.requisition_header + set status_code = 'APPROVED', + approved_by = user, + approved_at = current_timestamp, + approval_source_code = 'HUMAN', + approval_source_type = 'APPRSRC', + approval_notes = :enotes2, + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd and requisition_number = :selReqnbr; + if sqlcode < 0; + writeMsg('Approve failed: SQLCODE=' + %char(sqlcode)); + iter; + endif; + writeMsg('Requisition ' + %trim(ddreqnbr) + ' approved.'); + return; + endif; + + if *in07; + exec sql + update perpdemo.requisition_header + set status_code = 'REJECTED', + approved_by = user, + approved_at = current_timestamp, + approval_source_code = 'HUMAN', + approval_source_type = 'APPRSRC', + approval_notes = :enotes2, + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd and requisition_number = :selReqnbr; + if sqlcode < 0; + writeMsg('Reject failed: SQLCODE=' + %char(sqlcode)); + iter; + endif; + writeMsg('Requisition ' + %trim(ddreqnbr) + ' rejected.'); + return; + endif; + + iter; + enddo; +endsr; + +// --------------------------------------------------------------------- +begsr loadLines2; + numLines = 0; + exec sql declare c2 cursor for + select item_number, quantity, uom_code, est_unit_cost + from perpdemo.requisition_line + where company_code = :compcd and requisition_number = :selReqnbr + order by line_number; + exec sql open c2; + if sqlcode < 0; + writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); + return; + endif; + + dow numLines < %elem(detailLines); + exec sql fetch c2 into :lineRow2; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + numLines += 1; + detailLines(numLines) = lineRow2; + enddo; + exec sql close c2; +endsr; + +// --------------------------------------------------------------------- +// Fills the fixed L1..L6 (item/qty/uom/cost) plain fields on RDETAIL from +// detailLines(). Each row's 4 fields are conditioned in the DDS on its +// own indicator (*in60..*in65) so an unused row is truly blank on screen +// -- not just zeroed-out numerics, which display as "0.0000" per +// EDTCDE(3) and read as confusing garbage data rather than "no line +// here." Also turns on *in34 (conditions the "more lines exist" message) +// when numLines exceeds what the screen can show. +begsr fillDetailLines; + if numLines > MAXDTLLINES; + *in34 = *on; + else; + *in34 = *off; + endif; + + *in60 = (numLines >= 1); + *in61 = (numLines >= 2); + *in62 = (numLines >= 3); + *in63 = (numLines >= 4); + *in64 = (numLines >= 5); + *in65 = (numLines >= 6); + + if numLines >= 1; + l1item = detailLines(1).item; + l1qty = detailLines(1).qty; + l1uom = detailLines(1).uom; + l1cost = detailLines(1).cost; + endif; + + if numLines >= 2; + l2item = detailLines(2).item; + l2qty = detailLines(2).qty; + l2uom = detailLines(2).uom; + l2cost = detailLines(2).cost; + endif; + + if numLines >= 3; + l3item = detailLines(3).item; + l3qty = detailLines(3).qty; + l3uom = detailLines(3).uom; + l3cost = detailLines(3).cost; + endif; + + if numLines >= 4; + l4item = detailLines(4).item; + l4qty = detailLines(4).qty; + l4uom = detailLines(4).uom; + l4cost = detailLines(4).cost; + endif; + + if numLines >= 5; + l5item = detailLines(5).item; + l5qty = detailLines(5).qty; + l5uom = detailLines(5).uom; + l5cost = detailLines(5).cost; + endif; + + if numLines >= 6; + l6item = detailLines(6).item; + l6qty = detailLines(6).qty; + l6uom = detailLines(6).uom; + l6cost = detailLines(6).cost; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr clearMsgs; + msgrrn = 0; + *in41 = *on; + write rmsgctl; + *in41 = *off; +endsr; + +// --------------------------------------------------------------------- +dcl-proc writeMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + smsgkey : + x'0000000000000000'); + msgrrn += 1; + spgmq = statusDS.programName; + write rmsgsfl; +end-proc; diff --git a/perp/qrpglesrc/reqauto.sqlrpgle b/perp/qrpglesrc/reqauto.sqlrpgle new file mode 100644 index 00000000..342e4dee --- /dev/null +++ b/perp/qrpglesrc/reqauto.sqlrpgle @@ -0,0 +1,154 @@ +**free + +// --------------------------------------------------------------------- +// Module: reqauto (CoderFlow auto-approval hook) +// Purpose: See reqauto_pr.rpgle for the exported procedure contracts. +// Callers commit/rollback the unit-of-work; this module never +// issues COMMIT/ROLLBACK (DDL_STYLE_GUIDE.md Sec.13). +// Epic: PERP-6 (PERP-36) +// --------------------------------------------------------------------- + +ctl-opt nomain; + +exec sql set option closqlcsr = *endmod; + +/copy reqauto_pr.rpgle + +// --------------------------------------------------------------------- +// Host-variable naming: prefixed per subprocedure (sc_/ev_) so the +// SQLRPGLE precompiler's module-wide (not subprocedure-scoped) host +// variable collection doesn't raise SQL0314 (DDL_STYLE_GUIDE.md Sec.13). +// --------------------------------------------------------------------- + +// reqauto_score — no-op placeholder scorer (see prototype for contract). +dcl-proc reqauto_score export; + dcl-pi *n packed(5:2); + sc_company char(3) const; + sc_reqnbr int(20) const; + sc_errmsg varchar(80); + end-pi; + + dcl-s sc_cnt int(10); + + sc_errmsg = ''; + + exec sql + select count(*) into :sc_cnt + from perpdemo.requisition_header + where company_code = :sc_company and requisition_number = :sc_reqnbr; + if sc_cnt = 0; + sc_errmsg = 'reqauto_score: requisition not found'; + return -1; + endif; + + // Placeholder score. Not a function of the requisition's content -- + // a real CoderFlow scoring call will replace this body. Chosen high + // enough to clear the demo's default 85% threshold so the happy path + // is exercisable end-to-end before real scoring exists. + return 92.50; + +end-proc; + +// reqauto_evaluate — score + conditionally auto-approve (see prototype). +dcl-proc reqauto_evaluate export; + dcl-pi *n int(10); + ev_company char(3) const; + ev_reqnbr int(20) const; + ev_errmsg varchar(80); + end-pi; + + dcl-s ev_status varchar(20); + dcl-s ev_total packed(15:2); + dcl-s ev_conf packed(5:2); + dcl-s ev_thresh packed(5:2); + dcl-s ev_maxamt packed(15:2); + dcl-s ev_thrTxt varchar(256); + dcl-s ev_maxTxt varchar(256); + dcl-s ev_notes varchar(500); + + ev_errmsg = ''; + + exec sql + select status_code, total_estimated_cost + into :ev_status, :ev_total + from perpdemo.requisition_header + where company_code = :ev_company and requisition_number = :ev_reqnbr; + if sqlcode <> 0; + ev_errmsg = 'reqauto_evaluate: requisition not found'; + return -1; + endif; + + if ev_status <> 'SUBMITTED'; + ev_errmsg = 'reqauto_evaluate: status is ' + %trim(ev_status) + + ', expected SUBMITTED'; + return -1; + endif; + + ev_conf = reqauto_score(ev_company : ev_reqnbr : ev_errmsg); + if ev_conf < 0; + return -1; + endif; + + exec sql + update perpdemo.requisition_header + set confidence_pct = :ev_conf, + updated_at = current_timestamp, + updated_by = user + where company_code = :ev_company and requisition_number = :ev_reqnbr; + if sqlcode < 0; + ev_errmsg = 'reqauto_evaluate: confidence_pct update failed SQLCODE=' + + %char(sqlcode); + return -1; + endif; + + exec sql + select config_value into :ev_thrTxt + from perpdemo.company_config + where company_code = :ev_company + and config_key = 'approval.auto_threshold'; + if sqlcode <> 0; + ev_errmsg = 'reqauto_evaluate: approval.auto_threshold not configured'; + return -1; + endif; + + exec sql + select config_value into :ev_maxTxt + from perpdemo.company_config + where company_code = :ev_company + and config_key = 'approval.auto_max_amount'; + if sqlcode <> 0; + ev_errmsg = 'reqauto_evaluate: approval.auto_max_amount not configured'; + return -1; + endif; + + ev_thresh = %dec(%trim(ev_thrTxt) : 5 : 2); + ev_maxamt = %dec(%trim(ev_maxTxt) : 15 : 2); + + if ev_conf >= ev_thresh and ev_total <= ev_maxamt; + // Placeholder explanation -- a real confidence rationale string + // will come from CoderFlow once real scoring lands. + ev_notes = 'Auto-approved by CoderFlow: confidence ' + %char(ev_conf) + + '% >= threshold ' + %char(ev_thresh) + '%, total ' + + %char(ev_total) + ' <= max ' + %char(ev_maxamt) + '.'; + exec sql + update perpdemo.requisition_header + set status_code = 'APPROVED', + approved_by = 'CODERFLOW', + approved_at = current_timestamp, + approval_source_code = 'CODERFLOW', + approval_source_type = 'APPRSRC', + approval_notes = :ev_notes, + updated_at = current_timestamp, + updated_by = user + where company_code = :ev_company and requisition_number = :ev_reqnbr; + if sqlcode < 0; + ev_errmsg = 'reqauto_evaluate: auto-approve update failed SQLCODE=' + + %char(sqlcode); + return -1; + endif; + return 1; + endif; + + return 0; + +end-proc; diff --git a/perp/qrpglesrc/reqauto_pr.rpgle b/perp/qrpglesrc/reqauto_pr.rpgle new file mode 100644 index 00000000..b36bd891 --- /dev/null +++ b/perp/qrpglesrc/reqauto_pr.rpgle @@ -0,0 +1,40 @@ +**free + +// --------------------------------------------------------------------- +// Prototypes: reqauto (CoderFlow auto-approval hook) +// Module: perp +// Purpose: Integration point for CoderFlow. Scores a submitted +// requisition and auto-approves it when the score and +// total both pass the company's configured thresholds. +// Epic: PERP-6 (PERP-36) +// --------------------------------------------------------------------- + +// reqauto_score — no-op placeholder scorer. Returns a fixed confidence_pct +// (0-100) for the given requisition. Today this is a stand-in for the +// real CoderFlow scoring call that will replace it; it does not inspect +// the requisition's content. Returns -1 and fills errmsg if the +// requisition is not found. +dcl-pr reqauto_score packed(5:2); + company char(3) const; + reqnbr int(20) const; + errmsg varchar(80); +end-pr; + +// reqauto_evaluate — score a requisition and auto-approve it if the score +// exceeds company_config('approval.auto_threshold') AND +// total_estimated_cost is under company_config('approval.auto_max_amount'). +// Always writes confidence_pct back to the requisition, whether or not +// it clears the bar. On auto-approval, stamps approved_by='CODERFLOW', +// approved_at=now, approval_source_code='CODERFLOW', and a placeholder +// approval_notes explanation (a real explanation string will come from +// CoderFlow later). +// +// Returns: 1 = auto-approved +// 0 = scored but not auto-approved (stays SUBMITTED) +// -1 = error (requisition not found, missing config, or a +// non-DRAFT/SUBMITTED status); errmsg is filled +dcl-pr reqauto_evaluate int(10); + company char(3) const; + reqnbr int(20) const; + errmsg varchar(80); +end-pr; diff --git a/perp/qrpglesrc/reqautosmk.sqlrpgle b/perp/qrpglesrc/reqautosmk.sqlrpgle new file mode 100644 index 00000000..9bf5f900 --- /dev/null +++ b/perp/qrpglesrc/reqautosmk.sqlrpgle @@ -0,0 +1,77 @@ +**free + +// --------------------------------------------------------------------- +// Program: reqautosmk (reqauto smoke test) +// Purpose: One-shot caller that exercises reqauto_evaluate against a +// real requisition so a joblog + interactive session confirms +// the service program is bound correctly. +// Meant to be CALLed once from an interactive session: +// CALL PGM(PERPDEMO/REQAUTOSMK) PARM('ACM' '3 ') +// (requisition 3 must exist and be status SUBMITTED). The +// requisition number parameter is CHAR(8), not numeric -- raw +// CALL/PARM (no *CMD definition, no RPG prototype on the +// caller's side) sends exactly the literal's own length with +// no padding to the receiver's declared size, so the literal +// MUST be padded to exactly 8 characters (trailing blanks) or +// the receiver reads past the passed argument (RNX0105 at +// runtime, confirmed PERP-36 -- an unquoted numeric literal or +// an unpadded quoted one both corrupt the value silently/ +// fatally rather than raising a friendly error). +// Epic: PERP-6 (PERP-36) +// --------------------------------------------------------------------- + +ctl-opt dftactgrp(*no) actgrp(*new) bnddir('PERP'); + +/copy reqauto_pr.rpgle + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-pi *n; + p_company char(3); + p_reqnbr char(8); +end-pi; + +dcl-s errmsg varchar(80); +dcl-s result int(10); +dcl-s reqnbr int(20); +dcl-s line char(256); +dcl-s msgkey char(4); + +reqnbr = %dec(%trim(p_reqnbr) : 20 : 0); +result = reqauto_evaluate(p_company : reqnbr : errmsg); +line = 'reqauto_evaluate(' + %trim(p_company) + ',' + %char(reqnbr) + + ') = ' + %char(result) + ' err=' + errmsg; +callMsg(line); + +exec sql commit; + +*inlr = *on; +return; + +dcl-proc callMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + msgkey : + x'0000000000000000'); +end-proc; diff --git a/perp/qrpglesrc/reqentr.sqlrpgle b/perp/qrpglesrc/reqentr.sqlrpgle new file mode 100644 index 00000000..6929a06e --- /dev/null +++ b/perp/qrpglesrc/reqentr.sqlrpgle @@ -0,0 +1,514 @@ +**free + +// --------------------------------------------------------------------- +// Program: reqentr (Requisition Entry) +// Purpose: DSPF-based requisition entry, scoped by the company selected +// via perpselr (*LDA positions 1-3). Header screen collects +// requested_by/need_by/priority/notes, allocates the doc +// number via docseq_next('REQ'), then inserts a DRAFT header. +// Line screen is a subfile of requisition_line rows -- F6=Add +// opens an edit panel that defaults UOM from item and +// est_unit_cost from the item's preferred vendor price. +// F8=Submit requires >=1 line and flips status to SUBMITTED; +// no further changes are allowed once submitted. +// Epic: PERP-6 (PERP-34) +// --------------------------------------------------------------------- + +ctl-opt dftactgrp(*no) actgrp(*new) bnddir('PERP'); + +dcl-f reqentd workstn sfile(rlsfl:rrn) sfile(rmsgsfl:msgrrn); + +/copy docseq_pr.rpgle + +dcl-ds ldaDS dtaara(*lda) len(1024) qualified; + compcd char(3) pos(1); +end-ds; + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-ds statusDS psds qualified; + programName char(10) pos(334); +end-ds; + +dcl-ds lineRow qualified; + lnbr int(10); + item varchar(25); + qty packed(15:4); + uom varchar(5); + cost packed(15:4); +end-ds; + +dcl-ds rows likeds(lineRow) dim(500); +dcl-s numRows int(10); +dcl-s i int(10); +dcl-s rrn int(10); +dcl-s msgrrn int(10); +dcl-s selRrn int(10); +dcl-s changeRrn int(10); +dcl-s selOpt char(1); +dcl-s compcd char(3); +dcl-s reqnbr int(20); +dcl-s docerrmsg varchar(80); +dcl-s reqStatus varchar(20); +dcl-s nextLine int(10); +dcl-s chgLnbr int(10); +dcl-s cnt int(10); +dcl-s edefuom varchar(5); +dcl-s edefcost packed(15:4); +dcl-s edesc varchar(60); + +in ldaDS; +compcd = ldaDS.compcd; + +if compcd = ''; + exsr clearMsgs; + writeMsg('No company selected - run Select Company (PERPSELR) first.'); + *in40 = *on; + write rmsgctl; + hcompdsp = ''; + exfmt rhead; + *inlr = *on; + return; +endif; + +hcompdsp = compcd; + +// ----------------------------------------------------------------------- +// Header entry -- collect requested_by/need_by/priority/notes, validate, +// allocate the doc number, insert the DRAFT header. +// ----------------------------------------------------------------------- +hreqby = ''; +hneedby = %date() + %days(7); +hpricd = 'NORMAL'; +hnotes = ''; + +exsr clearMsgs; + +dow '1'; + *in40 = *off; + if msgrrn > 0; + *in40 = *on; + endif; + exfmt rhead; + + if *in03 or *in12; + *inlr = *on; + return; + endif; + + exsr clearMsgs; + + if %trim(hreqby) = ''; + writeMsg('Requested By is required.'); + iter; + endif; + + exec sql + select count(*) into :cnt + from perpdemo.perp_user + where user_code = :hreqby; + if cnt = 0; + writeMsg('Requested By ' + %trim(hreqby) + ' not found.'); + iter; + endif; + + if %trim(hpricd) = ''; + hpricd = 'NORMAL'; + endif; + + exec sql + select count(*) into :cnt + from perpdemo.code_master + where code_type = 'PRIORITY' and code_value = :hpricd; + if cnt = 0; + writeMsg('Priority ' + %trim(hpricd) + ' not valid.'); + iter; + endif; + + leave; +enddo; + +reqnbr = docseq_next(compcd : 'REQ' : docerrmsg); +if reqnbr = 0; + writeMsg('Could not allocate requisition number: ' + docerrmsg); + *inlr = *on; + return; +endif; + +exec sql + insert into perpdemo.requisition_header + (company_code, requisition_number, requested_by, need_by_date, + priority_code, notes) + values (:compcd, :reqnbr, :hreqby, :hneedby, :hpricd, :hnotes); +if sqlcode < 0; + writeMsg('Could not create requisition: SQLCODE=' + %char(sqlcode)); + *inlr = *on; + return; +endif; + +// ----------------------------------------------------------------------- +// Line entry -- subfile of requisition_line rows. +// ----------------------------------------------------------------------- +exsr clearMsgs; +writeMsg('Requisition ' + %char(reqnbr) + ' created (DRAFT). Add lines, ' + + 'then F8=Submit.'); + +dow '1'; + exsr loadHeader; + exsr loadLines; + + if numRows = 0; + *in30 = *off; + write rnolin; + else; + exsr fillSubfile; + *in30 = *on; + endif; + + write rlfoot; + *in40 = *off; + if msgrrn > 0; + *in40 = *on; + endif; + write rmsgctl; + exfmt rlctl; + + if *in03 or *in12; + leave; + endif; + + exsr clearMsgs; + + if *in06; + if reqStatus <> 'DRAFT'; + writeMsg('Requisition already submitted - no further changes allowed.'); + else; + exsr addLine; + endif; + iter; + endif; + + if *in08; + if numRows = 0; + writeMsg('At least one line is required before submitting.'); + elseif reqStatus <> 'DRAFT'; + writeMsg('Requisition already submitted.'); + else; + exec sql + update perpdemo.requisition_header + set status_code = 'SUBMITTED', + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd and requisition_number = :reqnbr; + if sqlcode < 0; + writeMsg('Submit failed: SQLCODE=' + %char(sqlcode)); + else; + writeMsg('Requisition ' + %char(reqnbr) + ' submitted.'); + endif; + endif; + iter; + endif; + + // Fully drain the READC loop before switching to RLEDIT for a change + // (option 2). Calling changeLine in-line here -- while a READC cursor + // is still active on RLSFL -- disturbs the subfile's pending read + // sequence on this same device file, and the next readc raises + // CPF5006 ("Session or device error occurred in file REQENTD"). Same + // fix as PERPSELR/REQAPRR: collect the row to change while draining + // (deletes and invalid-option messages don't switch formats, so they + // still run in-line), act on the change only after the loop finishes + // (DDL_STYLE_GUIDE.md Sec.14). + if numRows > 0; + selRrn = 0; + selOpt = ' '; + changeRrn = 0; + readc rlsfl; + dow not %eof(reqentd); + if slopt <> ''; + selRrn = rrn; + selOpt = slopt; + exsr handleOpt; + selRrn = 0; + endif; + readc rlsfl; + enddo; + + if changeRrn > 0 and msgrrn = 0; + selRrn = changeRrn; + exsr changeLine; + endif; + endif; + +enddo; + +*inlr = *on; +return; + +// --------------------------------------------------------------------- +begsr loadHeader; + exec sql + select status_code, requested_by, need_by_date, priority_code, + total_estimated_cost + into :reqStatus, :dreqby, :dneedby, :dpricd, :dtotest + from perpdemo.requisition_header + where company_code = :compcd and requisition_number = :reqnbr; + dreqnbr = %char(reqnbr); + dstatus = reqStatus; +endsr; + +// --------------------------------------------------------------------- +begsr loadLines; + numRows = 0; + exec sql declare c1 cursor for + select line_number, item_number, quantity, uom_code, est_unit_cost + from perpdemo.requisition_line + where company_code = :compcd and requisition_number = :reqnbr + order by line_number; + exec sql open c1; + if sqlcode < 0; + writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); + return; + endif; + + dow numRows < %elem(rows); + exec sql fetch c1 into :lineRow.lnbr, :lineRow.item, :lineRow.qty, + :lineRow.uom, :lineRow.cost; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + numRows += 1; + rows(numRows) = lineRow; + enddo; + exec sql close c1; +endsr; + +// --------------------------------------------------------------------- +begsr fillSubfile; + rrn = 0; + *in31 = *on; + write rlctl; + *in31 = *off; + for i = 1 to numRows; + slopt = ''; + slline = rows(i).lnbr; + slitem = rows(i).item; + slqty = rows(i).qty; + sluom = rows(i).uom; + slcost = rows(i).cost; + rrn += 1; + write rlsfl; + endfor; +endsr; + +// --------------------------------------------------------------------- +begsr handleOpt; + chain selRrn rlsfl; + if %found(reqentd); + if reqStatus <> 'DRAFT'; + writeMsg('Requisition already submitted - no further changes allowed.'); + return; + endif; + select; + when selOpt = '2'; + if changeRrn = 0; + changeRrn = selRrn; + else; + writeMsg('Only one line may be changed per Enter.'); + endif; + when selOpt = '4'; + exsr deleteLine; + other; + writeMsg('Option ' + selOpt + ' not valid.'); + endsl; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr addLine; + emode = 'A'; + eitem = ''; + eqty = 0; + euom = ''; + ecost = 0; + + dow '1'; + exfmt rledit; + if *in12; + return; + endif; + + if %trim(eitem) = ''; + writeMsg('Item Number is required.'); + iter; + endif; + + exec sql + select item_description, inventory_uom + into :edesc, :edefuom + from perpdemo.item + where company_code = :compcd and item_number = :eitem; + if sqlcode <> 0; + writeMsg('Item ' + %trim(eitem) + ' not found for this company.'); + iter; + endif; + + if eqty <= 0; + writeMsg('Quantity must be greater than zero.'); + iter; + endif; + + if %trim(euom) = ''; + euom = edefuom; + endif; + + if ecost = 0; + exec sql + select ivp.unit_price + into :edefcost + from perpdemo.item_vendor_price ivp + join perpdemo.item_vendor iv + on iv.company_code = ivp.company_code + and iv.item_number = ivp.item_number + and iv.vendor_code = ivp.vendor_code + where ivp.company_code = :compcd + and ivp.item_number = :eitem + and iv.is_preferred = 'Y' + and ivp.effective_to is null + fetch first 1 row only; + if sqlcode = 0; + ecost = edefcost; + endif; + endif; + + leave; + enddo; + + exec sql + select coalesce(max(line_number), 0) + 1 + into :nextLine + from perpdemo.requisition_line + where company_code = :compcd and requisition_number = :reqnbr; + + exec sql + insert into perpdemo.requisition_line + (company_code, requisition_number, line_number, item_number, + quantity, uom_code, est_unit_cost) + values (:compcd, :reqnbr, :nextLine, :eitem, :eqty, :euom, :ecost); + if sqlcode < 0; + writeMsg('Add line failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Added line ' + %char(nextLine) + ': ' + %trim(edesc) + + ' (' + %trim(euom) + ' @ ' + %char(ecost) + ').'); + exsr recalcTotal; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr changeLine; + // Read from the rows() snapshot (populated by loadLines), not the live + // RLSFL buffer -- changeLine now runs after the READC loop has fully + // drained (see the fix note above the readc loop), by which point the + // subfile buffer holds whatever row READC last visited, not + // necessarily this one. + chgLnbr = rows(selRrn).lnbr; + emode = 'C'; + eitem = rows(selRrn).item; + eqty = rows(selRrn).qty; + euom = rows(selRrn).uom; + ecost = rows(selRrn).cost; + + exfmt rledit; + if *in12; + return; + endif; + + if eqty <= 0; + writeMsg('Quantity must be greater than zero.'); + return; + endif; + + exec sql + update perpdemo.requisition_line + set quantity = :eqty, + uom_code = :euom, + est_unit_cost = :ecost, + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd and requisition_number = :reqnbr + and line_number = :chgLnbr; + if sqlcode < 0; + writeMsg('Change failed: SQLCODE=' + %char(sqlcode)); + else; + writeMsg('Updated line ' + %char(chgLnbr) + '.'); + exsr recalcTotal; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr deleteLine; + exec sql + delete from perpdemo.requisition_line + where company_code = :compcd and requisition_number = :reqnbr + and line_number = :slline; + if sqlcode < 0; + writeMsg('Delete failed: SQLSTATE=' + sqlstate); + else; + writeMsg('Deleted line ' + %char(slline) + '.'); + exsr recalcTotal; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr recalcTotal; + exec sql + update perpdemo.requisition_header + set total_estimated_cost = + (select coalesce(sum(quantity * est_unit_cost), 0) + from perpdemo.requisition_line + where company_code = :compcd + and requisition_number = :reqnbr), + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd and requisition_number = :reqnbr; +endsr; + +// --------------------------------------------------------------------- +begsr clearMsgs; + msgrrn = 0; + *in41 = *on; + write rmsgctl; + *in41 = *off; +endsr; + +// --------------------------------------------------------------------- +dcl-proc writeMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + smsgkey : + x'0000000000000000'); + msgrrn += 1; + spgmq = statusDS.programName; + write rmsgsfl; +end-proc; diff --git a/perp/qsrvsrc/reqauto.bnd b/perp/qsrvsrc/reqauto.bnd new file mode 100644 index 00000000..bd51b959 --- /dev/null +++ b/perp/qsrvsrc/reqauto.bnd @@ -0,0 +1,4 @@ +strpgmexp pgmlvl(*current) signature('REQAUTO ') + export symbol("REQAUTO_SCORE") + export symbol("REQAUTO_EVALUATE") +endpgmexp From 1c6a471322a31514bf570ff0150b92b7ada93e47 Mon Sep 17 00:00:00 2001 From: Gary Jones Date: Wed, 22 Jul 2026 15:19:11 +0000 Subject: [PATCH 08/13] =?UTF-8?q?PERP-7:=20Purchasing=20=E2=80=94=20po=5Fh?= =?UTF-8?q?eader/line/schedule=20+=20entry,=20from-req,=20blanket,=20brows?= =?UTF-8?q?e=20programs?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Delivers the full Purchasing epic (PERP-37..41) in one pass. DDL (PERP-37): - po_header, po_line, po_line_schedule tables, all journaled to PERPJRN (*BOTH/*OPNCLO). FK order preserved: po_header FKs company, vendor, perp_user (buyer), code_master; po_line FKs po_header, item, uom, code_master, and composite-FKs requisition_line for the optional source_requisition line-level linkage (MATCH SIMPLE, both null on manual PO). - po_line_open view exposes the demo-friendly derived columns (open_qty = ordered_qty - received_qty, extended_price = ordered_qty * unit_price). This is the reference workaround for the GENERATED ALWAYS AS (expression) gap documented in DDL_STYLE_GUIDE.md Sec.9 -- computed columns still don't build on this target, but a companion view does. Programs (PERP-38..41): - poentr / poentd: manual PO entry, reqentr shape. Buyer snapshot from vendor.buyer_code; docseq_next('PO'); unit_price default from item_vendor_price current row; F8=Submit flips DRAFT to OPEN. Currency hard-coded to USD per user request (removed the field from the DSPF, INSERT relies on the DDL default). - poreqr / poreqd: PO from requisition (consolidate/split). Selects APPROVED reqs whose lines aren't yet linked to any po_line; groups by preferred vendor; F6=Confirm creates POs with source_requisition line-level linkage. Requisition Converted status is derived from the linkage, not stored. - poschr / poschd: blanket schedule maintenance. Soft warning when total scheduled_qty > po_line.ordered_qty. OPTIONS(*NOPASS) parms so pobrwr drills in scoped. - pobrwr / pobrwd: PO browse & inquiry. Filterable subfile + plain- record BDETAIL drawn from po_line_open. Opt 9 calls poschr scoped to line 1 for blanket-schedule editing. Menu wiring: new PERPPOM child menu with 4 options; PERPMNU adds option 7 -> GO PERPDEMO/PERPPOM. Style guide + playbook updated with three runtime-only gotchas learned live during PERP-7 (all compile clean severity 00, then crash on first exercise): - Date/DATFMT triangle: ctl-opt datfmt(*iso) + explicit %date(...: *ISO) + sentinel dates within 1940-2039 (the SQL precompiler generates its intermediate host vars with the job DATFMT and ignores ctl-opt datfmt(*iso), so the SQL side stays capped at *MDY even after the ctl-opt fix). RNQ0114 otherwise. - %subst(varchar : 1 : N) is strict about current data length, not declared max -- 'OPEN' (4 chars) can't answer %subst(...,1,10) even in a VARCHAR(20) column. RNQ0100 otherwise. Fix: direct assign; RPG right-pads or truncates automatically. - %editc(int : 'X') returns hex, not decimal. Use %char() for plain doc-number display. Silent-wrong-output otherwise (every PO # in the first browse rendered as 0000000000). Now captured in perp/AGENTS.md "Runtime-only gotchas" section (loads at the top of the playbook for future PERP work) and perp/DDL_STYLE_GUIDE.md Sec.13. Verification: state-based via SQL (DDL + view + CHECK constraints + consolidation flow all exercised against live PERPDEMO with test rows, cleaned up after). Interactive UI verification of the 4 programs done live by the user, three RPG runtime bugs surfaced and fixed in the process (see above). Jira: PERP-7 epic + PERP-37..41 stories all transitioned Done. Confluence Data Model, Delivery Plan, PERP hub, and Design Decisions pages updated. --- perp/AGENTS.md | 39 ++ perp/DDL_STYLE_GUIDE.md | 101 ++++ perp/Rules.mk | 55 ++- perp/perpmnu.msgf | 1 + perp/perppom.msgf | 5 + perp/qddlsrc/po_header.table.sql | 102 ++++ perp/qddlsrc/po_line.table.sql | 120 +++++ perp/qddlsrc/po_line_open.view.sql | 33 ++ perp/qddlsrc/po_line_schedule.table.sql | 71 +++ perp/qddssrc/perpmnu.dspf | 1 + perp/qddssrc/perppom.dspf | 32 ++ perp/qddssrc/pobrwd.dspf | 155 ++++++ perp/qddssrc/poentd.dspf | 116 +++++ perp/qddssrc/poreqd.dspf | 112 +++++ perp/qddssrc/poschd.dspf | 111 +++++ perp/qrpglesrc/pobrwr.sqlrpgle | 456 +++++++++++++++++ perp/qrpglesrc/poentr.sqlrpgle | 544 +++++++++++++++++++++ perp/qrpglesrc/poreqr.sqlrpgle | 618 ++++++++++++++++++++++++ perp/qrpglesrc/poschr.sqlrpgle | 484 +++++++++++++++++++ 19 files changed, 3154 insertions(+), 2 deletions(-) create mode 100644 perp/perppom.msgf create mode 100644 perp/qddlsrc/po_header.table.sql create mode 100644 perp/qddlsrc/po_line.table.sql create mode 100644 perp/qddlsrc/po_line_open.view.sql create mode 100644 perp/qddlsrc/po_line_schedule.table.sql create mode 100644 perp/qddssrc/perppom.dspf create mode 100644 perp/qddssrc/pobrwd.dspf create mode 100644 perp/qddssrc/poentd.dspf create mode 100644 perp/qddssrc/poreqd.dspf create mode 100644 perp/qddssrc/poschd.dspf create mode 100644 perp/qrpglesrc/pobrwr.sqlrpgle create mode 100644 perp/qrpglesrc/poentr.sqlrpgle create mode 100644 perp/qrpglesrc/poreqr.sqlrpgle create mode 100644 perp/qrpglesrc/poschr.sqlrpgle diff --git a/perp/AGENTS.md b/perp/AGENTS.md index 2fd46d34..e434e1ba 100644 --- a/perp/AGENTS.md +++ b/perp/AGENTS.md @@ -20,6 +20,45 @@ for every table, index, view, and CL in this module. In particular: - No `SET OPTION COMMIT = *NONE` in RPG — real commitment control against the perp journal +## Runtime-only gotchas that clean compiles won't catch + +Three gotchas on this environment routinely compile clean at severity 00 +and then crash at runtime on the first exercise. Always factor these in +when adding a new RPG or SQLRPGLE program under `perp/qrpglesrc/`: + +- **`ctl-opt datfmt(*iso)` is mandatory for any program that touches + Date values.** The job DATFMT is `*MDY` (year range 1940-2039). + Without the ctl-opt override every RPG Date variable inherits that + narrow range as its storage format and any value outside it (a + `0001-01-01` sentinel, an SQL fetch of an out-of-range date, a DSPF + `L DATFMT(*ISO)` read) crashes with `RNQ0114`. Three-layer fix: + - Put `datfmt(*iso)` on `ctl-opt`. + - Parse every literal with `%date('yyyy-mm-dd' : *ISO)`. + - Keep any Date value that will be assigned to an SQL host variable + inside 1940-2039 (e.g. sentinels `1940-01-01`/`2039-12-31`) — the + SQL precompiler generates its intermediate host vars with the JOB + DATFMT and ignores `ctl-opt datfmt(*iso)`, so the SQL side stays + capped at *MDY even after the first two fixes. + + Full analysis in `DDL_STYLE_GUIDE.md` §13. This bit every PO program + during PERP-7 and burned three round-trips before the third layer + landed — don't repeat. + +- **`%subst(varchar : 1 : N)` fails when `N > %len(current data)`, not + just when `N > declared max`.** A VARCHAR(20) column holding + `'OPEN'` (4 chars) can't answer `%subst(..., 1, 10)` — `RNQ0100`. + For "fit into a fixed-width display field", drop the `%subst` and + use direct assignment: RPG right-pads or truncates automatically. + Only reach for `%subst` when you actually need a middle slice, and + guard with `%min(%len(...), N)` when you do. + +- **`%editc(int : 'X')` produces hex, not decimal.** For displaying a + numeric doc-number as a plain string (PO number, requisition + number, line number), use `%char()`. `%editc` with `'X'` returns + the hex representation of the internal byte pattern — PERP-7's + first live browse rendered every PO number as `0000000000` before + this was caught. + ## Build target Objects build into the **`PERPDEMO`** library on IBM i. `PERPDEMO` is a diff --git a/perp/DDL_STYLE_GUIDE.md b/perp/DDL_STYLE_GUIDE.md index 7c65f68c..f2fd8698 100644 --- a/perp/DDL_STYLE_GUIDE.md +++ b/perp/DDL_STYLE_GUIDE.md @@ -231,6 +231,17 @@ a view) instead of a generated column; don't re-attempt this in DDL without budgeting time to re-verify it against whatever DB2 for i PTF/config is live at the time. +**Worked example — PO open_qty via a view (PERP-37).** `po_line` needs a +per-row `open_qty = ordered_qty - received_qty` for the browse screen and +receipt allocation. Rather than fight the computed-column parser, the epic +ships a companion view `po_line_open` (`qddlsrc/po_line_open.view.sql`) that +`SELECT ordered_qty - received_qty AS open_qty, ordered_qty * unit_price AS +extended_price ... FROM po_line`. Programs that need the derived columns +join the view; programs that don't read `po_line` directly. Views are +`.view.sql` and build as normal `RUNSQLSTM` → `*FILE` LFs (short name auto- +derives; `po_line_open` came out as `PO_LI00002`, confirmed via `SYSTABLES` +after build — same auto-derivation rule as tables). + ## 10. Generic lookup — `code_master` Simple code-and-description lookups (statuses, priorities, roles, approval @@ -331,6 +342,96 @@ maintenance programs. These apply to every RPG or SQLRPGLE source under and reserve positions in the LDA — every job has an LDA automatically, so no runtime `CRTDTAARA` is needed. PERP session state (currently just the selected company code at positions 1-3) lives in the LDA. +- **The SQLRPGLE precompiler does not accept `:ds(i).field` as a host + variable.** Found in PERP-39 (`poreqr.sqlrpgle`): a WHERE clause of + `and rl.requisition_number = :reqs(i).reqnbr` fails with `SQL0312 + Variable REQS not defined or not usable` and `SQL0104 Token ( not + valid`. Same rule applies to nested DS arrays like + `:plan(v).lines(L).item`. Fix: copy the array element to a plain + scalar host variable (`xReqNbr = reqs(i).reqnbr; ... where + ... = :xReqNbr`). This is why `poreqr` has an `x`-prefixed staging + block near the top of its declarations. +- **`dcl-s` inside a `begsr` subroutine is illegal.** Found in the same + program: local variables declared with `dcl-s` inside a `begsr` block + raise `RNF0724 The statement type is out of sequence for the main + procedure`, because `begsr` runs in the main procedure's scope (not + its own like `dcl-proc`). Hoist all `dcl-s`/`dcl-ds` to the main + declaration section; only executable statements go in a `begsr`. +- **Free-format RPG allows only one statement per line.** Two statements + separated by whitespace on the same line (e.g. + `*in60 = *off; *in61 = *off;`) raise `RNF5508 End of free-format + statement is not blank`. Put each on its own line. +- **`%editc(int : 'X')` returns hex, not decimal.** Every PO number + in `pobrwr`'s first live browse rendered as `0000000000` because + `bsponbr = %editc(rows(i).ponbr : 'X')` — edit code `'X'` is + documented as "hex representation of a zoned decimal", not "plain + string". For displaying a numeric doc-number (PO number, + requisition number, line number) as a plain string, use `%char()`. + Use `%editc` only when you deliberately want an RPG edit-code + formatted output (comma grouping, sign, decimal shift, etc.) and + never `'X'` for business display. + +- **`%subst(varchar : 1 : N)` fails at runtime when `N` exceeds the + current data length, not just when it exceeds the declared max.** + Found in `pobrwr` after the DATFMT fix landed — `bsstat = %subst( + rows(i).stat : 1 : 10)` where `stat` is `VARCHAR(20)` holding + `'OPEN'` (4 chars) raised `RNQ0100 Length or start position is out + of range for the string operation (C G D F)` at runtime, even + though the declared max (20) is well above the requested 10. Same + applies to `%subst(vendor_name : 1 : 25)` when the vendor name + happens to be shorter than 25. + + **Fix:** just use direct assignment from VARCHAR into a fixed CHAR + field. RPG right-pads or truncates automatically — no `%subst` is + needed for "fit into the display field". Use `%subst` only when + you actually need a middle slice, and even then guard with + `%min(%len(...), N)`. Fixed across `pobrwr`, `poreqr`, `poschr` + in one pass; captured here so downstream epics don't repeat it. + +- **Sentinel/filter Date values in embedded SQL must stay within the + job DATFMT range (`*MDY`, 1940-2039, on this env).** The SQL + precompiler generates its intermediate host variables (the ones + named `SQL_00020`, `SQL_00021`, ... that back every `:var` + reference in an EXEC SQL) with `DATFMT(*MDY/)` — the JOB DATFMT, + IGNORING `ctl-opt datfmt(*iso)`. Confirmed by inspecting the + compile listing after the "fix": + + ``` + D SQL_00020 192 199D DATFMT(*MDY/) FFRDT + D SQL_00021 200 207D DATFMT(*MDY/) FTODT + ... + SQL_00020 = FFRDT; //SQL <-- assigns *ISO FFRDT into *MDY SQL_00020 + ``` + + So even when the RPG Date variable's *storage* format is `*ISO` + (thanks to `ctl-opt datfmt(*iso)`), the precompiler-generated host + variable it gets assigned to is `*MDY`, and any value outside + 1940-2039 crashes with `RNQ0114 The year portion of a Date or + Timestamp value is not in the correct range (C G D F)`. Found in + `pobrwr` (browse-filter from/to sentinels), 2026-07-22, after two + earlier fix attempts (adding `:*ISO` to the parse, then + `datfmt(*iso)` to `ctl-opt`) both compiled clean but ran the same + crash at the exact same statement. + + **What works:** + 1. Put `datfmt(*iso)` on `ctl-opt` — sets RPG Date variable + storage to *ISO (0001-9999); needed for anything that assigns + to/from the DSPF's `L DATFMT(*ISO)` fields. + 2. Parse literals with explicit `%date('yyyy-mm-dd' : *ISO)` so + the parse step doesn't use the job DATFMT. + 3. **Keep any Date value that will be assigned to an SQL host + variable within `1940-2039`.** For the pobrwr filter, that + meant swapping `0001-01-01` / `9999-12-31` sentinels for + `1940-01-01` / `2039-12-31` — still functionally "no filter" + for realistic PO dates, but doesn't fail the *MDY range check. + + All three steps are needed; the third is what stopped the runtime + crash for good. If you truly need out-of-range Date values in SQL + (unlikely in PERP), the only escape is to bypass the host-variable + path — use dynamic SQL with the date rendered as a CHAR literal + inside the statement text, or move the Date column comparison out + of the WHERE clause entirely. `%date()` with no args (returns + today) is always safe. - **Program/module/file object names cap at 10 characters — same as journal receivers (§7).** Learned again in PERP-32: naming a smoke-test caller `itmvprcqsmk.sqlrpgle` (11 chars) failed `CRTSQLRPGI` with diff --git a/perp/Rules.mk b/perp/Rules.mk index 820632e1..917bb601 100644 --- a/perp/Rules.mk +++ b/perp/Rules.mk @@ -215,6 +215,50 @@ reqauto.srvpgm: reqauto.module qsrvsrc/reqauto.bnd reqautosmk.pgm: qrpglesrc/reqautosmk.sqlrpgle qrpglesrc/reqauto_pr.rpgle reqauto.srvpgm | perp.bnddir requisition_header.file +# --- PERP-7: Purchasing — po_header / po_line / po_line_schedule --------- +# FK order: po_header (company, vendor, perp_user (buyer), code_master) +# before po_line (po_header, item, uom, code_master, requisition_line for +# optional back-link) before po_line_schedule (po_line). The po_line_open +# view (ordered_qty - received_qty computed via view rather than a stored +# GENERATED ALWAYS AS column — see DDL_STYLE_GUIDE.md Sec.9) hangs off +# po_line as a normal (not order-only) prereq so it always rebuilds +# alongside its base table. +po_header.file: qddlsrc/po_header.table.sql company.file vendor.file perp_user.file code_master.file | perpsjpf.pgm +po_line.file: qddlsrc/po_line.table.sql po_header.file item.file uom.file code_master.file requisition_line.file | perpsjpf.pgm +po_line_schedule.file: qddlsrc/po_line_schedule.table.sql po_line.file | perpsjpf.pgm +po_line_open.file: qddlsrc/po_line_open.view.sql po_line.file + +# Manual PO entry program (header + line subfile). Calls docseq_next('PO') +# for numbering; snapshots buyer_code from vendor at header commit; +# defaults line UOM from item, unit_price from the entered vendor's +# current item_vendor_price row. Same shape as reqentr (PERP-34). +poentd.file: qddssrc/poentd.dspf +poentr.pgm: qrpglesrc/poentr.sqlrpgle qrpglesrc/docseq_pr.rpgle qddssrc/poentd.dspf | poentd.file perp.bnddir po_header.file po_line.file item.file item_vendor.file item_vendor_price.file uom.file vendor.file perp_user.file + +# PO from requisition (consolidate/split). Selects APPROVED requisitions, +# groups their lines by preferred vendor (one PO per vendor -> splitting), +# consolidates multiple selected reqs into a single PO per vendor. Each +# generated po_line carries source_requisition_number + +# source_requisition_line_number so "converted" status is derivable by +# joining po_line back to requisition_line's PK. Approved reqs flip to +# CONVERTED once all their lines have been placed on a PO. +poreqd.file: qddssrc/poreqd.dspf +poreqr.pgm: qrpglesrc/poreqr.sqlrpgle qrpglesrc/docseq_pr.rpgle qddssrc/poreqd.dspf | poreqd.file perp.bnddir po_header.file po_line.file requisition_header.file requisition_line.file item_vendor.file item_vendor_price.file vendor.file + +# Blanket PO schedule maintenance. Subfile of po_line_schedule rows for +# a given (company, po_number, line_number). Add/Change/Delete rows. +# Warn (not block) when total scheduled_qty exceeds po_line.ordered_qty. +poschd.file: qddssrc/poschd.dspf +poschr.pgm: qrpglesrc/poschr.sqlrpgle qddssrc/poschd.dspf | poschd.file po_line.file po_line_schedule.file + +# PO browse & inquiry. Filterable subfile of PO headers (status, vendor, +# buyer, order-date range); Option 5 drills to detail (header + all +# lines, joined to po_line_open for open_qty + extended_price); Option 8 +# on a line drills to source requisition (if any) + schedule (if blanket). +pobrwd.file: qddssrc/pobrwd.dspf +pobrwr.pgm: qrpglesrc/pobrwr.sqlrpgle qddssrc/pobrwd.dspf | pobrwd.file po_header.file po_line.file po_line_open.file po_line_schedule.file requisition_line.file vendor.file perp_user.file + + # --- PERP menus (glue for exploratory verification) ----------------------- # GO PERPDEMO/PERPMNU is the single entry point. PERPMNU itself only holds # "Select company" + one option per child menu + Sign off -- the child @@ -254,11 +298,18 @@ perpreqm.file: qddssrc/perpreqm.dspf perpreqm.msgf: perpreqm.msgf perpreqm.menu: perpreqm.msgf perpreqm.file | reqentr.pgm reqaprr.pgm +# PERP-7 Purchasing child menu. Options: 1 manual PO (poentr), 2 PO from +# requisition (poreqr), 3 blanket schedule (poschr), 4 browse/inquiry +# (pobrwr). +perppom.file: qddssrc/perppom.dspf +perppom.msgf: perppom.msgf +perppom.menu: perppom.msgf perppom.file | poentr.pgm poreqr.pgm poschr.pgm pobrwr.pgm + # Top-level menu. Order-only on perpselr.pgm (called directly) and on the -# 5 child .menu targets (routed to via GO PERPDEMO/, not CALLed). +# 6 child .menu targets (routed to via GO PERPDEMO/, not CALLed). perpmnu.file: qddssrc/perpmnu.dspf perpmnu.msgf: perpmnu.msgf -perpmnu.menu: perpmnu.msgf perpmnu.file | perpselr.pgm perpsysm.menu perpinvm.menu perpvndm.menu perpdiag.menu perpreqm.menu +perpmnu.menu: perpmnu.msgf perpmnu.file | perpselr.pgm perpsysm.menu perpinvm.menu perpvndm.menu perpdiag.menu perpreqm.menu perppom.menu # --- CL setup ------------------------------------------------------------- diff --git a/perp/perpmnu.msgf b/perp/perpmnu.msgf index 79bd03a0..acd07c58 100644 --- a/perp/perpmnu.msgf +++ b/perp/perpmnu.msgf @@ -5,4 +5,5 @@ addmsgd msgid(usr0003) msgf($LIBRARY/$NAME) msg('go perpdemo/perpinvm') addmsgd msgid(usr0004) msgf($LIBRARY/$NAME) msg('go perpdemo/perpvndm') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0005) msgf($LIBRARY/$NAME) msg('go perpdemo/perpdiag') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0006) msgf($LIBRARY/$NAME) msg('go perpdemo/perpreqm') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0007) msgf($LIBRARY/$NAME) msg('go perpdemo/perppom') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0090) msgf($LIBRARY/$NAME) msg('signoff') seclvl(*none) sev(00) fmt(*none) diff --git a/perp/perppom.msgf b/perp/perppom.msgf new file mode 100644 index 00000000..b303fb35 --- /dev/null +++ b/perp/perppom.msgf @@ -0,0 +1,5 @@ +crtmsgf msgf($LIBRARY/$NAME) +addmsgd msgid(usr0001) msgf($LIBRARY/$NAME) msg('call poentr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0002) msgf($LIBRARY/$NAME) msg('call poreqr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0003) msgf($LIBRARY/$NAME) msg('call poschr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0004) msgf($LIBRARY/$NAME) msg('call pobrwr') seclvl(*none) sev(00) fmt(*none) diff --git a/perp/qddlsrc/po_header.table.sql b/perp/qddlsrc/po_header.table.sql new file mode 100644 index 00000000..169742d5 --- /dev/null +++ b/perp/qddlsrc/po_header.table.sql @@ -0,0 +1,102 @@ +-- --------------------------------------------------------------------------- +-- Table: po_header (system name PO_HEADER, auto-derived) +-- Module: perp +-- Purpose: Purchase order header. Buyer is snapshotted from vendor at +-- creation so historical POs keep their original buyer even if +-- the vendor is later reassigned. total_amount is maintained by +-- the PO entry program (UPDATE ... SET total_amount = SUM(...)) +-- — same idiom used by requisition_header.total_estimated_cost. +-- No po_display computed column here — DDL_STYLE_GUIDE.md Sec.9's +-- GENERATED ALWAYS AS (expression) pattern does not build on this +-- target (confirmed PERP-33); display formatting happens in RPG. +-- Epic: PERP-7 (PERP-37) +-- --------------------------------------------------------------------------- + +-- 'po_header' (9 chars) is itself a valid system name, so DB2 auto-derives +-- PO_HEADER and FOR SYSTEM NAME would raise SQL7029 — same rule as company +-- and vendor. Omit the clause and let it auto-derive. +CREATE TABLE po_header ( + + -- Composite key (per-company) --------------------------------------------- + company_code FOR COLUMN COMPCD CHAR(3) NOT NULL, + po_number FOR COLUMN PONBR BIGINT NOT NULL, + + -- Vendor / buyer ----------------------------------------------------------- + vendor_code FOR COLUMN VNDCD VARCHAR(10) NOT NULL, + -- buyer_code is snapshotted from vendor.buyer_code at PO creation. FK to + -- perp_user (same rule vendor.buyer_code follows) — a buyer must be a + -- real named user; CODERFLOW does not create POs (unlike requisition + -- approvals which can be system-stamped). + buyer_code FOR COLUMN BUYCD CHAR(10) NOT NULL, + + -- Dates ------------------------------------------------------------------- + order_date FOR COLUMN ORDDT DATE NOT NULL DEFAULT CURRENT_DATE, + + -- Status (FK to code_master POSTATUS) ------------------------------------- + status_code FOR COLUMN STCODE VARCHAR(20) NOT NULL DEFAULT 'DRAFT', + status_type FOR COLUMN STTYPE VARCHAR(20) NOT NULL DEFAULT 'POSTATUS', + + -- Currency (FK to code_master CURRENCY) ----------------------------------- + currency_code FOR COLUMN CURR VARCHAR(20) NOT NULL DEFAULT 'USD', + currency_type FOR COLUMN CURTYP VARCHAR(20) NOT NULL DEFAULT 'CURRENCY', + + -- Roll-up total. Maintained by po entry program on line insert/change/ + -- delete via the same UPDATE-with-subquery pattern requisition_header uses. + total_amount FOR COLUMN TOTAMT DECIMAL(15,2) NOT NULL DEFAULT 0, + + -- Long-form notes. 'notes' (5 chars) is itself a valid system name so + -- explicit FOR COLUMN NOTES raises SQL0612 — omit and let it auto-derive + -- (same finding as requisition_header, DDL_STYLE_GUIDE.md Sec.2). + notes CLOB(16K), + + -- Standard audit block ---------------------------------------------------- + created_at FOR COLUMN CRTAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + created_by FOR COLUMN CRTBY VARCHAR(18) NOT NULL DEFAULT USER, + updated_at FOR COLUMN UPDAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_by FOR COLUMN UPDBY VARCHAR(18) NOT NULL DEFAULT USER, + is_active FOR COLUMN ISACT CHAR(1) NOT NULL DEFAULT 'Y', + + -- Composite primary key --------------------------------------------------- + PRIMARY KEY (company_code, po_number), + + -- Constraints ------------------------------------------------------------- + CONSTRAINT pohdr_isact_ck CHECK (is_active IN ('Y','N')), + CONSTRAINT pohdr_sttype_ck CHECK (status_type = 'POSTATUS'), + CONSTRAINT pohdr_curtyp_ck CHECK (currency_type = 'CURRENCY'), + CONSTRAINT pohdr_totamt_ck CHECK (total_amount >= 0), + + -- FKs ---------------------------------------------------------------------- + CONSTRAINT pohdr_company_fk FOREIGN KEY (company_code) + REFERENCES company (company_code) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT pohdr_vendor_fk FOREIGN KEY (company_code, vendor_code) + REFERENCES vendor (company_code, vendor_code) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT pohdr_buyer_fk FOREIGN KEY (buyer_code) + REFERENCES perp_user (user_code) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT pohdr_stat_fk FOREIGN KEY (status_type, status_code) + REFERENCES code_master (code_type, code_value) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT pohdr_curr_fk FOREIGN KEY (currency_type, currency_code) + REFERENCES code_master (code_type, code_value) + ON DELETE RESTRICT ON UPDATE RESTRICT +); + +LABEL ON TABLE po_header IS + 'PERP purchase order header'; + +LABEL ON COLUMN po_header ( + company_code IS 'Company code (FK to company)', + po_number IS 'PO number (doc_sequence PO)', + vendor_code IS 'Vendor (FK to vendor)', + buyer_code IS 'Buyer snapshot from vendor at creation', + order_date IS 'Date PO was placed', + status_code IS 'Status (FK to code_master POSTATUS)', + status_type IS 'Status type discriminator (constant)', + currency_code IS 'Currency (FK to code_master CURRENCY)', + currency_type IS 'Currency type discriminator (constant)', + total_amount IS 'Sum of line ordered_qty * unit_price', + notes IS 'Long-form notes', + is_active IS 'Active flag (Y/N, soft delete)' +); diff --git a/perp/qddlsrc/po_line.table.sql b/perp/qddlsrc/po_line.table.sql new file mode 100644 index 00000000..f00e3764 --- /dev/null +++ b/perp/qddlsrc/po_line.table.sql @@ -0,0 +1,120 @@ +-- --------------------------------------------------------------------------- +-- Table: po_line (system name PO_LINE, auto-derived) +-- Module: perp +-- Purpose: Purchase order line. unit_price is snapshotted from +-- item_vendor_price at PO creation so historical POs keep their +-- original price even if the current effective row is later +-- superseded (same snapshot idiom as buyer_code on po_header). +-- source_requisition_number / source_requisition_line_number +-- are nullable — populated only when the line originates from +-- a requisition (PERP-39). This line-level (not header-level) +-- linkage lets one requisition line be split across multiple +-- POs and multiple requisitions be consolidated into one PO. +-- open_qty is NOT a stored column — DDL_STYLE_GUIDE.md Sec.9's +-- GENERATED ALWAYS AS (expression) pattern does not build here. +-- Callers derive it as (ordered_qty - received_qty) in RPG or +-- via the po_line_open view (built in the same epic). +-- Epic: PERP-7 (PERP-37) +-- --------------------------------------------------------------------------- + +-- 'po_line' (7 chars) is itself a valid system name, so DB2 auto-derives +-- PO_LINE and FOR SYSTEM NAME would raise SQL7029. Omit the clause. +CREATE TABLE po_line ( + + -- Composite key (per-company, per-PO) ------------------------------------- + company_code FOR COLUMN COMPCD CHAR(3) NOT NULL, + po_number FOR COLUMN PONBR BIGINT NOT NULL, + line_number FOR COLUMN LINNBR INTEGER NOT NULL, + + -- Item / quantity --------------------------------------------------------- + item_number FOR COLUMN ITMNBR VARCHAR(25) NOT NULL, + ordered_qty FOR COLUMN ORDQTY DECIMAL(15,4) NOT NULL DEFAULT 0, + received_qty FOR COLUMN RCVQTY DECIMAL(15,4) NOT NULL DEFAULT 0, + uom_code FOR COLUMN UOMCD VARCHAR(5) NOT NULL, + + -- Snapshot at PO creation ------------------------------------------------- + unit_price FOR COLUMN UNTPRC DECIMAL(15,4) NOT NULL DEFAULT 0, + + -- Optional expected receipt date. Blanket-schedule lines with real + -- delivery dates live in po_line_schedule. + expected_receipt_date FOR COLUMN EXPRCV DATE, + + -- Line status (per-line, e.g. one line CLOSED while other lines OPEN). + -- Same POSTATUS lookup as the header. + status_code FOR COLUMN STCODE VARCHAR(20) NOT NULL DEFAULT 'OPEN', + status_type FOR COLUMN STTYPE VARCHAR(20) NOT NULL DEFAULT 'POSTATUS', + + -- Optional back-link to the requisition line this PO line came from. + -- Both are nullable together — a manual PO carries NULLs. The FK + -- constraint permits NULLs (RESTRICT on delete/update) — see reqln_ref_fk + -- at the bottom of the table. + source_requisition_number FOR COLUMN SRCRQN BIGINT, + source_requisition_line_number FOR COLUMN SRCRQL INTEGER, + + -- Standard audit block ---------------------------------------------------- + created_at FOR COLUMN CRTAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + created_by FOR COLUMN CRTBY VARCHAR(18) NOT NULL DEFAULT USER, + updated_at FOR COLUMN UPDAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_by FOR COLUMN UPDBY VARCHAR(18) NOT NULL DEFAULT USER, + is_active FOR COLUMN ISACT CHAR(1) NOT NULL DEFAULT 'Y', + + -- Composite primary key --------------------------------------------------- + PRIMARY KEY (company_code, po_number, line_number), + + -- Constraints ------------------------------------------------------------- + CONSTRAINT poln_isact_ck CHECK (is_active IN ('Y','N')), + CONSTRAINT poln_linnbr_ck CHECK (line_number > 0), + CONSTRAINT poln_ordqty_ck CHECK (ordered_qty > 0), + CONSTRAINT poln_rcvqty_ck CHECK (received_qty >= 0 + AND received_qty <= ordered_qty), + CONSTRAINT poln_untprc_ck CHECK (unit_price >= 0), + CONSTRAINT poln_sttype_ck CHECK (status_type = 'POSTATUS'), + -- Requisition back-link is all-or-nothing. + CONSTRAINT poln_srcreq_ck CHECK ( + (source_requisition_number IS NULL AND source_requisition_line_number IS NULL) + OR + (source_requisition_number IS NOT NULL AND source_requisition_line_number IS NOT NULL) + ), + + -- FKs ---------------------------------------------------------------------- + CONSTRAINT poln_hdr_fk FOREIGN KEY (company_code, po_number) + REFERENCES po_header (company_code, po_number) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT poln_item_fk FOREIGN KEY (company_code, item_number) + REFERENCES item (company_code, item_number) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT poln_uom_fk FOREIGN KEY (uom_code) + REFERENCES uom (uom_code) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT poln_stat_fk FOREIGN KEY (status_type, status_code) + REFERENCES code_master (code_type, code_value) + ON DELETE RESTRICT ON UPDATE RESTRICT, + -- Composite FK to requisition_line — DB2 for i treats a composite FK + -- where any component is NULL as satisfied (MATCH SIMPLE default), so + -- manual PO lines with both source columns NULL pass without needing + -- a special "manual" placeholder row. + CONSTRAINT poln_srcreq_fk FOREIGN KEY + (company_code, source_requisition_number, source_requisition_line_number) + REFERENCES requisition_line (company_code, requisition_number, line_number) + ON DELETE RESTRICT ON UPDATE RESTRICT +); + +LABEL ON TABLE po_line IS + 'PERP purchase order line'; + +LABEL ON COLUMN po_line ( + company_code IS 'Company code (FK to po_header)', + po_number IS 'PO number (FK to po_header)', + line_number IS 'Line number within PO (PK)', + item_number IS 'Item number (FK to item)', + ordered_qty IS 'Quantity ordered', + received_qty IS 'Running receipt total (updated by receipts)', + uom_code IS 'Unit of measure (FK to uom)', + unit_price IS 'Unit price snapshot at PO creation', + expected_receipt_date IS 'Expected receipt date (null on blanket)', + status_code IS 'Line status (FK to code_master POSTATUS)', + status_type IS 'Status type discriminator (constant)', + source_requisition_number IS 'Source requisition number, null on manual PO', + source_requisition_line_number IS 'Source requisition line, null on manual PO', + is_active IS 'Active flag (Y/N, soft delete)' +); diff --git a/perp/qddlsrc/po_line_open.view.sql b/perp/qddlsrc/po_line_open.view.sql new file mode 100644 index 00000000..ec706286 --- /dev/null +++ b/perp/qddlsrc/po_line_open.view.sql @@ -0,0 +1,33 @@ +-- --------------------------------------------------------------------------- +-- View: po_line_open (system name PO_LINE_OP, auto-derived) +-- Module: perp +-- Purpose: Expose po_line with a computed open_qty column +-- (ordered_qty - received_qty). This is the workaround for the +-- "no GENERATED ALWAYS AS (expression) computed columns" gotcha +-- documented in DDL_STYLE_GUIDE.md Sec.9 — RPG reads either +-- po_line directly and derives open_qty in code, or joins this +-- view where open_qty is already computed. +-- Epic: PERP-7 (PERP-37) +-- --------------------------------------------------------------------------- + +CREATE VIEW po_line_open AS + SELECT company_code, + po_number, + line_number, + item_number, + ordered_qty, + received_qty, + (ordered_qty - received_qty) AS open_qty, + uom_code, + unit_price, + (ordered_qty * unit_price) AS extended_price, + expected_receipt_date, + status_code, + source_requisition_number, + source_requisition_line_number, + is_active + FROM po_line; + +-- LABEL ON TABLE caps at 50 chars on DB2 for i (DDL_STYLE_GUIDE.md Sec.2). +LABEL ON TABLE po_line_open IS + 'PERP po_line with open_qty + extended_price'; diff --git a/perp/qddlsrc/po_line_schedule.table.sql b/perp/qddlsrc/po_line_schedule.table.sql new file mode 100644 index 00000000..1a3933a5 --- /dev/null +++ b/perp/qddlsrc/po_line_schedule.table.sql @@ -0,0 +1,71 @@ +-- --------------------------------------------------------------------------- +-- Table: po_line_schedule (auto-derived short name) +-- Module: perp +-- Purpose: Blanket-PO delivery schedule. Optional per line — a normal PO +-- line has zero schedule rows and relies on +-- po_line.expected_receipt_date; a blanket line has one row per +-- scheduled delivery. scheduled_qty rolls up per line to the +-- same ordered_qty on po_line (soft warning if it doesn't; +-- see PERP-40 — the maintenance program flags but does not +-- block on the mismatch, since demo flows often adjust +-- ordered_qty after schedules are set). +-- Epic: PERP-7 (PERP-37) +-- --------------------------------------------------------------------------- + +-- 'po_line_schedule' is 16 chars — DB2 will auto-derive a short name +-- (same shape as requisition_header/line, confirmed via DSPOBJD after +-- build). FOR SYSTEM NAME omitted per DDL_STYLE_GUIDE.md Sec.2. +CREATE TABLE po_line_schedule ( + + -- Composite key (per-company, per-PO, per-line, per-schedule-seq) --------- + company_code FOR COLUMN COMPCD CHAR(3) NOT NULL, + po_number FOR COLUMN PONBR BIGINT NOT NULL, + line_number FOR COLUMN LINNBR INTEGER NOT NULL, + schedule_seq FOR COLUMN SCHSEQ INTEGER NOT NULL, + + -- Schedule -------------------------------------------------------------- + scheduled_date FOR COLUMN SCHDT DATE NOT NULL, + scheduled_qty FOR COLUMN SCHQTY DECIMAL(15,4) NOT NULL DEFAULT 0, + received_qty FOR COLUMN RCVQTY DECIMAL(15,4) NOT NULL DEFAULT 0, + + -- 'notes' auto-derives to a valid ≤10-char system name; explicit + -- FOR COLUMN NOTES raises SQL0612 (same finding as elsewhere) — omit. + notes VARCHAR(240) NOT NULL DEFAULT '', + + -- Standard audit block -------------------------------------------------- + created_at FOR COLUMN CRTAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + created_by FOR COLUMN CRTBY VARCHAR(18) NOT NULL DEFAULT USER, + updated_at FOR COLUMN UPDAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_by FOR COLUMN UPDBY VARCHAR(18) NOT NULL DEFAULT USER, + is_active FOR COLUMN ISACT CHAR(1) NOT NULL DEFAULT 'Y', + + -- Composite primary key -------------------------------------------------- + PRIMARY KEY (company_code, po_number, line_number, schedule_seq), + + -- Constraints ----------------------------------------------------------- + CONSTRAINT posch_isact_ck CHECK (is_active IN ('Y','N')), + CONSTRAINT posch_seq_ck CHECK (schedule_seq > 0), + CONSTRAINT posch_schqty_ck CHECK (scheduled_qty > 0), + CONSTRAINT posch_rcvqty_ck CHECK (received_qty >= 0 + AND received_qty <= scheduled_qty), + + -- FK to po_line ----------------------------------------------------------- + CONSTRAINT posch_ln_fk FOREIGN KEY (company_code, po_number, line_number) + REFERENCES po_line (company_code, po_number, line_number) + ON DELETE RESTRICT ON UPDATE RESTRICT +); + +LABEL ON TABLE po_line_schedule IS + 'PERP PO blanket line delivery schedule'; + +LABEL ON COLUMN po_line_schedule ( + company_code IS 'Company code (FK to po_line)', + po_number IS 'PO number (FK to po_line)', + line_number IS 'Line number (FK to po_line)', + schedule_seq IS 'Schedule sequence within line (PK)', + scheduled_date IS 'Scheduled delivery date', + scheduled_qty IS 'Quantity scheduled for this delivery', + received_qty IS 'Quantity received against this schedule', + notes IS 'Schedule notes', + is_active IS 'Active flag (Y/N, soft delete)' +); diff --git a/perp/qddssrc/perpmnu.dspf b/perp/qddssrc/perpmnu.dspf index e77c21c9..347388de 100644 --- a/perp/qddssrc/perpmnu.dspf +++ b/perp/qddssrc/perpmnu.dspf @@ -26,6 +26,7 @@ A 8 7'4. Vendor & Pricing' A 9 7'5. Diagnostics / Smoke Tests' A 10 7'6. Requisitioning' + A 11 7'7. Purchasing' A 12 6'90. Sign off' A 23 2'F3=Exit' A COLOR(BLU) diff --git a/perp/qddssrc/perppom.dspf b/perp/qddssrc/perppom.dspf new file mode 100644 index 00000000..05b43595 --- /dev/null +++ b/perp/qddssrc/perppom.dspf @@ -0,0 +1,32 @@ + A* PERPPOM menu + A DSPSIZ(24 80 *DS3) + A CHGINPDFT + A INDARA + A PRINT(*LIBL/QSYSPRT) + A* CRTMNU TYPE(*DSPF) requires a record format named PERPPOM + A R PERPPOM + A LOCK + A SLNO(01) + A CLRL(*ALL) + A ALWROL + A CF03 + A HELP + A HOME + A HLPRTN + A 1 2'PERPPOM' + A COLOR(BLU) + A 1 25'PERP - Purchasing' + A DSPATR(HI) + A COLOR(WHT) + A 3 2'Select one of the following:' + A COLOR(BLU) + A 5 7'1. Manual PO entry' + A 6 7'2. Create POs from approved requi- + A sitions' + A 7 7'3. Blanket PO schedule maintenance' + A 8 7'4. Browse / inquire POs' + A 23 2'F3=Exit' + A COLOR(BLU) + A* CMDPROMPT Do not delete this DDS spec. + A 021 2'Selection: - + A ' diff --git a/perp/qddssrc/pobrwd.dspf b/perp/qddssrc/pobrwd.dspf new file mode 100644 index 00000000..e515ae64 --- /dev/null +++ b/perp/qddssrc/pobrwd.dspf @@ -0,0 +1,155 @@ + A DSPSIZ(24 80 *DS3) + A PRINT + A CA03(03 'Exit') + A CA05(05 'Refresh') + A CA12(12 'Cancel/Back') + A R BSFL SFL + A 51 SFLNXTCHG + A BSOPT 1A B 12 2 + A 50 DSPATR(RI) + A 50 DSPATR(PC) + A BSPONBR 10A O 12 5 + A BSVNDR 10A O 12 16 + A BSVNDNM 25A O 12 27 + A BSBUYER 10A O 12 53 + A BSORDDT L O 12 64DATFMT(*ISO) + A BSSTAT 6A O 12 75 + A R BSCTL SFLCTL(BSFL) + A SFLSIZ(0099) + A SFLPAG(0006) + A OVERLAY + A SFLDSPCTL + A N31 30 SFLDSP + A 31 SFLCLR + A N31 30 SFLEND(*MORE) + A 1 30'Purchase Order Browse' + A DSPATR(HI) + A 2 2'Company:' + A LCOMPDSP 3A O 2 11 + A 3 2'Filter -- Status:' + A FSTAT 10A B 3 20 + A 3 32'Vendor:' + A FVND 10A B 3 40 + A 3 52'Buyer:' + A FBUY 10A B 3 59 + A 4 2'From date:' + A FFRDT L B 4 13DATFMT(*ISO) + A 4 27'To date:' + A FTODT L B 4 36DATFMT(*ISO) + A 4 50'(blank = no filter)' + A 6 2'Enter=Apply filter' + A 8 2'Type option, press Enter.' + A 9 4'5=Detail 9=Blanket schedules' + A 11 2'Opt' + A DSPATR(UL) + A 11 5'PO #' + A DSPATR(UL) + A 11 16'Vendor' + A DSPATR(UL) + A 11 27'Vendor Name' + A DSPATR(UL) + A 11 53'Buyer' + A DSPATR(UL) + A 11 64'Order Dt' + A DSPATR(UL) + A 11 75'Status' + A DSPATR(UL) + A R BFOOT + A OVERLAY + A 23 2'F3=Exit F5=Refresh F12=Back' + A COLOR(BLU) + A R BNOPO + A OVERLAY + A 14 20'No purchase orders match filter.' + A R BDETAIL + A OVERLAY + A 1 25'PO Detail' + A DSPATR(HI) + A 2 2'PO #:' + A DDPONBR 10A O 2 8 + A 2 22'Vendor:' + A DDVNDR 10A O 2 30 + A DDVNDNM 30A O 2 41 + A 3 2'Buyer:' + A DDBUYR 10A O 3 9 + A 3 22'Order Date:' + A DDORDDT L O 3 34DATFMT(*ISO) + A 3 47'Status:' + A DDSTAT 20A O 3 55 + A 4 2'Total Amount:' + A DDTOT 15Y 2O 4 16EDTCDE(3) + A 4 34'Currency:' + A DDCURR 5A O 4 44 + A 6 2'Lines:' + A 7 2'Line' + A DSPATR(UL) + A 7 7'Item' + A DSPATR(UL) + A 7 33'Ord' + A DSPATR(UL) + A 7 43'Rcv' + A DSPATR(UL) + A 7 53'Open' + A DSPATR(UL) + A 7 62'Price' + A DSPATR(UL) + A 7 72'Src Req' + A DSPATR(UL) + A 60 L1LN 3Y 0O 8 2EDTCDE(3) + A 60 L1ITEM 25A O 8 7 + A 60 L1ORD 10Y 2O 8 33EDTCDE(3) + A 60 L1RCV 10Y 2O 8 43EDTCDE(3) + A 60 L1OPEN 10Y 2O 8 53EDTCDE(3) + A 60 L1PRC 10Y 2O 8 62EDTCDE(3) + A 60 L1SRC 8A O 8 72 + A 61 L2LN 3Y 0O 9 2EDTCDE(3) + A 61 L2ITEM 25A O 9 7 + A 61 L2ORD 10Y 2O 9 33EDTCDE(3) + A 61 L2RCV 10Y 2O 9 43EDTCDE(3) + A 61 L2OPEN 10Y 2O 9 53EDTCDE(3) + A 61 L2PRC 10Y 2O 9 62EDTCDE(3) + A 61 L2SRC 8A O 9 72 + A 62 L3LN 3Y 0O 10 2EDTCDE(3) + A 62 L3ITEM 25A O 10 7 + A 62 L3ORD 10Y 2O 10 33EDTCDE(3) + A 62 L3RCV 10Y 2O 10 43EDTCDE(3) + A 62 L3OPEN 10Y 2O 10 53EDTCDE(3) + A 62 L3PRC 10Y 2O 10 62EDTCDE(3) + A 62 L3SRC 8A O 10 72 + A 63 L4LN 3Y 0O 11 2EDTCDE(3) + A 63 L4ITEM 25A O 11 7 + A 63 L4ORD 10Y 2O 11 33EDTCDE(3) + A 63 L4RCV 10Y 2O 11 43EDTCDE(3) + A 63 L4OPEN 10Y 2O 11 53EDTCDE(3) + A 63 L4PRC 10Y 2O 11 62EDTCDE(3) + A 63 L4SRC 8A O 11 72 + A 64 L5LN 3Y 0O 12 2EDTCDE(3) + A 64 L5ITEM 25A O 12 7 + A 64 L5ORD 10Y 2O 12 33EDTCDE(3) + A 64 L5RCV 10Y 2O 12 43EDTCDE(3) + A 64 L5OPEN 10Y 2O 12 53EDTCDE(3) + A 64 L5PRC 10Y 2O 12 62EDTCDE(3) + A 64 L5SRC 8A O 12 72 + A 65 L6LN 3Y 0O 13 2EDTCDE(3) + A 65 L6ITEM 25A O 13 7 + A 65 L6ORD 10Y 2O 13 33EDTCDE(3) + A 65 L6RCV 10Y 2O 13 43EDTCDE(3) + A 65 L6OPEN 10Y 2O 13 53EDTCDE(3) + A 65 L6PRC 10Y 2O 13 62EDTCDE(3) + A 65 L6SRC 8A O 13 72 + A 34 15 2'More lines exist -- not all shown.' + A 17 2'Schedules:' + A DDSCH 50A O 17 13 + A 23 2'F12=Back F5=Refresh' + A COLOR(BLU) + A R RMSGSFL SFL + A SFLMSGRCD(24) + A SMSGKEY SFLMSGKEY + A SPGMQ SFLPGMQ(10) + A R RMSGCTL SFLCTL(RMSGSFL) + A OVERLAY + A N41 40 SFLDSP + A 41 SFLCLR + A N41 40 SFLEND + A SFLSIZ(0002) + A SFLPAG(0001) diff --git a/perp/qddssrc/poentd.dspf b/perp/qddssrc/poentd.dspf new file mode 100644 index 00000000..885cfff2 --- /dev/null +++ b/perp/qddssrc/poentd.dspf @@ -0,0 +1,116 @@ + A DSPSIZ(24 80 *DS3) + A PRINT + A CA03(03 'Exit') + A CA05(05 'Refresh') + A CA06(06 'Add') + A CA08(08 'Submit') + A CA12(12 'Cancel') + A R PHEAD + A OVERLAY + A 1 30'Purchase Order Entry' + A DSPATR(HI) + A 2 2'Company:' + A HCOMPDSP 3A O 2 11 + A 3 2'Vendor Code:' + A HVNDCD 10A B 3 15 + A HVNDNM 30A O 3 28 + A 4 2'Buyer:' + A HBUYCD 10A O 4 9 + A DSPATR(HI) + A 4 22'(defaulted from vendor)' + A 5 2'Order Date:' + A HORDDT L B 5 14DATFMT(*ISO) + A 5 26'(YYYY-MM-DD)' + A 6 2'Notes:' + A HNOTES 50A B 6 9 + A 23 2'F3=Exit F12=Cancel' + A COLOR(BLU) + A R PLSFL SFL + A 51 SFLNXTCHG + A SLOPT 1A B 9 2 + A 50 DSPATR(RI) + A 50 DSPATR(PC) + A SLLINE 3Y 0O 9 5 + A SLITEM 25A O 9 10 + A SLQTY 15Y 4O 9 36EDTCDE(3) + A SLUOM 5A O 9 54 + A SLPRICE 15Y 4O 9 61EDTCDE(3) + A R PLCTL SFLCTL(PLSFL) + A SFLSIZ(0099) + A SFLPAG(0007) + A OVERLAY + A SFLDSPCTL + A N31 30 SFLDSP + A 31 SFLCLR + A N31 30 SFLEND(*MORE) + A 1 30'Purchase Order Lines' + A DSPATR(HI) + A 2 2'PO #:' + A DPONBR 15A O 2 8 + A 2 40'Vendor:' + A DVNDCD 10A O 2 48 + A DVNDNM 30A O 2 59 + A 3 2'Buyer:' + A DBUYCD 10A O 3 9 + A 3 40'Order Date:' + A DORDDT L O 3 52DATFMT(*ISO) + A 4 2'Status:' + A DSTATUS 20A O 4 10 + A 4 40'Total Amount:' + A DTOTAMT 15Y 2O 4 54EDTCDE(3) + A 6 2'Type option, press Enter.' + A 7 4'2=Change 4=Delete' + A 8 2'Opt' + A DSPATR(UL) + A 8 5'Line' + A DSPATR(UL) + A 8 10'Item' + A DSPATR(UL) + A 8 36'Ord Qty' + A DSPATR(UL) + A 8 54'UOM' + A DSPATR(UL) + A 8 61'Unit Price' + A DSPATR(UL) + A R PLFOOT + A OVERLAY + A 23 2'F3=Exit F5=Refresh F6=Add F8=Su- + A bmit F12=Cancel' + A COLOR(BLU) + A R PNOLIN + A OVERLAY + A 11 20'No lines yet. Press F6=Add.' + A R PLEDIT + A OVERLAY + A 1 25'Add/Change PO Line' + A DSPATR(HI) + A 2 2'Mode:' + A EMODE 1A O 2 8 + A 3 2'Item Number:' + A EITEM 25A B 3 15 + A EITMDSC 40A O 3 42 + A DSPATR(HI) + A 4 2'Quantity:' + A EQTY 15Y 4B 4 12EDTCDE(3) + A 5 2'UOM:' + A EUOM 5A B 5 7 + A 5 15'(blank = default from item)' + A 6 2'Unit Price:' + A EPRICE 15Y 4B 6 14EDTCDE(3) + A 6 33'(0 = default from vendor)' + A 7 2'Expected Recv Date:' + A EEXPDT L B 7 22DATFMT(*ISO) + A 7 34'(blank = none)' + A 23 2'Enter=Save F12=Cancel' + A COLOR(BLU) + A R PMSGSFL SFL + A SFLMSGRCD(24) + A SMSGKEY SFLMSGKEY + A SPGMQ SFLPGMQ(10) + A R PMSGCTL SFLCTL(PMSGSFL) + A OVERLAY + A N41 40 SFLDSP + A 41 SFLCLR + A N41 40 SFLEND + A SFLSIZ(0002) + A SFLPAG(0001) diff --git a/perp/qddssrc/poreqd.dspf b/perp/qddssrc/poreqd.dspf new file mode 100644 index 00000000..0070f059 --- /dev/null +++ b/perp/qddssrc/poreqd.dspf @@ -0,0 +1,112 @@ + A DSPSIZ(24 80 *DS3) + A PRINT + A CA03(03 'Exit') + A CA05(05 'Refresh') + A CA06(06 'Convert/Confirm') + A CA12(12 'Cancel/Back') + A R SSFL SFL + A 51 SFLNXTCHG + A SSOPT 1A B 9 2 + A 50 DSPATR(RI) + A 50 DSPATR(PC) + A SSREQNBR 8A O 9 5 + A SSREQBY 10A O 9 14 + A SSNEEDBY L O 9 25DATFMT(*ISO) + A SSVNDR 10A O 9 36 + A SSVNDNM 25A O 9 47 + A SSTOTEST 15Y 2O 9 73EDTCDE(3) + A R SSCTL SFLCTL(SSFL) + A SFLSIZ(0099) + A SFLPAG(0007) + A OVERLAY + A SFLDSPCTL + A N31 30 SFLDSP + A 31 SFLCLR + A N31 30 SFLEND(*MORE) + A 1 22'Create POs from Approved Requisi- + A tions' + A DSPATR(HI) + A 2 2'Company:' + A LCOMPDSP 3A O 2 11 + A 6 2'Type option 1=Select, press Enter- + A , then F6=Convert.' + A 8 2'Opt' + A DSPATR(UL) + A 8 5'Req #' + A DSPATR(UL) + A 8 14'Requested By' + A DSPATR(UL) + A 8 25'Need By' + A DSPATR(UL) + A 8 36'Vendor' + A DSPATR(UL) + A 8 47'Vendor Name' + A DSPATR(UL) + A 8 73'Est Cost' + A DSPATR(UL) + A R SFOOT + A OVERLAY + A 23 2'F3=Exit F5=Refresh F6=Convert - + A F12=Cancel' + A COLOR(BLU) + A R SNOSUB + A OVERLAY + A 11 20'No approved requisitions to conv- + A ert.' + A R SPREV + A OVERLAY + A 1 25'Preview - POs to Create' + A DSPATR(HI) + A 2 2'Company:' + A PCOMPDSP 3A O 2 11 + A 3 2'Selected requisitions:' + A PSELCNT 4Y 0O 3 26EDTCDE(3) + A 3 34'lines:' + A PLNCNT 4Y 0O 3 41EDTCDE(3) + A 3 47'PO count:' + A PPOCNT 4Y 0O 3 57EDTCDE(3) + A 5 2'The following POs will be created- + A :' + A 6 2'Vendor' + A DSPATR(UL) + A 6 12'Vendor Name' + A DSPATR(UL) + A 6 43'Lines' + A DSPATR(UL) + A 6 51'Total Amount' + A DSPATR(UL) + A 60 P1VNDR 10A O 7 2 + A 60 P1VNDNM 30A O 7 12 + A 60 P1LNS 4Y 0O 7 43EDTCDE(3) + A 60 P1TOT 15Y 2O 7 51EDTCDE(3) + A 61 P2VNDR 10A O 8 2 + A 61 P2VNDNM 30A O 8 12 + A 61 P2LNS 4Y 0O 8 43EDTCDE(3) + A 61 P2TOT 15Y 2O 8 51EDTCDE(3) + A 62 P3VNDR 10A O 9 2 + A 62 P3VNDNM 30A O 9 12 + A 62 P3LNS 4Y 0O 9 43EDTCDE(3) + A 62 P3TOT 15Y 2O 9 51EDTCDE(3) + A 63 P4VNDR 10A O 10 2 + A 63 P4VNDNM 30A O 10 12 + A 63 P4LNS 4Y 0O 10 43EDTCDE(3) + A 63 P4TOT 15Y 2O 10 51EDTCDE(3) + A 64 P5VNDR 10A O 11 2 + A 64 P5VNDNM 30A O 11 12 + A 64 P5LNS 4Y 0O 11 43EDTCDE(3) + A 64 P5TOT 15Y 2O 11 51EDTCDE(3) + A 34 13 2'More vendors exist -- not all sho- + A wn.' + A 15 2'F6=Confirm create F12=Back' + A COLOR(BLU) + A R RMSGSFL SFL + A SFLMSGRCD(24) + A SMSGKEY SFLMSGKEY + A SPGMQ SFLPGMQ(10) + A R RMSGCTL SFLCTL(RMSGSFL) + A OVERLAY + A N41 40 SFLDSP + A 41 SFLCLR + A N41 40 SFLEND + A SFLSIZ(0002) + A SFLPAG(0001) diff --git a/perp/qddssrc/poschd.dspf b/perp/qddssrc/poschd.dspf new file mode 100644 index 00000000..889f3737 --- /dev/null +++ b/perp/qddssrc/poschd.dspf @@ -0,0 +1,111 @@ + A DSPSIZ(24 80 *DS3) + A PRINT + A CA03(03 'Exit') + A CA05(05 'Refresh') + A CA06(06 'Add') + A CA12(12 'Cancel') + A R HHEAD + A OVERLAY + A 1 25'Blanket PO Schedule' + A DSPATR(HI) + A 2 2'Company:' + A HCOMPDSP 3A O 2 11 + A 3 2'PO Number:' + A HPONBR 10A B 3 13 + A 4 2'Line Number:' + A HLINE 3Y 0B 4 15EDTCDE(3) + A 23 2'Enter=Load F3=Exit F12=Cance- + A l' + A COLOR(BLU) + A R HSFL SFL + A 51 SFLNXTCHG + A SLOPT 1A B 10 2 + A 50 DSPATR(RI) + A 50 DSPATR(PC) + A SLSEQ 3Y 0O 10 5 + A SLSCHDT L O 10 10DATFMT(*ISO) + A SLSCHQTY 15Y 4O 10 22EDTCDE(3) + A SLRCVQTY 15Y 4O 10 40EDTCDE(3) + A SLSCHNOT 30A O 10 58 + A R HSCTL SFLCTL(HSFL) + A SFLSIZ(0099) + A SFLPAG(0007) + A OVERLAY + A SFLDSPCTL + A N31 30 SFLDSP + A 31 SFLCLR + A N31 30 SFLEND(*MORE) + A 1 25'Blanket PO Schedule' + A DSPATR(HI) + A 2 2'PO #:' + A DPONBR 10A O 2 8 + A 2 20'Line:' + A DLINE 3Y 0O 2 26EDTCDE(3) + A 2 35'Item:' + A DITEM 25A O 2 41 + A 3 2'Vendor:' + A DVNDCD 10A O 3 10 + A 3 22'Ord Qty:' + A DORDQTY 15Y 4O 3 31EDTCDE(3) + A 3 47'UOM:' + A DUOM 5A O 3 52 + A 4 2'Sched Total:' + A DSCHTOT 15Y 4O 4 15EDTCDE(3) + A 4 32'Recv Total:' + A DRCVTOT 15Y 4O 4 44EDTCDE(3) + A 70 5 2'** Scheduled qty exceeds ordered qty *- + A *' + A COLOR(RED) + A DSPATR(HI) + A 7 2'Type option, press Enter.' + A 8 4'2=Change 4=Delete' + A 9 2'Opt' + A DSPATR(UL) + A 9 5'Seq' + A DSPATR(UL) + A 9 10'Scheduled' + A DSPATR(UL) + A 9 22'Sched Qty' + A DSPATR(UL) + A 9 40'Recv Qty' + A DSPATR(UL) + A 9 58'Notes' + A DSPATR(UL) + A R HFOOT + A OVERLAY + A 23 2'F3=Exit F5=Refresh F6=Add F12=- + A Cancel' + A COLOR(BLU) + A R HNOSCH + A OVERLAY + A 12 20'No schedules yet. Press F6=Add.' + A R HEDIT + A OVERLAY + A 1 25'Add/Change Schedule' + A DSPATR(HI) + A 2 2'Mode:' + A EMODE 1A O 2 8 + A 3 2'Seq:' + A ESEQ 3Y 0O 3 7EDTCDE(3) + A 4 2'Scheduled Date:' + A ESCHDT L B 4 18DATFMT(*ISO) + A 4 30'(YYYY-MM-DD)' + A 5 2'Scheduled Qty:' + A ESCHQTY 15Y 4B 5 17EDTCDE(3) + A 6 2'Received Qty:' + A ERCVQTY 15Y 4B 6 16EDTCDE(3) + A 7 2'Notes:' + A ENOTES 50A B 7 9 + A 23 2'Enter=Save F12=Cancel' + A COLOR(BLU) + A R HMSGSFL SFL + A SFLMSGRCD(24) + A SMSGKEY SFLMSGKEY + A SPGMQ SFLPGMQ(10) + A R HMSGCTL SFLCTL(HMSGSFL) + A OVERLAY + A N41 40 SFLDSP + A 41 SFLCLR + A N41 40 SFLEND + A SFLSIZ(0002) + A SFLPAG(0001) diff --git a/perp/qrpglesrc/pobrwr.sqlrpgle b/perp/qrpglesrc/pobrwr.sqlrpgle new file mode 100644 index 00000000..78e4e338 --- /dev/null +++ b/perp/qrpglesrc/pobrwr.sqlrpgle @@ -0,0 +1,456 @@ +**free + +// --------------------------------------------------------------------- +// Program: pobrwr (PO Browse & Inquiry) +// Purpose: Filterable subfile of PO headers with drill-down to detail. +// Filters: status_code, vendor_code, buyer_code, order-date +// range. Enter reloads the subfile with the current filter +// values. +// +// Option 5 on a PO switches to plain-record BDETAIL showing +// header + up to 6 lines joined to po_line_open for open_qty +// and extended_price + a src-req display + a schedule +// summary line. Follows reqaprr's "one subfile + plain +// detail" shape (DDL_STYLE_GUIDE.md Sec.14) to avoid the +// CPF5006 two-subfile crash. +// +// Option 9 calls poschr for the selected PO (line 1) so the +// user can drill into blanket schedules without leaving the +// browse -- if the PO has no lines, that call falls through +// to the schedule program's own not-found message. +// Epic: PERP-7 (PERP-41) +// --------------------------------------------------------------------- + +// datfmt(*iso) is REQUIRED here (not decorative) -- filter defaults +// use 0001-01-01 / 9999-12-31 as sentinels, and the job DATFMT on +// this environment is *MDY (2-digit year, 1940-2039). Without this +// ctl-opt, every Date variable in this program is capped at *MDY's +// range and RNQ0114 fires at runtime the first time the DSPF WRITEs +// the FFRDT/FTODT fields or the SQL fetches one. +ctl-opt dftactgrp(*no) actgrp(*new) datfmt(*iso); + +dcl-f pobrwd workstn sfile(bsfl:rrn) sfile(rmsgsfl:msgrrn); + +dcl-ds ldaDS dtaara(*lda) len(1024) qualified; + compcd char(3) pos(1); +end-ds; + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-pr poschCall extpgm('POSCHR'); + in_ponbr char(10) const; + in_line packed(3:0) const; +end-pr; + +dcl-ds statusDS psds qualified; + programName char(10) pos(334); +end-ds; + +dcl-ds poRow qualified; + ponbr int(20); + vndcd char(10); + vndnm varchar(60); + buyer char(10); + orddt date; + stat varchar(20); +end-ds; + +dcl-ds rows likeds(poRow) dim(500); +dcl-s numRows int(10); +dcl-s rrn int(10); +dcl-s msgrrn int(10); +dcl-s selRrn int(10); +dcl-s i int(10); +dcl-s compcd char(3); +dcl-s selOpt char(1); +dcl-s selPo int(20); +dcl-s firstLine int(10); +dcl-s cnt int(10); + +// Cursor scalars. +dcl-s cPo int(20); +dcl-s cVnd char(10); +dcl-s cVndNm varchar(60); +dcl-s cBuyer char(10); +dcl-s cOrdDt date; +dcl-s cStat varchar(20); +dcl-s cCurr varchar(20); +dcl-s cTot packed(15:2); +dcl-s cLine int(10); +dcl-s cItem varchar(25); +dcl-s cOrd packed(15:4); +dcl-s cRcv packed(15:4); +dcl-s cOpen packed(15:4); +dcl-s cPrice packed(15:4); +dcl-s cSrcReq int(20); +dcl-s cSrcLn int(10); +dcl-s cSchCnt int(10); + +// Locals used by showDetail/putLine -- hoisted to main scope; dcl-s +// inside a begsr triggers RNF0724 (DDL_STYLE_GUIDE.md Sec.13). +dcl-s ln int(10); +dcl-s schedTot packed(15:4); +dcl-s schedCnt int(10); +dcl-s srcTxt char(8); + +in ldaDS; +compcd = ldaDS.compcd; + +if compcd = ''; + exsr clearMsgs; + writeMsg('No company selected - run Select Company (PERPSELR) first.'); + *in40 = *on; + lcompdsp = ''; + write rmsgctl; + exfmt bfoot; + *inlr = *on; + return; +endif; + +lcompdsp = compcd; +// Initial filter state -- everything. +fstat = ''; +fvnd = ''; +fbuy = ''; +// Filter sentinels must be within the *MDY 1940-2039 range: the SQL +// precompiler generates its intermediate host variables (SQL_00020 / +// SQL_00021 for :ffrdt / :ftodt) with the JOB DATFMT (*MDY on this +// env), IGNORING the ctl-opt datfmt(*iso). Assigning any date outside +// 1940-2039 into those generated vars crashes with RNQ0114. 1940 and +// 2039 both safely bracket every realistic PO order_date. Also parse +// with :*ISO in case a future ctl-opt change drops the datfmt override. +ffrdt = %date('1940-01-01' : *ISO); +ftodt = %date('2039-12-31' : *ISO); + +// ----------------------------------------------------------------------- +// Browse loop. +// ----------------------------------------------------------------------- +dow '1'; + exsr loadPOs; + + if numRows = 0; + *in30 = *off; + write bnopo; + else; + exsr fillBSFL; + *in30 = *on; + endif; + + write bfoot; + *in40 = *off; + if msgrrn > 0; + *in40 = *on; + endif; + write rmsgctl; + exfmt bsctl; + + if *in03 or *in12; + leave; + endif; + + exsr clearMsgs; + + // Handle selections (Opt 5 = detail, Opt 9 = schedule maintenance). + if numRows > 0; + selRrn = 0; + selOpt = ' '; + selPo = 0; + readc bsfl; + dow not %eof(pobrwd); + if bsopt <> ''; + if selRrn = 0; + selRrn = rrn; + selOpt = bsopt; + selPo = rows(rrn).ponbr; + else; + writeMsg('Only one selection per Enter.'); + endif; + endif; + readc bsfl; + enddo; + + if selRrn > 0 and msgrrn = 0; + select; + when selOpt = '5'; + exsr showDetail; + when selOpt = '9'; + // Find the first (lowest-numbered) line to hand to poschr. + exec sql + select coalesce(min(line_number), 0) + into :firstLine + from perpdemo.po_line + where company_code = :compcd + and po_number = :selPo; + if firstLine = 0; + writeMsg('PO ' + %char(selPo) + ' has no lines yet.'); + else; + poschCall(%char(selPo) : firstLine); + endif; + other; + writeMsg('Option ' + selOpt + ' not valid.'); + endsl; + endif; + endif; +enddo; + +*inlr = *on; +return; + +// --------------------------------------------------------------------- +// loadPOs -- pull PO headers matching the current filter values. +// Empty filter fields skip that filter (fstat='' means "any status", +// etc.). +// --------------------------------------------------------------------- +begsr loadPOs; + numRows = 0; + + exec sql declare bc1 cursor for + select h.po_number, h.vendor_code, v.vendor_name, h.buyer_code, + h.order_date, h.status_code + from perpdemo.po_header h + join perpdemo.vendor v + on v.company_code = h.company_code and v.vendor_code = h.vendor_code + where h.company_code = :compcd + and (:fstat = '' or h.status_code = :fstat) + and (:fvnd = '' or h.vendor_code = :fvnd) + and (:fbuy = '' or h.buyer_code = :fbuy) + and h.order_date between :ffrdt and :ftodt + order by h.po_number desc; + exec sql open bc1; + if sqlcode < 0; + writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode) + + ' STATE=' + sqlstate); + return; + endif; + + dow numRows < %elem(rows); + exec sql fetch bc1 into :cPo, :cVnd, :cVndNm, :cBuyer, + :cOrdDt, :cStat; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + numRows += 1; + rows(numRows).ponbr = cPo; + rows(numRows).vndcd = cVnd; + rows(numRows).vndnm = cVndNm; + rows(numRows).buyer = cBuyer; + rows(numRows).orddt = cOrdDt; + rows(numRows).stat = cStat; + enddo; + exec sql close bc1; +endsr; + +// --------------------------------------------------------------------- +begsr fillBSFL; + rrn = 0; + *in31 = *on; + write bsctl; + *in31 = *off; + for i = 1 to numRows; + bsopt = ''; + bsponbr = %char(rows(i).ponbr); + bsvndr = rows(i).vndcd; + // Direct assign VARCHAR -> fixed CHAR: RPG right-pads or truncates + // automatically. %subst is strict about the CURRENT length of a + // VARCHAR (not the declared max) and raises RNQ0100 when a value + // like 'DRAFT' (5 chars) is asked for 10 chars. + bsvndnm = rows(i).vndnm; + bsbuyer = rows(i).buyer; + bsorddt = rows(i).orddt; + bsstat = rows(i).stat; + rrn += 1; + write bsfl; + endfor; +endsr; + +// --------------------------------------------------------------------- +// showDetail -- populate BDETAIL fields for the selected PO and up +// to 6 lines from po_line_open. EXFMT once; Enter or F12 returns +// to the browse. +// --------------------------------------------------------------------- +begsr showDetail; + exec sql + select h.vendor_code, v.vendor_name, h.buyer_code, h.order_date, + h.status_code, h.total_amount, h.currency_code + into :cVnd, :cVndNm, :cBuyer, :cOrdDt, :cStat, :cTot, :cCurr + from perpdemo.po_header h + join perpdemo.vendor v + on v.company_code = h.company_code and v.vendor_code = h.vendor_code + where h.company_code = :compcd and h.po_number = :selPo; + if sqlcode <> 0; + writeMsg('PO ' + %char(selPo) + ' lookup failed: SQLCODE=' + + %char(sqlcode)); + return; + endif; + + ddponbr = %char(selPo); + ddvndr = cVnd; + ddvndnm = cVndNm; + ddbuyr = cBuyer; + ddorddt = cOrdDt; + ddstat = cStat; + ddtot = cTot; + ddcurr = cCurr; + + // Turn off all line indicators. + *in60 = *off; + *in61 = *off; + *in62 = *off; + *in63 = *off; + *in64 = *off; + *in65 = *off; + *in34 = *off; + + ln = 0; + exec sql declare bc2 cursor for + select line_number, item_number, ordered_qty, received_qty, open_qty, + unit_price, + coalesce(source_requisition_number, 0), + coalesce(source_requisition_line_number, 0) + from perpdemo.po_line_open + where company_code = :compcd and po_number = :selPo + order by line_number; + exec sql open bc2; + + dow '1'; + exec sql fetch bc2 into :cLine, :cItem, :cOrd, :cRcv, :cOpen, + :cPrice, :cSrcReq, :cSrcLn; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + ln += 1; + if ln > 6; + *in34 = *on; + leave; + endif; + exsr putLine; + enddo; + exec sql close bc2; + + // Schedule summary: count + total scheduled qty across ALL lines + // of this PO. + exec sql + select count(*), coalesce(sum(scheduled_qty), 0) + into :schedCnt, :schedTot + from perpdemo.po_line_schedule + where company_code = :compcd and po_number = :selPo; + if schedCnt = 0; + ddsch = 'None'; + else; + ddsch = %char(schedCnt) + ' schedule(s), total qty ' + + %char(schedTot); + endif; + + *in40 = *off; + if msgrrn > 0; + *in40 = *on; + endif; + write rmsgctl; + exfmt bdetail; +endsr; + +// putLine -- ln, cItem, cOrd, cRcv, cOpen, cPrice, cSrcReq, cSrcLn +// already staged; fan out to L* fields by row. +begsr putLine; + if cSrcReq = 0; + srcTxt = ''; + else; + srcTxt = %char(cSrcReq) + '/' + %char(cSrcLn); + endif; + select; + when ln = 1; + *in60 = *on; + l1ln = cLine; + l1item = cItem; + l1ord = cOrd; + l1rcv = cRcv; + l1open = cOpen; + l1prc = cPrice; + l1src = srcTxt; + when ln = 2; + *in61 = *on; + l2ln = cLine; + l2item = cItem; + l2ord = cOrd; + l2rcv = cRcv; + l2open = cOpen; + l2prc = cPrice; + l2src = srcTxt; + when ln = 3; + *in62 = *on; + l3ln = cLine; + l3item = cItem; + l3ord = cOrd; + l3rcv = cRcv; + l3open = cOpen; + l3prc = cPrice; + l3src = srcTxt; + when ln = 4; + *in63 = *on; + l4ln = cLine; + l4item = cItem; + l4ord = cOrd; + l4rcv = cRcv; + l4open = cOpen; + l4prc = cPrice; + l4src = srcTxt; + when ln = 5; + *in64 = *on; + l5ln = cLine; + l5item = cItem; + l5ord = cOrd; + l5rcv = cRcv; + l5open = cOpen; + l5prc = cPrice; + l5src = srcTxt; + when ln = 6; + *in65 = *on; + l6ln = cLine; + l6item = cItem; + l6ord = cOrd; + l6rcv = cRcv; + l6open = cOpen; + l6prc = cPrice; + l6src = srcTxt; + endsl; +endsr; + +// --------------------------------------------------------------------- +begsr clearMsgs; + msgrrn = 0; + *in41 = *on; + write rmsgctl; + *in41 = *off; +endsr; + +// --------------------------------------------------------------------- +dcl-proc writeMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + smsgkey : + x'0000000000000000'); + msgrrn += 1; + spgmq = statusDS.programName; + write rmsgsfl; +end-proc; diff --git a/perp/qrpglesrc/poentr.sqlrpgle b/perp/qrpglesrc/poentr.sqlrpgle new file mode 100644 index 00000000..3b10a62b --- /dev/null +++ b/perp/qrpglesrc/poentr.sqlrpgle @@ -0,0 +1,544 @@ +**free + +// --------------------------------------------------------------------- +// Program: poentr (Manual Purchase Order Entry) +// Purpose: DSPF-based manual PO entry, scoped by the company selected +// via perpselr (*LDA positions 1-3). Header screen collects +// vendor / order date / notes; buyer_code is snapshotted from +// vendor at header commit. Currency is hard-coded to USD -- +// the code_master CURRENCY lookup only has 'USD' in it today +// and there's no per-company override yet. Allocates the doc +// number via docseq_next('PO'), then inserts a DRAFT header. +// Line screen is a subfile of po_line rows -- F6=Add opens an +// edit panel that defaults UOM from item and unit_price from +// the preferred vendor's current item_vendor_price row. +// F8=Submit requires >=1 line and flips status to OPEN; +// no further changes are allowed once submitted. +// Epic: PERP-7 (PERP-38) +// --------------------------------------------------------------------- + +// datfmt(*iso) is REQUIRED (not decorative) -- eexpdt uses 0001-01-01 +// as its "no expected receipt date" sentinel, and the job DATFMT on +// this environment is *MDY (2-digit year, 1940-2039). Without this +// ctl-opt, RPG Date variables are capped at that range and any +// out-of-range value crashes at runtime with RNQ0114. +ctl-opt dftactgrp(*no) actgrp(*new) bnddir('PERP') datfmt(*iso); + +dcl-f poentd workstn sfile(plsfl:rrn) sfile(pmsgsfl:msgrrn); + +/copy docseq_pr.rpgle + +dcl-ds ldaDS dtaara(*lda) len(1024) qualified; + compcd char(3) pos(1); +end-ds; + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-ds statusDS psds qualified; + programName char(10) pos(334); +end-ds; + +dcl-ds lineRow qualified; + lnbr int(10); + item varchar(25); + qty packed(15:4); + uom varchar(5); + price packed(15:4); +end-ds; + +dcl-ds rows likeds(lineRow) dim(500); +dcl-s numRows int(10); +dcl-s i int(10); +dcl-s rrn int(10); +dcl-s msgrrn int(10); +dcl-s selRrn int(10); +dcl-s changeRrn int(10); +dcl-s selOpt char(1); +dcl-s compcd char(3); +dcl-s ponbr int(20); +dcl-s docerrmsg varchar(80); +dcl-s poStatus varchar(20); +dcl-s nextLine int(10); +dcl-s chgLnbr int(10); +dcl-s cnt int(10); +dcl-s edefuom varchar(5); +dcl-s edefprice packed(15:4); +dcl-s edesc varchar(60); +dcl-s hbuyer char(10); +dcl-s hvname varchar(60); + +in ldaDS; +compcd = ldaDS.compcd; + +if compcd = ''; + exsr clearMsgs; + writeMsg('No company selected - run Select Company (PERPSELR) first.'); + *in40 = *on; + write pmsgctl; + hcompdsp = ''; + exfmt phead; + *inlr = *on; + return; +endif; + +hcompdsp = compcd; + +// ----------------------------------------------------------------------- +// Header entry -- collect vendor / order_date / notes, validate, +// snapshot buyer from vendor, allocate the doc number, insert the +// DRAFT header. Currency is hard-coded to USD (see program header). +// ----------------------------------------------------------------------- +hvndcd = ''; +hvndnm = ''; +hbuycd = ''; +horddt = %date(); +hnotes = ''; + +exsr clearMsgs; + +dow '1'; + *in40 = *off; + if msgrrn > 0; + *in40 = *on; + endif; + exfmt phead; + + if *in03 or *in12; + *inlr = *on; + return; + endif; + + exsr clearMsgs; + + if %trim(hvndcd) = ''; + writeMsg('Vendor Code is required.'); + iter; + endif; + + exec sql + select vendor_name, buyer_code + into :hvname, :hbuyer + from perpdemo.vendor + where company_code = :compcd and vendor_code = :hvndcd + and is_active = 'Y'; + if sqlcode <> 0; + writeMsg('Vendor ' + %trim(hvndcd) + ' not found for this company.'); + iter; + endif; + + hvndnm = hvname; + hbuycd = hbuyer; + + leave; +enddo; + +ponbr = docseq_next(compcd : 'PO' : docerrmsg); +if ponbr = 0; + writeMsg('Could not allocate PO number: ' + docerrmsg); + *inlr = *on; + return; +endif; + +// currency_code defaults to 'USD' via the po_header DDL default; leave +// it out of the column list so any future default change lands here +// too. +exec sql + insert into perpdemo.po_header + (company_code, po_number, vendor_code, buyer_code, order_date, + notes) + values (:compcd, :ponbr, :hvndcd, :hbuycd, :horddt, :hnotes); +if sqlcode < 0; + writeMsg('Could not create PO: SQLCODE=' + %char(sqlcode)); + *inlr = *on; + return; +endif; + +exec sql commit; + +// ----------------------------------------------------------------------- +// Line entry -- subfile of po_line rows. +// ----------------------------------------------------------------------- +exsr clearMsgs; +writeMsg('PO ' + %char(ponbr) + ' created (DRAFT) for vendor ' + + %trim(hvndcd) + '. Add lines, then F8=Submit.'); + +dow '1'; + exsr loadHeader; + exsr loadLines; + + if numRows = 0; + *in30 = *off; + write pnolin; + else; + exsr fillSubfile; + *in30 = *on; + endif; + + write plfoot; + *in40 = *off; + if msgrrn > 0; + *in40 = *on; + endif; + write pmsgctl; + exfmt plctl; + + if *in03 or *in12; + leave; + endif; + + exsr clearMsgs; + + if *in06; + if poStatus <> 'DRAFT'; + writeMsg('PO already submitted - no further changes allowed.'); + else; + exsr addLine; + endif; + iter; + endif; + + if *in08; + if numRows = 0; + writeMsg('At least one line is required before submitting.'); + elseif poStatus <> 'DRAFT'; + writeMsg('PO already submitted.'); + else; + exec sql + update perpdemo.po_header + set status_code = 'OPEN', + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd and po_number = :ponbr; + if sqlcode < 0; + writeMsg('Submit failed: SQLCODE=' + %char(sqlcode)); + else; + exec sql commit; + writeMsg('PO ' + %char(ponbr) + ' submitted (OPEN).'); + endif; + endif; + iter; + endif; + + // Drain the READC loop before switching to PLEDIT for a change + // (option 2). Same fix pattern as reqentr.sqlrpgle / DDL_STYLE_GUIDE + // Sec.14 -- collect the row to change while draining, act on it after + // the loop finishes. + if numRows > 0; + selRrn = 0; + selOpt = ' '; + changeRrn = 0; + readc plsfl; + dow not %eof(poentd); + if slopt <> ''; + selRrn = rrn; + selOpt = slopt; + exsr handleOpt; + selRrn = 0; + endif; + readc plsfl; + enddo; + + if changeRrn > 0 and msgrrn = 0; + selRrn = changeRrn; + exsr changeLine; + endif; + endif; + +enddo; + +*inlr = *on; +return; + +// --------------------------------------------------------------------- +begsr loadHeader; + exec sql + select h.status_code, h.vendor_code, v.vendor_name, h.buyer_code, + h.order_date, h.total_amount + into :poStatus, :dvndcd, :dvndnm, :dbuycd, :dorddt, :dtotamt + from perpdemo.po_header h + join perpdemo.vendor v + on v.company_code = h.company_code and v.vendor_code = h.vendor_code + where h.company_code = :compcd and h.po_number = :ponbr; + dponbr = %char(ponbr); + dstatus = poStatus; +endsr; + +// --------------------------------------------------------------------- +begsr loadLines; + numRows = 0; + exec sql declare pc1 cursor for + select line_number, item_number, ordered_qty, uom_code, unit_price + from perpdemo.po_line + where company_code = :compcd and po_number = :ponbr + order by line_number; + exec sql open pc1; + if sqlcode < 0; + writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); + return; + endif; + + dow numRows < %elem(rows); + exec sql fetch pc1 into :lineRow.lnbr, :lineRow.item, :lineRow.qty, + :lineRow.uom, :lineRow.price; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + numRows += 1; + rows(numRows) = lineRow; + enddo; + exec sql close pc1; +endsr; + +// --------------------------------------------------------------------- +begsr fillSubfile; + rrn = 0; + *in31 = *on; + write plctl; + *in31 = *off; + for i = 1 to numRows; + slopt = ''; + slline = rows(i).lnbr; + slitem = rows(i).item; + slqty = rows(i).qty; + sluom = rows(i).uom; + slprice = rows(i).price; + rrn += 1; + write plsfl; + endfor; +endsr; + +// --------------------------------------------------------------------- +begsr handleOpt; + chain selRrn plsfl; + if %found(poentd); + if poStatus <> 'DRAFT'; + writeMsg('PO already submitted - no further changes allowed.'); + return; + endif; + select; + when selOpt = '2'; + if changeRrn = 0; + changeRrn = selRrn; + else; + writeMsg('Only one line may be changed per Enter.'); + endif; + when selOpt = '4'; + exsr deleteLine; + other; + writeMsg('Option ' + selOpt + ' not valid.'); + endsl; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr addLine; + emode = 'A'; + eitem = ''; + eitmdsc = ''; + eqty = 0; + euom = ''; + eprice = 0; + // Sentinel "no expected receipt date". %date() with no format uses + // the job DATFMT which on this environment is *MDY (year range + // 1940-2039), so '0001' triggers RNQ0114. Force *ISO. + eexpdt = %date('0001-01-01' : *ISO); + + dow '1'; + exfmt pledit; + if *in12; + return; + endif; + + if %trim(eitem) = ''; + writeMsg('Item Number is required.'); + iter; + endif; + + exec sql + select item_description, inventory_uom + into :edesc, :edefuom + from perpdemo.item + where company_code = :compcd and item_number = :eitem; + if sqlcode <> 0; + writeMsg('Item ' + %trim(eitem) + ' not found for this company.'); + iter; + endif; + + eitmdsc = edesc; + + if eqty <= 0; + writeMsg('Quantity must be greater than zero.'); + iter; + endif; + + if %trim(euom) = ''; + euom = edefuom; + endif; + + if eprice = 0; + // Default from this vendor's current price row for the item. + exec sql + select unit_price + into :edefprice + from perpdemo.item_vendor_price + where company_code = :compcd + and item_number = :eitem + and vendor_code = :hvndcd + and effective_to is null + fetch first 1 row only; + if sqlcode = 0; + eprice = edefprice; + endif; + endif; + + leave; + enddo; + + exec sql + select coalesce(max(line_number), 0) + 1 + into :nextLine + from perpdemo.po_line + where company_code = :compcd and po_number = :ponbr; + + if eexpdt = %date('0001-01-01' : *ISO); + exec sql + insert into perpdemo.po_line + (company_code, po_number, line_number, item_number, + ordered_qty, uom_code, unit_price) + values (:compcd, :ponbr, :nextLine, :eitem, :eqty, :euom, :eprice); + else; + exec sql + insert into perpdemo.po_line + (company_code, po_number, line_number, item_number, + ordered_qty, uom_code, unit_price, expected_receipt_date) + values (:compcd, :ponbr, :nextLine, :eitem, :eqty, :euom, :eprice, + :eexpdt); + endif; + if sqlcode < 0; + writeMsg('Add line failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + exec sql commit; + writeMsg('Added line ' + %char(nextLine) + ': ' + %trim(edesc) + + ' (' + %trim(euom) + ' @ ' + %char(eprice) + ').'); + exsr recalcTotal; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr changeLine; + chgLnbr = rows(selRrn).lnbr; + emode = 'C'; + eitem = rows(selRrn).item; + eqty = rows(selRrn).qty; + euom = rows(selRrn).uom; + eprice = rows(selRrn).price; + + exec sql + select item_description + into :edesc + from perpdemo.item + where company_code = :compcd and item_number = :eitem; + if sqlcode = 0; + eitmdsc = edesc; + else; + eitmdsc = ''; + endif; + + exfmt pledit; + if *in12; + return; + endif; + + if eqty <= 0; + writeMsg('Quantity must be greater than zero.'); + return; + endif; + + exec sql + update perpdemo.po_line + set ordered_qty = :eqty, + uom_code = :euom, + unit_price = :eprice, + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd and po_number = :ponbr + and line_number = :chgLnbr; + if sqlcode < 0; + writeMsg('Change failed: SQLCODE=' + %char(sqlcode)); + else; + exec sql commit; + writeMsg('Updated line ' + %char(chgLnbr) + '.'); + exsr recalcTotal; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr deleteLine; + exec sql + delete from perpdemo.po_line + where company_code = :compcd and po_number = :ponbr + and line_number = :slline; + if sqlcode < 0; + writeMsg('Delete failed: SQLSTATE=' + sqlstate); + else; + exec sql commit; + writeMsg('Deleted line ' + %char(slline) + '.'); + exsr recalcTotal; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr recalcTotal; + exec sql + update perpdemo.po_header + set total_amount = + (select coalesce(sum(ordered_qty * unit_price), 0) + from perpdemo.po_line + where company_code = :compcd + and po_number = :ponbr), + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd and po_number = :ponbr; + exec sql commit; +endsr; + +// --------------------------------------------------------------------- +begsr clearMsgs; + msgrrn = 0; + *in41 = *on; + write pmsgctl; + *in41 = *off; +endsr; + +// --------------------------------------------------------------------- +dcl-proc writeMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + smsgkey : + x'0000000000000000'); + msgrrn += 1; + spgmq = statusDS.programName; + write pmsgsfl; +end-proc; diff --git a/perp/qrpglesrc/poreqr.sqlrpgle b/perp/qrpglesrc/poreqr.sqlrpgle new file mode 100644 index 00000000..e21387af --- /dev/null +++ b/perp/qrpglesrc/poreqr.sqlrpgle @@ -0,0 +1,618 @@ +**free + +// --------------------------------------------------------------------- +// Program: poreqr (Create POs from Approved Requisitions) +// Purpose: Convert one or more APPROVED requisitions into POs, grouping +// lines by the preferred vendor per item (one PO per vendor -> +// "splitting"), consolidating multiple selected reqs going to +// the same vendor into a single PO ("consolidation"). +// +// Line-level linkage: each generated po_line carries +// source_requisition_number + source_requisition_line_number +// so "converted" status is derivable by joining po_line back +// to requisition_line's PK (no redundant status column, per +// the PERP-37 DDL design note). +// +// Requisitions with no preferred vendor rows for their items, +// or already fully converted, are skipped with a message. +// +// Follows reqaprr's "one subfile + plain-record detail" shape +// (see DDL_STYLE_GUIDE.md Sec.14) -- SSFL (approved-req +// subfile) plus a plain SPREV record for the vendor-grouped +// preview (up to 5 vendors shown; the count message covers +// any overflow). No second real subfile. +// Epic: PERP-7 (PERP-39) +// --------------------------------------------------------------------- + +// datfmt(*iso) for consistency with the other PO programs -- the job +// DATFMT here is *MDY (2-digit year, 1940-2039) and we want every +// PERP program to accept the full RPG Date range. +ctl-opt dftactgrp(*no) actgrp(*new) bnddir('PERP') datfmt(*iso); + +dcl-f poreqd workstn sfile(ssfl:rrn) sfile(rmsgsfl:msgrrn); + +/copy docseq_pr.rpgle + +dcl-ds ldaDS dtaara(*lda) len(1024) qualified; + compcd char(3) pos(1); +end-ds; + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-ds statusDS psds qualified; + programName char(10) pos(334); +end-ds; + +// A row of the approved-req subfile. +dcl-ds reqRow qualified; + reqnbr int(20); + reqby char(10); + needby date; + totest packed(15:2); + isSel ind; + // Snapshot of the dominant vendor for this req (first line's + // preferred vendor) -- purely for display. + vndcd char(10); + vndnm varchar(60); +end-ds; + +// A plan row: vendor + a list of (reqnbr, reqline, item, qty, uom, price). +dcl-ds planLine qualified; + reqnbr int(20); + reqline int(10); + item varchar(25); + qty packed(15:4); + uom varchar(5); + price packed(15:4); +end-ds; +dcl-ds vendorPlan qualified; + vndcd char(10); + vndnm varchar(60); + lineCount int(10); + totAmt packed(15:2); + lines likeds(planLine) dim(500); +end-ds; + +dcl-ds reqs likeds(reqRow) dim(500); +dcl-ds plan likeds(vendorPlan) dim(50); +dcl-s numReqs int(10); +dcl-s numPlan int(10); +dcl-s rrn int(10); +dcl-s msgrrn int(10); +dcl-s selCnt int(10); +dcl-s lineCnt int(10); +dcl-s i int(10); +dcl-s j int(10); +dcl-s k int(10); +dcl-s compcd char(3); +dcl-s docerrmsg varchar(80); +dcl-s newPo int(20); +dcl-s vidx int(10); +dcl-s prevMode ind; + +// Cursor host vars. +dcl-s cReqNbr int(20); +dcl-s cReqBy char(10); +dcl-s cNeedBy date; +dcl-s cTotEst packed(15:2); +dcl-s cVndCd char(10); +dcl-s cVndNm varchar(60); +dcl-s cReqLine int(10); +dcl-s cItem varchar(25); +dcl-s cQty packed(15:4); +dcl-s cUom varchar(5); +dcl-s cPrice packed(15:4); + +// Staging scalars for SQL statements that need array-element data. +// The SQLRPGLE precompiler does not accept :ds(i).field as a host +// variable, so we copy into these plain scalars first. +dcl-s xReqNbr int(20); +dcl-s xReqLine int(10); +dcl-s xVndCd char(10); +dcl-s xItem varchar(25); +dcl-s xQty packed(15:4); +dcl-s xUom varchar(5); +dcl-s xPrice packed(15:4); +dcl-s xTotAmt packed(15:2); +dcl-s xBuyer char(10); + +// Locals used by createPOs -- dcl-s inside a begsr triggers RNF0724 +// ("statement type out of sequence"), so they live up here. +dcl-s poCount int(10); +dcl-s lineNbr int(10); +dcl-s v int(10); +dcl-s L int(10); + +in ldaDS; +compcd = ldaDS.compcd; + +if compcd = ''; + exsr clearMsgs; + writeMsg('No company selected - run Select Company (PERPSELR) first.'); + *in40 = *on; + lcompdsp = ''; + write rmsgctl; + exfmt sfoot; + *inlr = *on; + return; +endif; + +lcompdsp = compcd; +pcompdsp = compcd; + +// ----------------------------------------------------------------------- +// Selection loop. +// ----------------------------------------------------------------------- +prevMode = *off; + +dow '1'; + exsr loadReqs; + + if numReqs = 0; + *in30 = *off; + write snosub; + else; + exsr fillSSFL; + *in30 = *on; + endif; + + write sfoot; + *in40 = *off; + if msgrrn > 0; + *in40 = *on; + endif; + write rmsgctl; + exfmt ssctl; + + if *in03 or *in12; + leave; + endif; + + exsr clearMsgs; + + // Read selections. Guard READC against an unloaded subfile + // (DDL_STYLE_GUIDE.md Sec.14 -- CPF5006 otherwise). + selCnt = 0; + if numReqs > 0; + readc ssfl; + dow not %eof(poreqd); + if ssopt = '1'; + reqs(rrn).isSel = *on; + selCnt += 1; + endif; + readc ssfl; + enddo; + endif; + + if *in06; + if selCnt = 0; + writeMsg('Select at least one requisition (option 1) before F6.'); + iter; + endif; + + exsr buildPlan; + + if numPlan = 0; + writeMsg('Selected requisitions produced no PO lines -- check that ' + + 'items have a preferred vendor with a current price row.'); + // Clear selections and iter. + for i = 1 to numReqs; + reqs(i).isSel = *off; + endfor; + iter; + endif; + + exsr showPreview; + + if *in06; + // Confirmed -- create the POs. + exsr createPOs; + // After creation, refresh the list (converted lines drop out + // of the "unconverted approved" query) and clear selections. + exec sql commit; + // Clear selection flags on the in-memory copy for safety. + for i = 1 to numReqs; + reqs(i).isSel = *off; + endfor; + else; + // F12 back to selection -- keep selections in the array; refill + // the subfile from reqs() so they still show. + writeMsg('Conversion cancelled.'); + // NB: subfile is rebuilt from perpdemo on next iteration, so the + // in-memory isSel flags are effectively wiped; that's fine -- + // the user re-selects. + endif; + iter; + endif; +enddo; + +*inlr = *on; +return; + +// --------------------------------------------------------------------- +// loadReqs -- pull APPROVED reqs whose lines are not yet all linked +// to a po_line. A req with SOME lines converted still shows (its +// remaining lines get placed on new POs -- classic "splitting"). +// --------------------------------------------------------------------- +begsr loadReqs; + numReqs = 0; + + exec sql declare rc1 cursor for + select h.requisition_number, h.requested_by, h.need_by_date, + h.total_estimated_cost, + coalesce(v.vendor_code, ''), + coalesce(v.vendor_name, '') + from perpdemo.requisition_header h + left join lateral ( + select iv.vendor_code, ven.vendor_name + from perpdemo.requisition_line rl + join perpdemo.item_vendor iv + on iv.company_code = rl.company_code + and iv.item_number = rl.item_number + and iv.is_preferred = 'Y' + join perpdemo.vendor ven + on ven.company_code = iv.company_code + and ven.vendor_code = iv.vendor_code + where rl.company_code = h.company_code + and rl.requisition_number = h.requisition_number + order by rl.line_number + fetch first 1 row only + ) v on 1=1 + where h.company_code = :compcd + and h.status_code = 'APPROVED' + and exists ( + select 1 + from perpdemo.requisition_line rl2 + where rl2.company_code = h.company_code + and rl2.requisition_number = h.requisition_number + and not exists ( + select 1 from perpdemo.po_line pl + where pl.company_code = rl2.company_code + and pl.source_requisition_number = rl2.requisition_number + and pl.source_requisition_line_number = rl2.line_number + ) + ) + order by h.requisition_number; + exec sql open rc1; + if sqlcode < 0; + writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode) + + ' STATE=' + sqlstate); + return; + endif; + + dow numReqs < %elem(reqs); + exec sql fetch rc1 into :cReqNbr, :cReqBy, :cNeedBy, :cTotEst, + :cVndCd, :cVndNm; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + numReqs += 1; + reqs(numReqs).reqnbr = cReqNbr; + reqs(numReqs).reqby = cReqBy; + reqs(numReqs).needby = cNeedBy; + reqs(numReqs).totest = cTotEst; + reqs(numReqs).vndcd = cVndCd; + reqs(numReqs).vndnm = cVndNm; + reqs(numReqs).isSel = *off; + enddo; + exec sql close rc1; +endsr; + +// --------------------------------------------------------------------- +begsr fillSSFL; + rrn = 0; + *in31 = *on; + write ssctl; + *in31 = *off; + for i = 1 to numReqs; + ssopt = ''; + ssreqnbr = %char(reqs(i).reqnbr); + ssreqby = reqs(i).reqby; + ssneedby = reqs(i).needby; + ssvndr = reqs(i).vndcd; + ssvndnm = reqs(i).vndnm; + sstotest = reqs(i).totest; + rrn += 1; + write ssfl; + endfor; +endsr; + +// --------------------------------------------------------------------- +// buildPlan -- for each selected req, iterate its unconverted lines, +// look up the preferred vendor + current price, add to the vendor's +// plan bucket. Multiple selected reqs -> same vendor -> same bucket +// (consolidation). Different items on same req -> different vendors +// -> different buckets (splitting). +// --------------------------------------------------------------------- +begsr buildPlan; + numPlan = 0; + lineCnt = 0; + + for i = 1 to numReqs; + if not reqs(i).isSel; + iter; + endif; + + xReqNbr = reqs(i).reqnbr; + + exec sql declare rc2 cursor for + select rl.line_number, rl.item_number, rl.quantity, + rl.uom_code, + coalesce(iv.vendor_code, ''), + coalesce(ven.vendor_name, ''), + coalesce(ivp.unit_price, rl.est_unit_cost) + from perpdemo.requisition_line rl + left join perpdemo.item_vendor iv + on iv.company_code = rl.company_code + and iv.item_number = rl.item_number + and iv.is_preferred = 'Y' + left join perpdemo.vendor ven + on ven.company_code = iv.company_code + and ven.vendor_code = iv.vendor_code + left join perpdemo.item_vendor_price ivp + on ivp.company_code = iv.company_code + and ivp.item_number = iv.item_number + and ivp.vendor_code = iv.vendor_code + and ivp.effective_to is null + where rl.company_code = :compcd + and rl.requisition_number = :xReqNbr + and not exists ( + select 1 from perpdemo.po_line pl + where pl.company_code = rl.company_code + and pl.source_requisition_number = rl.requisition_number + and pl.source_requisition_line_number = rl.line_number + ) + order by rl.line_number; + exec sql open rc2; + if sqlcode < 0; + writeMsg('buildPlan open failed: SQLCODE=' + %char(sqlcode)); + return; + endif; + + dow '1'; + exec sql fetch rc2 into :cReqLine, :cItem, :cQty, :cUom, + :cVndCd, :cVndNm, :cPrice; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + + if cVndCd = ''; + // No preferred vendor -- skip this line with a warning. + writeMsg('Skipped req ' + %char(reqs(i).reqnbr) + + ' line ' + %char(cReqLine) + + ' (' + %trim(cItem) + '): no preferred vendor.'); + iter; + endif; + + // Find or add the vendor bucket. + vidx = 0; + for j = 1 to numPlan; + if plan(j).vndcd = cVndCd; + vidx = j; + leave; + endif; + endfor; + if vidx = 0; + if numPlan >= %elem(plan); + writeMsg('Too many distinct vendors -- capping preview.'); + leave; + endif; + numPlan += 1; + vidx = numPlan; + plan(vidx).vndcd = cVndCd; + plan(vidx).vndnm = cVndNm; + plan(vidx).lineCount = 0; + plan(vidx).totAmt = 0; + endif; + + if plan(vidx).lineCount >= %elem(plan(vidx).lines); + writeMsg('Too many lines for vendor ' + %trim(cVndCd) + + ' -- capping.'); + iter; + endif; + + plan(vidx).lineCount += 1; + k = plan(vidx).lineCount; + plan(vidx).lines(k).reqnbr = reqs(i).reqnbr; + plan(vidx).lines(k).reqline = cReqLine; + plan(vidx).lines(k).item = cItem; + plan(vidx).lines(k).qty = cQty; + plan(vidx).lines(k).uom = cUom; + plan(vidx).lines(k).price = cPrice; + plan(vidx).totAmt += cQty * cPrice; + lineCnt += 1; + enddo; + exec sql close rc2; + endfor; +endsr; + +// --------------------------------------------------------------------- +// showPreview -- populate SPREV plain-record fields for up to 5 +// vendor buckets, EXFMT, wait for F6 (confirm) or F12 (back). +// --------------------------------------------------------------------- +begsr showPreview; + pselcnt = selCnt; + plncnt = lineCnt; + ppocnt = numPlan; + + *in60 = *off; + *in61 = *off; + *in62 = *off; + *in63 = *off; + *in64 = *off; + *in34 = *off; + + if numPlan >= 1; + *in60 = *on; + p1vndr = plan(1).vndcd; + p1vndnm = plan(1).vndnm; + p1lns = plan(1).lineCount; + p1tot = plan(1).totAmt; + endif; + if numPlan >= 2; + *in61 = *on; + p2vndr = plan(2).vndcd; + p2vndnm = plan(2).vndnm; + p2lns = plan(2).lineCount; + p2tot = plan(2).totAmt; + endif; + if numPlan >= 3; + *in62 = *on; + p3vndr = plan(3).vndcd; + p3vndnm = plan(3).vndnm; + p3lns = plan(3).lineCount; + p3tot = plan(3).totAmt; + endif; + if numPlan >= 4; + *in63 = *on; + p4vndr = plan(4).vndcd; + p4vndnm = plan(4).vndnm; + p4lns = plan(4).lineCount; + p4tot = plan(4).totAmt; + endif; + if numPlan >= 5; + *in64 = *on; + p5vndr = plan(5).vndcd; + p5vndnm = plan(5).vndnm; + p5lns = plan(5).lineCount; + p5tot = plan(5).totAmt; + endif; + if numPlan > 5; + *in34 = *on; + endif; + + *in40 = *off; + if msgrrn > 0; + *in40 = *on; + endif; + write rmsgctl; + exfmt sprev; +endsr; + +// --------------------------------------------------------------------- +// createPOs -- one PO per vendor bucket. Snapshots buyer_code from +// vendor; allocates po_number from docseq_next('PO'); inserts po_header +// + po_line rows; each po_line carries source_requisition_number + +// source_requisition_line_number for the derived converted-status +// lookup. +// --------------------------------------------------------------------- +begsr createPOs; + poCount = 0; + + for v = 1 to numPlan; + if plan(v).lineCount = 0; + iter; + endif; + + // Copy vendor bucket into scalars (SQLRPGLE precompiler doesn't + // accept :plan(v).field as a host variable -- SQL0312). + xVndCd = plan(v).vndcd; + xTotAmt = plan(v).totAmt; + + // Snapshot buyer from vendor. + exec sql + select buyer_code + into :xBuyer + from perpdemo.vendor + where company_code = :compcd + and vendor_code = :xVndCd; + if sqlcode <> 0; + writeMsg('Vendor ' + %trim(xVndCd) + + ' lookup failed: SQLCODE=' + %char(sqlcode)); + exec sql rollback; + return; + endif; + + newPo = docseq_next(compcd : 'PO' : docerrmsg); + if newPo = 0; + writeMsg('docseq_next failed: ' + docerrmsg); + exec sql rollback; + return; + endif; + + exec sql + insert into perpdemo.po_header + (company_code, po_number, vendor_code, buyer_code, + status_code, total_amount) + values (:compcd, :newPo, :xVndCd, :xBuyer, + 'OPEN', :xTotAmt); + if sqlcode < 0; + writeMsg('po_header insert failed: SQLCODE=' + %char(sqlcode) + + ' STATE=' + sqlstate); + exec sql rollback; + return; + endif; + + lineNbr = 0; + for L = 1 to plan(v).lineCount; + lineNbr += 1; + xItem = plan(v).lines(L).item; + xQty = plan(v).lines(L).qty; + xUom = plan(v).lines(L).uom; + xPrice = plan(v).lines(L).price; + xReqNbr = plan(v).lines(L).reqnbr; + xReqLine = plan(v).lines(L).reqline; + exec sql + insert into perpdemo.po_line + (company_code, po_number, line_number, item_number, + ordered_qty, uom_code, unit_price, + source_requisition_number, source_requisition_line_number) + values (:compcd, :newPo, :lineNbr, + :xItem, :xQty, :xUom, :xPrice, + :xReqNbr, :xReqLine); + if sqlcode < 0; + writeMsg('po_line insert failed for vendor ' + + %trim(plan(v).vndcd) + ': SQLCODE=' + + %char(sqlcode) + ' STATE=' + sqlstate); + exec sql rollback; + return; + endif; + endfor; + + poCount += 1; + endfor; + + writeMsg('Created ' + %char(poCount) + ' PO(s) from ' + + %char(selCnt) + ' requisition(s) (' + + %char(lineCnt) + ' line(s)).'); +endsr; + +// --------------------------------------------------------------------- +begsr clearMsgs; + msgrrn = 0; + *in41 = *on; + write rmsgctl; + *in41 = *off; +endsr; + +// --------------------------------------------------------------------- +dcl-proc writeMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + smsgkey : + x'0000000000000000'); + msgrrn += 1; + spgmq = statusDS.programName; + write rmsgsfl; +end-proc; diff --git a/perp/qrpglesrc/poschr.sqlrpgle b/perp/qrpglesrc/poschr.sqlrpgle new file mode 100644 index 00000000..0adedbd5 --- /dev/null +++ b/perp/qrpglesrc/poschr.sqlrpgle @@ -0,0 +1,484 @@ +**free + +// --------------------------------------------------------------------- +// Program: poschr (Blanket PO Schedule Maintenance) +// Purpose: Maintain po_line_schedule rows for a given (company, +// po_number, line_number). Blanket POs use a schedule row per +// delivery; a non-blanket line simply has zero schedule rows. +// Company comes from *LDA[1:3] via perpselr. PO and line are +// entered on the header screen (or arrive via optional call +// parameters -- see the parm list on the entry procedure). +// +// Total scheduled qty is compared against po_line.ordered_qty +// on every refresh. Excess is highlighted with indicator 70 +// (red warning line) and a message -- soft, not a hard block, +// per the PERP-40 requirement. +// Epic: PERP-7 (PERP-40) +// --------------------------------------------------------------------- + +// datfmt(*iso) for consistency with the other PO programs -- the job +// DATFMT here is *MDY (2-digit year, 1940-2039). +ctl-opt dftactgrp(*no) actgrp(*new) datfmt(*iso); + +dcl-f poschd workstn sfile(hsfl:rrn) sfile(hmsgsfl:msgrrn); + +dcl-ds ldaDS dtaara(*lda) len(1024) qualified; + compcd char(3) pos(1); +end-ds; + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-ds statusDS psds qualified; + programName char(10) pos(334); +end-ds; + +// Optional entry parameters. When both parms carry non-blank data the +// header screen is skipped and the schedule is loaded immediately. A +// call with no parms drops the user on the header entry screen. +// Optional parms via OPTIONS(*NOPASS) -- menu option calls with none, +// PO detail calls with both (PERP-41 wires this). +dcl-pi *n; + in_ponbr char(10) const options(*nopass); + in_line packed(3:0) const options(*nopass); +end-pi; + +dcl-ds schedRow qualified; + seq int(10); + schdt date; + qty packed(15:4); + rcvqty packed(15:4); + notes varchar(240); +end-ds; + +dcl-ds rows likeds(schedRow) dim(500); +dcl-s numRows int(10); +dcl-s rrn int(10); +dcl-s msgrrn int(10); +dcl-s selRrn int(10); +dcl-s changeRrn int(10); +dcl-s i int(10); +dcl-s compcd char(3); +dcl-s ponbr int(20); +dcl-s lineNbr int(10); +dcl-s chgSeq int(10); +dcl-s nextSeq int(10); +dcl-s selOpt char(1); +dcl-s cnt int(10); +dcl-s parmed ind; +// po_line context for the header. +dcl-s itemNbr varchar(25); +dcl-s vndCd varchar(10); +dcl-s ordQty packed(15:4); +dcl-s uomCd varchar(5); +dcl-s schTot packed(15:4); +dcl-s rcvTot packed(15:4); + +in ldaDS; +compcd = ldaDS.compcd; + +if compcd = ''; + exsr clearMsgs; + writeMsg('No company selected - run Select Company (PERPSELR) first.'); + *in40 = *on; + hcompdsp = ''; + hponbr = ''; + hline = 0; + write hmsgctl; + exfmt hhead; + *inlr = *on; + return; +endif; + +hcompdsp = compcd; + +// Prefill from parms when supplied. Guard reads with %parms() because +// the parms are OPTIONS(*NOPASS) -- menu callers pass none. +parmed = *off; +if %parms() >= 2; + if %trim(in_ponbr) <> '' and in_line > 0; + hponbr = in_ponbr; + hline = in_line; + parmed = *on; + endif; +endif; + +// ----------------------------------------------------------------------- +// Header entry loop -- collect (or accept from parms) po_number + line; +// look them up on po_line to prove they exist and grab item / vendor / +// ordered_qty / uom for the detail screen. +// ----------------------------------------------------------------------- +dow '1'; + if not parmed; + *in40 = *off; + if msgrrn > 0; + *in40 = *on; + endif; + exfmt hhead; + + if *in03 or *in12; + *inlr = *on; + return; + endif; + endif; + + exsr clearMsgs; + + if %trim(hponbr) = ''; + writeMsg('PO Number is required.'); + parmed = *off; + iter; + endif; + + monitor; + ponbr = %int(%trim(hponbr)); + on-error; + writeMsg('PO Number ' + %trim(hponbr) + ' must be numeric.'); + parmed = *off; + iter; + endmon; + + if hline <= 0; + writeMsg('Line Number must be greater than zero.'); + parmed = *off; + iter; + endif; + lineNbr = hline; + + exec sql + select item_number, + (select vendor_code from perpdemo.po_header + where company_code = :compcd and po_number = :ponbr), + ordered_qty, uom_code, received_qty + into :itemNbr, :vndCd, :ordQty, :uomCd, :rcvTot + from perpdemo.po_line + where company_code = :compcd + and po_number = :ponbr + and line_number = :lineNbr; + if sqlcode = 100; + writeMsg('PO ' + %char(ponbr) + ' line ' + %char(lineNbr) + + ' not found.'); + parmed = *off; + iter; + endif; + if sqlcode < 0; + writeMsg('Lookup failed: SQLCODE=' + %char(sqlcode)); + parmed = *off; + iter; + endif; + + leave; +enddo; + +// ----------------------------------------------------------------------- +// Schedule maintenance loop. +// ----------------------------------------------------------------------- +dow '1'; + exsr loadSched; + + if numRows = 0; + *in30 = *off; + write hnosch; + else; + exsr fillSubfile; + *in30 = *on; + endif; + + // Header context. + dponbr = hponbr; + dline = lineNbr; + ditem = itemNbr; + dvndcd = vndCd; + dordqty = ordQty; + duom = uomCd; + dschtot = schTot; + drcvtot = rcvTot; + *in70 = *off; + if schTot > ordQty; + *in70 = *on; + endif; + + write hfoot; + *in40 = *off; + if msgrrn > 0; + *in40 = *on; + endif; + write hmsgctl; + exfmt hsctl; + + if *in03 or *in12; + leave; + endif; + + exsr clearMsgs; + + if *in06; + exsr addSched; + iter; + endif; + + // Drain READC loop before switching to HEDIT for a change + // (DDL_STYLE_GUIDE.md Sec.14 pattern). + if numRows > 0; + selRrn = 0; + selOpt = ' '; + changeRrn = 0; + readc hsfl; + dow not %eof(poschd); + if slopt <> ''; + selRrn = rrn; + selOpt = slopt; + exsr handleOpt; + selRrn = 0; + endif; + readc hsfl; + enddo; + + if changeRrn > 0 and msgrrn = 0; + selRrn = changeRrn; + exsr changeSched; + endif; + endif; + +enddo; + +*inlr = *on; +return; + +// --------------------------------------------------------------------- +begsr loadSched; + numRows = 0; + schTot = 0; + + exec sql declare sc1 cursor for + select schedule_seq, scheduled_date, scheduled_qty, received_qty, + notes + from perpdemo.po_line_schedule + where company_code = :compcd + and po_number = :ponbr + and line_number = :lineNbr + order by schedule_seq; + exec sql open sc1; + if sqlcode < 0; + writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); + return; + endif; + + dow numRows < %elem(rows); + exec sql fetch sc1 into :schedRow.seq, :schedRow.schdt, + :schedRow.qty, :schedRow.rcvqty, + :schedRow.notes; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + numRows += 1; + rows(numRows) = schedRow; + schTot += schedRow.qty; + enddo; + exec sql close sc1; + + // Refresh po_line.received_qty (a receipt program may have updated it). + exec sql + select received_qty + into :rcvTot + from perpdemo.po_line + where company_code = :compcd + and po_number = :ponbr + and line_number = :lineNbr; +endsr; + +// --------------------------------------------------------------------- +begsr fillSubfile; + rrn = 0; + *in31 = *on; + write hsctl; + *in31 = *off; + for i = 1 to numRows; + slopt = ''; + slseq = rows(i).seq; + slschdt = rows(i).schdt; + slschqty = rows(i).qty; + slrcvqty = rows(i).rcvqty; + slschnot = rows(i).notes; + rrn += 1; + write hsfl; + endfor; +endsr; + +// --------------------------------------------------------------------- +begsr handleOpt; + chain selRrn hsfl; + if %found(poschd); + select; + when selOpt = '2'; + if changeRrn = 0; + changeRrn = selRrn; + else; + writeMsg('Only one row may be changed per Enter.'); + endif; + when selOpt = '4'; + exsr deleteSched; + other; + writeMsg('Option ' + selOpt + ' not valid.'); + endsl; + endif; +endsr; + +// --------------------------------------------------------------------- +begsr addSched; + emode = 'A'; + eseq = 0; + eschdt = %date(); + eschqty = 0; + ercvqty = 0; + enotes = ''; + + dow '1'; + exfmt hedit; + if *in12; + return; + endif; + + if eschqty <= 0; + writeMsg('Scheduled Qty must be greater than zero.'); + iter; + endif; + + if ercvqty < 0; + writeMsg('Received Qty cannot be negative.'); + iter; + endif; + + if ercvqty > eschqty; + writeMsg('Received Qty cannot exceed Scheduled Qty.'); + iter; + endif; + + leave; + enddo; + + exec sql + select coalesce(max(schedule_seq), 0) + 1 + into :nextSeq + from perpdemo.po_line_schedule + where company_code = :compcd + and po_number = :ponbr + and line_number = :lineNbr; + + exec sql + insert into perpdemo.po_line_schedule + (company_code, po_number, line_number, schedule_seq, + scheduled_date, scheduled_qty, received_qty, notes) + values (:compcd, :ponbr, :lineNbr, :nextSeq, + :eschdt, :eschqty, :ercvqty, :enotes); + if sqlcode < 0; + writeMsg('Add failed: SQLCODE=' + %char(sqlcode) + + ' STATE=' + sqlstate); + return; + endif; + + exec sql commit; + writeMsg('Added schedule seq ' + %char(nextSeq) + ' (' + + %char(eschqty) + ' on ' + %char(eschdt) + ').'); +endsr; + +// --------------------------------------------------------------------- +begsr changeSched; + chgSeq = rows(selRrn).seq; + emode = 'C'; + eseq = chgSeq; + eschdt = rows(selRrn).schdt; + eschqty = rows(selRrn).qty; + ercvqty = rows(selRrn).rcvqty; + enotes = rows(selRrn).notes; + + exfmt hedit; + if *in12; + return; + endif; + + if eschqty <= 0; + writeMsg('Scheduled Qty must be greater than zero.'); + return; + endif; + + if ercvqty < 0 or ercvqty > eschqty; + writeMsg('Received Qty must be between 0 and Scheduled Qty.'); + return; + endif; + + exec sql + update perpdemo.po_line_schedule + set scheduled_date = :eschdt, + scheduled_qty = :eschqty, + received_qty = :ercvqty, + notes = :enotes, + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd + and po_number = :ponbr + and line_number = :lineNbr + and schedule_seq = :chgSeq; + if sqlcode < 0; + writeMsg('Change failed: SQLCODE=' + %char(sqlcode)); + return; + endif; + + exec sql commit; + writeMsg('Updated schedule seq ' + %char(chgSeq) + '.'); +endsr; + +// --------------------------------------------------------------------- +begsr deleteSched; + exec sql + delete from perpdemo.po_line_schedule + where company_code = :compcd + and po_number = :ponbr + and line_number = :lineNbr + and schedule_seq = :slseq; + if sqlcode < 0; + writeMsg('Delete failed: SQLSTATE=' + sqlstate); + return; + endif; + exec sql commit; + writeMsg('Deleted schedule seq ' + %char(slseq) + '.'); +endsr; + +// --------------------------------------------------------------------- +begsr clearMsgs; + msgrrn = 0; + *in41 = *on; + write hmsgctl; + *in41 = *off; +endsr; + +// --------------------------------------------------------------------- +dcl-proc writeMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + smsgkey : + x'0000000000000000'); + msgrrn += 1; + spgmq = statusDS.programName; + write hmsgsfl; +end-proc; From 9ab9f396f895e4eb46525b3164fcd135d7bab24e Mon Sep 17 00:00:00 2001 From: Gary Jones Date: Fri, 7 Aug 2026 17:24:49 +0000 Subject: [PATCH 09/13] =?UTF-8?q?PERP-8:=20Receiving=20&=20Reconciliation?= =?UTF-8?q?=20=E2=80=94=20po=5Freceipt/line=20+=20reconciliation=5Flog,=20?= =?UTF-8?q?receipt=20entry=20(UOM=20conversion=20+=20lot=20capture),=20lot?= =?UTF-8?q?=20reconciliation=20service,=20reconciliation=20log=20browse?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Closes the requisition -> PO -> receiving transaction loop (PERP-42..45): - PERP-42: po_receipt, po_receipt_line, reconciliation_log tables, journaled to PERPJRN. - PERP-43: rcventr/rcventd PO receipt entry — validates PO status, converts vendor UOM to inventory UOM via item_uom_conversion, upserts item_lot for lot-controlled items, rolls up po_line/po_header status on every receipt (the PO-status-transition-from-receipts item PERP-7 deferred to this epic). Fixes a message-subfile display bug found live (missing WRITE before EXFMT). - PERP-44: lotrecon module/srvpgm + lotrcnsmk smoke test — detects and repairs drift between item.qty_on_hand and SUM(item_lot.qty_on_hand), logging every repair to reconciliation_log. - PERP-45: rcnbrwr/rcnbrwd — filterable reconciliation_log browse + detail. - New PERPRCVM child menu under PERPMNU option 8; lotrcnsmk added to PERPDIAG option 5. DDL_STYLE_GUIDE.md gains Sec.16a (message-subfile WRITE-before-EXFMT gotcha) and Sec.17 (CHECK constraints cannot cross tables). Confluence Data Model, Design Decisions, Delivery Plan, and PERP hub pages updated to reflect the shipped schema and epic status. Co-Authored-By: CoderFlow Learn more: https://coderflow.ai --- perp/DDL_STYLE_GUIDE.md | 59 +++ perp/Rules.mk | 56 ++- perp/perp.bnddir | 1 + perp/perpdiag.msgf | 1 + perp/perpmnu.msgf | 1 + perp/perprcvm.msgf | 3 + perp/qddlsrc/po_receipt.table.sql | 89 ++++ perp/qddlsrc/po_receipt_line.table.sql | 106 +++++ perp/qddlsrc/reconciliation_log.table.sql | 86 ++++ perp/qddssrc/perpdiag.dspf | 2 + perp/qddssrc/perpmnu.dspf | 3 +- perp/qddssrc/perprcvm.dspf | 30 ++ perp/qddssrc/rcnbrwd.dspf | 92 ++++ perp/qddssrc/rcventd.dspf | 117 +++++ perp/qrpglesrc/lotrcnsmk.sqlrpgle | 77 ++++ perp/qrpglesrc/lotrecon.sqlrpgle | 92 ++++ perp/qrpglesrc/lotrecon_pr.rpgle | 45 ++ perp/qrpglesrc/rcnbrwr.sqlrpgle | 264 +++++++++++ perp/qrpglesrc/rcventr.sqlrpgle | 519 ++++++++++++++++++++++ perp/qsrvsrc/lotrecon.bnd | 3 + 20 files changed, 1642 insertions(+), 4 deletions(-) create mode 100644 perp/perprcvm.msgf create mode 100644 perp/qddlsrc/po_receipt.table.sql create mode 100644 perp/qddlsrc/po_receipt_line.table.sql create mode 100644 perp/qddlsrc/reconciliation_log.table.sql create mode 100644 perp/qddssrc/perprcvm.dspf create mode 100644 perp/qddssrc/rcnbrwd.dspf create mode 100644 perp/qddssrc/rcventd.dspf create mode 100644 perp/qrpglesrc/lotrcnsmk.sqlrpgle create mode 100644 perp/qrpglesrc/lotrecon.sqlrpgle create mode 100644 perp/qrpglesrc/lotrecon_pr.rpgle create mode 100644 perp/qrpglesrc/rcnbrwr.sqlrpgle create mode 100644 perp/qrpglesrc/rcventr.sqlrpgle create mode 100644 perp/qsrvsrc/lotrecon.bnd diff --git a/perp/DDL_STYLE_GUIDE.md b/perp/DDL_STYLE_GUIDE.md index f2fd8698..23ec1c34 100644 --- a/perp/DDL_STYLE_GUIDE.md +++ b/perp/DDL_STYLE_GUIDE.md @@ -648,3 +648,62 @@ CRTSRCPF FILE(PERPDEMO/QSQLSRC) RCDLEN(112) TEXT('PERP - SQL source') `QDDLSRC` was missing at PERP-2 initial cutover and was created after the fact; keep it as part of the PERPDEMO bootstrap for future clones. + +## 16a. A message subfile only updates when its SFLCTL record is re-WRITE'n + +**Toggling the `*in40`-style RPG indicator that conditions `SFLDSP` has no +visible effect unless the `SFLCTL` record itself is `WRITE`'n again** -- +changing the RPG variable is not enough; the device only re-evaluates a +record's conditioning indicators when that specific record is the target +of a `WRITE`/`EXFMT` operation. Found in `rcventr` (PERP-43): the header +validation loop and the `receiveLine` edit-panel loop each set `*in40` +based on `msgrrn` and then `EXFMT`'d a *different* format (`RHEAD` / +`RLEDIT`) without an explicit `WRITE rmsgctl` first. Confirmed live: an +invalid-PO-number error never appeared on screen at all, even though +`writeMsg` had correctly written a row into the message subfile and +`msgrrn` was correctly nonzero. + +Every PERP work-with program's *subfile* loop already gets this right +(`write rlctl` / `write plctl` / `write bsctl` immediately before the +`exfmt` of the same cycle) -- the bug only shows up in a program's +*header entry* or *plain edit-panel* loop, which don't otherwise need to +re-`WRITE` their own record before `EXFMT` (since `EXFMT` both writes and +reads that record). The message subfile control record is a second, +separate record that needs its own explicit `WRITE` every cycle if its +indicators changed, regardless of what other record is being `EXFMT`'d +in that same iteration. + +**Fix:** any loop that both (a) conditionally shows/hides the message +subfile via an indicator and (b) `EXFMT`s a record other than the message +`SFLCTL` itself must `WRITE` the message `SFLCTL` record explicitly, +every iteration, before that `EXFMT` -- not just toggle the indicator +variable. `poentr`'s and `reqentr`'s header-entry loops follow the same +toggle-without-write shape as `rcventr`'s did before this fix and were +likely never live-tested against a failing header validation (PERP-7's +own verification notes cite the AIDEMO-menu-no-cmdline block as the +reason interactive testing was skipped in favor of state-based SQL +checks) -- worth a live retest and matching fix there if anyone is in +that code again, but out of scope to change opportunistically here. + +## 17. CHECK constraints cannot cross tables + +A `CHECK` constraint's expression may only reference columns of the table +being defined — DB2 for i (like every SQL-standard implementation) has no +concept of a cross-table `CHECK`. Found in PERP-42: the ticket for +`po_receipt_line` asked for "if `item.lot_controlled = 'Y'` then +`lot_number IS NOT NULL`", which reads like an ordinary `CHECK` but +`item.lot_controlled` lives on a different table than `lot_number`. There +is no DDL syntax that expresses this — a subquery inside `CHECK` is +rejected outright, and there's no cross-table trigger-like `CHECK` variant +on this platform. + +**Fix: enforce it in the RPG program that inserts the row, not in DDL.** +`rcventr` (PERP-43) looks up `item.lot_controlled` before `INSERT`ing into +`po_receipt_line` and rejects the entry interactively if a lot-controlled +item has no lot number entered. The column itself stays nullable in DDL +(`lot_number` on `po_receipt_line`) — the invariant is real and enforced, +just at the application layer instead of the database layer. This is a +general rule, not specific to lots/receipts: any "if column A on table X +then column B on table Y must be Z" business rule in a future PERP story +needs the same treatment — don't spend time trying to express it as a +table-level `CONSTRAINT` first. diff --git a/perp/Rules.mk b/perp/Rules.mk index 917bb601..4862d7f0 100644 --- a/perp/Rules.mk +++ b/perp/Rules.mk @@ -259,6 +259,50 @@ pobrwd.file: qddssrc/pobrwd.dspf pobrwr.pgm: qrpglesrc/pobrwr.sqlrpgle qddssrc/pobrwd.dspf | pobrwd.file po_header.file po_line.file po_line_open.file po_line_schedule.file requisition_line.file vendor.file perp_user.file +# --- PERP-8: Receiving & Reconciliation ----------------------------------- +# FK order: po_receipt (company, po_header, perp_user, code_master) before +# po_receipt_line (po_receipt, po_line, item). reconciliation_log FKs item +# only (no natural key -- IDENTITY surrogate, see DDL_STYLE_GUIDE.md Sec.5). +po_receipt.file: qddlsrc/po_receipt.table.sql company.file po_header.file perp_user.file code_master.file | perpsjpf.pgm +po_receipt_line.file: qddlsrc/po_receipt_line.table.sql po_receipt.file po_line.file item.file | perpsjpf.pgm +reconciliation_log.file: qddlsrc/reconciliation_log.table.sql item.file | perpsjpf.pgm + +# PO receipt entry program (header + open-lines subfile). Calls +# docseq_next('RCP') for numbering; header is POSTED immediately (no DRAFT +# workflow -- adding a receipt line IS the act of receiving). Per-line +# action is subfile Option 1=Receive (not F6=Add) -- every receipt line +# originates from an existing open po_line, unlike poentr/reqentr where F6 +# creates a brand-new row from nothing; option-based selection matches +# poentr's own 2=Change/4=Delete and pobrwr's 5=Detail/9=Schedule idiom for +# actions against an existing row. Converts vendor UOM -> inventory UOM via +# item_uom_conversion, upserts item_lot for lot-controlled items, rolls +# po_line.received_qty/status_code and po_header.status_code forward -- +# the PO-status-transition-from-receipts follow-up PERP-7's recap deferred +# to this epic. +rcventd.file: qddssrc/rcventd.dspf +rcventr.pgm: qrpglesrc/rcventr.sqlrpgle qrpglesrc/docseq_pr.rpgle qddssrc/rcventd.dspf | rcventd.file perp.bnddir po_receipt.file po_receipt_line.file po_header.file po_line.file item.file item_uom_conversion.file item_lot.file perp_user.file uom.file + +# Lot reconciliation service. Module + srvpgm + bnddir, same pattern as +# docseq/itmvprcq/whcoord/reqauto. Scans lot-controlled items for one +# company, compares item.qty_on_hand to SUM(item_lot.qty_on_hand), logs +# and repairs (lot is the source of truth) any drift to reconciliation_log. +lotrecon.module: qrpglesrc/lotrecon.sqlrpgle qrpglesrc/lotrecon_pr.rpgle | item.file item_lot.file reconciliation_log.file +lotrecon.srvpgm: lotrecon.module qsrvsrc/lotrecon.bnd +# perp.bnddir target already declared above (PERP-19 docseq section); +# adding a new addbnddire entry there for lotrecon is enough. + +# Smoke-test caller for lotrecon -- CALL PERPDEMO/LOTRCNSMK PARM('ACM' 'CODERFLOW '). +lotrcnsmk.pgm: qrpglesrc/lotrcnsmk.sqlrpgle qrpglesrc/lotrecon_pr.rpgle lotrecon.srvpgm | perp.bnddir item.file item_lot.file reconciliation_log.file + +# Reconciliation log browse & inquiry. Filterable subfile (item, reconciled +# by, date range on run_timestamp); Option 5 drills to a plain-record +# detail showing before/after values + notes. No F6=Add -- this table is +# populated exclusively by lotrecon, never by hand (same reasoning pobrwd +# already applies: browse-only screens in this module omit F6). +rcnbrwd.file: qddssrc/rcnbrwd.dspf +rcnbrwr.pgm: qrpglesrc/rcnbrwr.sqlrpgle qddssrc/rcnbrwd.dspf | rcnbrwd.file reconciliation_log.file item.file + + # --- PERP menus (glue for exploratory verification) ----------------------- # GO PERPDEMO/PERPMNU is the single entry point. PERPMNU itself only holds # "Select company" + one option per child menu + Sign off -- the child @@ -289,7 +333,7 @@ perpvndm.menu: perpvndm.msgf perpvndm.file | wrkvndr.pgm wrkivnr.pgm wrkivpr.pgm # PERP-19/27/32: service-program smoke testers perpdiag.file: qddssrc/perpdiag.dspf perpdiag.msgf: perpdiag.msgf -perpdiag.menu: perpdiag.msgf perpdiag.file | docseqsmk.pgm ivprcqsmk.pgm whcoordsmk.pgm reqautosmk.pgm +perpdiag.menu: perpdiag.msgf perpdiag.file | docseqsmk.pgm ivprcqsmk.pgm whcoordsmk.pgm reqautosmk.pgm lotrcnsmk.pgm # PERP-6/7/8: Requisitioning / Purchasing / Receiving each get their own # child menu under PERPMNU (see codermake menu note below). PERP-34 adds @@ -305,11 +349,17 @@ perppom.file: qddssrc/perppom.dspf perppom.msgf: perppom.msgf perppom.menu: perppom.msgf perppom.file | poentr.pgm poreqr.pgm poschr.pgm pobrwr.pgm +# PERP-8 Receiving child menu. Option 1 (rcventr, PERP-43), option 2 +# (rcnbrwr, reconciliation log browse, PERP-45). +perprcvm.file: qddssrc/perprcvm.dspf +perprcvm.msgf: perprcvm.msgf +perprcvm.menu: perprcvm.msgf perprcvm.file | rcventr.pgm rcnbrwr.pgm + # Top-level menu. Order-only on perpselr.pgm (called directly) and on the -# 6 child .menu targets (routed to via GO PERPDEMO/, not CALLed). +# 7 child .menu targets (routed to via GO PERPDEMO/, not CALLed). perpmnu.file: qddssrc/perpmnu.dspf perpmnu.msgf: perpmnu.msgf -perpmnu.menu: perpmnu.msgf perpmnu.file | perpselr.pgm perpsysm.menu perpinvm.menu perpvndm.menu perpdiag.menu perpreqm.menu perppom.menu +perpmnu.menu: perpmnu.msgf perpmnu.file | perpselr.pgm perpsysm.menu perpinvm.menu perpvndm.menu perpdiag.menu perpreqm.menu perppom.menu perprcvm.menu # --- CL setup ------------------------------------------------------------- diff --git a/perp/perp.bnddir b/perp/perp.bnddir index 02527487..2ac25477 100644 --- a/perp/perp.bnddir +++ b/perp/perp.bnddir @@ -3,3 +3,4 @@ addbnddire bnddir($LIBRARY/$NAME) obj(($LIBRARY/docseq *srvpgm *immed)) addbnddire bnddir($LIBRARY/$NAME) obj(($LIBRARY/itmvprcq *srvpgm *immed)) addbnddire bnddir($LIBRARY/$NAME) obj(($LIBRARY/whcoord *srvpgm *immed)) addbnddire bnddir($LIBRARY/$NAME) obj(($LIBRARY/reqauto *srvpgm *immed)) +addbnddire bnddir($LIBRARY/$NAME) obj(($LIBRARY/lotrecon *srvpgm *immed)) diff --git a/perp/perpdiag.msgf b/perp/perpdiag.msgf index 41310016..66847a16 100644 --- a/perp/perpdiag.msgf +++ b/perp/perpdiag.msgf @@ -3,3 +3,4 @@ addmsgd msgid(usr0001) msgf($LIBRARY/$NAME) msg('call docseqsmk parm(''ACM'' ''P addmsgd msgid(usr0002) msgf($LIBRARY/$NAME) msg('call ivprcqsmk parm(''ACM'' ''WIDGET1'')') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0003) msgf($LIBRARY/$NAME) msg('call whcoordsmk parm(''ACM'')') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0004) msgf($LIBRARY/$NAME) msg('call reqautosmk parm(''ACM'' ''3 '')') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0005) msgf($LIBRARY/$NAME) msg('call lotrcnsmk parm(''ACM'' ''CODERFLOW '')') seclvl(*none) sev(00) fmt(*none) diff --git a/perp/perpmnu.msgf b/perp/perpmnu.msgf index acd07c58..973a43e2 100644 --- a/perp/perpmnu.msgf +++ b/perp/perpmnu.msgf @@ -6,4 +6,5 @@ addmsgd msgid(usr0004) msgf($LIBRARY/$NAME) msg('go perpdemo/perpvndm') addmsgd msgid(usr0005) msgf($LIBRARY/$NAME) msg('go perpdemo/perpdiag') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0006) msgf($LIBRARY/$NAME) msg('go perpdemo/perpreqm') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0007) msgf($LIBRARY/$NAME) msg('go perpdemo/perppom') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0008) msgf($LIBRARY/$NAME) msg('go perpdemo/perprcvm') seclvl(*none) sev(00) fmt(*none) addmsgd msgid(usr0090) msgf($LIBRARY/$NAME) msg('signoff') seclvl(*none) sev(00) fmt(*none) diff --git a/perp/perprcvm.msgf b/perp/perprcvm.msgf new file mode 100644 index 00000000..47afa538 --- /dev/null +++ b/perp/perprcvm.msgf @@ -0,0 +1,3 @@ +crtmsgf msgf($LIBRARY/$NAME) +addmsgd msgid(usr0001) msgf($LIBRARY/$NAME) msg('call rcventr') seclvl(*none) sev(00) fmt(*none) +addmsgd msgid(usr0002) msgf($LIBRARY/$NAME) msg('call rcnbrwr') seclvl(*none) sev(00) fmt(*none) diff --git a/perp/qddlsrc/po_receipt.table.sql b/perp/qddlsrc/po_receipt.table.sql new file mode 100644 index 00000000..ff35eb95 --- /dev/null +++ b/perp/qddlsrc/po_receipt.table.sql @@ -0,0 +1,89 @@ +-- --------------------------------------------------------------------------- +-- Table: po_receipt (system name PO_RECEIPT, auto-derived) +-- Module: perp +-- Purpose: Purchase order receipt header. One row per receiving event +-- against a PO (multiple receipts per PO are expected -- scheduled +-- / blanket deliveries and partial shipments both land here). +-- receipt_number is allocated from document_sequence via +-- docseq_next('RCP'), same idiom as po_number/requisition_number. +-- status_code defaults to POSTED -- unlike po_header/requisition +-- there is no DRAFT workflow here: creating a receipt line IS the +-- act of receiving (see rcventr, PERP-43), so the header is +-- POSTED from creation. RCPSTATUS (DRAFT/POSTED/VOIDED) was +-- already seeded in code_master by PERP-2/PERP-15; VOIDED exists +-- for a future void flow but no program sets it in this epic -- +-- same "lookup exists, no program uses it yet" deferral pattern +-- as POSTATUS.CANCELLED noted in PERP-7's recap. +-- Epic: PERP-8 (PERP-42) +-- --------------------------------------------------------------------------- + +-- 'po_receipt' (10 chars) is itself a valid system name, so DB2 auto-derives +-- PO_RECEIPT and an explicit FOR SYSTEM NAME would raise SQL7029 -- same +-- rule as po_line/po_header (DDL_STYLE_GUIDE.md Sec.2). +CREATE TABLE po_receipt ( + + -- Composite key (per-company) --------------------------------------------- + company_code FOR COLUMN COMPCD CHAR(3) NOT NULL, + receipt_number FOR COLUMN RCPNBR BIGINT NOT NULL, + + -- Source PO --------------------------------------------------------------- + po_number FOR COLUMN PONBR BIGINT NOT NULL, + + -- Receipt metadata ---------------------------------------------------------- + receipt_date FOR COLUMN RCPDT DATE NOT NULL DEFAULT CURRENT_DATE, + -- received_by is NOT FK'd to perp_user's role -- any perp_user may + -- receive; role-based restriction is out of scope for this epic. + received_by FOR COLUMN RCVBY CHAR(10) NOT NULL, + + -- Status (FK to code_master RCPSTATUS) ------------------------------------- + status_code FOR COLUMN STCODE VARCHAR(20) NOT NULL DEFAULT 'POSTED', + status_type FOR COLUMN STTYPE VARCHAR(20) NOT NULL DEFAULT 'RCPSTATUS', + + -- Long-form notes. 'notes' (5 chars) is itself a valid system name so + -- explicit FOR COLUMN NOTES raises SQL0612 -- omit and let it auto-derive + -- (same finding as po_header/requisition_header, DDL_STYLE_GUIDE.md Sec.2). + notes CLOB(16K), + + -- Standard audit block ---------------------------------------------------- + created_at FOR COLUMN CRTAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + created_by FOR COLUMN CRTBY VARCHAR(18) NOT NULL DEFAULT USER, + updated_at FOR COLUMN UPDAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_by FOR COLUMN UPDBY VARCHAR(18) NOT NULL DEFAULT USER, + is_active FOR COLUMN ISACT CHAR(1) NOT NULL DEFAULT 'Y', + + -- Composite primary key --------------------------------------------------- + PRIMARY KEY (company_code, receipt_number), + + -- Constraints --------------------------------------------------------------- + CONSTRAINT porcp_isact_ck CHECK (is_active IN ('Y','N')), + CONSTRAINT porcp_sttype_ck CHECK (status_type = 'RCPSTATUS'), + + -- FKs ----------------------------------------------------------------------- + CONSTRAINT porcp_company_fk FOREIGN KEY (company_code) + REFERENCES company (company_code) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT porcp_po_fk FOREIGN KEY (company_code, po_number) + REFERENCES po_header (company_code, po_number) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT porcp_rcvby_fk FOREIGN KEY (received_by) + REFERENCES perp_user (user_code) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT porcp_stat_fk FOREIGN KEY (status_type, status_code) + REFERENCES code_master (code_type, code_value) + ON DELETE RESTRICT ON UPDATE RESTRICT +); + +LABEL ON TABLE po_receipt IS + 'PERP purchase order receipt header'; + +LABEL ON COLUMN po_receipt ( + company_code IS 'Company code (FK to po_header)', + receipt_number IS 'Receipt number (docseq RCP)', + po_number IS 'Source PO number (FK to po_header)', + receipt_date IS 'Date goods were received', + received_by IS 'Receiver (FK to perp_user)', + status_code IS 'Status (FK to code_master RCPSTATUS)', + status_type IS 'Status type discriminator (constant)', + notes IS 'Long-form notes', + is_active IS 'Active flag (Y/N, soft delete)' +); diff --git a/perp/qddlsrc/po_receipt_line.table.sql b/perp/qddlsrc/po_receipt_line.table.sql new file mode 100644 index 00000000..e745216d --- /dev/null +++ b/perp/qddlsrc/po_receipt_line.table.sql @@ -0,0 +1,106 @@ +-- --------------------------------------------------------------------------- +-- Table: po_receipt_line (auto-derived short name) +-- Module: perp +-- Purpose: Purchase order receipt line. Records what was actually received +-- against one po_line, in BOTH the vendor's UOM (as entered) and +-- the item's inventory UOM (as posted to item.qty_on_hand / +-- item_lot), plus the conversion factor snapshot used at receipt +-- time (same snapshot idiom as po_line.unit_price). +-- +-- po_number is denormalized from the parent po_receipt row. +-- po_receipt only carries po_number, not po_line's line_number, +-- so without this column a direct FK to po_line would need a +-- three-table join at insert time just to resolve one value. +-- Storing it here (like buyer_code on po_header, unit_price on +-- po_line) makes the FK to po_line direct and gives rcventr a +-- single INSERT instead of a lookup-then-insert. item_number is +-- denormalized from po_line the same way, for a direct FK to +-- item and so item_lot upserts don't need an extra join either. +-- +-- lot_number is nullable. The ticket's stated rule -- +-- "if item.lot_controlled = 'Y' then lot_number IS NOT NULL" -- +-- cannot be a DB2 for i CHECK constraint: a CHECK expression may +-- only reference columns of the table being defined, and +-- lot_controlled lives on item, a different table. Enforced in +-- rcventr (PERP-43) before INSERT instead; see +-- DDL_STYLE_GUIDE.md Sec.17 for the general rule. +-- Epic: PERP-8 (PERP-42) +-- --------------------------------------------------------------------------- + +-- 'po_receipt_line' is 16 chars -- DB2 will auto-derive a short name (same +-- shape as po_line_schedule/requisition_line). FOR SYSTEM NAME omitted per +-- DDL_STYLE_GUIDE.md Sec.2; confirm the real short name via DSPOBJD after +-- build before referencing it in any native/CL-level command. +CREATE TABLE po_receipt_line ( + + -- Composite key (per-company, per-receipt) --------------------------------- + company_code FOR COLUMN COMPCD CHAR(3) NOT NULL, + receipt_number FOR COLUMN RCPNBR BIGINT NOT NULL, + line_number FOR COLUMN LINNBR INTEGER NOT NULL, + + -- Denormalized back-link to po_line (see header note) ---------------------- + po_number FOR COLUMN PONBR BIGINT NOT NULL, + po_line_number FOR COLUMN POLNNBR INTEGER NOT NULL, + item_number FOR COLUMN ITMNBR VARCHAR(25) NOT NULL, + + -- Quantities: vendor UOM as entered, inventory UOM as posted, and the + -- conversion factor snapshot used to compute the latter from the former. + qty_received_vendor_uom FOR COLUMN QTYVUOM DECIMAL(15,4) NOT NULL, + qty_received_inventory_uom FOR COLUMN QTYIUOM DECIMAL(15,4) NOT NULL, + uom_conversion_factor FOR COLUMN CONVFCT DECIMAL(15,6) NOT NULL DEFAULT 1, + + -- Lot number -- required by rcventr when item.lot_controlled = 'Y', + -- nullable here since DB2 for i can't cross-table CHECK it (see header). + lot_number FOR COLUMN LOTNBR VARCHAR(20), + + -- 'notes' auto-derives to a valid <=10-char system name; explicit + -- FOR COLUMN NOTES raises SQL0612 (same finding as po_line_schedule) -- + -- omit. + notes VARCHAR(240) NOT NULL DEFAULT '', + + -- Standard audit block ---------------------------------------------------- + created_at FOR COLUMN CRTAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + created_by FOR COLUMN CRTBY VARCHAR(18) NOT NULL DEFAULT USER, + updated_at FOR COLUMN UPDAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_by FOR COLUMN UPDBY VARCHAR(18) NOT NULL DEFAULT USER, + is_active FOR COLUMN ISACT CHAR(1) NOT NULL DEFAULT 'Y', + + -- Composite primary key --------------------------------------------------- + PRIMARY KEY (company_code, receipt_number, line_number), + + -- Constraints --------------------------------------------------------------- + CONSTRAINT porcl_isact_ck CHECK (is_active IN ('Y','N')), + CONSTRAINT porcl_linnbr_ck CHECK (line_number > 0), + CONSTRAINT porcl_qtyvuom_ck CHECK (qty_received_vendor_uom > 0), + CONSTRAINT porcl_qtyiuom_ck CHECK (qty_received_inventory_uom > 0), + CONSTRAINT porcl_convfct_ck CHECK (uom_conversion_factor > 0), + + -- FKs ----------------------------------------------------------------------- + CONSTRAINT porcl_rcpt_fk FOREIGN KEY (company_code, receipt_number) + REFERENCES po_receipt (company_code, receipt_number) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT porcl_poln_fk FOREIGN KEY (company_code, po_number, po_line_number) + REFERENCES po_line (company_code, po_number, line_number) + ON DELETE RESTRICT ON UPDATE RESTRICT, + CONSTRAINT porcl_item_fk FOREIGN KEY (company_code, item_number) + REFERENCES item (company_code, item_number) + ON DELETE RESTRICT ON UPDATE RESTRICT +); + +LABEL ON TABLE po_receipt_line IS + 'PERP purchase order receipt line'; + +LABEL ON COLUMN po_receipt_line ( + company_code IS 'Company code (FK to po_receipt)', + receipt_number IS 'Receipt number (FK to po_receipt)', + line_number IS 'Line number within receipt (PK)', + po_number IS 'Source PO number (FK to po_line, denorm)', + po_line_number IS 'Source PO line number (FK to po_line)', + item_number IS 'Item received (FK to item, denorm)', + qty_received_vendor_uom IS 'Qty received, vendor UOM (as entered)', + qty_received_inventory_uom IS 'Qty received, inventory UOM (as posted)', + uom_conversion_factor IS 'Vendor-to-inventory UOM factor snapshot', + lot_number IS 'Lot number, required if item lot-controlled', + notes IS 'Receipt line notes', + is_active IS 'Active flag (Y/N, soft delete)' +); diff --git a/perp/qddlsrc/reconciliation_log.table.sql b/perp/qddlsrc/reconciliation_log.table.sql new file mode 100644 index 00000000..24631ebe --- /dev/null +++ b/perp/qddlsrc/reconciliation_log.table.sql @@ -0,0 +1,86 @@ +-- --------------------------------------------------------------------------- +-- Table: reconciliation_log (auto-derived short name) +-- Module: perp +-- Purpose: Audit trail of lot-vs-item-balance drift detection and repair. +-- Written exclusively by the lotrecon service program (PERP-44) +-- -- no RPG program inserts into this table interactively. Has no +-- natural key (a reconciliation run doesn't identify itself by +-- anything but "when it happened"), so per DDL_STYLE_GUIDE.md +-- Sec.5 this is the one table in the module allowed a surrogate +-- GENERATED ALWAYS AS IDENTITY key. +-- +-- reconciled_by is NOT FK'd to perp_user -- an automated run +-- stamps the literal 'CODERFLOW', which is not a row in the human +-- user directory. Same rationale/pattern as +-- requisition_header.approved_by. +-- Epic: PERP-8 (PERP-42) +-- --------------------------------------------------------------------------- + +-- 'reconciliation_log' is 19 chars -- DB2 will auto-derive a short name. +-- FOR SYSTEM NAME omitted per DDL_STYLE_GUIDE.md Sec.2; confirm the real +-- short name via DSPOBJD after build. +CREATE TABLE reconciliation_log ( + + -- Composite key -- company_code leads per Sec.3, reconciliation_id is + -- the IDENTITY surrogate (globally unique on its own; company_code + -- still leads the PK for multi-tenant consistency with every other + -- table in the module). ------------------------------------------------ + company_code FOR COLUMN COMPCD CHAR(3) NOT NULL, + reconciliation_id FOR COLUMN RECONID INTEGER GENERATED ALWAYS AS IDENTITY + (START WITH 1 INCREMENT BY 1) NOT NULL, + + -- What was reconciled and when -------------------------------------------- + item_number FOR COLUMN ITMNBR VARCHAR(25) NOT NULL, + run_timestamp FOR COLUMN RUNTS TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + + -- Before / after balances -------------------------------------------------- + item_qty_before FOR COLUMN QTYBEF DECIMAL(15,4) NOT NULL, + lot_sum_before FOR COLUMN LOTBEF DECIMAL(15,4) NOT NULL, + qty_after FOR COLUMN QTYAFT DECIMAL(15,4) NOT NULL, + + -- Who/what ran the reconciliation. Not FK'd -- see header note. + reconciled_by FOR COLUMN RCNBY VARCHAR(18) NOT NULL, + + -- 'notes' auto-derives to a valid <=10-char system name; explicit + -- FOR COLUMN NOTES raises SQL0612 (same finding as elsewhere) -- omit. + notes VARCHAR(240) NOT NULL DEFAULT '', + + -- Standard audit block. This table is append-only in practice (no + -- program updates a row after insert), but every PERP table carries + -- the same five columns for module consistency. ----------------------- + created_at FOR COLUMN CRTAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + created_by FOR COLUMN CRTBY VARCHAR(18) NOT NULL DEFAULT USER, + updated_at FOR COLUMN UPDAT TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_by FOR COLUMN UPDBY VARCHAR(18) NOT NULL DEFAULT USER, + is_active FOR COLUMN ISACT CHAR(1) NOT NULL DEFAULT 'Y', + + -- Composite primary key --------------------------------------------------- + PRIMARY KEY (company_code, reconciliation_id), + + -- Constraints --------------------------------------------------------------- + CONSTRAINT rcnlog_isact_ck CHECK (is_active IN ('Y','N')), + CONSTRAINT rcnlog_qtybef_ck CHECK (item_qty_before >= 0), + CONSTRAINT rcnlog_lotbef_ck CHECK (lot_sum_before >= 0), + CONSTRAINT rcnlog_qtyaft_ck CHECK (qty_after >= 0), + + -- FK to item ------------------------------------------------------------ + CONSTRAINT rcnlog_item_fk FOREIGN KEY (company_code, item_number) + REFERENCES item (company_code, item_number) + ON DELETE RESTRICT ON UPDATE RESTRICT +); + +LABEL ON TABLE reconciliation_log IS + 'PERP lot vs item balance reconciliation audit log'; + +LABEL ON COLUMN reconciliation_log ( + company_code IS 'Company code (FK to item)', + reconciliation_id IS 'Surrogate identity key (no natural key exists)', + item_number IS 'Item reconciled (FK to item)', + run_timestamp IS 'When the reconciliation ran', + item_qty_before IS 'item.qty_on_hand before repair', + lot_sum_before IS 'SUM(item_lot.qty_on_hand) before repair', + qty_after IS 'item.qty_on_hand after repair (= lot_sum_before)', + reconciled_by IS 'User code or CODERFLOW, not FK-enforced', + notes IS 'Reconciliation notes', + is_active IS 'Active flag (Y/N, soft delete)' +); diff --git a/perp/qddssrc/perpdiag.dspf b/perp/qddssrc/perpdiag.dspf index a71a3880..50f51587 100644 --- a/perp/qddssrc/perpdiag.dspf +++ b/perp/qddssrc/perpdiag.dspf @@ -28,6 +28,8 @@ A te service' A 8 7'4. Smoke test CoderFlow auto-app- A roval hook' + A 9 7'5. Smoke test lot reconciliation + A service' A 23 2'F3=Exit' A COLOR(BLU) A* CMDPROMPT Do not delete this DDS spec. diff --git a/perp/qddssrc/perpmnu.dspf b/perp/qddssrc/perpmnu.dspf index 347388de..f8f2e888 100644 --- a/perp/qddssrc/perpmnu.dspf +++ b/perp/qddssrc/perpmnu.dspf @@ -27,7 +27,8 @@ A 9 7'5. Diagnostics / Smoke Tests' A 10 7'6. Requisitioning' A 11 7'7. Purchasing' - A 12 6'90. Sign off' + A 12 7'8. Receiving' + A 13 6'90. Sign off' A 23 2'F3=Exit' A COLOR(BLU) A* CMDPROMPT Do not delete this DDS spec. diff --git a/perp/qddssrc/perprcvm.dspf b/perp/qddssrc/perprcvm.dspf new file mode 100644 index 00000000..b0df9fe5 --- /dev/null +++ b/perp/qddssrc/perprcvm.dspf @@ -0,0 +1,30 @@ + A* PERPRCVM menu + A DSPSIZ(24 80 *DS3) + A CHGINPDFT + A INDARA + A PRINT(*LIBL/QSYSPRT) + A* CRTMNU TYPE(*DSPF) requires a record format named PERPRCVM + A R PERPRCVM + A LOCK + A SLNO(01) + A CLRL(*ALL) + A ALWROL + A CF03 + A HELP + A HOME + A HLPRTN + A 1 2'PERPRCVM' + A COLOR(BLU) + A 1 25'PERP - Receiving & Reconcilia- + A tion' + A DSPATR(HI) + A COLOR(WHT) + A 3 2'Select one of the following:' + A COLOR(BLU) + A 5 7'1. Receive against a PO' + A 6 7'2. Reconciliation log browse' + A 23 2'F3=Exit' + A COLOR(BLU) + A* CMDPROMPT Do not delete this DDS spec. + A 021 2'Selection: - + A ' diff --git a/perp/qddssrc/rcnbrwd.dspf b/perp/qddssrc/rcnbrwd.dspf new file mode 100644 index 00000000..11b8ebe9 --- /dev/null +++ b/perp/qddssrc/rcnbrwd.dspf @@ -0,0 +1,92 @@ + A DSPSIZ(24 80 *DS3) + A PRINT + A CA03(03 'Exit') + A CA05(05 'Refresh') + A CA12(12 'Cancel/Back') + A R LSFL SFL + A 51 SFLNXTCHG + A LSOPT 1A B 11 2 + A 50 DSPATR(RI) + A 50 DSPATR(PC) + A LSID 10Y 0O 11 5EDTCDE(3) + A LSITEM 25A O 11 17 + A LSQBEF 11Y 4O 11 43EDTCDE(3) + A LSQAFT 11Y 4O 11 57EDTCDE(3) + A LSRCNBY 10A O 11 70 + A R LCTL SFLCTL(LSFL) + A SFLSIZ(0099) + A SFLPAG(0006) + A OVERLAY + A SFLDSPCTL + A N31 30 SFLDSP + A 31 SFLCLR + A N31 30 SFLEND(*MORE) + A 1 22'Reconciliation Log Browse' + A DSPATR(HI) + A 2 2'Company:' + A LCOMPDSP 3A O 2 11 + A 3 2'Filter -- Item:' + A FITEM 25A B 3 18 + A 3 46'Reconciled By:' + A FRCNBY 18A B 3 62 + A 4 2'From date:' + A FFRDT L B 4 13DATFMT(*ISO) + A 4 27'To date:' + A FTODT L B 4 36DATFMT(*ISO) + A 4 50'(blank = no filter)' + A 6 2'Enter=Apply filter' + A 8 2'Type option, press Enter.' + A 9 4'5=Detail' + A 10 2'Opt' + A DSPATR(UL) + A 10 5'ID' + A DSPATR(UL) + A 10 17'Item' + A DSPATR(UL) + A 10 43'Qty Before' + A DSPATR(UL) + A 10 57'Qty After' + A DSPATR(UL) + A 10 70'By' + A DSPATR(UL) + A R LFOOT + A OVERLAY + A 23 2'F3=Exit F5=Refresh F12=Back' + A COLOR(BLU) + A R LNOROWS + A OVERLAY + A 13 15'No reconciliation log entries - + A match filter.' + A R LDETAIL + A OVERLAY + A 1 27'Reconciliation Detail' + A DSPATR(HI) + A 2 2'ID:' + A DDID 10Y 0O 2 7EDTCDE(3) + A 2 20'Item:' + A DDITEM 25A O 2 26 + A 3 2'Run Timestamp:' + A DDRUNTS 26A O 3 17 + A 5 2'Qty Before:' + A DDQBEF 11Y 4O 5 14EDTCDE(3) + A 5 30'Lot Sum Before:' + A DDLSUM 11Y 4O 5 46EDTCDE(3) + A 6 2'Qty After:' + A DDQAFT 11Y 4O 6 14EDTCDE(3) + A 7 2'Reconciled By:' + A DDRCNBY 18A O 7 17 + A 8 2'Notes:' + A DDNOTES 70A O 8 9 + A 23 2'F5=Refresh F12=Back' + A COLOR(BLU) + A R RMSGSFL SFL + A SFLMSGRCD(24) + A SMSGKEY SFLMSGKEY + A SPGMQ SFLPGMQ(10) + A R RMSGCTL SFLCTL(RMSGSFL) + A OVERLAY + A N41 40 SFLDSP + A 41 SFLCLR + A N41 40 SFLEND + A SFLSIZ(0002) + A SFLPAG(0001) diff --git a/perp/qddssrc/rcventd.dspf b/perp/qddssrc/rcventd.dspf new file mode 100644 index 00000000..81f338af --- /dev/null +++ b/perp/qddssrc/rcventd.dspf @@ -0,0 +1,117 @@ + A DSPSIZ(24 80 *DS3) + A PRINT + A CA03(03 'Exit') + A CA05(05 'Refresh') + A CA12(12 'Cancel') + A R RHEAD + A OVERLAY + A 1 28'Receipt Entry' + A DSPATR(HI) + A 2 2'Company:' + A HCOMPDSP 3A O 2 11 + A 3 2'PO Number:' + A HPONBR 15Y 0B 3 13EDTCDE(3) + A 3 31'Vendor:' + A HVNDNM 30A O 3 39 + A 4 2'PO Status:' + A HPOSTAT 20A O 4 13 + A 5 2'Receipt Date:' + A HRCPDT L B 5 16DATFMT(*ISO) + A 5 28'(YYYY-MM-DD)' + A 6 2'Received By:' + A HRCVBY 10A B 6 16 + A HRCVNM 30A O 6 28 + A 7 2'Notes:' + A HNOTES 50A B 7 9 + A 23 2'F3=Exit F12=Cancel' + A COLOR(BLU) + A R RLSFL SFL + A 51 SFLNXTCHG + A SLOPT 1A B 9 2 + A 50 DSPATR(RI) + A 50 DSPATR(PC) + A SLLINE 3Y 0O 9 7EDTCDE(3) + A SLITEM 25A O 9 12 + A SLDESC 20A O 9 38 + A SLOPEN 11Y 4O 9 59EDTCDE(3) + A SLUOM 5A O 9 72 + A R RLCTL SFLCTL(RLSFL) + A SFLSIZ(0099) + A SFLPAG(0007) + A OVERLAY + A SFLDSPCTL + A N31 30 SFLDSP + A 31 SFLCLR + A N31 30 SFLEND(*MORE) + A 1 27'Purchase Order Receiving' + A DSPATR(HI) + A 2 2'PO #:' + A DPONBR 15A O 2 8 + A 2 30'Vendor:' + A DVNDR 10A O 2 38 + A DVNDNM 25A O 2 49 + A 3 2'Received By:' + A DRCVBY 10A O 3 16 + A DRCVNM 30A O 3 28 + A 4 2'Receipt Date:' + A DRCPDT L O 4 16DATFMT(*ISO) + A 4 30'PO Status:' + A DPOSTAT 20A O 4 41 + A 6 2'Type 1=Receive next to a line, - + A press Enter.' + A 7 2'Opt' + A DSPATR(UL) + A 7 7'Line' + A DSPATR(UL) + A 7 12'Item' + A DSPATR(UL) + A 7 38'Description' + A DSPATR(UL) + A 7 59'Open Qty' + A DSPATR(UL) + A 7 72'UOM' + A DSPATR(UL) + A R RLFOOT + A OVERLAY + A 23 2'F3=Exit F5=Refresh F12=Cancel' + A COLOR(BLU) + A R RNOLIN + A OVERLAY + A 11 15'No open lines for this PO -- eve- + A rything has been received.' + A R RLEDIT + A OVERLAY + A 1 25'Receive PO Line' + A DSPATR(HI) + A 2 2'Line:' + A ELINE 3Y 0O 2 8EDTCDE(3) + A 2 20'Item:' + A EITEM 25A O 2 26 + A 3 2'Description:' + A EDESC 30A O 3 16 + A 4 2'Open Qty:' + A EOPEN 11Y 4O 4 12EDTCDE(3) + A 4 30'Vendor UOM:' + A EUOM 5A O 4 42 + A 5 2'Qty Received (vendor UOM):' + A EQTY 11Y 4B 5 30EDTCDE(3) + A 6 2'Lot Controlled:' + A ELOTCTL 1A O 6 18 + A 7 2'Lot Number:' + A ELOT 20A B 7 14 + A 7 36'(required if lot controlled)' + A 8 2'Notes:' + A ENOTES 50A B 8 9 + A 23 2'Enter=Save F12=Cancel' + A COLOR(BLU) + A R RMSGSFL SFL + A SFLMSGRCD(24) + A SMSGKEY SFLMSGKEY + A SPGMQ SFLPGMQ(10) + A R RMSGCTL SFLCTL(RMSGSFL) + A OVERLAY + A N41 40 SFLDSP + A 41 SFLCLR + A N41 40 SFLEND + A SFLSIZ(0002) + A SFLPAG(0001) diff --git a/perp/qrpglesrc/lotrcnsmk.sqlrpgle b/perp/qrpglesrc/lotrcnsmk.sqlrpgle new file mode 100644 index 00000000..43f10e84 --- /dev/null +++ b/perp/qrpglesrc/lotrcnsmk.sqlrpgle @@ -0,0 +1,77 @@ +**free + +// --------------------------------------------------------------------- +// Program: lotrcnsmk (lotrecon smoke test) +// Purpose: One-shot caller that exercises lotrecon_run and prints the +// results via SNDPGMMSG so a joblog + interactive session +// confirms the service program is bound correctly. Also +// proves out the CoderFlow demo path: reconciled_by = +// 'CODERFLOW' when called with that parameter. +// Meant to be CALLed once from an interactive session: +// CALL PGM(PERPDEMO/LOTRCNSMK) PARM('ACM' 'CODERFLOW ') +// Epic: PERP-8 (PERP-44) +// --------------------------------------------------------------------- + +ctl-opt dftactgrp(*no) actgrp(*new) bnddir('PERP'); + +/copy lotrecon_pr.rpgle + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-pi *n; + p_company char(3); + p_reconciledby char(18); +end-pi; + +dcl-ds rows likeds(lotrecon_row) dim(200); +dcl-s errmsg varchar(80); +dcl-s cnt int(10); +dcl-s i int(10); +dcl-s line char(256); +dcl-s msgkey char(4); + +cnt = lotrecon_run(p_company : p_reconciledby : rows : errmsg); +line = 'lotrecon_run discrepancies=' + %char(cnt) + ' err=' + errmsg; +callMsg(line); + +for i = 1 to cnt; + line = %trim(rows(i).item) + ' before=' + %char(rows(i).qtybefore) + + ' lotsum=' + %char(rows(i).lotsum) + + ' after=' + %char(rows(i).qtyafter); + callMsg(line); +endfor; + +// The service program never commits (leaf module rule, DDL_STYLE_GUIDE +// Sec.13) -- the caller commits here. +exec sql commit; + +*inlr = *on; +return; + +dcl-proc callMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + msgkey : + x'0000000000000000'); +end-proc; diff --git a/perp/qrpglesrc/lotrecon.sqlrpgle b/perp/qrpglesrc/lotrecon.sqlrpgle new file mode 100644 index 00000000..221a99a8 --- /dev/null +++ b/perp/qrpglesrc/lotrecon.sqlrpgle @@ -0,0 +1,92 @@ +**free + +// --------------------------------------------------------------------- +// Module: lotrecon (lot vs item-balance reconciliation service) +// Purpose: Implements lotrecon_run -- see lotrecon_pr.rpgle for the +// prototype and its docstring. +// Epic: PERP-8 (PERP-44) +// --------------------------------------------------------------------- + +ctl-opt nomain; + +// Real commitment control against PERPJRN -- per DDL_STYLE_GUIDE Sec.7. +exec sql set option closqlcsr = *endmod; + +/copy lotrecon_pr.rpgle + +// Host variables prefixed lr_ -- the SQLRPGLE precompiler collects host +// variables at module scope, not subprocedure scope (DDL_STYLE_GUIDE +// Sec.13), so an unprefixed name here could collide with a future +// second exported procedure in this module. +dcl-proc lotrecon_run export; + dcl-pi *n int(10); + lr_company char(3) const; + lr_reconciledby varchar(18) const; + lr_rows likeds(lotrecon_row) dim(200); + lr_errmsg varchar(80); + end-pi; + + dcl-s lr_count int(10) inz(0); + dcl-s lr_item varchar(25); + dcl-s lr_qtyoh packed(15:4); + dcl-s lr_lotsum packed(15:4); + + lr_errmsg = ''; + + // Lot sum via a correlated subquery, not a JOIN + GROUP BY -- an + // item with zero lot rows must still be scanned (lot sum 0 vs + // whatever qty_on_hand drifted to), which an inner JOIN would drop + // and a plain GROUP BY would need a LEFT JOIN + null-handling for + // anyway. COALESCE covers the "no lot rows yet" case. + exec sql declare lr1 cursor for + select i.item_number, i.qty_on_hand, + coalesce((select sum(l.qty_on_hand) + from perpdemo.item_lot l + where l.company_code = i.company_code + and l.item_number = i.item_number + and l.is_active = 'Y'), 0) + from perpdemo.item i + where i.company_code = :lr_company + and i.lot_controlled = 'Y' + and i.is_active = 'Y' + order by i.item_number; + exec sql open lr1; + if sqlcode < 0; + lr_errmsg = 'lotrecon_run open: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate; + return 0; + endif; + + dow lr_count < %elem(lr_rows); + exec sql fetch lr1 into :lr_item, :lr_qtyoh, :lr_lotsum; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + + if lr_qtyoh <> lr_lotsum; + exec sql + insert into perpdemo.reconciliation_log + (company_code, item_number, item_qty_before, lot_sum_before, + qty_after, reconciled_by, notes) + values (:lr_company, :lr_item, :lr_qtyoh, :lr_lotsum, :lr_lotsum, + :lr_reconciledby, 'Auto-repaired: lot is source of truth'); + + exec sql + update perpdemo.item + set qty_on_hand = :lr_lotsum, + updated_at = current_timestamp, + updated_by = :lr_reconciledby + where company_code = :lr_company and item_number = :lr_item; + + lr_count += 1; + lr_rows(lr_count).item = lr_item; + lr_rows(lr_count).qtybefore = lr_qtyoh; + lr_rows(lr_count).lotsum = lr_lotsum; + lr_rows(lr_count).qtyafter = lr_lotsum; + endif; + enddo; + exec sql close lr1; + + return lr_count; + +end-proc; diff --git a/perp/qrpglesrc/lotrecon_pr.rpgle b/perp/qrpglesrc/lotrecon_pr.rpgle new file mode 100644 index 00000000..7420e5f3 --- /dev/null +++ b/perp/qrpglesrc/lotrecon_pr.rpgle @@ -0,0 +1,45 @@ +**free + +// --------------------------------------------------------------------- +// Prototypes: lotrecon (lot vs item-balance reconciliation service) +// Module: perp +// Purpose: Detects drift between item.qty_on_hand and +// SUM(item_lot.qty_on_hand) for lot-controlled items +// (Option C balances -- denormalized by design, see +// item_lot.table.sql), and repairs it. Lot is the source +// of truth: item.qty_on_hand is set to match the lot sum. +// Every repair is logged to reconciliation_log. Callers: +// a future scheduled/CoderFlow job, smoke-test caller +// lotrcnsmk. +// Epic: PERP-8 (PERP-44) +// --------------------------------------------------------------------- + +// One reconciliation result row -- mirrors reconciliation_log's +// before/after columns. +dcl-ds lotrecon_row qualified template; + item varchar(25); + qtybefore packed(15:4); + lotsum packed(15:4); + qtyafter packed(15:4); +end-ds; + +// lotrecon_run -- scan every lot-controlled, active item for one +// company; for each where item.qty_on_hand <> SUM(item_lot.qty_on_hand), +// log the discrepancy to reconciliation_log and repair item.qty_on_hand +// to match the lot sum (lot is the source of truth). Returns the number +// of discrepancies found and repaired (0 = clean, no drift -- check +// errmsg to tell a genuinely clean run apart from a failed one: errmsg +// is blank when 0 legitimately means "no drift found"). +// +// Does NOT commit or rollback -- per DDL_STYLE_GUIDE.md Sec.13, leaf +// service programs never issue commitment-control statements; the +// caller commits (or rolls back on error) after this returns. +// +// Raises no messages itself; SQL diagnostics are returned in errmsg as +// 'SQLCODE=... SQLSTATE=...' for the caller to log/display. +dcl-pr lotrecon_run int(10); + company char(3) const; + reconciledby varchar(18) const; + resultRows likeds(lotrecon_row) dim(200); + errmsg varchar(80); +end-pr; diff --git a/perp/qrpglesrc/rcnbrwr.sqlrpgle b/perp/qrpglesrc/rcnbrwr.sqlrpgle new file mode 100644 index 00000000..a0aa3a52 --- /dev/null +++ b/perp/qrpglesrc/rcnbrwr.sqlrpgle @@ -0,0 +1,264 @@ +**free + +// --------------------------------------------------------------------- +// Program: rcnbrwr (Reconciliation Log Browse & Inquiry) +// Purpose: Filterable subfile of reconciliation_log rows (item, +// reconciled_by, run_timestamp date range). Option 5 drills to +// a plain-record detail showing before/after values + notes. +// No F6=Add -- this table is populated exclusively by the +// lotrecon service (PERP-44), never by hand, same reasoning +// pobrwd already applies (browse-only screens in this module +// omit F6). +// Epic: PERP-8 (PERP-45) +// --------------------------------------------------------------------- + +// datfmt(*iso) is REQUIRED here (not decorative) -- filter defaults use +// 1940-01-01 / 2039-12-31 as sentinels, and the job DATFMT on this +// environment is *MDY (2-digit year, 1940-2039). Without this ctl-opt, +// every Date variable in this program is capped at *MDY's range and +// RNQ0114 fires at runtime the first time the DSPF WRITEs the FFRDT/ +// FTODT fields or the SQL fetches one. Same fix pobrwr needed. +ctl-opt dftactgrp(*no) actgrp(*new) datfmt(*iso); + +dcl-f rcnbrwd workstn sfile(lsfl:rrn) sfile(rmsgsfl:msgrrn); + +dcl-ds ldaDS dtaara(*lda) len(1024) qualified; + compcd char(3) pos(1); +end-ds; + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-ds statusDS psds qualified; + programName char(10) pos(334); +end-ds; + +dcl-ds reconRow qualified; + id int(10); + item varchar(25); + qbef packed(11:4); + qaft packed(11:4); + rcnby varchar(18); +end-ds; + +dcl-ds rows likeds(reconRow) dim(500); +dcl-s numRows int(10); +dcl-s rrn int(10); +dcl-s msgrrn int(10); +dcl-s selRrn int(10); +dcl-s selOpt char(1); +dcl-s selId int(10); +dcl-s i int(10); +dcl-s compcd char(3); + +// Cursor scalars. +dcl-s cId int(10); +dcl-s cItem varchar(25); +dcl-s cQbef packed(11:4); +dcl-s cQaft packed(11:4); +dcl-s cRcnby varchar(18); + +in ldaDS; +compcd = ldaDS.compcd; + +if compcd = ''; + exsr clearMsgs; + writeMsg('No company selected - run Select Company (PERPSELR) first.'); + *in40 = *on; + lcompdsp = ''; + write rmsgctl; + exfmt lfoot; + *inlr = *on; + return; +endif; + +lcompdsp = compcd; +fitem = ''; +frcnby = ''; +// Filter sentinels must stay within the *MDY 1940-2039 range -- see +// ctl-opt comment above and pobrwr's own identical fix. +ffrdt = %date('1940-01-01' : *ISO); +ftodt = %date('2039-12-31' : *ISO); + +// ----------------------------------------------------------------------- +// Browse loop. +// ----------------------------------------------------------------------- +dow '1'; + exsr loadRows; + + if numRows = 0; + *in30 = *off; + write lnorows; + else; + exsr fillSubfile; + *in30 = *on; + endif; + + write lfoot; + *in40 = *off; + if msgrrn > 0; + *in40 = *on; + endif; + write rmsgctl; + exfmt lctl; + + if *in03 or *in12; + leave; + endif; + + exsr clearMsgs; + + if numRows > 0; + selRrn = 0; + selOpt = ' '; + readc lsfl; + dow not %eof(rcnbrwd); + if lsopt <> ''; + if selRrn = 0; + selRrn = rrn; + selOpt = lsopt; + else; + writeMsg('Only one selection per Enter.'); + endif; + endif; + readc lsfl; + enddo; + + if selRrn > 0 and msgrrn = 0; + select; + when selOpt = '5'; + selId = rows(selRrn).id; + exsr showDetail; + other; + writeMsg('Option ' + selOpt + ' not valid.'); + endsl; + endif; + endif; +enddo; + +*inlr = *on; +return; + +// --------------------------------------------------------------------- +// loadRows -- pull reconciliation_log rows matching the current filter +// values. Empty filter fields skip that filter (fitem='' means "any +// item", etc.). +begsr loadRows; + numRows = 0; + + exec sql declare lc1 cursor for + select reconciliation_id, item_number, item_qty_before, qty_after, + reconciled_by + from perpdemo.reconciliation_log + where company_code = :compcd + and (:fitem = '' or item_number = :fitem) + and (:frcnby = '' or reconciled_by = :frcnby) + and cast(run_timestamp as date) between :ffrdt and :ftodt + order by reconciliation_id desc; + exec sql open lc1; + if sqlcode < 0; + writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode) + + ' STATE=' + sqlstate); + return; + endif; + + dow numRows < %elem(rows); + exec sql fetch lc1 into :cId, :cItem, :cQbef, :cQaft, :cRcnby; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + numRows += 1; + rows(numRows).id = cId; + rows(numRows).item = cItem; + rows(numRows).qbef = cQbef; + rows(numRows).qaft = cQaft; + rows(numRows).rcnby = cRcnby; + enddo; + exec sql close lc1; +endsr; + +// --------------------------------------------------------------------- +begsr fillSubfile; + rrn = 0; + *in31 = *on; + write lctl; + *in31 = *off; + for i = 1 to numRows; + lsopt = ''; + lsid = rows(i).id; + lsitem = rows(i).item; + lsqbef = rows(i).qbef; + lsqaft = rows(i).qaft; + // Direct assign VARCHAR -> fixed CHAR: RPG right-pads/truncates + // automatically. %subst is strict about CURRENT length, not + // declared max (DDL_STYLE_GUIDE Sec.13) -- don't use it here. + lsrcnby = rows(i).rcnby; + rrn += 1; + write lsfl; + endfor; +endsr; + +// --------------------------------------------------------------------- +// showDetail -- populate LDETAIL fields for the selected reconciliation +// row. EXFMT once; F12 returns to the browse. +begsr showDetail; + exec sql + select reconciliation_id, item_number, char(run_timestamp), + item_qty_before, lot_sum_before, qty_after, reconciled_by, + notes + into :ddid, :dditem, :ddrunts, :ddqbef, :ddlsum, :ddqaft, + :ddrcnby, :ddnotes + from perpdemo.reconciliation_log + where company_code = :compcd and reconciliation_id = :selId; + if sqlcode <> 0; + writeMsg('Reconciliation ' + %char(selId) + ' lookup failed: SQLCODE=' + + %char(sqlcode)); + return; + endif; + + *in40 = *off; + if msgrrn > 0; + *in40 = *on; + endif; + write rmsgctl; + exfmt ldetail; +endsr; + +// --------------------------------------------------------------------- +begsr clearMsgs; + msgrrn = 0; + *in41 = *on; + write rmsgctl; + *in41 = *off; +endsr; + +// --------------------------------------------------------------------- +dcl-proc writeMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + smsgkey : + x'0000000000000000'); + msgrrn += 1; + spgmq = statusDS.programName; + write rmsgsfl; +end-proc; diff --git a/perp/qrpglesrc/rcventr.sqlrpgle b/perp/qrpglesrc/rcventr.sqlrpgle new file mode 100644 index 00000000..dd16a866 --- /dev/null +++ b/perp/qrpglesrc/rcventr.sqlrpgle @@ -0,0 +1,519 @@ +**free + +// --------------------------------------------------------------------- +// Program: rcventr (PO Receipt Entry) +// Purpose: DSPF-based receipt entry, scoped by the company selected via +// perpselr (*LDA positions 1-3). Header screen picks a PO +// (must be OPEN or PARTIAL) and a receiver; allocates the doc +// number via docseq_next('RCP') and inserts a POSTED header -- +// there is no DRAFT workflow here, unlike poentr/reqentr: +// creating a receipt line IS the act of receiving. +// +// Line screen is a subfile of the PO's still-open lines +// (status_code <> CLOSED), joined to po_line_open for open_qty. +// Per-line action is subfile Option 1=Receive, not F6=Add -- +// every receipt line originates from an existing open po_line, +// unlike poentr where F6 creates a brand-new row from nothing. +// Receiving a line: converts vendor UOM -> inventory UOM via +// item_uom_conversion, upserts item_lot for lot-controlled +// items, and rolls po_line.received_qty/status_code and +// po_header.status_code forward -- the PO-status-transition- +// from-receipts item PERP-7's recap deferred to this epic. +// Epic: PERP-8 (PERP-43) +// --------------------------------------------------------------------- + +// datfmt(*iso) kept for consistency with every other PERP program that +// touches Date fields (DDS DATFMT(*ISO) fields) -- no out-of-range +// sentinel date is used here (receipt_date always defaults to a real +// %date()), so the *MDY host-variable trap (DDL_STYLE_GUIDE Sec.13) +// does not apply to this program the way it did to poentr/pobrwr. +ctl-opt dftactgrp(*no) actgrp(*new) bnddir('PERP') datfmt(*iso); + +dcl-f rcventd workstn sfile(rlsfl:rrn) sfile(rmsgsfl:msgrrn); + +/copy docseq_pr.rpgle + +dcl-ds ldaDS dtaara(*lda) len(1024) qualified; + compcd char(3) pos(1); +end-ds; + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-ds statusDS psds qualified; + programName char(10) pos(334); +end-ds; + +dcl-ds lineRow qualified; + lnbr int(10); + item varchar(25); + desc varchar(30); + openqty packed(11:4); + uom varchar(5); +end-ds; + +dcl-ds rows likeds(lineRow) dim(500); +dcl-s numRows int(10); +dcl-s i int(10); +dcl-s rrn int(10); +dcl-s msgrrn int(10); +dcl-s selRrn int(10); +dcl-s selOpt char(1); +dcl-s compcd char(3); +dcl-s rcpnbr int(20); +dcl-s docerrmsg varchar(80); +dcl-s hvndnmW varchar(60); +dcl-s hrcvnmW varchar(60); +dcl-s dvndnmW varchar(60); +dcl-s invuom varchar(5); +dcl-s convFactor packed(15:6); +dcl-s qtyInv packed(15:4); +dcl-s nextRLine int(10); +dcl-s newHdrStat varchar(20); + +in ldaDS; +compcd = ldaDS.compcd; + +if compcd = ''; + exsr clearMsgs; + writeMsg('No company selected - run Select Company (PERPSELR) first.'); + *in40 = *on; + write rmsgctl; + hcompdsp = ''; + exfmt rhead; + *inlr = *on; + return; +endif; + +hcompdsp = compcd; + +// ----------------------------------------------------------------------- +// Header entry -- pick PO, receipt date, receiver, notes. Validate the +// PO exists for this company and is still open to receive against. +// ----------------------------------------------------------------------- +hponbr = 0; +hrcpdt = %date(); +hrcvby = ''; +hnotes = ''; + +exsr clearMsgs; + +dow '1'; + *in40 = *off; + if msgrrn > 0; + *in40 = *on; + endif; + write rmsgctl; + exfmt rhead; + + if *in03 or *in12; + *inlr = *on; + return; + endif; + + exsr clearMsgs; + + if hponbr <= 0; + writeMsg('PO Number is required.'); + iter; + endif; + + exec sql + select h.status_code, v.vendor_name + into :hpostat, :hvndnmW + from perpdemo.po_header h + join perpdemo.vendor v + on v.company_code = h.company_code and v.vendor_code = h.vendor_code + where h.company_code = :compcd and h.po_number = :hponbr; + if sqlcode <> 0; + writeMsg('PO ' + %char(hponbr) + ' not found for this company.'); + iter; + endif; + hvndnm = hvndnmW; + + if hpostat <> 'OPEN' and hpostat <> 'PARTIAL'; + writeMsg('PO ' + %char(hponbr) + ' is ' + %trim(hpostat) + + ' - not open for receiving.'); + iter; + endif; + + if %trim(hrcvby) = ''; + writeMsg('Received By is required.'); + iter; + endif; + + exec sql + select display_name + into :hrcvnmW + from perpdemo.perp_user + where user_code = :hrcvby; + if sqlcode <> 0; + writeMsg('Receiver ' + %trim(hrcvby) + ' not found.'); + iter; + endif; + hrcvnm = hrcvnmW; + + leave; +enddo; + +rcpnbr = docseq_next(compcd : 'RCP' : docerrmsg); +if rcpnbr = 0; + writeMsg('Could not allocate receipt number: ' + docerrmsg); + *inlr = *on; + return; +endif; + +// status_code/status_type default to POSTED/RCPSTATUS via the DDL +// default -- left out of the column list so a future default change +// lands here too (same idiom poentr uses for po_header.currency_code). +exec sql + insert into perpdemo.po_receipt + (company_code, receipt_number, po_number, receipt_date, received_by, + notes) + values (:compcd, :rcpnbr, :hponbr, :hrcpdt, :hrcvby, :hnotes); +if sqlcode < 0; + writeMsg('Could not create receipt: SQLCODE=' + %char(sqlcode)); + *inlr = *on; + return; +endif; + +exec sql commit; + +// ----------------------------------------------------------------------- +// Line entry -- subfile of the PO's still-open lines. +// ----------------------------------------------------------------------- +exsr clearMsgs; +writeMsg('Receipt ' + %char(rcpnbr) + ' created for PO ' + %char(hponbr) + + '. Type 1=Receive next to a line.'); + +dow '1'; + exsr loadHeaderRecap; + exsr loadOpenLines; + + if numRows = 0; + *in30 = *off; + write rnolin; + else; + exsr fillSubfile; + *in30 = *on; + endif; + + write rlfoot; + *in40 = *off; + if msgrrn > 0; + *in40 = *on; + endif; + write rmsgctl; + exfmt rlctl; + + if *in03 or *in12; + leave; + endif; + + exsr clearMsgs; + + if numRows > 0; + selRrn = 0; + selOpt = ' '; + readc rlsfl; + dow not %eof(rcventd); + if slopt <> ''; + if selRrn = 0; + selRrn = rrn; + selOpt = slopt; + else; + writeMsg('Only one selection per Enter.'); + endif; + endif; + readc rlsfl; + enddo; + + if selRrn > 0 and msgrrn = 0; + select; + when selOpt = '1'; + exsr receiveLine; + other; + writeMsg('Option ' + selOpt + ' not valid.'); + endsl; + endif; + endif; +enddo; + +*inlr = *on; +return; + +// --------------------------------------------------------------------- +begsr loadHeaderRecap; + exec sql + select h.status_code, v.vendor_code, v.vendor_name + into :hpostat, :dvndr, :dvndnmW + from perpdemo.po_header h + join perpdemo.vendor v + on v.company_code = h.company_code and v.vendor_code = h.vendor_code + where h.company_code = :compcd and h.po_number = :hponbr; + dvndnm = dvndnmW; + dponbr = %char(hponbr); + drcvby = hrcvby; + drcvnm = hrcvnm; + drcpdt = hrcpdt; + dpostat = hpostat; +endsr; + +// --------------------------------------------------------------------- +// loadOpenLines -- po_line rows still open (status_code <> CLOSED), +// joined to po_line_open for open_qty and to item for the description. +begsr loadOpenLines; + numRows = 0; + exec sql declare rc1 cursor for + select l.line_number, l.item_number, i.item_description, + o.open_qty, l.uom_code + from perpdemo.po_line l + join perpdemo.po_line_open o + on o.company_code = l.company_code and o.po_number = l.po_number + and o.line_number = l.line_number + join perpdemo.item i + on i.company_code = l.company_code and i.item_number = l.item_number + where l.company_code = :compcd and l.po_number = :hponbr + and l.status_code <> 'CLOSED' and l.is_active = 'Y' + order by l.line_number; + exec sql open rc1; + if sqlcode < 0; + writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); + return; + endif; + + dow numRows < %elem(rows); + exec sql fetch rc1 into :lineRow.lnbr, :lineRow.item, :lineRow.desc, + :lineRow.openqty, :lineRow.uom; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + numRows += 1; + rows(numRows) = lineRow; + enddo; + exec sql close rc1; +endsr; + +// --------------------------------------------------------------------- +begsr fillSubfile; + rrn = 0; + *in31 = *on; + write rlctl; + *in31 = *off; + for i = 1 to numRows; + slopt = ''; + slline = rows(i).lnbr; + slitem = rows(i).item; + sldesc = rows(i).desc; + slopen = rows(i).openqty; + sluom = rows(i).uom; + rrn += 1; + write rlsfl; + endfor; +endsr; + +// --------------------------------------------------------------------- +// receiveLine -- prompt for qty received (vendor UOM) + lot number +// (if lot-controlled), then post everywhere a receipt touches: +// po_receipt_line insert, item_lot upsert, po_line roll-up, item +// qty_on_hand bump, po_header status recalc. +begsr receiveLine; + eline = rows(selRrn).lnbr; + eitem = rows(selRrn).item; + edesc = rows(selRrn).desc; + eopen = rows(selRrn).openqty; + euom = rows(selRrn).uom; + + exec sql + select lot_controlled, inventory_uom + into :elotctl, :invuom + from perpdemo.item + where company_code = :compcd and item_number = :eitem; + + eqty = 0; + elot = ''; + enotes = ''; + + dow '1'; + *in40 = *off; + if msgrrn > 0; + *in40 = *on; + endif; + write rmsgctl; + exfmt rledit; + if *in12; + return; + endif; + + exsr clearMsgs; + + if eqty <= 0; + writeMsg('Quantity must be greater than zero.'); + iter; + endif; + + if eqty > eopen; + writeMsg('Quantity exceeds open quantity of ' + %char(eopen) + '.'); + iter; + endif; + + if elotctl = 'Y' and %trim(elot) = ''; + writeMsg('Lot number is required for this lot-controlled item.'); + iter; + endif; + + leave; + enddo; + + if %trim(euom) = %trim(invuom); + convFactor = 1; + else; + exec sql + select conversion_factor + into :convFactor + from perpdemo.item_uom_conversion + where company_code = :compcd and item_number = :eitem + and from_uom = :euom and to_uom = :invuom; + if sqlcode <> 0; + writeMsg('No UOM conversion from ' + %trim(euom) + ' to ' + + %trim(invuom) + ' defined for this item.'); + return; + endif; + endif; + + qtyInv = eqty * convFactor; + + exec sql + select coalesce(max(line_number), 0) + 1 + into :nextRLine + from perpdemo.po_receipt_line + where company_code = :compcd and receipt_number = :rcpnbr; + + if %trim(elot) = ''; + exec sql + insert into perpdemo.po_receipt_line + (company_code, receipt_number, line_number, po_number, + po_line_number, item_number, qty_received_vendor_uom, + qty_received_inventory_uom, uom_conversion_factor, notes) + values (:compcd, :rcpnbr, :nextRLine, :hponbr, :eline, + :eitem, :eqty, :qtyInv, :convFactor, :enotes); + else; + exec sql + insert into perpdemo.po_receipt_line + (company_code, receipt_number, line_number, po_number, + po_line_number, item_number, qty_received_vendor_uom, + qty_received_inventory_uom, uom_conversion_factor, lot_number, + notes) + values (:compcd, :rcpnbr, :nextRLine, :hponbr, :eline, + :eitem, :eqty, :qtyInv, :convFactor, :elot, :enotes); + endif; + if sqlcode < 0; + writeMsg('Receipt line insert failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + return; + endif; + + if elotctl = 'Y'; + exec sql + update perpdemo.item_lot + set qty_on_hand = qty_on_hand + :qtyInv, + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd and item_number = :eitem + and lot_number = :elot; + if sqlcode = 100; + exec sql + insert into perpdemo.item_lot + (company_code, item_number, lot_number, qty_on_hand) + values (:compcd, :eitem, :elot, :qtyInv); + endif; + endif; + + exec sql + update perpdemo.po_line + set received_qty = received_qty + :qtyInv, + status_code = case + when received_qty + :qtyInv >= ordered_qty then 'CLOSED' + when received_qty + :qtyInv > 0 then 'PARTIAL' + else 'OPEN' + end, + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd and po_number = :hponbr + and line_number = :eline; + if sqlcode < 0; + writeMsg('po_line update failed: SQLCODE=' + %char(sqlcode)); + return; + endif; + + exec sql + update perpdemo.item + set qty_on_hand = qty_on_hand + :qtyInv, + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd and item_number = :eitem; + + exec sql + select case + when count(*) = sum(case when status_code = 'CLOSED' then 1 else 0 end) + then 'RECEIVED' + when sum(case when received_qty > 0 then 1 else 0 end) > 0 + then 'PARTIAL' + else 'OPEN' + end + into :newHdrStat + from perpdemo.po_line + where company_code = :compcd and po_number = :hponbr and is_active = 'Y'; + + exec sql + update perpdemo.po_header + set status_code = :newHdrStat, + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd and po_number = :hponbr; + + exec sql commit; + + writeMsg('Received ' + %char(eqty) + ' ' + %trim(euom) + ' (' + + %char(qtyInv) + ' ' + %trim(invuom) + ') on line ' + + %char(eline) + '.'); +endsr; + +// --------------------------------------------------------------------- +begsr clearMsgs; + msgrrn = 0; + *in41 = *on; + write rmsgctl; + *in41 = *off; +endsr; + +// --------------------------------------------------------------------- +dcl-proc writeMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + smsgkey : + x'0000000000000000'); + msgrrn += 1; + spgmq = statusDS.programName; + write rmsgsfl; +end-proc; diff --git a/perp/qsrvsrc/lotrecon.bnd b/perp/qsrvsrc/lotrecon.bnd new file mode 100644 index 00000000..9677990f --- /dev/null +++ b/perp/qsrvsrc/lotrecon.bnd @@ -0,0 +1,3 @@ +strpgmexp pgmlvl(*current) signature('LOTRECON ') + export symbol("LOTRECON_RUN") +endpgmexp From 2f6b06bdfbff6918947488bc6627934be987557d Mon Sep 17 00:00:00 2001 From: Gary Jones Date: Fri, 7 Aug 2026 19:53:11 +0000 Subject: [PATCH 10/13] # Summary MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit ## What I did Created a new Epic in the **PERP** Jira project (plogic.atlassian.net) to track Phase Two work: - **Epic:** [PERP-51 — Phase Two: Prompt Programs and Aesthetic Improvements](https://plogic.atlassian.net/browse/PERP-51) - **Description:** Tracks Phase Two work covering prompt program enhancements and aesthetic/UI improvements identified through hands-on system testing. This was a pure ticketing exercise — no code was changed and no repository was touched. ## Why The user is going to manually walk through the PERP system, testing functionality and identifying areas for improvement. Each issue they find will be filed as a Story under this epic in a series of follow-up requests/tasks, rather than being implemented immediately. ## Next steps - Waiting for the user to report specific issues found during testing. - For each issue reported, I will create a Story in Jira under project PERP with the Epic link set to **PERP-51**. No code changes will be made as part of this ticketing workflow unless the user explicitly asks for implementation work separately. - I saved a memory note (`project-perp-phase-two-epic.md`) recording that PERP-51 is the active Phase Two epic, so future tasks/sessions know where to file new stories. ## Issues encountered None. The epic was created successfully on the first attempt. ## IBM i task library `IBMI_BUILD_LIBRARY` = `AITSK00071` (not used in this task, since no build or code work was performed). ## Exploratory Verification Not applicable — this task did not involve any interactive IBM i display file screens or code changes; it was limited to creating a Jira epic. Co-Authored-By: CoderFlow Learn more: https://coderflow.ai --- perp/DDL_STYLE_GUIDE.md | 125 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 125 insertions(+) diff --git a/perp/DDL_STYLE_GUIDE.md b/perp/DDL_STYLE_GUIDE.md index 23ec1c34..d89233dc 100644 --- a/perp/DDL_STYLE_GUIDE.md +++ b/perp/DDL_STYLE_GUIDE.md @@ -432,6 +432,22 @@ maintenance programs. These apply to every RPG or SQLRPGLE source under inside the statement text, or move the Date column comparison out of the WHERE clause entirely. `%date()` with no args (returns today) is always safe. +- **A correctly-ranged sentinel default does not protect against a + user blanking the field.** Found in `pobrwr` again, 2026-08-07 + (PERP-89): even with the `1940-2039` sentinel fix above already in + place, clearing the From/To date filter field on screen and + pressing Enter crashes with the identical `RNQ0114`. Blanking a + native DDS `L`-type field does not behave like clearing a character + field — it still produces *some* date value that has to pass the + *MDY range check, and no PERP program currently guards for it. + There is also no equivalent, for a blanked date field, of the + character-filter idiom (`:fstat = '' or ...`) that already lets + `fvnd`/`fbuy`/etc. mean "no filter" — `loadPOs`-style code applies + the date bounds unconditionally. Any optional/filter date field + needs to explicitly detect blank input before it reaches an SQL host + variable and decide what blank should mean (most likely: reapply + the sentinel), rather than assume 5250 will always hand back an + in-range value. - **Program/module/file object names cap at 10 characters — same as journal receivers (§7).** Learned again in PERP-32: naming a smoke-test caller `itmvprcqsmk.sqlrpgle` (11 chars) failed `CRTSQLRPGI` with @@ -454,6 +470,35 @@ maintenance programs. These apply to every RPG or SQLRPGLE source under `CA03/CA05/CA06/CA12` once at file level. - **Standard F-key legend on every DSPF**: F3=Exit, F5=Refresh, F6=Add, F12=Cancel — declared at file level and echoed in the footer line. +- **F12 means "back one screen in this program's own flow," never "end + the program."** Only F3 ends the program and returns to the menu. An + edit/add panel's `EXFMT` should `return` from its subroutine on + `*in12` (unwinding to redisplay the list/caller) — most PERP + programs already get this right for their edit panels (`WRKITMR`, + `WRKIVNR`, `WRKCNVR`, etc.). The mistake is at the *list* level: + `if *in03 or *in12; leave; endif;` on a top-level list/subfile + screen is correct ONLY when that screen is the true entry point of + the flow with nothing earlier to go back to (e.g. `PERPSELR`'s + company picker, or a program's own header-entry screen). Found live + on three programs where a *second* screen in the same flow made + this mistake instead — `reqentr`'s Requisition Lines list (PERP-85), + `poentr`'s Purchase Order Lines list (PERP-94), and `poschr`'s + Schedule list (PERP-95) — each exits straight to the menu on F12 + from a screen that has an obvious "back" target (the header screen), + discarding the user's place even though the parent record is + already saved. Audit every `if *in03 or *in12` in a new or changed + program and ask: is this genuinely screen #1 of the flow? +- **After a terminal action (Submit, Approve, Reject), navigate the + user somewhere useful — don't leave them staring at the now-locked + record.** Two programs `iter`ed back to redisplay the very screen + that had just been locked, with no way to start the next document + without exiting the whole program (`reqentr`'s F8=Submit, PERP-86; + `poentr`'s F8=Submit, PERP-93). Decide, for every finalize action, + what screen the user lands on next (a list of similar documents, or + a fresh entry screen for the same document type), and carry the + confirmation `writeMsg()` forward to whatever screen they land on — + see the `clearMsgs()` ordering note above; don't let it get wiped in + the transition. - **Message subfile** (`R xMSGSFL` / `R xMSGCTL`) attached at row 24 on every screen; RPG uses `QMHSNDPM` to post messages. - **`QMHSNDPM`'s message-key output parameter must be the DDS field bound @@ -470,6 +515,23 @@ maintenance programs. These apply to every RPG or SQLRPGLE source under here breaks every message the program ever shows. Always pass the record's own `SFLMSGKEY` field, and double-check this any time you copy the `writeMsg`/`clearMsgs` boilerplate into a new program. +- **`clearMsgs()` must run *before* an action handler's `writeMsg()` + in the same pass, never after.** The standard boilerplate calls + `clearMsgs()` once per loop iteration, ahead of that iteration's own + `EXFMT`, so a message queued during the *previous* pass survives to + be shown on the *next* one. If an F6/F8/etc. handler instead calls + `writeMsg()` and then `iter`s straight back to the top of the loop, + and `clearMsgs()` sits unconditionally at that same top, it wipes + `msgrrn` and clears the message subfile before the next `EXFMT` ever + displays the message the handler just queued — confirmation or error + text is queued and destroyed in the same pass, and the action looks + like it silently did nothing. Found in `wrkivpr` (PERP-74: the + F6=Add-with-blank-item warning never reaches the screen) and + suspected as a contributing factor in `reqaprr` (PERP-87: + Approve/Reject confirmations). `reqentr`'s line-list loop gets this + right — `clearMsgs()` sits *between* the F3/F12 check and the F6/F8 + dispatch, not folded into the very top of the loop after them — use + that ordering as the reference shape when copying the boilerplate. - **The record format shown alongside (or right before) the message subfile must have `OVERLAY`**, or displaying/writing it clears the screen and erases the just-written message subfile before the user @@ -535,6 +597,23 @@ maintenance programs. These apply to every RPG or SQLRPGLE source under business subfile in `reqaprr` without an actual interactive retest on this environment proving it renders** — a clean compile and a textbook-correct design have both already failed to predict this. + + **Addendum, PERP-87 (2026-08-07):** live testing reports F6=Approve, + F7=Reject, *and* F12 all appearing to return to the menu instead of + back to the `ASFL`/`ASCTL` list, from the current (workaround) + `RDETAIL` design described above. Read in isolation, the RPG source + for all three (`reqaprr.sqlrpgle`'s `reviewReq` subroutine) looks + correct — each just `return`s to the outer loop, which should + redisplay the list, not end the program — so if this reproduces, it + is likely the *same* unconfirmed device-error class documented + above, now apparently reachable on the *return* path out of the + plain `RDETAIL` format rather than only on entry into a second + subfile. That would mean the current workaround has not fully + closed the underlying issue. Needs a live joblog check for an + escape message (`RNX1255`/`CPF5006`-class) at the point of return + before assuming this needs an RPG logic fix — don't spend a + redesign cycle on `reviewReq`'s branching logic until that's ruled + out. - **A `SFLCTL` record's `SFLDSPCTL` keyword combined with an input-capable (`B`) field positioned *below* the subfile's anchor row raises `CPD7812`: "Subfile control record overlaps subfile record"** @@ -575,6 +654,29 @@ maintenance programs. These apply to every RPG or SQLRPGLE source under exactly one column (the decimal point) — leave at least that much headroom between adjacent fields packed onto the same row, or the compile will overlap/truncate. + - **That one-column allowance is not the whole story — compute the + field's *maximum* rendered width, including comma insertion, + before spacing columns.** `EDTCDE(3)` inserts a comma every 3 + integer digits. A `15Y 4` field (13 integer digits) can render up + to 20 characters wide (13 digits + 4 commas + 1 decimal point + 4 + decimals) — not just "16 digits + 1". Found overlapping in three + places once realistic (larger) values were entered: `pobrwd.dspf`'s + PO Detail line columns (Ord/Rcv/Open/Price only 9-10 columns + apart, PERP-90), `poentd.dspf`'s PO Lines Qty column running into + the UOM column (PERP-92), and `poreqd.dspf`'s Est Cost column + starting at column 73 with a 20-character max width — 12 columns + past the right edge of an 80-column screen, so it silently wraps + onto the next physical row (PERP-97, and suspected of breaking F6 + option detection there since the wrap likely misaligns how the + web renderer maps keystrokes back to the right subfile record). + Work out the worst-case width for every `Y`-type field's digit + count before choosing its column, not just "+1 for the decimal." + - **Right-align the column heading over the field, not over its + start column.** A numeric field's value is right-justified within + its width; a heading positioned at the field's left edge reads as + "too far left" once real data appears (PERP-90, PERP-92, and + `wrkcnvd.dspf`'s Factor heading). Position heading text so it ends + at (or near) the field's rightmost column instead. - **Never issue `READC` against a subfile that was not written to this cycle.** If the load routine finds 0 rows this pass (e.g. an empty filter result, or the "enter a key value to begin" state before any @@ -707,3 +809,26 @@ general rule, not specific to lots/receipts: any "if column A on table X then column B on table Y must be Z" business rule in a future PERP story needs the same treatment — don't spend time trying to express it as a table-level `CONSTRAINT` first. + +## 18. Screen-to-source coverage + +Every interactive screen a user can reach should have matching +`.dspf`/`.sqlrpgle` source in this repo — the repo is the source of +truth, and live testing/fixes are only possible for what's actually +checked in here. + +**Found a gap, PERP-98 (2026-08-07):** the live "Receipt Entry" screen +(PO Number, Vendor, PO Status, Receipt Date, Received By, Notes +fields) has no corresponding source anywhere under `qddssrc/` or +`qrpglesrc/` in this module — every other screen exercised during +Phase 2 testing had matching source; this one didn't. Whatever object +is actually running for it was not built from (or was never checked +into) this repo. + +Before treating any live-reported bug as a source-level fix, confirm +the screen's source actually exists here first. If it doesn't, that's +its own finding — flag it rather than guessing at a fix, and don't +pull the live object's source off the IBM i host to fill the gap (see +the top-level environment rules); the gap itself needs a decision +(locate the real source, or write a new one into this repo) before +code work can start. From d199f3b3f5126139d66ed032c49db12e6c430acd Mon Sep 17 00:00:00 2001 From: Gary Jones Date: Thu, 20 Aug 2026 20:37:57 +0000 Subject: [PATCH 11/13] PERP-52: allow mixed-case name/address input, add Change (Edit) function for companies perpseld.dspf/perpselr.sqlrpgle: added CHECK(LC) to Company name/Address/City so they accept lowercase (DDS input fields default to uppercase-only without it); coded fields (company code, state, country, currency) stay uppercase. Added 2=Change company info alongside 1=Select, reusing the existing Add panel (now "Edit Company" with a Mode: A/C indicator); company code is protected (DSPATR(PR)) during Change since it's an FK'd primary key. Also fixed a missing-holdMsg bug found live: the "Company X selected"/Add confirmation messages were being silently wiped before ever displaying. Also, per a follow-up request, 1=Select now exits straight back to the calling menu after committing the LDA update (F3-style) instead of redisplaying the list -- the confirmation message on that path was removed since it's no longer shown to anyone. PERP-51: implement remaining Phase Two tickets (PERP-72..98) and fix 3 systemic RPG bugs found via live testing Second batch of the PERP-51 epic (PERP-72 through PERP-98): MM/DD/YY date display across Requisition Entry/Approval, PO Entry/Browse/Schedule, Item Lots, and Receipt Entry; new reusable numeric PO-number prompt program (poprmt, F4=Prompt convention); item/vendor prompts on remaining screens; column realignment and F12-navigation fixes on PO Entry and PO Browse; outer-loop restart pattern on Requisition/PO Entry after submit. Live exploratory testing (not just code review) surfaced and fixed three bug classes affecting most programs in the module, well beyond their originating tickets: - `return;` inside a `begsr` subroutine ends the whole RPG program, not just that subroutine -- fixed by switching to `leavesr;` in 19 programs (itmprmt, vndprmt, poprmt, perpselr, wrkcnvr, wrklotr, wrkitmr, wrkivnr, wrkivpr, wrkiclr, reqentr, poentr, pobrwr, rcventr, poschr, wlmr, wrkusrr, reqaprr, poreqr). - Message-subfile control record not re-written before the next EXFMT (poentr, poschr header loops), and missing/incomplete holdMsg one-shot-skip coverage (wrkcnvr, wrkitmr, wrkivnr, wrkiclr, wrkusrr, wlmr, reqaprr) -- both silently dropped validation/confirmation messages that were otherwise queued correctly. - Sentinel date value (0001-01-01) crashed with RNQ0114 on a DATFMT(*MDY)-bound screen field despite the program's own datfmt(*iso) ctl-opt -- fixed by using an in-range sentinel (1940-01-01) in poentr; corrected a stale comment in pobrwr describing the same trap it had already fixed correctly. All 47 PERP-51 child tickets and the epic itself remain "In Progress" (not "Done") per explicit instruction -- final sign-off is the user's own testing pass. Also: adopted local codermake build/ stamps for pre-existing PERPDEMO data tables after a container-restart wiped the stamp cache, avoiding an accidental CRTPF/ RUNSQLSTM re-create attempt against populated tables (none were harmed). Co-Authored-By: CoderFlow Learn more: https://coderflow.ai --- perp/Rules.mk | 32 +- perp/build/PERPDEMO.lib | 0 perp/build/code_master.file | 0 perp/build/company.file | 0 perp/build/company_config.file | 0 perp/build/document_sequence.file | 0 perp/build/example_reference.file | 0 perp/build/item.file | 0 perp/build/item_class.file | 0 perp/build/item_lot.file | 0 perp/build/item_uom_conversion.file | 0 perp/build/item_vendor.file | 0 perp/build/item_vendor_preferred_ak.file | 0 perp/build/item_vendor_price.file | 0 perp/build/item_vendor_price_history.file | 0 perp/build/itmprm2d.file | 0 perp/build/itmprmt.pgm | 0 perp/build/perp.bnddir | 0 perp/build/perp_user.file | 0 perp/build/perpseld.file | 0 perp/build/perpselr.pgm | 0 perp/build/perpsjpf.pgm | 0 perp/build/po_header.file | 0 perp/build/po_line.file | 0 perp/build/po_line_open.file | 0 perp/build/po_line_schedule.file | 0 perp/build/po_receipt.file | 0 perp/build/po_receipt_line.file | 0 perp/build/pobrwd.file | 0 perp/build/pobrwr.pgm | 0 perp/build/poentd.file | 0 perp/build/poentr.pgm | 0 perp/build/poprmt.pgm | 0 perp/build/poprmtd.file | 0 perp/build/poreqd.file | 0 perp/build/poreqr.pgm | 0 perp/build/poschd.file | 0 perp/build/poschr.pgm | 0 perp/build/rcventd.file | 0 perp/build/rcventr.pgm | 0 perp/build/reconciliation_log.file | 0 perp/build/reqaprd.file | 0 perp/build/reqaprr.pgm | 0 perp/build/reqentd.file | 0 perp/build/reqentr.pgm | 0 perp/build/requisition_header.file | 0 perp/build/requisition_line.file | 0 perp/build/uom.file | 0 perp/build/vendor.file | 0 perp/build/vndprmt.pgm | 0 perp/build/vndprmtd.file | 0 perp/build/warehouse_layout.file | 0 perp/build/wlmd.file | 0 perp/build/wlmr.pgm | 0 perp/build/wrkcnvd.file | 0 perp/build/wrkcnvr.pgm | 0 perp/build/wrkicld.file | 0 perp/build/wrkiclr.pgm | 0 perp/build/wrkitmd.file | 0 perp/build/wrkitmr.pgm | 0 perp/build/wrkivnd.file | 0 perp/build/wrkivnr.pgm | 0 perp/build/wrkivpd.file | 0 perp/build/wrkivpr.pgm | 0 perp/build/wrklotd.file | 0 perp/build/wrklotr.pgm | 0 perp/build/wrkusrd.file | 0 perp/build/wrkusrr.pgm | 0 perp/qddssrc/itmprm2d.dspf | 50 + perp/qddssrc/perpseld.dspf | 33 +- perp/qddssrc/pobrwd.dspf | 82 +- perp/qddssrc/poentd.dspf | 28 +- perp/qddssrc/poprmtd.dspf | 56 + perp/qddssrc/poreqd.dspf | 10 +- perp/qddssrc/poschd.dspf | 12 +- perp/qddssrc/rcventd.dspf | 3 +- perp/qddssrc/reqaprd.dspf | 8 +- perp/qddssrc/reqentd.dspf | 11 +- perp/qddssrc/vndprmtd.dspf | 52 + perp/qddssrc/wlmd.dspf | 19 +- perp/qddssrc/wrkcnvd.dspf | 5 +- perp/qddssrc/wrkicld.dspf | 2 +- perp/qddssrc/wrkitmd.dspf | 9 +- perp/qddssrc/wrkivnd.dspf | 5 +- perp/qddssrc/wrkivpd.dspf | 2 + perp/qddssrc/wrklotd.dspf | 7 +- perp/qddssrc/wrkusrd.dspf | 14 +- perp/qrpglesrc/itmprmt.sqlrpgle | 213 +++ perp/qrpglesrc/perpselr.sqlrpgle | 148 +- perp/qrpglesrc/pobrwr.sqlrpgle | 54 +- perp/qrpglesrc/poentr.sqlrpgle | 192 ++- perp/qrpglesrc/poprmt.sqlrpgle | 211 +++ perp/qrpglesrc/poreqr.sqlrpgle | 20 +- perp/qrpglesrc/poschr.sqlrpgle | 41 +- perp/qrpglesrc/rcventr.sqlrpgle | 30 +- perp/qrpglesrc/reqaprr.sqlrpgle | 57 +- perp/qrpglesrc/reqentr.sqlrpgle | 109 +- perp/qrpglesrc/vndprmt.sqlrpgle | 204 +++ perp/qrpglesrc/wlmr.sqlrpgle | 16 +- perp/qrpglesrc/wrkcnvr.sqlrpgle | 36 +- perp/qrpglesrc/wrkiclr.sqlrpgle | 18 +- perp/qrpglesrc/wrkitmr.sqlrpgle | 51 +- perp/qrpglesrc/wrkivnr.sqlrpgle | 74 +- perp/qrpglesrc/wrkivpr.sqlrpgle | 72 +- perp/qrpglesrc/wrklotr.sqlrpgle | 116 +- perp/qrpglesrc/wrkusrr.sqlrpgle | 18 +- perp/tmp/logs/itmprmt.pgm.log | 1501 +++++++++++++++++++++ 107 files changed, 3357 insertions(+), 264 deletions(-) create mode 100644 perp/build/PERPDEMO.lib create mode 100644 perp/build/code_master.file create mode 100644 perp/build/company.file create mode 100644 perp/build/company_config.file create mode 100644 perp/build/document_sequence.file create mode 100644 perp/build/example_reference.file create mode 100644 perp/build/item.file create mode 100644 perp/build/item_class.file create mode 100644 perp/build/item_lot.file create mode 100644 perp/build/item_uom_conversion.file create mode 100644 perp/build/item_vendor.file create mode 100644 perp/build/item_vendor_preferred_ak.file create mode 100644 perp/build/item_vendor_price.file create mode 100644 perp/build/item_vendor_price_history.file create mode 100644 perp/build/itmprm2d.file create mode 100644 perp/build/itmprmt.pgm create mode 100644 perp/build/perp.bnddir create mode 100644 perp/build/perp_user.file create mode 100644 perp/build/perpseld.file create mode 100644 perp/build/perpselr.pgm create mode 100644 perp/build/perpsjpf.pgm create mode 100644 perp/build/po_header.file create mode 100644 perp/build/po_line.file create mode 100644 perp/build/po_line_open.file create mode 100644 perp/build/po_line_schedule.file create mode 100644 perp/build/po_receipt.file create mode 100644 perp/build/po_receipt_line.file create mode 100644 perp/build/pobrwd.file create mode 100644 perp/build/pobrwr.pgm create mode 100644 perp/build/poentd.file create mode 100644 perp/build/poentr.pgm create mode 100644 perp/build/poprmt.pgm create mode 100644 perp/build/poprmtd.file create mode 100644 perp/build/poreqd.file create mode 100644 perp/build/poreqr.pgm create mode 100644 perp/build/poschd.file create mode 100644 perp/build/poschr.pgm create mode 100644 perp/build/rcventd.file create mode 100644 perp/build/rcventr.pgm create mode 100644 perp/build/reconciliation_log.file create mode 100644 perp/build/reqaprd.file create mode 100644 perp/build/reqaprr.pgm create mode 100644 perp/build/reqentd.file create mode 100644 perp/build/reqentr.pgm create mode 100644 perp/build/requisition_header.file create mode 100644 perp/build/requisition_line.file create mode 100644 perp/build/uom.file create mode 100644 perp/build/vendor.file create mode 100644 perp/build/vndprmt.pgm create mode 100644 perp/build/vndprmtd.file create mode 100644 perp/build/warehouse_layout.file create mode 100644 perp/build/wlmd.file create mode 100644 perp/build/wlmr.pgm create mode 100644 perp/build/wrkcnvd.file create mode 100644 perp/build/wrkcnvr.pgm create mode 100644 perp/build/wrkicld.file create mode 100644 perp/build/wrkiclr.pgm create mode 100644 perp/build/wrkitmd.file create mode 100644 perp/build/wrkitmr.pgm create mode 100644 perp/build/wrkivnd.file create mode 100644 perp/build/wrkivnr.pgm create mode 100644 perp/build/wrkivpd.file create mode 100644 perp/build/wrkivpr.pgm create mode 100644 perp/build/wrklotd.file create mode 100644 perp/build/wrklotr.pgm create mode 100644 perp/build/wrkusrd.file create mode 100644 perp/build/wrkusrr.pgm create mode 100644 perp/qddssrc/itmprm2d.dspf create mode 100644 perp/qddssrc/poprmtd.dspf create mode 100644 perp/qddssrc/vndprmtd.dspf create mode 100644 perp/qrpglesrc/itmprmt.sqlrpgle create mode 100644 perp/qrpglesrc/poprmt.sqlrpgle create mode 100644 perp/qrpglesrc/vndprmt.sqlrpgle create mode 100644 perp/tmp/logs/itmprmt.pgm.log diff --git a/perp/Rules.mk b/perp/Rules.mk index 4862d7f0..242b9030 100644 --- a/perp/Rules.mk +++ b/perp/Rules.mk @@ -84,7 +84,7 @@ wrkuomr.pgm: qrpglesrc/wrkuomr.sqlrpgle qddssrc/wrkuomd.dspf | wrkuomd.file uom # Scoped by *LDA company (perpselr) + item number entered on screen. wrkcnvd.file: qddssrc/wrkcnvd.dspf -wrkcnvr.pgm: qrpglesrc/wrkcnvr.sqlrpgle qddssrc/wrkcnvd.dspf | wrkcnvd.file item_uom_conversion.file +wrkcnvr.pgm: qrpglesrc/wrkcnvr.sqlrpgle qddssrc/wrkcnvd.dspf | wrkcnvd.file item_uom_conversion.file itmprmt.pgm # --- PERP-22: Item class maintenance -------------------------------------- @@ -98,7 +98,7 @@ wrkiclr.pgm: qrpglesrc/wrkiclr.sqlrpgle qddssrc/wrkicld.dspf | wrkicld.file ite # pre-scoped to the selected item (dynamic CALL via EXTPGM, not compile-time # bound -- wrkcnvr.pgm listed as order-only so build order still makes sense). wrkitmd.file: qddssrc/wrkitmd.dspf -wrkitmr.pgm: qrpglesrc/wrkitmr.sqlrpgle qddssrc/wrkitmd.dspf | wrkitmd.file item.file wrkcnvr.pgm wrklotr.pgm +wrkitmr.pgm: qrpglesrc/wrkitmr.sqlrpgle qddssrc/wrkitmd.dspf | wrkitmd.file item.file wrkcnvr.pgm wrklotr.pgm itmprmt.pgm # --- PERP-24: Item lot maintenance & inquiry -------------------------------- @@ -106,7 +106,7 @@ wrkitmr.pgm: qrpglesrc/wrkitmr.sqlrpgle qddssrc/wrkitmd.dspf | wrkitmd.file ite # idiom as wrkcnvr. Discrepancy indicator: item.qty_on_hand vs # SUM(item_lot.qty_on_hand) for the scoped item. wrklotd.file: qddssrc/wrklotd.dspf -wrklotr.pgm: qrpglesrc/wrklotr.sqlrpgle qddssrc/wrklotd.dspf | wrklotd.file item_lot.file +wrklotr.pgm: qrpglesrc/wrklotr.sqlrpgle qddssrc/wrklotd.dspf | wrklotd.file item_lot.file itmprmt.pgm # --- PERP-27: Warehouse coordinate query service -------------------------- @@ -138,6 +138,18 @@ item_vendor_preferred_ak.file: qddlsrc/item_vendor_preferred_ak.index.sql item_v item_vendor_price.file: qddlsrc/item_vendor_price.table.sql item_vendor.file code_master.file | perpsjpf.pgm +# --- PERP-51: Standard, reusable Item/Vendor Number prompt programs ------ +# Field-level "?" + Enter lookup, callable from any screen with a keyable +# Item Number or Vendor field via a plain dynamic CALL (EXTPGM prototype +# declared in each caller) -- same idiom wrkitmr already uses to call +# wrkcnvr/wrklotr. Not bound service programs, so no bnddir/exports. +itmprm2d.file: qddssrc/itmprm2d.dspf +itmprmt.pgm: qrpglesrc/itmprmt.sqlrpgle qddssrc/itmprm2d.dspf | itmprm2d.file item.file + +vndprmtd.file: qddssrc/vndprmtd.dspf +vndprmt.pgm: qrpglesrc/vndprmt.sqlrpgle qddssrc/vndprmtd.dspf | vndprmtd.file vendor.file + + # --- PERP-29: Vendor master maintenance ----------------------------------- # Scoped by *LDA company (perpselr). Subfile filters by active-only and # buyer_code. @@ -149,7 +161,7 @@ wrkvndr.pgm: qrpglesrc/wrkvndr.sqlrpgle qddssrc/wrkvndd.dspf | wrkvndd.file ven # Scoped by *LDA company (perpselr) plus an item OR vendor entered on # screen (item wins if both are entered). wrkivnd.file: qddssrc/wrkivnd.dspf -wrkivnr.pgm: qrpglesrc/wrkivnr.sqlrpgle qddssrc/wrkivnd.dspf | wrkivnd.file item_vendor.file +wrkivnr.pgm: qrpglesrc/wrkivnr.sqlrpgle qddssrc/wrkivnd.dspf | wrkivnd.file item_vendor.file itmprmt.pgm vndprmt.pgm # --- PERP-31: Item-vendor price maintenance (effective-dated) -------------- @@ -157,7 +169,7 @@ wrkivnr.pgm: qrpglesrc/wrkivnr.sqlrpgle qddssrc/wrkivnd.dspf | wrkivnd.file ite # screen. Read-only history list; F6=Add closes the current row and # inserts a new one dated today. wrkivpd.file: qddssrc/wrkivpd.dspf -wrkivpr.pgm: qrpglesrc/wrkivpr.sqlrpgle qddssrc/wrkivpd.dspf | wrkivpd.file item_vendor_price.file +wrkivpr.pgm: qrpglesrc/wrkivpr.sqlrpgle qddssrc/wrkivpd.dspf | wrkivpd.file item_vendor_price.file itmprmt.pgm vndprmt.pgm # --- PERP-32: Pricing history query service -------------------------------- @@ -185,7 +197,7 @@ requisition_line.file: qddlsrc/requisition_line.table.sql requisition_header # for numbering; defaults line UOM from item, est_unit_cost from the # preferred vendor's current item_vendor_price row. reqentd.file: qddssrc/reqentd.dspf -reqentr.pgm: qrpglesrc/reqentr.sqlrpgle qrpglesrc/docseq_pr.rpgle qddssrc/reqentd.dspf | reqentd.file perp.bnddir requisition_header.file requisition_line.file item.file item_vendor.file item_vendor_price.file uom.file perp_user.file +reqentr.pgm: qrpglesrc/reqentr.sqlrpgle qrpglesrc/docseq_pr.rpgle qddssrc/reqentd.dspf | reqentd.file perp.bnddir requisition_header.file requisition_line.file item.file item_vendor.file item_vendor_price.file uom.file perp_user.file itmprmt.pgm # Requisition approval program (list of SUBMITTED reqs -> detail w/ up to # 6 lines as plain fields + confidence badge -> Approve/Reject stamping @@ -233,7 +245,7 @@ po_line_open.file: qddlsrc/po_line_open.view.sql po_line.file # defaults line UOM from item, unit_price from the entered vendor's # current item_vendor_price row. Same shape as reqentr (PERP-34). poentd.file: qddssrc/poentd.dspf -poentr.pgm: qrpglesrc/poentr.sqlrpgle qrpglesrc/docseq_pr.rpgle qddssrc/poentd.dspf | poentd.file perp.bnddir po_header.file po_line.file item.file item_vendor.file item_vendor_price.file uom.file vendor.file perp_user.file +poentr.pgm: qrpglesrc/poentr.sqlrpgle qrpglesrc/docseq_pr.rpgle qddssrc/poentd.dspf | poentd.file perp.bnddir po_header.file po_line.file item.file item_vendor.file item_vendor_price.file uom.file vendor.file perp_user.file itmprmt.pgm vndprmt.pgm # PO from requisition (consolidate/split). Selects APPROVED requisitions, # groups their lines by preferred vendor (one PO per vendor -> splitting), @@ -280,7 +292,11 @@ reconciliation_log.file: qddlsrc/reconciliation_log.table.sql item.file # the PO-status-transition-from-receipts follow-up PERP-7's recap deferred # to this epic. rcventd.file: qddssrc/rcventd.dspf -rcventr.pgm: qrpglesrc/rcventr.sqlrpgle qrpglesrc/docseq_pr.rpgle qddssrc/rcventd.dspf | rcventd.file perp.bnddir po_receipt.file po_receipt_line.file po_header.file po_line.file item.file item_uom_conversion.file item_lot.file perp_user.file uom.file +rcventr.pgm: qrpglesrc/rcventr.sqlrpgle qrpglesrc/docseq_pr.rpgle qddssrc/rcventd.dspf | rcventd.file perp.bnddir po_receipt.file po_receipt_line.file po_header.file po_line.file item.file item_uom_conversion.file item_lot.file perp_user.file uom.file poprmt.pgm + +# --- PERP-51/PERP-98: standard, reusable PO Number prompt (rcventr) ----- +poprmtd.file: qddssrc/poprmtd.dspf +poprmt.pgm: qrpglesrc/poprmt.sqlrpgle qddssrc/poprmtd.dspf | poprmtd.file po_header.file vendor.file # Lot reconciliation service. Module + srvpgm + bnddir, same pattern as # docseq/itmvprcq/whcoord/reqauto. Scans lot-controlled items for one diff --git a/perp/build/PERPDEMO.lib b/perp/build/PERPDEMO.lib new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/code_master.file b/perp/build/code_master.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/company.file b/perp/build/company.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/company_config.file b/perp/build/company_config.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/document_sequence.file b/perp/build/document_sequence.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/example_reference.file b/perp/build/example_reference.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/item.file b/perp/build/item.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/item_class.file b/perp/build/item_class.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/item_lot.file b/perp/build/item_lot.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/item_uom_conversion.file b/perp/build/item_uom_conversion.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/item_vendor.file b/perp/build/item_vendor.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/item_vendor_preferred_ak.file b/perp/build/item_vendor_preferred_ak.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/item_vendor_price.file b/perp/build/item_vendor_price.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/item_vendor_price_history.file b/perp/build/item_vendor_price_history.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/itmprm2d.file b/perp/build/itmprm2d.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/itmprmt.pgm b/perp/build/itmprmt.pgm new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/perp.bnddir b/perp/build/perp.bnddir new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/perp_user.file b/perp/build/perp_user.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/perpseld.file b/perp/build/perpseld.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/perpselr.pgm b/perp/build/perpselr.pgm new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/perpsjpf.pgm b/perp/build/perpsjpf.pgm new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/po_header.file b/perp/build/po_header.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/po_line.file b/perp/build/po_line.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/po_line_open.file b/perp/build/po_line_open.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/po_line_schedule.file b/perp/build/po_line_schedule.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/po_receipt.file b/perp/build/po_receipt.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/po_receipt_line.file b/perp/build/po_receipt_line.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/pobrwd.file b/perp/build/pobrwd.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/pobrwr.pgm b/perp/build/pobrwr.pgm new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/poentd.file b/perp/build/poentd.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/poentr.pgm b/perp/build/poentr.pgm new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/poprmt.pgm b/perp/build/poprmt.pgm new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/poprmtd.file b/perp/build/poprmtd.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/poreqd.file b/perp/build/poreqd.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/poreqr.pgm b/perp/build/poreqr.pgm new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/poschd.file b/perp/build/poschd.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/poschr.pgm b/perp/build/poschr.pgm new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/rcventd.file b/perp/build/rcventd.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/rcventr.pgm b/perp/build/rcventr.pgm new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/reconciliation_log.file b/perp/build/reconciliation_log.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/reqaprd.file b/perp/build/reqaprd.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/reqaprr.pgm b/perp/build/reqaprr.pgm new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/reqentd.file b/perp/build/reqentd.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/reqentr.pgm b/perp/build/reqentr.pgm new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/requisition_header.file b/perp/build/requisition_header.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/requisition_line.file b/perp/build/requisition_line.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/uom.file b/perp/build/uom.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/vendor.file b/perp/build/vendor.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/vndprmt.pgm b/perp/build/vndprmt.pgm new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/vndprmtd.file b/perp/build/vndprmtd.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/warehouse_layout.file b/perp/build/warehouse_layout.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/wlmd.file b/perp/build/wlmd.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/wlmr.pgm b/perp/build/wlmr.pgm new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/wrkcnvd.file b/perp/build/wrkcnvd.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/wrkcnvr.pgm b/perp/build/wrkcnvr.pgm new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/wrkicld.file b/perp/build/wrkicld.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/wrkiclr.pgm b/perp/build/wrkiclr.pgm new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/wrkitmd.file b/perp/build/wrkitmd.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/wrkitmr.pgm b/perp/build/wrkitmr.pgm new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/wrkivnd.file b/perp/build/wrkivnd.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/wrkivnr.pgm b/perp/build/wrkivnr.pgm new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/wrkivpd.file b/perp/build/wrkivpd.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/wrkivpr.pgm b/perp/build/wrkivpr.pgm new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/wrklotd.file b/perp/build/wrklotd.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/wrklotr.pgm b/perp/build/wrklotr.pgm new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/wrkusrd.file b/perp/build/wrkusrd.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/wrkusrr.pgm b/perp/build/wrkusrr.pgm new file mode 100644 index 00000000..e69de29b diff --git a/perp/qddssrc/itmprm2d.dspf b/perp/qddssrc/itmprm2d.dspf new file mode 100644 index 00000000..048cc3d5 --- /dev/null +++ b/perp/qddssrc/itmprm2d.dspf @@ -0,0 +1,50 @@ + A DSPSIZ(24 80 *DS3) + A PRINT + A CA03(03 'Exit') + A CA05(05 'Refresh') + A CA12(12 'Cancel') + A R ITPSFL SFL + A 51 SFLNXTCHG + A SOPT 1A B 8 2 + A 50 DSPATR(RI) + A 50 DSPATR(PC) + A SIITEM 25A O 8 5 + A SIDESC 48A O 8 31 + A R ITPCTL SFLCTL(ITPSFL) + A SFLSIZ(0099) + A SFLPAG(0007) + A OVERLAY + A SFLDSPCTL + A N31 30 SFLDSP + A 31 SFLCLR + A N31 30 SFLEND(*MORE) + A 1 31'Item Number Prompt' + A DSPATR(HI) + A 2 2'Search (item/desc):' + A SSEARCH 30A B 2 35 + A 4 2'Type 1 to select an item.' + A 7 2'Opt' + A DSPATR(UL) + A 7 6'Item' + A DSPATR(UL) + A 7 31'Description' + A DSPATR(UL) + A R ITPFOOT + A 23 2'F3=Exit F5=Refresh F12=Ca- + A ncel' + A COLOR(BLU) + A R ITPNONE + A OVERLAY + A 10 20'** No items match this searc- + A h **' + A R ITPMSGSFL SFL + A SFLMSGRCD(24) + A SMSGKEY SFLMSGKEY + A SPGMQ SFLPGMQ(10) + A R ITPMSGCTL SFLCTL(ITPMSGSFL) + A OVERLAY + A N41 40 SFLDSP + A 41 SFLCLR + A N41 40 SFLEND + A SFLSIZ(0002) + A SFLPAG(0001) diff --git a/perp/qddssrc/perpseld.dspf b/perp/qddssrc/perpseld.dspf index 22568fd1..e2b04eda 100644 --- a/perp/qddssrc/perpseld.dspf +++ b/perp/qddssrc/perpseld.dspf @@ -2,6 +2,7 @@ A PRINT A CA03(03 'Exit') A CA05(05 'Refresh') + A CA06(06 'Add') A CA12(12 'Cancel') A R COSFL SFL A 51 SFLNXTCHG @@ -24,7 +25,8 @@ A 2 2'Currently selected . . :' A SCURSEL 3A O 2 30DSPATR(HI) A 4 2'Type option, press Enter.' - A 5 4'1=Select this company' + A 5 4'1=Select this company 2=Chan- + A ge company info' A 7 4'Opt' A DSPATR(UL) A 7 9'Code' @@ -34,8 +36,33 @@ A 7 76'Curr' A DSPATR(UL) A R COFOOT - A 23 2'F3=Exit F5=Refresh F12=Ca- - A ncel' + A 23 2'F3=Exit F5=Refresh F6=Add - + A F12=Cancel' + A COLOR(BLU) + A R COEDIT + A OVERLAY + A 1 30'Edit Company' + A DSPATR(HI) + A 2 2'Mode:' + A EMODE 1A O 2 8 + A 3 2'Company code:' + A ECOMPC 3A B 3 17 + A 60 DSPATR(PR) + A 4 2'Company name:' + A ECOMPNM 60A B 4 17CHECK(LC) + A 5 2'Address:' + A EADDR1 60A B 5 17CHECK(LC) + A 6 2'City:' + A ECITY 40A B 6 17CHECK(LC) + A 6 59'State:' + A ESTATE 3A B 6 66 + A 7 2'Postal code:' + A EPOSTCD 12A B 7 17 + A 7 36'Country:' + A ECNTRY 3A B 7 45 + A 8 2'Base currency:' + A EBASECUR 20A B 8 17 + A 23 2'Enter=Save F12=Cancel' A COLOR(BLU) A R CONONE A OVERLAY diff --git a/perp/qddssrc/pobrwd.dspf b/perp/qddssrc/pobrwd.dspf index e515ae64..870a1f6a 100644 --- a/perp/qddssrc/pobrwd.dspf +++ b/perp/qddssrc/pobrwd.dspf @@ -12,7 +12,7 @@ A BSVNDR 10A O 12 16 A BSVNDNM 25A O 12 27 A BSBUYER 10A O 12 53 - A BSORDDT L O 12 64DATFMT(*ISO) + A BSORDDT L O 12 64DATFMT(*MDY) A BSSTAT 6A O 12 75 A R BSCTL SFLCTL(BSFL) A SFLSIZ(0099) @@ -33,16 +33,16 @@ A 3 52'Buyer:' A FBUY 10A B 3 59 A 4 2'From date:' - A FFRDT L B 4 13DATFMT(*ISO) + A FFRDT L B 4 13DATFMT(*MDY) A 4 27'To date:' - A FTODT L B 4 36DATFMT(*ISO) + A FTODT L B 4 36DATFMT(*MDY) A 4 50'(blank = no filter)' A 6 2'Enter=Apply filter' A 8 2'Type option, press Enter.' A 9 4'5=Detail 9=Blanket schedules' A 11 2'Opt' A DSPATR(UL) - A 11 5'PO #' + A 11 6'PO #' A DSPATR(UL) A 11 16'Vendor' A DSPATR(UL) @@ -73,7 +73,7 @@ A 3 2'Buyer:' A DDBUYR 10A O 3 9 A 3 22'Order Date:' - A DDORDDT L O 3 34DATFMT(*ISO) + A DDORDDT L O 3 34DATFMT(*MDY) A 3 47'Status:' A DDSTAT 20A O 3 55 A 4 2'Total Amount:' @@ -85,62 +85,62 @@ A DSPATR(UL) A 7 7'Item' A DSPATR(UL) - A 7 33'Ord' + A 7 39'Ord' A DSPATR(UL) - A 7 43'Rcv' + A 7 49'Rcv' A DSPATR(UL) - A 7 53'Open' + A 7 58'Open' A DSPATR(UL) - A 7 62'Price' + A 7 67'Price' A DSPATR(UL) - A 7 72'Src Req' + A 7 73'Src Req' A DSPATR(UL) A 60 L1LN 3Y 0O 8 2EDTCDE(3) A 60 L1ITEM 25A O 8 7 - A 60 L1ORD 10Y 2O 8 33EDTCDE(3) - A 60 L1RCV 10Y 2O 8 43EDTCDE(3) - A 60 L1OPEN 10Y 2O 8 53EDTCDE(3) - A 60 L1PRC 10Y 2O 8 62EDTCDE(3) - A 60 L1SRC 8A O 8 72 + A 60 L1ORD 7Y 2O 8 33EDTCDE(3) + A 60 L1RCV 7Y 2O 8 43EDTCDE(3) + A 60 L1OPEN 7Y 2O 8 53EDTCDE(3) + A 60 L1PRC 7Y 2O 8 63EDTCDE(3) + A 60 L1SRC 8A O 8 73 A 61 L2LN 3Y 0O 9 2EDTCDE(3) A 61 L2ITEM 25A O 9 7 - A 61 L2ORD 10Y 2O 9 33EDTCDE(3) - A 61 L2RCV 10Y 2O 9 43EDTCDE(3) - A 61 L2OPEN 10Y 2O 9 53EDTCDE(3) - A 61 L2PRC 10Y 2O 9 62EDTCDE(3) - A 61 L2SRC 8A O 9 72 + A 61 L2ORD 7Y 2O 9 33EDTCDE(3) + A 61 L2RCV 7Y 2O 9 43EDTCDE(3) + A 61 L2OPEN 7Y 2O 9 53EDTCDE(3) + A 61 L2PRC 7Y 2O 9 63EDTCDE(3) + A 61 L2SRC 8A O 9 73 A 62 L3LN 3Y 0O 10 2EDTCDE(3) A 62 L3ITEM 25A O 10 7 - A 62 L3ORD 10Y 2O 10 33EDTCDE(3) - A 62 L3RCV 10Y 2O 10 43EDTCDE(3) - A 62 L3OPEN 10Y 2O 10 53EDTCDE(3) - A 62 L3PRC 10Y 2O 10 62EDTCDE(3) - A 62 L3SRC 8A O 10 72 + A 62 L3ORD 7Y 2O 10 33EDTCDE(3) + A 62 L3RCV 7Y 2O 10 43EDTCDE(3) + A 62 L3OPEN 7Y 2O 10 53EDTCDE(3) + A 62 L3PRC 7Y 2O 10 63EDTCDE(3) + A 62 L3SRC 8A O 10 73 A 63 L4LN 3Y 0O 11 2EDTCDE(3) A 63 L4ITEM 25A O 11 7 - A 63 L4ORD 10Y 2O 11 33EDTCDE(3) - A 63 L4RCV 10Y 2O 11 43EDTCDE(3) - A 63 L4OPEN 10Y 2O 11 53EDTCDE(3) - A 63 L4PRC 10Y 2O 11 62EDTCDE(3) - A 63 L4SRC 8A O 11 72 + A 63 L4ORD 7Y 2O 11 33EDTCDE(3) + A 63 L4RCV 7Y 2O 11 43EDTCDE(3) + A 63 L4OPEN 7Y 2O 11 53EDTCDE(3) + A 63 L4PRC 7Y 2O 11 63EDTCDE(3) + A 63 L4SRC 8A O 11 73 A 64 L5LN 3Y 0O 12 2EDTCDE(3) A 64 L5ITEM 25A O 12 7 - A 64 L5ORD 10Y 2O 12 33EDTCDE(3) - A 64 L5RCV 10Y 2O 12 43EDTCDE(3) - A 64 L5OPEN 10Y 2O 12 53EDTCDE(3) - A 64 L5PRC 10Y 2O 12 62EDTCDE(3) - A 64 L5SRC 8A O 12 72 + A 64 L5ORD 7Y 2O 12 33EDTCDE(3) + A 64 L5RCV 7Y 2O 12 43EDTCDE(3) + A 64 L5OPEN 7Y 2O 12 53EDTCDE(3) + A 64 L5PRC 7Y 2O 12 63EDTCDE(3) + A 64 L5SRC 8A O 12 73 A 65 L6LN 3Y 0O 13 2EDTCDE(3) A 65 L6ITEM 25A O 13 7 - A 65 L6ORD 10Y 2O 13 33EDTCDE(3) - A 65 L6RCV 10Y 2O 13 43EDTCDE(3) - A 65 L6OPEN 10Y 2O 13 53EDTCDE(3) - A 65 L6PRC 10Y 2O 13 62EDTCDE(3) - A 65 L6SRC 8A O 13 72 + A 65 L6ORD 7Y 2O 13 33EDTCDE(3) + A 65 L6RCV 7Y 2O 13 43EDTCDE(3) + A 65 L6OPEN 7Y 2O 13 53EDTCDE(3) + A 65 L6PRC 7Y 2O 13 63EDTCDE(3) + A 65 L6SRC 8A O 13 73 A 34 15 2'More lines exist -- not all shown.' A 17 2'Schedules:' A DDSCH 50A O 17 13 - A 23 2'F12=Back F5=Refresh' + A 23 2'F5=Refresh F12=Back' A COLOR(BLU) A R RMSGSFL SFL A SFLMSGRCD(24) diff --git a/perp/qddssrc/poentd.dspf b/perp/qddssrc/poentd.dspf index 885cfff2..891fd186 100644 --- a/perp/qddssrc/poentd.dspf +++ b/perp/qddssrc/poentd.dspf @@ -19,8 +19,8 @@ A DSPATR(HI) A 4 22'(defaulted from vendor)' A 5 2'Order Date:' - A HORDDT L B 5 14DATFMT(*ISO) - A 5 26'(YYYY-MM-DD)' + A HORDDT L B 5 14DATFMT(*MDY) + A 5 26'(MM/DD/YY)' A 6 2'Notes:' A HNOTES 50A B 6 9 A 23 2'F3=Exit F12=Cancel' @@ -33,8 +33,8 @@ A SLLINE 3Y 0O 9 5 A SLITEM 25A O 9 10 A SLQTY 15Y 4O 9 36EDTCDE(3) - A SLUOM 5A O 9 54 - A SLPRICE 15Y 4O 9 61EDTCDE(3) + A SLUOM 5A O 9 56 + A SLPRICE 15Y 4O 9 62EDTCDE(3) A R PLCTL SFLCTL(PLSFL) A SFLSIZ(0099) A SFLPAG(0007) @@ -49,11 +49,11 @@ A DPONBR 15A O 2 8 A 2 40'Vendor:' A DVNDCD 10A O 2 48 - A DVNDNM 30A O 2 59 + A DVNDNM 22A O 2 59 A 3 2'Buyer:' A DBUYCD 10A O 3 9 A 3 40'Order Date:' - A DORDDT L O 3 52DATFMT(*ISO) + A DORDDT L O 3 52DATFMT(*MDY) A 4 2'Status:' A DSTATUS 20A O 4 10 A 4 40'Total Amount:' @@ -62,15 +62,15 @@ A 7 4'2=Change 4=Delete' A 8 2'Opt' A DSPATR(UL) - A 8 5'Line' + A 8 6'Line' A DSPATR(UL) - A 8 10'Item' + A 8 11'Item' A DSPATR(UL) - A 8 36'Ord Qty' + A 8 48'Ord Qty' A DSPATR(UL) - A 8 54'UOM' + A 8 56'UOM' A DSPATR(UL) - A 8 61'Unit Price' + A 8 71'Unit Price' A DSPATR(UL) A R PLFOOT A OVERLAY @@ -88,7 +88,7 @@ A EMODE 1A O 2 8 A 3 2'Item Number:' A EITEM 25A B 3 15 - A EITMDSC 40A O 3 42 + A EITMDSC 39A O 3 42 A DSPATR(HI) A 4 2'Quantity:' A EQTY 15Y 4B 4 12EDTCDE(3) @@ -99,8 +99,8 @@ A EPRICE 15Y 4B 6 14EDTCDE(3) A 6 33'(0 = default from vendor)' A 7 2'Expected Recv Date:' - A EEXPDT L B 7 22DATFMT(*ISO) - A 7 34'(blank = none)' + A EEXPDT L B 7 22DATFMT(*MDY) + A 7 34'(MM/DD/YY, blank = none)' A 23 2'Enter=Save F12=Cancel' A COLOR(BLU) A R PMSGSFL SFL diff --git a/perp/qddssrc/poprmtd.dspf b/perp/qddssrc/poprmtd.dspf new file mode 100644 index 00000000..82fc96d4 --- /dev/null +++ b/perp/qddssrc/poprmtd.dspf @@ -0,0 +1,56 @@ + A DSPSIZ(24 80 *DS3) + A PRINT + A CA03(03 'Exit') + A CA05(05 'Refresh') + A CA12(12 'Cancel') + A R PPSFL SFL + A 51 SFLNXTCHG + A SOPT 1A B 8 2 + A 50 DSPATR(RI) + A 50 DSPATR(PC) + A SIPONBR 15Y 0O 8 5EDTCDE(3) + A SIVNDR 10A O 8 22 + A SIVNDNM 30A O 8 33 + A SISTAT 10A O 8 65 + A R PPCTL SFLCTL(PPSFL) + A SFLSIZ(0099) + A SFLPAG(0007) + A OVERLAY + A SFLDSPCTL + A N31 30 SFLDSP + A 31 SFLCLR + A N31 30 SFLEND(*MORE) + A 1 26'PO Number Prompt' + A DSPATR(HI) + A 2 2'Search (PO # or vendor):' + A SSEARCH 30A B 2 28 + A 4 2'Type 1 to select a PO.' + A 7 2'Opt' + A DSPATR(UL) + A 7 6'PO #' + A DSPATR(UL) + A 7 22'Vendor' + A DSPATR(UL) + A 7 33'Vendor Name' + A DSPATR(UL) + A 7 65'Status' + A DSPATR(UL) + A R PPFOOT + A 23 2'F3=Exit F5=Refresh F12=Ca- + A ncel' + A COLOR(BLU) + A R PPNONE + A OVERLAY + A 10 20'** No POs awaiting receipt for - + A this search **' + A R PPMSGSFL SFL + A SFLMSGRCD(24) + A SMSGKEY SFLMSGKEY + A SPGMQ SFLPGMQ(10) + A R PPMSGCTL SFLCTL(PPMSGSFL) + A OVERLAY + A N41 40 SFLDSP + A 41 SFLCLR + A N41 40 SFLEND + A SFLSIZ(0002) + A SFLPAG(0001) diff --git a/perp/qddssrc/poreqd.dspf b/perp/qddssrc/poreqd.dspf index 0070f059..3f67870d 100644 --- a/perp/qddssrc/poreqd.dspf +++ b/perp/qddssrc/poreqd.dspf @@ -2,7 +2,7 @@ A PRINT A CA03(03 'Exit') A CA05(05 'Refresh') - A CA06(06 'Convert/Confirm') + A CF06(06 'Convert/Confirm') A CA12(12 'Cancel/Back') A R SSFL SFL A 51 SFLNXTCHG @@ -11,10 +11,10 @@ A 50 DSPATR(PC) A SSREQNBR 8A O 9 5 A SSREQBY 10A O 9 14 - A SSNEEDBY L O 9 25DATFMT(*ISO) + A SSNEEDBY L O 9 27DATFMT(*MDY) A SSVNDR 10A O 9 36 A SSVNDNM 25A O 9 47 - A SSTOTEST 15Y 2O 9 73EDTCDE(3) + A SSTOTEST 6Y 2O 9 73EDTCDE(3) A R SSCTL SFLCTL(SSFL) A SFLSIZ(0099) A SFLPAG(0007) @@ -32,11 +32,11 @@ A , then F6=Convert.' A 8 2'Opt' A DSPATR(UL) - A 8 5'Req #' + A 8 6'Req #' A DSPATR(UL) A 8 14'Requested By' A DSPATR(UL) - A 8 25'Need By' + A 8 27'Need By' A DSPATR(UL) A 8 36'Vendor' A DSPATR(UL) diff --git a/perp/qddssrc/poschd.dspf b/perp/qddssrc/poschd.dspf index 889f3737..adfb6cfa 100644 --- a/perp/qddssrc/poschd.dspf +++ b/perp/qddssrc/poschd.dspf @@ -23,7 +23,7 @@ A 50 DSPATR(RI) A 50 DSPATR(PC) A SLSEQ 3Y 0O 10 5 - A SLSCHDT L O 10 10DATFMT(*ISO) + A SLSCHDT L O 10 10DATFMT(*MDY) A SLSCHQTY 15Y 4O 10 22EDTCDE(3) A SLRCVQTY 15Y 4O 10 40EDTCDE(3) A SLSCHNOT 30A O 10 58 @@ -47,8 +47,8 @@ A DVNDCD 10A O 3 10 A 3 22'Ord Qty:' A DORDQTY 15Y 4O 3 31EDTCDE(3) - A 3 47'UOM:' - A DUOM 5A O 3 52 + A 3 58'UOM:' + A DUOM 5A O 3 64 A 4 2'Sched Total:' A DSCHTOT 15Y 4O 4 15EDTCDE(3) A 4 32'Recv Total:' @@ -61,7 +61,7 @@ A 8 4'2=Change 4=Delete' A 9 2'Opt' A DSPATR(UL) - A 9 5'Seq' + A 9 6'Seq' A DSPATR(UL) A 9 10'Scheduled' A DSPATR(UL) @@ -88,8 +88,8 @@ A 3 2'Seq:' A ESEQ 3Y 0O 3 7EDTCDE(3) A 4 2'Scheduled Date:' - A ESCHDT L B 4 18DATFMT(*ISO) - A 4 30'(YYYY-MM-DD)' + A ESCHDT L B 4 18DATFMT(*MDY) + A 4 30'(MM/DD/YY)' A 5 2'Scheduled Qty:' A ESCHQTY 15Y 4B 5 17EDTCDE(3) A 6 2'Received Qty:' diff --git a/perp/qddssrc/rcventd.dspf b/perp/qddssrc/rcventd.dspf index 81f338af..71ad37fb 100644 --- a/perp/qddssrc/rcventd.dspf +++ b/perp/qddssrc/rcventd.dspf @@ -1,6 +1,7 @@ A DSPSIZ(24 80 *DS3) A PRINT A CA03(03 'Exit') + A CA04(04 'Prompt') A CA05(05 'Refresh') A CA12(12 'Cancel') A R RHEAD @@ -23,7 +24,7 @@ A HRCVNM 30A O 6 28 A 7 2'Notes:' A HNOTES 50A B 7 9 - A 23 2'F3=Exit F12=Cancel' + A 23 2'F3=Exit F4=Prompt F12=Cancel' A COLOR(BLU) A R RLSFL SFL A 51 SFLNXTCHG diff --git a/perp/qddssrc/reqaprd.dspf b/perp/qddssrc/reqaprd.dspf index e3a1504a..120832ba 100644 --- a/perp/qddssrc/reqaprd.dspf +++ b/perp/qddssrc/reqaprd.dspf @@ -12,7 +12,7 @@ A 50 DSPATR(PC) A ASREQNBR 8A O 9 5 A ASREQBY 10A O 9 14 - A ASNEEDBY L O 9 25DATFMT(*ISO) + A ASNEEDBY L O 9 25DATFMT(*MDY) A ASPRICD 10A O 9 36 A ASTOTEST 15Y 2O 9 47EDTCDE(3) A ASCONF 8A O 9 65 @@ -31,11 +31,11 @@ A 6 2'Type option 5=Review, press Enter.' A 8 2'Opt' A DSPATR(UL) - A 8 5'Req #' + A 8 6'Req #' A DSPATR(UL) A 8 14'Requested By' A DSPATR(UL) - A 8 25'Need By' + A 8 27'Need By' A DSPATR(UL) A 8 36'Priority' A DSPATR(UL) @@ -59,7 +59,7 @@ A 2 30'Requested By:' A DDREQBY 10A O 2 44 A 3 2'Need By:' - A DDNEEDBY L O 3 11DATFMT(*ISO) + A DDNEEDBY L O 3 11DATFMT(*MDY) A 3 30'Priority:' A DDPRICD 20A O 3 40 A 4 2'Total Est Cost:' diff --git a/perp/qddssrc/reqentd.dspf b/perp/qddssrc/reqentd.dspf index 24778eb9..28666d98 100644 --- a/perp/qddssrc/reqentd.dspf +++ b/perp/qddssrc/reqentd.dspf @@ -14,8 +14,8 @@ A 3 2'Requested By:' A HREQBY 10A B 3 16 A 4 2'Need By Date:' - A HNEEDBY L B 4 16DATFMT(*ISO) - A 4 28'(YYYY-MM-DD)' + A HNEEDBY L B 4 16DATFMT(*MDY) + A 4 28'(MM/DD/YY)' A 5 2'Priority:' A HPRICD 20A B 5 12 A 5 34'(LOW/NORMAL/HIGH/CRITICAL)' @@ -48,7 +48,7 @@ A 2 40'Requested By:' A DREQBY 10A O 2 54 A 3 2'Need By:' - A DNEEDBY L O 3 11DATFMT(*ISO) + A DNEEDBY L O 3 11DATFMT(*MDY) A 3 40'Priority:' A DPRICD 20A O 3 50 A 4 2'Status:' @@ -59,9 +59,9 @@ A 7 4'2=Change 4=Delete' A 8 2'Opt' A DSPATR(UL) - A 8 5'Line' + A 8 6'Line' A DSPATR(UL) - A 8 10'Item' + A 8 11'Item' A DSPATR(UL) A 8 36'Qty' A DSPATR(UL) @@ -85,6 +85,7 @@ A EMODE 1A O 2 8 A 3 2'Item Number:' A EITEM 25A B 3 15 + A 3 41'(? = prompt)' A 4 2'Quantity:' A EQTY 15Y 4B 4 12EDTCDE(3) A 5 2'UOM:' diff --git a/perp/qddssrc/vndprmtd.dspf b/perp/qddssrc/vndprmtd.dspf new file mode 100644 index 00000000..bac1c25a --- /dev/null +++ b/perp/qddssrc/vndprmtd.dspf @@ -0,0 +1,52 @@ + A DSPSIZ(24 80 *DS3) + A PRINT + A CA03(03 'Exit') + A CA05(05 'Refresh') + A CA12(12 'Cancel') + A R VPSFL SFL + A 51 SFLNXTCHG + A SOPT 1A B 8 2 + A 50 DSPATR(RI) + A 50 DSPATR(PC) + A SIVENDOR 10A O 8 5 + A SIVNAME 60A O 8 17 + A R VPCTL SFLCTL(VPSFL) + A SFLSIZ(0099) + A SFLPAG(0007) + A OVERLAY + A SFLDSPCTL + A N31 30 SFLDSP + A 31 SFLCLR + A N31 30 SFLEND(*MORE) + A 1 30'Vendor Number Prompt' + A DSPATR(HI) + A 2 2'Search (vendor # or name):' + A SSEARCH 30A B 2 30 + A 4 2'Type 1 to select a vendor, o- + A r change Search and press En- + A ter.' + A 7 2'Opt' + A DSPATR(UL) + A 7 6'Vendor' + A DSPATR(UL) + A 7 17'Name' + A DSPATR(UL) + A R VPFOOT + A 23 2'F3=Exit F5=Refresh F12=Ca- + A ncel' + A COLOR(BLU) + A R VPNONE + A OVERLAY + A 10 20'** No vendors match this sea- + A rch **' + A R VPMSGSFL SFL + A SFLMSGRCD(24) + A SMSGKEY SFLMSGKEY + A SPGMQ SFLPGMQ(10) + A R VPMSGCTL SFLCTL(VPMSGSFL) + A OVERLAY + A N41 40 SFLDSP + A 41 SFLCLR + A N41 40 SFLEND + A SFLSIZ(0002) + A SFLPAG(0001) diff --git a/perp/qddssrc/wlmd.dspf b/perp/qddssrc/wlmd.dspf index 8f7a05c9..2bee653e 100644 --- a/perp/qddssrc/wlmd.dspf +++ b/perp/qddssrc/wlmd.dspf @@ -5,6 +5,7 @@ A CA06(06 'Add') A CA12(12 'Cancel') A R WLEDIT + A OVERLAY A 1 22'Warehouse Layout Maintenance' A DSPATR(HI) A 2 2'Company . . . . . . . :' @@ -12,27 +13,27 @@ A 3 2'Status . . . . . . . . :' A ESTAT 10A O 3 27 A 5 2'Warehouse name . . . . :' - A EWHSNM 50A B 5 27 + A EWHSNM 50A B 5 28 A 7 2'Grid dimensions' A DSPATR(UL) A 8 2'Aisles . . . . . . . . :' - A EASLCNT 5Y 0B 8 27EDTCDE(3) + A EASLCNT 5Y 0B 8 28EDTCDE(3) A 9 2'Bays per aisle . . . . :' - A EBAYSPA 5Y 0B 9 27EDTCDE(3) + A EBAYSPA 5Y 0B 9 28EDTCDE(3) A 10 2'Shelves per bay . . . . :' - A ESHLFSB 5Y 0B 10 27EDTCDE(3) + A ESHLFSB 5Y 0B 10 28EDTCDE(3) A 12 2'Bin dimensions (meters)' A DSPATR(UL) A 13 2'Bin width . . . . . . . :' - A EBINWID 9Y 4B 13 27EDTCDE(3) + A EBINWID 9Y 4B 13 28EDTCDE(3) A 14 2'Bin depth . . . . . . . :' - A EBINDEP 9Y 4B 14 27EDTCDE(3) + A EBINDEP 9Y 4B 14 28EDTCDE(3) A 15 2'Bin height . . . . . . :' - A EBINHGT 9Y 4B 15 27EDTCDE(3) + A EBINHGT 9Y 4B 15 28EDTCDE(3) A 16 2'Aisle spacing . . . . . :' - A EASLSPC 9Y 4B 16 27EDTCDE(3) + A EASLSPC 9Y 4B 16 28EDTCDE(3) A 18 2'Notes . . . . . . . . . :' - A ENOTES 50A B 18 27 + A ENOTES 50A B 18 28 A R WLNOCO A OVERLAY A 20 20'** No company selected - run - diff --git a/perp/qddssrc/wrkcnvd.dspf b/perp/qddssrc/wrkcnvd.dspf index 9f935b81..b41b7438 100644 --- a/perp/qddssrc/wrkcnvd.dspf +++ b/perp/qddssrc/wrkcnvd.dspf @@ -26,15 +26,16 @@ A SCOMPDSP 3A O 2 11 A 2 20'Item Number:' A SFITEM 25A B 2 33 + A 2 59'(? = prompt)' A 4 2'Type option, press Enter.' A 5 4'2=Change 4=Delete' A 7 2'Opt' A DSPATR(UL) - A 7 5'From' + A 7 6'From' A DSPATR(UL) A 7 11'To' A DSPATR(UL) - A 7 17'Factor' + A 7 29'Factor' A DSPATR(UL) A R CVFOOT A 23 2'F3=Exit F5=Refresh F6=Add- diff --git a/perp/qddssrc/wrkicld.dspf b/perp/qddssrc/wrkicld.dspf index 3a712922..6ac3409e 100644 --- a/perp/qddssrc/wrkicld.dspf +++ b/perp/qddssrc/wrkicld.dspf @@ -28,7 +28,7 @@ A ay' A 7 2'Opt' A DSPATR(UL) - A 7 5'Class' + A 7 6'Class' A DSPATR(UL) A 7 17'Description' A DSPATR(UL) diff --git a/perp/qddssrc/wrkitmd.dspf b/perp/qddssrc/wrkitmd.dspf index 1e3d676c..d616d215 100644 --- a/perp/qddssrc/wrkitmd.dspf +++ b/perp/qddssrc/wrkitmd.dspf @@ -32,12 +32,14 @@ A SFACT 1A B 2 55 A 3 2'Low stock only (Y/N):' A SFLOW 1A B 3 24 + A 4 2'Position To / Filter:' + A SPOSTO 30A B 4 24 A 5 2'Type option, press Enter.' A 6 4'2=Change 4=Delete 5=Display - A 6=UOM Conversions 7=Lots' A 7 2'Opt' A DSPATR(UL) - A 7 5'Item' + A 7 6'Item' A DSPATR(UL) A 7 31'Description' A DSPATR(UL) @@ -45,7 +47,7 @@ A DSPATR(UL) A 7 73'Lot' A DSPATR(UL) - A 7 75'Low' + A 7 77'Low' A DSPATR(UL) A R WIFOOT A 23 2'F3=Exit F5=Refresh F6=Add - @@ -65,8 +67,9 @@ A DSPATR(HI) A 2 2'Mode:' A EMODE 1A O 2 8 - A 2 5'Item:' + A 2 15'Item:' A EITEM 25A B 2 25 + A 2 51'(? = prompt)' A 3 2'Description:' A EDESC 60A B 3 15 A 4 2'Short Desc:' diff --git a/perp/qddssrc/wrkivnd.dspf b/perp/qddssrc/wrkivnd.dspf index 5c6cc083..f69b5c2c 100644 --- a/perp/qddssrc/wrkivnd.dspf +++ b/perp/qddssrc/wrkivnd.dspf @@ -32,11 +32,12 @@ A SFITEM 15A B 2 22 A 2 39'Vendor:' A SFVENDOR 10A B 2 47 + A 2 58'(? = prompt)' A 4 2'Type option, press Enter.' A 5 4'2=Change 4=Delete' A 7 2'Opt' A DSPATR(UL) - A 7 5'Item' + A 7 6'Item' A DSPATR(UL) A 7 18'Vendor' A DSPATR(UL) @@ -70,8 +71,10 @@ A EMODE 1A O 2 8 A 3 2'Item:' A EITEM 25A B 3 15 + A 3 41'(? = prompt)' A 4 2'Vendor:' A EVENDOR 10A B 4 15 + A 4 26'(? = prompt)' A 5 2'Vendor Part #:' A EPARTN 25A B 5 17 A 6 2'Lead Time (days):' diff --git a/perp/qddssrc/wrkivpd.dspf b/perp/qddssrc/wrkivpd.dspf index 6bb7ad7f..10720726 100644 --- a/perp/qddssrc/wrkivpd.dspf +++ b/perp/qddssrc/wrkivpd.dspf @@ -26,6 +26,7 @@ A SFITEM 15A B 2 22 A 2 39'Vendor:' A SFVENDOR 10A B 2 47 + A 2 58'(? = prompt)' A 4 2'Historical rows are read-only. F- A 6=Add a new current price.' A 7 2'From' @@ -39,6 +40,7 @@ A 7 47'Source' A DSPATR(UL) A R IPFOOT + A OVERLAY A 23 2'F3=Exit F5=Refresh F6=Add Ne- A w Price F12=Cancel' A COLOR(BLU) diff --git a/perp/qddssrc/wrklotd.dspf b/perp/qddssrc/wrklotd.dspf index 18e902d7..0478b1ff 100644 --- a/perp/qddssrc/wrklotd.dspf +++ b/perp/qddssrc/wrklotd.dspf @@ -27,6 +27,7 @@ A SCOMPDSP 3A O 2 11 A 2 20'Item Number:' A SFITEM 25A B 2 33 + A 2 59'(? = prompt)' A 3 2'Item On Hand:' A SIOH 15Y 4O 3 16EDTCDE(3) A 3 38'Lot Total:' @@ -39,7 +40,7 @@ A 7 4'2=Change 4=Delete' A 9 2'Opt' A DSPATR(UL) - A 9 5'Lot' + A 9 6'Lot' A DSPATR(UL) A 9 26'Qty On Hand' A DSPATR(UL) @@ -68,9 +69,9 @@ A ELOT 20A B 3 14 A 4 2'Qty On Hand:' A EQTY 15Y 4B 4 15EDTCDE(3) - A 5 2'Received Date (YYYY-MM-DD):' + A 5 2'Received Date (MM/DD/YY):' A ERECV 10A B 5 31 - A 6 2'Expiry Date (YYYY-MM-DD, bla- + A 6 2'Expiry Date (MM/DD/YY, bla- A nk=none):' A EEXPD 10A B 6 41 A 7 2'Active:' diff --git a/perp/qddssrc/wrkusrd.dspf b/perp/qddssrc/wrkusrd.dspf index 22eec740..9e428d5e 100644 --- a/perp/qddssrc/wrkusrd.dspf +++ b/perp/qddssrc/wrkusrd.dspf @@ -52,13 +52,15 @@ A 3 2'User code:' A EUCODE 10A B 3 15 A 4 2'Display name:' - A EUNAME 60A B 4 17 + A EUNAME 60A B 4 17CHECK(LC) A 5 2'Email:' - A EUEMAIL 120A B 5 15 - A 6 2'Role:' - A EUROLE 20A B 6 15 - A 7 2'Active:' - A EUACT 1A B 7 15 + A EUEMAIL 120A B 5 15CHECK(LC) + A 7 2'Role:' + A EUROLE 20A B 7 15 + A 7 36'(ADMIN/APPROVER/BUYER/RECEIVER/REQ- + A UESTER)' + A 8 2'Active:' + A EUACT 1A B 8 15 A 23 2'Enter=Save F12=Cancel' A COLOR(BLU) A R UMSGSFL SFL diff --git a/perp/qrpglesrc/itmprmt.sqlrpgle b/perp/qrpglesrc/itmprmt.sqlrpgle new file mode 100644 index 00000000..6043b0c8 --- /dev/null +++ b/perp/qrpglesrc/itmprmt.sqlrpgle @@ -0,0 +1,213 @@ +**free + +// --------------------------------------------------------------------- +// Program: itmprmt (standard, reusable Item Number prompt/lookup) +// Purpose: System-wide "?" + Enter lookup for any keyable Item Number +// field. Caller CALLs this program passing the company code +// and the field's current value; typing '?' into the field +// before Enter is the trigger convention every caller uses, +// so this program treats a '?' seed the same as a blank +// search (full list). Any other seed value pre-fills the +// Search field so partial text the user already typed keeps +// working as a filter. The subfile lists item_number + +// item_description, filtered case-insensitively on either +// column; 1=Select on a row returns that item_number in the +// same parameter. F3/F12 cancel and return the field blank. +// Model: perpselr's subfile-picker pattern (PERP-16), +// adapted for field-level invocation instead of a full-screen +// menu step. Called via a plain dynamic CALL (EXTPGM +// prototype declared in each caller) -- the same idiom +// wrkitmr already uses to call wrkcnvr/wrklotr -- not a bound +// service program, so no bnddir/exports wiring is needed. +// Callers: wrkcnvr (PERP-54), wrkitmr (PERP-57), wrkivnr (PERP-58), +// wrkivpr (PERP-59), wrklotr (PERP-60), reqentr (PERP-61), +// poentr (PERP-62). +// Epic: PERP-51 (PERP-56) +// --------------------------------------------------------------------- + +ctl-opt dftactgrp(*no) actgrp(*new); + +dcl-pi *n; + pCompcd char(3) const; + pItem varchar(25); +end-pi; + +dcl-f itmprm2d workstn sfile(itpsfl:rrn) sfile(itpmsgsfl:msgrrn); + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-ds statusDS psds qualified; + programName char(10) pos(334); +end-ds; + +dcl-ds itemRow qualified; + item varchar(25); + desc varchar(60); +end-ds; + +dcl-ds rows likeds(itemRow) dim(500); +dcl-s numRows int(10); +dcl-s i int(10); +dcl-s rrn int(10); +dcl-s msgrrn int(10); +dcl-s msgkey char(4); +dcl-s selRrn int(10); +dcl-s search varchar(30); + +search = %trim(pItem); +if search = '?'; + search = ''; +endif; +ssearch = search; + +dow not *in03 and not *in12; + exsr clearMsgs; + exsr loadRows; + + if numRows = 0; + *in30 = *off; + write itpnone; + else; + exsr fillSubfile; + *in30 = *on; + endif; + + write itpfoot; + if msgrrn > 0; + *in40 = *on; + write itpmsgctl; + else; + *in40 = *off; + endif; + + exfmt itpctl; + + if *in03 or *in12; + pItem = ''; + leave; + endif; + + if *in05; + iter; + endif; + + if ssearch <> search; + search = %trim(ssearch); + iter; + endif; + + // Guard on numRows: READC against a subfile that was never written + // to this cycle (0 rows loaded) raises a "Session or device error" + // (CPF5006-class) runtime error instead of just returning *EOF. + if numRows > 0; + selRrn = 0; + readc itpsfl; + dow not %eof(itmprm2d); + if sopt = '1'; + if selRrn = 0; + selRrn = rrn; + else; + writeMsg('Only one item may be selected per Enter.'); + endif; + elseif sopt <> ''; + writeMsg('Option ' + sopt + ' is not valid - use 1.'); + endif; + readc itpsfl; + enddo; + endif; + + if selRrn > 0 and msgrrn = 0; + chain selRrn itpsfl; + pItem = siitem; + leave; + endif; + +enddo; + +*inlr = *on; +return; + +// --------------------------------------------------------------------- +begsr loadRows; + numRows = 0; + exec sql declare ip1 cursor for + select item_number, item_description + from perpdemo.item + where company_code = :pCompcd + and (:search = '' + or upper(item_number) like '%' || upper(:search) || '%' + or upper(item_description) like '%' || upper(:search) || '%') + order by item_number; + exec sql open ip1; + if sqlcode < 0; + writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); + leavesr; + endif; + + dow numRows < %elem(rows); + exec sql fetch ip1 into :itemRow; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + numRows += 1; + rows(numRows) = itemRow; + enddo; + exec sql close ip1; +endsr; + +// --------------------------------------------------------------------- +begsr fillSubfile; + rrn = 0; + *in31 = *on; + write itpctl; + *in31 = *off; + for i = 1 to numRows; + *in50 = *off; + *in51 = *off; + sopt = ''; + siitem = rows(i).item; + sidesc = %subst(rows(i).desc : 1 : %min(%len(rows(i).desc) : 48)); + rrn += 1; + write itpsfl; + endfor; +endsr; + +// --------------------------------------------------------------------- +begsr clearMsgs; + msgrrn = 0; + *in41 = *on; + write itpmsgctl; + *in41 = *off; +endsr; + +// --------------------------------------------------------------------- +dcl-proc writeMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + smsgkey : + x'0000000000000000'); + msgrrn += 1; + spgmq = statusDS.programName; + write itpmsgsfl; +end-proc; diff --git a/perp/qrpglesrc/perpselr.sqlrpgle b/perp/qrpglesrc/perpselr.sqlrpgle index 120e7186..8b263089 100644 --- a/perp/qrpglesrc/perpselr.sqlrpgle +++ b/perp/qrpglesrc/perpselr.sqlrpgle @@ -44,18 +44,31 @@ dcl-ds coRow qualified; end-ds; dcl-ds companies likeds(coRow) dim(200); -dcl-s numCo int(10); -dcl-s i int(10); -dcl-s rrn int(10); -dcl-s msgrrn int(10); -dcl-s selRrn int(10); -dcl-s msgkey char(4); +dcl-s numCo int(10); +dcl-s i int(10); +dcl-s rrn int(10); +dcl-s msgrrn int(10); +dcl-s selRrn int(10); +dcl-s changeRrn int(10); +dcl-s selOpt char(1); +dcl-s msgkey char(4); +dcl-s holdMsg ind; in ldaDS; scursel = ldaDS.compcd; dow not *in03 and not *in12; - exsr clearMsgs; + // A message queued by an action handler below (F6=Add, 2=Change, + // 1=Select) must survive one full loop pass before being cleared, + // or it never reaches the screen -- clearMsgs wipes msgrrn back to 0 + // on the very next pass, before this pass's own exfmt ever shows it. + // holdMsg skips exactly one clearMsgs call right after such a + // message was queued. Same pattern as wrkivpr (PERP-74). + if holdMsg; + holdMsg = *off; + else; + exsr clearMsgs; + endif; exsr loadCompanies; if numCo = 0; @@ -84,32 +97,51 @@ dow not *in03 and not *in12; iter; // refresh endif; + if *in06; + exsr addCompany; + iter; + endif; + // Guard on numCo: READC against a subfile that was never written to // this cycle (0 rows loaded) raises a "Session or device error" // (CPF5006-class) runtime error instead of just returning *EOF. if numCo > 0; - selRrn = 0; + selRrn = 0; + changeRrn = 0; readc cosfl; dow not %eof(perpseld); - if sopt = '1'; - if selRrn = 0; + if sopt <> ''; + selOpt = sopt; + if selRrn > 0 or changeRrn > 0; + writeMsg('Only one option may be used per Enter.'); + elseif selOpt = '1'; selRrn = rrn; + elseif selOpt = '2'; + changeRrn = rrn; else; - writeMsg('Only one company may be selected per Enter.'); + writeMsg('Option ' + %trim(selOpt) + ' is not valid - use 1 or 2.'); endif; - elseif sopt <> ''; - writeMsg('Option ' + %trim(sopt) + ' is not valid - use 1.'); endif; readc cosfl; enddo; endif; + // 1=Select commits the LDA update and then exits the program + // straight back to the caller (the menu) -- same as F3 -- instead + // of redisplaying this list. No point queuing a confirmation message + // first: with no further EXFMT on this device, it would never be + // seen. if selRrn > 0 and msgrrn = 0; chain selRrn cosfl; ldaDS.compcd = scompc; out ldaDS; - writeMsg('Company ' + ldaDS.compcd + ' selected for this session.'); scursel = ldaDS.compcd; + leave; + endif; + + if changeRrn > 0 and msgrrn = 0; + chain changeRrn cosfl; + exsr changeCompany; endif; enddo; @@ -128,7 +160,7 @@ begsr loadCompanies; exec sql open cocsr; if sqlcode < 0; writeMsg('SQL error opening cursor: ' + %char(sqlcode)); - return; + leavesr; endif; dow numCo < %elem(companies); @@ -168,6 +200,92 @@ begsr clearMsgs; *in41 = *off; endsr; +// --------------------------------------------------------------------- +// PERP-52: F6=Create new company. Minimal add panel over the company +// table -- required fields only, defaults matching the DDL's DEFAULTs +// (country_code='US', base_currency='USD'). *in60 off -- ECOMPC (the +// primary key) is editable while adding, protected while changing +// (see changeCompany below). +begsr addCompany; + emode = 'A'; + *in60 = *off; + ecompc = ''; + ecompnm = ''; + eaddr1 = ''; + ecity = ''; + estate = ''; + epostcd = ''; + ecntry = 'US'; + ebasecur = 'USD'; + exfmt coedit; + if not *in12 and ecompc <> '' and ecompnm <> ''; + exec sql + insert into perpdemo.company + (company_code, company_name, address_line1, city_name, + state_code, postal_code, country_code, base_currency) + values (:ecompc, :ecompnm, :eaddr1, :ecity, + :estate, :epostcd, :ecntry, :ebasecur); + if sqlcode < 0; + writeMsg('Add company failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Company ' + %trim(ecompc) + ' created.'); + endif; + holdMsg = *on; + endif; + // *in12 (F12) here only cancels the Add Company panel, not the + // whole Select Company screen -- reset before returning to the + // outer dow, which also tests *in12 to decide whether to exit. + *in12 = *off; +endsr; + +// --------------------------------------------------------------------- +// PERP-52: 2=Change. Same COEDIT panel as Add, but the company code +// (primary key, referenced by FK from nearly every other PERP table) +// is protected -- *in60 on makes ECOMPC display-only via DSPATR(PR) +// in the DDS, so the WHERE clause below always matches the row the +// user actually selected, never a typo'd or retyped code. +begsr changeCompany; + emode = 'C'; + *in60 = *on; + ecompc = scompc; + exec sql + select company_name, address_line1, city_name, state_code, + postal_code, country_code, base_currency + into :ecompnm, :eaddr1, :ecity, :estate, + :epostcd, :ecntry, :ebasecur + from perpdemo.company + where company_code = :ecompc; + if sqlcode <> 0; + writeMsg('Company ' + %trim(ecompc) + ' disappeared before change.'); + holdMsg = *on; + leavesr; + endif; + exfmt coedit; + if not *in12; + exec sql + update perpdemo.company + set company_name = :ecompnm, + address_line1 = :eaddr1, + city_name = :ecity, + state_code = :estate, + postal_code = :epostcd, + country_code = :ecntry, + base_currency = :ebasecur, + updated_at = current_timestamp, + updated_by = user + where company_code = :ecompc; + if sqlcode < 0; + writeMsg('Change failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Company ' + %trim(ecompc) + ' updated.'); + endif; + holdMsg = *on; + endif; + *in12 = *off; +endsr; + // --------------------------------------------------------------------- dcl-proc writeMsg; dcl-pi *n; diff --git a/perp/qrpglesrc/pobrwr.sqlrpgle b/perp/qrpglesrc/pobrwr.sqlrpgle index 78e4e338..93d6284e 100644 --- a/perp/qrpglesrc/pobrwr.sqlrpgle +++ b/perp/qrpglesrc/pobrwr.sqlrpgle @@ -21,12 +21,14 @@ // Epic: PERP-7 (PERP-41) // --------------------------------------------------------------------- -// datfmt(*iso) is REQUIRED here (not decorative) -- filter defaults -// use 0001-01-01 / 9999-12-31 as sentinels, and the job DATFMT on -// this environment is *MDY (2-digit year, 1940-2039). Without this -// ctl-opt, every Date variable in this program is capped at *MDY's -// range and RNQ0114 fires at runtime the first time the DSPF WRITEs -// the FFRDT/FTODT fields or the SQL fetches one. +// datfmt(*iso) is REQUIRED here (not decorative). FFRDT/FTODT are +// DATFMT(*MDY) on pobrwd.dspf, which binds their underlying variables +// to *MDY's 1940-2039 year range regardless of this ctl-opt (which +// only governs Date variables not tied to a display-file field) -- +// see the PERP-89 clamp below, which uses 1940-01-01/2039-12-31 as +// in-range sentinels for exactly this reason (an out-of-range sentinel +// like 0001-01-01 crashes with RNQ0114 the moment it's assigned to +// one of these fields -- confirmed live in poentr's EEXPDT). ctl-opt dftactgrp(*no) actgrp(*new) datfmt(*iso); dcl-f pobrwd workstn sfile(bsfl:rrn) sfile(rmsgsfl:msgrrn); @@ -76,6 +78,7 @@ dcl-s selOpt char(1); dcl-s selPo int(20); dcl-s firstLine int(10); dcl-s cnt int(10); +dcl-s doneAll ind; // Cursor scalars. dcl-s cPo int(20); @@ -131,11 +134,12 @@ fbuy = ''; // with :*ISO in case a future ctl-opt change drops the datfmt override. ffrdt = %date('1940-01-01' : *ISO); ftodt = %date('2039-12-31' : *ISO); +doneAll = *off; // ----------------------------------------------------------------------- // Browse loop. // ----------------------------------------------------------------------- -dow '1'; +dow not doneAll; exsr loadPOs; if numRows = 0; @@ -158,6 +162,24 @@ dow '1'; leave; endif; + // PERP-89: blanking (or otherwise invalidating) either date filter + // produces a value outside the *MDY-safe 1940-2039 range, which then + // crashes with RNQ0114 the moment loadPOs' embedded SQL touches it + // (the SQL precompiler's own intermediate host variable for a date + // parameter is bound to the JOB's *MDY format regardless of this + // program's ctl-opt datfmt(*iso) override -- see the header comment + // and DDL_STYLE_GUIDE.md). %subdt is a plain RPG built-in, not an + // SQL host variable, so it's safe to test the *year* of whatever + // came back from the screen -- including an out-of-range value -- + // before it ever reaches loadPOs. Clamping back to the sentinel is + // exactly "blank means no filter on that side" per the ticket. + if %subdt(ffrdt : *years) < 1940 or %subdt(ffrdt : *years) > 2039; + ffrdt = %date('1940-01-01' : *ISO); + endif; + if %subdt(ftodt : *years) < 1940 or %subdt(ftodt : *years) > 2039; + ftodt = %date('2039-12-31' : *ISO); + endif; + exsr clearMsgs; // Handle selections (Opt 5 = detail, Opt 9 = schedule maintenance). @@ -183,6 +205,13 @@ dow '1'; select; when selOpt = '5'; exsr showDetail; + // PERP-96: F3 on the detail popup should exit the whole + // program like everywhere else, not just fall through to + // redisplaying the browse list (which is already correct + // for F12/Enter -- no change needed there). + if doneAll; + leave; + endif; when selOpt = '9'; // Find the first (lowest-numbered) line to hand to poschr. exec sql @@ -230,7 +259,7 @@ begsr loadPOs; if sqlcode < 0; writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode) + ' STATE=' + sqlstate); - return; + leavesr; endif; dow numRows < %elem(rows); @@ -290,7 +319,7 @@ begsr showDetail; if sqlcode <> 0; writeMsg('PO ' + %char(selPo) + ' lookup failed: SQLCODE=' + %char(sqlcode)); - return; + leavesr; endif; ddponbr = %char(selPo); @@ -357,6 +386,13 @@ begsr showDetail; endif; write rmsgctl; exfmt bdetail; + + // PERP-96: F3 here should exit the whole program (consistent with + // every other PERP screen), not just fall through and return to the + // browse list the way F12/Enter already correctly do. + if *in03; + doneAll = *on; + endif; endsr; // putLine -- ln, cItem, cOrd, cRcv, cOpen, cPrice, cSrcReq, cSrcLn diff --git a/perp/qrpglesrc/poentr.sqlrpgle b/perp/qrpglesrc/poentr.sqlrpgle index 3b10a62b..cdd88e92 100644 --- a/perp/qrpglesrc/poentr.sqlrpgle +++ b/perp/qrpglesrc/poentr.sqlrpgle @@ -17,11 +17,16 @@ // Epic: PERP-7 (PERP-38) // --------------------------------------------------------------------- -// datfmt(*iso) is REQUIRED (not decorative) -- eexpdt uses 0001-01-01 -// as its "no expected receipt date" sentinel, and the job DATFMT on -// this environment is *MDY (2-digit year, 1940-2039). Without this -// ctl-opt, RPG Date variables are capped at that range and any -// out-of-range value crashes at runtime with RNQ0114. +// eexpdt (PERP-92/PERP-78) uses 1940-01-01 as its "no expected receipt +// date" sentinel. This field is DATFMT(*MDY) on poentd.dspf (so the +// screen renders MM/DD/YY per PERP-78) -- that DDS-level format binds +// the underlying variable's valid year range to 1940-2039 REGARDLESS +// of this program's own datfmt(*iso) ctl-opt, which only governs Date +// variables NOT tied to a display-file field. An earlier attempt used +// 0001-01-01 as the sentinel and crashed with RNQ0114 the moment F6=Add +// assigned it to eexpdt -- confirmed live. 1940-01-01 is both a real, +// in-range *MDY date and obviously never a genuine business date, so +// it works as a sentinel without fighting the field's own DDS format. ctl-opt dftactgrp(*no) actgrp(*new) bnddir('PERP') datfmt(*iso); dcl-f poentd workstn sfile(plsfl:rrn) sfile(pmsgsfl:msgrrn); @@ -44,6 +49,18 @@ dcl-pr QMHSNDPM extpgm; errorCode char(8) const; end-pr; +// Standard, reusable Item/Vendor Number prompts (PERP-51/PERP-56/PERP-70). +// Same dynamic CALL idiom as wrkitmr's callWrkcnvr/callWrklotr. +dcl-pr callItmprmt extpgm('ITMPRMT'); + pCompcd char(3) const; + pItem varchar(25); +end-pr; + +dcl-pr callVndprmt extpgm('VNDPRMT'); + pCompcd char(3) const; + pVendor varchar(10); +end-pr; + dcl-ds statusDS psds qualified; programName char(10) pos(334); end-ds; @@ -76,6 +93,10 @@ dcl-s edefprice packed(15:4); dcl-s edesc varchar(60); dcl-s hbuyer char(10); dcl-s hvname varchar(60); +dcl-s promptItem varchar(25); +dcl-s promptVendor varchar(10); +dcl-s doneAll ind; +dcl-s holdMsg ind; in ldaDS; compcd = ldaDS.compcd; @@ -97,50 +118,72 @@ hcompdsp = compcd; // Header entry -- collect vendor / order_date / notes, validate, // snapshot buyer from vendor, allocate the doc number, insert the // DRAFT header. Currency is hard-coded to USD (see program header). +// Wrapped in an outer loop (PERP-93) so a successful F8=Submit on the +// line screen below returns here for the NEXT PO instead of leaving +// the user stranded on the now-read-only submitted line list -- same +// pattern as reqentr.sqlrpgle (PERP-86). // ----------------------------------------------------------------------- -hvndcd = ''; -hvndnm = ''; -hbuycd = ''; -horddt = %date(); -hnotes = ''; +doneAll = *off; + +dow not doneAll; + hvndcd = ''; + hvndnm = ''; + hbuycd = ''; + horddt = %date(); + hnotes = ''; + + // PERP-93: a submit confirmation queued just before restarting this + // loop must survive one pass before clearMsgs wipes it -- same + // holdMsg pattern as reqentr.sqlrpgle (PERP-86). + if holdMsg; + holdMsg = *off; + else; + exsr clearMsgs; + endif; -exsr clearMsgs; + dow '1'; + *in40 = *off; + if msgrrn > 0; + *in40 = *on; + endif; + write pmsgctl; + exfmt phead; -dow '1'; - *in40 = *off; - if msgrrn > 0; - *in40 = *on; - endif; - exfmt phead; + if *in03 or *in12; + *inlr = *on; + return; + endif; - if *in03 or *in12; - *inlr = *on; - return; - endif; + exsr clearMsgs; - exsr clearMsgs; + if %trim(hvndcd) = '?'; + promptVendor = hvndcd; + callVndprmt(compcd : promptVendor); + hvndcd = promptVendor; + iter; + endif; - if %trim(hvndcd) = ''; - writeMsg('Vendor Code is required.'); - iter; - endif; + if %trim(hvndcd) = ''; + writeMsg('Vendor Code is required.'); + iter; + endif; - exec sql - select vendor_name, buyer_code - into :hvname, :hbuyer - from perpdemo.vendor - where company_code = :compcd and vendor_code = :hvndcd - and is_active = 'Y'; - if sqlcode <> 0; - writeMsg('Vendor ' + %trim(hvndcd) + ' not found for this company.'); - iter; - endif; + exec sql + select vendor_name, buyer_code + into :hvname, :hbuyer + from perpdemo.vendor + where company_code = :compcd and vendor_code = :hvndcd + and is_active = 'Y'; + if sqlcode <> 0; + writeMsg('Vendor ' + %trim(hvndcd) + ' not found for this company.'); + iter; + endif; - hvndnm = hvname; - hbuycd = hbuyer; + hvndnm = hvname; + hbuycd = hbuyer; - leave; -enddo; + leave; + enddo; ponbr = docseq_next(compcd : 'PO' : docerrmsg); if ponbr = 0; @@ -192,9 +235,17 @@ dow '1'; write pmsgctl; exfmt plctl; - if *in03 or *in12; + // PERP-94: F3 exits the program; F12 must NOT -- it should just step + // back to (redisplay) this line list rather than ending the whole + // flow. The PO header is already committed at this point, so + // there's no earlier screen to unwind into. + if *in03; + doneAll = *on; leave; endif; + if *in12; + iter; + endif; exsr clearMsgs; @@ -223,7 +274,13 @@ dow '1'; writeMsg('Submit failed: SQLCODE=' + %char(sqlcode)); else; exec sql commit; + // PERP-93: return to a fresh header entry screen for the next + // PO instead of staying parked on this now read-only line + // list. holdMsg carries this confirmation through to the + // restarted header loop above. writeMsg('PO ' + %char(ponbr) + ' submitted (OPEN).'); + holdMsg = *on; + leave; endif; endif; iter; @@ -254,6 +311,7 @@ dow '1'; endif; endif; + enddo; enddo; *inlr = *on; @@ -284,7 +342,7 @@ begsr loadLines; exec sql open pc1; if sqlcode < 0; writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); - return; + leavesr; endif; dow numRows < %elem(rows); @@ -323,7 +381,7 @@ begsr handleOpt; if %found(poentd); if poStatus <> 'DRAFT'; writeMsg('PO already submitted - no further changes allowed.'); - return; + leavesr; endif; select; when selOpt = '2'; @@ -351,12 +409,21 @@ begsr addLine; // Sentinel "no expected receipt date". %date() with no format uses // the job DATFMT which on this environment is *MDY (year range // 1940-2039), so '0001' triggers RNQ0114. Force *ISO. - eexpdt = %date('0001-01-01' : *ISO); + eexpdt = %date('1940-01-01' : *ISO); dow '1'; exfmt pledit; if *in12; - return; + leavesr; + endif; + + // Item Number prompt (PERP-62): '?' + Enter invokes the standard + // reusable Item Number lookup (PERP-56) and returns the selection. + if %trim(eitem) = '?'; + promptItem = eitem; + callItmprmt(compcd : promptItem); + eitem = promptItem; + iter; endif; if %trim(eitem) = ''; @@ -410,7 +477,7 @@ begsr addLine; from perpdemo.po_line where company_code = :compcd and po_number = :ponbr; - if eexpdt = %date('0001-01-01' : *ISO); + if eexpdt = %date('1940-01-01' : *ISO); exec sql insert into perpdemo.po_line (company_code, po_number, line_number, item_number, @@ -455,14 +522,37 @@ begsr changeLine; eitmdsc = ''; endif; - exfmt pledit; - if *in12; - return; - endif; + dow '1'; + exfmt pledit; + if *in12; + leavesr; + endif; + + // Item Number prompt (PERP-62): '?' + Enter invokes the standard + // reusable Item Number lookup (PERP-56) and returns the selection. + if %trim(eitem) = '?'; + promptItem = eitem; + callItmprmt(compcd : promptItem); + eitem = promptItem; + exec sql + select item_description + into :edesc + from perpdemo.item + where company_code = :compcd and item_number = :eitem; + if sqlcode = 0; + eitmdsc = edesc; + else; + eitmdsc = ''; + endif; + iter; + endif; + + leave; + enddo; if eqty <= 0; writeMsg('Quantity must be greater than zero.'); - return; + leavesr; endif; exec sql diff --git a/perp/qrpglesrc/poprmt.sqlrpgle b/perp/qrpglesrc/poprmt.sqlrpgle new file mode 100644 index 00000000..f40c63f9 --- /dev/null +++ b/perp/qrpglesrc/poprmt.sqlrpgle @@ -0,0 +1,211 @@ +**free + +// --------------------------------------------------------------------- +// Program: poprmt (standard, reusable PO Number prompt/lookup) +// Purpose: PERP-98. Lists purchase orders still awaiting receipt +// (status_code OPEN or PARTIAL) for the calling company, +// with a Search box filtering on PO number or vendor +// code/name, case-insensitive. 1=Select on a row returns +// that po_number. F3/F12 cancel and return 0. +// po_number is a NUMERIC field (HPONBR on rcventd.dspf is +// 15Y 0), so this program does NOT use the "?" + Enter +// convention the item/vendor prompts use (a 5250 numeric +// input field rejects a literal "?" character at the device +// level, before RPG ever sees it) -- callers instead invoke +// this via a dedicated F4=Prompt key, the conventional IBM i +// UI idiom for a numeric-field lookup. +// Callers: rcventr (PERP-98). +// Epic: PERP-51 (PERP-98) +// --------------------------------------------------------------------- + +ctl-opt dftactgrp(*no) actgrp(*new); + +dcl-pi *n; + pCompcd char(3) const; + pPonbr packed(15:0); +end-pi; + +dcl-f poprmtd workstn sfile(ppsfl:rrn) sfile(ppmsgsfl:msgrrn); + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-ds statusDS psds qualified; + programName char(10) pos(334); +end-ds; + +dcl-ds poRow qualified; + ponbr int(20); + vndr varchar(10); + vndnm varchar(60); + stat varchar(20); +end-ds; + +dcl-ds rows likeds(poRow) dim(500); +dcl-s numRows int(10); +dcl-s i int(10); +dcl-s rrn int(10); +dcl-s msgrrn int(10); +dcl-s msgkey char(4); +dcl-s selRrn int(10); +dcl-s search varchar(30); + +search = ''; +ssearch = search; + +dow not *in03 and not *in12; + exsr clearMsgs; + exsr loadRows; + + if numRows = 0; + *in30 = *off; + write ppnone; + else; + exsr fillSubfile; + *in30 = *on; + endif; + + write ppfoot; + if msgrrn > 0; + *in40 = *on; + write ppmsgctl; + else; + *in40 = *off; + endif; + + exfmt ppctl; + + if *in03 or *in12; + pPonbr = 0; + leave; + endif; + + if *in05; + iter; + endif; + + if %trim(ssearch) <> search; + search = %trim(ssearch); + iter; + endif; + + // Guard on numRows: READC against a subfile that was never written + // to this cycle (0 rows loaded) raises a "Session or device error" + // (CPF5006-class) runtime error instead of just returning *EOF. + if numRows > 0; + selRrn = 0; + readc ppsfl; + dow not %eof(poprmtd); + if sopt = '1'; + if selRrn = 0; + selRrn = rrn; + else; + writeMsg('Only one PO may be selected per Enter.'); + endif; + elseif sopt <> ''; + writeMsg('Option ' + sopt + ' is not valid - use 1.'); + endif; + readc ppsfl; + enddo; + endif; + + if selRrn > 0 and msgrrn = 0; + chain selRrn ppsfl; + pPonbr = siponbr; + leave; + endif; + +enddo; + +*inlr = *on; +return; + +// --------------------------------------------------------------------- +begsr loadRows; + numRows = 0; + exec sql declare pp1 cursor for + select h.po_number, h.vendor_code, v.vendor_name, h.status_code + from perpdemo.po_header h + join perpdemo.vendor v + on v.company_code = h.company_code and v.vendor_code = h.vendor_code + where h.company_code = :pCompcd + and h.status_code in ('OPEN', 'PARTIAL') + and (:search = '' + or char(h.po_number) like '%' || :search || '%' + or upper(v.vendor_code) like '%' || upper(:search) || '%' + or upper(v.vendor_name) like '%' || upper(:search) || '%') + order by h.po_number desc; + exec sql open pp1; + if sqlcode < 0; + writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); + leavesr; + endif; + + dow numRows < %elem(rows); + exec sql fetch pp1 into :poRow; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + numRows += 1; + rows(numRows) = poRow; + enddo; + exec sql close pp1; +endsr; + +// --------------------------------------------------------------------- +begsr fillSubfile; + rrn = 0; + *in31 = *on; + write ppctl; + *in31 = *off; + for i = 1 to numRows; + *in50 = *off; + *in51 = *off; + sopt = ''; + siponbr = rows(i).ponbr; + sivndr = rows(i).vndr; + sivndnm = rows(i).vndnm; + sistat = rows(i).stat; + rrn += 1; + write ppsfl; + endfor; +endsr; + +// --------------------------------------------------------------------- +begsr clearMsgs; + msgrrn = 0; + *in41 = *on; + write ppmsgctl; + *in41 = *off; +endsr; + +// --------------------------------------------------------------------- +dcl-proc writeMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + smsgkey : + x'0000000000000000'); + msgrrn += 1; + spgmq = statusDS.programName; + write ppmsgsfl; +end-proc; diff --git a/perp/qrpglesrc/poreqr.sqlrpgle b/perp/qrpglesrc/poreqr.sqlrpgle index e21387af..a9b921a9 100644 --- a/perp/qrpglesrc/poreqr.sqlrpgle +++ b/perp/qrpglesrc/poreqr.sqlrpgle @@ -195,6 +195,12 @@ dow '1'; endif; if *in06; + // *in06 is a response indicator: the workstation turns it on when + // F6 is pressed but never turns it off on its own, so it must be + // cleared here or it stays "stuck on" and every later Enter/F5/F12 + // press on this screen is misread as another F6 (PERP-97 follow-up + // bug found during live testing -- distinct from the DDS overflow). + *in06 = *off; if selCnt = 0; writeMsg('Select at least one requisition (option 1) before F6.'); iter; @@ -215,6 +221,8 @@ dow '1'; exsr showPreview; if *in06; + // Same stuck-indicator concern as above -- clear it once consumed. + *in06 = *off; // Confirmed -- create the POs. exsr createPOs; // After creation, refresh the list (converted lines drop out @@ -287,7 +295,7 @@ begsr loadReqs; if sqlcode < 0; writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode) + ' STATE=' + sqlstate); - return; + leavesr; endif; dow numReqs < %elem(reqs); @@ -376,7 +384,7 @@ begsr buildPlan; exec sql open rc2; if sqlcode < 0; writeMsg('buildPlan open failed: SQLCODE=' + %char(sqlcode)); - return; + leavesr; endif; dow '1'; @@ -530,14 +538,14 @@ begsr createPOs; writeMsg('Vendor ' + %trim(xVndCd) + ' lookup failed: SQLCODE=' + %char(sqlcode)); exec sql rollback; - return; + leavesr; endif; newPo = docseq_next(compcd : 'PO' : docerrmsg); if newPo = 0; writeMsg('docseq_next failed: ' + docerrmsg); exec sql rollback; - return; + leavesr; endif; exec sql @@ -550,7 +558,7 @@ begsr createPOs; writeMsg('po_header insert failed: SQLCODE=' + %char(sqlcode) + ' STATE=' + sqlstate); exec sql rollback; - return; + leavesr; endif; lineNbr = 0; @@ -575,7 +583,7 @@ begsr createPOs; + %trim(plan(v).vndcd) + ': SQLCODE=' + %char(sqlcode) + ' STATE=' + sqlstate); exec sql rollback; - return; + leavesr; endif; endfor; diff --git a/perp/qrpglesrc/poschr.sqlrpgle b/perp/qrpglesrc/poschr.sqlrpgle index 0adedbd5..0c5be6df 100644 --- a/perp/qrpglesrc/poschr.sqlrpgle +++ b/perp/qrpglesrc/poschr.sqlrpgle @@ -75,6 +75,7 @@ dcl-s nextSeq int(10); dcl-s selOpt char(1); dcl-s cnt int(10); dcl-s parmed ind; +dcl-s calledWithParms ind; // po_line context for the header. dcl-s itemNbr varchar(25); dcl-s vndCd varchar(10); @@ -123,6 +124,7 @@ dow '1'; if msgrrn > 0; *in40 = *on; endif; + write hmsgctl; exfmt hhead; if *in03 or *in12; @@ -179,6 +181,15 @@ dow '1'; leave; enddo; +// PERP-95: remember whether this invocation ever showed the header +// entry screen (hhead). parmed is only ever cleared inside the loop +// above, never re-set once cleared, so its value here tells us +// whether hhead was skipped entirely (called with valid parms from +// PO Browse -- no earlier screen to step back to) or was displayed +// at least once (standalone menu invocation -- there IS an earlier +// screen conceptually behind the schedule list). +calledWithParms = parmed; + // ----------------------------------------------------------------------- // Schedule maintenance loop. // ----------------------------------------------------------------------- @@ -215,9 +226,21 @@ dow '1'; write hmsgctl; exfmt hsctl; - if *in03 or *in12; + // PERP-95: F3 always exits. F12 exits only when this invocation was + // called with parms from PO Browse (no header screen was shown, so + // F12 correctly returns control to that caller). When invoked + // standalone from the menu, the header screen (hhead) was shown + // first, so F12 here should just redisplay this list, not end the + // program. + if *in03; leave; endif; + if *in12; + if calledWithParms; + leave; + endif; + iter; + endif; exsr clearMsgs; @@ -270,7 +293,7 @@ begsr loadSched; exec sql open sc1; if sqlcode < 0; writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); - return; + leavesr; endif; dow numRows < %elem(rows); @@ -345,7 +368,7 @@ begsr addSched; dow '1'; exfmt hedit; if *in12; - return; + leavesr; endif; if eschqty <= 0; @@ -383,7 +406,7 @@ begsr addSched; if sqlcode < 0; writeMsg('Add failed: SQLCODE=' + %char(sqlcode) + ' STATE=' + sqlstate); - return; + leavesr; endif; exec sql commit; @@ -403,17 +426,17 @@ begsr changeSched; exfmt hedit; if *in12; - return; + leavesr; endif; if eschqty <= 0; writeMsg('Scheduled Qty must be greater than zero.'); - return; + leavesr; endif; if ercvqty < 0 or ercvqty > eschqty; writeMsg('Received Qty must be between 0 and Scheduled Qty.'); - return; + leavesr; endif; exec sql @@ -430,7 +453,7 @@ begsr changeSched; and schedule_seq = :chgSeq; if sqlcode < 0; writeMsg('Change failed: SQLCODE=' + %char(sqlcode)); - return; + leavesr; endif; exec sql commit; @@ -447,7 +470,7 @@ begsr deleteSched; and schedule_seq = :slseq; if sqlcode < 0; writeMsg('Delete failed: SQLSTATE=' + sqlstate); - return; + leavesr; endif; exec sql commit; writeMsg('Deleted schedule seq ' + %char(slseq) + '.'); diff --git a/perp/qrpglesrc/rcventr.sqlrpgle b/perp/qrpglesrc/rcventr.sqlrpgle index dd16a866..ba31437c 100644 --- a/perp/qrpglesrc/rcventr.sqlrpgle +++ b/perp/qrpglesrc/rcventr.sqlrpgle @@ -49,6 +49,14 @@ dcl-pr QMHSNDPM extpgm; errorCode char(8) const; end-pr; +// Standard, reusable PO Number prompt (PERP-51/PERP-98). Numeric field, +// so invoked via F4=Prompt rather than the "?" convention item/vendor +// prompts use. Same dynamic CALL idiom as wrkitmr's callWrkcnvr etc. +dcl-pr callPoprmt extpgm('POPRMT'); + pCompcd char(3) const; + pPonbr packed(15:0); +end-pr; + dcl-ds statusDS psds qualified; programName char(10) pos(334); end-ds; @@ -79,6 +87,7 @@ dcl-s convFactor packed(15:6); dcl-s qtyInv packed(15:4); dcl-s nextRLine int(10); dcl-s newHdrStat varchar(20); +dcl-s promptPonbr packed(15:0); in ldaDS; compcd = ldaDS.compcd; @@ -122,6 +131,17 @@ dow '1'; exsr clearMsgs; + // PO Number prompt (PERP-98): F4 invokes the standard reusable PO + // Number lookup (lists POs still awaiting receipt) and returns the + // selection. HPONBR is numeric, so this uses F4=Prompt rather than + // the "?" + Enter convention item/vendor fields use. + if *in04; + promptPonbr = hponbr; + callPoprmt(compcd : promptPonbr); + hponbr = promptPonbr; + iter; + endif; + if hponbr <= 0; writeMsg('PO Number is required.'); iter; @@ -288,7 +308,7 @@ begsr loadOpenLines; exec sql open rc1; if sqlcode < 0; writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); - return; + leavesr; endif; dow numRows < %elem(rows); @@ -351,7 +371,7 @@ begsr receiveLine; write rmsgctl; exfmt rledit; if *in12; - return; + leavesr; endif; exsr clearMsgs; @@ -386,7 +406,7 @@ begsr receiveLine; if sqlcode <> 0; writeMsg('No UOM conversion from ' + %trim(euom) + ' to ' + %trim(invuom) + ' defined for this item.'); - return; + leavesr; endif; endif; @@ -419,7 +439,7 @@ begsr receiveLine; if sqlcode < 0; writeMsg('Receipt line insert failed: SQLCODE=' + %char(sqlcode) + ' SQLSTATE=' + sqlstate); - return; + leavesr; endif; if elotctl = 'Y'; @@ -452,7 +472,7 @@ begsr receiveLine; and line_number = :eline; if sqlcode < 0; writeMsg('po_line update failed: SQLCODE=' + %char(sqlcode)); - return; + leavesr; endif; exec sql diff --git a/perp/qrpglesrc/reqaprr.sqlrpgle b/perp/qrpglesrc/reqaprr.sqlrpgle index bbc353e4..20e56eed 100644 --- a/perp/qrpglesrc/reqaprr.sqlrpgle +++ b/perp/qrpglesrc/reqaprr.sqlrpgle @@ -114,6 +114,7 @@ dcl-s compcd char(3); dcl-s selReqnbr int(20); dcl-s confPct packed(5:2); dcl-s confInd int(5); +dcl-s holdMsg ind; in ldaDS; compcd = ldaDS.compcd; @@ -133,7 +134,15 @@ endif; lcompdsp = compcd; dow '1'; - exsr clearMsgs; + // PERP-87: a confirmation queued by reviewReq's Approve/Reject just + // before returning here must survive one pass before clearMsgs + // wipes it, or it never reaches the screen -- same holdMsg pattern + // as PERP-74/PERP-86. + if holdMsg; + holdMsg = *off; + else; + exsr clearMsgs; + endif; exsr loadReqs; if numReqs = 0; @@ -176,10 +185,15 @@ dow '1'; if reviewRrn = 0; reviewRrn = selRrn; else; + // Queued mid-readc, before this pass's own exfmt already + // happened -- must survive one more full loop pass before + // clearMsgs wipes it, or it never reaches the screen. writeMsg('Only one requisition may be reviewed per Enter.'); + holdMsg = *on; endif; else; writeMsg('Option ' + selOpt + ' not valid - use 5.'); + holdMsg = *on; endif; selRrn = 0; endif; @@ -209,7 +223,7 @@ begsr loadReqs; exec sql open c1; if sqlcode < 0; writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); - return; + leavesr; endif; dow numReqs < %elem(reqs); @@ -263,7 +277,14 @@ begsr reviewReq; exsr fillDetailLines; dow '1'; - exsr clearMsgs; + // PERP-87: same holdMsg pattern as the outer list loop -- an + // Approve/Reject SQL-failure message queued below must survive + // one pass before being wiped by clearMsgs. + if holdMsg; + holdMsg = *off; + else; + exsr clearMsgs; + endif; if msgrrn > 0; *in40 = *on; else; @@ -272,8 +293,20 @@ begsr reviewReq; write rmsgctl; exfmt rdetail; + // PERP-87: response indicators are program-level, not + // format-level -- RPG does not automatically turn them back off + // between EXFMTs to different record formats sharing this device + // file. Leaving *in06/*in07/*in12 ON here would make the OUTER + // list loop's own "if *in03 or *in12" check (evaluated right + // after its NEXT exfmt asctl, before the user has pressed + // anything on that screen) fire immediately, ending the whole + // program and looking exactly like "F6/F7/F12 kick back to the + // menu" -- reset all three explicitly on every path out of here. if *in12; - return; + *in06 = *off; + *in07 = *off; + *in12 = *off; + leavesr; endif; if *in06; @@ -288,12 +321,17 @@ begsr reviewReq; updated_at = current_timestamp, updated_by = user where company_code = :compcd and requisition_number = :selReqnbr; + *in06 = *off; if sqlcode < 0; writeMsg('Approve failed: SQLCODE=' + %char(sqlcode)); + holdMsg = *on; iter; endif; writeMsg('Requisition ' + %trim(ddreqnbr) + ' approved.'); - return; + holdMsg = *on; + *in07 = *off; + *in12 = *off; + leavesr; endif; if *in07; @@ -308,12 +346,17 @@ begsr reviewReq; updated_at = current_timestamp, updated_by = user where company_code = :compcd and requisition_number = :selReqnbr; + *in07 = *off; if sqlcode < 0; writeMsg('Reject failed: SQLCODE=' + %char(sqlcode)); + holdMsg = *on; iter; endif; writeMsg('Requisition ' + %trim(ddreqnbr) + ' rejected.'); - return; + holdMsg = *on; + *in06 = *off; + *in12 = *off; + leavesr; endif; iter; @@ -331,7 +374,7 @@ begsr loadLines2; exec sql open c2; if sqlcode < 0; writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); - return; + leavesr; endif; dow numLines < %elem(detailLines); diff --git a/perp/qrpglesrc/reqentr.sqlrpgle b/perp/qrpglesrc/reqentr.sqlrpgle index 6929a06e..68f19b8c 100644 --- a/perp/qrpglesrc/reqentr.sqlrpgle +++ b/perp/qrpglesrc/reqentr.sqlrpgle @@ -36,6 +36,13 @@ dcl-pr QMHSNDPM extpgm; errorCode char(8) const; end-pr; +// Standard, reusable Item Number prompt (PERP-51/PERP-56). Same dynamic +// CALL idiom as wrkitmr's callWrkcnvr/callWrklotr. +dcl-pr callItmprmt extpgm('ITMPRMT'); + pCompcd char(3) const; + pItem varchar(25); +end-pr; + dcl-ds statusDS psds qualified; programName char(10) pos(334); end-ds; @@ -66,6 +73,9 @@ dcl-s cnt int(10); dcl-s edefuom varchar(5); dcl-s edefcost packed(15:4); dcl-s edesc varchar(60); +dcl-s promptItem varchar(25); +dcl-s doneAll ind; +dcl-s holdMsg ind; in ldaDS; compcd = ldaDS.compcd; @@ -85,20 +95,48 @@ hcompdsp = compcd; // ----------------------------------------------------------------------- // Header entry -- collect requested_by/need_by/priority/notes, validate, -// allocate the doc number, insert the DRAFT header. +// allocate the doc number, insert the DRAFT header. Wrapped in an outer +// loop (PERP-86) so a successful F8=Submit on the line screen below +// returns here for the NEXT requisition instead of leaving the user +// stranded on the now-read-only submitted line list. // ----------------------------------------------------------------------- -hreqby = ''; -hneedby = %date() + %days(7); -hpricd = 'NORMAL'; -hnotes = ''; - -exsr clearMsgs; +doneAll = *off; + +dow not doneAll; + // PERP-76: default Requested By to the current job user, but only when + // that job user is actually a known perp_user -- an interactive/SSH job + // user (e.g. AIDEMO) will almost never be one, and pre-filling with a + // value that then fails the "not found" check below just traded a blank + // required field for a confusing default the human has to notice and + // overwrite anyway. Leaving it blank keeps the existing, already-clear + // "Requested By is required" prompt as the fallback. + exec sql values(user) into :hreqby; + exec sql + select count(*) into :cnt + from perpdemo.perp_user + where user_code = :hreqby; + if cnt = 0; + hreqby = ''; + endif; + hneedby = %date() + %days(7); + hpricd = 'NORMAL'; + hnotes = ''; + + // PERP-86: a submit confirmation queued just before restarting this + // loop must survive one pass before clearMsgs wipes it -- same + // holdMsg pattern as PERP-74/PERP-87. + if holdMsg; + holdMsg = *off; + else; + exsr clearMsgs; + endif; -dow '1'; + dow '1'; *in40 = *off; if msgrrn > 0; *in40 = *on; endif; + write rmsgctl; exfmt rhead; if *in03 or *in12; @@ -183,9 +221,17 @@ dow '1'; write rmsgctl; exfmt rlctl; - if *in03 or *in12; + // PERP-85: F3 exits the program; F12 must NOT -- it should just step + // back to (redisplay) this line list rather than ending the whole + // flow. The requisition header is already committed at this point, + // so there's no earlier screen to unwind into. + if *in03; + doneAll = *on; leave; endif; + if *in12; + iter; + endif; exsr clearMsgs; @@ -213,7 +259,13 @@ dow '1'; if sqlcode < 0; writeMsg('Submit failed: SQLCODE=' + %char(sqlcode)); else; + // PERP-86: return to a fresh header entry screen for the next + // requisition instead of staying parked on this now read-only + // line list. holdMsg carries this confirmation through to the + // restarted header loop above. writeMsg('Requisition ' + %char(reqnbr) + ' submitted.'); + holdMsg = *on; + leave; endif; endif; iter; @@ -249,6 +301,7 @@ dow '1'; endif; endif; + enddo; enddo; *inlr = *on; @@ -277,7 +330,7 @@ begsr loadLines; exec sql open c1; if sqlcode < 0; writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); - return; + leavesr; endif; dow numRows < %elem(rows); @@ -316,7 +369,7 @@ begsr handleOpt; if %found(reqentd); if reqStatus <> 'DRAFT'; writeMsg('Requisition already submitted - no further changes allowed.'); - return; + leavesr; endif; select; when selOpt = '2'; @@ -344,7 +397,16 @@ begsr addLine; dow '1'; exfmt rledit; if *in12; - return; + leavesr; + endif; + + // Item Number prompt (PERP-61): '?' + Enter invokes the standard + // reusable Item Number lookup (PERP-56) and returns the selection. + if %trim(eitem) = '?'; + promptItem = eitem; + callItmprmt(compcd : promptItem); + eitem = promptItem; + iter; endif; if %trim(eitem) = ''; @@ -428,14 +490,27 @@ begsr changeLine; euom = rows(selRrn).uom; ecost = rows(selRrn).cost; - exfmt rledit; - if *in12; - return; - endif; + dow '1'; + exfmt rledit; + if *in12; + leavesr; + endif; + + // Item Number prompt (PERP-61): '?' + Enter invokes the standard + // reusable Item Number lookup (PERP-56) and returns the selection. + if %trim(eitem) = '?'; + promptItem = eitem; + callItmprmt(compcd : promptItem); + eitem = promptItem; + iter; + endif; + + leave; + enddo; if eqty <= 0; writeMsg('Quantity must be greater than zero.'); - return; + leavesr; endif; exec sql diff --git a/perp/qrpglesrc/vndprmt.sqlrpgle b/perp/qrpglesrc/vndprmt.sqlrpgle new file mode 100644 index 00000000..7fa7e0f1 --- /dev/null +++ b/perp/qrpglesrc/vndprmt.sqlrpgle @@ -0,0 +1,204 @@ +**free + +// --------------------------------------------------------------------- +// Program: vndprmt (standard, reusable Vendor Number prompt/lookup) +// Purpose: Companion to itmprmt (PERP-56). System-wide "?" + Enter +// lookup for any keyable Vendor field. Same calling +// convention: caller CALLs this program passing the company +// code and the field's current value; '?' (or blank) lists +// all vendors, any other seed pre-fills the Search field. +// Subfile lists vendor_code + vendor_name, filtered +// case-insensitively on either column; 1=Select on a row +// returns that vendor_code. F3/F12 cancel and return the +// field blank. Called via a plain dynamic CALL (EXTPGM +// prototype declared in each caller), same idiom as itmprmt. +// Callers: wrkivnr (PERP-71). +// Epic: PERP-51 (PERP-70) +// --------------------------------------------------------------------- + +ctl-opt dftactgrp(*no) actgrp(*new); + +dcl-pi *n; + pCompcd char(3) const; + pVendor varchar(10); +end-pi; + +dcl-f vndprmtd workstn sfile(vpsfl:rrn) sfile(vpmsgsfl:msgrrn); + +dcl-pr QMHSNDPM extpgm; + msgId char(7) const; + msgF char(20) const; + msgData char(256) const; + msgDataLen int(10) const; + msgType char(10) const; + stackEntry char(10) const; + stackCntr int(10) const; + msgKey char(4); + errorCode char(8) const; +end-pr; + +dcl-ds statusDS psds qualified; + programName char(10) pos(334); +end-ds; + +dcl-ds vendorRow qualified; + vendor varchar(10); + name varchar(60); +end-ds; + +dcl-ds rows likeds(vendorRow) dim(500); +dcl-s numRows int(10); +dcl-s i int(10); +dcl-s rrn int(10); +dcl-s msgrrn int(10); +dcl-s msgkey char(4); +dcl-s selRrn int(10); +dcl-s search varchar(30); + +search = %trim(pVendor); +if search = '?'; + search = ''; +endif; +ssearch = search; + +dow not *in03 and not *in12; + exsr clearMsgs; + exsr loadRows; + + if numRows = 0; + *in30 = *off; + write vpnone; + else; + exsr fillSubfile; + *in30 = *on; + endif; + + write vpfoot; + if msgrrn > 0; + *in40 = *on; + write vpmsgctl; + else; + *in40 = *off; + endif; + + exfmt vpctl; + + if *in03 or *in12; + pVendor = ''; + leave; + endif; + + if *in05; + iter; + endif; + + if ssearch <> search; + search = %trim(ssearch); + iter; + endif; + + // Guard on numRows: READC against a subfile that was never written + // to this cycle (0 rows loaded) raises a "Session or device error" + // (CPF5006-class) runtime error instead of just returning *EOF. + if numRows > 0; + selRrn = 0; + readc vpsfl; + dow not %eof(vndprmtd); + if sopt = '1'; + if selRrn = 0; + selRrn = rrn; + else; + writeMsg('Only one vendor may be selected per Enter.'); + endif; + elseif sopt <> ''; + writeMsg('Option ' + sopt + ' is not valid - use 1.'); + endif; + readc vpsfl; + enddo; + endif; + + if selRrn > 0 and msgrrn = 0; + chain selRrn vpsfl; + pVendor = sivendor; + leave; + endif; + +enddo; + +*inlr = *on; +return; + +// --------------------------------------------------------------------- +begsr loadRows; + numRows = 0; + exec sql declare vp1 cursor for + select vendor_code, vendor_name + from perpdemo.vendor + where company_code = :pCompcd + and (:search = '' + or upper(vendor_code) like '%' || upper(:search) || '%' + or upper(vendor_name) like '%' || upper(:search) || '%') + order by vendor_code; + exec sql open vp1; + if sqlcode < 0; + writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); + leavesr; + endif; + + dow numRows < %elem(rows); + exec sql fetch vp1 into :vendorRow; + if sqlcode = 100 or sqlcode < 0; + leave; + endif; + numRows += 1; + rows(numRows) = vendorRow; + enddo; + exec sql close vp1; +endsr; + +// --------------------------------------------------------------------- +begsr fillSubfile; + rrn = 0; + *in31 = *on; + write vpctl; + *in31 = *off; + for i = 1 to numRows; + *in50 = *off; + *in51 = *off; + sopt = ''; + sivendor = rows(i).vendor; + sivname = rows(i).name; + rrn += 1; + write vpsfl; + endfor; +endsr; + +// --------------------------------------------------------------------- +begsr clearMsgs; + msgrrn = 0; + *in41 = *on; + write vpmsgctl; + *in41 = *off; +endsr; + +// --------------------------------------------------------------------- +dcl-proc writeMsg; + dcl-pi *n; + text varchar(256) const; + end-pi; + dcl-s data char(256); + data = text; + QMHSNDPM( + 'CPF9897' : + 'QCPFMSG QSYS ' : + data : + %len(text) : + '*INFO ' : + '* ' : + 1 : + smsgkey : + x'0000000000000000'); + msgrrn += 1; + spgmq = statusDS.programName; + write vpmsgsfl; +end-proc; diff --git a/perp/qrpglesrc/wlmr.sqlrpgle b/perp/qrpglesrc/wlmr.sqlrpgle index 360afb19..b0b31fa4 100644 --- a/perp/qrpglesrc/wlmr.sqlrpgle +++ b/perp/qrpglesrc/wlmr.sqlrpgle @@ -38,6 +38,7 @@ end-ds; dcl-s compcd char(3); dcl-s exists ind; dcl-s msgrrn int(10); +dcl-s holdMsg ind; in ldaDS; compcd = ldaDS.compcd; @@ -61,7 +62,17 @@ dow not *in03 and not *in12; leave; endif; - exsr clearMsgs; + // A message queued by an action handler below (F6=Add) must survive + // one full loop pass before being cleared, or it never reaches the + // screen -- clearMsgs wipes msgrrn back to 0 on the very next pass, + // before this pass's own exfmt ever shows it. holdMsg skips exactly + // one clearMsgs call right after such a message was queued. Same + // pattern as wrkivpr (PERP-74). + if holdMsg; + holdMsg = *off; + else; + exsr clearMsgs; + endif; exsr loadRow; write wlfoot; @@ -132,7 +143,8 @@ begsr addRow; if exists; writeMsg('Row already exists for company ' + %trim(compcd) + ' - press Enter to save changes.'); - return; + holdMsg = *on; + leavesr; endif; exec sql diff --git a/perp/qrpglesrc/wrkcnvr.sqlrpgle b/perp/qrpglesrc/wrkcnvr.sqlrpgle index 317f563d..c0976efc 100644 --- a/perp/qrpglesrc/wrkcnvr.sqlrpgle +++ b/perp/qrpglesrc/wrkcnvr.sqlrpgle @@ -37,6 +37,13 @@ dcl-pr QMHSNDPM extpgm; errorCode char(8) const; end-pr; +// Standard, reusable Item Number prompt (PERP-51/PERP-56). Same dynamic +// CALL idiom as wrkitmr's callWrkcnvr/callWrklotr. +dcl-pr callItmprmt extpgm('ITMPRMT'); + pCompcd char(3) const; + pItem varchar(25); +end-pr; + dcl-ds statusDS psds qualified; programName char(10) pos(334); end-ds; @@ -58,6 +65,8 @@ dcl-s selRrn int(10); dcl-s selOpt char(1); dcl-s filter varchar(25); dcl-s compcd char(3); +dcl-s promptItem varchar(25); +dcl-s holdMsg ind; in ldaDS; compcd = ldaDS.compcd; @@ -93,7 +102,17 @@ dow not *in03 and not *in12; leave; endif; - exsr clearMsgs; + // A message queued by an action handler below (2=Change, etc.) must + // survive one full loop pass before being cleared, or it never + // reaches the screen -- clearMsgs wipes msgrrn back to 0 on the very + // next pass, before this pass's own exfmt ever shows it. holdMsg + // skips exactly one clearMsgs call right after such a message was + // queued. Same pattern as wrkivpr (PERP-74). + if holdMsg; + holdMsg = *off; + else; + exsr clearMsgs; + endif; if filter = ''; *in30 = *off; @@ -138,6 +157,16 @@ dow not *in03 and not *in12; iter; endif; + // Item Number prompt (PERP-54): '?' + Enter invokes the standard + // reusable Item Number lookup (PERP-56) and returns the selection. + if %trim(sfitem) = '?'; + promptItem = sfitem; + callItmprmt(compcd : promptItem); + sfitem = promptItem; + filter = promptItem; + iter; + endif; + // Refresh scope from screen entry if sfitem <> filter; filter = sfitem; @@ -179,7 +208,7 @@ begsr loadRows; exec sql open c1; if sqlcode < 0; writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); - return; + leavesr; endif; dow numRows < %elem(rows); @@ -261,7 +290,8 @@ begsr changeRow; and from_uom = :efrom and to_uom = :eto; if sqlcode <> 0; writeMsg('Row disappeared before change.'); - return; + holdMsg = *on; + leavesr; endif; exsr editLoop; if not *in12; diff --git a/perp/qrpglesrc/wrkiclr.sqlrpgle b/perp/qrpglesrc/wrkiclr.sqlrpgle index 7fdb1231..e6201688 100644 --- a/perp/qrpglesrc/wrkiclr.sqlrpgle +++ b/perp/qrpglesrc/wrkiclr.sqlrpgle @@ -50,6 +50,7 @@ dcl-s msgkey char(4); dcl-s selRrn int(10); dcl-s selOpt char(1); dcl-s compcd char(3); +dcl-s holdMsg ind; in ldaDS; compcd = ldaDS.compcd; @@ -75,7 +76,17 @@ dow not *in03 and not *in12; leave; endif; - exsr clearMsgs; + // A message queued by an action handler below (2=Change, etc.) must + // survive one full loop pass before being cleared, or it never + // reaches the screen -- clearMsgs wipes msgrrn back to 0 on the very + // next pass, before this pass's own exfmt ever shows it. holdMsg + // skips exactly one clearMsgs call right after such a message was + // queued. Same pattern as wrkivpr (PERP-74). + if holdMsg; + holdMsg = *off; + else; + exsr clearMsgs; + endif; exsr loadRows; if numRows = 0; @@ -143,7 +154,7 @@ begsr loadRows; exec sql open c1; if sqlcode < 0; writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); - return; + leavesr; endif; dow numRows < %elem(rows); @@ -222,7 +233,8 @@ begsr changeRow; where company_code = :compcd and class_code = :eclass; if sqlcode <> 0; writeMsg('Row disappeared before change.'); - return; + holdMsg = *on; + leavesr; endif; exsr editLoop; if not *in12; diff --git a/perp/qrpglesrc/wrkitmr.sqlrpgle b/perp/qrpglesrc/wrkitmr.sqlrpgle index 3c2e000c..d312dd74 100644 --- a/perp/qrpglesrc/wrkitmr.sqlrpgle +++ b/perp/qrpglesrc/wrkitmr.sqlrpgle @@ -45,6 +45,13 @@ dcl-pr callWrklotr extpgm('WRKLOTR'); pItem varchar(25) const; end-pr; +// Standard, reusable Item Number prompt (PERP-51/PERP-56). Same dynamic +// CALL idiom as callWrkcnvr/callWrklotr above. +dcl-pr callItmprmt extpgm('ITMPRMT'); + pCompcd char(3) const; + pItem varchar(25); +end-pr; + dcl-ds statusDS psds qualified; programName char(10) pos(334); end-ds; @@ -70,6 +77,9 @@ dcl-s compcd char(3); dcl-s fClass varchar(10); dcl-s fActOnly char(1); dcl-s fLowOnly char(1); +dcl-s fPosTo varchar(30); +dcl-s promptItem varchar(25); +dcl-s holdMsg ind; in ldaDS; compcd = ldaDS.compcd; @@ -77,9 +87,11 @@ scompdsp = compcd; fClass = ''; fActOnly = 'N'; fLowOnly = 'N'; +fPosTo = ''; sfclass = ''; sfact = 'N'; sflow = 'N'; +sposto = ''; if compcd = ''; exsr clearMsgs; @@ -101,7 +113,17 @@ dow not *in03 and not *in12; leave; endif; - exsr clearMsgs; + // A message queued by an action handler below (2=Change, etc.) must + // survive one full loop pass before being cleared, or it never + // reaches the screen -- clearMsgs wipes msgrrn back to 0 on the very + // next pass, before this pass's own exfmt ever shows it. holdMsg + // skips exactly one clearMsgs call right after such a message was + // queued. Same pattern as wrkivpr (PERP-74). + if holdMsg; + holdMsg = *off; + else; + exsr clearMsgs; + endif; exsr loadRows; if numRows = 0; @@ -129,6 +151,7 @@ dow not *in03 and not *in12; fClass = sfclass; fActOnly = sfact; fLowOnly = sflow; + fPosTo = %trim(sposto); iter; endif; @@ -138,10 +161,12 @@ dow not *in03 and not *in12; endif; // Refresh filters from screen entry - if sfclass <> fClass or sfact <> fActOnly or sflow <> fLowOnly; + if sfclass <> fClass or sfact <> fActOnly or sflow <> fLowOnly + or sposto <> fPosTo; fClass = sfclass; fActOnly = sfact; fLowOnly = sflow; + fPosTo = %trim(sposto); iter; endif; @@ -180,11 +205,14 @@ begsr loadRows; and (:fClass = '' or class_code = :fClass) and (:fActOnly = 'N' or is_active = 'Y') and (:fLowOnly = 'N' or qty_on_hand <= reorder_point) + and (:fPosTo = '' + or upper(item_number) like upper(:fPosTo) || '%' + or upper(item_description) like '%' || upper(:fPosTo) || '%') order by item_number; exec sql open c1; if sqlcode < 0; writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); - return; + leavesr; endif; dow numRows < %elem(rows); @@ -306,7 +334,8 @@ begsr changeRow; where company_code = :compcd and item_number = :eitem; if sqlcode <> 0; writeMsg('Row disappeared before change.'); - return; + holdMsg = *on; + leavesr; endif; exsr editLoop; if not *in12; @@ -372,7 +401,19 @@ endsr; // --------------------------------------------------------------------- begsr editLoop; - exfmt wiedit; + dow not *in12; + exfmt wiedit; + if *in12; + leave; + endif; + if %trim(eitem) = '?'; + promptItem = eitem; + callItmprmt(compcd : promptItem); + eitem = promptItem; + iter; + endif; + leave; + enddo; endsr; // --------------------------------------------------------------------- diff --git a/perp/qrpglesrc/wrkivnr.sqlrpgle b/perp/qrpglesrc/wrkivnr.sqlrpgle index 55fbc120..a6f86b53 100644 --- a/perp/qrpglesrc/wrkivnr.sqlrpgle +++ b/perp/qrpglesrc/wrkivnr.sqlrpgle @@ -33,6 +33,18 @@ dcl-pr QMHSNDPM extpgm; errorCode char(8) const; end-pr; +// Standard, reusable Item/Vendor Number prompts (PERP-51/PERP-56/PERP-70). +// Same dynamic CALL idiom as wrkitmr's callWrkcnvr/callWrklotr. +dcl-pr callItmprmt extpgm('ITMPRMT'); + pCompcd char(3) const; + pItem varchar(25); +end-pr; + +dcl-pr callVndprmt extpgm('VNDPRMT'); + pCompcd char(3) const; + pVendor varchar(10); +end-pr; + dcl-ds statusDS psds qualified; programName char(10) pos(334); end-ds; @@ -58,6 +70,9 @@ dcl-s selOpt char(1); dcl-s compcd char(3); dcl-s fItem varchar(25); dcl-s fVendor varchar(10); +dcl-s promptItem varchar(25); +dcl-s promptVendor varchar(10); +dcl-s holdMsg ind; in ldaDS; compcd = ldaDS.compcd; @@ -87,7 +102,17 @@ dow not *in03 and not *in12; leave; endif; - exsr clearMsgs; + // A message queued by an action handler below (F6=Add, 2=Change, + // etc.) must survive one full loop pass before being cleared, or it + // never reaches the screen -- clearMsgs wipes msgrrn back to 0 on + // the very next pass, before this pass's own exfmt ever shows it. + // holdMsg skips exactly one clearMsgs call right after such a + // message was queued. Same pattern as wrkivpr (PERP-74). + if holdMsg; + holdMsg = *off; + else; + exsr clearMsgs; + endif; if fItem = '' and fVendor = ''; *in30 = *off; @@ -128,6 +153,25 @@ dow not *in03 and not *in12; iter; endif; + // Item/Vendor Number prompts (PERP-58/PERP-71): '?' + Enter invokes + // the standard reusable lookups (PERP-56/PERP-70) and returns the + // selection into the filter field that was prompted. + if %trim(sfitem) = '?'; + promptItem = sfitem; + callItmprmt(compcd : promptItem); + sfitem = promptItem; + fItem = promptItem; + iter; + endif; + + if %trim(sfvendor) = '?'; + promptVendor = sfvendor; + callVndprmt(compcd : promptVendor); + sfvendor = promptVendor; + fVendor = promptVendor; + iter; + endif; + // Refresh scope from screen entry if sfitem <> fItem or sfvendor <> fVendor; fItem = sfitem; @@ -173,7 +217,7 @@ begsr loadRows; exec sql open iv1; if sqlcode < 0; writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); - return; + leavesr; endif; dow numRows < %elem(rows); @@ -228,7 +272,8 @@ endsr; begsr addRow; if fItem = '' and fVendor = ''; writeMsg('Enter an item or vendor before adding a profile.'); - return; + holdMsg = *on; + leavesr; endif; emode = 'A'; eitem = fItem; @@ -274,7 +319,8 @@ begsr changeRow; and vendor_code = :evendor; if sqlcode <> 0; writeMsg('Row disappeared before change.'); - return; + holdMsg = *on; + leavesr; endif; exsr editLoop; if not *in12; @@ -317,7 +363,25 @@ endsr; // --------------------------------------------------------------------- begsr editLoop; - exfmt ivedit; + dow not *in12; + exfmt ivedit; + if *in12; + leave; + endif; + if %trim(eitem) = '?'; + promptItem = eitem; + callItmprmt(compcd : promptItem); + eitem = promptItem; + iter; + endif; + if %trim(evendor) = '?'; + promptVendor = evendor; + callVndprmt(compcd : promptVendor); + evendor = promptVendor; + iter; + endif; + leave; + enddo; endsr; // --------------------------------------------------------------------- diff --git a/perp/qrpglesrc/wrkivpr.sqlrpgle b/perp/qrpglesrc/wrkivpr.sqlrpgle index 2ae4f937..9453615d 100644 --- a/perp/qrpglesrc/wrkivpr.sqlrpgle +++ b/perp/qrpglesrc/wrkivpr.sqlrpgle @@ -36,6 +36,18 @@ dcl-pr QMHSNDPM extpgm; errorCode char(8) const; end-pr; +// Standard, reusable Item/Vendor Number prompts (PERP-51/PERP-56/PERP-70). +// Same dynamic CALL idiom as wrkitmr's callWrkcnvr/callWrklotr. +dcl-pr callItmprmt extpgm('ITMPRMT'); + pCompcd char(3) const; + pItem varchar(25); +end-pr; + +dcl-pr callVndprmt extpgm('VNDPRMT'); + pCompcd char(3) const; + pVendor varchar(10); +end-pr; + dcl-ds statusDS psds qualified; programName char(10) pos(334); end-ds; @@ -57,6 +69,9 @@ dcl-s msgkey char(4); dcl-s compcd char(3); dcl-s fItem varchar(25); dcl-s fVendor varchar(10); +dcl-s promptItem varchar(25); +dcl-s promptVendor varchar(10); +dcl-s holdMsg ind; in ldaDS; compcd = ldaDS.compcd; @@ -86,7 +101,17 @@ dow not *in03 and not *in12; leave; endif; - exsr clearMsgs; + // PERP-74: a message queued by an action handler below (F6, etc.) + // must survive one full loop pass before being cleared, or it never + // reaches the screen -- clearMsgs wipes msgrrn back to 0 on the very + // next pass, before the "if msgrrn > 0" check further down ever sees + // it. holdMsg skips exactly one clearMsgs call right after such a + // message was queued. + if holdMsg; + holdMsg = *off; + else; + exsr clearMsgs; + endif; if fItem = '' or fVendor = ''; *in30 = *off; @@ -128,6 +153,29 @@ dow not *in03 and not *in12; else; exsr addPrice; endif; + if msgrrn > 0; + holdMsg = *on; + endif; + iter; + endif; + + // Item Number prompt (PERP-59): '?' + Enter invokes the standard + // reusable Item Number lookup (PERP-56) and returns the selection. + if %trim(sfitem) = '?'; + promptItem = sfitem; + callItmprmt(compcd : promptItem); + sfitem = promptItem; + fItem = promptItem; + iter; + endif; + + // Vendor Number prompt (PERP-75): '?' + Enter invokes the standard + // reusable Vendor Number lookup (PERP-70) and returns the selection. + if %trim(sfvendor) = '?'; + promptVendor = sfvendor; + callVndprmt(compcd : promptVendor); + sfvendor = promptVendor; + fVendor = promptVendor; iter; endif; @@ -145,9 +193,21 @@ return; // --------------------------------------------------------------------- begsr loadRows; numRows = 0; + // PERP-83: display as MM/DD/YY. effective_from/to are stored as + // native DATE columns but rendered here as plain strings (SEFFFRM/ + // SEFFTO carry no DATFMT keyword), so the format has to be built by + // hand from the ISO string -- DB2 for i's CHAR(date,fmt) built-in + // formats (ISO/USA/EUR/JIS) all use a 4-digit year, none produce a + // 2-digit year directly. exec sql declare p1 cursor for - select char(effective_from, iso), - case when effective_to is null then '' else char(effective_to, iso) end, + select substr(char(effective_from, iso), 6, 2) || '/' + || substr(char(effective_from, iso), 9, 2) || '/' + || substr(char(effective_from, iso), 3, 2), + case when effective_to is null then '' + else substr(char(effective_to, iso), 6, 2) || '/' + || substr(char(effective_to, iso), 9, 2) || '/' + || substr(char(effective_to, iso), 3, 2) + end, unit_price, currency_code, price_source from perpdemo.item_vendor_price where company_code = :compcd and item_number = :fItem @@ -156,7 +216,7 @@ begsr loadRows; exec sql open p1; if sqlcode < 0; writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); - return; + leavesr; endif; dow numRows < %elem(rows); @@ -196,7 +256,7 @@ begsr addPrice; eprcsrc = 'MANUAL'; exfmt ipadd; if *in12 or enewprc <= 0; - return; + leavesr; endif; // Close the current row, if one exists (no current row is fine -- @@ -210,7 +270,7 @@ begsr addPrice; and vendor_code = :fVendor and effective_to is null; if sqlcode < 0; writeMsg('Close of prior price failed: SQLCODE=' + %char(sqlcode)); - return; + leavesr; endif; exec sql diff --git a/perp/qrpglesrc/wrklotr.sqlrpgle b/perp/qrpglesrc/wrklotr.sqlrpgle index 4a0cdb0c..0a77ea6a 100644 --- a/perp/qrpglesrc/wrklotr.sqlrpgle +++ b/perp/qrpglesrc/wrklotr.sqlrpgle @@ -13,7 +13,12 @@ // Epic: PERP-3 (PERP-24) // --------------------------------------------------------------------- -ctl-opt dftactgrp(*no) actgrp(*new); +// PERP-84: datfmt(*iso) is required now that this program declares +// Date-typed variables (parsedRecv/parsedExpd below) to validate the +// MM/DD/YY Received/Expiry Date entry fields. Without this override the +// job's *MDY (1940-2039) DATFMT becomes the Date variables' storage +// format, per perp/AGENTS.md's RNQ0114 gotcha. +ctl-opt dftactgrp(*no) actgrp(*new) datfmt(*iso); dcl-pi *n; pCompcd char(3) const options(*nopass); @@ -38,6 +43,13 @@ dcl-pr QMHSNDPM extpgm; errorCode char(8) const; end-pr; +// Standard, reusable Item Number prompt (PERP-51/PERP-56). Same dynamic +// CALL idiom as wrkitmr's callWrkcnvr/callWrklotr. +dcl-pr callItmprmt extpgm('ITMPRMT'); + pCompcd char(3) const; + pItem varchar(25); +end-pr; + dcl-ds statusDS psds qualified; programName char(10) pos(334); end-ds; @@ -61,6 +73,18 @@ dcl-s filter varchar(25); dcl-s compcd char(3); dcl-s itemOh packed(15:4); dcl-s lotTotal packed(15:4); +dcl-s promptItem varchar(25); + +// PERP-84: MM/DD/YY entry validation for ERECV/EEXPD (see editLoop). +// parsedRecv/parsedExpd are Date-typed working vars used only to +// validate/reformat the typed text -- they are never bound directly to +// an SQL host variable (erecv/eexpd stay char(10) for that), so the +// SQL-precompiler-intermediate-host-variable *MDY cap documented in +// perp/AGENTS.md #13 does not come into play here. +dcl-s parsedRecv date; +dcl-s parsedExpd date; +dcl-s validRecv ind; +dcl-s validExpd ind; in ldaDS; compcd = ldaDS.compcd; @@ -146,6 +170,16 @@ dow not *in03 and not *in12; iter; endif; + // Item Number prompt (PERP-60): '?' + Enter invokes the standard + // reusable Item Number lookup (PERP-56) and returns the selection. + if %trim(sfitem) = '?'; + promptItem = sfitem; + callItmprmt(compcd : promptItem); + sfitem = promptItem; + filter = promptItem; + iter; + endif; + // Refresh scope from screen entry if sfitem <> filter; filter = sfitem; @@ -201,17 +235,29 @@ endsr; // --------------------------------------------------------------------- begsr loadRows; numRows = 0; + // PERP-84: display as MM/DD/YY. received_date/expiry_date are stored + // as native DATE columns but rendered here as plain strings (SRECV/ + // SEXPD carry no DATFMT keyword), so the format has to be built by + // hand from the ISO string -- DB2 for i's CHAR(date,fmt) built-in + // formats (ISO/USA/EUR/JIS) all use a 4-digit year, none produce a + // 2-digit year directly. Same technique as wrkivpr.sqlrpgle (PERP-83). exec sql declare c1 cursor for select lot_number, qty_on_hand, - char(received_date, iso), - coalesce(char(expiry_date, iso), '') + substr(char(received_date, iso), 6, 2) || '/' + || substr(char(received_date, iso), 9, 2) || '/' + || substr(char(received_date, iso), 3, 2), + case when expiry_date is null then '' + else substr(char(expiry_date, iso), 6, 2) || '/' + || substr(char(expiry_date, iso), 9, 2) || '/' + || substr(char(expiry_date, iso), 3, 2) + end from perpdemo.item_lot where company_code = :compcd and item_number = :filter order by lot_number; exec sql open c1; if sqlcode < 0; writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); - return; + leavesr; endif; dow numRows < %elem(rows); @@ -264,7 +310,7 @@ begsr addRow; emode = 'A'; elot = ''; eqty = 0; - erecv = %char(%date():*iso); + erecv = %char(%date():*mdy); eexpd = ''; eactive = 'Y'; exsr editLoop; @@ -322,8 +368,66 @@ begsr deleteRow; endsr; // --------------------------------------------------------------------- +// PERP-84: erecv/eexpd are typed by the user as MM/DD/YY on LTEDIT. +// Validate on every Enter; on failure, show the error in the message +// subfile alongside LTEDIT and let the user retry (never crash into +// the SQL date(:erecv) cast in addRow/changeRow with unparsed text). +// On success, erecv/eexpd are normalized to ISO ('yyyy-mm-dd') text so +// the existing date(:erecv)/date(:eexpd) SQL casts in addRow/changeRow +// keep working unchanged. begsr editLoop; - exfmt ltedit; + exsr clearMsgs; + dow *on; + if msgrrn > 0; + *in40 = *on; + write ltmsgctl; + else; + *in40 = *off; + endif; + exfmt ltedit; + + if *in12; + leave; + endif; + + exsr clearMsgs; + + if %trim(erecv) = ''; + writeMsg('Received Date is required (MM/DD/YY).'); + iter; + endif; + + validRecv = *on; + monitor; + parsedRecv = %date(%trim(erecv):*mdy); + on-error; + validRecv = *off; + endmon; + if not validRecv; + writeMsg('Invalid Received Date - enter as MM/DD/YY.'); + iter; + endif; + + validExpd = *on; + if %trim(eexpd) <> ''; + monitor; + parsedExpd = %date(%trim(eexpd):*mdy); + on-error; + validExpd = *off; + endmon; + endif; + if not validExpd; + writeMsg('Invalid Expiry Date - enter as MM/DD/YY, or blank for none.'); + iter; + endif; + + erecv = %char(parsedRecv:*iso); + if %trim(eexpd) <> ''; + eexpd = %char(parsedExpd:*iso); + endif; + + leave; + enddo; endsr; // --------------------------------------------------------------------- diff --git a/perp/qrpglesrc/wrkusrr.sqlrpgle b/perp/qrpglesrc/wrkusrr.sqlrpgle index d8d41c09..6165930e 100644 --- a/perp/qrpglesrc/wrkusrr.sqlrpgle +++ b/perp/qrpglesrc/wrkusrr.sqlrpgle @@ -46,9 +46,20 @@ dcl-s msgrrn int(10); dcl-s msgkey char(4); dcl-s selRrn int(10); dcl-s selOpt char(1); +dcl-s holdMsg ind; dow not *in03 and not *in12; - exsr clearMsgs; + // A message queued by an action handler below (2=Change, etc.) must + // survive one full loop pass before being cleared, or it never + // reaches the screen -- clearMsgs wipes msgrrn back to 0 on the very + // next pass, before this pass's own exfmt ever shows it. holdMsg + // skips exactly one clearMsgs call right after such a message was + // queued. Same pattern as wrkivpr (PERP-74). + if holdMsg; + holdMsg = *off; + else; + exsr clearMsgs; + endif; exsr loadRows; if numRows = 0; @@ -113,7 +124,7 @@ begsr loadRows; exec sql open u1; if sqlcode < 0; writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); - return; + leavesr; endif; dow numRows < %elem(rows); @@ -197,7 +208,8 @@ begsr changeRow; where user_code = :eucode; if sqlcode <> 0; writeMsg('Row disappeared before change.'); - return; + holdMsg = *on; + leavesr; endif; exsr editLoop; if not *in12; diff --git a/perp/tmp/logs/itmprmt.pgm.log b/perp/tmp/logs/itmprmt.pgm.log new file mode 100644 index 00000000..33ef92a4 --- /dev/null +++ b/perp/tmp/logs/itmprmt.pgm.log @@ -0,0 +1,1501 @@ +CPC7301: File QSQLPRE created in library QTEMP. +CPC7305: Member ITMPRMT added to file QSQLPRE in QTEMP. +CPC3201: Member ITMPRMT file QSQLPRE in QTEMP changed. +RNS9307: Diagnostic check of source is complete. Highest severity is 00. +CPC0904: Data area RETURNCODE created in library QTEMP. +CPC7301: File QSQLTEMP1 created in library QTEMP. +CPC7305: Member ITMPRMT added to file QSQLTEMP1 in QTEMP. +CPI2119: AUT and USRPRF parameter values were ignored. +CPI2121: Replaced object ITMPRMT type *PGM was moved to QRPLOBJ. +RNS9304: Program ITMPRMT placed in library PERPDEMO. 00 highest severity. Created on 08/20/26 at 16:25:09. + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 1 + Command . . . . . . . . . . . . : CRTBNDRPG + Issued by . . . . . . . . . . : AIDEMO + Program . . . . . . . . . . . . : ITMPRMT + Library . . . . . . . . . . . : PERPDEMO + Text 'description' . . . . . . . : *SRCMBRTXT + Source stream file . . . . . . : qrpglesrc/itmprmt.sqlrpgle + CCSID . . . . . . . . . . . . : 1208 + Target CCSID . . . . . . . . . . : *JOB (37) + Text 'description' . . . . . . . : + Last Change . . . . . . . . . . : 08/20/26 16:25:03 + Generation severity level . . . : 10 + Default activation group . . . . : *YES + Compiler options . . . . . . . . : *XREF *GEN *NOSECLVL *SHOWCPY + *EXPDDS *EXT *NOSHOWSKP *NOSRCSTMT + *DEBUGIO *UNREF *NOEVENTF + Debugging views . . . . . . . . : *ALL + Debug encryption key . . . . . . : *NONE + Output . . . . . . . . . . . . . : *PRINT + Optimization level . . . . . . . : *NONE + Source listing indentation . . . : *NONE + Type conversion options . . . . : *NONE + Sort sequence . . . . . . . . . : *JOB + Language identifier . . . . . . : *JOB + Replace program . . . . . . . . : *YES + User profile . . . . . . . . . . : *USER + Authority . . . . . . . . . . . : *LIBCRTAUT + Truncate numeric . . . . . . . . : *YES + Fix numeric . . . . . . . . . . : *NONE + Target release . . . . . . . . . : V7R4M0 + Allow null values . . . . . . . : *NO + Define condition names . . . . . : *NONE + Enable performance collection . : *PEP + Profiling data . . . . . . . . . : *NOCOL + Licensed Internal Code options . : + Generate program interface . . . : *NO + Include directory . . . . . . . : . + Preprocessor options . . . . . . : *NORMVCOMMENT *EXPINCLUDE *NOSEQSRC + Output source file . . . . . . . : QSQLPRE + Library . . . . . . . . . . . : QTEMP + Output source member . . . . . . : ITMPRMT + MINIMUM OUTPUT LINE LENGTH . . . : 100 + Require prototype for export . . : *NO + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 2 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + S o u r c e L i s t i n g + 1 **free 000001 + 2 000002 + 3 // --------------------------------------------------------------------- 000003 + 4 // Program: itmprmt (standard, reusable Item Number prompt/lookup) 000004 + 5 // Purpose: System-wide "?" + Enter lookup for any keyable Item Number 000005 + 6 // field. Caller CALLs this program passing the company code 000006 + 7 // and the field's current value; typing '?' into the field 000007 + 8 // before Enter is the trigger convention every caller uses, 000008 + 9 // so this program treats a '?' seed the same as a blank 000009 + 10 // search (full list). Any other seed value pre-fills the 000010 + 11 // Search field so partial text the user already typed keeps 000011 + 12 // working as a filter. The subfile lists item_number + 000012 + 13 // item_description, filtered case-insensitively on either 000013 + 14 // column; 1=Select on a row returns that item_number in the 000014 + 15 // same parameter. F3/F12 cancel and return the field blank. 000015 + 16 // Model: perpselr's subfile-picker pattern (PERP-16), 000016 + 17 // adapted for field-level invocation instead of a full-screen 000017 + 18 // menu step. Called via a plain dynamic CALL (EXTPGM 000018 + 19 // prototype declared in each caller) -- the same idiom 000019 + 20 // wrkitmr already uses to call wrkcnvr/wrklotr -- not a bound 000020 + 21 // service program, so no bnddir/exports wiring is needed. 000021 + 22 // Callers: wrkcnvr (PERP-54), wrkitmr (PERP-57), wrkivnr (PERP-58), 000022 + 23 // wrkivpr (PERP-59), wrklotr (PERP-60), reqentr (PERP-61), 000023 + 24 // poentr (PERP-62). 000024 + 25 // Epic: PERP-51 (PERP-56) 000025 + 26 // --------------------------------------------------------------------- 000026 + 27 000027 + 28 ctl-opt dftactgrp(*no) actgrp(*new); 000028 + 29 000029 + 30 dcl-pi *n; 000030 + 31 pCompcd char(3) const; 000031 + 32 pItem varchar(25); 000032 + 33 end-pi; 000033 + 34 000034 + 35 dcl-f itmprm2d workstn sfile(itpsfl:rrn) sfile(itpmsgsfl:msgrrn); 000035 + 36 000036 + 37 dcl-pr QMHSNDPM extpgm; 000037 + 38 msgId char(7) const; 000038 + 39 msgF char(20) const; 000039 + 40 msgData char(256) const; 000040 + 41 msgDataLen int(10) const; 000041 + 42 msgType char(10) const; 000042 + 43 stackEntry char(10) const; 000043 + 44 stackCntr int(10) const; 000044 + 45 msgKey char(4); 000045 + 46 errorCode char(8) const; 000046 + 47 end-pr; 000047 + 48 000048 + 49 dcl-ds statusDS psds qualified; 000049 + 50 programName char(10) pos(334); 000050 + 51 end-ds; 000051 + 52 000052 + 53 dcl-ds itemRow qualified; 000053 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 3 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 54 item varchar(25); 000054 + 55 desc varchar(60); 000055 + 56 end-ds; 000056 + 57 000057 + 58 dcl-ds rows likeds(itemRow) dim(500); 000058 + 59 dcl-s numRows int(10); 000059 + 60 dcl-s i int(10); 000060 + 61 dcl-s rrn int(10); 000061 + 62 dcl-s msgrrn int(10); 000062 + 63 dcl-s msgkey char(4); 000063 + 64 dcl-s selRrn int(10); 000064 + 65 dcl-s search varchar(30); 000065 + 66 000066 + 67 search = %trim(pItem); 000067 + 68 if search = '?'; 000068 + 69 search = ''; 000069 + 70 endif; 000070 + 71 ssearch = search; 000071 + 72 000072 + 73 dow not *in03 and not *in12; 000073 + 74 exsr clearMsgs; 000074 + 75 exsr loadRows; 000075 + 76 000076 + 77 if numRows = 0; 000077 + 78 *in30 = *off; 000078 + 79 write itpnone; 000079 + 80 else; 000080 + 81 exsr fillSubfile; 000081 + 82 *in30 = *on; 000082 + 83 endif; 000083 + 84 000084 + 85 write itpfoot; 000085 + 86 if msgrrn > 0; 000086 + 87 *in40 = *on; 000087 + 88 write itpmsgctl; 000088 + 89 else; 000089 + 90 *in40 = *off; 000090 + 91 endif; 000091 + 92 000092 + 93 exfmt itpctl; 000093 + 94 000094 + 95 if *in03 or *in12; 000095 + 96 pItem = ''; 000096 + 97 leave; 000097 + 98 endif; 000098 + 99 000099 + 100 if *in05; 000100 + 101 iter; 000101 + 102 endif; 000102 + 103 000103 + 104 if ssearch <> search; 000104 + 105 search = %trim(ssearch); 000105 + 106 iter; 000106 + 107 endif; 000107 + 108 000108 + 109 // Guard on numRows: READC against a subfile that was never written 000109 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 4 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 110 // to this cycle (0 rows loaded) raises a "Session or device error" 000110 + 111 // (CPF5006-class) runtime error instead of just returning *EOF. 000111 + 112 if numRows > 0; 000112 + 113 selRrn = 0; 000113 + 114 readc itpsfl; 000114 + 115 dow not %eof(itmprm2d); 000115 + 116 if sopt = '1'; 000116 + 117 if selRrn = 0; 000117 + 118 selRrn = rrn; 000118 + 119 else; 000119 + 120 writeMsg('Only one item may be selected per Enter.'); 000120 + 121 endif; 000121 + 122 elseif sopt <> ''; 000122 + 123 writeMsg('Option ' + sopt + ' is not valid - use 1.'); 000123 + 124 endif; 000124 + 125 readc itpsfl; 000125 + 126 enddo; 000126 + 127 endif; 000127 + 128 000128 + 129 if selRrn > 0 and msgrrn = 0; 000129 + 130 chain selRrn itpsfl; 000130 + 131 pItem = siitem; 000131 + 132 leave; 000132 + 133 endif; 000133 + 134 000134 + 135 enddo; 000135 + 136 000136 + 137 *inlr = *on; 000137 + 138 return; 000138 + 139 000139 + 140 // --------------------------------------------------------------------- 000140 + 141 begsr loadRows; 000141 + 142 numRows = 0; 000142 + 143 exec sql declare ip1 cursor for 000143 + 144 select item_number, item_description 000144 + 145 from perpdemo.item 000145 + 146 where company_code = :pCompcd 000146 + 147 and (:search = '' 000147 + 148 or upper(item_number) like '%' || upper(:search) || '%' 000148 + 149 or upper(item_description) like '%' || upper(:search) || '%') 000149 + 150 order by item_number; 000150 + 151 exec sql open ip1; 000151 + 152 if sqlcode < 0; 000152 + 153 writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); 000153 + 154 leavesr; 000154 + 155 endif; 000155 + 156 000156 + 157 dow numRows < %elem(rows); 000157 + 158 exec sql fetch ip1 into :itemRow; 000158 + 159 if sqlcode = 100 or sqlcode < 0; 000159 + 160 leave; 000160 + 161 endif; 000161 + 162 numRows += 1; 000162 + 163 rows(numRows) = itemRow; 000163 + 164 enddo; 000164 + 165 exec sql close ip1; 000165 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 5 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 166 endsr; 000166 + 167 000167 + 168 // --------------------------------------------------------------------- 000168 + 169 begsr fillSubfile; 000169 + 170 rrn = 0; 000170 + 171 *in31 = *on; 000171 + 172 write itpctl; 000172 + 173 *in31 = *off; 000173 + 174 for i = 1 to numRows; 000174 + 175 *in50 = *off; 000175 + 176 *in51 = *off; 000176 + 177 sopt = ''; 000177 + 178 siitem = rows(i).item; 000178 + 179 sidesc = %subst(rows(i).desc : 1 : %min(%len(rows(i).desc) : 48)); 000179 + 180 rrn += 1; 000180 + 181 write itpsfl; 000181 + 182 endfor; 000182 + 183 endsr; 000183 + 184 000184 + 185 // --------------------------------------------------------------------- 000185 + 186 begsr clearMsgs; 000186 + 187 msgrrn = 0; 000187 + 188 *in41 = *on; 000188 + 189 write itpmsgctl; 000189 + 190 *in41 = *off; 000190 + 191 endsr; 000191 + 192 000192 + 193 // --------------------------------------------------------------------- 000193 + 194 dcl-proc writeMsg; 000194 + 195 dcl-pi *n; 000195 + 196 text varchar(256) const; 000196 + 197 end-pi; 000197 + 198 dcl-s data char(256); 000198 + 199 data = text; 000199 + 200 QMHSNDPM( 000200 + 201 'CPF9897' : 000201 + 202 'QCPFMSG QSYS ' : 000202 + 203 data : 000203 + 204 %len(text) : 000204 + 205 '*INFO ' : 000205 + 206 '* ' : 000206 + 207 1 : 000207 + 208 smsgkey : 000208 + 209 x'0000000000000000'); 000209 + 210 msgrrn += 1; 000210 + 211 spgmq = statusDS.programName; 000211 + 212 write itpmsgsfl; 000212 + 213 end-proc; 000213 + * * * * * E N D O F S O U R C E * * * * * + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 6 + Line <---------------------- Data Records --------------------------------------------------------------> Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Date Id Number + C o m p i l e T i m e D a t a + * * * * * E N D O F C O M P I L E T I M E D A T A * * * * * + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 7 + M e s s a g e S u m m a r y + Msg id Sv Number Message text + * * * * * E N D O F M E S S A G E S U M M A R Y * * * * * + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 8 + F i n a l S u m m a r y + Message Totals: + Information (00) . . . . . . . : 0 + Warning (10) . . . . . . . : 0 + Error (20) . . . . . . . : 0 + Severe Error (30+) . . . . . . : 0 + --------------------------------- ------- + Total . . . . . . . . . . . . . : 0 + Source Totals: + Records . . . . . . . . . . . . : 213 + Specifications . . . . . . . . : 154 + Data records . . . . . . . . . : 0 + Comments . . . . . . . . . . . : 56 + * * * * * E N D O F F I N A L S U M M A R Y * * * * * + Diagnostic check of source is complete. Highest severity is 00. + * * * * * E N D O F C O M P I L A T I O N * * * * * + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object ITMPRMT 08/20/26 16:25:08 Page 1 + Source type...............RPG + Object name...............PERPDEMO/ITMPRMT + Source file...............QTEMP/QSQLPRE + Member....................*OBJ + To source file............QTEMP/QSQLTEMP1 + Options...................*XREF + RPG preprocessor options..*LVL2 + Listing option............*PRINT + Target release............V7R4M0 + INCLUDE file..............*LIBL/QRPGLESRC + Commit....................*CHG + Allow copy of data........*OPTIMIZE + Close SQL cursor..........*ENDACTGRP + Allow blocking............*ALLREAD + Delay PREPARE.............*NO + Concurrent access + resolution..............*DFT + Generation level..........10 + Printer file..............*LIBL/QSYSPRT + Date format...............*JOB + Date separator............*JOB + Time format...............*HMS + Time separator ...........*JOB + Replace...................*YES + Relational database.......*LOCAL + User .....................*CURRENT + RDB connect method........*DUW + Default collection........*NONE + Dynamic default + collection..............*NO + Package name..............*OBJLIB/*OBJ + Path......................*NAMING + SQL rules.................*DB2 + Created object type.......*PGM + Debugging view............*SOURCE + Debugging encryption key..*NONE + User profile .............*NAMING + Dynamic user profile......*USER + Sort sequence.............*JOB + Language ID...............*JOB + IBM SQL flagging..........*NOFLAG + ANS flagging..............*NONE + Text......................*SRCMBRTXT + Source file CCSID.........37 + Conversion CCSID..........1208 + Job CCSID.................37 + Decimal result options: + Maximum precision.......31 + Maximum scale...........31 + Minimum divide scale....0 + DECFLOAT rounding mode....*HALFEVEN + Compiler options..........incdir('.') tgtccsid(*job) output(*print) + Source member changed on 08/20/26 16:25:08 + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object ITMPRMT 08/20/26 16:25:08 Page 2 + Record *...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 SEQNBR Last change + 1 **free 000001 08/20/26 + 2 000002 08/20/26 + 3 // --------------------------------------------------------------------- 000003 08/20/26 + 4 // Program: itmprmt (standard, reusable Item Number prompt/lookup) 000004 08/20/26 + 5 // Purpose: System-wide "?" + Enter lookup for any keyable Item Number 000005 08/20/26 + 6 // field. Caller CALLs this program passing the company code 000006 08/20/26 + 7 // and the field's current value; typing '?' into the field 000007 08/20/26 + 8 // before Enter is the trigger convention every caller uses, 000008 08/20/26 + 9 // so this program treats a '?' seed the same as a blank 000009 08/20/26 + 10 // search (full list). Any other seed value pre-fills the 000010 08/20/26 + 11 // Search field so partial text the user already typed keeps 000011 08/20/26 + 12 // working as a filter. The subfile lists item_number + 000012 08/20/26 + 13 // item_description, filtered case-insensitively on either 000013 08/20/26 + 14 // column; 1=Select on a row returns that item_number in the 000014 08/20/26 + 15 // same parameter. F3/F12 cancel and return the field blank. 000015 08/20/26 + 16 // Model: perpselr's subfile-picker pattern (PERP-16), 000016 08/20/26 + 17 // adapted for field-level invocation instead of a full-screen 000017 08/20/26 + 18 // menu step. Called via a plain dynamic CALL (EXTPGM 000018 08/20/26 + 19 // prototype declared in each caller) -- the same idiom 000019 08/20/26 + 20 // wrkitmr already uses to call wrkcnvr/wrklotr -- not a bound 000020 08/20/26 + 21 // service program, so no bnddir/exports wiring is needed. 000021 08/20/26 + 22 // Callers: wrkcnvr (PERP-54), wrkitmr (PERP-57), wrkivnr (PERP-58), 000022 08/20/26 + 23 // wrkivpr (PERP-59), wrklotr (PERP-60), reqentr (PERP-61), 000023 08/20/26 + 24 // poentr (PERP-62). 000024 08/20/26 + 25 // Epic: PERP-51 (PERP-56) 000025 08/20/26 + 26 // --------------------------------------------------------------------- 000026 08/20/26 + 27 000027 08/20/26 + 28 ctl-opt dftactgrp(*no) actgrp(*new); 000028 08/20/26 + 29 000029 08/20/26 + 30 dcl-pi *n; 000030 08/20/26 + 31 pCompcd char(3) const; 000031 08/20/26 + 32 pItem varchar(25); 000032 08/20/26 + 33 end-pi; 000033 08/20/26 + 34 000034 08/20/26 + 35 dcl-f itmprm2d workstn sfile(itpsfl:rrn) sfile(itpmsgsfl:msgrrn); 000035 08/20/26 + 36 000036 08/20/26 + 37 dcl-pr QMHSNDPM extpgm; 000037 08/20/26 + 38 msgId char(7) const; 000038 08/20/26 + 39 msgF char(20) const; 000039 08/20/26 + 40 msgData char(256) const; 000040 08/20/26 + 41 msgDataLen int(10) const; 000041 08/20/26 + 42 msgType char(10) const; 000042 08/20/26 + 43 stackEntry char(10) const; 000043 08/20/26 + 44 stackCntr int(10) const; 000044 08/20/26 + 45 msgKey char(4); 000045 08/20/26 + 46 errorCode char(8) const; 000046 08/20/26 + 47 end-pr; 000047 08/20/26 + 48 000048 08/20/26 + 49 dcl-ds statusDS psds qualified; 000049 08/20/26 + 50 programName char(10) pos(334); 000050 08/20/26 + 51 end-ds; 000051 08/20/26 + 52 000052 08/20/26 + 53 dcl-ds itemRow qualified; 000053 08/20/26 + 54 item varchar(25); 000054 08/20/26 + 55 desc varchar(60); 000055 08/20/26 + 56 end-ds; 000056 08/20/26 + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object ITMPRMT 08/20/26 16:25:08 Page 3 + Record *...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 SEQNBR Last change + 57 000057 08/20/26 + 58 dcl-ds rows likeds(itemRow) dim(500); 000058 08/20/26 + 59 dcl-s numRows int(10); 000059 08/20/26 + 60 dcl-s i int(10); 000060 08/20/26 + 61 dcl-s rrn int(10); 000061 08/20/26 + 62 dcl-s msgrrn int(10); 000062 08/20/26 + 63 dcl-s msgkey char(4); 000063 08/20/26 + 64 dcl-s selRrn int(10); 000064 08/20/26 + 65 dcl-s search varchar(30); 000065 08/20/26 + 66 000066 08/20/26 + 67 search = %trim(pItem); 000067 08/20/26 + 68 if search = '?'; 000068 08/20/26 + 69 search = ''; 000069 08/20/26 + 70 endif; 000070 08/20/26 + 71 ssearch = search; 000071 08/20/26 + 72 000072 08/20/26 + 73 dow not *in03 and not *in12; 000073 08/20/26 + 74 exsr clearMsgs; 000074 08/20/26 + 75 exsr loadRows; 000075 08/20/26 + 76 000076 08/20/26 + 77 if numRows = 0; 000077 08/20/26 + 78 *in30 = *off; 000078 08/20/26 + 79 write itpnone; 000079 08/20/26 + 80 else; 000080 08/20/26 + 81 exsr fillSubfile; 000081 08/20/26 + 82 *in30 = *on; 000082 08/20/26 + 83 endif; 000083 08/20/26 + 84 000084 08/20/26 + 85 write itpfoot; 000085 08/20/26 + 86 if msgrrn > 0; 000086 08/20/26 + 87 *in40 = *on; 000087 08/20/26 + 88 write itpmsgctl; 000088 08/20/26 + 89 else; 000089 08/20/26 + 90 *in40 = *off; 000090 08/20/26 + 91 endif; 000091 08/20/26 + 92 000092 08/20/26 + 93 exfmt itpctl; 000093 08/20/26 + 94 000094 08/20/26 + 95 if *in03 or *in12; 000095 08/20/26 + 96 pItem = ''; 000096 08/20/26 + 97 leave; 000097 08/20/26 + 98 endif; 000098 08/20/26 + 99 000099 08/20/26 + 100 if *in05; 000100 08/20/26 + 101 iter; 000101 08/20/26 + 102 endif; 000102 08/20/26 + 103 000103 08/20/26 + 104 if ssearch <> search; 000104 08/20/26 + 105 search = %trim(ssearch); 000105 08/20/26 + 106 iter; 000106 08/20/26 + 107 endif; 000107 08/20/26 + 108 000108 08/20/26 + 109 // Guard on numRows: READC against a subfile that was never written 000109 08/20/26 + 110 // to this cycle (0 rows loaded) raises a "Session or device error" 000110 08/20/26 + 111 // (CPF5006-class) runtime error instead of just returning *EOF. 000111 08/20/26 + 112 if numRows > 0; 000112 08/20/26 + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object ITMPRMT 08/20/26 16:25:08 Page 4 + Record *...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 SEQNBR Last change + 113 selRrn = 0; 000113 08/20/26 + 114 readc itpsfl; 000114 08/20/26 + 115 dow not %eof(itmprm2d); 000115 08/20/26 + 116 if sopt = '1'; 000116 08/20/26 + 117 if selRrn = 0; 000117 08/20/26 + 118 selRrn = rrn; 000118 08/20/26 + 119 else; 000119 08/20/26 + 120 writeMsg('Only one item may be selected per Enter.'); 000120 08/20/26 + 121 endif; 000121 08/20/26 + 122 elseif sopt <> ''; 000122 08/20/26 + 123 writeMsg('Option ' + sopt + ' is not valid - use 1.'); 000123 08/20/26 + 124 endif; 000124 08/20/26 + 125 readc itpsfl; 000125 08/20/26 + 126 enddo; 000126 08/20/26 + 127 endif; 000127 08/20/26 + 128 000128 08/20/26 + 129 if selRrn > 0 and msgrrn = 0; 000129 08/20/26 + 130 chain selRrn itpsfl; 000130 08/20/26 + 131 pItem = siitem; 000131 08/20/26 + 132 leave; 000132 08/20/26 + 133 endif; 000133 08/20/26 + 134 000134 08/20/26 + 135 enddo; 000135 08/20/26 + 136 000136 08/20/26 + 137 *inlr = *on; 000137 08/20/26 + 138 return; 000138 08/20/26 + 139 000139 08/20/26 + 140 // --------------------------------------------------------------------- 000140 08/20/26 + 141 begsr loadRows; 000141 08/20/26 + 142 numRows = 0; 000142 08/20/26 + 143 exec sql declare ip1 cursor for 000143 08/20/26 + 144 select item_number, item_description 000144 08/20/26 + 145 from perpdemo.item 000145 08/20/26 + 146 where company_code = :pCompcd 000146 08/20/26 + 147 and (:search = '' 000147 08/20/26 + 148 or upper(item_number) like '%' || upper(:search) || '%' 000148 08/20/26 + 149 or upper(item_description) like '%' || upper(:search) || '%') 000149 08/20/26 + 150 order by item_number; 000150 08/20/26 + 151 exec sql open ip1; 000151 08/20/26 + 152 if sqlcode < 0; 000152 08/20/26 + 153 writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); 000153 08/20/26 + 154 leavesr; 000154 08/20/26 + 155 endif; 000155 08/20/26 + 156 000156 08/20/26 + 157 dow numRows < %elem(rows); 000157 08/20/26 + 158 exec sql fetch ip1 into :itemRow; 000158 08/20/26 + 159 if sqlcode = 100 or sqlcode < 0; 000159 08/20/26 + 160 leave; 000160 08/20/26 + 161 endif; 000161 08/20/26 + 162 numRows += 1; 000162 08/20/26 + 163 rows(numRows) = itemRow; 000163 08/20/26 + 164 enddo; 000164 08/20/26 + 165 exec sql close ip1; 000165 08/20/26 + 166 endsr; 000166 08/20/26 + 167 000167 08/20/26 + 168 // --------------------------------------------------------------------- 000168 08/20/26 + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object ITMPRMT 08/20/26 16:25:08 Page 5 + Record *...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 SEQNBR Last change + 169 begsr fillSubfile; 000169 08/20/26 + 170 rrn = 0; 000170 08/20/26 + 171 *in31 = *on; 000171 08/20/26 + 172 write itpctl; 000172 08/20/26 + 173 *in31 = *off; 000173 08/20/26 + 174 for i = 1 to numRows; 000174 08/20/26 + 175 *in50 = *off; 000175 08/20/26 + 176 *in51 = *off; 000176 08/20/26 + 177 sopt = ''; 000177 08/20/26 + 178 siitem = rows(i).item; 000178 08/20/26 + 179 sidesc = %subst(rows(i).desc : 1 : %min(%len(rows(i).desc) : 48)); 000179 08/20/26 + 180 rrn += 1; 000180 08/20/26 + 181 write itpsfl; 000181 08/20/26 + 182 endfor; 000182 08/20/26 + 183 endsr; 000183 08/20/26 + 184 000184 08/20/26 + 185 // --------------------------------------------------------------------- 000185 08/20/26 + 186 begsr clearMsgs; 000186 08/20/26 + 187 msgrrn = 0; 000187 08/20/26 + 188 *in41 = *on; 000188 08/20/26 + 189 write itpmsgctl; 000189 08/20/26 + 190 *in41 = *off; 000190 08/20/26 + 191 endsr; 000191 08/20/26 + 192 000192 08/20/26 + 193 // --------------------------------------------------------------------- 000193 08/20/26 + 194 dcl-proc writeMsg; 000194 08/20/26 + 195 dcl-pi *n; 000195 08/20/26 + 196 text varchar(256) const; 000196 08/20/26 + 197 end-pi; 000197 08/20/26 + 198 dcl-s data char(256); 000198 08/20/26 + 199 data = text; 000199 08/20/26 + 200 QMHSNDPM( 000200 08/20/26 + 201 'CPF9897' : 000201 08/20/26 + 202 'QCPFMSG QSYS ' : 000202 08/20/26 + 203 data : 000203 08/20/26 + 204 %len(text) : 000204 08/20/26 + 205 '*INFO ' : 000205 08/20/26 + 206 '* ' : 000206 08/20/26 + 207 1 : 000207 08/20/26 + 208 smsgkey : 000208 08/20/26 + 209 x'0000000000000000'); 000209 08/20/26 + 210 msgrrn += 1; 000210 08/20/26 + 211 spgmq = statusDS.programName; 000211 08/20/26 + 212 write itpmsgsfl; 000212 08/20/26 + 213 end-proc; 000213 08/20/26 + * * * * * E N D O F S O U R C E * * * * * + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object ITMPRMT 08/20/26 16:25:08 Page 6 + CROSS REFERENCE + Data Names Define Reference + AISLE 145 VARCHAR(10) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + AISLE_CODE 145 COLUMN FOR AISLE IN PERPDEMO.ITEM + BAY 145 VARCHAR(10) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + BAY_CODE 145 COLUMN FOR BAY IN PERPDEMO.ITEM + CLASS_CODE 145 COLUMN FOR CLSCD IN PERPDEMO.ITEM + CLSCD 145 VARCHAR(10) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + COMPANY_CODE **** COLUMN + 146 + COMPANY_CODE 145 COLUMN FOR COMPCD IN PERPDEMO.ITEM + COMPCD 145 CHARACTER(3) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + CREATED_AT 145 COLUMN FOR CRTAT IN PERPDEMO.ITEM + CREATED_BY 145 COLUMN FOR CRTBY IN PERPDEMO.ITEM + CRITICAL_LEVEL 145 COLUMN FOR CRITLV IN PERPDEMO.ITEM + CRITLV 145 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM + CRTAT 145 TIMESTAMP(26) COLUMN (NOT NULL) IN PERPDEMO.ITEM + CRTBY 145 VARCHAR(18) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + DATA 198 CHARACTER(256) IN RPG PROCEDURE WRITEMSG + DESC 55 VARCHAR(60) IN ITEMROW + DESC 58 VARCHAR(60) IN ROWS + I 60 INTEGER PRECISION(9,0) + INVENTORY_UOM 145 COLUMN FOR INVUOM IN PERPDEMO.ITEM + INVUOM 145 VARCHAR(5) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + IP1 143 CURSOR + 151 158 165 + IS_ACTIVE 145 COLUMN FOR ISACT IN PERPDEMO.ITEM + ISACT 145 CHARACTER(1) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + ITEM 54 VARCHAR(25) IN ITEMROW + ITEM 58 VARCHAR(25) IN ROWS + ITEM **** TABLE IN PERPDEMO + 145 + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object ITMPRMT 08/20/26 16:25:08 Page 7 + CROSS REFERENCE + ITEM_DESCRIPTION **** COLUMN + 144 149 + ITEM_DESCRIPTION 145 COLUMN FOR ITMDSC IN PERPDEMO.ITEM + ITEM_NUMBER **** COLUMN + 144 148 150 + ITEM_NUMBER 145 COLUMN FOR ITMNBR IN PERPDEMO.ITEM + ITEMROW 53 STRUCTURE + 158 + ITMDSC 145 VARCHAR(60) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + ITMNBR 145 VARCHAR(25) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + LEAD_TIME_DAYS 145 COLUMN FOR LEADTM IN PERPDEMO.ITEM + LEADTM 145 INTEGER PRECISION(9,0) COLUMN (NOT NULL) IN PERPDEMO.ITEM + LOT_CONTROLLED 145 COLUMN FOR LOTCTL IN PERPDEMO.ITEM + LOTCTL 145 CHARACTER(1) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + MAX_QTY 145 COLUMN FOR MAXQTY IN PERPDEMO.ITEM + MAXQTY 145 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM + MIN_QTY 145 COLUMN FOR MINQTY IN PERPDEMO.ITEM + MINQTY 145 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM + MSGKEY 63 CHARACTER(4) + MSGRRN 62 INTEGER PRECISION(9,0) + NUMROWS 59 INTEGER PRECISION(9,0) + PCOMPCD 31 CHARACTER(3) CONSTANT + 146 + PERPDEMO **** SCHEMA + 145 + PITEM 32 VARCHAR(25) + PROGRAMNAME 50 CHARACTER(10) IN STATUSDS + QMHSNDPM 37 + QTY_AVAILABLE 145 COLUMN FOR QTYAVL IN PERPDEMO.ITEM + QTY_FROZEN 145 COLUMN FOR QTYFRZ IN PERPDEMO.ITEM + QTY_ON_HAND 145 COLUMN FOR QTYOH IN PERPDEMO.ITEM + QTY_ON_ORDER 145 COLUMN FOR QTYOO IN PERPDEMO.ITEM + QTYAVL 145 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM + QTYFRZ 145 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object ITMPRMT 08/20/26 16:25:08 Page 8 + CROSS REFERENCE + QTYOH 145 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM + QTYOO 145 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM + REORDER_POINT 145 COLUMN FOR RORDPT IN PERPDEMO.ITEM + RORDPT 145 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM + ROWS 58 ARRAY(500) STRUCTURE + RRN 61 INTEGER PRECISION(9,0) + SAFETY_STOCK 145 COLUMN FOR SAFSTK IN PERPDEMO.ITEM + SAFSTK 145 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM + SEARCH 65 VARCHAR(30) + 147 148 149 + SELRRN 64 INTEGER PRECISION(9,0) + SHELF 145 VARCHAR(10) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + SHELF_CODE 145 COLUMN FOR SHELF IN PERPDEMO.ITEM + SHORT_DESCRIPTION 145 COLUMN FOR SHTDSC IN PERPDEMO.ITEM + SHTDSC 145 VARCHAR(20) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + SIDESC 35 CHARACTER(48) + SIITEM 35 CHARACTER(25) + SMSGKEY 35 CHARACTER(4) + SOPT 35 CHARACTER(1) + SPGMQ 35 CHARACTER(10) + SSEARCH 35 CHARACTER(30) + STATUSDS 49 STRUCTURE + STKUOM 145 VARCHAR(5) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + STOCKING_UOM 145 COLUMN FOR STKUOM IN PERPDEMO.ITEM + TEXT 196 VARCHAR(256) CONSTANT IN RPG PROCEDURE WRITEMSG + UPDAT 145 TIMESTAMP(26) COLUMN (NOT NULL) IN PERPDEMO.ITEM + UPDATED_AT 145 COLUMN FOR UPDAT IN PERPDEMO.ITEM + UPDATED_BY 145 COLUMN FOR UPDBY IN PERPDEMO.ITEM + UPDBY 145 VARCHAR(18) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object ITMPRMT 08/20/26 16:25:08 Page 9 + CROSS REFERENCE + WRITEMSG 194 RPG PROCEDURE + No errors found in source + 213 Source records processed + * * * * * E N D O F L I S T I N G * * * * * + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 1 + Command . . . . . . . . . . . . : CRTBNDRPG + Issued by . . . . . . . . . . : AIDEMO + Program . . . . . . . . . . . . : ITMPRMT + Library . . . . . . . . . . . : PERPDEMO + Text 'description' . . . . . . . : *SRCMBRTXT + Source stream file . . . . . . : /QSYS.LIB/QTEMP.LIB/QSQLTEMP1.FILE/ITMPRMT.MBR + CCSID . . . . . . . . . . . . : 37 + Target CCSID . . . . . . . . . . : *JOB (37) + Text 'description' . . . . . . . : + Last Change . . . . . . . . . . : 08/20/26 16:25:08 + Generation severity level . . . : 10 + Default activation group . . . . : *YES + Compiler options . . . . . . . . : *XREF *GEN *NOSECLVL *SHOWCPY + *EXPDDS *EXT *NOSHOWSKP *NOSRCSTMT + *DEBUGIO *UNREF *NOEVENTF + Debugging views . . . . . . . . : *ALL + Debug encryption key . . . . . . : *NONE + Output . . . . . . . . . . . . . : *PRINT + Optimization level . . . . . . . : *NONE + Source listing indentation . . . : *NONE + Type conversion options . . . . : *NONE + Sort sequence . . . . . . . . . : *JOB + Language identifier . . . . . . : *JOB + Replace program . . . . . . . . : *YES + User profile . . . . . . . . . . : *USER + Authority . . . . . . . . . . . : *LIBCRTAUT + Truncate numeric . . . . . . . . : *YES + Fix numeric . . . . . . . . . . : *NONE + Target release . . . . . . . . . : V7R4M0 + Allow null values . . . . . . . : *NO + Define condition names . . . . . : *NONE + Enable performance collection . : *PEP + Profiling data . . . . . . . . . : *NOCOL + Licensed Internal Code options . : + Generate program interface . . . : *NO + Include directory . . . . . . . : . + Preprocessor options . . . . . . : *NONE + Require prototype for export . . : *NO + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 2 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + S o u r c e L i s t i n g + 1 **free 000001 + 2 000002 + 3 // --------------------------------------------------------------------- 000003 + 4 // Program: itmprmt (standard, reusable Item Number prompt/lookup) 000004 + 5 // Purpose: System-wide "?" + Enter lookup for any keyable Item Number 000005 + 6 // field. Caller CALLs this program passing the company code 000006 + 7 // and the field's current value; typing '?' into the field 000007 + 8 // before Enter is the trigger convention every caller uses, 000008 + 9 // so this program treats a '?' seed the same as a blank 000009 + 10 // search (full list). Any other seed value pre-fills the 000010 + 11 // Search field so partial text the user already typed keeps 000011 + 12 // working as a filter. The subfile lists item_number + 000012 + 13 // item_description, filtered case-insensitively on either 000013 + 14 // column; 1=Select on a row returns that item_number in the 000014 + 15 // same parameter. F3/F12 cancel and return the field blank. 000015 + 16 // Model: perpselr's subfile-picker pattern (PERP-16), 000016 + 17 // adapted for field-level invocation instead of a full-screen 000017 + 18 // menu step. Called via a plain dynamic CALL (EXTPGM 000018 + 19 // prototype declared in each caller) -- the same idiom 000019 + 20 // wrkitmr already uses to call wrkcnvr/wrklotr -- not a bound 000020 + 21 // service program, so no bnddir/exports wiring is needed. 000021 + 22 // Callers: wrkcnvr (PERP-54), wrkitmr (PERP-57), wrkivnr (PERP-58), 000022 + 23 // wrkivpr (PERP-59), wrklotr (PERP-60), reqentr (PERP-61), 000023 + 24 // poentr (PERP-62). 000024 + 25 // Epic: PERP-51 (PERP-56) 000025 + 26 // --------------------------------------------------------------------- 000026 + 27 000027 + 28 ctl-opt dftactgrp(*no) actgrp(*new); 000028 + 29 000029 + *--------------------------------------------------------------------* + * Compiler Options in Effect: * + *--------------------------------------------------------------------* + * Text 'description' . . . . . . . : * + * Generation severity level . . . : 10 * + * Default activation group . . . . : *NO * + * Compiler options . . . . . . . . : *XREF *GEN * + * *NOSECLVL *SHOWCPY * + * *EXPDDS *EXT * + * *NOSHOWSKP *NOSRCSTMT * + * *DEBUGIO *UNREF * + * *NOEVENTF * + * Optimization level . . . . . . . : *NONE * + * Source listing indentation . . . : *NONE * + * Type conversion options . . . . : *NONE * + * Sort sequence . . . . . . . . . : *JOB * + * Language identifier . . . . . . : *JOB * + * User profile . . . . . . . . . . : *USER * + * Authority . . . . . . . . . . . : *LIBCRTAUT * + * Truncate numeric . . . . . . . . : *YES * + * Fix numeric . . . . . . . . . . : *NONE * + * Allow null values . . . . . . . : *NO * + * Storage model . . . . . . . . . : *SNGLVL * + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 3 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + * Binding directory from Command . : *NONE * + * Binding directory from Source . : *NONE * + * Activation group . . . . . . . . : *NEW * + * Enable performance collection . : *PEP * + * Profiling data . . . . . . . . . : *NOCOL * + * Generate program interface . . . : *NO * + * REQUIRE PROTOTYPE FOR EXPORT . . : *NO * + *--------------------------------------------------------------------* + 30 dcl-pi *n; 000030 + 31 pCompcd char(3) const; 000031 + 32 pItem varchar(25); 000032 + 33 end-pi; 000033 + 34 000034 + 35 dcl-f itmprm2d workstn sfile(itpsfl:rrn) sfile(itpmsgsfl:msgrrn); 000035 + *--------------------------------------------------------------------------------------------* + * RPG name External name * + * File name. . . . . . . . . : ITMPRM2D PERPDEMO/ITMPRM2D * + * Record format(s) . . . . . : ITPSFL ITPSFL * + * ITPCTL ITPCTL * + * ITPFOOT ITPFOOT * + * ITPNONE ITPNONE * + * ITPMSGSFL ITPMSGSFL * + * ITPMSGCTL ITPMSGCTL * + *--------------------------------------------------------------------------------------------* + 36 000036 + 37 dcl-pr QMHSNDPM extpgm; 000037 + 38 msgId char(7) const; 000038 + 39 msgF char(20) const; 000039 + 40 msgData char(256) const; 000040 + 41 msgDataLen int(10) const; 000041 + 42 msgType char(10) const; 000042 + 43 stackEntry char(10) const; 000043 + 44 stackCntr int(10) const; 000044 + 45 msgKey char(4); 000045 + 46 errorCode char(8) const; 000046 + 47 end-pr; 000047 + 48 000048 + 49 dcl-ds statusDS psds qualified; 000049 + 50 programName char(10) pos(334); 000050 + 51 end-ds; 000051 + 52 000052 + 53 dcl-ds itemRow qualified; 000053 + 54 item varchar(25); 000054 + 55 desc varchar(60); 000055 + 56 end-ds; 000056 + 57 000057 + 58 dcl-ds rows likeds(itemRow) dim(500); 000058 + 59 dcl-s numRows int(10); 000059 + 60 dcl-s i int(10); 000060 + 61 dcl-s rrn int(10); 000061 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 4 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 62 dcl-s msgrrn int(10); 000062 + 63 dcl-s msgkey char(4); 000063 + 64 dcl-s selRrn int(10); 000064 + 65 dcl-s search varchar(30); 000065 + 66 000066 + 67 /SET CCSID(*CHAR:*JOBRUNMIX) 000067 + 68 // SQL COMMUNICATION AREA //SQL 000068 + 69 DCL-DS SQLCA; //SQL 000069 + 70 SQLCAID CHAR(8) INZ(X'0000000000000000'); //SQL 000070 + 71 SQLAID CHAR(8) OVERLAY(SQLCAID); //SQL 000071 + 72 SQLCABC INT(10); //SQL 000072 + 73 SQLABC BINDEC(9) OVERLAY(SQLCABC); //SQL 000073 + 74 SQLCODE INT(10); //SQL 000074 + 75 SQLCOD BINDEC(9) OVERLAY(SQLCODE); //SQL 000075 + 76 SQLERRML INT(5); //SQL 000076 + 77 SQLERL BINDEC(4) OVERLAY(SQLERRML); //SQL 000077 + 78 SQLERRMC CHAR(70); //SQL 000078 + 79 SQLERM CHAR(70) OVERLAY(SQLERRMC); //SQL 000079 + 80 SQLERRP CHAR(8); //SQL 000080 + 81 SQLERP CHAR(8) OVERLAY(SQLERRP); //SQL 000081 + 82 SQLERR CHAR(24); //SQL 000082 + 83 SQLER1 BINDEC(9) OVERLAY(SQLERR:*NEXT); //SQL 000083 + 84 SQLER2 BINDEC(9) OVERLAY(SQLERR:*NEXT); //SQL 000084 + 85 SQLER3 BINDEC(9) OVERLAY(SQLERR:*NEXT); //SQL 000085 + 86 SQLER4 BINDEC(9) OVERLAY(SQLERR:*NEXT); //SQL 000086 + 87 SQLER5 BINDEC(9) OVERLAY(SQLERR:*NEXT); //SQL 000087 + 88 SQLER6 BINDEC(9) OVERLAY(SQLERR:*NEXT); //SQL 000088 + 89 SQLERRD INT(10) DIM(6) OVERLAY(SQLERR); //SQL 000089 + 90 SQLWRN CHAR(11); //SQL 000090 + 91 SQLWN0 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000091 + 92 SQLWN1 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000092 + 93 SQLWN2 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000093 + 94 SQLWN3 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000094 + 95 SQLWN4 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000095 + 96 SQLWN5 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000096 + 97 SQLWN6 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000097 + 98 SQLWN7 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000098 + 99 SQLWN8 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000099 + 100 SQLWN9 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000100 + 101 SQLWNA CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000101 + 102 SQLWARN CHAR(1) DIM(11) OVERLAY(SQLWRN); //SQL 000102 + 103 SQLSTATE CHAR(5); //SQL 000103 + 104 SQLSTT CHAR(5) OVERLAY(SQLSTATE); //SQL 000104 + 105 END-DS SQLCA; //SQL 000105 + 106 DCL-PR SQLROUTE_CALL EXTPGM(SQLROUTE); //SQL 000106 + 107 CA LIKEDS(SQLCA); //SQL 000107 + 108 *N BINDEC(4) OPTIONS(*NOPASS); //SQL 000108 + 109 *N CHAR(1) OPTIONS(*NOPASS); //SQL 000109 + 110 END-PR SQLROUTE_CALL; //SQL 000110 + 111 DCL-PR SQLOPEN_CALL EXTPGM(SQLOPEN); //SQL 000111 + 112 CA LIKEDS(SQLCA); //SQL 000112 + 113 *N BINDEC(4); //SQL 000113 + 114 END-PR SQLOPEN_CALL; //SQL 000114 + 115 DCL-PR SQLCLSE_CALL EXTPGM(SQLCLSE); //SQL 000115 + 116 CA LIKEDS(SQLCA); //SQL 000116 + 117 *N BINDEC(4); //SQL 000117 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 5 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 118 END-PR SQLCLSE_CALL; //SQL 000118 + 119 DCL-PR SQLCMIT_CALL EXTPGM(SQLCMIT); //SQL 000119 + 120 CA LIKEDS(SQLCA); //SQL 000120 + 121 *N BINDEC(4); //SQL 000121 + 122 END-PR SQLCMIT_CALL; //SQL 000122 + 123 /RESTORE CCSID(*CHAR) 000123 + 124 DCL-C SQLROUTE CONST('QSYS/QSQROUTE'); //SQL 000124 + 125 DCL-C SQLOPEN CONST('QSYS/QSQROUTE'); //SQL 000125 + 126 DCL-C SQLCLSE CONST('QSYS/QSQLCLSE'); //SQL 000126 + 127 DCL-C SQLCMIT CONST('QSYS/QSQLCMIT'); //SQL 000127 + 128 DCL-C SQFRD CONST(2); //SQL 000128 + 129 DCL-C SQFCRT CONST(8); //SQL 000129 + 130 DCL-C SQFOVR CONST(16); //SQL 000130 + 131 DCL-C SQFAPP CONST(32); //SQL 000131 + 132 **END-FREE 000132 + Line <---------------------- Source Specifications ----------------------------><---- Comments ----> Do Page Change Src Seq + Number ....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Line Date Id Number + 133 D DS OPEN 000133 + 134 D SQL_00000 1 2B 0 INZ(128) length of header 000134 + 135 D SQL_00001 3 4B 0 INZ(2) statement number 000135 + 136 D SQL_00002 5 8U 0 INZ(0) invocation mark 000136 + 137 D SQL_00003 9 9A INZ('0') CCSID(*JOBRUNMIX) data is okay 000137 + 138 D SQL_00004 10 128A CCSID(*JOBRUNMIX) end of header 000138 + 139 D SQL_00005 129 131A CCSID(*JOBRUNMIX) PCOMPCD 000139 + 140 D SQL_00006 132 163A VARYING CCSID(*JOBRUNMIX) SEARCH 000140 + 141 D SQL_00007 164 195A VARYING CCSID(*JOBRUNMIX) SEARCH 000141 + 142 D SQL_00008 196 227A VARYING CCSID(*JOBRUNMIX) SEARCH 000142 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 143 **FREE 000143 + 144 **END-FREE 000144 + Line <---------------------- Source Specifications ----------------------------><---- Comments ----> Do Page Change Src Seq + Number ....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Line Date Id Number + 145 D DS FETCH 000145 + 146 D SQL_00009 1 2B 0 INZ(128) length of header 000146 + 147 D SQL_00010 3 4B 0 INZ(3) statement number 000147 + 148 D SQL_00011 5 8U 0 INZ(0) invocation mark 000148 + 149 D SQL_00012 9 9A INZ('0') CCSID(*JOBRUNMIX) data is okay 000149 + 150 D SQL_00013 10 128A CCSID(*JOBRUNMIX) end of header 000150 + 151 D SQL_00014 129 155A VARYING CCSID(*JOBRUNMIX) ITEMROW.ITEM 000151 + 152 D SQL_00015 156 217A VARYING CCSID(*JOBRUNMIX) ITEMROW.DESC 000152 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 153 **FREE 000153 + 154 **END-FREE 000154 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 6 + Line <---------------------- Source Specifications ----------------------------><---- Comments ----> Do Page Change Src Seq + Number ....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Line Date Id Number + 155 D DS CLOSE 000155 + 156 D SQL_00016 1 2B 0 INZ(128) length of header 000156 + 157 D SQL_00017 3 4B 0 INZ(4) statement number 000157 + 158 D SQL_00018 5 8U 0 INZ(0) invocation mark 000158 + 159 D SQL_00019 9 9A INZ('0') CCSID(*JOBRUNMIX) data is okay 000159 + 160 D SQL_00020 10 127A CCSID(*JOBRUNMIX) end of header 000160 + 161 D SQL_00021 128 128A CCSID(*JOBRUNMIX) end of header 000161 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 162 **FREE 000162 + 163=IITPSFL 1000001 + *--------------------------------------------------------------------------------------------* 1 + * RPG record format . . . . : ITPSFL * 1 + * External format . . . . . : ITPSFL : PERPDEMO/ITMPRM2D * 1 + *--------------------------------------------------------------------------------------------* 1 + 164=I N 1 1 *IN03 Exit 1000002 + 165=I N 2 2 *IN05 Refresh 1000003 + 166=I N 3 3 *IN12 Cancel 1000004 + 167=I A 4 4 SOPT 1000005 + 168=I A 5 29 SIITEM 1000006 + 169=I A 30 77 SIDESC 1000007 + 170=IITPCTL 2000001 + *--------------------------------------------------------------------------------------------* 2 + * RPG record format . . . . : ITPCTL * 2 + * External format . . . . . : ITPCTL : PERPDEMO/ITMPRM2D * 2 + *--------------------------------------------------------------------------------------------* 2 + 171=I N 1 1 *IN03 Exit 2000002 + 172=I N 2 2 *IN05 Refresh 2000003 + 173=I N 3 3 *IN12 Cancel 2000004 + 174=I A 4 33 SSEARCH 2000005 + 175=IITPFOOT 3000001 + *--------------------------------------------------------------------------------------------* 3 + * RPG record format . . . . : ITPFOOT * 3 + * External format . . . . . : ITPFOOT : PERPDEMO/ITMPRM2D * 3 + *--------------------------------------------------------------------------------------------* 3 + 176=I N 1 1 *IN03 Exit 3000002 + 177=I N 2 2 *IN05 Refresh 3000003 + 178=I N 3 3 *IN12 Cancel 3000004 + 179=IITPNONE 4000001 + *--------------------------------------------------------------------------------------------* 4 + * RPG record format . . . . : ITPNONE * 4 + * External format . . . . . : ITPNONE : PERPDEMO/ITMPRM2D * 4 + *--------------------------------------------------------------------------------------------* 4 + 180=I N 1 1 *IN03 Exit 4000002 + 181=I N 2 2 *IN05 Refresh 4000003 + 182=I N 3 3 *IN12 Cancel 4000004 + 183=IITPMSGSFL 5000001 + *--------------------------------------------------------------------------------------------* 5 + * RPG record format . . . . : ITPMSGSFL * 5 + * External format . . . . . : ITPMSGSFL : PERPDEMO/ITMPRM2D * 5 + *--------------------------------------------------------------------------------------------* 5 + 184=I N 1 1 *IN03 Exit 5000002 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 7 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 185=I N 2 2 *IN05 Refresh 5000003 + 186=I N 3 3 *IN12 Cancel 5000004 + 187=I A 4 7 SMSGKEY 5000005 + 188=I A 8 17 SPGMQ 5000006 + 189=IITPMSGCTL 6000001 + *--------------------------------------------------------------------------------------------* 6 + * RPG record format . . . . : ITPMSGCTL * 6 + * External format . . . . . : ITPMSGCTL : PERPDEMO/ITMPRM2D * 6 + *--------------------------------------------------------------------------------------------* 6 + 190=I N 1 1 *IN03 Exit 6000002 + 191=I N 2 2 *IN05 Refresh 6000003 + 192=I N 3 3 *IN12 Cancel 6000004 + 193 search = %trim(pItem); 000163 + 194 if search = '?'; B01 000164 + 195 search = ''; 01 000165 + 196 endif; E01 000166 + 197 ssearch = search; 000167 + 198 000168 + 199 dow not *in03 and not *in12; B01 000169 + 200 exsr clearMsgs; 01 000170 + 201 exsr loadRows; 01 000171 + 202 000172 + 203 if numRows = 0; B02 000173 + 204 *in30 = *off; 02 000174 + 205 write itpnone; 02 000175 + 206 else; X02 000176 + 207 exsr fillSubfile; 02 000177 + 208 *in30 = *on; 02 000178 + 209 endif; E02 000179 + 210 000180 + 211 write itpfoot; 01 000181 + 212 if msgrrn > 0; B02 000182 + 213 *in40 = *on; 02 000183 + 214 write itpmsgctl; 02 000184 + 215 else; X02 000185 + 216 *in40 = *off; 02 000186 + 217 endif; E02 000187 + 218 000188 + 219 exfmt itpctl; 01 000189 + 220 000190 + 221 if *in03 or *in12; B02 000191 + 222 pItem = ''; 02 000192 + 223 leave; 02 000193 + 224 endif; E02 000194 + 225 000195 + 226 if *in05; B02 000196 + 227 iter; 02 000197 + 228 endif; E02 000198 + 229 000199 + 230 if ssearch <> search; B02 000200 + 231 search = %trim(ssearch); 02 000201 + 232 iter; 02 000202 + 233 endif; E02 000203 + 234 000204 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 8 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 235 // Guard on numRows: READC against a subfile that was never written 000205 + 236 // to this cycle (0 rows loaded) raises a "Session or device error" 000206 + 237 // (CPF5006-class) runtime error instead of just returning *EOF. 000207 + 238 if numRows > 0; B02 000208 + 239 selRrn = 0; 02 000209 + 240 readc itpsfl; 02 000210 + 241 dow not %eof(itmprm2d); B03 000211 + 242 if sopt = '1'; B04 000212 + 243 if selRrn = 0; B05 000213 + 244 selRrn = rrn; 05 000214 + 245 else; X05 000215 + 246 writeMsg('Only one item may be selected per Enter.'); 05 000216 + 247 endif; E05 000217 + 248 elseif sopt <> ''; X04 000218 + 249 writeMsg('Option ' + sopt + ' is not valid - use 1.'); 04 000219 + 250 endif; E04 000220 + 251 readc itpsfl; 03 000221 + 252 enddo; E03 000222 + 253 endif; E02 000223 + 254 000224 + 255 if selRrn > 0 and msgrrn = 0; B02 000225 + 256 chain selRrn itpsfl; 02 000226 + 257 pItem = siitem; 02 000227 + 258 leave; 02 000228 + 259 endif; E02 000229 + 260 000230 + 261 enddo; E01 000231 + 262 000232 + 263 *inlr = *on; 000233 + 264 return; 000234 + 265 000235 + 266 // --------------------------------------------------------------------- 000236 + 267 begsr loadRows; 000237 + 268 numRows = 0; 000238 + 269 //* exec sql declare ip1 cursor for 000239 + 270 //* select item_number, item_description 000240 + 271 //* from perpdemo.item 000241 + 272 //* where company_code = :pCompcd 000242 + 273 //* and (:search = '' 000243 + 274 //* or upper(item_number) like '%' || upper(:search) || '%' 000244 + 275 //* or upper(item_description) like '%' || upper(:search) || '%') 000245 + 276 //* order by item_number; 000246 + 277 //* exec sql open ip1; 000247 + 278 SQL_00005 = PCOMPCD; //SQL 000248 + 279 SQL_00006 = SEARCH; //SQL 000249 + 280 SQL_00007 = SEARCH; //SQL 000250 + 281 SQL_00008 = SEARCH; //SQL 000251 + 282 SQLER6 = -4; //SQL 000252 + 283 IF SQL_00002 = 0 //SQL B01 000253 + 284 OR SQL_00003 <> *LOVAL; //SQL B01 000254 + 285 SQLROUTE_CALL( //SQL 01 000255 + 286 SQLCA //SQL 01 000256 + 287 : SQL_00000 //SQL 01 000257 + 288 ); //SQL 01 000258 + 289 ELSE; //SQL X01 000259 + 290 SQLOPEN_CALL( //SQL 01 000260 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 9 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 291 SQLCA //SQL 01 000261 + 292 : SQL_00000 //SQL 01 000262 + 293 ); //SQL 01 000263 + 294 ENDIF; //SQL E01 000264 + 295 if sqlcode < 0; B01 000265 + 296 writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); 01 000266 + 297 leavesr; 01 000267 + 298 endif; E01 000268 + 299 000269 + 300 dow numRows < %elem(rows); B01 000270 + 301 //* exec sql fetch ip1 into :itemRow; 000271 + 302 SQLER6 = -4; //SQL 3 01 000272 + 303 SQLROUTE_CALL( //SQL 01 000273 + 304 SQLCA //SQL 01 000274 + 305 : SQL_00009 //SQL 01 000275 + 306 ); //SQL 01 000276 + 307 IF SQL_00012 = '1'; //SQL B02 000277 + 308 EVAL ITEMROW.ITEM = SQL_00014; //SQL 02 000278 + 309 EVAL ITEMROW.DESC = SQL_00015; //SQL 02 000279 + 310 ENDIF; //SQL E02 000280 + 311 if sqlcode = 100 or sqlcode < 0; B02 000281 + 312 leave; 02 000282 + 313 endif; E02 000283 + 314 numRows += 1; 01 000284 + 315 rows(numRows) = itemRow; 01 000285 + 316 enddo; E01 000286 + 317 //* exec sql close ip1; 000287 + 318 SQLER6 = 4; //SQL 000288 + 319 IF SQL_00018 = 0; //SQL B01 000289 + 320 SQLROUTE_CALL( //SQL 01 000290 + 321 SQLCA //SQL 01 000291 + 322 : SQL_00016 //SQL 01 000292 + 323 ); //SQL 01 000293 + 324 ELSE; //SQL X01 000294 + 325 SQLCLSE_CALL( //SQL 01 000295 + 326 SQLCA //SQL 01 000296 + 327 : SQL_00016 //SQL 01 000297 + 328 ); //SQL 01 000298 + 329 ENDIF; //SQL E01 000299 + 330 endsr; 000300 + 331 000301 + 332 // --------------------------------------------------------------------- 000302 + 333 begsr fillSubfile; 000303 + 334 rrn = 0; 000304 + 335 *in31 = *on; 000305 + 336 write itpctl; 000306 + 337 *in31 = *off; 000307 + 338 for i = 1 to numRows; B01 000308 + 339 *in50 = *off; 01 000309 + 340 *in51 = *off; 01 000310 + 341 sopt = ''; 01 000311 + 342 siitem = rows(i).item; 01 000312 + 343 sidesc = %subst(rows(i).desc : 1 : %min(%len(rows(i).desc) : 48)); 01 000313 + 344 rrn += 1; 01 000314 + 345 write itpsfl; 01 000315 + 346 endfor; E01 000316 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 10 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 347 endsr; 000317 + 348 000318 + 349 // --------------------------------------------------------------------- 000319 + 350 begsr clearMsgs; 000320 + 351 msgrrn = 0; 000321 + 352 *in41 = *on; 000322 + 353 write itpmsgctl; 000323 + 354 *in41 = *off; 000324 + 355 endsr; 000325 + 356 000326 + 357 // --------------------------------------------------------------------- 000327 + 358=OITPSFL 7000001 + *--------------------------------------------------------------------------------------------* 7 + * RPG record format . . . . : ITPSFL * 7 + * External format . . . . . : ITPSFL : PERPDEMO/ITMPRM2D * 7 + *--------------------------------------------------------------------------------------------* 7 + 359=O *IN50 2N CHAR 1 7000002 + 360=O *IN51 1N CHAR 1 7000003 + 361=O SOPT 3A CHAR 1 7000004 + 362=O SIITEM 28A CHAR 25 7000005 + 363=O SIDESC 76A CHAR 48 7000006 + 364=OITPCTL 8000001 + *--------------------------------------------------------------------------------------------* 8 + * RPG record format . . . . : ITPCTL * 8 + * External format . . . . . : ITPCTL : PERPDEMO/ITMPRM2D * 8 + *--------------------------------------------------------------------------------------------* 8 + 365=O *IN30 2N CHAR 1 8000002 + 366=O *IN31 1N CHAR 1 8000003 + 367=O SSEARCH 32A CHAR 30 8000004 + 368=OITPFOOT 9000001 + *--------------------------------------------------------------------------------------------* 9 + * RPG record format . . . . : ITPFOOT * 9 + * External format . . . . . : ITPFOOT : PERPDEMO/ITMPRM2D * 9 + *--------------------------------------------------------------------------------------------* 9 + 369=OITPNONE 10000001 + *--------------------------------------------------------------------------------------------* 10 + * RPG record format . . . . : ITPNONE * 10 + * External format . . . . . : ITPNONE : PERPDEMO/ITMPRM2D * 10 + *--------------------------------------------------------------------------------------------* 10 + 370=OITPMSGSFL 11000001 + *--------------------------------------------------------------------------------------------* 11 + * RPG record format . . . . : ITPMSGSFL * 11 + * External format . . . . . : ITPMSGSFL : PERPDEMO/ITMPRM2D * 11 + *--------------------------------------------------------------------------------------------* 11 + 371=O SMSGKEY 4A CHAR 4 11000002 + 372=O SPGMQ 14A CHAR 10 11000003 + 373=OITPMSGCTL 12000001 + *--------------------------------------------------------------------------------------------* 12 + * RPG record format . . . . : ITPMSGCTL * 12 + * External format . . . . . : ITPMSGCTL : PERPDEMO/ITMPRM2D * 12 + *--------------------------------------------------------------------------------------------* 12 + 374=O *IN40 2N CHAR 1 12000002 + 375=O *IN41 1N CHAR 1 12000003 + 376 dcl-proc writeMsg; 000328 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 11 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 377 dcl-pi *n; 000329 + 378 text varchar(256) const; 000330 + 379 end-pi; 000331 + 380 dcl-s data char(256); 000332 + 381 data = text; 000333 + 382 QMHSNDPM( 000334 + 383 'CPF9897' : 000335 + 384 'QCPFMSG QSYS ' : 000336 + 385 data : 000337 + 386 %len(text) : 000338 + 387 '*INFO ' : 000339 + 388 '* ' : 000340 + 389 1 : 000341 + 390 smsgkey : 000342 + 391 x'0000000000000000'); 000343 + 392 msgrrn += 1; 000344 + 393 spgmq = statusDS.programName; 000345 + 394 write itpmsgsfl; 000346 + 395 end-proc; 000347 + * * * * * E N D O F S O U R C E * * * * * + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 12 + A d d i t i o n a l D i a g n o s t i c M e s s a g e s + Msg id Sv Number Seq Message text + * * * * * E N D O F A D D I T I O N A L D I A G N O S T I C M E S S A G E S * * * * * + O u t p u t B u f f e r P o s i t i o n s + Line Start End Field or Constant + Number Pos Pos + 359 2 2 *IN50 + 360 1 1 *IN51 + 361 3 3 SOPT + 362 4 28 SIITEM + 363 29 76 SIDESC + 359 2 2 *IN50 + 360 1 1 *IN51 + 361 3 3 SOPT + 362 4 28 SIITEM + 363 29 76 SIDESC + 365 2 2 *IN30 + 366 1 1 *IN31 + 367 3 32 SSEARCH + 365 2 2 *IN30 + 366 1 1 *IN31 + 367 3 32 SSEARCH + 371 1 4 SMSGKEY + 372 5 14 SPGMQ + 371 1 4 SMSGKEY + 372 5 14 SPGMQ + 374 2 2 *IN40 + 375 1 1 *IN41 + 374 2 2 *IN40 + 375 1 1 *IN41 + * * * * * E N D O F O U T P U T B U F F E R P O S I T I O N * * * * * + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 13 + C r o s s R e f e r e n c e + File and Record References: + File Device References (D=Defined) + Record + ITMPRM2D WORKSTN 35D 241 + ITPSFL 35D 163 240 251 + 256 345 358 + ITPCTL 35D 170 219 336 + 364 + ITPFOOT 35D 175 211 368 + ITPNONE 35D 179 205 369 + ITPMSGSFL 35D 183 370 394 + ITPMSGCTL 35D 189 214 353 + 373 + Global Field References: + Field Attributes References (D=Defined M=Modified) + *INLR N(1) 263M + *IN03 N(1) 164D 171M 176M 180M + 184M 190M 199 221 + *IN05 N(1) 165D 172M 177M 181M + 185M 191M 226 + *IN12 N(1) 166D 173M 178M 182M + 186M 192M 199 221 + *IN30 N(1) 204M 208M 365 + *IN31 N(1) 335M 337M 366 + *IN40 N(1) 213M 216M 374 + *IN41 N(1) 352M 354M 375 + *IN50 N(1) 339M 359 + *IN51 N(1) 340M 360 + CLEARMSGS BEGSR 200 350D + FILLSUBFILE BEGSR 207 333D + I I(10,0) 60D 338 342 343 + 343 + ITEMROW DS(89) 53D 58 308M 309M + 315 + DESC A(60) 55D 309 + VARYING(2) + ITEM A(25) 54D 308 + VARYING(2) + LOADROWS BEGSR 201 267D + *RNF7031 MSGKEY A(4) 63D + MSGRRN I(10,0) 35 62D 212 255 + 351M 392M + NUMROWS I(10,0) 59D 203 238 268M + 300 314M 315 338 + PCOMPCD A(3) 31D 278 + BASED(_QRNL_PRM+) + PITEM A(25) 32D 193 222M 257M + BASED(_QRNL_PRM+) + VARYING(2) + QMHSNDPM PROTOTYPE 37D 382M + ROWS(500) DS(89) 58D 300 315M 342 + 343 343 + DESC A(60) 343 343 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 14 + VARYING(2) + ITEM A(25) 342 + VARYING(2) + RRN I(10,0) 35 61D 244 334M + 344M + SEARCH A(30) 65D 193M 194 195M + VARYING(2) 197 230 231M 279 + 280 281 + SELRRN I(10,0) 64D 239M 243 244M + 255 256 + SIDESC A(48) 169M 343M 363 + SIITEM A(25) 168M 257 342M 362 + SMSGKEY A(4) 187M 371 390 + SOPT A(1) 167M 242 248 249 + 341M 361 + SPGMQ A(10) 188M 372 393M + *RNF7031 SQFAPP CONST 131D + *RNF7031 SQFCRT CONST 129D + *RNF7031 SQFOVR CONST 130D + *RNF7031 SQFRD CONST 128D + SQL_00000 B(4,0) 134D 287 292 + *RNF7031 SQL_00001 B(4,0) 135D + SQL_00002 U(10,0) 136D 283 + SQL_00003 A(1) 137D 284 + *RNF7031 SQL_00004 A(119) 138D + SQL_00005 A(3) 139D 278M + SQL_00006 A(30) 140D 279M + VARYING(2) + SQL_00007 A(30) 141D 280M + VARYING(2) + SQL_00008 A(30) 142D 281M + VARYING(2) + SQL_00009 B(4,0) 146D 305 + *RNF7031 SQL_00010 B(4,0) 147D + *RNF7031 SQL_00011 U(10,0) 148D + SQL_00012 A(1) 149D 307 + *RNF7031 SQL_00013 A(119) 150D + SQL_00014 A(25) 151D 308 + VARYING(2) + SQL_00015 A(60) 152D 309 + VARYING(2) + SQL_00016 B(4,0) 156D 322 327 + *RNF7031 SQL_00017 B(4,0) 157D + SQL_00018 U(10,0) 158D 319 + *RNF7031 SQL_00019 A(1) 159D + *RNF7031 SQL_00020 A(118) 160D + *RNF7031 SQL_00021 A(1) 161D + *RNF7031 SQLABC B(9,0) 73D + *RNF7031 SQLAID A(8) 71D + SQLCA DS(136) 69D 107 112 116 + 120 286 291 304 + 321 326 + SQLCABC I(10,0) 72D 73 + SQLCAID A(8) 70D 71 + SQLCLSE CONST 115 126D + SQLCLSE_CALL PROTOTYPE 115D 325M + SQLCMIT CONST 119 127D + *RNF7031 SQLCMIT_CALL PROTOTYPE 119D + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 15 + *RNF7031 SQLCOD B(9,0) 75D + SQLCODE I(10,0) 74D 75 295 296 + 311 311 + *RNF7031 SQLERL B(4,0) 77D + *RNF7031 SQLERM A(70) 79D + *RNF7031 SQLERP A(8) 81D + SQLERR A(24) 82D 83 84 85 + 86 87 88 89 + *RNF7031 SQLERRD(6) I(10,0) 89D + SQLERRMC A(70) 78D 79 + SQLERRML I(5,0) 76D 77 + SQLERRP A(8) 80D 81 + *RNF7031 SQLER1 B(9,0) 83D + *RNF7031 SQLER2 B(9,0) 84D + *RNF7031 SQLER3 B(9,0) 85D + *RNF7031 SQLER4 B(9,0) 86D + *RNF7031 SQLER5 B(9,0) 87D + SQLER6 B(9,0) 88D 282M 302M 318M + SQLOPEN CONST 111 125D + SQLOPEN_CALL PROTOTYPE 111D 290M + SQLROUTE CONST 106 124D + SQLROUTE_CALL PROTOTYPE 106D 285M 303M 320M + SQLSTATE A(5) 103D 104 + *RNF7031 SQLSTT A(5) 104D + *RNF7031 SQLWARN(11) A(1) 102D + *RNF7031 SQLWNA A(1) 101D + *RNF7031 SQLWN0 A(1) 91D + *RNF7031 SQLWN1 A(1) 92D + *RNF7031 SQLWN2 A(1) 93D + *RNF7031 SQLWN3 A(1) 94D + *RNF7031 SQLWN4 A(1) 95D + *RNF7031 SQLWN5 A(1) 96D + *RNF7031 SQLWN6 A(1) 97D + *RNF7031 SQLWN7 A(1) 98D + *RNF7031 SQLWN8 A(1) 99D + *RNF7031 SQLWN9 A(1) 100D + SQLWRN A(11) 90D 91 92 93 + 94 95 96 97 + 98 99 100 101 + 102 + SSEARCH A(30) 174M 197M 230 231 + 367 + STATUSDS DS(343) 49D 393 + PROGRAMNAME A(10) 50D 393 + WRITEMSG PROTOTYPE 246M 249M 296M 376 + Field References for subprocedure WRITEMSG + Field Attributes References (D=Defined M=Modified) + DATA A(256) 380D 381M 385 + TEXT A(256) 378D 381 386 + BASED(_QRNL_PST+) + VARYING(2) + Indicator References: + Indicator References (D=Defined M=Modified) + 03 164M 171M 176M 180M + 184M 190M 199 221 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 16 + 05 165M 172M 177M 181M + 185M 191M 226 + 12 166M 173M 178M 182M + 186M 192M 199 221 + 30 204M 208M 365 + 31 335M 337M 366 + 40 213M 216M 374 + 41 352M 354M 375 + 50 339M 359 + 51 340M 360 + LR 263M + * * * * * E N D O F C R O S S R E F E R E N C E * * * * * + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 17 + E x t e r n a l R e f e r e n c e s + Statically bound procedures: + Procedure References + Imported fields: + Field Attributes Defined + No references in the source. + Exported fields: + Field Attributes Defined + No references in the source. + * * * * * E N D O F E X T E R N A L R E F E R E N C E S * * * * * + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 18 + M e s s a g e S u m m a r y + Msg id Sv Number Message text + *RNF7031 00 40 The name or indicator is not referenced. + * * * * * E N D O F M E S S A G E S U M M A R Y * * * * * + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 19 + F i n a l S u m m a r y + Message Totals: + Information (00) . . . . . . . : 40 + Warning (10) . . . . . . . : 0 + Error (20) . . . . . . . : 0 + Severe Error (30+) . . . . . . : 0 + --------------------------------- ------- + Total . . . . . . . . . . . . . : 40 + Source Totals: + Records . . . . . . . . . . . . : 395 + Specifications . . . . . . . . : 316 + Data records . . . . . . . . . : 0 + Comments . . . . . . . . . . . : 68 + * * * * * E N D O F F I N A L S U M M A R Y * * * * * + Program ITMPRMT placed in library PERPDEMO. 00 highest severity. Created on 08/20/26 at 16:25:09. + * * * * * E N D O F C O M P I L A T I O N * * * * * From c3ea980f74311338c83a07136f3656bea04324e8 Mon Sep 17 00:00:00 2001 From: Gary Jones Date: Thu, 20 Aug 2026 21:38:43 +0000 Subject: [PATCH 12/13] PERP-55: fix From/To heading-to-data misalignment on wrkcnvd.dspf (attribute-byte gap cascade) The From heading sat one column right of its own SFROM data field because every named DDS field reserves a hidden attribute-byte column immediately before its start, and the Opt heading's trailing character occupied the slot From's own attribute byte needed. Fixed by shifting the whole downstream chain by one column in both records: SFROM/STO/SFACT in the subfile data record, and To/Factor in the heading record. Compiles clean with zero warnings (previous single-field attempts each threw CPD7866 field-overlap warnings). Live-verified: From/CS and To/EA now land on exactly the same columns. Co-Authored-By: CoderFlow Learn more: https://coderflow.ai --- perp/qddssrc/wrkcnvd.dspf | 10 +- perp/tmp/logs/itmprmt.pgm.log | 1501 -------------------------------- perp/tmp/logs/wrkcnvd.file.log | 205 +++++ 3 files changed, 210 insertions(+), 1506 deletions(-) delete mode 100644 perp/tmp/logs/itmprmt.pgm.log create mode 100644 perp/tmp/logs/wrkcnvd.file.log diff --git a/perp/qddssrc/wrkcnvd.dspf b/perp/qddssrc/wrkcnvd.dspf index b41b7438..3ac43249 100644 --- a/perp/qddssrc/wrkcnvd.dspf +++ b/perp/qddssrc/wrkcnvd.dspf @@ -9,9 +9,9 @@ A SOPT 1A B 8 2 A 50 DSPATR(RI) A 50 DSPATR(PC) - A SFROM 5A O 8 5 - A STO 5A O 8 11 - A SFACT 15Y 6O 8 17EDTCDE(3) + A SFROM 5A O 8 6 + A STO 5A O 8 12 + A SFACT 15Y 6O 8 18EDTCDE(3) A R CVCTL SFLCTL(CVSFL) A SFLSIZ(0099) A SFLPAG(0007) @@ -33,9 +33,9 @@ A DSPATR(UL) A 7 6'From' A DSPATR(UL) - A 7 11'To' + A 7 12'To' A DSPATR(UL) - A 7 29'Factor' + A 7 27'Factor' A DSPATR(UL) A R CVFOOT A 23 2'F3=Exit F5=Refresh F6=Add- diff --git a/perp/tmp/logs/itmprmt.pgm.log b/perp/tmp/logs/itmprmt.pgm.log deleted file mode 100644 index 33ef92a4..00000000 --- a/perp/tmp/logs/itmprmt.pgm.log +++ /dev/null @@ -1,1501 +0,0 @@ -CPC7301: File QSQLPRE created in library QTEMP. -CPC7305: Member ITMPRMT added to file QSQLPRE in QTEMP. -CPC3201: Member ITMPRMT file QSQLPRE in QTEMP changed. -RNS9307: Diagnostic check of source is complete. Highest severity is 00. -CPC0904: Data area RETURNCODE created in library QTEMP. -CPC7301: File QSQLTEMP1 created in library QTEMP. -CPC7305: Member ITMPRMT added to file QSQLTEMP1 in QTEMP. -CPI2119: AUT and USRPRF parameter values were ignored. -CPI2121: Replaced object ITMPRMT type *PGM was moved to QRPLOBJ. -RNS9304: Program ITMPRMT placed in library PERPDEMO. 00 highest severity. Created on 08/20/26 at 16:25:09. - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 1 - Command . . . . . . . . . . . . : CRTBNDRPG - Issued by . . . . . . . . . . : AIDEMO - Program . . . . . . . . . . . . : ITMPRMT - Library . . . . . . . . . . . : PERPDEMO - Text 'description' . . . . . . . : *SRCMBRTXT - Source stream file . . . . . . : qrpglesrc/itmprmt.sqlrpgle - CCSID . . . . . . . . . . . . : 1208 - Target CCSID . . . . . . . . . . : *JOB (37) - Text 'description' . . . . . . . : - Last Change . . . . . . . . . . : 08/20/26 16:25:03 - Generation severity level . . . : 10 - Default activation group . . . . : *YES - Compiler options . . . . . . . . : *XREF *GEN *NOSECLVL *SHOWCPY - *EXPDDS *EXT *NOSHOWSKP *NOSRCSTMT - *DEBUGIO *UNREF *NOEVENTF - Debugging views . . . . . . . . : *ALL - Debug encryption key . . . . . . : *NONE - Output . . . . . . . . . . . . . : *PRINT - Optimization level . . . . . . . : *NONE - Source listing indentation . . . : *NONE - Type conversion options . . . . : *NONE - Sort sequence . . . . . . . . . : *JOB - Language identifier . . . . . . : *JOB - Replace program . . . . . . . . : *YES - User profile . . . . . . . . . . : *USER - Authority . . . . . . . . . . . : *LIBCRTAUT - Truncate numeric . . . . . . . . : *YES - Fix numeric . . . . . . . . . . : *NONE - Target release . . . . . . . . . : V7R4M0 - Allow null values . . . . . . . : *NO - Define condition names . . . . . : *NONE - Enable performance collection . : *PEP - Profiling data . . . . . . . . . : *NOCOL - Licensed Internal Code options . : - Generate program interface . . . : *NO - Include directory . . . . . . . : . - Preprocessor options . . . . . . : *NORMVCOMMENT *EXPINCLUDE *NOSEQSRC - Output source file . . . . . . . : QSQLPRE - Library . . . . . . . . . . . : QTEMP - Output source member . . . . . . : ITMPRMT - MINIMUM OUTPUT LINE LENGTH . . . : 100 - Require prototype for export . . : *NO - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 2 - Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq - Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number - S o u r c e L i s t i n g - 1 **free 000001 - 2 000002 - 3 // --------------------------------------------------------------------- 000003 - 4 // Program: itmprmt (standard, reusable Item Number prompt/lookup) 000004 - 5 // Purpose: System-wide "?" + Enter lookup for any keyable Item Number 000005 - 6 // field. Caller CALLs this program passing the company code 000006 - 7 // and the field's current value; typing '?' into the field 000007 - 8 // before Enter is the trigger convention every caller uses, 000008 - 9 // so this program treats a '?' seed the same as a blank 000009 - 10 // search (full list). Any other seed value pre-fills the 000010 - 11 // Search field so partial text the user already typed keeps 000011 - 12 // working as a filter. The subfile lists item_number + 000012 - 13 // item_description, filtered case-insensitively on either 000013 - 14 // column; 1=Select on a row returns that item_number in the 000014 - 15 // same parameter. F3/F12 cancel and return the field blank. 000015 - 16 // Model: perpselr's subfile-picker pattern (PERP-16), 000016 - 17 // adapted for field-level invocation instead of a full-screen 000017 - 18 // menu step. Called via a plain dynamic CALL (EXTPGM 000018 - 19 // prototype declared in each caller) -- the same idiom 000019 - 20 // wrkitmr already uses to call wrkcnvr/wrklotr -- not a bound 000020 - 21 // service program, so no bnddir/exports wiring is needed. 000021 - 22 // Callers: wrkcnvr (PERP-54), wrkitmr (PERP-57), wrkivnr (PERP-58), 000022 - 23 // wrkivpr (PERP-59), wrklotr (PERP-60), reqentr (PERP-61), 000023 - 24 // poentr (PERP-62). 000024 - 25 // Epic: PERP-51 (PERP-56) 000025 - 26 // --------------------------------------------------------------------- 000026 - 27 000027 - 28 ctl-opt dftactgrp(*no) actgrp(*new); 000028 - 29 000029 - 30 dcl-pi *n; 000030 - 31 pCompcd char(3) const; 000031 - 32 pItem varchar(25); 000032 - 33 end-pi; 000033 - 34 000034 - 35 dcl-f itmprm2d workstn sfile(itpsfl:rrn) sfile(itpmsgsfl:msgrrn); 000035 - 36 000036 - 37 dcl-pr QMHSNDPM extpgm; 000037 - 38 msgId char(7) const; 000038 - 39 msgF char(20) const; 000039 - 40 msgData char(256) const; 000040 - 41 msgDataLen int(10) const; 000041 - 42 msgType char(10) const; 000042 - 43 stackEntry char(10) const; 000043 - 44 stackCntr int(10) const; 000044 - 45 msgKey char(4); 000045 - 46 errorCode char(8) const; 000046 - 47 end-pr; 000047 - 48 000048 - 49 dcl-ds statusDS psds qualified; 000049 - 50 programName char(10) pos(334); 000050 - 51 end-ds; 000051 - 52 000052 - 53 dcl-ds itemRow qualified; 000053 - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 3 - Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq - Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number - 54 item varchar(25); 000054 - 55 desc varchar(60); 000055 - 56 end-ds; 000056 - 57 000057 - 58 dcl-ds rows likeds(itemRow) dim(500); 000058 - 59 dcl-s numRows int(10); 000059 - 60 dcl-s i int(10); 000060 - 61 dcl-s rrn int(10); 000061 - 62 dcl-s msgrrn int(10); 000062 - 63 dcl-s msgkey char(4); 000063 - 64 dcl-s selRrn int(10); 000064 - 65 dcl-s search varchar(30); 000065 - 66 000066 - 67 search = %trim(pItem); 000067 - 68 if search = '?'; 000068 - 69 search = ''; 000069 - 70 endif; 000070 - 71 ssearch = search; 000071 - 72 000072 - 73 dow not *in03 and not *in12; 000073 - 74 exsr clearMsgs; 000074 - 75 exsr loadRows; 000075 - 76 000076 - 77 if numRows = 0; 000077 - 78 *in30 = *off; 000078 - 79 write itpnone; 000079 - 80 else; 000080 - 81 exsr fillSubfile; 000081 - 82 *in30 = *on; 000082 - 83 endif; 000083 - 84 000084 - 85 write itpfoot; 000085 - 86 if msgrrn > 0; 000086 - 87 *in40 = *on; 000087 - 88 write itpmsgctl; 000088 - 89 else; 000089 - 90 *in40 = *off; 000090 - 91 endif; 000091 - 92 000092 - 93 exfmt itpctl; 000093 - 94 000094 - 95 if *in03 or *in12; 000095 - 96 pItem = ''; 000096 - 97 leave; 000097 - 98 endif; 000098 - 99 000099 - 100 if *in05; 000100 - 101 iter; 000101 - 102 endif; 000102 - 103 000103 - 104 if ssearch <> search; 000104 - 105 search = %trim(ssearch); 000105 - 106 iter; 000106 - 107 endif; 000107 - 108 000108 - 109 // Guard on numRows: READC against a subfile that was never written 000109 - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 4 - Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq - Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number - 110 // to this cycle (0 rows loaded) raises a "Session or device error" 000110 - 111 // (CPF5006-class) runtime error instead of just returning *EOF. 000111 - 112 if numRows > 0; 000112 - 113 selRrn = 0; 000113 - 114 readc itpsfl; 000114 - 115 dow not %eof(itmprm2d); 000115 - 116 if sopt = '1'; 000116 - 117 if selRrn = 0; 000117 - 118 selRrn = rrn; 000118 - 119 else; 000119 - 120 writeMsg('Only one item may be selected per Enter.'); 000120 - 121 endif; 000121 - 122 elseif sopt <> ''; 000122 - 123 writeMsg('Option ' + sopt + ' is not valid - use 1.'); 000123 - 124 endif; 000124 - 125 readc itpsfl; 000125 - 126 enddo; 000126 - 127 endif; 000127 - 128 000128 - 129 if selRrn > 0 and msgrrn = 0; 000129 - 130 chain selRrn itpsfl; 000130 - 131 pItem = siitem; 000131 - 132 leave; 000132 - 133 endif; 000133 - 134 000134 - 135 enddo; 000135 - 136 000136 - 137 *inlr = *on; 000137 - 138 return; 000138 - 139 000139 - 140 // --------------------------------------------------------------------- 000140 - 141 begsr loadRows; 000141 - 142 numRows = 0; 000142 - 143 exec sql declare ip1 cursor for 000143 - 144 select item_number, item_description 000144 - 145 from perpdemo.item 000145 - 146 where company_code = :pCompcd 000146 - 147 and (:search = '' 000147 - 148 or upper(item_number) like '%' || upper(:search) || '%' 000148 - 149 or upper(item_description) like '%' || upper(:search) || '%') 000149 - 150 order by item_number; 000150 - 151 exec sql open ip1; 000151 - 152 if sqlcode < 0; 000152 - 153 writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); 000153 - 154 leavesr; 000154 - 155 endif; 000155 - 156 000156 - 157 dow numRows < %elem(rows); 000157 - 158 exec sql fetch ip1 into :itemRow; 000158 - 159 if sqlcode = 100 or sqlcode < 0; 000159 - 160 leave; 000160 - 161 endif; 000161 - 162 numRows += 1; 000162 - 163 rows(numRows) = itemRow; 000163 - 164 enddo; 000164 - 165 exec sql close ip1; 000165 - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 5 - Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq - Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number - 166 endsr; 000166 - 167 000167 - 168 // --------------------------------------------------------------------- 000168 - 169 begsr fillSubfile; 000169 - 170 rrn = 0; 000170 - 171 *in31 = *on; 000171 - 172 write itpctl; 000172 - 173 *in31 = *off; 000173 - 174 for i = 1 to numRows; 000174 - 175 *in50 = *off; 000175 - 176 *in51 = *off; 000176 - 177 sopt = ''; 000177 - 178 siitem = rows(i).item; 000178 - 179 sidesc = %subst(rows(i).desc : 1 : %min(%len(rows(i).desc) : 48)); 000179 - 180 rrn += 1; 000180 - 181 write itpsfl; 000181 - 182 endfor; 000182 - 183 endsr; 000183 - 184 000184 - 185 // --------------------------------------------------------------------- 000185 - 186 begsr clearMsgs; 000186 - 187 msgrrn = 0; 000187 - 188 *in41 = *on; 000188 - 189 write itpmsgctl; 000189 - 190 *in41 = *off; 000190 - 191 endsr; 000191 - 192 000192 - 193 // --------------------------------------------------------------------- 000193 - 194 dcl-proc writeMsg; 000194 - 195 dcl-pi *n; 000195 - 196 text varchar(256) const; 000196 - 197 end-pi; 000197 - 198 dcl-s data char(256); 000198 - 199 data = text; 000199 - 200 QMHSNDPM( 000200 - 201 'CPF9897' : 000201 - 202 'QCPFMSG QSYS ' : 000202 - 203 data : 000203 - 204 %len(text) : 000204 - 205 '*INFO ' : 000205 - 206 '* ' : 000206 - 207 1 : 000207 - 208 smsgkey : 000208 - 209 x'0000000000000000'); 000209 - 210 msgrrn += 1; 000210 - 211 spgmq = statusDS.programName; 000211 - 212 write itpmsgsfl; 000212 - 213 end-proc; 000213 - * * * * * E N D O F S O U R C E * * * * * - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 6 - Line <---------------------- Data Records --------------------------------------------------------------> Change Src Seq - Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Date Id Number - C o m p i l e T i m e D a t a - * * * * * E N D O F C O M P I L E T I M E D A T A * * * * * - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 7 - M e s s a g e S u m m a r y - Msg id Sv Number Message text - * * * * * E N D O F M E S S A G E S U M M A R Y * * * * * - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 8 - F i n a l S u m m a r y - Message Totals: - Information (00) . . . . . . . : 0 - Warning (10) . . . . . . . : 0 - Error (20) . . . . . . . : 0 - Severe Error (30+) . . . . . . : 0 - --------------------------------- ------- - Total . . . . . . . . . . . . . : 0 - Source Totals: - Records . . . . . . . . . . . . : 213 - Specifications . . . . . . . . : 154 - Data records . . . . . . . . . : 0 - Comments . . . . . . . . . . . : 56 - * * * * * E N D O F F I N A L S U M M A R Y * * * * * - Diagnostic check of source is complete. Highest severity is 00. - * * * * * E N D O F C O M P I L A T I O N * * * * * - 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object ITMPRMT 08/20/26 16:25:08 Page 1 - Source type...............RPG - Object name...............PERPDEMO/ITMPRMT - Source file...............QTEMP/QSQLPRE - Member....................*OBJ - To source file............QTEMP/QSQLTEMP1 - Options...................*XREF - RPG preprocessor options..*LVL2 - Listing option............*PRINT - Target release............V7R4M0 - INCLUDE file..............*LIBL/QRPGLESRC - Commit....................*CHG - Allow copy of data........*OPTIMIZE - Close SQL cursor..........*ENDACTGRP - Allow blocking............*ALLREAD - Delay PREPARE.............*NO - Concurrent access - resolution..............*DFT - Generation level..........10 - Printer file..............*LIBL/QSYSPRT - Date format...............*JOB - Date separator............*JOB - Time format...............*HMS - Time separator ...........*JOB - Replace...................*YES - Relational database.......*LOCAL - User .....................*CURRENT - RDB connect method........*DUW - Default collection........*NONE - Dynamic default - collection..............*NO - Package name..............*OBJLIB/*OBJ - Path......................*NAMING - SQL rules.................*DB2 - Created object type.......*PGM - Debugging view............*SOURCE - Debugging encryption key..*NONE - User profile .............*NAMING - Dynamic user profile......*USER - Sort sequence.............*JOB - Language ID...............*JOB - IBM SQL flagging..........*NOFLAG - ANS flagging..............*NONE - Text......................*SRCMBRTXT - Source file CCSID.........37 - Conversion CCSID..........1208 - Job CCSID.................37 - Decimal result options: - Maximum precision.......31 - Maximum scale...........31 - Minimum divide scale....0 - DECFLOAT rounding mode....*HALFEVEN - Compiler options..........incdir('.') tgtccsid(*job) output(*print) - Source member changed on 08/20/26 16:25:08 - 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object ITMPRMT 08/20/26 16:25:08 Page 2 - Record *...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 SEQNBR Last change - 1 **free 000001 08/20/26 - 2 000002 08/20/26 - 3 // --------------------------------------------------------------------- 000003 08/20/26 - 4 // Program: itmprmt (standard, reusable Item Number prompt/lookup) 000004 08/20/26 - 5 // Purpose: System-wide "?" + Enter lookup for any keyable Item Number 000005 08/20/26 - 6 // field. Caller CALLs this program passing the company code 000006 08/20/26 - 7 // and the field's current value; typing '?' into the field 000007 08/20/26 - 8 // before Enter is the trigger convention every caller uses, 000008 08/20/26 - 9 // so this program treats a '?' seed the same as a blank 000009 08/20/26 - 10 // search (full list). Any other seed value pre-fills the 000010 08/20/26 - 11 // Search field so partial text the user already typed keeps 000011 08/20/26 - 12 // working as a filter. The subfile lists item_number + 000012 08/20/26 - 13 // item_description, filtered case-insensitively on either 000013 08/20/26 - 14 // column; 1=Select on a row returns that item_number in the 000014 08/20/26 - 15 // same parameter. F3/F12 cancel and return the field blank. 000015 08/20/26 - 16 // Model: perpselr's subfile-picker pattern (PERP-16), 000016 08/20/26 - 17 // adapted for field-level invocation instead of a full-screen 000017 08/20/26 - 18 // menu step. Called via a plain dynamic CALL (EXTPGM 000018 08/20/26 - 19 // prototype declared in each caller) -- the same idiom 000019 08/20/26 - 20 // wrkitmr already uses to call wrkcnvr/wrklotr -- not a bound 000020 08/20/26 - 21 // service program, so no bnddir/exports wiring is needed. 000021 08/20/26 - 22 // Callers: wrkcnvr (PERP-54), wrkitmr (PERP-57), wrkivnr (PERP-58), 000022 08/20/26 - 23 // wrkivpr (PERP-59), wrklotr (PERP-60), reqentr (PERP-61), 000023 08/20/26 - 24 // poentr (PERP-62). 000024 08/20/26 - 25 // Epic: PERP-51 (PERP-56) 000025 08/20/26 - 26 // --------------------------------------------------------------------- 000026 08/20/26 - 27 000027 08/20/26 - 28 ctl-opt dftactgrp(*no) actgrp(*new); 000028 08/20/26 - 29 000029 08/20/26 - 30 dcl-pi *n; 000030 08/20/26 - 31 pCompcd char(3) const; 000031 08/20/26 - 32 pItem varchar(25); 000032 08/20/26 - 33 end-pi; 000033 08/20/26 - 34 000034 08/20/26 - 35 dcl-f itmprm2d workstn sfile(itpsfl:rrn) sfile(itpmsgsfl:msgrrn); 000035 08/20/26 - 36 000036 08/20/26 - 37 dcl-pr QMHSNDPM extpgm; 000037 08/20/26 - 38 msgId char(7) const; 000038 08/20/26 - 39 msgF char(20) const; 000039 08/20/26 - 40 msgData char(256) const; 000040 08/20/26 - 41 msgDataLen int(10) const; 000041 08/20/26 - 42 msgType char(10) const; 000042 08/20/26 - 43 stackEntry char(10) const; 000043 08/20/26 - 44 stackCntr int(10) const; 000044 08/20/26 - 45 msgKey char(4); 000045 08/20/26 - 46 errorCode char(8) const; 000046 08/20/26 - 47 end-pr; 000047 08/20/26 - 48 000048 08/20/26 - 49 dcl-ds statusDS psds qualified; 000049 08/20/26 - 50 programName char(10) pos(334); 000050 08/20/26 - 51 end-ds; 000051 08/20/26 - 52 000052 08/20/26 - 53 dcl-ds itemRow qualified; 000053 08/20/26 - 54 item varchar(25); 000054 08/20/26 - 55 desc varchar(60); 000055 08/20/26 - 56 end-ds; 000056 08/20/26 - 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object ITMPRMT 08/20/26 16:25:08 Page 3 - Record *...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 SEQNBR Last change - 57 000057 08/20/26 - 58 dcl-ds rows likeds(itemRow) dim(500); 000058 08/20/26 - 59 dcl-s numRows int(10); 000059 08/20/26 - 60 dcl-s i int(10); 000060 08/20/26 - 61 dcl-s rrn int(10); 000061 08/20/26 - 62 dcl-s msgrrn int(10); 000062 08/20/26 - 63 dcl-s msgkey char(4); 000063 08/20/26 - 64 dcl-s selRrn int(10); 000064 08/20/26 - 65 dcl-s search varchar(30); 000065 08/20/26 - 66 000066 08/20/26 - 67 search = %trim(pItem); 000067 08/20/26 - 68 if search = '?'; 000068 08/20/26 - 69 search = ''; 000069 08/20/26 - 70 endif; 000070 08/20/26 - 71 ssearch = search; 000071 08/20/26 - 72 000072 08/20/26 - 73 dow not *in03 and not *in12; 000073 08/20/26 - 74 exsr clearMsgs; 000074 08/20/26 - 75 exsr loadRows; 000075 08/20/26 - 76 000076 08/20/26 - 77 if numRows = 0; 000077 08/20/26 - 78 *in30 = *off; 000078 08/20/26 - 79 write itpnone; 000079 08/20/26 - 80 else; 000080 08/20/26 - 81 exsr fillSubfile; 000081 08/20/26 - 82 *in30 = *on; 000082 08/20/26 - 83 endif; 000083 08/20/26 - 84 000084 08/20/26 - 85 write itpfoot; 000085 08/20/26 - 86 if msgrrn > 0; 000086 08/20/26 - 87 *in40 = *on; 000087 08/20/26 - 88 write itpmsgctl; 000088 08/20/26 - 89 else; 000089 08/20/26 - 90 *in40 = *off; 000090 08/20/26 - 91 endif; 000091 08/20/26 - 92 000092 08/20/26 - 93 exfmt itpctl; 000093 08/20/26 - 94 000094 08/20/26 - 95 if *in03 or *in12; 000095 08/20/26 - 96 pItem = ''; 000096 08/20/26 - 97 leave; 000097 08/20/26 - 98 endif; 000098 08/20/26 - 99 000099 08/20/26 - 100 if *in05; 000100 08/20/26 - 101 iter; 000101 08/20/26 - 102 endif; 000102 08/20/26 - 103 000103 08/20/26 - 104 if ssearch <> search; 000104 08/20/26 - 105 search = %trim(ssearch); 000105 08/20/26 - 106 iter; 000106 08/20/26 - 107 endif; 000107 08/20/26 - 108 000108 08/20/26 - 109 // Guard on numRows: READC against a subfile that was never written 000109 08/20/26 - 110 // to this cycle (0 rows loaded) raises a "Session or device error" 000110 08/20/26 - 111 // (CPF5006-class) runtime error instead of just returning *EOF. 000111 08/20/26 - 112 if numRows > 0; 000112 08/20/26 - 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object ITMPRMT 08/20/26 16:25:08 Page 4 - Record *...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 SEQNBR Last change - 113 selRrn = 0; 000113 08/20/26 - 114 readc itpsfl; 000114 08/20/26 - 115 dow not %eof(itmprm2d); 000115 08/20/26 - 116 if sopt = '1'; 000116 08/20/26 - 117 if selRrn = 0; 000117 08/20/26 - 118 selRrn = rrn; 000118 08/20/26 - 119 else; 000119 08/20/26 - 120 writeMsg('Only one item may be selected per Enter.'); 000120 08/20/26 - 121 endif; 000121 08/20/26 - 122 elseif sopt <> ''; 000122 08/20/26 - 123 writeMsg('Option ' + sopt + ' is not valid - use 1.'); 000123 08/20/26 - 124 endif; 000124 08/20/26 - 125 readc itpsfl; 000125 08/20/26 - 126 enddo; 000126 08/20/26 - 127 endif; 000127 08/20/26 - 128 000128 08/20/26 - 129 if selRrn > 0 and msgrrn = 0; 000129 08/20/26 - 130 chain selRrn itpsfl; 000130 08/20/26 - 131 pItem = siitem; 000131 08/20/26 - 132 leave; 000132 08/20/26 - 133 endif; 000133 08/20/26 - 134 000134 08/20/26 - 135 enddo; 000135 08/20/26 - 136 000136 08/20/26 - 137 *inlr = *on; 000137 08/20/26 - 138 return; 000138 08/20/26 - 139 000139 08/20/26 - 140 // --------------------------------------------------------------------- 000140 08/20/26 - 141 begsr loadRows; 000141 08/20/26 - 142 numRows = 0; 000142 08/20/26 - 143 exec sql declare ip1 cursor for 000143 08/20/26 - 144 select item_number, item_description 000144 08/20/26 - 145 from perpdemo.item 000145 08/20/26 - 146 where company_code = :pCompcd 000146 08/20/26 - 147 and (:search = '' 000147 08/20/26 - 148 or upper(item_number) like '%' || upper(:search) || '%' 000148 08/20/26 - 149 or upper(item_description) like '%' || upper(:search) || '%') 000149 08/20/26 - 150 order by item_number; 000150 08/20/26 - 151 exec sql open ip1; 000151 08/20/26 - 152 if sqlcode < 0; 000152 08/20/26 - 153 writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); 000153 08/20/26 - 154 leavesr; 000154 08/20/26 - 155 endif; 000155 08/20/26 - 156 000156 08/20/26 - 157 dow numRows < %elem(rows); 000157 08/20/26 - 158 exec sql fetch ip1 into :itemRow; 000158 08/20/26 - 159 if sqlcode = 100 or sqlcode < 0; 000159 08/20/26 - 160 leave; 000160 08/20/26 - 161 endif; 000161 08/20/26 - 162 numRows += 1; 000162 08/20/26 - 163 rows(numRows) = itemRow; 000163 08/20/26 - 164 enddo; 000164 08/20/26 - 165 exec sql close ip1; 000165 08/20/26 - 166 endsr; 000166 08/20/26 - 167 000167 08/20/26 - 168 // --------------------------------------------------------------------- 000168 08/20/26 - 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object ITMPRMT 08/20/26 16:25:08 Page 5 - Record *...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 SEQNBR Last change - 169 begsr fillSubfile; 000169 08/20/26 - 170 rrn = 0; 000170 08/20/26 - 171 *in31 = *on; 000171 08/20/26 - 172 write itpctl; 000172 08/20/26 - 173 *in31 = *off; 000173 08/20/26 - 174 for i = 1 to numRows; 000174 08/20/26 - 175 *in50 = *off; 000175 08/20/26 - 176 *in51 = *off; 000176 08/20/26 - 177 sopt = ''; 000177 08/20/26 - 178 siitem = rows(i).item; 000178 08/20/26 - 179 sidesc = %subst(rows(i).desc : 1 : %min(%len(rows(i).desc) : 48)); 000179 08/20/26 - 180 rrn += 1; 000180 08/20/26 - 181 write itpsfl; 000181 08/20/26 - 182 endfor; 000182 08/20/26 - 183 endsr; 000183 08/20/26 - 184 000184 08/20/26 - 185 // --------------------------------------------------------------------- 000185 08/20/26 - 186 begsr clearMsgs; 000186 08/20/26 - 187 msgrrn = 0; 000187 08/20/26 - 188 *in41 = *on; 000188 08/20/26 - 189 write itpmsgctl; 000189 08/20/26 - 190 *in41 = *off; 000190 08/20/26 - 191 endsr; 000191 08/20/26 - 192 000192 08/20/26 - 193 // --------------------------------------------------------------------- 000193 08/20/26 - 194 dcl-proc writeMsg; 000194 08/20/26 - 195 dcl-pi *n; 000195 08/20/26 - 196 text varchar(256) const; 000196 08/20/26 - 197 end-pi; 000197 08/20/26 - 198 dcl-s data char(256); 000198 08/20/26 - 199 data = text; 000199 08/20/26 - 200 QMHSNDPM( 000200 08/20/26 - 201 'CPF9897' : 000201 08/20/26 - 202 'QCPFMSG QSYS ' : 000202 08/20/26 - 203 data : 000203 08/20/26 - 204 %len(text) : 000204 08/20/26 - 205 '*INFO ' : 000205 08/20/26 - 206 '* ' : 000206 08/20/26 - 207 1 : 000207 08/20/26 - 208 smsgkey : 000208 08/20/26 - 209 x'0000000000000000'); 000209 08/20/26 - 210 msgrrn += 1; 000210 08/20/26 - 211 spgmq = statusDS.programName; 000211 08/20/26 - 212 write itpmsgsfl; 000212 08/20/26 - 213 end-proc; 000213 08/20/26 - * * * * * E N D O F S O U R C E * * * * * - 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object ITMPRMT 08/20/26 16:25:08 Page 6 - CROSS REFERENCE - Data Names Define Reference - AISLE 145 VARCHAR(10) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM - AISLE_CODE 145 COLUMN FOR AISLE IN PERPDEMO.ITEM - BAY 145 VARCHAR(10) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM - BAY_CODE 145 COLUMN FOR BAY IN PERPDEMO.ITEM - CLASS_CODE 145 COLUMN FOR CLSCD IN PERPDEMO.ITEM - CLSCD 145 VARCHAR(10) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM - COMPANY_CODE **** COLUMN - 146 - COMPANY_CODE 145 COLUMN FOR COMPCD IN PERPDEMO.ITEM - COMPCD 145 CHARACTER(3) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM - CREATED_AT 145 COLUMN FOR CRTAT IN PERPDEMO.ITEM - CREATED_BY 145 COLUMN FOR CRTBY IN PERPDEMO.ITEM - CRITICAL_LEVEL 145 COLUMN FOR CRITLV IN PERPDEMO.ITEM - CRITLV 145 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM - CRTAT 145 TIMESTAMP(26) COLUMN (NOT NULL) IN PERPDEMO.ITEM - CRTBY 145 VARCHAR(18) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM - DATA 198 CHARACTER(256) IN RPG PROCEDURE WRITEMSG - DESC 55 VARCHAR(60) IN ITEMROW - DESC 58 VARCHAR(60) IN ROWS - I 60 INTEGER PRECISION(9,0) - INVENTORY_UOM 145 COLUMN FOR INVUOM IN PERPDEMO.ITEM - INVUOM 145 VARCHAR(5) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM - IP1 143 CURSOR - 151 158 165 - IS_ACTIVE 145 COLUMN FOR ISACT IN PERPDEMO.ITEM - ISACT 145 CHARACTER(1) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM - ITEM 54 VARCHAR(25) IN ITEMROW - ITEM 58 VARCHAR(25) IN ROWS - ITEM **** TABLE IN PERPDEMO - 145 - 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object ITMPRMT 08/20/26 16:25:08 Page 7 - CROSS REFERENCE - ITEM_DESCRIPTION **** COLUMN - 144 149 - ITEM_DESCRIPTION 145 COLUMN FOR ITMDSC IN PERPDEMO.ITEM - ITEM_NUMBER **** COLUMN - 144 148 150 - ITEM_NUMBER 145 COLUMN FOR ITMNBR IN PERPDEMO.ITEM - ITEMROW 53 STRUCTURE - 158 - ITMDSC 145 VARCHAR(60) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM - ITMNBR 145 VARCHAR(25) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM - LEAD_TIME_DAYS 145 COLUMN FOR LEADTM IN PERPDEMO.ITEM - LEADTM 145 INTEGER PRECISION(9,0) COLUMN (NOT NULL) IN PERPDEMO.ITEM - LOT_CONTROLLED 145 COLUMN FOR LOTCTL IN PERPDEMO.ITEM - LOTCTL 145 CHARACTER(1) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM - MAX_QTY 145 COLUMN FOR MAXQTY IN PERPDEMO.ITEM - MAXQTY 145 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM - MIN_QTY 145 COLUMN FOR MINQTY IN PERPDEMO.ITEM - MINQTY 145 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM - MSGKEY 63 CHARACTER(4) - MSGRRN 62 INTEGER PRECISION(9,0) - NUMROWS 59 INTEGER PRECISION(9,0) - PCOMPCD 31 CHARACTER(3) CONSTANT - 146 - PERPDEMO **** SCHEMA - 145 - PITEM 32 VARCHAR(25) - PROGRAMNAME 50 CHARACTER(10) IN STATUSDS - QMHSNDPM 37 - QTY_AVAILABLE 145 COLUMN FOR QTYAVL IN PERPDEMO.ITEM - QTY_FROZEN 145 COLUMN FOR QTYFRZ IN PERPDEMO.ITEM - QTY_ON_HAND 145 COLUMN FOR QTYOH IN PERPDEMO.ITEM - QTY_ON_ORDER 145 COLUMN FOR QTYOO IN PERPDEMO.ITEM - QTYAVL 145 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM - QTYFRZ 145 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM - 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object ITMPRMT 08/20/26 16:25:08 Page 8 - CROSS REFERENCE - QTYOH 145 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM - QTYOO 145 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM - REORDER_POINT 145 COLUMN FOR RORDPT IN PERPDEMO.ITEM - RORDPT 145 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM - ROWS 58 ARRAY(500) STRUCTURE - RRN 61 INTEGER PRECISION(9,0) - SAFETY_STOCK 145 COLUMN FOR SAFSTK IN PERPDEMO.ITEM - SAFSTK 145 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM - SEARCH 65 VARCHAR(30) - 147 148 149 - SELRRN 64 INTEGER PRECISION(9,0) - SHELF 145 VARCHAR(10) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM - SHELF_CODE 145 COLUMN FOR SHELF IN PERPDEMO.ITEM - SHORT_DESCRIPTION 145 COLUMN FOR SHTDSC IN PERPDEMO.ITEM - SHTDSC 145 VARCHAR(20) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM - SIDESC 35 CHARACTER(48) - SIITEM 35 CHARACTER(25) - SMSGKEY 35 CHARACTER(4) - SOPT 35 CHARACTER(1) - SPGMQ 35 CHARACTER(10) - SSEARCH 35 CHARACTER(30) - STATUSDS 49 STRUCTURE - STKUOM 145 VARCHAR(5) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM - STOCKING_UOM 145 COLUMN FOR STKUOM IN PERPDEMO.ITEM - TEXT 196 VARCHAR(256) CONSTANT IN RPG PROCEDURE WRITEMSG - UPDAT 145 TIMESTAMP(26) COLUMN (NOT NULL) IN PERPDEMO.ITEM - UPDATED_AT 145 COLUMN FOR UPDAT IN PERPDEMO.ITEM - UPDATED_BY 145 COLUMN FOR UPDBY IN PERPDEMO.ITEM - UPDBY 145 VARCHAR(18) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM - 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object ITMPRMT 08/20/26 16:25:08 Page 9 - CROSS REFERENCE - WRITEMSG 194 RPG PROCEDURE - No errors found in source - 213 Source records processed - * * * * * E N D O F L I S T I N G * * * * * - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 1 - Command . . . . . . . . . . . . : CRTBNDRPG - Issued by . . . . . . . . . . : AIDEMO - Program . . . . . . . . . . . . : ITMPRMT - Library . . . . . . . . . . . : PERPDEMO - Text 'description' . . . . . . . : *SRCMBRTXT - Source stream file . . . . . . : /QSYS.LIB/QTEMP.LIB/QSQLTEMP1.FILE/ITMPRMT.MBR - CCSID . . . . . . . . . . . . : 37 - Target CCSID . . . . . . . . . . : *JOB (37) - Text 'description' . . . . . . . : - Last Change . . . . . . . . . . : 08/20/26 16:25:08 - Generation severity level . . . : 10 - Default activation group . . . . : *YES - Compiler options . . . . . . . . : *XREF *GEN *NOSECLVL *SHOWCPY - *EXPDDS *EXT *NOSHOWSKP *NOSRCSTMT - *DEBUGIO *UNREF *NOEVENTF - Debugging views . . . . . . . . : *ALL - Debug encryption key . . . . . . : *NONE - Output . . . . . . . . . . . . . : *PRINT - Optimization level . . . . . . . : *NONE - Source listing indentation . . . : *NONE - Type conversion options . . . . : *NONE - Sort sequence . . . . . . . . . : *JOB - Language identifier . . . . . . : *JOB - Replace program . . . . . . . . : *YES - User profile . . . . . . . . . . : *USER - Authority . . . . . . . . . . . : *LIBCRTAUT - Truncate numeric . . . . . . . . : *YES - Fix numeric . . . . . . . . . . : *NONE - Target release . . . . . . . . . : V7R4M0 - Allow null values . . . . . . . : *NO - Define condition names . . . . . : *NONE - Enable performance collection . : *PEP - Profiling data . . . . . . . . . : *NOCOL - Licensed Internal Code options . : - Generate program interface . . . : *NO - Include directory . . . . . . . : . - Preprocessor options . . . . . . : *NONE - Require prototype for export . . : *NO - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 2 - Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq - Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number - S o u r c e L i s t i n g - 1 **free 000001 - 2 000002 - 3 // --------------------------------------------------------------------- 000003 - 4 // Program: itmprmt (standard, reusable Item Number prompt/lookup) 000004 - 5 // Purpose: System-wide "?" + Enter lookup for any keyable Item Number 000005 - 6 // field. Caller CALLs this program passing the company code 000006 - 7 // and the field's current value; typing '?' into the field 000007 - 8 // before Enter is the trigger convention every caller uses, 000008 - 9 // so this program treats a '?' seed the same as a blank 000009 - 10 // search (full list). Any other seed value pre-fills the 000010 - 11 // Search field so partial text the user already typed keeps 000011 - 12 // working as a filter. The subfile lists item_number + 000012 - 13 // item_description, filtered case-insensitively on either 000013 - 14 // column; 1=Select on a row returns that item_number in the 000014 - 15 // same parameter. F3/F12 cancel and return the field blank. 000015 - 16 // Model: perpselr's subfile-picker pattern (PERP-16), 000016 - 17 // adapted for field-level invocation instead of a full-screen 000017 - 18 // menu step. Called via a plain dynamic CALL (EXTPGM 000018 - 19 // prototype declared in each caller) -- the same idiom 000019 - 20 // wrkitmr already uses to call wrkcnvr/wrklotr -- not a bound 000020 - 21 // service program, so no bnddir/exports wiring is needed. 000021 - 22 // Callers: wrkcnvr (PERP-54), wrkitmr (PERP-57), wrkivnr (PERP-58), 000022 - 23 // wrkivpr (PERP-59), wrklotr (PERP-60), reqentr (PERP-61), 000023 - 24 // poentr (PERP-62). 000024 - 25 // Epic: PERP-51 (PERP-56) 000025 - 26 // --------------------------------------------------------------------- 000026 - 27 000027 - 28 ctl-opt dftactgrp(*no) actgrp(*new); 000028 - 29 000029 - *--------------------------------------------------------------------* - * Compiler Options in Effect: * - *--------------------------------------------------------------------* - * Text 'description' . . . . . . . : * - * Generation severity level . . . : 10 * - * Default activation group . . . . : *NO * - * Compiler options . . . . . . . . : *XREF *GEN * - * *NOSECLVL *SHOWCPY * - * *EXPDDS *EXT * - * *NOSHOWSKP *NOSRCSTMT * - * *DEBUGIO *UNREF * - * *NOEVENTF * - * Optimization level . . . . . . . : *NONE * - * Source listing indentation . . . : *NONE * - * Type conversion options . . . . : *NONE * - * Sort sequence . . . . . . . . . : *JOB * - * Language identifier . . . . . . : *JOB * - * User profile . . . . . . . . . . : *USER * - * Authority . . . . . . . . . . . : *LIBCRTAUT * - * Truncate numeric . . . . . . . . : *YES * - * Fix numeric . . . . . . . . . . : *NONE * - * Allow null values . . . . . . . : *NO * - * Storage model . . . . . . . . . : *SNGLVL * - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 3 - Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq - Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number - * Binding directory from Command . : *NONE * - * Binding directory from Source . : *NONE * - * Activation group . . . . . . . . : *NEW * - * Enable performance collection . : *PEP * - * Profiling data . . . . . . . . . : *NOCOL * - * Generate program interface . . . : *NO * - * REQUIRE PROTOTYPE FOR EXPORT . . : *NO * - *--------------------------------------------------------------------* - 30 dcl-pi *n; 000030 - 31 pCompcd char(3) const; 000031 - 32 pItem varchar(25); 000032 - 33 end-pi; 000033 - 34 000034 - 35 dcl-f itmprm2d workstn sfile(itpsfl:rrn) sfile(itpmsgsfl:msgrrn); 000035 - *--------------------------------------------------------------------------------------------* - * RPG name External name * - * File name. . . . . . . . . : ITMPRM2D PERPDEMO/ITMPRM2D * - * Record format(s) . . . . . : ITPSFL ITPSFL * - * ITPCTL ITPCTL * - * ITPFOOT ITPFOOT * - * ITPNONE ITPNONE * - * ITPMSGSFL ITPMSGSFL * - * ITPMSGCTL ITPMSGCTL * - *--------------------------------------------------------------------------------------------* - 36 000036 - 37 dcl-pr QMHSNDPM extpgm; 000037 - 38 msgId char(7) const; 000038 - 39 msgF char(20) const; 000039 - 40 msgData char(256) const; 000040 - 41 msgDataLen int(10) const; 000041 - 42 msgType char(10) const; 000042 - 43 stackEntry char(10) const; 000043 - 44 stackCntr int(10) const; 000044 - 45 msgKey char(4); 000045 - 46 errorCode char(8) const; 000046 - 47 end-pr; 000047 - 48 000048 - 49 dcl-ds statusDS psds qualified; 000049 - 50 programName char(10) pos(334); 000050 - 51 end-ds; 000051 - 52 000052 - 53 dcl-ds itemRow qualified; 000053 - 54 item varchar(25); 000054 - 55 desc varchar(60); 000055 - 56 end-ds; 000056 - 57 000057 - 58 dcl-ds rows likeds(itemRow) dim(500); 000058 - 59 dcl-s numRows int(10); 000059 - 60 dcl-s i int(10); 000060 - 61 dcl-s rrn int(10); 000061 - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 4 - Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq - Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number - 62 dcl-s msgrrn int(10); 000062 - 63 dcl-s msgkey char(4); 000063 - 64 dcl-s selRrn int(10); 000064 - 65 dcl-s search varchar(30); 000065 - 66 000066 - 67 /SET CCSID(*CHAR:*JOBRUNMIX) 000067 - 68 // SQL COMMUNICATION AREA //SQL 000068 - 69 DCL-DS SQLCA; //SQL 000069 - 70 SQLCAID CHAR(8) INZ(X'0000000000000000'); //SQL 000070 - 71 SQLAID CHAR(8) OVERLAY(SQLCAID); //SQL 000071 - 72 SQLCABC INT(10); //SQL 000072 - 73 SQLABC BINDEC(9) OVERLAY(SQLCABC); //SQL 000073 - 74 SQLCODE INT(10); //SQL 000074 - 75 SQLCOD BINDEC(9) OVERLAY(SQLCODE); //SQL 000075 - 76 SQLERRML INT(5); //SQL 000076 - 77 SQLERL BINDEC(4) OVERLAY(SQLERRML); //SQL 000077 - 78 SQLERRMC CHAR(70); //SQL 000078 - 79 SQLERM CHAR(70) OVERLAY(SQLERRMC); //SQL 000079 - 80 SQLERRP CHAR(8); //SQL 000080 - 81 SQLERP CHAR(8) OVERLAY(SQLERRP); //SQL 000081 - 82 SQLERR CHAR(24); //SQL 000082 - 83 SQLER1 BINDEC(9) OVERLAY(SQLERR:*NEXT); //SQL 000083 - 84 SQLER2 BINDEC(9) OVERLAY(SQLERR:*NEXT); //SQL 000084 - 85 SQLER3 BINDEC(9) OVERLAY(SQLERR:*NEXT); //SQL 000085 - 86 SQLER4 BINDEC(9) OVERLAY(SQLERR:*NEXT); //SQL 000086 - 87 SQLER5 BINDEC(9) OVERLAY(SQLERR:*NEXT); //SQL 000087 - 88 SQLER6 BINDEC(9) OVERLAY(SQLERR:*NEXT); //SQL 000088 - 89 SQLERRD INT(10) DIM(6) OVERLAY(SQLERR); //SQL 000089 - 90 SQLWRN CHAR(11); //SQL 000090 - 91 SQLWN0 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000091 - 92 SQLWN1 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000092 - 93 SQLWN2 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000093 - 94 SQLWN3 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000094 - 95 SQLWN4 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000095 - 96 SQLWN5 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000096 - 97 SQLWN6 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000097 - 98 SQLWN7 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000098 - 99 SQLWN8 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000099 - 100 SQLWN9 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000100 - 101 SQLWNA CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000101 - 102 SQLWARN CHAR(1) DIM(11) OVERLAY(SQLWRN); //SQL 000102 - 103 SQLSTATE CHAR(5); //SQL 000103 - 104 SQLSTT CHAR(5) OVERLAY(SQLSTATE); //SQL 000104 - 105 END-DS SQLCA; //SQL 000105 - 106 DCL-PR SQLROUTE_CALL EXTPGM(SQLROUTE); //SQL 000106 - 107 CA LIKEDS(SQLCA); //SQL 000107 - 108 *N BINDEC(4) OPTIONS(*NOPASS); //SQL 000108 - 109 *N CHAR(1) OPTIONS(*NOPASS); //SQL 000109 - 110 END-PR SQLROUTE_CALL; //SQL 000110 - 111 DCL-PR SQLOPEN_CALL EXTPGM(SQLOPEN); //SQL 000111 - 112 CA LIKEDS(SQLCA); //SQL 000112 - 113 *N BINDEC(4); //SQL 000113 - 114 END-PR SQLOPEN_CALL; //SQL 000114 - 115 DCL-PR SQLCLSE_CALL EXTPGM(SQLCLSE); //SQL 000115 - 116 CA LIKEDS(SQLCA); //SQL 000116 - 117 *N BINDEC(4); //SQL 000117 - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 5 - Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq - Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number - 118 END-PR SQLCLSE_CALL; //SQL 000118 - 119 DCL-PR SQLCMIT_CALL EXTPGM(SQLCMIT); //SQL 000119 - 120 CA LIKEDS(SQLCA); //SQL 000120 - 121 *N BINDEC(4); //SQL 000121 - 122 END-PR SQLCMIT_CALL; //SQL 000122 - 123 /RESTORE CCSID(*CHAR) 000123 - 124 DCL-C SQLROUTE CONST('QSYS/QSQROUTE'); //SQL 000124 - 125 DCL-C SQLOPEN CONST('QSYS/QSQROUTE'); //SQL 000125 - 126 DCL-C SQLCLSE CONST('QSYS/QSQLCLSE'); //SQL 000126 - 127 DCL-C SQLCMIT CONST('QSYS/QSQLCMIT'); //SQL 000127 - 128 DCL-C SQFRD CONST(2); //SQL 000128 - 129 DCL-C SQFCRT CONST(8); //SQL 000129 - 130 DCL-C SQFOVR CONST(16); //SQL 000130 - 131 DCL-C SQFAPP CONST(32); //SQL 000131 - 132 **END-FREE 000132 - Line <---------------------- Source Specifications ----------------------------><---- Comments ----> Do Page Change Src Seq - Number ....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Line Date Id Number - 133 D DS OPEN 000133 - 134 D SQL_00000 1 2B 0 INZ(128) length of header 000134 - 135 D SQL_00001 3 4B 0 INZ(2) statement number 000135 - 136 D SQL_00002 5 8U 0 INZ(0) invocation mark 000136 - 137 D SQL_00003 9 9A INZ('0') CCSID(*JOBRUNMIX) data is okay 000137 - 138 D SQL_00004 10 128A CCSID(*JOBRUNMIX) end of header 000138 - 139 D SQL_00005 129 131A CCSID(*JOBRUNMIX) PCOMPCD 000139 - 140 D SQL_00006 132 163A VARYING CCSID(*JOBRUNMIX) SEARCH 000140 - 141 D SQL_00007 164 195A VARYING CCSID(*JOBRUNMIX) SEARCH 000141 - 142 D SQL_00008 196 227A VARYING CCSID(*JOBRUNMIX) SEARCH 000142 - Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq - Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number - 143 **FREE 000143 - 144 **END-FREE 000144 - Line <---------------------- Source Specifications ----------------------------><---- Comments ----> Do Page Change Src Seq - Number ....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Line Date Id Number - 145 D DS FETCH 000145 - 146 D SQL_00009 1 2B 0 INZ(128) length of header 000146 - 147 D SQL_00010 3 4B 0 INZ(3) statement number 000147 - 148 D SQL_00011 5 8U 0 INZ(0) invocation mark 000148 - 149 D SQL_00012 9 9A INZ('0') CCSID(*JOBRUNMIX) data is okay 000149 - 150 D SQL_00013 10 128A CCSID(*JOBRUNMIX) end of header 000150 - 151 D SQL_00014 129 155A VARYING CCSID(*JOBRUNMIX) ITEMROW.ITEM 000151 - 152 D SQL_00015 156 217A VARYING CCSID(*JOBRUNMIX) ITEMROW.DESC 000152 - Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq - Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number - 153 **FREE 000153 - 154 **END-FREE 000154 - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 6 - Line <---------------------- Source Specifications ----------------------------><---- Comments ----> Do Page Change Src Seq - Number ....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Line Date Id Number - 155 D DS CLOSE 000155 - 156 D SQL_00016 1 2B 0 INZ(128) length of header 000156 - 157 D SQL_00017 3 4B 0 INZ(4) statement number 000157 - 158 D SQL_00018 5 8U 0 INZ(0) invocation mark 000158 - 159 D SQL_00019 9 9A INZ('0') CCSID(*JOBRUNMIX) data is okay 000159 - 160 D SQL_00020 10 127A CCSID(*JOBRUNMIX) end of header 000160 - 161 D SQL_00021 128 128A CCSID(*JOBRUNMIX) end of header 000161 - Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq - Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number - 162 **FREE 000162 - 163=IITPSFL 1000001 - *--------------------------------------------------------------------------------------------* 1 - * RPG record format . . . . : ITPSFL * 1 - * External format . . . . . : ITPSFL : PERPDEMO/ITMPRM2D * 1 - *--------------------------------------------------------------------------------------------* 1 - 164=I N 1 1 *IN03 Exit 1000002 - 165=I N 2 2 *IN05 Refresh 1000003 - 166=I N 3 3 *IN12 Cancel 1000004 - 167=I A 4 4 SOPT 1000005 - 168=I A 5 29 SIITEM 1000006 - 169=I A 30 77 SIDESC 1000007 - 170=IITPCTL 2000001 - *--------------------------------------------------------------------------------------------* 2 - * RPG record format . . . . : ITPCTL * 2 - * External format . . . . . : ITPCTL : PERPDEMO/ITMPRM2D * 2 - *--------------------------------------------------------------------------------------------* 2 - 171=I N 1 1 *IN03 Exit 2000002 - 172=I N 2 2 *IN05 Refresh 2000003 - 173=I N 3 3 *IN12 Cancel 2000004 - 174=I A 4 33 SSEARCH 2000005 - 175=IITPFOOT 3000001 - *--------------------------------------------------------------------------------------------* 3 - * RPG record format . . . . : ITPFOOT * 3 - * External format . . . . . : ITPFOOT : PERPDEMO/ITMPRM2D * 3 - *--------------------------------------------------------------------------------------------* 3 - 176=I N 1 1 *IN03 Exit 3000002 - 177=I N 2 2 *IN05 Refresh 3000003 - 178=I N 3 3 *IN12 Cancel 3000004 - 179=IITPNONE 4000001 - *--------------------------------------------------------------------------------------------* 4 - * RPG record format . . . . : ITPNONE * 4 - * External format . . . . . : ITPNONE : PERPDEMO/ITMPRM2D * 4 - *--------------------------------------------------------------------------------------------* 4 - 180=I N 1 1 *IN03 Exit 4000002 - 181=I N 2 2 *IN05 Refresh 4000003 - 182=I N 3 3 *IN12 Cancel 4000004 - 183=IITPMSGSFL 5000001 - *--------------------------------------------------------------------------------------------* 5 - * RPG record format . . . . : ITPMSGSFL * 5 - * External format . . . . . : ITPMSGSFL : PERPDEMO/ITMPRM2D * 5 - *--------------------------------------------------------------------------------------------* 5 - 184=I N 1 1 *IN03 Exit 5000002 - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 7 - Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq - Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number - 185=I N 2 2 *IN05 Refresh 5000003 - 186=I N 3 3 *IN12 Cancel 5000004 - 187=I A 4 7 SMSGKEY 5000005 - 188=I A 8 17 SPGMQ 5000006 - 189=IITPMSGCTL 6000001 - *--------------------------------------------------------------------------------------------* 6 - * RPG record format . . . . : ITPMSGCTL * 6 - * External format . . . . . : ITPMSGCTL : PERPDEMO/ITMPRM2D * 6 - *--------------------------------------------------------------------------------------------* 6 - 190=I N 1 1 *IN03 Exit 6000002 - 191=I N 2 2 *IN05 Refresh 6000003 - 192=I N 3 3 *IN12 Cancel 6000004 - 193 search = %trim(pItem); 000163 - 194 if search = '?'; B01 000164 - 195 search = ''; 01 000165 - 196 endif; E01 000166 - 197 ssearch = search; 000167 - 198 000168 - 199 dow not *in03 and not *in12; B01 000169 - 200 exsr clearMsgs; 01 000170 - 201 exsr loadRows; 01 000171 - 202 000172 - 203 if numRows = 0; B02 000173 - 204 *in30 = *off; 02 000174 - 205 write itpnone; 02 000175 - 206 else; X02 000176 - 207 exsr fillSubfile; 02 000177 - 208 *in30 = *on; 02 000178 - 209 endif; E02 000179 - 210 000180 - 211 write itpfoot; 01 000181 - 212 if msgrrn > 0; B02 000182 - 213 *in40 = *on; 02 000183 - 214 write itpmsgctl; 02 000184 - 215 else; X02 000185 - 216 *in40 = *off; 02 000186 - 217 endif; E02 000187 - 218 000188 - 219 exfmt itpctl; 01 000189 - 220 000190 - 221 if *in03 or *in12; B02 000191 - 222 pItem = ''; 02 000192 - 223 leave; 02 000193 - 224 endif; E02 000194 - 225 000195 - 226 if *in05; B02 000196 - 227 iter; 02 000197 - 228 endif; E02 000198 - 229 000199 - 230 if ssearch <> search; B02 000200 - 231 search = %trim(ssearch); 02 000201 - 232 iter; 02 000202 - 233 endif; E02 000203 - 234 000204 - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 8 - Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq - Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number - 235 // Guard on numRows: READC against a subfile that was never written 000205 - 236 // to this cycle (0 rows loaded) raises a "Session or device error" 000206 - 237 // (CPF5006-class) runtime error instead of just returning *EOF. 000207 - 238 if numRows > 0; B02 000208 - 239 selRrn = 0; 02 000209 - 240 readc itpsfl; 02 000210 - 241 dow not %eof(itmprm2d); B03 000211 - 242 if sopt = '1'; B04 000212 - 243 if selRrn = 0; B05 000213 - 244 selRrn = rrn; 05 000214 - 245 else; X05 000215 - 246 writeMsg('Only one item may be selected per Enter.'); 05 000216 - 247 endif; E05 000217 - 248 elseif sopt <> ''; X04 000218 - 249 writeMsg('Option ' + sopt + ' is not valid - use 1.'); 04 000219 - 250 endif; E04 000220 - 251 readc itpsfl; 03 000221 - 252 enddo; E03 000222 - 253 endif; E02 000223 - 254 000224 - 255 if selRrn > 0 and msgrrn = 0; B02 000225 - 256 chain selRrn itpsfl; 02 000226 - 257 pItem = siitem; 02 000227 - 258 leave; 02 000228 - 259 endif; E02 000229 - 260 000230 - 261 enddo; E01 000231 - 262 000232 - 263 *inlr = *on; 000233 - 264 return; 000234 - 265 000235 - 266 // --------------------------------------------------------------------- 000236 - 267 begsr loadRows; 000237 - 268 numRows = 0; 000238 - 269 //* exec sql declare ip1 cursor for 000239 - 270 //* select item_number, item_description 000240 - 271 //* from perpdemo.item 000241 - 272 //* where company_code = :pCompcd 000242 - 273 //* and (:search = '' 000243 - 274 //* or upper(item_number) like '%' || upper(:search) || '%' 000244 - 275 //* or upper(item_description) like '%' || upper(:search) || '%') 000245 - 276 //* order by item_number; 000246 - 277 //* exec sql open ip1; 000247 - 278 SQL_00005 = PCOMPCD; //SQL 000248 - 279 SQL_00006 = SEARCH; //SQL 000249 - 280 SQL_00007 = SEARCH; //SQL 000250 - 281 SQL_00008 = SEARCH; //SQL 000251 - 282 SQLER6 = -4; //SQL 000252 - 283 IF SQL_00002 = 0 //SQL B01 000253 - 284 OR SQL_00003 <> *LOVAL; //SQL B01 000254 - 285 SQLROUTE_CALL( //SQL 01 000255 - 286 SQLCA //SQL 01 000256 - 287 : SQL_00000 //SQL 01 000257 - 288 ); //SQL 01 000258 - 289 ELSE; //SQL X01 000259 - 290 SQLOPEN_CALL( //SQL 01 000260 - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 9 - Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq - Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number - 291 SQLCA //SQL 01 000261 - 292 : SQL_00000 //SQL 01 000262 - 293 ); //SQL 01 000263 - 294 ENDIF; //SQL E01 000264 - 295 if sqlcode < 0; B01 000265 - 296 writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); 01 000266 - 297 leavesr; 01 000267 - 298 endif; E01 000268 - 299 000269 - 300 dow numRows < %elem(rows); B01 000270 - 301 //* exec sql fetch ip1 into :itemRow; 000271 - 302 SQLER6 = -4; //SQL 3 01 000272 - 303 SQLROUTE_CALL( //SQL 01 000273 - 304 SQLCA //SQL 01 000274 - 305 : SQL_00009 //SQL 01 000275 - 306 ); //SQL 01 000276 - 307 IF SQL_00012 = '1'; //SQL B02 000277 - 308 EVAL ITEMROW.ITEM = SQL_00014; //SQL 02 000278 - 309 EVAL ITEMROW.DESC = SQL_00015; //SQL 02 000279 - 310 ENDIF; //SQL E02 000280 - 311 if sqlcode = 100 or sqlcode < 0; B02 000281 - 312 leave; 02 000282 - 313 endif; E02 000283 - 314 numRows += 1; 01 000284 - 315 rows(numRows) = itemRow; 01 000285 - 316 enddo; E01 000286 - 317 //* exec sql close ip1; 000287 - 318 SQLER6 = 4; //SQL 000288 - 319 IF SQL_00018 = 0; //SQL B01 000289 - 320 SQLROUTE_CALL( //SQL 01 000290 - 321 SQLCA //SQL 01 000291 - 322 : SQL_00016 //SQL 01 000292 - 323 ); //SQL 01 000293 - 324 ELSE; //SQL X01 000294 - 325 SQLCLSE_CALL( //SQL 01 000295 - 326 SQLCA //SQL 01 000296 - 327 : SQL_00016 //SQL 01 000297 - 328 ); //SQL 01 000298 - 329 ENDIF; //SQL E01 000299 - 330 endsr; 000300 - 331 000301 - 332 // --------------------------------------------------------------------- 000302 - 333 begsr fillSubfile; 000303 - 334 rrn = 0; 000304 - 335 *in31 = *on; 000305 - 336 write itpctl; 000306 - 337 *in31 = *off; 000307 - 338 for i = 1 to numRows; B01 000308 - 339 *in50 = *off; 01 000309 - 340 *in51 = *off; 01 000310 - 341 sopt = ''; 01 000311 - 342 siitem = rows(i).item; 01 000312 - 343 sidesc = %subst(rows(i).desc : 1 : %min(%len(rows(i).desc) : 48)); 01 000313 - 344 rrn += 1; 01 000314 - 345 write itpsfl; 01 000315 - 346 endfor; E01 000316 - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 10 - Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq - Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number - 347 endsr; 000317 - 348 000318 - 349 // --------------------------------------------------------------------- 000319 - 350 begsr clearMsgs; 000320 - 351 msgrrn = 0; 000321 - 352 *in41 = *on; 000322 - 353 write itpmsgctl; 000323 - 354 *in41 = *off; 000324 - 355 endsr; 000325 - 356 000326 - 357 // --------------------------------------------------------------------- 000327 - 358=OITPSFL 7000001 - *--------------------------------------------------------------------------------------------* 7 - * RPG record format . . . . : ITPSFL * 7 - * External format . . . . . : ITPSFL : PERPDEMO/ITMPRM2D * 7 - *--------------------------------------------------------------------------------------------* 7 - 359=O *IN50 2N CHAR 1 7000002 - 360=O *IN51 1N CHAR 1 7000003 - 361=O SOPT 3A CHAR 1 7000004 - 362=O SIITEM 28A CHAR 25 7000005 - 363=O SIDESC 76A CHAR 48 7000006 - 364=OITPCTL 8000001 - *--------------------------------------------------------------------------------------------* 8 - * RPG record format . . . . : ITPCTL * 8 - * External format . . . . . : ITPCTL : PERPDEMO/ITMPRM2D * 8 - *--------------------------------------------------------------------------------------------* 8 - 365=O *IN30 2N CHAR 1 8000002 - 366=O *IN31 1N CHAR 1 8000003 - 367=O SSEARCH 32A CHAR 30 8000004 - 368=OITPFOOT 9000001 - *--------------------------------------------------------------------------------------------* 9 - * RPG record format . . . . : ITPFOOT * 9 - * External format . . . . . : ITPFOOT : PERPDEMO/ITMPRM2D * 9 - *--------------------------------------------------------------------------------------------* 9 - 369=OITPNONE 10000001 - *--------------------------------------------------------------------------------------------* 10 - * RPG record format . . . . : ITPNONE * 10 - * External format . . . . . : ITPNONE : PERPDEMO/ITMPRM2D * 10 - *--------------------------------------------------------------------------------------------* 10 - 370=OITPMSGSFL 11000001 - *--------------------------------------------------------------------------------------------* 11 - * RPG record format . . . . : ITPMSGSFL * 11 - * External format . . . . . : ITPMSGSFL : PERPDEMO/ITMPRM2D * 11 - *--------------------------------------------------------------------------------------------* 11 - 371=O SMSGKEY 4A CHAR 4 11000002 - 372=O SPGMQ 14A CHAR 10 11000003 - 373=OITPMSGCTL 12000001 - *--------------------------------------------------------------------------------------------* 12 - * RPG record format . . . . : ITPMSGCTL * 12 - * External format . . . . . : ITPMSGCTL : PERPDEMO/ITMPRM2D * 12 - *--------------------------------------------------------------------------------------------* 12 - 374=O *IN40 2N CHAR 1 12000002 - 375=O *IN41 1N CHAR 1 12000003 - 376 dcl-proc writeMsg; 000328 - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 11 - Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq - Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number - 377 dcl-pi *n; 000329 - 378 text varchar(256) const; 000330 - 379 end-pi; 000331 - 380 dcl-s data char(256); 000332 - 381 data = text; 000333 - 382 QMHSNDPM( 000334 - 383 'CPF9897' : 000335 - 384 'QCPFMSG QSYS ' : 000336 - 385 data : 000337 - 386 %len(text) : 000338 - 387 '*INFO ' : 000339 - 388 '* ' : 000340 - 389 1 : 000341 - 390 smsgkey : 000342 - 391 x'0000000000000000'); 000343 - 392 msgrrn += 1; 000344 - 393 spgmq = statusDS.programName; 000345 - 394 write itpmsgsfl; 000346 - 395 end-proc; 000347 - * * * * * E N D O F S O U R C E * * * * * - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 12 - A d d i t i o n a l D i a g n o s t i c M e s s a g e s - Msg id Sv Number Seq Message text - * * * * * E N D O F A D D I T I O N A L D I A G N O S T I C M E S S A G E S * * * * * - O u t p u t B u f f e r P o s i t i o n s - Line Start End Field or Constant - Number Pos Pos - 359 2 2 *IN50 - 360 1 1 *IN51 - 361 3 3 SOPT - 362 4 28 SIITEM - 363 29 76 SIDESC - 359 2 2 *IN50 - 360 1 1 *IN51 - 361 3 3 SOPT - 362 4 28 SIITEM - 363 29 76 SIDESC - 365 2 2 *IN30 - 366 1 1 *IN31 - 367 3 32 SSEARCH - 365 2 2 *IN30 - 366 1 1 *IN31 - 367 3 32 SSEARCH - 371 1 4 SMSGKEY - 372 5 14 SPGMQ - 371 1 4 SMSGKEY - 372 5 14 SPGMQ - 374 2 2 *IN40 - 375 1 1 *IN41 - 374 2 2 *IN40 - 375 1 1 *IN41 - * * * * * E N D O F O U T P U T B U F F E R P O S I T I O N * * * * * - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 13 - C r o s s R e f e r e n c e - File and Record References: - File Device References (D=Defined) - Record - ITMPRM2D WORKSTN 35D 241 - ITPSFL 35D 163 240 251 - 256 345 358 - ITPCTL 35D 170 219 336 - 364 - ITPFOOT 35D 175 211 368 - ITPNONE 35D 179 205 369 - ITPMSGSFL 35D 183 370 394 - ITPMSGCTL 35D 189 214 353 - 373 - Global Field References: - Field Attributes References (D=Defined M=Modified) - *INLR N(1) 263M - *IN03 N(1) 164D 171M 176M 180M - 184M 190M 199 221 - *IN05 N(1) 165D 172M 177M 181M - 185M 191M 226 - *IN12 N(1) 166D 173M 178M 182M - 186M 192M 199 221 - *IN30 N(1) 204M 208M 365 - *IN31 N(1) 335M 337M 366 - *IN40 N(1) 213M 216M 374 - *IN41 N(1) 352M 354M 375 - *IN50 N(1) 339M 359 - *IN51 N(1) 340M 360 - CLEARMSGS BEGSR 200 350D - FILLSUBFILE BEGSR 207 333D - I I(10,0) 60D 338 342 343 - 343 - ITEMROW DS(89) 53D 58 308M 309M - 315 - DESC A(60) 55D 309 - VARYING(2) - ITEM A(25) 54D 308 - VARYING(2) - LOADROWS BEGSR 201 267D - *RNF7031 MSGKEY A(4) 63D - MSGRRN I(10,0) 35 62D 212 255 - 351M 392M - NUMROWS I(10,0) 59D 203 238 268M - 300 314M 315 338 - PCOMPCD A(3) 31D 278 - BASED(_QRNL_PRM+) - PITEM A(25) 32D 193 222M 257M - BASED(_QRNL_PRM+) - VARYING(2) - QMHSNDPM PROTOTYPE 37D 382M - ROWS(500) DS(89) 58D 300 315M 342 - 343 343 - DESC A(60) 343 343 - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 14 - VARYING(2) - ITEM A(25) 342 - VARYING(2) - RRN I(10,0) 35 61D 244 334M - 344M - SEARCH A(30) 65D 193M 194 195M - VARYING(2) 197 230 231M 279 - 280 281 - SELRRN I(10,0) 64D 239M 243 244M - 255 256 - SIDESC A(48) 169M 343M 363 - SIITEM A(25) 168M 257 342M 362 - SMSGKEY A(4) 187M 371 390 - SOPT A(1) 167M 242 248 249 - 341M 361 - SPGMQ A(10) 188M 372 393M - *RNF7031 SQFAPP CONST 131D - *RNF7031 SQFCRT CONST 129D - *RNF7031 SQFOVR CONST 130D - *RNF7031 SQFRD CONST 128D - SQL_00000 B(4,0) 134D 287 292 - *RNF7031 SQL_00001 B(4,0) 135D - SQL_00002 U(10,0) 136D 283 - SQL_00003 A(1) 137D 284 - *RNF7031 SQL_00004 A(119) 138D - SQL_00005 A(3) 139D 278M - SQL_00006 A(30) 140D 279M - VARYING(2) - SQL_00007 A(30) 141D 280M - VARYING(2) - SQL_00008 A(30) 142D 281M - VARYING(2) - SQL_00009 B(4,0) 146D 305 - *RNF7031 SQL_00010 B(4,0) 147D - *RNF7031 SQL_00011 U(10,0) 148D - SQL_00012 A(1) 149D 307 - *RNF7031 SQL_00013 A(119) 150D - SQL_00014 A(25) 151D 308 - VARYING(2) - SQL_00015 A(60) 152D 309 - VARYING(2) - SQL_00016 B(4,0) 156D 322 327 - *RNF7031 SQL_00017 B(4,0) 157D - SQL_00018 U(10,0) 158D 319 - *RNF7031 SQL_00019 A(1) 159D - *RNF7031 SQL_00020 A(118) 160D - *RNF7031 SQL_00021 A(1) 161D - *RNF7031 SQLABC B(9,0) 73D - *RNF7031 SQLAID A(8) 71D - SQLCA DS(136) 69D 107 112 116 - 120 286 291 304 - 321 326 - SQLCABC I(10,0) 72D 73 - SQLCAID A(8) 70D 71 - SQLCLSE CONST 115 126D - SQLCLSE_CALL PROTOTYPE 115D 325M - SQLCMIT CONST 119 127D - *RNF7031 SQLCMIT_CALL PROTOTYPE 119D - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 15 - *RNF7031 SQLCOD B(9,0) 75D - SQLCODE I(10,0) 74D 75 295 296 - 311 311 - *RNF7031 SQLERL B(4,0) 77D - *RNF7031 SQLERM A(70) 79D - *RNF7031 SQLERP A(8) 81D - SQLERR A(24) 82D 83 84 85 - 86 87 88 89 - *RNF7031 SQLERRD(6) I(10,0) 89D - SQLERRMC A(70) 78D 79 - SQLERRML I(5,0) 76D 77 - SQLERRP A(8) 80D 81 - *RNF7031 SQLER1 B(9,0) 83D - *RNF7031 SQLER2 B(9,0) 84D - *RNF7031 SQLER3 B(9,0) 85D - *RNF7031 SQLER4 B(9,0) 86D - *RNF7031 SQLER5 B(9,0) 87D - SQLER6 B(9,0) 88D 282M 302M 318M - SQLOPEN CONST 111 125D - SQLOPEN_CALL PROTOTYPE 111D 290M - SQLROUTE CONST 106 124D - SQLROUTE_CALL PROTOTYPE 106D 285M 303M 320M - SQLSTATE A(5) 103D 104 - *RNF7031 SQLSTT A(5) 104D - *RNF7031 SQLWARN(11) A(1) 102D - *RNF7031 SQLWNA A(1) 101D - *RNF7031 SQLWN0 A(1) 91D - *RNF7031 SQLWN1 A(1) 92D - *RNF7031 SQLWN2 A(1) 93D - *RNF7031 SQLWN3 A(1) 94D - *RNF7031 SQLWN4 A(1) 95D - *RNF7031 SQLWN5 A(1) 96D - *RNF7031 SQLWN6 A(1) 97D - *RNF7031 SQLWN7 A(1) 98D - *RNF7031 SQLWN8 A(1) 99D - *RNF7031 SQLWN9 A(1) 100D - SQLWRN A(11) 90D 91 92 93 - 94 95 96 97 - 98 99 100 101 - 102 - SSEARCH A(30) 174M 197M 230 231 - 367 - STATUSDS DS(343) 49D 393 - PROGRAMNAME A(10) 50D 393 - WRITEMSG PROTOTYPE 246M 249M 296M 376 - Field References for subprocedure WRITEMSG - Field Attributes References (D=Defined M=Modified) - DATA A(256) 380D 381M 385 - TEXT A(256) 378D 381 386 - BASED(_QRNL_PST+) - VARYING(2) - Indicator References: - Indicator References (D=Defined M=Modified) - 03 164M 171M 176M 180M - 184M 190M 199 221 - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 16 - 05 165M 172M 177M 181M - 185M 191M 226 - 12 166M 173M 178M 182M - 186M 192M 199 221 - 30 204M 208M 365 - 31 335M 337M 366 - 40 213M 216M 374 - 41 352M 354M 375 - 50 339M 359 - 51 340M 360 - LR 263M - * * * * * E N D O F C R O S S R E F E R E N C E * * * * * - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 17 - E x t e r n a l R e f e r e n c e s - Statically bound procedures: - Procedure References - Imported fields: - Field Attributes Defined - No references in the source. - Exported fields: - Field Attributes Defined - No references in the source. - * * * * * E N D O F E X T E R N A L R E F E R E N C E S * * * * * - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 18 - M e s s a g e S u m m a r y - Msg id Sv Number Message text - *RNF7031 00 40 The name or indicator is not referenced. - * * * * * E N D O F M E S S A G E S U M M A R Y * * * * * - 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/ITMPRMT IDEV 08/20/26 16:25:08 Page 19 - F i n a l S u m m a r y - Message Totals: - Information (00) . . . . . . . : 40 - Warning (10) . . . . . . . : 0 - Error (20) . . . . . . . : 0 - Severe Error (30+) . . . . . . : 0 - --------------------------------- ------- - Total . . . . . . . . . . . . . : 40 - Source Totals: - Records . . . . . . . . . . . . : 395 - Specifications . . . . . . . . : 316 - Data records . . . . . . . . . : 0 - Comments . . . . . . . . . . . : 68 - * * * * * E N D O F F I N A L S U M M A R Y * * * * * - Program ITMPRMT placed in library PERPDEMO. 00 highest severity. Created on 08/20/26 at 16:25:09. - * * * * * E N D O F C O M P I L A T I O N * * * * * diff --git a/perp/tmp/logs/wrkcnvd.file.log b/perp/tmp/logs/wrkcnvd.file.log new file mode 100644 index 00000000..556e79a2 --- /dev/null +++ b/perp/tmp/logs/wrkcnvd.file.log @@ -0,0 +1,205 @@ +CPI2126: AUT parameter ignored. +CPI2121: Replaced object WRKCNVD type *FILE was moved to QRPLOBJ. +CPC7301: File WRKCNVD created in library PERPDEMO. + 5770SS1 V7R5M0 220415 Data Description PERPDEMO/WRKCNVD 8/16/26 17:35:52 Page 1 + File name . . . . . . . . . . . . . . . . . . . . . : WRKCNVD + Library name . . . . . . . . . . . . . . . . . . : PERPDEMO + File attribute . . . . . . . . . . . . . . . . . . : Display + Source file containing DDS . . . . . . . . . . . . : QDDSSRC + Library name . . . . . . . . . . . . . . . . . . : PERPDEMO + Source member containing DDS . . . . . . . . . . . : WRKCNVD + Source member last changed . . . . . . . . . . . . : 08/20/26 17:35:51 + Source listing options . . . . . . . . . . . . . . : *SOURCE *LIST *NOSECLVL *NOEVENTF + DDS generation severity level . . . . . . . . . . . : 20 + DDS flagging severity level . . . . . . . . . . . . : 00 + Authority . . . . . . . . . . . . . . . . . . . . . : *LIBCRTAUT + Replace file . . . . . . . . . . . . . . . . . . . : *YES + Text . . . . . . . . . . . . . . . . . . . . . . . : + Compiler . . . . . . . . . . . . . . . . . . . . . : IBM System i5 Data Description Processor + Data Description Source + SEQNBR *...+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8 Date + 1 A DSPSIZ(24 80 *DS3) + 2 A PRINT + 3 A CA03(03 'Exit') + 4 A CA05(05 'Refresh') + 5 A CA06(06 'Add') + 6 A CA12(12 'Cancel') + 7 A R CVSFL SFL + 8 A 51 SFLNXTCHG + 9 A SOPT 1A B 8 2 + 10 A 50 DSPATR(RI) + 11 A 50 DSPATR(PC) + 12 A SFROM 5A O 8 6 + 13 A STO 5A O 8 12 + 14 A SFACT 15Y 6O 8 18EDTCDE(3) + 15 A R CVCTL SFLCTL(CVSFL) + 16 A SFLSIZ(0099) + 17 A SFLPAG(0007) + 18 A OVERLAY + 19 A SFLDSPCTL + 20 A N31 30 SFLDSP + 21 A 31 SFLCLR + 22 A N31 30 SFLEND(*MORE) + 23 A 1 20'Work with Item UOM Conversions' + 24 A DSPATR(HI) + 25 A 2 2'Company:' + 26 A SCOMPDSP 3A O 2 11 + 27 A 2 20'Item Number:' + 28 A SFITEM 25A B 2 33 + 29 A 2 59'(? = prompt)' + 30 A 4 2'Type option, press Enter.' + 31 A 5 4'2=Change 4=Delete' + 32 A 7 2'Opt' + 33 A DSPATR(UL) + 34 A 7 6'From' + 35 A DSPATR(UL) + 36 A 7 12'To' + 37 A DSPATR(UL) + 38 A 7 27'Factor' + 5770SS1 V7R5M0 220415 Data Description PERPDEMO/WRKCNVD 8/16/26 17:35:52 Page 2 + Data Description Source + SEQNBR *...+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8 Date + 39 A DSPATR(UL) + 40 A R CVFOOT + 41 A 23 2'F3=Exit F5=Refresh F6=Add- + 42 A F12=Cancel' + 43 A COLOR(BLU) + 44 A R CVNONE + 45 A OVERLAY + 46 A 10 20'** No conversions for this it- + 47 A em **' + 48 A R CVNOITEM + 49 A OVERLAY + 50 A 10 20'** Enter an item number to be- + 51 A gin **' + 52 A R CVEDIT + 53 A OVERLAY + 54 A 1 25'Edit Item UOM Conversion' + 55 A DSPATR(HI) + 56 A 2 2'Mode:' + 57 A EMODE 1A O 2 8 + 58 A 3 2'From UOM:' + 59 A EFROM 5A B 3 13 + 60 A 4 2'To UOM:' + 61 A ETO 5A B 4 13 + 62 A 5 2'Factor:' + 63 A EFACT 15Y 6B 5 13EDTCDE(3) + 64 A 6 2'Active:' + 65 A EACTIVE 1A B 6 13 + 66 A 23 2'Enter=Save F12=Cancel' + 67 A COLOR(BLU) + 68 A R CVMSGSFL SFL + 69 A SFLMSGRCD(24) + 70 A SMSGKEY SFLMSGKEY + 71 A SPGMQ SFLPGMQ(10) + 72 A R CVMSGCTL SFLCTL(CVMSGSFL) + 73 A OVERLAY + 74 A N41 40 SFLDSP + 75 A 41 SFLCLR + 76 A N41 40 SFLEND + 77 A SFLSIZ(0002) + 78 A SFLPAG(0001) + * * * * * E N D O F S O U R C E * * * * * + 5770SS1 V7R5M0 220415 Data Description PERPDEMO/WRKCNVD 8/16/26 17:35:52 Page 3 + Expanded Source + Field Buffer position + SEQNBR *...+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8 length Out In + 1 DSPSIZ(24 80 *DS3) PRINT + + 3 CA03(03 'Exit') CA05(05 'Refresh') + + 5 CA06(06 'Add') CA12(12 'Cancel') + * Option indicator output buffer positions: + * *IN50 0002 *IN51 0001 + * Response indicator input buffer positions: + * *IN03 0001 *IN05 0002 *IN06 0003 *IN12 0004 + 7 R CVSFL SFL + 8 51 SFLNXTCHG + 9 SOPT 1A B 8 2 1 3 5 + 10 50 DSPATR(RI) + 11 50 DSPATR(PC) + 12 SFROM 5A O 8 6 5 4 6 + 13 STO 5A O 8 12 5 9 11 + 14 SFACT 15Y 6O 8 18EDTCDE(3) 15 14 16 + * Option indicator output buffer positions: + * *IN30 0002 *IN31 0001 + * Response indicator input buffer positions: + * *IN03 0001 *IN05 0002 *IN06 0003 *IN12 0004 + 15 R CVCTL + *DS3 SFLSIZ(0099) SFLPAG(007) + 15 SFLCTL(CVSFL) OVERLAY SFLDSPCTL + 20 N31 30 SFLDSP + 21 31 SFLCLR + 22 N31 30 SFLEND(*MORE) + 23 1 20'Work with Item UOM Conversions' + 30 + 24 DSPATR(HI) + 25 2 2'Company:' 8 + 26 SCOMPDSP 3A O 2 11 3 3 + 27 2 20'Item Number:' 12 + 28 SFITEM 25A B 2 33 25 6 5 + 29 2 59'(? = prompt)' 12 + 30 4 2'Type option, press Enter.' 25 + 31 5 4'2=Change 4=Delete' 19 + 32 7 2'Opt' DSPATR(UL) 3 + 34 7 6'From' DSPATR(UL) 4 + 36 7 12'To' DSPATR(UL) 2 + 38 7 27'Factor' DSPATR(UL) 6 + * Response indicator input buffer positions: + * *IN03 0001 *IN05 0002 *IN06 0003 *IN12 0004 + 40 R CVFOOT + 41 23 2'F3=Exit F5=Refresh F6=Add F1- 42 + 41 2=Cancel' COLOR(BLU) + * Response indicator input buffer positions: + * *IN03 0001 *IN05 0002 *IN06 0003 *IN12 0004 + 44 R CVNONE OVERLAY + 46 10 20'** No conversions for this item **- 34 + 46 ' + * Response indicator input buffer positions: + * *IN03 0001 *IN05 0002 *IN06 0003 *IN12 0004 + 48 R CVNOITEM OVERLAY + 50 10 20'** Enter an item number to begin *- 35 + 50 *' + 5770SS1 V7R5M0 220415 Data Description PERPDEMO/WRKCNVD 8/16/26 17:35:52 Page 4 + Expanded Source + Field Buffer position + SEQNBR *...+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8 length Out In + * Response indicator input buffer positions: + * *IN03 0001 *IN05 0002 *IN06 0003 *IN12 0004 + 52 R CVEDIT OVERLAY + 54 1 25'Edit Item UOM Conversion' + 24 + 55 DSPATR(HI) + 56 2 2'Mode:' 5 + 57 EMODE 1A O 2 8 1 1 + 58 3 2'From UOM:' 9 + 59 EFROM 5A B 3 13 5 2 5 + 60 4 2'To UOM:' 7 + 61 ETO 5A B 4 13 5 7 10 + 62 5 2'Factor:' 7 + 63 EFACT 15Y 6B 5 13EDTCDE(3) 15 12 15 + 64 6 2'Active:' 7 + 65 EACTIVE 1A B 6 13 1 27 30 + 66 23 2'Enter=Save F12=Cancel' + 23 + 67 COLOR(BLU) + * Response indicator input buffer positions: + * *IN03 0001 *IN05 0002 *IN06 0003 *IN12 0004 + 68 R CVMSGSFL + *DS3 SFLMSGRCD(24) + 68 SFL + 70 SMSGKEY SFLMSGKEY 4 1 5 + 71 SPGMQ SFLPGMQ(10) 10 5 9 + * Option indicator output buffer positions: + * *IN40 0002 *IN41 0001 + * Response indicator input buffer positions: + * *IN03 0001 *IN05 0002 *IN06 0003 *IN12 0004 + 72 R CVMSGCTL + *DS3 SFLSIZ(0002) SFLPAG(001) + 72 SFLCTL(CVMSGSFL) OVERLAY + 74 N41 40 SFLDSP + 75 41 SFLCLR + 76 N41 40 SFLEND + * * * * * E N D O F E X P A N D E D S O U R C E * * * * * + 5770SS1 V7R5M0 220415 Data Description PERPDEMO/WRKCNVD 8/16/26 17:35:52 Page 5 + Message Summary + Total Informational Warning Error Severe + (0-9) (10-19) (20-29) (30-99) + 0 0 0 0 0 + * CPC7301 00 Message . . . . : File WRKCNVD created in library PERPDEMO. + * * * * * E N D O F C O M P I L A T I O N * * * * * From 76df589695f4de1aa519ab9ced157cddbc9a7fc2 Mon Sep 17 00:00:00 2001 From: Gary Jones Date: Wed, 26 Aug 2026 21:12:57 +0000 Subject: [PATCH 13/13] PERP: extend required-field validation to 12 more Add/Change programs Following the wrkitmr fix, an audit found the same "blank required/FK field surfaces as a raw SQLCODE/SQLSTATE message" trait in 12 other programs. Fixed all of them: wrkvndr, wrkusrr, wrkcnvr, wrkcmr, wrkiclr, wrkuomr, wrkivnr, wrklotr (each gets a validateXxx subroutine checking required fields before the SQL, with plain per-field messages), plus one-line UOM checks in poentr/reqentr's changeLine, and unit_price/currency_code + company_code/ company_name/base_currency checks in wrkivpr/perpselr. While there, fixed the SAME message-display bugs already documented for wrkitmr in three of these files (wrkvndr, wrkcmr, wrkuomr had no holdMsg mechanism at all, so every add/change/delete result was silently lost) and the same return;-ends-whole-program bug in those same three files' error paths (should be leavesr;). A module-wide sweep afterward found the identical return; bug in one more file, rcnbrwr.sqlrpgle, NOT fixed here since it's outside this fix's scope -- flagged for a follow-up decision. All 12 programs rebuilt clean (severity 00) and live-verified: each shows the correct field-specific message, and a full valid save still works. Also includes a one-time shadow-build of cfdemo's menu.menu into this task's AITSK00019 build library, needed to restore command-line navigation for interactive testing (this task started in a fresh container without the shadow-menu from earlier in this session). This produced cfdemo/build/* artifacts that are specific to this ephemeral task library and have no value in a future container -- worth discarding rather than keeping tracked. Co-Authored-By: CoderFlow Learn more: https://coderflow.ai --- cfdemo/build/AITSK00019.lib | 0 cfdemo/build/menu.file | 0 cfdemo/build/menu.menu | 0 cfdemo/build/menu.msgf | 0 cfdemo/tmp/logs/AITSK00019.lib.log | 0 cfdemo/tmp/logs/menu.file.log | 92 + cfdemo/tmp/logs/menu.menu.log | 1 + cfdemo/tmp/logs/menu.msgf.log | 1 + perp/build/wrkcmd.file | 0 perp/build/wrkcmr.pgm | 0 perp/build/wrkuomd.file | 0 perp/build/wrkuomr.pgm | 0 perp/build/wrkvndd.file | 0 perp/build/wrkvndr.pgm | 0 perp/qddssrc/wrkitmd.dspf | 2 +- perp/qrpglesrc/perpselr.sqlrpgle | 89 +- perp/qrpglesrc/poentr.sqlrpgle | 5 + perp/qrpglesrc/reqentr.sqlrpgle | 5 + perp/qrpglesrc/wrkcmr.sqlrpgle | 99 +- perp/qrpglesrc/wrkcnvr.sqlrpgle | 77 +- perp/qrpglesrc/wrkiclr.sqlrpgle | 69 +- perp/qrpglesrc/wrkitmr.sqlrpgle | 98 +- perp/qrpglesrc/wrkivnr.sqlrpgle | 99 +- perp/qrpglesrc/wrkivpr.sqlrpgle | 11 +- perp/qrpglesrc/wrklotr.sqlrpgle | 26 +- perp/qrpglesrc/wrkuomr.sqlrpgle | 90 +- perp/qrpglesrc/wrkusrr.sqlrpgle | 77 +- perp/qrpglesrc/wrkvndr.sqlrpgle | 131 +- perp/tmp/logs/wrkcnvd.file.log | 205 -- perp/tmp/logs/wrklotr.pgm.log | 2799 ++++++++++++++++++++++++++++ 30 files changed, 3551 insertions(+), 425 deletions(-) create mode 100644 cfdemo/build/AITSK00019.lib create mode 100644 cfdemo/build/menu.file create mode 100644 cfdemo/build/menu.menu create mode 100644 cfdemo/build/menu.msgf create mode 100644 cfdemo/tmp/logs/AITSK00019.lib.log create mode 100644 cfdemo/tmp/logs/menu.file.log create mode 100644 cfdemo/tmp/logs/menu.menu.log create mode 100644 cfdemo/tmp/logs/menu.msgf.log create mode 100644 perp/build/wrkcmd.file create mode 100644 perp/build/wrkcmr.pgm create mode 100644 perp/build/wrkuomd.file create mode 100644 perp/build/wrkuomr.pgm create mode 100644 perp/build/wrkvndd.file create mode 100644 perp/build/wrkvndr.pgm delete mode 100644 perp/tmp/logs/wrkcnvd.file.log create mode 100644 perp/tmp/logs/wrklotr.pgm.log diff --git a/cfdemo/build/AITSK00019.lib b/cfdemo/build/AITSK00019.lib new file mode 100644 index 00000000..e69de29b diff --git a/cfdemo/build/menu.file b/cfdemo/build/menu.file new file mode 100644 index 00000000..e69de29b diff --git a/cfdemo/build/menu.menu b/cfdemo/build/menu.menu new file mode 100644 index 00000000..e69de29b diff --git a/cfdemo/build/menu.msgf b/cfdemo/build/menu.msgf new file mode 100644 index 00000000..e69de29b diff --git a/cfdemo/tmp/logs/AITSK00019.lib.log b/cfdemo/tmp/logs/AITSK00019.lib.log new file mode 100644 index 00000000..e69de29b diff --git a/cfdemo/tmp/logs/menu.file.log b/cfdemo/tmp/logs/menu.file.log new file mode 100644 index 00000000..777828f7 --- /dev/null +++ b/cfdemo/tmp/logs/menu.file.log @@ -0,0 +1,92 @@ +CPC7301: File QDDSSRC created in library AITSK00019. +CPC7305: Member MENU added to file QDDSSRC in AITSK00019. +CPC7301: File MENU created in library AITSK00019. + 5770SS1 V7R5M0 220415 Data Description AITSK00019/MENU 8/23/26 16:28:31 Page 1 + File name . . . . . . . . . . . . . . . . . . . . . : MENU + Library name . . . . . . . . . . . . . . . . . . : AITSK00019 + File attribute . . . . . . . . . . . . . . . . . . : Display + Source file containing DDS . . . . . . . . . . . . : QDDSSRC + Library name . . . . . . . . . . . . . . . . . . : AITSK00019 + Source member containing DDS . . . . . . . . . . . : MENU + Source member last changed . . . . . . . . . . . . : 08/26/26 16:28:30 + Source listing options . . . . . . . . . . . . . . : *SOURCE *LIST *NOSECLVL *NOEVENTF + DDS generation severity level . . . . . . . . . . . : 20 + DDS flagging severity level . . . . . . . . . . . . : 00 + Authority . . . . . . . . . . . . . . . . . . . . . : *LIBCRTAUT + Replace file . . . . . . . . . . . . . . . . . . . : *YES + Text . . . . . . . . . . . . . . . . . . . . . . . : + Compiler . . . . . . . . . . . . . . . . . . . . . : IBM System i5 Data Description Processor + Data Description Source + SEQNBR *...+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8 Date + 1 A* Free Form Menu: MENU + 2 A DSPSIZ(24 80 *DS3 - + 3 A 27 132 *DS4) + 4 A CHGINPDFT + 5 A INDARA + 6 A PRINT(*LIBL/QSYSPRT) + 7 A R MENU + * CPD5235-.********* + * CPD8111-********** + 8 A DSPMOD(*DS3) + 9 A LOCK + 10 A SLNO(01) + 11 A CLRL(*ALL) + * CPD8018-* + 12 A ALWROL + * CPD8018-* + 13 A CF03 + 14 A HELP + 15 A HOME + 16 A HLPRTN + 17 A 1 2'MENU' + 18 A COLOR(BLU) + 19 A 1 29'Agentic Coding Demo Menu' + 20 A DSPATR(HI) + 21 A COLOR(WHT) + 22 A 3 2'Select one of the following:' + 23 A COLOR(BLU) + 24 A 5 7'1. Work with Customers' + 25 A 6 7'2. Work with Customers (RPGOA)' + 26 A 7 7'3. Work with Customers (EJS)' + 27 A 8 7'4. Go to PERP menu (PERPMNU)' + 28 A 10 6'90. Sign off' + 29 A* CMDPROMPT Do not delete this DDS spec. + 30 A 021 2'Selection: - + 31 A ' + * * * * * E N D O F S O U R C E * * * * * + 5770SS1 V7R5M0 220415 Data Description AITSK00019/MENU 8/23/26 16:28:31 Page 2 + Expanded Source + Field Buffer position + SEQNBR *...+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8 length Out In + 2 DSPSIZ(24 80 *DS3 - + 2 27 132 *DS4) CHGINPDFT + + 5 INDARA PRINT(*LIBL/QSYSPRT) + 7 R MENU DSPMOD(*DS3) LOCK SLNO(01) + + 11 CLRL(*ALL) ALWROL CF03 HELP HOME + + 16 HLPRTN + 17 1 2'MENU' COLOR(BLU) 4 + 19 1 29'Agentic Coding Demo Menu' + 24 + 20 DSPATR(HI) COLOR(WHT) + 22 3 2'Select one of the following:' + 28 + 23 COLOR(BLU) + 24 5 7'1. Work with Customers' 22 + 25 6 7'2. Work with Customers (RPGOA)' 30 + 26 7 7'3. Work with Customers (EJS)' 28 + 27 8 7'4. Go to PERP menu (PERPMNU)' 28 + 28 10 6'90. Sign off' 12 + 30 21 2'Selection: - 38 + 30 ' + * * * * * E N D O F E X P A N D E D S O U R C E * * * * * + 5770SS1 V7R5M0 220415 Data Description AITSK00019/MENU 8/23/26 16:28:31 Page 3 + Messages + ID Severity Number + * CPD5235 10 1 Message . . . . : Record name same as name of file being created. + * CPD8018 10 2 Message . . . . : Keyword may not function as expected with DSPMOD. + * CPD8111 10 1 Message . . . . : Record may not function as expected. + 5770SS1 V7R5M0 220415 Data Description AITSK00019/MENU 8/23/26 16:28:31 Page 4 + Message Summary + Total Informational Warning Error Severe + (0-9) (10-19) (20-29) (30-99) + 4 0 4 0 0 + * CPC7301 00 Message . . . . : File MENU created in library AITSK00019. + * * * * * E N D O F C O M P I L A T I O N * * * * * diff --git a/cfdemo/tmp/logs/menu.menu.log b/cfdemo/tmp/logs/menu.menu.log new file mode 100644 index 00000000..0bcf05f3 --- /dev/null +++ b/cfdemo/tmp/logs/menu.menu.log @@ -0,0 +1 @@ +CPC9801: Object MENU type *MENU created in library AITSK00019. diff --git a/cfdemo/tmp/logs/menu.msgf.log b/cfdemo/tmp/logs/menu.msgf.log new file mode 100644 index 00000000..033bdfb8 --- /dev/null +++ b/cfdemo/tmp/logs/menu.msgf.log @@ -0,0 +1 @@ +CPC9801: Object MENU type *MSGF created in library AITSK00019. diff --git a/perp/build/wrkcmd.file b/perp/build/wrkcmd.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/wrkcmr.pgm b/perp/build/wrkcmr.pgm new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/wrkuomd.file b/perp/build/wrkuomd.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/wrkuomr.pgm b/perp/build/wrkuomr.pgm new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/wrkvndd.file b/perp/build/wrkvndd.file new file mode 100644 index 00000000..e69de29b diff --git a/perp/build/wrkvndr.pgm b/perp/build/wrkvndr.pgm new file mode 100644 index 00000000..e69de29b diff --git a/perp/qddssrc/wrkitmd.dspf b/perp/qddssrc/wrkitmd.dspf index d616d215..e50842a1 100644 --- a/perp/qddssrc/wrkitmd.dspf +++ b/perp/qddssrc/wrkitmd.dspf @@ -69,7 +69,7 @@ A EMODE 1A O 2 8 A 2 15'Item:' A EITEM 25A B 2 25 - A 2 51'(? = prompt)' + A N60 2 51'(? = prompt)' A 3 2'Description:' A EDESC 60A B 3 15 A 4 2'Short Desc:' diff --git a/perp/qrpglesrc/perpselr.sqlrpgle b/perp/qrpglesrc/perpselr.sqlrpgle index 8b263089..3b00bf88 100644 --- a/perp/qrpglesrc/perpselr.sqlrpgle +++ b/perp/qrpglesrc/perpselr.sqlrpgle @@ -53,6 +53,7 @@ dcl-s changeRrn int(10); dcl-s selOpt char(1); dcl-s msgkey char(4); dcl-s holdMsg ind; +dcl-s validationFailed ind; in ldaDS; scursel = ldaDS.compcd; @@ -192,6 +193,24 @@ begsr fillSubfile; endfor; endsr; +// --------------------------------------------------------------------- +// Required-field validation for the Add/Change Company panel, done here +// in RPG instead of letting a blank required field surface as a raw +// FK/NOT-NULL violation from the database. +begsr validateCompany; + validationFailed = *off; + if %trim(ecompc) = ''; + writeMsg('Company Code is required.'); + validationFailed = *on; + elseif %trim(ecompnm) = ''; + writeMsg('Company Name is required.'); + validationFailed = *on; + elseif %trim(ebasecur) = ''; + writeMsg('Base Currency is required.'); + validationFailed = *on; + endif; +endsr; + // --------------------------------------------------------------------- begsr clearMsgs; msgrrn = 0; @@ -207,6 +226,7 @@ endsr; // primary key) is editable while adding, protected while changing // (see changeCompany below). begsr addCompany; + exsr clearMsgs; emode = 'A'; *in60 = *off; ecompc = ''; @@ -218,20 +238,25 @@ begsr addCompany; ecntry = 'US'; ebasecur = 'USD'; exfmt coedit; - if not *in12 and ecompc <> '' and ecompnm <> ''; - exec sql - insert into perpdemo.company - (company_code, company_name, address_line1, city_name, - state_code, postal_code, country_code, base_currency) - values (:ecompc, :ecompnm, :eaddr1, :ecity, - :estate, :epostcd, :ecntry, :ebasecur); - if sqlcode < 0; - writeMsg('Add company failed: SQLCODE=' + %char(sqlcode) - + ' SQLSTATE=' + sqlstate); + if not *in12; + exsr validateCompany; + if validationFailed; + holdMsg = *on; else; - writeMsg('Company ' + %trim(ecompc) + ' created.'); + exec sql + insert into perpdemo.company + (company_code, company_name, address_line1, city_name, + state_code, postal_code, country_code, base_currency) + values (:ecompc, :ecompnm, :eaddr1, :ecity, + :estate, :epostcd, :ecntry, :ebasecur); + if sqlcode < 0; + writeMsg('Add company failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Company ' + %trim(ecompc) + ' created.'); + endif; + holdMsg = *on; endif; - holdMsg = *on; endif; // *in12 (F12) here only cancels the Add Company panel, not the // whole Select Company screen -- reset before returning to the @@ -246,6 +271,7 @@ endsr; // in the DDS, so the WHERE clause below always matches the row the // user actually selected, never a typo'd or retyped code. begsr changeCompany; + exsr clearMsgs; emode = 'C'; *in60 = *on; ecompc = scompc; @@ -263,25 +289,30 @@ begsr changeCompany; endif; exfmt coedit; if not *in12; - exec sql - update perpdemo.company - set company_name = :ecompnm, - address_line1 = :eaddr1, - city_name = :ecity, - state_code = :estate, - postal_code = :epostcd, - country_code = :ecntry, - base_currency = :ebasecur, - updated_at = current_timestamp, - updated_by = user - where company_code = :ecompc; - if sqlcode < 0; - writeMsg('Change failed: SQLCODE=' + %char(sqlcode) - + ' SQLSTATE=' + sqlstate); + exsr validateCompany; + if validationFailed; + holdMsg = *on; else; - writeMsg('Company ' + %trim(ecompc) + ' updated.'); + exec sql + update perpdemo.company + set company_name = :ecompnm, + address_line1 = :eaddr1, + city_name = :ecity, + state_code = :estate, + postal_code = :epostcd, + country_code = :ecntry, + base_currency = :ebasecur, + updated_at = current_timestamp, + updated_by = user + where company_code = :ecompc; + if sqlcode < 0; + writeMsg('Change failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Company ' + %trim(ecompc) + ' updated.'); + endif; + holdMsg = *on; endif; - holdMsg = *on; endif; *in12 = *off; endsr; diff --git a/perp/qrpglesrc/poentr.sqlrpgle b/perp/qrpglesrc/poentr.sqlrpgle index cdd88e92..a80cbfc1 100644 --- a/perp/qrpglesrc/poentr.sqlrpgle +++ b/perp/qrpglesrc/poentr.sqlrpgle @@ -555,6 +555,11 @@ begsr changeLine; leavesr; endif; + if %trim(euom) = ''; + writeMsg('UOM is required.'); + leavesr; + endif; + exec sql update perpdemo.po_line set ordered_qty = :eqty, diff --git a/perp/qrpglesrc/reqentr.sqlrpgle b/perp/qrpglesrc/reqentr.sqlrpgle index 68f19b8c..3a6fea67 100644 --- a/perp/qrpglesrc/reqentr.sqlrpgle +++ b/perp/qrpglesrc/reqentr.sqlrpgle @@ -513,6 +513,11 @@ begsr changeLine; leavesr; endif; + if %trim(euom) = ''; + writeMsg('UOM is required.'); + leavesr; + endif; + exec sql update perpdemo.requisition_line set quantity = :eqty, diff --git a/perp/qrpglesrc/wrkcmr.sqlrpgle b/perp/qrpglesrc/wrkcmr.sqlrpgle index 6b2fc37d..d6fb1722 100644 --- a/perp/qrpglesrc/wrkcmr.sqlrpgle +++ b/perp/qrpglesrc/wrkcmr.sqlrpgle @@ -49,12 +49,24 @@ dcl-s msgkey char(4); dcl-s selRrn int(10); dcl-s selOpt char(1); dcl-s filter varchar(20); +dcl-s holdMsg ind; +dcl-s validationFailed ind; filter = ''; sftype = ''; dow not *in03 and not *in12; - exsr clearMsgs; + // A message queued by an action handler below (addRow, etc.) must + // survive one full loop pass before being cleared, or it never + // reaches the screen -- clearMsgs wipes msgrrn back to 0 on the very + // next pass, before this pass's own exfmt ever shows it. holdMsg + // skips exactly one clearMsgs call right after such a message was + // queued. Same pattern as wrkitmr. + if holdMsg; + holdMsg = *off; + else; + exsr clearMsgs; + endif; exsr loadRows; if numRows = 0; @@ -143,7 +155,8 @@ begsr loadRows; endif; if sqlcode < 0; writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); - return; + holdMsg = *on; + leavesr; endif; dow numRows < %elem(rows); @@ -197,12 +210,14 @@ begsr handleOpt; exsr displayRow; other; writeMsg('Option ' + selOpt + ' not valid.'); + holdMsg = *on; endsl; endif; endsr; // --------------------------------------------------------------------- begsr addRow; + exsr clearMsgs; emode = 'A'; etype = filter; evalue = ''; @@ -211,23 +226,30 @@ begsr addRow; esort = 0; eactive = 'Y'; exsr editLoop; - if not *in12 and etype <> '' and evalue <> ''; - exec sql - insert into perpdemo.code_master - (code_type, code_value, description, short_desc, - sort_order, is_active) - values (:etype, :evalue, :edesc, :eshort, :esort, :eactive); - if sqlcode < 0; - writeMsg('Add failed: SQLCODE=' + %char(sqlcode) - + ' SQLSTATE=' + sqlstate); + if not *in12; + exsr validateCode; + if validationFailed; + holdMsg = *on; else; - writeMsg('Added ' + %trim(etype) + '/' + %trim(evalue) + '.'); + exec sql + insert into perpdemo.code_master + (code_type, code_value, description, short_desc, + sort_order, is_active) + values (:etype, :evalue, :edesc, :eshort, :esort, :eactive); + if sqlcode < 0; + writeMsg('Add failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Added ' + %trim(etype) + '/' + %trim(evalue) + '.'); + endif; + holdMsg = *on; endif; endif; endsr; // --------------------------------------------------------------------- begsr changeRow; + exsr clearMsgs; emode = 'C'; etype = stype; evalue = svalue; @@ -238,29 +260,37 @@ begsr changeRow; where code_type = :etype and code_value = :evalue; if sqlcode <> 0; writeMsg('Row disappeared before change.'); - return; + holdMsg = *on; + leavesr; endif; exsr editLoop; if not *in12; - exec sql - update perpdemo.code_master - set description = :edesc, - short_desc = :eshort, - sort_order = :esort, - is_active = :eactive, - updated_at = current_timestamp, - updated_by = user - where code_type = :etype and code_value = :evalue; - if sqlcode < 0; - writeMsg('Change failed: SQLCODE=' + %char(sqlcode)); + exsr validateCode; + if validationFailed; + holdMsg = *on; else; - writeMsg('Updated ' + %trim(etype) + '/' + %trim(evalue) + '.'); + exec sql + update perpdemo.code_master + set description = :edesc, + short_desc = :eshort, + sort_order = :esort, + is_active = :eactive, + updated_at = current_timestamp, + updated_by = user + where code_type = :etype and code_value = :evalue; + if sqlcode < 0; + writeMsg('Change failed: SQLCODE=' + %char(sqlcode)); + else; + writeMsg('Updated ' + %trim(etype) + '/' + %trim(evalue) + '.'); + endif; + holdMsg = *on; endif; endif; endsr; // --------------------------------------------------------------------- begsr deleteRow; + exsr clearMsgs; exec sql delete from perpdemo.code_master where code_type = :stype and code_value = :svalue; @@ -269,6 +299,7 @@ begsr deleteRow; else; writeMsg('Deleted ' + %trim(stype) + '/' + %trim(svalue) + '.'); endif; + holdMsg = *on; endsr; // --------------------------------------------------------------------- @@ -289,6 +320,24 @@ begsr editLoop; exfmt cmedit; endsr; +// --------------------------------------------------------------------- +// Required-field validation for the Add/Change panel, done here in RPG +// instead of letting a blank required field surface as a raw NOT-NULL +// violation from the database. +begsr validateCode; + validationFailed = *off; + if %trim(etype) = ''; + writeMsg('Code Type is required.'); + validationFailed = *on; + elseif %trim(evalue) = ''; + writeMsg('Code Value is required.'); + validationFailed = *on; + elseif %trim(edesc) = ''; + writeMsg('Description is required.'); + validationFailed = *on; + endif; +endsr; + // --------------------------------------------------------------------- begsr clearMsgs; msgrrn = 0; diff --git a/perp/qrpglesrc/wrkcnvr.sqlrpgle b/perp/qrpglesrc/wrkcnvr.sqlrpgle index c0976efc..686ed5e6 100644 --- a/perp/qrpglesrc/wrkcnvr.sqlrpgle +++ b/perp/qrpglesrc/wrkcnvr.sqlrpgle @@ -67,6 +67,7 @@ dcl-s filter varchar(25); dcl-s compcd char(3); dcl-s promptItem varchar(25); dcl-s holdMsg ind; +dcl-s validationFailed ind; in ldaDS; compcd = ldaDS.compcd; @@ -150,6 +151,7 @@ dow not *in03 and not *in12; if *in06; if sfitem = ''; writeMsg('Enter an item number before adding a conversion.'); + holdMsg = *on; else; filter = sfitem; exsr addRow; @@ -251,34 +253,43 @@ begsr handleOpt; exsr deleteRow; other; writeMsg('Option ' + selOpt + ' not valid.'); + holdMsg = *on; endsl; endif; endsr; // --------------------------------------------------------------------- begsr addRow; + exsr clearMsgs; emode = 'A'; efrom = ''; eto = ''; efact = 0; eactive = 'Y'; exsr editLoop; - if not *in12 and efrom <> '' and eto <> ''; - exec sql - insert into perpdemo.item_uom_conversion - (company_code, item_number, from_uom, to_uom, conversion_factor, is_active) - values (:compcd, :filter, :efrom, :eto, :efact, :eactive); - if sqlcode < 0; - writeMsg('Add failed: SQLCODE=' + %char(sqlcode) - + ' SQLSTATE=' + sqlstate); + if not *in12; + exsr validateConv; + if validationFailed; + holdMsg = *on; else; - writeMsg('Added ' + %trim(efrom) + ' -> ' + %trim(eto) + '.'); + exec sql + insert into perpdemo.item_uom_conversion + (company_code, item_number, from_uom, to_uom, conversion_factor, is_active) + values (:compcd, :filter, :efrom, :eto, :efact, :eactive); + if sqlcode < 0; + writeMsg('Add failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Added ' + %trim(efrom) + ' -> ' + %trim(eto) + '.'); + endif; + holdMsg = *on; endif; endif; endsr; // --------------------------------------------------------------------- begsr changeRow; + exsr clearMsgs; emode = 'C'; efrom = sfrom; eto = sto; @@ -295,24 +306,31 @@ begsr changeRow; endif; exsr editLoop; if not *in12; - exec sql - update perpdemo.item_uom_conversion - set conversion_factor = :efact, - is_active = :eactive, - updated_at = current_timestamp, - updated_by = user - where company_code = :compcd and item_number = :filter - and from_uom = :efrom and to_uom = :eto; - if sqlcode < 0; - writeMsg('Change failed: SQLCODE=' + %char(sqlcode)); + exsr validateConv; + if validationFailed; + holdMsg = *on; else; - writeMsg('Updated ' + %trim(efrom) + ' -> ' + %trim(eto) + '.'); + exec sql + update perpdemo.item_uom_conversion + set conversion_factor = :efact, + is_active = :eactive, + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd and item_number = :filter + and from_uom = :efrom and to_uom = :eto; + if sqlcode < 0; + writeMsg('Change failed: SQLCODE=' + %char(sqlcode)); + else; + writeMsg('Updated ' + %trim(efrom) + ' -> ' + %trim(eto) + '.'); + endif; + holdMsg = *on; endif; endif; endsr; // --------------------------------------------------------------------- begsr deleteRow; + exsr clearMsgs; exec sql delete from perpdemo.item_uom_conversion where company_code = :compcd and item_number = :filter @@ -322,6 +340,7 @@ begsr deleteRow; else; writeMsg('Deleted ' + %trim(sfrom) + ' -> ' + %trim(sto) + '.'); endif; + holdMsg = *on; endsr; // --------------------------------------------------------------------- @@ -329,6 +348,24 @@ begsr editLoop; exfmt cvedit; endsr; +// --------------------------------------------------------------------- +// Required-field validation for the Add/Change panel, done here in RPG +// instead of letting a blank From/To UOM or zero Factor surface as a raw +// FK/CHECK-constraint violation from the database. +begsr validateConv; + validationFailed = *off; + if %trim(efrom) = ''; + writeMsg('From UOM is required.'); + validationFailed = *on; + elseif %trim(eto) = ''; + writeMsg('To UOM is required.'); + validationFailed = *on; + elseif efact <= 0; + writeMsg('Factor is required.'); + validationFailed = *on; + endif; +endsr; + // --------------------------------------------------------------------- begsr clearMsgs; msgrrn = 0; diff --git a/perp/qrpglesrc/wrkiclr.sqlrpgle b/perp/qrpglesrc/wrkiclr.sqlrpgle index e6201688..2af17767 100644 --- a/perp/qrpglesrc/wrkiclr.sqlrpgle +++ b/perp/qrpglesrc/wrkiclr.sqlrpgle @@ -51,6 +51,7 @@ dcl-s selRrn int(10); dcl-s selOpt char(1); dcl-s compcd char(3); dcl-s holdMsg ind; +dcl-s validationFailed ind; in ldaDS; compcd = ldaDS.compcd; @@ -198,32 +199,41 @@ begsr handleOpt; exsr displayRow; other; writeMsg('Option ' + selOpt + ' not valid.'); + holdMsg = *on; endsl; endif; endsr; // --------------------------------------------------------------------- begsr addRow; + exsr clearMsgs; emode = 'A'; eclass = ''; edesc = ''; eactive = 'Y'; exsr editLoop; - if not *in12 and eclass <> ''; - exec sql - insert into perpdemo.item_class (company_code, class_code, description, is_active) - values (:compcd, :eclass, :edesc, :eactive); - if sqlcode < 0; - writeMsg('Add failed: SQLCODE=' + %char(sqlcode) - + ' SQLSTATE=' + sqlstate); + if not *in12; + exsr validateClass; + if validationFailed; + holdMsg = *on; else; - writeMsg('Added ' + %trim(eclass) + '.'); + exec sql + insert into perpdemo.item_class (company_code, class_code, description, is_active) + values (:compcd, :eclass, :edesc, :eactive); + if sqlcode < 0; + writeMsg('Add failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Added ' + %trim(eclass) + '.'); + endif; + holdMsg = *on; endif; endif; endsr; // --------------------------------------------------------------------- begsr changeRow; + exsr clearMsgs; emode = 'C'; eclass = sclass; exec sql @@ -238,23 +248,30 @@ begsr changeRow; endif; exsr editLoop; if not *in12; - exec sql - update perpdemo.item_class - set description = :edesc, - is_active = :eactive, - updated_at = current_timestamp, - updated_by = user - where company_code = :compcd and class_code = :eclass; - if sqlcode < 0; - writeMsg('Change failed: SQLCODE=' + %char(sqlcode)); + exsr validateClass; + if validationFailed; + holdMsg = *on; else; - writeMsg('Updated ' + %trim(eclass) + '.'); + exec sql + update perpdemo.item_class + set description = :edesc, + is_active = :eactive, + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd and class_code = :eclass; + if sqlcode < 0; + writeMsg('Change failed: SQLCODE=' + %char(sqlcode)); + else; + writeMsg('Updated ' + %trim(eclass) + '.'); + endif; + holdMsg = *on; endif; endif; endsr; // --------------------------------------------------------------------- begsr deleteRow; + exsr clearMsgs; exec sql delete from perpdemo.item_class where company_code = :compcd and class_code = :sclass; @@ -263,6 +280,7 @@ begsr deleteRow; else; writeMsg('Deleted ' + %trim(sclass) + '.'); endif; + holdMsg = *on; endsr; // --------------------------------------------------------------------- @@ -282,6 +300,21 @@ begsr editLoop; exfmt icedit; endsr; +// --------------------------------------------------------------------- +// Required-field validation for the Add/Change panel, done here in RPG +// instead of letting a blank required field surface as a raw NOT-NULL +// violation from the database. +begsr validateClass; + validationFailed = *off; + if %trim(eclass) = ''; + writeMsg('Class Code is required.'); + validationFailed = *on; + elseif %trim(edesc) = ''; + writeMsg('Description is required.'); + validationFailed = *on; + endif; +endsr; + // --------------------------------------------------------------------- begsr clearMsgs; msgrrn = 0; diff --git a/perp/qrpglesrc/wrkitmr.sqlrpgle b/perp/qrpglesrc/wrkitmr.sqlrpgle index d312dd74..1dd4ed80 100644 --- a/perp/qrpglesrc/wrkitmr.sqlrpgle +++ b/perp/qrpglesrc/wrkitmr.sqlrpgle @@ -80,6 +80,7 @@ dcl-s fLowOnly char(1); dcl-s fPosTo varchar(30); dcl-s promptItem varchar(25); dcl-s holdMsg ind; +dcl-s validationFailed ind; in ldaDS; compcd = ldaDS.compcd; @@ -273,7 +274,17 @@ endsr; // --------------------------------------------------------------------- begsr addRow; + // Clear any message left over from a PRIOR action before this one queues + // its own -- without this, pressing F6 again right after seeing a message + // (before the outer loop's own clearMsgs ever runs) stacks a second + // message behind the first, and the stale one shows instead of this + // action's real result. + exsr clearMsgs; emode = 'A'; + // PERP-57: the item prompt makes no sense while adding a brand-new item + // (there's nothing to look up yet) -- *in60 on hides the "(? = prompt)" + // hint and skips the prompt-invocation check in editLoop below. + *in60 = *on; eitem = ''; edesc = ''; eshort = ''; @@ -294,8 +305,24 @@ begsr addRow; eaisle = ''; ebay = ''; eshelf = ''; - exsr editLoop; - if not *in12 and eitem <> ''; + // Loop so a failed insert redisplays THIS SAME panel with the error and + // the user's own entries intact, instead of bouncing back to the list -- + // only a successful add or an explicit Cancel (F12) leaves the loop. + dow *on; + exsr editLoop; + if *in12; + leave; + endif; + // Clear the message the user just saw (if any) before queuing THIS + // iteration's own result -- otherwise a retry within this same loop + // stacks its message behind the previous iteration's, same as the + // across-actions case clearMsgs at the top of this subroutine guards. + exsr clearMsgs; + exsr validateEdit; + if validationFailed; + holdMsg = *on; + iter; + endif; exec sql insert into perpdemo.item (company_code, item_number, item_description, short_description, @@ -309,15 +336,21 @@ begsr addRow; if sqlcode < 0; writeMsg('Add failed: SQLCODE=' + %char(sqlcode) + ' SQLSTATE=' + sqlstate); + holdMsg = *on; + iter; else; writeMsg('Added ' + %trim(eitem) + '.'); + holdMsg = *on; + leave; endif; - endif; + enddo; endsr; // --------------------------------------------------------------------- begsr changeRow; + exsr clearMsgs; emode = 'C'; + *in60 = *off; eitem = siitem; exec sql select item_description, short_description, class_code, @@ -337,8 +370,19 @@ begsr changeRow; holdMsg = *on; leavesr; endif; - exsr editLoop; - if not *in12; + // Same retry-in-place shape as addRow: a failed update redisplays this + // panel with the error and the user's entries intact. + dow *on; + exsr editLoop; + if *in12; + leave; + endif; + exsr clearMsgs; + exsr validateEdit; + if validationFailed; + holdMsg = *on; + iter; + endif; exec sql update perpdemo.item set item_description = :edesc, @@ -361,14 +405,19 @@ begsr changeRow; where company_code = :compcd and item_number = :eitem; if sqlcode < 0; writeMsg('Change failed: SQLCODE=' + %char(sqlcode)); + holdMsg = *on; + iter; else; writeMsg('Updated ' + %trim(eitem) + '.'); + holdMsg = *on; + leave; endif; - endif; + enddo; endsr; // --------------------------------------------------------------------- begsr deleteRow; + exsr clearMsgs; exec sql delete from perpdemo.item where company_code = :compcd and item_number = :siitem; @@ -377,11 +426,13 @@ begsr deleteRow; else; writeMsg('Deleted ' + %trim(siitem) + '.'); endif; + holdMsg = *on; endsr; // --------------------------------------------------------------------- begsr displayRow; emode = 'D'; + *in60 = *off; eitem = siitem; exec sql select item_description, short_description, class_code, @@ -402,11 +453,19 @@ endsr; // --------------------------------------------------------------------- begsr editLoop; dow not *in12; + // Re-issue the message SFLCTL record before every exfmt on this format, + // exactly like the outer loop does for wictl -- otherwise a message + // queued by a failed insert/update (with the caller looping back into + // this same edit panel to show it) never reaches the screen, and any + // stale message left over from the calling list screen can bleed + // through WIEDIT's OVERLAY instead of being explicitly cleared. + *in40 = (msgrrn > 0); + write wimsgctl; exfmt wiedit; if *in12; leave; endif; - if %trim(eitem) = '?'; + if not *in60 and %trim(eitem) = '?'; promptItem = eitem; callItmprmt(compcd : promptItem); eitem = promptItem; @@ -416,6 +475,31 @@ begsr editLoop; enddo; endsr; +// --------------------------------------------------------------------- +// Required-field validation for the Add/Change panel, done here in RPG +// instead of letting a blank required field surface as a raw FK violation +// (e.g. ITEM_STKUOM_FK) from the database. Checked in screen order so the +// first message matches the first blank field the user would fix. +begsr validateEdit; + validationFailed = *off; + if %trim(eitem) = ''; + writeMsg('Item Number is required.'); + validationFailed = *on; + elseif %trim(edesc) = ''; + writeMsg('Description is required.'); + validationFailed = *on; + elseif %trim(eclass) = ''; + writeMsg('Class is required.'); + validationFailed = *on; + elseif %trim(einvuom) = ''; + writeMsg('Inventory UOM is required.'); + validationFailed = *on; + elseif %trim(estkuom) = ''; + writeMsg('Stocking UOM is required.'); + validationFailed = *on; + endif; +endsr; + // --------------------------------------------------------------------- begsr clearMsgs; msgrrn = 0; diff --git a/perp/qrpglesrc/wrkivnr.sqlrpgle b/perp/qrpglesrc/wrkivnr.sqlrpgle index a6f86b53..12740baa 100644 --- a/perp/qrpglesrc/wrkivnr.sqlrpgle +++ b/perp/qrpglesrc/wrkivnr.sqlrpgle @@ -73,6 +73,7 @@ dcl-s fVendor varchar(10); dcl-s promptItem varchar(25); dcl-s promptVendor varchar(10); dcl-s holdMsg ind; +dcl-s validationFailed ind; in ldaDS; compcd = ldaDS.compcd; @@ -264,12 +265,14 @@ begsr handleOpt; exsr deleteRow; other; writeMsg('Option ' + selOpt + ' not valid.'); + holdMsg = *on; endsl; endif; endsr; // --------------------------------------------------------------------- begsr addRow; + exsr clearMsgs; if fItem = '' and fVendor = ''; writeMsg('Enter an item or vendor before adding a profile.'); holdMsg = *on; @@ -285,27 +288,34 @@ begsr addRow; epref = 'N'; eactive = 'Y'; exsr editLoop; - if not *in12 and eitem <> '' and evendor <> ''; - exec sql - insert into perpdemo.item_vendor - (company_code, item_number, vendor_code, vendor_part_number, - lead_time_days, moq, pack_size, is_preferred, is_active) - values (:compcd, :eitem, :evendor, :epartn, - :eleadtm, :emoq, :epacksz, :epref, :eactive); - if sqlcode = -803; - writeMsg('Add failed: another vendor is already preferred for' - + ' this item - clear it first.'); - elseif sqlcode < 0; - writeMsg('Add failed: SQLCODE=' + %char(sqlcode) - + ' SQLSTATE=' + sqlstate); + if not *in12; + exsr validateVendorProfile; + if validationFailed; + holdMsg = *on; else; - writeMsg('Added ' + %trim(eitem) + '/' + %trim(evendor) + '.'); + exec sql + insert into perpdemo.item_vendor + (company_code, item_number, vendor_code, vendor_part_number, + lead_time_days, moq, pack_size, is_preferred, is_active) + values (:compcd, :eitem, :evendor, :epartn, + :eleadtm, :emoq, :epacksz, :epref, :eactive); + if sqlcode = -803; + writeMsg('Add failed: another vendor is already preferred for' + + ' this item - clear it first.'); + elseif sqlcode < 0; + writeMsg('Add failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Added ' + %trim(eitem) + '/' + %trim(evendor) + '.'); + endif; + holdMsg = *on; endif; endif; endsr; // --------------------------------------------------------------------- begsr changeRow; + exsr clearMsgs; emode = 'C'; eitem = siitem; evendor = sivendor; @@ -324,32 +334,39 @@ begsr changeRow; endif; exsr editLoop; if not *in12; - exec sql - update perpdemo.item_vendor - set vendor_part_number = :epartn, - lead_time_days = :eleadtm, - moq = :emoq, - pack_size = :epacksz, - is_preferred = :epref, - is_active = :eactive, - updated_at = current_timestamp, - updated_by = user - where company_code = :compcd and item_number = :eitem - and vendor_code = :evendor; - if sqlcode = -803; - writeMsg('Change failed: another vendor is already preferred for' - + ' this item - clear it first.'); - elseif sqlcode < 0; - writeMsg('Change failed: SQLCODE=' + %char(sqlcode) - + ' SQLSTATE=' + sqlstate); + exsr validateVendorProfile; + if validationFailed; + holdMsg = *on; else; - writeMsg('Updated ' + %trim(eitem) + '/' + %trim(evendor) + '.'); + exec sql + update perpdemo.item_vendor + set vendor_part_number = :epartn, + lead_time_days = :eleadtm, + moq = :emoq, + pack_size = :epacksz, + is_preferred = :epref, + is_active = :eactive, + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd and item_number = :eitem + and vendor_code = :evendor; + if sqlcode = -803; + writeMsg('Change failed: another vendor is already preferred for' + + ' this item - clear it first.'); + elseif sqlcode < 0; + writeMsg('Change failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Updated ' + %trim(eitem) + '/' + %trim(evendor) + '.'); + endif; + holdMsg = *on; endif; endif; endsr; // --------------------------------------------------------------------- begsr deleteRow; + exsr clearMsgs; exec sql delete from perpdemo.item_vendor where company_code = :compcd and item_number = :siitem @@ -359,6 +376,7 @@ begsr deleteRow; else; writeMsg('Deleted ' + %trim(siitem) + '/' + %trim(sivendor) + '.'); endif; + holdMsg = *on; endsr; // --------------------------------------------------------------------- @@ -384,6 +402,21 @@ begsr editLoop; enddo; endsr; +// --------------------------------------------------------------------- +// Required-field validation for the Add/Change panel, done here in RPG +// instead of letting a blank required field surface as a raw FK/NOT-NULL +// violation from the database. +begsr validateVendorProfile; + validationFailed = *off; + if %trim(eitem) = ''; + writeMsg('Item Number is required.'); + validationFailed = *on; + elseif %trim(evendor) = ''; + writeMsg('Vendor Code is required.'); + validationFailed = *on; + endif; +endsr; + // --------------------------------------------------------------------- begsr clearMsgs; msgrrn = 0; diff --git a/perp/qrpglesrc/wrkivpr.sqlrpgle b/perp/qrpglesrc/wrkivpr.sqlrpgle index 9453615d..ff34989f 100644 --- a/perp/qrpglesrc/wrkivpr.sqlrpgle +++ b/perp/qrpglesrc/wrkivpr.sqlrpgle @@ -255,7 +255,16 @@ begsr addPrice; ecurr = 'USD'; eprcsrc = 'MANUAL'; exfmt ipadd; - if *in12 or enewprc <= 0; + if *in12; + leavesr; + endif; + + if enewprc <= 0; + writeMsg('New Price is required.'); + leavesr; + endif; + if %trim(ecurr) = ''; + writeMsg('Currency is required.'); leavesr; endif; diff --git a/perp/qrpglesrc/wrklotr.sqlrpgle b/perp/qrpglesrc/wrklotr.sqlrpgle index 0a77ea6a..0a96a17e 100644 --- a/perp/qrpglesrc/wrklotr.sqlrpgle +++ b/perp/qrpglesrc/wrklotr.sqlrpgle @@ -74,6 +74,7 @@ dcl-s compcd char(3); dcl-s itemOh packed(15:4); dcl-s lotTotal packed(15:4); dcl-s promptItem varchar(25); +dcl-s holdMsg ind; // PERP-84: MM/DD/YY entry validation for ERECV/EEXPD (see editLoop). // parsedRecv/parsedExpd are Date-typed working vars used only to @@ -121,7 +122,17 @@ dow not *in03 and not *in12; leave; endif; - exsr clearMsgs; + // A message queued by an action handler below (addRow, etc.) must + // survive one full loop pass before being cleared, or it never + // reaches the screen -- clearMsgs wipes msgrrn back to 0 on the very + // next pass, before this pass's own exfmt ever shows it. holdMsg + // skips exactly one clearMsgs call right after such a message was + // queued. Same pattern as wrkitmr. + if holdMsg; + holdMsg = *off; + else; + exsr clearMsgs; + endif; if filter = ''; *in30 = *off; @@ -163,6 +174,7 @@ dow not *in03 and not *in12; if *in06; if sfitem = ''; writeMsg('Enter an item number before adding a lot.'); + holdMsg = *on; else; filter = sfitem; exsr addRow; @@ -301,12 +313,14 @@ begsr handleOpt; exsr deleteRow; other; writeMsg('Option ' + selOpt + ' not valid.'); + holdMsg = *on; endsl; endif; endsr; // --------------------------------------------------------------------- begsr addRow; + exsr clearMsgs; emode = 'A'; elot = ''; eqty = 0; @@ -326,11 +340,13 @@ begsr addRow; else; writeMsg('Added lot ' + %trim(elot) + '.'); endif; + holdMsg = *on; endif; endsr; // --------------------------------------------------------------------- begsr changeRow; + exsr clearMsgs; emode = 'C'; elot = slot; eqty = sqty; @@ -352,11 +368,13 @@ begsr changeRow; else; writeMsg('Updated lot ' + %trim(elot) + '.'); endif; + holdMsg = *on; endif; endsr; // --------------------------------------------------------------------- begsr deleteRow; + exsr clearMsgs; exec sql delete from perpdemo.item_lot where company_code = :compcd and item_number = :filter and lot_number = :slot; @@ -365,6 +383,7 @@ begsr deleteRow; else; writeMsg('Deleted lot ' + %trim(slot) + '.'); endif; + holdMsg = *on; endsr; // --------------------------------------------------------------------- @@ -392,6 +411,11 @@ begsr editLoop; exsr clearMsgs; + if %trim(elot) = ''; + writeMsg('Lot Number is required.'); + iter; + endif; + if %trim(erecv) = ''; writeMsg('Received Date is required (MM/DD/YY).'); iter; diff --git a/perp/qrpglesrc/wrkuomr.sqlrpgle b/perp/qrpglesrc/wrkuomr.sqlrpgle index e40f2eca..69051a0e 100644 --- a/perp/qrpglesrc/wrkuomr.sqlrpgle +++ b/perp/qrpglesrc/wrkuomr.sqlrpgle @@ -46,9 +46,21 @@ dcl-s msgrrn int(10); dcl-s msgkey char(4); dcl-s selRrn int(10); dcl-s selOpt char(1); +dcl-s holdMsg ind; +dcl-s validationFailed ind; dow not *in03 and not *in12; - exsr clearMsgs; + // A message queued by an action handler below (addRow, etc.) must + // survive one full loop pass before being cleared, or it never + // reaches the screen -- clearMsgs wipes msgrrn back to 0 on the very + // next pass, before this pass's own exfmt ever shows it. holdMsg + // skips exactly one clearMsgs call right after such a message was + // queued. Same pattern as wrkitmr. + if holdMsg; + holdMsg = *off; + else; + exsr clearMsgs; + endif; exsr loadRows; if numRows = 0; @@ -115,7 +127,8 @@ begsr loadRows; exec sql open c1; if sqlcode < 0; writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); - return; + holdMsg = *on; + leavesr; endif; dow numRows < %elem(rows); @@ -160,33 +173,42 @@ begsr handleOpt; exsr displayRow; other; writeMsg('Option ' + selOpt + ' not valid.'); + holdMsg = *on; endsl; endif; endsr; // --------------------------------------------------------------------- begsr addRow; + exsr clearMsgs; emode = 'A'; ecode = ''; edesc = ''; ecat = ''; eactive = 'Y'; exsr editLoop; - if not *in12 and ecode <> ''; - exec sql - insert into perpdemo.uom (uom_code, description, uom_category, is_active) - values (:ecode, :edesc, :ecat, :eactive); - if sqlcode < 0; - writeMsg('Add failed: SQLCODE=' + %char(sqlcode) - + ' SQLSTATE=' + sqlstate); + if not *in12; + exsr validateUom; + if validationFailed; + holdMsg = *on; else; - writeMsg('Added ' + %trim(ecode) + '.'); + exec sql + insert into perpdemo.uom (uom_code, description, uom_category, is_active) + values (:ecode, :edesc, :ecat, :eactive); + if sqlcode < 0; + writeMsg('Add failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Added ' + %trim(ecode) + '.'); + endif; + holdMsg = *on; endif; endif; endsr; // --------------------------------------------------------------------- begsr changeRow; + exsr clearMsgs; emode = 'C'; ecode = scode; exec sql @@ -196,28 +218,36 @@ begsr changeRow; where uom_code = :ecode; if sqlcode <> 0; writeMsg('Row disappeared before change.'); - return; + holdMsg = *on; + leavesr; endif; exsr editLoop; if not *in12; - exec sql - update perpdemo.uom - set description = :edesc, - uom_category = :ecat, - is_active = :eactive, - updated_at = current_timestamp, - updated_by = user - where uom_code = :ecode; - if sqlcode < 0; - writeMsg('Change failed: SQLCODE=' + %char(sqlcode)); + exsr validateUom; + if validationFailed; + holdMsg = *on; else; - writeMsg('Updated ' + %trim(ecode) + '.'); + exec sql + update perpdemo.uom + set description = :edesc, + uom_category = :ecat, + is_active = :eactive, + updated_at = current_timestamp, + updated_by = user + where uom_code = :ecode; + if sqlcode < 0; + writeMsg('Change failed: SQLCODE=' + %char(sqlcode)); + else; + writeMsg('Updated ' + %trim(ecode) + '.'); + endif; + holdMsg = *on; endif; endif; endsr; // --------------------------------------------------------------------- begsr deleteRow; + exsr clearMsgs; exec sql delete from perpdemo.uom where uom_code = :scode; @@ -226,6 +256,7 @@ begsr deleteRow; else; writeMsg('Deleted ' + %trim(scode) + '.'); endif; + holdMsg = *on; endsr; // --------------------------------------------------------------------- @@ -245,6 +276,21 @@ begsr editLoop; exfmt uoedit; endsr; +// --------------------------------------------------------------------- +// Required-field validation for the Add/Change panel, done here in RPG +// instead of letting a blank required field surface as a raw NOT-NULL +// violation from the database. +begsr validateUom; + validationFailed = *off; + if %trim(ecode) = ''; + writeMsg('UOM Code is required.'); + validationFailed = *on; + elseif %trim(edesc) = ''; + writeMsg('Description is required.'); + validationFailed = *on; + endif; +endsr; + // --------------------------------------------------------------------- begsr clearMsgs; msgrrn = 0; diff --git a/perp/qrpglesrc/wrkusrr.sqlrpgle b/perp/qrpglesrc/wrkusrr.sqlrpgle index 6165930e..03235e58 100644 --- a/perp/qrpglesrc/wrkusrr.sqlrpgle +++ b/perp/qrpglesrc/wrkusrr.sqlrpgle @@ -47,6 +47,7 @@ dcl-s msgkey char(4); dcl-s selRrn int(10); dcl-s selOpt char(1); dcl-s holdMsg ind; +dcl-s validationFailed ind; dow not *in03 and not *in12; // A message queued by an action handler below (2=Change, etc.) must @@ -170,12 +171,14 @@ begsr handleOpt; exsr displayRow; other; writeMsg('Option ' + selOpt + ' not valid.'); + holdMsg = *on; endsl; endif; endsr; // --------------------------------------------------------------------- begsr addRow; + exsr clearMsgs; emode = 'A'; eucode = ''; euname = ''; @@ -183,22 +186,29 @@ begsr addRow; eurole = 'REQUESTER'; euact = 'Y'; exsr editLoop; - if not *in12 and eucode <> ''; - exec sql - insert into perpdemo.perp_user - (user_code, display_name, email_address, role_code, is_active) - values (:eucode, :euname, :euemail, :eurole, :euact); - if sqlcode < 0; - writeMsg('Add failed: SQLCODE=' + %char(sqlcode) - + ' SQLSTATE=' + sqlstate); + if not *in12; + exsr validateUser; + if validationFailed; + holdMsg = *on; else; - writeMsg('Added ' + %trim(eucode) + '.'); + exec sql + insert into perpdemo.perp_user + (user_code, display_name, email_address, role_code, is_active) + values (:eucode, :euname, :euemail, :eurole, :euact); + if sqlcode < 0; + writeMsg('Add failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Added ' + %trim(eucode) + '.'); + endif; + holdMsg = *on; endif; endif; endsr; // --------------------------------------------------------------------- begsr changeRow; + exsr clearMsgs; emode = 'C'; eucode = sucode; exec sql @@ -213,26 +223,33 @@ begsr changeRow; endif; exsr editLoop; if not *in12; - exec sql - update perpdemo.perp_user - set display_name = :euname, - email_address = :euemail, - role_code = :eurole, - is_active = :euact, - updated_at = current_timestamp, - updated_by = user - where user_code = :eucode; - if sqlcode < 0; - writeMsg('Change failed: SQLCODE=' + %char(sqlcode) - + ' SQLSTATE=' + sqlstate); + exsr validateUser; + if validationFailed; + holdMsg = *on; else; - writeMsg('Updated ' + %trim(eucode) + '.'); + exec sql + update perpdemo.perp_user + set display_name = :euname, + email_address = :euemail, + role_code = :eurole, + is_active = :euact, + updated_at = current_timestamp, + updated_by = user + where user_code = :eucode; + if sqlcode < 0; + writeMsg('Change failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Updated ' + %trim(eucode) + '.'); + endif; + holdMsg = *on; endif; endif; endsr; // --------------------------------------------------------------------- begsr deleteRow; + exsr clearMsgs; exec sql delete from perpdemo.perp_user where user_code = :sucode; @@ -241,6 +258,7 @@ begsr deleteRow; else; writeMsg('Deleted ' + %trim(sucode) + '.'); endif; + holdMsg = *on; endsr; // --------------------------------------------------------------------- @@ -260,6 +278,21 @@ begsr editLoop; exfmt uedit; endsr; +// --------------------------------------------------------------------- +// Required-field validation for the Add/Change panel, done here in RPG +// instead of letting a blank required field surface as a raw FK/NOT-NULL +// violation from the database. +begsr validateUser; + validationFailed = *off; + if %trim(eucode) = ''; + writeMsg('User Code is required.'); + validationFailed = *on; + elseif %trim(eurole) = ''; + writeMsg('Role is required.'); + validationFailed = *on; + endif; +endsr; + // --------------------------------------------------------------------- begsr clearMsgs; msgrrn = 0; diff --git a/perp/qrpglesrc/wrkvndr.sqlrpgle b/perp/qrpglesrc/wrkvndr.sqlrpgle index 18b9713b..be05118c 100644 --- a/perp/qrpglesrc/wrkvndr.sqlrpgle +++ b/perp/qrpglesrc/wrkvndr.sqlrpgle @@ -53,6 +53,8 @@ dcl-s selOpt char(1); dcl-s compcd char(3); dcl-s fActOnly char(1); dcl-s fBuyer char(10); +dcl-s holdMsg ind; +dcl-s validationFailed ind; in ldaDS; compcd = ldaDS.compcd; @@ -82,7 +84,17 @@ dow not *in03 and not *in12; leave; endif; - exsr clearMsgs; + // A message queued by an action handler below (addRow, etc.) must + // survive one full loop pass before being cleared, or it never + // reaches the screen -- clearMsgs wipes msgrrn back to 0 on the very + // next pass, before this pass's own exfmt ever shows it. holdMsg + // skips exactly one clearMsgs call right after such a message was + // queued. Same pattern as wrkitmr. + if holdMsg; + holdMsg = *off; + else; + exsr clearMsgs; + endif; exsr loadRows; if numRows = 0; @@ -161,7 +173,8 @@ begsr loadRows; exec sql open v1; if sqlcode < 0; writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); - return; + holdMsg = *on; + leavesr; endif; dow numRows < %elem(rows); @@ -207,12 +220,14 @@ begsr handleOpt; exsr displayRow; other; writeMsg('Option ' + selOpt + ' not valid.'); + holdMsg = *on; endsl; endif; endsr; // --------------------------------------------------------------------- begsr addRow; + exsr clearMsgs; emode = 'A'; evcode = ''; evname = ''; @@ -230,28 +245,35 @@ begsr addRow; etaxid = ''; eactive = 'Y'; exsr editLoop; - if not *in12 and evcode <> ''; - exec sql - insert into perpdemo.vendor - (company_code, vendor_code, vendor_name, address_line1, address_line2, - city_name, state_code, postal_code, country_code, phone_number, - email_address, contact_name, buyer_code, payment_terms_code, tax_id, - is_active) - values (:compcd, :evcode, :evname, :eaddr1, :eaddr2, - :ecity, :estate, :epostcd, :ecntry, :ephone, - :eemail, :ecntct, :ebuyer, :epterms, :etaxid, - :eactive); - if sqlcode < 0; - writeMsg('Add failed: SQLCODE=' + %char(sqlcode) - + ' SQLSTATE=' + sqlstate); + if not *in12; + exsr validateVendor; + if validationFailed; + holdMsg = *on; else; - writeMsg('Added ' + %trim(evcode) + '.'); + exec sql + insert into perpdemo.vendor + (company_code, vendor_code, vendor_name, address_line1, address_line2, + city_name, state_code, postal_code, country_code, phone_number, + email_address, contact_name, buyer_code, payment_terms_code, tax_id, + is_active) + values (:compcd, :evcode, :evname, :eaddr1, :eaddr2, + :ecity, :estate, :epostcd, :ecntry, :ephone, + :eemail, :ecntct, :ebuyer, :epterms, :etaxid, + :eactive); + if sqlcode < 0; + writeMsg('Add failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Added ' + %trim(evcode) + '.'); + endif; + holdMsg = *on; endif; endif; endsr; // --------------------------------------------------------------------- begsr changeRow; + exsr clearMsgs; emode = 'C'; evcode = svcode; exec sql @@ -265,40 +287,48 @@ begsr changeRow; where company_code = :compcd and vendor_code = :evcode; if sqlcode <> 0; writeMsg('Row disappeared before change.'); - return; + holdMsg = *on; + leavesr; endif; exsr editLoop; if not *in12; - exec sql - update perpdemo.vendor - set vendor_name = :evname, - address_line1 = :eaddr1, - address_line2 = :eaddr2, - city_name = :ecity, - state_code = :estate, - postal_code = :epostcd, - country_code = :ecntry, - phone_number = :ephone, - email_address = :eemail, - contact_name = :ecntct, - buyer_code = :ebuyer, - payment_terms_code = :epterms, - tax_id = :etaxid, - is_active = :eactive, - updated_at = current_timestamp, - updated_by = user - where company_code = :compcd and vendor_code = :evcode; - if sqlcode < 0; - writeMsg('Change failed: SQLCODE=' + %char(sqlcode) - + ' SQLSTATE=' + sqlstate); + exsr validateVendor; + if validationFailed; + holdMsg = *on; else; - writeMsg('Updated ' + %trim(evcode) + '.'); + exec sql + update perpdemo.vendor + set vendor_name = :evname, + address_line1 = :eaddr1, + address_line2 = :eaddr2, + city_name = :ecity, + state_code = :estate, + postal_code = :epostcd, + country_code = :ecntry, + phone_number = :ephone, + email_address = :eemail, + contact_name = :ecntct, + buyer_code = :ebuyer, + payment_terms_code = :epterms, + tax_id = :etaxid, + is_active = :eactive, + updated_at = current_timestamp, + updated_by = user + where company_code = :compcd and vendor_code = :evcode; + if sqlcode < 0; + writeMsg('Change failed: SQLCODE=' + %char(sqlcode) + + ' SQLSTATE=' + sqlstate); + else; + writeMsg('Updated ' + %trim(evcode) + '.'); + endif; + holdMsg = *on; endif; endif; endsr; // --------------------------------------------------------------------- begsr deleteRow; + exsr clearMsgs; exec sql delete from perpdemo.vendor where company_code = :compcd and vendor_code = :svcode; @@ -307,6 +337,7 @@ begsr deleteRow; else; writeMsg('Deleted ' + %trim(svcode) + '.'); endif; + holdMsg = *on; endsr; // --------------------------------------------------------------------- @@ -339,6 +370,24 @@ begsr editLoop; exfmt vedit; endsr; +// --------------------------------------------------------------------- +// Required-field validation for the Add/Change panel, done here in RPG +// instead of letting a blank required field surface as a raw FK/NOT-NULL +// violation from the database. +begsr validateVendor; + validationFailed = *off; + if %trim(evcode) = ''; + writeMsg('Vendor Code is required.'); + validationFailed = *on; + elseif %trim(evname) = ''; + writeMsg('Vendor Name is required.'); + validationFailed = *on; + elseif %trim(ebuyer) = ''; + writeMsg('Buyer is required.'); + validationFailed = *on; + endif; +endsr; + // --------------------------------------------------------------------- begsr clearMsgs; msgrrn = 0; diff --git a/perp/tmp/logs/wrkcnvd.file.log b/perp/tmp/logs/wrkcnvd.file.log deleted file mode 100644 index 556e79a2..00000000 --- a/perp/tmp/logs/wrkcnvd.file.log +++ /dev/null @@ -1,205 +0,0 @@ -CPI2126: AUT parameter ignored. -CPI2121: Replaced object WRKCNVD type *FILE was moved to QRPLOBJ. -CPC7301: File WRKCNVD created in library PERPDEMO. - 5770SS1 V7R5M0 220415 Data Description PERPDEMO/WRKCNVD 8/16/26 17:35:52 Page 1 - File name . . . . . . . . . . . . . . . . . . . . . : WRKCNVD - Library name . . . . . . . . . . . . . . . . . . : PERPDEMO - File attribute . . . . . . . . . . . . . . . . . . : Display - Source file containing DDS . . . . . . . . . . . . : QDDSSRC - Library name . . . . . . . . . . . . . . . . . . : PERPDEMO - Source member containing DDS . . . . . . . . . . . : WRKCNVD - Source member last changed . . . . . . . . . . . . : 08/20/26 17:35:51 - Source listing options . . . . . . . . . . . . . . : *SOURCE *LIST *NOSECLVL *NOEVENTF - DDS generation severity level . . . . . . . . . . . : 20 - DDS flagging severity level . . . . . . . . . . . . : 00 - Authority . . . . . . . . . . . . . . . . . . . . . : *LIBCRTAUT - Replace file . . . . . . . . . . . . . . . . . . . : *YES - Text . . . . . . . . . . . . . . . . . . . . . . . : - Compiler . . . . . . . . . . . . . . . . . . . . . : IBM System i5 Data Description Processor - Data Description Source - SEQNBR *...+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8 Date - 1 A DSPSIZ(24 80 *DS3) - 2 A PRINT - 3 A CA03(03 'Exit') - 4 A CA05(05 'Refresh') - 5 A CA06(06 'Add') - 6 A CA12(12 'Cancel') - 7 A R CVSFL SFL - 8 A 51 SFLNXTCHG - 9 A SOPT 1A B 8 2 - 10 A 50 DSPATR(RI) - 11 A 50 DSPATR(PC) - 12 A SFROM 5A O 8 6 - 13 A STO 5A O 8 12 - 14 A SFACT 15Y 6O 8 18EDTCDE(3) - 15 A R CVCTL SFLCTL(CVSFL) - 16 A SFLSIZ(0099) - 17 A SFLPAG(0007) - 18 A OVERLAY - 19 A SFLDSPCTL - 20 A N31 30 SFLDSP - 21 A 31 SFLCLR - 22 A N31 30 SFLEND(*MORE) - 23 A 1 20'Work with Item UOM Conversions' - 24 A DSPATR(HI) - 25 A 2 2'Company:' - 26 A SCOMPDSP 3A O 2 11 - 27 A 2 20'Item Number:' - 28 A SFITEM 25A B 2 33 - 29 A 2 59'(? = prompt)' - 30 A 4 2'Type option, press Enter.' - 31 A 5 4'2=Change 4=Delete' - 32 A 7 2'Opt' - 33 A DSPATR(UL) - 34 A 7 6'From' - 35 A DSPATR(UL) - 36 A 7 12'To' - 37 A DSPATR(UL) - 38 A 7 27'Factor' - 5770SS1 V7R5M0 220415 Data Description PERPDEMO/WRKCNVD 8/16/26 17:35:52 Page 2 - Data Description Source - SEQNBR *...+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8 Date - 39 A DSPATR(UL) - 40 A R CVFOOT - 41 A 23 2'F3=Exit F5=Refresh F6=Add- - 42 A F12=Cancel' - 43 A COLOR(BLU) - 44 A R CVNONE - 45 A OVERLAY - 46 A 10 20'** No conversions for this it- - 47 A em **' - 48 A R CVNOITEM - 49 A OVERLAY - 50 A 10 20'** Enter an item number to be- - 51 A gin **' - 52 A R CVEDIT - 53 A OVERLAY - 54 A 1 25'Edit Item UOM Conversion' - 55 A DSPATR(HI) - 56 A 2 2'Mode:' - 57 A EMODE 1A O 2 8 - 58 A 3 2'From UOM:' - 59 A EFROM 5A B 3 13 - 60 A 4 2'To UOM:' - 61 A ETO 5A B 4 13 - 62 A 5 2'Factor:' - 63 A EFACT 15Y 6B 5 13EDTCDE(3) - 64 A 6 2'Active:' - 65 A EACTIVE 1A B 6 13 - 66 A 23 2'Enter=Save F12=Cancel' - 67 A COLOR(BLU) - 68 A R CVMSGSFL SFL - 69 A SFLMSGRCD(24) - 70 A SMSGKEY SFLMSGKEY - 71 A SPGMQ SFLPGMQ(10) - 72 A R CVMSGCTL SFLCTL(CVMSGSFL) - 73 A OVERLAY - 74 A N41 40 SFLDSP - 75 A 41 SFLCLR - 76 A N41 40 SFLEND - 77 A SFLSIZ(0002) - 78 A SFLPAG(0001) - * * * * * E N D O F S O U R C E * * * * * - 5770SS1 V7R5M0 220415 Data Description PERPDEMO/WRKCNVD 8/16/26 17:35:52 Page 3 - Expanded Source - Field Buffer position - SEQNBR *...+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8 length Out In - 1 DSPSIZ(24 80 *DS3) PRINT + - 3 CA03(03 'Exit') CA05(05 'Refresh') + - 5 CA06(06 'Add') CA12(12 'Cancel') - * Option indicator output buffer positions: - * *IN50 0002 *IN51 0001 - * Response indicator input buffer positions: - * *IN03 0001 *IN05 0002 *IN06 0003 *IN12 0004 - 7 R CVSFL SFL - 8 51 SFLNXTCHG - 9 SOPT 1A B 8 2 1 3 5 - 10 50 DSPATR(RI) - 11 50 DSPATR(PC) - 12 SFROM 5A O 8 6 5 4 6 - 13 STO 5A O 8 12 5 9 11 - 14 SFACT 15Y 6O 8 18EDTCDE(3) 15 14 16 - * Option indicator output buffer positions: - * *IN30 0002 *IN31 0001 - * Response indicator input buffer positions: - * *IN03 0001 *IN05 0002 *IN06 0003 *IN12 0004 - 15 R CVCTL - *DS3 SFLSIZ(0099) SFLPAG(007) - 15 SFLCTL(CVSFL) OVERLAY SFLDSPCTL - 20 N31 30 SFLDSP - 21 31 SFLCLR - 22 N31 30 SFLEND(*MORE) - 23 1 20'Work with Item UOM Conversions' + 30 - 24 DSPATR(HI) - 25 2 2'Company:' 8 - 26 SCOMPDSP 3A O 2 11 3 3 - 27 2 20'Item Number:' 12 - 28 SFITEM 25A B 2 33 25 6 5 - 29 2 59'(? = prompt)' 12 - 30 4 2'Type option, press Enter.' 25 - 31 5 4'2=Change 4=Delete' 19 - 32 7 2'Opt' DSPATR(UL) 3 - 34 7 6'From' DSPATR(UL) 4 - 36 7 12'To' DSPATR(UL) 2 - 38 7 27'Factor' DSPATR(UL) 6 - * Response indicator input buffer positions: - * *IN03 0001 *IN05 0002 *IN06 0003 *IN12 0004 - 40 R CVFOOT - 41 23 2'F3=Exit F5=Refresh F6=Add F1- 42 - 41 2=Cancel' COLOR(BLU) - * Response indicator input buffer positions: - * *IN03 0001 *IN05 0002 *IN06 0003 *IN12 0004 - 44 R CVNONE OVERLAY - 46 10 20'** No conversions for this item **- 34 - 46 ' - * Response indicator input buffer positions: - * *IN03 0001 *IN05 0002 *IN06 0003 *IN12 0004 - 48 R CVNOITEM OVERLAY - 50 10 20'** Enter an item number to begin *- 35 - 50 *' - 5770SS1 V7R5M0 220415 Data Description PERPDEMO/WRKCNVD 8/16/26 17:35:52 Page 4 - Expanded Source - Field Buffer position - SEQNBR *...+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8 length Out In - * Response indicator input buffer positions: - * *IN03 0001 *IN05 0002 *IN06 0003 *IN12 0004 - 52 R CVEDIT OVERLAY - 54 1 25'Edit Item UOM Conversion' + 24 - 55 DSPATR(HI) - 56 2 2'Mode:' 5 - 57 EMODE 1A O 2 8 1 1 - 58 3 2'From UOM:' 9 - 59 EFROM 5A B 3 13 5 2 5 - 60 4 2'To UOM:' 7 - 61 ETO 5A B 4 13 5 7 10 - 62 5 2'Factor:' 7 - 63 EFACT 15Y 6B 5 13EDTCDE(3) 15 12 15 - 64 6 2'Active:' 7 - 65 EACTIVE 1A B 6 13 1 27 30 - 66 23 2'Enter=Save F12=Cancel' + 23 - 67 COLOR(BLU) - * Response indicator input buffer positions: - * *IN03 0001 *IN05 0002 *IN06 0003 *IN12 0004 - 68 R CVMSGSFL - *DS3 SFLMSGRCD(24) - 68 SFL - 70 SMSGKEY SFLMSGKEY 4 1 5 - 71 SPGMQ SFLPGMQ(10) 10 5 9 - * Option indicator output buffer positions: - * *IN40 0002 *IN41 0001 - * Response indicator input buffer positions: - * *IN03 0001 *IN05 0002 *IN06 0003 *IN12 0004 - 72 R CVMSGCTL - *DS3 SFLSIZ(0002) SFLPAG(001) - 72 SFLCTL(CVMSGSFL) OVERLAY - 74 N41 40 SFLDSP - 75 41 SFLCLR - 76 N41 40 SFLEND - * * * * * E N D O F E X P A N D E D S O U R C E * * * * * - 5770SS1 V7R5M0 220415 Data Description PERPDEMO/WRKCNVD 8/16/26 17:35:52 Page 5 - Message Summary - Total Informational Warning Error Severe - (0-9) (10-19) (20-29) (30-99) - 0 0 0 0 0 - * CPC7301 00 Message . . . . : File WRKCNVD created in library PERPDEMO. - * * * * * E N D O F C O M P I L A T I O N * * * * * diff --git a/perp/tmp/logs/wrklotr.pgm.log b/perp/tmp/logs/wrklotr.pgm.log new file mode 100644 index 00000000..247d4cf0 --- /dev/null +++ b/perp/tmp/logs/wrklotr.pgm.log @@ -0,0 +1,2799 @@ +CPC7301: File QSQLPRE created in library QTEMP. +CPC7305: Member WRKLOTR added to file QSQLPRE in QTEMP. +CPC3201: Member WRKLOTR file QSQLPRE in QTEMP changed. +RNS9307: Diagnostic check of source is complete. Highest severity is 00. +CPC0904: Data area RETURNCODE created in library QTEMP. +CPC7301: File QSQLTEMP1 created in library QTEMP. +CPC7305: Member WRKLOTR added to file QSQLTEMP1 in QTEMP. +CPI2119: AUT and USRPRF parameter values were ignored. +CPI2121: Replaced object WRKLOTR type *PGM was moved to QRPLOBJ. +RNS9304: Program WRKLOTR placed in library PERPDEMO. 00 highest severity. Created on 08/26/26 at 16:51:51. + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 1 + Command . . . . . . . . . . . . : CRTBNDRPG + Issued by . . . . . . . . . . : AIDEMO + Program . . . . . . . . . . . . : WRKLOTR + Library . . . . . . . . . . . : PERPDEMO + Text 'description' . . . . . . . : *SRCMBRTXT + Source stream file . . . . . . : qrpglesrc/wrklotr.sqlrpgle + CCSID . . . . . . . . . . . . : 1208 + Target CCSID . . . . . . . . . . : *JOB (37) + Text 'description' . . . . . . . : + Last Change . . . . . . . . . . : 08/26/26 16:51:48 + Generation severity level . . . : 10 + Default activation group . . . . : *YES + Compiler options . . . . . . . . : *XREF *GEN *NOSECLVL *SHOWCPY + *EXPDDS *EXT *NOSHOWSKP *NOSRCSTMT + *DEBUGIO *UNREF *NOEVENTF + Debugging views . . . . . . . . : *ALL + Debug encryption key . . . . . . : *NONE + Output . . . . . . . . . . . . . : *PRINT + Optimization level . . . . . . . : *NONE + Source listing indentation . . . : *NONE + Type conversion options . . . . : *NONE + Sort sequence . . . . . . . . . : *JOB + Language identifier . . . . . . : *JOB + Replace program . . . . . . . . : *YES + User profile . . . . . . . . . . : *USER + Authority . . . . . . . . . . . : *LIBCRTAUT + Truncate numeric . . . . . . . . : *YES + Fix numeric . . . . . . . . . . : *NONE + Target release . . . . . . . . . : V7R4M0 + Allow null values . . . . . . . : *NO + Define condition names . . . . . : *NONE + Enable performance collection . : *PEP + Profiling data . . . . . . . . . : *NOCOL + Licensed Internal Code options . : + Generate program interface . . . : *NO + Include directory . . . . . . . : . + Preprocessor options . . . . . . : *NORMVCOMMENT *EXPINCLUDE *NOSEQSRC + Output source file . . . . . . . : QSQLPRE + Library . . . . . . . . . . . : QTEMP + Output source member . . . . . . : WRKLOTR + MINIMUM OUTPUT LINE LENGTH . . . : 100 + Require prototype for export . . : *NO + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 2 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + S o u r c e L i s t i n g + 1 **free 000001 + 2 000002 + 3 // --------------------------------------------------------------------- 000003 + 4 // Program: wrklotr (Work with Item Lots) 000004 + 5 // Purpose: DSPF-based CRUD for item_lot, scoped by the company selected 000005 + 6 // via perpselr (*LDA positions 1-3) and an item number entered 000006 + 7 // on screen (same scoping idiom as wrkcnvr). Shows item.on_hand 000007 + 8 // alongside SUM(item_lot.qty_on_hand) and flags a discrepancy 000008 + 9 // -- the entry point for the reconciliation demo (Option C: 000009 + 10 // balances denormalized on both item and item_lot by design). 000010 + 11 // Callable standalone or pre-scoped by passing company/item 000011 + 12 // (mirrors wrkcnvr's PERP-23 integration). 000012 + 13 // Epic: PERP-3 (PERP-24) 000013 + 14 // --------------------------------------------------------------------- 000014 + 15 000015 + 16 // PERP-84: datfmt(*iso) is required now that this program declares 000016 + 17 // Date-typed variables (parsedRecv/parsedExpd below) to validate the 000017 + 18 // MM/DD/YY Received/Expiry Date entry fields. Without this override the 000018 + 19 // job's *MDY (1940-2039) DATFMT becomes the Date variables' storage 000019 + 20 // format, per perp/AGENTS.md's RNQ0114 gotcha. 000020 + 21 ctl-opt dftactgrp(*no) actgrp(*new) datfmt(*iso); 000021 + 22 000022 + 23 dcl-pi *n; 000023 + 24 pCompcd char(3) const options(*nopass); 000024 + 25 pItem varchar(25) const options(*nopass); 000025 + 26 end-pi; 000026 + 27 000027 + 28 dcl-f wrklotd workstn sfile(ltsfl:rrn) sfile(ltmsgsfl:msgrrn); 000028 + 29 000029 + 30 dcl-ds ldaDS dtaara(*lda) len(1024) qualified; 000030 + 31 compcd char(3) pos(1); 000031 + 32 end-ds; 000032 + 33 000033 + 34 dcl-pr QMHSNDPM extpgm; 000034 + 35 msgId char(7) const; 000035 + 36 msgF char(20) const; 000036 + 37 msgData char(256) const; 000037 + 38 msgDataLen int(10) const; 000038 + 39 msgType char(10) const; 000039 + 40 stackEntry char(10) const; 000040 + 41 stackCntr int(10) const; 000041 + 42 msgKey char(4); 000042 + 43 errorCode char(8) const; 000043 + 44 end-pr; 000044 + 45 000045 + 46 // Standard, reusable Item Number prompt (PERP-51/PERP-56). Same dynamic 000046 + 47 // CALL idiom as wrkitmr's callWrkcnvr/callWrklotr. 000047 + 48 dcl-pr callItmprmt extpgm('ITMPRMT'); 000048 + 49 pCompcd char(3) const; 000049 + 50 pItem varchar(25); 000050 + 51 end-pr; 000051 + 52 000052 + 53 dcl-ds statusDS psds qualified; 000053 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 3 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 54 programName char(10) pos(334); 000054 + 55 end-ds; 000055 + 56 000056 + 57 dcl-ds ltRow qualified; 000057 + 58 lot varchar(20); 000058 + 59 qty packed(15:4); 000059 + 60 recv varchar(10); 000060 + 61 expd varchar(10); 000061 + 62 end-ds; 000062 + 63 000063 + 64 dcl-ds rows likeds(ltRow) dim(500); 000064 + 65 dcl-s numRows int(10); 000065 + 66 dcl-s i int(10); 000066 + 67 dcl-s rrn int(10); 000067 + 68 dcl-s msgrrn int(10); 000068 + 69 dcl-s msgkey char(4); 000069 + 70 dcl-s selRrn int(10); 000070 + 71 dcl-s selOpt char(1); 000071 + 72 dcl-s filter varchar(25); 000072 + 73 dcl-s compcd char(3); 000073 + 74 dcl-s itemOh packed(15:4); 000074 + 75 dcl-s lotTotal packed(15:4); 000075 + 76 dcl-s promptItem varchar(25); 000076 + 77 dcl-s holdMsg ind; 000077 + 78 000078 + 79 // PERP-84: MM/DD/YY entry validation for ERECV/EEXPD (see editLoop). 000079 + 80 // parsedRecv/parsedExpd are Date-typed working vars used only to 000080 + 81 // validate/reformat the typed text -- they are never bound directly to 000081 + 82 // an SQL host variable (erecv/eexpd stay char(10) for that), so the 000082 + 83 // SQL-precompiler-intermediate-host-variable *MDY cap documented in 000083 + 84 // perp/AGENTS.md #13 does not come into play here. 000084 + 85 dcl-s parsedRecv date; 000085 + 86 dcl-s parsedExpd date; 000086 + 87 dcl-s validRecv ind; 000087 + 88 dcl-s validExpd ind; 000088 + 89 000089 + 90 in ldaDS; 000090 + 91 compcd = ldaDS.compcd; 000091 + 92 000092 + 93 if %parms >= 1 and pCompcd <> ''; 000093 + 94 compcd = pCompcd; 000094 + 95 endif; 000095 + 96 scompdsp = compcd; 000096 + 97 filter = ''; 000097 + 98 if %parms >= 2 and pItem <> ''; 000098 + 99 filter = pItem; 000099 + 100 sfitem = pItem; 000100 + 101 else; 000101 + 102 sfitem = ''; 000102 + 103 endif; 000103 + 104 000104 + 105 if compcd = ''; 000105 + 106 exsr clearMsgs; 000106 + 107 writeMsg('No company selected - run Select Company (PERPSELR) first.'); 000107 + 108 endif; 000108 + 109 000109 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 4 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 110 dow not *in03 and not *in12; 000110 + 111 if compcd = ''; 000111 + 112 *in30 = *off; 000112 + 113 write ltnoitem; 000113 + 114 write ltfoot; 000114 + 115 if msgrrn > 0; 000115 + 116 *in40 = *on; 000116 + 117 write ltmsgctl; 000117 + 118 else; 000118 + 119 *in40 = *off; 000119 + 120 endif; 000120 + 121 exfmt ltctl; 000121 + 122 leave; 000122 + 123 endif; 000123 + 124 000124 + 125 // A message queued by an action handler below (addRow, etc.) must 000125 + 126 // survive one full loop pass before being cleared, or it never 000126 + 127 // reaches the screen -- clearMsgs wipes msgrrn back to 0 on the very 000127 + 128 // next pass, before this pass's own exfmt ever shows it. holdMsg 000128 + 129 // skips exactly one clearMsgs call right after such a message was 000129 + 130 // queued. Same pattern as wrkitmr. 000130 + 131 if holdMsg; 000131 + 132 holdMsg = *off; 000132 + 133 else; 000133 + 134 exsr clearMsgs; 000134 + 135 endif; 000135 + 136 000136 + 137 if filter = ''; 000137 + 138 *in30 = *off; 000138 + 139 *in60 = *off; 000139 + 140 numRows = 0; 000140 + 141 sioh = 0; 000141 + 142 slottot = 0; 000142 + 143 write ltnoitem; 000143 + 144 else; 000144 + 145 exsr loadBalances; 000145 + 146 exsr loadRows; 000146 + 147 if numRows = 0; 000147 + 148 *in30 = *off; 000148 + 149 write ltnone; 000149 + 150 else; 000150 + 151 exsr fillSubfile; 000151 + 152 *in30 = *on; 000152 + 153 endif; 000153 + 154 endif; 000154 + 155 000155 + 156 write ltfoot; 000156 + 157 if msgrrn > 0; 000157 + 158 *in40 = *on; 000158 + 159 write ltmsgctl; 000159 + 160 else; 000160 + 161 *in40 = *off; 000161 + 162 endif; 000162 + 163 exfmt ltctl; 000163 + 164 000164 + 165 if *in03 or *in12; 000165 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 5 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 166 leave; 000166 + 167 endif; 000167 + 168 000168 + 169 if *in05; 000169 + 170 filter = sfitem; 000170 + 171 iter; 000171 + 172 endif; 000172 + 173 000173 + 174 if *in06; 000174 + 175 if sfitem = ''; 000175 + 176 writeMsg('Enter an item number before adding a lot.'); 000176 + 177 holdMsg = *on; 000177 + 178 else; 000178 + 179 filter = sfitem; 000179 + 180 exsr addRow; 000180 + 181 endif; 000181 + 182 iter; 000182 + 183 endif; 000183 + 184 000184 + 185 // Item Number prompt (PERP-60): '?' + Enter invokes the standard 000185 + 186 // reusable Item Number lookup (PERP-56) and returns the selection. 000186 + 187 if %trim(sfitem) = '?'; 000187 + 188 promptItem = sfitem; 000188 + 189 callItmprmt(compcd : promptItem); 000189 + 190 sfitem = promptItem; 000190 + 191 filter = promptItem; 000191 + 192 iter; 000192 + 193 endif; 000193 + 194 000194 + 195 // Refresh scope from screen entry 000195 + 196 if sfitem <> filter; 000196 + 197 filter = sfitem; 000197 + 198 iter; 000198 + 199 endif; 000199 + 200 000200 + 201 // Process subfile options. Guard on numRows: READC against a subfile 000201 + 202 // that was never written to this cycle (0 rows loaded) raises a 000202 + 203 // "Session or device error" (CPF5006-class) runtime error instead of 000203 + 204 // just returning *EOF. 000204 + 205 if numRows > 0; 000205 + 206 selRrn = 0; 000206 + 207 selOpt = ' '; 000207 + 208 readc ltsfl; 000208 + 209 dow not %eof(wrklotd); 000209 + 210 if sopt <> ''; 000210 + 211 selRrn = rrn; 000211 + 212 selOpt = sopt; 000212 + 213 exsr handleOpt; 000213 + 214 selRrn = 0; 000214 + 215 endif; 000215 + 216 readc ltsfl; 000216 + 217 enddo; 000217 + 218 endif; 000218 + 219 000219 + 220 enddo; 000220 + 221 000221 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 6 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 222 *inlr = *on; 000222 + 223 return; 000223 + 224 000224 + 225 // --------------------------------------------------------------------- 000225 + 226 begsr loadBalances; 000226 + 227 exec sql 000227 + 228 select qty_on_hand into :itemOh 000228 + 229 from perpdemo.item 000229 + 230 where company_code = :compcd and item_number = :filter; 000230 + 231 if sqlcode <> 0; 000231 + 232 itemOh = 0; 000232 + 233 endif; 000233 + 234 exec sql 000234 + 235 select coalesce(sum(qty_on_hand), 0) into :lotTotal 000235 + 236 from perpdemo.item_lot 000236 + 237 where company_code = :compcd and item_number = :filter; 000237 + 238 sioh = itemOh; 000238 + 239 slottot = lotTotal; 000239 + 240 if itemOh <> lotTotal; 000240 + 241 *in60 = *on; 000241 + 242 else; 000242 + 243 *in60 = *off; 000243 + 244 endif; 000244 + 245 endsr; 000245 + 246 000246 + 247 // --------------------------------------------------------------------- 000247 + 248 begsr loadRows; 000248 + 249 numRows = 0; 000249 + 250 // PERP-84: display as MM/DD/YY. received_date/expiry_date are stored 000250 + 251 // as native DATE columns but rendered here as plain strings (SRECV/ 000251 + 252 // SEXPD carry no DATFMT keyword), so the format has to be built by 000252 + 253 // hand from the ISO string -- DB2 for i's CHAR(date,fmt) built-in 000253 + 254 // formats (ISO/USA/EUR/JIS) all use a 4-digit year, none produce a 000254 + 255 // 2-digit year directly. Same technique as wrkivpr.sqlrpgle (PERP-83). 000255 + 256 exec sql declare c1 cursor for 000256 + 257 select lot_number, qty_on_hand, 000257 + 258 substr(char(received_date, iso), 6, 2) || '/' 000258 + 259 || substr(char(received_date, iso), 9, 2) || '/' 000259 + 260 || substr(char(received_date, iso), 3, 2), 000260 + 261 case when expiry_date is null then '' 000261 + 262 else substr(char(expiry_date, iso), 6, 2) || '/' 000262 + 263 || substr(char(expiry_date, iso), 9, 2) || '/' 000263 + 264 || substr(char(expiry_date, iso), 3, 2) 000264 + 265 end 000265 + 266 from perpdemo.item_lot 000266 + 267 where company_code = :compcd and item_number = :filter 000267 + 268 order by lot_number; 000268 + 269 exec sql open c1; 000269 + 270 if sqlcode < 0; 000270 + 271 writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); 000271 + 272 leavesr; 000272 + 273 endif; 000273 + 274 000274 + 275 dow numRows < %elem(rows); 000275 + 276 exec sql fetch c1 into :ltRow; 000276 + 277 if sqlcode = 100 or sqlcode < 0; 000277 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 7 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 278 leave; 000278 + 279 endif; 000279 + 280 numRows += 1; 000280 + 281 rows(numRows) = ltRow; 000281 + 282 enddo; 000282 + 283 exec sql close c1; 000283 + 284 endsr; 000284 + 285 000285 + 286 // --------------------------------------------------------------------- 000286 + 287 begsr fillSubfile; 000287 + 288 rrn = 0; 000288 + 289 *in31 = *on; 000289 + 290 write ltctl; 000290 + 291 *in31 = *off; 000291 + 292 for i = 1 to numRows; 000292 + 293 *in50 = *off; 000293 + 294 *in51 = *off; 000294 + 295 sopt = ''; 000295 + 296 slot = rows(i).lot; 000296 + 297 sqty = rows(i).qty; 000297 + 298 srecv = rows(i).recv; 000298 + 299 sexpd = rows(i).expd; 000299 + 300 rrn += 1; 000300 + 301 write ltsfl; 000301 + 302 endfor; 000302 + 303 endsr; 000303 + 304 000304 + 305 // --------------------------------------------------------------------- 000305 + 306 begsr handleOpt; 000306 + 307 chain selRrn ltsfl; 000307 + 308 if %found(wrklotd); 000308 + 309 select; 000309 + 310 when selOpt = '2'; 000310 + 311 exsr changeRow; 000311 + 312 when selOpt = '4'; 000312 + 313 exsr deleteRow; 000313 + 314 other; 000314 + 315 writeMsg('Option ' + selOpt + ' not valid.'); 000315 + 316 holdMsg = *on; 000316 + 317 endsl; 000317 + 318 endif; 000318 + 319 endsr; 000319 + 320 000320 + 321 // --------------------------------------------------------------------- 000321 + 322 begsr addRow; 000322 + 323 exsr clearMsgs; 000323 + 324 emode = 'A'; 000324 + 325 elot = ''; 000325 + 326 eqty = 0; 000326 + 327 erecv = %char(%date():*mdy); 000327 + 328 eexpd = ''; 000328 + 329 eactive = 'Y'; 000329 + 330 exsr editLoop; 000330 + 331 if not *in12 and elot <> ''; 000331 + 332 exec sql 000332 + 333 insert into perpdemo.item_lot 000333 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 8 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 334 (company_code, item_number, lot_number, qty_on_hand, received_date, expiry_date) 000334 + 335 values (:compcd, :filter, :elot, :eqty, date(:erecv), 000335 + 336 case when :eexpd = '' then null else date(:eexpd) end); 000336 + 337 if sqlcode < 0; 000337 + 338 writeMsg('Add failed: SQLCODE=' + %char(sqlcode) 000338 + 339 + ' SQLSTATE=' + sqlstate); 000339 + 340 else; 000340 + 341 writeMsg('Added lot ' + %trim(elot) + '.'); 000341 + 342 endif; 000342 + 343 holdMsg = *on; 000343 + 344 endif; 000344 + 345 endsr; 000345 + 346 000346 + 347 // --------------------------------------------------------------------- 000347 + 348 begsr changeRow; 000348 + 349 exsr clearMsgs; 000349 + 350 emode = 'C'; 000350 + 351 elot = slot; 000351 + 352 eqty = sqty; 000352 + 353 erecv = srecv; 000353 + 354 eexpd = sexpd; 000354 + 355 eactive = 'Y'; 000355 + 356 exsr editLoop; 000356 + 357 if not *in12; 000357 + 358 exec sql 000358 + 359 update perpdemo.item_lot 000359 + 360 set qty_on_hand = :eqty, 000360 + 361 received_date = date(:erecv), 000361 + 362 expiry_date = case when :eexpd = '' then null else date(:eexpd) end, 000362 + 363 updated_at = current_timestamp, 000363 + 364 updated_by = user 000364 + 365 where company_code = :compcd and item_number = :filter and lot_number = :elot; 000365 + 366 if sqlcode < 0; 000366 + 367 writeMsg('Change failed: SQLCODE=' + %char(sqlcode)); 000367 + 368 else; 000368 + 369 writeMsg('Updated lot ' + %trim(elot) + '.'); 000369 + 370 endif; 000370 + 371 holdMsg = *on; 000371 + 372 endif; 000372 + 373 endsr; 000373 + 374 000374 + 375 // --------------------------------------------------------------------- 000375 + 376 begsr deleteRow; 000376 + 377 exsr clearMsgs; 000377 + 378 exec sql 000378 + 379 delete from perpdemo.item_lot 000379 + 380 where company_code = :compcd and item_number = :filter and lot_number = :slot; 000380 + 381 if sqlcode < 0; 000381 + 382 writeMsg('Delete failed: SQLSTATE=' + sqlstate); 000382 + 383 else; 000383 + 384 writeMsg('Deleted lot ' + %trim(slot) + '.'); 000384 + 385 endif; 000385 + 386 holdMsg = *on; 000386 + 387 endsr; 000387 + 388 000388 + 389 // --------------------------------------------------------------------- 000389 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 9 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 390 // PERP-84: erecv/eexpd are typed by the user as MM/DD/YY on LTEDIT. 000390 + 391 // Validate on every Enter; on failure, show the error in the message 000391 + 392 // subfile alongside LTEDIT and let the user retry (never crash into 000392 + 393 // the SQL date(:erecv) cast in addRow/changeRow with unparsed text). 000393 + 394 // On success, erecv/eexpd are normalized to ISO ('yyyy-mm-dd') text so 000394 + 395 // the existing date(:erecv)/date(:eexpd) SQL casts in addRow/changeRow 000395 + 396 // keep working unchanged. 000396 + 397 begsr editLoop; 000397 + 398 exsr clearMsgs; 000398 + 399 dow *on; 000399 + 400 if msgrrn > 0; 000400 + 401 *in40 = *on; 000401 + 402 write ltmsgctl; 000402 + 403 else; 000403 + 404 *in40 = *off; 000404 + 405 endif; 000405 + 406 exfmt ltedit; 000406 + 407 000407 + 408 if *in12; 000408 + 409 leave; 000409 + 410 endif; 000410 + 411 000411 + 412 exsr clearMsgs; 000412 + 413 000413 + 414 if %trim(elot) = ''; 000414 + 415 writeMsg('Lot Number is required.'); 000415 + 416 iter; 000416 + 417 endif; 000417 + 418 000418 + 419 if %trim(erecv) = ''; 000419 + 420 writeMsg('Received Date is required (MM/DD/YY).'); 000420 + 421 iter; 000421 + 422 endif; 000422 + 423 000423 + 424 validRecv = *on; 000424 + 425 monitor; 000425 + 426 parsedRecv = %date(%trim(erecv):*mdy); 000426 + 427 on-error; 000427 + 428 validRecv = *off; 000428 + 429 endmon; 000429 + 430 if not validRecv; 000430 + 431 writeMsg('Invalid Received Date - enter as MM/DD/YY.'); 000431 + 432 iter; 000432 + 433 endif; 000433 + 434 000434 + 435 validExpd = *on; 000435 + 436 if %trim(eexpd) <> ''; 000436 + 437 monitor; 000437 + 438 parsedExpd = %date(%trim(eexpd):*mdy); 000438 + 439 on-error; 000439 + 440 validExpd = *off; 000440 + 441 endmon; 000441 + 442 endif; 000442 + 443 if not validExpd; 000443 + 444 writeMsg('Invalid Expiry Date - enter as MM/DD/YY, or blank for none.'); 000444 + 445 iter; 000445 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 10 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 446 endif; 000446 + 447 000447 + 448 erecv = %char(parsedRecv:*iso); 000448 + 449 if %trim(eexpd) <> ''; 000449 + 450 eexpd = %char(parsedExpd:*iso); 000450 + 451 endif; 000451 + 452 000452 + 453 leave; 000453 + 454 enddo; 000454 + 455 endsr; 000455 + 456 000456 + 457 // --------------------------------------------------------------------- 000457 + 458 begsr clearMsgs; 000458 + 459 msgrrn = 0; 000459 + 460 *in41 = *on; 000460 + 461 write ltmsgctl; 000461 + 462 *in41 = *off; 000462 + 463 endsr; 000463 + 464 000464 + 465 // --------------------------------------------------------------------- 000465 + 466 dcl-proc writeMsg; 000466 + 467 dcl-pi *n; 000467 + 468 text varchar(256) const; 000468 + 469 end-pi; 000469 + 470 dcl-s data char(256); 000470 + 471 data = text; 000471 + 472 QMHSNDPM( 000472 + 473 'CPF9897' : 000473 + 474 'QCPFMSG QSYS ' : 000474 + 475 data : 000475 + 476 %len(text) : 000476 + 477 '*INFO ' : 000477 + 478 '* ' : 000478 + 479 1 : 000479 + 480 smsgkey : 000480 + 481 x'0000000000000000'); 000481 + 482 msgrrn += 1; 000482 + 483 spgmq = statusDS.programName; 000483 + 484 write ltmsgsfl; 000484 + 485 end-proc; 000485 + * * * * * E N D O F S O U R C E * * * * * + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 11 + Line <---------------------- Data Records --------------------------------------------------------------> Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Date Id Number + C o m p i l e T i m e D a t a + * * * * * E N D O F C O M P I L E T I M E D A T A * * * * * + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 12 + M e s s a g e S u m m a r y + Msg id Sv Number Message text + * * * * * E N D O F M E S S A G E S U M M A R Y * * * * * + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 13 + F i n a l S u m m a r y + Message Totals: + Information (00) . . . . . . . : 0 + Warning (10) . . . . . . . : 0 + Error (20) . . . . . . . : 0 + Severe Error (30+) . . . . . . : 0 + --------------------------------- ------- + Total . . . . . . . . . . . . . : 0 + Source Totals: + Records . . . . . . . . . . . . : 485 + Specifications . . . . . . . . : 376 + Data records . . . . . . . . . : 0 + Comments . . . . . . . . . . . : 106 + * * * * * E N D O F F I N A L S U M M A R Y * * * * * + Diagnostic check of source is complete. Highest severity is 00. + * * * * * E N D O F C O M P I L A T I O N * * * * * + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object WRKLOTR 08/26/26 16:51:50 Page 1 + Source type...............RPG + Object name...............PERPDEMO/WRKLOTR + Source file...............QTEMP/QSQLPRE + Member....................*OBJ + To source file............QTEMP/QSQLTEMP1 + Options...................*XREF + RPG preprocessor options..*LVL2 + Listing option............*PRINT + Target release............V7R4M0 + INCLUDE file..............*LIBL/QRPGLESRC + Commit....................*CHG + Allow copy of data........*OPTIMIZE + Close SQL cursor..........*ENDACTGRP + Allow blocking............*ALLREAD + Delay PREPARE.............*NO + Concurrent access + resolution..............*DFT + Generation level..........10 + Printer file..............*LIBL/QSYSPRT + Date format...............*JOB + Date separator............*JOB + Time format...............*HMS + Time separator ...........*JOB + Replace...................*YES + Relational database.......*LOCAL + User .....................*CURRENT + RDB connect method........*DUW + Default collection........*NONE + Dynamic default + collection..............*NO + Package name..............*OBJLIB/*OBJ + Path......................*NAMING + SQL rules.................*DB2 + Created object type.......*PGM + Debugging view............*SOURCE + Debugging encryption key..*NONE + User profile .............*NAMING + Dynamic user profile......*USER + Sort sequence.............*JOB + Language ID...............*JOB + IBM SQL flagging..........*NOFLAG + ANS flagging..............*NONE + Text......................*SRCMBRTXT + Source file CCSID.........37 + Conversion CCSID..........1208 + Job CCSID.................37 + Decimal result options: + Maximum precision.......31 + Maximum scale...........31 + Minimum divide scale....0 + DECFLOAT rounding mode....*HALFEVEN + Compiler options..........incdir('.') tgtccsid(*job) output(*print) + Source member changed on 08/26/26 16:51:50 + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object WRKLOTR 08/26/26 16:51:50 Page 2 + Record *...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 SEQNBR Last change + 1 **free 000001 08/26/26 + 2 000002 08/26/26 + 3 // --------------------------------------------------------------------- 000003 08/26/26 + 4 // Program: wrklotr (Work with Item Lots) 000004 08/26/26 + 5 // Purpose: DSPF-based CRUD for item_lot, scoped by the company selected 000005 08/26/26 + 6 // via perpselr (*LDA positions 1-3) and an item number entered 000006 08/26/26 + 7 // on screen (same scoping idiom as wrkcnvr). Shows item.on_hand 000007 08/26/26 + 8 // alongside SUM(item_lot.qty_on_hand) and flags a discrepancy 000008 08/26/26 + 9 // -- the entry point for the reconciliation demo (Option C: 000009 08/26/26 + 10 // balances denormalized on both item and item_lot by design). 000010 08/26/26 + 11 // Callable standalone or pre-scoped by passing company/item 000011 08/26/26 + 12 // (mirrors wrkcnvr's PERP-23 integration). 000012 08/26/26 + 13 // Epic: PERP-3 (PERP-24) 000013 08/26/26 + 14 // --------------------------------------------------------------------- 000014 08/26/26 + 15 000015 08/26/26 + 16 // PERP-84: datfmt(*iso) is required now that this program declares 000016 08/26/26 + 17 // Date-typed variables (parsedRecv/parsedExpd below) to validate the 000017 08/26/26 + 18 // MM/DD/YY Received/Expiry Date entry fields. Without this override the 000018 08/26/26 + 19 // job's *MDY (1940-2039) DATFMT becomes the Date variables' storage 000019 08/26/26 + 20 // format, per perp/AGENTS.md's RNQ0114 gotcha. 000020 08/26/26 + 21 ctl-opt dftactgrp(*no) actgrp(*new) datfmt(*iso); 000021 08/26/26 + 22 000022 08/26/26 + 23 dcl-pi *n; 000023 08/26/26 + 24 pCompcd char(3) const options(*nopass); 000024 08/26/26 + 25 pItem varchar(25) const options(*nopass); 000025 08/26/26 + 26 end-pi; 000026 08/26/26 + 27 000027 08/26/26 + 28 dcl-f wrklotd workstn sfile(ltsfl:rrn) sfile(ltmsgsfl:msgrrn); 000028 08/26/26 + 29 000029 08/26/26 + 30 dcl-ds ldaDS dtaara(*lda) len(1024) qualified; 000030 08/26/26 + 31 compcd char(3) pos(1); 000031 08/26/26 + 32 end-ds; 000032 08/26/26 + 33 000033 08/26/26 + 34 dcl-pr QMHSNDPM extpgm; 000034 08/26/26 + 35 msgId char(7) const; 000035 08/26/26 + 36 msgF char(20) const; 000036 08/26/26 + 37 msgData char(256) const; 000037 08/26/26 + 38 msgDataLen int(10) const; 000038 08/26/26 + 39 msgType char(10) const; 000039 08/26/26 + 40 stackEntry char(10) const; 000040 08/26/26 + 41 stackCntr int(10) const; 000041 08/26/26 + 42 msgKey char(4); 000042 08/26/26 + 43 errorCode char(8) const; 000043 08/26/26 + 44 end-pr; 000044 08/26/26 + 45 000045 08/26/26 + 46 // Standard, reusable Item Number prompt (PERP-51/PERP-56). Same dynamic 000046 08/26/26 + 47 // CALL idiom as wrkitmr's callWrkcnvr/callWrklotr. 000047 08/26/26 + 48 dcl-pr callItmprmt extpgm('ITMPRMT'); 000048 08/26/26 + 49 pCompcd char(3) const; 000049 08/26/26 + 50 pItem varchar(25); 000050 08/26/26 + 51 end-pr; 000051 08/26/26 + 52 000052 08/26/26 + 53 dcl-ds statusDS psds qualified; 000053 08/26/26 + 54 programName char(10) pos(334); 000054 08/26/26 + 55 end-ds; 000055 08/26/26 + 56 000056 08/26/26 + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object WRKLOTR 08/26/26 16:51:50 Page 3 + Record *...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 SEQNBR Last change + 57 dcl-ds ltRow qualified; 000057 08/26/26 + 58 lot varchar(20); 000058 08/26/26 + 59 qty packed(15:4); 000059 08/26/26 + 60 recv varchar(10); 000060 08/26/26 + 61 expd varchar(10); 000061 08/26/26 + 62 end-ds; 000062 08/26/26 + 63 000063 08/26/26 + 64 dcl-ds rows likeds(ltRow) dim(500); 000064 08/26/26 + 65 dcl-s numRows int(10); 000065 08/26/26 + 66 dcl-s i int(10); 000066 08/26/26 + 67 dcl-s rrn int(10); 000067 08/26/26 + 68 dcl-s msgrrn int(10); 000068 08/26/26 + 69 dcl-s msgkey char(4); 000069 08/26/26 + 70 dcl-s selRrn int(10); 000070 08/26/26 + 71 dcl-s selOpt char(1); 000071 08/26/26 + 72 dcl-s filter varchar(25); 000072 08/26/26 + 73 dcl-s compcd char(3); 000073 08/26/26 + 74 dcl-s itemOh packed(15:4); 000074 08/26/26 + 75 dcl-s lotTotal packed(15:4); 000075 08/26/26 + 76 dcl-s promptItem varchar(25); 000076 08/26/26 + 77 dcl-s holdMsg ind; 000077 08/26/26 + 78 000078 08/26/26 + 79 // PERP-84: MM/DD/YY entry validation for ERECV/EEXPD (see editLoop). 000079 08/26/26 + 80 // parsedRecv/parsedExpd are Date-typed working vars used only to 000080 08/26/26 + 81 // validate/reformat the typed text -- they are never bound directly to 000081 08/26/26 + 82 // an SQL host variable (erecv/eexpd stay char(10) for that), so the 000082 08/26/26 + 83 // SQL-precompiler-intermediate-host-variable *MDY cap documented in 000083 08/26/26 + 84 // perp/AGENTS.md #13 does not come into play here. 000084 08/26/26 + 85 dcl-s parsedRecv date; 000085 08/26/26 + 86 dcl-s parsedExpd date; 000086 08/26/26 + 87 dcl-s validRecv ind; 000087 08/26/26 + 88 dcl-s validExpd ind; 000088 08/26/26 + 89 000089 08/26/26 + 90 in ldaDS; 000090 08/26/26 + 91 compcd = ldaDS.compcd; 000091 08/26/26 + 92 000092 08/26/26 + 93 if %parms >= 1 and pCompcd <> ''; 000093 08/26/26 + 94 compcd = pCompcd; 000094 08/26/26 + 95 endif; 000095 08/26/26 + 96 scompdsp = compcd; 000096 08/26/26 + 97 filter = ''; 000097 08/26/26 + 98 if %parms >= 2 and pItem <> ''; 000098 08/26/26 + 99 filter = pItem; 000099 08/26/26 + 100 sfitem = pItem; 000100 08/26/26 + 101 else; 000101 08/26/26 + 102 sfitem = ''; 000102 08/26/26 + 103 endif; 000103 08/26/26 + 104 000104 08/26/26 + 105 if compcd = ''; 000105 08/26/26 + 106 exsr clearMsgs; 000106 08/26/26 + 107 writeMsg('No company selected - run Select Company (PERPSELR) first.'); 000107 08/26/26 + 108 endif; 000108 08/26/26 + 109 000109 08/26/26 + 110 dow not *in03 and not *in12; 000110 08/26/26 + 111 if compcd = ''; 000111 08/26/26 + 112 *in30 = *off; 000112 08/26/26 + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object WRKLOTR 08/26/26 16:51:50 Page 4 + Record *...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 SEQNBR Last change + 113 write ltnoitem; 000113 08/26/26 + 114 write ltfoot; 000114 08/26/26 + 115 if msgrrn > 0; 000115 08/26/26 + 116 *in40 = *on; 000116 08/26/26 + 117 write ltmsgctl; 000117 08/26/26 + 118 else; 000118 08/26/26 + 119 *in40 = *off; 000119 08/26/26 + 120 endif; 000120 08/26/26 + 121 exfmt ltctl; 000121 08/26/26 + 122 leave; 000122 08/26/26 + 123 endif; 000123 08/26/26 + 124 000124 08/26/26 + 125 // A message queued by an action handler below (addRow, etc.) must 000125 08/26/26 + 126 // survive one full loop pass before being cleared, or it never 000126 08/26/26 + 127 // reaches the screen -- clearMsgs wipes msgrrn back to 0 on the very 000127 08/26/26 + 128 // next pass, before this pass's own exfmt ever shows it. holdMsg 000128 08/26/26 + 129 // skips exactly one clearMsgs call right after such a message was 000129 08/26/26 + 130 // queued. Same pattern as wrkitmr. 000130 08/26/26 + 131 if holdMsg; 000131 08/26/26 + 132 holdMsg = *off; 000132 08/26/26 + 133 else; 000133 08/26/26 + 134 exsr clearMsgs; 000134 08/26/26 + 135 endif; 000135 08/26/26 + 136 000136 08/26/26 + 137 if filter = ''; 000137 08/26/26 + 138 *in30 = *off; 000138 08/26/26 + 139 *in60 = *off; 000139 08/26/26 + 140 numRows = 0; 000140 08/26/26 + 141 sioh = 0; 000141 08/26/26 + 142 slottot = 0; 000142 08/26/26 + 143 write ltnoitem; 000143 08/26/26 + 144 else; 000144 08/26/26 + 145 exsr loadBalances; 000145 08/26/26 + 146 exsr loadRows; 000146 08/26/26 + 147 if numRows = 0; 000147 08/26/26 + 148 *in30 = *off; 000148 08/26/26 + 149 write ltnone; 000149 08/26/26 + 150 else; 000150 08/26/26 + 151 exsr fillSubfile; 000151 08/26/26 + 152 *in30 = *on; 000152 08/26/26 + 153 endif; 000153 08/26/26 + 154 endif; 000154 08/26/26 + 155 000155 08/26/26 + 156 write ltfoot; 000156 08/26/26 + 157 if msgrrn > 0; 000157 08/26/26 + 158 *in40 = *on; 000158 08/26/26 + 159 write ltmsgctl; 000159 08/26/26 + 160 else; 000160 08/26/26 + 161 *in40 = *off; 000161 08/26/26 + 162 endif; 000162 08/26/26 + 163 exfmt ltctl; 000163 08/26/26 + 164 000164 08/26/26 + 165 if *in03 or *in12; 000165 08/26/26 + 166 leave; 000166 08/26/26 + 167 endif; 000167 08/26/26 + 168 000168 08/26/26 + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object WRKLOTR 08/26/26 16:51:50 Page 5 + Record *...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 SEQNBR Last change + 169 if *in05; 000169 08/26/26 + 170 filter = sfitem; 000170 08/26/26 + 171 iter; 000171 08/26/26 + 172 endif; 000172 08/26/26 + 173 000173 08/26/26 + 174 if *in06; 000174 08/26/26 + 175 if sfitem = ''; 000175 08/26/26 + 176 writeMsg('Enter an item number before adding a lot.'); 000176 08/26/26 + 177 holdMsg = *on; 000177 08/26/26 + 178 else; 000178 08/26/26 + 179 filter = sfitem; 000179 08/26/26 + 180 exsr addRow; 000180 08/26/26 + 181 endif; 000181 08/26/26 + 182 iter; 000182 08/26/26 + 183 endif; 000183 08/26/26 + 184 000184 08/26/26 + 185 // Item Number prompt (PERP-60): '?' + Enter invokes the standard 000185 08/26/26 + 186 // reusable Item Number lookup (PERP-56) and returns the selection. 000186 08/26/26 + 187 if %trim(sfitem) = '?'; 000187 08/26/26 + 188 promptItem = sfitem; 000188 08/26/26 + 189 callItmprmt(compcd : promptItem); 000189 08/26/26 + 190 sfitem = promptItem; 000190 08/26/26 + 191 filter = promptItem; 000191 08/26/26 + 192 iter; 000192 08/26/26 + 193 endif; 000193 08/26/26 + 194 000194 08/26/26 + 195 // Refresh scope from screen entry 000195 08/26/26 + 196 if sfitem <> filter; 000196 08/26/26 + 197 filter = sfitem; 000197 08/26/26 + 198 iter; 000198 08/26/26 + 199 endif; 000199 08/26/26 + 200 000200 08/26/26 + 201 // Process subfile options. Guard on numRows: READC against a subfile 000201 08/26/26 + 202 // that was never written to this cycle (0 rows loaded) raises a 000202 08/26/26 + 203 // "Session or device error" (CPF5006-class) runtime error instead of 000203 08/26/26 + 204 // just returning *EOF. 000204 08/26/26 + 205 if numRows > 0; 000205 08/26/26 + 206 selRrn = 0; 000206 08/26/26 + 207 selOpt = ' '; 000207 08/26/26 + 208 readc ltsfl; 000208 08/26/26 + 209 dow not %eof(wrklotd); 000209 08/26/26 + 210 if sopt <> ''; 000210 08/26/26 + 211 selRrn = rrn; 000211 08/26/26 + 212 selOpt = sopt; 000212 08/26/26 + 213 exsr handleOpt; 000213 08/26/26 + 214 selRrn = 0; 000214 08/26/26 + 215 endif; 000215 08/26/26 + 216 readc ltsfl; 000216 08/26/26 + 217 enddo; 000217 08/26/26 + 218 endif; 000218 08/26/26 + 219 000219 08/26/26 + 220 enddo; 000220 08/26/26 + 221 000221 08/26/26 + 222 *inlr = *on; 000222 08/26/26 + 223 return; 000223 08/26/26 + 224 000224 08/26/26 + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object WRKLOTR 08/26/26 16:51:50 Page 6 + Record *...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 SEQNBR Last change + 225 // --------------------------------------------------------------------- 000225 08/26/26 + 226 begsr loadBalances; 000226 08/26/26 + 227 exec sql 000227 08/26/26 + 228 select qty_on_hand into :itemOh 000228 08/26/26 + 229 from perpdemo.item 000229 08/26/26 + 230 where company_code = :compcd and item_number = :filter; 000230 08/26/26 + 231 if sqlcode <> 0; 000231 08/26/26 + 232 itemOh = 0; 000232 08/26/26 + 233 endif; 000233 08/26/26 + 234 exec sql 000234 08/26/26 + 235 select coalesce(sum(qty_on_hand), 0) into :lotTotal 000235 08/26/26 + 236 from perpdemo.item_lot 000236 08/26/26 + 237 where company_code = :compcd and item_number = :filter; 000237 08/26/26 + 238 sioh = itemOh; 000238 08/26/26 + 239 slottot = lotTotal; 000239 08/26/26 + 240 if itemOh <> lotTotal; 000240 08/26/26 + 241 *in60 = *on; 000241 08/26/26 + 242 else; 000242 08/26/26 + 243 *in60 = *off; 000243 08/26/26 + 244 endif; 000244 08/26/26 + 245 endsr; 000245 08/26/26 + 246 000246 08/26/26 + 247 // --------------------------------------------------------------------- 000247 08/26/26 + 248 begsr loadRows; 000248 08/26/26 + 249 numRows = 0; 000249 08/26/26 + 250 // PERP-84: display as MM/DD/YY. received_date/expiry_date are stored 000250 08/26/26 + 251 // as native DATE columns but rendered here as plain strings (SRECV/ 000251 08/26/26 + 252 // SEXPD carry no DATFMT keyword), so the format has to be built by 000252 08/26/26 + 253 // hand from the ISO string -- DB2 for i's CHAR(date,fmt) built-in 000253 08/26/26 + 254 // formats (ISO/USA/EUR/JIS) all use a 4-digit year, none produce a 000254 08/26/26 + 255 // 2-digit year directly. Same technique as wrkivpr.sqlrpgle (PERP-83). 000255 08/26/26 + 256 exec sql declare c1 cursor for 000256 08/26/26 + 257 select lot_number, qty_on_hand, 000257 08/26/26 + 258 substr(char(received_date, iso), 6, 2) || '/' 000258 08/26/26 + 259 || substr(char(received_date, iso), 9, 2) || '/' 000259 08/26/26 + 260 || substr(char(received_date, iso), 3, 2), 000260 08/26/26 + 261 case when expiry_date is null then '' 000261 08/26/26 + 262 else substr(char(expiry_date, iso), 6, 2) || '/' 000262 08/26/26 + 263 || substr(char(expiry_date, iso), 9, 2) || '/' 000263 08/26/26 + 264 || substr(char(expiry_date, iso), 3, 2) 000264 08/26/26 + 265 end 000265 08/26/26 + 266 from perpdemo.item_lot 000266 08/26/26 + 267 where company_code = :compcd and item_number = :filter 000267 08/26/26 + 268 order by lot_number; 000268 08/26/26 + 269 exec sql open c1; 000269 08/26/26 + 270 if sqlcode < 0; 000270 08/26/26 + 271 writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); 000271 08/26/26 + 272 leavesr; 000272 08/26/26 + 273 endif; 000273 08/26/26 + 274 000274 08/26/26 + 275 dow numRows < %elem(rows); 000275 08/26/26 + 276 exec sql fetch c1 into :ltRow; 000276 08/26/26 + 277 if sqlcode = 100 or sqlcode < 0; 000277 08/26/26 + 278 leave; 000278 08/26/26 + 279 endif; 000279 08/26/26 + 280 numRows += 1; 000280 08/26/26 + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object WRKLOTR 08/26/26 16:51:50 Page 7 + Record *...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 SEQNBR Last change + 281 rows(numRows) = ltRow; 000281 08/26/26 + 282 enddo; 000282 08/26/26 + 283 exec sql close c1; 000283 08/26/26 + 284 endsr; 000284 08/26/26 + 285 000285 08/26/26 + 286 // --------------------------------------------------------------------- 000286 08/26/26 + 287 begsr fillSubfile; 000287 08/26/26 + 288 rrn = 0; 000288 08/26/26 + 289 *in31 = *on; 000289 08/26/26 + 290 write ltctl; 000290 08/26/26 + 291 *in31 = *off; 000291 08/26/26 + 292 for i = 1 to numRows; 000292 08/26/26 + 293 *in50 = *off; 000293 08/26/26 + 294 *in51 = *off; 000294 08/26/26 + 295 sopt = ''; 000295 08/26/26 + 296 slot = rows(i).lot; 000296 08/26/26 + 297 sqty = rows(i).qty; 000297 08/26/26 + 298 srecv = rows(i).recv; 000298 08/26/26 + 299 sexpd = rows(i).expd; 000299 08/26/26 + 300 rrn += 1; 000300 08/26/26 + 301 write ltsfl; 000301 08/26/26 + 302 endfor; 000302 08/26/26 + 303 endsr; 000303 08/26/26 + 304 000304 08/26/26 + 305 // --------------------------------------------------------------------- 000305 08/26/26 + 306 begsr handleOpt; 000306 08/26/26 + 307 chain selRrn ltsfl; 000307 08/26/26 + 308 if %found(wrklotd); 000308 08/26/26 + 309 select; 000309 08/26/26 + 310 when selOpt = '2'; 000310 08/26/26 + 311 exsr changeRow; 000311 08/26/26 + 312 when selOpt = '4'; 000312 08/26/26 + 313 exsr deleteRow; 000313 08/26/26 + 314 other; 000314 08/26/26 + 315 writeMsg('Option ' + selOpt + ' not valid.'); 000315 08/26/26 + 316 holdMsg = *on; 000316 08/26/26 + 317 endsl; 000317 08/26/26 + 318 endif; 000318 08/26/26 + 319 endsr; 000319 08/26/26 + 320 000320 08/26/26 + 321 // --------------------------------------------------------------------- 000321 08/26/26 + 322 begsr addRow; 000322 08/26/26 + 323 exsr clearMsgs; 000323 08/26/26 + 324 emode = 'A'; 000324 08/26/26 + 325 elot = ''; 000325 08/26/26 + 326 eqty = 0; 000326 08/26/26 + 327 erecv = %char(%date():*mdy); 000327 08/26/26 + 328 eexpd = ''; 000328 08/26/26 + 329 eactive = 'Y'; 000329 08/26/26 + 330 exsr editLoop; 000330 08/26/26 + 331 if not *in12 and elot <> ''; 000331 08/26/26 + 332 exec sql 000332 08/26/26 + 333 insert into perpdemo.item_lot 000333 08/26/26 + 334 (company_code, item_number, lot_number, qty_on_hand, received_date, expiry_date) 000334 08/26/26 + 335 values (:compcd, :filter, :elot, :eqty, date(:erecv), 000335 08/26/26 + 336 case when :eexpd = '' then null else date(:eexpd) end); 000336 08/26/26 + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object WRKLOTR 08/26/26 16:51:50 Page 8 + Record *...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 SEQNBR Last change + 337 if sqlcode < 0; 000337 08/26/26 + 338 writeMsg('Add failed: SQLCODE=' + %char(sqlcode) 000338 08/26/26 + 339 + ' SQLSTATE=' + sqlstate); 000339 08/26/26 + 340 else; 000340 08/26/26 + 341 writeMsg('Added lot ' + %trim(elot) + '.'); 000341 08/26/26 + 342 endif; 000342 08/26/26 + 343 holdMsg = *on; 000343 08/26/26 + 344 endif; 000344 08/26/26 + 345 endsr; 000345 08/26/26 + 346 000346 08/26/26 + 347 // --------------------------------------------------------------------- 000347 08/26/26 + 348 begsr changeRow; 000348 08/26/26 + 349 exsr clearMsgs; 000349 08/26/26 + 350 emode = 'C'; 000350 08/26/26 + 351 elot = slot; 000351 08/26/26 + 352 eqty = sqty; 000352 08/26/26 + 353 erecv = srecv; 000353 08/26/26 + 354 eexpd = sexpd; 000354 08/26/26 + 355 eactive = 'Y'; 000355 08/26/26 + 356 exsr editLoop; 000356 08/26/26 + 357 if not *in12; 000357 08/26/26 + 358 exec sql 000358 08/26/26 + 359 update perpdemo.item_lot 000359 08/26/26 + 360 set qty_on_hand = :eqty, 000360 08/26/26 + 361 received_date = date(:erecv), 000361 08/26/26 + 362 expiry_date = case when :eexpd = '' then null else date(:eexpd) end, 000362 08/26/26 + 363 updated_at = current_timestamp, 000363 08/26/26 + 364 updated_by = user 000364 08/26/26 + 365 where company_code = :compcd and item_number = :filter and lot_number = :elot; 000365 08/26/26 + 366 if sqlcode < 0; 000366 08/26/26 + 367 writeMsg('Change failed: SQLCODE=' + %char(sqlcode)); 000367 08/26/26 + 368 else; 000368 08/26/26 + 369 writeMsg('Updated lot ' + %trim(elot) + '.'); 000369 08/26/26 + 370 endif; 000370 08/26/26 + 371 holdMsg = *on; 000371 08/26/26 + 372 endif; 000372 08/26/26 + 373 endsr; 000373 08/26/26 + 374 000374 08/26/26 + 375 // --------------------------------------------------------------------- 000375 08/26/26 + 376 begsr deleteRow; 000376 08/26/26 + 377 exsr clearMsgs; 000377 08/26/26 + 378 exec sql 000378 08/26/26 + 379 delete from perpdemo.item_lot 000379 08/26/26 + 380 where company_code = :compcd and item_number = :filter and lot_number = :slot; 000380 08/26/26 + 381 if sqlcode < 0; 000381 08/26/26 + 382 writeMsg('Delete failed: SQLSTATE=' + sqlstate); 000382 08/26/26 + 383 else; 000383 08/26/26 + 384 writeMsg('Deleted lot ' + %trim(slot) + '.'); 000384 08/26/26 + 385 endif; 000385 08/26/26 + 386 holdMsg = *on; 000386 08/26/26 + 387 endsr; 000387 08/26/26 + 388 000388 08/26/26 + 389 // --------------------------------------------------------------------- 000389 08/26/26 + 390 // PERP-84: erecv/eexpd are typed by the user as MM/DD/YY on LTEDIT. 000390 08/26/26 + 391 // Validate on every Enter; on failure, show the error in the message 000391 08/26/26 + 392 // subfile alongside LTEDIT and let the user retry (never crash into 000392 08/26/26 + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object WRKLOTR 08/26/26 16:51:50 Page 9 + Record *...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 SEQNBR Last change + 393 // the SQL date(:erecv) cast in addRow/changeRow with unparsed text). 000393 08/26/26 + 394 // On success, erecv/eexpd are normalized to ISO ('yyyy-mm-dd') text so 000394 08/26/26 + 395 // the existing date(:erecv)/date(:eexpd) SQL casts in addRow/changeRow 000395 08/26/26 + 396 // keep working unchanged. 000396 08/26/26 + 397 begsr editLoop; 000397 08/26/26 + 398 exsr clearMsgs; 000398 08/26/26 + 399 dow *on; 000399 08/26/26 + 400 if msgrrn > 0; 000400 08/26/26 + 401 *in40 = *on; 000401 08/26/26 + 402 write ltmsgctl; 000402 08/26/26 + 403 else; 000403 08/26/26 + 404 *in40 = *off; 000404 08/26/26 + 405 endif; 000405 08/26/26 + 406 exfmt ltedit; 000406 08/26/26 + 407 000407 08/26/26 + 408 if *in12; 000408 08/26/26 + 409 leave; 000409 08/26/26 + 410 endif; 000410 08/26/26 + 411 000411 08/26/26 + 412 exsr clearMsgs; 000412 08/26/26 + 413 000413 08/26/26 + 414 if %trim(elot) = ''; 000414 08/26/26 + 415 writeMsg('Lot Number is required.'); 000415 08/26/26 + 416 iter; 000416 08/26/26 + 417 endif; 000417 08/26/26 + 418 000418 08/26/26 + 419 if %trim(erecv) = ''; 000419 08/26/26 + 420 writeMsg('Received Date is required (MM/DD/YY).'); 000420 08/26/26 + 421 iter; 000421 08/26/26 + 422 endif; 000422 08/26/26 + 423 000423 08/26/26 + 424 validRecv = *on; 000424 08/26/26 + 425 monitor; 000425 08/26/26 + 426 parsedRecv = %date(%trim(erecv):*mdy); 000426 08/26/26 + 427 on-error; 000427 08/26/26 + 428 validRecv = *off; 000428 08/26/26 + 429 endmon; 000429 08/26/26 + 430 if not validRecv; 000430 08/26/26 + 431 writeMsg('Invalid Received Date - enter as MM/DD/YY.'); 000431 08/26/26 + 432 iter; 000432 08/26/26 + 433 endif; 000433 08/26/26 + 434 000434 08/26/26 + 435 validExpd = *on; 000435 08/26/26 + 436 if %trim(eexpd) <> ''; 000436 08/26/26 + 437 monitor; 000437 08/26/26 + 438 parsedExpd = %date(%trim(eexpd):*mdy); 000438 08/26/26 + 439 on-error; 000439 08/26/26 + 440 validExpd = *off; 000440 08/26/26 + 441 endmon; 000441 08/26/26 + 442 endif; 000442 08/26/26 + 443 if not validExpd; 000443 08/26/26 + 444 writeMsg('Invalid Expiry Date - enter as MM/DD/YY, or blank for none.'); 000444 08/26/26 + 445 iter; 000445 08/26/26 + 446 endif; 000446 08/26/26 + 447 000447 08/26/26 + 448 erecv = %char(parsedRecv:*iso); 000448 08/26/26 + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object WRKLOTR 08/26/26 16:51:50 Page 10 + Record *...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8 ...+... 9 ...+... 0 SEQNBR Last change + 449 if %trim(eexpd) <> ''; 000449 08/26/26 + 450 eexpd = %char(parsedExpd:*iso); 000450 08/26/26 + 451 endif; 000451 08/26/26 + 452 000452 08/26/26 + 453 leave; 000453 08/26/26 + 454 enddo; 000454 08/26/26 + 455 endsr; 000455 08/26/26 + 456 000456 08/26/26 + 457 // --------------------------------------------------------------------- 000457 08/26/26 + 458 begsr clearMsgs; 000458 08/26/26 + 459 msgrrn = 0; 000459 08/26/26 + 460 *in41 = *on; 000460 08/26/26 + 461 write ltmsgctl; 000461 08/26/26 + 462 *in41 = *off; 000462 08/26/26 + 463 endsr; 000463 08/26/26 + 464 000464 08/26/26 + 465 // --------------------------------------------------------------------- 000465 08/26/26 + 466 dcl-proc writeMsg; 000466 08/26/26 + 467 dcl-pi *n; 000467 08/26/26 + 468 text varchar(256) const; 000468 08/26/26 + 469 end-pi; 000469 08/26/26 + 470 dcl-s data char(256); 000470 08/26/26 + 471 data = text; 000471 08/26/26 + 472 QMHSNDPM( 000472 08/26/26 + 473 'CPF9897' : 000473 08/26/26 + 474 'QCPFMSG QSYS ' : 000474 08/26/26 + 475 data : 000475 08/26/26 + 476 %len(text) : 000476 08/26/26 + 477 '*INFO ' : 000477 08/26/26 + 478 '* ' : 000478 08/26/26 + 479 1 : 000479 08/26/26 + 480 smsgkey : 000480 08/26/26 + 481 x'0000000000000000'); 000481 08/26/26 + 482 msgrrn += 1; 000482 08/26/26 + 483 spgmq = statusDS.programName; 000483 08/26/26 + 484 write ltmsgsfl; 000484 08/26/26 + 485 end-proc; 000485 08/26/26 + * * * * * E N D O F S O U R C E * * * * * + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object WRKLOTR 08/26/26 16:51:50 Page 11 + CROSS REFERENCE + Data Names Define Reference + AISLE 229 VARCHAR(10) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + AISLE_CODE 229 COLUMN FOR AISLE IN PERPDEMO.ITEM + BAY 229 VARCHAR(10) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + BAY_CODE 229 COLUMN FOR BAY IN PERPDEMO.ITEM + CALLITMPRMT 48 + CLASS_CODE 229 COLUMN FOR CLSCD IN PERPDEMO.ITEM + CLSCD 229 VARCHAR(10) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + COMPANY_CODE **** COLUMN + 230 237 267 334 365 380 + COMPANY_CODE 266 COLUMN FOR COMPCD IN PERPDEMO.ITEM_LOT + COMPANY_CODE 229 COLUMN FOR COMPCD IN PERPDEMO.ITEM + COMPCD 31 CHARACTER(3) IN LDADS + COMPCD 73 CHARACTER(3) + 230 237 267 335 365 380 + COMPCD 266 CHARACTER(3) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM_LOT + COMPCD 229 CHARACTER(3) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + CREATED_AT 266 COLUMN FOR CRTAT IN PERPDEMO.ITEM_LOT + CREATED_AT 229 COLUMN FOR CRTAT IN PERPDEMO.ITEM + CREATED_BY 266 COLUMN FOR CRTBY IN PERPDEMO.ITEM_LOT + CREATED_BY 229 COLUMN FOR CRTBY IN PERPDEMO.ITEM + CRITICAL_LEVEL 229 COLUMN FOR CRITLV IN PERPDEMO.ITEM + CRITLV 229 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM + CRTAT 266 TIMESTAMP(26) COLUMN (NOT NULL) IN PERPDEMO.ITEM_LOT + CRTAT 229 TIMESTAMP(26) COLUMN (NOT NULL) IN PERPDEMO.ITEM + CRTBY 266 VARCHAR(18) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM_LOT + CRTBY 229 VARCHAR(18) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + C1 256 CURSOR + 269 276 283 + DATA 470 CHARACTER(256) IN RPG PROCEDURE WRITEMSG + EACTIVE 28 CHARACTER(1) + EEXPD 28 CHARACTER(10) + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object WRKLOTR 08/26/26 16:51:50 Page 12 + CROSS REFERENCE + 336 336 362 362 + ELOT 28 CHARACTER(20) + 335 365 + EMODE 28 CHARACTER(1) + EQTY 28 DECIMAL(15,4) + 335 360 + ERECV 28 CHARACTER(10) + 335 361 + EXPD 61 VARCHAR(10) IN LTROW + EXPD 64 VARCHAR(10) IN ROWS + EXPDT 266 DATE(10) COLUMN IN PERPDEMO.ITEM_LOT + EXPIRY_DATE **** COLUMN + 261 262 263 264 334 362 + EXPIRY_DATE 266 COLUMN FOR EXPDT IN PERPDEMO.ITEM_LOT + FILTER 72 VARCHAR(25) + 230 237 267 335 365 380 + HOLDMSG 77 CHARACTER(1) + I 66 INTEGER PRECISION(9,0) + INVENTORY_UOM 229 COLUMN FOR INVUOM IN PERPDEMO.ITEM + INVUOM 229 VARCHAR(5) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + IS_ACTIVE 266 COLUMN FOR ISACT IN PERPDEMO.ITEM_LOT + IS_ACTIVE 229 COLUMN FOR ISACT IN PERPDEMO.ITEM + ISACT 266 CHARACTER(1) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM_LOT + ISACT 229 CHARACTER(1) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + ISO **** COLUMN + 258 259 260 262 263 264 + ITEM **** TABLE IN PERPDEMO + 229 + ITEM_DESCRIPTION 229 COLUMN FOR ITMDSC IN PERPDEMO.ITEM + ITEM_LOT **** TABLE IN PERPDEMO + 236 266 333 359 379 + ITEM_NUMBER **** COLUMN + 230 237 267 334 365 380 + ITEM_NUMBER 266 COLUMN FOR ITMNBR IN PERPDEMO.ITEM_LOT + ITEM_NUMBER 229 COLUMN FOR ITMNBR IN PERPDEMO.ITEM + ITEMOH 74 DECIMAL(15,4) + 228 + ITMDSC 229 VARCHAR(60) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + ITMNBR 266 VARCHAR(25) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM_LOT + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object WRKLOTR 08/26/26 16:51:50 Page 13 + CROSS REFERENCE + ITMNBR 229 VARCHAR(25) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + LDADS 30 STRUCTURE + LEAD_TIME_DAYS 229 COLUMN FOR LEADTM IN PERPDEMO.ITEM + LEADTM 229 INTEGER PRECISION(9,0) COLUMN (NOT NULL) IN PERPDEMO.ITEM + LOT 58 VARCHAR(20) IN LTROW + LOT 64 VARCHAR(20) IN ROWS + LOT_CONTROLLED 229 COLUMN FOR LOTCTL IN PERPDEMO.ITEM + LOT_NUMBER **** COLUMN + 257 268 334 365 380 + LOT_NUMBER 266 COLUMN FOR LOTNBR IN PERPDEMO.ITEM_LOT + LOTCTL 229 CHARACTER(1) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + LOTNBR 266 VARCHAR(20) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM_LOT + LOTTOTAL 75 DECIMAL(15,4) + 235 + LTROW 57 STRUCTURE + 276 + MAX_QTY 229 COLUMN FOR MAXQTY IN PERPDEMO.ITEM + MAXQTY 229 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM + MIN_QTY 229 COLUMN FOR MINQTY IN PERPDEMO.ITEM + MINQTY 229 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM + MSGKEY 69 CHARACTER(4) + MSGRRN 68 INTEGER PRECISION(9,0) + NUMROWS 65 INTEGER PRECISION(9,0) + PARSEDEXPD 86 DATE(8) + PARSEDRECV 85 DATE(8) + PCOMPCD 24 CHARACTER(3) CONSTANT + PERPDEMO **** SCHEMA + 229 236 266 333 359 379 + PITEM 25 VARCHAR(25) CONSTANT + PROGRAMNAME 54 CHARACTER(10) IN STATUSDS + PROMPTITEM 76 VARCHAR(25) + QMHSNDPM 34 + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object WRKLOTR 08/26/26 16:51:50 Page 14 + CROSS REFERENCE + QTY 59 DECIMAL(15,4) IN LTROW + QTY 64 DECIMAL(15,4) IN ROWS + QTY_AVAILABLE 229 COLUMN FOR QTYAVL IN PERPDEMO.ITEM + QTY_FROZEN 229 COLUMN FOR QTYFRZ IN PERPDEMO.ITEM + QTY_ON_HAND **** COLUMN + 228 235 257 334 360 + QTY_ON_HAND 266 COLUMN FOR QTYOH IN PERPDEMO.ITEM_LOT + QTY_ON_HAND 229 COLUMN FOR QTYOH IN PERPDEMO.ITEM + QTY_ON_ORDER 229 COLUMN FOR QTYOO IN PERPDEMO.ITEM + QTYAVL 229 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM + QTYFRZ 229 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM + QTYOH 266 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM_LOT + QTYOH 229 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM + QTYOO 229 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM + RCVDT 266 DATE(10) COLUMN (NOT NULL) IN PERPDEMO.ITEM_LOT + RECEIVED_DATE **** COLUMN + 258 259 260 334 361 + RECEIVED_DATE 266 COLUMN FOR RCVDT IN PERPDEMO.ITEM_LOT + RECV 60 VARCHAR(10) IN LTROW + RECV 64 VARCHAR(10) IN ROWS + REORDER_POINT 229 COLUMN FOR RORDPT IN PERPDEMO.ITEM + RORDPT 229 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM + ROWS 64 ARRAY(500) STRUCTURE + RRN 67 INTEGER PRECISION(9,0) + SAFETY_STOCK 229 COLUMN FOR SAFSTK IN PERPDEMO.ITEM + SAFSTK 229 DECIMAL(15,4) COLUMN (NOT NULL) IN PERPDEMO.ITEM + SCOMPDSP 28 CHARACTER(3) + SELOPT 71 CHARACTER(1) + SELRRN 70 INTEGER PRECISION(9,0) + SEXPD 28 CHARACTER(10) + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object WRKLOTR 08/26/26 16:51:50 Page 15 + CROSS REFERENCE + SFITEM 28 CHARACTER(25) + SHELF 229 VARCHAR(10) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + SHELF_CODE 229 COLUMN FOR SHELF IN PERPDEMO.ITEM + SHORT_DESCRIPTION 229 COLUMN FOR SHTDSC IN PERPDEMO.ITEM + SHTDSC 229 VARCHAR(20) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + SIOH 28 DECIMAL(15,4) + SLOT 28 CHARACTER(20) + 380 + SLOTTOT 28 DECIMAL(15,4) + SMSGKEY 28 CHARACTER(4) + SOPT 28 CHARACTER(1) + SPGMQ 28 CHARACTER(10) + SQTY 28 DECIMAL(15,4) + SRECV 28 CHARACTER(10) + STATUSDS 53 STRUCTURE + STKUOM 229 VARCHAR(5) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + STOCKING_UOM 229 COLUMN FOR STKUOM IN PERPDEMO.ITEM + TEXT 468 VARCHAR(256) CONSTANT IN RPG PROCEDURE WRITEMSG + UPDAT 266 TIMESTAMP(26) COLUMN (NOT NULL) IN PERPDEMO.ITEM_LOT + UPDAT 229 TIMESTAMP(26) COLUMN (NOT NULL) IN PERPDEMO.ITEM + UPDATED_AT 266 COLUMN FOR UPDAT IN PERPDEMO.ITEM_LOT + UPDATED_AT 229 COLUMN FOR UPDAT IN PERPDEMO.ITEM + UPDATED_AT **** COLUMN + 363 + UPDATED_BY 266 COLUMN FOR UPDBY IN PERPDEMO.ITEM_LOT + UPDATED_BY 229 COLUMN FOR UPDBY IN PERPDEMO.ITEM + UPDATED_BY **** COLUMN + 364 + UPDBY 266 VARCHAR(18) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM_LOT + UPDBY 229 VARCHAR(18) CCSID 37 COLUMN (NOT NULL) IN PERPDEMO.ITEM + VALIDEXPD 88 CHARACTER(1) + 5770ST1 V7R5M0 220415 Create SQL ILE RPG Object WRKLOTR 08/26/26 16:51:50 Page 16 + CROSS REFERENCE + VALIDRECV 87 CHARACTER(1) + WRITEMSG 466 RPG PROCEDURE + No errors found in source + 485 Source records processed + * * * * * E N D O F L I S T I N G * * * * * + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 1 + Command . . . . . . . . . . . . : CRTBNDRPG + Issued by . . . . . . . . . . : AIDEMO + Program . . . . . . . . . . . . : WRKLOTR + Library . . . . . . . . . . . : PERPDEMO + Text 'description' . . . . . . . : *SRCMBRTXT + Source stream file . . . . . . : /QSYS.LIB/QTEMP.LIB/QSQLTEMP1.FILE/WRKLOTR.MBR + CCSID . . . . . . . . . . . . : 37 + Target CCSID . . . . . . . . . . : *JOB (37) + Text 'description' . . . . . . . : + Last Change . . . . . . . . . . : 08/26/26 16:51:50 + Generation severity level . . . : 10 + Default activation group . . . . : *YES + Compiler options . . . . . . . . : *XREF *GEN *NOSECLVL *SHOWCPY + *EXPDDS *EXT *NOSHOWSKP *NOSRCSTMT + *DEBUGIO *UNREF *NOEVENTF + Debugging views . . . . . . . . : *ALL + Debug encryption key . . . . . . : *NONE + Output . . . . . . . . . . . . . : *PRINT + Optimization level . . . . . . . : *NONE + Source listing indentation . . . : *NONE + Type conversion options . . . . : *NONE + Sort sequence . . . . . . . . . : *JOB + Language identifier . . . . . . : *JOB + Replace program . . . . . . . . : *YES + User profile . . . . . . . . . . : *USER + Authority . . . . . . . . . . . : *LIBCRTAUT + Truncate numeric . . . . . . . . : *YES + Fix numeric . . . . . . . . . . : *NONE + Target release . . . . . . . . . : V7R4M0 + Allow null values . . . . . . . : *NO + Define condition names . . . . . : *NONE + Enable performance collection . : *PEP + Profiling data . . . . . . . . . : *NOCOL + Licensed Internal Code options . : + Generate program interface . . . : *NO + Include directory . . . . . . . : . + Preprocessor options . . . . . . : *NONE + Require prototype for export . . : *NO + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 2 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + S o u r c e L i s t i n g + 1 **free 000001 + 2 000002 + 3 // --------------------------------------------------------------------- 000003 + 4 // Program: wrklotr (Work with Item Lots) 000004 + 5 // Purpose: DSPF-based CRUD for item_lot, scoped by the company selected 000005 + 6 // via perpselr (*LDA positions 1-3) and an item number entered 000006 + 7 // on screen (same scoping idiom as wrkcnvr). Shows item.on_hand 000007 + 8 // alongside SUM(item_lot.qty_on_hand) and flags a discrepancy 000008 + 9 // -- the entry point for the reconciliation demo (Option C: 000009 + 10 // balances denormalized on both item and item_lot by design). 000010 + 11 // Callable standalone or pre-scoped by passing company/item 000011 + 12 // (mirrors wrkcnvr's PERP-23 integration). 000012 + 13 // Epic: PERP-3 (PERP-24) 000013 + 14 // --------------------------------------------------------------------- 000014 + 15 000015 + 16 // PERP-84: datfmt(*iso) is required now that this program declares 000016 + 17 // Date-typed variables (parsedRecv/parsedExpd below) to validate the 000017 + 18 // MM/DD/YY Received/Expiry Date entry fields. Without this override the 000018 + 19 // job's *MDY (1940-2039) DATFMT becomes the Date variables' storage 000019 + 20 // format, per perp/AGENTS.md's RNQ0114 gotcha. 000020 + 21 ctl-opt dftactgrp(*no) actgrp(*new) datfmt(*iso); 000021 + 22 000022 + *--------------------------------------------------------------------* + * Compiler Options in Effect: * + *--------------------------------------------------------------------* + * Text 'description' . . . . . . . : * + * Generation severity level . . . : 10 * + * Default activation group . . . . : *NO * + * Compiler options . . . . . . . . : *XREF *GEN * + * *NOSECLVL *SHOWCPY * + * *EXPDDS *EXT * + * *NOSHOWSKP *NOSRCSTMT * + * *DEBUGIO *UNREF * + * *NOEVENTF * + * Optimization level . . . . . . . : *NONE * + * Source listing indentation . . . : *NONE * + * Type conversion options . . . . : *NONE * + * Sort sequence . . . . . . . . . : *JOB * + * Language identifier . . . . . . : *JOB * + * User profile . . . . . . . . . . : *USER * + * Authority . . . . . . . . . . . : *LIBCRTAUT * + * Truncate numeric . . . . . . . . : *YES * + * Fix numeric . . . . . . . . . . : *NONE * + * Allow null values . . . . . . . : *NO * + * Storage model . . . . . . . . . : *SNGLVL * + * Binding directory from Command . : *NONE * + * Binding directory from Source . : *NONE * + * Activation group . . . . . . . . : *NEW * + * Enable performance collection . : *PEP * + * Profiling data . . . . . . . . . : *NOCOL * + * Generate program interface . . . : *NO * + * REQUIRE PROTOTYPE FOR EXPORT . . : *NO * + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 3 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + *--------------------------------------------------------------------* + 23 dcl-pi *n; 000023 + 24 pCompcd char(3) const options(*nopass); 000024 + 25 pItem varchar(25) const options(*nopass); 000025 + 26 end-pi; 000026 + 27 000027 + 28 dcl-f wrklotd workstn sfile(ltsfl:rrn) sfile(ltmsgsfl:msgrrn); 000028 + *--------------------------------------------------------------------------------------------* + * RPG name External name * + * File name. . . . . . . . . : WRKLOTD PERPDEMO/WRKLOTD * + * Record format(s) . . . . . : LTSFL LTSFL * + * LTCTL LTCTL * + * LTFOOT LTFOOT * + * LTNONE LTNONE * + * LTNOITEM LTNOITEM * + * LTEDIT LTEDIT * + * LTMSGSFL LTMSGSFL * + * LTMSGCTL LTMSGCTL * + *--------------------------------------------------------------------------------------------* + 29 000029 + 30 dcl-ds ldaDS dtaara(*lda) len(1024) qualified; 000030 + 31 compcd char(3) pos(1); 000031 + 32 end-ds; 000032 + 33 000033 + 34 dcl-pr QMHSNDPM extpgm; 000034 + 35 msgId char(7) const; 000035 + 36 msgF char(20) const; 000036 + 37 msgData char(256) const; 000037 + 38 msgDataLen int(10) const; 000038 + 39 msgType char(10) const; 000039 + 40 stackEntry char(10) const; 000040 + 41 stackCntr int(10) const; 000041 + 42 msgKey char(4); 000042 + 43 errorCode char(8) const; 000043 + 44 end-pr; 000044 + 45 000045 + 46 // Standard, reusable Item Number prompt (PERP-51/PERP-56). Same dynamic 000046 + 47 // CALL idiom as wrkitmr's callWrkcnvr/callWrklotr. 000047 + 48 dcl-pr callItmprmt extpgm('ITMPRMT'); 000048 + 49 pCompcd char(3) const; 000049 + 50 pItem varchar(25); 000050 + 51 end-pr; 000051 + 52 000052 + 53 dcl-ds statusDS psds qualified; 000053 + 54 programName char(10) pos(334); 000054 + 55 end-ds; 000055 + 56 000056 + 57 dcl-ds ltRow qualified; 000057 + 58 lot varchar(20); 000058 + 59 qty packed(15:4); 000059 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 4 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 60 recv varchar(10); 000060 + 61 expd varchar(10); 000061 + 62 end-ds; 000062 + 63 000063 + 64 dcl-ds rows likeds(ltRow) dim(500); 000064 + 65 dcl-s numRows int(10); 000065 + 66 dcl-s i int(10); 000066 + 67 dcl-s rrn int(10); 000067 + 68 dcl-s msgrrn int(10); 000068 + 69 dcl-s msgkey char(4); 000069 + 70 dcl-s selRrn int(10); 000070 + 71 dcl-s selOpt char(1); 000071 + 72 dcl-s filter varchar(25); 000072 + 73 dcl-s compcd char(3); 000073 + 74 dcl-s itemOh packed(15:4); 000074 + 75 dcl-s lotTotal packed(15:4); 000075 + 76 dcl-s promptItem varchar(25); 000076 + 77 dcl-s holdMsg ind; 000077 + 78 000078 + 79 // PERP-84: MM/DD/YY entry validation for ERECV/EEXPD (see editLoop). 000079 + 80 // parsedRecv/parsedExpd are Date-typed working vars used only to 000080 + 81 // validate/reformat the typed text -- they are never bound directly to 000081 + 82 // an SQL host variable (erecv/eexpd stay char(10) for that), so the 000082 + 83 // SQL-precompiler-intermediate-host-variable *MDY cap documented in 000083 + 84 // perp/AGENTS.md #13 does not come into play here. 000084 + 85 dcl-s parsedRecv date; 000085 + 86 dcl-s parsedExpd date; 000086 + 87 dcl-s validRecv ind; 000087 + 88 dcl-s validExpd ind; 000088 + 89 000089 + 90 /SET CCSID(*CHAR:*JOBRUNMIX) 000090 + 91 // SQL COMMUNICATION AREA //SQL 000091 + 92 DCL-DS SQLCA; //SQL 000092 + 93 SQLCAID CHAR(8) INZ(X'0000000000000000'); //SQL 000093 + 94 SQLAID CHAR(8) OVERLAY(SQLCAID); //SQL 000094 + 95 SQLCABC INT(10); //SQL 000095 + 96 SQLABC BINDEC(9) OVERLAY(SQLCABC); //SQL 000096 + 97 SQLCODE INT(10); //SQL 000097 + 98 SQLCOD BINDEC(9) OVERLAY(SQLCODE); //SQL 000098 + 99 SQLERRML INT(5); //SQL 000099 + 100 SQLERL BINDEC(4) OVERLAY(SQLERRML); //SQL 000100 + 101 SQLERRMC CHAR(70); //SQL 000101 + 102 SQLERM CHAR(70) OVERLAY(SQLERRMC); //SQL 000102 + 103 SQLERRP CHAR(8); //SQL 000103 + 104 SQLERP CHAR(8) OVERLAY(SQLERRP); //SQL 000104 + 105 SQLERR CHAR(24); //SQL 000105 + 106 SQLER1 BINDEC(9) OVERLAY(SQLERR:*NEXT); //SQL 000106 + 107 SQLER2 BINDEC(9) OVERLAY(SQLERR:*NEXT); //SQL 000107 + 108 SQLER3 BINDEC(9) OVERLAY(SQLERR:*NEXT); //SQL 000108 + 109 SQLER4 BINDEC(9) OVERLAY(SQLERR:*NEXT); //SQL 000109 + 110 SQLER5 BINDEC(9) OVERLAY(SQLERR:*NEXT); //SQL 000110 + 111 SQLER6 BINDEC(9) OVERLAY(SQLERR:*NEXT); //SQL 000111 + 112 SQLERRD INT(10) DIM(6) OVERLAY(SQLERR); //SQL 000112 + 113 SQLWRN CHAR(11); //SQL 000113 + 114 SQLWN0 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000114 + 115 SQLWN1 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000115 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 5 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 116 SQLWN2 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000116 + 117 SQLWN3 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000117 + 118 SQLWN4 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000118 + 119 SQLWN5 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000119 + 120 SQLWN6 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000120 + 121 SQLWN7 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000121 + 122 SQLWN8 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000122 + 123 SQLWN9 CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000123 + 124 SQLWNA CHAR(1) OVERLAY(SQLWRN:*NEXT); //SQL 000124 + 125 SQLWARN CHAR(1) DIM(11) OVERLAY(SQLWRN); //SQL 000125 + 126 SQLSTATE CHAR(5); //SQL 000126 + 127 SQLSTT CHAR(5) OVERLAY(SQLSTATE); //SQL 000127 + 128 END-DS SQLCA; //SQL 000128 + 129 DCL-PR SQLROUTE_CALL EXTPGM(SQLROUTE); //SQL 000129 + 130 CA LIKEDS(SQLCA); //SQL 000130 + 131 *N BINDEC(4) OPTIONS(*NOPASS); //SQL 000131 + 132 *N CHAR(1) OPTIONS(*NOPASS); //SQL 000132 + 133 END-PR SQLROUTE_CALL; //SQL 000133 + 134 DCL-PR SQLOPEN_CALL EXTPGM(SQLOPEN); //SQL 000134 + 135 CA LIKEDS(SQLCA); //SQL 000135 + 136 *N BINDEC(4); //SQL 000136 + 137 END-PR SQLOPEN_CALL; //SQL 000137 + 138 DCL-PR SQLCLSE_CALL EXTPGM(SQLCLSE); //SQL 000138 + 139 CA LIKEDS(SQLCA); //SQL 000139 + 140 *N BINDEC(4); //SQL 000140 + 141 END-PR SQLCLSE_CALL; //SQL 000141 + 142 DCL-PR SQLCMIT_CALL EXTPGM(SQLCMIT); //SQL 000142 + 143 CA LIKEDS(SQLCA); //SQL 000143 + 144 *N BINDEC(4); //SQL 000144 + 145 END-PR SQLCMIT_CALL; //SQL 000145 + 146 /RESTORE CCSID(*CHAR) 000146 + 147 DCL-C SQLROUTE CONST('QSYS/QSQROUTE'); //SQL 000147 + 148 DCL-C SQLOPEN CONST('QSYS/QSQROUTE'); //SQL 000148 + 149 DCL-C SQLCLSE CONST('QSYS/QSQLCLSE'); //SQL 000149 + 150 DCL-C SQLCMIT CONST('QSYS/QSQLCMIT'); //SQL 000150 + 151 DCL-C SQFRD CONST(2); //SQL 000151 + 152 DCL-C SQFCRT CONST(8); //SQL 000152 + 153 DCL-C SQFOVR CONST(16); //SQL 000153 + 154 DCL-C SQFAPP CONST(32); //SQL 000154 + 155 **END-FREE 000155 + Line <---------------------- Source Specifications ----------------------------><---- Comments ----> Do Page Change Src Seq + Number ....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Line Date Id Number + 156 D DS SELECT 000156 + 157 D SQL_00000 1 2B 0 INZ(128) length of header 000157 + 158 D SQL_00001 3 4B 0 INZ(2) statement number 000158 + 159 D SQL_00002 5 8U 0 INZ(0) invocation mark 000159 + 160 D SQL_00003 9 9A INZ('0') CCSID(*JOBRUNMIX) data is okay 000160 + 161 D SQL_00004 10 128A CCSID(*JOBRUNMIX) end of header 000161 + 162 D SQL_00005 129 131A CCSID(*JOBRUNMIX) COMPCD 000162 + 163 D SQL_00006 132 158A VARYING CCSID(*JOBRUNMIX) FILTER 000163 + 164 D SQL_00007 159 166P 4 ITEMOH 000164 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 6 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 165 **FREE 000165 + 166 **END-FREE 000166 + Line <---------------------- Source Specifications ----------------------------><---- Comments ----> Do Page Change Src Seq + Number ....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Line Date Id Number + 167 D DS SELECT 000167 + 168 D SQL_00008 1 2B 0 INZ(128) length of header 000168 + 169 D SQL_00009 3 4B 0 INZ(3) statement number 000169 + 170 D SQL_00010 5 8U 0 INZ(0) invocation mark 000170 + 171 D SQL_00011 9 9A INZ('0') CCSID(*JOBRUNMIX) data is okay 000171 + 172 D SQL_00012 10 128A CCSID(*JOBRUNMIX) end of header 000172 + 173 D SQL_00013 129 131A CCSID(*JOBRUNMIX) COMPCD 000173 + 174 D SQL_00014 132 158A VARYING CCSID(*JOBRUNMIX) FILTER 000174 + 175 D SQL_00015 159 166P 4 LOTTOTAL 000175 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 176 **FREE 000176 + 177 **END-FREE 000177 + Line <---------------------- Source Specifications ----------------------------><---- Comments ----> Do Page Change Src Seq + Number ....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Line Date Id Number + 178 D DS OPEN 000178 + 179 D SQL_00016 1 2B 0 INZ(128) length of header 000179 + 180 D SQL_00017 3 4B 0 INZ(4) statement number 000180 + 181 D SQL_00018 5 8U 0 INZ(0) invocation mark 000181 + 182 D SQL_00019 9 9A INZ('0') CCSID(*JOBRUNMIX) data is okay 000182 + 183 D SQL_00020 10 128A CCSID(*JOBRUNMIX) end of header 000183 + 184 D SQL_00021 129 131A CCSID(*JOBRUNMIX) COMPCD 000184 + 185 D SQL_00022 132 158A VARYING CCSID(*JOBRUNMIX) FILTER 000185 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 186 **FREE 000186 + 187 **END-FREE 000187 + Line <---------------------- Source Specifications ----------------------------><---- Comments ----> Do Page Change Src Seq + Number ....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Line Date Id Number + 188 D DS FETCH 000188 + 189 D SQL_00023 1 2B 0 INZ(128) length of header 000189 + 190 D SQL_00024 3 4B 0 INZ(5) statement number 000190 + 191 D SQL_00025 5 8U 0 INZ(0) invocation mark 000191 + 192 D SQL_00026 9 9A INZ('0') CCSID(*JOBRUNMIX) data is okay 000192 + 193 D SQL_00027 10 128A CCSID(*JOBRUNMIX) end of header 000193 + 194 D SQL_00028 129 150A VARYING CCSID(*JOBRUNMIX) LTROW.LOT 000194 + 195 D SQL_00029 151 158P 4 LTROW.QTY 000195 + 196 D SQL_00030 159 170A VARYING CCSID(*JOBRUNMIX) LTROW.RECV 000196 + 197 D SQL_00031 171 182A VARYING CCSID(*JOBRUNMIX) LTROW.EXPD 000197 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 7 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 198 **FREE 000198 + 199 **END-FREE 000199 + Line <---------------------- Source Specifications ----------------------------><---- Comments ----> Do Page Change Src Seq + Number ....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Line Date Id Number + 200 D DS CLOSE 000200 + 201 D SQL_00032 1 2B 0 INZ(128) length of header 000201 + 202 D SQL_00033 3 4B 0 INZ(6) statement number 000202 + 203 D SQL_00034 5 8U 0 INZ(0) invocation mark 000203 + 204 D SQL_00035 9 9A INZ('0') CCSID(*JOBRUNMIX) data is okay 000204 + 205 D SQL_00036 10 127A CCSID(*JOBRUNMIX) end of header 000205 + 206 D SQL_00037 128 128A CCSID(*JOBRUNMIX) end of header 000206 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 207 **FREE 000207 + 208 **END-FREE 000208 + Line <---------------------- Source Specifications ----------------------------><---- Comments ----> Do Page Change Src Seq + Number ....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Line Date Id Number + 209 D DS INSERT 000209 + 210 D SQL_00038 1 2B 0 INZ(128) length of header 000210 + 211 D SQL_00039 3 4B 0 INZ(7) statement number 000211 + 212 D SQL_00040 5 8U 0 INZ(0) invocation mark 000212 + 213 D SQL_00041 9 9A INZ('0') CCSID(*JOBRUNMIX) data is okay 000213 + 214 D SQL_00042 10 127A CCSID(*JOBRUNMIX) end of header 000214 + 215 D SQL_00043 129 131A CCSID(*JOBRUNMIX) COMPCD 000215 + 216 D SQL_00044 132 158A VARYING CCSID(*JOBRUNMIX) FILTER 000216 + 217 D SQL_00045 159 178A CCSID(*JOBRUNMIX) ELOT 000217 + 218 D SQL_00046 179 186P 4 EQTY 000218 + 219 D SQL_00047 187 196A CCSID(*JOBRUNMIX) ERECV 000219 + 220 D SQL_00048 197 206A CCSID(*JOBRUNMIX) EEXPD 000220 + 221 D SQL_00049 207 216A CCSID(*JOBRUNMIX) EEXPD 000221 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 222 **FREE 000222 + 223 **END-FREE 000223 + Line <---------------------- Source Specifications ----------------------------><---- Comments ----> Do Page Change Src Seq + Number ....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Line Date Id Number + 224 D DS UPDATE 000224 + 225 D SQL_00050 1 2B 0 INZ(128) length of header 000225 + 226 D SQL_00051 3 4B 0 INZ(8) statement number 000226 + 227 D SQL_00052 5 8U 0 INZ(0) invocation mark 000227 + 228 D SQL_00053 9 9A INZ('0') CCSID(*JOBRUNMIX) data is okay 000228 + 229 D SQL_00054 10 127A CCSID(*JOBRUNMIX) end of header 000229 + 230 D SQL_00055 129 136P 4 EQTY 000230 + 231 D SQL_00056 137 146A CCSID(*JOBRUNMIX) ERECV 000231 + 232 D SQL_00057 147 156A CCSID(*JOBRUNMIX) EEXPD 000232 + 233 D SQL_00058 157 166A CCSID(*JOBRUNMIX) EEXPD 000233 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 8 + Line <---------------------- Source Specifications ----------------------------><---- Comments ----> Do Page Change Src Seq + Number ....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Line Date Id Number + 234 D SQL_00059 167 169A CCSID(*JOBRUNMIX) COMPCD 000234 + 235 D SQL_00060 170 196A VARYING CCSID(*JOBRUNMIX) FILTER 000235 + 236 D SQL_00061 197 216A CCSID(*JOBRUNMIX) ELOT 000236 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 237 **FREE 000237 + 238 **END-FREE 000238 + Line <---------------------- Source Specifications ----------------------------><---- Comments ----> Do Page Change Src Seq + Number ....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Line Date Id Number + 239 D DS DELETE 000239 + 240 D SQL_00062 1 2B 0 INZ(128) length of header 000240 + 241 D SQL_00063 3 4B 0 INZ(9) statement number 000241 + 242 D SQL_00064 5 8U 0 INZ(0) invocation mark 000242 + 243 D SQL_00065 9 9A INZ('0') CCSID(*JOBRUNMIX) data is okay 000243 + 244 D SQL_00066 10 127A CCSID(*JOBRUNMIX) end of header 000244 + 245 D SQL_00067 129 131A CCSID(*JOBRUNMIX) COMPCD 000245 + 246 D SQL_00068 132 158A VARYING CCSID(*JOBRUNMIX) FILTER 000246 + 247 D SQL_00069 159 178A CCSID(*JOBRUNMIX) SLOT 000247 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 248 **FREE 000248 + 249=ILTSFL 1000001 + *--------------------------------------------------------------------------------------------* 1 + * RPG record format . . . . : LTSFL * 1 + * External format . . . . . : LTSFL : PERPDEMO/WRKLOTD * 1 + *--------------------------------------------------------------------------------------------* 1 + 250=I N 1 1 *IN03 Exit 1000002 + 251=I N 2 2 *IN05 Refresh 1000003 + 252=I N 3 3 *IN06 Add 1000004 + 253=I N 4 4 *IN12 Cancel 1000005 + 254=I A 5 5 SOPT 1000006 + 255=I A 6 25 SLOT 1000007 + 256=I S 26 40 4SQTY 1000008 + 257=I A 41 50 SRECV 1000009 + 258=I A 51 60 SEXPD 1000010 + 259=ILTCTL 2000001 + *--------------------------------------------------------------------------------------------* 2 + * RPG record format . . . . : LTCTL * 2 + * External format . . . . . : LTCTL : PERPDEMO/WRKLOTD * 2 + *--------------------------------------------------------------------------------------------* 2 + 260=I N 1 1 *IN03 Exit 2000002 + 261=I N 2 2 *IN05 Refresh 2000003 + 262=I N 3 3 *IN06 Add 2000004 + 263=I N 4 4 *IN12 Cancel 2000005 + 264=I A 5 29 SFITEM 2000006 + 265=ILTFOOT 3000001 + *--------------------------------------------------------------------------------------------* 3 + * RPG record format . . . . : LTFOOT * 3 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 9 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + * External format . . . . . : LTFOOT : PERPDEMO/WRKLOTD * 3 + *--------------------------------------------------------------------------------------------* 3 + 266=I N 1 1 *IN03 Exit 3000002 + 267=I N 2 2 *IN05 Refresh 3000003 + 268=I N 3 3 *IN06 Add 3000004 + 269=I N 4 4 *IN12 Cancel 3000005 + 270=ILTNONE 4000001 + *--------------------------------------------------------------------------------------------* 4 + * RPG record format . . . . : LTNONE * 4 + * External format . . . . . : LTNONE : PERPDEMO/WRKLOTD * 4 + *--------------------------------------------------------------------------------------------* 4 + 271=I N 1 1 *IN03 Exit 4000002 + 272=I N 2 2 *IN05 Refresh 4000003 + 273=I N 3 3 *IN06 Add 4000004 + 274=I N 4 4 *IN12 Cancel 4000005 + 275=ILTNOITEM 5000001 + *--------------------------------------------------------------------------------------------* 5 + * RPG record format . . . . : LTNOITEM * 5 + * External format . . . . . : LTNOITEM : PERPDEMO/WRKLOTD * 5 + *--------------------------------------------------------------------------------------------* 5 + 276=I N 1 1 *IN03 Exit 5000002 + 277=I N 2 2 *IN05 Refresh 5000003 + 278=I N 3 3 *IN06 Add 5000004 + 279=I N 4 4 *IN12 Cancel 5000005 + 280=ILTEDIT 6000001 + *--------------------------------------------------------------------------------------------* 6 + * RPG record format . . . . : LTEDIT * 6 + * External format . . . . . : LTEDIT : PERPDEMO/WRKLOTD * 6 + *--------------------------------------------------------------------------------------------* 6 + 281=I N 1 1 *IN03 Exit 6000002 + 282=I N 2 2 *IN05 Refresh 6000003 + 283=I N 3 3 *IN06 Add 6000004 + 284=I N 4 4 *IN12 Cancel 6000005 + 285=I A 5 24 ELOT 6000006 + 286=I S 25 39 4EQTY 6000007 + 287=I A 40 49 ERECV 6000008 + 288=I A 50 59 EEXPD 6000009 + 289=I A 60 60 EACTIVE 6000010 + 290=ILTMSGSFL 7000001 + *--------------------------------------------------------------------------------------------* 7 + * RPG record format . . . . : LTMSGSFL * 7 + * External format . . . . . : LTMSGSFL : PERPDEMO/WRKLOTD * 7 + *--------------------------------------------------------------------------------------------* 7 + 291=I N 1 1 *IN03 Exit 7000002 + 292=I N 2 2 *IN05 Refresh 7000003 + 293=I N 3 3 *IN06 Add 7000004 + 294=I N 4 4 *IN12 Cancel 7000005 + 295=I A 5 8 SMSGKEY 7000006 + 296=I A 9 18 SPGMQ 7000007 + 297=ILTMSGCTL 8000001 + *--------------------------------------------------------------------------------------------* 8 + * RPG record format . . . . : LTMSGCTL * 8 + * External format . . . . . : LTMSGCTL : PERPDEMO/WRKLOTD * 8 + *--------------------------------------------------------------------------------------------* 8 + 298=I N 1 1 *IN03 Exit 8000002 + 299=I N 2 2 *IN05 Refresh 8000003 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 10 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 300=I N 3 3 *IN06 Add 8000004 + 301=I N 4 4 *IN12 Cancel 8000005 + 302 in ldaDS; 000249 + 303 compcd = ldaDS.compcd; 000250 + 304 000251 + 305 if %parms >= 1 and pCompcd <> ''; B01 000252 + 306 compcd = pCompcd; 01 000253 + 307 endif; E01 000254 + 308 scompdsp = compcd; 000255 + 309 filter = ''; 000256 + 310 if %parms >= 2 and pItem <> ''; B01 000257 + 311 filter = pItem; 01 000258 + 312 sfitem = pItem; 01 000259 + 313 else; X01 000260 + 314 sfitem = ''; 01 000261 + 315 endif; E01 000262 + 316 000263 + 317 if compcd = ''; B01 000264 + 318 exsr clearMsgs; 01 000265 + 319 writeMsg('No company selected - run Select Company (PERPSELR) first.'); 01 000266 + 320 endif; E01 000267 + 321 000268 + 322 dow not *in03 and not *in12; B01 000269 + 323 if compcd = ''; B02 000270 + 324 *in30 = *off; 02 000271 + 325 write ltnoitem; 02 000272 + 326 write ltfoot; 02 000273 + 327 if msgrrn > 0; B03 000274 + 328 *in40 = *on; 03 000275 + 329 write ltmsgctl; 03 000276 + 330 else; X03 000277 + 331 *in40 = *off; 03 000278 + 332 endif; E03 000279 + 333 exfmt ltctl; 02 000280 + 334 leave; 02 000281 + 335 endif; E02 000282 + 336 000283 + 337 // A message queued by an action handler below (addRow, etc.) must 000284 + 338 // survive one full loop pass before being cleared, or it never 000285 + 339 // reaches the screen -- clearMsgs wipes msgrrn back to 0 on the very 000286 + 340 // next pass, before this pass's own exfmt ever shows it. holdMsg 000287 + 341 // skips exactly one clearMsgs call right after such a message was 000288 + 342 // queued. Same pattern as wrkitmr. 000289 + 343 if holdMsg; B02 000290 + 344 holdMsg = *off; 02 000291 + 345 else; X02 000292 + 346 exsr clearMsgs; 02 000293 + 347 endif; E02 000294 + 348 000295 + 349 if filter = ''; B02 000296 + 350 *in30 = *off; 02 000297 + 351 *in60 = *off; 02 000298 + 352 numRows = 0; 02 000299 + 353 sioh = 0; 02 000300 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 11 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 354 slottot = 0; 02 000301 + 355 write ltnoitem; 02 000302 + 356 else; X02 000303 + 357 exsr loadBalances; 02 000304 + 358 exsr loadRows; 02 000305 + 359 if numRows = 0; B03 000306 + 360 *in30 = *off; 03 000307 + 361 write ltnone; 03 000308 + 362 else; X03 000309 + 363 exsr fillSubfile; 03 000310 + 364 *in30 = *on; 03 000311 + 365 endif; E03 000312 + 366 endif; E02 000313 + 367 000314 + 368 write ltfoot; 01 000315 + 369 if msgrrn > 0; B02 000316 + 370 *in40 = *on; 02 000317 + 371 write ltmsgctl; 02 000318 + 372 else; X02 000319 + 373 *in40 = *off; 02 000320 + 374 endif; E02 000321 + 375 exfmt ltctl; 01 000322 + 376 000323 + 377 if *in03 or *in12; B02 000324 + 378 leave; 02 000325 + 379 endif; E02 000326 + 380 000327 + 381 if *in05; B02 000328 + 382 filter = sfitem; 02 000329 + 383 iter; 02 000330 + 384 endif; E02 000331 + 385 000332 + 386 if *in06; B02 000333 + 387 if sfitem = ''; B03 000334 + 388 writeMsg('Enter an item number before adding a lot.'); 03 000335 + 389 holdMsg = *on; 03 000336 + 390 else; X03 000337 + 391 filter = sfitem; 03 000338 + 392 exsr addRow; 03 000339 + 393 endif; E03 000340 + 394 iter; 02 000341 + 395 endif; E02 000342 + 396 000343 + 397 // Item Number prompt (PERP-60): '?' + Enter invokes the standard 000344 + 398 // reusable Item Number lookup (PERP-56) and returns the selection. 000345 + 399 if %trim(sfitem) = '?'; B02 000346 + 400 promptItem = sfitem; 02 000347 + 401 callItmprmt(compcd : promptItem); 02 000348 + 402 sfitem = promptItem; 02 000349 + 403 filter = promptItem; 02 000350 + 404 iter; 02 000351 + 405 endif; E02 000352 + 406 000353 + 407 // Refresh scope from screen entry 000354 + 408 if sfitem <> filter; B02 000355 + 409 filter = sfitem; 02 000356 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 12 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 410 iter; 02 000357 + 411 endif; E02 000358 + 412 000359 + 413 // Process subfile options. Guard on numRows: READC against a subfile 000360 + 414 // that was never written to this cycle (0 rows loaded) raises a 000361 + 415 // "Session or device error" (CPF5006-class) runtime error instead of 000362 + 416 // just returning *EOF. 000363 + 417 if numRows > 0; B02 000364 + 418 selRrn = 0; 02 000365 + 419 selOpt = ' '; 02 000366 + 420 readc ltsfl; 02 000367 + 421 dow not %eof(wrklotd); B03 000368 + 422 if sopt <> ''; B04 000369 + 423 selRrn = rrn; 04 000370 + 424 selOpt = sopt; 04 000371 + 425 exsr handleOpt; 04 000372 + 426 selRrn = 0; 04 000373 + 427 endif; E04 000374 + 428 readc ltsfl; 03 000375 + 429 enddo; E03 000376 + 430 endif; E02 000377 + 431 000378 + 432 enddo; E01 000379 + 433 000380 + 434 *inlr = *on; 000381 + 435 return; 000382 + 436 000383 + 437 // --------------------------------------------------------------------- 000384 + 438 begsr loadBalances; 000385 + 439 //* exec sql 000386 + 440 //* select qty_on_hand into :itemOh 000387 + 441 //* from perpdemo.item 000388 + 442 //* where company_code = :compcd and item_number = :filter; 000389 + 443 SQL_00005 = COMPCD; //SQL 000390 + 444 SQL_00006 = FILTER; //SQL 000391 + 445 SQLER6 = -4; //SQL 2 000392 + 446 SQLROUTE_CALL( //SQL 000393 + 447 SQLCA //SQL 000394 + 448 : SQL_00000 //SQL 000395 + 449 ); //SQL 000396 + 450 IF SQL_00003 = '1'; //SQL B01 000397 + 451 EVAL ITEMOH = SQL_00007; //SQL 01 000398 + 452 ENDIF; //SQL E01 000399 + 453 if sqlcode <> 0; B01 000400 + 454 itemOh = 0; 01 000401 + 455 endif; E01 000402 + 456 //* exec sql 000403 + 457 //* select coalesce(sum(qty_on_hand), 0) into :lotTotal 000404 + 458 //* from perpdemo.item_lot 000405 + 459 //* where company_code = :compcd and item_number = :filter; 000406 + 460 SQL_00013 = COMPCD; //SQL 000407 + 461 SQL_00014 = FILTER; //SQL 000408 + 462 SQLER6 = -4; //SQL 3 000409 + 463 SQLROUTE_CALL( //SQL 000410 + 464 SQLCA //SQL 000411 + 465 : SQL_00008 //SQL 000412 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 13 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 466 ); //SQL 000413 + 467 IF SQL_00011 = '1'; //SQL B01 000414 + 468 EVAL LOTTOTAL = SQL_00015; //SQL 01 000415 + 469 ENDIF; //SQL E01 000416 + 470 sioh = itemOh; 000417 + 471 slottot = lotTotal; 000418 + 472 if itemOh <> lotTotal; B01 000419 + 473 *in60 = *on; 01 000420 + 474 else; X01 000421 + 475 *in60 = *off; 01 000422 + 476 endif; E01 000423 + 477 endsr; 000424 + 478 000425 + 479 // --------------------------------------------------------------------- 000426 + 480 begsr loadRows; 000427 + 481 numRows = 0; 000428 + 482 // PERP-84: display as MM/DD/YY. received_date/expiry_date are stored 000429 + 483 // as native DATE columns but rendered here as plain strings (SRECV/ 000430 + 484 // SEXPD carry no DATFMT keyword), so the format has to be built by 000431 + 485 // hand from the ISO string -- DB2 for i's CHAR(date,fmt) built-in 000432 + 486 // formats (ISO/USA/EUR/JIS) all use a 4-digit year, none produce a 000433 + 487 // 2-digit year directly. Same technique as wrkivpr.sqlrpgle (PERP-83). 000434 + 488 //* exec sql declare c1 cursor for 000435 + 489 //* select lot_number, qty_on_hand, 000436 + 490 //* substr(char(received_date, iso), 6, 2) || '/' 000437 + 491 //* || substr(char(received_date, iso), 9, 2) || '/' 000438 + 492 //* || substr(char(received_date, iso), 3, 2), 000439 + 493 //* case when expiry_date is null then '' 000440 + 494 //* else substr(char(expiry_date, iso), 6, 2) || '/' 000441 + 495 //* || substr(char(expiry_date, iso), 9, 2) || '/' 000442 + 496 //* || substr(char(expiry_date, iso), 3, 2) 000443 + 497 //* end 000444 + 498 //* from perpdemo.item_lot 000445 + 499 //* where company_code = :compcd and item_number = :filter 000446 + 500 //* order by lot_number; 000447 + 501 //* exec sql open c1; 000448 + 502 SQL_00021 = COMPCD; //SQL 000449 + 503 SQL_00022 = FILTER; //SQL 000450 + 504 SQLER6 = -4; //SQL 000451 + 505 IF SQL_00018 = 0 //SQL B01 000452 + 506 OR SQL_00019 <> *LOVAL; //SQL B01 000453 + 507 SQLROUTE_CALL( //SQL 01 000454 + 508 SQLCA //SQL 01 000455 + 509 : SQL_00016 //SQL 01 000456 + 510 ); //SQL 01 000457 + 511 ELSE; //SQL X01 000458 + 512 SQLOPEN_CALL( //SQL 01 000459 + 513 SQLCA //SQL 01 000460 + 514 : SQL_00016 //SQL 01 000461 + 515 ); //SQL 01 000462 + 516 ENDIF; //SQL E01 000463 + 517 if sqlcode < 0; B01 000464 + 518 writeMsg('SQL open failed: SQLCODE=' + %char(sqlcode)); 01 000465 + 519 leavesr; 01 000466 + 520 endif; E01 000467 + 521 000468 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 14 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 522 dow numRows < %elem(rows); B01 000469 + 523 //* exec sql fetch c1 into :ltRow; 000470 + 524 SQLER6 = -4; //SQL 5 01 000471 + 525 SQLROUTE_CALL( //SQL 01 000472 + 526 SQLCA //SQL 01 000473 + 527 : SQL_00023 //SQL 01 000474 + 528 ); //SQL 01 000475 + 529 IF SQL_00026 = '1'; //SQL B02 000476 + 530 EVAL LTROW.LOT = SQL_00028; //SQL 02 000477 + 531 EVAL LTROW.QTY = SQL_00029; //SQL 02 000478 + 532 EVAL LTROW.RECV = SQL_00030; //SQL 02 000479 + 533 EVAL LTROW.EXPD = SQL_00031; //SQL 02 000480 + 534 ENDIF; //SQL E02 000481 + 535 if sqlcode = 100 or sqlcode < 0; B02 000482 + 536 leave; 02 000483 + 537 endif; E02 000484 + 538 numRows += 1; 01 000485 + 539 rows(numRows) = ltRow; 01 000486 + 540 enddo; E01 000487 + 541 //* exec sql close c1; 000488 + 542 SQLER6 = 6; //SQL 000489 + 543 IF SQL_00034 = 0; //SQL B01 000490 + 544 SQLROUTE_CALL( //SQL 01 000491 + 545 SQLCA //SQL 01 000492 + 546 : SQL_00032 //SQL 01 000493 + 547 ); //SQL 01 000494 + 548 ELSE; //SQL X01 000495 + 549 SQLCLSE_CALL( //SQL 01 000496 + 550 SQLCA //SQL 01 000497 + 551 : SQL_00032 //SQL 01 000498 + 552 ); //SQL 01 000499 + 553 ENDIF; //SQL E01 000500 + 554 endsr; 000501 + 555 000502 + 556 // --------------------------------------------------------------------- 000503 + 557 begsr fillSubfile; 000504 + 558 rrn = 0; 000505 + 559 *in31 = *on; 000506 + 560 write ltctl; 000507 + 561 *in31 = *off; 000508 + 562 for i = 1 to numRows; B01 000509 + 563 *in50 = *off; 01 000510 + 564 *in51 = *off; 01 000511 + 565 sopt = ''; 01 000512 + 566 slot = rows(i).lot; 01 000513 + 567 sqty = rows(i).qty; 01 000514 + 568 srecv = rows(i).recv; 01 000515 + 569 sexpd = rows(i).expd; 01 000516 + 570 rrn += 1; 01 000517 + 571 write ltsfl; 01 000518 + 572 endfor; E01 000519 + 573 endsr; 000520 + 574 000521 + 575 // --------------------------------------------------------------------- 000522 + 576 begsr handleOpt; 000523 + 577 chain selRrn ltsfl; 000524 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 15 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 578 if %found(wrklotd); B01 000525 + 579 select; B02 000526 + 580 when selOpt = '2'; X02 000527 + 581 exsr changeRow; 02 000528 + 582 when selOpt = '4'; X02 000529 + 583 exsr deleteRow; 02 000530 + 584 other; X02 000531 + 585 writeMsg('Option ' + selOpt + ' not valid.'); 02 000532 + 586 holdMsg = *on; 02 000533 + 587 endsl; E02 000534 + 588 endif; E01 000535 + 589 endsr; 000536 + 590 000537 + 591 // --------------------------------------------------------------------- 000538 + 592 begsr addRow; 000539 + 593 exsr clearMsgs; 000540 + 594 emode = 'A'; 000541 + 595 elot = ''; 000542 + 596 eqty = 0; 000543 + 597 erecv = %char(%date():*mdy); 000544 + 598 eexpd = ''; 000545 + 599 eactive = 'Y'; 000546 + 600 exsr editLoop; 000547 + 601 if not *in12 and elot <> ''; B01 000548 + 602 //* exec sql 000549 + 603 //* insert into perpdemo.item_lot 000550 + 604 //* (company_code, item_number, lot_number, qty_on_hand, received_date, expiry_date) 000551 + 605 //* values (:compcd, :filter, :elot, :eqty, date(:erecv), 000552 + 606 //* case when :eexpd = '' then null else date(:eexpd) end); 000553 + 607 SQL_00043 = COMPCD; //SQL 01 000554 + 608 SQL_00044 = FILTER; //SQL 01 000555 + 609 SQL_00045 = ELOT; //SQL 01 000556 + 610 SQL_00046 = EQTY; //SQL 01 000557 + 611 SQL_00047 = ERECV; //SQL 01 000558 + 612 SQL_00048 = EEXPD; //SQL 01 000559 + 613 SQL_00049 = EEXPD; //SQL 01 000560 + 614 SQLER6 = -4; //SQL 7 01 000561 + 615 SQLROUTE_CALL( //SQL 01 000562 + 616 SQLCA //SQL 01 000563 + 617 : SQL_00038 //SQL 01 000564 + 618 ); //SQL 01 000565 + 619 if sqlcode < 0; B02 000566 + 620 writeMsg('Add failed: SQLCODE=' + %char(sqlcode) 02 000567 + 621 + ' SQLSTATE=' + sqlstate); 02 000568 + 622 else; X02 000569 + 623 writeMsg('Added lot ' + %trim(elot) + '.'); 02 000570 + 624 endif; E02 000571 + 625 holdMsg = *on; 01 000572 + 626 endif; E01 000573 + 627 endsr; 000574 + 628 000575 + 629 // --------------------------------------------------------------------- 000576 + 630 begsr changeRow; 000577 + 631 exsr clearMsgs; 000578 + 632 emode = 'C'; 000579 + 633 elot = slot; 000580 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 16 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 634 eqty = sqty; 000581 + 635 erecv = srecv; 000582 + 636 eexpd = sexpd; 000583 + 637 eactive = 'Y'; 000584 + 638 exsr editLoop; 000585 + 639 if not *in12; B01 000586 + 640 //* exec sql 000587 + 641 //* update perpdemo.item_lot 000588 + 642 //* set qty_on_hand = :eqty, 000589 + 643 //* received_date = date(:erecv), 000590 + 644 //* expiry_date = case when :eexpd = '' then null else date(:eexpd) end, 000591 + 645 //* updated_at = current_timestamp, 000592 + 646 //* updated_by = user 000593 + 647 //* where company_code = :compcd and item_number = :filter and lot_number = :elot; 000594 + 648 SQL_00055 = EQTY; //SQL 01 000595 + 649 SQL_00056 = ERECV; //SQL 01 000596 + 650 SQL_00057 = EEXPD; //SQL 01 000597 + 651 SQL_00058 = EEXPD; //SQL 01 000598 + 652 SQL_00059 = COMPCD; //SQL 01 000599 + 653 SQL_00060 = FILTER; //SQL 01 000600 + 654 SQL_00061 = ELOT; //SQL 01 000601 + 655 SQLER6 = -4; //SQL 8 01 000602 + 656 SQLROUTE_CALL( //SQL 01 000603 + 657 SQLCA //SQL 01 000604 + 658 : SQL_00050 //SQL 01 000605 + 659 ); //SQL 01 000606 + 660 if sqlcode < 0; B02 000607 + 661 writeMsg('Change failed: SQLCODE=' + %char(sqlcode)); 02 000608 + 662 else; X02 000609 + 663 writeMsg('Updated lot ' + %trim(elot) + '.'); 02 000610 + 664 endif; E02 000611 + 665 holdMsg = *on; 01 000612 + 666 endif; E01 000613 + 667 endsr; 000614 + 668 000615 + 669 // --------------------------------------------------------------------- 000616 + 670 begsr deleteRow; 000617 + 671 exsr clearMsgs; 000618 + 672 //* exec sql 000619 + 673 //* delete from perpdemo.item_lot 000620 + 674 //* where company_code = :compcd and item_number = :filter and lot_number = :slot; 000621 + 675 SQL_00067 = COMPCD; //SQL 000622 + 676 SQL_00068 = FILTER; //SQL 000623 + 677 SQL_00069 = SLOT; //SQL 000624 + 678 SQLER6 = -4; //SQL 9 000625 + 679 SQLROUTE_CALL( //SQL 000626 + 680 SQLCA //SQL 000627 + 681 : SQL_00062 //SQL 000628 + 682 ); //SQL 000629 + 683 if sqlcode < 0; B01 000630 + 684 writeMsg('Delete failed: SQLSTATE=' + sqlstate); 01 000631 + 685 else; X01 000632 + 686 writeMsg('Deleted lot ' + %trim(slot) + '.'); 01 000633 + 687 endif; E01 000634 + 688 holdMsg = *on; 000635 + 689 endsr; 000636 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 17 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 690 000637 + 691 // --------------------------------------------------------------------- 000638 + 692 // PERP-84: erecv/eexpd are typed by the user as MM/DD/YY on LTEDIT. 000639 + 693 // Validate on every Enter; on failure, show the error in the message 000640 + 694 // subfile alongside LTEDIT and let the user retry (never crash into 000641 + 695 // the SQL date(:erecv) cast in addRow/changeRow with unparsed text). 000642 + 696 // On success, erecv/eexpd are normalized to ISO ('yyyy-mm-dd') text so 000643 + 697 // the existing date(:erecv)/date(:eexpd) SQL casts in addRow/changeRow 000644 + 698 // keep working unchanged. 000645 + 699 begsr editLoop; 000646 + 700 exsr clearMsgs; 000647 + 701 dow *on; B01 000648 + 702 if msgrrn > 0; B02 000649 + 703 *in40 = *on; 02 000650 + 704 write ltmsgctl; 02 000651 + 705 else; X02 000652 + 706 *in40 = *off; 02 000653 + 707 endif; E02 000654 + 708 exfmt ltedit; 01 000655 + 709 000656 + 710 if *in12; B02 000657 + 711 leave; 02 000658 + 712 endif; E02 000659 + 713 000660 + 714 exsr clearMsgs; 01 000661 + 715 000662 + 716 if %trim(elot) = ''; B02 000663 + 717 writeMsg('Lot Number is required.'); 02 000664 + 718 iter; 02 000665 + 719 endif; E02 000666 + 720 000667 + 721 if %trim(erecv) = ''; B02 000668 + 722 writeMsg('Received Date is required (MM/DD/YY).'); 02 000669 + 723 iter; 02 000670 + 724 endif; E02 000671 + 725 000672 + 726 validRecv = *on; 01 000673 + 727 monitor; B02 000674 + 728 parsedRecv = %date(%trim(erecv):*mdy); 02 000675 + 729 on-error; X02 000676 + 730 validRecv = *off; 02 000677 + 731 endmon; E02 000678 + 732 if not validRecv; B02 000679 + 733 writeMsg('Invalid Received Date - enter as MM/DD/YY.'); 02 000680 + 734 iter; 02 000681 + 735 endif; E02 000682 + 736 000683 + 737 validExpd = *on; 01 000684 + 738 if %trim(eexpd) <> ''; B02 000685 + 739 monitor; B03 000686 + 740 parsedExpd = %date(%trim(eexpd):*mdy); 03 000687 + 741 on-error; X03 000688 + 742 validExpd = *off; 03 000689 + 743 endmon; E03 000690 + 744 endif; E02 000691 + 745 if not validExpd; B02 000692 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 18 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + 746 writeMsg('Invalid Expiry Date - enter as MM/DD/YY, or blank for none.'); 02 000693 + 747 iter; 02 000694 + 748 endif; E02 000695 + 749 000696 + 750 erecv = %char(parsedRecv:*iso); 01 000697 + 751 if %trim(eexpd) <> ''; B02 000698 + 752 eexpd = %char(parsedExpd:*iso); 02 000699 + 753 endif; E02 000700 + 754 000701 + 755 leave; 01 000702 + 756 enddo; E01 000703 + 757 endsr; 000704 + 758 000705 + 759 // --------------------------------------------------------------------- 000706 + 760 begsr clearMsgs; 000707 + 761 msgrrn = 0; 000708 + 762 *in41 = *on; 000709 + 763 write ltmsgctl; 000710 + 764 *in41 = *off; 000711 + 765 endsr; 000712 + 766 000713 + 767 // --------------------------------------------------------------------- 000714 + 768=OLTSFL 9000001 + *--------------------------------------------------------------------------------------------* 9 + * RPG record format . . . . : LTSFL * 9 + * External format . . . . . : LTSFL : PERPDEMO/WRKLOTD * 9 + *--------------------------------------------------------------------------------------------* 9 + 769=O *IN50 2N CHAR 1 9000002 + 770=O *IN51 1N CHAR 1 9000003 + 771=O SOPT 3A CHAR 1 9000004 + 772=O SLOT 23A CHAR 20 9000005 + 773=O SQTY 38S ZONE 15,4 9000006 + 774=O SRECV 48A CHAR 10 9000007 + 775=O SEXPD 58A CHAR 10 9000008 + 776=OLTCTL 10000001 + *--------------------------------------------------------------------------------------------* 10 + * RPG record format . . . . : LTCTL * 10 + * External format . . . . . : LTCTL : PERPDEMO/WRKLOTD * 10 + *--------------------------------------------------------------------------------------------* 10 + 777=O *IN30 2N CHAR 1 10000002 + 778=O *IN31 1N CHAR 1 10000003 + 779=O *IN60 3N CHAR 1 10000004 + 780=O SCOMPDSP 6A CHAR 3 10000005 + 781=O SFITEM 31A CHAR 25 10000006 + 782=O SIOH 46S ZONE 15,4 10000007 + 783=O SLOTTOT 61S ZONE 15,4 10000008 + 784=OLTFOOT 11000001 + *--------------------------------------------------------------------------------------------* 11 + * RPG record format . . . . : LTFOOT * 11 + * External format . . . . . : LTFOOT : PERPDEMO/WRKLOTD * 11 + *--------------------------------------------------------------------------------------------* 11 + 785=OLTNONE 12000001 + *--------------------------------------------------------------------------------------------* 12 + * RPG record format . . . . : LTNONE * 12 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 19 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + * External format . . . . . : LTNONE : PERPDEMO/WRKLOTD * 12 + *--------------------------------------------------------------------------------------------* 12 + 786=OLTNOITEM 13000001 + *--------------------------------------------------------------------------------------------* 13 + * RPG record format . . . . : LTNOITEM * 13 + * External format . . . . . : LTNOITEM : PERPDEMO/WRKLOTD * 13 + *--------------------------------------------------------------------------------------------* 13 + 787=OLTEDIT 14000001 + *--------------------------------------------------------------------------------------------* 14 + * RPG record format . . . . : LTEDIT * 14 + * External format . . . . . : LTEDIT : PERPDEMO/WRKLOTD * 14 + *--------------------------------------------------------------------------------------------* 14 + 788=O EMODE 1A CHAR 1 14000002 + 789=O ELOT 21A CHAR 20 14000003 + 790=O EQTY 36S ZONE 15,4 14000004 + 791=O ERECV 46A CHAR 10 14000005 + 792=O EEXPD 56A CHAR 10 14000006 + 793=O EACTIVE 57A CHAR 1 14000007 + 794=OLTMSGSFL 15000001 + *--------------------------------------------------------------------------------------------* 15 + * RPG record format . . . . : LTMSGSFL * 15 + * External format . . . . . : LTMSGSFL : PERPDEMO/WRKLOTD * 15 + *--------------------------------------------------------------------------------------------* 15 + 795=O SMSGKEY 4A CHAR 4 15000002 + 796=O SPGMQ 14A CHAR 10 15000003 + 797=OLTMSGCTL 16000001 + *--------------------------------------------------------------------------------------------* 16 + * RPG record format . . . . : LTMSGCTL * 16 + * External format . . . . . : LTMSGCTL : PERPDEMO/WRKLOTD * 16 + *--------------------------------------------------------------------------------------------* 16 + 798=O *IN40 2N CHAR 1 16000002 + 799=O *IN41 1N CHAR 1 16000003 + 800 dcl-proc writeMsg; 000715 + 801 dcl-pi *n; 000716 + 802 text varchar(256) const; 000717 + 803 end-pi; 000718 + 804 dcl-s data char(256); 000719 + 805 data = text; 000720 + 806 QMHSNDPM( 000721 + 807 'CPF9897' : 000722 + 808 'QCPFMSG QSYS ' : 000723 + 809 data : 000724 + 810 %len(text) : 000725 + 811 '*INFO ' : 000726 + 812 '* ' : 000727 + 813 1 : 000728 + 814 smsgkey : 000729 + 815 x'0000000000000000'); 000730 + 816 msgrrn += 1; 000731 + 817 spgmq = statusDS.programName; 000732 + 818 write ltmsgsfl; 000733 + 819 end-proc; 000734 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 20 + Line <---------------------- Source Specifications -----------------------------------------------------> Do Change Src Seq + Number ....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....8....+....9....+...10 Num Date Id Number + * * * * * E N D O F S O U R C E * * * * * + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 21 + A d d i t i o n a l D i a g n o s t i c M e s s a g e s + Msg id Sv Number Seq Message text + * * * * * E N D O F A D D I T I O N A L D I A G N O S T I C M E S S A G E S * * * * * + O u t p u t B u f f e r P o s i t i o n s + Line Start End Field or Constant + Number Pos Pos + 769 2 2 *IN50 + 770 1 1 *IN51 + 771 3 3 SOPT + 772 4 23 SLOT + 773 24 38 SQTY + 774 39 48 SRECV + 775 49 58 SEXPD + 769 2 2 *IN50 + 770 1 1 *IN51 + 771 3 3 SOPT + 772 4 23 SLOT + 773 24 38 SQTY + 774 39 48 SRECV + 775 49 58 SEXPD + 777 2 2 *IN30 + 778 1 1 *IN31 + 779 3 3 *IN60 + 780 4 6 SCOMPDSP + 781 7 31 SFITEM + 782 32 46 SIOH + 783 47 61 SLOTTOT + 777 2 2 *IN30 + 778 1 1 *IN31 + 779 3 3 *IN60 + 780 4 6 SCOMPDSP + 781 7 31 SFITEM + 782 32 46 SIOH + 783 47 61 SLOTTOT + 788 1 1 EMODE + 789 2 21 ELOT + 790 22 36 EQTY + 791 37 46 ERECV + 792 47 56 EEXPD + 793 57 57 EACTIVE + 788 1 1 EMODE + 789 2 21 ELOT + 790 22 36 EQTY + 791 37 46 ERECV + 792 47 56 EEXPD + 793 57 57 EACTIVE + 795 1 4 SMSGKEY + 796 5 14 SPGMQ + 795 1 4 SMSGKEY + 796 5 14 SPGMQ + 798 2 2 *IN40 + 799 1 1 *IN41 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 22 + 798 2 2 *IN40 + 799 1 1 *IN41 + * * * * * E N D O F O U T P U T B U F F E R P O S I T I O N * * * * * + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 23 + C r o s s R e f e r e n c e + File and Record References: + File Device References (D=Defined) + Record + WRKLOTD WORKSTN 28D 421 578 + LTSFL 28D 249 420 428 + 571 577 768 + LTCTL 28D 259 333 375 + 560 776 + LTFOOT 28D 265 326 368 + 784 + LTNONE 28D 270 361 785 + LTNOITEM 28D 275 325 355 + 786 + LTEDIT 28D 280 708 787 + LTMSGSFL 28D 290 794 818 + LTMSGCTL 28D 297 329 371 + 704 763 797 + Global Field References: + Field Attributes References (D=Defined M=Modified) + *INLR N(1) 434M + *IN03 N(1) 250D 260M 266M 271M + 276M 281M 291M 298M + 322 377 + *IN05 N(1) 251D 261M 267M 272M + 277M 282M 292M 299M + 381 + *IN06 N(1) 252D 262M 268M 273M + 278M 283M 293M 300M + 386 + *IN12 N(1) 253D 263M 269M 274M + 279M 284M 294M 301M + 322 377 601 639 + 710 + *IN30 N(1) 324M 350M 360M 364M + 777 + *IN31 N(1) 559M 561M 778 + *IN40 N(1) 328M 331M 370M 373M + 703M 706M 798 + *IN41 N(1) 762M 764M 799 + *IN50 N(1) 563M 769 + *IN51 N(1) 564M 770 + *IN60 N(1) 351M 473M 475M 779 + ADDROW BEGSR 392 592D + CALLITMPRMT PROTOTYPE 48D 401M + CHANGEROW BEGSR 581 630D + CLEARMSGS BEGSR 318 346 593 631 + 671 700 714 760D + COMPCD A(3) 73D 303M 306M 308 + 317 323 401 443 + 460 502 607 652 + 675 + DELETEROW BEGSR 583 670D + EACTIVE A(1) 289M 599M 637M 793 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 24 + EDITLOOP BEGSR 600 638 699D + EEXPD A(10) 288M 598M 612 613 + 636M 650 651 738 + 740 751 752M 792 + ELOT A(20) 285M 595M 601 609 + 623 633M 654 663 + 716 789 + EMODE A(1) 594M 632M 788 + EQTY P(15,4) 286M 596M 610 634M + 648 790 + ERECV A(10) 287M 597M 611 635M + 649 721 728 750M + 791 + FILLSUBFILE BEGSR 363 557D + FILTER A(25) 72D 309M 311M 349 + VARYING(2) 382M 391M 403M 408 + 409M 444 461 503 + 608 653 676 + HANDLEOPT BEGSR 425 576D + HOLDMSG N(1) 77D 343 344M 389M + 586M 625M 665M 688M + I I(10,0) 66D 562 566 567 + 568 569 + ITEMOH P(15,4) 74D 451M 454M 470 + 472 + LDADS DS(1024) 30D 302 303 + COMPCD A(3) 31D 303 + LOADBALANCES BEGSR 357 438D + LOADROWS BEGSR 358 480D + LOTTOTAL P(15,4) 75D 468M 471 472 + LTROW DS(54) 57D 64 530M 531M + 532M 533M 539 + EXPD A(10) 61D 533 + VARYING(2) + LOT A(20) 58D 530 + VARYING(2) + QTY P(15,4) 59D 531 + RECV A(10) 60D 532 + VARYING(2) + *RNF7031 MSGKEY A(4) 69D + MSGRRN I(10,0) 28 68D 327 369 + 702 761M 816M + NUMROWS I(10,0) 65D 352M 359 417 + 481M 522 538M 539 + 562 + PARSEDEXPD D(10*ISO-) 86D 740M 752 + PARSEDRECV D(10*ISO-) 85D 728M 750 + PCOMPCD A(3) 24D 305 306 + BASED(_QRNL_PRM+) + PITEM A(25) 25D 310 311 312 + BASED(_QRNL_PRM+) + VARYING(2) + PROMPTITEM A(25) 76D 400M 401 402 + VARYING(2) 403 + QMHSNDPM PROTOTYPE 34D 806M + ROWS(500) DS(54) 64D 522 539M 566 + 567 568 569 + EXPD A(10) 569 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 25 + VARYING(2) + LOT A(20) 566 + VARYING(2) + QTY P(15,4) 567 + RECV A(10) 568 + VARYING(2) + RRN I(10,0) 28 67D 423 558M + 570M + SCOMPDSP A(3) 308M 780 + SELOPT A(1) 71D 419M 424M 580 + 582 585 + SELRRN I(10,0) 70D 418M 423M 426M + 577 + SEXPD A(10) 258M 569M 636 775 + SFITEM A(25) 264M 312M 314M 382 + 387 391 399 400 + 402M 408 409 781 + SIOH P(15,4) 353M 470M 782 + SLOT A(20) 255M 566M 633 677 + 686 772 + SLOTTOT P(15,4) 354M 471M 783 + SMSGKEY A(4) 295M 795 814 + SOPT A(1) 254M 422 424 565M + 771 + SPGMQ A(10) 296M 796 817M + *RNF7031 SQFAPP CONST 154D + *RNF7031 SQFCRT CONST 152D + *RNF7031 SQFOVR CONST 153D + *RNF7031 SQFRD CONST 151D + SQL_00000 B(4,0) 157D 448 + *RNF7031 SQL_00001 B(4,0) 158D + *RNF7031 SQL_00002 U(10,0) 159D + SQL_00003 A(1) 160D 450 + *RNF7031 SQL_00004 A(119) 161D + SQL_00005 A(3) 162D 443M + SQL_00006 A(25) 163D 444M + VARYING(2) + SQL_00007 P(15,4) 164D 451 + SQL_00008 B(4,0) 168D 465 + *RNF7031 SQL_00009 B(4,0) 169D + *RNF7031 SQL_00010 U(10,0) 170D + SQL_00011 A(1) 171D 467 + *RNF7031 SQL_00012 A(119) 172D + SQL_00013 A(3) 173D 460M + SQL_00014 A(25) 174D 461M + VARYING(2) + SQL_00015 P(15,4) 175D 468 + SQL_00016 B(4,0) 179D 509 514 + *RNF7031 SQL_00017 B(4,0) 180D + SQL_00018 U(10,0) 181D 505 + SQL_00019 A(1) 182D 506 + *RNF7031 SQL_00020 A(119) 183D + SQL_00021 A(3) 184D 502M + SQL_00022 A(25) 185D 503M + VARYING(2) + SQL_00023 B(4,0) 189D 527 + *RNF7031 SQL_00024 B(4,0) 190D + *RNF7031 SQL_00025 U(10,0) 191D + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 26 + SQL_00026 A(1) 192D 529 + *RNF7031 SQL_00027 A(119) 193D + SQL_00028 A(20) 194D 530 + VARYING(2) + SQL_00029 P(15,4) 195D 531 + SQL_00030 A(10) 196D 532 + VARYING(2) + SQL_00031 A(10) 197D 533 + VARYING(2) + SQL_00032 B(4,0) 201D 546 551 + *RNF7031 SQL_00033 B(4,0) 202D + SQL_00034 U(10,0) 203D 543 + *RNF7031 SQL_00035 A(1) 204D + *RNF7031 SQL_00036 A(118) 205D + *RNF7031 SQL_00037 A(1) 206D + SQL_00038 B(4,0) 210D 617 + *RNF7031 SQL_00039 B(4,0) 211D + *RNF7031 SQL_00040 U(10,0) 212D + *RNF7031 SQL_00041 A(1) 213D + *RNF7031 SQL_00042 A(118) 214D + SQL_00043 A(3) 215D 607M + SQL_00044 A(25) 216D 608M + VARYING(2) + SQL_00045 A(20) 217D 609M + SQL_00046 P(15,4) 218D 610M + SQL_00047 A(10) 219D 611M + SQL_00048 A(10) 220D 612M + SQL_00049 A(10) 221D 613M + SQL_00050 B(4,0) 225D 658 + *RNF7031 SQL_00051 B(4,0) 226D + *RNF7031 SQL_00052 U(10,0) 227D + *RNF7031 SQL_00053 A(1) 228D + *RNF7031 SQL_00054 A(118) 229D + SQL_00055 P(15,4) 230D 648M + SQL_00056 A(10) 231D 649M + SQL_00057 A(10) 232D 650M + SQL_00058 A(10) 233D 651M + SQL_00059 A(3) 234D 652M + SQL_00060 A(25) 235D 653M + VARYING(2) + SQL_00061 A(20) 236D 654M + SQL_00062 B(4,0) 240D 681 + *RNF7031 SQL_00063 B(4,0) 241D + *RNF7031 SQL_00064 U(10,0) 242D + *RNF7031 SQL_00065 A(1) 243D + *RNF7031 SQL_00066 A(118) 244D + SQL_00067 A(3) 245D 675M + SQL_00068 A(25) 246D 676M + VARYING(2) + SQL_00069 A(20) 247D 677M + *RNF7031 SQLABC B(9,0) 96D + *RNF7031 SQLAID A(8) 94D + SQLCA DS(136) 92D 130 135 139 + 143 447 464 508 + 513 526 545 550 + 616 657 680 + SQLCABC I(10,0) 95D 96 + SQLCAID A(8) 93D 94 + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 27 + SQLCLSE CONST 138 149D + SQLCLSE_CALL PROTOTYPE 138D 549M + SQLCMIT CONST 142 150D + *RNF7031 SQLCMIT_CALL PROTOTYPE 142D + *RNF7031 SQLCOD B(9,0) 98D + SQLCODE I(10,0) 97D 98 453 517 + 518 535 535 619 + 620 660 661 683 + *RNF7031 SQLERL B(4,0) 100D + *RNF7031 SQLERM A(70) 102D + *RNF7031 SQLERP A(8) 104D + SQLERR A(24) 105D 106 107 108 + 109 110 111 112 + *RNF7031 SQLERRD(6) I(10,0) 112D + SQLERRMC A(70) 101D 102 + SQLERRML I(5,0) 99D 100 + SQLERRP A(8) 103D 104 + *RNF7031 SQLER1 B(9,0) 106D + *RNF7031 SQLER2 B(9,0) 107D + *RNF7031 SQLER3 B(9,0) 108D + *RNF7031 SQLER4 B(9,0) 109D + *RNF7031 SQLER5 B(9,0) 110D + SQLER6 B(9,0) 111D 445M 462M 504M + 524M 542M 614M 655M + 678M + SQLOPEN CONST 134 148D + SQLOPEN_CALL PROTOTYPE 134D 512M + SQLROUTE CONST 129 147D + SQLROUTE_CALL PROTOTYPE 129D 446M 463M 507M + 525M 544M 615M 656M + 679M + SQLSTATE A(5) 126D 127 621 684 + *RNF7031 SQLSTT A(5) 127D + *RNF7031 SQLWARN(11) A(1) 125D + *RNF7031 SQLWNA A(1) 124D + *RNF7031 SQLWN0 A(1) 114D + *RNF7031 SQLWN1 A(1) 115D + *RNF7031 SQLWN2 A(1) 116D + *RNF7031 SQLWN3 A(1) 117D + *RNF7031 SQLWN4 A(1) 118D + *RNF7031 SQLWN5 A(1) 119D + *RNF7031 SQLWN6 A(1) 120D + *RNF7031 SQLWN7 A(1) 121D + *RNF7031 SQLWN8 A(1) 122D + *RNF7031 SQLWN9 A(1) 123D + SQLWRN A(11) 113D 114 115 116 + 117 118 119 120 + 121 122 123 124 + 125 + SQTY P(15,4) 256M 567M 634 773 + SRECV A(10) 257M 568M 635 774 + STATUSDS DS(343) 53D 817 + PROGRAMNAME A(10) 54D 817 + VALIDEXPD N(1) 88D 737M 742M 745 + VALIDRECV N(1) 87D 726M 730M 732 + WRITEMSG PROTOTYPE 319M 388M 518M 585M + 620M 623M 661M 663M + 684M 686M 717M 722M + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 28 + 733M 746M 800 + Field References for subprocedure WRITEMSG + Field Attributes References (D=Defined M=Modified) + DATA A(256) 804D 805M 809 + TEXT A(256) 802D 805 810 + BASED(_QRNL_PST+) + VARYING(2) + Indicator References: + Indicator References (D=Defined M=Modified) + 03 250M 260M 266M 271M + 276M 281M 291M 298M + 322 377 + 05 251M 261M 267M 272M + 277M 282M 292M 299M + 381 + 06 252M 262M 268M 273M + 278M 283M 293M 300M + 386 + 12 253M 263M 269M 274M + 279M 284M 294M 301M + 322 377 601 639 + 710 + 30 324M 350M 360M 364M + 777 + 31 559M 561M 778 + 40 328M 331M 370M 373M + 703M 706M 798 + 41 762M 764M 799 + 50 563M 769 + 51 564M 770 + 60 351M 473M 475M 779 + LR 434M + * * * * * E N D O F C R O S S R E F E R E N C E * * * * * + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 29 + E x t e r n a l R e f e r e n c e s + Statically bound procedures: + Procedure References + Imported fields: + Field Attributes Defined + No references in the source. + Exported fields: + Field Attributes Defined + No references in the source. + * * * * * E N D O F E X T E R N A L R E F E R E N C E S * * * * * + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 30 + M e s s a g e S u m m a r y + Msg id Sv Number Message text + *RNF7031 00 58 The name or indicator is not referenced. + * * * * * E N D O F M E S S A G E S U M M A R Y * * * * * + 5770WDS V7R5M0 220415 RN IBM ILE RPG PERPDEMO/WRKLOTR IDEV 08/26/26 16:51:50 Page 31 + F i n a l S u m m a r y + Message Totals: + Information (00) . . . . . . . : 58 + Warning (10) . . . . . . . : 0 + Error (20) . . . . . . . : 0 + Severe Error (30+) . . . . . . : 0 + --------------------------------- ------- + Total . . . . . . . . . . . . . : 58 + Source Totals: + Records . . . . . . . . . . . . : 819 + Specifications . . . . . . . . : 651 + Data records . . . . . . . . . : 0 + Comments . . . . . . . . . . . : 147 + * * * * * E N D O F F I N A L S U M M A R Y * * * * * + Program WRKLOTR placed in library PERPDEMO. 00 highest severity. Created on 08/26/26 at 16:51:51. + * * * * * E N D O F C O M P I L A T I O N * * * * *