SDWLE5   ;;IOFO BAY PINES/TEH - WAITING LIST-ENTER/EDIT;06/12/2002 ; 11/28/05 10  ; Compiled February 7, 2006 11:42:40:32am
 ;;5.3;scheduling;**263,417**;AUG 13 1993
 ;
 ;
 ;***************************************************************************************************
 ;                                             CHANGE LOG
 ;                               PATCH                                DESCRIPTION
 ;   ----                        -----                                -----------
 ;04/10/2005                   SD*5.3*417       Add ability to select multiple POSITIONS for a TEAM.
 ;   
 ;   
EN ;
 ;POSITION (404.57)
 K DIR,DIC,SDWLCPP N SDWLCP S SDWLTCNT=0
 D GETTEAM,GETLIST
 I SDWLTCNT>1 D  G END:Y="^" I Y<1 W *7,"Select a TEAM or enter an '^' to QUIT." G EN
 .W !,"Patient has multiple TEAM entries. Select the TEAM for POSITION selection.",!
 .K Y N X S X=0 F  S X=$O(SDWLTP("T",X)) Q:X<1  S SDWLT=$$GET1^DIQ(404.51,X_",",.01) W !,?10,SDWLT
 .W ! S DIR(0)="PAO^404.51:EMZ",DIR("S")="I $D(SDWLTP(""T"",+Y))",DIR("A")="Select TEAM: " D ^DIR Q:Y<1
 .I +Y K SDWLCT S SDWLCT(+Y)="",SDWLCT=+Y,SDWLIN=+$P(Y(0),U,7) Q
 I SDWLTCNT'>1,$D(SDWLINL) S SDWLIN=SDWLINL
 I $D(SDWLCT) S SDX=$P($G(^SCTM(404.57,SDWLCT,0)),U,2),SDWLIN=$P($G(^SCTM(404.51,SDX,0)),U,7)
ENA ;
 I '$D(SDWLTP("T",SDWLCT,"P")) W !,"No Positions Meet Wait List Criteria" G END
 K DIR,DIC,DR,DIE,SDWLSCR S DA=SDWLDA K SDWLTH,SDWLMAX
 S SDWLERR=0,SDWLY="Position",SDWLVAR=$S($D(SDWLSP):SDWLSP,1:0)
 S (SDWLYN,SDWLTYE)=6,SDWLVBR="SDWLSP",SDWLF=404.57
 S SDWLMAX=$P(^SCTM(404.57,0),U,3)
 I $D(^SDWL(409.3,SDWLDA,0)),$P(^(0),U,3)="" D
 .S DIE="^SDWL(409.3,",DR="2////^S X=SDWLIN",DA=SDWLDA D ^DIE
 S SDWLA=0 F  S SDWLA=$O(^SCTM(404.57,SDWLA)) Q:SDWLA<1  D
 .I '$D(SDWLTP("T",SDWLCT,"P",SDWLA)) Q
 .S SDWLMAX=0,X=$$PCPOSCNT^SCAPMCU1(SDWLA,DT,0),SDWLMAX(SDWLA)="" D
 ..I X>0,$P(^SCTM(404.57,SDWLA,0),U,8)>X!($P(^SCTM(404.57,SDWLA,0),U,8)=X) K SDWLMAX(SDWLA)
 .S X=$G(^SCTM(404.57,SDWLA,0)) I +$P(X,U,4)=0 S SDWLTH(SDWLA)="" K SDWLMAX(SDWLA)
 .I '$D(SDWLSCR) S SDWLN=0
 .S SDWLSCR="I $P(^SCTM(404.57,+Y,0),U,2)=SDWLCT,'$D(SDWLTH(+Y)),$D(SDWLMAX(+Y)),'$D(SDWLPSS(+Y))"
 I '$O(SDWLMAX(0)) W !,"No Position for this Team meets Wait List Criteria" S SDWLERR=1,DUOUT=1
 G END:SDWLERR
EN0 W ! D EN1
 I $D(DUOUT),SDWLVAR G END
 S DR=SDWLYN_"////^S X=SDWLVAR",DIE=409.3 D ^DIE S @SDWLVBR=SDWLVAR G END
 Q
EN1 ;;-DIC LOOKUP
 I $D(SDWLDATA) K SDWLPSS
 I SDWLCT=SDWLVAR D
 .S X=$$EXTERNAL^DILFD(409.3,SDWLYN,,SDWLCT) I X'="" S DIR("B")=X
 K DR,DIE,DIC,DUOUT S DIR("?")="^S X=""?"",DIC(""S"")=""I $P(^SCTM(404.57,+Y,0),U,2)=SDWLCT,'$D(SDWLTH(+Y)),$D(SDWLMAX(+Y))"",DIC=404.57,DIC(0)=""EQMNZ"" D ^DIC"
 S DIR(0)="FAO",DIR("A")="Select "_SDWLY_": " D ^DIR
 I $D(DTOUT) S DUOUT=1
 I X["^" S DUOUT=1 Q
 I X="@" W *7," ??" G EN1
 I X="" W *7,"Required or '^' to quit." G EN1
 S DUOUT=$S(X=0:1,X="":1,X["^":1,$D(DTOUT):1,X="@":1,1:0) I 'DUOUT K DUOUT
 I $D(DUOUT) Q
 S DIC("S")=SDWLSCR,DIC=404.57
 S DIC(0)="EMNZ" D ^DIC G EN1:+Y<1 S SDWLVAR=+Y
 K DIR
 Q
GETLIST ;GET LIST OF VALID POSITIONS
 N SDWLTMX,SDWLTMP,SDWLP S (SDWLTMX,SDWLTMP)=0
 F  S SDWLTMX=$O(SDWLTP("T",SDWLTMX)) Q:SDWLTMX<1  D
 .S SDWLP=0 F  S SDWLP=$O(^SCTM(404.57,"C",SDWLTMX,SDWLP)) Q:SDWLP<1  D
 ..I $D(SDWLCP4N),SDWLP=SDWLCP4N Q
 ..S SDWLTP("T",SDWLTMX,"P",SDWLP)=""
 F  S SDWLTMP=$O(^SDWL(409.3,"B",SDWLDFN,SDWLTMP)) Q:SDWLTMP<1  D
 .S X=$G(^SDWL(409.3,SDWLTMP,0)) I X D
 ..I $P(X,U,5)=2 S Y=$P(X,U,7) I Y S SDWLTMX=$P($G(^SCTM(404.57,Y,0)),U,2) I $D(SDWLTP("T",SDWLTMX,"P",Y)) K SDWLTP("T",SDWLTMX,"P",Y)
 Q
GETTEAM ;GET TEAMS
 ;GET CURRENT TEAM ASSIGNMENTS 404.41 AND 409.3
 ;
 K SDWLTMX,SDWLTP S SDWLTP="",SDWLTCNT=0 N SDWLZ
 S SDWLZ=0 F  S SDWLZ=$O(^SCPT(404.42,"B",SDWLDFN,SDWLZ)) Q:SDWLZ<1  D
 .S X=$G(^SCPT(404.42,SDWLZ,0)) I $P(X,U,9) Q
 .S SDWLTP("T",+$P(X,U,3))="",SDWLCT=$P(X,U,3),SDWLTCNT=SDWLTCNT+1
 S SDWLTMX=0
 F  S SDWLTMX=$O(^SDWL(409.3,"B",SDWLDFN,SDWLTMX)) Q:SDWLTMX<1  D
 .S X=$G(^SDWL(409.3,SDWLTMX,0)) Q:$P(X,U,17)="C"  Q:$P(X,U,5)'=1  I +$P(X,U,6)>0,'$D(SDWLP("T",$P(X,U,6))) S SDWLTP("T",$P(X,U,6))="",SDWLTCNT=SDWLTCNT+1,SDWLCT=$P(X,U,6)
 K SDWLTMX,X
 Q
END K SDWLA,SDWLMAX,SDWLTH,SDWLSCR,DIR,DIC,DIE,DR,SDWLTMX,SDWLPSS,SDWLPDA,SDWLCT,SDWLTMX,SDWLTCNT,SDWLPSS,SDWLPDA,SDWLX
 K SDWLVBR,SDWLVAR,SDWLYN,SDWLF,SDWLY,X,SDWLTP
 Q