IBCEM ;ALB/TMP - 837 EDI RETURN MESSAGE PROCESSING ;17-APR-96
;;2.0;INTEGRATED BILLING;**137,191,155,371,547**;21-MAR-94;Build 119
;;Per VA Directive 6402, this routine should not be modified.
Q
;
UPD ; Update messages manually from messages list
N IBDA,IBOK,IBTDA,ZTSK,IBTSK,IBTYP,IBU,IBU1,IB0
D FULL^VALM1
D SEL(.IBDA,1)
S IBDA=$O(IBDA(""))
I IBDA="" G UPDQ
S IBTDA=+IBDA(IBDA)
I '$$LOCK(IBTDA) G UPDQ
S IB0=$G(^IBA(364.2,IBTDA,0))
;
I IB0="" D G UPDQ
. W !,*7,"Message ",IBDA," is no longer in return message file" S IBOK=""
. D PAUSE^VALM1
I $P(IB0,U,11) S IBOK=1 D G:'IBOK UPDQ
. N ZTSK
. S ZTSK=$P(IB0,U,11) D STAT^%ZTLOAD Q:ZTSK(0)=0 ;Task not scheduled
. I "12"[ZTSK(1) W *7,!,"This message has already been scheduled for update. Task # is: ",$P(IB0,U,11) S IBOK="" D PAUSE^VALM1
;
I $P(IB0,U,6)=""!("UP"'[$P(IB0,U,6)) D G UPDQ
. W !,*7,"Message status ("_$$EXPAND^IBTRE(364.2,.06,$P(IB0,U,6))_") is not appropriate for this action"
. D PAUSE^VALM1
;
S IBTYP=$P($G(^IBE(364.3,+$P(IB0,U,2),0)),U)
S IBU=$S(IBTYP="REPORT":"MAILIT^IBCESRV2",IBTYP["837REC":"CON837^IBCESRV2",IBTYP["837REJ":"REJ837^IBCESRV2",IBTYP["835EOB":"EOB835^IBCESRV3",1:""),IBU1=$S(IBTYP["837":$E(IBTYP,$L(IBTYP)),1:2)
I IBU="" W !,*7,"This message has an invalid message type - can't update" D PAUSE^VALM1 G UPDQ
S IBTSK=$$TASK(IBU,$P(IB0,U,4),IBTDA,IBU1)
I IBTSK W !,"Update has been tasked (#",IBTSK,")"
I 'IBTSK W !,*7,"Update could not be tasked. Please try again later!!!"
D PAUSE^VALM1
;
D BLD^IBCEM1
UPDQ I $G(IBTDA) L -^IBA(364.2,IBTDA,0)
S VALMBCK="R"
Q
;
VP ; View/Print Return Messages
N DHD,DIC,FLDS,BY,FR,TO,DIR,Y,L,IBDA,IBTDA,IBBILLS
D FULL^VALM1,SEL(.IBDA,1)
S IBDA=$O(IBDA(""))
G:'IBDA VPQ
S IBTDA=$G(IBDA(IBDA)),IBBILLS=""
I $P($G(^IBA(364.2,IBTDA,0)),U,4),'$P(^(0),U,5) D
.S DIR(0)="YA",DIR("B")="NO",DIR("A")="Do you want to list all bills for this batch?: " D ^DIR K DIR
.I Y S IBBILLS=1
S DHD=$S(IBBILLS:"[IBCEM MESSAGE LIST HDR]",1:""),DIC="^IBA(364.2,",FLDS=$S(IBBILLS:"[IBCEM MESSAGE LIST]",1:"[CAPTIONED]"),BY="@NUMBER",(FR,TO)=$G(IBDA(IBDA)),L=0 D EN1^DIP
D PAUSE^VALM1
VPQ S VALMBCK="R"
Q
;
SEL(IBDA,ONE) ; Select entry(s) from list
; IBDA = array returned if selections made
; IBDA(n)=ien of bill selected in file 399
; ONE = if set to 1, only one selection can be made at a time
N IB
K IBDA
D EN^VALM2($G(XQORNOD(0)),$S('$G(ONE):"",1:"S"))
S IBDA=0 F S IBDA=$O(VALMY(IBDA)) Q:'IBDA S IB=$G(^TMP("IBCEM-837DX",$J,IBDA)),IBDA(IBDA)=+$P(IB,U,2)
Q
;
UPDEDI(IBDA,FUNC,NOCT,MSCN) ; Update EDI files - cancel/resubmit/print as
; resolution to message
; IBDA = transmit bill ien # for bill
; FUNC = "E" for edit/resubmit, "C" for cancel, "R" for resubmit not
; from edit, "P" for print, "Z" for COB processed , "N" for no
; further action needed-close record
; NOCT = 1 if not necessary to update batch count, 0 if update needed
; MSCN = 2 if this call came from CLONE and the cloned claim is a secondary and its primary was an MRA
; (secondaries created from MRA primaries share the same claim#. Do not want to cancel MRA
; associated with the primary, only any EOBs associated with the cloned secondary claim).
;
N IB0,IBBA,IBBDA,IBCT,IBM,IBTDA,IBNEW,DA,DIE,DR,Z,IBTEXT,IBZ,IBIFN,IBSTAT
S IB0=$G(^IBA(364,+IBDA,0)),IBBA=$P(IB0,U,2)
Q:IB0="" S IBIFN=+IB0
;
S IBNEW=$S(FUNC="E"!(FUNC="R"):+$P($G(^IBA(364,+$$LAST364^IBCEF4(+IB0),0)),U,2),1:"") S:IBNEW=IBBA IBNEW=""
;
S IBSTAT=$P(IB0,U,3) ; current status in file 364
I '$F(".C.R.E.Z.","."_IBSTAT_".") D ; don't update if in final status
. S DR=".03////"_$S(FUNC="E":"R","NP"'[FUNC:FUNC,1:"Z")_";.04///NOW" S:FUNC="E"!(FUNC="R") DR=DR_$S(IBNEW:";.06////"_IBNEW,1:"")
. S DA=+IBDA,DIE="^IBA(364," D ^DIE ;Update the transmit bill record
. Q
;
I IBBA D CKRES^IBCESRV2(IBBA) ;Update completely resubmitted flags
;
I IBBA,(FUNC="P"!(IBNEW&'$G(NOCT))) D CTDOWN^IBCEM02(IBBA,1) ;If resubmitted in a new batch or printed, update old batch
;
S IBTEXT(1)=" UPDATED BY: "_$$EXTERNAL^DILFD(361.02,.02,,+$G(DUZ))
S IBTEXT(2)="ACTION USED: "_$S(FUNC="E":"BILL EDITED/RESUBMITTED",FUNC="C":"BILL CANCELED",FUNC="R":"BILL RESUBMITTED WITHOUT EDIT",FUNC="P":"PRINT BILL",FUNC="Z":"PROCESS COB",1:"")
S IBTEXT(2)=$S(IBTEXT(2)="":"UNSPECIFIED",1:IBTEXT(2)_" - REVIEW MARKED AS COMPLETE")
S IBTEXT=2
;
; Update file 361
S IBZ=0 F S IBZ=$O(^IBM(361,"AERR",+IBDA,IBZ)) Q:'IBZ I $D(^IBM(361,IBZ,0)),$P(^(0),U,10)="",$P(^(0),U,9)<2 D
. S DIE="^IBM(361,",DR=".09////2;.1////"_$TR(FUNC,"RCEIBZPN","RCROOFOO"),DA=IBZ D ^DIE
. I FUNC'="","ECRPIBZ"[FUNC D ; Update review status, notes for message
.. D NOTECHG^IBCECSA2(IBZ,1,.IBTEXT)
;
; Update file 361.1 with the Cancel Status, to cancel All EOB's on file
; patch 547***, Pass #2 if don't want to cancel MRA, otherwise pass 0
; I FUNC="C" D STAT^IBCEMU2(IBIFN,9,0)
I FUNC="C" D STAT^IBCEMU2(IBIFN,9,+$G(MSCN))
;
Q
;
DEL ; Delete messages from messages list - locked with IB SUPERVISOR key
N IBDA,IBOK,IBTDA,IBTYP,IBU,IBU1,IB0,DIR,IBT,IBE,Z,X,Y,XMSUBJ,XMTO,XMBODY,XMDUZ
D FULL^VALM1
S IBTDA=0
I '$D(^XUSEC("IB SUPERVISOR",DUZ)) D G DELQ
. W !,"You don't have authority to use this action. See your supervisr for assistance"
. D PAUSE^VALM1
D SEL(.IBDA,1)
S IBDA=$O(IBDA(""))
I IBDA="" G DELQ
W !
S DIR(0)="YA",DIR("A",1)="This action will PERMANENTLY delete a return 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"
D ^DIR K DIR
G:Y'=1 DELQ
S IBTDA=+IBDA(IBDA)
I '$$LOCK(IBTDA) G DELQ
S IB0=$G(^IBA(364.2,IBTDA,0))
;
I $P(IB0,U,11) S IBOK=1 D G:'IBOK DELQ
. N ZTSK
. S ZTSK=$P(IB0,U,11) D STAT^%ZTLOAD Q:ZTSK(0)=0 ;Task not scheduled
. I "12"[ZTSK(1) W *7,!,"This message is currently scheduled for update. Task # is: ",$P(IB0,U,11) S IBOK="" D PAUSE^VALM1
;
I $P(IB0,U,6)=""!("UP"'[$P(IB0,U,6)) D G DELQ
. W !,*7,"Message status ("_$$EXPAND^IBTRE(364.2,.06,$P(IB0,U,6))_") is not appropriate for this action"
. D PAUSE^VALM1
;
S DIR(0)="YA",DIR("A",1)=" ",DIR("A",2)="",$P(DIR("A",2),"*",54)="",DIR("A",3)="* This 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
;
K ^TMP("IBMSG",$J)
M ^TMP("IBMSG",$J)=^IBA(364.2,IBTDA)
D DELMSG^IBCESRV2(IBTDA)
I $D(^IBA(364.2,IBTDA)) D G DELQ
. W !,"Message not deleted - problem with delete" D PAUSE^VALM1
;
S IBT(1)="EDI return message #"_$P(IB0,U)_" has been deleted"
S IBT(2)=" "
S IBT(3)="DELETED BY: "_$P($G(^VA(200,+$G(DUZ),0)),U)_" "_$$FMTE^XLFDT($$NOW^XLFDT,2)
S Z=$$EXPAND^IBTRE(364.2,.06,$P(IB0,U,6)) S:Z="" Z="??"
S IBT(4)=" STATUS: "_$E(Z_$J("",11),1,11)_" MESSAGE TYPE: "_$P($G(^IBE(364.3,+$P(IB0,U,2),0)),U,5)
S IBT(5)=" MESSAGE #: "_$E($P(IB0,U)_$J("",11),1,11)_" STATUS DATE: "_$$FMTE^XLFDT($P($G(^TMP("IBMSG",$J,1)),U,3))
S IBT(6)=" BATCH #: "_$E($P($G(^IBA(364.1,+$P(IB0,U,4),0)),U)_$J("",11),1,11)_" BILL #: "_$$EXPAND^IBTRE(364.2,.05,$P(IB0,U,5))
S IBT(7)=" "
S IBT(8)="MESSAGE TEXT:",IBE=8
S Z=0 F S Z=$O(^TMP("IBMSG",$J,2,Z)) Q:'Z S IBE=IBE+1,IBT(IBE)=$G(^(Z,0))
S XMSUBJ="EDI MESSAGE DELETED",XMBODY="IBT",XMDUZ="",XMTO("I:G.IB EDI")=""
D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
;
K ^TMP("IBMSG",$J)
;
W !,"A bulletin has been sent to report this deletion",!
D PAUSE^VALM1
;
D BLD^IBCEM1
DELQ L -^IBA(364.2,IBTDA,0)
S VALMBCK="R"
Q
;
TASK(IBRTN,IBBDA,IBTDA,IBTYP) ; Schedule the task to update data base from message
; IBRTN = routine to task
; IBBDA = batch # associated with the message (OPTIONAL)
; IBTDA = internal entry of message
; IBTYP = the number that is the last digit in the message type
;
N ZTSK,ZTDESC,ZTIO,ZTDTH,ZTSAVE,DA,DR,DIE
S ZTIO="",ZTDTH=$H,ZTDESC="UPDATE DATA BASE FROM EDI RETURN MESSAGE",ZTSAVE("IB*")="",ZTRTN=IBRTN
D ^%ZTLOAD
I $G(ZTSK),$G(^IBA(364.2,IBTDA,0)) S DIE="^IBA(364.2,",DR=".11////"_ZTSK_";.06////U",DA=IBTDA D ^DIE
Q $G(ZTSK)
;
LOCK(IBTDA) ; Attempt to lock message file entry IBTDA
; Return 1 if successful, 0 if not able to lock
;
N OK
S OK=1
L +^IBA(364.2,IBTDA,0):5
I '$T D
. I '$D(DIQUIET) W !,*7,"Another user is editing this entry ... try again later" D PAUSE^VALM1
. S IBDA="",OK=0
Q OK
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEM 8641 printed Apr 09, 2024@21:37:42 Page 2
IBCEM ;ALB/TMP - 837 EDI RETURN MESSAGE PROCESSING ;17-APR-96
+1 ;;2.0;INTEGRATED BILLING;**137,191,155,371,547**;21-MAR-94;Build 119
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
UPD ; Update messages manually from messages list
+1 NEW IBDA,IBOK,IBTDA,ZTSK,IBTSK,IBTYP,IBU,IBU1,IB0
+2 DO FULL^VALM1
+3 DO SEL(.IBDA,1)
+4 SET IBDA=$ORDER(IBDA(""))
+5 IF IBDA=""
GOTO UPDQ
+6 SET IBTDA=+IBDA(IBDA)
+7 IF '$$LOCK(IBTDA)
GOTO UPDQ
+8 SET IB0=$GET(^IBA(364.2,IBTDA,0))
+9 ;
+10 IF IB0=""
Begin DoDot:1
+11 WRITE !,*7,"Message ",IBDA," is no longer in return message file"
SET IBOK=""
+12 DO PAUSE^VALM1
End DoDot:1
GOTO UPDQ
+13 IF $PIECE(IB0,U,11)
SET IBOK=1
Begin DoDot:1
+14 NEW ZTSK
+15 ;Task not scheduled
SET ZTSK=$PIECE(IB0,U,11)
DO STAT^%ZTLOAD
if ZTSK(0)=0
QUIT
+16 IF "12"[ZTSK(1)
WRITE *7,!,"This message has already been scheduled for update. Task # is: ",$PIECE(IB0,U,11)
SET IBOK=""
DO PAUSE^VALM1
End DoDot:1
if 'IBOK
GOTO UPDQ
+17 ;
+18 IF $PIECE(IB0,U,6)=""!("UP"'[$PIECE(IB0,U,6))
Begin DoDot:1
+19 WRITE !,*7,"Message status ("_$$EXPAND^IBTRE(364.2,.06,$PIECE(IB0,U,6))_") is not appropriate for this action"
+20 DO PAUSE^VALM1
End DoDot:1
GOTO UPDQ
+21 ;
+22 SET IBTYP=$PIECE($GET(^IBE(364.3,+$PIECE(IB0,U,2),0)),U)
+23 SET IBU=$SELECT(IBTYP="REPORT":"MAILIT^IBCESRV2",IBTYP["837REC":"CON837^IBCESRV2",IBTYP["837REJ":"REJ837^IBCESRV2",IBTYP["835EOB":"EOB835^IBCESRV3",1:"")
SET IBU1=$SELECT(IBTYP["837":$EXTRACT(IBTYP,$LENGTH(IBTYP)),1:2)
+24 IF IBU=""
WRITE !,*7,"This message has an invalid message type - can't update"
DO PAUSE^VALM1
GOTO UPDQ
+25 SET IBTSK=$$TASK(IBU,$PIECE(IB0,U,4),IBTDA,IBU1)
+26 IF IBTSK
WRITE !,"Update has been tasked (#",IBTSK,")"
+27 IF 'IBTSK
WRITE !,*7,"Update could not be tasked. Please try again later!!!"
+28 DO PAUSE^VALM1
+29 ;
+30 DO BLD^IBCEM1
UPDQ IF $GET(IBTDA)
LOCK -^IBA(364.2,IBTDA,0)
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
VP ; View/Print Return Messages
+1 NEW DHD,DIC,FLDS,BY,FR,TO,DIR,Y,L,IBDA,IBTDA,IBBILLS
+2 DO FULL^VALM1
DO SEL(.IBDA,1)
+3 SET IBDA=$ORDER(IBDA(""))
+4 if 'IBDA
GOTO VPQ
+5 SET IBTDA=$GET(IBDA(IBDA))
SET IBBILLS=""
+6 IF $PIECE($GET(^IBA(364.2,IBTDA,0)),U,4)
IF '$PIECE(^(0),U,5)
Begin DoDot:1
+7 SET DIR(0)="YA"
SET DIR("B")="NO"
SET DIR("A")="Do you want to list all bills for this batch?: "
DO ^DIR
KILL DIR
+8 IF Y
SET IBBILLS=1
End DoDot:1
+9 SET DHD=$SELECT(IBBILLS:"[IBCEM MESSAGE LIST HDR]",1:"")
SET DIC="^IBA(364.2,"
SET FLDS=$SELECT(IBBILLS:"[IBCEM MESSAGE LIST]",1:"[CAPTIONED]")
SET BY="@NUMBER"
SET (FR,TO)=$GET(IBDA(IBDA))
SET L=0
DO EN1^DIP
+10 DO PAUSE^VALM1
VPQ SET VALMBCK="R"
+1 QUIT
+2 ;
SEL(IBDA,ONE) ; Select entry(s) from list
+1 ; IBDA = array returned if selections made
+2 ; IBDA(n)=ien of bill selected in file 399
+3 ; ONE = if set to 1, only one selection can be made at a time
+4 NEW IB
+5 KILL IBDA
+6 DO EN^VALM2($GET(XQORNOD(0)),$SELECT('$GET(ONE):"",1:"S"))
+7 SET IBDA=0
FOR
SET IBDA=$ORDER(VALMY(IBDA))
if 'IBDA
QUIT
SET IB=$GET(^TMP("IBCEM-837DX",$JOB,IBDA))
SET IBDA(IBDA)=+$PIECE(IB,U,2)
+8 QUIT
+9 ;
UPDEDI(IBDA,FUNC,NOCT,MSCN) ; Update EDI files - cancel/resubmit/print as
+1 ; resolution to message
+2 ; IBDA = transmit bill ien # for bill
+3 ; FUNC = "E" for edit/resubmit, "C" for cancel, "R" for resubmit not
+4 ; from edit, "P" for print, "Z" for COB processed , "N" for no
+5 ; further action needed-close record
+6 ; NOCT = 1 if not necessary to update batch count, 0 if update needed
+7 ; MSCN = 2 if this call came from CLONE and the cloned claim is a secondary and its primary was an MRA
+8 ; (secondaries created from MRA primaries share the same claim#. Do not want to cancel MRA
+9 ; associated with the primary, only any EOBs associated with the cloned secondary claim).
+10 ;
+11 NEW IB0,IBBA,IBBDA,IBCT,IBM,IBTDA,IBNEW,DA,DIE,DR,Z,IBTEXT,IBZ,IBIFN,IBSTAT
+12 SET IB0=$GET(^IBA(364,+IBDA,0))
SET IBBA=$PIECE(IB0,U,2)
+13 if IB0=""
QUIT
SET IBIFN=+IB0
+14 ;
+15 SET IBNEW=$SELECT(FUNC="E"!(FUNC="R"):+$PIECE($GET(^IBA(364,+$$LAST364^IBCEF4(+IB0),0)),U,2),1:"")
if IBNEW=IBBA
SET IBNEW=""
+16 ;
+17 ; current status in file 364
SET IBSTAT=$PIECE(IB0,U,3)
+18 ; don't update if in final status
IF '$FIND(".C.R.E.Z.","."_IBSTAT_".")
Begin DoDot:1
+19 SET DR=".03////"_$SELECT(FUNC="E":"R","NP"'[FUNC:FUNC,1:"Z")_";.04///NOW"
if FUNC="E"!(FUNC="R")
SET DR=DR_$SELECT(IBNEW:";.06////"_IBNEW,1:"")
+20 ;Update the transmit bill record
SET DA=+IBDA
SET DIE="^IBA(364,"
DO ^DIE
+21 QUIT
End DoDot:1
+22 ;
+23 ;Update completely resubmitted flags
IF IBBA
DO CKRES^IBCESRV2(IBBA)
+24 ;
+25 ;If resubmitted in a new batch or printed, update old batch
IF IBBA
IF (FUNC="P"!(IBNEW&'$GET(NOCT)))
DO CTDOWN^IBCEM02(IBBA,1)
+26 ;
+27 SET IBTEXT(1)=" UPDATED BY: "_$$EXTERNAL^DILFD(361.02,.02,,+$GET(DUZ))
+28 SET IBTEXT(2)="ACTION USED: "_$SELECT(FUNC="E":"BILL EDITED/RESUBMITTED",FUNC="C":"BILL CANCELED",FUNC="R":"BILL RESUBMITTED WITHOUT EDIT",FUNC="P":"PRINT BILL",FUNC="Z":"PROCESS COB",1:"")
+29 SET IBTEXT(2)=$SELECT(IBTEXT(2)="":"UNSPECIFIED",1:IBTEXT(2)_" - REVIEW MARKED AS COMPLETE")
+30 SET IBTEXT=2
+31 ;
+32 ; Update file 361
+33 SET IBZ=0
FOR
SET IBZ=$ORDER(^IBM(361,"AERR",+IBDA,IBZ))
if 'IBZ
QUIT
IF $DATA(^IBM(361,IBZ,0))
IF $PIECE(^(0),U,10)=""
IF $PIECE(^(0),U,9)<2
Begin DoDot:1
+34 SET DIE="^IBM(361,"
SET DR=".09////2;.1////"_$TRANSLATE(FUNC,"RCEIBZPN","RCROOFOO")
SET DA=IBZ
DO ^DIE
+35 ; Update review status, notes for message
IF FUNC'=""
IF "ECRPIBZ"[FUNC
Begin DoDot:2
+36 DO NOTECHG^IBCECSA2(IBZ,1,.IBTEXT)
End DoDot:2
End DoDot:1
+37 ;
+38 ; Update file 361.1 with the Cancel Status, to cancel All EOB's on file
+39 ; patch 547***, Pass #2 if don't want to cancel MRA, otherwise pass 0
+40 ; I FUNC="C" D STAT^IBCEMU2(IBIFN,9,0)
+41 IF FUNC="C"
DO STAT^IBCEMU2(IBIFN,9,+$GET(MSCN))
+42 ;
+43 QUIT
+44 ;
DEL ; Delete messages from messages list - locked with IB SUPERVISOR key
+1 NEW IBDA,IBOK,IBTDA,IBTYP,IBU,IBU1,IB0,DIR,IBT,IBE,Z,X,Y,XMSUBJ,XMTO,XMBODY,XMDUZ
+2 DO FULL^VALM1
+3 SET IBTDA=0
+4 IF '$DATA(^XUSEC("IB SUPERVISOR",DUZ))
Begin DoDot:1
+5 WRITE !,"You don't have authority to use this action. See your supervisr for assistance"
+6 DO PAUSE^VALM1
End DoDot:1
GOTO DELQ
+7 DO SEL(.IBDA,1)
+8 SET IBDA=$ORDER(IBDA(""))
+9 IF IBDA=""
GOTO DELQ
+10 WRITE !
+11 SET DIR(0)="YA"
SET DIR("A",1)="This action will PERMANENTLY delete a return message from your system"
SET DIR("A",2)="A bulletin will be sent to report the deletion"
SET DIR("A",3)=" "
+12 SET DIR("A")="ARE YOU SURE YOU WANT TO CONTINUE? "
SET DIR("B")="NO"
+13 DO ^DIR
KILL DIR
+14 if Y'=1
GOTO DELQ
+15 SET IBTDA=+IBDA(IBDA)
+16 IF '$$LOCK(IBTDA)
GOTO DELQ
+17 SET IB0=$GET(^IBA(364.2,IBTDA,0))
+18 ;
+19 IF $PIECE(IB0,U,11)
SET IBOK=1
Begin DoDot:1
+20 NEW ZTSK
+21 ;Task not scheduled
SET ZTSK=$PIECE(IB0,U,11)
DO STAT^%ZTLOAD
if ZTSK(0)=0
QUIT
+22 IF "12"[ZTSK(1)
WRITE *7,!,"This message is currently scheduled for update. Task # is: ",$PIECE(IB0,U,11)
SET IBOK=""
DO PAUSE^VALM1
End DoDot:1
if 'IBOK
GOTO DELQ
+23 ;
+24 IF $PIECE(IB0,U,6)=""!("UP"'[$PIECE(IB0,U,6))
Begin DoDot:1
+25 WRITE !,*7,"Message status ("_$$EXPAND^IBTRE(364.2,.06,$PIECE(IB0,U,6))_") is not appropriate for this action"
+26 DO PAUSE^VALM1
End DoDot:1
GOTO DELQ
+27 ;
+28 SET DIR(0)="YA"
SET DIR("A",1)=" "
SET DIR("A",2)=""
SET $PIECE(DIR("A",2),"*",54)=""
SET DIR("A",3)="* This message is about to be PERMANENTLY deleted!! *"
SET DIR("A",4)=DIR("A",2)
SET DIR("A",5)=" "
+29 SET DIR("A")="ARE YOU STILL SURE YOU WANT TO CONTINUE? "
SET DIR("B")="NO"
+30 WRITE !
DO ^DIR
WRITE !
KILL DIR
+31 IF Y'=1
WRITE !!,"Nothing deleted"
DO PAUSE^VALM1
GOTO DELQ
+32 ;
+33 KILL ^TMP("IBMSG",$JOB)
+34 MERGE ^TMP("IBMSG",$JOB)=^IBA(364.2,IBTDA)
+35 DO DELMSG^IBCESRV2(IBTDA)
+36 IF $DATA(^IBA(364.2,IBTDA))
Begin DoDot:1
+37 WRITE !,"Message not deleted - problem with delete"
DO PAUSE^VALM1
End DoDot:1
GOTO DELQ
+38 ;
+39 SET IBT(1)="EDI return message #"_$PIECE(IB0,U)_" has been deleted"
+40 SET IBT(2)=" "
+41 SET IBT(3)="DELETED BY: "_$PIECE($GET(^VA(200,+$GET(DUZ),0)),U)_" "_$$FMTE^XLFDT($$NOW^XLFDT,2)
+42 SET Z=$$EXPAND^IBTRE(364.2,.06,$PIECE(IB0,U,6))
if Z=""
SET Z="??"
+43 SET IBT(4)=" STATUS: "_$EXTRACT(Z_$JUSTIFY("",11),1,11)_" MESSAGE TYPE: "_$PIECE($GET(^IBE(364.3,+$PIECE(IB0,U,2),0)),U,5)
+44 SET IBT(5)=" MESSAGE #: "_$EXTRACT($PIECE(IB0,U)_$JUSTIFY("",11),1,11)_" STATUS DATE: "_$$FMTE^XLFDT($PIECE($GET(^TMP("IBMSG",$JOB,1)),U,3))
+45 SET IBT(6)=" BATCH #: "_$EXTRACT($PIECE($GET(^IBA(364.1,+$PIECE(IB0,U,4),0)),U)_$JUSTIFY("",11),1,11)_" BILL #: "_$$EXPAND^IBTRE(364.2,.05,$PIECE(IB0,U,5))
+46 SET IBT(7)=" "
+47 SET IBT(8)="MESSAGE TEXT:"
SET IBE=8
+48 SET Z=0
FOR
SET Z=$ORDER(^TMP("IBMSG",$JOB,2,Z))
if 'Z
QUIT
SET IBE=IBE+1
SET IBT(IBE)=$GET(^(Z,0))
+49 SET XMSUBJ="EDI MESSAGE DELETED"
SET XMBODY="IBT"
SET XMDUZ=""
SET XMTO("I:G.IB EDI")=""
+50 DO SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
+51 ;
+52 KILL ^TMP("IBMSG",$JOB)
+53 ;
+54 WRITE !,"A bulletin has been sent to report this deletion",!
+55 DO PAUSE^VALM1
+56 ;
+57 DO BLD^IBCEM1
DELQ LOCK -^IBA(364.2,IBTDA,0)
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
TASK(IBRTN,IBBDA,IBTDA,IBTYP) ; Schedule the task to update data base from message
+1 ; IBRTN = routine to task
+2 ; IBBDA = batch # associated with the message (OPTIONAL)
+3 ; IBTDA = internal entry of message
+4 ; IBTYP = the number that is the last digit in the message type
+5 ;
+6 NEW ZTSK,ZTDESC,ZTIO,ZTDTH,ZTSAVE,DA,DR,DIE
+7 SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTDESC="UPDATE DATA BASE FROM EDI RETURN MESSAGE"
SET ZTSAVE("IB*")=""
SET ZTRTN=IBRTN
+8 DO ^%ZTLOAD
+9 IF $GET(ZTSK)
IF $GET(^IBA(364.2,IBTDA,0))
SET DIE="^IBA(364.2,"
SET DR=".11////"_ZTSK_";.06////U"
SET DA=IBTDA
DO ^DIE
+10 QUIT $GET(ZTSK)
+11 ;
LOCK(IBTDA) ; Attempt to lock message file entry IBTDA
+1 ; Return 1 if successful, 0 if not able to lock
+2 ;
+3 NEW OK
+4 SET OK=1
+5 LOCK +^IBA(364.2,IBTDA,0):5
+6 IF '$TEST
Begin DoDot:1
+7 IF '$DATA(DIQUIET)
WRITE !,*7,"Another user is editing this entry ... try again later"
DO PAUSE^VALM1
+8 SET IBDA=""
SET OK=0
End DoDot:1
+9 QUIT OK
+10 ;
