70 lines
4.5 KiB
Mathematica
70 lines
4.5 KiB
Mathematica
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
|