source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLPL.m@ 700

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

initial load of WorldVistAEHR
File size: 5.5 KB
RevLine 
[613]1SDWLPL ;IOFO BAY PINES/DMR,esw - WAIT LIST PICK LIST ; 6/1/05 1:05pm ; Compiled May 1, 2007 14:32:52
2 ;;5.3;scheduling;**327,394,417,446**;AUG 13, 1993;Build 77
3 ;
4 ;
5 ;09/23/2006 Patch SD*5.3*417 Upper/Lower case usage.
6 ;SD*5.3*446 - Included M - matched appointments
7 ;
8 I '$D(^SDWL(409.3,"B",DFN)) Q
9 S NN=""
10 W !,"This patient is currently on the Wait List."
11 ;
12ANS1 ;
13 S DIR("B")="NO",DIR("A")="Do you want to display open Wait list entries? (Y or N): ",DIR(0)="Y^AO" D ^DIR
14 K DIR
15 Q:'Y
16 ;
17ANS2(DFN,ANS2) ;
18 N STR S ANS2=" ",STR=",A,S,C,"
19 F Q:STR[ANS2!(ANS2="^") D
20TST .W !!,"Display Open Wait List entries selection:",!
21 .S DIR(0)="S^A:ALL;C:Matching Appt CLINIC;S:matching Appt SPECIALTY",DIR("B")="A",DIR("A")="Select Entry or ""^"" to QUIT " D ^DIR S ANS2=Y
22 .IF ANS2'="A"&(ANS2'="S")&(ANS2'="C")&(ANS2'="^") W !!,"PLEASE ENTER 'A' for All entries, 'C' for clinic or 'S' for current specialty/stop code or '^' to quit."
23 K DIR
24 Q:ANS2="^"
25 D INIT(DFN,ANS2) I '$D(^TMP($J,"SDWLPL")) W !!,"No selected open EWL entry has been found!" Q
26DISPLAY ;
27 D LIST(ANS2,DFN)
28 Q
29 ;
30INIT(DFN,ANS2) ;
31 ; ANS2: A - ALL
32 ; S - All Specialties
33 ; C - All Clinics
34 ; M - Matches stop codes only
35 S (INST,SCODE,CLINIC,DENTER,REQBY,DESIRD,SCPRI,IEN,SSN)="" K ^TMP("SDWLPL",$J),^TMP($J,"SDWLPL")
36 F S IEN=$O(^SDWL(409.3,"B",DFN,IEN)) Q:IEN="" D
37 .Q:$$GET1^DIQ(409.3,IEN_",",23,"I")="C"
38 .Q:$$GET1^DIQ(409.3,IEN_",",18,"I")'=""
39 .S ^TMP("SDWLPL",$J,IEN)=$G(^SDWL(409.3,IEN,0)) S DENTER="",DENTER=$P($G(^TMP("SDWLPL",$J,IEN)),"^",2)
40 .S (WLTYPE,TYPE,WLTN,NUM)="",TYPE=$P($G(^TMP("SDWLPL",$J,IEN)),"^",5)
41 .IF DENTER'=""&(TYPE'="") D
42 ..IF ANS2="A" D ARAY1
43 ..IF ANS2="S" D ARAY2
44 ..IF ANS2="C" D ARAY3
45 ..IF ANS2="M" D ARAY4
46 ;
47 K ANS1,NN,INST,SCODE,CLINIC,DENTER,REQBY,DESIRD,SCPRI
48 K CLINIC,WLTYPE,TYPE,WLTN,NUM,REC
49 Q
50 ;
51ARAY1 ;
52 IF TYPE=1 S WLTYPE="PCMM TEAM",NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",6),WLTNI=$$GET1^DIQ(404.51,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(404.51,NUM_",",.01)
53 IF TYPE=2 S WLTYPE="PCMM POSITION",NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",7),WLTNI=$$GET1^DIQ(404.57,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(404.57,NUM_",",.01)
54 IF TYPE=3 S WLTYPE="SERV/SPECIALTY",NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",8),WLTNI=$$GET1^DIQ(409.31,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(409.31,NUM_",",.01)
55 IF TYPE=4 S WLTYPE="CLINIC",NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",9),WLTNI=$$GET1^DIQ(409.32,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(409.32,NUM_",",.01)
56 D SAVE(TYPE,WLTNI,IEN)
57 Q
58 ;
59ARAY2 ;
60 IF TYPE=3 D
61 .S SCODE=+$P($G(^TMP($J,"APPT",1)),U,13),NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",8),WLTNI=$$GET1^DIQ(409.31,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(409.31,NUM_",",.01)
62 .;Q:SCODE'=WLTNI
63 .S WLTYPE="SERV/SPECIAL"
64 .D SAVE(TYPE,WLTNI,IEN)
65 Q
66 ;
67ARAY3 ;
68 IF TYPE=4 D
69 .S CLINIC=+$P($G(^TMP($J,"APPT",1)),U,2),NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",9),WLTNI=$$GET1^DIQ(409.32,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(409.32,NUM_",",.01)
70 .;Q:CLINIC'=WLTNI
71 .S WLTYPE="CLINIC"
72 .D SAVE(TYPE,WLTNI,IEN)
73 Q
74ARAY4 ;identify both clinic and specialties EWL matching by stop code with entered appointment
75 S SCODE=+$P($G(^TMP($J,"APPT",1)),U,13)
76 IF TYPE=3 D Q
77 .S NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",8),WLTNI=$$GET1^DIQ(409.31,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(409.31,NUM_",",.01)
78 .Q:SCODE'=WLTNI
79 .S WLTYPE="SERV/SPECIAL"
80 .D SAVE(TYPE,WLTNI,IEN)
81 IF TYPE=4 D
82 .N SDCLSC
83 .S NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",9),WLTNI=$$GET1^DIQ(409.32,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(409.32,NUM_",",.01)
84 .S SDCLSC=$$GET1^DIQ(44,WLTNI_",",8,"I") ; STOP CODE
85 .Q:SCODE'=SDCLSC
86 .S WLTYPE="CLINIC"
87 .D SAVE(TYPE,WLTNI,IEN)
88 Q
89 ;
90SAVE(TYPE,WLTNI,IEN) ;
91 S REQBY=$P($G(^TMP("SDWLPL",$J,IEN)),"^",12)
92 S INST=$P($G(^TMP("SDWLPL",$J,IEN)),"^",3)
93 N DESIRED S DESIRED=$P($G(^TMP("SDWLPL",$J,IEN)),"^",16)
94 S SCPRI=$E($$GET1^DIQ(409.3,IEN_",",15)) ;SC priority
95 N NAME,SSN S NAME=$$GET1^DIQ(2,DFN_",",.01),SSN=$$GET1^DIQ(2,DFN_",",.09)
96 N SDBY S SDBY=$$GET1^DIQ(409.3,IEN_",",11),SDBY=$E(SDBY,1,3)
97 S NN=$O(^TMP($J,"SDWLPL",""),-1)+1
98 S ^TMP($J,"SDWLPL",NN)=IEN_U_WLTYPE_U_SCPRI_U_WLTN_U_INST_U_DENTER_U_SDBY_U_DESIRED
99 ;
100 N SPIEC S SPIEC=$S(TYPE=4:9,TYPE=3:10,TYPE=2:11,TYPE=1:12)
101 S $P(^TMP($J,"SDWLPL",NN),U,SPIEC)=WLTNI
102 K ^TMP("SDWLPL",$J,IEN)
103 Q
104 ;
105LIST(ANS2,DFN) ;
106 W:$D(IOF) @IOF
107 ;D APPTD^SDWLEVAL ;display appointment(s) again
108 W !,"=========================================================================="
109 N NAME,SSN S NAME=$$GET1^DIQ(2,DFN_",",.01),SSN=$$GET1^DIQ(2,DFN_",",.09)
110 ;W !!,$S(ANS2="A":" All",ANS2="C":" All Clinics",ANS2="M":" Matched Entries:",ANS2="S":" All Specialties",1:" All")
111 W !," Open EWL entries matching appointment specialty"
112 W !,"------------------------------" I ANS2'="A" W "-----------"
113 W !,"EW List Type SC/P Waiting for Institution Orig Date By Des. Date Reopen"
114 W !,"--------------------------------------------------------------------------------"
115 S (REC,NUM)=""
116 F S NUM=$O(^TMP($J,"SDWLPL",NUM)) Q:NUM="" S REC=^TMP($J,"SDWLPL",NUM) D
117 .S IEN=+REC N SDP,SDR D
118 ..S SDP=$E($$GET1^DIQ(409.3,IEN_",",10)) ;priority
119 ..S SDR=$$GET1^DIQ(409.3,IEN_",",29,"I") ;reopen reason
120 .N SDINS,SDIN S SDINS=$P(REC,"^",5) S SDIN=$$GET1^DIQ(4,SDINS_",",.01,"I")
121 .W !,NUM_". ",$E($P(REC,"^",2),1,12),?16,$P(REC,"^",3)_"/"_SDP,?21,$E($P(REC,U,4),1,13),?35,SDIN,?47,$$FMTE^XLFDT($P(REC,"^",6),8),?59,$P(REC,"^",7),?63,$$FMTE^XLFDT($P(REC,"^",8),8),?77,SDR
122 .N SDUP,SDLO
123 .S SDUP="ABCDEFGHIJKLMNOPRSTUWQXYzv",SDLO="abcdefghijklmnoprstuwqxyzv"
124 .N SMT S SMT=$$GET1^DIQ(409.3,IEN_",",25) I SMT'="" S SMT=$TR(SMT,SDUP,SDLO) W !?2,"Comment: ",SMT
125 .N SMO S SMO=$$GET1^DIQ(409.3,IEN_",",30) I SMO'="" S SMO=$TR(SMO,SDUP,SDLO) W !?2,"Reopen: ",SMO
126 Q
Note: See TracBrowser for help on using the repository browser.