DG53591A ;ALB/GN - DG*5.3*591 CLEANUP FOR PURGED DEPENDENT INCOME; 3/17/04 12:26pm ; 7/26/04 10:51am
;;5.3;Registration;**591,1015**;Aug 13, 1993;Build 21
Q
;
POST ;post install entry tag call. processes entire file in live mode
N ZTDTH,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTQUEUED,ZTSAVE
D MES^XPDUTL("")
D MES^XPDUTL("=====================================================")
D MES^XPDUTL("Queuing Cleanup Purged Dependent Income Relations....")
I $$CHKSTAT(1) D Q
. D BMES^XPDUTL("ABORTING Post Install Utility Queuing")
. D MES^XPDUTL("=====================================================")
S ZTRTN="QUE^DG53591A"
S ZTDESC="Cleanup Purged Dependent Income Relations"
; delay start by 5 minutes to give 1st cleanup a head start
S ZTIO=""
S ZTDTH=$H,$P(ZTDTH,",",2)=$P(ZTDTH,",",2)+300
D ^%ZTLOAD
L -^XTMP($$NAMSPC)
D MES^XPDUTL("This request queued as Task # "_ZTSK)
D MES^XPDUTL("=====================================================")
D MES^XPDUTL("")
Q
;
TEST ; Entry point for taskman (testing mode)
S TESTING=1
QUE ; Entry point for taskman (live mode)
N NAMSPC S NAMSPC=$$NAMSPC^DG53591A
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,IVMPTR,IVMDPTR,BEGTIME,PURGDT
N DFN,TMP,ICDT,MTST,IVMDUPE,COUNT,PRI,TYPE,TYPNAM,IVMIEN,PRIM
N DG22,MTDT,R21,R22,R12,BADDT,BADYR,NEWYR,PMT,SSN,DGDFN
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 IVMPTR=+$P(XREC,U,3) ;total repointed recs
S DGDFN=+$P(XREC,U,7) ;last DFN of 2nd cleanup
S IVMDPTR=+$P(XREC,U,8) ;total del 408.1275 recs
;
;setup XTMP according to stds.
D SETUPX(60)
;
;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.22 and create a DFN ordered xref
K ^TMP(NAMSPC)
;
; build TMP xref from AMT xref in 408.22
; fmt of TMP(Namspc,MT ien,DFN,408.21 ien,408.22 ien)
S GL=$NA(^DGMT(408.22,"AMT"))
F S GL=$Q(@GL) Q:$QS(GL,2)'="AMT" D
. Q:$QS(GL,3)'?.N ;insure 3rd sub=numeric
. Q:+$G(^DPT($QS(GL,4),.35)) ;skip vets w/DOD
. S ^TMP(NAMSPC,$QS(GL,4),$QS(GL,3),$QS(GL,5))=$QS(GL,6)
;
;drive through TMP XREF looking for bad 408.22 refs with no 408.31
S ZTSTOP=0
F QQ=1:1 S DFN=$O(^TMP(NAMSPC,DFN)) Q:'DFN D Q:ZTSTOP
. S MTIEN=0
. F S MTIEN=$O(^TMP(NAMSPC,DFN,MTIEN)) Q:'MTIEN D Q:ZTSTOP
. . S R21=0
. . F S R21=$O(^TMP(NAMSPC,DFN,MTIEN,R21)) Q:'R21 D Q:ZTSTOP
. . . S IVMTOT=IVMTOT+1 ;tot ien's read
. . . ;
. . . ;only process recs that are pointing to nonexistent 408.31 recs
. . . S R22=$P(^TMP(NAMSPC,DFN,MTIEN,R21),"^",1)
. . . Q:$D(^DGMT(408.31,MTIEN,0))
. . . ;
. . . ;quit, if 408.22 xref's below ref. bad 408.21 recs
. . . Q:'$D(^DGMT(408.21,R21,0))
. . . ;
. . . ;determine Income year for bad ptr from the 408.21 file
. . . S BADDT=(+^DGMT(408.21,R21,0))+11231,BADYR=$E(BADDT,1,3)
. . . S BADDT=$S(BADDT>DT:DT,1:BADDT)
. . . ;
. . . ;get previous Primary MT (PMT) based on the bad ptr's MT year
. . . ;and quit if PMT Not found
. . . S PMT=$$LST^DGMTU(DFN,BADDT)
. . . Q:'PMT
. . . ;
. . . ;quit, if the PMT income year does not match the bad ptr year
. . . S MTDT=$P(PMT,"^",2),NEWYR=$E(MTDT,1,3)
. . . Q:BADYR'=NEWYR
. . . ;
. . . ;quit, if (Cat C & < Oct 1999)or(if Not Cat C & > 2 years old)
. . . ; or if MT is No Longer Required
. . . N CATC,NOREQ
. . . S CATC=$P(PMT,"^",4)="C"
. . . S NOREQ=$P(PMT,"^",3)["NO LONGER REQUIRED"
. . . Q:(CATC)&(MTDT<2991001)
. . . Q:('CATC)&(MTDT<(DT-20000))
. . . Q:$E(MTDT,1,3)<303
. . . Q:NOREQ
. . . ;
. . . ;quit, if PMT was already pointed to by another 408.22 rec
. . . S NEWIEN=+PMT
. . . Q:$D(^TMP(NAMSPC,DFN,NEWIEN))
. . . ;
. . . ;quit, if MT to point to is from Other VAMC
. . . Q:$P(PMT,"^",5)=4
. . . ;
. . . ;fall thru to re-point this bad 408.22 xref to new PMT ien
. . . S IVMPTR=IVMPTR+1
. . . D PT40822(DFN,R22,NEWIEN,MTIEN) ;repoint bad 408.22
. . . D XMIT(DFN,MTDT) ;re-xmit PMT to HEC
. . . S $P(^TMP(NAMSPC,DFN,MTIEN),"^",2)=NEWIEN
. ;
. ;update last processed info
. S $P(^XTMP(NAMSPC,0,0),U,1,3)=DFN_U_IVMTOT_U_IVMPTR
. M ^XTMP(NAMSPC,DFN)=^TMP(NAMSPC,DFN)
. ;
. ;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")
. K TMP
;
;set status and if complete, call 2nd pass cleanup
I ZTSTOP D
. S $P(^XTMP(NAMSPC,0,0),U,5,6)="STOPPED"_U_$$NOW^XLFDT
E D ;2nd pass will mark complete
. D EN^DG53591B ;second pass dependent cleanup
;
;mail stats
D MAIL^DG53591A
K TESTING,^TMP(NAMSPC)
L -^XTMP($$NAMSPC)
Q
;
PT40822(DFN,R22,NEWIEN,MTIEN) ; Repoint this bad 408.22 xref to a new MT
N DATA,MTDAT
S DATA(31)=NEWIEN
I '$G(TESTING),$$UPD^DGENDBS(408.22,R22,.DATA)
S SSN=$E(^DPT(DFN,0),1)_$E($P(^DPT(DFN,0),"^",9),6,9)
S MTDAT=+$G(^DGMT(408.31,NEWIEN,0))
S TEXT=" SSN="_SSN_" Point 408.22 ien "_R22_" From MT "_MTIEN
S TEXT=TEXT_" to "_NEWIEN_" "_$$FMTE^XLFDT(MTDAT,2)
W:'$D(ZTQUEUED) !,TEXT
S ^XTMP(NAMSPC,"DET",DFN,R22)=TEXT
Q
;
XMIT(DFN,MTDT) ; Re-transmit this Income Year per this MT date
N YRIEN,DATA,YEAR
S YEAR=$$LYR^DGMTSCU1(MTDT)
S YRIEN=$O(^IVM(301.5,"AYR",YEAR,DFN,0))
S DATA(.03)=0
I '$G(TESTING),$$UPD^DGENDBS(301.5,YRIEN,.DATA)
W:'$D(ZTQUEUED) !,"Transmit Income Year ",YEAR," IVM file ien: ",YRIEN
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 files for a re-run
S:'$D(NAMSPC) NAMSPC=$$NAMSPC^DG53591A
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^DG53591A
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 Purged Dependent Income Relations"
Q
;
NAMSPC() ; Return a consistent name space variable
Q $T(+0)
;
MAIL ; mail stats
N ACT,LACT,DFN,BTIME,HTEXT,TEXT,NAMSPC,LIN,MSGNO,IVMBAD,IVMPTR,IVMTOT
N LSSN,R40831,STS,STSNAM
S MSGNO=0
S NAMSPC=$$NAMSPC^DG53591A
S IVMTOT=$P($G(^XTMP(NAMSPC,0,0)),U,2)
S IVMPTR=$P($G(^XTMP(NAMSPC,0,0)),U,3)
S BTIME=$P($G(^XTMP(NAMSPC,0,0)),U,4)
S STAT=$P($G(^XTMP(NAMSPC,0,0)),U,5)
S STIME=$P($G(^XTMP(NAMSPC,0,0)),U,6)
S IVMDPTR=$P($G(^XTMP(NAMSPC,0,0)),U,8)
;
D HDNG(.HTEXT,.MSGNO,.LIN)
D SUMRY(.LIN)
D MAILIT(HTEXT)
;
D SNDDET
Q
;
HDNG(HTEXT,MSGNO,LIN) ;build heading lines for mail message
K ^TMP(NAMSPC,$J,"MSG")
S LIN=0
S HTEXT="Cleanup Purged Dependent Income Relations completed:"
S HTEXT=HTEXT_$$FMTE^XLFDT(STIME,2)
D BLDLINE(HTEXT,.LIN)
D BLDLINE("",.LIN)
I TESTING S TEXT="** TESTING **" D BLDLINE(TEXT,.LIN)
I MSGNO S TEXT="Message number: "_MSGNO D BLDLINE(TEXT,.LIN)
D BLDLINE("",.LIN)
S MSGNO=MSGNO+1
Q
;
SUMRY(LIN) ;build summary lines for mail message
S TEXT=" Total Records Processed: "_$J($FN(IVMTOT,","),11)
D BLDLINE(TEXT,.LIN)
S TEXT=" 408.22 recs re-pointed: "_$J($FN(IVMPTR,","),11)
D BLDLINE(TEXT,.LIN)
S TEXT=" 408.1275 recs deleted : "_$J($FN(IVMDPTR,","),11)
D BLDLINE(TEXT,.LIN)
D BLDLINE("",.LIN)
D BLDLINE("",.LIN)
D BLDLINE("",.LIN)
;
I IVMPTR D
. D BLDLINE("Detail changes to follow in subsequent mail messages.",.LIN)
Q
;
SNDDET ;build and send detail messages limit under 2000 lines each
N TEXT,GL,MAXLIN,MORE
S MAXLIN=1995,MORE=0
D HDNG(.HTEXT,.MSGNO,.LIN)
;
S GL=$NA(^XTMP(NAMSPC,"DET"))
F S GL=$Q(@GL) Q:GL="" Q:$QS(GL,1)'=NAMSPC D
. S TEXT=$G(@GL)
. S MORE=1 ;at least 1 more line to send
. D BLDLINE(TEXT,.LIN)
. ;max lines reached, print a msg
. I LIN>MAXLIN D S MORE=0
. . D MAILIT(HTEXT),HDNG(.HTEXT,.MSGNO,.LIN)
;
;print final message if any to print
D MAILIT(HTEXT):MORE
Q
;
BLDLINE(TEXT,LIN) ;build a single line into TMP message global
S LIN=LIN+1
S ^TMP(NAMSPC,$J,"MSG",LIN)=TEXT
Q
MAILIT(HTEXT) ; send the mail message
N XMY,XMDUZ,XMSUB,XMTEXT
S XMY(DUZ)="",XMDUZ=.5
S XMSUB=HTEXT
S XMTEXT="^TMP(NAMSPC,$J,""MSG"","
D ^XMD
Q
DG53591A ;ALB/GN - DG*5.3*591 CLEANUP FOR PURGED DEPENDENT INCOME; 3/17/04 12:26pm ; 7/26/04 10:51am
+1 ;;5.3;Registration;**591,1015**;Aug 13, 1993;Build 21
+2 QUIT
+3 ;
POST ;post install entry tag call. processes entire file in live mode
+1 NEW ZTDTH,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTQUEUED,ZTSAVE
+2 DO MES^XPDUTL("")
+3 DO MES^XPDUTL("=====================================================")
+4 DO MES^XPDUTL("Queuing Cleanup Purged Dependent Income Relations....")
+5 IF $$CHKSTAT(1)
Begin DoDot:1
+6 DO BMES^XPDUTL("ABORTING Post Install Utility Queuing")
+7 DO MES^XPDUTL("=====================================================")
End DoDot:1
QUIT
+8 SET ZTRTN="QUE^DG53591A"
+9 SET ZTDESC="Cleanup Purged Dependent Income Relations"
+10 ; delay start by 5 minutes to give 1st cleanup a head start
+11 SET ZTIO=""
+12 SET ZTDTH=$HOROLOG
SET $PIECE(ZTDTH,",",2)=$PIECE(ZTDTH,",",2)+300
+13 DO ^%ZTLOAD
+14 LOCK -^XTMP($$NAMSPC)
+15 DO MES^XPDUTL("This request queued as Task # "_ZTSK)
+16 DO MES^XPDUTL("=====================================================")
+17 DO MES^XPDUTL("")
+18 QUIT
+19 ;
TEST ; Entry point for taskman (testing mode)
+1 SET TESTING=1
QUE ; Entry point for taskman (live mode)
+1 NEW NAMSPC
SET NAMSPC=$$NAMSPC^DG53591A
+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,IVMPTR,IVMDPTR,BEGTIME,PURGDT
+5 NEW DFN,TMP,ICDT,MTST,IVMDUPE,COUNT,PRI,TYPE,TYPNAM,IVMIEN,PRIM
+6 NEW DG22,MTDT,R21,R22,R12,BADDT,BADYR,NEWYR,PMT,SSN,DGDFN
+7 SET TESTING=+$GET(TESTING)
+8 ;
+9 ;get last run info if exists
+10 SET XREC=$GET(^XTMP(NAMSPC,0,0))
+11 ;last REC processed
SET DFN=$PIECE(XREC,U,1)
+12 ;total records processed
SET IVMTOT=+$PIECE(XREC,U,2)
+13 ;total repointed recs
SET IVMPTR=+$PIECE(XREC,U,3)
+14 ;last DFN of 2nd cleanup
SET DGDFN=+$PIECE(XREC,U,7)
+15 ;total del 408.1275 recs
SET IVMDPTR=+$PIECE(XREC,U,8)
+16 ;
+17 ;setup XTMP according to stds.
+18 DO SETUPX(60)
+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.22 and create a DFN ordered xref
+25 KILL ^TMP(NAMSPC)
+26 ;
+27 ; build TMP xref from AMT xref in 408.22
+28 ; fmt of TMP(Namspc,MT ien,DFN,408.21 ien,408.22 ien)
+29 SET GL=$NAME(^DGMT(408.22,"AMT"))
+30 FOR
SET GL=$QUERY(@GL)
IF $QSUBSCRIPT(GL,2)'="AMT"
QUIT
Begin DoDot:1
+31 ;insure 3rd sub=numeric
IF $QSUBSCRIPT(GL,3)'?.N
QUIT
+32 ;skip vets w/DOD
IF +$GET(^DPT($QSUBSCRIPT(GL,4),.35))
QUIT
+33 SET ^TMP(NAMSPC,$QSUBSCRIPT(GL,4),$QSUBSCRIPT(GL,3),$QSUBSCRIPT(GL,5))=$QSUBSCRIPT(GL,6)
End DoDot:1
+34 ;
+35 ;drive through TMP XREF looking for bad 408.22 refs with no 408.31
+36 SET ZTSTOP=0
+37 FOR QQ=1:1
SET DFN=$ORDER(^TMP(NAMSPC,DFN))
IF 'DFN
QUIT
Begin DoDot:1
+38 SET MTIEN=0
+39 FOR
SET MTIEN=$ORDER(^TMP(NAMSPC,DFN,MTIEN))
IF 'MTIEN
QUIT
Begin DoDot:2
+40 SET R21=0
+41 FOR
SET R21=$ORDER(^TMP(NAMSPC,DFN,MTIEN,R21))
IF 'R21
QUIT
Begin DoDot:3
+42 ;tot ien's read
SET IVMTOT=IVMTOT+1
+43 ;
+44 ;only process recs that are pointing to nonexistent 408.31 recs
+45 SET R22=$PIECE(^TMP(NAMSPC,DFN,MTIEN,R21),"^",1)
+46 IF $DATA(^DGMT(408.31,MTIEN,0))
QUIT
+47 ;
+48 ;quit, if 408.22 xref's below ref. bad 408.21 recs
+49 IF '$DATA(^DGMT(408.21,R21,0))
QUIT
+50 ;
+51 ;determine Income year for bad ptr from the 408.21 file
+52 SET BADDT=(+^DGMT(408.21,R21,0))+11231
SET BADYR=$EXTRACT(BADDT,1,3)
+53 SET BADDT=$SELECT(BADDT>DT:DT,1:BADDT)
+54 ;
+55 ;get previous Primary MT (PMT) based on the bad ptr's MT year
+56 ;and quit if PMT Not found
+57 SET PMT=$$LST^DGMTU(DFN,BADDT)
+58 IF 'PMT
QUIT
+59 ;
+60 ;quit, if the PMT income year does not match the bad ptr year
+61 SET MTDT=$PIECE(PMT,"^",2)
SET NEWYR=$EXTRACT(MTDT,1,3)
+62 IF BADYR'=NEWYR
QUIT
+63 ;
+64 ;quit, if (Cat C & < Oct 1999)or(if Not Cat C & > 2 years old)
+65 ; or if MT is No Longer Required
+66 NEW CATC,NOREQ
+67 SET CATC=$PIECE(PMT,"^",4)="C"
+68 SET NOREQ=$PIECE(PMT,"^",3)["NO LONGER REQUIRED"
+69 IF (CATC)&(MTDT<2991001)
QUIT
+70 IF ('CATC)&(MTDT<(DT-20000))
QUIT
+71 IF $EXTRACT(MTDT,1,3)<303
QUIT
+72 IF NOREQ
QUIT
+73 ;
+74 ;quit, if PMT was already pointed to by another 408.22 rec
+75 SET NEWIEN=+PMT
+76 IF $DATA(^TMP(NAMSPC,DFN,NEWIEN))
QUIT
+77 ;
+78 ;quit, if MT to point to is from Other VAMC
+79 IF $PIECE(PMT,"^",5)=4
QUIT
+80 ;
+81 ;fall thru to re-point this bad 408.22 xref to new PMT ien
+82 SET IVMPTR=IVMPTR+1
+83 ;repoint bad 408.22
DO PT40822(DFN,R22,NEWIEN,MTIEN)
+84 ;re-xmit PMT to HEC
DO XMIT(DFN,MTDT)
+85 SET $PIECE(^TMP(NAMSPC,DFN,MTIEN),"^",2)=NEWIEN
End DoDot:3
IF ZTSTOP
QUIT
End DoDot:2
IF ZTSTOP
QUIT
+86 ;
+87 ;update last processed info
+88 SET $PIECE(^XTMP(NAMSPC,0,0),U,1,3)=DFN_U_IVMTOT_U_IVMPTR
+89 MERGE ^XTMP(NAMSPC,DFN)=^TMP(NAMSPC,DFN)
+90 ;
+91 ;check for stop request after every 20 processed DFN recs
+92 IF QQ#20=0
Begin DoDot:2
+93 IF $$S^%ZTLOAD
SET ZTSTOP=1
+94 IF $DATA(^XTMP(NAMSPC,0,"STOP"))
SET ZTSTOP=1
KILL ^XTMP(NAMSPC,0,"STOP")
End DoDot:2
+95 KILL TMP
End DoDot:1
IF ZTSTOP
QUIT
+96 ;
+97 ;set status and if complete, call 2nd pass cleanup
+98 IF ZTSTOP
Begin DoDot:1
+99 SET $PIECE(^XTMP(NAMSPC,0,0),U,5,6)="STOPPED"_U_$$NOW^XLFDT
End DoDot:1
+100 ;2nd pass will mark complete
IF '$TEST
Begin DoDot:1
+101 ;second pass dependent cleanup
DO EN^DG53591B
End DoDot:1
+102 ;
+103 ;mail stats
+104 DO MAIL^DG53591A
+105 KILL TESTING,^TMP(NAMSPC)
+106 LOCK -^XTMP($$NAMSPC)
+107 QUIT
+108 ;
PT40822(DFN,R22,NEWIEN,MTIEN) ; Repoint this bad 408.22 xref to a new MT
+1 NEW DATA,MTDAT
+2 SET DATA(31)=NEWIEN
+3 IF '$GET(TESTING)
IF $$UPD^DGENDBS(408.22,R22,.DATA)
+4 SET SSN=$EXTRACT(^DPT(DFN,0),1)_$EXTRACT($PIECE(^DPT(DFN,0),"^",9),6,9)
+5 SET MTDAT=+$GET(^DGMT(408.31,NEWIEN,0))
+6 SET TEXT=" SSN="_SSN_" Point 408.22 ien "_R22_" From MT "_MTIEN
+7 SET TEXT=TEXT_" to "_NEWIEN_" "_$$FMTE^XLFDT(MTDAT,2)
+8 IF '$DATA(ZTQUEUED)
WRITE !,TEXT
+9 SET ^XTMP(NAMSPC,"DET",DFN,R22)=TEXT
+10 QUIT
+11 ;
XMIT(DFN,MTDT) ; Re-transmit this Income Year per this MT date
+1 NEW YRIEN,DATA,YEAR
+2 SET YEAR=$$LYR^DGMTSCU1(MTDT)
+3 SET YRIEN=$ORDER(^IVM(301.5,"AYR",YEAR,DFN,0))
+4 SET DATA(.03)=0
+5 IF '$GET(TESTING)
IF $$UPD^DGENDBS(301.5,YRIEN,.DATA)
+6 IF '$DATA(ZTQUEUED)
WRITE !,"Transmit Income Year ",YEAR," IVM file ien: ",YRIEN
+7 QUIT
+8 ;
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 files for a re-run
+1 IF '$DATA(NAMSPC)
SET NAMSPC=$$NAMSPC^DG53591A
+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^DG53591A
+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 Purged Dependent Income Relations"
+7 QUIT
+8 ;
NAMSPC() ; Return a consistent name space variable
+1 QUIT $TEXT(+0)
+2 ;
MAIL ; mail stats
+1 NEW ACT,LACT,DFN,BTIME,HTEXT,TEXT,NAMSPC,LIN,MSGNO,IVMBAD,IVMPTR,IVMTOT
+2 NEW LSSN,R40831,STS,STSNAM
+3 SET MSGNO=0
+4 SET NAMSPC=$$NAMSPC^DG53591A
+5 SET IVMTOT=$PIECE($GET(^XTMP(NAMSPC,0,0)),U,2)
+6 SET IVMPTR=$PIECE($GET(^XTMP(NAMSPC,0,0)),U,3)
+7 SET BTIME=$PIECE($GET(^XTMP(NAMSPC,0,0)),U,4)
+8 SET STAT=$PIECE($GET(^XTMP(NAMSPC,0,0)),U,5)
+9 SET STIME=$PIECE($GET(^XTMP(NAMSPC,0,0)),U,6)
+10 SET IVMDPTR=$PIECE($GET(^XTMP(NAMSPC,0,0)),U,8)
+11 ;
+12 DO HDNG(.HTEXT,.MSGNO,.LIN)
+13 DO SUMRY(.LIN)
+14 DO MAILIT(HTEXT)
+15 ;
+16 DO SNDDET
+17 QUIT
+18 ;
HDNG(HTEXT,MSGNO,LIN) ;build heading lines for mail message
+1 KILL ^TMP(NAMSPC,$JOB,"MSG")
+2 SET LIN=0
+3 SET HTEXT="Cleanup Purged Dependent Income Relations completed:"
+4 SET HTEXT=HTEXT_$$FMTE^XLFDT(STIME,2)
+5 DO BLDLINE(HTEXT,.LIN)
+6 DO BLDLINE("",.LIN)
+7 IF TESTING
SET TEXT="** TESTING **"
DO BLDLINE(TEXT,.LIN)
+8 IF MSGNO
SET TEXT="Message number: "_MSGNO
DO BLDLINE(TEXT,.LIN)
+9 DO BLDLINE("",.LIN)
+10 SET MSGNO=MSGNO+1
+11 QUIT
+12 ;
SUMRY(LIN) ;build summary lines for mail message
+1 SET TEXT=" Total Records Processed: "_$JUSTIFY($FNUMBER(IVMTOT,","),11)
+2 DO BLDLINE(TEXT,.LIN)
+3 SET TEXT=" 408.22 recs re-pointed: "_$JUSTIFY($FNUMBER(IVMPTR,","),11)
+4 DO BLDLINE(TEXT,.LIN)
+5 SET TEXT=" 408.1275 recs deleted : "_$JUSTIFY($FNUMBER(IVMDPTR,","),11)
+6 DO BLDLINE(TEXT,.LIN)
+7 DO BLDLINE("",.LIN)
+8 DO BLDLINE("",.LIN)
+9 DO BLDLINE("",.LIN)
+10 ;
+11 IF IVMPTR
Begin DoDot:1
+12 DO BLDLINE("Detail changes to follow in subsequent mail messages.",.LIN)
End DoDot:1
+13 QUIT
+14 ;
SNDDET ;build and send detail messages limit under 2000 lines each
+1 NEW TEXT,GL,MAXLIN,MORE
+2 SET MAXLIN=1995
SET MORE=0
+3 DO HDNG(.HTEXT,.MSGNO,.LIN)
+4 ;
+5 SET GL=$NAME(^XTMP(NAMSPC,"DET"))
+6 FOR
SET GL=$QUERY(@GL)
IF GL=""
QUIT
IF $QSUBSCRIPT(GL,1)'=NAMSPC
QUIT
Begin DoDot:1
+7 SET TEXT=$GET(@GL)
+8 ;at least 1 more line to send
SET MORE=1
+9 DO BLDLINE(TEXT,.LIN)
+10 ;max lines reached, print a msg
+11 IF LIN>MAXLIN
Begin DoDot:2
+12 DO MAILIT(HTEXT)
DO HDNG(.HTEXT,.MSGNO,.LIN)
End DoDot:2
SET MORE=0
End DoDot:1
+13 ;
+14 ;print final message if any to print
+15 IF MORE
DO MAILIT(HTEXT)
+16 QUIT
+17 ;
BLDLINE(TEXT,LIN) ;build a single line into TMP message global
+1 SET LIN=LIN+1
+2 SET ^TMP(NAMSPC,$JOB,"MSG",LIN)=TEXT
+3 QUIT
MAILIT(HTEXT) ; send the mail message
+1 NEW XMY,XMDUZ,XMSUB,XMTEXT
+2 SET XMY(DUZ)=""
SET XMDUZ=.5
+3 SET XMSUB=HTEXT
+4 SET XMTEXT="^TMP(NAMSPC,$J,""MSG"","
+5 DO ^XMD
+6 QUIT
