- DITMGMRG ;SFISC/EDE(OHPRD)-RELINK/MERGE TWO ENTRIES BELOW POINTED TO FILE ;8MAR2006
- ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- ;;Per VA Directive 6402, this routine should not be modified.
- ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- ;;Licensed under the terms of the Apache License, Version 2.0.
- ;
- ; Merge two entries below pointed to file. See ^DITMDOC.
- ;
- START ;
- D ^DITMGM1
- I 'DITMGMRG("GO") D EOJ K DITMGMRG Q
- D EN
- K DITMGMRG
- Q
- ;
- EN ; EXTERNAL ENTRY POINT
- D INIT^DITMGMRI
- Q:$D(DITMGMQF)
- D STACK
- S:$D(DITMGMRG("NOTALK")) DITMGM2("NOTALK")=1
- D ^DITMGM2 K DITMGM2("NOTALK")
- K ^UTILITY("DITMGMRG",$J)
- W:'$D(DITMGMRG("NOTALK")) !!,"Merge complete",!!
- D EOJ
- Q
- ;
- STACK ;STACK ALL FILES POINTING TO POINTED TO FILE AND IF .01 FIELD
- ;POINTING AND DINUM, FILES POINTING TO POINTING FILE, AND SO ON.
- ;
- W:'$D(DITMGMRG("NOTALK")) !!,"Gathering files and checking 'PT' nodes"
- NEW DITMGFLE,DITMGPFL,DITMGPFD,DITMSKP
- K ^UTILITY("DITMGMRG",$J)
- S DITMGFLE=DITMGMRG("FILE")
- D FILES
- Q
- ;
- FILES ; CALLED RECURSIVELY
- D PTCHK
- F DITMGPFL=0:0 S DITMGPFL=$O(^DD(DITMGFLE,0,"PT",DITMGPFL)) Q:DITMGPFL'=+DITMGPFL D I 'DITMSKP D FIELDS
- . S DITMSKP=0
- . I $D(DITMGMRG("EXCLUDE",DITMGPFL)) S DITMSKP=1 Q
- . ;I DITMGFLE=DITMGPFL S DITMSKP=1 Q
- . Q:'$D(DITMGMRG("PACKAGE"))
- . I DITMGMRG("PACKAGE") S:'$D(DITMGMRG("PACKAGE",DITMGPFL)) DITMSKP=1 Q
- . Q
- Q
- ;
- FIELDS ;
- ;W:'$D(DITMGMRG("NOTALK")) "f"
- F DITMGPFD=0:0 S DITMGPFD=$O(^DD(DITMGFLE,0,"PT",DITMGPFL,DITMGPFD)) Q:DITMGPFD'=+DITMGPFD D
- IHS . I DITMGPFL=2,DITMGPFD=.082 Q ;NEW LINE
- . S ^UTILITY("DITMGMRG",$J,DITMGPFL,DITMGPFD)=DITMGFLE
- . ;W:'$D(DITMGMRG("NOTALK")) $S($D(^DD(DITMGPFL,0,"UP")):"s",1:".")
- . I DITMGPFD=.01,'$D(^DD(DITMGPFL,0,"UP")),$P(^DD(DITMGPFL,.01,0),U,5,99)["DINUM" D RECURSE
- Q
- ;
- RECURSE ;
- ;W:'$D(DITMGMRG("NOTALK")) "d"
- NEW DITMGFLE
- S DITMGFLE=DITMGPFL
- NEW DITMGPFL,DITMGPFD
- D FILES
- Q
- ;
- PTCHK ; MAKE SURE "PT" CORRECT
- I '$D(DITMGMRG("NOTALK")) ;W $S(DITMGMRG("FILE")=DITMGFLE:"",1:"[")
- E S DITMU4("NOTALK")=1
- S DITMU4FI=DITMGFLE
- F DITMU4PF=0:0 S DITMU4PF=$O(^DD(DITMU4FI,0,"PT",DITMU4PF)) Q:DITMU4PF="" F DITMU4PD=0:0 S DITMU4PD=$O(^DD(DITMU4FI,0,"PT",DITMU4PF,DITMU4PD)) Q:DITMU4PD="" D CHKIT^DITMU4
- K DITMU4FI,DITMU4L,DITMU4PF,DITMU4PD,DITMU4X,DITMU4("NOTALK")
- ;I DITMGMRG("FILE")'=DITMGFLE,'$D(DITMGMRG("NOTALK")) W "]"
- Q
- ;
- EOJ ;
- K X,Y
- K %,DIPGM
- I $D(DITMGMQF) S DITMGMRG("QFLG")=DITMGMQF
- K DITMGMF,DITMGMFG,DITMGMFL,DITMGMQF,DITMGMT
- K AUPNDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX
- I $D(ZTQUEUED) S ZTREQ="@" Q
- I $D(ZTSK) K ^%ZTSK(ZTSK),ZTSK Q ; old Kernel
- I '$D(DITMGMRG("NOTALK")),$D(DITMGMRG("ERROR")) D EOJ2 K DITMGMRG("ERROR")
- Q
- ;
- EOJ2 ; List errors
- W !!,"The following errors occurred during the merge: ",!
- F %=0:0 S %=$O(DITMGMRG("ERROR",%)) Q:%'=+% W !,DITMGMRG("ERROR",%)
- W !
- K %
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDITMGMRG 2993 printed Feb 19, 2025@00:20:38 Page 2
- DITMGMRG ;SFISC/EDE(OHPRD)-RELINK/MERGE TWO ENTRIES BELOW POINTED TO FILE ;8MAR2006
- +1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- +4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- +5 ;;Licensed under the terms of the Apache License, Version 2.0.
- +6 ;
- +7 ; Merge two entries below pointed to file. See ^DITMDOC.
- +8 ;
- START ;
- +1 DO ^DITMGM1
- +2 IF 'DITMGMRG("GO")
- DO EOJ
- KILL DITMGMRG
- QUIT
- +3 DO EN
- +4 KILL DITMGMRG
- +5 QUIT
- +6 ;
- EN ; EXTERNAL ENTRY POINT
- +1 DO INIT^DITMGMRI
- +2 if $DATA(DITMGMQF)
- QUIT
- +3 DO STACK
- +4 if $DATA(DITMGMRG("NOTALK"))
- SET DITMGM2("NOTALK")=1
- +5 DO ^DITMGM2
- KILL DITMGM2("NOTALK")
- +6 KILL ^UTILITY("DITMGMRG",$JOB)
- +7 if '$DATA(DITMGMRG("NOTALK"))
- WRITE !!,"Merge complete",!!
- +8 DO EOJ
- +9 QUIT
- +10 ;
- STACK ;STACK ALL FILES POINTING TO POINTED TO FILE AND IF .01 FIELD
- +1 ;POINTING AND DINUM, FILES POINTING TO POINTING FILE, AND SO ON.
- +2 ;
- +3 if '$DATA(DITMGMRG("NOTALK"))
- WRITE !!,"Gathering files and checking 'PT' nodes"
- +4 NEW DITMGFLE,DITMGPFL,DITMGPFD,DITMSKP
- +5 KILL ^UTILITY("DITMGMRG",$JOB)
- +6 SET DITMGFLE=DITMGMRG("FILE")
- +7 DO FILES
- +8 QUIT
- +9 ;
- FILES ; CALLED RECURSIVELY
- +1 DO PTCHK
- +2 FOR DITMGPFL=0:0
- SET DITMGPFL=$ORDER(^DD(DITMGFLE,0,"PT",DITMGPFL))
- if DITMGPFL'=+DITMGPFL
- QUIT
- Begin DoDot:1
- +3 SET DITMSKP=0
- +4 IF $DATA(DITMGMRG("EXCLUDE",DITMGPFL))
- SET DITMSKP=1
- QUIT
- +5 ;I DITMGFLE=DITMGPFL S DITMSKP=1 Q
- +6 if '$DATA(DITMGMRG("PACKAGE"))
- QUIT
- +7 IF DITMGMRG("PACKAGE")
- if '$DATA(DITMGMRG("PACKAGE",DITMGPFL))
- SET DITMSKP=1
- QUIT
- +8 QUIT
- End DoDot:1
- IF 'DITMSKP
- DO FIELDS
- +9 QUIT
- +10 ;
- FIELDS ;
- +1 ;W:'$D(DITMGMRG("NOTALK")) "f"
- +2 FOR DITMGPFD=0:0
- SET DITMGPFD=$ORDER(^DD(DITMGFLE,0,"PT",DITMGPFL,DITMGPFD))
- if DITMGPFD'=+DITMGPFD
- QUIT
- Begin DoDot:1
- IHS ;NEW LINE
- IF DITMGPFL=2
- IF DITMGPFD=.082
- QUIT
- +1 SET ^UTILITY("DITMGMRG",$JOB,DITMGPFL,DITMGPFD)=DITMGFLE
- +2 ;W:'$D(DITMGMRG("NOTALK")) $S($D(^DD(DITMGPFL,0,"UP")):"s",1:".")
- +3 IF DITMGPFD=.01
- IF '$DATA(^DD(DITMGPFL,0,"UP"))
- IF $PIECE(^DD(DITMGPFL,.01,0),U,5,99)["DINUM"
- DO RECURSE
- End DoDot:1
- +4 QUIT
- +5 ;
- RECURSE ;
- +1 ;W:'$D(DITMGMRG("NOTALK")) "d"
- +2 NEW DITMGFLE
- +3 SET DITMGFLE=DITMGPFL
- +4 NEW DITMGPFL,DITMGPFD
- +5 DO FILES
- +6 QUIT
- +7 ;
- PTCHK ; MAKE SURE "PT" CORRECT
- +1 ;W $S(DITMGMRG("FILE")=DITMGFLE:"",1:"[")
- IF '$DATA(DITMGMRG("NOTALK"))
- +2 IF '$TEST
- SET DITMU4("NOTALK")=1
- +3 SET DITMU4FI=DITMGFLE
- +4 FOR DITMU4PF=0:0
- SET DITMU4PF=$ORDER(^DD(DITMU4FI,0,"PT",DITMU4PF))
- if DITMU4PF=""
- QUIT
- FOR DITMU4PD=0:0
- SET DITMU4PD=$ORDER(^DD(DITMU4FI,0,"PT",DITMU4PF,DITMU4PD))
- if DITMU4PD=""
- QUIT
- DO CHKIT^DITMU4
- +5 KILL DITMU4FI,DITMU4L,DITMU4PF,DITMU4PD,DITMU4X,DITMU4("NOTALK")
- +6 ;I DITMGMRG("FILE")'=DITMGFLE,'$D(DITMGMRG("NOTALK")) W "]"
- +7 QUIT
- +8 ;
- EOJ ;
- +1 KILL X,Y
- +2 KILL %,DIPGM
- +3 IF $DATA(DITMGMQF)
- SET DITMGMRG("QFLG")=DITMGMQF
- +4 KILL DITMGMF,DITMGMFG,DITMGMFL,DITMGMQF,DITMGMT
- +5 KILL AUPNDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX
- +6 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- QUIT
- +7 ; old Kernel
- IF $DATA(ZTSK)
- KILL ^%ZTSK(ZTSK),ZTSK
- QUIT
- +8 IF '$DATA(DITMGMRG("NOTALK"))
- IF $DATA(DITMGMRG("ERROR"))
- DO EOJ2
- KILL DITMGMRG("ERROR")
- +9 QUIT
- +10 ;
- EOJ2 ; List errors
- +1 WRITE !!,"The following errors occurred during the merge: ",!
- +2 FOR %=0:0
- SET %=$ORDER(DITMGMRG("ERROR",%))
- if %'=+%
- QUIT
- WRITE !,DITMGMRG("ERROR",%)
- +3 WRITE !
- +4 KILL %
- +5 QUIT