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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCDUPM 3644 printed Nov 22, 2024@17:24:56 Page 2
MCDUPM ;WASH/DCB-DUPLICATION FINDER ;4/30/96 08:39
+1 ;;2.3;Medicine;;09/13/1996
START ;
+1 KILL ^TMP($JOB,"DUP")
+2 NEW FILE,FIL,ID,VAL,FLOC,IEN,YES
+3 WRITE @IOF,"Compiling Data: please wait",!!!!
+4 FOR OFFSET=1:1
SET IEN=+$PIECE($TEXT(FILE+OFFSET),";",3)
if IEN'>0
QUIT
Begin DoDot:1
+5 IF IEN'=700.1
DO MAIN2(IEN)
+6 QUIT
End DoDot:1
+7 DO MAIN2(697.5)
+8 DO ^MCDUPR
+9 QUIT
MAIN2(IEN) ;The 2nd half of main
+1 WRITE !,IEN,?20,$$GET1^DID(IEN,"","","NAME")
+2 SET FILE=$$GET1^DID(IEN,"","","GLOBAL NAME")
KILL YES
+3 SET ID=$$ID(FILE)
+4 DO DUP(FILE,ID)
if '$DATA(YES)
KILL ^TMP($JOB,"DUP","I",IEN)
+5 SET ^TMP($JOB,"DUP","F",IEN)=$SELECT($DATA(YES):1,1:0)
+6 WRITE ?60,$SELECT($DATA(YES):"DUP",1:"NO DUP")
+7 if $DATA(YES)
DO COMPILE^MCDUP1(FILE)
+8 QUIT
DUP(FILE,ID) ;Main Routine
+1 NEW POINT,XDUP,COUNT
+2 DO INIT(FILE,ID)
DO FINDDUPS(FILE,ID)
+3 if $DATA(YES)
DO TABLE(FILE,ID)
+4 QUIT
ID(FILE) ;loads the Identifiers from the ID node
+1 NEW MFILE,FIELD,TEMP
SET MFILE=+$PIECE(FILE,"(",2)
SET FIELD=""
SET ID=".01"
+2 FOR
SET FIELD=+$ORDER(^DD(MFILE,0,"ID",FIELD))
if FIELD=0
QUIT
SET ID=ID_";"_FIELD
+3 QUIT ID
POINTER(FILE,POINT) ;load the pointers from th PT node
+1 NEW TEMP,COUNT,MFILE
SET TEMP=""
SET MFILE=+$PIECE(FILE,"(",2)
+2 FOR COUNT=1:1
SET TEMP=$ORDER(^DD(MFILE,0,"PT",TEMP))
if TEMP=""
QUIT
Begin DoDot:1
+3 IF $DATA(^DD(TEMP,0))
SET POINT(COUNT,"FILE")=TEMP
SET POINT(COUNT,"FIELD")=$ORDER(^DD(MFILE,0,"PT",TEMP,""))
End DoDot:1
+4 QUIT
INIT(FILE,ID) ; Builds a global with all of the indefitiers
+1 NEW TEMP,FILEN,ORD
+2 SET FILEN=+$PIECE(FILE,"(",2)
+3 SET TEMP=""
SET (COUNT,RECC,MREC)=0
SET ORD=FILE_"""B"",TEMP)"
+4 FOR
SET TEMP=$ORDER(@ORD)
if TEMP=""
QUIT
DO LOAD(FILE,TEMP,ID)
+5 QUIT
LOAD(FILE,NAME,ID) ;Loads the array.
+1 NEW TEMP,REC,FILEN,COUNT
+2 SET (TEMP,REC)=""
+3 SET FILEN=+$PIECE(FILE,"(",2)
+4 FOR
SET REC=$ORDER(@(FILE_"""B"""_",NAME,REC)"))
if REC=""
QUIT
Begin DoDot:1
+5 IF '$DATA(@(FILE_REC_",0)"))
KILL ^MCAR(FILEN,"B",NAME,REC)
QUIT
+6 DO MOVE(FILE,FILEN,REC)
End DoDot:1
+7 QUIT
MOVE(FILE,FILEN,REC,COUNT) ;Get the Identifiers from the file
+1 ;Builds a global of
+2 ;^TMP($J,"DUP-I",file number,.01 field,internal rec number,"N") =
+3 ; the identifiers of the record
+4 NEW ID3,DA,DR,DIC,TMP,LOOP,TEMP,TMP1,HOLD
+5 SET HOLD=U
SET DIC=FILE
SET DIQ="ID3("
SET DA=REC
SET DR=ID
SET DIQ(0)="I"
DO EN^DIQ1
+6 ; get the .01 field
SET TMP1=ID3(FILEN,REC,.01,"I")
+7 FOR LOOP=2:1
if '$PIECE(ID,";",LOOP)
QUIT
SET TMP=$GET(ID3(FILEN,REC,$PIECE(ID,";",LOOP),"I"))
SET HOLD=HOLD_TMP_U
+8 SET ^TMP($JOB,"DUP","I",FILEN,TMP1,REC,0)=HOLD
+9 QUIT
FINDDUPS(FILE,ID) ; Finds Duplications and store them in a temp global
+1 NEW TEMP,FILEN
SET TEMP=""
SET FILEN=+$PIECE(FILE,"(",2)
+2 FOR
SET TEMP=$ORDER(^TMP($JOB,"DUP","I",FILEN,TEMP))
if TEMP=""
QUIT
DO BUILD(TEMP,FILEN)
+3 QUIT
BUILD(TEMP,FILEN) ; Move the duplication in a single global
+1 NEW LOOP,REC,ARR
SET (REC,LOOP)=""
+2 FOR
SET REC=$ORDER(^TMP($JOB,"DUP","I",FILEN,TEMP,REC))
if REC=""
QUIT
Begin DoDot:1
+3 SET ARR(^TMP($JOB,"DUP","I",FILEN,TEMP,REC,0))=$GET(ARR(^TMP($JOB,"DUP","I",FILEN,TEMP,REC,0)))_REC_"^"
End DoDot:1
+4 FOR
SET LOOP=$ORDER(ARR(LOOP))
if LOOP=""
QUIT
Begin DoDot:1
+5 SET ^TMP($JOB,"DUP","I",FILEN,TEMP,$PIECE(ARR(LOOP),U),1)=ARR(LOOP)_"*"
+6 if $PIECE(^TMP($JOB,"DUP","I",FILEN,TEMP,$PIECE(ARR(LOOP),U),1),U,2)'="*"
SET YES=""
End DoDot:1
+7 QUIT
TABLE(FILE,ID) ; Takes the temp array and builds a table for repointing
+1 NEW LOOP,REC,OLD,TEMP,FILEN
SET TEMP=""
SET FILEN=+$PIECE(FILE,"(",2)
+2 FOR
SET TEMP=$ORDER(^TMP($JOB,"DUP","I",FILEN,TEMP))
if TEMP=""
QUIT
Begin DoDot:1
+3 SET REC=""
FOR
SET REC=+$ORDER(^TMP($JOB,"DUP","I",FILEN,TEMP,REC))
if REC=0
QUIT
Begin DoDot:2
+4 IF $DATA(^TMP($JOB,"DUP","I",FILEN,TEMP,REC,1))
Begin DoDot:3
+5 FOR LOOP=1:1
SET OLD=$PIECE(^TMP($JOB,"DUP","I",FILEN,TEMP,REC,1),U,LOOP)
if OLD="*"
QUIT
SET ^TMP($JOB,"DUP","RT",FILEN,OLD)=REC
End DoDot:3
End DoDot:2
End DoDot:1
+6 QUIT
FILE ;;File#
+1 ;;697
+2 ;;696.4
+3 ;;695.3
+4 ;;693.5
+5 ;;696.9
+6 ;;699.82
+7 ;;699.6
+8 ;;699.84
+9 ;;693.3
+10 ;;699.85
+11 ;;699.55
+12 ;;695.6
+13 ;;693.2
+14 ;;694.1
+15 ;;696.5
+16 ;;696.2
+17 ;;699.83
+18 ;;693
+19 ;;696.7
+20 ;;699.57
+21 ;;696.3
+22 ;;699.88
+23 ;;698.9
+24 ;;695.9
+25 ;;698.4
+26 ;;698.6
+27 ;;695.4
+28 ;;696.1
+29 ;;695.8
+30 ;;695.1
+31 ;;699.81
+32 ;;696
+33 ;;699.86
+34 ;;695.5
+35 ;;700.1
+36 ;;690.2
+37 ;;690.5
+38 ;;694.8
