PDA-0539 (Разработка автоматизированной системы учета выбывших из стационара), страница 14

*------------------------------------------------

SELECT BUFF8

APPEND BLANK

SELECT KARTA

SET RELATION TO NUM_IB INTO DIA66

GO TOP

DO show_st

DO WHILE !EOF()

IF IF(dep=0,.T.,IF(dep=KARTA->DEPARTMENT,.T.,.F.)).AND.;

KARTA->DATE_END>=_DATE_FROM.AND.KARTA->DATE_END<=_DATE_TILL

SELECT BUFF8

IF _OTCH=16

IF KARTA->END1=2

REPLACE A1 WITH A1+1 && ВСЕГО

IF KARTA->OLD<3 && НОВОРОЖДЕННЫЕ

REPLACE A2 WITH A2+1

ENDIF

ENDIF

IF DIA66->SHIFR="0000" && ОКАЗАВШИЕСЯ ЗДОРОВЫМИ

REPLACE A3 WITH A3+1

ENDIF

ELSEIF _OTCH=17.AND.KARTA->END1=3

IF KARTA->OLD=1

REPLACE A1 WITH A1+1 && УМЕРЛО В ВОЗРАСТЕ 0-6 СУТОК

ENDIF

IF (KARTA->DATE_END-KARTA->DATE_IN+;

piece(KARTA->HOUR_IN,KARTA->MINS_IN,KARTA->HOUR_END,KARTA->MINS_END)<1)

IF (KARTA->DATE_END-KARTA->DATE_B+;

piece(KARTA->HOUR_B,KARTA->MINS_B,KARTA->HOUR_END,KARTA->MINS_END)<=1)

&& В ВОЗРАСТЕ ДО СУТОК

REPLACE A2 WITH A2+1

ENDIF

IF KARTA->OLD<7 && В ВОЗРАСТЕ ДО ГОДА

REPLACE A3 WITH A3+1

SELECT DIA66

state() && Поиск паталого-анатомического диагноза (если он есть)

DO WHILE DIA66->NUM_IB=KARTA->NUM_IB

IF DIA66->KOD1="1".AND.;

(DIA66->SHIFR>="4800".AND.DIA66->SHIFR<="4869")

SELECT BUFF8

REPLACE A4 WITH A4+1 && В ТОМ ЧИСЛЕ УМЕРЛО ОТ ПНЕВМОНИИ

EXIT

ENDIF

SKIP 1

ENDDO

ENDIF

ENDIF

ELSEIF _OTCH=18.AND.(KARTA->SHIFR="410 ".OR.KARTA->SHIFR="412 ")

IF KARTA->TIME<3

REPLACE A1 WITH A1+1 && ВСЕГО ПОСТУПИЛО БОЛЬНЫХ ИНФАРКТОМ

ENDIF

IF KARTA->END1=3.AND.(KARTA->DATE_END-KARTA->DATE_IN+;

piece(KARTA->HOUR_IN,KARTA->MINS_IN,KARTA->HOUR_END,KARTA->MINS_END)<1)

REPLACE A2 WITH A2+1 && УМЕРЛО В ПЕРВЫЕ 24 ЧАСА

ENDIF

ELSEIF _OTCH=19.AND.(KARTA->SHIFR>="6300".AND.KARTA->SHIFR<="6769")

IF KARTA->END1=3

REPLACE A1 WITH A1+1 && ВСЕГО УМЕРЛО БЕРЕМЕННЫХ,РОЖЕНИЦ И РОДИЛЬНИЦ

SELECT DIA66

state() && Поиск паталого-анатомического диагноза (если он есть)

DO WHILE DIA66->NUM_IB=KARTA->NUM_IB

IF DIA66->KOD1="1".AND.;

(DIA66->SHIFR>="6300".AND.DIA66->SHIFR<="6769")

SELECT BUFF8

REPLACE A2 WITH A2+1 && УМЕРЛО ОТ ОСЛОЖНЯЮЩИХ ЗАБОЛЕВАНИЙ

EXIT

ENDIF

SKIP 1

ENDDO

ENDIF

ENDIF

SELECT KARTA

ENDIF

SKIP 1

show_din(count) && ПРОЦЕДУРА ПРЕДСТАВЛЕНИЯ ОБРАБОТКИ ЗАПИСЕЙ

ENDDO

SET RELATION TO

numb_STR() && НУМЕРАЦИЯ СТРОК

*------------------------------------------------

ENDCASE

*------------------------------------------------

SELECT BUFF8

IF _OTCH=6

DELETE FOR EMPTY(COUNT2)=.T.

PACK

ENDIF

@ 13,25 SAY " СОЗДАЕТСЯ ОТЧЕТ : "+OT2+" "

REPORT FORM &OT1 FOR IF(_OTCH=1.OR._OTCH=2.OR._OTCH=5,;

!EMPTY(NUMBER),.T.) TO FILE &OT2 PLAIN

IF _OTCH=9.OR._OTCH=10.OR._OTCH=11.OR._OTCH=12

REPORT FORM OTCH.FRM TO FILE OTCH.TXT PLAIN

USE

corr_ttl("OTCH.TXT",dep_name,DTOC(_DATE_FROM),DTOC(_DATE_TILL))

link2("OTCH.TXT",OT2)

RENAME OTCH.TXT TO &OT2

ELSE

USE

corr_ttl(OT2,dep_name,DTOC(_DATE_FROM),DTOC(_DATE_TILL))

ENDIF

IF _OTCH=4.OR._OTCH=9.AND.dep#14.OR.;

_OTCH=10.OR._OTCH=11.AND.f=2.OR._OTCH=12.OR._OTCH=15

link2(OT2,OT2D1)

ENDIF

ELSE

SELECT BUFF8

USE

LOOP

ENDIF

ENDIF

SET CURSOR ON

fileview(OT2,3,2,21,77,"N/BG",350)

do_PRN()

RESTORE SCREEN FROM scr1

SET CURSOR OFF

ELSE

SELECT BUFF8

USE

ENDIF

ENDDO

RELEASE coun,c1,v1,v2,txt,seek,numb1,_COUNTALL,rec

SELECT (sel)

RETURN 0

*********************************************************************

* Функция нумерации строк в отчетном документе *

*********************************************************************

FUNCTION numb_STR

SELECT BUFF8

GO TOP

PRIVATE numb1

numb1=0

DO WHILE !EOF()

numb1=numb1+1

REPLACE NUMBER WITH STR(numb1,5)

SKIP 1

ENDDO

RETURN 0

*********************************************************************

* Функция разбиения болезней на классы *

*********************************************************************

FUNCTION grad

lsl=SELECT()

SELECT 0

USE CLASS.DBF INDEX CLASS ALIAS CLASS

PRIVATE coun1,K,seek,_COUNTALL,rec

coun1=RECCOUNT()

seek=" "

_COUNTALL=0

rec=0

GO TOP

SELECT BUFF8

SET SOFTSEEK ON

FOR K=1 TO coun1

seek=CLASS->SHIFR_LEFT

SEEK seek

IF !EOF()

IF BUFF8->SHIFR SHIFR_RIGH

numb1=numb1+1

rec=RECNO()

IF _OTCH=1

_SHIFR=SHIFR

_COUNT1=COUNT1

_COUNT2=COUNT2

_A1=A1

_A2=A2

_A3=A3

_A4=A4

_A5=A5

_A6=A6

APPEND BLANK

REPLACE SHIFR WITH _SHIFR,COUNT1 WITH _COUNT1,COUNT2 WITH _COUNT2,;

A1 WITH _A1,A2 WITH _A2,A3 WITH _A3,A4 WITH _A4,;

A5 WITH _A5,A6 WITH _A6

SUM COUNT1,COUNT2,A1,A2,A3,A4,A5,A6 TO ;

_COUNT1,_COUNT2,_A1,_A2,_A3,_A4,_A5,_A6 ;

WHILE BUFF8->SHIFR SHIFR_RIGH

GOTO rec

REPLACE COUNT1 WITH _COUNT1,COUNT2 WITH _COUNT2,A1 WITH _A1,;

A2 WITH _A2,A3 WITH _A3,A4 WITH _A4,A5 WITH _A5,A6 WITH _A6

ENDIF

REPLACE BUFF8->NUMBER WITH STR(numb1,2)

REPLACE BUFF8->NAMECL WITH CLASS->NAME_CLASS

REPLACE BUFF8->SHIFRL WITH CLASS->SHIFR_LEFT

REPLACE BUFF8->SHIFRR WITH CLASS->SHIFR_RIGH

IF _OTCH=6

SUM COUNT1 TO _COUNTALL WHILE BUFF8->SHIFR SHIFR_RIGH

GO rec

REPLACE BUFF8->COUNT2 WITH _COUNTALL

ENDIF

ENDIF

SKIP 1 ALIAS CLASS

ELSE

EXIT

ENDIF

NEXT

SET SOFTSEEK OFF

SELECT CLASS

USE

SELECT (lsl)

RETURN 0

*********************************************************************

* Функция разбиения на группы ( для отчета N1,(N2 и N5) ) *

*********************************************************************

FUNCTION grad1

lsl=SELECT()

SELECT 0

IF _OTCH=1

USE GRUP1.DBF INDEX GRUP1 ALIAS GRUP

ELSE && для _OTCH=2 и _OTCH=5

USE GRUP2.DBF INDEX GRUP2 ALIAS GRUP

ENDIF

PRIVATE coun1,K,seek

coun1=RECCOUNT()

seek=" "

GO TOP

SELECT BUFF8

SET SOFTSEEK ON

FOR K=1 TO coun1

seek=GRUP->SHIFR_LEFT

SEEK seek

IF !EOF()

IF BUFF8->SHIFR SHIFR_RIGH

IF !EMPTY(BUFF8->NUMBER)

SKIP 1 ALIAS BUFF8

ENDIF

rec=RECNO()

SUM COUNT1,COUNT2,A1,A2,A3,A4,A5,A6 TO ;

_COUNT1,_COUNT2,_A1,_A2,_A3,_A4,_A5,_A6 ;

WHILE BUFF8->SHIFR SHIFR_RIGH

GOTO rec

REPLACE COUNT1 WITH _COUNT1,COUNT2 WITH _COUNT2,A1 WITH _A1,;

A2 WITH _A2,A3 WITH _A3,A4 WITH _A4,A5 WITH _A5,A6 WITH _A6

REPLACE BUFF8->NUMBER WITH "-"

REPLACE BUFF8->NAMECL WITH GRUP->NAME_GRUP

REPLACE BUFF8->SHIFRL WITH GRUP->SHIFR_LEFT

REPLACE BUFF8->SHIFRR WITH GRUP->SHIFR_RIGH

ENDIF

SKIP 1 ALIAS GRUP

ELSE

EXIT

ENDIF

NEXT

SET SOFTSEEK OFF

SELECT GRUP

USE

SELECT (lsl)

RETURN 0

*********************************************************************

* Функция слияния двух текстовых файлов *

*********************************************************************

FUNCTION link2

PARAMETERS F1,F2

RUN ("COPY &F1+&F2 &F1>NUL")

DELETE FILE &F2

RETURN 0

*********************************************************************

* Представление на экране обработки записей БД ( начало ) *

*********************************************************************

PROCEDURE SHOW_ST

@ 4,7 CLEAR TO 15,72

saycent(5,5,75," *** "+_OTCH_N+" *** ")

saycent(6,5,75,"по "+IF(dep=0,"всему стационару ","отделению "+dep_name))

saycent(7,5,75,"за период с "+DTOC(_DATE_FROM)+" по "+DTOC(_DATE_TILL))

STORE 0 TO c1,v1,v2

coun=RECCOUNT()

v1=replicate(chr(178),60)

PRIVATE clr11

clr11=SETCOLOR()

SET COLOR TO (color1)

@ 8,8 CLEAR TO 15,71

@ 8,8 TO 15,71 DOUBLE

saycent(15,5,75," ESC - прервать обработку ")

@ 12,9 TO 14,70

@ 13,10 say v1

@ 9,10 TO 11,37

@ 10,11 SAY "ОБРАБОТАНО:"

@ 10,24 SAY 0

@ 9,41 TO 11,70

@ 10,42 SAY "ВСЕГО ЗАПИСЕЙ:"

@ 10,61 SAY coun

SET COLOR TO (clr11)

RETURN

*********************************************************************

* Представление на экране обработки записей БД ( динамика ) *

*********************************************************************

PROCEDURE SHOW_DIN

PARAMETERS counts

c1=c1+counts

v2=replicate(chr(219),int(60*(c1/coun)))

@ 13,10 SAY v2

@ 10,24 SAY c1

count=1

RETURN

*********************************************************************

* Суммирование колонок по классам операций для отчета N3 *

*********************************************************************

FUNCTION summ

PRIVATE k,s,s1,n,A,B,C

SELECT BUFF8

SET SOFTSEEK ON

GO TOP

FOR k=2 TO 16

s=IF(k<10,"0"+STR(k,1),STR(k,2))+"00"

SEEK s

IF !FOUND()

APPEND BLANK

REPLACE SHIFR WITH s

catalog(@s,@txt)

REPLACE NAME WITH ALLTRIM(txt)

ENDIF

n=RECNO()

SKIP 1

s1=IF(k+1<10,"0"+STR(k+1,1),STR(k+1,2))+"00"

SUM COUNT1,COUNT2,A1 TO A,B,C WHILE SHIFR

GO n

REPLACE COUNT1 WITH COUNT1+A,COUNT2 WITH COUNT2+B,A1 WITH A1+C

NEXT

SUM COUNT1,COUNT2,A1 TO A,B,C FOR RIGHT(SHIFR,2)="00"

APPEND BLANK

REPLACE SHIFR WITH "9999", NAME WITH "*** Всего ***",;

COUNT1 WITH COUNT1+A,COUNT2 WITH COUNT2+B,A1 WITH A1+C

SET SOFTSEEK OFF

RETURN 0

*********************************************************************

* Процедура навигации ( просмотра ) БД *

*********************************************************************

PROCEDURE navy

PRIVATE sel1,clr1,screen1

sel1=SELECT()

clr1=SETCOLOR()

menu1=1

D2=.F.

SELECT karta

SET SOFTSEEK ON

SET COLOR TO &color5

DO WHILE menu1#0

@ 7,8 CLEAR TO 14,72

SAVE SCREEN TO screen1

@ 8,15 PROMPT "ВВЕДИТЕ НОМЕР И/Б "

@ 9,15 PROMPT "ВВЕДИТЕ ФАМИЛИЮ БОЛЬНОГО "

@ 10,15 PROMPT "ВВЕДИТЕ ДАТУ ПОСТУПЛЕНИЯ "

@ 11,15 PROMPT "ТЕКУЩАЯ КАРТА "

@ 12,15 PROMPT "СЛЕДУЮЩАЯ КАРТА "

@ 13,15 PROMPT "ПРЕДЫДУЩАЯ КАРТА "

MENU TO menu1

IF menu1=1

SET CURSOR ON

@ 8,45 GET _NUM_IB PICTURE "@R 99/99999"

READ

SET CURSOR OFF

SEEK _NUM_IB

D2=EOF()

menu1=5

ELSEIF menu1=2

SET CURSOR ON

@ 9,45 GET _FAM PICTURE "@K" VALID RUSSIAN(_FAM)

READ

SET CURSOR OFF

SET FILTER TO FAM>=ALLTRIM(_FAM)

GO TOP

D2=EOF()

menu1=5

SET FILTER TO

ELSEIF menu1=3

SET CURSOR ON

@ 10,45 GET _DATE_IN PICTURE "@D"

READ

SET CURSOR OFF

SET FILTER TO DATE_IN=_DATE_IN

GO TOP

D2=EOF()

IF D2=.F.

menu1=1

@ 16,8 CLEAR TO 20,72

DO WHILE menu1#0.AND.!D2

_NUM_IB=NUM_IB

_FAM=FAM

_DATE_IN=DATE_IN

DO first

@ 11,14 TO 14,40 DOUBLE

@ 12,15 PROMPT "СЛЕДУЮЩАЯ КАРТА "

@ 13,15 PROMPT "ПРЕДЫДУЩАЯ КАРТА "

MENU TO menu1

IF menu1=1

SKIP

D2=EOF()

ELSEIF menu1=2

SKIP -1

D2=BOF()

ENDIF

ENDDO

menu1=1

ENDIF

SET FILTER TO

ELSEIF menu1=5

SKIP

D2=EOF()

ELSEIF menu1=6

SKIP -1

D2=BOF()

ENDIF

@ 16,8 CLEAR TO 20,72

IF D2=.F.

_NUM_IB=NUM_IB

_FAM=FAM

_DATE_IN=DATE_IN

DO first

ELSEIF D2=.T.

@ 17,25 TO 19,55 DOUBLE

@ 18,31 SAY "БОЛЬШЕ ЗАПИСЕЙ НЕТ!"

ENDIF

ENDDO

SET SOFTSEEK OFF

SELECT (sel1)

SET COLOR TO (clr1)

RETURN

*********************************************************************

* ПРОВЕРКА ПРАВИЛЬНОСТИ ЗАПОЛНЕНИЯ КАРТЫ *

*********************************************************************

FUNCTION all_r

PRIVATE _qui

_qui=.F.

IF EMPTY(_FAM)=.T.

message('e',"НЕ ВВЕДЕНА ФАМИЛИЯ ПАЦИЕНТА")

beg_line=1

cur_promp=2

ELSEIF EMPTY(_DATE_B)=.T.

message('e',"НЕ ВВЕДЕНА ДАТА РОЖДЕНИЯ")

beg_line=1

cur_promp=5

ELSEIF EMPTY(_OLD)=.T.

message('e',"НЕ ВВЕДЕН ВОЗРАСТ")

beg_line=1

cur_promp=6

ELSEIF EMPTY(_RAION)=.T.

message('e',"НЕ ВВЕДЕН РАЙОН ПРОЖИВАНИЯ")

beg_line=1

cur_promp=9

ELSEIF EMPTY(_CITY_VILL)=.T.

message('e',"НЕ ВВЕДЕН ПУНКТ ")

beg_line=1

cur_promp=10

ELSEIF EMPTY(_STATE)=.T.

message('e',"НЕ ВВЕДЕНО НАЗВАНИЕ ГОСУДАРСТВА ")

beg_line=1

cur_promp=12

ELSEIF EMPTY(_DEPARTMENT)=.T.

message('e',"НЕ ВВЕДЕНO НАЗВАНИЕ ОТДЕЛЕНИЕ")

beg_line=1

cur_promp=13

ELSEIF EMPTY(_KOIKA)=.T.

message('e',"НЕ ВВЕДЕН ПРОФИЛЬ КОЙКИ")

beg_line=1

cur_promp=14

ELSEIF EMPTY(_DATE_IN)=.T.

message('e',"НЕ ВВЕДЕНА ДАТА ПОСТУПЛЕНИЯ")

beg_line=1

cur_promp=17

ELSEIF EMPTY(_DATE_END)=.T.

message('e',"НЕ ВВЕДЕНА ДАТА ВЫПИСКИ")

beg_line=20

cur_promp=20

ELSEIF _ALL_DAY<0.AND.EMPTY(_DATE_END)=.F.

beg_line=1

cur_promp=17

message('e',"НЕСООТВЕТСТВИЕ МЕЖДУ ДАТАМИ ПОСТУПЛЕНИЯ И ВЫПИСКИ")

ELSEIF _END1=3.AND.EMPTY(_OLD_D)=.T.

message('e',"НЕ ВВЕДЕН ВОЗРАСТ НА МОМЕНТ СМЕРТИ")

beg_line=1

cur_promp=18

ELSEIF EMPTY(_END1)=.T.

message('e',"НЕ ВВЕДЕН ПУНКТ ")

beg_line=1

cur_promp=19

ELSEIF EMPTY(_NUM_COME)=.T.

message('e',"НЕ ВВЕДЕНО КОЛИЧЕСТВО ГОСПИТАЛИЗАЦИЙ")

beg_line=20

cur_promp=22

* ELSEIF EMPTY(_DIA_DIRECT)=.T.

* message('e',"НЕ ВВЕДЕН НАПРАВЛЯЮЩИЙ ДИАГНОЗ")

* beg_line=20

* cur_promp=21

ELSEIF LEN(vars1[1])=0

message('e',"НЕ ВВЕДЕН ОСНОВНОЙ ДИАГНОЗ")

beg_line=20

cur_promp=23

ELSEIF AT("000.0",vars1[1])#0.AND.LEN(vars[1])>80

message('e',"ОШИБОЧНЫЙ ДИАГНОЗ")

beg_line=20

cur_promp=25

ELSEIF AT("000.0",vars1[1])#0.AND.LEN(vars1[2])#0

message('e',"ОШИБОЧНЫЙ ДИАГНОЗ")

beg_line=20

cur_promp=25

ELSE

_qui=.T.

ENDIF

RETURN (_qui)

*********************************************************************

* Представление на экране основной информации из 66 формы *

*********************************************************************

PROCEDURE first

IF !BOF().AND.!EOF()

@ 16,8 CLEAR TO 20,72

@ 17,15 SAY "НОМЕР И/Б :"+NUM_IB

@ 18,15 SAY "ФАМИЛИЯ БОЛЬНОГО :"+ALLTRIM(FAM)

@ 19,15 SAY "ДАТА ПОСТУПЛЕНИЯ :"

@ 19,34 SAY DATE_IN

ENDIF

RETURN

*********************************************************************

* Каталог операций *

*********************************************************************

FUNCTION catalog

PARAMETERS s,t

PRIVATE sel3,screen3,N3

sel3=SELECT()

SAVE SCREEN TO screen3

select 0

use cato.dbf index cato alias cato

SET SOFTSEEK ON

SEEK s

SET SOFTSEEK OFF

IF FOUND()

t=NAME_ILL

ELSE

private NUILL,K

go top

nuill=RECCOUNT()

declare OPERATION[NUILL]

for K=1 to NUILL

operation[k]=NAME_ILL

skip 1

next

release NUILL,K

@ 4,1 CLEAR TO 21,78

@ 4,1 TO 21,78

saycent(4,1,78," КАТАЛОГ ОПЕРАЦИЙ ")

N3=ACHOICE(5,2,20,77,operation,.T.,"",NUMBER-1)

IF LASTKEY()=27

RESTORE SCREEN FROM screen3

use

SELECT (sel3)

RETURN (-1)

ENDIF

GO N3

s=SHIFR

t=NAME_ILL

ENDIF

RESTORE SCREEN FROM screen3

use

SELECT (sel3)

RETURN (0)

*********************************************************************

* Процедура настройки каталогов *

*********************************************************************

PROCEDURE recon

PRIVATE N4,N5,cod_name

STORE 0 TO N4,N5

DO WHILE gotomain=.F.

cod_name=SPACE(4)

codif1("CORR",@N4)

IF LASTKEY()=27

SET CURSOR OFF

RETURN

ELSEIF N4=1

cod_name="RIGS"

ELSEIF N4=2

cod_name="DIRS"

ELSEIF N4=3

cod_name="STTE"

ELSEIF N4=4

cod_name="HOSP"

ELSEIF N4=5

cod_name="BIRS"

ELSEIF N4=6

cod_name="RIZS"

ELSEIF N4=7

cod_name="DEPS"

ELSEIF N4=8

cod_name="KOIK"

ELSEIF N4=9

cod_name="RIZ1"

ELSEIF N4=10

cod_name="RIZ2"

ELSEIF N4=11

cod_name="RIZ3"

ELSEIF N4=12

cod_name="OLDS"

ELSEIF N4=13

cod_name="PLCE"

ENDIF

codifM("CODIF",cod_name,@N5)

ENDDO

RELEASE N4,N5,cod_name

RETURN

*********************************************************************

* Продедура работы с каталогами *

*********************************************************************

FUNCTION codifM

PARAMETERS codfile,code_name,code_var

PRIVATE screen,sel,ret,i,k,svtx,maxlen,color,count,first,x1,x2,y1,y2

PRIVATE prom,prom1

IF !t_qwerty

RETURN 0

ENDIF

SAVE SCREEN TO screen

SET CURSOR OFF

color=SETCOLOR()

sel=SELECT()

SET COLOR TO (color3)

SET EXACT OFF

SELECT &CODFILE

CLEAR TYPEAHEAD

prom= "ESC- отказ,ENTER-переименовать"

prom1="INS-добавить,DEL-удалить"

first=1

DO WHILE .T.

SEEK (code_name)

IF !FOUND()

RETURN ""

ENDIF

svtx=ALLTRIM(TEXT)

maxlen=MAX(LEN(svtx),MAX(LEN(prom),LEN(prom1)))

COUNT WHILE SUBSTR(KEY,1,4)=SUBSTR(code_name+' ',1,4) TO COUNT

count=count-1 && не учитываем заголовок

DECLARE A[count],B[count]

* A[]-массив для текстов шаблонов

* B[]-массив для номеров шаблонов

IF count=0

DECLARE A[1]

a[1]=" Кодификатор пуст,воспользуйтесь клавишей INS"

maxlen=MAX(maxlen,40)

ENDIF

SEEK(code_name)

FOR k=1 TO COUNT

SKIP

A[K]=ALLTRIM(TEXT)

B[K]=SUBSTR(KEY,5)

maxlen=MAX(maxlen,LEN(A[K]))

NEXT

y1=12-ROUND(MIN(count,13)/2 +0.49,0)

x1=37-ROUND(MIN(maxlen,72)/2 +0.49,0)

* рисование рамки и заголовка *

SET COLOR TO (color3)

y2=MIN(y1+count+2,20)

x2=MIN(x1+maxlen+3,77)

RESTORE SCREEN FROM SCREEN

@ y1,x1,y2,x2 BOX singl+fon2

@ y2,x1,y2+3,x2 BOX "+-+¦--L¦"+fon2

saycent(y2+1,x1,x2,prom)

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 &&

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 &&

IF count>0

ins_pic(code_name,b[count])

ELSE

ins_pic(code_name,' ')

ENDIF

first=count+1

CASE LASTKEY()=7 &&

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)

old1=alltrim(str(year1-1))

else

if day(today)

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

f_mov=1

keyboard chr(23)

return(0)

case key=5 .and. line-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

181