- 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 Feb 19, 2025@00:05:55 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