source: FOIAVistA/trunk/r/MEDICINE-MC/MCDUP1.m@ 1755

Last change on this file since 1755 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.9 KB
Line 
1MCDUP1 ;WASH/DCB-Repoints the pointed to file and removes the dup ;11/8/95 10:50
2 ;;2.3;Medicine;;09/13/1996
3COMPILE(FILE) ;
4 ; This routine requires ^TMP($J,"DUP",FILE
5 N POINT,TEMP,POINTER,NFILE
6 W !,?10,"CHECKING FILES FOR POINTERS TO DUPLICATE ENTRIES:"
7 S NFILE=+$P(FILE,"(",2)
8 Q:'$D(^TMP($J,"DUP","RT",NFILE)) ;The global that holds the repointing table
9 S ^TMP($J,"DUP","RT",NFILE,0)=0 ;For null input
10 D POINTER^MCDUPM(FILE,.POINT) ;get THE POINTERS
11 ;Loop through the pointers file and repoint the records
12 S TEMP="" F S TEMP=$O(POINT(TEMP)) Q:TEMP="" D REPOINT(FILE,TEMP,.POINT)
13 Q
14REPOINT(FILE,POINTER,POINT) ;Repoints the records
15 N MFILE,FIELD,PFILE
16 S MFILE=+$P(FILE,"(",2),PFILE=POINT(POINTER,"FILE"),FIELD=POINT(POINTER,"FIELD")
17 W !,?20,PFILE," "
18 ;Determine if its a subfile or a mainfile.
19 I $P(^DD(PFILE,0),U)="FIELD" D
20 . D MAINFILE(PFILE,MFILE,FIELD)
21 . Q
22 E D
23 . D SUBFILE(PFILE,MFILE,FIELD)
24 . Q
25 Q
26MAINFILE(PFILE,FILE,FIELD) ;Repoints records within the main file
27 N REC,TEMP,NODE,PIECE,CFILE,DA,DR
28 ;get the node and piece
29 S TEMP=$$GET1^DID(PFILE,FIELD,"","GLOBAL SUBSCRIPT LOCATION")
30 S NODE=$P(TEMP,";"),PIECE=$P(TEMP,";",2)
31 S CFILE=$$GET1^DID(PFILE,"","","GLOBAL NAME") ; get the global location
32 S REC=0 F S REC=+$O(@(CFILE_"REC)")) Q:REC=0 D ;Go through the file
33 .; Get the old and new pointers.
34 .S OLDREC=+$P($G(@(CFILE_"REC,NODE)")),U,PIECE)
35 .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
36 .; If old and new don't match then repoint the record to the new pointer
37 .I OLDREC'=NEWREC D
38 ..S TEMP="$P("_CFILE_REC_","_NODE_"),U,"_PIECE_")"
39 ..S TEMP2="M"_U_PFILE_U_REC_U_FIELD_U_NODE_U_PIECE
40 ..D JOURNAL(.VAL,FILE,TEMP,TEMP2,OLDREC,NEWREC)
41 Q
42SUBFILE(SUBFILE,FILE,SFIELD) ;Repoint records within the Subfile.
43 N SNODE,SPIECE,FIELD,DIE,DR,DA,TEMP,MFILE,CFILE,MREC,SREC,NAME,MNODE,MPIECE
44 S MAINFILE=^DD(SUBFILE,0,"UP") ;Get the main file
45 S NAME=$P(^DD(SUBFILE,0)," SUB-FIELD^",1) ;Get the field name
46 S TEMP=$$GET1^DID(SUBFILE,SFIELD,"","GLOBAL SUBSCRIPT LOCATION")
47 S SNODE=$P(TEMP,";"),SPIECE=$P(TEMP,";",2) ;Get the node of piece of the subfile
48 S FIELD=$O(^DD(MAINFILE,"B",NAME,"")) ;Get the field number in the main file
49 S TEMP=$$GET1^DID(MAINFILE,FIELD,"","GLOBAL SUBSCRIPT LOCATION")
50 S MNODE=$P(TEMP,";"),MPIECE=$P(TEMP,";",2) ; Get the main node and piece of the file
51 I ^DD(MAINFILE,0)["SUB-FIELD" D SUBF(SUBFILE,FILE,SFIELD,MAINFILE,SNODE,FIELD,MNODE,MPIECE) Q
52 S CFILE=$$GET1^DID(MAINFILE,"","","GLOBAL NAME") ; Get global location
53 S MREC=0 F S MREC=+$O(@(CFILE_"MREC)")) Q:MREC=0 D ;Loop through Main file
54 .S SREC=0 F S SREC=+$O(@(CFILE_"MREC,MNODE,SREC)")) Q:SREC=0 D ;Loop through the subfile within the main file.
55 ..; Get the old and new pointer
56 ..S OLDREC=+$P($G(@(CFILE_"MREC,MNODE,SREC,SNODE)")),U,SPIECE)
57 ..Q:'$D(^MCAR(FILE,OLDREC,0))
58 ..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
59 ..;if old and new pointers don't match then repoint the subfile to the new pointer.
60 ..I OLDREC'=NEWREC D
61 ...S TEMP="$P("_CFILE_MREC_","_MNODE_","_SREC_","_SNODE_"),U,"_SPIECE_")"
62 ...S TEMP2="S"_U_MAINFILE_U_MREC_U_FIELD_U_MNODE_U_SUBFILE_U_SREC_U_SFIELD_U_SNODE_U_SPIECE
63 ...D JOURNAL(.VAL,FILE,TEMP,TEMP2,OLDREC,NEWREC)
64 Q
65SUBF(SUBFILE,FILE,SFIELD1,SFILE1,SNODE1,SFIELD,SNODE,SPIECE) ;
66 ;Repoints subfile within a subfile
67 N MFIELD,MFN,MNODE,MAINFILE,REC,SREC,SREC1
68 S MAINFILE=^DD(SFILE1,0,"UP"),CFILE=$$GET1^DID(MAINFILE,"","","GLOBAL NAME")
69 S MFN=""
70 F S MFN=$O(^DD(SFILE1,0,"NM",MFN)) Q:MFN="" D
71 . S MFIELD=0
72 . F S MFIELD=$O(^DD(MAINFILE,"B",MFN,MFIELD)) Q:MFIELD'>0 D
73 .. I $G(^DD(MAINFILE,MFIELD,0))]"" D SUBF0
74 .. Q
75 . Q
76 Q
77SUBF0 ;
78 S TEMP=$$GET1^DID(MAINFILE,MFIELD,"","GLOBAL SUBSCRIPT LOCATION")
79 S MNODE=$P(TEMP,";")
80 S TEMP=$$GET1^DID(SUBFILE,SFIELD1,"","GLOBAL SUBSCRIPT LOCATION")
81 S SNODE1=$P(TEMP,";")
82 S SPIECE=$P(TEMP,";",2)
83 S REC=0 F S REC=+$O(@(CFILE_"REC)")) Q:REC=0 D
84 .S SREC=0 F S SREC=+$O(@(CFILE_"REC,MNODE,SREC)")) Q:SREC=0 D
85 ..S SREC1=0 F S SREC1=+$O(@(CFILE_"REC,MNODE,SREC,SNODE,SREC1)")) Q:SREC1=0 D
86 ...S OLDREC=+$P($G(@(CFILE_"REC,MNODE,SREC,SNODE,SREC1,SNODE1)")),U,SPIECE)
87 ...Q:'$D(^TMP($J,"DUP","RT",FILE,OLDREC))
88 ...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
89 ...I OLDREC'=NEWREC D
90 ....S TEMP="$P("_CFILE_REC_","_MNODE_","_SREC_","_SNODE_","_SREC1_","_SNODE1_"),U,"_SPIECE_")"
91 ....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
92 ....D JOURNAL(.VAL,FILE,TEMP,TEMP2,OLDREC,NEWREC)
93 Q
94JOURNAL(VAL,FILE,TEMP,TEMP2,OLDREC,NEWREC) ;Stores the changes that was made
95 S VAL=$G(VAL)+1
96 S ^TMP($J,"DUP","J",FILE,VAL,0)=TEMP
97 S ^TMP($J,"DUP","J",FILE,VAL,1)=TEMP2
98 S ^TMP($J,"DUP","J",FILE,VAL,"OLD")=OLDREC
99 S ^TMP($J,"DUP","J",FILE,VAL,"NEW")=NEWREC
100 Q
Note: See TracBrowser for help on using the repository browser.