PRCA315P ;SLT/BAA-PRCA*4.5*315 POST INSTALL ;1 Mar 97
;;4.5;Accounts Receivable;**315**;Mar 20, 1995;Build 67
;;Per VA Directive 6402, this routine should not be modified.
POSTINIT ;
;
D BMES^XPDUTL(" >> Starting the Post-Initialization routine ...")
D MES^XPDUTL(" ")
; AR CATEGORIES
D ARCAT
D REVSC
D DELOPT
D CRSSVC
D CSJOB
D MES^XPDUTL(" >> End of the Post-Initialization routine ...")
Q
;
;
ARCAT ;AR CATEGORY ENTRIES (430.2)
N %,ARNAME,D,D0,DA,DI,DIC,DIE,DIK,DINUM,DLAYGO,DQ,DR,RCDATA,RCDINUM,X,Y,FLG,RCS
D MES^XPDUTL(" -> Adding new ACCOUNTS RECEIVABLE CATEGORY file (#430.2) entries ...")
;
; install entries in file 430.2
S FLG=0
F RCDINUM=46,47 D
. S RCS="CT"_RCDINUM
. S RCDATA=$P($T(@RCS),";",3,99)
. S (DIC,DIE)="^PRCA(430.2,",DIC(0)="L",DLAYGO=430.2
. ;
. S ARNAME=$P(RCDATA,";")
. ;
. I $D(^PRCA(430.2,RCDINUM,0)) S DIK="^PRCA(430.2,",DA=RCDINUM D ^DIK
. ;
. S (DIC,DIE)="^PRCA(430.2,",DIC(0)="L",DLAYGO=430.2
. ;
. ; set the fields
. S (DINUM,DA)=RCDINUM,X=ARNAME
. S DIC("DR")="1///"_$P(RCDATA,";",2)_";2///"_$P(RCDATA,";",3)_";3///"_$P(RCDATA,";",6)_";5///"_$P(RCDATA,";",5)_";6///"_$P(RCDATA,";",4)
. S DIC("DR")=DIC("DR")_";7///2;9///0;10///0;11///0;12///"_$P(RCDATA,";",7)_";13///2;"
. ; add entry
. S X=ARNAME D FILE^DICN K DIC I Y<1 K X,Y Q
. D MES^XPDUTL(" New Category "_ARNAME_" added") S FLG=1
;
I FLG D MES^XPDUTL(" New ACCOUNTS RECEIVABLE CATEGORY file (#430.2) entries added")
D MES^XPDUTL(" ")
Q
;
;
REVSC ;REVENUE SOURCE CODE entries in file #347.3
N I,RSCDATA,DIC,Y,GBL,DA,X,DIE,DR
D MES^XPDUTL(" -> Adding new REVENUE SOURCE CODE file (#347.3) entries ...")
S GBL="^RC(347.3,"
F I=1:1 D Q:RSCDATA="END"
. S RSCDATA=$P($T(NEWRSC+I),";",3,99)
. Q:RSCDATA="END"
. ; do a lookup and continue if exists.
. S DIC=GBL,X=$P(RSCDATA,";") D ^DIC
. I +Y>0 S DIK=GBL,DA=+Y D ^DIK
. ; add entry
. S X=$P(RSCDATA,";")
. S DIC("DR")=".02///"_$P(RSCDATA,";",2)_";",DIC(0)="L"
. S DIC("DR")=DIC("DR")_".03///0;"
. D FILE^DICN
. I +Y=-1 D
. . D MES^XPDUTL(" "_$P(RSCDATA,";")_" failed to add!")
D MES^XPDUTL(" New REVENUE SOURCE CODE file (#347.3) entries added")
Q
;
;
DELOPT ; remove PRCAC SET REPAYMENT option
N DA,DIK,MEN,OPT,RET
; RET - value returned from
S MEN="PRCAC REPAYMENT MENU"
S DA(1)=+$$LKOPT^XPDMENU(MEN)
S OPT="PRCAC SET REPAYMENT"
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."))
S OPT="PRCAC ENTER EDIT REPAYMENT"
S DA=+$$LKOPT^XPDMENU(OPT) ; get option IEN
I $D(^DIC(19,DA(1),10,"B",DA)) Q ; Option already added
D ADD^XPDMENU(MEN,OPT,"",1) ; Set Enter/Edit Repayment as the first item in Repayment Menu
Q
;
N DA,DIK,MEN,OPT,RET
; RET - value returned from
S MEN="RCTCSP MENU"
S DA(1)=+$$LKOPT^XPDMENU(MEN)
D BMES^XPDUTL(" -> Updating ["_MEN_"]")
F OPT="RCTCSP RECONCILIATION WORKLIST","RCTCSP RECONCIL REPORT" D
. K RET S RET=$$DELETE^XPDMENU(MEN,OPT) ; delete option from menu
. S DA=+$$LKOPT^XPDMENU(OPT) ; get option IEN
. D MES^XPDUTL(" Menu update to option: "_OPT_" "_$S(RET:"completed.",1:"not needed."))
. I $D(^DIC(19,DA(1),10,"B",DA)) Q ; Option already added
. D ADD^XPDMENU(MEN,OPT,"")
Q
;
CSJOB ;Job the process to build the new Cross-Servicing data fields.
N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSK
;
D BMES^XPDUTL(" -> Queuing background job to do the following:")
D MES^XPDUTL(" 1. Populate Cross-Servicing indices in ACCOUNTS RECEIVABLE file (#430)")
D MES^XPDUTL(" 2. Searching ACCOUNTS RECEIVABLE file (#430) for CS Stops placed")
D MES^XPDUTL(" prior to this patch in field STOP TCSP REFERRAL FLAG (#157).")
D MES^XPDUTL(" 3. Populate new field ORIGINAL DATE REFERRED TO TCSP (#156) in ACCOUNTS")
D MES^XPDUTL(" RECEIVABLE file (#430).")
D MES^XPDUTL(" ")
;
; Setup required variables
S ZTRTN="CSJOB1^PRCA315P",ZTIO="",ZTDTH=$H
S ZTDESC="Background job to build CS indices for PRCA*4.5*315"
;
; Task the job
D ^%ZTLOAD
;
; Check if task was created
I $D(ZTSK) D MES^XPDUTL(" Task #"_ZTSK_" queued.")
I '$D(ZTSK) D MES^XPDUTL(" Task not queued. Please create a support ticket.")
D MES^XPDUTL(" ")
Q
;
CSJOB1 ;Populate new indices in #430
K ^TMP($J)
S DIK="^PRCA(430,",DIK(1)="172" D ENALL^DIK
S ^TMP($J,"PRCA315P",1)="FILE #430 FIELD #172 INDEX POPULATED"
S DIK="^PRCA(430,",DIK(1)="301" D ENALL^DIK
S ^TMP($J,"PRCA315P",2)="FILE #430 FIELD #301 INDEX POPULATED"
;
CSSTOP ;determine CS stops placed in 430 prior to Patch 315
N RCIEN,DEBTOR,BILL,CSDATE,LIST,MSG,GLO
N DIFROM,XMDUN,XMY,XMZ ; need to be newed or mailman will not deliver the message
S GLO=$NA(^TMP($J,"RCRJRCORMM"))
;
S @GLO@(1)="Bills currently flagged to stop TCSP referral activity prior"
S @GLO@(2)="to PRCA*4.5*315. These bills will not show on the new report:"
S @GLO@(3)="'Cross-Servicing Stop Reactivate Report'."
S @GLO@(4)=" "
S RCIEN=0 F S RCIEN=$O(^PRCA(430,RCIEN)) Q:'RCIEN D
. K LIST
. I $P($G(^PRCA(430,RCIEN,15)),U,7) D
.. D GETS^DIQ(430,RCIEN_",",".01;9;158","IE","LIST","MSG")
.. S BILL=$G(LIST(430,RCIEN_",",.01,"E")),DEBTOR=$G(LIST(430,RCIEN_",",9,"E")),CSDATE=$G(LIST(430,RCIEN_",",158,"E"))
.. S @GLO@(RCIEN)=BILL_U_DEBTOR_U_CSDATE
. ;Load date into field #156, ORIGINAL DATE REFERRED TO TCSP
. I $G(^PRCA(439,RCIEN,21)) Q
. D GETS^DIQ(430,RCIEN_",","151;153;158","I","LIST","MSG")
. F I=151,153,158 I LIST(430,RCIEN_",",I,"I")?7N S ^PRCA(430,RCIEN,21)=LIST(430,RCIEN_",",I,"I") Q
S ^TMP($J,"PRCA315P",3)="BILLS CURRENTLY FLAGGED TO STOP TCSP REPORT CREATED"
S ^TMP($J,"PRCA315P",4)="FILE #430 FIELD #156 VALUES POPULATED"
S XMDUZ=.5,XMY(.5)="",XMY(DUZ)="",XMY("G.TCSP")=""
S XMZ=$$SENDMSG^RCRJRCOR("STOP TCSP REFERRAL's existing before PRCA*4.5*315",.XMY)
K ^TMP($J,"RCRJRCORMM")
S ^TMP($J,"PRCA315P",5)="BILLS CURRENTLY FLAGGED TO STOP TCSP REPORT MAIL SENT"
;
N CNT,MSG,XMY,XMDUZ,DIFROM,XMSUB,XMTEXT
S XMY(DUZ)=""
S XMSUB="PRCA*4.5*315 Post install routine has completed",XMDUZ="Patch PRCA*4.5*315"
S XMTEXT="^TMP($J,""PRCA315P"","
D ^XMD
Q
;
;Revenue Source Codes (RSC#)//
NEWRSC ;SOURCE CODE;NAME
;;8VZZ;HUMAN 3RD-PRTY OUTPATIENT
;;8UZZ;HUMAN 3RD-PRTY INPATIENT
;;841Z;INELI 3RD-PARTY INPATIENT
;;842Z;INELI 3RD-PARTY OUTPATIENT
;;END
;
;
;;ACCOUNTS RECEIVABLE CATEGORY FILE (#430.2)
;;.01 CATEGORY;1 ABBREVIATION;6 CATEGORY NUMBER;7 ACCRUED
CT46 ;;EMERGENCY/HUMANITARIAN REIMB.;HR;252;48;T;1213;1
CT47 ;;INELIGIBLE HOSP. REIMB.;IR;251;49;T;1213;0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCA315P 7063 printed Sep 23, 2025@19:14:41 Page 2
PRCA315P ;SLT/BAA-PRCA*4.5*315 POST INSTALL ;1 Mar 97
+1 ;;4.5;Accounts Receivable;**315**;Mar 20, 1995;Build 67
+2 ;;Per VA Directive 6402, this routine should not be modified.
POSTINIT ;
+1 ;
+2 DO BMES^XPDUTL(" >> Starting the Post-Initialization routine ...")
+3 DO MES^XPDUTL(" ")
+4 ; AR CATEGORIES
+5 DO ARCAT
+6 DO REVSC
+7 DO DELOPT
+8 DO CRSSVC
+9 DO CSJOB
+10 DO MES^XPDUTL(" >> End of the Post-Initialization routine ...")
+11 QUIT
+12 ;
+13 ;
ARCAT ;AR CATEGORY ENTRIES (430.2)
+1 NEW %,ARNAME,D,D0,DA,DI,DIC,DIE,DIK,DINUM,DLAYGO,DQ,DR,RCDATA,RCDINUM,X,Y,FLG,RCS
+2 DO MES^XPDUTL(" -> Adding new ACCOUNTS RECEIVABLE CATEGORY file (#430.2) entries ...")
+3 ;
+4 ; install entries in file 430.2
+5 SET FLG=0
+6 FOR RCDINUM=46,47
Begin DoDot:1
+7 SET RCS="CT"_RCDINUM
+8 SET RCDATA=$PIECE($TEXT(@RCS),";",3,99)
+9 SET (DIC,DIE)="^PRCA(430.2,"
SET DIC(0)="L"
SET DLAYGO=430.2
+10 ;
+11 SET ARNAME=$PIECE(RCDATA,";")
+12 ;
+13 IF $DATA(^PRCA(430.2,RCDINUM,0))
SET DIK="^PRCA(430.2,"
SET DA=RCDINUM
DO ^DIK
+14 ;
+15 SET (DIC,DIE)="^PRCA(430.2,"
SET DIC(0)="L"
SET DLAYGO=430.2
+16 ;
+17 ; set the fields
+18 SET (DINUM,DA)=RCDINUM
SET X=ARNAME
+19 SET DIC("DR")="1///"_$PIECE(RCDATA,";",2)_";2///"_$PIECE(RCDATA,";",3)_";3///"_$PIECE(RCDATA,";",6)_";5///"_$PIECE(RCDATA,";",5)_";6///"_$PIECE(RCDATA,";",4)
+20 SET DIC("DR")=DIC("DR")_";7///2;9///0;10///0;11///0;12///"_$PIECE(RCDATA,";",7)_";13///2;"
+21 ; add entry
+22 SET X=ARNAME
DO FILE^DICN
KILL DIC
IF Y<1
KILL X,Y
QUIT
+23 DO MES^XPDUTL(" New Category "_ARNAME_" added")
SET FLG=1
End DoDot:1
+24 ;
+25 IF FLG
DO MES^XPDUTL(" New ACCOUNTS RECEIVABLE CATEGORY file (#430.2) entries added")
+26 DO MES^XPDUTL(" ")
+27 QUIT
+28 ;
+29 ;
REVSC ;REVENUE SOURCE CODE entries in file #347.3
+1 NEW I,RSCDATA,DIC,Y,GBL,DA,X,DIE,DR
+2 DO MES^XPDUTL(" -> Adding new REVENUE SOURCE CODE file (#347.3) entries ...")
+3 SET GBL="^RC(347.3,"
+4 FOR I=1:1
Begin DoDot:1
+5 SET RSCDATA=$PIECE($TEXT(NEWRSC+I),";",3,99)
+6 if RSCDATA="END"
QUIT
+7 ; do a lookup and continue if exists.
+8 SET DIC=GBL
SET X=$PIECE(RSCDATA,";")
DO ^DIC
+9 IF +Y>0
SET DIK=GBL
SET DA=+Y
DO ^DIK
+10 ; add entry
+11 SET X=$PIECE(RSCDATA,";")
+12 SET DIC("DR")=".02///"_$PIECE(RSCDATA,";",2)_";"
SET DIC(0)="L"
+13 SET DIC("DR")=DIC("DR")_".03///0;"
+14 DO FILE^DICN
+15 IF +Y=-1
Begin DoDot:2
+16 DO MES^XPDUTL(" "_$PIECE(RSCDATA,";")_" failed to add!")
End DoDot:2
End DoDot:1
if RSCDATA="END"
QUIT
+17 DO MES^XPDUTL(" New REVENUE SOURCE CODE file (#347.3) entries added")
+18 QUIT
+19 ;
+20 ;
DELOPT ; remove PRCAC SET REPAYMENT option
+1 NEW DA,DIK,MEN,OPT,RET
+2 ; RET - value returned from
+3 SET MEN="PRCAC REPAYMENT MENU"
+4 SET DA(1)=+$$LKOPT^XPDMENU(MEN)
+5 SET OPT="PRCAC SET REPAYMENT"
+6 DO BMES^XPDUTL(" -> Updating ["_MEN_"]")
+7 ; delete option from menu
SET RET=$$DELETE^XPDMENU(MEN,OPT)
+8 ; get option IEN
SET DA=+$$LKOPT^XPDMENU(OPT)
+9 ; code can be re-run if already deleted
IF DA>0
SET DIK="^DIC(19,"
DO ^DIK
+10 DO MES^XPDUTL(" Menu update "_$SELECT(RET:"completed.",1:"not needed."))
+11 SET OPT="PRCAC ENTER EDIT REPAYMENT"
+12 ; get option IEN
SET DA=+$$LKOPT^XPDMENU(OPT)
+13 ; Option already added
IF $DATA(^DIC(19,DA(1),10,"B",DA))
QUIT
+14 ; Set Enter/Edit Repayment as the first item in Repayment Menu
DO ADD^XPDMENU(MEN,OPT,"",1)
+15 QUIT
+16 ;
+1 NEW DA,DIK,MEN,OPT,RET
+2 ; RET - value returned from
+3 SET MEN="RCTCSP MENU"
+4 SET DA(1)=+$$LKOPT^XPDMENU(MEN)
+5 DO BMES^XPDUTL(" -> Updating ["_MEN_"]")
+6 FOR OPT="RCTCSP RECONCILIATION WORKLIST","RCTCSP RECONCIL REPORT"
Begin DoDot:1
+7 ; delete option from menu
KILL RET
SET RET=$$DELETE^XPDMENU(MEN,OPT)
+8 ; get option IEN
SET DA=+$$LKOPT^XPDMENU(OPT)
+9 DO MES^XPDUTL(" Menu update to option: "_OPT_" "_$SELECT(RET:"completed.",1:"not needed."))
+10 ; Option already added
IF $DATA(^DIC(19,DA(1),10,"B",DA))
QUIT
+11 DO ADD^XPDMENU(MEN,OPT,"")
End DoDot:1
+12 QUIT
+13 ;
CSJOB ;Job the process to build the new Cross-Servicing data fields.
+1 NEW ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSK
+2 ;
+3 DO BMES^XPDUTL(" -> Queuing background job to do the following:")
+4 DO MES^XPDUTL(" 1. Populate Cross-Servicing indices in ACCOUNTS RECEIVABLE file (#430)")
+5 DO MES^XPDUTL(" 2. Searching ACCOUNTS RECEIVABLE file (#430) for CS Stops placed")
+6 DO MES^XPDUTL(" prior to this patch in field STOP TCSP REFERRAL FLAG (#157).")
+7 DO MES^XPDUTL(" 3. Populate new field ORIGINAL DATE REFERRED TO TCSP (#156) in ACCOUNTS")
+8 DO MES^XPDUTL(" RECEIVABLE file (#430).")
+9 DO MES^XPDUTL(" ")
+10 ;
+11 ; Setup required variables
+12 SET ZTRTN="CSJOB1^PRCA315P"
SET ZTIO=""
SET ZTDTH=$HOROLOG
+13 SET ZTDESC="Background job to build CS indices for PRCA*4.5*315"
+14 ;
+15 ; Task the job
+16 DO ^%ZTLOAD
+17 ;
+18 ; Check if task was created
+19 IF $DATA(ZTSK)
DO MES^XPDUTL(" Task #"_ZTSK_" queued.")
+20 IF '$DATA(ZTSK)
DO MES^XPDUTL(" Task not queued. Please create a support ticket.")
+21 DO MES^XPDUTL(" ")
+22 QUIT
+23 ;
CSJOB1 ;Populate new indices in #430
+1 KILL ^TMP($JOB)
+2 SET DIK="^PRCA(430,"
SET DIK(1)="172"
DO ENALL^DIK
+3 SET ^TMP($JOB,"PRCA315P",1)="FILE #430 FIELD #172 INDEX POPULATED"
+4 SET DIK="^PRCA(430,"
SET DIK(1)="301"
DO ENALL^DIK
+5 SET ^TMP($JOB,"PRCA315P",2)="FILE #430 FIELD #301 INDEX POPULATED"
+6 ;
CSSTOP ;determine CS stops placed in 430 prior to Patch 315
+1 NEW RCIEN,DEBTOR,BILL,CSDATE,LIST,MSG,GLO
+2 ; need to be newed or mailman will not deliver the message
NEW DIFROM,XMDUN,XMY,XMZ
+3 SET GLO=$NAME(^TMP($JOB,"RCRJRCORMM"))
+4 ;
+5 SET @GLO@(1)="Bills currently flagged to stop TCSP referral activity prior"
+6 SET @GLO@(2)="to PRCA*4.5*315. These bills will not show on the new report:"
+7 SET @GLO@(3)="'Cross-Servicing Stop Reactivate Report'."
+8 SET @GLO@(4)=" "
+9 SET RCIEN=0
FOR
SET RCIEN=$ORDER(^PRCA(430,RCIEN))
if 'RCIEN
QUIT
Begin DoDot:1
+10 KILL LIST
+11 IF $PIECE($GET(^PRCA(430,RCIEN,15)),U,7)
Begin DoDot:2
+12 DO GETS^DIQ(430,RCIEN_",",".01;9;158","IE","LIST","MSG")
+13 SET BILL=$GET(LIST(430,RCIEN_",",.01,"E"))
SET DEBTOR=$GET(LIST(430,RCIEN_",",9,"E"))
SET CSDATE=$GET(LIST(430,RCIEN_",",158,"E"))
+14 SET @GLO@(RCIEN)=BILL_U_DEBTOR_U_CSDATE
End DoDot:2
+15 ;Load date into field #156, ORIGINAL DATE REFERRED TO TCSP
+16 IF $GET(^PRCA(439,RCIEN,21))
QUIT
+17 DO GETS^DIQ(430,RCIEN_",","151;153;158","I","LIST","MSG")
+18 FOR I=151,153,158
IF LIST(430,RCIEN_",",I,"I")?7N
SET ^PRCA(430,RCIEN,21)=LIST(430,RCIEN_",",I,"I")
QUIT
End DoDot:1
+19 SET ^TMP($JOB,"PRCA315P",3)="BILLS CURRENTLY FLAGGED TO STOP TCSP REPORT CREATED"
+20 SET ^TMP($JOB,"PRCA315P",4)="FILE #430 FIELD #156 VALUES POPULATED"
+21 SET XMDUZ=.5
SET XMY(.5)=""
SET XMY(DUZ)=""
SET XMY("G.TCSP")=""
+22 SET XMZ=$$SENDMSG^RCRJRCOR("STOP TCSP REFERRAL's existing before PRCA*4.5*315",.XMY)
+23 KILL ^TMP($JOB,"RCRJRCORMM")
+24 SET ^TMP($JOB,"PRCA315P",5)="BILLS CURRENTLY FLAGGED TO STOP TCSP REPORT MAIL SENT"
+25 ;
+26 NEW CNT,MSG,XMY,XMDUZ,DIFROM,XMSUB,XMTEXT
+27 SET XMY(DUZ)=""
+28 SET XMSUB="PRCA*4.5*315 Post install routine has completed"
SET XMDUZ="Patch PRCA*4.5*315"
+29 SET XMTEXT="^TMP($J,""PRCA315P"","
+30 DO ^XMD
+31 QUIT
+32 ;
+33 ;Revenue Source Codes (RSC#)//
NEWRSC ;SOURCE CODE;NAME
+1 ;;8VZZ;HUMAN 3RD-PRTY OUTPATIENT
+2 ;;8UZZ;HUMAN 3RD-PRTY INPATIENT
+3 ;;841Z;INELI 3RD-PARTY INPATIENT
+4 ;;842Z;INELI 3RD-PARTY OUTPATIENT
+5 ;;END
+6 ;
+7 ;
+8 ;;ACCOUNTS RECEIVABLE CATEGORY FILE (#430.2)
+9 ;;.01 CATEGORY;1 ABBREVIATION;6 CATEGORY NUMBER;7 ACCRUED
CT46 ;;EMERGENCY/HUMANITARIAN REIMB.;HR;252;48;T;1213;1
CT47 ;;INELIGIBLE HOSP. REIMB.;IR;251;49;T;1213;0
