DG53591 ;ALB/GN - DG*5.3*591 CLEANUP FOR OVERLAYED INCOME TEST THRESHOLD AND STATUS; 3/17/04 12:26pm ; 7/29/04 11:33am
;;5.3;Registration;**591,1015**;Aug 13, 1993;Build 21
Q
;
SITETEST ; Site test Entry tag. Allows incremental testing in live mode
N QUIT,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTQUEUED,ZTSAVE,CHKPNT
S CHKPNT=3
W !,"Do you want to process the next "_CHKPNT_" bad tests and stop for review? "
K DIR
S DIR("?",1)=" Enter Y to process the next "_CHKPNT_" bad tests it finds and stop the utility."
S DIR("?",2)=" This will allow you to verify the cleanup in small steps. Enter N to process"
S DIR("?")=" the remainder of the file to completion."
S DIR(0)="Y" D ^DIR
I $D(DTOUT)!$D(DUOUT) W !,"Cancelled...",! Q
;
S:'Y CHKPNT=0 ;do not use check points
;
; setup TM variables and Load
S ZTRTN=$S($G(TESTING):"TEST^DG53591",1:"QUE^DG53591")
S ZTDESC="Cleanup Bad Thresholds in the Means Test file"
S ZTIO=""
S ZTSAVE("CHKPNT")=""
;
W !!,ZTDESC,!
;check if already running or completed.
S QUIT=$$CHKSTAT(0)
Q:QUIT
D ^%ZTLOAD
L -^XTMP($$NAMSPC)
I $D(ZTSK) D
. W !,"This request queued as Task # ",ZTSK,!
Q
;
POST ;post install entry tag call. processes entire file in live mode
I +$G(XPDQUES("POS1"))=0 D Q
. D MES^XPDUTL("")
. D MES^XPDUTL("==================================================")
. D MES^XPDUTL(" POST INSTALL ABORTED AND WAS NOT SENT TO TASKMAN")
. D MES^XPDUTL("==================================================")
. D MES^XPDUTL("")
N ZTDTH,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTQUEUED,ZTSAVE,CHKPNT
D MES^XPDUTL("")
D MES^XPDUTL("=====================================================")
D MES^XPDUTL("Queuing Bad Income Threshold Test Purge Utility.....")
I $$CHKSTAT(1) D Q
. D BMES^XPDUTL("ABORTING Post Install Utility Queuing")
. D MES^XPDUTL("=====================================================")
S ZTRTN="QUE^DG53591"
S ZTDESC="Cleanup Bad Thresholds in the Means Test file"
S ZTIO="",ZTDTH=$H
S CHKPNT=0,ZTSAVE("CHKPNT")=""
D ^%ZTLOAD
L -^XTMP($$NAMSPC)
D MES^XPDUTL("This request queued as Task # "_ZTSK)
D MES^XPDUTL("=====================================================")
D MES^XPDUTL("")
D EN^DG53591C ;restore eff date recs in error
D POST^DG53591A ;link 2nd cleanup to start later
Q
;
TEST ; Entry point for taskman (testing mode)
S TESTING=1
QUE ; Entry point for taskman (live mode)
N NAMSPC S NAMSPC=$$NAMSPC^DG53591
L +^XTMP(NAMSPC):10 I '$T D Q ;quit if can't get a lock
. S $P(^XTMP(NAMSPC,0,0),U,5)="NO LOCK GAINED"
N QQ,ZTSTOP,XREC,MTIEN,DIK,DA,IVMTOT,IVMPUR,BEGTIME,PURGDT,IVMBAD
N DFN,TMP,ICDT,MTST,IVMDUPE,COUNT,PRI,TYPE,TYPNAM,IVMIEN,PRIM
N BADYR,FOUND,GOODIEN,SRCE,TMPIVM,XX,IVMCV,MAX,IVMIEND,LINKB,LINKG
N MTDT,R40831,THRS,YEAR,YRIEN
S TESTING=+$G(TESTING)
;
;get last run info if exists
S XREC=$G(^XTMP(NAMSPC,0,0))
S DFN=$P(XREC,U,1) ;last REC processed
S IVMTOT=+$P(XREC,U,2) ;total records processed
S IVMPUR=+$P(XREC,U,3) ;total bad records purged
S IVMBAD=+$P(XREC,U,7) ;total bad records found
;
;setup XTMP according to stds.
D SETUPX(30)
;
;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.31 looking for bad threshold values per INCYR
S ZTSTOP=0
F QQ=1:1 S DFN=$O(^DGMT(408.31,"C",DFN)) Q:'DFN D Q:ZTSTOP
. S MTIEN=""
. K TMP S FOUND=0
. F S MTIEN=$O(^DGMT(408.31,"C",DFN,MTIEN),-1) Q:MTIEN="" D Q:ZTSTOP!(FOUND)
. . S IVMTOT=IVMTOT+1 ;tot ien's processed
. . Q:'$D(^DGMT(408.31,MTIEN,0)) ;bad 0 node, quit
. . Q:$E(+$G(^DGMT(408.31,MTIEN,0)),1,3)<303 ;skip < 2003
. . S R40831=^DGMT(408.31,MTIEN,0)
. . S MTDT=+R40831 Q:$L(MTDT)'=7 ;bad MT date, quit
. . S TYPE=$P(R40831,"^",19) Q:TYPE>1 ;not a MT, quit
. . S THRS=+$P(R40831,"^",12) ;get MT threshold
. . Q:'THRS ;thrs. not > 0, quit
. . S YEAR=$E(MTDT,1,3)_"0000" ;build MT thrs. year
. . ;
. . ;find and save the bad year & IEN, also save related good year
. . ;quit when the first good ien is found
. . I THRS'=$P($G(^DG(43,1,"MT",YEAR,0)),"^",2) D
. . . S TMP(NAMSPC,DFN,"BAD",YEAR,MTIEN)=^DGMT(408.31,MTIEN,0)
. . . S BADYR=YEAR
. . . S IVMBAD=IVMBAD+1
. . E D
. . . I $D(TMP(NAMSPC,DFN,"BAD",YEAR)) D
. . . . S TMP(NAMSPC,DFN,"GOOD",YEAR,MTIEN)=^DGMT(408.31,MTIEN,0)
. . . . S FOUND=1
. ;
. ;cleanup, delete any bad tests that also have a corresponding good
. ;test for that same Income year, then re-transmit that year to HEC
. S YEAR=0
. F S YEAR=$O(TMP(NAMSPC,DFN,"BAD",YEAR)) Q:'YEAR D
. . ;if no Good MT found, then cleanup and quit
. . I '$D(TMP(NAMSPC,DFN,"GOOD",YEAR)) K TMP(NAMSPC,DFN,"BAD",YEAR) Q
. . S MTIEN=""
. . F S MTIEN=$O(TMP(NAMSPC,DFN,"BAD",YEAR,MTIEN)) Q:MTIEN="" D
. . . ;
. . . ;if Good MT exists for year then delete Bad MT
. . . S GOODIEN=$O(TMP(NAMSPC,DFN,"GOOD",YEAR,0))
. . . D:GOODIEN]"" SETPRIM(GOODIEN,1) ;insure a PRIM
. . . D DELMT(MTIEN,DFN,.IVMPUR) ;del MT
. . . ;
. . . ;if a linked RXCT see if it needs to be deleted or re-pointed
. . . S LINKB=$P($G(^DGMT(408.31,MTIEN,2)),"^",6)
. . . ;if bad MT is linked & RX is linked back to bad MT, then relink
. . . I LINKB,$P($G(^DGMT(408.31,LINKB,2)),"^",6)=MTIEN D LINKED
. . . ;
. . . ;set year to be re-transmitted
. . . S YRIEN=$O(^IVM(301.5,"AYR",YEAR,DFN,0))
. . . S DATA(.03)=0
. . . I 'TESTING,$$UPD^DGENDBS(301.5,YRIEN,.DATA)
. ;
. ;update last processed info
. S $P(^XTMP(NAMSPC,0,0),U,1,3)=DFN_U_IVMTOT_U_IVMPUR
. S $P(^XTMP(NAMSPC,0,0),U,7)=IVMBAD
. M ^XTMP(NAMSPC)=TMP(NAMSPC)
. ;
. ;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")
;
;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
D MAIL^DG53591M
K TESTING
L -^XTMP($$NAMSPC)
Q
;
LINKED ;Resolve the linked RX tests to a bad MT
S LINKG=$P($G(^DGMT(408.31,GOODIEN,2)),"^",6)
;
;if the Good MT is linked
I LINKG D
. ;good MT not linked to the same RX as the Bad MT, then delete
. ;the bad linked RX
. I LINKG'=LINKB D
. . D DELMT(LINKB,DFN,.IVMPUR)
. . S TMP(NAMSPC,DFN,"DELLNK",YEAR,LINKB)=^DGMT(408.31,LINKB,0)
. ;
. ;else both MT point to same RX, then point RX back to Good MT
. E D
. . D REPOINT(LINKB,GOODIEN)
. . S TMP(NAMSPC,DFN,"PNTLNK",YEAR,LINKB)=^DGMT(408.31,LINKB,0)
;
;else save RX and point to Good MT & point Good MT back to RX
E D
. D REPOINT(LINKB,GOODIEN)
. S TMP(NAMSPC,DFN,"PNTLNK",YEAR,LINKB)=^DGMT(408.31,LINKB,0)
Q
;
DELMT(IEN,DFN,PUR,BAD) ; delete 408.31 ien only, no income related files
Q:'$G(IEN)
N DA,DIK
S TESTING=+$G(TESTING,1),DFN=$G(DFN)
;
S DA=IEN,DIK="^DGMT(408.31," D:'TESTING ^DIK ;del MT here
S PUR=PUR+1
S BAD(IEN)=""
W:'$D(ZTQUEUED) !,"Deleting Bad IEN in 408.31 > ",IEN," for DFN > ",DFN
;
Q
;
REPOINT(LINK,MT) ; repoint a linked RXCT to MT and vice versa
Q:'$G(LINK)!('$G(MT))
N DATA
S TESTING=+$G(TESTING,1)
S DATA(2.06)=MT
I 'TESTING,$$UPD^DGENDBS(408.31,LINK,.DATA)
I $$UPD^DGENDBS(408.31,LINK,.DATA)
W:'$D(ZTQUEUED) !,"Point RXCT in 408.31 > ",LINK," to Good MT > ",MT
S DATA(2.06)=LINK
I 'TESTING,$$UPD^DGENDBS(408.31,MT,.DATA)
I $$UPD^DGENDBS(408.31,MT,.DATA)
W:'$D(ZTQUEUED) !,"Point Good MT in 408.31 > ",MT," to RXCT > ",LINK
;
Q
;
SETPRIM(DA,PR) ; set an Income Test (in #408.31) to Prim or Not
; Input: DA= ien in 408.31 to set "PRIM" node
; PR= what to set PRIM node to; 0 or 1
Q:'$D(DA)
Q:'$D(PR)
Q:PR=$G(^DGMT(408.31,DA,"PRIM"))
N DR,DIE
S DR="2////"_PR,DIE="^DGMT(408.31,"
D:'$G(TESTING) ^DIE
D ^DIE
Q
;
CHKSTAT(POST) ;check if job is running, stopped, or completed
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 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 ^XTMPs
. D KILIT
Q QUIT
;
KILIT ; kill Xtmp work file for a re-run
S:'$D(NAMSPC) NAMSPC=$$NAMSPC^DG53591
K ^XTMP(NAMSPC)
Q
;
STOP ; alternate stop method
S ^XTMP($$NAMSPC,0,"STOP")=""
Q
;
SETUPX(EXPDAY) ;Setup XTMP according to standards and set expiration days
N BEGTIME,PURGDT,NAMSPC
S NAMSPC=$$NAMSPC^DG53591
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 Thresholds in the Means Test File"
Q
;
NAMSPC() ; Return a consistent name space variable
Q $T(+0)
DG53591 ;ALB/GN - DG*5.3*591 CLEANUP FOR OVERLAYED INCOME TEST THRESHOLD AND STATUS; 3/17/04 12:26pm ; 7/29/04 11:33am
+1 ;;5.3;Registration;**591,1015**;Aug 13, 1993;Build 21
+2 QUIT
+3 ;
SITETEST ; Site test Entry tag. Allows incremental testing in live mode
+1 NEW QUIT,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTQUEUED,ZTSAVE,CHKPNT
+2 SET CHKPNT=3
+3 WRITE !,"Do you want to process the next "_CHKPNT_" bad tests and stop for review? "
+4 KILL DIR
+5 SET DIR("?",1)=" Enter Y to process the next "_CHKPNT_" bad tests it finds and stop the utility."
+6 SET DIR("?",2)=" This will allow you to verify the cleanup in small steps. Enter N to process"
+7 SET DIR("?")=" the remainder of the file to completion."
+8 SET DIR(0)="Y"
DO ^DIR
+9 IF $DATA(DTOUT)!$DATA(DUOUT)
WRITE !,"Cancelled...",!
QUIT
+10 ;
+11 ;do not use check points
IF 'Y
SET CHKPNT=0
+12 ;
+13 ; setup TM variables and Load
+14 SET ZTRTN=$SELECT($GET(TESTING):"TEST^DG53591",1:"QUE^DG53591")
+15 SET ZTDESC="Cleanup Bad Thresholds in the Means Test file"
+16 SET ZTIO=""
+17 SET ZTSAVE("CHKPNT")=""
+18 ;
+19 WRITE !!,ZTDESC,!
+20 ;check if already running or completed.
+21 SET QUIT=$$CHKSTAT(0)
+22 IF QUIT
QUIT
+23 DO ^%ZTLOAD
+24 LOCK -^XTMP($$NAMSPC)
+25 IF $DATA(ZTSK)
Begin DoDot:1
+26 WRITE !,"This request queued as Task # ",ZTSK,!
End DoDot:1
+27 QUIT
+28 ;
POST ;post install entry tag call. processes entire file in live mode
+1 IF +$GET(XPDQUES("POS1"))=0
Begin DoDot:1
+2 DO MES^XPDUTL("")
+3 DO MES^XPDUTL("==================================================")
+4 DO MES^XPDUTL(" POST INSTALL ABORTED AND WAS NOT SENT TO TASKMAN")
+5 DO MES^XPDUTL("==================================================")
+6 DO MES^XPDUTL("")
End DoDot:1
QUIT
+7 NEW ZTDTH,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTQUEUED,ZTSAVE,CHKPNT
+8 DO MES^XPDUTL("")
+9 DO MES^XPDUTL("=====================================================")
+10 DO MES^XPDUTL("Queuing Bad Income Threshold Test Purge Utility.....")
+11 IF $$CHKSTAT(1)
Begin DoDot:1
+12 DO BMES^XPDUTL("ABORTING Post Install Utility Queuing")
+13 DO MES^XPDUTL("=====================================================")
End DoDot:1
QUIT
+14 SET ZTRTN="QUE^DG53591"
+15 SET ZTDESC="Cleanup Bad Thresholds in the Means Test file"
+16 SET ZTIO=""
SET ZTDTH=$HOROLOG
+17 SET CHKPNT=0
SET ZTSAVE("CHKPNT")=""
+18 DO ^%ZTLOAD
+19 LOCK -^XTMP($$NAMSPC)
+20 DO MES^XPDUTL("This request queued as Task # "_ZTSK)
+21 DO MES^XPDUTL("=====================================================")
+22 DO MES^XPDUTL("")
+23 ;restore eff date recs in error
DO EN^DG53591C
+24 ;link 2nd cleanup to start later
DO POST^DG53591A
+25 QUIT
+26 ;
TEST ; Entry point for taskman (testing mode)
+1 SET TESTING=1
QUE ; Entry point for taskman (live mode)
+1 NEW NAMSPC
SET NAMSPC=$$NAMSPC^DG53591
+2 ;quit if can't get a lock
LOCK +^XTMP(NAMSPC):10
IF '$TEST
Begin DoDot:1
+3 SET $PIECE(^XTMP(NAMSPC,0,0),U,5)="NO LOCK GAINED"
End DoDot:1
QUIT
+4 NEW QQ,ZTSTOP,XREC,MTIEN,DIK,DA,IVMTOT,IVMPUR,BEGTIME,PURGDT,IVMBAD
+5 NEW DFN,TMP,ICDT,MTST,IVMDUPE,COUNT,PRI,TYPE,TYPNAM,IVMIEN,PRIM
+6 NEW BADYR,FOUND,GOODIEN,SRCE,TMPIVM,XX,IVMCV,MAX,IVMIEND,LINKB,LINKG
+7 NEW MTDT,R40831,THRS,YEAR,YRIEN
+8 SET TESTING=+$GET(TESTING)
+9 ;
+10 ;get last run info if exists
+11 SET XREC=$GET(^XTMP(NAMSPC,0,0))
+12 ;last REC processed
SET DFN=$PIECE(XREC,U,1)
+13 ;total records processed
SET IVMTOT=+$PIECE(XREC,U,2)
+14 ;total bad records purged
SET IVMPUR=+$PIECE(XREC,U,3)
+15 ;total bad records found
SET IVMBAD=+$PIECE(XREC,U,7)
+16 ;
+17 ;setup XTMP according to stds.
+18 DO SETUPX(30)
+19 ;
+20 ;init status field and start date & time if null
+21 SET $PIECE(^XTMP(NAMSPC,0,0),U,5,6)="RUNNING^"
+22 IF $PIECE(^XTMP(NAMSPC,0,0),U,4)=""
SET $PIECE(^XTMP(NAMSPC,0,0),U,4)=$$NOW^XLFDT
+23 ;
+24 ;drive through 408.31 looking for bad threshold values per INCYR
+25 SET ZTSTOP=0
+26 FOR QQ=1:1
SET DFN=$ORDER(^DGMT(408.31,"C",DFN))
IF 'DFN
QUIT
Begin DoDot:1
+27 SET MTIEN=""
+28 KILL TMP
SET FOUND=0
+29 FOR
SET MTIEN=$ORDER(^DGMT(408.31,"C",DFN,MTIEN),-1)
IF MTIEN=""
QUIT
Begin DoDot:2
+30 ;tot ien's processed
SET IVMTOT=IVMTOT+1
+31 ;bad 0 node, quit
IF '$DATA(^DGMT(408.31,MTIEN,0))
QUIT
+32 ;skip < 2003
IF $EXTRACT(+$GET(^DGMT(408.31,MTIEN,0)),1,3)<303
QUIT
+33 SET R40831=^DGMT(408.31,MTIEN,0)
+34 ;bad MT date, quit
SET MTDT=+R40831
IF $LENGTH(MTDT)'=7
QUIT
+35 ;not a MT, quit
SET TYPE=$PIECE(R40831,"^",19)
IF TYPE>1
QUIT
+36 ;get MT threshold
SET THRS=+$PIECE(R40831,"^",12)
+37 ;thrs. not > 0, quit
IF 'THRS
QUIT
+38 ;build MT thrs. year
SET YEAR=$EXTRACT(MTDT,1,3)_"0000"
+39 ;
+40 ;find and save the bad year & IEN, also save related good year
+41 ;quit when the first good ien is found
+42 IF THRS'=$PIECE($GET(^DG(43,1,"MT",YEAR,0)),"^",2)
Begin DoDot:3
+43 SET TMP(NAMSPC,DFN,"BAD",YEAR,MTIEN)=^DGMT(408.31,MTIEN,0)
+44 SET BADYR=YEAR
+45 SET IVMBAD=IVMBAD+1
End DoDot:3
+46 IF '$TEST
Begin DoDot:3
+47 IF $DATA(TMP(NAMSPC,DFN,"BAD",YEAR))
Begin DoDot:4
+48 SET TMP(NAMSPC,DFN,"GOOD",YEAR,MTIEN)=^DGMT(408.31,MTIEN,0)
+49 SET FOUND=1
End DoDot:4
End DoDot:3
End DoDot:2
IF ZTSTOP!(FOUND)
QUIT
+50 ;
+51 ;cleanup, delete any bad tests that also have a corresponding good
+52 ;test for that same Income year, then re-transmit that year to HEC
+53 SET YEAR=0
+54 FOR
SET YEAR=$ORDER(TMP(NAMSPC,DFN,"BAD",YEAR))
IF 'YEAR
QUIT
Begin DoDot:2
+55 ;if no Good MT found, then cleanup and quit
+56 IF '$DATA(TMP(NAMSPC,DFN,"GOOD",YEAR))
KILL TMP(NAMSPC,DFN,"BAD",YEAR)
QUIT
+57 SET MTIEN=""
+58 FOR
SET MTIEN=$ORDER(TMP(NAMSPC,DFN,"BAD",YEAR,MTIEN))
IF MTIEN=""
QUIT
Begin DoDot:3
+59 ;
+60 ;if Good MT exists for year then delete Bad MT
+61 SET GOODIEN=$ORDER(TMP(NAMSPC,DFN,"GOOD",YEAR,0))
+62 ;insure a PRIM
IF GOODIEN]""
DO SETPRIM(GOODIEN,1)
+63 ;del MT
DO DELMT(MTIEN,DFN,.IVMPUR)
+64 ;
+65 ;if a linked RXCT see if it needs to be deleted or re-pointed
+66 SET LINKB=$PIECE($GET(^DGMT(408.31,MTIEN,2)),"^",6)
+67 ;if bad MT is linked & RX is linked back to bad MT, then relink
+68 IF LINKB
IF $PIECE($GET(^DGMT(408.31,LINKB,2)),"^",6)=MTIEN
DO LINKED
+69 ;
+70 ;set year to be re-transmitted
+71 SET YRIEN=$ORDER(^IVM(301.5,"AYR",YEAR,DFN,0))
+72 SET DATA(.03)=0
+73 IF 'TESTING
IF $$UPD^DGENDBS(301.5,YRIEN,.DATA)
End DoDot:3
End DoDot:2
+74 ;
+75 ;update last processed info
+76 SET $PIECE(^XTMP(NAMSPC,0,0),U,1,3)=DFN_U_IVMTOT_U_IVMPUR
+77 SET $PIECE(^XTMP(NAMSPC,0,0),U,7)=IVMBAD
+78 MERGE ^XTMP(NAMSPC)=TMP(NAMSPC)
+79 ;
+80 ;check for stop request after every 20 processed DFN recs
+81 IF QQ#20=0
Begin DoDot:2
+82 IF $$S^%ZTLOAD
SET ZTSTOP=1
+83 IF $DATA(^XTMP(NAMSPC,0,"STOP"))
SET ZTSTOP=1
KILL ^XTMP(NAMSPC,0,"STOP")
End DoDot:2
End DoDot:1
IF ZTSTOP
QUIT
+84 ;
+85 ;set status and mail stats
+86 IF ZTSTOP
SET $PIECE(^XTMP(NAMSPC,0,0),U,5,6)="STOPPED"_U_$$NOW^XLFDT
+87 IF '$TEST
SET $PIECE(^XTMP(NAMSPC,0,0),U,5,6)="COMPLETED"_U_$$NOW^XLFDT
+88 DO MAIL^DG53591M
+89 KILL TESTING
+90 LOCK -^XTMP($$NAMSPC)
+91 QUIT
+92 ;
LINKED ;Resolve the linked RX tests to a bad MT
+1 SET LINKG=$PIECE($GET(^DGMT(408.31,GOODIEN,2)),"^",6)
+2 ;
+3 ;if the Good MT is linked
+4 IF LINKG
Begin DoDot:1
+5 ;good MT not linked to the same RX as the Bad MT, then delete
+6 ;the bad linked RX
+7 IF LINKG'=LINKB
Begin DoDot:2
+8 DO DELMT(LINKB,DFN,.IVMPUR)
+9 SET TMP(NAMSPC,DFN,"DELLNK",YEAR,LINKB)=^DGMT(408.31,LINKB,0)
End DoDot:2
+10 ;
+11 ;else both MT point to same RX, then point RX back to Good MT
+12 IF '$TEST
Begin DoDot:2
+13 DO REPOINT(LINKB,GOODIEN)
+14 SET TMP(NAMSPC,DFN,"PNTLNK",YEAR,LINKB)=^DGMT(408.31,LINKB,0)
End DoDot:2
End DoDot:1
+15 ;
+16 ;else save RX and point to Good MT & point Good MT back to RX
+17 IF '$TEST
Begin DoDot:1
+18 DO REPOINT(LINKB,GOODIEN)
+19 SET TMP(NAMSPC,DFN,"PNTLNK",YEAR,LINKB)=^DGMT(408.31,LINKB,0)
End DoDot:1
+20 QUIT
+21 ;
DELMT(IEN,DFN,PUR,BAD) ; delete 408.31 ien only, no income related files
+1 IF '$GET(IEN)
QUIT
+2 NEW DA,DIK
+3 SET TESTING=+$GET(TESTING,1)
SET DFN=$GET(DFN)
+4 ;
+5 ;del MT here
SET DA=IEN
SET DIK="^DGMT(408.31,"
IF 'TESTING
DO ^DIK
+6 SET PUR=PUR+1
+7 SET BAD(IEN)=""
+8 IF '$DATA(ZTQUEUED)
WRITE !,"Deleting Bad IEN in 408.31 > ",IEN," for DFN > ",DFN
+9 ;
+10 QUIT
+11 ;
REPOINT(LINK,MT) ; repoint a linked RXCT to MT and vice versa
+1 IF '$GET(LINK)!('$GET(MT))
QUIT
+2 NEW DATA
+3 SET TESTING=+$GET(TESTING,1)
+4 SET DATA(2.06)=MT
+5 IF 'TESTING
IF $$UPD^DGENDBS(408.31,LINK,.DATA)
+6 IF $$UPD^DGENDBS(408.31,LINK,.DATA)
+7 IF '$DATA(ZTQUEUED)
WRITE !,"Point RXCT in 408.31 > ",LINK," to Good MT > ",MT
+8 SET DATA(2.06)=LINK
+9 IF 'TESTING
IF $$UPD^DGENDBS(408.31,MT,.DATA)
+10 IF $$UPD^DGENDBS(408.31,MT,.DATA)
+11 IF '$DATA(ZTQUEUED)
WRITE !,"Point Good MT in 408.31 > ",MT," to RXCT > ",LINK
+12 ;
+13 QUIT
+14 ;
SETPRIM(DA,PR) ; set an Income Test (in #408.31) to Prim or Not
+1 ; Input: DA= ien in 408.31 to set "PRIM" node
+2 ; PR= what to set PRIM node to; 0 or 1
+3 IF '$DATA(DA)
QUIT
+4 IF '$DATA(PR)
QUIT
+5 IF PR=$GET(^DGMT(408.31,DA,"PRIM"))
QUIT
+6 NEW DR,DIE
+7 SET DR="2////"_PR
SET DIE="^DGMT(408.31,"
+8 IF '$GET(TESTING)
DO ^DIE
+9 DO ^DIE
+10 QUIT
+11 ;
CHKSTAT(POST) ;check if job is running, stopped, or completed
+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 the previous 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
End DoDot:1
+29 QUIT QUIT
+30 ;
KILIT ; kill Xtmp work file for a re-run
+1 IF '$DATA(NAMSPC)
SET NAMSPC=$$NAMSPC^DG53591
+2 KILL ^XTMP(NAMSPC)
+3 QUIT
+4 ;
STOP ; alternate stop method
+1 SET ^XTMP($$NAMSPC,0,"STOP")=""
+2 QUIT
+3 ;
SETUPX(EXPDAY) ;Setup XTMP according to standards and set expiration days
+1 NEW BEGTIME,PURGDT,NAMSPC
+2 SET NAMSPC=$$NAMSPC^DG53591
+3 SET BEGTIME=$$NOW^XLFDT()
+4 SET PURGDT=$$FMADD^XLFDT(BEGTIME,EXPDAY)
+5 SET ^XTMP(NAMSPC,0)=PURGDT_U_BEGTIME
+6 SET $PIECE(^XTMP(NAMSPC,0),U,3)="Cleanup Bad Thresholds in the Means Test File"
+7 QUIT
+8 ;
NAMSPC() ; Return a consistent name space variable
+1 QUIT $TEXT(+0)
