source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBAXDR.m@ 1000

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

initial load of WorldVistAEHR

File size: 1.3 KB
Line 
1IBAXDR ;SF-IRMFO/JLI,REM - ROUTINE TO MERGE ENTRIES IN IB FILE FOR PATIENT MERGE ;3/9/98 13:35
2 ;;2.0;INTEGRATED BILLING;**94**;21-MAR-94
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,IBDIC,FROMX,TO,FROMX1,TO1,FROM,FRX,TOX
9 S XARRAY=$NA(^TMP($J,"IBDUMR1"))
10 K @XARRAY
11 S FROM=XARRAY
12 S IBDIC=$G(^DIC(351.1,0,"GL"))
13 I IBDIC="" 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(@(IBDIC_"""B"",FROMX,0)"))
17 . S TO1=$O(@(IBDIC_"""B"",TO,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,TOX))
21 . S @XARRAY@(FROMX1,TO1,FRX,TOX)=""
22 . I FROMX1=0 D Q
23 . . D SAVEMERG^XDRMERGB(351.1,FROMX1,TO1)
24 . . K @XARRAY@(FROMX1,TO1)
25 . I TO1=0 D Q
26 . . D SAVEMERG^XDRMERGB(351.1,FROMX1,TO1)
27 . . K @XARRAY@(FROMX1,TO1)
28 . . N IBDXXX
29 . . S IBDXXX(351.1,(FROMX1_","),.01)=TO
30 . . D UPDATE^DIE("","IBDXXX")
31 I '$D(@XARRAY) Q
32 D EN^XDRMERG(351.1,"XARRAY") ; NOW CONVERT ANY POINTERS TO THE MERGED ENTRIES
33 S IBDIC=$G(^DIC(351.1,0,"GL"))
34 I IBDIC'="" D
35 . F FROMX=0:0 S FROMX=$O(@XARRAY@(FROMX)) Q:FROMX'>0 K @(IBDIC_FROMX_")")
36 Q
Note: See TracBrowser for help on using the repository browser.