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

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

initial load of FOIAVistA 6/30/08 version
File size: 8.8 KB
Line 
1IBCEP9 ;ALB/TMP - MASS UPDATE OF PROVIDER ID FROM FILE OR MANUAL ;08-NOV-00
2 ;;2.0;INTEGRATED BILLING;**137,200,320,348,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5EN ; Get parameters and mass input provider id by ins co
6 N A,DA,DIC,DIE,DIK,DIR,DR,POP,Q,Q0,X,Y,Y3,Z,Z0
7 N IBCND,IBCU,IBCT,IBDELIM,IBFILE,IBFILEN,IBFILEP,IBFORMAT
8 N IBFT,IBINFILE,IBINS,IBL,IBN,IBOK,IBOPEN,IBPOS,IBPT,IBQUIT
9 N IBQUIT1,IBQUOTES,IBRA,IBS,IBSA,IBSTART,IBSRC,IBVERIFY,IBVNAME
10 K ^TMP("IBPID_IN",$J),^TMP("IBPID-ERR",$J),^TMP("IBPID",$J)
11 S IBQUIT=0
121 ; Select INSURANCE COMPANY NAME:
13 G:IBQUIT ENQ
14 S IBQUIT1=0
15 S DIC("S")="I $P($G(^DIC(36,+Y,3)),U,13)'=""C"""
16 S DIC(0)="AEMQ",DIC="^DIC(36," D ^DIC
17 I Y'>0 G ENQ
18 S IBINS=+Y
19 S IBQUIT=$$LOCK^IBCEP9B(IBINS)
20 I IBQUIT,$G(IBINS) D G 1
21 . D UNLOCK^IBCEP9B(IBINS)
22 . S IBINS="",IBQUIT=0
23 . W !!,"Unable to lock all associated insurance companies.",!,"Please try again later.",!!
24 ;
252 ; get data source
26 S IBQUIT1=0
27 S DIR(0)="SA^M:Manual Entry;F:Entry from file"
28 S DIR("A")="PROVIDER ID DATA SOURCE: ",DIR("B")="Manual Entry"
29 S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
30 I Y=""!("FM"'[Y)!IBQUIT1 D UNLOCK^IBCEP9B(IBINS) G 1
31 S IBSRC=Y,IBVERIFY=0
32 S IBVERIFY=(Y="M")
33 I 'IBVERIFY D G:IBQUIT ENQ G:IBQUIT 2
34 . S DIR(0)="YA",DIR("A")="DO YOU WANT TO VIEW/VERIFY EACH ENTRY BEFORE IT GETS UPDATED?: "
35 . S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
36 . I Y=1 S IBVERIFY=1
37 ;
38 G:IBSRC="M" 4
3921 ; get parameters for file type
40 G:IBQUIT ENQ
41 S IBQUIT1=0
42 S DIR(0)="SA^D:DELIMITED;F:FIXED LENGTH",DIR("B")="D",DIR("A")="SELECT FILE FORMAT: "
43 S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
44 I IBQUIT1 G 2
45 S IBPOS=Y
46 I IBPOS="D" D G:IBQUIT1 21
47 . S DIR(0)="FA^1:1",DIR("B")=",",DIR("A")="DELIMITER CHARACTER: "
48 . S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
49 . Q:IBQUIT1
50 . S $P(IBPOS,U,2)=Y
51 . S DIR(0)="YA",DIR("B")="NO",DIR("A")="ARE QUOTES WITHIN A FIELD DOUBLE QUOTED?: "
52 . S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1,,,1)
53 . Q:IBQUIT1
54 . S $P(IBPOS,U,3)=Y
553 ; select external file name
56 G:IBQUIT ENQ
57 S IBQUIT1=0
58 G:IBSRC="M" 2
59 S DIR(0)="FA^1:60"
60 S DIR("A")="FILE NAME PATH: ",DIR("B")=$$PWD^%ZISH
61 S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
62 G:IBQUIT1 2
63 S IBFILEP=$P(Y,U)
64 S DIR(0)="FA^1:60"
65 S DIR("A")="FILE NAME: "
66 S IBSA("*")=""
67 S DIR("?")="^S Y3=$$LIST^%ZISH(IBFILEP,""IBSA"",""IBRA"") I Y3=1 S Y3="""" F S Y3=$O(IBRA(Y3)) Q:Y3="""" W !,Y3"
68 S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1,,,1)
69 G:IBQUIT1 2
70 S IBFILEN=$P(Y,U)
71 K ^TMP($J),IBRA,Y3
72 N Y S Y=$$FTG^%ZISH(IBFILEP,IBFILEN,$NA(^TMP($J,1)),2)
73 I Y=0 W !,"FILE ",IBFILEP,IBFILEN," COULD NOT BE FOUND OR COULD NOT BE OPENED",! G 3
74 S IBFILE=IO
754 ; select Provider ID Type
76 G:IBQUIT ENQ
77 S IBQUIT1=0
78 S DIR(0)="355.9,.06"
79 I IBSRC="M" S Z=$P($G(^IBE(355.97,+$$PPTYP^IBCEP0(IBINS),0)),U) S:Z'="" DIR("B")=Z
80 S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
81 G:Y=""!IBQUIT1 3
82 S IBPTYP=$P(Y,U)
835 ; select Forms Type
84 G:IBQUIT ENQ
85 S IBQUIT1=0
86 S DIR(0)="355.9,.04r",DIR("B")="BOTH UB-04 AND CMS-1500 FORMS"
87 S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
88 G:IBQUIT1 4
89 I Y=""!("012"'[Y) G 5
90 S IBFT=$P(Y,U)
916 ; select Bill Care Type
92 G:IBQUIT ENQ
93 S IBQUIT1=0
94 S DIR(0)="355.9,.05r",DIR("B")="BOTH INPATIENT AND OUTPATIENT"
95 S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
96 G:IBQUIT1 5
97 I Y=""!("0123"'[$P(Y,U)) G 6
98 S IBCT=$P(Y,U)
99 ;
100 S IBCND=$$CAREUN^IBCEP3(IBINS,IBPTYP,IBFT,IBCT,IBCT=3)
1017 ; get Care Unit
102 G:IBQUIT ENQ
103 S IBQUIT1=0
104 I IBCND D G:IBQUIT1 6
105 . S DIR(0)="355.9,.03O"
106 . S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
107 . Q:IBQUIT1
108 . S IBCU=$P(Y,U)
109 . I IBCU="" W !!,$J("",22),"***** WARNING *****",!," YOU WILL NEED TO MANUALLY ENTER THE CARE UNIT FOR EACH PROVIDER",!!
110 ;
111 ; Manual entry to get providers from VistA
112 I IBSRC="M" D MANUAL^IBCEP9B G:IBQUIT1 6
113 ; For 'OTHER' files ask position/length or delimiter/piece for data
114 I IBSRC="F" D I IBQUIT1 G:'IBCND 6 G 7
115 . F Z="PROV. SSN^SSN^15^1","PROV. NAME^NAM^30","PROV. 1500 ID^PROF_ID^15","PROV. UB-04 ID^INST_ID^15" D Q:IBQUIT1
116 .. I $P(IBPOS,U)'="D" D
117 ... N X
118 ... I IBFT=0!(IBFT=1) Q:Z["PROF_ID" I Z["INST_ID" S $P(Z,U)="PROV. ID"
119 ... I IBFT=2 Q:Z["INST_ID"
120 ... S DIR("A")="START POSITION OF "_$P(Z,U)_" FIELD: "
121 ... S DIR(0)="NA"_$S($P(Z,U,4)!($P(Z,U)["PROV. ID")!($P(Z,U)["_ID"):"",1:"O")_"^1:250"
122 ... W ! S X=$$DIR1^IBCEP9B(.DIR,Z,.IBQUIT,.IBQUIT1)
123 ... Q:IBQUIT1
124 ... I X>0 D
125 .... S IBPOS($P(Z,U,2))=X
126 .... S DIR("A")="LENGTH OF "_$P(Z,U)_" FIELD: "
127 .... S DIR(0)="NA"_$S($P(Z,U,3):"^1:"_$P(Z,U,3),1:"")
128 .... S X=$$DIR1^IBCEP9B(.DIR,Z,.IBQUIT,.IBQUIT1)
129 .... Q:IBQUIT1
130 .... S $P(IBPOS($P(Z,U,2)),U,2)=IBPOS($P(Z,U,2))+X-1
131 .. ;
132 .. I $P(IBPOS,U)="D" D
133 ... I IBFT=0!(IBFT=1) Q:Z["PROF_ID" I Z["INST_ID" S $P(Z,U)="PROV. ID"
134 ... I IBFT=2 Q:Z["INST_ID"
135 ... W ! S DIR("A")="STARTING '"_$P(IBPOS,U,2)_"' PIECE # OF "_$P(Z,U)_" FIELD: "
136 ... S DIR(0)="NA"_$S($P(Z,U,4)!($P(Z,U)["PROV. ID")!($P(Z,U)["_ID"):"",1:"O")
137 ... S X=$$DIR1^IBCEP9B(.DIR,Z,.IBQUIT,.IBQUIT1)
138 ... Q:IBQUIT1
139 ... I X>0 D
140 .... S (DIR("B"),IBPOS($P(Z,U,2)))=X
141 .... S DIR("A")="ENDING '"_$P(IBPOS,U,2)_"' PIECE # OF "_$P(Z,U)_" FIELD: "
142 .... S DIR(0)="NA"_$S($P(Z,U,4):"",1:"O")_U_(IBPOS($P(Z,U,2)))_":99"
143 .... S DIR("?")="JUST PRESS THE ENTER KEY IF THIS FIELD IS CONTAINED IN ONLY 1 PIECE"
144 .... S Y=$$DIR1^IBCEP9B(.DIR,Z,.IBQUIT,.IBQUIT1)
145 .... Q:IBQUIT1
146 .... W ! I Y>0,Y'=IBPOS($P(Z,U,2)) S $P(IBPOS($P(Z,U,2)),U,2)=Y
147 .. ;
148 . Q:IBQUIT1
149 . D READFILE^IBCEP9B
150 . ;
151P1 ;
152 S Z="" F S Z=$O(^TMP("IBPID_IN",$J,Z)) Q:Z="" S Z0=0 F S Z0=$O(^TMP("IBPID_IN",$J,Z,Z0)) Q:'Z0 S Q=$G(^(Z0)) D G:IBQUIT ENQ
153 . ;
154 . I IBSRC="M" D Q
155 .. D DISP^IBCEP9B(Q,0,IBINS,IBPTYP,IBFT,IBCT,$G(IBCU),,IBSRC)
156 .. ; Manually add IDs
157 .. S IBN=$$DUP(+Z0_";VA(200,",IBINS,$S($G(IBCU)'="":IBCU,1:"*N/A*"),IBFT,IBCT,IBPTYP)
158 .. I 'IBN D Q:IBQUIT!(IBN'>0)
159 ... S IBN=$$ADDID^IBCEP9B(Z0,IBINS,$G(IBCU),IBFT,IBCT,IBPTYP,,.IBQUIT)
160 .. S DIE="^IBA(355.9,",DR=".07",DA=+IBN D ^DIE
161 .. I $D(Y)!($P($G(^IBA(355.9,+IBN,0)),U,7)="") D
162 ... I $P(IBN,U,3) S DA=+IBN,DIK="^IBA(355.9," D ^DIK
163 ... S DIR(0)="YA",DIR("B")="NO",DIR("A")="DO YOU WANT TO STOP ENTERING PROVIDER IDs?: "
164 ... S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1,,1,1)
165 ... I Y=1 S IBQUIT=1
166 .. S IBID=$P($G(^IBA(355.9,+IBN,0)),U,7)
167 .. S:$L(IBID) ^TMP("IBPID_IN",$J,U,Z0,"INST_ID")=IBID
168 .. I IBID="" K ^TMP("IBPID_IN",$J,U,Z0)
169 .. I IBQUIT=1 F S Z0=$O(^TMP("IBPID_IN",$J,U,Z0)) Q:Z0="" K ^TMP("IBPID_IN",$J,U,Z0) ; user wants to stop, remove all remaining names from list
170 . ;
171 . S IBOK=1
172 . N IBX,IBID
173 . M IBX=^TMP("IBPID_IN",$J,Z,Z0)
174 . I IBSRC="F" S IBID=$S(IBFT=0!(IBFT=1):$G(IBX("INST_ID")),1:$G(IBX("PROF_ID")))
175 . I $G(IBVERIFY) D ; Display record, ask OK to file id's
176 .. D DISP^IBCEP9B(Q,0,IBINS,IBPTYP,IBFT,IBCT,$G(IBCU),,IBSRC)
177 .. W !,"PROVIDER ID: ",IBID
178 .. S DIR("A")="OK TO FILE THIS ID FOR THIS PROVIDER?: ",DIR(0)="YA",DIR("B")="NO"
179 .. S Y=$$DIR(.DIR,,,,1,1)
180 .. I Y'=1 D Q ; Send to error array
181 ... S IBOK=0
182 ... S ^TMP("IBPID-ERR",$J,2,$P(IBX,U),$P(IBX,U,2)_" ","PROV ID")=IBID
183 ... S ^TMP("IBPID_IN",$J,U,Z0,0)="NO PRINT"
184 ... N Z1
185 ... S Z1="" F S Z1=$O(IBX(Z1)) Q:Z1="" I $G(IBX(Z1))'="",Z1'["_ID" S ^TMP("IBPID-ERR",$J,2,$P(IBX,U),$P(IBX,U,2)_" ",Z1)=IBX(Z1)
186 . I IBOK D ; Add/update the record
187 .. I IBSRC="F" D
188 ... I IBID'="" D
189 .... S IBN=$$ADDID^IBCEP9B(+Z0,IBINS,$G(IBCU),IBFT,IBCT,IBPTYP,,.IBQUIT)
190 .... I IBQUIT D:IBN>0 Q
191 ..... S DA=+IBN,DIK="^IBA(355.9," D ^DIK
192 .... I IBN>0 S DIE="^IBA(355.9,",DA=+IBN,DR=".07////"_IBID D ^DIE
193 .. ;
194 ;
195ENQ ; Print report, exit
196 I $G(IBINS) D
197 . D COPY^IBCEPCID(IBINS)
198 . D UNLOCK^IBCEP9B(IBINS)
199 ;
200 I ($D(^TMP("IBPID-ERR",$J)))!($D(^TMP("IBPID_IN",$J))) D
201 . N %ZIS,ZTSAVE,ZTRTN,ZTDESC,IBDUZ
202 . S IBDUZ=$G(DUZ)
203 . S %ZIS="QM" D ^%ZIS Q:POP
204 . I $D(IO("Q")) K IO("Q") D D ^%ZTLOAD K ZTSK D HOME^%ZIS Q
205 .. S ZTRTN="PRTERR^IBCEP9B",ZTSAVE("^TMP(""IBPID-ERR"",$J,")=""
206 .. S ZTSAVE("^TMP(""IBPID_IN"",$J,")="",ZTSAVE("IB*")=""
207 .. S ZTDESC="IB - PROVIDER ID BATCH UPDATE ERROR LOG"
208 . U IO
209 . D PRTERR^IBCEP9B
210 K ^TMP("IBPID_IN",$J),^TMP("IBPID-ERR",$J),^TMP("IBPID",$J)
211 U IO(0)
212 Q
213 ;
214DUP(IBPRV,IBINS,IBCU,IBFT,IBCT,IBPTYP) ; Check if provider id record already exists in file 355.9
215 Q +$O(^IBA(355.9,"AUNIQ",IBPRV,IBINS,IBCU,IBFT,IBCT,IBPTYP,0))
216 ;
217ERREOF ; Traps EOF error on file read for non-DSM systems
218 N IBERROR S IBERROR=$$EC^%ZOSV
219 I IBERROR["ENDOFFILE" D CLOSE(.IBOPEN) G ENQ
220 D ^%ZTER
221 Q
222 ;
223CLOSE(IBOPEN) ; Close file
224 D CLOSE^%ZISH("IBINFILE") S IBOPEN=0
225 Q
226 ;
227DIR(DIR,IBQUIT,IBQUIT1,X,IBW1,IBW2) ; Standard call to ^DIR
228 ; Inputs DIR array
229 ; Returns IBQUIT,IBQUIT1,X if passed by reference
230 ; AND
231 ; FUNCTION returns the value of Y
232 ; IBW1 = 1 if initial write ! should be done
233 ; IBW2 = 1 if last write ! should be done
234 N DIROUT,DTOUT,DUOUT,DA
235 W:$G(IBW1) ! D ^DIR K DIR W:$G(IBW2) !
236 S (IBQUIT,IBQUIT1)=0
237 S DIR("?")="Enter '^' to back up one prompt or '^^' to exit the option"
238 I $D(DIROUT) S (IBQUIT,IBQUIT1)=1
239 I $D(DTOUT)!$D(DUOUT) S IBQUIT1=1
240 Q Y
241 ;
242ERR ; Error list
243 ;; INVALID OR MISSING SSN - NO PROVIDER MATCH FOUND
244 ;; NO UPDATE PER USER REQUEST
245 ;;
Note: See TracBrowser for help on using the repository browser.