| 1 | PSBXMRG ;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 | ;
|
|---|
| 7 | EN(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
|
|---|
