RTTR1 ;ALB/PKE,JLU-Record Transfer Option ; 11/09/90 14:24 ; 1/16/03 4:23pm
;;2.0;Record Tracking;**6,33,38**;10/22/91
;
PT W @IOF D EQUALS^RTUTL3
W !,?20,XMB(CT) D LINE^RTUTL3 W !,"| |",?20,"Station Name Number Mail Routing Symbol",?79,"|"
Q
;
PN I $D(XMB(CT)) W !,"| 1a |",XMB(CT),?79,"|"
I $D(XMB(CT+1)) W !,"| 1b |",XMB(CT+1),?79,"|"
I $D(XMB(CT+2)) W !,"| 1c |",XMB(CT+2),?79,"|"
Q
;
PN1 D LINE^RTUTL3
W !,"| 4. NAME (Last,First,Middle)",?79,"|"
Q
;
PN2 W !,"| ",XMB(CT),?$X+46,"|"
Q
;
PY5 D LINE^RTUTL3
W !,"| 5a. [CN] ",XMB(CT),?39,"|"," [SS] ",XMB(CT+1),?79,"|"
Q
;
PY6 D LINE^RTUTL3
W !,"| 6. [SN] ",XMB(CT),?79,"|"
Q
;
PL16 D LINE^RTUTL3
W !,"| 16. FROM (Originating office) ",XMB(CT)
Q
;
PL16A W $C(13),"| 17. Date ",XMB(CT+1),?$X+49,"|"
Q
;
PL17 W $C(13),"| 18. Check when copy 2 is sent to Telecom [",XMB(CT),"] UNIT ",?$X+26,"|"
Q
;
REQ ;can screen also on domain entry to only select setup domains
;no laygo?
;entry for action on transferred TO other
;need to format xmb(1-3)
4 ;1,2,3 Station Name, No, Mail Routing
S RTVAR=0
S DIC="^RTV(195.9,",DIC("A")="Select Institution: ",DIC(0)="IAEQM"
S DIC("S")="S Z0=^(0),Z=$P($P(Z0,U),"";"",2) I Z=""DIC(4,"",$P(Z0,U,3)="_+RTAPL
S DIC("V")="I $P(Y(0),U,4)=""I"""
K XMB,XMY
S CT=1,XMB(CT)="REQUEST FOR TRANSFER OF VETERANS RECORDS "
D PT
;
S CT=2,DIC("B")=""
AGN F CT=CT:1:4 S DIC("A")="| 1"_$C(95+CT)_" | " D ^DIC Q:Y<0 G:$D(RTB(+Y)) AGN S RTB(+Y)=CT,RTB=+Y,Y=$P(Y,"^",2) D NAM S XMB(CT)=$J(Y,25)_$J(N,18) D WHOTO K X0,X1,X2,X3
I $D(DUOUT)!($D(DTOUT)) D EX Q
XXX ;S BL=".",$P(BL,".",50)=""
K DIC
D INST
;4 name ,5 cn ssn , 6 sn
Y4 S DIC("A")="| ",DIC("B")="",CT=5
S DIC(0)="AIEMQZ",DIC="^DPT(" D PN1 S NDIC="N XMB D ^DIC" X NDIC K NDIC I $D(DUOUT)!($D(DTOUT))!(Y<1) D EX Q
S XMB(CT)=$J($P(Y,"^",2),30)
S CT=1 D PT
S CT=2 D PN
S CT=5 D PN1,PN2
K DIC
;
Y5 S CT=6 I $D(^DPT(+Y,.31)) S J=$P(^(.31),U,3)
E S J=""
S XMB(CT)=$S(J:J,1:"Unknown"),XMB(CT+1)=$S(+$P(Y(0),U,9):$P(Y(0),U,9),1:"Unknown")
D PY5
;
Y6 S CT=8 I $D(^DPT(+Y,.32)) S J=$P(^(.32),U,8)
E S J=""
S XMB(CT)=$S(J:J,1:"Unknown")
D PY6
;
K DUOUT,DTOUT D Y7^RTTR11 I $D(DUOUT)!($D(DTOUT)) D EX Q
;
L16 ;16 FROM (originating office)
S CT=35
;saved incase want to make this field editable.
;S DIR("A")="| 16. FROM (Originating office) ",DIR(0)="FAO^1:40"
;D ^DIR I $D(DUOUT)!($D(DTOUT)) D EX Q
;K DIR
S XMB(CT)=$S($D(RTDIV):$P(^DIC(4,RTDIV,0),U),1:"Unknown")
D PL16
;
D LINE^RTUTL3
K X,Y,DIR
S DIR(0)="D^::AET",DIR("A")="| 17. Date ? ",DIR("B")="NOW"
D ^DIR K DIR I $D(DUOUT)!($D(DTOUT)) D EX Q
D DD^%DT S XMB(CT+1)=Y
D PL16A
I $D(RTKEY) Q
;
L17 S CT=37
I XMB(12)="" S XMB(CT)="" D XM1,LINE^RTUTL3 Q
D LINE^RTUTL3
S DIR("A")="| 18. Check when copy 2 is sent to Telecom [ ] UNIT ",DIR(0)="YOA"
D ^DIR I $D(DUOUT)!($D(DTOUT)) D EX Q
S XMB(CT)=$S(Y=1:"X",1:"")
D PL17
D LINE^RTUTL3
D XM1
XM S XMY(DUZ)="",XMB="RT REQUEST/NOTICE TRANSFER" D ^XMB K XMB
D EX Q
;
BOR S DA=+Y,DR="[RT BORROWER SET-UP]",DIE="^RTV(195.9," D ^DIE K DE,DQ Q
NAM S Z="^"_$P(Y,";",2) I "^DIC(4,^"[(Z_"^"),$D(@(Z_+Y_",0)")) S Y=$P(^(0),"^"),N=$S($D(^(99)):$P(^(99),"^"),1:"") Q
Q
WHOTO ;
N RTQUIT
I $D(^RTV(195.9,RTB,0)),$D(^(1)) S X0=$P(^(0),U,5),X1=^(1)
E Q
;X0 request prt ;X1 domain ;X2 remot mail grp ;x3 mail routing sym
S X2=$P(X1,"^",2),X3=$P(X1,"^",3),XMB(CT)=XMB(CT)_$J(X3,25),X1=$P(X1,"^")
I $G(X0)']""&($G(X2)']"") W !!,"Routing information for this Borrower/Location is incomplete - see Site Manager." S RTQUIT=1
I '$L(X1) W !,"Domain for this Borrower/Loacation is missing - see Site Manager." S RTQUIT=1
I $G(RTQUIT)=1 W !?20,"No message will be sent.",!!! Q
I $D(^DIC(4.2,X1,0)) S X1=$P(^(0),"^")
E Q
I '$L(X0),'$L(X2) Q
S:$L(X0) AXMY("D."_X0_"@"_X1)=""
S:$L(X2) AXMY("G."_X2_"@"_X1)=""
Q
INST S AN=""
F AZ=0:0 S AN=$O(AXMY(AN)) Q:AN="" I $E(AN,$L(AN))="@" K AXMY(AN)
S (AN,XMN)=0,XMDUZ=DUZ F AZ=0:0 S AN=$O(AXMY(AN)) Q:AN="" S X=AN D INST^XMA21
K AZ,AN,AXMY,XMN,XMM,XMQ,XMMG,XMDUZ Q
;
EX K RTB,DIR,CT,DA,DIE,DIC,DR,DTOUT,DUOUT,XMB,A,BL,C,N,X0,X1,X2,X3,XMY
K RTVAR,RTV,Y,YZ,Z,X,Y Q
;
XM1 S CT=1 D PT^RTTR1
S CT=2 D PN^RTTR1
S CT=5 D PN1^RTTR1,PN2^RTTR1
S CT=6 D PY5^RTTR1
S CT=8 D PY6^RTTR1
S CT=10 D LINE^RTUTL3 W ! D PY8^RTTR11
S CT=12 D LINE^RTUTL3 W ! D PY11^RTTR11,LINE^RTUTL3
W ! K DIR S DIR(0)="E" D ^DIR K DIR Q:'Y
S CT=21 W ! D LINE^RTUTL3,PY13D^RTTR11 W ! D PY13^RTTR11,PY13A^RTTR11 W ! D PY13B^RTTR11,PY13C^RTTR11
S CT=31 D LINE^RTUTL3,PL14^RTTR11 W ! D PL14A^RTTR11 W ! D PL14B^RTTR11
S CT=33 D LINE^RTUTL3 W ! D PL15^RTTR11
S CT=35 D PL16^RTTR1,LINE^RTUTL3 W ! D PL16A^RTTR1
S CT=37 D LINE^RTUTL3 W ! D PL17^RTTR1,LINE^RTUTL3
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTTR1 4854 printed Oct 16, 2024@18:35:46 Page 2
RTTR1 ;ALB/PKE,JLU-Record Transfer Option ; 11/09/90 14:24 ; 1/16/03 4:23pm
+1 ;;2.0;Record Tracking;**6,33,38**;10/22/91
+2 ;
PT WRITE @IOF
DO EQUALS^RTUTL3
+1 WRITE !,?20,XMB(CT)
DO LINE^RTUTL3
WRITE !,"| |",?20,"Station Name Number Mail Routing Symbol",?79,"|"
+2 QUIT
+3 ;
PN IF $DATA(XMB(CT))
WRITE !,"| 1a |",XMB(CT),?79,"|"
+1 IF $DATA(XMB(CT+1))
WRITE !,"| 1b |",XMB(CT+1),?79,"|"
+2 IF $DATA(XMB(CT+2))
WRITE !,"| 1c |",XMB(CT+2),?79,"|"
+3 QUIT
+4 ;
PN1 DO LINE^RTUTL3
+1 WRITE !,"| 4. NAME (Last,First,Middle)",?79,"|"
+2 QUIT
+3 ;
PN2 WRITE !,"| ",XMB(CT),?$X+46,"|"
+1 QUIT
+2 ;
PY5 DO LINE^RTUTL3
+1 WRITE !,"| 5a. [CN] ",XMB(CT),?39,"|"," [SS] ",XMB(CT+1),?79,"|"
+2 QUIT
+3 ;
PY6 DO LINE^RTUTL3
+1 WRITE !,"| 6. [SN] ",XMB(CT),?79,"|"
+2 QUIT
+3 ;
PL16 DO LINE^RTUTL3
+1 WRITE !,"| 16. FROM (Originating office) ",XMB(CT)
+2 QUIT
+3 ;
PL16A WRITE $CHAR(13),"| 17. Date ",XMB(CT+1),?$X+49,"|"
+1 QUIT
+2 ;
PL17 WRITE $CHAR(13),"| 18. Check when copy 2 is sent to Telecom [",XMB(CT),"] UNIT ",?$X+26,"|"
+1 QUIT
+2 ;
REQ ;can screen also on domain entry to only select setup domains
+1 ;no laygo?
+2 ;entry for action on transferred TO other
+3 ;need to format xmb(1-3)
4 ;1,2,3 Station Name, No, Mail Routing
+1 SET RTVAR=0
+2 SET DIC="^RTV(195.9,"
SET DIC("A")="Select Institution: "
SET DIC(0)="IAEQM"
+3 SET DIC("S")="S Z0=^(0),Z=$P($P(Z0,U),"";"",2) I Z=""DIC(4,"",$P(Z0,U,3)="_+RTAPL
+4 SET DIC("V")="I $P(Y(0),U,4)=""I"""
+5 KILL XMB,XMY
+6 SET CT=1
SET XMB(CT)="REQUEST FOR TRANSFER OF VETERANS RECORDS "
+7 DO PT
+8 ;
+9 SET CT=2
SET DIC("B")=""
AGN FOR CT=CT:1:4
SET DIC("A")="| 1"_$CHAR(95+CT)_" | "
DO ^DIC
if Y<0
QUIT
if $DATA(RTB(+Y))
GOTO AGN
SET RTB(+Y)=CT
SET RTB=+Y
SET Y=$PIECE(Y,"^",2)
DO NAM
SET XMB(CT)=$JUSTIFY(Y,25)_$JUSTIFY(N,18)
DO WHOTO
KILL X0,X1,X2,X3
+1 IF $DATA(DUOUT)!($DATA(DTOUT))
DO EX
QUIT
XXX ;S BL=".",$P(BL,".",50)=""
+1 KILL DIC
+2 DO INST
+3 ;4 name ,5 cn ssn , 6 sn
Y4 SET DIC("A")="| "
SET DIC("B")=""
SET CT=5
+1 SET DIC(0)="AIEMQZ"
SET DIC="^DPT("
DO PN1
SET NDIC="N XMB D ^DIC"
XECUTE NDIC
KILL NDIC
IF $DATA(DUOUT)!($DATA(DTOUT))!(Y<1)
DO EX
QUIT
+2 SET XMB(CT)=$JUSTIFY($PIECE(Y,"^",2),30)
+3 SET CT=1
DO PT
+4 SET CT=2
DO PN
+5 SET CT=5
DO PN1
DO PN2
+6 KILL DIC
+7 ;
Y5 SET CT=6
IF $DATA(^DPT(+Y,.31))
SET J=$PIECE(^(.31),U,3)
+1 IF '$TEST
SET J=""
+2 SET XMB(CT)=$SELECT(J:J,1:"Unknown")
SET XMB(CT+1)=$SELECT(+$PIECE(Y(0),U,9):$PIECE(Y(0),U,9),1:"Unknown")
+3 DO PY5
+4 ;
Y6 SET CT=8
IF $DATA(^DPT(+Y,.32))
SET J=$PIECE(^(.32),U,8)
+1 IF '$TEST
SET J=""
+2 SET XMB(CT)=$SELECT(J:J,1:"Unknown")
+3 DO PY6
+4 ;
+5 KILL DUOUT,DTOUT
DO Y7^RTTR11
IF $DATA(DUOUT)!($DATA(DTOUT))
DO EX
QUIT
+6 ;
L16 ;16 FROM (originating office)
+1 SET CT=35
+2 ;saved incase want to make this field editable.
+3 ;S DIR("A")="| 16. FROM (Originating office) ",DIR(0)="FAO^1:40"
+4 ;D ^DIR I $D(DUOUT)!($D(DTOUT)) D EX Q
+5 ;K DIR
+6 SET XMB(CT)=$SELECT($DATA(RTDIV):$PIECE(^DIC(4,RTDIV,0),U),1:"Unknown")
+7 DO PL16
+8 ;
+9 DO LINE^RTUTL3
+10 KILL X,Y,DIR
+11 SET DIR(0)="D^::AET"
SET DIR("A")="| 17. Date ? "
SET DIR("B")="NOW"
+12 DO ^DIR
KILL DIR
IF $DATA(DUOUT)!($DATA(DTOUT))
DO EX
QUIT
+13 DO DD^%DT
SET XMB(CT+1)=Y
+14 DO PL16A
+15 IF $DATA(RTKEY)
QUIT
+16 ;
L17 SET CT=37
+1 IF XMB(12)=""
SET XMB(CT)=""
DO XM1
DO LINE^RTUTL3
QUIT
+2 DO LINE^RTUTL3
+3 SET DIR("A")="| 18. Check when copy 2 is sent to Telecom [ ] UNIT "
SET DIR(0)="YOA"
+4 DO ^DIR
IF $DATA(DUOUT)!($DATA(DTOUT))
DO EX
QUIT
+5 SET XMB(CT)=$SELECT(Y=1:"X",1:"")
+6 DO PL17
+7 DO LINE^RTUTL3
+8 DO XM1
XM SET XMY(DUZ)=""
SET XMB="RT REQUEST/NOTICE TRANSFER"
DO ^XMB
KILL XMB
+1 DO EX
QUIT
+2 ;
BOR SET DA=+Y
SET DR="[RT BORROWER SET-UP]"
SET DIE="^RTV(195.9,"
DO ^DIE
KILL DE,DQ
QUIT
NAM SET Z="^"_$PIECE(Y,";",2)
IF "^DIC(4,^"[(Z_"^")
IF $DATA(@(Z_+Y_",0)"))
SET Y=$PIECE(^(0),"^")
SET N=$SELECT($DATA(^(99)):$PIECE(^(99),"^"),1:"")
QUIT
+1 QUIT
WHOTO ;
+1 NEW RTQUIT
+2 IF $DATA(^RTV(195.9,RTB,0))
IF $DATA(^(1))
SET X0=$PIECE(^(0),U,5)
SET X1=^(1)
+3 IF '$TEST
QUIT
+4 ;X0 request prt ;X1 domain ;X2 remot mail grp ;x3 mail routing sym
+5 SET X2=$PIECE(X1,"^",2)
SET X3=$PIECE(X1,"^",3)
SET XMB(CT)=XMB(CT)_$JUSTIFY(X3,25)
SET X1=$PIECE(X1,"^")
+6 IF $GET(X0)']""&($GET(X2)']"")
WRITE !!,"Routing information for this Borrower/Location is incomplete - see Site Manager."
SET RTQUIT=1
+7 IF '$LENGTH(X1)
WRITE !,"Domain for this Borrower/Loacation is missing - see Site Manager."
SET RTQUIT=1
+8 IF $GET(RTQUIT)=1
WRITE !?20,"No message will be sent.",!!!
QUIT
+9 IF $DATA(^DIC(4.2,X1,0))
SET X1=$PIECE(^(0),"^")
+10 IF '$TEST
QUIT
+11 IF '$LENGTH(X0)
IF '$LENGTH(X2)
QUIT
+12 if $LENGTH(X0)
SET AXMY("D."_X0_"@"_X1)=""
+13 if $LENGTH(X2)
SET AXMY("G."_X2_"@"_X1)=""
+14 QUIT
INST SET AN=""
+1 FOR AZ=0:0
SET AN=$ORDER(AXMY(AN))
if AN=""
QUIT
IF $EXTRACT(AN,$LENGTH(AN))="@"
KILL AXMY(AN)
+2 SET (AN,XMN)=0
SET XMDUZ=DUZ
FOR AZ=0:0
SET AN=$ORDER(AXMY(AN))
if AN=""
QUIT
SET X=AN
DO INST^XMA21
+3 KILL AZ,AN,AXMY,XMN,XMM,XMQ,XMMG,XMDUZ
QUIT
+4 ;
EX KILL RTB,DIR,CT,DA,DIE,DIC,DR,DTOUT,DUOUT,XMB,A,BL,C,N,X0,X1,X2,X3,XMY
+1 KILL RTVAR,RTV,Y,YZ,Z,X,Y
QUIT
+2 ;
XM1 SET CT=1
DO PT^RTTR1
+1 SET CT=2
DO PN^RTTR1
+2 SET CT=5
DO PN1^RTTR1
DO PN2^RTTR1
+3 SET CT=6
DO PY5^RTTR1
+4 SET CT=8
DO PY6^RTTR1
+5 SET CT=10
DO LINE^RTUTL3
WRITE !
DO PY8^RTTR11
+6 SET CT=12
DO LINE^RTUTL3
WRITE !
DO PY11^RTTR11
DO LINE^RTUTL3
+7 WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
if 'Y
QUIT
+8 SET CT=21
WRITE !
DO LINE^RTUTL3
DO PY13D^RTTR11
WRITE !
DO PY13^RTTR11
DO PY13A^RTTR11
WRITE !
DO PY13B^RTTR11
DO PY13C^RTTR11
+9 SET CT=31
DO LINE^RTUTL3
DO PL14^RTTR11
WRITE !
DO PL14A^RTTR11
WRITE !
DO PL14B^RTTR11
+10 SET CT=33
DO LINE^RTUTL3
WRITE !
DO PL15^RTTR11
+11 SET CT=35
DO PL16^RTTR1
DO LINE^RTUTL3
WRITE !
DO PL16A^RTTR1
+12 SET CT=37
DO LINE^RTUTL3
WRITE !
DO PL17^RTTR1
DO LINE^RTUTL3
+13 QUIT
