RCP345 ;AITC/CJE,hrubovcak - ePayment Lockbox Post-Installation Processing ;22 Jan 2019 14:32:31
;;4.5;Accounts Receivable;**345**;Mar 20, 1995;Build 34
;Per VA Directive 6402, this routine should not be modified.
Q
;
POST ;
D AUTO1
;
D BMES^XPDUTL("Creating index on CARC Auto-Decrease No Pay (#344.62)")
S DIK="^RCY(344.62,",DIK(1)=".08^ACTVN" D ENALL^DIK
;
D RXADDF ; Populate defaults for Pharmacy Auto-Decrease
EFT ;
S ZTRTN="EFT3446^"_$T(+0),ZTDESC="Add EFT Payer/TIN to 344.6",ZTIO="",ZTDTH=$H
D ^%ZTLOAD
D MES^XPDUTL($S($G(ZTSK):"Task# "_ZTSK_" queued, to add EFTs to 344.6",1:"Unable to queue EFT 344.6 task."))
;
D BMES^XPDUTL("Fixing ERA numbers...")
D FIX3444
;
D BMES^XPDUTL("PRCA*4.5*345 post-installation finished "_$$HTE^XLFDT($H))
Q
;
AUTO1 ; Populate default values for 1st party auto-decrease
N FDA,IEN3501,J,RCLIST
D BMES^XPDUTL("Populate default values for 1st party auto-decrease (#342)")
S FDA(342,"1,",.14)=0
S FDA(342,"1,",.15)=0
D FILE^DIE("","FDA")
;
S RCLIST(1)="DG FEE SERVICE (OPT) NEW"
S RCLIST(2)="DG OPT COPAY NEW"
; S RCLIST(3)="PSO NSC RX COPAY NEW"
; S RCLIST(4)="PSO SC RX COPAY NEW"
S RCLIST(3)="CC (OPT) NEW"
;
K ^RC(342,1,14)
S J=0 F S J=$O(RCLIST(J)) Q:'J D ;
. S IEN3501=$O(^IBE(350.1,"B",RCLIST(J),0))
. I IEN3501 D ;
. . K FDA,IENS
. . S FDA(342.014,"+1,1,",.01)=IEN3501
. . S FDA(342.014,"+1,1,",.02)=1
. . D UPDATE^DIE("","FDA")
Q
;
RXADDF ; Populate defaults for Pharmacy Auto-Decrease
N FDA
S FDA(344.61,"1,",1.02)=0
S FDA(344.61,"1,",1.03)=5
S FDA(344.61,"1,",1.04)=100
D FILE^DIE("","FDA")
Q
;
EFT3446 ; Add EFT Payer/TINs to payer exclusion file
N ID,IEN,NAME,RET
S IEN=0
F S IEN=$O(^RCY(344.31,IEN)) Q:'IEN D ;
. S NAME=$$GET1^DIQ(344.31,IEN_",",.02)
. S ID=$$GET1^DIQ(344.31,IEN_",",.03)
. I NAME=""!(ID="") Q
. I '$D(^RCY(344.6,"CPID",NAME,ID)) S RET=$$PAYRINIT^RCDPESP(IEN,344.31)
Q
;
FIX3444 ; Repair Internal Entry Numbers in 344.4 where IEN is not equal to .01
N IEN,ENTRY
S IEN=0
F S IEN=$O(^RCY(344.4,IEN)) Q:'IEN D ;
. S ENTRY=$P($G(^RCY(344.4,IEN,0)),"^",1)
. I 'ENTRY Q
. I ENTRY'=IEN D ;
. . N FDA
. . S FDA(344.4,IEN_",",.01)=IEN
. . D FILE^DIE("","FDA")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCP345 2276 printed Nov 22, 2024@16:57:30 Page 2
RCP345 ;AITC/CJE,hrubovcak - ePayment Lockbox Post-Installation Processing ;22 Jan 2019 14:32:31
+1 ;;4.5;Accounts Receivable;**345**;Mar 20, 1995;Build 34
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
POST ;
+1 DO AUTO1
+2 ;
+3 DO BMES^XPDUTL("Creating index on CARC Auto-Decrease No Pay (#344.62)")
+4 SET DIK="^RCY(344.62,"
SET DIK(1)=".08^ACTVN"
DO ENALL^DIK
+5 ;
+6 ; Populate defaults for Pharmacy Auto-Decrease
DO RXADDF
EFT ;
+1 SET ZTRTN="EFT3446^"_$TEXT(+0)
SET ZTDESC="Add EFT Payer/TIN to 344.6"
SET ZTIO=""
SET ZTDTH=$HOROLOG
+2 DO ^%ZTLOAD
+3 DO MES^XPDUTL($SELECT($GET(ZTSK):"Task# "_ZTSK_" queued, to add EFTs to 344.6",1:"Unable to queue EFT 344.6 task."))
+4 ;
+5 DO BMES^XPDUTL("Fixing ERA numbers...")
+6 DO FIX3444
+7 ;
+8 DO BMES^XPDUTL("PRCA*4.5*345 post-installation finished "_$$HTE^XLFDT($HOROLOG))
+9 QUIT
+10 ;
AUTO1 ; Populate default values for 1st party auto-decrease
+1 NEW FDA,IEN3501,J,RCLIST
+2 DO BMES^XPDUTL("Populate default values for 1st party auto-decrease (#342)")
+3 SET FDA(342,"1,",.14)=0
+4 SET FDA(342,"1,",.15)=0
+5 DO FILE^DIE("","FDA")
+6 ;
+7 SET RCLIST(1)="DG FEE SERVICE (OPT) NEW"
+8 SET RCLIST(2)="DG OPT COPAY NEW"
+9 ; S RCLIST(3)="PSO NSC RX COPAY NEW"
+10 ; S RCLIST(4)="PSO SC RX COPAY NEW"
+11 SET RCLIST(3)="CC (OPT) NEW"
+12 ;
+13 KILL ^RC(342,1,14)
+14 ;
SET J=0
FOR
SET J=$ORDER(RCLIST(J))
if 'J
QUIT
Begin DoDot:1
+15 SET IEN3501=$ORDER(^IBE(350.1,"B",RCLIST(J),0))
+16 ;
IF IEN3501
Begin DoDot:2
+17 KILL FDA,IENS
+18 SET FDA(342.014,"+1,1,",.01)=IEN3501
+19 SET FDA(342.014,"+1,1,",.02)=1
+20 DO UPDATE^DIE("","FDA")
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
RXADDF ; Populate defaults for Pharmacy Auto-Decrease
+1 NEW FDA
+2 SET FDA(344.61,"1,",1.02)=0
+3 SET FDA(344.61,"1,",1.03)=5
+4 SET FDA(344.61,"1,",1.04)=100
+5 DO FILE^DIE("","FDA")
+6 QUIT
+7 ;
EFT3446 ; Add EFT Payer/TINs to payer exclusion file
+1 NEW ID,IEN,NAME,RET
+2 SET IEN=0
+3 ;
FOR
SET IEN=$ORDER(^RCY(344.31,IEN))
if 'IEN
QUIT
Begin DoDot:1
+4 SET NAME=$$GET1^DIQ(344.31,IEN_",",.02)
+5 SET ID=$$GET1^DIQ(344.31,IEN_",",.03)
+6 IF NAME=""!(ID="")
QUIT
+7 IF '$DATA(^RCY(344.6,"CPID",NAME,ID))
SET RET=$$PAYRINIT^RCDPESP(IEN,344.31)
End DoDot:1
+8 QUIT
+9 ;
FIX3444 ; Repair Internal Entry Numbers in 344.4 where IEN is not equal to .01
+1 NEW IEN,ENTRY
+2 SET IEN=0
+3 ;
FOR
SET IEN=$ORDER(^RCY(344.4,IEN))
if 'IEN
QUIT
Begin DoDot:1
+4 SET ENTRY=$PIECE($GET(^RCY(344.4,IEN,0)),"^",1)
+5 IF 'ENTRY
QUIT
+6 ;
IF ENTRY'=IEN
Begin DoDot:2
+7 NEW FDA
+8 SET FDA(344.4,IEN_",",.01)=IEN
+9 DO FILE^DIE("","FDA")
End DoDot:2
End DoDot:1
+10 QUIT
