Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBR

IBR.m

Go to the documentation of this file.
  1. IBR ;ALB/AAS - INTEGRATED BILLING - A/R INTERFACE ;25-FEB-91
  1. 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.
  1. ;
  1. ; - handles calls to AR
  1. ; - input IBSEQNO = 1,2, or 3
  1. ; - IBDUZ = user causing entry
  1. ; - IBNOS = IBnumber^Ibnumber... to process
  1. ; - DFN = patient number
  1. ; - output Y = 1 if successful
  1. ; - =-1^error code if unsuccessful
  1. S IBERR=""
  1. I '$D(IBSEQNO) S IBERR="IB017;"_IBERR G END
  1. D @IBSEQNO
  1. G END
  1. ;
  1. 1 ; -pass new entries to a/r
  1. S IBTOTL=0 N IBNOW,IBN ;IB*630 RTW add IBN to the new.
  1. 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)
  1. Q:IBNOS=""!(IBTOTL<1)
  1. S IBSERV="",IBATYP=$P(X,"^",3) I $D(^IBE(350.1,+IBATYP,0)) S IBSERV=$P(^(0),"^",4)
  1. D ARPARM^IBAUTL
  1. S IBWHER=3
  1. D BILLNO^IBAUTL I +Y<1 G ERR
  1. S IBWHER=4
  1. ;
  1. ; The following checks determine if there are Duplicate Copay charges for a Patient/Date. (Beginning of IB*2.0*630 updates)
  1. N IBEXCOPAY,IBAT
  1. S IBEXCOPAY=""
  1. F I=1:1 S IBN=$P(IBNOS,"^",I) Q:'IBN D
  1. . ; Load the ACTION TYPE (#.03)
  1. . S IBAT=$P($G(^IB(IBN,0)),U,3)
  1. . ; Quit if the ACTION TYPE is not a Copay
  1. . 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
  1. . ; Run Duplicate Copay checks & store related info in ^XTMP("IB TRANS"
  1. . S IBEXCOPAY=$$COPAYCHK^IBAUTL8(DFN,IBN,0)
  1. ; End of IB*2.0*630 updates
  1. ;
  1. F I=1:1 S IBN=$P(IBNOS,"^",I) Q:'IBN D UP1,UP3:IBSEQNO=3
  1. Q
  1. UP1 ; -update IB data and reindex
  1. N DIERR,FDA
  1. S FDA(350,IBN_",",.05)=$S(IBERR="":3,1:9)
  1. S FDA(350,IBN_",",.11)=IBIL
  1. S FDA(350,IBN_",",.12)=IBTRAN
  1. D FILE^DIE("K","FDA")
  1. I $G(DIERR) S IBERR="IB020;"_IBERR
  1. Q
  1. 2 S IBTOTL=0 N IBNOW
  1. 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)
  1. S IBIL=$P(X,"^",11)
  1. ;
  1. S IBSERV="",IBATYP=$P(X,"^",3) I $D(^IBE(350.1,+IBATYP,0)) S IBSERV=$P(^(0),"^",4)
  1. D ARPARM^IBAUTL
  1. S IBWHER=3
  1. ; - piece 1 of X (21) denotes the AR Trans. Type of Decrease Adjustment
  1. 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
  1. ;
  1. S IBWHER=4
  1. F I=1:1 S IBN=$P(IBNOS,"^",I) Q:'IBN D UP2
  1. Q
  1. UP2 ; -update IB data and reindex
  1. N IBPARNT,IBCRES
  1. S DIE="^IB(",DA=IBN,DR=".05////"_$S(IBERR="":3,1:9)
  1. D ^DIE K DIE,DR,DA
  1. I $D(Y) S IBERR="IB020;"_IBERR
  1. S DA=IBN,DIK="^IB(" D IX^DIK
  1. ;W "FILING UPDATED ENTRY IN IB",!
  1. K DIK,DA
  1. ; -update parent to cancelled
  1. S IBPARNT=$P(^IB(IBN,0),"^",9),IBCRES=$P(^IB(IBN,0),"^",10)
  1. S DIE="^IB(",DA=IBPARNT,DR=".05////10;.1////"_IBCRES D ^DIE K DIE,DA,DR
  1. Q
  1. ;
  1. 3 D 1
  1. Q
  1. UP3 ; -update status of all previous bills to updated
  1. ;
  1. N IBI,IBJ
  1. 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
  1. Q
  1. ;
  1. UP4(IBN,IBIL) ; update field 350/.11 and "ABIL" xref IB*2.0*715
  1. ;
  1. ; IBN - file 350 ien
  1. ; IBIL - AR bill #
  1. ;
  1. N FDA
  1. S FDA(350,IBN_",",.11)=IBIL
  1. L +^IB(IBN):5 I '$T Q
  1. D FILE^DIE("","FDA")
  1. L -^IB(IBN)
  1. Q
  1. ;
  1. ERR D ^IBAERR:$D(ZTQUEUED) Q
  1. END ;
  1. S Y=$S(IBERR="":1,1:"-1^"_IBERR)
  1. K IBERR Q
  1. ;
  1. TRCHK ; - if entry has an ar transaction number take out of list
  1. I $P(X,"^",12)!($$HOLD^IBRUTL(X,IBN,IBDUZ,IBSEQNO)) D
  1. . I I=1 S IBNOS=$P(IBNOS,"^",2,99)
  1. . E S IBNOS=$P(IBNOS,"^",1,I-1)_"^"_$P(IBNOS,"^",I+1,99)
  1. . S $P(X,"^",7)=0,I=I-1
  1. Q
  1. ;
  1. ;
  1. AR ; Pass charges which need separate bills to Accounts Receivable.
  1. ; Variable input: DFN -- Pointer to the patient in file #2
  1. ; IBSITE -- Facility number
  1. ; IBATYP -- Pointer to the action type in file #350.1
  1. ; IBFR -- 'Bill From' Date
  1. ; IBCHG -- Charge amount
  1. ; IBN -- Pointer to the charge in file #350
  1. ; IBY -- Set to 1 to denote potential success
  1. ; IBSERV -- Pointer to the service in file #49
  1. ;
  1. ; Variable output: IBY -- Set <0 if there is an error
  1. ;
  1. D SET,REL:IBY>0
  1. Q
  1. ;
  1. ;
  1. SET ; Set up stub receivable in AR.
  1. S PRCASV("SITE")=IBSITE
  1. S PRCASV("SER")=IBSERV
  1. D SETUP^PRCASVC3
  1. S:PRCASV("ARREC")<0 IBY=PRCASV("ARREC")
  1. S:PRCASV("ARBIL")<0 IBY=PRCASV("ARBIL")
  1. Q
  1. ;
  1. REL ; Release the charge to AR.
  1. S PRCASV("APR")=DUZ
  1. S PRCASV("BDT")=DT
  1. S PRCASV("CAT")=+$P($G(^IBE(350.1,IBATYP,0)),"^",3)
  1. S PRCASV("DEBTOR")=DFN_";DPT("
  1. S PRCASV("FY")=$$FY^IBOUTL(IBFR)_"^"_IBCHG
  1. ;
  1. D ^PRCASVC6
  1. 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
  1. ;
  1. I 'PRCASV("OKAY") D G RELQ
  1. .W:$G(IBJOB)=4 !," >> Unable to establish this receivable in AR! Please investigate before",!," trying to re-bill this patient."
  1. .S IBY="-1^^Unable to establish receivable in AR."
  1. ;
  1. ; - update the receivable status to Active
  1. S PRCASV("STATUS")=16
  1. D STATUS^PRCASVC1
  1. ;
  1. RELQ K PRCASV,IBTRAN,IBIL,IBERR
  1. Q
  1. ;