83 lines
3.3 KiB
Mathematica
83 lines
3.3 KiB
Mathematica
IBQLPL1 ;LEB/MRY - PATIENTS QUALIFY/MISSING INFO LIST ; 24-MAR-95
|
|
;;1.0;UTILIZATION MGMT ROLLUP LOCAL;**1**;Oct 01, 1995
|
|
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
Q
|
|
;
|
|
START ; -- loop thru discharges in Claims Tracking
|
|
S IBDDT=IBBDT-.01
|
|
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
|
|
..;
|
|
..S IBQUIT=0 D CLAIMS^IBQL356 Q:IBQUIT
|
|
..S IB(1.06)=$S(IB(1.06)="L":"ZL",IB(1.06)="":"AA",1:IB(1.06))
|
|
..;
|
|
..I IBRPT="Q" D QUALIFY
|
|
..I IBRPT="M" D MISSING
|
|
I $$STOP Q
|
|
Q
|
|
;
|
|
QUALIFY ; --list patients to be included in Rollup
|
|
S DFN=$P(IBTRND,"^",2),X=$G(^DPT(DFN,0))
|
|
S IBNAM=$P(X,"^"),SSN=$P(X,"^",9) S:SSN ^TMP("IBQLPL",$J,IB(1.06),IBDDT,SSN)=IBNAM
|
|
Q
|
|
;
|
|
;
|
|
MISSING ; -- list patients with missing data
|
|
;
|
|
; -- send message if missing adm diagnosis, enroll code, adm
|
|
F IBFLD=.04,.05,.09 D ERR I IBERR'="" S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),IBFLD)=IBERR
|
|
; -- check for (.0001) fundemental completion errors
|
|
I $P(IBTRND,"^",18)'=1 D
|
|
.S IBERR="EVENT TYPE NOT OF INPATIENT ADMISSION (#"_IB(.01)_")"
|
|
.S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),.0001)=IBERR
|
|
I $P(IBTRND,"^",20)'=1 D
|
|
.S IBERR="CLAIMS TRACKING ENTRY IS INACTIVE (#"_IB(.01)_")"
|
|
.S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),.0002)=IBERR
|
|
;
|
|
ORDER ; -- check (.001) procedure ordering errors, arrange in DAY order.
|
|
S IBTRV=0
|
|
D ORDCHK^IBQLPL3
|
|
Q:IB001
|
|
S IBDAY=0
|
|
F S IBDAY=$O(IBORDER(IBDAY)) Q:'IBDAY D
|
|
.S IBTRV=IBORDER(IBDAY)
|
|
.I IBDAY=1 D ADMIT
|
|
.I IBDAY>1 D STAY
|
|
I $O(^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),0)) S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03))=IBNAM
|
|
Q
|
|
;
|
|
ADMIT ; get Admission Review infomation into IB(array)
|
|
D ADMIT^IBQL356 Q:IBQUIT
|
|
; -- send message if no treating specialty, service
|
|
F IBFLD=.12,1.07 D ERR I IBERR'="" S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),IBFLD)=IBERR
|
|
; -- send message if si,is, reasons are not answered
|
|
I IB(1.01)="",IB(1.02)="",IB(1.03)="" F IBFLD=1.01,1.02,1.03 D ERR I IBERR'="" S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),IBFLD)=IBERR
|
|
; -- check for (.0001) fundemetally completion errors
|
|
I $P(IBTRVD,"^",21)'=10 D
|
|
.S IBERR="Admission Stay not COMPLETE (#"_IB(.01)_")"
|
|
.S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),.0004)=IBERR
|
|
S IBPIS=IB(1.02)
|
|
Q
|
|
;
|
|
STAY ; get Stay Review information into IB(array)
|
|
D STAY^IBQL356 Q:IBQUIT
|
|
F IBFLD=13.07,13.08 D ERR I IBERR'="" S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),(IB(13.01)+IBFLD))=IBERR
|
|
I IB(13.02)="",IB(13.06)="" F IBFLD=13.02,13.06 D ERR I IBERR'="" S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),(IB(13.01)+IBFLD))=IBERR
|
|
; -- check for (.0001) fundementally completion errors
|
|
I $P(IBTRVD,"^",21)'=10 D
|
|
.S IBERR="STAY DAY "_IB(13.01)_" NOT COMPLETE (#"_IB(.01)_")"
|
|
.S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),(IB(13.01)+.0004))=IBERR
|
|
Q
|
|
;
|
|
ERR ; -- return missing message
|
|
S IBERR=""
|
|
I IB(IBFLD)="" S IBERR="MISSING "_IBD(IBFLD) S:IBFLD>13 IBERR=IBERR_" DAY "_IB(13.01) S IBERR=IBERR_" (#"_IB(.01)_")"
|
|
Q
|
|
ERR1 ; -- return error message that entry EVENT TYPE is not Inpatient status.
|
|
S IBERR="EVENT TYPE not of INPATIENT ADMISSION (#"_IB(.01)_")"
|
|
Q
|
|
STOP() ;determine if user has requested the queued report to stop
|
|
I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ I +$G(IBPAG) W !,"***TASK STOPPED BY USER***"
|
|
Q +$G(ZTSTOP)
|