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

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

initial load of WorldVistAEHR
File size: 9.2 KB
RevLine 
[613]1IBCEP82 ;ALB/CLT - Special cross references and data entry for fields in file 355.93 ;18 Apr 2008 3:46 PM
2 ;;2.0;INTEGRATED BILLING;**343,374,377,391**;21-MAR-94;Build 39
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ; Call at tags only
6 Q
7 ;This routine will ask for the NPI, check for duplicate entries, and check for proper
8 ;format using the double-add-double formula. If the NPI is being deleted it will ask
9 ;the user why it is being deleted.
10 ;If it is being deleted because of an erroneous entry it will be completely deleted.
11 ;If it is a valid NPI being deleted because of possible inappropriate usage it will be
12 ;maintained in the history cross reference to preclude anyone from using this NPI again.
13 ;
14EN(IBNPRV) ;Routine primary entry point
15 N DTOUT,DUOUT,DA,DIR,DIE,DIC,DR,X,Y,IBKEY
16 N IBIEN,IBNPI,IBCHECK,IBOLDNPI,IBRBNPI,IBRB
17 S IBOLDNPI="",IBNPI="",IBKEY="XUSNPIMTL"
18EN1 ;
19 S (DA,IBIEN)=IBNPRV
20 K DIR
21 S DIR(0)="FO^10:10",DIR("A")="NPI",DIR("?")="Enter a 10 digit National Provider Identifier"
22 I $G(DA) S:$P($G(^IBA(355.93,DA,0)),U,14)'="" (DIR("B"),IBOLDNPI,IBNPI)=$P($G(^IBA(355.93,DA,0)),U,14)
23 D ^DIR S IBCHECK=$S(Y=IBOLDNPI:2,1:0)
24 I X="^" W *7,!," EXIT NOT ALLOWED ??" G EN1
25 I $E(X)="^" W *7,!," JUMPING NOT ALLOWED ??" G EN1
26 I X="@" G:IBOLDNPI'="" DEL W *7,"??" G EN1
27 I $G(DUOUT)!$G(DTOUT) G XIT
28 I $G(IBOLDNPI)="",$G(X)="" G XIT
29 S IBNPI=$S(X="":$G(IBOLDNPI),1:X)
30 I '$$PROC(IBNPI,IBOLDNPI,IBIEN) G EN1
31 G XIT
32 ;
33EN2(IBNPRV,INDENT) ; entry point from input templates IB SCREEN82 and IB SCREEN8H
34 N DTOUT,DUOUT,DA,DIR,DIE,DIC,DR,X,Y,IBKEY
35 N IBIEN,IBNPI,IBCHECK,IBOLDNPI,IBRBNPI,IBRB,SPACES
36 S IBNPI="",IBKEY="XUSNPIMTL",IBOLDNPI="",SPACES=" "
37EN21 ;
38 S (DA,IBIEN)=IBNPRV
39 K DIR
40 S DIR(0)="FO^10:10",DIR("A")=$E(SPACES,1,INDENT)_"NPI",DIR("?")=$E(SPACES,1,INDENT)_"Enter a 10 digit National Provider Identifier"
41 I $G(DA) S:$P($G(^IBA(355.93,DA,0)),U,14)'="" (DIR("B"),IBOLDNPI,IBNPI)=$P($G(^IBA(355.93,DA,0)),U,14)
42 D ^DIR S IBCHECK=$S(Y=IBOLDNPI:2,1:0)
43 I X="@" G:IBOLDNPI'="" DEL W *7,"??" G EN21
44 I $G(DUOUT)!$G(DTOUT) G XIT
45 I $G(IBOLDNPI)="",$G(X)="" G XIT
46 S IBNPI=$S(X="":$G(IBOLDNPI),1:X)
47 I '$$PROC(IBNPI,IBOLDNPI,IBIEN) G EN21
48 G XIT
49 ;
50PROC(IBNPI,IBOLDNPI,IBIEN) ; process new NPI
51 I '$$CHKDGT^XUSNPI(IBNPI) W !,*7,$E($G(SPACES),1,+$G(INDENT))_"Not a valid NPI. Please try again.",! Q 0
52 I $$NPIUSED^IBCEP81(IBNPI,IBOLDNPI,IBIEN,IBCHECK,IBKEY)=1 Q 0
53 S IBCHECK=1
54 I IBOLDNPI="" D ACTI
55 I IBOLDNPI'="" D:IBNPI'=IBOLDNPI INACT
56 S $P(^IBA(355.93,IBIEN,0),U,14)=IBNPI,^IBA(355.93,"NPI",IBNPI,IBIEN)="",^IBA(355.93,"NPIHISTORY",IBNPI,IBIEN)=""
57 Q 1
58 ;
59ACTI ;CREATE AN ACTIVATED ENTRY IN MULTIPLE NPISTATUS FIELD
60 S DA(1)=IBIEN,DIC="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DIC(0)="L",X=$$NOW^XLFDT()
61 S DIC("DR")=".02////^S X=1;.03////^S X=IBNPI;.04////^S X=DUZ"
62 D FILE^DICN
63 S $P(^IBA(355.93,IBIEN,0),U,14)=IBNPI
64 Q
65 ;
66DEL ;NPI HAS BEEN DELETED
67 ;If the user deletes the NPI this subroutine will determine why it was deleted and, if it was because it was found
68 ;in a false identity situation, will mark it in history to never be used again.
69 S IBNPI=$G(DIR("B"))
70 K DIR
71 S DIR(0)="Y"
72 S DIR("A")="Are you sure you wish to delete this NPI"
73 S DIR("?")="You have indicated you wish to delete the NPI. This is a second chance check."
74 D ^DIR
75 G:Y(0)="NO" XIT
76 S DIR(0)="S^E:ERROR;V:VALID",DIR("A")="Was this a Valid NPI or an NPI entered in Error"
77 S DIR("?",1)="An example of an NPI entered in error is if the entry person transposed numbers,"
78 S DIR("?",2)="or if the NPI for one provider is accidentally assigned to a different provider."
79 S DIR("?")="Enter an 'E' for Error or a 'V' for Valid."
80 D ^DIR
81 I Y="E" D COMP W !,"The NPI has been deleted.",!
82 I Y="V" S IBCHECK=2 D INACT W !,"The NPI is now inactive.",!
83 Q:$D(DTOUT)!($D(DUOUT))
84 S IBOLDNPI=IBNPI D WARND(IBIEN,IBOLDNPI,IBKEY)
85 Q
86 ;
87COMP ;COMPLETELY DELETE THE NPI
88 ;This subroutine will delete the NPI from the file 355.93.
89 S OIEN=$O(^IBA(355.93,IBIEN,"NPISTATUS","C",IBOLDNPI,"A"),-1)
90 D DELNPI(IBIEN,OIEN)
91 K ^IBA(355.93,"NPI",IBOLDNPI,DA),^IBA(355.93,"NPIHISTORY",IBOLDNPI,DA)
92 S IBRB=0
93 D ; Find the most recent status '0' (inactive) NPI entry in the list.
94 . N IBRBLST,IBRBTMP
95 . ; Don't want to roll back to the same number you are deleting.
96 . S IBRBLST(IBOLDNPI)=""
97 . S IBRBTMP="A"
98 . ; Go through each entry in reverse order
99 . F S IBRBTMP=$O(^IBA(355.93,IBIEN,"NPISTATUS",IBRBTMP),-1) Q:'IBRBTMP D Q:IBRB'=0
100 .. S IBRBLST=^IBA(355.93,IBIEN,"NPISTATUS",IBRBTMP,0)
101 .. ; If this is an 'active' entry then ignore it.
102 .. I $P(IBRBLST,U,2)=1 Q
103 .. ; If this entry does not have an NPI then ignore it.
104 .. I $P(IBRBLST,U,3)="" Q
105 .. ;If this is an inactive entry then report it.
106 .. I $P(IBRBLST,U,2)=0 S IBRB=IBRBTMP Q
107 .. Q
108 . Q
109 I IBRB>0 D ROLLBACK
110 Q
111 ;
112DELNPI(IEN,OIEN) ;DELETE-INVALID removes NPI from file.
113 NEW DIE,DIK,DIC,DA,DR,D,D0,DI,DIC,DQ,X
114 NEW DP,DM,DK,DL,DIEL
115 S DIE="^IBA(355.93,",DA=IEN,DR="41.01////@"
116 D ^DIE
117 S DA(1)=IEN,DIK="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DA=OIEN
118 D ^DIK
119 Q
120 ;
121INACT ;INACTIVATE AN ENTRY
122 ;This subroutine makes two entries in the NPI multiple field:
123 ;one for the deactivation of the old NPI and the second
124 ;for the activation of a new NPI.
125 S DA(1)=IBIEN,DIC="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DIC(0)="L",X=$$NOW^XLFDT()
126 S DIC("DR")=".02////^S X=0;.03////^S X=IBOLDNPI;.04////^S X=DUZ"
127 D FILE^DICN
128 S ^IBA(355.93,"NPIHISTORY",IBOLDNPI,DA(1))=""
129 K ^IBA(355.93,"NPI",IBOLDNPI,DA(1))
130 S $P(^IBA(355.93,IBIEN,0),U,14)=""
131 I $G(IBCHECK)<2 D
132 .D ACTI
133 .S ^IBA(355.93,"NPIHISTORY",IBNPI,DA(1))=""
134 .D WARNR(IBIEN,IBOLDNPI,IBKEY)
135 Q
136 ;
137ROLLBACK ;Rollback or delete NPI
138 S IBRBNPI=$P(^IBA(355.93,IBIEN,"NPISTATUS",IBRB,0),U,3)
139 NEW DIE,DIK,DIC,DA,DR,D,D0,DI,DIC,DQ,X
140 NEW DP,DM,DK,DL,DIEL
141 S DA(1)=IBIEN,DIK="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DA=IBRB
142 D ^DIK
143 S $P(^IBA(355.93,IBIEN,0),U,14)=IBRBNPI,^IBA(355.93,"NPI",IBRBNPI,IBIEN)=""
144 Q
145 ;
146XIT ;CLEAN AND EXIT
147 Q
148 ;
149XR ;Set the primary taxonomy code cross reference for field 42
150 N ATAX S ATAX=""
151 I $D(^IBA(355.93,DA(1),"TAXONOMY","D")) D:X=1
152 . F S ATAX=$O(^IBA(355.93,DA(1),"TAXONOMY","D",1,ATAX)) Q:ATAX="" D
153 .. K ^IBA(355.93,DA(1),"TAXONOMY","D",1,ATAX)
154 .. I ATAX'=DA S $P(^IBA(355.93,DA(1),"TAXONOMY",ATAX,0),U,2)=0,^IBA(355.93,DA(1),"TAXONOMY","D",0,ATAX)=""
155 S ^IBA(355.93,DA(1),"TAXONOMY","D",X,DA)=""
156 Q
157 ;
158KXR ;Kill primary taxonomy code cross reference for field 42
159 N K
160 F K=0,1 K ^IBA(355.93,DA(1),"TAXONOMY","D",K,DA)
161 Q
162 ;
163WARNR(IBIEN,IBOLDNPI,IBKEY) ;Warn user that the old NPI that was replaced is currently used by an entry in the New Person file (#200)
164 N IBIEN200
165 Q:$G(IBOLDNPI)=""
166 S IBIEN200=$O(^VA(200,"ANPI",IBOLDNPI,""))
167 Q:IBIEN200=""
168 W !!,"WARNING: NPI ",IBOLDNPI," is also associated with Provider ",$$GET1^DIQ(200,IBIEN200,.01),".",!
169 I $O(^XUSEC(IBKEY,""))="" W !!,"There are no holders of the ",IBKEY," security key on the VistA system. Contact your IRM department for further direction." Q
170 W !,"A MailMan message has been sent to holders of the "_""""_IBKEY_""""_" security key."
171 D MAILR(IBIEN,IBKEY,IBIEN200,IBOLDNPI)
172 Q
173 ;
174WARND(IBIEN,IBOLDNPI,IBKEY) ;Warn user that the old NPI that was deleted is currently used by an entry in the New Person file (#200)
175 N IBIEN200
176 Q:$G(IBOLDNPI)=""
177 S IBIEN200=$O(^VA(200,"ANPI",IBOLDNPI,""))
178 Q:IBIEN200=""
179 W !!,"WARNING: NPI ",IBOLDNPI," is also associated with VA Provider ",$$GET1^DIQ(200,IBIEN200,.01),".",!
180 I $O(^XUSEC(IBKEY,""))="" W !!,"There are no holders of the ",IBKEY," security key on the VistA system. Contact your IRM department for further direction." Q
181 W !,"A MailMan message has been sent to holders of the "_""""_IBKEY_""""_" security key."
182 D MAILD(IBIEN,IBKEY,IBIEN200,IBOLDNPI)
183 Q
184 ;
185MAILR(IBIEN,IBKEY,IBIEN200,IBOLDNPI) ;Send mailman message for replacement of NPI
186 ;This subroutine is supported by IA# 10070
187 ;Lookups in NEW PERSON file (#200) are supported by IA#10076
188 N IBIEN2,XMDUZ,XMSUB,XMTEXT,XMY,IBMSG,XMZ,XMMG
189 S IBIEN2=0 F S IBIEN2=$O(^XUSEC(IBKEY,IBIEN2)) Q:IBIEN2="" S XMY(IBIEN2)=""
190 S XMDUZ=$S($G(DUZ):DUZ,1:.5),XMSUB="NPI Replacement"
191 S IBMSG(1)="The NPI "_IBOLDNPI_" was changed to "_IBNPI_" for"
192 S IBMSG(2)=$$GET1^DIQ(355.93,IBIEN,.01)_" in the IB NON/OTHER VA BILLING PROVIDER"
193 S IBMSG(3)="file. The NPI "_IBOLDNPI_" is also associated with"
194 S IBMSG(4)=$$GET1^DIQ(200,IBIEN200,.01)_" in the NEW PERSON file."
195 S IBMSG(5)=""
196 S IBMSG(6)="The same change may need to be made to the NEW PERSON file using the"
197 S IBMSG(7)="Add/Edit NPI values for Providers option."
198 S XMTEXT="IBMSG(" D ^XMD
199 Q
200 ;
201MAILD(IBIEN,IBKEY,IBIEN200,IBOLDNPI) ;Send mailman message for deletion of an NPI
202 ;This subroutine is supported by IA# 10070
203 ;Lookups in NEW PERSON file (#200) are supported by IA#10076
204 N IBIEN2,XMDUZ,XMSUB,XMTEXT,XMY,IBMSG,XMZ,XMMG
205 S IBIEN2=0 F S IBIEN2=$O(^XUSEC(IBKEY,IBIEN2)) Q:IBIEN2="" S XMY(IBIEN2)=""
206 S XMDUZ=$S($G(DUZ):DUZ,1:.5),XMSUB="NPI Deletion"
207 S IBMSG(1)="The NPI "_IBOLDNPI_" was deleted for "_$$GET1^DIQ(355.93,IBIEN,.01)
208 S IBMSG(2)="in the IB NON/OTHER VA BILLING PROVIDER file. The NPI "_IBOLDNPI_" is also"
209 S IBMSG(3)="associated with "_$$GET1^DIQ(200,IBIEN200,.01)_" in the NEW PERSON file."
210 S IBMSG(4)=""
211 S IBMSG(5)="The same change may need to be made to the NEW PERSON file using the"
212 S IBMSG(6)="Add/Edit NPI values for Providers option."
213 S XMTEXT="IBMSG(" D ^XMD
214 Q
Note: See TracBrowser for help on using the repository browser.