#Include 'Inkey.Ch' #Include 'BOX.ch' #Define SOH Chr( 1) #Define STX Chr( 2) #Define ETX Chr( 3) #Define ACK Chr( 6) #Define NAK Chr( 21) #Define CAN Chr( 24) #Define NOK Chr(127) MemVar COR_GET,COR_CB1,COR_CB2,COR_BX1,COR_BX2,MULTI ,USUAR ,OUT MemVar KXSTP ,KXSID ,KXSNM ,KXIDA ,KXOID ,KXCOV ,KXMED ,KXCOL ,KXENT ,KXSDT MemVar KXSTM ,KXMTP ,KXNUM ,KXFG1 ,KXWBC ,KXPBL ,KXBLA ,KXPPM ,KXPRM ,KXPMI MemVar KXMIE ,KXPMM ,KXMTM ,KXPBT ,KXBST ,KXPNE ,KXNEU ,KXPL1 ,KXlY1 ,KXPL2 MemVar KXlY2 ,KXPMO ,KXMON ,KXPEO ,KXEOS ,KXPBA ,KXBAS ,KXFG2 ,KXRBC ,KXHGB MemVar KXHCT ,KXMCV ,KXMCH ,KXCHC ,KXRDW ,KXFG3 ,KXPLT ,KXMPV ,KXPCT ,KXPDW MemVar KXLIM ,KXFG4 ,KXFG5 ,KXFG6 ,KXFG7 ,KX_NUM,KX_SD1 ,KX_SID,KX_SDT ,KX_STM MemVar KX_SNM ,KX_IDA ,KX_COV ,KX_MED ,KX_COL ,KX_ENT,KX_FG1 ,KX_WBC,KX_PBLA,KX_BLA MemVar KX_PPRM,KX_PRM ,KX_PMIE,KX_MIE ,KX_PMTM,KX_MTM,KX_PBST,KX_BST,KX_PNEU,KX_NEU MemVar KX_PLY1,KX_LY1 ,KX_PLY2,KX_LY2 ,KX_PMON,KX_MON,KX_PEOS,KX_EOS,KX_PBAS,KX_BAS MemVar KX_FG2 ,KX_RBC ,KX_HGB ,KX_HCT ,KX_MCV ,KX_MCH,KX_CHC ,KX_RDW,KX_FG3 ,KX_PLT MemVar KX_MPV ,KX_PCT ,KX_PDW ,KX_LIM ,KX_FG4 ,KX_FG5,KX_FG6 ,KX_FG7,KX_MC1 ,KX_MC2 MemVar KX_MC3 ,KX_MC4 ,KX_MC5 ,KX_MC6 ,KX_MC7 ,KX_MC8,KX_MD1 ,KX_MD2,KX_MD3 ,KX_MD4 MemVar KX_MD5 ,KX_MD6 ,KX_MD7 ,KX_MD8 ,KX_OC1 ,KX_OD1,KX_OC2 ,KX_OD2,RG1 MemVar GETVR2 * * ************************************************************************************************* * * Recebe() --> Função de comunicação com o ROCHE KX-21N * *------------------------------------------------------------------------------------------------ Function Recebe() Local MKY,DB0,SCR,SID,NOM Local CT1,CT2,CT3,CT4 Local GETLIST := {},; GETVR1 := {},; GETVR3 := {},; GETVR4 := {},; GETVR5 := {},; GETVR6 := {},; GETVR7 := {},; LEU := {},; ERI := {},; PLT := {} PUBLIC nHandle := 0, c_com := "" SetCursor(0) DBCloseAll() DBUseArea(.T.,'DBFCDX','CAB_0','CAB',.T.) If !NetErr() DBUseArea(.T.,'DBFCDX','ARQ_2','ARQ',MULTI) If !NetErr() If File('ARQ_2.CDX') Set Index To ARQ_2 Else Alert('Necess rio indexar o Arquivo - ARQ_2.DBF') DBCloseAll() Return (NIL) EndIf DBUseArea(.T.,,'REF_1','REF',MULTI) If !NetErr() If File('REF_1.CDX') Set Index To REF_1 Else Alert('Necess rio indexar o Arquivo - REF_1.DBF') DBCloseAll() Return (NIL) EndIf DBUseArea(.T.,,'PRM_0','PRM',MULTI) If !NetErr() DBUseArea(.T.,,'HIS_2','HIS',MULTI) If !NetErr() If File('HIS_2.CDX') Set Index To HIS_2 Else Alert('Necess rio indexar o Arquivo - HIS_2.DBF') DBCloseAll() Return (NIL) EndIf DBUseArea(.T.,,'HST_1','HST',MULTI) If !NetErr() If File('HST_1.CDX') Set Index To HST_1 Else Alert('Necess rio indexar o Arquivo - HST_1.DBF') DBCloseAll() Return (NIL) EndIf DBUseArea(.T.,,'KX21','KX21',MULTI) If !NetErr() If File('KX21.CDX') OrdSetFocus( 1 ) Else Alert('Necess rio indexar o Arquivo - KX21.DBF') DBCloseAll() Return (NIL) EndIf Else Alert('Erro na Abertura do Arquivo - KX21.DBF') DBCloseAll() Return (NIL) EndIf DBUseArea(.T.,,'CNT_1','CNT',MULTI) If !NetErr() If File('CNT_1.CDX') Set Index To CNT_1 Else Alert('Necess rio indexar o Arquivo - CNT_1.DBF') DBCloseAll() Return (NIL) EndIf Else Alert('Erro na Abertura do Arquivo - CNT_1.DBF') DBCloseAll() Return (NIL) EndIf Else Alert('Erro na Abertura do Arquivo - HST_1.DBF') DBCloseAll() Return (NIL) EndIf Else Alert('Erro na Abertura do Arquivo - HIS_2.DBF') DBCloseAll() Return (NIL) EndIf Else Alert('Erro na Abertura do Arquivo - PRM_0.DBF') DBCloseAll() Return (NIL) EndIf Else Alert('Necess rio indexar o Arquivo - REF_1.DBF') DBCloseAll() Return (NIL) EndIf Else Alert('Necess rio indexar o Arquivo - ARQ_2.DBF') DBCloseAll() Return (NIL) EndIf Else Alert('Necess rio indexar o Arquivo - CAB_0.DBF') DBCloseAll() Return (NIL) EndIf DBSelectAr( "KX21") KX21->(DBSetOrder( 1 )) SetKey(K_F6, {|| B_Save(K_CTRL_END)}) SetKey(K_F2, {|| FPesq()}) SetKey(K_ALT_M, {|| FVMorf()}) SetKey(K_ALT_H, {|| CNTHEM()}) nHandle := IniciaPorta() SetColor(cor_6) @ 00,00,03,79 Box B_DOUBLE @ 03,00,19,79 Box 'Ì͹³ÀÄÙ³' @ 19,00,23,79 Box 'ÃÄ´³ÙÄÀ³ ' @ 00,21 Say ' R E C E B I M E N T O D E D A D O S ' @ 20,01 Say ' Menu Principal Excluir Cancelar ImpressÆo/Edi‡Æo ' @ 21,01 Say ' Editar Exames Grava‡Æo Autom tica ' @ 22,01 Say ' <1...9> Pesquisar Nova Ficha ' SetColor(COR_BX1) @ 21,61,23,79 Box 'ÉÍ»³ÙÄÀ³ ' c_cornow := SETCOLOR(cor_7) @ 19,01 SAY "Usu rio: " + __usuar + " " SETCOLOR(c_cornow) DB0 := TBrowseDB(02,01,18,78) DB0:ColSep := '³' DB0:HeadSep := 'ËÍ' DB0:AddColumn(TBColumnNew('S' , {|| KX21->KXSIT})) DB0:AddColumn(TBColumnNew('I' , {|| KX21->KXIMP})) DB0:AddColumn(TBColumnNew('T' , {|| IIf(!Empty(KX21->KXDTT),'û',' ')})) DB0:AddColumn(TBColumnNew('Seq' , {|| KX21->KXNUM})) DB0:AddColumn(TBColumnNew('C¢digo' , {|| KX21->KXSID})) DB0:AddColumn(TBColumnNew('Paciente', {|| SubStr(KX21->KXSNM,1,10)})) DB0:AddColumn(TBColumnNew('Data' , {|| SubStr(KX21->KXSDT,1,5)})) AAdd(LEU, TBColumnNew('Leuc¢cito' , {|| Transform(KX21->KXWBC,'@E 9,999,999' )})) AAdd(LEU, TBColumnNew('Bastäes' , {|| Transform(KX21->KXPBST,'@E 99.9')+' '+Transform(KX21->KXBST,'@E 99,999')})) AAdd(LEU, TBColumnNew('Segmentados', {|| Transform(KX21->KXPNEU,'@E 99.9')+' '+Transform(KX21->KXNEU,'@E 99,999')})) AAdd(LEU, TBColumnNew('Linf¢citos' , {|| Transform(KX21->KXPLY1,'@E 99.9')+' '+Transform(KX21->KXLY1,'@E 99,999')})) AAdd(LEU, TBColumnNew('Mon¢citos' , {|| Transform(KX21->KXPMON,'@E 99.9')+' '+Transform(KX21->KXMON,'@E 99,999')})) AAdd(LEU, TBColumnNew('Eosin¢filos', {|| Transform(KX21->KXPEOS,'@E 99.9')+' '+Transform(KX21->KXEOS,'@E 99,999')})) AAdd(LEU, TBColumnNew('Bas¢filos' , {|| Transform(KX21->KXPBAS,'@E 99.9')+' '+Transform(KX21->KXBAS,'@E 99,999')})) AAdd(ERI, TBColumnNew('Hemac', {|| Transform(KX21->KXRBC,'@E 99.99')})) AAdd(ERI, TBColumnNew('Hemg' , {|| Transform(KX21->KXHGB,'@E 99.9' )})) AAdd(ERI, TBColumnNew('Hemt' , {|| Transform(KX21->KXHCT,'@E 99.9' )})) AAdd(ERI, TBColumnNew('VCM' , {|| Transform(KX21->KXMCV,'@E 999.9' )})) AAdd(ERI, TBColumnNew('HCM' , {|| Transform(KX21->KXMCH,'@E 99.9' )})) AAdd(ERI, TBColumnNew('CHCM' , {|| Transform(KX21->KXCHC,'@E 99.9' )})) AAdd(ERI, TBColumnNew('RDW' , {|| Transform(KX21->KXRDW,'@E 99.9' )})) AAdd(PLT, TBColumnNew('Plaquetas', {|| Transform(KX21->KXPLT,'@E 9,999,999')})) AAdd(PLT, TBColumnNew(' VPM' , {|| Transform(KX21->KXMPV,'@E 99.9' )})) AAdd(PLT, TBColumnNew(' PCT' , {|| Transform(KX21->KXPCT,'@E 99.99' )})) AAdd(PLT, TBColumnNew(' PDW' , {|| Transform(KX21->KXPDW,'@E 99.9' )})) AEVal(LEU, {|CT2| DB0:AddColumn(CT2)}) DB0:Freeze := 8 DB0:ColPos := 10 * 1 || 2 3 || 4 5 || 6 7 8 9 10 cor := " N /BG , W /RB , N/BG , W+/B, W+/R , W/N, R/W, N/W, R/W, N/W" DB0:colorspec := cor DB0:GoBottom() While .T. While(!DB0:Stabilize()); End * If DB0:ColPos < DB0:Freeze + 1 While DB0:ColPos < DB0:Freeze + 1 While(!DB0:Stabilize()); End SetCursor(1) DB0:Right() DB0:RefreshAll() EndDo Else DB0:colorRect( {DB0:RowPos, 1, DB0:RowPos, DB0:ColCount},{2,4} ) DB0:hilite() * MKY := InKey(2) * IF IsWorking( nHandle ) .AND. nHandle > 0 @ 22,62 SAY " "+c_com+" ativa " ELSE SetColor(cor_7) @ 22,62 SAY " "+c_com+" INATIVA " SetColor(cor_6) ENDIF * IF LASTKEY() = 287 && Alt-S - Usuário com aSenha := {20,40,cor_7,19,01,cor_7} && senha. Em Senha.prg __Senha := SENHA() RELEASE aSenha ElseIf MKY == 32 .Or. (MKY >= 48 .And. MKY <= 57) && Espaço, zero, nove, (pesquisa). SCR := SaveScreen(00,00,24,79) * SID := Space(12) NOM := Space(16) * SetCursor(1) SetColor(COR_BX1) @ 10,11,15,43 Box 'Õ͸³ÙÄÀ³ ' * SetColor(COR_BX2) @ 10,19 Say ' P E S Q U I S A ' * @ 12,13 Say 'C¢digo ....:' @ 13,13 Say 'Nome.......:' * If MKY != 32 KeyBoard Chr(MKY) EndIf * @ 12,26 Get SID When Empty( NOM ) @ 13,26 Get NOM When ( Empty( SID ) .OR. VAL( SID )==0 ) Read * IF Empty(NOM) SID := STRZERO( VAL( SID ), 12 ) ELSE SID := "" ENDIF DB0:GoTop() DB0:forceStable() If LastKey() != K_ESC KX21->(DBSetOrder(IIf(!Empty(SID), 4, 5))) If KX21->(!DBSeek(IIf(!Empty(SID), SID, NOM))) KX21->(DBSetOrder(1)) DB0:GoBottom() Else KX21->(DBSetOrder(1)) DB0:RowPos := 1 DB0:Configure() EndIf EndIf * SetCursor(0) RestScreen(00,00,24,79,SCR) ElseIf MKY == K_DOWN DB0:Down() ElseIf MKY == K_UP DB0:Up() ElseIf MKY == K_CTRL_PGUP DB0:GoTop() DB0:forceStable() ElseIf MKY == K_CTRL_PGDN DB0:GoBottom() ElseIf MKY == K_LEFT DB0:Left() ElseIf MKY == K_RIGHT If DB0:ColPos == DB0:ColCount If DB0:ColCount == 14 .And. DB0:Freeze == 8 * CT3 := 8 CT4 := 8 * AEVal(LEU, {|| DB0:DelColumn(CT3)}) AEVal(ERI, {|CT2| DB0:InsColumn(CT4++,CT2)}) * DB0:Freeze := 7 ElseIf DB0:ColCount == 14 .And. DB0:Freeze == 7 * CT3 := 8 CT4 := 8 * AEVal(ERI, {|| DB0:DelColumn(CT3)}) AEVal(PLT, {|CT2| DB0:InsColumn(CT4++,CT2)}) * DB0:Freeze := 7 ElseIf DB0:ColCount == 11 * CT3 := 8 CT4 := 8 * AEVal(PLT, {|| DB0:DelColumn(CT3)}) AEVal(LEU, {|CT2| DB0:InsColumn(CT4++,CT2)}) * DB0:Freeze := 8 DB0:ColPos := 10 EndIf Else DB0:Right() EndIf ElseIf MKY == K_PGDN DB0:PageDown() ElseIf MKY == K_PGUP DB0:PageUp() ElseIf MKY == K_ALT_O n_contagem := KX21->KXPBLA+KX21->KXPPRM+KX21->KXPMIE+KX21->KXPMTM+KX21->KXPBST+KX21->KXPNEU+KX21->KXPLY1+KX21->KXPLY2+KX21->KXPMON+KX21->KXPEOS+KX21->KXPBAS If Str((n_contagem),6,2) != '100.00' If Alert('A contagem do Leucograma nÆo completou 100%',{'Continuar','Cancelar'}) == 2 Loop EndIf EndIf * n_alert := ALERT('Confirme a Libera‡Æo de Transferˆncia ???',{'Liberar','Cancelar'}) IF n_alert == 1 IF __nivel == "BIO" KX21->(B_LockRec(0)) KX21->(FieldPut( 1,'û' )) && Libera KX21->(FieldPut( 2,__usuar)) && usuário. KX21->(DBCommit()) KX21->(DBUnLock()) * If ARQ->(DBSeek(KX21->KXSID)) ARQ->(B_LockRec(0)) Else ARQ->(B_AddRec(0)) ARQ->(FieldPut( 7,'1')) EndIf * ARQ->(FieldPut( 1,'X')) ARQ->(FieldPut( 2,'----')) ARQ->(FieldPut( 3,KX21->KXSID)) ARQ->(FieldPut( 4,KX21->KXSNM)) ARQ->(FieldPut( 6,KX21->KXLIM)) ARQ->(DBCommit()) ARQ->(DBUnLock()) Commit ELSE ALERT("Seu n¡vel nÆo permite liberar exames !!!") ENDIF ENDIF ElseIf MKY == K_ALT_N * NovaFich() * ARQ->( DBCommit() ) ARQ->(DBUnLock()) * ElseIf MKY == K_ALT_T If !Empty(KX21->KXIMP) If Alert('Confirme Cancelamento da ImpressÆo ???',{'Sim','NÆo'}) == 1 KX21->(B_LockRec(0)) KX21->(FieldPut( 3,' ')) KX21->(DBCommit()) KX21->(DBUnLock()) * Commit EndIf ElseIf !Empty(KX21->KXSIT) If Alert('Confirme Cancelamento da Libera‡Æo de Transferˆncia ???',{'Sim','NÆo'}) == 1 KX21->(B_LockRec(0)) KX21->(FieldPut( 1,' ')) KX21->(FieldPut( 4,' ')) KX21->(DBCommit()) KX21->(DBUnLock()) * Commit EndIf EndIf ElseIf MKY == K_ALT_E If Alert('Confirme ExclusÆo de Registro ???',{'Sim','NÆo'}) == 1 If HST->(DBSeek(DToS(CToD(KX21->KXSDT))+KX21->KXNUM)) While HST->HSTNUM == KX21->KXNUM HST->(B_LockRec(0)) HST->(DBDelete()) HST->(DBCommit()) HST->(DBUnLock()) HST->(DBSkip(1)) EndDo EndIf * KX21->(B_LockRec(0)) KX21->(DBDelete()) KX21->(DBCommit()) KX21->(DBUnLock()) * EndIf ElseIf MKY == K_ALT_I If !Empty(KX21->KXSIT) If Empty(KX21->KXIMP) If Alert('Confirme ImpressÆo ???',{'Sim','NÆo'}) == 1 * ALERT( "Rotina desativada." ) * OUT := IIf( PRM->PRMOUT != 0 , PRM->PRMOUT , F_Impress() ) * If OUT == 1 * ImpHP560() ElseIF OUT == 2 * ImpHP870() ElseIF OUT == 3 * ImpEPSON() EndIf * * KX21->(B_LockRec(0)) * KX21->(FieldPut( 3,'I')) * KX21->(DBCommit()) * KX21->(DBUnLock()) EndIf Else If Alert('Confirme ReimpressÆo ???',{'Sim','NÆo'}) == 1 * ALERT( "Rotina desativada." ) * OUT := IIf( PRM->PRMOUT != 0 , PRM->PRMOUT , F_Impress() ) * If OUT == 1 * ImpHP560() ElseIF OUT == 2 * ImpHP870() ElseIF OUT == 3 * ImpEPSON() EndIf * EndIf EndIf EndIf ElseIf MKY == K_ENTER *############################################################################## IF IsWorking( nHandle ) .AND. nHandle > 0 @ 22,62 SAY " "+c_com+" ativa a" ELSE SetColor(cor_7) @ 22,62 SAY " "+c_com+" INATIVA a" SetColor(cor_6) ENDIF * inkey(0) *############################################################################## If !Empty(KX21->KXNUM+KX21->KXSID) * SCR := SaveScreen(00,00,24,79) RG1 := KX21->(RecNo()) * KX_NUM := KX21->KXNUM KX_SD1 := KX21->KXSID KX_SID := KX21->KXSID KX_SDT := KX21->KXSDT KX_STM := KX21->KXSTM * KX_SNM := KX21->KXSNM && + Space(14) KX_IDA := Space( 8) KX_LIM := KX21->KXLIM KX_COV := Space(30) KX_MED := Space(30) KX_COL := Space(20) KX_ENT := Space(20) * If ARQ->(DBSeek(KX21->KXSID)) KX_SNM := ARQ->ARQNOM KX_IDA := ARQ->ARQIDA KX_LIM := ARQ->ARQLIM KX_COV := ARQ->ARQCOV KX_MED := ARQ->ARQMED KX_COL := ARQ->ARQCOL KX_ENT := ARQ->ARQENT EndIf * KX_FG1 := KX21->KXFG1 KX_WBC := KX21->KXWBC * KX_PBLA := KX21->KXPBLA KX_PPRM := KX21->KXPPRM KX_PMIE := KX21->KXPMIE KX_PMTM := KX21->KXPMTM KX_PBST := KX21->KXPBST KX_PNEU := KX21->KXPNEU KX_PLY1 := KX21->KXPLY1 KX_PLY2 := KX21->KXPLY2 KX_PMON := KX21->KXPMON KX_PEOS := KX21->KXPEOS KX_PBAS := KX21->KXPBAS * KX_BLA := KX21->KXBLA KX_PRM := KX21->KXPRM KX_MIE := KX21->KXMIE KX_MTM := KX21->KXMTM KX_BST := KX21->KXBST KX_NEU := KX21->KXNEU KX_LY1 := KX21->KXLY1 KX_LY2 := KX21->KXLY2 KX_MON := KX21->KXMON KX_EOS := KX21->KXEOS KX_BAS := KX21->KXBAS * KX_FG2 := KX21->KXFG2 KX_RBC := KX21->KXRBC KX_HGB := KX21->KXHGB KX_HCT := KX21->KXHCT KX_MCV := KX21->KXMCV KX_MCH := KX21->KXMCH KX_CHC := KX21->KXCHC KX_RDW := KX21->KXRDW * KX_FG3 := KX21->KXFG3 KX_PLT := KX21->KXPLT KX_MPV := KX21->KXMPV KX_PCT := KX21->KXPCT KX_PDW := KX21->KXPDW * KX_FG4 := KX21->KXFG4 KX_FG5 := KX21->KXFG5 KX_FG6 := KX21->KXFG6 KX_FG7 := KX21->KXFG7 * KX_MC1 := KX21->KXMC1 KX_MC2 := KX21->KXMC2 KX_MC3 := KX21->KXMC3 KX_MC4 := KX21->KXMC4 KX_MC5 := KX21->KXMC5 KX_MC6 := KX21->KXMC6 KX_MC7 := KX21->KXMC7 KX_MC8 := KX21->KXMC8 KX_MD1 := KX21->KXMD1 KX_MD2 := KX21->KXMD2 KX_MD3 := KX21->KXMD3 KX_MD4 := KX21->KXMD4 KX_MD5 := KX21->KXMD5 KX_MD6 := KX21->KXMD6 KX_MD7 := KX21->KXMD7 KX_MD8 := KX21->KXMD8 * KX_OC1 := KX21->KXOC1 KX_OC2 := KX21->KXOC2 KX_OD1 := KX21->KXOD1 KX_OD2 := KX21->KXOD2 * GETVR1 := {} GETVR2 := {} GETVR3 := {} GETVR4 := {} GETVR5 := {} GETVR6 := {} GETVR7 := {} * AAdd(GETVR1, GetNew(01, 11, MemVarBlock('KX_NUM'),'KX_NUM')) AAdd(GETVR1, GetNew(01, 33, MemVarBlock('KX_SID'),'KX_SID','@K 99999999')) AAdd(GETVR1, GetNew(01, 52, MemVarBlock('KX_SDT'),'KX_SDT')) AAdd(GETVR1, GetNew(01, 63, MemVarBlock('KX_STM'),'KX_STM')) AAdd(GETVR1, GetNew(02, 11, MemVarBlock('KX_SNM'),'KX_SNM')) AAdd(GETVR1, GetNew(02, 52, MemVarBlock('KX_IDA'),'KX_IDA')) AAdd(GETVR1, GetNew(02, 71, MemVarBlock('KX_LIM'),'KX_LIM')) AAdd(GETVR1, GetNew(03, 11, MemVarBlock('KX_COV'),'KX_COV')) AAdd(GETVR1, GetNew(04, 11, MemVarBlock('KX_MED'),'KX_MED')) AAdd(GETVR1, GetNew(03, 52, MemVarBlock('KX_COL'),'KX_COL')) AAdd(GETVR1, GetNew(04, 52, MemVarBlock('KX_ENT'),'KX_ENT')) * AAdd(GETVR2, GetNew(06, 03, MemVarBlock('KX_FG1') ,'KX_FG1' ,'@!')) AAdd(GETVR2, GetNew(08, 19, MemVarBlock('KX_WBC') ,'KX_WBC' ,'@E 999,999')) AAdd(GETVR2, GetNew(09, 15, MemVarBlock('KX_PBLA'),'KX_PBLA','@E 99.9')) AAdd(GETVR2, GetNew(09, 20, MemVarBlock('KX_BLA') ,'KX_BLA' ,'@E 99,999')) AAdd(GETVR2, GetNew(10, 15, MemVarBlock('KX_PPRM'),'KX_PPRM','@E 99.9')) AAdd(GETVR2, GetNew(10, 20, MemVarBlock('KX_PRM') ,'KX_PRM' ,'@E 99,999')) AAdd(GETVR2, GetNew(11, 15, MemVarBlock('KX_PMIE'),'KX_PMIE','@E 99.9')) AAdd(GETVR2, GetNew(11, 20, MemVarBlock('KX_MIE') ,'KX_MIE' ,'@E 99,999')) AAdd(GETVR2, GetNew(12, 15, MemVarBlock('KX_PMTM'),'KX_PMTM','@E 99.9')) AAdd(GETVR2, GetNew(12, 20, MemVarBlock('KX_MTM') ,'KX_MTM' ,'@E 99,999')) AAdd(GETVR2, GetNew(13, 15, MemVarBlock('KX_PBST'),'KX_PBST','@E 99.9')) AAdd(GETVR2, GetNew(13, 20, MemVarBlock('KX_BST') ,'KX_BST' ,'@E 99,999')) AAdd(GETVR2, GetNew(14, 15, MemVarBlock('KX_PNEU'),'KX_PNEU','@E 99.9')) AAdd(GETVR2, GetNew(14, 20, MemVarBlock('KX_NEU') ,'KX_NEU' ,'@E 99,999')) AAdd(GETVR2, GetNew(15, 15, MemVarBlock('KX_PLY1'),'KX_PLY1','@E 99.9')) AAdd(GETVR2, GetNew(15, 20, MemVarBlock('KX_LY1') ,'KX_LY1' ,'@E 99,999')) AAdd(GETVR2, GetNew(16, 15, MemVarBlock('KX_PLY2'),'KX_PLY2','@E 99.9')) AAdd(GETVR2, GetNew(16, 20, MemVarBlock('KX_LY2') ,'KX_LY2' ,'@E 99,999')) AAdd(GETVR2, GetNew(17, 15, MemVarBlock('KX_PMON'),'KX_PMON','@E 99.9')) AAdd(GETVR2, GetNew(17, 20, MemVarBlock('KX_MON') ,'KX_MON' ,'@E 99,999')) AAdd(GETVR2, GetNew(18, 15, MemVarBlock('KX_PEOS'),'KX_PEOS','@E 99.9')) AAdd(GETVR2, GetNew(18, 20, MemVarBlock('KX_EOS') ,'KX_EOS' ,'@E 99,999')) AAdd(GETVR2, GetNew(19, 15, MemVarBlock('KX_PBAS'),'KX_PBAS','@E 99.9')) AAdd(GETVR2, GetNew(19, 20, MemVarBlock('KX_BAS') ,'KX_BAS' ,'@E 99,999')) * AAdd(GETVR3, GetNew(06, 30, MemVarBlock('KX_FG2'),'KX_FG2','@!')) AAdd(GETVR3, GetNew(08, 43, MemVarBlock('KX_RBC'),'KX_RBC','@E 9.99')) AAdd(GETVR3, GetNew(09, 42, MemVarBlock('KX_HGB'),'KX_HGB','@E 99.99')) AAdd(GETVR3, GetNew(10, 42, MemVarBlock('KX_HCT'),'KX_HCT','@E 99.99')) AAdd(GETVR3, GetNew(11, 41, MemVarBlock('KX_MCV'),'KX_MCV','@E 999.9')) AAdd(GETVR3, GetNew(12, 42, MemVarBlock('KX_MCH'),'KX_MCH','@E 99.9')) AAdd(GETVR3, GetNew(13, 42, MemVarBlock('KX_CHC'),'KX_CHC','@E 99.9')) AAdd(GETVR3, GetNew(14, 42, MemVarBlock('KX_RDW'),'KX_RDW','@E 99.9')) * AAdd(GETVR4, GetNew(06, 57, MemVarBlock('KX_FG3'),'KX_FG3','@!')) AAdd(GETVR4, GetNew(08, 66, MemVarBlock('KX_PLT'),'KX_PLT','@E 999,999')) AAdd(GETVR4, GetNew(09, 68, MemVarBlock('KX_MPV'),'KX_MPV','@E 99.99')) AAdd(GETVR4, GetNew(10, 69, MemVarBlock('KX_PCT'),'KX_PCT','@E 9.99')) AAdd(GETVR4, GetNew(11, 68, MemVarBlock('KX_PDW'),'KX_PDW','@E 99.99')) * AAdd(GETVR5, GetNew(17, 44, MemVarBlock('KX_FG4'),'KX_FG4','@!')) AAdd(GETVR5, GetNew(18, 44, MemVarBlock('KX_FG5'),'KX_FG5','@!')) AAdd(GETVR5, GetNew(19, 44, MemVarBlock('KX_FG6'),'KX_FG6','@!')) AAdd(GETVR5, GetNew(20, 44, MemVarBlock('KX_FG7'),'KX_FG7','@!')) * AAdd(GETVR6, GetNew(08, 05, MemVarBlock('KX_MC1'),'KX_MC1','@!')) AAdd(GETVR6, GetNew(08, 11, MemVarBlock('KX_MD1'),'KX_MD1','@S66')) AAdd(GETVR6, GetNew(09, 05, MemVarBlock('KX_MC2'),'KX_MC2','@!')) AAdd(GETVR6, GetNew(09, 11, MemVarBlock('KX_MD2'),'KX_MD2','@S66')) AAdd(GETVR6, GetNew(10, 05, MemVarBlock('KX_MC3'),'KX_MC3','@!')) AAdd(GETVR6, GetNew(10, 11, MemVarBlock('KX_MD3'),'KX_MD3','@S66')) AAdd(GETVR6, GetNew(11, 05, MemVarBlock('KX_MC4'),'KX_MC4','@!')) AAdd(GETVR6, GetNew(11, 11, MemVarBlock('KX_MD4'),'KX_MD4','@S66')) AAdd(GETVR6, GetNew(12, 05, MemVarBlock('KX_MC5'),'KX_MC5','@!')) AAdd(GETVR6, GetNew(12, 11, MemVarBlock('KX_MD5'),'KX_MD5','@S66')) AAdd(GETVR6, GetNew(13, 05, MemVarBlock('KX_MC6'),'KX_MC6','@!')) AAdd(GETVR6, GetNew(13, 11, MemVarBlock('KX_MD6'),'KX_MD6','@S66')) AAdd(GETVR6, GetNew(14, 05, MemVarBlock('KX_MC7'),'KX_MC7','@!')) AAdd(GETVR6, GetNew(14, 11, MemVarBlock('KX_MD7'),'KX_MD7','@S66')) AAdd(GETVR6, GetNew(15, 05, MemVarBlock('KX_MC8'),'KX_MC8','@!')) AAdd(GETVR6, GetNew(15, 11, MemVarBlock('KX_MD8'),'KX_MD8','@S66')) * AAdd(GETVR7, GetNew(19, 05, MemVarBlock('KX_OC1'),'KX_OC1','@!')) AAdd(GETVR7, GetNew(19, 11, MemVarBlock('KX_OD1'),'KX_OD1','@S66')) AAdd(GETVR7, GetNew(20, 05, MemVarBlock('KX_OC2'),'KX_OC2','@!')) AAdd(GETVR7, GetNew(20, 11, MemVarBlock('KX_OD2'),'KX_OD2','@S66')) * GETVR1[ 1]:PreBlock := {|| .F.} GETVR1[ 2]:PostBlock := {|| FExiste(KX_SID,GETVR1)} GETVR1[ 3]:PreBlock := {|| .F.} GETVR1[ 4]:PreBlock := {|| .F.} * GETVR2[ 1]:PostBlock := {|| FDigT() .And. KX_FG1$'X '} GETVR2[ 3]:PostBlock := {|| FCalc( 1,GETVR2)} GETVR2[ 4]:PreBlock := {|| .F.} GETVR2[ 5]:PostBlock := {|| FCalc( 2,GETVR2)} GETVR2[ 6]:PreBlock := {|| .F.} GETVR2[ 7]:PostBlock := {|| FCalc( 3,GETVR2)} GETVR2[ 8]:PreBlock := {|| .F.} GETVR2[ 9]:PostBlock := {|| FCalc( 4,GETVR2)} GETVR2[10]:PreBlock := {|| .F.} GETVR2[11]:PostBlock := {|| FCalc( 5,GETVR2)} GETVR2[12]:PreBlock := {|| .F.} GETVR2[13]:PostBlock := {|| FCalc( 6,GETVR2)} GETVR2[14]:PreBlock := {|| .F.} GETVR2[15]:PostBlock := {|| FCalc( 7,GETVR2)} GETVR2[16]:PreBlock := {|| .F.} GETVR2[17]:PostBlock := {|| FCalc( 8,GETVR2)} GETVR2[18]:PreBlock := {|| .F.} GETVR2[19]:PostBlock := {|| FCalc( 9,GETVR2)} GETVR2[20]:PreBlock := {|| .F.} GETVR2[21]:PostBlock := {|| FCalc(10,GETVR2)} GETVR2[22]:PreBlock := {|| .F.} GETVR2[23]:PostBlock := {|| (FCalc(11,GETVR2) .AND. (LastKey() == K_UP .Or. Str((KX_PBLA+KX_PPRM+KX_PMIE+KX_PMTM+KX_PBST+KX_PNEU+KX_PLY1+KX_PLY2+KX_PMON+KX_PEOS+KX_PBAS),6,2) == '100.00'))} GETVR2[24]:PreBlock := {|| .F.} * GETVR3[ 1]:PostBlock := {|| FDigT() .And. KX_FG2$'X '} GETVR3[ 4]:PostBlock := {|| FCalc(12,GETVR3)} GETVR3[ 5]:PreBlock := {|| .F.} GETVR3[ 6]:PreBlock := {|| .F.} GETVR3[ 7]:PreBlock := {|| .F.} * GETVR4[ 1]:PostBlock := {|| FDigT() .And. KX_FG3$'X '} * GETVR5[ 1]:PostBlock := {|| FDigT() .And. KX_FG4$'X '} GETVR5[ 2]:PostBlock := {|| KX_FG5$'X '} GETVR5[ 3]:PostBlock := {|| KX_FG6$'X '} GETVR5[ 4]:PostBlock := {|| KX_FG7$'X '} * GETVR6[ 1]:PostBlock := {|| FDigT() .And. IIf(Empty(KX_MD1), FBusca('HIS',KX_MC1,GETVR6), .T.)} GETVR6[ 3]:PostBlock := {|| IIf(Empty(KX_MD2), FBusca('HIS',KX_MC2,GETVR6), .T.)} GETVR6[ 5]:PostBlock := {|| IIf(Empty(KX_MD3), FBusca('HIS',KX_MC3,GETVR6), .T.)} GETVR6[ 7]:PostBlock := {|| IIf(Empty(KX_MD4), FBusca('HIS',KX_MC4,GETVR6), .T.)} GETVR6[ 9]:PostBlock := {|| IIf(Empty(KX_MD5), FBusca('HIS',KX_MC5,GETVR6), .T.)} GETVR6[11]:PostBlock := {|| IIf(Empty(KX_MD6), FBusca('HIS',KX_MC6,GETVR6), .T.)} GETVR6[13]:PostBlock := {|| IIf(Empty(KX_MD7), FBusca('HIS',KX_MC7,GETVR6), .T.)} GETVR6[15]:PostBlock := {|| IIf(Empty(KX_MD8), FBusca('HIS',KX_MC8,GETVR6), .T.)} * GETVR7[ 1]:PostBlock := {|| FDigT() .And. IIf(Empty(KX_OD1), FBusca('HIS',KX_OC1,GETVR7), .T.)} GETVR7[ 3]:PostBlock := {|| IIf(Empty(KX_OD2), FBusca('HIS',KX_OC2,GETVR7), .T.)} * FTela(1,GETVR1,GETVR2,GETVR3,GETVR4,GETVR5) * While .T. SetCursor(1) ReadModal(GETVR1) SetCursor(0) * If LastKey() != K_ESC While .T. SetCursor(1) ReadModal(GETVR2) SetCursor(0) * If LastKey() == K_UP Exit ElseIf LastKey() != K_ESC While .T. SetCursor(1) ReadModal(GETVR3) SetCursor(0) * If LastKey() == K_UP Exit ElseIf LastKey() != K_ESC While .T. SetCursor(1) ReadModal(GETVR4) SetCursor(0) * If LastKey() == K_UP Exit ElseIf LastKey() != K_ESC While .T. SetCursor(1) ReadModal(GETVR5) SetCursor(0) * If LastKey() == K_UP Exit ElseIf LastKey() != K_ESC FTela(2,GETVR6,GETVR7) * While .T. SetCursor(1) ReadModal(GETVR6) SetCursor(0) * If LastKey() == K_UP FTela(1,GETVR1,GETVR2,GETVR3,GETVR4,GETVR5) Exit ElseIf LastKey() != K_ESC While .T. SetCursor(1) ReadModal(GETVR7) SetCursor(0) * If LastKey() == K_UP Exit ElseIf LastKey() != K_ESC n_alert := ALERT('Confirme !!!',{'Gravar','Cancelar','Liberar e Enviar'}) *############################################################################## IF IsWorking( nHandle ) .AND. nHandle > 0 @ 22,62 SAY " "+c_com+" ativa b" ELSE SetColor(cor_7) @ 22,62 SAY " "+c_com+" INATIVA b" SetColor(cor_6) ENDIF * inkey(0) *############################################################################## IF n_alert = 1 .OR. n_alert = 3 KX21->(DBGoTo(RG1)) KX21->(B_LockRec(0)) * IF n_alert == 3 IF __nivel == "BIO" KX21->(FieldPut( 1,'û' )) && Libera KX21->(FieldPut( 2,__usuar)) && usuário. ELSE ALERT("Seu n¡vel nÆo permite liberar exames !!! ;;" +; "Os valores digitados ou alterados foram gravados.") ENDIF ENDIF KX_SID := RIGHT( "00000000" + ALLTRIM( KX_SID ) , 08 ) KX21->(FieldPut( 6,KX_NUM)) KX21->(FieldPut( 8,KX_SID)) KX21->(FieldPut( 9,KX_SNM)) KX21->(FieldPut(11,KX_SDT)) KX21->(FieldPut(12,KX_STM)) * KX21->(FieldPut(13,KX_FG1)) KX21->(FieldPut(14,KX_WBC)) KX21->(FieldPut(15,KX_BLA)) KX21->(FieldPut(16,KX_PRM)) KX21->(FieldPut(17,KX_MIE)) KX21->(FieldPut(18,KX_MTM)) KX21->(FieldPut(19,KX_BST)) KX21->(FieldPut(20,KX_NEU)) KX21->(FieldPut(21,KX_LY1)) KX21->(FieldPut(22,KX_LY2)) KX21->(FieldPut(23,KX_MON)) KX21->(FieldPut(24,KX_EOS)) KX21->(FieldPut(25,KX_BAS)) * KX21->(FieldPut(26,KX_FG2)) KX21->(FieldPut(27,KX_RBC)) KX21->(FieldPut(28,KX_HGB)) KX21->(FieldPut(29,KX_HCT)) KX21->(FieldPut(30,KX_MCV)) KX21->(FieldPut(31,KX_MCH)) KX21->(FieldPut(32,KX_CHC)) KX21->(FieldPut(33,KX_RDW)) * KX21->(FieldPut(34,KX_FG3)) KX21->(FieldPut(35,KX_PLT)) KX21->(FieldPut(36,KX_MPV)) KX21->(FieldPut(37,KX_PCT)) KX21->(FieldPut(38,KX_PDW)) * KX21->(FieldPut(39,KX_PBLA)) KX21->(FieldPut(40,KX_PPRM)) KX21->(FieldPut(41,KX_PMIE)) KX21->(FieldPut(42,KX_PMTM)) KX21->(FieldPut(43,KX_PBST)) KX21->(FieldPut(44,KX_PNEU)) KX21->(FieldPut(45,KX_PLY1)) KX21->(FieldPut(46,KX_PLY2)) KX21->(FieldPut(47,KX_PMON)) KX21->(FieldPut(48,KX_PEOS)) KX21->(FieldPut(49,KX_PBAS)) KX21->(FieldPut(50,KX_LIM)) * KX21->(FieldPut(51,KX_FG4)) KX21->(FieldPut(52,KX_FG5)) KX21->(FieldPut(53,KX_FG6)) KX21->(FieldPut(54,KX_FG7)) * KX21->(FieldPut(55,KX_MC1)) KX21->(FieldPut(56,KX_MC2)) KX21->(FieldPut(57,KX_MC3)) KX21->(FieldPut(58,KX_MC4)) KX21->(FieldPut(59,KX_MC5)) KX21->(FieldPut(60,KX_MC6)) KX21->(FieldPut(61,KX_MC7)) KX21->(FieldPut(62,KX_MC8)) * KX21->(FieldPut(63,KX_MD1)) KX21->(FieldPut(64,KX_MD2)) KX21->(FieldPut(65,KX_MD3)) KX21->(FieldPut(66,KX_MD4)) KX21->(FieldPut(67,KX_MD5)) KX21->(FieldPut(68,KX_MD6)) KX21->(FieldPut(69,KX_MD7)) KX21->(FieldPut(70,KX_MD8)) * KX21->(FieldPut(71,KX_OC1)) KX21->(FieldPut(72,KX_OC2)) KX21->(FieldPut(73,KX_OD1)) KX21->(FieldPut(74,KX_OD2)) KX21->(DBCommit()) KX21->(DBUnLock()) * If ARQ->(DBSeek(KX_SD1)) If KX_SD1 != KX_SID If ARQ->(DBSeek(KX_SID)) ARQ->(DBSeek(KX_SD1)) * ARQ->(B_LockRec(0)) ARQ->(DBDelete()) ARQ->(DBUnLock()) * ARQ->(DBSeek(KX_SID)) Else ARQ->(DBSeek(KX_SD1)) EndIf EndIf * ARQ->(B_LockRec(0)) Else ARQ->(B_AddRec(0)) ARQ->(FieldPut( 7,'1')) EndIf * ARQ->(FieldPut( 1,'X')) ARQ->(FieldPut( 2,Space(4))) ARQ->(FieldPut( 3,KX_SID)) ARQ->(FieldPut( 4,KX_SNM)) ARQ->(FieldPut( 5,KX_IDA)) ARQ->(FieldPut( 6,KX_LIM)) ARQ->(FieldPut( 8,KX_MED)) ARQ->(FieldPut( 9,KX_COV)) ARQ->(FieldPut(10,KX_COL)) ARQ->(FieldPut(11,KX_ENT)) ARQ->(DBCommit()) ARQ->(DBUnLock()) EndIf * *############################################################################## IF IsWorking( nHandle ) .AND. nHandle > 0 @ 22,62 SAY " "+c_com+" ativa c" ELSE SetColor(cor_7) @ 22,62 SAY " "+c_com+" INATIVA c" SetColor(cor_6) ENDIF * inkey(0) *############################################################################## IF n_alert == 3 .AND. __nivel == "BIO" EnviaRes1() && Envia os resultados liberados para o servidor. ENDIF * *############################################################################## IF IsWorking( nHandle ) .AND. nHandle > 0 @ 22,62 SAY " "+c_com+" ativa d" ELSE SetColor(cor_7) @ 22,62 SAY " "+c_com+" INATIVA d" SetColor(cor_6) ENDIF * inkey(0) *############################################################################## EndIf * Exit EndDo EndIf * If LastKey() != K_UP Exit EndIf EndDo EndIf * If LastKey() != K_UP Exit EndIf EndDo EndIf * If LastKey() != K_UP Exit EndIf EndDo EndIf * If LastKey() != K_UP Exit EndIf EndDo EndIf * If LastKey() != K_UP Exit EndIf EndDo EndIf * If LastKey() != K_UP Exit EndIf EndDo * RestScreen(00,00,24,79,SCR) * DB0:Down() EndIf ElseIf MKY == K_ESC EXIT EndIf EndIf * IF IsWorking( nHandle ) .AND. InBufSize( nHandle ) > 0 RecebeDados() DB0:RefreshAll() DB0:GoBottom() ENDIF * If MKY != K_UP .Or. MKY != K_DOWN DB0:RefreshAll() Else DB0:RefreshCurrent() EndIf EndDo * IF IsWorking( nHandle ) OutChr( nHandle, @ACK ) && Envia um Ack (06) para o COBAS_KX. FechaPorta() ENDIF * RELEASE nHandle DBCloseAll() * Return (NIL) * * ************************************************************************************************* * * B_AddRec() --> Função de Lock de registro e geração de Append Blank. * Parâmetros :- Tempo relativo ao número de tentativas. *------------------------------------------------------------------------------------------------ Function B_AddRec(_WAIT) Local ForEver := (_WAIT == 0) // Número de vezes para tentativas. While (_WAIT > 0 .Or. ForEver) _WAIT-- Append Blank // Gera um registro em branco. If !NetErr() // Se nao houver erro. Return (.T.) Endif Inkey(1) EndDo Return (.F.) // Se houver erro. * * ************************************************************************************************* * * B_LockRec() --> Função de Lock de registro. * Parâmetros :- Tempo relativo ao número de tentativas. *------------------------------------------------------------------------------------------------ Function B_LockRec(_WAIT) Local ForEver := (_WAIT == 0) // Numero de vezes para tentativas While (_WAIT > 0 .Or. ForEver) _WAIT-- If RLock() // Tenta locar o registro. Return (.T.) Endif Inkey(1) EndDo Return (.F.) * * ************************************************************************************************* * * FDigit() --> Função de Cálculo do CheckSum * *------------------------------------------------------------------------------------------------ Function FDigit(LIN) Local CTD,DG1,DG2,DG3,DG4,DG5 Local TM1,TM2,TM3,TM4,TM5 DG1 := SubStr(LIN, 2,286) DG2 := SubStr(LIN, 290,336) DG3 := SubStr(LIN, 628,336) DG4 := SubStr(LIN, 966,336) DG5 := SubStr(LIN,1304,336) TM1 := 0 CTD := 1 For CTD := 1 To Len(DG1) - 2 TM1 := TM1 + Asc(SubStr(DG1,CTD,1)) Next CTD TM2 := 0 CTD := 1 For CTD := 1 To Len(DG2) - 2 TM2 := TM2 + Asc(SubStr(DG2,CTD,1)) Next CTD TM3 := 0 CTD := 1 For CTD := 1 To Len(DG3) - 2 TM3 := TM3 + Asc(SubStr(DG3,CTD,1)) Next CTD TM4 := 0 CTD := 1 For CTD := 1 To Len(DG4) - 2 TM4 := TM4 + Asc(SubStr(DG4,CTD,1)) Next CTD TM5 := 0 CTD := 1 For CTD := 1 To Len(DG5) - 2 TM5 := TM5 + Asc(SubStr(DG5,CTD,1)) Next CTD If FDeci(TM1%256) == SubStr(DG1,Len(DG1) - 1,2) .And. IIf(Len(LIN) == 1640, FDeci(TM2%256) == SubStr(DG2,Len(DG2) - 1,2) .And.; FDeci(TM3%256) == SubStr(DG3,Len(DG3) - 1,2) .And.; FDeci(TM4%256) == SubStr(DG4,Len(DG4) - 1,2) .And.; FDeci(TM5%256) == SubStr(DG5,Len(DG5) - 1,2), .T.) Return (.T.) EndIf * Return (.F.) * * ************************************************************************************************* * * FDeci() --> Função de Conversão em Hexadecimal * *------------------------------------------------------------------------------------------------ Function FDeci(DEC) Local HX1,HX2,HX3,HX4 HX1 := Int(DEC/4096) HX2 := Int((DEC - (HX1 * 4096))/ 256) HX3 := Int((DEC - ((HX1 * 4096) + (HX2 * 256)))/ 16) HX4 := Int((DEC - ((HX1 * 4096) + (HX2 * 256) + (HX3 * 16)))/ 1) HX1 := IIf(HX1 == 10, 'A', IIf(HX1 == 11, 'B', IIF(HX1 == 12, 'C', IIf(HX1 == 13, 'D', IIf(HX1 == 14, 'E', IIf(HX1 == 15, 'F', Str(HX1,1,1))))))) HX2 := IIf(HX2 == 10, 'A', IIf(HX2 == 11, 'B', IIF(HX2 == 12, 'C', IIf(HX2 == 13, 'D', IIf(HX2 == 14, 'E', IIf(HX2 == 15, 'F', Str(HX2,1,1))))))) HX3 := IIf(HX3 == 10, 'A', IIf(HX3 == 11, 'B', IIF(HX3 == 12, 'C', IIf(HX3 == 13, 'D', IIf(HX3 == 14, 'E', IIf(HX3 == 15, 'F', Str(HX3,1,1))))))) HX4 := IIf(HX4 == 10, 'A', IIf(HX4 == 11, 'B', IIF(HX4 == 12, 'C', IIf(HX4 == 13, 'D', IIf(HX4 == 14, 'E', IIf(HX4 == 15, 'F', Str(HX4,1,1))))))) Return (IIf(HX1 == '0' .And. HX2 == '0', (HX3 + HX4), (HX1 + HX2 + HX3 + HX4))) * * ************************************************************************************************* * * FCalc() --> Função de Cálculo de Valores * *------------------------------------------------------------------------------------------------ Function FCalc(IND,GETVR1) Do Case Case IND == 1 KX_BLA := KX_WBC*(KX_PBLA/100.00) Case IND == 2 KX_PRM := KX_WBC*(KX_PPRM/100.00) Case IND == 3 KX_MIE := KX_WBC*(KX_PMIE/100.00) Case IND == 4 KX_MTM := KX_WBC*(KX_PMTM/100.00) Case IND == 5 KX_BST := KX_WBC*(KX_PBST/100.00) Case IND == 6 KX_NEU := KX_WBC*(KX_PNEU/100.00) Case IND == 7 KX_LY1 := KX_WBC*(KX_PLY1/100.00) Case IND == 8 KX_LY2 := KX_WBC*(KX_PLY2/100.00) Case IND == 9 KX_MON := KX_WBC*(KX_PMON/100.00) Case IND == 10 KX_EOS := KX_WBC*(KX_PEOS/100.00) Case IND == 11 KX_BAS := KX_WBC*(KX_PBAS/100.00) n_contagem := KX_PBLA+KX_PPRM+KX_PMIE+KX_PMTM+KX_PBST+KX_PNEU+KX_PLY1+KX_PLY2+KX_PMON+KX_PEOS+KX_PBAS @ 20,06 say "Total: " + STR(n_contagem,05,01) Case IND == 12 KX_MCV := (KX_HCT*10)/KX_RBC KX_MCH := (KX_HGB*10)/KX_RBC KX_CHC := (KX_HGB/KX_HCT)*100 EndCase AEVal(GETVR1, {|CT2| CT2:Reset()}) AEVal(GETVR1, {|CT2| CT2:Display()}) Return (.T.) * * ************************************************************************************************* * * FGravaLin() --> Função de Lock de registro e geração de Append Blank. * *------------------------------------------------------------------------------------------------ Function FGravaLin(LIN) Local CT1,DG1,DG2,DG3,DG4,DG5,KXARR DG1 := SubStr(LIN, 1,286) KXMTP := SubStr(DG1, 3, 3) && vazio. KXNUM := SubStr(DG1, 8, 4) && Número seqüencial. KXSTP := SubStr(DG1,13, 1) && ??? KXSID := SubStr(DG1,20, 8) && Ficha do paciente. KXSNM := SubStr(DG1,31,16) && Nome do paciente - não usado no KX. KXOID := SubStr(DG1,50, 3) KXSDT := SubStr(DG1,56, 8) KXSTM := SubStr(DG1,67, 5) KXWBC := Val(SubStr(DG1,74, 5))*100 KXPBL := 0.0 KXPPM := 0.0 KXPMI := 0.0 KXPMM := 0.0 KXPNE := Val(SubStr(DG1,176, 5))/10 KXPL1 := Val(SubStr(DG1,182, 5))/10 KXPL2 := 0.0 KXPMO := Val(SubStr(DG1,188, 5))/10 KXPEO := Val(SubStr(DG1,194, 5))/10 KXPBA := Val(SubStr(DG1,200, 5))/10 KXPBT := 0.0 KXFG1 := 'X' KXBLA := 0 KXPRM := 0 KXMIE := 0 KXMTM := 0 KXBST := 0 KXNEU := KXWBC*(KXPNE/100.00) KXLY1 := KXWBC*(KXPL1/100.00) KXLY2 := 0 KXMON := KXWBC*(KXPMO/100.00) KXEOS := KXWBC*(KXPEO/100.00) KXBAS := KXWBC*(KXPBA/100.00) /**** KXNEU := Val(SubStr(DG1, 80, 5))*100 KXLY1 := Val(SubStr(DG1, 86, 5))*100 KXMON := Val(SubStr(DG1, 92, 5))*100 KXEOS := Val(SubStr(DG1, 98, 5))*100 KXBAS := Val(SubStr(DG1,104, 5))*100 ****/ KXFG2 := 'X' KXRBC := Val(SubStr(DG1,110, 5))/100 KXHGB := Val(SubStr(DG1,116, 5))/10 KXHCT := Val(SubStr(DG1,122, 5))/10 KXMCV := Val(SubStr(DG1,128, 5))/10 KXMCH := Val(SubStr(DG1,134, 5))/10 KXCHC := Val(SubStr(DG1,140, 5))/10 KXRDW := Val(SubStr(DG1,146, 5))/10 KXFG3 := 'X' KXPLT := Val(SubStr(DG1,152, 5))*1000 KXMPV := Val(SubStr(DG1,158, 5))/10 KXPCT := Val(SubStr(DG1,164, 5))/100 KXPDW := Val(SubStr(DG1,170, 5))/10 KXLIM := SubStr(DG1,278,1) KXFG4 := 'X' KXFG5 := 'X' KXFG6 := 'X' KXFG7 := 'X' KX21->(B_AddRec(0)) KX21->(FieldPut( 5,KXMTP)) KX21->(FieldPut( 6,KXNUM)) KX21->(FieldPut( 7,KXSTP)) KX21->(FieldPut( 8,KXSID)) KX21->(FieldPut( 9,KXSNM)) KX21->(FieldPut(10,KXOID)) KX21->(FieldPut(11,KXSDT)) KX21->(FieldPut(12,KXSTM)) KX21->(FieldPut(13,KXFG1)) KX21->(FieldPut(14,KXWBC)) KX21->(FieldPut(15,KXBLA)) KX21->(FieldPut(16,KXPRM)) KX21->(FieldPut(17,KXMIE)) KX21->(FieldPut(18,KXMTM)) KX21->(FieldPut(19,KXBST)) KX21->(FieldPut(20,KXNEU)) KX21->(FieldPut(21,KXLY1)) KX21->(FieldPut(22,KXLY2)) KX21->(FieldPut(23,KXMON)) KX21->(FieldPut(24,KXEOS)) KX21->(FieldPut(25,KXBAS)) KX21->(FieldPut(26,KXFG2)) KX21->(FieldPut(27,KXRBC)) KX21->(FieldPut(28,KXHGB)) KX21->(FieldPut(29,KXHCT)) KX21->(FieldPut(30,KXMCV)) KX21->(FieldPut(31,KXMCH)) KX21->(FieldPut(32,KXCHC)) KX21->(FieldPut(33,KXRDW)) KX21->(FieldPut(34,KXFG3)) KX21->(FieldPut(35,KXPLT)) KX21->(FieldPut(36,KXMPV)) KX21->(FieldPut(37,KXPCT)) KX21->(FieldPut(38,KXPDW)) KX21->(FieldPut(39,KXPBL)) KX21->(FieldPut(40,KXPPM)) KX21->(FieldPut(41,KXPMI)) KX21->(FieldPut(42,KXPMM)) KX21->(FieldPut(43,KXPBT)) KX21->(FieldPut(44,KXPNE)) KX21->(FieldPut(45,KXPL1)) KX21->(FieldPut(46,KXPL2)) KX21->(FieldPut(47,KXPMO)) KX21->(FieldPut(48,KXPEO)) KX21->(FieldPut(49,KXPBA)) KX21->(FieldPut(50,KXLIM)) KX21->(FieldPut(51,KXFG4)) KX21->(FieldPut(52,KXFG5)) KX21->(FieldPut(53,KXFG6)) KX21->(FieldPut(54,KXFG7)) KX21->(DBCommit) KX21->(DBUnLock()) If Len(LIN) == 1640 DG2 := SubStr(LIN, 289,336) DG3 := SubStr(LIN, 627,336) DG4 := SubStr(LIN, 965,336) DG5 := SubStr(LIN,1303,336) CT1 := 1 For CT1 := 1 To 4 HST->(B_AddRec(0)) HST->(FieldPut( 1, SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))), 3, 3))) HST->(FieldPut( 2, SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))), 8, 4))) HST->(FieldPut( 3, SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))), 13, 1))) HST->(FieldPut( 4, SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))), 16,12))) HST->(FieldPut( 5, SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))), 31,16))) HST->(FieldPut( 6, SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))), 50, 3))) HST->(FieldPut( 7, SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))), 56, 8))) HST->(FieldPut( 8, SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))), 67, 5))) HST->(FieldPut( 9,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))), 74, 5)))) HST->(FieldPut(10,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))), 80, 3)))) HST->(FieldPut(11,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))), 84, 3)))) HST->(FieldPut(12,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))), 88, 3)))) HST->(FieldPut(13,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))), 92, 3)))) HST->(FieldPut(14,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))), 96, 3)))) HST->(FieldPut(15,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),100, 3)))) HST->(FieldPut(16,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),104, 3)))) HST->(FieldPut(17,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),108, 3)))) HST->(FieldPut(18,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),112, 3)))) HST->(FieldPut(19,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),116, 3)))) HST->(FieldPut(20,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),120, 3)))) HST->(FieldPut(21,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),124, 3)))) HST->(FieldPut(22,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),128, 3)))) HST->(FieldPut(23,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),132, 3)))) HST->(FieldPut(24,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),136, 3)))) HST->(FieldPut(25,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),140, 3)))) HST->(FieldPut(26,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),144, 3)))) HST->(FieldPut(27,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),148, 3)))) HST->(FieldPut(28,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),152, 3)))) HST->(FieldPut(29,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),156, 3)))) HST->(FieldPut(30,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),160, 3)))) HST->(FieldPut(31,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),164, 3)))) HST->(FieldPut(32,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),168, 3)))) HST->(FieldPut(33,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),172, 3)))) HST->(FieldPut(34,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),176, 3)))) HST->(FieldPut(35,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),180, 3)))) HST->(FieldPut(36,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),184, 3)))) HST->(FieldPut(37,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),188, 3)))) HST->(FieldPut(38,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),192, 3)))) HST->(FieldPut(39,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),196, 3)))) HST->(FieldPut(40,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),200, 3)))) HST->(FieldPut(41,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),204, 3)))) HST->(FieldPut(42,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),208, 3)))) HST->(FieldPut(43,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),212, 3)))) HST->(FieldPut(44,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),216, 3)))) HST->(FieldPut(45,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),220, 3)))) HST->(FieldPut(46,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),224, 3)))) HST->(FieldPut(47,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),228, 3)))) HST->(FieldPut(48,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),232, 3)))) HST->(FieldPut(49,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),236, 3)))) HST->(FieldPut(50,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),240, 3)))) HST->(FieldPut(51,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),244, 3)))) HST->(FieldPut(52,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),248, 3)))) HST->(FieldPut(53,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),252, 3)))) HST->(FieldPut(54,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),256, 3)))) HST->(FieldPut(55,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),260, 3)))) HST->(FieldPut(56,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),264, 3)))) HST->(FieldPut(57,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),268, 3)))) HST->(FieldPut(58,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),272, 3)))) HST->(FieldPut(59,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),276, 3)))) HST->(FieldPut(60,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),280, 3)))) HST->(FieldPut(61,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),284, 3)))) HST->(FieldPut(62,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),288, 3)))) HST->(FieldPut(63,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),292, 3)))) HST->(FieldPut(64,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),296, 3)))) HST->(FieldPut(65,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),300, 3)))) HST->(FieldPut(66,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),304, 3)))) HST->(FieldPut(67,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),308, 3)))) HST->(FieldPut(68,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),312, 3)))) HST->(FieldPut(69,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),316, 3)))) HST->(FieldPut(70,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),320, 3)))) HST->(FieldPut(71,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),324, 3)))) HST->(FieldPut(72,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),328, 3)))) HST->(FieldPut(73,Val(SubStr(IIf(CT1 == 1, DG2, IIf(CT1 == 2, DG3, IIf(CT1 == 3, DG4, DG5))),332, 3)))) HST->(DBCommit()) HST->(DBUnLock()) Next CT1 EndIf Return (NIL) * * ************************************************************************************************* * * FPesq() --> Função de pesquisa em arquivos secundário. * *------------------------------------------------------------------------------------------------ Function FPesq() Local CT1,CT2,SEL,CUR,COR,IND,TEC,RET,IDK,RES Local PESQ,SCR1,SCR2 SEL := Select() CUR := SetCursor() COR := SetColor() IND := IndexOrd() SCR1 := SaveScreen(00, 00, 24, 79) If Ascan({'KX_MC1','KX_MC2','KX_MC3','KX_MC4','KX_MC5','KX_MC6','KX_MC7','KX_MC8','KX_OC1','KX_OC2','HISCOD'},ReadVar()) == 0 Select (SEL) Return (.F.) EndIf SetCursor(0) Select HIS DBSetOrder(2) DBGoTop() SetColor(COR_BX1) @ 12,02,20,77 Box 'Õ͸³´Äó ' @ 20,02,22,77 Box 'Æ͵³ÙÄÀ³ ' SetColor(COR_BX2) @ 13,03 Clear To 19,76 @ 21,03 Clear To 21,76 @ 21,03 Say ' Retorna a rotina. Inclus„o. Escolha do ¡tem.' PESQ := TBrowseDB(13,03,19,76) PESQ:ColSep := '³' PESQ:HeadSep := 'ÑÍ' PESQ:AddColumn(TBColumnNew('C¢digo' ,{|| HIS->HISCOD})) PESQ:AddColumn(TBColumnNew('Hist¢rico',{|| SubStr(HIS->HISDES,1,65)})) CT1 := Space(0) While .T. While(!PESQ:Stabilize()); EndDo PESQ:ColorRect({PESQ:RowPos, 1, PESQ:RowPos, PESQ:ColCount},{2,1}) TEC := Inkey(2) If TEC == K_DOWN PESQ:Down() ElseIf TEC == K_UP PESQ:Up() ElseIf TEC == K_PGUP PESQ:PageUp() ElseIf TEC == K_PGDN PESQ:PageDown() ElseIf TEC == K_CTRL_PGUP PESQ:GoTop() ElseIf TEC == K_CTRL_PGDN PESQ:GoBottom() ElseIf TEC == K_HOME PESQ:Home() ElseIf TEC == K_END PESQ:End() ElseIf TEC == K_CTRL_HOME PESQ:PanHome() ElseIf TEC == K_CTRL_END PESQ:PanEnd() ElseIf TEC == K_INS Cadastro(2) PESQ:Down() PESQ:RefreshAll() While(!PESQ:Stabilize()); EndDo PESQ:ColorRect({PESQ:RowPos, 1, PESQ:RowPos, PESQ:ColCount},{2,1}) ElseIf TEC == K_ENTER RET := PESQ:GetColumn(1) KeyBoard EVal(RET:Block) Exit ElseIf TEC == K_ESC Exit EndIf If Ascan({'KX_MC1','KX_MC2','KX_MC3','KX_MC4','KX_MC5','KX_MC6','KX_MC7','KX_MC8','KX_OC1','KX_OC2'},ReadVar()) != 0 IF IsWorking( nHandle ) RecebeDados() ENDIF *Com_Check() EndiF PESQ:RefreshAll() EnddO DBSetOrder(1) Select (SEL) DBSetOrder(IND) SetCursor(CUR) SetColor(COR) RestScreen(00, 00, 24, 79, SCR1) Return (NIL) * * ************************************************************************************************* * * FBusca() --> Função de busca em arquivos secundário. * *------------------------------------------------------------------------------------------------ Function FBusca(ALI,VAR,GETVAR) Local SEL := Select() Local AVAR := {'KX_MC1','KX_MC2','KX_MC3','KX_MC4','KX_MC5','KX_MC6','KX_MC7','KX_MC8','KX_OC1','KX_OC2'} If LastKey() == K_UP .Or. Empty(VAR) Select (SEL) Return (.T.) EndIf Select (ALI) If !DBSeek(VAR) If ReadVar() == 'KX_MC1' KX_MC1 := Space( 5) KX_MD1 := Space(75) ElseIf ReadVar() == 'KX_MC2' KX_MC2 := Space( 5) KX_MD2 := Space(75) ElseIf ReadVar() == 'KX_MC3' KX_MC3 := Space( 5) KX_MD3 := Space(75) ElseIf ReadVar() == 'KX_MC4' KX_MC4 := Space( 5) KX_MD4 := Space(75) ElseIf ReadVar() == 'KX_MC5' KX_MC5 := Space( 5) KX_MD5 := Space(75) ElseIf ReadVar() == 'KX_MC6' KX_MC6 := Space( 5) KX_MD6 := Space(75) ElseIf ReadVar() == 'KX_MC7' KX_MC7 := Space( 5) KX_MD7 := Space(75) ElseIf ReadVar() == 'KX_MC8' KX_MC8 := Space( 5) KX_MD8 := Space(75) ElseIf ReadVar() == 'KX_OC1' KX_OC1 := Space( 5) KX_OD1 := Space(75) ElseIf ReadVar() == 'KX_OC2' KX_OC2 := Space( 5) KX_OD2 := Space(75) EndIf AEVal(GETVAR, {|CT2| CT2:Reset()}) AEVal(GETVAR, {|CT2| CT2:Display()}) Select (SEL) Return (.F.) Else If ReadVar() == 'KX_MC1' KX_MD1 := HIS->HISDES ElseIf ReadVar() == 'KX_MC2' KX_MD2 := HIS->HISDES ElseIf ReadVar() == 'KX_MC3' KX_MD3 := HIS->HISDES ElseIf ReadVar() == 'KX_MC4' KX_MD4 := HIS->HISDES ElseIf ReadVar() == 'KX_MC5' KX_MD5 := HIS->HISDES ElseIf ReadVar() == 'KX_MC6' KX_MD6 := HIS->HISDES ElseIf ReadVar() == 'KX_MC7' KX_MD7 := HIS->HISDES ElseIf ReadVar() == 'KX_MC8' KX_MD8 := HIS->HISDES ElseIf ReadVar() == 'KX_OC1' KX_OD1 := HIS->HISDES ElseIf ReadVar() == 'KX_OC2' KX_OD2 := HIS->HISDES EndIf AEVal(GETVAR, {|CT2| CT2:Reset()}) AEVal(GETVAR, {|CT2| CT2:Display()}) Select (SEL) Return (.T.) EndIf Return (NIL) * * ************************************************************************************************* * * B_Save() --> Função de salvamento por meio da tecla F6 (Ctrl W) * *------------------------------------------------------------------------------------------------ Function B_Save(KEY) KeyBoard Chr(KEY) Return (.T.) * * ************************************************************************************************* * * FDigT() --> Função de Troca de Tela. * *------------------------------------------------------------------------------------------------ Function FDigT() Local GETLIST := {} If LastKey() == K_UP Clear Gets EndIf Return (.T.) * * ************************************************************************************************* * * FTela() --> Função de montagem de Tela * *------------------------------------------------------------------------------------------------ Function FTela(IND,GT1,GT2,GT3,GT4,GT5) If IND == 1 SetColor(COR_BX1) @ 00,00,05,79 Box 'ÉÍ»³ÀÄÙ³ ' @ 05,00,21,27 Box 'ÉÍ»³ÏÍƳ ' @ 05,27,16,54 Box 'ËÍ»³ÏÍƳ ' @ 05,54,16,79 Box 'ËÍ»³µÍϳ ' @ 16,27,21,79 Box 'ÉÍ»³µÍϳ ' @ 21,00,23,79 Box 'ÉÍ»³ÙÄÀ³ ' SetColor(COR_BX2) @ 00,21 Say ' R E C E B I M E N T O D E D A D O S ' @ 01,02 Say 'N£mero Ficha Data/Hora /' @ 02,02 Say 'Paciente Idade Limites' @ 03,02 Say 'Convˆnio Coleta ' @ 04,02 Say 'M‚dico Entrega ' @ 06,01 Say ' ( ) LEUCOGRAMA % /mm3' @ 08,01 Say ' Leuc¢citos ' @ 09,01 Say ' Blastos ' @ 10,01 Say ' P.Miel¢citos ' @ 11,01 Say ' Miel¢citos ' @ 12,01 Say ' M.Miel¢citos ' @ 13,01 Say ' Bastäes ' @ 14,01 Say ' Segmentados ' @ 15,01 Say ' Linf¢citos T ' @ 16,01 Say ' Linf¢citos A ' @ 17,01 Say ' Mon¢citos ' @ 18,01 Say ' Eosin¢filos ' @ 19,01 Say ' Bas¢filos ' @ 06,28 Say ' ( ) ERITROGRAMA ' @ 08,28 Say ' Hem cia m/mm3' @ 09,28 Say ' Hemoglobina g/dl ' @ 10,28 Say ' Hemat¢crito % ' @ 11,28 Say ' VCM fL ' @ 12,28 Say ' HCM pg ' @ 13,28 Say ' Conc HCM g/dl ' @ 14,28 Say ' RDW ' @ 06,55 Say ' ( ) PLAQUETAS ' @ 08,55 Say ' Plaquetas /mm3 ' @ 09,55 Say ' VPM fL ' @ 10,55 Say ' PCT % ' @ 11,55 Say ' PDW ' @ 17,28 Say ' HISTOGRAMAS ( ) Lym-Baso-Mono' @ 18,28 Say ' ( ) Mono-Poly ' @ 19,28 Say ' ( ) Plt ' @ 20,28 Say ' ( ) Rbc ' @ 22,01 Say ' Retorna Avan‡a Quadro Acessa Morfologias Contador' AEVal(GT1, {|CT2| CT2:Reset()}) AEVal(GT1, {|CT2| CT2:Display()}) AEVal(GT2, {|CT2| CT2:Reset()}) AEVal(GT2, {|CT2| CT2:Display()}) AEVal(GT3, {|CT2| CT2:Reset()}) AEVal(GT3, {|CT2| CT2:Display()}) AEVal(GT4, {|CT2| CT2:Reset()}) AEVal(GT4, {|CT2| CT2:Display()}) AEVal(GT5, {|CT2| CT2:Reset()}) AEVal(GT5, {|CT2| CT2:Display()}) ElseIf IND == 2 SetColor(COR_BX1) @ 05,00,16,79 Box 'Æ͵³µÍƳ ' @ 16,00,21,79 Box 'Æ͵³µÍƳ ' SetColor(COR_BX2) @ 00,21 Say ' R E C E B I M E N T O D E D A D O S ' @ 06,01 Say ' MORFOLOGIA ' @ 08,01 Say ' #1 ' @ 09,01 Say ' #2 ' @ 10,01 Say ' #3 ' @ 11,01 Say ' #4 ' @ 12,01 Say ' #5 ' @ 13,01 Say ' #6 ' @ 14,01 Say ' #7 ' @ 15,01 Say ' #8 ' @ 17,01 Say ' OBSERVA€ÇO ' @ 19,01 Say ' #1 ' @ 20,01 Say ' #2 ' @ 22,01 Say ' Retorna ao Recebimento Avan‡a Quadro Pesquisa ' AEVal(GT1, {|CT2| CT2:Reset()}) AEVal(GT1, {|CT2| CT2:Display()}) AEVal(GT2, {|CT2| CT2:Reset()}) AEVal(GT2, {|CT2| CT2:Display()}) EndIf Return (NIL) * * ************************************************************************************************* * * Com_Check() --> Função de checagem de envio de mensagens. * *------------------------------------------------------------------------------------------------ * Function Com_Check(DB0) * * Local CT1,HDL,LIN,FLG * Local SCR := SaveScreen(00,00,24,79) * * If Com_Count(PRM->PRMCOM) > 0 * * HDL := Space(0) * LIN := Space(0) * * While .T. * * HDL := Com_Read(PRM->PRMCOM,Com_Count(PRM->PRMCOM)) * LIN := LIN + HDL * * Regua() * * If (Len(LIN) == 288 .Or. Len(LIN) == 1640 .Or. Len(LIN)%288 == 0) .And. Len(HDL) == 0 * If Len(LIN) == 288 .Or. Len(LIN) == 1640 * If FDigit(LIN) * FGravaLin(LIN) * Else * Com_Flush(PRM->PRMCOM) * Com_Send(PRM->PRMCOM,NAK) * F_Erro(LIN,1) * EndIf * Else * FLG := .T. * CT1 := 1 * For CT1 := 1 To Len(LIN) Step 288 * If !FDigit(SubStr(LIN,CT1,288)) * FLG := .F. * EndIf * Next * * If FLG * CT1 := 1 * For CT1 := 1 To Len(LIN) Step 288 * FGravaLin(SubStr(LIN,CT1,288)) * Next * Else * Com_Flush(PRM->PRMCOM) * Com_Send(PRM->PRMCOM,NAK) * F_Erro(LIN,1) * EndIf * EndIf * RestSCreen(00,00,24,79,SCR) * Return (1) * Else * If Len(HDL) == 0 * Com_Flush(PRM->PRMCOM) * Com_Send(PRM->PRMCOM,NAK) * * F_Erro(LIN,2) * RestSCreen(00,00,24,79,SCR) * Return (2) * EndIf * EndIf * EndDo * EndIf * RestSCreen(00,00,24,79,SCR) * Return (0) * * ************************************************************************************************* * * FVMorf() --> Função de Acesso direto à morfologia * *------------------------------------------------------------------------------------------------ Function FVMorf() If ReadVar() == 'KX_SID' KeyBoard Chr(23)+Chr(23)+Chr(23)+Chr(23)+Chr(23) EndIf Return (NIL) * * ************************************************************************************************* * * FExiste() --> Função que verifica o existência dos dados no arquivo ARQ * *------------------------------------------------------------------------------------------------ Function FExiste(SID,GETVR1) SID := RIGHT( "00000000" + ALLTRIM(SID) , 08 ) If ARQ->(DBSeek(SID)) KX_SNM := ARQ->ARQNOM KX_IDA := ARQ->ARQIDA KX_LIM := ARQ->ARQLIM KX_COV := ARQ->ARQCOV KX_MED := ARQ->ARQMED KX_COL := ARQ->ARQCOL KX_ENT := ARQ->ARQENT EndIf AEVal(GETVR1, {|CT2| CT2:Reset()}) AEVal(GETVR1, {|CT2| CT2:Display()}) Return (.T.) * * ************************************************************************************************* * * Regua() --> Função que sinaliza o recebimento de mensagens * *------------------------------------------------------------------------------------------------ Function Regua() Local CTD,CUR,PSX,PSY SetColor(COR_BX1) @ 21,61,23,79 Box 'ÉÍ»³ÙÄÀ³ ' CTD := 1 For CTD := 10 To 1 STEP -1 SetColor(COR_BX2) @ 22,62 Say ' Rec -' + Replicate('<',CTD) Inkey(PRM->PRMTP1/10) Next Return (NIL) * * ************************************************************************************************* * * F_Erro() --> Função que grava tipo de erro da recepção * *------------------------------------------------------------------------------------------------ Function F_Erro(LIN,IND) Local FLE If File('KX21N.ERR') FLE := FOpen('KX21N.ERR',2) FSeek(FLE,0,2) Else FLE := FCreate('KX21N.ERR',0) EndIf If IND == 1 FWrite(FLE,DToC(Date())+'-'+Time()+' *** Erro de Digito Verificador ***'+Chr(13)+Chr(10),54) ElseIf IND == 2 FWrite(FLE,DToC(Date())+'-'+Time()+' *** Erro no Tamanho de Mensagem *** Tamanho Recebido: ' + STR(Len(LIN),6,0) +Chr(13)+Chr(10),95) EndIf FWrite(FLE,LIN+Chr(13)+Chr(10),Len(LIN)+2) FWrite(FLE,Chr(13)+Chr(10),2) FClose(FLE) Return (NIL) * * *-------------------------------------------------------------------------------------------------- ** Inicia Porta *-------------------------------------------------------------------------------------------------- PROCEDURE IniciaPorta() * Local Porta := .f. Public f_Com := '' Public InBuff := '' *Public nHandle := 0 Public f_Buff := 1000 * c_com := "COM" + ALLTRIM( STR( PRM->PRMCOM,02,00 ) ) * ////////// Init_port( "COM1", ----1200-- , -----8-----, 0->NOPARITY, -----1-----, 8000 ) nHandle := Init_Port( c_com , PRM->PRMBRT, PRM->PRMDTB, PRM->PRMPRT, PRM->PRMSTB, f_Buff ) * IF IsWorking( nHandle ) OutBufClr( nHandle ) && Limpa o Buffer de Saída OutChr( nHandle, ACK ) && Envia um Ack (06) para o KX21. ENDIF * RETURN( nHandle ) * * *-------------------------------------------------------------------------------------------------- * Fecha Porta *-------------------------------------------------------------------------------------------------- PROCEDURE FechaPorta() ** Fecha a porta UnInt_Port( nHandle ) RETURN NIL * * *-------------------------------------------------------------------------------------------------- * Recebe Dados *-------------------------------------------------------------------------------------------------- PROCEDURE RecebeDados() * Local cRead := cLinha := cRetorno := "" * PUBLIC c_data1 , c_hora1 , c_sid , c_PdaI , c_anali, c_reser PUBLIC n_wbc , n_rbc , n_hgb , n_hct , n_mcv , n_mch , n_mchc PUBLIC n_plt , n_lym1 , n_mxd1 , n_neut1 , n_lym2 , n_mxd2 , n_neut2 PUBLIC n_rdwsd , n_rdwcv , n_pdw , n_mpv , n_plcr PUBLIC c_wbc_ , c_rbc_ , c_hgb_ , c_hct_ , c_mcv_ , c_mch_ , c_mchc_ PUBLIC c_plt_ , c_lym1_ , c_mxd1_ , c_neut1_, c_lym2_, c_mxd2_ , c_neut2_ PUBLIC c_rdwsd_, c_rdwcv_, c_pdw_ , c_mpv_ , c_plcr_ * IF ! IsWorking( nHandle ) RETURN(.F.) ENDIF * OutBufClr( nHandle ) && Limpa o Buffer de Saída OutChr( nHandle, ACK ) && Envia um Ack (06) para o KX. * DO WHILE InBufSize( nHandle ) > 0 nRead := InBufSize( nHandle ) cRead := Space( nRead ) InChr( nHandle, nRead, @cRead) cRetorno += cRead @ 22,62 Say ' ' Regua() IF ( LEFT( cRetorno, 04 ) == CHR(2) + "D1U" .AND. RIGHT( cRetorno, 01 ) == CHR(3) .AND. LEN(cRetorno) == 131 ) FormataDados( cRetorno ) GravaDBF() cRetorno := "" ENDIF * ENDDO * OutChr( nHandle, ACK ) // Envia um Ack (06) para o KX. * RETURN( cRetorno ) * *-------------------------------------------------------------------------------------------------- FUNCTION FormataDados( cStr02 ) * c_data1 := SSTODD( SUBS(cStr02, 05, 08 ) ) c_anali := SUBS( cStr02, 13, 01 ) && Analisys Information. c_sid := SUBS( cStr02, 17, 12 ) c_PdaI := SUBS( cStr02, 29, 06 ) && flags. c_reser := SUBS( cStr02, 35, 01 ) n_wbc := VAL( SUBS(cStr02, 36, 04 ) ) * 100 ; c_wbc_ := SUBS(cStr02, 40, 01 ) n_rbc := VAL( SUBS(cStr02, 41, 04 ) ) / 100 ; c_rbc_ := SUBS(cStr02, 45, 01 ) n_hgb := VAL( SUBS(cStr02, 46, 04 ) ) / 10 ; c_hgb_ := SUBS(cStr02, 50, 01 ) n_hct := VAL( SUBS(cStr02, 51, 04 ) ) / 10 ; c_hct_ := SUBS(cStr02, 55, 01 ) n_mcv := VAL( SUBS(cStr02, 56, 04 ) ) / 10 ; c_mcv_ := SUBS(cStr02, 60, 01 ) n_mch := VAL( SUBS(cStr02, 61, 04 ) ) / 10 ; c_mch_ := SUBS(cStr02, 65, 01 ) n_mchc := VAL( SUBS(cStr02, 66, 04 ) ) / 10 ; c_mchc_ := SUBS(cStr02, 70, 01 ) n_plt := VAL( SUBS(cStr02, 71, 04 ) ) * 1000 ; c_plt_ := SUBS(cStr02, 75, 01 ) n_lym1 := VAL( SUBS(cStr02, 76, 04 ) ) / 10 ; c_lym1_ := SUBS(cStr02, 80, 01 ) n_mxd1 := VAL( SUBS(cStr02, 81, 04 ) ) / 10 ; c_mxd1_ := SUBS(cStr02, 85, 01 ) n_neut1 := VAL( SUBS(cStr02, 86, 04 ) ) / 10 ; c_neut1_ := SUBS(cStr02, 90, 01 ) n_lym2 := VAL( SUBS(cStr02, 91, 04 ) ) / 10 ; c_lym2_ := SUBS(cStr02, 95, 01 ) n_mxd2 := VAL( SUBS(cStr02, 96, 04 ) ) / 10 ; c_mxd2_ := SUBS(cStr02, 100, 01 ) n_neut2 := VAL( SUBS(cStr02, 101, 04 ) ) / 10 ; c_neut2_ := SUBS(cStr02, 105, 01 ) n_rdwsd := VAL( SUBS(cStr02, 106, 04 ) ) / 10 ; c_rdwsd_ := SUBS(cStr02, 110, 01 ) n_rdwcv := VAL( SUBS(cStr02, 111, 04 ) ) / 10 ; c_rdwcv_ := SUBS(cStr02, 115, 01 ) n_pdw := VAL( SUBS(cStr02, 116, 04 ) ) / 10 ; c_pdw_ := SUBS(cStr02, 120, 01 ) n_mpv := VAL( SUBS(cStr02, 121, 04 ) ) / 10 ; c_mpv_ := SUBS(cStr02, 125, 01 ) n_plcr := VAL( SUBS(cStr02, 126, 04 ) ) / 10 ; c_plcr_ := SUBS(cStr02, 130, 01 ) * RETURN(.T.) * *-------------------------------------------------------------------------------------------------- FUNCTION GravaDBF() * KX21->( DBGoBottom() ) c_seq := STRZERO( VAL( KX21->KXNUM ) + 01, 04, 00 ) KX21->( Adireg( 10 ) ) * KX21->( FieldPut( FieldPos( "KXSDT" ), c_data1 ) ) KX21->( FieldPut( FieldPos( "KXSTM" ), LEFT( TIME(), 05 ) ) ) KX21->( FieldPut( FieldPos( "KXNUM" ), c_seq ) ) KX21->( FieldPut( FieldPos( "KXSID" ), c_sid ) ) KX21->( FieldPut( FieldPos( "KXWBC" ), n_wbc ) ) KX21->( FieldPut( FieldPos( "KXBLA" ), 0 ) ) KX21->( FieldPut( FieldPos( "KXPRM" ), 0 ) ) KX21->( FieldPut( FieldPos( "KXMIE" ), 0 ) ) KX21->( FieldPut( FieldPos( "KXMTM" ), 0 ) ) KX21->( FieldPut( FieldPos( "KXBST" ), 0 ) ) KX21->( FieldPut( FieldPos( "KXlY2" ), 0 ) ) KX21->( FieldPut( FieldPos( "KXMON" ), 0 ) ) KX21->( FieldPut( FieldPos( "KXEOS" ), 0 ) ) KX21->( FieldPut( FieldPos( "KXBAS" ), 0 ) ) KX21->( FieldPut( FieldPos( "KXRBC" ), n_rbc ) ) KX21->( FieldPut( FieldPos( "KXHGB" ), n_hgb ) ) KX21->( FieldPut( FieldPos( "KXHCT" ), n_hct ) ) KX21->( FieldPut( FieldPos( "KXMCV" ), n_mcv ) ) KX21->( FieldPut( FieldPos( "KXMCH" ), n_mch ) ) KX21->( FieldPut( FieldPos( "KXCHC" ), n_mchc ) ) KX21->( FieldPut( FieldPos( "KXRDW" ), n_rdwcv ) ) KX21->( FieldPut( FieldPos( "KXPLT" ), n_plt ) ) KX21->( FieldPut( FieldPos( "KXMPV" ), n_mpv ) ) KX21->( FieldPut( FieldPos( "KXPCT" ), 0 ) ) && Plaquetócrito, calculado pelo Celldyn. KX21->( FieldPut( FieldPos( "KXPDW" ), n_pdw ) ) KX21->( FieldPut( FieldPos( "KXPBLA" ), 0 ) ) && contagem. KX21->( FieldPut( FieldPos( "KXPPRM" ), 0 ) ) && contagem. KX21->( FieldPut( FieldPos( "KXPMIE" ), 0 ) ) && contagem. KX21->( FieldPut( FieldPos( "KXPMTM" ), 0 ) ) && contagem. KX21->( FieldPut( FieldPos( "KXPBST" ), 0 ) ) && contagem. KX21->( FieldPut( FieldPos( "KXPNEU" ), n_neut1 ) ) KX21->( FieldPut( FieldPos( "KXPLY1" ), n_lym1 ) ) KX21->( FieldPut( FieldPos( "KXPLY2" ), 0 ) ) KX21->( FieldPut( FieldPos( "KXPMON" ), 0 ) ) KX21->( FieldPut( FieldPos( "KXPEOS" ), 0 ) ) KX21->( FieldPut( FieldPos( "KXPBAS" ), 0 ) ) KX21->( FieldPut( FieldPos( "KXNEU" ), n_wbc*( n_neut1/100.00 ) ) ) KX21->( FieldPut( FieldPos( "KXlY1" ), n_wbc*( n_lym1/100.00 ) ) ) * KX21->( FieldPut( FieldPos( "KXFG1" ), "X" ) ) KX21->( FieldPut( FieldPos( "KXFG2" ), "X" ) ) KX21->( FieldPut( FieldPos( "KXFG3" ), "X" ) ) * KX21->( DBCommit() ) KX21->( DBUnlock() ) * RETURN(.T.) * * ************************************************************************************************* * * Função EnviaRes1() * Desenvolvida por: Ivo Fritz Hasse * Objetivo: Envia os Resultados de 1 paciente de cada vez para o Servidor * *------------------------------------------------------------------------------------------------ Function EnviaRes1() * c_mens := MENS('Enviando os resultados liberados.... ;; ' + ; 'Ficha: ; ' + ; 'Paciente: ; ' + ; 'Exame: ', ; 10,00,cor_6,01) * SET CURSOR ON l_kx21_con := Testa_drive(c_EndServ,"KX21N") && Testa conexão com o Servidor. IF ! l_kx21_con Alert('ConexÆo com o Servidor FALHOU') RETURN(.F.) ENDIF * SET CENTURY ON c_data := DTOSS( DATE() ) SET CENTURY OFF * SELE 21 IF ! Redopen(10,c_EndServ,"PACIENTE","paciente",.T.,"PACIENTE") RETURN(.F.) ENDIF OrdSetFocus( 1 ) * SELE 22 IF ! Redopen(10,c_EndServ,"PACIEXA","paciexa",.T.,"PACIEXA") RETURN(.F.) ENDIF OrdSetFocus( 1 ) * SELE 23 IF ! Redopen(10,c_EndServ,"EXARES","exares",.T.,"EXARES") RETURN(.F.) ENDIF * c_imp = KX21->KXIMP * c_cod = RIGHT(ALLTRIM(KX21->KXSID), 06 ) && Ficha, sem a área. * c_leu = "^"+STR(KX21->KXWBC,6,0) && Leucócitos. * c_per = "^"+STR(KX21->KXPBLA,5,1) + "^"+STR(KX21->KXPPRM,5,1) +; && percentuais "^"+STR(KX21->KXPMIE,5,1) + "^"+STR(KX21->KXPMTM,5,1) +; && de leucócitos. "^"+STR(KX21->KXPBST,5,1) + "^"+STR(KX21->KXPNEU,5,1) +; "^"+STR(KX21->KXPLY1,5,1) + "^"+STR(KX21->KXPLY2,5,1) +; "^"+STR(KX21->KXPMON,5,1) + "^"+STR(KX21->KXPEOS,5,1) +; "^"+STR(KX21->KXPBAS,5,1) * c_eri = "^"+STR(KX21->KXRBC,5,2) + "^"+STR(KX21->KXHGB,5,2) +; && Eritrograma. "^"+STR(KX21->KXHCT,5,2) + "^"+STR(KX21->KXMCV,5,1) +; "^"+STR(KX21->KXMCH,5,1) + "^"+STR(KX21->KXCHC,5,1) +; "^"+STR(KX21->KXRDW,5,1) * c_pla = "^"+STR(KX21->KXPLT,7,0) + "^"+STR(KX21->KXMPV,5,2) +; && Plaquetas, "^"+STR(KX21->KXPCT,5,2) + "^"+STR(KX21->KXPDW,5,2) && com PDW. * c_plq = "^"+STR(KX21->KXPLT,7,0) && só Plaquetas. * c_coa = "^"+STR(KX21->KXPLT,7,0) + "$ $ $ $ $ $ " && Plaquetas do Coágulograma. * c_co2 = "^"+STR(KX21->KXPLT,8,0) + "$ $ $ $ $ $ " && Plaquetas do Coágulograma 2. * c_mor8= "$"+KX21->KXMD1 + "$"+KX21->KXMD2 + "$"+KX21->KXMD3 +; && Morfologia, "$"+KX21->KXMD4 + "$"+KX21->KXMD5 + "$"+KX21->KXMD6 +; && com 7 linhas. "$"+KX21->KXMD7 * c_mor4= "$"+KX21->KXMD1 + "$"+KX21->KXMD2 + "$"+KX21->KXMD3 +; && Morfologia, "$"+KX21->KXMD4 && com 4 linhas. * c_obs = "$"+KX21->KXOD1 + "$"+KX21->KXOD2 && Observações, * && com 2 linhas. * SELE PACIENTE PACIENTE->( DBSeek( c_cod ) ) @ 10,26 SAY PACIENTE->P_COD @ 11,26 SAY PACIENTE->P_NOME * c_dat = PACIENTE->P_DATA c_exareq = ALLTRIM( PACIENTE->P_EXAFEIT ) n_ct = 0 c_cod = PACIENTE->P_COD && Assume o número com a * && respectiva área. SELE PACIEXA PACIEXA->( DBSeek( c_cod ) ) SELE EXARES * c_exames = " HEM LEU ERI PLQ COA CO2 " * DO WHILE n_ct <= LEN(c_exareq) / 3 * IF IsWorking( nHandle ) .AND. InBufSize( nHandle ) > 0 RecebeDados() DB0:RefreshAll() DB0:GoBottom() ENDIF * c_exa = SUBSTR(c_exarec,(n_ct*3)+1,3) @ 00,00 say "="+c_exa+"=" ? n_ct wait n_ct = n_ct + 1 *----------------------- Avalia se este exame já tem resultados no Servidor ---------- l_loop := .F. PACIEXA->( DBSeek( c_cod ) ) WHILE PACIEXA->PE_CODPACI == c_cod && .AND. c_exa == PACIEXA->PE_CODEXA IF ! PACIEXA->PE_CODEXA == c_exa PACIEXA->( DBSkip() ) LOOP ENDIF IF PACIEXA->PE_STATUS $ "RLI" && Se Registrado, Liberado ou Impresso. l_loop := .T. ALERT(" O exame '"+c_exa+"' j  tem resultados registrados no Servidor. ;;" +; "Transferˆncia destes dados cancelada.") PACIEXA->( DBSkip() ) ELSE EXIT ENDIF ENDDO IF l_loop PACIEXA->( DBSkip() ) LOOP ENDIF *------------------------------------------------------------------------------------- IF c_exa = "HEM" c_cont = c_leu + c_per + c_eri + c_pla + c_mor8 + "$" ELSEIF c_exa = "ERI" c_cont = c_eri + "$" ELSEIF c_exa = "LEU" c_cont = c_leu + c_per + c_plq + c_mor4 + "$" ELSEIF c_exa = "PLQ" c_cont = c_plq + "$" ELSEIF c_exa = "COA" c_cont = c_coa + "$" ELSEIF c_exa = "CO2" c_cont = c_co2 + "$" ELSE LOOP ENDIF * @ 12,26 SAY c_exa * DO WHILE .T. * IF LEN(c_cont) > 50 IF ! EXARES->( Adireg(10) ) Msg("Arquivo nÆo est  dispon¡vel...") ELSE EXARES->( DBCommit() ) EXARES->( DBUnlock() ) ENDIF IF EXARES->( Reglock(10) ) REPL Conteudo WITH SUBS(c_cont,1,50),; Cod WITH c_exa,; Codpac WITH c_cod,; Datareg WITH c_dat,; Dataexa WITH DDTOSS(c_data) EXARES->( DBCommit() ) EXARES->( DBUnlock() ) ELSE Msg("Arquivo nÆo est  dispon¡vel...") ENDIF c_cont = SUBS(c_cont,51) EXARES->( DBSkip() ) ELSE IF ! EXARES->( Adireg(10) ) Msg("Arquivo nÆo est  dispon¡vel...",3) ELSE EXARES->( DBCommit() ) EXARES->( DBUnlock() ) ENDIF IF EXARES->( Reglock(10) ) REPL Conteudo WITH c_cont,; Cod WITH c_exa,; Codpac WITH c_cod,; Datareg WITH c_dat,; Dataexa WITH DDTOSS(c_data) EXARES->( DBCommit() ) EXARES->( DBUnlock() ) ELSE Msg("Arquivo nÆo est  dispon¡vel...",3) ENDIF EXIT ENDIF ENDDO * SELE PACIEXA SEEK c_cod DO WHILE c_exa <> PACIEXA->PE_CODEXA .AND. ! EOF() SKIP ENDDO PACIEXA->( Reglock(10) ) IF c_imp = "I" && Já foi impresso via Kx21.exe REPLACE PE_STATUS WITH "I" ELSE REPLACE PE_LIBER WITH KX21->KXLIB IF EMPTY( PE_LIBER ) REPLACE PE_STATUS WITH "R" ELSE REPLACE PE_STATUS WITH "L" ENDIF ENDIF REPLACE PE_TRANS WITH "T" PACIEXA->( DBCommit() ) PACIEXA->( DBUnlock() ) * KX21->( RegLock(10) ) KX21->( FieldPut( FieldPos( "KXDTT" ) , DTODD( Date() ) ) ) KX21->( DBCommit() ) KX21->( DBUnlock() ) * SELE EXARES * INKEY(0.2) && "freio" da rotina * ENDDO * SELE PACIENTE USE SELE PACIEXA USE SELE EXARES USE SELE KX21 * * INKEY(0.2) * RETURN(nil)