DG53618 ;ALB/GN/PHH,EG - DG*5.3*618 CLEANUP DANGLING RECS; 04/27/2005
;;5.3;Registration;**618,1015**;Aug 13, 1993;Build 21
;
; Cleans up dangling file Income Relation file #408.12 records where
; it points to bad or non-existent Income Person file #408.13 and
; Patient file #2 records.
;
; 1. If it points to file 2, that doesn't exist or has a bad 0 node,
; delete the 408.12 rec that points to the bad 2 rec, then
; delete the 408.21 that points to 408.12 rec, then
; delete the 408.22 rec that points to the 408.21.
; 2. Same logic will be used if points to bad 408.13 recs
;
Q
;
POST ;post install entry tag call. processes entire file in live mode
N ZTDTH,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTQUEUED,ZTSAVE,CHKPNT
D MES^XPDUTL("")
D MES^XPDUTL("=====================================================")
D MES^XPDUTL("Queuing Bad Patient Relation Pointers cleanup process.....")
I $$CHKSTAT(1) D Q
. D BMES^XPDUTL("ABORTING Post Install Cleanup Queuing")
. D MES^XPDUTL("=====================================================")
. Q
S ZTRTN="QUE^DG53618"
S ZTDESC="Cleanup Bad Pointers In Patient Relation File"
S ZTIO="",ZTDTH=$H
S CHKPNT=0,ZTSAVE("CHKPNT")=""
D ^%ZTLOAD
D MES^XPDUTL("This request queued as Task # "_ZTSK)
D MES^XPDUTL("=====================================================")
D MES^XPDUTL("")
Q
;
TEST ; Entry point for taskman (testing mode)
N TESTING,ZTQUEUED
S TESTING=1,ZTQUEUED=0
;if running again, check to see if complete
;if so, ask user to rerun
I $$CHKSTAT(0) D Q
. U 0 W !,"Task is already running or user opted to not restart"
. Q
D QUE
Q
QUE ; Entry point for taskman (live mode)
N NAMSPC S NAMSPC=$$NAMSPC^DG53618
N QQ,ZTSTOP,XREC,MTIEN,DIK,DA,DGTOT,DGDEL12,BEGTIME,PURGDT,DGDEL21
N TMP,ICDT,COUNT,TYPE,TYPNAM,DGDEL22,REC12,REC21,REC22
N DGBAD03,DGBADPAT,DGBADPER
N R12,PT,DFN,X,U
S U="^"
I '$D(TESTING) N TESTING S TESTING=0
I '$D(ZTQUEUED) N ZTQUEUED S ZTQUEUED=1
;
;get last run info if exists
S XREC=$G(^XTMP(NAMSPC,0,0))
S R12=+$P(XREC,U,1) ;last REC processed
S DGTOT=+$P(XREC,U,2) ;total records processed
S DGDEL12=+$P(XREC,U,3) ;total bad 408.12 records purged
S DGDEL21=+$P(XREC,U,7) ;total bad 408.21 records found
S DGDEL22=+$P(XREC,U,8) ;total bad 408.22 records found
S DGBADPAT=+$P(XREC,U,9) ;total bad pointer to file #2
S DGBADPER=+$P(XREC,U,10) ;total bad pointer to file #408.13
S DGBAD03=+$P(XREC,U,11) ;null or bad field # 03
;
;setup XTMP according to stds.
D SETUPX(90)
;
;init status field and start date & time if null
S $P(^XTMP(NAMSPC,0,0),U,5,6)="RUNNING^"
S:$P(^XTMP(NAMSPC,0,0),U,4)="" $P(^XTMP(NAMSPC,0,0),U,4)=$$NOW^XLFDT
;
;drive through 408.12 looking for bad variable pointers
S ZTSTOP=0
F QQ=1:1 S R12=$O(^DGPR(408.12,R12)) Q:(R12'>0)!ZTSTOP D
. ;check for stop request after every 20 processed DFN recs
. I QQ#20=0 D
. . S:$$S^%ZTLOAD ZTSTOP=1
. . I $D(^XTMP(NAMSPC,0,"STOP")) S ZTSTOP=1 K ^XTMP(NAMSPC,0,"STOP")
. . Q
. I ZTSTOP Q
. S DGTOT=DGTOT+1
. S $P(^XTMP(NAMSPC,0,0),U,1,2)=R12_U_DGTOT
. ;
. S DFN=$$GET1^DIQ(408.12,R12_",",.01,"I")
. S PT=$$GET1^DIQ(408.12,R12_",",.03,"I")
. ;
. ;good patient (#.01),good variable pointer (#.03)...quit
. I $$GOODPAT(DFN)="Y",$$GOODPTR(PT)="Y" Q
. ;
. ; cleanup Income Relation file #408.12 & the bad pointed to file
. ; either Patient file #2 or Income Person file #408.13
. I 'ZTQUEUED W !!,"File #408.12, ien ",R12," has a bad pointer to "
. ;if patient (#.01) is null
. I DFN="" D
. . S X="null patient (field #.01)"
. . I 'ZTQUEUED W X
. . S ^XTMP(NAMSPC,"BADPR",R12,"ERR",1)=X
. . S DGBADPAT=DGBADPAT+1
. . D ACHK03(R12,PT,ZTQUEUED,TESTING,.DGBADPAT,.DGBADPER,.DGBAD03)
. . Q
. ;patient #.01 not found
. I DFN'="",$$GOODPAT(DFN)="N" D
. . S X="patient "_DFN_" (field #.01)"
. . I 'ZTQUEUED W X
. . S ^XTMP(NAMSPC,"BADPR",R12,"ERR",1)=X
. . S DGBADPAT=DGBADPAT+1
. . ;I 'TESTING S DA=DFN,DIK="^DPT(" D ^DIK
. . D ACHK03(R12,PT,ZTQUEUED,TESTING,.DGBADPAT,.DGBADPER,.DGBAD03)
. . Q
. ;patient (#.03) is also a patient, is bad, but patient (# .01) is ok
. I $$GOODPAT(DFN)="Y",PT["DPT",$$GOODPTR(PT)="N" D
. . S X="patient "_$P(PT,";",1)_" (field #.03)"
. . I 'ZTQUEUED W X
. . S ^XTMP(NAMSPC,"BADPR",R12,"ERR",1)=X
. . S DGBADPAT=DGBADPAT+1
. . ;I 'TESTING S DA=$P(PT,";",1),DIK="^DPT(" D ^DIK
. . Q
. ;patient (#.01) is good, but income person is bad
. I $$GOODPAT(DFN)="Y",PT["DGPR",$$GOODPTR(PT)="N" D
. . S X="income person "_$P(PT,";",1)_" (field #.03)"
. . I 'ZTQUEUED W X
. . S ^XTMP(NAMSPC,"BADPR",R12,"ERR",1)=X
. . S DGBADPER=DGBADPER+1
. . I 'TESTING S DA=$P(PT,";",1),DIK="^DGPR(408.13," D ^DIK
. . Q
. ;patient #.01 is good, but #.03 is null
. I $$GOODPAT(DFN)="Y",PT="" D
. . S X="null field #.03"
. . I 'ZTQUEUED W X
. . S ^XTMP(NAMSPC,"BADPR",R12,"ERR",1)=X
. . S DGBAD03=DGBAD03+1
. . Q
. ;patient #.01 is good, but #.03 is not null
. ;and is bad
. I $$GOODPAT(DFN)="Y",PT'["DGPR",PT'["DPT",PT'="",$$GOODPTR(PT)="N" D
. . S X="variable pointer "_$P(PT,";",1)_" (field #.03)"
. . I 'ZTQUEUED W X
. . S ^XTMP(NAMSPC,"BADPR",R12,"ERR",1)=X
. . S DGBAD03=DGBAD03+1
. . Q
. D DEL40812(R12,.DGDEL12,.DGDEL21,.DGDEL22,ZTQUEUED,TESTING,NAMSPC)
. Q
;
;update last processed info
S X=$G(^XTMP(NAMSPC,0,0))
S $P(X,U,3)=DGDEL12,$P(X,U,7)=DGDEL21
S $P(X,U,8)=DGDEL22,$P(X,U,9)=DGBADPAT
S $P(X,U,10)=DGBADPER,$P(X,U,11)=DGBAD03
S ^XTMP(NAMSPC,0,0)=X
;set status and mail stats
I ZTSTOP S $P(^XTMP(NAMSPC,0,0),U,5,6)="STOPPED"_U_$$NOW^XLFDT
E S $P(^XTMP(NAMSPC,0,0),U,5,6)="COMPLETED"_U_$$NOW^XLFDT
S X=$$MAIL^DG53618M(TESTING)
K TESTING
L -^XTMP($$NAMSPC)
Q
;
GOODPAT(DFN) ;determine if patient is there
N X,U
S U="^"
I DFN="" Q "N"
I '$D(^DPT(DFN,0)) Q "N"
S X=$G(^DPT(DFN,0)) I X="" Q "N"
I X?13"^".E Q "N"
Q "Y"
;
GOODPTR(PT) ;determine if reference is there
N X,U,SUB,GL,REF
S U="^"
I PT'["DPT",PT'["DGPR" Q "N"
S SUB=$P(PT,";",1),GL=$P(PT,";",2)
I SUB="" Q "N"
I SUB'=+SUB S SUB=$C(34)_SUB_$C(34)
I GL'="DPT(",GL'="DGPR(408.13," Q "N"
S REF="^"_GL_SUB_",0)"
S X=$G(@REF)
I '$D(@REF) Q "N"
I $G(GL)["DPT",X?13"^".E Q "N"
I $G(GL)["DGPR",$P(X,U,1)="" Q "N"
Q "Y"
;
;at this point, you have a bad .01 field, but want
;to check .03 also
ACHK03(R12,PT,ZTQUEUED,TESTING,DGBADPAT,DGBADPER,DGBAD03) ;
;update counters to include bad variable pointers
;bad pointer to patient
I PT["DPT",$$GOODPTR(PT)="N" D Q
. S DGBADPAT=DGBADPAT+1
. S X="and bad patient pointer "_$P(PT,";",1)_" (field #.03)"
. I 'ZTQUEUED W !," ",X
. S ^XTMP(NAMSPC,"BADPR",R12,"ERR",2)=X
. ;I 'TESTING S DA=$P(PT,";",1),DIK="^DPT(" D ^DIK
. Q
;bad pointer to income person
I PT["DGPR",$$GOODPTR(PT)="N" D Q
. S DGBADPER=DGBADPER+1
. S X="and bad income person pointer "_$P(PT,";",1)_" (field #.03)"
. I 'ZTQUEUED W !," ",X
. S ^XTMP(NAMSPC,"BADPR",R12,"ERR",2)=X
. I 'TESTING S DA=$P(PT,";",1),DIK="^DGPR(408.13," D ^DIK
. Q
;null variable pointer
I PT="" D Q
. S X="and null pointer (field #.03)"
. I 'ZTQUEUED W !," ",X
. S DGBAD03=DGBAD03+1
. S ^XTMP(NAMSPC,"BADPR",R12,"ERR",2)=X
. Q
;bad variable pointer
I $$GOODPTR(PT)="N" D
. S X="and bad variable pointer "_$P(PT,";",1)_" (field #.03)"
. I 'ZTQUEUED W !," ",X
. S DGBAD03=DGBAD03+1
. S ^XTMP(NAMSPC,"BADPR",R12,"ERR",2)=X
. Q
Q
;
DEL40812(R12,DGDEL12,DGDEL21,DGDEL22,ZTQUEUED,TESTING,NAMSPC) ;
; Kill bad #408.12 file rec and files that point to it
N DA,DIK,R21,R22,X
S DA=R12,DIK="^DGPR(408.12," D ^DIK:'TESTING
S DGDEL12=DGDEL12+1
I 'ZTQUEUED W !,?2,"Deleting 408.12 ien > ",R12
;
;kill all 408.21's that point to the bad 408.12
S R21=0
F S R21=$O(^DGMT(408.21,"C",R12,R21)) Q:'R21 D
. I 'TESTING S DA=R21,DIK="^DGMT(408.21," D ^DIK
. S DGDEL21=DGDEL21+1
. S X="Deleting related ien "_R21_" in file #408.21"
. I 'ZTQUEUED W !,?4,X
. S ^XTMP(NAMSPC,"BADPR",R12,"REL",R21)=X
. ;
. ;kill all 408.22's that point to the bad 408.21
. S R22=0
. F S R22=$O(^DGMT(408.22,"AIND",R21,R22)) Q:'R22 D
. . I 'TESTING S DA=R22,DIK="^DGMT(408.22," D ^DIK
. . S DGDEL22=DGDEL22+1
. . S X="Deleting related ien "_R22_" in file # 408.22"
. . I 'ZTQUEUED W !,?6,X
. . S ^XTMP(NAMSPC,"BADPR",R12,"REL",R21,R22)=X
. . Q
. Q
Q
;
CHKSTAT(POST) ;
N Y,DUOUT,DTOUT,QUIT,STAT,STIME,NAMSPC
S QUIT=0
S NAMSPC=$$NAMSPC
L +^XTMP(NAMSPC):1
I '$T D BMES^XPDUTL("*** ALREADY RUNNING ***") Q 1
;
; get job status
S STAT=$P($G(^XTMP(NAMSPC,0,0)),U,5)
S STIME=$P($G(^XTMP(NAMSPC,0,0)),U,6)
;
I POST D KILIT Q 0
;
;if job Completed and run from menu opt, ask to Re-Run
I STAT="COMPLETED" D
. W " was Completed on "_$$FMTE^XLFDT(STIME)
. W !," Do you want to Re-Run again?"
. K DIR
. S DIR("?",1)=" Entering Y, will delete the XTMP global where theprevious cleanup"
. S DIR("?")=" information was stored and begin a new job, or N to cancel request"
. S DIR(0)="Y" D ^DIR
. I 'Y S QUIT=1 Q
. W !," ARE YOU SURE?"
. K DIR
. S DIR("?")="Enter Y to begin a new Job or N to cancel request"
. S DIR(0)="Y" D ^DIR
. I 'Y S QUIT=1 Q
. ;fall thru to re-run mode, kill ^XTMPs
. D KILIT
. Q
Q QUIT
;
KILIT ; kill Xtmp work file for a re-run
S:'$D(NAMSPC) NAMSPC=$$NAMSPC^DG53618
K ^XTMP(NAMSPC)
Q
;
STOP ; alternate stop method
S ^XTMP($$NAMSPC,0,"STOP")=""
Q
;
SETUPX(EXPDAY) ;Setup XTMP
N BEGTIME,PURGDT,NAMSPC,U
S U="^"
S NAMSPC=$$NAMSPC^DG53618
S BEGTIME=$$NOW^XLFDT()
S PURGDT=$$FMADD^XLFDT(BEGTIME,EXPDAY)
S ^XTMP(NAMSPC,0)=PURGDT_U_BEGTIME
S $P(^XTMP(NAMSPC,0),U,3)="Cleanup Bad Pointers In PATIENT RELATION File"
Q
;
NAMSPC() ; Return a consistent name space variable
Q $T(+0)
DG53618 ;ALB/GN/PHH,EG - DG*5.3*618 CLEANUP DANGLING RECS; 04/27/2005
+1 ;;5.3;Registration;**618,1015**;Aug 13, 1993;Build 21
+2 ;
+3 ; Cleans up dangling file Income Relation file #408.12 records where
+4 ; it points to bad or non-existent Income Person file #408.13 and
+5 ; Patient file #2 records.
+6 ;
+7 ; 1. If it points to file 2, that doesn't exist or has a bad 0 node,
+8 ; delete the 408.12 rec that points to the bad 2 rec, then
+9 ; delete the 408.21 that points to 408.12 rec, then
+10 ; delete the 408.22 rec that points to the 408.21.
+11 ; 2. Same logic will be used if points to bad 408.13 recs
+12 ;
+13 QUIT
+14 ;
POST ;post install entry tag call. processes entire file in live mode
+1 NEW ZTDTH,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTQUEUED,ZTSAVE,CHKPNT
+2 DO MES^XPDUTL("")
+3 DO MES^XPDUTL("=====================================================")
+4 DO MES^XPDUTL("Queuing Bad Patient Relation Pointers cleanup process.....")
+5 IF $$CHKSTAT(1)
Begin DoDot:1
+6 DO BMES^XPDUTL("ABORTING Post Install Cleanup Queuing")
+7 DO MES^XPDUTL("=====================================================")
+8 QUIT
End DoDot:1
QUIT
+9 SET ZTRTN="QUE^DG53618"
+10 SET ZTDESC="Cleanup Bad Pointers In Patient Relation File"
+11 SET ZTIO=""
SET ZTDTH=$HOROLOG
+12 SET CHKPNT=0
SET ZTSAVE("CHKPNT")=""
+13 DO ^%ZTLOAD
+14 DO MES^XPDUTL("This request queued as Task # "_ZTSK)
+15 DO MES^XPDUTL("=====================================================")
+16 DO MES^XPDUTL("")
+17 QUIT
+18 ;
TEST ; Entry point for taskman (testing mode)
+1 NEW TESTING,ZTQUEUED
+2 SET TESTING=1
SET ZTQUEUED=0
+3 ;if running again, check to see if complete
+4 ;if so, ask user to rerun
+5 IF $$CHKSTAT(0)
Begin DoDot:1
+6 USE 0
WRITE !,"Task is already running or user opted to not restart"
+7 QUIT
End DoDot:1
QUIT
+8 DO QUE
+9 QUIT
QUE ; Entry point for taskman (live mode)
+1 NEW NAMSPC
SET NAMSPC=$$NAMSPC^DG53618
+2 NEW QQ,ZTSTOP,XREC,MTIEN,DIK,DA,DGTOT,DGDEL12,BEGTIME,PURGDT,DGDEL21
+3 NEW TMP,ICDT,COUNT,TYPE,TYPNAM,DGDEL22,REC12,REC21,REC22
+4 NEW DGBAD03,DGBADPAT,DGBADPER
+5 NEW R12,PT,DFN,X,U
+6 SET U="^"
+7 IF '$DATA(TESTING)
NEW TESTING
SET TESTING=0
+8 IF '$DATA(ZTQUEUED)
NEW ZTQUEUED
SET ZTQUEUED=1
+9 ;
+10 ;get last run info if exists
+11 SET XREC=$GET(^XTMP(NAMSPC,0,0))
+12 ;last REC processed
SET R12=+$PIECE(XREC,U,1)
+13 ;total records processed
SET DGTOT=+$PIECE(XREC,U,2)
+14 ;total bad 408.12 records purged
SET DGDEL12=+$PIECE(XREC,U,3)
+15 ;total bad 408.21 records found
SET DGDEL21=+$PIECE(XREC,U,7)
+16 ;total bad 408.22 records found
SET DGDEL22=+$PIECE(XREC,U,8)
+17 ;total bad pointer to file #2
SET DGBADPAT=+$PIECE(XREC,U,9)
+18 ;total bad pointer to file #408.13
SET DGBADPER=+$PIECE(XREC,U,10)
+19 ;null or bad field # 03
SET DGBAD03=+$PIECE(XREC,U,11)
+20 ;
+21 ;setup XTMP according to stds.
+22 DO SETUPX(90)
+23 ;
+24 ;init status field and start date & time if null
+25 SET $PIECE(^XTMP(NAMSPC,0,0),U,5,6)="RUNNING^"
+26 IF $PIECE(^XTMP(NAMSPC,0,0),U,4)=""
SET $PIECE(^XTMP(NAMSPC,0,0),U,4)=$$NOW^XLFDT
+27 ;
+28 ;drive through 408.12 looking for bad variable pointers
+29 SET ZTSTOP=0
+30 FOR QQ=1:1
SET R12=$ORDER(^DGPR(408.12,R12))
IF (R12'>0)!ZTSTOP
QUIT
Begin DoDot:1
+31 ;check for stop request after every 20 processed DFN recs
+32 IF QQ#20=0
Begin DoDot:2
+33 IF $$S^%ZTLOAD
SET ZTSTOP=1
+34 IF $DATA(^XTMP(NAMSPC,0,"STOP"))
SET ZTSTOP=1
KILL ^XTMP(NAMSPC,0,"STOP")
+35 QUIT
End DoDot:2
+36 IF ZTSTOP
QUIT
+37 SET DGTOT=DGTOT+1
+38 SET $PIECE(^XTMP(NAMSPC,0,0),U,1,2)=R12_U_DGTOT
+39 ;
+40 SET DFN=$$GET1^DIQ(408.12,R12_",",.01,"I")
+41 SET PT=$$GET1^DIQ(408.12,R12_",",.03,"I")
+42 ;
+43 ;good patient (#.01),good variable pointer (#.03)...quit
+44 IF $$GOODPAT(DFN)="Y"
IF $$GOODPTR(PT)="Y"
QUIT
+45 ;
+46 ; cleanup Income Relation file #408.12 & the bad pointed to file
+47 ; either Patient file #2 or Income Person file #408.13
+48 IF 'ZTQUEUED
WRITE !!,"File #408.12, ien ",R12," has a bad pointer to "
+49 ;if patient (#.01) is null
+50 IF DFN=""
Begin DoDot:2
+51 SET X="null patient (field #.01)"
+52 IF 'ZTQUEUED
WRITE X
+53 SET ^XTMP(NAMSPC,"BADPR",R12,"ERR",1)=X
+54 SET DGBADPAT=DGBADPAT+1
+55 DO ACHK03(R12,PT,ZTQUEUED,TESTING,.DGBADPAT,.DGBADPER,.DGBAD03)
+56 QUIT
End DoDot:2
+57 ;patient #.01 not found
+58 IF DFN'=""
IF $$GOODPAT(DFN)="N"
Begin DoDot:2
+59 SET X="patient "_DFN_" (field #.01)"
+60 IF 'ZTQUEUED
WRITE X
+61 SET ^XTMP(NAMSPC,"BADPR",R12,"ERR",1)=X
+62 SET DGBADPAT=DGBADPAT+1
+63 ;I 'TESTING S DA=DFN,DIK="^DPT(" D ^DIK
+64 DO ACHK03(R12,PT,ZTQUEUED,TESTING,.DGBADPAT,.DGBADPER,.DGBAD03)
+65 QUIT
End DoDot:2
+66 ;patient (#.03) is also a patient, is bad, but patient (# .01) is ok
+67 IF $$GOODPAT(DFN)="Y"
IF PT["DPT"
IF $$GOODPTR(PT)="N"
Begin DoDot:2
+68 SET X="patient "_$PIECE(PT,";",1)_" (field #.03)"
+69 IF 'ZTQUEUED
WRITE X
+70 SET ^XTMP(NAMSPC,"BADPR",R12,"ERR",1)=X
+71 SET DGBADPAT=DGBADPAT+1
+72 ;I 'TESTING S DA=$P(PT,";",1),DIK="^DPT(" D ^DIK
+73 QUIT
End DoDot:2
+74 ;patient (#.01) is good, but income person is bad
+75 IF $$GOODPAT(DFN)="Y"
IF PT["DGPR"
IF $$GOODPTR(PT)="N"
Begin DoDot:2
+76 SET X="income person "_$PIECE(PT,";",1)_" (field #.03)"
+77 IF 'ZTQUEUED
WRITE X
+78 SET ^XTMP(NAMSPC,"BADPR",R12,"ERR",1)=X
+79 SET DGBADPER=DGBADPER+1
+80 IF 'TESTING
SET DA=$PIECE(PT,";",1)
SET DIK="^DGPR(408.13,"
DO ^DIK
+81 QUIT
End DoDot:2
+82 ;patient #.01 is good, but #.03 is null
+83 IF $$GOODPAT(DFN)="Y"
IF PT=""
Begin DoDot:2
+84 SET X="null field #.03"
+85 IF 'ZTQUEUED
WRITE X
+86 SET ^XTMP(NAMSPC,"BADPR",R12,"ERR",1)=X
+87 SET DGBAD03=DGBAD03+1
+88 QUIT
End DoDot:2
+89 ;patient #.01 is good, but #.03 is not null
+90 ;and is bad
+91 IF $$GOODPAT(DFN)="Y"
IF PT'["DGPR"
IF PT'["DPT"
IF PT'=""
IF $$GOODPTR(PT)="N"
Begin DoDot:2
+92 SET X="variable pointer "_$PIECE(PT,";",1)_" (field #.03)"
+93 IF 'ZTQUEUED
WRITE X
+94 SET ^XTMP(NAMSPC,"BADPR",R12,"ERR",1)=X
+95 SET DGBAD03=DGBAD03+1
+96 QUIT
End DoDot:2
+97 DO DEL40812(R12,.DGDEL12,.DGDEL21,.DGDEL22,ZTQUEUED,TESTING,NAMSPC)
+98 QUIT
End DoDot:1
+99 ;
+100 ;update last processed info
+101 SET X=$GET(^XTMP(NAMSPC,0,0))
+102 SET $PIECE(X,U,3)=DGDEL12
SET $PIECE(X,U,7)=DGDEL21
+103 SET $PIECE(X,U,8)=DGDEL22
SET $PIECE(X,U,9)=DGBADPAT
+104 SET $PIECE(X,U,10)=DGBADPER
SET $PIECE(X,U,11)=DGBAD03
+105 SET ^XTMP(NAMSPC,0,0)=X
+106 ;set status and mail stats
+107 IF ZTSTOP
SET $PIECE(^XTMP(NAMSPC,0,0),U,5,6)="STOPPED"_U_$$NOW^XLFDT
+108 IF '$TEST
SET $PIECE(^XTMP(NAMSPC,0,0),U,5,6)="COMPLETED"_U_$$NOW^XLFDT
+109 SET X=$$MAIL^DG53618M(TESTING)
+110 KILL TESTING
+111 LOCK -^XTMP($$NAMSPC)
+112 QUIT
+113 ;
GOODPAT(DFN) ;determine if patient is there
+1 NEW X,U
+2 SET U="^"
+3 IF DFN=""
QUIT "N"
+4 IF '$DATA(^DPT(DFN,0))
QUIT "N"
+5 SET X=$GET(^DPT(DFN,0))
IF X=""
QUIT "N"
+6 IF X?13"^".E
QUIT "N"
+7 QUIT "Y"
+8 ;
GOODPTR(PT) ;determine if reference is there
+1 NEW X,U,SUB,GL,REF
+2 SET U="^"
+3 IF PT'["DPT"
IF PT'["DGPR"
QUIT "N"
+4 SET SUB=$PIECE(PT,";",1)
SET GL=$PIECE(PT,";",2)
+5 IF SUB=""
QUIT "N"
+6 IF SUB'=+SUB
SET SUB=$CHAR(34)_SUB_$CHAR(34)
+7 IF GL'="DPT("
IF GL'="DGPR(408.13,"
QUIT "N"
+8 SET REF="^"_GL_SUB_",0)"
+9 SET X=$GET(@REF)
+10 IF '$DATA(@REF)
QUIT "N"
+11 IF $GET(GL)["DPT"
IF X?13"^".E
QUIT "N"
+12 IF $GET(GL)["DGPR"
IF $PIECE(X,U,1)=""
QUIT "N"
+13 QUIT "Y"
+14 ;
+15 ;at this point, you have a bad .01 field, but want
+16 ;to check .03 also
ACHK03(R12,PT,ZTQUEUED,TESTING,DGBADPAT,DGBADPER,DGBAD03) ;
+1 ;update counters to include bad variable pointers
+2 ;bad pointer to patient
+3 IF PT["DPT"
IF $$GOODPTR(PT)="N"
Begin DoDot:1
+4 SET DGBADPAT=DGBADPAT+1
+5 SET X="and bad patient pointer "_$PIECE(PT,";",1)_" (field #.03)"
+6 IF 'ZTQUEUED
WRITE !," ",X
+7 SET ^XTMP(NAMSPC,"BADPR",R12,"ERR",2)=X
+8 ;I 'TESTING S DA=$P(PT,";",1),DIK="^DPT(" D ^DIK
+9 QUIT
End DoDot:1
QUIT
+10 ;bad pointer to income person
+11 IF PT["DGPR"
IF $$GOODPTR(PT)="N"
Begin DoDot:1
+12 SET DGBADPER=DGBADPER+1
+13 SET X="and bad income person pointer "_$PIECE(PT,";",1)_" (field #.03)"
+14 IF 'ZTQUEUED
WRITE !," ",X
+15 SET ^XTMP(NAMSPC,"BADPR",R12,"ERR",2)=X
+16 IF 'TESTING
SET DA=$PIECE(PT,";",1)
SET DIK="^DGPR(408.13,"
DO ^DIK
+17 QUIT
End DoDot:1
QUIT
+18 ;null variable pointer
+19 IF PT=""
Begin DoDot:1
+20 SET X="and null pointer (field #.03)"
+21 IF 'ZTQUEUED
WRITE !," ",X
+22 SET DGBAD03=DGBAD03+1
+23 SET ^XTMP(NAMSPC,"BADPR",R12,"ERR",2)=X
+24 QUIT
End DoDot:1
QUIT
+25 ;bad variable pointer
+26 IF $$GOODPTR(PT)="N"
Begin DoDot:1
+27 SET X="and bad variable pointer "_$PIECE(PT,";",1)_" (field #.03)"
+28 IF 'ZTQUEUED
WRITE !," ",X
+29 SET DGBAD03=DGBAD03+1
+30 SET ^XTMP(NAMSPC,"BADPR",R12,"ERR",2)=X
+31 QUIT
End DoDot:1
+32 QUIT
+33 ;
DEL40812(R12,DGDEL12,DGDEL21,DGDEL22,ZTQUEUED,TESTING,NAMSPC) ;
+1 ; Kill bad #408.12 file rec and files that point to it
+2 NEW DA,DIK,R21,R22,X
+3 SET DA=R12
SET DIK="^DGPR(408.12,"
IF 'TESTING
DO ^DIK
+4 SET DGDEL12=DGDEL12+1
+5 IF 'ZTQUEUED
WRITE !,?2,"Deleting 408.12 ien > ",R12
+6 ;
+7 ;kill all 408.21's that point to the bad 408.12
+8 SET R21=0
+9 FOR
SET R21=$ORDER(^DGMT(408.21,"C",R12,R21))
IF 'R21
QUIT
Begin DoDot:1
+10 IF 'TESTING
SET DA=R21
SET DIK="^DGMT(408.21,"
DO ^DIK
+11 SET DGDEL21=DGDEL21+1
+12 SET X="Deleting related ien "_R21_" in file #408.21"
+13 IF 'ZTQUEUED
WRITE !,?4,X
+14 SET ^XTMP(NAMSPC,"BADPR",R12,"REL",R21)=X
+15 ;
+16 ;kill all 408.22's that point to the bad 408.21
+17 SET R22=0
+18 FOR
SET R22=$ORDER(^DGMT(408.22,"AIND",R21,R22))
IF 'R22
QUIT
Begin DoDot:2
+19 IF 'TESTING
SET DA=R22
SET DIK="^DGMT(408.22,"
DO ^DIK
+20 SET DGDEL22=DGDEL22+1
+21 SET X="Deleting related ien "_R22_" in file # 408.22"
+22 IF 'ZTQUEUED
WRITE !,?6,X
+23 SET ^XTMP(NAMSPC,"BADPR",R12,"REL",R21,R22)=X
+24 QUIT
End DoDot:2
+25 QUIT
End DoDot:1
+26 QUIT
+27 ;
CHKSTAT(POST) ;
+1 NEW Y,DUOUT,DTOUT,QUIT,STAT,STIME,NAMSPC
+2 SET QUIT=0
+3 SET NAMSPC=$$NAMSPC
+4 LOCK +^XTMP(NAMSPC):1
+5 IF '$TEST
DO BMES^XPDUTL("*** ALREADY RUNNING ***")
QUIT 1
+6 ;
+7 ; get job status
+8 SET STAT=$PIECE($GET(^XTMP(NAMSPC,0,0)),U,5)
+9 SET STIME=$PIECE($GET(^XTMP(NAMSPC,0,0)),U,6)
+10 ;
+11 IF POST
DO KILIT
QUIT 0
+12 ;
+13 ;if job Completed and run from menu opt, ask to Re-Run
+14 IF STAT="COMPLETED"
Begin DoDot:1
+15 WRITE " was Completed on "_$$FMTE^XLFDT(STIME)
+16 WRITE !," Do you want to Re-Run again?"
+17 KILL DIR
+18 SET DIR("?",1)=" Entering Y, will delete the XTMP global where theprevious cleanup"
+19 SET DIR("?")=" information was stored and begin a new job, or N to cancel request"
+20 SET DIR(0)="Y"
DO ^DIR
+21 IF 'Y
SET QUIT=1
QUIT
+22 WRITE !," ARE YOU SURE?"
+23 KILL DIR
+24 SET DIR("?")="Enter Y to begin a new Job or N to cancel request"
+25 SET DIR(0)="Y"
DO ^DIR
+26 IF 'Y
SET QUIT=1
QUIT
+27 ;fall thru to re-run mode, kill ^XTMPs
+28 DO KILIT
+29 QUIT
End DoDot:1
+30 QUIT QUIT
+31 ;
KILIT ; kill Xtmp work file for a re-run
+1 IF '$DATA(NAMSPC)
SET NAMSPC=$$NAMSPC^DG53618
+2 KILL ^XTMP(NAMSPC)
+3 QUIT
+4 ;
STOP ; alternate stop method
+1 SET ^XTMP($$NAMSPC,0,"STOP")=""
+2 QUIT
+3 ;
SETUPX(EXPDAY) ;Setup XTMP
+1 NEW BEGTIME,PURGDT,NAMSPC,U
+2 SET U="^"
+3 SET NAMSPC=$$NAMSPC^DG53618
+4 SET BEGTIME=$$NOW^XLFDT()
+5 SET PURGDT=$$FMADD^XLFDT(BEGTIME,EXPDAY)
+6 SET ^XTMP(NAMSPC,0)=PURGDT_U_BEGTIME
+7 SET $PIECE(^XTMP(NAMSPC,0),U,3)="Cleanup Bad Pointers In PATIENT RELATION File"
+8 QUIT
+9 ;
NAMSPC() ; Return a consistent name space variable
+1 QUIT $TEXT(+0)
