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

PRCFALCK.m

Go to the documentation of this file.
  1. PRCFALCK ;WISC@ALTOONA/CTB-CHECK FISCAL LOCK FILE ; 03/21/94 10:30 AM
  1. V ;;5.1;IFCAP;;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. LOCK N X0,X1,X2,X3,Y
  1. S %=0 G FAIL:'$D(X)#2,FAIL:X="",FAIL:'$D(^PRCF(421.4,"B",X)) S X1=$O(^PRCF(421.4,"B",X,0)) I X1="" G FAIL
  1. L +^PRCF(421.4,X1,0):1 I $T S X0=^PRCF(421.4,X1,0) I +$P(X0,"^",2)=0 D NOW^%DTC S ^PRCF(421.4,X1,0)=$P(X0,"^",1)_"^1^"_DUZ_"^"_% S %=1 L -^PRCF(421.4,X1,0) Q
  1. S X0=^PRCF(421.4,X1,0)
  1. S X3=$P(X0,"^",3) I +X3>0,$D(^VA(200,X3,0)) S X3=$P(^(0),"^",1)
  1. E S %=0,X3="an unknown person"
  1. I $D(ZTIO),ZTIO=""!(ZTIO="@") G OUT
  1. W !!!,X," lock was set by ",X3 S Y=$P(X0,"^",4) D DD^%DT W:Y]"" " on ",Y,"."
  1. W !,"No further action taken. Contact your supervisor to clear the lock."
  1. OUT I $G(X1) L -^PRCF(421.4,X1,0) Q
  1. FAIL W !!!,"Corruption exists in the FISCAL LOCK file.",!,"PLEASE CONTACT YOUR SITE MANAGER.",!!!!! S %=0 Q
  1. ;
  1. CLEAR ;Clear a lock
  1. S DIC=421.4,DIC(0)="AEMZQ" D ^DIC K DIC Q:Y<0
  1. I +$P(Y(0),"^",2)=0 S $P(^PRCF(421.4,+Y,0),"^",3)="" W !!,$P(Y(0),"^")," Lock is not in use. No action taken." K Y Q
  1. S DA=+Y F I=1:1:4 S X(I)=$P(Y(0),"^",I)
  1. S Y=X(4) D D^PRCFQ S X(3)=$S($D(^VA(200,X(3),0)):$P(^(0),"^"),1:"an unknown person")
  1. W ! S %A="It looks like the lock was set by "_X(3)_$S(Y]"":" on "_Y,1:"")
  1. S %A(1)="Have you checked with all your users to be sure that "_X(1),%A(2)="is not in progress on the system",%B="",%=2 D ^PRCFYN I %'=1 D NA Q
  1. S %A="Are you sure that you want to clear this lock",%B="",%=2 D ^PRCFYN I %'=1 D NA Q
  1. W !!,"OK, I will now clear the ",X(1)," lock." S ^PRCF(421.4,DA,0)=$P(^PRCF(421.4,DA,0),"^",1) K X,Y S X=" ---Done---" D MSG^PRCFQ Q
  1. NA S X=" No action taken" D MSG^PRCFQ K Y,X Q
  1. UNLOCK ;INTERNAL ENTRY TO CLEAR LOCK. REQUIRES VARIABLE X EQUAL TO LOCK NAME
  1. S X1=$O(^PRCF(421.4,"B",X,0)) Q:X1="" S ^(0)=$P(^PRCF(421.4,+X1,0),"^",1) K X,X1 Q