- 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_")"
