RTT12 ;ISC-ALBANY/PKE-repoint request to new record ; 12/30/02 12:28pm
;;2.0;Record Tracking;**31**;10/22/91
D EN K X,P,Z,RDT,RTV0,RTWND Q
;
EN I '$D(RT)!('$D(RTPAR))!('RT)!('RTPAR) Q
S RTRD(1)="Yes^transfer Requests to Record/Volume "_RTVOL
S RTRD(2)="No^not change the Record/Volume(s) Requested."
S:'$D(RTRD("A")) RTRD("A")="Pending Requests can be transferred to last Record/Volume just created. "_$C(13,10)_" Transfer Requests to volume '"_RTVOL_"' ? "
S RTRD(0)="S",RTRD("B")=2 D SET^RTRD K RTRD S X=$E(X) S:X["^" RTESC="" I X'="Y" Q
;get pend cut
Q:'$D(RTTY) D PND^RTRPT Q:'$D(RTWND(+RTTY))
;get requests
GET ;
N RTCNT
F RTV0=0:0 S RTV0=$O(^RT("P",RTPAR,RTV0)) Q:'RTV0 I RTV0'=RT D FIND
S RTV0=RTPAR Q:RTV0=RT
;z=da
FIND F Z=0:0 S Z=$O(^RTV(190.1,"B",RTV0,Z)) Q:'Z D REC L -^RTV(190.1,Z)
QUIT
;
REC I $D(^RTV(190.1,Z,0)),$D(^RT(+^RTV(190.1,Z,0))) L +^RTV(190.1,Z):1 I '$T G REC
N RTMVMNT0
I '$D(^RTV(190.1,Z,0))!('$D(^RT(+^RTV(190.1,Z,0)))) L -^RTV(190.1,Z) Q
;only requests,pending
S RTMVMNT0=^RTV(190.1,Z,0) ;zero node of the entry in 190.1
S RDT=+$P(RTMVMNT0,U,4) Q:'RDT I $P(RDT,".")<RTWND(+RTTY) Q
I $P(RTMVMNT0,U,6)'="r" D Q
. S RTCNT=$G(RTCNT)+1
. I $G(RTCNT)=1 W !!,"The following request(s) cannot be transferred due to Request Status:"
. W !?2,"Request for "_$E($$EXTRNL(4,4),1,12)_" for "_$E($$EXTRNL(5,5),1,25)_" - Status is "_$$EXTRNL(6,6)
S $P(^RTV(190.1,Z,0),"^",1)=RT,^RTV(190.1,"B",RT,Z)="" K ^RTV(190.1,"B",RTV0,Z) ;W " ." R X:0
;date/time needed
DAT I RDT,$D(^RTV(190.1,"AC",RTV0,$P(RDT,"."),Z)) S ^RTV(190.1,"AC",RT,$P(RDT,"."),Z)="" K ^RTV(190.1,"AC",RTV0,$P(RDT,"."),Z)
;
;pull list
PUL S P=+$P(^RTV(190.1,Z,0),"^",10)
I P,$D(^RTV(190.1,"AP1",P,RTV0,Z)) S ^RTV(190.1,"AP1",P,RT,Z)="" K ^RTV(190.1,"AP1",P,RTV0,Z)
L -^RTV(190.1,Z) Q
EXTRNL(RTPIECE,RTFIELD) ;get external values for fields to be displayed
; RTPIECE is piece of zero node, 190.1
; RTFIELD is FM field number
S Y=$P(RTMVMNT0,U,RTPIECE)
S C=$P(^DD(190.1,RTFIELD,0),U,2)
D Y^DIQ
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTT12 2069 printed Nov 22, 2024@17:44:56 Page 2
RTT12 ;ISC-ALBANY/PKE-repoint request to new record ; 12/30/02 12:28pm
+1 ;;2.0;Record Tracking;**31**;10/22/91
+2 DO EN
KILL X,P,Z,RDT,RTV0,RTWND
QUIT
+3 ;
EN IF '$DATA(RT)!('$DATA(RTPAR))!('RT)!('RTPAR)
QUIT
+1 SET RTRD(1)="Yes^transfer Requests to Record/Volume "_RTVOL
+2 SET RTRD(2)="No^not change the Record/Volume(s) Requested."
+3 if '$DATA(RTRD("A"))
SET RTRD("A")="Pending Requests can be transferred to last Record/Volume just created. "_$CHAR(13,10)_" Transfer Requests to volume '"_RTVOL_"' ? "
+4 SET RTRD(0)="S"
SET RTRD("B")=2
DO SET^RTRD
KILL RTRD
SET X=$EXTRACT(X)
if X["^"
SET RTESC=""
IF X'="Y"
QUIT
+5 ;get pend cut
+6 if '$DATA(RTTY)
QUIT
DO PND^RTRPT
if '$DATA(RTWND(+RTTY))
QUIT
+7 ;get requests
GET ;
+1 NEW RTCNT
+2 FOR RTV0=0:0
SET RTV0=$ORDER(^RT("P",RTPAR,RTV0))
if 'RTV0
QUIT
IF RTV0'=RT
DO FIND
+3 SET RTV0=RTPAR
if RTV0=RT
QUIT
+4 ;z=da
FIND FOR Z=0:0
SET Z=$ORDER(^RTV(190.1,"B",RTV0,Z))
if 'Z
QUIT
DO REC
LOCK -^RTV(190.1,Z)
+1 QUIT
+2 ;
REC IF $DATA(^RTV(190.1,Z,0))
IF $DATA(^RT(+^RTV(190.1,Z,0)))
LOCK +^RTV(190.1,Z):1
IF '$TEST
GOTO REC
+1 NEW RTMVMNT0
+2 IF '$DATA(^RTV(190.1,Z,0))!('$DATA(^RT(+^RTV(190.1,Z,0))))
LOCK -^RTV(190.1,Z)
QUIT
+3 ;only requests,pending
+4 ;zero node of the entry in 190.1
SET RTMVMNT0=^RTV(190.1,Z,0)
+5 SET RDT=+$PIECE(RTMVMNT0,U,4)
if 'RDT
QUIT
IF $PIECE(RDT,".")<RTWND(+RTTY)
QUIT
+6 IF $PIECE(RTMVMNT0,U,6)'="r"
Begin DoDot:1
+7 SET RTCNT=$GET(RTCNT)+1
+8 IF $GET(RTCNT)=1
WRITE !!,"The following request(s) cannot be transferred due to Request Status:"
+9 WRITE !?2,"Request for "_$EXTRACT($$EXTRNL(4,4),1,12)_" for "_$EXTRACT($$EXTRNL(5,5),1,25)_" - Status is "_$$EXTRNL(6,6)
End DoDot:1
QUIT
+10 ;W " ." R X:0
SET $PIECE(^RTV(190.1,Z,0),"^",1)=RT
SET ^RTV(190.1,"B",RT,Z)=""
KILL ^RTV(190.1,"B",RTV0,Z)
+11 ;date/time needed
DAT IF RDT
IF $DATA(^RTV(190.1,"AC",RTV0,$PIECE(RDT,"."),Z))
SET ^RTV(190.1,"AC",RT,$PIECE(RDT,"."),Z)=""
KILL ^RTV(190.1,"AC",RTV0,$PIECE(RDT,"."),Z)
+1 ;
+2 ;pull list
PUL SET P=+$PIECE(^RTV(190.1,Z,0),"^",10)
+1 IF P
IF $DATA(^RTV(190.1,"AP1",P,RTV0,Z))
SET ^RTV(190.1,"AP1",P,RT,Z)=""
KILL ^RTV(190.1,"AP1",P,RTV0,Z)
+2 LOCK -^RTV(190.1,Z)
QUIT
EXTRNL(RTPIECE,RTFIELD) ;get external values for fields to be displayed
+1 ; RTPIECE is piece of zero node, 190.1
+2 ; RTFIELD is FM field number
+3 SET Y=$PIECE(RTMVMNT0,U,RTPIECE)
+4 SET C=$PIECE(^DD(190.1,RTFIELD,0),U,2)
+5 DO Y^DIQ
+6 QUIT Y
