source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDWLE5.m@ 1446

Last change on this file since 1446 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.2 KB
Line 
1SDWLE5 ;;IOFO BAY PINES/TEH - WAITING LIST-ENTER/EDIT;06/12/2002 ; 11/28/05 10 ; Compiled February 7, 2006 11:42:40:32am
2 ;;5.3;scheduling;**263,417**;AUG 13 1993
3 ;
4 ;
5 ;***************************************************************************************************
6 ; CHANGE LOG
7 ; PATCH DESCRIPTION
8 ; ---- ----- -----------
9 ;04/10/2005 SD*5.3*417 Add ability to select multiple POSITIONS for a TEAM.
10 ;
11 ;
12EN ;
13 ;POSITION (404.57)
14 K DIR,DIC,SDWLCPP N SDWLCP S SDWLTCNT=0
15 D GETTEAM,GETLIST
16 I SDWLTCNT>1 D G END:Y="^" I Y<1 W *7,"Select a TEAM or enter an '^' to QUIT." G EN
17 .W !,"Patient has multiple TEAM entries. Select the TEAM for POSITION selection.",!
18 .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
19 .W ! S DIR(0)="PAO^404.51:EMZ",DIR("S")="I $D(SDWLTP(""T"",+Y))",DIR("A")="Select TEAM: " D ^DIR Q:Y<1
20 .I +Y K SDWLCT S SDWLCT(+Y)="",SDWLCT=+Y,SDWLIN=+$P(Y(0),U,7) Q
21 I SDWLTCNT'>1,$D(SDWLINL) S SDWLIN=SDWLINL
22 I $D(SDWLCT) S SDX=$P($G(^SCTM(404.57,SDWLCT,0)),U,2),SDWLIN=$P($G(^SCTM(404.51,SDX,0)),U,7)
23ENA ;
24 I '$D(SDWLTP("T",SDWLCT,"P")) W !,"No Positions Meet Wait List Criteria" G END
25 K DIR,DIC,DR,DIE,SDWLSCR S DA=SDWLDA K SDWLTH,SDWLMAX
26 S SDWLERR=0,SDWLY="Position",SDWLVAR=$S($D(SDWLSP):SDWLSP,1:0)
27 S (SDWLYN,SDWLTYE)=6,SDWLVBR="SDWLSP",SDWLF=404.57
28 S SDWLMAX=$P(^SCTM(404.57,0),U,3)
29 I $D(^SDWL(409.3,SDWLDA,0)),$P(^(0),U,3)="" D
30 .S DIE="^SDWL(409.3,",DR="2////^S X=SDWLIN",DA=SDWLDA D ^DIE
31 S SDWLA=0 F S SDWLA=$O(^SCTM(404.57,SDWLA)) Q:SDWLA<1 D
32 .I '$D(SDWLTP("T",SDWLCT,"P",SDWLA)) Q
33 .S SDWLMAX=0,X=$$PCPOSCNT^SCAPMCU1(SDWLA,DT,0),SDWLMAX(SDWLA)="" D
34 ..I X>0,$P(^SCTM(404.57,SDWLA,0),U,8)>X!($P(^SCTM(404.57,SDWLA,0),U,8)=X) K SDWLMAX(SDWLA)
35 .S X=$G(^SCTM(404.57,SDWLA,0)) I +$P(X,U,4)=0 S SDWLTH(SDWLA)="" K SDWLMAX(SDWLA)
36 .I '$D(SDWLSCR) S SDWLN=0
37 .S SDWLSCR="I $P(^SCTM(404.57,+Y,0),U,2)=SDWLCT,'$D(SDWLTH(+Y)),$D(SDWLMAX(+Y)),'$D(SDWLPSS(+Y))"
38 I '$O(SDWLMAX(0)) W !,"No Position for this Team meets Wait List Criteria" S SDWLERR=1,DUOUT=1
39 G END:SDWLERR
40EN0 W ! D EN1
41 I $D(DUOUT),SDWLVAR G END
42 S DR=SDWLYN_"////^S X=SDWLVAR",DIE=409.3 D ^DIE S @SDWLVBR=SDWLVAR G END
43 Q
44EN1 ;;-DIC LOOKUP
45 I $D(SDWLDATA) K SDWLPSS
46 I SDWLCT=SDWLVAR D
47 .S X=$$EXTERNAL^DILFD(409.3,SDWLYN,,SDWLCT) I X'="" S DIR("B")=X
48 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"
49 S DIR(0)="FAO",DIR("A")="Select "_SDWLY_": " D ^DIR
50 I $D(DTOUT) S DUOUT=1
51 I X["^" S DUOUT=1 Q
52 I X="@" W *7," ??" G EN1
53 I X="" W *7,"Required or '^' to quit." G EN1
54 S DUOUT=$S(X=0:1,X="":1,X["^":1,$D(DTOUT):1,X="@":1,1:0) I 'DUOUT K DUOUT
55 I $D(DUOUT) Q
56 S DIC("S")=SDWLSCR,DIC=404.57
57 S DIC(0)="EMNZ" D ^DIC G EN1:+Y<1 S SDWLVAR=+Y
58 K DIR
59 Q
60GETLIST ;GET LIST OF VALID POSITIONS
61 N SDWLTMX,SDWLTMP,SDWLP S (SDWLTMX,SDWLTMP)=0
62 F S SDWLTMX=$O(SDWLTP("T",SDWLTMX)) Q:SDWLTMX<1 D
63 .S SDWLP=0 F S SDWLP=$O(^SCTM(404.57,"C",SDWLTMX,SDWLP)) Q:SDWLP<1 D
64 ..I $D(SDWLCP4N),SDWLP=SDWLCP4N Q
65 ..S SDWLTP("T",SDWLTMX,"P",SDWLP)=""
66 F S SDWLTMP=$O(^SDWL(409.3,"B",SDWLDFN,SDWLTMP)) Q:SDWLTMP<1 D
67 .S X=$G(^SDWL(409.3,SDWLTMP,0)) I X D
68 ..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)
69 Q
70GETTEAM ;GET TEAMS
71 ;GET CURRENT TEAM ASSIGNMENTS 404.41 AND 409.3
72 ;
73 K SDWLTMX,SDWLTP S SDWLTP="",SDWLTCNT=0 N SDWLZ
74 S SDWLZ=0 F S SDWLZ=$O(^SCPT(404.42,"B",SDWLDFN,SDWLZ)) Q:SDWLZ<1 D
75 .S X=$G(^SCPT(404.42,SDWLZ,0)) I $P(X,U,9) Q
76 .S SDWLTP("T",+$P(X,U,3))="",SDWLCT=$P(X,U,3),SDWLTCNT=SDWLTCNT+1
77 S SDWLTMX=0
78 F S SDWLTMX=$O(^SDWL(409.3,"B",SDWLDFN,SDWLTMX)) Q:SDWLTMX<1 D
79 .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)
80 K SDWLTMX,X
81 Q
82END K SDWLA,SDWLMAX,SDWLTH,SDWLSCR,DIR,DIC,DIE,DR,SDWLTMX,SDWLPSS,SDWLPDA,SDWLCT,SDWLTMX,SDWLTCNT,SDWLPSS,SDWLPDA,SDWLX
83 K SDWLVBR,SDWLVAR,SDWLYN,SDWLF,SDWLY,X,SDWLTP
84 Q
Note: See TracBrowser for help on using the repository browser.