PSUCP3 ;BIR/REG - PBM UTILITY TO PURGE ^XTMP and ^XTMP ;25 AUG 1998
;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
EN ;
N PSUI,PSUPDT,PSUCDT,PSUI1,PSUI2
D NOW^%DTC
S PSUCDT=X
S PSUI="PSU"
F S PSUI=$O(^XTMP(PSUI)) Q:$E(PSUI,1,3)'="PSU" D
.K ^XTMP(PSUI) Q
.S PSUPDT=$P($G(^XTMP(PSUI,0)),"^",1)
.I PSUPDT="" K ^XTMP(PSUI) Q
.I PSUPDT<PSUCDT K ^XTMP(PSUI) Q
;
Q ;ALL PURGED
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUCP3 402 printed Nov 22, 2024@17:37:33 Page 2
PSUCP3 ;BIR/REG - PBM UTILITY TO PURGE ^XTMP and ^XTMP ;25 AUG 1998
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
EN ;
+1 NEW PSUI,PSUPDT,PSUCDT,PSUI1,PSUI2
+2 DO NOW^%DTC
+3 SET PSUCDT=X
+4 SET PSUI="PSU"
+5 FOR
SET PSUI=$ORDER(^XTMP(PSUI))
if $EXTRACT(PSUI,1,3)'="PSU"
QUIT
Begin DoDot:1
+6 KILL ^XTMP(PSUI)
QUIT
+7 SET PSUPDT=$PIECE($GET(^XTMP(PSUI,0)),"^",1)
+8 IF PSUPDT=""
KILL ^XTMP(PSUI)
QUIT
+9 IF PSUPDT<PSUCDT
KILL ^XTMP(PSUI)
QUIT
End DoDot:1
+10 ;
+11 ;ALL PURGED
QUIT
