IBCROIP ;ALB/ARH - RATES: REPORTS CHARGE ITEM: PROCEDURES ; 12/01/04
;;2.0;INTEGRATED BILLING;**287**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN ; OPTION ENTRY POINT: Charge Item report for Procedures Only - get parameters then run the report
N RATES,DIVS,CPTS,IBBDT,IBEDT,IBCS,IBCS0,IBSUB,IBQUIT,IBSCRPT
;
W !!,"Procedure Charge Report: Print charges for selected CPT procedures.",!
;
D SELRATE(.RATES) Q:'RATES ; get billing rates to include
D SELDIVS(.DIVS) Q:DIVS<0 ; get divisions
D SELCPTS(.CPTS) Q:'CPTS ; get list of CPT codes
;
S IBBDT=$$GETDT^IBCRU1(DT,"Charges effective beginning on") Q:IBBDT'?7N
S IBEDT=$$GETDT^IBCRU1(DT,"Charges effective ending on") Q:IBEDT'?7N
;
S IBQUIT=0 D DEV I IBQUIT G EXIT
;
RPT ; find, save, and print Charge Item report - entry for tasked jobs DBIA #2815
;
K ^TMP($J,"IBCROI") S IBSCRPT="IBCROI"
;
S IBCS=0 F S IBCS=$O(^IBE(363.1,IBCS)) Q:'IBCS D
. S IBCS0=$G(^IBE(363.1,IBCS,0))
. ;
. I '$D(RATES(+$P(IBCS0,U,2))) Q
. I DIVS'=1,+$P(IBCS0,U,7) I '$$CHKDV(+$P(IBCS0,U,7),.DIVS) Q
. ;
. S IBSUB=+$P(IBCS0,U,4)_U_$P(IBCS0,U,1) ; sort by CT and charge set name
. ;
. D GET
;
D PRINT^IBCROI
;
EXIT D EXIT^IBCROI
Q
;
;
GET ; get charge items for selected procedures
N IBCPTS,IBC1,IBC2,IBCFIRST,IBCLAST,IBCNEXT,IBCIFN
;
S IBCPTS="" F S IBCPTS=$O(CPTS(IBCPTS)) Q:IBCPTS="" D
. I IBCPTS'?5UN1"-"5UN Q
. S IBC1=$P(IBCPTS,"-",1),IBCFIRST=$O(^ICPT("B",IBC1),-1)
. S IBC2=$P(IBCPTS,"-",2),IBCLAST=$O(^ICPT("B",IBC2))
. ;
. S IBCNEXT=IBCFIRST F S IBCNEXT=$O(^ICPT("B",IBCNEXT)) Q:(IBCNEXT="")!(IBCNEXT=IBCLAST) D
.. S IBCIFN=$O(^ICPT("B",IBCNEXT,0))
.. ;
.. D SRCHITM^IBCROI1(IBCS,IBSUB,3,IBBDT,IBEDT,IBCIFN)
. ;
. D TMPHDR^IBCROI1(IBSCRPT,IBSUB,0,"Procedure Charges","1^1",IBBDT,IBEDT)
Q
;
CHKDV(RG,DIVS) ; check if Region contains a selected division (where DIVS is array of divisions)
N IBDV,IBSEL S IBSEL=0
I +$O(^IBE(363.31,+$G(RG),11,"B",0)) S IBDV=0 F S IBDV=$O(DIVS(IBDV)) Q:'IBDV D Q:+IBSEL
. I +$O(^IBE(363.31,RG,11,"B",IBDV,0)) S IBSEL=1
Q IBSEL
;
SELRATE(RATES) ; get rates to review, RATES(ptr to 363.3)=Billing Rate Name returned, or RATES=0 if none selected
N IBN,IBX,IBY,IBCNT,IBDFLT,IBARR,DIR,DIRUT,DTOUT,DUOUT,X,Y K RATES S RATES=0
;
S IBN="" F S IBN=$O(^IBE(363.3,"B",IBN)) Q:IBN="" D
. S IBX=0 F S IBX=$O(^IBE(363.3,"B",IBN,IBX)) Q:'IBX D
.. S IBY=$G(^IBE(363.3,IBX,0)) I $P(IBY,U,4)'=2 Q
.. S IBCNT=$G(IBCNT)+1
.. ;
.. I $E(IBY,1,3)="RC " S IBDFLT=$G(IBDFLT)_IBCNT_","
.. S IBARR(IBCNT)=IBX_U_IBN,IBARR=IBCNT
;
W !,"Select Charge Billing Rates:"
S IBCNT=0 F S IBCNT=$O(IBARR(IBCNT)) Q:'IBCNT W !,?10,IBCNT," - ",$P(IBARR(IBCNT),U,2)
;
S DIR(0)="LO^1:"_IBARR_":0",DIR("A")="Charge Rates",DIR("B")=IBDFLT D ^DIR Q:$$QUIT
;
F IBX=1:1:20 S IBCNT=$P(Y,",",IBX) Q:'IBCNT S IBY=IBARR(IBCNT),RATES=$G(RATES)+1,RATES(+IBY)=$P(IBY,U,2)
;
Q
;
SELDIVS(VAUTD) ; Issue prompt for Division (ALL: VAUTD=1, SELECT: VAUTD=0, VAUTD(DV ptr)=DV Name, ELSE: VAUTD=-1)
N Y D PSDR^IBODIV I Y<0 K VAUTD S VAUTD=-1
Q
;
SELCPTS(CPTS) ; Select CPT Codes, returned in array ranges separated by dash, external form, or CPTS=0 if none selected
; will only allow ranges with matching first character because of length
N IBI,IBCOD,IBCOD1,IBCOD2,DIC,DIR,DIRUT,DTOUT,DUOUT,X,Y K CPTS S CPTS=0
;
S DIR("?")="Enter a CPT/HCPCS code or range of codes separated by a dash"
S DIR("A")="Select CPT/HPCS Codes",DIR(0)="FO^^"
;
F IBI=1:1 D ^DIR Q:$$QUIT D
. S IBCOD=$$UP^XLFSTR(Y),IBCOD1=$P(IBCOD,"-",1),IBCOD2=$P(IBCOD,"-",2)
. ;
. I IBCOD["-" S IBCOD1=$$LJ^XLFSTR(IBCOD1,5,0),IBCOD2=$$LJ^XLFSTR(IBCOD2,5,0)
. I IBCOD'["-" S IBCOD1=$P($$CPTDIC(IBCOD),U,2),IBCOD2=IBCOD1 I IBCOD1="" W ?36,"??" Q
. ;
. I (IBCOD1'?5UN)!(IBCOD2'?5UN) W ?36,"??" Q
. I IBCOD1'=IBCOD2,IBCOD2']IBCOD1 W ?36,IBCOD1,"-",IBCOD2," Invalid Range" Q
. I $E(IBCOD1,1)'=$E(IBCOD2,1) W ?36,"Range too large, first character must match" Q
. ;
. S IBCOD=IBCOD1_"-"_IBCOD2 S CPTS=$G(CPTS)+1,CPTS(IBCOD)=""
;
Q
;
CPTDIC(CODE) ; inquiry on CPT code, returns null or 'internal^external'
N IBX,DIC,DUOUT,DTOUT,I,X,Y S IBX="" I $G(CODE)'="" S X=CODE,DIC="^ICPT(",DIC(0)="EM" D ^DIC I Y>1 S IBX=Y
Q IBX
;
;
QUIT() N IBX S IBX=0 I ($G(Y)="")!($D(DIRUT))!($D(DUOUT))!($D(DTOUT)) S IBX=1
Q IBX
;
DEV ; get device
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^IBCROIP",ZTDESC="Charge Procedure Report",ZTSAVE("IB*")="",ZTSAVE("RATES(")="",ZTSAVE("CPTS(")="",ZTSAVE("DIVS(")="",ZTSAVE("DIVS")="" D ^%ZTLOAD K IO("Q") S IBQUIT=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCROIP 4742 printed Dec 13, 2024@02:19:52 Page 2
IBCROIP ;ALB/ARH - RATES: REPORTS CHARGE ITEM: PROCEDURES ; 12/01/04
+1 ;;2.0;INTEGRATED BILLING;**287**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
EN ; OPTION ENTRY POINT: Charge Item report for Procedures Only - get parameters then run the report
+1 NEW RATES,DIVS,CPTS,IBBDT,IBEDT,IBCS,IBCS0,IBSUB,IBQUIT,IBSCRPT
+2 ;
+3 WRITE !!,"Procedure Charge Report: Print charges for selected CPT procedures.",!
+4 ;
+5 ; get billing rates to include
DO SELRATE(.RATES)
if 'RATES
QUIT
+6 ; get divisions
DO SELDIVS(.DIVS)
if DIVS<0
QUIT
+7 ; get list of CPT codes
DO SELCPTS(.CPTS)
if 'CPTS
QUIT
+8 ;
+9 SET IBBDT=$$GETDT^IBCRU1(DT,"Charges effective beginning on")
if IBBDT'?7N
QUIT
+10 SET IBEDT=$$GETDT^IBCRU1(DT,"Charges effective ending on")
if IBEDT'?7N
QUIT
+11 ;
+12 SET IBQUIT=0
DO DEV
IF IBQUIT
GOTO EXIT
+13 ;
RPT ; find, save, and print Charge Item report - entry for tasked jobs DBIA #2815
+1 ;
+2 KILL ^TMP($JOB,"IBCROI")
SET IBSCRPT="IBCROI"
+3 ;
+4 SET IBCS=0
FOR
SET IBCS=$ORDER(^IBE(363.1,IBCS))
if 'IBCS
QUIT
Begin DoDot:1
+5 SET IBCS0=$GET(^IBE(363.1,IBCS,0))
+6 ;
+7 IF '$DATA(RATES(+$PIECE(IBCS0,U,2)))
QUIT
+8 IF DIVS'=1
IF +$PIECE(IBCS0,U,7)
IF '$$CHKDV(+$PIECE(IBCS0,U,7),.DIVS)
QUIT
+9 ;
+10 ; sort by CT and charge set name
SET IBSUB=+$PIECE(IBCS0,U,4)_U_$PIECE(IBCS0,U,1)
+11 ;
+12 DO GET
End DoDot:1
+13 ;
+14 DO PRINT^IBCROI
+15 ;
EXIT DO EXIT^IBCROI
+1 QUIT
+2 ;
+3 ;
GET ; get charge items for selected procedures
+1 NEW IBCPTS,IBC1,IBC2,IBCFIRST,IBCLAST,IBCNEXT,IBCIFN
+2 ;
+3 SET IBCPTS=""
FOR
SET IBCPTS=$ORDER(CPTS(IBCPTS))
if IBCPTS=""
QUIT
Begin DoDot:1
+4 IF IBCPTS'?5UN1"-"5UN
QUIT
+5 SET IBC1=$PIECE(IBCPTS,"-",1)
SET IBCFIRST=$ORDER(^ICPT("B",IBC1),-1)
+6 SET IBC2=$PIECE(IBCPTS,"-",2)
SET IBCLAST=$ORDER(^ICPT("B",IBC2))
+7 ;
+8 SET IBCNEXT=IBCFIRST
FOR
SET IBCNEXT=$ORDER(^ICPT("B",IBCNEXT))
if (IBCNEXT="")!(IBCNEXT=IBCLAST)
QUIT
Begin DoDot:2
+9 SET IBCIFN=$ORDER(^ICPT("B",IBCNEXT,0))
+10 ;
+11 DO SRCHITM^IBCROI1(IBCS,IBSUB,3,IBBDT,IBEDT,IBCIFN)
End DoDot:2
+12 ;
+13 DO TMPHDR^IBCROI1(IBSCRPT,IBSUB,0,"Procedure Charges","1^1",IBBDT,IBEDT)
End DoDot:1
+14 QUIT
+15 ;
CHKDV(RG,DIVS) ; check if Region contains a selected division (where DIVS is array of divisions)
+1 NEW IBDV,IBSEL
SET IBSEL=0
+2 IF +$ORDER(^IBE(363.31,+$GET(RG),11,"B",0))
SET IBDV=0
FOR
SET IBDV=$ORDER(DIVS(IBDV))
if 'IBDV
QUIT
Begin DoDot:1
+3 IF +$ORDER(^IBE(363.31,RG,11,"B",IBDV,0))
SET IBSEL=1
End DoDot:1
if +IBSEL
QUIT
+4 QUIT IBSEL
+5 ;
SELRATE(RATES) ; get rates to review, RATES(ptr to 363.3)=Billing Rate Name returned, or RATES=0 if none selected
+1 NEW IBN,IBX,IBY,IBCNT,IBDFLT,IBARR,DIR,DIRUT,DTOUT,DUOUT,X,Y
KILL RATES
SET RATES=0
+2 ;
+3 SET IBN=""
FOR
SET IBN=$ORDER(^IBE(363.3,"B",IBN))
if IBN=""
QUIT
Begin DoDot:1
+4 SET IBX=0
FOR
SET IBX=$ORDER(^IBE(363.3,"B",IBN,IBX))
if 'IBX
QUIT
Begin DoDot:2
+5 SET IBY=$GET(^IBE(363.3,IBX,0))
IF $PIECE(IBY,U,4)'=2
QUIT
+6 SET IBCNT=$GET(IBCNT)+1
+7 ;
+8 IF $EXTRACT(IBY,1,3)="RC "
SET IBDFLT=$GET(IBDFLT)_IBCNT_","
+9 SET IBARR(IBCNT)=IBX_U_IBN
SET IBARR=IBCNT
End DoDot:2
End DoDot:1
+10 ;
+11 WRITE !,"Select Charge Billing Rates:"
+12 SET IBCNT=0
FOR
SET IBCNT=$ORDER(IBARR(IBCNT))
if 'IBCNT
QUIT
WRITE !,?10,IBCNT," - ",$PIECE(IBARR(IBCNT),U,2)
+13 ;
+14 SET DIR(0)="LO^1:"_IBARR_":0"
SET DIR("A")="Charge Rates"
SET DIR("B")=IBDFLT
DO ^DIR
if $$QUIT
QUIT
+15 ;
+16 FOR IBX=1:1:20
SET IBCNT=$PIECE(Y,",",IBX)
if 'IBCNT
QUIT
SET IBY=IBARR(IBCNT)
SET RATES=$GET(RATES)+1
SET RATES(+IBY)=$PIECE(IBY,U,2)
+17 ;
+18 QUIT
+19 ;
SELDIVS(VAUTD) ; Issue prompt for Division (ALL: VAUTD=1, SELECT: VAUTD=0, VAUTD(DV ptr)=DV Name, ELSE: VAUTD=-1)
+1 NEW Y
DO PSDR^IBODIV
IF Y<0
KILL VAUTD
SET VAUTD=-1
+2 QUIT
+3 ;
SELCPTS(CPTS) ; Select CPT Codes, returned in array ranges separated by dash, external form, or CPTS=0 if none selected
+1 ; will only allow ranges with matching first character because of length
+2 NEW IBI,IBCOD,IBCOD1,IBCOD2,DIC,DIR,DIRUT,DTOUT,DUOUT,X,Y
KILL CPTS
SET CPTS=0
+3 ;
+4 SET DIR("?")="Enter a CPT/HCPCS code or range of codes separated by a dash"
+5 SET DIR("A")="Select CPT/HPCS Codes"
SET DIR(0)="FO^^"
+6 ;
+7 FOR IBI=1:1
DO ^DIR
if $$QUIT
QUIT
Begin DoDot:1
+8 SET IBCOD=$$UP^XLFSTR(Y)
SET IBCOD1=$PIECE(IBCOD,"-",1)
SET IBCOD2=$PIECE(IBCOD,"-",2)
+9 ;
+10 IF IBCOD["-"
SET IBCOD1=$$LJ^XLFSTR(IBCOD1,5,0)
SET IBCOD2=$$LJ^XLFSTR(IBCOD2,5,0)
+11 IF IBCOD'["-"
SET IBCOD1=$PIECE($$CPTDIC(IBCOD),U,2)
SET IBCOD2=IBCOD1
IF IBCOD1=""
WRITE ?36,"??"
QUIT
+12 ;
+13 IF (IBCOD1'?5UN)!(IBCOD2'?5UN)
WRITE ?36,"??"
QUIT
+14 IF IBCOD1'=IBCOD2
IF IBCOD2']IBCOD1
WRITE ?36,IBCOD1,"-",IBCOD2," Invalid Range"
QUIT
+15 IF $EXTRACT(IBCOD1,1)'=$EXTRACT(IBCOD2,1)
WRITE ?36,"Range too large, first character must match"
QUIT
+16 ;
+17 SET IBCOD=IBCOD1_"-"_IBCOD2
SET CPTS=$GET(CPTS)+1
SET CPTS(IBCOD)=""
End DoDot:1
+18 ;
+19 QUIT
+20 ;
CPTDIC(CODE) ; inquiry on CPT code, returns null or 'internal^external'
+1 NEW IBX,DIC,DUOUT,DTOUT,I,X,Y
SET IBX=""
IF $GET(CODE)'=""
SET X=CODE
SET DIC="^ICPT("
SET DIC(0)="EM"
DO ^DIC
IF Y>1
SET IBX=Y
+2 QUIT IBX
+3 ;
+4 ;
QUIT() NEW IBX
SET IBX=0
IF ($GET(Y)="")!($DATA(DIRUT))!($DATA(DUOUT))!($DATA(DTOUT))
SET IBX=1
+1 QUIT IBX
+2 ;
DEV ; get device
+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^IBCROIP"
SET ZTDESC="Charge Procedure Report"
SET ZTSAVE("IB*")=""
SET ZTSAVE("RATES(")=""
SET ZTSAVE("CPTS(")=""
SET ZTSAVE("DIVS(")=""
SET ZTSAVE("DIVS")=""
DO ^%ZTLOAD
KILL IO("Q")
SET IBQUIT=1
+3 QUIT
