Here’s some code that we use.
#!/usr/bin/env tcl
proc socketcmd { listenport sock ip_addr port } {
echo [clock format [clock seconds]]: socket connected on $listenport
set pd $::portdata($listenport)
keylget pd USERID userid
keylget pd PASSWORD password
keylget pd URL url
keylget pd RCPT rcpt
fconfigure $sock -blocking 0 -translation binary
fileevent $sock readable [list iocmd $listenport $sock $ip_addr $port $userid $password $url $rcpt]
}
proc iocmd { listenport sock ip_addr port userid password url rcpt } {
set data “”
echo iocmd $listenport $sock $ip_addr $port $userid $password $url $rcpt
while { 1 } {
if { [eof $sock] } {
echo [clock format [clock seconds]]: socket closed
return [close $sock]
}
append data [read $sock]
#echo data = “{$data}”
if { [regexp {^.*x0b([^x0b]*)x1cx0d$} $data -> msg] } {
#echo msg = $msg
echo [clock format [clock seconds]]: received message from Cloverleaf on $listenport
set replymsg [postmsg $msg $url $userid $password $rcpt]
set data “”
puts -nonewline $sock “x0b$replymsgx1cx0d”
flush $sock
return
} else {
# incomplete msg
after 1000
}
}
close $sock
}
proc postmsg { msg url userid password rcpt } {
package require http
package require tls
package require hl7
::http::register https 443 ::tls::socket
::tls::init -tls1 1
set disp CONTINUE
set errdisp ERROR
# puts “Message:n[join [split $msg r] n]”
# puts “End of messagen”
set qry [::http::formatQuery USERID $userid PASSWORD $password MESSAGEDATA $msg]
set result [catch {::http::geturl $url -query $qry -timeout 50000} token]
echo http::geturl = $result
flush stdout
if { $result } {
return [myack $msg $token]
} else {
upvar #0 $token state
if { [::http::status $token] ne “ok” } {
# geturl returned success, but status is not ok.
# this usually happens when the web server closes the
# connection before responding.
return [myack $msg “http::status = [::http::status $token]”]
} elseif { [::http::ncode $token] / 100 != 2 } {
# unsuccessful HTTP response code
parray state
return [myack $msg “http::code = [::http::code $token]”]
} else {
set replymsg [::http::data $token]
echo replymsg = [split $replymsg n]
set replymsg “[join [lsearch -inline -all -exact -not [split $replymsg n] {}] r]r”
set hl7 [hl7::parse_msg $replymsg]
if { [hl7::get_field hl7 MSA.1] eq “AE” } {
if { [regexp {^Not logged in:} [hl7::get_field hl7 MSA.3]] } {
# retry on temporary failures
hl7::set_field hl7 MSA.1 “AR”
set replymsg [hl7::join_msg hl7]
echo ‘received temporary error; changed to AR’
echo sleeping for 30 seconds
after 30000
echo done sleeping
} else {
hl7::set_field hl7 MSA.1 “AA” ;# send AA to Cloverleaf
set replymsg [hl7::join_msg hl7]
send_mail $msg $hl7 $rcpt
}
} elseif { [hl7::get_field hl7 MSA.1] eq “AR” } {
if { [regexp {^Processing error prevented the completion of this request:} [hl7::get_field hl7 ERR.8]] } {
hl7::set_field hl7 MSA.1 “AA” ;# send AA to Cloverleaf
send_mail $msg $hl7 $rcpt
hl7::delete_seg hl7 ERR
set replymsg [hl7::join_msg hl7]
}
}
echo forwarding reply from child
return $replymsg
}
}
}
proc myack { msg errmsg } {
echo creating nak message: $errmsg
set mh [msgcreate $msg]
keylset args2 MODE run
keylset args2 MSGID $mh
keylset args2 CONTEXT sms_ib_data
set replymsg “”
foreach dispItem [eval “hl7Raw_ack_vmc $args2″] {
lassign $dispItem disp newmh
if { $disp eq “OVER” } {
set replymsg [msgget $newmh]
}
msgdestroy $newmh
}
#echo replymsg = $replymsg
set hl7 [hl7::parse_msg $replymsg]
hl7::set_field hl7 MSA.1 “AR”
hl7::set_field hl7 MSA.3 “proxy error: $errmsg”
echo sleeping for 30 seconds
after 30000
echo done sleeping
return [hl7::join_msg hl7]
}
proc send_mail { hl7msg hl7ack rcpt } {
package require mime
package require smtp
set hl7 [hl7::parse_msg $hl7msg]
set body “nPatient MRN: [hl7::get_field hl7 PID.3.1]”
append body “nPatient Name: [hl7::get_field hl7 PID.5]”
append body “nAdministration date: [hl7::get_field hl7 RXA.4]”
append body “nAdministered code: [hl7::get_field hl7 RXA.5]”
append body “nError message: [hl7::get_field hl7ack ERR.8]”
append body “nMessage ID: [hl7::get_field hl7 MSH.10]”
append body “nn[string map { r n } $hl7msg]”
#set body [string map { r n } $hl7]
#append body [string map { r n } [hl7::join_msg hl7ack]]
# rxa 4 admin date
# rxa 5 admin code
set textT [mime::initialize -canonical text/plain -string $body]
# create a multipart containing both, and a timestamp
set multiT [mime::initialize -canonical multipart/mixed
-parts [list $textT]]
# call Sendmail to deliver the message
#set rcpt “David_Barr@valleymed.org”
set rcpt2 [join $rcpt ” “]
set fp [open “|/usr/sbin/sendmail $rcpt2” w]
puts $fp “To: [join $rcpt ,]”
puts $fp “From: “VMC.QDX Integrator production mode.” ”
puts $fp “Subject: child profile error”
#Date: Wed, 02 Mar 2008 16:34:00 -0700
puts $fp [::mime::buildmessage $multiT]
close $fp
}
set HciConnName dummy
foreach { what port data } [read_file $HciRoot/scripts/child-proxy.cfg] {
socket -server “socketcmd $port” $port
set ::portdata($port) $data
}
vwait forever
.
