Routine: SDWLE3

SDWLE3 ;IOFO BAY PINES/TEH - WAITING LIST-ENTER/EDIT;06/12/2002 ; 12/14/05 1:28pm  ; Compiled April 25, 2006 10:42:02

 ;;5.3;scheduling;**263,417,446**;AUG 13 1993;Build 77

 ;******************************************************************

 ;                             CHANGE LOG

 ;   DATE                        PATCH                   DESCRIPTION

 ;   ----                        -----                   -----------

 ;   08/01/2005                SD*5.3*417              Permit multiple teams

 ;   04/21/2006                SD*5.3*446              Inter-Facility Transfer

EN ;

 ;ASK FOR SPECIFIC TEAM (404.51)

 K DIR,DIC,DR,DIE,SDTMENT S (DA,SDTMENT)=SDWLDA K SDWLTH,SDWLMAX

 S SDWLYN=5,SDWLTYE=1,SDWLVBR="SDWLST"

 I $D(SDWLST),'SDWLST K SDWLST

 I $G(SDWLCP3)'="" D

 .W !,"This patient is already on the ",SDWLCP3,"." S DIR(0)="Y^A0",DIR("B")="NO",DIR("A")="Are you sure you want to continue" D ^DIR

 .I 'Y!(Y["^") S DUOUT=1 Q

 I $D(DUOUT),DUOUT G END

 D GETLIST

 S SDWLERR=0,SDWLY="Team",SDWLVAR=$S($D(SDWLST):SDWLST,1:0),SDWLSCR=""

 S SDWLVBR="SDWLST"

EN1 W ! S SDWLS=SDWLY,SDWLX=$S(SDWLTYE=1:"T",SDWLTYE=2:"P",1:""),SDWLSX="     "_SDWLS

 S SDWLF="SCTM(404.51,"

 S SDWLA=0 F  S SDWLA=$O(^SCTM(404.58,"B",SDWLA)) Q:SDWLA=""  D

 .I $D(SDWLCT),SDWLCT=SDWLA Q

 .I $P($G(^SCTM(404.51,SDWLA,0)),U,7)'=SDWLIN Q

 .I +$$ACTTM^SCMCTMU(SDWLA)=0 S SDWLTH(SDWLA)=""

 .S SDWLMAX=0,X=$$TEAMCNT^SCAPMCU1(SDWLA,DT),SDWLMAX(SDWLA)=""  D

 ..I X<$P($G(^SCTM(404.51,SDWLA,0)),U,8) K SDWLMAX(SDWLA)

 N SDWLT S SDWLT=0 F  S SDWLT=$O(SDWLPLST(1,SDWLT)) Q:SDWLT<1  K SDWLMAX(SDWLT)

 S SDWLSCR="I $P(^(0),U,7)=SDWLIN,'$D(SDWLTH(+Y)),$D(SDWLMAX(+Y)),'$D(SDWLPLST(SDWLTYE,+Y,SDWLIN))"

 D EN2 G END:$D(DUOUT)

 ;DA=SDWLDA, see EN

 S DR="5////^S X=SDWLVAR",DIE=409.3 D ^DIE

 N FLG D FLAGS(.FLG,DFN,SDWLVAR)

 I 'FLG S DA=SDTMENT,DIE=409.3 D

 .S SDINTR=FLG(1),SDREJ=FLG(2),SDMTM=FLG(3)

 .S DR="32////^S X=SDREJ;34////^S X=SDINTR;38////^S X=SDMTM" D ^DIE

 S @SDWLVBR=SDWLVAR

 I $D(SDWLVARO),SDWLVARO,SDWLVAR'=SDWLVARO D DELPOS

 G END

EN2 ;-DIR READ

 I '$D(SDWLDATA),$D(SDWLMAX)'=11 W !,"No TEAMS are available for this INSTITUTION.",! S DUOUT="" Q

 K DIR,DR,DIE,DIC,DUOUT

 S DIR("?")="^S X=""?"",DIC(""S"")=""I $P(^SCTM(404.51,+Y,0),U,7)=SDWLIN,'$D(SDWLTH(+Y)),$D(SDWLMAX(+Y)),'$D(SDWLPLST(1,+Y,SDWLINE))"" S DIC=404.51,DIC(0)=""EQMNZ"" D ^DIC"

 I $D(SDWLVAR),SDWLVAR S X=SDWLVAR,SDWLMPX=$$EXTERNAL^DILFD(409.3,SDWLYN,,SDWLVAR),DIR("B")=SDWLMPX,SDWLVARO=SDWLVAR K X

 S DIR(0)="FAO",DIR("A")="Select "_SDWLY_": "

 D ^DIR

 I X["^" S DUOUT=1 Q

 S DUOUT=$S(X=0:1,X="@":1,$D(DTOUT):1,1:0) I 'DUOUT K DUOUT

 I X="@" W *7," No deleting allowing." G EN2

 S DIC("S")=SDWLSCR

 S DIC(0)="EMNZ",DIC=404.51 D ^DIC I $D(DTOUT) S DUOUT=1

 I $D(DUOUT) Q

 I Y<0 W "??" G EN2

 S SDWLVAR=+Y

 ;identify flags

FLAGS(FLG,DFN,TEAM) ;

 N SDTEAM S SDTEAM=$G(TEAM)

 ; check if transfer and if multiple teams in institution

 S SDCNT=0,SDINTR=0,SDREJ=0,SDMTM=0 D

 .S SDWLIN=$P($G(^SCTM(404.51,TEAM,0)),U,7)

 .I $P(^SCTM(404.51,TEAM,0),U,5)'=1 Q  ; cannot be primary care provider team

 .;identify INTRA-transfer

 .;- is patient assigned to PC provider?

 .I $$GETALL^SCAPMCA(DFN) D

 ..I $G(^TMP("SC",$J,DFN,"PCPOS",0)) S SDTM=$P(^(1),U,3) I SDTM>0 D

 ...I $P($G(^SCTM(404.51,SDTM,0)),U,7)'=SDWLIN S SDINTR=1 D  ; inter transfer ; different institution

 ..I '$G(^TMP("SC",$J,DFN,"PCPOS",0)) D

 ...;check available PCMM teams in other institutions and if so set up rejection flag

 ...S SDINS=""

 ...F  S SDINS=$O(^SCTM(404.51,"AINST",SDINS)) Q:SDINS=""  I SDINS'=SDWLIN D  Q:SDREJ

 ....S SDCNT=0,SDT=""

 ....F  S SDT=$O(^SCTM(404.51,"AINST",SDINS,SDT)) Q:SDT=""  D  Q:SDREJ

 .....I $$ACTTM^SCMCTMU(SDT,DT)&($P($G(^SCTM(404.51,SDT,0)),U,5))&'$P($G(^SCTM(404.51,SDT,0)),U,10) D

 ......S SCTMCT=$$TEAMCNT^SCAPMCU1(SDT) ;currently assigned

 ......S SCTMMAX=$P($$GETEAM^SCAPMCU3(SDT),"^",8) ;maximum set

 ......I SCTMCT<SCTMMAX S SDREJ=1

 ..;find all teams from institution SDWLIN

 ..I SDINTR S SDCNT=0,SDT="" D

 ...F  S SDT=$O(^SCTM(404.51,"AINST",SDWLIN,SDT)) Q:SDT=""  I $P(^SCTM(404.51,SDT,0),U,5)=1 S TEAM(SDT)="",SDCNT=SDCNT+1

 S FLG(1)=SDINTR,FLG(2)=SDREJ,FLG(3)=SDMTM

 I SDCNT>1 S SDMTM=1,FLG(3)=SDMTM,FLG=1 S SDCC="" F  S SDCC=$O(TEAM(SDCC)) Q:SDCC=""  S TEAM=SDCC N DR,Y D WMT

 I SDCNT>1 S TEAM=$G(SDTEAM) Q

 I SDCNT'>1 N DR,Y S FLG=0 S TEAM=$G(SDTEAM) Q

WMT D INPUT^SDWLRP1(.RES,DFN_U_1_U_TEAM_U_U_DUZ_"^^"_U_SDINTR_U_SDREJ_U_SDMTM)

 ;I $G(RES) S OK=0,DA=+$P(RES,U,2),DIE="^SDWL(409.3,",DR="25;S OK=1" D ^DIE  I '$G(OK) S DIK=DIE D ^DIK W !,"Wait list entry deleted"

GETLIST ;GET LIST OF TEAM ASSIGNMENTS - SD*5.3*417

 N SDWLDAX,X,Z,SDWLIN K SDWLPLST S SDWLPLST=""

 S SDWLDAX=0 F  S SDWLDAX=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDAX)) Q:SDWLDAX=""  D

 .S Z=$G(^SDWL(409.3,SDWLDAX,0)),X=$P(Z,U,5),SDWLINE=+$P(Z,U,3) Q:X'=1&(X'=2)  D

 ..S Y=+$S(X=1:$P(Z,U,6),X=2:$P(Z,U,7),1:0) Q:'Y  D

 ...I $P(Z,U,17)["O" S SDWLPLST(X,Y,SDWLINE)="" I $D(SDWLST),SDWLST=+Y K SDWLPLST(X,Y,SDWLINE)

 S Y=0 F  S Y=$O(SDWLCPT(Y)) Q:Y=""  D

 .S SDWLPLST(1,Y,SDWLINE)="" I $D(SDWLST),SDWLST=+Y K SDWLPLST(1,Y,SDWLINE)

DELPOS ;DELETE POSITIONS FOR OLD TEAM

 S SDWLA=0,CNT=0 F  S SDWLA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLA)) Q:SDWLA<1  D

 .S X=$G(^SDWL(409.3,SDWLA,0)) Q:$P(X,U,7)=""

 .I $P(X,U,5)'=2 Q

 .I $P(X,U,17)["C" Q

 .S SDWLPX=+$P(X,U,7) I $P($G(^SCTM(404.57,SDWLPX,0)),U,2)'=SDWLVARO Q

 .S CNT=CNT+1,^XTMP("SDWLE3",$J,CNT)=SDWLA_";"_X W !

 I 'CNT Q

 W !,"This patient has one or more Wait List entries for PCMM Positions",!

 W !,"Wait List Type",?30,"Waiting For",?45,"Institution",?60,"Date Entered",!

 S Y=0 F  S Y=$O(^XTMP("SDWLE3",$J,Y)) Q:Y<1  S X=$G(^XTMP("SDWLE3",$J,Y)),SDWLIEN=$P(X,";",1) D

 .W !,$$GET1^DIQ(409.3,SDWLIEN,4),?30,$$GET1^DIQ(409.3,SDWLIEN,6),?45,$$GET1^DIQ(409.3,SDWLIEN,2),?60,$$GET1^DIQ(409.3,SDWLIEN,1)

 W ! S SDWLET=$$EXTERNAL^DILFD(409.3,SDWLYN,,SDWLVARO)

 K DIR S DIR("?",1)="This patient has one or more Wait List entries for PCMM positions."

 S DIR("?",2)="By answering 'YES' you will close the Wait List entries which were listed."

 S DIR("?")="Answer 'NO' to keep those Wait List entries open."

 S DIR("A")="Do you wish to close these POSITION(S) entries? ",DIR(0)="Y",DIR("B")="YES" D ^DIR

 I 'Y W *7," No POSITIONS closed." Q

 N DA S SDWLA=0 F  S SDWLA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLA)) Q:SDWLA<1  D

 .S X=$G(^SDWL(409.3,SDWLA,0)) Q:$P(X,U,7)=""  D

 ..S SDWLP=$P(X,U,7) I $P(^SCTM(404.57,SDWLP,0),U,2)=SDWLVARO D

 ...K DIE,DIC,DR,DICR,DIR S DA=SDWLA,SDWLDISP="NN"

 ...S DIE="^SDWL(409.3,",DR="21////^S X=SDWLDISP" D ^DIE

 ...S DR="19////^S X=DT" D ^DIE

 ...S DR="20////^S X=SDWLDUZ" D ^DIE

 ...S DR="23////""C""" D ^DIE

END K SDWLA,SDWLMAX,SDWLTH,SDWLSCR,DIR,DIC,DIE,DR,SDWLPLST,SDWLDAX,DTOUT,SDWLCP3,SDWLINE

 K X,Y,Z,SDWLPLST,SDWLB,SDWLA,SDWLSX,SDWLS,SDWLVBR,SDWLVAR,SDWLSCR,SDWLF,SDWLYN,SDWLMPX

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLE3   6974     printed  Mar 13, 2025@22:07:36                                                                                                                                                                                                      Page 2

SDWLE3    ;IOFO BAY PINES/TEH - WAITING LIST-ENTER/EDIT;06/12/2002 ; 12/14/05 1:28pm  ; Compiled April 25, 2006 10:42:02

 +1       ;;5.3;scheduling;**263,417,446**;AUG 13 1993;Build 77

 +2       ;

 +3       ;

 +4       ;******************************************************************

 +5       ;                             CHANGE LOG

 +6       ;

 +7       ;   DATE                        PATCH                   DESCRIPTION

 +8       ;   ----                        -----                   -----------

 +9       ;   08/01/2005                SD*5.3*417              Permit multiple teams

 +10      ;   04/21/2006                SD*5.3*446              Inter-Facility Transfer

 +11      ;

 +12      ;

EN        ;

 +1       ;ASK FOR SPECIFIC TEAM (404.51)

 +2        KILL DIR,DIC,DR,DIE,SDTMENT

           SET (DA,SDTMENT)=SDWLDA

           KILL SDWLTH,SDWLMAX

 +3        SET SDWLYN=5

           SET SDWLTYE=1

           SET SDWLVBR="SDWLST"

 +4        IF $DATA(SDWLST)

               IF 'SDWLST

                   KILL SDWLST

 +5        IF $GET(SDWLCP3)'=""

               Begin DoDot:1

 +6                WRITE !,"This patient is already on the ",SDWLCP3,"."

                   SET DIR(0)="Y^A0"

                   SET DIR("B")="NO"

                   SET DIR("A")="Are you sure you want to continue"

                   DO ^DIR

 +7                IF 'Y!(Y["^")

                       SET DUOUT=1

                       QUIT

               End DoDot:1

 +8        IF $DATA(DUOUT)

               IF DUOUT

                   GOTO END

 +9        DO GETLIST

 +10       SET SDWLERR=0

           SET SDWLY="Team"

           SET SDWLVAR=$SELECT($DATA(SDWLST):SDWLST,1:0)

           SET SDWLSCR=""

 +11       SET SDWLVBR="SDWLST"

EN1        WRITE !

           SET SDWLS=SDWLY

           SET SDWLX=$SELECT(SDWLTYE=1:"T",SDWLTYE=2:"P",1:"")

           SET SDWLSX="     "_SDWLS

 +1        SET SDWLF="SCTM(404.51,"

 +2        SET SDWLA=0

FOR

               SET SDWLA=$ORDER(^SCTM(404.58,"B",SDWLA))

               if SDWLA=""

                   QUIT

               Begin DoDot:1

 +3                IF $DATA(SDWLCT)

                       IF SDWLCT=SDWLA

                           QUIT

 +4                IF $PIECE($GET(^SCTM(404.51,SDWLA,0)),U,7)'=SDWLIN

                       QUIT

 +5                IF +$$ACTTM^SCMCTMU(SDWLA)=0

                       SET SDWLTH(SDWLA)=""

 +6                SET SDWLMAX=0

                   SET X=$$TEAMCNT^SCAPMCU1(SDWLA,DT)

                   SET SDWLMAX(SDWLA)=""

                   Begin DoDot:2

 +7                    IF X<$PIECE($GET(^SCTM(404.51,SDWLA,0)),U,8)

                           KILL SDWLMAX(SDWLA)

                   End DoDot:2

               End DoDot:1

 +8        NEW SDWLT

           SET SDWLT=0

FOR

               SET SDWLT=$ORDER(SDWLPLST(1,SDWLT))

               if SDWLT<1

                   QUIT

               KILL SDWLMAX(SDWLT)

 +9        SET SDWLSCR="I $P(^(0),U,7)=SDWLIN,'$D(SDWLTH(+Y)),$D(SDWLMAX(+Y)),'$D(SDWLPLST(SDWLTYE,+Y,SDWLIN))"

 +10       DO EN2

           if $DATA(DUOUT)

               GOTO END

 +11      ;DA=SDWLDA, see EN

 +12       SET DR="5////^S X=SDWLVAR"

           SET DIE=409.3

           DO ^DIE

 +13       NEW FLG

           DO FLAGS(.FLG,DFN,SDWLVAR)

 +14       IF 'FLG

               SET DA=SDTMENT

               SET DIE=409.3

               Begin DoDot:1

 +15               SET SDINTR=FLG(1)

                   SET SDREJ=FLG(2)

                   SET SDMTM=FLG(3)

 +16               SET DR="32////^S X=SDREJ;34////^S X=SDINTR;38////^S X=SDMTM"

                   DO ^DIE

               End DoDot:1

 +17      ;

 +18       SET @SDWLVBR=SDWLVAR

 +19       IF $DATA(SDWLVARO)

               IF SDWLVARO

                   IF SDWLVAR'=SDWLVARO

                       DO DELPOS

 +20       GOTO END

EN2       ;-DIR READ

 +1        IF '$DATA(SDWLDATA)

               IF $DATA(SDWLMAX)'=11

                   WRITE !,"No TEAMS are available for this INSTITUTION.",!

                   SET DUOUT=""

                   QUIT

 +2        KILL DIR,DR,DIE,DIC,DUOUT

 +3        SET DIR("?")="^S X=""?"",DIC(""S"")=""I $P(^SCTM(404.51,+Y,0),U,7)=SDWLIN,'$D(SDWLTH(+Y)),$D(SDWLMAX(+Y)),'$D(SDWLPLST(1,+Y,SDWLINE))"" S DIC=404.51,DIC(0)=""EQMNZ"" D ^DIC"

 +4        IF $DATA(SDWLVAR)

               IF SDWLVAR

                   SET X=SDWLVAR

                   SET SDWLMPX=$$EXTERNAL^DILFD(409.3,SDWLYN,,SDWLVAR)

                   SET DIR("B")=SDWLMPX

                   SET SDWLVARO=SDWLVAR

                   KILL X

 +5        SET DIR(0)="FAO"

           SET DIR("A")="Select "_SDWLY_": "

 +6        DO ^DIR

 +7        IF X["^"

               SET DUOUT=1

               QUIT

 +8        SET DUOUT=$SELECT(X=0:1,X="@":1,$DATA(DTOUT):1,1:0)

           IF 'DUOUT

               KILL DUOUT

 +9        IF X="@"

               WRITE *7," No deleting allowing."

               GOTO EN2

 +10       SET DIC("S")=SDWLSCR

 +11       SET DIC(0)="EMNZ"

           SET DIC=404.51

           DO ^DIC

           IF $DATA(DTOUT)

               SET DUOUT=1

 +12       IF $DATA(DUOUT)

               QUIT

 +13       IF Y<0

               WRITE "??"

               GOTO EN2

 +14       SET SDWLVAR=+Y

 +15       QUIT

 +16      ;identify flags

FLAGS(FLG,DFN,TEAM) ;

 +1        NEW SDTEAM

           SET SDTEAM=$GET(TEAM)

 +2       ; check if transfer and if multiple teams in institution

 +3        SET SDCNT=0

           SET SDINTR=0

           SET SDREJ=0

           SET SDMTM=0

           Begin DoDot:1

 +4            SET SDWLIN=$PIECE($GET(^SCTM(404.51,TEAM,0)),U,7)

 +5       ; cannot be primary care provider team

               IF $PIECE(^SCTM(404.51,TEAM,0),U,5)'=1

                   QUIT

 +6       ;identify INTRA-transfer

 +7       ;- is patient assigned to PC provider?

 +8            IF $$GETALL^SCAPMCA(DFN)

                   Begin DoDot:2

 +9                    IF $GET(^TMP("SC",$JOB,DFN,"PCPOS",0))

                           SET SDTM=$PIECE(^(1),U,3)

                           IF SDTM>0

                               Begin DoDot:3

 +10      ; inter transfer ; different institution

                                   IF $PIECE($GET(^SCTM(404.51,SDTM,0)),U,7)'=SDWLIN

                                       SET SDINTR=1

                                       Begin DoDot:4

                                       End DoDot:4

                               End DoDot:3

 +11                   IF '$GET(^TMP("SC",$JOB,DFN,"PCPOS",0))

                           Begin DoDot:3

 +12      ;check available PCMM teams in other institutions and if so set up rejection flag

 +13                           SET SDINS=""

 +14                           FOR

                                   SET SDINS=$ORDER(^SCTM(404.51,"AINST",SDINS))

                                   if SDINS=""

                                       QUIT

                                   IF SDINS'=SDWLIN

                                       Begin DoDot:4

 +15                                       SET SDCNT=0

                                           SET SDT=""

 +16                                       FOR

                                               SET SDT=$ORDER(^SCTM(404.51,"AINST",SDINS,SDT))

                                               if SDT=""

                                                   QUIT

                                               Begin DoDot:5

 +17                                               IF $$ACTTM^SCMCTMU(SDT,DT)&($PIECE($GET(^SCTM(404.51,SDT,0)),U,5))&'$PIECE($GET(^SCTM(404.51,SDT,0)),U,10)

                                                       Begin DoDot:6

 +18      ;currently assigned

                                                           SET SCTMCT=$$TEAMCNT^SCAPMCU1(SDT)

 +19      ;maximum set

                                                           SET SCTMMAX=$PIECE($$GETEAM^SCAPMCU3(SDT),"^",8)

 +20                                                       IF SCTMCT<SCTMMAX

                                                               SET SDREJ=1

                                                       End DoDot:6

                                               End DoDot:5

                                               if SDREJ

                                                   QUIT

                                       End DoDot:4

                                       if SDREJ

                                           QUIT

                           End DoDot:3

 +21      ;find all teams from institution SDWLIN

 +22                   IF SDINTR

                           SET SDCNT=0

                           SET SDT=""

                           Begin DoDot:3

 +23                           FOR

                                   SET SDT=$ORDER(^SCTM(404.51,"AINST",SDWLIN,SDT))

                                   if SDT=""

                                       QUIT

                                   IF $PIECE(^SCTM(404.51,SDT,0),U,5)=1

                                       SET TEAM(SDT)=""

                                       SET SDCNT=SDCNT+1

                           End DoDot:3

                   End DoDot:2

           End DoDot:1

 +24       SET FLG(1)=SDINTR

           SET FLG(2)=SDREJ

           SET FLG(3)=SDMTM

 +25       IF SDCNT>1

               SET SDMTM=1

               SET FLG(3)=SDMTM

               SET FLG=1

               SET SDCC=""

FOR

                   SET SDCC=$ORDER(TEAM(SDCC))

                   if SDCC=""

                       QUIT

                   SET TEAM=SDCC

                   NEW DR,Y

                   DO WMT

 +26       IF SDCNT>1

               SET TEAM=$GET(SDTEAM)

               QUIT

 +27       IF SDCNT'>1

               NEW DR,Y

               SET FLG=0

               SET TEAM=$GET(SDTEAM)

               QUIT

WMT        DO INPUT^SDWLRP1(.RES,DFN_U_1_U_TEAM_U_U_DUZ_"^^"_U_SDINTR_U_SDREJ_U_SDMTM)

 +1       ;I $G(RES) S OK=0,DA=+$P(RES,U,2),DIE="^SDWL(409.3,",DR="25;S OK=1" D ^DIE  I '$G(OK) S DIK=DIE D ^DIK W !,"Wait list entry deleted"

 +2        QUIT

GETLIST   ;GET LIST OF TEAM ASSIGNMENTS - SD*5.3*417

 +1        NEW SDWLDAX,X,Z,SDWLIN

           KILL SDWLPLST

           SET SDWLPLST=""

 +2        SET SDWLDAX=0

FOR

               SET SDWLDAX=$ORDER(^SDWL(409.3,"B",SDWLDFN,SDWLDAX))

               if SDWLDAX=""

                   QUIT

               Begin DoDot:1

 +3                SET Z=$GET(^SDWL(409.3,SDWLDAX,0))

                   SET X=$PIECE(Z,U,5)

                   SET SDWLINE=+$PIECE(Z,U,3)

                   if X'=1&(X'=2)

                       QUIT

                   Begin DoDot:2

 +4                    SET Y=+$SELECT(X=1:$PIECE(Z,U,6),X=2:$PIECE(Z,U,7),1:0)

                       if 'Y

                           QUIT

                       Begin DoDot:3

 +5                        IF $PIECE(Z,U,17)["O"

                               SET SDWLPLST(X,Y,SDWLINE)=""

                               IF $DATA(SDWLST)

                                   IF SDWLST=+Y

                                       KILL SDWLPLST(X,Y,SDWLINE)

                       End DoDot:3

                   End DoDot:2

               End DoDot:1

 +6        SET Y=0

FOR

               SET Y=$ORDER(SDWLCPT(Y))

               if Y=""

                   QUIT

               Begin DoDot:1

 +7                SET SDWLPLST(1,Y,SDWLINE)=""

                   IF $DATA(SDWLST)

                       IF SDWLST=+Y

                           KILL SDWLPLST(1,Y,SDWLINE)

               End DoDot:1

 +8        QUIT

DELPOS    ;DELETE POSITIONS FOR OLD TEAM

 +1        SET SDWLA=0

           SET CNT=0

FOR

               SET SDWLA=$ORDER(^SDWL(409.3,"B",SDWLDFN,SDWLA))

               if SDWLA<1

                   QUIT

               Begin DoDot:1

 +2                SET X=$GET(^SDWL(409.3,SDWLA,0))

                   if $PIECE(X,U,7)=""

                       QUIT

 +3                IF $PIECE(X,U,5)'=2

                       QUIT

 +4                IF $PIECE(X,U,17)["C"

                       QUIT

 +5                SET SDWLPX=+$PIECE(X,U,7)

                   IF $PIECE($GET(^SCTM(404.57,SDWLPX,0)),U,2)'=SDWLVARO

                       QUIT

 +6                SET CNT=CNT+1

                   SET ^XTMP("SDWLE3",$JOB,CNT)=SDWLA_";"_X

                   WRITE !

               End DoDot:1

 +7        IF 'CNT

               QUIT

 +8        WRITE !,"This patient has one or more Wait List entries for PCMM Positions",!

 +9        WRITE !,"Wait List Type",?30,"Waiting For",?45,"Institution",?60,"Date Entered",!

 +10       SET Y=0

FOR

               SET Y=$ORDER(^XTMP("SDWLE3",$JOB,Y))

               if Y<1

                   QUIT

               SET X=$GET(^XTMP("SDWLE3",$JOB,Y))

               SET SDWLIEN=$PIECE(X,";",1)

               Begin DoDot:1

 +11               WRITE !,$$GET1^DIQ(409.3,SDWLIEN,4),?30,$$GET1^DIQ(409.3,SDWLIEN,6),?45,$$GET1^DIQ(409.3,SDWLIEN,2),?60,$$GET1^DIQ(409.3,SDWLIEN,1)

               End DoDot:1

 +12       WRITE !

           SET SDWLET=$$EXTERNAL^DILFD(409.3,SDWLYN,,SDWLVARO)

 +13       KILL DIR

           SET DIR("?",1)="This patient has one or more Wait List entries for PCMM positions."

 +14       SET DIR("?",2)="By answering 'YES' you will close the Wait List entries which were listed."

 +15       SET DIR("?")="Answer 'NO' to keep those Wait List entries open."

 +16       SET DIR("A")="Do you wish to close these POSITION(S) entries? "

           SET DIR(0)="Y"

           SET DIR("B")="YES"

           DO ^DIR

 +17       IF 'Y

               WRITE *7," No POSITIONS closed."

               QUIT

 +18       NEW DA

           SET SDWLA=0

FOR

               SET SDWLA=$ORDER(^SDWL(409.3,"B",SDWLDFN,SDWLA))

               if SDWLA<1

                   QUIT

               Begin DoDot:1

 +19               SET X=$GET(^SDWL(409.3,SDWLA,0))

                   if $PIECE(X,U,7)=""

                       QUIT

                   Begin DoDot:2

 +20                   SET SDWLP=$PIECE(X,U,7)

                       IF $PIECE(^SCTM(404.57,SDWLP,0),U,2)=SDWLVARO

                           Begin DoDot:3

 +21                           KILL DIE,DIC,DR,DICR,DIR

                               SET DA=SDWLA

                               SET SDWLDISP="NN"

 +22                           SET DIE="^SDWL(409.3,"

                               SET DR="21////^S X=SDWLDISP"

                               DO ^DIE

 +23                           SET DR="19////^S X=DT"

                               DO ^DIE

 +24                           SET DR="20////^S X=SDWLDUZ"

                               DO ^DIE

 +25                           SET DR="23////""C"""

                               DO ^DIE

                           End DoDot:3

                   End DoDot:2

               End DoDot:1

 +26       QUIT

END        KILL SDWLA,SDWLMAX,SDWLTH,SDWLSCR,DIR,DIC,DIE,DR,SDWLPLST,SDWLDAX,DTOUT,SDWLCP3,SDWLINE

 +1        KILL X,Y,Z,SDWLPLST,SDWLB,SDWLA,SDWLSX,SDWLS,SDWLVBR,SDWLVAR,SDWLSCR,SDWLF,SDWLYN,SDWLMPX

 +2        QUIT

SDWLE3.m