- 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 Jan 18, 2025@02:59:59 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