IBQLPRG ;LEB/MRY - PURGE UMR FILE AFTER ROLLUP ; 22-APR-95
;;1.0;UTILIZATION MGMT ROLLUP LOCAL;;Oct 01, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
N DIR,DIK,DA
; --
W !,"Purge Rollup Data"
S DIR(0)="SA^L:LOCAL;A:ALL",DIR("A")="Purge Local or ALL: ",DIR("B")="ALL" D ^DIR G:$D(DUOUT)!($D(DTOUT)) END
S IBDNLD=Y
S ZTRTN="PURGE^IBQLPRG",ZTDESC="IBQ - LOCAL PURGE ",ZTSAVE("IBDNLD")="",ZTIO=""
D ^%ZTLOAD G END
;
PURGE ; -- Purge entries
S DIK="^IBQ(538,"
S IBTRN=0 F S IBTRN=$O(^IBQ(538,IBTRN)) Q:'IBTRN D
.I IBDNLD="L" Q:$P(^IBQ(538,IBTRN,1),"^",6)'="L"
.S DA=IBTRN D ^DIK
Q
END K IBDNLD,IBTRN Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBQLPRG 664 printed Nov 22, 2024@17:51:21 Page 2
IBQLPRG ;LEB/MRY - PURGE UMR FILE AFTER ROLLUP ; 22-APR-95
+1 ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;;Oct 01, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 NEW DIR,DIK,DA
+5 ; --
+6 WRITE !,"Purge Rollup Data"
+7 SET DIR(0)="SA^L:LOCAL;A:ALL"
SET DIR("A")="Purge Local or ALL: "
SET DIR("B")="ALL"
DO ^DIR
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO END
+8 SET IBDNLD=Y
+9 SET ZTRTN="PURGE^IBQLPRG"
SET ZTDESC="IBQ - LOCAL PURGE "
SET ZTSAVE("IBDNLD")=""
SET ZTIO=""
+10 DO ^%ZTLOAD
GOTO END
+11 ;
PURGE ; -- Purge entries
+1 SET DIK="^IBQ(538,"
+2 SET IBTRN=0
FOR
SET IBTRN=$ORDER(^IBQ(538,IBTRN))
if 'IBTRN
QUIT
Begin DoDot:1
+3 IF IBDNLD="L"
if $PIECE(^IBQ(538,IBTRN,1),"^",6)'="L"
QUIT
+4 SET DA=IBTRN
DO ^DIK
End DoDot:1
+5 QUIT
END KILL IBDNLD,IBTRN
QUIT
