source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLE3.m@ 1776

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

initial load of WorldVistAEHR
File size: 6.7 KB
Line 
1SDWLE3 ;IOFO BAY PINES/TEH - WAITING LIST-ENTER/EDIT;06/12/2002 ; 12/14/05 1:28pm ; Compiled April 25, 2006 10:42:02
2 ;;5.3;scheduling;**263,417,446**;AUG 13 1993;Build 77
3 ;
4 ;
5 ;******************************************************************
6 ; CHANGE LOG
7 ;
8 ; DATE PATCH DESCRIPTION
9 ; ---- ----- -----------
10 ; 08/01/2005 SD*5.3*417 Permit multiple teams
11 ; 04/21/2006 SD*5.3*446 Inter-Facility Transfer
12 ;
13 ;
14EN ;
15 ;ASK FOR SPECIFIC TEAM (404.51)
16 K DIR,DIC,DR,DIE,SDTMENT S (DA,SDTMENT)=SDWLDA K SDWLTH,SDWLMAX
17 S SDWLYN=5,SDWLTYE=1,SDWLVBR="SDWLST"
18 I $D(SDWLST),'SDWLST K SDWLST
19 I $G(SDWLCP3)'="" D
20 .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
21 .I 'Y!(Y["^") S DUOUT=1 Q
22 I $D(DUOUT),DUOUT G END
23 D GETLIST
24 S SDWLERR=0,SDWLY="Team",SDWLVAR=$S($D(SDWLST):SDWLST,1:0),SDWLSCR=""
25 S SDWLVBR="SDWLST"
26EN1 W ! S SDWLS=SDWLY,SDWLX=$S(SDWLTYE=1:"T",SDWLTYE=2:"P",1:""),SDWLSX=" "_SDWLS
27 S SDWLF="SCTM(404.51,"
28 S SDWLA=0 F S SDWLA=$O(^SCTM(404.58,"B",SDWLA)) Q:SDWLA="" D
29 .I $D(SDWLCT),SDWLCT=SDWLA Q
30 .I $P($G(^SCTM(404.51,SDWLA,0)),U,7)'=SDWLIN Q
31 .I +$$ACTTM^SCMCTMU(SDWLA)=0 S SDWLTH(SDWLA)=""
32 .S SDWLMAX=0,X=$$TEAMCNT^SCAPMCU1(SDWLA,DT),SDWLMAX(SDWLA)="" D
33 ..I X<$P($G(^SCTM(404.51,SDWLA,0)),U,8) K SDWLMAX(SDWLA)
34 N SDWLT S SDWLT=0 F S SDWLT=$O(SDWLPLST(1,SDWLT)) Q:SDWLT<1 K SDWLMAX(SDWLT)
35 S SDWLSCR="I $P(^(0),U,7)=SDWLIN,'$D(SDWLTH(+Y)),$D(SDWLMAX(+Y)),'$D(SDWLPLST(SDWLTYE,+Y,SDWLIN))"
36 D EN2 G END:$D(DUOUT)
37 ;DA=SDWLDA, see EN
38 S DR="5////^S X=SDWLVAR",DIE=409.3 D ^DIE
39 N FLG D FLAGS(.FLG,DFN,SDWLVAR)
40 I 'FLG S DA=SDTMENT,DIE=409.3 D
41 .S SDINTR=FLG(1),SDREJ=FLG(2),SDMTM=FLG(3)
42 .S DR="32////^S X=SDREJ;34////^S X=SDINTR;38////^S X=SDMTM" D ^DIE
43 ;
44 S @SDWLVBR=SDWLVAR
45 I $D(SDWLVARO),SDWLVARO,SDWLVAR'=SDWLVARO D DELPOS
46 G END
47EN2 ;-DIR READ
48 I '$D(SDWLDATA),$D(SDWLMAX)'=11 W !,"No TEAMS are available for this INSTITUTION.",! S DUOUT="" Q
49 K DIR,DR,DIE,DIC,DUOUT
50 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"
51 I $D(SDWLVAR),SDWLVAR S X=SDWLVAR,SDWLMPX=$$EXTERNAL^DILFD(409.3,SDWLYN,,SDWLVAR),DIR("B")=SDWLMPX,SDWLVARO=SDWLVAR K X
52 S DIR(0)="FAO",DIR("A")="Select "_SDWLY_": "
53 D ^DIR
54 I X["^" S DUOUT=1 Q
55 S DUOUT=$S(X=0:1,X="@":1,$D(DTOUT):1,1:0) I 'DUOUT K DUOUT
56 I X="@" W *7," No deleting allowing." G EN2
57 S DIC("S")=SDWLSCR
58 S DIC(0)="EMNZ",DIC=404.51 D ^DIC I $D(DTOUT) S DUOUT=1
59 I $D(DUOUT) Q
60 I Y<0 W "??" G EN2
61 S SDWLVAR=+Y
62 Q
63 ;identify flags
64FLAGS(FLG,DFN,TEAM) ;
65 N SDTEAM S SDTEAM=$G(TEAM)
66 ; check if transfer and if multiple teams in institution
67 S SDCNT=0,SDINTR=0,SDREJ=0,SDMTM=0 D
68 .S SDWLIN=$P($G(^SCTM(404.51,TEAM,0)),U,7)
69 .I $P(^SCTM(404.51,TEAM,0),U,5)'=1 Q ; cannot be primary care provider team
70 .;identify INTRA-transfer
71 .;- is patient assigned to PC provider?
72 .I $$GETALL^SCAPMCA(DFN) D
73 ..I $G(^TMP("SC",$J,DFN,"PCPOS",0)) S SDTM=$P(^(1),U,3) I SDTM>0 D
74 ...I $P($G(^SCTM(404.51,SDTM,0)),U,7)'=SDWLIN S SDINTR=1 D ; inter transfer ; different institution
75 ..I '$G(^TMP("SC",$J,DFN,"PCPOS",0)) D
76 ...;check available PCMM teams in other institutions and if so set up rejection flag
77 ...S SDINS=""
78 ...F S SDINS=$O(^SCTM(404.51,"AINST",SDINS)) Q:SDINS="" I SDINS'=SDWLIN D Q:SDREJ
79 ....S SDCNT=0,SDT=""
80 ....F S SDT=$O(^SCTM(404.51,"AINST",SDINS,SDT)) Q:SDT="" D Q:SDREJ
81 .....I $$ACTTM^SCMCTMU(SDT,DT)&($P($G(^SCTM(404.51,SDT,0)),U,5))&'$P($G(^SCTM(404.51,SDT,0)),U,10) D
82 ......S SCTMCT=$$TEAMCNT^SCAPMCU1(SDT) ;currently assigned
83 ......S SCTMMAX=$P($$GETEAM^SCAPMCU3(SDT),"^",8) ;maximum set
84 ......I SCTMCT<SCTMMAX S SDREJ=1
85 ..;find all teams from institution SDWLIN
86 ..I SDINTR S SDCNT=0,SDT="" D
87 ...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
88 S FLG(1)=SDINTR,FLG(2)=SDREJ,FLG(3)=SDMTM
89 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
90 I SDCNT>1 S TEAM=$G(SDTEAM) Q
91 I SDCNT'>1 N DR,Y S FLG=0 S TEAM=$G(SDTEAM) Q
92WMT D INPUT^SDWLRP1(.RES,DFN_U_1_U_TEAM_U_U_DUZ_"^^"_U_SDINTR_U_SDREJ_U_SDMTM)
93 ;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"
94 Q
95GETLIST ;GET LIST OF TEAM ASSIGNMENTS - SD*5.3*417
96 N SDWLDAX,X,Z,SDWLIN K SDWLPLST S SDWLPLST=""
97 S SDWLDAX=0 F S SDWLDAX=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDAX)) Q:SDWLDAX="" D
98 .S Z=$G(^SDWL(409.3,SDWLDAX,0)),X=$P(Z,U,5),SDWLINE=+$P(Z,U,3) Q:X'=1&(X'=2) D
99 ..S Y=+$S(X=1:$P(Z,U,6),X=2:$P(Z,U,7),1:0) Q:'Y D
100 ...I $P(Z,U,17)["O" S SDWLPLST(X,Y,SDWLINE)="" I $D(SDWLST),SDWLST=+Y K SDWLPLST(X,Y,SDWLINE)
101 S Y=0 F S Y=$O(SDWLCPT(Y)) Q:Y="" D
102 .S SDWLPLST(1,Y,SDWLINE)="" I $D(SDWLST),SDWLST=+Y K SDWLPLST(1,Y,SDWLINE)
103 Q
104DELPOS ;DELETE POSITIONS FOR OLD TEAM
105 S SDWLA=0,CNT=0 F S SDWLA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLA)) Q:SDWLA<1 D
106 .S X=$G(^SDWL(409.3,SDWLA,0)) Q:$P(X,U,7)=""
107 .I $P(X,U,5)'=2 Q
108 .I $P(X,U,17)["C" Q
109 .S SDWLPX=+$P(X,U,7) I $P($G(^SCTM(404.57,SDWLPX,0)),U,2)'=SDWLVARO Q
110 .S CNT=CNT+1,^XTMP("SDWLE3",$J,CNT)=SDWLA_";"_X W !
111 I 'CNT Q
112 W !,"This patient has one or more Wait List entries for PCMM Positions",!
113 W !,"Wait List Type",?30,"Waiting For",?45,"Institution",?60,"Date Entered",!
114 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
115 .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)
116 W ! S SDWLET=$$EXTERNAL^DILFD(409.3,SDWLYN,,SDWLVARO)
117 K DIR S DIR("?",1)="This patient has one or more Wait List entries for PCMM positions."
118 S DIR("?",2)="By answering 'YES' you will close the Wait List entries which were listed."
119 S DIR("?")="Answer 'NO' to keep those Wait List entries open."
120 S DIR("A")="Do you wish to close these POSITION(S) entries? ",DIR(0)="Y",DIR("B")="YES" D ^DIR
121 I 'Y W *7," No POSITIONS closed." Q
122 N DA S SDWLA=0 F S SDWLA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLA)) Q:SDWLA<1 D
123 .S X=$G(^SDWL(409.3,SDWLA,0)) Q:$P(X,U,7)="" D
124 ..S SDWLP=$P(X,U,7) I $P(^SCTM(404.57,SDWLP,0),U,2)=SDWLVARO D
125 ...K DIE,DIC,DR,DICR,DIR S DA=SDWLA,SDWLDISP="NN"
126 ...S DIE="^SDWL(409.3,",DR="21////^S X=SDWLDISP" D ^DIE
127 ...S DR="19////^S X=DT" D ^DIE
128 ...S DR="20////^S X=SDWLDUZ" D ^DIE
129 ...S DR="23////""C""" D ^DIE
130 Q
131END K SDWLA,SDWLMAX,SDWLTH,SDWLSCR,DIR,DIC,DIE,DR,SDWLPLST,SDWLDAX,DTOUT,SDWLCP3,SDWLINE
132 K X,Y,Z,SDWLPLST,SDWLB,SDWLA,SDWLSX,SDWLS,SDWLVBR,SDWLVAR,SDWLSCR,SDWLF,SDWLYN,SDWLMPX
133 Q
Note: See TracBrowser for help on using the repository browser.