Routine: IBOAMS

IBOAMS ;ALB/AAS - PRINT REVENUE CODE TOTALS FOR MEANS TEST AMIS ; 10-SEP-91

 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

 ;MAP TO DGCRAMS1

EN ;  - Report of inpatient and nhcu per diems

 ;***

 ;S XRTL=$ZU(0),XRTN="IBOAMS-1" D T0^%ZOSV ;start rt clock

 D HOME^%ZIS W @IOF,?19,"Report of Revenue Code Totals by Rate Type",!!!

 S DIC="^DGCR(399.3,",DIC(0)="AEQMN",DIC("A")="Select Means Test Rate Type: "

 S IBRT="" F  S IBRT=$O(^DGCR(399.3,"B",IBRT)) Q:IBRT=""  I IBRT["MEANS TEST" S DIC("B")=$O(^(IBRT,0)) Q

 D ^DIC K DIC G:+Y<1 ENQ S IBRT=+Y

DATE W ! S %DT="AEPX",%DT("A")="START WITH DATE FIRST PRINTED: " D ^%DT K %DT G ENQ:Y<1 S IBBDT=Y

DATE1 W ! S %DT="EPX" R !,"GO TO DATE FIRST PRINTED: ",X:DTIME S:X=" " X=IBBDT G ENQ:(X="")!(X["^") D ^%DT K %DT G DATE1:Y<1 S IBEDT=Y I Y<IBBDT W *7," ??",!,"ENDING DATE must follow BEGINNING DATE." G DATE1

 W ! S DIR(0)="Y",DIR("A")="PRINT SUMMARY PAGE ONLY",DIR("B")="YES" D ^DIR K DIR G:$D(DIRUT) ENQ S IBSUM=Y

DEV W ! S %ZIS="QM",%ZIS("A")="Output Device: " D ^%ZIS G:POP ENQ

 I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^IBOAMS",ZTDESC="Revenue Code Report",ZTSAVE("IB*")="" D ^%ZTLOAD K ZTSK G ENQ

 U IO

 ;***

 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOAMS" D T1^%ZOSV ;stop rt clock

DQ ;  - start report here

 ;***

 ;S XRTL=$ZU(0),XRTN="IBOAMS-2" D T0^%ZOSV ;start rt clock

 S (IBCNT,IBQUIT,IBPAG,IBTC)=0 D NOW^%DTC S Y=% D D^DIQ S IBPDT=Y

 D HDR

 K IBT S IBDT=IBBDT-.01

 F  S IBDT=$O(^DGCR(399,"AP",IBDT)) Q:'IBDT!(IBDT>(IBEDT+.25))!(IBQUIT)  S IBIFN=0 F  S IBIFN=$O(^DGCR(399,"AP",IBDT,IBIFN)) Q:'IBIFN!(IBQUIT)  D BLD

 D:'IBQUIT TOTALS

 I '$D(IBT) W !,"No Matches Found"

 D PAUSE:'IBQUIT

ENQ ;

 ;***

 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOAMS" D T1^%ZOSV ;stop rt clock

 I $D(ZTQUEUED) S ZTREQ="@" Q

 K R,X,X2,X3,Y,DFN,IB,IBBDT,IBC,IBDT,IBEDT,IBGT,IBIFN,IBLINE,IBPAG,IBPDT,IBRT,IBSUM,IBT,IBTC,VA,VAERR,DIC,DIR,%DT,IBY,IBQUIT,IBCNT

 D ^%ZISC

BLD ;

 K IB

 I $P(^DGCR(399,IBIFN,0),"^",7)'=IBRT!($S('$D(^("S")):1,$P(^("S"),"^",16):1,1:0)) Q

 S (IBC,R)=0 F  S R=$O(^DGCR(399,IBIFN,"RC",R)) Q:'R  I $D(^DGCR(399,IBIFN,"RC",R,0)) D BLD1

 S IBCNT=IBCNT+1,R=0 F  S R=$O(^DGCR(399,IBIFN,"RC","B",R)) Q:'R  S:'$D(IBCNT(R)) IBCNT(R)=0 S IBCNT(R)=IBCNT(R)+1

 Q:IBSUM

 I ($Y+4+IBC)>IOSL D PAUSE Q:IBQUIT  D HDR

 S DFN=$P(^DGCR(399,IBIFN,0),"^",2) D PID^VADPT W !,$E($P(^DPT(DFN,0),"^"),1,20),?23,VA("PID"),?38,$P(^DGCR(399,IBIFN,0),"^")

 S R=0 F  S R=$O(IB(R)) Q:'R  W ?59,$S($D(^DGCR(399.2,+R,0)):$P(^(0),"^"),1:R),?67 S X=IB(R),X2="2$",X3=12 D COMMA^%DTC W X,!

BLD1 S IB=^DGCR(399,IBIFN,"RC",R,0) S:'$D(IB(+IB)) IB(+IB)=0,IBC=IBC+1 S IB(+IB)=IB(+IB)+$P(IB,"^",4) S:'$D(IBT(+IB)) IBT(+IB)=0,IBTC=IBTC+1 S IBT(+IB)=IBT(+IB)+$P(IB,"^",4)

TOTALS ;  - print revenue code totals

 Q:'$D(IBT)

 I ($Y+4+IBTC)>IOSL S IBSUM=1 D PAUSE Q:IBQUIT  D HDR

 S IBGT=0

 W:'IBSUM !,"----------------------------------------------",!,"REVENUE CODE TOTALS",!

 S R=0 F  S R=$O(IBT(R)) Q:'R  W !,"Revenue Code: ",$S($D(^DGCR(399.2,+R,0)):$P(^(0),"^"),1:R)," .........." S IBGT=IBGT+IBT(R),X=IBT(R),X2="2$",X3=13 D COMMA^%DTC W ?32,X,?50,$J(IBCNT(R),8)," Bills"

 S X=IBGT,X2="2$",X3=13 D COMMA^%DTC W !,?31,"--------------",!,"   ",?32,X,?50,$J(IBCNT,8)," Bills"

HDR ;  - patient data header

 S IBPAG=IBPAG+1

 W:$E(IOST,1,2)["C-"!(IBPAG>1) @IOF

 W "Revenue Code Totals for ",$P(^DGCR(399.3,IBRT,0),"^",1),?(IOM-32),IBPDT,"  PAGE ",IBPAG

 W !,"For Bills First Printed " S Y=IBBDT D DT^DIQ W "  to  " S Y=IBEDT D DT^DIQ

 W:'IBSUM !,"Patient",?25,"Pt. ID.",?38,"Bill No.",?56,"Rev. Code",?72,"Amount"

 S IBLINE="",$P(IBLINE,"-",IOM)="" W !,IBLINE

PAUSE Q:$E(IOST,1,2)'["C-"

 F IBY=$Y:1:(IOSL-4) W !

 S DIR(0)="E" D ^DIR K DIR I $D(DIRUT)!($D(DUOUT)) S IBQUIT=1 K DIRUT,DTOUT,DUOUT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOAMS   3801     printed  Feb 18, 2025@23:51:44                                                                                                                                                                                                      Page 2

IBOAMS    ;ALB/AAS - PRINT REVENUE CODE TOTALS FOR MEANS TEST AMIS ; 10-SEP-91

 +1       ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

 +2       ;

 +3       ;MAP TO DGCRAMS1

 +4       ;

EN        ;  - Report of inpatient and nhcu per diems

 +1       ;***

 +2       ;S XRTL=$ZU(0),XRTN="IBOAMS-1" D T0^%ZOSV ;start rt clock

 +3       ;

 +4        DO HOME^%ZIS

           WRITE @IOF,?19,"Report of Revenue Code Totals by Rate Type",!!!

 +5        SET DIC="^DGCR(399.3,"

           SET DIC(0)="AEQMN"

           SET DIC("A")="Select Means Test Rate Type: "

 +6        SET IBRT=""

FOR

               SET IBRT=$ORDER(^DGCR(399.3,"B",IBRT))

               if IBRT=""

                   QUIT

               IF IBRT["MEANS TEST"

                   SET DIC("B")=$ORDER(^(IBRT,0))

                   QUIT

 +7        DO ^DIC

           KILL DIC

           if +Y<1

               GOTO ENQ

           SET IBRT=+Y

 +8       ;

DATE       WRITE !

           SET %DT="AEPX"

           SET %DT("A")="START WITH DATE FIRST PRINTED: "

           DO ^%DT

           KILL %DT

           if Y<1

               GOTO ENQ

           SET IBBDT=Y

DATE1      WRITE !

           SET %DT="EPX"

           READ !,"GO TO DATE FIRST PRINTED: ",X:DTIME

           if X=" "

               SET X=IBBDT

           if (X="")!(X["^")

               GOTO ENQ

           DO ^%DT

           KILL %DT

           if Y<1

               GOTO DATE1

           SET IBEDT=Y

           IF Y<IBBDT

               WRITE *7," ??",!,"ENDING DATE must follow BEGINNING DATE."

               GOTO DATE1

 +1       ;

 +2        WRITE !

           SET DIR(0)="Y"

           SET DIR("A")="PRINT SUMMARY PAGE ONLY"

           SET DIR("B")="YES"

           DO ^DIR

           KILL DIR

           if $DATA(DIRUT)

               GOTO ENQ

           SET IBSUM=Y

 +3       ;

DEV        WRITE !

           SET %ZIS="QM"

           SET %ZIS("A")="Output Device: "

           DO ^%ZIS

           if POP

               GOTO ENQ

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

               KILL IO("Q")

               SET ZTRTN="DQ^IBOAMS"

               SET ZTDESC="Revenue Code Report"

               SET ZTSAVE("IB*")=""

               DO ^%ZTLOAD

               KILL ZTSK

               GOTO ENQ

 +2        USE IO

 +3       ;***

 +4       ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOAMS" D T1^%ZOSV ;stop rt clock

 +5       ;

DQ        ;  - start report here

 +1       ;***

 +2       ;S XRTL=$ZU(0),XRTN="IBOAMS-2" D T0^%ZOSV ;start rt clock

 +3        SET (IBCNT,IBQUIT,IBPAG,IBTC)=0

           DO NOW^%DTC

           SET Y=%

           DO D^DIQ

           SET IBPDT=Y

 +4        DO HDR

 +5        KILL IBT

           SET IBDT=IBBDT-.01

 +6        FOR

               SET IBDT=$ORDER(^DGCR(399,"AP",IBDT))

               if 'IBDT!(IBDT>(IBEDT+.25))!(IBQUIT)

                   QUIT

               SET IBIFN=0

FOR

                   SET IBIFN=$ORDER(^DGCR(399,"AP",IBDT,IBIFN))

                   if 'IBIFN!(IBQUIT)

                       QUIT

                   DO BLD

 +7       ;

 +8        if 'IBQUIT

               DO TOTALS

 +9        IF '$DATA(IBT)

               WRITE !,"No Matches Found"

 +10       if 'IBQUIT

               DO PAUSE

ENQ       ;

 +1       ;***

 +2       ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOAMS" D T1^%ZOSV ;stop rt clock

 +3        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

               QUIT

 +4        KILL R,X,X2,X3,Y,DFN,IB,IBBDT,IBC,IBDT,IBEDT,IBGT,IBIFN,IBLINE,IBPAG,IBPDT,IBRT,IBSUM,IBT,IBTC,VA,VAERR,DIC,DIR,%DT,IBY,IBQUIT,IBCNT

 +5        DO ^%ZISC

 +6        QUIT

 +7       ;

BLD       ;

 +1        KILL IB

 +2        IF $PIECE(^DGCR(399,IBIFN,0),"^",7)'=IBRT!($SELECT('$DATA(^("S")):1,$PIECE(^("S"),"^",16):1,1:0))

               QUIT

 +3        SET (IBC,R)=0

FOR

               SET R=$ORDER(^DGCR(399,IBIFN,"RC",R))

               if 'R

                   QUIT

               IF $DATA(^DGCR(399,IBIFN,"RC",R,0))

                   DO BLD1

 +4        SET IBCNT=IBCNT+1

           SET R=0

FOR

               SET R=$ORDER(^DGCR(399,IBIFN,"RC","B",R))

               if 'R

                   QUIT

               if '$DATA(IBCNT(R))

                   SET IBCNT(R)=0

               SET IBCNT(R)=IBCNT(R)+1

 +5        if IBSUM

               QUIT

 +6        IF ($Y+4+IBC)>IOSL

               DO PAUSE

               if IBQUIT

                   QUIT

               DO HDR

 +7        SET DFN=$PIECE(^DGCR(399,IBIFN,0),"^",2)

           DO PID^VADPT

           WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),"^"),1,20),?23,VA("PID"),?38,$PIECE(^DGCR(399,IBIFN,0),"^")

 +8        SET R=0

FOR

               SET R=$ORDER(IB(R))

               if 'R

                   QUIT

               WRITE ?59,$SELECT($DATA(^DGCR(399.2,+R,0)):$PIECE(^(0),"^"),1:R),?67

               SET X=IB(R)

               SET X2="2$"

               SET X3=12

               DO COMMA^%DTC

               WRITE X,!

 +9        QUIT

 +10      ;

BLD1       SET IB=^DGCR(399,IBIFN,"RC",R,0)

           if '$DATA(IB(+IB))

               SET IB(+IB)=0

               SET IBC=IBC+1

           SET IB(+IB)=IB(+IB)+$PIECE(IB,"^",4)

           if '$DATA(IBT(+IB))

               SET IBT(+IB)=0

               SET IBTC=IBTC+1

           SET IBT(+IB)=IBT(+IB)+$PIECE(IB,"^",4)

 +1        QUIT

 +2       ;

TOTALS    ;  - print revenue code totals

 +1        if '$DATA(IBT)

               QUIT

 +2        IF ($Y+4+IBTC)>IOSL

               SET IBSUM=1

               DO PAUSE

               if IBQUIT

                   QUIT

               DO HDR

 +3        SET IBGT=0

 +4        if 'IBSUM

               WRITE !,"----------------------------------------------",!,"REVENUE CODE TOTALS",!

 +5        SET R=0

FOR

               SET R=$ORDER(IBT(R))

               if 'R

                   QUIT

               WRITE !,"Revenue Code: ",$SELECT($DATA(^DGCR(399.2,+R,0)):$PIECE(^(0),"^"),1:R)," .........."

               SET IBGT=IBGT+IBT(R)

               SET X=IBT(R)

               SET X2="2$"

               SET X3=13

               DO COMMA^%DTC

               WRITE ?32,X,?50,$JUSTIFY(IBCNT(R),8)," Bills"

 +6        SET X=IBGT

           SET X2="2$"

           SET X3=13

           DO COMMA^%DTC

           WRITE !,?31,"--------------",!,"   ",?32,X,?50,$JUSTIFY(IBCNT,8)," Bills"

 +7        QUIT

HDR       ;  - patient data header

 +1        SET IBPAG=IBPAG+1

 +2        if $EXTRACT(IOST,1,2)["C-"!(IBPAG>1)

               WRITE @IOF

 +3        WRITE "Revenue Code Totals for ",$PIECE(^DGCR(399.3,IBRT,0),"^",1),?(IOM-32),IBPDT,"  PAGE ",IBPAG

 +4        WRITE !,"For Bills First Printed "

           SET Y=IBBDT

           DO DT^DIQ

           WRITE "  to  "

           SET Y=IBEDT

           DO DT^DIQ

 +5        if 'IBSUM

               WRITE !,"Patient",?25,"Pt. ID.",?38,"Bill No.",?56,"Rev. Code",?72,"Amount"

 +6        SET IBLINE=""

           SET $PIECE(IBLINE,"-",IOM)=""

           WRITE !,IBLINE

 +7        QUIT

PAUSE      if $EXTRACT(IOST,1,2)'["C-"

               QUIT

 +1        FOR IBY=$Y:1:(IOSL-4)

               WRITE !

 +2        SET DIR(0)="E"

           DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)!($DATA(DUOUT))

               SET IBQUIT=1

               KILL DIRUT,DTOUT,DUOUT

 +3        QUIT

IBOAMS.m