IBAXDR.m

IBAXDR ;SF-IRMFO/JLI,REM - ROUTINE TO MERGE ENTRIES IN IB FILE FOR PATIENT MERGE ;3/9/98  13:35

 ;;2.0;INTEGRATED BILLING;**94**;21-MAR-94

 ;;Per VHA Directive 10-93-142, this routine should not be modified.

 ;;

 ;;

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($J,"IBDUMR1"))

 K @XARRAY

 S FROM=XARRAY

 S IBDIC=$G(^DIC(351.1,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(351.1,FROMX1,TO1)

 . . K @XARRAY@(FROMX1,TO1)

 . I TO1=0 D  Q

 . . D SAVEMERG^XDRMERGB(351.1,FROMX1,TO1)

 . . K @XARRAY@(FROMX1,TO1)

 . . N IBDXXX

 . . S IBDXXX(351.1,(FROMX1_","),.01)=TO

 . . D UPDATE^DIE("","IBDXXX")

 I '$D(@XARRAY) Q

 D EN^XDRMERG(351.1,"XARRAY") ; NOW CONVERT ANY POINTERS TO THE MERGED ENTRIES

 S IBDIC=$G(^DIC(351.1,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 ---IBAXDR   1327     printed  Apr 09, 2024@21:04:23                                                                                                                                                                                                      Page 2

IBAXDR    ;SF-IRMFO/JLI,REM - ROUTINE TO MERGE ENTRIES IN IB FILE FOR PATIENT MERGE ;3/9/98  13:35

 +1       ;;2.0;INTEGRATED BILLING;**94**;21-MAR-94

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;;

 +4       ;;

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($JOB,"IBDUMR1"))

 +4        KILL @XARRAY

 +5        SET FROM=XARRAY

 +6        SET IBDIC=$GET(^DIC(351.1,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(351.1,FROMX1,TO1)

 +18                       KILL @XARRAY@(FROMX1,TO1)

                       End DoDot:2

                       QUIT 

 +19               IF TO1=0

                       Begin DoDot:2

 +20                       DO SAVEMERG^XDRMERGB(351.1,FROMX1,TO1)

 +21                       KILL @XARRAY@(FROMX1,TO1)

 +22                       NEW IBDXXX

 +23                       SET IBDXXX(351.1,(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(351.1,"XARRAY")

 +27       SET IBDIC=$GET(^DIC(351.1,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