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

RCDPAYER.m

Go to the documentation of this file. 
  1. 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
  1.  ;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ;Integration Agreement 5549
  1.  ;
  1.  Q
  1.  ;
  1. EN(IB3611) ;Called from IBJTTC
  1.  ; IB3611 = ien of EXPLANATION OF BENEFITS file (361.1)
  1.  ; gathers payer contact data from file 361.1 and 344.4
  1.  ; returns the data to IBJTTC for display on COMMENT HISTORY screen of TPJI
  1.  N AR3444,CONTACTS,ERA3,FOUND,I,IBTEXT,IB25,STR,WEB,NAME
  1.  ;
  1.  S CONTACTS="",STR="",FOUND=0,WEB="",NAME=""
  1.  ;
  1.  ;Retrieve contacts from EOB file
  1.  S IB25=$P($G(^IBM(361.1,IB3611,25)),U,1,7) ;IA 4051
  1.  S:$TR(IB25,U,"")]"" FOUND=1,STR=IB25
  1.  ;
  1.  ;Get ERA reference
  1.  S AR3444=$O(^RCY(344.4,"ADET",IB3611,""))
  1.  ;
  1.  ;If no contact in EOB retrieve contacts from ERA file
  1.  I AR3444,'FOUND D
  1.  .S ERA3=$P($G(^RCY(344.4,AR3444,3)),U,1,7)
  1.  .S:$TR(ERA3,U,"")]"" FOUND=1,STR=ERA3
  1.  ;
  1.  ;Retrieve Payer Web Address from ERA file
  1.  I AR3444 S WEB=$P($G(^RCY(344.4,AR3444,5)),U) S:WEB]"" FOUND=1
  1.  ;
  1.  ;Get Payer Contact Name
  1.  S NAME=$P(STR,U) S:NAME]"" FOUND=1
  1.  ;
  1.  ;Format contacts
  1.  I STR]"" D
  1.  .N I,CTYP,CPOS
  1.  .F I=2,4,6 D:$P(STR,U,I)]""
  1.  ..;Validate contact type
  1.  ..S CTYP=$P(STR,U,I+1)
  1.  ..S CPOS=$S(CTYP="TE":1,CTYP="FX":2,CTYP="EM":3,CTYP="EX":4,1:0)
  1.  ..Q:'CPOS
  1.  ..;Save only first occurance of each type of contact
  1.  ..S:$P(CONTACTS,U,CPOS)="" $P(CONTACTS,U,CPOS)=$P(STR,U,I)
  1.  ;
  1.  ;Allow for misfiled legacy contact data
  1.  I FOUND,NAME="",WEB="",CONTACTS="" S FOUND=0
  1.  ;Return found_web_phone_fax_email
  1.  Q FOUND_U_NAME_U_WEB_U_CONTACTS
  1.  ;
  1. ADD(PRCABN) ;Update AR Transaction file #433 with comment type transaction
  1.  ;PRCABN = Bill/Claim IEN for file #399.
  1.  ;called only if 'ERA Contact Information' type comment is not found
  1.  ;serves as a notice to the user that the contact data came from the 835 ERA. Called from IBJTTC
  1.  ;
  1.  ;Note; PJH 8/11/2010 - see ADJUST^RCJIBFN3 (called by ARCA^IBJTA1)
  1.  ;
  1.  N AUTHDT,IBIFN,MRADT,STATUS
  1.  S IBIFN=PRCABN
  1.  S STATUS=$P($G(^DGCR(399,IBIFN,0)),U,13)
  1.  S AUTHDT=$P($G(^DGCR(399,IBIFN,"S")),U,10)
  1.  S MRADT=$P($G(^DGCR(399,IBIFN,"S")),U,7)
  1.  ;
  1.  ;If claim status is "NOT REVIEWED" or claim status is "CANCELLED"
  1.  ;with neither MRA request date nor Authorization date present
  1.  ;comment may not be added
  1.  I STATUS=1!(STATUS=7&(MRADT="")&(AUTHDT="")) Q
  1.  ;
  1.  ;If claim status is "REQUEST MRA" or claim status is "CANCELLED"
  1.  ;with MRA request date present, but no Authorization date comment
  1.  ;cannot be added
  1.  I STATUS=2!(STATUS=7&(MRADT'="")&(AUTHDT="")) Q
  1.  ;
  1.  ;Ignore bill cancelled in IB
  1.  I '$D(^PRCA(430,PRCABN,2,0)) Q
  1.  ;
  1.  ;Ignore Archived bill
  1.  I $P($G(^PRCA(430,PRCABN,0)),"^",8)=49 Q
  1.  ;
  1.  ;Build AR Transaction
  1.  ;
  1.  N PRCAEN,PRCAA1,DR,DIE,DA,D0,PRCAD,RCASK,PRCAA2,PRCA,PRCATY
  1.  ;
  1.  ;Create stub record in 433
  1.  D SETTR^PRCAUTL,PATTR^PRCAUTL Q:'$D(PRCAEN)
  1.  ;
  1.  S PRCAA1=$S($D(^PRCA(433,PRCAEN,4,0)):+$P(^(0),U,4),1:0)
  1.  Q:PRCAA1'>0  S PRCAA2=$P(^(0),U,3)
  1.  ;
  1.  ;Direct update of [PRCA COMMENT] edit template fields 
  1.  ;(excluding Date of Contact, Extended Comments and Follow-up Date)
  1.  S DIE="^PRCA(433,",DA=PRCAEN
  1.  S DR=".03////"_PRCABN ;Bill Number
  1.  S DR=DR_";3////0" ;Calm Code Done
  1.  S DR=DR_";12////"_$O(^PRCA(430.3,"AC",17,0)) ;Transaction Type
  1.  S DR=DR_";15////0" ;Transaction Amount
  1.  S DR=DR_";42////.5" ;Processed by POSTMASTER
  1.  S DR=DR_";11////"_DT ;Transaction date
  1.  S DR=DR_";4////2" ;Transaction status (complete)
  1.  S DR=DR_";5.02////ERA Payer Contact Information" D ^DIE
  1.  ;
  1.  ;Leave validation checks in place
  1.  I $P($G(^PRCA(433,PRCAEN,5)),"^",2)=""!'$P(^PRCA(433,PRCAEN,1),"^") S PRCACOMM="TRANSACTION INCOMPLETE" D DELETE^PRCAWO1 K PRCACOMM Q
  1.  ;
  1.  I '$D(PRCAD("DELETE")) S RCASK=1 D TRANUP^PRCAUTL,UPPRIN^PRCADJ
  1.  ;
  1.  I $P($G(^RCD(340,+$P(^PRCA(430,PRCABN,0),"^",9),0)),"^")[";DPT(" D
  1.  .;Ensure comment does not appear on patient statement
  1.  .S $P(^PRCA(433,PRCAEN,0),"^",10)=1
  1.  Q
  1.  ;
  1.  ;Audit Comment from EOB Move/Copy
  1. AUDIT(ORIG,TEXT,MODE) ;
  1.  ; ORIG = ien of entry in 361.1
  1.  ; TEXT = move/copy reason
  1.  ; MODE = is this a move or a copy event
  1.  ;
  1.  ;Translate EOB ien  to claim number IA 4051
  1.  N PRCABN
  1.  S PRCABN=$P($G(^IBM(361.1,ORIG,0)),U) Q:'PRCABN
  1.  ;Build AR Transaction
  1.  ;
  1.  N PRCAEN,PRCAA1,DR,DIE,DA,D0,PRCAD,RCASK,PRCAA2,PRCA,PRCATY
  1.  ;
  1.  ;Create stub record in 433
  1.  D SETTR^PRCAUTL,PATTR^PRCAUTL Q:'$D(PRCAEN)
  1.  ;
  1.  S PRCAA1=$S($D(^PRCA(433,PRCAEN,4,0)):+$P(^(0),U,4),1:0)
  1.  Q:PRCAA1'>0  S PRCAA2=$P(^(0),U,3)
  1.  ;
  1.  N MTEXT,INIT
  1.  S INIT=$$GET1^DIQ(200,DUZ,1)
  1.  S:INIT="" INIT="USER UNK."
  1.  S MTEXT="EEOB MOVED BY "_INIT
  1.  I MODE="C" S MTEXT="EEOB COPIED BY "_INIT
  1.  I MODE="R" S MTEXT="EEOB REMOVED BY "_INIT
  1.  I MODE="W" S MTEXT="EEOB MOVE/COPY IN SPLIT/EDIT"
  1.  I MODE="L" S MTEXT="EEOB MOVE/COPY IN LINK PAYMENT"
  1.  ;Direct update of [PRCA COMMENT] edit template fields 
  1.  ;(excluding Date of Contact, Extended Comments and Follow-up Date)
  1.  S DIE="^PRCA(433,",DA=PRCAEN
  1.  S DR=".03////"_PRCABN ;Bill Number
  1.  S DR=DR_";3////0" ;Calm Code Done
  1.  S DR=DR_";12////"_$O(^PRCA(430.3,"AC",17,0)) ;Transaction Type
  1.  S DR=DR_";15////0" ;Transaction Amount
  1.  S DR=DR_";42////"_$S($G(RCDUZ):RCDUZ,1:DUZ) ;Processed by - PRCA*4.5*326 use RCDUZ if it is set
  1.  S DR=DR_";4////2" ;Transaction status (complete)
  1.  S DR=DR_";5.02////"_MTEXT ;Brief comment
  1.  D ^DIE
  1.  ;Store justification text in comment field
  1.  N DA,DIC,DLAYGO,DR,X
  1.  S DA(1)=PRCAEN
  1.  S DIC="^PRCA(433,"_DA(1)_",7,",DIC(0)="L",X=$P(TEXT,U)
  1.  D FILE^DICN
  1.  ;Store auto generated text from stand alone option in comment field
  1.  I $P(TEXT,U,2)]"" D
  1.  .N DA,DIC,DLAYGO,DR,X
  1.  .S DA(1)=PRCAEN
  1.  .S DIC="^PRCA(433,"_DA(1)_",7,",DIC(0)="L",X="- "_$P(TEXT,U,2)
  1.  .D FILE^DICN
  1.  Q