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