PRCA447P ;MNTVBB/KXL - Disable AR CBO Extract ;04/14/25
;;4.5;Accounts Receivable;**447**;Mar 20, 1995;Build 4
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference to FIND1^DIC in ICR #2051
; Reference to FILE^DIE in ICR #10018
; Reference to ^DIK in ICR #10013
; Reference to FMADD^XLFDT in ICR #10103
; Reference to BMES^XPDUTL in ICR #10141
; Reference to MES^XPDUTL in ICR #10141
; Reference to LKOPT^XPDMENU in ICR #1157
; Reference to OUT^XPDMENU in ICR #1157
;
;
Q
;
EN ; Backup files
;
;AR DATA QUEUE file ^RCXV (#348.4)
;ACCOUNTS RECEIVABLE TRANS.TYPE FILE ^PRCA (#430.3)
;
N P447FILE,P447FILES,PRCAA,PRCACNT
S P447FILE=""
S P447FILES="348.4^430.3"
S PRCACNT=0
F PRCACNT=1:1:$L(P447FILES,"^") D
. S P447FILE=$P(P447FILES,"^",PRCACNT)
. D GLBBKUP
. Q
; Begin Update
D POST
Q
;
POST ; Disable CBO extract and associated objects
N U S U="^"
D MSG("PRCA*4.5*447 Post-Install starts.....")
D ARPAR
D MENU
D QUEUE
D TRANSTYP
D TSK
D MSG(" ")
D MSG("PRCA*4.5*447 Post-Install is complete.")
Q
;
ARPAR ; Set CBO STATUS = 0 in AR Site Param file (#342)
;
N PRCAUP
S PRCAUP(342,"1,",20.04)=0
D FILE^DIE("E","PRCAUP","ERROR")
D BMES^XPDUTL("FILE 342 CBO STATUS set to OFF")
Q
;
QUEUE ; Purge AR Data Queue
;AR DATA QUEUE file (#348.4)
N DA,DIK
S DIK="^RCXV("
S DA=0
F S DA=$O(^RCXV(DA)) Q:DA=""!(DA?.A) D
. D ^DIK
D BMES^XPDUTL("AR Data Queue File (#348.4) purge completed")
Q
;
TRANSTYP ; Set CBO flag = 0 if currently set = 1
;ACCOUNTS RECEIVABLE TRANS.TYPE FILE (#430.3)
N PRCACBO,PRCAIEN,PRCAND
S PRCAIEN=0
F S PRCAIEN=$O(^PRCA(430.3,PRCAIEN)) Q:PRCAIEN=""!(PRCAIEN?.A) D
. S PRCAND=^PRCA(430.3,PRCAIEN,0)
. S PRCACBO=$P(PRCAND,U,6)
. I PRCACBO=1 S PRCAUP(430.3,PRCAIEN_",",5)=0
D FILE^DIE("I","PRCAUP","PRCAERR")
D BMES^XPDUTL("ACCOUNTS RECEIVABLE TRANS.TYPE FILE (#430.3) updated")
Q
;
TSK ; Remove task from OPTION SCHEDULING file (#19.2)
N DA,DIK
D BMES^XPDUTL("Checking if List of NPI data for CBO is tasked")
S DA=$$FIND1^DIC(19.2,"","","XUS NPI CBO LIST") I DA>0 D Q
. S ^XTMP("PRCA447P",$J,0)=$$FMADD^XLFDT(DT+90)_"^"_DT_"^copy of CBO Task^"_DA
. M ^XTMP("PRCA447P",19.2,$H,DA)=^DIC(19.2,DA)
. S DIK="^DIC(19.2," D ^DIK
. D BMES^XPDUTL("Task removed")
D BMES^XPDUTL("Not tasked, no action needed")
Q
;
MSG(PRCAA) ;
D MES^XPDUTL(PRCAA)
Q
;
GLBBKUP ; XTMP Backup of file(s)
N PRCABKND
S PRCABKND="PRCA*4.5*477-Disable CBO file updates (#348.4,430.3)"
S ^XTMP("PRCA447P",0)=$$FMADD^XLFDT(DT,120)_"^"_DT_"^"_PRCABKND
I P447FILE=348.4 M ^XTMP("PRCA447P",P447FILE,$H)=^RCXV Q
M ^XTMP("PRCA447P",P447FILE,$H)=^PRCA(P447FILE)
Q
;
;
N PRCAI,PRCAM,PRCAO
S PRCAO="Option placed out of order with patch PRCA*4.5*447"
F PRCAI=1:1 S PRCAM=$P($T(OPTS+PRCAI),";;",2) Q:PRCAM="" D
.N PRCAY S PRCAY=$$FIND1(PRCAM) I PRCAY<0 D BMES^XPDUTL("Option: "_PRCAM_" was not found!") Q
.D OUT^XPDMENU(PRCAM,PRCAO)
.D BMES^XPDUTL("Option: "_PRCAM_" placed out of order")
.Q
Q
;
FIND1(PRCAX) ;find the option IEN based on the option name
;Input: PRCAX = option name
;Return: IEN option name; else -1
N PRCAERR,Y
S Y=$$LKOPT^XPDMENU(PRCAX)
Q $S(Y="":-1,1:Y)
;
OPTS ;menu options to make out of order
;;PRCA CBO PARAMETERS
;;RCXVSRV
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCA447P 3410 printed Sep 23, 2025@19:14:51 Page 2
PRCA447P ;MNTVBB/KXL - Disable AR CBO Extract ;04/14/25
+1 ;;4.5;Accounts Receivable;**447**;Mar 20, 1995;Build 4
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to FIND1^DIC in ICR #2051
+5 ; Reference to FILE^DIE in ICR #10018
+6 ; Reference to ^DIK in ICR #10013
+7 ; Reference to FMADD^XLFDT in ICR #10103
+8 ; Reference to BMES^XPDUTL in ICR #10141
+9 ; Reference to MES^XPDUTL in ICR #10141
+10 ; Reference to LKOPT^XPDMENU in ICR #1157
+11 ; Reference to OUT^XPDMENU in ICR #1157
+12 ;
+13 ;
+14 QUIT
+15 ;
EN ; Backup files
+1 ;
+2 ;AR DATA QUEUE file ^RCXV (#348.4)
+3 ;ACCOUNTS RECEIVABLE TRANS.TYPE FILE ^PRCA (#430.3)
+4 ;
+5 NEW P447FILE,P447FILES,PRCAA,PRCACNT
+6 SET P447FILE=""
+7 SET P447FILES="348.4^430.3"
+8 SET PRCACNT=0
+9 FOR PRCACNT=1:1:$LENGTH(P447FILES,"^")
Begin DoDot:1
+10 SET P447FILE=$PIECE(P447FILES,"^",PRCACNT)
+11 DO GLBBKUP
+12 QUIT
End DoDot:1
+13 ; Begin Update
+14 DO POST
+15 QUIT
+16 ;
POST ; Disable CBO extract and associated objects
+1 NEW U
SET U="^"
+2 DO MSG("PRCA*4.5*447 Post-Install starts.....")
+3 DO ARPAR
+4 DO MENU
+5 DO QUEUE
+6 DO TRANSTYP
+7 DO TSK
+8 DO MSG(" ")
+9 DO MSG("PRCA*4.5*447 Post-Install is complete.")
+10 QUIT
+11 ;
ARPAR ; Set CBO STATUS = 0 in AR Site Param file (#342)
+1 ;
+2 NEW PRCAUP
+3 SET PRCAUP(342,"1,",20.04)=0
+4 DO FILE^DIE("E","PRCAUP","ERROR")
+5 DO BMES^XPDUTL("FILE 342 CBO STATUS set to OFF")
+6 QUIT
+7 ;
QUEUE ; Purge AR Data Queue
+1 ;AR DATA QUEUE file (#348.4)
+2 NEW DA,DIK
+3 SET DIK="^RCXV("
+4 SET DA=0
+5 FOR
SET DA=$ORDER(^RCXV(DA))
if DA=""!(DA?.A)
QUIT
Begin DoDot:1
+6 DO ^DIK
End DoDot:1
+7 DO BMES^XPDUTL("AR Data Queue File (#348.4) purge completed")
+8 QUIT
+9 ;
TRANSTYP ; Set CBO flag = 0 if currently set = 1
+1 ;ACCOUNTS RECEIVABLE TRANS.TYPE FILE (#430.3)
+2 NEW PRCACBO,PRCAIEN,PRCAND
+3 SET PRCAIEN=0
+4 FOR
SET PRCAIEN=$ORDER(^PRCA(430.3,PRCAIEN))
if PRCAIEN=""!(PRCAIEN?.A)
QUIT
Begin DoDot:1
+5 SET PRCAND=^PRCA(430.3,PRCAIEN,0)
+6 SET PRCACBO=$PIECE(PRCAND,U,6)
+7 IF PRCACBO=1
SET PRCAUP(430.3,PRCAIEN_",",5)=0
End DoDot:1
+8 DO FILE^DIE("I","PRCAUP","PRCAERR")
+9 DO BMES^XPDUTL("ACCOUNTS RECEIVABLE TRANS.TYPE FILE (#430.3) updated")
+10 QUIT
+11 ;
TSK ; Remove task from OPTION SCHEDULING file (#19.2)
+1 NEW DA,DIK
+2 DO BMES^XPDUTL("Checking if List of NPI data for CBO is tasked")
+3 SET DA=$$FIND1^DIC(19.2,"","","XUS NPI CBO LIST")
IF DA>0
Begin DoDot:1
+4 SET ^XTMP("PRCA447P",$JOB,0)=$$FMADD^XLFDT(DT+90)_"^"_DT_"^copy of CBO Task^"_DA
+5 MERGE ^XTMP("PRCA447P",19.2,$HOROLOG,DA)=^DIC(19.2,DA)
+6 SET DIK="^DIC(19.2,"
DO ^DIK
+7 DO BMES^XPDUTL("Task removed")
End DoDot:1
QUIT
+8 DO BMES^XPDUTL("Not tasked, no action needed")
+9 QUIT
+10 ;
MSG(PRCAA) ;
+1 DO MES^XPDUTL(PRCAA)
+2 QUIT
+3 ;
GLBBKUP ; XTMP Backup of file(s)
+1 NEW PRCABKND
+2 SET PRCABKND="PRCA*4.5*477-Disable CBO file updates (#348.4,430.3)"
+3 SET ^XTMP("PRCA447P",0)=$$FMADD^XLFDT(DT,120)_"^"_DT_"^"_PRCABKND
+4 IF P447FILE=348.4
MERGE ^XTMP("PRCA447P",P447FILE,$HOROLOG)=^RCXV
QUIT
+5 MERGE ^XTMP("PRCA447P",P447FILE,$HOROLOG)=^PRCA(P447FILE)
+6 QUIT
+7 ;
+1 ;
+2 NEW PRCAI,PRCAM,PRCAO
+3 SET PRCAO="Option placed out of order with patch PRCA*4.5*447"
+4 FOR PRCAI=1:1
SET PRCAM=$PIECE($TEXT(OPTS+PRCAI),";;",2)
if PRCAM=""
QUIT
Begin DoDot:1
+5 NEW PRCAY
SET PRCAY=$$FIND1(PRCAM)
IF PRCAY<0
DO BMES^XPDUTL("Option: "_PRCAM_" was not found!")
QUIT
+6 DO OUT^XPDMENU(PRCAM,PRCAO)
+7 DO BMES^XPDUTL("Option: "_PRCAM_" placed out of order")
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
FIND1(PRCAX) ;find the option IEN based on the option name
+1 ;Input: PRCAX = option name
+2 ;Return: IEN option name; else -1
+3 NEW PRCAERR,Y
+4 SET Y=$$LKOPT^XPDMENU(PRCAX)
+5 QUIT $SELECT(Y="":-1,1:Y)
+6 ;
OPTS ;menu options to make out of order
+1 ;;PRCA CBO PARAMETERS
+2 ;;RCXVSRV
