HLOTLNK ;IRMFO-ALB/CJM - APIs for the HL Logical Link file;03/24/2004 14:43 ;02/11/2011
;;1.6;HEALTH LEVEL SEVEN;**126,130,131,139,146,155**;Oct 13, 1995;Build 4
;Per VHA Directive 2004-038, this routine should not be modified.
;
SETSHUT(LINKIEN) ;
;sets the shutdown flag (can not fail - if the link doesn't exist, by definition its shutdown)
Q:'$G(LINKIEN) 1
Q:'$D(^HLCS(870,LINKIEN,0)) 1
S $P(^HLCS(870,LINKIEN,0),"^",16)=1
Q 1
SETOPEN(LINKIEN) ;
;clears the shutdown flag, returns 1 on success, 0 on failure
Q:'$G(LINKIEN) 0
Q:'$D(^HLCS(870,LINKIEN,0)) 0
S $P(^HLCS(870,LINKIEN,0),"^",16)=""
Q 1
;
IFSHUT(LINKNAME) ;
;returns 1 if the link was shut down to HLO
N IEN,LINK,RET
S RET=0
S LINK=$P($G(LINKNAME),":")
;** Start HL*1.6*139 RBN **
;Q:LINK=""
Q:LINK="" 1
;** END HL*1.6*139 RBN **
S IEN=$O(^HLCS(870,"B",LINK,0))
Q:'IEN 1
S:$P($G(^HLCS(870,IEN,0)),"^",16) RET=1
ZB0 Q RET
;
DOMAIN(LINKIEN) ;
;Returns the domain associated with this link
;
Q:'$G(LINKIEN) ""
N NODE,DOMAIN
S DOMAIN=""
S NODE=$G(^HLCS(870,LINKIEN,0))
I $P(NODE,"^",7) D
.S DOMAIN=$P($G(^DIC(4.2,$P(NODE,"^",7),0)),"^")
.S DOMAIN=$S($L(DOMAIN):"HL7."_DOMAIN,1:"")
I '$L(DOMAIN) S DOMAIN=$P(NODE,"^",8)
Q DOMAIN
;
PORT(LINKIEN) ;
;Returns the HLO port associated with this link
;
Q:'$G(LINKIEN) ""
N NODE,PORT
S NODE=$G(^HLCS(870,LINKIEN,400))
S PORT=$P(NODE,"^",8)
S:'PORT PORT=$S($P($G(^HLD(779.1,1,0)),"^",3)="P":5001,1:5026)
Q PORT
;
PORT2(LINKNAME) ;given the name of the link, returns its HLO port
N PORT
Q:'$L(LINKNAME) ""
S PORT=$$PORT($O(^HLCS(870,"B",LINKNAME,0)))
Q:'$L(PORT) ""
Q PORT
;
STATNUM(LINKIEN) ;
;Given the ien of the link, this function returns the station #.
;
Q:'$G(LINKIEN) ""
N INST
S INST=$P($G(^HLCS(870,LINKIEN,0)),"^",2)
Q:'INST ""
Q $P($G(^DIC(4,INST,99)),"^")
;
FINDLINK(STATN) ;
;Returns the link ien based on the station # =STATN
;The link found must have a name starting with "VA", as these are
;reserved for officially released links associated with VHA institutions
;** EXCEPTION** MPIVA is an official link associated with 200M
;
Q:'$L($G(STATN)) 0
;
N NAME,IEN
S (NAME,IEN)=""
F S NAME=$O(^HLCS(870,"AC",STATN,NAME)) Q:NAME="" I (NAME'="VA-VIE"),($E(NAME,1,2)="VA")!(NAME="MPIVA") S IEN=$O(^HLCS(870,"AC",STATN,NAME,0)) Q
Q IEN
;
GETLINK(LINKNAME,LINK) ;
N IEN
Q:'$L(LINKNAME) 0
S IEN=$O(^HLCS(870,"B",LINKNAME,0))
I IEN Q $$GET(IEN,.LINK)
I LINKNAME="HLO DEFAULT LISTENER" D Q 1
.N NODE
.S LINK("NAME")=LINKNAME
.S LINK("IEN")=0
.S LINK("SHUTDOWN")=""
.S LINK("LLP")="TCP"
.S LINK("SERVER")="1^"_"M"
.S NODE=$G(^HLD(779.1,1,0))
.S LINK("DOMAIN")=$P(NODE,"^",1)
.S LINK("PORT")=$S($P(NODE,"^",3)="P":5001,$P(NODE,"^",3)="T":5026,1:"")
.S LINK("IP")=""
Q 0
GET(IEN,LINK) ;
N NODE,PTR
K LINK
S NODE=$G(^HLCS(870,IEN,0))
Q:NODE="" 0
S LINK("NAME")=$P(NODE,"^")
S LINK("IEN")=IEN
S LINK("SHUTDOWN")=+$P(NODE,"^",16)
I $P(NODE,"^",23)=1 S LINK("SINGLE THREADED")=1
E S LINK("SINGLE THREADED")=0
I $P(NODE,"^",7) D
.S LINK("DOMAIN")=$P(^DIC(4.2,$P(NODE,"^",7),0),"^")
.S LINK("DOMAIN")=$S($L(LINK("DOMAIN")):"HL7."_LINK("DOMAIN"),1:"")
I $G(LINK("DOMAIN"))="" S LINK("DOMAIN")=$P(NODE,"^",8)
S PTR=$P(NODE,"^",3)
S LINK("LLP")=$S('PTR:"",1:$P($G(^HLCS(869.1,PTR,0)),"^"))
S LINK("SERVER")=""
I LINK("LLP")="TCP" D
.S LINK("SERVER")=1
.S NODE=$G(^HLCS(870,IEN,400))
.S LINK("IP")=$P(NODE,"^")
.S LINK("PORT")=$P(NODE,"^",8)
.S:'LINK("PORT") LINK("PORT")=$S($P($G(^HLD(779.1,1,0)),"^",3)="P":5001,1:5026)
.S:$P(NODE,"^",3)="C" LINK("SERVER")=0
.I LINK("SERVER") S LINK("SERVER")=LINK("SERVER")_"^"_$P(NODE,"^",3)
Q 1
;
SET1(LINK,MDOMAIN) ;
N DOMAIN
Q:'$L(MDOMAIN)
S DOMAIN=$P($G(^DIC(4.2,MDOMAIN,0)),"^")
S DOMAIN=$S($L(DOMAIN):"HL7."_DOMAIN,1:"")
I DOMAIN'="" S ^HLCS(870,"AD","TCP",DOMAIN,LINK)=""
Q
KILL1(LINK,MDOMAIN) ;
N DOMAIN
Q:'$L(MDOMAIN)
S DOMAIN=$P($G(^DIC(4.2,MDOMAIN,0)),"^")
S DOMAIN=$S($L(DOMAIN):"HL7."_DOMAIN,1:"")
I DOMAIN'="" K ^HLCS(870,"AD","TCP",DOMAIN,LINK)
Q
SET2(LINK,DOMAIN) ;
I DOMAIN'="" S ^HLCS(870,"AD","TCP",DOMAIN,LINK)=""
Q
KILL2(LINK,DOMAIN) ;
I DOMAIN'="" K ^HLCS(870,"AD","TCP",DOMAIN,LINK)
Q
SET3(LINK,DEVICE) ;
Q:'DEVICE
S ^HLCS(870,"AD","HLLP",DEVICE,LINK)=""
Q
KILL3(LINK,DEVICE) ;
Q:'DEVICE
S ^HLCS(870,"AD","HLLP",DEVICE,LINK)=""
Q
LLP(LINKNAME) ;
;finds the type of LLP for a named link
N IEN,LLP
S IEN=$O(^HLCS(870,"B",LINKNAME,0))
Q:'IEN ""
S LLP=$P($G(^HLCS(870,IEN,0)),"^",3)
Q:'LLP ""
Q $P($G(^HLCS(869.1,LLP,0)),"^")
;
DEVICE(LINKNAME) ;
N IEN
S IEN=$O(^HLCS(870,"B",LINKNAME,0))
Q:'IEN ""
Q $P($G(^HLCS(870,IEN,200)),"^")
;
RTRNLNK(COMP1,COMP2,COMP3) ;
;based on the sending facility from the original header, this function finds the return link, or "" if not successful
;Inputs:
; COMP1,COMP2,COMP3 - 3 components of the sending facility from the original message
;
N LINK,IEN
S LINK=""
I $G(COMP3)="DNS",$P($G(COMP2),":")]"" S LINK=$O(^HLCS(870,"AD","TCP",$P(COMP2,":"),""))
I LINK="",$L($G(COMP1)) S IEN=$$FINDLINK(COMP1) S:IEN LINK=$P($G(^HLCS(870,IEN,0)),"^")
Q LINK
;
;HLLP is not implemented in HLO
;I LLP="HLLP" N DEVICE S DEVICE=$$DEVICE(FROMLINK) I DEVICE Q $O(^HLCS(870,"AD","TCP",DEVICE,""))
;Q ""
;
CHKLINK(LINK) ;
Q:'$L(LINK) 0
Q:'$O(^HLCS(870,"B",LINK,0)) 0
Q 1
ONETHRED(LINKNAME) ;
;Returns the value of the SINGLE THREADED flag of the HL LOGICAL LINK
;file.
;Input:
; LINKNAME - the name given to an entry in the HL LOGICAL LINK file.
;Output:
; The function returns 1 if the SINGLE THREADED flag is set to YES,
; otherwiste it returns 0.
N IEN
S IEN=$O(^HLCS(870,"B",LINKNAME,0))
Q:'IEN 0
I $P($G(^HLCS(870,IEN,0)),"^",23)=1 Q 1
Q 0
;
STHREADS(LINKNAME,ON) ;
;This function is used to turn on or off the SINGLE THREADED flag of
;the HL LOGICAL LINK file.
;
;Input:
; LINKNAME - (required) the name of an entry in the HL LOGICAL LINK file.
; ON - 1 will set the flag.
; 0,"", or not present will cause the flag to be deleted.
; Other values are not accepted and will cause an error to be returned.
;Output:
; function returns -1 if the inputs are invalid. Otherwise returns
; the new value of the SINGLE THREADED flag.
N IEN
I $G(ON)'="",$G(ON)'=0,$G(ON)'=1 Q -1
S IEN=$O(^HLCS(870,"B",LINKNAME,0))
Q:'IEN -1
S $P(^HLCS(870,IEN,0),"^",23)=+$G(ON)
Q +$G(ON)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLOTLNK 6596 printed Dec 13, 2024@01:59:15 Page 2
HLOTLNK ;IRMFO-ALB/CJM - APIs for the HL Logical Link file;03/24/2004 14:43 ;02/11/2011
+1 ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,139,146,155**;Oct 13, 1995;Build 4
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
SETSHUT(LINKIEN) ;
+1 ;sets the shutdown flag (can not fail - if the link doesn't exist, by definition its shutdown)
+2 if '$GET(LINKIEN)
QUIT 1
+3 if '$DATA(^HLCS(870,LINKIEN,0))
QUIT 1
+4 SET $PIECE(^HLCS(870,LINKIEN,0),"^",16)=1
+5 QUIT 1
SETOPEN(LINKIEN) ;
+1 ;clears the shutdown flag, returns 1 on success, 0 on failure
+2 if '$GET(LINKIEN)
QUIT 0
+3 if '$DATA(^HLCS(870,LINKIEN,0))
QUIT 0
+4 SET $PIECE(^HLCS(870,LINKIEN,0),"^",16)=""
+5 QUIT 1
+6 ;
IFSHUT(LINKNAME) ;
+1 ;returns 1 if the link was shut down to HLO
+2 NEW IEN,LINK,RET
+3 SET RET=0
+4 SET LINK=$PIECE($GET(LINKNAME),":")
+5 ;** Start HL*1.6*139 RBN **
+6 ;Q:LINK=""
+7 if LINK=""
QUIT 1
+8 ;** END HL*1.6*139 RBN **
+9 SET IEN=$ORDER(^HLCS(870,"B",LINK,0))
+10 if 'IEN
QUIT 1
+11 if $PIECE($GET(^HLCS(870,IEN,0)),"^",16)
SET RET=1
ZB0 QUIT RET
+1 ;
DOMAIN(LINKIEN) ;
+1 ;Returns the domain associated with this link
+2 ;
+3 if '$GET(LINKIEN)
QUIT ""
+4 NEW NODE,DOMAIN
+5 SET DOMAIN=""
+6 SET NODE=$GET(^HLCS(870,LINKIEN,0))
+7 IF $PIECE(NODE,"^",7)
Begin DoDot:1
+8 SET DOMAIN=$PIECE($GET(^DIC(4.2,$PIECE(NODE,"^",7),0)),"^")
+9 SET DOMAIN=$SELECT($LENGTH(DOMAIN):"HL7."_DOMAIN,1:"")
End DoDot:1
+10 IF '$LENGTH(DOMAIN)
SET DOMAIN=$PIECE(NODE,"^",8)
+11 QUIT DOMAIN
+12 ;
PORT(LINKIEN) ;
+1 ;Returns the HLO port associated with this link
+2 ;
+3 if '$GET(LINKIEN)
QUIT ""
+4 NEW NODE,PORT
+5 SET NODE=$GET(^HLCS(870,LINKIEN,400))
+6 SET PORT=$PIECE(NODE,"^",8)
+7 if 'PORT
SET PORT=$SELECT($PIECE($GET(^HLD(779.1,1,0)),"^",3)="P":5001,1:5026)
+8 QUIT PORT
+9 ;
PORT2(LINKNAME) ;given the name of the link, returns its HLO port
+1 NEW PORT
+2 if '$LENGTH(LINKNAME)
QUIT ""
+3 SET PORT=$$PORT($ORDER(^HLCS(870,"B",LINKNAME,0)))
+4 if '$LENGTH(PORT)
QUIT ""
+5 QUIT PORT
+6 ;
STATNUM(LINKIEN) ;
+1 ;Given the ien of the link, this function returns the station #.
+2 ;
+3 if '$GET(LINKIEN)
QUIT ""
+4 NEW INST
+5 SET INST=$PIECE($GET(^HLCS(870,LINKIEN,0)),"^",2)
+6 if 'INST
QUIT ""
+7 QUIT $PIECE($GET(^DIC(4,INST,99)),"^")
+8 ;
FINDLINK(STATN) ;
+1 ;Returns the link ien based on the station # =STATN
+2 ;The link found must have a name starting with "VA", as these are
+3 ;reserved for officially released links associated with VHA institutions
+4 ;** EXCEPTION** MPIVA is an official link associated with 200M
+5 ;
+6 if '$LENGTH($GET(STATN))
QUIT 0
+7 ;
+8 NEW NAME,IEN
+9 SET (NAME,IEN)=""
+10 FOR
SET NAME=$ORDER(^HLCS(870,"AC",STATN,NAME))
if NAME=""
QUIT
IF (NAME'="VA-VIE")
IF ($EXTRACT(NAME,1,2)="VA")!(NAME="MPIVA")
SET IEN=$ORDER(^HLCS(870,"AC",STATN,NAME,0))
QUIT
+11 QUIT IEN
+12 ;
GETLINK(LINKNAME,LINK) ;
+1 NEW IEN
+2 if '$LENGTH(LINKNAME)
QUIT 0
+3 SET IEN=$ORDER(^HLCS(870,"B",LINKNAME,0))
+4 IF IEN
QUIT $$GET(IEN,.LINK)
+5 IF LINKNAME="HLO DEFAULT LISTENER"
Begin DoDot:1
+6 NEW NODE
+7 SET LINK("NAME")=LINKNAME
+8 SET LINK("IEN")=0
+9 SET LINK("SHUTDOWN")=""
+10 SET LINK("LLP")="TCP"
+11 SET LINK("SERVER")="1^"_"M"
+12 SET NODE=$GET(^HLD(779.1,1,0))
+13 SET LINK("DOMAIN")=$PIECE(NODE,"^",1)
+14 SET LINK("PORT")=$SELECT($PIECE(NODE,"^",3)="P":5001,$PIECE(NODE,"^",3)="T":5026,1:"")
+15 SET LINK("IP")=""
End DoDot:1
QUIT 1
+16 QUIT 0
GET(IEN,LINK) ;
+1 NEW NODE,PTR
+2 KILL LINK
+3 SET NODE=$GET(^HLCS(870,IEN,0))
+4 if NODE=""
QUIT 0
+5 SET LINK("NAME")=$PIECE(NODE,"^")
+6 SET LINK("IEN")=IEN
+7 SET LINK("SHUTDOWN")=+$PIECE(NODE,"^",16)
+8 IF $PIECE(NODE,"^",23)=1
SET LINK("SINGLE THREADED")=1
+9 IF '$TEST
SET LINK("SINGLE THREADED")=0
+10 IF $PIECE(NODE,"^",7)
Begin DoDot:1
+11 SET LINK("DOMAIN")=$PIECE(^DIC(4.2,$PIECE(NODE,"^",7),0),"^")
+12 SET LINK("DOMAIN")=$SELECT($LENGTH(LINK("DOMAIN")):"HL7."_LINK("DOMAIN"),1:"")
End DoDot:1
+13 IF $GET(LINK("DOMAIN"))=""
SET LINK("DOMAIN")=$PIECE(NODE,"^",8)
+14 SET PTR=$PIECE(NODE,"^",3)
+15 SET LINK("LLP")=$SELECT('PTR:"",1:$PIECE($GET(^HLCS(869.1,PTR,0)),"^"))
+16 SET LINK("SERVER")=""
+17 IF LINK("LLP")="TCP"
Begin DoDot:1
+18 SET LINK("SERVER")=1
+19 SET NODE=$GET(^HLCS(870,IEN,400))
+20 SET LINK("IP")=$PIECE(NODE,"^")
+21 SET LINK("PORT")=$PIECE(NODE,"^",8)
+22 if 'LINK("PORT")
SET LINK("PORT")=$SELECT($PIECE($GET(^HLD(779.1,1,0)),"^",3)="P":5001,1:5026)
+23 if $PIECE(NODE,"^",3)="C"
SET LINK("SERVER")=0
+24 IF LINK("SERVER")
SET LINK("SERVER")=LINK("SERVER")_"^"_$PIECE(NODE,"^",3)
End DoDot:1
+25 QUIT 1
+26 ;
SET1(LINK,MDOMAIN) ;
+1 NEW DOMAIN
+2 if '$LENGTH(MDOMAIN)
QUIT
+3 SET DOMAIN=$PIECE($GET(^DIC(4.2,MDOMAIN,0)),"^")
+4 SET DOMAIN=$SELECT($LENGTH(DOMAIN):"HL7."_DOMAIN,1:"")
+5 IF DOMAIN'=""
SET ^HLCS(870,"AD","TCP",DOMAIN,LINK)=""
+6 QUIT
KILL1(LINK,MDOMAIN) ;
+1 NEW DOMAIN
+2 if '$LENGTH(MDOMAIN)
QUIT
+3 SET DOMAIN=$PIECE($GET(^DIC(4.2,MDOMAIN,0)),"^")
+4 SET DOMAIN=$SELECT($LENGTH(DOMAIN):"HL7."_DOMAIN,1:"")
+5 IF DOMAIN'=""
KILL ^HLCS(870,"AD","TCP",DOMAIN,LINK)
+6 QUIT
SET2(LINK,DOMAIN) ;
+1 IF DOMAIN'=""
SET ^HLCS(870,"AD","TCP",DOMAIN,LINK)=""
+2 QUIT
KILL2(LINK,DOMAIN) ;
+1 IF DOMAIN'=""
KILL ^HLCS(870,"AD","TCP",DOMAIN,LINK)
+2 QUIT
SET3(LINK,DEVICE) ;
+1 if 'DEVICE
QUIT
+2 SET ^HLCS(870,"AD","HLLP",DEVICE,LINK)=""
+3 QUIT
KILL3(LINK,DEVICE) ;
+1 if 'DEVICE
QUIT
+2 SET ^HLCS(870,"AD","HLLP",DEVICE,LINK)=""
+3 QUIT
LLP(LINKNAME) ;
+1 ;finds the type of LLP for a named link
+2 NEW IEN,LLP
+3 SET IEN=$ORDER(^HLCS(870,"B",LINKNAME,0))
+4 if 'IEN
QUIT ""
+5 SET LLP=$PIECE($GET(^HLCS(870,IEN,0)),"^",3)
+6 if 'LLP
QUIT ""
+7 QUIT $PIECE($GET(^HLCS(869.1,LLP,0)),"^")
+8 ;
DEVICE(LINKNAME) ;
+1 NEW IEN
+2 SET IEN=$ORDER(^HLCS(870,"B",LINKNAME,0))
+3 if 'IEN
QUIT ""
+4 QUIT $PIECE($GET(^HLCS(870,IEN,200)),"^")
+5 ;
RTRNLNK(COMP1,COMP2,COMP3) ;
+1 ;based on the sending facility from the original header, this function finds the return link, or "" if not successful
+2 ;Inputs:
+3 ; COMP1,COMP2,COMP3 - 3 components of the sending facility from the original message
+4 ;
+5 NEW LINK,IEN
+6 SET LINK=""
+7 IF $GET(COMP3)="DNS"
IF $PIECE($GET(COMP2),":")]""
SET LINK=$ORDER(^HLCS(870,"AD","TCP",$PIECE(COMP2,":"),""))
+8 IF LINK=""
IF $LENGTH($GET(COMP1))
SET IEN=$$FINDLINK(COMP1)
if IEN
SET LINK=$PIECE($GET(^HLCS(870,IEN,0)),"^")
+9 QUIT LINK
+10 ;
+11 ;HLLP is not implemented in HLO
+12 ;I LLP="HLLP" N DEVICE S DEVICE=$$DEVICE(FROMLINK) I DEVICE Q $O(^HLCS(870,"AD","TCP",DEVICE,""))
+13 ;Q ""
+14 ;
CHKLINK(LINK) ;
+1 if '$LENGTH(LINK)
QUIT 0
+2 if '$ORDER(^HLCS(870,"B",LINK,0))
QUIT 0
+3 QUIT 1
ONETHRED(LINKNAME) ;
+1 ;Returns the value of the SINGLE THREADED flag of the HL LOGICAL LINK
+2 ;file.
+3 ;Input:
+4 ; LINKNAME - the name given to an entry in the HL LOGICAL LINK file.
+5 ;Output:
+6 ; The function returns 1 if the SINGLE THREADED flag is set to YES,
+7 ; otherwiste it returns 0.
+8 NEW IEN
+9 SET IEN=$ORDER(^HLCS(870,"B",LINKNAME,0))
+10 if 'IEN
QUIT 0
+11 IF $PIECE($GET(^HLCS(870,IEN,0)),"^",23)=1
QUIT 1
+12 QUIT 0
+13 ;
STHREADS(LINKNAME,ON) ;
+1 ;This function is used to turn on or off the SINGLE THREADED flag of
+2 ;the HL LOGICAL LINK file.
+3 ;
+4 ;Input:
+5 ; LINKNAME - (required) the name of an entry in the HL LOGICAL LINK file.
+6 ; ON - 1 will set the flag.
+7 ; 0,"", or not present will cause the flag to be deleted.
+8 ; Other values are not accepted and will cause an error to be returned.
+9 ;Output:
+10 ; function returns -1 if the inputs are invalid. Otherwise returns
+11 ; the new value of the SINGLE THREADED flag.
+12 NEW IEN
+13 IF $GET(ON)'=""
IF $GET(ON)'=0
IF $GET(ON)'=1
QUIT -1
+14 SET IEN=$ORDER(^HLCS(870,"B",LINKNAME,0))
+15 if 'IEN
QUIT -1
+16 SET $PIECE(^HLCS(870,IEN,0),"^",23)=+$GET(ON)
+17 QUIT +$GET(ON)
