Routine: IBCF32

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)

	;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

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

IBCF32.m