- Timestamp:
- Dec 4, 2009, 8:26:01 PM (15 years ago)
- Location:
- FOIAVistA/tag/r
- Files:
-
- 1 edited
- 1 copied
Legend:
- Unmodified
- Added
- Removed
-
FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEOB00.m
r628 r636 1 1 IBCEOB00 ;ALB/ESG - 835 EDI EOB MSG PROCESSING CONT ;30-JUN-2003 2 ;;2.0;INTEGRATED BILLING;**155,349 ,377**;21-MAR-94;Build 232 ;;2.0;INTEGRATED BILLING;**155,349**;21-MAR-94;Build 46 3 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 4 Q … … 94 94 ICNX ; 95 95 Q 96 ;97 15(IB0,IBEGBL,IBEOB) ; Record '15'98 ;99 N A,IBOK100 ;101 S A="3;1.03;1;0;0^4;1.04;1;0;0^5;1.05;1;0;0^6;1.07;1;0;0^7;1.08;1;0;0^8;1.09;1;0;0^9;1.02;1;0;0^10;2.05;1;0;0"102 ;103 S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB)104 I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 15 data" G Q15105 ;106 ; For Medicare MRA's only:107 ; If the Covered Amount is present (15 record, piece 3), then file108 ; a claim level adjustment with Group code=OA, Reason code=AB3.109 ;110 I $P($G(^IBM(361.1,IBEOB,0)),U,4)=1,+$P(IB0,U,3) D111 . N IB20112 . S IB20=20_U_$P(IB0,U,2)_U_"OA"_U_"AB3"_U_$P(IB0,U,3)_U_"0000000000"113 . S IB20=IB20_U_"Covered Amount"114 . S IBOK=$$20(IB20,IBEGBL,IBEOB)115 . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Could not file the OA-AB3 claim level adjustment for the Covered Amount"116 . K ^TMP($J,20)117 . Q118 ;119 Q15 Q IBOK120 ;121 20(IB0,IBEGBL,IBEOB) ; Record '20'122 ;123 N A,LEVEL,IBGRP,IBDA,IBOK124 ;125 S IBGRP=$P(IB0,U,3)126 I IBGRP'="" S ^TMP($J,20)=IBGRP127 I IBGRP="" S IBGRP=$G(^TMP($J,20))128 I IBGRP="" S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Missing claim level adjustment group code" G Q20129 ;130 S IBDA(1)=$O(^IBM(361.1,IBEOB,10,"B",IBGRP,0))131 ;132 I 'IBDA(1) D ;Needs a new entry at group level133 . N X,Y,DA,DD,DO,DIC,DLAYGO134 . S DIC="^IBM(361.1,"_IBEOB_",10,",DIC(0)="L",DLAYGO=361.11,DA(1)=IBEOB135 . S DIC("P")=$$GETSPEC^IBEFUNC(361.1,10)136 . S X=IBGRP137 . D FILE^DICN K DIC,DO,DD,DLAYGO138 . I Y<0 K IBDA S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Adjustment group code could not be added" Q139 . S IBDA(1)=+Y140 ;141 I $G(IBDA(1)) D ;Add a new entry at the reason code level142 . S DIC="^IBM(361.1,"_IBEOB_",10,"_IBDA(1)_",1,",DIC(0)="L",DLAYGO=361.111,DA(2)=IBEOB,DA(1)=IBDA(1)143 . S DIC("P")=$$GETSPEC^IBEFUNC(361.11,1)144 . S X=$P(IB0,U,4)145 . D FILE^DICN K DIC,DO,DD,DLAYGO146 . I Y<0 K IBDA S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Adjustment reason code could not be added" Q147 . S IBDA=+Y148 ;149 I $G(IBDA) D150 . S LEVEL=10,LEVEL("DIE")="^IBM(361.1,"_IBEOB_",10,"_IBDA(1)_",1,"151 . S LEVEL(0)=IBDA,LEVEL(1)=IBDA(1),LEVEL(2)=IBEOB152 . S A="5;.02;1;0;0^6;.03;0;1;1^7;.04;0;1;0"153 . S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB,.LEVEL)154 . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad adjustment reason code ("_$P(IB0,U,4)_") data" Q155 Q20 Q $G(IBOK)156 96 ; 157 97 35(IB0,IBEGBL,IBEOB) ; Record '35' … … 223 163 Q X 224 164 ; 165 UPDNM(IBEOB,IB0,IBBULL,IBDR) ; Update name on claim if it comes back changed 166 ; IBEOB = the internal entry # of the entry in file 361.1 167 ; IB0 = the raw data returned from the 835 flat file 168 ; IBBULL = holds result of name change check in piece 1 - if name 169 ; changed, first '^' piece is 1, 3rd '^' piece is the old 170 ; insured's name 171 ; IBDR = returned as the updated 'DR' string with the name changed 172 ; fields to use to update the EOB file (361.1) - pass by reference 173 ; 174 N IBCHGED,IBIFN,IBNEW,IBCOB,DIE,DR,X,Y 175 I $P(IB0,U,7) D 176 . S IBNEW=$P(IB0,U,3)_","_$P(IB0,U,4)_$S($P(IB0,U,5)'="":" "_$P(IB0,U,5),1:""),$P(IBBULL,U)=1 177 . S IBCOB=+$P($G(^IBM(361.1,IBEOB,0)),U,15) 178 . S IBIFN=+$G(^IBM(361.1,+IBEOB,0)) 179 . S IB=$G(^DGCR(399,IBIFN,"I"_IBCOB)) 180 . ; 181 . I IB'="",$P(IB,U,17)'=IBNEW D 182 .. ; Update the claim data only 183 .. S $P(IBBULL,U,3)=$P(IB,U,17) ; save old value 184 .. S $P(IB,U,17)=IBNEW 185 .. S DIE="^DGCR(399,",DA=IBIFN,DR="30"_IBCOB_"////"_IB 186 .. D:DA ^DIE 187 .. S IBCHGED=1 188 . S IBDR=$G(IBDR)_"6.01////"_$P(IB0,U,3)_","_$P(IB0,U,4)_" "_$P(IB0,U,5)_";" 189 ; 190 Q $G(IBCHGED) 191 ; 192 UPDID(IBEOB,IB0,IBBULL,IBDR) ; Update id # on claim and policy if it comes back 193 ; changed 194 ; IBEOB = the internal entry # of the entry in file 361.1 195 ; IB0 = the raw data returned from the 835 flat file 196 ; IBBULL = holds result of id change check in piece 2 - if id changed, 197 ; second '^' piece = 1,4th '^' piece is the old insured's id 198 ; IBDR = returned as the updated 'DR' string with the id changed fields 199 ; to use to update the EOB file (361.1) - pass by reference 200 ; 201 N IBCHGED,IBNEW,IBCOB,IB,DIE,DR,DA,X,Y 202 I $P(IB0,U,8) D 203 . S IBNEW=$P(IB0,U,6),$P(IBBULL,U,2)=1 204 . S IBIFN=+$G(^IBM(361.1,+IBEOB,0)) 205 . S IBCOB=+$P($G(^IBM(361.1,IBEOB,0)),U,15) 206 . S IB=$G(^DGCR(399,IBIFN,"I"_IBCOB)) 207 . ; 208 . I IB'="",$P(IB,U,2)'=IBNEW D 209 .. ; Update the claim 210 .. S $P(IBBULL,U,4)=$P(IB,U,2) ; save old value 211 .. S $P(IB,U,2)=IBNEW 212 .. S DIE="^DGCR(399,",DA=IBIFN,DR="30"_IBCOB_"////"_IB D ^DIE 213 .. ; 214 .. ; Update the policy 215 .. S DA(1)=$P($G(^DGCR(399,IBIFN,0)),U,2),DA=$P($G(^("M")),U,(11+IBCOB)),DR="1////"_IBNEW,DIE="^DPT("_DA(1)_",.312," 216 .. I DA(1),DA D ^DIE 217 .. S IBCHGED=1 218 . S IBDR=$G(IBDR)_"6.02////"_$P(IB0,U,6)_";" 219 ; 220 Q $G(IBCHGED) 221 ;
Note:
See TracChangeset
for help on using the changeset viewer.