* check the validity of the specific field
* and correction
* 2008/08/21 created by jian
***********************************************
FJIANZ01L UF F 3000 DISK EXTFILE(@FileLoc) USROPN
FYB81010T IF E DISK USROPN
F**YB81040T IF E DISK
F***********************************************
D @OV S 54 DIM(3) PERRCD(1) CTDATA
D @PA S 1 DIM(54)
D @FileLoc S 22
D @LF s 300
D @B c const(X'0E')
D @E c const(X'0F')
D @K c const(X'40')
D RCDS DS 3000
C***********************************************
C EXSR DEFINE
C*
C EXSR LOCAT
C*
C IF @HI = 0 OR @HF = 0
C EVAL *INLR = *ON
C RETURN
C ENDIF
c eval @FileLoc = @libnm + '/' + @filenm
C OPEN JIANZ01L
C READ JIANZ01L RCDS
C DOW NOT %EOF(JIANZ01L)
c***
c exsr checkfld
c if *in51 = *on
c eval %subst(RCDS:@HI:@HF)=%subst(@LF:1:@HF)
c update JIANZ01L RCDS
c endif
c***
C READ JIANZ01L RCDS
C ENDDO
C CLOSE JIANZ01L
C EVAL *INLR = *ON
c****************************************************************
c define begsr
c*
c *entry plist
c parm @libnm 10
c parm @filenm 10
c parm @fldnm 10
c*
c move *blank MBRNAM 10
c endsr
c*
C****************************************************************
C LOCAT BEGSR
c***GET A MEMBER NAME.
C CALL 'YB8102'
C PARM MBRNAM
c***OVERRIDE FILE YB81010T
C MOVEA @OV(1) @PA(1)
C MOVEA MBRNAM @PA(44)
C Z-ADD 54 @LNCMD 15 5
C CALL 'QCMDEXC'
C PARM @PA(01)
C PARM @LNCMD
*
c***OVERRIDE FILE YB81040T
C MOVEA @OV(2) @PA(1)
C MOVEA MBRNAM @PA(44)
C Z-ADD 54 @LNCMD 15 5
C CALL 'QCMDEXC'
C PARM @PA(01)
C PARM @LNCMD
** WRITE FILE FIELD DESCRIPTION TO FILE YB81010T
C CALL 'YB8104'
C PARM @filenm
C PARM MBRNAM
c*
C Z-ADD *ZEROS @HI 5 0
C Z-ADD *ZEROS @HF 5 0
c** open file YB81010T
c open YB81010T
C*
c* *loval setll YB81010T
C READ YB81010T
C DOW NOT %EOF(YB81010T)
C IF @fldnm = WHFLDI
C EVAL @HI = WHIBO
C EVAL @HF = WHFLDB
C LEAVE
C ENDIF
C READ YB81010T
C ENDDO
c** close file YB81010T
c close yb81010t
c** delete override all files
c z-add 17 @lncmd
c call 'QCMDEXC'
C PARM @OV(3)
C PARM @LNCMD
C** delete the temporary member
C CALL 'YB8103'
C PARM MBRNAM
c*
c endsr
C****************************************************************
c checkfld begsr
c*
c z-add *zeros BLOC 4 0
c z-add *zeros ELOC 4 0
c z-add *zeros BLO2 4 0
c z-add *zeros ELO2 4 0
c z-add *zeros @LLC 4 0
c move '0' chkflg 1
c eval *in50 = *off
c eval *in51 = *off
c clear @lf
c** field assignment..
c eval %subst(@LF:1:@HF)=%subst(RCDS:@HI:@HF)
c** deal in a loop.
c z-add 1 X 4 0
c dou *in50 = *on or X >= @HF
c EVAL BLOC = %SCAN(@B:@LF:X)
c*** not found the beginning of double char X'0E'
c*** replace all the X'0F' with blank(X'40')
c**
c tag1 tag
c if BLOC = 0
c dou ELOC = 0
c EVAL ELOC = %SCAN(@B:@LF:X)
c if ELOC > 0
c eval %subst(@LF:ELOC:1) = @K
c N51 eval *in51 = *on
c endif
c enddo
c eval *in50 = *on
c leaveSR
c endif
c** IF FOUND X'0E' AT THE LAST 3 BYTE,REPLACE WITH BLANK..
c**
c if BLOC >= @HF - 2
c eval %subst(@LF:BLOC:@HF-BLOC+1) = *BLANK
c eval *in50 = *on
c leaveSR
C ENDIF
c**
c EVAL ELOC = %SCAN(@E:@LF:BLOC)
c**
c if ELOC = 0
c**** miss the end of double char X'0F'
c**** replace the last byte of the field with X'0F'
c*$$$$$$ eval %subst(@LF:@HF:1) = @E
c eval @LLC = %checkr(' ':@LF:@HF)
c if @LLC = @HF
c eval %subst(@LF:@HF:1) = @E
c elseif @LLC > 0
c eval %subst(@LF:@LLC+1:1) = @E
c endif
c N51 eval *in51 = *on
c**
c**** replace the remain X'0E' with blank(X'40)
c**
c dou BLO2 = 0
c eval BLO2 = %scan(@B:@LF:BLOC+1)
c if BLO2 > 0
c eval %subst(@LF:BLO2:1) = @K
c N51 eval *in51 = *on
c endif
c enddo
c**
c*** leave the subroutine
c eval *in50 = *on
c leavesr
c endif
c*
c**
c if %rem(ELOC-BLOC:2) = 0
c EVAL BLOC = %SCAN(@B:@LF:BLOC+1)
c goto tag1
c endif
c*** the X'0F' before the valid X'0E'
c dou ELO2 > BLOC
c eval ELO2 = %scan(@E:@LF:X)
c if ELO2 = 0 or ELO2 > BLOC
c leave
c endif
c if ELO2 < BLOC
c** eval %subst(@LF:ELO2:1) = @K
c eval %subst(@LF:X:ELO2-X+1) = *blank
c N51 eval *in51 = *on
c endif
c enddo
c*
c*** the X'0E' before the valid X'0E'
c dou ELO2 > BLOC
c eval ELO2 = %scan(@B:@LF:X )
c if ELO2 = 0 or ELO2 >= BLOC
c leave
c endif
c if ELO2 < BLOC
c eval %subst(@LF:ELO2:BLOC-ELO2) = *blank
c N51 eval *in51 = *on
c endif
c enddo
c*
c*** the X'0E' between the valid X'0E' and X'0F'
c dou BLO2 > ELOC
c eval BLO2 = %scan(@B:@LF:BLOC+1)
c if BLO2 = 0 or BLO2 > ELOC
c leave
c endif
c if BLO2 < ELOC
c eval %subst(@LF:BLO2:1) = @K
c N51 eval *in51 = *on
c endif
c enddo
c*
c*
c eval X = ELOC + 1
c*
c*
c
c enddo
c
c endsr
C****************************************************************
**
OVRDBF FILE(YB81010T) TOFILE(YB81010T) MBR( )
OVRDBF FILE(YB81040T) TOFILE(YB81040T) MBR( )
DLTOVR FILE(*ALL)
