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

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

revised back to 6/30/08 version
File size: 9.4 KB
Line 
1IBCCC2 ;ALB/AAS - CANCEL AND CLONE A BILL - CONTINUED ;6/6/03 9:56am
2 ;;2.0;INTEGRATED BILLING;**80,106,124,138,51,151,137,161,182,211,245,155,296,320,348,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;MAP TO DGCRCC2
6 ;
7 ;STEP 5 - get remainder of data to move and store in MCCR then x-ref
8 ;STEP 6 - go to screens, come out to IBB1 or something like that
9 ;
10STEP5 S IBIFN1=$P(^DGCR(399,IBIFN,0),"^",15) G END:$S(IBIFN1="":1,'$D(^DGCR(399,IBIFN1,0)):1,1:0)
11 ;
12 ;move pure data nodes
13 F I="I1","I2","I3","M1" I $D(^DGCR(399,IBIFN1,I)) S ^DGCR(399,IBIFN,I)=^DGCR(399,IBIFN1,I)
14 ;
15 ;move top level data node. ;Do not move 'TX' node
16 F I="U","U1","U2","U3","UF2","UF3","UF31","C","M" I $D(^DGCR(399,IBIFN1,I)) S IBND(I)=^(I) D @I
17 ;
18 ;move multiple level data
19 F I="CC","OC","OP","OT","RC","CP","CV","PRV" I $D(^DGCR(399,IBIFN1,I,0)) D @I
20 ;
21 D FTPRV^IBCEU5(IBIFN) ; Ask change prov type if form type not the same
22 D COBCHG(IBIFN,,.IBCOB)
23 ;
24 D ^IBCCC3 ; copy table files (362.3)
25 ;
26 S I=$G(^DGCR(399,IBIFN1,0)) I $P(I,U,13)=7,$P(I,U,20)=1 D COPYB^IBCDC(IBIFN1,IBIFN) ; update auto bill files
27 D PRIOR(IBIFN) ; add new bill to previous bills in series, primary/secondary
28 I +$G(IBCTCOPY) N IBAUTO S IBAUTO=1 D PROC^IBCU7A(IBIFN),BILL^IBCRBC(IBIFN),CPTMOD26^IBCU73(IBIFN) D RECALL^DILFD(399,IBIFN_",",DUZ) G END
29 ;
30STEP6 N IBGOEND
31 I '$G(IBCE("EDI"))!$G(IBCE("EDI","NEW")),'$G(IBCEAUTO) D IBSCEDT G END:$G(IBGOEND)
32 ;
33 ;
34END K DFN,IB,IBA,IBA2,IBAD,IBADD1,IBBNO,IBCAN,IBCCC,IBDA,IBDPT,IBDR,IBDT,IBI,IBI1,IBIDS,IBIFN,IBIFN1,IBND,IBQUIT,IBU,IBUN,IBARST,IBCOB,IBCNCOPY,IBCBCOPY
35 K IBV,IBV1,IBW,IBWW,IBYN,IBZZ,PRCASV,PRCAERCD,PRCAERR,PRCASVC,PRCAT,IBBT,IBCH,IBNDS,IBOA,IBREV,IBX,DGXRF1,VAEL,VAERR,IBAC,IBCCC,IBDD1,IBIN,DGREV,DGREV00,DGREVHDR,IBCHK
36 K IBBS,IBLS,DGPCM,IBIP,IBND0,IBNDU,IBO,IBPTF,IBST,IBUC,IBDD,D,%,%DT,DIC,VA,VADM,X,X1,X2,X3,X4,Y,I,J,K,DGRVRCAL,DDH,DGACTDT,DGAMNT,DGBR,DGBRN,DGBSI,DGBSLOS,IBA1,IBOD,IBINS,IBN,IBPROC,DGFUNC,DGIFN
37 Q
38 ;
39 ;
40IBSCEDT ; call the IB bill edit screens and validate the data
41 N IBV,IBPAR,IBAC,IBHV,IBH,IBCIREDT
42 D RECALL^DILFD(399,IBIFN_",",DUZ)
43ST1 S IBV=0 D ^IBCSCU,^IBCSC1 I $G(IBPOPOUT) S IBGOEND=1 G IBSCX
44 S IBAC=1
45 D ^IBCB1
46 I $G(IBCIREDT) G ST1
47IBSCX ;
48 Q
49 ;
50 ;
51U F J=3,4,6:1:17,20 I $P(IBND("U"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U"),"^",J)=$P(IBND("U"),"^",J)
52 Q
53U1 F J=1:1:9,13,14 I $P(IBND("U1"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U1"),"^",J)=$P(IBND("U1"),"^",J)
54 Q
55U2 F J=1:1:19 I $P(IBND("U2"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U2"),"^",J)=$P(IBND("U2"),"^",J)
56 Q
57U3 F J=1:1:3 I $P(IBND("U3"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U3"),"^",J)=$P(IBND("U3"),"^",J)
58 Q
59UF2 F J=1,3 I $P(IBND("UF2"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF2"),"^",J)=$P(IBND("UF2"),"^",J)
60 Q
61UF3 F J=1:1:7 I $P(IBND("UF3"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF3"),"^",J)=$P(IBND("UF3"),"^",J)
62 Q
63UF31 F J=1:1:3 I $P(IBND("UF31"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF31"),"^",J)=$P(IBND("UF31"),"^",J)
64 Q
65C F J=10 I $P(IBND("C"),"^",J)]"" S $P(^DGCR(399,IBIFN,"C"),"^",J)=$P(IBND("C"),"^",J)
66 I '$D(^DGCR(399,IBIFN1,"CP")) D CP1
67 Q
68M F J=1:1:14 I $P(IBND("M"),"^",J)]"" S $P(^DGCR(399,IBIFN,"M"),"^",J)=$P(IBND("M"),"^",J)
69 Q
70CC S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
71 S IBDD=399.04 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
72OP S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
73 S IBDD=399.043 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
74 Q
75OC S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
76 S IBDD=399.041 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
77 Q
78OT S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
79 S IBDD=399.048 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
80 Q
81CV ; Don't copy value codes from inpatient inst to inpatient prof bills
82 I $$FT^IBCEF(IBIFN1)'=2,$$FT^IBCEF(IBIFN)=2 Q
83 S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
84 S IBDD=399.047 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
85 Q
86RC S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
87 S IBDD=399.042 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S IBND("RC")=^(0) F K=1:1:15 S $P(^DGCR(399,IBIFN,I,J,0),"^",K)=$P(IBND("RC"),"^",K),X=$P(IBND("RC"),"^",K)
88 Q
89CP S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
90 I +$G(IBNOCPT) Q
91 S IBDD=399.0304 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S IBND("CP")=^(0),IBND("CP-AUX")=$G(^("AUX")) D
92 . F K=1:1:7,9:1:14,16:1:22 S $P(^DGCR(399,IBIFN,I,J,0),"^",K)=$P(IBND("CP"),"^",K)
93 . ; esg - 11/2/06 - IB*2*348 - 50.09 field was added - AUX piece [9]
94 . I IBND("CP-AUX")'="" F K=1:1:9 S $P(^DGCR(399,IBIFN,I,J,"AUX"),"^",K)=$P(IBND("CP-AUX"),"^",K)
95 . I $D(^DGCR(399,IBIFN1,I,J,"MOD",0)) S ^DGCR(399,IBIFN,I,J,"MOD",0)=^DGCR(399,IBIFN1,I,J,"MOD",0) D
96 .. S K=0 F S K=$O(^DGCR(399,IBIFN1,I,J,"MOD",K)) Q:'K D
97 ... I $G(IBNOTC),$P($$MOD^ICPTMOD(+$P($G(^DGCR(399,IBIFN1,I,J,"MOD",K,0)),U,2),"I"),U,2)="TC" Q ; Don't copy TC modifier from inst to prof bill
98 ... S ^DGCR(399,IBIFN,I,J,"MOD",K,0)=^DGCR(399,IBIFN1,I,J,"MOD",K,0)
99CP1 S IBCOD=$P($G(^DGCR(399,IBIFN,0)),"^",9) Q:IBCOD=""!('$D(^DGCR(399,IBIFN1,"C")))
100 I IBCOD=9 F DGI=4,5,6 I $P(^DGCR(399,IBIFN1,"C"),"^",DGI) S X=$P(^("C"),"^",DGI)_";ICD0(",DGPROCDT=$P(^("C"),"^",DGI+7) D FILE
101 I IBCOD=4 F DGI=1,2,3 I $P(^DGCR(399,IBIFN1,"C"),"^",DGI) S X=$P(^("C"),"^",DGI)_";ICPT(",DGPROCDT=$P(^("C"),"^",DGI+10) D FILE
102 I IBCOD=5 F DGI=7,8,9 I $P(^DGCR(399,IBIFN1,"C"),"^",DGI) S X=$P(^("C"),"^",DGI)_";ICPT(",DGPROCDT=$P(^("C"),"^",DGI+4) D FILE
103 Q
104 ;
105PRV S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
106 N Z,Z0
107 S Z=$P($G(^DGCR(399,IBIFN,0)),U,19),Z0=$P($G(^DGCR(399,IBIFN1,0)),U,19)
108 S IBDD=399.0222 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) D
109 . S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
110 . I Z'=Z0,$S(X=3:Z0=3,X=4:Z0=2,1:0) S $P(^DGCR(399,IBIFN,I,J,0),U)=(Z0+1)
111 Q
112 ;
113COB S J=0 F S J=$O(IBCOB(I,J)) Q:'J S $P(^DGCR(399,IBIFN,I),U,J)=IBCOB(I,J)
114 Q
115 ;
116FILE N DIC,DIE,DR,DA,X,Y,DLAYGO,DD,DO
117 I '$D(^DGCR(399,IBIFN,"CP",0)) S DIC("P")=$$GETSPEC^IBEFUNC(399,304)
118 S DIC(0)="L",DLAYGO=399,DA(1)=IBIFN,DIC="^DGCR(399,"_DA(1)_",""CP""," Q:X="" D FILE^DICN K DO,DD Q:+Y<1 S DA=+Y
119 S DIE="^DGCR(399,"_DA(1)_",""CP"",",DR="1///"_DGPROCDT D ^DIE
120 K DGPROCDT
121 Q
122 ;
123INDEX ;index entire file (set logic)
124 S DIK="^DGCR(399,",DA=IBIFN D IX1^DIK K DA,DIK
125 Q
126 ;
127PRIOR(IBIFN) ; set Secondary/Tertiary Bill #s on prior bills, if the bill is cancelled remove it from prior bills
128 N IBSEQ,IBSEQN,IBM1,I,IBIFN1
129 S IBSEQ=$$COB^IBCEF(IBIFN)
130 S IBSEQN=$S(IBSEQ="S":6,IBSEQ="T":7,1:"") Q:'IBSEQN
131 ;
132 S IBM1=$G(^DGCR(399,IBIFN,"M1")) I +$P(^DGCR(399,IBIFN,0),U,13)=7 S IBIFN=""
133 F I=5,6 I I<IBSEQN S IBIFN1=+$P(IBM1,U,I) I +IBIFN1,$D(^DGCR(399,+IBIFN1,0)) S $P(^DGCR(399,IBIFN1,"M1"),U,IBSEQN)=IBIFN
134 Q
135 ;
136COBCHG(IBIFN,IBINS,IBCOB) ; Make changes for a new COB payer for bill
137 ; IBIFN = ien of bill in file 399
138 ; IBINS = ien of bill's current insurance (optional)
139 ; IBCOB = array subscripted by node,piece of COB data field change
140 ;
141 N I,IBFRMTYP,IBTAXLST
142 ; Subtract the Prior Payments from the bill's Offset (these are re-added by triggers)
143 F I=4,5,6 S $P(^DGCR(399,IBIFN,"U1"),U,2)=$P($G(^DGCR(399,IBIFN,"U1")),U,2)-$P($G(^DGCR(399,IBIFN,"U2")),U,I)
144 ;
145 I $G(IBINS),$$MCRWNR^IBEFUNC(IBINS) D
146 . ;MCRWNR is current insurance ... move payer only
147 . N IBCOBN,IBX
148 . S IBCOBN=$$COBN^IBCEF(IBIFN)
149 . S IBCOB(0,21)=$P("S^T^",U,IBCOBN)
150 . S IBCOB("M1",IBCOBN+4)=IBIFN
151 . S IBCOB("TX",1)="",IBCOB("TX",2)=""
152 . S IBX=$$REQMRA^IBEFUNC(IBIFN)
153 . I IBX=0 S IBCOB("TX",5)=0 ; MRA not needed
154 . I IBX["R" S IBCOB("TX",5)="A" ; MRA skipped
155 . I IBX=1,$$CHK^IBCEMU1(IBIFN) S IBCOB("TX",5)="C" ; MRA on file
156 . I $G(IBPRCOB) S IBCOB("TX",5)="C" ; MRA being proc'd
157 . D PRIOR(IBIFN)
158 . Q
159 ;
160 ;reset fields for next Sequence Payer
161 F I=0,"M1","U2","TX" I $D(IBCOB(I)) D COB
162 ;
163 ; IB*2.0*211
164 ; save off Form Type
165 S IBFRMTYP=$P($G(^DGCR(399,IBIFN,0)),U,19)
166 ; Save off Taxonomies for providers.
167 S I=0 F S I=$O(^DGCR(399,IBIFN,"PRV",I)) Q:'I S IBTAXLST(I)=$P($G(^DGCR(399,IBIFN,"PRV",I,0)),U,15)
168 ;
169 ; fire xrefs set logic
170 D INDEX
171 ;
172 ; Restore Form Type if changed, but don't restore Form Type if
173 ; creating CMS-1500 claim from CTCOPY1^IBCCCB
174 I $G(IBCTCOPY)'=1,IBFRMTYP'=$P($G(^DGCR(399,IBIFN,0)),U,19) N DA,DIE,DR S DA=IBIFN,DIE="^DGCR(399,",DR=".19////"_IBFRMTYP D ^DIE
175 ;
176 ; Restore Claim MRA Status field since triggers in fields 101 & 102
177 ; will overwrite the correct value when processing the MRA/EOB.
178 ; If we're processing the MRA/EOB, then a valid MRA has been received.
179 I $G(IBPRCOB) N DA,DIE,DR S DA=IBIFN,DIE="^DGCR(399,",DR="24////C" D ^DIE
180 ;
181 ; Restore Taxonomies in fields 243 and 244.
182 S I=$P($G(IBND("U3")),U,2)
183 I I'=$P($G(^DGCR(399,IBIFN,"U3")),U,2) D
184 . N DA,DIE,DR S DA=IBIFN,DIE="^DGCR(399,",DR="243////"_$S(I'="":I,1:"@") D ^DIE
185 S I=$P($G(IBND("U3")),U,3)
186 I I'=$P($G(^DGCR(399,IBIFN,"U3")),U,3) D
187 . N DA,DIE,DR S DA=IBIFN,DIE="^DGCR(399,",DR="244////"_$S(I'="":I,1:"@") D ^DIE
188 ; Restore Taxonomies in field .15 in sub-file 399.0222.
189 S IBTAXLST=0 F S IBTAXLST=$O(IBTAXLST(IBTAXLST)) Q:'IBTAXLST D
190 . S I=IBTAXLST(IBTAXLST)
191 . I I=$P($G(^DGCR(399,IBIFN,"PRV",IBTAXLST,0)),U,15) Q ; No change
192 . N DA,DIE,DR
193 . S DA(1)=IBIFN,DA=IBTAXLST
194 . S DIE="^DGCR(399,"_DA(1)_",""PRV"",",DR=".15////"_$S(I'="":I,1:"@")
195 . D ^DIE
196 . Q
197 ;
198 K IBCOB("TX")
199 Q
200 ;
Note: See TracBrowser for help on using the repository browser.