| [613] | 1 | PRCGARCH ;WIRMFO@ALTOONA/CTB CLEAR FILE 443.9 ;12/10/97 9:51 AM
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | N PERCENT,MIN,SEC,TIME,DX,DY,HOURS,TREC,LREC,LINE,DA,LASTENT,XPOS,A,BTIME,XCOUNT,COUNT
|
|---|
| 5 | S TREC=$P(^PRC(443.9,0),"^",4)
|
|---|
| 6 | QUIT:TREC=0
|
|---|
| 7 | S MESSAGE="CLEARING FILE 443.9"
|
|---|
| 8 | D BEGIN^PRCGU
|
|---|
| 9 | S DA=0,LASTENT=0,BTIME=$P($H,",",2),XCOUNT=0
|
|---|
| 10 | D PERCENT^PRCGU
|
|---|
| 11 | F D S XCOUNT=XCOUNT+COUNT D:'$D(ZTQUEUED) PERCENT^PRCGU Q:('DA)!($D(UPOUT))
|
|---|
| 12 | . F COUNT=1:1:LREC S DA=$O(^PRC(443.9,DA)) Q:'DA D R X:0 I X["^" S UPOUT=1 W !!!,"Option Terminated.",*7 QUIT
|
|---|
| 13 | . . I '$D(^PRC(442,DA,0)) D REMOVE QUIT
|
|---|
| 14 | . . I $P(^PRC(442,DA,0),"-")=PRC("SITE") D REMOVE
|
|---|
| 15 | . . S LASTENT=DA
|
|---|
| 16 | . . QUIT
|
|---|
| 17 | . QUIT
|
|---|
| 18 | S $P(^PRC(443.9,0),"^",3)=LASTENT
|
|---|
| 19 | D END^PRCGU
|
|---|
| 20 | QUIT
|
|---|
| 21 | REMOVE ;Remove one entry from 443.9
|
|---|
| 22 | N X,DIK
|
|---|
| 23 | S DIK="^PRC(443.9," D ^DIK
|
|---|
| 24 | QUIT
|
|---|
