source: FOIAVistA/tag/r/MEDICINE-MC/MCDUP1.m

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