- 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 Jan 18, 2025@03:00:39 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