H*PARMS DFTACTGRP(*NO) ACTGRP(*CALLER) COMMIT(*NONE) h Debug d*===================================================================== d* PROGRAMA....: SCHINSRC d* DESCRIPCION.: Buscar string en miembro fuente. d* AUTOR.......: Diego M. ACEVEDO -Argentina d* FECHA.......: 24/09/2004 d*===================================================================== fSchinsrcd cf e Workstn Sfile(Sfl1:W0rec1) InfDs(Status) d*---------------------------------------------------------- d* Display File Feedback Data Structure . d*----------------------------------------------------- d Status Ds d W0Aib 1a Overlay(Status:369) d W0crs 370 371b 0 d W0sfPs 378 379b 0 d*---------------------------------------------------------- d* Program information . d*----------------------------------------------------- d sDs d P$$Pgm *Proc d*----------------------------------------------------- d* Send Program Message API. . d*----------------------------------------------------- d qmhsndpm Pr extpgm('QMHSNDPM') d 7a d 20a d 32767a Options(*Varsize) d 10i 0 d 10a d 10a d 10i 0 d 4a d mhserr like(ErrCod) d*----------------------------------------------------- d* Clear Program Message API. . d*----------------------------------------------------- d qmhrmvpm Pr extpgm('QMHRMVPM') d 1a d 10i 0 d 4a d 10a d mhrerr Like(ErrCod) d*---------------------------------------------------------- d* Comando di sistema. d*---------------------------------------------------------- d qcmdexc pr ExtPgm('QCMDEXC') d 55a d 15p 5 d*----------------------------------------------------- d* Error Code Data Structure . d*----------------------------------------------------- d ErrCod Ds Inz d bytprv 1 4b 0 Inz(256) d bytava 5 8b 0 Inz(0) d errid 9 15a d œœreserv 16 16a d msgdta 17 256a d*----------------------------------------------------- d ParmValues Ds d Vallen 5i 0 Overlay(ParmValues) d ValCond 5a Overlay(ParmValues:3) d ValSch 10a Overlay(ParmValues:8) d ValOper 3a Overlay(ParmValues:18) d ValData 10a Overlay(ParmValues:21) d*----------------------------------------------------- d CharDs Ds d Bin 5i 0 Overlay(CharDs) d*---------------------------------------------------------- d* Par metros de entrada. . d*---------------------------------------------------------- d Parm1 Ds d NbrPrm1 5i 0 Overlay(Parm1) d Filenam 10a Overlay(Parm1:3) d Library 10a Overlay(Parm1:13) d Member 10a Overlay(Parm1:23) d* d Parm2 Ds d NbrElem 5i 0 Overlay(Parm2) d PrmData 288a Overlay(Parm2:3) d* d Text s 50a d*---------------------------------------------------------- d* Constantes . d*---------------------------------------------------------- d* Cantidad de elementos definidos en el comando d MAXELEM c Const(8) d ENTER c Const('1') d Clear c Const('001001') d Set c Const('010000') d SPAG c Const(10) d SysMsgF c Const('QCPFMSG *LIBL ') d*---------------------------------------------------------- d* Campos stand-alone . d*---------------------------------------------------------- d W0Rec1 s Like(W$$sr1) d W1Rec1 s Like(W$$sr1) d Long s 10i 0 Inz d Stack s 10i 0 Inz d MsgLen s 10i 0 Inz(%len(msgdta)) d Pos s 5i 0 Inz(1) d Len s 5i 0 Inz d X s 5i 0 Inz d Z s 5i 0 Inz d Offsets s 5i 0 Dim(MAXELEM) Inz d CmdLen s 15p 5 Inz d SQLStmt s 600a Inz('Select srcdta, rrn(File) From - d File Where ') d SrcDta s 112a Inz d CmdStr s 80a Inz d MsgF s 20a Inz d MsgTyp s 10a Inz('*INFO') d MsgRmv s 10a Inz('*ALL') d PgmQ s 10a Inz('*') d MsgID s 7a Inz d MsgKey s 4a Inz d*---------------------------------------------------------- d* Arrays d*---------------------------------------------------------- d $Fld s 10 Dim(9) CtData PerRcd(1) d $Sst s 30 Dim(9) Alt($Fld) d $Cnd s 3 Dim(8) CtData PerRcd(1) d $Rpl s 9 Dim(8) Alt($Cnd) d $Key s 79 Dim(2) CtData PerRcd(1) d*---------------------------------------------------------- c* Definición de par metros de entrada. c *Entry Plist c Parm Oper 4 c Parm Parm1 c Parm Parm2 c Parm Text c* c* Definición de sentencias SQL. c/Exec SQL c+ Declare SCH Dynamic scroll cursor for S1 c/End-Exec c* c*========================================================== c* c* M A I N P R O G R A M c* c*========================================================== c* c If Oper = '*NEW' c* c Eval CmdStr = 'Ovrdbf File ' + %Trim(Library) + c '/' + %Trim(Filenam) + ' ' + %Trim( c Member) + ' ' +'OvrScope(*Calllvl)' c Eval CmdLen = %Len(%Trim(CmdStr)) c CallP qcmdexc(CmdStr:CmdLen) c* c/Exec SQL c+ Prepare S1 From :SQLStmt c/End-Exec c* c/Exec SQL c+ Open SCH c/End-Exec c* c/Exec SQL c+ Fetch SCH Into :SrcDta, :Long c/End-Exec c If SqlCod = *Zeros c Clear Sfl1 c Eval H1NRcd = Long c Eval S1Membr = Member c Eval S1Text = Text c Add 1 W0rec1 30 c Write Sfl1 c EndIf c* c/Exec SQL c+ Close SCH c/End-Exec c Else c* c* Muestra resultado de la búsqueda. c Eval W$$sr1 = 1 c Eval W$$Ck1 = $Key(1) c Eval W$$Ck2 = $Key(2) c SetOn 34 c* c DoU *In03 or *In12 c Write SflCtl c* c* Desctivar PUTOVR. c ExFmt Ctl1 c Eval W$$sr1 = W0sfps c ExSr RmvMsg c* c W0aib CasEq ENTER Ctrl c *In25 CasEq *On PageUP c *In26 CasEq *On PageDW c End c EndDo c* c/Exec SQL c+ Close SCH c/End-Exec c SetOn LR c EndIf c* c Return c* c*========================================================== c* S U B R U T I N A S c*========================================================== c*---------------------------------------------------------- c* SUBRUTINA: CTRL c* PROPOSITO: Procesa subfile. c*---------------------------------------------------------- c Ctrl BegSr c* c If *In30 c ReadC Sfl1 50 c DoW NOT *In50 c* c If S1Opz = 5 c Eval CmdStr = 'DspPfm ' + %Trim(Library) + '/' + c %Trim(Filenam)+ ' ' + %Trim(S1Membr) c + ' FromRcd(' + %Editc(H1NRcd:'X') + c ')' c c Eval CmdLen = %Len(%Trim(CmdStr)) c CallP qcmdexc(CmdStr:CmdLen) c EndIf c* c Clear S1Opz c SetOff 39 c Update Sfl1 c* c ReadC Sfl1 50 c EndDo c EndIf c* c EndSr c*---------------------------------------------------------- c* SUBRUTINA: PAGEUP c* PROPOSITO: Avance de p gina. c*---------------------------------------------------------- c PageUP BegSr c* c Eval MsgID = 'CPD6A69' c Eval MsgF = SysMsgF c ExSr SndMsg c* c EndSr c*---------------------------------------------------------- c* SUBRUTINA: PAGEDW c* PROPOSITO: Retroceso de p gina. c*---------------------------------------------------------- c PageDW BegSr c* c Eval MsgID = 'CPD6A66' c Eval MsgF = SysMsgF c ExSr SndMsg c* c EndSr c*---------------------------------------------------------- c* SUBRUTINA: ARMAALL c* PROPOSITO: Arma búsqueda por registro completo. c*---------------------------------------------------------- c ArmaAll BegSr c* c Eval SQLStmt = %Trim(SQLStmt) + ' Ucase(SrcDta) ' c* c ValOper LookUp $Cnd(Z) 69 c 69 Eval SQLStmt = %Trim(SQLStmt) + ' ' + $Rpl(Z) c* c If ValOper <> '*LK' and ValOper <> '*NL' c* c* Elimina blancos. c If ValData <> *Blanks c Eval SQLStmt = %Trim(SQLStmt) + ' ''' + %Trim( c ValData) + '''' c Else c Eval SQLStmt = %Trim(SQLStmt) + ' ''' + ValData + c '''' c EndIf c* c Else c ExSr ArmaLike c EndIf c* c EndSr c*---------------------------------------------------------- c* SUBRUTINA: ARMALIKE c* PROPOSITO: Arma string de búsqueda. c*---------------------------------------------------------- c ArmaLike BegSr c* c If ValData <> *Blanks c '*':'%' Xlate ValData ValData c Eval SQLStmt = %Trim(SQLStmt) + ' ''' + %Trim( c ValData) + '''' c Else c Eval ValData = *All'%' c Eval SQLStmt = %Trim(SQLStmt) + ' ''' + ValData + c '''' c EndIf c* c EndSr c*---------------------------------------------------------- c* SUBRUTINA: SNDMSG c* PROPOSITO: Enviar mensaje. c*---------------------------------------------------------- c SndMsg BegSr c* c Reset ErrCod c* c CallP qmhsndpm(MsgID:MsgF:msgdta:MsgLen:MsgTyp:PgmQ c :Stack:MsgKey:ErrCod) c* c EndSr c*---------------------------------------------------------- c* SUBRUTINA: RMVMSG c* PROPOSITO: Borrar mensaje. c*---------------------------------------------------------- c RmvMsg BegSr c* c Reset ErrCod c Clear MsgKey c* c CallP qmhrmvpm(PgmQ:Stack:MsgKey:MsgRmv:ErrCod) c* c EndSr c*---------------------------------------------------------- c* SUBRUTINA: *PSSR c* PROPOSITO: Rutina de excepción/error. c*---------------------------------------------------------- c *Pssr BegSr c* c Dump c SetOn H9 c Return c* c EndSr c*---------------------------------------------------------- c* SUBRUTINA: *INZSR c* PROPOSITO: Inicialización c*---------------------------------------------------------- c *InzSr BegSr c* c* Recuperar offsets de los elementos. c Do NbrElem X c Eval CharDs = %Subst(PrmData:Pos:2) c Eval OffSets(X) = Bin+1 c Eval Pos = Pos+2 c EndDo c* c* Arma sentencia SQL. c Do NbrElem X c* c Eval Z = 1 c Eval ParmValues = %Subst(Parm2:OffSets(X):%Len( c ParmValues)) c* c If ValCond <> '*NONE ' c Eval SQLStmt = %Trim(SQLStmt) + ' ' + %Subst( c ValCond:2:3) c EndIf c* c* Arma búsqueda por todo el registro. c If ValSch = '*ALL' c ExSr ArmaAll c Leave c* c* Búsqueda por columnas (Solamente hoja C) c Else c* c ValSch LookUp $Fld(Z) 69 c 69 Eval SQLStmt = %Trim(SQLStmt) + ' ' + $Sst(Z) c* c Eval Z = 1 c ValOper LookUp $Cnd(Z) 69 c 69 Eval SQLStmt = %Trim(SQLStmt) + ' ' + $Rpl(Z) c* c If ValOper <> '*LK' and ValOper <> '*NL' c* c* Elimina blancos. c If ValData <> *Blanks c Eval SQLStmt = %Trim(SQLStmt) + ' ''' + %Trim( c ValData) + '''' c Else c Eval SQLStmt = %Trim(SQLStmt) + ' ''' + ValData + c '''' c EndIf c* c Else c ExSr ArmaLike c EndIf c EndIf c EndDo c* c* Inicializa subfile. c Movea Clear *In(30) c Write Ctl1 c Movea Set *In(30) c* c Clear W0rec1 c Clear W1rec1 c SetOn 40 c* c EndSr c*=========================================================== ** $Fld/$Sst FACTOR1 Ucase(Substr(SrcDta, 12, 14)) CODOPE Ucase(Substr(SrcDta, 26, 10)) FACTOR2 Ucase(Substr(SrcDta, 36, 14)) FACTOR2EXTUcase(Substr(SrcDta, 36, 45)) RESULT Ucase(Substr(SrcDta, 50, 14)) INDHI Ucase(Substr(SrcDta, 71, 2)) INDLO Ucase(Substr(SrcDta, 73, 2)) INDEQ Ucase(Substr(SrcDta, 75, 2)) COMMENT Ucase(Substr(SrcDta, 81, 20)) ** $Cnd/$Rpl *EQ= *NE<> *GE>= *GT> *LE<= *LT< *LKLike *NLNOT Like ** $$Key F3=Salir F12=Salir