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

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

initial load of WorldVistAEHR
File size: 7.0 KB
Line 
1IBCEF77 ;WOIFO/SS - FORMATTER/EXTRACT BILL FUNCTIONS ;31-JUL-03
2 ;;2.0;INTEGRATED BILLING;**232,280,155,290,291,320,348,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5SORT(IBPRNUM,IBPRTYP,IB399,IBSRC,IBDST,IBN,IBEXC,IBSEQ,IBLIMIT) ;
6 N IBXIEN,IBXDATA,IBNET,IBTRI,IB1,IB2,IBID,Z,IBZ,IBZ1,IBSVP
7 S (IB1,IB2,IBZ,IBZ1,IBTRI)=""
8 D F^IBCEF("N-ALL ATT/RENDERING PROV SSN","IBZ",,IB399)
9 S IBZ1=$$ALLPTYP^IBCEF3(IB399)
10 F Z=1:1:3 S $P(IBZ1,U,Z)=$S($P(IBZ1,U,Z)="CH":1,1:"") S:$P(IBZ1,U,Z) IBTRI=1
11 S IBNET=$$NETID^IBCEP() ; netwrk id type
12 I $G(IBN) D
13 . S Z=0 F S Z=$O(IBDST(IBPRNUM,IBPRTYP,Z)) Q:'Z S IBID(+$P(IBDST(IBPRNUM,IBPRTYP,Z),U,9))=""
14 F S IB1=$O(IBSRC(IB1)) Q:IB1="" D Q:IBN=IBLIMIT
15 . N OK,IBSTLIC
16 . S IBSTLIC=""
17 . F S IB2=$O(IBSRC(IB1,IB2)) Q:IB2="" D Q:IBN=IBLIMIT
18 . . S IBSVP=$P(IBSRC(IB1,IB2),U)
19 . . ; If ID overridden, output no others of this type
20 . . I $G(IBEXC),$P($G(IBSRC(IB1,IB2)),U,9)=IBEXC Q
21 . . ; Ck state of care/lic match if st lic#
22 . . I $P($G(IBSRC(IB1,IB2)),U,3)="0B" S OK=1 D Q:'OK
23 . . . I +$$CAREST^IBCEP2A(IB399)'=$P(IBSRC(IB1,IB2),U,7) S IBSTLIC=1 Q
24 . . . I $G(IBSTLIC(0))'="" S OK=0 Q
25 . . . S IBSTLIC(0)=$G(IBSRC(IB1,IB2)),OK=0
26 . . ; Exclude SSN from sec ids unless required
27 . . I $P($G(IBSRC(IB1,IB2)),U,3)="SY" Q
28 . . ; Only 1 of each prov id type
29 . . Q:$D(IBID(+$P($G(IBSRC(IB1,IB2)),U,9)))
30 . . S IBN=IBN+1,IBID(+$P($G(IBSRC(IB1,IB2)),U,9))=""
31 . . S IBDST(IBPRNUM,IBPRTYP,IBN)=$G(IBSRC(IB1,IB2))
32 . I IBN'=IBLIMIT,'$G(IBSTLIC),$G(IBSTLIC(0))'="" S IBN=IBN+1,IBDST(IBPRNUM,IBPRTYP,IBN)=IBSTLIC(0)
33 I $$FT^IBCEF(IB399)=2,$G(IBID(IBNET))="",IBTRI,$P(IBZ1,U,IBSEQ) D ; WCJ 02/13/2006
34 . Q:$P(IBZ,U,IBPRTYP)=""
35 . ; here, no network id & TRICARE ins co.
36 . N Z
37 . S Z=+$O(^DGCR(399,IB399,"PRV","B",IBPRTYP,0)),Z=$P($G(^DGCR(399,IB399,"PRV",Z,0)),U,2)
38 . S IBN=IBN+1,IBDST(IBPRNUM,IBPRTYP,IBN)=Z_U_+$$POLICY^IBCEF(IB399,1,IBSEQ)_U_$P($G(^IBE(355.97,IBNET,0)),U,3)_U_$P(IBZ,U,IBPRTYP)_U_"0^0^^^"_IBNET
39 Q
40 ;
41 ; esg - 8/25/06 - IB*2*348 - CFIDS function
42 ;
43CFIDS(IBIFN,PRVTYP,ALLOWIDS) ; Claim Form IDs for human providers
44 ; Function returns a 3 piece string: [1] default secondary ID qual
45 ; [2] default secondary ID
46 ; [3] NPI
47 ; Input: IBIFN - internal claim#
48 ; PRVTYP - internal provider type ID number
49 ; - 1:REFER;2:OPER;3:REND;4:ATT;5:SUPER;9:OTHER
50 ; - if blank, then default Att/Rend based on form type
51 ; ALLOWIDS - List of allowable Secondary IDS ^ delimited.
52 ; ex "^1A^1B^1C^1H^G2^LU^N5^"
53 ; UB-04 only wants IDs provided by the payer, not the providers own IDS
54 ; Also, they want the qualifier to be G2 (Commercial)
55 ; if it is a payer provided ID
56 NEW ID,FT,IBZ,IBQ,IBSID,IBNPI,I,OK
57 S ID=""
58 I '$G(IBIFN) G CFIDSX
59 S FT=$$FT^IBCEF(IBIFN)
60 I '$G(PRVTYP) S PRVTYP=3 I FT=3 S PRVTYP=4
61 D ALLIDS^IBCEF75(IBIFN,.IBZ,1)
62 S OK=0 I $G(ALLOWIDS)="" S OK=1
63 F I=1:1 D Q:OK
64 . S IBQ=$P($G(IBZ("PROVINF",IBIFN,"C",1,PRVTYP,I)),U,3) ; qualifier
65 . S IBSID=$P($G(IBZ("PROVINF",IBIFN,"C",1,PRVTYP,I)),U,4) ; ID#
66 . I IBQ="",IBSID="" S OK=1 Q
67 . Q:OK
68 . I $G(ALLOWIDS)[(U_IBQ_U) S OK=1,IBQ="G2" Q
69 . S (IBQ,IBSID)=""
70 S IBNPI=""
71 D F^IBCEF("N-PROVIDER NPI CODES","IBNPI",,IBIFN)
72 S IBNPI=$P(IBNPI,U,PRVTYP) ; NPI
73 ;
74 ; special check for the referring doc
75 I PRVTYP=1,$D(IBZ("PROVINF",IBIFN,"C",1,PRVTYP)),IBQ="",IBSID="" S IBQ="1G",IBSID="VAD000"
76 ;
77 ; If UB-04 and no IDs, use VA UPIN as deafult
78 I $D(IBZ("PROVINF",IBIFN,"C",1,PRVTYP)),FT=3,IBQ="",IBSID="" S IBQ="1G",IBSID="VAD000"
79 ;
80 ; determine if legacy ID's should be displayed
81 I '$$PRTLID(IBIFN,IBNPI) S (IBQ,IBSID)=""
82 ;
83 S ID=IBQ_U_IBSID_U_IBNPI
84CFIDSX ;
85 Q ID
86 ;
87DOL(AMT,LEN,DEC) ; format dollar amounts for printed claim forms
88 ; AMT = amount to be formatted
89 ; LEN = length of field - right justified to this length
90 ; DEC = flag to include the decimal point or not
91 ; DEFAULT value is to not include the decimal point
92 ; if DEC is not defined or 0, assume no decimal point
93 ; so 15 will be returned as 1500, 6.77 will be returned as 677
94 ; if DEC is 1, then the decimal point will be included
95 ;
96 S LEN=$G(LEN,10),DEC=$G(DEC,0) ; defaults
97 S AMT=$FN(+$G(AMT),"",2) ; format # with 2 decimals
98 I 'DEC S AMT=$TR(AMT,".") ; strip or leave decimal
99 S AMT=$J(AMT,LEN) ; right justify
100 Q AMT
101 ;
102PRTLID(IBIFN,NPI) ; YMG; Print Legacy IDs on the CMS-1500 or UB-04 form
103 ; Function fetches form type associated with given claim number
104 ; (values: 2 - CMS-1500 form, 3 - UB-04 form), then looks at
105 ; "Print Legacy ID" site parameter for this particular form type.
106 ;
107 ; Possible site parameter values are:
108 ; "Y" - always print Legacy ID
109 ; "N" - never print Legacy ID
110 ; "C" - only print Legacy ID if NPI is not available.
111 ;
112 ; This information is used to determine if Legacy ID should be printed
113 ; for claim number in question.
114 ;
115 ; Note: Situation when "Print Legacy ID" site parameter is not set is treated
116 ; as if this parameter was set to "Y" - always print Legacy ID.
117 ;
118 ; Input:
119 ; IBIFN - internal claim number
120 ; NPI - NPI number (or "" if no NPI is available)
121 ;
122 ; Returns:
123 ; 0 - Legacy ID should not be printed
124 ; 1 - Legacy ID should be printed
125 ;
126 Q $S(NPI="":"YC",1:"Y")[$P($G(^IBE(350.9,1,1)),U,$S($$FT^IBCEF(IBIFN)=2:32,1:33))
127 ;
128REMARK(IBIFN,IBXDATA,OFLG) ; procedure to return array of UB-04 remark text
129 ; for claim IBIFN. Data pulled from field# 402 of file 399 and
130 ; formatted into an array IBXDATA(n) where each line is not greater
131 ; than 24 characters long. This will fit into UB-04 FL-80.
132 ;
133 ; OFLG=1 only when called in the output formatter. In this case, only
134 ; 4 lines in IBXDATA will be returned.
135 ;
136 NEW TEXT,LEN,IBZ,J,PCE,CHS,NEWCHS,IBK,J,TX
137 K IBXDATA
138 S TEXT=$P($G(^DGCR(399,+$G(IBIFN),"UF2")),U,3) I TEXT="" Q
139 ;
140 ; need to break up large words for word wrapping purposes to get
141 ; as many characters as possible in the box.
142 S LEN=17
143 F PCE=1:1 Q:PCE>$L(TEXT," ") S CHS=$P(TEXT," ",PCE) I $L(CHS)>LEN D
144 . S NEWCHS=$E(CHS,1,LEN)_" "_$E(CHS,LEN+1,999)
145 . S $P(TEXT," ",PCE)=NEWCHS
146 . Q
147 ;
148 ; When calling FSTRNG^IBJU1 which calls ^DIWP, FileMan builds the
149 ; array with strings of max length=1 less than what you tell it.
150 ;
151 S LEN=20 ; line 1 is 19 chars
152 D FSTRNG^IBJU1(TEXT,LEN,.IBZ) ; build IBZ array
153 S IBK=$$TRIM^XLFSTR($G(IBZ(1))) ; save off the first line
154 S TEXT=$P(TEXT,IBK,2,99) ; restore the rest of the text
155 S TEXT=$$TRIM^XLFSTR(TEXT) ; trim spaces
156 ;
157 S LEN=25 ; the rest is 24 chars
158 D FSTRNG^IBJU1(TEXT,LEN,.IBZ) ; build IBZ array
159 S IBXDATA(1)=" "_IBK ; line 1
160 S J=0 F S J=$O(IBZ(J)) Q:'J D ; lines 2-n
161 . I J>3,$G(OFLG) Q ; only 4 lines for output formatter
162 . S TX=$$TRIM^XLFSTR($G(IBZ(J)))
163 . I TX'="" S IBXDATA(J+1)=TX
164 . Q
165 Q
166 ;
Note: See TracBrowser for help on using the repository browser.