SDWLIFT6 ;IOFO BAY PINES/OG - INTER-FACILITY TRANSFER: DISPLAY ACCEPT DETAILS ;1/5/16 11:00am
;;5.3;Scheduling;**415,446,645**;AUG 13 1993;Build 7
;
;
;******************************************************************
; CHANGE LOG
;
; DATE PATCH DESCRIPTION
; ---- ----- -----------
; 04/14/2006 SD*5.3*446 INTER-FACILITY TRANSFER
;
Q
EN ; INITIALIZE VARIABLES FOR DISPLAY
N DFN,SDWLI,SDWLOK,SDWLIFN0
K SDWLLIST
D GETLIST^SDWLIFT5
S (SDWLIFTN,SDWLIFN0)=$$GETTN^SDWLIFT(.SDWLLIST)
I 'SDWLIFTN S VALMBCK="R" Q
L +^SDWL(409.36,SDWLIFTN):10 I '$T S VALMBCK="R" Q
; Refresh list and loop to ensure that the selection hasn't been removed while the choice was being made.
K SDWLLIST D GETLIST^SDWLIFT5
S (SDWLOK,SDWLI)=0 F S SDWLI=$O(SDWLLIST(SDWLI)) Q:'SDWLI I SDWLLIST(SDWLI,1)=SDWLIFTN S SDWLOK=1 Q
D:SDWLOK
.N DIC,DFN,SDWLDFN,SDWLICN,SDWLSSN,SDWLTY,X,Y
.S SDWLICN=$$GET1^DIQ(409.36,SDWLIFTN,991.01)
.S SDWLSSN=$$GET1^DIQ(409.36,SDWLIFTN,.09)
.S (DFN,SDWLDFN)=$S(+SDWLICN:$O(^DPT("AICN",SDWLICN,"")),1:"")
.I DFN="" S (DFN,SDWLDFN)=$S(+SDWLSSN:$O(^DPT("SSN",SDWLSSN,"")),1:"")
.S SDWLTY=$$GET1^DIQ(409.36,SDWLIFTN,4,"I")
.D EN^VALM("SDWL TRANSFER ACC VIEW")
.Q
L -^SDWL(409.36,SDWLIFN0)
D INIT^SDWLIFT5
S VALMBCK="R"
Q
INIT ; Default initialization options.
N SDWLINFO
D GETINFO(.SDWLINFO)
F VALMCNT=1:1:SDWLINFO(0) D SET^VALM10(VALMCNT,SDWLINFO(VALMCNT,0))
Q
GETINFO(SDWLOUT) ; The Coversheet function calls here too.
N DIC,D,X,WP,TMP,SDWLADD,SDWLFID,SDWLI
D GETS^DIQ(409.36,SDWLIFTN,"*",,"TMP")
S SDWLOUT(0)=1
D:SDWLDFN=""
.S SDWLOUT(SDWLOUT(0),0)="Patient not registered"
.S SDWLOUT(0)=SDWLOUT(0)+1
.D CNTRL^VALM10(1,1,22,IOINHI,IOINORM)
.Q
S SDWLOUT(SDWLOUT(0),0)="Transmg. Inst: "_$E($$GET1^DIQ(4,$$FIND1^DIC(4,"","X",TMP(409.36,SDWLIFTN_",",.1),"D"),.01)_SDWLSPS,1,28)_" "
S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_"Transmn. Date: "_TMP(409.36,SDWLIFTN_",",.2)
S SDWLOUT(0)=SDWLOUT(0)+1
S SDWLOUT(SDWLOUT(0),0)="Name: "_$E(TMP(409.36,SDWLIFTN_",",.01)_SDWLSPS,1,27)_" "
S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_"Sex: "_$E(TMP(409.36,SDWLIFTN_",",.02)_SDWLSPS,1,7)
S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_"DoB: "_$E(TMP(409.36,SDWLIFTN_",",.03)_SDWLSPS,1,13)
S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_"SSN: "_TMP(409.36,SDWLIFTN_",",.09)
;
S SDWLOUT(0)=SDWLOUT(0)+1,SDWLADD=SDWLOUT(0)
S SDWLOUT(SDWLOUT(0),0)=$E("Address: "_TMP(409.36,SDWLIFTN_",",.111)_SDWLSPS,1,58)_" Status: "_TMP(409.36,SDWLIFTN_",",1)
F SDWLFID=.112:.001:.114,.117 I TMP(409.36,SDWLIFTN_",",SDWLFID)'="" S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)=$E(SDWLSPS,1,9)_TMP(409.36,SDWLIFTN_",",SDWLFID)
I TMP(409.36,SDWLIFTN_",",.115)_TMP(409.36,SDWLIFTN_",",.116)'="" D
.S SDWLOUT(0)=SDWLOUT(0)+1
.S SDWLOUT(SDWLOUT(0),0)=$E(SDWLSPS,1,9)
.I TMP(409.36,SDWLIFTN_",",.115)'="" S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_TMP(409.36,SDWLIFTN_",",.115)
.S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_" "_TMP(409.36,SDWLIFTN_",",.116)
.Q
I TMP(409.36,SDWLIFTN_",",.131)'="" S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)="Phone no "_TMP(409.36,SDWLIFTN_",",.131)
D:TMP(409.36,SDWLIFTN_",",.1217)'="" ; Temporary address details. Displayed to the right of the address in up to 3 lines starting column 62
.S SDWLOUT(SDWLADD,0)=$E(SDWLOUT(SDWLADD,0)_SDWLSPS,1,61)_"Temporary address" ; There should be at least three lines if it is also indicated as temporary.
.S SDWLOUT(SDWLADD+1,0)=$E(SDWLOUT(SDWLADD+1,0)_SDWLSPS,1,61)_"From: "_TMP(409.36,SDWLIFTN_",",.1217)
.S SDWLOUT(SDWLADD+2,0)=$E(SDWLOUT(SDWLADD+2,0)_SDWLSPS,1,61)_"To : "_TMP(409.36,SDWLIFTN_",",.1218)
.Q
S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)="Service connected: "_TMP(409.36,SDWLIFTN_",",.301)
I TMP(409.36,SDWLIFTN_",",.301)="YES" S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_" Percentage: "_TMP(409.36,SDWLIFTN_",",.302)
S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)="Primary Eligibility: "_TMP(409.36,SDWLIFTN_",",.361)
S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)="Wait List Type: "
S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_TMP(409.36,SDWLIFTN_",",4)_" : "_TMP(409.36,SDWLIFTN_",",5)
; SD*5.3*645 - replaced Desired Date with CID/Preferred Date when presented to the user
;S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)="Desired Date of Appt: "
S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)="CID/Preferred Date of Appt: "
S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_TMP(409.36,SDWLIFTN_",",22)
S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_" Integration Control Number: "
S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_TMP(409.36,SDWLIFTN_",",991.01)
S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)="Comments: "
S X=$$GET1^DIQ(409.36,SDWLIFTN_",",.4,"Z","WP")
S SDWLI=0 F S SDWLI=$O(WP(SDWLI)) Q:'SDWLI S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)=WP(SDWLI,0)
Q
GETTN(SDWLLIST) ; Get transfer id.
N DIR,Y
I 'SDWLLIST(0) S DIR(0)="Y",DIR("A")="No entries. OK",DIR("B")="YES" D ^DIR Q 0
I SDWLLIST(0)=1 S Y=1 ; If there is only one, don't ask.
E S DIR(0)="L^1:"_SDWLLIST(0),DIR("A")="Which entry?" D ^DIR
Q $G(SDWLLIST(+Y,1),0)
HD ; -- Make header line for list processor
S (VALMHDR(1),VALMHDR(2))=""
Q
PCMM(SDWLIFTN,DFN) ;
N SDWLPCMM,SDWLRES,DIE,DA,DR
I $G(DFN)="" W !,"Patient not entered on the system. Use Load/edit" S DIR(0)="E",VALMBCK="R" D ^DIR Q
S (SDWLPCMM,SDWLRES)=0
D PAT^SCMCQK
;If a PCMM assignment was made, close 409.36
;if an EWL Entry was created instead, add pointer
;then pass a message back.
Q:'SDWLPCMM&'SDWLRES
S DIE="^SDWL(409.36,",DA=SDWLIFTN
I SDWLPCMM S DR="1///C"
E S DR="409.3///"_$P(SDWLRES,U,2)
D ^DIE,SENDST(SDWLIFTN)
Q
;
ACCEPT ; Sign the transaction off as accepted. Remove the temporary file and send a message to transmitting facility
N DIR
I $$GET1^DIQ(409.36,SDWLIFTN,.3)'="YES" D Q
.S DIR("A")="A coversheet does not appear to have been requested."_$C(13,10)_"This is required before acceptance. Enter RETURN to continue or '^' to exit"
.S DIR(0)="E"
.D ^DIR
.S VALMBCK=$S(Y:"R",1:"Q")
.Q
D FULL^VALM1
S DIR(0)="Y"
S DIR("A")="Do you confirm that the appropriate action was taken to schedule this patient"_$C(13,10)_"for an appointment or she/he has EWL entry and the cover sheet has been printed"
S DIR("B")="N"
D ^DIR
D:Y
.N SDWLSTN,SDWLINST,XMY,XMSUB,XMTEXT,XMDUZ,SDWLX,DA,DIK
.S SDWLSTN=$$GET1^DIQ(409.36,SDWLIFTN,.1)
.S SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D")
.S XMY("S.SDWL-XFER-SERVER@"_$$GET1^DIQ(4,SDWLINST,60))=""
.S XMSUB="SDWL TRANSFER ACCEPTANCE"
.S XMTEXT="SDWLX("
.S XMDUZ="POSTMASTER"
.S SDWLX(1,0)=".5"_U_"SENDING FACILITY TRANSFER ID"_U_$$GET1^DIQ(409.36,SDWLIFTN,.5)
.S SDWLX(2,0)="7"_U_"ACCEPTING PERSON"_U_$$GET1^DIQ(200,DUZ,.01)
.S SDWLX(0)=2
.D ^XMD
.S DA=SDWLIFTN,DIK="^SDWL(409.36," D ^DIK
.Q
S VALMBCK="Q"
Q
REJECT ; Sign the transaction off as rejected. Remove the temporary file and send a message to transmitting facility
N SDWLSTN,SDWLINST,XMSUB,XMY,XMTEXT,XMDUZ,SDWLX
S SDWLSTN=$$GET1^DIQ(409.36,SDWLIFTN,.1)
S SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D")
S XMY("S.SDWL-XFER-SERVER@"_$$GET1^DIQ(4,SDWLINST,60))=""
S XMSUB="SDWL TRANSFER REJECTION"
S XMTEXT="SDWLX("
S XMDUZ="POSTMASTER"
S SDWLX(1,0)=".5"_U_"SENDING FACILITY TRANSFER ID"_U_$$GET1^DIQ(409.36,SDWLIFTN,.5)
S SDWLX(0)=1
D ^XMD
S DA=SDWLIFTN,DIK="^SDWL(409.36," D ^DIK
;teh/05/20/2005 cleans the SDWLLIST array and reset count.
K SDWLLIST(SDWLIFTN)
S SDWLLIST(0)=SDWLLIST(0)-1
S VALMBCK="Q"
EXIT ; Tidy up
K SDWLIFTN
Q
SENDST(SDWLIFTN) ; Send status change notification
N SDWLSTN,SDWLINST,TMP,XMSUB,XMY,XMTEXT,XMDUZ,SDWLX,SDWLDA,SDWLDIS
S SDWLDA=$$GET1^DIQ(409.36,SDWLIFTN,409.3,"I"),SDWLDIS=$$GET1^DIQ(409.3,SDWLDA,21,"I")
D GETS^DIQ(409.36,SDWLIFTN,".1;.5;1;2","I","TMP")
S SDWLSTN=TMP(409.36,SDWLIFTN_",",.1,"I")
S SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D")
S XMY("S.SDWL-XFER-SERVER@"_$$GET1^DIQ(4,SDWLINST,60))=""
S XMSUB="SDWL TRANSFER STATUS CHANGE"
S XMTEXT="SDWLX("
S XMDUZ="POSTMASTER"
S SDWLX(1,0)=.5_U_"SENDING FACILITY TRANSFER ID"_U_TMP(409.36,SDWLIFTN_",",.5,"I")
S SDWLX(2,0)=1_U_"STATUS"_U_TMP(409.36,SDWLIFTN_",",1,"I")
S SDWLX(3,0)=7_U_"ACCEPTING PERSON"_U_$$GET1^DIQ(200,DUZ,.01)
S SDWLX(4,0)=2_U_"FACILITY TRANFERRED TO"_U_TMP(409.36,SDWLIFTN_",",2,"I")
S SDWLX(5,0)=21_U_"DISPOSITION"_U_SDWLDIS
S SDWLX(0)=5
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLIFT6 8703 printed Apr 09, 2024@21:43:17 Page 2
SDWLIFT6 ;IOFO BAY PINES/OG - INTER-FACILITY TRANSFER: DISPLAY ACCEPT DETAILS ;1/5/16 11:00am
+1 ;;5.3;Scheduling;**415,446,645**;AUG 13 1993;Build 7
+2 ;
+3 ;
+4 ;******************************************************************
+5 ; CHANGE LOG
+6 ;
+7 ; DATE PATCH DESCRIPTION
+8 ; ---- ----- -----------
+9 ; 04/14/2006 SD*5.3*446 INTER-FACILITY TRANSFER
+10 ;
+11 QUIT
EN ; INITIALIZE VARIABLES FOR DISPLAY
+1 NEW DFN,SDWLI,SDWLOK,SDWLIFN0
+2 KILL SDWLLIST
+3 DO GETLIST^SDWLIFT5
+4 SET (SDWLIFTN,SDWLIFN0)=$$GETTN^SDWLIFT(.SDWLLIST)
+5 IF 'SDWLIFTN
SET VALMBCK="R"
QUIT
+6 LOCK +^SDWL(409.36,SDWLIFTN):10
IF '$TEST
SET VALMBCK="R"
QUIT
+7 ; Refresh list and loop to ensure that the selection hasn't been removed while the choice was being made.
+8 KILL SDWLLIST
DO GETLIST^SDWLIFT5
+9 SET (SDWLOK,SDWLI)=0
FOR
SET SDWLI=$ORDER(SDWLLIST(SDWLI))
if 'SDWLI
QUIT
IF SDWLLIST(SDWLI,1)=SDWLIFTN
SET SDWLOK=1
QUIT
+10 if SDWLOK
Begin DoDot:1
+11 NEW DIC,DFN,SDWLDFN,SDWLICN,SDWLSSN,SDWLTY,X,Y
+12 SET SDWLICN=$$GET1^DIQ(409.36,SDWLIFTN,991.01)
+13 SET SDWLSSN=$$GET1^DIQ(409.36,SDWLIFTN,.09)
+14 SET (DFN,SDWLDFN)=$SELECT(+SDWLICN:$ORDER(^DPT("AICN",SDWLICN,"")),1:"")
+15 IF DFN=""
SET (DFN,SDWLDFN)=$SELECT(+SDWLSSN:$ORDER(^DPT("SSN",SDWLSSN,"")),1:"")
+16 SET SDWLTY=$$GET1^DIQ(409.36,SDWLIFTN,4,"I")
+17 DO EN^VALM("SDWL TRANSFER ACC VIEW")
+18 QUIT
End DoDot:1
+19 LOCK -^SDWL(409.36,SDWLIFN0)
+20 DO INIT^SDWLIFT5
+21 SET VALMBCK="R"
+22 QUIT
INIT ; Default initialization options.
+1 NEW SDWLINFO
+2 DO GETINFO(.SDWLINFO)
+3 FOR VALMCNT=1:1:SDWLINFO(0)
DO SET^VALM10(VALMCNT,SDWLINFO(VALMCNT,0))
+4 QUIT
GETINFO(SDWLOUT) ; The Coversheet function calls here too.
+1 NEW DIC,D,X,WP,TMP,SDWLADD,SDWLFID,SDWLI
+2 DO GETS^DIQ(409.36,SDWLIFTN,"*",,"TMP")
+3 SET SDWLOUT(0)=1
+4 if SDWLDFN=""
Begin DoDot:1
+5 SET SDWLOUT(SDWLOUT(0),0)="Patient not registered"
+6 SET SDWLOUT(0)=SDWLOUT(0)+1
+7 DO CNTRL^VALM10(1,1,22,IOINHI,IOINORM)
+8 QUIT
End DoDot:1
+9 SET SDWLOUT(SDWLOUT(0),0)="Transmg. Inst: "_$EXTRACT($$GET1^DIQ(4,$$FIND1^DIC(4,"","X",TMP(409.36,SDWLIFTN_",",.1),"D"),.01)_SDWLSPS,1,28)_" "
+10 SET SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_"Transmn. Date: "_TMP(409.36,SDWLIFTN_",",.2)
+11 SET SDWLOUT(0)=SDWLOUT(0)+1
+12 SET SDWLOUT(SDWLOUT(0),0)="Name: "_$EXTRACT(TMP(409.36,SDWLIFTN_",",.01)_SDWLSPS,1,27)_" "
+13 SET SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_"Sex: "_$EXTRACT(TMP(409.36,SDWLIFTN_",",.02)_SDWLSPS,1,7)
+14 SET SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_"DoB: "_$EXTRACT(TMP(409.36,SDWLIFTN_",",.03)_SDWLSPS,1,13)
+15 SET SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_"SSN: "_TMP(409.36,SDWLIFTN_",",.09)
+16 ;
+17 SET SDWLOUT(0)=SDWLOUT(0)+1
SET SDWLADD=SDWLOUT(0)
+18 SET SDWLOUT(SDWLOUT(0),0)=$EXTRACT("Address: "_TMP(409.36,SDWLIFTN_",",.111)_SDWLSPS,1,58)_" Status: "_TMP(409.36,SDWLIFTN_",",1)
+19 FOR SDWLFID=.112:.001:.114,.117
IF TMP(409.36,SDWLIFTN_",",SDWLFID)'=""
SET SDWLOUT(0)=SDWLOUT(0)+1
SET SDWLOUT(SDWLOUT(0),0)=$EXTRACT(SDWLSPS,1,9)_TMP(409.36,SDWLIFTN_",",SDWLFID)
+20 IF TMP(409.36,SDWLIFTN_",",.115)_TMP(409.36,SDWLIFTN_",",.116)'=""
Begin DoDot:1
+21 SET SDWLOUT(0)=SDWLOUT(0)+1
+22 SET SDWLOUT(SDWLOUT(0),0)=$EXTRACT(SDWLSPS,1,9)
+23 IF TMP(409.36,SDWLIFTN_",",.115)'=""
SET SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_TMP(409.36,SDWLIFTN_",",.115)
+24 SET SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_" "_TMP(409.36,SDWLIFTN_",",.116)
+25 QUIT
End DoDot:1
+26 IF TMP(409.36,SDWLIFTN_",",.131)'=""
SET SDWLOUT(0)=SDWLOUT(0)+1
SET SDWLOUT(SDWLOUT(0),0)="Phone no "_TMP(409.36,SDWLIFTN_",",.131)
+27 ; Temporary address details. Displayed to the right of the address in up to 3 lines starting column 62
if TMP(409.36,SDWLIFTN_",",.1217)'=""
Begin DoDot:1
+28 ; There should be at least three lines if it is also indicated as temporary.
SET SDWLOUT(SDWLADD,0)=$EXTRACT(SDWLOUT(SDWLADD,0)_SDWLSPS,1,61)_"Temporary address"
+29 SET SDWLOUT(SDWLADD+1,0)=$EXTRACT(SDWLOUT(SDWLADD+1,0)_SDWLSPS,1,61)_"From: "_TMP(409.36,SDWLIFTN_",",.1217)
+30 SET SDWLOUT(SDWLADD+2,0)=$EXTRACT(SDWLOUT(SDWLADD+2,0)_SDWLSPS,1,61)_"To : "_TMP(409.36,SDWLIFTN_",",.1218)
+31 QUIT
End DoDot:1
+32 SET SDWLOUT(0)=SDWLOUT(0)+1
SET SDWLOUT(SDWLOUT(0),0)="Service connected: "_TMP(409.36,SDWLIFTN_",",.301)
+33 IF TMP(409.36,SDWLIFTN_",",.301)="YES"
SET SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_" Percentage: "_TMP(409.36,SDWLIFTN_",",.302)
+34 SET SDWLOUT(0)=SDWLOUT(0)+1
SET SDWLOUT(SDWLOUT(0),0)="Primary Eligibility: "_TMP(409.36,SDWLIFTN_",",.361)
+35 SET SDWLOUT(0)=SDWLOUT(0)+1
SET SDWLOUT(SDWLOUT(0),0)="Wait List Type: "
+36 SET SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_TMP(409.36,SDWLIFTN_",",4)_" : "_TMP(409.36,SDWLIFTN_",",5)
+37 ; SD*5.3*645 - replaced Desired Date with CID/Preferred Date when presented to the user
+38 ;S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)="Desired Date of Appt: "
+39 SET SDWLOUT(0)=SDWLOUT(0)+1
SET SDWLOUT(SDWLOUT(0),0)="CID/Preferred Date of Appt: "
+40 SET SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_TMP(409.36,SDWLIFTN_",",22)
+41 SET SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_" Integration Control Number: "
+42 SET SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_TMP(409.36,SDWLIFTN_",",991.01)
+43 SET SDWLOUT(0)=SDWLOUT(0)+1
SET SDWLOUT(SDWLOUT(0),0)="Comments: "
+44 SET X=$$GET1^DIQ(409.36,SDWLIFTN_",",.4,"Z","WP")
+45 SET SDWLI=0
FOR
SET SDWLI=$ORDER(WP(SDWLI))
if 'SDWLI
QUIT
SET SDWLOUT(0)=SDWLOUT(0)+1
SET SDWLOUT(SDWLOUT(0),0)=WP(SDWLI,0)
+46 QUIT
GETTN(SDWLLIST) ; Get transfer id.
+1 NEW DIR,Y
+2 IF 'SDWLLIST(0)
SET DIR(0)="Y"
SET DIR("A")="No entries. OK"
SET DIR("B")="YES"
DO ^DIR
QUIT 0
+3 ; If there is only one, don't ask.
IF SDWLLIST(0)=1
SET Y=1
+4 IF '$TEST
SET DIR(0)="L^1:"_SDWLLIST(0)
SET DIR("A")="Which entry?"
DO ^DIR
+5 QUIT $GET(SDWLLIST(+Y,1),0)
HD ; -- Make header line for list processor
+1 SET (VALMHDR(1),VALMHDR(2))=""
+2 QUIT
PCMM(SDWLIFTN,DFN) ;
+1 NEW SDWLPCMM,SDWLRES,DIE,DA,DR
+2 IF $GET(DFN)=""
WRITE !,"Patient not entered on the system. Use Load/edit"
SET DIR(0)="E"
SET VALMBCK="R"
DO ^DIR
QUIT
+3 SET (SDWLPCMM,SDWLRES)=0
+4 DO PAT^SCMCQK
+5 ;If a PCMM assignment was made, close 409.36
+6 ;if an EWL Entry was created instead, add pointer
+7 ;then pass a message back.
+8 if 'SDWLPCMM&'SDWLRES
QUIT
+9 SET DIE="^SDWL(409.36,"
SET DA=SDWLIFTN
+10 IF SDWLPCMM
SET DR="1///C"
+11 IF '$TEST
SET DR="409.3///"_$PIECE(SDWLRES,U,2)
+12 DO ^DIE
DO SENDST(SDWLIFTN)
+13 QUIT
+14 ;
ACCEPT ; Sign the transaction off as accepted. Remove the temporary file and send a message to transmitting facility
+1 NEW DIR
+2 IF $$GET1^DIQ(409.36,SDWLIFTN,.3)'="YES"
Begin DoDot:1
+3 SET DIR("A")="A coversheet does not appear to have been requested."_$CHAR(13,10)_"This is required before acceptance. Enter RETURN to continue or '^' to exit"
+4 SET DIR(0)="E"
+5 DO ^DIR
+6 SET VALMBCK=$SELECT(Y:"R",1:"Q")
+7 QUIT
End DoDot:1
QUIT
+8 DO FULL^VALM1
+9 SET DIR(0)="Y"
+10 SET DIR("A")="Do you confirm that the appropriate action was taken to schedule this patient"_$CHAR(13,10)_"for an appointment or she/he has EWL entry and the cover sheet has been printed"
+11 SET DIR("B")="N"
+12 DO ^DIR
+13 if Y
Begin DoDot:1
+14 NEW SDWLSTN,SDWLINST,XMY,XMSUB,XMTEXT,XMDUZ,SDWLX,DA,DIK
+15 SET SDWLSTN=$$GET1^DIQ(409.36,SDWLIFTN,.1)
+16 SET SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D")
+17 SET XMY("S.SDWL-XFER-SERVER@"_$$GET1^DIQ(4,SDWLINST,60))=""
+18 SET XMSUB="SDWL TRANSFER ACCEPTANCE"
+19 SET XMTEXT="SDWLX("
+20 SET XMDUZ="POSTMASTER"
+21 SET SDWLX(1,0)=".5"_U_"SENDING FACILITY TRANSFER ID"_U_$$GET1^DIQ(409.36,SDWLIFTN,.5)
+22 SET SDWLX(2,0)="7"_U_"ACCEPTING PERSON"_U_$$GET1^DIQ(200,DUZ,.01)
+23 SET SDWLX(0)=2
+24 DO ^XMD
+25 SET DA=SDWLIFTN
SET DIK="^SDWL(409.36,"
DO ^DIK
+26 QUIT
End DoDot:1
+27 SET VALMBCK="Q"
+28 QUIT
REJECT ; Sign the transaction off as rejected. Remove the temporary file and send a message to transmitting facility
+1 NEW SDWLSTN,SDWLINST,XMSUB,XMY,XMTEXT,XMDUZ,SDWLX
+2 SET SDWLSTN=$$GET1^DIQ(409.36,SDWLIFTN,.1)
+3 SET SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D")
+4 SET XMY("S.SDWL-XFER-SERVER@"_$$GET1^DIQ(4,SDWLINST,60))=""
+5 SET XMSUB="SDWL TRANSFER REJECTION"
+6 SET XMTEXT="SDWLX("
+7 SET XMDUZ="POSTMASTER"
+8 SET SDWLX(1,0)=".5"_U_"SENDING FACILITY TRANSFER ID"_U_$$GET1^DIQ(409.36,SDWLIFTN,.5)
+9 SET SDWLX(0)=1
+10 DO ^XMD
+11 SET DA=SDWLIFTN
SET DIK="^SDWL(409.36,"
DO ^DIK
+12 ;teh/05/20/2005 cleans the SDWLLIST array and reset count.
+13 KILL SDWLLIST(SDWLIFTN)
+14 SET SDWLLIST(0)=SDWLLIST(0)-1
+15 SET VALMBCK="Q"
EXIT ; Tidy up
+1 KILL SDWLIFTN
+2 QUIT
SENDST(SDWLIFTN) ; Send status change notification
+1 NEW SDWLSTN,SDWLINST,TMP,XMSUB,XMY,XMTEXT,XMDUZ,SDWLX,SDWLDA,SDWLDIS
+2 SET SDWLDA=$$GET1^DIQ(409.36,SDWLIFTN,409.3,"I")
SET SDWLDIS=$$GET1^DIQ(409.3,SDWLDA,21,"I")
+3 DO GETS^DIQ(409.36,SDWLIFTN,".1;.5;1;2","I","TMP")
+4 SET SDWLSTN=TMP(409.36,SDWLIFTN_",",.1,"I")
+5 SET SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D")
+6 SET XMY("S.SDWL-XFER-SERVER@"_$$GET1^DIQ(4,SDWLINST,60))=""
+7 SET XMSUB="SDWL TRANSFER STATUS CHANGE"
+8 SET XMTEXT="SDWLX("
+9 SET XMDUZ="POSTMASTER"
+10 SET SDWLX(1,0)=.5_U_"SENDING FACILITY TRANSFER ID"_U_TMP(409.36,SDWLIFTN_",",.5,"I")
+11 SET SDWLX(2,0)=1_U_"STATUS"_U_TMP(409.36,SDWLIFTN_",",1,"I")
+12 SET SDWLX(3,0)=7_U_"ACCEPTING PERSON"_U_$$GET1^DIQ(200,DUZ,.01)
+13 SET SDWLX(4,0)=2_U_"FACILITY TRANFERRED TO"_U_TMP(409.36,SDWLIFTN_",",2,"I")
+14 SET SDWLX(5,0)=21_U_"DISPOSITION"_U_SDWLDIS
+15 SET SDWLX(0)=5
+16 DO ^XMD
+17 QUIT
