SDWLRP4 ;IOFO BAY PINES/TEH - WAITING LIST - MERGE RPC;06/28/2002 ; 26 Aug 2002 1:25 PM
;;5.3;scheduling;**263,485,497**;AUG 13 1993;Build 3
;
INPUT(SDWLRES,SDWLSTR) ;
;
;
; Input:
; SDWLSTR = location of data = ^TMP("SDWLG",$J,i,0)
; (R) = Required Field
; (O) = Optional
;
; .01 2 3 4 5 9 10 11 23 22
; SSN (R)^ORIGINATING DATE^INSTITUTION^TYPE (R)^^TYPE MOD^ORGINATING USER (R)^PRIORITY^REQUEST BY^CURRENT STATUS^DESIRED DATE
; 1 2 3 4 6/7/8/9 10 11 12 17 16
;
; Output:
; SDWLRES = -1^MESSAGE Failed
; SDWLRES = 1^IEN Saved to ^SDWL(409.3,IEN,0)
;
;
K ^TMP("SDWLIN",$J),^TMP("SDWLOUT",$J),^TMP("DIERR",$J),D
I '$G(SDWLSTR) S SDWLRES="-1^Data String Missing^Failed" Q
I $P(SDWLSTR,U)="" S SDWLRES="-1^No SSN^Failed" Q
I $P(SDWLSTR,U,3)="" S SDWLRES="-1^No Insitution^Failed" Q
I $P(SDWLSTR,U,4)="" S SDWLRES="-1^No Type^Failed" Q
I $P(SDWLSTR,U,6)="",$P(SDWLSTR,U,7)="",$P(SDWLSTR,U,8)="",$P(SDWLSTR,U,9)="" S SDWLRES="-1^No Type Modifier^Failed" Q
I $P(SDWLSTR,U,11)'="",$$DCHK($P(SDWLSTR,U,11))<1 S SDWLRES="-1^Invalid Date^Failed" Q
S $P(SDWLSTR,U)=$TR($P(SDWLSTR,U),"-","")
D NEW
I $P(SDWLRES,U,1)<0 Q
D FDA I SDWLRES<0 D DEL Q
D SET I SDWLRES<0 D DEL Q
D CLEAN^DILF K ^TMP("SDWLIN",$J),^TMP("SDWLOUT",$J)
Q
NEW ;Get IEN from ^SDWL(409.3,IEN,0).
N SDWLTP,SDWL6,SDWL6P,SDWL7,SDWL7P,SDWL8,SDWL8P,SDWL9,SDWL9P,SDWLMOD,SDWLTP,SDWLIN,SDWLDFN
N SDWLPRI,SDWLODUZ,SDWLRBY
S SDWLRES=""
I $P(SDWLSTR,U,4) D
.S SDWLTP=+$P(SDWLSTR,U,4),(SDWL6,SDWL7,SDWL8,SDWL9)="",SDWLMOD=0 D
..I SDWLTP=1 S SDWL6=$P(SDWLSTR,U,6),SDWL6=$O(^SCTM(404.51,"B",SDWL6,"")) I SDWL6'="" S SDWL6P=$O(^SCTM(404.51,"B",SDWL6,0)),SDWLMOD=1
..I SDWLTP=2 S SDWL7=$P(SDWLSTR,U,7),SDWL7=$O(^SCTM(404.57,"B",SDWL7,"")) I SDWL7'="" S SDWL7P=$O(^SCTM(404.57,"B",SDWL7,0)),SDWLMOD=1
..I SDWLTP=3 S SDWL8=$P(SDWLSTR,U,8),SDWL80="" F S SDWL80=$O(^DIC(40.7,"B",SDWL8,SDWL80)) Q:SDWL80="" D
...I $D(^SDWL(409.31,"B",SDWL80)) S SDWL8=$O(^SDWL(409.31,"B",SDWL80,0)),$P(SDWLSTR,U,8)=SDWL8,SDWLMOD=1
..I SDWLTP=4 S SDWL9=$P(SDWLSTR,U,9),SDWL90="" F SDWL90=$O(^SC("B",SDWL9,SDWL90)) Q:SDWL90="" D
...I $D(^SDWL(409.32,"B",SDWL90)) S SDWL9=$O(^SDWL(409.32,"B",SDWL90,0)),$P(SDWLSTR,U,9)=SDWL9,SDWLMOD=1
I 'SDWLMOD S SDWLRES="-1^No Type Mod found^Failed" Q
S SDWLIN=$P(SDWLSTR,U,3) I SDWLIN="" S SDWLRES="-1^No Institution^Failed" Q
S SDWLIN=$O(^DIC(4,"B",SDWLIN,0)) I SDWLIN="" S SDWLRES="-1^Invalid Institution^Failed" Q
S SDWLDFN=$P(SDWLSTR,U,1) S D="SSN",DIC(0)="MNZ",X=SDWLDFN,D="SSN",DIC=2 D IX^DIC I Y<0 S SDWLRES="-1^SSN failed" Q
S SDWLDFN=+Y
I SDWLDFN="" S SDWLRES="-1^Invalid SSN^Failed" Q
I $$DUP(SDWLDFN) S SDWLRES="-1^Duplicate^Failed" Q
S SDWLPRI=$S($P(SDWLSTR,U,11)="":"A",1:"F")
S SDWLODUZ=.5,SDWLRBY=2
I SDWLTP=1!(SDWLTP=2) S SDWLPRI="A",SDWLRBY=""
S SDWLSTRN=SDWLTP_"^"_SDWLPRI_"^"_SDWLODUZ_"^"_SDWLRBY_"^"_SDWL6_"^"_SDWL7_"^"_SDWL8_"^"_SDWL9
S DIC(0)="LX",X=SDWLDFN,DIC="^SDWL(409.3," D FILE^DICN I Y<0 S SDWLRES="-1^IEN failed^Failed" Q
S SDWLDFN=$P(Y,U,2),SDWLDA=+Y,SDWLDUZ=$P(SDWLSTR,U,9)
S DIE="^SDWL(409.3,",DA=SDWLDA
I SDWLPRI="F" D
.S DR="22///"_$P(SDWLSTR,U,11) D ^DIE
I SDWLPRI="A",SDWLTP=3!(SDWLTP=4) D
.S DR="22///^S X=DT" D ^DIE
S DR="1////^S X=DT" D ^DIE
S DR="2////^S X=SDWLIN" D ^DIE
S DR="23////^S X=""O""",DIE="^SDWL(409.3," D ^DIE K DIE,DR,DA
;
;SET DATE OF DEATH
;
S X=$$GET1^DIQ(2,SDWLDFN_",",".351") I X'="" D
.S DA=SDWLDA
.S DR="19////^S X=DT",DIE="^SDWL(409.3," D ^DIE
.S DR="20////^S X=DUZ" D ^DIE
.S DR="23////^S X=""C""" D ^DIE
.S DR="21////^S X=""D""" D ^DIE K DIE,DR,DA
;
;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 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 'SDWLEE.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="27.1////^S X=$S($G(SDWLRNED):SDWLRNED,$G(SDWLD):SDWLD,1:"""")" D ^DIE
S DR="27.2////^S X=SDWLDB" D ^DIE
S DR="9////^S X=DUZ" D ^DIE K DIE,DA,DR,%H
K SDWLRNE,SDWLD,SDWLDE,SDWLEE,SDWLDET,DIC,DIR,DR,DIE,SDWLDS,SDWLE,SDWLRNED
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=$G(^DGCN(391.91,SDWLX,0)) D
..;CHECK FOR TREATING FACILITY
..I $$TF^XUAF4(+$P(SDWLY,U,2)) D
...;SORT FOR LAST TREATMENT DATE
...S SDWLD=$P(SDWLY,U,3) 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 S SDWLE=3
K SDWLDTF
Q
FDA ;Get data from SDWLSTR string and set FDA.
S SDWLF=409.3
S SDWLVAL="" F SDWLI=1,2,3,4,5,6,7,8 S SDWLVAL=$P(SDWLSTRN,"^",SDWLI) D
.S SDWLFLD=SDWLI D
..S SDWLFLD=$S(SDWLFLD=1:4,SDWLFLD=2:10,SDWLFLD=3:9,SDWLFLD=4:11,SDWLFLD=5:5,SDWLFLD=6:6,SDWLFLD=7:7,SDWLFLD=8:8)
.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
;
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
K DIC,DA
S SDWLRES=1_"^"_$G(SDWLDA)
Q
DEL S DA=SDWLDA,DIK="^SDWL(409.3," D ^DIK K DIK,DA
S SDWLRES="-1^Entry "_SDWLDA_" Deleted"
Q
DUP(IEN) ;Duplicate Check
;if institution, wait list type, and wait list modifier are the same it's a duplicate
;SDWLV1 : IEN in 409.3
;SDWLV2 : Zero node of 409.3
;SDWLV3 : Wait List Type Modifier value passed in
;SDWLV4 : Wait List Type Modifier value in current record
;SDWLIN : Institution value passed in checked against piece 3 of current record
;SDWLSTR : Incoming value string
; Wait List Type piece 4 of SDWLSTR (incoming value) checked against piece 5
; of SDWLV2 (zero node of current record
N SDWLV1,SDWLV2,SDWLV3,SDWLV4,SDWLV5
S (SDWLV1,SDWLV5)=0
F S SDWLV1=$O(^SDWL(409.3,"B",IEN,SDWLV1)) Q:('SDWLV1!SDWLV5) D
. S SDWLV2=$G(^SDWL(409.3,SDWLV1,0)) Q:SDWLV2=""
. S SDWLV3=$S($P(SDWLSTR,U,4)=1:SDWL6,$P(SDWLSTR,U,4)=2:SDWL7,$P(SDWLSTR,U,4)=3:SDWL8,$P(SDWLSTR,U,4)=4:SDWL9,1:0)
. S SDWLV4=$S($P(SDWLV2,U,5)=1:$P(SDWLV2,U,6),$P(SDWLV2,U,5)=2:$P(SDWLV2,U,7),$P(SDWLV2,U,5)=3:$P(SDWLV2,U,8),$P(SDWLV2,U,5)=4:$P(SDWLV2,U,9),1:0)
. I $P(SDWLV2,U,3)=SDWLIN,$P(SDWLSTR,U,4)=$P(SDWLV2,U,5),SDWLV3=SDWLV4 S SDWLV5=1 Q
Q SDWLV5
DCHK(VALID) ;Check for valid DESIRED DATE
N X
S X=VALID,%DT="X" D ^%DT
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLRP4 7603 printed Apr 09, 2024@21:54:55 Page 2
SDWLRP4 ;IOFO BAY PINES/TEH - WAITING LIST - MERGE RPC;06/28/2002 ; 26 Aug 2002 1:25 PM
+1 ;;5.3;scheduling;**263,485,497**;AUG 13 1993;Build 3
+2 ;
INPUT(SDWLRES,SDWLSTR) ;
+1 ;
+2 ;
+3 ; Input:
+4 ; SDWLSTR = location of data = ^TMP("SDWLG",$J,i,0)
+5 ; (R) = Required Field
+6 ; (O) = Optional
+7 ;
+8 ; .01 2 3 4 5 9 10 11 23 22
+9 ; SSN (R)^ORIGINATING DATE^INSTITUTION^TYPE (R)^^TYPE MOD^ORGINATING USER (R)^PRIORITY^REQUEST BY^CURRENT STATUS^DESIRED DATE
+10 ; 1 2 3 4 6/7/8/9 10 11 12 17 16
+11 ;
+12 ; Output:
+13 ; SDWLRES = -1^MESSAGE Failed
+14 ; SDWLRES = 1^IEN Saved to ^SDWL(409.3,IEN,0)
+15 ;
+16 ;
+17 KILL ^TMP("SDWLIN",$JOB),^TMP("SDWLOUT",$JOB),^TMP("DIERR",$JOB),D
+18 IF '$GET(SDWLSTR)
SET SDWLRES="-1^Data String Missing^Failed"
QUIT
+19 IF $PIECE(SDWLSTR,U)=""
SET SDWLRES="-1^No SSN^Failed"
QUIT
+20 IF $PIECE(SDWLSTR,U,3)=""
SET SDWLRES="-1^No Insitution^Failed"
QUIT
+21 IF $PIECE(SDWLSTR,U,4)=""
SET SDWLRES="-1^No Type^Failed"
QUIT
+22 IF $PIECE(SDWLSTR,U,6)=""
IF $PIECE(SDWLSTR,U,7)=""
IF $PIECE(SDWLSTR,U,8)=""
IF $PIECE(SDWLSTR,U,9)=""
SET SDWLRES="-1^No Type Modifier^Failed"
QUIT
+23 IF $PIECE(SDWLSTR,U,11)'=""
IF $$DCHK($PIECE(SDWLSTR,U,11))<1
SET SDWLRES="-1^Invalid Date^Failed"
QUIT
+24 SET $PIECE(SDWLSTR,U)=$TRANSLATE($PIECE(SDWLSTR,U),"-","")
+25 DO NEW
+26 IF $PIECE(SDWLRES,U,1)<0
QUIT
+27 DO FDA
IF SDWLRES<0
DO DEL
QUIT
+28 DO SET
IF SDWLRES<0
DO DEL
QUIT
+29 DO CLEAN^DILF
KILL ^TMP("SDWLIN",$JOB),^TMP("SDWLOUT",$JOB)
+30 QUIT
NEW ;Get IEN from ^SDWL(409.3,IEN,0).
+1 NEW SDWLTP,SDWL6,SDWL6P,SDWL7,SDWL7P,SDWL8,SDWL8P,SDWL9,SDWL9P,SDWLMOD,SDWLTP,SDWLIN,SDWLDFN
+2 NEW SDWLPRI,SDWLODUZ,SDWLRBY
+3 SET SDWLRES=""
+4 IF $PIECE(SDWLSTR,U,4)
Begin DoDot:1
+5 SET SDWLTP=+$PIECE(SDWLSTR,U,4)
SET (SDWL6,SDWL7,SDWL8,SDWL9)=""
SET SDWLMOD=0
Begin DoDot:2
+6 IF SDWLTP=1
SET SDWL6=$PIECE(SDWLSTR,U,6)
SET SDWL6=$ORDER(^SCTM(404.51,"B",SDWL6,""))
IF SDWL6'=""
SET SDWL6P=$ORDER(^SCTM(404.51,"B",SDWL6,0))
SET SDWLMOD=1
+7 IF SDWLTP=2
SET SDWL7=$PIECE(SDWLSTR,U,7)
SET SDWL7=$ORDER(^SCTM(404.57,"B",SDWL7,""))
IF SDWL7'=""
SET SDWL7P=$ORDER(^SCTM(404.57,"B",SDWL7,0))
SET SDWLMOD=1
+8 IF SDWLTP=3
SET SDWL8=$PIECE(SDWLSTR,U,8)
SET SDWL80=""
FOR
SET SDWL80=$ORDER(^DIC(40.7,"B",SDWL8,SDWL80))
if SDWL80=""
QUIT
Begin DoDot:3
+9 IF $DATA(^SDWL(409.31,"B",SDWL80))
SET SDWL8=$ORDER(^SDWL(409.31,"B",SDWL80,0))
SET $PIECE(SDWLSTR,U,8)=SDWL8
SET SDWLMOD=1
End DoDot:3
+10 IF SDWLTP=4
SET SDWL9=$PIECE(SDWLSTR,U,9)
SET SDWL90=""
FOR SDWL90=$ORDER(^SC("B",SDWL9,SDWL90))
if SDWL90=""
QUIT
Begin DoDot:3
+11 IF $DATA(^SDWL(409.32,"B",SDWL90))
SET SDWL9=$ORDER(^SDWL(409.32,"B",SDWL90,0))
SET $PIECE(SDWLSTR,U,9)=SDWL9
SET SDWLMOD=1
End DoDot:3
End DoDot:2
End DoDot:1
+12 IF 'SDWLMOD
SET SDWLRES="-1^No Type Mod found^Failed"
QUIT
+13 SET SDWLIN=$PIECE(SDWLSTR,U,3)
IF SDWLIN=""
SET SDWLRES="-1^No Institution^Failed"
QUIT
+14 SET SDWLIN=$ORDER(^DIC(4,"B",SDWLIN,0))
IF SDWLIN=""
SET SDWLRES="-1^Invalid Institution^Failed"
QUIT
+15 SET SDWLDFN=$PIECE(SDWLSTR,U,1)
SET D="SSN"
SET DIC(0)="MNZ"
SET X=SDWLDFN
SET D="SSN"
SET DIC=2
DO IX^DIC
IF Y<0
SET SDWLRES="-1^SSN failed"
QUIT
+16 SET SDWLDFN=+Y
+17 IF SDWLDFN=""
SET SDWLRES="-1^Invalid SSN^Failed"
QUIT
+18 IF $$DUP(SDWLDFN)
SET SDWLRES="-1^Duplicate^Failed"
QUIT
+19 SET SDWLPRI=$SELECT($PIECE(SDWLSTR,U,11)="":"A",1:"F")
+20 SET SDWLODUZ=.5
SET SDWLRBY=2
+21 IF SDWLTP=1!(SDWLTP=2)
SET SDWLPRI="A"
SET SDWLRBY=""
+22 SET SDWLSTRN=SDWLTP_"^"_SDWLPRI_"^"_SDWLODUZ_"^"_SDWLRBY_"^"_SDWL6_"^"_SDWL7_"^"_SDWL8_"^"_SDWL9
+23 SET DIC(0)="LX"
SET X=SDWLDFN
SET DIC="^SDWL(409.3,"
DO FILE^DICN
IF Y<0
SET SDWLRES="-1^IEN failed^Failed"
QUIT
+24 SET SDWLDFN=$PIECE(Y,U,2)
SET SDWLDA=+Y
SET SDWLDUZ=$PIECE(SDWLSTR,U,9)
+25 SET DIE="^SDWL(409.3,"
SET DA=SDWLDA
+26 IF SDWLPRI="F"
Begin DoDot:1
+27 SET DR="22///"_$PIECE(SDWLSTR,U,11)
DO ^DIE
End DoDot:1
+28 IF SDWLPRI="A"
IF SDWLTP=3!(SDWLTP=4)
Begin DoDot:1
+29 SET DR="22///^S X=DT"
DO ^DIE
End DoDot:1
+30 SET DR="1////^S X=DT"
DO ^DIE
+31 SET DR="2////^S X=SDWLIN"
DO ^DIE
+32 SET DR="23////^S X=""O"""
SET DIE="^SDWL(409.3,"
DO ^DIE
KILL DIE,DR,DA
+33 ;
+34 ;SET DATE OF DEATH
+35 ;
+36 SET X=$$GET1^DIQ(2,SDWLDFN_",",".351")
IF X'=""
Begin DoDot:1
+37 SET DA=SDWLDA
+38 SET DR="19////^S X=DT"
SET DIE="^SDWL(409.3,"
DO ^DIE
+39 SET DR="20////^S X=DUZ"
DO ^DIE
+40 SET DR="23////^S X=""C"""
DO ^DIE
+41 SET DR="21////^S X=""D"""
DO ^DIE
KILL DIE,DR,DA
End DoDot:1
+42 ;
+43 ;DETERMINE ENROLLEE STATUS
+44 ;
+45 ;SDWLE=1 = NEW ENROLLEE
+46 ;SDWLE=2 = ESTABLISHED
+47 ;SDWLE=3 = PRIOR ENROLLEE
+48 ;SDWLE=4 = UNDETERMINED
+49 ;
+50 SET SDWLDE=+$HOROLOG
SET SDWLE=0
SET (SDWLEE,SDWLRNED,SDWLDB)=0
DO SB1
+51 if SDWLE=2
GOTO SB0
+52 SET SDWLRNE=$$ENROLL^EASWTAPI(SDWLDFN)
if $PIECE(SDWLRNE,U,4)="A"
GOTO SB0
SET SDWLRNED=$PIECE(SDWLRNE,U,3)
+53 IF SDWLRNED
SET X=SDWLRNED
DO H^%DTC
SET SDWLDS=%H
SET SDWLDE=+$HOROLOG
SET SDWLDET=SDWLDE-SDWLDS
IF SDWLDET<366
SET SDWLE=1
+54 IF $DATA(SDWLDET)
IF SDWLDET>365
SET SDWLE=3
+55 IF 'SDWLRNE
SET SDWLE=4
SB0 IF $DATA(SDWLRNE)
IF $PIECE(SDWLRNE,U,4)="A"
Begin DoDot:1
+1 IF 'SDWLEE.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="27.1////^S X=$S($G(SDWLRNED):SDWLRNED,$G(SDWLD):SDWLD,1:"""")"
DO ^DIE
+7 SET DR="27.2////^S X=SDWLDB"
DO ^DIE
+8 SET DR="9////^S X=DUZ"
DO ^DIE
KILL DIE,DA,DR,%H
+9 KILL SDWLRNE,SDWLD,SDWLDE,SDWLEE,SDWLDET,DIC,DIR,DR,DIE,SDWLDS,SDWLE,SDWLRNED
+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=$GET(^DGCN(391.91,SDWLX,0))
Begin DoDot:2
+3 ;CHECK FOR TREATING FACILITY
+4 IF $$TF^XUAF4(+$PIECE(SDWLY,U,2))
Begin DoDot:3
+5 ;SORT FOR LAST TREATMENT DATE
+6 SET SDWLD=$PIECE(SDWLY,U,3)
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
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=1,2,3,4,5,6,7,8
SET SDWLVAL=$PIECE(SDWLSTRN,"^",SDWLI)
Begin DoDot:1
+3 SET SDWLFLD=SDWLI
Begin DoDot:2
+4 SET SDWLFLD=$SELECT(SDWLFLD=1:4,SDWLFLD=2:10,SDWLFLD=3:9,SDWLFLD=4:11,SDWLFLD=5:5,SDWLFLD=6:6,SDWLFLD=7:7,SDWLFLD=8:8)
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 ;
+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
+6 ;
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 KILL DIC,DA
+4 SET SDWLRES=1_"^"_$GET(SDWLDA)
+5 QUIT
DEL SET DA=SDWLDA
SET DIK="^SDWL(409.3,"
DO ^DIK
KILL DIK,DA
+1 SET SDWLRES="-1^Entry "_SDWLDA_" Deleted"
+2 QUIT
DUP(IEN) ;Duplicate Check
+1 ;if institution, wait list type, and wait list modifier are the same it's a duplicate
+2 ;SDWLV1 : IEN in 409.3
+3 ;SDWLV2 : Zero node of 409.3
+4 ;SDWLV3 : Wait List Type Modifier value passed in
+5 ;SDWLV4 : Wait List Type Modifier value in current record
+6 ;SDWLIN : Institution value passed in checked against piece 3 of current record
+7 ;SDWLSTR : Incoming value string
+8 ; Wait List Type piece 4 of SDWLSTR (incoming value) checked against piece 5
+9 ; of SDWLV2 (zero node of current record
+10 NEW SDWLV1,SDWLV2,SDWLV3,SDWLV4,SDWLV5
+11 SET (SDWLV1,SDWLV5)=0
+12 FOR
SET SDWLV1=$ORDER(^SDWL(409.3,"B",IEN,SDWLV1))
if ('SDWLV1!SDWLV5)
QUIT
Begin DoDot:1
+13 SET SDWLV2=$GET(^SDWL(409.3,SDWLV1,0))
if SDWLV2=""
QUIT
+14 SET SDWLV3=$SELECT($PIECE(SDWLSTR,U,4)=1:SDWL6,$PIECE(SDWLSTR,U,4)=2:SDWL7,$PIECE(SDWLSTR,U,4)=3:SDWL8,$PIECE(SDWLSTR,U,4)=4:SDWL9,1:0)
+15 SET SDWLV4=$SELECT($PIECE(SDWLV2,U,5)=1:$PIECE(SDWLV2,U,6),$PIECE(SDWLV2,U,5)=2:$PIECE(SDWLV2,U,7),$PIECE(SDWLV2,U,5)=3:$PIECE(SDWLV2,U,8),$PIECE(SDWLV2,U,5)=4:$PIECE(SDWLV2,U,9),1:0)
+16 IF $PIECE(SDWLV2,U,3)=SDWLIN
IF $PIECE(SDWLSTR,U,4)=$PIECE(SDWLV2,U,5)
IF SDWLV3=SDWLV4
SET SDWLV5=1
QUIT
End DoDot:1
+17 QUIT SDWLV5
DCHK(VALID) ;Check for valid DESIRED DATE
+1 NEW X
+2 SET X=VALID
SET %DT="X"
DO ^%DT
+3 QUIT Y
