- HLOSRVR ;ALB/CJM- Server for receiving messages - 10/4/94 1pm
- ;;1.6;HEALTH LEVEL SEVEN;**126,130,131**;Oct 13, 1995;Build 10
- ;
- GETWORK(WORK) ;
- ;GET WORK function for a single server OR Taskman multi-server
- N LINK
- I '$$CHKSTOP^HLOPROC,$G(WORK("LINK"))]"",$$GETLINK^HLOTLNK(WORK("LINK"),.LINK),+LINK("SERVER") S WORK("PORT")=LINK("PORT") Q 1
- Q 0
- ;
- DOWORKS(WORK) ;
- ;DO WORK rtn for a single server (non-concurrent)
- D SERVER(WORK("LINK"))
- Q
- DOWORKM(WORK) ;
- ;DO WORK rtn for a Taskman multi-server (Cache systems only)
- D LISTEN^%ZISTCPS(WORK("PORT"),"SERVER^HLOSRVR("""_WORK("LINK")_""")")
- Q
- ;
- 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.
- ;Input:
- ; LINKNAME - only pass it in if an additional service is being created on a different port
- Q:'$L(LINKNAME)
- D VMS
- Q
- ;
- 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.
- Q:$$CHKSTOP^HLOPROC
- D
- .Q:$L($G(LINKNAME))
- .;
- .N PROC,NODE
- .S PROC=$O(^HLD(779.3,"B","VMS TCP LISTENER",0))
- .I PROC S LINKNAME=$P($G(^HLD(779.3,PROC,0)),"^",14) Q:$L(LINKNAME)
- .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)
- .S LINKNAME="HLO DEFAULT LISTENER"
- ;
- D SERVER(LINKNAME,"SYS$NET")
- Q
- ;
- SERVER(LINKNAME,LOGICAL) ; LINKNAME identifies the logical link, which describes the communication channel to be used
- N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOSRVR1"
- N HLCSTATE,INQUE
- S INQUE=0
- Q:'$$CONNECT(.HLCSTATE,LINKNAME,.LOGICAL)
- K LINKNAME
- F Q:'HLCSTATE("CONNECTED") D Q:$$CHKSTOP^HLOPROC
- .N HLMSTATE,SENT
- .;
- .;read msg and parse the hdr
- .;HLMSTATE("MSA",1) is set with type of ack to return
- .I $$READMSG^HLOSRVR1(.HLCSTATE,.HLMSTATE) D
- ..;
- ..;send an ack if required and save the MSA segment
- ..I (HLMSTATE("MSA",1)]"") S SENT=$$WRITEACK(.HLCSTATE,.HLMSTATE) D:HLMSTATE("IEN") SAVEACK(.HLMSTATE,SENT)
- ..D:HLMSTATE("IEN") UPDATE(.HLMSTATE,.HLCSTATE)
- ..D:HLCSTATE("COUNTS")>4 SAVECNTS^HLOSTAT(.HLCSTATE)
- .E D INQUE() H:HLCSTATE("CONNECTED") 1
- ;
- END D CLOSE^HLOT(.HLCSTATE)
- D INQUE()
- D SAVECNTS^HLOSTAT(.HLCSTATE)
- Q
- ;
- CONNECT(HLCSTATE,LINKNAME,LOGICAL) ;
- ;sets up HLCSTATE() and opens a server connection
- ;
- N LINK,NODE
- S HLCSTATE("CONNECTED")=0
- Q:'$$GETLINK^HLOTLNK(LINKNAME,.LINK) 0
- Q:+LINK("SERVER")'=1 0
- S HLCSTATE("SERVER")=LINK("SERVER")
- M HLCSTATE("LINK")=LINK
- S HLCSTATE("READ TIMEOUT")=20
- S HLCSTATE("OPEN TIMEOUT")=30
- S HLCSTATE("READ")="" ;buffer for reads
- ;
- ;HLCSTATE("BUFFER",<seg>,<line>) write buffer
- S HLCSTATE("BUFFER","BYTE COUNT")=0 ;count of bytes in buffer
- S HLCSTATE("BUFFER","SEGMENT COUNT")=0 ;count of segments in buffer
- ;
- S HLCSTATE("COUNTS")=0
- S HLCSTATE("MESSAGE ENDED")=0 ;end of message flag
- S NODE=^%ZOSF("OS")
- S HLCSTATE("SYSTEM","OS")=$S(NODE["DSM":"DSM",NODE["OpenM":"CACHE",NODE["G.TM":"G.TM",1:"")
- Q:HLCSTATE("SYSTEM","OS")="" 0
- D ;get necessary system parameters
- .N SYS,SUB
- .D SYSPARMS^HLOSITE(.SYS)
- .F SUB="MAXSTRING","DOMAIN","STATION","PROCESSING ID","NORMAL PURGE","ERROR PURGE" S HLCSTATE("SYSTEM",SUB)=SYS(SUB)
- .S HLCSTATE("SYSTEM","BUFFER")=SYS("HL7 BUFFER")
- I HLCSTATE("LINK","LLP")="TCP" D
- .D OPEN^HLOTCP(.HLCSTATE,.LOGICAL)
- E ;no other LLP implemented
- ;
- Q HLCSTATE("CONNECTED")
- ;
- INQUE(MSGIEN,PARMS) ;
- ;puts received messages on the incoming queue and sets the B x-refs
- I $G(MSGIEN) S INQUE=INQUE+1 M INQUE(MSGIEN)=PARMS
- I ('$G(MSGIEN))!(INQUE>20) S MSGIEN=0 D
- .F S MSGIEN=$O(INQUE(MSGIEN)) Q:'MSGIEN D
- ..S ^HLB("B",INQUE(MSGIEN,"MSGID"),MSGIEN)=""
- ..S ^HLA("B",INQUE(MSGIEN,"DT/TM"),INQUE(MSGIEN,"BODY"))=""
- ..D:INQUE(MSGIEN,"PASS")
- ...N PURGE
- ...S PURGE=+$G(INQUE(MSGIEN,"PURGE"))
- ...S PURGE("ACKTOIEN")=$G(INQUE(MSGIEN,"ACKTOIEN"))
- ...D INQUE^HLOQUE(INQUE(MSGIEN,"FROM"),INQUE(MSGIEN,"QUEUE"),MSGIEN,INQUE(MSGIEN,"ACTION"),.PURGE)
- .K INQUE S INQUE=0
- Q
- ;
- SAVEACK(HLMSTATE,SENT) ;
- ;Input:
- ; SENT - flag = 1 if transmission of ack succeeded, 0 otherwise
- ;
- N NODE,I
- S $P(NODE,"^")=HLMSTATE("MSA","DT/TM OF MESSAGE")
- S $P(NODE,"^",2)=HLMSTATE("MSA","MESSAGE CONTROL ID")
- S $P(NODE,"^",3)="MSA"
- F I=1:1:3 S NODE=NODE_"|"_$G(HLMSTATE("MSA",I))
- S ^HLB(HLMSTATE("IEN"),4)=NODE
- S:SENT $P(^HLB(HLMSTATE("IEN"),0),"^",$S($E(HLMSTATE("MSA",1))="A":18,1:17))=1
- Q
- ;
- UPDATE(HLMSTATE,HLCSTATE) ;
- ;Updates status and purge date when appropriate
- ;Also, sets the "B" xrefs, files 777,778, and places message on the incoming queue
- ;
- N PARMS,PURGE,WAIT
- S PARMS("PASS")=0
- I HLMSTATE("STATUS","ACTION")]"",HLMSTATE("STATUS")'="SE" S PARMS("PASS")=1,$P(^HLB(HLMSTATE("IEN"),0),"^",6)=HLMSTATE("STATUS","QUEUE")
- D:'PARMS("PASS") ;if not passing to the app, set the purge date
- .I HLMSTATE("STATUS")="" S HLMSTATE("STATUS")="SU"
- .S:HLMSTATE("BATCH") WAIT=HLCSTATE("SYSTEM","ERROR PURGE")
- .S:'HLMSTATE("BATCH") WAIT=$S(HLMSTATE("STATUS")="SE":24*HLCSTATE("SYSTEM","ERROR PURGE"),1:HLCSTATE("SYSTEM","NORMAL PURGE"))
- .S PURGE=$$FMADD^XLFDT($$NOW^XLFDT,,WAIT)
- .S $P(^HLB(HLMSTATE("IEN"),0),"^",9)=PURGE
- .S ^HLB("AD","IN",PURGE,HLMSTATE("IEN"))=""
- .;if this is an app ack, purge the original message at the same time
- .I $G(HLMSTATE("ACK TO","IEN")),'HLMSTATE("BATCH") D
- ..S $P(^HLB(+HLMSTATE("ACK TO","IEN"),0),"^",9)=PURGE
- ..S ^HLB("AD","IN",PURGE,+HLMSTATE("ACK TO","IEN"))=""
- ;
- ;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
- I HLMSTATE("STATUS")="",HLMSTATE("HDR","APP ACK TYPE")'="AL" S HLMSTATE("STATUS")="SU"
- 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"
- .N APP
- .S APP=HLMSTATE("HDR","RECEIVING APPLICATION") S:APP="" APP="UNKNOWN" S ^HLB("ERRORS","SE",APP,HLMSTATE("DT/TM"),HLMSTATE("IEN"))=""
- ;
- ;set the necessary parms for passing the msg to the app via the infiler
- D:PARMS("PASS")
- .N I,FROM
- .S FROM=HLMSTATE("HDR","SENDING FACILITY",1)
- .I HLMSTATE("HDR","SENDING FACILITY",2)]"" S FROM=FROM_"~"_HLMSTATE("HDR","SENDING FACILITY",2)_"~"_HLMSTATE("HDR","SENDING FACILITY",3)
- .I FROM="" S FROM="UNKNOWN SENDING FACILITY"
- .S PARMS("FROM")=FROM,PARMS("QUEUE")=HLMSTATE("STATUS","QUEUE"),PARMS("ACTION")=HLMSTATE("STATUS","ACTION")
- .I HLMSTATE("STATUS")'="" S PARMS("PURGE")=1
- .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
- ;
- S PARMS("BODY")=HLMSTATE("BODY")
- S PARMS("DT/TM")=HLMSTATE("DT/TM")
- S PARMS("MSGID")=HLMSTATE("ID")
- D INQUE(HLMSTATE("IEN"),.PARMS)
- Q
- ;
- WRITEACK(HLCSTATE,HLMSTATE) ;
- ;Sends an accept ack
- ;
- ;Input:
- ; HLCSTATE (pass by reference) defines the communication channel
- ; HLMSTATE (pass by reference) the message being acked
- ; ("MSA",1) - value for MSA-1
- ; ("MSA",2) - value for MSA-2
- ; ("MSA",3) - value for MSA-3
- ; ("HDR") - parsed values for the message being ack'd
- ;Output:
- ; Function returns 1 if successful, 0 otherwise
- ; HLMSTATE("MSA","MESSAGE CONTROL ID") - the msg id of the ack
- ; HLMSTATE(,"MSA","DT/TM OF MESSAGE") - from the ack header
- ;
- N HDR,SUB,FS,CS,MSA,ACKID,TIME
- ;Hard-code the delimiters, the standard requires that the receiving system accept the delimiters listed in the header
- S FS="|"
- S CS="^"
- S TIME=$$NOW^XLFDT
- S HLMSTATE("MSA","DT/TM OF MESSAGE")=TIME
- S ACKID=HLCSTATE("SYSTEM","STATION")_" "_$$NEWIEN^HLOF778A("OUT")
- S HLMSTATE("MSA","MESSAGE CONTROL ID")=ACKID
- ;
- S HDR(1)="MSH"_FS_"^~\&"_FS_HLMSTATE("HDR","RECEIVING APPLICATION")_FS_HLCSTATE("SYSTEM","STATION")_CS_HLCSTATE("SYSTEM","DOMAIN")_CS_"DNS"_FS
- 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)
- ;
- 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"
- ;
- S MSA(1)="MSA"_FS
- F SUB=1:1:3 S MSA(1)=MSA(1)_HLMSTATE("MSA",SUB)_FS
- I $$WRITEHDR^HLOT(.HLCSTATE,.HDR),$$WRITESEG^HLOT(.HLCSTATE,.MSA),$$ENDMSG^HLOT(.HLCSTATE) S HLCSTATE("COUNTS","ACKS")=$G(HLCSTATE("COUNTS","ACKS"))+1 Q 1
- S HLMSTATE("MSA","DT/TM OF MESSAGE")=""
- Q 0
- HLOSRVR ;ALB/CJM- Server for receiving messages - 10/4/94 1pm
- +1 ;;1.6;HEALTH LEVEL SEVEN;**126,130,131**;Oct 13, 1995;Build 10
- +2 ;
- GETWORK(WORK) ;
- +1 ;GET WORK function for a single server OR Taskman multi-server
- +2 NEW LINK
- +3 IF '$$CHKSTOP^HLOPROC
- IF $GET(WORK("LINK"))]""
- IF $$GETLINK^HLOTLNK(WORK("LINK"),.LINK)
- IF +LINK("SERVER")
- SET WORK("PORT")=LINK("PORT")
- QUIT 1
- +4 QUIT 0
- +5 ;
- DOWORKS(WORK) ;
- +1 ;DO WORK rtn for a single server (non-concurrent)
- +2 DO SERVER(WORK("LINK"))
- +3 QUIT
- DOWORKM(WORK) ;
- +1 ;DO WORK rtn for a Taskman multi-server (Cache systems only)
- +2 DO LISTEN^%ZISTCPS(WORK("PORT"),"SERVER^HLOSRVR("""_WORK("LINK")_""")")
- +3 QUIT
- +4 ;
- 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.
- +1 ;Input:
- +2 ; LINKNAME - only pass it in if an additional service is being created on a different port
- +3 IF '$LENGTH(LINKNAME)
- QUIT
- +4 DO VMS
- +5 QUIT
- +6 ;
- 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.
- +1 IF $$CHKSTOP^HLOPROC
- QUIT
- +2 Begin DoDot:1
- +3 IF $LENGTH($GET(LINKNAME))
- QUIT
- +4 ;
- +5 NEW PROC,NODE
- +6 SET PROC=$ORDER(^HLD(779.3,"B","VMS TCP LISTENER",0))
- +7 IF PROC
- SET LINKNAME=$PIECE($GET(^HLD(779.3,PROC,0)),"^",14)
- IF $LENGTH(LINKNAME)
- QUIT
- +8 SET NODE=$GET(^HLD(779.1,1,0))
- IF $PIECE(NODE,"^",10)
- SET LINKNAME=$PIECE($GET(^HLCS(870,$PIECE(NODE,"^",10),0)),"^")
- IF $LENGTH(LINKNAME)
- QUIT
- +9 SET LINKNAME="HLO DEFAULT LISTENER"
- End DoDot:1
- +10 ;
- +11 DO SERVER(LINKNAME,"SYS$NET")
- +12 QUIT
- +13 ;
- SERVER(LINKNAME,LOGICAL) ; LINKNAME identifies the logical link, which describes the communication channel to be used
- +1 NEW $ETRAP,$ESTACK
- SET $ETRAP="G ERROR^HLOSRVR1"
- +2 NEW HLCSTATE,INQUE
- +3 SET INQUE=0
- +4 IF '$$CONNECT(.HLCSTATE,LINKNAME,.LOGICAL)
- QUIT
- +5 KILL LINKNAME
- +6 FOR
- IF 'HLCSTATE("CONNECTED")
- QUIT
- Begin DoDot:1
- +7 NEW HLMSTATE,SENT
- +8 ;
- +9 ;read msg and parse the hdr
- +10 ;HLMSTATE("MSA",1) is set with type of ack to return
- +11 IF $$READMSG^HLOSRVR1(.HLCSTATE,.HLMSTATE)
- Begin DoDot:2
- +12 ;
- +13 ;send an ack if required and save the MSA segment
- +14 IF (HLMSTATE("MSA",1)]"")
- SET SENT=$$WRITEACK(.HLCSTATE,.HLMSTATE)
- IF HLMSTATE("IEN")
- DO SAVEACK(.HLMSTATE,SENT)
- +15 IF HLMSTATE("IEN")
- DO UPDATE(.HLMSTATE,.HLCSTATE)
- +16 IF HLCSTATE("COUNTS")>4
- DO SAVECNTS^HLOSTAT(.HLCSTATE)
- End DoDot:2
- +17 IF '$TEST
- DO INQUE()
- IF HLCSTATE("CONNECTED")
- HANG 1
- End DoDot:1
- IF $$CHKSTOP^HLOPROC
- QUIT
- +18 ;
- END DO CLOSE^HLOT(.HLCSTATE)
- +1 DO INQUE()
- +2 DO SAVECNTS^HLOSTAT(.HLCSTATE)
- +3 QUIT
- +4 ;
- CONNECT(HLCSTATE,LINKNAME,LOGICAL) ;
- +1 ;sets up HLCSTATE() and opens a server connection
- +2 ;
- +3 NEW LINK,NODE
- +4 SET HLCSTATE("CONNECTED")=0
- +5 IF '$$GETLINK^HLOTLNK(LINKNAME,.LINK)
- QUIT 0
- +6 IF +LINK("SERVER")'=1
- QUIT 0
- +7 SET HLCSTATE("SERVER")=LINK("SERVER")
- +8 MERGE HLCSTATE("LINK")=LINK
- +9 SET HLCSTATE("READ TIMEOUT")=20
- +10 SET HLCSTATE("OPEN TIMEOUT")=30
- +11 ;buffer for reads
- SET HLCSTATE("READ")=""
- +12 ;
- +13 ;HLCSTATE("BUFFER",<seg>,<line>) write buffer
- +14 ;count of bytes in buffer
- SET HLCSTATE("BUFFER","BYTE COUNT")=0
- +15 ;count of segments in buffer
- SET HLCSTATE("BUFFER","SEGMENT COUNT")=0
- +16 ;
- +17 SET HLCSTATE("COUNTS")=0
- +18 ;end of message flag
- SET HLCSTATE("MESSAGE ENDED")=0
- +19 SET NODE=^%ZOSF("OS")
- +20 SET HLCSTATE("SYSTEM","OS")=$SELECT(NODE["DSM":"DSM",NODE["OpenM":"CACHE",NODE["G.TM":"G.TM",1:"")
- +21 IF HLCSTATE("SYSTEM","OS")=""
- QUIT 0
- +22 ;get necessary system parameters
- Begin DoDot:1
- +23 NEW SYS,SUB
- +24 DO SYSPARMS^HLOSITE(.SYS)
- +25 FOR SUB="MAXSTRING","DOMAIN","STATION","PROCESSING ID","NORMAL PURGE","ERROR PURGE"
- SET HLCSTATE("SYSTEM",SUB)=SYS(SUB)
- +26 SET HLCSTATE("SYSTEM","BUFFER")=SYS("HL7 BUFFER")
- End DoDot:1
- +27 IF HLCSTATE("LINK","LLP")="TCP"
- Begin DoDot:1
- +28 DO OPEN^HLOTCP(.HLCSTATE,.LOGICAL)
- End DoDot:1
- +29 ;no other LLP implemented
- IF '$TEST
- +30 ;
- +31 QUIT HLCSTATE("CONNECTED")
- +32 ;
- INQUE(MSGIEN,PARMS) ;
- +1 ;puts received messages on the incoming queue and sets the B x-refs
- +2 IF $GET(MSGIEN)
- SET INQUE=INQUE+1
- MERGE INQUE(MSGIEN)=PARMS
- +3 IF ('$GET(MSGIEN))!(INQUE>20)
- SET MSGIEN=0
- Begin DoDot:1
- +4 FOR
- SET MSGIEN=$ORDER(INQUE(MSGIEN))
- IF 'MSGIEN
- QUIT
- Begin DoDot:2
- +5 SET ^HLB("B",INQUE(MSGIEN,"MSGID"),MSGIEN)=""
- +6 SET ^HLA("B",INQUE(MSGIEN,"DT/TM"),INQUE(MSGIEN,"BODY"))=""
- +7 IF INQUE(MSGIEN,"PASS")
- Begin DoDot:3
- +8 NEW PURGE
- +9 SET PURGE=+$GET(INQUE(MSGIEN,"PURGE"))
- +10 SET PURGE("ACKTOIEN")=$GET(INQUE(MSGIEN,"ACKTOIEN"))
- +11 DO INQUE^HLOQUE(INQUE(MSGIEN,"FROM"),INQUE(MSGIEN,"QUEUE"),MSGIEN,INQUE(MSGIEN,"ACTION"),.PURGE)
- End DoDot:3
- End DoDot:2
- +12 KILL INQUE
- SET INQUE=0
- End DoDot:1
- +13 QUIT
- +14 ;
- SAVEACK(HLMSTATE,SENT) ;
- +1 ;Input:
- +2 ; SENT - flag = 1 if transmission of ack succeeded, 0 otherwise
- +3 ;
- +4 NEW NODE,I
- +5 SET $PIECE(NODE,"^")=HLMSTATE("MSA","DT/TM OF MESSAGE")
- +6 SET $PIECE(NODE,"^",2)=HLMSTATE("MSA","MESSAGE CONTROL ID")
- +7 SET $PIECE(NODE,"^",3)="MSA"
- +8 FOR I=1:1:3
- SET NODE=NODE_"|"_$GET(HLMSTATE("MSA",I))
- +9 SET ^HLB(HLMSTATE("IEN"),4)=NODE
- +10 IF SENT
- SET $PIECE(^HLB(HLMSTATE("IEN"),0),"^",$SELECT($EXTRACT(HLMSTATE("MSA",1))="A":18,1:17))=1
- +11 QUIT
- +12 ;
- UPDATE(HLMSTATE,HLCSTATE) ;
- +1 ;Updates status and purge date when appropriate
- +2 ;Also, sets the "B" xrefs, files 777,778, and places message on the incoming queue
- +3 ;
- +4 NEW PARMS,PURGE,WAIT
- +5 SET PARMS("PASS")=0
- +6 IF HLMSTATE("STATUS","ACTION")]""
- IF HLMSTATE("STATUS")'="SE"
- SET PARMS("PASS")=1
- SET $PIECE(^HLB(HLMSTATE("IEN"),0),"^",6)=HLMSTATE("STATUS","QUEUE")
- +7 ;if not passing to the app, set the purge date
- IF 'PARMS("PASS")
- Begin DoDot:1
- +8 IF HLMSTATE("STATUS")=""
- SET HLMSTATE("STATUS")="SU"
- +9 IF HLMSTATE("BATCH")
- SET WAIT=HLCSTATE("SYSTEM","ERROR PURGE")
- +10 IF 'HLMSTATE("BATCH")
- SET WAIT=$SELECT(HLMSTATE("STATUS")="SE":24*HLCSTATE("SYSTEM","ERROR PURGE"),1:HLCSTATE("SYSTEM","NORMAL PURGE"))
- +11 SET PURGE=$$FMADD^XLFDT($$NOW^XLFDT,,WAIT)
- +12 SET $PIECE(^HLB(HLMSTATE("IEN"),0),"^",9)=PURGE
- +13 SET ^HLB("AD","IN",PURGE,HLMSTATE("IEN"))=""
- +14 ;if this is an app ack, purge the original message at the same time
- +15 IF $GET(HLMSTATE("ACK TO","IEN"))
- IF 'HLMSTATE("BATCH")
- Begin DoDot:2
- +16 SET $PIECE(^HLB(+HLMSTATE("ACK TO","IEN"),0),"^",9)=PURGE
- +17 SET ^HLB("AD","IN",PURGE,+HLMSTATE("ACK TO","IEN"))=""
- End DoDot:2
- End DoDot:1
- +18 ;
- +19 ;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
- +20 IF HLMSTATE("STATUS")=""
- IF HLMSTATE("HDR","APP ACK TYPE")'="AL"
- SET HLMSTATE("STATUS")="SU"
- +21 IF HLMSTATE("STATUS")'=""
- SET $PIECE(^HLB(HLMSTATE("IEN"),0),"^",20)=HLMSTATE("STATUS")
- IF $GET(HLMSTATE("MSA",3))]""
- SET $PIECE(^HLB(HLMSTATE("IEN"),0),"^",21)=HLMSTATE("MSA",3)
- IF HLMSTATE("STATUS")="SE"
- Begin DoDot:1
- +22 NEW APP
- +23 SET APP=HLMSTATE("HDR","RECEIVING APPLICATION")
- IF APP=""
- SET APP="UNKNOWN"
- SET ^HLB("ERRORS","SE",APP,HLMSTATE("DT/TM"),HLMSTATE("IEN"))=""
- End DoDot:1
- +24 ;
- +25 ;set the necessary parms for passing the msg to the app via the infiler
- +26 IF PARMS("PASS")
- Begin DoDot:1
- +27 NEW I,FROM
- +28 SET FROM=HLMSTATE("HDR","SENDING FACILITY",1)
- +29 IF HLMSTATE("HDR","SENDING FACILITY",2)]""
- SET FROM=FROM_"~"_HLMSTATE("HDR","SENDING FACILITY",2)_"~"_HLMSTATE("HDR","SENDING FACILITY",3)
- +30 IF FROM=""
- SET FROM="UNKNOWN SENDING FACILITY"
- +31 SET PARMS("FROM")=FROM
- SET PARMS("QUEUE")=HLMSTATE("STATUS","QUEUE")
- SET PARMS("ACTION")=HLMSTATE("STATUS","ACTION")
- +32 IF HLMSTATE("STATUS")'=""
- SET PARMS("PURGE")=1
- +33 ;to insure that the infiler will know to set the purge date at the same time as the initial message
- IF $GET(HLMSTATE("ACK TO","IEN"))
- SET PARMS("ACKTOIEN")=HLMSTATE("ACK TO","IEN")
- End DoDot:1
- +34 ;
- +35 SET PARMS("BODY")=HLMSTATE("BODY")
- +36 SET PARMS("DT/TM")=HLMSTATE("DT/TM")
- +37 SET PARMS("MSGID")=HLMSTATE("ID")
- +38 DO INQUE(HLMSTATE("IEN"),.PARMS)
- +39 QUIT
- +40 ;
- WRITEACK(HLCSTATE,HLMSTATE) ;
- +1 ;Sends an accept ack
- +2 ;
- +3 ;Input:
- +4 ; HLCSTATE (pass by reference) defines the communication channel
- +5 ; HLMSTATE (pass by reference) the message being acked
- +6 ; ("MSA",1) - value for MSA-1
- +7 ; ("MSA",2) - value for MSA-2
- +8 ; ("MSA",3) - value for MSA-3
- +9 ; ("HDR") - parsed values for the message being ack'd
- +10 ;Output:
- +11 ; Function returns 1 if successful, 0 otherwise
- +12 ; HLMSTATE("MSA","MESSAGE CONTROL ID") - the msg id of the ack
- +13 ; HLMSTATE(,"MSA","DT/TM OF MESSAGE") - from the ack header
- +14 ;
- +15 NEW HDR,SUB,FS,CS,MSA,ACKID,TIME
- +16 ;Hard-code the delimiters, the standard requires that the receiving system accept the delimiters listed in the header
- +17 SET FS="|"
- +18 SET CS="^"
- +19 SET TIME=$$NOW^XLFDT
- +20 SET HLMSTATE("MSA","DT/TM OF MESSAGE")=TIME
- +21 SET ACKID=HLCSTATE("SYSTEM","STATION")_" "_$$NEWIEN^HLOF778A("OUT")
- +22 SET HLMSTATE("MSA","MESSAGE CONTROL ID")=ACKID
- +23 ;
- +24 SET HDR(1)="MSH"_FS_"^~\&"_FS_HLMSTATE("HDR","RECEIVING APPLICATION")_FS_HLCSTATE("SYSTEM","STATION")_CS_HLCSTATE("SYSTEM","DOMAIN")_CS_"DNS"_FS
- +25 SET 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)
- +26 ;
- +27 SET 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"
- +28 ;
- +29 SET MSA(1)="MSA"_FS
- +30 FOR SUB=1:1:3
- SET MSA(1)=MSA(1)_HLMSTATE("MSA",SUB)_FS
- +31 IF $$WRITEHDR^HLOT(.HLCSTATE,.HDR)
- IF $$WRITESEG^HLOT(.HLCSTATE,.MSA)
- IF $$ENDMSG^HLOT(.HLCSTATE)
- SET HLCSTATE("COUNTS","ACKS")=$GET(HLCSTATE("COUNTS","ACKS"))+1
- QUIT 1
- +32 SET HLMSTATE("MSA","DT/TM OF MESSAGE")=""
- +33 QUIT 0