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"
Q
;
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
Q
;
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCREC 3330 printed Apr 09, 2024@21:17:40 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
