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

HLCSQUE.m

Go to the documentation of this file.
  1. HLCSQUE ;ALB/MFK/CJM HL7 UTILITY FUNCTIONS - 10/4/94 11AM ;02/17/2011
  1. ;;1.6;HEALTH LEVEL SEVEN;**14,61,59,153**;Oct 13, 1995;Build 11
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ENQUEUE(IEN,HLDIR) ;Assign a message for queue entry
  1. ; INPUT: IEN - Internal Entry Number for file 870 - HL7 QUEUE
  1. ; HLDIR - Direction of queue (IN/OUT)
  1. ; OUTPUT: BEG - Location in the queue to stuff the message
  1. ; -1 - Error
  1. N FRONT,BACK,DIC,DA,X,DINUM,ENTRY,Y,BPOINTER,NEWREC
  1. ; Make sure required variables were given
  1. S IEN=$G(IEN)
  1. Q:(IEN="") "-1^Queue not given"
  1. I +IEN<1 S IEN=$O(^HLCS(870,"B",IEN,""))
  1. Q:(IEN="") "-1^Invalid queue"
  1. ; Convert direction to a number
  1. S HLDIR=$G(HLDIR)
  1. Q:(HLDIR'="IN")&(HLDIR'="OUT")&(HLDIR'=1)&(HLDIR'=2) "-1^Invalid direction"
  1. S HLDIR=$S(HLDIR="IN":1,HLDIR="OUT":2,HLDIR=2:2,1:1)
  1. S BPOINTER=$S(HLDIR=1:"IN",1:"OUT")_" QUEUE BACK POINTER"
  1. S FRONT=$G(^HLCS(870,IEN,$S(HLDIR=1:"IN",1:"OUT")_" QUEUE FRONT POINTER"))
  1. D DELETE^HLCSQUE1(IEN,HLDIR,FRONT)
  1. F L +^HLCS(870,IEN,BPOINTER):20 Q:$T
  1. S BACK=$G(^HLCS(870,IEN,BPOINTER))
  1. ; Set up DICN call
  1. S DIC="^HLCS(870,"_IEN_","_HLDIR_","
  1. S ENTRY=HLDIR+18
  1. S DIC(0)="LNX",DA(1)=IEN,DIC("P")=$P(^DD(870,ENTRY,0),"^",2)
  1. S NEWREC=BACK+1
  1. S (DINUM,X)=NEWREC
  1. ; Create Record
  1. K DD,DO
  1. F D Q:Y>0 H 1
  1. .F L +^HLCS(870,IEN,HLDIR,NEWREC):20 Q:$T
  1. .D FILE^DICN
  1. .I Y=-1 L -^HLCS(870,IEN,HLDIR,NEWREC) S NEWREC=NEWREC+1,(X,DINUM)=NEWREC
  1. ; Set the 'status' to 'S' for stub
  1. S $P(^HLCS(870,IEN,HLDIR,NEWREC,0),"^",2)="S"
  1. S ^HLCS(870,IEN,BPOINTER)=NEWREC
  1. EXIT1 ; Unlock and return results
  1. L -^HLCS(870,IEN,BPOINTER)
  1. L -^HLCS(870,IEN,HLDIR,NEWREC)
  1. Q IEN_"^"_NEWREC
  1. ;
  1. DEQUEUE(IEN,HLDIR) ;Release the next message from the queue
  1. N RETURN,FRONT,FPOINTER
  1. ;
  1. N FOUND,NOMORE,NEXT,HLRTIME,STATUS
  1. ;
  1. S IEN=$G(IEN)
  1. Q:(IEN="") "-1^Queue not given"
  1. I +IEN<1 S IEN=$O(^HLCS(870,"B",IEN,""))
  1. Q:(IEN="") "-1^Invalid queue"
  1. ; Convert direction to a number
  1. S HLDIR=$G(HLDIR)
  1. Q:(HLDIR'="IN")&(HLDIR'="OUT")&(HLDIR'=1)&(HLDIR'=2) "-1^Invalid direction"
  1. S HLDIR=$S(HLDIR="IN":1,HLDIR="OUT":2,HLDIR=2:2,1:1)
  1. S FPOINTER=$S(HLDIR=1:"IN",1:"OUT")_" QUEUE FRONT POINTER"
  1. S HLRTIME=$P($G(^HLCS(870,IEN,0)),"^",22) ; retention time in minutes for stub
  1. S:HLRTIME HLRTIME=HLRTIME*60
  1. S:(HLRTIME<300) HLRTIME=600
  1. L +^HLCS(870,IEN,FPOINTER):1
  1. I '$T S RETURN="-1^NO NEXT RECORD" G EXIT2
  1. S FRONT=$G(^HLCS(870,IEN,FPOINTER))
  1. S (FOUND,NOMORE)=0
  1. F NEXT=FRONT+1:1 D Q:FOUND Q:NOMORE
  1. .F L +^HLCS(870,IEN,HLDIR,NEXT):20 Q:$T
  1. .I '$D(^HLCS(870,IEN,HLDIR,NEXT,0)) D Q:NOMORE
  1. ..;missing record
  1. ..L -^HLCS(870,IEN,HLDIR,NEXT)
  1. ..;update front pointer
  1. ..S:$O(^HLCS(870,IEN,HLDIR,NEXT)) ^HLCS(870,IEN,FPOINTER)=NEXT
  1. ..;
  1. ..;Is there another record following the missing one?
  1. ..S NEXT=$O(^HLCS(870,IEN,HLDIR,NEXT))
  1. ..I 'NEXT S NOMORE=1,RETURN="-1^NO NEXT RECORD" Q
  1. ..;
  1. ..;The next record after missing record has been found - lock it!
  1. ..F L +^HLCS(870,IEN,HLDIR,NEXT):20 Q:$T
  1. ..;
  1. .;A record has been found.
  1. .S STATUS=$P($G(^HLCS(870,IEN,HLDIR,NEXT,0)),"^",2)
  1. .;Is it a pending message, a stub, or done?
  1. .I STATUS="P" D
  1. ..;it is a pending message, so should be returned.
  1. ..S FOUND=1,RETURN=IEN_"^"_NEXT
  1. ..;
  1. .E D
  1. ..;if the record is DONE then the front pointer is wrong - fix it and try again!
  1. ..I STATUS="D" S ^HLCS(870,IEN,FPOINTER)=NEXT Q
  1. ..;
  1. ..;Must be a stub record
  1. ..;
  1. ..;discard 'old' stub records
  1. ..N HLDT1
  1. ..S HLDT1=$P($G(^HLCS(870,IEN,HLDIR,NEXT,0)),"^",10)
  1. ..I 'HLDT1 D Q
  1. ...;not an old stub record - can not discard
  1. ...S $P(^HLCS(870,IEN,HLDIR,NEXT,0),"^",10)=$$NOW^XLFDT,NOMORE=1,RETURN="-1^STUB"
  1. ..;
  1. ..I $$FMDIFF^XLFDT($$NOW^XLFDT,HLDT1,2)>HLRTIME D
  1. ...;Is an old stub record - should continue on to the next record
  1. ...S $P(^HLCS(870,IEN,HLDIR,NEXT,0),"^",2)="U"
  1. ...;update front pointer
  1. ...S ^HLCS(870,IEN,FPOINTER)=NEXT
  1. ..E D
  1. ...;not an old stub record - should NOT continue to next record
  1. ...S NOMORE=1,RETURN="-1^STUB"
  1. .;
  1. .L -^HLCS(870,IEN,HLDIR,NEXT)
  1. ;
  1. S:FOUND ^HLCS(870,IEN,FPOINTER)=NEXT
  1. EXIT2 L -^HLCS(870,IEN,FPOINTER)
  1. Q RETURN
  1. ;
  1. CLEARQUE(IEN,HLDIR) ;Empty an entire queue
  1. ; IEN - Entry number for queue - can be name from "B" X-ref
  1. ; HLDIR - Can be "IN", "OUT", 1 or 2.
  1. ; output: 0 for success
  1. ; -1^error for error
  1. N MSG,X,ERR,FP,BP
  1. ;NOTE: this is not needed to initialize a queue
  1. ; enqueue will set up (?) a new queue
  1. ; Make sure that required variables exist
  1. S IEN=$G(IEN)
  1. Q:(IEN="") "-1^Internal Entry Number missing"
  1. I +IEN<1 S IEN=$O(^HLCS(870,"B",IEN,""))
  1. Q:(IEN="") "-1^Invalid IEN"
  1. ; Convert direction to a number
  1. S HLDIR=$G(HLDIR)
  1. Q:(HLDIR'="IN")&(HLDIR'="OUT")&(HLDIR'=1)&(HLDIR'=2) "-1^Invalid direction"
  1. S HLDIR=$S(HLDIR="IN":1,HLDIR="OUT":2,HLDIR=2:2,1:1)
  1. ; If in queue, set front pointer to 6, out pointer gets set to 8
  1. I HLDIR=1 S FP="IN QUEUE FRONT POINTER",BP="IN QUEUE BACK POINTER"
  1. I HLDIR=2 S FP="OUT QUEUE FRONT POINTER",BP="OUT QUEUE BACK POINTER"
  1. S MSG=0
  1. W !
  1. ; Loop through and delete messages
  1. F S MSG=$O(^HLCS(870,IEN,HLDIR,MSG)) Q:(MSG'>0) D
  1. .S ERR=$$DELMSG^HLCSQUE1(IEN,HLDIR,MSG) W "."
  1. .I ERR W ERR,!
  1. ; Clear front and back pointers
  1. S ^HLCS(870,IEN,FP)=0
  1. S ^HLCS(870,IEN,BP)=0
  1. ;K IEN,HLDIR
  1. Q 0
  1. ;
  1. PUSH(HLDOUT0,HLDOUT1) ;-- Place message back on queue
  1. ; INPUT - HLDOUT0 IEN of file 870
  1. ; HLDOUT1 IEN of Out Multiple
  1. ; OUTPUT- NONE
  1. ;
  1. ;-- exit if not vaild variables
  1. I 'HLDOUT0!'HLDOUT1 G PUSHQ
  1. ;-- exit if global does not already exist
  1. I '$D(^HLCS(870,HLDOUT0,"OUT QUEUE FRONT POINTER")) G PUSHQ
  1. S ^HLCS(870,HLDOUT0,"OUT QUEUE FRONT POINTER")=(HLDOUT1-1)
  1. PUSHQ Q
  1. ;