IBCEMSG ;ALB/JEH - EDI PURGE STATUS MESSAGES ;10-APR-01
;;2.0;INTEGRATED BILLING:**137**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;
N IBDELDT,IBSEL,IBQUIT,IBPRT,DTOUT,DUOUT,DIRUT,X,Y
K ^TMP("IBCEMSGA",$J)
I '$D(^XUSEC("IB SUPERVISOR",DUZ)) W !!,"You do not have the appropriate authority to delete status messages. See your supervisor for assistance." G MSGQ
W !,"This option will delete status messages in one of the Final Review statuses",!,"prior to a selected date",!!
S DIR("A")="DELETE (A)LL OR (S)ELECTED STATUS MESSAGES? ",DIR("B")="SELECTED"
S DIR(0)="SAXB^A:ALL STATUS MESSAGES;S:SELECTED STATUS MESSAGES"
D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT) G MSGQ
S IBSEL=Y
;
W !
I IBSEL="A" D G:IBQUIT MSGQ
. S IBQUIT=0
. S DIR("A")="DELETE STATUS MESSAGES REVIEWED PRIOR TO"
. S DIR(0)="D^:DTP:EX" W ! D ^DIR K DIR
. I $D(DTOUT)!$D(DUOUT) S IBQUIT=1 Q
. S IBDELDT=Y
. S DIR("A",1)="This action will delete all status messages with a"
. S DIR("A",2)="final review action dated before "_$$FMTE^XLFDT(IBDELDT)
. S DIR("A",3)=""
. S DIR("A")="ARE YOU SURE THIS IS WHAT YOU WANT TO DO",DIR("B")="YES"
. S DIR(0)="Y" D ^DIR K DIR
. I $D(DTOUT)!$D(DUOUT)!(+Y=0) S IBQUIT=1 Q
. S DIR("A")="DO YOU WANT TO PRINT STATUS MESSAGES BEFORE DELETION"
. S DIR(0)="Y",DIR("B")="YES"
. D ^DIR K DIR
. I $D(DTOUT)!$D(DUOUT) S IBQUIT=1 Q
. S IBPRT=Y
I IBSEL="A" D SET,PRT:IBPRT,DEL
I IBSEL="S" D EN^IBCEMSG1
MSGQ ;
Q
SET ;set up tmp global
N IBDT,IBIEN,IB0,IBNUM,IBSEV,IBFNR,IBFRD,IBQUIT,IBAUTO
S (IBDT,IBQUIT)=0 F S IBDT=$O(^IBM(361,"AFR",IBDT)) Q:'IBDT!(IBQUIT) S IBIEN=0 F S IBIEN=$O(^IBM(361,"AFR",IBDT,IBIEN)) Q:'IBIEN!(IBQUIT) D
. I IBDT>IBDELDT S IBQUIT=1 Q
. S IB0=$G(^IBM(361,IBIEN,0))
. S IBNUM=$$BN1^PRCAFN($P($G(IB0),U))
. S IBSEV=$$EXPAND^IBTRE(361,.03,$P($G(IB0),U,3))
. S IBFNR=$$EXPAND^IBTRE(361,.1,$P($G(IB0),U,10))
. S IBFRD=$$DAT1^IBOUTL($P($G(IB0),U,13))
. S IBAUTO=$$EXPAND^IBTRE(361,.14,$P(IB0,U,5))
. S ^TMP("IBCEMSGA",$J,IBIEN)=IBNUM_U_IBSEV_U_IBFNR_U_IBFRD
Q
;
PRT ;print status message list
N IBPG,%ZIS
S IBPG=0
S %ZIS="M" D ^%ZIS G:POP MSGQ
U IO
PRT1 ;
N IBIEN,IB0 D HDR
S IBIEN=0 F S IBIEN=$O(^TMP("IBCEMSGA",$J,IBIEN)) Q:'IBIEN S IB0=^(IBIEN) D
.I ($Y+5)>IOSL D Q:IBQUIT
.. D ASK Q:IBQUIT D HDR
. W !,$P(IB0,U),?13,$P(IB0,U,2),?34,$P(IB0,U,3),?71,$P(IB0,U,4)
W !
D ^%ZISC
Q
ASK ;
I $E(IOST,1,2)'["C-" Q
N DIR,DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="E" D ^DIR
I ($D(DIRUT))!($D(DUOUT)) S IBQUIT=1 Q
Q
;
HDR ; - report header
I $E(IOST,1,2)="C-" W @IOF,*13
S IBPG=IBPG+1
W !!,"Status Messages Selected for Deletion",?57,$$FMTE^XLFDT(DT),?71,"Page: ",IBPG,!
W !,?13,"Message",?34,"Final Review",?67,"Final Review",!,"Bill #",?13,"Severity",?37,"Action",?72,"Date"
W !,$TR($J("",IOM)," ","=")
Q
DEL ;Delete status messages in final review status
N DIK,DA,Y,IBIEN,IBCNT
W !
S DIR("A")="ARE YOU SURE YOU WANT TO DELETE STATUS MESSAGES",DIR("B")="YES"
S DIR(0)="Y" D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!(Y=0) G DELQ
S IBCNT=0,DIK="^IBM(361,"
S IBIEN=0 F S IBIEN=$O(^TMP("IBCEMSGA",$J,IBIEN)) Q:'IBIEN S DA=IBIEN D ^DIK S IBCNT=IBCNT+1
W !!,IBCNT_$S(IBCNT>1:" Messages",1:" Message")_" deleted"
DELQ Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEMSG 3311 printed Apr 09, 2024@21:18:45 Page 2
IBCEMSG ;ALB/JEH - EDI PURGE STATUS MESSAGES ;10-APR-01
+1 ;;2.0;INTEGRATED BILLING:**137**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;
+1 NEW IBDELDT,IBSEL,IBQUIT,IBPRT,DTOUT,DUOUT,DIRUT,X,Y
+2 KILL ^TMP("IBCEMSGA",$JOB)
+3 IF '$DATA(^XUSEC("IB SUPERVISOR",DUZ))
WRITE !!,"You do not have the appropriate authority to delete status messages. See your supervisor for assistance."
GOTO MSGQ
+4 WRITE !,"This option will delete status messages in one of the Final Review statuses",!,"prior to a selected date",!!
+5 SET DIR("A")="DELETE (A)LL OR (S)ELECTED STATUS MESSAGES? "
SET DIR("B")="SELECTED"
+6 SET DIR(0)="SAXB^A:ALL STATUS MESSAGES;S:SELECTED STATUS MESSAGES"
+7 DO ^DIR
KILL DIR
+8 IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO MSGQ
+9 SET IBSEL=Y
+10 ;
+11 WRITE !
+12 IF IBSEL="A"
Begin DoDot:1
+13 SET IBQUIT=0
+14 SET DIR("A")="DELETE STATUS MESSAGES REVIEWED PRIOR TO"
+15 SET DIR(0)="D^:DTP:EX"
WRITE !
DO ^DIR
KILL DIR
+16 IF $DATA(DTOUT)!$DATA(DUOUT)
SET IBQUIT=1
QUIT
+17 SET IBDELDT=Y
+18 SET DIR("A",1)="This action will delete all status messages with a"
+19 SET DIR("A",2)="final review action dated before "_$$FMTE^XLFDT(IBDELDT)
+20 SET DIR("A",3)=""
+21 SET DIR("A")="ARE YOU SURE THIS IS WHAT YOU WANT TO DO"
SET DIR("B")="YES"
+22 SET DIR(0)="Y"
DO ^DIR
KILL DIR
+23 IF $DATA(DTOUT)!$DATA(DUOUT)!(+Y=0)
SET IBQUIT=1
QUIT
+24 SET DIR("A")="DO YOU WANT TO PRINT STATUS MESSAGES BEFORE DELETION"
+25 SET DIR(0)="Y"
SET DIR("B")="YES"
+26 DO ^DIR
KILL DIR
+27 IF $DATA(DTOUT)!$DATA(DUOUT)
SET IBQUIT=1
QUIT
+28 SET IBPRT=Y
End DoDot:1
if IBQUIT
GOTO MSGQ
+29 IF IBSEL="A"
DO SET
if IBPRT
DO PRT
DO DEL
+30 IF IBSEL="S"
DO EN^IBCEMSG1
MSGQ ;
+1 QUIT
SET ;set up tmp global
+1 NEW IBDT,IBIEN,IB0,IBNUM,IBSEV,IBFNR,IBFRD,IBQUIT,IBAUTO
+2 SET (IBDT,IBQUIT)=0
FOR
SET IBDT=$ORDER(^IBM(361,"AFR",IBDT))
if 'IBDT!(IBQUIT)
QUIT
SET IBIEN=0
FOR
SET IBIEN=$ORDER(^IBM(361,"AFR",IBDT,IBIEN))
if 'IBIEN!(IBQUIT)
QUIT
Begin DoDot:1
+3 IF IBDT>IBDELDT
SET IBQUIT=1
QUIT
+4 SET IB0=$GET(^IBM(361,IBIEN,0))
+5 SET IBNUM=$$BN1^PRCAFN($PIECE($GET(IB0),U))
+6 SET IBSEV=$$EXPAND^IBTRE(361,.03,$PIECE($GET(IB0),U,3))
+7 SET IBFNR=$$EXPAND^IBTRE(361,.1,$PIECE($GET(IB0),U,10))
+8 SET IBFRD=$$DAT1^IBOUTL($PIECE($GET(IB0),U,13))
+9 SET IBAUTO=$$EXPAND^IBTRE(361,.14,$PIECE(IB0,U,5))
+10 SET ^TMP("IBCEMSGA",$JOB,IBIEN)=IBNUM_U_IBSEV_U_IBFNR_U_IBFRD
End DoDot:1
+11 QUIT
+12 ;
PRT ;print status message list
+1 NEW IBPG,%ZIS
+2 SET IBPG=0
+3 SET %ZIS="M"
DO ^%ZIS
if POP
GOTO MSGQ
+4 USE IO
PRT1 ;
+1 NEW IBIEN,IB0
DO HDR
+2 SET IBIEN=0
FOR
SET IBIEN=$ORDER(^TMP("IBCEMSGA",$JOB,IBIEN))
if 'IBIEN
QUIT
SET IB0=^(IBIEN)
Begin DoDot:1
+3 IF ($Y+5)>IOSL
Begin DoDot:2
+4 DO ASK
if IBQUIT
QUIT
DO HDR
End DoDot:2
if IBQUIT
QUIT
+5 WRITE !,$PIECE(IB0,U),?13,$PIECE(IB0,U,2),?34,$PIECE(IB0,U,3),?71,$PIECE(IB0,U,4)
End DoDot:1
+6 WRITE !
+7 DO ^%ZISC
+8 QUIT
ASK ;
+1 IF $EXTRACT(IOST,1,2)'["C-"
QUIT
+2 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT
+3 SET DIR(0)="E"
DO ^DIR
+4 IF ($DATA(DIRUT))!($DATA(DUOUT))
SET IBQUIT=1
QUIT
+5 QUIT
+6 ;
HDR ; - report header
+1 IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF,*13
+2 SET IBPG=IBPG+1
+3 WRITE !!,"Status Messages Selected for Deletion",?57,$$FMTE^XLFDT(DT),?71,"Page: ",IBPG,!
+4 WRITE !,?13,"Message",?34,"Final Review",?67,"Final Review",!,"Bill #",?13,"Severity",?37,"Action",?72,"Date"
+5 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","=")
+6 QUIT
DEL ;Delete status messages in final review status
+1 NEW DIK,DA,Y,IBIEN,IBCNT
+2 WRITE !
+3 SET DIR("A")="ARE YOU SURE YOU WANT TO DELETE STATUS MESSAGES"
SET DIR("B")="YES"
+4 SET DIR(0)="Y"
DO ^DIR
KILL DIR
+5 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y=0)
GOTO DELQ
+6 SET IBCNT=0
SET DIK="^IBM(361,"
+7 SET IBIEN=0
FOR
SET IBIEN=$ORDER(^TMP("IBCEMSGA",$JOB,IBIEN))
if 'IBIEN
QUIT
SET DA=IBIEN
DO ^DIK
SET IBCNT=IBCNT+1
+8 WRITE !!,IBCNT_$SELECT(IBCNT>1:" Messages",1:" Message")_" deleted"
DELQ QUIT
+1 ;
