IBQLPL3 ;LEB/MRY - PATIENTS QUALIFY/MISSING LIST ; 18-AUG-95
;;1.0;UTILIZATION MGMT ROLLUP LOCAL;**1**;Oct 01, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
Q
ORDCHK ; -- edit check the UR procedure in entering reviews (.001 errors).
S (IBTRV,IB001)=0 K IBORDER
F S IBTRV=$O(^IBT(356.1,"C",IBTRN,IBTRV)) Q:'IBTRV D
.S IBTRVD=$G(^IBT(356.1,IBTRV,0)) I '+IBTRVD D S IB001=1
..S IBERR="Bad cross-reference in Reviews (#"_IB(.01)_")"
..S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),.001)=IBERR
.; -- ignore INACTIVE review entries.
.I '$P(IBTRVD,"^",19)!'$P(IBTRVD,"^",21) Q
.I '$P(IBTRVD,"^",3) D S IB001=1
..S IBERR="No DAY entered in Reviews (#"_IB(.01)_")"
..S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),.002)=IBERR
.I $D(IBORDER(+$P(IBTRVD,"^",3))) D S IB001=1
..S IBERR="Review entries contain same DAY (#"_IB(.01)_")"
..S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),.003)=IBERR
.I 'IB001 S IBORDER($P(IBTRVD,"^",3))=IBTRV
S IBDAY=0
F IBCNT=1:1 S IBDAY=$O(IBORDER(IBDAY)) Q:'IBDAY D
.I IBDAY'=IBCNT D S IB001=1
..S IBERR="DAY entries not in consecutive order (#"_IB(.01)_")"
..S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),.004)=IBERR
;
END ; -- clean up
I $O(^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),0)) S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03))=IBNAM
K IBDAY,IBCNT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBQLPL3 1346 printed Nov 22, 2024@17:51:18 Page 2
IBQLPL3 ;LEB/MRY - PATIENTS QUALIFY/MISSING LIST ; 18-AUG-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
ORDCHK ; -- edit check the UR procedure in entering reviews (.001 errors).
+1 SET (IBTRV,IB001)=0
KILL IBORDER
+2 FOR
SET IBTRV=$ORDER(^IBT(356.1,"C",IBTRN,IBTRV))
if 'IBTRV
QUIT
Begin DoDot:1
+3 SET IBTRVD=$GET(^IBT(356.1,IBTRV,0))
IF '+IBTRVD
Begin DoDot:2
+4 SET IBERR="Bad cross-reference in Reviews (#"_IB(.01)_")"
+5 SET ^TMP("IBQLPL",$JOB,IB(1.06),IBDDT,IB(.03),.001)=IBERR
End DoDot:2
SET IB001=1
+6 ; -- ignore INACTIVE review entries.
+7 IF '$PIECE(IBTRVD,"^",19)!'$PIECE(IBTRVD,"^",21)
QUIT
+8 IF '$PIECE(IBTRVD,"^",3)
Begin DoDot:2
+9 SET IBERR="No DAY entered in Reviews (#"_IB(.01)_")"
+10 SET ^TMP("IBQLPL",$JOB,IB(1.06),IBDDT,IB(.03),.002)=IBERR
End DoDot:2
SET IB001=1
+11 IF $DATA(IBORDER(+$PIECE(IBTRVD,"^",3)))
Begin DoDot:2
+12 SET IBERR="Review entries contain same DAY (#"_IB(.01)_")"
+13 SET ^TMP("IBQLPL",$JOB,IB(1.06),IBDDT,IB(.03),.003)=IBERR
End DoDot:2
SET IB001=1
+14 IF 'IB001
SET IBORDER($PIECE(IBTRVD,"^",3))=IBTRV
End DoDot:1
+15 SET IBDAY=0
+16 FOR IBCNT=1:1
SET IBDAY=$ORDER(IBORDER(IBDAY))
if 'IBDAY
QUIT
Begin DoDot:1
+17 IF IBDAY'=IBCNT
Begin DoDot:2
+18 SET IBERR="DAY entries not in consecutive order (#"_IB(.01)_")"
+19 SET ^TMP("IBQLPL",$JOB,IB(1.06),IBDDT,IB(.03),.004)=IBERR
End DoDot:2
SET IB001=1
End DoDot:1
+20 ;
END ; -- clean up
+1 IF $ORDER(^TMP("IBQLPL",$JOB,IB(1.06),IBDDT,IB(.03),0))
SET ^TMP("IBQLPL",$JOB,IB(1.06),IBDDT,IB(.03))=IBNAM
+2 KILL IBDAY,IBCNT
+3 QUIT
