IBQLPRG.m

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 ---IBQLPRG   664     printed  Apr 09, 2024@21:43:05                                                                                                                                                                                                      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