- 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
- 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
