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
Q
;
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,!
Q
;
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)
Q
;
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"
Q
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
Q
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOAMS 3801 printed Oct 16, 2024@18:25:52 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
