DG488 ;ALB/GN - CLEANUP PATIENT RELATION & INCOME FILES;12/11/02 ; 2/4/03 1:25pm
;;5.3;REGISTRATION;**488**;5-1-2001
;
Q
;
TEST ; Entry point for testing this routine, then fall thru.
S TESTING=1
EN ; Entry point to start job
;
N QUIT,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTQUEUED,ZTSAVE
;
S TESTING=+$G(TESTING)
; setup TM variables and Load
S ZTSAVE("TESTING")=""
S ZTRTN=("TASK^DG488")
S ZTDESC="Cleanup Patient Relation & Income Files"
S ZTIO=""
W !!,ZTDESC,!
;
;check if already running or completed.
S QUIT=$$CHKSTAT
I QUIT L -^XTMP($$NAMSPC) K TESTING Q
D ^%ZTLOAD
L -^XTMP($$NAMSPC)
K TESTING
I $D(ZTSK) D
. W !,"This request queued as Task # ",ZTSK,!
Q
;
TASK ; Entry point for taskman
L +^XTMP($$NAMSPC):10 I '$T D Q ;quit if can't get a lock
. S $P(^XTMP($$NAMSPC,0,0),U,12)="NO LOCK GAINED"
N ZTSTOP,LSTREC,DIK,DA,NAMSPC,DGT12,DG12,DG12X,DGT22,DG22,DG22X
N BEGTIME,PURGDT,DGFIL,IEN,DGIEN,BTIME,STAT,STIME,DGT21,DG21,DG21X
S NAMSPC=$$NAMSPC
S ZTDESC=$G(ZTDESC,"Cleanup of Patient Related Income files")
;
S TESTING=$G(TESTING,1) ;assume testing if not defined
;setup XTMP according to stds.
S BEGTIME=$$NOW^XLFDT()
S PURGDT=$$FMADD^XLFDT(BEGTIME,30)
S ^XTMP(NAMSPC,0)=PURGDT_U_BEGTIME_U_ZTDESC
S ^XTMP(NAMSPC,0,"TASKID")=$G(ZTSK,"DIRECT")
S ^XTMP(NAMSPC,0,"TESTING")=TESTING
;get last run data
D GETLAST
;init begin time, if not there, and status & stop time fields
S $P(^XTMP(NAMSPC,0,0),U,12,13)="RUNNING^"
S:$P(^XTMP(NAMSPC,0,0),U,11)="" $P(^XTMP(NAMSPC,0,0),U,11)=$$NOW^XLFDT
;start/restart cleanups
S:DGFIL="" DGFIL=408.12
I DGFIL=408.12 D
. S IEN=DGIEN,DGIEN=0
. D DG40812(IEN)
. S:'ZTSTOP DGFIL=408.21 ;continue if stop not requested
I DGFIL=408.21 D
. S IEN=DGIEN,DGIEN=0
. D DG40821(IEN)
. S:'ZTSTOP DGFIL=408.22 ;continue if stop not requested
I DGFIL=408.22 D
. S IEN=DGIEN
. D DG40822(IEN)
;
;set status and mail stats
I ZTSTOP S $P(^XTMP(NAMSPC,0,0),U,12,13)="STOPPED"_U_$$NOW^XLFDT
E S $P(^XTMP(NAMSPC,0,0),U,12,13)="COMPLETED"_U_$$NOW^XLFDT
D MAIL^DG488M
L -^XTMP(NAMSPC)
K TESTING
Q
;
DG40812(IEN) ; Main Cleanup driver for file 408.12
N REC12 S ZTSTOP=0
F S IEN=$O(^DGPR(408.12,"B",IEN)) Q:('IEN)!(ZTSTOP) D
. S REC12=0
. F S REC12=$O(^DGPR(408.12,"B",IEN,REC12)) Q:('REC12)!(ZTSTOP) D
. . S DGT12=DGT12+1
. . ;
. . ;if bad xref then kill the xref, else check for damaged 0 node
. . I '$D(^DGPR(408.12,REC12)) D
. . . S ^XTMP(NAMSPC,408.12,"B",IEN,REC12)=""
. . . I 'TESTING K ^DGPR(408.12,"B",IEN,REC12)
. . . S DG12X=DG12X+1
. . E D
. . . Q:+$P(^DGPR(408.12,REC12,0),U,3) ;quit if piece 3 is there
. . . M ^XTMP(NAMSPC,"408.12",REC12)=^DGPR(408.12,REC12)
. . . D DEL40821(REC12,.DG21,.DG21X)
. . . ;
. . . ;delete bad 408.12
. . . S DIK="^DGPR(408.12,",DA=REC12
. . . I 'TESTING D ^DIK
. . . K DIK,DA
. . . S DG12=DG12+1
. . ;
. . ;check for stop request after every 100 processed recs
. . I DGT12#100=0 D
. . . S:$$S^%ZTLOAD ZTSTOP=1
. . . I $D(^XTMP(NAMSPC,0,"STOP")) S ZTSTOP=1 K ^XTMP(NAMSPC,0,"STOP")
. . S LSTREC=DGFIL_"/"_IEN
. . S $P(^XTMP(NAMSPC,0,0),U,1)=LSTREC
. . S $P(^XTMP(NAMSPC,0,0),U,2,6)=DGT12_U_DG12_U_DG12X_U_DGT22_U_DG22
. . S $P(^XTMP(NAMSPC,0,0),U,9,10)=DG21_U_DG21X
Q
;
DEL40821(R12,DG21,DG21X) ; Delete any entries in 408.21 that point to the bad
; 408.12 record.
N REC21 S REC21=0
F S REC21=$O(^DGMT(408.21,"C",R12,REC21)) Q:'REC21 D
. ;if bad xref then kill the xref, else kill the real record
. I '$D(^DGMT(408.21,REC21)) D
. . S ^XTMP(NAMSPC,408.21,"C",R12,REC21)=""
. . I 'TESTING K ^DGMT(408.21,"C",R12,REC21)
. . S DG21X=DG21X+1
. E D
. . M ^XTMP(NAMSPC,"408.21",REC21)=^DGMT(408.21,REC21)
. . D DG22AIND(REC21)
. . S DIK="^DGMT(408.21,",DA=REC21
. . I 'TESTING D ^DIK
. . K DIK,DA
. . S DG21=DG21+1
Q
;
DG22AIND(R21) ;Delete any entries in 408.22 that is pointing to the bad 408.21
N REC22 S REC22=0
F S REC22=$O(^DGMT(408.22,"AIND",R21,REC22)) Q:'REC22 D
. S DGT22=DGT22+1
. ;if bad xref then kill the xref, else kill the real record
. I '$D(^DGMT(408.22,REC22)) D
. . I 'TESTING K ^DGMT(408.22,"AIND",R21,REC22)
. . S DG22=DG22+1
. E D
. . M ^XTMP(NAMSPC,"408.22",REC22)=^DGMT(408.22,REC22)
. . S DIK="^DGMT(408.22,",DA=REC22
. . I 'TESTING D ^DIK
. . K DIK,DA
. . S DG22=DG22+1
Q
;
DG40821(IEN) ; Main Cleanup driver for file 408.21, If 408.21 not pointed to
; by any 408.22 record, then delete it and check 408.12 for possible
; deletion as well.
N REC21 S ZTSTOP=0
F S IEN=$O(^DGMT(408.21,"B",IEN)) Q:('IEN)!(ZTSTOP) D
. S REC21=0
. F S REC21=$O(^DGMT(408.21,"B",IEN,REC21)) Q:('REC21)!(ZTSTOP) D
. . S DGT21=DGT21+1
. . ;if bad xref then kill the xref, else check for damaged 0 node
. . I '$D(^DGMT(408.21,REC21)) D
. . . S ^XTMP(NAMSPC,408.21,"B",IEN,REC21)=""
. . . I 'TESTING K ^DGMT(408.21,"B",IEN,REC21)
. . . S DG21X=DG21X+1
. . E D
. . . Q:$D(^DGMT(408.22,"AIND",REC21)) ;quit if 408.21 pointed to
. . . M ^XTMP(NAMSPC,"408.21",REC21)=^DGMT(408.21,REC21)
. . . S REC12=0
. . . D DEL21(REC21,.REC12,.DG21)
. . . D:REC12 CHK40812(REC12,REC21,.DG12)
. . ;
. . ;check for stop request after every 100 processed recs
. . I DGT21#100=0 D
. . . S:$$S^%ZTLOAD ZTSTOP=1
. . . I $D(^XTMP(NAMSPC,0,"STOP")) S ZTSTOP=1 K ^XTMP(NAMSPC,0,"STOP")
. . S LSTREC=DGFIL_"/"_IEN
. . S $P(^XTMP(NAMSPC,0,0),U,1)=LSTREC
. . S $P(^XTMP(NAMSPC,0,0),U,3)=DG12
. . S $P(^XTMP(NAMSPC,0,0),U,8,10)=DGT21_U_DG21_U_DG21X
Q
;
DEL21(R21,R12,DG21) ; save to Xtmp & associated REC12, then delete the 408.21
Q:'$D(^DGMT(408.21,R21))
M ^XTMP(NAMSPC,"408.21",R21)=^DGMT(408.21,R21)
S R12=+$P($G(^DGMT(408.21,R21,0)),U,2)
S DIK="^DGMT(408.21,",DA=R21
I 'TESTING D ^DIK
K DIK,DA
S DG21=DG21+1
Q
;
CHK40812(R12,R21,DG12) ; delete 408.12's if no other 408.21's pointing to it
N XX,OK,REC21 S (REC21,OK)=0
F XX=0:1 S REC21=$O(^DGMT(408.21,"C",R12,REC21)) Q:'REC21 D
. S:REC21=R21 OK=1
Q:XX>1 ;quit if other 408.21's are pointing to 408.12
Q:(XX=1)&('OK) ;quit if only one rec and not the correct one
;
M ^XTMP(NAMSPC,"408.12",R12)=^DGPR(408.12,R12)
S DIK="^DGPR(408.12,",DA=R12
I 'TESTING D ^DIK
K DIK,DA
S DG12=DG12+1
Q
;
DG40822(IEN) ; Main Cleanup driver for file 408.22
N REC22 S ZTSTOP=0
F S IEN=$O(^DGMT(408.22,"B",IEN)) Q:('IEN)!(ZTSTOP) D
. S REC22=0
. F S REC22=$O(^DGMT(408.22,"B",IEN,REC22)) Q:('REC22)!(ZTSTOP) D
. . S DGT22=DGT22+1
. . ;
. . ;if bad xref then kill the xref, else check for damaged 0 node
. . I '$D(^DGMT(408.22,REC22)) D
. . . S ^XTMP(NAMSPC,"408.22","B",IEN,REC22)=""
. . . I 'TESTING K ^DGMT(408.22,"B",IEN,REC22)
. . . S DG22X=DG22X+1
. . E D
. . . Q:+$P(^DGMT(408.22,REC22,0),U,2) ;quit if piece 2 is there
. . . ;save & delete bad 408.22 rec
. . . M ^XTMP(NAMSPC,"408.22",REC22)=^DGMT(408.22,REC22)
. . . S DIK="^DGMT(408.22,",DA=REC22
. . . I 'TESTING D ^DIK
. . . K DIK,DA
. . . S DG22=DG22+1
. . ;
. . ;check for stop request after every 100 processed recs
. . I DGT22#100=0 D
. . . S:$$S^%ZTLOAD ZTSTOP=1
. . . I $D(^XTMP(NAMSPC,0,"STOP")) S ZTSTOP=1 K ^XTMP(NAMSPC,0,"STOP")
. . S LSTREC=DGFIL_"/"_IEN
. . S $P(^XTMP(NAMSPC,0,0),U,1)=LSTREC
. . S $P(^XTMP(NAMSPC,0,0),U,5,7)=DGT22_U_DG22_U_DG22X
Q
;
CHKSTAT() ;check if job is running, stopped, or completed
N Y,DUOUT,DTOUT,QUIT,NAMSPC
S QUIT=0
S NAMSPC=$$NAMSPC
L +^XTMP(NAMSPC):1
I '$T W !!,*7,"*** ALREADY RUNNING ***" H 4 Q 1
;
; get current mode
N TESTMODE S TESTMODE=$G(^XTMP(NAMSPC,0,"TESTING"))
; get job status
S STAT=$P($G(^XTMP(NAMSPC,0,0)),U,12)
S STIME=$P($G(^XTMP(NAMSPC,0,0)),U,13)
Q:STAT="" QUIT
;
;if job Completed or trying to resume in Live mode when previously
;incompleted in Test mode, ask to Re-Run
I STAT="COMPLETED" D
. D MSG(.QUIT)
E D
. I ('TESTING&TESTMODE)!(TESTING&'TESTMODE) D MSG(.QUIT)
Q QUIT
;
GETLAST ;get last run info
S DGFIL=$P($G(^XTMP(NAMSPC,0,0)),"/") ;file
S DGIEN=+$P($G(^XTMP(NAMSPC,0,0)),"/",2) ;ien
S DGT12=+$P($G(^XTMP(NAMSPC,0,0)),U,2) ;tot 408.12 recs processed
S DG12=+$P($G(^XTMP(NAMSPC,0,0)),U,3) ;tot 408.12 recs purged
S DG12X=+$P($G(^XTMP(NAMSPC,0,0)),U,4) ;tot bad 408.12 "B" purged
S DGT22=+$P($G(^XTMP(NAMSPC,0,0)),U,5) ;tot 408.22 recs processed
S DG22=+$P($G(^XTMP(NAMSPC,0,0)),U,6) ;tot 408.22 recs purged
S DG22X=+$P($G(^XTMP(NAMSPC,0,0)),U,7) ;tot bad 408.22 "B" purged
S DGT21=+$P($G(^XTMP(NAMSPC,0,0)),U,8) ;tot 408.21 recs processed
S DG21=+$P($G(^XTMP(NAMSPC,0,0)),U,9) ;tot 408.21 recs purged
S DG21X=+$P($G(^XTMP(NAMSPC,0,0)),U,10) ;tot bad 408.21 "C" purged
S BTIME=$P($G(^XTMP(NAMSPC,0,0)),U,11) ;begin time
S STAT=$P($G(^XTMP(NAMSPC,0,0)),U,12) ;status
S STIME=$P($G(^XTMP(NAMSPC,0,0)),U,13) ;stop time
Q
;
MSG(QUIT) ;print message to user
W " was "_STAT_" on "_$$FMTE^XLFDT(STIME)
W " in "_$S(TESTMODE:"TEST",1:"LIVE")_" mode "
W !," Do you want to Re-Run in "_$S(TESTING:"TEST",1:"LIVE")
W " mode?"
K DIR
S DIR("?",1)=" Entering Y, will delete the XTMP global where the previous 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 ^XTMP
K ^XTMP(NAMSPC)
Q
;
STOP ; alternate stop method
S ^XTMP($$NAMSPC,0,"STOP")=""
Q
NAMSPC() ;
Q "DG*5.3*488"
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG488 9777 printed Sep 23, 2025@20:11:17 Page 2
DG488 ;ALB/GN - CLEANUP PATIENT RELATION & INCOME FILES;12/11/02 ; 2/4/03 1:25pm
+1 ;;5.3;REGISTRATION;**488**;5-1-2001
+2 ;
+3 QUIT
+4 ;
TEST ; Entry point for testing this routine, then fall thru.
+1 SET TESTING=1
EN ; Entry point to start job
+1 ;
+2 NEW QUIT,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTQUEUED,ZTSAVE
+3 ;
+4 SET TESTING=+$GET(TESTING)
+5 ; setup TM variables and Load
+6 SET ZTSAVE("TESTING")=""
+7 SET ZTRTN=("TASK^DG488")
+8 SET ZTDESC="Cleanup Patient Relation & Income Files"
+9 SET ZTIO=""
+10 WRITE !!,ZTDESC,!
+11 ;
+12 ;check if already running or completed.
+13 SET QUIT=$$CHKSTAT
+14 IF QUIT
LOCK -^XTMP($$NAMSPC)
KILL TESTING
QUIT
+15 DO ^%ZTLOAD
+16 LOCK -^XTMP($$NAMSPC)
+17 KILL TESTING
+18 IF $DATA(ZTSK)
Begin DoDot:1
+19 WRITE !,"This request queued as Task # ",ZTSK,!
End DoDot:1
+20 QUIT
+21 ;
TASK ; Entry point for taskman
+1 ;quit if can't get a lock
LOCK +^XTMP($$NAMSPC):10
IF '$TEST
Begin DoDot:1
+2 SET $PIECE(^XTMP($$NAMSPC,0,0),U,12)="NO LOCK GAINED"
End DoDot:1
QUIT
+3 NEW ZTSTOP,LSTREC,DIK,DA,NAMSPC,DGT12,DG12,DG12X,DGT22,DG22,DG22X
+4 NEW BEGTIME,PURGDT,DGFIL,IEN,DGIEN,BTIME,STAT,STIME,DGT21,DG21,DG21X
+5 SET NAMSPC=$$NAMSPC
+6 SET ZTDESC=$GET(ZTDESC,"Cleanup of Patient Related Income files")
+7 ;
+8 ;assume testing if not defined
SET TESTING=$GET(TESTING,1)
+9 ;setup XTMP according to stds.
+10 SET BEGTIME=$$NOW^XLFDT()
+11 SET PURGDT=$$FMADD^XLFDT(BEGTIME,30)
+12 SET ^XTMP(NAMSPC,0)=PURGDT_U_BEGTIME_U_ZTDESC
+13 SET ^XTMP(NAMSPC,0,"TASKID")=$GET(ZTSK,"DIRECT")
+14 SET ^XTMP(NAMSPC,0,"TESTING")=TESTING
+15 ;get last run data
+16 DO GETLAST
+17 ;init begin time, if not there, and status & stop time fields
+18 SET $PIECE(^XTMP(NAMSPC,0,0),U,12,13)="RUNNING^"
+19 if $PIECE(^XTMP(NAMSPC,0,0),U,11)=""
SET $PIECE(^XTMP(NAMSPC,0,0),U,11)=$$NOW^XLFDT
+20 ;start/restart cleanups
+21 if DGFIL=""
SET DGFIL=408.12
+22 IF DGFIL=408.12
Begin DoDot:1
+23 SET IEN=DGIEN
SET DGIEN=0
+24 DO DG40812(IEN)
+25 ;continue if stop not requested
if 'ZTSTOP
SET DGFIL=408.21
End DoDot:1
+26 IF DGFIL=408.21
Begin DoDot:1
+27 SET IEN=DGIEN
SET DGIEN=0
+28 DO DG40821(IEN)
+29 ;continue if stop not requested
if 'ZTSTOP
SET DGFIL=408.22
End DoDot:1
+30 IF DGFIL=408.22
Begin DoDot:1
+31 SET IEN=DGIEN
+32 DO DG40822(IEN)
End DoDot:1
+33 ;
+34 ;set status and mail stats
+35 IF ZTSTOP
SET $PIECE(^XTMP(NAMSPC,0,0),U,12,13)="STOPPED"_U_$$NOW^XLFDT
+36 IF '$TEST
SET $PIECE(^XTMP(NAMSPC,0,0),U,12,13)="COMPLETED"_U_$$NOW^XLFDT
+37 DO MAIL^DG488M
+38 LOCK -^XTMP(NAMSPC)
+39 KILL TESTING
+40 QUIT
+41 ;
DG40812(IEN) ; Main Cleanup driver for file 408.12
+1 NEW REC12
SET ZTSTOP=0
+2 FOR
SET IEN=$ORDER(^DGPR(408.12,"B",IEN))
if ('IEN)!(ZTSTOP)
QUIT
Begin DoDot:1
+3 SET REC12=0
+4 FOR
SET REC12=$ORDER(^DGPR(408.12,"B",IEN,REC12))
if ('REC12)!(ZTSTOP)
QUIT
Begin DoDot:2
+5 SET DGT12=DGT12+1
+6 ;
+7 ;if bad xref then kill the xref, else check for damaged 0 node
+8 IF '$DATA(^DGPR(408.12,REC12))
Begin DoDot:3
+9 SET ^XTMP(NAMSPC,408.12,"B",IEN,REC12)=""
+10 IF 'TESTING
KILL ^DGPR(408.12,"B",IEN,REC12)
+11 SET DG12X=DG12X+1
End DoDot:3
+12 IF '$TEST
Begin DoDot:3
+13 ;quit if piece 3 is there
if +$PIECE(^DGPR(408.12,REC12,0),U,3)
QUIT
+14 MERGE ^XTMP(NAMSPC,"408.12",REC12)=^DGPR(408.12,REC12)
+15 DO DEL40821(REC12,.DG21,.DG21X)
+16 ;
+17 ;delete bad 408.12
+18 SET DIK="^DGPR(408.12,"
SET DA=REC12
+19 IF 'TESTING
DO ^DIK
+20 KILL DIK,DA
+21 SET DG12=DG12+1
End DoDot:3
+22 ;
+23 ;check for stop request after every 100 processed recs
+24 IF DGT12#100=0
Begin DoDot:3
+25 if $$S^%ZTLOAD
SET ZTSTOP=1
+26 IF $DATA(^XTMP(NAMSPC,0,"STOP"))
SET ZTSTOP=1
KILL ^XTMP(NAMSPC,0,"STOP")
End DoDot:3
+27 SET LSTREC=DGFIL_"/"_IEN
+28 SET $PIECE(^XTMP(NAMSPC,0,0),U,1)=LSTREC
+29 SET $PIECE(^XTMP(NAMSPC,0,0),U,2,6)=DGT12_U_DG12_U_DG12X_U_DGT22_U_DG22
+30 SET $PIECE(^XTMP(NAMSPC,0,0),U,9,10)=DG21_U_DG21X
End DoDot:2
End DoDot:1
+31 QUIT
+32 ;
DEL40821(R12,DG21,DG21X) ; Delete any entries in 408.21 that point to the bad
+1 ; 408.12 record.
+2 NEW REC21
SET REC21=0
+3 FOR
SET REC21=$ORDER(^DGMT(408.21,"C",R12,REC21))
if 'REC21
QUIT
Begin DoDot:1
+4 ;if bad xref then kill the xref, else kill the real record
+5 IF '$DATA(^DGMT(408.21,REC21))
Begin DoDot:2
+6 SET ^XTMP(NAMSPC,408.21,"C",R12,REC21)=""
+7 IF 'TESTING
KILL ^DGMT(408.21,"C",R12,REC21)
+8 SET DG21X=DG21X+1
End DoDot:2
+9 IF '$TEST
Begin DoDot:2
+10 MERGE ^XTMP(NAMSPC,"408.21",REC21)=^DGMT(408.21,REC21)
+11 DO DG22AIND(REC21)
+12 SET DIK="^DGMT(408.21,"
SET DA=REC21
+13 IF 'TESTING
DO ^DIK
+14 KILL DIK,DA
+15 SET DG21=DG21+1
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
DG22AIND(R21) ;Delete any entries in 408.22 that is pointing to the bad 408.21
+1 NEW REC22
SET REC22=0
+2 FOR
SET REC22=$ORDER(^DGMT(408.22,"AIND",R21,REC22))
if 'REC22
QUIT
Begin DoDot:1
+3 SET DGT22=DGT22+1
+4 ;if bad xref then kill the xref, else kill the real record
+5 IF '$DATA(^DGMT(408.22,REC22))
Begin DoDot:2
+6 IF 'TESTING
KILL ^DGMT(408.22,"AIND",R21,REC22)
+7 SET DG22=DG22+1
End DoDot:2
+8 IF '$TEST
Begin DoDot:2
+9 MERGE ^XTMP(NAMSPC,"408.22",REC22)=^DGMT(408.22,REC22)
+10 SET DIK="^DGMT(408.22,"
SET DA=REC22
+11 IF 'TESTING
DO ^DIK
+12 KILL DIK,DA
+13 SET DG22=DG22+1
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
DG40821(IEN) ; Main Cleanup driver for file 408.21, If 408.21 not pointed to
+1 ; by any 408.22 record, then delete it and check 408.12 for possible
+2 ; deletion as well.
+3 NEW REC21
SET ZTSTOP=0
+4 FOR
SET IEN=$ORDER(^DGMT(408.21,"B",IEN))
if ('IEN)!(ZTSTOP)
QUIT
Begin DoDot:1
+5 SET REC21=0
+6 FOR
SET REC21=$ORDER(^DGMT(408.21,"B",IEN,REC21))
if ('REC21)!(ZTSTOP)
QUIT
Begin DoDot:2
+7 SET DGT21=DGT21+1
+8 ;if bad xref then kill the xref, else check for damaged 0 node
+9 IF '$DATA(^DGMT(408.21,REC21))
Begin DoDot:3
+10 SET ^XTMP(NAMSPC,408.21,"B",IEN,REC21)=""
+11 IF 'TESTING
KILL ^DGMT(408.21,"B",IEN,REC21)
+12 SET DG21X=DG21X+1
End DoDot:3
+13 IF '$TEST
Begin DoDot:3
+14 ;quit if 408.21 pointed to
if $DATA(^DGMT(408.22,"AIND",REC21))
QUIT
+15 MERGE ^XTMP(NAMSPC,"408.21",REC21)=^DGMT(408.21,REC21)
+16 SET REC12=0
+17 DO DEL21(REC21,.REC12,.DG21)
+18 if REC12
DO CHK40812(REC12,REC21,.DG12)
End DoDot:3
+19 ;
+20 ;check for stop request after every 100 processed recs
+21 IF DGT21#100=0
Begin DoDot:3
+22 if $$S^%ZTLOAD
SET ZTSTOP=1
+23 IF $DATA(^XTMP(NAMSPC,0,"STOP"))
SET ZTSTOP=1
KILL ^XTMP(NAMSPC,0,"STOP")
End DoDot:3
+24 SET LSTREC=DGFIL_"/"_IEN
+25 SET $PIECE(^XTMP(NAMSPC,0,0),U,1)=LSTREC
+26 SET $PIECE(^XTMP(NAMSPC,0,0),U,3)=DG12
+27 SET $PIECE(^XTMP(NAMSPC,0,0),U,8,10)=DGT21_U_DG21_U_DG21X
End DoDot:2
End DoDot:1
+28 QUIT
+29 ;
DEL21(R21,R12,DG21) ; save to Xtmp & associated REC12, then delete the 408.21
+1 if '$DATA(^DGMT(408.21,R21))
QUIT
+2 MERGE ^XTMP(NAMSPC,"408.21",R21)=^DGMT(408.21,R21)
+3 SET R12=+$PIECE($GET(^DGMT(408.21,R21,0)),U,2)
+4 SET DIK="^DGMT(408.21,"
SET DA=R21
+5 IF 'TESTING
DO ^DIK
+6 KILL DIK,DA
+7 SET DG21=DG21+1
+8 QUIT
+9 ;
CHK40812(R12,R21,DG12) ; delete 408.12's if no other 408.21's pointing to it
+1 NEW XX,OK,REC21
SET (REC21,OK)=0
+2 FOR XX=0:1
SET REC21=$ORDER(^DGMT(408.21,"C",R12,REC21))
if 'REC21
QUIT
Begin DoDot:1
+3 if REC21=R21
SET OK=1
End DoDot:1
+4 ;quit if other 408.21's are pointing to 408.12
if XX>1
QUIT
+5 ;quit if only one rec and not the correct one
if (XX=1)&('OK)
QUIT
+6 ;
+7 MERGE ^XTMP(NAMSPC,"408.12",R12)=^DGPR(408.12,R12)
+8 SET DIK="^DGPR(408.12,"
SET DA=R12
+9 IF 'TESTING
DO ^DIK
+10 KILL DIK,DA
+11 SET DG12=DG12+1
+12 QUIT
+13 ;
DG40822(IEN) ; Main Cleanup driver for file 408.22
+1 NEW REC22
SET ZTSTOP=0
+2 FOR
SET IEN=$ORDER(^DGMT(408.22,"B",IEN))
if ('IEN)!(ZTSTOP)
QUIT
Begin DoDot:1
+3 SET REC22=0
+4 FOR
SET REC22=$ORDER(^DGMT(408.22,"B",IEN,REC22))
if ('REC22)!(ZTSTOP)
QUIT
Begin DoDot:2
+5 SET DGT22=DGT22+1
+6 ;
+7 ;if bad xref then kill the xref, else check for damaged 0 node
+8 IF '$DATA(^DGMT(408.22,REC22))
Begin DoDot:3
+9 SET ^XTMP(NAMSPC,"408.22","B",IEN,REC22)=""
+10 IF 'TESTING
KILL ^DGMT(408.22,"B",IEN,REC22)
+11 SET DG22X=DG22X+1
End DoDot:3
+12 IF '$TEST
Begin DoDot:3
+13 ;quit if piece 2 is there
if +$PIECE(^DGMT(408.22,REC22,0),U,2)
QUIT
+14 ;save & delete bad 408.22 rec
+15 MERGE ^XTMP(NAMSPC,"408.22",REC22)=^DGMT(408.22,REC22)
+16 SET DIK="^DGMT(408.22,"
SET DA=REC22
+17 IF 'TESTING
DO ^DIK
+18 KILL DIK,DA
+19 SET DG22=DG22+1
End DoDot:3
+20 ;
+21 ;check for stop request after every 100 processed recs
+22 IF DGT22#100=0
Begin DoDot:3
+23 if $$S^%ZTLOAD
SET ZTSTOP=1
+24 IF $DATA(^XTMP(NAMSPC,0,"STOP"))
SET ZTSTOP=1
KILL ^XTMP(NAMSPC,0,"STOP")
End DoDot:3
+25 SET LSTREC=DGFIL_"/"_IEN
+26 SET $PIECE(^XTMP(NAMSPC,0,0),U,1)=LSTREC
+27 SET $PIECE(^XTMP(NAMSPC,0,0),U,5,7)=DGT22_U_DG22_U_DG22X
End DoDot:2
End DoDot:1
+28 QUIT
+29 ;
CHKSTAT() ;check if job is running, stopped, or completed
+1 NEW Y,DUOUT,DTOUT,QUIT,NAMSPC
+2 SET QUIT=0
+3 SET NAMSPC=$$NAMSPC
+4 LOCK +^XTMP(NAMSPC):1
+5 IF '$TEST
WRITE !!,*7,"*** ALREADY RUNNING ***"
HANG 4
QUIT 1
+6 ;
+7 ; get current mode
+8 NEW TESTMODE
SET TESTMODE=$GET(^XTMP(NAMSPC,0,"TESTING"))
+9 ; get job status
+10 SET STAT=$PIECE($GET(^XTMP(NAMSPC,0,0)),U,12)
+11 SET STIME=$PIECE($GET(^XTMP(NAMSPC,0,0)),U,13)
+12 if STAT=""
QUIT QUIT
+13 ;
+14 ;if job Completed or trying to resume in Live mode when previously
+15 ;incompleted in Test mode, ask to Re-Run
+16 IF STAT="COMPLETED"
Begin DoDot:1
+17 DO MSG(.QUIT)
End DoDot:1
+18 IF '$TEST
Begin DoDot:1
+19 IF ('TESTING&TESTMODE)!(TESTING&'TESTMODE)
DO MSG(.QUIT)
End DoDot:1
+20 QUIT QUIT
+21 ;
GETLAST ;get last run info
+1 ;file
SET DGFIL=$PIECE($GET(^XTMP(NAMSPC,0,0)),"/")
+2 ;ien
SET DGIEN=+$PIECE($GET(^XTMP(NAMSPC,0,0)),"/",2)
+3 ;tot 408.12 recs processed
SET DGT12=+$PIECE($GET(^XTMP(NAMSPC,0,0)),U,2)
+4 ;tot 408.12 recs purged
SET DG12=+$PIECE($GET(^XTMP(NAMSPC,0,0)),U,3)
+5 ;tot bad 408.12 "B" purged
SET DG12X=+$PIECE($GET(^XTMP(NAMSPC,0,0)),U,4)
+6 ;tot 408.22 recs processed
SET DGT22=+$PIECE($GET(^XTMP(NAMSPC,0,0)),U,5)
+7 ;tot 408.22 recs purged
SET DG22=+$PIECE($GET(^XTMP(NAMSPC,0,0)),U,6)
+8 ;tot bad 408.22 "B" purged
SET DG22X=+$PIECE($GET(^XTMP(NAMSPC,0,0)),U,7)
+9 ;tot 408.21 recs processed
SET DGT21=+$PIECE($GET(^XTMP(NAMSPC,0,0)),U,8)
+10 ;tot 408.21 recs purged
SET DG21=+$PIECE($GET(^XTMP(NAMSPC,0,0)),U,9)
+11 ;tot bad 408.21 "C" purged
SET DG21X=+$PIECE($GET(^XTMP(NAMSPC,0,0)),U,10)
+12 ;begin time
SET BTIME=$PIECE($GET(^XTMP(NAMSPC,0,0)),U,11)
+13 ;status
SET STAT=$PIECE($GET(^XTMP(NAMSPC,0,0)),U,12)
+14 ;stop time
SET STIME=$PIECE($GET(^XTMP(NAMSPC,0,0)),U,13)
+15 QUIT
+16 ;
MSG(QUIT) ;print message to user
+1 WRITE " was "_STAT_" on "_$$FMTE^XLFDT(STIME)
+2 WRITE " in "_$SELECT(TESTMODE:"TEST",1:"LIVE")_" mode "
+3 WRITE !," Do you want to Re-Run in "_$SELECT(TESTING:"TEST",1:"LIVE")
+4 WRITE " mode?"
+5 KILL DIR
+6 SET DIR("?",1)=" Entering Y, will delete the XTMP global where the previous cleanup"
+7 SET DIR("?")=" information was stored and begin a new job, or N to cancel request"
+8 SET DIR(0)="Y"
DO ^DIR
+9 IF 'Y
SET QUIT=1
QUIT
+10 WRITE !," ARE YOU SURE?"
+11 KILL DIR
+12 SET DIR("?")="Enter Y to begin a new Job or N to cancel request"
+13 SET DIR(0)="Y"
DO ^DIR
+14 IF 'Y
SET QUIT=1
QUIT
+15 ;fall thru to re-run mode, kill ^XTMP
+16 KILL ^XTMP(NAMSPC)
+17 QUIT
+18 ;
STOP ; alternate stop method
+1 SET ^XTMP($$NAMSPC,0,"STOP")=""
+2 QUIT
NAMSPC() ;
+1 QUIT "DG*5.3*488"
