Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: HLOF778A

HLOF778A.m

Go to the documentation of this file.
  1. 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
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ;
  1. NEW(HLMSTATE) ;
  1. ;This function creates a new entry in file 778.
  1. ;Input:
  1. ; HLMSTATE (required, pass by reference) These subscripts are expected:
  1. ;
  1. ;Output - the function returns the ien of the newly created record
  1. ;
  1. N IEN,NODE,ID,STAT,RTNTN,APP
  1. S STAT="HLMSTATE(""STATUS"")"
  1. S IEN=$$NEWIEN(HLMSTATE("DIRECTION"),$$TCP)
  1. Q:'IEN 0
  1. S HLMSTATE("IEN")=IEN
  1. ;
  1. D ;build the message header
  1. .N HDR
  1. .;for incoming messages the header segment should already exist
  1. .;for outgoing messages must build the header segment
  1. .I HLMSTATE("DIRECTION")="OUT" D Q
  1. ..I HLMSTATE("BATCH"),$G(HLMSTATE("ACK TO"))]"" S HLMSTATE("HDR","REFERENCE BATCH CONTROL ID")=HLMSTATE("ACK TO")
  1. ..D BUILDHDR^HLOPBLD1(.HLMSTATE,$S(HLMSTATE("BATCH"):"BHS",1:"MSH"),.HDR)
  1. ..S HLMSTATE("HDR",1)=HDR(1),HLMSTATE("HDR",2)=HDR(2)
  1. ;
  1. K ^HLB(IEN)
  1. S ID=$S(HLMSTATE("BATCH"):HLMSTATE("HDR","BATCH CONTROL ID"),1:HLMSTATE("HDR","MESSAGE CONTROL ID"))
  1. S NODE=ID_"^"_HLMSTATE("BODY")_"^"_$G(HLMSTATE("ACK TO"))_"^"_$S(HLMSTATE("DIRECTION")="IN":"I",1:"O")_"^"
  1. S $P(NODE,"^",5)=$G(@STAT@("LINK NAME"))
  1. S $P(NODE,"^",6)=$G(@STAT@("QUEUE"))
  1. S $P(NODE,"^",8)=$G(@STAT@("PORT"))
  1. S $P(NODE,"^",20)=$G(@STAT)
  1. S $P(NODE,"^",21)=$G(@STAT@("ERROR TEXT"))
  1. S $P(NODE,"^",16)=HLMSTATE("DT/TM")
  1. S APP=$S(HLMSTATE("DIRECTION")="OUT":HLMSTATE("HDR","SENDING APPLICATION"),1:HLMSTATE("HDR","RECEIVING APPLICATION"))
  1. I HLMSTATE("BATCH") D
  1. .S RTNTN=$$RTNTN^HLOAPP(APP)
  1. E D
  1. .S RTNTN=$$RTNTN^HLOAPP(APP,HLMSTATE("HDR","MESSAGE TYPE"),HLMSTATE("HDR","EVENT"),HLMSTATE("HDR","VERSION"))
  1. S $P(NODE,"^",22)=RTNTN
  1. I HLMSTATE("BATCH"),HLMSTATE("SYSTEM","ERROR PURGE")>RTNTN S RTNTN=HLMSTATE("SYSTEM","ERROR PURGE")
  1. I 'HLMSTATE("BATCH"),HLMSTATE("SYSTEM","NORMAL PURGE")>RTNTN S RTNTN=HLMSTATE("SYSTEM","NORMAL PURGE")
  1. S HLMSTATE("RETENTION")=RTNTN
  1. ;
  1. I HLMSTATE("DIRECTION")="OUT" D
  1. .S $P(NODE,"^",10)=$P($G(@STAT@("APP ACK RESPONSE")),"^")
  1. .S $P(NODE,"^",11)=$P($G(@STAT@("APP ACK RESPONSE")),"^",2)
  1. .S $P(NODE,"^",12)=$P($G(@STAT@("ACCEPT ACK RESPONSE")),"^")
  1. .S $P(NODE,"^",13)=$P($G(@STAT@("ACCEPT ACK RESPONSE")),"^",2)
  1. .S $P(NODE,"^",14)=$P($G(@STAT@("FAILURE RESPONSE")),"^")
  1. .S $P(NODE,"^",15)=$P($G(@STAT@("FAILURE RESPONSE")),"^",2)
  1. .;
  1. .;for outgoing set these x-refs now, for incoming msgs set them later
  1. .S ^HLB("B",ID,IEN)=""
  1. .S ^HLB("C",HLMSTATE("BODY"),IEN)=""
  1. .I ($G(@STAT)="ER") D
  1. ..S ^HLB("ERRORS",$S($L($G(HLMSTATE("HDR","RECEIVING APPLICATION"))):HLMSTATE("HDR","RECEIVING APPLICATION"),1:"UNKNOWN"),HLMSTATE("DT/TM CREATED"),IEN)=""
  1. ..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")))
  1. .;
  1. .;save some space for the ack
  1. .S:($G(HLMSTATE("HDR","ACCEPT ACK TYPE"))="AL") ^HLB(IEN,4)="^^^ "
  1. I $G(HLMSTATE("STATUS","PURGE")) S $P(NODE,"^",9)=HLMSTATE("STATUS","PURGE"),^HLB("AD","OUT",HLMSTATE("STATUS","PURGE"),HLMSTATE("IEN"))=""
  1. S ^HLB(IEN,0)=NODE
  1. ;
  1. ;store the message header
  1. S ^HLB(IEN,1)=HLMSTATE("HDR",1)
  1. S ^HLB(IEN,2)=HLMSTATE("HDR",2)
  1. ;
  1. ;if the msg is an app ack, update the original msg
  1. I $G(HLMSTATE("ACK TO IEN"))]"" D
  1. .N ACKTO
  1. .M ACKTO=HLMSTATE("ACK TO")
  1. .S ACKTO("IEN")=HLMSTATE("ACK TO IEN")
  1. .S ACKTO("ACK BY")=$S(HLMSTATE("BATCH"):HLMSTATE("HDR","BATCH CONTROL ID"),1:HLMSTATE("HDR","MESSAGE CONTROL ID"))
  1. .D ACKTO^HLOF778(.HLMSTATE,.ACKTO)
  1. .S HLMSTATE("ACK TO","DONE")=1 ;because the update was already done, otherwise it might be done again
  1. ;
  1. ;The "SEARCH" x-ref will be created asynchronously
  1. S ^HLTMP("PENDING SEARCH X-REF",$J,HLMSTATE("DT/TM CREATED"),IEN)=""
  1. ;
  1. ;sequence q?
  1. I HLMSTATE("DIRECTION")="OUT",$G(@STAT@("SEQUENCE QUEUE"))'="" S ^HLB(IEN,5)=@STAT@("SEQUENCE QUEUE")
  1. ;
  1. Q IEN
  1. ;
  1. 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.
  1. ;Inputs:
  1. ; DIR = "IN" or "OUT" (required)
  1. ; TCP = 1,0 (optional)
  1. ;Output - the function returns the next available ien. Several counters are used:
  1. ;
  1. ; <"OUT","TCP">
  1. ; <"OUT","NOT TCP">
  1. ; <"IN","TCP">
  1. ; <"IN","NOT TCP">
  1. ;
  1. N IEN,COUNTER,INC
  1. I DIR="OUT" S INC=$S(+$G(TCP):0,1:100000000000)
  1. I DIR="IN" S INC=$S(+$G(TCP):200000000000,1:300000000000)
  1. S COUNTER=$NA(^HLC("FILE778",DIR,$S(+$G(TCP):"TCP",1:"NOT TCP")))
  1. AGAIN ;
  1. S IEN=$$INC^HLOSITE(COUNTER,1)
  1. I IEN>100000000000 D
  1. .L +@COUNTER:200
  1. .I $T,@COUNTER>100000000000 S @COUNTER=1,IEN=1
  1. .L -@COUNTER
  1. I IEN>100000000000 G AGAIN
  1. Q (IEN+INC)
  1. ;
  1. TCP() ;checks the link to see if its TCP, return 1 if yes, 0 if no or not defined
  1. N IEN,TCP
  1. S TCP=1
  1. S IEN=$G(HLMSTATE("STATUS","LINK IEN"))
  1. I IEN,$P($G(^HLCS(869.1,+$P($G(^HLCS(870,IEN,0)),"^",3),0)),"^")'="TCP" S TCP=0
  1. Q TCP
  1. ;
  1. GETWORK(WORK) ; Used by the Process Manager.
  1. ;Are there any messages that need the "SEARCH" x-ref set?
  1. ;Inputs:
  1. ; WORK (required, pass-by-reference)
  1. ; ("DOLLARJ")
  1. ; ("NOW") (required by the process manager, pass-by-reference)
  1. ;
  1. L +^HLTMP("PENDING SEARCH X-REF"):0
  1. Q:'$T 0
  1. N OLD,DOLLARJ,SUCCESS,NOW
  1. S SUCCESS=0
  1. S NOW=$$SEC^XLFDT($H)
  1. S (OLD,DOLLARJ)=$G(WORK("DOLLARJ"))
  1. F S DOLLARJ=$O(^HLTMP("PENDING SEARCH X-REF",DOLLARJ)) Q:DOLLARJ="" D Q:SUCCESS
  1. .N TIME S TIME=$O(^HLTMP("PENDING SEARCH X-REF",DOLLARJ,""))
  1. .S:(NOW-$$SEC^XLFDT(TIME)>10) SUCCESS=1
  1. ;
  1. I OLD'="",'SUCCESS F S DOLLARJ=$O(^HLTMP("PENDING SEARCH X-REF",DOLLARJ)) Q:DOLLARJ="" Q:DOLLARJ>OLD D Q:SUCCESS
  1. .N TIME S TIME=$O(^HLTMP("PENDING SEARCH X-REF",DOLLARJ,""))
  1. .S:(NOW-$$SEC^XLFDT(TIME)>10) SUCCESS=1
  1. S WORK("DOLLARJ")=DOLLARJ,WORK("NOW")=NOW
  1. Q:WORK("DOLLARJ")]"" 1
  1. L -^HLTMP("PENDING SEARCH X-REF")
  1. Q 0
  1. ;
  1. DOWORK(WORK) ;Used by the Process Manager
  1. ;Sets the "SEARCH" x-ref, running 10 seconds behind when the message record was created.
  1. ;
  1. N MSGIEN,TIME
  1. S TIME=0
  1. F S TIME=$O(^HLTMP("PENDING SEARCH X-REF",WORK("DOLLARJ"),TIME)) Q:'TIME Q:((WORK("NOW")-$$SEC^XLFDT(TIME))<10) D
  1. .S MSGIEN=0
  1. .F S MSGIEN=$O(^HLTMP("PENDING SEARCH X-REF",WORK("DOLLARJ"),TIME,MSGIEN)) Q:'MSGIEN D
  1. ..N MSG
  1. ..I $$GETMSG^HLOMSG(MSGIEN,.MSG) D
  1. ...Q:'MSG("DT/TM CREATED")
  1. ...I MSG("BATCH") D
  1. ....N HDR
  1. ....F Q:'$$NEXTMSG^HLOMSG(.MSG,.HDR) S MSG("HDR",1)=HDR(1),MSG("HDR",2)=HDR(2) D SET(.MSG)
  1. ...E D
  1. ....D SET(.MSG)
  1. ..K ^HLTMP("PENDING SEARCH X-REF",WORK("DOLLARJ"),TIME,MSGIEN)
  1. L -^HLTMP("PENDING SEARCH X-REF")
  1. Q
  1. ;
  1. SET(MSG) ;
  1. ;sets the ^HLB("SEARCH") x-ref
  1. ;
  1. N APP,FS,CS,IEN
  1. I MSG("DIRECTION")'="IN",MSG("DIRECTION")'="OUT" Q
  1. S FS=$E(MSG("HDR",1),4)
  1. Q:FS=""
  1. S CS=$E(MSG("HDR",1),5)
  1. S APP=$S(MSG("DIRECTION")="IN":$P($P(MSG("HDR",1),FS,5),CS),1:$P($P(MSG("HDR",1),FS,3),CS))
  1. I APP="" S APP="UNKNOWN"
  1. I MSG("BATCH") D
  1. .N VALUE
  1. .S VALUE=$P(MSG("HDR",2),FS,4)
  1. .S MSG("MESSAGE TYPE")=$P(VALUE,CS)
  1. .S MSG("EVENT")=$P(VALUE,CS,2)
  1. S:MSG("MESSAGE TYPE")="" MSG("MESSAGE TYPE")="<none>"
  1. S:MSG("EVENT")="" MSG("EVENT")="<none>"
  1. S IEN=MSG("IEN")
  1. I MSG("BATCH") S IEN=IEN_"^"_MSG("BATCH","CURRENT MESSAGE")
  1. S ^HLB("SEARCH",MSG("DIRECTION"),MSG("DT/TM CREATED"),APP,MSG("MESSAGE TYPE"),MSG("EVENT"),IEN)=""
  1. Q
  1. ;
  1. SETPURGE(MSG,MSGSTAT,MATE,MATESTAT) ; Set message up for purging.
  1. ;Resets the purge date/time.
  1. ;Input:
  1. ; MSG (required) ien of the message, file #778
  1. ; MSGSTAT (required) the status
  1. ; MATE - ien of other message if this is a two-message transaction
  1. ; MATESTAT (optional) status of mate
  1. ;Output:
  1. ; Function returns 1 on success, 0 on failure
  1. ;
  1. N NODE,SYSPURGE,NEWPURGE
  1. Q:'$G(MSG) 0
  1. S NODE=$G(^HLB(MSG,0))
  1. Q:NODE="" 0
  1. Q:MSGSTAT="" 0
  1. D SYSPURGE^HLOSITE(.SYSPURGE)
  1. ;
  1. S MSG("BODY")=+$P(NODE,"^",2)
  1. S MSG("BATCH")=$S(MSG("BODY"):+$P($G(^HLA(MSG("BODY"),0)),"^",2),1:0)
  1. S MSG("OLD PURGE")=$P(NODE,"^",9)
  1. S MSG("DIR")=$S($E($P(NODE,"^",4))="I":"IN",1:"OUT")
  1. S MSG("RETENTION")=+$P(NODE,"^",22)
  1. I 'MSG("RETENTION") S MSG("RETENTION")=$S(MSG("BATCH"):SYSPURGE("ERROR"),1:SYSPURGE("NORMAL"))
  1. ;
  1. ;
  1. I MATE D I MATE,MATESTAT="" Q 0 ;don't purge if the mate doesn't have a status!
  1. .S NODE=$G(^HLB(MATE,0))
  1. .I NODE="" K MATE Q
  1. .S MATE("BODY")=+$P(NODE,"^",2)
  1. .S MATE("BATCH")=$S(MATE("BODY"):+$P($G(^HLA(MATE("BODY"),0)),"^",2),1:0)
  1. .S MATE("OLD PURGE")=$P(NODE,"^",9)
  1. .S MATE("DIR")=$S($E($P(NODE,"^",4))="I":"IN",1:"OUT")
  1. .S MATE("RETENTION")=+$P(NODE,"^",22)
  1. .I 'MATE("RETENTION") S MATE("RETENTION")=$S(MATE("BATCH"):SYSPURGE("ERROR"),1:SYSPURGE("NORMAL"))
  1. .I $G(MATESTAT)="" S MATESTAT=$P(NODE,"^",20)
  1. ;
  1. ;determine purge time
  1. S NEWPURGE=MSG("RETENTION")
  1. I MSGSTAT="ER",SYSPURGE("ERROR")>NEWPURGE S NEWPURGE=SYSPURGE("ERROR")
  1. I MATE D
  1. .I MATE("RETENTION")>NEWPURGE S NEWPURGE=MATE("RETENTION")
  1. .I MATESTAT="ER",SYSPURGE("ERROR")>NEWPURGE S NEWPURGE=SYSPURGE("ERROR")
  1. ;
  1. S NEWPURGE=$$FMADD^XLFDT($$NOW^XLFDT,NEWPURGE)
  1. I NEWPURGE<MSG("OLD PURGE") S NEWPURGE=MSG("OLD PURGE")
  1. I NEWPURGE<$G(MATE("OLD PURGE")) S NEWPURGE=MATE("OLD PURGE")
  1. I MSG("OLD PURGE"),MSG("OLD PURGE")'=NEWPURGE D
  1. .K ^HLB("AD",MSG("DIR"),MSG("OLD PURGE"),MSG)
  1. .S $P(^HLB(MSG,0),"^",9)=NEWPURGE,^HLB("AD",MSG("DIR"),NEWPURGE,MSG)=""
  1. I MATE,MATE("OLD PURGE"),MATE("OLD PURGE")'=NEWPURGE D
  1. .K ^HLB("AD",MATE("DIR"),MATE("OLD PURGE"),MATE)
  1. .S $P(^HLB(MATE,0),"^",9)=NEWPURGE,^HLB("AD",MATE("DIR"),NEWPURGE,MATE)=""
  1. I 'MSG("OLD PURGE") S $P(^HLB(MSG,0),"^",9)=NEWPURGE,^HLB("AD",MSG("DIR"),NEWPURGE,MSG)=""
  1. I MATE,'MATE("OLD PURGE") S $P(^HLB(MATE,0),"^",9)=NEWPURGE,^HLB("AD",MATE("DIR"),NEWPURGE,MATE)=""
  1. Q 1