38 lines
1.3 KiB
Mathematica
38 lines
1.3 KiB
Mathematica
PSBXMRG ;ROUTINE TO MERGE ENTRIES IN BCMA MED LOG FILE FOR PATIENT MERGE ;Mar 2004
|
|
;;3.0;BAR CODE MED ADMIN;;Mar 2004
|
|
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
;Reference to EN^XDRMERG is supported by DBIA #2365
|
|
;Reference to SAVEMERG^XDRMERGB is supported by DBIA #2338
|
|
;
|
|
EN(ARRAY) ; Entry point called with NAME of array containing from, and to entries.
|
|
;
|
|
N XARRAY,IBDIC,FROMX,TO,FROMX1,TO1,FROM,FRX,TOX
|
|
S XARRAY=$NA(^TMP("PSB",$J))
|
|
K @XARRAY
|
|
S FROM=XARRAY
|
|
S IBDIC=$G(^DIC(53.79,0,"GL"))
|
|
I IBDIC="" Q
|
|
F FROMX=0:0 S FROMX=$O(@ARRAY@(FROMX)) Q:FROMX'>0 D
|
|
. S TO=$O(@ARRAY@(FROMX,0))
|
|
. S FROMX1=$O(@(IBDIC_"""B"",FROMX,0)"))
|
|
. S TO1=$O(@(IBDIC_"""B"",TO,0)"))
|
|
. I TO1="",FROMX1="" Q
|
|
. S TO1=$S(TO1>0:TO1,1:0),FROMX1=$S(FROMX1>0:FROMX1,1:0)
|
|
. S FRX=$O(@ARRAY@(FROMX,TO,"")),TOX=$O(@ARRAY@(FROMX,TO,FRX,TOX))
|
|
. S @XARRAY@(FROMX1,TO1,FRX,TOX)=""
|
|
. I FROMX1=0 D Q
|
|
. . D SAVEMERG^XDRMERGB(53.79,FROMX1,TO1)
|
|
. . K @XARRAY@(FROMX1,TO1)
|
|
. I TO1=0 D Q
|
|
. . D SAVEMERG^XDRMERGB(53.79,FROMX1,TO1)
|
|
. . K @XARRAY@(FROMX1,TO1)
|
|
. . N IBDXXX
|
|
. . S IBDXXX(53.79,(FROMX1_","),.01)=TO
|
|
. . D UPDATE^DIE("","IBDXXX")
|
|
I '$D(@XARRAY) Q
|
|
D EN^XDRMERG(53.79,"XARRAY") ; NOW CONVERT ANY POINTERS TO THE MERGED ENTRIES
|
|
S IBDIC=$G(^DIC(53.79,0,"GL"))
|
|
I IBDIC'="" D
|
|
. F FROMX=0:0 S FROMX=$O(@XARRAY@(FROMX)) Q:FROMX'>0 K @(IBDIC_FROMX_")")
|
|
Q
|