DGVPTIB1 ;alb/mjk - IBACKIN for export with PIMS v5.3; 4/21/93
;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
;
IBACKIN ;ALB/RLW - Check-in Link for OP Co-payment ; 12-JUN-92
;;Version 1.5 ; INTEGRATED BILLING ;**3,14**; 29-JUL-92
;
EN ; main entry point
Q ;ihs/cmi/maw 02/08/2012 patch 1014 no IB so entire routine is not needed
;***
;S XRTL=$ZU(0),XRTN="IBACKIN-1" D T0^%ZOSV ;start rt clock
;I $D(XRT0),(('$D(SDATA))!(+$G(SDAMEVT)<2)) S:'$D(XRTN) XRTN="IBACKIN" D T1^%ZOSV ;stop rt clock
;
Q:'$G(SDATA)!(+$G(SDAMEVT)<2)
S IBADFN=$P(SDATA,"^",2)
CHKSTAT ; check appointment status, quit if inpatient or not relevant
;***
;I $D(XRT0),(($P(SDATA("BEFORE","STATUS"),"^",6)>0)!($P(SDATA("AFTER","STATUS"),"^",6)>0)) S:'$D(XRTN) XRTN="IBACKIN" D T1^%ZOSV ;stop rt clock
;
I ($P(SDATA("BEFORE","STATUS"),"^",6)>0)!($P(SDATA("AFTER","STATUS"),"^",6)>0) G ENQ
S IBAST=+SDATA("AFTER","STATUS"),IBBST=+SDATA("BEFORE","STATUS"),IBWST=$P(SDATA,"^",5)
;***
;I $D(XRT0),IBAST=8 S:'$D(XRTN) XRTN="IBACKIN" D T1^%ZOSV ;stop rt clock
;I IBAST=8 G ENQ
I (IBAST=1)!(IBAST=2)!(IBAST=4)!(IBAST=6) D SETUP G ENQ
I IBBST=1!(IBBST=2) D SETUP
ENQ K IBAST,IBEL,IBSERV,IBADFN,IBATYP,IBIEN,IBPARNT,IBCHRGD,IBCNP,IBDT,IBN,IBSFTLK,IBTRAN,IBIL,IBFAC,IBNOS,IBX,IBADATE,IBPDT,IBSTAT,IBXA,X,IBBST,IBWST
;***
;I $D(XRT0) S:'$D(XRTN) XRTN="IBACKIN" D T1^%ZOSV ;stop rt clock
;
Q
SETUP ;
I '$D(DT) D DT^DICRW
S IBX="O",IBXA="4",IBDATE=$P(SDATA,"^",3),IBDT=(IBDATE\1)
Q:'$$BIL^DGMTUB(IBADFN,IBDATE)
S Y=1,IBDUZ=$S(DUZ=0:.5,DUZ="":.5,1:DUZ) N IBJOB S IBJOB=5,IBWHER="IBACKIN"
;check no-count
S IBACLIN=$P(SDATA,"^",4) Q:$P(^SC(IBACLIN,0),"^",17)="Y"
I $D(^DPT(IBADFN,"S",IBDATE,0)) S IBAPTYPE=$P(^(0),"^",16)
; if C&P check if there's already an op copay for that day and cancel
I IBAPTYPE=1 D CANCP^IBECEA3 Q
; billable event check
Q:$$IGN^IBEFUNC(IBAPTYPE,DT)=1
S IBSFTLK="44:"_$P(SDATA,"^",4)_";S:"_$P(SDATA,"^",3)_";1:"_+SDATA
D SITE^IBAUTL,SERV^IBAUTL2,TYPE^IBAUTL2
S:IBAST=3 IBATYP=$P(^IBE(350.1,IBATYP,0),"^",6)
K X S X=IBSERV_"^"_IBADFN_"^"_IBATYP_"^"_"^"_DUZ,X(0)=1
; - logic to add a charge
I IBWST="CO",IBAST=2 D ADD G SETUPQ
I IBWST="CI",IBAST<3 D ADD G SETUPQ
; - logic to cancel a charge
S IBCRES=$S(IBAST=4!(IBAST=6):17,1:18)
I IBWST="CI",IBBST<3,IBAST>2 D CANCEL G SETUPQ
I IBWST="CO",IBBST=2,IBAST'=2 D CANCEL
SETUPQ K IBCRES
Q
ADD ; add op copay charge
D APPT^IBECEA3
G:(IBCHRGD>0)!(IBCNP>0) ADDQ
D TYPE^IBAUTL2 I $D(IBY),+IBY<0 D ^IBAERR ; - input IBDT,IBSERV,IBX returns IBATYP,IBCHG,IBDESC
S IBATYP=$S(IBCHRGD=2:53,1:51),IBSEQNO=$P(^IBE(350.1,IBATYP,0),"^",5) I '$D(IBSEQNO) S Y="-1^IBO23" D ^IBAERR G ADDQ
D ARPARM^IBAUTL I $D(Y),+Y<0 D ^IBAERR G ADDQ
D BILLNO^IBAUTL I $D(Y),+Y<0 D ^IBAERR G ADDQ
D ADD^IBAUTL I $D(Y),+Y<0 D ^IBAERR G ADDQ
L +(^IB(IBN)):10 E S Y="-1^IB014" D ^IBAERR G ADDQ
S $P(^IB(IBN,1),"^",1)=IBDUZ,$P(^IB(IBN,0),"^",2,17)=IBADFN_"^"_IBATYP_"^"_IBSFTLK_"^2^1^"_IBCHG_"^"_IBDESC_"^"_IBN_"^^"_IBIL_"^"_IBTRAN_"^"_IBFAC_"^"_IBDT_"^"_IBDT_"^"_IBN_"^"_IBDT K ^IB("AC",1,IBN)
S DIK="^IB(",DA=IBN D IX^DIK K DIK,DA L -^IB(IBN)
S IBNOS=IBN D ^IBAFIL I $D(Y),+Y<0 D ^IBAERR
I '$D(^IBE(351,"ACT",IBADFN)) S DFN=IBADFN,IBCLDT=IBDT D CLADD^IBAUTL3
ADDQ Q
CANCEL ; cancel op copay charge - search for op charges from same date, then compare softlink
S IBPTDT=""
F S IBPTDT=$O(^IB("APTDT",IBADFN,IBPTDT)) Q:IBPTDT="" S IBIEN="" D
.F K X S IBIEN=$O(^IB("APTDT",IBADFN,IBPTDT,IBIEN)) Q:IBIEN="" Q:'$D(^IB(IBIEN,0)) S X=$P(^IB(IBIEN,0),"^",4) I $P(X,";",1,2)=$P(IBSFTLK,";",1,2) D Q
..S IBX=IBIEN_"^4",IBTOTL=0 D CANCHG^IBECEA2
..D ARPARM^IBAUTL I $D(Y),+Y<0 D ^IBAERR Q
..I $G(IBNOS) D ^IBAFIL I $D(Y),+Y<0 D ^IBAERR
..S I=IBDT D CKBILL S IBPTDT=9999999
CANQ Q
;
CKBILL ; if a charge has been cancelled, search for other visits for day that might be billable.
N IBAD,IBSD,IBSN S IBAD=I
F Q:IBAST=1 S IBAD=$O(^DPT(IBADFN,"S",IBAD)) Q:$E(IBAD,1,7)'=IBDT S IBSD=$G(^(IBAD,0)) I $P(IBSD,"^",2)="" D
.Q:+$$STATUS^SDAM1(IBADFN,IBAD,+IBSD,IBSD)>2 ; appt not co'd or ci'd
.F IBSN=0:0 Q:IBAST=1 S IBSN=$O(^SC(+IBSD,"S",IBAD,1,IBSN)) Q:'IBSN I +$G(^(IBSN,0))=IBADFN D
..S IBAST=1,IBX="O",IBSFTLK="44:"_+IBSD_";S:"_IBAD_";1:"_IBSN
..S SDATA=IBSN_"^"_IBADFN_"^"_IBAD_"^"_+IBSD D ADD
CKQ Q
DGVPTIB1 ;alb/mjk - IBACKIN for export with PIMS v5.3; 4/21/93
+1 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
+2 ;
IBACKIN ;ALB/RLW - Check-in Link for OP Co-payment ; 12-JUN-92
+1 ;;Version 1.5 ; INTEGRATED BILLING ;**3,14**; 29-JUL-92
+2 ;
EN ; main entry point
+1 ;ihs/cmi/maw 02/08/2012 patch 1014 no IB so entire routine is not needed
QUIT
+2 ;***
+3 ;S XRTL=$ZU(0),XRTN="IBACKIN-1" D T0^%ZOSV ;start rt clock
+4 ;I $D(XRT0),(('$D(SDATA))!(+$G(SDAMEVT)<2)) S:'$D(XRTN) XRTN="IBACKIN" D T1^%ZOSV ;stop rt clock
+5 ;
+6 IF '$GET(SDATA)!(+$GET(SDAMEVT)<2)
QUIT
+7 SET IBADFN=$PIECE(SDATA,"^",2)
CHKSTAT ; check appointment status, quit if inpatient or not relevant
+1 ;***
+2 ;I $D(XRT0),(($P(SDATA("BEFORE","STATUS"),"^",6)>0)!($P(SDATA("AFTER","STATUS"),"^",6)>0)) S:'$D(XRTN) XRTN="IBACKIN" D T1^%ZOSV ;stop rt clock
+3 ;
+4 IF ($PIECE(SDATA("BEFORE","STATUS"),"^",6)>0)!($PIECE(SDATA("AFTER","STATUS"),"^",6)>0)
GOTO ENQ
+5 SET IBAST=+SDATA("AFTER","STATUS")
SET IBBST=+SDATA("BEFORE","STATUS")
SET IBWST=$PIECE(SDATA,"^",5)
+6 ;***
+7 ;I $D(XRT0),IBAST=8 S:'$D(XRTN) XRTN="IBACKIN" D T1^%ZOSV ;stop rt clock
+8 ;I IBAST=8 G ENQ
+9 IF (IBAST=1)!(IBAST=2)!(IBAST=4)!(IBAST=6)
DO SETUP
GOTO ENQ
+10 IF IBBST=1!(IBBST=2)
DO SETUP
ENQ KILL IBAST,IBEL,IBSERV,IBADFN,IBATYP,IBIEN,IBPARNT,IBCHRGD,IBCNP,IBDT,IBN,IBSFTLK,IBTRAN,IBIL,IBFAC,IBNOS,IBX,IBADATE,IBPDT,IBSTAT,IBXA,X,IBBST,IBWST
+1 ;***
+2 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBACKIN" D T1^%ZOSV ;stop rt clock
+3 ;
+4 QUIT
SETUP ;
+1 IF '$DATA(DT)
DO DT^DICRW
+2 SET IBX="O"
SET IBXA="4"
SET IBDATE=$PIECE(SDATA,"^",3)
SET IBDT=(IBDATE\1)
+3 IF '$$BIL^DGMTUB(IBADFN,IBDATE)
QUIT
+4 SET Y=1
SET IBDUZ=$SELECT(DUZ=0:.5,DUZ="":.5,1:DUZ)
NEW IBJOB
SET IBJOB=5
SET IBWHER="IBACKIN"
+5 ;check no-count
+6 SET IBACLIN=$PIECE(SDATA,"^",4)
IF $PIECE(^SC(IBACLIN,0),"^",17)="Y"
QUIT
+7 IF $DATA(^DPT(IBADFN,"S",IBDATE,0))
SET IBAPTYPE=$PIECE(^(0),"^",16)
+8 ; if C&P check if there's already an op copay for that day and cancel
+9 IF IBAPTYPE=1
DO CANCP^IBECEA3
QUIT
+10 ; billable event check
+11 IF $$IGN^IBEFUNC(IBAPTYPE,DT)=1
QUIT
+12 SET IBSFTLK="44:"_$PIECE(SDATA,"^",4)_";S:"_$PIECE(SDATA,"^",3)_";1:"_+SDATA
+13 DO SITE^IBAUTL
DO SERV^IBAUTL2
DO TYPE^IBAUTL2
+14 IF IBAST=3
SET IBATYP=$PIECE(^IBE(350.1,IBATYP,0),"^",6)
+15 KILL X
SET X=IBSERV_"^"_IBADFN_"^"_IBATYP_"^"_"^"_DUZ
SET X(0)=1
+16 ; - logic to add a charge
+17 IF IBWST="CO"
IF IBAST=2
DO ADD
GOTO SETUPQ
+18 IF IBWST="CI"
IF IBAST<3
DO ADD
GOTO SETUPQ
+19 ; - logic to cancel a charge
+20 SET IBCRES=$SELECT(IBAST=4!(IBAST=6):17,1:18)
+21 IF IBWST="CI"
IF IBBST<3
IF IBAST>2
DO CANCEL
GOTO SETUPQ
+22 IF IBWST="CO"
IF IBBST=2
IF IBAST'=2
DO CANCEL
SETUPQ KILL IBCRES
+1 QUIT
ADD ; add op copay charge
+1 DO APPT^IBECEA3
+2 IF (IBCHRGD>0)!(IBCNP>0)
GOTO ADDQ
+3 ; - input IBDT,IBSERV,IBX returns IBATYP,IBCHG,IBDESC
DO TYPE^IBAUTL2
IF $DATA(IBY)
IF +IBY<0
DO ^IBAERR
+4 SET IBATYP=$SELECT(IBCHRGD=2:53,1:51)
SET IBSEQNO=$PIECE(^IBE(350.1,IBATYP,0),"^",5)
IF '$DATA(IBSEQNO)
SET Y="-1^IBO23"
DO ^IBAERR
GOTO ADDQ
+5 DO ARPARM^IBAUTL
IF $DATA(Y)
IF +Y<0
DO ^IBAERR
GOTO ADDQ
+6 DO BILLNO^IBAUTL
IF $DATA(Y)
IF +Y<0
DO ^IBAERR
GOTO ADDQ
+7 DO ADD^IBAUTL
IF $DATA(Y)
IF +Y<0
DO ^IBAERR
GOTO ADDQ
+8 LOCK +(^IB(IBN)):10
IF '$TEST
SET Y="-1^IB014"
DO ^IBAERR
GOTO ADDQ
+9 SET $PIECE(^IB(IBN,1),"^",1)=IBDUZ
SET $PIECE(^IB(IBN,0),"^",2,17)=IBADFN_"^"_IBATYP_"^"_IBSFTLK_"^2^1^"_IBCHG_"^"_IBDESC_"^"_IBN_"^^"_IBIL_"^"_IBTRAN_"^"_IBFAC_"^"_IBDT_"^"_IBDT_"^"_IBN_"^"_IBDT
KILL ^IB("AC",1,IBN)
+10 SET DIK="^IB("
SET DA=IBN
DO IX^DIK
KILL DIK,DA
LOCK -^IB(IBN)
+11 SET IBNOS=IBN
DO ^IBAFIL
IF $DATA(Y)
IF +Y<0
DO ^IBAERR
+12 IF '$DATA(^IBE(351,"ACT",IBADFN))
SET DFN=IBADFN
SET IBCLDT=IBDT
DO CLADD^IBAUTL3
ADDQ QUIT
CANCEL ; cancel op copay charge - search for op charges from same date, then compare softlink
+1 SET IBPTDT=""
+2 FOR
SET IBPTDT=$ORDER(^IB("APTDT",IBADFN,IBPTDT))
IF IBPTDT=""
QUIT
SET IBIEN=""
Begin DoDot:1
+3 FOR
KILL X
SET IBIEN=$ORDER(^IB("APTDT",IBADFN,IBPTDT,IBIEN))
IF IBIEN=""
QUIT
IF '$DATA(^IB(IBIEN,0))
QUIT
SET X=$PIECE(^IB(IBIEN,0),"^",4)
IF $PIECE(X,";",1,2)=$PIECE(IBSFTLK,";",1,2)
Begin DoDot:2
+4 SET IBX=IBIEN_"^4"
SET IBTOTL=0
DO CANCHG^IBECEA2
+5 DO ARPARM^IBAUTL
IF $DATA(Y)
IF +Y<0
DO ^IBAERR
QUIT
+6 IF $GET(IBNOS)
DO ^IBAFIL
IF $DATA(Y)
IF +Y<0
DO ^IBAERR
+7 SET I=IBDT
DO CKBILL
SET IBPTDT=9999999
End DoDot:2
QUIT
End DoDot:1
CANQ QUIT
+1 ;
CKBILL ; if a charge has been cancelled, search for other visits for day that might be billable.
+1 NEW IBAD,IBSD,IBSN
SET IBAD=I
+2 FOR
IF IBAST=1
QUIT
SET IBAD=$ORDER(^DPT(IBADFN,"S",IBAD))
IF $EXTRACT(IBAD,1,7)'=IBDT
QUIT
SET IBSD=$GET(^(IBAD,0))
IF $PIECE(IBSD,"^",2)=""
Begin DoDot:1
+3 ; appt not co'd or ci'd
IF +$$STATUS^SDAM1(IBADFN,IBAD,+IBSD,IBSD)>2
QUIT
+4 FOR IBSN=0:0
IF IBAST=1
QUIT
SET IBSN=$ORDER(^SC(+IBSD,"S",IBAD,1,IBSN))
IF 'IBSN
QUIT
IF +$GET(^(IBSN,0))=IBADFN
Begin DoDot:2
+5 SET IBAST=1
SET IBX="O"
SET IBSFTLK="44:"_+IBSD_";S:"_IBAD_";1:"_IBSN
+6 SET SDATA=IBSN_"^"_IBADFN_"^"_IBAD_"^"_+IBSD
DO ADD
End DoDot:2
End DoDot:1
CKQ QUIT
