HLUTIL ;SFISC/RJH- Utilities for HL7 TCP ;06/03/2008 11:20
;;1.6;HEALTH LEVEL SEVEN;**36,19,57,64,66,109,142**;Oct 13, 1995;Build 17
;Per VHA Directive 2004-038, this routine should not be modified.
Q
;For TCP only
MSGSTAT(X) ;message status
;input value: X = message id
;return value: status^status updated^error msg.^error type pointer^
;queue position or # of retries^# open failed^ack timeout
; status:
; 0 = message doesn't exist
; 1 = waiting in queue
; 1.5 = opening connection
; 1.7 = awaiting response, # of retries
; 2 = awaiting application ack
; 3 = successfully completed
; 4 = error
; 8 = being generated
; 9 = awaiting processing
Q:$G(X)']"" 0
N C,I,L,Y,Z
S Y=$O(^HLMA("C",X,0)) Q:'Y 0
;lock node to flush disk buffers
L +^HLMA(Y,"P"):3 S Z=$G(^HLMA(Y,"P"))
S:'Z Z=0
;if pending, get queue position
I +Z=1 D
. ;get Logical Link, if msg. not in x-ref, then it is being sent
. S L=+$P(^HLMA(Y,0),U,7) Q:'$D(^HLMA("AC","O",L,Y))
. ;find position in queue, if greater than 2 - use 2
. S I=Y F C=1:1:2 S I=$O(^HLMA("AC","O",L,I),-1) Q:'I
. S $P(Z,U,5)=C
L -^HLMA(Y,"P")
Q Z
;
MSGACT(X,HLIENACT) ;outgoing message action
;input value: X = message id
; HLIENACT = 1-cancel; 2-requeue
;return value: 1 = action sucessful
; 0 = action failed
Q:$G(X)']"" 0
N HLIEN,HLIEN0,HLSTAT,HLTCP,Y,LINK
S HLIEN=+$O(^HLMA("C",X,0)) Q:'HLIEN 0
S HLIEN0=$G(^HLMA(HLIEN,0)) Q:'HLIEN0 0
;must be outgoing
Q:$P(HLIEN0,U,3)'="O" 0
F Y=1:1:3 L +^HLMA(HLIEN,"P"):1 Q:$T H 1
E Q 0
;
;**109**
S LINK=$P($G(^HLMA(HLIEN,0)),"^",7)
;
S HLSTAT=1
;cancel
I HLIENACT=1 D
. ;HLTCP is set so that file 773 is updated
. S HLTCP=""
. D STATUS^HLTF0(HLIEN,3,,"Cancelled by application",1)
.;
.;**109**
. D DEQUE^HLCSREP(LINK,"O",HLIEN)
.;
;requeue
I HLIENACT=2 D
. N DA,DIK,HLJ
. ;check for type=outgoing and logical link, need for "AC" x-ref
. I $P(HLIEN0,U,3)'="O"!('$P(HLIEN0,U,7)) S HLSTAT=0 Q
. ;set status=pend transmission
. S Y=$NA(HLJ(773,HLIEN_",")),@Y@(20)=1
. ;delete status update, error msg, error type, date processed
. S (@Y@(21),@Y@(22),@Y@(23),@Y@(100))="@"
. D FILE^HLDIE("","HLJ","","MSGACT","HLUTIL") ; HL*1.6*109
. ;**109**
. ;need to set "AC" x-ref
.; S DA=HLIEN,DIK="^HLMA(",DIK(1)="7^AC"
.; D EN1^DIK
.;
.;**109**
. D ENQUE^HLCSREP(LINK,"O",HLIEN)
;
L -^HLMA(HLIEN,"P")
Q HLSTAT
;
CHKLL(X) ;check setup of Logical Link
;input value: X = institution number or name
;return value: 1 = setup OK
; 0 = LL setup incorrect
N HLF,HLRESLT
S HLF=$S(X:"I",1:"")
D LINK^HLUTIL3(X,.HLRESLT,HLF)
S X=+$O(HLRESLT(0)) Q:'X 0
Q $$LLOK^HLCSLM(X)
;
DONTPURG() ; set the DONT PURGE field to 1 in order to prevent the message
; from purging.
; return value : 1 for successfully set the field
; -1 for failure
Q $$SETPURG(1)
;
TOPURG() ; clear the DONT PURGE field to allow the message to be purged.
; return value : 0 for successfully clear the field
; -1 for failure
Q $$SETPURG(0)
;
SETPURG(STATUS) ; to set or to clear the DONT PURGE field
; HLMTIENS = ien in file 773 for this message
; input: 1 to set the DONT PURGE field
; 0 to clear the DONT PURGE field.
; return value: 1 means successfully set the DONT PURGE field
; 0 means successfully clear the DONT PURGE field
; -1 means fail to set or to clear the field
I (STATUS'=1),(STATUS'=0) Q -1
I '$D(^HLMA(+$G(HLMTIENS),0)) Q -1
;
L +^HLMA(HLMTIENS):30
E Q -1
S $P(^HLMA(HLMTIENS,2),U)=STATUS
L -^HLMA(HLMTIENS)
Q STATUS
;
REPROC(IEN,RTN) ; reprocessing message
; IEN- the message IEN in file 773
; RTN- the routine, to be Xecuted for processing the message
; return value: 0 for success, -1 for failure
N HLMTIEN,HLMTIENS,HLNEXT,HLNODE,HLQUIT,HLERR,HLRESLT,HLTCP
N HL,HDR,FS,ECH,HLMSA,X,X1,X2
S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL"
I '$D(^HLMA(+$G(IEN),0)) Q -1
;
; patch HL*1.6*142
; I $G(RTN)'["" Q -1
I $G(RTN)']"" Q -1
;
S (HLMTIENS,HLTCP)=+IEN,HLMTIEN=+^HLMA(HLMTIENS,0),HLMSA=$$MSA^HLTP3(HLMTIEN)
M HDR=^HLMA(HLMTIENS,"MSH")
D CHK^HLTPCK2(.HDR,.HL,.HLMSA)
Q:HL'="" -1
;
I RTN["D " X RTN
I RTN'["D " D
. I RTN["^" X "D "_RTN
. I RTN'["^" X "D ^"_RTN
S HLRESLT=0 S:($D(HLERR)) HLRESLT="9^"_$G(^HL(771.7,9,0))
; update the status
D STATUS^HLTF0(HLMTIENS,$S(HLRESLT:4,1:3),$S(HLRESLT:+HLRESLT,1:""),$S($D(HLERR):HLERR,HLRESLT:$P(HLRESLT,"^",2),1:""),1)
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLUTIL 4737 printed Oct 16, 2024@18:01:14 Page 2
HLUTIL ;SFISC/RJH- Utilities for HL7 TCP ;06/03/2008 11:20
+1 ;;1.6;HEALTH LEVEL SEVEN;**36,19,57,64,66,109,142**;Oct 13, 1995;Build 17
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ;For TCP only
MSGSTAT(X) ;message status
+1 ;input value: X = message id
+2 ;return value: status^status updated^error msg.^error type pointer^
+3 ;queue position or # of retries^# open failed^ack timeout
+4 ; status:
+5 ; 0 = message doesn't exist
+6 ; 1 = waiting in queue
+7 ; 1.5 = opening connection
+8 ; 1.7 = awaiting response, # of retries
+9 ; 2 = awaiting application ack
+10 ; 3 = successfully completed
+11 ; 4 = error
+12 ; 8 = being generated
+13 ; 9 = awaiting processing
+14 if $GET(X)']""
QUIT 0
+15 NEW C,I,L,Y,Z
+16 SET Y=$ORDER(^HLMA("C",X,0))
if 'Y
QUIT 0
+17 ;lock node to flush disk buffers
+18 LOCK +^HLMA(Y,"P"):3
SET Z=$GET(^HLMA(Y,"P"))
+19 if 'Z
SET Z=0
+20 ;if pending, get queue position
+21 IF +Z=1
Begin DoDot:1
+22 ;get Logical Link, if msg. not in x-ref, then it is being sent
+23 SET L=+$PIECE(^HLMA(Y,0),U,7)
if '$DATA(^HLMA("AC","O",L,Y))
QUIT
+24 ;find position in queue, if greater than 2 - use 2
+25 SET I=Y
FOR C=1:1:2
SET I=$ORDER(^HLMA("AC","O",L,I),-1)
if 'I
QUIT
+26 SET $PIECE(Z,U,5)=C
End DoDot:1
+27 LOCK -^HLMA(Y,"P")
+28 QUIT Z
+29 ;
MSGACT(X,HLIENACT) ;outgoing message action
+1 ;input value: X = message id
+2 ; HLIENACT = 1-cancel; 2-requeue
+3 ;return value: 1 = action sucessful
+4 ; 0 = action failed
+5 if $GET(X)']""
QUIT 0
+6 NEW HLIEN,HLIEN0,HLSTAT,HLTCP,Y,LINK
+7 SET HLIEN=+$ORDER(^HLMA("C",X,0))
if 'HLIEN
QUIT 0
+8 SET HLIEN0=$GET(^HLMA(HLIEN,0))
if 'HLIEN0
QUIT 0
+9 ;must be outgoing
+10 if $PIECE(HLIEN0,U,3)'="O"
QUIT 0
+11 FOR Y=1:1:3
LOCK +^HLMA(HLIEN,"P"):1
if $TEST
QUIT
HANG 1
+12 IF '$TEST
QUIT 0
+13 ;
+14 ;**109**
+15 SET LINK=$PIECE($GET(^HLMA(HLIEN,0)),"^",7)
+16 ;
+17 SET HLSTAT=1
+18 ;cancel
+19 IF HLIENACT=1
Begin DoDot:1
+20 ;HLTCP is set so that file 773 is updated
+21 SET HLTCP=""
+22 DO STATUS^HLTF0(HLIEN,3,,"Cancelled by application",1)
+23 ;
+24 ;**109**
+25 DO DEQUE^HLCSREP(LINK,"O",HLIEN)
+26 ;
End DoDot:1
+27 ;requeue
+28 IF HLIENACT=2
Begin DoDot:1
+29 NEW DA,DIK,HLJ
+30 ;check for type=outgoing and logical link, need for "AC" x-ref
+31 IF $PIECE(HLIEN0,U,3)'="O"!('$PIECE(HLIEN0,U,7))
SET HLSTAT=0
QUIT
+32 ;set status=pend transmission
+33 SET Y=$NAME(HLJ(773,HLIEN_","))
SET @Y@(20)=1
+34 ;delete status update, error msg, error type, date processed
+35 SET (@Y@(21),@Y@(22),@Y@(23),@Y@(100))="@"
+36 ; HL*1.6*109
DO FILE^HLDIE("","HLJ","","MSGACT","HLUTIL")
+37 ;**109**
+38 ;need to set "AC" x-ref
+39 ; S DA=HLIEN,DIK="^HLMA(",DIK(1)="7^AC"
+40 ; D EN1^DIK
+41 ;
+42 ;**109**
+43 DO ENQUE^HLCSREP(LINK,"O",HLIEN)
End DoDot:1
+44 ;
+45 LOCK -^HLMA(HLIEN,"P")
+46 QUIT HLSTAT
+47 ;
CHKLL(X) ;check setup of Logical Link
+1 ;input value: X = institution number or name
+2 ;return value: 1 = setup OK
+3 ; 0 = LL setup incorrect
+4 NEW HLF,HLRESLT
+5 SET HLF=$SELECT(X:"I",1:"")
+6 DO LINK^HLUTIL3(X,.HLRESLT,HLF)
+7 SET X=+$ORDER(HLRESLT(0))
if 'X
QUIT 0
+8 QUIT $$LLOK^HLCSLM(X)
+9 ;
DONTPURG() ; set the DONT PURGE field to 1 in order to prevent the message
+1 ; from purging.
+2 ; return value : 1 for successfully set the field
+3 ; -1 for failure
+4 QUIT $$SETPURG(1)
+5 ;
TOPURG() ; clear the DONT PURGE field to allow the message to be purged.
+1 ; return value : 0 for successfully clear the field
+2 ; -1 for failure
+3 QUIT $$SETPURG(0)
+4 ;
SETPURG(STATUS) ; to set or to clear the DONT PURGE field
+1 ; HLMTIENS = ien in file 773 for this message
+2 ; input: 1 to set the DONT PURGE field
+3 ; 0 to clear the DONT PURGE field.
+4 ; return value: 1 means successfully set the DONT PURGE field
+5 ; 0 means successfully clear the DONT PURGE field
+6 ; -1 means fail to set or to clear the field
+7 IF (STATUS'=1)
IF (STATUS'=0)
QUIT -1
+8 IF '$DATA(^HLMA(+$GET(HLMTIENS),0))
QUIT -1
+9 ;
+10 LOCK +^HLMA(HLMTIENS):30
+11 IF '$TEST
QUIT -1
+12 SET $PIECE(^HLMA(HLMTIENS,2),U)=STATUS
+13 LOCK -^HLMA(HLMTIENS)
+14 QUIT STATUS
+15 ;
REPROC(IEN,RTN) ; reprocessing message
+1 ; IEN- the message IEN in file 773
+2 ; RTN- the routine, to be Xecuted for processing the message
+3 ; return value: 0 for success, -1 for failure
+4 NEW HLMTIEN,HLMTIENS,HLNEXT,HLNODE,HLQUIT,HLERR,HLRESLT,HLTCP
+5 NEW HL,HDR,FS,ECH,HLMSA,X,X1,X2
+6 SET HLQUIT=0
SET HLNODE=""
SET HLNEXT="D HLNEXT^HLCSUTL"
+7 IF '$DATA(^HLMA(+$GET(IEN),0))
QUIT -1
+8 ;
+9 ; patch HL*1.6*142
+10 ; I $G(RTN)'["" Q -1
+11 IF $GET(RTN)']""
QUIT -1
+12 ;
+13 SET (HLMTIENS,HLTCP)=+IEN
SET HLMTIEN=+^HLMA(HLMTIENS,0)
SET HLMSA=$$MSA^HLTP3(HLMTIEN)
+14 MERGE HDR=^HLMA(HLMTIENS,"MSH")
+15 DO CHK^HLTPCK2(.HDR,.HL,.HLMSA)
+16 if HL'=""
QUIT -1
+17 ;
+18 IF RTN["D "
XECUTE RTN
+19 IF RTN'["D "
Begin DoDot:1
+20 IF RTN["^"
XECUTE "D "_RTN
+21 IF RTN'["^"
XECUTE "D ^"_RTN
End DoDot:1
+22 SET HLRESLT=0
if ($DATA(HLERR))
SET HLRESLT="9^"_$GET(^HL(771.7,9,0))
+23 ; update the status
+24 DO STATUS^HLTF0(HLMTIENS,$SELECT(HLRESLT:4,1:3),$SELECT(HLRESLT:+HLRESLT,1:""),$SELECT($DATA(HLERR):HLERR,HLRESLT:$PIECE(HLRESLT,"^",2),1:""),1)
+25 QUIT 0
