IBCSC82.m

IBCSC82	;ALB/MJB - MCCR SCREEN 8 (UB-92 BILL SPECIFIC INFO)  ;27 MAY 88 10:20

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

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

	;

EN	S IBCUBFT=$$FT^IBCU3(IBIFN) I IBCUBFT=2 K IBCUBFT G ^IBCSC8H ;hcfa 1500

	;

	D ^IBCSCU S IBSR=8,IBSR1=2,IBV1="00000" S:IBV IBV1="11111" F I="U","U1",0,"UF3","UF31","U2" S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I),1:"")

	D H^IBCSCU

	S Z=1,IBW=1 X IBWW W " Bill Remark     : ",$S($P(IB("U1"),U,8)]"":$P(IB("U1"),U,8),1:IBUN)

	W !,?3," Tx Auth. Code   : ",$S($P(IB("U"),U,13)]"":$P(IB("U"),U,13),1:IBUN)

	W !,?3," Admitting Dx    : " S IBX=$P(IB("U2"),U,1),IBX=$G(^ICD9(+IBX,0)) W $S(IBX'="":$P(IBX,U,1)_" - "_$P(IBX,U,3),1:IBUN)

	S Z=2,IBW=1 X IBWW W " Attending Phy.  : ",$S($P(IB("U1"),U,13)]"":$P(IB("U1"),U,13),1:IBUN)

	W !,?3," Other Physician : ",$S($P(IB("U1"),U,14)]"":$P(IB("U1"),U,14),1:IBUN)

	S Z=3,IBW=1 X IBWW W " Form Locator 2  : ",$S($P(IB("UF3"),U,1)]"":$P(IB("UF3"),U,1),1:IBUN)

	W !,?3," Form Locator 11 : ",$S($P(IB("UF3"),U,2)]"":$P(IB("UF3"),U,2),1:IBUN)

	S Z=4,IBW=1 X IBWW W " Form Locator 31 : ",$S($P(IB("UF3"),U,3)]"":$P(IB("UF3"),U,3),1:IBUN)

	S IBX=0 I $P(IB("UF3"),U,4)'="" W !,?3," Form Locator 37A: ",$P(IB("UF3"),U,4) S IBX=1

	I $P(IB("UF3"),U,5)'="" W !,?3," Form Locator 37B: ",$P(IB("UF3"),U,5) S IBX=1

	I $P(IB("UF3"),U,6)'="" W !,?3," Form Locator 37C: ",$P(IB("UF3"),U,6) S IBX=1

	I 'IBX W !,?3," Form Locator 37 : ",IBUN

	S Z=5,IBW=1 X IBWW W " Form Locator 56 : ",$S($P(IB("UF3"),U,7)]"":$P(IB("UF3"),U,7),1:IBUN)

	W !,?3," Form Locator 57 : ",$S($P(IB("UF31"),U,1)]"":$P(IB("UF31"),U,1),1:IBUN)

	W !,?3," Form Locator 78 : ",$S($P(IB("UF31"),U,2)]"":$P(IB("UF31"),U,2),1:IBUN)

	G ^IBCSCP

Q	Q

	;IBCSC8

IBCSC82   ;ALB/MJB - MCCR SCREEN 8 (UB-92 BILL SPECIFIC INFO)  ;27 MAY 88 10:20

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

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

 +3       ;

EN        ;hcfa 1500

           SET IBCUBFT=$$FT^IBCU3(IBIFN)

           IF IBCUBFT=2

               KILL IBCUBFT

               GOTO ^IBCSC8H

 +1       ;

 +2        DO ^IBCSCU

           SET IBSR=8

           SET IBSR1=2

           SET IBV1="00000"

           IF IBV

               SET IBV1="11111"

           FOR I="U","U1",0,"UF3","UF31","U2"

               SET IB(I)=$SELECT($DATA(^DGCR(399,IBIFN,I)):^(I),1:"")

 +3        DO H^IBCSCU

 +4        SET Z=1

           SET IBW=1

           XECUTE IBWW

           WRITE " Bill Remark     : ",$SELECT($PIECE(IB("U1"),U,8)]"":$PIECE(IB("U1"),U,8),1:IBUN)

 +5        WRITE !,?3," Tx Auth. Code   : ",$SELECT($PIECE(IB("U"),U,13)]"":$PIECE(IB("U"),U,13),1:IBUN)

 +6        WRITE !,?3," Admitting Dx    : "

           SET IBX=$PIECE(IB("U2"),U,1)

           SET IBX=$GET(^ICD9(+IBX,0))

           WRITE $SELECT(IBX'="":$PIECE(IBX,U,1)_" - "_$PIECE(IBX,U,3),1:IBUN)

 +7        SET Z=2

           SET IBW=1

           XECUTE IBWW

           WRITE " Attending Phy.  : ",$SELECT($PIECE(IB("U1"),U,13)]"":$PIECE(IB("U1"),U,13),1:IBUN)

 +8        WRITE !,?3," Other Physician : ",$SELECT($PIECE(IB("U1"),U,14)]"":$PIECE(IB("U1"),U,14),1:IBUN)

 +9        SET Z=3

           SET IBW=1

           XECUTE IBWW

           WRITE " Form Locator 2  : ",$SELECT($PIECE(IB("UF3"),U,1)]"":$PIECE(IB("UF3"),U,1),1:IBUN)

 +10       WRITE !,?3," Form Locator 11 : ",$SELECT($PIECE(IB("UF3"),U,2)]"":$PIECE(IB("UF3"),U,2),1:IBUN)

 +11       SET Z=4

           SET IBW=1

           XECUTE IBWW

           WRITE " Form Locator 31 : ",$SELECT($PIECE(IB("UF3"),U,3)]"":$PIECE(IB("UF3"),U,3),1:IBUN)

 +12       SET IBX=0

           IF $PIECE(IB("UF3"),U,4)'=""

               WRITE !,?3," Form Locator 37A: ",$PIECE(IB("UF3"),U,4)

               SET IBX=1

 +13       IF $PIECE(IB("UF3"),U,5)'=""

               WRITE !,?3," Form Locator 37B: ",$PIECE(IB("UF3"),U,5)

               SET IBX=1

 +14       IF $PIECE(IB("UF3"),U,6)'=""

               WRITE !,?3," Form Locator 37C: ",$PIECE(IB("UF3"),U,6)

               SET IBX=1

 +15       IF 'IBX

               WRITE !,?3," Form Locator 37 : ",IBUN

 +16       SET Z=5

           SET IBW=1

           XECUTE IBWW

           WRITE " Form Locator 56 : ",$SELECT($PIECE(IB("UF3"),U,7)]"":$PIECE(IB("UF3"),U,7),1:IBUN)

 +17       WRITE !,?3," Form Locator 57 : ",$SELECT($PIECE(IB("UF31"),U,1)]"":$PIECE(IB("UF31"),U,1),1:IBUN)

 +18       WRITE !,?3," Form Locator 78 : ",$SELECT($PIECE(IB("UF31"),U,2)]"":$PIECE(IB("UF31"),U,2),1:IBUN)

 +19       GOTO ^IBCSCP

Q          QUIT 

 +1       ;IBCSC8