jsoto/MBS
2
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
0f48fc5afcc1be55315b2c6d941722e929923885
MBS/PROYECTO/irdir/irprmt004.4gl
T
jsotoandClaude Opus 5.5 d8764b3bda JSOTO Alta y compilacion G6 de programas CG, Cheques, Activos, Tesoreria, Repuestos e Informatica 
Merge de main (ipprrp013/014/046/053) con conflictos resueltos:
- mbsERP.4pw: ipprrp014 conserva ambos 4rp y su 4fd.
- bin/ipprrp014.4rp: columnas MARGEN/CLASIF. + titulo IPPRRP014.

Programas agregados a mbsERP.4pw (53 compilan y enlazan con fgl602):
- CONTABILIDAD GENERAL, ACTIVOS FIJOS, REPUESTOS; grupos nuevos TESORERIA,
  CHEQUES e INFORMATICA (segprmt001 = seguridad2.0/segprmt0001.4gl).
- irdir copiado de 3.20 PROYECTOS/irdir a PROYECTO/irdir; helpers de
  PROYECTOS/otrodir en FUNCIONES_IR (departamento -> irdepartamento.4gl).
- Fuentes mas nuevos de 3.20: edprrp118, edprrp080, acprrp010, cgprmt022.
- FUNCIONES: GeneraEntradaDiario.4gl a la version 3.20 + costoLiquidacion.4gl.
- Ajustes G6: existe duplicado en irprgb000, fakeData de 22 campos y
  answer2 en irprmt036/020 (ApiMaintainC), selectOutputSimple en irprcs008,
  schemas de forms a smarmotech, referencia declarada en cgprmt005.
- cgprmt005 sigue sin enlazar: requiere funciones de EXTERIOR.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
2026-10-15 16:22:14 -04:00

458 lines
15 KiB
Plaintext
Raw Blame History

{
-------------------------------------------------------------------------------
PROGRAMA : IRPRMT004
OBJETIVO : Capturar, Modificar, Eliminar registros de la
Tabla de Costos Estandares
PROGRAMADOR : Ing. Juan Fco. Soto.
FECHA REALIZACION : Marzo 1, 1993.
-------------------------------------------------------------------------------
}
GLOBALS "irprgb000.4gl"
DEFINE checkapi, answer INT
## Arreglo consulta/modificacion: se navega sobre un arreglo en memoria en vez
## de un SCROLL CURSOR vivo, porque bajo el RDD de SQL Server cualquier otra
## sentencia (los SELECT a mestable, el COMMIT del Escoger, el UPDATE de
## eLiminar) cierra el cursor de servidor y provoca el error -400
## "Fetch attempted on unopen cursor".
DEFINE arr_costos DYNAMIC ARRAY OF RECORD
mes_ini LIKE intb00013.mes_ini,
mes_fin LIKE intb00013.mes_fin,
ano LIKE intb00013.ano,
cod_n LIKE intb00001.cod_n,
cod_grupo LIKE intb00001.cod_grupo,
cod_tipo LIKE intb00001.cod_tipo,
cod_sec LIKE intb00001.cod_sec,
costo_st LIKE intb00013.costo_st,
us_crea LIKE intb00013.us_crea,
fech_crea LIKE intb00013.fech_crea,
us_mod LIKE intb00013.us_mod,
fech_mod LIKE intb00013.fech_mod,
descrip_esp LIKE intb00001.descrip_esp,
unidad_med LIKE intb00001.unidad_med
END RECORD
MAIN
DEFER INTERRUPT
CALL ARG_VAL(1) RETURNING usuarios
CALL ARG_VAL(2) RETURNING clave
CONNECT to "smarmotech" USER usuarios USING clave
SELECT * INTO p_companias.* FROM companias
CALL irprmt004()
END MAIN
FUNCTION irprmt004()
CLEAR SCREEN
OPTIONS
FORM LINE 9,
ERROR LINE 23,
COMMENT LINE 22
OPEN FORM irfmmt004 FROM "irfmmt004"
DISPLAY FORM irfmmt004
DISPLAY "irprmt004" AT 4,3
DISPLAY "Costo Standard " AT 6,31
MENU "OPCIONES"
COMMAND "Adicionar"
"<Esc> Adiciona Registro <Ctrl-C> Cancela Operacion"
CLEAR FORM
LET int_flag = false
CALL irpcad004()
COMMAND "Consultar-modificar"
"<Esc> Realiza Busqueda <Ctrl-C> Cancela Operacion"
LET int_flag = false
CALL irpcmf004()
COMMAND "Salir" "Retorna Menu Anterior"
EXIT MENU
END MENU
END FUNCTION
FUNCTION irpcad004()
#WHENEVER ERROR CONTINUE
## Captura los datos que va a contener el registro
INPUT BY NAME costos.mes_ini THRU costos.costo_st
## Verifica que el costo exista en el catalogo de costos. Si existe,
## entonces despliega los datos del registro existente.
AFTER FIELD mes_ini
IF costos.mes_ini IS NULL THEN
LET numero_msg = 16
CALL msg(numero_msg)
NEXT FIELD mes_ini
ELSE
SELECT descrip INTO descrip1 FROM mestable
WHERE mes = costos.mes_ini and
status_t is null
IF status >= 0 THEN
IF status = NOTFOUND THEN
LET numero_msg = 3
CALL msg(numero_msg)
NEXT FIELD mes_ini
END IF
END IF
DISPLAY BY NAME descrip1
END IF
AFTER FIELD mes_fin
IF costos.mes_fin IS NULL THEN
LET numero_msg = 16
CALL msg(numero_msg)
NEXT FIELD mes_fin
ELSE
SELECT descrip INTO descrip2 FROM mestable
WHERE mes = costos.mes_fin and
status_t is null
IF status >= 0 THEN
IF status = NOTFOUND THEN
LET numero_msg = 3
CALL msg(numero_msg)
NEXT FIELD mes_fin
END IF
END IF
DISPLAY BY NAME descrip2
END IF
AFTER FIELD ano
IF costos.ano IS NULL THEN
LET numero_msg = 16
CALL msg(numero_msg)
NEXT FIELD ano
END IF
AFTER FIELD cod_sec
SELECT mes_ini,mes_fin,ano,cod_n,cod_grupo,cod_tipo,cod_sec
FROM irtb00013
WHERE mes_ini = costos.mes_ini AND
mes_fin = costos.mes_fin AND
ano = costos.ano AND
cod_n = costos.cod_n AND
cod_grupo = costos.cod_grupo AND
cod_tipo = costos.cod_tipo AND
cod_sec = costos.cod_sec
IF status != NOTFOUND THEN
LET numero_msg = 12
CALL msg(numero_msg)
NEXT FIELD mes_ini
END IF
IF ( costos.cod_n = 0 AND costos.cod_grupo = 0 AND
costos.cod_tipo = 0 AND costos.cod_sec = 0 ) THEN
LET numero_msg = 16
CALL msg(numero_msg)
NEXT FIELD cod_n
ELSE
SELECT a.descrip_esp,a.unidad_med
INTO articulos.descrip_esp,articulos.unidad_med
FROM irtb00002 a
WHERE a.cod_n=costos.cod_n AND a.cod_grupo=costos.cod_grupo AND
a.cod_tipo=costos.cod_tipo AND a.cod_sec=costos.cod_sec AND
a.status_t is null
IF status >= 0 THEN
IF status = NOTFOUND THEN
LET numero_msg = 3
CALL msg(numero_msg)
NEXT FIELD cod_n
END IF
END IF
DISPLAY BY NAME articulos.descrip_esp,articulos.unidad_med
END IF
AFTER FIELD costo_st
IF costos.costo_st IS NULL THEN
LET numero_msg = 16
CALL msg(numero_msg)
NEXT FIELD costo_st
END IF
AFTER INPUT
IF int_flag THEN
LET numero_msg = 2
CALL msg(numero_msg)
LET int_flag = FALSE
RETURN
END IF
IF costos.costo_st IS NULL THEN
LET numero_msg = 16
CALL msg(numero_msg)
NEXT FIELD costo_st
ELSE
LET m_articulos.cod_n = costos.cod_n
LET m_articulos.cod_grupo = costos.cod_grupo
LET m_articulos.cod_tipo = costos.cod_tipo
LET m_articulos.cod_sec = costos.cod_sec
LET m_articulos.descrip_esp = articulos.descrip_esp
LET m_articulos.descrip_ing = costos.costo_st
SELECT SUM(cantidad_2) INTO m_articulos.existencia from irtb00006
WHERE cod_n = costos.cod_n and cod_grupo = costos.cod_grupo
and cod_tipo = costos.cod_tipo and cod_sec = costos.cod_sec
AND status_t IS NULL
SELECT exist_min, id_maintainx INTO m_articulos.exist_min, checkapi FROM irtb00002
WHERE cod_n = costos.cod_n and cod_grupo = costos.cod_grupo
and cod_tipo = costos.cod_tipo and cod_sec = costos.cod_sec
AND status_t IS NULL
BEGIN WORK
IF checkapi IS NOT NULL THEN
CALL ApiMaintainR('PATCH',checkapi, m_articulos.*, usuarios) RETURNING answer
IF answer != 1 THEN
DISPLAY "AQUI 6"
ROLLBACK WORK
END IF
END IF
INSERT INTO irtb00013 VALUES (costos.mes_ini,costos.mes_fin,
costos.ano,costos.cod_n,costos.cod_grupo,
costos.cod_tipo,costos.cod_sec,costos.costo_st,
null,USER,getdate(),null, NULL)
LET numero_msg = 1
CALL msg(numero_msg)
COMMIT WORK
LET costos.cod_n = NULL
LET costos.cod_grupo = NULL
LET costos.cod_tipo = NULL
LET costos.cod_sec = NULL
LET costos.costo_st = NULL
NEXT FIELD cod_n
END IF
END INPUT
END FUNCTION
FUNCTION irp_show004(p_idx)
## Copia el registro p_idx del arreglo en memoria a la pantalla.
DEFINE p_idx SMALLINT
LET costos.mes_ini = arr_costos[p_idx].mes_ini
LET costos.mes_fin = arr_costos[p_idx].mes_fin
LET costos.ano = arr_costos[p_idx].ano
LET costos.cod_n = arr_costos[p_idx].cod_n
LET costos.cod_grupo = arr_costos[p_idx].cod_grupo
LET costos.cod_tipo = arr_costos[p_idx].cod_tipo
LET costos.cod_sec = arr_costos[p_idx].cod_sec
LET costos.costo_st = arr_costos[p_idx].costo_st
LET costos.us_crea = arr_costos[p_idx].us_crea
LET costos.fech_crea = arr_costos[p_idx].fech_crea
LET costos.us_mod = arr_costos[p_idx].us_mod
LET costos.fech_mod = arr_costos[p_idx].fech_mod
LET articulos.descrip_esp = arr_costos[p_idx].descrip_esp
LET articulos.unidad_med = arr_costos[p_idx].unidad_med
SELECT descrip INTO descrip1 FROM mestable
WHERE mes = costos.mes_ini and status_t is null
DISPLAY BY NAME descrip1
SELECT descrip INTO descrip2 FROM mestable
WHERE mes = costos.mes_fin and status_t is null
DISPLAY BY NAME descrip2
DISPLAY BY NAME costos.*,articulos.descrip_esp,articulos.unidad_med
END FUNCTION
FUNCTION irpcmf004()
#WHENEVER ERROR CONTINUE
## Aqui se prepara para la captura del criterio de seleccion
DEFINE idx, tot SMALLINT
CONSTRUCT criterio ON c.mes_ini,c.mes_fin,c.ano,
c.cod_n,c.cod_grupo,
c.cod_tipo,c.cod_sec,c.costo_st
FROM mes_ini,mes_fin,ano,
cod_n,cod_grupo,
cod_tipo,cod_sec,costo_st
IF int_flag THEN
LET numero_msg = 2
CALL msg(numero_msg)
LET int_flag = FALSE
RETURN
END IF
LET SELEC =
"SELECT UNIQUE c.mes_ini,c.mes_fin,c.ano,d.cod_n,d.cod_grupo, ",
" d.cod_tipo,d.cod_sec,c.costo_st,c.us_crea,c.fech_crea, ",
" c.us_mod,c.fech_mod,d.descrip_esp,d.unidad_med ",
"FROM irtb00013 c, irtb00002 d ",
"WHERE c.cod_n=d.cod_n AND c.cod_grupo=d.cod_grupo AND ",
" c.cod_tipo = d.cod_tipo AND c.cod_sec = d.cod_sec AND ",
" c.status_t is null AND d.status_t IS NULL AND ",
criterio clipped," ORDER BY 4,5,6,7"
## Se carga TODO el resultado a memoria de una sola vez y se cierra el cursor.
## Asi la navegacion no depende de un cursor vivo (que SQL Server cierra al
## ejecutar cualquier otra sentencia sobre la conexion).
PREPARE busca FROM selec
DECLARE datos CURSOR FOR busca
CALL arr_costos.clear()
LET tot = 1
FOREACH datos INTO arr_costos[tot].*
LET tot = tot + 1
END FOREACH
LET tot = tot - 1
FREE datos
IF tot = 0 THEN
LET numero_msg = 3
CALL msg(numero_msg)
RETURN
END IF
LET idx = 1
CALL irp_show004(idx)
MENU "OPCIONES"
COMMAND "Siguiente"
"Presenta en pantalla el proximo registro encontrado"
IF idx < tot THEN
LET idx = idx + 1
CALL irp_show004(idx)
ELSE
LET numero_msg = 4
CALL msg(numero_msg)
END IF
COMMAND "Anterior"
"Presenta en pantalla el registro anterior encontrado"
IF idx > 1 THEN
LET idx = idx - 1
CALL irp_show004(idx)
ELSE
LET numero_msg = 5
CALL msg(numero_msg)
END IF
COMMAND "Primero"
"Presenta en pantalla el primer registro encontrado"
LET idx = 1
CALL irp_show004(idx)
COMMAND "Ultimo"
"Presenta en pantalla el ultimo registro encontrado"
LET idx = tot
CALL irp_show004(idx)
COMMAND "Escoger"
"<Esc> Actualiza Registro <Ctrl-C> Cancela Operacion"
INPUT BY NAME costos.costo_st,
costos.us_crea,
costos.fech_crea,
costos.us_mod,
costos.fech_mod WITHOUT DEFAULTS
AFTER FIELD costo_st
IF costos.costo_st IS NULL THEN
LET numero_msg = 16
CALL msg(numero_msg)
NEXT FIELD costo_st
END IF
## Verifica si el usuario presiono la tecla <Ctrl-C>
AFTER INPUT
IF int_flag THEN
LET numero_msg = 2
CALL msg(numero_msg)
LET int_flag = FALSE
RETURN
END IF
LET m_articulos.cod_n = costos.cod_n
LET m_articulos.cod_grupo = costos.cod_grupo
LET m_articulos.cod_tipo = costos.cod_tipo
LET m_articulos.cod_sec = costos.cod_sec
LET m_articulos.descrip_esp = articulos.descrip_esp
LET m_articulos.descrip_ing = costos.costo_st
SELECT SUM(cantidad_2) INTO m_articulos.existencia from irtb00006
WHERE cod_n = costos.cod_n and cod_grupo = costos.cod_grupo
and cod_tipo = costos.cod_tipo and cod_sec = costos.cod_sec
AND status_t IS NULL
SELECT exist_min, id_maintainx INTO m_articulos.exist_min, checkapi FROM irtb00002
WHERE cod_n = costos.cod_n and cod_grupo = costos.cod_grupo
and cod_tipo = costos.cod_tipo and cod_sec = costos.cod_sec
AND status_t IS NULL
BEGIN WORK
IF checkapi IS NOT NULL THEN
CALL ApiMaintainR('PATCH',checkapi, m_articulos.*, usuarios) RETURNING answer
IF answer != 1 THEN
DISPLAY "AQUI 6"
ROLLBACK WORK
END IF
END IF
UPDATE irtb00013 SET costo_st = costos.costo_st,
us_mod = USER,
fech_mod = getdate()
WHERE cod_n = costos.cod_n and
cod_grupo = costos.cod_grupo and
cod_tipo = costos.cod_tipo and
cod_sec = costos.cod_sec
## Refleja el nuevo costo en el arreglo en memoria para que la navegacion
## siga mostrando el valor actualizado.
LET arr_costos[idx].costo_st = costos.costo_st
LET arr_costos[idx].us_mod = usuarios
LET arr_costos[idx].fech_mod = TODAY
LET numero_msg = 13
CALL msg(numero_msg)
COMMIT WORK
EXIT INPUT
END INPUT
COMMAND KEY ("L") "eLiminar"
UPDATE irtb00013 SET status_t = "E"
WHERE cod_n = costos.cod_n and
cod_grupo = costos.cod_grupo and
cod_tipo = costos.cod_tipo and
cod_sec = costos.cod_sec
LET numero_msg = 39
CALL msg(numero_msg)
## Quita el registro eliminado del arreglo en memoria y reposiciona.
CALL arr_costos.deleteElement(idx)
LET tot = arr_costos.getLength()
IF tot = 0 THEN
CLEAR FORM
EXIT MENU
END IF
IF idx > tot THEN
LET idx = tot
END IF
CALL irp_show004(idx)
COMMAND "Retornar"
"Retorna al menu anterior"
CLEAR FORM
EXIT MENU
END MENU
END FUNCTION
Reference in New Issue View Git Blame Copy Permalink