- 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
