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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLE5 4358 printed Apr 09, 2024@21:49:27 Page 2
SDWLE5 ;;IOFO BAY PINES/TEH - WAITING LIST-ENTER/EDIT;06/12/2002 ; 11/28/05 10 ; Compiled February 7, 2006 11:42:40:32am
+1 ;;5.3;scheduling;**263,417**;AUG 13 1993
+2 ;
+3 ;
+4 ;***************************************************************************************************
+5 ; CHANGE LOG
+6 ; PATCH DESCRIPTION
+7 ; ---- ----- -----------
+8 ;04/10/2005 SD*5.3*417 Add ability to select multiple POSITIONS for a TEAM.
+9 ;
+10 ;
EN ;
+1 ;POSITION (404.57)
+2 KILL DIR,DIC,SDWLCPP
NEW SDWLCP
SET SDWLTCNT=0
+3 DO GETTEAM
DO GETLIST
+4 IF SDWLTCNT>1
Begin DoDot:1
+5 WRITE !,"Patient has multiple TEAM entries. Select the TEAM for POSITION selection.",!
+6 KILL Y
NEW X
SET X=0
FOR
SET X=$ORDER(SDWLTP("T",X))
if X<1
QUIT
SET SDWLT=$$GET1^DIQ(404.51,X_",",.01)
WRITE !,?10,SDWLT
+7 WRITE !
SET DIR(0)="PAO^404.51:EMZ"
SET DIR("S")="I $D(SDWLTP(""T"",+Y))"
SET DIR("A")="Select TEAM: "
DO ^DIR
if Y<1
QUIT
+8 IF +Y
KILL SDWLCT
SET SDWLCT(+Y)=""
SET SDWLCT=+Y
SET SDWLIN=+$PIECE(Y(0),U,7)
QUIT
End DoDot:1
if Y="^"
GOTO END
IF Y<1
WRITE *7,"Select a TEAM or enter an '^' to QUIT."
GOTO EN
+9 IF SDWLTCNT'>1
IF $DATA(SDWLINL)
SET SDWLIN=SDWLINL
+10 IF $DATA(SDWLCT)
SET SDX=$PIECE($GET(^SCTM(404.57,SDWLCT,0)),U,2)
SET SDWLIN=$PIECE($GET(^SCTM(404.51,SDX,0)),U,7)
ENA ;
+1 IF '$DATA(SDWLTP("T",SDWLCT,"P"))
WRITE !,"No Positions Meet Wait List Criteria"
GOTO END
+2 KILL DIR,DIC,DR,DIE,SDWLSCR
SET DA=SDWLDA
KILL SDWLTH,SDWLMAX
+3 SET SDWLERR=0
SET SDWLY="Position"
SET SDWLVAR=$SELECT($DATA(SDWLSP):SDWLSP,1:0)
+4 SET (SDWLYN,SDWLTYE)=6
SET SDWLVBR="SDWLSP"
SET SDWLF=404.57
+5 SET SDWLMAX=$PIECE(^SCTM(404.57,0),U,3)
+6 IF $DATA(^SDWL(409.3,SDWLDA,0))
IF $PIECE(^(0),U,3)=""
Begin DoDot:1
+7 SET DIE="^SDWL(409.3,"
SET DR="2////^S X=SDWLIN"
SET DA=SDWLDA
DO ^DIE
End DoDot:1
+8 SET SDWLA=0
FOR
SET SDWLA=$ORDER(^SCTM(404.57,SDWLA))
if SDWLA<1
QUIT
Begin DoDot:1
+9 IF '$DATA(SDWLTP("T",SDWLCT,"P",SDWLA))
QUIT
+10 SET SDWLMAX=0
SET X=$$PCPOSCNT^SCAPMCU1(SDWLA,DT,0)
SET SDWLMAX(SDWLA)=""
Begin DoDot:2
+11 IF X>0
IF $PIECE(^SCTM(404.57,SDWLA,0),U,8)>X!($PIECE(^SCTM(404.57,SDWLA,0),U,8)=X)
KILL SDWLMAX(SDWLA)
End DoDot:2
+12 SET X=$GET(^SCTM(404.57,SDWLA,0))
IF +$PIECE(X,U,4)=0
SET SDWLTH(SDWLA)=""
KILL SDWLMAX(SDWLA)
+13 IF '$DATA(SDWLSCR)
SET SDWLN=0
+14 SET SDWLSCR="I $P(^SCTM(404.57,+Y,0),U,2)=SDWLCT,'$D(SDWLTH(+Y)),$D(SDWLMAX(+Y)),'$D(SDWLPSS(+Y))"
End DoDot:1
+15 IF '$ORDER(SDWLMAX(0))
WRITE !,"No Position for this Team meets Wait List Criteria"
SET SDWLERR=1
SET DUOUT=1
+16 if SDWLERR
GOTO END
EN0 WRITE !
DO EN1
+1 IF $DATA(DUOUT)
IF SDWLVAR
GOTO END
+2 SET DR=SDWLYN_"////^S X=SDWLVAR"
SET DIE=409.3
DO ^DIE
SET @SDWLVBR=SDWLVAR
GOTO END
+3 QUIT
EN1 ;;-DIC LOOKUP
+1 IF $DATA(SDWLDATA)
KILL SDWLPSS
+2 IF SDWLCT=SDWLVAR
Begin DoDot:1
+3 SET X=$$EXTERNAL^DILFD(409.3,SDWLYN,,SDWLCT)
IF X'=""
SET DIR("B")=X
End DoDot:1
+4 KILL DR,DIE,DIC,DUOUT
SET 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"
+5 SET DIR(0)="FAO"
SET DIR("A")="Select "_SDWLY_": "
DO ^DIR
+6 IF $DATA(DTOUT)
SET DUOUT=1
+7 IF X["^"
SET DUOUT=1
QUIT
+8 IF X="@"
WRITE *7," ??"
GOTO EN1
+9 IF X=""
WRITE *7,"Required or '^' to quit."
GOTO EN1
+10 SET DUOUT=$SELECT(X=0:1,X="":1,X["^":1,$DATA(DTOUT):1,X="@":1,1:0)
IF 'DUOUT
KILL DUOUT
+11 IF $DATA(DUOUT)
QUIT
+12 SET DIC("S")=SDWLSCR
SET DIC=404.57
+13 SET DIC(0)="EMNZ"
DO ^DIC
if +Y<1
GOTO EN1
SET SDWLVAR=+Y
+14 KILL DIR
+15 QUIT
GETLIST ;GET LIST OF VALID POSITIONS
+1 NEW SDWLTMX,SDWLTMP,SDWLP
SET (SDWLTMX,SDWLTMP)=0
+2 FOR
SET SDWLTMX=$ORDER(SDWLTP("T",SDWLTMX))
if SDWLTMX<1
QUIT
Begin DoDot:1
+3 SET SDWLP=0
FOR
SET SDWLP=$ORDER(^SCTM(404.57,"C",SDWLTMX,SDWLP))
if SDWLP<1
QUIT
Begin DoDot:2
+4 IF $DATA(SDWLCP4N)
IF SDWLP=SDWLCP4N
QUIT
+5 SET SDWLTP("T",SDWLTMX,"P",SDWLP)=""
End DoDot:2
End DoDot:1
+6 FOR
SET SDWLTMP=$ORDER(^SDWL(409.3,"B",SDWLDFN,SDWLTMP))
if SDWLTMP<1
QUIT
Begin DoDot:1
+7 SET X=$GET(^SDWL(409.3,SDWLTMP,0))
IF X
Begin DoDot:2
+8 IF $PIECE(X,U,5)=2
SET Y=$PIECE(X,U,7)
IF Y
SET SDWLTMX=$PIECE($GET(^SCTM(404.57,Y,0)),U,2)
IF $DATA(SDWLTP("T",SDWLTMX,"P",Y))
KILL SDWLTP("T",SDWLTMX,"P",Y)
End DoDot:2
End DoDot:1
+9 QUIT
GETTEAM ;GET TEAMS
+1 ;GET CURRENT TEAM ASSIGNMENTS 404.41 AND 409.3
+2 ;
+3 KILL SDWLTMX,SDWLTP
SET SDWLTP=""
SET SDWLTCNT=0
NEW SDWLZ
+4 SET SDWLZ=0
FOR
SET SDWLZ=$ORDER(^SCPT(404.42,"B",SDWLDFN,SDWLZ))
if SDWLZ<1
QUIT
Begin DoDot:1
+5 SET X=$GET(^SCPT(404.42,SDWLZ,0))
IF $PIECE(X,U,9)
QUIT
+6 SET SDWLTP("T",+$PIECE(X,U,3))=""
SET SDWLCT=$PIECE(X,U,3)
SET SDWLTCNT=SDWLTCNT+1
End DoDot:1
+7 SET SDWLTMX=0
+8 FOR
SET SDWLTMX=$ORDER(^SDWL(409.3,"B",SDWLDFN,SDWLTMX))
if SDWLTMX<1
QUIT
Begin DoDot:1
+9 SET X=$GET(^SDWL(409.3,SDWLTMX,0))
if $PIECE(X,U,17)="C"
QUIT
if $PIECE(X,U,5)'=1
QUIT
IF +$PIECE(X,U,6)>0
IF '$DATA(SDWLP("T",$PIECE(X,U,6)))
SET SDWLTP("T",$PIECE(X,U,6))=""
SET SDWLTCNT=SDWLTCNT+1
SET SDWLCT=$PIECE(X,U,6)
End DoDot:1
+10 KILL SDWLTMX,X
+11 QUIT
END KILL SDWLA,SDWLMAX,SDWLTH,SDWLSCR,DIR,DIC,DIE,DR,SDWLTMX,SDWLPSS,SDWLPDA,SDWLCT,SDWLTMX,SDWLTCNT,SDWLPSS,SDWLPDA,SDWLX
+1 KILL SDWLVBR,SDWLVAR,SDWLYN,SDWLF,SDWLY,X,SDWLTP
+2 QUIT
