Cache for Windows^INT^^~Format=Cache.S~
%RO on  22  Mar  2010     1 : 23  PM
dbf^INT^ 1 ^ 61807 , 48200 ^ 0 
dbf ;Кривошеев С.А.;Процедуры и функции для работы с файлами формата dbf;;[  22 / 03 / 2010   13 : 22  ]
TMPLOAD                                ; * Пример чтения записей *
 n
 S dbname=$NA(^F($J,"^dbf","Name"))
 s file="c:\box\tmp.dbf"
 s file=$$DbOpen(file)
 i file="" w !!,"Проблемы с открытием файла..." q
 f  s val=$$NextRec(file,"drec") q:val=""  d TMPREC
 c file
 q
TMPREC                                 ; показать запись
 w !
 zw drec
 h  1 
 q
TMPCRT                                 ; * Пример создания файла dbf *
 N
 S dbname=$NA(^F($J,"^dbf","Name"))
 S dbdata=$NA(^F($J,"^dbf","Data"))
 s file="\\ksa\box\tmp.dbf"
 K @dbname
 D TMPNEW
 S dbdev=$$DbOpen(file)
 K @dbdata
 D REPLACE("KFOSB","tmp")
 D REPLACE("SUM", 100 )
 D DBAPPEND()
 K @dbdata
 D REPLACE("KFOSB","tm1")
 D REPLACE("SUM", 200 )
 D DBAPPEND()
 C dbdev
 W !!,"Все."
 Q
TMPNEW                                 ; создание структуры
 N cas
 D ADDFLD("KFOSB", 3 )
 D ADDFLD("NLS", 10 )
 D ADDFLD("NLS_PRN", 22 )
 D ADDFLD("NLS_KFOSB", 3 )
 D ADDFLD("FIO", 40 )
 D ADDFLD("SUM", 12 ,"N", 2 )
 D ADDFLD("KNKEY", 10 )
 D ADDFLD("KOP", 3 ,"N")
 D ADDFLD("DOP", 3 ,"N")
 D ADDFLD("UDOST", 8 )
 D ADDFLD("IDN", 10 ,"N")
 D ADDFLD("N_PLAT", 6 )
 D ADDFLD("N_ORG", 3 )
 D ADDFLD("ERR", 60 )
 D ADDFLD("MASK", 1 )
 S cas=$$DbCreate(file,dbname)
 K @dbname
 W:cas !,"Фаил "_file_" создан!"
 W !!,"Все."
 Q
DBAPPEND(Dev,Data,Name)                ; * Добавить запись *
 N str,i,beg,allrec,var,file
 ; Dev  - номер открытого устройства
 ; Data - имя глобала данных записи
 ; Name - имя стркутурного глобала
 S Dev=$G(Dev,$G(dbdev))
 S Data=$G(Data,$G(dbdata))
 S Name=$G(Name,$G(dbname))
 S str=" "
 S i=""
 F  S i=$O(@Name@("Fields", 0 ,i)) Q:i=""  D VALFLD
 S file=@Name@("File")
 S allrec=@Name@("AllRec")
 S beg= 32 *(@Name@("AllFld")+ 1 )+ 1 
 S beg=beg+(@Name@("LenRec")*allrec)
 D USE(Dev,beg)
 W str_$C( 26 )
 S allrec=allrec+ 1 
 S @Name@("AllRec")=allrec
 D USE(Dev, 1 )
 S var=$zd($h, 3 )
 S var=$tr(var,"-")
 S $e(var, 1 , 2 )=""
 S var=$$DateSym(var)
 D W(var)
 S var=$$NSym(allrec)
 D W(var, 4 )
 Q
VALFLD                                 ; значение поля
 N fld
 S fld=@Name@("Fields", 0 ,i)
 D:'$D(@Data@(fld)) REPLACE(fld,,Data,Name)
 S str=str_@Data@(fld)
 Q
REPLACE(Fld,Val,Data,Name)             ; * Записать изменение поля *
 N typ,len,dec
 ; Data - имя глобала данных записи
 ; Name - имя стркутурного глобала
 S Val=$G(Val)
 S Data=$G(Data,$G(dbdata))
 S Name=$G(Name,$G(dbname))
 S typ=@Name@("Fields", 1 ,Fld,"Typ")
 S len=@Name@("Fields", 1 ,Fld,"Len")
 S dec=@Name@("Fields", 1 ,Fld,"Dec")
 I typ="L" S:Val= 1  Val="T" S:Val="" Val="F"
 S:typ="N" Val=$J(+Val,len,dec)
 S:typ="D" Val=$$DateVal(Val)
 S:typ="C" Val=$$PadR(Val,len)
 S Val=$E(Val, 1 ,len)
 S @Data@(Fld)=Val
 Q
DateVal(Val)                           ; Значение типа дата
 q:Val="" $j("", 8 )
 q:Val'["." Val
 q $$ConvData(Val)
NextRec(File,Data,Type,Del,Name)       ; * Прочитать следующую запись *
 n rec,data,dev,i,dn
 ; File - имя файла (или порта MSM)
 ; Data - имя переменной для записи данных по полям
 ; Type -  1  убрать пробелы справа,  2  слева,  3  справа и слева (если Data'="")
 ; Del  -  0  не читать удаленные записи,  1  читать
 ; Name - имя стркутурного глобала
 s Data=$g(Data)
 s Type=$g(Type, 3 )
 s Del=$g(Del, 0 )
 S Name=$G(Name,$G(dbname))
 s dev=$i
 s rec=$g(@Name@("Record"))+ 1 
NEXTREC                                ; Собственно чтение
 q:@Name@("AllRec")<rec ""
 D USE(File)
 r data#@Name@("LenRec")
 D USE(dev)
 s @Name@("Record")=rec
 s rec=rec+ 1  
 i 'Del,$e(data)="*" g NEXTREC
 s $e(data)=""
 s data=$$Upper(data)
 q:Data="" data
 s dn=$na(@Name@("Fields"))
 s i=""
 f  s i=$o(@dn@( 0 ,i)) q:i=""  d DATAFLD 
 q rec
DATAFLD                                ; записать значение поля
 n fld,val,l,typ
 s fld=@dn@( 0 ,i)
 s l=@dn@( 1 ,fld,"Len")
 s typ=@dn@( 1 ,fld,"Typ")
 s val=$e(data, 1 ,l)
 d:typ="D" DATE
 d:typ="N" NUMERIC
 d:typ="L" LOGICAL
 d SPACE
 s @Data@(fld)=val
 s data=$e(data,l+ 1 ,$l(data))
 q
LOGICAL                                ; логическое поле
 s val=$$At(val)
 i val="T" s val= 1  q
 s val= 0 
 q
NUMERIC                                ; числовое поле
 s val=$$At(val) 
 s val=+val
 s:val= 0  val=""
 q
SPACE                                  ; убрать пробелы
 q:typ'="C"
 i Type= 1  s val=$$Rt(val) q
 i Type= 2  s val=$$Lt(val) q
 i Type= 3  s val=$$At(val) q
 q
DATE                                   ; преобразование даты
 s val=$$ConvData(val)
 s:val[" " val=""
 q
DbOpen(File,Name)                      ; * Открыть DBF *
 N prt,var,allfld,dev,i,dn
 ; Name - имя стркутурного глобала
 S Name=$G(Name,$G(dbname))
 s Byte=$g(Byte, 16 )
 S dev=$I
 K @Name
 S prt=$$FOpen(File,"RWU")
 I prt="" D USE(dev) Q ""
 S @Name@("File")=File
 D LOADTIT
 S dn=$NA(@Name@("Fields"))
 F i= 1 : 1 :allfld D LOADFLD
 D USE(prt,@Name@("LenTit"))
 D USE(dev)
 Q prt
LOADFLD                                ; данные о поле
 N beg,var,fld,str
 S beg= 32 *i
 D USE(prt,beg)
 R str# 18 
 D USE(dev)
 S fld=$E(str, 1 , 11 )
 S fld=$p(fld,$C( 0 ))
 S @dn@( 0 ,i)=fld
 S @dn@( 1 ,fld,"Pos")=i
 S var=$E(str, 12 )
 S @dn@( 1 ,fld,"Typ")=var
 S var=$E(str, 17 )
 S var=$A(var)
 S @dn@( 1 ,fld,"Len")=var
 S var=$E(str, 18 )
 S var=$A(var)
 S @dn@( 1 ,fld,"Dec")=var
 Q
LOADTIT                                ; данные шапки
 N str
 D USE(prt, 4 )
 R str# 8 
 D USE(dev)
 S var=$E(str, 1 , 4 )
 S var=$$SymN(var)
 S @Name@("AllRec")=var
 S var=$E(str, 5 , 6 )
 S var=$$SymN(var)
 S @Name@("LenTit")=var
 S allfld=(var- 1 \ 32 )- 1 
 S @Name@("AllFld")=allfld
 S var=$E(str, 7 , 8 )
 S var=$$SymN(var)
 S @Name@("LenRec")=var
 Q
DbCreate(File,Name,Code)               ; * Создание файла формата dBASE III *
 N prt,dev,lentit,lenrec
 ; File - имя файла
 ; Name - имя стркутурного глобала
 ; Code - имя кодовой страницы
 s:$g(Code)="" Code="cp866"
 S dev=$I
 S prt=$$FOpen(File)
 D USE(dev)
 Q:prt=""  0 
 D DATA
 D USE(prt)
 D TITLE
 D WFLDS
 D USE(dev)
 C prt
 Q  1 
WFLDS                                  ; записать данные ополях
 N i
 S i=""
 F  S i=$O(@Name@(i)) Q:i=""  D WFLD
 D W($C($ZH("0D")))
 Q
WFLD                                   ;    записать поле
 N var
 S var=@Name@(i,"Fld")
 D W(var, 11 )
 S var=$G(@Name@(i,"Typ"),"C")
 D W(var)
 ; ? адрес данных поля в памяти
 D W(, 4 )
 S var=@Name@(i,"Len")
 S var=$$NSym(var)
 D W(var)
 S var=$G(@Name@(i,"Dec"), 0 )
 S var=$$NSym(var)
 D W(var)
 D W(, 14 )
 Q
DATA                                   ; сбор данных о структуре
 N i
 S i=$O(@Name@(""),- 1 )
 S lentit= 32 *(i+ 1 )+ 1 
 S lenrec= 0 
 S i=""
 F  S i=$O(@Name@(i)) Q:i=""  S lenrec=lenrec+@Name@(i,"Len")
 S lenrec=lenrec+ 1 
 Q
TITLE                                  ; титульные данные
 N dat,var
 S dat=$$Date()
 D W($C($ZH("03")))
 S var=$$ConvData(dat)
 S var=$$DateSym(var)
 D W(var, 3 )
 D W(, 4 )
 S var=$$NSym(lentit)
 D W(var, 2 )
 S var=$$NSym(lenrec)
 D W(var, 2 )
 D W(, 17 )
 s val=$$Code
 D W(val)
 D W(, 2 )
 Q
W(Str,Len,Sym)                         ; записать данные
 S Str=$G(Str)
 S Len=$G(Len,$L(Str))
 S Sym=$G(Sym,$C( 0 ))
 W $$PadR(Str,Len,Sym)
 Q
Code()                                 ; * Код кодовой страницы *
 q:Code="CP866" $c( 101 )
 q:Code="WINDOWS-1251" $c( 32 )
 q " "
ADDFLD(Fld,Len,Typ,Dec,Name)           ; * Добавить поле в структурный глобал *
 N i
 ; Fld  - имя поля
 ; Len  - длина
 ; Typ  - тип
 ; Dec  - количество знаков после запятой
 ; Name - имя стркутурного глобала
 S Typ=$G(Typ,"C")
 S:$g(Dec)="" Dec= 0 
 S Name=$G(Name,$G(dbname))
 S:Typ="D" Len=$S($G(Len)="": 8 , 1 :Len)
 S:Typ="M" Len= 10 
 S:Typ="L" Len= 1 
 S i=$O(@Name@(""),- 1 )+ 1 
 S @Name@(i,"Fld")=Fld
 S @Name@(i,"Len")=Len
 S @Name@(i,"Typ")=Typ
 S @Name@(i,"Dec")=Dec
 Q
DateSym(Date)                          ; * Дату в символы *
 N str,i,n
 S str=""
 S n=$L(Date)\ 2 
 F i= 1 : 1 :n S str=str_$C($E(Date,(i- 1 )* 2 + 1 ,i* 2 ))
 Q str
NSym(N)                                ; * Число в символы *
 N str,base,var
 S base= 256 
 S str=""
LABEL1                                 ; метка операции
 S var=N#base
 S str=str_$C(var)
 S N=N\base
 G:N'=0 LABEL1
 Q str
SymN(Str)                              ; * Символы в число *
 N n,base,l,i,k
 S base= 256 
 S n= 0 
 S l=$L(Str)
 S k= 1 
 F i= 1 : 1 :l D NEWSYM
 Q n
NEWSYM                                 ; очередной символ
 N var
 S var=$E(Str,i)
 S var=$A(var)
 S var=var*k
 S n=n+var
 S k=k*base
 Q
FOpen(File,Typ,Byte,Sym)               ; * Открыть файл *
 S Typ=$G(Typ,"WNS")
 S:Typ="W" Typ="WNS"
 S:Typ="R" Typ="RS"
 S Sym=$G(Sym)
 I $ZU( 68 , 40 , 1 )
 q:":\/"[$e(File,$l(File)) ""
 I Sym'="" O File:(Typ::Sym):0 Q:$T File Q ""
 O File:(Typ::""): 0 
 Q:$T File
 Q ""
FUse(File,Byte)                        ; * Использовать файл *
 S Byte=$G(Byte)
 I Byte="" U File Q File
 I Byte'="" U File:Byte Q File
 Q File
USE(Dev,Byte)                          ; * Активизировать устройство *
 S Dev=$G(Dev,$P)
 S Byte=$G(Byte)
 I Byte'="" U Dev:Byte Q
 U Dev
 Q
Upper(Str)                            ; Перевести строку в верхний регистр
 N str1,str2
 S str2="QWERTYUIOPASDFGHJKLZXCVBNMЙЦУКЕНГШЩЗХФЫВАПРОЛДЖЭЯЧСМИТЬБЮЪЁ"
 S str1="qwertyuiopasdfghjklzxcvbnmйцукенгшщзхфывапролджэячсмитьбюъё"
 Q $TR(Str,str1,str2)
PadR(Str,Len,Sym)                     ; Равнять справа строку Str до длины Len
                                      ; символами Sym. По умолчанию - пробелами
 S Len=$G(Len, 80 )
 Q $E(Str_$$Rs($G(Sym," "),Len), 1 ,Len)
ConvData(Data)                        ; Конвертация даты
                                      ;  12 . 01 . 95  ->  950112 
                                      ;  950112  ->  12 . 01 . 95 
 q:Data="" ""
 Q:Data["." $TR("AaGgBbCc","Cc.Bb.AaGg",Data)
 Q:$L(Data)= 6  $TR("Cc.Bb.Aa","AaBbCc",Data)
 Q $TR("Cc.Bb.AaGg","AaGgBbCc",Data)
At(S)                                 ; Убрать левые и правые пробелы
 Q $$Rt($$Lt(S))
Rt(Str)                               ; Убрать правые пробелы в Str
 N s,l
 S l=$L(Str),s=$J("",l)
 Q $E(Str, 0 ,$F(Str_s,s)-l- 1 )
Lt(Str)                               ; Убрать левые пробелы в Str
 Q $E(Str,$F(Str_".",$E($TR(Str_"."," ")))- 1 ,$L(Str))
Rs(Symbol,Num)                        ; Повторить Num раз символ Symbol
 N str
 S $P(str,Symbol,Num+ 1 )=""
 Q $G(str)
Date(Hor,Typ)
 n dat
 s:$g(Hor)="" Hor=$h
 s Typ=$g(Typ)
 s dat=$zd(Hor, 4 )
 s dat=$tr(dat,"/",".")
 s dat=$e(dat, 1 , 8 )
 q dat