source: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU4.m

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

initial load of FOIAVistA 6/30/08 version
File size: 7.9 KB
Line 
1IBCEU4 ;ALB/TMP - EDI UTILITIES ;02-OCT-96
2 ;;2.0;INTEGRATED BILLING;**51,137,210,155,290**;21-MAR-94
3 ;
4TESTFLD ; Entrypoint to call to test the output the formatter will
5 ; produce for a specific entry in file 364.7
6 ;
7 N X,Y,DIC,IBCT
8 K IBXDATA,IBXSAVE
9 S IBCT=0
10 F W !,$S(IBCT:"Another ",1:""),"Bill: " S DIC="^DGCR(399,",DIC(0)="AEMQ" D ^DIC Q:Y<0 D
11 . S IBCT=1
12 . K ^TMP($J),^TMP("IBXSAVE",$J),^TMP("IBXDATA",$J),IBXSAVE,IBXDATA
13 . D FLDS(+Y)
14 . F R !!,"VARIABLE TO DISPLAY (IBXDATA): ",X:DTIME Q:X["^" S:X="" X="IBXDATA" D
15 .. I $S($E(X,$L(X))'=")"&($L(X,"(")>1):1,1:$L(X,"(")'=$L(X,")")) W !,"BAD VARIABLE NAME" Q
16 .. I '$D(@X) W " *** NO DATA TO DISPLAY" Q
17 .. N S S S=X
18 .. W !,X," = ",$G(@X)
19 .. F S X=$Q(@X) Q:X'[S W !,X," = ",@X
20 .. W !
21 Q
22 ;
23FLDS(IBIFN) ; Extract fields for bill IBIFN
24 N X,Y,DIC,IB1,IBI,IBAR,IBXPG,IBXLN,IBXCOL,IBXREC,Z,Z0
25 W !,"Remember to run this for flds that set up pre-requisite data (if any) first",!
26 ;
27 S IB1=1
28 F W !,$S('IB1:"Another ",1:""),"Form Field: " S DIC="^IBA(364.7,",DIC(0)="AEMQZ" D ^DIC Q:Y<0 D
29 . S IB1=0
30 . N IBZXX,IBXIEN
31 . ; Execute data element logic for fld
32 . S IBI=+Y,Z=$P($G(^IBA(364.5,+$P(Y(0),U,3),0)),U)
33 . S Z0=$G(^IBA(364.6,+Y(0),0))
34 . S IBAR=$G(^IBA(364.5,+$P(Y(0),U,3),2)) S:IBAR="" IBAR="IBXDATA"
35 . S IBXPG=$P(Z0,U,4),IBXLN=$P(Z0,U,5),IBXCOL=$P(Z0,U,8),IBXREC=1
36 . D F^IBCEF(Z,"IBZXX","",IBIFN)
37 . Q:'$D(IBZXX)
38 . K @IBAR
39 . M @IBAR=IBZXX
40 . I $G(^IBA(364.7,IBI,1))'="" S IBXIEN=IBIFN X ^IBA(364.7,IBI,1)
41 . D CLEAN^DILF
42 Q
43 ;
44DATE(X) ; Convert date in YYYYMMDD or YYMMDD format to MM DD YYYY or MM DD YY
45 N Z
46 S Z=X
47 I $L(X)=8 S Z=$E(X,5,6)_" "_$E(X,7,8)_" "_$E(X,1,4)
48 I $L(X)=6 S Z=$E(X,3,4)_" "_$E(X,5,6)_" "_$E(X,1,2)
49 Q Z
50 ;
51MCRSPEC(IBIFN,MCR,IBPIEN) ; Returns specialty code for a provider on bill
52 ; IBIFN = bill ien (file 399)
53 ; MCR = 1 if 2-digit MCR code should be returned 0 or null=3 digit code
54 ; IBPIEN = vp of the provider for which to get the
55 ; specialty, otherwise it returns specialty code for the 'required'
56 ; provider on bill (default is file 200 if no file designated)
57 ;
58 N IBZ,IBDT
59 S IBZ="99" ;default if none found
60 S IBDT=$P($G(^DGCR(399,+IBIFN,"U")),U,1) ; use statement from date
61 I '$G(IBPIEN) D F^IBCEF("N-SPECIALTY CODE","IBZ",,IBIFN)
62 I $G(IBPIEN) S:$P(IBPIEN,";",2)="" IBPIEN=IBPIEN_";VA(200," S IBZ=$$SPEC^IBCEU(IBPIEN,IBDT)
63 I '$G(MCR) S IBZ="0"_IBZ
64 Q IBZ
65 ;
66ECODE(IBP,CD) ; Function returns 1 if procedure ien IBP is an E-code
67 ; CD = returned = the external code, if passed by reference
68 N Q
69 S CD=$P($$ICD9^IBACSV(+IBP),U)
70 Q ($E(CD)="E")
71 ;
72BOX82NM(IBIFN,IBZSAVE) ; Returns the data to be printed in form locators 82
73 ; and 83 on the UB92 for bill ien IBIFN, based on the providers on the
74 ; bill
75 ; Pass array IBZSAVE by reference
76 N Z,IBZ,IBCT
77 ;
78 D F^IBCEF("N-ALL PROVIDERS","IBZ",,IBIFN)
79 F Z=1:1:6 S IBZSAVE("PRV-82",Z)=""
80 ; Find Providers and store them (if found) in this order:
81 ; Attending/Rendering, Operating, Referring, Other
82 F Z=4,2,1,9 D
83 . S IBCT=$S(Z=4:0,1:IBCT) Q:IBCT>4
84 . I Z=4,$$FT^IBCEF(IBIFN)=2 S Z=3 ; Find rendering for HCFA 1500
85 . I $S(Z=4!(Z=3):0,1:'$O(IBZ(Z,0))) Q
86 . S IBCT=IBCT+1
87 . I Z=4,$G(IBZ(4,1))="",$$FT^IBCEF(IBIFN)=3,'$D(^DGCR(399,IBIFN,"PRV")) S IBZ(Z,1)="DEPT OF VETERANS AFFAIRS" ;Default for old bills w/o prv
88 . I $O(IBZ(Z,1,1)) S IBZSAVE("PRV-82",IBCT)=$G(IBZ(Z,1,2))_" "_$G(IBZ(Z,1,3))
89 . S IBCT=IBCT+1,IBZSAVE("PRV-82",IBCT)=$P($G(IBZ(Z,1,1)),U)_" "_$P($G(IBZ(Z,1)),U)
90 Q
91 ;
92STATOK(IBIFN,VALST) ; Returns 1 if status of bill IBIFN is one of the valid
93 ; status codes in VALST
94 N OK,Z
95 S OK=0
96 I $G(VALST)'="" S OK=$L(VALST,$P($G(^DGCR(399,IBIFN,0)),U,13))>1
97 Q OK
98 ;
99RXPRLOOK(IBX) ; Do a FM lookup of procedures for RX that can be linked
100 ; to a specific revenue code (ones that are not already soft-linked)
101 ; Function returns ien of the 'CP' node multiple for the selected proc
102 ; OR "" if none selected or selection is invalid
103 ;
104 ; IBX = the procedure code
105 ;
106 N IBZ,IBMAX,IBEACH,IBMANY,IBHLP,IBNEXT,Z
107 S IBMAX=50,IBEACH=5,IBHLP=0
108 K ^TMP("DILIST",$J),^TMP("DIERR",$J),^TMP("DIHELP",$J),^TMP("IBLIST",$J)
109 ;
110 S IBZ=IBX
111 I IBX?1"?".E,'$D(DIQUIET) D
112 . I IBX?2"?".E S IBMAX=50,IBEACH=20 D RXPRHLP(IBMAX,.IBNEXT) S IBHLP=1
113 . S IBX=""
114 . ;
115 I IBX'="" D
116 . S:$L(IBX)<5 IBX="`"_IBX
117 . D FIND^DIC(399.0304,","_DA(1)_",","@;.01E","A",IBX,IBMAX,,"I '$$LINKED^IBCEU4(.DA,Y)")
118 . D XFER(0)
119 ;
120 S IBMANY=($G(^TMP("IBLIST",$J,0))>1)
121 I IBMANY D ;More than one match found
122 . I $D(DIQUIET) S ^TMP("IBLIST",$J,0)=0,IBX="" Q
123 . N IB1,IB2,IBSEL,IBGOT,IBCNT,Q,Q1
124 . S (IBGOT,IB1,IB2)=0
125 . F S IB1=$O(^TMP("IBLIST",$J,2,IB1)) Q:'IB1 D Q:IBGOT
126 .. S IB2=IB2+1
127 .. S Q=$J("",5)_$S('IBHLP:$E(IB2_$J("",5),1,5),1:"")_^TMP("IBLIST",$J,2,IB1)
128 .. F Q1=0:0 S Q1=$O(^TMP("IBLIST",$J,"ID",IB1,Q1)) Q:'Q1 D
129 ... I $G(^TMP("IBLIST",$J,"ID",IB1,Q1))'="" S Q=Q_" "_^TMP("IBLIST",$J,"ID",IB1,Q1) Q
130 ... I $G(^TMP("IBLIST",$J,"ID",IB1,Q1,"E"))'="" S Q=Q_" "_^TMP("IBLIST",$J,"ID",IB1,Q1,"E")
131 .. S IBSEL($S(IB2#IBEACH:IB2#IBEACH,1:IBEACH))=Q
132 .. I '$O(^TMP("IBLIST",$J,2,IB1))!'(IB1#IBEACH) D
133 ... M DIR("A")=IBSEL K IBSEL
134 ... I 'IBHLP D
135 .... S:$O(^TMP("IBLIST",$J,2,IB1)) DIR("A",6)="Press <RETURN> to see more, '^' to exit this list, OR"
136 .... S DIR("A")="SELECT 1-"_IB2_": "
137 .... S DIR(0)="NAO^1:"_IB2_":0"
138 .... S DIR("?")="Enter your selection for procedure from 1 to "_IB2
139 ... I IBHLP D
140 .... I $S(IB2'=+$G(^TMP("IBLIST",$J,0)):1,1:$P($G(^(0)),U,3)) S DIR("A")="'^' TO STOP: ",DIR(0)="EA" Q
141 .... S Z=0 F S Z=$O(DIR("A",Z)) Q:'Z W !,DIR("A",Z)
142 .... S Y="^" K DIR W ! Q
143 ... I $D(DIR("A")) D ^DIR K DIR
144 ... I IBHLP S Y=$S(Y=1:"",1:"^")
145 ... I Y="" D Q
146 .... I $O(^TMP("IBLIST",$J,2,IB1)) Q
147 .... S IBX=""
148 .... W:'IBHLP !
149 .... I $P($G(^TMP("IBLIST",$J,0)),U,3),IB1'<IBMAX D
150 ..... I 'IBHLP W !!,"There were more than ",IBMAX," matches found. Please try again with more specific input",! Q
151 ..... D RXPRHLP(IBMAX,.IBNEXT)
152 ... I Y["^" S IBX="",IBGOT=1 Q
153 ... I Y>0 S IBGOT=1,IBX=$G(^TMP("IBLIST",$J,2,+Y)) D RECALL^DILFD(399.0304,+IBX_",",DUZ)
154 . I 'IBGOT S ^TMP("IBLIST",$J,0)=0
155 I 'IBMANY,$G(^TMP("IBLIST",$J,0)) D
156 . N Q,Q1
157 . S Q=^TMP("IBLIST",$J,2,1)
158 . F Q1=0:0 S Q1=$O(^TMP("IBLIST",$J,"ID",1,Q1)) Q:'Q1 D
159 .. I $G(^TMP("IBLIST",$J,"ID",1,Q1))'="" S Q=Q_" "_^TMP("IBLIST",$J,"ID",1,Q1) Q
160 .. I $G(^TMP("IBLIST",$J,"ID",1,Q1,"E"))'="" S Q=Q_" "_^TMP("IBLIST",$J,"ID",1,Q1,"E")
161 . D EN^DDIOL($J("",16)_Q) S IBX=$G(^TMP("IBLIST",$J,2,1)) D RECALL^DILFD(399.0304,+IBX_",",DUZ)
162 ;
163 D CLEAN^DILF
164 K ^TMP("IBLIST",$J)
165 Q IBX
166 ;
167RXPRHLP(IBMAX,IBNEXT) ; Get list for ?? help
168 ;
169 ; IBMAX = The maximum # of entries to extract at once
170 ; IBNEXT = Contains the value of the index to start at
171 ;
172 N IBQ,IBZ
173 S IBQ=+$O(^TMP("IBLIST",$J,2,""),-1),IBZ=","_DA(1)_","
174 D LIST^DIC(399.0304,IBZ,"@;.01EI;1E",,IBMAX,.IBNEXT,,"B","I '$$LINKED^IBCEU4(.DA,Y)"),XFER(IBQ)
175 Q
176 ;
177LINKED(DA,Y) ; Function returns 1 if proc already linked to an RX rev code
178 ; DA = the DA array from the RC multiple
179 ; Y = the ien of the CP multiple
180 N Z
181 S Z=+$O(^DGCR(399,DA(1),"RC","ACP",Y,0))
182 Q $S(Z:Z'=DA,1:0)
183 ;
184XFER(IBQ) ; Transfer DILIST to IBLIST array
185 ; IBQ = the number of entries already found
186 N Z,IBZ
187 S (Z,IBZ)=0
188 F S Z=$O(^TMP("DILIST",$J,2,Z)) Q:'Z S IBZ=IBZ+1,^TMP("IBLIST",$J,2,IBZ+IBQ)=^TMP("DILIST",$J,2,Z) M ^TMP("IBLIST",$J,"ID",IBZ+IBQ)=^TMP("DILIST",$J,"ID",Z)
189 ;
190 I $D(^TMP("DILIST",$J,0)) S ^TMP("IBLIST",$J,0)=^TMP("DILIST",$J,0)
191 S $P(^TMP("IBLIST",$J,0),U)=IBQ+IBZ
192 Q
193 ;
194NOREV(DA,IBRX) ; Returns 1 if no other revenue code on bill DA(1)
195 ; is linked to prescription entry IBRX
196 N X,Z
197 S X=1,Z=0 F S Z=$O(^DGCR(399,DA(1),"RC",Z)) Q:'Z I DA'=Z,$P($G(^(Z,0)),U,11)=IBRX S X=0 Q
198 Q X
199 ;
200ASKRX(DA) ; Returns the selected RX entry in file 362.4
201 N DIR,X,Y
202 S DIR(0)="PAO^IBA(362.4,"
203 S DIR("A")=" RX: ",DIR("B")=$P($G(^IBA(362.4,+$P($G(^DGCR(399,DA(1),"RC",DA,0)),U,11),0)),U)
204 S DIR("S")="I $P(^(0),U,2)=DA(1),$$NOREV^IBCEU4(.DA,Y)"
205 D ^DIR K DIR
206 Q $S(Y>0:+Y,1:"")
207 ;
208SLF(IBIFN) ; Returns 1 if Attending/Rendering provider id is SLF000
209 N IB,IBZ
210 S IB=0
211 D F^IBCEF("N-ATT/REND PROVIDER ID","IBZ",,IBIFN)
212 S:$G(IBZ)="SLF000" IB=1
213 Q IB
214 ;
Note: See TracBrowser for help on using the repository browser.