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)=""
Q
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
Q
;
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
Q
W !
S DIR(0)="E" D ^DIR K DIR
I Y=""!(Y=0) S RMPREND=1 Q:Y=""!(Y=0)
W @IOF
;
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
Q
;
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
Q
;
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)
Q
;
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRSP1 3718 printed Apr 09, 2024@21:37:42 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
+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 ;
+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
