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

BLRALAC.m

Go to the documentation of this file. 
  1. BLRALAC ;DAOU/ALA-Archive/Purge Lab Audit ;[ 12/19/2002  7:13 AM ]
  1.  ;;5.2;LR;**1013,1015**;NOV 18, 2002
  1.  ;
  1.  ;**PROGRAM DESCRIPTION**
  1.  ;  This program will archive and purge lab audit data.
  1.  ;
  1. EN ;  Determine archive filename,path, and last date run
  1.  ;  Check for parameters in Audit sub-file, if null QUIT.
  1.  I '$D(^BLRALAB(9009027.2,1,0)) G EXIT
  1.  I $P($G(^BLRALAB(9009027.2,1,0)),U,2)<1 G EXIT
  1.  S BLRAPTH=$P($G(^BLRALAB(9009027.2,1,0)),U,4) I BLRAPTH="" G EXIT
  1.  S BLRADAYS=$P($G(^BLRALAB(9009027.2,1,0)),U,3)
  1.  I BLRADAYS="" S BLRADAYS=7
  1.  S BLRAEDT=$$FMADD^XLFDT($$DT^XLFDT(),-BLRADAYS)
  1.  S BLRADT=$$HLDATE^HLFNC($$DT^XLFDT())
  1.  S BLRANME="BLRA"_BLRADT_".txt"
  1.  K ^TMP($J,"BLRA"),^TMP("BLRZ",$J)
  1.  ;------------------------------------------------------------
  1. DDD ;DATE PORTION OF ROUTINE
  1.  S DDD1="",PID1=""
  1.  F  S DDD1=$O(^BLRALAB(9009027,"B",DDD1)) Q:DDD1\1>BLRAEDT!(DDD1="")  D
  1.  . F  S PID1=$O(^BLRALAB(9009027,"B",DDD1,PID1)) Q:PID1=""  D
  1.  .. D GETS^DIQ(9009027,PID1,"*","R","^TMP(""BLRZ"",$J","ERR")
  1.  ;THE AFOREMENTIONED CODE LOOPS THRU GLOBAL ^BLRALAB GETS ALL NODES
  1.  ;OF THE DATA AND STORES THEM IN A TEMP GLOBAL ^TMP
  1.  ;------------------------------------------------------------
  1. FIL ;  Set file
  1.  S BGLOB="^TMP(""BLRZ"",$J,9009027)"
  1.  S BLRAY=$$OPEN^%ZISH(BLRAPTH,BLRANME,"A") I BLRAY=1 W !!,"Unable to open Host File Server to create archive file" Q
  1.  U IO W "ACCESSION#^DATE/TIME STAMP^MENU OPTION^PATIENT^USER"
  1.  S IEN="" F  S IEN=$O(@BGLOB@(IEN)) Q:'IEN  D
  1.  . U IO W ! S FLD="" F  S FLD=$O(@BGLOB@(IEN,FLD)) Q:FLD=""  D
  1.  .. U IO W @BGLOB@(IEN,FLD),"^"
  1.  U IO W ! D CLOSE^%ZISH(BLRAY)
  1.  S $P(^BLRALAB(9009027.2,1,0),U,5)=$$NOW^XLFDT()
  1.  ;------------------------------------------------------------
  1. DEL ;  Delete Records by date
  1.  K DA,DIK
  1.  S BDTM=""
  1.  S DIK="^BLRALAB(9009027,"
  1.  F  S BDTM=$O(^BLRALAB(9009027,"B",BDTM)) Q:BDTM\1>BLRAEDT!(BDTM="")  D
  1.  . S DA="",DA(1)=BDTM
  1.  . F  S DA=$O(^BLRALAB(9009027,"B",BDTM,DA)) Q:'DA  D ^DIK
  1.  ;-----------------------------------------------------------
  1. EXIT K BLRADT,BLRANME,BLRAPTH,DIR,Y,X,DIK,DA,IEN,%DT
  1.  K BLRAY,BGLOB,FLD,DDD1,PID1,DIC,BDTM,BLRAEDT
  1.  K ^TMP("BLRZ",$J),^TMP($J,"BLRAUSC"),^TMP($J,"BLRAU")
  1.  Q
  1.  ;
  1. EN2 ;EP
  1.  ;
  1.  ;  This sub-routine will allow the site manager to setup
  1.  ;  the Lab ESIG Audit Parameters.
  1.  ;
  1.  N Y,BLRAFIL
  1.  K DIC,DIE,DIR,DA,DR
  1.  ;  Find the Lab ESIG Audit Record
  1.  W @IOF
  1.  S DIC="^BLRALAB(9009027.2,"
  1.  S DIC(0)="AELMQO"
  1.  D ^DIC
  1.  I Y<1 Q
  1.  ;  Display the current parameters
  1.  S DA=$P($G(Y),U)
  1.  S BLRAFIL=$$EXTERNAL^DILFD(9009027.2,.01,"",$P($G(Y),U,2))
  1.  D EN^DDIOL("","","!!")
  1.  D EN^DDIOL("THE CURRENT LAB ESIG PARAMETERS ARE:","","!")
  1.  S DR=0 D EN^DIQ
  1.  ;  Allow to edit parameters
  1.  S DIR(0)="Y"
  1.  S DIR("A")="Would you like to edit these parameters "
  1.  S DIR("B")="YES"
  1.  D ^DIR
  1.  I Y S DIE=DIC,DR="[BLRA AUDIT PARAMETERS]" D ^DIE
  1.  I $$GET1^DIQ(9009027.2,DA,.02,"I")<1 D
  1.  . D EN^DDIOL("     *** THE LAB ESIG AUDITING AND ARCHIVING IS TURNED OFF ***","","!!!")
  1.  . D EN^DDIOL("     *** PLEASE UNSCHEDULE THE 'BLRA LAB ARCHIVE' OPTION IN TASKMAN ***","","!")
  1.  E  D
  1.  . D EN^DDIOL("     *** THE LAB ESIG AUDITING AND ARCHIVING IS TURNED ON ***","","!!!")
  1.  . D EN^DDIOL("     *** PLEASE SCHEDULE THE 'BLRA LAB ARCHIVE' OPTION IN TASKMAN ***","","!")
  1.  D EN^DDIOL("","","!!!!")
  1.  K DIE,DIC,DIR,DR,DA
  1.  Q
  1.  ;
  1. FORM ;EP - Check format of directory pathname
  1.  ;
  1.  S BLRAMVER=$$VERSION^%ZOSV(1)
  1.  I BLRAMVER["UNIX" D
  1.  . I X["\"!($E(X,1,1)'="/")!($E(X,$L(X),$L(X))'="/") K X D
  1.  .. D EN^DDIOL("*** INCORRECT DIRECTORY PATHNAME! ***","","!!")
  1.  E  D
  1.  . I X["/"!($E(X,1,1)'?.A)!($E(X,2,2)'=":")!($E(X,3,3)'="\") K X D
  1.  .. D EN^DDIOL("*** INCORRECT DIRECTORY PATHNAME! ***","","!!")
  1.  K BLRAMVER
  1.  Q
  1. KILLX ;  EP
  1.  S BLRAMVER=$$VERSION^%ZOSV(1)
  1.  I BLRAMVER["UNIX" D
  1.  . D EN^DDIOL("Enter UNIX directory pathnames in the following format: /usr3/IHS/RPMS0/","","!")
  1.  E  D
  1.  . D EN^DDIOL("Enter NT directory pathnames in the following format: C:\","","!")
  1.  K BLRAMVER
  1.  Q