- 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 Jan 18, 2025@03:01:41 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