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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCGPM1 2818 printed Dec 13, 2024@02:04:52 Page 2
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
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;This routine contains misc functions/tools to be used by the
+3 ;purge package
ADD(X,Y,Z) ;PARAMETER CALL TO ADD NEW ENTRY TO PURGE MASTER FILE
+1 ;RETURNS Z=0 (ZERO) IF UNSUCCESSFUL, Z=1 (ONE) IF SUCCESSFUL
+2 ;ARGUEMENT LIST = RECORD NUMBER (DA)^ENTRY POINT^ROUTINE NAME^VARIABLE STRING
+3 ;X= ENTRY POINT^ROUTINE NAME
+4 ;Y= VARIABLE STRING
+5 NEW NODE,LAST,TOTAL,DONE
+6 IF X=""
SET Z=0
QUIT
+7 LOCK +^PRC(443.1,0):10
IF '$TEST
SET Z=0
QUIT
+8 SET NODE=^PRC(443.1,0)
SET LAST=$PIECE(NODE,"^",3)
SET TOTAL=$PIECE(NODE,"^",4)
+9 FOR
Begin DoDot:1
+10 SET LAST=LAST+1
+11 if X'["^"
SET X="^"_X
+12 IF '$DATA(^PRC(443.1,LAST))
SET ^PRC(443.1,LAST,0)=LAST_"^"_X_"^"_Y
SET $PIECE(^PRC(443.1,0),"^",3,4)=(LAST_"^"_(TOTAL+1))
SET DONE=1
+13 QUIT
End DoDot:1
if $DATA(DONE)
QUIT
+14 LOCK -^PRC(443.1,0)
+15 SET Z=1
QUIT
REMOVE(DA) ;REMOVE ENTRY FROM FILE 443.1
+1 ;PARAMATER CALL TO REMOVE RECORD 'DA' FROM FILE
+2 NEW NODE,LAST,TOTAL
+3 IF +DA=0!(DA'=+DA)
QUIT
+4 IF '$DATA(^PRC(443.1,DA))
QUIT
+5 FOR
LOCK +^PRC(443.1,0):1
IF $TEST
QUIT
+6 SET NODE=^PRC(443.1,0)
SET LAST=$PIECE(NODE,"^",3)
SET TOTAL=$PIECE(NODE,"^",4)
+7 KILL ^PRC(443.1,DA)
SET TOTAL=TOTAL-1
+8 IF DA'<LAST
FOR
SET LAST=LAST-1
if ($DATA(^PRC(443.1,LAST))!(LAST=0))
QUIT
+9 SET $PIECE(^PRC(443.1,0),"^",3,4)=LAST_"^"_TOTAL
+10 LOCK -^PRC(443.1,0)
+11 QUIT
ADDIP(X,Y,Z) ;PARAMETER CALL TO ADD NEW ENTRY TO INPROCESS FILE
+1 ;RETURNS Z=0 (ZERO) IF UNSUCCESSFUL, Z=DA NUMBER IF SUCCESSFUL
+2 ;ARGUEMENT LIST = RECORD NUM (DA)^ENTRY POINT^ROUTINE NAME^VARIABLE STRING
+3 ;X= ENTRY POINT^ROUTINE NAME
+4 ;Y= VARIABLE STRING
+5 NEW NODE,LAST,TOTAL,DONE
+6 IF (X="")
SET Z=0
QUIT
+7 FOR
LOCK +^PRC(443.3,0):1
IF $TEST
QUIT
+8 SET NODE=^PRC(443.3,0)
SET LAST=$PIECE(NODE,"^",3)
SET TOTAL=$PIECE(NODE,"^",4)
+9 FOR
Begin DoDot:1
+10 SET LAST=LAST+1
+11 if X'["^"
SET X="^"_X
+12 IF '$DATA(^PRC(443.3,LAST))
SET ^PRC(443.3,LAST,0)=LAST_"^"_X_"^"_Y
SET ^(1)=$HOROLOG
SET $PIECE(^PRC(443.3,0),"^",3,4)=(LAST_"^"_(TOTAL+1))
SET DONE=LAST
+13 QUIT
End DoDot:1
if $DATA(DONE)
QUIT
+14 LOCK -^PRC(443.3,0)
+15 SET Z=DONE
QUIT
REMIP(DA) ;PARAMETER CALL TO REMOVE RECORD 'DA' FROM FILE 443.3
+1 NEW NODE,LAST,TOTAL
+2 IF +DA=0!(DA'=+DA)
QUIT
+3 IF '$DATA(^PRC(443.3,DA))
QUIT
+4 FOR
LOCK +^PRC(443.3,0):1
IF $TEST
QUIT
+5 SET NODE=^PRC(443.3,0)
SET LAST=$PIECE(NODE,"^",3)
SET TOTAL=$PIECE(NODE,"^",4)
+6 KILL ^PRC(443.3,DA)
SET TOTAL=TOTAL-1
+7 IF DA'<LAST
FOR
SET LAST=LAST-1
if ($DATA(^PRC(443.3,LAST))!(LAST=0))
QUIT
+8 SET $PIECE(^PRC(443.3,0),"^",3,4)=LAST_"^"_TOTAL
+9 IF $ORDER(^PRC(443.3,0))=""
SET $PIECE(^PRC(443.0),"^",3,4)="^"
+10 LOCK -^PRC(443.3,0)
+11 QUIT
CLN445 ;add line to delete
+1 SET MYHLD=0
SET MYCOUNT=0
SET THISCNT=0
+2 FOR
SET MYHLD=$ORDER(^PRC(443.1,MYHLD))
if 'MYHLD
QUIT
SET MYCOUNT=MYHLD
+3 SET LAST=MYCOUNT+1
+4 SET X="FIND445^PRCG238P"
+5 SET THISCNT=$PIECE(^PRC(443.1,0),U,4)
+6 SET Y=""
+7 if X'["^"
SET X="^"_X
+8 IF '$DATA(^PRC(443.1,LAST))
SET ^PRC(443.1,LAST,0)=LAST_"^"_X_"^"_Y
SET $PIECE(^PRC(443.1,0),"^",3,4)=(LAST_"^"_(THISCNT+1))
+9 KILL MYHLD,MYCOUNT,THISCNT
+10 QUIT
