HLOUSR7 ;OIFO-ALB/CJM - Deleting HLO queues ;03/26/2012
;;1.6;HEALTH LEVEL SEVEN;**147,153,158**;Oct 13, 1995;Build 14
;Per VHA Directive 2004-038, this routine should not be modified.
;
;
SPURGE ; Entry point from ListManager for deleting sequential queues.
N CONF,LINK,QUE,PORT,WHEN,COUNT,IEN
S VALMBCK="R"
D OWNSKEY^XUSRB(.CONF,"HLOMGR",DUZ)
I CONF(0)'=1 D Q
. W !,"**** You are not authorized to use this option ****" D PAUSE^VALM1 Q
S QUE=$$GETQ^HLOUSR4()
Q:QUE=""
I '$D(^HLB("QUEUE","SEQUENCE",QUE)) W !,"There are no messages on that queue!" D PAUSE^VALM1 Q
W !!,"Deleting a queue in error will result in lost messages!"
Q:'$$ASKYESNO^HLOUSR2("Are you SURE you want to delete that queue","NO")
W !!,"After removing the messages from the sequence queue they will deleted"
W !,"When do you want to schedule the messages to be purged?"
S WHEN=$$ASKWHEN($$FMADD^XLFDT($$NOW^XLFDT,7),"Date/Time to schedule purge:")
Q:'WHEN
S (IEN,COUNT)=0
F S IEN=$O(^HLB("QUEUE","SEQUENCE",QUE,IEN)) Q:'IEN S COUNT=COUNT+1 Q:COUNT>100
I COUNT>100,$$ASKTASK() D
.S ZTRTN="SEQPURGE^HLOUSR7"
.S ZTDESC="HLO QUEUE PURGE"
.S ZTDTH=$H
.S ZTIO=""
.S ZTSAVE("QUE")=QUE,ZTSAVE("WHEN")=""
.D ^%ZTLOAD
.I '$G(ZTSK) W !!,?5,"UNABLE TO SCHEDULE PURGE JOB",!
.I $G(ZTSK) W !!,?5,"Purge job is scheduled, task #"_ZTSK
.D PAUSE^VALM1
E D
.D SEQPURGE
.I $L(HLRFRSH) D @HLRFRSH
Q
;
OPURGE ; Entry point from ListManager for deleting outgoing queues.
N CONF,LINK,QUE,PORT,WHEN,COUNT,IEN
S VALMBCK="R"
D OWNSKEY^XUSRB(.CONF,"HLOMGR",DUZ)
I CONF(0)'=1 D Q
. W !,"**** You are not authorized to use this option ****" D PAUSE^VALM1 Q
S LINK=$$ASKLINK^HLOUSR
Q:LINK=""
W !
S PORT=$$ASKPORT^HLOTRACE(LINK)
I 'PORT W !,"There are no outgoing messages for that destination!" Q
S LINK=LINK_":"_PORT
W !
S QUE=$$ASKQUE^HLOTRACE(LINK)
I QUE="" W !,"There are no outgoing messages for that destination!" Q
W !!,"Deleting a queue in error will result in lost messages!"
Q:'$$ASKYESNO^HLOUSR2("Are you SURE you want to delete that queue","NO")
W !!,"After removing the messages from the outgoing queue they will deleted"
W !,"When do you want to schedule the messages to be purged?"
S WHEN=$$ASKWHEN($$FMADD^XLFDT($$NOW^XLFDT,7),"Date/Time to schedule purge:")
Q:'WHEN
S (IEN,COUNT)=0
F S IEN=$O(^HLB("QUEUE","OUT",LINK,QUE,IEN)) Q:'IEN S COUNT=COUNT+1 Q:COUNT>100
I COUNT>100,$$ASKTASK() D
.S ZTRTN="OUTPURGE^HLOUSR7"
.S ZTDESC="HLO QUEUE PURGE"
.S ZTDTH=$H
.S ZTIO=""
.S ZTSAVE("LINK")="",ZTSAVE("QUE")=QUE,ZTSAVE("WHEN")=""
.D ^%ZTLOAD
.I '$G(ZTSK) W !!,?5,"UNABLE TO SCHEDULE PURGE JOB",!
.I $G(ZTSK) W !!,?5,"Purge job is scheduled, task #"_ZTSK
.D PAUSE^VALM1
E D
.D OUTPURGE
.D OUTQUE^HLOUSR6
Q
;
ASKTASK() ;
W !!,"There are a lot of messages pending on that queue!"
Q $$ASKYESNO^HLOUSR2("Would you like to delete the queue in the background via a separate task","YES")
;
;
ASKWHEN(DEFAULT,PROMPT) ;
;Description: Asks the user to enter a dt/tm.
;Input: DEFAULT - the suggested default dt/time (optional, defaults to NOW)
;PROMPT - optional prompt
;Output: Returns the date as the function value, or 0 if the user does not select a date
;
;
N %DT
S %DT="AEST"
S:$L($G(PROMPT)) %DT("A")=PROMPT
S %DT("B")=$$FMTE^XLFDT($S($L($G(DEFAULT)):DEFAULT,1:"NOW"))
S %DT(0)="NOW"
Q:$D(DTOUT) 0
D ^%DT
I Y=-1 Q 0
Q Y
OUTPURGE ;Purge outgoing queue
N MSG,CNT
N MSG
S (CNT,MSG)=0
I '$D(ZTQUEUED) W !,"Removing messages....",!
F S MSG=$O(^HLB("QUEUE","OUT",LINK,QUE,MSG)) Q:'MSG D
.S CNT=CNT+1
.I '(CNT#100),'$D(ZTQUEUED) W "."
.I '(CNT#70000),'$D(ZTQUEUED) W "!"
.D DEQUE^HLOQUE(LINK,QUE,"OUT",MSG)
.I $$SETPURGE(MSG,WHEN) S $P(^HLB(MSG,0),"^",21)="MESSAGE GENERATED IN ERROR AND NOT TRANSMITTED"
Q
;
SEQPURGE ;Purge sequence queue
N MSG,CNT
S (CNT,MSG)=0
I '$D(ZTQUEUED) W !,"Removing messages....",!
F S MSG=$O(^HLB("QUEUE","SEQUENCE",QUE,MSG)) Q:'MSG D
.S CNT=CNT+1
.I '(CNT#100),'$D(ZTQUEUED) W "."
.I '(CNT#70000),'$D(ZTQUEUED) W "!"
.K ^HLB("QUEUE","SEQUENCE",QUE,MSG)
.I $$SETPURGE(MSG,WHEN) S $P(^HLB(MSG,0),"^",21)="MESSAGE GENERATED IN ERROR AND NOT TRANSMITTED"
I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE")),-$G(^HLC("QUEUECOUNT","SEQUENCE",QUE)))
S ^HLC("QUEUECOUNT","SEQUENCE",QUE)=0
S ^HLB("QUEUE","SEQUENCE",QUE)=""
Q
;
SETPURGE(MSGIEN,TIME) ; Set message up for purging.
;Resets the purge date/time.
;Input:
; MSGIEN (required) ien of the message, file #778
; TIME (optional) dt/time to set the purge time to, defaults to NOW
;Output:
; Function returns 1 on success, 0 on failure
;
N NODE,OLDTIME,HLDIR
Q:'$G(MSGIEN) 0
S NODE=$G(^HLB(MSGIEN,0))
Q:NODE="" 0
S OLDTIME=$P(NODE,"^",9)
S:'$G(TIME) TIME=$$NOW^XLFDT
S HLDIR=$S($E($P(NODE,"^",4))="I":"IN",1:"OUT")
K:OLDTIME ^HLB("AD",HLDIR,OLDTIME,MSGIEN)
S $P(^HLB(MSGIEN,0),"^",9)=TIME
S ^HLB("AD",HLDIR,TIME,MSGIEN)=""
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLOUSR7 5048 printed Sep 23, 2025@19:35:29 Page 2
HLOUSR7 ;OIFO-ALB/CJM - Deleting HLO queues ;03/26/2012
+1 ;;1.6;HEALTH LEVEL SEVEN;**147,153,158**;Oct 13, 1995;Build 14
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;
SPURGE ; Entry point from ListManager for deleting sequential queues.
+1 NEW CONF,LINK,QUE,PORT,WHEN,COUNT,IEN
+2 SET VALMBCK="R"
+3 DO OWNSKEY^XUSRB(.CONF,"HLOMGR",DUZ)
+4 IF CONF(0)'=1
Begin DoDot:1
+5 WRITE !,"**** You are not authorized to use this option ****"
DO PAUSE^VALM1
QUIT
End DoDot:1
QUIT
+6 SET QUE=$$GETQ^HLOUSR4()
+7 if QUE=""
QUIT
+8 IF '$DATA(^HLB("QUEUE","SEQUENCE",QUE))
WRITE !,"There are no messages on that queue!"
DO PAUSE^VALM1
QUIT
+9 WRITE !!,"Deleting a queue in error will result in lost messages!"
+10 if '$$ASKYESNO^HLOUSR2("Are you SURE you want to delete that queue","NO")
QUIT
+11 WRITE !!,"After removing the messages from the sequence queue they will deleted"
+12 WRITE !,"When do you want to schedule the messages to be purged?"
+13 SET WHEN=$$ASKWHEN($$FMADD^XLFDT($$NOW^XLFDT,7),"Date/Time to schedule purge:")
+14 if 'WHEN
QUIT
+15 SET (IEN,COUNT)=0
+16 FOR
SET IEN=$ORDER(^HLB("QUEUE","SEQUENCE",QUE,IEN))
if 'IEN
QUIT
SET COUNT=COUNT+1
if COUNT>100
QUIT
+17 IF COUNT>100
IF $$ASKTASK()
Begin DoDot:1
+18 SET ZTRTN="SEQPURGE^HLOUSR7"
+19 SET ZTDESC="HLO QUEUE PURGE"
+20 SET ZTDTH=$HOROLOG
+21 SET ZTIO=""
+22 SET ZTSAVE("QUE")=QUE
SET ZTSAVE("WHEN")=""
+23 DO ^%ZTLOAD
+24 IF '$GET(ZTSK)
WRITE !!,?5,"UNABLE TO SCHEDULE PURGE JOB",!
+25 IF $GET(ZTSK)
WRITE !!,?5,"Purge job is scheduled, task #"_ZTSK
+26 DO PAUSE^VALM1
End DoDot:1
+27 IF '$TEST
Begin DoDot:1
+28 DO SEQPURGE
+29 IF $LENGTH(HLRFRSH)
DO @HLRFRSH
End DoDot:1
+30 QUIT
+31 ;
OPURGE ; Entry point from ListManager for deleting outgoing queues.
+1 NEW CONF,LINK,QUE,PORT,WHEN,COUNT,IEN
+2 SET VALMBCK="R"
+3 DO OWNSKEY^XUSRB(.CONF,"HLOMGR",DUZ)
+4 IF CONF(0)'=1
Begin DoDot:1
+5 WRITE !,"**** You are not authorized to use this option ****"
DO PAUSE^VALM1
QUIT
End DoDot:1
QUIT
+6 SET LINK=$$ASKLINK^HLOUSR
+7 if LINK=""
QUIT
+8 WRITE !
+9 SET PORT=$$ASKPORT^HLOTRACE(LINK)
+10 IF 'PORT
WRITE !,"There are no outgoing messages for that destination!"
QUIT
+11 SET LINK=LINK_":"_PORT
+12 WRITE !
+13 SET QUE=$$ASKQUE^HLOTRACE(LINK)
+14 IF QUE=""
WRITE !,"There are no outgoing messages for that destination!"
QUIT
+15 WRITE !!,"Deleting a queue in error will result in lost messages!"
+16 if '$$ASKYESNO^HLOUSR2("Are you SURE you want to delete that queue","NO")
QUIT
+17 WRITE !!,"After removing the messages from the outgoing queue they will deleted"
+18 WRITE !,"When do you want to schedule the messages to be purged?"
+19 SET WHEN=$$ASKWHEN($$FMADD^XLFDT($$NOW^XLFDT,7),"Date/Time to schedule purge:")
+20 if 'WHEN
QUIT
+21 SET (IEN,COUNT)=0
+22 FOR
SET IEN=$ORDER(^HLB("QUEUE","OUT",LINK,QUE,IEN))
if 'IEN
QUIT
SET COUNT=COUNT+1
if COUNT>100
QUIT
+23 IF COUNT>100
IF $$ASKTASK()
Begin DoDot:1
+24 SET ZTRTN="OUTPURGE^HLOUSR7"
+25 SET ZTDESC="HLO QUEUE PURGE"
+26 SET ZTDTH=$HOROLOG
+27 SET ZTIO=""
+28 SET ZTSAVE("LINK")=""
SET ZTSAVE("QUE")=QUE
SET ZTSAVE("WHEN")=""
+29 DO ^%ZTLOAD
+30 IF '$GET(ZTSK)
WRITE !!,?5,"UNABLE TO SCHEDULE PURGE JOB",!
+31 IF $GET(ZTSK)
WRITE !!,?5,"Purge job is scheduled, task #"_ZTSK
+32 DO PAUSE^VALM1
End DoDot:1
+33 IF '$TEST
Begin DoDot:1
+34 DO OUTPURGE
+35 DO OUTQUE^HLOUSR6
End DoDot:1
+36 QUIT
+37 ;
ASKTASK() ;
+1 WRITE !!,"There are a lot of messages pending on that queue!"
+2 QUIT $$ASKYESNO^HLOUSR2("Would you like to delete the queue in the background via a separate task","YES")
+3 ;
+4 ;
ASKWHEN(DEFAULT,PROMPT) ;
+1 ;Description: Asks the user to enter a dt/tm.
+2 ;Input: DEFAULT - the suggested default dt/time (optional, defaults to NOW)
+3 ;PROMPT - optional prompt
+4 ;Output: Returns the date as the function value, or 0 if the user does not select a date
+5 ;
+6 ;
+7 NEW %DT
+8 SET %DT="AEST"
+9 if $LENGTH($GET(PROMPT))
SET %DT("A")=PROMPT
+10 SET %DT("B")=$$FMTE^XLFDT($SELECT($LENGTH($GET(DEFAULT)):DEFAULT,1:"NOW"))
+11 SET %DT(0)="NOW"
+12 if $DATA(DTOUT)
QUIT 0
+13 DO ^%DT
+14 IF Y=-1
QUIT 0
+15 QUIT Y
OUTPURGE ;Purge outgoing queue
+1 NEW MSG,CNT
+2 NEW MSG
+3 SET (CNT,MSG)=0
+4 IF '$DATA(ZTQUEUED)
WRITE !,"Removing messages....",!
+5 FOR
SET MSG=$ORDER(^HLB("QUEUE","OUT",LINK,QUE,MSG))
if 'MSG
QUIT
Begin DoDot:1
+6 SET CNT=CNT+1
+7 IF '(CNT#100)
IF '$DATA(ZTQUEUED)
WRITE "."
+8 IF '(CNT#70000)
IF '$DATA(ZTQUEUED)
WRITE "!"
+9 DO DEQUE^HLOQUE(LINK,QUE,"OUT",MSG)
+10 IF $$SETPURGE(MSG,WHEN)
SET $PIECE(^HLB(MSG,0),"^",21)="MESSAGE GENERATED IN ERROR AND NOT TRANSMITTED"
End DoDot:1
+11 QUIT
+12 ;
SEQPURGE ;Purge sequence queue
+1 NEW MSG,CNT
+2 SET (CNT,MSG)=0
+3 IF '$DATA(ZTQUEUED)
WRITE !,"Removing messages....",!
+4 FOR
SET MSG=$ORDER(^HLB("QUEUE","SEQUENCE",QUE,MSG))
if 'MSG
QUIT
Begin DoDot:1
+5 SET CNT=CNT+1
+6 IF '(CNT#100)
IF '$DATA(ZTQUEUED)
WRITE "."
+7 IF '(CNT#70000)
IF '$DATA(ZTQUEUED)
WRITE "!"
+8 KILL ^HLB("QUEUE","SEQUENCE",QUE,MSG)
+9 IF $$SETPURGE(MSG,WHEN)
SET $PIECE(^HLB(MSG,0),"^",21)="MESSAGE GENERATED IN ERROR AND NOT TRANSMITTED"
End DoDot:1
+10 IF $$INC^HLOSITE($NAME(^HLC("QUEUECOUNT","SEQUENCE")),-$GET(^HLC("QUEUECOUNT","SEQUENCE",QUE)))
+11 SET ^HLC("QUEUECOUNT","SEQUENCE",QUE)=0
+12 SET ^HLB("QUEUE","SEQUENCE",QUE)=""
+13 QUIT
+14 ;
SETPURGE(MSGIEN,TIME) ; Set message up for purging.
+1 ;Resets the purge date/time.
+2 ;Input:
+3 ; MSGIEN (required) ien of the message, file #778
+4 ; TIME (optional) dt/time to set the purge time to, defaults to NOW
+5 ;Output:
+6 ; Function returns 1 on success, 0 on failure
+7 ;
+8 NEW NODE,OLDTIME,HLDIR
+9 if '$GET(MSGIEN)
QUIT 0
+10 SET NODE=$GET(^HLB(MSGIEN,0))
+11 if NODE=""
QUIT 0
+12 SET OLDTIME=$PIECE(NODE,"^",9)
+13 if '$GET(TIME)
SET TIME=$$NOW^XLFDT
+14 SET HLDIR=$SELECT($EXTRACT($PIECE(NODE,"^",4))="I":"IN",1:"OUT")
+15 if OLDTIME
KILL ^HLB("AD",HLDIR,OLDTIME,MSGIEN)
+16 SET $PIECE(^HLB(MSGIEN,0),"^",9)=TIME
+17 SET ^HLB("AD",HLDIR,TIME,MSGIEN)=""
+18 QUIT 1
