- 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 Feb 19, 2025@00:29:03 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
