IBTRE6 ;ALB/AAS - CLAIMS TRACKING OUTPUT CLIN DATA ;2-SEP-1993
;;2.0;INTEGRATED BILLING;**210,461**;21-MAR-94;Build 58
;;Per VHA Directive 2004-038, this routine should not be modified.
;
ADMDIAG(IBTRN) ; -- output admitting diagnosis (inpatient)
;
N IBRES,IBDX,X
S IBRES=""
I '$G(IBTRN) G ADMDQ
S IBETYP=$$TRTP^IBTRE1(IBTRN) I IBETYP>1 G ADMDQ
S IBDX=+$O(^IBT(356.9,"ADG",+$P(^IBT(356,+IBTRN,0),"^",5),0))
I $D(VAIN(9)) S IBRES=VAIN(9) G ADMDQ
N VAIN,VAINDT,VA200
S VAINDT=$P($G(^IBT(356,+IBTRN,0)),U,6)
S VA200="" D INP^VADPT
S IBRES=VAIN(9)
ADMDQ Q IBRES
;
PDIAG(IBTRN) ; -- return primary diagnosis (inpatient)
N IBRES,IBDX
S IBRES=""
I '$G(IBTRN) G PDIAGQ
S IBDX=+$G(^IBT(356.9,+$O(^IBT(356.9,"ATP",+$P(^IBT(356,+IBTRN,0),"^",5),1,0)),0))
S IBRES=$$DIAG(IBDX,1,$$TRNDATE^IBACSV(IBTRN))
PDIAGQ Q IBRES
;
SDIAG ; -- return secondary diagnosis (inpatient
Q
;
ODIAG ; -- return outpatient diagnosis
Q
;
DIAG(IBDX,IBTXT,IBDT) ; -- Expand diagnosis from pointer
; -- input IBDX = pointer to diag
; IBTXT = if want text added (zero = number only)
N IBRES,IBZ
I '$G(IBDX) Q ""
S IBZ=$$ICD9^IBACSV(+IBDX,$G(IBDT)) I IBZ="" Q ""
S IBRES=$P(IBZ,U)
I $G(IBTXT) S IBRES=IBRES_" - "_$P(IBZ,U,3)
Q IBRES
;
;
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(IBPR,IBTXT) ; -- Expand procedure from pointer
; input IBPR=proc^^date (format of ^IBT(356.91,IEN,0))
; IBTXT = if want text added (zero = number only)
N IBRES,IBZ
I '$G(Z) S Z=1 ; what is that?
I '$G(IBPR) Q ""
S IBZ=$$ICD0^IBACSV(+IBPR,$P(IBPR,U,3))
S IBRES=$P(IBZ,U)
I $G(IBTXT),IBZ'="" S IBRES=IBRES_" - "_$P(IBZ,U,4)
Q IBRES
;
;
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
;
SETSDX(IBOE,IBSDX) ; get the list of Outpatient Encounter Diagnosis
; Output: IBSDX = count Dx's found, IBSDX(count) = V POV IEN ^ Dx IEN
N IBARR,IBI K IBSDX S IBSDX=0
Q:'$G(IBOE)
D GETDX^SDOE(+IBOE,"IBARR")
S IBI=0 F S IBI=$O(IBARR(IBI)) Q:'IBI S IBSDX=IBSDX+1,IBSDX(IBSDX)=IBI_U_+IBARR(IBI)
Q
;
LSTSDX(IBSDX) ; Print list of Outpatient Encounter Diagnosis
; Input: IBSDX = count Dx's found, IBSDX(count) = V POV pointer ^ Dx IEN
N IBI,IBDX W !
S IBI=0 F S IBI=$O(IBSDX(IBI)) Q:'IBI S IBDX=$$ICD9^IBACSV(+$P(IBSDX(IBI),U,2)) I IBDX'="" W !,?2,IBI,?5,$P(IBDX,U,1),?15,$E($P(IBDX,U,3),1,55)," (ICD-",$S($P(IBDX,U,19)=1:9,1:10),")"
Q
;
SETSDV(IBOE,IBSDV) ; get list of Outpatient Encounter Providers
; Output: IBSDV = count of Providers found, IBSDV(count) = V PROVIDER IEN ^ DX IEN
N IBARR,IBI K IBSDV S IBSDV=0
Q:'$G(IBOE)
D GETPRV^SDOE(+IBOE,"IBARR")
S IBI=0 F S IBI=$O(IBARR(IBI)) Q:'IBI S IBSDV=IBSDV+1,IBSDV(IBSDV)=IBI_U_+IBARR(IBI)
Q
;
LSTSDV(IBSDV) ; Print list of Outpatient Encounter Providers
; Input: IBSDV = count of Providers found, IBSDV(count) = V PROVIDER IEN ^ PROVIDER IEN
N IBI W ! S IBI=0 F S IBI=$O(IBSDV(IBI)) Q:'IBI W !,?2,IBI,?5,$P($G(^VA(200,+$P(IBSDV(IBI),U,2),0)),U)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRE6 5360 printed Oct 16, 2024@18:28:30 Page 2
IBTRE6 ;ALB/AAS - CLAIMS TRACKING OUTPUT CLIN DATA ;2-SEP-1993
+1 ;;2.0;INTEGRATED BILLING;**210,461**;21-MAR-94;Build 58
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
ADMDIAG(IBTRN) ; -- output admitting diagnosis (inpatient)
+1 ;
+2 NEW IBRES,IBDX,X
+3 SET IBRES=""
+4 IF '$GET(IBTRN)
GOTO ADMDQ
+5 SET IBETYP=$$TRTP^IBTRE1(IBTRN)
IF IBETYP>1
GOTO ADMDQ
+6 SET IBDX=+$ORDER(^IBT(356.9,"ADG",+$PIECE(^IBT(356,+IBTRN,0),"^",5),0))
+7 IF $DATA(VAIN(9))
SET IBRES=VAIN(9)
GOTO ADMDQ
+8 NEW VAIN,VAINDT,VA200
+9 SET VAINDT=$PIECE($GET(^IBT(356,+IBTRN,0)),U,6)
+10 SET VA200=""
DO INP^VADPT
+11 SET IBRES=VAIN(9)
ADMDQ QUIT IBRES
+1 ;
PDIAG(IBTRN) ; -- return primary diagnosis (inpatient)
+1 NEW IBRES,IBDX
+2 SET IBRES=""
+3 IF '$GET(IBTRN)
GOTO PDIAGQ
+4 SET IBDX=+$GET(^IBT(356.9,+$ORDER(^IBT(356.9,"ATP",+$PIECE(^IBT(356,+IBTRN,0),"^",5),1,0)),0))
+5 SET IBRES=$$DIAG(IBDX,1,$$TRNDATE^IBACSV(IBTRN))
PDIAGQ QUIT IBRES
+1 ;
SDIAG ; -- return secondary diagnosis (inpatient
+1 QUIT
+2 ;
ODIAG ; -- return outpatient diagnosis
+1 QUIT
+2 ;
DIAG(IBDX,IBTXT,IBDT) ; -- Expand diagnosis from pointer
+1 ; -- input IBDX = pointer to diag
+2 ; IBTXT = if want text added (zero = number only)
+3 NEW IBRES,IBZ
+4 IF '$GET(IBDX)
QUIT ""
+5 SET IBZ=$$ICD9^IBACSV(+IBDX,$GET(IBDT))
IF IBZ=""
QUIT ""
+6 SET IBRES=$PIECE(IBZ,U)
+7 IF $GET(IBTXT)
SET IBRES=IBRES_" - "_$PIECE(IBZ,U,3)
+8 QUIT IBRES
+9 ;
+10 ;
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(IBPR,IBTXT) ; -- Expand procedure from pointer
+1 ; input IBPR=proc^^date (format of ^IBT(356.91,IEN,0))
+2 ; IBTXT = if want text added (zero = number only)
+3 NEW IBRES,IBZ
+4 ; what is that?
IF '$GET(Z)
SET Z=1
+5 IF '$GET(IBPR)
QUIT ""
+6 SET IBZ=$$ICD0^IBACSV(+IBPR,$PIECE(IBPR,U,3))
+7 SET IBRES=$PIECE(IBZ,U)
+8 IF $GET(IBTXT)
IF IBZ'=""
SET IBRES=IBRES_" - "_$PIECE(IBZ,U,4)
+9 QUIT IBRES
+10 ;
+11 ;
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
+1 ;
SETSDX(IBOE,IBSDX) ; get the list of Outpatient Encounter Diagnosis
+1 ; Output: IBSDX = count Dx's found, IBSDX(count) = V POV IEN ^ Dx IEN
+2 NEW IBARR,IBI
KILL IBSDX
SET IBSDX=0
+3 if '$GET(IBOE)
QUIT
+4 DO GETDX^SDOE(+IBOE,"IBARR")
+5 SET IBI=0
FOR
SET IBI=$ORDER(IBARR(IBI))
if 'IBI
QUIT
SET IBSDX=IBSDX+1
SET IBSDX(IBSDX)=IBI_U_+IBARR(IBI)
+6 QUIT
+7 ;
LSTSDX(IBSDX) ; Print list of Outpatient Encounter Diagnosis
+1 ; Input: IBSDX = count Dx's found, IBSDX(count) = V POV pointer ^ Dx IEN
+2 NEW IBI,IBDX
WRITE !
+3 SET IBI=0
FOR
SET IBI=$ORDER(IBSDX(IBI))
if 'IBI
QUIT
SET IBDX=$$ICD9^IBACSV(+$PIECE(IBSDX(IBI),U,2))
IF IBDX'=""
WRITE !,?2,IBI,?5,$PIECE(IBDX,U,1),?15,$EXTRACT($PIECE(IBDX,U,3),1,55)," (ICD-",$SELECT($PIECE(IBDX,U,19)=1:9,1:10),")"
+4 QUIT
+5 ;
SETSDV(IBOE,IBSDV) ; get list of Outpatient Encounter Providers
+1 ; Output: IBSDV = count of Providers found, IBSDV(count) = V PROVIDER IEN ^ DX IEN
+2 NEW IBARR,IBI
KILL IBSDV
SET IBSDV=0
+3 if '$GET(IBOE)
QUIT
+4 DO GETPRV^SDOE(+IBOE,"IBARR")
+5 SET IBI=0
FOR
SET IBI=$ORDER(IBARR(IBI))
if 'IBI
QUIT
SET IBSDV=IBSDV+1
SET IBSDV(IBSDV)=IBI_U_+IBARR(IBI)
+6 QUIT
+7 ;
LSTSDV(IBSDV) ; Print list of Outpatient Encounter Providers
+1 ; Input: IBSDV = count of Providers found, IBSDV(count) = V PROVIDER IEN ^ PROVIDER IEN
+2 NEW IBI
WRITE !
SET IBI=0
FOR
SET IBI=$ORDER(IBSDV(IBI))
if 'IBI
QUIT
WRITE !,?2,IBI,?5,$PIECE($GET(^VA(200,+$PIECE(IBSDV(IBI),U,2),0)),U)
+3 QUIT
