source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGQPT1.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 7.7 KB
Line 
1DGQPT1 ; SLC/MKB - Change Patient Selection List ;6/5/01 12:36pm
2 ;;5.3;Registration;**447**;Aug 13, 1993
3 ;
4 ; SLC/PKS - 5/2000: Modified to deal with "Combinations."
5 ;
6CONTEXT() ; -- Returns current patient list context
7 Q $P($G(^TMP("DG",$J,"PATIENTS",0)),U,3)
8 ;
9WARD ; -- new ward list
10 N X,Y,DIC
11 D FULL^VALM1 S VALMBCK="R"
12 S DIC("B")=$P($$LISTSRC^DGQPTQ11(DUZ,"W"),U,2) ;added by CLA 8/4/97
13 S DIC("S")="N D0,X S D0=+Y D WIN^DGPMDDCF I 'X" ; inactive?
14 S DIC=42,DIC(0)="AEQM" D ^DIC Q:Y'>0 S $P(DGY,";",1,2)="W;"_+Y
15 Q
16 ;
17CLINIC ; -- new clinic list
18 N X,Y,Z,DIC,BEG,END,BEG1,END1
19 D FULL^VALM1 S VALMBCK="R"
20 S DIC("B")=$P($$LISTSRC^DGQPTQ11(DUZ,"C"),U,2) ;added by CLA 8/4/97
21 S DIC=44,DIC(0)="AEQM",DIC("A")="Select CLINIC: "
22 S DIC("S")="I $P(^(0),U,3)=""C"",$$ACTLOC^SDWU(+Y)"
23 D ^DIC Q:Y'>0 S (BEG1,END1)=""
24 S Z=$$DATE($P(ORY,";",3),1) Q:Z="^" S BEG=$P(Z,U),BEG1=$P(Z,U,2)
25 I BEG1 S Z=$$DATE($P(DGY,";",4),0) Q:Z="^" S END=$P(Z,U),END1=$P(Z,U,2)
26 I 'BEG1!'END1 Q
27 I BEG1,END1,END1<BEG1 S X=END,END=BEG,BEG=X ; switch
28 S $P(DGY,";",1,4)="C;"_+Y_";"_BEG_";"_END
29 Q
30 ;
31DATE(DEFLT,START) ; -- new start/stop date
32 N X,Y,DIR,%DT
33 S DIR(0)="FAO^1:20",DIR("A")=$S($G(START):"START",1:"STOP")_" DATE: "
34 S:$L($G(DEFLT)) DIR("B")=DEFLT
35 S DIR("?")="Enter the "_$S($G(START):"earliest",1:"latest")_" date for appointments to this clinic for which you wish to see the patients listed; indicate the date relative to TODAY, i.e. T+1 for tomorrow or T-2W for 2 weeks ago."
36D1 D ^DIR S:$D(DTOUT) X="^"
37 I "^"'[X S %DT="X" D ^%DT S:Y>0 X=X_U_Y I Y'>0 W $C(7),!,DIR("?"),! G D1
38 Q X
39 ;
40PROV ; -- new provider list
41 N X,Y,DIC
42 D FULL^VALM1 S VALMBCK="R"
43 S DIC("B")=$P($$LISTSRC^DGQPTQ11(DUZ,"P"),U,2) ;added by CLA 8/4/97
44 S DIC=200,DIC(0)="AEQ",DIC("A")="Select PROVIDER: ",D="AK.PROVIDER"
45 D IX^DIC Q:Y'>0 S $P(DGY,";",1,2)="P;"_+Y
46 Q
47 ;
48TEAM ; -- new team list
49 N X,Y,DIC
50 D FULL^VALM1 S VALMBCK="R"
51 S DIC("B")=$P($$LISTSRC^DGQPTQ11(DUZ,"T"),U,2) ;added by CLA 8/4/97
52 S DIC=100.21,DIC(0)="AEQM",DIC("A")="Select TEAM: "
53 D ^DIC Q:Y'>0 S $P(DGY,";",1,2)="T;"_+Y
54 Q
55 ;
56SPEC ; -- new treating specialty list
57 N X,Y,DIC
58 D FULL^VALM1 S VALMBCK="R"
59 S DIC("B")=$P($$LISTSRC^DGQPTQ11(DUZ,"S"),U,2) ;added by CLA 8/4/97
60 S DIC=45.7,DIC(0)="AEQM",DIC("S")="I $$ACTIVE^DGACT(45.7,Y,DT)"
61 D ^DIC Q:Y'>0 S $P(DGY,";",1,2)="S;"_+Y
62 Q
63 ;
64SORT ; -- new sort order
65 N X,Y,DIR
66 S X=($E(DGY)="C"),Y=$P(DGY,";",5)
67 S DIR(0)="SAM^A:Alphabetic;"_$S(X:"P:Date of Appointment;",1:"R:Room-Bed;")
68 S DIR("A")="(A)lphabetic or "_$S(X:"Date of A(p)pointment? ",1:"(R)oom-Bed? ")
69 S DIR("B")=$S(Y="R"&'X:"Room-Bed",Y="P"&X:"Date of Appointment",1:"Alphabetic")
70 ; Next 4 lines added by PKS to deal with "Combinations:"
71 I $E(ORY)="M" D
72 . S DIR(0)="SAM^A:Alphabetic;P:Appointment;S:Source"
73 . S DIR("A")="(A)lphabetic or Date of A(p)pointment or (S)ource "
74 . S DIR("B")="Alphabetic"
75 S DIR("?")="Enter the attribute you wish the list to sort by"
76 D ^DIR S:$D(DTOUT) Y="^" Q:Y="^"
77 S $P(DGY,";",5)=Y
78 Q
79 ;
80SAVE ; -- Save current list definition as default
81 N X,LIST,IFN,BEG,END,PARAM S VALMBCK=""
82 Q:'$$OK W !!,"Saving patient list definition ... "
83 S LIST=$$CONTEXT,X=$E(LIST)
84 ; Next line modified by PKS:
85 S PARAM="DGLP DEFAULT "_$S(X="T":"TEAM",X="P":"PROVIDER",X="S":"SPECIALTY",X="W":"WARD",X="C":"CLINIC ",X="M":"MULTIPLE",1:"^") I PARAM["^" W !,"ERROR" H 2 Q
86 ;added by CLA 12/12/96:
87 N DGSRV S DGSRV=$G(^VA(200,DUZ,5)) I +DGSRV>0 S DGSRV=$P(DGSRV,U)
88 ;
89 D EN^XPAR("USR","DGLP DEFAULT LIST SOURCE",1,X)
90 S IFN="`"_+$P(LIST,";",2)
91 I X'="C" D EN^XPAR("USR",PARAM,1,IFN)
92 I X="C" D ; add clinic for each day of week & start & stop dates
93 . N CPARAM
94 . S CPARAM=PARAM_"MONDAY" D EN^XPAR("USR",CPARAM,1,IFN)
95 . S CPARAM=PARAM_"TUESDAY" D EN^XPAR("USR",CPARAM,1,IFN)
96 . S CPARAM=PARAM_"WEDNESDAY" D EN^XPAR("USR",CPARAM,1,IFN)
97 . S CPARAM=PARAM_"THURSDAY" D EN^XPAR("USR",CPARAM,1,IFN)
98 . S CPARAM=PARAM_"FRIDAY" D EN^XPAR("USR",CPARAM,1,IFN)
99 . S CPARAM=PARAM_"SATURDAY" D EN^XPAR("USR",CPARAM,1,IFN)
100 . S CPARAM=PARAM_"SUNDAY" D EN^XPAR("USR",CPARAM,1,IFN)
101 . S BEG=$P(LIST,";",3),END=$P(LIST,";",4)
102 . D EN^XPAR("USR","DGLP DEFAULT CLINIC START DATE",1,BEG)
103 . D EN^XPAR("USR","DGLP DEFAULT CLINIC STOP DATE",1,END)
104 I $L($P(LIST,";",5)) D EN^XPAR("USR","DGLP DEFAULT LIST ORDER",1,$P(LIST,";",5))
105 W "done." H 1 S VALMBCK=""
106 Q
107 ;
108OK() ; -- Current definition ok?
109 N X,Y,DIR,LIST,PTR,SORT,BEG,END W !!,"Current List: "
110 S LIST=$$CONTEXT,PTR=+$P(LIST,";",2),BEG=$P(LIST,";",3),END=$P(LIST,";",4),SORT=$P(LIST,";",5)
111 I $E(LIST)="W" W "Ward "_$P($G(^DIC(42,+PTR,0)),U)
112 I $E(LIST)="C" W "Clinic "_$P($G(^SC(+PTR,0)),U)
113 I $E(LIST)="P" W "Primary Provider "_$P($G(^VA(200,+PTR,0)),U)
114 I $E(LIST)="T" W "Team "_$P($G(^OR(100.21,+PTR,0)),U)
115 I $E(LIST)="S" W "Specialty "_$P($G(^DIC(45.7,+PTR,0)),U)
116 ; Next line added by PKS:
117 I $E(LIST)="M" W "Combination"
118 I $L(SORT) W ", sorted by "_$S(SORT="P":"Appointment Date",SORT="R":"Room-Bed",1:"Name")
119 I $E(LIST)="C",BEG W !?14,"from "_BEG_" to "_END
120 S DIR(0)="YA",DIR("A")="Are you sure you want to save these list parameters as your default? "
121 S DIR("?")="Enter YES if you wish to use these same parameters again the next time a patient list is created for you to select from, or NO to quit without saving."
122 W ! D ^DIR
123 Q +Y
124 ;
125REMOVE ; Remove current default patient list view parameter setting(s).
126 ; SLC/PKS - 5/2000.
127 ;
128 ; Variables used:
129 ;
130 ; DGDUZ = User's DUZ.
131 ; DGQENT = Entity string for call to XPAR.
132 ; DGQERR = Error array for call to XPAR.
133 ; DGQSRC = Holds return value of call to FDEFSRC^ORQPTQ11(ORDUZ).
134 ;
135 N DGQDUZ,DGQENT,DGQERR,DGQSRC
136 ;
137 K DGQERR
138 S VALMBCK=""
139 S DGQDUZ=DUZ
140 Q:'$$OKR
141 W !!,"Removing your personal patient list definition ... "
142 S DGQENT=DUZ_";VA(200,"
143 D DEL^XPAR(DGQENT,"DGLP DEFAULT LIST SOURCE",,.ORQERR)
144 I ('$D(DGQERR)!(DGQERR=0)) D
145 .W "done."
146 .S DGQSRC=$$FDEFSRC^DGQPTQ11(DGQDUZ) ; Check for Service default.
147 .I $P(DGQSRC,U)'="" W !,"(NOTE: Service/Section default of """_$P(DGQSRC,U,3)_""" not affected.)"
148 .H 4
149 I $D(DGQERR) D
150 .S DGQSRC=$$FDEFSRC^DGQPTQ11(DGQDUZ) ; Check for Service default.
151 .I DGQERR=0 Q
152 .I $P(DGQERR,U,2)="Parameter instance not found" D Q
153 ..W "nothing to remove."
154 ..I $P(DGQSRC,U)'="" W !,"(NOTE: Service/Section default of """_$P(DGQSRC,U,3)_""" not affected.)"
155 ..H 4
156 .W !," ERROR: "_$P(DGQERR,U,2) H 3
157 S VALMBCK=""
158 Q
159 ;
160OKR() ; -- Remove current definition?
161 N X,Y,DIR,LIST,PTR
162 S DIR(0)="YA"
163 S DIR("A")="Are you sure you want to remove your current list default view? "
164 S DIR("?")="Enter YES if you wish to remove your current default patient list view, or NO to leave the current personal setting(s)."
165 W ! ; For display esthetics.
166 D ^DIR
167 Q +Y
168 ;
169COMBO ; New combination list.
170 ; SLC/PKS - 5/2000.
171 ;
172 ; Preset VALM for return:
173 D FULL^VALM1 S VALMBCK="R"
174 ;
175 ; Call existing code to create/edit user's "combination" sources:
176 D COMB^DGLP3USR
177 ;
178 ; Write the piece in "ORY" to indicate "Combination" sources:
179 S $P(DGY,";",1)="M"
180 D REBUILD
181 ;
182 Q
183 ;
184REBUILD ; -- Ok to rebuild listing?
185 N DGQUIT
186 I $E(DGY)="C",$P(DGY,";",5)="R" D Q:$G(DGQUIT)
187 . W !!,">> A Clinic list cannot be sorted by room-bed assignment!"
188 . W !," Please select a new sorting order:",!
189 . D SORT S:$P(DGY,";",5)="R" DGQUIT=1
190 ; Next section added by PKS for "Combinations:"
191 I $E(DGY)="M",$P(DGY,";",5)="R" D Q:$G(DGQUIT)
192 . W !!,">> A Combination list cannot be sorted by room-bed assignment!"
193 . W !," Please select a new sorting order:",!
194 . D SORT S:$P(DGY,";",5)="R" DGQUIT=1
195 I (($E(DGY)'="C")&($E(DGY)'="M")),$P(DGY,";",5)="P" D Q:$G(DGQUIT)
196 . W !!,">> A "_$S($E(DGY)="W":"Ward",$E(DGY)="P":"Primary Provider",$E(DGY)="T":"Team",$E(DGY)="S":"Specialty",1:"")_" list cannot be sorted by clinic appointment date!"
197 . W !," Please select a new sorting order:",!
198 . D SORT S:$P(DGY,";",5)="P" DGQUIT=1
199 D BUILD^DGQPT(DGY)
200 Q
Note: See TracBrowser for help on using the repository browser.