- IBOMTP1 ;ALB/CPM - CATEGORY C BILLING PROFILE (CON'T) ; 10-DEC-91
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;
- ;***
- ;S XRTL=$ZU(0),XRTN="IBOMTP1-2" D T0^%ZOSV ;start rt clock
- ; Begin compilation. Start with billing clocks.
- S Y=-(IBEDT+.1),X=0 F Q:-Y<IBBDT S Y=$O(^IBE(351,"AIVDT",IBDFN,Y)) Q:'Y F S X=$O(^IBE(351,"AIVDT",IBDFN,Y,X)) Q:'X S:$P($G(^IBE(351,X,0)),"^",4)'=3 ^TMP($J,"IBOMTP",-Y,"C")=""
- ;
- ; Get O/P visits from file #399.
- S X1=IBBDT,X2=-1 D C^%DTC S Y=X
- F S Y=$O(^DGCR(399,"AOPV",IBDFN,Y)) Q:'Y!(Y>IBEDT) D
- . S IBDA=0 F S IBDA=$O(^DGCR(399,"AOPV",IBDFN,Y,IBDA)) Q:'IBDA D
- .. I $D(^DGCR(399,+IBDA,0)),'$P($G(^("S")),"^",16),$P($G(^DGCR(399.3,+$P(^(0),"^",7),0)),"^")["MEANS" S ^TMP($J,"IBOMTP",Y,"M"_IBDA)=""
- ;
- ; Get the rest of the charges from file #350.
- S Y="" F S Y=$O(^IB("AFDT",IBDFN,Y)) Q:'Y I -Y'>IBEDT S Y1=0 F S Y1=$O(^IB("AFDT",IBDFN,Y,Y1)) Q:'Y1 D
- . S IBDA=0 F S IBDA=$O(^IB("AF",Y1,IBDA)) Q:'IBDA D
- .. Q:'$D(^IB(IBDA,0)) S IBX=^(0)
- .. Q:$P(IBX,"^",8)["ADMISSION"
- .. I $P(IBX,"^",15)<IBBDT!($P(IBX,"^",14)>IBEDT) Q
- .. S ^TMP($J,"IBOMTP",+$P(IBX,"^",14),"I"_IBDA)=""
- ;
- ; Print report.
- D NOW^%DTC S IBHDT=$$DAT2^IBOUTL($E(%,1,12))
- S IBLINE="",$P(IBLINE,"-",IOM+1)="",(IBPAG,IBCHGT,IBQUIT)=0
- S IBPT=$$PT^IBEFUNC(IBDFN)
- S IBH="Category C Billing Profile for "_$P(IBPT,"^")_" "_$P(IBPT,"^",2) D HDR
- I '$D(^TMP($J,"IBOMTP")) W !,"This patient has no Category C bills." D PAUSE^IBOUTL G END
- ; - first, print detail lines
- S IBD="" F S IBD=$O(^TMP($J,"IBOMTP",IBD)) Q:'IBD D G:IBQUIT END
- . S IBTY="" F S IBTY=$O(^TMP($J,"IBOMTP",IBD,IBTY)) Q:IBTY="" D Q:IBQUIT
- .. I $Y>(IOSL-5) D PAUSE^IBOUTL Q:IBQUIT D HDR
- .. W !,$$DAT1^IBOUTL(IBD)
- .. I IBTY="C" W ?12,"Begin Category C Billing Clock" Q
- .. S IBDA=+$E(IBTY,2,99),IBD0=$S($E(IBTY)="M":$G(^DGCR(399,IBDA,0)),1:$G(^IB(IBDA,0))),IBSEQ=0
- .. I $E(IBTY)="I" S IBSEQ=$P($G(^IBE(350.1,+$P(IBD0,"^",3),0)),"^",5)
- .. W ?14,$S($E(IBTY)="M":"OPT COPAYMENT (UB-82)",1:$$ACTNM^IBOUTL(+$P(IBD0,"^",3)))
- .. W ?44,$S($E(IBTY)="M":$P(IBD0,"^"),1:$$STAT())
- .. I $E(IBTY)="I",$P(IBD0,"^",14)'=$P(IBD0,"^",15) W ?54,$$DAT1^IBOUTL($P(IBD0,"^",15))
- .. I $E(IBTY)="M" S X=+$O(^DGCR(399,IBDA,"RC","B",500,0)),IBCHG=+$P($G(^DGCR(399,IBDA,"RC",X,0)),"^",2)
- .. E S IBCHG=+$P(IBD0,"^",7)
- .. I IBSEQ=2 S IBCHG=-IBCHG
- .. I $E(IBTY)="I",$P(IBD0,"^",11)="",$P($G(^IBE(350.21,+$P(IBD0,"^",5),0)),"^",5) S IBCHG=0
- .. S X=IBCHG,X2="2$",X3=10 D COMMA^%DTC W ?65,X
- .. S IBCHGT=IBCHGT+IBCHG
- .. I IBSEQ=2!($P(IBD0,"^",11)=""&($P($G(^IBE(350.21,+$P(IBD0,"^",5),0)),"^",5))) W !?5,"Charge Removal Reason: ",$S($D(^IBE(350.3,+$P(IBD0,"^",10),0)):$P(^(0),"^"),1:"UNKNOWN")
- ; - print totals line
- I $Y>(IOSL-5) D PAUSE^IBOUTL G:IBQUIT END D HDR
- W !?63,"-----------" S X=IBCHGT,X2="2$",X3=12 D COMMA^%DTC W !?63,X
- D PAUSE^IBOUTL
- ; - close device and quit
- END K ^TMP($J)
- ;***
- ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOMTP1" D T1^%ZOSV ;stop rt clock
- I $D(ZTQUEUED) S ZTREQ="@" Q
- K IBJ,IBD,IBH,IBHDT,IBTY,IBDA,IBD0,IBSEQ,IBQUIT,IBCHG,IBCHGT,IBPAG,IBLINE,IBX,IBPT,X,X2,X3,Y,Y1
- D ^%ZISC Q
- ;
- ;
- HDR ; Print header.
- I $E(IOST,1,2)["C-"!(IBPAG) W @IOF,*13
- S IBPAG=IBPAG+1 W ?(80-$L(IBH)\2),IBH
- W !,"From ",$$DAT1^IBOUTL(IBBDT)," through ",$$DAT1^IBOUTL(IBEDT)
- W ?IOM-36,IBHDT,?IOM-9,"Page: ",IBPAG
- W !,"BILL DATE BILL TYPE",?44,"BILL # BILL TO TOT CHARGE"
- W !,IBLINE,! Q
- ;
- STAT() ; Display bill number or status
- N IBSTAT S IBSTAT=$G(^IBE(350.21,+$P(IBD0,"^",5),0))
- Q $S($P(IBSTAT,"^",6):$$HLD(+$P(IBD0,"^",5)),$P(IBD0,"^",5)=99:"Converted",$P(IBD0,"^",11)]"":$P($P(IBD0,"^",11),"-",2),$P(IBSTAT,"^",5):"Cancelled",1:"Pending")
- ;
- HLD(STAT) ; Return an 'on hold' status string
- Q "Hold "_$S(STAT=20:"Rate",STAT=21:"Clm",STAT=22:"Adj",1:"Ins")
- IBOMTP1 ;ALB/CPM - CATEGORY C BILLING PROFILE (CON'T) ; 10-DEC-91
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- +2 ;
- +3 ;***
- +4 ;S XRTL=$ZU(0),XRTN="IBOMTP1-2" D T0^%ZOSV ;start rt clock
- +5 ; Begin compilation. Start with billing clocks.
- +6 SET Y=-(IBEDT+.1)
- SET X=0
- FOR
- IF -Y<IBBDT
- QUIT
- SET Y=$ORDER(^IBE(351,"AIVDT",IBDFN,Y))
- IF 'Y
- QUIT
- FOR
- SET X=$ORDER(^IBE(351,"AIVDT",IBDFN,Y,X))
- IF 'X
- QUIT
- IF $PIECE($GET(^IBE(351,X,0)),"^",4)'=3
- SET ^TMP($JOB,"IBOMTP",-Y,"C")=""
- +7 ;
- +8 ; Get O/P visits from file #399.
- +9 SET X1=IBBDT
- SET X2=-1
- DO C^%DTC
- SET Y=X
- +10 FOR
- SET Y=$ORDER(^DGCR(399,"AOPV",IBDFN,Y))
- IF 'Y!(Y>IBEDT)
- QUIT
- Begin DoDot:1
- +11 SET IBDA=0
- FOR
- SET IBDA=$ORDER(^DGCR(399,"AOPV",IBDFN,Y,IBDA))
- IF 'IBDA
- QUIT
- Begin DoDot:2
- +12 IF $DATA(^DGCR(399,+IBDA,0))
- IF '$PIECE($GET(^("S")),"^",16)
- IF $PIECE($GET(^DGCR(399.3,+$PIECE(^(0),"^",7),0)),"^")["MEANS"
- SET ^TMP($JOB,"IBOMTP",Y,"M"_IBDA)=""
- End DoDot:2
- End DoDot:1
- +13 ;
- +14 ; Get the rest of the charges from file #350.
- +15 SET Y=""
- FOR
- SET Y=$ORDER(^IB("AFDT",IBDFN,Y))
- IF 'Y
- QUIT
- IF -Y'>IBEDT
- SET Y1=0
- FOR
- SET Y1=$ORDER(^IB("AFDT",IBDFN,Y,Y1))
- IF 'Y1
- QUIT
- Begin DoDot:1
- +16 SET IBDA=0
- FOR
- SET IBDA=$ORDER(^IB("AF",Y1,IBDA))
- IF 'IBDA
- QUIT
- Begin DoDot:2
- +17 IF '$DATA(^IB(IBDA,0))
- QUIT
- SET IBX=^(0)
- +18 IF $PIECE(IBX,"^",8)["ADMISSION"
- QUIT
- +19 IF $PIECE(IBX,"^",15)<IBBDT!($PIECE(IBX,"^",14)>IBEDT)
- QUIT
- +20 SET ^TMP($JOB,"IBOMTP",+$PIECE(IBX,"^",14),"I"_IBDA)=""
- End DoDot:2
- End DoDot:1
- +21 ;
- +22 ; Print report.
- +23 DO NOW^%DTC
- SET IBHDT=$$DAT2^IBOUTL($EXTRACT(%,1,12))
- +24 SET IBLINE=""
- SET $PIECE(IBLINE,"-",IOM+1)=""
- SET (IBPAG,IBCHGT,IBQUIT)=0
- +25 SET IBPT=$$PT^IBEFUNC(IBDFN)
- +26 SET IBH="Category C Billing Profile for "_$PIECE(IBPT,"^")_" "_$PIECE(IBPT,"^",2)
- DO HDR
- +27 IF '$DATA(^TMP($JOB,"IBOMTP"))
- WRITE !,"This patient has no Category C bills."
- DO PAUSE^IBOUTL
- GOTO END
- +28 ; - first, print detail lines
- +29 SET IBD=""
- FOR
- SET IBD=$ORDER(^TMP($JOB,"IBOMTP",IBD))
- IF 'IBD
- QUIT
- Begin DoDot:1
- +30 SET IBTY=""
- FOR
- SET IBTY=$ORDER(^TMP($JOB,"IBOMTP",IBD,IBTY))
- IF IBTY=""
- QUIT
- Begin DoDot:2
- +31 IF $Y>(IOSL-5)
- DO PAUSE^IBOUTL
- IF IBQUIT
- QUIT
- DO HDR
- +32 WRITE !,$$DAT1^IBOUTL(IBD)
- +33 IF IBTY="C"
- WRITE ?12,"Begin Category C Billing Clock"
- QUIT
- +34 SET IBDA=+$EXTRACT(IBTY,2,99)
- SET IBD0=$SELECT($EXTRACT(IBTY)="M":$GET(^DGCR(399,IBDA,0)),1:$GET(^IB(IBDA,0)))
- SET IBSEQ=0
- +35 IF $EXTRACT(IBTY)="I"
- SET IBSEQ=$PIECE($GET(^IBE(350.1,+$PIECE(IBD0,"^",3),0)),"^",5)
- +36 WRITE ?14,$SELECT($EXTRACT(IBTY)="M":"OPT COPAYMENT (UB-82)",1:$$ACTNM^IBOUTL(+$PIECE(IBD0,"^",3)))
- +37 WRITE ?44,$SELECT($EXTRACT(IBTY)="M":$PIECE(IBD0,"^"),1:$$STAT())
- +38 IF $EXTRACT(IBTY)="I"
- IF $PIECE(IBD0,"^",14)'=$PIECE(IBD0,"^",15)
- WRITE ?54,$$DAT1^IBOUTL($PIECE(IBD0,"^",15))
- +39 IF $EXTRACT(IBTY)="M"
- SET X=+$ORDER(^DGCR(399,IBDA,"RC","B",500,0))
- SET IBCHG=+$PIECE($GET(^DGCR(399,IBDA,"RC",X,0)),"^",2)
- +40 IF '$TEST
- SET IBCHG=+$PIECE(IBD0,"^",7)
- +41 IF IBSEQ=2
- SET IBCHG=-IBCHG
- +42 IF $EXTRACT(IBTY)="I"
- IF $PIECE(IBD0,"^",11)=""
- IF $PIECE($GET(^IBE(350.21,+$PIECE(IBD0,"^",5),0)),"^",5)
- SET IBCHG=0
- +43 SET X=IBCHG
- SET X2="2$"
- SET X3=10
- DO COMMA^%DTC
- WRITE ?65,X
- +44 SET IBCHGT=IBCHGT+IBCHG
- +45 IF IBSEQ=2!($PIECE(IBD0,"^",11)=""&($PIECE($GET(^IBE(350.21,+$PIECE(IBD0,"^",5),0)),"^",5)))
- WRITE !?5,"Charge Removal Reason: ",$SELECT($DATA(^IBE(350.3,+$PIECE(IBD0,"^",10),0)):$PIECE(^(0),"^"),1:"UNKNOWN")
- End DoDot:2
- IF IBQUIT
- QUIT
- End DoDot:1
- IF IBQUIT
- GOTO END
- +46 ; - print totals line
- +47 IF $Y>(IOSL-5)
- DO PAUSE^IBOUTL
- IF IBQUIT
- GOTO END
- DO HDR
- +48 WRITE !?63,"-----------"
- SET X=IBCHGT
- SET X2="2$"
- SET X3=12
- DO COMMA^%DTC
- WRITE !?63,X
- +49 DO PAUSE^IBOUTL
- +50 ; - close device and quit
- END KILL ^TMP($JOB)
- +1 ;***
- +2 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOMTP1" D T1^%ZOSV ;stop rt clock
- +3 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- QUIT
- +4 KILL IBJ,IBD,IBH,IBHDT,IBTY,IBDA,IBD0,IBSEQ,IBQUIT,IBCHG,IBCHGT,IBPAG,IBLINE,IBX,IBPT,X,X2,X3,Y,Y1
- +5 DO ^%ZISC
- QUIT
- +6 ;
- +7 ;
- HDR ; Print header.
- +1 IF $EXTRACT(IOST,1,2)["C-"!(IBPAG)
- WRITE @IOF,*13
- +2 SET IBPAG=IBPAG+1
- WRITE ?(80-$LENGTH(IBH)\2),IBH
- +3 WRITE !,"From ",$$DAT1^IBOUTL(IBBDT)," through ",$$DAT1^IBOUTL(IBEDT)
- +4 WRITE ?IOM-36,IBHDT,?IOM-9,"Page: ",IBPAG
- +5 WRITE !,"BILL DATE BILL TYPE",?44,"BILL # BILL TO TOT CHARGE"
- +6 WRITE !,IBLINE,!
- QUIT
- +7 ;
- STAT() ; Display bill number or status
- +1 NEW IBSTAT
- SET IBSTAT=$GET(^IBE(350.21,+$PIECE(IBD0,"^",5),0))
- +2 QUIT $SELECT($PIECE(IBSTAT,"^",6):$$HLD(+$PIECE(IBD0,"^",5)),$PIECE(IBD0,"^",5)=99:"Converted",$PIECE(IBD0,"^",11)]"":$PIECE($PIECE(IBD0,"^",11),"-",2),$PIECE(IBSTAT,"^",5):"Cancelled",1:"Pending")
- +3 ;
- HLD(STAT) ; Return an 'on hold' status string
- +1 QUIT "Hold "_$SELECT(STAT=20:"Rate",STAT=21:"Clm",STAT=22:"Adj",1:"Ins")
