MCDUP1 ;WASH/DCB-Repoints the pointed to file and removes the dup ;11/8/95 10:50
;;2.3;Medicine;;09/13/1996
COMPILE(FILE) ;
; This routine requires ^TMP($J,"DUP",FILE
N POINT,TEMP,POINTER,NFILE
W !,?10,"CHECKING FILES FOR POINTERS TO DUPLICATE ENTRIES:"
S NFILE=+$P(FILE,"(",2)
Q:'$D(^TMP($J,"DUP","RT",NFILE)) ;The global that holds the repointing table
S ^TMP($J,"DUP","RT",NFILE,0)=0 ;For null input
D POINTER^MCDUPM(FILE,.POINT) ;get THE POINTERS
;Loop through the pointers file and repoint the records
S TEMP="" F S TEMP=$O(POINT(TEMP)) Q:TEMP="" D REPOINT(FILE,TEMP,.POINT)
Q
REPOINT(FILE,POINTER,POINT) ;Repoints the records
N MFILE,FIELD,PFILE
S MFILE=+$P(FILE,"(",2),PFILE=POINT(POINTER,"FILE"),FIELD=POINT(POINTER,"FIELD")
W !,?20,PFILE," "
;Determine if its a subfile or a mainfile.
I $P(^DD(PFILE,0),U)="FIELD" D
. D MAINFILE(PFILE,MFILE,FIELD)
. Q
E D
. D SUBFILE(PFILE,MFILE,FIELD)
. Q
Q
MAINFILE(PFILE,FILE,FIELD) ;Repoints records within the main file
N REC,TEMP,NODE,PIECE,CFILE,DA,DR
;get the node and piece
S TEMP=$$GET1^DID(PFILE,FIELD,"","GLOBAL SUBSCRIPT LOCATION")
S NODE=$P(TEMP,";"),PIECE=$P(TEMP,";",2)
S CFILE=$$GET1^DID(PFILE,"","","GLOBAL NAME") ; get the global location
S REC=0 F S REC=+$O(@(CFILE_"REC)")) Q:REC=0 D ;Go through the file
.; Get the old and new pointers.
.S OLDREC=+$P($G(@(CFILE_"REC,NODE)")),U,PIECE)
.S NEWREC=$P(^TMP($J,"DUP","RT",FILE,OLDREC),U),$P(^TMP($J,"DUP","RT",FILE,OLDREC),U,2)=+$P(^TMP($J,"DUP","RT",FILE,OLDREC),U,2)+1
.; If old and new don't match then repoint the record to the new pointer
.I OLDREC'=NEWREC D
..S TEMP="$P("_CFILE_REC_","_NODE_"),U,"_PIECE_")"
..S TEMP2="M"_U_PFILE_U_REC_U_FIELD_U_NODE_U_PIECE
..D JOURNAL(.VAL,FILE,TEMP,TEMP2,OLDREC,NEWREC)
Q
SUBFILE(SUBFILE,FILE,SFIELD) ;Repoint records within the Subfile.
N SNODE,SPIECE,FIELD,DIE,DR,DA,TEMP,MFILE,CFILE,MREC,SREC,NAME,MNODE,MPIECE
S MAINFILE=^DD(SUBFILE,0,"UP") ;Get the main file
S NAME=$P(^DD(SUBFILE,0)," SUB-FIELD^",1) ;Get the field name
S TEMP=$$GET1^DID(SUBFILE,SFIELD,"","GLOBAL SUBSCRIPT LOCATION")
S SNODE=$P(TEMP,";"),SPIECE=$P(TEMP,";",2) ;Get the node of piece of the subfile
S FIELD=$O(^DD(MAINFILE,"B",NAME,"")) ;Get the field number in the main file
S TEMP=$$GET1^DID(MAINFILE,FIELD,"","GLOBAL SUBSCRIPT LOCATION")
S MNODE=$P(TEMP,";"),MPIECE=$P(TEMP,";",2) ; Get the main node and piece of the file
I ^DD(MAINFILE,0)["SUB-FIELD" D SUBF(SUBFILE,FILE,SFIELD,MAINFILE,SNODE,FIELD,MNODE,MPIECE) Q
S CFILE=$$GET1^DID(MAINFILE,"","","GLOBAL NAME") ; Get global location
S MREC=0 F S MREC=+$O(@(CFILE_"MREC)")) Q:MREC=0 D ;Loop through Main file
.S SREC=0 F S SREC=+$O(@(CFILE_"MREC,MNODE,SREC)")) Q:SREC=0 D ;Loop through the subfile within the main file.
..; Get the old and new pointer
..S OLDREC=+$P($G(@(CFILE_"MREC,MNODE,SREC,SNODE)")),U,SPIECE)
..Q:'$D(^MCAR(FILE,OLDREC,0))
..S NEWREC=$P(^TMP($J,"DUP","RT",FILE,OLDREC),U),$P(^TMP($J,"DUP","RT",FILE,OLDREC),U,2)=+$P(^TMP($J,"DUP","RT",FILE,OLDREC),U,2)+1
..;if old and new pointers don't match then repoint the subfile to the new pointer.
..I OLDREC'=NEWREC D
...S TEMP="$P("_CFILE_MREC_","_MNODE_","_SREC_","_SNODE_"),U,"_SPIECE_")"
...S TEMP2="S"_U_MAINFILE_U_MREC_U_FIELD_U_MNODE_U_SUBFILE_U_SREC_U_SFIELD_U_SNODE_U_SPIECE
...D JOURNAL(.VAL,FILE,TEMP,TEMP2,OLDREC,NEWREC)
Q
SUBF(SUBFILE,FILE,SFIELD1,SFILE1,SNODE1,SFIELD,SNODE,SPIECE) ;
;Repoints subfile within a subfile
N MFIELD,MFN,MNODE,MAINFILE,REC,SREC,SREC1
S MAINFILE=^DD(SFILE1,0,"UP"),CFILE=$$GET1^DID(MAINFILE,"","","GLOBAL NAME")
S MFN=""
F S MFN=$O(^DD(SFILE1,0,"NM",MFN)) Q:MFN="" D
. S MFIELD=0
. F S MFIELD=$O(^DD(MAINFILE,"B",MFN,MFIELD)) Q:MFIELD'>0 D
.. I $G(^DD(MAINFILE,MFIELD,0))]"" D SUBF0
.. Q
. Q
Q
SUBF0 ;
S TEMP=$$GET1^DID(MAINFILE,MFIELD,"","GLOBAL SUBSCRIPT LOCATION")
S MNODE=$P(TEMP,";")
S TEMP=$$GET1^DID(SUBFILE,SFIELD1,"","GLOBAL SUBSCRIPT LOCATION")
S SNODE1=$P(TEMP,";")
S SPIECE=$P(TEMP,";",2)
S REC=0 F S REC=+$O(@(CFILE_"REC)")) Q:REC=0 D
.S SREC=0 F S SREC=+$O(@(CFILE_"REC,MNODE,SREC)")) Q:SREC=0 D
..S SREC1=0 F S SREC1=+$O(@(CFILE_"REC,MNODE,SREC,SNODE,SREC1)")) Q:SREC1=0 D
...S OLDREC=+$P($G(@(CFILE_"REC,MNODE,SREC,SNODE,SREC1,SNODE1)")),U,SPIECE)
...Q:'$D(^TMP($J,"DUP","RT",FILE,OLDREC))
...S NEWREC=$P(^TMP($J,"DUP","RT",FILE,OLDREC),U),$P(^TMP($J,"DUP","RT",FILE,OLDREC),U,2)=+$P(^TMP($J,"DUP","RT",FILE,OLDREC),U,2)+1
...I OLDREC'=NEWREC D
....S TEMP="$P("_CFILE_REC_","_MNODE_","_SREC_","_SNODE_","_SREC1_","_SNODE1_"),U,"_SPIECE_")"
....S TEMP2="SS"_U_MAINFILE_U_REC_U_FIELD_U_MNODE_U_SUBFILE_U_SREC_U_SFIELD_U_SNODE_U_SFILE1_U_SREC1_U_SFIELD1_U_SNODE1_U_SPIECE
....D JOURNAL(.VAL,FILE,TEMP,TEMP2,OLDREC,NEWREC)
Q
JOURNAL(VAL,FILE,TEMP,TEMP2,OLDREC,NEWREC) ;Stores the changes that was made
S VAL=$G(VAL)+1
S ^TMP($J,"DUP","J",FILE,VAL,0)=TEMP
S ^TMP($J,"DUP","J",FILE,VAL,1)=TEMP2
S ^TMP($J,"DUP","J",FILE,VAL,"OLD")=OLDREC
S ^TMP($J,"DUP","J",FILE,VAL,"NEW")=NEWREC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCDUP1 5098 printed Dec 13, 2024@02:14:53 Page 2
MCDUP1 ;WASH/DCB-Repoints the pointed to file and removes the dup ;11/8/95 10:50
+1 ;;2.3;Medicine;;09/13/1996
COMPILE(FILE) ;
+1 ; This routine requires ^TMP($J,"DUP",FILE
+2 NEW POINT,TEMP,POINTER,NFILE
+3 WRITE !,?10,"CHECKING FILES FOR POINTERS TO DUPLICATE ENTRIES:"
+4 SET NFILE=+$PIECE(FILE,"(",2)
+5 ;The global that holds the repointing table
if '$DATA(^TMP($JOB,"DUP","RT",NFILE))
QUIT
+6 ;For null input
SET ^TMP($JOB,"DUP","RT",NFILE,0)=0
+7 ;get THE POINTERS
DO POINTER^MCDUPM(FILE,.POINT)
+8 ;Loop through the pointers file and repoint the records
+9 SET TEMP=""
FOR
SET TEMP=$ORDER(POINT(TEMP))
if TEMP=""
QUIT
DO REPOINT(FILE,TEMP,.POINT)
+10 QUIT
REPOINT(FILE,POINTER,POINT) ;Repoints the records
+1 NEW MFILE,FIELD,PFILE
+2 SET MFILE=+$PIECE(FILE,"(",2)
SET PFILE=POINT(POINTER,"FILE")
SET FIELD=POINT(POINTER,"FIELD")
+3 WRITE !,?20,PFILE," "
+4 ;Determine if its a subfile or a mainfile.
+5 IF $PIECE(^DD(PFILE,0),U)="FIELD"
Begin DoDot:1
+6 DO MAINFILE(PFILE,MFILE,FIELD)
+7 QUIT
End DoDot:1
+8 IF '$TEST
Begin DoDot:1
+9 DO SUBFILE(PFILE,MFILE,FIELD)
+10 QUIT
End DoDot:1
+11 QUIT
MAINFILE(PFILE,FILE,FIELD) ;Repoints records within the main file
+1 NEW REC,TEMP,NODE,PIECE,CFILE,DA,DR
+2 ;get the node and piece
+3 SET TEMP=$$GET1^DID(PFILE,FIELD,"","GLOBAL SUBSCRIPT LOCATION")
+4 SET NODE=$PIECE(TEMP,";")
SET PIECE=$PIECE(TEMP,";",2)
+5 ; get the global location
SET CFILE=$$GET1^DID(PFILE,"","","GLOBAL NAME")
+6 ;Go through the file
SET REC=0
FOR
SET REC=+$ORDER(@(CFILE_"REC)"))
if REC=0
QUIT
Begin DoDot:1
+7 ; Get the old and new pointers.
+8 SET OLDREC=+$PIECE($GET(@(CFILE_"REC,NODE)")),U,PIECE)
+9 SET NEWREC=$PIECE(^TMP($JOB,"DUP","RT",FILE,OLDREC),U)
SET $PIECE(^TMP($JOB,"DUP","RT",FILE,OLDREC),U,2)=+$PIECE(^TMP($JOB,"DUP","RT",FILE,OLDREC),U,2)+1
+10 ; If old and new don't match then repoint the record to the new pointer
+11 IF OLDREC'=NEWREC
Begin DoDot:2
+12 SET TEMP="$P("_CFILE_REC_","_NODE_"),U,"_PIECE_")"
+13 SET TEMP2="M"_U_PFILE_U_REC_U_FIELD_U_NODE_U_PIECE
+14 DO JOURNAL(.VAL,FILE,TEMP,TEMP2,OLDREC,NEWREC)
End DoDot:2
End DoDot:1
+15 QUIT
SUBFILE(SUBFILE,FILE,SFIELD) ;Repoint records within the Subfile.
+1 NEW SNODE,SPIECE,FIELD,DIE,DR,DA,TEMP,MFILE,CFILE,MREC,SREC,NAME,MNODE,MPIECE
+2 ;Get the main file
SET MAINFILE=^DD(SUBFILE,0,"UP")
+3 ;Get the field name
SET NAME=$PIECE(^DD(SUBFILE,0)," SUB-FIELD^",1)
+4 SET TEMP=$$GET1^DID(SUBFILE,SFIELD,"","GLOBAL SUBSCRIPT LOCATION")
+5 ;Get the node of piece of the subfile
SET SNODE=$PIECE(TEMP,";")
SET SPIECE=$PIECE(TEMP,";",2)
+6 ;Get the field number in the main file
SET FIELD=$ORDER(^DD(MAINFILE,"B",NAME,""))
+7 SET TEMP=$$GET1^DID(MAINFILE,FIELD,"","GLOBAL SUBSCRIPT LOCATION")
+8 ; Get the main node and piece of the file
SET MNODE=$PIECE(TEMP,";")
SET MPIECE=$PIECE(TEMP,";",2)
+9 IF ^DD(MAINFILE,0)["SUB-FIELD"
DO SUBF(SUBFILE,FILE,SFIELD,MAINFILE,SNODE,FIELD,MNODE,MPIECE)
QUIT
+10 ; Get global location
SET CFILE=$$GET1^DID(MAINFILE,"","","GLOBAL NAME")
+11 ;Loop through Main file
SET MREC=0
FOR
SET MREC=+$ORDER(@(CFILE_"MREC)"))
if MREC=0
QUIT
Begin DoDot:1
+12 ;Loop through the subfile within the main file.
SET SREC=0
FOR
SET SREC=+$ORDER(@(CFILE_"MREC,MNODE,SREC)"))
if SREC=0
QUIT
Begin DoDot:2
+13 ; Get the old and new pointer
+14 SET OLDREC=+$PIECE($GET(@(CFILE_"MREC,MNODE,SREC,SNODE)")),U,SPIECE)
+15 if '$DATA(^MCAR(FILE,OLDREC,0))
QUIT
+16 SET NEWREC=$PIECE(^TMP($JOB,"DUP","RT",FILE,OLDREC),U)
SET $PIECE(^TMP($JOB,"DUP","RT",FILE,OLDREC),U,2)=+$PIECE(^TMP($JOB,"DUP","RT",FILE,OLDREC),U,2)+1
+17 ;if old and new pointers don't match then repoint the subfile to the new pointer.
+18 IF OLDREC'=NEWREC
Begin DoDot:3
+19 SET TEMP="$P("_CFILE_MREC_","_MNODE_","_SREC_","_SNODE_"),U,"_SPIECE_")"
+20 SET TEMP2="S"_U_MAINFILE_U_MREC_U_FIELD_U_MNODE_U_SUBFILE_U_SREC_U_SFIELD_U_SNODE_U_SPIECE
+21 DO JOURNAL(.VAL,FILE,TEMP,TEMP2,OLDREC,NEWREC)
End DoDot:3
End DoDot:2
End DoDot:1
+22 QUIT
SUBF(SUBFILE,FILE,SFIELD1,SFILE1,SNODE1,SFIELD,SNODE,SPIECE) ;
+1 ;Repoints subfile within a subfile
+2 NEW MFIELD,MFN,MNODE,MAINFILE,REC,SREC,SREC1
+3 SET MAINFILE=^DD(SFILE1,0,"UP")
SET CFILE=$$GET1^DID(MAINFILE,"","","GLOBAL NAME")
+4 SET MFN=""
+5 FOR
SET MFN=$ORDER(^DD(SFILE1,0,"NM",MFN))
if MFN=""
QUIT
Begin DoDot:1
+6 SET MFIELD=0
+7 FOR
SET MFIELD=$ORDER(^DD(MAINFILE,"B",MFN,MFIELD))
if MFIELD'>0
QUIT
Begin DoDot:2
+8 IF $GET(^DD(MAINFILE,MFIELD,0))]""
DO SUBF0
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 QUIT
SUBF0 ;
+1 SET TEMP=$$GET1^DID(MAINFILE,MFIELD,"","GLOBAL SUBSCRIPT LOCATION")
+2 SET MNODE=$PIECE(TEMP,";")
+3 SET TEMP=$$GET1^DID(SUBFILE,SFIELD1,"","GLOBAL SUBSCRIPT LOCATION")
+4 SET SNODE1=$PIECE(TEMP,";")
+5 SET SPIECE=$PIECE(TEMP,";",2)
+6 SET REC=0
FOR
SET REC=+$ORDER(@(CFILE_"REC)"))
if REC=0
QUIT
Begin DoDot:1
+7 SET SREC=0
FOR
SET SREC=+$ORDER(@(CFILE_"REC,MNODE,SREC)"))
if SREC=0
QUIT
Begin DoDot:2
+8 SET SREC1=0
FOR
SET SREC1=+$ORDER(@(CFILE_"REC,MNODE,SREC,SNODE,SREC1)"))
if SREC1=0
QUIT
Begin DoDot:3
+9 SET OLDREC=+$PIECE($GET(@(CFILE_"REC,MNODE,SREC,SNODE,SREC1,SNODE1)")),U,SPIECE)
+10 if '$DATA(^TMP($JOB,"DUP","RT",FILE,OLDREC))
QUIT
+11 SET NEWREC=$PIECE(^TMP($JOB,"DUP","RT",FILE,OLDREC),U)
SET $PIECE(^TMP($JOB,"DUP","RT",FILE,OLDREC),U,2)=+$PIECE(^TMP($JOB,"DUP","RT",FILE,OLDREC),U,2)+1
+12 IF OLDREC'=NEWREC
Begin DoDot:4
+13 SET TEMP="$P("_CFILE_REC_","_MNODE_","_SREC_","_SNODE_","_SREC1_","_SNODE1_"),U,"_SPIECE_")"
+14 SET TEMP2="SS"_U_MAINFILE_U_REC_U_FIELD_U_MNODE_U_SUBFILE_U_SREC_U_SFIELD_U_SNODE_U_SFILE1_U_SREC1_U_SFIELD1_U_SNODE1_U_SPIECE
+15 DO JOURNAL(.VAL,FILE,TEMP,TEMP2,OLDREC,NEWREC)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+16 QUIT
JOURNAL(VAL,FILE,TEMP,TEMP2,OLDREC,NEWREC) ;Stores the changes that was made
+1 SET VAL=$GET(VAL)+1
+2 SET ^TMP($JOB,"DUP","J",FILE,VAL,0)=TEMP
+3 SET ^TMP($JOB,"DUP","J",FILE,VAL,1)=TEMP2
+4 SET ^TMP($JOB,"DUP","J",FILE,VAL,"OLD")=OLDREC
+5 SET ^TMP($JOB,"DUP","J",FILE,VAL,"NEW")=NEWREC
+6 QUIT
