- 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 Jan 18, 2025@02:58:05 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 ;