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

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

initial load of FOIAVistA 6/30/08 version

File size: 5.9 KB
Line 
1IBCNEUT6 ;DAOU/ESG - IIV MISC. UTILITIES ;14-AUG-2002
2 ;;2.0;INTEGRATED BILLING;**184,252,271**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; Can't be called from the top
6 Q
7 ;
8AMCHECK ; This procedure will examine the insurance company names in the
9 ; Auto Match file (#365.11) to make sure there is still at least
10 ; one active insurance company with that name. If there isn't,
11 ; then the Auto Match entries for that insurance company name
12 ; will be deleted.
13 ;
14 NEW NAME,INSIEN,FOUNDACT,DA,DIK,DIC,X,Y,%
15 S NAME=""
16 F S NAME=$O(^IBCN(365.11,"C",NAME)) Q:NAME="" D
17 . ;
18 . ; For this Auto Match ins co name, see if there is an active ins co
19 . S INSIEN=0,FOUNDACT=0
20 . F S INSIEN=$O(^DIC(36,"B",NAME,INSIEN)) Q:'INSIEN I $$ACTIVE^IBCNEUT4(INSIEN) S FOUNDACT=1 Q
21 . ;
22 . ; If an active ins co was found, then we're OK so quit
23 . I FOUNDACT Q
24 . ;
25 . ; Otherwise, we need to delete all Auto Match entries for this name
26 . S DA=0,DIK="^IBCN(365.11,"
27 . F S DA=$O(^IBCN(365.11,"C",NAME,DA)) Q:'DA D ^DIK
28 . Q
29AMCHKX ;
30 Q
31 ;
32 ;
33AMADD(INSNAME,IBCNEXT1) ; Conditionally add an Auto Match entry based on user input
34 ; Input Parameters:
35 ; INSNAME is a valid, active insurance company name
36 ; IBCNEXT1 is the existing entry in the ins co name field in the
37 ; buffer. This may be used as the Auto Match value for
38 ; a new auto match entry.
39 ;
40 NEW AMDATA,AMIEN,AMERROR
41 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
42 NEW D,D0,D1,DA,DB,DC,DDH,DE,DG,DH,DI,DIC,DIE,DIEL,DIFLD,DIG,DIH
43 NEW DIK,DILN,DIPA,DISYS,DIV,DK,DL,DM,DN,DOV,DP,DQ,DR,DU,DV,DZ
44 ;
45 ; First, check security key to see if user is allowed to do this
46 I '$$KCHK^XUSRB("IBCNE IIV AUTO MATCH") G AMADDX
47 ;
48 S IBCNEXT1=$$UP^XLFSTR(IBCNEXT1) ; all uppercase
49 S IBCNEXT1=$$TRIM^XLFSTR(IBCNEXT1) ; lead/trail spaces
50 I IBCNEXT1="" G AMADDX ; must exist
51 I $L(IBCNEXT1)>30!($L(IBCNEXT1)<3) G AMADDX ; too long or too short
52 I IBCNEXT1=INSNAME G AMADDX ; cannot equal the name
53 I $D(^IBCN(365.11,"B",IBCNEXT1)) G AMADDX ; already in Auto Match
54 I $D(^DIC(36,"B",IBCNEXT1)) G AMADDX ; already an ins co name
55 I $D(^DIC(36,"C",IBCNEXT1)) G AMADDX ; already a synonym
56 I IBCNEXT1["*" G AMADDX ; no wildcards allowed
57 ;
58 S DIR(0)="YO"
59 S DIR("A",1)=" "
60 S DIR("A",2)="Do you want to add an Auto Match entry that associates"
61 S DIR("A")=IBCNEXT1_" with "_INSNAME
62 S DIR("B")="No"
63 S DIR("?",1)=" The Auto Match Value is "_IBCNEXT1_"."
64 S DIR("?",2)="The Insurance Company Name is "_INSNAME_"."
65 S DIR("?",3)=" "
66 S DIR("?",4)="Please enter NO if you do not want to associate these two values together"
67 S DIR("?",5)="in the Auto Match file."
68 S DIR("?",6)=" "
69 S DIR("?",7)="Please enter YES if you do want to create an Auto Match entry for these"
70 S DIR("?",8)="two values. If you enter YES, then you will have the chance to modify"
71 S DIR("?")="the Auto Match Value."
72 D ^DIR K DIR
73 D EN^DDIOL(,,"!!")
74 ;
75 ; If user didn't say Yes, then we exit
76 I 'Y G AMADDX
77 ; To allow for edits to the .01 field and not the .02 field,
78 ; Add this new entry first and then edit only the .01 field.
79 S AMDATA(365.11,"+1,",.01)=IBCNEXT1
80 S AMDATA(365.11,"+1,",.02)=INSNAME
81 S AMDATA(365.11,"+1,",.03)=$$NOW^XLFDT
82 S AMDATA(365.11,"+1,",.04)=DUZ
83 S AMDATA(365.11,"+1,",.05)=$$NOW^XLFDT
84 S AMDATA(365.11,"+1,",.06)=DUZ
85 S AMDATA(365.11,"+1,",.07)=IBCNEXT1
86 S AMDATA(365.11,"+1,",.08)=INSNAME
87 D UPDATE^DIE("","AMDATA","AMIEN","AMERROR")
88 ;
89 I $D(AMERROR) G AMADDX ; FileMan error so get out
90 S AMIEN=+$G(AMIEN(1)) ; internal entry number created
91 I 'AMIEN G AMADDX ; if IEN not there get out
92 ;
93 ; Here we have to edit the entry to allow for the opportunity to
94 ; change something
95 S DIE=365.11,DA=AMIEN,DR=".01;.05////"_$$NOW^XLFDT_";.06////"_DUZ
96 D ^DIE
97 ;
98 ; Display the confirmation message to the user
99 S AMDATA=$G(^IBCN(365.11,AMIEN,0))
100 I AMDATA'="" D EN^DDIOL($P(AMDATA,U,1)_" is now associated with "_$P(AMDATA,U,2)_".",,"!!?3")
101 D EN^DDIOL(,,"!!")
102AMADDX ;
103 Q
104 ;
105PYRFLTR() ;
106 ; Function to assist with filtering items in custom payer
107 ; lookups for most popular list. This logic is used in the
108 ; DIC("S") definition for the lookup
109 ;
110 NEW IBDATA,IBPIEN,IBPNM,IBAIEN,IBADATA,OK
111 ;
112 S OK=1
113 ;
114 S IBDATA=^(0) ; Naked reference from DIC call
115 S IBPIEN=$G(Y) I IBPIEN="" S OK=0 G XPFLTR
116 ;
117 ; Set Payer Name and IEN
118 S IBPNM=$P(IBDATA,U,1) I IBPNM="" S OK=0 G XPFLTR
119 ;
120 ; Set Payer Application IEN (365.13)
121 ; Quit if IIV not defined for payer
122 S IBAIEN=$$PYRAPP^IBCNEUT5("IIV",IBPIEN) I IBAIEN="" S OK=0 G XPFLTR
123 ;
124 ; Get IIV application specific data
125 S IBADATA=$G(^IBE(365.12,IBPIEN,1,IBAIEN,0)) I IBADATA="" S OK=0 G XPFLTR
126 ;
127 ; Filter if Deactivated
128 I +$P(IBADATA,U,11) S OK=0 G XPFLTR
129 ;
130 ; Filter if ID Inq Req ID and SSN is not ID
131 I +$P(IBADATA,U,8),'$P(IBADATA,U,9) S OK=0 G XPFLTR
132 ;
133 ; Filter if already in the list
134 I $D(^TMP($J,"IBJPI3-IENS",IBPIEN)) S OK=0 G XPFLTR
135 ;
136XPFLTR Q OK
137 ;
138DSPLINE() ;
139 ; Format display text for custom Most Pop. payer lookup
140 ;
141 N ITEMDATA,DISPSTR,IBAIEN,IBADATA,PYRIEN,PADLEN
142 ;
143 ; Initialize the data for the item to be displayed
144 ; Naked reference is referencing the DIC data
145 S ITEMDATA=^(0)
146 ;
147 ; Initialize Display string
148 S DISPSTR=""
149 ;
150 ; Payer IEN is passed from DIC as Y
151 S PYRIEN=+$G(Y) I 'PYRIEN G EXDSP
152 ;
153 ; Set Payer Application IEN (365.13)
154 S IBAIEN=$$PYRAPP^IBCNEUT5("IIV",PYRIEN) I IBAIEN="" G EXDSP
155 ;
156 ; Get IIV Application specific data
157 S IBADATA=$G(^IBE(365.12,PYRIEN,1,IBAIEN,0)) I IBADATA="" G EXDSP
158 ;
159 ; Pad start of display data, adjusting for payer name length
160 S PADLEN=$L($E($P($G(ITEMDATA),U),1,30))
161 S DISPSTR=DISPSTR_$$FO^IBCNEUT1("",31-PADLEN,"L")
162 ;
163 ; Add National and Local active flags
164 S DISPSTR=DISPSTR_" National: "_$$FO^IBCNEUT1($S('$P(IBADATA,U,2):"Inactive",1:"Active"),8)
165 S DISPSTR=DISPSTR_" Local: "_$$FO^IBCNEUT1($S('$P(IBADATA,U,3):"Inactive",1:"Active"),8)
166EXDSP ;
167 Q DISPSTR
168 ;
Note: See TracBrowser for help on using the repository browser.