source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDWLIFT.m@ 1303

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

initial load of FOIAVistA 6/30/08 version
File size: 8.3 KB
Line 
1SDWLIFT ;IOFO BAY PINES/OG - INTER-FACILITY TRANSFER: CONTROL RESPONSES;Compiled March 29, 2005 15:36:25 ; Compiled January 25, 2007 09:47:44 ; Compiled April 16, 2007 10:12:05
2 ;;5.3;Scheduling;**415,446**;AUG 13 1993;Build 77
3 ;
4 ;******************************************************************
5 ; CHANGE LOG
6 ;
7 ; DATE PATCH DESCRIPTION
8 ; ---- ----- -----------
9 ; 12/12/05 SD*5.3*446 Enhancements
10 ;
11MSGSVR ;xfer message server
12 ;variables provided by server XQ*
13 ;XQSOP : server option name
14 ;XQMSG : server request message number
15 ;XQSND : DUZ of sender
16 ;XQSUB : subject
17 ;SDMSG : local array of message lines
18 N SDWLMSG
19 D
20 .I $E(XQSUB,1,3)="RE:" Q ;quit for messages that are replies to original
21 .I XQSUB="SDWL TRANSFER REQUEST" D MSGSVRRQ^SDWLIFT0 Q ;transfer request
22 .I XQSUB="SDWL TRANSFER ACKNOWLEDGEMENT" D MSGSVRAR Q ;acknowledge request from receiving facility
23 .I XQSUB="SDWL TRANSFER REMOVAL REQUEST" D MSGSVRRM^SDWLIFT0 Q ;remove request
24 .I XQSUB="SDWL TRANSFER REMOVAL REQUEST ACKNOWLEDGEMENT" D MSGSVRRA Q ;remove request acknowledgement
25 .I XQSUB="SDWL TRANSFER ACCEPTANCE" D MSGSVRAC Q ;transaction accepted.
26 .I XQSUB="SDWL TRANSFER REJECTION" D MSGSVRRJ Q ;transaction rejected.
27 .I XQSUB="SDWL TRANSFER STATUS CHANGE" D MSGSVRSC Q ;status changed
28 .S SDWLMSG(1,0)="Message received by S.SDWL-XFER-SERVER option has an unrecognized message subject"
29 .D ERR(.SDWLMSG)
30 .Q
31 K XQMSG,XQSND,XQSUB
32 Q
33MSGSVRAR ;Acknowledge request
34 N DIE,DA,DR,DIC,D,X,SDWLX,SDWLI,SDWLMSG,TMP,SDWLDA,SDWLIST
35 D RMSG
36 S SDWLI=$O(SDWLMSG(1),-1) ;There's stuff between 0 and 1
37 F S SDWLI=$O(SDWLMSG(SDWLI)) Q:'SDWLI S SDWLX($P(SDWLMSG(SDWLI,0),U))=$P(SDWLMSG(SDWLI,0),U,3)
38 S DIC(0)="",DIC="^SDWL(409.35,",X="`"_SDWLX(.5) D ^DIC
39 ;If the transfer entry does not exist or does not belong to this request, send a removal request back
40 I Y=-1!(SDWLX(2)'=$$GET1^DIQ(409.35,SDWLX(.5),2,"I")) D SEND^SDWLIFT4(SDWLX(6),$$GET1^DIQ(4,$$FIND1^DIC(4,"","X",SDWLX(1),"D"),60)) Q
41 ; if this EWL entry is the subject of a transfer, close it and send message back to requesting facility
42 S SDWLIST="R",SDWLDA=$P(Y,U,2)
43 I $D(^SDWL(409.36,"C",SDWLDA)) S SDWLIST="C" D
44 .N DA,SDWLDUZ
45 .S DIE="^SDWL(409.3,"
46 .S DA=SDWLDA,SDWLDUZ=$$GET1^DIQ(409.35,SDWLIFTN,4,"I")
47 .S DR="21////^S X=""TR"";19////^S X=DT;20////^S X=SDWLDUZ;23////^S X=""C"""
48 .D ^DIE
49 .S DIE="^SDWL(409.36,",DA=$O(^SDWL(409.36,"C",SDWLDA,""))
50 .S DR="1///""R"";2///"_$$GET1^DIQ(409.35,SDWLIFTN,1,"I") D ^DIE
51 .D SENDST^SDWLIFT6(DA)
52 .Q
53 ;finally, set the transfer request file.
54 S DIE="^SDWL(409.35,",DA=SDWLX(.5),DR="3///"_SDWLIST_";6///"_SDWLX(6) D ^DIE Q
55 Q
56MSGSVRRA ;Removal acknowledgement
57 N SDWLX,SDWLNM,SDWLIFTN,SDWLSTN,SDWLINST,DIE,DA,DR,XMY,XMSUB,XMTEXT,XMDUZ,XMMG
58 D RMSG
59 S DIE=409.35,DA=$P(SDWLMSG(1,0),U,3)
60 D GETS^DIQ(DIE,DA_",",".01;6",,"TMP")
61 Q:'$D(TMP(DIE,DA_",",.01)) ;Already removed
62 S SDWLNM=TMP(DIE,DA_",",.01) ;Patient name
63 S SDWLIFTN=TMP(DIE,DA_",",6) ;Receiving facility's request id
64 S SDWLSTN=$$GET1^DIQ(DIE,DA,1)
65 S SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D")
66 S DA=$P(SDWLMSG(1,0),U,3),DIK="^SDWL(409.35," D ^DIK
67 S XMY("G.SDWL-TRANSFER-ADMIN")="",XMSUB="INTER-FACILITY XFER: Removal of cancelled request",XMTEXT="SDWLX(",XMDUZ="POSTMASTER"
68 S SDWLX(0)=1,SDWLX(SDWLX(0),0)="The request to transfer "_SDWLNM_" to "_$$GET1^DIQ(4,SDWLINST,.01)_" ("_SDWLSTN_") has been recalled."
69 D COL80(.SDWLX)
70 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0),0)="",SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0),0)="The details have been removed from the system."
71 D ^XMD
72 I $G(XMMG)["Error" S SDWLMSG(0)=1,SDWLMSG(1,0)="Message aborted with the following error: "_XMMG D ERR(.SDWLMSG)
73 Q
74MSGSVRAC ;Acceptance notification.
75 N TMP,DIE,DA,DR,XMY,XMSUB,XMTEXT,XMDUZ,XMMG,SDWLDUZ,SDWLINST,SDWLNM,SDWLX,SDWLTXT,SDWLMSG
76 D RMSG
77 S DIE=409.35,DA=$P(SDWLMSG(1,0),U,3),DR="3///A;7///"_$P(SDWLMSG(2,0),U,3) D ^DIE
78 S SDWLSTN=$$GET1^DIQ(409.35,DA,1),SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D"),SDWLNM=$$GET1^DIQ(409.35,DA,.01)
79 D GETS^DIQ(409.35,DA,".01;4","I","TMP")
80 S SDWLDUZ=TMP(409.35,DA_",",4,"I"),DIE("NO^")="NO EDITING" ;Disposition the EWL entry.
81 S DIE="^SDWL(409.3,",DA=TMP(409.35,DA_",",.01,"I"),DR="19////^S X=DT;20////^S X=SDWLDUZ;21////^S X=""TR"";23////^S X=""C""" D ^DIE
82 S XMY("G.SDWL-TRANSFER-ADMIN")="",XMSUB="INTER-FACILITY XFER: Request accepted",XMTEXT="SDWLX(",XMDUZ="POSTMASTER"
83 S SDWLX(0)=1,SDWLX(SDWLX(0),0)="The request to transfer "_SDWLNM_" to "_$$GET1^DIQ(4,SDWLINST,.01)_" ("_SDWLSTN_") has been accepted by the receiving facility."
84 D COL80(.SDWLX)
85 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0),0)="",SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0),0)="The status has been updated and can be viewed in SDWL TRANSFER REQUEST"
86 D ^XMD
87 I $G(XMMG)["Error" S SDWLMSG(0)=1,SDWLMSG(1,0)="Message aborted with the following error: "_XMMG D ERR(.SDWLMSG)
88 Q
89MSGSVRRJ ;Rejection notification.
90 N DIE,DA,DR,SDWLX,SDWLINST,SDWLNM,SDWLTXT,SDWLMSG,XMY,XMSUB,XMTEXT,XMDUZ,XMMG
91 D RMSG
92 S DIE=409.35,DA=$P(SDWLMSG(1,0),U,3),SDWLSTN=$$GET1^DIQ(DIE,DA,1),SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D"),SDWLNM=$$GET1^DIQ(DIE,DA,.01)
93 S DR="3///X" D ^DIE
94 S XMY("G.SDWL-TRANSFER-ADMIN")=""
95 S XMSUB="INTER-FACILITY XFER: Request declined",XMTEXT="SDWLX(",XMDUZ="POSTMASTER"
96 S SDWLX(0)=1,SDWLX(SDWLX(0),0)="The request to transfer "_SDWLNM_" to "_$$GET1^DIQ(4,SDWLINST,.01)_" ("_SDWLSTN_") has been rejected by the receiving facility."
97 D COL80(.SDWLX)
98 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0),0)="",SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0),0)="The status has been updated and can be viewed in, SDWL TRANSFER REQUEST"
99 D ^XMD
100 I $G(XMMG)["Error" S SDWLMSG(0)=1,SDWLMSG(1,0)="Message aborted with the following error: "_XMMG D ERR(.SDWLMSG)
101 Q
102MSGSVRSC ;Status changed
103 N SDWLDIS,SDWLDUZ,SDWLIFTN,SDWLINST,SDWLMSG,SDWLST35,SDWLST36,SDWLSTN,SDWLX
104 D RMSG
105 S SDWLST36=$P(SDWLMSG(2,0),U,3),SDWLST35=$S(SDWLST36="P":"R",SDWLST36="C":"A",SDWLST36="R":"X",1:SDWLST36)
106 I SDWLST36="T" ;?
107 S DIE=409.35,(SDWLIFTN,DA)=$P(SDWLMSG(1,0),U,3),DR="3///"_SDWLST35_";7///"_$P(SDWLMSG(3,0),U,3) D ^DIE
108 S SDWLSTN=$$GET1^DIQ(409.35,SDWLIFTN,1),SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D"),SDWLNM=$$GET1^DIQ(409.35,SDWLIFTN,.01)
109 S SDWLDIS=$P(SDWLMSG(5,0),U,3)
110 S XMY("G.SDWL-TRANSFER-ADMIN")=""
111 S XMSUB="INTER-FACILITY XFER: Transfer status change",XMTEXT="SDWLX(",XMDUZ="POSTMASTER"
112 S SDWLX(0)=1,SDWLX(SDWLX(0),0)="The the status of the transfer of "_SDWLNM_" to "_$$GET1^DIQ(4,SDWLINST,.01)_" ("_SDWLSTN_") has changed."
113 S SDWLX(0)=2,SDWLX(SDWLX(0),0)="It is now "_$$GET1^DIQ(409.35,SDWLIFTN,3)_"."
114 D COL80(.SDWLX)
115 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0),0)="",SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0),0)="The status has been updated and can be viewed in, SDWL TRANSFER REQUEST"
116 D ^XMD
117 I $G(XMMG)["Error" S SDWLMSG(0)=1,SDWLMSG(1,0)="Message aborted with the following error: "_XMMG D ERR(.SDWLMSG)
118 Q:SDWLST35'="A"
119 ; Close EWL entry
120 S DIE="^SDWL(409.3,"
121 S DA=$$GET1^DIQ(409.35,SDWLIFTN,.01,"I"),SDWLDUZ=$$GET1^DIQ(409.35,SDWLIFTN,4,"I")
122 S DR="21////^S X=SDWLDIS;19////^S X=DT;20////^S X=SDWLDUZ;23////^S X=""C"""
123 D ^DIE
124 Q
125COL80(SDWLX) ;Stop lines going over 80 columns.
126 N SDWLI,COLS
127 S COLS=79
128 F SDWLI=1:1 Q:'$D(SDWLX(SDWLI)) D:$L(SDWLX(SDWLI,0))>COLS
129 .N SDWLF,SDWLF0,SDWLX0
130 .S SDWLF=0
131 .F S SDWLF=$F(SDWLX(SDWLI,0)," ",SDWLF) Q:SDWLF>COLS!'SDWLF S SDWLF0=SDWLF
132 .S:'$D(SDWLX(SDWLI+1)) SDWLX(0)=SDWLI+1
133 .S SDWLX0=$G(SDWLX(SDWLI+1,0))
134 .S SDWLX(SDWLI+1,0)=$E(SDWLX(SDWLI,0),SDWLF0,$L(SDWLX(SDWLI,0)))
135 .S:SDWLX0'="" SDWLX(SDWLI+1,0)=SDWLX(SDWLI+1,0)_" "_SDWLX0
136 .S SDWLX(SDWLI,0)=$E(SDWLX(SDWLI,0),1,SDWLF0-2)
137 .Q
138 Q
139RMSG ;load message into local array
140 M SDWLMSG=^XMB(3.9,XQMSG,2)
141 Q
142ERR(SDWLX) ;send error message to developer
143 N XMSUB,XMY,XMTEXT,XMDUZ,SDWLMSG,SDWLI
144 S XMY("G.SDWL-TRANSFER-ADMIN")="",XMSUB="Error from S.SDWL-XFER Server",XMTEXT="SDWLMSG(",XMDUZ="POSTMASTER"
145 S SDWLMSG(1,0)=" Forum Message #: "_XQMSG
146 S SDWLMSG(2,0)="Sender's Mail Address: "_XQSND
147 S SDWLMSG(3,0)=" Subject: "_XQSUB
148 S SDWLMSG(4,0)="",SDWLMSG(0)=4
149 F SDWLI=1:1:SDWLX(0) S SDWLMSG(0)=SDWLMSG(0)+1,SDWLMSG(SDWLMSG(0),0)=SDWLX(SDWLI,0)
150 D ^XMD
151 Q
152GETTN(SDWLINFO) ;Get transfer id.
153 N LAST,DIR,Y
154 S LAST=$O(SDWLINFO(":"),-1)
155 I 'LAST S DIR(0)="Y",DIR("A")="No entries. OK",DIR("B")="YES" D ^DIR Q 0
156 I LAST=1 S Y=1 ;If there is only one, don't ask.
157 E S DIR(0)="L^1:"_LAST,DIR("A")="Which entry?" D ^DIR
158 Q $G(SDWLINFO(+Y,1),0)
159EXMNU Q
160ENMNU Q
Note: See TracBrowser for help on using the repository browser.