Routine: RMPRSP1

RMPRSP1 ;PHX/RFM/HPL/HNC-PRINT 5 DAY OLD SUSPENSE RECORDS ;8/29/1994

 ;;3.0;PROSTHETICS;**45,52,77**;Feb 09, 1996

 ; ODJ - patch 52 - 10/18/00 - fix undefined text line at EXT

 ;RVD patch #77 - change IO to ION

 D DIV4^RMPRSIT G:$D(X) EXIT1 S %ZIS="MQ" K IOP D ^%ZIS G:POP EXIT1

 I '$D(IO("Q")) U IO G PRINT

 K IO("Q") S ZTDESC="PRINT 5 DAY OLD SUSPENSE RECORDS",ZTRTN="PRINT^RMPRSP1",ZTIO=ION,ZTSAVE("RMPR(""STA"")")="",ZTSAVE("RMPRSITE")=""

 D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EXIT1

PRINT W:$E(IOST)["C-" @IOF S RMPRPAGE=1 F I=1:1:11 S FOT(I)=0,TOT=0

C S RMPREDT=$$FMADD^XLFDT(DT,-7),RO=0,RB=$$FMADD^XLFDT(DT,-90) F  S RB=$O(^RMPR(668,"B",RB)) Q:RB>RMPREDT!(RB'>0)  F  S RO=$O(^RMPR(668,"B",RB,RO)) Q:RO=""  D CK

 G WRI

CK Q:'$D(^RMPR(668,RO,0))

 Q:$P(^RMPR(668,RO,0),U,10)'="O"

 Q:$P(^RMPR(668,RO,0),U,9)>0!($P(^(0),U)'>0)!($P(^(0),U,3)'>0)!('+$P(^(0),U,2))

 Q:$P(^RMPR(668,RO,0),U,7)'=RMPR("STA")

 S ^TMP($J,$P(^RMPR(668,RO,0),U),$P(^DPT($P(^RMPR(668,RO,0),U,2),0),U),$S($P(^(0),U,4)>0:$P(^(0),U,4),1:1),RO)=""

WRI ;

 N RP,RQ,RZ,RS

 S RP=0,RQ=0,RZ=0,RS=0

 F  S RP=$O(^TMP($J,RP)) Q:RP=""  F  S RQ=$O(^TMP($J,RP,RQ)) Q:RQ=""  F  S RS=$O(^TMP($J,RP,RQ,RS)) Q:RS=""  F  S RZ=$O(^TMP($J,RP,RQ,RS,RZ)) Q:RZ=""!($D(RMPREND))  D WRI2

 I $D(RMPREND) G EXIT1

 I '$D(^TMP($J)) D

 .  S Y=DT D DD^%DT W !,Y,?25,"OVER 5 DAY OLD SUSPENSE REPORT"

 .  W !!,"No open suspense records over 5 days!" S RMPREX=1

 I $D(RMPREX) K RMPREX G EXIT1

 W ! F I=1:1:79 W "-"

 W !,"PSC",?5,"2421",?11,"2237",?17,"2529-3",?25,"2529-7",?33,"2474",?39,"2431",?45,"2914",?51,"OTHER",?58,"2520",?64,"STK ISU",?74,"TOTAL"

 W !,$J(FOT(1),3),?5,$J(FOT(2),4),?11,$J(FOT(3),4),?17,$J(FOT(4),6),?25,$J(FOT(5),6),?33,$J(FOT(6),4),?39,$J(FOT(7),4),?45,$J(FOT(8),4),?51,$J(FOT(9),5),?58,$J(FOT(10),4),?64,$J(FOT(11),7)

 S RO=0

 F  S RO=$O(FOT(RO)) Q:RO=""  S TOT=TOT+FOT(RO)

 W ?74,$J(TOT,5)

 I $E(IOST)["C-" W ! K DIR S DIR(0)="E" D ^DIR

EXIT1 ;common exit

 K FO,I,TOT,FOT,RMPREDT,RMPRFLG,RMPRFL,RMPREND,RMPRPAGE,RMPRG,X,Y

 K RMPRFORM,DIR,RP,RS,RQ,RO,RB,RZ,RMPRFOR1,^TMP($J),RP,RR,RMPRFOR2

 D ^%ZISC

WRI2 I RMPRPAGE=1,'$D(RMPRFL) W:$Y>1 @IOF D HEADER1 Q:$D(RMPREND)

 I $Y>(IOSL-6),$E(IOST)["C-",$D(RMPRFL) D HEADER Q:$D(RMPREND)

 I $Y>(IOSL-6),$D(RMPRFL) W @IOF D HEADER1

WRI3 ;

 N DAT1

 S DAT1=$$DAT1^RMPRUTL1(RP)

 W !,DAT1,?13,$E($P(^DPT($P(^RMPR(668,RZ,0),U,2),0),U),1,20),?35,$E($P(^(0),U,9),6,9)

 D FORM

 W ?59,$S($D(^VA(200,+$P(^RMPR(668,RZ,0),U,4),0)):$E($P(^VA(200,$P(^RMPR(668,RZ,0),U,4),0),U),1,19),1:"NO NAME AVAILABLE")

 S RMPRFL=1

 Q:$D(RMPREND)

 D:$D(^RMPR(668,RZ,2,0)) EXT

HEADER ;

W !

 S DIR(0)="E" D ^DIR K DIR

 I Y=""!(Y=0) S RMPREND=1 Q:Y=""!(Y=0)

 W @IOF

HEADER1 ;

 Q:$D(RMPREND)

 S RMPRFL=1

 W !,?23,"DELINQUENT OPEN SUSPENSE REPORT",?70,"STA ",$$STA^RMPRUTIL,!,?2,"DATE",?18,"PATIENT",?35,"SSN",?41,"FORM",?59,"SUSPENDED BY",?73,"PAGE ",RMPRPAGE,!

 S RMPRPAGE=RMPRPAGE+1

 I $D(RMPRFLG) W !,"CON'T" K RMPRFLG

EXT ;display only the first line of description

 ;modified in patch 52

 N RR

 S RR=$O(^RMPR(668,RZ,2,0))

 W:+RR !,$G(^RMPR(668,RZ,2,RR,0))

 ;display the entire description

 ;N RR

 ;S RR=0

 ;F  S RR=$O(^RMPR(668,RZ,2,RR)) W:RR="" ! Q:RR=""!($D(RMPREND))  D PEXT

PEXT ;

 ;I $Y>(IOSL-6),$E(IOST)["C",$D(RMPRFL) S RMPRFLG=1 D HEADER Q:$D(RMPREND)

 ;I $Y>(IOSL-6),$D(RMPRFL) W @IOF S RMPRFLG=1 D HEADER1

 ;W !,$P(^RMPR(668,RZ,2,RR,0),U)

FORM ;

 S FO=$P(^RMPR(668,RZ,0),U,3)

 W ?41,$S(FO=1:"PSC",FO=2:"2421",FO=3:"2237",FO=4:"2529-3",FO=5:"2529-7",FO=6:"2474",FO=7:"2431",FO=8:"2914",FO=9:"OTHER",FO=10:"2520",FO=11:"STOCK ISSUE",1:"UNK")

 S $P(FOT(FO),U)=$P(FOT(FO),U)+1

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRSP1   3718     printed  Feb 19, 2025@00:04:14                                                                                                                                                                                                     Page 2

RMPRSP1   ;PHX/RFM/HPL/HNC-PRINT 5 DAY OLD SUSPENSE RECORDS ;8/29/1994

 +1       ;;3.0;PROSTHETICS;**45,52,77**;Feb 09, 1996

 +2       ;

 +3       ; ODJ - patch 52 - 10/18/00 - fix undefined text line at EXT

 +4       ;RVD patch #77 - change IO to ION

 +5       ;

 +6        DO DIV4^RMPRSIT

           if $DATA(X)

               GOTO EXIT1

           SET %ZIS="MQ"

           KILL IOP

           DO ^%ZIS

           if POP

               GOTO EXIT1

 +7        IF '$DATA(IO("Q"))

               USE IO

               GOTO PRINT

 +8        KILL IO("Q")

           SET ZTDESC="PRINT 5 DAY OLD SUSPENSE RECORDS"

           SET ZTRTN="PRINT^RMPRSP1"

           SET ZTIO=ION

           SET ZTSAVE("RMPR(""STA"")")=""

           SET ZTSAVE("RMPRSITE")=""

 +9        DO ^%ZTLOAD

           if $DATA(ZTSK)

               WRITE !,"REQUEST QUEUED!"

           HANG 1

           GOTO EXIT1

PRINT      if $EXTRACT(IOST)["C-"

               WRITE @IOF

           SET RMPRPAGE=1

           FOR I=1:1:11

               SET FOT(I)=0

               SET TOT=0

C          SET RMPREDT=$$FMADD^XLFDT(DT,-7)

           SET RO=0

           SET RB=$$FMADD^XLFDT(DT,-90)

FOR

               SET RB=$ORDER(^RMPR(668,"B",RB))

               if RB>RMPREDT!(RB'>0)

                   QUIT

FOR

                   SET RO=$ORDER(^RMPR(668,"B",RB,RO))

                   if RO=""

                       QUIT

                   DO CK

 +1        GOTO WRI

CK         if '$DATA(^RMPR(668,RO,0))

               QUIT

 +1        if $PIECE(^RMPR(668,RO,0),U,10)'="O"

               QUIT

 +2        if $PIECE(^RMPR(668,RO,0),U,9)>0!($PIECE(^(0),U)'>0)!($PIECE(^(0),U,3)'>0)!('+$PIECE(^(0),U,2))

               QUIT

 +3        if $PIECE(^RMPR(668,RO,0),U,7)'=RMPR("STA")

               QUIT

 +4        SET ^TMP($JOB,$PIECE(^RMPR(668,RO,0),U),$PIECE(^DPT($PIECE(^RMPR(668,RO,0),U,2),0),U),$SELECT($PIECE(^(0),U,4)>0:$PIECE(^(0),U,4),1:1),RO)=""

 +5        QUIT

WRI       ;

 +1        NEW RP,RQ,RZ,RS

 +2        SET RP=0

           SET RQ=0

           SET RZ=0

           SET RS=0

 +3        FOR

               SET RP=$ORDER(^TMP($JOB,RP))

               if RP=""

                   QUIT

FOR

                   SET RQ=$ORDER(^TMP($JOB,RP,RQ))

                   if RQ=""

                       QUIT

FOR

                       SET RS=$ORDER(^TMP($JOB,RP,RQ,RS))

                       if RS=""

                           QUIT

FOR

                           SET RZ=$ORDER(^TMP($JOB,RP,RQ,RS,RZ))

                           if RZ=""!($DATA(RMPREND))

                               QUIT

                           DO WRI2

 +4        IF $DATA(RMPREND)

               GOTO EXIT1

 +5       ;

 +6       ;

 +7        IF '$DATA(^TMP($JOB))

               Begin DoDot:1

 +8                SET Y=DT

                   DO DD^%DT

                   WRITE !,Y,?25,"OVER 5 DAY OLD SUSPENSE REPORT"

 +9                WRITE !!,"No open suspense records over 5 days!"

                   SET RMPREX=1

               End DoDot:1

 +10       IF $DATA(RMPREX)

               KILL RMPREX

               GOTO EXIT1

 +11      ;

 +12       WRITE !

           FOR I=1:1:79

               WRITE "-"

 +13       WRITE !,"PSC",?5,"2421",?11,"2237",?17,"2529-3",?25,"2529-7",?33,"2474",?39,"2431",?45,"2914",?51,"OTHER",?58,"2520",?64,"STK ISU",?74,"TOTAL"

 +14       WRITE !,$JUSTIFY(FOT(1),3),?5,$JUSTIFY(FOT(2),4),?11,$JUSTIFY(FOT(3),4),?17,$JUSTIFY(FOT(4),6),?25,$JUSTIFY(FOT(5),6),?33,$JUSTIFY(FOT(6),4),?39,$JUSTIFY(FOT(7),4),?45,$JUSTIFY(FOT(8),4),?51,$JUSTIFY(FOT(9),5),?58,$JUSTIFY(FOT(10),4),?64,$JUSTI

FY(FOT(11),7)

 +15       SET RO=0

 +16       FOR

               SET RO=$ORDER(FOT(RO))

               if RO=""

                   QUIT

               SET TOT=TOT+FOT(RO)

 +17       WRITE ?74,$JUSTIFY(TOT,5)

 +18       IF $EXTRACT(IOST)["C-"

               WRITE !

               KILL DIR

               SET DIR(0)="E"

               DO ^DIR

 +19      ;

EXIT1     ;common exit

 +1        KILL FO,I,TOT,FOT,RMPREDT,RMPRFLG,RMPRFL,RMPREND,RMPRPAGE,RMPRG,X,Y

 +2        KILL RMPRFORM,DIR,RP,RS,RQ,RO,RB,RZ,RMPRFOR1,^TMP($JOB),RP,RR,RMPRFOR2

 +3        DO ^%ZISC

 +4        QUIT

 +5       ;

WRI2       IF RMPRPAGE=1

               IF '$DATA(RMPRFL)

                   if $Y>1

                       WRITE @IOF

                   DO HEADER1

                   if $DATA(RMPREND)

                       QUIT

 +1        IF $Y>(IOSL-6)

               IF $EXTRACT(IOST)["C-"

                   IF $DATA(RMPRFL)

                       DO HEADER

                       if $DATA(RMPREND)

                           QUIT

 +2        IF $Y>(IOSL-6)

               IF $DATA(RMPRFL)

                   WRITE @IOF

                   DO HEADER1

WRI3      ;

 +1        NEW DAT1

 +2        SET DAT1=$$DAT1^RMPRUTL1(RP)

 +3        WRITE !,DAT1,?13,$EXTRACT($PIECE(^DPT($PIECE(^RMPR(668,RZ,0),U,2),0),U),1,20),?35,$EXTRACT($PIECE(^(0),U,9),6,9)

 +4        DO FORM

 +5        WRITE ?59,$SELECT($DATA(^VA(200,+$PIECE(^RMPR(668,RZ,0),U,4),0)):$EXTRACT($PIECE(^VA(200,$PIECE(^RMPR(668,RZ,0),U,4),0),U),1,19),1:"NO NAME AVAILABLE")

 +6        SET RMPRFL=1

 +7        if $DATA(RMPREND)

               QUIT

 +8        if $DATA(^RMPR(668,RZ,2,0))

               DO EXT

 +9        QUIT

HEADER    ;

 +1        WRITE !

 +2        SET DIR(0)="E"

           DO ^DIR

           KILL DIR

 +3        IF Y=""!(Y=0)

               SET RMPREND=1

               if Y=""!(Y=0)

                   QUIT

 +4        WRITE @IOF

 +5       ;

HEADER1   ;

 +1        if $DATA(RMPREND)

               QUIT

 +2        SET RMPRFL=1

 +3        WRITE !,?23,"DELINQUENT OPEN SUSPENSE REPORT",?70,"STA ",$$STA^RMPRUTIL,!,?2,"DATE",?18,"PATIENT",?35,"SSN",?41,"FORM",?59,"SUSPENDED BY",?73,"PAGE ",RMPRPAGE,!

 +4        SET RMPRPAGE=RMPRPAGE+1

 +5        IF $DATA(RMPRFLG)

               WRITE !,"CON'T"

               KILL RMPRFLG

 +6        QUIT

 +7       ;

EXT       ;display only the first line of description

 +1       ;modified in patch 52

 +2        NEW RR

 +3        SET RR=$ORDER(^RMPR(668,RZ,2,0))

 +4        if +RR

               WRITE !,$GET(^RMPR(668,RZ,2,RR,0))

 +5       ;display the entire description

 +6       ;N RR

 +7       ;S RR=0

 +8       ;F  S RR=$O(^RMPR(668,RZ,2,RR)) W:RR="" ! Q:RR=""!($D(RMPREND))  D PEXT

 +9        QUIT

 +10      ;

PEXT      ;

 +1       ;I $Y>(IOSL-6),$E(IOST)["C",$D(RMPRFL) S RMPRFLG=1 D HEADER Q:$D(RMPREND)

 +2       ;I $Y>(IOSL-6),$D(RMPRFL) W @IOF S RMPRFLG=1 D HEADER1

 +3       ;W !,$P(^RMPR(668,RZ,2,RR,0),U)

 +4        QUIT

 +5       ;

FORM      ;

 +1        SET FO=$PIECE(^RMPR(668,RZ,0),U,3)

 +2        WRITE ?41,$SELECT(FO=1:"PSC",FO=2:"2421",FO=3:"2237",FO=4:"2529-3",FO=5:"2529-7",FO=6:"2474",FO=7:"2431",FO=8:"2914",FO=9:"OTHER",FO=10:"2520",FO=11:"STOCK ISSUE",1:"UNK")

 +3        SET $PIECE(FOT(FO),U)=$PIECE(FOT(FO),U)+1

 +4        QUIT

RMPRSP1.m