- 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 Mar 13, 2025@21:46:06 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
