| [623] | 1 | HLOSRVR ;ALB/CJM- Server for receiving messages - 10/4/94 1pm ;03/22/2007
|
|---|
| 2 | ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134**;Oct 13, 1995;Build 30
|
|---|
| 3 | ;Per VHA Directive 2004-038, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | GETWORK(WORK) ;
|
|---|
| 6 | ;GET WORK function for a single server or a Taskman multi-server
|
|---|
| 7 | N LINK
|
|---|
| 8 | I '$$CHKSTOP^HLOPROC,$G(WORK("LINK"))]"",$$GETLINK^HLOTLNK(WORK("LINK"),.LINK),+LINK("SERVER") S WORK("PORT")=LINK("PORT") Q 1
|
|---|
| 9 | Q 0
|
|---|
| 10 | ;
|
|---|
| 11 | DOWORKS(WORK) ;
|
|---|
| 12 | ;DO WORK rtn for a single server (non-concurrent)
|
|---|
| 13 | D SERVER(WORK("LINK"))
|
|---|
| 14 | Q
|
|---|
| 15 | DOWORKM(WORK) ;
|
|---|
| 16 | ;DO WORK rtn for a Taskman multi-server (Cache systems only)
|
|---|
| 17 | D LISTEN^%ZISTCPS(WORK("PORT"),"SERVER^HLOSRVR("""_WORK("LINK")_""")")
|
|---|
| 18 | Q
|
|---|
| 19 | ;
|
|---|
| 20 | VMS2(LINKNAME) ;called from a VMS TCP Service once a connection request has been received. This entry point should be used only if an additional VMS TCPIP Services are being created for HLO.
|
|---|
| 21 | ;Input:
|
|---|
| 22 | ; LINKNAME - only pass it in if an additional service is being created on a different port
|
|---|
| 23 | Q:'$L(LINKNAME)
|
|---|
| 24 | D VMS
|
|---|
| 25 | Q
|
|---|
| 26 | ;
|
|---|
| 27 | VMS ;Called from VMS TCP Service once a connection request has been received. This entry point should be used only by the standard HLO service that runs on the standard HLO port.
|
|---|
| 28 | Q:$$CHKSTOP^HLOPROC
|
|---|
| 29 | D
|
|---|
| 30 | .Q:$L($G(LINKNAME))
|
|---|
| 31 | .;
|
|---|
| 32 | .N PROC,NODE
|
|---|
| 33 | .S PROC=$O(^HLD(779.3,"B","VMS TCP LISTENER",0))
|
|---|
| 34 | .I PROC S LINKNAME=$P($G(^HLD(779.3,PROC,0)),"^",14) Q:$L(LINKNAME)
|
|---|
| 35 | .S NODE=$G(^HLD(779.1,1,0)) I $P(NODE,"^",10) S LINKNAME=$P($G(^HLCS(870,$P(NODE,"^",10),0)),"^") Q:$L(LINKNAME)
|
|---|
| 36 | .S LINKNAME="HLO DEFAULT LISTENER"
|
|---|
| 37 | ;
|
|---|
| 38 | D SERVER(LINKNAME,"SYS$NET")
|
|---|
| 39 | Q
|
|---|
| 40 | ;
|
|---|
| 41 | SERVER(LINKNAME,LOGICAL) ; LINKNAME identifies the logical link, which describes the communication channel to be used
|
|---|
| 42 | N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOSRVR1"
|
|---|
| 43 | N HLCSTATE,INQUE
|
|---|
| 44 | S INQUE=0
|
|---|
| 45 | Q:'$$CONNECT(.HLCSTATE,LINKNAME,.LOGICAL)
|
|---|
| 46 | K LINKNAME
|
|---|
| 47 | F Q:'HLCSTATE("CONNECTED") D Q:$$CHKSTOP^HLOPROC
|
|---|
| 48 | .N HLMSTATE,SENT
|
|---|
| 49 | .;
|
|---|
| 50 | .;read msg and parse the hdr
|
|---|
| 51 | .;HLMSTATE("MSA",1) is set with type of ack to return
|
|---|
| 52 | .I $$READMSG^HLOSRVR1(.HLCSTATE,.HLMSTATE) D
|
|---|
| 53 | ..;
|
|---|
| 54 | ..;send an ack if required and save the MSA segment
|
|---|
| 55 | ..I (HLMSTATE("MSA",1)]"") S SENT=$$WRITEACK(.HLCSTATE,.HLMSTATE) D:HLMSTATE("IEN") SAVEACK(.HLMSTATE,SENT)
|
|---|
| 56 | ..D:HLMSTATE("IEN") UPDATE(.HLMSTATE,.HLCSTATE)
|
|---|
| 57 | ..D:HLCSTATE("COUNTS")>4 SAVECNTS^HLOSTAT(.HLCSTATE)
|
|---|
| 58 | .E D INQUE() H:HLCSTATE("CONNECTED") 1
|
|---|
| 59 | ;
|
|---|
| 60 | END D CLOSE^HLOT(.HLCSTATE)
|
|---|
| 61 | D INQUE()
|
|---|
| 62 | D SAVECNTS^HLOSTAT(.HLCSTATE)
|
|---|
| 63 | Q
|
|---|
| 64 | ;
|
|---|
| 65 | CONNECT(HLCSTATE,LINKNAME,LOGICAL) ;
|
|---|
| 66 | ;sets up HLCSTATE() and opens a server connection
|
|---|
| 67 | ;
|
|---|
| 68 | N LINK,NODE
|
|---|
| 69 | S HLCSTATE("CONNECTED")=0
|
|---|
| 70 | Q:'$$GETLINK^HLOTLNK(LINKNAME,.LINK) 0
|
|---|
| 71 | Q:+LINK("SERVER")'=1 0
|
|---|
| 72 | S HLCSTATE("SERVER")=LINK("SERVER")
|
|---|
| 73 | M HLCSTATE("LINK")=LINK
|
|---|
| 74 | S HLCSTATE("READ TIMEOUT")=20
|
|---|
| 75 | S HLCSTATE("OPEN TIMEOUT")=30
|
|---|
| 76 | S HLCSTATE("READ")="" ;buffer for reads
|
|---|
| 77 | ;
|
|---|
| 78 | ;HLCSTATE("BUFFER",<seg>,<line>) write buffer
|
|---|
| 79 | S HLCSTATE("BUFFER","BYTE COUNT")=0 ;count of bytes in buffer
|
|---|
| 80 | S HLCSTATE("BUFFER","SEGMENT COUNT")=0 ;count of segments in buffer
|
|---|
| 81 | ;
|
|---|
| 82 | S HLCSTATE("COUNTS")=0
|
|---|
| 83 | S HLCSTATE("MESSAGE ENDED")=0 ;end of message flag
|
|---|
| 84 | S NODE=^%ZOSF("OS")
|
|---|
| 85 | S HLCSTATE("SYSTEM","OS")=$S(NODE["DSM":"DSM",NODE["OpenM":"CACHE",NODE["G.TM":"G.TM",1:"")
|
|---|
| 86 | Q:HLCSTATE("SYSTEM","OS")="" 0
|
|---|
| 87 | D ;get necessary system parameters
|
|---|
| 88 | .N SYS,SUB
|
|---|
| 89 | .D SYSPARMS^HLOSITE(.SYS)
|
|---|
| 90 | .F SUB="MAXSTRING","DOMAIN","STATION","PROCESSING ID","NORMAL PURGE","ERROR PURGE" S HLCSTATE("SYSTEM",SUB)=SYS(SUB)
|
|---|
| 91 | .S HLCSTATE("SYSTEM","BUFFER")=SYS("HL7 BUFFER")
|
|---|
| 92 | I HLCSTATE("LINK","LLP")="TCP" D
|
|---|
| 93 | .D OPEN^HLOTCP(.HLCSTATE,.LOGICAL)
|
|---|
| 94 | E ;no other LLP implemented
|
|---|
| 95 | ;
|
|---|
| 96 | Q HLCSTATE("CONNECTED")
|
|---|
| 97 | ;
|
|---|
| 98 | INQUE(MSGIEN,PARMS) ;
|
|---|
| 99 | ;puts received messages on the incoming queue and sets the B x-refs
|
|---|
| 100 | I $G(MSGIEN) S INQUE=INQUE+1 M INQUE(MSGIEN)=PARMS
|
|---|
| 101 | I ('$G(MSGIEN))!(INQUE>20) S MSGIEN=0 D
|
|---|
| 102 | .F S MSGIEN=$O(INQUE(MSGIEN)) Q:'MSGIEN D
|
|---|
| 103 | ..S ^HLB("B",INQUE(MSGIEN,"MSGID"),MSGIEN)=""
|
|---|
| 104 | ..S ^HLA("B",INQUE(MSGIEN,"DT/TM"),INQUE(MSGIEN,"BODY"))=""
|
|---|
| 105 | ..D:INQUE(MSGIEN,"PASS")
|
|---|
| 106 | ...N PURGE
|
|---|
| 107 | ...S PURGE=+$G(INQUE(MSGIEN,"PURGE"))
|
|---|
| 108 | ...S PURGE("ACKTOIEN")=$G(INQUE(MSGIEN,"ACKTOIEN"))
|
|---|
| 109 | ...D INQUE^HLOQUE(INQUE(MSGIEN,"FROM"),INQUE(MSGIEN,"QUEUE"),MSGIEN,INQUE(MSGIEN,"ACTION"),.PURGE)
|
|---|
| 110 | .K INQUE S INQUE=0
|
|---|
| 111 | Q
|
|---|
| 112 | ;
|
|---|
| 113 | SAVEACK(HLMSTATE,SENT) ;
|
|---|
| 114 | ;Input:
|
|---|
| 115 | ; SENT - flag = 1 if transmission of ack succeeded, 0 otherwise
|
|---|
| 116 | ;
|
|---|
| 117 | N NODE,I
|
|---|
| 118 | S $P(NODE,"^")=HLMSTATE("MSA","DT/TM OF MESSAGE")
|
|---|
| 119 | S $P(NODE,"^",2)=HLMSTATE("MSA","MESSAGE CONTROL ID")
|
|---|
| 120 | S $P(NODE,"^",3)="MSA"
|
|---|
| 121 | F I=1:1:3 S NODE=NODE_"|"_$G(HLMSTATE("MSA",I))
|
|---|
| 122 | S ^HLB(HLMSTATE("IEN"),4)=NODE
|
|---|
| 123 | S:SENT $P(^HLB(HLMSTATE("IEN"),0),"^",$S($E(HLMSTATE("MSA",1))="A":18,1:17))=1
|
|---|
| 124 | Q
|
|---|
| 125 | ;
|
|---|
| 126 | UPDATE(HLMSTATE,HLCSTATE) ;
|
|---|
| 127 | ;Updates status and purge date when appropriate
|
|---|
| 128 | ;Also, sets the "B" xrefs, files 777,778, and places message on the incoming queue
|
|---|
| 129 | ;
|
|---|
| 130 | N PARMS,PURGE,WAIT
|
|---|
| 131 | S PARMS("PASS")=0
|
|---|
| 132 | I HLMSTATE("STATUS","ACTION")]"",HLMSTATE("STATUS")'="SE" D
|
|---|
| 133 | .N IEN
|
|---|
| 134 | .S IEN=HLMSTATE("IEN")
|
|---|
| 135 | .S PARMS("PASS")=1,$P(^HLB(IEN,0),"^",6)=HLMSTATE("STATUS","QUEUE"),$P(^HLB(IEN,0),"^",10)=$P(HLMSTATE("STATUS","ACTION"),"^"),$P(^HLB(IEN,0),"^",11)=$P(HLMSTATE("STATUS","ACTION"),"^",2)
|
|---|
| 136 | D:'PARMS("PASS") ;if not passing to the app, set the purge date
|
|---|
| 137 | .I HLMSTATE("STATUS")="" S HLMSTATE("STATUS")="SU"
|
|---|
| 138 | .S:HLMSTATE("BATCH") WAIT=HLCSTATE("SYSTEM","ERROR PURGE")
|
|---|
| 139 | .S:'HLMSTATE("BATCH") WAIT=$S(($G(HLMSTATE("ACK TO","STATUS"))="AE"):24*HLCSTATE("SYSTEM","ERROR PURGE"),HLMSTATE("STATUS")="SE":24*HLCSTATE("SYSTEM","ERROR PURGE"),1:HLCSTATE("SYSTEM","NORMAL PURGE"))
|
|---|
| 140 | .S PURGE=$$FMADD^XLFDT($$NOW^XLFDT,,WAIT)
|
|---|
| 141 | .S $P(^HLB(HLMSTATE("IEN"),0),"^",9)=PURGE
|
|---|
| 142 | .S ^HLB("AD","IN",PURGE,HLMSTATE("IEN"))=""
|
|---|
| 143 | .;if this is an app ack, purge the original message at the same time
|
|---|
| 144 | .I $G(HLMSTATE("ACK TO","IEN")),'HLMSTATE("BATCH") D
|
|---|
| 145 | ..S $P(^HLB(+HLMSTATE("ACK TO","IEN"),0),"^",9)=PURGE
|
|---|
| 146 | ..S ^HLB("AD","IN",PURGE,+HLMSTATE("ACK TO","IEN"))=""
|
|---|
| 147 | ;
|
|---|
| 148 | ;if not waiting for an application ack, set the status now even if passing to the app - but don't set the purge until the infiler passes the message
|
|---|
| 149 | I HLMSTATE("STATUS")="",($G(HLMSTATE("ACK TO","IEN"))!HLMSTATE("HDR","APP ACK TYPE")'="AL") S HLMSTATE("STATUS")="SU"
|
|---|
| 150 | I HLMSTATE("STATUS")'="" S $P(^HLB(HLMSTATE("IEN"),0),"^",20)=HLMSTATE("STATUS") S:$G(HLMSTATE("MSA",3))]"" $P(^HLB(HLMSTATE("IEN"),0),"^",21)=HLMSTATE("MSA",3) D:HLMSTATE("STATUS")="SE"
|
|---|
| 151 | .N APP
|
|---|
| 152 | .S APP=HLMSTATE("HDR","RECEIVING APPLICATION") S:APP="" APP="UNKNOWN" S ^HLB("ERRORS","SE",APP,HLMSTATE("DT/TM"),HLMSTATE("IEN"))=""
|
|---|
| 153 | .D COUNT^HLOESTAT("IN",$G(HLMSTATE("HDR","RECEIVING APPLICATION")),$G(HLMSTATE("HDR","SENDING APPLICATION")),$S(HLMSTATE("BATCH"):"BATCH",1:$G(HLMSTATE("HDR","MESSAGE TYPE"))),$G(HLMSTATE("HDR","EVENT")))
|
|---|
| 154 | ;
|
|---|
| 155 | ;set the necessary parms for passing the msg to the app via the infiler
|
|---|
| 156 | D:PARMS("PASS")
|
|---|
| 157 | .N I,FROM
|
|---|
| 158 | .S FROM=HLMSTATE("HDR","SENDING FACILITY",1)
|
|---|
| 159 | .I HLMSTATE("HDR","SENDING FACILITY",2)]"" S FROM=FROM_"~"_HLMSTATE("HDR","SENDING FACILITY",2)_"~"_HLMSTATE("HDR","SENDING FACILITY",3)
|
|---|
| 160 | .I FROM="" S FROM="UNKNOWN SENDING FACILITY"
|
|---|
| 161 | .S PARMS("FROM")=FROM,PARMS("QUEUE")=HLMSTATE("STATUS","QUEUE"),PARMS("ACTION")=HLMSTATE("STATUS","ACTION")
|
|---|
| 162 | .I HLMSTATE("STATUS")'="" S PARMS("PURGE")=$S(HLMSTATE("STATUS")'="SU":2,$G(HLMSTATE("ACK TO","STATUS"))="AE":2,1:1)
|
|---|
| 163 | .S:$G(HLMSTATE("ACK TO","IEN")) PARMS("ACKTOIEN")=HLMSTATE("ACK TO","IEN") ;to insure that the infiler will know to set the purge date at the same time as the initial message
|
|---|
| 164 | ;
|
|---|
| 165 | S PARMS("BODY")=HLMSTATE("BODY")
|
|---|
| 166 | S PARMS("DT/TM")=HLMSTATE("DT/TM")
|
|---|
| 167 | S PARMS("MSGID")=HLMSTATE("ID")
|
|---|
| 168 | D INQUE(HLMSTATE("IEN"),.PARMS)
|
|---|
| 169 | Q
|
|---|
| 170 | ;
|
|---|
| 171 | WRITEACK(HLCSTATE,HLMSTATE) ;
|
|---|
| 172 | ;Sends an accept ack
|
|---|
| 173 | ;
|
|---|
| 174 | ;Input:
|
|---|
| 175 | ; HLCSTATE (pass by reference) defines the communication channel
|
|---|
| 176 | ; HLMSTATE (pass by reference) the message being acked
|
|---|
| 177 | ; ("MSA",1) - value for MSA-1
|
|---|
| 178 | ; ("MSA",2) - value for MSA-2
|
|---|
| 179 | ; ("MSA",3) - value for MSA-3
|
|---|
| 180 | ; ("HDR") - parsed values for the message being ack'd
|
|---|
| 181 | ;Output:
|
|---|
| 182 | ; Function returns 1 if successful, 0 otherwise
|
|---|
| 183 | ; HLMSTATE("MSA","MESSAGE CONTROL ID") - the msg id of the ack
|
|---|
| 184 | ; HLMSTATE(,"MSA","DT/TM OF MESSAGE") - from the ack header
|
|---|
| 185 | ;
|
|---|
| 186 | N HDR,SUB,FS,CS,MSA,ACKID,TIME
|
|---|
| 187 | ;Hard-code the delimiters, the standard requires that the receiving system accept the delimiters listed in the header
|
|---|
| 188 | S FS="|"
|
|---|
| 189 | S CS="^"
|
|---|
| 190 | S TIME=$$NOW^XLFDT
|
|---|
| 191 | S HLMSTATE("MSA","DT/TM OF MESSAGE")=TIME
|
|---|
| 192 | S ACKID=HLCSTATE("SYSTEM","STATION")_" "_$$NEWIEN^HLOF778A("OUT")
|
|---|
| 193 | S HLMSTATE("MSA","MESSAGE CONTROL ID")=ACKID
|
|---|
| 194 | ;
|
|---|
| 195 | S HDR(1)="MSH"_FS_"^~\&"_FS_HLMSTATE("HDR","RECEIVING APPLICATION")_FS_HLCSTATE("SYSTEM","STATION")_CS_HLCSTATE("SYSTEM","DOMAIN")_CS_"DNS"_FS
|
|---|
| 196 | S HDR(1)=HDR(1)_HLMSTATE("HDR","SENDING APPLICATION")_FS_HLMSTATE("HDR","SENDING FACILITY",1)_CS_HLMSTATE("HDR","SENDING FACILITY",2)_CS_HLMSTATE("HDR","SENDING FACILITY",3)
|
|---|
| 197 | ;
|
|---|
| 198 | S HDR(2)=FS_$$HLDATE^HLFNC(TIME,"TS")_FS_FS_"ACK"_FS_ACKID_FS_HLMSTATE("HDR","PROCESSING ID")_FS_"2.4"_FS_FS_FS_"NE"_FS_"NE"
|
|---|
| 199 | ;
|
|---|
| 200 | S MSA(1)="MSA"_FS
|
|---|
| 201 | F SUB=1:1:3 S MSA(1)=MSA(1)_HLMSTATE("MSA",SUB)_FS
|
|---|
| 202 | I $$WRITEHDR^HLOT(.HLCSTATE,.HDR),$$WRITESEG^HLOT(.HLCSTATE,.MSA),$$ENDMSG^HLOT(.HLCSTATE) S HLCSTATE("COUNTS","ACKS")=$G(HLCSTATE("COUNTS","ACKS"))+1 Q 1
|
|---|
| 203 | S HLMSTATE("MSA","DT/TM OF MESSAGE")=""
|
|---|
| 204 | Q 0
|
|---|
