IBR ;ALB/AAS - INTEGRATED BILLING - A/R INTERFACE ;25-FEB-91
V ;;2.0;INTEGRATED BILLING;**52,70,93,113,132,51**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; - handles calls to AR
; - input IBSEQNO = 1,2, or 3
; - IBDUZ = user causing entry
; - IBNOS = IBnumber^Ibnumber... to process
; - DFN = patient number
; - output Y = 1 if successful
; - =-1^error code if unsuccessful
S IBERR=""
I '$D(IBSEQNO) S IBERR="IB017;"_IBERR G END
D @IBSEQNO
G END
;
1 ; -pass new entries to a/r
S IBTOTL=0 N IBNOW
F I=1:1 S IBN=$P(IBNOS,"^",I) Q:'IBN S X=$S($D(^IB(IBN,0)):^(0),1:"") S:X="" IBERR="IB018;"_IBERR D TRCHK S IBTOTL=IBTOTL+$P(X,"^",7)
Q:IBNOS=""!(IBTOTL<1)
S IBSERV="",IBATYP=$P(X,"^",3) I $D(^IBE(350.1,+IBATYP,0)) S IBSERV=$P(^(0),"^",4)
D ARPARM^IBAUTL
S IBWHER=3
D BILLNO^IBAUTL I +Y<1 G ERR
S IBWHER=4
;
F I=1:1 S IBN=$P(IBNOS,"^",I) Q:'IBN D UP1,UP3:IBSEQNO=3
Q
UP1 ; -update IB data and reindex
N DIERR
S FDA(350,IBN_",",.05)=$S(IBERR="":3,1:9)
S FDA(350,IBN_",",.11)=IBIL
S FDA(350,IBN_",",.12)=IBTRAN
D FILE^DIE("K","FDA")
I $G(DIERR) S IBERR="IB020;"_IBERR
;S DIE="^IB(",DA=IBN,DR=".05////"_$S(IBERR="":3,1:9)_";.11////"_IBIL_";.12////"_IBTRAN
;D ^DIE K DIE,DR,DA
;I $D(Y) S IBERR="IB020;"_IBERR
;S DA=IBN,DIK="^IB(" D IX^DIK
;K DIK,DA
Q
2 S IBTOTL=0 N IBNOW
F I=1:1 S IBN=$P(IBNOS,"^",I) Q:'IBN S X=$S($D(^IB(IBN,0)):^(0),1:"") S:X="" IBERR="IB018;"_IBERR S:$P($G(^IB(+$P(X,"^",9),0)),"^",5)'=8 IBTOTL=IBTOTL+$P(X,"^",7)
S IBIL=$P(X,"^",11)
;
S IBSERV="",IBATYP=$P(X,"^",3) I $D(^IBE(350.1,+IBATYP,0)) S IBSERV=$P(^(0),"^",4)
D ARPARM^IBAUTL
S IBWHER=3
; - piece 1 of X (21) denotes the AR Trans. Type of Decrease Adjustment
I IBTOTL>0 S X="21^"_IBTOTL_"^"_IBIL_"^"_IBDUZ_"^"_$P(IBNOW,".")_"^"_$S($D(^IBE(350.3,+$P(^IB(IBNOS,0),"^",10),0)):$P(^(0),"^",1),1:"") D ^PRCASER1 I +Y<0 G ERR
;
S IBWHER=4
F I=1:1 S IBN=$P(IBNOS,"^",I) Q:'IBN D UP2
Q
UP2 ; -update IB data and reindex
S DIE="^IB(",DA=IBN,DR=".05////"_$S(IBERR="":3,1:9)
D ^DIE K DIE,DR,DA
I $D(Y) S IBERR="IB020;"_IBERR
S DA=IBN,DIK="^IB(" D IX^DIK
;W "FILING UPDATED ENTRY IN IB",!
K DIK,DA
; -update parent to cancelled
S IBPARNT=$P(^IB(IBN,0),"^",9),IBCRES=$P(^IB(IBN,0),"^",10)
S DIE="^IB(",DA=IBPARNT,DR=".05////10;.1////"_IBCRES D ^DIE K DIE,DA,DR
Q
;
3 D 1
Q
UP3 ; -update status of all previous bills to updated
;
N IBI,IBJ
S IBJ="" F IBI=0:0 S IBJ=$O(^IB("AD",$P(^IB(IBN,0),"^",9),IBJ)) Q:'IBJ I $D(^IB(IBJ,0)),$P(^(0),"^",5)=3,IBN'=IBJ S DIE="^IB(",DA=IBJ,DR=".05////4" D ^DIE
Q
;
ERR D ^IBAERR:$D(ZTQUEUED) Q
END ;
S Y=$S(IBERR="":1,1:"-1^"_IBERR)
K IBERR Q
;
TRCHK ; - if entry has an ar transaction number take out of list
I $P(X,"^",12)!($$HOLD^IBRUTL(X,IBN,IBDUZ,IBSEQNO)) D
. I I=1 S IBNOS=$P(IBNOS,"^",2,99)
. E S IBNOS=$P(IBNOS,"^",1,I-1)_"^"_$P(IBNOS,"^",I+1,99)
. S $P(X,"^",7)=0,I=I-1
Q
;
;
AR ; Pass charges which need separate bills to Accounts Receivable.
; Variable input: DFN -- Pointer to the patient in file #2
; IBSITE -- Facility number
; IBATYP -- Pointer to the action type in file #350.1
; IBFR -- 'Bill From' Date
; IBCHG -- Charge amount
; IBN -- Pointer to the charge in file #350
; IBY -- Set to 1 to denote potential success
; IBSERV -- Pointer to the service in file #49
;
; Variable output: IBY -- Set <0 if there is an error
;
D SET,REL:IBY>0
Q
;
;
SET ; Set up stub receivable in AR.
S PRCASV("SITE")=IBSITE
S PRCASV("SER")=IBSERV
D SETUP^PRCASVC3
S:PRCASV("ARREC")<0 IBY=PRCASV("ARREC")
S:PRCASV("ARBIL")<0 IBY=PRCASV("ARBIL")
Q
;
REL ; Release the charge to AR.
S PRCASV("APR")=DUZ
S PRCASV("BDT")=DT
S PRCASV("CAT")=+$P($G(^IBE(350.1,IBATYP,0)),"^",3)
S PRCASV("DEBTOR")=DFN_";DPT("
S PRCASV("FY")=$$FY^IBOUTL(IBFR)_"^"_IBCHG
;
D ^PRCASVC6
I PRCASV("OKAY") D
.S (IBTRAN,IBERR)="",IBIL=PRCASV("ARBIL")
.D UP1
.;
.D REL^PRCASVC
;
I 'PRCASV("OKAY") D G RELQ
.W:$G(IBJOB)=4 !," >> Unable to establish this receivable in AR! Please investigate before",!," trying to re-bill this patient."
.S IBY="-1^^Unable to establish receivable in AR."
;
; - update the receivable status to Active
S PRCASV("STATUS")=16
D STATUS^PRCASVC1
;
; - update charge status
;S (IBTRAN,IBERR)="",IBIL=PRCASV("ARBIL")
;D UP1
;
RELQ K PRCASV,IBTRAN,IBIL,IBERR
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBR 4689 printed Aug 15, 2021@00:00:59 Page 2
IBR ;ALB/AAS - INTEGRATED BILLING - A/R INTERFACE ;25-FEB-91
V ;;2.0;INTEGRATED BILLING;**52,70,93,113,132,51**;21-MAR-94
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
+3 ; - handles calls to AR
+4 ; - input IBSEQNO = 1,2, or 3
+5 ; - IBDUZ = user causing entry
+6 ; - IBNOS = IBnumber^Ibnumber... to process
+7 ; - DFN = patient number
+8 ; - output Y = 1 if successful
+9 ; - =-1^error code if unsuccessful
+10 SET IBERR=""
+11 IF '$DATA(IBSEQNO)
SET IBERR="IB017;"_IBERR
GOTO END
+12 DO @IBSEQNO
+13 GOTO END
+14 ;
1 ; -pass new entries to a/r
+1 SET IBTOTL=0
NEW IBNOW
+2 FOR I=1:1
SET IBN=$PIECE(IBNOS,"^",I)
if 'IBN
QUIT
SET X=$SELECT($DATA(^IB(IBN,0)):^(0),1:"")
if X=""
SET IBERR="IB018;"_IBERR
DO TRCHK
SET IBTOTL=IBTOTL+$PIECE(X,"^",7)
+3 if IBNOS=""!(IBTOTL<1)
QUIT
+4 SET IBSERV=""
SET IBATYP=$PIECE(X,"^",3)
IF $DATA(^IBE(350.1,+IBATYP,0))
SET IBSERV=$PIECE(^(0),"^",4)
+5 DO ARPARM^IBAUTL
+6 SET IBWHER=3
+7 DO BILLNO^IBAUTL
IF +Y<1
GOTO ERR
+8 SET IBWHER=4
+9 ;
+10 FOR I=1:1
SET IBN=$PIECE(IBNOS,"^",I)
if 'IBN
QUIT
DO UP1
if IBSEQNO=3
DO UP3
+11 QUIT
UP1 ; -update IB data and reindex
+1 NEW DIERR
+2 SET FDA(350,IBN_",",.05)=$SELECT(IBERR="":3,1:9)
+3 SET FDA(350,IBN_",",.11)=IBIL
+4 SET FDA(350,IBN_",",.12)=IBTRAN
+5 DO FILE^DIE("K","FDA")
+6 IF $GET(DIERR)
SET IBERR="IB020;"_IBERR
+7 ;S DIE="^IB(",DA=IBN,DR=".05////"_$S(IBERR="":3,1:9)_";.11////"_IBIL_";.12////"_IBTRAN
+8 ;D ^DIE K DIE,DR,DA
+9 ;I $D(Y) S IBERR="IB020;"_IBERR
+10 ;S DA=IBN,DIK="^IB(" D IX^DIK
+11 ;K DIK,DA
+12 QUIT
2 SET IBTOTL=0
NEW IBNOW
+1 FOR I=1:1
SET IBN=$PIECE(IBNOS,"^",I)
if 'IBN
QUIT
SET X=$SELECT($DATA(^IB(IBN,0)):^(0),1:"")
if X=""
SET IBERR="IB018;"_IBERR
if $PIECE($GET(^IB(+$PIECE(X,"^",9),0)),"^",5)'=8
SET IBTOTL=IBTOTL+$PIECE(X,"^",7)
+2 SET IBIL=$PIECE(X,"^",11)
+3 ;
+4 SET IBSERV=""
SET IBATYP=$PIECE(X,"^",3)
IF $DATA(^IBE(350.1,+IBATYP,0))
SET IBSERV=$PIECE(^(0),"^",4)
+5 DO ARPARM^IBAUTL
+6 SET IBWHER=3
+7 ; - piece 1 of X (21) denotes the AR Trans. Type of Decrease Adjustment
+8 IF IBTOTL>0
SET X="21^"_IBTOTL_"^"_IBIL_"^"_IBDUZ_"^"_$PIECE(IBNOW,".")_"^"_$SELECT($DATA(^IBE(350.3,+$PIECE(^IB(IBNOS,0),"^",10),0)):$PIECE(^(0),"^",1),1:"")
DO ^PRCASER1
IF +Y<0
GOTO ERR
+9 ;
+10 SET IBWHER=4
+11 FOR I=1:1
SET IBN=$PIECE(IBNOS,"^",I)
if 'IBN
QUIT
DO UP2
+12 QUIT
UP2 ; -update IB data and reindex
+1 SET DIE="^IB("
SET DA=IBN
SET DR=".05////"_$SELECT(IBERR="":3,1:9)
+2 DO ^DIE
KILL DIE,DR,DA
+3 IF $DATA(Y)
SET IBERR="IB020;"_IBERR
+4 SET DA=IBN
SET DIK="^IB("
DO IX^DIK
+5 ;W "FILING UPDATED ENTRY IN IB",!
+6 KILL DIK,DA
+7 ; -update parent to cancelled
+8 SET IBPARNT=$PIECE(^IB(IBN,0),"^",9)
SET IBCRES=$PIECE(^IB(IBN,0),"^",10)
+9 SET DIE="^IB("
SET DA=IBPARNT
SET DR=".05////10;.1////"_IBCRES
DO ^DIE
KILL DIE,DA,DR
+10 QUIT
+11 ;
3 DO 1
+1 QUIT
UP3 ; -update status of all previous bills to updated
+1 ;
+2 NEW IBI,IBJ
+3 SET IBJ=""
FOR IBI=0:0
SET IBJ=$ORDER(^IB("AD",$PIECE(^IB(IBN,0),"^",9),IBJ))
if 'IBJ
QUIT
IF $DATA(^IB(IBJ,0))
IF $PIECE(^(0),"^",5)=3
IF IBN'=IBJ
SET DIE="^IB("
SET DA=IBJ
SET DR=".05////4"
DO ^DIE
+4 QUIT
+5 ;
ERR if $DATA(ZTQUEUED)
DO ^IBAERR
QUIT
END ;
+1 SET Y=$SELECT(IBERR="":1,1:"-1^"_IBERR)
+2 KILL IBERR
QUIT
+3 ;
TRCHK ; - if entry has an ar transaction number take out of list
+1 IF $PIECE(X,"^",12)!($$HOLD^IBRUTL(X,IBN,IBDUZ,IBSEQNO))
Begin DoDot:1
+2 IF I=1
SET IBNOS=$PIECE(IBNOS,"^",2,99)
+3 IF '$TEST
SET IBNOS=$PIECE(IBNOS,"^",1,I-1)_"^"_$PIECE(IBNOS,"^",I+1,99)
+4 SET $PIECE(X,"^",7)=0
SET I=I-1
End DoDot:1
+5 QUIT
+6 ;
+7 ;
AR ; Pass charges which need separate bills to Accounts Receivable.
+1 ; Variable input: DFN -- Pointer to the patient in file #2
+2 ; IBSITE -- Facility number
+3 ; IBATYP -- Pointer to the action type in file #350.1
+4 ; IBFR -- 'Bill From' Date
+5 ; IBCHG -- Charge amount
+6 ; IBN -- Pointer to the charge in file #350
+7 ; IBY -- Set to 1 to denote potential success
+8 ; IBSERV -- Pointer to the service in file #49
+9 ;
+10 ; Variable output: IBY -- Set <0 if there is an error
+11 ;
+12 DO SET
if IBY>0
DO REL
+13 QUIT
+14 ;
+15 ;
SET ; Set up stub receivable in AR.
+1 SET PRCASV("SITE")=IBSITE
+2 SET PRCASV("SER")=IBSERV
+3 DO SETUP^PRCASVC3
+4 if PRCASV("ARREC")<0
SET IBY=PRCASV("ARREC")
+5 if PRCASV("ARBIL")<0
SET IBY=PRCASV("ARBIL")
+6 QUIT
+7 ;
REL ; Release the charge to AR.
+1 SET PRCASV("APR")=DUZ
+2 SET PRCASV("BDT")=DT
+3 SET PRCASV("CAT")=+$PIECE($GET(^IBE(350.1,IBATYP,0)),"^",3)
+4 SET PRCASV("DEBTOR")=DFN_";DPT("
+5 SET PRCASV("FY")=$$FY^IBOUTL(IBFR)_"^"_IBCHG
+6 ;
+7 DO ^PRCASVC6
+8 IF PRCASV("OKAY")
Begin DoDot:1
+9 SET (IBTRAN,IBERR)=""
SET IBIL=PRCASV("ARBIL")
+10 DO UP1
+11 ;
+12 DO REL^PRCASVC
End DoDot:1
+13 ;
+14 IF 'PRCASV("OKAY")
Begin DoDot:1
+15 if $GET(IBJOB)=4
WRITE !," >> Unable to establish this receivable in AR! Please investigate before",!," trying to re-bill this patient."
+16 SET IBY="-1^^Unable to establish receivable in AR."
End DoDot:1
GOTO RELQ
+17 ;
+18 ; - update the receivable status to Active
+19 SET PRCASV("STATUS")=16
+20 DO STATUS^PRCASVC1
+21 ;
+22 ; - update charge status
+23 ;S (IBTRAN,IBERR)="",IBIL=PRCASV("ARBIL")
+24 ;D UP1
+25 ;
RELQ KILL PRCASV,IBTRAN,IBIL,IBERR
+1 QUIT
+2 ;
