- 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 Mar 13, 2025@21:45:48 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
