IBOTR2 ;ALB/CPM - INSURANCE PAYMENT TREND REPORT - COMPILATION ; 5-JUN-91
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;
;MAP TO DGCROTR2
;
;***
;S XRTL=$ZU(0),XRTN="IBOTR-2" D T0^%ZOSV ;start rt clock
K ^TMP($J) S IBQUIT=0
S IBDA="" F IBCNT=1:1 S IBDA=$O(^DGCR(399,"AD",IBRT,IBDA)) Q:'IBDA D COMP I IBCNT#100=0 S IBQUIT=$$STOP^IBOUTL("Trend Report") Q:IBQUIT
D:'IBQUIT ^IBOTR3 ; Write the output report.
;***
;I $D(XRT0) S:'$D(XRTN) XRTN="IBOTR2" D T1^%ZOSV ;stop rt clock
I $D(ZTQUEUED) S ZTREQ="@" Q
K IB,IBAO,IBAP,IBCNT,IBDA,DFN,IBBC,DIC,DA,DR,DIQ,IBDP,IBDBC,IBSCF,IBSCT,IBQUIT
D ^%ZISC Q
;
;
COMP ; Compile Bill-Accounts/Receivable records for report.
Q:'$D(^DGCR(399,IBDA,0)) S IBD=^(0),IBBN=$P(IBD,"^"),DFN=+$P(IBD,"^",2),IBBC=$P(IBD,"^",5) S:IBBN="" IBBN="NULL"
Q:IBBRT="O"&("12"[IBBC) Q:IBBRT="I"&("34"[IBBC)
S IBDBC=$$CLO^PRCAFN(IBDA) Q:IBARST="O"&(IBDBC>0)!(IBARST="C"&(IBDBC<0))
S:IBDBC>0 IBBN=IBBN_" *" S:IBDBC'>0 IBDBC=DT
I $D(IBBRN),IBBRN="S" S IBBRTY=$S("12"[IBBC:"I",1:"O")
;
; - perform edits for Insurance company
S IBD=$P($G(^DGCR(399,IBDA,"M")),"^") Q:IBICF'="@"&(IBD="")
I $D(IBIC) Q:IBIC="ALL"&(IBD="") Q:IBIC="NULL"&(IBD]"")
S IBINS=$P($G(^DIC(36,+IBD,0)),"^")
I IBINS="" S IBINS="UNKNOWN" G CANC
I $G(IBIC)="ALL" G CANC
I IBICF="@"&(IBICL="") G CANC
Q:IBICF]IBINS!(IBINS]IBICL)
;
; - only keep cancelled bills if 'Bill Cancelled?' field is selected
CANC S IBINS=IBINS_"@@"_IBD
Q:'$D(^DGCR(399,IBDA,"S")) S IBD=^("S")
I $G(IBAF)'=16 Q:$P(IBD,"^",16) ; Bill has been cancelled
;
; - perform Printed/Treatment date edits
S IBDP=$P(IBD,"^",12)
I IBDF=1 Q:IBDP<IBBDT!(IBDP>IBEDT) ; Date printed is out of range
S IBD=$G(^DGCR(399,IBDA,"U")),IBSCF=$P(IBD,"^"),IBSCT=$P(IBD,"^",2)
I IBDF=2 Q:IBSCT<IBBDT!(IBSCF>IBEDT) ; Treatment dates out of range
I '$D(IBAF) G BUILD
;
; - find the selected field value and compare to selection parameters
K IB S DIC=399,DA=IBDA,DR=IBAF,DIQ="IB" S:IBAFD DIQ(0)="I"
D EN^DIQ1 K DIQ
S:IBAFD IB(399,IBDA,IBAF)=IB(399,IBDA,IBAF,"I")
S IB=$G(IB(399,IBDA,IBAF))
Q:IBAFF'="@"&(IB="")
I $D(IBAFZ) Q:IBAFZ="ALL"&(IB="") Q:IBAFZ="NULL"&(IB]"")
I IB="" G BUILD
I $G(IBAFZ)="ALL" G BUILD
I IBAFF="@",IBAFL="" G BUILD
I +IBAFF=IBAFF,+IBAFL=IBAFL Q:IB<IBAFF!(IB>IBAFL)
E Q:IBAFF]IB!(IB]IBAFL)
;
; - retrieve A/R data and build sort global.
BUILD S IBAO=$$ORI^PRCAFN(IBDA) S:IBAO<0 IBAO=0
S IBAP=$$TPR^PRCAFN(IBDA) S:IBAP<0 IBAP=0
S ^TMP($J,"IBOTR",IBBRTY,IBINS,$$NAMAGE(DFN)_"@@"_IBBN)="^"_IBSCF_"^"_IBSCT_"^"_IBDP_"^"_IBDBC_"^"_IBAO_"^"_IBAP
Q
;
NAMAGE(DFN) ; Return patient name and age.
; Input: DFN
; Output: Pt name (1st 18 chars)_"("_Pt Age_")"
N DPT0,X,X1,X2
S DPT0=$G(^DPT(DFN,0)),X2=$P(DPT0,"^",3)
I 'X2 S X="UNK"
E S X1=DT D ^%DTC S X=X\365.25
Q $E($P(DPT0,"^"),1,18)_" ("_X_")"
IBOTR2 ;ALB/CPM - INSURANCE PAYMENT TREND REPORT - COMPILATION ; 5-JUN-91
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;
+3 ;MAP TO DGCROTR2
+4 ;
+5 ;***
+6 ;S XRTL=$ZU(0),XRTN="IBOTR-2" D T0^%ZOSV ;start rt clock
+7 KILL ^TMP($JOB)
SET IBQUIT=0
+8 SET IBDA=""
FOR IBCNT=1:1
SET IBDA=$ORDER(^DGCR(399,"AD",IBRT,IBDA))
IF 'IBDA
QUIT
DO COMP
IF IBCNT#100=0
SET IBQUIT=$$STOP^IBOUTL("Trend Report")
IF IBQUIT
QUIT
+9 ; Write the output report.
IF 'IBQUIT
DO ^IBOTR3
+10 ;***
+11 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOTR2" D T1^%ZOSV ;stop rt clock
+12 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+13 KILL IB,IBAO,IBAP,IBCNT,IBDA,DFN,IBBC,DIC,DA,DR,DIQ,IBDP,IBDBC,IBSCF,IBSCT,IBQUIT
+14 DO ^%ZISC
QUIT
+15 ;
+16 ;
COMP ; Compile Bill-Accounts/Receivable records for report.
+1 IF '$DATA(^DGCR(399,IBDA,0))
QUIT
SET IBD=^(0)
SET IBBN=$PIECE(IBD,"^")
SET DFN=+$PIECE(IBD,"^",2)
SET IBBC=$PIECE(IBD,"^",5)
IF IBBN=""
SET IBBN="NULL"
+2 IF IBBRT="O"&("12"[IBBC)
QUIT
IF IBBRT="I"&("34"[IBBC)
QUIT
+3 SET IBDBC=$$CLO^PRCAFN(IBDA)
IF IBARST="O"&(IBDBC>0)!(IBARST="C"&(IBDBC<0))
QUIT
+4 IF IBDBC>0
SET IBBN=IBBN_" *"
IF IBDBC'>0
SET IBDBC=DT
+5 IF $DATA(IBBRN)
IF IBBRN="S"
SET IBBRTY=$SELECT("12"[IBBC:"I",1:"O")
+6 ;
+7 ; - perform edits for Insurance company
+8 SET IBD=$PIECE($GET(^DGCR(399,IBDA,"M")),"^")
IF IBICF'="@"&(IBD="")
QUIT
+9 IF $DATA(IBIC)
IF IBIC="ALL"&(IBD="")
QUIT
IF IBIC="NULL"&(IBD]"")
QUIT
+10 SET IBINS=$PIECE($GET(^DIC(36,+IBD,0)),"^")
+11 IF IBINS=""
SET IBINS="UNKNOWN"
GOTO CANC
+12 IF $GET(IBIC)="ALL"
GOTO CANC
+13 IF IBICF="@"&(IBICL="")
GOTO CANC
+14 IF IBICF]IBINS!(IBINS]IBICL)
QUIT
+15 ;
+16 ; - only keep cancelled bills if 'Bill Cancelled?' field is selected
CANC SET IBINS=IBINS_"@@"_IBD
+1 IF '$DATA(^DGCR(399,IBDA,"S"))
QUIT
SET IBD=^("S")
+2 ; Bill has been cancelled
IF $GET(IBAF)'=16
IF $PIECE(IBD,"^",16)
QUIT
+3 ;
+4 ; - perform Printed/Treatment date edits
+5 SET IBDP=$PIECE(IBD,"^",12)
+6 ; Date printed is out of range
IF IBDF=1
IF IBDP<IBBDT!(IBDP>IBEDT)
QUIT
+7 SET IBD=$GET(^DGCR(399,IBDA,"U"))
SET IBSCF=$PIECE(IBD,"^")
SET IBSCT=$PIECE(IBD,"^",2)
+8 ; Treatment dates out of range
IF IBDF=2
IF IBSCT<IBBDT!(IBSCF>IBEDT)
QUIT
+9 IF '$DATA(IBAF)
GOTO BUILD
+10 ;
+11 ; - find the selected field value and compare to selection parameters
+12 KILL IB
SET DIC=399
SET DA=IBDA
SET DR=IBAF
SET DIQ="IB"
IF IBAFD
SET DIQ(0)="I"
+13 DO EN^DIQ1
KILL DIQ
+14 IF IBAFD
SET IB(399,IBDA,IBAF)=IB(399,IBDA,IBAF,"I")
+15 SET IB=$GET(IB(399,IBDA,IBAF))
+16 IF IBAFF'="@"&(IB="")
QUIT
+17 IF $DATA(IBAFZ)
IF IBAFZ="ALL"&(IB="")
QUIT
IF IBAFZ="NULL"&(IB]"")
QUIT
+18 IF IB=""
GOTO BUILD
+19 IF $GET(IBAFZ)="ALL"
GOTO BUILD
+20 IF IBAFF="@"
IF IBAFL=""
GOTO BUILD
+21 IF +IBAFF=IBAFF
IF +IBAFL=IBAFL
IF IB<IBAFF!(IB>IBAFL)
QUIT
+22 IF '$TEST
IF IBAFF]IB!(IB]IBAFL)
QUIT
+23 ;
+24 ; - retrieve A/R data and build sort global.
BUILD SET IBAO=$$ORI^PRCAFN(IBDA)
IF IBAO<0
SET IBAO=0
+1 SET IBAP=$$TPR^PRCAFN(IBDA)
IF IBAP<0
SET IBAP=0
+2 SET ^TMP($JOB,"IBOTR",IBBRTY,IBINS,$$NAMAGE(DFN)_"@@"_IBBN)="^"_IBSCF_"^"_IBSCT_"^"_IBDP_"^"_IBDBC_"^"_IBAO_"^"_IBAP
+3 QUIT
+4 ;
NAMAGE(DFN) ; Return patient name and age.
+1 ; Input: DFN
+2 ; Output: Pt name (1st 18 chars)_"("_Pt Age_")"
+3 NEW DPT0,X,X1,X2
+4 SET DPT0=$GET(^DPT(DFN,0))
SET X2=$PIECE(DPT0,"^",3)
+5 IF 'X2
SET X="UNK"
+6 IF '$TEST
SET X1=DT
DO ^%DTC
SET X=X\365.25
+7 QUIT $EXTRACT($PIECE(DPT0,"^"),1,18)_" ("_X_")"
