- 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 Jan 18, 2025@03:29:04 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