HLOF778A ;ALB/CJM-HL7 - Saving messages to file 778 (continued) ;03/13/2012
;;1.6;HEALTH LEVEL SEVEN;**126,134,137,138,158**;Oct 13, 1995;Build 14
;Per VHA Directive 2004-038, this routine should not be modified.
;
;
NEW(HLMSTATE) ;
;This function creates a new entry in file 778.
;Input:
; HLMSTATE (required, pass by reference) These subscripts are expected:
;
;Output - the function returns the ien of the newly created record
;
N IEN,NODE,ID,STAT,RTNTN,APP
S STAT="HLMSTATE(""STATUS"")"
S IEN=$$NEWIEN(HLMSTATE("DIRECTION"),$$TCP)
Q:'IEN 0
S HLMSTATE("IEN")=IEN
;
D ;build the message header
.N HDR
.;for incoming messages the header segment should already exist
.;for outgoing messages must build the header segment
.I HLMSTATE("DIRECTION")="OUT" D Q
..I HLMSTATE("BATCH"),$G(HLMSTATE("ACK TO"))]"" S HLMSTATE("HDR","REFERENCE BATCH CONTROL ID")=HLMSTATE("ACK TO")
..D BUILDHDR^HLOPBLD1(.HLMSTATE,$S(HLMSTATE("BATCH"):"BHS",1:"MSH"),.HDR)
..S HLMSTATE("HDR",1)=HDR(1),HLMSTATE("HDR",2)=HDR(2)
;
K ^HLB(IEN)
S ID=$S(HLMSTATE("BATCH"):HLMSTATE("HDR","BATCH CONTROL ID"),1:HLMSTATE("HDR","MESSAGE CONTROL ID"))
S NODE=ID_"^"_HLMSTATE("BODY")_"^"_$G(HLMSTATE("ACK TO"))_"^"_$S(HLMSTATE("DIRECTION")="IN":"I",1:"O")_"^"
S $P(NODE,"^",5)=$G(@STAT@("LINK NAME"))
S $P(NODE,"^",6)=$G(@STAT@("QUEUE"))
S $P(NODE,"^",8)=$G(@STAT@("PORT"))
S $P(NODE,"^",20)=$G(@STAT)
S $P(NODE,"^",21)=$G(@STAT@("ERROR TEXT"))
S $P(NODE,"^",16)=HLMSTATE("DT/TM")
S APP=$S(HLMSTATE("DIRECTION")="OUT":HLMSTATE("HDR","SENDING APPLICATION"),1:HLMSTATE("HDR","RECEIVING APPLICATION"))
I HLMSTATE("BATCH") D
.S RTNTN=$$RTNTN^HLOAPP(APP)
E D
.S RTNTN=$$RTNTN^HLOAPP(APP,HLMSTATE("HDR","MESSAGE TYPE"),HLMSTATE("HDR","EVENT"),HLMSTATE("HDR","VERSION"))
S $P(NODE,"^",22)=RTNTN
I HLMSTATE("BATCH"),HLMSTATE("SYSTEM","ERROR PURGE")>RTNTN S RTNTN=HLMSTATE("SYSTEM","ERROR PURGE")
I 'HLMSTATE("BATCH"),HLMSTATE("SYSTEM","NORMAL PURGE")>RTNTN S RTNTN=HLMSTATE("SYSTEM","NORMAL PURGE")
S HLMSTATE("RETENTION")=RTNTN
;
I HLMSTATE("DIRECTION")="OUT" D
.S $P(NODE,"^",10)=$P($G(@STAT@("APP ACK RESPONSE")),"^")
.S $P(NODE,"^",11)=$P($G(@STAT@("APP ACK RESPONSE")),"^",2)
.S $P(NODE,"^",12)=$P($G(@STAT@("ACCEPT ACK RESPONSE")),"^")
.S $P(NODE,"^",13)=$P($G(@STAT@("ACCEPT ACK RESPONSE")),"^",2)
.S $P(NODE,"^",14)=$P($G(@STAT@("FAILURE RESPONSE")),"^")
.S $P(NODE,"^",15)=$P($G(@STAT@("FAILURE RESPONSE")),"^",2)
.;
.;for outgoing set these x-refs now, for incoming msgs set them later
.S ^HLB("B",ID,IEN)=""
.S ^HLB("C",HLMSTATE("BODY"),IEN)=""
.I ($G(@STAT)="ER") D
..S ^HLB("ERRORS",$S($L($G(HLMSTATE("HDR","RECEIVING APPLICATION"))):HLMSTATE("HDR","RECEIVING APPLICATION"),1:"UNKNOWN"),HLMSTATE("DT/TM CREATED"),IEN)=""
..D COUNT^HLOESTAT("OUT",$G(HLMSTATE("HDR","RECEIVING APPLICATION")),$G(HLMSTATE("HDR","SENDING APPLICATION")),$S(HLMSTATE("BATCH"):"BATCH",1:$G(HLMSTATE("HDR","MESSAGE TYPE"))),$G(HLMSTATE("HDR","EVENT")))
.;
.;save some space for the ack
.S:($G(HLMSTATE("HDR","ACCEPT ACK TYPE"))="AL") ^HLB(IEN,4)="^^^ "
I $G(HLMSTATE("STATUS","PURGE")) S $P(NODE,"^",9)=HLMSTATE("STATUS","PURGE"),^HLB("AD","OUT",HLMSTATE("STATUS","PURGE"),HLMSTATE("IEN"))=""
S ^HLB(IEN,0)=NODE
;
;store the message header
S ^HLB(IEN,1)=HLMSTATE("HDR",1)
S ^HLB(IEN,2)=HLMSTATE("HDR",2)
;
;if the msg is an app ack, update the original msg
I $G(HLMSTATE("ACK TO IEN"))]"" D
.N ACKTO
.M ACKTO=HLMSTATE("ACK TO")
.S ACKTO("IEN")=HLMSTATE("ACK TO IEN")
.S ACKTO("ACK BY")=$S(HLMSTATE("BATCH"):HLMSTATE("HDR","BATCH CONTROL ID"),1:HLMSTATE("HDR","MESSAGE CONTROL ID"))
.D ACKTO^HLOF778(.HLMSTATE,.ACKTO)
.S HLMSTATE("ACK TO","DONE")=1 ;because the update was already done, otherwise it might be done again
;
;The "SEARCH" x-ref will be created asynchronously
S ^HLTMP("PENDING SEARCH X-REF",$J,HLMSTATE("DT/TM CREATED"),IEN)=""
;
;sequence q?
I HLMSTATE("DIRECTION")="OUT",$G(@STAT@("SEQUENCE QUEUE"))'="" S ^HLB(IEN,5)=@STAT@("SEQUENCE QUEUE")
;
Q IEN
;
NEWIEN(DIR,TCP) ;
;This function uses a counter to get the next available ien for file 778. There are 4 different counters, each assigned as range of numbers, selected via the input parameters. It does not create a record.
;Inputs:
; DIR = "IN" or "OUT" (required)
; TCP = 1,0 (optional)
;Output - the function returns the next available ien. Several counters are used:
;
; <"OUT","TCP">
; <"OUT","NOT TCP">
; <"IN","TCP">
; <"IN","NOT TCP">
;
N IEN,COUNTER,INC
I DIR="OUT" S INC=$S(+$G(TCP):0,1:100000000000)
I DIR="IN" S INC=$S(+$G(TCP):200000000000,1:300000000000)
S COUNTER=$NA(^HLC("FILE778",DIR,$S(+$G(TCP):"TCP",1:"NOT TCP")))
AGAIN ;
S IEN=$$INC^HLOSITE(COUNTER,1)
I IEN>100000000000 D
.L +@COUNTER:200
.I $T,@COUNTER>100000000000 S @COUNTER=1,IEN=1
.L -@COUNTER
I IEN>100000000000 G AGAIN
Q (IEN+INC)
;
TCP() ;checks the link to see if its TCP, return 1 if yes, 0 if no or not defined
N IEN,TCP
S TCP=1
S IEN=$G(HLMSTATE("STATUS","LINK IEN"))
I IEN,$P($G(^HLCS(869.1,+$P($G(^HLCS(870,IEN,0)),"^",3),0)),"^")'="TCP" S TCP=0
Q TCP
;
GETWORK(WORK) ; Used by the Process Manager.
;Are there any messages that need the "SEARCH" x-ref set?
;Inputs:
; WORK (required, pass-by-reference)
; ("DOLLARJ")
; ("NOW") (required by the process manager, pass-by-reference)
;
L +^HLTMP("PENDING SEARCH X-REF"):0
Q:'$T 0
N OLD,DOLLARJ,SUCCESS,NOW
S SUCCESS=0
S NOW=$$SEC^XLFDT($H)
S (OLD,DOLLARJ)=$G(WORK("DOLLARJ"))
F S DOLLARJ=$O(^HLTMP("PENDING SEARCH X-REF",DOLLARJ)) Q:DOLLARJ="" D Q:SUCCESS
.N TIME S TIME=$O(^HLTMP("PENDING SEARCH X-REF",DOLLARJ,""))
.S:(NOW-$$SEC^XLFDT(TIME)>10) SUCCESS=1
;
I OLD'="",'SUCCESS F S DOLLARJ=$O(^HLTMP("PENDING SEARCH X-REF",DOLLARJ)) Q:DOLLARJ="" Q:DOLLARJ>OLD D Q:SUCCESS
.N TIME S TIME=$O(^HLTMP("PENDING SEARCH X-REF",DOLLARJ,""))
.S:(NOW-$$SEC^XLFDT(TIME)>10) SUCCESS=1
S WORK("DOLLARJ")=DOLLARJ,WORK("NOW")=NOW
Q:WORK("DOLLARJ")]"" 1
L -^HLTMP("PENDING SEARCH X-REF")
Q 0
;
DOWORK(WORK) ;Used by the Process Manager
;Sets the "SEARCH" x-ref, running 10 seconds behind when the message record was created.
;
N MSGIEN,TIME
S TIME=0
F S TIME=$O(^HLTMP("PENDING SEARCH X-REF",WORK("DOLLARJ"),TIME)) Q:'TIME Q:((WORK("NOW")-$$SEC^XLFDT(TIME))<10) D
.S MSGIEN=0
.F S MSGIEN=$O(^HLTMP("PENDING SEARCH X-REF",WORK("DOLLARJ"),TIME,MSGIEN)) Q:'MSGIEN D
..N MSG
..I $$GETMSG^HLOMSG(MSGIEN,.MSG) D
...Q:'MSG("DT/TM CREATED")
...I MSG("BATCH") D
....N HDR
....F Q:'$$NEXTMSG^HLOMSG(.MSG,.HDR) S MSG("HDR",1)=HDR(1),MSG("HDR",2)=HDR(2) D SET(.MSG)
...E D
....D SET(.MSG)
..K ^HLTMP("PENDING SEARCH X-REF",WORK("DOLLARJ"),TIME,MSGIEN)
L -^HLTMP("PENDING SEARCH X-REF")
Q
;
SET(MSG) ;
;sets the ^HLB("SEARCH") x-ref
;
N APP,FS,CS,IEN
I MSG("DIRECTION")'="IN",MSG("DIRECTION")'="OUT" Q
S FS=$E(MSG("HDR",1),4)
Q:FS=""
S CS=$E(MSG("HDR",1),5)
S APP=$S(MSG("DIRECTION")="IN":$P($P(MSG("HDR",1),FS,5),CS),1:$P($P(MSG("HDR",1),FS,3),CS))
I APP="" S APP="UNKNOWN"
I MSG("BATCH") D
.N VALUE
.S VALUE=$P(MSG("HDR",2),FS,4)
.S MSG("MESSAGE TYPE")=$P(VALUE,CS)
.S MSG("EVENT")=$P(VALUE,CS,2)
S:MSG("MESSAGE TYPE")="" MSG("MESSAGE TYPE")="<none>"
S:MSG("EVENT")="" MSG("EVENT")="<none>"
S IEN=MSG("IEN")
I MSG("BATCH") S IEN=IEN_"^"_MSG("BATCH","CURRENT MESSAGE")
S ^HLB("SEARCH",MSG("DIRECTION"),MSG("DT/TM CREATED"),APP,MSG("MESSAGE TYPE"),MSG("EVENT"),IEN)=""
Q
;
SETPURGE(MSG,MSGSTAT,MATE,MATESTAT) ; Set message up for purging.
;Resets the purge date/time.
;Input:
; MSG (required) ien of the message, file #778
; MSGSTAT (required) the status
; MATE - ien of other message if this is a two-message transaction
; MATESTAT (optional) status of mate
;Output:
; Function returns 1 on success, 0 on failure
;
N NODE,SYSPURGE,NEWPURGE
Q:'$G(MSG) 0
S NODE=$G(^HLB(MSG,0))
Q:NODE="" 0
Q:MSGSTAT="" 0
D SYSPURGE^HLOSITE(.SYSPURGE)
;
S MSG("BODY")=+$P(NODE,"^",2)
S MSG("BATCH")=$S(MSG("BODY"):+$P($G(^HLA(MSG("BODY"),0)),"^",2),1:0)
S MSG("OLD PURGE")=$P(NODE,"^",9)
S MSG("DIR")=$S($E($P(NODE,"^",4))="I":"IN",1:"OUT")
S MSG("RETENTION")=+$P(NODE,"^",22)
I 'MSG("RETENTION") S MSG("RETENTION")=$S(MSG("BATCH"):SYSPURGE("ERROR"),1:SYSPURGE("NORMAL"))
;
;
I MATE D I MATE,MATESTAT="" Q 0 ;don't purge if the mate doesn't have a status!
.S NODE=$G(^HLB(MATE,0))
.I NODE="" K MATE Q
.S MATE("BODY")=+$P(NODE,"^",2)
.S MATE("BATCH")=$S(MATE("BODY"):+$P($G(^HLA(MATE("BODY"),0)),"^",2),1:0)
.S MATE("OLD PURGE")=$P(NODE,"^",9)
.S MATE("DIR")=$S($E($P(NODE,"^",4))="I":"IN",1:"OUT")
.S MATE("RETENTION")=+$P(NODE,"^",22)
.I 'MATE("RETENTION") S MATE("RETENTION")=$S(MATE("BATCH"):SYSPURGE("ERROR"),1:SYSPURGE("NORMAL"))
.I $G(MATESTAT)="" S MATESTAT=$P(NODE,"^",20)
;
;determine purge time
S NEWPURGE=MSG("RETENTION")
I MSGSTAT="ER",SYSPURGE("ERROR")>NEWPURGE S NEWPURGE=SYSPURGE("ERROR")
I MATE D
.I MATE("RETENTION")>NEWPURGE S NEWPURGE=MATE("RETENTION")
.I MATESTAT="ER",SYSPURGE("ERROR")>NEWPURGE S NEWPURGE=SYSPURGE("ERROR")
;
S NEWPURGE=$$FMADD^XLFDT($$NOW^XLFDT,NEWPURGE)
I NEWPURGE<MSG("OLD PURGE") S NEWPURGE=MSG("OLD PURGE")
I NEWPURGE<$G(MATE("OLD PURGE")) S NEWPURGE=MATE("OLD PURGE")
I MSG("OLD PURGE"),MSG("OLD PURGE")'=NEWPURGE D
.K ^HLB("AD",MSG("DIR"),MSG("OLD PURGE"),MSG)
.S $P(^HLB(MSG,0),"^",9)=NEWPURGE,^HLB("AD",MSG("DIR"),NEWPURGE,MSG)=""
I MATE,MATE("OLD PURGE"),MATE("OLD PURGE")'=NEWPURGE D
.K ^HLB("AD",MATE("DIR"),MATE("OLD PURGE"),MATE)
.S $P(^HLB(MATE,0),"^",9)=NEWPURGE,^HLB("AD",MATE("DIR"),NEWPURGE,MATE)=""
I 'MSG("OLD PURGE") S $P(^HLB(MSG,0),"^",9)=NEWPURGE,^HLB("AD",MSG("DIR"),NEWPURGE,MSG)=""
I MATE,'MATE("OLD PURGE") S $P(^HLB(MATE,0),"^",9)=NEWPURGE,^HLB("AD",MATE("DIR"),NEWPURGE,MATE)=""
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLOF778A 10031 printed Dec 13, 2024@01:58:44 Page 2
HLOF778A ;ALB/CJM-HL7 - Saving messages to file 778 (continued) ;03/13/2012
+1 ;;1.6;HEALTH LEVEL SEVEN;**126,134,137,138,158**;Oct 13, 1995;Build 14
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;
NEW(HLMSTATE) ;
+1 ;This function creates a new entry in file 778.
+2 ;Input:
+3 ; HLMSTATE (required, pass by reference) These subscripts are expected:
+4 ;
+5 ;Output - the function returns the ien of the newly created record
+6 ;
+7 NEW IEN,NODE,ID,STAT,RTNTN,APP
+8 SET STAT="HLMSTATE(""STATUS"")"
+9 SET IEN=$$NEWIEN(HLMSTATE("DIRECTION"),$$TCP)
+10 if 'IEN
QUIT 0
+11 SET HLMSTATE("IEN")=IEN
+12 ;
+13 ;build the message header
Begin DoDot:1
+14 NEW HDR
+15 ;for incoming messages the header segment should already exist
+16 ;for outgoing messages must build the header segment
+17 IF HLMSTATE("DIRECTION")="OUT"
Begin DoDot:2
+18 IF HLMSTATE("BATCH")
IF $GET(HLMSTATE("ACK TO"))]""
SET HLMSTATE("HDR","REFERENCE BATCH CONTROL ID")=HLMSTATE("ACK TO")
+19 DO BUILDHDR^HLOPBLD1(.HLMSTATE,$SELECT(HLMSTATE("BATCH"):"BHS",1:"MSH"),.HDR)
+20 SET HLMSTATE("HDR",1)=HDR(1)
SET HLMSTATE("HDR",2)=HDR(2)
End DoDot:2
QUIT
End DoDot:1
+21 ;
+22 KILL ^HLB(IEN)
+23 SET ID=$SELECT(HLMSTATE("BATCH"):HLMSTATE("HDR","BATCH CONTROL ID"),1:HLMSTATE("HDR","MESSAGE CONTROL ID"))
+24 SET NODE=ID_"^"_HLMSTATE("BODY")_"^"_$GET(HLMSTATE("ACK TO"))_"^"_$SELECT(HLMSTATE("DIRECTION")="IN":"I",1:"O")_"^"
+25 SET $PIECE(NODE,"^",5)=$GET(@STAT@("LINK NAME"))
+26 SET $PIECE(NODE,"^",6)=$GET(@STAT@("QUEUE"))
+27 SET $PIECE(NODE,"^",8)=$GET(@STAT@("PORT"))
+28 SET $PIECE(NODE,"^",20)=$GET(@STAT)
+29 SET $PIECE(NODE,"^",21)=$GET(@STAT@("ERROR TEXT"))
+30 SET $PIECE(NODE,"^",16)=HLMSTATE("DT/TM")
+31 SET APP=$SELECT(HLMSTATE("DIRECTION")="OUT":HLMSTATE("HDR","SENDING APPLICATION"),1:HLMSTATE("HDR","RECEIVING APPLICATION"))
+32 IF HLMSTATE("BATCH")
Begin DoDot:1
+33 SET RTNTN=$$RTNTN^HLOAPP(APP)
End DoDot:1
+34 IF '$TEST
Begin DoDot:1
+35 SET RTNTN=$$RTNTN^HLOAPP(APP,HLMSTATE("HDR","MESSAGE TYPE"),HLMSTATE("HDR","EVENT"),HLMSTATE("HDR","VERSION"))
End DoDot:1
+36 SET $PIECE(NODE,"^",22)=RTNTN
+37 IF HLMSTATE("BATCH")
IF HLMSTATE("SYSTEM","ERROR PURGE")>RTNTN
SET RTNTN=HLMSTATE("SYSTEM","ERROR PURGE")
+38 IF 'HLMSTATE("BATCH")
IF HLMSTATE("SYSTEM","NORMAL PURGE")>RTNTN
SET RTNTN=HLMSTATE("SYSTEM","NORMAL PURGE")
+39 SET HLMSTATE("RETENTION")=RTNTN
+40 ;
+41 IF HLMSTATE("DIRECTION")="OUT"
Begin DoDot:1
+42 SET $PIECE(NODE,"^",10)=$PIECE($GET(@STAT@("APP ACK RESPONSE")),"^")
+43 SET $PIECE(NODE,"^",11)=$PIECE($GET(@STAT@("APP ACK RESPONSE")),"^",2)
+44 SET $PIECE(NODE,"^",12)=$PIECE($GET(@STAT@("ACCEPT ACK RESPONSE")),"^")
+45 SET $PIECE(NODE,"^",13)=$PIECE($GET(@STAT@("ACCEPT ACK RESPONSE")),"^",2)
+46 SET $PIECE(NODE,"^",14)=$PIECE($GET(@STAT@("FAILURE RESPONSE")),"^")
+47 SET $PIECE(NODE,"^",15)=$PIECE($GET(@STAT@("FAILURE RESPONSE")),"^",2)
+48 ;
+49 ;for outgoing set these x-refs now, for incoming msgs set them later
+50 SET ^HLB("B",ID,IEN)=""
+51 SET ^HLB("C",HLMSTATE("BODY"),IEN)=""
+52 IF ($GET(@STAT)="ER")
Begin DoDot:2
+53 SET ^HLB("ERRORS",$SELECT($LENGTH($GET(HLMSTATE("HDR","RECEIVING APPLICATION"))):HLMSTATE("HDR","RECEIVING APPLICATION"),1:"UNKNOWN"),HLMSTATE("DT/TM CREATED"),IEN)=""
+54 DO COUNT^HLOESTAT("OUT",$GET(HLMSTATE("HDR","RECEIVING APPLICATION")),$GET(HLMSTATE("HDR","SENDING APPLICATION")),$SELECT(HLMSTATE("BATCH"):"BATCH",1:$GET(HLMSTATE("HDR","MESSAGE TYPE"))),$GET(HLMSTATE("HDR","EVENT")))
End DoDot:2
+55 ;
+56 ;save some space for the ack
+57 if ($GET(HLMSTATE("HDR","ACCEPT ACK TYPE"))="AL")
SET ^HLB(IEN,4)="^^^ "
End DoDot:1
+58 IF $GET(HLMSTATE("STATUS","PURGE"))
SET $PIECE(NODE,"^",9)=HLMSTATE("STATUS","PURGE")
SET ^HLB("AD","OUT",HLMSTATE("STATUS","PURGE"),HLMSTATE("IEN"))=""
+59 SET ^HLB(IEN,0)=NODE
+60 ;
+61 ;store the message header
+62 SET ^HLB(IEN,1)=HLMSTATE("HDR",1)
+63 SET ^HLB(IEN,2)=HLMSTATE("HDR",2)
+64 ;
+65 ;if the msg is an app ack, update the original msg
+66 IF $GET(HLMSTATE("ACK TO IEN"))]""
Begin DoDot:1
+67 NEW ACKTO
+68 MERGE ACKTO=HLMSTATE("ACK TO")
+69 SET ACKTO("IEN")=HLMSTATE("ACK TO IEN")
+70 SET ACKTO("ACK BY")=$SELECT(HLMSTATE("BATCH"):HLMSTATE("HDR","BATCH CONTROL ID"),1:HLMSTATE("HDR","MESSAGE CONTROL ID"))
+71 DO ACKTO^HLOF778(.HLMSTATE,.ACKTO)
+72 ;because the update was already done, otherwise it might be done again
SET HLMSTATE("ACK TO","DONE")=1
End DoDot:1
+73 ;
+74 ;The "SEARCH" x-ref will be created asynchronously
+75 SET ^HLTMP("PENDING SEARCH X-REF",$JOB,HLMSTATE("DT/TM CREATED"),IEN)=""
+76 ;
+77 ;sequence q?
+78 IF HLMSTATE("DIRECTION")="OUT"
IF $GET(@STAT@("SEQUENCE QUEUE"))'=""
SET ^HLB(IEN,5)=@STAT@("SEQUENCE QUEUE")
+79 ;
+80 QUIT IEN
+81 ;
NEWIEN(DIR,TCP) ;
+1 ;This function uses a counter to get the next available ien for file 778. There are 4 different counters, each assigned as range of numbers, selected via the input parameters. It does not create a record.
+2 ;Inputs:
+3 ; DIR = "IN" or "OUT" (required)
+4 ; TCP = 1,0 (optional)
+5 ;Output - the function returns the next available ien. Several counters are used:
+6 ;
+7 ; <"OUT","TCP">
+8 ; <"OUT","NOT TCP">
+9 ; <"IN","TCP">
+10 ; <"IN","NOT TCP">
+11 ;
+12 NEW IEN,COUNTER,INC
+13 IF DIR="OUT"
SET INC=$SELECT(+$GET(TCP):0,1:100000000000)
+14 IF DIR="IN"
SET INC=$SELECT(+$GET(TCP):200000000000,1:300000000000)
+15 SET COUNTER=$NAME(^HLC("FILE778",DIR,$SELECT(+$GET(TCP):"TCP",1:"NOT TCP")))
AGAIN ;
+1 SET IEN=$$INC^HLOSITE(COUNTER,1)
+2 IF IEN>100000000000
Begin DoDot:1
+3 LOCK +@COUNTER:200
+4 IF $TEST
IF @COUNTER>100000000000
SET @COUNTER=1
SET IEN=1
+5 LOCK -@COUNTER
End DoDot:1
+6 IF IEN>100000000000
GOTO AGAIN
+7 QUIT (IEN+INC)
+8 ;
TCP() ;checks the link to see if its TCP, return 1 if yes, 0 if no or not defined
+1 NEW IEN,TCP
+2 SET TCP=1
+3 SET IEN=$GET(HLMSTATE("STATUS","LINK IEN"))
+4 IF IEN
IF $PIECE($GET(^HLCS(869.1,+$PIECE($GET(^HLCS(870,IEN,0)),"^",3),0)),"^")'="TCP"
SET TCP=0
+5 QUIT TCP
+6 ;
GETWORK(WORK) ; Used by the Process Manager.
+1 ;Are there any messages that need the "SEARCH" x-ref set?
+2 ;Inputs:
+3 ; WORK (required, pass-by-reference)
+4 ; ("DOLLARJ")
+5 ; ("NOW") (required by the process manager, pass-by-reference)
+6 ;
+7 LOCK +^HLTMP("PENDING SEARCH X-REF"):0
+8 if '$TEST
QUIT 0
+9 NEW OLD,DOLLARJ,SUCCESS,NOW
+10 SET SUCCESS=0
+11 SET NOW=$$SEC^XLFDT($HOROLOG)
+12 SET (OLD,DOLLARJ)=$GET(WORK("DOLLARJ"))
+13 FOR
SET DOLLARJ=$ORDER(^HLTMP("PENDING SEARCH X-REF",DOLLARJ))
if DOLLARJ=""
QUIT
Begin DoDot:1
+14 NEW TIME
SET TIME=$ORDER(^HLTMP("PENDING SEARCH X-REF",DOLLARJ,""))
+15 if (NOW-$$SEC^XLFDT(TIME)>10)
SET SUCCESS=1
End DoDot:1
if SUCCESS
QUIT
+16 ;
+17 IF OLD'=""
IF 'SUCCESS
FOR
SET DOLLARJ=$ORDER(^HLTMP("PENDING SEARCH X-REF",DOLLARJ))
if DOLLARJ=""
QUIT
if DOLLARJ>OLD
QUIT
Begin DoDot:1
+18 NEW TIME
SET TIME=$ORDER(^HLTMP("PENDING SEARCH X-REF",DOLLARJ,""))
+19 if (NOW-$$SEC^XLFDT(TIME)>10)
SET SUCCESS=1
End DoDot:1
if SUCCESS
QUIT
+20 SET WORK("DOLLARJ")=DOLLARJ
SET WORK("NOW")=NOW
+21 if WORK("DOLLARJ")]""
QUIT 1
+22 LOCK -^HLTMP("PENDING SEARCH X-REF")
+23 QUIT 0
+24 ;
DOWORK(WORK) ;Used by the Process Manager
+1 ;Sets the "SEARCH" x-ref, running 10 seconds behind when the message record was created.
+2 ;
+3 NEW MSGIEN,TIME
+4 SET TIME=0
+5 FOR
SET TIME=$ORDER(^HLTMP("PENDING SEARCH X-REF",WORK("DOLLARJ"),TIME))
if 'TIME
QUIT
if ((WORK("NOW")-$$SEC^XLFDT(TIME))<10)
QUIT
Begin DoDot:1
+6 SET MSGIEN=0
+7 FOR
SET MSGIEN=$ORDER(^HLTMP("PENDING SEARCH X-REF",WORK("DOLLARJ"),TIME,MSGIEN))
if 'MSGIEN
QUIT
Begin DoDot:2
+8 NEW MSG
+9 IF $$GETMSG^HLOMSG(MSGIEN,.MSG)
Begin DoDot:3
+10 if 'MSG("DT/TM CREATED")
QUIT
+11 IF MSG("BATCH")
Begin DoDot:4
+12 NEW HDR
+13 FOR
if '$$NEXTMSG^HLOMSG(.MSG,.HDR)
QUIT
SET MSG("HDR",1)=HDR(1)
SET MSG("HDR",2)=HDR(2)
DO SET(.MSG)
End DoDot:4
+14 IF '$TEST
Begin DoDot:4
+15 DO SET(.MSG)
End DoDot:4
End DoDot:3
+16 KILL ^HLTMP("PENDING SEARCH X-REF",WORK("DOLLARJ"),TIME,MSGIEN)
End DoDot:2
End DoDot:1
+17 LOCK -^HLTMP("PENDING SEARCH X-REF")
+18 QUIT
+19 ;
SET(MSG) ;
+1 ;sets the ^HLB("SEARCH") x-ref
+2 ;
+3 NEW APP,FS,CS,IEN
+4 IF MSG("DIRECTION")'="IN"
IF MSG("DIRECTION")'="OUT"
QUIT
+5 SET FS=$EXTRACT(MSG("HDR",1),4)
+6 if FS=""
QUIT
+7 SET CS=$EXTRACT(MSG("HDR",1),5)
+8 SET APP=$SELECT(MSG("DIRECTION")="IN":$PIECE($PIECE(MSG("HDR",1),FS,5),CS),1:$PIECE($PIECE(MSG("HDR",1),FS,3),CS))
+9 IF APP=""
SET APP="UNKNOWN"
+10 IF MSG("BATCH")
Begin DoDot:1
+11 NEW VALUE
+12 SET VALUE=$PIECE(MSG("HDR",2),FS,4)
+13 SET MSG("MESSAGE TYPE")=$PIECE(VALUE,CS)
+14 SET MSG("EVENT")=$PIECE(VALUE,CS,2)
End DoDot:1
+15 if MSG("MESSAGE TYPE")=""
SET MSG("MESSAGE TYPE")="<none>"
+16 if MSG("EVENT")=""
SET MSG("EVENT")="<none>"
+17 SET IEN=MSG("IEN")
+18 IF MSG("BATCH")
SET IEN=IEN_"^"_MSG("BATCH","CURRENT MESSAGE")
+19 SET ^HLB("SEARCH",MSG("DIRECTION"),MSG("DT/TM CREATED"),APP,MSG("MESSAGE TYPE"),MSG("EVENT"),IEN)=""
+20 QUIT
+21 ;
SETPURGE(MSG,MSGSTAT,MATE,MATESTAT) ; Set message up for purging.
+1 ;Resets the purge date/time.
+2 ;Input:
+3 ; MSG (required) ien of the message, file #778
+4 ; MSGSTAT (required) the status
+5 ; MATE - ien of other message if this is a two-message transaction
+6 ; MATESTAT (optional) status of mate
+7 ;Output:
+8 ; Function returns 1 on success, 0 on failure
+9 ;
+10 NEW NODE,SYSPURGE,NEWPURGE
+11 if '$GET(MSG)
QUIT 0
+12 SET NODE=$GET(^HLB(MSG,0))
+13 if NODE=""
QUIT 0
+14 if MSGSTAT=""
QUIT 0
+15 DO SYSPURGE^HLOSITE(.SYSPURGE)
+16 ;
+17 SET MSG("BODY")=+$PIECE(NODE,"^",2)
+18 SET MSG("BATCH")=$SELECT(MSG("BODY"):+$PIECE($GET(^HLA(MSG("BODY"),0)),"^",2),1:0)
+19 SET MSG("OLD PURGE")=$PIECE(NODE,"^",9)
+20 SET MSG("DIR")=$SELECT($EXTRACT($PIECE(NODE,"^",4))="I":"IN",1:"OUT")
+21 SET MSG("RETENTION")=+$PIECE(NODE,"^",22)
+22 IF 'MSG("RETENTION")
SET MSG("RETENTION")=$SELECT(MSG("BATCH"):SYSPURGE("ERROR"),1:SYSPURGE("NORMAL"))
+23 ;
+24 ;
+25 ;don't purge if the mate doesn't have a status!
IF MATE
Begin DoDot:1
+26 SET NODE=$GET(^HLB(MATE,0))
+27 IF NODE=""
KILL MATE
QUIT
+28 SET MATE("BODY")=+$PIECE(NODE,"^",2)
+29 SET MATE("BATCH")=$SELECT(MATE("BODY"):+$PIECE($GET(^HLA(MATE("BODY"),0)),"^",2),1:0)
+30 SET MATE("OLD PURGE")=$PIECE(NODE,"^",9)
+31 SET MATE("DIR")=$SELECT($EXTRACT($PIECE(NODE,"^",4))="I":"IN",1:"OUT")
+32 SET MATE("RETENTION")=+$PIECE(NODE,"^",22)
+33 IF 'MATE("RETENTION")
SET MATE("RETENTION")=$SELECT(MATE("BATCH"):SYSPURGE("ERROR"),1:SYSPURGE("NORMAL"))
+34 IF $GET(MATESTAT)=""
SET MATESTAT=$PIECE(NODE,"^",20)
End DoDot:1
IF MATE
IF MATESTAT=""
QUIT 0
+35 ;
+36 ;determine purge time
+37 SET NEWPURGE=MSG("RETENTION")
+38 IF MSGSTAT="ER"
IF SYSPURGE("ERROR")>NEWPURGE
SET NEWPURGE=SYSPURGE("ERROR")
+39 IF MATE
Begin DoDot:1
+40 IF MATE("RETENTION")>NEWPURGE
SET NEWPURGE=MATE("RETENTION")
+41 IF MATESTAT="ER"
IF SYSPURGE("ERROR")>NEWPURGE
SET NEWPURGE=SYSPURGE("ERROR")
End DoDot:1
+42 ;
+43 SET NEWPURGE=$$FMADD^XLFDT($$NOW^XLFDT,NEWPURGE)
+44 IF NEWPURGE<MSG("OLD PURGE")
SET NEWPURGE=MSG("OLD PURGE")
+45 IF NEWPURGE<$GET(MATE("OLD PURGE"))
SET NEWPURGE=MATE("OLD PURGE")
+46 IF MSG("OLD PURGE")
IF MSG("OLD PURGE")'=NEWPURGE
Begin DoDot:1
+47 KILL ^HLB("AD",MSG("DIR"),MSG("OLD PURGE"),MSG)
+48 SET $PIECE(^HLB(MSG,0),"^",9)=NEWPURGE
SET ^HLB("AD",MSG("DIR"),NEWPURGE,MSG)=""
End DoDot:1
+49 IF MATE
IF MATE("OLD PURGE")
IF MATE("OLD PURGE")'=NEWPURGE
Begin DoDot:1
+50 KILL ^HLB("AD",MATE("DIR"),MATE("OLD PURGE"),MATE)
+51 SET $PIECE(^HLB(MATE,0),"^",9)=NEWPURGE
SET ^HLB("AD",MATE("DIR"),NEWPURGE,MATE)=""
End DoDot:1
+52 IF 'MSG("OLD PURGE")
SET $PIECE(^HLB(MSG,0),"^",9)=NEWPURGE
SET ^HLB("AD",MSG("DIR"),NEWPURGE,MSG)=""
+53 IF MATE
IF 'MATE("OLD PURGE")
SET $PIECE(^HLB(MATE,0),"^",9)=NEWPURGE
SET ^HLB("AD",MATE("DIR"),NEWPURGE,MATE)=""
+54 QUIT 1
