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

XU8P387.m

Go to the documentation of this file.
  1. XU8P387 ;SFISC/SO- POST INSTALL CLEAN UP XREF AUSER ;5:41 AM 30 Nov 2005
  1. ;;8.0;KERNEL;**384**;Jul 10, 1995;Build 8
  1. ;
  1. D ^XU8P387X ;Install the fixed xref
  1. ;
  1. ;Clean up AUSER xref
  1. ;
  1. N IEN S IEN=0
  1. N XUDT540 S XUDT540=$$HTFM^XLFDT($H-540,1)
  1. F S IEN=$O(^VA(200,IEN)) Q:'IEN D
  1. . I IEN<1 Q
  1. . N DIK,DA
  1. . S DA=IEN
  1. . S DIK="^VA(200,",DIK(1)=".01^AUSER"
  1. . D EN1^DIK
  1. . ;
  1. . ;Check to see if DISUERed, But last sign-on is within 540 days
  1. . I '$D(^VA(200,IEN,0))#2 Q ;Missing Zeroth node
  1. . N NAME,LDATE,DISUER
  1. . S NAME=$P(^VA(200,IEN,0),U)
  1. . I NAME="" Q ; Entry has null .01 field
  1. . S LDATE=$P($G(^VA(200,IEN,1.1)),U) ;Get last sign-on
  1. . S DISUSER=$P(^VA(200,IEN,0),U,7) ;DISUER FLAG
  1. . I $D(^VA(200,"AUSER",NAME,IEN)) Q ;Entry already indexed
  1. . I $D(^XUSEC("XUORES",IEN)) S ^VA(200,"AUSER",NAME,IEN)="" Q
  1. . I DISUSER,LDATE'<XUDT540,DISUSER S ^VA(200,"AUSER",NAME,IEN)=""
  1. . Q
  1. Q