免费注册 查看新帖 |

Chinaunix

  平台 论坛 博客 文库
最近访问板块 发新帖
查看: 9656 | 回复: 0

随便写写 [复制链接]

论坛徽章:
0
发表于 2017-05-03 17:21 |显示全部楼层
H             DEBUG(*YES)
     HDATFMT(*YMD) DATEDIT(*MDY)
     H*=========================================================================
     H*   System       : Kin Yat MIS System                                    *
     H*                                                                        *
     H*   Program ID   - INV068D1                                              *
     H*   Program Name -維護IQC自動轉倉物料編號                            *
     H*   Create By    - Billy                                                 *
     H*   Create Date  - 11Apr2016                                             *
     H*                                                                        *
     H*   BMR     Date  Description                                            *
     H*  ----  -------  -------------------------------------------------------*
     F*=========================================================================
     F*
     FINV068F1  CF   E             WORKSTN
     F                                     SFILE(DSPS1:RRNF1)
     FIIML01    IF   E           K DISK
     FILMRL01   IF   E           K DISK
     FIQML02    IF   E           K DISK
     FZPAL01    IF   E           K DISK
     F*
     D*=========================================================================
     D*
     D                SDS
     D @PGM                  001    010
     D @PARMS                037    039  0
     D @MSGID                 40     46
     D @MSGDTA                91    170
     D @JOB                  244    253
     D @USER                 254    263
     D @JOB#                 264    269  0
     D*
     D TOPOS           S              2  0 INZ(8)
     D TOCRT           S              2  0 INZ(1)
     D TOAMD           S              2  0 INZ(2)
     D TODEL           S              2  0 INZ(4)
     D TODSP           S              2  0 INZ(5)
     D P1AUDT          S              1    INZ('1')
     D P1TRM           S              2    INZ('  ')
     D*
     C*=========================================================================
     C* Pre-mainline processing.
     C*=========================================================================
     C*
     C                   MOVE      'N'           ERROR             1
     C                   MOVE      'N'           RFRESH            1
     C                   MOVE      *ZEROS        Q#ACT
     C                   MOVE      *BLANKS       Q#PROD
     C                   MOVE      *LOVAL        K1PROD           35
     C*
     C     KLS001        KLIST
     C                   KFLD                    W#WHS
     C                   KFLD                    W#LOC
     C*
     C     'COMPANY '    CHAIN     ZPAL01
     C                   EVAL      SCR0101 = %SUBST(DATA:1:40)
     C*
     C                   EXSR      S1CLSF
     C                   EXSR      S1LDSF
     C*
     C     1             DOWEQ     1
     C*
     C                   IF        RFRESH = 'Y'
     C                   EXSR      S1CLSF
     C                   EXSR      S1LDSF
     C                   MOVE      'N'           RFRESH
     C                   ENDIF
     C*
     C                   EXSR      S1DPSF
     C                   MOVE      'N'           ERROR             1
     C                   EVAL      *IN21 = '0'
     C                   EVAL      *IN31 = '0'
     C                   EVAL      *IN32 = '0'
     C                   EVAL      *IN33 = '0'
     C                   EVAL      *IN34 = '0'
      *
     C                   IF        *IN03 = '1'
     C                   LEAVE
     C                   ENDIF
      *
     C                   IF        *IN05 = '1'
     C                   MOVE      *LOVAL        K1PROD
     C                   MOVE      'Y'           RFRESH
     C                   GOTO      T#REFRESH
     C                   ENDIF
     C*
     C* Process 1st line action
     C*
     C* To Create
     C                   IF        Q#ACT   = TOCRT
     C                   IF        Q#PROD  = *BLANKS
     C                   EVAL      *IN21   = '1'
     C                   EVAL      *IN31   = '1'
     C                   MOVE      'Y'           ERROR
     C                   ELSE
     C     Q#PROD        CHAIN     IIML01
     C                   IF        NOT %FOUND(IIML01)
     C                   EVAL      *IN21   = '1'
     C                   EVAL      *IN34   = '1'
     C                   MOVE      'Y'           ERROR
     C                   ELSE
     C     Q#PROD        CHAIN     IQML02
     C                   IF        %FOUND(IQML02)
     C                   EVAL      *IN21   = '1'
     C                   EVAL      *IN32   = '1'
     C                   MOVE      'Y'           ERROR
     C                   ELSE
     C                   CALL      'INV068D2'
     C                   PARM                    Q#ACT
     C                   PARM                    Q#PROD
     C                   PARM                    P1AUDT
     C                   PARM                    P1TRM
     C                   ENDIF
     C                   ENDIF
     C                   ENDIF
     C                   ENDIF
     C*
     C* To Amend or Delete or Display
     C                   IF        Q#ACT = TOAMD OR Q#ACT = TODEL OR
     C                             Q#ACT = TODSP
     C                   IF        Q#PROD  = *BLANKS
     C                   EVAL      *IN21 = '1'
     C                   EVAL      *IN31   = '1'
     C                   EVAL      ERROR   = 'Y'
     C                   ELSE
     C     Q#PROD        CHAIN     IQML02
     C                   IF        NOT %FOUND(IQML02)
     C                   EVAL      *IN21 = '1'
     C                   EVAL      *IN33   = '1'
     C                   EVAL      ERROR   = 'Y'
     C                   ELSE
     C                   CALL      'INV068D2'
     C                   PARM                    Q#ACT
     C                   PARM                    Q#PROD
     C                   PARM                    P1AUDT
     C                   PARM                    P1TRM
     C                   ENDIF
     C                   ENDIF
     C                   ENDIF
     C*
     C* To Position
     C                   IF        Q#ACT = TOPOS
     C                   IF        Q#PROD  <> *BLANKS
     C                   MOVE      *ZEROS        Q#ACT
     C                   MOVE      Q#PROD        K1PROD
     C                   MOVE      *BLANKS       Q#PROD
     C                   EVAL      RFRESH  = 'Y'
     C                   ELSE
     C                   MOVE      *ZEROS        Q#ACT
     C                   MOVE      *LOVAL        K1PROD
     C                   MOVE      *BLANKS       Q#PROD
     C                   EVAL      RFRESH  = 'Y'
     C                   ENDIF
     C                   ENDIF
     C*
     C                   IF        RRNF1 > 0 AND ERROR <> 'Y'
     C*
     C     RRNF1         CHAIN     DSPS1                              70
     C                   DOW       *IN70 = *OFF
     C                   IF        W#ACT <> *ZEROS
     C                   SELECT
     C                   WHEN      W#ACT = TOPOS
     C                   MOVE      'Y'           RFRESH
     C                   MOVE      W#PROD        K1PROD
     C                   LEAVE
     C                   WHEN      W#ACT <> TOPOS
     C                   CALL      'INV068D2'
     C                   PARM                    W#ACT
     C                   PARM                    W#PROD
     C                   PARM                    P1AUDT
     C                   PARM                    P1TRM
     C                   ENDSL
     C                   ENDIF
     C                   EVAL      RRNF1 = RRNF1 + 1
     C     RRNF1         CHAIN     DSPS1                              70
     C                   ENDDO
     C*
     C                   ENDIF
     C*
     C     T#REFRESH     TAG
     C                   ENDDO
     C*
     C                   MOVEL     *ON           *INLR
     C*
     C******************************************************************
     C* S2CLSF - Clear Subfile Screen
     C******************************************************************
     C     S1CLSF        BEGSR
     C                   MOVE      '0'           *IN92
     C                   MOVE      '0'           *IN93
     C                   MOVE      '1'           *IN94
     C                   WRITE     DSPC1
     C                   MOVE      '1'           *IN92
     C                   MOVE      '1'           *IN93
     C                   MOVE      '0'           *IN94
     C                   Z-ADD     0             RRNF1
     C                   ENDSR
     C*****************************************************************
     C* S1LDSF - Load Records To Subfile Screen
     C*****************************************************************
     C     S1LDSF        BEGSR
      *
     C     K1PROD        SETLL     IQML02
     C                   READ      IQML02
     C                   DOW       NOT %EOF(IQML02)
     C                   EVAL      W#ACT    = *ZEROS
     C                   EVAL      W#PROD   = ICPROD
     C                   EVAL      W#WHS    = ICWHS
     C                   EVAL      W#LOC    = ICLOC
     C     KLS001        CHAIN     ILMRL01
     C                   EVAL      W#LDESC  = LDESCR
     C                   IF        ICID     = 'IC'
     C                   EVAL      W#STATUS = 'Active(有效)'
     C                   ELSE
     C                   EVAL      W#STATUS = 'Inactive(無效)'
     C                   ENDIF
     C                   ADD       1             RRNF1             4 0
     C                   WRITE     DSPS1
     C     RRNF1         IFEQ      1000
     C                   LEAVE
     C                   ENDIF
     C                   READ      IQML02
     C                   ENDDO
      *
     C     RRNF1         IFEQ      0
     C                   MOVE      '0'           *IN92
     C                   MOVE      '1'           *IN93
     C                   MOVE      '1'           *IN69
     C                   ELSE
     C                   MOVE      '1'           *IN92
     C                   MOVE      '1'           *IN93
     C                   MOVE      '1'           *IN69
     C                   ENDIF
      *
     C                   ENDSR
     C*****************************************************************
     C* S2DPSF  - DISPLAY PROMPT WINDOW
     C*****************************************************************
     C     S1DPSF        BEGSR
     C*
     C     RRNF1         IFNE      0
     C                   Z-ADD     1             RRNF1
     C                   ENDIF
     C*
     C                   WRITE     DSPC1
     C                   WRITE     DSPK1
     C                   EXFMT     DSPC1
     C                   ENDSR
     C*

H*=========================================================================
     H*   System       : Kin Yat MIS System                                    *
     H*                                                                        *
     H*   Program ID   - INV068D2                                              *
     H*   Program Name - INV068D2-維護IQC自動轉倉物料編號                  *
     H*   Create By    - Billy                                                 *
     H*   Create Date  - 11Apr2016                                             *
     H*                                                                        *
     H*   BMR     Date  Description                                            *
     H*  ----  -------  -------------------------------------------------------*
     H*   20170422 - HAOCHEN(CH01)
     F*=========================================================================
     F*
     FINV068F2  CF   E             WORKSTN
     F*
     FIWML01    IF   E           K DISK
     F*
     FILML01    IF   E           K DISK
     F*
     FZPAL01    IF   E           K DISK
     F*
     FIQML02    UF A E           K DISK
     F*
     D*=========================================================================
     D*
     D                SDS
     D @PGM                  001    010
     D @PARMS                037    039  0
     D @MSGID                 40     46
     D @MSGDTA                91    170
     D @JOB                  244    253
     D @USER                 254    263
     D @JOB#                 264    269  0
     D*
     D* formational data structure  Message subfile
     D*
     D                 DS                        INZ
     D STKCNT                001    004B 0
     D DTALEN                005    008B 0
     D ERRCOD                009    012B 0
     D*
     D ERR1            S              1    INZ(' ')
     D*
     C*=========================================================================
     C* Pre-mainline processing.                                               *
     C*=========================================================================
     C*
     C                   Movel(p)  @PGM          PGMQ
     C                   Z-Add     60            DTALEN
     C*
     C     *ENTRY        PLIST
     C                   PARM                    P1OPT             2 0
     C                   PARM                    P1PROD           35
     C                   PARM                    P1AUDT            1
     C                   PARM                    P1TRM             1
     C*
     C                   EXSR      LOADF
     C*
     C     1             DOWEQ     1
     C
     C                   EXFMT     SCR01
     C                   Exsr      $CLRMSG
     C                   EVAL      *IN11 = '0'
     C                   EVAL      *IN13 = '0'
     C*
     C                   IF        *IN03 = *ON
     C                   LEAVE
     C                   ENDIF
     C*
     C* Check Input Value
     C*
     C                   EXSR      CHKSCR01
     C*
     C* No Error, Update IQML02
     C*
     C                   IF        ERR1 = 'N'
     C                   EXSR      UPDATEF
     C                   LEAVE
     C                   ELSE
     C                   Write     MSGCTL                               99
     C                   ENDIF
     C*
     C                   ENDDO
     C*
     C                   MOVEL     *ON           *INLR
     C*
     C*=========================================================================
     C* LOADF    - Load IQML02 Data File                                       *
     C*=========================================================================
     C*
     C     LOADF         BEGSR
     C*
     C                   EVAL      S1PROD = P1PROD
     C*
     C     'COMPANY '    CHAIN(N)  ZPAL01
     C                   EVAL      SCR0101= %SUBST(DATA:1:40)
     C*
     C                   SELECT
     C                   WHEN      P1OPT = 1
     C                   EVAL      SCR0102= '新增'
     C                   EVAL      S1WHS  = *BLANKS
     C                   EVAL      S1LOC  = *BLANKS
     C                   WHEN      P1OPT = 2
     C     P1PROD        CHAIN(N)  IQML02
     C                   IF        ICID   = 'IC'
     C                   EVAL      SCR0102= '修改'
     C                   ELSE
     C                   EVAL      SCR0102= '恢愎'
     C                   EVAL      *IN12  = '1'
     C                   ENDIF
     C                   EVAL      S1WHS  = ICWHS
     C                   EVAL      S1LOC  = ICLOC
     C                   WHEN      P1OPT = 4
     C     P1PROD        CHAIN(N)  IQML02
     C                   EVAL      SCR0102= '刪除'
     C                   EVAL      *IN12  = '1'
     C                   EVAL      S1WHS  = ICWHS
     C                   EVAL      S1LOC  = ICLOC
     C                   WHEN      P1OPT = 5
     C     P1PROD        CHAIN(N)  IQML02
     C                   EVAL      SCR0102= '查詢'
     C                   EVAL      *IN12  = '1'
     C                   EVAL      S1WHS  = ICWHS
     C                   EVAL      S1LOC  = ICLOC
     C                   ENDSL
     C*
     C                   ENDSR
     C*
     C*=========================================================================
     C* UPDATEF  - Update IQML02 File                                          *
     C*=========================================================================
     C*
     C     UPDATEF       BEGSR
     C*
     C                   SELECT
     C                   WHEN      P1OPT = 1
     C                   EVAL      ICID  = 'IC'
     C                   EVAL      ICPROD= S1PROD
     C                   EVAL      ICWHS = S1WHS
     C                   EVAL      ICLOC = S1LOC
     C                   EVAL      ICCUSER= @USER
     C                   EVAL      ICCDATE= *DATE
     C                   EVAL      ICUUSER= @USER
     C                   EVAL      ICUDATE= *DATE
     C                   WRITE     IQMR
     C                   WHEN      P1OPT = 2
     C     P1PROD        CHAIN     IQML02
     C                   IF        ICID  = 'IC'
     C                   EVAL      ICWHS = S1WHS
     C                   EVAL      ICLOC = S1LOC
     C                   UPDATE    IQMR
     C                   ELSE
CH01 C*                  EVAL      ICID  = 'ID'
CH01 C                   EVAL      ICID  = 'IC'
     C                   UPDATE    IQMR
     C                   ENDIF
     C                   WHEN      P1OPT = 4
     C     P1PROD        CHAIN     IQML02
     C                   EVAL      ICID  = 'ID'
     C                   UPDATE    IQMR
     C                   WHEN      P1OPT = 5
     C                   ENDSL
     C*
     C                   ENDSR
     C*
     C*=========================================================================
     C* CHKSCR01 - Check SCR01 Input Value                                     *
     C*=========================================================================
     C*
     C     CHKSCR01      BEGSR
     C*
     C                   EVAL      ERR1 = 'N'
     C*
     C* Check Input Warehouse
     C*
     C                   IF        S1WHS    = *BLANKS
     C                   Movel     'SSAZ02 '     MSGF
     C                   eval      MSGID = 'UMI0017'
     C                   exsr      $SNDMSG
     C                   EVAL      *IN11 = '1'
     C                   EVAL      ERR1 = 'Y'
     C                   ELSE
     C     S1WHS         CHAIN     IWML01
     C                   IF        NOT %FOUND(IWML01)
     C                   Movel     'SSAZ02 '     MSGF
     C                   eval      MSGID = 'UMD0365'
     C                   exsr      $SNDMSG
     C                   EVAL      *IN11 = '1'
     C                   EVAL      ERR1 = 'Y'
     C                   ENDIF
     C                   ENDIF
     C*
     C* Check Input Location
     C*
     C                   IF        S1LOC    = *BLANKS
     C                   Movel     'SSAZ02 '     MSGF
     C                   eval      MSGID = 'UMI0017'
     C                   exsr      $SNDMSG
     C                   EVAL      *IN13 = '1'
     C                   EVAL      ERR1 = 'Y'
     C                   ELSE
     C                   EVAL      KLSWHS = S1WHS
     C                   EVAL      KLSLOC = S1LOC
     C     KLS001        CHAIN     ILML01
     C                   IF        NOT %FOUND(ILML01)
     C                   Movel     'SSAZ02 '     MSGF
     C                   eval      MSGID = 'UMD0486'
     C                   exsr      $SNDMSG
     C                   EVAL      *IN13 = '1'
     C                   EVAL      ERR1 = 'Y'
     C                   ENDIF
     C                   ENDIF
     C*
     C                   ENDSR
     C*
     C*=========================================================================
     C*    $SndMsg - Send a message to the message subfile                     *
     C*=========================================================================
     C*
     C     $SndMsg       Begsr
     C*
     C                   call      'QMHSNDPM'
     C                   parm                    MSGID
     C                   parm                    MSGF
     C                   parm                    MSGDTA
     C                   parm                    DTALEN
     C                   parm                    MSGTYP
     C                   parm                    PGMQ
     C                   parm                    STKCNT
     C                   parm                    MSGKEY
     C                   Parm                    ERRCOD
     C*
     C                   endsr
     C*
     C*=========================================================================
     C*    $ClrMsg - Clear the messages from the screen                        *
     C*=========================================================================
     C*
     C     $ClrMsg       Begsr
     C*
     C                   call      'QMHRMVPM'
     C                   parm                    PGMQ
     C                   parm                    STKCNT
     C                   parm                    MSGKY
     C                   parm                    MSGRMV
     C                   parm                    ERRCOD
     C*
     C                   endsr
     C*=========================================================================
     C* *INZSR - Initial one time run subroutine                               *
     C*=========================================================================
     C*
     C     *INZSR        Begsr
     C*
     C* Initialize the message subfile fields
     C*
     C                   Movel     *BLANKS       MSGF             20
     C                   Movel     '*LIBL'       MSGLIB           10
     C                   Move      MSGLIB        MSGF
     C                   Move      *blanks       MSGKY            04
     C                   Move      *blanks       MSGDTA           80
     C                   Movel     '*DIAG'       MSGTYP           10
     C                   Movel     '*ALL'        MSGRMV           10
     C                   Movel     *blanks       MSGID            07
     C*
     C     KLS001        KLIST
     C                   KFLD                    KLSWHS            3
     C                   KFLD                    KLSLOC           10
     C*
     C                   Endsr
     C*


您需要登录后才可以回帖 登录 | 注册

本版积分规则 发表回复

  

北京盛拓优讯信息技术有限公司. 版权所有 京ICP备16024965号-6 北京市公安局海淀分局网监中心备案编号:11010802020122 niuxiaotong@pcpop.com 17352615567
未成年举报专区
中国互联网协会会员  联系我们:huangweiwei@itpub.net
感谢所有关心和支持过ChinaUnix的朋友们 转载本站内容请注明原作者名及出处

清除 Cookies - ChinaUnix - Archiver - WAP - TOP