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

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

initial load of WorldVistAEHR

File size: 7.3 KB
Line 
1IBCEP2A ;ALB/TMP - EDI UTILITIES for provider ID ;25-APR-01
2 ;;2.0;INTEGRATED BILLING;**137,232,320,348,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5ALT(IBPERF,IBSRC,IBALT,IBINS4,IBPTYP) ; set source level to next higher level
6 ; or set the alternate type and source if performing provider id
7 ; alternate type and source exist
8 ; IBPERF = 1 if performing provider id is requested
9 ; IBINS4 = '4' node of insurance co (file 36)
10 ; Pass IBPTYP by reference to get alternate provider id type
11 ; Pass IBALT by reference. Set to 1 if alternate id is to be used next
12 ;
13 I '$G(IBPERF)!($P(IBINS4,U,3)=1) S IBSRC=IBSRC-1 G ALTQ
14 S IBSRC=""
15 I '$G(IBALT),$P(IBINS4,U,3)=2,$P(IBINS4,U,10),$P(IBINS4,U,11) S IBALT=1,IBSRC=$P(IBINS4,U,11),IBPTYP=$P(IBINS4,U,10) S:IBPTYP="" IBPTYP=$P(IBINS4,U)
16 ;
17ALTQ Q IBSRC
18 ;
19IDSET(IBPTYP,IBINS4,IBPERF,IBSPEC,IBSRC,IBUP) ; set variables for provider id type search
20 N Z
21 S IBSPEC=$G(^IBE(355.97,+IBPTYP,1))
22 S Z=$S($G(IBPERF):2,$P(IBSPEC,U,5):6,$P(IBSPEC,U,6):4,1:2)
23 S IBSRC=$P(IBINS4,U,Z),IBUP=$P(IBINS4,U,$S(IBSRC:Z+1,1:0))
24 Q
25 ;
26CAREST(IBIFN) ; Return state file ien of state where care was performed
27 ; IBIFN = ien of bill in file 399
28 ; Get it from rendering facility or if none, the billing facility
29 N Z,IBXDATA,STATE
30 S STATE=""
31 D F^IBCEF("N-RENDERING INSTITUTION",,,IBIFN)
32 I IBXDATA D
33 . I '$P(IBXDATA,U,2) S STATE=+$P($G(^DIC(4,+IBXDATA,0)),U,2) Q
34 . S STATE=+$P($G(^IBA(355.93,+IBXDATA,0)),U,7)
35 E D
36 . D F^IBCEF("N-AGENT CASHIER STATE",,,IBIFN)
37 . S STATE=IBXDATA
38 Q STATE
39 ;
40RECALCA(IBIFN) ; Recalculate all performing provider id's on bill IBIFN
41 ; IBIFN = ien of bill entry (file 399)
42 N IBZ,IBZ0,IBX,IBP,IBSEQ,DA,DIE,DR,DIR,X,Y
43 ;
44 D EN^DDIOL("THIS FUNCTION HAS BEEN DISABLED",,"!") Q
45 ;
46 S DA(1)=IBIFN
47 I '$D(^XUSEC("IB SUPERVISOR",DUZ)) D EN^DDIOL("YOU ARE NOT AUTHORIZED TO PERFORM THIS FUNCTION",,"!")
48 S IBZ=0 F S IBZ=$O(^DGCR(399,IBIFN,"PRV",IBZ)) Q:'IBZ S IBP=$G(^(IBZ,0)) I $P(IBP,U,2)'="" D
49 . S DA=IBZ
50 . F IBZ0=5:1:7 Q:'$G(^DGCR(399,IBIFN,"I"_(IBZ0-4))) D
51 .. S IBSEQ=$$EXPAND^IBTRE(399.0222,.01,+IBP)_" "_$P("PRIMARY^SECONDARY^TERTIARY",U,IBZ0-4)_" PROVIDER ID "
52 .. S IBX=$$RECALC(.DA,IBZ0-4,$P(IBP,U,IBZ0),1)
53 .. I IBX'="",IBX=$P(IBP,U,IBZ0) D EN^DDIOL(IBSEQ_"NO CHANGE NEEDED",,"!") Q
54 .. I IBX'="",IBX'=$P(IBP,U,IBZ0) D Q
55 ... S DR=(IBZ0/100)_"////"_IBX,DIE="^DGCR(399,"_DA(1)_",""PRV""," D ^DIE
56 ... D EN^DDIOL(IBSEQ_"CHANGED TO "_IBX,,"!")
57 .. D EN^DDIOL(IBSEQ_"NOT FOUND",,"!")
58 Q
59 ;
60RECALC(IBDA,IBSEQ,IBX,IBD) ; Recalculate id #, if possible - called
61 ; from input transforms in subfile 399.0222, fields .05-.07
62 ; IBDA = DA array of the provider entry (file 399.0222)
63 ; IBSEQ = the numeric COB sequence of the provider id (1-3)
64 ; IBX = the current value of the id in the subfile
65 ; IBD = flag that if set to 1 will suppress the display text
66 ;
67 N IBPN,IBZ
68 S IBPN=$P($G(^DGCR(399,IBDA(1),"PRV",IBDA,0)),U,2)
69 I IBPN="" D:'$G(IBD) EN^DDIOL(" CAN'T CALCULATE WITHOUT A PROVIDER NAME","","?0") G RECALCQ
70 S IBZ=$$GETID^IBCEP2(IBDA(1),2,IBPN,IBSEQ)
71 I IBZ="" D:'$G(IBD) EN^DDIOL(" ID COULD NOT BE DETERMINED","","?0") G RECALCQ
72 D:'$G(IBD) EN^DDIOL(" "_IBZ_$S(IBZ'=IBX:"",1:" (no change)"),"","?0")
73 S IBX=IBZ
74 ;
75RECALCQ Q IBX
76 ;
77PERFPRV(IBIFN) ; Returns the variable pointer of the 'performing provider'
78 ; (attending or rendering) for a bill IBIFN
79 N IBP,IBPT,IBQ,Z
80 S Z=$$FT^IBCEF(IBIFN),IBPT=$S(Z=2:3,Z=3:4,1:0)
81 D GETPRV^IBCEU(IBIFN,IBPT,.IBP)
82 Q $P($G(IBP(IBPT,1)),U,3)
83 ;
84INSPAR(IBIFN,SEQ) ;
85 N Z,Z4,Z0
86 Q:$G(X)'="??"
87 S:'$G(SEQ) SEQ=$$COBN^IBCEF(IBIFN)
88 S Z=+$G(^DGCR(399,IBIFN,"I"_SEQ)),Z4=$G(^DIC(36,Z,4))
89 I Z D
90 . D EN^DDIOL(">"_$J("",20)_"-- PERFORMING PROVIDER ID PARAMETERS --",,"!")
91 . S Z0=$P(" PRIMARY^SECONDARY^ TERTIARY",U,SEQ)_" INSURANCE: "_$P($G(^DIC(36,Z,0)),U)
92 . D EN^DDIOL(">"_$J("",(80-$L(Z0))\2)_Z0,,"!")
93 . D EN^DDIOL("> Secondary Perf Prov ID Type (1500): "_$$EXPAND^IBTRE(36,4.01,+Z4),,"!")
94 . D EN^DDIOL("> Secondary Perf Prov ID Type (UB04): "_$$EXPAND^IBTRE(36,4.02,$P(Z4,U,2)),,"!")
95 . D EN^DDIOL("> Secondary Perf Prov IDs Required: "_$$EXPAND^IBTRE(36,4.03,$P(Z4,U,3)),,"!")
96 . D EN^DDIOL(" ",,"!")
97 Q
98 ;
99GETTYP(IBXIEN,IBCOBN,IBFUNC) ; Function returns provider id type for insurance co
100 ; with COB of IBCOBN on claim ien IBXIEN in first ^ pc and 1 in second
101 ; ^ piece if the id is required
102 ;
103 ; IBFUNC=1:REFERRING;2:OPERATING;3:RENDERING;4:ATTENDING;5:SUPERVISING;9:OTHER
104 ;
105 N A,R,Z,Z0
106 S A="",R=0
107 S:'$G(IBCOBN)!(IBCOBN>3) IBCOBN=$$COBN^IBCEF(IBXIEN)
108 S Z=+$G(^DGCR(399,IBXIEN,"I"_+IBCOBN))
109 I Z D
110 . S Z0=$$FT^IBCEF(IBXIEN)
111 . S A=+$P($G(^DIC(36,Z,4)),U,$S(Z0=2&($G(IBFUNC)=1):4,Z0=2:1,1:2))
112 . I A,$G(IBFUNC)'=1 S R=$P($G(^DIC(36,Z,4)),U,3),R=$S('R:0,R=3:1,R=1:Z0=2,R=2:Z0=3,1:0)
113 . I A,$G(IBFUNC)=1 S R=+$P($G(^DIC(36,Z,4)),U,5),R=$S('R:0,Z0'=2:0,1:1)
114 Q A_U_R
115 ;
116UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,IBUNIT,IBCU,IBT) ; Match most-least specific
117 ; *** SEE PARAMETER DEFINITIONS IN IBCEP3 ***
118 ;
119 ; Start in file 355.9 (Specific Provider)
120 ; IBPROV = (variable pointer syntax) provider on bill IBIFN
121 ;
122 N Q,Z0,Z1,Z2,IBID,IBX
123 S IBID=""
124 S IBX=$P($G(^IBA(355.9,+IBCU,0)),U,3) S:"0"[IBX IBX="*N/A*"
125 S Z0=$$FT^IBCEF(IBIFN),Z0=$S(Z0=2:2,Z0=3:1,1:0),Z1=$$INPAT^IBCEF(IBIFN,1) S:'Z1 Z1=2 S Z2=$$ISRX^IBCEF1(IBIFN)
126 ;
127 ; Match all elements
128 F Q=$S(Z2:3,1:Z1),$S(Z2:Z1,1:"") I Q'="",$D(^IBA(355.9,"AUNIQ",IBPROV,IBINS,IBX,Z0,Q,IBPTYP,IBCU)) S IBID=$P($G(^IBA(355.9,IBCU,0)),U,7),$P(IBT,U,2,3)=(IBCU_U_355.9) Q
129 G:IBID'="" UNIQ1Q
130 ;
131 ; Match both form types,specific I/O element
132 F Q=$S(Z2:3,1:Z1),$S(Z2:Z1,1:"") I Q'="",$D(^IBA(355.9,"AUNIQ",IBPROV,IBINS,IBX,0,Q,IBPTYP,IBCU)) S IBID=$P($G(^IBA(355.9,IBCU,0)),U,7),$P(IBT,U,2,3)=(IBCU_U_355.9) Q
133 G:IBID'="" UNIQ1Q
134 ;
135 ; Match specific form type, both I/O element or Rx
136 F Q=$S(Z2:3,1:0),$S(Z2:0,1:"") I Q'="",$D(^IBA(355.9,"AUNIQ",IBPROV,IBINS,IBX,Z0,Q,IBPTYP,IBCU)) S IBID=$P($G(^IBA(355.9,IBCU,0)),U,7),$P(IBT,U,2,3)=(IBCU_U_355.9) Q
137 G:IBID'="" UNIQ1Q
138 ;
139 ; Match both form types, both I/O element or Rx
140 F Q=$S(Z2:3,1:0),$S(Z2:0,1:"") I Q'="",$D(^IBA(355.9,"AUNIQ",IBPROV,IBINS,IBX,0,Q,IBPTYP,IBCU)) S IBID=$P($G(^IBA(355.9,IBCU,0)),U,7),$P(IBT,U,2,3)=(IBCU_U_355.9) Q
141 ;
142UNIQ1Q Q IBID
143 ;
144UNIQ2(IBIFN,IBINS,IBPTYP,IBUNIT,IBCU,IBT) ; Match on most-least specific
145 ; *** SEE PARAMETER DEFINITIONS IN IBCEP3 ***
146 ;
147 ; Start in file 355.91 (Specific Insurance)
148 ;
149 N Q,Z0,Z1,Z2,IBID,IBX
150 S IBID="" S:"0"[$G(IBUNIT) IBUNIT="*N/A*"
151 S Z0=$$FT^IBCEF(IBIFN),Z0=$S(Z0=2:2,Z0=3:1,1:0),Z1=$$INPAT^IBCEF(IBIFN,1) S:'Z1 Z1=2 S Z2=$$ISRX^IBCEF1(IBIFN)
152 ;
153 ; Match all elements
154 F Q=$S(Z2:3,1:Z1),$S(Z2:Z1,1:"") I Q'="",$D(^IBA(355.91,"AUNIQ",IBINS,IBUNIT,Z0,Q,IBPTYP,IBCU)) S IBID=$P($G(^IBA(355.91,IBCU,0)),U,7),$P(IBT,U,2,3)=(IBCU_U_355.91) Q
155 G:IBID'="" UNIQ2Q
156 ;
157 ; Match both form types,specific I/O element
158 F Q=$S(Z2:3,1:Z1),$S(Z2:Z1,1:"") I Q'="",$D(^IBA(355.91,"AUNIQ",IBINS,IBUNIT,0,Q,IBPTYP,IBCU)) S IBID=$P($G(^IBA(355.91,IBCU,0)),U,7),$P(IBT,U,2,3)=(IBCU_U_355.91) Q
159 G:IBID'="" UNIQ2Q
160 ;
161 ; Match specific form type, both I/O element or Rx
162 F Q=$S(Z2:3,1:0),$S(Z2:0,1:"") I Q'="",$D(^IBA(355.91,"AUNIQ",IBINS,IBUNIT,Z0,Q,IBPTYP,IBCU)) S IBID=$P($G(^IBA(355.91,IBCU,0)),U,7),$P(IBT,U,2,3)=(IBCU_U_355.91) Q
163 G:IBID'="" UNIQ2Q
164 ;
165 ; Match both form types, both I/O elements or Rx
166 F Q=$S(Z2:3,1:0),$S(Z2:0,1:"") I Q'="",$D(^IBA(355.91,"AUNIQ",IBINS,IBUNIT,0,Q,IBPTYP,IBCU)) S IBID=$P($G(^IBA(355.91,IBCU,0)),U,7),$P(IBT,U,2,3)=(IBCU_U_355.91) Q
167 ;
168UNIQ2Q Q IBID
169 ;
Note: See TracBrowser for help on using the repository browser.