/* * Copyright (c) 1995, 1996 Gunther Schadow. All rights reserved. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ % Clauses which clean up the HL-7 database. % % main entry point is cleanup/0 % :- module(db_clean,[cleanup/0]). :- style_check(+string). :- use_module(db-check,[removeNoKey/0,undefdSeg/1,retractNotify/1]). :- use_module(db-inter,[nil/1,nonnil/1,unimesg/3,unidesc/3]). val_number_stack(999999). new_val_number(Vn) :- val_number_stack(Vn), NVn is Vn - 1, retract(val_number_stack(Vn)), assert(val_number_stack(NVn)). uniq(A, P, C) :- findall(A, P, D), sort(D, C). deligate_type(tm). deligate_type(dt). deligate_type(ts). deligate_type(st). deligate_type(id). deligate_type(nm). deligate_type(si). deligate_type(pn). deligate_type(cq). deligate_type(zm). deligate_table(3,9996). deligate_table(76,9995). deligate_table(125,9998). cleanup :- use_module(rhl7), removeNoKey, fixAbstractSyntax, fix2_2, fixRepOpt, tell(hl7), uniq(F, rdb:functional_area(F,_,_), FaS), forall(member(F, FaS), ( rdb:functional_area(F, Chp, Des), writef("%t.\n", [functional_area(F, Chp, Des)]) )), nl, undefdSeg(UDSMs), forall(member([[M,E,_],_],UDSMs), ( message(M,E,C,D,B) -> retractNotify(rdb:message(M,E,C,D,B)) ; true )), /* DATA TYPE DEFINITIONS * * Undo some of the brain-dead CM types that simply extend * other composites or introduce anonymous types. */ /* 1. A composite data_type for the Message ID field in the MSH */ assert(rdb:data_type(zm, "message id and event code", '')), /* 2. A composite data_type for the Patient Location in * PV1: 3, 6, 11, 42, 43 * PV2: 1 * NPU: 1 */ assert(rdb:data_type(zl, "patient location", '')), /* 3. A composite data_type for the error specification * ERR: 1 */ assert(rdb:data_type(ze, "error code and location", '')), /* This statement activates the new types in the given fields. * It can be used to change other field types. */ forall(member([Seg, Nr, Typ], [ [msh, 9, zm], % the new ZM typ [pid,3,ck], % why has CK changed back to CM :-( [mrg,1,ck], % dito. [pv1,37,ck], % why do we have a CK type? [pv1,19,ck], % by recommendation of HL7 v2.2 Page 3-31 [pv1,3,zl], % the new ZL type [pv1,6,zl], [pv1,11,zl], [pv1,42,zl], [pv1,43,zl], [pv2,1,zl], [npu,1,zl], [err, 1, ze] % finally the ZE (error) type ]), ( rdb:field(F1, F2, Seg, Nr, F5, F6, _, F8, F9, F10, F11), retractall(rdb:field(_, _, Seg, Nr, _, _, _, _, _, _, _)), assert(rdb:field(F1, F2, Seg, Nr, F5, F6, Typ, F8, F9, F10, F11)) )), % generate message_type/3 uniq(Mt, rdb:message(Mt,_,_,_,_), MtL), forall(member(Mt, MtL), ( rdb:message(Mt,_,Ch,Ds,_), ( rdb:value(_,76,_,Mt,D,_) -> ( ( functional_area(Fa,Ch,_); Fa = '' ), writef("%t.\n", [message_type(Mt,D,Fa)]) ); ( ( functional_area(Fa,Ch,_); Fa = '' ), writef("%t.\n", [message_type(Mt,Ds,Fa)]), new_val_number(Vn), assert(rdb:value(Vn,76,'',Mt,Ds,'')) ) ) )), uniq([M,E], rdb:message(M,E,_,_,_), MsgL), forall(member([M,E], MsgL), ( rdb:message(M,E,_, Des, Def), ( E \= '' -> ( rdb:value(_,3,_,E,Des1,_), writef("%t.\n", [message(M, E, Des1, Def)]) ) ; writef("%t.\n", [message(M, E, Des, Def)]) ) )), nl, uniq(S, rdb:segment(S,_,_), SgL), forall(member(S, SgL), ( rdb:segment(S, Des, Ch), ( functional_area(Fa,Ch,_); Fa = '' ), writef("%t.\n", [segment(S, Des, Fa)]) )), nl, forall(rdb:field(De,Ds,S,F,_,L,Dt,Ro,Rp,Tb1,_), ( ( deligate_table(Tb1,Tb) -> true ; Tb = Tb1 ), portray_clause((field(S,F,Ds,Dt,Tb,Ro,Rp,L,De) :- true) ))), nl, forall((rdb:data_type(Id, Des, Len), \+deligate_type(Id)), writef("%t.\n", [data_type(Id, Des, Len)])), nl, forall( ( rdb:table(Id, Des, Cl), \+deligate_table(Id,_) ), ( rdb:value(_,Id,_,_,_,_) -> writef("%t.\n", [table(Id, Des, Cl)]) ; true )), nl, forall((rdb:value(Vn, Tb, _, Id, Des, _), \+deligate_table(Tb,_)), writef("%t.\n", [value(Tb, Id, Des, Vn)])), nl, told. special_segment(msh). special_segment(fhs). special_segment(bhs). fixAbstractSyntax :- /* * Eliminate encoding rules related stuff from the definitions */ forall((special_segment(Seg), member(Fld, [1,2]), rdb:field(De,Ds,Seg,Fld,_,Len,Dt,Ro,Rp,Tb,Dsd)), retract(rdb:field(De,Ds,Seg,Fld,_,Len,Dt,Ro,Rp,Tb,Dsd))). fix2_2 :- /* * Correct the names of acknowledgements: make them uniqe. */ retractall(rdb:message(ack, _, _, _, _)), assert(rdb:message(ack, '', 2, "general acknowledgement", [msh,msa,opt(err)])), retractall(rdb:message(mcf, _, _, _, _)), assert(rdb:message(mcf, '', 2, "deferred acknowledgement", [msh,msa,opt(err)])), /* * DSR and QRY messages are defined more than once. Erase all of then * which do not have an event code. */ retractall(rdb:message(dsr,'',_,_,_)), retractall(rdb:message(qry,'',_,_,_)), /* * The Order Entry chapter is pure horror! There are as much as six * different orders with different syntax/semantics overloaded onto * one single message (ORM) and no event code, which would discriminate * them! The ORR message takes the miserable situation times 2!!! * * - Fix an ORM message that was screwed up due to a missing closing * bracket. * - Complete the any(...) term. */ retractall(rdb:message(orm, _, _, _, _)), retractall(rdb:message(orr, _, _, _, _)), assert(rdb:message(orm,'', 4, "general order message", [msh, opt(rep(nte)), opt(pid, opt(rep(nte)), opt(rep(al1)), opt(pv1)), rep(orc, opt(opt(rep(any(obr,ods,odt,rqd,rxo))), opt(rq1)), opt(rep(nte)), opt(rep(rxr), opt(rep(rxc)), opt(rep(nte))), opt(rep(obx, opt(rep(nte)))), opt(blg))])), assert(rdb:message(orr, '', 4, "general order acknowledgement message", [msh, opt(rep(nte)), opt(pid, opt(rep(nte)), opt(rep(al1)), opt(pv1)), rep(orc, opt(opt(rep(any(obr,ods,odt,rqd,rxo))), opt(rq1)), opt(rep(nte)), opt(rep(rxr), opt(rep(rxc)), opt(rep(nte))))])), /* * Fix some ambiguity in the ORU message. NOTE that the ambiguity caused * by the outermost repeating group is not fixed! */ retractall(rdb:message(oru, _, _, _, _)), assert(rdb:message(oru,'',7,"observational results (unsolicited)", [msh, rep(opt(pid, opt(rep(nte)), opt(pv1)), rep(opt(orc), obr, rep(opt(nte)), opt(rep(obx, opt(rep(nte)))))), opt(dsc)])), /* * Fix the MFN and MFK messages: */ retractall(rdb:message(mfn, _, _, _, _)), assert(rdb:message(mfn, '', 8, "master file notification", [msh, mfi, rep(mfe, opt(rep(any(stf, pra /*, Z.. */))))])), retractall(rdb:message(mfk, _, _, _, _)), assert(rdb:message(mfk, '', 8, "master file acknowledgement", [msh, msa, opt(err), mfi, rep(opt(mfa))])), retractall(rdb:message(mfr, _, _, _, _)), assert(rdb:message(mfr, '', 8, "master file response", [msh, msa, qrd, opt(qrf), mfi, rep(mfe, opt(rep(any(stf, pra /*, Z.. */)))), opt(dsc)])), /* * Of course, MSA message instead of ACK message is a typo (chp8) */ retractall(rdb:message(msa, _, _, _, _)). /* * The production `rep(opt(X))' is an infinite recursion since it * yields (X.(X.(X.(nil.(nil.(nil.(...))))))). Thus we will change * all of those productions to `opt(rep(X))'. However, the production * rep(opt(X1), opt(X2), opt(X3), ... , opt(Xn)) yields the same * recursion and we can't do anything about it here. The parser has * to manage this problem. */ fixRepOpt :- forall(message(M, E, Ch, C, DefL), ( fixRepOpt(DefL, DefLn), retractall(rdb:message(M, E, Ch, C, DefL)), assert(fixed_message(M, E, Ch, C, DefLn)) )), forall(fixed_message(M, E, Ch, C, D), ( retractall(fixed_message(M, E, Ch, C, D)), assert(rdb:message(M, E, Ch, C, D)) )). fixRepOpt([],[]). fixRepOpt([H|T],[Hn|Tn]) :- fixRepOpt1(H, Hn), fixRepOpt(T, Tn). fixRepOpt1(rep(opt(X)), opt(rep(X))). fixRepOpt1(X, Xn) :- X =.. [F|A], fixRepOpt(A, An), Xn =.. [F|An].