source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDWLIFT0.m@ 1801

Last change on this file since 1801 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.5 KB
Line 
1SDWLIFT0 ;IOFO BAY PINES/OG - INTER-FACILITY TRANSFER: CONTROL REQUESTS; ; Compiled September 28, 2006 16:56:45
2 ;;5.3;Scheduling;**415,446**;AUG 13 1993;Build 77
3 ;
4 ;******************************************************************
5 ; CHANGE LOG
6 ;
7 ; DATE PATCH DESCRIPTION
8 ; ---- ----- -----------
9 ; 04/17/2006 SD*5.3*446 Add status on receipt
10 ;
11MSGSVRRQ ;handle transfer request
12 N DIC,DIE,DA,DR,DO,X,Y,%,XMY,XMSUB,XMTEXT,XMDUZ,XMMG,SDWLI,SDWLCI,SDWLI0,SDWLCOMM,SDWLMSG,SDWLRIN,SDWLIFTN,SDWLNM,SDWLDTM
13 D RMSG^SDWLIFT
14 S SDWLI=1,DIC="^SDWL(409.36,",DIC(0)="",(SDWLNM,X)=$P(SDWLMSG(SDWLI,0),U,3)
15 D FILE^DICN
16 I Y<0 S SDWLMSG(1,0)="Error creating new request: "_SDWLMSG(1,0) D ERR^SDWLIFT(.SDWLMSG) Q
17 S DA=+Y,DR="",(SDWLCI,SDWLI0)=0
18 F S SDWLI=$O(SDWLMSG(SDWLI)) Q:'SDWLI D
19 .;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.
20 .I $P(SDWLMSG(SDWLI,0),U)=.4 S SDWLCI=SDWLCI+1,SDWLCOMM(SDWLCI)=$P(SDWLMSG(SDWLI,0),U,3) Q
21 .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
22 .S SDWLI0=SDWLI0+1,$P(DR,";",SDWLI0)=$P(SDWLMSG(SDWLI,0),U)_"///"_$P(SDWLMSG(SDWLI,0),U,3)
23 .I $P(SDWLMSG(SDWLI,0),U)=.1 S SDWLSTN=$P(SDWLMSG(SDWLI,0),U,3),SDWLRIN=$$FIND1^DIC(4,"","X",SDWLSTN,"D") ;Requesting facility
24 .I $P(SDWLMSG(SDWLI,0),U)=.5 S SDWLIFTN=$P(SDWLMSG(SDWLI,0),U,3) ;Requesting facility's transfer ID
25 .Q
26 D NOW^%DTC
27 S DR=DR_";.2///"_%_";1///P",DIE=DIC D ^DIE ; 446 ; OG ; added status.
28 S DA(1)=DA,DIC=DIC_DA(1)_",""COMM"",",SDWLI=0
29 F S SDWLI=$O(SDWLCOMM(SDWLI)) Q:'SDWLI S X=SDWLCOMM(SDWLI) K DO D FILE^DICN
30 ;send acknowledgement message back reporting success or failure
31 S XMY("S.SDWL-XFER-SERVER@"_$$GET1^DIQ(4,SDWLRIN,60))="",XMSUB="SDWL TRANSFER ACKNOWLEDGEMENT",XMTEXT="SDWLX(",XMDUZ="POSTMASTER"
32 S SDWLI=1,SDWLX(SDWLI)=".5"_U_"SENDING FACILITY TRANSFER ID"_U_SDWLIFTN
33 S SDWLI=SDWLI+1,SDWLX(SDWLI)=".01"_U_"NAME"_U_SDWLNM
34 S SDWLI=SDWLI+1,SDWLX(SDWLI)=1_U_"STATION NUMBER"_U_$P($$SITE^VASITE(),U,3)
35 S SDWLI=SDWLI+1,SDWLX(SDWLI)=2_U_"TRANSMISSION DATE/TIME"_U_SDWLDTM
36 S SDWLI=SDWLI+1,SDWLX(SDWLI)=6_U_"RECEIVING FACILITY TRANSFER ID"_U_DA
37 D ^XMD
38 K XMY,SDWLX,SDWLMSG
39 I $G(XMMG)["Error" S SDWLMSG(0)=1,SDWLMSG(1,0)="Message aborted with the following error: "_XMMG D ERR^SDWLIFT(.SDWLMSG) Q
40 S XMY("G.SDWL-TRANSFER-ADMIN")="",XMSUB="INTER-FACILITY XFER: New request",XMTEXT="SDWLX(",XMDUZ="POSTMASTER"
41 S SDWLX(0)=1,SDWLX(SDWLX(0),0)="A request has arrived to transfer "_SDWLNM_" from "_$$GET1^DIQ(4,SDWLRIN,.01)_" ("_SDWLSTN_")."
42 D:$L(SDWLX(SDWLX(0),0))>80 COL80^SDWLIFT(.SDWLX)
43 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"
44 D ^XMD
45 I $G(XMMG)["Error" S SDWLMSG(0)=1,SDWLMSG(1,0)="Message aborted with the following error: "_XMMG D ERR^SDWLIFT(.SDWLMSG)
46 Q
47MSGSVRRM ;remove request
48 N DIE,DA,DR,DIK,DIC,D,X,XMY,XMSUB,XMTEXT,XMDUZ,XMMG,TMP,SDWLNM,SDWLIFTN,SDWLINST,SDWLSTN,SDWLDMN,SDWLX,SDWLMSG
49 D RMSG^SDWLIFT
50 S DIE=409.36,DA=$P(SDWLMSG(1,0),U,3)
51 D GETS^DIQ(DIE,DA_",",".01;.5",,"TMP")
52 S SDWLNM=TMP(DIE,DA_",",.01) ;Patient name
53 S SDWLIFTN=TMP(DIE,DA_",",.5) ;Sending facility's request id
54 S SDWLSTN=$$GET1^DIQ(DIE,DA,.1) ;Requesting station number
55 S SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D"),SDWLDMN=$$GET1^DIQ(4,SDWLINST,60)
56 S DIK="^SDWL(409.36," D ^DIK
57 S XMY("S.SDWL-XFER-SERVER@"_SDWLDMN)="",XMSUB="SDWL TRANSFER REMOVAL REQUEST ACKNOWLEDGEMENT",XMTEXT="SDWLX(",XMDUZ="POSTMASTER"
58 S SDWLX(1,0)=".5"_U_"SENDING FACILITY TRANSFER ID"_U_SDWLIFTN
59 S SDWLX(0)=1
60 D ^XMD
61 I $G(XMMG)["Error" S SDWLMSG(0)=1,SDWLMSG(1,0)="Message aborted with the following error: "_XMMG D ERR^SDWLIFT(.SDWLMSG)
62 K XMY,SDWLMSG,SDWLX
63 S XMY("G.SDWL-TRANSFER-ADMIN")="",XMSUB="INTER-FACILITY XFER: Removal of request",XMTEXT="SDWLX(",XMDUZ="POSTMASTER"
64 S SDWLX(0)=1,SDWLX(SDWLX(0),0)="The request to transfer "_SDWLNM_" from "_$$GET1^DIQ(4,SDWLINST,.01)_" ("_SDWLSTN_") has been recalled."
65 D:$L(SDWLX(SDWLX(0),0))>80 COL80^SDWLIFT(.SDWLX)
66 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."
67 D ^XMD
68 I $G(XMMG)["Error" S SDWLMSG(0)=1,SDWLMSG(1,0)="Message aborted with the following error: "_XMMG D ERR^SDWLIFT(.SDWLMSG)
69 Q
Note: See TracBrowser for help on using the repository browser.