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

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

revised back to 6/30/08 version

File size: 7.6 KB
Line 
1IBCNSC1 ;ALB/NLR - IBCNS INSURANCE COMPANY ;23-MAR-93
2 ;;2.0;INTEGRATED BILLING;**62,137,232,291,320,348,349**;21-MAR-94;Build 46
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 I $G(IBY)'=",12," N DIE,DA,DR S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="[IBEDIT INS CO1]" D ^DIE K DIE I $D(Y) S IB("^")=1
43 I $G(IBY)=",12," D EDITID^IBCEP(+IBCNS)
44 I $F(",6,13,",$G(IBY)) D PARENT^IBCNSC02(+IBCNS) ; parent/child management
45 L -^DIC(36,+IBCNS)
46MAINQ Q
47 ;
48FACID ; -- Edit facility ids
49 D FACID^IBCEP2B(+IBCNS,"E")
50 Q
51 ;
52SORRY ; -- can't inactivate, don't have key
53 W !!,"You do not have access to Inactivate entries. See your application coordinator.",! D PAUSE^VALM1
54 Q
55PRESCR ;
56 N OFFSET,START,IBCNS18,IBADD
57 S IBCNS18=$$ADDRESS^IBCNSC0(IBCNS,.18,11)
58 S START=34,OFFSET=2
59 D SET^IBCNSP(START,OFFSET+19," Prescription Claims Office Information ",IORVON,IORVOFF)
60 D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS18,"^",7),0)),"^",1))
61 D SET^IBCNSP(START+2,OFFSET," Street: "_$P(IBCNS18,"^",1))
62 D SET^IBCNSP(START+3,OFFSET," Street 2: "_$P(IBCNS18,"^",2))
63 ; D SET^IBCNSP(START+4,OFFSET,"Claim Off. ID: "_$P(IBCNS18,"^",11))
64 N OFFSET S OFFSET=45
65 D SET^IBCNSP(START+1,OFFSET," Street 3: "_$P(IBCNS18,"^",3)) S IBADD=1
66 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))
67 D SET^IBCNSP(START+2+IBADD,OFFSET," Phone: "_$P(IBCNS18,"^",8))
68 D SET^IBCNSP(START+3+IBADD,OFFSET," Fax: "_$P(IBCNS18,"^",9))
69 Q
70 ;
71PROVID N OFFSET,START,IBCNS4,IBCNS3,IBDISP,Z,LINE
72 S START=$O(^TMP("IBCNSC",$J,""),-1)+1
73 S (IB1ST("PROVID"),LINE)=START
74 S OFFSET=2,IBCNS4=$G(^DIC(36,IBCNS,4)),IBCNS3=$G(^(3))
75 ;
76 D SET^IBCNSP(LINE,OFFSET+25,"Provider IDs",IORVON,IORVOFF)
77 N OFFSET
78 S LINE=LINE+1,OFFSET=1
79 D SET^IBCNSP(LINE,OFFSET,"Billing Provider Secondary ID")
80 ;
81 N Z,Z0,Z1,IBS,I,DIV,FT,CU,CUF,DIVISION,FORMTYPE,PIDT
82 S Z=0 F S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z D
83 . S Z0=$G(^IBA(355.92,Z,0))
84 . Q:'$P(Z0,U,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type
85 . Q:'($P(Z0,U,8)="E")
86 . S IBS(+$P(Z0,U,5),+$P(Z0,U,3),+$P(Z0,U,4))=$P(Z0,U,6)_U_$P(Z0,U,7)
87 ;
88 S DIV="" F S DIV=$O(IBS(DIV)) Q:DIV="" D
89 . S DIVISION=$$DIV^IBCEP7(DIV)
90 . S CU="",CUF=0 F S CU=$O(IBS(DIV,CU)) Q:CU="" D
91 .. S FT="" F S FT=$O(IBS(DIV,CU,FT)) Q:FT="" D
92 ... S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN")
93 ... S LINE=LINE+1
94 ... I 'CUF,+CU S CUF=1 S TEXT=$P(DIVISION,"/")_" Care Units :",OFFSET=5 D SET^IBCNSP(LINE,OFFSET,TEXT) S LINE=LINE+1
95 ... 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
96 ... 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
97 ... D SET^IBCNSP(LINE,OFFSET,TEXT)
98 ;
99 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
100 ;
101 K IBS
102 S OFFSET=1,LINE=LINE+1
103 D SET^IBCNSP(LINE,OFFSET,"Additional Billing Provider Secondary IDs")
104 S Z=0 F S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z D
105 . S Z0=$G(^IBA(355.92,Z,0))
106 . Q:'$P(Z0,U,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type
107 . Q:'($P(Z0,U,8)="A")
108 . ; IBS(DIVISION,FORMTYPE,IDTYPE)=ID
109 . S IBS(+$P(Z0,U,5),+$P(Z0,U,4),+$P(Z0,U,6))=$P(Z0,U,7)
110 ;
111 S DIVISION=$$DIV^IBCEP7(0)
112 S DIV="" F S DIV=$O(IBS(DIV)) Q:DIV="" D
113 . S FT="" F S FT=$O(IBS(DIV,FT)) Q:FT="" D
114 .. S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN")
115 .. S TEXT=DIVISION_"/"_FORMTYPE_": "
116 .. S LINE=LINE+1,OFFSET=2
117 .. D SET^IBCNSP(LINE,OFFSET,TEXT)
118 .. S PIDT="" F S PIDT=$O(IBS(DIV,FT,PIDT)) Q:PIDT="" D
119 ... S LINE=LINE+1
120 ... S TEXT=$$GET1^DIQ(355.97,PIDT,.03,"E")_" "_IBS(DIV,FT,PIDT),OFFSET=5
121 ... D SET^IBCNSP(LINE,OFFSET,TEXT)
122 ;
123 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
124 ;
125 K IBS
126 S OFFSET=1,LINE=LINE+1
127 D SET^IBCNSP(LINE,OFFSET,"VA-Laboratory or Facility Secondary IDs")
128 S Z=0 F S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z D
129 . S Z0=$G(^IBA(355.92,Z,0))
130 . Q:'$P(Z0,U,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type
131 . Q:'($P(Z0,U,8)="LF")
132 . ; IBS(DIVISION,FORMTYPE,IDTYPE)=ID
133 . S IBS(+$P(Z0,U,5),+$P(Z0,U,4),+$P(Z0,U,6))=$P(Z0,U,7)
134 ;
135 S DIVISION=$$DIV^IBCEP7(0)
136 S DIV="" F S DIV=$O(IBS(DIV)) Q:DIV="" D
137 . S FT="" F S FT=$O(IBS(DIV,FT)) Q:FT="" D
138 .. S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN")
139 .. S TEXT=DIVISION_"/"_FORMTYPE_": "
140 .. S LINE=LINE+1,OFFSET=2
141 .. D SET^IBCNSP(LINE,OFFSET,TEXT)
142 .. S PIDT="" F S PIDT=$O(IBS(DIV,FT,PIDT)) Q:PIDT="" D
143 ... S LINE=LINE+1
144 ... ;S TEXT=$$EXPAND^IBTRE(355.92,.06,PIDT)_" "_IBS(DIV,FT,PIDT),OFFSET=5
145 ... S TEXT=$$GET1^DIQ(355.97,PIDT,.03,"E")_" "_IBS(DIV,FT,PIDT),OFFSET=5
146 ... D SET^IBCNSP(LINE,OFFSET,TEXT)
147 ;
148 ;
149 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
150 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
151 S OFFSET=2
152 S LINE=LINE+1 D SET^IBCNSP(LINE,OFFSET+25,"ID Parameters",IORVON,IORVOFF)
153 ;
154 S IBCNS4=$G(^DIC(36,IBCNS,4)),IBCNS3=$G(^(3)),OFFSET=1
155 S TEXT="Attending/Rendering Provider Secondary ID Qualifier (1500): "_$$EXPAND^IBTRE(36,4.01,+$P(IBCNS4,U))
156 S LINE=LINE+1
157 D SET^IBCNSP(LINE,OFFSET,TEXT)
158 ;
159 S TEXT="Attending/Rendering Provider Secondary ID Qualifier (UB-04): "_$$EXPAND^IBTRE(36,4.02,+$P(IBCNS4,U,2))
160 S LINE=LINE+1
161 D SET^IBCNSP(LINE,OFFSET,TEXT)
162 ;
163 S TEXT="Attending/Rendering Secondary ID Requirement: "_$$EXPAND^IBTRE(36,4.03,+$P(IBCNS4,U,3))
164 S LINE=LINE+1
165 D SET^IBCNSP(LINE,OFFSET,TEXT)
166 ;
167 S TEXT="Referring Provider Secondary ID Qualifier (1500): "_$$EXPAND^IBTRE(36,4.04,+$P(IBCNS4,U,4))
168 S LINE=LINE+1
169 D SET^IBCNSP(LINE,OFFSET,TEXT)
170 ;
171 S TEXT="Referring Provider Secondary ID Requirement: "_$$EXPAND^IBTRE(36,4.05,+$P(IBCNS4,U,5))
172 S LINE=LINE+1
173 D SET^IBCNSP(LINE,OFFSET,TEXT)
174 ;
175 S TEXT="Use Att/Rend ID as Billing Provider Sec. ID (1500): "_$$EXPAND^IBTRE(36,4.06,+$P(IBCNS4,U,6))
176 S LINE=LINE+1
177 D SET^IBCNSP(LINE,OFFSET,TEXT)
178 ;
179 S TEXT="Use Att/Rend ID as Billing Provider Sec. ID (UB-04): "_$$EXPAND^IBTRE(36,4.08,+$P(IBCNS4,U,8))
180 S LINE=LINE+1
181 D SET^IBCNSP(LINE,OFFSET,TEXT)
182 ;
183 S TEXT="Send VA Lab/Facility IDs or Facility Data for VAMC?: "_$$EXPAND^IBTRE(36,4.07,+$P(IBCNS4,U,7))
184 S LINE=LINE+1
185 D SET^IBCNSP(LINE,OFFSET,TEXT)
186 ;
187 S TEXT="Transmit no Billing Provider Sec. ID for the Electronic Plan Types: "
188 S LINE=LINE+1
189 D SET^IBCNSP(LINE,OFFSET,TEXT)
190 ;
191 N TAR,ERR,IBCT
192 D LIST^DIC(36.013,","_IBCNS_",",".01",,10,,,,,,"TAR","ERR")
193 F IBCT=1:1:+$G(TAR("DILIST",0)) D
194 . S TEXT=TAR("DILIST",1,IBCT)
195 . S LINE=LINE+1
196 . D SET^IBCNSP(LINE,OFFSET,TEXT)
197 ;
198 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
199 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
200 Q
201 ;
202INSDEF(IBINS,IBPTYP) ; Returns the default id # for an ins co, if possible
203 N X
204 S X=""
205 I IBINS,IBPTYP S X=$P($G(^IBA(355.91,+$O(^IBA(355.91,"AC",IBINS,IBPTYP,"*N/A*","")),0)),U,7)
206 Q X
Note: See TracBrowser for help on using the repository browser.