PRCAMRG ;SF-IRMFO/JLI,REM,TJK - ROUTINE TO MERGE ENTRIES IN AR DEBTOR FILE FOR PATIENT MERGE ;3/9/98 13:35
;;4.5;Accounts Receivable;**132**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;;
;;
EN(ARRAY) ; Entry point called with NAME of array containing from, and to entries.
;
N XARRAY,RCDIC,FROMX,TO,FROMX1,TO1,FROM,FRX,TOX
S XARRAY=$NA(^TMP($J,"PRCAMRG"))
K @XARRAY
S FROM=XARRAY
S RCDIC=$G(^DIC(340,0,"GL"))
I RCDIC="" Q
F FROMX=0:0 S FROMX=$O(@ARRAY@(FROMX)) Q:FROMX'>0 D
. S TO=$O(@ARRAY@(FROMX,0))
. S FROMX1=$O(@(RCDIC_"""B"",FROMX_"";DPT("",0)"))
. S TO1=$O(@(RCDIC_"""B"",TO_"";DPT("",0)"))
. I TO1="",FROMX1="" Q
. S TO1=$S(TO1>0:TO1,1:0),FROMX1=$S(FROMX1>0:FROMX1,1:0)
. S FRX=$O(@ARRAY@(FROMX,TO,"")),TOX=$O(@ARRAY@(FROMX,TO,FRX,""))
. S @XARRAY@(FROMX1,TO1,FRX,TOX)="",^TMP($J,"RCPOINT",FROMX1,TO1)=""
. I TO1=0 D Q
. . D SAVEMERG^XDRMERGB(340,FROMX1,TO1)
. . K @XARRAY@(FROMX1,TO1)
. . N RCDXXX
. . S RCDXXX(340,(FROMX1_","),.01)=TO_";DPT("
. . D UPDATE^DIE("","RCDXXX")
I '$D(@XARRAY) Q
D EN^XDRMERG(340,XARRAY)
REPNT D
.S FROM=0
.F S FROM=$O(^TMP($J,"RCPOINT",FROM)) Q:'FROM S TO=$O(^(FROM,0)) D
..S BILL=0
..F S BILL=$O(^PRCA(430,"C",FROM,BILL)) Q:'BILL S DIE="^PRCA(430,",DA=BILL,DR="9////"_TO D ^DIE
..Q
.Q
S RCDIC=$G(^DIC(340,0,"GL"))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAMRG 1400 printed Nov 22, 2024@16:50:41 Page 2
PRCAMRG ;SF-IRMFO/JLI,REM,TJK - ROUTINE TO MERGE ENTRIES IN AR DEBTOR FILE FOR PATIENT MERGE ;3/9/98 13:35
+1 ;;4.5;Accounts Receivable;**132**;Mar 20, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;;
+4 ;;
EN(ARRAY) ; Entry point called with NAME of array containing from, and to entries.
+1 ;
+2 NEW XARRAY,RCDIC,FROMX,TO,FROMX1,TO1,FROM,FRX,TOX
+3 SET XARRAY=$NAME(^TMP($JOB,"PRCAMRG"))
+4 KILL @XARRAY
+5 SET FROM=XARRAY
+6 SET RCDIC=$GET(^DIC(340,0,"GL"))
+7 IF RCDIC=""
QUIT
+8 FOR FROMX=0:0
SET FROMX=$ORDER(@ARRAY@(FROMX))
if FROMX'>0
QUIT
Begin DoDot:1
+9 SET TO=$ORDER(@ARRAY@(FROMX,0))
+10 SET FROMX1=$ORDER(@(RCDIC_"""B"",FROMX_"";DPT("",0)"))
+11 SET TO1=$ORDER(@(RCDIC_"""B"",TO_"";DPT("",0)"))
+12 IF TO1=""
IF FROMX1=""
QUIT
+13 SET TO1=$SELECT(TO1>0:TO1,1:0)
SET FROMX1=$SELECT(FROMX1>0:FROMX1,1:0)
+14 SET FRX=$ORDER(@ARRAY@(FROMX,TO,""))
SET TOX=$ORDER(@ARRAY@(FROMX,TO,FRX,""))
+15 SET @XARRAY@(FROMX1,TO1,FRX,TOX)=""
SET ^TMP($JOB,"RCPOINT",FROMX1,TO1)=""
+16 IF TO1=0
Begin DoDot:2
+17 DO SAVEMERG^XDRMERGB(340,FROMX1,TO1)
+18 KILL @XARRAY@(FROMX1,TO1)
+19 NEW RCDXXX
+20 SET RCDXXX(340,(FROMX1_","),.01)=TO_";DPT("
+21 DO UPDATE^DIE("","RCDXXX")
End DoDot:2
QUIT
End DoDot:1
+22 IF '$DATA(@XARRAY)
QUIT
+23 DO EN^XDRMERG(340,XARRAY)
REPNT Begin DoDot:1
+1 SET FROM=0
+2 FOR
SET FROM=$ORDER(^TMP($JOB,"RCPOINT",FROM))
if 'FROM
QUIT
SET TO=$ORDER(^(FROM,0))
Begin DoDot:2
+3 SET BILL=0
+4 FOR
SET BILL=$ORDER(^PRCA(430,"C",FROM,BILL))
if 'BILL
QUIT
SET DIE="^PRCA(430,"
SET DA=BILL
SET DR="9////"_TO
DO ^DIE
+5 QUIT
End DoDot:2
+6 QUIT
End DoDot:1
+7 SET RCDIC=$GET(^DIC(340,0,"GL"))
+8 QUIT
