IBTUTL4 ;ALB/AAS - CLAIMS TRACKING UTILITY ROUTINE ; 21-JUN-93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
AEA(IBTRC,X) ; -- dd input call for authorize entire admission (field 1.08)
N ARRAY,IBOK,IBTRN,IBTRND,Y,I,J,M,N S IBOK=1
I X,$P($G(^IBT(356.2,+IBTRC,1)),"^",7) D NOTOK("Deny Entire Admission already answered 'YES'.") G AEAQ
D ARRAY^IBTUTL3(IBTRC)
I $G(ARRAY(0)) D NOTOK("Entired Admission already denied on "_$$FMTE^XLFDT(+$G(^IBT(356.2,+ARRAY(0),0))))
I $G(ARRAY),ARRAY'=IBTRC D NOTOK("Entire Admission has already be authorized on "_$$FMTE^XLFDT(+$G(^IBT(356.2,+ARRAY,0))))
AEAQ Q IBOK
;
DEA(IBTRC,X) ; -- dd input call for deny entry admission (field 1.07)
N ARRAY,IBOK,IBTRN,IBTRND,Y,I,J,M,N S IBOK=1
I X,$P($G(^IBT(356.2,+IBTRC,1)),"^",8) D NOTOK("Authorize Entire Admission already answered 'YES'.") G DEAQ
D ARRAY^IBTUTL3(IBTRC)
I $G(ARRAY(0)),+ARRAY(0)'=IBTRC D NOTOK("Entired Admission already denied on "_$$FMTE^XLFDT(+$G(^IBT(356.2,+ARRAY(0),0))))
I $G(ARRAY) D NOTOK("Entire Admission has already be authorized on "_$$FMTE^XLFDT(+$G(^IBT(356.2,+ARRAY,0))))
DEAQ Q IBOK
;
AFDT(IBTRC,X) ; -- dd input call for check to approved from date (field .12)
; -- returns 1 if date okay, 0 if not, let input transform kill x
N ARRAY,IBOK,IBTRN,IBTRND,Y,I,J,M,N S IBOK=1
;
D CHK I 'IBOK G AFDTQ
;
I $P(^IBT(356.2,+IBTRC,0),U,13),X>$P(^(0),"^",13) D NOTOK("Care Authorized From Date must be before the Care Authorized To Date ("_$$FMTE^XLFDT($P(^IBT(356.2,+IBTRC,0),"^",13))_")!") G AFDTQ
;
D CHK2 I '$D(ARRAY) G AFDTQ
S M=0 F S M=$O(ARRAY(M)) Q:'M S N=0 F S N=$O(ARRAY(M,N)) Q:'N I IBTRC'=+ARRAY(M,N),X'<M,X'>N D NOTOK("Date entered is already covered by another entry.")
AFDTQ Q IBOK
;
ATDT(IBTRC,X) ; -- dd input call for check to approved to date (field .13)
; -- returns 1 if date okay, 0 if not, let input transform kill x
N ARRAY,IBOK,IBTRN,IBTRND,Y,I,J,M,N S IBOK=1
D CHK G:'IBOK ATDTQ
;
I $P(^IBT(356.2,+IBTRC,0),U,12),X<$P(^(0),"^",12) D NOTOK("Care Authorized To Date must not be before the Care Authorized From Date ("_$$FMTE^XLFDT($P(^IBT(356.2,+IBTRC,0),"^",13))_")!") G ATDTQ
;
D CHK2 I '$D(ARRAY) G ATDTQ
S M=0 F S M=$O(ARRAY(M)) Q:'M S N=0 F S N=$O(ARRAY(M,N)) Q:'N I IBTRC'=+ARRAY(M,N),X'<M,X'>N D NOTOK("Date entered is already covered by another entry.")
ATDTQ Q IBOK
;
DFDT(IBTRC,X) ; -- dd input call for check to denied from date (field .15)
; -- returns 1 if date okay, 0 if not, let input transform kill x
N ARRAY,IBOK,IBTRN,IBTRND,Y,I,J,M,N S IBOK=1
D CHK G:'IBOK DFDTQ
;
I $P(^IBT(356.2,+IBTRC,0),U,16),X>$P(^(0),"^",16) D NOTOK("Care Denied From Date must be before the Care Denied To Date ("_$$FMTE^XLFDT($P(^IBT(356.2,+IBTRC,0),"^",13))_")!") G DFDTQ
;
D CHK2 I '$D(ARRAY) G DFDTQ
S M=0 F S M=$O(ARRAY(M)) Q:'M S N=0 F S N=$O(ARRAY(M,N)) Q:'N I IBTRC'=+ARRAY(M,N),X'<M,X'>N D NOTOK("Date entered is already covered by another entry.")
DFDTQ Q IBOK
;
DTDT(IBTRC,X) ; -- dd input call for check to denied to date (field .16)
; -- returns 1 if date okay, 0 if not, let input transform kill x
N ARRAY,IBOK,IBTRN,IBTRND,Y,I,J,M,N S IBOK=1
D CHK G:'IBOK DTDTQ
;
I $P(^IBT(356.2,+IBTRC,0),U,15),X<$P(^(0),"^",15) D NOTOK("Date must not be before the Care Denied From Date ("_$$FMTE^XLFDT($P(^IBT(356.2,+IBTRC,0),"^",13))_")!") G DTDTQ
;
D CHK2 I '$D(ARRAY) G DTDTQ
S M=0 F S M=$O(ARRAY(M)) Q:'M S N=0 F S N=$O(ARRAY(M,N)) Q:'N I IBTRC'=+ARRAY(M,N),X'<M,X'>N D NOTOK("Date entered is already covered by another entry.")
DTDTQ Q IBOK
;
CHK ; -- generic check functions
I '$G(X)!('$G(IBTRC))!($G(^IBT(356.2,+$G(IBTRC),0))="") S IBOK=0 Q
S IBTRND=$G(^IBT(356,+$P($G(^IBT(356.2,+IBTRC,0)),"^",2),0))
;
I X<($P(IBTRND,"^",6)\1) D NOTOK("Date can't be before admission or visit date ("_$$FMTE^XLFDT($P(IBTRND,"^",6))_")!") Q
;
S Y=$$DISCH(+$P(IBTRND,"^",5)) I Y,X>Y D NOTOK("Date can not be after Discharge Date ("_$$FMTE^XLFDT(Y)_")!") Q
Q
;
CHK2 ; -- if pass first set of check do these
D ARRAY^IBTUTL3(IBTRC)
I $G(ARRAY) D NOTOK("Whole Admission has already been Authorized, can not add partial dates!")
I $G(ARRAY(0)) D NOTOK("Whole Admission has already been Denied, can not add partial dates!")
Q
;
NOTOK(MESS) ; -- process not okays
S IBOK=0
I '$D(ZTQUEUED),$G(MESS)'="" W !,MESS,!
Q
;
DISCH(DGPM) ; -- find discharge date for an admission
;
N X S X=""
I '$G(^DGPM(+$G(DGPM),0)) G DISCHQ
S X=+$G(^DGPM(+$P($G(^DGPM(DGPM,0)),"^",17),0))
DISCHQ Q X
IBTUTL4 ;ALB/AAS - CLAIMS TRACKING UTILITY ROUTINE ; 21-JUN-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
AEA(IBTRC,X) ; -- dd input call for authorize entire admission (field 1.08)
+1 NEW ARRAY,IBOK,IBTRN,IBTRND,Y,I,J,M,N
SET IBOK=1
+2 IF X
IF $PIECE($GET(^IBT(356.2,+IBTRC,1)),"^",7)
DO NOTOK("Deny Entire Admission already answered 'YES'.")
GOTO AEAQ
+3 DO ARRAY^IBTUTL3(IBTRC)
+4 IF $GET(ARRAY(0))
DO NOTOK("Entired Admission already denied on "_$$FMTE^XLFDT(+$GET(^IBT(356.2,+ARRAY(0),0))))
+5 IF $GET(ARRAY)
IF ARRAY'=IBTRC
DO NOTOK("Entire Admission has already be authorized on "_$$FMTE^XLFDT(+$GET(^IBT(356.2,+ARRAY,0))))
AEAQ QUIT IBOK
+1 ;
DEA(IBTRC,X) ; -- dd input call for deny entry admission (field 1.07)
+1 NEW ARRAY,IBOK,IBTRN,IBTRND,Y,I,J,M,N
SET IBOK=1
+2 IF X
IF $PIECE($GET(^IBT(356.2,+IBTRC,1)),"^",8)
DO NOTOK("Authorize Entire Admission already answered 'YES'.")
GOTO DEAQ
+3 DO ARRAY^IBTUTL3(IBTRC)
+4 IF $GET(ARRAY(0))
IF +ARRAY(0)'=IBTRC
DO NOTOK("Entired Admission already denied on "_$$FMTE^XLFDT(+$GET(^IBT(356.2,+ARRAY(0),0))))
+5 IF $GET(ARRAY)
DO NOTOK("Entire Admission has already be authorized on "_$$FMTE^XLFDT(+$GET(^IBT(356.2,+ARRAY,0))))
DEAQ QUIT IBOK
+1 ;
AFDT(IBTRC,X) ; -- dd input call for check to approved from date (field .12)
+1 ; -- returns 1 if date okay, 0 if not, let input transform kill x
+2 NEW ARRAY,IBOK,IBTRN,IBTRND,Y,I,J,M,N
SET IBOK=1
+3 ;
+4 DO CHK
IF 'IBOK
GOTO AFDTQ
+5 ;
+6 IF $PIECE(^IBT(356.2,+IBTRC,0),U,13)
IF X>$PIECE(^(0),"^",13)
DO NOTOK("Care Authorized From Date must be before the Care Authorized To Date ("_$$FMTE^XLFDT($PIECE(^IBT(356.2,+IBTRC,0),"^",13))_")!")
GOTO AFDTQ
+7 ;
+8 DO CHK2
IF '$DATA(ARRAY)
GOTO AFDTQ
+9 SET M=0
FOR
SET M=$ORDER(ARRAY(M))
IF 'M
QUIT
SET N=0
FOR
SET N=$ORDER(ARRAY(M,N))
IF 'N
QUIT
IF IBTRC'=+ARRAY(M,N)
IF X'<M
IF X'>N
DO NOTOK("Date entered is already covered by another entry.")
AFDTQ QUIT IBOK
+1 ;
ATDT(IBTRC,X) ; -- dd input call for check to approved to date (field .13)
+1 ; -- returns 1 if date okay, 0 if not, let input transform kill x
+2 NEW ARRAY,IBOK,IBTRN,IBTRND,Y,I,J,M,N
SET IBOK=1
+3 DO CHK
IF 'IBOK
GOTO ATDTQ
+4 ;
+5 IF $PIECE(^IBT(356.2,+IBTRC,0),U,12)
IF X<$PIECE(^(0),"^",12)
DO NOTOK("Care Authorized To Date must not be before the Care Authorized From Date ("_$$FMTE^XLFDT($PIECE(^IBT(356.2,+IBTRC,0),"^",13))_")!")
GOTO ATDTQ
+6 ;
+7 DO CHK2
IF '$DATA(ARRAY)
GOTO ATDTQ
+8 SET M=0
FOR
SET M=$ORDER(ARRAY(M))
IF 'M
QUIT
SET N=0
FOR
SET N=$ORDER(ARRAY(M,N))
IF 'N
QUIT
IF IBTRC'=+ARRAY(M,N)
IF X'<M
IF X'>N
DO NOTOK("Date entered is already covered by another entry.")
ATDTQ QUIT IBOK
+1 ;
DFDT(IBTRC,X) ; -- dd input call for check to denied from date (field .15)
+1 ; -- returns 1 if date okay, 0 if not, let input transform kill x
+2 NEW ARRAY,IBOK,IBTRN,IBTRND,Y,I,J,M,N
SET IBOK=1
+3 DO CHK
IF 'IBOK
GOTO DFDTQ
+4 ;
+5 IF $PIECE(^IBT(356.2,+IBTRC,0),U,16)
IF X>$PIECE(^(0),"^",16)
DO NOTOK("Care Denied From Date must be before the Care Denied To Date ("_$$FMTE^XLFDT($PIECE(^IBT(356.2,+IBTRC,0),"^",13))_")!")
GOTO DFDTQ
+6 ;
+7 DO CHK2
IF '$DATA(ARRAY)
GOTO DFDTQ
+8 SET M=0
FOR
SET M=$ORDER(ARRAY(M))
IF 'M
QUIT
SET N=0
FOR
SET N=$ORDER(ARRAY(M,N))
IF 'N
QUIT
IF IBTRC'=+ARRAY(M,N)
IF X'<M
IF X'>N
DO NOTOK("Date entered is already covered by another entry.")
DFDTQ QUIT IBOK
+1 ;
DTDT(IBTRC,X) ; -- dd input call for check to denied to date (field .16)
+1 ; -- returns 1 if date okay, 0 if not, let input transform kill x
+2 NEW ARRAY,IBOK,IBTRN,IBTRND,Y,I,J,M,N
SET IBOK=1
+3 DO CHK
IF 'IBOK
GOTO DTDTQ
+4 ;
+5 IF $PIECE(^IBT(356.2,+IBTRC,0),U,15)
IF X<$PIECE(^(0),"^",15)
DO NOTOK("Date must not be before the Care Denied From Date ("_$$FMTE^XLFDT($PIECE(^IBT(356.2,+IBTRC,0),"^",13))_")!")
GOTO DTDTQ
+6 ;
+7 DO CHK2
IF '$DATA(ARRAY)
GOTO DTDTQ
+8 SET M=0
FOR
SET M=$ORDER(ARRAY(M))
IF 'M
QUIT
SET N=0
FOR
SET N=$ORDER(ARRAY(M,N))
IF 'N
QUIT
IF IBTRC'=+ARRAY(M,N)
IF X'<M
IF X'>N
DO NOTOK("Date entered is already covered by another entry.")
DTDTQ QUIT IBOK
+1 ;
CHK ; -- generic check functions
+1 IF '$GET(X)!('$GET(IBTRC))!($GET(^IBT(356.2,+$GET(IBTRC),0))="")
SET IBOK=0
QUIT
+2 SET IBTRND=$GET(^IBT(356,+$PIECE($GET(^IBT(356.2,+IBTRC,0)),"^",2),0))
+3 ;
+4 IF X<($PIECE(IBTRND,"^",6)\1)
DO NOTOK("Date can't be before admission or visit date ("_$$FMTE^XLFDT($PIECE(IBTRND,"^",6))_")!")
QUIT
+5 ;
+6 SET Y=$$DISCH(+$PIECE(IBTRND,"^",5))
IF Y
IF X>Y
DO NOTOK("Date can not be after Discharge Date ("_$$FMTE^XLFDT(Y)_")!")
QUIT
+7 QUIT
+8 ;
CHK2 ; -- if pass first set of check do these
+1 DO ARRAY^IBTUTL3(IBTRC)
+2 IF $GET(ARRAY)
DO NOTOK("Whole Admission has already been Authorized, can not add partial dates!")
+3 IF $GET(ARRAY(0))
DO NOTOK("Whole Admission has already been Denied, can not add partial dates!")
+4 QUIT
+5 ;
NOTOK(MESS) ; -- process not okays
+1 SET IBOK=0
+2 IF '$DATA(ZTQUEUED)
IF $GET(MESS)'=""
WRITE !,MESS,!
+3 QUIT
+4 ;
DISCH(DGPM) ; -- find discharge date for an admission
+1 ;
+2 NEW X
SET X=""
+3 IF '$GET(^DGPM(+$GET(DGPM),0))
GOTO DISCHQ
+4 SET X=+$GET(^DGPM(+$PIECE($GET(^DGPM(DGPM,0)),"^",17),0))
DISCHQ QUIT X
