RCDPAYER ;ALB/PJH - TPJI Utility ;Jun 06, 2014@19:11:19
;;4.5;Accounts Receivable;**269,276,298,326,332**;Mar 20, 1995;Build 40
;Per VA Directive 6402, this routine should not be modified.
;
;Integration Agreement 5549
;
Q
;
EN(IB3611) ;Called from IBJTTC
; IB3611 = ien of EXPLANATION OF BENEFITS file (361.1)
; gathers payer contact data from file 361.1 and 344.4
; returns the data to IBJTTC for display on COMMENT HISTORY screen of TPJI
N AR3444,CONTACTS,ERA3,FOUND,I,IBTEXT,IB25,STR,WEB,NAME
;
S CONTACTS="",STR="",FOUND=0,WEB="",NAME=""
;
;Retrieve contacts from EOB file
S IB25=$P($G(^IBM(361.1,IB3611,25)),U,1,7) ;IA 4051
S:$TR(IB25,U,"")]"" FOUND=1,STR=IB25
;
;Get ERA reference
S AR3444=$O(^RCY(344.4,"ADET",IB3611,""))
;
;If no contact in EOB retrieve contacts from ERA file
I AR3444,'FOUND D
.S ERA3=$P($G(^RCY(344.4,AR3444,3)),U,1,7)
.S:$TR(ERA3,U,"")]"" FOUND=1,STR=ERA3
;
;Retrieve Payer Web Address from ERA file
I AR3444 S WEB=$P($G(^RCY(344.4,AR3444,5)),U) S:WEB]"" FOUND=1
;
;Get Payer Contact Name
S NAME=$P(STR,U) S:NAME]"" FOUND=1
;
;Format contacts
I STR]"" D
.N I,CTYP,CPOS
.F I=2,4,6 D:$P(STR,U,I)]""
..;Validate contact type
..S CTYP=$P(STR,U,I+1)
..S CPOS=$S(CTYP="TE":1,CTYP="FX":2,CTYP="EM":3,CTYP="EX":4,1:0)
..Q:'CPOS
..;Save only first occurance of each type of contact
..S:$P(CONTACTS,U,CPOS)="" $P(CONTACTS,U,CPOS)=$P(STR,U,I)
;
;Allow for misfiled legacy contact data
I FOUND,NAME="",WEB="",CONTACTS="" S FOUND=0
;Return found_web_phone_fax_email
Q FOUND_U_NAME_U_WEB_U_CONTACTS
;
ADD(PRCABN) ;Update AR Transaction file #433 with comment type transaction
;PRCABN = Bill/Claim IEN for file #399.
;called only if 'ERA Contact Information' type comment is not found
;serves as a notice to the user that the contact data came from the 835 ERA. Called from IBJTTC
;
;Note; PJH 8/11/2010 - see ADJUST^RCJIBFN3 (called by ARCA^IBJTA1)
;
N AUTHDT,IBIFN,MRADT,STATUS
S IBIFN=PRCABN
S STATUS=$P($G(^DGCR(399,IBIFN,0)),U,13)
S AUTHDT=$P($G(^DGCR(399,IBIFN,"S")),U,10)
S MRADT=$P($G(^DGCR(399,IBIFN,"S")),U,7)
;
;If claim status is "NOT REVIEWED" or claim status is "CANCELLED"
;with neither MRA request date nor Authorization date present
;comment may not be added
I STATUS=1!(STATUS=7&(MRADT="")&(AUTHDT="")) Q
;
;If claim status is "REQUEST MRA" or claim status is "CANCELLED"
;with MRA request date present, but no Authorization date comment
;cannot be added
I STATUS=2!(STATUS=7&(MRADT'="")&(AUTHDT="")) Q
;
;Ignore bill cancelled in IB
I '$D(^PRCA(430,PRCABN,2,0)) Q
;
;Ignore Archived bill
I $P($G(^PRCA(430,PRCABN,0)),"^",8)=49 Q
;
;Build AR Transaction
;
N PRCAEN,PRCAA1,DR,DIE,DA,D0,PRCAD,RCASK,PRCAA2,PRCA,PRCATY
;
;Create stub record in 433
D SETTR^PRCAUTL,PATTR^PRCAUTL Q:'$D(PRCAEN)
;
S PRCAA1=$S($D(^PRCA(433,PRCAEN,4,0)):+$P(^(0),U,4),1:0)
Q:PRCAA1'>0 S PRCAA2=$P(^(0),U,3)
;
;Direct update of [PRCA COMMENT] edit template fields
;(excluding Date of Contact, Extended Comments and Follow-up Date)
S DIE="^PRCA(433,",DA=PRCAEN
S DR=".03////"_PRCABN ;Bill Number
S DR=DR_";3////0" ;Calm Code Done
S DR=DR_";12////"_$O(^PRCA(430.3,"AC",17,0)) ;Transaction Type
S DR=DR_";15////0" ;Transaction Amount
S DR=DR_";42////.5" ;Processed by POSTMASTER
S DR=DR_";11////"_DT ;Transaction date
S DR=DR_";4////2" ;Transaction status (complete)
S DR=DR_";5.02////ERA Payer Contact Information" D ^DIE
;
;Leave validation checks in place
I $P($G(^PRCA(433,PRCAEN,5)),"^",2)=""!'$P(^PRCA(433,PRCAEN,1),"^") S PRCACOMM="TRANSACTION INCOMPLETE" D DELETE^PRCAWO1 K PRCACOMM Q
;
I '$D(PRCAD("DELETE")) S RCASK=1 D TRANUP^PRCAUTL,UPPRIN^PRCADJ
;
I $P($G(^RCD(340,+$P(^PRCA(430,PRCABN,0),"^",9),0)),"^")[";DPT(" D
.;Ensure comment does not appear on patient statement
.S $P(^PRCA(433,PRCAEN,0),"^",10)=1
Q
;
;Audit Comment from EOB Move/Copy
AUDIT(ORIG,TEXT,MODE) ;
; ORIG = ien of entry in 361.1
; TEXT = move/copy reason
; MODE = is this a move or a copy event
;
;Translate EOB ien to claim number IA 4051
N PRCABN
S PRCABN=$P($G(^IBM(361.1,ORIG,0)),U) Q:'PRCABN
;Build AR Transaction
;
N PRCAEN,PRCAA1,DR,DIE,DA,D0,PRCAD,RCASK,PRCAA2,PRCA,PRCATY
;
;Create stub record in 433
D SETTR^PRCAUTL,PATTR^PRCAUTL Q:'$D(PRCAEN)
;
S PRCAA1=$S($D(^PRCA(433,PRCAEN,4,0)):+$P(^(0),U,4),1:0)
Q:PRCAA1'>0 S PRCAA2=$P(^(0),U,3)
;
N MTEXT,INIT
S INIT=$$GET1^DIQ(200,DUZ,1)
S:INIT="" INIT="USER UNK."
S MTEXT="EEOB MOVED BY "_INIT
I MODE="C" S MTEXT="EEOB COPIED BY "_INIT
I MODE="R" S MTEXT="EEOB REMOVED BY "_INIT
I MODE="W" S MTEXT="EEOB MOVE/COPY IN SPLIT/EDIT"
I MODE="L" S MTEXT="EEOB MOVE/COPY IN LINK PAYMENT"
;Direct update of [PRCA COMMENT] edit template fields
;(excluding Date of Contact, Extended Comments and Follow-up Date)
S DIE="^PRCA(433,",DA=PRCAEN
S DR=".03////"_PRCABN ;Bill Number
S DR=DR_";3////0" ;Calm Code Done
S DR=DR_";12////"_$O(^PRCA(430.3,"AC",17,0)) ;Transaction Type
S DR=DR_";15////0" ;Transaction Amount
S DR=DR_";42////"_$S($G(RCDUZ):RCDUZ,1:DUZ) ;Processed by - PRCA*4.5*326 use RCDUZ if it is set
S DR=DR_";4////2" ;Transaction status (complete)
S DR=DR_";5.02////"_MTEXT ;Brief comment
D ^DIE
;Store justification text in comment field
N DA,DIC,DLAYGO,DR,X
S DA(1)=PRCAEN
S DIC="^PRCA(433,"_DA(1)_",7,",DIC(0)="L",X=$P(TEXT,U)
D FILE^DICN
;Store auto generated text from stand alone option in comment field
I $P(TEXT,U,2)]"" D
.N DA,DIC,DLAYGO,DR,X
.S DA(1)=PRCAEN
.S DIC="^PRCA(433,"_DA(1)_",7,",DIC(0)="L",X="- "_$P(TEXT,U,2)
.D FILE^DICN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPAYER 5707 printed Apr 09, 2024@20:53:27 Page 2
RCDPAYER ;ALB/PJH - TPJI Utility ;Jun 06, 2014@19:11:19
+1 ;;4.5;Accounts Receivable;**269,276,298,326,332**;Mar 20, 1995;Build 40
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;Integration Agreement 5549
+5 ;
+6 QUIT
+7 ;
EN(IB3611) ;Called from IBJTTC
+1 ; IB3611 = ien of EXPLANATION OF BENEFITS file (361.1)
+2 ; gathers payer contact data from file 361.1 and 344.4
+3 ; returns the data to IBJTTC for display on COMMENT HISTORY screen of TPJI
+4 NEW AR3444,CONTACTS,ERA3,FOUND,I,IBTEXT,IB25,STR,WEB,NAME
+5 ;
+6 SET CONTACTS=""
SET STR=""
SET FOUND=0
SET WEB=""
SET NAME=""
+7 ;
+8 ;Retrieve contacts from EOB file
+9 ;IA 4051
SET IB25=$PIECE($GET(^IBM(361.1,IB3611,25)),U,1,7)
+10 if $TRANSLATE(IB25,U,"")]""
SET FOUND=1
SET STR=IB25
+11 ;
+12 ;Get ERA reference
+13 SET AR3444=$ORDER(^RCY(344.4,"ADET",IB3611,""))
+14 ;
+15 ;If no contact in EOB retrieve contacts from ERA file
+16 IF AR3444
IF 'FOUND
Begin DoDot:1
+17 SET ERA3=$PIECE($GET(^RCY(344.4,AR3444,3)),U,1,7)
+18 if $TRANSLATE(ERA3,U,"")]""
SET FOUND=1
SET STR=ERA3
End DoDot:1
+19 ;
+20 ;Retrieve Payer Web Address from ERA file
+21 IF AR3444
SET WEB=$PIECE($GET(^RCY(344.4,AR3444,5)),U)
if WEB]""
SET FOUND=1
+22 ;
+23 ;Get Payer Contact Name
+24 SET NAME=$PIECE(STR,U)
if NAME]""
SET FOUND=1
+25 ;
+26 ;Format contacts
+27 IF STR]""
Begin DoDot:1
+28 NEW I,CTYP,CPOS
+29 FOR I=2,4,6
if $PIECE(STR,U,I)]""
Begin DoDot:2
+30 ;Validate contact type
+31 SET CTYP=$PIECE(STR,U,I+1)
+32 SET CPOS=$SELECT(CTYP="TE":1,CTYP="FX":2,CTYP="EM":3,CTYP="EX":4,1:0)
+33 if 'CPOS
QUIT
+34 ;Save only first occurance of each type of contact
+35 if $PIECE(CONTACTS,U,CPOS)=""
SET $PIECE(CONTACTS,U,CPOS)=$PIECE(STR,U,I)
End DoDot:2
End DoDot:1
+36 ;
+37 ;Allow for misfiled legacy contact data
+38 IF FOUND
IF NAME=""
IF WEB=""
IF CONTACTS=""
SET FOUND=0
+39 ;Return found_web_phone_fax_email
+40 QUIT FOUND_U_NAME_U_WEB_U_CONTACTS
+41 ;
ADD(PRCABN) ;Update AR Transaction file #433 with comment type transaction
+1 ;PRCABN = Bill/Claim IEN for file #399.
+2 ;called only if 'ERA Contact Information' type comment is not found
+3 ;serves as a notice to the user that the contact data came from the 835 ERA. Called from IBJTTC
+4 ;
+5 ;Note; PJH 8/11/2010 - see ADJUST^RCJIBFN3 (called by ARCA^IBJTA1)
+6 ;
+7 NEW AUTHDT,IBIFN,MRADT,STATUS
+8 SET IBIFN=PRCABN
+9 SET STATUS=$PIECE($GET(^DGCR(399,IBIFN,0)),U,13)
+10 SET AUTHDT=$PIECE($GET(^DGCR(399,IBIFN,"S")),U,10)
+11 SET MRADT=$PIECE($GET(^DGCR(399,IBIFN,"S")),U,7)
+12 ;
+13 ;If claim status is "NOT REVIEWED" or claim status is "CANCELLED"
+14 ;with neither MRA request date nor Authorization date present
+15 ;comment may not be added
+16 IF STATUS=1!(STATUS=7&(MRADT="")&(AUTHDT=""))
QUIT
+17 ;
+18 ;If claim status is "REQUEST MRA" or claim status is "CANCELLED"
+19 ;with MRA request date present, but no Authorization date comment
+20 ;cannot be added
+21 IF STATUS=2!(STATUS=7&(MRADT'="")&(AUTHDT=""))
QUIT
+22 ;
+23 ;Ignore bill cancelled in IB
+24 IF '$DATA(^PRCA(430,PRCABN,2,0))
QUIT
+25 ;
+26 ;Ignore Archived bill
+27 IF $PIECE($GET(^PRCA(430,PRCABN,0)),"^",8)=49
QUIT
+28 ;
+29 ;Build AR Transaction
+30 ;
+31 NEW PRCAEN,PRCAA1,DR,DIE,DA,D0,PRCAD,RCASK,PRCAA2,PRCA,PRCATY
+32 ;
+33 ;Create stub record in 433
+34 DO SETTR^PRCAUTL
DO PATTR^PRCAUTL
if '$DATA(PRCAEN)
QUIT
+35 ;
+36 SET PRCAA1=$SELECT($DATA(^PRCA(433,PRCAEN,4,0)):+$PIECE(^(0),U,4),1:0)
+37 if PRCAA1'>0
QUIT
SET PRCAA2=$PIECE(^(0),U,3)
+38 ;
+39 ;Direct update of [PRCA COMMENT] edit template fields
+40 ;(excluding Date of Contact, Extended Comments and Follow-up Date)
+41 SET DIE="^PRCA(433,"
SET DA=PRCAEN
+42 ;Bill Number
SET DR=".03////"_PRCABN
+43 ;Calm Code Done
SET DR=DR_";3////0"
+44 ;Transaction Type
SET DR=DR_";12////"_$ORDER(^PRCA(430.3,"AC",17,0))
+45 ;Transaction Amount
SET DR=DR_";15////0"
+46 ;Processed by POSTMASTER
SET DR=DR_";42////.5"
+47 ;Transaction date
SET DR=DR_";11////"_DT
+48 ;Transaction status (complete)
SET DR=DR_";4////2"
+49 SET DR=DR_";5.02////ERA Payer Contact Information"
DO ^DIE
+50 ;
+51 ;Leave validation checks in place
+52 IF $PIECE($GET(^PRCA(433,PRCAEN,5)),"^",2)=""!'$PIECE(^PRCA(433,PRCAEN,1),"^")
SET PRCACOMM="TRANSACTION INCOMPLETE"
DO DELETE^PRCAWO1
KILL PRCACOMM
QUIT
+53 ;
+54 IF '$DATA(PRCAD("DELETE"))
SET RCASK=1
DO TRANUP^PRCAUTL
DO UPPRIN^PRCADJ
+55 ;
+56 IF $PIECE($GET(^RCD(340,+$PIECE(^PRCA(430,PRCABN,0),"^",9),0)),"^")[";DPT("
Begin DoDot:1
+57 ;Ensure comment does not appear on patient statement
+58 SET $PIECE(^PRCA(433,PRCAEN,0),"^",10)=1
End DoDot:1
+59 QUIT
+60 ;
+61 ;Audit Comment from EOB Move/Copy
AUDIT(ORIG,TEXT,MODE) ;
+1 ; ORIG = ien of entry in 361.1
+2 ; TEXT = move/copy reason
+3 ; MODE = is this a move or a copy event
+4 ;
+5 ;Translate EOB ien to claim number IA 4051
+6 NEW PRCABN
+7 SET PRCABN=$PIECE($GET(^IBM(361.1,ORIG,0)),U)
if 'PRCABN
QUIT
+8 ;Build AR Transaction
+9 ;
+10 NEW PRCAEN,PRCAA1,DR,DIE,DA,D0,PRCAD,RCASK,PRCAA2,PRCA,PRCATY
+11 ;
+12 ;Create stub record in 433
+13 DO SETTR^PRCAUTL
DO PATTR^PRCAUTL
if '$DATA(PRCAEN)
QUIT
+14 ;
+15 SET PRCAA1=$SELECT($DATA(^PRCA(433,PRCAEN,4,0)):+$PIECE(^(0),U,4),1:0)
+16 if PRCAA1'>0
QUIT
SET PRCAA2=$PIECE(^(0),U,3)
+17 ;
+18 NEW MTEXT,INIT
+19 SET INIT=$$GET1^DIQ(200,DUZ,1)
+20 if INIT=""
SET INIT="USER UNK."
+21 SET MTEXT="EEOB MOVED BY "_INIT
+22 IF MODE="C"
SET MTEXT="EEOB COPIED BY "_INIT
+23 IF MODE="R"
SET MTEXT="EEOB REMOVED BY "_INIT
+24 IF MODE="W"
SET MTEXT="EEOB MOVE/COPY IN SPLIT/EDIT"
+25 IF MODE="L"
SET MTEXT="EEOB MOVE/COPY IN LINK PAYMENT"
+26 ;Direct update of [PRCA COMMENT] edit template fields
+27 ;(excluding Date of Contact, Extended Comments and Follow-up Date)
+28 SET DIE="^PRCA(433,"
SET DA=PRCAEN
+29 ;Bill Number
SET DR=".03////"_PRCABN
+30 ;Calm Code Done
SET DR=DR_";3////0"
+31 ;Transaction Type
SET DR=DR_";12////"_$ORDER(^PRCA(430.3,"AC",17,0))
+32 ;Transaction Amount
SET DR=DR_";15////0"
+33 ;Processed by - PRCA*4.5*326 use RCDUZ if it is set
SET DR=DR_";42////"_$SELECT($GET(RCDUZ):RCDUZ,1:DUZ)
+34 ;Transaction status (complete)
SET DR=DR_";4////2"
+35 ;Brief comment
SET DR=DR_";5.02////"_MTEXT
+36 DO ^DIE
+37 ;Store justification text in comment field
+38 NEW DA,DIC,DLAYGO,DR,X
+39 SET DA(1)=PRCAEN
+40 SET DIC="^PRCA(433,"_DA(1)_",7,"
SET DIC(0)="L"
SET X=$PIECE(TEXT,U)
+41 DO FILE^DICN
+42 ;Store auto generated text from stand alone option in comment field
+43 IF $PIECE(TEXT,U,2)]""
Begin DoDot:1
+44 NEW DA,DIC,DLAYGO,DR,X
+45 SET DA(1)=PRCAEN
+46 SET DIC="^PRCA(433,"_DA(1)_",7,"
SET DIC(0)="L"
SET X="- "_$PIECE(TEXT,U,2)
+47 DO FILE^DICN
End DoDot:1
+48 QUIT
