source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBXMRG.m@ 1166

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

initial load of FOIAVistA 6/30/08 version

File size: 1.3 KB
Line 
1PSBXMRG ;ROUTINE TO MERGE ENTRIES IN BCMA MED LOG FILE FOR PATIENT MERGE ;Mar 2004
2 ;;3.0;BAR CODE MED ADMIN;;Mar 2004
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;Reference to EN^XDRMERG is supported by DBIA #2365
5 ;Reference to SAVEMERG^XDRMERGB is supported by DBIA #2338
6 ;
7EN(ARRAY) ; Entry point called with NAME of array containing from, and to entries.
8 ;
9 N XARRAY,IBDIC,FROMX,TO,FROMX1,TO1,FROM,FRX,TOX
10 S XARRAY=$NA(^TMP("PSB",$J))
11 K @XARRAY
12 S FROM=XARRAY
13 S IBDIC=$G(^DIC(53.79,0,"GL"))
14 I IBDIC="" Q
15 F FROMX=0:0 S FROMX=$O(@ARRAY@(FROMX)) Q:FROMX'>0 D
16 . S TO=$O(@ARRAY@(FROMX,0))
17 . S FROMX1=$O(@(IBDIC_"""B"",FROMX,0)"))
18 . S TO1=$O(@(IBDIC_"""B"",TO,0)"))
19 . I TO1="",FROMX1="" Q
20 . S TO1=$S(TO1>0:TO1,1:0),FROMX1=$S(FROMX1>0:FROMX1,1:0)
21 . S FRX=$O(@ARRAY@(FROMX,TO,"")),TOX=$O(@ARRAY@(FROMX,TO,FRX,TOX))
22 . S @XARRAY@(FROMX1,TO1,FRX,TOX)=""
23 . I FROMX1=0 D Q
24 . . D SAVEMERG^XDRMERGB(53.79,FROMX1,TO1)
25 . . K @XARRAY@(FROMX1,TO1)
26 . I TO1=0 D Q
27 . . D SAVEMERG^XDRMERGB(53.79,FROMX1,TO1)
28 . . K @XARRAY@(FROMX1,TO1)
29 . . N IBDXXX
30 . . S IBDXXX(53.79,(FROMX1_","),.01)=TO
31 . . D UPDATE^DIE("","IBDXXX")
32 I '$D(@XARRAY) Q
33 D EN^XDRMERG(53.79,"XARRAY") ; NOW CONVERT ANY POINTERS TO THE MERGED ENTRIES
34 S IBDIC=$G(^DIC(53.79,0,"GL"))
35 I IBDIC'="" D
36 . F FROMX=0:0 S FROMX=$O(@XARRAY@(FROMX)) Q:FROMX'>0 K @(IBDIC_FROMX_")")
37 Q
Note: See TracBrowser for help on using the repository browser.