source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAMRG.m@ 1261

Last change on this file since 1261 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.3 KB
Line 
1PRCAMRG ;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 ;;
6EN(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)
30REPNT 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
Note: See TracBrowser for help on using the repository browser.