source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDWLE110.m@ 1800

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

initial load of FOIAVistA 6/30/08 version
File size: 4.6 KB
Line 
1SDWLE110 ;;IOFO BAY PINES/TEH - WAITING LIST-ENTER/EDIT;06/12/2002 ; 29 Aug 2002 2:54 PM
2 ;;5.3;scheduling;**263,273,424,454**;AUG 13 1993
3 ;
4 ;
5 ;******************************************************************
6 ; CHANGE LOG
7 ;
8 ; DATE PATCH DESCRIPTION
9 ; ---- ----- -----------
10 ; 11/27/02 SD*5.3*273 Add "/", line SA1+11,+13,FA2+13
11 ;
12 ;
13EN K DIR
14 I $D(^SDWL(409.3,SDWLDA,0)) S DIR("B")=$$EXTERNAL^DILFD(409.3,10,,$P(^(0),U,11))
15 I DIR("B")="" K DIR("B")
16 S DIR(0)="SO^1:Future Date;2:ASAP"
17 S DIR("L",1)="Priority",DIR("L",2)=""
18 S DIR("L",3)="1. Future Date",DIR("L")="2. ASAP"
19 D ^DIR I X["^" S DUOUT=1 Q ;-'^' here will remove patient from wait list
20 I X="@" W *7," ??" G EN
21 I X="" W *7,"Required or '^' to quit." G EN
22 I $D(DTOUT) S DUOUT=1 Q
23 S X=$E(X,1)
24 S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCEDFGHIJKLMNOPQRSTUVWXYZ")
25 S SDWLPRIE=$S(X["A":"A",X["F":"F",X[1:"F",X[2:"A",1:"F")
26 S DIE="^SDWL(409.3,",DA=SDWLDA,DR="10////^S X=SDWLPRIE" D ^DIE
27 ;
28 ;If priority is ASAP ask requesting provider
29 ;
30 I SDWLPRIE="A" S Y=DT D DD^%DT W " ",Y D SA,DUP G END:$D(DUOUT) Q
31 I SDWLPRIE="F" D FA G END:$D(DUOUT) Q ;to enter future date
32 Q
33 ;
34SA K DIR,DR,DIE S SDWLERR=0,SDWLX=$S($D(SDWLPROV):$$EXTERNAL^DILFD(409.3,12,,SDWLPROV),1:"")
35 I $D(SDWLPROV),SDWLPROV,SDWLX'="" S DIR("B")=SDWLX
36 I $D(^SDWL(409.3,SDWLDA,0)) S DIR("B")=$$EXTERNAL^DILFD(409.3,11,,$P(^(0),U,12))
37 I DIR("B")="" K DIR("B")
38 K %DT,DR S DIR(0)="SO^1:Provider;2:Patient"
39 S DIR("L",1)="Request By",DIR("L",2)=""
40 S DIR("L",3)="1. Provider",DIR("L")="2. Patient"
41 D ^DIR I X["^" S DUOUT=1,DIR("A")="ASAP" Q
42 S X=Y
43 I $D(DTOUT) S DUOUT=1,DIR("A")="ASAP" Q
44 S SDWLRBE=$S(X=1:1,X["PR":1,X["pr":1,X["Pr":1,X=2:2,X["PA":2,X["pa":2,X["Pa":2,1:0) I 'SDWLRBE W *7," ??" G SA
45 S DR="11////^S X=SDWLRBE",DA=SDWLDA,DIE="^SDWL(409.3," D ^DIE
46 ;
47SA1 I SDWLRBE=1 D
48 .S DIC("S")="I $$SCREEN^SDUTL2(Y,DT)"
49 .S SDWLX=$S($D(SDWLPROV):$$EXTERNAL^DILFD(409.3,12,,SDWLPROV),1:"") I SDWLX'="" S DIC("B")=SDWLPROV
50 .I $D(^SDWL(409.3,SDWLDA,0)) S DIR("B")=$$EXTERNAL^DILFD(409.3,11,,$P(^(0),U,12))
51 .S SDWLERR=0,DIC(0)="AEQ",DIC=200,DIC("A")="Provider Requesting Appointment: " D ^DIC
52 .I X["^" S DUOUT=1 Q
53 .I Y<1 S SDWLERR=1 Q
54 .I $D(DUOUT) Q
55 .I $D(DTOUT) S DUOUT=1 Q
56 .K DIC,DIC("S"),DIC("A"),DIC(0),DIC("B")
57 .S SDWLPROV=+Y,SDWLPRON=$P(Y,U,2),DIE="^SDWL(409.3,",DA=SDWLDA
58 .S DR="12////^S X=SDWLPROV" D ^DIE S SDWLPRVE=SDWLPROV
59 I SDWLERR W *7," Required" G SA1
60 S DR="11////^S X=SDWLRBE" D ^DIE
61 S DR="22///TODAY" D ^DIE K DIE,DR,DIC,DIR,SDWLPRVE,SDWLPROV,SDWLPRON
62 Q
63 ;
64 ;If Priority is 'FUTURE' ask Desired Date of Appointment and Requesting by Provider or Patient
65 ;
66FA S SDWLERR=0 K DIR,DUOUT,DR,DIE I $D(SDWLDAPE) S Y=SDWLDAPE D DD^%DT S DIR("B")=Y
67 I $D(^SDWL(409.3,SDWLDA,0)),$P(^(0),U,16) S %DT("B")=$$EXTERNAL^DILFD(409.3,22,,$P(^(0),U,16)) ;SD*5.3*424
68 S %DT="AE",%DT("A")="Desired Date of Appointment: " D ^%DT
69 I $D(DTOUT)!(X="^") G EN
70 I X="" W *7,!!,"This is a required response. Enter '^' to exit.",! G EN ;SD*5.3*454
71 S SDWLDAPE=Y,DR="22////^S X=SDWLDAPE",DIE="^SDWL(409.3,",DA=SDWLDA D ^DIE
72 K SDWLDAPE,Y,DA,DIE,%DT,%DT(0),%DT("A"),%DT("B")
73 ;
74FA1 K DIR,%DT,DR S DIR(0)="SO^1:Provider;2:Patient"
75 S SDWLX=$S($D(SDWLPROV):$$EXTERNAL^DILFD(409.3,12,,SDWLPROV),1:"") I SDWLX'="" S DIR("B")=SDWLPROV
76 I $D(^SDWL(409.3,SDWLDA,0)) S DIR("B")=$$EXTERNAL^DILFD(409.3,11,,$P(^(0),U,12))
77 I DIR("B")="" K DIR("B")
78 S DIR("L",1)="Request By",DIR("L",2)=""
79 S DIR("L",3)="1. Provider",DIR("L")="2. Patient"
80 D ^DIR I X["^" S DIR("B")=$S($D(SDWLDAPE):SDWLDAPE,1:"") G FA
81 S X=Y
82 I $D(DTOUT) S DUOUT=1 S DIR("B")=SDWLDAPE G FA
83 S SDWLRBE=$S(X=1:1,X["PR":1,X["pr":1,X["Pr":1,X=2:2,X["PA":2,X["pa":2,X["Pa":2,1:0) I 'SDWLRBE W *7," ??" G FA1
84 S DR="11////^S X=SDWLRBE",DA=SDWLDA,DIE="^SDWL(409.3," D ^DIE
85 ;
86FA2 I SDWLRBE=1 D
87 .;
88 .;if provider is selected look-up valid provider from new person (File 200)
89 .;
90 .S DIC("S")="I $$SCREEN^SDUTL2(Y,DT)"
91 .S SDWLX=$S($D(SDWLPROV):$$EXTERNAL^DILFD(409.3,12,,SDWLPROV),1:""),DIC("B")=$S($D(SDWLPROV):SDWLX,1:"")
92 .S SDWLERR=0,DIC(0)="AEQ",DIC=200,DIC("A")="Provider Requesting Appointment: " D ^DIC
93 .I X["^" S DUOUT=1 Q
94 .I Y<1 S SDWLERR=1 Q
95 .I $D(DTOUT) S DUOUT=1 Q
96 .Q:$D(DUOUT) D
97 ..K DIC,DIC("S"),DIC("A"),DIC(0),DIC("B")
98 ..S SDWLPROV=+Y,SDWLPRON=$P(Y,U,2),DIE="^SDWL(409.3,",DA=SDWLDA
99 ..S DR="12////^S X=SDWLPROV" D ^DIE S SDWLPRVE=SDWLPROV K DIE
100 I SDWLERR W *7," Required" G FA2
101END K DIC,DIE,DIR I $D(DUOUT) S DIR("B")=$S(SDWLPRIE="F":"Future",1:"ASAP")
102 K SDWLPRVE,SDWLPROV,SDWLPRON
103 Q
104 ;
105DUP ;
106 Q
Note: See TracBrowser for help on using the repository browser.