DG53461 ;ALB/AEG - DG*5.3*461 POST-INSTALLATION ;7-2-2002
;;5.3;Registration;**461**;Aug 13, 1993
;
; This cleanup consists of 1 issue dealing with duplicate
; CD (Catestropic Disability) Procedure Codes. The patient
; File (#2) will be searched for entries on living patients
; who have multiple entries associated with the same procedure
; and extremity.
;
EN ; Main Entry Point.
D INIT
Q
INIT ; Initialize Tracking Global and associated checkpoints.
K ^TMP($J),^XTMP("DG-DFN"),^XTMP("DG-P1")
N %,I,X,X1,X2
; Create Checkpoints.
I $D(XPDNM) D
.I $$VERCP^XPDUTL("DFN")'>0 D
..S %=$$NEWCP^XPDUTL("DFN","",0)
.I $$VERCP^XPDUTL("P1")'>0 D
..S %=$$NEWCP^XPDUTL("P1","",0)
; Initialize the tracking global.
F I="DFN","P1" D
.I $D(^XTMP("DG-"_I)) Q
.S X1=DT,X2=30 D C^%DTC
.S ^XTMP("DG-"_I,0)=X_U_$$DT^XLFDT_"^DG*5.3*461 POST INSTALL "
.S ^XTMP("DG-"_I,0)=^XTMP("DG-"_I,0)_$S(I="DFN":"Patient records",I="P1":"Duplicate Procedures",1:"errors")
I '$D(XPDNM) D
.S ^XTMP("DG-DFN",1)=0
.S ^XTMP("DG-P1",1)=0
;
; Check status. If root checkpoint has not completed start the cleanup
I $D(XPDNM) S %=$$VERCP^XPDUTL("DFN") D
.I '$D(^XTMP("DG-DFN",1)) S ^XTMP("DG-DFN",1)=0
.I '$D(^XTMP("DG-P1",1)) S ^XTMP("DG-P1",1)=0
I $G(%)="" S %=0
I %=0 D EN1
Q
;
EN1 ; Control process flow from this point forward.
D LOOP,DUPL,PURGE
N %
; Complete checkpoints and get out.
S %=$$COMCP^XPDUTL("DFN"),%=$$COMCP^XPDUTL("P1")
D CLEAN
Q
LOOP ; Initial Pass through the patient file to determine which records have
; corrupted data.
D BMES^XPDUTL("POST INSTALLATION PROCESSING")
D MES^XPDUTL("----------------------------")
N MESS D MESS^DG53461U D MES^XPDUTL(.MESS)
N DFN,DGCNT,DGDOD
D BMES^XPDUTL("SEARCH ENGINE STARTED AT "_$$FMTE^XLFDT($$NOW^XLFDT))
I '$D(ZTQUEUED) D MES^XPDUTL("Each `.` represents 200 records ...")
S DFN=0 F DGCNT=1:1 S DFN=$O(^DPT(DFN)) Q:'+DFN D
.I '$D(ZTQUEUED) W:'(DGCNT#200) "."
.S DGDOD=$P($G(^DPT(DFN,.35)),U)
.; Ignore patients who have a date of death on file.
.D:'+DGDOD
..I $D(^DPT(DFN,.397,0)),$P(^DPT(DFN,.397,0),U,4)>0 D
...N PIEN,P1,I
...S PIEN="" F S PIEN=$O(^DPT(DFN,.397,"B",PIEN)) Q:'+PIEN S P1="" F S P1=$O(^DPT(DFN,.397,"B",PIEN,P1)) Q:'+P1 D
....D SETTMP(DFN,P1)
....; Update Checkpoint
....N %
....I $D(XPDNM) S %=$$UPCP^XPDUTL("P1",P1)
....Q
...Q
..Q
.; Update DFN CheckPoint
.N %
.I $D(XPDNM) S %=$$UPCP^XPDUTL("DFN",DFN)
.Q
Q
;
SETTMP(DFN,P1) ; Return data value of specific entry being looked at
S ^TMP($J,"DFN",DFN)=$P($G(^DPT(DFN,.397,0)),U,4)
S ^TMP($J,"PCODE",DFN,P1)=$G(^DPT(DFN,.397,P1,0))
Q
DUPL ; Clean-up Duplicate Entries.
D BMES^XPDUTL("PARSING DATA TO LOCATE DUPLICATE ENTRIES ...")
N DFN,COUNT,I,IJ,VAL,VAL1
S DFN=""
F S DFN=$O(^TMP($J,"DFN",DFN)) Q:'+DFN D
.S COUNT=$G(^TMP($J,"DFN",DFN))
.F I=1:1:COUNT S VAL=$G(^TMP($J,"PCODE",DFN,I)) F IJ=1:1:COUNT S VAL1=$G(^TMP($J,"PCODE",DFN,IJ)) D
..I I'=IJ,'$D(^UTILITY("SCRATCH",$J,DFN,IJ,I)) S ^UTILITY("SCRATCH",$J,DFN,I,IJ)=COUNT
..I VAL=VAL1,I'=IJ,'$D(^UTILITY("SCRATCH",$J,DFN,IJ,I)) D
...I I>IJ S ^TMP("DUPLICATE",$J,DFN,I)=VAL,^UTILITY($J,"DUP",$P($G(^DPT(DFN,0)),U,1),DFN,VAL)=""
...I IJ>I S ^TMP("DUPLICATE",$J,DFN,IJ)=VAL1,^UTILITY($J,"DUP",$P($G(^DPT(DFN,0)),U,1),DFN,VAL1)=""
...Q
..Q
.Q
K ^TMP($J),^UTILITY("SCRATCH",$J)
Q
PURGE ; Cleanup duplicate CD procedures and report on those procedures.
I '$D(^TMP("DUPLICATE",$J)) D Q
.D M1^DG53461U
I $D(^TMP("DUPLICATE",$J)) D
.D BMES^XPDUTL("PURGING DUPLICATE ENTRIES ...")
.N DFN,PIEN,VAL
.S (DFN,PIEN)=""
.F S DFN=$O(^TMP("DUPLICATE",$J,DFN)) Q:'+DFN D
..S PIEN="" F S PIEN=$O(^TMP("DUPLICATE",$J,DFN,PIEN)) Q:'+PIEN D
...N DATA,DGENDA
...S DATA(.01)="@",DGENDA=PIEN,DGENDA(1)=DFN
...I '$$UPD^DGENDBS(2.397,.DGENDA,.DATA,.ERROR) D
....S ^TMP("ERROR",$J,DFN,ERROR)=""
....K ^UTILITY($J,"DUP",$P($G(^DPT(DFN,0)),U,1))
....Q
...Q
..Q
.Q
I $D(^UTILITY($J,"DUP")) D M2^DG53461U
I $D(^TMP("ERROR",$J)) D M3^DG53461U
Q
CLEAN ; Cleanup symbol table / temp globals and get out.
K ^TMP($J),^UTILITY($J),^XTMP("DG-DFN"),^XTMP("DG-P1")
K MESS,XMZ,ZTQUEUED,ERROR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53461 4236 printed Sep 23, 2025@20:13:23 Page 2
DG53461 ;ALB/AEG - DG*5.3*461 POST-INSTALLATION ;7-2-2002
+1 ;;5.3;Registration;**461**;Aug 13, 1993
+2 ;
+3 ; This cleanup consists of 1 issue dealing with duplicate
+4 ; CD (Catestropic Disability) Procedure Codes. The patient
+5 ; File (#2) will be searched for entries on living patients
+6 ; who have multiple entries associated with the same procedure
+7 ; and extremity.
+8 ;
EN ; Main Entry Point.
+1 DO INIT
+2 QUIT
INIT ; Initialize Tracking Global and associated checkpoints.
+1 KILL ^TMP($JOB),^XTMP("DG-DFN"),^XTMP("DG-P1")
+2 NEW %,I,X,X1,X2
+3 ; Create Checkpoints.
+4 IF $DATA(XPDNM)
Begin DoDot:1
+5 IF $$VERCP^XPDUTL("DFN")'>0
Begin DoDot:2
+6 SET %=$$NEWCP^XPDUTL("DFN","",0)
End DoDot:2
+7 IF $$VERCP^XPDUTL("P1")'>0
Begin DoDot:2
+8 SET %=$$NEWCP^XPDUTL("P1","",0)
End DoDot:2
End DoDot:1
+9 ; Initialize the tracking global.
+10 FOR I="DFN","P1"
Begin DoDot:1
+11 IF $DATA(^XTMP("DG-"_I))
QUIT
+12 SET X1=DT
SET X2=30
DO C^%DTC
+13 SET ^XTMP("DG-"_I,0)=X_U_$$DT^XLFDT_"^DG*5.3*461 POST INSTALL "
+14 SET ^XTMP("DG-"_I,0)=^XTMP("DG-"_I,0)_$SELECT(I="DFN":"Patient records",I="P1":"Duplicate Procedures",1:"errors")
End DoDot:1
+15 IF '$DATA(XPDNM)
Begin DoDot:1
+16 SET ^XTMP("DG-DFN",1)=0
+17 SET ^XTMP("DG-P1",1)=0
End DoDot:1
+18 ;
+19 ; Check status. If root checkpoint has not completed start the cleanup
+20 IF $DATA(XPDNM)
SET %=$$VERCP^XPDUTL("DFN")
Begin DoDot:1
+21 IF '$DATA(^XTMP("DG-DFN",1))
SET ^XTMP("DG-DFN",1)=0
+22 IF '$DATA(^XTMP("DG-P1",1))
SET ^XTMP("DG-P1",1)=0
End DoDot:1
+23 IF $GET(%)=""
SET %=0
+24 IF %=0
DO EN1
+25 QUIT
+26 ;
EN1 ; Control process flow from this point forward.
+1 DO LOOP
DO DUPL
DO PURGE
+2 NEW %
+3 ; Complete checkpoints and get out.
+4 SET %=$$COMCP^XPDUTL("DFN")
SET %=$$COMCP^XPDUTL("P1")
+5 DO CLEAN
+6 QUIT
LOOP ; Initial Pass through the patient file to determine which records have
+1 ; corrupted data.
+2 DO BMES^XPDUTL("POST INSTALLATION PROCESSING")
+3 DO MES^XPDUTL("----------------------------")
+4 NEW MESS
DO MESS^DG53461U
DO MES^XPDUTL(.MESS)
+5 NEW DFN,DGCNT,DGDOD
+6 DO BMES^XPDUTL("SEARCH ENGINE STARTED AT "_$$FMTE^XLFDT($$NOW^XLFDT))
+7 IF '$DATA(ZTQUEUED)
DO MES^XPDUTL("Each `.` represents 200 records ...")
+8 SET DFN=0
FOR DGCNT=1:1
SET DFN=$ORDER(^DPT(DFN))
if '+DFN
QUIT
Begin DoDot:1
+9 IF '$DATA(ZTQUEUED)
if '(DGCNT#200)
WRITE "."
+10 SET DGDOD=$PIECE($GET(^DPT(DFN,.35)),U)
+11 ; Ignore patients who have a date of death on file.
+12 if '+DGDOD
Begin DoDot:2
+13 IF $DATA(^DPT(DFN,.397,0))
IF $PIECE(^DPT(DFN,.397,0),U,4)>0
Begin DoDot:3
+14 NEW PIEN,P1,I
+15 SET PIEN=""
FOR
SET PIEN=$ORDER(^DPT(DFN,.397,"B",PIEN))
if '+PIEN
QUIT
SET P1=""
FOR
SET P1=$ORDER(^DPT(DFN,.397,"B",PIEN,P1))
if '+P1
QUIT
Begin DoDot:4
+16 DO SETTMP(DFN,P1)
+17 ; Update Checkpoint
+18 NEW %
+19 IF $DATA(XPDNM)
SET %=$$UPCP^XPDUTL("P1",P1)
+20 QUIT
End DoDot:4
+21 QUIT
End DoDot:3
+22 QUIT
End DoDot:2
+23 ; Update DFN CheckPoint
+24 NEW %
+25 IF $DATA(XPDNM)
SET %=$$UPCP^XPDUTL("DFN",DFN)
+26 QUIT
End DoDot:1
+27 QUIT
+28 ;
SETTMP(DFN,P1) ; Return data value of specific entry being looked at
+1 SET ^TMP($JOB,"DFN",DFN)=$PIECE($GET(^DPT(DFN,.397,0)),U,4)
+2 SET ^TMP($JOB,"PCODE",DFN,P1)=$GET(^DPT(DFN,.397,P1,0))
+3 QUIT
DUPL ; Clean-up Duplicate Entries.
+1 DO BMES^XPDUTL("PARSING DATA TO LOCATE DUPLICATE ENTRIES ...")
+2 NEW DFN,COUNT,I,IJ,VAL,VAL1
+3 SET DFN=""
+4 FOR
SET DFN=$ORDER(^TMP($JOB,"DFN",DFN))
if '+DFN
QUIT
Begin DoDot:1
+5 SET COUNT=$GET(^TMP($JOB,"DFN",DFN))
+6 FOR I=1:1:COUNT
SET VAL=$GET(^TMP($JOB,"PCODE",DFN,I))
FOR IJ=1:1:COUNT
SET VAL1=$GET(^TMP($JOB,"PCODE",DFN,IJ))
Begin DoDot:2
+7 IF I'=IJ
IF '$DATA(^UTILITY("SCRATCH",$JOB,DFN,IJ,I))
SET ^UTILITY("SCRATCH",$JOB,DFN,I,IJ)=COUNT
+8 IF VAL=VAL1
IF I'=IJ
IF '$DATA(^UTILITY("SCRATCH",$JOB,DFN,IJ,I))
Begin DoDot:3
+9 IF I>IJ
SET ^TMP("DUPLICATE",$JOB,DFN,I)=VAL
SET ^UTILITY($JOB,"DUP",$PIECE($GET(^DPT(DFN,0)),U,1),DFN,VAL)=""
+10 IF IJ>I
SET ^TMP("DUPLICATE",$JOB,DFN,IJ)=VAL1
SET ^UTILITY($JOB,"DUP",$PIECE($GET(^DPT(DFN,0)),U,1),DFN,VAL1)=""
+11 QUIT
End DoDot:3
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 KILL ^TMP($JOB),^UTILITY("SCRATCH",$JOB)
+15 QUIT
PURGE ; Cleanup duplicate CD procedures and report on those procedures.
+1 IF '$DATA(^TMP("DUPLICATE",$JOB))
Begin DoDot:1
+2 DO M1^DG53461U
End DoDot:1
QUIT
+3 IF $DATA(^TMP("DUPLICATE",$JOB))
Begin DoDot:1
+4 DO BMES^XPDUTL("PURGING DUPLICATE ENTRIES ...")
+5 NEW DFN,PIEN,VAL
+6 SET (DFN,PIEN)=""
+7 FOR
SET DFN=$ORDER(^TMP("DUPLICATE",$JOB,DFN))
if '+DFN
QUIT
Begin DoDot:2
+8 SET PIEN=""
FOR
SET PIEN=$ORDER(^TMP("DUPLICATE",$JOB,DFN,PIEN))
if '+PIEN
QUIT
Begin DoDot:3
+9 NEW DATA,DGENDA
+10 SET DATA(.01)="@"
SET DGENDA=PIEN
SET DGENDA(1)=DFN
+11 IF '$$UPD^DGENDBS(2.397,.DGENDA,.DATA,.ERROR)
Begin DoDot:4
+12 SET ^TMP("ERROR",$JOB,DFN,ERROR)=""
+13 KILL ^UTILITY($JOB,"DUP",$PIECE($GET(^DPT(DFN,0)),U,1))
+14 QUIT
End DoDot:4
+15 QUIT
End DoDot:3
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 IF $DATA(^UTILITY($JOB,"DUP"))
DO M2^DG53461U
+19 IF $DATA(^TMP("ERROR",$JOB))
DO M3^DG53461U
+20 QUIT
CLEAN ; Cleanup symbol table / temp globals and get out.
+1 KILL ^TMP($JOB),^UTILITY($JOB),^XTMP("DG-DFN"),^XTMP("DG-P1")
+2 KILL MESS,XMZ,ZTQUEUED,ERROR
+3 QUIT
