SDWLIFT ;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
;;5.3;Scheduling;**415,446**;AUG 13 1993;Build 77
;
;******************************************************************
; CHANGE LOG
;
; DATE PATCH DESCRIPTION
; ---- ----- -----------
; 12/12/05 SD*5.3*446 Enhancements
;
MSGSVR ;xfer message server
;variables provided by server XQ*
;XQSOP : server option name
;XQMSG : server request message number
;XQSND : DUZ of sender
;XQSUB : subject
;SDMSG : local array of message lines
N SDWLMSG
D
.I $E(XQSUB,1,3)="RE:" Q ;quit for messages that are replies to original
.I XQSUB="SDWL TRANSFER REQUEST" D MSGSVRRQ^SDWLIFT0 Q ;transfer request
.I XQSUB="SDWL TRANSFER ACKNOWLEDGEMENT" D MSGSVRAR Q ;acknowledge request from receiving facility
.I XQSUB="SDWL TRANSFER REMOVAL REQUEST" D MSGSVRRM^SDWLIFT0 Q ;remove request
.I XQSUB="SDWL TRANSFER REMOVAL REQUEST ACKNOWLEDGEMENT" D MSGSVRRA Q ;remove request acknowledgement
.I XQSUB="SDWL TRANSFER ACCEPTANCE" D MSGSVRAC Q ;transaction accepted.
.I XQSUB="SDWL TRANSFER REJECTION" D MSGSVRRJ Q ;transaction rejected.
.I XQSUB="SDWL TRANSFER STATUS CHANGE" D MSGSVRSC Q ;status changed
.S SDWLMSG(1,0)="Message received by S.SDWL-XFER-SERVER option has an unrecognized message subject"
.D ERR(.SDWLMSG)
.Q
K XQMSG,XQSND,XQSUB
Q
MSGSVRAR ;Acknowledge request
N DIE,DA,DR,DIC,D,X,SDWLX,SDWLI,SDWLMSG,TMP,SDWLDA,SDWLIST
D RMSG
S SDWLI=$O(SDWLMSG(1),-1) ;There's stuff between 0 and 1
F S SDWLI=$O(SDWLMSG(SDWLI)) Q:'SDWLI S SDWLX($P(SDWLMSG(SDWLI,0),U))=$P(SDWLMSG(SDWLI,0),U,3)
S DIC(0)="",DIC="^SDWL(409.35,",X="`"_SDWLX(.5) D ^DIC
;If the transfer entry does not exist or does not belong to this request, send a removal request back
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
; if this EWL entry is the subject of a transfer, close it and send message back to requesting facility
S SDWLIST="R",SDWLDA=$P(Y,U,2)
I $D(^SDWL(409.36,"C",SDWLDA)) S SDWLIST="C" D
.N DA,SDWLDUZ
.S DIE="^SDWL(409.3,"
.S DA=SDWLDA,SDWLDUZ=$$GET1^DIQ(409.35,SDWLIFTN,4,"I")
.S DR="21////^S X=""TR"";19////^S X=DT;20////^S X=SDWLDUZ;23////^S X=""C"""
.D ^DIE
.S DIE="^SDWL(409.36,",DA=$O(^SDWL(409.36,"C",SDWLDA,""))
.S DR="1///""R"";2///"_$$GET1^DIQ(409.35,SDWLIFTN,1,"I") D ^DIE
.D SENDST^SDWLIFT6(DA)
.Q
;finally, set the transfer request file.
S DIE="^SDWL(409.35,",DA=SDWLX(.5),DR="3///"_SDWLIST_";6///"_SDWLX(6) D ^DIE Q
Q
MSGSVRRA ;Removal acknowledgement
N SDWLX,SDWLNM,SDWLIFTN,SDWLSTN,SDWLINST,DIE,DA,DR,XMY,XMSUB,XMTEXT,XMDUZ,XMMG
D RMSG
S DIE=409.35,DA=$P(SDWLMSG(1,0),U,3)
D GETS^DIQ(DIE,DA_",",".01;6",,"TMP")
Q:'$D(TMP(DIE,DA_",",.01)) ;Already removed
S SDWLNM=TMP(DIE,DA_",",.01) ;Patient name
S SDWLIFTN=TMP(DIE,DA_",",6) ;Receiving facility's request id
S SDWLSTN=$$GET1^DIQ(DIE,DA,1)
S SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D")
S DA=$P(SDWLMSG(1,0),U,3),DIK="^SDWL(409.35," D ^DIK
S XMY("G.SDWL-TRANSFER-ADMIN")="",XMSUB="INTER-FACILITY XFER: Removal of cancelled request",XMTEXT="SDWLX(",XMDUZ="POSTMASTER"
S SDWLX(0)=1,SDWLX(SDWLX(0),0)="The request to transfer "_SDWLNM_" to "_$$GET1^DIQ(4,SDWLINST,.01)_" ("_SDWLSTN_") has been recalled."
D COL80(.SDWLX)
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."
D ^XMD
I $G(XMMG)["Error" S SDWLMSG(0)=1,SDWLMSG(1,0)="Message aborted with the following error: "_XMMG D ERR(.SDWLMSG)
Q
MSGSVRAC ;Acceptance notification.
N TMP,DIE,DA,DR,XMY,XMSUB,XMTEXT,XMDUZ,XMMG,SDWLDUZ,SDWLINST,SDWLNM,SDWLX,SDWLTXT,SDWLMSG
D RMSG
S DIE=409.35,DA=$P(SDWLMSG(1,0),U,3),DR="3///A;7///"_$P(SDWLMSG(2,0),U,3) D ^DIE
S SDWLSTN=$$GET1^DIQ(409.35,DA,1),SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D"),SDWLNM=$$GET1^DIQ(409.35,DA,.01)
D GETS^DIQ(409.35,DA,".01;4","I","TMP")
S SDWLDUZ=TMP(409.35,DA_",",4,"I"),DIE("NO^")="NO EDITING" ;Disposition the EWL entry.
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
S XMY("G.SDWL-TRANSFER-ADMIN")="",XMSUB="INTER-FACILITY XFER: Request accepted",XMTEXT="SDWLX(",XMDUZ="POSTMASTER"
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."
D COL80(.SDWLX)
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"
D ^XMD
I $G(XMMG)["Error" S SDWLMSG(0)=1,SDWLMSG(1,0)="Message aborted with the following error: "_XMMG D ERR(.SDWLMSG)
Q
MSGSVRRJ ;Rejection notification.
N DIE,DA,DR,SDWLX,SDWLINST,SDWLNM,SDWLTXT,SDWLMSG,XMY,XMSUB,XMTEXT,XMDUZ,XMMG
D RMSG
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)
S DR="3///X" D ^DIE
S XMY("G.SDWL-TRANSFER-ADMIN")=""
S XMSUB="INTER-FACILITY XFER: Request declined",XMTEXT="SDWLX(",XMDUZ="POSTMASTER"
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."
D COL80(.SDWLX)
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"
D ^XMD
I $G(XMMG)["Error" S SDWLMSG(0)=1,SDWLMSG(1,0)="Message aborted with the following error: "_XMMG D ERR(.SDWLMSG)
Q
MSGSVRSC ;Status changed
N SDWLDIS,SDWLDUZ,SDWLIFTN,SDWLINST,SDWLMSG,SDWLST35,SDWLST36,SDWLSTN,SDWLX
D RMSG
S SDWLST36=$P(SDWLMSG(2,0),U,3),SDWLST35=$S(SDWLST36="P":"R",SDWLST36="C":"A",SDWLST36="R":"X",1:SDWLST36)
I SDWLST36="T" ;?
S DIE=409.35,(SDWLIFTN,DA)=$P(SDWLMSG(1,0),U,3),DR="3///"_SDWLST35_";7///"_$P(SDWLMSG(3,0),U,3) D ^DIE
S SDWLSTN=$$GET1^DIQ(409.35,SDWLIFTN,1),SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D"),SDWLNM=$$GET1^DIQ(409.35,SDWLIFTN,.01)
S SDWLDIS=$P(SDWLMSG(5,0),U,3)
S XMY("G.SDWL-TRANSFER-ADMIN")=""
S XMSUB="INTER-FACILITY XFER: Transfer status change",XMTEXT="SDWLX(",XMDUZ="POSTMASTER"
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."
S SDWLX(0)=2,SDWLX(SDWLX(0),0)="It is now "_$$GET1^DIQ(409.35,SDWLIFTN,3)_"."
D COL80(.SDWLX)
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"
D ^XMD
I $G(XMMG)["Error" S SDWLMSG(0)=1,SDWLMSG(1,0)="Message aborted with the following error: "_XMMG D ERR(.SDWLMSG)
Q:SDWLST35'="A"
; Close EWL entry
S DIE="^SDWL(409.3,"
S DA=$$GET1^DIQ(409.35,SDWLIFTN,.01,"I"),SDWLDUZ=$$GET1^DIQ(409.35,SDWLIFTN,4,"I")
S DR="21////^S X=SDWLDIS;19////^S X=DT;20////^S X=SDWLDUZ;23////^S X=""C"""
D ^DIE
Q
COL80(SDWLX) ;Stop lines going over 80 columns.
N SDWLI,COLS
S COLS=79
F SDWLI=1:1 Q:'$D(SDWLX(SDWLI)) D:$L(SDWLX(SDWLI,0))>COLS
.N SDWLF,SDWLF0,SDWLX0
.S SDWLF=0
.F S SDWLF=$F(SDWLX(SDWLI,0)," ",SDWLF) Q:SDWLF>COLS!'SDWLF S SDWLF0=SDWLF
.S:'$D(SDWLX(SDWLI+1)) SDWLX(0)=SDWLI+1
.S SDWLX0=$G(SDWLX(SDWLI+1,0))
.S SDWLX(SDWLI+1,0)=$E(SDWLX(SDWLI,0),SDWLF0,$L(SDWLX(SDWLI,0)))
.S:SDWLX0'="" SDWLX(SDWLI+1,0)=SDWLX(SDWLI+1,0)_" "_SDWLX0
.S SDWLX(SDWLI,0)=$E(SDWLX(SDWLI,0),1,SDWLF0-2)
.Q
Q
RMSG ;load message into local array
M SDWLMSG=^XMB(3.9,XQMSG,2)
Q
ERR(SDWLX) ;send error message to developer
N XMSUB,XMY,XMTEXT,XMDUZ,SDWLMSG,SDWLI
S XMY("G.SDWL-TRANSFER-ADMIN")="",XMSUB="Error from S.SDWL-XFER Server",XMTEXT="SDWLMSG(",XMDUZ="POSTMASTER"
S SDWLMSG(1,0)=" Forum Message #: "_XQMSG
S SDWLMSG(2,0)="Sender's Mail Address: "_XQSND
S SDWLMSG(3,0)=" Subject: "_XQSUB
S SDWLMSG(4,0)="",SDWLMSG(0)=4
F SDWLI=1:1:SDWLX(0) S SDWLMSG(0)=SDWLMSG(0)+1,SDWLMSG(SDWLMSG(0),0)=SDWLX(SDWLI,0)
D ^XMD
Q
GETTN(SDWLINFO) ;Get transfer id.
N LAST,DIR,Y
S LAST=$O(SDWLINFO(":"),-1)
I 'LAST S DIR(0)="Y",DIR("A")="No entries. OK",DIR("B")="YES" D ^DIR Q 0
I LAST=1 S Y=1 ;If there is only one, don't ask.
E S DIR(0)="L^1:"_LAST,DIR("A")="Which entry?" D ^DIR
Q $G(SDWLINFO(+Y,1),0)
EXMNU Q
ENMNU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLIFT 8684 printed Oct 16, 2024@19:03:08 Page 2
SDWLIFT ;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
+1 ;;5.3;Scheduling;**415,446**;AUG 13 1993;Build 77
+2 ;
+3 ;******************************************************************
+4 ; CHANGE LOG
+5 ;
+6 ; DATE PATCH DESCRIPTION
+7 ; ---- ----- -----------
+8 ; 12/12/05 SD*5.3*446 Enhancements
+9 ;
MSGSVR ;xfer message server
+1 ;variables provided by server XQ*
+2 ;XQSOP : server option name
+3 ;XQMSG : server request message number
+4 ;XQSND : DUZ of sender
+5 ;XQSUB : subject
+6 ;SDMSG : local array of message lines
+7 NEW SDWLMSG
+8 Begin DoDot:1
+9 ;quit for messages that are replies to original
IF $EXTRACT(XQSUB,1,3)="RE:"
QUIT
+10 ;transfer request
IF XQSUB="SDWL TRANSFER REQUEST"
DO MSGSVRRQ^SDWLIFT0
QUIT
+11 ;acknowledge request from receiving facility
IF XQSUB="SDWL TRANSFER ACKNOWLEDGEMENT"
DO MSGSVRAR
QUIT
+12 ;remove request
IF XQSUB="SDWL TRANSFER REMOVAL REQUEST"
DO MSGSVRRM^SDWLIFT0
QUIT
+13 ;remove request acknowledgement
IF XQSUB="SDWL TRANSFER REMOVAL REQUEST ACKNOWLEDGEMENT"
DO MSGSVRRA
QUIT
+14 ;transaction accepted.
IF XQSUB="SDWL TRANSFER ACCEPTANCE"
DO MSGSVRAC
QUIT
+15 ;transaction rejected.
IF XQSUB="SDWL TRANSFER REJECTION"
DO MSGSVRRJ
QUIT
+16 ;status changed
IF XQSUB="SDWL TRANSFER STATUS CHANGE"
DO MSGSVRSC
QUIT
+17 SET SDWLMSG(1,0)="Message received by S.SDWL-XFER-SERVER option has an unrecognized message subject"
+18 DO ERR(.SDWLMSG)
+19 QUIT
End DoDot:1
+20 KILL XQMSG,XQSND,XQSUB
+21 QUIT
MSGSVRAR ;Acknowledge request
+1 NEW DIE,DA,DR,DIC,D,X,SDWLX,SDWLI,SDWLMSG,TMP,SDWLDA,SDWLIST
+2 DO RMSG
+3 ;There's stuff between 0 and 1
SET SDWLI=$ORDER(SDWLMSG(1),-1)
+4 FOR
SET SDWLI=$ORDER(SDWLMSG(SDWLI))
if 'SDWLI
QUIT
SET SDWLX($PIECE(SDWLMSG(SDWLI,0),U))=$PIECE(SDWLMSG(SDWLI,0),U,3)
+5 SET DIC(0)=""
SET DIC="^SDWL(409.35,"
SET X="`"_SDWLX(.5)
DO ^DIC
+6 ;If the transfer entry does not exist or does not belong to this request, send a removal request back
+7 IF Y=-1!(SDWLX(2)'=$$GET1^DIQ(409.35,SDWLX(.5),2,"I"))
DO SEND^SDWLIFT4(SDWLX(6),$$GET1^DIQ(4,$$FIND1^DIC(4,"","X",SDWLX(1),"D"),60))
QUIT
+8 ; if this EWL entry is the subject of a transfer, close it and send message back to requesting facility
+9 SET SDWLIST="R"
SET SDWLDA=$PIECE(Y,U,2)
+10 IF $DATA(^SDWL(409.36,"C",SDWLDA))
SET SDWLIST="C"
Begin DoDot:1
+11 NEW DA,SDWLDUZ
+12 SET DIE="^SDWL(409.3,"
+13 SET DA=SDWLDA
SET SDWLDUZ=$$GET1^DIQ(409.35,SDWLIFTN,4,"I")
+14 SET DR="21////^S X=""TR"";19////^S X=DT;20////^S X=SDWLDUZ;23////^S X=""C"""
+15 DO ^DIE
+16 SET DIE="^SDWL(409.36,"
SET DA=$ORDER(^SDWL(409.36,"C",SDWLDA,""))
+17 SET DR="1///""R"";2///"_$$GET1^DIQ(409.35,SDWLIFTN,1,"I")
DO ^DIE
+18 DO SENDST^SDWLIFT6(DA)
+19 QUIT
End DoDot:1
+20 ;finally, set the transfer request file.
+21 SET DIE="^SDWL(409.35,"
SET DA=SDWLX(.5)
SET DR="3///"_SDWLIST_";6///"_SDWLX(6)
DO ^DIE
QUIT
+22 QUIT
MSGSVRRA ;Removal acknowledgement
+1 NEW SDWLX,SDWLNM,SDWLIFTN,SDWLSTN,SDWLINST,DIE,DA,DR,XMY,XMSUB,XMTEXT,XMDUZ,XMMG
+2 DO RMSG
+3 SET DIE=409.35
SET DA=$PIECE(SDWLMSG(1,0),U,3)
+4 DO GETS^DIQ(DIE,DA_",",".01;6",,"TMP")
+5 ;Already removed
if '$DATA(TMP(DIE,DA_",",.01))
QUIT
+6 ;Patient name
SET SDWLNM=TMP(DIE,DA_",",.01)
+7 ;Receiving facility's request id
SET SDWLIFTN=TMP(DIE,DA_",",6)
+8 SET SDWLSTN=$$GET1^DIQ(DIE,DA,1)
+9 SET SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D")
+10 SET DA=$PIECE(SDWLMSG(1,0),U,3)
SET DIK="^SDWL(409.35,"
DO ^DIK
+11 SET XMY("G.SDWL-TRANSFER-ADMIN")=""
SET XMSUB="INTER-FACILITY XFER: Removal of cancelled request"
SET XMTEXT="SDWLX("
SET XMDUZ="POSTMASTER"
+12 SET SDWLX(0)=1
SET SDWLX(SDWLX(0),0)="The request to transfer "_SDWLNM_" to "_$$GET1^DIQ(4,SDWLINST,.01)_" ("_SDWLSTN_") has been recalled."
+13 DO COL80(.SDWLX)
+14 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0),0)=""
SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0),0)="The details have been removed from the system."
+15 DO ^XMD
+16 IF $GET(XMMG)["Error"
SET SDWLMSG(0)=1
SET SDWLMSG(1,0)="Message aborted with the following error: "_XMMG
DO ERR(.SDWLMSG)
+17 QUIT
MSGSVRAC ;Acceptance notification.
+1 NEW TMP,DIE,DA,DR,XMY,XMSUB,XMTEXT,XMDUZ,XMMG,SDWLDUZ,SDWLINST,SDWLNM,SDWLX,SDWLTXT,SDWLMSG
+2 DO RMSG
+3 SET DIE=409.35
SET DA=$PIECE(SDWLMSG(1,0),U,3)
SET DR="3///A;7///"_$PIECE(SDWLMSG(2,0),U,3)
DO ^DIE
+4 SET SDWLSTN=$$GET1^DIQ(409.35,DA,1)
SET SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D")
SET SDWLNM=$$GET1^DIQ(409.35,DA,.01)
+5 DO GETS^DIQ(409.35,DA,".01;4","I","TMP")
+6 ;Disposition the EWL entry.
SET SDWLDUZ=TMP(409.35,DA_",",4,"I")
SET DIE("NO^")="NO EDITING"
+7 SET DIE="^SDWL(409.3,"
SET DA=TMP(409.35,DA_",",.01,"I")
SET DR="19////^S X=DT;20////^S X=SDWLDUZ;21////^S X=""TR"";23////^S X=""C"""
DO ^DIE
+8 SET XMY("G.SDWL-TRANSFER-ADMIN")=""
SET XMSUB="INTER-FACILITY XFER: Request accepted"
SET XMTEXT="SDWLX("
SET XMDUZ="POSTMASTER"
+9 SET SDWLX(0)=1
SET SDWLX(SDWLX(0),0)="The request to transfer "_SDWLNM_" to "_$$GET1^DIQ(4,SDWLINST,.01)_" ("_SDWLSTN_") has been accepted by the receiving facility."
+10 DO COL80(.SDWLX)
+11 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0),0)=""
SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0),0)="The status has been updated and can be viewed in SDWL TRANSFER REQUEST"
+12 DO ^XMD
+13 IF $GET(XMMG)["Error"
SET SDWLMSG(0)=1
SET SDWLMSG(1,0)="Message aborted with the following error: "_XMMG
DO ERR(.SDWLMSG)
+14 QUIT
MSGSVRRJ ;Rejection notification.
+1 NEW DIE,DA,DR,SDWLX,SDWLINST,SDWLNM,SDWLTXT,SDWLMSG,XMY,XMSUB,XMTEXT,XMDUZ,XMMG
+2 DO RMSG
+3 SET DIE=409.35
SET DA=$PIECE(SDWLMSG(1,0),U,3)
SET SDWLSTN=$$GET1^DIQ(DIE,DA,1)
SET SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D")
SET SDWLNM=$$GET1^DIQ(DIE,DA,.01)
+4 SET DR="3///X"
DO ^DIE
+5 SET XMY("G.SDWL-TRANSFER-ADMIN")=""
+6 SET XMSUB="INTER-FACILITY XFER: Request declined"
SET XMTEXT="SDWLX("
SET XMDUZ="POSTMASTER"
+7 SET SDWLX(0)=1
SET SDWLX(SDWLX(0),0)="The request to transfer "_SDWLNM_" to "_$$GET1^DIQ(4,SDWLINST,.01)_" ("_SDWLSTN_") has been rejected by the receiving facility."
+8 DO COL80(.SDWLX)
+9 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0),0)=""
SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0),0)="The status has been updated and can be viewed in, SDWL TRANSFER REQUEST"
+10 DO ^XMD
+11 IF $GET(XMMG)["Error"
SET SDWLMSG(0)=1
SET SDWLMSG(1,0)="Message aborted with the following error: "_XMMG
DO ERR(.SDWLMSG)
+12 QUIT
MSGSVRSC ;Status changed
+1 NEW SDWLDIS,SDWLDUZ,SDWLIFTN,SDWLINST,SDWLMSG,SDWLST35,SDWLST36,SDWLSTN,SDWLX
+2 DO RMSG
+3 SET SDWLST36=$PIECE(SDWLMSG(2,0),U,3)
SET SDWLST35=$SELECT(SDWLST36="P":"R",SDWLST36="C":"A",SDWLST36="R":"X",1:SDWLST36)
+4 ;?
IF SDWLST36="T"
+5 SET DIE=409.35
SET (SDWLIFTN,DA)=$PIECE(SDWLMSG(1,0),U,3)
SET DR="3///"_SDWLST35_";7///"_$PIECE(SDWLMSG(3,0),U,3)
DO ^DIE
+6 SET SDWLSTN=$$GET1^DIQ(409.35,SDWLIFTN,1)
SET SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D")
SET SDWLNM=$$GET1^DIQ(409.35,SDWLIFTN,.01)
+7 SET SDWLDIS=$PIECE(SDWLMSG(5,0),U,3)
+8 SET XMY("G.SDWL-TRANSFER-ADMIN")=""
+9 SET XMSUB="INTER-FACILITY XFER: Transfer status change"
SET XMTEXT="SDWLX("
SET XMDUZ="POSTMASTER"
+10 SET SDWLX(0)=1
SET SDWLX(SDWLX(0),0)="The the status of the transfer of "_SDWLNM_" to "_$$GET1^DIQ(4,SDWLINST,.01)_" ("_SDWLSTN_") has changed."
+11 SET SDWLX(0)=2
SET SDWLX(SDWLX(0),0)="It is now "_$$GET1^DIQ(409.35,SDWLIFTN,3)_"."
+12 DO COL80(.SDWLX)
+13 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0),0)=""
SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0),0)="The status has been updated and can be viewed in, SDWL TRANSFER REQUEST"
+14 DO ^XMD
+15 IF $GET(XMMG)["Error"
SET SDWLMSG(0)=1
SET SDWLMSG(1,0)="Message aborted with the following error: "_XMMG
DO ERR(.SDWLMSG)
+16 if SDWLST35'="A"
QUIT
+17 ; Close EWL entry
+18 SET DIE="^SDWL(409.3,"
+19 SET DA=$$GET1^DIQ(409.35,SDWLIFTN,.01,"I")
SET SDWLDUZ=$$GET1^DIQ(409.35,SDWLIFTN,4,"I")
+20 SET DR="21////^S X=SDWLDIS;19////^S X=DT;20////^S X=SDWLDUZ;23////^S X=""C"""
+21 DO ^DIE
+22 QUIT
COL80(SDWLX) ;Stop lines going over 80 columns.
+1 NEW SDWLI,COLS
+2 SET COLS=79
+3 FOR SDWLI=1:1
if '$DATA(SDWLX(SDWLI))
QUIT
if $LENGTH(SDWLX(SDWLI,0))>COLS
Begin DoDot:1
+4 NEW SDWLF,SDWLF0,SDWLX0
+5 SET SDWLF=0
+6 FOR
SET SDWLF=$FIND(SDWLX(SDWLI,0)," ",SDWLF)
if SDWLF>COLS!'SDWLF
QUIT
SET SDWLF0=SDWLF
+7 if '$DATA(SDWLX(SDWLI+1))
SET SDWLX(0)=SDWLI+1
+8 SET SDWLX0=$GET(SDWLX(SDWLI+1,0))
+9 SET SDWLX(SDWLI+1,0)=$EXTRACT(SDWLX(SDWLI,0),SDWLF0,$LENGTH(SDWLX(SDWLI,0)))
+10 if SDWLX0'=""
SET SDWLX(SDWLI+1,0)=SDWLX(SDWLI+1,0)_" "_SDWLX0
+11 SET SDWLX(SDWLI,0)=$EXTRACT(SDWLX(SDWLI,0),1,SDWLF0-2)
+12 QUIT
End DoDot:1
+13 QUIT
RMSG ;load message into local array
+1 MERGE SDWLMSG=^XMB(3.9,XQMSG,2)
+2 QUIT
ERR(SDWLX) ;send error message to developer
+1 NEW XMSUB,XMY,XMTEXT,XMDUZ,SDWLMSG,SDWLI
+2 SET XMY("G.SDWL-TRANSFER-ADMIN")=""
SET XMSUB="Error from S.SDWL-XFER Server"
SET XMTEXT="SDWLMSG("
SET XMDUZ="POSTMASTER"
+3 SET SDWLMSG(1,0)=" Forum Message #: "_XQMSG
+4 SET SDWLMSG(2,0)="Sender's Mail Address: "_XQSND
+5 SET SDWLMSG(3,0)=" Subject: "_XQSUB
+6 SET SDWLMSG(4,0)=""
SET SDWLMSG(0)=4
+7 FOR SDWLI=1:1:SDWLX(0)
SET SDWLMSG(0)=SDWLMSG(0)+1
SET SDWLMSG(SDWLMSG(0),0)=SDWLX(SDWLI,0)
+8 DO ^XMD
+9 QUIT
GETTN(SDWLINFO) ;Get transfer id.
+1 NEW LAST,DIR,Y
+2 SET LAST=$ORDER(SDWLINFO(":"),-1)
+3 IF 'LAST
SET DIR(0)="Y"
SET DIR("A")="No entries. OK"
SET DIR("B")="YES"
DO ^DIR
QUIT 0
+4 ;If there is only one, don't ask.
IF LAST=1
SET Y=1
+5 IF '$TEST
SET DIR(0)="L^1:"_LAST
SET DIR("A")="Which entry?"
DO ^DIR
+6 QUIT $GET(SDWLINFO(+Y,1),0)
EXMNU QUIT
ENMNU QUIT
