IBR ;ALB/AAS - INTEGRATED BILLING - A/R INTERFACE ;25-FEB-91
V ;;2.0;INTEGRATED BILLING;**52,70,93,113,132,51,715,630**;21-MAR-94;Build 39
;;Per VA Directive 6402, 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,IBN ;IB*630 RTW add IBN to the new.
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
;
; The following checks determine if there are Duplicate Copay charges for a Patient/Date. (Beginning of IB*2.0*630 updates)
N IBEXCOPAY,IBAT
S IBEXCOPAY=""
F I=1:1 S IBN=$P(IBNOS,"^",I) Q:'IBN D
. ; Load the ACTION TYPE (#.03)
. S IBAT=$P($G(^IB(IBN,0)),U,3)
. ; Quit if the ACTION TYPE is not a Copay
. I "^51^74^136^203^45^48^133^130^16^17^18^19^20^21^22^23^24^^89^92^95^105^108^"'[("^"_IBAT_"^") Q
. ; Run Duplicate Copay checks & store related info in ^XTMP("IB TRANS"
. S IBEXCOPAY=$$COPAYCHK^IBAUTL8(DFN,IBN,0)
; End of IB*2.0*630 updates
;
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,FDA
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
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
N IBPARNT,IBCRES
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
;
UP4(IBN,IBIL) ; update field 350/.11 and "ABIL" xref IB*2.0*715
;
; IBN - file 350 ien
; IBIL - AR bill #
;
N FDA
S FDA(350,IBN_",",.11)=IBIL
L +^IB(IBN):5 I '$T Q
D FILE^DIE("","FDA")
L -^IB(IBN)
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 UP4($G(IBN),PRCASV("ARBIL")),REL^PRCASVC S IBERR="",IBIL=PRCASV("ARBIL"),IBTRAN=$G(PRCASV("IBTRAN")) D UP1 ; IB*2.0*715
;
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
;
RELQ K PRCASV,IBTRAN,IBIL,IBERR
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBR 5332 printed Apr 09, 2024@21:10:22 Page 2
IBR ;ALB/AAS - INTEGRATED BILLING - A/R INTERFACE ;25-FEB-91
V ;;2.0;INTEGRATED BILLING;**52,70,93,113,132,51,715,630**;21-MAR-94;Build 39
+1 ;;Per VA Directive 6402, 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 ;IB*630 RTW add IBN to the new.
SET IBTOTL=0
NEW IBNOW,IBN
+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 ; The following checks determine if there are Duplicate Copay charges for a Patient/Date. (Beginning of IB*2.0*630 updates)
+11 NEW IBEXCOPAY,IBAT
+12 SET IBEXCOPAY=""
+13 FOR I=1:1
SET IBN=$PIECE(IBNOS,"^",I)
if 'IBN
QUIT
Begin DoDot:1
+14 ; Load the ACTION TYPE (#.03)
+15 SET IBAT=$PIECE($GET(^IB(IBN,0)),U,3)
+16 ; Quit if the ACTION TYPE is not a Copay
+17 IF "^51^74^136^203^45^48^133^130^16^17^18^19^20^21^22^23^24^^89^92^95^105^108^"'[("^"_IBAT_"^")
QUIT
+18 ; Run Duplicate Copay checks & store related info in ^XTMP("IB TRANS"
+19 SET IBEXCOPAY=$$COPAYCHK^IBAUTL8(DFN,IBN,0)
End DoDot:1
+20 ; End of IB*2.0*630 updates
+21 ;
+22 FOR I=1:1
SET IBN=$PIECE(IBNOS,"^",I)
if 'IBN
QUIT
DO UP1
if IBSEQNO=3
DO UP3
+23 QUIT
UP1 ; -update IB data and reindex
+1 NEW DIERR,FDA
+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 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 NEW IBPARNT,IBCRES
+2 SET DIE="^IB("
SET DA=IBN
SET DR=".05////"_$SELECT(IBERR="":3,1:9)
+3 DO ^DIE
KILL DIE,DR,DA
+4 IF $DATA(Y)
SET IBERR="IB020;"_IBERR
+5 SET DA=IBN
SET DIK="^IB("
DO IX^DIK
+6 ;W "FILING UPDATED ENTRY IN IB",!
+7 KILL DIK,DA
+8 ; -update parent to cancelled
+9 SET IBPARNT=$PIECE(^IB(IBN,0),"^",9)
SET IBCRES=$PIECE(^IB(IBN,0),"^",10)
+10 SET DIE="^IB("
SET DA=IBPARNT
SET DR=".05////10;.1////"_IBCRES
DO ^DIE
KILL DIE,DA,DR
+11 QUIT
+12 ;
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 ;
UP4(IBN,IBIL) ; update field 350/.11 and "ABIL" xref IB*2.0*715
+1 ;
+2 ; IBN - file 350 ien
+3 ; IBIL - AR bill #
+4 ;
+5 NEW FDA
+6 SET FDA(350,IBN_",",.11)=IBIL
+7 LOCK +^IB(IBN):5
IF '$TEST
QUIT
+8 DO FILE^DIE("","FDA")
+9 LOCK -^IB(IBN)
+10 QUIT
+11 ;
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 ; IB*2.0*715
IF PRCASV("OKAY")
DO UP4($GET(IBN),PRCASV("ARBIL"))
DO REL^PRCASVC
SET IBERR=""
SET IBIL=PRCASV("ARBIL")
SET IBTRAN=$GET(PRCASV("IBTRAN"))
DO UP1
+9 ;
+10 IF 'PRCASV("OKAY")
Begin DoDot:1
+11 if $GET(IBJOB)=4
WRITE !," >> Unable to establish this receivable in AR! Please investigate before",!," trying to re-bill this patient."
+12 SET IBY="-1^^Unable to establish receivable in AR."
End DoDot:1
GOTO RELQ
+13 ;
+14 ; - update the receivable status to Active
+15 SET PRCASV("STATUS")=16
+16 DO STATUS^PRCASVC1
+17 ;
RELQ KILL PRCASV,IBTRAN,IBIL,IBERR
+1 QUIT
+2 ;
