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

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

initial load of FOIAVistA 6/30/08 version
File size: 8.8 KB
Line 
1IBCEF11 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS - CONT ;30-JAN-96
2 ;;2.0;INTEGRATED BILLING;**51,137,155,309,335,348,349,371**;21-MAR-94;Build 57
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5BOX24D(A,IB) ; Returns the lines for boxes 19-24 of the CMS-1500 display
6 ; IB = flag is 1 if only box 24 is needed
7 Q $S('$G(IB):"36",1:"44")_"^55"
8 ;
9RCBOX() ; Returns the lines for revenue code boxes of the UB-04 display
10 Q "19^41"
11 ;
12OUTPT(IBIFN,IBPRINT) ; Returns an array of service line data from
13 ; CMS-1500 box 24. Output is in IBXDATA(n)
14 ; IBPRINT = print flag 1: return print fields
15 ; 0: return EDI fields
16 ; Uses diagnosis array ^TMP("IBXSAVE",$J,"DX",IBIFN,DIAG CODE)=SEQ #
17 ; if it already exists. If not, it builds it from N-DIAGNOSES element
18 ;
19 ; For EDI call: Returns IBXDATA(n)=
20 ; begin date(YYYYMMDD)^end date(YYYYMMDD)^pos^tos^
21 ; proc code/revenue code - if no procedure (not the pointers)^
22 ; type of code^dx pointer(s)^unit charge^units^modifiers separated by;
23 ; ^purchased charge amount ^anesthesia minutes^emergency indicator^
24 ; lab-type service flag.
25 ;
26 ; Also Returns IBXDATA(IBI,"COB",COB,m) with COB data for each line
27 ; item found in an accepted EOB for the bill and = the reference
28 ; line in the first '^' piece followed by the '0' node data of file
29 ; 361.115 (LINE LEVEL ADJUSTMENTS)
30 ; COB = COB sequence # of adjustment's ins co, m = seq #
31 ; -- AND --
32 ; IBXDATA(IBI,"COB",COB,m,z,p)=
33 ; the data on the '0' node for each subordinate entry of file
34 ; 361.11511 (REASONS) (Only first 3 pieces for 837 output)
35 ; z = group code, sometimes preceeded by a space p = seq #
36 ;
37 ; For Print call: Returns begin date(DDMMYYYY)^end date(DDMMYYYY) or
38 ; null if equal to begin date^pos^tos^bedsection name(if no procedure)
39 ; or procedure code(not the pointer)^ ... refer to EDI call results
40 ; Also, IBXDATA(n,"TEXT")=the text to print on first line of box 24,
41 ; If no procedure code, returns IBXDATA(n,"A")=rev code abbrev
42 ;
43 ; For both calls, returns IBXDATA(n,item type,item ptr)=""
44 ; -- AND --
45 ; IBXDATA(n,"RX")=RX#^drug name^NDC^refill #^(re)fill date^qty^days
46 ; ^chrge^ien of file 362.4^NDC format
47 ; If line references a prescription
48 ; -- AND --
49 ; If no revenue code for a prescription, returns IBXDATA(n,"ARX")=""
50 ; -- AND --
51 ; IBXDATA(n,"AUX")='AUX' node of the procedure entry
52 ;
53 N IB,IBI,IBJ,IBFLD,IBDXI,IBXIEN,Z,IBXTRA,IBRX,IBRX0,IBRX1,Z0,Z1
54 ;
55 K ^TMP($J,"IBITEM")
56 S ^TMP($J,"IBITEM")=""
57 ; Build diagnosis array if not already built
58 I $O(^TMP("IBXSAVE",$J,"DX",IBIFN,""))="",$O(^IBA(362.3,"AIFN"_IBIFN,"")) D
59 .N Z,IBXDATA D F^IBCEF("N-DIAGNOSES",,,IBIFN)
60 .S Z="" F S Z=$O(IBXDATA(Z)) K:$O(IBXDATA(0))=""&(Z="") IBXDATA Q:Z="" S:$P(IBXDATA(Z),U,2) ^TMP("IBXSAVE",$J,"DX",IBIFN,$P(IBXDATA(Z),U,2))=Z
61 ;
62 S IB(0)=$G(^DGCR(399,IBIFN,0)),IB("U")=$G(^("U")),IB("U1")=$G(^("U1"))
63 S IBI="" F S IBI=$O(^TMP("IBXSAVE",$J,"DX",IBIFN,IBI)) Q:IBI="" S IBDXI(IBI)=^(IBI)
64 I '$G(IBPRINT) D RVCE^IBCF23(IBIFN,IBIFN)
65 I $G(IBPRINT) D RVCE^IBCF23(,IBIFN)
66 ; Returns IBFLD(24) = begin date^end date^pos^tos^
67 ; proc/bedsection/revenue code^dx pointer^unit charge^
68 ; units^modifiers^ purchased charge amount ^anesthesia minutes^
69 ; emergency indicator ^ AND
70 ; IBFLD(24,n,type,item)=""
71 ; IBFLD(24,n_"A") = revenue code abbreviation if no procedure
72 ; IBFLD(24,n,"AUX") = 'AUX' node of line item
73 ; IBFLD(24,n,"RX") = soft pointer to file 362.4 from 'item' fld
74 ; (can be null)
75 ;
76 D SET^IBCSC5A(IBIFN,.IBRX) ;prescriptions
77 ; IBRX1(ien 362.4)=RX#^drug ien^NDC^refil #^(re)fil date^qty^days^chrge
78 I IBRX S IBRX="" F S IBRX=$O(IBRX(IBRX)) Q:IBRX="" S IBRX0=0 F S IBRX0=$O(IBRX(IBRX,IBRX0)) Q:'IBRX0 D
79 . N IBRXH
80 . S IBRXH=IBRX(IBRX,IBRX0)
81 . S IBRX1(+IBRXH)=IBRX_U_$P(IBRXH,U,2)_U_$P(IBRXH,U,5)_U_$P(IBRXH,U,7)_U_IBRX0_U_$P(IBRXH,U,4)_U_$P(IBRXH,U,3)_U_$P(IBRXH,U,6)_U_+IBRXH_U_$P(IBRXH,U,8)
82 K IBRX
83 ;
84 ; for EDI, remove any $0 line items from the IBFLD array before
85 ; dropping down into the next loop (IB*2*371)
86 I '$G(IBPRINT) D
87 . NEW IBZ,IBI,Z
88 . M IBZ=IBFLD K IBFLD
89 . S (IBI,Z)=0
90 . F S IBI=$O(IBZ(24,IBI)) Q:IBI'=+IBI D
91 .. I $P(IBZ(24,IBI),U,7)*$P(IBZ(24,IBI),U,8)'>0 Q
92 .. S Z=Z+1
93 .. M IBFLD(24,Z)=IBZ(24,IBI)
94 .. S IBFLD(24)=Z
95 .. Q
96 . Q
97 ;
98 S IBI=0
99 F S IBI=$O(IBFLD(24,IBI)) Q:IBI'=+IBI D
100 . S IBRX1=0
101 . S IBXDATA(IBI)=$P(IBFLD(24,IBI),U)_U_$P(IBFLD(24,IBI),U,$S($P(IBFLD(24,IBI),U,2)=""&'$G(IBPRINT):1,1:2))
102 . S $P(IBXDATA(IBI),U,3,5)=$P(IBFLD(24,IBI),U,3,5)
103 . S $P(IBXDATA(IBI),U,6)=$S($D(IBFLD(24,IBI_"X")):"CJ",1:"HC")
104 . S $P(IBXDATA(IBI),U,7,13)=$P(IBFLD(24,IBI),U,6,12)
105 . S $P(IBXDATA(IBI),U,14)=+$$ISLAB(IBXDATA(IBI))
106 . ;
107 . I $D(IBFLD(24,IBI,"RX")) D ;Rx
108 .. S IBRX1=1
109 .. I $P($G(IBFLD(24,IBI,"AUX")),U,8)'="" S $P(IBFLD(24,IBI,"AUX"),U,8)="",$P(IBFLD(24,IBI,"AUX"),U,9)="" ;No free text allowed for rx's
110 .. I $D(IBRX1(+IBFLD(24,IBI,"RX"))) D Q ;Soft link exists
111 ...D ZERO^IBRXUTL(+$P(IBRX1(+IBFLD(24,IBI,"RX")),U,2))
112 ... S IBXDATA(IBI,"RX")=IBRX1(+IBFLD(24,IBI,"RX")),$P(IBXDATA(IBI,"RX"),U,2)=$E($G(^TMP($J,"IBDRUG",+$P(IBRX1(+IBFLD(24,IBI,"RX")),U,2),.01)),1,30)
113 ... K IBRX1(+IBFLD(24,IBI,"RX"))
114 ... ; No soft link - must find the first Rx with the same charge
115 .. S IBRX="" F S IBRX=$O(IBRX1(IBRX)) Q:'IBRX I +$P(IBRX1(IBRX),U,8)=+$P(IBXDATA(IBI),U,8) D Q
116 ... D ZERO^IBRXUTL(+$P(IBRX1(IBRX),U,2))
117 ... S IBXDATA(IBI,"RX")=IBRX1(IBRX),$P(IBXDATA(IBI,"RX"),U,2)=$E($G(^TMP($J,"IBDRUG",+$P(IBRX1(IBRX),U,2),.01)),1,30) K IBRX1(IBRX) Q
118 ... Q
119 .. Q
120 . ;
121 . I $G(IBFLD(24,IBI,"AUX"))'="" D
122 .. I $G(IBPRINT),$P(IBFLD(24,IBI,"AUX"),U,8)'="" S IBXDATA(IBI,"TEXT")=$P(IBFLD(24,IBI,"AUX"),U,8),$P(IBFLD(24,IBI,"AUX"),U,8)=""
123 .. S IBXDATA(IBI,"AUX")=IBFLD(24,IBI,"AUX")
124 .. Q
125 . ;
126 . I $G(IBPRINT) D
127 .. I '$P(IBXDATA(IBI),U,8),'$G(IBXDATA(IBI,"RX")) D Q
128 ... I $G(IBNOSHOW) Q ; don't show errors/warnings
129 ... S IBXDATA(IBI,"TEXT")="Warning:** REV CODE UNITS < #PROCEDURES, THEY MUST BE ="
130 ... I $D(IBXDATA(IBI,"AUX")) S $P(IBXDATA(IBI,"AUX"),U,9)=""
131 ... Q
132 .. ;
133 .. I $G(IBFLD(24,IBI_"A"))'="" D Q
134 ... S IBXDATA(IBI,"A")=IBFLD(24,IBI_"A")
135 ... I $G(IBNOSHOW) Q ; don't show errors/warnings
136 ... S IBXDATA(IBI,"TEXT")="Warning:** REV CODE UNITS > #PROCEDURES, THEY MUST BE=: "_IBFLD(24,IBI_"A")
137 ... I $D(IBXDATA(IBI,"AUX")) S $P(IBXDATA(IBI,"AUX"),U,9)=""
138 ... Q
139 .. ;
140 .. S IBRX=$G(IBXDATA(IBI,"RX"))
141 .. I IBRX'="" D ;Format Rx detail
142 ... N Z
143 ... S Z=$P(IBRX,U)
144 ... S Z=$S(Z'="":"Rx#"_Z_" ",1:"RX: ")
145 ... S IBXDATA(IBI,"TEXT")=Z_$S($P(IBRX,U,3)'="":"NDC: "_$P(IBRX,U,3),1:"NOC: "_$P(IBRX,U,2))_" Qty: "_$P(IBRX,U,6)_" Days: "_$P(IBRX,U,7)
146 ... S $P(IBXDATA(IBI,"AUX"),U,9)="N4" ; service line comment qualifier for RX's
147 ... Q
148 .. Q
149 . ;
150 . I '$G(IBPRINT) D COBLINE^IBCEU6(IBIFN,IBI,.IBXDATA,,.IBXTRA)
151 . Q
152 ;
153 I $G(IBPRINT) D
154 . S IBRX=0 F S IBRX=$O(IBRX1(IBRX)) Q:'IBRX D
155 .. S IBI=+$O(IBXDATA(""),-1)+1
156 .. S IBXDATA(IBI)=$$DATE($P(IBRX1(IBRX),U,5))
157 .. S IBXDATA(IBI,"TEXT")="**** ERROR - NO PROC LINK TO REV CODE FOR DRUG: RX#: "_$P(IBRX1(IBRX),U)_" NDC #: "_$P(IBRX1(IBRX),U,3)
158 .. I $D(IBXDATA(IBI,"AUX")) S $P(IBXDATA(IBI,"AUX"),U,9)=""
159 .. S IBXDATA(IBI,"ARX")=""
160 .. D ZERO^IBRXUTL(+$P(IBRX1(IBRX),U,2))
161 .. S IBXDATA(IBI,"RX")=IBRX1(IBRX),$P(IBXDATA(IBI,"RX"),U,2)=$E($G(^TMP($J,"IBDRUG",+$P(IBRX1(IBRX),U,2),.01)),1,30) K IBRX1(IBRX)
162 .. Q
163 . Q
164 ;
165 I '$G(IBPRINT),$D(IBXTRA) D COMBO^IBCEU2(.IBXDATA,.IBXTRA,0) ;Handle bundled/unbundled lines
166 K ^TMP($J,"IBDRUG")
167 Q
168 ;
169ISLAB(LDATA) ; Returns 0/1 if line item data indicates the item is a lab (1)
170 ; 'LAB' is defined here as type of service = 5
171 Q $E($P(LDATA,U,4))="5"
172 ;
173FMT(DATA,DLEN,FLEN) ; Returns a string in DATA with a max length of DLEN
174 ; and a field length of FLEN
175 Q $E($E(DATA,1,DLEN)_$J("",FLEN),1,FLEN)
176 ;
177DATE(X,DEL) ; Returns FM date in X as MMxDDxYYYY where x=DEL
178 S DEL=$G(DEL)
179 S X=$$DATE^IBCF2(X,1,1)
180 I X'="" S X=$E(X,1,2)_DEL_$E(X,3,4)_DEL_$E(X,5,8)
181 Q X
182 ;
183BATCH() ; Sets up record for and stores/returns the next batch number
184 N NUM,FAC,DO,DD,DLAYGO,DIC,X,Y
185 ;Keep latest batch number for view/print edi bill extract data option
186 I $D(IBVNUM) S NUM=IBVNUM G BATCHQ
187 ;Check for batch resubmit - if yes, use same number as original batch
188 I $P($G(^TMP("IBRESUBMIT",$J)),U,3)=1 S NUM=$P(^($J),U) G BATCHQ
189 L +^IBA(364.1,0):5 I '$T Q 0
190 S FAC=+$P($$SITE^VASITE(),U,3),NUM=$O(^IBA(364.1,"B",""),-1)
191 I $D(^IBA(364.1,+NUM,0)),$P(^(0),U,2)="" F D Q:'NUM!($P($G(^IBA(364.1,+NUM,0)),U,2)'="")
192 . I $D(^IBA(364.1,NUM,0)) S DA=NUM,DIK="^IBA(364.1," D ^DIK
193 . S NUM=$O(^IBA(364.1,"B",""),-1)
194 F S NUM=$S($P(NUM,FAC,2)'="":NUM+1,1:FAC_"0000001") Q:'$D(^IBA(364.1,"B",NUM))
195 K DO,DD S DIC="^IBA(364.1,",DLAYGO=364.1,DIC(0)="L",X=NUM D FILE^DICN K DD,DO I Y'>0 S NUM=0
196 L -^IBA(364.1,0)
197BATCHQ Q NUM
198 ;
Note: See TracBrowser for help on using the repository browser.