IBJDB11 ;ALB/CPM - BILLING LAG TIME REPORT (COMPILE) ; 27-DEC-96
;;2.0;INTEGRATED BILLING;**69,100,118,165**;21-MAR-94
;
EN ; - Entry point from IBJDB1.
;
; -
I IBRPT="D" F X=2,3,4,6,7,8 S:IBSEL[X IBSEL=IBSEL_X_"I,"
I 'IBSORT D INIT(0) G REV
S X=0 F S X=$S('VAUTD:$O(VAUTD(X)),1:$O(^DG(40.8,X))) Q:'X D INIT(X)
;
REV ; - Review all claims in file #399.
S IBN=0 F S IBN=$O(^DGCR(399,IBN)) Q:'IBN S IBN0=$G(^(IBN,0)) D Q:IBQ
.I IBN#100=0 S IBQ=$$STOP^IBOUTL("Billing Lag Time Report") Q:IBQ
.;
.I $P($G(^PRCA(430,IBN,0)),U,2)'=9 Q ; Not an RI claim.
.I $P(IBN0,U,13)<3 Q ; Not authorized.
.I $P(IBN0,U,13)=7 Q ; Cancelled in IB.
.S X=$P($G(^PRCA(430,IBN,0)),U,8) I X=26!(X=39) Q ; Cancelled in AR.
.;
.; - Does claim meet report criteria?
.S IBAUTH=$$AUTH(IBN) I 'IBAUTH Q
.;
.; - Get division, if necessary.
.I 'IBSORT S IBDIV=0
.E S IBDIV=$$DIV^IBJDF2(IBN) I 'IBDIV S IBDIV=+$$PRIM^VASITE()
.I IBSORT,'VAUTD,'$D(VAUTD(IBDIV)) Q ; Not a selected division.
.;
.S IBTY=$S($P(IBN0,U,5)<3:"IN",1:"OP") ; Inpatient or outpatient claim?
.;
.;- Get date PTF transmitted.
.S IBPTF="" I IBTY="IN" S IBPTF=$$PTF($P(IBN0,U,8)) Q:'IBPTF
.;
.; - Get other claim info and build date line.
.S IBDAT=$P(IBAUTH,U,2,5),DFN=+$P(IBN0,U,2),IBDFN=$G(^DPT(DFN,0))
.S IBPOL=+$G(^DPT(DFN,.312,+$P($G(^DGCR(399,IBN,"MP")),U,2),1))
.;
.; - Get care dates; quit if there are none.
.K IBDR S IBNU=$G(^DGCR(399,IBN,"U")) D
..I IBTY="IN" S X=+$P(IBNU,U,2) S:'X X=+IBNU S:X IBDR(X)="" Q
..I '$D(^DGCR(399,IBN,"OP")) D Q
...S X=+$P(IBNU,U,2) S:X IBDR(X)="" S:+IBNU&(+IBNU'=X) IBDR(+IBNU)=""
..S X=0 F S X=$O(^DGCR(399,IBN,"OP",X)) Q:'X S IBDR(X)=""
.I '$D(IBDR) Q
.;
.; - Calculate statistics for each care date.
.S IBX=0 F S IBX=$O(IBDR(IBX)) Q:'IBX D
..;
..; - Get discharge date.
..I IBTY="IN" D
...S IBX1=+$G(^DGPT(+$P(IBN0,U,8),70))\1 I IBX1 Q
...S IBX1=+$O(^DGPM("APTT3",DFN,(IBX-.0001)))\1 I 'IBX1 S IBX1=IBX
..;
..; - Get most recent check out date that has not been marked as non
..; billable by Claims Tracking; quit if there isn't one.
..I IBTY="OP" D K IBCL,IBCL1 Q:'IBCHK
...D CL(IBN) ;GET LIST OF CLINICS FOR THIS BILL
...S IBCHK=0,IBX1=IBX-.0001
...F S IBX1=$O(^SCE("ADFN",DFN,IBX1)) Q:'IBX1!((IBX1\1)>IBX) D
....S IBX2=0 F S IBX2=$O(^SCE("ADFN",DFN,IBX1,IBX2)) Q:'IBX2 D
.....;
.....;CHECK TO SEE IF CLINICS MATCH
.....S IBCL1=+$P($G(^SCE(IBX2,0)),U,4) Q:'$D(IBCL(IBCL1))
.....I $P($G(^IBT(356,+$O(^IBT(356,"ASCE",IBX2,0)),0)),U,19) Q
.....S IBX3=$P($G(^SCE(IBX2,0)),U,7)\1 I IBX3,IBX3'>$P(IBAUTH,U,2) D
...... S:IBX3>IBCHK IBCHK=IBX3 Q
..;
..S X=$S(IBTY="IN":IBX1_U_+IBPTF,1:IBX_U_IBCHK)_U_IBDAT
..S IBPOL1=$S(IBPOL>+X:1,1:0) ; Policy found after treatment.
..;
..; - Check date line for at least one date within the user specified
..; range; quit if there isn't any.
..S IBDCHK=0 F Y=2:1:6 I $$DL(0,$P(X,U,Y)) S IBDCHK=1 Q
..I 'IBDCHK Q
..;
..K D,Y,Z S IBSEL1=""
..F Y=1:1:5 S Z(1)=$P(X,U,Y),Z(2)=$P(X,U,Y+1) D
...;
...; - Check out date/PTF transmission date.
...I Y=1 D:Z(2) Q
....S D(0)=$$FMDIFF^XLFDT(Z(2),Z(1)),Z=$S(IBTY="IN":5,1:1)
....I $$DL(Z,Z(2)) S IBSEL1=IBSEL1_Z_",",Y(Z)=$S(IBRPT="D":Z(1)_U_Z(2)_U_D(0),1:D(0))
...;
...; - Date authorized.
...I Y=2 D:Z(1) Q
....S D(1)=$$FMDIFF^XLFDT(Z(2),Z(1)),Z=$S(IBTY="IN":6,1:2)
....I $$DL(Z,Z(2)) D
.....S Z1=$S(IBPOL1:Z_"I",1:Z),IBSEL1=IBSEL1_Z1_",",Y(Z1)=$S(IBRPT="D":Z(1)_U_Z(2)_U_D(1),1:D(1))
.....I Z1=Z D
......S Z2=Z_"I",IBSEL1=IBSEL1_Z2_",",Y(Z2)=$S(IBRPT="D":Z(1)_U_Z(2)_U_D(1),1:D(1))
...;
...; - Date activated.
...I Y=3 D:Z(2) Q
....S D(2)=$$FMDIFF^XLFDT(Z(2),Z(1)) I $$DL(9,Z(2)) S IBSEL1=IBSEL1_"9,",Y(9)=$S(IBRPT="D":Z(1)_U_Z(2)_U_D(2),1:D(2))
...;
...; - Payment date.
...I Y=4 D:Z(2) Q
....S D(3)=$$FMDIFF^XLFDT(Z(2),Z(1)),D(6)=$$FMDIFF^XLFDT(Z(2),+X)
....F Z=$S(IBTY="IN":7,1:3),10 I $$DL(Z,Z(2)) D
.....S Z1=$S(IBPOL1&(Z<10):Z_"I",1:Z),Z2=$S(Z<10:6,1:3)
.....S IBSEL1=IBSEL1_Z1_",",Y(Z1)=$S(IBRPT="D":$S(Z2=3:Z(1),1:+X)_U_Z(2)_U_D(Z2),1:D(Z2))
.....I Z1=Z,Z<10 S Z3=Z_"I",IBSEL1=IBSEL1_Z3_",",Y(Z3)=$S(IBRPT="D":$S(Z2=3:Z(1),1:+X)_U_Z(2)_U_D(Z2),1:D(Z2))
...;
...; - Date closed.
...I Z(2) D
....S D(4)=$$FMDIFF^XLFDT(Z(2),Z(1)),D(5)=$$FMDIFF^XLFDT(Z(2),+X)
....F Z=$S(IBTY="IN":8,1:4),11 I $$DL(Z,Z(2)) D
.....S Z1=$S(IBPOL1&(Z<11):Z_"I",1:Z),Z2=$S(Z<11:5,1:4)
.....S IBSEL1=IBSEL1_Z1_",",Y(Z1)=$S(IBRPT="D":$S(Z2=4:Z(1),1:+X)_U_Z(2)_U_D(Z2),1:D(Z2))
.....I Z1=Z,Z<11 S Z3=Z_"I",IBSEL1=IBSEL1_Z3_",",Y(Z3)=$S(IBRPT="D":$S(Z2=4:Z(1),1:+X)_U_Z(2)_U_D(Z2),1:D(Z2))
..;
..; - Save data for detail or summary report(s).
..F Y=1:1 S Z=$P(IBSEL1,",",Y) Q:'Z D
...I IBRPT="D" D
....S IBBN=$P(IBN0,U) S:IBPOL1 IBBN=IBBN_"*"
....S Y(Z)=IBBN_U_Y(Z),Y1(Z)=$G(Y1(Z))+1
....S ^TMP("IBJDB1",$J,IBDIV,IBTY,Z,$P(IBDFN,U)_"@@"_$P(IBDFN,U,9),Y1(Z))=Y(Z)
...E S IBCT(IBDIV,IBTY,Z)=IBCT(IBDIV,IBTY,Z)+1,IBTL(IBDIV,IBTY,Z)=IBTL(IBDIV,IBTY,Z)+Y(Z)
;
Q
;
INIT(X) ; - Initialize summary accumulators/detail division nodes.
I IBRPT="D" S ^TMP("IBJDB1",$J,X)="" Q
F Y=1:1:4,9,10,11,"2I","3I","4I" S (IBCT(X,"OP",Y),IBTL(X,"OP",Y))=0
F Y=5:1:11,"6I","7I","8I" S (IBCT(X,"IN",Y),IBTL(X,"IN",Y))=0
Q
;
AUTH(IBN) ; - Is this an authorized claim?
; Input: IBN=Pointer to the AR in file #430
; Output: VAL=1^2^3^4^5, where:
; 1=1-Authorized claim
; 0-Not an authorized claim
; 2=Date AR was authorized
; 3=Date AR was activated
; 4=AR first payment date
; 5=Date AR was closed
;
N IBPAY,IBT,IBT0,IBT1,VAL,X
S VAL=0 I '$G(IBN) G AUTHQ
;
; - Get date authorized (required).
S X=$P($G(^DGCR(399,IBN,"S")),U,10) G:'X AUTHQ S VAL="1^"_X
;
; - Get date activated, if available.
S X=$P($G(^PRCA(430,IBN,6)),U,21) I X S $P(VAL,U,3)=X\1 G FP
S X=$P($G(^PRCA(430,IBN,9)),U,3) I X S $P(VAL,U,3)=X\1 G FP
S X=$P($G(^PRCA(430,IBN,0)),U,10) I X S $P(VAL,U,3)=X\1
;
FP ; - Get first payment date, if available.
I '$P($G(^PRCA(430,IBN,7)),U,7) G DC ; No payments made.
S (IBPAY,IBT)=0 F S IBT=$O(^PRCA(433,"C",IBN,IBT)) Q:'IBT D Q:IBPAY
.S IBT0=$G(^PRCA(433,IBT,0)),IBT1=$G(^(1))
.I $P(IBT0,U,4)'=2 Q ; Not complete.
.I $P(IBT1,U,2)'=2,$P(IBT1,U,2)'=34 Q ; Not a payment.
.S X=$S(+IBT1:+IBT1,1:$P(IBT1,U,9)\1),$P(VAL,U,4)=X,IBPAY=1
;
DC ; - Get date AR closed.
S X=$$CLO^PRCAFN(IBN) I X>0 S $P(VAL,U,5)=X
;
; - Is there a payment date AND a closed date for this claim?
I '$P(VAL,U,4),$P(VAL,U,5) S $P(VAL,U)=0
;
AUTHQ Q VAL
;
DL(X,X1) ; - Is line item date valid for report?
; Input: X=Line item number (or 0), X1=Line item date
; Output: 1=valid, 0=invalid
; *Requires pre-defined variables IBBDT, IBEDT, and IBSEL
S X2=0 I 'X1 G DLQ
I 'X S:X1'<IBBDT&(X1'>IBEDT) X2=1 G DLQ
I IBSEL[(","_X_","),X1'<IBBDT,X1'>IBEDT S X2=1
DLQ Q X2
;
;
PTF(X) ; - Get most recent PTF transmission date.
; Input: X=IEN of PTF file entry.
; Output: Y=PTF date.
N I,K,Y
S Y=0 G:'$O(^DGP(45.83,"C",+X,0)) PTFQ
S I=0 F S I=$O(^DGP(45.83,"C",X,I)) Q:'I D
.S J=$P($G(^DGP(45.83,I,0)),U,2)\1 Q:J>$P(IBAUTH,U,2) S:J K(J)=""
S I=0 F S I=$O(K(I)) Q:'I S Y=I
;
PTFQ Q Y
;
CL(IBN) ; - Get the clinics for bill.
N I,J K IBCL ; IBCL=Bill clinic array.
S I=0 F S I=$O(^DGCR(399,IBN,"CP",I)) Q:I="" D
.S J=$P($G(^DGCR(399,IBN,"CP",I,0)),U,7) S:J IBCL(J)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDB11 7613 printed Nov 22, 2024@17:32:39 Page 2
IBJDB11 ;ALB/CPM - BILLING LAG TIME REPORT (COMPILE) ; 27-DEC-96
+1 ;;2.0;INTEGRATED BILLING;**69,100,118,165**;21-MAR-94
+2 ;
EN ; - Entry point from IBJDB1.
+1 ;
+2 ; -
+3 IF IBRPT="D"
FOR X=2,3,4,6,7,8
if IBSEL[X
SET IBSEL=IBSEL_X_"I,"
+4 IF 'IBSORT
DO INIT(0)
GOTO REV
+5 SET X=0
FOR
SET X=$SELECT('VAUTD:$ORDER(VAUTD(X)),1:$ORDER(^DG(40.8,X)))
if 'X
QUIT
DO INIT(X)
+6 ;
REV ; - Review all claims in file #399.
+1 SET IBN=0
FOR
SET IBN=$ORDER(^DGCR(399,IBN))
if 'IBN
QUIT
SET IBN0=$GET(^(IBN,0))
Begin DoDot:1
+2 IF IBN#100=0
SET IBQ=$$STOP^IBOUTL("Billing Lag Time Report")
if IBQ
QUIT
+3 ;
+4 ; Not an RI claim.
IF $PIECE($GET(^PRCA(430,IBN,0)),U,2)'=9
QUIT
+5 ; Not authorized.
IF $PIECE(IBN0,U,13)<3
QUIT
+6 ; Cancelled in IB.
IF $PIECE(IBN0,U,13)=7
QUIT
+7 ; Cancelled in AR.
SET X=$PIECE($GET(^PRCA(430,IBN,0)),U,8)
IF X=26!(X=39)
QUIT
+8 ;
+9 ; - Does claim meet report criteria?
+10 SET IBAUTH=$$AUTH(IBN)
IF 'IBAUTH
QUIT
+11 ;
+12 ; - Get division, if necessary.
+13 IF 'IBSORT
SET IBDIV=0
+14 IF '$TEST
SET IBDIV=$$DIV^IBJDF2(IBN)
IF 'IBDIV
SET IBDIV=+$$PRIM^VASITE()
+15 ; Not a selected division.
IF IBSORT
IF 'VAUTD
IF '$DATA(VAUTD(IBDIV))
QUIT
+16 ;
+17 ; Inpatient or outpatient claim?
SET IBTY=$SELECT($PIECE(IBN0,U,5)<3:"IN",1:"OP")
+18 ;
+19 ;- Get date PTF transmitted.
+20 SET IBPTF=""
IF IBTY="IN"
SET IBPTF=$$PTF($PIECE(IBN0,U,8))
if 'IBPTF
QUIT
+21 ;
+22 ; - Get other claim info and build date line.
+23 SET IBDAT=$PIECE(IBAUTH,U,2,5)
SET DFN=+$PIECE(IBN0,U,2)
SET IBDFN=$GET(^DPT(DFN,0))
+24 SET IBPOL=+$GET(^DPT(DFN,.312,+$PIECE($GET(^DGCR(399,IBN,"MP")),U,2),1))
+25 ;
+26 ; - Get care dates; quit if there are none.
+27 KILL IBDR
SET IBNU=$GET(^DGCR(399,IBN,"U"))
Begin DoDot:2
+28 IF IBTY="IN"
SET X=+$PIECE(IBNU,U,2)
if 'X
SET X=+IBNU
if X
SET IBDR(X)=""
QUIT
+29 IF '$DATA(^DGCR(399,IBN,"OP"))
Begin DoDot:3
+30 SET X=+$PIECE(IBNU,U,2)
if X
SET IBDR(X)=""
if +IBNU&(+IBNU'=X)
SET IBDR(+IBNU)=""
End DoDot:3
QUIT
+31 SET X=0
FOR
SET X=$ORDER(^DGCR(399,IBN,"OP",X))
if 'X
QUIT
SET IBDR(X)=""
End DoDot:2
+32 IF '$DATA(IBDR)
QUIT
+33 ;
+34 ; - Calculate statistics for each care date.
+35 SET IBX=0
FOR
SET IBX=$ORDER(IBDR(IBX))
if 'IBX
QUIT
Begin DoDot:2
+36 ;
+37 ; - Get discharge date.
+38 IF IBTY="IN"
Begin DoDot:3
+39 SET IBX1=+$GET(^DGPT(+$PIECE(IBN0,U,8),70))\1
IF IBX1
QUIT
+40 SET IBX1=+$ORDER(^DGPM("APTT3",DFN,(IBX-.0001)))\1
IF 'IBX1
SET IBX1=IBX
End DoDot:3
+41 ;
+42 ; - Get most recent check out date that has not been marked as non
+43 ; billable by Claims Tracking; quit if there isn't one.
+44 IF IBTY="OP"
Begin DoDot:3
+45 ;GET LIST OF CLINICS FOR THIS BILL
DO CL(IBN)
+46 SET IBCHK=0
SET IBX1=IBX-.0001
+47 FOR
SET IBX1=$ORDER(^SCE("ADFN",DFN,IBX1))
if 'IBX1!((IBX1\1)>IBX)
QUIT
Begin DoDot:4
+48 SET IBX2=0
FOR
SET IBX2=$ORDER(^SCE("ADFN",DFN,IBX1,IBX2))
if 'IBX2
QUIT
Begin DoDot:5
+49 ;
+50 ;CHECK TO SEE IF CLINICS MATCH
+51 SET IBCL1=+$PIECE($GET(^SCE(IBX2,0)),U,4)
if '$DATA(IBCL(IBCL1))
QUIT
+52 IF $PIECE($GET(^IBT(356,+$ORDER(^IBT(356,"ASCE",IBX2,0)),0)),U,19)
QUIT
+53 SET IBX3=$PIECE($GET(^SCE(IBX2,0)),U,7)\1
IF IBX3
IF IBX3'>$PIECE(IBAUTH,U,2)
Begin DoDot:6
+54 if IBX3>IBCHK
SET IBCHK=IBX3
QUIT
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
KILL IBCL,IBCL1
if 'IBCHK
QUIT
+55 ;
+56 SET X=$SELECT(IBTY="IN":IBX1_U_+IBPTF,1:IBX_U_IBCHK)_U_IBDAT
+57 ; Policy found after treatment.
SET IBPOL1=$SELECT(IBPOL>+X:1,1:0)
+58 ;
+59 ; - Check date line for at least one date within the user specified
+60 ; range; quit if there isn't any.
+61 SET IBDCHK=0
FOR Y=2:1:6
IF $$DL(0,$PIECE(X,U,Y))
SET IBDCHK=1
QUIT
+62 IF 'IBDCHK
QUIT
+63 ;
+64 KILL D,Y,Z
SET IBSEL1=""
+65 FOR Y=1:1:5
SET Z(1)=$PIECE(X,U,Y)
SET Z(2)=$PIECE(X,U,Y+1)
Begin DoDot:3
+66 ;
+67 ; - Check out date/PTF transmission date.
+68 IF Y=1
if Z(2)
Begin DoDot:4
+69 SET D(0)=$$FMDIFF^XLFDT(Z(2),Z(1))
SET Z=$SELECT(IBTY="IN":5,1:1)
+70 IF $$DL(Z,Z(2))
SET IBSEL1=IBSEL1_Z_","
SET Y(Z)=$SELECT(IBRPT="D":Z(1)_U_Z(2)_U_D(0),1:D(0))
End DoDot:4
QUIT
+71 ;
+72 ; - Date authorized.
+73 IF Y=2
if Z(1)
Begin DoDot:4
+74 SET D(1)=$$FMDIFF^XLFDT(Z(2),Z(1))
SET Z=$SELECT(IBTY="IN":6,1:2)
+75 IF $$DL(Z,Z(2))
Begin DoDot:5
+76 SET Z1=$SELECT(IBPOL1:Z_"I",1:Z)
SET IBSEL1=IBSEL1_Z1_","
SET Y(Z1)=$SELECT(IBRPT="D":Z(1)_U_Z(2)_U_D(1),1:D(1))
+77 IF Z1=Z
Begin DoDot:6
+78 SET Z2=Z_"I"
SET IBSEL1=IBSEL1_Z2_","
SET Y(Z2)=$SELECT(IBRPT="D":Z(1)_U_Z(2)_U_D(1),1:D(1))
End DoDot:6
End DoDot:5
End DoDot:4
QUIT
+79 ;
+80 ; - Date activated.
+81 IF Y=3
if Z(2)
Begin DoDot:4
+82 SET D(2)=$$FMDIFF^XLFDT(Z(2),Z(1))
IF $$DL(9,Z(2))
SET IBSEL1=IBSEL1_"9,"
SET Y(9)=$SELECT(IBRPT="D":Z(1)_U_Z(2)_U_D(2),1:D(2))
End DoDot:4
QUIT
+83 ;
+84 ; - Payment date.
+85 IF Y=4
if Z(2)
Begin DoDot:4
+86 SET D(3)=$$FMDIFF^XLFDT(Z(2),Z(1))
SET D(6)=$$FMDIFF^XLFDT(Z(2),+X)
+87 FOR Z=$SELECT(IBTY="IN":7,1:3),10
IF $$DL(Z,Z(2))
Begin DoDot:5
+88 SET Z1=$SELECT(IBPOL1&(Z<10):Z_"I",1:Z)
SET Z2=$SELECT(Z<10:6,1:3)
+89 SET IBSEL1=IBSEL1_Z1_","
SET Y(Z1)=$SELECT(IBRPT="D":$SELECT(Z2=3:Z(1),1:+X)_U_Z(2)_U_D(Z2),1:D(Z2))
+90 IF Z1=Z
IF Z<10
SET Z3=Z_"I"
SET IBSEL1=IBSEL1_Z3_","
SET Y(Z3)=$SELECT(IBRPT="D":$SELECT(Z2=3:Z(1),1:+X)_U_Z(2)_U_D(Z2),1:D(Z2))
End DoDot:5
End DoDot:4
QUIT
+91 ;
+92 ; - Date closed.
+93 IF Z(2)
Begin DoDot:4
+94 SET D(4)=$$FMDIFF^XLFDT(Z(2),Z(1))
SET D(5)=$$FMDIFF^XLFDT(Z(2),+X)
+95 FOR Z=$SELECT(IBTY="IN":8,1:4),11
IF $$DL(Z,Z(2))
Begin DoDot:5
+96 SET Z1=$SELECT(IBPOL1&(Z<11):Z_"I",1:Z)
SET Z2=$SELECT(Z<11:5,1:4)
+97 SET IBSEL1=IBSEL1_Z1_","
SET Y(Z1)=$SELECT(IBRPT="D":$SELECT(Z2=4:Z(1),1:+X)_U_Z(2)_U_D(Z2),1:D(Z2))
+98 IF Z1=Z
IF Z<11
SET Z3=Z_"I"
SET IBSEL1=IBSEL1_Z3_","
SET Y(Z3)=$SELECT(IBRPT="D":$SELECT(Z2=4:Z(1),1:+X)_U_Z(2)_U_D(Z2),1:D(Z2))
End DoDot:5
End DoDot:4
End DoDot:3
+99 ;
+100 ; - Save data for detail or summary report(s).
+101 FOR Y=1:1
SET Z=$PIECE(IBSEL1,",",Y)
if 'Z
QUIT
Begin DoDot:3
+102 IF IBRPT="D"
Begin DoDot:4
+103 SET IBBN=$PIECE(IBN0,U)
if IBPOL1
SET IBBN=IBBN_"*"
+104 SET Y(Z)=IBBN_U_Y(Z)
SET Y1(Z)=$GET(Y1(Z))+1
+105 SET ^TMP("IBJDB1",$JOB,IBDIV,IBTY,Z,$PIECE(IBDFN,U)_"@@"_$PIECE(IBDFN,U,9),Y1(Z))=Y(Z)
End DoDot:4
+106 IF '$TEST
SET IBCT(IBDIV,IBTY,Z)=IBCT(IBDIV,IBTY,Z)+1
SET IBTL(IBDIV,IBTY,Z)=IBTL(IBDIV,IBTY,Z)+Y(Z)
End DoDot:3
End DoDot:2
End DoDot:1
if IBQ
QUIT
+107 ;
+108 QUIT
+109 ;
INIT(X) ; - Initialize summary accumulators/detail division nodes.
+1 IF IBRPT="D"
SET ^TMP("IBJDB1",$JOB,X)=""
QUIT
+2 FOR Y=1:1:4,9,10,11,"2I","3I","4I"
SET (IBCT(X,"OP",Y),IBTL(X,"OP",Y))=0
+3 FOR Y=5:1:11,"6I","7I","8I"
SET (IBCT(X,"IN",Y),IBTL(X,"IN",Y))=0
+4 QUIT
+5 ;
AUTH(IBN) ; - Is this an authorized claim?
+1 ; Input: IBN=Pointer to the AR in file #430
+2 ; Output: VAL=1^2^3^4^5, where:
+3 ; 1=1-Authorized claim
+4 ; 0-Not an authorized claim
+5 ; 2=Date AR was authorized
+6 ; 3=Date AR was activated
+7 ; 4=AR first payment date
+8 ; 5=Date AR was closed
+9 ;
+10 NEW IBPAY,IBT,IBT0,IBT1,VAL,X
+11 SET VAL=0
IF '$GET(IBN)
GOTO AUTHQ
+12 ;
+13 ; - Get date authorized (required).
+14 SET X=$PIECE($GET(^DGCR(399,IBN,"S")),U,10)
if 'X
GOTO AUTHQ
SET VAL="1^"_X
+15 ;
+16 ; - Get date activated, if available.
+17 SET X=$PIECE($GET(^PRCA(430,IBN,6)),U,21)
IF X
SET $PIECE(VAL,U,3)=X\1
GOTO FP
+18 SET X=$PIECE($GET(^PRCA(430,IBN,9)),U,3)
IF X
SET $PIECE(VAL,U,3)=X\1
GOTO FP
+19 SET X=$PIECE($GET(^PRCA(430,IBN,0)),U,10)
IF X
SET $PIECE(VAL,U,3)=X\1
+20 ;
FP ; - Get first payment date, if available.
+1 ; No payments made.
IF '$PIECE($GET(^PRCA(430,IBN,7)),U,7)
GOTO DC
+2 SET (IBPAY,IBT)=0
FOR
SET IBT=$ORDER(^PRCA(433,"C",IBN,IBT))
if 'IBT
QUIT
Begin DoDot:1
+3 SET IBT0=$GET(^PRCA(433,IBT,0))
SET IBT1=$GET(^(1))
+4 ; Not complete.
IF $PIECE(IBT0,U,4)'=2
QUIT
+5 ; Not a payment.
IF $PIECE(IBT1,U,2)'=2
IF $PIECE(IBT1,U,2)'=34
QUIT
+6 SET X=$SELECT(+IBT1:+IBT1,1:$PIECE(IBT1,U,9)\1)
SET $PIECE(VAL,U,4)=X
SET IBPAY=1
End DoDot:1
if IBPAY
QUIT
+7 ;
DC ; - Get date AR closed.
+1 SET X=$$CLO^PRCAFN(IBN)
IF X>0
SET $PIECE(VAL,U,5)=X
+2 ;
+3 ; - Is there a payment date AND a closed date for this claim?
+4 IF '$PIECE(VAL,U,4)
IF $PIECE(VAL,U,5)
SET $PIECE(VAL,U)=0
+5 ;
AUTHQ QUIT VAL
+1 ;
DL(X,X1) ; - Is line item date valid for report?
+1 ; Input: X=Line item number (or 0), X1=Line item date
+2 ; Output: 1=valid, 0=invalid
+3 ; *Requires pre-defined variables IBBDT, IBEDT, and IBSEL
+4 SET X2=0
IF 'X1
GOTO DLQ
+5 IF 'X
if X1'<IBBDT&(X1'>IBEDT)
SET X2=1
GOTO DLQ
+6 IF IBSEL[(","_X_",")
IF X1'<IBBDT
IF X1'>IBEDT
SET X2=1
DLQ QUIT X2
+1 ;
+2 ;
PTF(X) ; - Get most recent PTF transmission date.
+1 ; Input: X=IEN of PTF file entry.
+2 ; Output: Y=PTF date.
+3 NEW I,K,Y
+4 SET Y=0
if '$ORDER(^DGP(45.83,"C",+X,0))
GOTO PTFQ
+5 SET I=0
FOR
SET I=$ORDER(^DGP(45.83,"C",X,I))
if 'I
QUIT
Begin DoDot:1
+6 SET J=$PIECE($GET(^DGP(45.83,I,0)),U,2)\1
if J>$PIECE(IBAUTH,U,2)
QUIT
if J
SET K(J)=""
End DoDot:1
+7 SET I=0
FOR
SET I=$ORDER(K(I))
if 'I
QUIT
SET Y=I
+8 ;
PTFQ QUIT Y
+1 ;
CL(IBN) ; - Get the clinics for bill.
+1 ; IBCL=Bill clinic array.
NEW I,J
KILL IBCL
+2 SET I=0
FOR
SET I=$ORDER(^DGCR(399,IBN,"CP",I))
if I=""
QUIT
Begin DoDot:1
+3 SET J=$PIECE($GET(^DGCR(399,IBN,"CP",I,0)),U,7)
if J
SET IBCL(J)=""
End DoDot:1
+4 QUIT
