IBQL356 ;LEB/MRY - UM ROLLUP - IBT DATA EXTRACTS ; 6-JUN-95
;;1.0;UTILIZATION MGMT ROLLUP LOCAL;**4**;Oct 01, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
Q
CLAIMS ; -- Extract Claims Tracking, Inpatient Provider, and Movement info.
; -- input: IBTRN from ^IBT(356,IBTRN...
; -- output: IB(array)=data from RESETC
D RESETC^IBQL356A S IBTRND=$G(^IBT(356,IBTRN,0)) I 'IBTRND S IBQUIT=1 Q
; -- get site and discharge date.
S IB(.02)=$P($$SITE^VASITE,"^",3),IB(.1)=$P($G(^IBT(356,IBTRN,1)),"^",9)
;-- get claims tracking data, entry id, admission, enrollement code
S IB(.01)=$P(IBTRND,"^"),DFN=$P(IBTRND,"^",2),IBNAM=$P($G(^DPT(DFN,0)),"^"),IB(.03)=$P($G(^DPT(DFN,0)),"^",9)
S IBR=$P(IBTRND,"^",25),IBD=$P(IBTRND,"^",26),IBL=$P(IBTRND,"^",27)
S IB(.05)=IBR_"-"_IBD_"-"_IBL I '(+IBR+IBD+IBL) S IB(.05)=""
S IB(1.06)=$S((+IBR+IBD)&(+IBL):"B",(+IBR+IBD):"N",(+IBL):"L",1:"")
S DGPM=$P(IBTRND,"^",5) I DGPM D
.S IB(.09)=$P($G(^DGPM(DGPM,0)),"^")
.; -- get inpatient provider data, admitting, attending, and resident physician
.S I="" F S I=$O(^IBT(356.94,"C",DGPM,I)) Q:'I S X=$G(^IBT(356.94,I,0)),IBTY=$P(X,"^",4),IB($S(IBTY=1:.07,IBTY=2:.08,IBTY=3:.06,1:"ERR"))=$P(X,"^",3)
.; - get patient movement data, treating specialty, ward, admitting diagnosis
.;S VAINDT=IB(.09) D INP^VADPT S IB(.12)=$P(VAIN(3),"^",2),IB(.11)=$P(VAIN(4),"^",2)
.;S IB(1.07)=$P($G(^DIC(42.4,+$P($G(^DIC(45.7,+$P($G(VAIN(3)),"^"),0)),"^",2),0)),"^",3)
.S X=+$O(^IBT(356.9,"ADG",DGPM,0)) S:X IB(.04)=$P(^ICD9(X,0),"^")
Q
;
ADMIT ; -- Extract Hospital Review Admission information
; -- input: IBTRV from ^IBT(356.1,IBTRN...
; -- output: IB(array)=data from RESETA
D RESETA^IBQL356A S IBTRVD=$G(^IBT(356.1,IBTRV,0)) I 'IBTRVD S IBQUIT=1 Q
; -- get hospital review admission data, acute adm?, si, is, reasons
; admission review
S IB(.13)=$P(IBTRVD,"^",6)!0,IB(1.01)=$P(IBTRVD,"^",4),IB(1.02)=$P(IBTRVD,"^",5),IB(1.04)=$P(IBTRVD,"^",10)!0,IB(1.05)=$P(IBTRVD,"^",11)!0
F I=1:1:3 Q:'$D(^IBT(356.1,IBTRV,12,I,0)) S X=+^(0),IB(1.03)=IB(1.03)_$P($G(^IBE(356.4,X,0)),"^",2)_" "
; -- if local and no si/is's and no reasons, try specialized units
I IBL,'IB(1.01),'IB(1.02),'IB(1.03) S IB(1.01)=$P(IBTRVD,"^",8),IB(1.02)=$P(IBTRVD,"^",9)
S:IB(1.01) IB(1.01)=$P(^IBE(356.3,IB(1.01),0),"^",3) S:IB(1.02) IB(1.02)=$P(^IBE(356.3,IB(1.02),0),"^",3)
; -- acute
I 'IB(1.03)!IB(.13) S IB("ACUTE ADMISSION")=1
S IB(.12)=$P($G(^DIC(45.7,+$P(IBTRVD,"^",7),0)),"^") I IB(.12)'="" S IB(1.07)=$P($G(^DIC(42.4,+$P($G(^DIC(45.7,+$P(IBTRVD,"^",7),0)),"^",2),0)),"^",3)
S VAINDT=$$VNDT^IBTRV(IBTRV) D INP^VADPT S:IB(.12)="" IB(.12)=$P(VAIN(3),"^",2),IB(1.07)=$P($G(^DIC(42.4,+$P($G(^DIC(45.7,+$P($G(VAIN(3)),"^"),0)),"^",2),0)),"^",3) S IB(.11)=$P(VAIN(4),"^",2)
Q
;
STAY ; -- Extract Continued Stay Review information
; -- input: IBTRN, IBTRV from ^IBT356,IBTRN...
; -- output: IB(array)=data from RESETS
D RESETS^IBQL356A S IBTRVD=$G(^IBT(356.1,IBTRV,0)) I 'IBTRVD S IBQUIT=1 Q
; -- get hospital review continued stay reviews, is, si, d/s, interviewed?, reasons
; continued stay reviews
S IB(13.01)=$P(IBTRVD,"^",3)
S IB(13.07)=$P($G(^DIC(45.7,+$P(IBTRVD,"^",7),0)),"^") I IB(13.07)'="" S IB(13.08)=$P($G(^DIC(42.4,+$P($G(^DIC(45.7,+$P(IBTRVD,"^",7),0)),"^",2),0)),"^",3)
I IB(13.07)="" S VAINDT=$$VNDT^IBTRV(IBTRV) D INP^VADPT S IB(13.07)=$P(VAIN(3),"^",2),IB(13.08)=$P($G(^DIC(42.4,+$P($G(^DIC(45.7,+$P($G(VAIN(3)),"^"),0)),"^",2),0)),"^",3)
S IB(13.03)=$P(IBTRVD,"^",4),IB(13.02)=$P(IBTRVD,"^",5),IB(13.04)=$P(IBTRVD,"^",12),IB(13.05)=$P(IBTRVD,"^",10)!0
S I=0,IBCNT=0 F S I=$O(^IBT(356.1,IBTRV,13,I)) Q:'I!(IBCNT>2) S IBCNT=IBCNT+1,X=+^IBT(356.1,IBTRV,13,I,0),IB(13.06)=IB(13.06)_$P($G(^IBE(356.4,X,0)),"^",2)_" "
; -- if local and no si/is's and no reasons, try specialized units
I IBL,'IB(13.03),'IB(13.02),'IB(13.06) S IB(13.03)=$P(IBTRVD,"^",8),IB(13.02)=$P(IBTRVD,"^",9)
S:IB(13.03) IB(13.03)=$P($G(^IBE(356.3,IB(13.03),0)),"^",3) S:IB(13.02) IB(13.02)=$P($G(^IBE(356.3,IB(13.02),0)),"^",3) S:IB(13.04) IB(13.04)=$P($G(^IBE(356.3,IB(13.04),0)),"^",3)
; -- if no d/c, no is, and no reasons, try 24 Hour Rule
I 'IB(13.04),'IB(13.02),'IB(13.06),IBPIS S IB(13.02)="24??"
; -- for 24 Hour Rule save previous Intensity of Service
S IBPIS=IB(13.02) S:IBPIS="24??" IBPIS=""
; acute stay
I 'IB(13.06) S IB("ACUTE STAY")=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBQL356 4430 printed Apr 09, 2024@21:43:29 Page 2
IBQL356 ;LEB/MRY - UM ROLLUP - IBT DATA EXTRACTS ; 6-JUN-95
+1 ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;**4**;Oct 01, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 QUIT
CLAIMS ; -- Extract Claims Tracking, Inpatient Provider, and Movement info.
+1 ; -- input: IBTRN from ^IBT(356,IBTRN...
+2 ; -- output: IB(array)=data from RESETC
+3 DO RESETC^IBQL356A
SET IBTRND=$GET(^IBT(356,IBTRN,0))
IF 'IBTRND
SET IBQUIT=1
QUIT
+4 ; -- get site and discharge date.
+5 SET IB(.02)=$PIECE($$SITE^VASITE,"^",3)
SET IB(.1)=$PIECE($GET(^IBT(356,IBTRN,1)),"^",9)
+6 ;-- get claims tracking data, entry id, admission, enrollement code
+7 SET IB(.01)=$PIECE(IBTRND,"^")
SET DFN=$PIECE(IBTRND,"^",2)
SET IBNAM=$PIECE($GET(^DPT(DFN,0)),"^")
SET IB(.03)=$PIECE($GET(^DPT(DFN,0)),"^",9)
+8 SET IBR=$PIECE(IBTRND,"^",25)
SET IBD=$PIECE(IBTRND,"^",26)
SET IBL=$PIECE(IBTRND,"^",27)
+9 SET IB(.05)=IBR_"-"_IBD_"-"_IBL
IF '(+IBR+IBD+IBL)
SET IB(.05)=""
+10 SET IB(1.06)=$SELECT((+IBR+IBD)&(+IBL):"B",(+IBR+IBD):"N",(+IBL):"L",1:"")
+11 SET DGPM=$PIECE(IBTRND,"^",5)
IF DGPM
Begin DoDot:1
+12 SET IB(.09)=$PIECE($GET(^DGPM(DGPM,0)),"^")
+13 ; -- get inpatient provider data, admitting, attending, and resident physician
+14 SET I=""
FOR
SET I=$ORDER(^IBT(356.94,"C",DGPM,I))
if 'I
QUIT
SET X=$GET(^IBT(356.94,I,0))
SET IBTY=$PIECE(X,"^",4)
SET IB($SELECT(IBTY=1:.07,IBTY=2:.08,IBTY=3:.06,1:"ERR"))=$PIECE(X,"^",3)
+15 ; - get patient movement data, treating specialty, ward, admitting diagnosis
+16 ;S VAINDT=IB(.09) D INP^VADPT S IB(.12)=$P(VAIN(3),"^",2),IB(.11)=$P(VAIN(4),"^",2)
+17 ;S IB(1.07)=$P($G(^DIC(42.4,+$P($G(^DIC(45.7,+$P($G(VAIN(3)),"^"),0)),"^",2),0)),"^",3)
+18 SET X=+$ORDER(^IBT(356.9,"ADG",DGPM,0))
if X
SET IB(.04)=$PIECE(^ICD9(X,0),"^")
End DoDot:1
+19 QUIT
+20 ;
ADMIT ; -- Extract Hospital Review Admission information
+1 ; -- input: IBTRV from ^IBT(356.1,IBTRN...
+2 ; -- output: IB(array)=data from RESETA
+3 DO RESETA^IBQL356A
SET IBTRVD=$GET(^IBT(356.1,IBTRV,0))
IF 'IBTRVD
SET IBQUIT=1
QUIT
+4 ; -- get hospital review admission data, acute adm?, si, is, reasons
+5 ; admission review
+6 SET IB(.13)=$PIECE(IBTRVD,"^",6)!0
SET IB(1.01)=$PIECE(IBTRVD,"^",4)
SET IB(1.02)=$PIECE(IBTRVD,"^",5)
SET IB(1.04)=$PIECE(IBTRVD,"^",10)!0
SET IB(1.05)=$PIECE(IBTRVD,"^",11)!0
+7 FOR I=1:1:3
if '$DATA(^IBT(356.1,IBTRV,12,I,0))
QUIT
SET X=+^(0)
SET IB(1.03)=IB(1.03)_$PIECE($GET(^IBE(356.4,X,0)),"^",2)_" "
+8 ; -- if local and no si/is's and no reasons, try specialized units
+9 IF IBL
IF 'IB(1.01)
IF 'IB(1.02)
IF 'IB(1.03)
SET IB(1.01)=$PIECE(IBTRVD,"^",8)
SET IB(1.02)=$PIECE(IBTRVD,"^",9)
+10 if IB(1.01)
SET IB(1.01)=$PIECE(^IBE(356.3,IB(1.01),0),"^",3)
if IB(1.02)
SET IB(1.02)=$PIECE(^IBE(356.3,IB(1.02),0),"^",3)
+11 ; -- acute
+12 IF 'IB(1.03)!IB(.13)
SET IB("ACUTE ADMISSION")=1
+13 SET IB(.12)=$PIECE($GET(^DIC(45.7,+$PIECE(IBTRVD,"^",7),0)),"^")
IF IB(.12)'=""
SET IB(1.07)=$PIECE($GET(^DIC(42.4,+$PIECE($GET(^DIC(45.7,+$PIECE(IBTRVD,"^",7),0)),"^",2),0)),"^",3)
+14 SET VAINDT=$$VNDT^IBTRV(IBTRV)
DO INP^VADPT
if IB(.12)=""
SET IB(.12)=$PIECE(VAIN(3),"^",2)
SET IB(1.07)=$PIECE($GET(^DIC(42.4,+$PIECE($GET(^DIC(45.7,+$PIECE($GET(VAIN(3)),"^"),0)),"^",2),0)),"^",3)
SET IB(.11)=$PIECE(VAIN(4),"^",2)
+15 QUIT
+16 ;
STAY ; -- Extract Continued Stay Review information
+1 ; -- input: IBTRN, IBTRV from ^IBT356,IBTRN...
+2 ; -- output: IB(array)=data from RESETS
+3 DO RESETS^IBQL356A
SET IBTRVD=$GET(^IBT(356.1,IBTRV,0))
IF 'IBTRVD
SET IBQUIT=1
QUIT
+4 ; -- get hospital review continued stay reviews, is, si, d/s, interviewed?, reasons
+5 ; continued stay reviews
+6 SET IB(13.01)=$PIECE(IBTRVD,"^",3)
+7 SET IB(13.07)=$PIECE($GET(^DIC(45.7,+$PIECE(IBTRVD,"^",7),0)),"^")
IF IB(13.07)'=""
SET IB(13.08)=$PIECE($GET(^DIC(42.4,+$PIECE($GET(^DIC(45.7,+$PIECE(IBTRVD,"^",7),0)),"^",2),0)),"^",3)
+8 IF IB(13.07)=""
SET VAINDT=$$VNDT^IBTRV(IBTRV)
DO INP^VADPT
SET IB(13.07)=$PIECE(VAIN(3),"^",2)
SET IB(13.08)=$PIECE($GET(^DIC(42.4,+$PIECE($GET(^DIC(45.7,+$PIECE($GET(VAIN(3)),"^"),0)),"^",2),0)),"^",3)
+9 SET IB(13.03)=$PIECE(IBTRVD,"^",4)
SET IB(13.02)=$PIECE(IBTRVD,"^",5)
SET IB(13.04)=$PIECE(IBTRVD,"^",12)
SET IB(13.05)=$PIECE(IBTRVD,"^",10)!0
+10 SET I=0
SET IBCNT=0
FOR
SET I=$ORDER(^IBT(356.1,IBTRV,13,I))
if 'I!(IBCNT>2)
QUIT
SET IBCNT=IBCNT+1
SET X=+^IBT(356.1,IBTRV,13,I,0)
SET IB(13.06)=IB(13.06)_$PIECE($GET(^IBE(356.4,X,0)),"^",2)_" "
+11 ; -- if local and no si/is's and no reasons, try specialized units
+12 IF IBL
IF 'IB(13.03)
IF 'IB(13.02)
IF 'IB(13.06)
SET IB(13.03)=$PIECE(IBTRVD,"^",8)
SET IB(13.02)=$PIECE(IBTRVD,"^",9)
+13 if IB(13.03)
SET IB(13.03)=$PIECE($GET(^IBE(356.3,IB(13.03),0)),"^",3)
if IB(13.02)
SET IB(13.02)=$PIECE($GET(^IBE(356.3,IB(13.02),0)),"^",3)
if IB(13.04)
SET IB(13.04)=$PIECE($GET(^IBE(356.3,IB(13.04),0)),"^",3)
+14 ; -- if no d/c, no is, and no reasons, try 24 Hour Rule
+15 IF 'IB(13.04)
IF 'IB(13.02)
IF 'IB(13.06)
IF IBPIS
SET IB(13.02)="24??"
+16 ; -- for 24 Hour Rule save previous Intensity of Service
+17 SET IBPIS=IB(13.02)
if IBPIS="24??"
SET IBPIS=""
+18 ; acute stay
+19 IF 'IB(13.06)
SET IB("ACUTE STAY")=1
+20 QUIT
