PRCAP298 ;BIRM/EWL ALB/hrubovcak - ePayment Lockbox Post-Installation Processing ;Dec 20, 2014@14:08:45
;;4.5;Accounts Receivable;**298**;Jan 21, 2014;Build 121
;Per VA Directive 6402, this routine should not be modified.
;
; References to ^XPDMENU supported by DBIA 1157
Q
;
PRE ; pre-installation processing
; delete old "C" cross-reference in ERA file (#344.4)
D DELIX^DDMOD(344.4,.06,1,"K")
D BMES^XPDUTL("Removed old cross-reference in file #344.4")
Q
;
POST ; PRCA*4.5*298 post-installation processing
D DELOPT ; remove RCDPE EOB TRANSFER REPORTS option
D SETPARMS ; set parameters in RCDPE PARAMETER file (#344.61)
D INITPRMS ; initialize file #344.6, cross-ref. files #344.31 & #344.4
Q
;
DELOPT ; remove RCDPE EOB TRANSFER REPORTS option
N DA,DIK,MEN,OPT,RET
; RET - value returned from
S MEN="RCDPE EDI LOCKBOX REPORTS MENU"
S OPT="RCDPE EOB TRANSFER REPORTS"
D BMES^XPDUTL("Updating ["_MEN_"]")
S RET=$$DELETE^XPDMENU(MEN,OPT) ; delete option from menu
S DA=+$$LKOPT^XPDMENU(OPT) ; get option IEN
I DA>0 S DIK="^DIC(19," D ^DIK ; code can be re-run if already deleted
D MES^XPDUTL("Menu update "_$S(RET:"completed.",1:"not needed."))
;
Q
;
SETPARMS ; update RCDPE PARAMETER file (#344.61)
N PRFDA,PRIENS,SITE,X
; PRFDA - Array for the ^DIE call
; PRIENS - IENS value for ^DIE
; SITE - site number from file #342,.01 SITE (POINTER TO INSTITUTION FILE (#4))
;
D MES^XPDUTL("Updating RCDPE PARAMETER file (#344.61)")
S SITE=$$GET1^DIQ(342,1,.01,"I")
I 'SITE D Q
.; This should never happen. If it does, there are bigger problems.
.D MES^XPDUTL("*******************************************************************************")
.D MES^XPDUTL("** **")
.D MES^XPDUTL("** There is a problem with the AR SITE PARAMETER file. This will need to be **")
.D MES^XPDUTL("** fixed. The RCDPE PARAMETER file cannot be initialized. **")
.D MES^XPDUTL("** **")
.D MES^XPDUTL("** Once the AR SITE PARAMETER file is fixed, re-run SETPARMS^PRCAP298 **")
.D MES^XPDUTL("** **")
.D MES^XPDUTL("*******************************************************************************")
;
S X=$G(^RCY(344.61,1,0))
; if parameters already initialized set cutoff date and exit
I $P(X,U) S $P(X,U,9)=DT,^RCY(344.61,1,0)=X D MES^XPDUTL("Updated PHARMACY EFT CUTOFF DATE") Q
D MES^XPDUTL("Initializing parameters.")
S PRIENS=$S($D(^RCY(344.61,1)):"1,",1:"+1,")
S PRFDA(344.61,PRIENS,.01)=SITE ; pointer to INSTITUTION file (#4)
S PRFDA(344.61,PRIENS,.03)=0 ; AUTO-DECREASE MED ENABLED
S PRFDA(344.61,PRIENS,.06)=21 ; MEDICAL EFT POST PREVENT DAYS
S PRFDA(344.61,PRIENS,.07)=999 ; PHARMACY EFT POST PREVENT DAYS
S PRFDA(344.61,PRIENS,.09)=DT ; PHARMACY EFT CUTOFF DATE
;
I PRIENS="+1," D UPDATE^DIE(,"PRFDA") ; create new entry
I PRIENS="1," D FILE^DIE(,"PRFDA") ; update existing entry
;
D MES^XPDUTL("Finished updates to RCDPE PARAMETER file (#344.61)")
Q
;
INITPRMS ; Task jobs to initialize file #344.6, cross-ref. files #344.31 & #344.4
;
N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSK
; set ^XTMP zero node for 180 day retention
S ^XTMP($T(+0),0)=$$HTFM^XLFDT($H+180)_U_DT_"^PRCA*4.5*298 post-installation"
D BMES^XPDUTL("Post-installation tasks "_$$FMTE^XLFDT($$NOW^XLFDT)) ; add date/time to log
D BMES^XPDUTL("Queueing tasks for files #344.6 and #344.4")
S ZTRTN="ERAPSTIN^"_$T(+0),ZTDESC="ERA (#344.4) post-init work",ZTIO="",ZTDTH=$H
D ^%ZTLOAD
D MES^XPDUTL($S($G(ZTSK):"Task number "_ZTSK_" has been queued.",1:"Unable to queue this task."))
I $G(ZTSK) D MES^XPDUTL("A MailMan message will be sent on completion.")
;
K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSK ; delete residual values
D BMES^XPDUTL(" "_$$FMTE^XLFDT($$NOW^XLFDT)) ; add date/time to log
D MES^XPDUTL("Queueing EDI THIRD PARTY EFT DETAIL file cross-ref. task.")
S ZTRTN="E3PDXREF^"_$T(+0),ZTDESC="EDI THIRD PARTY EFT DETAIL file cross-ref.",ZTIO="",ZTDTH=$H
D ^%ZTLOAD
D MES^XPDUTL($S($G(ZTSK):"Task number "_ZTSK_" has been queued.",1:"Unable to queue this task."))
I $G(ZTSK) D MES^XPDUTL("A MailMan message will be sent on completion.")
;
D BMES^XPDUTL("Done queuing tasks "_$$FMTE^XLFDT($$NOW^XLFDT))
Q
;
ERAPSTIN ; entry point from TaskMan to initialize file #344.6 and cross-ref. file #344.4
; sends MailMan message on completion, this subroutine can be called manually
;
N ERA0,ERAIEN,PRADD,PRATRI,PRCXREF,PRDNLZ,PRHXREF,PRERATTL,PRID,PRNODE,PRPAYER,PRXMBODY,PRXMSUBJ,PRXMTO,PRXMZR,X,X2,X3,XMINSTR,XR,XRS
; ERA0 - zero node of ERA
; ERAIEN - IEN in file #344.4
; PRADD - total updated in file #344.6 counter
; PRATRI - 'ATRIDUP' cross-ref. counter
; PRDNLZ - 'DNLZ' cross-ref. counter
; PRHXREF - 'H' cross-ref. counter
; PRID - Payer ID
; PRNODE - ^XTMP storage node
; PRPAYER - payer name
; PRXMBODY - root of message body
; PRXMSUBJ - message subject
; PRXMTO - array of MailMan message recipients
;
S PRNODE="ERAPOST4"
; loop through ELECTRONIC REMITTANCE ADVICE file #344.4
S PRADD=0 ; payers added to file #344.6
S PRDNLZ=0 ; 'DNLZ' cross-refs. added this run
S PRATRI=0 ; 'ATRIDUP' cross-refs. added this run
S PRCXREF=0 ; 'C' cross-refs. added this run
S PRHXREF=0 ; 'H' cross=refs. added this run
S PRERATTL=0 ; ERA entries examined
S PRNODE("BEG")=$$NOW^XLFDT
S ERAIEN=$G(^XTMP($T(+0),PRNODE,"LAST"))
I ERAIEN="" S ERAIEN=$C(1) ; iterating backwards, set to value past numbers
; if not already run, clean up old 'C' and 'H' cross-refs., they will be re-created
I '$G(^XTMP($T(+0),PRNODE,"FINISHED")) K ^RCY(344.4,"C"),^RCY(344.4,"H")
; run only once
I '$G(^XTMP($T(+0),PRNODE,"FINISHED")) F S ERAIEN=$O(^RCY(344.4,ERAIEN),-1) Q:'ERAIEN S ERA0=$G(^RCY(344.4,ERAIEN,0)) D:ERA0]""
.S PRERATTL=PRERATTL+1
.;add Payer Name and Payer ID to #344.6
.S PRPAYER=$P(ERA0,U,6),PRID=$P(ERA0,U,3) D
..Q:(PRPAYER="")!(PRID="") ; must have name and ID
..I '$D(^RCY(344.6,"CPID",$E(PRPAYER,1,60),$E(PRID,1,30))) D PAYRINIT^RCDPESP(ERAIEN) S PRADD=PRADD+1 ; only if entry doesn't exist
.;
.;set 'ATRIDUP' cross-ref. for TRACE # field (#.02) and INSURANCE CO ID (#.03)
.S X2=$P(ERA0,U,2),X3=$P(ERA0,U,3) D:(X2]"")&(X3]"") ; both fields must have values
..S X2=$$UP($E(X2,1,50)),X3=$$UP($E(X3,1,30)) ; set case and length
..S ^RCY(344.4,"ATRIDUP",X2,X3,ERAIEN)="",PRATRI=PRATRI+1
.; set 'DNLZ' cross-reference
.S X=$P(ERA0,U,2) I X]"" D:X?.N!($E(X)=0) ; TRACE # field (#.02), numerics or leading zero
..I $E(X)=0&($L(X)>2) F S X=$E(X,2,$L(X)) Q:$L(X)<2!'($E(X)=0) ; strip extra leading zeroes
..S:X]"" ^RCY(344.4,"DNLZ",X_" ",ERAIEN)="",PRDNLZ=PRDNLZ+1
.; set 'C' cross-reference for PAYMENT FROM field (#.06)
.S X=$P(ERA0,U,6) S:$TR(X," ")]"" ^RCY(344.4,"C",$$UP($E(X,1,60)),ERAIEN)="",PRCXREF=PRCXREF+1
.; set 'H' cross-reference for ERA Detail
.D:$D(^RCY(344.4,ERAIEN,1,"RECEIPT"))
..S XR=0 F S XR=$O(^RCY(344.4,ERAIEN,1,"RECEIPT",XR)) Q:XR="" S XRS="" D
...F S XRS=$O(^RCY(344.4,ERAIEN,1,"RECEIPT",XR,XRS)) Q:XRS="" S ^RCY(344.4,"H",XR,ERAIEN,XRS)="",PRHXREF=PRHXREF+1
.;
.S ^XTMP($T(+0),PRNODE,"LAST")=ERAIEN ; last IEN processed
;
S PRNODE("END")=$$NOW^XLFDT
I '$G(^XTMP($T(+0),PRNODE,"FINISHED")) S ^("FINISHED")=PRNODE("END")
; create MailMan message text
S PRXMBODY(0)=0
D ADD2TXT(.PRXMBODY,"Finished file #344.4 post-initialization tasks.")
D ADD2TXT(.PRXMBODY," Process begun: "_$$FMTE^XLFDT(PRNODE("BEG")))
D ADD2TXT(.PRXMBODY," Process ended: "_$$FMTE^XLFDT(PRNODE("END")))
D ADD2TXT(.PRXMBODY," ") ; blank line
D ADD2TXT(.PRXMBODY," Total ERA entries checked: "_$FN(PRERATTL,",")) ;PRERATTL
D ADD2TXT(.PRXMBODY," 'ATRIDUP' cross-refs. file #344.4: "_$FN(PRATRI,","))
D ADD2TXT(.PRXMBODY," 'C' cross-refs. file #344.4: "_$FN(PRCXREF,","))
D ADD2TXT(.PRXMBODY," 'DNLZ' cross-refs. file #344.4: "_$FN(PRDNLZ,","))
D ADD2TXT(.PRXMBODY," 'H' cross-refs. file #344.4: "_$FN(PRHXREF,","))
D ADD2TXT(.PRXMBODY," ") ; blank line
D ADD2TXT(.PRXMBODY," Entries added to file #344.6: "_$FN(PRADD,","))
D ADD2TXT(.PRXMBODY," ") ; blank line
I $G(ZTSK) D ADD2TXT(.PRXMBODY," * Queued as Task #"_ZTSK_" *")
D ADD2TXT(.PRXMBODY,"Report generated by the "_$T(+0)_" post-initialization routine.")
;
; save MailMan message text
M ^XTMP($T(+0),PRNODE,"MAIL MSG",$$NOW^XLFDT)=PRXMBODY
; send via MailMan
S PRXMSUBJ="PRCA*4.5*298 files #344.4 & #344.6 post-init completed"
S PRXMTO(.5)="",PRXMTO(DUZ)="" ; POSTMASTER and user who queued it
S PRXMTO("G.RCDPE PAYMENTS MGMT")=""
S XMINSTR("FROM")="POSTMASTER"
;
D SENDMSG^XMXAPI(DUZ,PRXMSUBJ,"PRXMBODY",.PRXMTO,.XMINSTR,.PRXMZR) ; send message
I $G(PRXMZR),'$G(ZTSK),$E(IOST,1,2)="C-" W !,"MailMan message number: "_PRXMZR
Q
;
;
E3PDXREF ; set 'ADR', 'F', and 'FNLZ' cross-refs. in EDI THIRD PARTY EFT DETAIL file (#344.31)
; sends MailMan message on completion, this subroutine can be called manually
;
N PR310,PR31IEN,PRADR,PRF,PRFNLZ,PRNODE,PRTOTL,PRXMBODY,PRXMSUBJ,PRXMTO,PRXMZR,X,XMINSTR
; PR310 - zero node for entry
; PR31IEN - IEN in ELECTRONIC REMITTANCE ADVICE
; PRADR - count of "ADR" cross-refs. set
; PRF - count of "F" cross-refs. set
; PRFNLZ - count of "F" cross-refs. set
; PRNODE - ^XTMP storage node
; PRTOTL - count of entries checked
; PRXMSUBJ - message subject
; PRXMTO - array of MailMan message recipients
; PRXMZR - message number returned
;
S PRNODE="E3PDXREF"
S (PRF,PRFNLZ,PRADR,PRTOTL)=0,PRNODE("BEG")=$$NOW^XLFDT
;
S PR31IEN=$G(^XTMP($T(+0),PRNODE,"LAST"))
I PR31IEN="" S PR31IEN=$C(1) ; iterating backwards, set to value past numbers
; run only once
I '$G(^XTMP($T(+0),PRNODE,"FINISHED")) F S PR31IEN=$O(^RCY(344.31,PR31IEN),-1) Q:'(PR31IEN>0) D
.S PR310=$G(^RCY(344.31,PR31IEN,0)) Q:PR310="" ; zero node of entry
.S PRTOTL=PRTOTL+1,X=$P(PR310,U,4) S:X]"" ^RCY(344.31,"F",$E(X,1,50),PR31IEN)="",PRF=PRF+1
.I X]"" D:X?.N!($E(X)=0) ; TRACE # field (#.02), only numerics or leading zero
..I $E(X)=0&($L(X)>2) F S X=$E(X,2,$L(X)) Q:$L(X)<2!'($E(X)=0) ; strip extra leading zeroes
..S:X]"" ^RCY(344.31,"FNLZ",X_" ",PR31IEN)="",PRFNLZ=PRFNLZ+1
.;
.S X=$P(PR310,U,13) S:X]"" ^RCY(344.31,"ADR",X,PR31IEN)="",PRADR=PRADR+1
.S ^XTMP($T(+0),PRNODE,"LAST")=PR31IEN
;
; disable 'D' new-style cross-ref., replaced by traditional 'F' cross-ref.
I '$G(^XTMP($T(+0),PRNODE,"FINISHED")) D:$D(^RCY(344.31,"D"))
.N PRDIERR,PRDIMSG ; error root, message root
.D DELIXN^DDMOD(344.31,"D","KW","PRDIMSG","PRDIERR") ; supported FileMan database server API
;
S PRNODE("END")=$$NOW^XLFDT
I '$G(^XTMP($T(+0),PRNODE,"FINISHED")) S ^("FINISHED")=PRNODE("END")
; create MailMan message text
S PRXMBODY(0)=0
D ADD2TXT(.PRXMBODY,"Updated cross-references for file #344.31")
D ADD2TXT(.PRXMBODY," Work begun: "_$$FMTE^XLFDT(PRNODE("BEG")))
D ADD2TXT(.PRXMBODY," Work ended: "_$$FMTE^XLFDT(PRNODE("END")))
D ADD2TXT(.PRXMBODY," ") ; blank line
D ADD2TXT(.PRXMBODY," Total Entries examined: "_$FN(PRTOTL,","))
D ADD2TXT(.PRXMBODY," ") ; blank line
D ADD2TXT(.PRXMBODY," 'F' cross-ref. total: "_$FN(PRF,","))
D ADD2TXT(.PRXMBODY," 'FNLZ' cross-ref. total: "_$FN(PRFNLZ,","))
D ADD2TXT(.PRXMBODY," 'ADR' cross-ref. total: "_$FN(PRADR,","))
D ADD2TXT(.PRXMBODY," ") ; blank line
I $G(ZTSK) D ADD2TXT(.PRXMBODY," * Queued as Task #"_ZTSK_" *")
D ADD2TXT(.PRXMBODY,"Report generated by the "_$T(+0)_" post-initialization routine.")
;
; save MailMan message text
M ^XTMP($T(+0),PRNODE,"MAIL MSG",$$NOW^XLFDT)=PRXMBODY
; send report via MailMan
S XMINSTR("FROM")="POSTMASTER"
S PRXMSUBJ="PRCA*4.5*298 file #344.31 post-init completed"
S PRXMTO(.5)="",PRXMTO(DUZ)="" ; POSTMASTER and user who queued it
S PRXMTO("G.RCDPE PAYMENTS MGMT")=""
;
D SENDMSG^XMXAPI(DUZ,PRXMSUBJ,"PRXMBODY",.PRXMTO,.XMINSTR,.PRXMZR) ; send message
I $G(PRXMZR),'$G(ZTSK),$E(IOST,1,2)="C-" D MES^XPDUTL("MailMan message number: "_PRXMZR)
;
Q
;
ADD2TXT(TXARY,LN) ; add LN to TXARY for MailMan Message
; TXARY passed by ref.
Q:$G(LN)=""
S TXARY(0)=$G(TXARY(0))+1,TXARY(TXARY(0),0)=LN Q
;
; function, returns uppercase
UP(T) Q $TR(T,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAP298 12547 printed Sep 23, 2025@19:16:39 Page 2
PRCAP298 ;BIRM/EWL ALB/hrubovcak - ePayment Lockbox Post-Installation Processing ;Dec 20, 2014@14:08:45
+1 ;;4.5;Accounts Receivable;**298**;Jan 21, 2014;Build 121
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; References to ^XPDMENU supported by DBIA 1157
+5 QUIT
+6 ;
PRE ; pre-installation processing
+1 ; delete old "C" cross-reference in ERA file (#344.4)
+2 DO DELIX^DDMOD(344.4,.06,1,"K")
+3 DO BMES^XPDUTL("Removed old cross-reference in file #344.4")
+4 QUIT
+5 ;
POST ; PRCA*4.5*298 post-installation processing
+1 ; remove RCDPE EOB TRANSFER REPORTS option
DO DELOPT
+2 ; set parameters in RCDPE PARAMETER file (#344.61)
DO SETPARMS
+3 ; initialize file #344.6, cross-ref. files #344.31 & #344.4
DO INITPRMS
+4 QUIT
+5 ;
DELOPT ; remove RCDPE EOB TRANSFER REPORTS option
+1 NEW DA,DIK,MEN,OPT,RET
+2 ; RET - value returned from
+3 SET MEN="RCDPE EDI LOCKBOX REPORTS MENU"
+4 SET OPT="RCDPE EOB TRANSFER REPORTS"
+5 DO BMES^XPDUTL("Updating ["_MEN_"]")
+6 ; delete option from menu
SET RET=$$DELETE^XPDMENU(MEN,OPT)
+7 ; get option IEN
SET DA=+$$LKOPT^XPDMENU(OPT)
+8 ; code can be re-run if already deleted
IF DA>0
SET DIK="^DIC(19,"
DO ^DIK
+9 DO MES^XPDUTL("Menu update "_$SELECT(RET:"completed.",1:"not needed."))
+10 ;
+11 QUIT
+12 ;
SETPARMS ; update RCDPE PARAMETER file (#344.61)
+1 NEW PRFDA,PRIENS,SITE,X
+2 ; PRFDA - Array for the ^DIE call
+3 ; PRIENS - IENS value for ^DIE
+4 ; SITE - site number from file #342,.01 SITE (POINTER TO INSTITUTION FILE (#4))
+5 ;
+6 DO MES^XPDUTL("Updating RCDPE PARAMETER file (#344.61)")
+7 SET SITE=$$GET1^DIQ(342,1,.01,"I")
+8 IF 'SITE
Begin DoDot:1
+9 ; This should never happen. If it does, there are bigger problems.
+10 DO MES^XPDUTL("*******************************************************************************")
+11 DO MES^XPDUTL("** **")
+12 DO MES^XPDUTL("** There is a problem with the AR SITE PARAMETER file. This will need to be **")
+13 DO MES^XPDUTL("** fixed. The RCDPE PARAMETER file cannot be initialized. **")
+14 DO MES^XPDUTL("** **")
+15 DO MES^XPDUTL("** Once the AR SITE PARAMETER file is fixed, re-run SETPARMS^PRCAP298 **")
+16 DO MES^XPDUTL("** **")
+17 DO MES^XPDUTL("*******************************************************************************")
End DoDot:1
QUIT
+18 ;
+19 SET X=$GET(^RCY(344.61,1,0))
+20 ; if parameters already initialized set cutoff date and exit
+21 IF $PIECE(X,U)
SET $PIECE(X,U,9)=DT
SET ^RCY(344.61,1,0)=X
DO MES^XPDUTL("Updated PHARMACY EFT CUTOFF DATE")
QUIT
+22 DO MES^XPDUTL("Initializing parameters.")
+23 SET PRIENS=$SELECT($DATA(^RCY(344.61,1)):"1,",1:"+1,")
+24 ; pointer to INSTITUTION file (#4)
SET PRFDA(344.61,PRIENS,.01)=SITE
+25 ; AUTO-DECREASE MED ENABLED
SET PRFDA(344.61,PRIENS,.03)=0
+26 ; MEDICAL EFT POST PREVENT DAYS
SET PRFDA(344.61,PRIENS,.06)=21
+27 ; PHARMACY EFT POST PREVENT DAYS
SET PRFDA(344.61,PRIENS,.07)=999
+28 ; PHARMACY EFT CUTOFF DATE
SET PRFDA(344.61,PRIENS,.09)=DT
+29 ;
+30 ; create new entry
IF PRIENS="+1,"
DO UPDATE^DIE(,"PRFDA")
+31 ; update existing entry
IF PRIENS="1,"
DO FILE^DIE(,"PRFDA")
+32 ;
+33 DO MES^XPDUTL("Finished updates to RCDPE PARAMETER file (#344.61)")
+34 QUIT
+35 ;
INITPRMS ; Task jobs to initialize file #344.6, cross-ref. files #344.31 & #344.4
+1 ;
+2 NEW ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSK
+3 ; set ^XTMP zero node for 180 day retention
+4 SET ^XTMP($TEXT(+0),0)=$$HTFM^XLFDT($HOROLOG+180)_U_DT_"^PRCA*4.5*298 post-installation"
+5 ; add date/time to log
DO BMES^XPDUTL("Post-installation tasks "_$$FMTE^XLFDT($$NOW^XLFDT))
+6 DO BMES^XPDUTL("Queueing tasks for files #344.6 and #344.4")
+7 SET ZTRTN="ERAPSTIN^"_$TEXT(+0)
SET ZTDESC="ERA (#344.4) post-init work"
SET ZTIO=""
SET ZTDTH=$HOROLOG
+8 DO ^%ZTLOAD
+9 DO MES^XPDUTL($SELECT($GET(ZTSK):"Task number "_ZTSK_" has been queued.",1:"Unable to queue this task."))
+10 IF $GET(ZTSK)
DO MES^XPDUTL("A MailMan message will be sent on completion.")
+11 ;
+12 ; delete residual values
KILL ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSK
+13 ; add date/time to log
DO BMES^XPDUTL(" "_$$FMTE^XLFDT($$NOW^XLFDT))
+14 DO MES^XPDUTL("Queueing EDI THIRD PARTY EFT DETAIL file cross-ref. task.")
+15 SET ZTRTN="E3PDXREF^"_$TEXT(+0)
SET ZTDESC="EDI THIRD PARTY EFT DETAIL file cross-ref."
SET ZTIO=""
SET ZTDTH=$HOROLOG
+16 DO ^%ZTLOAD
+17 DO MES^XPDUTL($SELECT($GET(ZTSK):"Task number "_ZTSK_" has been queued.",1:"Unable to queue this task."))
+18 IF $GET(ZTSK)
DO MES^XPDUTL("A MailMan message will be sent on completion.")
+19 ;
+20 DO BMES^XPDUTL("Done queuing tasks "_$$FMTE^XLFDT($$NOW^XLFDT))
+21 QUIT
+22 ;
ERAPSTIN ; entry point from TaskMan to initialize file #344.6 and cross-ref. file #344.4
+1 ; sends MailMan message on completion, this subroutine can be called manually
+2 ;
+3 NEW ERA0,ERAIEN,PRADD,PRATRI,PRCXREF,PRDNLZ,PRHXREF,PRERATTL,PRID,PRNODE,PRPAYER,PRXMBODY,PRXMSUBJ,PRXMTO,PRXMZR,X,X2,X3,XMINSTR,XR,XRS
+4 ; ERA0 - zero node of ERA
+5 ; ERAIEN - IEN in file #344.4
+6 ; PRADD - total updated in file #344.6 counter
+7 ; PRATRI - 'ATRIDUP' cross-ref. counter
+8 ; PRDNLZ - 'DNLZ' cross-ref. counter
+9 ; PRHXREF - 'H' cross-ref. counter
+10 ; PRID - Payer ID
+11 ; PRNODE - ^XTMP storage node
+12 ; PRPAYER - payer name
+13 ; PRXMBODY - root of message body
+14 ; PRXMSUBJ - message subject
+15 ; PRXMTO - array of MailMan message recipients
+16 ;
+17 SET PRNODE="ERAPOST4"
+18 ; loop through ELECTRONIC REMITTANCE ADVICE file #344.4
+19 ; payers added to file #344.6
SET PRADD=0
+20 ; 'DNLZ' cross-refs. added this run
SET PRDNLZ=0
+21 ; 'ATRIDUP' cross-refs. added this run
SET PRATRI=0
+22 ; 'C' cross-refs. added this run
SET PRCXREF=0
+23 ; 'H' cross=refs. added this run
SET PRHXREF=0
+24 ; ERA entries examined
SET PRERATTL=0
+25 SET PRNODE("BEG")=$$NOW^XLFDT
+26 SET ERAIEN=$GET(^XTMP($TEXT(+0),PRNODE,"LAST"))
+27 ; iterating backwards, set to value past numbers
IF ERAIEN=""
SET ERAIEN=$CHAR(1)
+28 ; if not already run, clean up old 'C' and 'H' cross-refs., they will be re-created
+29 IF '$GET(^XTMP($TEXT(+0),PRNODE,"FINISHED"))
KILL ^RCY(344.4,"C"),^RCY(344.4,"H")
+30 ; run only once
+31 IF '$GET(^XTMP($TEXT(+0),PRNODE,"FINISHED"))
FOR
SET ERAIEN=$ORDER(^RCY(344.4,ERAIEN),-1)
if 'ERAIEN
QUIT
SET ERA0=$GET(^RCY(344.4,ERAIEN,0))
if ERA0]""
Begin DoDot:1
+32 SET PRERATTL=PRERATTL+1
+33 ;add Payer Name and Payer ID to #344.6
+34 SET PRPAYER=$PIECE(ERA0,U,6)
SET PRID=$PIECE(ERA0,U,3)
Begin DoDot:2
+35 ; must have name and ID
if (PRPAYER="")!(PRID="")
QUIT
+36 ; only if entry doesn't exist
IF '$DATA(^RCY(344.6,"CPID",$EXTRACT(PRPAYER,1,60),$EXTRACT(PRID,1,30)))
DO PAYRINIT^RCDPESP(ERAIEN)
SET PRADD=PRADD+1
End DoDot:2
+37 ;
+38 ;set 'ATRIDUP' cross-ref. for TRACE # field (#.02) and INSURANCE CO ID (#.03)
+39 ; both fields must have values
SET X2=$PIECE(ERA0,U,2)
SET X3=$PIECE(ERA0,U,3)
if (X2]"")&(X3]"")
Begin DoDot:2
+40 ; set case and length
SET X2=$$UP($EXTRACT(X2,1,50))
SET X3=$$UP($EXTRACT(X3,1,30))
+41 SET ^RCY(344.4,"ATRIDUP",X2,X3,ERAIEN)=""
SET PRATRI=PRATRI+1
End DoDot:2
+42 ; set 'DNLZ' cross-reference
+43 ; TRACE # field (#.02), numerics or leading zero
SET X=$PIECE(ERA0,U,2)
IF X]""
if X?.N!($EXTRACT(X)=0)
Begin DoDot:2
+44 ; strip extra leading zeroes
IF $EXTRACT(X)=0&($LENGTH(X)>2)
FOR
SET X=$EXTRACT(X,2,$LENGTH(X))
if $LENGTH(X)<2!'($EXTRACT(X)=0)
QUIT
+45 if X]""
SET ^RCY(344.4,"DNLZ",X_" ",ERAIEN)=""
SET PRDNLZ=PRDNLZ+1
End DoDot:2
+46 ; set 'C' cross-reference for PAYMENT FROM field (#.06)
+47 SET X=$PIECE(ERA0,U,6)
if $TRANSLATE(X," ")]""
SET ^RCY(344.4,"C",$$UP($EXTRACT(X,1,60)),ERAIEN)=""
SET PRCXREF=PRCXREF+1
+48 ; set 'H' cross-reference for ERA Detail
+49 if $DATA(^RCY(344.4,ERAIEN,1,"RECEIPT"))
Begin DoDot:2
+50 SET XR=0
FOR
SET XR=$ORDER(^RCY(344.4,ERAIEN,1,"RECEIPT",XR))
if XR=""
QUIT
SET XRS=""
Begin DoDot:3
+51 FOR
SET XRS=$ORDER(^RCY(344.4,ERAIEN,1,"RECEIPT",XR,XRS))
if XRS=""
QUIT
SET ^RCY(344.4,"H",XR,ERAIEN,XRS)=""
SET PRHXREF=PRHXREF+1
End DoDot:3
End DoDot:2
+52 ;
+53 ; last IEN processed
SET ^XTMP($TEXT(+0),PRNODE,"LAST")=ERAIEN
End DoDot:1
+54 ;
+55 SET PRNODE("END")=$$NOW^XLFDT
+56 IF '$GET(^XTMP($TEXT(+0),PRNODE,"FINISHED"))
SET ^("FINISHED")=PRNODE("END")
+57 ; create MailMan message text
+58 SET PRXMBODY(0)=0
+59 DO ADD2TXT(.PRXMBODY,"Finished file #344.4 post-initialization tasks.")
+60 DO ADD2TXT(.PRXMBODY," Process begun: "_$$FMTE^XLFDT(PRNODE("BEG")))
+61 DO ADD2TXT(.PRXMBODY," Process ended: "_$$FMTE^XLFDT(PRNODE("END")))
+62 ; blank line
DO ADD2TXT(.PRXMBODY," ")
+63 ;PRERATTL
DO ADD2TXT(.PRXMBODY," Total ERA entries checked: "_$FNUMBER(PRERATTL,","))
+64 DO ADD2TXT(.PRXMBODY," 'ATRIDUP' cross-refs. file #344.4: "_$FNUMBER(PRATRI,","))
+65 DO ADD2TXT(.PRXMBODY," 'C' cross-refs. file #344.4: "_$FNUMBER(PRCXREF,","))
+66 DO ADD2TXT(.PRXMBODY," 'DNLZ' cross-refs. file #344.4: "_$FNUMBER(PRDNLZ,","))
+67 DO ADD2TXT(.PRXMBODY," 'H' cross-refs. file #344.4: "_$FNUMBER(PRHXREF,","))
+68 ; blank line
DO ADD2TXT(.PRXMBODY," ")
+69 DO ADD2TXT(.PRXMBODY," Entries added to file #344.6: "_$FNUMBER(PRADD,","))
+70 ; blank line
DO ADD2TXT(.PRXMBODY," ")
+71 IF $GET(ZTSK)
DO ADD2TXT(.PRXMBODY," * Queued as Task #"_ZTSK_" *")
+72 DO ADD2TXT(.PRXMBODY,"Report generated by the "_$TEXT(+0)_" post-initialization routine.")
+73 ;
+74 ; save MailMan message text
+75 MERGE ^XTMP($TEXT(+0),PRNODE,"MAIL MSG",$$NOW^XLFDT)=PRXMBODY
+76 ; send via MailMan
+77 SET PRXMSUBJ="PRCA*4.5*298 files #344.4 & #344.6 post-init completed"
+78 ; POSTMASTER and user who queued it
SET PRXMTO(.5)=""
SET PRXMTO(DUZ)=""
+79 SET PRXMTO("G.RCDPE PAYMENTS MGMT")=""
+80 SET XMINSTR("FROM")="POSTMASTER"
+81 ;
+82 ; send message
DO SENDMSG^XMXAPI(DUZ,PRXMSUBJ,"PRXMBODY",.PRXMTO,.XMINSTR,.PRXMZR)
+83 IF $GET(PRXMZR)
IF '$GET(ZTSK)
IF $EXTRACT(IOST,1,2)="C-"
WRITE !,"MailMan message number: "_PRXMZR
+84 QUIT
+85 ;
+86 ;
E3PDXREF ; set 'ADR', 'F', and 'FNLZ' cross-refs. in EDI THIRD PARTY EFT DETAIL file (#344.31)
+1 ; sends MailMan message on completion, this subroutine can be called manually
+2 ;
+3 NEW PR310,PR31IEN,PRADR,PRF,PRFNLZ,PRNODE,PRTOTL,PRXMBODY,PRXMSUBJ,PRXMTO,PRXMZR,X,XMINSTR
+4 ; PR310 - zero node for entry
+5 ; PR31IEN - IEN in ELECTRONIC REMITTANCE ADVICE
+6 ; PRADR - count of "ADR" cross-refs. set
+7 ; PRF - count of "F" cross-refs. set
+8 ; PRFNLZ - count of "F" cross-refs. set
+9 ; PRNODE - ^XTMP storage node
+10 ; PRTOTL - count of entries checked
+11 ; PRXMSUBJ - message subject
+12 ; PRXMTO - array of MailMan message recipients
+13 ; PRXMZR - message number returned
+14 ;
+15 SET PRNODE="E3PDXREF"
+16 SET (PRF,PRFNLZ,PRADR,PRTOTL)=0
SET PRNODE("BEG")=$$NOW^XLFDT
+17 ;
+18 SET PR31IEN=$GET(^XTMP($TEXT(+0),PRNODE,"LAST"))
+19 ; iterating backwards, set to value past numbers
IF PR31IEN=""
SET PR31IEN=$CHAR(1)
+20 ; run only once
+21 IF '$GET(^XTMP($TEXT(+0),PRNODE,"FINISHED"))
FOR
SET PR31IEN=$ORDER(^RCY(344.31,PR31IEN),-1)
if '(PR31IEN>0)
QUIT
Begin DoDot:1
+22 ; zero node of entry
SET PR310=$GET(^RCY(344.31,PR31IEN,0))
if PR310=""
QUIT
+23 SET PRTOTL=PRTOTL+1
SET X=$PIECE(PR310,U,4)
if X]""
SET ^RCY(344.31,"F",$EXTRACT(X,1,50),PR31IEN)=""
SET PRF=PRF+1
+24 ; TRACE # field (#.02), only numerics or leading zero
IF X]""
if X?.N!($EXTRACT(X)=0)
Begin DoDot:2
+25 ; strip extra leading zeroes
IF $EXTRACT(X)=0&($LENGTH(X)>2)
FOR
SET X=$EXTRACT(X,2,$LENGTH(X))
if $LENGTH(X)<2!'($EXTRACT(X)=0)
QUIT
+26 if X]""
SET ^RCY(344.31,"FNLZ",X_" ",PR31IEN)=""
SET PRFNLZ=PRFNLZ+1
End DoDot:2
+27 ;
+28 SET X=$PIECE(PR310,U,13)
if X]""
SET ^RCY(344.31,"ADR",X,PR31IEN)=""
SET PRADR=PRADR+1
+29 SET ^XTMP($TEXT(+0),PRNODE,"LAST")=PR31IEN
End DoDot:1
+30 ;
+31 ; disable 'D' new-style cross-ref., replaced by traditional 'F' cross-ref.
+32 IF '$GET(^XTMP($TEXT(+0),PRNODE,"FINISHED"))
if $DATA(^RCY(344.31,"D"))
Begin DoDot:1
+33 ; error root, message root
NEW PRDIERR,PRDIMSG
+34 ; supported FileMan database server API
DO DELIXN^DDMOD(344.31,"D","KW","PRDIMSG","PRDIERR")
End DoDot:1
+35 ;
+36 SET PRNODE("END")=$$NOW^XLFDT
+37 IF '$GET(^XTMP($TEXT(+0),PRNODE,"FINISHED"))
SET ^("FINISHED")=PRNODE("END")
+38 ; create MailMan message text
+39 SET PRXMBODY(0)=0
+40 DO ADD2TXT(.PRXMBODY,"Updated cross-references for file #344.31")
+41 DO ADD2TXT(.PRXMBODY," Work begun: "_$$FMTE^XLFDT(PRNODE("BEG")))
+42 DO ADD2TXT(.PRXMBODY," Work ended: "_$$FMTE^XLFDT(PRNODE("END")))
+43 ; blank line
DO ADD2TXT(.PRXMBODY," ")
+44 DO ADD2TXT(.PRXMBODY," Total Entries examined: "_$FNUMBER(PRTOTL,","))
+45 ; blank line
DO ADD2TXT(.PRXMBODY," ")
+46 DO ADD2TXT(.PRXMBODY," 'F' cross-ref. total: "_$FNUMBER(PRF,","))
+47 DO ADD2TXT(.PRXMBODY," 'FNLZ' cross-ref. total: "_$FNUMBER(PRFNLZ,","))
+48 DO ADD2TXT(.PRXMBODY," 'ADR' cross-ref. total: "_$FNUMBER(PRADR,","))
+49 ; blank line
DO ADD2TXT(.PRXMBODY," ")
+50 IF $GET(ZTSK)
DO ADD2TXT(.PRXMBODY," * Queued as Task #"_ZTSK_" *")
+51 DO ADD2TXT(.PRXMBODY,"Report generated by the "_$TEXT(+0)_" post-initialization routine.")
+52 ;
+53 ; save MailMan message text
+54 MERGE ^XTMP($TEXT(+0),PRNODE,"MAIL MSG",$$NOW^XLFDT)=PRXMBODY
+55 ; send report via MailMan
+56 SET XMINSTR("FROM")="POSTMASTER"
+57 SET PRXMSUBJ="PRCA*4.5*298 file #344.31 post-init completed"
+58 ; POSTMASTER and user who queued it
SET PRXMTO(.5)=""
SET PRXMTO(DUZ)=""
+59 SET PRXMTO("G.RCDPE PAYMENTS MGMT")=""
+60 ;
+61 ; send message
DO SENDMSG^XMXAPI(DUZ,PRXMSUBJ,"PRXMBODY",.PRXMTO,.XMINSTR,.PRXMZR)
+62 IF $GET(PRXMZR)
IF '$GET(ZTSK)
IF $EXTRACT(IOST,1,2)="C-"
DO MES^XPDUTL("MailMan message number: "_PRXMZR)
+63 ;
+64 QUIT
+65 ;
ADD2TXT(TXARY,LN) ; add LN to TXARY for MailMan Message
+1 ; TXARY passed by ref.
+2 if $GET(LN)=""
QUIT
+3 SET TXARY(0)=$GET(TXARY(0))+1
SET TXARY(TXARY(0),0)=LN
QUIT
+4 ;
+5 ; function, returns uppercase
UP(T) QUIT $TRANSLATE(T,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+1 ;
