HLOAPP ;ALB/CJM-HL7 -Application Registry ;02/23/2012
;;1.6;HEALTH LEVEL SEVEN;**126,132,137,139,158**;Oct 13, 1995;Build 14
;Per VHA Directive 2004-038, this routine should not be modified.
;
GETIEN(NAME) ;given the application name, it finds the ien. Returns 0 on failure
Q:'$L($G(NAME)) 0
Q +$O(^HLD(779.2,"C",$E(NAME,1,60),0))
;
ACTION(HEADER,ACTION,QUEUE) ;Given the parsed header of a message it returns both the action that should be performed in response to the message and the incoming queue that it should be placed on.
;
;** do not implement the Pass Immediate parameter **
;ACTION(HEADER,ACTION,QUEUE,IMMEDIATE);Given the parsed header of a message it returns both the action that should be performed in response to the message and the incoming queue that it should be placed on.
;
;Input:
; HEADER() subscripts are used: "RECEIVING APPLICATION","SEGMENT TYPE", "MESSAGE TYPE", "EVENT", "VERSION"
;Output:
; Function returns 1 on success, 0 on failure
; ACTION (pass by reference) <tag>^<rtn>
; QUEUE (pass by reference) returns the named queue if there is one, else "DEFAULT"
;
;** do not implement the Pass Immediate parameter **
; IMMEDIATE (pass by reference, optional) returns 1 if the application wants its messages passed to the incoming queue immediately, 0 otherwise
;
N IEN
S (ACTION,QUEUE)=""
S IEN=$$GETIEN(HEADER("RECEIVING APPLICATION"))
Q:'$G(IEN) 0
I $G(HEADER("SEGMENT TYPE"))="BHS" D
.S NODE=$G(^HLD(779.2,IEN,0))
.I $P(NODE,"^",5)]"" D
..S ACTION=$P(NODE,"^",4,5)
.E I $P(NODE,"^",7)]"" S ACTION=$P(NODE,"^",6,7)
.I $P(NODE,"^",8)]"" D
..S QUEUE=$P(NODE,"^",8)
.E I $P(NODE,"^",3)]"" S QUEUE=$P(NODE,"^",3)
E I HEADER("SEGMENT TYPE")="MSH" D
.I HEADER("MESSAGE TYPE")'="",HEADER("EVENT")'="" D
..N SUBIEN,NODE
..;did the application specify an action for the particular version of this message?
..I HEADER("VERSION")'="" S SUBIEN=$O(^HLD(779.2,IEN,1,"D",HEADER("MESSAGE TYPE"),HEADER("EVENT"),HEADER("VERSION"),0))
..;if not, look on the "C" index
..S:'$G(SUBIEN) SUBIEN=$O(^HLD(779.2,IEN,1,"C",HEADER("MESSAGE TYPE"),HEADER("EVENT"),0))
..;
..I SUBIEN D
...S NODE=$G(^HLD(779.2,IEN,1,SUBIEN,0))
...I $P(NODE,"^",5)]"" S ACTION=$P(NODE,"^",4,5)
...I $P(NODE,"^",3)]"" S QUEUE=$P(NODE,"^",3)
...;
...;** do not implement the Pass ImMediate parameter **
...;S IMMEDIATE=$P(NODE,"^",8)
...;
..I ACTION="" S NODE=$G(^HLD(779.2,IEN,0)) I $P(NODE,"^",7)]"" S ACTION=$P(NODE,"^",6,7)
..I QUEUE="" S NODE=$G(^HLD(779.2,IEN,0)) I $P(NODE,"^",3)]"" S QUEUE=$P(NODE,"^",3)
I QUEUE="" S QUEUE="DEFAULT"
;
;** do not implement the Pass Immediate parameter **
;I $G(IMMEDIATE)'=1 S IMMEDIATE=0
;
I ACTION="" Q 0
Q 1
;
RTRNLNK(APPNAME) ;
;given the name of a receiving application, this returns the return
;link for application acks if one is provided. Otherwise, return
;acks are routed based on the information provide in the message hdr
;
Q:(APPNAME="") ""
N IEN
S IEN=$$GETIEN(APPNAME)
Q:IEN $P($G(^HLD(779.2,IEN,0)),"^",2)
Q ""
;
RTRNPORT(APPNAME) ;
;Given the name of the sending application, IF the application has its
;own listener, its port # is returned. Application acks should be
;returned using that port
Q:(APPNAME="") ""
N IEN,LINK
S IEN=$$GETIEN(APPNAME)
Q:'IEN ""
S LINK=$P($G(^HLD(779.2,IEN,0)),"^",9)
Q:'LINK ""
Q $$PORT^HLOTLNK(LINK)
;
ACTIVE(APP,MSGTYPE,EVENT,VERSION) ;
;Returns 1 if the message's INACTIVE flag has NOT been set.
;
;Input:
; APP (required) the name of the sending application
; MSGTYPE (required) 3 character HL7 message type
; EVENT (required) 3 character HL7 event
; VERSION (optional) HL7 version ID as it appears in the message header
;Output:
; Function returns 1 if the message type specified by the input parameters has not been set to INACTIVE. It returns 0 otherwise.
;
N IEN,ACTIVE,SUBIEN
S ACTIVE=1
S IEN=$$GETIEN($G(APP))
Q:'$G(IEN) ACTIVE
Q:$G(MSGTYPE)="" ACTIVE
Q:$G(EVENT)="" ACTIVE
;did the application specify an action for the particular version of this message?
I $G(VERSION)'="" S SUBIEN=$O(^HLD(779.2,IEN,1,"D",MSGTYPE,EVENT,VERSION,0))
;if not, look on the "C" index
S:'$G(SUBIEN) SUBIEN=$O(^HLD(779.2,IEN,1,"C",MSGTYPE,EVENT,0))
;
S:SUBIEN ACTIVE='(+$P($G(^HLD(779.2,IEN,1,SUBIEN,0)),"^",7))
Q ACTIVE
;
EXCEPT(APPNAME) ;
;returns the exception handler (tag^routine) that should be invoked
;when an applicaiton's messages are being sequenced and an app ack
;is not timely received
;
N IEN,RTN
S IEN=$$GETIEN($G(APPNAME))
I IEN S RTN=$P($G(^HLD(779.2,IEN,0)),"^",10,11)
I $L($G(RTN))>1 Q RTN
Q "DEFAULT^HLOAPP"
;
DEFAULT ;default exception handler if the app doesn't specify one
S ^TMP("HLO SEQUENCING EXCEPTION",$J,$$NOW^XLFDT,+$G(HLMSGIEN))=""
Q
;
TIMEOUT(APPNAME) ;
N IEN,TIME
S IEN=$$GETIEN($G(APPNAME))
I IEN S TIME=$P($G(^HLD(779.2,IEN,0)),"^",12)
Q:'$G(TIME) 10
Q TIME
;
RTNTN(APP,MSGTYPE,EVENT,VERSION) ;
;Returns the retention time for this message, if specified.
;
;Input:
; APP (required) the name of the sending application
; MSGTYPE (required) 3 character HL7 message type
; EVENT (required) 3 character HL7 event
; VERSION (optional) HL7 version ID as it appears in the message header
;Output:
; Function returns retention time if spcified, 0 otherwise
;
N IEN,RET,SUBIEN
S RET=0
S IEN=$$GETIEN($G(APP))
Q:'$G(IEN) RET
I $L($G(MSGTYPE)),$L($G(EVENT)) D
.;did the application specify an action for the particular version of this message?
.I $G(VERSION)'="" S SUBIEN=$O(^HLD(779.2,IEN,1,"D",MSGTYPE,EVENT,VERSION,0)) I SUBIEN S RET=$P($G(^HLD(779.2,IEN,1,SUBIEN,0)),"^",8)
.;if not, look on the "C" index
.S:'RET SUBIEN=$O(^HLD(779.2,IEN,1,"C",MSGTYPE,EVENT,0)) I SUBIEN S RET=$P($G(^HLD(779.2,IEN,1,SUBIEN,0)),"^",8)
;
S:'RET RET=+$P($G(^HLD(779.2,IEN,0)),"^",13)
Q RET
;
;
;
;
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLOAPP 6003 printed Dec 13, 2024@01:58:32 Page 2
HLOAPP ;ALB/CJM-HL7 -Application Registry ;02/23/2012
+1 ;;1.6;HEALTH LEVEL SEVEN;**126,132,137,139,158**;Oct 13, 1995;Build 14
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
GETIEN(NAME) ;given the application name, it finds the ien. Returns 0 on failure
+1 if '$LENGTH($GET(NAME))
QUIT 0
+2 QUIT +$ORDER(^HLD(779.2,"C",$EXTRACT(NAME,1,60),0))
+3 ;
ACTION(HEADER,ACTION,QUEUE) ;Given the parsed header of a message it returns both the action that should be performed in response to the message and the incoming queue that it should be placed on.
+1 ;
+2 ;** do not implement the Pass Immediate parameter **
+3 ;ACTION(HEADER,ACTION,QUEUE,IMMEDIATE);Given the parsed header of a message it returns both the action that should be performed in response to the message and the incoming queue that it should be placed on.
+4 ;
+5 ;Input:
+6 ; HEADER() subscripts are used: "RECEIVING APPLICATION","SEGMENT TYPE", "MESSAGE TYPE", "EVENT", "VERSION"
+7 ;Output:
+8 ; Function returns 1 on success, 0 on failure
+9 ; ACTION (pass by reference) <tag>^<rtn>
+10 ; QUEUE (pass by reference) returns the named queue if there is one, else "DEFAULT"
+11 ;
+12 ;** do not implement the Pass Immediate parameter **
+13 ; IMMEDIATE (pass by reference, optional) returns 1 if the application wants its messages passed to the incoming queue immediately, 0 otherwise
+14 ;
+15 NEW IEN
+16 SET (ACTION,QUEUE)=""
+17 SET IEN=$$GETIEN(HEADER("RECEIVING APPLICATION"))
+18 if '$GET(IEN)
QUIT 0
+19 IF $GET(HEADER("SEGMENT TYPE"))="BHS"
Begin DoDot:1
+20 SET NODE=$GET(^HLD(779.2,IEN,0))
+21 IF $PIECE(NODE,"^",5)]""
Begin DoDot:2
+22 SET ACTION=$PIECE(NODE,"^",4,5)
End DoDot:2
+23 IF '$TEST
IF $PIECE(NODE,"^",7)]""
SET ACTION=$PIECE(NODE,"^",6,7)
+24 IF $PIECE(NODE,"^",8)]""
Begin DoDot:2
+25 SET QUEUE=$PIECE(NODE,"^",8)
End DoDot:2
+26 IF '$TEST
IF $PIECE(NODE,"^",3)]""
SET QUEUE=$PIECE(NODE,"^",3)
End DoDot:1
+27 IF '$TEST
IF HEADER("SEGMENT TYPE")="MSH"
Begin DoDot:1
+28 IF HEADER("MESSAGE TYPE")'=""
IF HEADER("EVENT")'=""
Begin DoDot:2
+29 NEW SUBIEN,NODE
+30 ;did the application specify an action for the particular version of this message?
+31 IF HEADER("VERSION")'=""
SET SUBIEN=$ORDER(^HLD(779.2,IEN,1,"D",HEADER("MESSAGE TYPE"),HEADER("EVENT"),HEADER("VERSION"),0))
+32 ;if not, look on the "C" index
+33 if '$GET(SUBIEN)
SET SUBIEN=$ORDER(^HLD(779.2,IEN,1,"C",HEADER("MESSAGE TYPE"),HEADER("EVENT"),0))
+34 ;
+35 IF SUBIEN
Begin DoDot:3
+36 SET NODE=$GET(^HLD(779.2,IEN,1,SUBIEN,0))
+37 IF $PIECE(NODE,"^",5)]""
SET ACTION=$PIECE(NODE,"^",4,5)
+38 IF $PIECE(NODE,"^",3)]""
SET QUEUE=$PIECE(NODE,"^",3)
+39 ;
+40 ;** do not implement the Pass ImMediate parameter **
+41 ;S IMMEDIATE=$P(NODE,"^",8)
+42 ;
End DoDot:3
+43 IF ACTION=""
SET NODE=$GET(^HLD(779.2,IEN,0))
IF $PIECE(NODE,"^",7)]""
SET ACTION=$PIECE(NODE,"^",6,7)
+44 IF QUEUE=""
SET NODE=$GET(^HLD(779.2,IEN,0))
IF $PIECE(NODE,"^",3)]""
SET QUEUE=$PIECE(NODE,"^",3)
End DoDot:2
End DoDot:1
+45 IF QUEUE=""
SET QUEUE="DEFAULT"
+46 ;
+47 ;** do not implement the Pass Immediate parameter **
+48 ;I $G(IMMEDIATE)'=1 S IMMEDIATE=0
+49 ;
+50 IF ACTION=""
QUIT 0
+51 QUIT 1
+52 ;
RTRNLNK(APPNAME) ;
+1 ;given the name of a receiving application, this returns the return
+2 ;link for application acks if one is provided. Otherwise, return
+3 ;acks are routed based on the information provide in the message hdr
+4 ;
+5 if (APPNAME="")
QUIT ""
+6 NEW IEN
+7 SET IEN=$$GETIEN(APPNAME)
+8 if IEN
QUIT $PIECE($GET(^HLD(779.2,IEN,0)),"^",2)
+9 QUIT ""
+10 ;
RTRNPORT(APPNAME) ;
+1 ;Given the name of the sending application, IF the application has its
+2 ;own listener, its port # is returned. Application acks should be
+3 ;returned using that port
+4 if (APPNAME="")
QUIT ""
+5 NEW IEN,LINK
+6 SET IEN=$$GETIEN(APPNAME)
+7 if 'IEN
QUIT ""
+8 SET LINK=$PIECE($GET(^HLD(779.2,IEN,0)),"^",9)
+9 if 'LINK
QUIT ""
+10 QUIT $$PORT^HLOTLNK(LINK)
+11 ;
ACTIVE(APP,MSGTYPE,EVENT,VERSION) ;
+1 ;Returns 1 if the message's INACTIVE flag has NOT been set.
+2 ;
+3 ;Input:
+4 ; APP (required) the name of the sending application
+5 ; MSGTYPE (required) 3 character HL7 message type
+6 ; EVENT (required) 3 character HL7 event
+7 ; VERSION (optional) HL7 version ID as it appears in the message header
+8 ;Output:
+9 ; Function returns 1 if the message type specified by the input parameters has not been set to INACTIVE. It returns 0 otherwise.
+10 ;
+11 NEW IEN,ACTIVE,SUBIEN
+12 SET ACTIVE=1
+13 SET IEN=$$GETIEN($GET(APP))
+14 if '$GET(IEN)
QUIT ACTIVE
+15 if $GET(MSGTYPE)=""
QUIT ACTIVE
+16 if $GET(EVENT)=""
QUIT ACTIVE
+17 ;did the application specify an action for the particular version of this message?
+18 IF $GET(VERSION)'=""
SET SUBIEN=$ORDER(^HLD(779.2,IEN,1,"D",MSGTYPE,EVENT,VERSION,0))
+19 ;if not, look on the "C" index
+20 if '$GET(SUBIEN)
SET SUBIEN=$ORDER(^HLD(779.2,IEN,1,"C",MSGTYPE,EVENT,0))
+21 ;
+22 if SUBIEN
SET ACTIVE='(+$PIECE($GET(^HLD(779.2,IEN,1,SUBIEN,0)),"^",7))
+23 QUIT ACTIVE
+24 ;
EXCEPT(APPNAME) ;
+1 ;returns the exception handler (tag^routine) that should be invoked
+2 ;when an applicaiton's messages are being sequenced and an app ack
+3 ;is not timely received
+4 ;
+5 NEW IEN,RTN
+6 SET IEN=$$GETIEN($GET(APPNAME))
+7 IF IEN
SET RTN=$PIECE($GET(^HLD(779.2,IEN,0)),"^",10,11)
+8 IF $LENGTH($GET(RTN))>1
QUIT RTN
+9 QUIT "DEFAULT^HLOAPP"
+10 ;
DEFAULT ;default exception handler if the app doesn't specify one
+1 SET ^TMP("HLO SEQUENCING EXCEPTION",$JOB,$$NOW^XLFDT,+$GET(HLMSGIEN))=""
+2 QUIT
+3 ;
TIMEOUT(APPNAME) ;
+1 NEW IEN,TIME
+2 SET IEN=$$GETIEN($GET(APPNAME))
+3 IF IEN
SET TIME=$PIECE($GET(^HLD(779.2,IEN,0)),"^",12)
+4 if '$GET(TIME)
QUIT 10
+5 QUIT TIME
+6 ;
RTNTN(APP,MSGTYPE,EVENT,VERSION) ;
+1 ;Returns the retention time for this message, if specified.
+2 ;
+3 ;Input:
+4 ; APP (required) the name of the sending application
+5 ; MSGTYPE (required) 3 character HL7 message type
+6 ; EVENT (required) 3 character HL7 event
+7 ; VERSION (optional) HL7 version ID as it appears in the message header
+8 ;Output:
+9 ; Function returns retention time if spcified, 0 otherwise
+10 ;
+11 NEW IEN,RET,SUBIEN
+12 SET RET=0
+13 SET IEN=$$GETIEN($GET(APP))
+14 if '$GET(IEN)
QUIT RET
+15 IF $LENGTH($GET(MSGTYPE))
IF $LENGTH($GET(EVENT))
Begin DoDot:1
+16 ;did the application specify an action for the particular version of this message?
+17 IF $GET(VERSION)'=""
SET SUBIEN=$ORDER(^HLD(779.2,IEN,1,"D",MSGTYPE,EVENT,VERSION,0))
IF SUBIEN
SET RET=$PIECE($GET(^HLD(779.2,IEN,1,SUBIEN,0)),"^",8)
+18 ;if not, look on the "C" index
+19 if 'RET
SET SUBIEN=$ORDER(^HLD(779.2,IEN,1,"C",MSGTYPE,EVENT,0))
IF SUBIEN
SET RET=$PIECE($GET(^HLD(779.2,IEN,1,SUBIEN,0)),"^",8)
End DoDot:1
+20 ;
+21 if 'RET
SET RET=+$PIECE($GET(^HLD(779.2,IEN,0)),"^",13)
+22 QUIT RET
+23 ;
+24 ;
+25 ;
+26 ;
+27 ;
+28 ;
