Routine: IBECPTZ

IBECPTZ	;ALB/ARH - CPT TRANSFER UTILITY, KILLS FROM 350.41,LIST ERRORS; 10/22/91

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

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

	;external entry point

CLEAN	;removes all entries from file 350.41 - to be used during a

	;preinit in which new updates (ie 350.41) are being released

N X

	S X=$P($G(^IBE(350.41,0)),"^",1,2) I X'="" K ^IBE(350.41) S ^IBE(350.41,0)=X

	;external entry point

PURGE	;deletes entries in 350.41 that have been transfered to 350.4

	W !!,?20,"Delete Transferred Codes from the Temporary BASC File",!!

	W !!!,"This option will only delete BASC codes in the temporary file that have"

	W !,"already been transferred to the permanent BASC file."

	S DIR(0)="Y",DIR("A")="Do you want to delete transferred codes now" D ^DIR K DIR

	G:$D(DIRUT)!('Y) KEND

	W !!,"Processing, this could take some time.   Please wait...",!!

	S (IBCNT,IBX)=0

	F IBI=1:1 S IBX=$O(^IBE(350.41,IBX)) Q:'IBX  S IBLN=$G(^IBE(350.41,IBX,0)) I $P(IBLN,"^",7) S DIK="^IBE(350.41,",DA=IBX D ^DIK K DIK S IBCNT=IBCNT+1

	W !!,"Done.  ",IBCNT," entries deleted from 350.41."

KEND	;

	K IBX,IBI,IBCNT,DA,IBLN,DIC,DUOUT,DTOUT,DIRUT,DIROUT,Y,X

	;external entry point

LIST	;lists all update errors in 350.41,  ie. status=0 only

	D HOME^%ZIS

	W @IOF,!,?15,"Billing Ambulatory Surgery Code Update Error List",!!!

	S DIC="^IBE(350.41,",FR="0,?,?",TO="0,?,?"

	S BY="@.07,.01,.02",FLDS="[IB CPT UPDATE ERROR]" D EN1^DIP

	K DIC,FR,TO,BY,FLDS,X,Y

IBECPTZ   ;ALB/ARH - CPT TRANSFER UTILITY, KILLS FROM 350.41,LIST ERRORS; 10/22/91

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

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

 +3       ;

 +4       ;external entry point

CLEAN     ;removes all entries from file 350.41 - to be used during a

 +1       ;preinit in which new updates (ie 350.41) are being released

 +2        NEW X

 +3        SET X=$PIECE($GET(^IBE(350.41,0)),"^",1,2)

           IF X'=""

               KILL ^IBE(350.41)

               SET ^IBE(350.41,0)=X

 +4        QUIT

 +5       ;

 +6       ;external entry point

PURGE     ;deletes entries in 350.41 that have been transfered to 350.4

 +1        WRITE !!,?20,"Delete Transferred Codes from the Temporary BASC File",!!

 +2        WRITE !!!,"This option will only delete BASC codes in the temporary file that have"

 +3        WRITE !,"already been transferred to the permanent BASC file."

 +4        SET DIR(0)="Y"

           SET DIR("A")="Do you want to delete transferred codes now"

           DO ^DIR

           KILL DIR

 +5        IF $DATA(DIRUT)!('Y)

               GOTO KEND

 +6        WRITE !!,"Processing, this could take some time.   Please wait...",!!

 +7       ;

 +8        SET (IBCNT,IBX)=0

 +9        FOR IBI=1:1

               SET IBX=$ORDER(^IBE(350.41,IBX))

               IF 'IBX

                   QUIT

               SET IBLN=$GET(^IBE(350.41,IBX,0))

               IF $PIECE(IBLN,"^",7)

                   SET DIK="^IBE(350.41,"

                   SET DA=IBX

                   DO ^DIK

                   KILL DIK

                   SET IBCNT=IBCNT+1

 +10       WRITE !!,"Done.  ",IBCNT," entries deleted from 350.41."

KEND      ;

 +1        KILL IBX,IBI,IBCNT,DA,IBLN,DIC,DUOUT,DTOUT,DIRUT,DIROUT,Y,X

 +2        QUIT

 +3       ;

 +4       ;external entry point

LIST      ;lists all update errors in 350.41,  ie. status=0 only

 +1        DO HOME^%ZIS

 +2        WRITE @IOF,!,?15,"Billing Ambulatory Surgery Code Update Error List",!!!

 +3        SET DIC="^IBE(350.41,"

           SET FR="0,?,?"

           SET TO="0,?,?"

 +4        SET BY="@.07,.01,.02"

           SET FLDS="[IB CPT UPDATE ERROR]"

           DO EN1^DIP

 +5        KILL DIC,FR,TO,BY,FLDS,X,Y

 +6        QUIT

IBECPTZ.m