Routine: IBCA2

IBCA2	;ALB/MRL - ADD NEW BILL  ;01 JUN 88 12:00

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

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

	;MAP TO DGCRA2

	W !,"Passing bill to Accounts Receivable Module..." D SETUP^PRCASVC3

	I $S($P(PRCASV("ARREC"),U)=-1:1,$P(PRCASV("ARBIL"),U)=-1:1,1:0) W *7,"  ",$P(PRCASV("ARREC"),"^",2),!,$$ETXT^IBEFUNC($P(PRCASV("ARBIL"),"^",2)) D Q G NREC^IBCA

	S IBIDS(.01)=$P(PRCASV("ARBIL"),"-",2),IBIDS(.17)=$S($D(IBIDS(.17)):IBIDS(.17),1:PRCASV("ARREC"))

	W !,"Billing Record #",IBIDS(.01)," being established for '",VADM(1),"'..." S IBIDS(.02)=DFN

	;D SC^IBCU3 ;calculate if SC veteran

	S IBIDS(.18)=$$SC^IBCU3(DFN) ; calculate if SC veteran

	D SPEC^IBCU4 ;calculate discharge bedsection

	S X=$P($T(WHERE),";;",2) F I=0:0 S I=$O(IBIDS(I)) Q:'I  S X1=$P($E(X,$F(X,I)+1,999),";",1),$P(IBDR($P(X1,"^",1)),"^",$P(X1,"^",2))=IBIDS(I)

	S IBIFN=PRCASV("ARREC") F I=0,"C","M","M1","S","U","U1" I $D(IBDR(I)) S ^DGCR(399,IBIFN,I)=IBDR(I)

	S $P(^DGCR(399,0),"^",3)=IBIFN,$P(^(0),"^",4)=$P(^(0),"^",4)+1 W !,"Cross-referencing new billing entry..." S DIK="^DGCR(399,",DA=IBIFN D IX1^DIK K DA,DIK

	S IBYN=1 W !!,*7,"Billing Record #",$P(^DGCR(399,+IBIFN,0),"^",1)," established for '",VADM(1),"'..."

	K DGPTUPDT D ^IBCU6

Q	K %,%DT,IBI,IBJ,IBDSDT,IBX,IB,IBA,IBNWBL,IBBT,IBIDS,I,J,VADM,X,X1,X2,X3,X4,Y,DGDIRA,DGDIRB,DGDIR0,DIR,DGRVRCAL Q

XREF	F IBI1=0:0 S IBI1=$O(^DD(399,IBI,1,IBI1)) Q:'IBI1  I $D(^DD(399,IBI,1,IBI1,1)) S DA=IBIFN,X=IBIDS(IBI) X ^DD(399,IBI,1,IBI1,1)

WHERE	;;.01^0^1;.02^0^2;.03^0^3;.04^0^4;.05^0^5;.06^0^6;.07^0^7;.08^0^8;.11^0^11;.17^0^17;.16^0^16;.18^0^18;.19^0^19;112^M^12;151^U^1;152^U^2;155^U^5;101^M^1;158^U^8;159^U^9;160^U^10;161^U^11;162^U^12;

WHEREOLD	;.01^0^1;.02^0^2;.03^0^3;.04^0^4;.05^0^5;.06^0^6;.07^0^7;.08^0^8;.11^0^11;.17^0^17;.16^0^16;.18^0^18;104^M^4;105^M^5;106^M^6;107^M^7;108^M^8;109^M^9;121^M1^1;151^U^1;152^U^2;155^U^5;101^M^1;158^U^8;159^U^9;160^U^10;161^U^11;162^U^12;

IBCA2     ;ALB/MRL - ADD NEW BILL  ;01 JUN 88 12:00

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

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

 +3       ;

 +4       ;MAP TO DGCRA2

 +5       ;

 +6        WRITE !,"Passing bill to Accounts Receivable Module..."

           DO SETUP^PRCASVC3

 +7        IF $SELECT($PIECE(PRCASV("ARREC"),U)=-1:1,$PIECE(PRCASV("ARBIL"),U)=-1:1,1:0)

               WRITE *7,"  ",$PIECE(PRCASV("ARREC"),"^",2),!,$$ETXT^IBEFUNC($PIECE(PRCASV("ARBIL"),"^",2))

               DO Q

               GOTO NREC^IBCA

 +8        SET IBIDS(.01)=$PIECE(PRCASV("ARBIL"),"-",2)

           SET IBIDS(.17)=$SELECT($DATA(IBIDS(.17)):IBIDS(.17),1:PRCASV("ARREC"))

 +9        WRITE !,"Billing Record #",IBIDS(.01)," being established for '",VADM(1),"'..."

           SET IBIDS(.02)=DFN

 +10      ;D SC^IBCU3 ;calculate if SC veteran

 +11      ; calculate if SC veteran

           SET IBIDS(.18)=$$SC^IBCU3(DFN)

 +12      ;calculate discharge bedsection

           DO SPEC^IBCU4

 +13       SET X=$PIECE($TEXT(WHERE),";;",2)

           FOR I=0:0

               SET I=$ORDER(IBIDS(I))

               IF 'I

                   QUIT

               SET X1=$PIECE($EXTRACT(X,$FIND(X,I)+1,999),";",1)

               SET $PIECE(IBDR($PIECE(X1,"^",1)),"^",$PIECE(X1,"^",2))=IBIDS(I)

 +14       SET IBIFN=PRCASV("ARREC")

           FOR I=0,"C","M","M1","S","U","U1"

               IF $DATA(IBDR(I))

                   SET ^DGCR(399,IBIFN,I)=IBDR(I)

 +15       SET $PIECE(^DGCR(399,0),"^",3)=IBIFN

           SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)+1

           WRITE !,"Cross-referencing new billing entry..."

           SET DIK="^DGCR(399,"

           SET DA=IBIFN

           DO IX1^DIK

           KILL DA,DIK

 +16       SET IBYN=1

           WRITE !!,*7,"Billing Record #",$PIECE(^DGCR(399,+IBIFN,0),"^",1)," established for '",VADM(1),"'..."

 +17       KILL DGPTUPDT

           DO ^IBCU6

Q          KILL %,%DT,IBI,IBJ,IBDSDT,IBX,IB,IBA,IBNWBL,IBBT,IBIDS,I,J,VADM,X,X1,X2,X3,X4,Y,DGDIRA,DGDIRB,DGDIR0,DIR,DGRVRCAL

           QUIT

 +1       ;

XREF       FOR IBI1=0:0

               SET IBI1=$ORDER(^DD(399,IBI,1,IBI1))

               IF 'IBI1

                   QUIT

               IF $DATA(^DD(399,IBI,1,IBI1,1))

                   SET DA=IBIFN

                   SET X=IBIDS(IBI)

                   XECUTE ^DD(399,IBI,1,IBI1,1)

 +1        QUIT

 +2       ;

WHERE     ;;.01^0^1;.02^0^2;.03^0^3;.04^0^4;.05^0^5;.06^0^6;.07^0^7;.08^0^8;.11^0^11;.17^0^17;.16^0^16;.18^0^18;.19^0^19;112^M^12;151^U^1;152^U^2;155^U^5;101^M^1;158^U^8;159^U^9;160^U^10;161^U^11;162^U^12;

 +1       ;

WHEREOLD  ;.01^0^1;.02^0^2;.03^0^3;.04^0^4;.05^0^5;.06^0^6;.07^0^7;.08^0^8;.11^0^11;.17^0^17;.16^0^16;.18^0^18;104^M^4;105^M^5;106^M^6;107^M^7;108^M^8;109^M^9;121^M1^1;151^U^1;152^U^2;155^U^5;101^M^1;158^U^8;159^U^9;160^U^10;161^U^11;162^U^12;

 +1        QUIT

IBCA2.m