IBAUTL ;ALB/AAS - INTEGRATED BILLING APPLICATION UTILITIES ; 14-FEB-91
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;
COST ; - find charges for transaction type, when only one
N IBD,IBN,IB K X1
S IBD=-(DT+.9) F S IBD=$O(^IBE(350.2,"AIVDT",DA,IBD)) Q:'IBD S IBN=0 F S IBN=$O(^IBE(350.2,"AIVDT",DA,IBD,IBN)) Q:'IBN S IB=$G(^IBE(350.2,IBN,0)) I IB]"",'$P(IB,"^",5)!($P(IB,"^",5)>DT) S X1=$P(IB,"^",4) G COSTQ
COSTQ S X1=+$G(X1)
Q
;
FY I $D(X) S IBAFY=$S($E(X,4,5)<10:$E(X,2,3),1:($E(X,2,3)+1))
Q
;
PTL ; - parent trace logic
; - input in x resulting from field from file 350
; - output in y=1 if found, -1^error message if not found
; - y(0) = zeroth node of top level
; - y(1) = zeroth node of second level
; - y(n) = zeroth node of nth level
;
K Y
S Y=1 I '+X!'($D(^DIC(+X,0,"GL"))) S Y="-1^IB004" G PTLQ
S IBAGL=^DIC(+X,0,"GL")
I '$D(@(IBAGL_$P($P(X,";",1),":",2)_",0)")) S Y="-1^IB005" G PTLQ
S Y(0)=^(0)
;
F IBJJ=2:1 S IBII=$P(X,";",IBJJ) Q:IBII="" D PTL1
PTLQ K IBAGL,IBII,IBJJ,IBMIN
Q
;
PTL1 ; - find y(n) of sublevels
S IBMIN=$P(IBII,":") I IBMIN="" S Y="-1^IB006" Q
I '$D(^(IBMIN,$P(IBII,":",2),0)) S Y="-1^IB006" Q
;I '$D(^(+IBII,$P(IBII,":",2),0)) S Y="-1^IB006" Q
S Y(IBJJ-1)=^(0)
Q
;
CHKX ; - check input x
; - piece 1 = service and exists
; - peice 2 = patient and exists
; - piece 3 = action type
; - piece 4 = user duz
S DFN=$P(X,"^",2),IBSERV=+IBSAVX
I $S('DFN:1,'$D(^DPT(DFN,0)):1,1:0) S Y="-1^IB002" G CHKXQ ;patient pointer bad
I $S('IBSERV:1,'$D(^DIC(49,IBSERV,0)):1,1:0) S Y="-1^IB003" G CHKXQ ;service pointer bad
I IBTAG=1 G CHKXQ
S IBDUZ=$P(IBSAVX,"^",4) I $S('IBDUZ:1,'$D(^VA(200,IBDUZ,0)):1,1:0) S Y="-1^IB007" G CHKXQ
I IBTAG=3 G CHKXQ
S IBATYP=$P(IBSAVX,"^",3) I $S('IBATYP:1,'$D(^IBE(350.1,IBATYP,0)):1,1:0) S Y="-1^IB008"
CHKXQ Q
;
SITE ; - calculate site from site parameters
; - output ibsite = station number
; = ibfac = pointer to institution file
I '$D(^IBE(350.9,1,0)) S Y="-1^IB016" Q
S IBFAC=$P(^IBE(350.9,1,0),"^",2),IBSITE=$S('$D(^DIC(4,IBFAC,99)):"",1:+^(99)) I IBSITE<1 S Y="-1^IB009"
Q
;
ADD ; - add new entry to ^ib
;
N %DT
L +^IB(0):10 I '$T S Y="-1^IB014" G ADDQ
S X=$P($S($D(^IB(0)):^(0),1:"^^-1"),"^",3)+1 L -^IB(0) I 'X S Y="-1^IB015" G ADDQ
K DD,DO,DIC,DR S DIC="^IB(",DIC(0)="L",DLAYGO=350
F X=X:1 L:$D(IBN1) -^IB(IBN1) I X>0,'$D(^IB(X)) S IBN1=X L +^IB(IBN1):1 I $T,'$D(^IB(X)) S DINUM=X,X=+IBSITE_X D FILE^DICN I +Y>0 Q
S IBN=+Y,DIE="^IB(",DA=IBN,DR=".02////"_$S($D(DFN):DFN,1:"")_";.03////"_$S($D(IBATYP):IBATYP,1:"")_";.05////1;12///NOW" D ^DIE K DA,DR,DIE
L -^IB(IBN1)
S Y=$S('$D(Y):1,1:"-1^IB028")
;
ADDQ K DO,DD,DINUM,DIC,IBN1 Q
;
ARPARM N X S X=DT
D SITE,FY,NOW^%DTC S IBNOW=%
Q
BILLNO ; -get open bill number
I '$G(IBTOTL),+$G(^PS(59.7,1,49.99))'<6 S (IBIL,IBTRAN)="" G BILLQ
S IBARTYP=$S($D(^IBE(350.1,+IBATYP,0)):$P(^(0),"^",3),1:"")
S X=IBSITE_"^"_IBSERV_"^"_IBARTYP_"^"_DFN_";DPT("_"^"_IBAFY_"^"_$S($D(IBTOTL):IBTOTL,1:0)_"^"_$S($D(IBDUZ):IBDUZ,$D(DUZ):DUZ,1:0)_"^"_$P(IBNOW,".",1) D ^PRCASER I +Y<1 G BILLQ
S IBIL=$P(Y,"^",2),IBTRAN=$P(Y,"^",3) I IBIL="" S Y="-1^IB011" G BILLQ
S IBTRAN=$S(IBTRAN>0:IBTRAN,1:"")
BILLQ Q
IBAUTL ;ALB/AAS - INTEGRATED BILLING APPLICATION UTILITIES ; 14-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 ;
COST ; - find charges for transaction type, when only one
+1 NEW IBD,IBN,IB
KILL X1
+2 SET IBD=-(DT+.9)
FOR
SET IBD=$ORDER(^IBE(350.2,"AIVDT",DA,IBD))
IF 'IBD
QUIT
SET IBN=0
FOR
SET IBN=$ORDER(^IBE(350.2,"AIVDT",DA,IBD,IBN))
IF 'IBN
QUIT
SET IB=$GET(^IBE(350.2,IBN,0))
IF IB]""
IF '$PIECE(IB,"^",5)!($PIECE(IB,"^",5)>DT)
SET X1=$PIECE(IB,"^",4)
GOTO COSTQ
COSTQ SET X1=+$GET(X1)
+1 QUIT
+2 ;
FY IF $DATA(X)
SET IBAFY=$SELECT($EXTRACT(X,4,5)<10:$EXTRACT(X,2,3),1:($EXTRACT(X,2,3)+1))
+1 QUIT
+2 ;
PTL ; - parent trace logic
+1 ; - input in x resulting from field from file 350
+2 ; - output in y=1 if found, -1^error message if not found
+3 ; - y(0) = zeroth node of top level
+4 ; - y(1) = zeroth node of second level
+5 ; - y(n) = zeroth node of nth level
+6 ;
+7 KILL Y
+8 SET Y=1
IF '+X!'($DATA(^DIC(+X,0,"GL")))
SET Y="-1^IB004"
GOTO PTLQ
+9 SET IBAGL=^DIC(+X,0,"GL")
+10 IF '$DATA(@(IBAGL_$PIECE($PIECE(X,";",1),":",2)_",0)"))
SET Y="-1^IB005"
GOTO PTLQ
+11 SET Y(0)=^(0)
+12 ;
+13 FOR IBJJ=2:1
SET IBII=$PIECE(X,";",IBJJ)
IF IBII=""
QUIT
DO PTL1
PTLQ KILL IBAGL,IBII,IBJJ,IBMIN
+1 QUIT
+2 ;
PTL1 ; - find y(n) of sublevels
+1 SET IBMIN=$PIECE(IBII,":")
IF IBMIN=""
SET Y="-1^IB006"
QUIT
+2 IF '$DATA(^(IBMIN,$PIECE(IBII,":",2),0))
SET Y="-1^IB006"
QUIT
+3 ;I '$D(^(+IBII,$P(IBII,":",2),0)) S Y="-1^IB006" Q
+4 SET Y(IBJJ-1)=^(0)
+5 QUIT
+6 ;
CHKX ; - check input x
+1 ; - piece 1 = service and exists
+2 ; - peice 2 = patient and exists
+3 ; - piece 3 = action type
+4 ; - piece 4 = user duz
+5 SET DFN=$PIECE(X,"^",2)
SET IBSERV=+IBSAVX
+6 ;patient pointer bad
IF $SELECT('DFN:1,'$DATA(^DPT(DFN,0)):1,1:0)
SET Y="-1^IB002"
GOTO CHKXQ
+7 ;service pointer bad
IF $SELECT('IBSERV:1,'$DATA(^DIC(49,IBSERV,0)):1,1:0)
SET Y="-1^IB003"
GOTO CHKXQ
+8 IF IBTAG=1
GOTO CHKXQ
+9 SET IBDUZ=$PIECE(IBSAVX,"^",4)
IF $SELECT('IBDUZ:1,'$DATA(^VA(200,IBDUZ,0)):1,1:0)
SET Y="-1^IB007"
GOTO CHKXQ
+10 IF IBTAG=3
GOTO CHKXQ
+11 SET IBATYP=$PIECE(IBSAVX,"^",3)
IF $SELECT('IBATYP:1,'$DATA(^IBE(350.1,IBATYP,0)):1,1:0)
SET Y="-1^IB008"
CHKXQ QUIT
+1 ;
SITE ; - calculate site from site parameters
+1 ; - output ibsite = station number
+2 ; = ibfac = pointer to institution file
+3 IF '$DATA(^IBE(350.9,1,0))
SET Y="-1^IB016"
QUIT
+4 SET IBFAC=$PIECE(^IBE(350.9,1,0),"^",2)
SET IBSITE=$SELECT('$DATA(^DIC(4,IBFAC,99)):"",1:+^(99))
IF IBSITE<1
SET Y="-1^IB009"
+5 QUIT
+6 ;
ADD ; - add new entry to ^ib
+1 ;
+2 NEW %DT
+3 LOCK +^IB(0):10
IF '$TEST
SET Y="-1^IB014"
GOTO ADDQ
+4 SET X=$PIECE($SELECT($DATA(^IB(0)):^(0),1:"^^-1"),"^",3)+1
LOCK -^IB(0)
IF 'X
SET Y="-1^IB015"
GOTO ADDQ
+5 KILL DD,DO,DIC,DR
SET DIC="^IB("
SET DIC(0)="L"
SET DLAYGO=350
+6 FOR X=X:1
IF $DATA(IBN1)
LOCK -^IB(IBN1)
IF X>0
IF '$DATA(^IB(X))
SET IBN1=X
LOCK +^IB(IBN1):1
IF $TEST
IF '$DATA(^IB(X))
SET DINUM=X
SET X=+IBSITE_X
DO FILE^DICN
IF +Y>0
QUIT
+7 SET IBN=+Y
SET DIE="^IB("
SET DA=IBN
SET DR=".02////"_$SELECT($DATA(DFN):DFN,1:"")_";.03////"_$SELECT($DATA(IBATYP):IBATYP,1:"")_";.05////1;12///NOW"
DO ^DIE
KILL DA,DR,DIE
+8 LOCK -^IB(IBN1)
+9 SET Y=$SELECT('$DATA(Y):1,1:"-1^IB028")
+10 ;
ADDQ KILL DO,DD,DINUM,DIC,IBN1
QUIT
+1 ;
ARPARM NEW X
SET X=DT
+1 DO SITE
DO FY
DO NOW^%DTC
SET IBNOW=%
+2 QUIT
BILLNO ; -get open bill number
+1 IF '$GET(IBTOTL)
IF +$GET(^PS(59.7,1,49.99))'<6
SET (IBIL,IBTRAN)=""
GOTO BILLQ
+2 SET IBARTYP=$SELECT($DATA(^IBE(350.1,+IBATYP,0)):$PIECE(^(0),"^",3),1:"")
+3 SET X=IBSITE_"^"_IBSERV_"^"_IBARTYP_"^"_DFN_";DPT("_"^"_IBAFY_"^"_$SELECT($DATA(IBTOTL):IBTOTL,1:0)_"^"_$SELECT($DATA(IBDUZ):IBDUZ,$DATA(DUZ):DUZ,1:0)_"^"_$PIECE(IBNOW,".",1)
DO ^PRCASER
IF +Y<1
GOTO BILLQ
+4 SET IBIL=$PIECE(Y,"^",2)
SET IBTRAN=$PIECE(Y,"^",3)
IF IBIL=""
SET Y="-1^IB011"
GOTO BILLQ
+5 SET IBTRAN=$SELECT(IBTRAN>0:IBTRAN,1:"")
BILLQ QUIT
