- 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 Feb 18, 2025@23:31:15 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