85 lines
4.2 KiB
Mathematica
85 lines
4.2 KiB
Mathematica
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
|