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

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

initial load of FOIAVistA 6/30/08 version

File size: 5.9 KB
Line 
1IBCEP82 ;ALB/CLT, Special cross references and data entry for fields in file 355.93 ; 14 Apr 2006 9:41 AM
2 ;;2.0;INTEGRATED BILLING;**343,374,377**;21-MAR-94;Build 23
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 ;Routine primary entry point
15 N DTOUT,DUOUT,DIR,DIE,DIC,DR,X,Y
16 N IBIEN,IBNPI,IBCHECK,IBOLDNPI,IBRBNPI,IBRB
17 S IBIEN=DA,IBOLDNPI=""
18EN1 ;
19 K DIR
20 S DIR(0)="FO^10:10",DIR("A")="NPI",DIR("?")="Enter a 10 digit National Provider Identifier"
21 I $G(DA) S:$P($G(^IBA(355.93,DA,0)),U,14)'="" (DIR("B"),IBOLDNPI)=$P($G(^IBA(355.93,DA,0)),U,14)
22 D ^DIR S IBCHECK=0
23 I X="^" W *7,!," EXIT NOT ALLOWED ??" G EN1
24 I $E(X)="^" W *7,!," JUMPING NOT ALLOWED ??" G EN1
25 I X="@" G:IBOLDNPI'="" DEL W *7,"??" G EN1
26 I $G(DUOUT)!$G(DTOUT)!(X="")!(Y=IBOLDNPI) G XIT
27 I '$$PROC(Y,IBOLDNPI,IBIEN) G EN1
28 G XIT
29 ;
30EN2(DA,INDENT) ; entry point from input templates IB SCREEN82 and IB SCREEN8H
31 N DTOUT,DUOUT,DIR,DIE,DIC,DR,X,Y
32 N IBIEN,IBNPI,IBCHECK,IBOLDNPI,IBRBNPI,IBRB,SPACES
33 S IBIEN=DA,IBOLDNPI="",SPACES=" "
34EN21 ;
35 K DIR
36 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"
37 I $G(DA) S:$P($G(^IBA(355.93,DA,0)),U,14)'="" (DIR("B"),IBOLDNPI)=$P($G(^IBA(355.93,DA,0)),U,14)
38 D ^DIR S IBCHECK=0
39 I X="@" G:IBOLDNPI'="" DEL W *7,"??" G EN21
40 I $G(DUOUT)!$G(DTOUT)!(X="")!(Y=IBOLDNPI) G XIT
41 I '$$PROC(Y,IBOLDNPI,IBIEN) G EN21
42 G XIT
43 ;
44PROC(IBNPI,IBOLDNPI,IBIEN) ; process new NPI
45 I '$$CHKDGT^XUSNPI(IBNPI) W !,*7,$E($G(SPACES),1,+$G(INDENT))_"Not a valid NPI. Please try again.",! Q 0
46 I $$NPIUSED^IBCEP81(IBNPI) Q 0
47 S IBCHECK=1
48 I IBOLDNPI="" D ACTI
49 I IBOLDNPI'="" D:IBNPI'=IBOLDNPI INACT
50 S $P(^IBA(355.93,IBIEN,0),U,14)=IBNPI,^IBA(355.93,"NPI",IBNPI,IBIEN)="",^IBA(355.93,"NPIHISTORY",IBNPI,IBIEN)=""
51 Q 1
52 ;
53ACTI ;CREATE AN ACTIVATED ENTRY IN MULTIPLE NPISTATUS FIELD
54 S DA(1)=IBIEN,DIC="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DIC(0)="L",X=$$NOW^XLFDT()
55 S DIC("DR")=".02////^S X=1;.03////^S X=IBNPI;.04////^S X=DUZ"
56 D FILE^DICN
57 S $P(^IBA(355.93,IBIEN,0),U,14)=IBNPI
58 Q
59 ;
60DEL ;NPI HAS BEEN DELETED
61 ;If the user deletes the NPI this subroutine will determine why it was deleted and if it was because it was found
62 ;in a false identity situation will mark it in history to never be used again.
63 S IBNPI=DIR("B")
64 K DIR
65 S DIR(0)="Y"
66 S DIR("A")="Are you sure you wish to delete this NPI"
67 S DIR("?")="You have indicated you wish to delete the NPI. This is a second chance check."
68 D ^DIR
69 G:Y(0)="NO" XIT
70 S DIR(0)="S^E:ERROR;V:VALID",DIR("A")="Was this a Valid NPI or an NPI entered in Error"
71 S DIR("?",1)="An example of an NPI entered in error is if the entry person transposed numbers,"
72 S DIR("?",2)="or if the NPI for one provider is accidentally assigned to a different provider."
73 S DIR("?")="Enter an 'E' for Error or a 'V' for Valid."
74 D ^DIR
75 I Y="E" D COMP W !,"The NPI has been deleted.",!
76 I Y="V" S IBCHECK=2 D INACT W !,"The NPI is now inactive.",!
77 Q
78 ;
79COMP ;COMPLETELY DELETE THE NPI
80 ;This subroutine will delete the NPI from the file 355.93.
81 S OIEN=$O(^IBA(355.93,IBIEN,"NPISTATUS","C",IBOLDNPI,"A"),-1)
82 D DELNPI(IBIEN,OIEN)
83 K ^IBA(355.93,"NPI",IBOLDNPI,DA),^IBA(355.93,"NPIHISTORY",IBOLDNPI,DA)
84 S IBRB=0
85 D ; Find the most recent status '0' (inactive) NPI entry in the list.
86 . N IBRBLST,IBRBTMP
87 . ; Don't want to roll back to the same number you are deleting.
88 . S IBRBLST(IBOLDNPI)=""
89 . S IBRBTMP="A"
90 . ; Go through each entry in reverse order
91 . F S IBRBTMP=$O(^IBA(355.93,IBIEN,"NPISTATUS",IBRBTMP),-1) Q:'IBRBTMP D Q:IBRB'=0
92 .. S IBRBLST=^IBA(355.93,IBIEN,"NPISTATUS",IBRBTMP,0)
93 .. ; If this is an 'active' entry then ignore it.
94 .. I $P(IBRBLST,U,2)=1 Q
95 .. ; If this entry does not have an NPI then ignore it.
96 .. I $P(IBRBLST,U,3)="" Q
97 .. ;If this is an inactive entry then report it.
98 .. I $P(IBRBLST,U,2)=0 S IBRB=IBRBTMP Q
99 .. Q
100 . Q
101 I IBRB>0 D ROLLBACK
102 Q
103 ;
104DELNPI(IEN,OIEN) ;DELETE-INVALID removes NPI from file.
105 NEW DIE,DIK,DIC,DA,DR,D,D0,DI,DIC,DQ,X
106 NEW DP,DM,DK,DL,DIEL
107 S DIE="^IBA(355.93,",DA=IEN,DR="41.01////@"
108 D ^DIE
109 S DA(1)=IEN,DIK="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DA=OIEN
110 D ^DIK
111 Q
112 ;
113INACT ;INACTIVATE AN ENTRY
114 ;This subroutine makes two entries in the NPI multiple field.
115 ;One for the deactivation of the old NPI and the second
116 ;for the activation of a new NPI.
117 S DA(1)=IBIEN,DIC="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DIC(0)="L",X=$$NOW^XLFDT()
118 S DIC("DR")=".02////^S X=0;.03////^S X=IBOLDNPI;.04////^S X=DUZ"
119 D FILE^DICN
120 S ^IBA(355.93,"NPIHISTORY",IBOLDNPI,DA(1))=""
121 K ^IBA(355.93,"NPI",IBOLDNPI,DA(1))
122 S $P(^IBA(355.93,IBIEN,0),U,14)=""
123 I $G(IBCHECK)<2 D ACTI
124 S ^IBA(355.93,"NPIHISTORY",IBNPI,DA(1))=""
125 Q
126 ;
127ROLLBACK ;Rollback or delete NPI
128 S IBRBNPI=$P(^IBA(355.93,IBIEN,"NPISTATUS",IBRB,0),U,3)
129 NEW DIE,DIK,DIC,DA,DR,D,D0,DI,DIC,DQ,X
130 NEW DP,DM,DK,DL,DIEL
131 S DA(1)=IBIEN,DIK="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DA=IBRB
132 D ^DIK
133 S $P(^IBA(355.93,IBIEN,0),U,14)=IBRBNPI,^IBA(355.93,"NPI",IBRBNPI,IBIEN)=""
134 Q
135 ;
136XIT ;CLEAN AND EXIT
137 Q
138 ;
139XR ;Set the primary taxonomy code cross reference for field 42
140 N ATAX S ATAX=""
141 I $D(^IBA(355.93,DA(1),"TAXONOMY","D")) D:X=1
142 . F S ATAX=$O(^IBA(355.93,DA(1),"TAXONOMY","D",1,ATAX)) Q:ATAX="" D
143 .. K ^IBA(355.93,DA(1),"TAXONOMY","D",1,ATAX)
144 .. 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)=""
145 S ^IBA(355.93,DA(1),"TAXONOMY","D",X,DA)=""
146 Q
147 ;
148KXR ;Kill primary taxonomy code cross reference for field 42
149 N K
150 F K=0,1 K ^IBA(355.93,DA(1),"TAXONOMY","D",K,DA)
151 Q
Note: See TracBrowser for help on using the repository browser.