Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RCDPEM5

RCDPEM5.m

Go to the documentation of this file. 
  1. RCDPEM5 ;ALB/PJH - EPAYMENTS MOVE EEOB TO NEW CLAIM ;Oct 29, 2014@16:43:51
  1.  ;;4.5;Accounts Receivable;**173,208,276,298,321,332**;Mar 20, 1995;Build 40
  1.  ;Per VA Directive 6402, this routine should not be modified.
  1.  Q
  1.  ;
  1. EN ;Entry point for EEOB Move/Copy/Remove [RCDPE EEOB MOVE/COPY/REMOVE] option
  1.  ;
  1.  N DIR,X,Y,DIROUT,DUOUT,MODE
  1.  S DIR("A")="Select action"
  1.  S DIR("B")="M"
  1.  S DIR(0)="S^M:Move EEOB to different claim;"
  1.  S DIR(0)=DIR(0)_"C:Copy EEOB to multiple claims;"
  1.  S DIR(0)=DIR(0)_"R:Remove EEOB from claim"
  1.  D ^DIR Q:$G(DIROUT)!$G(DUOUT)
  1.  S MODE=Y
  1.  ;
  1.  ; - PRCA*4.5*298 - OWNSKEY^XUSRB - Supported IA 3277  
  1.  I MODE="R" N MSG D OWNSKEY^XUSRB(.MSG,"RCDPE REMOVE EEOB",DUZ) I 'MSG(0) D  Q
  1.  .W !!,"SORRY, YOU ARE NOT AUTHORIZED TO USE THIS ACTION"
  1.  .W !,"This action is locked with RCDPE REMOVE EEOB key.",!
  1.  .N DIR S DIR(0)="E" D ^DIR
  1.  ;
  1.  ;Read access to file #361.1 under IA 4051
  1.  ;
  1.  N DA,DIC,DIE,DIR,DR,NCLAIM,ORIG,ORIGNAM,X,Y
  1.  ;
  1.  ;Allow selection of a original third party EOB
  1.  S DIC("A")="Select EXPLANATION OF BENEFIT (EEOB) to "_$S(MODE="M":"MOVE",MODE="R":"REMOVE",1:"COPY")_": "
  1.  ; screen to only allow selection of an active EEOB (not marked as deleted) and non-MRA type EOB
  1.  S DIC("S")="I ($P(^(0),U,4)=0)&('$P($G(^(102)),U))",DIC="^IBM(361.1,",DIC(0)="AEMQ"
  1.  W ! D ^DIC K DIC
  1.  ;
  1.  I Y'>0 Q
  1.  ; controlled subscription IA 1992
  1.  S ORIG=+Y,ORIGNAM=$$GET1^DIQ(399,$P(Y,U,2),.01)
  1.  ;
  1.  ;Get current bill payer sequence from claim - IA 3820
  1.  D
  1.  .N CURR,IEN399
  1.  .S IEN399=$P($G(^IBM(361.1,ORIG,0)),U) Q:'IEN399
  1.  .S CURR=$P($G(^DGCR(399,IEN399,0)),U,21) I (CURR'="T")&(CURR'="S") Q
  1.  .W !!,"Warning - selected EEOB has secondary claims and may have tertiary claims"
  1.  ;
  1.  ;Lock Original EOB
  1.  Q:'$$LOCK^IBCEOB4(ORIG)
  1.  ;
  1.  ;Remove Option
  1.  I MODE="R" D REMOVE(ORIG,MODE),EXIT Q
  1.  ;
  1.  ;Select Claim(s) to Move/Copy to
  1.  N RCBILL,RCBILLNM,NCLAIM,NCLAIMX,QUIT,SUB,LIT
  1.  S SUB=0,QUIT=0,LIT=""
  1.  W !
  1.  F  D  Q:QUIT  Q:SUB&(MODE="M")
  1.  .;Allow selection of a third party claim
  1.  .I MODE="M" S DIC("A")="Select A/R Bill to MOVE to: "
  1.  .I MODE="C" S DIC("A")="Select "_LIT_"A/R Bill to COPY to: "
  1.  .S DIC="^PRCA(430,",DIC(0)="AEMQ",DIC("S")="I $D(^DGCR(399,+Y,0))&($$VALSTAT^RCDPEM5(+Y))"
  1.  .D ^DIC K DIC
  1.  .I Y'>0 S QUIT=1 Q
  1.  .S RCBILL=+Y,RCBILLNM=$P($P(Y,U,2),"-",2)
  1.  .I ORIGNAM=RCBILLNM,MODE="M" W !,"Cannot move EEOB to same claim" Q
  1.  .I $D(NCLAIMX(RCBILL)) W !,"Claim already entered" Q
  1.  .S SUB=SUB+1,NCLAIM(SUB)=RCBILL,NCLAIMX(RCBILL)=""
  1.  .S:MODE="C" LIT="another "
  1.  ;
  1.  I $G(DUOUT)!$G(DIROUT) D EXIT Q
  1.  ;
  1.  ;User Exit or no claims selected
  1.  I '$O(NCLAIM("")) D EXIT Q
  1.  ;
  1.  ;Prompt user to continue
  1.  N DIR,X,Y,DIROUT
  1.  S DIR(0)="Y",DIR("B")="YES"
  1.  S DIR("A")=$$PROMPT(ORIG,.NCLAIM,MODE)
  1.  W ! D ^DIR
  1.  ;
  1.  I $G(DIROUT)!$G(DUOUT)!(Y=0) D EXIT Q
  1.  ;
  1.  ;Enter Justification Comment
  1.  N DIR,DIROUT,DUOUT,JCOM,X,Y
  1.  S DIR(0)="FA^1:100^K:$TR(X,"" "","""")="""" X",DIR("A")="Enter JUSTIFICATION COMMENT: "
  1.  W ! D ^DIR I $G(DIROUT)!$G(DUOUT) W !!,"Update not performed" D EXIT Q
  1.  S JCOM=Y
  1.  ;
  1.  ;Update EOB
  1.  D UPDATE(ORIG,.NCLAIM,MODE,JCOM),EXIT
  1.  ;
  1.  Q
  1.  ;
  1.  ;Unlock original EOB
  1. EXIT D UNLOCK^IBCEOB4(ORIG)
  1.  Q
  1.  ;
  1.  ;File EOB #361.1 changes - Integration Agreement 5671 for IBCEOB4
  1. UPDATE(ORIG,NCLAIM,MODE,JUST) ;
  1.  ; Input - ORIG - Original EOB
  1.  ;       - NCLAIM - New claim (s)
  1.  ;       - MODE M=Move C=Copy
  1.  ;       - JUST = User input justification text
  1.  ; Output -  Updates EOB and Audit log
  1.  N JUST1
  1.  ;Move EOB
  1.  I MODE="M" D
  1.  .;Auto generate text for AR comments on original claim
  1.  .S JUST1=$$JUST1(ORIG,.NCLAIM,"M",0)
  1.  .;Update AR Comments on the 'from bill'
  1.  .D AUDIT^RCDPAYER(ORIG,JUST_"^"_JUST1,MODE)
  1.  .;Change claim number on EEOB
  1.  .D MOVE^IBCEOB4(ORIG,NCLAIM(1),DUZ,$$NOW^XLFDT,JUST,MODE)
  1.  .;Update AR Comments on 'to bill'
  1.  .D AUDIT^RCDPAYER(ORIG,JUST_"^"_JUST1,MODE)
  1.  ;Copy EOB
  1.  I MODE="C" D
  1.  .D COPY^IBCEOB4(ORIG,.NCLAIM,DUZ,$$NOW^XLFDT,JUST,MODE)
  1.  .;Auto generate text for AR comments on original claim
  1.  .S JUST1=$$JUST1(ORIG,.NCLAIM,"C",0)
  1.  .;Update AR Comments on original claim
  1.  .D AUDIT^RCDPAYER(ORIG,JUST_"^"_JUST1,MODE)
  1.  .;Auto generate text for AR comments on new claim
  1.  .S JUST1=$$JUST1(ORIG,.NCLAIM,"C",1)
  1.  .;Update AR Comments on new claims
  1.  .N SUB,NEWEOB
  1.  .S SUB=0
  1.  .F  S SUB=$O(NCLAIM(SUB)) Q:'SUB  D
  1.  ..;Convert Claim pointer to EOB pointer
  1.  ..S NEWEOB=$O(^IBM(361.1,"B",NCLAIM(SUB),0)) Q:'NEWEOB
  1.  ..D AUDIT^RCDPAYER(NEWEOB,JUST_"^"_JUST1,MODE)
  1.  W !!,"EEOB Update Complete" H 1
  1.  Q
  1.  ;
  1. PROMPT(ORIG,NCLAIM,MODE) ;Construct prompt text
  1.  ; Input - ORIG - Original EOB
  1.  ;       - NCLAIM - New claim (s)
  1.  ;       - MODE M=Move C=Copy 
  1.  ; Output - Justification text
  1.  ;
  1.  N FIRST,STR,STR1,SUB,TEXT
  1.  ;Move or copy text
  1.  S TEXT=$$EXTERNAL^DILFD(361.1,.01,,$P($G(^IBM(361.1,ORIG,0)),U))
  1.  I MODE="M" S STR="Move EEOB from claim "_TEXT_" to claim "
  1.  E  S STR="Copy EEOB from claim "_TEXT_" to claim(s) "
  1.  ;Build list of claims
  1.  S STR1="",SUB="",FIRST=1
  1.  F  S SUB=$O(NCLAIM(SUB)) Q:'SUB  D
  1.  .S TEXT=$P($G(^PRCA(430,NCLAIM(SUB),0)),U)
  1.  .I FIRST S STR1=STR1_$P(TEXT,"-",2),FIRST=0 Q
  1.  .S STR1=STR1_", "_$P(TEXT,"-",2)
  1.  ;Return full prompt text
  1.  Q STR_STR1_" "
  1.  ;
  1. JUST(ORIG,NCLAIM,MODE,TYPE,SRC) ;Construct justification text for automatic updates
  1.  ; Input - ORIG - Original EOB
  1.  ;       - NCLAIM - New claim (s)
  1.  ;       - MODE - "M" = Move "C" =Copy "R" = Remove
  1.  ;       - TYPE - 0 = old EOB 1 = new EOB
  1.  ;       - SRC - "W" = Worklist "A" = Auto-post, "L" = Link Payment  
  1.  ; Output - Justification text
  1.  N FIRST,STR,STR1,SUB,TEXT
  1.  ;Original bill number
  1.  S TEXT=$$EXTERNAL^DILFD(361.1,.01,,$P($G(^IBM(361.1,ORIG,0)),U))
  1.  ;Justification comment for original EOB
  1.  I TYPE=0 D
  1.  .I MODE="R" S STR="EEOB removed from claim "_TEXT,STR1="" Q  ;PRCA*4.5*321
  1.  .I MODE="M" S STR="EEOB from claim "_TEXT_" moved to claim "
  1.  .I MODE="C" S STR="EEOB from claim "_TEXT_" copied to claim(s) "
  1.  .;Build list of claims
  1.  .S STR1="",SUB="",FIRST=1
  1.  .F  S SUB=$O(NCLAIM(SUB)) Q:'SUB  D
  1.  ..S TEXT=$P($G(^PRCA(430,NCLAIM(SUB),0)),U)
  1.  ..I FIRST S STR1=STR1_$P(TEXT,"-",2),FIRST=0 Q
  1.  ..S STR1=STR1_", "_$P(TEXT,"-",2)
  1.  ;Justification comment for new EOB's
  1.  I TYPE=1 D
  1.  .I MODE="M" S STR="EEOB moved from EEOB for claim "_TEXT,STR1=""
  1.  .I MODE="C" S STR="EEOB copied from EEOB for claim "_TEXT,STR1=""
  1.  ;Return full justification text
  1.  Q STR_STR1_" automatically by "_$S(SRC="A":"Auto-post",SRC="L":"Link Payment",1:"Worklist")
  1.  ;
  1. JUST1(ORIG,NCLAIM,MODE,TYPE) ;Construct AR comment for stand-alone MCR option
  1.  ; Input - ORIG - Original EOB
  1.  ;       - NCLAIM - New claim (s)
  1.  ;       - MODE M=Move C=Copy
  1.  ;       - TYPE = 0 - original EOB 1 - new EOB(s) 
  1.  ; Output - Justification text
  1.  N FIRST,STR,STR1,SUB,TEXT
  1.  ;Original bill number
  1.  S TEXT=$$EXTERNAL^DILFD(361.1,.01,,$P($G(^IBM(361.1,ORIG,0)),U))
  1.  ;Justification comment for original EOB
  1.  I TYPE=0 D
  1.  .I MODE="M" S STR="EEOB from claim "_TEXT_" moved to claim "
  1.  .I MODE="C" S STR="EEOB from claim "_TEXT_" copied to claim(s) "
  1.  .;Build list of claims
  1.  .S STR1="",SUB="",FIRST=1
  1.  .F  S SUB=$O(NCLAIM(SUB)) Q:'SUB  D
  1.  ..S TEXT=$P($G(^PRCA(430,NCLAIM(SUB),0)),U)
  1.  ..I FIRST S STR1=STR1_$P(TEXT,"-",2),FIRST=0 Q
  1.  ..S STR1=STR1_", "_$P(TEXT,"-",2)
  1.  ;Justification comment for new EOB's
  1.  I TYPE=1 D
  1.  .I MODE="M" S STR="EEOB moved from EEOB for claim "_TEXT,STR1=""
  1.  .I MODE="C" S STR="EEOB copied from EEOB for claim "_TEXT,STR1=""
  1.  ;Return comment text
  1.  Q STR_STR1
  1.  ;
  1. FINDEOB(IEN3444,BILL) ;Find EOB for a claim within an ERA
  1.  ; Input - IEN3444 = ERA ien
  1.  ;         BILL = Bill number
  1.  ; Output - IEN of EOB in #361.1
  1.  N IEN3611,SUB
  1.  S (SUB,IEN3611)=0
  1.  F  S SUB=$O(^RCY(344.4,IEN3444,1,"AC",SUB)) Q:'SUB  D  Q:IEN3611
  1.  .I $$EXTERNAL^DILFD(344.41,.02,,SUB)=BILL S IEN3611=SUB
  1.  Q IEN3611
  1.  ;
  1. REMOVE(ORIG,MODE) ; Interactive option to Remove EEOB - PRCA*4.5*298
  1.  ; Input - ORIG = original EOB in #361.1
  1.  ; Output - mode = "R"
  1.  ;
  1.  ;Prompt user to continue
  1.  N DIR,X,Y,DIROUT
  1.  S DIR(0)="Y",DIR("B")="YES"
  1.  S DIR("A")="Are you sure you want to remove EEOB from claim "_ORIGNAM_" (Y/N)?"
  1.  W ! D ^DIR
  1.  ;
  1.  I $G(DIROUT)!$G(DUOUT)!(Y=0) Q
  1.  ;
  1.  ;Enter Justification Comment
  1.  N DIR,DIROUT,DUOUT,JUST,X,Y
  1.  S DIR(0)="FA^1:100^K:$TR(X,"" "","""")="""" X",DIR("A")="Enter JUSTIFICATION COMMENT: "
  1.  W ! D ^DIR I $G(DIROUT)!$G(DUOUT) W !!,"Update not performed" D EXIT Q
  1.  S JUST=Y
  1.  ;
  1.  ;Update EEOB
  1.  D REMOVE^IBCEOB4(ORIG,DUZ,JUST)
  1.  ;Update AR Comments for removed claim
  1.  D AUDIT^RCDPAYER(ORIG,JUST,MODE)
  1.  ;
  1.  W !!,"EEOB Update Complete" H 1
  1.  Q
  1.  ; 
  1. VALSTAT(CLIEN) ; validation on current status of the AR claim selected for the move/copy event  
  1.  ; Claims that are in a incomplete state cannot be selected
  1.  ; incomplete states are determined at CURRENT STATUS (8,430) of the AR claim
  1.  ; AR claims with 'BILL INCOMPLETE', 'INCOMPLETE', 'NEW BILL' statuses cannot be selected 
  1.  ; CLIEN=430 ien
  1.  ; returns 0 or 1
  1.  N CSTAT,FLAG
  1.  S CSTAT=$$GET1^DIQ(430,CLIEN,8)
  1.  S FLAG=$S(CSTAT="BILL INCOMPLETE":0,CSTAT="INCOMPLETE":0,CSTAT="NEW BILL":0,1:1)
  1.  Q FLAG
  1.  ;
  1.  ; BEGIN - PRCA*4.5*321
  1. AUTO(OBILL,RCSPLIT,RCERA,SRC,ORIG) ;EP from RCDPEM and RCDPEMA
  1.  ; Automatic move copy of EOB
  1.  ; Input:   OBILL       - Original Bill number in #399 
  1.  ;          RCSPLIT     - Array of split lines
  1.  ;          RCERA       - ERA ien #344.4
  1.  ;          SRC         - "W" = Worklist "A" = APAR/Autopost
  1.  ;          ORIG        - IEN of EOB in file #361.1
  1.  ; Output - Update EOBs and audit trail
  1.  N CCLAIM,FLAG,IFN,J,NCLAIM,NBILL,JUST,JUST1,SUB,SUB1,VALID ; PRCA*4.5*332
  1.  ; EOB for the original claim must be present
  1.  I 'ORIG Q 1
  1.  S (SUB,SUB1)=0,VALID=1 ; ; PRCA*4.5*332
  1.  F J="O","N","S" S FLAG(J)=0 ; PRCA*4.5*332 Initialize flags for original, new and suspense EEOBs
  1.  ; Loop through split lines 
  1.  F  S SUB=$O(RCSPLIT(SUB)) Q:'SUB  D
  1.  . ; Bill Number on split line
  1.  . S NBILL=$P(RCSPLIT(SUB),U,2)
  1.  . S IFN=$P(RCSPLIT(SUB),U,7)   ; PRCA*4.5*332
  1.  . ; Ignore split lines with zero value
  1.  . Q:+$P(RCSPLIT(SUB),U,3)=0
  1.  . ; Suspense claims, piece 7 is pointer to AR claim file 430
  1.  . I 'IFN S FLAG("S")=1 Q      ; PRCA*4.5*332
  1.  . ; Is original bill is in the array?
  1.  . I OBILL=NBILL S FLAG("O")=1 ; PRCA*4.5*332
  1.  . ; Save POINTER to AR Claim file 430 (DINUM to 399)
  1.  . S SUB1=SUB1+1,NCLAIM(SUB1)=IFN
  1.  . ; Build list of new claims to copy
  1.  . I OBILL'=NBILL D    ; PRCA*4.5*332
  1.  . . S CCLAIM(IFN)=IFN ; PRCA*4.5*332
  1.  . . S FLAG("N")=1     ; PRCA*4.5*332
  1.  ;
  1.  ; No new claims. Payment must have been split to suspense, or suspense and original payment - no action
  1.  I 'FLAG("N") Q 1 ; PRCA*4.5*332
  1.  ;
  1.  ; Lock Original EOB
  1.  I '$$LOCK(ORIG) Q 0
  1.  ;
  1.  ; PRCA*4.5*332 - Start modified code block
  1.  ; If split to single new claim move EOB - i.e. change claim number on EOB
  1.  I SUB1=1,'FLAG("S") D  ;
  1.  . ; Change claim number on original EOB attached to ERA
  1.  . D AUTOMOVE(ORIG,.NCLAIM,SRC) ; PRCA*4.5*332
  1.  ;
  1.  ; Split was to multiple new claims or new claim(s) and suspense - copy original EOB to new claim(s)
  1.  E  D  ;
  1.  . ; Copy EOB to new EOBs for "to" claims
  1.  . D AUTOCOPY(ORIG,.CCLAIM,SRC) ; PRCA*4.5*332
  1.  . ; If no money went to suspense or the original EOB
  1.  . ; mark original EOB removed but with text of 'copied to claims....'
  1.  . I 'FLAG("O"),'FLAG("S") D   ;
  1.  . . S JUST=$$JUST(ORIG,.CCLAIM,"C",0,SRC)_" then removed"
  1.  . . D AUTOREM(ORIG,JUST)
  1.  ; PRCA*4.5*332 - End modified code block
  1.  ;
  1.  D UNLOCK(ORIG)
  1.  Q 1
  1.  ;
  1. AUTOREM(ORIG,JUST) ;Silent remove of EEOB where entire payment is suspensed or moved to other claims
  1.  ; Input - ORIG = EOB in #361.1
  1.  ;         JUST = Justification text
  1.  ; Output - Update EOB in #361.1 and audit trail
  1.  ;
  1.  ;Lock Original EOB
  1.  I '$$LOCK(ORIG) Q
  1.  ;Update EEOB
  1.  D REMOVE^IBCEOB4(ORIG,DUZ,JUST)
  1.  ;Update AR Comments for removed claim
  1.  D AUDIT^RCDPAYER(ORIG,JUST,"R")
  1.  ;Unlock original EOB
  1.  D UNLOCK(ORIG)
  1.  ;
  1.  Q
  1.  ;
  1. AUTOCOPY(ORIG,CCLAIM,SRC) ; EP from RCDPEU2 - Copy EOBs and upate AR TRANSACTION file - PRCA*4.5*332
  1.  ; Input: ORIG  - IEN for file 361.1 of original EOB
  1.  ;        CCLAIM - Array of claims to copy to
  1.  ;        SRC   - "W" = Worklist "A" = APAR/Autopost "L" = Link Payments
  1.  N JUST,JUST1,MODE,SUB,NEWEOB
  1.  S MODE=$S(SRC="L":"L",1:"W")
  1.  S JUST=$$JUST(ORIG,.CCLAIM,"C",0,SRC) ; Text for original EEOB (copied to claims x,y,z - then removed)
  1.  S JUST1=$$JUST(ORIG,.CCLAIM,"C",1,SRC) ; Text for copied to EEOB (copied from claim w)
  1.  ; Copy EOB to new EOBs for "to" claims
  1.  D COPY^IBCEOB4(ORIG,.CCLAIM,DUZ,$$NOW^XLFDT,JUST1,"C")
  1.  ;
  1.  ; Auto generate text for AR comments on original claim
  1.  D AUDIT^RCDPAYER(ORIG,JUST,MODE)
  1.  ; Auto generate text for AR comments on new claim
  1.  S SUB=0
  1.  F  S SUB=$O(CCLAIM(SUB)) Q:'SUB  D
  1.  . ; Convert Claim pointer to EOB pointer
  1.  . S NEWEOB=$O(^IBM(361.1,"B",CCLAIM(SUB),""),-1) Q:'NEWEOB
  1.  . D AUDIT^RCDPAYER(NEWEOB,JUST1,MODE)
  1.  Q
  1.  ;
  1. AUTOMOVE(ORIG,NCLAIM,SRC) ; EP from RCDPEU2 - Move EOB from one claim to another PRCA*4.5*332
  1.  ; Input: ORIG  - IEN for file 361.1 of original EOB
  1.  ;        NCLAIM - Array of new claims
  1.  ;        SRC   - "W" = Worklist "A" = APAR/Autopost "L" = Link Payments
  1.  N JUST,JUST1,MODE,SUB
  1.  S MODE=$S(SRC="L":"L",1:"W")
  1.  S JUST=$$JUST(ORIG,.NCLAIM,"M",0,SRC) ;Just. Text for original claim
  1.  S JUST1=$$JUST(ORIG,.NCLAIM,"M",1,SRC) ;Just. Text for new claim
  1.  ; Update AR Transaction for original claim
  1.  D AUDIT^RCDPAYER(ORIG,JUST,MODE)
  1.  ; Change claim number on original EOB attached to ERA
  1.  D MOVE^IBCEOB4(ORIG,NCLAIM(1),DUZ,$$NOW^XLFDT,JUST,"M")
  1.  ; Update AR Transaction for new claim
  1.  D AUDIT^RCDPAYER(ORIG,JUST1,MODE)
  1.  Q
  1.  ;
  1.  ;Read access to file #361.1 under IA 4051
  1. LOCK(EOBIEN) ;Lock Original EOB
  1.  L +^IBM(361.1,EOBIEN):5 I  Q 1
  1.  Q 0
  1.  ;
  1. UNLOCK(EOBIEN) ;Release EOB
  1.  L -^IBM(361.1,EOBIEN)
  1.  Q
  1.  ; END PRCA*4.5*321
  1.  ;
  1.  ;US1394 ADDITIONS - EP RCDPRPL1 and RCDPLPL3
  1. EEOB(RCRCPT,RCTRANDA) ; Option to restore associated suspended/removed EEOB
  1.  ;
  1.  ; INPUT  - RCRCPT - Receipt ien #344
  1.  ;        - RCTRANDA - Receipt line #344.01
  1.  ;
  1.  ; OUTPUT - RCEEOB - selected EEOB ien #361.1 
  1.  ; or 0 if no EEOB
  1.  ; or -1 if ^ abort 
  1.  ;
  1.  N CLAIM,DIROUT,DTOUT,DUOUT,RCEEOB,RCEEOBH,RCERA,RCLINE
  1.  ; Get new claim IEN from receipt line
  1.  S CLAIM=$$GET1^DIQ(344.01,RCTRANDA_","_RCRCPT_",",.09,"I")
  1.  ; Quit if this is not a third party claim payment
  1.  Q:CLAIM'["PRCA" 0
  1.  ; Check if ERA has a suspended EEOB for this line
  1.  S RCEEOB=$$SUSP(RCRCPT,RCTRANDA,.RCERA,.RCLINE)
  1.  ; If no suspended EEOB skip prompt
  1.  Q:'RCEEOB 0
  1.  ;
  1.  ; Get last move/copy history record - Read access to file #361.1 under IA 4051
  1.  S RCEEOBH=$O(^IBM(361.1,RCEEOB,101,"A"),-1)
  1.  ; Quit if EEOB if no history found - should not occur since EEOB is suspended
  1.  Q:'RCEEOBH 0
  1.  ; Display EOB detail
  1.  W !!,"This claim has an associated EEOB on ERA "_RCERA
  1.  W !!,"Claim Number     : ",$$GET1^DIQ(344.41,RCLINE_","_RCERA,.02,"E")
  1.  W !,"Trace Number     : ",$$GET1^DIQ(344.4,RCERA,.02,"E")
  1.  W !,"Total Amount Paid: ",$$GET1^DIQ(361.1,RCEEOB,1.01,"E")
  1.  W !,"Date/Time Removed: ",$$GET1^DIQ(361.1101,RCEEOBH_","_RCEEOB,.01,"E")
  1.  W !,"Removed by       : ",$$GET1^DIQ(361.1101,RCEEOBH_","_RCEEOB,.02,"E")
  1.  W !,"Justification    : ",$$GET1^DIQ(361.1101,RCEEOBH_","_RCEEOB,.03,"E"),!
  1.  ;
  1.  ; Confirm that this is the correct EEOB
  1.  K DIR
  1.  S DIR(0)="YO",DIR("B")="NO"
  1.  S DIR("A")="Is this the correct EEOB to associate with this claim"
  1.  D ^DIR
  1.  I $G(DTOUT)!($G(DUOUT)) Q -1
  1.  Q:Y'=1 0
  1.  ;
  1.  ;Return selected EEOB
  1.  Q RCEEOB
  1.  ;
  1. SUSP(RCRCPT,RCTRANDA,RCERA,RCLINE) ; Identify suspended EEOB
  1.  ;
  1.  ; INPUT - RCRCPT - Receipt ien #344
  1.  ;       - RCTRANDA - Receipt line #344.01
  1.  ;
  1.  ; OUTPUT - RCEEOB - selected EEOB ien #361.1 
  1.  ;        - RCERA - ERA ien #344.4
  1.  ;        - RCLINE - ERA line #344.41;
  1.  ;
  1.  N RCEEOB,RCORIG,RCRCZ,RCSPLIT
  1.  ; Get ERA from receipt
  1.  S RCERA=$$GET1^DIQ(344,RCRCPT_",",.18,"I")
  1.  ; Quit if no ERA
  1.  Q:'RCERA 0
  1.  ; Get ERA Scratchpad line
  1.  S RCRCZ=$$GET1^DIQ(344.01,RCTRANDA_","_RCRCPT_",",.27,"I")
  1.  ; Quit if ERA scratchpad line missing
  1.  Q:'RCRCZ 0
  1.  ; Get the original line sequence number from before the split was performed
  1.  S RCSPLIT=$$GET1^DIQ(344.491,RCRCZ_","_RCERA_",",.01),RCORIG=RCSPLIT\1
  1.  ; Convert sequence number into original line IEN
  1.  S RCORIG=$O(^RCY(344.49,RCERA,1,"ASEQ",RCORIG,""))
  1.  ; Quit if original scratchpad line not found
  1.  Q:'RCORIG 0
  1.  ; Get ERA line from original scratchpad line
  1.  S RCLINE=$$GET1^DIQ(344.491,RCORIG_","_RCERA_",",.09,"I")
  1.  ; Quit if ERA line not found
  1.  Q:'RCLINE 0
  1.  ; Get EEOB from ERA line
  1.  S RCEEOB=$$GET1^DIQ(344.41,RCLINE_","_RCERA_",",.02,"I")
  1.  ; Quit if ERA line pointer to EEOB is missing
  1.  Q:'RCEEOB 0
  1.  ; Ignore EEOB if status is not removed - read access to file #361.1 under IA 4051
  1.  Q:$$GET1^DIQ(361.1,RCEEOB_",",102,"I")'=1 0
  1.  ; Return suspended EEOB IEN
  1.  Q RCEEOB
  1.  ;
  1.  ; EP RCDPRPL1 and RCDPLPL3
  1. RESTORE(RCPTDA,RCTRANDA,ORIG,SRC) ; Change bill number on EOB and clear 'removed' status
  1.  ;
  1.  ; INPUT - RCPTDA   - Receipt ien #344
  1.  ;       - RCTRANDA - Receipt line #344.01
  1.  ;       - ORIG     - EOB ien #361.1
  1.  ;       - SRC      - 'L' - Link Payments 'R' - Receipt Porcessing
  1.  ;
  1.  Q:'$$LOCK^IBCEOB4(ORIG)
  1.  ;
  1.  W !,"Updating EEOB...."
  1.  ;
  1.  N NCLAIM,JUST
  1.  ; Get new claim IEN from receipt line
  1.  S NCLAIM=$P($$GET1^DIQ(344.01,RCTRANDA_","_RCPTDA_",",.09,"I"),";")
  1.  ; Set up justification text
  1.  S JUST="EEOB restored from suspense in "_$S(SRC="L":"Link Payments",SRC="R":"Edit Payments",1:"Other")
  1.  ; Update AR comments on 'from claim'
  1.  D AUDIT^RCDPAYER(ORIG,JUST,"W")
  1.  ; Change claim number on EOB
  1.  D MOVE^IBCEOB4(ORIG,NCLAIM,DUZ,$$NOW^XLFDT,JUST,"M")
  1.  ; Reset EEOB REMOVED status
  1.  D RESTORE^IBCEOB4(ORIG)
  1.  ;Unlock EOB
  1.  D UNLOCK^IBCEOB4(ORIG)
  1.  ;
  1.  H 1 W "done"
  1.  Q