source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF3.m@ 1742

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

initial load of FOIAVistA 6/30/08 version
File size: 8.9 KB
Line 
1IBCEF3 ;ALB/TMP - FORMATTER SPECIFIC BILL FLD FUNCTIONS ;17-JUNE-96
2 ;;2.0;INTEGRATED BILLING;**52,84,121,51,152,210,155,348,349,389**;21-MAR-94;Build 6
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5MPG(PG,FLDS,FORM) ; Set static flds on pages after page 1
6 ; for either 1500 or UB
7 ; PG = page #
8 ; FORM= 1 for UB, otherwise for 1500
9 ; FLDS: array passed by reference and containing lines OR
10 ; line/column from pg 1 to repeat on subsequent pages
11 ; Format: FLDS(LINE,COL) or FLDS(LINE) for whole line
12 ; CMS-1500: LINES 1-5,7-43,57 from col 1 to 50, 58-63
13 ; UB: see CKPGUB for lines and columns
14 ;
15 N Z,Z0,Z1,LPG
16 S FORM=$S($G(FORM)=1:3,1:2)
17 I FORM=2 D ; print page # on each pg, totals on last page of 1500
18 . S LPG=+$O(^TMP("IBXDATA",$J,IBXREC,""),-1)
19 . S Z="[Page "_PG_" of "_LPG_"]"
20 . S Z=$$FO^IBCNEUT1(Z,17,"R")
21 . D SETGBL^IBCEFG(PG,6,61,Z,.IBXSIZE)
22 . I PG=2 S Z=$P(Z,"[",1)_"[Page 1 of "_LPG_"]" D SETGBL^IBCEFG(1,6,61,Z,.IBXSIZE)
23 . I LPG=PG D
24 .. ;
25 .. ; esg - IB*2*348 - update dollar format for last page of 1500
26 .. ;
27 .. D SETGBL^IBCEFG(PG,57,51,$$DOL^IBCEF77($G(IBXSAVE("TOT")),9),.IBXSIZE)
28 .. D SETGBL^IBCEFG(PG,57,62,$$DOL^IBCEF77($G(IBXSAVE("PAID")),8),.IBXSIZE)
29 .. D SETGBL^IBCEFG(PG,57,71,$$DOL^IBCEF77($G(IBXSAVE("BDUE")),8),.IBXSIZE)
30 .. K IBXSAVE("PTOT"),IBXSAVE("TOT"),IBXSAVE("BDUE"),IBXSAVE("PAID")
31 ;
32 S Z=0 F S Z=$O(FLDS(Z)) Q:'Z D
33 . I $O(FLDS(Z,""))="" D Q ;repeats line
34 .. S Z0=0 F S Z0=$O(^TMP("IBXDATA",$J,IBXREC,1,Z,Z0)) Q:'Z0 S Z1=$G(^(Z0)) I Z1'="" D SETGBL^IBCEFG(PG,Z,Z0,Z1,.IBXSIZE)
35 . S Z0=0 F S Z0=$O(FLDS(Z,Z0)) Q:'Z0 S Z1=$G(^TMP("IBXDATA",$J,IBXREC,1,Z,Z0)) I Z1'="" D SETGBL^IBCEFG(PG,Z,Z0,Z1,.IBXSIZE)
36 . I FORM=2,LPG'=PG D
37 .. D SETGBL^IBCEFG(PG,57,51,"",.IBXSIZE)
38 .. D SETGBL^IBCEFG(PG,57,71,"",.IBXSIZE)
39 Q
40 ;
41NONSERV(Z,Z0) ; Set variable if non-service/non-text data is present for box
42 ; 24 of CMS-1500
43 ; Z = sequence of IBXSAVE being processed
44 ; Z0 = sequnce within IBXDATA to indicate actual line #
45 I $P(IBXSAVE("BOX24",Z),U)="" S IBXSAVE("NON-SERV",Z0)=""
46 Q
47 ;
48PG(VAL,LNCT) ;Set next pg for CMS-1500 lines
49 ;VAL = value of fld
50 ;LNCT = line # from IBXSAVE("BOX24") array
51 N IBP,IBL
52 S IBP=LNCT\12+(LNCT#12>0),IBL=LNCT-(12*(IBP-1))-1
53 I IBL'<0 S VAL=$$FORMAT(VAL,$G(IBXLOOP("IBX0")),$G(IBXDA)) D SETGBL^IBCEFG(IBP,IBXLN+IBL,IBXCOL,VAL,.IBXSIZE)
54 K IBXDATA(LNCT)
55 Q
56 ;
57MPGUB(PG,OFFSET,VAL,IBLN,IBCOL,NOFORM) ; Set up pages > 1 for UB overflows
58 ; PG = Page # to set (REQUIRED)
59 ; OFFSET = offset from first line this should be extracted into
60 ; 0 = first line (REQUIRED)
61 ; VAL = value to set (REQUIRED)
62 ; IBLN = line to set data at (if null, uses IBXLN)
63 ; IBCOL = column to set data at (if null, uses IBXCOL)
64 ; NOFORM = don't format, just output data as passed
65 ; Assumes formatter IBXLN,IBXCOL variables exist
66 ;
67 I $G(IBLN)="" S IBLN=IBXLN
68 I $G(IBCOL)="" S IBCOL=IBXCOL
69 S:'$G(NOFORM) VAL=$$FORMAT(VAL,$G(IBXLOOP("IBX0")),$G(IBXDA))
70 D SETGBL^IBCEFG(PG,IBLN+OFFSET,IBCOL,VAL,.IBXSIZE)
71 Q
72 ;
73CKREV(CT,VAL) ; Check too many rev code lines to fit on page
74 ; This procedure is only called when CT>22 (i.e. 23 or more)
75 ;
76 D MPGUB((CT-1)\22+1,CT-1#22,VAL) ; 22 codes on a single page
77 Q
78 ;
79CKPGUB ; Check to see if multiple UB pages are needed then populate
80 ; static flds from page 1, add page numbers
81 ;
82 N FLDS,LPG,IBPG,IBP,Z,Z0,TOT1,TOT2
83 ;
84 S LPG=$O(^TMP("IBXDATA",$J,IBXREC,""),-1),IBP=0
85 S Z="" F S Z=$O(^TMP("IBXDATA",$J,IBXREC,LPG,Z),-1) Q:'Z S Z0=0 F S Z0=$O(^TMP("IBXDATA",$J,IBXREC,LPG,Z,Z0)) Q:'Z0 I $G(^(Z0))'="" S IBP=1 Q
86 I 'IBP K ^TMP("IBXDATA",$J,IBXREC,LPG) S LPG=$O(^TMP("IBXDATA",$J,IBXREC,""),-1) Q:LPG=1
87 ;
88 ; Static flds
89 F Z=2:1:7 S FLDS(Z)="" ; FL-1 thru FL-9
90 F Z=1,10,13,19,22,25,28,31 S FLDS(9,Z)="" ; FL-10 thru FL-17
91 F Z=13:1:17 S FLDS(Z,1)="" ; payer address in FL-38
92 S FLDS(41,46)="" ; creation date
93 F Z=42,43,44,45,47,48,49,51,52,53 S FLDS(Z)="" ; FL-50 thru FL-65
94 F Z=57,59,61,63 S (FLDS(Z,59),FLDS(Z,72),FLDS(Z,74))="" ; FL-76-79 ID's
95 F Z=58,60,62,64 S (FLDS(Z,53),FLDS(Z,71))="" ; FL-76-79 Names
96 ;
97 F IBPG=1:1:LPG D
98 . ; Add pg # to last line of rev codes if multiple pages
99 . N IB,IBP
100 . S IB=$G(^TMP("IBXDATA",$J,IBXREC,IBPG,41,6))
101 . D MPGUB(IBPG,0,IBPG,41,10,1)
102 . D MPGUB(IBPG,0,LPG,41,16,1)
103 . D:IBPG>1 MPG(IBPG,.FLDS,1)
104 . Q
105 ; print totals on line 41 of the last page
106 S (TOT1,TOT2)=0
107 F Z=1:1 Q:'$D(^TMP($J,"IBC-RC",Z)) S Z0=^(Z) I +Z0=1 S TOT1=TOT1+$P(Z0,U,7),TOT2=TOT2+$P(Z0,U,8)
108 D MPGUB(IBPG,0,"0001",41,1,1)
109 D MPGUB(IBPG,0,$$DOL^IBCEF77(TOT1,9),41,61,1)
110 D MPGUB(IBPG,0,$$DOL^IBCEF77(TOT2,9),41,71,1)
111 ;
112 Q
113 ;
114HCPC(R) ;FORMAT HCPC fld FOR UB (returns formatted value)
115 ; R = flag for type of fld (1/2/3) being printed in rev code block
116 Q R ;No longer used as of patch IB*2.0*51
117 ;
118PROS(IBIFN) ; Extract billable prosthetics for 837
119 N IBARRAY,Z,Z0,CT,PROS
120 D SET^IBCSC5B(IBIFN,.IBARRAY)
121 I '$P(IBARRAY,U,2) S CT="" G PROSQ
122 S Z="",CT=0
123 F S Z=$O(IBARRAY(Z)) Q:Z="" S Z0="" F S Z0=$O(IBARRAY(Z,Z0)) Q:Z0="" S CT=CT+1 D
124 .S PROS=$$PINB^IBCSC5B(+IBARRAY(Z,Z0)) ; P389 removed p2 - item ptr file 661
125 .;date^^short descr^entry # in file 362.5
126 .S IBXDATA(CT)=Z_U_U_PROS_U_+IBARRAY(Z,Z0)
127PROSQ Q CT
128 ;
129B24(IBXSV,IBIFN,IBNOSHOW) ; Code to execute to set up IBXSV("BOX24") for
130 ; print or IBXSAVE("OUTPT") for transmit - called by output formatter
131 ; IBNOSHOW = 1 if not to show error/warning text lines
132 ; Pass IBXSV by reference
133 N IBSUB
134 S IBSUB=$S('$G(^TMP("IBTX",$J,IBIFN)):"BOX24",1:"OUTPT")
135 K IBXSV(IBSUB)
136 I '$D(IBIFN) S IBIFN=$G(IBXIEN)
137 I IBIFN D F^IBCEF("N-HCFA 1500 SERVICE"_$S(IBSUB["24":"S (PRINT",1:" LINE (EDI")_")",,,IBIFN)
138 I $S(IBSUB'["24":1,1:'$G(IBNOSHOW)) D
139 . M IBXSV(IBSUB)=IBXDATA
140 E D
141 . N Z,CT
142 . S (Z,CT)=0 F S Z=$O(IBXDATA(Z)) Q:'Z I '$D(IBXDATA(Z,"ARX")) S CT=CT+1 M IBXSV(IBSUB,CT)=IBXDATA(Z)
143 Q
144 ;
145 ; esg - 11/14/03 - Moved the below functions due to space constraints
146 ;
147ALLTYP(IBIFN) Q $$ALLTYP^IBCEF31(IBIFN)
148INSTYP(IBIFN,SEQ) Q $$INSTYP^IBCEF31(IBIFN,$G(SEQ))
149POLTYP(IBIFN,IBSEQ) Q $$POLTYP^IBCEF31(IBIFN,$G(IBSEQ))
150ALLPTYP(IBIFN) Q $$ALLPTYP^IBCEF31(IBIFN)
151 ;
152FILL(Z) ;
153 Q
154 ;
155 ; *****
156 ; The following code performs the multi-page set up for
157 ; printing overflow data on the UB
158 ; *****
159 ;
160XPROC(DATA,CT) ; Output any UB procedures after 6 on new page(s)
161 ; DATA = output data from IBXSAVE("PROC",CT)
162 ; CT = array sequence # of the procedure being output
163 ; Only used for local prints
164 N OFFSET,PG,COL,PRCODE,Q
165 S Q=(CT-1)\3#2,OFFSET=$S('Q:0,1:2)
166 S PG=(CT-1)\6+1,COL=1+(CT-1#3*15)
167 D MPGUB(PG,OFFSET,$P(DATA,U,1),58,COL)
168 D MPGUB(PG,OFFSET,$P(DATA,U,2),58,COL+9)
169 Q
170 ;
171XDIAG(DATA,CT) ; Output any UB other diagnoses after 8 on new page(s)
172 ; DATA = output data from IBXSAVE("DX",CT)
173 ; CT = array sequence # of the diagnosis being output
174 ; Only used for local prints
175 N COL,PG
176 S PG=(CT-1)\8+1,COL=8+(CT-1#9*7)
177 S DATA=$P($$ICD9^IBACSV(+DATA),U,1)
178 D MPGUB(PG,0,DATA,56,COL)
179 Q
180 ;
181XVAL(DATA,CT) ; Output any UB value codes after 12 on new page(s)
182 ; DATA = output data from IBXSAVE("VC",CT)
183 ; CT = array sequence # of the value code being output
184 ;
185 N COL,PG,OFFSET
186 S PG=(CT-1)\12+1,COL=44+(CT-1#3*13),OFFSET=(CT-(12*(PG-1))-1)\3
187 D MPGUB(PG,OFFSET,$P(DATA,U,1),14,COL)
188 D MPGUB(PG,OFFSET,$P(DATA,U,2),14,COL+3)
189 Q
190 ;
191XCC(DATA,CT) ; Output any UB condition codes after 11 on new page(s)
192 ; 11 condition codes per page, starting columns 34 thru 64
193 ; DATA = output data from IBXSAVE("CC",CT)
194 ; CT = array sequence # of the condition code being output
195 ;
196 N COL,PG
197 S PG=(CT-1)\11+1,COL=34+(CT-1#11*3)
198 D MPGUB(PG,0,DATA,9,COL)
199 Q
200 ;
201XOCC(DATA,CT,FL) ; Output any UB occurrence codes after 8 (2 per form
202 ; locators 31-34) on new page(s)
203 ; DATA = data from IBXSAVE("OCC",z) to be output
204 ; CT = array sequence # of occurrence code being output
205 ; FL = # of form locator being populated with the occ code
206 ;
207 N COL,PG,OFFSET
208 S PG=(CT-1)\2+1,COL=1+((FL-31)*10),OFFSET=$S(CT#2:0,1:1)
209 D MPGUB(PG,OFFSET,$P(DATA,U,1),11,COL)
210 D MPGUB(PG,OFFSET,$P(DATA,U,2),11,COL+4)
211 Q
212 ;
213XOCCS(DATA,CT,FL) ; Output any UB occurrence span codes after 4 on new page(s)
214 ; DATA = data from IBXSAVE("OCCS",z) to be output
215 ; CT = array sequence # of occurrence span code being output
216 ; FL = # of form locator being populated (either FL 35 or 36)
217 ;
218 N COL,PG,OFFSET
219 S PG=(CT-1)\2+1,OFFSET=$S(CT#2:0,1:1)
220 S COL=41+((FL-35)*17)
221 D MPGUB(PG,OFFSET,$P(DATA,U,1),11,COL)
222 D MPGUB(PG,OFFSET,$P(DATA,U,2),11,COL+4)
223 D MPGUB(PG,OFFSET,$P(DATA,U,3),11,COL+11)
224 Q
225 ;
226FORMAT(VAL,IBX0,IBXDA) ;
227 I IBX0'="",IBXDA S VAL=$$FORMAT^IBCEFG(VAL,$P($G(^IBA(364.6,+IBXDA,0)),U,9),$P(IBX0,U,7),IBX0)
228 Q VAL
229 ;
230OUTPDT(IBIFN,IBXSAVE,IBXDATA) ; Returns outpatient service to date
231 ; formatted CCYYMMDD for UB 837
232 ; IBIFN = ien of bill (file 399)
233 ; IBXSAVE = pass by reference for IBXSAVE("INPT") and IBXSAVE("DATE")
234 ; IBXDATA = array with formatted date or each line item - CCYYMMDD
235 N Z
236 S Z=0 F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z S IBXDATA(Z)=$S($P(IBXSAVE("INPT",Z),U,10):$$DT^IBCEFG1($P(IBXSAVE("INPT",Z),U,10),,"D8"),1:IBXSAVE("DATE"))
237 K IBXSAVE("DATE")
238 Q
239 ;
Note: See TracBrowser for help on using the repository browser.