RMPRSP3 ;HINES/HNC; - Print Pending Suspense Records File 668 ;5-5-00
;;3.0;PROSTHETICS;**45,55,77**;Feb 09, 1996
; RVD 3/17/03 patch #77 - allow queing to p-message. IO to ION
;
;station from CPRS may not be the same as site params, can not filter
;station is from duz(2), the division in file 200, or
;default institution in kernel system parameters file 8989.3.
;
EN ;PRINT PENDING SUSPENSE
;
S %ZIS="MQ" K IOP D ^%ZIS G:POP EXIT
I '$D(IO("Q")) U IO G PRINT
K IO("Q") S ZTDESC="PRINT OPEN/PENDING SUMMARY SUSPENSE",ZTRTN="PRINT^RMPRSP3",ZTIO=ION
D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EXIT
;
PRINT I '$D(IO("Q")) U IO
W:$E(IOST)["C" @IOF
S RMPRPAGE=1
K ^TMP($J)
;
ALL ;main sort logic
;REQUIRED VARIABLES: RMPRPAGE - PAGE NUMBER
;
;VARIABLES SET: RP - DATE OF SUPENSE RECORD
; RO - ENTRY NUMBER IN SUSPENSE
S RP=0
F S RP=$O(^RMPR(668,"B",RP)) Q:RP'>0 D
.S RO=0
.F S RO=$O(^RMPR(668,"B",RP,RO)) Q:RO'>0 D CK1
G WRI
Q
;
CK1 ;screen records
Q:$P(^RMPR(668,RO,0),U,10)="X"
Q:$P(^RMPR(668,RO,0),U,10)="C"
;
S DFN=$P(^RMPR(668,RO,0),U,2) Q:DFN=""
D DEM^VADPT
S ^TMP($J,$P(^RMPR(668,RO,0),U,1),$P(VADM(1),U,1),RO)=""
K VADM
Q
;
WRI I '$D(^TMP($J)) W !,"No Open/Pending Suspense Records",! G EXIT
;date/time
S RP=0
F S RP=$O(^TMP($J,RP)) Q:RP="" D
.;patient name
.S RQ=""
.F S RQ=$O(^TMP($J,RP,RQ)) Q:RQ="" D
. .;record number
. .S RZ=""
. .F S RZ=$O(^TMP($J,RP,RQ,RZ)) Q:RZ=""!($D(RMPREND)) D WRI2
;
EXIT K ^TMP($J) D ^%ZISC,KILL^XUSCLEAN 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
;
W !,$$DAT1^RMPRUTL1(RP)
W ?10,$$STATUS^RMPREOU(RZ,4)
S WRKDAY=$$CWRKDAY^RMPREOU(RZ) W " ",WRKDAY K WRKDAY
W ?24,$E($P(^DPT($P(^RMPR(668,RZ,0),U,2),0),U),1,20),?42,$E($P(^(0),U,9),6,9)
D TYPE
W ?61,$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)
;
Q
;
;
W !,"Prosthetics Open/Pending Summary Suspense List "
N X,Y,% D NOW^%DTC S Y=% D DD^%DT S Y=$TR(Y,"@"," ") W $P(Y,":",1,2)
W ?70,"STA ",$$STA^RMPRUTIL,!,"DATE",?10,"STATUS",?24,"PATIENT"
W ?42,"SSN",?48,"TYPE",?61,"SUSPENDED BY",?73,"PAGE ",RMPRPAGE
W !,$$REPEAT^XLFSTR("-",79),!
S RMPRPAGE=RMPRPAGE+1 I $D(RMPRFLG) W !,"CON'T" K RMPRFLG
Q
;
TYPE S FO=$P(^RMPR(668,RZ,0),U,8) W ?48,$S(FO=1:"ROUTINE",FO=2:"EYEGLASS",FO=3:"CONTACT LENS",FO=4:"OXYGEN",FO=5:"MANUAL",1:"") Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRSP3 2753 printed Dec 13, 2024@02:37:48 Page 2
RMPRSP3 ;HINES/HNC; - Print Pending Suspense Records File 668 ;5-5-00
+1 ;;3.0;PROSTHETICS;**45,55,77**;Feb 09, 1996
+2 ; RVD 3/17/03 patch #77 - allow queing to p-message. IO to ION
+3 ;
+4 ;station from CPRS may not be the same as site params, can not filter
+5 ;station is from duz(2), the division in file 200, or
+6 ;default institution in kernel system parameters file 8989.3.
+7 ;
EN ;PRINT PENDING SUSPENSE
+1 ;
+2 SET %ZIS="MQ"
KILL IOP
DO ^%ZIS
if POP
GOTO EXIT
+3 IF '$DATA(IO("Q"))
USE IO
GOTO PRINT
+4 KILL IO("Q")
SET ZTDESC="PRINT OPEN/PENDING SUMMARY SUSPENSE"
SET ZTRTN="PRINT^RMPRSP3"
SET ZTIO=ION
+5 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"REQUEST QUEUED!"
HANG 1
GOTO EXIT
+6 ;
PRINT IF '$DATA(IO("Q"))
USE IO
+1 if $EXTRACT(IOST)["C"
WRITE @IOF
+2 SET RMPRPAGE=1
+3 KILL ^TMP($JOB)
+4 ;
ALL ;main sort logic
+1 ;REQUIRED VARIABLES: RMPRPAGE - PAGE NUMBER
+2 ;
+3 ;VARIABLES SET: RP - DATE OF SUPENSE RECORD
+4 ; RO - ENTRY NUMBER IN SUSPENSE
+5 SET RP=0
+6 FOR
SET RP=$ORDER(^RMPR(668,"B",RP))
if RP'>0
QUIT
Begin DoDot:1
+7 SET RO=0
+8 FOR
SET RO=$ORDER(^RMPR(668,"B",RP,RO))
if RO'>0
QUIT
DO CK1
End DoDot:1
+9 GOTO WRI
+10 QUIT
+11 ;
CK1 ;screen records
+1 if $PIECE(^RMPR(668,RO,0),U,10)="X"
QUIT
+2 if $PIECE(^RMPR(668,RO,0),U,10)="C"
QUIT
+3 ;
+4 SET DFN=$PIECE(^RMPR(668,RO,0),U,2)
if DFN=""
QUIT
+5 DO DEM^VADPT
+6 SET ^TMP($JOB,$PIECE(^RMPR(668,RO,0),U,1),$PIECE(VADM(1),U,1),RO)=""
+7 KILL VADM
+8 QUIT
+9 ;
WRI IF '$DATA(^TMP($JOB))
WRITE !,"No Open/Pending Suspense Records",!
GOTO EXIT
+1 ;date/time
+2 SET RP=0
+3 FOR
SET RP=$ORDER(^TMP($JOB,RP))
if RP=""
QUIT
Begin DoDot:1
+4 ;patient name
+5 SET RQ=""
+6 FOR
SET RQ=$ORDER(^TMP($JOB,RP,RQ))
if RQ=""
QUIT
Begin DoDot:2
+7 ;record number
+8 SET RZ=""
+9 FOR
SET RZ=$ORDER(^TMP($JOB,RP,RQ,RZ))
if RZ=""!($DATA(RMPREND))
QUIT
DO WRI2
End DoDot:2
End DoDot:1
+10 ;
EXIT KILL ^TMP($JOB)
DO ^%ZISC
DO KILL^XUSCLEAN
QUIT
+1 ;
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
+3 ;
+4 WRITE !,$$DAT1^RMPRUTL1(RP)
+5 WRITE ?10,$$STATUS^RMPREOU(RZ,4)
+6 SET WRKDAY=$$CWRKDAY^RMPREOU(RZ)
WRITE " ",WRKDAY
KILL WRKDAY
+7 WRITE ?24,$EXTRACT($PIECE(^DPT($PIECE(^RMPR(668,RZ,0),U,2),0),U),1,20),?42,$EXTRACT($PIECE(^(0),U,9),6,9)
+8 DO TYPE
+9 WRITE ?61,$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")
SET RMPRFL=1
+10 if $DATA(RMPREND)
QUIT
+11 ;
+12 QUIT
+13 ;
SET DIR(0)="E"
DO ^DIR
KILL DIR
if Y<1
SET RMPREND=1
if Y=""!(Y=0)
QUIT
WRITE @IOF
+1 ;
QUIT
SET RMPRFL=1
+1 WRITE !,"Prosthetics Open/Pending Summary Suspense List "
+2 NEW X,Y,%
DO NOW^%DTC
SET Y=%
DO DD^%DT
SET Y=$TRANSLATE(Y,"@"," ")
WRITE $PIECE(Y,":",1,2)
+3 WRITE ?70,"STA ",$$STA^RMPRUTIL,!,"DATE",?10,"STATUS",?24,"PATIENT"
+4 WRITE ?42,"SSN",?48,"TYPE",?61,"SUSPENDED BY",?73,"PAGE ",RMPRPAGE
+5 WRITE !,$$REPEAT^XLFSTR("-",79),!
+6 SET RMPRPAGE=RMPRPAGE+1
IF $DATA(RMPRFLG)
WRITE !,"CON'T"
KILL RMPRFLG
+7 QUIT
+8 ;
TYPE SET FO=$PIECE(^RMPR(668,RZ,0),U,8)
WRITE ?48,$SELECT(FO=1:"ROUTINE",FO=2:"EYEGLASS",FO=3:"CONTACT LENS",FO=4:"OXYGEN",FO=5:"MANUAL",1:"")
QUIT
