RCRCPOST ;ALB/CMS - PRCA*4.5*63 POST ROUTINE ;
V ;;4.5;Accounts Receivable;**63**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
Q
EN ;Enter from Patch Install
D GRP,ATT,EVNT,ART,FORM,NDR,SET,INP
Q
;
GRP ;Change AR Group Parameters
;AR Group File 342.1
N DIE,DA,DR,X,Y W !,"Updating AR Group"
S DIE="^RC(342.1,"
S DA=$O(^RC(342.1,"B","DISTRICT COUNSEL",0))
I DA="" G GRP2
S DR=".01////REGIONAL COUNSEL;2.01////1;2.02////4999"
D ^DIE
;
GRP2 ;AR Group Type File 342.2
S DIE="^RC(342.2,"
S DA=$O(^RC(342.2,"B","DISTRICT COUNSEL",0))
I DA="" G GRPQ
S DR=".01////REGIONAL COUNSEL;1.01////[RCMS REGIONAL COUNSEL]"
D ^DIE
GRPQ Q
;
ATT ;add RC to AR TRANSMISSION TYPE 349.1
N D,DA,D0,DIC,DIE,DLAYGO,DR,X,Y K DD,DO W !,"Adding RC to 349.1"
S DA=$O(^RCT(349.1,"B","RC",0))
I DA G ATTE
S X="RC",DIC="^RCT(349.1,",DIC(0)="L",DLAYGO=349.1
D FILE^DICN K DD,DO I Y<1 G ATTQ
S DA=+Y
ATTE S DIE="^RCT(349.1,"
S DR=".02///REGIONAL COUNSEL;.03///1;.04///90"
D ^DIE
;** Ask user to point to their supporting Regional Counsel DOMAIN
ATTQ Q
;
EVNT ;Change AR Event File Entry
N DA W !,"Changing AR Event File"
S DA=$O(^RC(341.1,"B","DISTRICT COUNSEL PAYMENT",0))
I 'DA G EVNTQ
S $P(^RC(341.1,DA,0),U,1)="REGIONAL COUNSEL PAYMENT"
S ^RC(341.1,"B","REGIONAL COUNSEL PAYMENT",DA)=""
K ^RC(341.1,"B","DISTRICT COUNSEL PAYMENT",DA)
EVNTQ Q
;
ART ;Change AR Transactions containing DC/DOJ
N DA,RCDC,RCI,RCX W !,"Updating AR Transactions"
F RCI=3,5,6,7,29 S DA=$O(^PRCA(430.3,"AC",RCI,0)) Q:'DA D
.S RCDC=$P(^PRCA(430.3,DA,0),U,1)
.I RCDC'[" DC" Q
.I RCI'=3 S RCX=$P(RCDC,"DC/DOJ",1),RCX=RCX_"RC/DOJ"
.I RCI=3 S RCX=$P(RCDC,"DC",1),RCX=RCX_"RC"
.S $P(^PRCA(430.3,DA,0),U,1)=RCX
.S ^PRCA(430.3,"B",RCX,DA)=""
.K ^PRCA(430.3,"B",RCDC,DA)
ARTQ Q
;
FORM ;Change AR Form FL 4-484
N DA,RCI,X,Y W !,"Updating AR Form"
S DA=$O(^RC(343,"B","FL 4-484",0))
I 'DA G FORMQ
S RCI=0 F S RCI=$O(^RC(343,DA,1,RCI)) Q:'RCI D
.S X=^RC(343,DA,1,RCI,0)
.I X'["District" Q
.S Y=$P(X,"District",1),X=$P(X,"District",2)
.S ^RC(343,DA,1,RCI,0)=Y_"Regional"_X
FORMQ Q
;
NDR ;Change File 348 AR NDR Criteria
N DA,DIE,DR,RCB,RCI,RCN,X,Y W !,"Updating AR NDR Criteria"
F RCB=1230,1231,1232 S DA=$O(^RC(348,"B",RCB,0)) D
.S RCN=$P(^RC(348,DA,0),U,2)
.I RCN'["DISTRICT" Q
.S Y=$P(RCN,"DISTRICT",1),RCN=$P(RCN,"DISTRICT",2)
.S RCN=Y_"REGIONAL"_RCN
.S DR="1////"_RCN S DIE="^RC(348," D ^DIE
NDRQ Q
;
SET ;Change DC in File 430 to RC
N RC,RCI,RCY W !,"Changing Referral Code in File 430"
S RCI=0 F S RCI=$O(^PRCA(430,"AD",RCI)) Q:'RCI D
.S RCY=0 F S RCY=$O(^PRCA(430,"AD",RCI,RCY)) Q:'RCY D
..S RC=$P($G(^PRCA(430,RCY,6)),U,5)
..I RC="DC" S $P(^PRCA(430,RCY,6),U,5)="RC"
SETQ Q
;
INP ;Compile Input Template PRCA BATCH PAYMENT
N X,Y,DNM,DMAX
S X="PRCATB",DMAX=$$ROUSIZE^DILF
S Y=$O(^DIE("B","PRCA BATCH PAYMENT",0))
I Y D EN^DIEZ
INPQ Q
;
;RCRCPOST
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCRCPOST 2998 printed Dec 13, 2024@01:47:40 Page 2
RCRCPOST ;ALB/CMS - PRCA*4.5*63 POST ROUTINE ;
V ;;4.5;Accounts Receivable;**63**;Mar 20, 1995
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
EN ;Enter from Patch Install
+1 DO GRP
DO ATT
DO EVNT
DO ART
DO FORM
DO NDR
DO SET
DO INP
+2 QUIT
+3 ;
GRP ;Change AR Group Parameters
+1 ;AR Group File 342.1
+2 NEW DIE,DA,DR,X,Y
WRITE !,"Updating AR Group"
+3 SET DIE="^RC(342.1,"
+4 SET DA=$ORDER(^RC(342.1,"B","DISTRICT COUNSEL",0))
+5 IF DA=""
GOTO GRP2
+6 SET DR=".01////REGIONAL COUNSEL;2.01////1;2.02////4999"
+7 DO ^DIE
+8 ;
GRP2 ;AR Group Type File 342.2
+1 SET DIE="^RC(342.2,"
+2 SET DA=$ORDER(^RC(342.2,"B","DISTRICT COUNSEL",0))
+3 IF DA=""
GOTO GRPQ
+4 SET DR=".01////REGIONAL COUNSEL;1.01////[RCMS REGIONAL COUNSEL]"
+5 DO ^DIE
GRPQ QUIT
+1 ;
ATT ;add RC to AR TRANSMISSION TYPE 349.1
+1 NEW D,DA,D0,DIC,DIE,DLAYGO,DR,X,Y
KILL DD,DO
WRITE !,"Adding RC to 349.1"
+2 SET DA=$ORDER(^RCT(349.1,"B","RC",0))
+3 IF DA
GOTO ATTE
+4 SET X="RC"
SET DIC="^RCT(349.1,"
SET DIC(0)="L"
SET DLAYGO=349.1
+5 DO FILE^DICN
KILL DD,DO
IF Y<1
GOTO ATTQ
+6 SET DA=+Y
ATTE SET DIE="^RCT(349.1,"
+1 SET DR=".02///REGIONAL COUNSEL;.03///1;.04///90"
+2 DO ^DIE
+3 ;** Ask user to point to their supporting Regional Counsel DOMAIN
ATTQ QUIT
+1 ;
EVNT ;Change AR Event File Entry
+1 NEW DA
WRITE !,"Changing AR Event File"
+2 SET DA=$ORDER(^RC(341.1,"B","DISTRICT COUNSEL PAYMENT",0))
+3 IF 'DA
GOTO EVNTQ
+4 SET $PIECE(^RC(341.1,DA,0),U,1)="REGIONAL COUNSEL PAYMENT"
+5 SET ^RC(341.1,"B","REGIONAL COUNSEL PAYMENT",DA)=""
+6 KILL ^RC(341.1,"B","DISTRICT COUNSEL PAYMENT",DA)
EVNTQ QUIT
+1 ;
ART ;Change AR Transactions containing DC/DOJ
+1 NEW DA,RCDC,RCI,RCX
WRITE !,"Updating AR Transactions"
+2 FOR RCI=3,5,6,7,29
SET DA=$ORDER(^PRCA(430.3,"AC",RCI,0))
if 'DA
QUIT
Begin DoDot:1
+3 SET RCDC=$PIECE(^PRCA(430.3,DA,0),U,1)
+4 IF RCDC'[" DC"
QUIT
+5 IF RCI'=3
SET RCX=$PIECE(RCDC,"DC/DOJ",1)
SET RCX=RCX_"RC/DOJ"
+6 IF RCI=3
SET RCX=$PIECE(RCDC,"DC",1)
SET RCX=RCX_"RC"
+7 SET $PIECE(^PRCA(430.3,DA,0),U,1)=RCX
+8 SET ^PRCA(430.3,"B",RCX,DA)=""
+9 KILL ^PRCA(430.3,"B",RCDC,DA)
End DoDot:1
ARTQ QUIT
+1 ;
FORM ;Change AR Form FL 4-484
+1 NEW DA,RCI,X,Y
WRITE !,"Updating AR Form"
+2 SET DA=$ORDER(^RC(343,"B","FL 4-484",0))
+3 IF 'DA
GOTO FORMQ
+4 SET RCI=0
FOR
SET RCI=$ORDER(^RC(343,DA,1,RCI))
if 'RCI
QUIT
Begin DoDot:1
+5 SET X=^RC(343,DA,1,RCI,0)
+6 IF X'["District"
QUIT
+7 SET Y=$PIECE(X,"District",1)
SET X=$PIECE(X,"District",2)
+8 SET ^RC(343,DA,1,RCI,0)=Y_"Regional"_X
End DoDot:1
FORMQ QUIT
+1 ;
NDR ;Change File 348 AR NDR Criteria
+1 NEW DA,DIE,DR,RCB,RCI,RCN,X,Y
WRITE !,"Updating AR NDR Criteria"
+2 FOR RCB=1230,1231,1232
SET DA=$ORDER(^RC(348,"B",RCB,0))
Begin DoDot:1
+3 SET RCN=$PIECE(^RC(348,DA,0),U,2)
+4 IF RCN'["DISTRICT"
QUIT
+5 SET Y=$PIECE(RCN,"DISTRICT",1)
SET RCN=$PIECE(RCN,"DISTRICT",2)
+6 SET RCN=Y_"REGIONAL"_RCN
+7 SET DR="1////"_RCN
SET DIE="^RC(348,"
DO ^DIE
End DoDot:1
NDRQ QUIT
+1 ;
SET ;Change DC in File 430 to RC
+1 NEW RC,RCI,RCY
WRITE !,"Changing Referral Code in File 430"
+2 SET RCI=0
FOR
SET RCI=$ORDER(^PRCA(430,"AD",RCI))
if 'RCI
QUIT
Begin DoDot:1
+3 SET RCY=0
FOR
SET RCY=$ORDER(^PRCA(430,"AD",RCI,RCY))
if 'RCY
QUIT
Begin DoDot:2
+4 SET RC=$PIECE($GET(^PRCA(430,RCY,6)),U,5)
+5 IF RC="DC"
SET $PIECE(^PRCA(430,RCY,6),U,5)="RC"
End DoDot:2
End DoDot:1
SETQ QUIT
+1 ;
INP ;Compile Input Template PRCA BATCH PAYMENT
+1 NEW X,Y,DNM,DMAX
+2 SET X="PRCATB"
SET DMAX=$$ROUSIZE^DILF
+3 SET Y=$ORDER(^DIE("B","PRCA BATCH PAYMENT",0))
+4 IF Y
DO EN^DIEZ
INPQ QUIT
+1 ;
+2 ;RCRCPOST
