HLCSQUE ;ALB/MFK/CJM HL7 UTILITY FUNCTIONS - 10/4/94 11AM ;02/17/2011
;;1.6;HEALTH LEVEL SEVEN;**14,61,59,153**;Oct 13, 1995;Build 11
;Per VHA Directive 2004-038, this routine should not be modified.
ENQUEUE(IEN,HLDIR) ;Assign a message for queue entry
; INPUT: IEN - Internal Entry Number for file 870 - HL7 QUEUE
; HLDIR - Direction of queue (IN/OUT)
; OUTPUT: BEG - Location in the queue to stuff the message
; -1 - Error
N FRONT,BACK,DIC,DA,X,DINUM,ENTRY,Y,BPOINTER,NEWREC
; Make sure required variables were given
S IEN=$G(IEN)
Q:(IEN="") "-1^Queue not given"
I +IEN<1 S IEN=$O(^HLCS(870,"B",IEN,""))
Q:(IEN="") "-1^Invalid queue"
; Convert direction to a number
S HLDIR=$G(HLDIR)
Q:(HLDIR'="IN")&(HLDIR'="OUT")&(HLDIR'=1)&(HLDIR'=2) "-1^Invalid direction"
S HLDIR=$S(HLDIR="IN":1,HLDIR="OUT":2,HLDIR=2:2,1:1)
S BPOINTER=$S(HLDIR=1:"IN",1:"OUT")_" QUEUE BACK POINTER"
S FRONT=$G(^HLCS(870,IEN,$S(HLDIR=1:"IN",1:"OUT")_" QUEUE FRONT POINTER"))
D DELETE^HLCSQUE1(IEN,HLDIR,FRONT)
F L +^HLCS(870,IEN,BPOINTER):20 Q:$T
S BACK=$G(^HLCS(870,IEN,BPOINTER))
; Set up DICN call
S DIC="^HLCS(870,"_IEN_","_HLDIR_","
S ENTRY=HLDIR+18
S DIC(0)="LNX",DA(1)=IEN,DIC("P")=$P(^DD(870,ENTRY,0),"^",2)
S NEWREC=BACK+1
S (DINUM,X)=NEWREC
; Create Record
K DD,DO
F D Q:Y>0 H 1
.F L +^HLCS(870,IEN,HLDIR,NEWREC):20 Q:$T
.D FILE^DICN
.I Y=-1 L -^HLCS(870,IEN,HLDIR,NEWREC) S NEWREC=NEWREC+1,(X,DINUM)=NEWREC
; Set the 'status' to 'S' for stub
S $P(^HLCS(870,IEN,HLDIR,NEWREC,0),"^",2)="S"
S ^HLCS(870,IEN,BPOINTER)=NEWREC
EXIT1 ; Unlock and return results
L -^HLCS(870,IEN,BPOINTER)
L -^HLCS(870,IEN,HLDIR,NEWREC)
Q IEN_"^"_NEWREC
;
DEQUEUE(IEN,HLDIR) ;Release the next message from the queue
N RETURN,FRONT,FPOINTER
;
N FOUND,NOMORE,NEXT,HLRTIME,STATUS
;
S IEN=$G(IEN)
Q:(IEN="") "-1^Queue not given"
I +IEN<1 S IEN=$O(^HLCS(870,"B",IEN,""))
Q:(IEN="") "-1^Invalid queue"
; Convert direction to a number
S HLDIR=$G(HLDIR)
Q:(HLDIR'="IN")&(HLDIR'="OUT")&(HLDIR'=1)&(HLDIR'=2) "-1^Invalid direction"
S HLDIR=$S(HLDIR="IN":1,HLDIR="OUT":2,HLDIR=2:2,1:1)
S FPOINTER=$S(HLDIR=1:"IN",1:"OUT")_" QUEUE FRONT POINTER"
S HLRTIME=$P($G(^HLCS(870,IEN,0)),"^",22) ; retention time in minutes for stub
S:HLRTIME HLRTIME=HLRTIME*60
S:(HLRTIME<300) HLRTIME=600
L +^HLCS(870,IEN,FPOINTER):1
I '$T S RETURN="-1^NO NEXT RECORD" G EXIT2
S FRONT=$G(^HLCS(870,IEN,FPOINTER))
S (FOUND,NOMORE)=0
F NEXT=FRONT+1:1 D Q:FOUND Q:NOMORE
.F L +^HLCS(870,IEN,HLDIR,NEXT):20 Q:$T
.I '$D(^HLCS(870,IEN,HLDIR,NEXT,0)) D Q:NOMORE
..;missing record
..L -^HLCS(870,IEN,HLDIR,NEXT)
..;update front pointer
..S:$O(^HLCS(870,IEN,HLDIR,NEXT)) ^HLCS(870,IEN,FPOINTER)=NEXT
..;
..;Is there another record following the missing one?
..S NEXT=$O(^HLCS(870,IEN,HLDIR,NEXT))
..I 'NEXT S NOMORE=1,RETURN="-1^NO NEXT RECORD" Q
..;
..;The next record after missing record has been found - lock it!
..F L +^HLCS(870,IEN,HLDIR,NEXT):20 Q:$T
..;
.;A record has been found.
.S STATUS=$P($G(^HLCS(870,IEN,HLDIR,NEXT,0)),"^",2)
.;Is it a pending message, a stub, or done?
.I STATUS="P" D
..;it is a pending message, so should be returned.
..S FOUND=1,RETURN=IEN_"^"_NEXT
..;
.E D
..;if the record is DONE then the front pointer is wrong - fix it and try again!
..I STATUS="D" S ^HLCS(870,IEN,FPOINTER)=NEXT Q
..;
..;Must be a stub record
..;
..;discard 'old' stub records
..N HLDT1
..S HLDT1=$P($G(^HLCS(870,IEN,HLDIR,NEXT,0)),"^",10)
..I 'HLDT1 D Q
...;not an old stub record - can not discard
...S $P(^HLCS(870,IEN,HLDIR,NEXT,0),"^",10)=$$NOW^XLFDT,NOMORE=1,RETURN="-1^STUB"
..;
..I $$FMDIFF^XLFDT($$NOW^XLFDT,HLDT1,2)>HLRTIME D
...;Is an old stub record - should continue on to the next record
...S $P(^HLCS(870,IEN,HLDIR,NEXT,0),"^",2)="U"
...;update front pointer
...S ^HLCS(870,IEN,FPOINTER)=NEXT
..E D
...;not an old stub record - should NOT continue to next record
...S NOMORE=1,RETURN="-1^STUB"
.;
.L -^HLCS(870,IEN,HLDIR,NEXT)
;
S:FOUND ^HLCS(870,IEN,FPOINTER)=NEXT
EXIT2 L -^HLCS(870,IEN,FPOINTER)
Q RETURN
;
CLEARQUE(IEN,HLDIR) ;Empty an entire queue
; IEN - Entry number for queue - can be name from "B" X-ref
; HLDIR - Can be "IN", "OUT", 1 or 2.
; output: 0 for success
; -1^error for error
N MSG,X,ERR,FP,BP
;NOTE: this is not needed to initialize a queue
; enqueue will set up (?) a new queue
; Make sure that required variables exist
S IEN=$G(IEN)
Q:(IEN="") "-1^Internal Entry Number missing"
I +IEN<1 S IEN=$O(^HLCS(870,"B",IEN,""))
Q:(IEN="") "-1^Invalid IEN"
; Convert direction to a number
S HLDIR=$G(HLDIR)
Q:(HLDIR'="IN")&(HLDIR'="OUT")&(HLDIR'=1)&(HLDIR'=2) "-1^Invalid direction"
S HLDIR=$S(HLDIR="IN":1,HLDIR="OUT":2,HLDIR=2:2,1:1)
; If in queue, set front pointer to 6, out pointer gets set to 8
I HLDIR=1 S FP="IN QUEUE FRONT POINTER",BP="IN QUEUE BACK POINTER"
I HLDIR=2 S FP="OUT QUEUE FRONT POINTER",BP="OUT QUEUE BACK POINTER"
S MSG=0
W !
; Loop through and delete messages
F S MSG=$O(^HLCS(870,IEN,HLDIR,MSG)) Q:(MSG'>0) D
.S ERR=$$DELMSG^HLCSQUE1(IEN,HLDIR,MSG) W "."
.I ERR W ERR,!
; Clear front and back pointers
S ^HLCS(870,IEN,FP)=0
S ^HLCS(870,IEN,BP)=0
;K IEN,HLDIR
Q 0
;
PUSH(HLDOUT0,HLDOUT1) ;-- Place message back on queue
; INPUT - HLDOUT0 IEN of file 870
; HLDOUT1 IEN of Out Multiple
; OUTPUT- NONE
;
;-- exit if not vaild variables
I 'HLDOUT0!'HLDOUT1 G PUSHQ
;-- exit if global does not already exist
I '$D(^HLCS(870,HLDOUT0,"OUT QUEUE FRONT POINTER")) G PUSHQ
S ^HLCS(870,HLDOUT0,"OUT QUEUE FRONT POINTER")=(HLDOUT1-1)
PUSHQ Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLCSQUE 5779 printed Dec 13, 2024@01:56:50 Page 2
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
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
ENQUEUE(IEN,HLDIR) ;Assign a message for queue entry
+1 ; INPUT: IEN - Internal Entry Number for file 870 - HL7 QUEUE
+2 ; HLDIR - Direction of queue (IN/OUT)
+3 ; OUTPUT: BEG - Location in the queue to stuff the message
+4 ; -1 - Error
+5 NEW FRONT,BACK,DIC,DA,X,DINUM,ENTRY,Y,BPOINTER,NEWREC
+6 ; Make sure required variables were given
+7 SET IEN=$GET(IEN)
+8 if (IEN="")
QUIT "-1^Queue not given"
+9 IF +IEN<1
SET IEN=$ORDER(^HLCS(870,"B",IEN,""))
+10 if (IEN="")
QUIT "-1^Invalid queue"
+11 ; Convert direction to a number
+12 SET HLDIR=$GET(HLDIR)
+13 if (HLDIR'="IN")&(HLDIR'="OUT")&(HLDIR'=1)&(HLDIR'=2)
QUIT "-1^Invalid direction"
+14 SET HLDIR=$SELECT(HLDIR="IN":1,HLDIR="OUT":2,HLDIR=2:2,1:1)
+15 SET BPOINTER=$SELECT(HLDIR=1:"IN",1:"OUT")_" QUEUE BACK POINTER"
+16 SET FRONT=$GET(^HLCS(870,IEN,$SELECT(HLDIR=1:"IN",1:"OUT")_" QUEUE FRONT POINTER"))
+17 DO DELETE^HLCSQUE1(IEN,HLDIR,FRONT)
+18 FOR
LOCK +^HLCS(870,IEN,BPOINTER):20
if $TEST
QUIT
+19 SET BACK=$GET(^HLCS(870,IEN,BPOINTER))
+20 ; Set up DICN call
+21 SET DIC="^HLCS(870,"_IEN_","_HLDIR_","
+22 SET ENTRY=HLDIR+18
+23 SET DIC(0)="LNX"
SET DA(1)=IEN
SET DIC("P")=$PIECE(^DD(870,ENTRY,0),"^",2)
+24 SET NEWREC=BACK+1
+25 SET (DINUM,X)=NEWREC
+26 ; Create Record
+27 KILL DD,DO
+28 FOR
Begin DoDot:1
+29 FOR
LOCK +^HLCS(870,IEN,HLDIR,NEWREC):20
if $TEST
QUIT
+30 DO FILE^DICN
+31 IF Y=-1
LOCK -^HLCS(870,IEN,HLDIR,NEWREC)
SET NEWREC=NEWREC+1
SET (X,DINUM)=NEWREC
End DoDot:1
if Y>0
QUIT
HANG 1
+32 ; Set the 'status' to 'S' for stub
+33 SET $PIECE(^HLCS(870,IEN,HLDIR,NEWREC,0),"^",2)="S"
+34 SET ^HLCS(870,IEN,BPOINTER)=NEWREC
EXIT1 ; Unlock and return results
+1 LOCK -^HLCS(870,IEN,BPOINTER)
+2 LOCK -^HLCS(870,IEN,HLDIR,NEWREC)
+3 QUIT IEN_"^"_NEWREC
+4 ;
DEQUEUE(IEN,HLDIR) ;Release the next message from the queue
+1 NEW RETURN,FRONT,FPOINTER
+2 ;
+3 NEW FOUND,NOMORE,NEXT,HLRTIME,STATUS
+4 ;
+5 SET IEN=$GET(IEN)
+6 if (IEN="")
QUIT "-1^Queue not given"
+7 IF +IEN<1
SET IEN=$ORDER(^HLCS(870,"B",IEN,""))
+8 if (IEN="")
QUIT "-1^Invalid queue"
+9 ; Convert direction to a number
+10 SET HLDIR=$GET(HLDIR)
+11 if (HLDIR'="IN")&(HLDIR'="OUT")&(HLDIR'=1)&(HLDIR'=2)
QUIT "-1^Invalid direction"
+12 SET HLDIR=$SELECT(HLDIR="IN":1,HLDIR="OUT":2,HLDIR=2:2,1:1)
+13 SET FPOINTER=$SELECT(HLDIR=1:"IN",1:"OUT")_" QUEUE FRONT POINTER"
+14 ; retention time in minutes for stub
SET HLRTIME=$PIECE($GET(^HLCS(870,IEN,0)),"^",22)
+15 if HLRTIME
SET HLRTIME=HLRTIME*60
+16 if (HLRTIME<300)
SET HLRTIME=600
+17 LOCK +^HLCS(870,IEN,FPOINTER):1
+18 IF '$TEST
SET RETURN="-1^NO NEXT RECORD"
GOTO EXIT2
+19 SET FRONT=$GET(^HLCS(870,IEN,FPOINTER))
+20 SET (FOUND,NOMORE)=0
+21 FOR NEXT=FRONT+1:1
Begin DoDot:1
+22 FOR
LOCK +^HLCS(870,IEN,HLDIR,NEXT):20
if $TEST
QUIT
+23 IF '$DATA(^HLCS(870,IEN,HLDIR,NEXT,0))
Begin DoDot:2
+24 ;missing record
+25 LOCK -^HLCS(870,IEN,HLDIR,NEXT)
+26 ;update front pointer
+27 if $ORDER(^HLCS(870,IEN,HLDIR,NEXT))
SET ^HLCS(870,IEN,FPOINTER)=NEXT
+28 ;
+29 ;Is there another record following the missing one?
+30 SET NEXT=$ORDER(^HLCS(870,IEN,HLDIR,NEXT))
+31 IF 'NEXT
SET NOMORE=1
SET RETURN="-1^NO NEXT RECORD"
QUIT
+32 ;
+33 ;The next record after missing record has been found - lock it!
+34 FOR
LOCK +^HLCS(870,IEN,HLDIR,NEXT):20
if $TEST
QUIT
+35 ;
End DoDot:2
if NOMORE
QUIT
+36 ;A record has been found.
+37 SET STATUS=$PIECE($GET(^HLCS(870,IEN,HLDIR,NEXT,0)),"^",2)
+38 ;Is it a pending message, a stub, or done?
+39 IF STATUS="P"
Begin DoDot:2
+40 ;it is a pending message, so should be returned.
+41 SET FOUND=1
SET RETURN=IEN_"^"_NEXT
+42 ;
End DoDot:2
+43 IF '$TEST
Begin DoDot:2
+44 ;if the record is DONE then the front pointer is wrong - fix it and try again!
+45 IF STATUS="D"
SET ^HLCS(870,IEN,FPOINTER)=NEXT
QUIT
+46 ;
+47 ;Must be a stub record
+48 ;
+49 ;discard 'old' stub records
+50 NEW HLDT1
+51 SET HLDT1=$PIECE($GET(^HLCS(870,IEN,HLDIR,NEXT,0)),"^",10)
+52 IF 'HLDT1
Begin DoDot:3
+53 ;not an old stub record - can not discard
+54 SET $PIECE(^HLCS(870,IEN,HLDIR,NEXT,0),"^",10)=$$NOW^XLFDT
SET NOMORE=1
SET RETURN="-1^STUB"
End DoDot:3
QUIT
+55 ;
+56 IF $$FMDIFF^XLFDT($$NOW^XLFDT,HLDT1,2)>HLRTIME
Begin DoDot:3
+57 ;Is an old stub record - should continue on to the next record
+58 SET $PIECE(^HLCS(870,IEN,HLDIR,NEXT,0),"^",2)="U"
+59 ;update front pointer
+60 SET ^HLCS(870,IEN,FPOINTER)=NEXT
End DoDot:3
+61 IF '$TEST
Begin DoDot:3
+62 ;not an old stub record - should NOT continue to next record
+63 SET NOMORE=1
SET RETURN="-1^STUB"
End DoDot:3
End DoDot:2
+64 ;
+65 LOCK -^HLCS(870,IEN,HLDIR,NEXT)
End DoDot:1
if FOUND
QUIT
if NOMORE
QUIT
+66 ;
+67 if FOUND
SET ^HLCS(870,IEN,FPOINTER)=NEXT
EXIT2 LOCK -^HLCS(870,IEN,FPOINTER)
+1 QUIT RETURN
+2 ;
CLEARQUE(IEN,HLDIR) ;Empty an entire queue
+1 ; IEN - Entry number for queue - can be name from "B" X-ref
+2 ; HLDIR - Can be "IN", "OUT", 1 or 2.
+3 ; output: 0 for success
+4 ; -1^error for error
+5 NEW MSG,X,ERR,FP,BP
+6 ;NOTE: this is not needed to initialize a queue
+7 ; enqueue will set up (?) a new queue
+8 ; Make sure that required variables exist
+9 SET IEN=$GET(IEN)
+10 if (IEN="")
QUIT "-1^Internal Entry Number missing"
+11 IF +IEN<1
SET IEN=$ORDER(^HLCS(870,"B",IEN,""))
+12 if (IEN="")
QUIT "-1^Invalid IEN"
+13 ; Convert direction to a number
+14 SET HLDIR=$GET(HLDIR)
+15 if (HLDIR'="IN")&(HLDIR'="OUT")&(HLDIR'=1)&(HLDIR'=2)
QUIT "-1^Invalid direction"
+16 SET HLDIR=$SELECT(HLDIR="IN":1,HLDIR="OUT":2,HLDIR=2:2,1:1)
+17 ; If in queue, set front pointer to 6, out pointer gets set to 8
+18 IF HLDIR=1
SET FP="IN QUEUE FRONT POINTER"
SET BP="IN QUEUE BACK POINTER"
+19 IF HLDIR=2
SET FP="OUT QUEUE FRONT POINTER"
SET BP="OUT QUEUE BACK POINTER"
+20 SET MSG=0
+21 WRITE !
+22 ; Loop through and delete messages
+23 FOR
SET MSG=$ORDER(^HLCS(870,IEN,HLDIR,MSG))
if (MSG'>0)
QUIT
Begin DoDot:1
+24 SET ERR=$$DELMSG^HLCSQUE1(IEN,HLDIR,MSG)
WRITE "."
+25 IF ERR
WRITE ERR,!
End DoDot:1
+26 ; Clear front and back pointers
+27 SET ^HLCS(870,IEN,FP)=0
+28 SET ^HLCS(870,IEN,BP)=0
+29 ;K IEN,HLDIR
+30 QUIT 0
+31 ;
PUSH(HLDOUT0,HLDOUT1) ;-- Place message back on queue
+1 ; INPUT - HLDOUT0 IEN of file 870
+2 ; HLDOUT1 IEN of Out Multiple
+3 ; OUTPUT- NONE
+4 ;
+5 ;-- exit if not vaild variables
+6 IF 'HLDOUT0!'HLDOUT1
GOTO PUSHQ
+7 ;-- exit if global does not already exist
+8 IF '$DATA(^HLCS(870,HLDOUT0,"OUT QUEUE FRONT POINTER"))
GOTO PUSHQ
+9 SET ^HLCS(870,HLDOUT0,"OUT QUEUE FRONT POINTER")=(HLDOUT1-1)
PUSHQ QUIT
+1 ;
