source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDWLIFT3.m@ 1540

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

initial load of FOIAVistA 6/30/08 version
File size: 7.9 KB
Line 
1SDWLIFT3 ;IOFO BAY PINES/OG - INTER-FACILITY TRANSFER: NEW TRANSFER ; Compiled March 23, 2005 11:15:27 ; Compiled April 16, 2007 10:52:44
2 ;;5.3;Scheduling;**415,446**;AUG 13 1993;Build 77
3 ;
4 ;
5 ;******************************************************************
6 ; CHANGE LOG
7 ;
8 ; DATE PATCH DESCRIPTION
9 ; ---- ----- -----------
10 ; 12/12/05 SD*5.3*446 Enhancements
11 ;
12 Q
13EN ; INITIALIZE VARIABLES
14 N DIR,DIC,DR,DIE,VADM,X,Y
15 D FULL^VALM1
16 D EN2()
17 D INIT^SDWLIFT1(0)
18 ; VALMBCK required by List Manager
19 S VALMBCK="R"
20 Q
21EN2(SDWLDA) ; Entry point if Wait List has been selected elsewhere.
22 ; SDWLOPT is the option to be queried.
23 ; 1: Patient & Wait List Entry
24 ; 2: Institution
25 ; 3: Comments
26 ; 4: Processing
27 ; 5: Confirmation
28 N SDWLOPT,SDWLOPT0
29 S SDWLOPT=2
30 I '$D(SDWLDA) S SDWLDA="",SDWLOPT=1
31 S SDWLOPT0=SDWLOPT
32 F D Q:'SDWLOPT
33 .N SDWLDFN,SDWLDMN,SDWLIFTN,SDWLINST,DIC,DIE,DIR,DA,DO,I,Y,%,DIWETXT
34 .I SDWLOPT=1 D
35 ..N DFN,SDWLOK,SDWLOUT,SDWLC,SDWLI,SDWLNM,SDWLTMP
36 ..K Y,X
37 ..S DIC=2,DIC(0)="AEMZ",DIC("S")="I $$ISEWL^SDWLIFT3(+Y)"
38 ..D ^DIC
39 ..I Y=-1 S SDWLOPT=0 Q
40 ..S DFN=+Y ; DFN used to uniquely identify the patient in the following look-up.
41 ..D LIST^DIC(409.3,,".01;2;4;5;6;7;8",,,,$P(Y,U,2),,"I $$ISEWL2^SDWLIFT3(Y,DFN)",,"SDWLTMP")
42 ..F I=1:1:+SDWLTMP("DILIST",0) D
43 ...N TMP,SDWLSTA
44 ...S TMP=""
45 ...I SDWLTMP("DILIST","ID",I,2)'="" S TMP=TMP_SDWLTMP("DILIST","ID",I,2)_" "
46 ...D:SDWLTMP("DILIST","ID",I,4)'=""
47 ....S SDWLTMP("WLTY",I,0)=SDWLTMP("DILIST","ID",I,4),SDWLSTA=$$GET1^DIQ(409.3,SDWLTMP("DILIST",2,I),4,"I")
48 ....I SDWLTMP("DILIST","ID",I,SDWLSTA+4)'="" S SDWLTMP("WLTY",I,0)=SDWLTMP("WLTY",I,0)_" ("_SDWLTMP("DILIST","ID",I,SDWLSTA+4)_")"
49 ....S TMP=TMP_SDWLTMP("WLTY",I,0)
50 ....Q
51 ...S $P(DIR(0),";",I)=I_":"_TMP
52 ...Q
53 ..; If there is only one EWL entry, use that. The previous look-up will have ensured there is at least one.
54 ..; If there are more than one, call ^DIR to select.
55 ..S Y=1
56 ..I +SDWLTMP("DILIST",0)>1 S DIR(0)="S^"_DIR(0),DIR("A")="Enter 1 - "_+SDWLTMP("DILIST",0) D ^DIR Q:Y="^"
57 ..W !?4,"Institution:",?20,SDWLTMP("DILIST","ID",Y,2)
58 ..W !?4,"Wait List Type:",?20,$G(SDWLTMP("WLTY",Y,0))
59 ..S SDWLDA=SDWLTMP("DILIST",2,Y)
60 ..I $D(^SDWL(409.36,"C",SDWLDA)) S SDWLOK=0 D I SDWLOK S SDWLOPT=0 Q
61 ...N SDWLIFTN,SDWLSTN
62 ...S SDWLIFTN=$O(^SDWL(409.36,"C",SDWLDA,"")),SDWLSTN=$$GET1^DIQ(409.36,SDWLIFTN,".1")
63 ...S DIR(0)="E",DIR("A")="Press return to continue"
64 ...S DIR("A",1)="This EWL Entry is the result of a transfer request from "_$$GET1^DIQ(4,SDWLSTN,".01")_" ("_SDWLSTN_")"
65 ...;S DIR("A",2)="On acceptance at the destination facility, this EWL Entry will be removed."
66 ...S DIR("A",2)="To transfer care, close the EWL Entry as ER - ENTERED IN ERROR and reject the"
67 ...S DIR("A",3)="request. "_$$GET1^DIQ(4,SDWLSTN,".01")_" can then request the transfer."
68 ...D ^DIR
69 ...S SDWLOK=1
70 ...Q
71 ..S SDWLOPT=2
72 ..Q
73 .D:SDWLOPT=2
74 ..N SDWLY
75 ..S SDWLDFN=$$GET1^DIQ(409.3,SDWLDA,.01,"I")
76 ..S DIC=4
77 ..S DIC(0)="EMNQA"
78 ..S DIC("A")="Select Institution to transfer to: "
79 ..S DIC("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",'+$P($G(^DIC(4,+Y,99)),U,4),$L($P($G(^DIC(4,+Y,99)),U))=3,$$GET1^DIQ(4,Y,13)=""VAMC"""
80 ..D ^DIC
81 ..I Y=-1 S SDWLOPT=$S(SDWLOPT0=2:0,1:1) Q ; If the call was made to go straight to Institution, quit out if no institution is selected.
82 ..S SDWLY=+Y,SDWLDMN=$$GET1^DIQ(4,SDWLY,60)
83 ..I SDWLDMN="" W !,"This Institution does not have a Domain to which the request can be sent." Q
84 ..S SDWLINST=SDWLY,SDWLOPT=3
85 ..Q
86 .D:SDWLOPT=3
87 ..S DIC="^TMP(""SDWLIFT"",$J,""COMMENT""",DIWETXT="Transfer comments"
88 ..W !,DIWETXT
89 ..K @(DIC_")") S DIC=DIC_","
90 ..D EN^DIWE
91 ..S SDWLOPT=4
92 ..Q
93 .D:SDWLOPT=4
94 ..N SDWLDTM
95 ..K DIC
96 ..S DIR(0)="Y",DIR("A")="OK to send",DIR("B")="YES" D ^DIR
97 ..I 'Y S SDWLOPT=0 Q
98 ..S DIC=409.35,DIC(0)="Z",X=SDWLDA
99 ..D FILE^DICN
100 ..S SDWLIFTN=+Y
101 ..S DA(1)=+Y,DIC=DIC_DA(1)_",1,",SDWLI=0
102 ..F S SDWLI=$O(^TMP("SDWLIFT",$J,"COMMENT",SDWLI)) Q:'SDWLI S X=^TMP("SDWLIFT",$J,"COMMENT",SDWLI,0) K DO D FILE^DICN
103 ..D NOW^%DTC S SDWLDTM=%
104 ..S DIE=409.35,DR="1///"_$$GET1^DIQ(4,SDWLINST,99)_";2///"_SDWLDTM_";3///P;4///`"_DUZ
105 ..D ^DIE
106 ..D MSG
107 ..S SDWLOPT=0 K DIR
108 ..;S DIR(0)="E" D ^DIR
109 ..Q
110 .Q
111 Q
112 ;
113ISEWL(DFN) ; Filter for seach of PATIENT file ; OG ; SD*5.3*446
114 N SDWLOK,SDWLDA
115 S SDWLOK=0
116 Q:'$D(^SDWL(409.3,"B",DFN)) SDWLOK
117 S SDWLDA=0
118 F S SDWLDA=$O(^SDWL(409.3,"B",DFN,SDWLDA)) Q:'SDWLDA I $$ISEWL2(SDWLDA,DFN) S SDWLOK=1 Q
119 Q SDWLOK
120 ;
121ISEWL2(SDWLDA,DFN) ; If the EWL entry exists, is not closed, is a team or team position assignment and not already in transit.
122 N TMP
123 ;Q $$GET1^DIQ(409.3,SDWLDA,23,"I")'="C"&'$$GETTRN^SDWLIFT1(SDWLDA)&($$GET1^DIQ(409.3,SDWLDA,.01,"I")=DFN) old way of doing it.
124 D GETS^DIQ(409.3,SDWLDA_",",".01;4;23","I","TMP")
125 Q:$G(TMP(409.3,SDWLDA_",",.01,"I"))'=DFN 0
126 Q TMP(409.3,SDWLDA_",",23,"I")'="C"&("^1^2^"[("^"_TMP(409.3,SDWLDA_",",4,"I")_"^"))&'$$GETTRN^SDWLIFT1(SDWLDA)
127 ;
128MSG ;acknowledgement notification to destination
129 N SDWLDA,SDWLDTM,DFN,TMP,SDWLTY,SDWLX,SDWLI,DIE,DA,DR,VAPA,WP
130 N XMSUB,XMY,XMTEXT,XMDUZ,SDWLX,SDWLI
131 S XMSUB="SDWL TRANSFER REQUEST"
132 S XMY("S.SDWL-XFER-SERVER@"_SDWLDMN)=""
133 S XMTEXT="SDWLX("
134 S XMDUZ="POSTMASTER"
135 D NOW^%DTC S SDWLDTM=%
136 S SDWLDA=$$GET1^DIQ(409.35,SDWLIFTN,.01,"I")
137 D GETS^DIQ(409.3,SDWLDA,".01;4;22","I","TMP")
138 S DFN=TMP(409.3,SDWLDA_",",.01,"I")
139 S SDWLTY=TMP(409.3,SDWLDA_",",4,"I")
140 D DEM^VADPT,ADD^VADPT
141 D GETS^DIQ(2,DFN,".301;.302;991.01","I","TMP")
142 S SDWLX(0)=0
143 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".01"_U_"NAME"_U_VADM(1)
144 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".02"_U_"SEX"_U_$P(VADM(5),U)
145 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".03"_U_"DATE OF BIRTH"_U_$P(VADM(3),U)
146 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".09"_U_"SOCIAL SECURITY NUMBER"_U_$P(VADM(2),U)
147 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".1"_U_"REQUESTING STATION NUMBER"_U_$P($$SITE^VASITE(),U,3)
148 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".111"_U_"STREET ADDRESS [LINE 1]"_U_VAPA(1)
149 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".112"_U_"STREET ADDRESS [LINE 2]"_U_VAPA(2)
150 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".113"_U_"STREET ADDRESS [LINE 3]"_U_VAPA(3)
151 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".114"_U_"CITY"_U_VAPA(4)
152 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".115"_U_"STATE"_U_VAPA(5)
153 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".116"_U_"ZIP CODE"_U_VAPA(6)
154 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".117"_U_"COUNTY"_U_$P(VAPA(7),U)
155 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".1217"_U_"TEMPORARY ADDRESS START DATE"_U_$P(VAPA(9),U)
156 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".1218"_U_"TEMPORARY ADDRESS END DATE"_U_$P(VAPA(10),U)
157 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".131"_U_"PHONE NUMBER [RESIDENCE]"_U_VAPA(8)
158 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".301"_U_"SERVICE CONNECTED?"_U_TMP(2,DFN_",",.301,"I")
159 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".302"_U_"SERVICE CONNECTED PERCENTAGE"_U_TMP(2,DFN_",",.302,"I")
160 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".361"_U_"PRIMARY ELIGIBILITY CODE"_U_$$GET1^DIQ(2,DFN,.361)
161 S X=$$GET1^DIQ(409.35,SDWLIFTN_",",5,"Z","WP")
162 S SDWLI=0 F S SDWLI=$O(WP(SDWLI)) Q:'SDWLI S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".4"_U_"COMMENTS"_U_WP(SDWLI,0)
163 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".5"_U_"SENDING FACILITY TRANSFER ID"_U_SDWLIFTN
164 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=2_U_"TRANSMISSION DATE/TIME"_U_SDWLDTM
165 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=4_U_"WAIT LIST TYPE"_U_SDWLTY
166 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=5_U_"WAIT LIST TYPE EXTENSION"_U_$$GET1^DIQ(409.3,SDWLDA,4+SDWLTY)
167 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=22_U_"DESIRED DATE OF APPOINTMENT"_U_TMP(409.3,SDWLDA_",",22,"I")
168 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))="991.01"_U_"INTEGRATION CONTROL NUMBER"_U_TMP(2,DFN_",",991.01,"I")
169 D ^XMD
170 ; Change status of transfer file to TRANSMITTED
171 S DIE=409.35,DA=SDWLIFTN,DR="3///T" D ^DIE
172 ; Update the EWL Disposition code
173 S DIE=409.3,DA=SDWLDA,DR="21///TR" D ^DIE
174 Q
Note: See TracBrowser for help on using the repository browser.