- 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 Feb 19, 2025@00:28:57 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
