source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBAECU4.m@ 1259

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

initial load of WorldVistAEHR

File size: 8.1 KB
Line 
1IBAECU4 ;WOIFO/SS-LTC PHASE 2 UTILITIES ; 20-FEB-02
2 ;;2.0;INTEGRATED BILLING;**171,176**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;** LTC Clock related utilities **
5 ;Makes FM date from any date of month or YEAR_MONTH and Day #
6MKDATE(IBYM,IBD) ;
7 Q $E(IBYM,1,5)_$S(IBD<10:"0"_IBD,1:IBD)
8 ;substracts (CHNG<0) or adds (CHNG>0) days to date
9 ;DATE - date in FM format
10CHNGDATE(DATE,CHNG) ;
11 N X,X1,X2
12 S X1=DATE,X2=CHNG D C^%DTC
13 Q X
14 ;adjusts clocks
15 ; "C" - cancel it
16 ; "P" - 1) mark patient as "processed" i.e. we should
17 ; set CURRENT EVENTS DATE=""
18 ; or to 1st day of the next month if the patient is not disharged yet
19 ; 2)adjust 180 days clocks
20 ;.IBCLKADJ - array with info regarding clock adjustment
21 ;IBCLKIEN - ien of file 351.81
22 ;IBDFN - dfn of the patient
23 ;IBINPLD - returned value of $$ISINPAT^IBAECU2 for the last date of the month
24 ; if "^" - no admission for the last day of the
25 ; processed month, set CURRENT EVENTS DATE=""
26 ; if "number^" then we have inpatient LTC on the last day,
27 ; set CURRENT EVENTS DATE=1st day of the following month
28 ;IBEND the last date of the month
29CLCKADJ(IBCLKADJ,IBCLIEN,IBDFN,IBINPLD,IBEND) ;
30 N IBNEWDT
31 ;check if it is the 1st MJ then do not cancel clock and do not clear CURRENT EVENTS field
32 I $G(IBMJ1ST)="MJ1ST" Q:IBCLKADJ="C" Q:+IBINPLD=0
33 S IBNEWDT=""
34 ;"C": cancel clock
35 I IBCLKADJ="C" D Q
36 . L +^IBA(351.81,0):10 I '$T D Q ;quit
37 . . D ERRLOG^IBAECU5(+$G(IBDFN),+$G(IBCLIEN),"Clocks","Lock error: not cancelled")
38 . D CANCCLCK(IBCLIEN,IBDFN) ;cancel clock
39 . D CLKSTAMP(IBCLIEN,IBDFN)
40 . L -^IBA(351.81,0)
41 ;"P": mark that the patient has been processed succesfully
42 I IBCLKADJ="P" D Q
43 . L +^IBA(351.81,0):10 I '$T D Q ;quit
44 . . D ERRLOG^IBAECU5(+$G(IBDFN),+$G(IBCLIEN),"Clocks","Lock error: no current event change")
45 . I +IBINPLD>0 S IBNEWDT=$$CHNGDATE(IBEND,+1)
46 . D CHNGEVEN(IBCLIEN,IBDFN,IBNEWDT)
47 . D CLKSTAMP(IBCLIEN,IBDFN)
48 . L -^IBA(351.81,0)
49 ;
50 Q
51 ;if there are free days then:
52 ; returns 1
53 ;otherwise:
54 ; returns 0
55EXEMPT21(IBCLIEN) ;
56 Q $P($G(^IBA(351.81,IBCLIEN,0)),"^",6)>0
57 ;returns a new expiration date
58 ;which is = the same day next year - 1 day
59 ;example : for 3000401 it is 3010331
60GETEXPDT(IBDATE) ;
61 N IBY,IBMD
62 S IBMD=$E(IBDATE,4,7)
63 S IBY=$E(IBDATE,1,3)
64 I IBMD="0229" S IBMD="0228"
65 S IBY=IBY+1
66 Q $$CHNGDATE(+(IBY_IBMD),-1)
67 ;sets #350.81 fields 4.03 USER LAST UPDATING and 4.04 DATE LAST UPDATED
68 ;Note: use outside LOCK
69CLKSTAMP(IBIENCL,IBDFN1) ;
70 N IBIENS,IBFDA,IBD,IBERR
71 S IBIENS=IBIENCL_","
72 S IBFDA(351.81,IBIENS,4.03)=+$G(DUZ)
73 D NOW^%DTC S IBD=%
74 S IBFDA(351.81,IBIENS,4.04)=IBD
75 D FILE^DIE("","IBFDA","IBERR")
76 I $D(IBERR) D
77 . D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIENCL),"Clocks","stamp error:"_$G(IBERR("DIERR",1,"TEXT",1)))
78 Q
79 ;resets fields .03 (CLOCK BEGIN DATE) and .04 (CLOCK EXPIRATION DATE) of LTC clock file
80 ;INPUT:
81 ;IBIENCL - ien of #351.81
82 ;IBDATE - date in FM format
83 ;Note: use outside LOCK
84RESET21(IBIENCL,IBDATE,IBDFN1) ;
85 N IBIENS,IBFDA,IBERR
86 S IBIENS=IBIENCL_"," ; "D0,"
87 S IBFDA(351.81,IBIENS,.03)=IBDATE ;begin date (file#,IENS,field#)
88 S IBFDA(351.81,IBIENS,.04)=$$GETEXPDT(IBDATE) ;expiration date (file#,IENS,field#)
89 D FILE^DIE("","IBFDA","IBERR")
90 I $D(IBERR) D
91 . D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIENCL),"Clocks",$G(IBERR("DIERR",1,"TEXT",1)))
92 Q
93 ;Adds a new exempt day to multiple in #351.81
94 ;Set EXEMPT DAYS REMAINING to appropriate value
95 ;INPUT:
96 ;IBCLIEN - ien in file #351.81
97 ;DATE - new exempt date
98 ;Note: use outside LOCK
99ADDEXDAY(IBIENCL,IBDATE,IBDFN1) ;
100 N IBIENS,IBFDA,IBDAY,IBERR,IBSSI
101 S IBDAY=+$P($G(^IBA(351.81,IBIENCL,1,0)),"^",4)
102 Q:IBDAY=21
103 S IBDAY=IBDAY+1
104 ;-add day
105 S IBIENS="+1,"_IBIENCL_"," ; "+1,D0,"
106 S IBFDA(351.811,IBIENS,.01)=IBDAY ;(file#,IENS,field#)
107 S IBFDA(351.811,IBIENS,.02)=IBDATE ;(file#,IENS,field#)
108 D UPDATE^DIE("","IBFDA","IBSSI","IBERR")
109 I $D(IBERR) D
110 . D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIENCL),"Clocks",$G(IBERR("DIERR",1,"TEXT",1)))
111 ;-decrease DAYS REMAINING
112 S IBIENS=IBIENCL_"," ; "D0,"
113 S IBFDA(351.81,IBIENS,.06)=21-IBDAY ;Expiration date (file#,IENS,field#)
114 D FILE^DIE("","IBFDA","IBERR")
115 I $D(IBERR) D
116 . D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIENCL),"Clocks",$G(IBERR("DIERR",1,"TEXT",1)))
117 Q
118 ;check for 21 days errors
119 ;run once before start to process all days of the month for the patient
120 ;check correct number of days
121 ;IBIEN- ien of #351.81
122 ;if no days returns 0
123 ;if an error then files into ERRLOG and returns -1 or -2
124 ;if OK returns number of exempted days
125CHKDSERR(IBIENCL,IBDFN1) ;
126 N IBDAT,IBDS
127 S IBDAT=$G(^IBA(351.81,IBIENCL,1,0))
128 Q:IBDAT="" 0
129 S IBDS=$P($G(^IBA(351.81,IBIENCL,0)),"^",6)
130 I +$P(IBDAT,"^",3)'=+$P(IBDAT,"^",4) D Q -1
131 . D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIENCL),"Clocks","total number of entries and last EXEMPT DAY NUMBER are not equal in #351.811")
132 I IBDS'=(21-$P(IBDAT,"^",3)) D Q -2
133 . D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIENCL),"Clocks","DAYS REMAINING'=21-last EXEMPT DAY NUMBER")
134 I IBDS'=(21-$P(IBDAT,"^",4)) D Q -3
135 . D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIENCL),"Clocks","DAYS REMAINING'=21-total number of #351.811 entries")
136 Q +$P(IBDAT,"^",4)
137 ;closes entry in file #351.81
138 ; set STATUS = CLOSED
139 ;Note: use outside LOCK
140CLOSECLK(IBIENCL,IBDFN1) ;
141 D CHNGSTAT(IBIENCL,IBDFN1,2)
142 Q
143 ;Cancels clock entry
144 ; set STATUS = CANCEL
145 ;Note: use outside LOCK
146CANCCLCK(IBIENCL,IBDFN1) ;
147 D CHNGSTAT(IBIENCL,IBDFN1,3)
148 Q
149 ;resets CURRENT EVENTS DATE field
150 ;INPUT:
151 ;IBIENCL - ien of #351.81
152 ;IBDFN1 - dfn of the patient
153 ;IBDATE - new date or ""
154 ;Note: use outside LOCK
155CHNGEVEN(IBIENCL,IBDFN1,IBDATE) ;
156 N IBIENS,IBFDA,IBERR
157 S IBIENS=IBIENCL_"," ; "D0,"
158 S IBFDA(351.81,IBIENS,.07)=IBDATE ;status (file#,IENS,field#)
159 D FILE^DIE("","IBFDA","IBERR")
160 I $D(IBERR) D
161 . D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIENCL),"Clocks","change current event="_$G(IBDATE)_" "_$G(IBERR("DIERR",1,"TEXT",1)))
162 Q
163 ;resets STATUS field
164 ;INPUT:
165 ;IBIENCL - ien of #351.81
166 ;Note: use outside LOCK
167CHNGSTAT(IBIENCL,IBDFN1,IBNEWST) ;
168 N IBIENS,IBFDA,IBERR
169 S IBIENS=IBIENCL_"," ; "D0,"
170 S IBFDA(351.81,IBIENS,.05)=IBNEWST ;status (file#,IENS,field#)
171 D FILE^DIE("","IBFDA","IBERR")
172 I $D(IBERR) D
173 . D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIENCL),"Clocks","change status="_$G(IBNEWST)_" "_$G(IBERR("DIERR",1,"TEXT",1)))
174 Q
175 ;creates a new entry in file #351.81
176 ;sets adds (#.01),(#.02),(#.03),(#.05),(#4.01),(#4.02)
177 ;DOES NOT set EXPIRATION date (use RESET21)
178 ;returns new ien in file #351.81
179NEWCLK(IBDFN,IBDT) ;
180 N IBIEN
181 I '$D(DUZ) N DUZ S DUZ=0
182 S:'$D(U) U="^"
183 S IBIEN=$$ADDCL^IBAECU(IBDFN,IBDT)
184 Q:IBIEN<0 0 ;if was not created
185 Q IBIEN
186 ;run once to fix everything before start to process all days of the month for the patient
187 ;fix 21 days clock if CHKDSERR returns IBERCOD<0
188 ;IBIEN- ien of #351.81
189 ;Note: use outside LOCK
190FIX21CLK(IBIEN) ;
191 N IBV1,IBV2,IBARR,IBDFN1,IBDEL,IBIENS,IBERR,IBFDA,IBDATA,IBBEG,IBEXP
192 S (IBV1,IBARR,IBDEL)=0
193 S IBDATA=$G(^IBA(351.81,IBIEN,0))
194 S IBDFN1=+$P(IBDATA,"^",2)
195 S IBBEG=+$P(IBDATA,"^",3)
196 S IBEXP=+$P(IBDATA,"^",4)
197 I +IBEXP=0 D
198 . S IBIENS=IBIEN_"," ; "D0,"
199 . S IBFDA(351.81,IBIENS,.04)=$$GETEXPDT(IBBEG) ;expiration date
200 . D FILE^DIE("","IBFDA","IBERR")
201 . I $D(IBERR) D
202 . . D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIEN),"Clocks",$G(IBERR("DIERR",1,"TEXT",1)))
203 . S IBEXP=+$P($G(^IBA(351.81,IBIEN,0)),"^",4)
204 ;
205 Q:+IBDFN1=0
206 F S IBV1=$O(^IBA(351.81,IBIEN,1,IBV1)) Q:+IBV1=0 D
207 . S IBV2=+$P($G(^IBA(351.81,IBIEN,1,IBV1,0)),"^",2)
208 . I IBV2<IBBEG!(IBV2>IBEXP) D
209 . . D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIEN),"Clocks","Exempt day is out of clock range")
210 . S IBARR(+$P($G(^IBA(351.81,IBIEN,1,IBV1,0)),"^",2))=""
211 . S IBDEL(IBV1)=""
212 ;- DAYS REMAINING
213 S IBIENS=IBIEN_"," ; "D0,"
214 S IBFDA(351.81,IBIENS,.06)=21 ; (file#,IENS,field#)
215 D FILE^DIE("","IBFDA","IBERR")
216 I $D(IBERR) D
217 . D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIEN),"Clocks",$G(IBERR("DIERR",1,"TEXT",1)))
218 S IBV1=0
219 F S IBV1=$O(IBDEL(IBV1)) Q:+IBV1=0 D
220 . D DELEXDAY(IBIEN,IBV1)
221 S IBV1=0
222 F S IBV1=$O(IBARR(IBV1)) Q:+IBV1=0 D
223 . D ADDEXDAY(IBIEN,IBV1,IBDFN1)
224 Q
225 ;Delete exempt day from multiple
226 ;INPUT:
227 ;IBIEN - ien in file #351.81
228 ;IBN - ien of exempt date entry
229 ;Note: use outside LOCK
230DELEXDAY(IBIEN,IBN) ;
231 N IBIENS,IBFDA
232 S IBIENS=IBN_","_IBIEN_","
233 S IBFDA(351.811,IBIENS,.01)="@"
234 D FILE^DIE("","IBFDA")
235 Q
Note: See TracBrowser for help on using the repository browser.