- 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 ---[H[J[2J[HIBAXDR 1327 printed Feb 18, 2025@23:34:40 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
