Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCF31

IBCF31.m

Go to the documentation of this file. 
  1. IBCF31 ;ALB/BGA -UB92 HCFA-1450 (GATHER CODES) ;25-AUG-1993
  1.  ;;2.0;INTEGRATED BILLING;**17,52,80,51,516**;21-MAR-94;Build 123
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1. EN ;This routine requires prior execution of ibcf3.
  1.  ; OUTPUT FORMATTER DOES NOT USE THIS ROUTINE - MAY BE OBSOLETE
  1.  ;Field locators 22-62 are addressed here.
  1.  ;
  1.  S IBMAIL1=$G(^DGCR(399,IBIFN,"M1"))
  1.  ;
  1. 22 ;patient status
  1.  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)
  1. 23 ;medical/health record number ssn
  1.  S IBFL(23)=$P(VADM(2),U,2)
  1.  ;
  1. 24 ;condition codes 24-30
  1.  S (IBI,IBJ)=0 F  S IBJ=$O(^DGCR(399,+IBIFN,"CC",IBJ)) Q:'IBJ  S IBX=+$G(^(IBJ,0)),IBI=IBI+1,IBFL(24,IBI)=$P($G(^DGCR(399.1,+IBX,0)),U,2)
  1.  S IBFL(24)=IBI_U_0
  1.  ;
  1.  S IBX=$P(IBCUF3,U,3) D SPLIT^IBCF3(31,2,6,IBX) ; set IBFL(31)
  1. 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
  1.  ;. 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
  1.  ;. S IBI=IBI+1,IBFL(32,IBI)=$P(IBC,U,2)_U_$$DATE^IBCF3($P(IBY,U,2))
  1.  ;S IBFL(32)=IBI_U_0
  1.  ;S IBFL(36)=IBJ_U_0
  1.  D 32^IBCF32
  1.  ;
  1.  F IBI=1:1:3 S IBFL(37,IBI)=$P(IBCUF3,U,(IBI+3))
  1.  ;
  1. 38 ;responsible party with name and address
  1.  S IBFL(38,1)="" I $P(IBPMAILN,U,4)'="" S IBJ=0 D
  1.  . F IBI=4,5,6 I $P(IBPMAILN,U,IBI)'="" S IBJ=IBJ+1,IBFL(38,IBJ)=$P(IBPMAILN,U,IBI)
  1.  . S IBX=$P(IBMAIL1,U,1) I IBX'="" S IBJ=IBJ+1,IBFL(38,IBJ)=IBX
  1.  . K Y S Y=$P(IBPMAILN,U,9) D ZIPOUT^VAFADDR
  1.  . S IBJ=IBJ+1,IBFL(38,IBJ)=$P(IBPMAILN,U,7)_", "_$$STATE(+$P(IBPMAILN,U,8))_" "_Y K Y
  1.  ;
  1.  ;
  1. 39 ;value codes, 39-41
  1.  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
  1.  . S IBI=IBI+1,IBFL(39,IBI)=$P(IBJ,U,2)_U_$P(IBY,U,2)_U_$P(IBJ,U,12)
  1.  S IBFL(39)=IBI_U_0
  1.  ;
  1.  S IBFL(57)=$P(IBCUF31,U,1)
  1.  S IBX=$P(IBCUF3,U,7) D SPLIT^IBCF3(56,5,14,IBX) ; set IBFL(56)
  1.  I IBX="" F IBI=2,3,4 S IBX=+$P(IBMAIL1,U,(IBI+3)) I +IBX S IBFL(56,IBI)=$$BN1^PRCAFN(IBX) ; use prior bills
  1.  ;
  1. 50 F IBI=1:1:3 F IBJ=50:1:54,58:1:66 S IBFL(IBJ,IBI)=""
  1.  I '$D(^DGCR(399,IBIFN,"AIC")) D  G 80
  1.  . S IBFL(52,1)=$S(+$P(IBSTATE,U,5):"R",1:"Y") ; roi
  1.  . S IBFL(53,1)=$S("Nn0"[$P(IBSTATE,U,6)&($P(IBSTATE,U,6)'=""):"N",1:"Y") ; assign of benifits
  1.  . S IBFL(63,1)=$P(IBSTATE,U,13) ; tx auth cd
  1.  . I $P($G(^DGCR(399.3,+$P(IBCBILL,U,7),0)),U,1)["MEDICARE ESRD" D
  1.  .. 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)
  1.  ;
  1. INS ;list the primary, secondary .. insurance companies
  1.  ;IB*2.0*516/BAA - Call $$POLICY^IBCEF to insert HIPAA compliant fields into variable IBDI1. Data will
  1.  ;continue to be extracted from IBDI1 original location.
  1.  ;F IBI=1:1:3 S IBJ="I"_IBI S IBX=$G(^DGCR(399,IBIFN,IBJ)) I IBX'="" D  ; 516 - baa
  1.  F IBI=1:1:3 S IBX=$$POLICY^IBCEF(IBIFN,,IBI) I IBX'="" D  ; 516 - baa
  1.  . S IBY=$G(^DIC(36,+IBX,0)) Q:IBY=""
  1.  . S IBFL(50,IBI)=$P(IBY,U,1) ; payer
  1.  . S IBFL(51,IBI)=$P(IBMAIL1,U,(IBI+1)) ; provider #
  1.  . S IBFL(52,IBI)=$S(+$P(IBSTATE,U,5):"R",1:"Y") ; roi
  1.  . S IBFL(53,IBI)=$S("Nn0"[$P(IBSTATE,U,6)&($P(IBSTATE,U,6)'=""):"N",1:"Y") ;assign of benifits
  1.  . S IBFL(54,IBI)=$P(IBCU2,U,3+IBI) ;prior payment
  1.  . S IBFL(58,IBI)=$P(IBX,U,17) ; insureds name
  1.  . S IBFL(59,IBI)=$P(IBX,U,16) ; pt. rel to insured
  1.  . S IBFL(60,IBI)=$P(IBX,U,2) ; insurance number
  1.  . S IBFL(61,IBI)=$P(IBX,U,15) ; insurance group name
  1.  . S IBFL(62,IBI)=$P(IBX,U,3) ; insurance group number
  1.  . S IBFL(63,IBI)="" I IBI=1 S IBFL(63,IBI)=$P(IBSTATE,U,13) ; tx auth cd
  1.  . I $P(IBX,U,6)="v" D
  1.  .. D OPD^VADPT S IBFL(64,IBI)=$P(VAPD(7),U,1) K VAPD I ",3,9,"[+IBFL(64,IBI) Q
  1.  .. 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
  1.  . I $P(IBX,U,6)="s" D
  1.  .. S IBFL(64,IBI)=$P($G(^DPT(DFN,.25)),U,15) I ",3,9,"[+IBFL(64,IBI) Q
  1.  .. 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)
  1.  . I 'IBFL(64,IBI) S IBFL(64,IBI)=9
  1.  ;
  1. 80 ;procedure field locator 80
  1.  K IBPROC
  1.  D PROC^IBCVA1 S IBFL(80)=IBPROC_U_0_U_1,IBFL(80,1)=""
  1.  I +IBPROC S (IBI,IBX)=0 F  S IBX=$O(IBPROC(IBX)) Q:'IBX  D
  1.  . S IBY=$P($$PRCD^IBCEF1($P(IBPROC(IBX),U)),U)
  1.  . S IBI=IBI+1,IBFL(80,IBI)=IBY_U_$$DATE^IBCF3($P(IBPROC(IBX),U,2))
  1.  . I $P(IBPROC(IBX),U,15)'="" S IBM=$P(IBPROC(IBX),U,15) D
  1.  .. F I=1:1:$L(IBM,",") I $P(IBM,",",I)'="" S IBY=$P($$MOD^ICPTMOD($P(IBM,",",I),"I"),U,4) I IBY'="" S IBI=IBI+1,IBFL(80,IBI)=IBY_U_$$DATE^IBCF3($P(IBPROC(IBX),U,2))
  1.  K IBPROC,I,J
  1.  ;
  1.  Q
  1.  ;
  1. STATE(X) ;returns 2 letter abbreviation for state pointer
  1.  Q $P($G(^DIC(5,+$G(X),0)),U,2)