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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLIFT0 4672 printed Oct 16, 2024@19:03:09 Page 2
SDWLIFT0 ;IOFO BAY PINES/OG - INTER-FACILITY TRANSFER: CONTROL REQUESTS; ; Compiled September 28, 2006 16:56:45
+1 ;;5.3;Scheduling;**415,446**;AUG 13 1993;Build 77
+2 ;
+3 ;******************************************************************
+4 ; CHANGE LOG
+5 ;
+6 ; DATE PATCH DESCRIPTION
+7 ; ---- ----- -----------
+8 ; 04/17/2006 SD*5.3*446 Add status on receipt
+9 ;
MSGSVRRQ ;handle transfer request
+1 NEW DIC,DIE,DA,DR,DO,X,Y,%,XMY,XMSUB,XMTEXT,XMDUZ,XMMG,SDWLI,SDWLCI,SDWLI0,SDWLCOMM,SDWLMSG,SDWLRIN,SDWLIFTN,SDWLNM,SDWLDTM
+2 DO RMSG^SDWLIFT
+3 SET SDWLI=1
SET DIC="^SDWL(409.36,"
SET DIC(0)=""
SET (SDWLNM,X)=$PIECE(SDWLMSG(SDWLI,0),U,3)
+4 DO FILE^DICN
+5 IF Y<0
SET SDWLMSG(1,0)="Error creating new request: "_SDWLMSG(1,0)
DO ERR^SDWLIFT(.SDWLMSG)
QUIT
+6 SET DA=+Y
SET DR=""
SET (SDWLCI,SDWLI0)=0
+7 FOR
SET SDWLI=$ORDER(SDWLMSG(SDWLI))
if 'SDWLI
QUIT
Begin DoDot:1
+8 ;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.
+9 IF $PIECE(SDWLMSG(SDWLI,0),U)=.4
SET SDWLCI=SDWLCI+1
SET SDWLCOMM(SDWLCI)=$PIECE(SDWLMSG(SDWLI,0),U,3)
QUIT
+10 ;Transmission Date/Time: not written to #409.36, just returned for verification
IF $PIECE(SDWLMSG(SDWLI,0),U)=2
SET SDWLDTM=$PIECE(SDWLMSG(SDWLI,0),U,3)
QUIT
+11 SET SDWLI0=SDWLI0+1
SET $PIECE(DR,";",SDWLI0)=$PIECE(SDWLMSG(SDWLI,0),U)_"///"_$PIECE(SDWLMSG(SDWLI,0),U,3)
+12 ;Requesting facility
IF $PIECE(SDWLMSG(SDWLI,0),U)=.1
SET SDWLSTN=$PIECE(SDWLMSG(SDWLI,0),U,3)
SET SDWLRIN=$$FIND1^DIC(4,"","X",SDWLSTN,"D")
+13 ;Requesting facility's transfer ID
IF $PIECE(SDWLMSG(SDWLI,0),U)=.5
SET SDWLIFTN=$PIECE(SDWLMSG(SDWLI,0),U,3)
+14 QUIT
End DoDot:1
+15 DO NOW^%DTC
+16 ; 446 ; OG ; added status.
SET DR=DR_";.2///"_%_";1///P"
SET DIE=DIC
DO ^DIE
+17 SET DA(1)=DA
SET DIC=DIC_DA(1)_",""COMM"","
SET SDWLI=0
+18 FOR
SET SDWLI=$ORDER(SDWLCOMM(SDWLI))
if 'SDWLI
QUIT
SET X=SDWLCOMM(SDWLI)
KILL DO
DO FILE^DICN
+19 ;send acknowledgement message back reporting success or failure
+20 SET XMY("S.SDWL-XFER-SERVER@"_$$GET1^DIQ(4,SDWLRIN,60))=""
SET XMSUB="SDWL TRANSFER ACKNOWLEDGEMENT"
SET XMTEXT="SDWLX("
SET XMDUZ="POSTMASTER"
+21 SET SDWLI=1
SET SDWLX(SDWLI)=".5"_U_"SENDING FACILITY TRANSFER ID"_U_SDWLIFTN
+22 SET SDWLI=SDWLI+1
SET SDWLX(SDWLI)=".01"_U_"NAME"_U_SDWLNM
+23 SET SDWLI=SDWLI+1
SET SDWLX(SDWLI)=1_U_"STATION NUMBER"_U_$PIECE($$SITE^VASITE(),U,3)
+24 SET SDWLI=SDWLI+1
SET SDWLX(SDWLI)=2_U_"TRANSMISSION DATE/TIME"_U_SDWLDTM
+25 SET SDWLI=SDWLI+1
SET SDWLX(SDWLI)=6_U_"RECEIVING FACILITY TRANSFER ID"_U_DA
+26 DO ^XMD
+27 KILL XMY,SDWLX,SDWLMSG
+28 IF $GET(XMMG)["Error"
SET SDWLMSG(0)=1
SET SDWLMSG(1,0)="Message aborted with the following error: "_XMMG
DO ERR^SDWLIFT(.SDWLMSG)
QUIT
+29 SET XMY("G.SDWL-TRANSFER-ADMIN")=""
SET XMSUB="INTER-FACILITY XFER: New request"
SET XMTEXT="SDWLX("
SET XMDUZ="POSTMASTER"
+30 SET SDWLX(0)=1
SET SDWLX(SDWLX(0),0)="A request has arrived to transfer "_SDWLNM_" from "_$$GET1^DIQ(4,SDWLRIN,.01)_" ("_SDWLSTN_")."
+31 if $LENGTH(SDWLX(SDWLX(0),0))>80
DO COL80^SDWLIFT(.SDWLX)
+32 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0),0)=""
SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0),0)="Details available at menu option, SDWL TRANSFER ACCEPT"
+33 DO ^XMD
+34 IF $GET(XMMG)["Error"
SET SDWLMSG(0)=1
SET SDWLMSG(1,0)="Message aborted with the following error: "_XMMG
DO ERR^SDWLIFT(.SDWLMSG)
+35 QUIT
MSGSVRRM ;remove request
+1 NEW DIE,DA,DR,DIK,DIC,D,X,XMY,XMSUB,XMTEXT,XMDUZ,XMMG,TMP,SDWLNM,SDWLIFTN,SDWLINST,SDWLSTN,SDWLDMN,SDWLX,SDWLMSG
+2 DO RMSG^SDWLIFT
+3 SET DIE=409.36
SET DA=$PIECE(SDWLMSG(1,0),U,3)
+4 DO GETS^DIQ(DIE,DA_",",".01;.5",,"TMP")
+5 ;Patient name
SET SDWLNM=TMP(DIE,DA_",",.01)
+6 ;Sending facility's request id
SET SDWLIFTN=TMP(DIE,DA_",",.5)
+7 ;Requesting station number
SET SDWLSTN=$$GET1^DIQ(DIE,DA,.1)
+8 SET SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D")
SET SDWLDMN=$$GET1^DIQ(4,SDWLINST,60)
+9 SET DIK="^SDWL(409.36,"
DO ^DIK
+10 SET XMY("S.SDWL-XFER-SERVER@"_SDWLDMN)=""
SET XMSUB="SDWL TRANSFER REMOVAL REQUEST ACKNOWLEDGEMENT"
SET XMTEXT="SDWLX("
SET XMDUZ="POSTMASTER"
+11 SET SDWLX(1,0)=".5"_U_"SENDING FACILITY TRANSFER ID"_U_SDWLIFTN
+12 SET SDWLX(0)=1
+13 DO ^XMD
+14 IF $GET(XMMG)["Error"
SET SDWLMSG(0)=1
SET SDWLMSG(1,0)="Message aborted with the following error: "_XMMG
DO ERR^SDWLIFT(.SDWLMSG)
+15 KILL XMY,SDWLMSG,SDWLX
+16 SET XMY("G.SDWL-TRANSFER-ADMIN")=""
SET XMSUB="INTER-FACILITY XFER: Removal of request"
SET XMTEXT="SDWLX("
SET XMDUZ="POSTMASTER"
+17 SET SDWLX(0)=1
SET SDWLX(SDWLX(0),0)="The request to transfer "_SDWLNM_" from "_$$GET1^DIQ(4,SDWLINST,.01)_" ("_SDWLSTN_") has been recalled."
+18 if $LENGTH(SDWLX(SDWLX(0),0))>80
DO COL80^SDWLIFT(.SDWLX)
+19 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."
+20 DO ^XMD
+21 IF $GET(XMMG)["Error"
SET SDWLMSG(0)=1
SET SDWLMSG(1,0)="Message aborted with the following error: "_XMMG
DO ERR^SDWLIFT(.SDWLMSG)
+22 QUIT
