IBTRE6 ;ALB/AAS - CLAIMS TRACKING OUTPUT CLIN DATA ; 2-SEP-1993
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
ADMDIAG(IBTRN) ; -- output admitting diagnosis (inpatient)
;
N X S X=""
I '$G(IBTRN) G ADMDQ
S IBETYP=$$TRTP^IBTRE1(IBTRN) I IBETYP>1 G ADMDQ
S X=$$DIAG(+$O(^IBT(356.9,"ADG",+$P(^IBT(356,+IBTRN,0),"^",5),0)),1) I X'="" G ADMDQ
I $D(VAIN(9)) S X=VAIN(9)
I '$D(VAIN(9)) D
.N VAIN,VAINDT
.S VAINDT=$P(^IBT(356,IBTRN,0),U,6)
.S VA200="" D INP^VADPT
.S X=VAIN(9)
ADMDQ Q X
;
PDIAG(IBTRN) ; -- return primary diagnosis (inpatient)
N X S X=""
I '$G(IBTRN) G PDIAGQ
S X=$$DIAG(+$G(^IBT(356.9,+$O(^IBT(356.9,"ATP",+$P(^IBT(356,+IBTRN,0),"^",5),1,0)),0)),1)
PDIAGQ Q X
;
SDIAG ; -- return secondary diagnosis (inpatient
Q
;
ODIAG ; -- return outpatient diagnosis
Q
;
DIAG(X,Y) ; -- Expand diagnosis from pointer
; -- input x = pointer to diag
; y = if want text added (zero = number only)
I '$G(X) Q ""
Q $P($G(^ICD9(+$G(X),0)),"^")_$S($G(Y):" - "_$P($G(^ICD9(+$G(X),0)),"^",3),1:"")
;
;
APROV(IBTRN) ; -- return provider (inpatient)
;
N X S X=""
I '$G(IBTRN) G APROVQ
S X=$O(^IBT(356.94,"ATP",+$P(^IBT(356,+IBTRN,0),"^",5),2,0)) I X S X=$P($G(^IBT(356.94,+X,0)),"^",3) G APROVQ
S X=+$O(^IBT(356.94,"ATP",+$P(^IBT(356,+IBTRN,0),"^",5),1,0)) I X S X=$P($G(^IBT(356.94,+X,0)),"^",3) G APROVQ
I $D(VAIN(2)) S X=VAIN(2) I 'X S X=$G(VAIN(11))
I '$D(VAIN(2)) D
.N VAIN,VAINDT
.S VAINDT=$P(^IBT(356,IBTRN,0),U,6)
.S VA200="" D INP^VADPT
.S X=VAIN(2)
.I 'X S X=VAIN(11)
APROVQ Q $P($G(^VA(200,+X,0)),"^")
;
ATTEND ; -- return attendings (inpatient)
Q
;
PROV ; -- return providers (inpatient)
Q
;
OPROV ; -- returns outpatient providers
Q
;
PROC(X,Y) ; -- Expand procedure from pointer
; input x=proc^^date
; y= 1= exand
;
I '$G(Z) S Z=1
I '+$G(X) Q ""
Q $P($G(^ICD0(+X,0)),"^")_$S($G(Y):" - "_$P($G(^ICD0(+X,0)),"^",4),1:"")
;
OPROC ; -- outpatient procedures
Q
;
IPROC ; -- inpatient procedures
Q
;
LISTP(IBTRN,IBXY) ; -- return last y procedures for a tracking entry
; -- input ibtrn = tracking file pointer
; -- output array of procedure by date - ibxy(date)=procedure node
;
N IBDGPM,IBDT,IBDA,IBX,IBCNT
S (IBX,IBDT)="",IBXY=0
I '$G(IBTRN) G LISTPQ
S IBDGPM=$P($G(^IBT(356,IBTRN,0)),"^",5)
Q:'IBDGPM
F S IBDT=$O(^IBT(356.91,"APP",IBDGPM,IBDT)) Q:'IBDT S IBDA="" F S IBDA=$O(^IBT(356.91,"APP",IBDGPM,IBDT,IBDA)) Q:'IBDA D
.S IBX(-IBDT,IBDA)=$G(^IBT(356.91,IBDA,0))
;
S IBDT="" F S IBDT=$O(IBX(IBDT)) Q:'IBDT S IBDA=0 F S IBDA=$O(IBX(IBDT,IBDA)) Q:'IBDA D
.S IBXY=IBXY+1
.S IBXY(IBXY)=IBX(IBDT,IBDA)
LISTPQ Q
;
LSTPDG(X,IBDT,Y) ; -- return current diagnosis for a tracking entry
; -- input X = tracking file pointer
; ibdt = date for current diagnosis (null = last)
; y = 1= primary (default)
; 2= secondary
;
N IBY,IBX S (IBY,IBX)=""
I '$G(X) G LSTPDQ
S:'$G(IBDT) IBDT=DT S IBDT=-(IBDT+.9)
S:'$G(Y) Y=1 I Y'=1,Y'=2 S Y=1
F S IBDT=$O(^IBT(356.9,"APD",X,IBDT)) Q:'IBDT!($G(IBY)) S IBDA="" F S IBDA=$O(^IBT(356.9,"APD",X,IBDT,IBDA)) Q:'IBDA!($G(IBY)) D
.I $P(^IBT(356.9,IBDA,0),U,4)=Y S IBY=+^(0)
LSTPDQ Q IBY
;
DTCHK(DA,X) ; -- input transform for 356.94;.01. date not before admission or after discharge
N IBTRN,IBOK,IBCDT
S IBOK=1
G:'DA!($G(X)<1) DTCHKQ
S IBTRN=+$O(^IBT(356,"AD",+$P(^IBT(356.94,DA,0),"^",2),0))
G:'IBTRN DTCHKQ
S IBCDT=$$CDT^IBTODD1(IBTRN)
I X<$P(+IBCDT,".") S IBOK=0 G DTCHKQ ;before adm
I $P(IBCDT,"^",2),X>$P(IBCDT,"^",2) S IBOK=0 G DTCHKQ ; after disch
I X>$$FMADD^XLFDT(DT,7) S IBOK=0 G DTCHKQ
;
DTCHKQ Q IBOK
IBTRE6 ;ALB/AAS - CLAIMS TRACKING OUTPUT CLIN DATA ; 2-SEP-1993
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
ADMDIAG(IBTRN) ; -- output admitting diagnosis (inpatient)
+1 ;
+2 NEW X
SET X=""
+3 IF '$GET(IBTRN)
GOTO ADMDQ
+4 SET IBETYP=$$TRTP^IBTRE1(IBTRN)
IF IBETYP>1
GOTO ADMDQ
+5 SET X=$$DIAG(+$ORDER(^IBT(356.9,"ADG",+$PIECE(^IBT(356,+IBTRN,0),"^",5),0)),1)
IF X'=""
GOTO ADMDQ
+6 IF $DATA(VAIN(9))
SET X=VAIN(9)
+7 IF '$DATA(VAIN(9))
Begin DoDot:1
+8 NEW VAIN,VAINDT
+9 SET VAINDT=$PIECE(^IBT(356,IBTRN,0),U,6)
+10 SET VA200=""
DO INP^VADPT
+11 SET X=VAIN(9)
End DoDot:1
ADMDQ QUIT X
+1 ;
PDIAG(IBTRN) ; -- return primary diagnosis (inpatient)
+1 NEW X
SET X=""
+2 IF '$GET(IBTRN)
GOTO PDIAGQ
+3 SET X=$$DIAG(+$GET(^IBT(356.9,+$ORDER(^IBT(356.9,"ATP",+$PIECE(^IBT(356,+IBTRN,0),"^",5),1,0)),0)),1)
PDIAGQ QUIT X
+1 ;
SDIAG ; -- return secondary diagnosis (inpatient
+1 QUIT
+2 ;
ODIAG ; -- return outpatient diagnosis
+1 QUIT
+2 ;
DIAG(X,Y) ; -- Expand diagnosis from pointer
+1 ; -- input x = pointer to diag
+2 ; y = if want text added (zero = number only)
+3 IF '$GET(X)
QUIT ""
+4 QUIT $PIECE($GET(^ICD9(+$GET(X),0)),"^")_$SELECT($GET(Y):" - "_$PIECE($GET(^ICD9(+$GET(X),0)),"^",3),1:"")
+5 ;
+6 ;
APROV(IBTRN) ; -- return provider (inpatient)
+1 ;
+2 NEW X
SET X=""
+3 IF '$GET(IBTRN)
GOTO APROVQ
+4 SET X=$ORDER(^IBT(356.94,"ATP",+$PIECE(^IBT(356,+IBTRN,0),"^",5),2,0))
IF X
SET X=$PIECE($GET(^IBT(356.94,+X,0)),"^",3)
GOTO APROVQ
+5 SET X=+$ORDER(^IBT(356.94,"ATP",+$PIECE(^IBT(356,+IBTRN,0),"^",5),1,0))
IF X
SET X=$PIECE($GET(^IBT(356.94,+X,0)),"^",3)
GOTO APROVQ
+6 IF $DATA(VAIN(2))
SET X=VAIN(2)
IF 'X
SET X=$GET(VAIN(11))
+7 IF '$DATA(VAIN(2))
Begin DoDot:1
+8 NEW VAIN,VAINDT
+9 SET VAINDT=$PIECE(^IBT(356,IBTRN,0),U,6)
+10 SET VA200=""
DO INP^VADPT
+11 SET X=VAIN(2)
+12 IF 'X
SET X=VAIN(11)
End DoDot:1
APROVQ QUIT $PIECE($GET(^VA(200,+X,0)),"^")
+1 ;
ATTEND ; -- return attendings (inpatient)
+1 QUIT
+2 ;
PROV ; -- return providers (inpatient)
+1 QUIT
+2 ;
OPROV ; -- returns outpatient providers
+1 QUIT
+2 ;
PROC(X,Y) ; -- Expand procedure from pointer
+1 ; input x=proc^^date
+2 ; y= 1= exand
+3 ;
+4 IF '$GET(Z)
SET Z=1
+5 IF '+$GET(X)
QUIT ""
+6 QUIT $PIECE($GET(^ICD0(+X,0)),"^")_$SELECT($GET(Y):" - "_$PIECE($GET(^ICD0(+X,0)),"^",4),1:"")
+7 ;
OPROC ; -- outpatient procedures
+1 QUIT
+2 ;
IPROC ; -- inpatient procedures
+1 QUIT
+2 ;
LISTP(IBTRN,IBXY) ; -- return last y procedures for a tracking entry
+1 ; -- input ibtrn = tracking file pointer
+2 ; -- output array of procedure by date - ibxy(date)=procedure node
+3 ;
+4 NEW IBDGPM,IBDT,IBDA,IBX,IBCNT
+5 SET (IBX,IBDT)=""
SET IBXY=0
+6 IF '$GET(IBTRN)
GOTO LISTPQ
+7 SET IBDGPM=$PIECE($GET(^IBT(356,IBTRN,0)),"^",5)
+8 IF 'IBDGPM
QUIT
+9 FOR
SET IBDT=$ORDER(^IBT(356.91,"APP",IBDGPM,IBDT))
IF 'IBDT
QUIT
SET IBDA=""
FOR
SET IBDA=$ORDER(^IBT(356.91,"APP",IBDGPM,IBDT,IBDA))
IF 'IBDA
QUIT
Begin DoDot:1
+10 SET IBX(-IBDT,IBDA)=$GET(^IBT(356.91,IBDA,0))
End DoDot:1
+11 ;
+12 SET IBDT=""
FOR
SET IBDT=$ORDER(IBX(IBDT))
IF 'IBDT
QUIT
SET IBDA=0
FOR
SET IBDA=$ORDER(IBX(IBDT,IBDA))
IF 'IBDA
QUIT
Begin DoDot:1
+13 SET IBXY=IBXY+1
+14 SET IBXY(IBXY)=IBX(IBDT,IBDA)
End DoDot:1
LISTPQ QUIT
+1 ;
LSTPDG(X,IBDT,Y) ; -- return current diagnosis for a tracking entry
+1 ; -- input X = tracking file pointer
+2 ; ibdt = date for current diagnosis (null = last)
+3 ; y = 1= primary (default)
+4 ; 2= secondary
+5 ;
+6 NEW IBY,IBX
SET (IBY,IBX)=""
+7 IF '$GET(X)
GOTO LSTPDQ
+8 IF '$GET(IBDT)
SET IBDT=DT
SET IBDT=-(IBDT+.9)
+9 IF '$GET(Y)
SET Y=1
IF Y'=1
IF Y'=2
SET Y=1
+10 FOR
SET IBDT=$ORDER(^IBT(356.9,"APD",X,IBDT))
IF 'IBDT!($GET(IBY))
QUIT
SET IBDA=""
FOR
SET IBDA=$ORDER(^IBT(356.9,"APD",X,IBDT,IBDA))
IF 'IBDA!($GET(IBY))
QUIT
Begin DoDot:1
+11 IF $PIECE(^IBT(356.9,IBDA,0),U,4)=Y
SET IBY=+^(0)
End DoDot:1
LSTPDQ QUIT IBY
+1 ;
DTCHK(DA,X) ; -- input transform for 356.94;.01. date not before admission or after discharge
+1 NEW IBTRN,IBOK,IBCDT
+2 SET IBOK=1
+3 IF 'DA!($GET(X)<1)
GOTO DTCHKQ
+4 SET IBTRN=+$ORDER(^IBT(356,"AD",+$PIECE(^IBT(356.94,DA,0),"^",2),0))
+5 IF 'IBTRN
GOTO DTCHKQ
+6 SET IBCDT=$$CDT^IBTODD1(IBTRN)
+7 ;before adm
IF X<$PIECE(+IBCDT,".")
SET IBOK=0
GOTO DTCHKQ
+8 ; after disch
IF $PIECE(IBCDT,"^",2)
IF X>$PIECE(IBCDT,"^",2)
SET IBOK=0
GOTO DTCHKQ
+9 IF X>$$FMADD^XLFDT(DT,7)
SET IBOK=0
GOTO DTCHKQ
+10 ;
DTCHKQ QUIT IBOK
