IBTRE6.m

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