IBQLR2A ;LEB/MRY - PATIENT REPORT ; 1-JUN-95
;;1.0;UTILIZATION MGMT ROLLUP LOCAL;;Oct 01, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
PRINT D SVCTAB^IBQLR1B S (IBDATA,IBTS,IBQUIT,IBHDR,IBHDR1,IBSVC)="",IBPAG=0
; -- call to return header dates - IBTDT, IBDRNG
D DTC^IBQLPL2
S IBHDR="UTILIZATION MANAGEMENT",IBHDR2="PATIENT REVIEWS FOR "_IBDRNG S:IBTY="S" IBHDR1="SERVICE" S:IBTY="T" IBHDR1="TREATING SPECIALTY,(SERVICE)"
;
I '$D(^TMP("IBQLR2",$J)) D HDR W !!,?20,"<<< NO PATIENTS TO PRINT >>>" Q
F S IBSVC=$O(^TMP("IBQLR2",$J,IBSVC)) Q:IBSVC="" D TS Q:IBQUIT
G END
TS F S IBTS=$O(^TMP("IBQLR2",$J,IBSVC,IBTS)) Q:IBTS="" D Q:IBQUIT
.I IBTS=999 S IBSUBH=$S($D(IBSVC(IBSVC)):IBSVC(IBSVC),1:IBSVC("UNK"))
.E S IBSUBH=IBTS_",("_$S($D(IBSVC(IBSVC)):IBSVC(IBSVC),1:IBSVC("UNK"))_")"
.D PLINE
.S IBDDT="" F S IBDDT=$O(^TMP("IBQLR2",$J,IBSVC,IBTS,IBDDT)) Q:'IBDDT D Q:IBQUIT
..S IBSSN="" F S IBSSN=$O(^TMP("IBQLR2",$J,IBSVC,IBTS,IBDDT,IBSSN)) Q:'IBSSN D DATA Q:IBQUIT
Q
;
END K IBDATA,IBTS,IBADM,IBADIAG,IBENRLL,IBPHYAD,IBPHYAT,IBPHYRS,IBAAD,IBRAD,IBLOS,IBRSYCNT,IBHDR,IBHDR1,IBDRNG,IBDT,IBRSY,IBSSN,IBTDT,IBTRND1,IBTRV,IBTRVD
Q
;
DATA ;
S IBDATA=^TMP("IBQLR2",$J,IBSVC,IBTS,IBDDT,IBSSN)
S IBADM=$P(IBDATA,"^"),IBADIAG=$P(IBDATA,"^",2),IBENRLL=$P(IBDATA,"^",3)
S IBPHYAD=$P(IBDATA,"^",4),IBPHYAT=$P(IBDATA,"^",5),IBPHYRS=$P(IBDATA,"^",6)
S IBAAD=$P(IBDATA,"^",7),IBNAD=$P(IBDATA,"^",8),IBRAD=$P(IBDATA,"^",9)
S IBLOS=$G(^TMP("IBQLR2",$J,IBSVC,IBTS,IBDDT,IBSSN,"LOS"))
S IBSACNT=$G(^TMP("IBQLR2",$J,IBSVC,IBTS,IBDDT,IBSSN,"S-AC"))
S IBSNCNT=$G(^TMP("IBQLR2",$J,IBSVC,IBTS,IBDDT,IBSSN,"S-NAC"))
K IBRSY S IBRSY=""
F S IBRSY=$O(^TMP("IBQLR2",$J,IBSVC,IBTS,IBDDT,IBSSN,IBRSY)) Q:'IBRSY D
.S IBRSYCNT=^TMP("IBQLR2",$J,IBSVC,IBTS,IBDDT,IBSSN,IBRSY)
.S IBRSY(9999-IBRSYCNT,IBRSY)=""
D PLINE
Q
;
PLINE ;
I IBPAG=0 D HDR
D CHKL Q:IBQUIT
I IBSUBH'="",'$G(IBSSN) W !!,IBSUBH,! Q
W !,IBSSN,?11 S IBDT=IBADM D DTC W $J(IBDT,8) W ?20 S IBDT=IBDDT D DTC W $J(IBDT,8)
W ?29,IBADIAG,?37,IBENRLL,?45,$P(IBRAD," "),?52,$P(IBRAD," ",2),?58,$J(IBLOS,4),?63,$J(IBSACNT,4),?68,$J(IBSNCNT,4)
W ?73 S (RCNT,CNT)="" F S RCNT=$O(IBRSY(RCNT)) Q:'RCNT S REA="" D Q:CNT=4
.F S REA=$O(IBRSY(RCNT,REA)) Q:REA="" D Q:CNT=4
..W ?($X+2),$J(REA_"/"_(9999-RCNT),8)," " S CNT=CNT+1
;W ?85 S RCNT="" F I=1:1:3 S RCNT=$O(IBRSY(RCNT)) Q:'RCNT D ; for Download rpt. use F S RCNT=$O(...
;.W ?($X+2),$J(IBRSY(RCNT),6),?($X+2),$J(9999-RCNT,3)
Q
;
HDR ;
W:$E(IOST,1,2)["C-"!(IBPAG>0) @IOF S IBPAG=IBPAG+1
W !,IBTDT,?(IOM-$L(IBHDR)/2),IBHDR,?(IOM-10),"PAGE ",IBPAG
W !,?(IOM-$L(IBHDR1)/2),IBHDR1,!,?(IOM-$L(IBHDR2)/2),IBHDR2
W !!,?11,"ADMIT",?20,"DISCH",?37,"ENRLL",?45,"ADM. REASONS",?63,"#AC",?68,"#N-AC"
W ?76,"C O N T I N U E D S T A Y R E A S O N S"
;W ?73 F I=1:1:4 D ; for Download rpt. use F I=1:1:IBLVH
;.W ?($X+2),$J("S-REA",6),?($X+2)," "
W !,"SSN",?11,"DATE",?20,"DATE",?29,"DIAG",?37,"R-D-L",?45,"1",?52,"2",?58,"#LOS",?63,"DAYS",?68,"DAYS"
W ?73 F I=1:1:4 D ; for Download rpt. use F I=1:1:IBLVH
.W ?($X+2),$J(I_"/CNT",6),?($X+2)," "
W !,$TR($J("",IOM)," ","-")
Q
;
CHKL ; -- check end of page
I IOSL<($Y+5),$E(IOST,1,2)="C-" D PAUSE^VALM1 S:$D(DIRUT) IBQUIT=1 Q:IBQUIT W @IOF D HDR Q
I IOSL<($Y+5) D HDR
Q
;
DTC S IBDT=+$E(IBDT,4,5)_"/"_$E(IBDT,6,7)_"/"_$E(IBDT,2,3)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBQLR2A 3432 printed Dec 13, 2024@02:41:29 Page 2
IBQLR2A ;LEB/MRY - PATIENT REPORT ; 1-JUN-95
+1 ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;;Oct 01, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
PRINT DO SVCTAB^IBQLR1B
SET (IBDATA,IBTS,IBQUIT,IBHDR,IBHDR1,IBSVC)=""
SET IBPAG=0
+1 ; -- call to return header dates - IBTDT, IBDRNG
+2 DO DTC^IBQLPL2
+3 SET IBHDR="UTILIZATION MANAGEMENT"
SET IBHDR2="PATIENT REVIEWS FOR "_IBDRNG
if IBTY="S"
SET IBHDR1="SERVICE"
if IBTY="T"
SET IBHDR1="TREATING SPECIALTY,(SERVICE)"
+4 ;
+5 IF '$DATA(^TMP("IBQLR2",$JOB))
DO HDR
WRITE !!,?20,"<<< NO PATIENTS TO PRINT >>>"
QUIT
+6 FOR
SET IBSVC=$ORDER(^TMP("IBQLR2",$JOB,IBSVC))
if IBSVC=""
QUIT
DO TS
if IBQUIT
QUIT
+7 GOTO END
TS FOR
SET IBTS=$ORDER(^TMP("IBQLR2",$JOB,IBSVC,IBTS))
if IBTS=""
QUIT
Begin DoDot:1
+1 IF IBTS=999
SET IBSUBH=$SELECT($DATA(IBSVC(IBSVC)):IBSVC(IBSVC),1:IBSVC("UNK"))
+2 IF '$TEST
SET IBSUBH=IBTS_",("_$SELECT($DATA(IBSVC(IBSVC)):IBSVC(IBSVC),1:IBSVC("UNK"))_")"
+3 DO PLINE
+4 SET IBDDT=""
FOR
SET IBDDT=$ORDER(^TMP("IBQLR2",$JOB,IBSVC,IBTS,IBDDT))
if 'IBDDT
QUIT
Begin DoDot:2
+5 SET IBSSN=""
FOR
SET IBSSN=$ORDER(^TMP("IBQLR2",$JOB,IBSVC,IBTS,IBDDT,IBSSN))
if 'IBSSN
QUIT
DO DATA
if IBQUIT
QUIT
End DoDot:2
if IBQUIT
QUIT
End DoDot:1
if IBQUIT
QUIT
+6 QUIT
+7 ;
END KILL IBDATA,IBTS,IBADM,IBADIAG,IBENRLL,IBPHYAD,IBPHYAT,IBPHYRS,IBAAD,IBRAD,IBLOS,IBRSYCNT,IBHDR,IBHDR1,IBDRNG,IBDT,IBRSY,IBSSN,IBTDT,IBTRND1,IBTRV,IBTRVD
+1 QUIT
+2 ;
DATA ;
+1 SET IBDATA=^TMP("IBQLR2",$JOB,IBSVC,IBTS,IBDDT,IBSSN)
+2 SET IBADM=$PIECE(IBDATA,"^")
SET IBADIAG=$PIECE(IBDATA,"^",2)
SET IBENRLL=$PIECE(IBDATA,"^",3)
+3 SET IBPHYAD=$PIECE(IBDATA,"^",4)
SET IBPHYAT=$PIECE(IBDATA,"^",5)
SET IBPHYRS=$PIECE(IBDATA,"^",6)
+4 SET IBAAD=$PIECE(IBDATA,"^",7)
SET IBNAD=$PIECE(IBDATA,"^",8)
SET IBRAD=$PIECE(IBDATA,"^",9)
+5 SET IBLOS=$GET(^TMP("IBQLR2",$JOB,IBSVC,IBTS,IBDDT,IBSSN,"LOS"))
+6 SET IBSACNT=$GET(^TMP("IBQLR2",$JOB,IBSVC,IBTS,IBDDT,IBSSN,"S-AC"))
+7 SET IBSNCNT=$GET(^TMP("IBQLR2",$JOB,IBSVC,IBTS,IBDDT,IBSSN,"S-NAC"))
+8 KILL IBRSY
SET IBRSY=""
+9 FOR
SET IBRSY=$ORDER(^TMP("IBQLR2",$JOB,IBSVC,IBTS,IBDDT,IBSSN,IBRSY))
if 'IBRSY
QUIT
Begin DoDot:1
+10 SET IBRSYCNT=^TMP("IBQLR2",$JOB,IBSVC,IBTS,IBDDT,IBSSN,IBRSY)
+11 SET IBRSY(9999-IBRSYCNT,IBRSY)=""
End DoDot:1
+12 DO PLINE
+13 QUIT
+14 ;
PLINE ;
+1 IF IBPAG=0
DO HDR
+2 DO CHKL
if IBQUIT
QUIT
+3 IF IBSUBH'=""
IF '$GET(IBSSN)
WRITE !!,IBSUBH,!
QUIT
+4 WRITE !,IBSSN,?11
SET IBDT=IBADM
DO DTC
WRITE $JUSTIFY(IBDT,8)
WRITE ?20
SET IBDT=IBDDT
DO DTC
WRITE $JUSTIFY(IBDT,8)
+5 WRITE ?29,IBADIAG,?37,IBENRLL,?45,$PIECE(IBRAD," "),?52,$PIECE(IBRAD," ",2),?58,$JUSTIFY(IBLOS,4),?63,$JUSTIFY(IBSACNT,4),?68,$JUSTIFY(IBSNCNT,4)
+6 WRITE ?73
SET (RCNT,CNT)=""
FOR
SET RCNT=$ORDER(IBRSY(RCNT))
if 'RCNT
QUIT
SET REA=""
Begin DoDot:1
+7 FOR
SET REA=$ORDER(IBRSY(RCNT,REA))
if REA=""
QUIT
Begin DoDot:2
+8 WRITE ?($X+2),$JUSTIFY(REA_"/"_(9999-RCNT),8)," "
SET CNT=CNT+1
End DoDot:2
if CNT=4
QUIT
End DoDot:1
if CNT=4
QUIT
+9 ;W ?85 S RCNT="" F I=1:1:3 S RCNT=$O(IBRSY(RCNT)) Q:'RCNT D ; for Download rpt. use F S RCNT=$O(...
+10 ;.W ?($X+2),$J(IBRSY(RCNT),6),?($X+2),$J(9999-RCNT,3)
+11 QUIT
+12 ;
HDR ;
+1 if $EXTRACT(IOST,1,2)["C-"!(IBPAG>0)
WRITE @IOF
SET IBPAG=IBPAG+1
+2 WRITE !,IBTDT,?(IOM-$LENGTH(IBHDR)/2),IBHDR,?(IOM-10),"PAGE ",IBPAG
+3 WRITE !,?(IOM-$LENGTH(IBHDR1)/2),IBHDR1,!,?(IOM-$LENGTH(IBHDR2)/2),IBHDR2
+4 WRITE !!,?11,"ADMIT",?20,"DISCH",?37,"ENRLL",?45,"ADM. REASONS",?63,"#AC",?68,"#N-AC"
+5 WRITE ?76,"C O N T I N U E D S T A Y R E A S O N S"
+6 ;W ?73 F I=1:1:4 D ; for Download rpt. use F I=1:1:IBLVH
+7 ;.W ?($X+2),$J("S-REA",6),?($X+2)," "
+8 WRITE !,"SSN",?11,"DATE",?20,"DATE",?29,"DIAG",?37,"R-D-L",?45,"1",?52,"2",?58,"#LOS",?63,"DAYS",?68,"DAYS"
+9 ; for Download rpt. use F I=1:1:IBLVH
WRITE ?73
FOR I=1:1:4
Begin DoDot:1
+10 WRITE ?($X+2),$JUSTIFY(I_"/CNT",6),?($X+2)," "
End DoDot:1
+11 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
+12 QUIT
+13 ;
CHKL ; -- check end of page
+1 IF IOSL<($Y+5)
IF $EXTRACT(IOST,1,2)="C-"
DO PAUSE^VALM1
if $DATA(DIRUT)
SET IBQUIT=1
if IBQUIT
QUIT
WRITE @IOF
DO HDR
QUIT
+2 IF IOSL<($Y+5)
DO HDR
+3 QUIT
+4 ;
DTC SET IBDT=+$EXTRACT(IBDT,4,5)_"/"_$EXTRACT(IBDT,6,7)_"/"_$EXTRACT(IBDT,2,3)
+1 QUIT
