source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNEUT1.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: 6.7 KB
Line 
1IBCNEUT1 ;DAOU/ESG - IIV MISC. UTILITIES ;03-JUN-2002
2 ;;2.0;INTEGRATED BILLING;**184**;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 ;
8FO(VALUE,LENGTH,JUSTIFY,FILL,TRUNC) ; Formatted output function
9 ;
10 ; Input parameters:
11 ; VALUE the data to get formatted (required)
12 ; LENGTH the resulting length of the formatted string (required)
13 ; JUSTIFY "L" or "R" to indicate left or right justification
14 ; Default is "L" if not passed
15 ; FILL the character to fill in the spaces
16 ; Default is a space if not passed
17 ; TRUNC Whether or not to truncate Value if its longer than length
18 ; Default is Yes, to truncate if not passed
19 ;
20 NEW PAD,Z
21 I LENGTH>200 S LENGTH=200 ; reasonable length
22 S JUSTIFY=$G(JUSTIFY,"L") ; default Left
23 S FILL=$E($G(FILL)_" ") ; default space
24 S TRUNC=$G(TRUNC,1) ; default true
25 S $P(PAD,FILL,LENGTH-$L(VALUE)+1)=""
26 S Z=""
27 ;
28 ; Check for JUSTIFY being "R" first
29 I JUSTIFY["R" D G FOXIT
30 . I $L(VALUE)'>LENGTH S Z=PAD_VALUE Q
31 . I 'TRUNC S Z=VALUE Q
32 . S Z=$E(VALUE,$L(VALUE)-LENGTH+1,$L(VALUE)) Q
33 . Q
34 ;
35 ; JUSTIFY is "L" below
36 I $L(VALUE)'>LENGTH S Z=$E(VALUE_PAD,1,LENGTH) G FOXIT
37 I 'TRUNC S Z=VALUE G FOXIT
38 S Z=$E(VALUE,1,LENGTH)
39 ;
40FOXIT ;
41 Q Z
42 ;
43 ;
44AMLOOK(NAME,ERRFLG,LIST) ; Look-up an ins. co. name in Auto Match
45 ;
46 ; Input parameters
47 ; NAME Insurance company name to look for (required)
48 ; ERRFLG Error flag to determine whether or not to return
49 ; an array of all hits (optional)
50 ; LIST The array to be built - passed by reference
51 ; (optional)
52 ; LIST(ins co name)=auto match value
53 ;
54 ; Output
55 ; The value of this function is either 0 or 1.
56 ; 0 - no matches in the Auto Match file for this name
57 ; 1 - at least one match was found in the Auto Match file
58 ;
59 NEW FOUND,AMIEN,INSNAME,AMV,AMVSTART,NOMATCH
60 S FOUND=0 ; default to not found
61 KILL LIST ; initialize results array
62 S ERRFLG=+$G(ERRFLG) ; ERRFLG default is 0 if not present
63 S NAME=$$TRIM^XLFSTR($G(NAME)) ; strip leading/trailing spaces
64 I NAME="" G AMLOOKX ; get out if NAME not present
65 ;
66 ; First look for direct hits in the Auto Match file
67 S AMIEN=$O(^IBCN(365.11,"B",NAME,""))
68 I AMIEN D
69 . S FOUND=1
70 . I 'ERRFLG Q
71 . S INSNAME=$P($G(^IBCN(365.11,AMIEN,0)),U,2)
72 . I INSNAME'="" S LIST(INSNAME)=NAME
73 . Q
74 ;
75 ; If we found one and we're not building the array, then exit
76 I FOUND,'ERRFLG G AMLOOKX
77 ;
78 ; Use the first character of the NAME as a seed value to start
79 ; looping through the Auto Match entries. Only need to look at
80 ; entries with the "*" wildcard character.
81 S AMV=$E(NAME)
82 F S AMV=$O(^IBCN(365.11,"B",AMV)) Q:$E(AMV)'=$E(NAME) D I FOUND,'ERRFLG Q
83 . I AMV'["*" Q ; only looking for wildcarded entries
84 . ;
85 . ; Ensure that the first part of NAME is the same as the first
86 . ; part of the Auto Match value.
87 . S AMVSTART=$P(AMV,"*",1)
88 . I AMVSTART'="",$E(NAME,1,$L(AMVSTART))'=AMVSTART Q
89 . ;
90 . ; Build the NOMATCH variable and check it
91 . D AMC("NAME",AMV,.NOMATCH,0)
92 . I @NOMATCH Q
93 . ;
94 . ; We've got a match so process this accordingly
95 . S FOUND=1
96 . I 'ERRFLG Q
97 . S AMIEN=$O(^IBCN(365.11,"B",AMV,""))
98 . S INSNAME=$P($G(^IBCN(365.11,+AMIEN,0)),U,2)
99 . I INSNAME'="" S LIST(INSNAME)=AMV
100 . Q
101 ;
102 ; If we found one and we're not building the array, then exit
103 I FOUND,'ERRFLG G AMLOOKX
104 ;
105 ; Now we need to look at the Auto Match entries which start with
106 ; the "*" wildcard character.
107 S AMV="*"
108 F S AMV=$O(^IBCN(365.11,"B",AMV)) Q:$E(AMV)'="*" D I FOUND,'ERRFLG Q
109 . D AMC("NAME",AMV,.NOMATCH,0) ; build the NOMATCH variable
110 . I @NOMATCH Q ; check it
111 . S FOUND=1 ; We've got a match
112 . I 'ERRFLG Q
113 . S AMIEN=$O(^IBCN(365.11,"B",AMV,""))
114 . S INSNAME=$P($G(^IBCN(365.11,+AMIEN,0)),U,2)
115 . I INSNAME'="" S LIST(INSNAME)=AMV
116 . Q
117 ;
118AMLOOKX ;
119 Q FOUND
120 ;
121 ;
122AMC(NAME,AMV,MATCH,FLAG) ; Auto Match check function
123 ;
124 ; NAME - literal variable name to be matched; enclosed in quotes
125 ; AMV - Auto Match Value to be pattern matched
126 ; MATCH - Variable passed by reference; returns condition check command
127 ; FLAG - if 1, then pattern match check is positive (default)
128 ; - if 0, then pattern match check is negative
129 ;
130 NEW NUMPCE,J,PCE,PCE1
131 S FLAG=$G(FLAG,1)
132 S MATCH=NAME_$S('FLAG:"'?",1:"?")
133 S NUMPCE=$L(AMV,"*")
134 F J=1:1:NUMPCE D
135 . S PCE=$P(AMV,"*",J),PCE1=""
136 . I PCE'="" S PCE1="1"""_PCE_""""
137 . S MATCH=MATCH_PCE1
138 . I J'=NUMPCE S MATCH=MATCH_".E"
139 . Q
140AMCX ;
141 Q
142 ;
143 ;
144AMSEL(AMARRAY) ; Select an insurance company name from an Auto Match hit list
145 ;
146 ; Input
147 ; Array of Auto Match hits. The structure of this array is the
148 ; same as that returned by the call to $$AMLOOK above.
149 ; AMARRAY(ins co name) = Auto Match value
150 ;
151 ; Output
152 ; Insurance Company name (subscript of input array), or
153 ; -1 if user entered "^" or timed out, or
154 ; 0 if user didn't select any of these names
155 ; No changes are made to the array.
156 ;
157 NEW SEL,NM,CNT,MSG,MSGNUM,CH,TXT
158 NEW DIR,X,Y,DIRUT,DTOUT,DUOUT,DIROUT
159 S SEL=0
160 I '$D(AMARRAY) G AMSELX ; Get out if array not passed in
161 ;
162 ; Display the contents of the array
163 S MSG(1)="Results of Auto Match search"
164 S MSG(2)=""
165 S MSG(3)=" "_$$FO("Insurance Company Name",30)_" Auto Match Value"
166 S MSG(4)=" "_$$FO("----------------------",30)_" ----------------"
167 S MSG(1,"F")="!!"
168 S NM="",MSGNUM=$O(MSG(""),-1),CNT=0,CH=""
169 F S NM=$O(AMARRAY(NM)) Q:NM="" D
170 . S CNT=CNT+1
171 . S TXT=$$FO(NM,30)_" "_AMARRAY(NM)
172 . S MSGNUM=MSGNUM+1
173 . S MSG(MSGNUM)=" "_TXT
174 . I $L(CH)>440 Q
175 . I CH="" S CH=CNT_":"_TXT ; building the set of codes string
176 . E S CH=CH_";"_CNT_":"_TXT ; for the DIR reader later on
177 . Q
178 ;
179 ; Get out if there are no entries in the list
180 I 'CNT G AMSELX
181 ;
182 ; One more blank line in the display
183 S MSGNUM=MSGNUM+1
184 S MSG(MSGNUM)=""
185 ;
186 ; Display the entries in the list
187 DO EN^DDIOL(.MSG)
188 ;
189 ; Ask the first question
190 S DIR(0)="YO"
191 S DIR("A")="Would you like to select this insurance company"
192 I CNT>1 S DIR("A")="Would you like to select one of these insurance companies"
193 S DIR("B")="Yes"
194 D ^DIR K DIR
195 I $D(DIRUT) S SEL=-1 G AMSELX
196 I 'Y S SEL=0 G AMSELX
197 ;
198 ; User said Yes to the above question
199 ; Get out if there is only one entry in the array
200 I CNT=1 S SEL=$O(AMARRAY("")) G AMSELX
201 ;
202 ; At this point we know there are multiple entries in the list
203 S DIR(0)="SO^"_CH
204 S DIR("A")="Please choose an insurance company"
205 D ^DIR K DIR
206 I $D(DIRUT) S SEL=-1 G AMSELX
207 I 'Y S SEL=0 G AMSELX
208 S SEL=$$TRIM^XLFSTR($E(Y(0),1,30),"R") ; strip trailing spaces
209AMSELX ;
210 Q SEL
211 ;
Note: See TracBrowser for help on using the repository browser.