Routine: IBCROE

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!"

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)

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCROE   5698     printed  Feb 18, 2025@23:46:13                                                                                                                                                                                                      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

IBCROE.m