IBCB ;ALB/MRL - BILLING BEGINNING POINT/SELECT BILL OR PATIENT ;01 JUN 88 12:00
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;MAP TO DGCRB
;
EN ;
D HOME^%ZIS Q:'$D(IBAC)
;***
;I $D(XRT0) S:'$D(XRTN) XRTN="IBCB" D T1^%ZOSV ;stop rt clock
;S XRTL=$ZU(0),XRTN="IBCB-"_$G(IBAC) D T0^%ZOSV ;start rt clock
;
S:'$D(IBV) IBV=1 L K ^UTILITY($J),DFN,IBIFN,DIC S DIC(0)="EQMZ" R !!,"Enter BILL NUMBER or PATIENT NAME: ",IBX:DTIME I IBX["^"!(IBX="") S IBAC1=0 Q
S IBAC1=1
I IBX?1A4N!(IBX?2.A)!(IBX?2.A1",".AP)!(IBX?1A1P.AP) S DIC="^DPT(",X=IBX D ^DIC G EN:Y'>0 S DFN=+Y D HINQ S X=$S('$D(^DGCR(399,"C",DFN)):1,'$D(^DGCR(399,"AOP",DFN)):2,1:0)
I $D(DFN),X,IBAC<4 W !!,"No ",$S(X=1:"",1:"OPEN "),"billing records on file for this patient." D ASK I '$D(IBIFN) G EN
I $D(DFN) D DATE:'$D(IBIFN),ASK:'$D(IBIFN) D ST:$D(IBIFN) G EN
S DIC("S")=$S(IBAC'=4:"I $P(^(0),""^"",13)<3",1:"I $P(^(""S""),""^"",17)="""""),DIC="^DGCR(399,",X=IBX
D ^DIC G:Y'>0 EN S IBIFN=+Y,DFN=$P(Y(0),"^",2) D HINQ,ST G EN
G EN
HINQ I $S('$D(^DPT(DFN,.361)):1,$P(^(.361),"^",1)'="V":1,1:0) W !?17,"*** ELIGIBILITY NOT VERIFIED ***" D HINQ1
MT ;I $D(DFN) D ^DGMT1 K DGMTLL
I $D(DFN) D DIS^DGMTU(DFN)
Q
HINQ1 I $P($G(^IBE(350.9,1,1)),"^",16) S X="DVBHQZ4" X ^%ZOSF("TEST") K X I $T W ! D EN^DVBHQZ4 Q
;I $P($G(^IBE(350.9,1,1)),"^",16) F X="DVBHQZ4","DGHINQZ4" X ^%ZOSF("TEST") I $T S DGROUT=X K X W ! D @("EN^"_DGROUT) K DGROUT Q
K Y Q
ASK I IBAC'=1 K IBIFN Q
W !!,"DO YOU WANT TO ESTABLISH A NEW BILLING RECORD FOR '",$P(^DPT(DFN,0),"^",1),"'" S %=2 D YN^DICN
I '% W !!?4,"YES - To establish a new billing record in the billing file.",!?4,"NO - To discontinue this process immediately." G ASK
I %'=1 K IBIFN Q
K DA,Y,DINUM,IBIFN S (IBNEW,IBYN)=1 D ^IBCA Q
DATE I $D(^DGCR(399,"C",DFN)) S DA="" F I=1:1 S DA=$O(^DGCR(399,"APDT",DFN,DA)) Q:DA="" D DATE1
I IBAC=4,'$D(^UTILITY($J,"IB")) W !,"No ",$S($D(^DGCR(399,"C",DFN)):"UNCANCELLED ",1:""),"billing records on file for this patient." Q
S CT=0,CT1=1,IBT="" F J=1:1 S IBT=$O(^UTILITY($J,"IB",IBT)) Q:IBT="" F J1=0:0 S J1=$O(^UTILITY($J,"IB",IBT,J1)) Q:J1="" S X=J1 D SET
CT W ! S G="",CT2=$S(CT<(CT1+4):CT,1:(CT1+4)) F K=CT1:1:CT2 I $D(^UTILITY($J,"UB",K)) D WRLINE
S X="" D WDATE Q:X["^" I '$D(IB),$D(^UTILITY($J,"UB",K+1)) S CT1=K+1 G CT
K CT,CT1,CT2,K,^UTILITY($J,"UB") Q
WRLINE W !?2,K,?6 S IBDATA=^UTILITY($J,"UB",K),Y=+IBDATA X ^DD("DD") W Y,?25,$P(^DGCR(399,+$P(IBDATA,"^",2),0),"^",1),?34,$P(IBDATA,"^",3),?49,$P(IBDATA,"^",4),?71,$P(IBDATA,"^",5)
Q
DATE1 S IBT=$O(^DGCR(399,"APDT",DFN,DA,0)) I $D(^DGCR(399,+DA,0)),$S(IBAC<3:$P(^(0),U,13)<3,IBAC=3:$P(^(0),U,13)<3,'$D(^("S")):0,$P(^("S"),"^",17)]"":0,1:1) S ^UTILITY($J,"IB",IBT,DA)=""
Q
WDATE Q:'CT W !! W:K<CT "PRESS <RETURN> TO CONTINUE, OR",! W "CHOOSE 1",$S(CT=1:"",1:"-"_K),": " R X:DTIME Q:X["^"!(X="") I X["?" W !!,"Select one of the above or <RETURN> to establish a new billing record." G WDATE
I $S('$D(^UTILITY($J,"UB",+X)):1,+X>K:1,+X<1:1,'(X?.N):1,1:0) W !!,"NOT A VALID CHOICE!!",*7 G WDATE
S IBIFN=$P(^UTILITY($J,"UB",X),"^",2),IB=1 Q
SET I $S(IBV:1,$P(^DGCR(399,+X,0),"^",13):1,1:0) S CT=CT+1 D SET2
Q
SET2 S IBND0=^DGCR(399,+X,0)
S ^UTILITY($J,"UB",CT)=9999999-IBT_"^"_+X_"^"_$S($D(^DGCR(399.3,+$P(IBND0,"^",7),0)):$P(^(0),"^",4)_$S($P(IBND0,"^",5)<3:"-Inpt",1:"-Opt"),1:"")_"^"_$P($P($P(^DD(399,.13,0),"^",3),$P(IBND0,"^",13)_":",2),";",1)
I +$P(IBND0,"^",19)'=$P($G(^IBE(350.9,1,1)),U,26) S ^UTILITY($J,"UB",CT)=^UTILITY($J,"UB",CT)_"^"_$E($P($G(^IBE(353,+$P(IBND0,"^",19),0)),"^",1),1,9)
Q
ST L ^DGCR(399,IBIFN):5 I '$T W !,"No further processing of this record permitted at this time.",!,"Record locked by another user. Try again later." Q
S ^DISV(DUZ,"^DGCR(399,")=IBIFN
D NOPTF^IBCB2 I 'IBAC1 D NOPTF1^IBCB2 Q
G ST2:IBAC'=1
ST1 K ^UTILITY($J) D ^IBCSCU,^IBCSC1 G Q:'$T
ST2 D ^IBCB1 Q
Q ;
K IBIFN,IBV,IBAC
;***
;I $D(XRT0) S:'$D(XRTN) XRTN="IBCB" D T1^%ZOSV ;stop rt clock
Q
;
EDI S IBAC=1,IBV=0 D EN G Q:'IBAC1,EDI
REV ;S IBAC=2,IBV=0 D EN G Q:'IBAC1,REV
AUT S IBAC=3,IBV=0 D EN G Q:'IBAC1,AUT
GEN S IBAC=4,IBV=1 D EN G Q:'IBAC1,GEN
Q
IBCB ;ALB/MRL - BILLING BEGINNING POINT/SELECT BILL OR PATIENT ;01 JUN 88 12:00
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRB
+5 ;
EN ;
+1 DO HOME^%ZIS
IF '$DATA(IBAC)
QUIT
+2 ;***
+3 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBCB" D T1^%ZOSV ;stop rt clock
+4 ;S XRTL=$ZU(0),XRTN="IBCB-"_$G(IBAC) D T0^%ZOSV ;start rt clock
+5 ;
+6 IF '$DATA(IBV)
SET IBV=1
LOCK
KILL ^UTILITY($JOB),DFN,IBIFN,DIC
SET DIC(0)="EQMZ"
READ !!,"Enter BILL NUMBER or PATIENT NAME: ",IBX:DTIME
IF IBX["^"!(IBX="")
SET IBAC1=0
QUIT
+7 SET IBAC1=1
+8 IF IBX?1A4N!(IBX?2.A)!(IBX?2.A1",".AP)!(IBX?1A1P.AP)
SET DIC="^DPT("
SET X=IBX
DO ^DIC
IF Y'>0
GOTO EN
SET DFN=+Y
DO HINQ
SET X=$SELECT('$DATA(^DGCR(399,"C",DFN)):1,'$DATA(^DGCR(399,"AOP",DFN)):2,1:0)
+9 IF $DATA(DFN)
IF X
IF IBAC<4
WRITE !!,"No ",$SELECT(X=1:"",1:"OPEN "),"billing records on file for this patient."
DO ASK
IF '$DATA(IBIFN)
GOTO EN
+10 IF $DATA(DFN)
IF '$DATA(IBIFN)
DO DATE
IF '$DATA(IBIFN)
DO ASK
IF $DATA(IBIFN)
DO ST
GOTO EN
+11 SET DIC("S")=$SELECT(IBAC'=4:"I $P(^(0),""^"",13)<3",1:"I $P(^(""S""),""^"",17)=""""")
SET DIC="^DGCR(399,"
SET X=IBX
+12 DO ^DIC
IF Y'>0
GOTO EN
SET IBIFN=+Y
SET DFN=$PIECE(Y(0),"^",2)
DO HINQ
DO ST
GOTO EN
+13 GOTO EN
HINQ IF $SELECT('$DATA(^DPT(DFN,.361)):1,$PIECE(^(.361),"^",1)'="V":1,1:0)
WRITE !?17,"*** ELIGIBILITY NOT VERIFIED ***"
DO HINQ1
MT ;I $D(DFN) D ^DGMT1 K DGMTLL
+1 IF $DATA(DFN)
DO DIS^DGMTU(DFN)
+2 QUIT
HINQ1 IF $PIECE($GET(^IBE(350.9,1,1)),"^",16)
SET X="DVBHQZ4"
XECUTE ^%ZOSF("TEST")
KILL X
IF $TEST
WRITE !
DO EN^DVBHQZ4
QUIT
+1 ;I $P($G(^IBE(350.9,1,1)),"^",16) F X="DVBHQZ4","DGHINQZ4" X ^%ZOSF("TEST") I $T S DGROUT=X K X W ! D @("EN^"_DGROUT) K DGROUT Q
+2 KILL Y
QUIT
ASK IF IBAC'=1
KILL IBIFN
QUIT
+1 WRITE !!,"DO YOU WANT TO ESTABLISH A NEW BILLING RECORD FOR '",$PIECE(^DPT(DFN,0),"^",1),"'"
SET %=2
DO YN^DICN
+2 IF '%
WRITE !!?4,"YES - To establish a new billing record in the billing file.",!?4,"NO - To discontinue this process immediately."
GOTO ASK
+3 IF %'=1
KILL IBIFN
QUIT
+4 KILL DA,Y,DINUM,IBIFN
SET (IBNEW,IBYN)=1
DO ^IBCA
QUIT
DATE IF $DATA(^DGCR(399,"C",DFN))
SET DA=""
FOR I=1:1
SET DA=$ORDER(^DGCR(399,"APDT",DFN,DA))
IF DA=""
QUIT
DO DATE1
+1 IF IBAC=4
IF '$DATA(^UTILITY($JOB,"IB"))
WRITE !,"No ",$SELECT($DATA(^DGCR(399,"C",DFN)):"UNCANCELLED ",1:""),"billing records on file for this patient."
QUIT
+2 SET CT=0
SET CT1=1
SET IBT=""
FOR J=1:1
SET IBT=$ORDER(^UTILITY($JOB,"IB",IBT))
IF IBT=""
QUIT
FOR J1=0:0
SET J1=$ORDER(^UTILITY($JOB,"IB",IBT,J1))
IF J1=""
QUIT
SET X=J1
DO SET
CT WRITE !
SET G=""
SET CT2=$SELECT(CT<(CT1+4):CT,1:(CT1+4))
FOR K=CT1:1:CT2
IF $DATA(^UTILITY($JOB,"UB",K))
DO WRLINE
+1 SET X=""
DO WDATE
IF X["^"
QUIT
IF '$DATA(IB)
IF $DATA(^UTILITY($JOB,"UB",K+1))
SET CT1=K+1
GOTO CT
+2 KILL CT,CT1,CT2,K,^UTILITY($JOB,"UB")
QUIT
WRLINE WRITE !?2,K,?6
SET IBDATA=^UTILITY($JOB,"UB",K)
SET Y=+IBDATA
XECUTE ^DD("DD")
WRITE Y,?25,$PIECE(^DGCR(399,+$PIECE(IBDATA,"^",2),0),"^",1),?34,$PIECE(IBDATA,"^",3),?49,$PIECE(IBDATA,"^",4),?71,$PIECE(IBDATA,"^",5)
+1 QUIT
DATE1 SET IBT=$ORDER(^DGCR(399,"APDT",DFN,DA,0))
IF $DATA(^DGCR(399,+DA,0))
IF $SELECT(IBAC<3:$PIECE(^(0),U,13)<3,IBAC=3:$PIECE(^(0),U,13)<3,'$DATA(^("S")):0,$PIECE(^("S"),"^",17)]"":0,1:1)
SET ^UTILITY($JOB,"IB",IBT,DA)=""
+1 QUIT
WDATE IF 'CT
QUIT
WRITE !!
IF K<CT
WRITE "PRESS <RETURN> TO CONTINUE, OR",!
WRITE "CHOOSE 1",$SELECT(CT=1:"",1:"-"_K),": "
READ X:DTIME
IF X["^"!(X="")
QUIT
IF X["?"
WRITE !!,"Select one of the above or <RETURN> to establish a new billing record."
GOTO WDATE
+1 IF $SELECT('$DATA(^UTILITY($JOB,"UB",+X)):1,+X>K:1,+X<1:1,'(X?.N):1,1:0)
WRITE !!,"NOT A VALID CHOICE!!",*7
GOTO WDATE
+2 SET IBIFN=$PIECE(^UTILITY($JOB,"UB",X),"^",2)
SET IB=1
QUIT
SET IF $SELECT(IBV:1,$PIECE(^DGCR(399,+X,0),"^",13):1,1:0)
SET CT=CT+1
DO SET2
+1 QUIT
SET2 SET IBND0=^DGCR(399,+X,0)
+1 SET ^UTILITY($JOB,"UB",CT)=9999999-IBT_"^"_+X_"^"_$SELECT($DATA(^DGCR(399.3,+$PIECE(IBND0,"^",7),0)):$PIECE(^(0),"^",4)_$SELECT($PIECE(IBND0,"^",5)<3:"-Inpt",1:"-Opt"),1:"")_"^"_$PIECE($PIECE($PIECE(^DD(399,.13,0),"^",3),...
... $PIECE(IBND0,"^",13)_":",2),";",1)
+2 IF +$PIECE(IBND0,"^",19)'=$PIECE($GET(^IBE(350.9,1,1)),U,26)
SET ^UTILITY($JOB,"UB",CT)=^UTILITY($JOB,"UB",CT)_"^"_$EXTRACT($PIECE($GET(^IBE(353,+$PIECE(IBND0,"^",19),0)),"^",1),1,9)
+3 QUIT
ST LOCK ^DGCR(399,IBIFN):5
IF '$TEST
WRITE !,"No further processing of this record permitted at this time.",!,"Record locked by another user. Try again later."
QUIT
+1 SET ^DISV(DUZ,"^DGCR(399,")=IBIFN
+2 DO NOPTF^IBCB2
IF 'IBAC1
DO NOPTF1^IBCB2
QUIT
+3 IF IBAC'=1
GOTO ST2
ST1 KILL ^UTILITY($JOB)
DO ^IBCSCU
DO ^IBCSC1
IF '$TEST
GOTO Q
ST2 DO ^IBCB1
QUIT
Q ;
+1 KILL IBIFN,IBV,IBAC
+2 ;***
+3 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBCB" D T1^%ZOSV ;stop rt clock
+4 QUIT
+5 ;
EDI SET IBAC=1
SET IBV=0
DO EN
IF 'IBAC1
GOTO Q
GOTO EDI
REV ;S IBAC=2,IBV=0 D EN G Q:'IBAC1,REV
AUT SET IBAC=3
SET IBV=0
DO EN
IF 'IBAC1
GOTO Q
GOTO AUT
GEN SET IBAC=4
SET IBV=1
DO EN
IF 'IBAC1
GOTO Q
GOTO GEN
+1 QUIT
