PRCUPMK ;WISC@ALTOONA/CTB/WISC/PLT-IFCAP GENERAL BATCH PROCESS UTILITY ; 06 Apr 93 12:07 PM
V ;;5.0;IFCAP;;4/21/95
;S $ZT="ERR^PRCUPMK"
;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^PRCUPM1(ROU,VARIABLE,.IPDA)
. D @XROU
. D REMIP^PRCUPM1(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
S DA=0
FOR S DA=$O(^PRC(443.1,DA)) Q:'DA L +^PRC(443.1,DA):2 I Q
I DA="" QUIT ""
I $D(^PRC(443.1,DA,0))["0" DO QUIT ""
. 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
L -^PRC(443.1,0)
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCUPMK 1603 printed Dec 13, 2024@02:19:50 Page 2
PRCUPMK ;WISC@ALTOONA/CTB/WISC/PLT-IFCAP GENERAL BATCH PROCESS UTILITY ; 06 Apr 93 12:07 PM
V ;;5.0;IFCAP;;4/21/95
+1 ;S $ZT="ERR^PRCUPMK"
+2 ;S 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^PRCUPM1(ROU,VARIABLE,.IPDA)
+12 DO @XROU
+13 DO REMIP^PRCUPM1(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
+3 SET DA=0
+4 FOR
SET DA=$ORDER(^PRC(443.1,DA))
if 'DA
QUIT
LOCK +^PRC(443.1,DA):2
IF $TEST
QUIT
+5 IF DA=""
QUIT ""
+6 IF $DATA(^PRC(443.1,DA,0))["0"
Begin DoDot:1
+7 DO REMOVE(DA)
+8 LOCK -^PRC(443.1,DA)
+9 QUIT
End DoDot:1
QUIT ""
+10 SET NODE=^PRC(443.1,DA,0)
+11 DO REMOVE(DA)
+12 LOCK -^PRC(443.1,DA)
+13 QUIT NODE
+14 ;
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 LOCK -^PRC(443.1,0)
+11 QUIT
