LABCX7P.m

LABCX7P ; IHS/DIR/FJE - NYD-CLEVELAND ROUTINE TO PURGE "ACC" CROSS REFERENCE ;

 ;;5.2;LA;;NOV 01, 1997

 ;

 ;S %DT="AEPX",%DT("A")="Enter date to stop Purge: " D ^%DT Q:Y<0  S DATE=Y

 S %DT="",X="T-10" D ^%DT Q:Y<0  S DATE=Y ;MOD JPC (CHANGE #DAYS)

 S ANO="" F I=0:0 S ANO=$O(^LRO(68,"ACC",ANO)) Q:ANO=""  F AA=0:0 S AA=$O(^LRO(68,"ACC",ANO,AA)) Q:AA=""  D LOOP

 Q

LOOP F ADT=0:0 S ADT=$O(^LRO(68,"ACC",ANO,AA,ADT)) Q:ADT=""!(ADT'<DATE)  K ^LRO(68,"ACC",ANO,AA,ADT) ;W !,ANO,?20,ADT ;;MOD JPC 4/21/93 (DON'T PRINT)

 Q

LABCX7P   ; IHS/DIR/FJE - NYD-CLEVELAND ROUTINE TO PURGE "ACC" CROSS REFERENCE ;

 +1       ;;5.2;LA;;NOV 01, 1997

 +2       ;

 +3       ;S %DT="AEPX",%DT("A")="Enter date to stop Purge: " D ^%DT Q:Y<0  S DATE=Y

 +4       ;MOD JPC (CHANGE #DAYS)

           SET %DT=""

           SET X="T-10"

           DO ^%DT

           IF Y<0

               QUIT 

           SET DATE=Y

 +5        SET ANO=""

           FOR I=0:0

               SET ANO=$ORDER(^LRO(68,"ACC",ANO))

               IF ANO=""

                   QUIT 

               FOR AA=0:0

                   SET AA=$ORDER(^LRO(68,"ACC",ANO,AA))

                   IF AA=""

                       QUIT 

                   DO LOOP

 +6        QUIT 

LOOP      ;W !,ANO,?20,ADT ;;MOD JPC 4/21/93 (DON'T PRINT)

           FOR ADT=0:0

               SET ADT=$ORDER(^LRO(68,"ACC",ANO,AA,ADT))

               IF ADT=""!(ADT'<DATE)

                   QUIT 

               KILL ^LRO(68,"ACC",ANO,AA,ADT)

 +1        QUIT