SDWLRP1 ;;IOFO BAY PINES/TEH - WAITING LIST - RPC;06/28/2002 ; 26 Aug 2002 1:25 PM ; Compiled April 16, 2007 10:15:05
;;5.3;scheduling;**263,273,485,497,446,611**;AUG 13 1993;Build 9
;
;
;******************************************************************
; CHANGE LOG
;
; DATE PATCH DESCRIPTION
; ---- ----- -----------
; 2/21/03 SD*5.3*273 Line new+12 added "/"
; 5/10/06 SD*5.3*446 New field: INTRA-transfer
; 1/14/14 SD*5.3*611 Removed variables SDWLDUZ,SDWLDFN,SDWLDA from kill command
OUTPUT(SDWLOUT,SDWLDFN) ;-FULL
; input:
; DFN = Patient
; Lookup uses Wait List data file (409.3) and returns the following data.
;
; output:
; SCOUT = location of data = ^TMP("SDWLG",$J,i,0)
; for i=1:number of records returned:
;
; Field Location Description
; 1 2 ORIGINATION DATE
; 2 3 INSTITUTION
; 3 4 CLINIC
; 4 5 WAIT LIST TYPE
; 5 6 SPECIFIC TEAM
; 5.1 22 MARKED OPEN (SPECIFIC TEAM)
; 6 7 SPECIFIC POSITION
; 6.1 23 MARKED OPEN (SPEICIFIC POSITION)
; 7 8 SERVICE /SPECIALTY
; 8 9 SPECIFIC CLINIC
; 9 10 ORIGINATING USER
; 10 11 PRIORITY
; 11 12 REQUESTED BY
; 12 13 PROVIDER
; 22 16 DESIRED DATE OF APPT
; 23 17 CURRENT STATUS
; 25 18 COMMENTS
; 27 20 NEW ENROLLE
;
; Reference/ICR
; Registration/4943
;
N DIERR,SDWLDAX
I '$D(^SDWL(409.3,"B",SDWLDFN)) S SDWLRES=-1 Q ;- No Entry in Wait List file.
S SDWLDA="" F S SDWLDA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDA)) Q:SDWLDA<1 D
.S SDWLDAX="`"_SDWLDA
.D FIND^DIC(409.3,,".01;1;2;3;4;5;5.1;6;6.1;7;8;9;10;11;12;15;22;23;25","PS",.SDWLDAX)
I $G(DIERR) D CLEAN^DILF S SDWLRES=-1 Q
K SDWLOUT S SDWLOUT=$NA(^TMP("DILIST",$J))
Q
OUTPUT1(SDWLOUT,SDWLDFN) ;
;Brief Output - for Wait List.
; input:
; DFN = Patient
; Lookup uses Wait List data file (409.3) and returns the following data.
;
; output:
; SWDLRES = On/Not on Wait list^Number of IENs^IEN;IEN;IEN;IEN.....
; 1 0 ^ 2 ^1;2
;
S SDWLCNT=0,SDWLIEN=""
I '$D(^SDWL(409.3,"B",SDWLDFN)) S SDWLRES=$NA(^TMP("SDWLRP1",$J)),^TMP("SDWLRP1",$J,1)=-1
S SDWLDA="" F S SDWLDA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDA)) Q:SDWLDA<1 D
.I $P(^SDWL(409.3,SDWLDA,0),U,17)["C" Q
.S SDWLCNT=SDWLCNT+1
.S ^TMP("SDWLRP1",$J,SDWLCNT)=SDWLDA_"^"_$G(^SDWL(409.3,SDWLDA,0))
S SDWLOUT=$NA(^TMP("SDWLRP1",$J))
K SDWLDFN,SDWLDA,SDWLCNT,SDWLIEN
Q
OUTPUT3(SDWLOUT,SDWLDFN) ;Disposition Data
; input:
; DFN = Patient Internal ID
;
; output: Subscript 'DIS'
; Date Dispositioned^Disposition by^Disposition
;
N SDWLRES,SDWLDFN,SDWLDA,DIERR
I '$D(^SDWL(409.3,"B",SDWLDFN)) S SDWLRES=-1 Q ;- No Entry in Wait List file.
S SDWLDA="" F S SDWLDA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDA)) Q:SDWLDA<1 D
.S SDWLDAX="`"_SDWLDA
.D FIND^DIC(409.3,,"19;20;21","PS",.SDWLDAX)
I $G(DIERR) D CLEAN^DILF S SDWLRES=-1 Q
K SDWLOUT S SDWLOUT="^TMP(""DILIST"","_$J_")",SDWLRES=1
Q
INPUT(SDWLRES,SDWLSTR) ;
; Input:
; SDWLSTR = location of data = ^TMP("SDWLG",$J,i,0)
; (R) = Required Field
; (O) = Optional
;
; .01 2 3 5 6
; DFN (R)^TYPE (R)^SPECIFIC TEAM (O)^SPECIFIC POSITION (O)^ORGINATING USER (R)^COMMENT (O)^CLINIC (O)^INTRA FLAG (O)^REJ FLAG (O)^MULTI TEAM FLAG (O)
; 1 2 3 4 5 6 7 8 9 10
;
; Output:
; SDWLRES = 0 Failed
; SDWLRES = 1^IEN Saved to ^SDWL(409.3,IEN,0)
;
N DIERR,%H,SDWLF,SDWLFLD,SDWLFLG,SDWLI,SDWLIN,SDWLMSG,SDWLRNED,SDWLTP,SDWLVAL,SDWLX,SDWLY,X,Y
K ^TMP("SDWLIN",$J),^TMP("SDWLOUT",$J),^TMP("DIERR",$J)
I '$G(SDWLSTR) S SDWLRES="-1^Data String Missing" Q
D NEW
D FDA I SDWLRES<0 D DEL Q
;D VAL I SDWLRES<0 D DEL Q
D SET I SDWLRES<0 D DEL Q
D CLEAN^DILF K ^TMP("SDWLIN",$J),^TMP("SDWLOUT",$J)
; SD*5.3*611 stops variables SDWLDUZ,SDWLDFN,SDWLDA from being killed until END^SDWLE113
K Y
Q
NEW ;Get IEN from ^SDWL(409.3,IEN,0).
N DA,DIC,DIE,DIK,DR,SDREJ,SDINTRA,SDMULTI
I $P(SDWLSTR,U,4) D
.S SDWLTP=+$P(SDWLSTR,U,4)
.S SDWLIN=$P($G(^SCTM(404.51,+$P(^SCTM(404.57,SDWLTP,0),U,2),0)),U,7)
I $P(SDWLSTR,U,3) D
.S SDWLIN=$P($G(^SCTM(404.51,+$P(SDWLSTR,U,3),0)),U,7)
S SDWLDFN=+$P(SDWLSTR,U,1)
S SDREJ=$P(SDWLSTR,U,9),SDINTRA=$P(SDWLSTR,U,8),SDMULTI=$P(SDWLSTR,U,10)
;identify INTRA-transfer
;- last team assignment
S DIC(0)="LX",X=$P(SDWLSTR,U,1),DIC="^SDWL(409.3," D FILE^DICN I Y<0 S SDWLRES="-1^IEN failed" Q
S SDWLDFN=$P(Y,U,2),SDWLDA=+Y,SDWLDUZ=$P(SDWLSTR,U,9)
S DIE="^SDWL(409.3,",DA=SDWLDA
S DR="1///^S X=DT" D ^DIE
S DR="2////^S X=SDWLIN;32////^S X=SDREJ;34////^S X=SDINTRA;38////^S X=SDMULTI" D ^DIE
S DR="23///^S X=""O""",DIE="^SDWL(409.3," D ^DIE
;
;DETERMINE ENROLLEE STATUS
;
;SDWLE=1 = NEW ENROLLEE
;SDWLE=2 = ESTABLISHED
;SDWLE=3 = PRIOR ENROLLEE
;SDWLE=4 = UNDETERMINED
;
S SDWLDE=+$H,SDWLE=0,(SDWLEE,SDWLRNED,SDWLDB)=0 D SB1
G SB0:SDWLE=2
S SDWLRNE=$$ENROLL^EASWTAPI(SDWLDFN) G SB0:$P(SDWLRNE,U,4)="A" S SDWLRNED=$P(SDWLRNE,U,3)
I SDWLRNED S X=SDWLRNED D H^%DTC S SDWLDS=%H S SDWLDE=+$H,SDWLDET=SDWLDE-SDWLDS,SDWLDB=2 I SDWLDET<366 S SDWLE=1
I $D(SDWLDET),SDWLDET>365 S SDWLE=3
I 'SDWLRNE S SDWLE=4
SB0 I $D(SDWLRNE),$P(SDWLRNE,U,4)="A" D
.I 'SDWLRNE,SDWLEE>730!(SDWLEE=730) S SDWLE=4 Q
.I 'SDWLEE S SDWLE=4 Q
S SDWLRNE=$S(SDWLE=1:"N",SDWLE=2:"E",SDWLE=3:"P",SDWLE=4:"U",1:"U")
;-Code here for filling in 409.3
S DR="27////^S X=SDWLRNE",DIE="^SDWL(409.3,",DA=SDWLDA D ^DIE
S DR="9////^S X=DUZ" D ^DIE
S DR="27.1////^S X=$S($G(SDWLRNED):SDWLRNED,$G(SDWLD):SDWLD,1:"""")" D ^DIE
S DR="27.2////^S X=SDWLDB" D ^DIE
K SDWLRNE,SDWLD,SDWLDE,SDWLEE,SDWLDET,DIC,DIR,DR,DIE,SDWLDS,SDWLE
Q
SB1 I '$D(^DGCN(391.91,"B",SDWLDFN)) N SDWLDB S SDWLE=3 Q
S SDWLX="" F S SDWLX=$O(^DGCN(391.91,"B",SDWLDFN,SDWLX)) Q:SDWLX="" D
.S SDWLY=$P($G(^DGCN(391.91,SDWLX,0)),U,2,3) D
..;CHECK FOR TREATING FACILITY
..I $$TF^XUAF4(+$P(SDWLY,U)) D
...;SORT FOR LAST TREATMENT DATE
...S SDWLD=$P(SDWLY,U,2) I SDWLD S SDWLDTF(9999999-SDWLD)=SDWLX
I '$D(SDWLDTF) Q
S SDWLDTF=$O(SDWLDTF(0)) I SDWLDTF S (SDWLD,X)=9999999-SDWLDTF D H^%DTC S SDWLEE=SDWLDE-%H,SDWLDB=1 I SDWLEE<730 S SDWLE=2
I $D(SDWLEE),SDWLEE>730!(SDWLEE=730) S SDWLE=3
K SDWLDTF
Q
FDA ;Get data from SDWLSTR string and set FDA.
S SDWLF=409.3
S SDWLVAL="" F SDWLI=2:1:7 S SDWLVAL=$P(SDWLSTR,"^",SDWLI) D
.S SDWLFLD=SDWLI D
..S SDWLFLD=$S(SDWLFLD=2:4,SDWLFLD=3:5,SDWLFLD=4:6,SDWLFLD=5:9,SDWLFLD=7:15,1:25)
.S SDWLFLG="F",SDWLIEN=$$IENS^DILF(SDWLDA) ;,SDWLVAL=$$EXTERNAL^DILFD(SDWLF,SDWLFLD,,SDWLVAL,"SDWLMSG")
.I $D(SDWLMSG) M SDWLRES=SDWLMSG S SDWLRES=-1 Q
.D FDA^DILF(SDWLF,SDWLIEN,SDWLFLD,"",SDWLVAL,"^TMP(""SDWLIN"",$J)")
.S SDWLRES=1 M SDWLRES("SDWLIN")=^TMP("SDWLIN",$J)
Q
VAL ;Validate fields
N DIERR
D VALS^DIE(,"^TMP(""SDWLIN"",$J)","^TMP(""SDWLOUT"",$J)","SDWLMSG")
I $G(SDWLMSG("DIERR")) S SDWLRES=-1 Q
M SDWLRES("SDWLOUT")=^TMP("SDWLOUT",$J)
Q
SET ;Input data to file ^SDWL(409.3,IEN,0).
D UPDATE^DIE(,"^TMP(""SDWLIN"",$J)","SDWLMSG")
I $G(SDWLMSG("DIERR")) S SDWLRES=-1 Q
S SDWLRES=1_"^"_$G(SDWLDA)
Q
DEL S DA=SDWLDA,DIK="^SDWL(409.3," D ^DIK
S SDWLRES="-1^Entry "_SDWLDA_" Deleted"
Q
INPUTDP(SDWLRES,SDWLSTR) ;Set disposition in Wait List Patient file
;
; Input:
;
; SDWLSTR=Patient DFN^Disposition^User DUZ^Wait List IEN
;
; Ouput:
;
; SDWLRES=-1 Failed
; SDWKRES=1^IEN for Wait List File (409.3)
;
N SDWLDFN,SDWLDISP,SDWLDUZ,SDWLDA,SDWLDDT
I '$G(SDWLSTR) S SDWLRES="-1^Data String Missing" Q
I '$G(^SDWL(409.3,SDWLDA,0)) S SDWLRES="-1^Missing Patient IEN" Q
I '$D(^SDWL(409.3,"B",SDWLDFN)) S SDWLRES="-1^Missing Wait List data file" Q
D FDA1 I SDWLRES<0 D DEL1 Q
D VAL1 I SDWLRES<0 D DEL1 Q
D SET1 I SDWLRES<0 D DEL1 Q
D CLEAN^DILF K ^TMP("SDWLIN",$J),^TMP("SDWLOUT",$J)
Q
FDA1 ;
S SDWLDFN=$P(SDWLSTR,U,1),SDWLDISP=$P(SDWLSTR,U,2),SDWLDUZ=$P(SDWLSTR,U,3),SDWLDA=$P(SDWLSTR,U,4),SDWLDDT=DT
S SDWLIEN=$$IENS^DILF(SDWLDA)
F SDWLI=1:1:4 S SDWLVAL=$S(SDWLI=1:SDWLDISP,SDWLI=2:SDWLDUZ,SDWLI=3:SDWLDDT,SDWLI=4:"C"),SDWLFLD=$S(SDWLI=1:21,SDWLI=2:20,SDWLI=3:19,SDWLI=4:23) D
.S SDWLVAL=$$EXTERNAL^DILFD(SDWLF,SDWLFLD,,SDWLVAL,"SDWLMSG")
.I $D(SDWLMSG) M SDWLRES=SDWLMSG S SDWLRES=-1 Q
.D FDA^DILF(SDWLF,SDWLIEN,SDWLFLD,"",SDWLVAL,"^TMP(""SDWLIN"",$J)")
.S SDWLRES=1 M SDWLRES("SDWLIN")=^TMP("SDWLIN",$J)
Q
VAL1 ;
N DIERR
D VALS^DIE(,"^TMP(""SDWLIN"",$J)","^TMP(""SDWLOUT"",$J)","SDWLMSG")
I $G(SDWLMSG("DIERR")) S SDWLRES=-1 Q
M SDWLRES("SDWLOUT")=^TMP("SDWLOUT",$J)
Q
SET1 ;
D UPDATE^DIE(,"^TMP(""SDWLOUT"",$J)","SDWLMSG")
I $G(SDWLMSG("DIERR")) S SDWLRES=-1 Q
S SDWLRES=1
Q
DEL1 ;
S DA(1)=SDWLDA,DIK="^SDWL("_DA(1)_",""DIS""," F DA=19,20,21,23 D ^DIK
S SDWLRES="-1^"_"Disposition Nodes Deleted."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLRP1 10224 printed Oct 16, 2024@19:03:36 Page 2
SDWLRP1 ;;IOFO BAY PINES/TEH - WAITING LIST - RPC;06/28/2002 ; 26 Aug 2002 1:25 PM ; Compiled April 16, 2007 10:15:05
+1 ;;5.3;scheduling;**263,273,485,497,446,611**;AUG 13 1993;Build 9
+2 ;
+3 ;
+4 ;******************************************************************
+5 ; CHANGE LOG
+6 ;
+7 ; DATE PATCH DESCRIPTION
+8 ; ---- ----- -----------
+9 ; 2/21/03 SD*5.3*273 Line new+12 added "/"
+10 ; 5/10/06 SD*5.3*446 New field: INTRA-transfer
+11 ; 1/14/14 SD*5.3*611 Removed variables SDWLDUZ,SDWLDFN,SDWLDA from kill command
OUTPUT(SDWLOUT,SDWLDFN) ;-FULL
+1 ; input:
+2 ; DFN = Patient
+3 ; Lookup uses Wait List data file (409.3) and returns the following data.
+4 ;
+5 ; output:
+6 ; SCOUT = location of data = ^TMP("SDWLG",$J,i,0)
+7 ; for i=1:number of records returned:
+8 ;
+9 ; Field Location Description
+10 ; 1 2 ORIGINATION DATE
+11 ; 2 3 INSTITUTION
+12 ; 3 4 CLINIC
+13 ; 4 5 WAIT LIST TYPE
+14 ; 5 6 SPECIFIC TEAM
+15 ; 5.1 22 MARKED OPEN (SPECIFIC TEAM)
+16 ; 6 7 SPECIFIC POSITION
+17 ; 6.1 23 MARKED OPEN (SPEICIFIC POSITION)
+18 ; 7 8 SERVICE /SPECIALTY
+19 ; 8 9 SPECIFIC CLINIC
+20 ; 9 10 ORIGINATING USER
+21 ; 10 11 PRIORITY
+22 ; 11 12 REQUESTED BY
+23 ; 12 13 PROVIDER
+24 ; 22 16 DESIRED DATE OF APPT
+25 ; 23 17 CURRENT STATUS
+26 ; 25 18 COMMENTS
+27 ; 27 20 NEW ENROLLE
+28 ;
+29 ; Reference/ICR
+30 ; Registration/4943
+31 ;
+32 NEW DIERR,SDWLDAX
+33 ;- No Entry in Wait List file.
IF '$DATA(^SDWL(409.3,"B",SDWLDFN))
SET SDWLRES=-1
QUIT
+34 SET SDWLDA=""
FOR
SET SDWLDA=$ORDER(^SDWL(409.3,"B",SDWLDFN,SDWLDA))
if SDWLDA<1
QUIT
Begin DoDot:1
+35 SET SDWLDAX="`"_SDWLDA
+36 DO FIND^DIC(409.3,,".01;1;2;3;4;5;5.1;6;6.1;7;8;9;10;11;12;15;22;23;25","PS",.SDWLDAX)
End DoDot:1
+37 IF $GET(DIERR)
DO CLEAN^DILF
SET SDWLRES=-1
QUIT
+38 KILL SDWLOUT
SET SDWLOUT=$NAME(^TMP("DILIST",$JOB))
+39 QUIT
OUTPUT1(SDWLOUT,SDWLDFN) ;
+1 ;Brief Output - for Wait List.
+2 ; input:
+3 ; DFN = Patient
+4 ; Lookup uses Wait List data file (409.3) and returns the following data.
+5 ;
+6 ; output:
+7 ; SWDLRES = On/Not on Wait list^Number of IENs^IEN;IEN;IEN;IEN.....
+8 ; 1 0 ^ 2 ^1;2
+9 ;
+10 SET SDWLCNT=0
SET SDWLIEN=""
+11 IF '$DATA(^SDWL(409.3,"B",SDWLDFN))
SET SDWLRES=$NAME(^TMP("SDWLRP1",$JOB))
SET ^TMP("SDWLRP1",$JOB,1)=-1
+12 SET SDWLDA=""
FOR
SET SDWLDA=$ORDER(^SDWL(409.3,"B",SDWLDFN,SDWLDA))
if SDWLDA<1
QUIT
Begin DoDot:1
+13 IF $PIECE(^SDWL(409.3,SDWLDA,0),U,17)["C"
QUIT
+14 SET SDWLCNT=SDWLCNT+1
+15 SET ^TMP("SDWLRP1",$JOB,SDWLCNT)=SDWLDA_"^"_$GET(^SDWL(409.3,SDWLDA,0))
End DoDot:1
+16 SET SDWLOUT=$NAME(^TMP("SDWLRP1",$JOB))
+17 KILL SDWLDFN,SDWLDA,SDWLCNT,SDWLIEN
+18 QUIT
OUTPUT3(SDWLOUT,SDWLDFN) ;Disposition Data
+1 ; input:
+2 ; DFN = Patient Internal ID
+3 ;
+4 ; output: Subscript 'DIS'
+5 ; Date Dispositioned^Disposition by^Disposition
+6 ;
+7 NEW SDWLRES,SDWLDFN,SDWLDA,DIERR
+8 ;- No Entry in Wait List file.
IF '$DATA(^SDWL(409.3,"B",SDWLDFN))
SET SDWLRES=-1
QUIT
+9 SET SDWLDA=""
FOR
SET SDWLDA=$ORDER(^SDWL(409.3,"B",SDWLDFN,SDWLDA))
if SDWLDA<1
QUIT
Begin DoDot:1
+10 SET SDWLDAX="`"_SDWLDA
+11 DO FIND^DIC(409.3,,"19;20;21","PS",.SDWLDAX)
End DoDot:1
+12 IF $GET(DIERR)
DO CLEAN^DILF
SET SDWLRES=-1
QUIT
+13 KILL SDWLOUT
SET SDWLOUT="^TMP(""DILIST"","_$JOB_")"
SET SDWLRES=1
+14 QUIT
INPUT(SDWLRES,SDWLSTR) ;
+1 ; Input:
+2 ; SDWLSTR = location of data = ^TMP("SDWLG",$J,i,0)
+3 ; (R) = Required Field
+4 ; (O) = Optional
+5 ;
+6 ; .01 2 3 5 6
+7 ; DFN (R)^TYPE (R)^SPECIFIC TEAM (O)^SPECIFIC POSITION (O)^ORGINATING USER (R)^COMMENT (O)^CLINIC (O)^INTRA FLAG (O)^REJ FLAG (O)^MULTI TEAM FLAG (O)
+8 ; 1 2 3 4 5 6 7 8 9 10
+9 ;
+10 ; Output:
+11 ; SDWLRES = 0 Failed
+12 ; SDWLRES = 1^IEN Saved to ^SDWL(409.3,IEN,0)
+13 ;
+14 NEW DIERR,%H,SDWLF,SDWLFLD,SDWLFLG,SDWLI,SDWLIN,SDWLMSG,SDWLRNED,SDWLTP,SDWLVAL,SDWLX,SDWLY,X,Y
+15 KILL ^TMP("SDWLIN",$JOB),^TMP("SDWLOUT",$JOB),^TMP("DIERR",$JOB)
+16 IF '$GET(SDWLSTR)
SET SDWLRES="-1^Data String Missing"
QUIT
+17 DO NEW
+18 DO FDA
IF SDWLRES<0
DO DEL
QUIT
+19 ;D VAL I SDWLRES<0 D DEL Q
+20 DO SET
IF SDWLRES<0
DO DEL
QUIT
+21 DO CLEAN^DILF
KILL ^TMP("SDWLIN",$JOB),^TMP("SDWLOUT",$JOB)
+22 ; SD*5.3*611 stops variables SDWLDUZ,SDWLDFN,SDWLDA from being killed until END^SDWLE113
+23 KILL Y
+24 QUIT
NEW ;Get IEN from ^SDWL(409.3,IEN,0).
+1 NEW DA,DIC,DIE,DIK,DR,SDREJ,SDINTRA,SDMULTI
+2 IF $PIECE(SDWLSTR,U,4)
Begin DoDot:1
+3 SET SDWLTP=+$PIECE(SDWLSTR,U,4)
+4 SET SDWLIN=$PIECE($GET(^SCTM(404.51,+$PIECE(^SCTM(404.57,SDWLTP,0),U,2),0)),U,7)
End DoDot:1
+5 IF $PIECE(SDWLSTR,U,3)
Begin DoDot:1
+6 SET SDWLIN=$PIECE($GET(^SCTM(404.51,+$PIECE(SDWLSTR,U,3),0)),U,7)
End DoDot:1
+7 SET SDWLDFN=+$PIECE(SDWLSTR,U,1)
+8 SET SDREJ=$PIECE(SDWLSTR,U,9)
SET SDINTRA=$PIECE(SDWLSTR,U,8)
SET SDMULTI=$PIECE(SDWLSTR,U,10)
+9 ;identify INTRA-transfer
+10 ;- last team assignment
+11 SET DIC(0)="LX"
SET X=$PIECE(SDWLSTR,U,1)
SET DIC="^SDWL(409.3,"
DO FILE^DICN
IF Y<0
SET SDWLRES="-1^IEN failed"
QUIT
+12 SET SDWLDFN=$PIECE(Y,U,2)
SET SDWLDA=+Y
SET SDWLDUZ=$PIECE(SDWLSTR,U,9)
+13 SET DIE="^SDWL(409.3,"
SET DA=SDWLDA
+14 SET DR="1///^S X=DT"
DO ^DIE
+15 SET DR="2////^S X=SDWLIN;32////^S X=SDREJ;34////^S X=SDINTRA;38////^S X=SDMULTI"
DO ^DIE
+16 SET DR="23///^S X=""O"""
SET DIE="^SDWL(409.3,"
DO ^DIE
+17 ;
+18 ;DETERMINE ENROLLEE STATUS
+19 ;
+20 ;SDWLE=1 = NEW ENROLLEE
+21 ;SDWLE=2 = ESTABLISHED
+22 ;SDWLE=3 = PRIOR ENROLLEE
+23 ;SDWLE=4 = UNDETERMINED
+24 ;
+25 SET SDWLDE=+$HOROLOG
SET SDWLE=0
SET (SDWLEE,SDWLRNED,SDWLDB)=0
DO SB1
+26 if SDWLE=2
GOTO SB0
+27 SET SDWLRNE=$$ENROLL^EASWTAPI(SDWLDFN)
if $PIECE(SDWLRNE,U,4)="A"
GOTO SB0
SET SDWLRNED=$PIECE(SDWLRNE,U,3)
+28 IF SDWLRNED
SET X=SDWLRNED
DO H^%DTC
SET SDWLDS=%H
SET SDWLDE=+$HOROLOG
SET SDWLDET=SDWLDE-SDWLDS
SET SDWLDB=2
IF SDWLDET<366
SET SDWLE=1
+29 IF $DATA(SDWLDET)
IF SDWLDET>365
SET SDWLE=3
+30 IF 'SDWLRNE
SET SDWLE=4
SB0 IF $DATA(SDWLRNE)
IF $PIECE(SDWLRNE,U,4)="A"
Begin DoDot:1
+1 IF 'SDWLRNE
IF SDWLEE>730!(SDWLEE=730)
SET SDWLE=4
QUIT
+2 IF 'SDWLEE
SET SDWLE=4
QUIT
End DoDot:1
+3 SET SDWLRNE=$SELECT(SDWLE=1:"N",SDWLE=2:"E",SDWLE=3:"P",SDWLE=4:"U",1:"U")
+4 ;-Code here for filling in 409.3
+5 SET DR="27////^S X=SDWLRNE"
SET DIE="^SDWL(409.3,"
SET DA=SDWLDA
DO ^DIE
+6 SET DR="9////^S X=DUZ"
DO ^DIE
+7 SET DR="27.1////^S X=$S($G(SDWLRNED):SDWLRNED,$G(SDWLD):SDWLD,1:"""")"
DO ^DIE
+8 SET DR="27.2////^S X=SDWLDB"
DO ^DIE
+9 KILL SDWLRNE,SDWLD,SDWLDE,SDWLEE,SDWLDET,DIC,DIR,DR,DIE,SDWLDS,SDWLE
+10 QUIT
SB1 IF '$DATA(^DGCN(391.91,"B",SDWLDFN))
NEW SDWLDB
SET SDWLE=3
QUIT
+1 SET SDWLX=""
FOR
SET SDWLX=$ORDER(^DGCN(391.91,"B",SDWLDFN,SDWLX))
if SDWLX=""
QUIT
Begin DoDot:1
+2 SET SDWLY=$PIECE($GET(^DGCN(391.91,SDWLX,0)),U,2,3)
Begin DoDot:2
+3 ;CHECK FOR TREATING FACILITY
+4 IF $$TF^XUAF4(+$PIECE(SDWLY,U))
Begin DoDot:3
+5 ;SORT FOR LAST TREATMENT DATE
+6 SET SDWLD=$PIECE(SDWLY,U,2)
IF SDWLD
SET SDWLDTF(9999999-SDWLD)=SDWLX
End DoDot:3
End DoDot:2
End DoDot:1
+7 IF '$DATA(SDWLDTF)
QUIT
+8 SET SDWLDTF=$ORDER(SDWLDTF(0))
IF SDWLDTF
SET (SDWLD,X)=9999999-SDWLDTF
DO H^%DTC
SET SDWLEE=SDWLDE-%H
SET SDWLDB=1
IF SDWLEE<730
SET SDWLE=2
+9 IF $DATA(SDWLEE)
IF SDWLEE>730!(SDWLEE=730)
SET SDWLE=3
+10 KILL SDWLDTF
+11 QUIT
FDA ;Get data from SDWLSTR string and set FDA.
+1 SET SDWLF=409.3
+2 SET SDWLVAL=""
FOR SDWLI=2:1:7
SET SDWLVAL=$PIECE(SDWLSTR,"^",SDWLI)
Begin DoDot:1
+3 SET SDWLFLD=SDWLI
Begin DoDot:2
+4 SET SDWLFLD=$SELECT(SDWLFLD=2:4,SDWLFLD=3:5,SDWLFLD=4:6,SDWLFLD=5:9,SDWLFLD=7:15,1:25)
End DoDot:2
+5 ;,SDWLVAL=$$EXTERNAL^DILFD(SDWLF,SDWLFLD,,SDWLVAL,"SDWLMSG")
SET SDWLFLG="F"
SET SDWLIEN=$$IENS^DILF(SDWLDA)
+6 IF $DATA(SDWLMSG)
MERGE SDWLRES=SDWLMSG
SET SDWLRES=-1
QUIT
+7 DO FDA^DILF(SDWLF,SDWLIEN,SDWLFLD,"",SDWLVAL,"^TMP(""SDWLIN"",$J)")
+8 SET SDWLRES=1
MERGE SDWLRES("SDWLIN")=^TMP("SDWLIN",$JOB)
End DoDot:1
+9 QUIT
VAL ;Validate fields
+1 NEW DIERR
+2 DO VALS^DIE(,"^TMP(""SDWLIN"",$J)","^TMP(""SDWLOUT"",$J)","SDWLMSG")
+3 IF $GET(SDWLMSG("DIERR"))
SET SDWLRES=-1
QUIT
+4 MERGE SDWLRES("SDWLOUT")=^TMP("SDWLOUT",$JOB)
+5 QUIT
SET ;Input data to file ^SDWL(409.3,IEN,0).
+1 DO UPDATE^DIE(,"^TMP(""SDWLIN"",$J)","SDWLMSG")
+2 IF $GET(SDWLMSG("DIERR"))
SET SDWLRES=-1
QUIT
+3 SET SDWLRES=1_"^"_$GET(SDWLDA)
+4 QUIT
DEL SET DA=SDWLDA
SET DIK="^SDWL(409.3,"
DO ^DIK
+1 SET SDWLRES="-1^Entry "_SDWLDA_" Deleted"
+2 QUIT
INPUTDP(SDWLRES,SDWLSTR) ;Set disposition in Wait List Patient file
+1 ;
+2 ; Input:
+3 ;
+4 ; SDWLSTR=Patient DFN^Disposition^User DUZ^Wait List IEN
+5 ;
+6 ; Ouput:
+7 ;
+8 ; SDWLRES=-1 Failed
+9 ; SDWKRES=1^IEN for Wait List File (409.3)
+10 ;
+11 NEW SDWLDFN,SDWLDISP,SDWLDUZ,SDWLDA,SDWLDDT
+12 IF '$GET(SDWLSTR)
SET SDWLRES="-1^Data String Missing"
QUIT
+13 IF '$GET(^SDWL(409.3,SDWLDA,0))
SET SDWLRES="-1^Missing Patient IEN"
QUIT
+14 IF '$DATA(^SDWL(409.3,"B",SDWLDFN))
SET SDWLRES="-1^Missing Wait List data file"
QUIT
+15 DO FDA1
IF SDWLRES<0
DO DEL1
QUIT
+16 DO VAL1
IF SDWLRES<0
DO DEL1
QUIT
+17 DO SET1
IF SDWLRES<0
DO DEL1
QUIT
+18 DO CLEAN^DILF
KILL ^TMP("SDWLIN",$JOB),^TMP("SDWLOUT",$JOB)
+19 QUIT
FDA1 ;
+1 SET SDWLDFN=$PIECE(SDWLSTR,U,1)
SET SDWLDISP=$PIECE(SDWLSTR,U,2)
SET SDWLDUZ=$PIECE(SDWLSTR,U,3)
SET SDWLDA=$PIECE(SDWLSTR,U,4)
SET SDWLDDT=DT
+2 SET SDWLIEN=$$IENS^DILF(SDWLDA)
+3 FOR SDWLI=1:1:4
SET SDWLVAL=$SELECT(SDWLI=1:SDWLDISP,SDWLI=2:SDWLDUZ,SDWLI=3:SDWLDDT,SDWLI=4:"C")
SET SDWLFLD=$SELECT(SDWLI=1:21,SDWLI=2:20,SDWLI=3:19,SDWLI=4:23)
Begin DoDot:1
+4 SET SDWLVAL=$$EXTERNAL^DILFD(SDWLF,SDWLFLD,,SDWLVAL,"SDWLMSG")
+5 IF $DATA(SDWLMSG)
MERGE SDWLRES=SDWLMSG
SET SDWLRES=-1
QUIT
+6 DO FDA^DILF(SDWLF,SDWLIEN,SDWLFLD,"",SDWLVAL,"^TMP(""SDWLIN"",$J)")
+7 SET SDWLRES=1
MERGE SDWLRES("SDWLIN")=^TMP("SDWLIN",$JOB)
End DoDot:1
+8 QUIT
VAL1 ;
+1 NEW DIERR
+2 DO VALS^DIE(,"^TMP(""SDWLIN"",$J)","^TMP(""SDWLOUT"",$J)","SDWLMSG")
+3 IF $GET(SDWLMSG("DIERR"))
SET SDWLRES=-1
QUIT
+4 MERGE SDWLRES("SDWLOUT")=^TMP("SDWLOUT",$JOB)
+5 QUIT
SET1 ;
+1 DO UPDATE^DIE(,"^TMP(""SDWLOUT"",$J)","SDWLMSG")
+2 IF $GET(SDWLMSG("DIERR"))
SET SDWLRES=-1
QUIT
+3 SET SDWLRES=1
+4 QUIT
DEL1 ;
+1 SET DA(1)=SDWLDA
SET DIK="^SDWL("_DA(1)_",""DIS"","
FOR DA=19,20,21,23
DO ^DIK
+2 SET SDWLRES="-1^"_"Disposition Nodes Deleted."
+3 QUIT
