- SDWLIFT0 ;IOFO BAY PINES/OG - INTER-FACILITY TRANSFER: CONTROL REQUESTS; ; Compiled September 28, 2006 16:56:45
- ;;5.3;Scheduling;**415,446,1015**;AUG 13 1993;Build 21
- ;
- ;******************************************************************
- ; 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
- SDWLIFT0 ;IOFO BAY PINES/OG - INTER-FACILITY TRANSFER: CONTROL REQUESTS; ; Compiled September 28, 2006 16:56:45
- +1 ;;5.3;Scheduling;**415,446,1015**;AUG 13 1993;Build 21
- +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
