IBCSC8H.m

IBCSC8H	;ALB/ARH - MCCR SCREEN 8 (BILL SPECIFIC INFO) HCFA 1500 ; 4/21/92

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

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

	;HCFA 1500 screen 8

	;

	;MAP TO DGCRSC8H

	;

EN	D ^IBCSCU S IBSR=8,IBSR1="H",IBV1="000" S:IBV IBV1="111" F I="U","U1","UF2",0 S IB(I)=$G(^DGCR(399,IBIFN,I))

	D H^IBCSCU

	S Z=1,IBW=1 X IBWW W " Unable To Work From: " S Y=$P(IB("U"),U,16) X ^DD("DD") W $S(Y'="":Y,1:IBUN)

	W !?4,"Unable To Work To  : " S Y=$P(IB("U"),U,17) X ^DD("DD") W $S(Y'="":Y,1:IBUN)

	S Z=2,IBW=1 X IBWW W " Block 31           : ",$S($P(IB("UF2"),U,1)]"":$P(IB("UF2"),U,1),1:IBUN)

	S Z=3,IBW=1 X IBWW W " Tx Auth. Code      : ",$S($P(IB("U"),U,13)]"":$P(IB("U"),U,13),1:IBUN)

	G ^IBCSCP

Q	Q

	;IBCSC8H

IBCSC8H   ;ALB/ARH - MCCR SCREEN 8 (BILL SPECIFIC INFO) HCFA 1500 ; 4/21/92

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

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

 +3       ;HCFA 1500 screen 8

 +4       ;

 +5       ;MAP TO DGCRSC8H

 +6       ;

EN         DO ^IBCSCU

           SET IBSR=8

           SET IBSR1="H"

           SET IBV1="000"

           IF IBV

               SET IBV1="111"

           FOR I="U","U1","UF2",0

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

 +1        DO H^IBCSCU

 +2        SET Z=1

           SET IBW=1

           XECUTE IBWW

           WRITE " Unable To Work From: "

           SET Y=$PIECE(IB("U"),U,16)

           XECUTE ^DD("DD")

           WRITE $SELECT(Y'="":Y,1:IBUN)

 +3        WRITE !?4,"Unable To Work To  : "

           SET Y=$PIECE(IB("U"),U,17)

           XECUTE ^DD("DD")

           WRITE $SELECT(Y'="":Y,1:IBUN)

 +4        SET Z=2

           SET IBW=1

           XECUTE IBWW

           WRITE " Block 31           : ",$SELECT($PIECE(IB("UF2"),U,1)]"":$PIECE(IB("UF2"),U,1),1:IBUN)

 +5        SET Z=3

           SET IBW=1

           XECUTE IBWW

           WRITE " Tx Auth. Code      : ",$SELECT($PIECE(IB("U"),U,13)]"":$PIECE(IB("U"),U,13),1:IBUN)

 +6        GOTO ^IBCSCP

Q          QUIT 

 +1       ;IBCSC8H