source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF74.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: 8.7 KB
Line 
1IBCEF74 ;WOIFO/SS - FORMATTER/EXTRACT BILL FUNCTIONS ;31-JUL-03
2 ;;2.0;INTEGRATED BILLING;**232,280,155,290,291,320,358,343,374**;21-MAR-94;Build 16
3 ;; Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5SORT(IBPRNUM,IBPRTYP,IB399,IBSRC,IBDST,IBN,IBEXC,IBSEQ,IBLIMIT) ;
6 D SORT^IBCEF77($G(IBPRNUM),$G(IBPRTYP),$G(IB399),.IBSRC,.IBDST,$G(IBN),$G(IBEXC),$G(IBSEQ),$G(IBLIMIT))
7 Q
8 ;
9 ;-- PROVINF --
10 ;Create array with prov info
11 ;Input:
12 ; IB399 - ien #399
13 ; IBPRNUM - 1=prim ins, 2= sec, 3 -tert
14 ; IBRES - for results
15 ; IBSORT - to sort OTHER INSURANCE data
16 ; if PROVINF is called for "C" mode of PROVIDER subroutine then
17 ; IBSORT can be any (say 1)
18 ; if PROVINF is called for "O" mode then can be more than set of data
19 ; - need to sort array to use it (like IBXDATA(1) and IBXDATA(2))
20 ; for mode "O" it should be 1 or 2 (see PROVIDER section)
21 ;IBINSTP - "C" -current ins, "O"-other
22 ;Output:
23 ; IBRES(PRNUM,PRTYPE,SEQ#)=PROV^INSUR^IDTYPE^ID^FORMTYP^CARETYP
24 ; where:(see PROVIDER)
25PROVINF(IB399,IBPRNUM,IBRES,IBSORT,IBINSTP) ;
26 I $G(IB399)="" Q
27 I +$G(IBSORT)=0 S IBSORT=$G(IBPRNUM)
28 N IBPRTYP,IBINSCO,IBPROV,IBFRMTYP,IBCARE,IB35591,IBN,IBCURR,IBEXC,IBALLSSN,IBSSNIEN,IBLIMIT
29 S IBN=0
30 D F^IBCEF("N-ALL ATT/RENDERING PROV SSN","IBALLSSN",,IB399)
31 S Q=0 F S Q=$O(^IBE(355.97,Q)) Q:'Q I $P($G(^(Q,0)),U,3)="SY" S IBSSNIEN=Q Q
32 S IBINSCO=+$P($G(^DGCR(399,IB399,"M")),"^",IBPRNUM)
33 S IBFRMTYP=$$FT^IBCEF(IB399),IBFRMTYP=$S(IBFRMTYP=2:2,IBFRMTYP=3:1,1:0)
34 S IBCARE=$S($$ISRX^IBCEF1(IB399):3,1:0) ;if an Rx refill bill
35 S:IBCARE=0 IBCARE=$$INPAT^IBCEF(IB399,1) S:'IBCARE IBCARE=2 ;1-inp,2-out
36 S IBLIMIT=$S($G(IBINSTP)="C":5,1:3) ; Limits on secondary IDs
37 F IBPRTYP=1:1:9 D
38 . N Z,IB355OV
39 . S IBPROV=$$PROVPTR^IBCEF7(IB399,IBPRTYP)
40 . Q:+IBPROV=0
41 . ;don't create anything if form type not CMS-1500 or UB
42 . Q:IBFRMTYP=0
43 . N IBRETARR S IBRETARR=0
44 . D PRACT^IBCEF71(IBINSCO,IBFRMTYP,IBCARE,IBPROV,.IBRETARR,IBPRTYP,$G(IBINSTP))
45 . S IB355OV="",IBEXC=""
46 . S Z=$O(^DGCR(399,IB399,"PRV","B",IBPRTYP,0))
47 . I Z S Z=$G(^DGCR(399,IB399,"PRV",Z,0)) D
48 .. I $P(Z,U,IBPRNUM+4)'="",$P(Z,U,IBPRNUM+11)'="" S IB355OV=$P(Z,U,IBPRNUM+4)_U_$P(Z,U,IBPRNUM+11)
49 . S IBCURR=$$COB^IBCEF(IB399)
50 . S IBN=0,IB35591=$$CH35591^IBCEF72(IBINSCO,IBFRMTYP,IBCARE)
51 . I $G(IBINSTP)="C",$G(IBPRNUM)=1,"34"[$G(IBPRTYP),"P"[$G(IBCURR),$G(IBFRMTYP)=2,$$MCRONBIL^IBEFUNC(IB399) S IB355OV=$$MCR24K^IBCEU3(IB399)_"^12"
52 . I $G(IBINSTP)="O","34"[$G(IBPRTYP),"ST"[$G(IBCURR),$G(IBFRMTYP)=2,$$MCRONBIL^IBEFUNC(IB399) S IB355OV=$$MCR24K^IBCEU3(IB399)_"^12" ;Calculate MEDICARE (WNR) specific provider qualifier and ID for CMS-1500 secondary claims
53 . I $P(IB355OV,U,2) D
54 .. I $$CHCKSEC^IBCEF73(IBFRMTYP,IBPRTYP,$G(IBINSTP),$P($G(^IBE(355.97,+$P(IB355OV,U,2),0)),U,3)) D
55 ... S IBEXC=$P(IB355OV,U,2),IBN=IBN+1,IBRES(IBSORT,IBPRTYP,IBN)="OVERRIDE^"_IBINSCO_U_$P($G(^IBE(355.97,+IBEXC,0)),U,3)_U_$P(IB355OV,U)_"^^^^^"_+IBEXC
56 . I IB35591'="",IBEXC'=$P(IB35591,U,3) S:$$CHCKSEC^IBCEF73(IBFRMTYP,IBPRTYP,$G(IBINSTP),$P(IB35591,"^")) IBN=IBN+1,IBRES(IBSORT,IBPRTYP,IBN)="DEFAULT^"_IBINSCO_"^"_IB35591_"^^",$P(IBRES(IBSORT,IBPRTYP,IBN),U,9)=$P(IB35591,U,3)
57 . D SORT(IBSORT,IBPRTYP,IB399,.IBRETARR,.IBRES,IBN,IBEXC,IBPRNUM,IBLIMIT)
58 . S IBRES(IBSORT,IBPRTYP)=IBPROV
59 S IBRES(IBSORT)=$S(IBPRNUM=3:"T",IBPRNUM=2:"S",1:"P")
60 Q
61 ;
62SECIDCK(IBIFN,IBSEQ,IBTYP,IBIFN1) ; Function returns 1 if ID type ptr in
63 ; IBTYP is valid X12 code for the claim/prov function (IBPROVF)
64 ; as a sec id
65 ; IBSEQ = COB seq being checked
66 ; IBIFN1 = entry # in PRV multiple being checked
67 ; Called from input transform of fields .12-.14, subfile 399.0222
68 I $G(IBIFN)="" Q
69 N IBOK,IBFRM,IBCOBN,IBX12,IBPROVF
70 S IBPROVF=+$G(^DGCR(399,IBIFN,"PRV",IBIFN1,0))
71 S IBFRM=$$FT^IBCEF(IBIFN),IBFRM=$S(IBFRM=3:1,1:2) ; Form type
72 S IBCOBN=$$COBN^IBCEF(IBIFN) S:'IBCOBN IBCOBN=1 ; Current COB seq
73 S IBX12=$P($G(^IBE(355.97,+IBTYP,0)),U,3) ; X12 code for prov id typ
74 Q $$CHSEC^IBCEF73(IBFRM,IBPROVF,$S(IBSEQ=IBCOBN:"C",1:"O"),IBX12)
75 ;
76DEFID(IBIFN,IBPRV) ;
77 ; IBIFN = ien of bill
78 ; IBPRV = ien of entry subfile 399.0222
79 ; Function returns default ids: prim id def^sec id def^tert id def
80 ; SSN cannot be the default ID
81 I $G(IBIFN)="" Q ""
82 N Z,Z1,ID,IBZ,IBINS,IBINS4,IBUB
83 S IBZ=""
84 S IBUB=($$FT^IBCEF(IBIFN)=3)
85 D F^IBCEF("N-ALL ATT/REND PROV SSN/EI","IBZ","",IBIFN)
86 S Z=$G(^DGCR(399,IBIFN,"PRV",IBPRV,0)),ID=$P(Z,U,5,7)
87 F Z1=1:1:3 I $P(ID,U,Z1)="" D
88 . Q:'$G(^DGCR(399,IBIFN,"I"_Z1)) S IBINS=+^("I"_Z1)
89 . S $P(ID,U,Z1)=$$GETID^IBCEP2(IBIFN,2,$P(Z,U,2),Z1)
90 . ; Set default if null
91 . I $P(ID,U,Z1)="" S $P(ID,U,Z1)="VAD000"
92 Q ID
93 ;
94DISPID(IBXIEN) ; Display list of all prov and fac ids that will
95 ; extract for this bill if transmitted electronically
96 I $G(IBXIEN)="" Q
97 N IBID,IBID1,IBZ,IBCT,IBFRM,IBCOBN,IBATT,IBQUIT,IBTYP,DIR,IBIFN,X,Y,Z,Z0,Z1
98 N IBNPI,IBNONPI
99 S IBIFN=IBXIEN
100 S IBFRM=$$FT^IBCEF(IBIFN),IBCOBN=$$COBN^IBCEF(IBIFN),IBATT=$S(IBFRM=2:3,1:4)
101 W @IOF
102 W !,"If this bill is transmitted electronically, the following IDs will be sent:"
103 ; Returns all prov sec ids to be transmitted in indicated segments
104 S Z=+$G(^DGCR(399,IBIFN,"I1")) I Z W !," Primary Ins Co: ",$$EXTERNAL^DILFD(399,101,"",Z) I IBCOBN=1 W ?54,"<<<Current Ins"
105 S Z=+$G(^DGCR(399,IBIFN,"I2")) I Z W !,"Secondary Ins Co: ",$$EXTERNAL^DILFD(399,101,"",Z) I IBCOBN=2 W ?54,"<<<Current Ins"
106 S Z=+$G(^DGCR(399,IBIFN,"I3")) I Z W !," Tertiary Ins Co: ",$$EXTERNAL^DILFD(399,101,"",Z) I IBCOBN=3 W ?54,"<<<Current Ins"
107 W !!,"Provider IDs: (VistA Records OP1,OP2,OP4,OP8,OP9,OPR2,OPR3,OPR4,OPR5,OPR8):"
108 F Z=1:1:3 I $G(^DGCR(399,IBIFN,"I"_Z)) D PROVINF(IBIFN,Z,.IBID,"",$S(IBCOBN=Z:"C",1:"O"))
109 S Z=0 F S Z=$O(IBID(Z)) Q:'Z S Z0=0 F S Z0=$O(IBID(Z,Z0)) Q:'Z0 S IBID1(Z0,Z)="",Z1=0 F S Z1=$O(IBID(Z,Z0,Z1)) Q:'Z1 I $P(IBID(Z,Z0,Z1),U,9) S IBID1(Z0,Z,Z1)=IBID(Z,Z0,Z1)
110 ; PRXM/KJH - Add NPI to display for patch 343.
111 S IBNPI=$$PROVNPI^IBCEF73A(IBIFN,.IBNONPI)
112 S Z=+$O(^DGCR(399,IBIFN,"PRV","B",IBATT,0))
113 I Z S Z=$P($G(^DGCR(399,IBIFN,"PRV",Z,0)),U,2)
114 W !,?5,"ATTENDING/RENDERING: ",$$EXTERNAL^DILFD(399.0222,.02,"",Z)
115 D F^IBCEF("N-ALL ATT/REND PROV SSN/EI","IBZ","",IBIFN)
116 W !,?8,"NPI: ",?40,$S($P(IBNPI,U,IBATT)'="":$P(IBNPI,U,IBATT),1:"***MISSING***")
117 W !,?8,"SSN: ",?40,$S($P(IBZ,U,IBATT)'="":$P(IBZ,U,IBATT),1:"***MISSING***")
118 I $O(IBID1(IBATT,0)) W !,?8,"Secondary IDs"
119 S IBQUIT=0
120 ;
121 ; Attending/Rendering (4/3) secondary IDs
122 S Z0=0 F S Z0=$O(IBID1(IBATT,Z0)) Q:'Z0!IBQUIT K IBTYP S Z1=0 F S Z1=$O(IBID1(IBATT,Z0,Z1)) Q:'Z1 D Q:IBQUIT
123 . Q:$D(IBTYP(+$P(IBID1(IBATT,Z0,Z1),U,9))) ;1st of each type transmits
124 . I ($Y+5)>IOSL S IBQUIT=$$NOMORE() Q:IBQUIT
125 . S IBTYP(+$P(IBID1(IBATT,Z0,Z1),U,9))=""
126 . W !,?8,"(",$E("PST",Z0),") ",$$EXTERNAL^DILFD(36,4.01,"",$P(IBID1(IBATT,Z0,Z1),U,9)),?40,$P(IBID1(IBATT,Z0,Z1),U,4)
127 . Q
128 I IBQUIT G DISPIDX
129 ;
130 ; Referring(1), Operating(2), Supervising(5), Other(9) secondary IDs
131 ; PRXM/KJH - Patch 343. Modified first loop so it will always display provider and NPI and conditionally display other data.
132 ; S Z=0 F S Z=$O(IBID1(Z)) Q:'Z I Z<3!(Z>4) D Q:IBQUIT
133 S Z=0 F S Z=$O(^DGCR(399,IBIFN,"PRV","B",Z)) Q:'Z I Z<3!(Z>4) D Q:IBQUIT
134 . N Q
135 . S Q=+$O(^DGCR(399,IBIFN,"PRV","B",Z,0))
136 . W !!,?5,$$EXTERNAL^DILFD(399.0222,.01,"",Z),": "_$$EXTERNAL^DILFD(399.0222,.02,"",$P($G(^DGCR(399,IBIFN,"PRV",Q,0)),U,2))
137 . W !,?8,"NPI: ",?40,$S($P(IBNPI,U,Z)'="":$P(IBNPI,U,Z),1:"***MISSING***")
138 . S Z0=0 F S Z0=$O(IBID1(Z,Z0)) Q:'Z0!IBQUIT K IBTYP S Z1=0 F S Z1=$O(IBID1(Z,Z0,Z1)) Q:'Z1!IBQUIT D
139 .. Q:$D(IBTYP(+$P(IBID1(Z,Z0,Z1),U,9))) ; 1st of each type transmits
140 .. I ($Y+5)>IOSL S IBQUIT=$$NOMORE() Q:IBQUIT
141 .. S IBTYP(+$P(IBID1(Z,Z0,Z1),U,9))=""
142 .. W !,?8,"(",$E("PST",Z0),") ",$$EXTERNAL^DILFD(36,4.01,"",$P(IBID1(Z,Z0,Z1),U,9)),?40,$P(IBID1(Z,Z0,Z1),U,4)
143 .. Q
144 . Q
145 I IBQUIT G DISPIDX
146 ;
147 ; IB*2*320 - display additional IDs for ?ID
148 D EN^IBCEF74A(IBIFN,.IBQUIT)
149 ;
150DISPIDX ;
151 I '$G(IBQUIT) S DIR(0)="EA",DIR("A")="Press RETURN to continue " W ! D ^DIR K DIR
152 Q
153 ;
154NOMORE() ;
155 S DIR(0)="EA",DIR("A")="Press RETURN for more IDs or '^' to exit: " W ! D ^DIR
156 W @IOF
157 Q (Y'=1)
158 ;
159DEFSEC(IBIFN,IBARR) ; Returns array in IBARR for default prov sec ids for ien IBIFN
160 ; IBARR if passed by ref is returned IBARR(prov function,COBN)=def id
161 I $G(IBIFN)=""
162 N IBCAR,IBCOBN,IBPC,IBINS,IBARRX,Q,Z,Z0,ZINS,X
163 K IBARR
164 S ZINS="",IBCOBN=$$COBN^IBCEF(IBIFN),IBPC=$S($$FT^IBCEF(IBIFN)=3:2,1:1)
165 S IBCAR=$$INPAT^IBCEF(IBIFN,1),IBCAR=$S('IBCAR:2,1:1)
166 F Z=1:1:3 S ZINS=ZINS_+$G(^DGCR(399,IBIFN,"I"_Z))_U
167 F Z=1:1:3 I $P(ZINS,U,Z),'$P($G(^DIC(36,+$P(ZINS,U,Z),4)),U,IBPC) S $P(ZINS,U,Z)=""
168 S Z=0 F S Z=$O(^DGCR(399,IBIFN,"PRV",Z)) Q:'Z S Z0=$G(^(Z,0)) D
169 . F Q=1:1:3 D
170 .. I $P(Z0,U,Q+4)'="" S IBARR(+Z0,Q)=$P(Z0,U,Q+4) Q ; Override
171 .. S IBINS=$P(ZINS,U,Q)
172 .. Q:'IBINS
173 .. S X=$$IDFIND^IBCEP2(IBIFN,"",$P(Z0,U,2),Q,1)
174 .. I X'="" S IBARR(+Z0,Q)=X
175 Q
176 ;
Note: See TracBrowser for help on using the repository browser.