source: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF1.m@ 636

Last change on this file since 636 was 636, checked in by George Lilly, 14 years ago

WorldVistAEHR overlayed on FOIAVistA
File size: 8.9 KB
Line 
1IBCEF1 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS - CONT ;30-JAN-96
2 ;;2.0;INTEGRATED BILLING;**52,124,51,137,210,155,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5OCC(IBIFN,REL,TEXT) ;Sets up an arrays of occurrence codes for various cks
6 ;RETURNS 1^additional data for entry IBXSAVE("OCC",n) if REL or TEXT
7 ; parameters have been met or null if conditions not met
8 ;If no REL or TEXT parameters sent, just extract codes array
9 ; IBIFN = bill ien
10 ; REL = 'OCC RELATED TO' value to check for
11 ; TEXT = text to check for the .01 field of 399.1 entry pointed to
12 ; by the occurrence code
13 N OCC,SORT,ARR,N,DATA,CODE,CT
14 I '$D(IBXSAVE("OCC")),'$D(IBXSAVE("OCCS")) D
15 .N IBI,Z,CT1,CT2,Z0 S (IBI,CT1,CT2)=0
16 .F S IBI=$O(^DGCR(399,IBIFN,"OC",IBI)) Q:'IBI S Z=$G(^(IBI,0)) D
17 ..S Z0=$G(^DGCR(399.1,+Z,0))
18 ..Q:'$P(Z0,U,10)&'$P(Z0,U,4) ;Not an occurrence code
19 ..I $P(Z0,U,10) S CT2=CT2+1,IBXSAVE("OCCS",CT2)=$S($P(Z0,U,4):$P(Z0,U,2)_U_$P(Z,U,2),1:U)_U_$P(Z,U,4)_U_$P(Z0,U)_U_$P(Z0,U,9)_U_$P(Z,U,3)_U_$P(Z,U,2)
20 ..I '$P(Z0,U,10) S CT1=CT1+1,IBXSAVE("OCC",CT1)=$S($P(Z0,U,4):$P(Z0,U,2)_U_$P(Z,U,2),1:U)_U_U_$P(Z0,U)_U_$P(Z0,U,9)_U_$P(Z,U,3)_U_$P(Z,U,2)
21 I '$D(IBXSAVE("OCC"))&'$D(IBXSAVE("OCCS")) S IBXSAVE("OCC")="" G OCCQ
22 ;
23 ; esg - IB*2*349 - order the occurrence codes
24 ; Build the SORT array sorted by the occ code
25 F ARR="OCC","OCCS" S N=0 F S N=$O(IBXSAVE(ARR,N)) Q:'N S DATA=$G(IBXSAVE(ARR,N)) I $P(DATA,U,1)'="" S CODE=" "_$P(DATA,U,1),SORT(ARR,CODE,N)=DATA
26 ; Loop thru the SORT array and re-build the IBXSAVE array
27 F ARR="OCC","OCCS" K IBXSAVE(ARR) S CODE="",CT=0 F S CODE=$O(SORT(ARR,CODE)) Q:CODE="" S N=0 F S N=$O(SORT(ARR,CODE,N)) Q:'N S CT=CT+1,IBXSAVE(ARR,CT)=SORT(ARR,CODE,N)
28 ;
29 I $G(REL)'=""!($G(TEXT)'="") D OCC1("",.OCC,$G(REL),$G(TEXT)) D:'$D(OCC) OCC1("S",.OCC,$G(REL),$G(TEXT))
30OCCQ Q $G(OCC)
31 ;
32OCC1(ARR,OCC,REL,TEXT) ; Search thru local array for parameters met
33 ; ARR = null to search OCC subscript, "S" to search OCCS subscript
34 N Z
35 S ARR="OCC"_ARR,Z=0
36 F S Z=$O(IBXSAVE(ARR,Z)) Q:'Z D
37 .I $G(REL)'="",$P(IBXSAVE(ARR,Z),U,5)=REL S OCC="1"_$S(REL=2:U_$P(IBXSAVE(ARR,Z),U,6),1:"") Q
38 .I $G(TEXT)'="",$P(IBXSAVE(ARR,Z),U,4)=TEXT S OCC="1^"_$P(IBXSAVE(ARR,Z),U,7)
39 Q
40 ;
41RX(IBIFN) ; Format billable prescription data for refills for 837
42 N Z,IBXDATA,CT
43 I '$D(IBXSAVE("BOX24")) D B24^IBCEF3(.IBXSAVE,IBIFN,1)
44 S Z="",CT=0
45 F S Z=$O(IBXSAVE("BOX24",Z)) Q:Z="" I $D(IBXSAVE("BOX24",Z,"RX")) S CT=CT+1,IBXDATA(Z)=IBXSAVE("BOX24",Z,"RX")
46RXQ Q CT
47 ;
48OTHPAY(IBIFN,SEQ) ; Return the other insurance payment amount for bill
49 ; IBIFN and payer sequence SEQ (1-3)
50 N AMT,IBIFN1
51 S IBIFN1=$P($G(^DGCR(399,IBIFN,"M1")),U,SEQ+4)
52 I IBIFN1 D
53 . I $$MCRWNR^IBEFUNC(+$G(^DGCR(399,IBIFN,"I"_SEQ))) S AMT=$$MCRPAY^IBCEU0(IBIFN) Q
54 . S AMT=+$$TPR^PRCAFN(IBIFN1) Q:AMT ; A/R amount
55 . S AMT=+$P($G(^DGCR(399,IBIFN,"U2")),U,SEQ+3) ; amount on bill
56 Q $G(AMT)
57 ;
58OUTPT(IBIFN,IBPRINT) ; Moved for space
59 D OUTPT^IBCEF11(IBIFN,$G(IBPRINT))
60 Q
61 ;
62OCC92 ;Reformats IBXSAVE("OCC") and IBXSAVE("OCCS") to fit blocks on UB-04
63 ; Set up IBXSAVE(32-36) arrays
64 N IBPG,IB32,IB33,IB34,IB35,IB36,IBFL,Z,Z0,PG
65 S IBPG=0
66 F Z=32:1:36 K IBFL(Z) S IBFL(Z)=0
67 M IB32=IBXSAVE("OCC"),IB36=IBXSAVE("OCCS")
68 S IB32=$O(IB32(""),-1),IB36=$O(IB36(""),-1),PG=1
69 D OCC^IBCF32
70 F Z=32:1:36 S Z0="" F S Z0=$O(IBFL(Z,Z0)) Q:'Z0 S IBXSAVE("OC92",Z,Z0)=$P(IBFL(Z,Z0),U,1,3)
71 Q
72 ;
73BATCH() ; Moved for space IB*2*349
74 Q $$BATCH^IBCEF11()
75 ;
76PROC(T,TYPE) ; Find procedure code, strip '.' Function returns result
77 ; T = Procedure internal entry #;file reference
78 ; TYPE = "CPT" for only CPT/HCPCS valid
79 ; "ICD" for only ICD9 valid or null for either
80 N Q,S
81 S Q="",S="^"_$P($P(T,";",2),"(")
82 I $G(TYPE)="" D
83 . I $E(S,2,3)="IC" S Q=$P($$PRCD(T),U) Q
84 . I T["DIC(81.3" S Q=$$MOD^ICPTMOD(+T,"I") S Q=$S(Q>0:$P(Q,U,4),1:"")
85 I $G(TYPE)="CPT",$E(S,2,3)="IC" S Q=$$PRCD(T) Q
86 I $G(TYPE)="ICD",T["ICD0" S Q=$P($$ICD0^IBACSV(+T),U)
87 Q $TR(Q,".")
88 ;
89FACILITY(IBIFN) ;return the Facility (Institution pointer-#4) for a bill
90 ; the institution of the Bill Division (399,.22) if defined, otherwise the Facility Name (350.9,.02)
91 ;
92 N IB0,IBIN S IBIN=0
93 S IB0=$G(^DGCR(399,+$G(IBIFN),0)) I +$P(IB0,U,22) S IBIN=$$SITE^VASITE(+$P(IB0,U,3),+$P(IB0,U,22))
94 I IBIN'>0 S IBIN=+$P($G(^IBE(350.9,1,0)),U,2)
95 Q +IBIN
96 ;
97ISRX(IBIFN) ; Function to determine if bill is a prescription refill bill
98 ; Returns 0 if no Rx on bill or 1 if there is.
99 ;
100 N IBRX
101 I $D(^IBA(362.4,"AIFN"_IBIFN)) S IBRX=1
102 Q +$G(IBRX)
103 ;
104ISPROS(IBIFN) ; Function to determine if bill is a prosthetics bill
105 ; Returns 0 if no Prosthetics on bill or 1 if there is.
106 ;
107 N IBPROS
108 I $D(^IBA(362.5,"AIFN"_IBIFN)) S IBPROS=1
109 Q +$G(IBPROS)
110 ;
111FINDINS(IBIFN,IBSEQ) ; Returns the internal entry number of the insurance
112 ; company for bill ien IBIFN for payer sequence IBSEQ (or current if
113 ; IBSEQ is null)
114 Q $P($G(^DGCR(399,IBIFN,"I"_$$COBN^IBCEF(IBIFN,$G(IBSEQ)))),U)
115 ;
116TOB(IBIFN) ; Returns UB-04 type of bill from data in the output formatter
117 N IBTOB,IBZ1,IBZ2,IBZ3
118 D F^IBCEF("N-UB-04 LOCATION OF CARE","IBZ1",,IBIFN)
119 D F^IBCEF("N-UB-04 BILL CLASSIFICATION","IBZ2",,IBIFN)
120 D F^IBCEF("N-UB-04 TIMEFRAME OF BILL","IBZ3",,IBIFN)
121 S IBTOB=IBZ1_IBZ2_IBZ3
122 Q IBTOB
123 ;
124PRCD(PRIEN,ALL,EDT) ; Function returns the code that corresponds to the variable
125 ; pointer data in PRIEN (ien;file)
126 ; ALL = if ALL=1, returns the entire $$CPT^ICPTCOD for CPT or
127 ; ^code^name format for ICD result
128 ; or null if lookup fails
129 ; EDT = Effective date to check (not used if +$G(ALL)=0)
130 N CODE,IBX
131 S CODE=""
132 ;Modified for Code Set Versioning
133 I PRIEN["ICPT" S IBX=$$CPT^ICPTCOD(+PRIEN,$G(EDT)) G:IBX'>0 PRCDQ S CODE=$S($G(ALL):IBX,1:$P(IBX,U,2))
134 I PRIEN["ICD0" S IBX=$$ICD0^IBACSV(+PRIEN,$G(EDT)) G:IBX="" PRCDQ S CODE=$S($G(ALL):U_$P(IBX,U)_U_$P(IBX,U,4),1:$P(IBX,U))
135PRCDQ Q CODE
136 ;
137NFT(FT,IBIFN) ; Returns 1 if bill IBIFN is not of form type FT (internal)
138 ; so the data element should not be required
139 S FT=$S($$FT^IBCEF(IBIFN)=FT:0,1:1)
140 Q FT
141 ;
142REQ(FT,INP,IBIFN) ; Determine if bill IBIFN is of form type FT and
143 ; Inpatient (I) or Outpatient (O) status INP [or either if (null)]
144 ;
145 ;Returns 1 if both conditions FT and INP match for the bill
146 ; or 0 if either of these conditions are not true
147 ; I $$REQ^IBCEF1(2,"I",1) would mean if bill entry #1 is
148 ; CMS-1500/inpatient the data would be required
149 ; I '$$REQ^IBCEF1(2,"I",1) would mean if bill entry #1 is anything but
150 ; CMS-1500/inpatient, the data would not be
151 ; required
152 N Z
153 S Z=1
154 S:$$NFT(FT,IBIFN) Z=0 ; Not the form type for requirement
155 I Z,$G(INP)'="" D
156 . S Z0=$$INPAT^IBCEF(IBIFN,1),INP=$G(INP)
157 . S Z=$S(Z0:INP="I",1:INP="O") ;Check if I/O matches required state
158 Q Z
159 ;
160SET1(IBIFN,A,IBZ,IBXDATA,IBXNOREQ) ; Utility to set variables for output
161 ; formatter for professional EDI
162 ; Returns values of A, IBXDATA, IBZ, IBXNOREQ
163 N Z,CT
164 S A="^TMP($J,""IBLCT"")"
165 S (Z,CT)=0
166 F S Z=$O(IBXDATA(Z)) Q:'Z D ; Don't transmit 0-charges
167 . I $P(IBXDATA(Z),U,9),$P(IBXDATA(Z),U,8) S CT=CT+1 M IBZ(CT)=IBXDATA(Z)
168 K IBXDATA
169 S IBXNOREQ='$$REQ(2,"O",IBIFN)
170 Q
171 ;
172CIADDR(IBXDATA,IBXSAVE,LINE,FORM) ; Format current ins co address line LINE for FORM
173 ; FORM = 1 for CMS-1500, 2 for UB-04
174 ; Called from output formatter - both IBXDATA, IBXSAVE parameters are
175 ; passed by reference
176 ;
177 K IBXDATA
178 I $G(FORM)'=1 D
179 . ;
180 . ; esg - 11/17/06 - IB*2*349 - UB-04 FL-38 contains the payer name
181 . ; and address on 4 lines within this 5 line box. All 5 lines
182 . ; are formatted here into the IBXDATA array. This is the
183 . ; address that shows through the envelope window.
184 . ;
185 . N Z,LM,Q,ADDR,X
186 . S LM=$P($G(^IBE(350.9,1,1)),U,31) ; UB address column parameter
187 . S Z=""
188 . I LM S $P(Z," ",LM)="" ; beginning spaces indent
189 . S ADDR=$G(IBXSAVE("CADR")) ; address data string
190 . S IBXDATA(1)="",Q=1 ; line 1 is blank
191 . S Q=Q+1
192 . S IBXDATA(Q)=Z_$G(IBXSAVE("CADR_NAME")) ; line 2 payer name
193 . S X=$P(ADDR,U,1)
194 . I X'="" S Q=Q+1,IBXDATA(Q)=Z_X ; address line 1
195 . S X=$P(ADDR,U,2)
196 . I X'="" S Q=Q+1,IBXDATA(Q)=Z_X D ; address line 2
197 .. S X=$P(ADDR,U,3)
198 .. I X'="" S IBXDATA(Q)=IBXDATA(Q)_" "_X ; address line 3
199 .. Q
200 . S Q=Q+1 ; city,st,zip on last line
201 . S IBXDATA(Q)=Z_$P(ADDR,U,4)_", "_$$STATE^IBCEFG1($P(ADDR,U,5))_" "_$P(ADDR,U,6)
202 . KILL IBXSAVE("CADR_NAME"),IBXSAVE("CADR") ; cleanup
203 . Q
204 ;
205 I $G(FORM)=1 D ; CMS-1500
206 . N CT,X,Z
207 . S:'$D(IBXSAVE("INDENT")) Z="",$P(Z," ",+$P($G(^IBE(350.9,1,1)),U,27)+1)="",IBXSAVE("INDENT")=Z
208 . S CT=0
209 . S X=$P(IBXSAVE("CADR"),U) S:X'="" CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_X
210 . S X=$S($P(IBXSAVE("CADR"),U,2)'="":$P(IBXSAVE("CADR"),U,2),1:"")_$S($P(IBXSAVE("CADR"),U,2)'="":" ",1:"")_$P(IBXSAVE("CADR"),U,3) S:X'="" CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_X
211 . S CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_$P(IBXSAVE("CADR"),U,4)_", "_$$STATE^IBCEFG1($P(IBXSAVE("CADR"),U,5))_" "_$P(IBXSAVE("CADR"),U,6)
212 . Q
213 ;
214 Q
215 ;
Note: See TracBrowser for help on using the repository browser.