SDWLE111 ;;IOFO BAY PINES/TEH - WAITING LIST-ENTER/EDIT - WAIT LIST TYPE/INSTUTITION;20 Aug 2002
;;5.3;scheduling;**263,273,280,394,417,485**;AUG 13 1993;Build 2
;
;
;
;******************************************************************
; CHANGE LOG
;
; DATE PATCH DESCRIPTION
; ---- ----- -----------
;10/01/2002 263 Logical Order Change
;12/02/2002 273 line EN2+19 add '/'
;12/10/2004 SD*5.3*394 Add Service Connection prompts
;01/11/2005 417 Permit MultiplePanels
;02/16/2005 417 New logic for WAIT LIST TYPE Prompt. See Table in Release Notes.
;
;ASK WAIT LIST TYPE
;
EN ;
N SDWLPRP S (SDWLFLG,SDWLPRP)=0
D GETTM
I 'SDWLTEM S SDWLPRP=1
I SDWLTEM,'SDWLPOS S SDWLPRP=0
I $D(SDWLTY) W !,"Wait List Type: ",$$EXTERNAL^DILFD(409.3,4,,SDWLTY) W "// (No Editing)" S SDWLTYE=SDWLTY G EN10
;10/01/2002 - TEH
EN0 ;
I 'SDWLPRP D
.S DIR(0)="SO^1:PCMM TEAM ASSIGNMENT;2:PCMM POSITION ASSIGNMENT;3:SERVICE/SPECIALTY;4:SPECIFIC CLINIC"
.S DIR("L",1)=" Select Wait List Type: "
.S DIR("L",2)=""
.S DIR("L",3)=" 1. PCMM TEAM ASSIGNMENT"
.S DIR("L",4)=" 2. PCMM POSITION ASSIGNMENT"
.S DIR("L",5)=" 3. SERVICE/SPECIALTY"
.S DIR("L")=" 4. SPECIFIC CLINIC"
.S SDWLFLG=1
G EN9:SDWLFLG
EN1 I SDWLPRP D
.S DIR(0)="SO^1:PCMM TEAM ASSIGNMENT;2:SERVICE/SPECIALTY;3:SPECIFIC CLINIC"
.S DIR("L",1)=" Select Wait List Type: "
.S DIR("L",2)=""
.S DIR("L",3)=" 1. PCMM TEAM ASSIGNMENT"
.S DIR("L",4)=" 2. SERVICE/SPECIALTY"
.S DIR("L")=" 3. SPECIFIC CLINIC"
.S SDWLFLG=0
EN9 D ^DIR I X="" W " Required or '^' to Quit" G EN
I $D(DUOUT) S SDWLERR=1 G END
S SDWLTYE=+Y I 'SDWLFLG D
.S SDWLTYE=$S(+Y=1:1,+Y=2:3,+Y=3:4,1:0)
I 'SDWLTYE W " Invalid Entry." G EN
S DIE="^SDWL(409.3,",DR="4///^S X=SDWLTYE" D ^DIE
;
EN10 ;SERVICE CONNECTION - SD*5.3*394
;
D ^SDWLSC
;
;ASK INSTITUTION (FILE 4)
;
I SDWLTYE=2,$D(SDWLCPT),SDWLCPT S (SDWLINE,SDWLIN)=$P($G(^SCTM(404.51,+SDWLCPT,0)),U,7) G END
I SDWLTYE=2 S SDWLI=0 F S SDWLI=$O(^SCTM(404.57,SDWLI)) Q:SDWLI<1 D G END
.S SDWLL=+$P($G(^SCTM(404.57,SDWLI,0)),U,2),SDWLINL=+$P($G(^SCTM(404.51,+SDWLL,0)),U,7),SDWLINL(+SDWLINL)=""
K DUOUT S SDWLERR=0 W !
I $D(SDWLIN) D
.S X=$S($D(SDWLIN):$$EXTERNAL^DILFD(409.32,.02,,SDWLIN),1:""),SDWLINE=SDWLIN D
..W !,"Select Institution: ",X," // (No Editing)" S SDWLERR=1
I SDWLERR S SDWLERR=0 G END
I SDWLTYE=1 S DIC("S")="I $D(^SCTM(404.51,""AINST"",+Y))"
I SDWLTYE=2 S DIC("S")="I $D(SDWLINL(+Y))"
I SDWLTYE=4 S DIC("S")="I $D(^SDWL(409.32,""ACT"",+Y))"
I SDWLTYE=3 S DIC("S")="I $D(^SDWL(409.31,""E"",+Y))"
S DIC("S")=DIC("S")_",$$GET1^DIQ(4,+Y_"","",11,""I"")=""N"",$$TF^XUAF4(+Y)"
S DIC(0)="AEQNM",DIC="4",DIC("A")="Select Institution: " D ^DIC I Y<0,'$D(DUOUT) S SDWLERR=1 W "Required or '^' to Quit."
I $D(DUOUT) S SDWLERR=1 Q
G EN10:SDWLERR
I Y>0 D
.K DIC,DIC("A"),DIC("S"),DIC(0),DIC("B") S (SDWLIN,SDWLINE)=+Y,DIE="^SDWL(409.3,"
.I '$D(DUOUT),Y>0 S DR="2////^S X=SDWLIN",DIE="^SDWL(409.3,",DA=SDWLDA D ^DIE
I $D(DUOUT) S SDWLERR=1
END Q
;
;
GETTM ;CHECK WAIT LIST FOR TEAM ASSIGNMENT.
Q:SDWLTEM Q:'$D(SDWLDFN) N SDWLDA1,SDWLX
S SDWLDA1=0 F S SDWLDA1=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDA1)) Q:SDWLDA1<1 D
.S SDWLX=$G(^SDWL(409.3,SDWLDA1,0)) I $P(SDWLX,U,17)="O",$P(SDWLX,U,6) S SDWLTEM=1
K SDWLDA1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLE111 3655 printed Dec 13, 2024@03:02:27 Page 2
SDWLE111 ;;IOFO BAY PINES/TEH - WAITING LIST-ENTER/EDIT - WAIT LIST TYPE/INSTUTITION;20 Aug 2002
+1 ;;5.3;scheduling;**263,273,280,394,417,485**;AUG 13 1993;Build 2
+2 ;
+3 ;
+4 ;
+5 ;******************************************************************
+6 ; CHANGE LOG
+7 ;
+8 ; DATE PATCH DESCRIPTION
+9 ; ---- ----- -----------
+10 ;10/01/2002 263 Logical Order Change
+11 ;12/02/2002 273 line EN2+19 add '/'
+12 ;12/10/2004 SD*5.3*394 Add Service Connection prompts
+13 ;01/11/2005 417 Permit MultiplePanels
+14 ;02/16/2005 417 New logic for WAIT LIST TYPE Prompt. See Table in Release Notes.
+15 ;
+16 ;ASK WAIT LIST TYPE
+17 ;
EN ;
+1 NEW SDWLPRP
SET (SDWLFLG,SDWLPRP)=0
+2 DO GETTM
+3 IF 'SDWLTEM
SET SDWLPRP=1
+4 IF SDWLTEM
IF 'SDWLPOS
SET SDWLPRP=0
+5 IF $DATA(SDWLTY)
WRITE !,"Wait List Type: ",$$EXTERNAL^DILFD(409.3,4,,SDWLTY)
WRITE "// (No Editing)"
SET SDWLTYE=SDWLTY
GOTO EN10
+6 ;10/01/2002 - TEH
EN0 ;
+1 IF 'SDWLPRP
Begin DoDot:1
+2 SET DIR(0)="SO^1:PCMM TEAM ASSIGNMENT;2:PCMM POSITION ASSIGNMENT;3:SERVICE/SPECIALTY;4:SPECIFIC CLINIC"
+3 SET DIR("L",1)=" Select Wait List Type: "
+4 SET DIR("L",2)=""
+5 SET DIR("L",3)=" 1. PCMM TEAM ASSIGNMENT"
+6 SET DIR("L",4)=" 2. PCMM POSITION ASSIGNMENT"
+7 SET DIR("L",5)=" 3. SERVICE/SPECIALTY"
+8 SET DIR("L")=" 4. SPECIFIC CLINIC"
+9 SET SDWLFLG=1
End DoDot:1
+10 if SDWLFLG
GOTO EN9
EN1 IF SDWLPRP
Begin DoDot:1
+1 SET DIR(0)="SO^1:PCMM TEAM ASSIGNMENT;2:SERVICE/SPECIALTY;3:SPECIFIC CLINIC"
+2 SET DIR("L",1)=" Select Wait List Type: "
+3 SET DIR("L",2)=""
+4 SET DIR("L",3)=" 1. PCMM TEAM ASSIGNMENT"
+5 SET DIR("L",4)=" 2. SERVICE/SPECIALTY"
+6 SET DIR("L")=" 3. SPECIFIC CLINIC"
+7 SET SDWLFLG=0
End DoDot:1
EN9 DO ^DIR
IF X=""
WRITE " Required or '^' to Quit"
GOTO EN
+1 IF $DATA(DUOUT)
SET SDWLERR=1
GOTO END
+2 SET SDWLTYE=+Y
IF 'SDWLFLG
Begin DoDot:1
+3 SET SDWLTYE=$SELECT(+Y=1:1,+Y=2:3,+Y=3:4,1:0)
End DoDot:1
+4 IF 'SDWLTYE
WRITE " Invalid Entry."
GOTO EN
+5 SET DIE="^SDWL(409.3,"
SET DR="4///^S X=SDWLTYE"
DO ^DIE
+6 ;
EN10 ;SERVICE CONNECTION - SD*5.3*394
+1 ;
+2 DO ^SDWLSC
+3 ;
+4 ;ASK INSTITUTION (FILE 4)
+5 ;
+6 IF SDWLTYE=2
IF $DATA(SDWLCPT)
IF SDWLCPT
SET (SDWLINE,SDWLIN)=$PIECE($GET(^SCTM(404.51,+SDWLCPT,0)),U,7)
GOTO END
+7 IF SDWLTYE=2
SET SDWLI=0
FOR
SET SDWLI=$ORDER(^SCTM(404.57,SDWLI))
if SDWLI<1
QUIT
Begin DoDot:1
+8 SET SDWLL=+$PIECE($GET(^SCTM(404.57,SDWLI,0)),U,2)
SET SDWLINL=+$PIECE($GET(^SCTM(404.51,+SDWLL,0)),U,7)
SET SDWLINL(+SDWLINL)=""
End DoDot:1
GOTO END
+9 KILL DUOUT
SET SDWLERR=0
WRITE !
+10 IF $DATA(SDWLIN)
Begin DoDot:1
+11 SET X=$SELECT($DATA(SDWLIN):$$EXTERNAL^DILFD(409.32,.02,,SDWLIN),1:"")
SET SDWLINE=SDWLIN
Begin DoDot:2
+12 WRITE !,"Select Institution: ",X," // (No Editing)"
SET SDWLERR=1
End DoDot:2
End DoDot:1
+13 IF SDWLERR
SET SDWLERR=0
GOTO END
+14 IF SDWLTYE=1
SET DIC("S")="I $D(^SCTM(404.51,""AINST"",+Y))"
+15 IF SDWLTYE=2
SET DIC("S")="I $D(SDWLINL(+Y))"
+16 IF SDWLTYE=4
SET DIC("S")="I $D(^SDWL(409.32,""ACT"",+Y))"
+17 IF SDWLTYE=3
SET DIC("S")="I $D(^SDWL(409.31,""E"",+Y))"
+18 SET DIC("S")=DIC("S")_",$$GET1^DIQ(4,+Y_"","",11,""I"")=""N"",$$TF^XUAF4(+Y)"
+19 SET DIC(0)="AEQNM"
SET DIC="4"
SET DIC("A")="Select Institution: "
DO ^DIC
IF Y<0
IF '$DATA(DUOUT)
SET SDWLERR=1
WRITE "Required or '^' to Quit."
+20 IF $DATA(DUOUT)
SET SDWLERR=1
QUIT
+21 if SDWLERR
GOTO EN10
+22 IF Y>0
Begin DoDot:1
+23 KILL DIC,DIC("A"),DIC("S"),DIC(0),DIC("B")
SET (SDWLIN,SDWLINE)=+Y
SET DIE="^SDWL(409.3,"
+24 IF '$DATA(DUOUT)
IF Y>0
SET DR="2////^S X=SDWLIN"
SET DIE="^SDWL(409.3,"
SET DA=SDWLDA
DO ^DIE
End DoDot:1
+25 IF $DATA(DUOUT)
SET SDWLERR=1
END QUIT
+1 ;
+2 ;
GETTM ;CHECK WAIT LIST FOR TEAM ASSIGNMENT.
+1 if SDWLTEM
QUIT
if '$DATA(SDWLDFN)
QUIT
NEW SDWLDA1,SDWLX
+2 SET SDWLDA1=0
FOR
SET SDWLDA1=$ORDER(^SDWL(409.3,"B",SDWLDFN,SDWLDA1))
if SDWLDA1<1
QUIT
Begin DoDot:1
+3 SET SDWLX=$GET(^SDWL(409.3,SDWLDA1,0))
IF $PIECE(SDWLX,U,17)="O"
IF $PIECE(SDWLX,U,6)
SET SDWLTEM=1
End DoDot:1
+4 KILL SDWLDA1
