IBARXEU4 ;ALB/AAS - RX COPAY EXEMPTION CHECK IF PREVIOUSLY CANCELED ; 12-JAN-93
;;Version 2.0 ; INTEGRATED BILLING ;**34**; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
CANDT ; -- set beginning and ending dates
; input dfn =: patient internal number
; ibedt =: end date to cancel
; ibdt =: beging date to cancel
;
; output ibcandt =: begin date^end date to cancel
;
N X
;S IBCANDT=IBDT_"^"_IBEDT
;
; -- get last end date
S X=+$O(^IBA(354.1,"ACAN",DFN,"")) S:X<0 X=-X D:'X CONV ;never previously cancelled
I X,X>IBDT S IBDT=X
;
; -- only cancel back 1 year from today, or eff. legislation max
I IBDT<$$MINUS^IBARXEU0(DT) S IBDT=$$MINUS^IBARXEU0(DT)
I IBDT<$$STDATE^IBARXEU S IBDT=$$STDATE^IBARXEU
S IBCANDT=IBDT_"^"_IBEDT
CANDTQ Q
;
CONV ; -- see if conversion done
N X
S X=$G(^IBE(350.9,1,3)) G:$P(X,"^",14) CONVQ ; conversion complete
I $P(X,"^",3),DFN<$P(X,"^",4) G CONVQ ; patient already converted
;
; -- need to convert patient on the fly
S IBDT=$$STDATE^IBARXEU
CONVQ Q
;
ARCAN(DFN,IBSTAT,IBDT,IBEDT) ; -- process cancellation with ar logic here
;
; Input =: dfn patient internal entry number
; ibstat patient status from $$rxexmt or $$rxst
; ibdt beginning date to cancel
; ibedt ending date to cancel
;
Q:'+IBSTAT ; non-exempt patient
;
S:IBEDT>DT IBEDT=DT S:IBDT<$$STDATE^IBARXEU IBDT=$$STDATE^IBARXEU
;
; -- set begin and ending date, check x-ref
S X=+$O(^IBA(354.1,"ACAN",DFN,"")) S:X<0 X=-X
I X,X>IBDT S IBDT=X
;
; -- end date must be after begin date
I IBDT>IBEDT G ARCANQ
;
; -- set begin and ending dates in last entry created
D UPCAN
;
N IBWHER
S ERR=0,IBWHER=17
D EN1^PRCAX(DFN,IBDT,IBEDT,.ERR)
I ERR]"",+ERR'=ERR S ^TMP("IB-ERROR",$J,DFN)=ERR,IBEXERR=10 S:'$D(IBJOB) IBJOB=11 D ^IBAERR K IBEXERR
ARCANQ Q
;
UPCAN ; -- update canceled date fields
N X2
S DIE="^IBA(354.1,",DR=".13////"_IBDT_";.14////"_IBEDT
S DA=+$O(^(+$O(^IBA(354.1,"AIVDT",1,DFN,"")),0))
S X2=$G(^IBA(354.1,DA,0))
I $P(X2,"^",2)'=DFN!($P(X2,"^",14)) G UPCANQ
D ^DIE
K DIC,DIE,DA,DR,X
UPCANQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXEU4 2256 printed Apr 09, 2024@21:12:17 Page 2
IBARXEU4 ;ALB/AAS - RX COPAY EXEMPTION CHECK IF PREVIOUSLY CANCELED ; 12-JAN-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;**34**; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
CANDT ; -- set beginning and ending dates
+1 ; input dfn =: patient internal number
+2 ; ibedt =: end date to cancel
+3 ; ibdt =: beging date to cancel
+4 ;
+5 ; output ibcandt =: begin date^end date to cancel
+6 ;
+7 NEW X
+8 ;S IBCANDT=IBDT_"^"_IBEDT
+9 ;
+10 ; -- get last end date
+11 ;never previously cancelled
SET X=+$ORDER(^IBA(354.1,"ACAN",DFN,""))
if X<0
SET X=-X
if 'X
DO CONV
+12 IF X
IF X>IBDT
SET IBDT=X
+13 ;
+14 ; -- only cancel back 1 year from today, or eff. legislation max
+15 IF IBDT<$$MINUS^IBARXEU0(DT)
SET IBDT=$$MINUS^IBARXEU0(DT)
+16 IF IBDT<$$STDATE^IBARXEU
SET IBDT=$$STDATE^IBARXEU
+17 SET IBCANDT=IBDT_"^"_IBEDT
CANDTQ QUIT
+1 ;
CONV ; -- see if conversion done
+1 NEW X
+2 ; conversion complete
SET X=$GET(^IBE(350.9,1,3))
if $PIECE(X,"^",14)
GOTO CONVQ
+3 ; patient already converted
IF $PIECE(X,"^",3)
IF DFN<$PIECE(X,"^",4)
GOTO CONVQ
+4 ;
+5 ; -- need to convert patient on the fly
+6 SET IBDT=$$STDATE^IBARXEU
CONVQ QUIT
+1 ;
ARCAN(DFN,IBSTAT,IBDT,IBEDT) ; -- process cancellation with ar logic here
+1 ;
+2 ; Input =: dfn patient internal entry number
+3 ; ibstat patient status from $$rxexmt or $$rxst
+4 ; ibdt beginning date to cancel
+5 ; ibedt ending date to cancel
+6 ;
+7 ; non-exempt patient
if '+IBSTAT
QUIT
+8 ;
+9 if IBEDT>DT
SET IBEDT=DT
if IBDT<$$STDATE^IBARXEU
SET IBDT=$$STDATE^IBARXEU
+10 ;
+11 ; -- set begin and ending date, check x-ref
+12 SET X=+$ORDER(^IBA(354.1,"ACAN",DFN,""))
if X<0
SET X=-X
+13 IF X
IF X>IBDT
SET IBDT=X
+14 ;
+15 ; -- end date must be after begin date
+16 IF IBDT>IBEDT
GOTO ARCANQ
+17 ;
+18 ; -- set begin and ending dates in last entry created
+19 DO UPCAN
+20 ;
+21 NEW IBWHER
+22 SET ERR=0
SET IBWHER=17
+23 DO EN1^PRCAX(DFN,IBDT,IBEDT,.ERR)
+24 IF ERR]""
IF +ERR'=ERR
SET ^TMP("IB-ERROR",$JOB,DFN)=ERR
SET IBEXERR=10
if '$DATA(IBJOB)
SET IBJOB=11
DO ^IBAERR
KILL IBEXERR
ARCANQ QUIT
+1 ;
UPCAN ; -- update canceled date fields
+1 NEW X2
+2 SET DIE="^IBA(354.1,"
SET DR=".13////"_IBDT_";.14////"_IBEDT
+3 SET DA=+$ORDER(^(+$ORDER(^IBA(354.1,"AIVDT",1,DFN,"")),0))
+4 SET X2=$GET(^IBA(354.1,DA,0))
+5 IF $PIECE(X2,"^",2)'=DFN!($PIECE(X2,"^",14))
GOTO UPCANQ
+6 DO ^DIE
+7 KILL DIC,DIE,DA,DR,X
UPCANQ QUIT
