PSBXMRG.m

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

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