all.prg

用于医院科室核算的软件,把每日的科室收入按类输入

****************************************
*     替换以前处方的收费明细类名
****************************************

set talk off
set echo off
set safe off
set dele on
set escape off
set exclusive off
set century on
set date to ansi
close database
clear all
clear 

sele 2
use h:\data\qq-yl
sele 1
use h:\data\zy980801

go top
do while ! eof()
if g14="西药费"
xg13 ="西药费"
else
xc1=g7
sele 2
loca for xc1=c1
if found()
xg13=c11
else
xg13="其它"
endif
endif

sele 1
repl g13 with xg13
skip
enddo
brow
****************************************
*     收集某目录下的某类文件
****************************************

set defa to h:\data\
tfile=adir(test,"*.dbf")
set defa to c:\vfp

create  dbf  temp;
(name c(15),long n(10),date d,time c(8),char c(2))
for i=1 to tfile 
appe blan
repl name with test(i,1)
repl long with test(i,2)
repl date with test(i,3)
repl time with test(i,4)
repl char with test(i,5)
endfor
brow
****************************************
*     收集所有统计库记录
****************************************

set defa to h:\data\
tfile=adir(test,"zy98*.dbf")
set defa to c:\vfp

create  dbf  temp;
(name c(15),long n(10),date d,time c(8),char c(2))
for i=1 to tfile 
appe blan
repl name with test(i,1)
repl long with test(i,2)
repl date with test(i,3)
repl time with test(i,4)
repl char with test(i,5)
endfor
close data
sele 1
use test

sele 3
use temp
go top

do while ! eof()
xname="h:\data\"+name
sele 1
appe from &xname
sele 3
skip
enddo
********************************************************
*     替换所有统计库的某种收费的收费明细类名
********************************************************

set defa to h:\data\
tfile=adir(test,"zy98*.dbf")
set defa to c:\vfp

create  dbf  temp;
(name c(15),long n(10),date d,time c(8),char c(2))
for i=1 to tfile 
appe blan
repl name with test(i,1)
repl long with test(i,2)
repl date with test(i,3)
repl time with test(i,4)
repl char with test(i,5)
endfor
close data
sele 3
use temp
go top
set defa to h:\data\
do while ! eof()
xname=name

sele 1
use &xname

go top
do while ! eof()

if g7="注射器"
xg13 ="处置费"
else
skip
loop
endif
sele 1
repl g13 with xg13
skip
enddo
sele 3
skip
enddo
************************************
*        床位费计算(含日收费项目)
************************************
use h:\data\qq-yl
loca for c1="诊查费"
xzcf=c3
loca for c1="与儿童同床"
xtcf=c3
loca for c1="训练费"
xxlf=c3

use h:\data\zy-zcyhz
repl all a2 with date() for empty(a2)
sele 1
use h:\data\zy-ba
pack
scan for empty(a17)
xa16=a16
xa17=date()
xa12=a12
xa121=a121
xa122=a122
sele 2
use h:\data\qq-cw
loca for alltrim(xa121)=alltrim(e1) and alltrim(xa122)=alltrim(e2)
if found()
xe9=e9
xe10=e10
else
go top
xe9=e9
xe10=e10
endif
mcwf=0
for n=0 to xa17-xa16
mrq=xa16+n
rq1=".10.01"
rq2=".04.15"
rq0=mrq
rq01=dtoc(rq0)
rqn=substr(rq01,1,4)
mcwfrq1=ctod(rqn+rq1)
mcwfrq2=ctod(rqn+rq2)
if mrq>mcwfrq2 and mrq<mcwfrq1
mcwf=mcwf+xe9
else
mcwf=mcwf+xe10
endif
if xa12="脑瘫"
mcwf=mcwf+xzcf+xxlf+xtcf       && 脑瘫科每日诊查费（3元）+训练费（10元）+与儿童同床费（5元）
else
mcwf=mcwf+xzcf              && 非脑瘫科每日诊查费（3元）
endif
endfor
sele 1
repl f1 with mcwf
repl ff1 with ff0-ff-mcwf
endscan
************************************
*       测算不同的记录
************************************
use h:\data\mz_lscf
public xg1(reccount())
go bott
n=0
xg00=0
do while !bof()
if xg00<>g00
n=n+1
xg1(n)=g1
endif
xg00=g00
skip -1
enddo

for i=1 to n
? xg1(i)
endfor
************************************
*       制作菜单
************************************
@ 1,1 menu mypxz,nnn1,20
read menu to nnn3
if nnn3=0
loop
endif
************************************
*       制作按钮
************************************
@ 18,28 get yy2;
pict "@*HN \!\<Y.确认;\<N.退出";
size 1.6,12,12;
default "1";
font "MINGLI",11;
style"b";
VALID sy2()
read cycle

function sy2
if yy2="Y"
******************
*   打印库结构
******************

set talk off
set safe off
set exact off
set defa to \hhh
clear all
sele 1
use ttdbf
zap
xtt=adir(xdbf,"*.dbf")
n=0
do while n<xtt 
n=n+1
appe blan
repl a1 with n
repl a2 with xdbf(n,1)
if xdbf(n,1)="TTDBF.DBF"
sele 1
loop
endif
sele 2
use &xdbf(n,1)
xfile=str(n,6)
LIST STRU TO &xfile
sele 1
enddo
****************************************************
*         把所有的统计库的go,g00字段变成字符型
****************************************************

set safe off
set cent on
set date to ansi

set defa to h:\data\
tfile=adir(test,"zy98*.dbf")
set defa to c:\vfp

create  dbf  temp;
(name c(15),long n(10),date d,time c(8),char c(2))
for i=1 to tfile 
appe blan
repl name with test(i,1)
repl long with test(i,2)
repl date with test(i,3)
repl time with test(i,4)
repl char with test(i,5)
endfor
close data
sele 1
use temp
go top
pf="h:\data\"

do while ! eof()
xname=pf+name
sele 2
use c:\vfp\test
appe from  &xname
copy to &xname
sele 1
skip
enddo

**********************************************
*    从药品库中取出药品名称，规格，单位
**********************************************

sele 1
use  qq_yp
clea

sele 1
do while ! eof()
xc1=alltrim(substr(c1,1,at(" ",c1)-1))

xc21=alltrim(substr(c1,at(" ",c1),len(c1)))
xc2=alltrim(substr(xc21,1,at(" ",xc21)-1))
xc3=alltrim(substr(xc21,at(" ",xc21),len(xc21)))

? xc1              && 药品名称
?xc2               && 药品规格
?xc3               && 药品单位
wait ""
skip
enddo
****************************************
*     替换所有统计库的收费明细类名
****************************************

set defa to h:\data\
tfile=adir(test,"zy98*.dbf")
set defa to c:\vfp

create  dbf  temp;
(name c(15),long n(10),date d,time c(8),char c(2))
for i=1 to tfile 
appe blan
repl name with test(i,1)
repl long with test(i,2)
repl date with test(i,3)
repl time with test(i,4)
repl char with test(i,5)
endfor
close data
sele 3
use temp
go top
set defa to h:\data\
do while ! eof()
xname=name

sele 2
use h:\data\qq-yl
sele 1
use &xname

go top
do while ! eof()
if g14="西药费"
xg13 ="西药费"
else
xc1=g7
sele 2
loca for xc1=c1
if found()
xg13=c11
else
xg13="其它"
endif
endif

sele 1
repl g13 with xg13
skip
enddo
sele 3
skip
enddo

 ************************************
*        收集某患者的所有处方
************************************
* 已知：xa0,xa1
xa0=8890
xa1="谢禹廷   "
sele 1
use h:\data\zy-ba 
loca for xa0=a0 and xa1=alltrim(a1)

if found()
xa16=a16
if empty(a17)
xa17=date()
else
xa17=a17
endif
else
wait wind "未发现欲查询的患者病案，按任意键返回！"
close data
clear
retu
endif

sele 2
use h:\data\bq-cf1
copy stru to temp
set excl on
use temp

rq=xa16
do while rq<=xa17
sele 3
set excl off
hhh2="h:\data\zy"+substr(dtoc(rq),3,2)+substr(dtoc(rq),6,2)+substr(dtoc(rq),9,2)+".dbf"
if file(hhh2)
use &hhh2
set excl on
copy to lscf for xa0=g0 and xa1=g1
sele 2
appe from lscf
endif
rq=rq+1
enddo

for i=1 to 4
sele 3
set excl off
hhh1="h:\data\bq-cf"+str(i,1)
use &hhh1
set excl on
copy to lscf for xa0=g0 and xa1=g1
sele 2
appe from lscf
endfor
brow
set excl off
retu
************************************
*       测算不同的记录
************************************
use h:\data\mz_lscf
public xg1(reccount())
go bott
n=0
xg00=0
do while !bof()
if xg00<>g00
n=n+1
xg1(n)=g1
endif
xg00=g00
skip -1
enddo

for i=1 to n
? xg1(i)
endfor
************************************
*       制作菜单
************************************
@ 1,1 menu mypxz,nnn1,20
read menu to nnn3
if nnn3=0
loop
endif
******************
*   打印库结构
******************

set talk off
set safe off
set exact off
set defa to \hhh
clear all
sele 1
use ttdbf
zap
xtt=adir(xdbf,"*.dbf")
n=0
do while n<xtt 
n=n+1
appe blan
repl a1 with n
repl a2 with xdbf(n,1)
if xdbf(n,1)="TTDBF.DBF"
sele 1
loop
endif
sele 2
use &xdbf(n,1)
xfile=str(n,6)
LIST STRU TO &xfile
sele 1
enddo

************************************
*  统计程序(按统计收费名统计)
************************************

use temp

store 0 to xf1,xf2,xf3,xf4,xf5,xf6,xf7,xf8,xf9,xf10,xf11,xf12,xf13,xf14
go top
do while .not. eof()
  do case
     case g14="西药"
           xf2=xf2+g12
     case g14="中药"
           xf3=xf3+g12
     case g14="检查"
           xf4=xf4+g12
     case g14="治疗"
           xf5=xf5+g12
     case g14="放射"
           xf6=xf6+g12
     case g14="手术"
           xf7=xf7+g12
     case g14="化验"
           xf8=xf8+g12
     case g14="输血"
           xf9=xf9+g12
     case g14="输氧"
           xf10=xf10+g12
     case g14="接生"
           xf11=xf11+g12
     otherwise
           xf12=xf12+g12   &&其它
     endcase
          xf13=xf13+g12    &&合计
    skip
enddo
 ************************************
*  统计程序(按明细收费类名统计)
************************************

use test

store 0 to xf1,xf2,xf3,xf4,xf5,xf6,xf7,xf8,xf9,xf10,xf11,xf12,xf13,xf14,;
xf15,xf16,xf17,xf18,xf19,xf20,xf21,xf22,xf23,xf24,xf25,xf26

go top
do while .not. eof()
  do case
     case g13="西药费"
           xf2=xf2+g12
     case g13="中成药"
           xf3=xf3+g12
     case g13="中草药"
           xf4=xf4+g12
     case g13="处置费"
           xf5=xf5+g12
     case g13="护理费"
           xf6=xf6+g12
     case g13="陪护费"
           xf7=xf7+g12
     case g13="诊查费"
           xf8=xf8+g12
     case g13="治疗费"
           xf9=xf9+g12
     case g13="化验费"
           xf10=xf10+g12
     case g13="CT费"
           xf11=xf11+g12
     case g13="透视费"
           xf12=xf12+g12
     case g13="照相费"
           xf13=xf13+g12
     case g13="B超费"
           xf14=xf14+g12
     case g13="诱电费"
           xf15=xf15+g12
     case g13="脑电费"
           xf16=xf16+g12
     case g13="脑地形"
           xf17=xf17+g12
     case g13="心电费"
           xf18=xf18+g12
     case g13="病理费"
           xf19=xf19+g12
     case g13="手术费"
           xf20=xf20+g12
     case g13="血费"
           xf21=xf21+g12
     case g13="氧费"
           xf22=xf22+g12
     case g13="接产费"
           xf23=xf23+g12
     case g13="取暖费"
           xf24=xf24+g12
     otherwise
           xf25=xf25+g12   &&其它
     endcase
           xf26=xf26+g12    &&合计
    skip
enddo


****************************
*  test.prg (出一百题)
****************************

set cent on
set date to ansi
set excl on
clear

define window work1;
at .1,1 size 23,89;
font "mingli",12;
style"b";
in desktop;
colo rgb(0,0,0,192,192,192)

move wind work1 cent
if .not. wvisible("work1")
acti wind work1 same
else
activate wind work1 noshow
endif
@ 3,12 say "请选择:"
set colo to rgb(,,,164,200,240)  
@ 0,10 clear to 2,79        
@ 0.3,10 say space(18)+"打       印      习      题" font "arial",18
SET COLO OF SCHEME 2;
 TO ,w/b+,,,,w/g+,,,
@ 18,28 get yy2;
pict "@*HN \!\<Y.确认;\<N.退出";
size 1.6,12,12;
default "1";
font "arial",12;
style"b";
VALID sy2()
read cycle

function sy2
if yy2="Y"
set colo to
set device to print
for i=2 to 101
xa=0
do while xa<10
xa=rand()
xa=round(100*xa,0)
enddo
xb=0
do while xb<10
xb=rand()
xb=round(100*xb,0)
enddo
xc=rand()
xd=rand()
if xc>xd
xfh="+"
else
xfh="-"
endif
j=i
m=2
n=25
if xfh="-" and xa-xb<0
if xb-xa>99
i=i-1
loop
endif
@ 3*(round(j/4,0)),((j-round(j/4,0)*4)+m)*n say alltrim(str(xb))+xfh+alltrim(str(xa))+"="  font "arial",14
else
if xfh="+"
if xb+xa>99
i=i-1
loop
endif
@ 3*(round(j/4,0)),((j-round(j/4,0)*4)+m)*n say alltrim(str(xa))+xfh+alltrim(str(xb))+"="  font "arial",14
else
if xa-xb>99
i=i-1
loop
endif
@ 3*(round(j/4,0)),((j-round(j/4,0)*4)+m)*n say alltrim(str(xa))+xfh+alltrim(str(xb))+"="  font "arial",14
endif
endif
endfor
set print to lpt1
set device to screen
endif
clear
clear read all
deac wind all
retu
**********************************************
* 调整门诊处方中的科室名称
**********************************************
SET SAFE OFF
SET DELE OFF
SET TALK OFF
SET EXACT OFF

SELE 1
use h:\data\mz_cf

SCAN
xG2=ALLTRIM(G2)
SELE 2
USE H:\DATA\QQ_KS
LOCA FOR K1=XG2 AND LLL="3"
XK1=K1
SELE 1
REPL G2 WITH XK1
ENDSCAN

RQ=DATE()-1000
DO WHILE RQ<DATE()
hhh2="h:\data\MZ"+substr(dtoc(rq),3,2)+substr(dtoc(rq),6,2)+substr(dtoc(rq),9,2)+".dbf"
if file(hhh2)
SELE 1
use &HHH2
SCAN
xG2=ALLTRIM(G2)
SELE 2
USE H:\DATA\QQ_KS
LOCA FOR K1=XG2 AND LLL="3"
XK1=K1
SELE 1
REPL G2 WITH XK1
ENDSCAN
endif
rq=rq+1
ENDDO

USE H:\DATA\QQ_KS

COUNT TO N FOR SF="T"
LOCAL XKSM(N)

I=0
SCAN
I=I+1
XKSM(I)=K1
ENDS