source: FOIAVistA/trunk/r/MEDICINE-MC/MCDUPM.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 3.4 KB
Line 
1MCDUPM ;WASH/DCB-DUPLICATION FINDER ;4/30/96 08:39
2 ;;2.3;Medicine;;09/13/1996
3START ;
4 K ^TMP($J,"DUP")
5 N FILE,FIL,ID,VAL,FLOC,IEN,YES
6 W @IOF,"Compiling Data: please wait",!!!!
7 F OFFSET=1:1 S IEN=+$P($T(FILE+OFFSET),";",3) Q:IEN'>0 D
8 . I IEN'=700.1 D MAIN2(IEN)
9 . Q
10 D MAIN2(697.5)
11 D ^MCDUPR
12 Q
13MAIN2(IEN) ;The 2nd half of main
14 W !,IEN,?20,$$GET1^DID(IEN,"","","NAME")
15 S FILE=$$GET1^DID(IEN,"","","GLOBAL NAME") K YES
16 S ID=$$ID(FILE)
17 D DUP(FILE,ID) K:'$D(YES) ^TMP($J,"DUP","I",IEN)
18 S ^TMP($J,"DUP","F",IEN)=$S($D(YES):1,1:0)
19 W ?60,$S($D(YES):"DUP",1:"NO DUP")
20 D:$D(YES) COMPILE^MCDUP1(FILE)
21 Q
22DUP(FILE,ID) ;Main Routine
23 N POINT,XDUP,COUNT
24 D INIT(FILE,ID),FINDDUPS(FILE,ID)
25 D:$D(YES) TABLE(FILE,ID)
26 Q
27ID(FILE) ;loads the Identifiers from the ID node
28 N MFILE,FIELD,TEMP S MFILE=+$P(FILE,"(",2),FIELD="",ID=".01"
29 F S FIELD=+$O(^DD(MFILE,0,"ID",FIELD)) Q:FIELD=0 S ID=ID_";"_FIELD
30 Q ID
31POINTER(FILE,POINT) ;load the pointers from th PT node
32 N TEMP,COUNT,MFILE S TEMP="",MFILE=+$P(FILE,"(",2)
33 F COUNT=1:1 S TEMP=$O(^DD(MFILE,0,"PT",TEMP)) Q:TEMP="" D
34 .I $D(^DD(TEMP,0)) S POINT(COUNT,"FILE")=TEMP,POINT(COUNT,"FIELD")=$O(^DD(MFILE,0,"PT",TEMP,""))
35 Q
36INIT(FILE,ID) ; Builds a global with all of the indefitiers
37 N TEMP,FILEN,ORD
38 S FILEN=+$P(FILE,"(",2)
39 S TEMP="",(COUNT,RECC,MREC)=0,ORD=FILE_"""B"",TEMP)"
40 F S TEMP=$O(@ORD) Q:TEMP="" D LOAD(FILE,TEMP,ID)
41 Q
42LOAD(FILE,NAME,ID) ;Loads the array.
43 N TEMP,REC,FILEN,COUNT
44 S (TEMP,REC)=""
45 S FILEN=+$P(FILE,"(",2)
46 F S REC=$O(@(FILE_"""B"""_",NAME,REC)")) Q:REC="" D
47 .I '$D(@(FILE_REC_",0)")) K ^MCAR(FILEN,"B",NAME,REC) Q
48 .D MOVE(FILE,FILEN,REC)
49 Q
50MOVE(FILE,FILEN,REC,COUNT) ;Get the Identifiers from the file
51 ;Builds a global of
52 ;^TMP($J,"DUP-I",file number,.01 field,internal rec number,"N") =
53 ; the identifiers of the record
54 N ID3,DA,DR,DIC,TMP,LOOP,TEMP,TMP1,HOLD
55 S HOLD=U,DIC=FILE,DIQ="ID3(",DA=REC,DR=ID,DIQ(0)="I" D EN^DIQ1
56 S TMP1=ID3(FILEN,REC,.01,"I") ; get the .01 field
57 F LOOP=2:1 Q:'$P(ID,";",LOOP) S TMP=$G(ID3(FILEN,REC,$P(ID,";",LOOP),"I")),HOLD=HOLD_TMP_U
58 S ^TMP($J,"DUP","I",FILEN,TMP1,REC,0)=HOLD
59 Q
60FINDDUPS(FILE,ID) ; Finds Duplications and store them in a temp global
61 N TEMP,FILEN S TEMP="",FILEN=+$P(FILE,"(",2)
62 F S TEMP=$O(^TMP($J,"DUP","I",FILEN,TEMP)) Q:TEMP="" D BUILD(TEMP,FILEN)
63 Q
64BUILD(TEMP,FILEN) ; Move the duplication in a single global
65 N LOOP,REC,ARR S (REC,LOOP)=""
66 F S REC=$O(^TMP($J,"DUP","I",FILEN,TEMP,REC)) Q:REC="" D
67 .S ARR(^TMP($J,"DUP","I",FILEN,TEMP,REC,0))=$G(ARR(^TMP($J,"DUP","I",FILEN,TEMP,REC,0)))_REC_"^"
68 F S LOOP=$O(ARR(LOOP)) Q:LOOP="" D
69 .S ^TMP($J,"DUP","I",FILEN,TEMP,$P(ARR(LOOP),U),1)=ARR(LOOP)_"*"
70 .S:$P(^TMP($J,"DUP","I",FILEN,TEMP,$P(ARR(LOOP),U),1),U,2)'="*" YES=""
71 Q
72TABLE(FILE,ID) ; Takes the temp array and builds a table for repointing
73 N LOOP,REC,OLD,TEMP,FILEN S TEMP="",FILEN=+$P(FILE,"(",2)
74 F S TEMP=$O(^TMP($J,"DUP","I",FILEN,TEMP)) Q:TEMP="" D
75 .S REC="" F S REC=+$O(^TMP($J,"DUP","I",FILEN,TEMP,REC)) Q:REC=0 D
76 ..I $D(^TMP($J,"DUP","I",FILEN,TEMP,REC,1)) D
77 ...F LOOP=1:1 S OLD=$P(^TMP($J,"DUP","I",FILEN,TEMP,REC,1),U,LOOP) Q:OLD="*" S ^TMP($J,"DUP","RT",FILEN,OLD)=REC
78 Q
79FILE ;;File#
80 ;;697
81 ;;696.4
82 ;;695.3
83 ;;693.5
84 ;;696.9
85 ;;699.82
86 ;;699.6
87 ;;699.84
88 ;;693.3
89 ;;699.85
90 ;;699.55
91 ;;695.6
92 ;;693.2
93 ;;694.1
94 ;;696.5
95 ;;696.2
96 ;;699.83
97 ;;693
98 ;;696.7
99 ;;699.57
100 ;;696.3
101 ;;699.88
102 ;;698.9
103 ;;695.9
104 ;;698.4
105 ;;698.6
106 ;;695.4
107 ;;696.1
108 ;;695.8
109 ;;695.1
110 ;;699.81
111 ;;696
112 ;;699.86
113 ;;695.5
114 ;;700.1
115 ;;690.2
116 ;;690.5
117 ;;694.8
Note: See TracBrowser for help on using the repository browser.