*********************************************************************
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 <= CLASS->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 <= CLASS->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 <= CLASS->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 <= GRUP->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 <= GRUP->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<s1
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)