IBCF32 ;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.
;
;This routine requires prior execution of ibcf3.
;
DX ;set diagnosis codes fl 67-71
;S IBX=$G(^DGCR(399,+IBIFN,"C"))
;S IBI=0 F IBJ=14:1:18 S IBFL(67+IBI)=$P($G(^ICD9(+$P(IBX,U,IBJ),0)),U,1),IBI=IBI+1
N IBINDXX D SET^IBCSC4D(IBIFN,"",.IBINDXX) S IBX=0 F IBI=1:1:9 S IBX=$O(IBINDXX(IBX)) Q:'IBX S IBFL(66+IBI)=$P($G(^ICD9(+IBINDXX(IBX),0)),U,1)
;
76 ;fl 76 admitting diagnoses (if a ICD dx not entered get old position of dx)
S IBCBCOMM=$G(^DGCR(399,+IBIFN,"U1"))
S IBX=$P(IBCU2,U,1) S IBFL(76)=$S(+IBX:$P($G(^ICD9(+IBX,0)),U,1),1:$P(IBCBCOMM,U,5))
;
78 S IBX=$P(IBCUF31,U,2) D SPLIT^IBCF3(78,2,3,IBX) ; set IBFL(78)
;fl 79 procedure coding method used
S IBFL(79)=$P(IBCBILL,U,9)
;
82 ;fl 82 attending physician id
S IBFL(82)=$P(IBCBCOMM,U,13) I IBFL(82)="" S IBFL(82)="Dept. Veterans Affairs"
;fl 83 other physician id
S IBFL(83)=$P(IBCBCOMM,U,14)
;
84 ;fl 84 remarks
S IBFL(84,1)="Patient ID: "_$P(VADM(2),U,2)
S IBX=$P($G(^DGCR(399.3,+$P(IBCBILL,U,7),0)),U,2),IBFL(84,2)="Bill Type: "_$S(IBX'="":IBX,1:"UNSPECIFIED")
S IBFL(84,3)=$P(IBSIGN,U,4)
S IBFL(84,4)=$P(IBCBCOMM,U,8)
;
85 ;fl 85 provider representative signature
S IBFL(85,1)=$P(IBSIGN,U,1)
S IBFL(85,2)=$P(IBSIGN,U,2)
86 ;date bill submitted
S IBX=$P($G(^DGCR(399,+IBIFN,"S")),U,12),IBX=$S(+IBPNT:DT,+IBX:IBX,1:DT),IBFL(86)=$$DATE^IBCF3(IBX)
Q
;
;ADD OCCURRENCE CODES AND SPANS TO PRINT ARRAY
32 ;the following rules apply to printing occurrence codes and spans (see FL 32 in UB-92 manual)
; - fields 32a-36a are used before 32b-36b
; - if all occ code fields are used (32a&b -35a&b) then occ span fields (36a&b) may be used, w/ thru date blank
; - if all occ span fields are used (36a&b) the occ code fields 34&35 may be used, w/ code&from date in 34 and code&thru date in 35
;
K IB32,IB36 S IBPG=0 F IBI=32:1:36 K IBFL(IBI) S IBFL(IBI)="0^0"
;occurrence codes/span and dates 32-35 ,36
;load codes and spans into two flat arrays
S (IBI,IBJ,IBX)=0
F S IBX=$O(^DGCR(399,+IBIFN,"OC",IBX)) Q:'IBX S IBY=$G(^(IBX,0)),IBZ=$G(^DGCR(399.1,+IBY,0)) I +$P(IBZ,U,4) D
. I +$P(IBZ,U,10) S IBJ=IBJ+1,IB36(IBJ)=$P(IBZ,U,2)_U_$$DATE^IBCF3($P(IBY,U,2))_U_$$DATE^IBCF3($P(IBY,U,4)) Q
. S IBI=IBI+1,IB32(IBI)=$P(IBZ,U,2)_U_$$DATE^IBCF3($P(IBY,U,2))
S IB32=IBI_U_0
S IB36=IBJ_U_0
;
OCC ;
S IBPG=IBPG+1
S IBI=+$G(IBFL(32))+1
I +IB32 F IBI=IBI,IBI+1 S IBX=+$P(IB32,U,2) F IBJ=32,33,34,35 S IBX=$O(IB32(IBX)) Q:'IBX D
. S IBFL(IBJ,IBI)=IB32(IBX)
. S $P(IBFL(IBJ),U,1)=+IBFL(IBJ)+1
. S $P(IB32,U,1)=+IB32-1
. S $P(IB32,U,2)=IBX
;
S IBX=+$P(IB36,U,2),IBI=+$G(IBFL(36))+1
I +IB36 F IBI=IBI,IBI+1 S IBX=$O(IB36(IBX)) Q:'IBX D
. S IBFL(36,IBI)=IB36(IBX)
. S $P(IBFL(36),U,1)=+IBFL(36)+1
. S $P(IB36,U,1)=+IB36-1
. S $P(IB36,U,2)=IBX
;
I 'IB32,'IB36 G END
;
; add occ codes from 32 to occ span in 36
S IBI=+IBFL(36)+1 F IBI=IBI,IBI+1 I +IB32>0,'IB36,IBI'>(IBPG*2) D
. S IBX=+$P(IB32,U,2),IBX=$O(IB32(IBX)) Q:'IBX
. S IBY=IB32(IBX)
. S $P(IB32,U,1)=+IB32-1
. S $P(IB32,U,2)=IBX
. S IBX=+IBFL(36)+1
. S IBFL(36,IBX)=IBY
. S $P(IBFL(36),U,1)=+IBFL(36)+1
;
; add occ span from 36 to occ code in 32
S IBI=+IBFL(34)+1 F IBI=IBI,IBI+1 I +IB36>0,'IB32,IBI'>(IBPG*2) D
. S IBX=+$P(IB36,U,2),IBX=$O(IB36(IBX)) Q:'IBX
. S IBY=IB36(IBX)
. S $P(IB36,U,1)=+IB36-1
. S $P(IB36,U,2)=IBX
. S IBX=+IBFL(34)+1
. S IBFL(34,IBX)=$P(IBY,U,1)_U_$P(IBY,U,2),$P(IBFL(34),U,1)=+IBFL(34)+1
. S IBFL(35,IBX)=$P(IBY,U,1)_U_$P(IBY,U,3),$P(IBFL(35),U,1)=IBX
G OCC
END ;
K IB32,IB36
Q
IBCF32 ;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 ;
+4 ;This routine requires prior execution of ibcf3.
+5 ;
DX ;set diagnosis codes fl 67-71
+1 ;S IBX=$G(^DGCR(399,+IBIFN,"C"))
+2 ;S IBI=0 F IBJ=14:1:18 S IBFL(67+IBI)=$P($G(^ICD9(+$P(IBX,U,IBJ),0)),U,1),IBI=IBI+1
+3 NEW IBINDXX
DO SET^IBCSC4D(IBIFN,"",.IBINDXX)
SET IBX=0
FOR IBI=1:1:9
SET IBX=$ORDER(IBINDXX(IBX))
IF 'IBX
QUIT
SET IBFL(66+IBI)=$PIECE($GET(^ICD9(+IBINDXX(IBX),0)),U,1)
+4 ;
76 ;fl 76 admitting diagnoses (if a ICD dx not entered get old position of dx)
+1 SET IBCBCOMM=$GET(^DGCR(399,+IBIFN,"U1"))
+2 SET IBX=$PIECE(IBCU2,U,1)
SET IBFL(76)=$SELECT(+IBX:$PIECE($GET(^ICD9(+IBX,0)),U,1),1:$PIECE(IBCBCOMM,U,5))
+3 ;
78 ; set IBFL(78)
SET IBX=$PIECE(IBCUF31,U,2)
DO SPLIT^IBCF3(78,2,3,IBX)
+1 ;fl 79 procedure coding method used
+2 SET IBFL(79)=$PIECE(IBCBILL,U,9)
+3 ;
82 ;fl 82 attending physician id
+1 SET IBFL(82)=$PIECE(IBCBCOMM,U,13)
IF IBFL(82)=""
SET IBFL(82)="Dept. Veterans Affairs"
+2 ;fl 83 other physician id
+3 SET IBFL(83)=$PIECE(IBCBCOMM,U,14)
+4 ;
84 ;fl 84 remarks
+1 SET IBFL(84,1)="Patient ID: "_$PIECE(VADM(2),U,2)
+2 SET IBX=$PIECE($GET(^DGCR(399.3,+$PIECE(IBCBILL,U,7),0)),U,2)
SET IBFL(84,2)="Bill Type: "_$SELECT(IBX'="":IBX,1:"UNSPECIFIED")
+3 SET IBFL(84,3)=$PIECE(IBSIGN,U,4)
+4 SET IBFL(84,4)=$PIECE(IBCBCOMM,U,8)
+5 ;
85 ;fl 85 provider representative signature
+1 SET IBFL(85,1)=$PIECE(IBSIGN,U,1)
+2 SET IBFL(85,2)=$PIECE(IBSIGN,U,2)
86 ;date bill submitted
+1 SET IBX=$PIECE($GET(^DGCR(399,+IBIFN,"S")),U,12)
SET IBX=$SELECT(+IBPNT:DT,+IBX:IBX,1:DT)
SET IBFL(86)=$$DATE^IBCF3(IBX)
+2 QUIT
+3 ;
+4 ;ADD OCCURRENCE CODES AND SPANS TO PRINT ARRAY
32 ;the following rules apply to printing occurrence codes and spans (see FL 32 in UB-92 manual)
+1 ; - fields 32a-36a are used before 32b-36b
+2 ; - if all occ code fields are used (32a&b -35a&b) then occ span fields (36a&b) may be used, w/ thru date blank
+3 ; - if all occ span fields are used (36a&b) the occ code fields 34&35 may be used, w/ code&from date in 34 and code&thru date in 35
+4 ;
+5 KILL IB32,IB36
SET IBPG=0
FOR IBI=32:1:36
KILL IBFL(IBI)
SET IBFL(IBI)="0^0"
+6 ;occurrence codes/span and dates 32-35 ,36
+7 ;load codes and spans into two flat arrays
+8 SET (IBI,IBJ,IBX)=0
+9 FOR
SET IBX=$ORDER(^DGCR(399,+IBIFN,"OC",IBX))
IF 'IBX
QUIT
SET IBY=$GET(^(IBX,0))
SET IBZ=$GET(^DGCR(399.1,+IBY,0))
IF +$PIECE(IBZ,U,4)
Begin DoDot:1
+10 IF +$PIECE(IBZ,U,10)
SET IBJ=IBJ+1
SET IB36(IBJ)=$PIECE(IBZ,U,2)_U_$$DATE^IBCF3($PIECE(IBY,U,2))_U_$$DATE^IBCF3($PIECE(IBY,U,4))
QUIT
+11 SET IBI=IBI+1
SET IB32(IBI)=$PIECE(IBZ,U,2)_U_$$DATE^IBCF3($PIECE(IBY,U,2))
End DoDot:1
+12 SET IB32=IBI_U_0
+13 SET IB36=IBJ_U_0
+14 ;
OCC ;
+1 SET IBPG=IBPG+1
+2 SET IBI=+$GET(IBFL(32))+1
+3 IF +IB32
FOR IBI=IBI,IBI+1
SET IBX=+$PIECE(IB32,U,2)
FOR IBJ=32,33,34,35
SET IBX=$ORDER(IB32(IBX))
IF 'IBX
QUIT
Begin DoDot:1
+4 SET IBFL(IBJ,IBI)=IB32(IBX)
+5 SET $PIECE(IBFL(IBJ),U,1)=+IBFL(IBJ)+1
+6 SET $PIECE(IB32,U,1)=+IB32-1
+7 SET $PIECE(IB32,U,2)=IBX
End DoDot:1
+8 ;
+9 SET IBX=+$PIECE(IB36,U,2)
SET IBI=+$GET(IBFL(36))+1
+10 IF +IB36
FOR IBI=IBI,IBI+1
SET IBX=$ORDER(IB36(IBX))
IF 'IBX
QUIT
Begin DoDot:1
+11 SET IBFL(36,IBI)=IB36(IBX)
+12 SET $PIECE(IBFL(36),U,1)=+IBFL(36)+1
+13 SET $PIECE(IB36,U,1)=+IB36-1
+14 SET $PIECE(IB36,U,2)=IBX
End DoDot:1
+15 ;
+16 IF 'IB32
IF 'IB36
GOTO END
+17 ;
+18 ; add occ codes from 32 to occ span in 36
+19 SET IBI=+IBFL(36)+1
FOR IBI=IBI,IBI+1
IF +IB32>0
IF 'IB36
IF IBI'>(IBPG*2)
Begin DoDot:1
+20 SET IBX=+$PIECE(IB32,U,2)
SET IBX=$ORDER(IB32(IBX))
IF 'IBX
QUIT
+21 SET IBY=IB32(IBX)
+22 SET $PIECE(IB32,U,1)=+IB32-1
+23 SET $PIECE(IB32,U,2)=IBX
+24 SET IBX=+IBFL(36)+1
+25 SET IBFL(36,IBX)=IBY
+26 SET $PIECE(IBFL(36),U,1)=+IBFL(36)+1
End DoDot:1
+27 ;
+28 ; add occ span from 36 to occ code in 32
+29 SET IBI=+IBFL(34)+1
FOR IBI=IBI,IBI+1
IF +IB36>0
IF 'IB32
IF IBI'>(IBPG*2)
Begin DoDot:1
+30 SET IBX=+$PIECE(IB36,U,2)
SET IBX=$ORDER(IB36(IBX))
IF 'IBX
QUIT
+31 SET IBY=IB36(IBX)
+32 SET $PIECE(IB36,U,1)=+IB36-1
+33 SET $PIECE(IB36,U,2)=IBX
+34 SET IBX=+IBFL(34)+1
+35 SET IBFL(34,IBX)=$PIECE(IBY,U,1)_U_$PIECE(IBY,U,2)
SET $PIECE(IBFL(34),U,1)=+IBFL(34)+1
+36 SET IBFL(35,IBX)=$PIECE(IBY,U,1)_U_$PIECE(IBY,U,3)
SET $PIECE(IBFL(35),U,1)=IBX
End DoDot:1
+37 GOTO OCC
END ;
+1 KILL IB32,IB36
+2 QUIT
