- Timestamp:
- Dec 4, 2009, 8:26:01 PM (14 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/IBCNSC1.m
r628 r636 1 1 IBCNSC1 ;ALB/NLR - IBCNS INSURANCE COMPANY ;23-MAR-93 2 ;;2.0;INTEGRATED BILLING;**62,137,232,291,320,348,349 ,371**;21-MAR-94;Build 572 ;;2.0;INTEGRATED BILLING;**62,137,232,291,320,348,349**;21-MAR-94;Build 46 3 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; … … 40 40 I $G(IBY)=",12," D FACID 41 41 F Z=1,2,4,9,13,14 S IBEDIKEY(Z)=$P($G(^DIC(36,+IBCNS,3)),U,Z) ; save EDI data fields 42 F Z=1:1:8 S IBEDIKEY(Z,6)=$P($G(^DIC(36,+IBCNS,6)),U,Z) ; save EDI data fields 43 I $G(IBY)'=",12," N DIE,DA,DR S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="[IBEDIT INS CO1]" D ^DIE K DIE S:$D(Y) IB("^")=1 D:$TR($P($G(^DIC(36,IBCNS,6)),U,1,8),U)]"" CUIDS(IBCNS) 42 I $G(IBY)'=",12," N DIE,DA,DR S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="[IBEDIT INS CO1]" D ^DIE K DIE I $D(Y) S IB("^")=1 44 43 I $G(IBY)=",12," D EDITID^IBCEP(+IBCNS) 45 44 I $F(",6,13,",$G(IBY)) D PARENT^IBCNSC02(+IBCNS) ; parent/child management … … 57 56 N OFFSET,START,IBCNS18,IBADD 58 57 S IBCNS18=$$ADDRESS^IBCNSC0(IBCNS,.18,11) 59 S START= 41,OFFSET=258 S START=34,OFFSET=2 60 59 D SET^IBCNSP(START,OFFSET+19," Prescription Claims Office Information ",IORVON,IORVOFF) 61 60 D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS18,"^",7),0)),"^",1)) … … 206 205 I IBINS,IBPTYP S X=$P($G(^IBA(355.91,+$O(^IBA(355.91,"AC",IBINS,IBPTYP,"*N/A*","")),0)),U,7) 207 206 Q X 208 ;209 CUIDS(IBCNS) ;210 N DIE,DA,DR,PIECE,DAT6,Y211 S DAT6=$P(^DIC(36,IBCNS,6),U,1,8) ; get the Payer IDs212 ;213 ; Make sure each qualifier has an ID and vice versa214 F PIECE=1,3,5,7 D215 . I $TR($P(DAT6,U,PIECE,PIECE+1),U)="" Q ; both blank216 . I $P(DAT6,U,PIECE)]"",$P(DAT6,U,PIECE+1)]"" Q ; both have data217 . S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="6.0"_$S($P(DAT6,U,PIECE)]"":PIECE,1:PIECE+1)_"////@"218 . D ^DIE K DIE219 ;220 S DAT6=$P($G(^DIC(36,IBCNS,6)),U,1,8) ; get the Payer IDs again since they may have changed above.221 ;222 ; Make sure the first pair of ID/Qual are populated if the 2nd pair is. If not, move em over.223 ; This is done for institutional then professional224 F PIECE=1,5 D225 . I $P(DAT6,U,PIECE)]"" Q ; already has set one226 . I $P(DAT6,U,PIECE+2)="" Q ; has no second set227 . S DIE="^DIC(36,",(DA,Y)=IBCNS228 . ; deleting the qualifier triggers deletion of the ID229 . S DR="6.0"_PIECE_"////"_$P(DAT6,U,PIECE+2)_";6.0"_(PIECE+1)_"////"_$P(DAT6,U,PIECE+3)_";6.0"_(PIECE+2)_"////@"230 . D ^DIE K DIE231 Q
Note:
See TracChangeset
for help on using the changeset viewer.