h Debug d*===================================================================== d* PROGRAMA....: SCHFLD2R d* DESCRIPCION.: Buscar campo en miembro fuente. d* AUTOR.......: Diego M. ACEVEDO -Buenos Aires- Argentina d* d* d* Compilar con DFTACTGRP(*NO) ACTGRP(*CALLER) d*===================================================================== fFile if f 112 Disk UsrOpn InfDs(OpnFbk) fSchfldd cf e Workstn Sfile(Sfl1:W0rec1) InfDs(Status) fFileOut o e Disk UsrOpn d*---------------------------------------------------------- d OpnFbk Ds d RcdNbr 10i 0 Overlay(OpnFbk:397) d*---------------------------------------------------------- d* Display File Feedback Data Structure . d*----------------------------------------------------- d Status Ds d W0Aib 1a Overlay(Status:369) 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 Const 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* 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 Parm5 Ds d OutFile 10a Overlay(Parm5) d OutLibl 10a Overlay(Parm5:11) d* d Parm6 Ds d NbrPrm6 5i 0 Overlay(Parm6) d OutMbr 10a Overlay(Parm6:3) d OutOpt 8a Overlay(Parm6:13) d* d Text s 50a d*----------------------------------------------------- d* Constantes . d*----------------------------------------------------- d C c Const('cC') 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 Lc c Const('abcdefghijklmn•opqrstuvwxyz') d Uc c Const('ABCDEFGHIJKLMNœOPQRSTUVWXYZ') d*----------------------------------------------------- d* Campos stand-alone . d*----------------------------------------------------- d W0Rec1 s Like(W$$sr1) d W1Rec1 s Like(W$$sr1) d Stack s 10i 0 Inz d MsgLen s 10i 0 Inz(%len(msgdta)) d X s 5i 0 Inz d CmdLen s 15p 5 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 $Page s 1n Inz d $Read s 1n Inz d $Found s 1n Inz d*---------------------------------------------------------- d* Estructura de archivo de entrada. d*---------------------------------------------------------- d InputDs Ds d SrcDta 112a Overlay(InputDs) d Hoja 1a Overlay(SrcDta:18) d Ast 1a Overlay(SrcDta:19) d Fc1 14a Overlay(SrcDta:24) d Oper 10a Overlay(SrcDta:38) d Fc2E 45a Overlay(SrcDta:48) d Fc2 14a Overlay(Fc2E) d Res 14a Overlay(Fc2E:15) d*---------------------------------------------------------- d* Arrays d*---------------------------------------------------------- d $Key s 79 Dim(2) CtData PerRcd(1) d $Prm s 7 Dim(2) CtData PerRcd(1) d $Dsc s 14 Dim(2) Alt($Prm) d*---------------------------------------------------------- c* Definición de parámetros de entrada. c *Entry Plist c Parm Option 4 c Parm Parm1 c Parm Field 14 c Parm Posic 7 c Parm Parm4 8 c Parm Parm5 c Parm Parm6 c Parm Text c* c*========================================================== c* c* M A I N P R O G R A M c* c*========================================================== c* c If Option = '*NEW' <-------------+ c* | c Eval $Page = *Off | c Eval $Read = *Off | c Eval $Found = *Off | 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 Open File 99 | c* | c Read File InputDs 50 | c DoW NOT *In50 <------------+| c* || c If %Scan(Hoja:C) > *Zeros or $Page <-----------+|| c Eval $Page =*On ||| c* ||| c* Convierte a mayúsculas. ||| c Eval InputDs = %Xlate(Lc:Uc:InputDs) ||| c* ||| c* Omite lineas anuladas. ||| c If Ast = *Blank <----------+||| c* |||| c If Posic = '*TARGET' <---------+|||| c* ||||| c If %Scan('EVAL':Oper) > *Zeros <--------+||||| c* |||||| c* Busca signo =. |||||| c If %Scan('=':Fc2E) = *Zeros <-------+|||||| c Read File InputDs 50 ||||||| c Eval InputDs = %Xlate(Lc:Uc:InputDs) ||||||| c EndIf >-------+|||||| c* |||||| c If %Subst(Fc2E:1:%Scan('=':Fc2E)-1) = %Trim( <-------+|||||| c Field) ||||||| c ExSr WriteSfl ||||||| c Leave ||||||| c EndIf >-------+|||||| c* |||||| c ElseIf Res = %Trim(Field) }--------|||||| c ExSr WriteSfl |||||| c Leave |||||| c EndIf >--------+||||| c* ||||| c ElseIf %Scan('EVAL':Oper) > *Zeros OR %Scan('CALLP':}---------||||| c Oper) > *Zeros ||||| c ExSr ProcRight ||||| c* ||||| c* Si encontró un registro, finaliza. ||||| c If $Found <--------+||||| c Leave |||||| c EndIf >--------+||||| c* ||||| c ElseIf (Fc1 = %Trim(Field)) OR (Fc2 = %Trim(Field)) }---------||||| c ExSr WriteSfl ||||| c Leave ||||| c EndIf >---------+|||| c EndIf >----------+||| c EndIf >-----------+|| c* || c If NOT $Read <-----------+|| c Read File InputDs 50 ||| c ElseIf NOT $Found }-----------||| c Eval $Read = *Off ||| c EndIf >-----------+|| c EndDo >------------+| c* | c Close File | c* | c Else }-------------| c* | c* Muestra resultado de la búsqueda si la salida es por pantalla. | c If Parm4 = '*DISPLAY' <------------+| c* || c Eval W$$sr1 = 1 || c Eval W$$Ck1 = $Key(1) || c Eval W$$Ck2 = $Key(2) || c Eval C1SrcF = Filenam || c Eval C1SrcL = Library || c Eval C1Field = Field || c Eval X = 1 || c Posic LookUp $Prm(X) 69 || c Eval C1Posit = $Dsc(X) || 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 Else }------------|| c ExSr GrabaFileOut || c EndIf >------------+| c* | c* Cierra archivo de salida si corresponde. | c If %Open(FileOut) <------------+| c Close FileOut || c EndIf >------------+| c* | 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: WRITESFL c* PROPOSITO: Graba subfile. c*---------------------------------------------------------- c WriteSfl BegSr c* c Clear Sfl1 c Eval H1NRcd = RcdNbr c Eval S1Membr = Member c Eval S1Text = Text c Add 1 W0rec1 30 c Write Sfl1 c* c Eval W1Rec1 = W0Rec1 c* c EndSr c*---------------------------------------------------------- c* SUBRUTINA: PROCRIGHT c* PROPOSITO: Procesa búsqueda a derecha. c*---------------------------------------------------------- c ProcRight BegSr c* c Eval $Read = *Off c Eval $Found = *Off c* c DoU Oper <> *Blanks OR *In50 <-------------+ c* | c* Convierte a mayúsculas. | c Eval InputDs = %Xlate(Lc:Uc:InputDs) | c* | c If NOT $Read <------------+| c* || c If %Scan('=':Fc2E) < %Len(Fc2E) <-----------+|| c If %Scan(%Trim(Field):Fc2E:%Scan('=':Fc2E)+1) > <----------+||| c *Zeros |||| c ExSr WriteSfl |||| c Eval $Found = *On |||| c LeaveSr |||| c EndIf >----------+||| c EndIf >-----------+|| c* || c ElseIf %Scan(%Trim(Field):Fc2E) > *Zeros }------------|| c || c ExSr WriteSfl || c Eval $Found = *On || c LeaveSr || c EndIf >------------+| c* | c Read File InputDs 50 | c n50 Eval $Read = *On | c EndDo >-------------+ c* c EndSr c*---------------------------------------------------------- c* SUBRUTINA: GRABAFILEOUT c* PROPOSITO: Graba archivo de salida. c*---------------------------------------------------------- c GrabaFileOut BegSr c* c If *In30 <-------------+ c Do W1Rec1 W0Rec1 <------------+| c W0Rec1 Chain Sfl1 || c* || c Clear $SchFld || c Eval $SrcPf = Filenam || c Eval $SrcLb = Library || c Eval $SrcMb = S1Membr || c Eval $SrcTx = S1Text || c Eval $SrcFl = H1NRcd || c Write $SchFld || c EndDo >------------+| 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* 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* Abre archivo de salida si corresponde. c If Parm4 = '*OUTFILE' <-------------+ c Open FileOut | c EndIf >-------------+ c* c EndSr c*=========================================================== ** $Key F3=Salir F12=Salir ** $Prm/$Dsc *SOURCEOrigen *TARGETDestino