RCDPEX5 ;ALB/TMK,DWA - ELECTRONIC EOB EXCEPTION PROCESSING - FILE 344.5 ;8 Aug 2018 21:44:13
;;4.5;Accounts Receivable;**332**;Mar 20, 1995;Build 40
;Per VA Directive 6402, this routine should not be modified.
Q
;
UPD ; Update (File) ERA msgs manually from DUPLICATE exception list for file 344.5
N RC0,RCDA,RCLKBXDA,RCOK,RCTSK,RCTYP,RCU,ZTSK
D FULL^VALM1
D SEL(.RCDA,1)
S RCDA=$O(RCDA(""))
I RCDA="" G UPDQ
S RCLKBXDA=+RCDA(RCDA)
S RC0=$G(^RCY(344.5,RCLKBXDA,0))
I RC0="" D G UPDQ
. W !,$C(7)_"ERA #"_RCDA_" is no longer in exception file" S RCOK=0
. D PAUSE^VALM1
;
I '$$LOCK(RCLKBXDA) D G UPDQ
. W !,$C(7)_"Could not Lock ERA #"_RCDA_" to file it." S RCOK=0
. D PAUSE^VALM1
;
S RC0=$G(^RCY(344.5,RCLKBXDA,0))
I RC0="" D G UPDQ
. W !,$C(7)_"ERA #"_RCDA_" is no longer in exception file" S RCOK=0
. D PAUSE^VALM1
I $P(RC0,U,5) S RCOK=1 D G:'RCOK UPDQ
. N ZTSK
. S ZTSK=$P(RC0,U,5) D STAT^%ZTLOAD Q:ZTSK(0)=0 ;Task not scheduled
. I "12"[ZTSK(1) W !,$C(7)_"This record has already been scheduled for update. Task # is: "_$P(RC0,U,5) S RCOK="" D PAUSE^VALM1
;
S RCTYP=$P(RC0,U,2)
S RCU=$S(RCTYP="835ERA":"NEWERA^RCDPESR2("_RCLKBXDA_",1)",RCTYP="835XFR":"FILEEOB^RCDPESR5("_RCLKBXDA_")",1:"")
I RCU="" W !,$C(7)_"This message has an invalid 'type' - can't update" D PAUSE^VALM1 G UPDQ
S RCTSK=$$TASK(RCU,RCLKBXDA)
I RCTSK W !,"File update has been tasked (#"_RCTSK_")"
I 'RCTSK W !,$C(7)_"File update could not be tasked. Please try again later!"
D PAUSE^VALM1
;
D BLD^RCDPEX1("DUPLICATE ERA")
UPDQ ; fall through or GOTO from above
I $G(RCLKBXDA) L -^RCY(344.5,RCLKBXDA)
S VALMBCK="R"
Q
;
VP ; View/Print ERA Messages - File 344.5
N DHD,DIC,FLDS,BY,FR,TO,DIR,Y,L,RCDA,RCTDA,RCRAW,POP
D FULL^VALM1,SEL(.RCDA,1)
S RCDA=$O(RCDA(""))
G:'RCDA VPQ
S RCTDA=$G(RCDA(RCDA))
S DIR(0)="YA",DIR("A")="DO YOU WANT TO INCLUDE DATA THE WAY IT WAS RECEIVED (RAW DATA)?: ",DIR("B")="N" D ^DIR K DIR
I $D(DUOUT)!$D(DTOUT) G VPQ
S RCRAW=+Y
; Ask device
N %ZIS,ZTRTN,ZTSAVE,ZTDESC
S %ZIS="QM" D ^%ZIS G:POP VPQ
I $D(IO("Q")) D G VPQ
. S ZTRTN="VPOUT^RCDPEX",ZTDESC="AR - Print EEOB Exception Message"
. S ZTSAVE("RCTDA")="",ZTSAVE("RCRAW")=""
. D ^%ZTLOAD
. W !!,$S($D(ZTSK):"Your task number"_ZTSK_" has been queued.",1:"Unable to queue this job.")
. K ZTSK,IO("Q") D HOME^%ZIS
U IO
;
VPOUT ; Entrypoint for queued job
N Z,Z0,RCSTOP,RCPG,RCXM,RCXM1,RC,RCZ,RCTDAC,RCV5
K ^TMP($J,"RCRAW"),^TMP($J,"RCOUT")
S RCTDAC=RCTDA_",",RCV5=0
;
D GETS^DIQ(344.5,RCTDAC,"*","IEN","RCZ")
D TXTDE^RCDPEX(RCTDA,.RCZ,1,.RCXM,.RC)
;
I $O(^RCY(344.5,RCTDA,"EX",0)) D
. S RC=RC+1,RCXM(RC)="**EXCEPTION MESSAGES**"
. D TXTDE^RCDPEX(RCTDA,.RCZ,5,.RCXM,.RC)
;
K ^TMP("RCSAVE",$J)
M ^TMP("RCSAVE",$J)=^RCY(344.5,RCTDA,2)
I +$P($G(^TMP("RCSAVE",$J,1,0)),U,16)>0 S RCV5=1
S Z=0 F S Z=$O(^TMP("RCSAVE",$J,Z)) Q:'Z I $P($G(^(Z,0)),U)["835" K ^(0) Q ; Get rid of header node
D DISP^RCDPESR0("^TMP(""RCSAVE"",$J)","^TMP($J,""RCRAW"")",1,"^TMP($J,""RCOUT"")",75) ; Get formatted 'raw' data
K ^TMP("RCSAVE",$J)
I $G(RCRAW) D
. S RC=$O(^TMP($J,"RCOUT",""),-1)+1,^TMP($J,"RCOUT",RC)=" "
. S RC=RC+1,^TMP($J,"RCOUT",RC)="**RAW DATA**"
. S Z=0 F S Z=$O(^RCY(344.5,RCTDA,2,Z)) Q:'Z D
.. F Z0=1:80:$L($G(^RCY(344.5,RCTDA,2,Z,0))) S RC=RC+1,^TMP($J,"RCOUT",RC)=$E($G(^RCY(344.5,RCTDA,2,Z,0)),Z0,Z0+79)
;
S (RCPG,RCSTOP,Z)=0
F S Z=$O(RCXM(Z)) Q:'Z S ^TMP($J,"RCOUT",Z-999)=RCXM(Z)
S Z=""
F S Z=$O(^TMP($J,"RCOUT",Z)) Q:'Z D Q:RCSTOP
. I $D(ZTQUEUED),$$S^%ZTLOAD S (RCSTOP,ZTSTOP)=1 K ZTREQ I +$G(RCPG) W !,"***TASK STOPPED BY USER***" Q
. I 'RCPG!(($Y+5)>IOSL) D I RCSTOP Q
.. D:RCPG ASK^RCDPEX(.RCSTOP) I RCSTOP Q
.. D HDR(RCTDA,.RCPG)
. W !,$G(^TMP($J,"RCOUT",Z))
I 'RCSTOP,RCPG D ASK^RCDPEX(.RCSTOP)
;
I $D(ZTQUEUED) S ZTREQ="@"
I '$D(ZTQUEUED) D ^%ZISC
;
VPQ K ^TMP($J,"RCRAW"),^TMP($J,"RCOUT")
S VALMBCK="R"
Q
;
SEL(RCDA,ONE) ; Select entry(s) from list
; RCDA = array returned if selections made
; RCDA(n)=ien of bill selected in file 344.5
; ONE = if set to 1, only one selection can be made at a time
N RC
K RCDA
D EN^VALM2($G(XQORNOD(0)),$S('$G(ONE):"",1:"S"))
S RCDA=0 F S RCDA=$O(VALMY(RCDA)) Q:'RCDA S RC=$G(^TMP("RCDPEX-EOBDX",$J,RCDA)),RCDA(RCDA)=+$P(RC,U,2)
Q
;
DEL ; RCDPEX DELETE DUP MESSAGE option
; Delete messages from messages list - file 344.5
N DIR,RC0,RCDA,RCDIQ,RCE,RCLKBXDA,RCOK,RCPAYTP,RCT,RCTYP,RCU,RCX,Z
D FULL^VALM1
S RCLKBXDA=0
D SEL(.RCDA,1)
S RCDA=$O(RCDA(""))
I RCDA="" G DELQ
S RCLKBXDA=+RCDA(RCDA),RCLKBXDA("iens")=RCLKBXDA_","
S RCPAYTP=$$PAYTYP^RCDPEX(RCLKBXDA)
S DIR(0)="YA",DIR("A",1)="This action will PERMANENTLY delete an EDI Lockbox message from your system",DIR("A",2)="A bulletin will be sent to report the deletion",DIR("A",3)=" "
S DIR("A")="Are you sure you want to continue? ",DIR("B")="NO"
W ! D ^DIR K DIR
G:Y'=1 DELQ
I '$$LOCK(RCLKBXDA) D G DELQ
. K DIR
. S DIR(0)="EA",DIR("A",1)=" ",DIR("A",2)="Unable to lock the EDI LOCKBOX MESSAGE for deletion."
. S DIR("A")="Press ENTER: " D ^DIR
S RC0=$G(^RCY(344.5,RCLKBXDA,0))
;
I $P(RC0,U,5) S RCOK=1 D G:'RCOK DELQ
. N ZTSK
. S ZTSK=$P(RC0,U,5) D STAT^%ZTLOAD Q:ZTSK(0)=0 ;Task not scheduled
. I "12"[ZTSK(1) W !,$C(7)_"This Lockbox message is scheduled for update. Task # is: "_$P(RC0,U,11) S RCOK="" D PAUSE^VALM1
;
S DIR(0)="YA",DIR("A",1)=" ",DIR("A",2)="",$P(DIR("A",2),"*",66)="",DIR("A",3)="* This EDI Lockbox message is about to be PERMANENTLY deleted!! *",DIR("A",4)=DIR("A",2),DIR("A",5)=" "
S DIR("A")="Are you STILL sure you want to continue? ",DIR("B")="NO"
W ! D ^DIR W ! K DIR
I Y'=1 W !!,"Nothing deleted" D PAUSE^VALM1 G DELQ
;
D SNDMLMN(RCLKBXDA),LKBXDEL(RCLKBXDA)
I $D(^RCY(344.5,RCLKBXDA)) D G DELQ
. W !,"EDI Lockbox message not deleted - problem with deletion." D PAUSE^VALM1
;
W !,"A MailMan message has been sent to report this deletion.",!
D PAUSE^VALM1,BLD^RCDPEX1("DUPLICATE ERA")
;
DELQ ; fall through or GOTO here
L -^RCY(344.5,RCLKBXDA,0)
S VALMBCK="R"
Q
;
SNDMLMN(RCLKBXDA) ; send MailMan message about RCLKBXDA entry in 344.5
N J,LN,RCDPDATA,X,XMINSTR,XMTO,XMZ,Y
K ^TMP($J,"RCMMSG") ; mail text storage
S DR=".01:.04;.07:.15"
D DIQ3445^RCDPEX1(RCLKBXDA,DR) ; returns RCDPDATA array
; create MailMan text
S LN=1,^TMP($J,"RCMMSG",LN,0)="An EDI LOCKBOX MESSAGE was deleted "_$$FMTE^XLFDT($$NOW^XLFDT)
S LN=LN+1,^TMP($J,"RCMMSG",LN,0)="The user: "_$$GET1^DIQ(200,DUZ_",",.01)_" (User #"_DUZ_")"
S LN=LN+1,^TMP($J,"RCMMSG",LN,0)=" ",LN=LN+1,^TMP($J,"RCMMSG",LN,0)="Deleted Lockbox Message Information: "
; add data and field labels to message
F J=.01:.01:.04,.07:.01:.15 D
. S X=$G(RCDPDATA(344.5,RCLKBXDA,J,"E")) Q:X="" ; skip null fields
. S LN=LN+1,^TMP($J,"RCMMSG",LN,0)=" > "_$$GET1^DID(344.5,J,"","LABEL")_": "_X
; send as a priority message
S XMTO(DUZ)="",XMTO("G.RCDPE PAYMENTS MGMT")="",XMINSTR("FLAGS")="P"
D SENDMSG^XMXAPI(DUZ,"EDI LOCKBOX MESSAGE DELETION",$NA(^TMP($J,"RCMMSG")),.XMTO,.XMINSTR,.XMZ)
I '$G(ZTSK),$E(IOST,1,2)="C-",$G(XMZ) W !,"MailMan message #"_XMZ_" sent."
K ^TMP($J,"RCMMSG")
Q
;
LKBXDEL(RCLKBXDA) ;Delete entry from AR EDI LOCKBOX MESSAGES file
N DA,DIC,DIK,X,Y S DIK="^RCY(344.5,",DA=RCLKBXDA D ^DIK
Q
;
TASK(RCRTN,RCLKBXDA) ;function, Schedule the task to update data base from message
; RCRTN - routine to task
; RCLKBXDA - IEN in file 344.5
; returns: TaskMan task #
N ZTSK,ZTDESC,ZTIO,ZTDTH,ZTSAVE,DA,DR,DIE
S ZTIO="",ZTDTH=$H,ZTDESC="UPDATE DATA BASE FROM EEOB EXCEPTION PROCESSING",ZTSAVE("RC*")="",ZTRTN=RCRTN
D ^%ZTLOAD
I $G(ZTSK),$G(^RCY(344.5,RCLKBXDA,0)) D
. S DIE="^RCY(344.5,",DR=".05///"_ZTSK_";.04///1;.08///0",DA=RCLKBXDA D ^DIE
Q $G(ZTSK)
;
LOCK(RCLKBXDA) ; Boolean function, lock entry RCLKBXDA in file 344.5
; Return 1 if successful, else zero
Q:'($G(RCLKBXDA)>0) "^no 344.5 IEN to lock" ; error message is also false
N LCK L +^RCY(344.5,RCLKBXDA,0):DILOCKTM S LCK=$T
Q LCK
;
HDR(RCTDA,RCPG) ;Prints report heading
; RCTDA = ien of file 344.5
; RCPG = page # last printed
N Z
I RCPG!($E(IOST,1,2)="C-") W @IOF,*13
I 'RCPG D
. N RCX,RCZ
. D TXT0^RCDPEX(RCTDA,.RCZ,.RCX,0) ; Get 0-node captioned fields
. S Z=0 F S Z=$O(RCX(Z)) Q:'Z S ^TMP($J,"RCHDR_EX",Z)=RCX(Z)
S RCPG=RCPG+1
W !,?15,"EDI LBOX - DUPLICATE ERA - EEOB DETAIL",?55,$$FMTE^XLFDT(DT,2),?70,"Page: ",RCPG,!
S Z=0 F S Z=$O(^TMP($J,"RCHDR_EX",Z)) Q:'Z W !,$G(^(Z))
W !,$TR($J("",IOM)," ","=")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPEX5 8617 printed Oct 16, 2024@17:46:52 Page 2
RCDPEX5 ;ALB/TMK,DWA - ELECTRONIC EOB EXCEPTION PROCESSING - FILE 344.5 ;8 Aug 2018 21:44:13
+1 ;;4.5;Accounts Receivable;**332**;Mar 20, 1995;Build 40
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
UPD ; Update (File) ERA msgs manually from DUPLICATE exception list for file 344.5
+1 NEW RC0,RCDA,RCLKBXDA,RCOK,RCTSK,RCTYP,RCU,ZTSK
+2 DO FULL^VALM1
+3 DO SEL(.RCDA,1)
+4 SET RCDA=$ORDER(RCDA(""))
+5 IF RCDA=""
GOTO UPDQ
+6 SET RCLKBXDA=+RCDA(RCDA)
+7 SET RC0=$GET(^RCY(344.5,RCLKBXDA,0))
+8 IF RC0=""
Begin DoDot:1
+9 WRITE !,$CHAR(7)_"ERA #"_RCDA_" is no longer in exception file"
SET RCOK=0
+10 DO PAUSE^VALM1
End DoDot:1
GOTO UPDQ
+11 ;
+12 IF '$$LOCK(RCLKBXDA)
Begin DoDot:1
+13 WRITE !,$CHAR(7)_"Could not Lock ERA #"_RCDA_" to file it."
SET RCOK=0
+14 DO PAUSE^VALM1
End DoDot:1
GOTO UPDQ
+15 ;
+16 SET RC0=$GET(^RCY(344.5,RCLKBXDA,0))
+17 IF RC0=""
Begin DoDot:1
+18 WRITE !,$CHAR(7)_"ERA #"_RCDA_" is no longer in exception file"
SET RCOK=0
+19 DO PAUSE^VALM1
End DoDot:1
GOTO UPDQ
+20 IF $PIECE(RC0,U,5)
SET RCOK=1
Begin DoDot:1
+21 NEW ZTSK
+22 ;Task not scheduled
SET ZTSK=$PIECE(RC0,U,5)
DO STAT^%ZTLOAD
if ZTSK(0)=0
QUIT
+23 IF "12"[ZTSK(1)
WRITE !,$CHAR(7)_"This record has already been scheduled for update. Task # is: "_$PIECE(RC0,U,5)
SET RCOK=""
DO PAUSE^VALM1
End DoDot:1
if 'RCOK
GOTO UPDQ
+24 ;
+25 SET RCTYP=$PIECE(RC0,U,2)
+26 SET RCU=$SELECT(RCTYP="835ERA":"NEWERA^RCDPESR2("_RCLKBXDA_",1)",RCTYP="835XFR":"FILEEOB^RCDPESR5("_RCLKBXDA_")",1:"")
+27 IF RCU=""
WRITE !,$CHAR(7)_"This message has an invalid 'type' - can't update"
DO PAUSE^VALM1
GOTO UPDQ
+28 SET RCTSK=$$TASK(RCU,RCLKBXDA)
+29 IF RCTSK
WRITE !,"File update has been tasked (#"_RCTSK_")"
+30 IF 'RCTSK
WRITE !,$CHAR(7)_"File update could not be tasked. Please try again later!"
+31 DO PAUSE^VALM1
+32 ;
+33 DO BLD^RCDPEX1("DUPLICATE ERA")
UPDQ ; fall through or GOTO from above
+1 IF $GET(RCLKBXDA)
LOCK -^RCY(344.5,RCLKBXDA)
+2 SET VALMBCK="R"
+3 QUIT
+4 ;
VP ; View/Print ERA Messages - File 344.5
+1 NEW DHD,DIC,FLDS,BY,FR,TO,DIR,Y,L,RCDA,RCTDA,RCRAW,POP
+2 DO FULL^VALM1
DO SEL(.RCDA,1)
+3 SET RCDA=$ORDER(RCDA(""))
+4 if 'RCDA
GOTO VPQ
+5 SET RCTDA=$GET(RCDA(RCDA))
+6 SET DIR(0)="YA"
SET DIR("A")="DO YOU WANT TO INCLUDE DATA THE WAY IT WAS RECEIVED (RAW DATA)?: "
SET DIR("B")="N"
DO ^DIR
KILL DIR
+7 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO VPQ
+8 SET RCRAW=+Y
+9 ; Ask device
+10 NEW %ZIS,ZTRTN,ZTSAVE,ZTDESC
+11 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO VPQ
+12 IF $DATA(IO("Q"))
Begin DoDot:1
+13 SET ZTRTN="VPOUT^RCDPEX"
SET ZTDESC="AR - Print EEOB Exception Message"
+14 SET ZTSAVE("RCTDA")=""
SET ZTSAVE("RCRAW")=""
+15 DO ^%ZTLOAD
+16 WRITE !!,$SELECT($DATA(ZTSK):"Your task number"_ZTSK_" has been queued.",1:"Unable to queue this job.")
+17 KILL ZTSK,IO("Q")
DO HOME^%ZIS
End DoDot:1
GOTO VPQ
+18 USE IO
+19 ;
VPOUT ; Entrypoint for queued job
+1 NEW Z,Z0,RCSTOP,RCPG,RCXM,RCXM1,RC,RCZ,RCTDAC,RCV5
+2 KILL ^TMP($JOB,"RCRAW"),^TMP($JOB,"RCOUT")
+3 SET RCTDAC=RCTDA_","
SET RCV5=0
+4 ;
+5 DO GETS^DIQ(344.5,RCTDAC,"*","IEN","RCZ")
+6 DO TXTDE^RCDPEX(RCTDA,.RCZ,1,.RCXM,.RC)
+7 ;
+8 IF $ORDER(^RCY(344.5,RCTDA,"EX",0))
Begin DoDot:1
+9 SET RC=RC+1
SET RCXM(RC)="**EXCEPTION MESSAGES**"
+10 DO TXTDE^RCDPEX(RCTDA,.RCZ,5,.RCXM,.RC)
End DoDot:1
+11 ;
+12 KILL ^TMP("RCSAVE",$JOB)
+13 MERGE ^TMP("RCSAVE",$JOB)=^RCY(344.5,RCTDA,2)
+14 IF +$PIECE($GET(^TMP("RCSAVE",$JOB,1,0)),U,16)>0
SET RCV5=1
+15 ; Get rid of header node
SET Z=0
FOR
SET Z=$ORDER(^TMP("RCSAVE",$JOB,Z))
if 'Z
QUIT
IF $PIECE($GET(^(Z,0)),U)["835"
KILL ^(0)
QUIT
+16 ; Get formatted 'raw' data
DO DISP^RCDPESR0("^TMP(""RCSAVE"",$J)","^TMP($J,""RCRAW"")",1,"^TMP($J,""RCOUT"")",75)
+17 KILL ^TMP("RCSAVE",$JOB)
+18 IF $GET(RCRAW)
Begin DoDot:1
+19 SET RC=$ORDER(^TMP($JOB,"RCOUT",""),-1)+1
SET ^TMP($JOB,"RCOUT",RC)=" "
+20 SET RC=RC+1
SET ^TMP($JOB,"RCOUT",RC)="**RAW DATA**"
+21 SET Z=0
FOR
SET Z=$ORDER(^RCY(344.5,RCTDA,2,Z))
if 'Z
QUIT
Begin DoDot:2
+22 FOR Z0=1:80:$LENGTH($GET(^RCY(344.5,RCTDA,2,Z,0)))
SET RC=RC+1
SET ^TMP($JOB,"RCOUT",RC)=$EXTRACT($GET(^RCY(344.5,RCTDA,2,Z,0)),Z0,Z0+79)
End DoDot:2
End DoDot:1
+23 ;
+24 SET (RCPG,RCSTOP,Z)=0
+25 FOR
SET Z=$ORDER(RCXM(Z))
if 'Z
QUIT
SET ^TMP($JOB,"RCOUT",Z-999)=RCXM(Z)
+26 SET Z=""
+27 FOR
SET Z=$ORDER(^TMP($JOB,"RCOUT",Z))
if 'Z
QUIT
Begin DoDot:1
+28 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET (RCSTOP,ZTSTOP)=1
KILL ZTREQ
IF +$GET(RCPG)
WRITE !,"***TASK STOPPED BY USER***"
QUIT
+29 IF 'RCPG!(($Y+5)>IOSL)
Begin DoDot:2
+30 if RCPG
DO ASK^RCDPEX(.RCSTOP)
IF RCSTOP
QUIT
+31 DO HDR(RCTDA,.RCPG)
End DoDot:2
IF RCSTOP
QUIT
+32 WRITE !,$GET(^TMP($JOB,"RCOUT",Z))
End DoDot:1
if RCSTOP
QUIT
+33 IF 'RCSTOP
IF RCPG
DO ASK^RCDPEX(.RCSTOP)
+34 ;
+35 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+36 IF '$DATA(ZTQUEUED)
DO ^%ZISC
+37 ;
VPQ KILL ^TMP($JOB,"RCRAW"),^TMP($JOB,"RCOUT")
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
SEL(RCDA,ONE) ; Select entry(s) from list
+1 ; RCDA = array returned if selections made
+2 ; RCDA(n)=ien of bill selected in file 344.5
+3 ; ONE = if set to 1, only one selection can be made at a time
+4 NEW RC
+5 KILL RCDA
+6 DO EN^VALM2($GET(XQORNOD(0)),$SELECT('$GET(ONE):"",1:"S"))
+7 SET RCDA=0
FOR
SET RCDA=$ORDER(VALMY(RCDA))
if 'RCDA
QUIT
SET RC=$GET(^TMP("RCDPEX-EOBDX",$JOB,RCDA))
SET RCDA(RCDA)=+$PIECE(RC,U,2)
+8 QUIT
+9 ;
DEL ; RCDPEX DELETE DUP MESSAGE option
+1 ; Delete messages from messages list - file 344.5
+2 NEW DIR,RC0,RCDA,RCDIQ,RCE,RCLKBXDA,RCOK,RCPAYTP,RCT,RCTYP,RCU,RCX,Z
+3 DO FULL^VALM1
+4 SET RCLKBXDA=0
+5 DO SEL(.RCDA,1)
+6 SET RCDA=$ORDER(RCDA(""))
+7 IF RCDA=""
GOTO DELQ
+8 SET RCLKBXDA=+RCDA(RCDA)
SET RCLKBXDA("iens")=RCLKBXDA_","
+9 SET RCPAYTP=$$PAYTYP^RCDPEX(RCLKBXDA)
+10 SET DIR(0)="YA"
SET DIR("A",1)="This action will PERMANENTLY delete an EDI Lockbox message from your system"
SET DIR("A",2)="A bulletin will be sent to report the deletion"
SET DIR("A",3)=" "
+11 SET DIR("A")="Are you sure you want to continue? "
SET DIR("B")="NO"
+12 WRITE !
DO ^DIR
KILL DIR
+13 if Y'=1
GOTO DELQ
+14 IF '$$LOCK(RCLKBXDA)
Begin DoDot:1
+15 KILL DIR
+16 SET DIR(0)="EA"
SET DIR("A",1)=" "
SET DIR("A",2)="Unable to lock the EDI LOCKBOX MESSAGE for deletion."
+17 SET DIR("A")="Press ENTER: "
DO ^DIR
End DoDot:1
GOTO DELQ
+18 SET RC0=$GET(^RCY(344.5,RCLKBXDA,0))
+19 ;
+20 IF $PIECE(RC0,U,5)
SET RCOK=1
Begin DoDot:1
+21 NEW ZTSK
+22 ;Task not scheduled
SET ZTSK=$PIECE(RC0,U,5)
DO STAT^%ZTLOAD
if ZTSK(0)=0
QUIT
+23 IF "12"[ZTSK(1)
WRITE !,$CHAR(7)_"This Lockbox message is scheduled for update. Task # is: "_$PIECE(RC0,U,11)
SET RCOK=""
DO PAUSE^VALM1
End DoDot:1
if 'RCOK
GOTO DELQ
+24 ;
+25 SET DIR(0)="YA"
SET DIR("A",1)=" "
SET DIR("A",2)=""
SET $PIECE(DIR("A",2),"*",66)=""
SET DIR("A",3)="* This EDI Lockbox message is about to be PERMANENTLY deleted!! *"
SET DIR("A",4)=DIR("A",2)
SET DIR("A",5)=" "
+26 SET DIR("A")="Are you STILL sure you want to continue? "
SET DIR("B")="NO"
+27 WRITE !
DO ^DIR
WRITE !
KILL DIR
+28 IF Y'=1
WRITE !!,"Nothing deleted"
DO PAUSE^VALM1
GOTO DELQ
+29 ;
+30 DO SNDMLMN(RCLKBXDA)
DO LKBXDEL(RCLKBXDA)
+31 IF $DATA(^RCY(344.5,RCLKBXDA))
Begin DoDot:1
+32 WRITE !,"EDI Lockbox message not deleted - problem with deletion."
DO PAUSE^VALM1
End DoDot:1
GOTO DELQ
+33 ;
+34 WRITE !,"A MailMan message has been sent to report this deletion.",!
+35 DO PAUSE^VALM1
DO BLD^RCDPEX1("DUPLICATE ERA")
+36 ;
DELQ ; fall through or GOTO here
+1 LOCK -^RCY(344.5,RCLKBXDA,0)
+2 SET VALMBCK="R"
+3 QUIT
+4 ;
SNDMLMN(RCLKBXDA) ; send MailMan message about RCLKBXDA entry in 344.5
+1 NEW J,LN,RCDPDATA,X,XMINSTR,XMTO,XMZ,Y
+2 ; mail text storage
KILL ^TMP($JOB,"RCMMSG")
+3 SET DR=".01:.04;.07:.15"
+4 ; returns RCDPDATA array
DO DIQ3445^RCDPEX1(RCLKBXDA,DR)
+5 ; create MailMan text
+6 SET LN=1
SET ^TMP($JOB,"RCMMSG",LN,0)="An EDI LOCKBOX MESSAGE was deleted "_$$FMTE^XLFDT($$NOW^XLFDT)
+7 SET LN=LN+1
SET ^TMP($JOB,"RCMMSG",LN,0)="The user: "_$$GET1^DIQ(200,DUZ_",",.01)_" (User #"_DUZ_")"
+8 SET LN=LN+1
SET ^TMP($JOB,"RCMMSG",LN,0)=" "
SET LN=LN+1
SET ^TMP($JOB,"RCMMSG",LN,0)="Deleted Lockbox Message Information: "
+9 ; add data and field labels to message
+10 FOR J=.01:.01:.04,.07:.01:.15
Begin DoDot:1
+11 ; skip null fields
SET X=$GET(RCDPDATA(344.5,RCLKBXDA,J,"E"))
if X=""
QUIT
+12 SET LN=LN+1
SET ^TMP($JOB,"RCMMSG",LN,0)=" > "_$$GET1^DID(344.5,J,"","LABEL")_": "_X
End DoDot:1
+13 ; send as a priority message
+14 SET XMTO(DUZ)=""
SET XMTO("G.RCDPE PAYMENTS MGMT")=""
SET XMINSTR("FLAGS")="P"
+15 DO SENDMSG^XMXAPI(DUZ,"EDI LOCKBOX MESSAGE DELETION",$NAME(^TMP($JOB,"RCMMSG")),.XMTO,.XMINSTR,.XMZ)
+16 IF '$GET(ZTSK)
IF $EXTRACT(IOST,1,2)="C-"
IF $GET(XMZ)
WRITE !,"MailMan message #"_XMZ_" sent."
+17 KILL ^TMP($JOB,"RCMMSG")
+18 QUIT
+19 ;
LKBXDEL(RCLKBXDA) ;Delete entry from AR EDI LOCKBOX MESSAGES file
+1 NEW DA,DIC,DIK,X,Y
SET DIK="^RCY(344.5,"
SET DA=RCLKBXDA
DO ^DIK
+2 QUIT
+3 ;
TASK(RCRTN,RCLKBXDA) ;function, Schedule the task to update data base from message
+1 ; RCRTN - routine to task
+2 ; RCLKBXDA - IEN in file 344.5
+3 ; returns: TaskMan task #
+4 NEW ZTSK,ZTDESC,ZTIO,ZTDTH,ZTSAVE,DA,DR,DIE
+5 SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTDESC="UPDATE DATA BASE FROM EEOB EXCEPTION PROCESSING"
SET ZTSAVE("RC*")=""
SET ZTRTN=RCRTN
+6 DO ^%ZTLOAD
+7 IF $GET(ZTSK)
IF $GET(^RCY(344.5,RCLKBXDA,0))
Begin DoDot:1
+8 SET DIE="^RCY(344.5,"
SET DR=".05///"_ZTSK_";.04///1;.08///0"
SET DA=RCLKBXDA
DO ^DIE
End DoDot:1
+9 QUIT $GET(ZTSK)
+10 ;
LOCK(RCLKBXDA) ; Boolean function, lock entry RCLKBXDA in file 344.5
+1 ; Return 1 if successful, else zero
+2 ; error message is also false
if '($GET(RCLKBXDA)>0)
QUIT "^no 344.5 IEN to lock"
+3 NEW LCK
LOCK +^RCY(344.5,RCLKBXDA,0):DILOCKTM
SET LCK=$TEST
+4 QUIT LCK
+5 ;
HDR(RCTDA,RCPG) ;Prints report heading
+1 ; RCTDA = ien of file 344.5
+2 ; RCPG = page # last printed
+3 NEW Z
+4 IF RCPG!($EXTRACT(IOST,1,2)="C-")
WRITE @IOF,*13
+5 IF 'RCPG
Begin DoDot:1
+6 NEW RCX,RCZ
+7 ; Get 0-node captioned fields
DO TXT0^RCDPEX(RCTDA,.RCZ,.RCX,0)
+8 SET Z=0
FOR
SET Z=$ORDER(RCX(Z))
if 'Z
QUIT
SET ^TMP($JOB,"RCHDR_EX",Z)=RCX(Z)
End DoDot:1
+9 SET RCPG=RCPG+1
+10 WRITE !,?15,"EDI LBOX - DUPLICATE ERA - EEOB DETAIL",?55,$$FMTE^XLFDT(DT,2),?70,"Page: ",RCPG,!
+11 SET Z=0
FOR
SET Z=$ORDER(^TMP($JOB,"RCHDR_EX",Z))
if 'Z
QUIT
WRITE !,$GET(^(Z))
+12 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","=")
+13 QUIT
