- 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 Feb 19, 2025@00:01:33 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
