SDWLIFT4.m

SDWLIFT4 ;IOFO BAY PINES/OG - INTER-FACILITY TRANSFER: REMOVE TRANSFER DETAILS  ; Compiled March 23, 2005 11:22:00

 ;;5.3;Scheduling;**415,1015**;AUG 13 1993;Build 21

 ;

 ;

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

 ;                             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

SDWLIFT4  ;IOFO BAY PINES/OG - INTER-FACILITY TRANSFER: REMOVE TRANSFER DETAILS  ; Compiled March 23, 2005 11:22:00

 +1       ;;5.3;Scheduling;**415,1015**;AUG 13 1993;Build 21

 +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