DG53P593 ;BAY/JAT - Patient File Cleanup; 2/22/1999 ; 6/24/04 3:43pm
;;5.3;Registration;**593**;Aug 13,1993
Q
;
CLEANUP ;This entry point will do the cleanup.
;
N DGENSKIP
S DGENSKIP=0
W !,"This is a one-time cleanup of the Patient File."
W !,"Certain records which were created in error will be deleted."
N X1,X2
K ^XTMP("DG53P593",$J)
S X1=DT,X2=90 D C^%DTC
S ^XTMP("DG53P593",$J,0)=X_"^"_DT_"^Patient File cleanup"
I $$DEVICE() D ENTER
Q
;
REPORT ;This entry point was provided for testing, so that before
;patient records are deleted the site can have a list of
;the DFN's that would be deleted.
;
;Use this entry point to report on what the cleanup would do.
;No changes will be made to the database.
;
N DGENSKIP
S DGENSKIP=1
W !,"This is a preliminary report by DFN of the Patient file"
W !,"records which would be deleted by the cleanup."
N X1,X2
K ^XTMP("DG53P593",$J)
S X1=DT,X2=90 D C^%DTC
S ^XTMP("DG53P593",$J,0)=X_"^"_DT_"^Patient File cleanup"
I $$DEVICE() D ENTER
Q
;
ENTER ;
;
D DELETE(DGENSKIP)
D:(DGENSKIP) ^%ZISC
I $D(ZTQUEUED) S ZTREQ="@"
Q
DEVICE() ;
;Description: allows the user to select a device.
;
;Output:
; Function Value - Returns 0 if the user decides not to print or to
; queue the report, 1 otherwise.
;
N OK,IOP,POP,%ZIS
S OK=1
S %ZIS="MQ"
D ^%ZIS
S:POP OK=0
D:OK&$D(IO("Q"))
.N ZTRTN,ZTDESC,ZTSKM,ZTREQ,ZTSTOP
.S ZTRTN="ENTER^DG53P593",ZTDESC=$S(DGENSKIP:"Report",1:"Cleanup")_" of Incomplete Patient Records"
.S ZTSAVE("DGENSKIP")=""
.D ^%ZTLOAD
.W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
.D HOME^%ZIS
.S OK=0
Q OK
;
DELETE(DGENSKIP) ;
;This will delete bogus patient records --
;
;Input: If DGENSKIP=1, the records will not be deleted,
;just reported.
;
N DFN,SUB,GOOD,COUNT,DGNAME,DGDEL,DGSORT,DGVAL,DGFDA,DGERR
S (COUNT,DFN)=0
F S DFN=$O(^DPT(DFN)) Q:'DFN D
.; merged record
.I $D(^DPT(DFN,-9)) Q
.; in process of being merged
.I $P($G(^DPT(DFN,0)),U)["MERGING INTO" Q
.; usual good patient record
.I $D(^DPT(DFN,0)) S DGNAME=$P($G(^DPT(DFN,0)),U) I DGNAME'="",$D(^DPT("B",DGNAME,DFN)) Q
.; evaluate if record related to DG*5.3*578
.D EVAL578
.; evaluate if record related to DG*5.3*222
.S GOOD=0
.S SUB=""
.F S SUB=$O(^DPT(DFN,SUB)) Q:SUB="" D
..I (SUB'=.3),(SUB'=.38),(SUB'=.52) S GOOD=1 Q
.I 'GOOD D DIKDEL Q
.I DGDEL D DIKDEL
;
D PRINT
Q
;
EVAL578 ;
S DGDEL=0
N DGCNT,DGNODE,DGSSN,DGNEWIEN,DGMPI
I '$D(^DPT(DFN,0)) Q
S DGNODE=""
S DGCNT=0
F S DGNODE=$O(^DPT(DFN,DGNODE)) Q:DGNODE="" S DGCNT=DGCNT+1
; there must be minimal data, so skip if too many nodes
Q:DGCNT>7
I DGNAME="" S DGDEL=DGDEL+1
I DGNAME'="",'$D(^DPT("B",DGNAME,DFN)) S DGDEL=DGDEL+1
S DGSSN=$P($G(^DPT(DFN,0)),U,9)
I DGSSN="" S DGDEL=DGDEL+1
I DGSSN'="",'$D(^DPT("SSN",DGSSN,DFN)) S DGDEL=DGDEL+1 D
.S DGNEWIEN=0
.F S DGNEWIEN=$O(^DPT("SSN",DGSSN,DGNEWIEN)) Q:'DGNEWIEN I DGNEWIEN S DGDEL=DGDEL+1
S DGMPI=$E($P($G(^DPT(DFN,"MPI")),U),1,3)
I DGMPI="" S DGDEL=DGDEL+1
; checking if only local ICN
I DGMPI=+$$SITE^VASITE() S DGDEL=DGDEL+1
I DGDEL>1 Q
S DGDEL=0
Q
;
DIKDEL ;
S COUNT=COUNT+1
S DGSORT=$S('GOOD:2,1:1)
S ^XTMP("DG53P593",$J,DGSORT,DFN)=$S(DGSORT=1:"Related to DG*5.3*578",1:"Related to DG*5.3*222")
I 'DGENSKIP D
.D DELEXE
.I '$D(^DPT(DFN,0)) D Q
..S DA=DFN,DIK="^DPT(" D ^DIK K DA,DIK
.I $P($G(^DPT(DFN,0)),U)="" K ^DPT(DFN) Q
.S DGVAL="@"
.S DGFDA(2,DFN_",",.01)=DGVAL
.D FILE^DIE("","DGFDA","DGERR")
Q
;
DELEXE ; Delete exceptions on file for patient record being removed.
S EXCT=""
F S EXCT=$O(^RGHL7(991.1,"ADFN",EXCT)) Q:EXCT="" D
. I $D(^RGHL7(991.1,"ADFN",EXCT,DFN)) D
.. S IEN=0
.. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCT,DFN,IEN)) Q:'IEN D
... S IEN2=0
... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCT,DFN,IEN,IEN2)) Q:'IEN2 D
.... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
.... I NUM=1 D
..... L +^RGHL7(991.1,IEN):10
..... S DIK="^RGHL7(991.1,",DA=IEN
..... D ^DIK K DIK,DA
..... L -^RGHL7(991.1,IEN)
.... E I NUM>1 D DELE
K EXCT,IEN,IEN2,NUM
Q
DELE ; delete exception
L +^RGHL7(991.1,IEN):10
S DA(1)=IEN,DA=IEN2
S DIK="^RGHL7(991.1,"_DA(1)_",1,"
D ^DIK K DIK,DA
L -^RGHL7(991.1,IEN)
Q
PRINT ;
U IO
N DGDDT,DGQUIT,DGPG
S DGDDT=$$FMTE^XLFDT($$NOW^XLFDT,"D")
S (DGQUIT,DGPG)=0
D HEAD
I '$G(COUNT) D Q
.W !!!,?20,"*** No records to report ***"
W !!,"*** COUNT OF BAD PATIENT RECORDS"_$S(DGENSKIP:"",1:" DELETED")_": ",COUNT," ***",!!
S DGSORT=0
F S DGSORT=$O(^XTMP("DG53P593",$J,DGSORT)) Q:'DGSORT D Q:DGQUIT
.S DFN=0
.F S DFN=$O(^XTMP("DG53P593",$J,DGSORT,DFN)) Q:'DFN D Q:DGQUIT
..I $Y>(IOSL-4) D HEAD
..W ?2,DFN,?15,$G(^XTMP("DG53P593",$J,DGSORT,DFN)),!
;
I DGQUIT W:$D(ZTQUEUED) !!,"Report stopped at user's request" Q
I $G(DGPG)>0,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQUIT=1
I $D(ZTQUEUED) S ZTREQ="@"
Q
;
HEAD ;
I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DGQUIT)=1 Q
I $G(DGPG)>0,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQUIT=1
Q:DGQUIT
S DGPG=$G(DGPG)+1
W @IOF,!,DGDDT,?15,"DG*5.3*593 Patient File Cleanup Utility",?70,"Page:",$J(DGPG,5),! K X S $P(X,"-",81)="" W X,!
W !,?2,"DFN",?15,"Reason for Deletion",!
S $P(X,"-",81)="" W X,!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53P593 5405 printed Dec 13, 2024@02:39:51 Page 2
DG53P593 ;BAY/JAT - Patient File Cleanup; 2/22/1999 ; 6/24/04 3:43pm
+1 ;;5.3;Registration;**593**;Aug 13,1993
+2 QUIT
+3 ;
CLEANUP ;This entry point will do the cleanup.
+1 ;
+2 NEW DGENSKIP
+3 SET DGENSKIP=0
+4 WRITE !,"This is a one-time cleanup of the Patient File."
+5 WRITE !,"Certain records which were created in error will be deleted."
+6 NEW X1,X2
+7 KILL ^XTMP("DG53P593",$JOB)
+8 SET X1=DT
SET X2=90
DO C^%DTC
+9 SET ^XTMP("DG53P593",$JOB,0)=X_"^"_DT_"^Patient File cleanup"
+10 IF $$DEVICE()
DO ENTER
+11 QUIT
+12 ;
REPORT ;This entry point was provided for testing, so that before
+1 ;patient records are deleted the site can have a list of
+2 ;the DFN's that would be deleted.
+3 ;
+4 ;Use this entry point to report on what the cleanup would do.
+5 ;No changes will be made to the database.
+6 ;
+7 NEW DGENSKIP
+8 SET DGENSKIP=1
+9 WRITE !,"This is a preliminary report by DFN of the Patient file"
+10 WRITE !,"records which would be deleted by the cleanup."
+11 NEW X1,X2
+12 KILL ^XTMP("DG53P593",$JOB)
+13 SET X1=DT
SET X2=90
DO C^%DTC
+14 SET ^XTMP("DG53P593",$JOB,0)=X_"^"_DT_"^Patient File cleanup"
+15 IF $$DEVICE()
DO ENTER
+16 QUIT
+17 ;
ENTER ;
+1 ;
+2 DO DELETE(DGENSKIP)
+3 if (DGENSKIP)
DO ^%ZISC
+4 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+5 QUIT
DEVICE() ;
+1 ;Description: allows the user to select a device.
+2 ;
+3 ;Output:
+4 ; Function Value - Returns 0 if the user decides not to print or to
+5 ; queue the report, 1 otherwise.
+6 ;
+7 NEW OK,IOP,POP,%ZIS
+8 SET OK=1
+9 SET %ZIS="MQ"
+10 DO ^%ZIS
+11 if POP
SET OK=0
+12 if OK&$DATA(IO("Q"))
Begin DoDot:1
+13 NEW ZTRTN,ZTDESC,ZTSKM,ZTREQ,ZTSTOP
+14 SET ZTRTN="ENTER^DG53P593"
SET ZTDESC=$SELECT(DGENSKIP:"Report",1:"Cleanup")_" of Incomplete Patient Records"
+15 SET ZTSAVE("DGENSKIP")=""
+16 DO ^%ZTLOAD
+17 WRITE !,$SELECT($DATA(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
+18 DO HOME^%ZIS
+19 SET OK=0
End DoDot:1
+20 QUIT OK
+21 ;
DELETE(DGENSKIP) ;
+1 ;This will delete bogus patient records --
+2 ;
+3 ;Input: If DGENSKIP=1, the records will not be deleted,
+4 ;just reported.
+5 ;
+6 NEW DFN,SUB,GOOD,COUNT,DGNAME,DGDEL,DGSORT,DGVAL,DGFDA,DGERR
+7 SET (COUNT,DFN)=0
+8 FOR
SET DFN=$ORDER(^DPT(DFN))
if 'DFN
QUIT
Begin DoDot:1
+9 ; merged record
+10 IF $DATA(^DPT(DFN,-9))
QUIT
+11 ; in process of being merged
+12 IF $PIECE($GET(^DPT(DFN,0)),U)["MERGING INTO"
QUIT
+13 ; usual good patient record
+14 IF $DATA(^DPT(DFN,0))
SET DGNAME=$PIECE($GET(^DPT(DFN,0)),U)
IF DGNAME'=""
IF $DATA(^DPT("B",DGNAME,DFN))
QUIT
+15 ; evaluate if record related to DG*5.3*578
+16 DO EVAL578
+17 ; evaluate if record related to DG*5.3*222
+18 SET GOOD=0
+19 SET SUB=""
+20 FOR
SET SUB=$ORDER(^DPT(DFN,SUB))
if SUB=""
QUIT
Begin DoDot:2
+21 IF (SUB'=.3)
IF (SUB'=.38)
IF (SUB'=.52)
SET GOOD=1
QUIT
End DoDot:2
+22 IF 'GOOD
DO DIKDEL
QUIT
+23 IF DGDEL
DO DIKDEL
End DoDot:1
+24 ;
+25 DO PRINT
+26 QUIT
+27 ;
EVAL578 ;
+1 SET DGDEL=0
+2 NEW DGCNT,DGNODE,DGSSN,DGNEWIEN,DGMPI
+3 IF '$DATA(^DPT(DFN,0))
QUIT
+4 SET DGNODE=""
+5 SET DGCNT=0
+6 FOR
SET DGNODE=$ORDER(^DPT(DFN,DGNODE))
if DGNODE=""
QUIT
SET DGCNT=DGCNT+1
+7 ; there must be minimal data, so skip if too many nodes
+8 if DGCNT>7
QUIT
+9 IF DGNAME=""
SET DGDEL=DGDEL+1
+10 IF DGNAME'=""
IF '$DATA(^DPT("B",DGNAME,DFN))
SET DGDEL=DGDEL+1
+11 SET DGSSN=$PIECE($GET(^DPT(DFN,0)),U,9)
+12 IF DGSSN=""
SET DGDEL=DGDEL+1
+13 IF DGSSN'=""
IF '$DATA(^DPT("SSN",DGSSN,DFN))
SET DGDEL=DGDEL+1
Begin DoDot:1
+14 SET DGNEWIEN=0
+15 FOR
SET DGNEWIEN=$ORDER(^DPT("SSN",DGSSN,DGNEWIEN))
if 'DGNEWIEN
QUIT
IF DGNEWIEN
SET DGDEL=DGDEL+1
End DoDot:1
+16 SET DGMPI=$EXTRACT($PIECE($GET(^DPT(DFN,"MPI")),U),1,3)
+17 IF DGMPI=""
SET DGDEL=DGDEL+1
+18 ; checking if only local ICN
+19 IF DGMPI=+$$SITE^VASITE()
SET DGDEL=DGDEL+1
+20 IF DGDEL>1
QUIT
+21 SET DGDEL=0
+22 QUIT
+23 ;
DIKDEL ;
+1 SET COUNT=COUNT+1
+2 SET DGSORT=$SELECT('GOOD:2,1:1)
+3 SET ^XTMP("DG53P593",$JOB,DGSORT,DFN)=$SELECT(DGSORT=1:"Related to DG*5.3*578",1:"Related to DG*5.3*222")
+4 IF 'DGENSKIP
Begin DoDot:1
+5 DO DELEXE
+6 IF '$DATA(^DPT(DFN,0))
Begin DoDot:2
+7 SET DA=DFN
SET DIK="^DPT("
DO ^DIK
KILL DA,DIK
End DoDot:2
QUIT
+8 IF $PIECE($GET(^DPT(DFN,0)),U)=""
KILL ^DPT(DFN)
QUIT
+9 SET DGVAL="@"
+10 SET DGFDA(2,DFN_",",.01)=DGVAL
+11 DO FILE^DIE("","DGFDA","DGERR")
End DoDot:1
+12 QUIT
+13 ;
DELEXE ; Delete exceptions on file for patient record being removed.
+1 SET EXCT=""
+2 FOR
SET EXCT=$ORDER(^RGHL7(991.1,"ADFN",EXCT))
if EXCT=""
QUIT
Begin DoDot:1
+3 IF $DATA(^RGHL7(991.1,"ADFN",EXCT,DFN))
Begin DoDot:2
+4 SET IEN=0
+5 FOR
SET IEN=$ORDER(^RGHL7(991.1,"ADFN",EXCT,DFN,IEN))
if 'IEN
QUIT
Begin DoDot:3
+6 SET IEN2=0
+7 FOR
SET IEN2=$ORDER(^RGHL7(991.1,"ADFN",EXCT,DFN,IEN,IEN2))
if 'IEN2
QUIT
Begin DoDot:4
+8 SET NUM=""
SET NUM=$PIECE(^RGHL7(991.1,IEN,1,0),"^",4)
+9 IF NUM=1
Begin DoDot:5
+10 LOCK +^RGHL7(991.1,IEN):10
+11 SET DIK="^RGHL7(991.1,"
SET DA=IEN
+12 DO ^DIK
KILL DIK,DA
+13 LOCK -^RGHL7(991.1,IEN)
End DoDot:5
+14 IF '$TEST
IF NUM>1
DO DELE
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 KILL EXCT,IEN,IEN2,NUM
+16 QUIT
DELE ; delete exception
+1 LOCK +^RGHL7(991.1,IEN):10
+2 SET DA(1)=IEN
SET DA=IEN2
+3 SET DIK="^RGHL7(991.1,"_DA(1)_",1,"
+4 DO ^DIK
KILL DIK,DA
+5 LOCK -^RGHL7(991.1,IEN)
+6 QUIT
PRINT ;
+1 USE IO
+2 NEW DGDDT,DGQUIT,DGPG
+3 SET DGDDT=$$FMTE^XLFDT($$NOW^XLFDT,"D")
+4 SET (DGQUIT,DGPG)=0
+5 DO HEAD
+6 IF '$GET(COUNT)
Begin DoDot:1
+7 WRITE !!!,?20,"*** No records to report ***"
End DoDot:1
QUIT
+8 WRITE !!,"*** COUNT OF BAD PATIENT RECORDS"_$SELECT(DGENSKIP:"",1:" DELETED")_": ",COUNT," ***",!!
+9 SET DGSORT=0
+10 FOR
SET DGSORT=$ORDER(^XTMP("DG53P593",$JOB,DGSORT))
if 'DGSORT
QUIT
Begin DoDot:1
+11 SET DFN=0
+12 FOR
SET DFN=$ORDER(^XTMP("DG53P593",$JOB,DGSORT,DFN))
if 'DFN
QUIT
Begin DoDot:2
+13 IF $Y>(IOSL-4)
DO HEAD
+14 WRITE ?2,DFN,?15,$GET(^XTMP("DG53P593",$JOB,DGSORT,DFN)),!
End DoDot:2
if DGQUIT
QUIT
End DoDot:1
if DGQUIT
QUIT
+15 ;
+16 IF DGQUIT
if $DATA(ZTQUEUED)
WRITE !!,"Report stopped at user's request"
QUIT
+17 IF $GET(DGPG)>0
IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
if +Y=0
SET DGQUIT=1
+18 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+19 QUIT
+20 ;
HEAD ;
+1 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET (ZTSTOP,DGQUIT)=1
QUIT
+2 IF $GET(DGPG)>0
IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
if +Y=0
SET DGQUIT=1
+3 if DGQUIT
QUIT
+4 SET DGPG=$GET(DGPG)+1
+5 WRITE @IOF,!,DGDDT,?15,"DG*5.3*593 Patient File Cleanup Utility",?70,"Page:",$JUSTIFY(DGPG,5),!
KILL X
SET $PIECE(X,"-",81)=""
WRITE X,!
+6 WRITE !,?2,"DFN",?15,"Reason for Deletion",!
+7 SET $PIECE(X,"-",81)=""
WRITE X,!
+8 QUIT
