IBR ;ALB/AAS - INTEGRATED BILLING - A/R INTERFACE ; 25-FEB-91
;;Version 2.0 ; INTEGRATED BILLING ;; 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
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
;
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
IBR ;ALB/AAS - INTEGRATED BILLING - A/R INTERFACE ; 25-FEB-91
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; - handles calls to AR
+5 ; - input IBSEQNO = 1,2, or 3
+6 ; - IBDUZ = user causing entry
+7 ; - IBNOS = IBnumber^Ibnumber... to process
+8 ; - DFN = patient number
+9 ; - output Y = 1 if successful
+10 ; - =-1^error code if unsuccessful
+11 SET IBERR=""
+12 IF '$DATA(IBSEQNO)
SET IBERR="IB017;"_IBERR
GOTO END
+13 DO @IBSEQNO
+14 GOTO END
+15 ;
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 SET DIE="^IB("
SET DA=IBN
SET DR=".05////"_$SELECT(IBERR="":3,1:9)_";.11////"_IBIL_";.12////"_IBTRAN
+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 KILL DIK,DA
+6 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 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
+3 QUIT
+4 ;
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
