SDWLIFT4 ;IOFO BAY PINES/OG - INTER-FACILITY TRANSFER: REMOVE TRANSFER DETAILS ; Compiled March 23, 2005 11:22:00
;;5.3;Scheduling;**415**;AUG 13 1993
;
;
;******************************************************************
; CHANGE LOG
;
; DATE PATCH DESCRIPTION
; ---- ----- -----------
;
;
Q
EN ; INITIALIZE VARIABLES FOR REMOVE
N SDWLINFO
D GETDATA^SDWLIFT5(.SDWLINFO,0)
S SDWLIFTN=$$GETTN^SDWLIFT(.SDWLINFO)
S VALMBCK="R"
Q:'SDWLIFTN
D EN^VALM("SDWL TRANSFER REQ REMV")
D INIT^SDWLIFT1(0)
S VALMBCK="R"
Q
REMOVE ;
N X,DIC,DIK,DA,DR,Y
S X="`"_SDWLIFTN,DIC=409.35,DIC(0)="Z" D ^DIC
I $P(Y(0),U,4)="R" D REMREQ
E S DA=SDWLIFTN,DIK="^SDWL(409.35," D ^DIK
K ^TMP("SDWLIFT",$J,"EP")
Q
REMREQ ; send removal request to SDWL-XFER-SERVER
N SDWLRIN,DIE,DA,DR
S SDWLRIN=$$GET1^DIQ(409.35,SDWLIFTN,6)
D SEND(SDWLRIN,$$GET1^DIQ(4,$$FIND1^DIC(4,"","X",$$GET1^DIQ(409.35,SDWLIFTN,1,"I"),"D"),60))
S DIE=409.35,DA=SDWLIFTN,DR="3///C" D ^DIE
Q
SEND(SDWLRIN,SDWLDMN) ;
N XMSUB,XMY,XMTEXT,XMDUZ,SDWLX
S XMSUB="SDWL TRANSFER REMOVAL REQUEST"
S XMY("S.SDWL-XFER-SERVER@"_SDWLDMN)=""
S XMTEXT="SDWLX("
S XMDUZ="POSTMASTER"
S SDWLX(1,0)="6"_U_"RECEIVING FACILITY TRANSFER ID"_U_SDWLRIN
S SDWLX(0)=1
D ^XMD
Q
EXIT ; Tidy up
K SDWLIFTN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLIFT4 1466 printed Dec 13, 2024@03:02:50 Page 2
SDWLIFT4 ;IOFO BAY PINES/OG - INTER-FACILITY TRANSFER: REMOVE TRANSFER DETAILS ; Compiled March 23, 2005 11:22:00
+1 ;;5.3;Scheduling;**415**;AUG 13 1993
+2 ;
+3 ;
+4 ;******************************************************************
+5 ; CHANGE LOG
+6 ;
+7 ; DATE PATCH DESCRIPTION
+8 ; ---- ----- -----------
+9 ;
+10 ;
+11 QUIT
EN ; INITIALIZE VARIABLES FOR REMOVE
+1 NEW SDWLINFO
+2 DO GETDATA^SDWLIFT5(.SDWLINFO,0)
+3 SET SDWLIFTN=$$GETTN^SDWLIFT(.SDWLINFO)
+4 SET VALMBCK="R"
+5 if 'SDWLIFTN
QUIT
+6 DO EN^VALM("SDWL TRANSFER REQ REMV")
+7 DO INIT^SDWLIFT1(0)
+8 SET VALMBCK="R"
+9 QUIT
REMOVE ;
+1 NEW X,DIC,DIK,DA,DR,Y
+2 SET X="`"_SDWLIFTN
SET DIC=409.35
SET DIC(0)="Z"
DO ^DIC
+3 IF $PIECE(Y(0),U,4)="R"
DO REMREQ
+4 IF '$TEST
SET DA=SDWLIFTN
SET DIK="^SDWL(409.35,"
DO ^DIK
+5 KILL ^TMP("SDWLIFT",$JOB,"EP")
+6 QUIT
REMREQ ; send removal request to SDWL-XFER-SERVER
+1 NEW SDWLRIN,DIE,DA,DR
+2 SET SDWLRIN=$$GET1^DIQ(409.35,SDWLIFTN,6)
+3 DO SEND(SDWLRIN,$$GET1^DIQ(4,$$FIND1^DIC(4,"","X",$$GET1^DIQ(409.35,SDWLIFTN,1,"I"),"D"),60))
+4 SET DIE=409.35
SET DA=SDWLIFTN
SET DR="3///C"
DO ^DIE
+5 QUIT
SEND(SDWLRIN,SDWLDMN) ;
+1 NEW XMSUB,XMY,XMTEXT,XMDUZ,SDWLX
+2 SET XMSUB="SDWL TRANSFER REMOVAL REQUEST"
+3 SET XMY("S.SDWL-XFER-SERVER@"_SDWLDMN)=""
+4 SET XMTEXT="SDWLX("
+5 SET XMDUZ="POSTMASTER"
+6 SET SDWLX(1,0)="6"_U_"RECEIVING FACILITY TRANSFER ID"_U_SDWLRIN
+7 SET SDWLX(0)=1
+8 DO ^XMD
+9 QUIT
EXIT ; Tidy up
+1 KILL SDWLIFTN
