source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBSHAUT.m@ 1639

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

initial load of WorldVistAEHR
File size: 9.3 KB
RevLine 
[613]1FBSHAUT ;WCIOFO/SAB-ENTER/EDIT STATE HOME AUTHORIZATION ;2/9/1999
2 ;;3.5;FEE BASIS;**13**;JAN 30, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5ADD ; Enter new authorization
6 ; Called from option FBSH ENTER AUTH
7 D SETUP
8 I 'FBPOP F D Q:'$G(DFN)
9 . ; select patient
10 . D PAT Q:'$G(DFN)
11 . ; show patient demographics
12 . S FBPROG(0)=FBPROG
13 . S FBPROG="I $P(^(0),U,3)=FBPROG(0)"
14 . D ^FBAADEM
15 . S FBPROG=FBPROG(0)
16 . ; get dates
17 . D BDATES
18 . I FBBEGDT]"" D
19 . . ; add/edit authorization
20 . . S DA(1)=DFN,X=FBBEGDT
21 . . S DIC="^FBAAA("_DA(1)_",1,",DIC(0)="LQ",DLAYGO=161
22 . . S DIC("DR")=".02////^S X=FBENDDT;.03////^S X=FBPROG;.095////4;100////^S X=DUZ;S FBTYPE=FBPROG;.07"
23 . . S DIC("P")=$P(^DD(161,1,0),U,2)
24 . . K DD,DO D FILE^DICN K DIC,DLAYGO
25 . . I Y'>0 W $C(7),!,"AUTH. NOT ADDED" Q
26 . . S (DA,FBAAADA)=+Y
27 . . ; edit remaining fields
28 . . S DIE="^FBAAA("_DA(1)_",1,"
29 . . S DR=".04;.021"
30 . . D ^DIE K DIE
31 . . ; queue MRA
32 . . S FBX=$$QMRA(DFN,FBAAADA,"A")
33 . ;
34 . ; unlock patient
35 . L -^FBAAA(DFN,FBPROG)
36 D WRAPUP
37 Q
38 ;
39CHANGE ; Change existing authorization
40 ; Called from option FBSH CHANGE AUTH
41 D SETUP
42 I 'FBPOP F D Q:'$G(DFN)
43 . ; select patient
44 . D PAT Q:'$G(DFN)
45 . ; select existing authorization
46 . S FBPROG(0)=FBPROG
47 . S FBPROG="I $P(^(0),U,3)=FBPROG(0)"
48 . D GETAUTH^FBAAUTL1 S FBPROG=FBPROG(0)
49 . I FTP'="" D
50 . . S (DA,FBAAADA)=FTP,DA(1)=DFN
51 . . I $P($G(FBDMRA),U) W $C(7),!,"AUTH IS AUSTIN DELETED. USE THE REINSTATE OPTION TO CHANGE IT." Q
52 . . ; save current data
53 . . S FBAOLD=$G(^FBAAA(DA(1),1,DA,0)),FBANEW=""
54 . . S FBBEGDT=$P(FBAOLD,U),FBENDDT=$P(FBAOLD,U,2)
55 . . ; display current data
56 . . W !!,"FROM DATE: ",$$FMTE^XLFDT(FBBEGDT)," (No Editing)"
57 . . ; edit TO DATE and check for conflicts
58 . . D TDATE Q:FBENDDT=""
59 . . ; update/edit fields
60 . . S DIE="^FBAAA("_DA(1)_",1,"
61 . . S DR=".02////^S X=FBENDDT;100////^S X=DUZ;S FBTYPE=FBPROG;.07;.04;.021"
62 . . D ^DIE K DIE
63 . . ; if TO DATE or PURPOSE OF VISIT changed then queue MRA
64 . . S FBANEW=$G(^FBAAA(DA(1),1,DA,0))
65 . . I $P(FBANEW,U,2)'=$P(FBAOLD,U,2)!($P(FBANEW,U,7)'=$P(FBAOLD,U,7)) D
66 . . . ; queue MRA
67 . . . S FBX=$$QMRA(DFN,FBAAADA,"C")
68 . ;
69 . ; unlock patient
70 . L -^FBAAA(DFN,FBPROG)
71 D WRAPUP
72 Q
73 ;
74DELETE ; Delete existing authorization
75 ; Called from option FBSH DELETE AUTH
76 D SETUP
77 I 'FBPOP F D Q:'$G(DFN)
78 . ; select patient
79 . D PAT Q:'$G(DFN)
80 . ; select existing authorization
81 . S FBPROG(0)=FBPROG
82 . S FBPROG="I $P(^(0),U,3)=FBPROG(0)"
83 . D GETAUTH^FBAAUTL1 S FBPROG=FBPROG(0)
84 . I FTP'="" D
85 . . N FBY
86 . . S (DA,FBAAADA)=FTP,DA(1)=DFN
87 . . ; confirm
88 . . S FBY=$G(^FBAAA(DFN,1,FTP,0))
89 . . S DIR(0)="Y",DIR("A")="OK to DELETE the "_$$FMTE^XLFDT($P(FBY,U),2)_"-"_$$FMTE^XLFDT($P(FBY,U,2),2)_" authorization"
90 . . D ^DIR K DIR Q:'Y
91 . . ; queue MRA, update ADEL node
92 . . S FBX=$$QMRA(DFN,FBAAADA,"D")
93 . . S $P(^FBAAA(DFN,1,FBAAADA,"ADEL"),U,1,2)="1^"_DT
94 . ;
95 . ; unlock patient
96 . L -^FBAAA(DFN,FBPROG)
97 D WRAPUP
98 Q
99 ;
100REINSTA ; Reinstate deleted authorization
101 ; Called from option FBSH REINSTATE AUTH
102 D SETUP
103 I 'FBPOP F D Q:'$G(DFN)
104 . ; select patient
105 . D PAT Q:'$G(DFN)
106 . ; select existing deleted authorization
107 . S FBPROG(0)=FBPROG
108 . S FBPROG="I $P(^(0),U,3)=FBPROG(0),$P($G(^(""ADEL"")),U)"
109 . D GETAUTH^FBAAUTL1 S FBPROG=FBPROG(0)
110 . I FTP'="" D
111 . . S (DA,FBAAADA)=FTP,DA(1)=DFN
112 . . ; confirm
113 . . ; save current data
114 . . S FBAOLD=$G(^FBAAA(DA(1),1,DA,0)),FBANEW=""
115 . . S FBBEGDT=$P(FBAOLD,U),FBENDDT=$P(FBAOLD,U,2)
116 . . ; display current data
117 . . W !!,"FROM DATE: ",$$FMTE^XLFDT(FBBEGDT)," (No Editing)"
118 . . ; edit TO DATE and check for conflicts
119 . . D TDATE Q:FBENDDT=""
120 . . ; update/edit fields
121 . . S DIE="^FBAAA("_DA(1)_",1,"
122 . . S DR=".02////^S X=FBENDDT;100////^S X=DUZ;S FBTYPE=FBPROG;.07;.04;.021"
123 . . D ^DIE K DIE
124 . . ; queue MRA, clear ADEL node
125 . . S FBX=$$QMRA(DFN,FBAAADA,"R")
126 . . K ^FBAAA(DFN,1,FBAAADA,"ADEL")
127 . ;
128 . ; unlock patient
129 . L -^FBAAA(DFN,FBPROG)
130 D WRAPUP
131 Q
132 ;
133SETUP ; initial setup - returns FBPOP = 1 when problem
134 D SITEP^FBAAUTL Q:FBPOP
135 S FBAADDYS=+$P(FBSITE(0),"^",13),FBAAASKV=$P(FBSITE(1),"^",1)
136 ;
137 S FBPROG=$O(^FBAA(161.8,"B","STATE HOME",0))
138 I 'FBPROG D Q
139 . W $C(7)
140 . W !,"ERROR. STATE HOME not found in FEE BASIS PROGRAM (#161.8) file."
141 . W !,"Unable to process State Home authorization. Please contact IRM."
142 . S FBPOP=1
143 Q
144 ;
145PAT ; select patient
146 ; returns DFN as patient ien (or undef if not selected)
147 K DFN
148 W ! S DIC="^DPT(",DIC(0)="QEAZM" D ^DIC Q:Y'>0 S DFN=+Y
149 I $P($G(^DPT(DFN,.361)),"^")="" W !!,"ELIGIBILITY HAS NOT BEEN DETERMINED NOR PENDING, CANNOT ENTER AN AUTHORIZATION." G PAT
150 I $P($G(^DPT(DFN,.32)),"^",4)=2 W !!?4,"VETERAN HAS A DISHONORABLE DISCHARGE, " S X=$P($G(^(.321)),"^") W $S(X="Y":"ONLY ELIGIBLE FOR AGENT ORANGE EXAM.",1:"NOT ELIGIBLE FOR BENEFITS.")
151 I "N"[$E(X) W ! S DIR("A")="Do you want to continue",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR G PAT:$S($D(DIRUT):1,'Y:1,1:0)
152 ; if patient not in file #161 then add
153 I '$D(^FBAAA(DFN,0)) D I Y'>0 W $C(7),!,"ERROR ADDING TO #161" K DFN Q
154 . S DA=DFN
155 . L +^FBAAA(DA):5 I '$T S Y="" Q
156 . K DD,DO S (X,DINUM)=DA
157 . S DIC="^FBAAA(",DIC(0)="LM",DLAYGO=161
158 . D FILE^DICN K DIC,DINUM
159 . L -^FBAAA(DFN)
160 ; lock patient/program
161 L +^FBAAA(DFN,FBPROG):5 I '$T D G PAT
162 . W $C(7),!,"ANOTHER USER IS EDITING THIS PATIENT & PROGRAM. PLEASE TRY AGAIN LATER."
163 Q
164 ;
165WRAPUP ; clean-up
166 K DFN,FB,FBAAADA,FBAAASKV,FBAADDYS,FBANEW,FBAOLD,FBBEGDT
167 K FBDMRA,FBENDDT,FBOPT,FBPOP,FBPROG,FBSITE,FTP,FBTYPE,FBX
168 K DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,X,Y
169 Q
170 ;
171BDATES ; get both from and to dates of new authorization
172 ; input
173 ; DFN patient ien in file 161
174 ; FBPROG program ien in file
175 ; output
176 ; FBBEGDT From Date, FileMan format, null if dates not selected
177 ; FBENDDT To Date, FileMan format, null if dates not selected
178 ;
179 S %DT("A")="Enter FROM DATE: ",%DT="AEX"
180 D ^%DT K %DT I Y'>0 S (FBBEGDT,FBENDDT)="" Q
181 S FBBEGDT=Y
182 ;
183 S %DT("A")="Enter TO DATE: ",%DT="AEX",%DT(0)=FBBEGDT
184 D ^%DT K %DT I Y'>0 S (FBBEGDT,FBENDDT)="" Q
185 S FBENDDT=Y
186 ; ensure dates do not conflict with existing authorization
187 S FBX=$$CONFLICT(DFN,FBPROG,FBBEGDT,FBENDDT,1)
188 I FBX D RCON(DFN,FBX) G BDATES
189 Q
190 ;
191TDATE ; get to date for existing authorization
192 ; input
193 ; DFN patient ien in file 161
194 ; FBPROG program ien in file
195 ; FBBEGDT From Date, FileMan format
196 ; FBENDDT (optional) current value of To Date
197 ; output
198 ; FBENDDT To Date, FileMan format, null if date not selected
199 ;
200 S %DT("A")="Enter TO DATE: ",%DT="AEX",%DT(0)=FBBEGDT
201 I $G(FBENDDT)]"" S %DT("B")=$$FMTE^XLFDT(FBENDDT)
202 D ^%DT K %DT I Y'>0 S FBENDDT="" Q
203 S FBENDDT=Y
204 ;
205 S FBX=$$CONFLICT(DFN,FBPROG,FBBEGDT,FBENDDT,0)
206 I FBX D RCON(DFN,FBX) G TDATE
207 Q
208 ;
209CONFLICT(DFN,PRG,FDT,TDT,NEWAUT) ; check for conflict with existing auth.
210 ; input
211 ; DFN - patient ien
212 ; PRG - program ien
213 ; FDT - from date in fileman format
214 ; TDT - to date in fileman format
215 ; NEWAUT - optional flag, true if dates for a new authorization
216 ; returns string with value =
217 ; list of authorization iens (delimited by ^) that conflict OR
218 ; null when no conflict found
219 ;
220 ; A conflict exists if
221 ; 1) the from date of a new authorization has already been used as
222 ; the from date for an existing authorization (including deleted)
223 ; for the same FEE program.
224 ; OR
225 ; 2) the date range (FROM-TO) of this authorization overlaps the
226 ; date range of a different, active (does not include deleted)
227 ; authorization for the same FEE program. Note that the from date
228 ; of one authorization can equal the to date of a different
229 ; authorization and would not be in conflict.
230 ;
231 N FBI,FBRET,FBY
232 S FBRET=""
233 ; loop thru authorizations
234 S FBI=0 F S FBI=$O(^FBAAA(DFN,1,FBI)) Q:'FBI D
235 . S FBY=$G(^FBAAA(DFN,1,FBI,0))
236 . Q:$P(FBY,U,3)'=PRG ; not program of interest
237 . Q:$P(FBY,U)=""!($P(FBY,U,2)="") ; date missing - invalid
238 . ; if same from date and not new then must be the selected auth.
239 . ; and wouldn't conflict with self. if new then conflict found.
240 . I $P(FBY,U)=FDT S:NEWAUT FBRET=FBRET_FBI_U Q ; same from date
241 . Q:$P($G(^FBAAA(DFN,1,FBI,"ADEL")),U) ; austin deleted
242 . I FDT<$P(FBY,U,2),TDT>$P(FBY,U) S FBRET=FBRET_FBI_U ; conflict
243 Q FBRET
244 ;
245RCON(DFN,LIST) ; Report Conflicts
246 N CNT,FBA,FBFD,FBI,FBIEN,FBP
247 S CNT=$L(LIST,U)-1
248 W $C(7)
249 W !!,"The specified dates conflict with other authorization(s)."
250 W !,"Please specify different dates for this authorization or"
251 W !,"remove the conflcit by first editing the other authorization(s)."
252 W !!,"Conflict with FROM DATE",?30,"TO DATE",?45,"PURPOSE OF VISIT"
253 F FBP=1:1 S FBI=$P(LIST,U,FBP) Q:FBI="" D
254 . S FBFD=$P($G(^FBAAA(DFN,1,FBI,0)),U)
255 . Q:FBFD=""
256 . S FBA(FBFD)=FBI
257 S FBFD="" F S FBFD=$O(FBA(FBFD)) Q:FBFD="" D
258 . S FBI=FBA(FBFD)
259 . S FBIEN=FBI_","_DFN_","
260 . W !
261 . I $P($G(^FBAAA(DFN,1,FBI,"ADEL")),U)]"" D
262 . . W !,?2,"**Austin Deleted** - Use Reinstate to reuse this From Date"
263 . W ?15,$$GET1^DIQ(161.01,FBIEN,.01)
264 . W ?30,$$GET1^DIQ(161.01,FBIEN,.02)
265 . W ?45,$$GET1^DIQ(161.01,FBIEN,.07)
266 W !
267 Q
268 ;
269QMRA(DFN,AUT,TYP) ; Queue MRA for transmission to Austin
270 ; input
271 ; DFN - patient ien (file 2)
272 ; AUT - authorization ien (file 161.01)
273 ; TYP - type of MRA (A, C, D, or R)
274 ; returns ien of MRA (file 161.26)
275 N DD,DO,DIC,DLAYGO
276 S DIC="^FBAA(161.26,",DIC(0)="L",DLAYGO=161.26,X=DFN
277 S DIC("DR")="1///^S X=""P"";2///^S X=AUT;3///^S X=TYP"
278 K DD,DO D FILE^DICN K DIC,DLAYGO
279 Q +Y
280 ;
281 ;FBSHAUT
Note: See TracBrowser for help on using the repository browser.