PRCFACD.m

PRCFACD ;WISC@ALTOONA/CTB-AUTO PURGE OF CODE SHEETS ;25 May 90/12:17 PM

V ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 S IOP="HOME" D ^%ZIS K IOP W @IOF I '$D(DUZ(0)) S DUZ(0)=""

 S PRCFSN=0 F I=1:1 S PRCFSN=$O(^PRC(411,PRCFSN)) Q:PRCFSN=""!(PRCFSN'?.N)  K Y D A

OUT K PRCFSN,PRCFDATE,I,J,X,Y,%DT,D0,DA Q

EN1 ;ENTRY POINT TO DELETE ALL CODE SHEETS (BEYOND RETENTION PERIOD) FOR A SINGLE STATION

 S PRCF("X")="ASF" D ^PRCFSITE Q:'%

 K PRC("FY"),PRC("PARAM"),PRC("QTR")

 W !!,"THIS PROGRAM WILL DELETE ALL CODE SHEETS FOR A SINGLE STATION NUMBER WHICH HAVE",!,"A TRANSMISSION DATE EARLIER (OLDER) THAN THE DATE SPECIFIED BY THE USER",!! S %DT="EXA" D ^%DT Q:Y<0  S PRCFSN=PRC("SITE")

 S X=Y D DD^%DT W ! S %A="ARE YOU SURE YOU WANT TO KILL ALL CODE SHEETS WITH TRANSMISSION ",%A(1)="DATES BEFORE "_Y_" FOR STATION NUMBER "_PRC("SITE"),%B=""

 S %=1 D ^PRCFYN I %'=1 W $C(7),"  <NOTHING DELETED>" R X:3 Q

 S Y=X D A G OUT

 Q

EN2 ;DELETE A SINGLE CODE SHEET

 S DIC(0)="AMEQN",DIC("A")="Select Code Sheet to be Deleted: ",DIC=423 D ^DIC K DIC I Y<0 W $C(7)," <NOTHING DELETED>" R X:3 Q

 S %A="OK TO DELETE",%B="" S %=2 D ^PRCFYN I %'=1 W $C(7)," <NOTHING DELETED>" R X:3 Q

 S DA=+Y D K W "  CODE SHEET DELETED",$C(7) R X:2 Q

 Q

A ;SELECT CODE SHEETS TO BE DELETED FOR STATION NUMBER PRCFSN 

 I '$D(Y) S X=$P(^PRC(411,PRCFSN,0),"^",14) S:X="" X=90 S X="T-"_X,%DT="" D ^%DT

 S PRCFDATE=Y,D0=0,L=0 F J=1:1 S D0=$O(^PRCF(423,D0)) Q:D0=""!(D0'?.N)  I $P(^PRCF(423,D0,0),U,2)=PRCFSN,$D(^PRCF(423,D0,"TRANS")),$P(^("TRANS"),"^",3)<PRCFDATE S DA=D0,L=L+1 D K

 W !!,L," CODE SHEETS DELETED FOR STATION ",PRC("SITE") Q

K ;KILL THE CODE SHEET AND CROSS REFERENCES

 S DIK="^PRCF(423," D WAIT^PRCFYN,^DIK K DA S PRCFDEL="" Q

 K K,X,DA Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCFACD   1794     printed  Apr 09, 2024@21:13:02                                                                                                                                                                                                     Page 2

PRCFACD   ;WISC@ALTOONA/CTB-AUTO PURGE OF CODE SHEETS ;25 May 90/12:17 PM

V         ;;5.1;IFCAP;;Oct 20, 2000

 +1       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +2        SET IOP="HOME"

           DO ^%ZIS

           KILL IOP

           WRITE @IOF

           IF '$DATA(DUZ(0))

               SET DUZ(0)=""

 +3        SET PRCFSN=0

           FOR I=1:1

               SET PRCFSN=$ORDER(^PRC(411,PRCFSN))

               if PRCFSN=""!(PRCFSN'?.N)

                   QUIT 

               KILL Y

               DO A

OUT        KILL PRCFSN,PRCFDATE,I,J,X,Y,%DT,D0,DA

           QUIT 

EN1       ;ENTRY POINT TO DELETE ALL CODE SHEETS (BEYOND RETENTION PERIOD) FOR A SINGLE STATION

 +1        SET PRCF("X")="ASF"

           DO ^PRCFSITE

           if '%

               QUIT 

 +2        KILL PRC("FY"),PRC("PARAM"),PRC("QTR")

 +3        WRITE !!,"THIS PROGRAM WILL DELETE ALL CODE SHEETS FOR A SINGLE STATION NUMBER WHICH HAVE",!,"A TRANSMISSION DATE EARLIER (OLDER) THAN THE DATE SPECIFIED BY THE USER",!!

           SET %DT="EXA"

           DO ^%DT

           if Y<0

               QUIT 

           SET PRCFSN=PRC("SITE")

 +4        SET X=Y

           DO DD^%DT

           WRITE !

           SET %A="ARE YOU SURE YOU WANT TO KILL ALL CODE SHEETS WITH TRANSMISSION "

           SET %A(1)="DATES BEFORE "_Y_" FOR STATION NUMBER "_PRC("SITE")

           SET %B=""

 +5        SET %=1

           DO ^PRCFYN

           IF %'=1

               WRITE $CHAR(7),"  <NOTHING DELETED>"

               READ X:3

               QUIT 

 +6        SET Y=X

           DO A

           GOTO OUT

 +7        QUIT 

EN2       ;DELETE A SINGLE CODE SHEET

 +1        SET DIC(0)="AMEQN"

           SET DIC("A")="Select Code Sheet to be Deleted: "

           SET DIC=423

           DO ^DIC

           KILL DIC

           IF Y<0

               WRITE $CHAR(7)," <NOTHING DELETED>"

               READ X:3

               QUIT 

 +2        SET %A="OK TO DELETE"

           SET %B=""

           SET %=2

           DO ^PRCFYN

           IF %'=1

               WRITE $CHAR(7)," <NOTHING DELETED>"

               READ X:3

               QUIT 

 +3        SET DA=+Y

           DO K

           WRITE "  CODE SHEET DELETED",$CHAR(7)

           READ X:2

           QUIT 

 +4        QUIT 

A         ;SELECT CODE SHEETS TO BE DELETED FOR STATION NUMBER PRCFSN 

 +1        IF '$DATA(Y)

               SET X=$PIECE(^PRC(411,PRCFSN,0),"^",14)

               if X=""

                   SET X=90

               SET X="T-"_X

               SET %DT=""

               DO ^%DT

 +2        SET PRCFDATE=Y

           SET D0=0

           SET L=0

           FOR J=1:1

               SET D0=$ORDER(^PRCF(423,D0))

               if D0=""!(D0'?.N)

                   QUIT 

               IF $PIECE(^PRCF(423,D0,0),U,2)=PRCFSN

                   IF $DATA(^PRCF(423,D0,"TRANS"))

                       IF $PIECE(^("TRANS"),"^",3)<PRCFDATE

                           SET DA=D0

                           SET L=L+1

                           DO K

 +3        WRITE !!,L," CODE SHEETS DELETED FOR STATION ",PRC("SITE")

           QUIT 

K         ;KILL THE CODE SHEET AND CROSS REFERENCES

 +1        SET DIK="^PRCF(423,"

           DO WAIT^PRCFYN

           DO ^DIK

           KILL DA

           SET PRCFDEL=""

           QUIT 

 +2        KILL K,X,DA

           QUIT