PRCGARCH.m

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 ---PRCGARCH   883     printed  Apr 09, 2024@21:20:18                                                                                                                                                                                                     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