Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSBXMRG

PSBXMRG.m

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