- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCCC2.m
r613 r623 1 IBCCC2 2 ;;2.0;INTEGRATED BILLING;**80,106,124,138,51,151,137,161,182,211,245,155,296,320,348,349,371**;21-MAR-94;Build 57 3 4 5 6 7 8 9 10 STEP5 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 STEP6 31 32 33 34 END 35 36 37 38 39 40 IBSCEDT 41 42 43 ST1 44 45 46 47 IBSCX 48 49 50 51 U 52 53 U1 54 55 U2 56 57 U3 F J=1:1:7I $P(IBND("U3"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U3"),"^",J)=$P(IBND("U3"),"^",J)58 59 UF2 60 61 UF3 62 63 UF31 64 65 C 66 67 68 M 69 70 CC 71 72 OP 73 74 75 OC 76 77 78 OT 79 80 81 CV 82 83 84 85 86 RC 87 88 89 CP 90 91 92 93 94 95 96 97 98 99 CP1 100 101 102 103 104 105 PRV 106 107 108 109 110 111 112 113 COB 114 115 116 FILE 117 118 119 120 121 122 123 INDEX 124 125 126 127 PRIOR(IBIFN) 128 129 130 131 132 133 134 135 136 COBCHG(IBIFN,IBINS,IBCOB) 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 1 IBCCC2 ;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 ; 10 STEP5 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 ; 30 STEP6 N IBGOEND 31 I '$G(IBCE("EDI"))!$G(IBCE("EDI","NEW")),'$G(IBCEAUTO) D IBSCEDT G END:$G(IBGOEND) 32 ; 33 ; 34 END 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 ; 40 IBSCEDT ; 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) 43 ST1 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 47 IBSCX ; 48 Q 49 ; 50 ; 51 U 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 53 U1 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 55 U2 F J=1:1:19 I $P(IBND("U2"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U2"),"^",J)=$P(IBND("U2"),"^",J) 56 Q 57 U3 F J=1:1:3 I $P(IBND("U3"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U3"),"^",J)=$P(IBND("U3"),"^",J) 58 Q 59 UF2 F J=1,3 I $P(IBND("UF2"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF2"),"^",J)=$P(IBND("UF2"),"^",J) 60 Q 61 UF3 F J=1:1:7 I $P(IBND("UF3"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF3"),"^",J)=$P(IBND("UF3"),"^",J) 62 Q 63 UF31 F J=1:1:3 I $P(IBND("UF31"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF31"),"^",J)=$P(IBND("UF31"),"^",J) 64 Q 65 C 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 68 M F J=1:1:14 I $P(IBND("M"),"^",J)]"" S $P(^DGCR(399,IBIFN,"M"),"^",J)=$P(IBND("M"),"^",J) 69 Q 70 CC 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),"^") 72 OP 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 75 OC 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 78 OT 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 81 CV ; 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 86 RC 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 89 CP 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) 99 CP1 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 ; 105 PRV 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 ; 113 COB 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 ; 116 FILE 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 ; 123 INDEX ;index entire file (set logic) 124 S DIK="^DGCR(399,",DA=IBIFN D IX1^DIK K DA,DIK 125 Q 126 ; 127 PRIOR(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 ; 136 COBCHG(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 TracChangeset
for help on using the changeset viewer.
