PRCFALCK ;WISC@ALTOONA/CTB-CHECK FISCAL LOCK FILE ; 03/21/94 10:30 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
LOCK N X0,X1,X2,X3,Y
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
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
S X0=^PRCF(421.4,X1,0)
S X3=$P(X0,"^",3) I +X3>0,$D(^VA(200,X3,0)) S X3=$P(^(0),"^",1)
E S %=0,X3="an unknown person"
I $D(ZTIO),ZTIO=""!(ZTIO="@") G OUT
W !!!,X," lock was set by ",X3 S Y=$P(X0,"^",4) D DD^%DT W:Y]"" " on ",Y,"."
W !,"No further action taken. Contact your supervisor to clear the lock."
OUT I $G(X1) L -^PRCF(421.4,X1,0) Q
FAIL W !!!,"Corruption exists in the FISCAL LOCK file.",!,"PLEASE CONTACT YOUR SITE MANAGER.",!!!!! S %=0 Q
;
CLEAR ;Clear a lock
S DIC=421.4,DIC(0)="AEMZQ" D ^DIC K DIC Q:Y<0
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
S DA=+Y F I=1:1:4 S X(I)=$P(Y(0),"^",I)
S Y=X(4) D D^PRCFQ S X(3)=$S($D(^VA(200,X(3),0)):$P(^(0),"^"),1:"an unknown person")
W ! S %A="It looks like the lock was set by "_X(3)_$S(Y]"":" on "_Y,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
S %A="Are you sure that you want to clear this lock",%B="",%=2 D ^PRCFYN I %'=1 D NA Q
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
NA S X=" No action taken" D MSG^PRCFQ K Y,X Q
UNLOCK ;INTERNAL ENTRY TO CLEAR LOCK. REQUIRES VARIABLE X EQUAL TO LOCK NAME
S X1=$O(^PRCF(421.4,"B",X,0)) Q:X1="" S ^(0)=$P(^PRCF(421.4,+X1,0),"^",1) K X,X1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFALCK 1908 printed Dec 13, 2024@02:02:25 Page 2
PRCFALCK ;WISC@ALTOONA/CTB-CHECK FISCAL LOCK FILE ; 03/21/94 10:30 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
LOCK NEW X0,X1,X2,X3,Y
+1 SET %=0
if '$DATA(X)#2
GOTO FAIL
if X=""
GOTO FAIL
if '$DATA(^PRCF(421.4,"B",X))
GOTO FAIL
SET X1=$ORDER(^PRCF(421.4,"B",X,0))
IF X1=""
GOTO FAIL
+2 LOCK +^PRCF(421.4,X1,0):1
IF $TEST
SET X0=^PRCF(421.4,X1,0)
IF +$PIECE(X0,"^",2)=0
DO NOW^%DTC
SET ^PRCF(421.4,X1,0)=$PIECE(X0,"^",1)_"^1^"_DUZ_"^"_%
SET %=1
LOCK -^PRCF(421.4,X1,0)
QUIT
+3 SET X0=^PRCF(421.4,X1,0)
+4 SET X3=$PIECE(X0,"^",3)
IF +X3>0
IF $DATA(^VA(200,X3,0))
SET X3=$PIECE(^(0),"^",1)
+5 IF '$TEST
SET %=0
SET X3="an unknown person"
+6 IF $DATA(ZTIO)
IF ZTIO=""!(ZTIO="@")
GOTO OUT
+7 WRITE !!!,X," lock was set by ",X3
SET Y=$PIECE(X0,"^",4)
DO DD^%DT
if Y]""
WRITE " on ",Y,"."
+8 WRITE !,"No further action taken. Contact your supervisor to clear the lock."
OUT IF $GET(X1)
LOCK -^PRCF(421.4,X1,0)
QUIT
FAIL WRITE !!!,"Corruption exists in the FISCAL LOCK file.",!,"PLEASE CONTACT YOUR SITE MANAGER.",!!!!!
SET %=0
QUIT
+1 ;
CLEAR ;Clear a lock
+1 SET DIC=421.4
SET DIC(0)="AEMZQ"
DO ^DIC
KILL DIC
if Y<0
QUIT
+2 IF +$PIECE(Y(0),"^",2)=0
SET $PIECE(^PRCF(421.4,+Y,0),"^",3)=""
WRITE !!,$PIECE(Y(0),"^")," Lock is not in use. No action taken."
KILL Y
QUIT
+3 SET DA=+Y
FOR I=1:1:4
SET X(I)=$PIECE(Y(0),"^",I)
+4 SET Y=X(4)
DO D^PRCFQ
SET X(3)=$SELECT($DATA(^VA(200,X(3),0)):$PIECE(^(0),"^"),1:"an unknown person")
+5 WRITE !
SET %A="It looks like the lock was set by "_X(3)_$SELECT(Y]"":" on "_Y,1:"")
+6 SET %A(1)="Have you checked with all your users to be sure that "_X(1)
SET %A(2)="is not in progress on the system"
SET %B=""
SET %=2
DO ^PRCFYN
IF %'=1
DO NA
QUIT
+7 SET %A="Are you sure that you want to clear this lock"
SET %B=""
SET %=2
DO ^PRCFYN
IF %'=1
DO NA
QUIT
+8 WRITE !!,"OK, I will now clear the ",X(1)," lock."
SET ^PRCF(421.4,DA,0)=$PIECE(^PRCF(421.4,DA,0),"^",1)
KILL X,Y
SET X=" ---Done---"
DO MSG^PRCFQ
QUIT
NA SET X=" No action taken"
DO MSG^PRCFQ
KILL Y,X
QUIT
UNLOCK ;INTERNAL ENTRY TO CLEAR LOCK. REQUIRES VARIABLE X EQUAL TO LOCK NAME
+1 SET X1=$ORDER(^PRCF(421.4,"B",X,0))
if X1=""
QUIT
SET ^(0)=$PIECE(^PRCF(421.4,+X1,0),"^",1)
KILL X,X1
QUIT
