| 1 | PRCAMRG ;SF-IRMFO/JLI,REM,TJK - ROUTINE TO MERGE ENTRIES IN AR DEBTOR FILE FOR PATIENT MERGE ;3/9/98 13:35
|
|---|
| 2 | ;;4.5;Accounts Receivable;**132**;Mar 20, 1995
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;;
|
|---|
| 5 | ;;
|
|---|
| 6 | EN(ARRAY) ; Entry point called with NAME of array containing from, and to entries.
|
|---|
| 7 | ;
|
|---|
| 8 | N XARRAY,RCDIC,FROMX,TO,FROMX1,TO1,FROM,FRX,TOX
|
|---|
| 9 | S XARRAY=$NA(^TMP($J,"PRCAMRG"))
|
|---|
| 10 | K @XARRAY
|
|---|
| 11 | S FROM=XARRAY
|
|---|
| 12 | S RCDIC=$G(^DIC(340,0,"GL"))
|
|---|
| 13 | I RCDIC="" Q
|
|---|
| 14 | F FROMX=0:0 S FROMX=$O(@ARRAY@(FROMX)) Q:FROMX'>0 D
|
|---|
| 15 | . S TO=$O(@ARRAY@(FROMX,0))
|
|---|
| 16 | . S FROMX1=$O(@(RCDIC_"""B"",FROMX_"";DPT("",0)"))
|
|---|
| 17 | . S TO1=$O(@(RCDIC_"""B"",TO_"";DPT("",0)"))
|
|---|
| 18 | . I TO1="",FROMX1="" Q
|
|---|
| 19 | . S TO1=$S(TO1>0:TO1,1:0),FROMX1=$S(FROMX1>0:FROMX1,1:0)
|
|---|
| 20 | . S FRX=$O(@ARRAY@(FROMX,TO,"")),TOX=$O(@ARRAY@(FROMX,TO,FRX,""))
|
|---|
| 21 | . S @XARRAY@(FROMX1,TO1,FRX,TOX)="",^TMP($J,"RCPOINT",FROMX1,TO1)=""
|
|---|
| 22 | . I TO1=0 D Q
|
|---|
| 23 | . . D SAVEMERG^XDRMERGB(340,FROMX1,TO1)
|
|---|
| 24 | . . K @XARRAY@(FROMX1,TO1)
|
|---|
| 25 | . . N RCDXXX
|
|---|
| 26 | . . S RCDXXX(340,(FROMX1_","),.01)=TO_";DPT("
|
|---|
| 27 | . . D UPDATE^DIE("","RCDXXX")
|
|---|
| 28 | I '$D(@XARRAY) Q
|
|---|
| 29 | D EN^XDRMERG(340,XARRAY)
|
|---|
| 30 | REPNT D
|
|---|
| 31 | .S FROM=0
|
|---|
| 32 | .F S FROM=$O(^TMP($J,"RCPOINT",FROM)) Q:'FROM S TO=$O(^(FROM,0)) D
|
|---|
| 33 | ..S BILL=0
|
|---|
| 34 | ..F S BILL=$O(^PRCA(430,"C",FROM,BILL)) Q:'BILL S DIE="^PRCA(430,",DA=BILL,DR="9////"_TO D ^DIE
|
|---|
| 35 | ..Q
|
|---|
| 36 | .Q
|
|---|
| 37 | S RCDIC=$G(^DIC(340,0,"GL"))
|
|---|
| 38 | Q
|
|---|
