RC45P303 ;ALB/TJB - POST-INSTALL PRCA*4.5*303 ;02-APR-15
;;4.5;Accounts Receivable;**303**;Mar 20, 1995;Build 84
;;Per VA Directive 6402, this routine should not be modified.
;
;
POST ;This will rename two options and Reindex 344.4 for the updated indexes
N ERROR
;
D BMES^XPDUTL(" Post-install for PRCA*4.5*303 Starting.")
;
D RNAME ; Rename Options
D RIDX ; Index updates to File 344.4
D SUBSC ; Subscribe the server process to the G.CARC_RARC_DATA group
D REMDIC1 ; Remove the RC MESSAGE TEXT OBJECT file and data
D REMDIC2 ; Remove the RC MESSAGE TESTING USER PREFERENCE file and data
;
D BMES^XPDUTL(" Post-install for PRCA*4.5*303 Complete.")
;
Q
;
RNAME ; Rename ^DIC(19) options for ePayments
; RCDPE EDI LOCKBOX MENU^EDI Lockbox (ePayments)
; RCDPE EDI LOCKBOX REPORTS MENU^EDI Lockbox (ePayments) Reports Menu
N IEN,RCFDA,RCERR
D MES^XPDUTL(" >> Renaming Options entries for EDI LOCKBOX ...")
S IEN="",IEN=$O(^DIC(19,"B","RCDPE EDI LOCKBOX MENU",IEN))
I +IEN'>0 S ERROR=1 D MES^XPDUTL(" >> ERROR: Renaming Options entries for EDI LOCKBOX MENU ...") Q
; Now update the 1 "MENU TEXT" field for this IEN
S RCFDA(19,IEN_",",1)="EDI Lockbox (ePayments)"
D FILE^DIE("","RCFDA","RCERR")
;
S IEN="",IEN=$O(^DIC(19,"B","RCDPE EDI LOCKBOX REPORTS MENU",IEN))
I +IEN'>0 S ERROR=1 D MES^XPDUTL(" >> ERROR: Renaming Options entries for EDI LOCKBOX REPORTS MENU ...") Q
; Now update the 1 "MENU TEXT" field for this IEN
S RCFDA(19,IEN_",",1)="EDI Lockbox (ePayments) Reports Menu"
D FILE^DIE("","RCFDA","RCERR")
;
RNAMEQ ;
D MES^XPDUTL(" >> Completed Renaming Options entries for EDI LOCKBOX ...")
Q
;
RIDX ; Index ^RCY(344.4) for the new index on field .03 (INSURANCE CO ID)
;
N DIK
D MES^XPDUTL(" >> Removing old ""I"" xref for file 344.4 ...")
K ^RCY(344.4,"I") ; Remove index
D MES^XPDUTL(" >> Rebuilding ""I"" xref for file 344.4 ...")
; Now index the Payer TINs
S DIK(1)=".03^I",DIK="^RCY(344.4," D ENALL^DIK
D MES^XPDUTL(" >> Completed Rebuilding ""I"" xref for file 344.4 ...")
Q
;
SUBSC ; Subscribe the server process to the G.CARC_RARC_DATA group
N DOMAIN,NUM,ADDR,ADDR2,ZZ,RCOUT
D MES^XPDUTL(" >> Adding Server Option to Mail group CARC_RARC_DATA ...")
S NUM=$P($G(^XMB(1,1,0)),U,1) ; Get IEN for lookup in DOMAIN (^DIC(4.2)) File
I NUM="" S ERROR=1 D MES^XPDUTL(" >> ERROR: Getting pointer to Domain Name from Mailman Parameters file...") Q
S DOMAIN=$P($G(^DIC(4.2,NUM,0)),U,1)
I DOMAIN="" S ERROR=1 D MES^XPDUTL(" >> ERROR: Getting Domain Name from DOMAIN (#4.2) file...") Q
S ADDR="S.RCDPE EDI CARC-RARC SERVER@"_DOMAIN
;S ADDR2="vhaepayments@domain.ext" ; Messages generated by the server process needs to go to this address.
; Subscribe address to CARC_RARC_DATA group
S NUM=$$FIND1^DIC(3.8,"","MX","CARC_RARC_DATA","","","RCOUT")
I NUM=0 S ERROR=1 D MES^XPDUTL(" >> ERROR: Getting IEN for CARC_RARC_DATA mail group...") Q
I $P($G(^XMB(3.8,NUM,0)),U,1)'="CARC_RARC_DATA" S ERROR=1 D MES^XPDUTL(" >> ERROR: .01 field of IEN: "_NUM_" Did not match CARC_RARC_DATA ...") Q
; Update "MEMBERS - REMOTE SUB-FIELD" File #3.812 in Mail Group file #3.8
; See if any existing users are this ADDR
I $$CHKADDR(NUM,ADDR) D MES^XPDUTL(" >> Server Option already subscribed to Mail group CARC_RARC_DATA ...") Q
; Add user to group
S ZZ(1,3.812,"+2,"_NUM_",",.01)=ADDR
D UPDATE^DIE("","ZZ(1)")
D MES^XPDUTL(" >> Completed Adding Server Option to Mail group CARC_RARC_DATA ...")
;
Q
;
CHKADDR(CIEN,CADD) ; See if the address already exists for this entry
N RCMEM,RCERROR,CZ,COK
S COK=0
D GETS^DIQ(3.8,CIEN_",","12*","I","RCMEM","RCERROR")
; Walk the returned array
Q:$D(RCMEM)<10 0 ; Nothing in RCMEM return 0
S CZ="" F S CZ=$O(RCMEM("3.812",CZ)) Q:CZ="" I RCMEM("3.812",CZ,.01,"I")=CADD S COK=1 Q ; Found the address so no need to add it
Q COK
;
REMDIC1 ;
; Remove the RC MESSAGE TEXT OBJECT file and data
;
; Check the volume set and do not delete for the following test accounts
; %ZOSF - ICR 10096
N VOL S VOL=^%ZOSF("PROD")
I VOL="CARVDD"!(VOL="SUPVBB")!(VOL="CHEYL140")!(VOL="CHEYL141")!(VOL="CHEYL185") Q
;
D BMES^XPDUTL(" >> Delete the RC MESSAGE TEXT OBJECT file")
I '$D(^RCY(344.81)),'$D(^DIC(344.81)) D MES^XPDUTL(" Already Deleted") Q
N DIU
S DIU=344.81,DIU(0)="D"
D EN^DIU2
D MES^XPDUTL(" >> Completed")
Q
;
REMDIC2 ;
; Remove the RC MESSAGE TESTING USER PREFERENCE file and data
;
; Check the volume set and do not delete for the following test accounts
; %ZOSF - ICR 10096
N VOL S VOL=^%ZOSF("PROD")
I VOL="CARVDD"!(VOL="SUPVBB")!(VOL="CHEYL140")!(VOL="CHEYL141")!(VOL="CHEYL185") Q
;
D BMES^XPDUTL(" >> Delete the RC TESTING USER PREFERENCES file")
I '$D(^RCY(344.82)),'$D(^DIC(344.82)) D MES^XPDUTL(" Already Deleted") Q
N DIU
S DIU=344.82,DIU(0)="D"
D EN^DIU2
D MES^XPDUTL(" >> Completed")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRC45P303 5026 printed Dec 13, 2024@01:42:17 Page 2
RC45P303 ;ALB/TJB - POST-INSTALL PRCA*4.5*303 ;02-APR-15
+1 ;;4.5;Accounts Receivable;**303**;Mar 20, 1995;Build 84
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;
POST ;This will rename two options and Reindex 344.4 for the updated indexes
+1 NEW ERROR
+2 ;
+3 DO BMES^XPDUTL(" Post-install for PRCA*4.5*303 Starting.")
+4 ;
+5 ; Rename Options
DO RNAME
+6 ; Index updates to File 344.4
DO RIDX
+7 ; Subscribe the server process to the G.CARC_RARC_DATA group
DO SUBSC
+8 ; Remove the RC MESSAGE TEXT OBJECT file and data
DO REMDIC1
+9 ; Remove the RC MESSAGE TESTING USER PREFERENCE file and data
DO REMDIC2
+10 ;
+11 DO BMES^XPDUTL(" Post-install for PRCA*4.5*303 Complete.")
+12 ;
+13 QUIT
+14 ;
RNAME ; Rename ^DIC(19) options for ePayments
+1 ; RCDPE EDI LOCKBOX MENU^EDI Lockbox (ePayments)
+2 ; RCDPE EDI LOCKBOX REPORTS MENU^EDI Lockbox (ePayments) Reports Menu
+3 NEW IEN,RCFDA,RCERR
+4 DO MES^XPDUTL(" >> Renaming Options entries for EDI LOCKBOX ...")
+5 SET IEN=""
SET IEN=$ORDER(^DIC(19,"B","RCDPE EDI LOCKBOX MENU",IEN))
+6 IF +IEN'>0
SET ERROR=1
DO MES^XPDUTL(" >> ERROR: Renaming Options entries for EDI LOCKBOX MENU ...")
QUIT
+7 ; Now update the 1 "MENU TEXT" field for this IEN
+8 SET RCFDA(19,IEN_",",1)="EDI Lockbox (ePayments)"
+9 DO FILE^DIE("","RCFDA","RCERR")
+10 ;
+11 SET IEN=""
SET IEN=$ORDER(^DIC(19,"B","RCDPE EDI LOCKBOX REPORTS MENU",IEN))
+12 IF +IEN'>0
SET ERROR=1
DO MES^XPDUTL(" >> ERROR: Renaming Options entries for EDI LOCKBOX REPORTS MENU ...")
QUIT
+13 ; Now update the 1 "MENU TEXT" field for this IEN
+14 SET RCFDA(19,IEN_",",1)="EDI Lockbox (ePayments) Reports Menu"
+15 DO FILE^DIE("","RCFDA","RCERR")
+16 ;
RNAMEQ ;
+1 DO MES^XPDUTL(" >> Completed Renaming Options entries for EDI LOCKBOX ...")
+2 QUIT
+3 ;
RIDX ; Index ^RCY(344.4) for the new index on field .03 (INSURANCE CO ID)
+1 ;
+2 NEW DIK
+3 DO MES^XPDUTL(" >> Removing old ""I"" xref for file 344.4 ...")
+4 ; Remove index
KILL ^RCY(344.4,"I")
+5 DO MES^XPDUTL(" >> Rebuilding ""I"" xref for file 344.4 ...")
+6 ; Now index the Payer TINs
+7 SET DIK(1)=".03^I"
SET DIK="^RCY(344.4,"
DO ENALL^DIK
+8 DO MES^XPDUTL(" >> Completed Rebuilding ""I"" xref for file 344.4 ...")
+9 QUIT
+10 ;
SUBSC ; Subscribe the server process to the G.CARC_RARC_DATA group
+1 NEW DOMAIN,NUM,ADDR,ADDR2,ZZ,RCOUT
+2 DO MES^XPDUTL(" >> Adding Server Option to Mail group CARC_RARC_DATA ...")
+3 ; Get IEN for lookup in DOMAIN (^DIC(4.2)) File
SET NUM=$PIECE($GET(^XMB(1,1,0)),U,1)
+4 IF NUM=""
SET ERROR=1
DO MES^XPDUTL(" >> ERROR: Getting pointer to Domain Name from Mailman Parameters file...")
QUIT
+5 SET DOMAIN=$PIECE($GET(^DIC(4.2,NUM,0)),U,1)
+6 IF DOMAIN=""
SET ERROR=1
DO MES^XPDUTL(" >> ERROR: Getting Domain Name from DOMAIN (#4.2) file...")
QUIT
+7 SET ADDR="S.RCDPE EDI CARC-RARC SERVER@"_DOMAIN
+8 ;S ADDR2="vhaepayments@domain.ext" ; Messages generated by the server process needs to go to this address.
+9 ; Subscribe address to CARC_RARC_DATA group
+10 SET NUM=$$FIND1^DIC(3.8,"","MX","CARC_RARC_DATA","","","RCOUT")
+11 IF NUM=0
SET ERROR=1
DO MES^XPDUTL(" >> ERROR: Getting IEN for CARC_RARC_DATA mail group...")
QUIT
+12 IF $PIECE($GET(^XMB(3.8,NUM,0)),U,1)'="CARC_RARC_DATA"
SET ERROR=1
DO MES^XPDUTL(" >> ERROR: .01 field of IEN: "_NUM_" Did not match CARC_RARC_DATA ...")
QUIT
+13 ; Update "MEMBERS - REMOTE SUB-FIELD" File #3.812 in Mail Group file #3.8
+14 ; See if any existing users are this ADDR
+15 IF $$CHKADDR(NUM,ADDR)
DO MES^XPDUTL(" >> Server Option already subscribed to Mail group CARC_RARC_DATA ...")
QUIT
+16 ; Add user to group
+17 SET ZZ(1,3.812,"+2,"_NUM_",",.01)=ADDR
+18 DO UPDATE^DIE("","ZZ(1)")
+19 DO MES^XPDUTL(" >> Completed Adding Server Option to Mail group CARC_RARC_DATA ...")
+20 ;
+21 QUIT
+22 ;
CHKADDR(CIEN,CADD) ; See if the address already exists for this entry
+1 NEW RCMEM,RCERROR,CZ,COK
+2 SET COK=0
+3 DO GETS^DIQ(3.8,CIEN_",","12*","I","RCMEM","RCERROR")
+4 ; Walk the returned array
+5 ; Nothing in RCMEM return 0
if $DATA(RCMEM)<10
QUIT 0
+6 ; Found the address so no need to add it
SET CZ=""
FOR
SET CZ=$ORDER(RCMEM("3.812",CZ))
if CZ=""
QUIT
IF RCMEM("3.812",CZ,.01,"I")=CADD
SET COK=1
QUIT
+7 QUIT COK
+8 ;
REMDIC1 ;
+1 ; Remove the RC MESSAGE TEXT OBJECT file and data
+2 ;
+3 ; Check the volume set and do not delete for the following test accounts
+4 ; %ZOSF - ICR 10096
+5 NEW VOL
SET VOL=^%ZOSF("PROD")
+6 IF VOL="CARVDD"!(VOL="SUPVBB")!(VOL="CHEYL140")!(VOL="CHEYL141")!(VOL="CHEYL185")
QUIT
+7 ;
+8 DO BMES^XPDUTL(" >> Delete the RC MESSAGE TEXT OBJECT file")
+9 IF '$DATA(^RCY(344.81))
IF '$DATA(^DIC(344.81))
DO MES^XPDUTL(" Already Deleted")
QUIT
+10 NEW DIU
+11 SET DIU=344.81
SET DIU(0)="D"
+12 DO EN^DIU2
+13 DO MES^XPDUTL(" >> Completed")
+14 QUIT
+15 ;
REMDIC2 ;
+1 ; Remove the RC MESSAGE TESTING USER PREFERENCE file and data
+2 ;
+3 ; Check the volume set and do not delete for the following test accounts
+4 ; %ZOSF - ICR 10096
+5 NEW VOL
SET VOL=^%ZOSF("PROD")
+6 IF VOL="CARVDD"!(VOL="SUPVBB")!(VOL="CHEYL140")!(VOL="CHEYL141")!(VOL="CHEYL185")
QUIT
+7 ;
+8 DO BMES^XPDUTL(" >> Delete the RC TESTING USER PREFERENCES file")
+9 IF '$DATA(^RCY(344.82))
IF '$DATA(^DIC(344.82))
DO MES^XPDUTL(" Already Deleted")
QUIT
+10 NEW DIU
+11 SET DIU=344.82
SET DIU(0)="D"
+12 DO EN^DIU2
+13 DO MES^XPDUTL(" >> Completed")
+14 QUIT
