source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLIFT0.m@ 1780

SDWLIFT0 ;IOFO BAY PINES/OG - INTER-FACILITY TRANSFER: CONTROL REQUESTS;  ; Compiled September 28, 2006 16:56:45

 ;;5.3;Scheduling;**415,446**;AUG 13 1993;Build 77

 ;

 ;******************************************************************

 ;                             CHANGE LOG

 ;

 ;   DATE                        PATCH                   DESCRIPTION

 ;   ----                        -----                   -----------

 ;   04/17/2006                  SD*5.3*446              Add status on receipt

 ;

MSGSVRRQ ;handle transfer request

 N DIC,DIE,DA,DR,DO,X,Y,%,XMY,XMSUB,XMTEXT,XMDUZ,XMMG,SDWLI,SDWLCI,SDWLI0,SDWLCOMM,SDWLMSG,SDWLRIN,SDWLIFTN,SDWLNM,SDWLDTM

 D RMSG^SDWLIFT

 S SDWLI=1,DIC="^SDWL(409.36,",DIC(0)="",(SDWLNM,X)=$P(SDWLMSG(SDWLI,0),U,3)

 D FILE^DICN

 I Y<0 S SDWLMSG(1,0)="Error creating new request: "_SDWLMSG(1,0) D ERR^SDWLIFT(.SDWLMSG) Q

 S DA=+Y,DR="",(SDWLCI,SDWLI0)=0

 F  S SDWLI=$O(SDWLMSG(SDWLI)) Q:'SDWLI  D

 .;I $P(SDWLMSG(SDWLI,0),U)=.361 S X=$P(SDWLMSG(SDWLI,0),U,3),DIC=8 D ^DIC S SDWLI0=SDWLI0+1,$P(DR,";",SDWLI0)=".361///"_$S(Y=-1:"",1:+Y) Q  ; Primary eligibility code. Expansion transmitted, get IEN.

 .I $P(SDWLMSG(SDWLI,0),U)=.4 S SDWLCI=SDWLCI+1,SDWLCOMM(SDWLCI)=$P(SDWLMSG(SDWLI,0),U,3) Q

 .I $P(SDWLMSG(SDWLI,0),U)=2 S SDWLDTM=$P(SDWLMSG(SDWLI,0),U,3) Q  ;Transmission Date/Time: not written to #409.36, just returned for verification

 .S SDWLI0=SDWLI0+1,$P(DR,";",SDWLI0)=$P(SDWLMSG(SDWLI,0),U)_"///"_$P(SDWLMSG(SDWLI,0),U,3)

 .I $P(SDWLMSG(SDWLI,0),U)=.1 S SDWLSTN=$P(SDWLMSG(SDWLI,0),U,3),SDWLRIN=$$FIND1^DIC(4,"","X",SDWLSTN,"D")  ;Requesting facility

 .I $P(SDWLMSG(SDWLI,0),U)=.5 S SDWLIFTN=$P(SDWLMSG(SDWLI,0),U,3)  ;Requesting facility's transfer ID

 .Q

 D NOW^%DTC

 S DR=DR_";.2///"_%_";1///P",DIE=DIC D ^DIE  ; 446 ; OG ; added status.

 S DA(1)=DA,DIC=DIC_DA(1)_",""COMM"",",SDWLI=0

 F  S SDWLI=$O(SDWLCOMM(SDWLI)) Q:'SDWLI  S X=SDWLCOMM(SDWLI) K DO D FILE^DICN

 ;send acknowledgement message back reporting success or failure

 S XMY("S.SDWL-XFER-SERVER@"_$$GET1^DIQ(4,SDWLRIN,60))="",XMSUB="SDWL TRANSFER ACKNOWLEDGEMENT",XMTEXT="SDWLX(",XMDUZ="POSTMASTER"

 S SDWLI=1,SDWLX(SDWLI)=".5"_U_"SENDING FACILITY TRANSFER ID"_U_SDWLIFTN

 S SDWLI=SDWLI+1,SDWLX(SDWLI)=".01"_U_"NAME"_U_SDWLNM

 S SDWLI=SDWLI+1,SDWLX(SDWLI)=1_U_"STATION NUMBER"_U_$P($$SITE^VASITE(),U,3)

 S SDWLI=SDWLI+1,SDWLX(SDWLI)=2_U_"TRANSMISSION DATE/TIME"_U_SDWLDTM

 S SDWLI=SDWLI+1,SDWLX(SDWLI)=6_U_"RECEIVING FACILITY TRANSFER ID"_U_DA

 D ^XMD

 K XMY,SDWLX,SDWLMSG

 I $G(XMMG)["Error" S SDWLMSG(0)=1,SDWLMSG(1,0)="Message aborted with the following error: "_XMMG D ERR^SDWLIFT(.SDWLMSG) Q

 S XMY("G.SDWL-TRANSFER-ADMIN")="",XMSUB="INTER-FACILITY XFER: New request",XMTEXT="SDWLX(",XMDUZ="POSTMASTER"

 S SDWLX(0)=1,SDWLX(SDWLX(0),0)="A request has arrived to transfer "_SDWLNM_" from "_$$GET1^DIQ(4,SDWLRIN,.01)_" ("_SDWLSTN_")."

 D:$L(SDWLX(SDWLX(0),0))>80 COL80^SDWLIFT(.SDWLX)

 S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0),0)="",SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0),0)="Details available at menu option, SDWL TRANSFER ACCEPT"

 D ^XMD

 I $G(XMMG)["Error" S SDWLMSG(0)=1,SDWLMSG(1,0)="Message aborted with the following error: "_XMMG D ERR^SDWLIFT(.SDWLMSG)

 Q

MSGSVRRM ;remove request

 N DIE,DA,DR,DIK,DIC,D,X,XMY,XMSUB,XMTEXT,XMDUZ,XMMG,TMP,SDWLNM,SDWLIFTN,SDWLINST,SDWLSTN,SDWLDMN,SDWLX,SDWLMSG

 D RMSG^SDWLIFT

 S DIE=409.36,DA=$P(SDWLMSG(1,0),U,3)

 D GETS^DIQ(DIE,DA_",",".01;.5",,"TMP")

 S SDWLNM=TMP(DIE,DA_",",.01)  ;Patient name

 S SDWLIFTN=TMP(DIE,DA_",",.5)  ;Sending facility's request id

 S SDWLSTN=$$GET1^DIQ(DIE,DA,.1)  ;Requesting station number

 S SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D"),SDWLDMN=$$GET1^DIQ(4,SDWLINST,60)

 S DIK="^SDWL(409.36," D ^DIK

 S XMY("S.SDWL-XFER-SERVER@"_SDWLDMN)="",XMSUB="SDWL TRANSFER REMOVAL REQUEST ACKNOWLEDGEMENT",XMTEXT="SDWLX(",XMDUZ="POSTMASTER"

 S SDWLX(1,0)=".5"_U_"SENDING FACILITY TRANSFER ID"_U_SDWLIFTN

 S SDWLX(0)=1

 D ^XMD

 I $G(XMMG)["Error" S SDWLMSG(0)=1,SDWLMSG(1,0)="Message aborted with the following error: "_XMMG D ERR^SDWLIFT(.SDWLMSG)

 K XMY,SDWLMSG,SDWLX

 S XMY("G.SDWL-TRANSFER-ADMIN")="",XMSUB="INTER-FACILITY XFER: Removal of request",XMTEXT="SDWLX(",XMDUZ="POSTMASTER"

 S SDWLX(0)=1,SDWLX(SDWLX(0),0)="The request to transfer "_SDWLNM_" from "_$$GET1^DIQ(4,SDWLINST,.01)_" ("_SDWLSTN_") has been recalled."

 D:$L(SDWLX(SDWLX(0),0))>80 COL80^SDWLIFT(.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^SDWLIFT(.SDWLMSG)

 Q