DITMGMRG ;SFISC/EDE(OHPRD)-RELINK/MERGE TWO ENTRIES BELOW POINTED TO FILE ;2/24/94 16:10 [ 04/02/2003 8:23 AM ]
;;22.0;VA FileMan;;**1001**;APR 1, 2003
;;22.0;VA FileMan;;Mar 30, 1999
;THIS ROUTINE CONTAINS AN IHS MODIFICATION BY IHS/ANMC/LJF 2/23/2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
; 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
. ;----- BEGIN IHS MODIFICATION
. ;INSERT NEW LINE. DO NOT REPOINT MERGED TO PATIENT FIELD #.082 OF
. ;PATIENT FILE #2
. ;ORIGINAL MODIFICATION BY IHS/ANMC/LJF 2/23/2000
. I DITMGPFL=2,DITMGPFD=.082 Q ;NEW LINE
. ;----- END IHS MODIFICATION
. 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
DITMGMRG ;SFISC/EDE(OHPRD)-RELINK/MERGE TWO ENTRIES BELOW POINTED TO FILE ;2/24/94 16:10 [ 04/02/2003 8:23 AM ]
+1 ;;22.0;VA FileMan;;**1001**;APR 1, 2003
+2 ;;22.0;VA FileMan;;Mar 30, 1999
+3 ;THIS ROUTINE CONTAINS AN IHS MODIFICATION BY IHS/ANMC/LJF 2/23/2000
+4 ;Per VHA Directive 10-93-142, this routine should not be modified.
+5 ;
+6 ; Merge two entries below pointed to file. See ^DITMDOC.
+7 ;
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
+3 ;----- BEGIN IHS MODIFICATION
+4 ;INSERT NEW LINE. DO NOT REPOINT MERGED TO PATIENT FIELD #.082 OF
+5 ;PATIENT FILE #2
+6 ;ORIGINAL MODIFICATION BY IHS/ANMC/LJF 2/23/2000
+7 ;NEW LINE
IF DITMGPFL=2
IF DITMGPFD=.082
QUIT
+8 ;----- END IHS MODIFICATION
+9 SET ^UTILITY("DITMGMRG",$JOB,DITMGPFL,DITMGPFD)=DITMGFLE
+10 ;W:'$D(DITMGMRG("NOTALK")) $S($D(^DD(DITMGPFL,0,"UP")):"s",1:".")
+11 IF DITMGPFD=.01
IF '$DATA(^DD(DITMGPFL,0,"UP"))
IF $PIECE(^DD(DITMGPFL,.01,0),U,5,99)["DINUM"
DO RECURSE
End DoDot:1
+12 QUIT
+13 ;
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
