Файл: Р азработка информационного комплекса для лечебного учреждения.doc

SET COLOR TO "W+/B"

@ 18,56 CLEAR TO 22,77

@ 18,56 TO 22,77

@ 18,65 SAY " "+DTOC(dat)+" "

@ 19,58 SAY REPLICATE(CHR(178),18)

@ 20,58 SAY REPLICATE(CHR(178),18)

@ 21,58 SAY REPLICATE(CHR(178),18)

SET COLOR TO "W+/BG"

****@ 20,57 CLEAR TO 21,76

@ 19,58 SAY hosp

//@ 21,64 SAY addr // для Убинского 

@ 8,1 SAY " ф Ы Ы ЫЯЯЯЫ ЫЯЯЯЯЫ ЫЯЯЯЯЫ ЫЯЯЯЯЫ ЯЯЯЫЯЯЯ ЫЯЯЯЯ Ы Ы ф"

@ 9,1 SAY " ффффф Ы Ы Ы Ы Ы Ы Ы Ы Ы Ы Ы Ы Ы Ы ЮЭ Ы Ы"

@ 10,1 SAY " фф ф фф ЮЭ ЮЭ Ы Ы Ы Ы Ы Ы Ы Ы Ы Ы Ы Ы Ы ЮЭ ЮЭ"

@ 11,1 SAY " ф ф ф ф Ы Ы Ы Ы Ы Ы Ы Ы Ы Ы Ы Ы Ы ЮЭ Ы Ы"

@ 12,1 SAY " фф ф фф фф ЮЭ ЫЬЬЫ Ы Ы Ы ЫЬЬЬЬЫ Ы Ы Ы ЫЬЬЬЬ ЫЬЬЫ ЮЭ ЮЭ"

@ 13,1 SAY " ффффф ф Ы Ы Ы Ы Ы Ы Ы Ы Ы Ы Ы Ы ЮЭ фффффффф"

@ 14,1 SAY " ф фф ЮЭ Ы ЫЬЬЬЫ ЫЬЬЬЬЫ Ы ЫЬЬЬЬЫ Ы ЫЬЬЬЬ Ы ЫЬ ЮЭ ЮЭ"

@ 14,1 SAY " ь"

SET COLOR TO "W+/B"

@ 16,6 CLEAR TO 20,39

@ 16,6 TO 20,39

RETURN

PROCEDURE BAY

exi=.T.

RETURN

PROCEDURE OPEN_DB

LOCAL i

SET COLOR TO "W+/W"

SELECT 1

USE passport

@ 3, 7 SAY SPACE(11)

INDEX ON STR(ID,6) TO passport

lenID=FIELDSIZE(FIELDNUM("ID")) // размер поля ID

SELECT 2

USE pat_list

@ 3, 18 SAY SPACE(11)

INDEX ON L_NAME-F_NAME-S_NAME-DTOS(BR_DATE) TO l_name

@ 3, 29 SAY SPACE(11)

INDEX ON STR(NUM_PASS,7) TO num_pass

@ 3, 40 SAY SPACE(11)

INDEX ON STR(ID,6) TO pat_list

SET INDEX TO pat_list, num_pass, l_name

SELECT 3

USE fluoteka

GOTO BOTTOM

maxNum=NUMBER

serNum=SERIY

dat_flu=FLUO_DATE

@ 3, 51 SAY SPACE(11)

INDEX ON STR(ID,6) TO fluoteka

SELECT 5

USE list_att

@ 3, 62 SAY SPACE(11)

SET COLOR TO "W+/B"

RETURN
PROCEDURE SETTING

LOCAL i, buf, s_c, n, alt1, k

PUBLIC grNa

buf=SAVESCREEN(0,0,24,79)

s_c=SETCOLOR("W+/BG+")

@ 0,0 CLEAR TO 24,79

@ 0,0 TO 23,79

SETCOLOR("W+/B+")

@ 24,0 CLEAR TO 24,79

@ 24, 1 SAY "Выберите пункт для настройки"

SETCOLOR("W+/BG+")

SELECT 5

SET FILTER TO !EMPTY(RUSSIAN)

COUNT FOR !EMPTY(RUSSIAN) TO n

PUBLIC topic[n], grp[n]

GOTO TOP

FOR i=1 TO n

topic[i]=TRIM(RUSSIAN)

k=(40-LEN(topic[i]))/2

topic[i]=SPACE(k)+topic[i]+SPACE(k)

grp[i]=GROUP

SKIP

NEXT

SETCOLOR("W+/BR+")

@ 4,20 CLEAR TO 5+n,60

@ 4,20 TO 5+n,60

DO WHILE .T. // 2 - выход по "Esc"

CLEAR TYPEAHEAD

SET FILTER TO !EMPTY(RUSSIAN)

GOTO TOP

FOR i=1 TO n

@ 4+i, 21 PROMPT topic[i]

NEXT

MENU TO alt1

IF alt1 = 0

SET FILTER TO

SETCOLOR(s_c)

RESTSCREEN(0,0,24,79,buf)

RETURN

ENDIF

grNa=grp[alt1]

DO SET_LIST

ENDDO

SET FILTER TO

SETCOLOR(s_c)

RESTSCREEN(0,0,24,79,buf)

RETURN
PROCEDURE SET_LIST

LOCAL i, buf, s_c, n, alt1, maxCod, buf1, sav_col, str, pre_alt1, k

// PUBLIC

buf=SAVESCREEN(0,0,24,79)

s_c=SETCOLOR("W+/BR+")

@ 0,0 CLEAR TO 24,79

@ 0,0 TO 22,79

SET FILTER TO GROUP==grNA

COUNT FOR GROUP==grNA TO n

GOTO TOP

PUBLIC txt[n+20], cod[n+20]

maxCod=0

FOR i=1 TO n

txt[i]=NAME

cod[i]=CODE

maxCod=IF(maxCod
IF DELETED()

txt[i]=txt[i]+" *"

ENDIF

SKIP

NEXT

alt1=0

pre_alt1=0

SETCOLOR("W+/BG+")

DO WHILE .T.

flag=0

k=IF(n+2<23, n+2, 22)

@ 1,7 CLEAR TO k,72

@ 1,7 TO k,72

SETCOLOR("W+/B+")

@ 23,0 CLEAR TO 24,79

@ 24,3 Пометка * означает, что данный пункт удален. Нажмите F8 для отмены удаления"

@ 23,0 SAY '"Esc" - выход; "Enter" - выбор; F2 - добавить; F3 - редактировать; F8 - удалить'

SETCOLOR("W+/BG+")

alt1 = ACHOICE(2,8,k-1,71,txt,.T.,"USE_SET",alt1)

IF LASTKEY() = 27

---

EXIT

ENDIF

CLEAR TYPEAHEAD

IF flag = 13

pre_alt1=alt1

ENDIF

IF pre_alt1 = 0 .AND. flag != -1

buf1=SAVESCREEN(0,0,24,79)

sav_col=SETCOLOR("W+/R+")

@ 8,15 CLEAR TO 12,65

@ 8,15 TO 12,65

@ 10, 25 SAY "Сначала сделайте выбор пункта!"

INKEY(delay)

SETCOLOR(sav_col)

RESTSCREEN(0,0,24,79,buf1)

ELSE

DO CASE

CASE flag = 13

SETCOLOR("W+/B+")

@ 0, 14 CLEAR TO 0,78

@ 0, 15 SAY txt[pre_alt1]

SETCOLOR("W+/BG+")

CASE flag = -2

buf1=SAVESCREEN(0,0,24,79)

sav_col=SETCOLOR("W+/B+")

@ 8,5 CLEAR TO 14,75

@ 8,5 TO 14,75

@ 10, 27 SAY "Пожалуйста, отредактируйте!"

str=txt[pre_alt1]

@ 12, 8 GET str

SET KEY 27 TO ESC_GETA

flag=0

READ

SET KEY 27 TO

IF flag != 2

LOCATE FOR CODE == cod[pre_alt1]

REPLACE NAME WITH str

COMMIT

txt[pre_alt1]=str

ENDIF

SETCOLOR(sav_col)

RESTSCREEN(0,0,24,79,buf1)

CASE flag = -7

IF SUBSTR(txt[pre_alt1],64,1)="*"

txt[pre_alt1]=SUBSTR(txt[pre_alt1],1,62)

LOCATE FOR CODE == cod[pre_alt1]

RECALL

// pre_alt1=0

ELSE

txt[pre_alt1]=txt[pre_alt1]+" *"

LOCATE FOR CODE == cod[pre_alt1]

DELETE

ENDIF

CASE flag = -1

buf1=SAVESCREEN(0,0,24,79)

@ 24,0 CLEAR TO 24,79

sav_col=SETCOLOR("W+/B+")

@ 8,5 CLEAR TO 14,75

@ 8,5 TO 14,75

@ 10, 30 SAY "Пожалуйста, добавьте!"

str=SPACE(LEN(NAME))

@ 12, 9 GET str

SET KEY 27 TO ESC_GETA

flag=0

READ

SET KEY 27 TO

IF flag != 2

APPEND BLANK

REPLACE NAME WITH str, CODE WITH maxCod+1, GROUP WITH grNA

COMMIT

maxCod=maxCod+1

n=n+1

txt[n]=str

cod[n]=maxCod

ENDIF

SETCOLOR(sav_col)

RESTSCREEN(0,0,24,79,buf1)

ENDCASE

ENDIF

ENDDO

SET FILTER TO

SETCOLOR(s_c)

RESTSCREEN(0,0,24,79,buf)

RETURN
PROCEDURE IDENT

** заведение новой карточки в картотеке

LOCAL i, limit, count, s_c

PUBLIC npass, iden, fl_pass, nd, filt, nCart, cond

limit=300

nCart=0

buf=SAVESCREEN(0,0,24,79)

sav_col=SETCOLOR("W+/RB")

SET KEY 27 TO ESC_GETA

flag=0

DO WHILE flag = 0 // 2 – выход по "Esc"

CLEAR TYPEAHEAD

fl_pass=0

npass=SPACE(7)

SETCOLOR("W+/RB")

@ 0,0 CLEAR TO 24,79

@ 0,0 TO 24,79 DOUBLE

SETCOLOR("W+/B")

@ 17,10 CLEAR TO 23,70

@ 17,10 TO 23,70 DOUBLE

@ 18, 12 SAY ' Введите номер паспорта (семь цифр) и нажмите "Enter"'

@ 22, 12 SAY 'Если нет паспорта  - "Enter" "Esc" - выход'

@ 20, 38 GET npass

READ

IF flag = 2

EXIT

ENDIF

npass=VAL(npass)

IF npass != 0

SELECT 2

SET ORDER TO 2

SET FILTER TO !DELETED() // без стертых записей!

SEEK STR(npass,7)

IF !FOUND()

s_c=SETCOLOR("W+/BG")

@ 10,10 CLEAR TO 12,70

@ 12,10 TO 12,70

@ 11, 20 SAY 'В флюоротеке НЕТ такого номера паспорта '

INKEY(0)

SETCOLOR(s_c)

ELSE

fl_pass=1

cond="NUM_PASS = npass"

DO CHOI_PAT

ENDIF

ELSE

ln=SPACE(30)

nd=0

DO WHILE nd = 0

ln=ln+SPACE(30-LEN(ln))

@ 18, 11 CLEAR TO 22, 69

@ 19, 17 SAY "Введите фамилию для поиска:"

@ 22, 17 SAY "Можно ввести 2 – 3 первых буквы фамилии"

@ 20, 35 GET ln

READ

IF flag = 2

EXIT

ENDIF

IF !EMPTY(ln)

ln=Rusup(TRIM(LTRIM(ln)))

SELECT 2

SET FILTER TO !DELETED() // без стертых записей!

SET ORDER TO 3

SEEK ln // filt=filt+".AND. ln $ 2->L_NAME"

IF !FOUND()

s_c=SETCOLOR("W+/BG")

@ 10,10 CLEAR TO 12,70

@ 12,10 TO 12,70

@ 11, 22 SAY 'В флюоротеке НЕТ такой фамилии'

---

INKEY(delay)

SETCOLOR(s_c)

flag = 2

EXIT

ELSE

nd=1

cond="ln $ 2->L_NAME"

DO CHOI_PAT

EXIT

ENDIF

ENDIF

ENDDO

ENDIF

SELECT 2

SET ORDER TO 1

SET FILTER TO

IF flag = 2 // пациента нет в картотеке,

flag = 0 // надо ввести паспортные данные

CLEAR TYPEAHEAD

DO IN_PASS

ENDIF

IF flag = 2

EXIT

ENDIF

IF fl_pass != 0 // паспортные данные введены успешно

DO NEW_FLUO // оформить новую карточку

nCart=nCart+1

ENDIF

IF flag = 2

EXIT

ELSE

IF nCart >= 35 // 35 – иначе портятся индексы!

nCart=0

SETCOLOR("W+/B")

@ 10,10 CLEAR TO 16,70

@ 10,10 TO 16,70

@ 13, 28 SAY 'Пожалуйста, подождите...'

SELECT 3

INDEX ON STR(ID,6) TO fluoteka

SELECT 1

INDEX ON STR(ID,6) TO passport

SELECT 2

INDEX ON L_NAME-F_NAME-S_NAME TO l_name

INDEX ON STR(NUM_PASS,7) TO num_pass

INDEX ON STR(ID,6) TO pat_list

SET INDEX TO pat_list, num_pass, l_name

ENDIF

ENDIF

ENDDO

SET KEY 27 TO

SETCOLOR(sav_col)

RESTSCREEN(0,0,24,79,buf)

RETURN
PROCEDURE CHOI_PAT

PRIVATE i

PUBLIC adoc:={}, aid:={}

PUBLIC afs:={} // только для нормальной работы PASSP

i=0

DO WHILE &cond

i=i+1

AADD(adoc,RTRIM(L_NAME)+" "+RTRIM(F_NAME)+" "+RTRIM(S_NAME);

+"; "+DTOC(BR_DATE)) // +"\\"+STR(ID)

AADD(aid,ID)

AADD(afs,"")

SKIP

ENDDO

@ 18, 11 CLEAR TO 22,69

@ 19, 23 SAY 'Выберите пациента и нажмите "Enter"'

@ 21, 20 SAY 'Нажмите "Esc", если пациента нет в списке'

SETCOLOR("W+/BG")

alter = ACHOICE(1,1,16,78,adoc,.T.,"USE_PASS",alter)

IF oper = 1 .AND. flag != 2 // пациент идентифицирован­

fl_pass=1

iden=aid[alter]

SET ORDER TO 1

SEEK STR(iden,6)

SELECT 1

SEEK STR(iden,6)

SELECT 3

SEEK STR(iden,6)

DO PASSP // отредактировать паспортные данные

ENDIF

RETURN
PROCEDURE ESC_GETA

** выход из GET по Esc

CLEAR GETS

flag=2

KEYBOARD CHR(13)

RETURN
PROCEDURE NEW_FLUO

** оформление новой карточки

LOCAL dsin, who, lab, numb, qs, buf, ser

@ 0,0 CLEAR TO 23,79

@ 0,0 TO 23,79 DOUBLE

nStr=24

nCol=1

str_dw="Введите данные флюорограммы"

DO STR_24

SELECT 3

dsin=SPACE(LEN(DS_INIT))

//IF dat_flu = dat

// numb=LTRIM(STR(maxNum+1))

// numb=IF(LEN(numb)=3, numb, IF(LEN(numb)=2, " "+numb, " "+numb))

//ELSE

// numb=" " // SPACE(3)

//ENDIF

numb=LTRIM(STR(maxNum+1))+SPACE(3-LEN(LTRIM(STR(maxNum+1))))

ser=LTRIM(STR(serNum))+SPACE(2-LEN(LTRIM(STR(serNum))))

qs=" "

@ 1, 1 SAY "Флюорограмма  N" GET numb

@ 1, 21 SAY "Серия " GET ser

@ 2, 1 SAY "Дата" GET dat

@ 3, 1 SAY "Число снимков" GET qs

READ

IF flag = 2

RETURN

ENDIF

alter=1

@ 4,1 SAY "Цель исследования"

@ 4, 20 PROMPT "профилактическая"

@ 5, 20 PROMPT "диагностическая"

MENU TO alter

IF flag = 2

RETURN

ENDIF

gi=IF(alter=1, .F., .T.)

SELECT 5

SET FILTER TO GROUP="DEPART" .AND. !DELETED()

COUNT FOR GROUP="DEPART" .AND. !DELETED() TO ndra

---

GOTO TOP

IF ndra = 0

SETCOLOR("W+/B")

@ 10,10 CLEAR TO 15,70

@ 10,10 TO 15,70

@ 12, 20 SAY 'Выберите пункт "НАСТРОЙКА" в главном меню'

@ 13, 19 SAY 'и заполните список «Направившие учреждения"'

INKEY(delay)

flag=2

SETCOLOR("W+/BG")

SET FILTER TO

RETURN

ENDIF

buf=SAVESCREEN(6,1,22,78)

@ 6, 1 SAY "Выберите направившее учреждение из списка "

adoc:=ARRAY(ndra)

aid:=ARRAY(ndra)

maxl=0

FOR i=1 TO ndra

adoc[i]=RTRIM(NAME)

aid[i]=CODE

maxl=IF(LEN(RTRIM(NAME))>maxl, LEN(RTRIM(NAME)), maxl)

SKIP

NEXT

s_c=SETCOLOR("W+/RB")

maxS=IF(8+ndra<22, 8+ndra, 22)

@ 7,9 CLEAR TO maxS,10+maxl

@ 7,9 TO maxS,10+maxl

alter=1

alter = ACHOICE(8,10,maxS-1,9+maxl,adoc,.T.,"USE_PASS",alter)

SETCOLOR(s_c)

RESTSCREEN(6,1,22,78,buf)

SET FILTER TO

//IF flag = 2

IF alter = 0

RETURN

ENDIF

who=aid[alter]

@ 6, 1 SAY "Направившее учреждение"+adoc[alter]

@ 7, 1 SAY "DS при направлении"

@ 8, 1 GET dsin

READ

IF flag = 2

RETURN

ENDIF

SET FILTER TO GROUP="LABORANT" .AND. !DELETED()

COUNT FOR GROUP="LABORANT" .AND. !DELETED() TO ndra

GOTO TOP

IF ndra = 0

SETCOLOR("W+/B")

@ 10,10 CLEAR TO 15,70

@ 10,10 TO 15,70

@ 12, 20 SAY 'Выберите пункт "НАСТРОЙКА" в главном меню'

@ 13, 21 SAY 'и заполните список "ФАМИЛИИ ЛАБОРАНТОВ"'

INKEY(delay)

flag=2

SETCOLOR("W+/BG")

SET FILTER TO

RETURN

ENDIF

buf=SAVESCREEN(6,1,22,78)

@ 9, 1 SAY "Выберите фамилию лаборанта из списка "

adoc:=ARRAY(ndra)

aid:=ARRAY(ndra)

maxl=0

FOR i=1 TO ndra

adoc[i]=RTRIM(NAME)

aid[i]=CODE

maxl=IF(LEN(RTRIM(NAME))>maxl, LEN(RTRIM(NAME)), maxl)

SKIP

NEXT

s_c=SETCOLOR("W+/RB")

maxS=IF(11+ndra<22, 11+ndra, 22)

@ 10,9 CLEAR TO maxS,10+maxl

@ 10,9 TO maxS,10+maxl

alter=1

alter = ACHOICE(11,10,maxS-1,9+maxl,adoc,.T.,"USE_PASS",alter)

SETCOLOR(s_c)

SET FILTER TO

IF alter = 0

RESTSCREEN(6,1,22,78,buf)

RETURN

ENDIF

lab=aid[alter]

@ 9, 1 SAY SPACE(36)

SELECT 3

APPEND BLANK

REPLACE ID WITH iden, FLUO_DATE WITH dat

REPLACE SERIY WITH VAL(ser), NUMBER WITH VAL(numb)

REPLACE QUAL WITH VAL(qs), GOAL WITH gi, DEPART WITH who

REPLACE DS_INIT WITH dsin, LABORANT WITH lab, KEY WITH .T.

SELECT 2

REPLACE LAST_DATE WITH dat

COMMIT

maxNum=maxNum+1

//INKEY(del1)

SETCOLOR("W+/B")

@24, 1 SAY 'Нажмите любую клавишу для продолжения, "Esc" - ввод описания флюорограммы`

INKEY(0)

IF LASTKEY() == 27

DO IN_FLUO

ENDIF

RETURN
PROCEDURE IN_PASS

** ввод паспортных данных нового пациента 

LOCAL i, lname, fname, sname, npass, bri, ag, sx, wrk, adr1, pro

LOCAL adr2, nph, cit, grinv, cont, buf, fl_seek

flag=0

@ 0,0 CLEAR TO 23,79

@ 0,0 TO 23,79 DOUBLE

nStr=24

nCol=1

str_dw="Введите паспортные данные"

DO STR_24

SELECT 2

IF !EMPTY(ln)

lname=SUBSTR(ln+SPACE(LEN(L_NAME)),1,LEN(L_NAME))

ELSE

lname=SPACE(LEN(L_NAME))

ENDIF

fname=SPACE(LEN(F_NAME))

sname=SPACE(LEN(S_NAME))

npass=SPACE(7)

bri=CTOD("")

sx="М"

SELECT 1

// pi=STR(pi,6)

pi=pi_inst

arr=arr_inst+SPACE(LEN(ARREA)-LEN(arr_inst))

adr1=SPACE(LEN(ADDRESS1))

adr2=SPACE(LEN(ADDRESS2))

nph=SPACE(LEN(PHONE))

grinv=SPACE(LEN(INVALID))

wrk=SPACE(LEN(WORK))

pro=SPACE(LEN(PROF))

@ 1, 1 SAY "Фамилия" GET lname

@ 2, 1 SAY "Имя " GET fname

@ 3, 1 SAY "Отчество" GET sname

@ 4, 1 SAY "Дата рождения" GET bri

@ 1, 45 SAY "Номер паспорта " GET npass

---

READ

lname=Rusup(lname)

fname=Rusup(fname)

sname=Rusup(sname)

IF flag = 2

RETURN

ENDIF

SELECT 2

SET ORDER TO 3

SEEK lname-fname-sname-DTOS(bri)

SET ORDER TO 1

fl_seek=0

IF FOUND()

iden=ID

SELECT 1

SEEK STR(iden,6)

ELSE

fl_seek=1

@ 4, 25 SAY "Пол (м/ж)" GET sx

---