FHADRSY.m

FHADRSY ; HISC/NCA - Purge Old Annual Dietetic Data ;4/25/95  12:47

 ;;5.5;DIETETICS;;Jan 28, 2005

EN1 ; Purge Data Older than three years

 S X="T-1095",%DT="X" D ^%DT S EDT=$E(+Y,1,3)_"0500"

 S FLG=0 F QTR=1:1:4 S PRE=$E(EDT,1,4)_QTR_"00" I $D(^FH(117.3,"B",PRE,PRE)) S FLG=1 Q

 I 'FLG W !!,"Already Purged to ",$E(EDT,2,3) G KIL

D1 W !!,"Purge To The Year: ",$E(EDT,2,3)," // " R X:DTIME G:'$T!(X="^") KIL G:X="" D2 S %DT="E" D ^%DT G:U[X!$D(DTOUT) KIL G:Y<1 D1

 S Y=$E(+Y,1,3)_"0000" I Y>EDT W *7,!!,"CANNOT PURGE TO YEAR THAT IS GREATER THAN THE DEFAULT!" G D1

 S EDT=+Y

D2 F PRE=0:0 S PRE=$O(^FH(117.3,PRE)) Q:PRE'<EDT  D K0

 W !!,"... Done"

KIL G KILL^XUSCLEAN

K0 K ^FH(117.3,PRE),^FH(117.3,"B",PRE,PRE) Q

FHADRSY   ; HISC/NCA - Purge Old Annual Dietetic Data ;4/25/95  12:47

 +1       ;;5.5;DIETETICS;;Jan 28, 2005

EN1       ; Purge Data Older than three years

 +1        SET X="T-1095"

           SET %DT="X"

           DO ^%DT

           SET EDT=$EXTRACT(+Y,1,3)_"0500"

 +2        SET FLG=0

           FOR QTR=1:1:4

               SET PRE=$EXTRACT(EDT,1,4)_QTR_"00"

               IF $DATA(^FH(117.3,"B",PRE,PRE))

                   SET FLG=1

                   QUIT 

 +3        IF 'FLG

               WRITE !!,"Already Purged to ",$EXTRACT(EDT,2,3)

               GOTO KIL

D1         WRITE !!,"Purge To The Year: ",$EXTRACT(EDT,2,3)," // "

           READ X:DTIME

           IF '$TEST!(X="^")

               GOTO KIL

           IF X=""

               GOTO D2

           SET %DT="E"

           DO ^%DT

           IF U[X!$DATA(DTOUT)

               GOTO KIL

           IF Y<1

               GOTO D1

 +1        SET Y=$EXTRACT(+Y,1,3)_"0000"

           IF Y>EDT

               WRITE *7,!!,"CANNOT PURGE TO YEAR THAT IS GREATER THAN THE DEFAULT!"

               GOTO D1

 +2        SET EDT=+Y

D2         FOR PRE=0:0

               SET PRE=$ORDER(^FH(117.3,PRE))

               IF PRE'<EDT

                   QUIT 

               DO K0

 +1        WRITE !!,"... Done"

KIL        GOTO KILL^XUSCLEAN

K0         KILL ^FH(117.3,PRE),^FH(117.3,"B",PRE,PRE)

           QUIT