- 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 Jan 18, 2025@03:42:23 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