73 lines
2.7 KiB
Mathematica
73 lines
2.7 KiB
Mathematica
PRCGPM1 ;WIRMFO@ALTOONA/CTB/WIRMFO/PLT/BGJ - IFCAP PURGEMASTER PROCESS PRCGPM CONT. ;12/10/97 9:53 AM
|
|
V ;;5.1;IFCAP;**95**;Oct 20, 2000
|
|
;Per VHA Directive 2004-038, this routine should not be modified.
|
|
;This routine contains misc functions/tools to be used by the
|
|
;purge package
|
|
ADD(X,Y,Z) ;PARAMETER CALL TO ADD NEW ENTRY TO PURGE MASTER FILE
|
|
;RETURNS Z=0 (ZERO) IF UNSUCCESSFUL, Z=1 (ONE) IF SUCCESSFUL
|
|
;ARGUEMENT LIST = RECORD NUMBER (DA)^ENTRY POINT^ROUTINE NAME^VARIABLE STRING
|
|
;X= ENTRY POINT^ROUTINE NAME
|
|
;Y= VARIABLE STRING
|
|
NEW NODE,LAST,TOTAL,DONE
|
|
I X="" S Z=0 QUIT
|
|
L +^PRC(443.1,0):10 I '$T S Z=0 QUIT
|
|
S NODE=^PRC(443.1,0),LAST=$P(NODE,"^",3),TOTAL=$P(NODE,"^",4)
|
|
F D Q:$D(DONE)
|
|
. S LAST=LAST+1
|
|
. S:X'["^" X="^"_X
|
|
. I '$D(^PRC(443.1,LAST)) S ^PRC(443.1,LAST,0)=LAST_"^"_X_"^"_Y,$P(^PRC(443.1,0),"^",3,4)=(LAST_"^"_(TOTAL+1)),DONE=1
|
|
. QUIT
|
|
L -^PRC(443.1,0)
|
|
S Z=1 QUIT
|
|
REMOVE(DA) ;REMOVE ENTRY FROM FILE 443.1
|
|
;PARAMATER CALL TO REMOVE RECORD 'DA' FROM FILE
|
|
NEW NODE,LAST,TOTAL
|
|
I +DA=0!(DA'=+DA) QUIT
|
|
I '$D(^PRC(443.1,DA)) QUIT
|
|
FOR L +^PRC(443.1,0):1 I Q
|
|
S NODE=^PRC(443.1,0),LAST=$P(NODE,"^",3),TOTAL=$P(NODE,"^",4)
|
|
K ^PRC(443.1,DA) S TOTAL=TOTAL-1
|
|
I DA'<LAST F S LAST=LAST-1 Q:($D(^PRC(443.1,LAST))!(LAST=0))
|
|
S $P(^PRC(443.1,0),"^",3,4)=LAST_"^"_TOTAL
|
|
L -^PRC(443.1,0)
|
|
QUIT
|
|
ADDIP(X,Y,Z) ;PARAMETER CALL TO ADD NEW ENTRY TO INPROCESS FILE
|
|
;RETURNS Z=0 (ZERO) IF UNSUCCESSFUL, Z=DA NUMBER IF SUCCESSFUL
|
|
;ARGUEMENT LIST = RECORD NUM (DA)^ENTRY POINT^ROUTINE NAME^VARIABLE STRING
|
|
;X= ENTRY POINT^ROUTINE NAME
|
|
;Y= VARIABLE STRING
|
|
NEW NODE,LAST,TOTAL,DONE
|
|
I (X="") S Z=0 QUIT
|
|
F L +^PRC(443.3,0):1 I Q
|
|
S NODE=^PRC(443.3,0),LAST=$P(NODE,"^",3),TOTAL=$P(NODE,"^",4)
|
|
F D Q:$D(DONE)
|
|
. S LAST=LAST+1
|
|
. S:X'["^" X="^"_X
|
|
. I '$D(^PRC(443.3,LAST)) S ^PRC(443.3,LAST,0)=LAST_"^"_X_"^"_Y,^(1)=$H,$P(^PRC(443.3,0),"^",3,4)=(LAST_"^"_(TOTAL+1)),DONE=LAST
|
|
. QUIT
|
|
L -^PRC(443.3,0)
|
|
S Z=DONE QUIT
|
|
REMIP(DA) ;PARAMETER CALL TO REMOVE RECORD 'DA' FROM FILE 443.3
|
|
NEW NODE,LAST,TOTAL
|
|
I +DA=0!(DA'=+DA) QUIT
|
|
I '$D(^PRC(443.3,DA)) QUIT
|
|
FOR L +^PRC(443.3,0):1 I Q
|
|
S NODE=^PRC(443.3,0),LAST=$P(NODE,"^",3),TOTAL=$P(NODE,"^",4)
|
|
K ^PRC(443.3,DA) S TOTAL=TOTAL-1
|
|
I DA'<LAST F S LAST=LAST-1 Q:($D(^PRC(443.3,LAST))!(LAST=0))
|
|
S $P(^PRC(443.3,0),"^",3,4)=LAST_"^"_TOTAL
|
|
I $O(^PRC(443.3,0))="" S $P(^PRC(443.0),"^",3,4)="^"
|
|
L -^PRC(443.3,0)
|
|
QUIT
|
|
CLN445 ;add line to delete
|
|
S MYHLD=0,MYCOUNT=0,THISCNT=0
|
|
F S MYHLD=$O(^PRC(443.1,MYHLD)) Q:'MYHLD S MYCOUNT=MYHLD
|
|
S LAST=MYCOUNT+1
|
|
S X="FIND445^PRCG238P"
|
|
S THISCNT=$P(^PRC(443.1,0),U,4)
|
|
S Y=""
|
|
S:X'["^" X="^"_X
|
|
I '$D(^PRC(443.1,LAST)) S ^PRC(443.1,LAST,0)=LAST_"^"_X_"^"_Y,$P(^PRC(443.1,0),"^",3,4)=(LAST_"^"_(THISCNT+1))
|
|
K MYHLD,MYCOUNT,THISCNT
|
|
Q
|