Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DG488

DG488.m

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