source: FOIAVistA/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/ECPRVUTL.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: 7.3 KB
Line 
1ECPRVUTL ;ALB/JAP - Provider Selection with Person Class ;7 Aug 97
2 ;;2.0; EVENT CAPTURE ;**5**;8 May 96
3 ;
4PROV(ECDT,ECPROVS) ;get providers - new providers function
5 ;
6 ;this function is duplicated in PROV^ECMUTL
7 ;
8 ;select provider(s) with active person class
9 ;no updating of file #721 record is done here
10 ;
11 ; input
12 ; ECDT = date/time of procedure (required)
13 ; ECPROVS = local array, passed by reference (required)
14 ;
15 ; output
16 ; ECU(1) = provider #1 (mandatory) ien^provider #1 name^person class
17 ; ECU(2) = provider #2 (optional) ien^provider #2 name^person class
18 ; ECU(3) = provider #3 (optional) ien^provider #3 name^person class
19 ;
20 ; returns
21 ; 0 ==> provider selection successful; at least
22 ; provider #1 selected.
23 ; 1 ==> selection unsuccessful or user timed-out
24 ; 2 ==> selection unsuccessful or user entered "^"
25 ;
26 N ECU,ECU2,ECU3,ECDA
27 D GET("",ECDT,.ECU,.ECU2,.ECU3,.ECOUT)
28 S ECPROVS(1)=ECU,ECPROVS(2)=ECU2,ECPROVS(3)=ECU3
29 Q ECOUT
30 ;
31GET(ECDA,ECDT,ECU,ECU2,ECU3,ECOUT) ;get providers with person class
32 ;
33 ;select provider(s) with active person class
34 ;no updating of file #721 record is done here
35 ;
36 ; input
37 ; ECDA = ien of pertinent record in file #721 (required)
38 ; but may be null
39 ; ECDT = date/time of procedure (required)
40 ; internal FM format;
41 ; if null defaults to DT
42 ; (ECU,ECU2,ECU3) = any (required; pass by reference);
43 ; will be reset
44 ; ECOUT = (required; pass by reference)
45 ;
46 ; output
47 ; ECU = provider #1 ien in file #200^provider name^person class OR
48 ; provider #1 ien in file #200^provider name^null OR
49 ; null^null^null (if provider not determined)
50 ; (provider #1 cannot be deleted; required field)
51 ; ECU2 = provider #2 ien in file #200^provider name^person class OR
52 ; provider #1 ien in file #200^provider name^null OR
53 ; null^null^null (if provider not determined) OR
54 ; @^null^null (if provider deleted)
55 ; ECU3 = (same format as provider #2)
56 ; ECOUT = 0 if selection successful OR
57 ; 1 if user times out; selection unsuccessful
58 ; 2 if user up-arrows out; selection unsuccessful
59 ;
60 ; Note: If user up-arrows out or times out, then
61 ; ECU,ECU2,ECU3 set back to value at entry.
62 ;
63 N ECUTN,DA,DIR,DIRUT,DTOUT,DUOUT,X,Y,ECDATA,ECUN,ECUN2,ECUN3,ECUC,ECUC2,ECUC3,OLDP
64 S ECOUT=0,(ECU,ECU2,ECU3)="",(ECUN,ECUN2,ECUN3)="",(ECUC,ECUC2,ECUC3)="",ECDATA="" F JJ=1:1:3 S OLDP(JJ)="^^"
65 ;if using an existing record in file #721, pick-up some basic data
66 I +ECDA>0 D
67 .S DA=ECDA,ECDATA=$G(^ECH(ECDA,0)),ECDT=$P(ECDATA,"^",3)
68 .S ECU=$P(ECDATA,"^",11),ECU2=$P(ECDATA,"^",15),ECU3=$P(ECDATA,"^",17)
69 .S $P(OLDP(1),"^")=ECU,$P(OLDP(2),"^")=ECU2,$P(OLDP(3),"^")=ECU3
70 I ECDT="" S ECDT=DT
71 ;allow user to select new or update existing provider(s)
72 D PV
73 I +ECOUT D Q
74 .S ECU=OLDP(1)
75 .S ECU2=OLDP(2)
76 .S ECU3=OLDP(3)
77 I '+ECOUT D
78 .S ECU=ECU_"^"_ECUN_"^"_ECUC
79 .S ECU2=ECU2_"^"_ECUN2_"^"_ECUC2
80 .S ECU3=ECU3_"^"_ECUN3_"^"_ECUC3
81 ;make sure no duplicates exist
82 I +ECU D
83 .I +ECU=+ECU2 S ECU2="@^^"
84 .I +ECU=+ECU3 S ECU3="@^^"
85 I +ECU2 D
86 .I +ECU2=+ECU3 S ECU3="@^^"
87 ;if an existing 2nd provider is deleted, fill-in using 3rd provider
88 I $E(ECU2,1)="@",+ECU3 S ECU2=ECU3,ECU3="@^^"
89 ;make sure info is complete for each provider
90 I +ECU>0 D COMP(.ECU,ECDT)
91 I +ECU2>0 D COMP(.ECU2,ECDT)
92 I +ECU3>0 D COMP(.ECU3,ECDT)
93 Q
94 ;
95 ;if ecu,ecu2,ecu3 are already defined (i.e., not null), then y(0),y(0,0) won't be
96 ;returned from DIR call;
97PV ;1st provider - required
98 ;if 1st provider exists, it can't be deleted; but may be over-written
99 K Y,DIR S DIR(0)="721,10",DIR("A")="Provider" D ^DIR K DIR I Y D
100 .S ECUN=$G(Y(0,0)) I ECUN="" S ECUN=$$DICLK(ECU)
101 .S ECUC=$$CLASS(+Y,ECDT)
102 S:$D(DTOUT) ECOUT=1 S:$D(DUOUT) ECOUT=2
103 Q:$G(ECOUT)
104 I +$G(ECUC)<0 S ECUC="" G PV
105 S ECU=+Y
106 ;
107PV2 ;2nd provider - optional
108 ;if 2nd provider exists, it may be deleted or over-written
109 K Y,DIR S DIR(0)="721,15",DIR("A")="Provider #2" D ^DIR K DIR I Y D
110 .Q:+Y=+ECU
111 .S ECUN2=$G(Y(0,0)) I ECUN2="" S ECUN2=$$DICLK(ECU2)
112 .S ECUC2=$$CLASS(+Y,ECDT)
113 S:$D(DTOUT) ECOUT=1 S:$D(DUOUT) ECOUT=2
114 Q:$G(ECOUT)
115 I 'Y,X="@",+ECU2 S ECU2="@",ECUN2="" W !,?5,"Provider #2 will be deleted..." I +ECU3 G PV3
116 Q:ECU2="@"
117 I +Y=+ECU W $C(7),!!,?15,"But that's Provider #1... Try again.",! G PV2
118 I +$G(ECUC2)<0 S ECUC2="" G PV2
119 S ECU2=$S(+Y>0:+Y,1:"")
120 Q:ECU2=""
121 ;
122PV3 ;3rd provider - optional
123 ;if 3rd provider exists, it may be deleted or over-written
124 K Y,DIR S DIR(0)="721,17",DIR("A")="Provider #3" D ^DIR K DIR I Y D
125 .Q:+Y=+ECU Q:+Y=+ECU2
126 .S ECUN3=$G(Y(0,0)) I ECUN3="" S ECUN3=$$DICLK(ECU3)
127 .S ECUC3=$$CLASS(+Y,ECDT)
128 S:$D(DTOUT) ECOUT=1 S:$D(DUOUT) ECOUT=2
129 Q:$G(ECOUT)
130 I 'Y,X="@",+ECU3 S ECU3="@",ECUN3="" W !,?5,"Provider #3 will be deleted..."
131 Q:ECU3="@"
132 I +Y=+ECU W $C(7),!!,?15,"But that's Provider #1... Try again.",! G PV3
133 I +Y=+ECU2 W $C(7),!!,?15,"But that's Provider #2... Try again.",! G PV3
134 I +$G(ECUC3)<0 S ECUC3="" G PV3
135 S ECU3=$S(+Y>0:+Y,1:"")
136 Q
137 ;
138CLASS(ECUX,ECDTX) ;get person class - display
139 ; input
140 ; ECUX=ien in file #200 (required)
141 ; ECDTX=date/time of procedure (required)
142 ; output
143 ; ECUTN= -1 if no person class
144 ; or
145 ; -2 if no active person class
146 ; or
147 ; ien in file #8932.1^occupation^specialty^subspecialty^effective date^expiration date^va code
148 N ECUTN,ECDATE,Y
149 S Y=ECDTX D DD^%DT S ECDATE=Y
150 S ECUTN=$$GET^XUA4A72(ECUX,ECDTX)
151 I +ECUTN>0 D
152 .W !?5,"Occupation: ",$P(ECUTN,"^",2)
153 .I $P(ECUTN,"^",3)]"" W !?5,"Specialty: ",$P(ECUTN,"^",3)
154 .I $P(ECUTN,"^",4)]"" W !?5,"Subspecialty: ",$P(ECUTN,"^",4)
155 .W !
156 E D CMSG
157 Q ECUTN
158 ;
159CMSG ;inactive person class msgs
160 I +ECUTN=-1 D
161 .W !!?10,"Only Providers with an active Person Class may"
162 .W !?10,"be selected."
163 I +ECUTN=-2 D
164 .W !!?10,"This Provider does not have an active Person Class"
165 .W !?10,"for the date of "_$P(ECDATE,"@",1)_"."
166 W !!?10,"Please check your provider selection and try again.",!
167 Q
168 ;
169DICLK(ECUX) ;use DIC lookup if editing existing provider in file #721
170 ; input
171 ; ECUX=ien in file #200 (required)
172 ; output
173 ; Y(0,0); i.e., name
174 N DIC,X
175 S X=ECUX,DIC="^VA(200,",DIC(0)="NZ"
176 D ^DIC
177 Q $G(Y(0,0))
178 ;
179COMP(ECUX,ECDTX) ;check & complete the provider return variables
180 ;or get user/provider name and person class info
181 ; input
182 ; ECUX=ien in file #200^name^person class ien^occupation^specialty^subspecialty^etc.
183 ; (required)
184 ; but pieces 3,4,5 may be null;
185 ; passed by reference
186 ; ECDTX=pertinent date; internal FM format (required)
187 ; but may be null
188 ; output
189 ; ECUX=ien in file #200^name^compress person class info
190 N ECSPEC,E1,E2,E3,ECUTN,X,Y
191 ;get provider name, if not there;
192 I '$G(ECDTX) S ECDTX=""
193 I $P(ECUX,"^",2)="" D
194 .S $P(ECUX,"^",2)=$$DICLK(+ECUX)
195 .S ECUTN=$$GET^XUA4A72(+ECUX,ECDTX) I +ECUTN<0 S ECUTN=""
196 .S $P(ECUX,"^",3)=ECUTN
197 ;compress the person class information into 1 piece
198 ;if specialty and subspecialty are defined, use that;
199 ;otherwise use occupation plus specialty (if defined)
200 I +$P(ECUX,"^",3)=0 S ECUX=$P(ECUX,"^",1,2)_"^"_"(Person Class undefined.)" Q
201 S E1=$P(ECUX,"^",4),E2=$P(ECUX,"^",5),E3=$P(ECUX,"^",6)
202 I $L(E3)>0 D
203 .S ECSPEC=$E(E2,1,18)_"/"_$E(E3,1,40)
204 .S ECUX=$P(ECUX,"^",1,2)_"^"_ECSPEC
205 E D
206 .I $L(E2)>0 S ECSPEC=$E(E1,1,18)_"/"_$E(E2,1,40)
207 .I $L(E2)=0 S ECSPEC=E1
208 .S ECUX=$P(ECUX,"^",1,2)_"^"_ECSPEC
209 Q
Note: See TracBrowser for help on using the repository browser.