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

DG53591.m

Go to the documentation of this file. 
  1. 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
  1.  Q
  1.  ;
  1. SITETEST ; Site test Entry tag.  Allows incremental testing in live mode
  1.  N QUIT,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTQUEUED,ZTSAVE,CHKPNT
  1.  S CHKPNT=3
  1.  W !,"Do you want to process the next "_CHKPNT_" bad tests and stop for review? "
  1.  K DIR
  1.  S DIR("?",1)="  Enter Y to process the next "_CHKPNT_" bad tests it finds and stop the utility."
  1.  S DIR("?",2)="  This will allow you to verify the cleanup in small steps.  Enter N to process"
  1.  S DIR("?")="  the remainder of the file to completion."
  1.  S DIR(0)="Y" D ^DIR
  1.  I $D(DTOUT)!$D(DUOUT) W !,"Cancelled...",! Q
  1.  ;
  1.  S:'Y CHKPNT=0                               ;do not use check points
  1.  ;
  1.  ; setup TM variables and Load 
  1.  S ZTRTN=$S($G(TESTING):"TEST^DG53591",1:"QUE^DG53591")
  1.  S ZTDESC="Cleanup Bad Thresholds in the Means Test file"
  1.  S ZTIO=""
  1.  S ZTSAVE("CHKPNT")=""
  1.  ;
  1.  W !!,ZTDESC,!
  1.  ;check if already running or completed.
  1.  S QUIT=$$CHKSTAT(0)
  1.  Q:QUIT
  1.  D ^%ZTLOAD
  1.  L -^XTMP($$NAMSPC)
  1.  I $D(ZTSK) D
  1.  . W !,"This request queued as Task # ",ZTSK,!
  1.  Q
  1.  ;
  1. POST ;post install entry tag call.  processes entire file in live mode
  1.  I +$G(XPDQUES("POS1"))=0 D  Q
  1.  . D MES^XPDUTL("")
  1.  . D MES^XPDUTL("==================================================")
  1.  . D MES^XPDUTL(" POST INSTALL ABORTED AND WAS NOT SENT TO TASKMAN")
  1.  . D MES^XPDUTL("==================================================")
  1.  . D MES^XPDUTL("")
  1.  N ZTDTH,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTQUEUED,ZTSAVE,CHKPNT
  1.  D MES^XPDUTL("")
  1.  D MES^XPDUTL("=====================================================")
  1.  D MES^XPDUTL("Queuing Bad Income Threshold Test Purge Utility.....")
  1.  I $$CHKSTAT(1) D  Q
  1.  . D BMES^XPDUTL("ABORTING  Post Install Utility Queuing")
  1.  . D MES^XPDUTL("=====================================================")
  1.  S ZTRTN="QUE^DG53591"
  1.  S ZTDESC="Cleanup Bad Thresholds in the Means Test file"
  1.  S ZTIO="",ZTDTH=$H
  1.  S CHKPNT=0,ZTSAVE("CHKPNT")=""
  1.  D ^%ZTLOAD
  1.  L -^XTMP($$NAMSPC)
  1.  D MES^XPDUTL("This request queued as Task # "_ZTSK)
  1.  D MES^XPDUTL("=====================================================")
  1.  D MES^XPDUTL("")
  1.  D EN^DG53591C                        ;restore eff date recs in error
  1.  D POST^DG53591A                      ;link 2nd cleanup to start later
  1.  Q
  1.  ;
  1. TEST ; Entry point for taskman (testing mode)
  1.  S TESTING=1
  1. QUE ; Entry point for taskman (live mode)
  1.  N NAMSPC S NAMSPC=$$NAMSPC^DG53591
  1.  L +^XTMP(NAMSPC):10 I '$T D  Q   ;quit if can't get a lock
  1.  . S $P(^XTMP(NAMSPC,0,0),U,5)="NO LOCK GAINED"
  1.  N QQ,ZTSTOP,XREC,MTIEN,DIK,DA,IVMTOT,IVMPUR,BEGTIME,PURGDT,IVMBAD
  1.  N DFN,TMP,ICDT,MTST,IVMDUPE,COUNT,PRI,TYPE,TYPNAM,IVMIEN,PRIM
  1.  N BADYR,FOUND,GOODIEN,SRCE,TMPIVM,XX,IVMCV,MAX,IVMIEND,LINKB,LINKG
  1.  N MTDT,R40831,THRS,YEAR,YRIEN
  1.  S TESTING=+$G(TESTING)
  1.  ;
  1.  ;get last run info if exists
  1.  S XREC=$G(^XTMP(NAMSPC,0,0))
  1.  S DFN=$P(XREC,U,1)         ;last REC processed
  1.  S IVMTOT=+$P(XREC,U,2)          ;total records processed
  1.  S IVMPUR=+$P(XREC,U,3)          ;total bad records purged
  1.  S IVMBAD=+$P(XREC,U,7)          ;total bad records found
  1.  ;
  1.  ;setup XTMP according to stds.
  1.  D SETUPX(30)
  1.  ;
  1.  ;init status field and start date & time if null
  1.  S $P(^XTMP(NAMSPC,0,0),U,5,6)="RUNNING^"
  1.  S:$P(^XTMP(NAMSPC,0,0),U,4)="" $P(^XTMP(NAMSPC,0,0),U,4)=$$NOW^XLFDT
  1.  ;
  1.  ;drive through 408.31 looking for bad threshold values per INCYR
  1.  S ZTSTOP=0
  1.  F QQ=1:1 S DFN=$O(^DGMT(408.31,"C",DFN)) Q:'DFN  D  Q:ZTSTOP
  1.  . S MTIEN=""
  1.  . K TMP S FOUND=0
  1.  . F  S MTIEN=$O(^DGMT(408.31,"C",DFN,MTIEN),-1) Q:MTIEN=""  D  Q:ZTSTOP!(FOUND)
  1.  . . S IVMTOT=IVMTOT+1                            ;tot ien's processed
  1.  . . Q:'$D(^DGMT(408.31,MTIEN,0))                 ;bad 0 node, quit
  1.  . . Q:$E(+$G(^DGMT(408.31,MTIEN,0)),1,3)<303     ;skip < 2003
  1.  . . S R40831=^DGMT(408.31,MTIEN,0)
  1.  . . S MTDT=+R40831 Q:$L(MTDT)'=7                 ;bad MT date, quit
  1.  . . S TYPE=$P(R40831,"^",19) Q:TYPE>1            ;not a MT, quit
  1.  . . S THRS=+$P(R40831,"^",12)                    ;get MT threshold
  1.  . . Q:'THRS                                      ;thrs. not > 0, quit
  1.  . . S YEAR=$E(MTDT,1,3)_"0000"                   ;build MT thrs. year
  1.  . . ;
  1.  . . ;find and save the bad year & IEN, also save related good year
  1.  . . ;quit when the first good ien is found
  1.  . . I THRS'=$P($G(^DG(43,1,"MT",YEAR,0)),"^",2) D
  1.  . . . S TMP(NAMSPC,DFN,"BAD",YEAR,MTIEN)=^DGMT(408.31,MTIEN,0)
  1.  . . . S BADYR=YEAR
  1.  . . . S IVMBAD=IVMBAD+1
  1.  . . E  D
  1.  . . . I $D(TMP(NAMSPC,DFN,"BAD",YEAR)) D
  1.  . . . . S TMP(NAMSPC,DFN,"GOOD",YEAR,MTIEN)=^DGMT(408.31,MTIEN,0)
  1.  . . . . S FOUND=1
  1.  . ;
  1.  . ;cleanup, delete any bad tests that also have a corresponding good
  1.  . ;test for that same Income year, then re-transmit that year to HEC
  1.  . S YEAR=0
  1.  . F  S YEAR=$O(TMP(NAMSPC,DFN,"BAD",YEAR)) Q:'YEAR  D
  1.  . . ;if no Good MT found, then cleanup and quit
  1.  . . I '$D(TMP(NAMSPC,DFN,"GOOD",YEAR)) K TMP(NAMSPC,DFN,"BAD",YEAR) Q
  1.  . . S MTIEN=""
  1.  . . F  S MTIEN=$O(TMP(NAMSPC,DFN,"BAD",YEAR,MTIEN)) Q:MTIEN=""  D
  1.  . . . ;
  1.  . . . ;if Good MT exists for year then delete Bad MT
  1.  . . . S GOODIEN=$O(TMP(NAMSPC,DFN,"GOOD",YEAR,0))
  1.  . . . D:GOODIEN]"" SETPRIM(GOODIEN,1)                  ;insure a PRIM
  1.  . . . D DELMT(MTIEN,DFN,.IVMPUR)                       ;del MT
  1.  . . . ;
  1.  . . . ;if a linked RXCT see if it needs to be deleted or re-pointed
  1.  . . . S LINKB=$P($G(^DGMT(408.31,MTIEN,2)),"^",6)
  1.  . . . ;if bad MT is linked & RX is linked back to bad MT, then relink
  1.  . . . I LINKB,$P($G(^DGMT(408.31,LINKB,2)),"^",6)=MTIEN D LINKED
  1.  . . . ;
  1.  . . . ;set year to be re-transmitted
  1.  . . . S YRIEN=$O(^IVM(301.5,"AYR",YEAR,DFN,0))
  1.  . . . S DATA(.03)=0
  1.  . . . I 'TESTING,$$UPD^DGENDBS(301.5,YRIEN,.DATA)
  1.  . ;
  1.  . ;update last processed info
  1.  . S $P(^XTMP(NAMSPC,0,0),U,1,3)=DFN_U_IVMTOT_U_IVMPUR
  1.  . S $P(^XTMP(NAMSPC,0,0),U,7)=IVMBAD
  1.  . M ^XTMP(NAMSPC)=TMP(NAMSPC)
  1.  . ;
  1.  . ;check for stop request after every 20 processed DFN recs
  1.  . I QQ#20=0 D
  1.  . . S:$$S^%ZTLOAD ZTSTOP=1
  1.  . . I $D(^XTMP(NAMSPC,0,"STOP")) S ZTSTOP=1 K ^XTMP(NAMSPC,0,"STOP")
  1.  ;
  1.  ;set status and mail stats
  1.  I ZTSTOP S $P(^XTMP(NAMSPC,0,0),U,5,6)="STOPPED"_U_$$NOW^XLFDT
  1.  E  S $P(^XTMP(NAMSPC,0,0),U,5,6)="COMPLETED"_U_$$NOW^XLFDT
  1.  D MAIL^DG53591M
  1.  K TESTING
  1.  L -^XTMP($$NAMSPC)
  1.  Q
  1.  ;
  1. LINKED ;Resolve the linked RX tests to a bad MT
  1.  S LINKG=$P($G(^DGMT(408.31,GOODIEN,2)),"^",6)
  1.  ;
  1.  ;if the Good MT is linked
  1.  I LINKG D
  1.  . ;good MT not linked to the same RX as the Bad MT, then delete 
  1.  . ;the bad linked RX
  1.  . I LINKG'=LINKB D
  1.  . . D DELMT(LINKB,DFN,.IVMPUR)
  1.  . . S TMP(NAMSPC,DFN,"DELLNK",YEAR,LINKB)=^DGMT(408.31,LINKB,0)
  1.  . ;
  1.  . ;else both MT point to same RX, then point RX back to Good MT
  1.  . E  D
  1.  . . D REPOINT(LINKB,GOODIEN)
  1.  . . S TMP(NAMSPC,DFN,"PNTLNK",YEAR,LINKB)=^DGMT(408.31,LINKB,0)
  1.  ;
  1.  ;else save RX and point to Good MT & point Good MT back to RX
  1.  E  D
  1.  . D REPOINT(LINKB,GOODIEN)
  1.  . S TMP(NAMSPC,DFN,"PNTLNK",YEAR,LINKB)=^DGMT(408.31,LINKB,0)
  1.  Q
  1.  ;
  1. DELMT(IEN,DFN,PUR,BAD) ; delete 408.31 ien only, no income related files
  1.  Q:'$G(IEN)
  1.  N DA,DIK
  1.  S TESTING=+$G(TESTING,1),DFN=$G(DFN)
  1.  ;
  1.  S DA=IEN,DIK="^DGMT(408.31," D:'TESTING ^DIK        ;del MT here
  1.  S PUR=PUR+1
  1.  S BAD(IEN)=""
  1.  W:'$D(ZTQUEUED) !,"Deleting Bad IEN in 408.31 > ",IEN," for DFN > ",DFN
  1.  ;
  1.  Q
  1.  ;
  1. REPOINT(LINK,MT) ;  repoint a linked RXCT to MT and vice versa
  1.  Q:'$G(LINK)!('$G(MT))
  1.  N DATA
  1.  S TESTING=+$G(TESTING,1)
  1.  S DATA(2.06)=MT
  1.  I 'TESTING,$$UPD^DGENDBS(408.31,LINK,.DATA)
  1.  I $$UPD^DGENDBS(408.31,LINK,.DATA)
  1.  W:'$D(ZTQUEUED) !,"Point RXCT in 408.31 > ",LINK," to Good MT > ",MT
  1.  S DATA(2.06)=LINK
  1.  I 'TESTING,$$UPD^DGENDBS(408.31,MT,.DATA)
  1.  I $$UPD^DGENDBS(408.31,MT,.DATA)
  1.  W:'$D(ZTQUEUED) !,"Point Good MT in 408.31 > ",MT," to RXCT > ",LINK
  1.  ;
  1.  Q
  1.  ;
  1. 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
  1.  ;        PR= what to set PRIM node to; 0 or 1
  1.  Q:'$D(DA)
  1.  Q:'$D(PR)
  1.  Q:PR=$G(^DGMT(408.31,DA,"PRIM"))
  1.  N DR,DIE
  1.  S DR="2////"_PR,DIE="^DGMT(408.31,"
  1.  D:'$G(TESTING) ^DIE
  1.  D ^DIE
  1.  Q
  1.  ;
  1. CHKSTAT(POST) ;check if job is running, stopped, or completed
  1.  N Y,DUOUT,DTOUT,QUIT,STAT,STIME,NAMSPC
  1.  S QUIT=0
  1.  S NAMSPC=$$NAMSPC
  1.  L +^XTMP(NAMSPC):1
  1.  I '$T D BMES^XPDUTL("*** ALREADY RUNNING ***") Q 1
  1.  ;
  1.  ; get job status
  1.  S STAT=$P($G(^XTMP(NAMSPC,0,0)),U,5)
  1.  S STIME=$P($G(^XTMP(NAMSPC,0,0)),U,6)
  1.  ;
  1.  I POST D KILIT Q 0
  1.  ;
  1.  ;if job Completed and run from menu opt, ask to Re-Run
  1.  I STAT="COMPLETED" D
  1.  . W " was Completed on "_$$FMTE^XLFDT(STIME)
  1.  . W !,"  Do you want to Re-Run again?"
  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 ^XTMPs
  1.  . D KILIT
  1.  Q QUIT
  1.  ;
  1. KILIT ; kill Xtmp work file for a re-run
  1.  S:'$D(NAMSPC) NAMSPC=$$NAMSPC^DG53591
  1.  K ^XTMP(NAMSPC)
  1.  Q
  1.  ;
  1. STOP ; alternate stop method
  1.  S ^XTMP($$NAMSPC,0,"STOP")=""
  1.  Q
  1.  ;
  1. SETUPX(EXPDAY) ;Setup XTMP according to standards and set expiration days
  1.  N BEGTIME,PURGDT,NAMSPC
  1.  S NAMSPC=$$NAMSPC^DG53591
  1.  S BEGTIME=$$NOW^XLFDT()
  1.  S PURGDT=$$FMADD^XLFDT(BEGTIME,EXPDAY)
  1.  S ^XTMP(NAMSPC,0)=PURGDT_U_BEGTIME
  1.  S $P(^XTMP(NAMSPC,0),U,3)="Cleanup Bad Thresholds in the Means Test File"
  1.  Q
  1.  ;
  1. NAMSPC() ; Return a consistent name space variable
  1.  Q $T(+0)