Routine: IBCREC

IBCREC ;ALB/ARH - RATES: CM INACTIVATE CPT CHARGE OPTION ; 22-MAY-1996

 ;;2.0;INTEGRATED BILLING;**52,131**;21-MAR-94

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

ENTER ; OPTION ENTRY POINT:  inactivate all CPT procedures Charge Items that are currently inactive in the CPT file

 W @IOF W !,?8,"**** INACTIVATE CHARGES FOR ALL CURRENTLY INACTIVE CPTS ****"

 W !!,?5,"For all Charge Sets based on CPT procedures, this option will add an",!,?5,"Inactive Date to each Charge Item that is a currently Inactive CPT code.",!!

 N DIR,DTOUT,DUOUT,DIRUT,X,Y,IBQUIT K ^TMP($J,"IBCREC")

 S DIR(0)="SO^1:Print List of Active Charges for Inactive CPT's;2:Inactivate Charges for Inactive CPT's"

 D ^DIR K DIR I +Y<1!$D(DIRUT) Q

 I +Y=1 D DEV Q:$G(IBQUIT)  G RPT

 W !!!,"All charges for currently Inactive CPT codes will become inactive",!,"on the CPT Inactive Date.",!

 S DIR(0)="YO",DIR("A")="Is this correct, do you want to continue" D ^DIR K DIR I Y'=1 W !,"None inactivated",! Q

 I Y=1 W !,"Beginning Inactivations" W !,$$INACTCPT(0)," charges inactivated"

INACTCPT(SAVE) ; inactivate charges for all Inactive CPT codes, all sets checked

 ; if an active charge for an Inactive CPT, the CPT's inactive date is added as the charges Inactive Date

 ; if a CPT is inactive before the charges Effective date, that Effective date is added as the Inactive Date

 ;    Input:   SAVE - if true, charge items that would be deleted are entered into TMP array for print instead

 ;    Output:  returns the count of the charge items inactivated

 N IBCS,IBBI,IBXRF,IBSUB2,IBITM,IBEFDT,IBCIFN,IBCNT,IBINDTCI,IBINDATE,IBX,INDT S IBCNT=0

 S IBCS=0 F  S IBCS=$O(^IBE(363.1,IBCS)) Q:'IBCS  D

. ;

 . S IBBI=$$CSBI^IBCRU3(IBCS) I +IBBI'=2 Q

 . S IBXRF="AIVDTS"_+IBCS I '$D(ZTQUEUED),'$D(XPDNM) W "."

 . I +$G(SAVE) S IBSUB2=$$TMPHDR(IBCS) Q:IBSUB2=""

. ;

 . S IBITM=0 F  S IBITM=$O(^IBA(363.2,IBXRF,IBITM)) Q:'IBITM  D

 .. ;

 .. S IBX=$$CPT^ICPTCOD(IBITM,DT) I +$P(IBX,U,7) Q

 .. S INDT=$P(IBX,U,6) I 'INDT Q

 .. ;

 .. S IBEFDT=-9999999 F  S IBEFDT=$O(^IBA(363.2,IBXRF,IBITM,IBEFDT)) Q:'IBEFDT  D

 ... S IBCIFN=0 F  S IBCIFN=$O(^IBA(363.2,IBXRF,IBITM,IBEFDT,IBCIFN)) Q:'IBCIFN  D

 .... ;

 .... S IBINDTCI=$$INACTCI^IBCRU4(IBCIFN) I +IBINDTCI,IBINDTCI<INDT Q

 .... ;

 .... S IBINDATE=INDT I -IBEFDT>IBINDATE S IBINDATE=-IBEFDT

 .... I IBINDATE=$P($G(^IBA(363.2,IBCIFN,0)),U,4) Q

 .... ;

 .... S IBCNT=IBCNT+1

 .... I +$G(SAVE) D TMPLN^IBCROI1(IBCIFN,"IBCREC",IBSUB2,1) Q

 .... D EDITCI^IBCREF(IBCIFN,"","","",IBINDATE)

 Q IBCNT

DATE(X) ;

 Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)

TMPHDR(CS) ; set up array header for printed report

 N IBHDR,IBSUB2 S IBSUB2="BILLING RATE",IBHDR="Charges for Inactive CPT's"

 D TMPHDR^IBCROI1("IBCREC",IBSUB2,0,IBHDR,"1^1")

 Q IBSUB2

DEV ; get device for printed report

 S IBQUIT=0 S %ZIS="QM",%ZIS("A")="OUTPUT DEVICE: " D ^%ZIS I POP S IBQUIT=1 Q

 I $D(IO("Q")) S ZTRTN="RPT^IBCREC",ZTDESC="Charges for Inactive CPT's" D ^%ZTLOAD K IO("Q") S IBQUIT=1

RPT ; print report - entry point for tasked jobs

 N IBSCRPT,IBCNT S IBSCRPT="IBCREC" K ^TMP($J,"IBCREC")

 S IBCNT=$$INACTCPT(1)

 I $D(^TMP($J,"IBCREC")) S $P(^TMP($J,"IBCREC"),U,4)=IBCNT_" Charges for Inactive CPT's"

 G RPT^IBCROI

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCREC   3330     printed  Mar 13, 2025@21:23:57                                                                                                                                                                                                      Page 2

IBCREC    ;ALB/ARH - RATES: CM INACTIVATE CPT CHARGE OPTION ; 22-MAY-1996

 +1       ;;2.0;INTEGRATED BILLING;**52,131**;21-MAR-94

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

 +3       ;

ENTER     ; OPTION ENTRY POINT:  inactivate all CPT procedures Charge Items that are currently inactive in the CPT file

 +1       ;

 +2        WRITE @IOF

           WRITE !,?8,"**** INACTIVATE CHARGES FOR ALL CURRENTLY INACTIVE CPTS ****"

 +3        WRITE !!,?5,"For all Charge Sets based on CPT procedures, this option will add an",!,?5,"Inactive Date to each Charge Item that is a currently Inactive CPT code.",!!

 +4       ;

 +5        NEW DIR,DTOUT,DUOUT,DIRUT,X,Y,IBQUIT

           KILL ^TMP($JOB,"IBCREC")

 +6       ;

 +7        SET DIR(0)="SO^1:Print List of Active Charges for Inactive CPT's;2:Inactivate Charges for Inactive CPT's"

 +8        DO ^DIR

           KILL DIR

           IF +Y<1!$DATA(DIRUT)

               QUIT

 +9        IF +Y=1

               DO DEV

               if $GET(IBQUIT)

                   QUIT

               GOTO RPT

 +10      ;

 +11       WRITE !!!,"All charges for currently Inactive CPT codes will become inactive",!,"on the CPT Inactive Date.",!

 +12      ;

 +13       SET DIR(0)="YO"

           SET DIR("A")="Is this correct, do you want to continue"

           DO ^DIR

           KILL DIR

           IF Y'=1

               WRITE !,"None inactivated",!

               QUIT

 +14      ;

 +15       IF Y=1

               WRITE !,"Beginning Inactivations"

               WRITE !,$$INACTCPT(0)," charges inactivated"

 +16       QUIT

 +17      ;

INACTCPT(SAVE) ; inactivate charges for all Inactive CPT codes, all sets checked

 +1       ; if an active charge for an Inactive CPT, the CPT's inactive date is added as the charges Inactive Date

 +2       ; if a CPT is inactive before the charges Effective date, that Effective date is added as the Inactive Date

 +3       ;    Input:   SAVE - if true, charge items that would be deleted are entered into TMP array for print instead

 +4       ;    Output:  returns the count of the charge items inactivated

 +5       ;

 +6        NEW IBCS,IBBI,IBXRF,IBSUB2,IBITM,IBEFDT,IBCIFN,IBCNT,IBINDTCI,IBINDATE,IBX,INDT

           SET IBCNT=0

 +7       ;

 +8        SET IBCS=0

FOR

               SET IBCS=$ORDER(^IBE(363.1,IBCS))

               if 'IBCS

                   QUIT

               Begin DoDot:1

 +9       ;

 +10               SET IBBI=$$CSBI^IBCRU3(IBCS)

                   IF +IBBI'=2

                       QUIT

 +11               SET IBXRF="AIVDTS"_+IBCS

                   IF '$DATA(ZTQUEUED)

                       IF '$DATA(XPDNM)

                           WRITE "."

 +12               IF +$GET(SAVE)

                       SET IBSUB2=$$TMPHDR(IBCS)

                       if IBSUB2=""

                           QUIT

 +13      ;

 +14               SET IBITM=0

FOR

                       SET IBITM=$ORDER(^IBA(363.2,IBXRF,IBITM))

                       if 'IBITM

                           QUIT

                       Begin DoDot:2

 +15      ;

 +16                       SET IBX=$$CPT^ICPTCOD(IBITM,DT)

                           IF +$PIECE(IBX,U,7)

                               QUIT

 +17                       SET INDT=$PIECE(IBX,U,6)

                           IF 'INDT

                               QUIT

 +18      ;

 +19                       SET IBEFDT=-9999999

FOR

                               SET IBEFDT=$ORDER(^IBA(363.2,IBXRF,IBITM,IBEFDT))

                               if 'IBEFDT

                                   QUIT

                               Begin DoDot:3

 +20                               SET IBCIFN=0

FOR

                                       SET IBCIFN=$ORDER(^IBA(363.2,IBXRF,IBITM,IBEFDT,IBCIFN))

                                       if 'IBCIFN

                                           QUIT

                                       Begin DoDot:4

 +21      ;

 +22                                       SET IBINDTCI=$$INACTCI^IBCRU4(IBCIFN)

                                           IF +IBINDTCI

                                               IF IBINDTCI<INDT

                                                   QUIT

 +23      ;

 +24                                       SET IBINDATE=INDT

                                           IF -IBEFDT>IBINDATE

                                               SET IBINDATE=-IBEFDT

 +25                                       IF IBINDATE=$PIECE($GET(^IBA(363.2,IBCIFN,0)),U,4)

                                               QUIT

 +26      ;

 +27                                       SET IBCNT=IBCNT+1

 +28                                       IF +$GET(SAVE)

                                               DO TMPLN^IBCROI1(IBCIFN,"IBCREC",IBSUB2,1)

                                               QUIT

 +29                                       DO EDITCI^IBCREF(IBCIFN,"","","",IBINDATE)

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +30       QUIT IBCNT

 +31      ;

DATE(X)   ;

 +1        QUIT $EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)

 +2       ;

TMPHDR(CS) ; set up array header for printed report

 +1        NEW IBHDR,IBSUB2

           SET IBSUB2="BILLING RATE"

           SET IBHDR="Charges for Inactive CPT's"

 +2        DO TMPHDR^IBCROI1("IBCREC",IBSUB2,0,IBHDR,"1^1")

 +3        QUIT IBSUB2

 +4       ;

DEV       ; get device for printed report

 +1        SET IBQUIT=0

           SET %ZIS="QM"

           SET %ZIS("A")="OUTPUT DEVICE: "

           DO ^%ZIS

           IF POP

               SET IBQUIT=1

               QUIT

 +2        IF $DATA(IO("Q"))

               SET ZTRTN="RPT^IBCREC"

               SET ZTDESC="Charges for Inactive CPT's"

               DO ^%ZTLOAD

               KILL IO("Q")

               SET IBQUIT=1

 +3        QUIT

 +4       ;

RPT       ; print report - entry point for tasked jobs

 +1        NEW IBSCRPT,IBCNT

           SET IBSCRPT="IBCREC"

           KILL ^TMP($JOB,"IBCREC")

 +2        SET IBCNT=$$INACTCPT(1)

 +3        IF $DATA(^TMP($JOB,"IBCREC"))

               SET $PIECE(^TMP($JOB,"IBCREC"),U,4)=IBCNT_" Charges for Inactive CPT's"

 +4        GOTO RPT^IBCROI

 +5        QUIT

IBCREC.m