- 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
