Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDWLIFT

SDWLIFT.m

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