Routine: IBCF22

IBCF22	;ALB/ARH - HCFA 1500 19-90 DATA (gather other data) ; 12-JUN-93

	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

	;;Per VHA Directive 10-93-142, this routine should not be modified.

	; requires DFN, IBIFN, IB(0)

	F IBI="C","U","U1","UF2" S IB(IBI)=$G(^DGCR(399,IBIFN,IBI))

	S IBFLD(12)="PUBLIC LAW 99-272/SECTION 1729 TITLE 38"

	S IBFLD(13)="PUBLIC LAW 99-272"

DATES	S IBFLD(14)=$$DATE($P(IB(0),U,3))

	I $G(IBFLD(15))="",IBIFN'=$P(IB(0),U,17) S IBFLD(15)=$$DATE($P($G(^DGCR(399,+$P(IB(0),U,17),0)),U,3))

	S IBFLD("16A")=$$DATE($P(IB("U"),U,16)),IBFLD("16B")=$$DATE($P(IB("U"),U,17))

	I $P(IB(0),U,5)<3 S IBFLD("18A")=$$DATE($P(IB("U"),U,1)),IBFLD("18B")=$$DATE($P(IB("U"),U,2))

	I $P(IB(0),U,5)>2 S VAINDT=$P(IB(0),U,3) D INP^VADPT I +VAIN(1) D

	. S IBFLD("18A")=$$DATE(VAIN(7)),IBFLD("18B")=$$DATE(+$G(^DGPM(+$P($G(^DGPM(+VAIN(1),0)),U,17),0)))

	K VAINDT,VAIN

	S IBFLD(19)="THE UNDERSIGNED CERTIFIES TREATMENT IS NOT FOR A SERVICE-CONNECTED CONDITION"

	S IBFLD(20)=0

DX	;S X=14 F IBI="21A","21B","21C","21D" S IBFLD(IBI)=$P($G(^ICD9(+$P(IB("C"),U,X),0)),U,1),X=X+1

	;F IBI="21A","21B","21C","21D" S IBFLD(IBI)=""

	;N IBINDXX D SET^IBCSC4D(IBIFN,"",.IBINDXX) S X=0,Y="21@" D

	;. F  S X=$O(IBINDXX(X)) Q:'X  S Y=$O(IBFLD(Y)) Q:+Y'=21  S IBFLD(Y)=$P($G(^ICD9(+IBINDXX(X),0)),U,1)

	N IBDXX,IBPOX D SET^IBCSC4D(IBIFN,.IBDXX,.IBPOX) S X=0

	F IBI=1:1:4 S IBFLD(21,IBI)="" I IBI'>$P(IBPOX,U,2) S X=$O(IBPOX(X)),IBFLD(21,IBI)=$P($G(^ICD9(+IBPOX(X),0)),U,1),IBDXI(+$G(IBDXX(+IBPOX(X))))=IBI

	S IBFLD(23)=$P(IB("U"),U,13)

	D ^IBCF23 ; block 24

	S IBFLD(25)=$P($G(^IBE(350.9,1,1)),U,5)

	S IBFLD(26)=$P(IB(0),U,1)

	S IBFLD(28)=+IB("U1")-$P(IB("U1"),U,2)

LAST3	S IBFLD(31)=$G(^DGCR(399,IBIFN,"UF2")) ;assuming there are 3 available lines

	S X=+$P($G(^IBE(350.9,1,0)),U,2),Y=$G(^DIC(4,X,0)),IBI=1 I Y'="" D

	. S IBFLD(32,1)=$P(Y,U,1),IBX=+$P(Y,U,2),Y=$G(^DIC(4,X,1))

	. S IBFLD(32,2)=$P(Y,U,1) I $P(Y,U,2)'="" S IBFLD(32,2)=IBFLD(32,2)_", "_$P(Y,U,2)

	. S IBFLD(32,3)=$P(Y,U,3),IBFLD(32,"X")=$$STATE^IBCF2(IBX)_" "_$P(Y,U,4)

	S X=$G(^IBE(350.9,1,2))

	S IBFLD(33,1)=$P(X,U,1),IBFLD(33,2)=$P(X,U,2)

	S IBFLD(33,3)=$P(X,U,3),IBFLD(33,"X")=$$STATE^IBCF2($P(X,U,4))_" "_$P(X,U,5)

	S IBFLD(33,4)=$P(X,U,6)

END	Q

DATE(X)	; returns date in form format

	Q ($E(X,4,5)_" "_$E(X,6,7)_" "_$E(X,2,3))

IBCF22    ;ALB/ARH - HCFA 1500 19-90 DATA (gather other data) ; 12-JUN-93

 +1       ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

 +4       ; requires DFN, IBIFN, IB(0)

 +5        FOR IBI="C","U","U1","UF2"

               SET IB(IBI)=$GET(^DGCR(399,IBIFN,IBI))

 +6        SET IBFLD(12)="PUBLIC LAW 99-272/SECTION 1729 TITLE 38"

 +7        SET IBFLD(13)="PUBLIC LAW 99-272"

DATES      SET IBFLD(14)=$$DATE($PIECE(IB(0),U,3))

 +1        IF $GET(IBFLD(15))=""

               IF IBIFN'=$PIECE(IB(0),U,17)

                   SET IBFLD(15)=$$DATE($PIECE($GET(^DGCR(399,+$PIECE(IB(0),U,17),0)),U,3))

 +2        SET IBFLD("16A")=$$DATE($PIECE(IB("U"),U,16))

           SET IBFLD("16B")=$$DATE($PIECE(IB("U"),U,17))

 +3        IF $PIECE(IB(0),U,5)<3

               SET IBFLD("18A")=$$DATE($PIECE(IB("U"),U,1))

               SET IBFLD("18B")=$$DATE($PIECE(IB("U"),U,2))

 +4        IF $PIECE(IB(0),U,5)>2

               SET VAINDT=$PIECE(IB(0),U,3)

               DO INP^VADPT

               IF +VAIN(1)

                   Begin DoDot:1

 +5                    SET IBFLD("18A")=$$DATE(VAIN(7))

                       SET IBFLD("18B")=$$DATE(+$GET(^DGPM(+$PIECE($GET(^DGPM(+VAIN(1),0)),U,17),0)))

                   End DoDot:1

 +6        KILL VAINDT,VAIN

 +7        SET IBFLD(19)="THE UNDERSIGNED CERTIFIES TREATMENT IS NOT FOR A SERVICE-CONNECTED CONDITION"

 +8        SET IBFLD(20)=0

 +9       ;

DX        ;S X=14 F IBI="21A","21B","21C","21D" S IBFLD(IBI)=$P($G(^ICD9(+$P(IB("C"),U,X),0)),U,1),X=X+1

 +1       ;F IBI="21A","21B","21C","21D" S IBFLD(IBI)=""

 +2       ;N IBINDXX D SET^IBCSC4D(IBIFN,"",.IBINDXX) S X=0,Y="21@" D

 +3       ;. F  S X=$O(IBINDXX(X)) Q:'X  S Y=$O(IBFLD(Y)) Q:+Y'=21  S IBFLD(Y)=$P($G(^ICD9(+IBINDXX(X),0)),U,1)

 +4       ;

 +5        NEW IBDXX,IBPOX

           DO SET^IBCSC4D(IBIFN,.IBDXX,.IBPOX)

           SET X=0

 +6        FOR IBI=1:1:4

               SET IBFLD(21,IBI)=""

               IF IBI'>$PIECE(IBPOX,U,2)

                   SET X=$ORDER(IBPOX(X))

                   SET IBFLD(21,IBI)=$PIECE($GET(^ICD9(+IBPOX(X),0)),U,1)

                   SET IBDXI(+$GET(IBDXX(+IBPOX(X))))=IBI

 +7       ;

 +8        SET IBFLD(23)=$PIECE(IB("U"),U,13)

 +9       ;

 +10      ; block 24

           DO ^IBCF23

 +11      ;

 +12       SET IBFLD(25)=$PIECE($GET(^IBE(350.9,1,1)),U,5)

 +13       SET IBFLD(26)=$PIECE(IB(0),U,1)

 +14       SET IBFLD(28)=+IB("U1")-$PIECE(IB("U1"),U,2)

LAST3     ;assuming there are 3 available lines

           SET IBFLD(31)=$GET(^DGCR(399,IBIFN,"UF2"))

 +1        SET X=+$PIECE($GET(^IBE(350.9,1,0)),U,2)

           SET Y=$GET(^DIC(4,X,0))

           SET IBI=1

           IF Y'=""

               Begin DoDot:1

 +2                SET IBFLD(32,1)=$PIECE(Y,U,1)

                   SET IBX=+$PIECE(Y,U,2)

                   SET Y=$GET(^DIC(4,X,1))

 +3                SET IBFLD(32,2)=$PIECE(Y,U,1)

                   IF $PIECE(Y,U,2)'=""

                       SET IBFLD(32,2)=IBFLD(32,2)_", "_$PIECE(Y,U,2)

 +4                SET IBFLD(32,3)=$PIECE(Y,U,3)

                   SET IBFLD(32,"X")=$$STATE^IBCF2(IBX)_" "_$PIECE(Y,U,4)

               End DoDot:1

 +5        SET X=$GET(^IBE(350.9,1,2))

 +6        SET IBFLD(33,1)=$PIECE(X,U,1)

           SET IBFLD(33,2)=$PIECE(X,U,2)

 +7        SET IBFLD(33,3)=$PIECE(X,U,3)

           SET IBFLD(33,"X")=$$STATE^IBCF2($PIECE(X,U,4))_" "_$PIECE(X,U,5)

 +8        SET IBFLD(33,4)=$PIECE(X,U,6)

 +9       ;

END        QUIT

 +1       ;

DATE(X)   ; returns date in form format

 +1        QUIT ($EXTRACT(X,4,5)_" "_$EXTRACT(X,6,7)_" "_$EXTRACT(X,2,3))

IBCF22.m