标题: 随便写写 [打印本页] 作者: goodbilly 时间: 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*