- PRCGARCH ;WIRMFO@ALTOONA/CTB CLEAR FILE 443.9 ;12/10/97 9:51 AM
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- N PERCENT,MIN,SEC,TIME,DX,DY,HOURS,TREC,LREC,LINE,DA,LASTENT,XPOS,A,BTIME,XCOUNT,COUNT
- S TREC=$P(^PRC(443.9,0),"^",4)
- QUIT:TREC=0
- S MESSAGE="CLEARING FILE 443.9"
- D BEGIN^PRCGU
- S DA=0,LASTENT=0,BTIME=$P($H,",",2),XCOUNT=0
- D PERCENT^PRCGU
- F D S XCOUNT=XCOUNT+COUNT D:'$D(ZTQUEUED) PERCENT^PRCGU Q:('DA)!($D(UPOUT))
- . 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
- . . I '$D(^PRC(442,DA,0)) D REMOVE QUIT
- . . I $P(^PRC(442,DA,0),"-")=PRC("SITE") D REMOVE
- . . S LASTENT=DA
- . . QUIT
- . QUIT
- S $P(^PRC(443.9,0),"^",3)=LASTENT
- D END^PRCGU
- QUIT
- REMOVE ;Remove one entry from 443.9
- N X,DIK
- S DIK="^PRC(443.9," D ^DIK
- QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCGARCH 883 printed Jan 18, 2025@03:05:59 Page 2
- PRCGARCH ;WIRMFO@ALTOONA/CTB CLEAR FILE 443.9 ;12/10/97 9:51 AM
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 NEW PERCENT,MIN,SEC,TIME,DX,DY,HOURS,TREC,LREC,LINE,DA,LASTENT,XPOS,A,BTIME,XCOUNT,COUNT
- +3 SET TREC=$PIECE(^PRC(443.9,0),"^",4)
- +4 if TREC=0
- QUIT
- +5 SET MESSAGE="CLEARING FILE 443.9"
- +6 DO BEGIN^PRCGU
- +7 SET DA=0
- SET LASTENT=0
- SET BTIME=$PIECE($HOROLOG,",",2)
- SET XCOUNT=0
- +8 DO PERCENT^PRCGU
- +9 FOR
- Begin DoDot:1
- +10 FOR COUNT=1:1:LREC
- SET DA=$ORDER(^PRC(443.9,DA))
- if 'DA
- QUIT
- Begin DoDot:2
- +11 IF '$DATA(^PRC(442,DA,0))
- DO REMOVE
- QUIT
- +12 IF $PIECE(^PRC(442,DA,0),"-")=PRC("SITE")
- DO REMOVE
- +13 SET LASTENT=DA
- +14 QUIT
- End DoDot:2
- READ X:0
- IF X["^"
- SET UPOUT=1
- WRITE !!!,"Option Terminated.",*7
- QUIT
- +15 QUIT
- End DoDot:1
- SET XCOUNT=XCOUNT+COUNT
- if '$DATA(ZTQUEUED)
- DO PERCENT^PRCGU
- if ('DA)!($DATA(UPOUT))
- QUIT
- +16 SET $PIECE(^PRC(443.9,0),"^",3)=LASTENT
- +17 DO END^PRCGU
- +18 QUIT
- REMOVE ;Remove one entry from 443.9
- +1 NEW X,DIK
- +2 SET DIK="^PRC(443.9,"
- DO ^DIK
- +3 QUIT