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

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

initial load of WorldVistAEHR
File size: 8.2 KB
Line 
1IBCEP9B ;ALB/TMP - UPDATE OF PROVIDER ID FROM FILE UTILITIES ;14-NOV-00
2 ;;2.0;INTEGRATED BILLING;**137,200,320**;21-MAR-94
3 ;
4 Q
5 ;
6READFILE ; Read records stored in ^TMP($J
7 ;
8 N D,DA,DIC,IBCT,IBP,IBQUIT,IBS,IBX,P,P3,X,Y,Z
9 S (IBCT,IBQUIT,IBQUIT1,IBS)=0
10 U IO(0)
11 ;
12 F S IBCT=$O(^TMP($J,IBCT)) Q:'IBCT S X=$G(^(IBCT)) I X'="" D Q:IBQUIT
13 . D Q:IBQUIT
14 .. I $P($G(IBPOS),U)="D" D
15 ... D CSV(X,.IBX,$P(IBPOS,U,2),$P(IBPOS,U,3))
16 ... D DSETUP(.IBX,.IBPOS,.P) K IBX
17 .. I $P($G(IBPOS),U)'="D" D FSETUP(X,.IBPOS,.P)
18 . ;
19 . I $G(P(1))'="" S P(1)=$$NOPUNCT^IBCEF(P(1),1),X=P(1),D="SSN",DIC="^VA(200,",DIC(0)="" D IX^DIC
20 . S IBP=+Y,IBVNAME=$P(Y,U,2)
21 . I $S($G(P(1))="":1,1:Y'>0) D Q
22 .. S ^TMP("IBPID-ERR",$J,1,$S($G(P(1))'="":P(1),1:"NO SSN"),$G(P(2))_" ","??")=""
23 .. N IBID
24 .. S IBID=$S(IBFT=0!(IBFT=1):$G(P("INST_ID")),1:$G(P("PROF_ID")))
25 .. S ^TMP("IBPID-ERR",$J,1,$S($G(P(1))'="":P(1),1:"NO SSN"),$G(P(2))_" ","PROV ID")=IBID
26 . ;
27 . S ^TMP("IBPID_IN",$J,U,IBP)=P(1)_U_P(2)_U_IBVNAME
28 . F Q0=0,"TID","UPIN","INST_ID","PROF_ID","CU","CRED" S ^TMP("IBPID_IN",$J,U,IBP,Q0)=$G(P(Q0))
29 Q
30 ;
31CSV(X,IBX,IBDEL,IBQUOTES) ; Parse out fields from a delimited file
32 ; X = data string in CSV format to be parsed
33 ; IBX = array returned if passed by reference, subscripted by field #
34 ; IBDEL = the delimiter
35 ; If IBQUOTES=1, quoted strings are double quoted within a field
36 N FC,I,PC,QCT,QM,QM2,QM4,STR,TPC
37 S FC=0,TPC=$L(X,IBDEL),QM=$C(34),QM2=QM_QM,QM4=QM2_QM2
38 F PC=1:1:TPC D
39 . S STR=$P(X,IBDEL,PC)
40 . S FC=FC+1
41 . I (STR=QM2)!(STR=QM4) S IBX(FC)="" Q
42 . I $E(STR,1)=QM D
43 .. F QCT=0:1 Q:$E(STR,QCT+1)'=QM
44 .. F Q:($E(STR,1,QCT)=$E(STR,$L(STR)-(QCT-1),$L(STR))) S PC=PC+1 Q:PC>TPC S STR=STR_IBDEL_$P(X,IBDEL,PC)
45 .. I PC>TPC S IBX(0)="-1^UNMATCHED QUOTE MARKS" Q
46 .. F Q:$E(STR,1)'=QM I $E(STR,$L(STR))=QM S STR=$E(STR,2,$L(STR)-1)
47 . I IBQUOTES,STR[QM2 D
48 .. F I=1:1:$L(STR) I $E(STR,I,I+1)=QM2 S STR=$E(STR,1,I)_$E(STR,I+2,9999)
49 . S IBX(FC)=STR
50 Q
51 ;
52MANUAL ; Manual entry to get providers from VistA
53 N IBCRED,IBDA,IBNAM,IBSSN
54 ; S IBCNT=0 ; this looks like extraneous code, IBCNT not used anywhere.
55 F D I X=""!(X["^") Q
56 . S Y=$$LOOKUP^XUSER Q:X="" I X["^" S IBQUIT1=1 Q
57 . S IBDA=+Y,IBNAM=$P(Y,U,2)
58 . S IBSSN=$$GET1^DIQ(200,IBDA_",",9,"I")
59 . S IBCRED=$$GET1^DIQ(200,IBDA_",",10.6,"I")
60 . S ^TMP("IBPID_IN",$J,U,IBDA)=IBSSN_U_IBNAM_" "_IBCRED
61 Q
62 ;
63DIR1(DIR,Z,IBQUIT,IBQUIT1) ; Ask position
64 N X,Y
65 S Y=$$DIR^IBCEP9(.DIR,.IBQUIT,.IBQUIT1)
66 I IBQUIT1 S Y="" G DIRQ
67 I $P(Z,U,4),Y'>0 S Y="",(IBQUIT1,IBQUIT)=1
68 I Y'>0 S Y=""
69DIRQ Q Y
70 ;
71DISP(Q,IBID,IBINS,IBPTYP,IBFT,IBCT,IBCU,IBPID,IBSRC) ; Display provider data
72 ; includes ID data if IBID=1
73 ; Q = SSN^provider name from input^provider name from file #200
74 ; IBPID = array of id numbers to be stored
75 N A,IBL,Q0,Z
76 S $P(Q,U,2)=$$FLEN($P(Q,U,2))
77 S Q0(1)="PROVIDER : "_$P(Q,U)_$S($P(Q,U,2)'="":" ("_$P(Q,U,2)_")",1:"")_$S(IBSRC="F":" <- input file data",1:"")
78 S Q0(2)="" S:IBSRC="F" Q0(2)=$J("("_$P(Q,U,3),22+$L($P(Q,U,3)))_") <- VA match"
79 S IBL=0
80 D DISP^IBCEP4("Q0",IBINS,IBPTYP,IBFT,IBCT,3,.IBL)
81 I $G(IBCU)'="" S Q0(IBL+1)="CARE UNIT: "_IBCU
82 W !
83 S A=0 F S A=$O(Q0(A)) Q:'A W !,Q0(A)
84 I $G(IBID),$O(IBPID(""))'="" D ; Display id's to be filed
85 . W ! S Z="" F S Z=$O(IBPID(Z)) Q:Z="" I IBPID(Z)'="" D
86 .. W !,$S(Z="TID":"TAX ID NUMBER",Z="INST_ID":"INSTITUTIONAL ID",Z="PROF_ID":"PROFESSIONAL ID",Z="UPIN":"UPIN",1:"PROV ID"),": ",IBPID(Z)
87 Q
88 ;
89DSETUP(IBX,IBPOS,P) ; Set up the subscripted array P with the correct data
90 ; from IBX(pc #) based on the parameters in array IBPOS
91 ; RETURNED: P(data index)=data value (pass by reference)
92 N Q,Z,Z0
93 S Z=$G(IBPOS("SSN")),P(1)=""
94 F Z0=+Z:1:$S('$P(Z,U,2):Z,1:$P(Z,U,2)) S P(1)=P(1)_$S(P(1)'=""&($G(IBX(Z0))'=""):" ",1:"")_$G(IBX(Z0))
95 S Z=$G(IBPOS("NAM")),P(2)=""
96 F Z0=+Z:1:$S('$P(Z,U,2):Z,1:$P(Z,U,2)) S P(2)=P(2)_$S(P(2)'=""&($G(IBX(Z0))'=""):" ",1:"")_$G(IBX(Z0))
97 F Q="TID","UPIN","INST_ID","PROF_ID","CRED","CU","LIC" D
98 . S Z=$G(IBPOS(Q)),P(Q)=""
99 . Q:'Z
100 . F Z0=+Z:1:$S('$P(Z,U,2):Z,1:$P(Z,U,2)) S P(Q)=P(Q)_$S(P(Q)'=""&($G(IBX(Z0))'=""):" ",1:"")_$G(IBX(Z0))
101 Q
102 ;
103FSETUP(X,IBPOS,P) ;Set up the subscripted array P with the correct data
104 ; from record data in X, based on the parameters in array IBPOS for a
105 ; fixed length data field format
106 ; RETURNED: P(data index)=data value (pass by reference)
107 ;
108 N Q,Z
109 S Z=$G(IBPOS("SSN")),P(1)=""
110 S P(1)=$E(X,+Z,$S($P(Z,U,2):$P(Z,U,2),1:+Z))
111 S Z=$G(IBPOS("NAM")),P(2)=""
112 S P(2)=$E(X,+Z,$S($P(Z,U,2):$P(Z,U,2),1:+Z))
113 F Q="TID","UPIN","INST_ID","PROF_ID","CRED","CU","LIC" D
114 . S Z=$G(IBPOS(Q)),P(Q)=""
115 . Q:'Z
116 . S P(Q)=$$FLEN($E(X,+Z,$S($P(Z,U,2):$P(Z,U,2),1:+Z)))
117 Q
118 ;
119FLEN(IBX) ; Strip out trailing spaces from field
120 ; FUNCTION returns stripped data
121 N Z,IB,IB1
122 S IB1=IBX,IB=$TR(IB1," ")
123 I IB'="" F Z=$L(IB1):-1:1 I $E(IB1,Z)'=" " S IB=$E(IB1,1,Z) Q
124 Q IB
125 ;
126ADDID(IB200,IBINS,IBCU,IBFT,IBCT,IBPTYP,IBQUIT,IBQUIT1) ; Add ID record (file 355.9) if not already there
127 N DIC,X,Y,DO,DD,DLAYGO,DIR
128 S X=IB200_";VA(200,"
129 S Y=+$O(^IBA(355.9,"AUNIQ",X,$S(IBINS:IBINS,1:"*ALL*"),$S($G(IBCU)'="":IBCU,1:"*N/A*"),IBFT,IBCT,IBPTYP,0))
130 I 'Y D
131 . S DIC(0)="L",DIC="^IBA(355.9,",DLAYGO=355.9,DIC("DR")=".02////"_IBINS_$S($G(IBCU)'="":";.03////"_IBCU,1:"")_";.04////"_IBFT_";.05////"_IBCT_";.06////"_IBPTYP
132 . D FILE^DICN K DIC,DO,DD,DLAYGO
133 I Y'>0 D Q
134 . S DIR(0)="AE",DIR("A",1)="A PROBLEM WAS ENCOUNTERED ADDING THIS PROVIDER ID RECORD - NO RECORD ADDED",DIR("A")="PRESS ENTER TO CONTINUE "
135 . S Y=$$DIR^IBCEP9(.DIR,.IBQUIT,.IBQUIT1,,1,1)
136 S IBN=Y
137 Q $S(IBN>0:IBN,1:0)
138 ;
139PRTERR ; Prints error report
140 N IBPAGE,Z,Z0,Z1,Z2,Z3,IBLCT,IBSTOP,IBHDT
141 W:$E(IOST,1,2)["C-" @IOF
142 I $D(^TMP("IBPID-ERR",$J)) D
143 . S IBSTOP=0,IBLCT=$$HDR(.IBPAGE,.IBSTOP,.IBHDT)
144 . S Z=0 F S Z=$O(^TMP("IBPID-ERR",$J,Z)) Q:'Z W !!,$P($T(ERR+Z^IBCEP9),";;",2)_":" D
145 .. S Z0=""
146 .. F S Z0=$O(^TMP("IBPID-ERR",$J,Z,Z0)) Q:Z0="" S IBLCT=IBLCT+1 S:(IBLCT+5)>IOSL IBLCT=$$HDR(.IBPAGE,.IBSTOP) Q:IBSTOP D
147 ... S Z1="" F S Z1=$O(^TMP("IBPID-ERR",$J,Z,Z0,Z1)) Q:Z1="" W !,$E(Z0_$J("",9),1,9) W:$P(Z1,U)'="" " "_$E($P(Z1,U)_$J("",40),1,40) D
148 .... S Z2="" F S Z2=$O(^TMP("IBPID-ERR",$J,Z,Z0,Z1,Z2)) Q:Z2="" S Z3=$G(^(Z2)) I Z3'="" D
149 ..... W " "_$S(Z2="CU":"CARE UNIT",Z2="CRED":"CREDENTIALS",Z2="TID":"TAX ID #",Z2="LIC_ST":"LICENSE STATE",Z2="LIC":"LICENSE",Z2="UPIN":"UPIN",1:Z2)_": "_Z3
150FILED ; Prints all filed records
151 I $D(^TMP("IBPID_IN",$J)) D
152 . S IBSTOP=0,IBLCT=$$HDR(.IBPAGE,.IBSTOP,.IBHDT)
153 . W !!," RECORDS SELECTED FOR FILING:"
154 . S Z0=""
155 . F S Z0=$O(^TMP("IBPID_IN",$J,U,Z0)) Q:Z0="" S IBLCT=IBLCT+1 S:(IBLCT+5)>IOSL IBLCT=$$HDR(.IBPAGE,.IBSTOP) Q:IBSTOP D
156 .. I $G(^TMP("IBPID_IN",$J,U,Z0,0))="NO PRINT" S:IBLCT>6 IBLCT=IBLCT-1 Q
157 .. S Z=^TMP("IBPID_IN",$J,U,Z0)
158 .. W !,$P(Z,U,1),?12,$P(Z,U,2),?52,$G(^TMP("IBPID_IN",$J,U,Z0,"INST_ID"))
159 ;
160 I $E(IOST,1,2)["C-",'IBSTOP K DIR S DIR(0)="E" D ^DIR K DIR
161 W @IOF
162 I $D(ZTQUEUED) S ZTREQ="@"
163 I '$D(ZTQUEUED) W ! D ^%ZISC
164 Q
165HDR(PG,IBSTOP,IBHDT) ; Prints error report header, function returns # of lines used
166 ; PG = the last page # printed
167 ; IBHDT = the run date of the report
168 N Z,IBLCT
169 S IBLCT=0
170 I '$G(PG) S IBHDT="RUN DATE: "_$$FMTE^XLFDT($$NOW^XLFDT(),2)_U_"RUN BY: "_$P($G(^VA(200,+$G(IBDUZ),0)),U)
171 I $G(PG),$E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR S IBSTOP=('Y) G:IBSTOP HDRQ W @IOF
172 S PG=$G(PG)+1
173 W $J("",23)_"BATCH UPDATE OF PROVIDER ID REPORT"_$J("",13)_"PAGE: ",PG
174 W !,$J("",(80-$L($P($G(IBHDT),U)))\2),$P($G(IBHDT),U)
175 W !,$J("",(80-$L($P($G(IBHDT),U,2)))\2),$P($G(IBHDT),U,2)
176 W !!," INSURANCE CO: "_$P($G(^DIC(36,+$G(IBINS),0)),U)
177 W !,"PROVIDER ID TYPE: "_$P($G(^IBE(355.97,+$G(IBPTYP),0)),U)
178 W !," FORM TYPE: "_$$EXPAND^IBTRE(355.91,.04,$G(IBFT))
179 W !," CARE TYPE: "_$$EXPAND^IBTRE(355.91,.05,$G(IBCT))
180 S IBLCT=7
181 I $G(IBCU)'="" W !,$J("",7)_"CARE UNIT: "_IBCU S IBLCT=IBLCT+1
182 S Z="",$P(Z,"=",81)="",IBLCT=IBLCT+1
183 W !,Z
184HDRQ Q $G(IBLCT)
185 ;
186LOCK(IBINS) ; Lock Parent and Children up
187 N IBQUIT
188 S IBQUIT=0
189 I $P($G(^DIC(36,IBINS,3)),U,13)="P" D
190 . L +^DIC(36,IBINS):5 E S IBQUIT=1 Q
191 . N CHILD
192 . S CHILD="" F S CHILD=$O(^DIC(36,"APC",IBINS,CHILD)) Q:'+CHILD D Q:IBQUIT
193 .. L +^DIC(36,CHILD):5 E S IBQUIT=1
194 Q IBQUIT
195 ;
196UNLOCK(IBINS) ; Unlock the family
197 I $P($G(^DIC(36,IBINS,3)),U,13)="P" D
198 . L -^DIC(36,IBINS)
199 . N CHILD
200 . S CHILD="" F S CHILD=$O(^DIC(36,"APC",IBINS,CHILD)) Q:'+CHILD D
201 .. L -^DIC(36,CHILD)
202 Q
203 ;
Note: See TracBrowser for help on using the repository browser.