source: WorldVistAEHR/trunk/r/MEDICINE-MC/MCDUPM.m@ 1046

MCDUPM ;WASH/DCB-DUPLICATION FINDER ;4/30/96  08:39

 ;;2.3;Medicine;;09/13/1996

START ;

 K ^TMP($J,"DUP")

 N FILE,FIL,ID,VAL,FLOC,IEN,YES

 W @IOF,"Compiling Data: please wait",!!!!

 F OFFSET=1:1 S IEN=+$P($T(FILE+OFFSET),";",3) Q:IEN'>0  D

 . I IEN'=700.1 D MAIN2(IEN)

 . Q

 D MAIN2(697.5)

 D ^MCDUPR

 Q

MAIN2(IEN) ;The 2nd half of main

 W !,IEN,?20,$$GET1^DID(IEN,"","","NAME")

 S FILE=$$GET1^DID(IEN,"","","GLOBAL NAME") K YES

 S ID=$$ID(FILE)

 D DUP(FILE,ID) K:'$D(YES) ^TMP($J,"DUP","I",IEN)

 S ^TMP($J,"DUP","F",IEN)=$S($D(YES):1,1:0)

 W ?60,$S($D(YES):"DUP",1:"NO DUP")

 D:$D(YES) COMPILE^MCDUP1(FILE)

 Q

DUP(FILE,ID) ;Main Routine

 N POINT,XDUP,COUNT

 D INIT(FILE,ID),FINDDUPS(FILE,ID)

 D:$D(YES) TABLE(FILE,ID)

 Q

ID(FILE) ;loads the Identifiers from the ID node

 N MFILE,FIELD,TEMP S MFILE=+$P(FILE,"(",2),FIELD="",ID=".01"

 F  S FIELD=+$O(^DD(MFILE,0,"ID",FIELD)) Q:FIELD=0  S ID=ID_";"_FIELD

 Q ID

POINTER(FILE,POINT) ;load the pointers from th PT node

 N TEMP,COUNT,MFILE S TEMP="",MFILE=+$P(FILE,"(",2)

 F COUNT=1:1 S TEMP=$O(^DD(MFILE,0,"PT",TEMP)) Q:TEMP=""  D

 .I $D(^DD(TEMP,0)) S POINT(COUNT,"FILE")=TEMP,POINT(COUNT,"FIELD")=$O(^DD(MFILE,0,"PT",TEMP,""))

 Q

INIT(FILE,ID) ; Builds a global with all of the indefitiers

 N TEMP,FILEN,ORD

 S FILEN=+$P(FILE,"(",2)

 S TEMP="",(COUNT,RECC,MREC)=0,ORD=FILE_"""B"",TEMP)"

 F  S TEMP=$O(@ORD) Q:TEMP=""  D LOAD(FILE,TEMP,ID)

 Q

LOAD(FILE,NAME,ID) ;Loads the array.

 N TEMP,REC,FILEN,COUNT

 S (TEMP,REC)=""

 S FILEN=+$P(FILE,"(",2)

 F  S REC=$O(@(FILE_"""B"""_",NAME,REC)")) Q:REC=""  D 

 .I '$D(@(FILE_REC_",0)")) K ^MCAR(FILEN,"B",NAME,REC) Q

 .D MOVE(FILE,FILEN,REC)

 Q

MOVE(FILE,FILEN,REC,COUNT) ;Get the Identifiers from the file

 ;Builds a global of

 ;^TMP($J,"DUP-I",file number,.01 field,internal rec number,"N") =

 ;         the identifiers of the record

 N ID3,DA,DR,DIC,TMP,LOOP,TEMP,TMP1,HOLD

 S HOLD=U,DIC=FILE,DIQ="ID3(",DA=REC,DR=ID,DIQ(0)="I" D EN^DIQ1

 S TMP1=ID3(FILEN,REC,.01,"I") ; get the .01 field

 F LOOP=2:1 Q:'$P(ID,";",LOOP)  S TMP=$G(ID3(FILEN,REC,$P(ID,";",LOOP),"I")),HOLD=HOLD_TMP_U

 S ^TMP($J,"DUP","I",FILEN,TMP1,REC,0)=HOLD

 Q

FINDDUPS(FILE,ID) ; Finds Duplications and store them in a temp global

 N TEMP,FILEN S TEMP="",FILEN=+$P(FILE,"(",2)

 F  S TEMP=$O(^TMP($J,"DUP","I",FILEN,TEMP)) Q:TEMP=""  D BUILD(TEMP,FILEN)

 Q

BUILD(TEMP,FILEN) ; Move the duplication in a single global

 N LOOP,REC,ARR S (REC,LOOP)=""

 F  S REC=$O(^TMP($J,"DUP","I",FILEN,TEMP,REC)) Q:REC=""  D

 .S ARR(^TMP($J,"DUP","I",FILEN,TEMP,REC,0))=$G(ARR(^TMP($J,"DUP","I",FILEN,TEMP,REC,0)))_REC_"^"

 F  S LOOP=$O(ARR(LOOP)) Q:LOOP=""  D

 .S ^TMP($J,"DUP","I",FILEN,TEMP,$P(ARR(LOOP),U),1)=ARR(LOOP)_"*"

 .S:$P(^TMP($J,"DUP","I",FILEN,TEMP,$P(ARR(LOOP),U),1),U,2)'="*" YES=""

 Q

TABLE(FILE,ID) ; Takes the temp array and builds a table for repointing

 N LOOP,REC,OLD,TEMP,FILEN S TEMP="",FILEN=+$P(FILE,"(",2)

 F  S TEMP=$O(^TMP($J,"DUP","I",FILEN,TEMP)) Q:TEMP=""  D

 .S REC="" F  S REC=+$O(^TMP($J,"DUP","I",FILEN,TEMP,REC)) Q:REC=0  D

 ..I $D(^TMP($J,"DUP","I",FILEN,TEMP,REC,1)) D

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

 Q

FILE ;;File#

 ;;697

 ;;696.4

 ;;695.3

 ;;693.5

 ;;696.9

 ;;699.82

 ;;699.6

 ;;699.84

 ;;693.3

 ;;699.85

 ;;699.55

 ;;695.6

 ;;693.2

 ;;694.1

 ;;696.5

 ;;696.2

 ;;699.83

 ;;693

 ;;696.7

 ;;699.57

 ;;696.3

 ;;699.88

 ;;698.9

 ;;695.9

 ;;698.4

 ;;698.6

 ;;695.4

 ;;696.1

 ;;695.8

 ;;695.1

 ;;699.81

 ;;696

 ;;699.86

 ;;695.5

 ;;700.1

 ;;690.2

 ;;690.5

 ;;694.8