IBECEAU3.m

IBECEAU3	;ALB/CPM - Cancel/Edit/Add... Add New IB Action ; 11-MAR-93

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

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

	;

ADD	; Add a new Integrated Billing Action entry.

	;   Input:     DFN  --  Pointer to patient in file #2

	;           IBATYP  --  Pointer to Action Type in file #350.1

	;           IBUNIT  --  Number of units of charge

	;            IBCHG  --  Total charge

	;           IBDESC  --  Charge description

	;           IBSITE  --  Pointer to the facility in file #4

	;            IBFAC  --  Facility number

	;             IBFR  --  Bill From date

	;             IBTO  --  Bill To date

	;             IBSL  --  Softlink  [OPTIONAL]

	;          IBPARNT  --  Pointer to parent entry in #350  [OPTIONAL]

	;           IBEVDA  --  Pointer to parent event in #350  [OPTIONAL], or

	;                   --  "*" to set ibevda=ibn

	;           IBEVDT  --  Event Date  [OPTIONAL]

	;             IBIL  --  Bill Number  [OPTIONAL]

	;           IBCRES  --  Pointer to canc. reason in #350.3  [OPTIONAL]

	;             IBXA  --  IB Action billing group  [OPTIONAL]

	;            IBJOB  --  Option being executed  [OPTIONAL]

	;            IBCVA  --  CHAMPVA Admission date [OPTIONAL]

	;

	;  Output:     IBN  --  Internal number of new entry in file #350

	;

	N DA,DIK,IBASTR,IBND,Y

	D ADD^IBAUTL I Y<1 S IBY=Y G ADDQ

	S:$G(IBEVDA)="*" IBEVDA=IBN

	S IBND=DFN_"^"_IBATYP_"^"_$S($G(IBSL):IBSL,1:"350:"_IBN)_"^1^"_IBUNIT_"^"_IBCHG_"^"_IBDESC_"^"_$S($D(IBPARNT):IBPARNT,1:IBN)_"^"_$G(IBCRES)_"^"_$G(IBIL)_"^^"_IBFAC

	I IBDESC'["RX COPAY" S IBND=IBND_"^"_IBFR_"^"_IBTO_"^"_$G(IBEVDA)_$S($G(IBEVDT):"^"_IBEVDT,$G(IBXA)=1!($G(IBXA)=4)!($G(IBJOB)=5):"^"_IBFR,1:"")

	S $P(^IB(IBN,0),"^",2,17)=IBND

	D NOW^%DTC S $P(^IB(IBN,1),"^")=DUZ,$P(^(1),"^",3,5)=DUZ_"^"_%_$S($G(IBCVA):"^"_IBCVA,1:"")

	S DIK="^IB(",DA=IBN D IX1^DIK

ADDQ	Q

	;

CTBB	; Charge to be billed

	W !!,"Charge to be billed --> $",$J(IBCHG,0,2)

	Q

	;

NODED	; Could not determine the Medicare Deductible amount.

	W !,*7,"The Medicare Deductible Amount for ",$$DAT1^IBOUTL(IBCLDT)," could not be determined."

	W !,"You should determine the cause of this problem before proceeding."

	S IBY=-1

	Q

IBECEAU3  ;ALB/CPM - Cancel/Edit/Add... Add New IB Action ; 11-MAR-93

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

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

 +3       ;

ADD       ; Add a new Integrated Billing Action entry.

 +1       ;   Input:     DFN  --  Pointer to patient in file #2

 +2       ;           IBATYP  --  Pointer to Action Type in file #350.1

 +3       ;           IBUNIT  --  Number of units of charge

 +4       ;            IBCHG  --  Total charge

 +5       ;           IBDESC  --  Charge description

 +6       ;           IBSITE  --  Pointer to the facility in file #4

 +7       ;            IBFAC  --  Facility number

 +8       ;             IBFR  --  Bill From date

 +9       ;             IBTO  --  Bill To date

 +10      ;             IBSL  --  Softlink  [OPTIONAL]

 +11      ;          IBPARNT  --  Pointer to parent entry in #350  [OPTIONAL]

 +12      ;           IBEVDA  --  Pointer to parent event in #350  [OPTIONAL], or

 +13      ;                   --  "*" to set ibevda=ibn

 +14      ;           IBEVDT  --  Event Date  [OPTIONAL]

 +15      ;             IBIL  --  Bill Number  [OPTIONAL]

 +16      ;           IBCRES  --  Pointer to canc. reason in #350.3  [OPTIONAL]

 +17      ;             IBXA  --  IB Action billing group  [OPTIONAL]

 +18      ;            IBJOB  --  Option being executed  [OPTIONAL]

 +19      ;            IBCVA  --  CHAMPVA Admission date [OPTIONAL]

 +20      ;

 +21      ;  Output:     IBN  --  Internal number of new entry in file #350

 +22      ;

 +23       NEW DA,DIK,IBASTR,IBND,Y

 +24       DO ADD^IBAUTL

           IF Y<1

               SET IBY=Y

               GOTO ADDQ

 +25       IF $GET(IBEVDA)="*"

               SET IBEVDA=IBN

 +26       SET IBND=DFN_"^"_IBATYP_"^"_$SELECT($GET(IBSL):IBSL,1:"350:"_IBN)_"^1^"_IBUNIT_"^"_IBCHG_"^"_IBDESC_"^"_$SELECT($DATA(IBPARNT):IBPARNT,1:IBN)_"^"_$GET(IBCRES)_"^"_$GET(IBIL)_"^^"_IBFAC

 +27       IF IBDESC'["RX COPAY"

               SET IBND=IBND_"^"_IBFR_"^"_IBTO_"^"_$GET(IBEVDA)_$SELECT($GET(IBEVDT):"^"_IBEVDT,$GET(IBXA)=1!($GET(IBXA)=4)!($GET(IBJOB)=5):"^"_IBFR,1:"")

 +28       SET $PIECE(^IB(IBN,0),"^",2,17)=IBND

 +29       DO NOW^%DTC

           SET $PIECE(^IB(IBN,1),"^")=DUZ

           SET $PIECE(^(1),"^",3,5)=DUZ_"^"_%_$SELECT($GET(IBCVA):"^"_IBCVA,1:"")

 +30       SET DIK="^IB("

           SET DA=IBN

           DO IX1^DIK

ADDQ       QUIT 

 +1       ;

CTBB      ; Charge to be billed

 +1        WRITE !!,"Charge to be billed --> $",$JUSTIFY(IBCHG,0,2)

 +2        QUIT 

 +3       ;

NODED     ; Could not determine the Medicare Deductible amount.

 +1        WRITE !,*7,"The Medicare Deductible Amount for ",$$DAT1^IBOUTL(IBCLDT)," could not be determined."

 +2        WRITE !,"You should determine the cause of this problem before proceeding."

 +3        SET IBY=-1

 +4        QUIT