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)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBQLPL1 3449 printed Nov 22, 2024@17:51:16 Page 2
IBQLPL1 ;LEB/MRY - PATIENTS QUALIFY/MISSING INFO LIST ; 24-MAR-95
+1 ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;**1**;Oct 01, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
START ; -- loop thru discharges in Claims Tracking
+1 SET IBDDT=IBBDT-.01
+2 FOR
SET IBDDT=$ORDER(^IBT(356,"ADIS",IBDDT))
if 'IBDDT!(IBDDT>IBEDT)
QUIT
Begin DoDot:1
+3 SET IBTRN=""
FOR
SET IBTRN=$ORDER(^IBT(356,"ADIS",IBDDT,IBTRN))
if 'IBTRN
QUIT
Begin DoDot:2
+4 IF '$DATA(^IBT(356.1,"C",IBTRN))!'$GET(^IBT(356,IBTRN,0))
QUIT
+5 ;
+6 SET IBQUIT=0
DO CLAIMS^IBQL356
if IBQUIT
QUIT
+7 SET IB(1.06)=$SELECT(IB(1.06)="L":"ZL",IB(1.06)="":"AA",1:IB(1.06))
+8 ;
+9 IF IBRPT="Q"
DO QUALIFY
+10 IF IBRPT="M"
DO MISSING
End DoDot:2
End DoDot:1
+11 IF $$STOP
QUIT
+12 QUIT
+13 ;
QUALIFY ; --list patients to be included in Rollup
+1 SET DFN=$PIECE(IBTRND,"^",2)
SET X=$GET(^DPT(DFN,0))
+2 SET IBNAM=$PIECE(X,"^")
SET SSN=$PIECE(X,"^",9)
if SSN
SET ^TMP("IBQLPL",$JOB,IB(1.06),IBDDT,SSN)=IBNAM
+3 QUIT
+4 ;
+5 ;
MISSING ; -- list patients with missing data
+1 ;
+2 ; -- send message if missing adm diagnosis, enroll code, adm
+3 FOR IBFLD=.04,.05,.09
DO ERR
IF IBERR'=""
SET ^TMP("IBQLPL",$JOB,IB(1.06),IBDDT,IB(.03),IBFLD)=IBERR
+4 ; -- check for (.0001) fundemental completion errors
+5 IF $PIECE(IBTRND,"^",18)'=1
Begin DoDot:1
+6 SET IBERR="EVENT TYPE NOT OF INPATIENT ADMISSION (#"_IB(.01)_")"
+7 SET ^TMP("IBQLPL",$JOB,IB(1.06),IBDDT,IB(.03),.0001)=IBERR
End DoDot:1
+8 IF $PIECE(IBTRND,"^",20)'=1
Begin DoDot:1
+9 SET IBERR="CLAIMS TRACKING ENTRY IS INACTIVE (#"_IB(.01)_")"
+10 SET ^TMP("IBQLPL",$JOB,IB(1.06),IBDDT,IB(.03),.0002)=IBERR
End DoDot:1
+11 ;
ORDER ; -- check (.001) procedure ordering errors, arrange in DAY order.
+1 SET IBTRV=0
+2 DO ORDCHK^IBQLPL3
+3 if IB001
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
+9 IF $ORDER(^TMP("IBQLPL",$JOB,IB(1.06),IBDDT,IB(.03),0))
SET ^TMP("IBQLPL",$JOB,IB(1.06),IBDDT,IB(.03))=IBNAM
+10 QUIT
+11 ;
ADMIT ; get Admission Review infomation into IB(array)
+1 DO ADMIT^IBQL356
if IBQUIT
QUIT
+2 ; -- send message if no treating specialty, service
+3 FOR IBFLD=.12,1.07
DO ERR
IF IBERR'=""
SET ^TMP("IBQLPL",$JOB,IB(1.06),IBDDT,IB(.03),IBFLD)=IBERR
+4 ; -- send message if si,is, reasons are not answered
+5 IF IB(1.01)=""
IF IB(1.02)=""
IF IB(1.03)=""
FOR IBFLD=1.01,1.02,1.03
DO ERR
IF IBERR'=""
SET ^TMP("IBQLPL",$JOB,IB(1.06),IBDDT,IB(.03),IBFLD)=IBERR
+6 ; -- check for (.0001) fundemetally completion errors
+7 IF $PIECE(IBTRVD,"^",21)'=10
Begin DoDot:1
+8 SET IBERR="Admission Stay not COMPLETE (#"_IB(.01)_")"
+9 SET ^TMP("IBQLPL",$JOB,IB(1.06),IBDDT,IB(.03),.0004)=IBERR
End DoDot:1
+10 SET IBPIS=IB(1.02)
+11 QUIT
+12 ;
STAY ; get Stay Review information into IB(array)
+1 DO STAY^IBQL356
if IBQUIT
QUIT
+2 FOR IBFLD=13.07,13.08
DO ERR
IF IBERR'=""
SET ^TMP("IBQLPL",$JOB,IB(1.06),IBDDT,IB(.03),(IB(13.01)+IBFLD))=IBERR
+3 IF IB(13.02)=""
IF IB(13.06)=""
FOR IBFLD=13.02,13.06
DO ERR
IF IBERR'=""
SET ^TMP("IBQLPL",$JOB,IB(1.06),IBDDT,IB(.03),(IB(13.01)+IBFLD))=IBERR
+4 ; -- check for (.0001) fundementally completion errors
+5 IF $PIECE(IBTRVD,"^",21)'=10
Begin DoDot:1
+6 SET IBERR="STAY DAY "_IB(13.01)_" NOT COMPLETE (#"_IB(.01)_")"
+7 SET ^TMP("IBQLPL",$JOB,IB(1.06),IBDDT,IB(.03),(IB(13.01)+.0004))=IBERR
End DoDot:1
+8 QUIT
+9 ;
ERR ; -- return missing message
+1 SET IBERR=""
+2 IF IB(IBFLD)=""
SET IBERR="MISSING "_IBD(IBFLD)
if IBFLD>13
SET IBERR=IBERR_" DAY "_IB(13.01)
SET IBERR=IBERR_" (#"_IB(.01)_")"
+3 QUIT
ERR1 ; -- return error message that entry EVENT TYPE is not Inpatient status.
+1 SET IBERR="EVENT TYPE not of INPATIENT ADMISSION (#"_IB(.01)_")"
+2 QUIT
STOP() ;determine if user has requested the queued report to stop
+1 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET ZTSTOP=1
KILL ZTREQ
IF +$GET(IBPAG)
WRITE !,"***TASK STOPPED BY USER***"
+2 QUIT +$GET(ZTSTOP)
