IBQLLD ;LEB/MRY - LOAD UMR FILE ; 31-MAR-95
;;1.0;UTILIZATION MGMT ROLLUP LOCAL;**2**;Oct 01, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
I '$D(IBRPT) Q
; --
I '$D(DT) D DT^DICRW
D PULL^IBQLPL
I IBRPT="N" S IBDNLD="N" G START
W !!,"Create Rollup File"
;W !,"The next National Rollup will be " S Y=IBBDT X ^DD("DD") W Y_" to " S Y=IBEDT X ^DD("DD") W Y
I IBMSG'="" W !!,IBMSG,!,IBMSG1
;
DATE ; -- get date range
W ! D DATE^IBOUTL
I IBBDT=""!(IBEDT="") G END
S X1=IBEDT,X2=IBBDT D ^%DTC I X>365 W !,"<<< please report 1 years of information only. >>>" G DATE
;
S DIR(0)="SA^RD:RANDOM & DISEASE;L:LOCAL;A:ALL",DIR("A")="Random & Disease Cases, Local Cases or ALL Cases: ",DIR("B")="ALL" D ^DIR I $D(DUOUT)!($D(DTOUT)) G END
S IBDNLD=Y
F I="IBBDT","IBEDT","IBRPT","IBDNLD" S ZTSAVE(I)=""
S ZTRTN="START^IBQLLD",ZTDESC="IBQ - LOCAL ROLLUP ",ZTIO=""
D ^%ZTLOAD G END
;
START S IBDDT=IBBDT-.01,IBREC=0
F S IBDDT=$O(^IBT(356,"ADIS",IBDDT)) Q:'IBDDT!(IBDDT>IBEDT) D
.S IBTRN="" F S IBTRN=$O(^IBT(356,"ADIS",IBDDT,IBTRN)) Q:'IBTRN D
..I '$D(^IBT(356.1,"C",IBTRN))!'$G(^IBT(356,IBTRN,0)) Q
..D DATA
..Q
.Q
;
D TRANSMIT^IBQLLD1
;
END K IBDATA,X,I,DFN,DGPM,VAINDT,VAIN,IBRPT,IBFLD,IB,IBDDT,IBBDT,IBTRN,IBTRND,IBNAM,IBR,IBD,IBL,IBDNLD,IBHR,IBDAY,IBREC,IBORDER
Q
;
DATA ;
K IBDATA S IBQUIT=""
CLAIMS ; get Claims Tracking and misc. information into IB(array)
D CLAIMS^IBQL356 Q:IBQUIT
; -- quit if missing entry id, site, ssn, adm diagnosis, enroll code,
; admission, rollup type
F IBFLD=.01,.02,.03,.04,.05,.09,1.06 I IB(IBFLD)="" S IBQUIT=1 Q
; -- quit if EVENT TYPE not INPATIENT ADMISSION or INACTIVE.
I $P(IBTRND,"^",18)'=1!($P(IBTRND,"^",20)'=1) S IBQUIT=1 Q
Q:IBQUIT
Q:IBDNLD="N"&(IB(1.06)="L") Q:IBDNLD="L"&(IB(1.06)="N") Q:IBDNLD="RD"&(IB(1.06)="L")
;
ORDER ; -- check procedure ordering errors, arrange in DAY order.
S IBTRV=0
D ORDCHK^IBQLLD2
Q:IBQUIT
S IBDAY=0
F S IBDAY=$O(IBORDER(IBDAY)) Q:'IBDAY D Q:IBQUIT
.S IBTRV=IBORDER(IBDAY)
.I IBDAY=1 D ADMIT
.I IBDAY>1 D STAY
;
; -- quit if missing discharge date
I IB(.1)="" S IBQUIT=1 Q
;
LOAD ; -- load data into ^ibq(538, file
Q:IBQUIT Q:'$D(IBDATA(0)) Q:'$D(IBDATA(1))
D LOAD^IBQLLD1 S IBREC=IBREC+1
Q
;
;
ADMIT ; get Admission Review information into IB(array)
D ADMIT^IBQL356 Q:IBQUIT
; -- quit if missing treating specialty, service
F IBFLD=.12,1.07 I IB(IBFLD)="" S IBQUIT=1 Q
; -- quit if missing si, is and reason from admission
I IB(1.01)="",IB(1.02)="",IB(1.03)="" S IBQUIT=1 Q
; -- quit if not ACTIVE or not COMPLETE.
I $P(IBTRVD,"^",21)'=10 S IBQUIT=1 Q
S X="" F IBFLD=.01:.01:.13 S X=X_IBFLD_":"_IB(IBFLD)_"^"
S IBDATA(0)=$P(X,"^",1,$L(X,"^")-1)
S X="" F IBFLD=1.01:.01:1.07 S X=X_IBFLD_":"_IB(IBFLD)_"^"
S IBDATA(1)=$P(X,"^",1,$L(X,"^")-1)
S IBPIS=IB(1.02)
Q
;
STAY ; get Stay Review information into IB(array)
D STAY^IBQL356 Q:IBQUIT
; -- quit if missing 'is' AND missing 'reasons'
I IB(13.02)="",IB(13.06)="" S IBQUIT=1 Q
; -- quit if missing Treating Specialty in continued stay
I IB(13.07)="" S IBQUIT=1 Q
; -- quit if not ACTIVE or not COMPLETE.
I $P(IBTRVD,"^",21)'=10 S IBQUIT=1 Q
Q:IBQUIT
S X="" F IBFLD=13.01,13.02,13.03,13.04,13.05,13.06,13.07,13.08 S X=X_(IBFLD-13)_":"_IB(IBFLD)_"^"
S IBDATA(IB(13.01))=$P(X,"^",1,$L(X,"^")-1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBQLLD 3424 printed Dec 13, 2024@02:41:15 Page 2
IBQLLD ;LEB/MRY - LOAD UMR FILE ; 31-MAR-95
+1 ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;**2**;Oct 01, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 IF '$DATA(IBRPT)
QUIT
+5 ; --
+6 IF '$DATA(DT)
DO DT^DICRW
+7 DO PULL^IBQLPL
+8 IF IBRPT="N"
SET IBDNLD="N"
GOTO START
+9 WRITE !!,"Create Rollup File"
+10 ;W !,"The next National Rollup will be " S Y=IBBDT X ^DD("DD") W Y_" to " S Y=IBEDT X ^DD("DD") W Y
+11 IF IBMSG'=""
WRITE !!,IBMSG,!,IBMSG1
+12 ;
DATE ; -- get date range
+1 WRITE !
DO DATE^IBOUTL
+2 IF IBBDT=""!(IBEDT="")
GOTO END
+3 SET X1=IBEDT
SET X2=IBBDT
DO ^%DTC
IF X>365
WRITE !,"<<< please report 1 years of information only. >>>"
GOTO DATE
+4 ;
+5 SET DIR(0)="SA^RD:RANDOM & DISEASE;L:LOCAL;A:ALL"
SET DIR("A")="Random & Disease Cases, Local Cases or ALL Cases: "
SET DIR("B")="ALL"
DO ^DIR
IF $DATA(DUOUT)!($DATA(DTOUT))
GOTO END
+6 SET IBDNLD=Y
+7 FOR I="IBBDT","IBEDT","IBRPT","IBDNLD"
SET ZTSAVE(I)=""
+8 SET ZTRTN="START^IBQLLD"
SET ZTDESC="IBQ - LOCAL ROLLUP "
SET ZTIO=""
+9 DO ^%ZTLOAD
GOTO END
+10 ;
START SET IBDDT=IBBDT-.01
SET IBREC=0
+1 FOR
SET IBDDT=$ORDER(^IBT(356,"ADIS",IBDDT))
if 'IBDDT!(IBDDT>IBEDT)
QUIT
Begin DoDot:1
+2 SET IBTRN=""
FOR
SET IBTRN=$ORDER(^IBT(356,"ADIS",IBDDT,IBTRN))
if 'IBTRN
QUIT
Begin DoDot:2
+3 IF '$DATA(^IBT(356.1,"C",IBTRN))!'$GET(^IBT(356,IBTRN,0))
QUIT
+4 DO DATA
+5 QUIT
End DoDot:2
+6 QUIT
End DoDot:1
+7 ;
+8 DO TRANSMIT^IBQLLD1
+9 ;
END KILL IBDATA,X,I,DFN,DGPM,VAINDT,VAIN,IBRPT,IBFLD,IB,IBDDT,IBBDT,IBTRN,IBTRND,IBNAM,IBR,IBD,IBL,IBDNLD,IBHR,IBDAY,IBREC,IBORDER
+1 QUIT
+2 ;
DATA ;
+1 KILL IBDATA
SET IBQUIT=""
CLAIMS ; get Claims Tracking and misc. information into IB(array)
+1 DO CLAIMS^IBQL356
if IBQUIT
QUIT
+2 ; -- quit if missing entry id, site, ssn, adm diagnosis, enroll code,
+3 ; admission, rollup type
+4 FOR IBFLD=.01,.02,.03,.04,.05,.09,1.06
IF IB(IBFLD)=""
SET IBQUIT=1
QUIT
+5 ; -- quit if EVENT TYPE not INPATIENT ADMISSION or INACTIVE.
+6 IF $PIECE(IBTRND,"^",18)'=1!($PIECE(IBTRND,"^",20)'=1)
SET IBQUIT=1
QUIT
+7 if IBQUIT
QUIT
+8 if IBDNLD="N"&(IB(1.06)="L")
QUIT
if IBDNLD="L"&(IB(1.06)="N")
QUIT
if IBDNLD="RD"&(IB(1.06)="L")
QUIT
+9 ;
ORDER ; -- check procedure ordering errors, arrange in DAY order.
+1 SET IBTRV=0
+2 DO ORDCHK^IBQLLD2
+3 if IBQUIT
QUIT
+4 SET IBDAY=0
+5 FOR
SET IBDAY=$ORDER(IBORDER(IBDAY))
if 'IBDAY
QUIT
Begin DoDot:1
+6 SET IBTRV=IBORDER(IBDAY)
+7 IF IBDAY=1
DO ADMIT
+8 IF IBDAY>1
DO STAY
End DoDot:1
if IBQUIT
QUIT
+9 ;
+10 ; -- quit if missing discharge date
+11 IF IB(.1)=""
SET IBQUIT=1
QUIT
+12 ;
LOAD ; -- load data into ^ibq(538, file
+1 if IBQUIT
QUIT
if '$DATA(IBDATA(0))
QUIT
if '$DATA(IBDATA(1))
QUIT
+2 DO LOAD^IBQLLD1
SET IBREC=IBREC+1
+3 QUIT
+4 ;
+5 ;
ADMIT ; get Admission Review information into IB(array)
+1 DO ADMIT^IBQL356
if IBQUIT
QUIT
+2 ; -- quit if missing treating specialty, service
+3 FOR IBFLD=.12,1.07
IF IB(IBFLD)=""
SET IBQUIT=1
QUIT
+4 ; -- quit if missing si, is and reason from admission
+5 IF IB(1.01)=""
IF IB(1.02)=""
IF IB(1.03)=""
SET IBQUIT=1
QUIT
+6 ; -- quit if not ACTIVE or not COMPLETE.
+7 IF $PIECE(IBTRVD,"^",21)'=10
SET IBQUIT=1
QUIT
+8 SET X=""
FOR IBFLD=.01:.01:.13
SET X=X_IBFLD_":"_IB(IBFLD)_"^"
+9 SET IBDATA(0)=$PIECE(X,"^",1,$LENGTH(X,"^")-1)
+10 SET X=""
FOR IBFLD=1.01:.01:1.07
SET X=X_IBFLD_":"_IB(IBFLD)_"^"
+11 SET IBDATA(1)=$PIECE(X,"^",1,$LENGTH(X,"^")-1)
+12 SET IBPIS=IB(1.02)
+13 QUIT
+14 ;
STAY ; get Stay Review information into IB(array)
+1 DO STAY^IBQL356
if IBQUIT
QUIT
+2 ; -- quit if missing 'is' AND missing 'reasons'
+3 IF IB(13.02)=""
IF IB(13.06)=""
SET IBQUIT=1
QUIT
+4 ; -- quit if missing Treating Specialty in continued stay
+5 IF IB(13.07)=""
SET IBQUIT=1
QUIT
+6 ; -- quit if not ACTIVE or not COMPLETE.
+7 IF $PIECE(IBTRVD,"^",21)'=10
SET IBQUIT=1
QUIT
+8 if IBQUIT
QUIT
+9 SET X=""
FOR IBFLD=13.01,13.02,13.03,13.04,13.05,13.06,13.07,13.08
SET X=X_(IBFLD-13)_":"_IB(IBFLD)_"^"
+10 SET IBDATA(IB(13.01))=$PIECE(X,"^",1,$LENGTH(X,"^")-1)
+11 QUIT
