Routine: IBCCC1

IBCCC1	;ALB/AAS - CANCEL AND CLONE A BILL - CONTINUED ;25-JAN-90

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

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

	;MAP TO DGCRCC1

	;STEP 1 - cancell bill

	;STEP 1.5 - entry to clone previously cancelled bill.  (must be cancell)

	;STEP 2 - build array of IBIDS call screen that asks ok

	;STEP 3 - pass stub entry to ar

	;STEP 4 - store stub data in MCCR then x-ref

	;STEP 5 - get remainder of data to move and store in MCCR then x-ref

	;STEP 6 - go to screens, come out to IBB1 or something like that

STEP4	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..." D INDEX^IBCCC2

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

END	K %,%DT,IB,IBA,IBNWBL,IBBT,IBIDS,I,J,VADM,X,X1,X2,X3,X4,Y

	G ^IBCCC2 ;go to step 5

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) I X]"" 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;.09^0^9;.11^0^11;.12^0^12;.17^0^17;.18^0^18;.19^0^19;.15^0^15;.16^0^16;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;

IBCCC1    ;ALB/AAS - CANCEL AND CLONE A BILL - CONTINUED ;25-JAN-90

 +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 DGCRCC1

 +5       ;

 +6       ;STEP 1 - cancell bill

 +7       ;STEP 1.5 - entry to clone previously cancelled bill.  (must be cancell)

 +8       ;STEP 2 - build array of IBIDS call screen that asks ok

 +9       ;STEP 3 - pass stub entry to ar

 +10      ;STEP 4 - store stub data in MCCR then x-ref

 +11      ;STEP 5 - get remainder of data to move and store in MCCR then x-ref

 +12      ;STEP 6 - go to screens, come out to IBB1 or something like that

 +13      ;

STEP4      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)

 +1        SET IBIFN=PRCASV("ARREC")

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

               IF $DATA(IBDR(I))

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

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

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

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

           DO INDEX^IBCCC2

 +3        SET IBYN=1

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

END        KILL %,%DT,IB,IBA,IBNWBL,IBBT,IBIDS,I,J,VADM,X,X1,X2,X3,X4,Y

 +1       ;

 +2       ;go to step 5

           GOTO ^IBCCC2

 +3       ;

 +4       ;

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)

                   IF X]""

                       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;.09^0^9;.11^0^11;.12^0^12;.17^0^17;.18^0^18;.19^0^19;.15^0^15;.16^0^16;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;

IBCCC1.m