- 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 Feb 18, 2025@23:37:05 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 ;