COBOLソース出力結果
こちらの記事は、メイン記事「IBM Bobを使用した受注データプログラムと仕様書の作成（COBOL ILE + CL）」の付属記事になります。
メイン記事はこちらを参照ください。
IBM Bobで初回出力結果
ORDPGM.CBL(初回)
ORDPGM.CBL(初回)
*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
* プログラム名 : ORDPGM
* 名称 : 受注データ入力プログラム
* 作成日 : 2025/01/01
* 概要 : 受注ヘッダ・明細の入力/照会/更新/削除
*
* 使用ファイル :
* ORDDSP - 受注入力画面ファイル (DSPF)
* ORDHDR - 受注ヘッダファイル (PF)
* ORDDTL - 受注明細ファイル (PF)
* CUSTMST - 得意先マスタ (PF)
* EMPMST - 社員マスタ (PF)
* ITMMST - 品目マスタ (PF)
*
* ファンクションキー :
* F3 = プログラム終了
* F5 = 受注データ照会
* F6 = 新規受注登録
* F8 = 明細行追加 (次頁)
* F10 = 受注データ削除
* F12 = 取消（前画面へ）
* Enter = 登録/更新確定
*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
IDENTIFICATION DIVISION.
PROGRAM-ID. ORDPGM.
AUTHOR. SYSTEM.
DATE-WRITTEN. 2025-01-01.
*----------------------------------------------------------
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-AS400.
OBJECT-COMPUTER. IBM-AS400.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
*--- 受注入力画面ファイル
SELECT ORDDSP ASSIGN TO WORKSTATION-ORDDSP
ORGANIZATION IS TRANSACTION.
*--- 受注ヘッダファイル
SELECT ORDHDR ASSIGN TO DATABASE-ORDHDR
ORGANIZATION IS INDEXED
ACCESS MODE IS DYNAMIC
RECORD KEY IS HD-ORDNO
FILE STATUS IS WS-HDRSTS.
*--- 受注明細ファイル
SELECT ORDDTL ASSIGN TO DATABASE-ORDDTL
ORGANIZATION IS INDEXED
ACCESS MODE IS DYNAMIC
RECORD KEY IS DT-ORDNO
FILE STATUS IS WS-DTLSTS.
*--- 得意先マスタファイル
SELECT CUSTMST ASSIGN TO DATABASE-CUSTMST
ORGANIZATION IS INDEXED
ACCESS MODE IS RANDOM
RECORD KEY IS CS-CUSCD
FILE STATUS IS WS-CUSSTS.
*--- 品目マスタファイル
SELECT ITMMST ASSIGN TO DATABASE-ITMMST
ORGANIZATION IS INDEXED
ACCESS MODE IS RANDOM
RECORD KEY IS IT-ITMCD
FILE STATUS IS WS-ITMSTS.
*----------------------------------------------------------
DATA DIVISION.
FILE SECTION.
*--- 受注入力画面ファイル -----------------------------------
FD ORDDSP.
01 ORDDSP-REC.
COPY DDS-ALL-FORMATS OF ORDDSP.
*--- 受注ヘッダファイル ------------------------------------
FD ORDHDR.
01 ORDHDR-REC.
05 HD-ORDNO PIC X(7). *> 受注番号
05 HD-ORDDAT PIC X(8). *> 受注日
05 HD-CUSCD PIC X(6). *> 得意先コード
05 HD-EMPCD PIC X(4). *> 担当者コード
05 HD-DLVADR PIC X(30). *> 納品先
05 HD-DUEDAT PIC X(8). *> 納期
05 HD-RMRK PIC X(40). *> 備考
05 HD-ORDSTS PIC X(1). *> 受注状態
88 HD-STS-NYURYOKU VALUE '0'. *> 入力中
88 HD-STS-KAKUNIN VALUE '1'. *> 確認済
88 HD-STS-JYUCHU VALUE '2'. *> 受注済
88 HD-STS-CANCEL VALUE '9'. *> キャンセル
05 HD-REGDAT PIC X(8). *> 登録日
05 HD-REGUSR PIC X(10). *> 登録者
05 HD-UPDDAT PIC X(8). *> 更新日
05 HD-UPDUSR PIC X(10). *> 更新者
*--- 受注明細ファイル --------------------------------------
FD ORDDTL.
01 ORDDTL-REC.
05 DT-ORDNO PIC X(7). *> 受注番号
05 DT-DTLNO PIC 9(2). *> 明細行番号
05 DT-ITMCD PIC X(8). *> 品目コード
05 DT-QTY PIC 9(5)V99. *> 数量
05 DT-UPR PIC 9(9)V99. *> 単価
05 DT-AMT PIC 9(11)V99. *> 金額
05 DT-TAX PIC 9(9)V99. *> 消費税
*--- 得意先マスタファイル ----------------------------------
FD CUSTMST.
01 CUSTMST-REC.
05 CS-CUSCD PIC X(6). *> 得意先コード
05 CS-CUSNM PIC X(20). *> 得意先名
05 CS-ADDR PIC X(40). *> 住所
05 CS-TEL PIC X(13). *> 電話番号
*--- 品目マスタファイル ------------------------------------
FD ITMMST.
01 ITMMST-REC.
05 IT-ITMCD PIC X(8). *> 品目コード
05 IT-ITMNM PIC X(20). *> 品目名称
05 IT-STDPRC PIC 9(9)V99. *> 標準単価
05 IT-UNIT PIC X(5). *> 単位
*----------------------------------------------------------
WORKING-STORAGE SECTION.
*--- プログラム制御フラグ -----------------------------------
01 WS-FLAGS.
05 WS-END-FLG PIC X(1) VALUE 'N'.
88 WS-END VALUE 'Y'.
88 WS-CONTINUE VALUE 'N'.
05 WS-MODE PIC X(1) VALUE SPACE.
88 WS-MODE-HEADER VALUE 'H'. *> ヘッダ画面
88 WS-MODE-DETAIL VALUE 'D'. *> 明細画面
88 WS-MODE-NEW VALUE 'N'. *> 新規入力
88 WS-MODE-UPD VALUE 'U'. *> 更新
88 WS-MODE-INQ VALUE 'I'. *> 照会
05 WS-EXIST-FLG PIC X(1) VALUE 'N'.
88 WS-EXISTS VALUE 'Y'.
88 WS-NOT-EXISTS VALUE 'N'.
*--- ファイルステータス ------------------------------------
01 WS-FILE-STATUS.
05 WS-HDRSTS PIC X(2) VALUE SPACES.
05 WS-DTLSTS PIC X(2) VALUE SPACES.
05 WS-CUSSTS PIC X(2) VALUE SPACES.
05 WS-ITMSTS PIC X(2) VALUE SPACES.
*--- ファンクションキー判定 ---------------------------------
01 WS-FKEY.
05 WS-FK03 PIC X(1) VALUE 'N'.
88 WS-F03 VALUE 'Y'.
05 WS-FK05 PIC X(1) VALUE 'N'.
88 WS-F05 VALUE 'Y'.
05 WS-FK06 PIC X(1) VALUE 'N'.
88 WS-F06 VALUE 'Y'.
05 WS-FK08 PIC X(1) VALUE 'N'.
88 WS-F08 VALUE 'Y'.
05 WS-FK10 PIC X(1) VALUE 'N'.
88 WS-F10 VALUE 'Y'.
05 WS-FK12 PIC X(1) VALUE 'N'.
88 WS-F12 VALUE 'Y'.
*--- 消費税率 -----------------------------------------------
01 WS-TAX-RATE PIC V99 VALUE .10.
*--- 明細最大行数 -------------------------------------------
01 WS-MAX-DTL PIC 9(2) VALUE 05.
01 WS-DTL-CNT PIC 9(2) VALUE ZERO.
*--- 日付・時刻 --------------------------------------------
01 WS-TODAY PIC X(8).
01 WS-SYSUSER PIC X(10).
*--- メッセージ定義 ----------------------------------------
01 WS-MESSAGES.
05 MSG-NORMAL PIC X(79)
VALUE '正常に処理されました。'.
05 MSG-NOT-FOUND PIC X(79)
VALUE '受注番号が見つかりません。受注番号を確認してください。'.
05 MSG-ALREADY-EXISTS PIC X(79)
VALUE 'この受注番号はすでに登録されています。'.
05 MSG-ORDNO-REQ PIC X(79)
VALUE '受注番号を入力してください。'.
05 MSG-CUSCD-REQ PIC X(79)
VALUE '得意先コードを入力してください。'.
05 MSG-CUSCD-ERR PIC X(79)
VALUE '得意先コードが存在しません。正しいコードを入力してください。'.
05 MSG-ORDDAT-ERR PIC X(79)
VALUE '受注日の形式が正しくありません。(YYYYMMDD)'.
05 MSG-ITMCD-ERR PIC X(79)
VALUE '品目コードが存在しません。正しいコードを入力してください。'.
05 MSG-QTY-ERR PIC X(79)
VALUE '数量に0以下の値は設定できません。'.
05 MSG-DELETE-CONF PIC X(79)
VALUE '削除してもよいですか？ F4=確定 F12=取消'.
05 MSG-DELETED PIC X(79)
VALUE '受注データを削除しました。'.
05 MSG-SAVED PIC X(79)
VALUE '受注データを登録しました。'.
05 MSG-UPDATED PIC X(79)
VALUE '受注データを更新しました。'.
05 MSG-IO-ERROR PIC X(79)
VALUE 'ファイル入出力エラーが発生しました。システム管理者に連絡してください。'.
*--- 作業変数 -----------------------------------------------
01 WS-WORK.
05 WS-IDX PIC 9(2) VALUE ZERO.
05 WS-SUBTOT PIC 9(11)V99 VALUE ZERO.
05 WS-TAXTOT PIC 9(9)V99 VALUE ZERO.
05 WS-GRANDTL PIC 9(12)V99 VALUE ZERO.
05 WS-CONFIRM PIC X(1) VALUE 'N'.
*--- 画面フィールド作業域（ORDDET用）-----------------------
01 WS-SCREEN.
05 WS-ORDNO PIC X(7).
05 WS-ORDDAT PIC X(8).
05 WS-CUSCD PIC X(6).
05 WS-CUSNM PIC X(20).
05 WS-EMPCD PIC X(4).
05 WS-EMPNM PIC X(12).
05 WS-DLVADR PIC X(30).
05 WS-DUEDAT PIC X(8).
05 WS-RMRK PIC X(40).
05 WS-ORDSTS PIC X(1).
05 WS-ORDSTNM PIC X(8).
05 WS-MSGLIN PIC X(79).
*--- 明細行 (5行分) ---
05 WS-DTL-LINE OCCURS 5 TIMES INDEXED BY DL-IDX.
10 WS-ITMCD PIC X(8).
10 WS-ITMNM PIC X(20).
10 WS-QTY PIC 9(5)V99.
10 WS-UPR PIC 9(9)V99.
10 WS-AMT PIC 9(11)V99.
10 WS-TAX PIC 9(9)V99.
*----------------------------------------------------------
PROCEDURE DIVISION.
*==========================================================
* メイン制御
*==========================================================
0000-MAIN.
PERFORM 9000-OPEN-FILES.
PERFORM 9100-INIT-SCREEN.
MOVE 'H' TO WS-MODE.
PERFORM UNTIL WS-END
EVALUATE TRUE
WHEN WS-MODE-HEADER
PERFORM 1000-HEADER-PROCESS
WHEN WS-MODE-DETAIL
PERFORM 2000-DETAIL-PROCESS
WHEN OTHER
MOVE 'Y' TO WS-END-FLG
END-EVALUATE
END-PERFORM.
PERFORM 9900-CLOSE-FILES.
STOP RUN.
*==========================================================
* 1000-HEADER-PROCESS : ヘッダ画面処理
*==========================================================
1000-HEADER-PROCESS.
PERFORM 1100-DISP-HEADER.
PERFORM 1200-RECV-HEADER.
EVALUATE TRUE
WHEN WS-F03
MOVE 'Y' TO WS-END-FLG
WHEN WS-F05
PERFORM 1300-INQUIRY
WHEN WS-F06
PERFORM 1400-NEW-ORDER
WHEN OTHER
MOVE MSG-ORDNO-REQ TO WS-MSGLIN
END-EVALUATE.
1100-DISP-HEADER.
MOVE SPACES TO ORDDSP-REC.
MOVE WS-MSGLIN TO MSGLIN OF HEADER.
WRITE ORDDSP-REC FORMAT IS 'HEADER'.
MOVE SPACES TO WS-MSGLIN.
1200-RECV-HEADER.
MOVE 'N' TO WS-FK03 WS-FK05 WS-FK06 WS-FK10 WS-FK12.
READ ORDDSP-REC FORMAT IS 'HEADER'.
MOVE ORDNO OF HEADER TO WS-ORDNO.
IF IND(03) = '1' THEN MOVE 'Y' TO WS-FK03 END-IF.
IF IND(05) = '1' THEN MOVE 'Y' TO WS-FK05 END-IF.
IF IND(06) = '1' THEN MOVE 'Y' TO WS-FK06 END-IF.
IF IND(12) = '1' THEN MOVE 'Y' TO WS-FK12 END-IF.
1300-INQUIRY.
IF WS-ORDNO = SPACES
MOVE MSG-ORDNO-REQ TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
MOVE WS-ORDNO TO HD-ORDNO.
READ ORDHDR INTO ORDHDR-REC KEY IS HD-ORDNO
INVALID KEY
MOVE MSG-NOT-FOUND TO WS-MSGLIN
EXIT PARAGRAPH
END-READ.
PERFORM 8100-LOAD-SCREEN-FROM-HDR.
PERFORM 8200-LOAD-DTL-FROM-FILE.
MOVE 'I' TO WS-MODE.
MOVE 'D' TO WS-MODE.
1400-NEW-ORDER.
PERFORM 9100-INIT-SCREEN.
PERFORM 8300-GET-TODAY.
MOVE WS-TODAY TO WS-ORDDAT.
MOVE 'N' TO WS-MODE.
MOVE 'D' TO WS-MODE.
*==========================================================
* 2000-DETAIL-PROCESS : 明細画面処理
*==========================================================
2000-DETAIL-PROCESS.
PERFORM 2100-CALC-TOTALS.
PERFORM 2200-DISP-DETAIL.
PERFORM 2300-RECV-DETAIL.
EVALUATE TRUE
WHEN WS-F03
MOVE 'Y' TO WS-END-FLG
WHEN WS-F05
MOVE 'H' TO WS-MODE
WHEN WS-F10
PERFORM 2600-DELETE-ORDER
WHEN WS-F12
MOVE 'H' TO WS-MODE
PERFORM 9100-INIT-SCREEN
WHEN OTHER
PERFORM 2400-VALIDATE-INPUT
IF WS-MSGLIN = SPACES
PERFORM 2500-SAVE-ORDER
END-IF
END-EVALUATE.
2100-CALC-TOTALS.
MOVE ZERO TO WS-SUBTOT WS-TAXTOT WS-GRANDTL.
PERFORM VARYING DL-IDX FROM 1 BY 1
UNTIL DL-IDX > WS-MAX-DTL
IF WS-ITMCD(DL-IDX) NOT = SPACES
COMPUTE WS-AMT(DL-IDX) =
WS-QTY(DL-IDX) * WS-UPR(DL-IDX)
COMPUTE WS-TAX(DL-IDX) =
WS-AMT(DL-IDX) * WS-TAX-RATE
ADD WS-AMT(DL-IDX) TO WS-SUBTOT
ADD WS-TAX(DL-IDX) TO WS-TAXTOT
END-IF
END-PERFORM.
COMPUTE WS-GRANDTL = WS-SUBTOT + WS-TAXTOT.
2200-DISP-DETAIL.
MOVE SPACES TO ORDDSP-REC.
*--- ヘッダ項目の設定 ---
MOVE WS-ORDNO TO ORDNO OF ORDDET.
MOVE WS-ORDDAT TO ORDDAT OF ORDDET.
MOVE WS-CUSCD TO CUSCD OF ORDDET.
MOVE WS-CUSNM TO CUSNM OF ORDDET.
MOVE WS-EMPCD TO EMPCD OF ORDDET.
MOVE WS-EMPNM TO EMPNM OF ORDDET.
MOVE WS-DLVADR TO DLVADR OF ORDDET.
MOVE WS-DUEDAT TO DUEDAT OF ORDDET.
MOVE WS-RMRK TO RMRK OF ORDDET.
MOVE WS-ORDSTS TO ORDSTS OF ORDDET.
MOVE WS-ORDSTNM TO ORDSTNM OF ORDDET.
*--- 明細行の設定 ---
MOVE WS-ITMCD(1) TO ITMCD1 OF ORDDET.
MOVE WS-ITMNM(1) TO ITMNM1 OF ORDDET.
MOVE WS-QTY(1) TO QTY1 OF ORDDET.
MOVE WS-UPR(1) TO UPR1 OF ORDDET.
MOVE WS-AMT(1) TO AMT1 OF ORDDET.
MOVE WS-TAX(1) TO TAX1 OF ORDDET.
MOVE WS-ITMCD(2) TO ITMCD2 OF ORDDET.
MOVE WS-ITMNM(2) TO ITMNM2 OF ORDDET.
MOVE WS-QTY(2) TO QTY2 OF ORDDET.
MOVE WS-UPR(2) TO UPR2 OF ORDDET.
MOVE WS-AMT(2) TO AMT2 OF ORDDET.
MOVE WS-TAX(2) TO TAX2 OF ORDDET.
MOVE WS-ITMCD(3) TO ITMCD3 OF ORDDET.
MOVE WS-ITMNM(3) TO ITMNM3 OF ORDDET.
MOVE WS-QTY(3) TO QTY3 OF ORDDET.
MOVE WS-UPR(3) TO UPR3 OF ORDDET.
MOVE WS-AMT(3) TO AMT3 OF ORDDET.
MOVE WS-TAX(3) TO TAX3 OF ORDDET.
MOVE WS-ITMCD(4) TO ITMCD4 OF ORDDET.
MOVE WS-ITMNM(4) TO ITMNM4 OF ORDDET.
MOVE WS-QTY(4) TO QTY4 OF ORDDET.
MOVE WS-UPR(4) TO UPR4 OF ORDDET.
MOVE WS-AMT(4) TO AMT4 OF ORDDET.
MOVE WS-TAX(4) TO TAX4 OF ORDDET.
MOVE WS-ITMCD(5) TO ITMCD5 OF ORDDET.
MOVE WS-ITMNM(5) TO ITMNM5 OF ORDDET.
MOVE WS-QTY(5) TO QTY5 OF ORDDET.
MOVE WS-UPR(5) TO UPR5 OF ORDDET.
MOVE WS-AMT(5) TO AMT5 OF ORDDET.
MOVE WS-TAX(5) TO TAX5 OF ORDDET.
*--- 合計の設定 ---
MOVE WS-SUBTOT TO SUBTOT OF ORDDET.
MOVE WS-TAXTOT TO TAXTOT OF ORDDET.
MOVE WS-GRANDTL TO GRANDTL OF ORDDET.
MOVE WS-MSGLIN TO MSGLIN OF ORDDET.
WRITE ORDDSP-REC FORMAT IS 'ORDDET'.
MOVE SPACES TO WS-MSGLIN.
2300-RECV-DETAIL.
MOVE 'N' TO WS-FK03 WS-FK05 WS-FK06 WS-FK08
WS-FK10 WS-FK12.
READ ORDDSP-REC FORMAT IS 'ORDDET'.
*--- ファンクションキーインジケータ取得 ---
IF IND(03) = '1' THEN MOVE 'Y' TO WS-FK03 END-IF.
IF IND(05) = '1' THEN MOVE 'Y' TO WS-FK05 END-IF.
IF IND(06) = '1' THEN MOVE 'Y' TO WS-FK06 END-IF.
IF IND(08) = '1' THEN MOVE 'Y' TO WS-FK08 END-IF.
IF IND(10) = '1' THEN MOVE 'Y' TO WS-FK10 END-IF.
IF IND(12) = '1' THEN MOVE 'Y' TO WS-FK12 END-IF.
*--- 入力値を作業域へ取込 ---
MOVE ORDNO OF ORDDET TO WS-ORDNO.
MOVE ORDDAT OF ORDDET TO WS-ORDDAT.
MOVE CUSCD OF ORDDET TO WS-CUSCD.
MOVE EMPCD OF ORDDET TO WS-EMPCD.
MOVE DLVADR OF ORDDET TO WS-DLVADR.
MOVE DUEDAT OF ORDDET TO WS-DUEDAT.
MOVE RMRK OF ORDDET TO WS-RMRK.
MOVE ITMCD1 OF ORDDET TO WS-ITMCD(1).
MOVE QTY1 OF ORDDET TO WS-QTY(1).
MOVE UPR1 OF ORDDET TO WS-UPR(1).
MOVE ITMCD2 OF ORDDET TO WS-ITMCD(2).
MOVE QTY2 OF ORDDET TO WS-QTY(2).
MOVE UPR2 OF ORDDET TO WS-UPR(2).
MOVE ITMCD3 OF ORDDET TO WS-ITMCD(3).
MOVE QTY3 OF ORDDET TO WS-QTY(3).
MOVE UPR3 OF ORDDET TO WS-UPR(3).
MOVE ITMCD4 OF ORDDET TO WS-ITMCD(4).
MOVE QTY4 OF ORDDET TO WS-QTY(4).
MOVE UPR4 OF ORDDET TO WS-UPR(4).
MOVE ITMCD5 OF ORDDET TO WS-ITMCD(5).
MOVE QTY5 OF ORDDET TO WS-QTY(5).
MOVE UPR5 OF ORDDET TO WS-UPR(5).
2400-VALIDATE-INPUT.
MOVE SPACES TO WS-MSGLIN.
*--- 受注番号 必須チェック ---
IF WS-ORDNO = SPACES
MOVE MSG-ORDNO-REQ TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
*--- 受注日 形式チェック (数字8桁) ---
IF WS-ORDDAT NOT NUMERIC
MOVE MSG-ORDDAT-ERR TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
*--- 得意先コード 必須・存在チェック ---
IF WS-CUSCD = SPACES
MOVE MSG-CUSCD-REQ TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
MOVE WS-CUSCD TO CS-CUSCD.
READ CUSTMST INTO CUSTMST-REC KEY IS CS-CUSCD
INVALID KEY
MOVE MSG-CUSCD-ERR TO WS-MSGLIN
EXIT PARAGRAPH
END-READ.
MOVE CS-CUSNM TO WS-CUSNM.
*--- 明細チェック ---
PERFORM VARYING DL-IDX FROM 1 BY 1
UNTIL DL-IDX > WS-MAX-DTL
IF WS-ITMCD(DL-IDX) NOT = SPACES
*--- 品目コード存在チェック ---
MOVE WS-ITMCD(DL-IDX) TO IT-ITMCD
READ ITMMST INTO ITMMST-REC KEY IS IT-ITMCD
INVALID KEY
MOVE MSG-ITMCD-ERR TO WS-MSGLIN
EXIT PARAGRAPH
END-READ.
MOVE IT-ITMNM TO WS-ITMNM(DL-IDX).
*--- 単価0の場合はマスタから取得 ---
IF WS-UPR(DL-IDX) = ZERO
MOVE IT-STDPRC TO WS-UPR(DL-IDX)
END-IF.
*--- 数量チェック ---
IF WS-QTY(DL-IDX) <= ZERO
MOVE MSG-QTY-ERR TO WS-MSGLIN
EXIT PARAGRAPH
END-IF
END-IF
END-PERFORM.
2500-SAVE-ORDER.
PERFORM 8300-GET-TODAY.
*--- 既存レコードチェック ---
MOVE WS-ORDNO TO HD-ORDNO.
READ ORDHDR INTO ORDHDR-REC KEY IS HD-ORDNO
INVALID KEY
MOVE 'N' TO WS-EXIST-FLG
NOT INVALID KEY
MOVE 'Y' TO WS-EXIST-FLG
END-READ.
*--- ヘッダレコード設定 ---
MOVE WS-ORDNO TO HD-ORDNO.
MOVE WS-ORDDAT TO HD-ORDDAT.
MOVE WS-CUSCD TO HD-CUSCD.
MOVE WS-EMPCD TO HD-EMPCD.
MOVE WS-DLVADR TO HD-DLVADR.
MOVE WS-DUEDAT TO HD-DUEDAT.
MOVE WS-RMRK TO HD-RMRK.
MOVE '1' TO HD-ORDSTS.
MOVE WS-TODAY TO HD-UPDDAT.
MOVE WS-SYSUSER TO HD-UPDUSR.
*--- 新規/更新 ---
IF WS-NOT-EXISTS
MOVE WS-TODAY TO HD-REGDAT
MOVE WS-SYSUSER TO HD-REGUSR
WRITE ORDHDR-REC FROM ORDHDR-REC
IF WS-HDRSTS NOT = '00'
MOVE MSG-IO-ERROR TO WS-MSGLIN
EXIT PARAGRAPH
END-IF
ELSE
REWRITE ORDHDR-REC FROM ORDHDR-REC
IF WS-HDRSTS NOT = '00'
MOVE MSG-IO-ERROR TO WS-MSGLIN
EXIT PARAGRAPH
END-IF
END-IF.
*--- 明細レコード書込（既存削除→再登録）---
IF WS-EXISTS
PERFORM 8400-DELETE-DTL
END-IF.
PERFORM VARYING DL-IDX FROM 1 BY 1
UNTIL DL-IDX > WS-MAX-DTL
IF WS-ITMCD(DL-IDX) NOT = SPACES
MOVE WS-ORDNO TO DT-ORDNO
MOVE DL-IDX TO DT-DTLNO
MOVE WS-ITMCD(DL-IDX) TO DT-ITMCD
MOVE WS-QTY(DL-IDX) TO DT-QTY
MOVE WS-UPR(DL-IDX) TO DT-UPR
MOVE WS-AMT(DL-IDX) TO DT-AMT
MOVE WS-TAX(DL-IDX) TO DT-TAX
WRITE ORDDTL-REC FROM ORDDTL-REC
IF WS-DTLSTS NOT = '00'
MOVE MSG-IO-ERROR TO WS-MSGLIN
EXIT PARAGRAPH
END-IF
END-IF
END-PERFORM.
IF WS-NOT-EXISTS
MOVE MSG-SAVED TO WS-MSGLIN
ELSE
MOVE MSG-UPDATED TO WS-MSGLIN
END-IF.
MOVE '1' TO WS-ORDSTS.
MOVE '確認済 ' TO WS-ORDSTNM.
2600-DELETE-ORDER.
IF WS-ORDNO = SPACES
MOVE MSG-ORDNO-REQ TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
MOVE WS-ORDNO TO HD-ORDNO.
READ ORDHDR INTO ORDHDR-REC KEY IS HD-ORDNO
INVALID KEY
MOVE MSG-NOT-FOUND TO WS-MSGLIN
EXIT PARAGRAPH
END-READ.
*--- 削除確認 ---
MOVE MSG-DELETE-CONF TO WS-MSGLIN.
PERFORM 2200-DISP-DETAIL.
READ ORDDSP-REC FORMAT IS 'ORDDET'.
IF IND(12) = '1'
MOVE SPACES TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
*--- ヘッダ削除 ---
DELETE ORDHDR-REC.
IF WS-HDRSTS NOT = '00'
MOVE MSG-IO-ERROR TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
*--- 明細削除 ---
PERFORM 8400-DELETE-DTL.
MOVE MSG-DELETED TO WS-MSGLIN.
PERFORM 9100-INIT-SCREEN.
MOVE 'H' TO WS-MODE.
*==========================================================
* 8000-SUBROUTINES : サブルーチン群
*==========================================================
8100-LOAD-SCREEN-FROM-HDR.
MOVE HD-ORDNO TO WS-ORDNO.
MOVE HD-ORDDAT TO WS-ORDDAT.
MOVE HD-CUSCD TO WS-CUSCD.
MOVE HD-EMPCD TO WS-EMPCD.
MOVE HD-DLVADR TO WS-DLVADR.
MOVE HD-DUEDAT TO WS-DUEDAT.
MOVE HD-RMRK TO WS-RMRK.
MOVE HD-ORDSTS TO WS-ORDSTS.
EVALUATE HD-ORDSTS
WHEN '0' MOVE '入力中 ' TO WS-ORDSTNM
WHEN '1' MOVE '確認済 ' TO WS-ORDSTNM
WHEN '2' MOVE '受注済 ' TO WS-ORDSTNM
WHEN '9' MOVE 'キャンセル' TO WS-ORDSTNM
WHEN OTHER MOVE '不明 ' TO WS-ORDSTNM
END-EVALUATE.
*--- 得意先名取得 ---
MOVE WS-CUSCD TO CS-CUSCD.
READ CUSTMST INTO CUSTMST-REC KEY IS CS-CUSCD
INVALID KEY
MOVE SPACES TO WS-CUSNM
NOT INVALID KEY
MOVE CS-CUSNM TO WS-CUSNM
END-READ.
8200-LOAD-DTL-FROM-FILE.
PERFORM VARYING DL-IDX FROM 1 BY 1
UNTIL DL-IDX > WS-MAX-DTL
INITIALIZE WS-DTL-LINE(DL-IDX)
END-PERFORM.
MOVE WS-ORDNO TO DT-ORDNO.
MOVE 1 TO DT-DTLNO.
START ORDDTL KEY IS NOT LESS THAN DT-ORDNO
INVALID KEY
EXIT PARAGRAPH
END-START.
PERFORM UNTIL WS-DTLSTS NOT = '00'
READ ORDDTL NEXT INTO ORDDTL-REC
AT END EXIT PERFORM
END-READ
IF DT-ORDNO NOT = WS-ORDNO
EXIT PERFORM
END-IF
IF DT-DTLNO <= WS-MAX-DTL
MOVE DT-ITMCD TO WS-ITMCD(DT-DTLNO)
MOVE DT-QTY TO WS-QTY(DT-DTLNO)
MOVE DT-UPR TO WS-UPR(DT-DTLNO)
MOVE DT-AMT TO WS-AMT(DT-DTLNO)
MOVE DT-TAX TO WS-TAX(DT-DTLNO)
*--- 品目名取得 ---
MOVE DT-ITMCD TO IT-ITMCD
READ ITMMST INTO ITMMST-REC KEY IS IT-ITMCD
INVALID KEY
MOVE SPACES TO WS-ITMNM(DT-DTLNO)
NOT INVALID KEY
MOVE IT-ITMNM TO WS-ITMNM(DT-DTLNO)
END-READ
END-IF
END-PERFORM.
8300-GET-TODAY.
MOVE FUNCTION CURRENT-DATE(1:8) TO WS-TODAY.
8400-DELETE-DTL.
MOVE WS-ORDNO TO DT-ORDNO.
MOVE 1 TO DT-DTLNO.
START ORDDTL KEY IS NOT LESS THAN DT-ORDNO
INVALID KEY
EXIT PARAGRAPH
END-START.
PERFORM UNTIL WS-DTLSTS NOT = '00'
READ ORDDTL NEXT INTO ORDDTL-REC
AT END EXIT PERFORM
END-READ
IF DT-ORDNO NOT = WS-ORDNO
EXIT PERFORM
END-IF
DELETE ORDDTL-REC
END-PERFORM.
*==========================================================
* 9000-OPEN-FILES : ファイルオープン
*==========================================================
9000-OPEN-FILES.
OPEN I-O ORDDSP.
OPEN I-O ORDHDR.
OPEN I-O ORDDTL.
OPEN INPUT CUSTMST.
OPEN INPUT ITMMST.
*==========================================================
* 9100-INIT-SCREEN : 画面作業域の初期化
*==========================================================
9100-INIT-SCREEN.
INITIALIZE WS-SCREEN.
MOVE SPACES TO WS-MSGLIN.
*==========================================================
* 9900-CLOSE-FILES : ファイルクローズ
*==========================================================
9900-CLOSE-FILES.
CLOSE ORDDSP.
CLOSE ORDHDR.
CLOSE ORDDTL.
CLOSE CUSTMST.
CLOSE ITMMST.
IBM Bobでレビュー→修正した結果
ORDPGM.CBL(IBM Bob)
ORDPGM.CBL(IBM Bob)
*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
* プログラム名 : ORDPGM
* 名称 : 受注データ入力プログラム
* 作成日 : 2025/01/01
* 概要 : 受注ヘッダ・明細の入力/照会/更新/削除
*
* 使用ファイル :
* ORDDSP - 受注入力画面ファイル (DSPF)
* ORDHDR - 受注ヘッダファイル (PF)
* ORDDTL - 受注明細ファイル (PF)
* CUSTMST - 得意先マスタ (PF)
* EMPMST - 社員マスタ (PF)
* ITMMST - 品目マスタ (PF)
*
* ファンクションキー :
* F3 = プログラム終了
* F5 = 受注データ照会
* F6 = 新規受注登録
* F8 = 明細行追加 (次頁)
* F10 = 受注データ削除
* F12 = 取消（前画面へ）
* Enter = 登録/更新確定
*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
IDENTIFICATION DIVISION.
PROGRAM-ID. ORDPGM.
AUTHOR. SYSTEM.
DATE-WRITTEN. 2025-01-01.
*----------------------------------------------------------
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-AS400.
OBJECT-COMPUTER. IBM-AS400.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
*--- 受注入力画面ファイル
SELECT ORDDSP ASSIGN TO WORKSTATION-ORDDSP
ORGANIZATION IS TRANSACTION.
*--- 受注ヘッダファイル
SELECT ORDHDR ASSIGN TO DATABASE-ORDHDR
ORGANIZATION IS INDEXED
ACCESS MODE IS DYNAMIC
RECORD KEY IS HD-ORDNO
FILE STATUS IS WS-HDRSTS.
*--- 受注明細ファイル
SELECT ORDDTL ASSIGN TO DATABASE-ORDDTL
ORGANIZATION IS INDEXED
ACCESS MODE IS DYNAMIC
RECORD KEY IS DT-ORDNO DT-DTLNO
FILE STATUS IS WS-DTLSTS.
*--- 得意先マスタファイル
SELECT CUSTMST ASSIGN TO DATABASE-CUSTMST
ORGANIZATION IS INDEXED
ACCESS MODE IS RANDOM
RECORD KEY IS CS-CUSCD
FILE STATUS IS WS-CUSSTS.
*--- 品目マスタファイル
SELECT ITMMST ASSIGN TO DATABASE-ITMMST
ORGANIZATION IS INDEXED
ACCESS MODE IS RANDOM
RECORD KEY IS IT-ITMCD
FILE STATUS IS WS-ITMSTS.
*----------------------------------------------------------
DATA DIVISION.
FILE SECTION.
*--- 受注入力画面ファイル -----------------------------------
FD ORDDSP.
01 ORDDSP-REC.
COPY DDS-ALL-FORMATS OF ORDDSP.
*--- 受注ヘッダファイル ------------------------------------
FD ORDHDR.
01 ORDHDR-REC.
05 HD-ORDNO PIC X(7). *> 受注番号
05 HD-ORDDAT PIC X(8). *> 受注日
05 HD-CUSCD PIC X(6). *> 得意先コード
05 HD-EMPCD PIC X(4). *> 担当者コード
05 HD-DLVADR PIC X(30). *> 納品先
05 HD-DUEDAT PIC X(8). *> 納期
05 HD-RMRK PIC X(40). *> 備考
05 HD-ORDSTS PIC X(1). *> 受注状態
88 HD-STS-NYURYOKU VALUE '0'. *> 入力中
88 HD-STS-KAKUNIN VALUE '1'. *> 確認済
88 HD-STS-JYUCHU VALUE '2'. *> 受注済
88 HD-STS-CANCEL VALUE '9'. *> キャンセル
05 HD-REGDAT PIC X(8). *> 登録日
05 HD-REGUSR PIC X(10). *> 登録者
05 HD-UPDDAT PIC X(8). *> 更新日
05 HD-UPDUSR PIC X(10). *> 更新者
*--- 受注明細ファイル --------------------------------------
FD ORDDTL.
01 ORDDTL-REC.
05 DT-ORDNO PIC X(7). *> 受注番号
05 DT-DTLNO PIC 9(2). *> 明細行番号
05 DT-ITMCD PIC X(8). *> 品目コード
05 DT-QTY PIC 9(5)V99. *> 数量
05 DT-UPR PIC 9(9)V99. *> 単価
05 DT-AMT PIC 9(11)V99. *> 金額
05 DT-TAX PIC 9(9)V99. *> 消費税
*--- 得意先マスタファイル ----------------------------------
FD CUSTMST.
01 CUSTMST-REC.
05 CS-CUSCD PIC X(6). *> 得意先コード
05 CS-CUSNM PIC X(20). *> 得意先名
05 CS-ADDR PIC X(40). *> 住所
05 CS-TEL PIC X(13). *> 電話番号
*--- 品目マスタファイル ------------------------------------
FD ITMMST.
01 ITMMST-REC.
05 IT-ITMCD PIC X(8). *> 品目コード
05 IT-ITMNM PIC X(20). *> 品目名称
05 IT-STDPRC PIC 9(9)V99. *> 標準単価
05 IT-UNIT PIC X(5). *> 単位
*----------------------------------------------------------
WORKING-STORAGE SECTION.
*--- プログラム制御フラグ -----------------------------------
01 WS-FLAGS.
05 WS-END-FLG PIC X(1) VALUE 'N'.
88 WS-END VALUE 'Y'.
88 WS-CONTINUE VALUE 'N'.
05 WS-MODE PIC X(1) VALUE SPACE.
88 WS-MODE-HEADER VALUE 'H'. *> ヘッダ画面
88 WS-MODE-DETAIL VALUE 'D'. *> 明細画面
88 WS-MODE-NEW VALUE 'N'. *> 新規入力
88 WS-MODE-UPD VALUE 'U'. *> 更新
88 WS-MODE-INQ VALUE 'I'. *> 照会
05 WS-EXIST-FLG PIC X(1) VALUE 'N'.
88 WS-EXISTS VALUE 'Y'.
88 WS-NOT-EXISTS VALUE 'N'.
*--- ファイルステータス ------------------------------------
01 WS-FILE-STATUS.
05 WS-HDRSTS PIC X(2) VALUE SPACES.
05 WS-DTLSTS PIC X(2) VALUE SPACES.
05 WS-CUSSTS PIC X(2) VALUE SPACES.
05 WS-ITMSTS PIC X(2) VALUE SPACES.
*--- ファンクションキー判定 ---------------------------------
01 WS-FKEY.
05 WS-FK03 PIC X(1) VALUE 'N'.
88 WS-F03 VALUE 'Y'.
05 WS-FK05 PIC X(1) VALUE 'N'.
88 WS-F05 VALUE 'Y'.
05 WS-FK06 PIC X(1) VALUE 'N'.
88 WS-F06 VALUE 'Y'.
05 WS-FK08 PIC X(1) VALUE 'N'.
88 WS-F08 VALUE 'Y'.
05 WS-FK10 PIC X(1) VALUE 'N'.
88 WS-F10 VALUE 'Y'.
05 WS-FK12 PIC X(1) VALUE 'N'.
88 WS-F12 VALUE 'Y'.
*--- 消費税率 -----------------------------------------------
01 WS-TAX-RATE PIC V99 VALUE .10.
*--- 明細最大行数 -------------------------------------------
01 WS-MAX-DTL PIC 9(2) VALUE 05.
01 WS-DTL-CNT PIC 9(2) VALUE ZERO.
*--- 日付・時刻 --------------------------------------------
01 WS-TODAY PIC X(8).
01 WS-SYSUSER PIC X(10) VALUE SPACES.
*--- メッセージ定義 ----------------------------------------
01 WS-MESSAGES.
05 MSG-NORMAL PIC X(79)
VALUE '正常に処理されました。'.
05 MSG-NOT-FOUND PIC X(79)
VALUE '受注番号が見つかりません。受注番号を確認してください。'.
05 MSG-ALREADY-EXISTS PIC X(79)
VALUE 'この受注番号はすでに登録されています。'.
05 MSG-ORDNO-REQ PIC X(79)
VALUE '受注番号を入力してください。'.
05 MSG-CUSCD-REQ PIC X(79)
VALUE '得意先コードを入力してください。'.
05 MSG-CUSCD-ERR PIC X(79)
VALUE '得意先コードが存在しません。正しいコードを入力してください。'.
05 MSG-ORDDAT-ERR PIC X(79)
VALUE '受注日の形式が正しくありません。(YYYYMMDD)'.
05 MSG-ITMCD-ERR PIC X(79)
VALUE '品目コードが存在しません。正しいコードを入力してください。'.
05 MSG-QTY-ERR PIC X(79)
VALUE '数量に0以下の値は設定できません。'.
05 MSG-DELETE-CONF PIC X(79)
VALUE '削除してもよいですか？ F4=確定 F12=取消'.
05 MSG-DELETED PIC X(79)
VALUE '受注データを削除しました。'.
05 MSG-SAVED PIC X(79)
VALUE '受注データを登録しました。'.
05 MSG-UPDATED PIC X(79)
VALUE '受注データを更新しました。'.
05 MSG-IO-ERROR PIC X(79)
VALUE 'ファイル入出力エラーが発生しました。システム管理者に連絡してください。'.
*--- 作業変数 -----------------------------------------------
01 WS-WORK.
05 WS-IDX PIC 9(2) VALUE ZERO.
05 WS-SUBTOT PIC 9(11)V99 VALUE ZERO.
05 WS-TAXTOT PIC 9(9)V99 VALUE ZERO.
05 WS-GRANDTL PIC 9(12)V99 VALUE ZERO.
05 WS-CONFIRM PIC X(1) VALUE 'N'.
*--- 画面フィールド作業域（ORDDET用）-----------------------
01 WS-SCREEN.
05 WS-ORDNO PIC X(7).
05 WS-ORDDAT PIC X(8).
05 WS-CUSCD PIC X(6).
05 WS-CUSNM PIC X(20).
05 WS-EMPCD PIC X(4).
05 WS-EMPNM PIC X(12).
05 WS-DLVADR PIC X(30).
05 WS-DUEDAT PIC X(8).
05 WS-RMRK PIC X(40).
05 WS-ORDSTS PIC X(1).
05 WS-ORDSTNM PIC X(8).
05 WS-MSGLIN PIC X(79).
*--- 明細行 (5行分) ---
05 WS-DTL-LINE OCCURS 5 TIMES INDEXED BY DL-IDX.
10 WS-ITMCD PIC X(8).
10 WS-ITMNM PIC X(20).
10 WS-QTY PIC 9(5)V99.
10 WS-UPR PIC 9(9)V99.
10 WS-AMT PIC 9(11)V99.
10 WS-TAX PIC 9(9)V99.
*----------------------------------------------------------
PROCEDURE DIVISION.
*==========================================================
* メイン制御
*==========================================================
0000-MAIN.
PERFORM 9000-OPEN-FILES.
PERFORM 9100-INIT-SCREEN.
MOVE 'H' TO WS-MODE.
PERFORM UNTIL WS-END
EVALUATE TRUE
WHEN WS-MODE-HEADER
PERFORM 1000-HEADER-PROCESS
WHEN WS-MODE-DETAIL
PERFORM 2000-DETAIL-PROCESS
WHEN OTHER
MOVE 'Y' TO WS-END-FLG
END-EVALUATE
END-PERFORM.
PERFORM 9900-CLOSE-FILES.
STOP RUN.
*==========================================================
* 1000-HEADER-PROCESS : ヘッダ画面処理
*==========================================================
1000-HEADER-PROCESS.
PERFORM 1100-DISP-HEADER.
PERFORM 1200-RECV-HEADER.
EVALUATE TRUE
WHEN WS-F03
MOVE 'Y' TO WS-END-FLG
WHEN WS-F05
PERFORM 1300-INQUIRY
WHEN WS-F06
PERFORM 1400-NEW-ORDER
WHEN OTHER
MOVE MSG-ORDNO-REQ TO WS-MSGLIN
END-EVALUATE.
1100-DISP-HEADER.
MOVE SPACES TO ORDDSP-REC.
MOVE WS-MSGLIN TO MSGLIN OF HEADER.
WRITE ORDDSP-REC FORMAT IS 'HEADER'.
MOVE SPACES TO WS-MSGLIN.
1200-RECV-HEADER.
MOVE 'N' TO WS-FK03 WS-FK05 WS-FK06 WS-FK10 WS-FK12.
READ ORDDSP-REC FORMAT IS 'HEADER'.
MOVE ORDNO OF HEADER TO WS-ORDNO.
IF IND(03) = '1' THEN MOVE 'Y' TO WS-FK03 END-IF.
IF IND(05) = '1' THEN MOVE 'Y' TO WS-FK05 END-IF.
IF IND(06) = '1' THEN MOVE 'Y' TO WS-FK06 END-IF.
IF IND(12) = '1' THEN MOVE 'Y' TO WS-FK12 END-IF.
1300-INQUIRY.
IF WS-ORDNO = SPACES
MOVE MSG-ORDNO-REQ TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
MOVE WS-ORDNO TO HD-ORDNO.
READ ORDHDR INTO ORDHDR-REC KEY IS HD-ORDNO
INVALID KEY
MOVE MSG-NOT-FOUND TO WS-MSGLIN
EXIT PARAGRAPH
END-READ.
PERFORM 8100-LOAD-SCREEN-FROM-HDR.
PERFORM 8200-LOAD-DTL-FROM-FILE.
MOVE 'D' TO WS-MODE.
1400-NEW-ORDER.
PERFORM 9100-INIT-SCREEN.
PERFORM 8300-GET-TODAY.
MOVE WS-TODAY TO WS-ORDDAT.
MOVE 'D' TO WS-MODE.
*==========================================================
* 2000-DETAIL-PROCESS : 明細画面処理
*==========================================================
2000-DETAIL-PROCESS.
PERFORM 2100-CALC-TOTALS.
PERFORM 2200-DISP-DETAIL.
PERFORM 2300-RECV-DETAIL.
EVALUATE TRUE
WHEN WS-F03
MOVE 'Y' TO WS-END-FLG
WHEN WS-F05
MOVE 'H' TO WS-MODE
WHEN WS-F10
PERFORM 2600-DELETE-ORDER
WHEN WS-F12
MOVE 'H' TO WS-MODE
PERFORM 9100-INIT-SCREEN
WHEN OTHER
PERFORM 2400-VALIDATE-INPUT
IF WS-MSGLIN = SPACES
PERFORM 2500-SAVE-ORDER
END-IF
END-EVALUATE.
2100-CALC-TOTALS.
MOVE ZERO TO WS-SUBTOT WS-TAXTOT WS-GRANDTL.
PERFORM VARYING DL-IDX FROM 1 BY 1
UNTIL DL-IDX > WS-MAX-DTL
IF WS-ITMCD(DL-IDX) NOT = SPACES
COMPUTE WS-AMT(DL-IDX) =
WS-QTY(DL-IDX) * WS-UPR(DL-IDX)
COMPUTE WS-TAX(DL-IDX) =
WS-AMT(DL-IDX) * WS-TAX-RATE
ADD WS-AMT(DL-IDX) TO WS-SUBTOT
ADD WS-TAX(DL-IDX) TO WS-TAXTOT
END-IF
END-PERFORM.
COMPUTE WS-GRANDTL = WS-SUBTOT + WS-TAXTOT.
2200-DISP-DETAIL.
MOVE SPACES TO ORDDSP-REC.
*--- ヘッダ項目の設定 ---
MOVE WS-ORDNO TO ORDNO OF ORDDET.
MOVE WS-ORDDAT TO ORDDAT OF ORDDET.
MOVE WS-CUSCD TO CUSCD OF ORDDET.
MOVE WS-CUSNM TO CUSNM OF ORDDET.
MOVE WS-EMPCD TO EMPCD OF ORDDET.
MOVE WS-EMPNM TO EMPNM OF ORDDET.
MOVE WS-DLVADR TO DLVADR OF ORDDET.
MOVE WS-DUEDAT TO DUEDAT OF ORDDET.
MOVE WS-RMRK TO RMRK OF ORDDET.
MOVE WS-ORDSTS TO ORDSTS OF ORDDET.
MOVE WS-ORDSTNM TO ORDSTNM OF ORDDET.
*--- 明細行の設定 ---
MOVE WS-ITMCD(1) TO ITMCD1 OF ORDDET.
MOVE WS-ITMNM(1) TO ITMNM1 OF ORDDET.
MOVE WS-QTY(1) TO QTY1 OF ORDDET.
MOVE WS-UPR(1) TO UPR1 OF ORDDET.
MOVE WS-AMT(1) TO AMT1 OF ORDDET.
MOVE WS-TAX(1) TO TAX1 OF ORDDET.
MOVE WS-ITMCD(2) TO ITMCD2 OF ORDDET.
MOVE WS-ITMNM(2) TO ITMNM2 OF ORDDET.
MOVE WS-QTY(2) TO QTY2 OF ORDDET.
MOVE WS-UPR(2) TO UPR2 OF ORDDET.
MOVE WS-AMT(2) TO AMT2 OF ORDDET.
MOVE WS-TAX(2) TO TAX2 OF ORDDET.
MOVE WS-ITMCD(3) TO ITMCD3 OF ORDDET.
MOVE WS-ITMNM(3) TO ITMNM3 OF ORDDET.
MOVE WS-QTY(3) TO QTY3 OF ORDDET.
MOVE WS-UPR(3) TO UPR3 OF ORDDET.
MOVE WS-AMT(3) TO AMT3 OF ORDDET.
MOVE WS-TAX(3) TO TAX3 OF ORDDET.
MOVE WS-ITMCD(4) TO ITMCD4 OF ORDDET.
MOVE WS-ITMNM(4) TO ITMNM4 OF ORDDET.
MOVE WS-QTY(4) TO QTY4 OF ORDDET.
MOVE WS-UPR(4) TO UPR4 OF ORDDET.
MOVE WS-AMT(4) TO AMT4 OF ORDDET.
MOVE WS-TAX(4) TO TAX4 OF ORDDET.
MOVE WS-ITMCD(5) TO ITMCD5 OF ORDDET.
MOVE WS-ITMNM(5) TO ITMNM5 OF ORDDET.
MOVE WS-QTY(5) TO QTY5 OF ORDDET.
MOVE WS-UPR(5) TO UPR5 OF ORDDET.
MOVE WS-AMT(5) TO AMT5 OF ORDDET.
MOVE WS-TAX(5) TO TAX5 OF ORDDET.
*--- 合計の設定 ---
MOVE WS-SUBTOT TO SUBTOT OF ORDDET.
MOVE WS-TAXTOT TO TAXTOT OF ORDDET.
MOVE WS-GRANDTL TO GRANDTL OF ORDDET.
MOVE WS-MSGLIN TO MSGLIN OF ORDDET.
WRITE ORDDSP-REC FORMAT IS 'ORDDET'.
MOVE SPACES TO WS-MSGLIN.
2300-RECV-DETAIL.
MOVE 'N' TO WS-FK03 WS-FK05 WS-FK06 WS-FK08
WS-FK10 WS-FK12.
READ ORDDSP-REC FORMAT IS 'ORDDET'.
*--- ファンクションキーインジケータ取得 ---
IF IND(03) = '1' THEN MOVE 'Y' TO WS-FK03 END-IF.
IF IND(05) = '1' THEN MOVE 'Y' TO WS-FK05 END-IF.
IF IND(06) = '1' THEN MOVE 'Y' TO WS-FK06 END-IF.
IF IND(08) = '1' THEN MOVE 'Y' TO WS-FK08 END-IF.
IF IND(10) = '1' THEN MOVE 'Y' TO WS-FK10 END-IF.
IF IND(12) = '1' THEN MOVE 'Y' TO WS-FK12 END-IF.
*--- 入力値を作業域へ取込 ---
MOVE ORDNO OF ORDDET TO WS-ORDNO.
MOVE ORDDAT OF ORDDET TO WS-ORDDAT.
MOVE CUSCD OF ORDDET TO WS-CUSCD.
MOVE EMPCD OF ORDDET TO WS-EMPCD.
MOVE DLVADR OF ORDDET TO WS-DLVADR.
MOVE DUEDAT OF ORDDET TO WS-DUEDAT.
MOVE RMRK OF ORDDET TO WS-RMRK.
MOVE ITMCD1 OF ORDDET TO WS-ITMCD(1).
MOVE QTY1 OF ORDDET TO WS-QTY(1).
MOVE UPR1 OF ORDDET TO WS-UPR(1).
MOVE ITMCD2 OF ORDDET TO WS-ITMCD(2).
MOVE QTY2 OF ORDDET TO WS-QTY(2).
MOVE UPR2 OF ORDDET TO WS-UPR(2).
MOVE ITMCD3 OF ORDDET TO WS-ITMCD(3).
MOVE QTY3 OF ORDDET TO WS-QTY(3).
MOVE UPR3 OF ORDDET TO WS-UPR(3).
MOVE ITMCD4 OF ORDDET TO WS-ITMCD(4).
MOVE QTY4 OF ORDDET TO WS-QTY(4).
MOVE UPR4 OF ORDDET TO WS-UPR(4).
MOVE ITMCD5 OF ORDDET TO WS-ITMCD(5).
MOVE QTY5 OF ORDDET TO WS-QTY(5).
MOVE UPR5 OF ORDDET TO WS-UPR(5).
2400-VALIDATE-INPUT.
MOVE SPACES TO WS-MSGLIN.
*--- 受注番号 必須チェック ---
IF WS-ORDNO = SPACES
MOVE MSG-ORDNO-REQ TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
*--- 受注日 形式チェック (数字8桁：各桁が '0'〜'9' か判定) ---
PERFORM VARYING WS-IDX FROM 1 BY 1
UNTIL WS-IDX > 8
IF WS-ORDDAT(WS-IDX:1) < '0' OR
WS-ORDDAT(WS-IDX:1) > '9'
MOVE MSG-ORDDAT-ERR TO WS-MSGLIN
EXIT PARAGRAPH
END-IF
END-PERFORM.
*--- 得意先コード 必須・存在チェック ---
IF WS-CUSCD = SPACES
MOVE MSG-CUSCD-REQ TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
MOVE WS-CUSCD TO CS-CUSCD.
READ CUSTMST INTO CUSTMST-REC KEY IS CS-CUSCD
INVALID KEY
MOVE MSG-CUSCD-ERR TO WS-MSGLIN
EXIT PARAGRAPH
END-READ.
MOVE CS-CUSNM TO WS-CUSNM.
*--- 明細チェック（全行チェック後にエラー判定）---
PERFORM VARYING DL-IDX FROM 1 BY 1
UNTIL DL-IDX > WS-MAX-DTL
IF WS-ITMCD(DL-IDX) NOT = SPACES
*--- 品目コード存在チェック ---
MOVE WS-ITMCD(DL-IDX) TO IT-ITMCD
READ ITMMST INTO ITMMST-REC KEY IS IT-ITMCD
INVALID KEY
MOVE MSG-ITMCD-ERR TO WS-MSGLIN
EXIT PARAGRAPH
END-READ.
MOVE IT-ITMNM TO WS-ITMNM(DL-IDX).
*--- 単価0の場合はマスタから取得 ---
IF WS-UPR(DL-IDX) = ZERO
MOVE IT-STDPRC TO WS-UPR(DL-IDX)
END-IF.
*--- 数量チェック ---
IF WS-QTY(DL-IDX) <= ZERO
MOVE MSG-QTY-ERR TO WS-MSGLIN
EXIT PARAGRAPH
END-IF
END-IF
END-PERFORM.
2500-SAVE-ORDER.
PERFORM 8300-GET-TODAY.
*--- 既存レコードチェック ---
MOVE WS-ORDNO TO HD-ORDNO.
READ ORDHDR INTO ORDHDR-REC KEY IS HD-ORDNO
INVALID KEY
MOVE 'N' TO WS-EXIST-FLG
NOT INVALID KEY
MOVE 'Y' TO WS-EXIST-FLG
END-READ.
*--- ヘッダレコード設定 ---
MOVE WS-ORDNO TO HD-ORDNO.
MOVE WS-ORDDAT TO HD-ORDDAT.
MOVE WS-CUSCD TO HD-CUSCD.
MOVE WS-EMPCD TO HD-EMPCD.
MOVE WS-DLVADR TO HD-DLVADR.
MOVE WS-DUEDAT TO HD-DUEDAT.
MOVE WS-RMRK TO HD-RMRK.
MOVE '1' TO HD-ORDSTS.
MOVE WS-TODAY TO HD-UPDDAT.
MOVE WS-SYSUSER TO HD-UPDUSR.
*--- 新規/更新 ---
IF WS-NOT-EXISTS
MOVE WS-TODAY TO HD-REGDAT
MOVE WS-SYSUSER TO HD-REGUSR
WRITE ORDHDR-REC
IF WS-HDRSTS NOT = '00'
MOVE MSG-IO-ERROR TO WS-MSGLIN
EXIT PARAGRAPH
END-IF
ELSE
REWRITE ORDHDR-REC
IF WS-HDRSTS NOT = '00'
MOVE MSG-IO-ERROR TO WS-MSGLIN
EXIT PARAGRAPH
END-IF
END-IF.
*--- 明細レコード書込（既存削除→再登録）---
IF WS-EXISTS
PERFORM 8400-DELETE-DTL
END-IF.
PERFORM VARYING DL-IDX FROM 1 BY 1
UNTIL DL-IDX > WS-MAX-DTL
IF WS-ITMCD(DL-IDX) NOT = SPACES
MOVE WS-ORDNO TO DT-ORDNO
MOVE DL-IDX TO DT-DTLNO
MOVE WS-ITMCD(DL-IDX) TO DT-ITMCD
MOVE WS-QTY(DL-IDX) TO DT-QTY
MOVE WS-UPR(DL-IDX) TO DT-UPR
MOVE WS-AMT(DL-IDX) TO DT-AMT
MOVE WS-TAX(DL-IDX) TO DT-TAX
WRITE ORDDTL-REC
IF WS-DTLSTS NOT = '00'
MOVE MSG-IO-ERROR TO WS-MSGLIN
EXIT PARAGRAPH
END-IF
END-IF
END-PERFORM.
IF WS-NOT-EXISTS
MOVE MSG-SAVED TO WS-MSGLIN
ELSE
MOVE MSG-UPDATED TO WS-MSGLIN
END-IF.
MOVE '1' TO WS-ORDSTS.
MOVE '確認済 ' TO WS-ORDSTNM.
2600-DELETE-ORDER.
IF WS-ORDNO = SPACES
MOVE MSG-ORDNO-REQ TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
MOVE WS-ORDNO TO HD-ORDNO.
READ ORDHDR INTO ORDHDR-REC KEY IS HD-ORDNO
INVALID KEY
MOVE MSG-NOT-FOUND TO WS-MSGLIN
EXIT PARAGRAPH
END-READ.
*--- 削除確認画面表示（CONFIRM レコード）---
MOVE MSG-DELETE-CONF TO WS-MSGLIN.
PERFORM 2200-DISP-DETAIL.
WRITE ORDDSP-REC FORMAT IS 'CONFIRM'.
READ ORDDSP-REC FORMAT IS 'CONFIRM'.
*--- F12=取消 または F4 以外は削除中止 ---
IF IND(12) = '1' OR IND(04) NOT = '1'
MOVE SPACES TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
*--- ヘッダ削除 ---
DELETE ORDHDR-REC.
IF WS-HDRSTS NOT = '00'
MOVE MSG-IO-ERROR TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
*--- 明細削除 ---
PERFORM 8400-DELETE-DTL.
MOVE MSG-DELETED TO WS-MSGLIN.
PERFORM 9100-INIT-SCREEN.
MOVE 'H' TO WS-MODE.
*==========================================================
* 8000-SUBROUTINES : サブルーチン群
*==========================================================
8100-LOAD-SCREEN-FROM-HDR.
MOVE HD-ORDNO TO WS-ORDNO.
MOVE HD-ORDDAT TO WS-ORDDAT.
MOVE HD-CUSCD TO WS-CUSCD.
MOVE HD-EMPCD TO WS-EMPCD.
MOVE HD-DLVADR TO WS-DLVADR.
MOVE HD-DUEDAT TO WS-DUEDAT.
MOVE HD-RMRK TO WS-RMRK.
MOVE HD-ORDSTS TO WS-ORDSTS.
EVALUATE HD-ORDSTS
WHEN '0' MOVE '入力中 ' TO WS-ORDSTNM
WHEN '1' MOVE '確認済 ' TO WS-ORDSTNM
WHEN '2' MOVE '受注済 ' TO WS-ORDSTNM
WHEN '9' MOVE 'キャンセル' TO WS-ORDSTNM
WHEN OTHER MOVE '不明 ' TO WS-ORDSTNM
END-EVALUATE.
*--- 得意先名取得 ---
MOVE WS-CUSCD TO CS-CUSCD.
READ CUSTMST INTO CUSTMST-REC KEY IS CS-CUSCD
INVALID KEY
MOVE SPACES TO WS-CUSNM
NOT INVALID KEY
MOVE CS-CUSNM TO WS-CUSNM
END-READ.
8200-LOAD-DTL-FROM-FILE.
PERFORM VARYING DL-IDX FROM 1 BY 1
UNTIL DL-IDX > WS-MAX-DTL
INITIALIZE WS-DTL-LINE(DL-IDX)
END-PERFORM.
MOVE WS-ORDNO TO DT-ORDNO.
MOVE 1 TO DT-DTLNO.
START ORDDTL KEY IS NOT LESS THAN DT-ORDNO
INVALID KEY
EXIT PARAGRAPH
END-START.
PERFORM UNTIL EXIT
READ ORDDTL NEXT INTO ORDDTL-REC
AT END EXIT PERFORM
END-READ
IF WS-DTLSTS NOT = '00'
EXIT PERFORM
END-IF
IF DT-ORDNO NOT = WS-ORDNO
EXIT PERFORM
END-IF
IF DT-DTLNO <= WS-MAX-DTL
MOVE DT-ITMCD TO WS-ITMCD(DT-DTLNO)
MOVE DT-QTY TO WS-QTY(DT-DTLNO)
MOVE DT-UPR TO WS-UPR(DT-DTLNO)
MOVE DT-AMT TO WS-AMT(DT-DTLNO)
MOVE DT-TAX TO WS-TAX(DT-DTLNO)
*--- 品目名取得 ---
MOVE DT-ITMCD TO IT-ITMCD
READ ITMMST INTO ITMMST-REC KEY IS IT-ITMCD
INVALID KEY
MOVE SPACES TO WS-ITMNM(DT-DTLNO)
NOT INVALID KEY
MOVE IT-ITMNM TO WS-ITMNM(DT-DTLNO)
END-READ
END-IF
END-PERFORM.
8300-GET-TODAY.
MOVE FUNCTION CURRENT-DATE(1:8) TO WS-TODAY.
8350-GET-SYSUSER.
*--- ジョブ実行ユーザIDを取得する ---
*--- IBM i COBOL では QUSRJOBI API を使って取得する ---
*--- 実機例: ---
*--- CALL 'QUSRJOBI' USING WS-SYSUSER ... ---
*--- 本実装では ORDCTL.CLP のパラメータ &USERID を ---
*--- ORDPGM に渡す方式に変更することを推奨する。 ---
*--- 暫定として SPACES のままとする。 ---
MOVE SPACES TO WS-SYSUSER.
8400-DELETE-DTL.
MOVE WS-ORDNO TO DT-ORDNO.
MOVE 1 TO DT-DTLNO.
START ORDDTL KEY IS NOT LESS THAN DT-ORDNO
INVALID KEY
EXIT PARAGRAPH
END-START.
PERFORM UNTIL EXIT
READ ORDDTL NEXT INTO ORDDTL-REC
AT END EXIT PERFORM
END-READ
IF WS-DTLSTS NOT = '00'
EXIT PERFORM
END-IF
IF DT-ORDNO NOT = WS-ORDNO
EXIT PERFORM
END-IF
DELETE ORDDTL-REC
END-PERFORM.
*==========================================================
* 9000-OPEN-FILES : ファイルオープン
*==========================================================
9000-OPEN-FILES.
OPEN I-O ORDDSP.
IF WS-HDRSTS NOT = '00'
STRING 'ORDDSP OPEN エラー FS=' WS-HDRSTS
DELIMITED SIZE INTO WS-MSGLIN
STOP RUN
END-IF.
OPEN I-O ORDHDR.
IF WS-HDRSTS NOT = '00'
STRING 'ORDHDR OPEN エラー FS=' WS-HDRSTS
DELIMITED SIZE INTO WS-MSGLIN
STOP RUN
END-IF.
OPEN I-O ORDDTL.
IF WS-DTLSTS NOT = '00'
STRING 'ORDDTL OPEN エラー FS=' WS-DTLSTS
DELIMITED SIZE INTO WS-MSGLIN
STOP RUN
END-IF.
OPEN INPUT CUSTMST.
IF WS-CUSSTS NOT = '00'
STRING 'CUSTMST OPEN エラー FS=' WS-CUSSTS
DELIMITED SIZE INTO WS-MSGLIN
STOP RUN
END-IF.
OPEN INPUT ITMMST.
IF WS-ITMSTS NOT = '00'
STRING 'ITMMST OPEN エラー FS=' WS-ITMSTS
DELIMITED SIZE INTO WS-MSGLIN
STOP RUN
END-IF.
*==========================================================
* 9100-INIT-SCREEN : 画面作業域の初期化
*==========================================================
9100-INIT-SCREEN.
INITIALIZE WS-SCREEN.
MOVE SPACES TO WS-MSGLIN.
*==========================================================
* 9900-CLOSE-FILES : ファイルクローズ
*==========================================================
9900-CLOSE-FILES.
CLOSE ORDDSP.
CLOSE ORDHDR.
CLOSE ORDDTL.
CLOSE CUSTMST.
CLOSE ITMMST.
ChatGPTでレビュー→修正した結果
ORDPGM.CBL(ChatGPT)
ORDPGM.CBL(ChatGPT)
*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
* プログラム名 : ORDPGM
* 名称 : 受注データ入力プログラム
* 作成日 : 2026/09/02
* 概要 : 受注ヘッダ・明細の入力/照会/更新/削除
*
* 使用ファイル :
* ORDDSP - 受注入力画面ファイル
* ORDHDR - 受注ヘッダファイル
* ORDDTL - 受注明細ファイル
* CUSTMST - 得意先マスタ
* ITMMST - 品目マスタ
*
* 備考 :
* EMPMSTは今回提示されたPF定義に存在しないため、
* 本版では依存を外している。
*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
IDENTIFICATION DIVISION.
PROGRAM-ID. ORDPGM.
AUTHOR. SYSTEM.
DATE-WRITTEN. 2026-09-02.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-AS400.
OBJECT-COMPUTER. IBM-AS400.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT ORDDSP
ASSIGN TO WORKSTATION-ORDDSP
ORGANIZATION IS TRANSACTION
FILE STATUS IS WS-DSPSTS.
SELECT ORDHDR
ASSIGN TO DATABASE-ORDHDR
ORGANIZATION IS INDEXED
ACCESS MODE IS DYNAMIC
RECORD KEY IS HD-ORDNO
FILE STATUS IS WS-HDRSTS.
SELECT ORDDTL
ASSIGN TO DATABASE-ORDDTL
ORGANIZATION IS INDEXED
ACCESS MODE IS DYNAMIC
RECORD KEY IS DT-KEY
FILE STATUS IS WS-DTLSTS.
SELECT CUSTMST
ASSIGN TO DATABASE-CUSTMST
ORGANIZATION IS INDEXED
ACCESS MODE IS RANDOM
RECORD KEY IS CS-CUSCD
FILE STATUS IS WS-CUSSTS.
SELECT ITMMST
ASSIGN TO DATABASE-ITMMST
ORGANIZATION IS INDEXED
ACCESS MODE IS RANDOM
RECORD KEY IS IT-ITMCD
FILE STATUS IS WS-ITMSTS.
DATA DIVISION.
FILE SECTION.
*----------------------------------------------------------
* 画面ファイル
*----------------------------------------------------------
FD ORDDSP.
01 ORDDSP-REC.
COPY DDS-ALL-FORMATS OF ORDDSP.
*----------------------------------------------------------
* 受注ヘッダ
*----------------------------------------------------------
FD ORDHDR.
01 ORDHDR-REC.
05 HD-ORDNO PIC X(7).
05 HD-ORDDAT PIC X(8).
05 HD-CUSCD PIC X(6).
05 HD-EMPCD PIC X(4).
05 HD-DLVADR PIC X(30).
05 HD-DUEDAT PIC X(8).
05 HD-RMRK PIC X(40).
05 HD-ORDSTS PIC X(1).
88 HD-STS-NYURYOKU VALUE '0'.
88 HD-STS-KAKUNIN VALUE '1'.
88 HD-STS-JYUCHU VALUE '2'.
88 HD-STS-CANCEL VALUE '9'.
05 HD-REGDAT PIC X(8).
05 HD-REGUSR PIC X(10).
05 HD-UPDDAT PIC X(8).
05 HD-UPDUSR PIC X(10).
*----------------------------------------------------------
* 受注明細
*
* DDSキー :
* ORDNO + DTLNO
*
* 複合キーをグループとして定義
*----------------------------------------------------------
FD ORDDTL.
01 ORDDTL-REC.
05 DT-KEY.
10 DT-ORDNO PIC X(7).
10 DT-DTLNO PIC 9(2).
05 DT-ITMCD PIC X(8).
05 DT-QTY PIC 9(5)V99.
05 DT-UPR PIC 9(9)V99.
05 DT-AMT PIC 9(11)V99.
05 DT-TAX PIC 9(9)V99.
*----------------------------------------------------------
* 得意先マスタ
* PF定義とレコード長を合わせる
*----------------------------------------------------------
FD CUSTMST.
01 CUSTMST-REC.
05 CS-CUSCD PIC X(6).
05 CS-CUSNM PIC X(20).
05 CS-CUSNMK PIC X(20).
05 CS-ADDR1 PIC X(30).
05 CS-ADDR2 PIC X(30).
05 CS-ZIPCOD PIC X(7).
05 CS-TEL PIC X(13).
05 CS-FAX PIC X(13).
05 CS-PICEMPCD PIC X(4).
05 CS-PAYTERM PIC X(2).
05 CS-CUSTSTS PIC X(1).
05 CS-REGDAT PIC X(8).
05 CS-REGUSR PIC X(10).
05 CS-UPDDAT PIC X(8).
05 CS-UPDUSR PIC X(10).
*----------------------------------------------------------
* 品目マスタ
* PF定義とレコード長を合わせる
*----------------------------------------------------------
FD ITMMST.
01 ITMMST-REC.
05 IT-ITMCD PIC X(8).
05 IT-ITMNM PIC X(20).
05 IT-ITMNMK PIC X(20).
05 IT-ITMGRP PIC X(4).
05 IT-UNIT PIC X(5).
05 IT-STDPRC PIC 9(9)V99.
05 IT-BUYPRC PIC 9(9)V99.
05 IT-STQTY PIC 9(7)V99.
05 IT-SAFEQTY PIC 9(7)V99.
05 IT-ITMSTS PIC X(1).
05 IT-REGDAT PIC X(8).
05 IT-REGUSR PIC X(10).
05 IT-UPDDAT PIC X(8).
05 IT-UPDUSR PIC X(10).
WORKING-STORAGE SECTION.
*----------------------------------------------------------
* ファイルステータス
*----------------------------------------------------------
01 WS-FILE-STATUS.
05 WS-DSPSTS PIC XX VALUE '00'.
05 WS-HDRSTS PIC XX VALUE '00'.
05 WS-DTLSTS PIC XX VALUE '00'.
05 WS-CUSSTS PIC XX VALUE '00'.
05 WS-ITMSTS PIC XX VALUE '00'.
*----------------------------------------------------------
* ファイルOPEN状態
*----------------------------------------------------------
01 WS-OPEN-FLAGS.
05 WS-DSP-OPEN PIC X VALUE 'N'.
05 WS-HDR-OPEN PIC X VALUE 'N'.
05 WS-DTL-OPEN PIC X VALUE 'N'.
05 WS-CUS-OPEN PIC X VALUE 'N'.
05 WS-ITM-OPEN PIC X VALUE 'N'.
*----------------------------------------------------------
* 画面制御
*----------------------------------------------------------
01 WS-SCREEN-MODE PIC X VALUE 'H'.
88 WS-MODE-HEADER VALUE 'H'.
88 WS-MODE-DETAIL VALUE 'D'.
* 操作モード
* N = 新規
* U = 更新
* I = 照会
01 WS-OP-MODE PIC X VALUE 'N'.
88 WS-OP-NEW VALUE 'N'.
88 WS-OP-UPDATE VALUE 'U'.
88 WS-OP-INQUIRY VALUE 'I'.
*----------------------------------------------------------
* 終了フラグ
*----------------------------------------------------------
01 WS-END-FLG PIC X VALUE 'N'.
88 WS-END VALUE 'Y'.
88 WS-CONTINUE VALUE 'N'.
*----------------------------------------------------------
* ファンクションキー
*----------------------------------------------------------
01 WS-INDICATORS.
05 IN03 PIC 1 INDIC 03.
88 WS-F03 VALUE B"1".
05 IN04 PIC 1 INDIC 04.
88 WS-F04 VALUE B"1".
05 IN05 PIC 1 INDIC 05.
88 WS-F05 VALUE B"1".
05 IN06 PIC 1 INDIC 06.
88 WS-F06 VALUE B"1".
05 IN08 PIC 1 INDIC 08.
88 WS-F08 VALUE B"1".
05 IN10 PIC 1 INDIC 10.
88 WS-F10 VALUE B"1".
05 IN12 PIC 1 INDIC 12.
88 WS-F12 VALUE B"1".
*----------------------------------------------------------
* 消費税率
*----------------------------------------------------------
01 WS-TAX-RATE PIC V99 VALUE .10.
*----------------------------------------------------------
* 明細最大行数
*----------------------------------------------------------
01 WS-MAX-DTL PIC 9(2) VALUE 5.
01 WS-DTL-CNT PIC 9(2) VALUE ZERO.
*----------------------------------------------------------
* ユーザー・日付
*----------------------------------------------------------
01 WS-TODAY PIC X(8).
01 WS-SYSUSER PIC X(10).
*----------------------------------------------------------
* メッセージ
*----------------------------------------------------------
01 WS-MESSAGES.
05 MSG-NORMAL
PIC X(79)
VALUE '正常に処理されました。'.
05 MSG-NOT-FOUND
PIC X(79)
VALUE '受注番号が見つかりません。受注番号を確認してください。'.
05 MSG-ALREADY-EXISTS
PIC X(79)
VALUE 'この受注番号はすでに登録されています。'.
05 MSG-ORDNO-REQ
PIC X(79)
VALUE '受注番号を入力してください。'.
05 MSG-CUSCD-REQ
PIC X(79)
VALUE '得意先コードを入力してください。'.
05 MSG-CUSCD-ERR
PIC X(79)
VALUE '得意先コードが存在しないか、無効です。'.
05 MSG-ORDDAT-ERR
PIC X(79)
VALUE '受注日の形式が正しくありません。(YYYYMMDD)'.
05 MSG-ITMCD-ERR
PIC X(79)
VALUE '品目コードが存在しないか、販売停止です。'.
05 MSG-QTY-ERR
PIC X(79)
VALUE '数量に0以下の値は設定できません。'.
05 MSG-DETAIL-REQ
PIC X(79)
VALUE '明細を1件以上入力してください。'.
05 MSG-DELETE-CONF
PIC X(79)
VALUE '削除してよいですか？ Enter=確定 F12=取消'.
05 MSG-DELETED
PIC X(79)
VALUE '受注データを削除しました。'.
05 MSG-SAVED
PIC X(79)
VALUE '受注データを登録しました。'.
05 MSG-UPDATED
PIC X(79)
VALUE '受注データを更新しました。'.
05 MSG-DTL-MAX
PIC X(79)
VALUE '明細は5行まで入力できます。'.
05 MSG-INQUIRY
PIC X(79)
VALUE '照会モードです。'.
05 MSG-IO-ERROR
PIC X(79)
VALUE 'ファイル入出力エラーが発生しました。'.
05 MSG-OPEN-ERROR
PIC X(79)
VALUE 'ファイルオープンエラーが発生しました。'.
*----------------------------------------------------------
* 作業域
*----------------------------------------------------------
01 WS-WORK.
05 WS-IDX PIC 9(2) VALUE ZERO.
05 WS-SUBTOT PIC 9(11)V99 VALUE ZERO.
05 WS-TAXTOT PIC 9(9)V99 VALUE ZERO.
05 WS-GRANDTL PIC 9(12)V99 VALUE ZERO.
05 WS-DTL-EXISTS PIC X VALUE 'N'.
*----------------------------------------------------------
* 画面作業域
*----------------------------------------------------------
01 WS-SCREEN.
05 WS-ORDNO PIC X(7).
05 WS-ORDDAT PIC X(8).
05 WS-CUSCD PIC X(6).
05 WS-CUSNM PIC X(20).
05 WS-EMPCD PIC X(4).
05 WS-EMPNM PIC X(12).
05 WS-DLVADR PIC X(30).
05 WS-DUEDAT PIC X(8).
05 WS-RMRK PIC X(40).
05 WS-ORDSTS PIC X(1).
05 WS-ORDSTNM PIC X(8).
05 WS-MSGLIN PIC X(79).
05 WS-DTL-LINE
OCCURS 5 TIMES
INDEXED BY DL-IDX.
10 WS-ITMCD PIC X(8).
10 WS-ITMNM PIC X(20).
10 WS-QTY PIC 9(5)V99.
10 WS-UPR PIC 9(9)V99.
10 WS-AMT PIC 9(11)V99.
10 WS-TAX PIC 9(9)V99.
*----------------------------------------------------------
* 日付チェック用
*----------------------------------------------------------
01 WS-DATE-WORK.
05 WS-YEAR PIC 9(4).
05 WS-MONTH PIC 9(2).
05 WS-DAY PIC 9(2).
05 WS-MAX-DAY PIC 9(2).
05 WS-LEAP-FLG PIC X VALUE 'N'.
*----------------------------------------------------------
* PROCEDURE
*----------------------------------------------------------
PROCEDURE DIVISION USING LK-USERID.
LINKAGE SECTION.
01 LK-USERID PIC X(10).
*==========================================================
* メイン
*==========================================================
0000-MAIN.
MOVE LK-USERID TO WS-SYSUSER.
PERFORM 9000-OPEN-FILES
IF WS-END
GOBACK
END-IF
PERFORM 9100-INIT-SCREEN
MOVE 'H' TO WS-SCREEN-MODE
PERFORM UNTIL WS-END
EVALUATE TRUE
WHEN WS-MODE-HEADER
PERFORM 1000-HEADER-PROCESS
WHEN WS-MODE-DETAIL
PERFORM 2000-DETAIL-PROCESS
WHEN OTHER
MOVE 'Y' TO WS-END-FLG
END-EVALUATE
END-PERFORM
PERFORM 9900-CLOSE-FILES
MOVE 0 TO RETURN-CODE
GOBACK.
*==========================================================
* ヘッダ画面処理
*==========================================================
1000-HEADER-PROCESS.
PERFORM 1100-DISP-HEADER
PERFORM 1200-RECV-HEADER
EVALUATE TRUE
WHEN WS-F03
MOVE 'Y' TO WS-END-FLG
WHEN WS-F05
PERFORM 1300-INQUIRY
WHEN WS-F06
PERFORM 1400-NEW-ORDER
WHEN WS-F10
PERFORM 1500-DELETE-FROM-HEADER
WHEN WS-F12
PERFORM 9100-INIT-SCREEN
WHEN OTHER
MOVE MSG-ORDNO-REQ TO WS-MSGLIN
END-EVALUATE.
*==========================================================
* ヘッダ画面表示
*==========================================================
1100-DISP-HEADER.
MOVE SPACES TO ORDDSP-REC.
MOVE WS-MSGLIN
TO MSGLIN OF HEADER.
WRITE ORDDSP-REC
FORMAT IS 'HEADER'.
MOVE SPACES TO WS-MSGLIN.
*==========================================================
* ヘッダ画面入力
*==========================================================
1200-RECV-HEADER.
MOVE B"0" TO IN03 IN04 IN05 IN06
IN08 IN10 IN12.
READ ORDDSP-REC
FORMAT IS 'HEADER'
INDICATORS ARE WS-INDICATORS.
MOVE ORDNO OF HEADER TO WS-ORDNO.
*==========================================================
* 受注照会
*==========================================================
1300-INQUIRY.
IF WS-ORDNO = SPACES
MOVE MSG-ORDNO-REQ TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
MOVE WS-ORDNO TO HD-ORDNO.
READ ORDHDR
KEY IS HD-ORDNO
INVALID KEY
MOVE MSG-NOT-FOUND TO WS-MSGLIN
EXIT PARAGRAPH
END-READ.
IF WS-HDRSTS NOT = '00'
MOVE MSG-IO-ERROR TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
PERFORM 8100-LOAD-SCREEN-FROM-HDR
PERFORM 8200-LOAD-DTL-FROM-FILE
MOVE 'U' TO WS-OP-MODE
MOVE 'D' TO WS-SCREEN-MODE.
*==========================================================
* 新規受注
*==========================================================
1400-NEW-ORDER.
PERFORM 9100-INIT-SCREEN
PERFORM 8300-GET-TODAY
MOVE WS-TODAY TO WS-ORDDAT
MOVE 'N' TO WS-OP-MODE
MOVE 'D' TO WS-SCREEN-MODE.
*==========================================================
* ヘッダ画面からの削除
*==========================================================
1500-DELETE-FROM-HEADER.
IF WS-ORDNO = SPACES
MOVE MSG-ORDNO-REQ TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
MOVE WS-ORDNO TO HD-ORDNO.
READ ORDHDR
KEY IS HD-ORDNO
INVALID KEY
MOVE MSG-NOT-FOUND TO WS-MSGLIN
EXIT PARAGRAPH
END-READ.
PERFORM 8100-LOAD-SCREEN-FROM-HDR
PERFORM 8200-LOAD-DTL-FROM-FILE
MOVE 'D' TO WS-SCREEN-MODE
PERFORM 2600-DELETE-ORDER.
*==========================================================
* 明細画面処理
*==========================================================
2000-DETAIL-PROCESS.
PERFORM 2100-CALC-TOTALS
PERFORM 2200-DISP-DETAIL
PERFORM 2300-RECV-DETAIL
EVALUATE TRUE
WHEN WS-F03
MOVE 'Y' TO WS-END-FLG
WHEN WS-F05
MOVE 'H' TO WS-SCREEN-MODE
WHEN WS-F06
PERFORM 1400-NEW-ORDER
WHEN WS-F08
MOVE MSG-DTL-MAX TO WS-MSGLIN
WHEN WS-F10
PERFORM 2600-DELETE-ORDER
WHEN WS-F12
MOVE 'H' TO WS-SCREEN-MODE
PERFORM 9100-INIT-SCREEN
WHEN OTHER
IF WS-OP-INQUIRY
MOVE MSG-INQUIRY TO WS-MSGLIN
ELSE
PERFORM 2400-VALIDATE-INPUT
IF WS-MSGLIN = SPACES
PERFORM 2500-SAVE-ORDER
END-IF
END-IF
END-EVALUATE.
*==========================================================
* 合計計算
*==========================================================
2100-CALC-TOTALS.
MOVE ZERO TO WS-SUBTOT
MOVE ZERO TO WS-TAXTOT
MOVE ZERO TO WS-GRANDTL
PERFORM VARYING DL-IDX FROM 1 BY 1
UNTIL DL-IDX > WS-MAX-DTL
IF WS-ITMCD(DL-IDX) NOT = SPACES
COMPUTE WS-AMT(DL-IDX) =
WS-QTY(DL-IDX) * WS-UPR(DL-IDX)
COMPUTE WS-TAX(DL-IDX) ROUNDED =
WS-AMT(DL-IDX) * WS-TAX-RATE
ADD WS-AMT(DL-IDX)
TO WS-SUBTOT
ADD WS-TAX(DL-IDX)
TO WS-TAXTOT
END-IF
END-PERFORM
COMPUTE WS-GRANDTL =
WS-SUBTOT + WS-TAXTOT.
*==========================================================
* 明細画面表示
*==========================================================
2200-DISP-DETAIL.
MOVE SPACES TO ORDDSP-REC.
MOVE WS-ORDNO
TO ORDNO OF ORDDET.
MOVE WS-ORDDAT
TO ORDDAT OF ORDDET.
MOVE WS-CUSCD
TO CUSCD OF ORDDET.
MOVE WS-CUSNM
TO CUSNM OF ORDDET.
MOVE WS-EMPCD
TO EMPCD OF ORDDET.
MOVE WS-EMPNM
TO EMPNM OF ORDDET.
MOVE WS-DLVADR
TO DLVADR OF ORDDET.
MOVE WS-DUEDAT
TO DUEDAT OF ORDDET.
MOVE WS-RMRK
TO RMRK OF ORDDET.
MOVE WS-ORDSTS
TO ORDSTS OF ORDDET.
MOVE WS-ORDSTNM
TO ORDSTNM OF ORDDET.
MOVE WS-ITMCD(1) TO ITMCD1 OF ORDDET.
MOVE WS-ITMNM(1) TO ITMNM1 OF ORDDET.
MOVE WS-QTY(1) TO QTY1 OF ORDDET.
MOVE WS-UPR(1) TO UPR1 OF ORDDET.
MOVE WS-AMT(1) TO AMT1 OF ORDDET.
MOVE WS-TAX(1) TO TAX1 OF ORDDET.
MOVE WS-ITMCD(2) TO ITMCD2 OF ORDDET.
MOVE WS-ITMNM(2) TO ITMNM2 OF ORDDET.
MOVE WS-QTY(2) TO QTY2 OF ORDDET.
MOVE WS-UPR(2) TO UPR2 OF ORDDET.
MOVE WS-AMT(2) TO AMT2 OF ORDDET.
MOVE WS-TAX(2) TO TAX2 OF ORDDET.
MOVE WS-ITMCD(3) TO ITMCD3 OF ORDDET.
MOVE WS-ITMNM(3) TO ITMNM3 OF ORDDET.
MOVE WS-QTY(3) TO QTY3 OF ORDDET.
MOVE WS-UPR(3) TO UPR3 OF ORDDET.
MOVE WS-AMT(3) TO AMT3 OF ORDDET.
MOVE WS-TAX(3) TO TAX3 OF ORDDET.
MOVE WS-ITMCD(4) TO ITMCD4 OF ORDDET.
MOVE WS-ITMNM(4) TO ITMNM4 OF ORDDET.
MOVE WS-QTY(4) TO QTY4 OF ORDDET.
MOVE WS-UPR(4) TO UPR4 OF ORDDET.
MOVE WS-AMT(4) TO AMT4 OF ORDDET.
MOVE WS-TAX(4) TO TAX4 OF ORDDET.
MOVE WS-ITMCD(5) TO ITMCD5 OF ORDDET.
MOVE WS-ITMNM(5) TO ITMNM5 OF ORDDET.
MOVE WS-QTY(5) TO QTY5 OF ORDDET.
MOVE WS-UPR(5) TO UPR5 OF ORDDET.
MOVE WS-AMT(5) TO AMT5 OF ORDDET.
MOVE WS-TAX(5) TO TAX5 OF ORDDET.
MOVE WS-SUBTOT
TO SUBTOT OF ORDDET.
MOVE WS-TAXTOT
TO TAXTOT OF ORDDET.
MOVE WS-GRANDTL
TO GRANDTL OF ORDDET.
MOVE WS-MSGLIN
TO MSGLIN OF ORDDET.
WRITE ORDDSP-REC
FORMAT IS 'ORDDET'.
MOVE SPACES TO WS-MSGLIN.
*==========================================================
* 明細画面入力
*==========================================================
2300-RECV-DETAIL.
MOVE B"0" TO IN03 IN04 IN05 IN06
IN08 IN10 IN12.
READ ORDDSP-REC
FORMAT IS 'ORDDET'
INDICATORS ARE WS-INDICATORS.
MOVE ORDNO OF ORDDET
TO WS-ORDNO.
MOVE ORDDAT OF ORDDET
TO WS-ORDDAT.
MOVE CUSCD OF ORDDET
TO WS-CUSCD.
MOVE EMPCD OF ORDDET
TO WS-EMPCD.
MOVE DLVADR OF ORDDET
TO WS-DLVADR.
MOVE DUEDAT OF ORDDET
TO WS-DUEDAT.
MOVE RMRK OF ORDDET
TO WS-RMRK.
MOVE ITMCD1 OF ORDDET TO WS-ITMCD(1).
MOVE QTY1 OF ORDDET TO WS-QTY(1).
MOVE UPR1 OF ORDDET TO WS-UPR(1).
MOVE ITMCD2 OF ORDDET TO WS-ITMCD(2).
MOVE QTY2 OF ORDDET TO WS-QTY(2).
MOVE UPR2 OF ORDDET TO WS-UPR(2).
MOVE ITMCD3 OF ORDDET TO WS-ITMCD(3).
MOVE QTY3 OF ORDDET TO WS-QTY(3).
MOVE UPR3 OF ORDDET TO WS-UPR(3).
MOVE ITMCD4 OF ORDDET TO WS-ITMCD(4).
MOVE QTY4 OF ORDDET TO WS-QTY(4).
MOVE UPR4 OF ORDDET TO WS-UPR(4).
MOVE ITMCD5 OF ORDDET TO WS-ITMCD(5).
MOVE QTY5 OF ORDDET TO WS-QTY(5).
MOVE UPR5 OF ORDDET TO WS-UPR(5).
*==========================================================
* 入力チェック
*==========================================================
2400-VALIDATE-INPUT.
MOVE SPACES TO WS-MSGLIN
MOVE ZERO TO WS-DTL-CNT.
*----------------------------------------------------------
* 受注番号
*----------------------------------------------------------
IF WS-ORDNO = SPACES
MOVE MSG-ORDNO-REQ TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
*----------------------------------------------------------
* 受注日
*----------------------------------------------------------
IF WS-ORDDAT NOT NUMERIC
MOVE MSG-ORDDAT-ERR TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
*----------------------------------------------------------
* 得意先
*----------------------------------------------------------
IF WS-CUSCD = SPACES
MOVE MSG-CUSCD-REQ TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
MOVE WS-CUSCD TO CS-CUSCD.
READ CUSTMST
KEY IS CS-CUSCD
INVALID KEY
MOVE MSG-CUSCD-ERR TO WS-MSGLIN
EXIT PARAGRAPH
END-READ.
IF WS-CUSSTS NOT = '00'
MOVE MSG-IO-ERROR TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
IF CS-CUSTSTS NOT = '1'
MOVE MSG-CUSCD-ERR TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
MOVE CS-CUSNM TO WS-CUSNM.
*----------------------------------------------------------
* 明細
*----------------------------------------------------------
PERFORM VARYING DL-IDX FROM 1 BY 1
UNTIL DL-IDX > WS-MAX-DTL
IF WS-ITMCD(DL-IDX) NOT = SPACES
ADD 1 TO WS-DTL-CNT
MOVE WS-ITMCD(DL-IDX)
TO IT-ITMCD
READ ITMMST
KEY IS IT-ITMCD
INVALID KEY
MOVE MSG-ITMCD-ERR
TO WS-MSGLIN
EXIT PARAGRAPH
END-READ
IF WS-ITMSTS NOT = '00'
MOVE MSG-IO-ERROR
TO WS-MSGLIN
EXIT PARAGRAPH
END-IF
IF IT-ITMSTS NOT = '1'
MOVE MSG-ITMCD-ERR
TO WS-MSGLIN
EXIT PARAGRAPH
END-IF
MOVE IT-ITMNM
TO WS-ITMNM(DL-IDX)
IF WS-UPR(DL-IDX) = ZERO
MOVE IT-STDPRC
TO WS-UPR(DL-IDX)
END-IF
IF WS-QTY(DL-IDX) <= ZERO
MOVE MSG-QTY-ERR
TO WS-MSGLIN
EXIT PARAGRAPH
END-IF
END-IF
END-PERFORM.
*----------------------------------------------------------
* 明細0件チェック
*----------------------------------------------------------
IF WS-DTL-CNT = ZERO
MOVE MSG-DETAIL-REQ TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
*==========================================================
* 登録／更新
*==========================================================
2500-SAVE-ORDER.
PERFORM 8300-GET-TODAY.
*----------------------------------------------------------
* 既存受注チェック
*----------------------------------------------------------
MOVE WS-ORDNO TO HD-ORDNO.
READ ORDHDR
KEY IS HD-ORDNO
INVALID KEY
MOVE 'N' TO WS-DTL-EXISTS
NOT INVALID KEY
MOVE 'Y' TO WS-DTL-EXISTS
END-READ.
*----------------------------------------------------------
* 新規モード
*----------------------------------------------------------
IF WS-OP-NEW
IF WS-DTL-EXISTS = 'Y'
MOVE MSG-ALREADY-EXISTS TO WS-MSGLIN
EXIT PARAGRAPH
END-IF
END-IF.
*----------------------------------------------------------
* 更新モード
*----------------------------------------------------------
IF WS-OP-UPDATE
IF WS-DTL-EXISTS = 'N'
MOVE MSG-NOT-FOUND TO WS-MSGLIN
EXIT PARAGRAPH
END-IF
END-IF.
*----------------------------------------------------------
* ヘッダ設定
*----------------------------------------------------------
MOVE WS-ORDNO TO HD-ORDNO.
MOVE WS-ORDDAT TO HD-ORDDAT.
MOVE WS-CUSCD TO HD-CUSCD.
MOVE WS-EMPCD TO HD-EMPCD.
MOVE WS-DLVADR TO HD-DLVADR.
MOVE WS-DUEDAT TO HD-DUEDAT.
MOVE WS-RMRK TO HD-RMRK.
MOVE '1' TO HD-ORDSTS.
MOVE WS-TODAY
TO HD-UPDDAT.
MOVE WS-SYSUSER
TO HD-UPDUSR.
*----------------------------------------------------------
* 新規登録
*----------------------------------------------------------
IF WS-OP-NEW
MOVE WS-TODAY
TO HD-REGDAT
MOVE WS-SYSUSER
TO HD-REGUSR
WRITE ORDHDR-REC
IF WS-HDRSTS NOT = '00'
MOVE MSG-IO-ERROR TO WS-MSGLIN
EXIT PARAGRAPH
END-IF
ELSE
*----------------------------------------------------------
* 更新
*----------------------------------------------------------
REWRITE ORDHDR-REC
IF WS-HDRSTS NOT = '00'
MOVE MSG-IO-ERROR TO WS-MSGLIN
EXIT PARAGRAPH
END-IF
END-IF.
*----------------------------------------------------------
* 更新時は既存明細を削除
*----------------------------------------------------------
IF WS-OP-UPDATE
PERFORM 8400-DELETE-DTL
IF WS-DTLSTS NOT = '00'
AND WS-DTLSTS NOT = '10'
MOVE MSG-IO-ERROR TO WS-MSGLIN
EXIT PARAGRAPH
END-IF
END-IF.
*----------------------------------------------------------
* 明細登録
*----------------------------------------------------------
PERFORM VARYING DL-IDX FROM 1 BY 1
UNTIL DL-IDX > WS-MAX-DTL
IF WS-ITMCD(DL-IDX) NOT = SPACES
MOVE WS-ORDNO
TO DT-ORDNO
MOVE DL-IDX
TO DT-DTLNO
MOVE WS-ITMCD(DL-IDX)
TO DT-ITMCD
MOVE WS-QTY(DL-IDX)
TO DT-QTY
MOVE WS-UPR(DL-IDX)
TO DT-UPR
COMPUTE DT-AMT =
WS-QTY(DL-IDX) *
WS-UPR(DL-IDX)
COMPUTE DT-TAX ROUNDED =
DT-AMT * WS-TAX-RATE
WRITE ORDDTL-REC
IF WS-DTLSTS NOT = '00'
MOVE MSG-IO-ERROR
TO WS-MSGLIN
EXIT PARAGRAPH
END-IF
END-IF
END-PERFORM.
*----------------------------------------------------------
* 画面更新
*----------------------------------------------------------
IF WS-OP-NEW
MOVE MSG-SAVED TO WS-MSGLIN
ELSE
MOVE MSG-UPDATED TO WS-MSGLIN
END-IF.
MOVE '1' TO WS-ORDSTS.
MOVE '確認済 ' TO WS-ORDSTNM.
*==========================================================
* 削除
*==========================================================
2600-DELETE-ORDER.
IF WS-ORDNO = SPACES
MOVE MSG-ORDNO-REQ TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
*----------------------------------------------------------
* 対象受注存在確認
*----------------------------------------------------------
MOVE WS-ORDNO TO HD-ORDNO.
READ ORDHDR
KEY IS HD-ORDNO
INVALID KEY
MOVE MSG-NOT-FOUND TO WS-MSGLIN
EXIT PARAGRAPH
END-READ.
*----------------------------------------------------------
* 削除確認
*----------------------------------------------------------
MOVE MSG-DELETE-CONF TO WS-MSGLIN.
PERFORM 2200-DISP-DETAIL
MOVE B"0" TO IN03 IN04 IN05 IN06
IN08 IN10 IN12.
READ ORDDSP-REC
FORMAT IS 'ORDDET'
INDICATORS ARE WS-INDICATORS.
* F12 = 取消
IF WS-F12
MOVE SPACES TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
* F3 = 終了の場合も削除しない
IF WS-F03
MOVE 'Y' TO WS-END-FLG
EXIT PARAGRAPH
END-IF.
*----------------------------------------------------------
* ヘッダ削除
*----------------------------------------------------------
DELETE ORDHDR-REC
IF WS-HDRSTS NOT = '00'
MOVE MSG-IO-ERROR TO WS-MSGLIN
EXIT PARAGRAPH
END-IF.
*----------------------------------------------------------
* 明細削除
*----------------------------------------------------------
PERFORM 8400-DELETE-DTL
MOVE MSG-DELETED TO WS-MSGLIN
PERFORM 9100-INIT-SCREEN
MOVE 'H' TO WS-SCREEN-MODE.
*==========================================================
* ヘッダ→画面
*==========================================================
8100-LOAD-SCREEN-FROM-HDR.
MOVE HD-ORDNO
TO WS-ORDNO.
MOVE HD-ORDDAT
TO WS-ORDDAT.
MOVE HD-CUSCD
TO WS-CUSCD.
MOVE HD-EMPCD
TO WS-EMPCD.
MOVE HD-DLVADR
TO WS-DLVADR.
MOVE HD-DUEDAT
TO WS-DUEDAT.
MOVE HD-RMRK
TO WS-RMRK.
MOVE HD-ORDSTS
TO WS-ORDSTS.
EVALUATE HD-ORDSTS
WHEN '0'
MOVE '入力中 ' TO WS-ORDSTNM
WHEN '1'
MOVE '確認済 ' TO WS-ORDSTNM
WHEN '2'
MOVE '受注済 ' TO WS-ORDSTNM
WHEN '9'
MOVE 'キャンセル' TO WS-ORDSTNM
WHEN OTHER
MOVE '不明 ' TO WS-ORDSTNM
END-EVALUATE.
* 得意先名
MOVE WS-CUSCD TO CS-CUSCD.
READ CUSTMST
KEY IS CS-CUSCD
INVALID KEY
MOVE SPACES TO WS-CUSNM
NOT INVALID KEY
MOVE CS-CUSNM TO WS-CUSNM
END-READ.
* 担当者マスタは今回のPF一覧に存在しないため
* 担当者名は空白とする
MOVE SPACES TO WS-EMPNM.
*==========================================================
* 明細ファイル→画面
*==========================================================
8200-LOAD-DTL-FROM-FILE.
PERFORM VARYING DL-IDX FROM 1 BY 1
UNTIL DL-IDX > WS-MAX-DTL
INITIALIZE WS-DTL-LINE(DL-IDX)
END-PERFORM.
MOVE WS-ORDNO TO DT-ORDNO
MOVE 1 TO DT-DTLNO
START ORDDTL
KEY IS NOT LESS THAN DT-KEY
INVALID KEY
EXIT PARAGRAPH
END-START.
PERFORM UNTIL WS-DTLSTS NOT = '00'
READ ORDDTL NEXT RECORD
AT END
MOVE '10' TO WS-DTLSTS
END-READ
IF WS-DTLSTS = '00'
IF DT-ORDNO NOT = WS-ORDNO
MOVE '99' TO WS-DTLSTS
ELSE
IF DT-DTLNO <= WS-MAX-DTL
MOVE DT-ITMCD
TO WS-ITMCD(DT-DTLNO)
MOVE DT-QTY
TO WS-QTY(DT-DTLNO)
MOVE DT-UPR
TO WS-UPR(DT-DTLNO)
MOVE DT-AMT
TO WS-AMT(DT-DTLNO)
MOVE DT-TAX
TO WS-TAX(DT-DTLNO)
MOVE DT-ITMCD
TO IT-ITMCD
READ ITMMST
KEY IS IT-ITMCD
INVALID KEY
MOVE SPACES
TO WS-ITMNM(DT-DTLNO)
NOT INVALID KEY
MOVE IT-ITMNM
TO WS-ITMNM(DT-DTLNO)
END-READ
END-IF
END-IF
END-IF
END-PERFORM.
*==========================================================
* 今日取得
*==========================================================
8300-GET-TODAY.
MOVE FUNCTION CURRENT-DATE(1:8)
TO WS-TODAY.
*==========================================================
* 明細削除
*==========================================================
8400-DELETE-DTL.
MOVE WS-ORDNO TO DT-ORDNO
MOVE 1 TO DT-DTLNO
START ORDDTL
KEY IS NOT LESS THAN DT-KEY
INVALID KEY
MOVE '10' TO WS-DTLSTS
EXIT PARAGRAPH
END-START.
PERFORM UNTIL WS-DTLSTS NOT = '00'
READ ORDDTL NEXT RECORD
AT END
MOVE '10' TO WS-DTLSTS
END-READ
IF WS-DTLSTS = '00'
IF DT-ORDNO NOT = WS-ORDNO
MOVE '10' TO WS-DTLSTS
ELSE
DELETE ORDDTL-REC
END-IF
END-IF
END-PERFORM.
*==========================================================
* ファイルOPEN
*==========================================================
9000-OPEN-FILES.
OPEN I-O ORDDSP.
IF WS-DSPSTS NOT = '00'
MOVE MSG-OPEN-ERROR TO WS-MSGLIN
MOVE 2 TO RETURN-CODE
MOVE 'Y' TO WS-END-FLG
EXIT PARAGRAPH
END-IF.
MOVE 'Y' TO WS-DSP-OPEN.
OPEN I-O ORDHDR.
IF WS-HDRSTS NOT = '00'
MOVE MSG-OPEN-ERROR TO WS-MSGLIN
MOVE 2 TO RETURN-CODE
MOVE 'Y' TO WS-END-FLG
EXIT PARAGRAPH
END-IF.
MOVE 'Y' TO WS-HDR-OPEN.
OPEN I-O ORDDTL.
IF WS-DTLSTS NOT = '00'
MOVE MSG-OPEN-ERROR TO WS-MSGLIN
MOVE 2 TO RETURN-CODE
MOVE 'Y' TO WS-END-FLG
EXIT PARAGRAPH
END-IF.
MOVE 'Y' TO WS-DTL-OPEN.
OPEN INPUT CUSTMST.
IF WS-CUSSTS NOT = '00'
MOVE MSG-OPEN-ERROR TO WS-MSGLIN
MOVE 2 TO RETURN-CODE
MOVE 'Y' TO WS-END-FLG
EXIT PARAGRAPH
END-IF.
MOVE 'Y' TO WS-CUS-OPEN.
OPEN INPUT ITMMST.
IF WS-ITMSTS NOT = '00'
MOVE MSG-OPEN-ERROR TO WS-MSGLIN
MOVE 2 TO RETURN-CODE
MOVE 'Y' TO WS-END-FLG
EXIT PARAGRAPH
END-IF.
MOVE 'Y' TO WS-ITM-OPEN.
*==========================================================
* 画面初期化
*==========================================================
9100-INIT-SCREEN.
INITIALIZE WS-SCREEN.
MOVE SPACES TO WS-MSGLIN.
MOVE 'N' TO WS-OP-MODE.
MOVE '0' TO WS-ORDSTS.
MOVE '入力中 ' TO WS-ORDSTNM.
*==========================================================
* ファイルCLOSE
*==========================================================
9900-CLOSE-FILES.
IF WS-DSP-OPEN = 'Y'
CLOSE ORDDSP
END-IF.
IF WS-HDR-OPEN = 'Y'
CLOSE ORDHDR
END-IF.
IF WS-DTL-OPEN = 'Y'
CLOSE ORDDTL
END-IF.
IF WS-CUS-OPEN = 'Y'
CLOSE CUSTMST
END-IF.
IF WS-ITM-OPEN = 'Y'
CLOSE ITMMST
END-IF.
当記事の著作権はIBMに帰属します。詳細はこちらを参照ください。