RTP6 ;ISC-ALBANY/PKE-kill logic, xref on file 44,.01 ; 9/17/87 20:21 ;
;;v 2.0;Record Tracking;;**13**;10/22/91
;
EN K ^TMP("RT F44",$J) S (RTPL,RTPLSAV)=X,RTPLNEW=$P(^SC(DA,0),U,1)
;
D FIND,SET,EX Q
;
EX K RTN,RTM,RTPL,RTPLSAV,RTPLNEW,RTPLDAT Q
;
FIND F RTN=1:1 S RTPL=$O(^RTV(194.2,"B",RTPL)) Q:$P(RTPL," [",1)]RTPLSAV Q:RTPL="" I $P(RTPL," [",1)=RTPLSAV F RTM=0:0 S RTM=$O(^RTV(194.2,"B",RTPL,RTM)) Q:'RTM D W1 D UTL,KILL
Q
SET Q:'$D(^TMP("RT F44",$J))
F RTM=0:0 S RTM=$O(^TMP("RT F44",$J,RTM)) Q:'RTM S RTPLDAT=^(RTM),RTPLDAT=RTPLNEW_$P(RTPLDAT,RTPLSAV,2) D TST S $P(^RTV(194.2,RTM,0),U)=RTPLDAT,^RTV(194.2,"B",RTPLDAT,RTM)=""
;
I RTN>1 W !!,"Number of Pull Lists renamed = ",RTN-1,!!
Q
UTL S ^TMP("RT F44",$J,RTM)=RTPL Q
;
KILL K ^RTV(194.2,"B",RTPL) Q
;
TST ;S ^TMP("RT F44",$J,"NEW",RTM)=RTPLDAT Q
;
W1 I RTN=1 W !,"Renameing Pull Lists in file 194.2",!,"." Q
E W "." Q
Q
PULL K RTPULL,RTPULL0,RTDT
W !!,"Select"_$S('$D(RTIRE):" Pull List: ALL CLINIC LISTS //",1:" a 'RR' Record Retirement Pull List: ") R X:DTIME G PULLQ:'$T!(X["^") S:X=""&('$D(RTIRE)) X="ALL" D UALL I $T S RTPULL="ALL" G RTDT
G PULLQ:X=""
S DIC="^RTV(194.2,",DIC(0)="ZEMQI"
S DIC("S")="I $P(^(0),U,12)="_RTDV_",$P(^(0),U,15)="_+RTAPL_",$P(^(0),U,10)"_$S('$D(RTIRE):"'=3",1:"=3")
D ^DIC K DIC G PULL:Y<0 S RTPULL=+Y,RTPULL0=Y(0),RTDT=$P($P(Y(0),"^",2),".")
I $P(Y(0),"^",6)="x" W !!,*7,"This pull list was cancelled by ",$S($D(^VA(200,+$P(Y(0),"^",8),0)):$P(^(0),"^"),1:"UNKNOWN")," on " S Y=$P(Y(0),"^",7) D DT^DIQ W "." G PULL
RTDT W ! I '$D(RTDT) S %DT="EAFX",%DT("A")="Select Date: " D ^%DT K %DT I Y>0 S RTDT=Y D SHOW^RTP41 I 'RTC K RTDT G RTDT
PULLQ I '$D(RTPULL)!('$D(RTDT)) K RTPULL,RTDT,RTPULL0
K RTC Q
UALL X ^%ZOSF("UPPERCASE")
S X=Y I X="ALL"!($E(X,1,4)="ALL ")!(X="ALL CLINIC LISTS") Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTP6 1847 printed Dec 13, 2024@02:34:22 Page 2
RTP6 ;ISC-ALBANY/PKE-kill logic, xref on file 44,.01 ; 9/17/87 20:21 ;
+1 ;;v 2.0;Record Tracking;;**13**;10/22/91
+2 ;
EN KILL ^TMP("RT F44",$JOB)
SET (RTPL,RTPLSAV)=X
SET RTPLNEW=$PIECE(^SC(DA,0),U,1)
+1 ;
+2 DO FIND
DO SET
DO EX
QUIT
+3 ;
EX KILL RTN,RTM,RTPL,RTPLSAV,RTPLNEW,RTPLDAT
QUIT
+1 ;
FIND FOR RTN=1:1
SET RTPL=$ORDER(^RTV(194.2,"B",RTPL))
if $PIECE(RTPL," [",1)]RTPLSAV
QUIT
if RTPL=""
QUIT
IF $PIECE(RTPL," [",1)=RTPLSAV
FOR RTM=0:0
SET RTM=$ORDER(^RTV(194.2,"B",RTPL,RTM))
if 'RTM
QUIT
DO W1
DO UTL
DO KILL
+1 QUIT
SET if '$DATA(^TMP("RT F44",$JOB))
QUIT
+1 FOR RTM=0:0
SET RTM=$ORDER(^TMP("RT F44",$JOB,RTM))
if 'RTM
QUIT
SET RTPLDAT=^(RTM)
SET RTPLDAT=RTPLNEW_$PIECE(RTPLDAT,RTPLSAV,2)
DO TST
SET $PIECE(^RTV(194.2,RTM,0),U)=RTPLDAT
SET ^RTV(194.2,"B",RTPLDAT,RTM)=""
+2 ;
+3 IF RTN>1
WRITE !!,"Number of Pull Lists renamed = ",RTN-1,!!
+4 QUIT
UTL SET ^TMP("RT F44",$JOB,RTM)=RTPL
QUIT
+1 ;
KILL KILL ^RTV(194.2,"B",RTPL)
QUIT
+1 ;
TST ;S ^TMP("RT F44",$J,"NEW",RTM)=RTPLDAT Q
+1 ;
W1 IF RTN=1
WRITE !,"Renameing Pull Lists in file 194.2",!,"."
QUIT
+1 IF '$TEST
WRITE "."
QUIT
+2 QUIT
PULL KILL RTPULL,RTPULL0,RTDT
+1 WRITE !!,"Select"_$SELECT('$DATA(RTIRE):" Pull List: ALL CLINIC LISTS //",1:" a 'RR' Record Retirement Pull List: ")
READ X:DTIME
if '$TEST!(X["^")
GOTO PULLQ
if X=""&('$DATA(RTIRE))
SET X="ALL"
DO UALL
IF $TEST
SET RTPULL="ALL"
GOTO RTDT
+2 if X=""
GOTO PULLQ
+3 SET DIC="^RTV(194.2,"
SET DIC(0)="ZEMQI"
+4 SET DIC("S")="I $P(^(0),U,12)="_RTDV_",$P(^(0),U,15)="_+RTAPL_",$P(^(0),U,10)"_$SELECT('$DATA(RTIRE):"'=3",1:"=3")
+5 DO ^DIC
KILL DIC
if Y<0
GOTO PULL
SET RTPULL=+Y
SET RTPULL0=Y(0)
SET RTDT=$PIECE($PIECE(Y(0),"^",2),".")
+6 IF $PIECE(Y(0),"^",6)="x"
WRITE !!,*7,"This pull list was cancelled by ",$SELECT($DATA(^VA(200,+$PIECE(Y(0),"^",8),0)):$PIECE(^(0),"^"),1:"UNKNOWN")," on "
SET Y=$PIECE(Y(0),"^",7)
DO DT^DIQ
WRITE "."
GOTO PULL
RTDT WRITE !
IF '$DATA(RTDT)
SET %DT="EAFX"
SET %DT("A")="Select Date: "
DO ^%DT
KILL %DT
IF Y>0
SET RTDT=Y
DO SHOW^RTP41
IF 'RTC
KILL RTDT
GOTO RTDT
PULLQ IF '$DATA(RTPULL)!('$DATA(RTDT))
KILL RTPULL,RTDT,RTPULL0
+1 KILL RTC
QUIT
UALL XECUTE ^%ZOSF("UPPERCASE")
+1 SET X=Y
IF X="ALL"!($EXTRACT(X,1,4)="ALL ")!(X="ALL CLINIC LISTS")
QUIT
+2 QUIT
