- IBCF31 ;ALB/BGA -UB92 HCFA-1450 (GATHER CODES) ;25-AUG-1993
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- EN ;This routine requires prior execution of ibcf3.
- ;Field locators 22-62 are addressed here.
- ;
- S IBMAIL1=$G(^DGCR(399,IBIFN,"M1"))
- ;
- 22 ;patient status
- S IBFL(22)="" I +IBINPAT,$P(IBSTATE,U,12) S IBX=$P(IBSTATE,U,12),IBFL(22)=$P($G(^DGCR(399.1,+IBX,0)),U,2)
- 23 ;medical/health record number ssn
- S IBFL(23)=$P(VADM(2),U,2)
- ;
- 24 ;condition codes 24-30
- S (IBI,IBX)=0 F S IBX=$O(^DGCR(399,+IBIFN,"CC",IBX)) Q:'IBX S IBI=IBI+1,IBFL(24,IBI)=$G(^(IBX,0))
- S IBFL(24)=IBI_U_0
- ;
- S IBX=$P(IBCUF3,U,3) D SPLIT^IBCF3(31,2,6,IBX) ; set IBFL(31)
- 32 ;occurrence codes/span and dates 32-35 ,36
- ;S (IBI,IBJ,IBX)=0 F S IBX=$O(^DGCR(399,+IBIFN,"OC",IBX)) Q:'IBX S IBY=$G(^(IBX,0)),IBC=$G(^DGCR(399.1,+IBY,0)) I IBC'="" D
- ;. I +$P(IBC,U,10) S IBJ=IBJ+1,IBFL(36,IBJ)=$P(IBC,U,2)_U_$$DATE^IBCF3($P(IBY,U,2))_U_$$DATE^IBCF3($P(IBY,U,4)) Q
- ;. S IBI=IBI+1,IBFL(32,IBI)=$P(IBC,U,2)_U_$$DATE^IBCF3($P(IBY,U,2))
- ;S IBFL(32)=IBI_U_0
- ;S IBFL(36)=IBJ_U_0
- D 32^IBCF32
- ;
- F IBI=1:1:3 S IBFL(37,IBI)=$P(IBCUF3,U,(IBI+3))
- ;
- 38 ;responsible party with name and address
- S IBFL(38,1)="" I $P(IBPMAILN,U,4)'="" S IBJ=0 D
- . F IBI=4,5,6 I $P(IBPMAILN,U,IBI)'="" S IBJ=IBJ+1,IBFL(38,IBJ)=$P(IBPMAILN,U,IBI)
- . S IBX=$P(IBMAIL1,U,1) I IBX'="" S IBJ=IBJ+1,IBFL(38,IBJ)=IBX
- . S IBJ=IBJ+1,IBFL(38,IBJ)=$P(IBPMAILN,U,7)_", "_$$STATE(+$P(IBPMAILN,U,8))_" "_$P(IBPMAILN,U,9)
- ;
- ;
- 39 ;value codes, 39-41
- S (IBI,IBX)=0 F S IBX=$O(^DGCR(399,+IBIFN,"CV",IBX)) Q:'IBX S IBY=$G(^(IBX,0)),IBJ=$G(^DGCR(399.1,+IBY,0)) I IBJ'="" D
- . S IBI=IBI+1,IBFL(39,IBI)=$P(IBJ,U,2)_U_$P(IBY,U,2)_U_$P(IBJ,U,12)
- S IBFL(39)=IBI_U_0
- ;
- S IBFL(57)=$P(IBCUF31,U,1),IBX=$P(IBCUF3,U,7) D SPLIT^IBCF3(56,5,14,IBX) ; set IBFL(56)
- ;
- 50 F IBI=1:1:3 F IBJ=50:1:53,58:1:66 S IBFL(IBJ,IBI)=""
- I '$D(^DGCR(399,IBIFN,"AIC")) D G 80
- . S IBFL(52,1)=$S(+$P(IBSTATE,U,5):"R",1:"Y") ; roi
- . S IBFL(53,1)=$S("Nn0"[$P(IBSTATE,U,6)&($P(IBSTATE,U,6)'=""):"N",1:"Y") ; assign of benifits
- . S IBFL(63,1)=$P(IBSTATE,U,13) ; tx auth cd
- . I $P($G(^DGCR(399.3,+$P(IBCBILL,U,7),0)),U,1)["MEDICARE ESRD" D
- .. S IBFL(50,1)="MEDICARE ESRD",IBFL(51,1)=$P(IBSIGN,U,21),IBFL(58,1)=VADM(1),IBFL(59,1)="01",IBFL(60,1)=$P(VADM(2),U,2)
- ;
- INS ;list the primary, secondary .. insurance companies
- F IBI=1:1:3 S IBJ="I"_IBI S IBX=$G(^DGCR(399,IBIFN,IBJ)) I IBX'="" D
- . S IBY=$G(^DIC(36,+IBX,0)) Q:IBY=""
- . S IBFL(50,IBI)=$P(IBY,U,1) ; payer
- . S IBFL(51,IBI)=$P(IBMAIL1,U,(IBI+1)) ; provider #
- . S IBFL(52,IBI)=$S(+$P(IBSTATE,U,5):"R",1:"Y") ; roi
- . S IBFL(53,IBI)=$S("Nn0"[$P(IBSTATE,U,6)&($P(IBSTATE,U,6)'=""):"N",1:"Y") ;assign of benifits
- . S IBFL(58,IBI)=$P(IBX,U,17) ; insureds name
- . S IBFL(59,IBI)=$P(IBX,U,16) ; pt. rel to insured
- . S IBFL(60,IBI)=$P(IBX,U,2) ; insurance number
- . S IBFL(61,IBI)=$P(IBX,U,15) ; insurance group name
- . S IBFL(62,IBI)=$P(IBX,U,3) ; insurance group number
- . S IBFL(63,IBI)="" I IBI=1 S IBFL(63,IBI)=$P(IBSTATE,U,13) ; tx auth cd
- . I $P(IBX,U,6)="v" D
- .. D OPD^VADPT S IBFL(64,IBI)=$P(VAPD(7),U,1) K VAPD I ",3,9,"[+IBFL(64,IBI) Q
- .. S VAOA("A")=5 D OAD^VADPT S IBFL(65,IBI)=VAOA(9),IBFL(66,IBI)=VAOA(4)_$S(VAOA(4)'="":", ",1:"")_$P(VAOA(5),U,2) K VAOA
- . I $P(IBX,U,6)="s" D
- .. S IBFL(64,IBI)=$P($G(^DPT(DFN,.25)),U,15) I ",3,9,"[+IBFL(64,IBI) Q
- .. S VAOA("A")=6 D OAD^VADPT S IBFL(65,IBI)=VAOA(9),IBFL(66,IBI)=VAOA(4)_$S(VAOA(4)'="":", ",1:"")_$P(VAOA(5),U,2)
- . I 'IBFL(64,IBI) S IBFL(64,IBI)=9
- ;
- 80 ;procedure field locator 80
- K IBPROC
- D PROC^IBCVA1 S IBFL(80)=IBPROC_U_0_U_1,IBFL(80,1)=""
- I +IBPROC S (IBI,IBX)=0 F S IBX=$O(IBPROC(IBX)) Q:'IBX D
- . I $P(IBPROC(IBX),U,1)["ICPT(" S IBY=$P($G(^ICPT(+IBPROC(IBX),0)),U,1)
- . I $P(IBPROC(IBX),U,1)["ICD0(" S IBY=$P($G(^ICD0(+IBPROC(IBX),0)),U,1)
- . S IBI=IBI+1,IBFL(80,IBI)=IBY_U_$$DATE^IBCF3($P(IBPROC(IBX),U,2))
- K IBPROC,I,J
- ;
- Q
- ;
- STATE(X) ;returns 2 letter abbreviation for state pointer
- Q $P($G(^DIC(5,+$G(X),0)),U,2)
- IBCF31 ;ALB/BGA -UB92 HCFA-1450 (GATHER CODES) ;25-AUG-1993
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- EN ;This routine requires prior execution of ibcf3.
- +1 ;Field locators 22-62 are addressed here.
- +2 ;
- +3 SET IBMAIL1=$GET(^DGCR(399,IBIFN,"M1"))
- +4 ;
- 22 ;patient status
- +1 SET IBFL(22)=""
- IF +IBINPAT
- IF $PIECE(IBSTATE,U,12)
- SET IBX=$PIECE(IBSTATE,U,12)
- SET IBFL(22)=$PIECE($GET(^DGCR(399.1,+IBX,0)),U,2)
- 23 ;medical/health record number ssn
- +1 SET IBFL(23)=$PIECE(VADM(2),U,2)
- +2 ;
- 24 ;condition codes 24-30
- +1 SET (IBI,IBX)=0
- FOR
- SET IBX=$ORDER(^DGCR(399,+IBIFN,"CC",IBX))
- IF 'IBX
- QUIT
- SET IBI=IBI+1
- SET IBFL(24,IBI)=$GET(^(IBX,0))
- +2 SET IBFL(24)=IBI_U_0
- +3 ;
- +4 ; set IBFL(31)
- SET IBX=$PIECE(IBCUF3,U,3)
- DO SPLIT^IBCF3(31,2,6,IBX)
- 32 ;occurrence codes/span and dates 32-35 ,36
- +1 ;S (IBI,IBJ,IBX)=0 F S IBX=$O(^DGCR(399,+IBIFN,"OC",IBX)) Q:'IBX S IBY=$G(^(IBX,0)),IBC=$G(^DGCR(399.1,+IBY,0)) I IBC'="" D
- +2 ;. I +$P(IBC,U,10) S IBJ=IBJ+1,IBFL(36,IBJ)=$P(IBC,U,2)_U_$$DATE^IBCF3($P(IBY,U,2))_U_$$DATE^IBCF3($P(IBY,U,4)) Q
- +3 ;. S IBI=IBI+1,IBFL(32,IBI)=$P(IBC,U,2)_U_$$DATE^IBCF3($P(IBY,U,2))
- +4 ;S IBFL(32)=IBI_U_0
- +5 ;S IBFL(36)=IBJ_U_0
- +6 DO 32^IBCF32
- +7 ;
- +8 FOR IBI=1:1:3
- SET IBFL(37,IBI)=$PIECE(IBCUF3,U,(IBI+3))
- +9 ;
- 38 ;responsible party with name and address
- +1 SET IBFL(38,1)=""
- IF $PIECE(IBPMAILN,U,4)'=""
- SET IBJ=0
- Begin DoDot:1
- +2 FOR IBI=4,5,6
- IF $PIECE(IBPMAILN,U,IBI)'=""
- SET IBJ=IBJ+1
- SET IBFL(38,IBJ)=$PIECE(IBPMAILN,U,IBI)
- +3 SET IBX=$PIECE(IBMAIL1,U,1)
- IF IBX'=""
- SET IBJ=IBJ+1
- SET IBFL(38,IBJ)=IBX
- +4 SET IBJ=IBJ+1
- SET IBFL(38,IBJ)=$PIECE(IBPMAILN,U,7)_", "_$$STATE(+$PIECE(IBPMAILN,U,8))_" "_$PIECE(IBPMAILN,U,9)
- End DoDot:1
- +5 ;
- +6 ;
- 39 ;value codes, 39-41
- +1 SET (IBI,IBX)=0
- FOR
- SET IBX=$ORDER(^DGCR(399,+IBIFN,"CV",IBX))
- IF 'IBX
- QUIT
- SET IBY=$GET(^(IBX,0))
- SET IBJ=$GET(^DGCR(399.1,+IBY,0))
- IF IBJ'=""
- Begin DoDot:1
- +2 SET IBI=IBI+1
- SET IBFL(39,IBI)=$PIECE(IBJ,U,2)_U_$PIECE(IBY,U,2)_U_$PIECE(IBJ,U,12)
- End DoDot:1
- +3 SET IBFL(39)=IBI_U_0
- +4 ;
- +5 ; set IBFL(56)
- SET IBFL(57)=$PIECE(IBCUF31,U,1)
- SET IBX=$PIECE(IBCUF3,U,7)
- DO SPLIT^IBCF3(56,5,14,IBX)
- +6 ;
- 50 FOR IBI=1:1:3
- FOR IBJ=50:1:53,58:1:66
- SET IBFL(IBJ,IBI)=""
- +1 IF '$DATA(^DGCR(399,IBIFN,"AIC"))
- Begin DoDot:1
- +2 ; roi
- SET IBFL(52,1)=$SELECT(+$PIECE(IBSTATE,U,5):"R",1:"Y")
- +3 ; assign of benifits
- SET IBFL(53,1)=$SELECT("Nn0"[$PIECE(IBSTATE,U,6)&($PIECE(IBSTATE,U,6)'=""):"N",1:"Y")
- +4 ; tx auth cd
- SET IBFL(63,1)=$PIECE(IBSTATE,U,13)
- +5 IF $PIECE($GET(^DGCR(399.3,+$PIECE(IBCBILL,U,7),0)),U,1)["MEDICARE ESRD"
- Begin DoDot:2
- +6 SET IBFL(50,1)="MEDICARE ESRD"
- SET IBFL(51,1)=$PIECE(IBSIGN,U,21)
- SET IBFL(58,1)=VADM(1)
- SET IBFL(59,1)="01"
- SET IBFL(60,1)=$PIECE(VADM(2),U,2)
- End DoDot:2
- End DoDot:1
- GOTO 80
- +7 ;
- INS ;list the primary, secondary .. insurance companies
- +1 FOR IBI=1:1:3
- SET IBJ="I"_IBI
- SET IBX=$GET(^DGCR(399,IBIFN,IBJ))
- IF IBX'=""
- Begin DoDot:1
- +2 SET IBY=$GET(^DIC(36,+IBX,0))
- IF IBY=""
- QUIT
- +3 ; payer
- SET IBFL(50,IBI)=$PIECE(IBY,U,1)
- +4 ; provider #
- SET IBFL(51,IBI)=$PIECE(IBMAIL1,U,(IBI+1))
- +5 ; roi
- SET IBFL(52,IBI)=$SELECT(+$PIECE(IBSTATE,U,5):"R",1:"Y")
- +6 ;assign of benifits
- SET IBFL(53,IBI)=$SELECT("Nn0"[$PIECE(IBSTATE,U,6)&($PIECE(IBSTATE,U,6)'=""):"N",1:"Y")
- +7 ; insureds name
- SET IBFL(58,IBI)=$PIECE(IBX,U,17)
- +8 ; pt. rel to insured
- SET IBFL(59,IBI)=$PIECE(IBX,U,16)
- +9 ; insurance number
- SET IBFL(60,IBI)=$PIECE(IBX,U,2)
- +10 ; insurance group name
- SET IBFL(61,IBI)=$PIECE(IBX,U,15)
- +11 ; insurance group number
- SET IBFL(62,IBI)=$PIECE(IBX,U,3)
- +12 ; tx auth cd
- SET IBFL(63,IBI)=""
- IF IBI=1
- SET IBFL(63,IBI)=$PIECE(IBSTATE,U,13)
- +13 IF $PIECE(IBX,U,6)="v"
- Begin DoDot:2
- +14 DO OPD^VADPT
- SET IBFL(64,IBI)=$PIECE(VAPD(7),U,1)
- KILL VAPD
- IF ",3,9,"[+IBFL(64,IBI)
- QUIT
- +15 SET VAOA("A")=5
- DO OAD^VADPT
- SET IBFL(65,IBI)=VAOA(9)
- SET IBFL(66,IBI)=VAOA(4)_$SELECT(VAOA(4)'="":", ",1:"")_$PIECE(VAOA(5),U,2)
- KILL VAOA
- End DoDot:2
- +16 IF $PIECE(IBX,U,6)="s"
- Begin DoDot:2
- +17 SET IBFL(64,IBI)=$PIECE($GET(^DPT(DFN,.25)),U,15)
- IF ",3,9,"[+IBFL(64,IBI)
- QUIT
- +18 SET VAOA("A")=6
- DO OAD^VADPT
- SET IBFL(65,IBI)=VAOA(9)
- SET IBFL(66,IBI)=VAOA(4)_$SELECT(VAOA(4)'="":", ",1:"")_$PIECE(VAOA(5),U,2)
- End DoDot:2
- +19 IF 'IBFL(64,IBI)
- SET IBFL(64,IBI)=9
- End DoDot:1
- +20 ;
- 80 ;procedure field locator 80
- +1 KILL IBPROC
- +2 DO PROC^IBCVA1
- SET IBFL(80)=IBPROC_U_0_U_1
- SET IBFL(80,1)=""
- +3 IF +IBPROC
- SET (IBI,IBX)=0
- FOR
- SET IBX=$ORDER(IBPROC(IBX))
- IF 'IBX
- QUIT
- Begin DoDot:1
- +4 IF $PIECE(IBPROC(IBX),U,1)["ICPT("
- SET IBY=$PIECE($GET(^ICPT(+IBPROC(IBX),0)),U,1)
- +5 IF $PIECE(IBPROC(IBX),U,1)["ICD0("
- SET IBY=$PIECE($GET(^ICD0(+IBPROC(IBX),0)),U,1)
- +6 SET IBI=IBI+1
- SET IBFL(80,IBI)=IBY_U_$$DATE^IBCF3($PIECE(IBPROC(IBX),U,2))
- End DoDot:1
- +7 KILL IBPROC,I,J
- +8 ;
- +9 QUIT
- +10 ;
- STATE(X) ;returns 2 letter abbreviation for state pointer
- +1 QUIT $PIECE($GET(^DIC(5,+$GET(X),0)),U,2)
