IBCROE ;OAK/ELZ - CHARGE MASTER TO EXCEL OUTPUT ;28-NOV-2005
;;2.0;INTEGRATED BILLING;**308**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; This routine will produce output from Charge Master for the local site in a format that can be imported
; into excel.
;
; load an Inpatient and a Non-Provider based site for same zip code first
;
;
EN ; main option entry point
N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,IBRCVER,IBZIP,POP,%ZIS,IBVERS,ZTRTN,ZTDESC,ZTSAVE,ZTSK
;
;find zip code for extraction
S DIR(0)="F^3:3^K:X'?3N X",DIR("A")="Enter a 3 digit zip identifier"
S DIR("?")="Enter the first 3 digits of a zip code for which you want to extract data." D ^DIR Q:$D(DIRUT)
S IBZIP=Y
;
S IBVERS=$$SELVERS Q:'IBVERS
;
; find out where to write output
W !!,"Select where you would like the output. This will be very large and you",!,"should select either a Host File Server (HFS) printer or Current Terminal",!,"(screen capture) to save the output to a file."
S %ZIS="QM" D ^%ZIS Q:POP
I $D(IO("Q")) D Q
. S ZTRTN="DQ^IBCROE",ZTDESC="IB Reasonable Charges Extract"
. S (ZTSAVE("IBZIP"),ZTSAVE("IBVERS"))=""
. D ^%ZTLOAD D HOME^%ZIS K IO("Q") W !,"QUEUED TASK #",ZTSK
;
;
DQ ; tasked entry point
U IO D EXCEL(IBZIP,IBVERS)
;
;
D ^%ZISC
S:$D(ZTQUEUED) ZTREQ="@"
I '$D(ZTQUEUED) D HOME^%ZIS W !,"Done!"
;
;
Q
;
SELVERS() ; get version to extract from user
N DIR,DIRUT,DTOUT,DUOUT,X,Y,IB,IBV,IBVP,IBX,IBVL
; use primary site to list and remove prior to version 2.0 as choices
S IBVL=$$VERSITE^IBCRHBRV($P($$SITE^VASITE,"^",3)),IBV=""
F X=1:1 Q:'$P(IBVL,",",X) S:$P(IBVL,",",X)>1.9 IBV=IBV_$S($L($P(IBVL,",",X))>2:$P(IBVL,",",X),1:$P(IBVL,",",X)_".0")_"^"
S IBV=$E(IBV,1,$L(IBV)-1)
S IBX=0
W !!,"Select the version of Reasonable Charges to extract.",!
S DIR("?")="Enter a code from the list corresponding to the version of Reasonable Charges to upload. Must be version 2.0 or greater. There was no version 2.2 of Reasonable Charges."
S DIR(0)="SO^"
F IB=1:1:$L(IBV,U) S IBVP=$P(IBV,U,IB),DIR(0)=DIR(0)_+IBVP_":RC version "_IBVP_" eff "_$$FMTE^XLFDT($$VERSDT^IBCRHBRV(+IBVP),"2Z")_" inact "_$$FMTE^XLFDT($$VERSEDT^IBCRHBRV(+IBVP),"2Z")_";"
D ^DIR K DIR S:$L(Y)=1 Y=Y_".0" S IBX=+$S(IBV[Y:Y,1:0)
Q IBX
;
;
; call at EXEL with zip and version, will print to host file the calculated charges by type
EXCEL(ZIP,VERS) ;
N IB2,IB3,IBZ,COL,IBBI,IBBR,IBBR0,IBCHG,IBCI,IBCI0,IBCM,IBCNT,IBCPT,IBCS,IBCS0,IBCSNM,IBCT,IBDV,IBLNZ,IBMOD,IBMODI,IBNAME,IBPB,IBRG,IBRG0,Z
K ^TMP("IBCROE",$J)
S IBCNT=0
;
S IBCS=0 F S IBCS=$O(^IBE(363.1,IBCS)) Q:'IBCS D
. S IBCS0=$G(^IBE(363.1,IBCS,0))
. ;
. S IBCSNM=$P(IBCS0,U,1) Q:$E(IBCSNM,1,3)'="RC-"
. S IBBR=+$P(IBCS0,U,2),IBBR0=$G(^IBE(363.3,IBBR,0))
. S IBRG=+$P(IBCS0,U,7),IBRG0=$G(^IBE(363.31,IBRG,0)),IBDV=$P(IBRG0," ",2)
. ;
. I $P(IBRG0,U,2)'=ZIP Q
. ;
. S IBBI=$$EXPAND^IBCRU1(363.3,.04,$P(IBBR0,U,4))
. S IBCT=$S(IBBR0["FACILITY":"FACILITY",IBBR0["PHYSICIAN":"PHYSICIAN",1:$P(IBBR0,U,1))
. ;
. I IBBI["MISC",IBCSNM'["SNF" S COL=2,IBNAME="Partial Hospitalization"
. I IBBI["MISC",IBCSNM["SKILLED" S COL=1,IBNAME="Skilled Nursing"
. I IBBI="DRG",IBCSNM["ANC" S COL=1,IBNAME="Inpatient Anc" I IBCSNM["ICU" S COL=COL+1,IBNAME=IBNAME_" ICU"
. I IBBI="DRG",IBCSNM["R&B" S COL=3,IBNAME="Inpatient R&B" I IBCSNM["ICU" S COL=COL+1,IBNAME=IBNAME_" ICU"
. ;
. I IBBI="CPT",IBCSNM["INPT" S COL=1,IBNAME="Inpatient Facility" I IBCT="PHYSICIAN" S COL=COL+1,IBNAME="Inpatient Physician"
. I IBBI="CPT",IBCSNM["SNF" S COL=3,IBNAME="SNF Facility" I IBCT="PHYSICIAN" S COL=COL+1,IBNAME="SNF Physician"
. I IBBI="CPT",IBCSNM["OPT" S COL=5,IBNAME="Outpatient Facility" I IBCT="PHYSICIAN" S COL=COL+1,IBNAME="Outpatient Physician"
. I IBBI="CPT",IBCSNM["FS" S COL=7,IBNAME="Freestanding Physician"
. ;
. S IBPB=$P(IBRG0,U,3),IBPB=$S(IBPB=1:"VAMC Provider Based",IBPB=2:"Opt Provider Based",IBPB=3:"Non-Provider Based",1:"Provider Based Unknown")
. ;
. S IBCM=$P(IBBR0,U,5),IBCM=$S(IBCM=4:"ml",IBCM=5:"mn+",IBCM=6:"hr+",1:"")
. ;
. S IB2(IBCS)=IBBI_U_COL_U_IBNAME_U_IBDV_U_IBPB_U_IBCM
. S $P(IB3(IBBI),U,COL)=IBNAME_" "_IBDV_" "_IBPB
. ;
. S IBCNT=IBCNT+1 I IBCNT#1000=0,'$D(ZTQUEUED) U IO(0) W "." U IO
;
ITEMS ;
S IBBI="" F S IBBI=$O(IB3(IBBI)) Q:IBBI="" S ^TMP("IBCROE",$J,IBBI)="Item^Modifier^"_IB3(IBBI)
;
S IBCI=0 F S IBCI=$O(^IBA(363.2,IBCI)) Q:'IBCI D
. S IBCI0=^IBA(363.2,IBCI,0),IBCSNM=$P($G(^IBE(363.1,+$P(IBCI0,U,2),0)),U,1) Q:IBCSNM=""
. S IBLNZ=$G(IB2($P(IBCI0,U,2))) I IBLNZ="" S IBZ("NOT DONE ",IBCSNM)="" Q
. S IBZ("DONE",IBCSNM)=""
. ;
. Q:$P(IBCI0,U,3)'=$$VERSDT^IBCRHBRV(VERS)
. ;
. S IBCHG=$P(IBCI0,U,5)_$P(IBLNZ,U,6)_$P(IBCI0,U,8)
. S IBMOD=$P(IBCI0,U,7) I IBMOD'="" S IBMOD=$P($$MOD^ICPTMOD(IBMOD,"I"),U,2)
. I IBMOD="" S IBMOD=0
. S IBCPT=$$EXPAND^IBCRU1(363.2,.01,$P(IBCI0,U,1))
. ;
. S IBBI=$P(IBLNZ,U,1)
. S COL=$P(IBLNZ,U,2)
. I $P($G(^TMP("IBCROE",$J,IBBI,IBCPT,IBMOD)),U,COL)'="" Q ;DUP
. S $P(^TMP("IBCROE",$J,IBBI,IBCPT,IBMOD),U,COL)=IBCHG
. ;
. S IBCNT=IBCNT+1 I IBCNT#1000=0,'$D(ZTQUEUED) U IO(0) W "." U IO
;
;
D WRT
K ^TMP("IBCROE",$J)
Q
WRT ;
S IBBI="" F S IBBI=$O(^TMP("IBCROE",$J,IBBI)) Q:IBBI="" D
. W !,^TMP("IBCROE",$J,IBBI)
. S IBCPT="" F S IBCPT=$O(^TMP("IBCROE",$J,IBBI,IBCPT)) Q:IBCPT="" D
.. S IBMOD="" F S IBMOD=$O(^TMP("IBCROE",$J,IBBI,IBCPT,IBMOD)) Q:IBMOD="" D
... S IBMODI=IBMOD I IBMOD=0 S IBMODI=""
... W !,IBCPT,U,IBMODI,U,^TMP("IBCROE",$J,IBBI,IBCPT,IBMOD)
... S IBCNT=IBCNT+1 I IBCNT#1000=0,'$D(ZTQUEUED),$E(IOST,1,2)'="C-" U IO(0) W "." U IO
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCROE 5698 printed Sep 23, 2025@19:56:04 Page 2
IBCROE ;OAK/ELZ - CHARGE MASTER TO EXCEL OUTPUT ;28-NOV-2005
+1 ;;2.0;INTEGRATED BILLING;**308**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; This routine will produce output from Charge Master for the local site in a format that can be imported
+5 ; into excel.
+6 ;
+7 ; load an Inpatient and a Non-Provider based site for same zip code first
+8 ;
+9 ;
EN ; main option entry point
+1 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,IBRCVER,IBZIP,POP,%ZIS,IBVERS,ZTRTN,ZTDESC,ZTSAVE,ZTSK
+2 ;
+3 ;find zip code for extraction
+4 SET DIR(0)="F^3:3^K:X'?3N X"
SET DIR("A")="Enter a 3 digit zip identifier"
+5 SET DIR("?")="Enter the first 3 digits of a zip code for which you want to extract data."
DO ^DIR
if $DATA(DIRUT)
QUIT
+6 SET IBZIP=Y
+7 ;
+8 SET IBVERS=$$SELVERS
if 'IBVERS
QUIT
+9 ;
+10 ; find out where to write output
+11 WRITE !!,"Select where you would like the output. This will be very large and you",!,"should select either a Host File Server (HFS) printer or Current Terminal",!,"(screen capture) to save the output to a file."
+12 SET %ZIS="QM"
DO ^%ZIS
if POP
QUIT
+13 IF $DATA(IO("Q"))
Begin DoDot:1
+14 SET ZTRTN="DQ^IBCROE"
SET ZTDESC="IB Reasonable Charges Extract"
+15 SET (ZTSAVE("IBZIP"),ZTSAVE("IBVERS"))=""
+16 DO ^%ZTLOAD
DO HOME^%ZIS
KILL IO("Q")
WRITE !,"QUEUED TASK #",ZTSK
End DoDot:1
QUIT
+17 ;
+18 ;
DQ ; tasked entry point
+1 USE IO
DO EXCEL(IBZIP,IBVERS)
+2 ;
+3 ;
+4 DO ^%ZISC
+5 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+6 IF '$DATA(ZTQUEUED)
DO HOME^%ZIS
WRITE !,"Done!"
+7 ;
+8 ;
+9 QUIT
+10 ;
SELVERS() ; get version to extract from user
+1 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y,IB,IBV,IBVP,IBX,IBVL
+2 ; use primary site to list and remove prior to version 2.0 as choices
+3 SET IBVL=$$VERSITE^IBCRHBRV($PIECE($$SITE^VASITE,"^",3))
SET IBV=""
+4 FOR X=1:1
if '$PIECE(IBVL,",",X)
QUIT
if $PIECE(IBVL,",",X)>1.9
SET IBV=IBV_$SELECT($LENGTH($PIECE(IBVL,",",X))>2:$PIECE(IBVL,",",X),1:$PIECE(IBVL,",",X)_".0")_"^"
+5 SET IBV=$EXTRACT(IBV,1,$LENGTH(IBV)-1)
+6 SET IBX=0
+7 WRITE !!,"Select the version of Reasonable Charges to extract.",!
+8 SET DIR("?")="Enter a code from the list corresponding to the version of Reasonable Charges to upload. Must be version 2.0 or greater. There was no version 2.2 of Reasonable Charges."
+9 SET DIR(0)="SO^"
+10 FOR IB=1:1:$LENGTH(IBV,U)
SET IBVP=$PIECE(IBV,U,IB)
SET DIR(0)=DIR(0)_+IBVP_":RC version "_IBVP_" eff "_$$FMTE^XLFDT($$VERSDT^IBCRHBRV(+IBVP),"2Z")_" inact "_$$FMTE^XLFDT($$VERSEDT^IBCRHBRV(+IBVP),"2Z")_";"
+11 DO ^DIR
KILL DIR
if $LENGTH(Y)=1
SET Y=Y_".0"
SET IBX=+$SELECT(IBV[Y:Y,1:0)
+12 QUIT IBX
+13 ;
+14 ;
+15 ; call at EXEL with zip and version, will print to host file the calculated charges by type
EXCEL(ZIP,VERS) ;
+1 NEW IB2,IB3,IBZ,COL,IBBI,IBBR,IBBR0,IBCHG,IBCI,IBCI0,IBCM,IBCNT,IBCPT,IBCS,IBCS0,IBCSNM,IBCT,IBDV,IBLNZ,IBMOD,IBMODI,IBNAME,IBPB,IBRG,IBRG0,Z
+2 KILL ^TMP("IBCROE",$JOB)
+3 SET IBCNT=0
+4 ;
+5 SET IBCS=0
FOR
SET IBCS=$ORDER(^IBE(363.1,IBCS))
if 'IBCS
QUIT
Begin DoDot:1
+6 SET IBCS0=$GET(^IBE(363.1,IBCS,0))
+7 ;
+8 SET IBCSNM=$PIECE(IBCS0,U,1)
if $EXTRACT(IBCSNM,1,3)'="RC-"
QUIT
+9 SET IBBR=+$PIECE(IBCS0,U,2)
SET IBBR0=$GET(^IBE(363.3,IBBR,0))
+10 SET IBRG=+$PIECE(IBCS0,U,7)
SET IBRG0=$GET(^IBE(363.31,IBRG,0))
SET IBDV=$PIECE(IBRG0," ",2)
+11 ;
+12 IF $PIECE(IBRG0,U,2)'=ZIP
QUIT
+13 ;
+14 SET IBBI=$$EXPAND^IBCRU1(363.3,.04,$PIECE(IBBR0,U,4))
+15 SET IBCT=$SELECT(IBBR0["FACILITY":"FACILITY",IBBR0["PHYSICIAN":"PHYSICIAN",1:$PIECE(IBBR0,U,1))
+16 ;
+17 IF IBBI["MISC"
IF IBCSNM'["SNF"
SET COL=2
SET IBNAME="Partial Hospitalization"
+18 IF IBBI["MISC"
IF IBCSNM["SKILLED"
SET COL=1
SET IBNAME="Skilled Nursing"
+19 IF IBBI="DRG"
IF IBCSNM["ANC"
SET COL=1
SET IBNAME="Inpatient Anc"
IF IBCSNM["ICU"
SET COL=COL+1
SET IBNAME=IBNAME_" ICU"
+20 IF IBBI="DRG"
IF IBCSNM["R&B"
SET COL=3
SET IBNAME="Inpatient R&B"
IF IBCSNM["ICU"
SET COL=COL+1
SET IBNAME=IBNAME_" ICU"
+21 ;
+22 IF IBBI="CPT"
IF IBCSNM["INPT"
SET COL=1
SET IBNAME="Inpatient Facility"
IF IBCT="PHYSICIAN"
SET COL=COL+1
SET IBNAME="Inpatient Physician"
+23 IF IBBI="CPT"
IF IBCSNM["SNF"
SET COL=3
SET IBNAME="SNF Facility"
IF IBCT="PHYSICIAN"
SET COL=COL+1
SET IBNAME="SNF Physician"
+24 IF IBBI="CPT"
IF IBCSNM["OPT"
SET COL=5
SET IBNAME="Outpatient Facility"
IF IBCT="PHYSICIAN"
SET COL=COL+1
SET IBNAME="Outpatient Physician"
+25 IF IBBI="CPT"
IF IBCSNM["FS"
SET COL=7
SET IBNAME="Freestanding Physician"
+26 ;
+27 SET IBPB=$PIECE(IBRG0,U,3)
SET IBPB=$SELECT(IBPB=1:"VAMC Provider Based",IBPB=2:"Opt Provider Based",IBPB=3:"Non-Provider Based",1:"Provider Based Unknown")
+28 ;
+29 SET IBCM=$PIECE(IBBR0,U,5)
SET IBCM=$SELECT(IBCM=4:"ml",IBCM=5:"mn+",IBCM=6:"hr+",1:"")
+30 ;
+31 SET IB2(IBCS)=IBBI_U_COL_U_IBNAME_U_IBDV_U_IBPB_U_IBCM
+32 SET $PIECE(IB3(IBBI),U,COL)=IBNAME_" "_IBDV_" "_IBPB
+33 ;
+34 SET IBCNT=IBCNT+1
IF IBCNT#1000=0
IF '$DATA(ZTQUEUED)
USE IO(0)
WRITE "."
USE IO
End DoDot:1
+35 ;
ITEMS ;
+1 SET IBBI=""
FOR
SET IBBI=$ORDER(IB3(IBBI))
if IBBI=""
QUIT
SET ^TMP("IBCROE",$JOB,IBBI)="Item^Modifier^"_IB3(IBBI)
+2 ;
+3 SET IBCI=0
FOR
SET IBCI=$ORDER(^IBA(363.2,IBCI))
if 'IBCI
QUIT
Begin DoDot:1
+4 SET IBCI0=^IBA(363.2,IBCI,0)
SET IBCSNM=$PIECE($GET(^IBE(363.1,+$PIECE(IBCI0,U,2),0)),U,1)
if IBCSNM=""
QUIT
+5 SET IBLNZ=$GET(IB2($PIECE(IBCI0,U,2)))
IF IBLNZ=""
SET IBZ("NOT DONE ",IBCSNM)=""
QUIT
+6 SET IBZ("DONE",IBCSNM)=""
+7 ;
+8 if $PIECE(IBCI0,U,3)'=$$VERSDT^IBCRHBRV(VERS)
QUIT
+9 ;
+10 SET IBCHG=$PIECE(IBCI0,U,5)_$PIECE(IBLNZ,U,6)_$PIECE(IBCI0,U,8)
+11 SET IBMOD=$PIECE(IBCI0,U,7)
IF IBMOD'=""
SET IBMOD=$PIECE($$MOD^ICPTMOD(IBMOD,"I"),U,2)
+12 IF IBMOD=""
SET IBMOD=0
+13 SET IBCPT=$$EXPAND^IBCRU1(363.2,.01,$PIECE(IBCI0,U,1))
+14 ;
+15 SET IBBI=$PIECE(IBLNZ,U,1)
+16 SET COL=$PIECE(IBLNZ,U,2)
+17 ;DUP
IF $PIECE($GET(^TMP("IBCROE",$JOB,IBBI,IBCPT,IBMOD)),U,COL)'=""
QUIT
+18 SET $PIECE(^TMP("IBCROE",$JOB,IBBI,IBCPT,IBMOD),U,COL)=IBCHG
+19 ;
+20 SET IBCNT=IBCNT+1
IF IBCNT#1000=0
IF '$DATA(ZTQUEUED)
USE IO(0)
WRITE "."
USE IO
End DoDot:1
+21 ;
+22 ;
+23 DO WRT
+24 KILL ^TMP("IBCROE",$JOB)
+25 QUIT
WRT ;
+1 SET IBBI=""
FOR
SET IBBI=$ORDER(^TMP("IBCROE",$JOB,IBBI))
if IBBI=""
QUIT
Begin DoDot:1
+2 WRITE !,^TMP("IBCROE",$JOB,IBBI)
+3 SET IBCPT=""
FOR
SET IBCPT=$ORDER(^TMP("IBCROE",$JOB,IBBI,IBCPT))
if IBCPT=""
QUIT
Begin DoDot:2
+4 SET IBMOD=""
FOR
SET IBMOD=$ORDER(^TMP("IBCROE",$JOB,IBBI,IBCPT,IBMOD))
if IBMOD=""
QUIT
Begin DoDot:3
+5 SET IBMODI=IBMOD
IF IBMOD=0
SET IBMODI=""
+6 WRITE !,IBCPT,U,IBMODI,U,^TMP("IBCROE",$JOB,IBBI,IBCPT,IBMOD)
+7 SET IBCNT=IBCNT+1
IF IBCNT#1000=0
IF '$DATA(ZTQUEUED)
IF $EXTRACT(IOST,1,2)'="C-"
USE IO(0)
WRITE "."
USE IO
End DoDot:3
End DoDot:2
End DoDot:1
+8 QUIT
