IBOMTC1 ;ALB/CPM - CATEGORY C BILLING ACTIVITY LIST (CON'T) ; 09-JAN-92
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;
;***
;S XRTL=$ZU(0),XRTN="IBOMTC-2" D T0^%ZOSV ;start rt clock
; Select charges from file #350.
S DFN="" F S DFN=$O(^IB("AFDT",DFN)) Q:'DFN D
. S EVDT=-(IBEDT+.99) F S EVDT=$O(^IB("AFDT",DFN,EVDT)) Q:'EVDT D
.. S EVDA=0 F S EVDA=$O(^IB("AFDT",DFN,EVDT,EVDA)) Q:'EVDA D
... S IBDA=0 F IBCNT=1:1 S IBDA=$O(^IB("AF",EVDA,IBDA)) Q:'IBDA D
.... Q:'$D(^IB(IBDA,0)) S IBD0=^(0)
.... Q:$P(IBD0,"^",8)["ADMISSION"
.... I $P(IBD0,"^",15)<IBBDT!($P(IBD0,"^",14)>IBEDT) Q
.... S NAM=$P($G(^DPT(DFN,0)),"^") S:NAM="" NAM="UNKNOWN"
.... S ^TMP($J,"IBOMTC",NAM_"@@"_DFN,+$P(IBD0,"^",14),IBDA)=""
;
; Print report.
D NOW^%DTC S IBHDT=$$DAT2^IBOUTL($E(%,1,12))
S IBLINE="",$P(IBLINE,"-",IOM+1)="",(IBPAG,IBQUIT)=0 D HDR G:IBQUIT END
I '$D(^TMP($J,"IBOMTC")) W !!,"There are no Category C bills for this date range." G END
;
S NAM="" F S NAM=$O(^TMP($J,"IBOMTC",NAM)) Q:NAM="" D Q:IBQUIT
. S IBPT=$$PT^IBEFUNC($P(NAM,"@@",2))
. I $Y>(IOSL-5) D PAUSE^IBOUTL Q:IBQUIT D HDR Q:IBQUIT
. W !,$E($P(IBPT,"^"),1,10),?11,$P(IBPT,"^",3)
. S IBDT="" F S IBDT=$O(^TMP($J,"IBOMTC",NAM,IBDT)) Q:'IBDT D Q:IBQUIT
.. S IBDA="" F S IBDA=$O(^TMP($J,"IBOMTC",NAM,IBDT,IBDA)) Q:'IBDA D Q:IBQUIT
... I $Y>(IOSL-4) D PAUSE^IBOUTL Q:IBQUIT D HDR Q:IBQUIT W !,$E($P(IBPT,"^"),1,10),?11,$P(IBPT,"^",3)
... S IBD0=$G(^IB(+IBDA,0)) Q:'IBD0
... S X=$P($P($G(^IBE(350.1,+$P(IBD0,"^",3),0)),"^")," ",2,99)
... W ?17,$E($P(X," ",1,$L(X," ")-1),1,16)
... W ?35,$E($P($G(^IBE(350.21,+$P(IBD0,"^",5),0)),"^",2),1,11)
... W ?47,$$DAT1^IBOUTL($P(IBD0,"^",14)),?57,$$DAT1^IBOUTL($P(IBD0,"^",15))
... W ?66,$J($P(IBD0,"^",6),3)
... S X=$P(IBD0,"^",7),X2="2$",X3=10 D COMMA^%DTC W ?70,X,!
;
; - close device and quit
END D:'IBQUIT PAUSE^IBOUTL K ^TMP($J,"IBOMTC")
;***
;I $D(XRT0) S:'$D(XRTN) XRTN="IBOMTC1" D T1^%ZOSV ;stop rt clock
I $D(ZTQUEUED) S ZTREQ="@" Q
K NAM,DFN,EVDA,EVDT,IBD0,IBDA,IBDT,IBJ,IBQUIT,IBLINE,IBHDT,IBPAG,IBPT,IBCNT,X,X2,X3
D ^%ZISC Q
;
;
HDR ; Print header.
I $E(IOST,1,2)["C-"!(IBPAG) W @IOF
S IBPAG=IBPAG+1 W "Category C Billing Activity List",?IOM-35,IBHDT,?IOM-9,"Page: ",IBPAG
W !,"Charges from ",$$DAT1^IBOUTL(IBBDT)," through ",$$DAT1^IBOUTL(IBEDT)
W !,"PATIENT/ID",?17,"DESCRIPTION",?35,"STATUS",?49,"FROM",?60,"TO",?66,"UNITS",?72,"CHARGE"
W !,IBLINE
S IBQUIT=$$STOP^IBOUTL("Category C Billing Activity List")
Q
IBOMTC1 ;ALB/CPM - CATEGORY C BILLING ACTIVITY LIST (CON'T) ; 09-JAN-92
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;
+3 ;***
+4 ;S XRTL=$ZU(0),XRTN="IBOMTC-2" D T0^%ZOSV ;start rt clock
+5 ; Select charges from file #350.
+6 SET DFN=""
FOR
SET DFN=$ORDER(^IB("AFDT",DFN))
IF 'DFN
QUIT
Begin DoDot:1
+7 SET EVDT=-(IBEDT+.99)
FOR
SET EVDT=$ORDER(^IB("AFDT",DFN,EVDT))
IF 'EVDT
QUIT
Begin DoDot:2
+8 SET EVDA=0
FOR
SET EVDA=$ORDER(^IB("AFDT",DFN,EVDT,EVDA))
IF 'EVDA
QUIT
Begin DoDot:3
+9 SET IBDA=0
FOR IBCNT=1:1
SET IBDA=$ORDER(^IB("AF",EVDA,IBDA))
IF 'IBDA
QUIT
Begin DoDot:4
+10 IF '$DATA(^IB(IBDA,0))
QUIT
SET IBD0=^(0)
+11 IF $PIECE(IBD0,"^",8)["ADMISSION"
QUIT
+12 IF $PIECE(IBD0,"^",15)<IBBDT!($PIECE(IBD0,"^",14)>IBEDT)
QUIT
+13 SET NAM=$PIECE($GET(^DPT(DFN,0)),"^")
IF NAM=""
SET NAM="UNKNOWN"
+14 SET ^TMP($JOB,"IBOMTC",NAM_"@@"_DFN,+$PIECE(IBD0,"^",14),IBDA)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 ;
+16 ; Print report.
+17 DO NOW^%DTC
SET IBHDT=$$DAT2^IBOUTL($EXTRACT(%,1,12))
+18 SET IBLINE=""
SET $PIECE(IBLINE,"-",IOM+1)=""
SET (IBPAG,IBQUIT)=0
DO HDR
IF IBQUIT
GOTO END
+19 IF '$DATA(^TMP($JOB,"IBOMTC"))
WRITE !!,"There are no Category C bills for this date range."
GOTO END
+20 ;
+21 SET NAM=""
FOR
SET NAM=$ORDER(^TMP($JOB,"IBOMTC",NAM))
IF NAM=""
QUIT
Begin DoDot:1
+22 SET IBPT=$$PT^IBEFUNC($PIECE(NAM,"@@",2))
+23 IF $Y>(IOSL-5)
DO PAUSE^IBOUTL
IF IBQUIT
QUIT
DO HDR
IF IBQUIT
QUIT
+24 WRITE !,$EXTRACT($PIECE(IBPT,"^"),1,10),?11,$PIECE(IBPT,"^",3)
+25 SET IBDT=""
FOR
SET IBDT=$ORDER(^TMP($JOB,"IBOMTC",NAM,IBDT))
IF 'IBDT
QUIT
Begin DoDot:2
+26 SET IBDA=""
FOR
SET IBDA=$ORDER(^TMP($JOB,"IBOMTC",NAM,IBDT,IBDA))
IF 'IBDA
QUIT
Begin DoDot:3
+27 IF $Y>(IOSL-4)
DO PAUSE^IBOUTL
IF IBQUIT
QUIT
DO HDR
IF IBQUIT
QUIT
WRITE !,$EXTRACT($PIECE(IBPT,"^"),1,10),?11,$PIECE(IBPT,"^",3)
+28 SET IBD0=$GET(^IB(+IBDA,0))
IF 'IBD0
QUIT
+29 SET X=$PIECE($PIECE($GET(^IBE(350.1,+$PIECE(IBD0,"^",3),0)),"^")," ",2,99)
+30 WRITE ?17,$EXTRACT($PIECE(X," ",1,$LENGTH(X," ")-1),1,16)
+31 WRITE ?35,$EXTRACT($PIECE($GET(^IBE(350.21,+$PIECE(IBD0,"^",5),0)),"^",2),1,11)
+32 WRITE ?47,$$DAT1^IBOUTL($PIECE(IBD0,"^",14)),?57,$$DAT1^IBOUTL($PIECE(IBD0,"^",15))
+33 WRITE ?66,$JUSTIFY($PIECE(IBD0,"^",6),3)
+34 SET X=$PIECE(IBD0,"^",7)
SET X2="2$"
SET X3=10
DO COMMA^%DTC
WRITE ?70,X,!
End DoDot:3
IF IBQUIT
QUIT
End DoDot:2
IF IBQUIT
QUIT
End DoDot:1
IF IBQUIT
QUIT
+35 ;
+36 ; - close device and quit
END IF 'IBQUIT
DO PAUSE^IBOUTL
KILL ^TMP($JOB,"IBOMTC")
+1 ;***
+2 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOMTC1" D T1^%ZOSV ;stop rt clock
+3 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+4 KILL NAM,DFN,EVDA,EVDT,IBD0,IBDA,IBDT,IBJ,IBQUIT,IBLINE,IBHDT,IBPAG,IBPT,IBCNT,X,X2,X3
+5 DO ^%ZISC
QUIT
+6 ;
+7 ;
HDR ; Print header.
+1 IF $EXTRACT(IOST,1,2)["C-"!(IBPAG)
WRITE @IOF
+2 SET IBPAG=IBPAG+1
WRITE "Category C Billing Activity List",?IOM-35,IBHDT,?IOM-9,"Page: ",IBPAG
+3 WRITE !,"Charges from ",$$DAT1^IBOUTL(IBBDT)," through ",$$DAT1^IBOUTL(IBEDT)
+4 WRITE !,"PATIENT/ID",?17,"DESCRIPTION",?35,"STATUS",?49,"FROM",?60,"TO",?66,"UNITS",?72,"CHARGE"
+5 WRITE !,IBLINE
+6 SET IBQUIT=$$STOP^IBOUTL("Category C Billing Activity List")
+7 QUIT
