- 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 Feb 18, 2025@23:28:49 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