- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHADRSY 725 printed Mar 13, 2025@20:51:20 Page 2
- 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
