- 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
