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

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

initial load of FOIAVistA 6/30/08 version
File size: 8.7 KB
Line 
1IBCNSC1 ;ALB/NLR - IBCNS INSURANCE COMPANY ;23-MAR-93
2 ;;2.0;INTEGRATED BILLING;**62,137,232,291,320,348,349,371**;21-MAR-94;Build 57
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5% G EN^IBCNSC
6 ;
7AI ; -- (In)Activate Company
8 D FULL^VALM1 W !!
9 I '$D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)) D SORRY G EXIT
10 D ^IBCNSC2
11 G EXIT
12CC ; -- Change Insurance Company
13 D FULL^VALM1 W !!
14 S IBCNS1=IBCNS K IBCNS D INSCO^IBCNSC
15 I '$D(IBCNS) S IBCNS=IBCNS1
16 K IBCNS1,VALMQUIT
17 G EXIT
18EA ; -- Billing,Claims,Appeals,Inquiry,Telephone,Main,Remarks,Synonyms
19 D FULL^VALM1
20 ;
21 ; IB*2*320 - check key for associate company action
22 I $G(IBY)=",13,",'$$KCHK^XUSRB("IB EDI INSURANCE EDIT") D G EXIT
23 . W !!?5,"You must hold the IB EDI INSURANCE EDIT key to access this option."
24 . D PAUSE^VALM1
25 . Q
26 ;
27 W !!
28 D MAIN
29 ;
30 ; -- was company deleted
31 I '$D(^DIC(36,IBCNS)) W !!,"<DELETED>",!! S VALMQUIT="" Q
32 ;
33EXIT ;
34 D HDR^IBCNSC,BLD^IBCNSC
35 S VALMBCK="R"
36 Q
37MAIN ; -- Call edit template
38 N IBEDIKEY,Z
39 L +^DIC(36,+IBCNS):5 I '$T D LOCKED^IBTRCD1 G MAINQ
40 I $G(IBY)=",12," D FACID
41 F Z=1,2,4,9,13,14 S IBEDIKEY(Z)=$P($G(^DIC(36,+IBCNS,3)),U,Z) ; save EDI data fields
42 F Z=1:1:8 S IBEDIKEY(Z,6)=$P($G(^DIC(36,+IBCNS,6)),U,Z) ; save EDI data fields
43 I $G(IBY)'=",12," N DIE,DA,DR S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="[IBEDIT INS CO1]" D ^DIE K DIE S:$D(Y) IB("^")=1 D:$TR($P($G(^DIC(36,IBCNS,6)),U,1,8),U)]"" CUIDS(IBCNS)
44 I $G(IBY)=",12," D EDITID^IBCEP(+IBCNS)
45 I $F(",6,13,",$G(IBY)) D PARENT^IBCNSC02(+IBCNS) ; parent/child management
46 L -^DIC(36,+IBCNS)
47MAINQ Q
48 ;
49FACID ; -- Edit facility ids
50 D FACID^IBCEP2B(+IBCNS,"E")
51 Q
52 ;
53SORRY ; -- can't inactivate, don't have key
54 W !!,"You do not have access to Inactivate entries. See your application coordinator.",! D PAUSE^VALM1
55 Q
56PRESCR ;
57 N OFFSET,START,IBCNS18,IBADD
58 S IBCNS18=$$ADDRESS^IBCNSC0(IBCNS,.18,11)
59 S START=41,OFFSET=2
60 D SET^IBCNSP(START,OFFSET+19," Prescription Claims Office Information ",IORVON,IORVOFF)
61 D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS18,"^",7),0)),"^",1))
62 D SET^IBCNSP(START+2,OFFSET," Street: "_$P(IBCNS18,"^",1))
63 D SET^IBCNSP(START+3,OFFSET," Street 2: "_$P(IBCNS18,"^",2))
64 ; D SET^IBCNSP(START+4,OFFSET,"Claim Off. ID: "_$P(IBCNS18,"^",11))
65 N OFFSET S OFFSET=45
66 D SET^IBCNSP(START+1,OFFSET," Street 3: "_$P(IBCNS18,"^",3)) S IBADD=1
67 D SET^IBCNSP(START+1+IBADD,OFFSET," City/State: "_$E($P(IBCNS18,"^",4),1,15)_$S($P(IBCNS18,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCNS18,"^",5),0)),"^",2)_" "_$E($P(IBCNS18,"^",6),1,5))
68 D SET^IBCNSP(START+2+IBADD,OFFSET," Phone: "_$P(IBCNS18,"^",8))
69 D SET^IBCNSP(START+3+IBADD,OFFSET," Fax: "_$P(IBCNS18,"^",9))
70 Q
71 ;
72PROVID N OFFSET,START,IBCNS4,IBCNS3,IBDISP,Z,LINE
73 S START=$O(^TMP("IBCNSC",$J,""),-1)+1
74 S (IB1ST("PROVID"),LINE)=START
75 S OFFSET=2,IBCNS4=$G(^DIC(36,IBCNS,4)),IBCNS3=$G(^(3))
76 ;
77 D SET^IBCNSP(LINE,OFFSET+25,"Provider IDs",IORVON,IORVOFF)
78 N OFFSET
79 S LINE=LINE+1,OFFSET=1
80 D SET^IBCNSP(LINE,OFFSET,"Billing Provider Secondary ID")
81 ;
82 N Z,Z0,Z1,IBS,I,DIV,FT,CU,CUF,DIVISION,FORMTYPE,PIDT
83 S Z=0 F S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z D
84 . S Z0=$G(^IBA(355.92,Z,0))
85 . Q:'$P(Z0,U,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type
86 . Q:'($P(Z0,U,8)="E")
87 . S IBS(+$P(Z0,U,5),+$P(Z0,U,3),+$P(Z0,U,4))=$P(Z0,U,6)_U_$P(Z0,U,7)
88 ;
89 S DIV="" F S DIV=$O(IBS(DIV)) Q:DIV="" D
90 . S DIVISION=$$DIV^IBCEP7(DIV)
91 . S CU="",CUF=0 F S CU=$O(IBS(DIV,CU)) Q:CU="" D
92 .. S FT="" F S FT=$O(IBS(DIV,CU,FT)) Q:FT="" D
93 ... S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN")
94 ... S LINE=LINE+1
95 ... I 'CUF,+CU S CUF=1 S TEXT=$P(DIVISION,"/")_" Care Units :",OFFSET=5 D SET^IBCNSP(LINE,OFFSET,TEXT) S LINE=LINE+1
96 ... I CU=0 S TEXT=DIVISION_"/"_FORMTYPE_": "_$$GET1^DIQ(355.97,$P(IBS(DIV,CU,FT),U),.03,"E")_" "_$P(IBS(DIV,CU,FT),U,2),OFFSET=2
97 ... I +CU S TEXT=$$EXPAND^IBTRE(355.92,.03,CU)_"/"_FORMTYPE_": "_$$GET1^DIQ(355.97,$P(IBS(DIV,CU,FT),U),.03,"E")_" "_$P(IBS(DIV,CU,FT),U,2),OFFSET=5
98 ... D SET^IBCNSP(LINE,OFFSET,TEXT)
99 ;
100 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
101 ;
102 K IBS
103 S OFFSET=1,LINE=LINE+1
104 D SET^IBCNSP(LINE,OFFSET,"Additional Billing Provider Secondary IDs")
105 S Z=0 F S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z D
106 . S Z0=$G(^IBA(355.92,Z,0))
107 . Q:'$P(Z0,U,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type
108 . Q:'($P(Z0,U,8)="A")
109 . ; IBS(DIVISION,FORMTYPE,IDTYPE)=ID
110 . S IBS(+$P(Z0,U,5),+$P(Z0,U,4),+$P(Z0,U,6))=$P(Z0,U,7)
111 ;
112 S DIVISION=$$DIV^IBCEP7(0)
113 S DIV="" F S DIV=$O(IBS(DIV)) Q:DIV="" D
114 . S FT="" F S FT=$O(IBS(DIV,FT)) Q:FT="" D
115 .. S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN")
116 .. S TEXT=DIVISION_"/"_FORMTYPE_": "
117 .. S LINE=LINE+1,OFFSET=2
118 .. D SET^IBCNSP(LINE,OFFSET,TEXT)
119 .. S PIDT="" F S PIDT=$O(IBS(DIV,FT,PIDT)) Q:PIDT="" D
120 ... S LINE=LINE+1
121 ... S TEXT=$$GET1^DIQ(355.97,PIDT,.03,"E")_" "_IBS(DIV,FT,PIDT),OFFSET=5
122 ... D SET^IBCNSP(LINE,OFFSET,TEXT)
123 ;
124 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
125 ;
126 K IBS
127 S OFFSET=1,LINE=LINE+1
128 D SET^IBCNSP(LINE,OFFSET,"VA-Laboratory or Facility Secondary IDs")
129 S Z=0 F S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z D
130 . S Z0=$G(^IBA(355.92,Z,0))
131 . Q:'$P(Z0,U,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type
132 . Q:'($P(Z0,U,8)="LF")
133 . ; IBS(DIVISION,FORMTYPE,IDTYPE)=ID
134 . S IBS(+$P(Z0,U,5),+$P(Z0,U,4),+$P(Z0,U,6))=$P(Z0,U,7)
135 ;
136 S DIVISION=$$DIV^IBCEP7(0)
137 S DIV="" F S DIV=$O(IBS(DIV)) Q:DIV="" D
138 . S FT="" F S FT=$O(IBS(DIV,FT)) Q:FT="" D
139 .. S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN")
140 .. S TEXT=DIVISION_"/"_FORMTYPE_": "
141 .. S LINE=LINE+1,OFFSET=2
142 .. D SET^IBCNSP(LINE,OFFSET,TEXT)
143 .. S PIDT="" F S PIDT=$O(IBS(DIV,FT,PIDT)) Q:PIDT="" D
144 ... S LINE=LINE+1
145 ... ;S TEXT=$$EXPAND^IBTRE(355.92,.06,PIDT)_" "_IBS(DIV,FT,PIDT),OFFSET=5
146 ... S TEXT=$$GET1^DIQ(355.97,PIDT,.03,"E")_" "_IBS(DIV,FT,PIDT),OFFSET=5
147 ... D SET^IBCNSP(LINE,OFFSET,TEXT)
148 ;
149 ;
150 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
151 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
152 S OFFSET=2
153 S LINE=LINE+1 D SET^IBCNSP(LINE,OFFSET+25,"ID Parameters",IORVON,IORVOFF)
154 ;
155 S IBCNS4=$G(^DIC(36,IBCNS,4)),IBCNS3=$G(^(3)),OFFSET=1
156 S TEXT="Attending/Rendering Provider Secondary ID Qualifier (1500): "_$$EXPAND^IBTRE(36,4.01,+$P(IBCNS4,U))
157 S LINE=LINE+1
158 D SET^IBCNSP(LINE,OFFSET,TEXT)
159 ;
160 S TEXT="Attending/Rendering Provider Secondary ID Qualifier (UB-04): "_$$EXPAND^IBTRE(36,4.02,+$P(IBCNS4,U,2))
161 S LINE=LINE+1
162 D SET^IBCNSP(LINE,OFFSET,TEXT)
163 ;
164 S TEXT="Attending/Rendering Secondary ID Requirement: "_$$EXPAND^IBTRE(36,4.03,+$P(IBCNS4,U,3))
165 S LINE=LINE+1
166 D SET^IBCNSP(LINE,OFFSET,TEXT)
167 ;
168 S TEXT="Referring Provider Secondary ID Qualifier (1500): "_$$EXPAND^IBTRE(36,4.04,+$P(IBCNS4,U,4))
169 S LINE=LINE+1
170 D SET^IBCNSP(LINE,OFFSET,TEXT)
171 ;
172 S TEXT="Referring Provider Secondary ID Requirement: "_$$EXPAND^IBTRE(36,4.05,+$P(IBCNS4,U,5))
173 S LINE=LINE+1
174 D SET^IBCNSP(LINE,OFFSET,TEXT)
175 ;
176 S TEXT="Use Att/Rend ID as Billing Provider Sec. ID (1500): "_$$EXPAND^IBTRE(36,4.06,+$P(IBCNS4,U,6))
177 S LINE=LINE+1
178 D SET^IBCNSP(LINE,OFFSET,TEXT)
179 ;
180 S TEXT="Use Att/Rend ID as Billing Provider Sec. ID (UB-04): "_$$EXPAND^IBTRE(36,4.08,+$P(IBCNS4,U,8))
181 S LINE=LINE+1
182 D SET^IBCNSP(LINE,OFFSET,TEXT)
183 ;
184 S TEXT="Send VA Lab/Facility IDs or Facility Data for VAMC?: "_$$EXPAND^IBTRE(36,4.07,+$P(IBCNS4,U,7))
185 S LINE=LINE+1
186 D SET^IBCNSP(LINE,OFFSET,TEXT)
187 ;
188 S TEXT="Transmit no Billing Provider Sec. ID for the Electronic Plan Types: "
189 S LINE=LINE+1
190 D SET^IBCNSP(LINE,OFFSET,TEXT)
191 ;
192 N TAR,ERR,IBCT
193 D LIST^DIC(36.013,","_IBCNS_",",".01",,10,,,,,,"TAR","ERR")
194 F IBCT=1:1:+$G(TAR("DILIST",0)) D
195 . S TEXT=TAR("DILIST",1,IBCT)
196 . S LINE=LINE+1
197 . D SET^IBCNSP(LINE,OFFSET,TEXT)
198 ;
199 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
200 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
201 Q
202 ;
203INSDEF(IBINS,IBPTYP) ; Returns the default id # for an ins co, if possible
204 N X
205 S X=""
206 I IBINS,IBPTYP S X=$P($G(^IBA(355.91,+$O(^IBA(355.91,"AC",IBINS,IBPTYP,"*N/A*","")),0)),U,7)
207 Q X
208 ;
209CUIDS(IBCNS) ;
210 N DIE,DA,DR,PIECE,DAT6,Y
211 S DAT6=$P(^DIC(36,IBCNS,6),U,1,8) ; get the Payer IDs
212 ;
213 ; Make sure each qualifier has an ID and vice versa
214 F PIECE=1,3,5,7 D
215 . I $TR($P(DAT6,U,PIECE,PIECE+1),U)="" Q ; both blank
216 . I $P(DAT6,U,PIECE)]"",$P(DAT6,U,PIECE+1)]"" Q ; both have data
217 . S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="6.0"_$S($P(DAT6,U,PIECE)]"":PIECE,1:PIECE+1)_"////@"
218 . D ^DIE K DIE
219 ;
220 S DAT6=$P($G(^DIC(36,IBCNS,6)),U,1,8) ; get the Payer IDs again since they may have changed above.
221 ;
222 ; Make sure the first pair of ID/Qual are populated if the 2nd pair is. If not, move em over.
223 ; This is done for institutional then professional
224 F PIECE=1,5 D
225 . I $P(DAT6,U,PIECE)]"" Q ; already has set one
226 . I $P(DAT6,U,PIECE+2)="" Q ; has no second set
227 . S DIE="^DIC(36,",(DA,Y)=IBCNS
228 . ; deleting the qualifier triggers deletion of the ID
229 . S DR="6.0"_PIECE_"////"_$P(DAT6,U,PIECE+2)_";6.0"_(PIECE+1)_"////"_$P(DAT6,U,PIECE+3)_";6.0"_(PIECE+2)_"////@"
230 . D ^DIE K DIE
231 Q
Note: See TracBrowser for help on using the repository browser.