saycent(y2+2,x1,x2,prom1)
saycent(y1,x1,x2,svtx)
I=ACHOICE(y1+1,x1+1,y2-1,x2-1,a,.t.,"u_key1",first)
IF i=0
ret=""
CLEAR TYPEAHEAD
EXIT
ELSE
DO CASE
CASE LASTKEY()=13.AND.COUNT>0 &&<ENTER>
SEEK(code_name)
SKIP I
PRIVATE scr,col1,pict
pict=SPACE(LEN(TEXT))
scr=SAVESCREEN(10,9,12,70)
col1=SETCOLOR()
SET COLOR TO (color7)
@10,9,12,70 box singl+fon2
saycent(10,9,70,"ВВОДИТЕ НОВОЕ ИМЯ")
SET CURSOR ON
@ 11,10 GET pict
READ
PICT=STRTRAN(pict,'Н','H')
SET CURSOR OFF
SETCOLOR(col1)
RESTSCREEN(10,9,12,70,scr)
IF LASTKEY()#27.AND.!EMPTY(PICT) && ESC
REPLACE TEXT WITH pict
ENDIF
RELEASE scr,col1,pict
CASE LASTKEY()=22 &&<INS>
IF count>0
ins_pic(code_name,b[count])
ELSE
ins_pic(code_name,' ')
ENDIF
first=count+1
CASE LASTKEY()=7 &&<DEL>
IF count>0
del_pic(code_name,i)
ENDIF
first=i-1
ENDCASE
ENDIF
ENDDO
*CLEAR TYPEAHEAD
REINDEX
RESTORE SCREEN FROM screen
SET COLOR TO (color)
SELECT(sel)
SET CURSOR OFF
RETURN ret
*********************************************************************
* Проверка наличия в текущей директории файла отчета *
*********************************************************************
FUNCTION f_FRM
PRIVATE log,screen
log=.T.
IF !FILE(OT1)
log=.F.
SAVE SCREEN TO screen
@ 8,8 CLEAR TO 15,71
@ 8,8 TO 15,71 DOUBLE
saycent(8,20,60,"ВНИМАНИЕ")
@ 11,15 SAY "ДЛЯ СОЗДАНИЯ ОТЧЕТА НЕОБХОДИМ ФАЙЛ :"+OT1
@ 12,15 SAY "УКАЗАННОГО ФАЙЛА НЕТ В РАБОЧЕЙ ДИРЕКТОРИИ"
INKEY(10)
RESTORE SCREEN FROM screen
ENDIF
RETURN (log)
*********************************************************************
* Функция ввода отчетного периода *
*********************************************************************
FUNCTION period
PRIVATE screen,M1,R1
R1=0
M1=1
SAVE SCREEN TO screen
SET CURSOR ON
@ 8,8 CLEAR TO 15,71
@ 8,8 TO 15,71 DOUBLE
DO WHILE .T.
saycent(8,20,60,"ВВЕДИТЕ ОТЧЕТНЫЙ ПЕРИОД")
@ 9,17 TO 11,34
@ 10,20 SAY "c " GET _DATE_FROM PICTURE "@D"
@ 9,47 TO 11,64
@ 10,50 SAY "по " GET _DATE_TILL PICTURE "@D"
@ 12,17 TO 14,64
@ 13,21 PROMPT " Ok "
@ 13,38 PROMPT " ПОВТОР "
@ 13,53 PROMPT " ОТКАЗ "
READ
MENU TO M1
IF M1=1
EXIT
ELSEIF M1=2
M1=1
ELSEIF M1=0.OR.M1=3
R1=1
EXIT
ENDIF
ENDDO
SET CURSOR OFF
RESTORE SCREEN FROM screen
RETURN (R1)
*********************************************************************
* Вывод отчетного документа на печать *
*********************************************************************
FUNCTION do_PRN
PRIVATE YN
YN=1
codif1("PRNT",@YN)
IF YN=2
SET CURSOR OFF
TYPE &OT2 TO PRINT
ENDIF
RETURN 0
*********************************************************************
* Функция определения возраста пациента *
*********************************************************************
FUNCTION y_m_day
PARAMETERS day_bir,hour_bir,mins_bir,day_bas,hour_bas,mins_bas
PRIVATE years,mons,days,screen,txt
SAVE SCREEN TO screen
txt=""
years="00"
@ 1,20 CLEAR TO 3,60
@ 1,20 TO 3,60
@ 2,22 SAY IF(choice=8," Возраст пациента :","Возраст на момент смерти:")
years=oldM(day_bir,day_bas)
IF VAL(years)>0
txt=years
IF VAL(years)=1
txt=txt+" год"
ELSEIF VAL(years)<5
txt=txt+" года"
ELSE
txt=txt+" лет"
ENDIF
ELSE
mons=INT((day_bas-day_bir)/30)
IF mons>0
txt=ALLTRIM(STR(mons))
IF mons=1
txt=txt+" месяц"
ELSEIF mons<5
txt=txt+" месяца"
ELSE
txt=txt+" месяцев"
ENDIF
ELSE
PRIVATE _add
_add=piece(hour_bir,mins_bir,hour_bas,mins_bas)
days=day_bas-day_bir+_add
txt=ALLTRIM(STR(days))
IF days=1
txt=txt+" день"
ELSEIF days<5
txt=txt+" дня"
ELSE
txt=txt+" дней"
ENDIF
ENDIF
ENDIF
@ 2,50 SAY txt
vars[choice]=vars[choice]+"."
PRIVATE string2
string2=""
IF choice=8
context(@string2,promp[choice],vars[choice],length,New_Str)
stuff1(@string,length,string2,choice,row,len(promp))
choice=9
vars[choice]=codif1("OLDS",@_OLD)
ELSEIF choice=22
codif1("OLDS",@_OLD_D)
ENDIF
RESTORE SCREEN FROM screen
RETURN 0
*********************************************************************
* Функция определения полных лет пациента *
*********************************************************************
FUNCTION oldM
PARAMETERS b_dat,today
PRIVATE old1
PRIVATE year1
SET CENTURY OFF
year1=year(today)-year(b_dat)
if month(today)>month(b_dat)
old1=alltrim(str(year1))
else
if month(today)<month(b_dat)
old1=alltrim(str(year1-1))
else
if day(today)<day(b_dat)
old1=alltrim(str(year1-1))
else
old1=alltrim(str(year1))
endif
endif
endif
RETURN old1
*********************************************************************
* Функция перевода минут в сутки *
*********************************************************************
FUNCTION piece
PARAMETERS H1,M1,H2,M2
PRIVATE P
P=0.00
P=((60*H2+M2)-(60*H1+M1))/1440
RETURN (P)
*********************************************************************
* Коррекция заголовка отчетного документа *
*********************************************************************
FUNCTION corr_ttl
PARAMETERS _file,_str1,_str2,_str3
PRIVATE h,l,v
h=FCREATE("_0000F",0)
FSEEK(h,0,0)
FWRITE(h,"Отделение: "+_str1+CHR(13)+CHR(10),11+LEN(_str1)+2)
FWRITE(h,"Отчетный период: "+_str2+" - "+_str3+CHR(13)+CHR(10),;
17+LEN(_str2)+3+LEN(_str3)+2)
FWRITE(h,"Дата формирования отчета : "+DTOC(_today)+CHR(13)+CHR(10),;
27+LEN(DTOC(_today))+2)
FCLOSE(h)
RUN ("COPY _0000F+&_file _0000F>NUL")
DELETE FILE &_file
RENAME _0000F TO &_file
RETURN 0
********************************************************************
Модуль: VIEWER.PRG
*************************************************************************
* Функция просмотра текстового файла в заданном окне - fileview. *
* Для перемещения текста в окне используются *
* только: *
* Параметры: *
* filename - имя файла, *
* wt,wl,wb,wr - окно просмотра, *
* color - цвет [необязательный параметр], *
* linewide - длина строки(гориз. скроллинг) [необязательный параметр]. *
*************************************************************************
function fileview
parameters filename,wt,wl,wb,wr,color,linewide
private col_sv
col_sv=setcolor()
if pcount()<6
color="W+/B,N/G,BG/N,RB+/B,BG/B"
endif
if pcount()<7
linewide=wr-wl+1
endif
set key 24 to cr
set key 18 to bl
set key 3 to bl
set key 29 to bl
set key 30 to bl
set key 31 to bl
if empty(color)
color="W+/B,N/G,BG/N,RB+/B,BG/B"
endif
setcolor(color)
private f_mov
private fh,file_len,file_down,file_up
private blok,pos_str,pos_cur
private lines,old_line,count,cnt_pos
private buf,p,wt,wl,wb,wr
private str_vid,p_vid
private buf1,buf2
buf="buf1"
blok=2000
pos_str=wb-wt+1
pos_cur=wb-wt+1
lines=0
count=0
cnt_pos=0
old_line=0
last=chr(13)+chr(10)
f_mov=0
fh=fopen(filename,0)
if ferror()#0
@ 1,2 say "Ошибка при открытии файла "+filename
return(0)
endif
file_len=fseek(fh,0,2)
fseek(fh,0,0)
buf1=freadstr(fh,blok)
file_down=blok
file_up=-1
str_vid=buf1
p_vid= rat(last,str_vid)
str_vid=left(str_vid,p_vid-1)
do while .T.
clear typeahead
memoedit(STRTRAN(str_vid,"Н","H"),wt,wl,wb,wr,.F.,"mod",linewide,'',pos_str,0,pos_cur,0)
if lastkey()=27
exit
endif
do case
case f_mov=1
str_vid=&buf
buf=if(buf="buf1","buf2","buf1")
fseek(fh,file_down,0)
file_down=file_down+blok
file_up=file_down-3*blok
&buf=freadstr(fh,blok)
str_vid=str_vid+&buf
pos_str=lines-old_line+1
pos_cur=wb-wt+1
old_line=pos_str-1
p_vid= rat(last,str_vid)
str_vid=left(str_vid,p_vid-1)
count=count+1
if count>cnt_pos
cnt_pos=cnt_pos+1
p="pos"+alltrim(str(cnt_pos))
private &p
&p=pos_str
endif
case f_mov=-1
fseek(fh,file_up,0)
file_down=file_down-blok
file_up=file_down-3*blok
&buf=freadstr(fh,blok)
str_vid=&buf
buf=if(buf="buf1","buf2","buf1")
str_vid=str_vid+&buf
count=count-1
p="pos"+alltrim(str(count))
pos_str=&p+wb-wt+1
pos_cur=wb-wt+1
p_vid= rat(last,str_vid)
str_vid=left(str_vid,p_vid-1)
otherwise
endcase
enddo
fclose(fh)
set key 24
set key 18
set key 3
set key 29
set key 30
set key 31
setcolor(col_sv)
RETURN(0)
function mod
parameters mode,line,col
private key
key=lastkey()
do case
case key=13 .and. line=lines .and. file_down<file_len
f_mov=1
keyboard chr(23)
return(0)
case key=5 .and. line<=wb-wt+2 .and. file_up>-1
f_mov=-1
keyboard chr(23)
return(0)
otherwise
lines=line
endcase
return(0)
procedure cr
keyboard chr(13)
return
procedure bl
keyboard chr(32)
return