source: FOIAVistA/trunk/r/RECORD_TRACKING-RT/RTTR1.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.6 KB
Line 
1RTTR1 ;ALB/PKE,JLU-Record Transfer Option ; 11/09/90 14:24 ; 1/16/03 4:23pm
2 ;;2.0;Record Tracking;**6,33,38**;10/22/91
3 ;
4PT W @IOF D EQUALS^RTUTL3
5 W !,?20,XMB(CT) D LINE^RTUTL3 W !,"| |",?20,"Station Name Number Mail Routing Symbol",?79,"|"
6 Q
7 ;
8PN I $D(XMB(CT)) W !,"| 1a |",XMB(CT),?79,"|"
9 I $D(XMB(CT+1)) W !,"| 1b |",XMB(CT+1),?79,"|"
10 I $D(XMB(CT+2)) W !,"| 1c |",XMB(CT+2),?79,"|"
11 Q
12 ;
13PN1 D LINE^RTUTL3
14 W !,"| 4. NAME (Last,First,Middle)",?79,"|"
15 Q
16 ;
17PN2 W !,"| ",XMB(CT),?$X+46,"|"
18 Q
19 ;
20PY5 D LINE^RTUTL3
21 W !,"| 5a. [CN] ",XMB(CT),?39,"|"," [SS] ",XMB(CT+1),?79,"|"
22 Q
23 ;
24PY6 D LINE^RTUTL3
25 W !,"| 6. [SN] ",XMB(CT),?79,"|"
26 Q
27 ;
28PL16 D LINE^RTUTL3
29 W !,"| 16. FROM (Originating office) ",XMB(CT)
30 Q
31 ;
32PL16A W $C(13),"| 17. Date ",XMB(CT+1),?$X+49,"|"
33 Q
34 ;
35PL17 W $C(13),"| 18. Check when copy 2 is sent to Telecom [",XMB(CT),"] UNIT ",?$X+26,"|"
36 Q
37 ;
38REQ ;can screen also on domain entry to only select setup domains
39 ;no laygo?
40 ;entry for action on transferred TO other
41 ;need to format xmb(1-3)
424 ;1,2,3 Station Name, No, Mail Routing
43 S RTVAR=0
44 S DIC="^RTV(195.9,",DIC("A")="Select Institution: ",DIC(0)="IAEQM"
45 S DIC("S")="S Z0=^(0),Z=$P($P(Z0,U),"";"",2) I Z=""DIC(4,"",$P(Z0,U,3)="_+RTAPL
46 S DIC("V")="I $P(Y(0),U,4)=""I"""
47 K XMB,XMY
48 S CT=1,XMB(CT)="REQUEST FOR TRANSFER OF VETERANS RECORDS "
49 D PT
50 ;
51 S CT=2,DIC("B")=""
52AGN 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
53 I $D(DUOUT)!($D(DTOUT)) D EX Q
54XXX ;S BL=".",$P(BL,".",50)=""
55 K DIC
56 D INST
57 ;4 name ,5 cn ssn , 6 sn
58Y4 S DIC("A")="| ",DIC("B")="",CT=5
59 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
60 S XMB(CT)=$J($P(Y,"^",2),30)
61 S CT=1 D PT
62 S CT=2 D PN
63 S CT=5 D PN1,PN2
64 K DIC
65 ;
66Y5 S CT=6 I $D(^DPT(+Y,.31)) S J=$P(^(.31),U,3)
67 E S J=""
68 S XMB(CT)=$S(J:J,1:"Unknown"),XMB(CT+1)=$S(+$P(Y(0),U,9):$P(Y(0),U,9),1:"Unknown")
69 D PY5
70 ;
71Y6 S CT=8 I $D(^DPT(+Y,.32)) S J=$P(^(.32),U,8)
72 E S J=""
73 S XMB(CT)=$S(J:J,1:"Unknown")
74 D PY6
75 ;
76 K DUOUT,DTOUT D Y7^RTTR11 I $D(DUOUT)!($D(DTOUT)) D EX Q
77 ;
78L16 ;16 FROM (originating office)
79 S CT=35
80 ;saved incase want to make this field editable.
81 ;S DIR("A")="| 16. FROM (Originating office) ",DIR(0)="FAO^1:40"
82 ;D ^DIR I $D(DUOUT)!($D(DTOUT)) D EX Q
83 ;K DIR
84 S XMB(CT)=$S($D(RTDIV):$P(^DIC(4,RTDIV,0),U),1:"Unknown")
85 D PL16
86 ;
87 D LINE^RTUTL3
88 K X,Y,DIR
89 S DIR(0)="D^::AET",DIR("A")="| 17. Date ? ",DIR("B")="NOW"
90 D ^DIR K DIR I $D(DUOUT)!($D(DTOUT)) D EX Q
91 D DD^%DT S XMB(CT+1)=Y
92 D PL16A
93 I $D(RTKEY) Q
94 ;
95L17 S CT=37
96 I XMB(12)="" S XMB(CT)="" D XM1,LINE^RTUTL3 Q
97 D LINE^RTUTL3
98 S DIR("A")="| 18. Check when copy 2 is sent to Telecom [ ] UNIT ",DIR(0)="YOA"
99 D ^DIR I $D(DUOUT)!($D(DTOUT)) D EX Q
100 S XMB(CT)=$S(Y=1:"X",1:"")
101 D PL17
102 D LINE^RTUTL3
103 D XM1
104XM S XMY(DUZ)="",XMB="RT REQUEST/NOTICE TRANSFER" D ^XMB K XMB
105 D EX Q
106 ;
107BOR S DA=+Y,DR="[RT BORROWER SET-UP]",DIE="^RTV(195.9," D ^DIE K DE,DQ Q
108NAM 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
109 Q
110WHOTO ;
111 N RTQUIT
112 I $D(^RTV(195.9,RTB,0)),$D(^(1)) S X0=$P(^(0),U,5),X1=^(1)
113 E Q
114 ;X0 request prt ;X1 domain ;X2 remot mail grp ;x3 mail routing sym
115 S X2=$P(X1,"^",2),X3=$P(X1,"^",3),XMB(CT)=XMB(CT)_$J(X3,25),X1=$P(X1,"^")
116 I $G(X0)']""&($G(X2)']"") W !!,"Routing information for this Borrower/Location is incomplete - see Site Manager." S RTQUIT=1
117 I '$L(X1) W !,"Domain for this Borrower/Loacation is missing - see Site Manager." S RTQUIT=1
118 I $G(RTQUIT)=1 W !?20,"No message will be sent.",!!! Q
119 I $D(^DIC(4.2,X1,0)) S X1=$P(^(0),"^")
120 E Q
121 I '$L(X0),'$L(X2) Q
122 S:$L(X0) AXMY("D."_X0_"@"_X1)=""
123 S:$L(X2) AXMY("G."_X2_"@"_X1)=""
124 Q
125INST S AN=""
126 F AZ=0:0 S AN=$O(AXMY(AN)) Q:AN="" I $E(AN,$L(AN))="@" K AXMY(AN)
127 S (AN,XMN)=0,XMDUZ=DUZ F AZ=0:0 S AN=$O(AXMY(AN)) Q:AN="" S X=AN D INST^XMA21
128 K AZ,AN,AXMY,XMN,XMM,XMQ,XMMG,XMDUZ Q
129 ;
130EX K RTB,DIR,CT,DA,DIE,DIC,DR,DTOUT,DUOUT,XMB,A,BL,C,N,X0,X1,X2,X3,XMY
131 K RTVAR,RTV,Y,YZ,Z,X,Y Q
132 ;
133XM1 S CT=1 D PT^RTTR1
134 S CT=2 D PN^RTTR1
135 S CT=5 D PN1^RTTR1,PN2^RTTR1
136 S CT=6 D PY5^RTTR1
137 S CT=8 D PY6^RTTR1
138 S CT=10 D LINE^RTUTL3 W ! D PY8^RTTR11
139 S CT=12 D LINE^RTUTL3 W ! D PY11^RTTR11,LINE^RTUTL3
140 W ! K DIR S DIR(0)="E" D ^DIR K DIR Q:'Y
141 S CT=21 W ! D LINE^RTUTL3,PY13D^RTTR11 W ! D PY13^RTTR11,PY13A^RTTR11 W ! D PY13B^RTTR11,PY13C^RTTR11
142 S CT=31 D LINE^RTUTL3,PL14^RTTR11 W ! D PL14A^RTTR11 W ! D PL14B^RTTR11
143 S CT=33 D LINE^RTUTL3 W ! D PL15^RTTR11
144 S CT=35 D PL16^RTTR1,LINE^RTUTL3 W ! D PL16A^RTTR1
145 S CT=37 D LINE^RTUTL3 W ! D PL17^RTTR1,LINE^RTUTL3
146 Q
Note: See TracBrowser for help on using the repository browser.