SDWLIFT3 ;IOFO BAY PINES/OG - INTER-FACILITY TRANSFER: NEW TRANSFER ; Compiled March 23, 2005 11:15:27 ; Compiled April 16, 2007 10:52:44
;;5.3;Scheduling;**415,446,1015**;AUG 13 1993;Build 21
;
;
;******************************************************************
; CHANGE LOG
;
; DATE PATCH DESCRIPTION
; ---- ----- -----------
; 12/12/05 SD*5.3*446 Enhancements
;
Q
EN ; INITIALIZE VARIABLES
N DIR,DIC,DR,DIE,VADM,X,Y
D FULL^VALM1
D EN2()
D INIT^SDWLIFT1(0)
; VALMBCK required by List Manager
S VALMBCK="R"
Q
EN2(SDWLDA) ; Entry point if Wait List has been selected elsewhere.
; SDWLOPT is the option to be queried.
; 1: Patient & Wait List Entry
; 2: Institution
; 3: Comments
; 4: Processing
; 5: Confirmation
N SDWLOPT,SDWLOPT0
S SDWLOPT=2
I '$D(SDWLDA) S SDWLDA="",SDWLOPT=1
S SDWLOPT0=SDWLOPT
F D Q:'SDWLOPT
.N SDWLDFN,SDWLDMN,SDWLIFTN,SDWLINST,DIC,DIE,DIR,DA,DO,I,Y,%,DIWETXT
.I SDWLOPT=1 D
..N DFN,SDWLOK,SDWLOUT,SDWLC,SDWLI,SDWLNM,SDWLTMP
..K Y,X
..S DIC=2,DIC(0)="AEMZ",DIC("S")="I $$ISEWL^SDWLIFT3(+Y)"
..D ^DIC
..I Y=-1 S SDWLOPT=0 Q
..S DFN=+Y ; DFN used to uniquely identify the patient in the following look-up.
..D LIST^DIC(409.3,,".01;2;4;5;6;7;8",,,,$P(Y,U,2),,"I $$ISEWL2^SDWLIFT3(Y,DFN)",,"SDWLTMP")
..F I=1:1:+SDWLTMP("DILIST",0) D
...N TMP,SDWLSTA
...S TMP=""
...I SDWLTMP("DILIST","ID",I,2)'="" S TMP=TMP_SDWLTMP("DILIST","ID",I,2)_" "
...D:SDWLTMP("DILIST","ID",I,4)'=""
....S SDWLTMP("WLTY",I,0)=SDWLTMP("DILIST","ID",I,4),SDWLSTA=$$GET1^DIQ(409.3,SDWLTMP("DILIST",2,I),4,"I")
....I SDWLTMP("DILIST","ID",I,SDWLSTA+4)'="" S SDWLTMP("WLTY",I,0)=SDWLTMP("WLTY",I,0)_" ("_SDWLTMP("DILIST","ID",I,SDWLSTA+4)_")"
....S TMP=TMP_SDWLTMP("WLTY",I,0)
....Q
...S $P(DIR(0),";",I)=I_":"_TMP
...Q
..; If there is only one EWL entry, use that. The previous look-up will have ensured there is at least one.
..; If there are more than one, call ^DIR to select.
..S Y=1
..I +SDWLTMP("DILIST",0)>1 S DIR(0)="S^"_DIR(0),DIR("A")="Enter 1 - "_+SDWLTMP("DILIST",0) D ^DIR Q:Y="^"
..W !?4,"Institution:",?20,SDWLTMP("DILIST","ID",Y,2)
..W !?4,"Wait List Type:",?20,$G(SDWLTMP("WLTY",Y,0))
..S SDWLDA=SDWLTMP("DILIST",2,Y)
..I $D(^SDWL(409.36,"C",SDWLDA)) S SDWLOK=0 D I SDWLOK S SDWLOPT=0 Q
...N SDWLIFTN,SDWLSTN
...S SDWLIFTN=$O(^SDWL(409.36,"C",SDWLDA,"")),SDWLSTN=$$GET1^DIQ(409.36,SDWLIFTN,".1")
...S DIR(0)="E",DIR("A")="Press return to continue"
...S DIR("A",1)="This EWL Entry is the result of a transfer request from "_$$GET1^DIQ(4,SDWLSTN,".01")_" ("_SDWLSTN_")"
...;S DIR("A",2)="On acceptance at the destination facility, this EWL Entry will be removed."
...S DIR("A",2)="To transfer care, close the EWL Entry as ER - ENTERED IN ERROR and reject the"
...S DIR("A",3)="request. "_$$GET1^DIQ(4,SDWLSTN,".01")_" can then request the transfer."
...D ^DIR
...S SDWLOK=1
...Q
..S SDWLOPT=2
..Q
.D:SDWLOPT=2
..N SDWLY
..S SDWLDFN=$$GET1^DIQ(409.3,SDWLDA,.01,"I")
..S DIC=4
..S DIC(0)="EMNQA"
..S DIC("A")="Select Institution to transfer to: "
..S DIC("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",'+$P($G(^DIC(4,+Y,99)),U,4),$L($P($G(^DIC(4,+Y,99)),U))=3,$$GET1^DIQ(4,Y,13)=""VAMC"""
..D ^DIC
..I Y=-1 S SDWLOPT=$S(SDWLOPT0=2:0,1:1) Q ; If the call was made to go straight to Institution, quit out if no institution is selected.
..S SDWLY=+Y,SDWLDMN=$$GET1^DIQ(4,SDWLY,60)
..I SDWLDMN="" W !,"This Institution does not have a Domain to which the request can be sent." Q
..S SDWLINST=SDWLY,SDWLOPT=3
..Q
.D:SDWLOPT=3
..S DIC="^TMP(""SDWLIFT"",$J,""COMMENT""",DIWETXT="Transfer comments"
..W !,DIWETXT
..K @(DIC_")") S DIC=DIC_","
..D EN^DIWE
..S SDWLOPT=4
..Q
.D:SDWLOPT=4
..N SDWLDTM
..K DIC
..S DIR(0)="Y",DIR("A")="OK to send",DIR("B")="YES" D ^DIR
..I 'Y S SDWLOPT=0 Q
..S DIC=409.35,DIC(0)="Z",X=SDWLDA
..D FILE^DICN
..S SDWLIFTN=+Y
..S DA(1)=+Y,DIC=DIC_DA(1)_",1,",SDWLI=0
..F S SDWLI=$O(^TMP("SDWLIFT",$J,"COMMENT",SDWLI)) Q:'SDWLI S X=^TMP("SDWLIFT",$J,"COMMENT",SDWLI,0) K DO D FILE^DICN
..D NOW^%DTC S SDWLDTM=%
..S DIE=409.35,DR="1///"_$$GET1^DIQ(4,SDWLINST,99)_";2///"_SDWLDTM_";3///P;4///`"_DUZ
..D ^DIE
..D MSG
..S SDWLOPT=0 K DIR
..;S DIR(0)="E" D ^DIR
..Q
.Q
Q
;
ISEWL(DFN) ; Filter for seach of PATIENT file ; OG ; SD*5.3*446
N SDWLOK,SDWLDA
S SDWLOK=0
Q:'$D(^SDWL(409.3,"B",DFN)) SDWLOK
S SDWLDA=0
F S SDWLDA=$O(^SDWL(409.3,"B",DFN,SDWLDA)) Q:'SDWLDA I $$ISEWL2(SDWLDA,DFN) S SDWLOK=1 Q
Q SDWLOK
;
ISEWL2(SDWLDA,DFN) ; If the EWL entry exists, is not closed, is a team or team position assignment and not already in transit.
N TMP
;Q $$GET1^DIQ(409.3,SDWLDA,23,"I")'="C"&'$$GETTRN^SDWLIFT1(SDWLDA)&($$GET1^DIQ(409.3,SDWLDA,.01,"I")=DFN) old way of doing it.
D GETS^DIQ(409.3,SDWLDA_",",".01;4;23","I","TMP")
Q:$G(TMP(409.3,SDWLDA_",",.01,"I"))'=DFN 0
Q TMP(409.3,SDWLDA_",",23,"I")'="C"&("^1^2^"[("^"_TMP(409.3,SDWLDA_",",4,"I")_"^"))&'$$GETTRN^SDWLIFT1(SDWLDA)
;
MSG ;acknowledgement notification to destination
N SDWLDA,SDWLDTM,DFN,TMP,SDWLTY,SDWLX,SDWLI,DIE,DA,DR,VAPA,WP
N XMSUB,XMY,XMTEXT,XMDUZ,SDWLX,SDWLI
S XMSUB="SDWL TRANSFER REQUEST"
S XMY("S.SDWL-XFER-SERVER@"_SDWLDMN)=""
S XMTEXT="SDWLX("
S XMDUZ="POSTMASTER"
D NOW^%DTC S SDWLDTM=%
S SDWLDA=$$GET1^DIQ(409.35,SDWLIFTN,.01,"I")
D GETS^DIQ(409.3,SDWLDA,".01;4;22","I","TMP")
S DFN=TMP(409.3,SDWLDA_",",.01,"I")
S SDWLTY=TMP(409.3,SDWLDA_",",4,"I")
D DEM^VADPT,ADD^VADPT
D GETS^DIQ(2,DFN,".301;.302;991.01","I","TMP")
S SDWLX(0)=0
S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".01"_U_"NAME"_U_VADM(1)
S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".02"_U_"SEX"_U_$P(VADM(5),U)
S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".03"_U_"DATE OF BIRTH"_U_$P(VADM(3),U)
S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".09"_U_"SOCIAL SECURITY NUMBER"_U_$P(VADM(2),U)
S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".1"_U_"REQUESTING STATION NUMBER"_U_$P($$SITE^VASITE(),U,3)
S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".111"_U_"STREET ADDRESS [LINE 1]"_U_VAPA(1)
S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".112"_U_"STREET ADDRESS [LINE 2]"_U_VAPA(2)
S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".113"_U_"STREET ADDRESS [LINE 3]"_U_VAPA(3)
S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".114"_U_"CITY"_U_VAPA(4)
S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".115"_U_"STATE"_U_VAPA(5)
S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".116"_U_"ZIP CODE"_U_VAPA(6)
S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".117"_U_"COUNTY"_U_$P(VAPA(7),U)
S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".1217"_U_"TEMPORARY ADDRESS START DATE"_U_$P(VAPA(9),U)
S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".1218"_U_"TEMPORARY ADDRESS END DATE"_U_$P(VAPA(10),U)
S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".131"_U_"PHONE NUMBER [RESIDENCE]"_U_VAPA(8)
S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".301"_U_"SERVICE CONNECTED?"_U_TMP(2,DFN_",",.301,"I")
S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".302"_U_"SERVICE CONNECTED PERCENTAGE"_U_TMP(2,DFN_",",.302,"I")
S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".361"_U_"PRIMARY ELIGIBILITY CODE"_U_$$GET1^DIQ(2,DFN,.361)
S X=$$GET1^DIQ(409.35,SDWLIFTN_",",5,"Z","WP")
S SDWLI=0 F S SDWLI=$O(WP(SDWLI)) Q:'SDWLI S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".4"_U_"COMMENTS"_U_WP(SDWLI,0)
S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".5"_U_"SENDING FACILITY TRANSFER ID"_U_SDWLIFTN
S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=2_U_"TRANSMISSION DATE/TIME"_U_SDWLDTM
S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=4_U_"WAIT LIST TYPE"_U_SDWLTY
S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=5_U_"WAIT LIST TYPE EXTENSION"_U_$$GET1^DIQ(409.3,SDWLDA,4+SDWLTY)
S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=22_U_"DESIRED DATE OF APPOINTMENT"_U_TMP(409.3,SDWLDA_",",22,"I")
S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))="991.01"_U_"INTEGRATION CONTROL NUMBER"_U_TMP(2,DFN_",",991.01,"I")
D ^XMD
; Change status of transfer file to TRANSMITTED
S DIE=409.35,DA=SDWLIFTN,DR="3///T" D ^DIE
; Update the EWL Disposition code
S DIE=409.3,DA=SDWLDA,DR="21///TR" D ^DIE
Q
SDWLIFT3 ;IOFO BAY PINES/OG - INTER-FACILITY TRANSFER: NEW TRANSFER ; Compiled March 23, 2005 11:15:27 ; Compiled April 16, 2007 10:52:44
+1 ;;5.3;Scheduling;**415,446,1015**;AUG 13 1993;Build 21
+2 ;
+3 ;
+4 ;******************************************************************
+5 ; CHANGE LOG
+6 ;
+7 ; DATE PATCH DESCRIPTION
+8 ; ---- ----- -----------
+9 ; 12/12/05 SD*5.3*446 Enhancements
+10 ;
+11 QUIT
EN ; INITIALIZE VARIABLES
+1 NEW DIR,DIC,DR,DIE,VADM,X,Y
+2 DO FULL^VALM1
+3 DO EN2()
+4 DO INIT^SDWLIFT1(0)
+5 ; VALMBCK required by List Manager
+6 SET VALMBCK="R"
+7 QUIT
EN2(SDWLDA) ; Entry point if Wait List has been selected elsewhere.
+1 ; SDWLOPT is the option to be queried.
+2 ; 1: Patient & Wait List Entry
+3 ; 2: Institution
+4 ; 3: Comments
+5 ; 4: Processing
+6 ; 5: Confirmation
+7 NEW SDWLOPT,SDWLOPT0
+8 SET SDWLOPT=2
+9 IF '$DATA(SDWLDA)
SET SDWLDA=""
SET SDWLOPT=1
+10 SET SDWLOPT0=SDWLOPT
+11 FOR
Begin DoDot:1
+12 NEW SDWLDFN,SDWLDMN,SDWLIFTN,SDWLINST,DIC,DIE,DIR,DA,DO,I,Y,%,DIWETXT
+13 IF SDWLOPT=1
Begin DoDot:2
+14 NEW DFN,SDWLOK,SDWLOUT,SDWLC,SDWLI,SDWLNM,SDWLTMP
+15 KILL Y,X
+16 SET DIC=2
SET DIC(0)="AEMZ"
SET DIC("S")="I $$ISEWL^SDWLIFT3(+Y)"
+17 DO ^DIC
+18 IF Y=-1
SET SDWLOPT=0
QUIT
+19 ; DFN used to uniquely identify the patient in the following look-up.
SET DFN=+Y
+20 DO LIST^DIC(409.3,,".01;2;4;5;6;7;8",,,,$PIECE(Y,U,2),,"I $$ISEWL2^SDWLIFT3(Y,DFN)",,"SDWLTMP")
+21 FOR I=1:1:+SDWLTMP("DILIST",0)
Begin DoDot:3
+22 NEW TMP,SDWLSTA
+23 SET TMP=""
+24 IF SDWLTMP("DILIST","ID",I,2)'=""
SET TMP=TMP_SDWLTMP("DILIST","ID",I,2)_" "
+25 IF SDWLTMP("DILIST","ID",I,4)'=""
Begin DoDot:4
+26 SET SDWLTMP("WLTY",I,0)=SDWLTMP("DILIST","ID",I,4)
SET SDWLSTA=$$GET1^DIQ(409.3,SDWLTMP("DILIST",2,I),4,"I")
+27 IF SDWLTMP("DILIST","ID",I,SDWLSTA+4)'=""
SET SDWLTMP("WLTY",I,0)=SDWLTMP("WLTY",I,0)_" ("_SDWLTMP("DILIST","ID",I,SDWLSTA+4)_")"
+28 SET TMP=TMP_SDWLTMP("WLTY",I,0)
+29 QUIT
End DoDot:4
+30 SET $PIECE(DIR(0),";",I)=I_":"_TMP
+31 QUIT
End DoDot:3
+32 ; If there is only one EWL entry, use that. The previous look-up will have ensured there is at least one.
+33 ; If there are more than one, call ^DIR to select.
+34 SET Y=1
+35 IF +SDWLTMP("DILIST",0)>1
SET DIR(0)="S^"_DIR(0)
SET DIR("A")="Enter 1 - "_+SDWLTMP("DILIST",0)
DO ^DIR
IF Y="^"
QUIT
+36 WRITE !?4,"Institution:",?20,SDWLTMP("DILIST","ID",Y,2)
+37 WRITE !?4,"Wait List Type:",?20,$GET(SDWLTMP("WLTY",Y,0))
+38 SET SDWLDA=SDWLTMP("DILIST",2,Y)
+39 IF $DATA(^SDWL(409.36,"C",SDWLDA))
SET SDWLOK=0
Begin DoDot:3
+40 NEW SDWLIFTN,SDWLSTN
+41 SET SDWLIFTN=$ORDER(^SDWL(409.36,"C",SDWLDA,""))
SET SDWLSTN=$$GET1^DIQ(409.36,SDWLIFTN,".1")
+42 SET DIR(0)="E"
SET DIR("A")="Press return to continue"
+43 SET DIR("A",1)="This EWL Entry is the result of a transfer request from "_$$GET1^DIQ(4,SDWLSTN,".01")_" ("_SDWLSTN_")"
+44 ;S DIR("A",2)="On acceptance at the destination facility, this EWL Entry will be removed."
+45 SET DIR("A",2)="To transfer care, close the EWL Entry as ER - ENTERED IN ERROR and reject the"
+46 SET DIR("A",3)="request. "_$$GET1^DIQ(4,SDWLSTN,".01")_" can then request the transfer."
+47 DO ^DIR
+48 SET SDWLOK=1
+49 QUIT
End DoDot:3
IF SDWLOK
SET SDWLOPT=0
QUIT
+50 SET SDWLOPT=2
+51 QUIT
End DoDot:2
+52 IF SDWLOPT=2
Begin DoDot:2
+53 NEW SDWLY
+54 SET SDWLDFN=$$GET1^DIQ(409.3,SDWLDA,.01,"I")
+55 SET DIC=4
+56 SET DIC(0)="EMNQA"
+57 SET DIC("A")="Select Institution to transfer to: "
+58 SET DIC("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",'+$P($G(^DIC(4,+Y,99)),U,4),$L($P($G(^DIC(4,+Y,99)),U))=3,$$GET1^DIQ(4,Y,13)=""VAMC"""
+59 DO ^DIC
+60 ; If the call was made to go straight to Institution, quit out if no institution is selected.
IF Y=-1
SET SDWLOPT=$SELECT(SDWLOPT0=2:0,1:1)
QUIT
+61 SET SDWLY=+Y
SET SDWLDMN=$$GET1^DIQ(4,SDWLY,60)
+62 IF SDWLDMN=""
WRITE !,"This Institution does not have a Domain to which the request can be sent."
QUIT
+63 SET SDWLINST=SDWLY
SET SDWLOPT=3
+64 QUIT
End DoDot:2
+65 IF SDWLOPT=3
Begin DoDot:2
+66 SET DIC="^TMP(""SDWLIFT"",$J,""COMMENT"""
SET DIWETXT="Transfer comments"
+67 WRITE !,DIWETXT
+68 KILL @(DIC_")")
SET DIC=DIC_","
+69 DO EN^DIWE
+70 SET SDWLOPT=4
+71 QUIT
End DoDot:2
+72 IF SDWLOPT=4
Begin DoDot:2
+73 NEW SDWLDTM
+74 KILL DIC
+75 SET DIR(0)="Y"
SET DIR("A")="OK to send"
SET DIR("B")="YES"
DO ^DIR
+76 IF 'Y
SET SDWLOPT=0
QUIT
+77 SET DIC=409.35
SET DIC(0)="Z"
SET X=SDWLDA
+78 DO FILE^DICN
+79 SET SDWLIFTN=+Y
+80 SET DA(1)=+Y
SET DIC=DIC_DA(1)_",1,"
SET SDWLI=0
+81 FOR
SET SDWLI=$ORDER(^TMP("SDWLIFT",$JOB,"COMMENT",SDWLI))
IF 'SDWLI
QUIT
SET X=^TMP("SDWLIFT",$JOB,"COMMENT",SDWLI,0)
KILL DO
DO FILE^DICN
+82 DO NOW^%DTC
SET SDWLDTM=%
+83 SET DIE=409.35
SET DR="1///"_$$GET1^DIQ(4,SDWLINST,99)_";2///"_SDWLDTM_";3///P;4///`"_DUZ
+84 DO ^DIE
+85 DO MSG
+86 SET SDWLOPT=0
KILL DIR
+87 ;S DIR(0)="E" D ^DIR
+88 QUIT
End DoDot:2
+89 QUIT
End DoDot:1
IF 'SDWLOPT
QUIT
+90 QUIT
+91 ;
ISEWL(DFN) ; Filter for seach of PATIENT file ; OG ; SD*5.3*446
+1 NEW SDWLOK,SDWLDA
+2 SET SDWLOK=0
+3 IF '$DATA(^SDWL(409.3,"B",DFN))
QUIT SDWLOK
+4 SET SDWLDA=0
+5 FOR
SET SDWLDA=$ORDER(^SDWL(409.3,"B",DFN,SDWLDA))
IF 'SDWLDA
QUIT
IF $$ISEWL2(SDWLDA,DFN)
SET SDWLOK=1
QUIT
+6 QUIT SDWLOK
+7 ;
ISEWL2(SDWLDA,DFN) ; If the EWL entry exists, is not closed, is a team or team position assignment and not already in transit.
+1 NEW TMP
+2 ;Q $$GET1^DIQ(409.3,SDWLDA,23,"I")'="C"&'$$GETTRN^SDWLIFT1(SDWLDA)&($$GET1^DIQ(409.3,SDWLDA,.01,"I")=DFN) old way of doing it.
+3 DO GETS^DIQ(409.3,SDWLDA_",",".01;4;23","I","TMP")
+4 IF $GET(TMP(409.3,SDWLDA_",",.01,"I"))'=DFN
QUIT 0
+5 QUIT TMP(409.3,SDWLDA_",",23,"I")'="C"&("^1^2^"[("^"_TMP(409.3,SDWLDA_",",4,"I")_"^"))&'$$GETTRN^SDWLIFT1(SDWLDA)
+6 ;
MSG ;acknowledgement notification to destination
+1 NEW SDWLDA,SDWLDTM,DFN,TMP,SDWLTY,SDWLX,SDWLI,DIE,DA,DR,VAPA,WP
+2 NEW XMSUB,XMY,XMTEXT,XMDUZ,SDWLX,SDWLI
+3 SET XMSUB="SDWL TRANSFER REQUEST"
+4 SET XMY("S.SDWL-XFER-SERVER@"_SDWLDMN)=""
+5 SET XMTEXT="SDWLX("
+6 SET XMDUZ="POSTMASTER"
+7 DO NOW^%DTC
SET SDWLDTM=%
+8 SET SDWLDA=$$GET1^DIQ(409.35,SDWLIFTN,.01,"I")
+9 DO GETS^DIQ(409.3,SDWLDA,".01;4;22","I","TMP")
+10 SET DFN=TMP(409.3,SDWLDA_",",.01,"I")
+11 SET SDWLTY=TMP(409.3,SDWLDA_",",4,"I")
+12 DO DEM^VADPT
DO ADD^VADPT
+13 DO GETS^DIQ(2,DFN,".301;.302;991.01","I","TMP")
+14 SET SDWLX(0)=0
+15 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))=".01"_U_"NAME"_U_VADM(1)
+16 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))=".02"_U_"SEX"_U_$PIECE(VADM(5),U)
+17 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))=".03"_U_"DATE OF BIRTH"_U_$PIECE(VADM(3),U)
+18 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))=".09"_U_"SOCIAL SECURITY NUMBER"_U_$PIECE(VADM(2),U)
+19 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))=".1"_U_"REQUESTING STATION NUMBER"_U_$PIECE($$SITE^VASITE(),U,3)
+20 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))=".111"_U_"STREET ADDRESS [LINE 1]"_U_VAPA(1)
+21 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))=".112"_U_"STREET ADDRESS [LINE 2]"_U_VAPA(2)
+22 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))=".113"_U_"STREET ADDRESS [LINE 3]"_U_VAPA(3)
+23 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))=".114"_U_"CITY"_U_VAPA(4)
+24 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))=".115"_U_"STATE"_U_VAPA(5)
+25 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))=".116"_U_"ZIP CODE"_U_VAPA(6)
+26 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))=".117"_U_"COUNTY"_U_$PIECE(VAPA(7),U)
+27 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))=".1217"_U_"TEMPORARY ADDRESS START DATE"_U_$PIECE(VAPA(9),U)
+28 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))=".1218"_U_"TEMPORARY ADDRESS END DATE"_U_$PIECE(VAPA(10),U)
+29 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))=".131"_U_"PHONE NUMBER [RESIDENCE]"_U_VAPA(8)
+30 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))=".301"_U_"SERVICE CONNECTED?"_U_TMP(2,DFN_",",.301,"I")
+31 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))=".302"_U_"SERVICE CONNECTED PERCENTAGE"_U_TMP(2,DFN_",",.302,"I")
+32 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))=".361"_U_"PRIMARY ELIGIBILITY CODE"_U_$$GET1^DIQ(2,DFN,.361)
+33 SET X=$$GET1^DIQ(409.35,SDWLIFTN_",",5,"Z","WP")
+34 SET SDWLI=0
FOR
SET SDWLI=$ORDER(WP(SDWLI))
IF 'SDWLI
QUIT
SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))=".4"_U_"COMMENTS"_U_WP(SDWLI,0)
+35 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))=".5"_U_"SENDING FACILITY TRANSFER ID"_U_SDWLIFTN
+36 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))=2_U_"TRANSMISSION DATE/TIME"_U_SDWLDTM
+37 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))=4_U_"WAIT LIST TYPE"_U_SDWLTY
+38 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))=5_U_"WAIT LIST TYPE EXTENSION"_U_$$GET1^DIQ(409.3,SDWLDA,4+SDWLTY)
+39 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))=22_U_"DESIRED DATE OF APPOINTMENT"_U_TMP(409.3,SDWLDA_",",22,"I")
+40 SET SDWLX(0)=SDWLX(0)+1
SET SDWLX(SDWLX(0))="991.01"_U_"INTEGRATION CONTROL NUMBER"_U_TMP(2,DFN_",",991.01,"I")
+41 DO ^XMD
+42 ; Change status of transfer file to TRANSMITTED
+43 SET DIE=409.35
SET DA=SDWLIFTN
SET DR="3///T"
DO ^DIE
+44 ; Update the EWL Disposition code
+45 SET DIE=409.3
SET DA=SDWLDA
SET DR="21///TR"
DO ^DIE
+46 QUIT
