- 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 Dec 13, 2024@02:11 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 ;