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

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

initial load of WorldVistAEHR

File size: 5.9 KB
Line 
1IBCEPCID ;ALB/WCJ - Provider ID functions ;13 Feb 2006
2 ;;2.0;INTEGRATED BILLING;**320**;21-MAR-94
3 ;; Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 G AWAY
6AWAY Q
7 ;
8COPY(IBINS) ; The purpose of this routine is to sync up insurance company IDs
9 ; It is passed an insurance company. If the insurance company is a stand alone company,
10 ; it quits. If it is passed a child, it synchs up with the parent. If it is passed a parent, it syncs
11 ; up with all it's children.
12 ;
13 ; The IDs that synched up are Provider ID's defined for providers by an insurance company, default IDs for all
14 ; Providers for and an insurance company, and additonal billing providers IDs for an insuracne company.
15 ;
16 ;
17 N TYPE,PARENT,CHILD,COPYINS
18 Q:$G(IBINS)=""
19 S TYPE=$$TYPE(IBINS)
20 Q:TYPE=""
21 I TYPE="P" S PARENT=IBINS,CHILD=""
22 I TYPE="C" S CHILD=IBINS,PARENT=$P($G(^DIC(36,IBINS,3)),U,14) Q:PARENT=""
23 D COPYTO(PARENT,CHILD,.COPYINS)
24 D LOOPTRNS(.COPYINS)
25 Q
26 ;
27TYPE(IBINS) ;
28 Q $P($G(^DIC(36,+IBINS,3)),U,13)
29 ;
30COPYTO(PARENT,CHILD,COPYINS) ; Figure out who to copy to:
31 I CHILD]"" S COPYINS(PARENT,CHILD)="" Q
32 F S CHILD=$O(^DIC(36,"APC",PARENT,CHILD)) Q:'CHILD S COPYINS(PARENT,CHILD)=""
33 Q
34 ;
35LOOPTRNS(COPYINS) ;
36 N PARENT,CHILD,IBFILE
37 S PARENT=$O(COPYINS(""))
38 Q:PARENT="" ; just in case
39 ;
40 S CHILD="" F S CHILD=$O(COPYINS(PARENT,CHILD)) Q:CHILD="" D
41 .F IBFILE=355.9,355.91,355.92 D
42 .. I IBFILE=355.9 D Q
43 ... N IBPRV,CU,FT,CT,QUAL,CDA,PDA
44 ... ;
45 ... ; File 355.9
46 ... ; Delete IDs in child but not parent
47 ... ; Edit IDs that are in both
48 ... S IBPRV="" F S IBPRV=$O(^IBA(IBFILE,"AUNIQ",IBPRV)) Q:IBPRV="" D
49 .... Q:IBPRV'[";VA(200," ; only copying VA providers
50 .... Q:'$D(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD))
51 .... S CU="" F S CU=$O(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD,CU)) Q:CU="" D
52 ..... S FT="" F S FT=$O(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD,CU,FT)) Q:FT="" D
53 ...... S CT="" F S CT=$O(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD,CU,FT,CT)) Q:CT="" D
54 ....... S QUAL="" F S QUAL=$O(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD,CU,FT,CT,QUAL)) Q:QUAL="" D
55 ........ S CDA=$O(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD,CU,FT,CT,QUAL,0))
56 ........ Q:'CDA
57 ........ I '$D(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU,FT,CT,QUAL)) D DEL(IBFILE,CDA) Q
58 ........ S PDA=$O(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU,FT,CT,QUAL,0))
59 ........ Q:PDA=""
60 ........ D MOD(IBFILE,CDA,PDA) Q
61 ... ;
62 ... ; File 355.9
63 ... ; Add IDs in parent but not child
64 ... S IBPRV="" F S IBPRV=$O(^IBA(IBFILE,"AUNIQ",IBPRV)) Q:IBPRV="" D
65 .... Q:IBPRV'[";VA(200," ; only copying VA providers
66 .... Q:'$D(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT))
67 .... S CU="" F S CU=$O(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU)) Q:CU="" D
68 ..... S FT="" F S FT=$O(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU,FT)) Q:FT="" D
69 ...... S CT="" F S CT=$O(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU,FT,CT)) Q:CT="" D
70 ....... S QUAL="" F S QUAL=$O(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU,FT,CT,QUAL)) Q:QUAL="" D
71 ........ S PDA=$O(^IBA(IBFILE,"AUNIQ",IBPRV,PARENT,CU,FT,CT,QUAL,0))
72 ........ Q:'PDA
73 ........ I '$D(^IBA(IBFILE,"AUNIQ",IBPRV,CHILD,CU,FT,CT,QUAL)) D ADD(IBFILE,PDA,CHILD) Q
74 .. ;
75 .. ; Files 355.91 and 355.92
76 .. ; Delete IDs in Child but not parent
77 .. ; Edit IDs that are in both
78 .. I $D(^IBA(IBFILE,"AUNIQ",CHILD)) D
79 ... N CU,FT,CTORD,QUAL,PDA,CDA,DELFL
80 ... S CU="" F S CU=$O(^IBA(IBFILE,"AUNIQ",CHILD,CU)) Q:CU="" D
81 .... S FT="" F S FT=$O(^IBA(IBFILE,"AUNIQ",CHILD,CU,FT)) Q:FT="" D
82 ..... S CTORD="" F S CTORD=$O(^IBA(IBFILE,"AUNIQ",CHILD,CU,FT,CTORD)) Q:CTORD="" D
83 ...... S QUAL="" F S QUAL=$O(^IBA(IBFILE,"AUNIQ",CHILD,CU,FT,CTORD,QUAL)) Q:QUAL="" D
84 ....... S CDA="" F S CDA=$O(^IBA(IBFILE,"AUNIQ",CHILD,CU,FT,CTORD,QUAL,CDA)) Q:CDA="" D
85 ........ S PDA=$O(^IBA(IBFILE,"AUNIQ",PARENT,CU,FT,CTORD,QUAL,0))
86 ........ S DELFL=1
87 ........ I PDA,IBFILE=355.91,$D(^IBA(IBFILE,"AUNIQ",PARENT,CU,FT,CTORD,QUAL)) S DELFL=0
88 ........ I PDA,IBFILE=355.92 S DELFL=0
89 ........ D:DELFL DEL(IBFILE,CDA)
90 ........ D:'DELFL MOD(IBFILE,CDA,PDA)
91 .. ;
92 .. ; Files 355.91 and 355.92
93 .. ; Add IDs that are in parent but not child
94 .. I $D(^IBA(IBFILE,"AUNIQ",PARENT)) D
95 ... N CU,FT,CTORD,QUAL,PDA
96 ... S CU="" F S CU=$O(^IBA(IBFILE,"AUNIQ",PARENT,CU)) Q:CU="" D
97 .... S FT="" F S FT=$O(^IBA(IBFILE,"AUNIQ",PARENT,CU,FT)) Q:FT="" D
98 ..... S CTORD="" F S CTORD=$O(^IBA(IBFILE,"AUNIQ",PARENT,CU,FT,CTORD)) Q:CTORD="" D
99 ...... S QUAL="" F S QUAL=$O(^IBA(IBFILE,"AUNIQ",PARENT,CU,FT,CTORD,QUAL)) Q:QUAL="" D
100 ....... S PDA="" F S PDA=$O(^IBA(IBFILE,"AUNIQ",PARENT,CU,FT,CTORD,QUAL,PDA)) Q:PDA="" D
101 ........ Q:$O(^IBA(IBFILE,"AUNIQ",CHILD,CU,FT,CTORD,QUAL,0))
102 ........ D ADD(IBFILE,PDA,CHILD) Q
103 Q
104 ;
105ADD(IBFILE,IEN,INS) ; Add a provider ID
106 N DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,DTOUT,DUOUT
107 N ZERO,CU,FT,CTORD,QUAL,ID
108 S ZERO=$G(^IBA(IBFILE,IEN,0))
109 Q:ZERO=""
110 S CU=$P(ZERO,U,3)
111 S FT=$P(ZERO,U,4)
112 S CTORD=$P(ZERO,U,5)
113 S QUAL=$P(ZERO,U,6)
114 S ID=$P(ZERO,U,7)
115 ;
116 I IBFILE=355.91!(IBFILE=355.92) D
117 . S X=INS
118 . S DIC("DR")=".03////"_CU_";.04////"_FT_";.05////"_CTORD_";.06////"_QUAL_";.07////"_ID
119 . I IBFILE=355.92 S DIC("DR")=DIC("DR")_";.08////A"
120 ;
121 I IBFILE=355.9 D
122 . S DIC("DR")=".02////"_INS_";.03////"_CU_";.04////"_FT_";.05////"_CTORD_";.06////"_QUAL_";.07////"_ID
123 . S X=$P(ZERO,U)
124 ;
125 S DIC(0)="L",(DIC,DLAYGO)=IBFILE
126 D FILE^DICN
127 Q
128 ;
129DEL(IBFILE,DA) ; Delete a Provider ID
130 N DIK,DIR,X,Y,Z,I
131 S DIK="^IBA("_IBFILE_","
132 F I=1:1 L +^IBA(IBFILE,DA):5 I Q
133 D ^DIK
134 L -^IBA(IBFILE,DA)
135 Q
136 ;
137MOD(IBFILE,IEN,PIEN) ; Modify an existing Provider ID
138 N I,ZERO,ID,PID,PZERO,FDAROOT
139 S ZERO=$G(^IBA(IBFILE,IEN,0))
140 Q:ZERO=""
141 S PZERO=$G(^IBA(IBFILE,PIEN,0))
142 Q:PZERO=""
143 S ID=$P(ZERO,U,7)
144 S PID=$P(PZERO,U,7)
145 Q:ID=PID
146 S FDAROOT(IBFILE,IEN_",",.07)=PID
147 F I=1:1 L +^IBA(IBFILE,IEN):5 I Q
148 D FILE^DIE(,"FDAROOT")
149 L -^IBA(IBFILE,IEN)
150 Q
151 ;
152RESYNCH() ; Resynch everything
153 L +^DIC(36):5 E W *7,!!,"Can not lock insurance company file, please try later.",!! Q
154 N INS
155 S INS="" F S INS=$O(^DIC(36,"APC",INS)) Q:INS="" D COPY(INS)
156 L -^DIC(36)
157 Q
Note: See TracBrowser for help on using the repository browser.