PRCGPMK ;WIRMFO@ALTOONA/CTB/WIRMFO/PLT - IFCAP PURGEMASTER SUBMANAGER (KILLER) ;12/10/97 9:54 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
S ZTREQ="@"
FOR DO Q:$$STOP!END
. S END=0
. S NODE=$$NEXT
. I NODE="" S END=1 QUIT
. S DA=$P(NODE,"^"),ROU=$P(NODE,"^",2,3),VARIABLE=$P(NODE,"^",4)
. I ROU=""!(ROU="^")!(ROU?.E1"^")!(DA="") QUIT
. S X=$P(ROU,"^",2) X ^%ZOSF("TEST") E QUIT
. S XROU=ROU I VARIABLE]"" S XROU=ROU_"("_""""_VARIABLE_""""_")"
. S IPDA=0 D ADDIP^PRCGPM1(ROU,VARIABLE,.IPDA)
. D @XROU S X=$P(ROU,"^",2)
. D REMIP^PRCGPM1(IPDA)
. K NODE,XROU,ROU,DA,VARIABLE,IPDA
. S END=0
. QUIT
QUIT
;
ERR ; REPORT ERRORS TO FILE
QUIT
;
STOP() ;CHECK TIME
N NOW
S NOW=$H
I +STOP>(+NOW) QUIT 0
I +NOW=(+STOP),$P(NOW,",",2)<$P(STOP,",",2) QUIT 0
QUIT 1
;
NEXT() ;GET NEXT NUMBER FROM 443.1
;EXTRINSIC FUNCTION TO RETURN NEXT AVAILABLE RECORD .
NEW DA,I,NODE
XX S DA=0
FOR S DA=$O(^PRC(443.1,DA)) Q:'DA L +^PRC(443.1,DA):4 I Q
I DA="" QUIT ""
I $D(^PRC(443.1,DA,0))["0" DO G XX
. DO REMOVE(DA)
. L -^PRC(443.1,DA)
. QUIT
S NODE=^PRC(443.1,DA,0)
D REMOVE(DA)
L -^PRC(443.1,DA)
QUIT NODE
;
REMOVE(DA) ;REMOVE ENTRY FROM FILE 443.1
;PARAMETER 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
I $O(^PRC(443.1,0))="" S $P(^(0),"^",3,4)="^"
L -^PRC(443.1,0)
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCGPMK 1724 printed Nov 22, 2024@17:14:59 Page 2
PRCGPMK ;WIRMFO@ALTOONA/CTB/WIRMFO/PLT - IFCAP PURGEMASTER SUBMANAGER (KILLER) ;12/10/97 9:54 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 SET ZTREQ="@"
+3 FOR
Begin DoDot:1
+4 SET END=0
+5 SET NODE=$$NEXT
+6 IF NODE=""
SET END=1
QUIT
+7 SET DA=$PIECE(NODE,"^")
SET ROU=$PIECE(NODE,"^",2,3)
SET VARIABLE=$PIECE(NODE,"^",4)
+8 IF ROU=""!(ROU="^")!(ROU?.E1"^")!(DA="")
QUIT
+9 SET X=$PIECE(ROU,"^",2)
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT
+10 SET XROU=ROU
IF VARIABLE]""
SET XROU=ROU_"("_""""_VARIABLE_""""_")"
+11 SET IPDA=0
DO ADDIP^PRCGPM1(ROU,VARIABLE,.IPDA)
+12 DO @XROU
SET X=$PIECE(ROU,"^",2)
+13 DO REMIP^PRCGPM1(IPDA)
+14 KILL NODE,XROU,ROU,DA,VARIABLE,IPDA
+15 SET END=0
+16 QUIT
End DoDot:1
if $$STOP!END
QUIT
+17 QUIT
+18 ;
ERR ; REPORT ERRORS TO FILE
+1 QUIT
+2 ;
STOP() ;CHECK TIME
+1 NEW NOW
+2 SET NOW=$HOROLOG
+3 IF +STOP>(+NOW)
QUIT 0
+4 IF +NOW=(+STOP)
IF $PIECE(NOW,",",2)<$PIECE(STOP,",",2)
QUIT 0
+5 QUIT 1
+6 ;
NEXT() ;GET NEXT NUMBER FROM 443.1
+1 ;EXTRINSIC FUNCTION TO RETURN NEXT AVAILABLE RECORD .
+2 NEW DA,I,NODE
XX SET DA=0
+1 FOR
SET DA=$ORDER(^PRC(443.1,DA))
if 'DA
QUIT
LOCK +^PRC(443.1,DA):4
IF $TEST
QUIT
+2 IF DA=""
QUIT ""
+3 IF $DATA(^PRC(443.1,DA,0))["0"
Begin DoDot:1
+4 DO REMOVE(DA)
+5 LOCK -^PRC(443.1,DA)
+6 QUIT
End DoDot:1
GOTO XX
+7 SET NODE=^PRC(443.1,DA,0)
+8 DO REMOVE(DA)
+9 LOCK -^PRC(443.1,DA)
+10 QUIT NODE
+11 ;
REMOVE(DA) ;REMOVE ENTRY FROM FILE 443.1
+1 ;PARAMETER 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 IF $ORDER(^PRC(443.1,0))=""
SET $PIECE(^(0),"^",3,4)="^"
+11 LOCK -^PRC(443.1,0)
+12 QUIT
