IBCEMSG1 ;ALB/JEH - EDI PURGE STATUS MESSAGES CONT. ;04-MAY-01
;;2.0;INTEGRATED BILLING;**137**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN ; - main entry
N IBDELDT,IBIEN,IBMSG,IBSORT,IBQUIT,IBFNR,IBFRD,IBREC,IBNUM,IBSEV,IB0,IBK
D EN^VALM("IBCEM STATUS MESSAGE")
Q
HDR ; -- header code
S VALMHDR(1)="Selected by "_$S(IBSORT="A":"Auto Filed/No Review",IBSORT="B":"Bill Number: "_IBNUM,IBSORT="S":"Message Severity: "_IBSEV,1:"Message Text containing word or phrase "_IBMSG)
S VALMHDR(2)="Reviewed Prior to: "_$$FMTE^XLFDT(IBDELDT,"2D")
Q
;
INIT ; -- set up variables
N DIR,X,Y
K ^TMP("IBCEMSGA",$J)
S DIR("A")="Select messages based on"
S DIR(0)="S^A:Auto Filed/No Review Only;B:Bill Number;S:Message Severity;T:Specific Message Text"
D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!(Y<0) S VALMQUIT=1 G INITQ
S IBSORT=Y
I IBSORT="B" D G:$G(VALMQUIT) INITQ
. S DIR("A")="Enter Bill Number"
. S DIR(0)="P^361:AEMQZ"
. D ^DIR K DIR
. I $D(DTOUT)!$D(DUOUT)!(Y<0) S VALMQUIT=1 Q
. S IBIEN=$P(Y,U,2),IBNUM=$$BN1^PRCAFN(IBIEN)
I IBSORT="S" D G:$G(VALMQUIT) INITQ
. S DIR("A")="(I)nformation/Warning or (R)ejection"
. S DIR(0)="SB^I:Information/Warning;R:Rejection"
. D ^DIR K DIR
. I $D(DUOUT)!$D(DTOUT)!(Y<0) S VALMQUIT=1 Q
. S IBSEV=Y
I IBSORT="T" D G:$G(VALMQUIT) INITQ
. S DIR("A")="Enter specific word or phrase the message should contain to be deleted"
. S DIR(0)="F^5:15^K:X'?.U X"
. D ^DIR K DIR
. I $D(DUOUT)!$D(DTOUT)!(Y<0) S VALMQUIT=1 Q
. S IBMSG=Y
S DIR("A")="INCLUDE STATUS MESSAGES REVIEWED PRIOR TO"
S DIR(0)="D^:DTP:EX" W ! D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT) S VALMQUIT=1 Q
S IBDELDT=Y
D @IBSORT
D BLD^IBCEMSG2
INITQ ;
Q
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
EXIT ; -- clean up and exit
K ^TMP("IBCEMSGA",$J),^TMP("IBCEMSGB",$J)
D CLEAN^VALM10
Q
A ; -- sort by auto filed
S IBK=0 F S IBK=$O(^IBM(361,"ANR",1,IBK)) Q:'IBK S IB0=$G(^IBM(361,IBK,0)) D
. I '$P(IB0,U,13)!($P(IB0,U,13)>IBDELDT) Q
. D SET
Q
;
B ; -- sort by bill number
S IBK=0 F S IBK=$O(^IBM(361,"B",IBIEN,IBK)) Q:'IBK S IB0=$G(^IBM(361,IBK,0)) D
. I '$P(IB0,U,13)!($P(IB0,U,13)>IBDELDT) Q
. D SET
Q
;
S ; -- sort by message severity
S IBK=0 F S IBK=$O(^IBM(361,"ASV",IBSEV,IBK)) Q:'IBK S IB0=$G(^IBM(361,IBK,0)) D
. I '$P(IB0,U,13)!($P(IB0,U,13)>IBDELDT) Q
. D SET
Q
;
T ; -- sort by message text
N Z,IBTXT,IB,IBDT
S IBDT=0 F S IBDT=$O(^IBM(361,"AFR",IBDT)) Q:'IBDT!(IBDT>IBDELDT) S IBK=0 F S IBK=$O(^IBM(361,"AFR",IBDT,IBK)) Q:'IBK S IB0=$G(^IBM(361,IBK,0)) D
. I '$O(^IBM(361,IBK,1,0)) Q
. S IB=0 F S IB=$O(^IBM(361,IBK,1,IB)) Q:'IB S Z=$G(^IBM(361,IBK,1,IB,0)) I $$UPPER^VALM1(Z)[IBMSG S IBTXT=$E(Z,1,60) D
.. D SET
.. S ^TMP("IBCEMSGA",$J,IBK)=^TMP("IBCEMSGA",$J,IBK)_U_IBTXT
Q
;
SET S IBNUM=$$BN1^PRCAFN($P(IB0,U))
S IBSEV=$$EXPAND^IBTRE(361,.03,$P(IB0,U,3))
S IBFNR=$$EXPAND^IBTRE(361,.1,$P(IB0,U,10))
S IBFRD=$$DAT1^IBOUTL($P(IB0,U,13))
S IBAUTO=$$EXPAND^IBTRE(361,.14,$P(IB0,U,14))
S ^TMP("IBCEMSGA",$J,IBK)=IBNUM_U_IBSEV_U_IBFNR_U_IBFRD_U_IBAUTO
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEMSG1 3147 printed Apr 09, 2024@21:29:07 Page 2
IBCEMSG1 ;ALB/JEH - EDI PURGE STATUS MESSAGES CONT. ;04-MAY-01
+1 ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
EN ; - main entry
+1 NEW IBDELDT,IBIEN,IBMSG,IBSORT,IBQUIT,IBFNR,IBFRD,IBREC,IBNUM,IBSEV,IB0,IBK
+2 DO EN^VALM("IBCEM STATUS MESSAGE")
+3 QUIT
HDR ; -- header code
+1 SET VALMHDR(1)="Selected by "_$SELECT(IBSORT="A":"Auto Filed/No Review",IBSORT="B":"Bill Number: "_IBNUM,IBSORT="S":"Message Severity: "_IBSEV,1:"Message Text containing word or phrase "_IBMSG)
+2 SET VALMHDR(2)="Reviewed Prior to: "_$$FMTE^XLFDT(IBDELDT,"2D")
+3 QUIT
+4 ;
INIT ; -- set up variables
+1 NEW DIR,X,Y
+2 KILL ^TMP("IBCEMSGA",$JOB)
+3 SET DIR("A")="Select messages based on"
+4 SET DIR(0)="S^A:Auto Filed/No Review Only;B:Bill Number;S:Message Severity;T:Specific Message Text"
+5 DO ^DIR
KILL DIR
+6 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y<0)
SET VALMQUIT=1
GOTO INITQ
+7 SET IBSORT=Y
+8 IF IBSORT="B"
Begin DoDot:1
+9 SET DIR("A")="Enter Bill Number"
+10 SET DIR(0)="P^361:AEMQZ"
+11 DO ^DIR
KILL DIR
+12 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y<0)
SET VALMQUIT=1
QUIT
+13 SET IBIEN=$PIECE(Y,U,2)
SET IBNUM=$$BN1^PRCAFN(IBIEN)
End DoDot:1
if $GET(VALMQUIT)
GOTO INITQ
+14 IF IBSORT="S"
Begin DoDot:1
+15 SET DIR("A")="(I)nformation/Warning or (R)ejection"
+16 SET DIR(0)="SB^I:Information/Warning;R:Rejection"
+17 DO ^DIR
KILL DIR
+18 IF $DATA(DUOUT)!$DATA(DTOUT)!(Y<0)
SET VALMQUIT=1
QUIT
+19 SET IBSEV=Y
End DoDot:1
if $GET(VALMQUIT)
GOTO INITQ
+20 IF IBSORT="T"
Begin DoDot:1
+21 SET DIR("A")="Enter specific word or phrase the message should contain to be deleted"
+22 SET DIR(0)="F^5:15^K:X'?.U X"
+23 DO ^DIR
KILL DIR
+24 IF $DATA(DUOUT)!$DATA(DTOUT)!(Y<0)
SET VALMQUIT=1
QUIT
+25 SET IBMSG=Y
End DoDot:1
if $GET(VALMQUIT)
GOTO INITQ
+26 SET DIR("A")="INCLUDE STATUS MESSAGES REVIEWED PRIOR TO"
+27 SET DIR(0)="D^:DTP:EX"
WRITE !
DO ^DIR
KILL DIR
+28 IF $DATA(DTOUT)!$DATA(DUOUT)
SET VALMQUIT=1
QUIT
+29 SET IBDELDT=Y
+30 DO @IBSORT
+31 DO BLD^IBCEMSG2
INITQ ;
+1 QUIT
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
EXIT ; -- clean up and exit
+1 KILL ^TMP("IBCEMSGA",$JOB),^TMP("IBCEMSGB",$JOB)
+2 DO CLEAN^VALM10
+3 QUIT
A ; -- sort by auto filed
+1 SET IBK=0
FOR
SET IBK=$ORDER(^IBM(361,"ANR",1,IBK))
if 'IBK
QUIT
SET IB0=$GET(^IBM(361,IBK,0))
Begin DoDot:1
+2 IF '$PIECE(IB0,U,13)!($PIECE(IB0,U,13)>IBDELDT)
QUIT
+3 DO SET
End DoDot:1
+4 QUIT
+5 ;
B ; -- sort by bill number
+1 SET IBK=0
FOR
SET IBK=$ORDER(^IBM(361,"B",IBIEN,IBK))
if 'IBK
QUIT
SET IB0=$GET(^IBM(361,IBK,0))
Begin DoDot:1
+2 IF '$PIECE(IB0,U,13)!($PIECE(IB0,U,13)>IBDELDT)
QUIT
+3 DO SET
End DoDot:1
+4 QUIT
+5 ;
S ; -- sort by message severity
+1 SET IBK=0
FOR
SET IBK=$ORDER(^IBM(361,"ASV",IBSEV,IBK))
if 'IBK
QUIT
SET IB0=$GET(^IBM(361,IBK,0))
Begin DoDot:1
+2 IF '$PIECE(IB0,U,13)!($PIECE(IB0,U,13)>IBDELDT)
QUIT
+3 DO SET
End DoDot:1
+4 QUIT
+5 ;
T ; -- sort by message text
+1 NEW Z,IBTXT,IB,IBDT
+2 SET IBDT=0
FOR
SET IBDT=$ORDER(^IBM(361,"AFR",IBDT))
if 'IBDT!(IBDT>IBDELDT)
QUIT
SET IBK=0
FOR
SET IBK=$ORDER(^IBM(361,"AFR",IBDT,IBK))
if 'IBK
QUIT
SET IB0=$GET(^IBM(361,IBK,0))
Begin DoDot:1
+3 IF '$ORDER(^IBM(361,IBK,1,0))
QUIT
+4 SET IB=0
FOR
SET IB=$ORDER(^IBM(361,IBK,1,IB))
if 'IB
QUIT
SET Z=$GET(^IBM(361,IBK,1,IB,0))
IF $$UPPER^VALM1(Z)[IBMSG
SET IBTXT=$EXTRACT(Z,1,60)
Begin DoDot:2
+5 DO SET
+6 SET ^TMP("IBCEMSGA",$JOB,IBK)=^TMP("IBCEMSGA",$JOB,IBK)_U_IBTXT
End DoDot:2
End DoDot:1
+7 QUIT
+8 ;
SET SET IBNUM=$$BN1^PRCAFN($PIECE(IB0,U))
+1 SET IBSEV=$$EXPAND^IBTRE(361,.03,$PIECE(IB0,U,3))
+2 SET IBFNR=$$EXPAND^IBTRE(361,.1,$PIECE(IB0,U,10))
+3 SET IBFRD=$$DAT1^IBOUTL($PIECE(IB0,U,13))
+4 SET IBAUTO=$$EXPAND^IBTRE(361,.14,$PIECE(IB0,U,14))
+5 SET ^TMP("IBCEMSGA",$JOB,IBK)=IBNUM_U_IBSEV_U_IBFNR_U_IBFRD_U_IBAUTO
+6 QUIT
