Routine: RMPR8PG

RMPR8PG ;PHX,HOIFO/JLT,SPS-PURGE 668 SUSPENSE FILE ;8/29/1994

 ;;3.0;PROSTHETICS;**5,75,140,163**;Feb 09, 1996;Build 9

 ;02/03/06 Added code to delete the pointer in 664.1 field .05 when a

 ;record is purged.

EN D DIV4^RMPRSIT Q:$D(X)

EN2 K %ZIS,IOP,ZTIO S %ZIS="MQ",%ZIS("B")="" D ^%ZIS G:POP END

 ;I IOST["C-" W !,$C(7),"YOU MAY NOT SELECT YOUR TERMINAL" G EN2

 I $D(IO("Q")) S ZTRTN="EN1^RMPR8PG",ZTDESC="PURGE 668 SUSPENSE FILE" F RD="I","RMPRIEN","RMPRDT","ION","RMPR(","RMPRSITE" S ZTSAVE(RD)=""

 I $D(IO("Q")) K IO("Q") D ^%ZTLOAD W !,"<REQUEST QUEUED!>" G EXIT

EN1 S (I,RMPRIEN,RDEL)=0,RMPRDT=$P(^RMPR(669.9,RMPRSITE,0),U,8) G:RMPRDT'>89 END

 S X1=DT,X2=-RMPRDT D C^%DTC S RMPRDT=X I RMPRDT<$O(^RMPR(668,"B",""))!('$O(^RMPR(668,0))) G END

 ;RMPR*3.0*163 adds check to insure the 0 node is defined in DIP run

 S DIS(0)="I $D(^RMPR(668,D0,0)),$P(^RMPR(668,D0,0),U,7)=RMPR(""STA"")",IOP=ION,DIC="^RMPR(668,",FLDS=".01;C1,1;C20;L17,2,3,6;C45;L15,5;C65,4;C1,7;C1",BY="5",FR=$S($D(^RMPR(668,"B")):$O(^RMPR(668,"B","")),1:2890101)

 S TO=RMPRDT,DHD="Purge Suspense File Entries from Station/Division "_RMPR("STA") D EN1^DIP

 N RMPR6641

 F  S RMPRIEN=$O(^RMPR(668,RMPRIEN)) Q:RMPRIEN'>0  I $P($G(^RMPR(668,RMPRIEN,0)),U,7)=RMPR("STA") I ($P(^RMPR(668,RMPRIEN,0),U,5))&($P(^(0),U,5)<RMPRDT) S DA=RMPRIEN,DIC="^RMPR(668," S DA=RMPRIEN,DIK=DIC D ^DIK D  S RDEL=RDEL+1

 . S RMPR6641=0 F  S RMPR6641=$O(^RMPR(664.1,"SUS",DA,RMPR6641)) Q:RMPR6641'>0  D

 .. I $D(^RMPR(664.1,RMPR6641,0)) S $P(^(0),U,8)=""

END I $G(RDEL)<1 W !!,"No Suspense entries purged."

 I $G(RDEL)>1 W !!,RDEL," Suspense entries purged."

 I $G(RDEL)=1 W !!,RDEL,"Suspense entry purged. "

EXIT ;common exit point

 K I,RD,X,DIS,%ZIS,X1,X2,RMPRIEN,RMPRDT,RMPR6641,RDEL,DIC,DIK,DA,RL,BY,DHD,DHIT,FLDS,FR,TO D ^%ZISC

 G AUDIT^RMPR8PG1    ;RMPR*3.0*163  Call to audit/remove file 668 'L' & 'L1' x-ref with pointer to null master rec

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR8PG   1924     printed  Apr 09, 2024@21:35:40                                                                                                                                                                                                     Page 2

RMPR8PG   ;PHX,HOIFO/JLT,SPS-PURGE 668 SUSPENSE FILE ;8/29/1994

 +1       ;;3.0;PROSTHETICS;**5,75,140,163**;Feb 09, 1996;Build 9

 +2       ;

 +3       ;02/03/06 Added code to delete the pointer in 664.1 field .05 when a

 +4       ;record is purged.

 +5       ;

EN         DO DIV4^RMPRSIT

           if $DATA(X)

               QUIT

EN2        KILL %ZIS,IOP,ZTIO

           SET %ZIS="MQ"

           SET %ZIS("B")=""

           DO ^%ZIS

           if POP

               GOTO END

 +1       ;I IOST["C-" W !,$C(7),"YOU MAY NOT SELECT YOUR TERMINAL" G EN2

 +2        IF $DATA(IO("Q"))

               SET ZTRTN="EN1^RMPR8PG"

               SET ZTDESC="PURGE 668 SUSPENSE FILE"

               FOR RD="I","RMPRIEN","RMPRDT","ION","RMPR(","RMPRSITE"

                   SET ZTSAVE(RD)=""

 +3        IF $DATA(IO("Q"))

               KILL IO("Q")

               DO ^%ZTLOAD

               WRITE !,"<REQUEST QUEUED!>"

               GOTO EXIT

EN1        SET (I,RMPRIEN,RDEL)=0

           SET RMPRDT=$PIECE(^RMPR(669.9,RMPRSITE,0),U,8)

           if RMPRDT'>89

               GOTO END

 +1        SET X1=DT

           SET X2=-RMPRDT

           DO C^%DTC

           SET RMPRDT=X

           IF RMPRDT<$ORDER(^RMPR(668,"B",""))!('$ORDER(^RMPR(668,0)))

               GOTO END

 +2       ;RMPR*3.0*163 adds check to insure the 0 node is defined in DIP run

 +3        SET DIS(0)="I $D(^RMPR(668,D0,0)),$P(^RMPR(668,D0,0),U,7)=RMPR(""STA"")"

           SET IOP=ION

           SET DIC="^RMPR(668,"

           SET FLDS=".01;C1,1;C20;L17,2,3,6;C45;L15,5;C65,4;C1,7;C1"

           SET BY="5"

           SET FR=$SELECT($DATA(^RMPR(668,"B")):$ORDER(^RMPR(668,"B","")),1:2890101)

 +4        SET TO=RMPRDT

           SET DHD="Purge Suspense File Entries from Station/Division "_RMPR("STA")

           DO EN1^DIP

 +5        NEW RMPR6641

 +6        FOR

               SET RMPRIEN=$ORDER(^RMPR(668,RMPRIEN))

               if RMPRIEN'>0

                   QUIT

               IF $PIECE($GET(^RMPR(668,RMPRIEN,0)),U,7)=RMPR("STA")

                   IF ($PIECE(^RMPR(668,RMPRIEN,0),U,5))&($PIECE(^(0),U,5)<RMPRDT)

                       SET DA=RMPRIEN

                       SET DIC="^RMPR(668,"

                       SET DA=RMPRIEN

                       SET DIK=DIC

                       DO ^DIK

                       Begin DoDot:1

 +7                        SET RMPR6641=0

FOR

                               SET RMPR6641=$ORDER(^RMPR(664.1,"SUS",DA,RMPR6641))

                               if RMPR6641'>0

                                   QUIT

                               Begin DoDot:2

 +8                                IF $DATA(^RMPR(664.1,RMPR6641,0))

                                       SET $PIECE(^(0),U,8)=""

                               End DoDot:2

                       End DoDot:1

                       SET RDEL=RDEL+1

END        IF $GET(RDEL)<1

               WRITE !!,"No Suspense entries purged."

 +1        IF $GET(RDEL)>1

               WRITE !!,RDEL," Suspense entries purged."

 +2        IF $GET(RDEL)=1

               WRITE !!,RDEL,"Suspense entry purged. "

EXIT      ;common exit point

 +1        KILL I,RD,X,DIS,%ZIS,X1,X2,RMPRIEN,RMPRDT,RMPR6641,RDEL,DIC,DIK,DA,RL,BY,DHD,DHIT,FLDS,FR,TO

           DO ^%ZISC

 +2       ;RMPR*3.0*163  Call to audit/remove file 668 'L' & 'L1' x-ref with pointer to null master rec

           GOTO AUDIT^RMPR8PG1

RMPR8PG.m