Разработка автоматизированной системы учета выбывших из стационара

CASE _OTCH=13

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

SELECT DIA66

SET RELATION to NUM_IB into KARTA, TO SHIFR INTO BUFF8

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_ENDSHIFR>"0000".AND.DIA66->SHIFRKOD1="1"

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

есть)

_SHIFR=DIA66->SHIFR

SELECT BUFF8

IF EOF()

APPEND BLANK

REPLACE SHIFR WITH _SHIFR

ENDIF

IF KARTA->END1=1.OR.KARTA->END1=2

REPLACE COUNT1 WITH COUNT1+1 && ОБЩЕЕ КОЛИЧЕСТВО ВЫБЫВШИХ

REPLACE A1 WITH A1+KARTA->ALL_DAY && ПРОВЕДЕНО ИМИ ДНЕЙ

IF KARTA->OLDEND1=3

REPLACE A2 WITH A2+1 && ОБЩЕЕ КОЛИЧЕСТВО УМЕРШИХ

REPLACE A3 WITH A3+KARTA->ALL_DAY && ПРОВЕДЕНО ИМИ ДНЕЙ

IF KARTA->OLDDEPARTMENT,.T.,.F.)).AND.;

KARTA->DATE_END>=_DATE_FROM.AND.KARTA->DATE_ENDSHIFR>"0000".AND.DIA66->SHIFRKOD1="1"

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

есть)

_SHIFR=DIA66->SHIFR

SELECT BUFF8

IF EOF()

APPEND BLANK

mkb(1,1,@_SHIFR,@txt)

REPLACE NAME WITH txt

REPLACE SHIFR WITH _SHIFR

ENDIF

pole=FIELD(8+KARTA->DEPARTMENT)

REPLACE &pole WITH &pole+1

SELECT DIA66

ENDIF

SKIP 1

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

ENDDO

SET RELATION TO

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

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

CASE _OTCH=15

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

SELECT KARTA

GO TOP

PRIVATE _NAME,_NUMBER

PRIVATE OT1D1,OT2D1

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_ENDRAION>1

SELECT BUFF8

IF KARTA->STATE=1

_NUMBER=""

IF KARTA->PLACE=0

_SHIFR="99 "

_NAME="Прочие области и районы РФ"

ELSE

_SHIFR=RIGHT(ALLTRIM(extra1(KARTA->PLACE,"PLCE")),4)

_NAME=extra1(KARTA->PLACE,"PLCE")

ENDIF

IF KARTA->RAION=2

_NUMBER="*"

_SHIFR="1000"

_NAME="Московская область"

ENDIF

ELSE

_NUMBER="*"

_SHIFR=SPACE(2)+STR(KARTA->STATE,2)

_NAME=extra1(KARTA->STATE,"STTE")

ENDIF

SEEK _SHIFR

IF !FOUND()

APPEND BLANK

REPLACE NUMBER WITH _NUMBER,SHIFR WITH _SHIFR,NAME WITH _NAME

ENDIF

pole=FIELD(8+KARTA->DIRECT1)

REPLACE &pole WITH &pole+1 && НАПРАВЛЯЮЩЕЕ

УЧРЕЖДЕНИЕ

pole=FIELD(23+KARTA->DEPARTMENT)

REPLACE &pole WITH &pole+1 && ОТДЕЛЕНИЯ БОЛЬНИЦЫ

pole=FIELD(38+KARTA->PASS)

REPLACE &pole WITH &pole+1 && Планово/экстренно

REPLACE COUNT1 WITH COUNT1+KARTA->ALL_DAY && Проведено дней

REPLACE COUNT2 WITH COUNT2+1 && ВСЕГО ВЫПИСАНО

SELECT KARTA

ENDIF

ENDIF

SKIP 1

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

ENDDO

SELECT BUFF8

SUM COUNT1,COUNT2,A1,A2,A3,A4,A5,A6,A7,A8,A9,A0,;

B1,B2,B3,B4,B5,B6,B7,B8,B9,B0,C1,C2,C3,C4,C5,C6,C7,C8,C9,C0 TO;

_1,_2,_3,_4,_5,_6,_7,_8,_9,_10,_11,_12,_13,_14,_15,_16,_17,_18,_19,;

_20,_21,_22,_23,_24,_25,_26,_27,_28,_29,_30,_31,_32

&& Суммирование по всем столбцам

APPEND BLANK

REPLACE SHIFR WITH " ",NAME WITH "Всего",COUNT1 WITH _1,;

COUNT2 WITH _2,A1 WITH _3,A2 WITH _4,A3 WITH _5,A4 WITH _6,;

A5 WITH _7,A6 WITH _8,A7 WITH _9,A8 WITH _10,A9 WITH _11,A0 WITH

_12,;

B1 WITH _13,B2 WITH _14,B3 WITH _15,B4 WITH _16,B5 WITH _17,;

B6 WITH _18,B7 WITH _19,B8 WITH _20,B9 WITH _21,B0 WITH _22,;

C1 WITH _23,C2 WITH _24,C3 WITH _25,C4 WITH _26,C5 WITH _27,;

C6 WITH _28,C7 WITH _29,C8 WITH _30,C9 WITH _31,C0 WITH _32

SUM COUNT1,COUNT2,A1,A2,A3,A4,A5,A6,A7,A8,A9,A0,;

B1,B2,B3,B4,B5,B6,B7,B8,B9,B0,C1,C2,C3,C4,C5,C6,C7,C8,C9,C0 TO;

_1,_2,_3,_4,_5,_6,_7,_8,_9,_10,_11,_12,_13,_14,_15,_16,_17,_18,_19,;

_20,_21,_22,_23,_24,_25,_26,_27,_28,_29,_30,_31,_32;

FOR SHIFR>" ".AND.SHIFR"1000"

&& Суммирование столбцов по всем областям РФ

APPEND BLANK

REPLACE SHIFR WITH "9990",NAME WITH "Всего по РФ",COUNT1 WITH _1,;

COUNT2 WITH _2,A1 WITH _3,A2 WITH _4,A3 WITH _5,A4 WITH _6,;

A5 WITH _7,A6 WITH _8,A7 WITH _9,A8 WITH _10,A9 WITH _11,A0 WITH

_12,;

B1 WITH _13,B2 WITH _14,B3 WITH _15,B4 WITH _16,B5 WITH _17,;

B6 WITH _18,B7 WITH _19,B8 WITH _20,B9 WITH _21,B0 WITH _22,;

C1 WITH _23,C2 WITH _24,C3 WITH _25,C4 WITH _26,C5 WITH _27,;

C6 WITH _28,C7 WITH _29,C8 WITH _30,C9 WITH _31,C0 WITH _32

OT1D1="OTCH"+ALLTRIM(STR(_OTCH))+"1"+".FRM" && OTCH*1.FRM

OT2D1="OTCH"+ALLTRIM(STR(_OTCH))+"1"+".TXT" && OTCH*1.TXT

REPORT FORM &OT1D1 TO FILE &OT2D1 PLAIN

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

CASE _OTCH=16.OR._OTCH=17.OR._OTCH=18.OR._OTCH=19

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

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_ENDEND1=2

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

IF KARTA->OLDSHIFR="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)DATE_END-KARTA->DATE_B+;

piece(KARTA->HOUR_B,KARTA->MINS_B,KARTA->HOUR_END,KARTA->MINS_END)OLDNUM_IB=KARTA->NUM_IB

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

(DIA66->SHIFR>="4800".AND.DIA66->SHIFRSHIFR="410 ".OR.KARTA->SHIFR="412 ")

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

piece(KARTA->HOUR_IN,KARTA->MINS_IN,KARTA->HOUR_END,KARTA-

>MINS_END)SHIFR>="6300".AND.KARTA->SHIFREND1=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->SHIFRSHIFR_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=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")

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)0

txt=ALLTRIM(STR(mons))

IF mons=1

txt=txt+" месяц"

ELSEIF monsmonth(b_dat)

old1=alltrim(str(year1))

else

if month(today)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()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-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

-----------------------

[pic]

Страницы: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11