SDWLE11 ;;IOFO BAY PINES/TEH - WAITING LIST-ENTER/EDIT - WAIT LIST TYPE/INSTUTITION;06/12/2002 ; 20 Aug 2002 2:10 PM
;;5.3;scheduling;**263,485,497,446,646**;AUG 13 1993;Build 8
;
;
;******************************************************************
; CHANGE LOG
;
; DATE PATCH DESCRIPTION
; ---- ----- -----------
; 05/09/2006 SD*5.3*485 CORRECT ENROLLMENT STATUS.
; 06/05/2006 SD*5.3*446 Scheduling reminder flag
;
;
NEW ;ADD NEW PATIENT
;SD*5.3*646 K DIC,DIR,DR,DIE N %H,SDWLDS,SDWLE,SDWLNEW,SDWLRNED,SDWLX,SDWLY
K DIC,DIR,DR,DIE,DO N %H,SDWLDS,SDWLE,SDWLNEW,SDWLRNED,SDWLX,SDWLY
S DIC(0)="LX",X=SDWLDFN,DIC="^SDWL(409.3," D FILE^DICN S (SDWLDA,DA)=+Y
S SDWLNEW=1 K DIC
L +^SDWL(409.3,SDWLDA):$G(DILOCKTM,3) I '$T W !,"Unable to acquire a lock on the Wait List file" Q
S DIE="^SDWL(409.3,",DR="1////^S X=DT"
D:$G(SDWLACA) ; 446
.W !,"Note: you are about to create an EWL entry to be used as a Scheduling Reminder."
.S DR=DR_";33////^S X=""Y"""
.Q
D ^DIE
L -^SDWL(409.3,SDWLDA)
;
;DETERMINE ENROLLEE STATUS
;
;SDWLE=1 = NEW ENROLLEE
;SDWLE=2 = ESTABLISHED
;SDWLE=3 = PRIOR ENROLLEE
;SDWLE=4 = UNDETERMINED
TST ;
EN S SDWLDE=+$H,SDWLE=1,(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 $D(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
;SAVE ENROLLEE CALCULATION DATE
S DR="27.1////^S X=$S($G(SDWLRNED):SDWLRNED,$G(SDWLD):SDWLD,1:"""")" D ^DIE
;SAVE DATABASE FILE
S DR="27.2////^S X=SDWLDB" D ^DIE
S DR="9////^S X=DUZ" D ^DIE
K SDWLRNE,SDWLD,SDWLDE,SDWLEE,SDWLDET,DIC,DIR,DR,DIE,X
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 VALID TF
..I $$TF^XUAF4(+$P(SDWLY,U,2)) D
...;GET LIST OF DATES FOR TF
...S SDWLD=$P(SDWLY,U,3) I SDWLD S SDWLDTF(9999999-SDWLD)=SDWLX
;FIND LAST TREATMENT DATE
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
END Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLE11 2643 printed Dec 13, 2024@03:02:25 Page 2
SDWLE11 ;;IOFO BAY PINES/TEH - WAITING LIST-ENTER/EDIT - WAIT LIST TYPE/INSTUTITION;06/12/2002 ; 20 Aug 2002 2:10 PM
+1 ;;5.3;scheduling;**263,485,497,446,646**;AUG 13 1993;Build 8
+2 ;
+3 ;
+4 ;******************************************************************
+5 ; CHANGE LOG
+6 ;
+7 ; DATE PATCH DESCRIPTION
+8 ; ---- ----- -----------
+9 ; 05/09/2006 SD*5.3*485 CORRECT ENROLLMENT STATUS.
+10 ; 06/05/2006 SD*5.3*446 Scheduling reminder flag
+11 ;
+12 ;
NEW ;ADD NEW PATIENT
+1 ;SD*5.3*646 K DIC,DIR,DR,DIE N %H,SDWLDS,SDWLE,SDWLNEW,SDWLRNED,SDWLX,SDWLY
+2 KILL DIC,DIR,DR,DIE,DO
NEW %H,SDWLDS,SDWLE,SDWLNEW,SDWLRNED,SDWLX,SDWLY
+3 SET DIC(0)="LX"
SET X=SDWLDFN
SET DIC="^SDWL(409.3,"
DO FILE^DICN
SET (SDWLDA,DA)=+Y
+4 SET SDWLNEW=1
KILL DIC
+5 LOCK +^SDWL(409.3,SDWLDA):$GET(DILOCKTM,3)
IF '$TEST
WRITE !,"Unable to acquire a lock on the Wait List file"
QUIT
+6 SET DIE="^SDWL(409.3,"
SET DR="1////^S X=DT"
+7 ; 446
if $GET(SDWLACA)
Begin DoDot:1
+8 WRITE !,"Note: you are about to create an EWL entry to be used as a Scheduling Reminder."
+9 SET DR=DR_";33////^S X=""Y"""
+10 QUIT
End DoDot:1
+11 DO ^DIE
+12 LOCK -^SDWL(409.3,SDWLDA)
+13 ;
+14 ;DETERMINE ENROLLEE STATUS
+15 ;
+16 ;SDWLE=1 = NEW ENROLLEE
+17 ;SDWLE=2 = ESTABLISHED
+18 ;SDWLE=3 = PRIOR ENROLLEE
+19 ;SDWLE=4 = UNDETERMINED
TST ;
EN SET SDWLDE=+$HOROLOG
SET SDWLE=1
SET (SDWLEE,SDWLRNED,SDWLDB)=0
DO SB1
+1 if SDWLE=2
GOTO SB0
+2 SET SDWLRNE=$$ENROLL^EASWTAPI(SDWLDFN)
if $PIECE(SDWLRNE,U,4)="A"
GOTO SB0
SET SDWLRNED=$PIECE(SDWLRNE,U,3)
+3 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
+4 IF $DATA(SDWLDET)
IF SDWLDET>365
SET SDWLE=3
+5 IF 'SDWLRNE
SET SDWLE=4
SB0 IF $DATA(SDWLRNE)
IF $PIECE(SDWLRNE,U,4)="A"
Begin DoDot:1
+1 IF $DATA(SDWLEE)
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 ;SAVE ENROLLEE CALCULATION DATE
+7 SET DR="27.1////^S X=$S($G(SDWLRNED):SDWLRNED,$G(SDWLD):SDWLD,1:"""")"
DO ^DIE
+8 ;SAVE DATABASE FILE
+9 SET DR="27.2////^S X=SDWLDB"
DO ^DIE
+10 SET DR="9////^S X=DUZ"
DO ^DIE
+11 KILL SDWLRNE,SDWLD,SDWLDE,SDWLEE,SDWLDET,DIC,DIR,DR,DIE,X
+12 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 VALID TF
+4 IF $$TF^XUAF4(+$PIECE(SDWLY,U,2))
Begin DoDot:3
+5 ;GET LIST OF DATES FOR TF
+6 SET SDWLD=$PIECE(SDWLY,U,3)
IF SDWLD
SET SDWLDTF(9999999-SDWLD)=SDWLX
End DoDot:3
End DoDot:2
End DoDot:1
+7 ;FIND LAST TREATMENT DATE
+8 IF '$DATA(SDWLDTF)
QUIT
+9 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
+10 IF $DATA(SDWLEE)
IF SDWLEE>730!(SDWLEE=730)
SET SDWLE=3
+11 KILL SDWLDTF
END QUIT
