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. 	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
  1. 	;;Per VHA Directive 10-93-142, 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
  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. 	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. 	S DIE="^IB(",DA=IBN,DR=".05////"_$S(IBERR="":3,1:9)_";.11////"_IBIL_";.12////"_IBTRAN
  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. 	K DIK,DA
  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. 	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. 	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. 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