- 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 Feb 18, 2025@23:53:10 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 ;