source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDWLIFT6.m@ 812

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

initial load of FOIAVistA 6/30/08 version
File size: 8.2 KB
Line 
1SDWLIFT6 ;IOFO BAY PINES/OG - INTER-FACILITY TRANSFER: DISPLAY ACCEPT DETAILS ; Compiled March 23, 2005 12:38:06 ; Compiled January 25, 2007 16:34:01
2 ;;5.3;Scheduling;**415,446**;AUG 13 1993;Build 77
3 ;
4 ;
5 ;******************************************************************
6 ; CHANGE LOG
7 ;
8 ; DATE PATCH DESCRIPTION
9 ; ---- ----- -----------
10 ; 04/14/2006 SD*5.3*446 INTER-FACILITY TRANSFER
11 ;
12 Q
13EN ; INITIALIZE VARIABLES FOR DISPLAY
14 N DFN,SDWLI,SDWLOK,SDWLIFN0
15 K SDWLLIST
16 D GETLIST^SDWLIFT5
17 S (SDWLIFTN,SDWLIFN0)=$$GETTN^SDWLIFT(.SDWLLIST)
18 I 'SDWLIFTN S VALMBCK="R" Q
19 L +^SDWL(409.36,SDWLIFTN):10 I '$T S VALMBCK="R" Q
20 ; Refresh list and loop to ensure that the selection hasn't been removed while the choice was being made.
21 K SDWLLIST D GETLIST^SDWLIFT5
22 S (SDWLOK,SDWLI)=0 F S SDWLI=$O(SDWLLIST(SDWLI)) Q:'SDWLI I SDWLLIST(SDWLI,1)=SDWLIFTN S SDWLOK=1 Q
23 D:SDWLOK
24 .N DIC,DFN,SDWLDFN,SDWLICN,SDWLSSN,SDWLTY,X,Y
25 .S SDWLICN=$$GET1^DIQ(409.36,SDWLIFTN,991.01)
26 .S SDWLSSN=$$GET1^DIQ(409.36,SDWLIFTN,.09)
27 .S (DFN,SDWLDFN)=$S(+SDWLICN:$O(^DPT("AICN",SDWLICN,"")),1:"")
28 .I DFN="" S (DFN,SDWLDFN)=$S(+SDWLSSN:$O(^DPT("SSN",SDWLSSN,"")),1:"")
29 .S SDWLTY=$$GET1^DIQ(409.36,SDWLIFTN,4,"I")
30 .D EN^VALM("SDWL TRANSFER ACC VIEW")
31 .Q
32 L -^SDWL(409.36,SDWLIFN0)
33 D INIT^SDWLIFT5
34 S VALMBCK="R"
35 Q
36INIT ; Default initialization options.
37 N SDWLINFO
38 D GETINFO(.SDWLINFO)
39 F VALMCNT=1:1:SDWLINFO(0) D SET^VALM10(VALMCNT,SDWLINFO(VALMCNT,0))
40 Q
41GETINFO(SDWLOUT) ; The Coversheet function calls here too.
42 N DIC,D,X,WP,TMP,SDWLADD,SDWLFID,SDWLI
43 D GETS^DIQ(409.36,SDWLIFTN,"*",,"TMP")
44 S SDWLOUT(0)=1
45 D:SDWLDFN=""
46 .S SDWLOUT(SDWLOUT(0),0)="Patient not registered"
47 .S SDWLOUT(0)=SDWLOUT(0)+1
48 .D CNTRL^VALM10(1,1,22,IOINHI,IOINORM)
49 .Q
50 S SDWLOUT(SDWLOUT(0),0)="Transmg. Inst: "_$E($$GET1^DIQ(4,$$FIND1^DIC(4,"","X",TMP(409.36,SDWLIFTN_",",.1),"D"),.01)_SDWLSPS,1,28)_" "
51 S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_"Transmn. Date: "_TMP(409.36,SDWLIFTN_",",.2)
52 S SDWLOUT(0)=SDWLOUT(0)+1
53 S SDWLOUT(SDWLOUT(0),0)="Name: "_$E(TMP(409.36,SDWLIFTN_",",.01)_SDWLSPS,1,27)_" "
54 S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_"Sex: "_$E(TMP(409.36,SDWLIFTN_",",.02)_SDWLSPS,1,7)
55 S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_"DoB: "_$E(TMP(409.36,SDWLIFTN_",",.03)_SDWLSPS,1,13)
56 S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_"SSN: "_TMP(409.36,SDWLIFTN_",",.09)
57 ;
58 S SDWLOUT(0)=SDWLOUT(0)+1,SDWLADD=SDWLOUT(0)
59 S SDWLOUT(SDWLOUT(0),0)=$E("Address: "_TMP(409.36,SDWLIFTN_",",.111)_SDWLSPS,1,58)_" Status: "_TMP(409.36,SDWLIFTN_",",1)
60 F SDWLFID=.112:.001:.114,.117 I TMP(409.36,SDWLIFTN_",",SDWLFID)'="" S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)=$E(SDWLSPS,1,9)_TMP(409.36,SDWLIFTN_",",SDWLFID)
61 I TMP(409.36,SDWLIFTN_",",.115)_TMP(409.36,SDWLIFTN_",",.116)'="" D
62 .S SDWLOUT(0)=SDWLOUT(0)+1
63 .S SDWLOUT(SDWLOUT(0),0)=$E(SDWLSPS,1,9)
64 .I TMP(409.36,SDWLIFTN_",",.115)'="" S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_TMP(409.36,SDWLIFTN_",",.115)
65 .S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_" "_TMP(409.36,SDWLIFTN_",",.116)
66 .Q
67 I TMP(409.36,SDWLIFTN_",",.131)'="" S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)="Phone no "_TMP(409.36,SDWLIFTN_",",.131)
68 D:TMP(409.36,SDWLIFTN_",",.1217)'="" ; Temporary address details. Displayed to the right of the address in up to 3 lines starting column 62
69 .S SDWLOUT(SDWLADD,0)=$E(SDWLOUT(SDWLADD,0)_SDWLSPS,1,61)_"Temporary address" ; There should be at least three lines if it is also indicated as temporary.
70 .S SDWLOUT(SDWLADD+1,0)=$E(SDWLOUT(SDWLADD+1,0)_SDWLSPS,1,61)_"From: "_TMP(409.36,SDWLIFTN_",",.1217)
71 .S SDWLOUT(SDWLADD+2,0)=$E(SDWLOUT(SDWLADD+2,0)_SDWLSPS,1,61)_"To : "_TMP(409.36,SDWLIFTN_",",.1218)
72 .Q
73 S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)="Service connected: "_TMP(409.36,SDWLIFTN_",",.301)
74 I TMP(409.36,SDWLIFTN_",",.301)="YES" S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_" Percentage: "_TMP(409.36,SDWLIFTN_",",.302)
75 S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)="Primary Eligibility: "_TMP(409.36,SDWLIFTN_",",.361)
76 S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)="Wait List Type: "
77 S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_TMP(409.36,SDWLIFTN_",",4)_" : "_TMP(409.36,SDWLIFTN_",",5)
78 S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)="Desired Date of Appt: "
79 S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_TMP(409.36,SDWLIFTN_",",22)
80 S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_" Integration Control Number: "
81 S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_TMP(409.36,SDWLIFTN_",",991.01)
82 S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)="Comments: "
83 S X=$$GET1^DIQ(409.36,SDWLIFTN_",",.4,"Z","WP")
84 S SDWLI=0 F S SDWLI=$O(WP(SDWLI)) Q:'SDWLI S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)=WP(SDWLI,0)
85 Q
86GETTN(SDWLLIST) ; Get transfer id.
87 N DIR,Y
88 I 'SDWLLIST(0) S DIR(0)="Y",DIR("A")="No entries. OK",DIR("B")="YES" D ^DIR Q 0
89 I SDWLLIST(0)=1 S Y=1 ; If there is only one, don't ask.
90 E S DIR(0)="L^1:"_SDWLLIST(0),DIR("A")="Which entry?" D ^DIR
91 Q $G(SDWLLIST(+Y,1),0)
92HD ; -- Make header line for list processor
93 S (VALMHDR(1),VALMHDR(2))=""
94 Q
95PCMM(SDWLIFTN,DFN) ;
96 N SDWLPCMM,SDWLRES,DIE,DA,DR
97 I $G(DFN)="" W !,"Patient not entered on the system. Use Load/edit" S DIR(0)="E",VALMBCK="R" D ^DIR Q
98 S (SDWLPCMM,SDWLRES)=0
99 D PAT^SCMCQK
100 ;If a PCMM assignment was made, close 409.36
101 ;if an EWL Entry was created instead, add pointer
102 ;then pass a message back.
103 Q:'SDWLPCMM&'SDWLRES
104 S DIE="^SDWL(409.36,",DA=SDWLIFTN
105 I SDWLPCMM S DR="1///C"
106 E S DR="409.3///"_$P(SDWLRES,U,2)
107 D ^DIE,SENDST(SDWLIFTN)
108 Q
109 ;
110ACCEPT ; Sign the transaction off as accepted. Remove the temporary file and send a message to transmitting facility
111 N DIR
112 I $$GET1^DIQ(409.36,SDWLIFTN,.3)'="YES" D Q
113 .S DIR("A")="A coversheet does not appear to have been requested."_$C(13,10)_"This is required before acceptance. Enter RETURN to continue or '^' to exit"
114 .S DIR(0)="E"
115 .D ^DIR
116 .S VALMBCK=$S(Y:"R",1:"Q")
117 .Q
118 D FULL^VALM1
119 S DIR(0)="Y"
120 S DIR("A")="Do you confirm that the appropriate action was taken to schedule this patient"_$C(13,10)_"for an appointment or she/he has EWL entry and the cover sheet has been printed"
121 S DIR("B")="N"
122 D ^DIR
123 D:Y
124 .N SDWLSTN,SDWLINST,XMY,XMSUB,XMTEXT,XMDUZ,SDWLX,DA,DIK
125 .S SDWLSTN=$$GET1^DIQ(409.36,SDWLIFTN,.1)
126 .S SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D")
127 .S XMY("S.SDWL-XFER-SERVER@"_$$GET1^DIQ(4,SDWLINST,60))=""
128 .S XMSUB="SDWL TRANSFER ACCEPTANCE"
129 .S XMTEXT="SDWLX("
130 .S XMDUZ="POSTMASTER"
131 .S SDWLX(1,0)=".5"_U_"SENDING FACILITY TRANSFER ID"_U_$$GET1^DIQ(409.36,SDWLIFTN,.5)
132 .S SDWLX(2,0)="7"_U_"ACCEPTING PERSON"_U_$$GET1^DIQ(200,DUZ,.01)
133 .S SDWLX(0)=2
134 .D ^XMD
135 .S DA=SDWLIFTN,DIK="^SDWL(409.36," D ^DIK
136 .Q
137 S VALMBCK="Q"
138 Q
139REJECT ; Sign the transaction off as rejected. Remove the temporary file and send a message to transmitting facility
140 N SDWLSTN,SDWLINST,XMSUB,XMY,XMTEXT,XMDUZ,SDWLX
141 S SDWLSTN=$$GET1^DIQ(409.36,SDWLIFTN,.1)
142 S SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D")
143 S XMY("S.SDWL-XFER-SERVER@"_$$GET1^DIQ(4,SDWLINST,60))=""
144 S XMSUB="SDWL TRANSFER REJECTION"
145 S XMTEXT="SDWLX("
146 S XMDUZ="POSTMASTER"
147 S SDWLX(1,0)=".5"_U_"SENDING FACILITY TRANSFER ID"_U_$$GET1^DIQ(409.36,SDWLIFTN,.5)
148 S SDWLX(0)=1
149 D ^XMD
150 S DA=SDWLIFTN,DIK="^SDWL(409.36," D ^DIK
151 ;teh/05/20/2005 cleans the SDWLLIST array and reset count.
152 K SDWLLIST(SDWLIFTN)
153 S SDWLLIST(0)=SDWLLIST(0)-1
154 S VALMBCK="Q"
155EXIT ; Tidy up
156 K SDWLIFTN
157 Q
158SENDST(SDWLIFTN) ; Send status change notification
159 N SDWLSTN,SDWLINST,TMP,XMSUB,XMY,XMTEXT,XMDUZ,SDWLX,SDWLDA,SDWLDIS
160 S SDWLDA=$$GET1^DIQ(409.36,SDWLIFTN,409.3,"I"),SDWLDIS=$$GET1^DIQ(409.3,SDWLDA,21,"I")
161 D GETS^DIQ(409.36,SDWLIFTN,".1;.5;1;2","I","TMP")
162 S SDWLSTN=TMP(409.36,SDWLIFTN_",",.1,"I")
163 S SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D")
164 S XMY("S.SDWL-XFER-SERVER@"_$$GET1^DIQ(4,SDWLINST,60))=""
165 S XMSUB="SDWL TRANSFER STATUS CHANGE"
166 S XMTEXT="SDWLX("
167 S XMDUZ="POSTMASTER"
168 S SDWLX(1,0)=.5_U_"SENDING FACILITY TRANSFER ID"_U_TMP(409.36,SDWLIFTN_",",.5,"I")
169 S SDWLX(2,0)=1_U_"STATUS"_U_TMP(409.36,SDWLIFTN_",",1,"I")
170 S SDWLX(3,0)=7_U_"ACCEPTING PERSON"_U_$$GET1^DIQ(200,DUZ,.01)
171 S SDWLX(4,0)=2_U_"FACILITY TRANFERRED TO"_U_TMP(409.36,SDWLIFTN_",",2,"I")
172 S SDWLX(5,0)=21_U_"DISPOSITION"_U_SDWLDIS
173 S SDWLX(0)=5
174 D ^XMD
175 Q
Note: See TracBrowser for help on using the repository browser.