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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBXMRG 1412 printed Dec 13, 2024@01:41:29 Page 2
PSBXMRG ;ROUTINE TO MERGE ENTRIES IN BCMA MED LOG FILE FOR PATIENT MERGE ;Mar 2004
+1 ;;3.0;BAR CODE MED ADMIN;;Mar 2004
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;Reference to EN^XDRMERG is supported by DBIA #2365
+4 ;Reference to SAVEMERG^XDRMERGB is supported by DBIA #2338
+5 ;
EN(ARRAY) ; Entry point called with NAME of array containing from, and to entries.
+1 ;
+2 NEW XARRAY,IBDIC,FROMX,TO,FROMX1,TO1,FROM,FRX,TOX
+3 SET XARRAY=$NAME(^TMP("PSB",$JOB))
+4 KILL @XARRAY
+5 SET FROM=XARRAY
+6 SET IBDIC=$GET(^DIC(53.79,0,"GL"))
+7 IF IBDIC=""
QUIT
+8 FOR FROMX=0:0
SET FROMX=$ORDER(@ARRAY@(FROMX))
if FROMX'>0
QUIT
Begin DoDot:1
+9 SET TO=$ORDER(@ARRAY@(FROMX,0))
+10 SET FROMX1=$ORDER(@(IBDIC_"""B"",FROMX,0)"))
+11 SET TO1=$ORDER(@(IBDIC_"""B"",TO,0)"))
+12 IF TO1=""
IF FROMX1=""
QUIT
+13 SET TO1=$SELECT(TO1>0:TO1,1:0)
SET FROMX1=$SELECT(FROMX1>0:FROMX1,1:0)
+14 SET FRX=$ORDER(@ARRAY@(FROMX,TO,""))
SET TOX=$ORDER(@ARRAY@(FROMX,TO,FRX,TOX))
+15 SET @XARRAY@(FROMX1,TO1,FRX,TOX)=""
+16 IF FROMX1=0
Begin DoDot:2
+17 DO SAVEMERG^XDRMERGB(53.79,FROMX1,TO1)
+18 KILL @XARRAY@(FROMX1,TO1)
End DoDot:2
QUIT
+19 IF TO1=0
Begin DoDot:2
+20 DO SAVEMERG^XDRMERGB(53.79,FROMX1,TO1)
+21 KILL @XARRAY@(FROMX1,TO1)
+22 NEW IBDXXX
+23 SET IBDXXX(53.79,(FROMX1_","),.01)=TO
+24 DO UPDATE^DIE("","IBDXXX")
End DoDot:2
QUIT
End DoDot:1
+25 IF '$DATA(@XARRAY)
QUIT
+26 ; NOW CONVERT ANY POINTERS TO THE MERGED ENTRIES
DO EN^XDRMERG(53.79,"XARRAY")
+27 SET IBDIC=$GET(^DIC(53.79,0,"GL"))
+28 IF IBDIC'=""
Begin DoDot:1
+29 FOR FROMX=0:0
SET FROMX=$ORDER(@XARRAY@(FROMX))
if FROMX'>0
QUIT
KILL @(IBDIC_FROMX_")")
End DoDot:1
+30 QUIT
