IBQLR3A ;LEB/MRY - PROVIDER/PATIENT REPORT ; 1-SEP-95
;;1.0;UTILIZATION MGMT ROLLUP LOCAL;;Oct 01, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
PRINT S (IBDATA,IBQUIT,IBHDR,IBHDR1,IBPHY)="",IBPAG=0
; -- call to return header dates - IBTDT, IBDRNG
D DTC^IBQLPL2
S IBHDR="UTILIZATION MANAGEMENT",IBHDR2="PATIENT REVIEWS FOR "_IBDRNG,IBHDR1="PROVIDER"
;
I '$D(^TMP("IBQLR3",$J)) D HDR W !!,?20,"<<< NO PATIENTS TO PRINT >>>" Q
F S IBPHY=$O(^TMP("IBQLR3",$J,IBPHY)) Q:IBPHY="" D G:IBQUIT END
.S IBSUBH=IBTYD_": "_IBPHY
.D PLINE Q:IBQUIT
.S IBDDT="" F S IBDDT=$O(^TMP("IBQLR3",$J,IBPHY,IBDDT)) Q:'IBDDT D Q:IBQUIT
..S IBSSN="" F S IBSSN=$O(^TMP("IBQLR3",$J,IBPHY,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,IBCHK
Q
;
DATA ;
S IBDATA=^TMP("IBQLR3",$J,IBPHY,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 IBCHK=$P(IBDATA,"^",10) I IBCHK=1 D PLINE Q
S IBLOS=$G(^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN,"LOS"))
S IBSACNT=$G(^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN,"S-AC"))
S IBSNCNT=$G(^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN,"S-NAC"))
K IBRSY S IBRSY=""
F S IBRSY=$O(^TMP("IBQLR3",$J,IBPHY,IBDDT,IBSSN,IBRSY)) Q:'IBRSY D
.S IBRSYCNT=^TMP("IBQLR3",$J,IBPHY,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)
I IBCHK=1 W ?58,"ATTENDING PROVIDER CONTAINS ADMITTING PROVIDER'S 'LOS' DATA." Q
W ?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[HIBQLR3A 3271 printed Nov 22, 2024@17:51:27 Page 2
IBQLR3A ;LEB/MRY - PROVIDER/PATIENT REPORT ; 1-SEP-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 SET (IBDATA,IBQUIT,IBHDR,IBHDR1,IBPHY)=""
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
SET IBHDR1="PROVIDER"
+4 ;
+5 IF '$DATA(^TMP("IBQLR3",$JOB))
DO HDR
WRITE !!,?20,"<<< NO PATIENTS TO PRINT >>>"
QUIT
+6 FOR
SET IBPHY=$ORDER(^TMP("IBQLR3",$JOB,IBPHY))
if IBPHY=""
QUIT
Begin DoDot:1
+7 SET IBSUBH=IBTYD_": "_IBPHY
+8 DO PLINE
if IBQUIT
QUIT
+9 SET IBDDT=""
FOR
SET IBDDT=$ORDER(^TMP("IBQLR3",$JOB,IBPHY,IBDDT))
if 'IBDDT
QUIT
Begin DoDot:2
+10 SET IBSSN=""
FOR
SET IBSSN=$ORDER(^TMP("IBQLR3",$JOB,IBPHY,IBDDT,IBSSN))
if 'IBSSN
QUIT
DO DATA
if IBQUIT
QUIT
End DoDot:2
if IBQUIT
QUIT
End DoDot:1
if IBQUIT
GOTO END
+11 QUIT
+12 ;
END KILL IBDATA,IBTS,IBADM,IBADIAG,IBENRLL,IBPHYAD,IBPHYAT,IBPHYRS,IBAAD,IBRAD,IBLOS,IBRSYCNT,IBHDR,IBHDR1,IBDRNG,IBDT,IBRSY,IBSSN,IBTDT,IBTRND1,IBTRV,IBTRVD,IBCHK
+1 QUIT
+2 ;
DATA ;
+1 SET IBDATA=^TMP("IBQLR3",$JOB,IBPHY,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 IBCHK=$PIECE(IBDATA,"^",10)
IF IBCHK=1
DO PLINE
QUIT
+6 SET IBLOS=$GET(^TMP("IBQLR3",$JOB,IBPHY,IBDDT,IBSSN,"LOS"))
+7 SET IBSACNT=$GET(^TMP("IBQLR3",$JOB,IBPHY,IBDDT,IBSSN,"S-AC"))
+8 SET IBSNCNT=$GET(^TMP("IBQLR3",$JOB,IBPHY,IBDDT,IBSSN,"S-NAC"))
+9 KILL IBRSY
SET IBRSY=""
+10 FOR
SET IBRSY=$ORDER(^TMP("IBQLR3",$JOB,IBPHY,IBDDT,IBSSN,IBRSY))
if 'IBRSY
QUIT
Begin DoDot:1
+11 SET IBRSYCNT=^TMP("IBQLR3",$JOB,IBPHY,IBDDT,IBSSN,IBRSY)
+12 SET IBRSY(9999-IBRSYCNT,IBRSY)=""
End DoDot:1
+13 DO PLINE
+14 QUIT
+15 ;
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)
+6 IF IBCHK=1
WRITE ?58,"ATTENDING PROVIDER CONTAINS ADMITTING PROVIDER'S 'LOS' DATA."
QUIT
+7 WRITE ?58,$JUSTIFY(IBLOS,4),?63,$JUSTIFY(IBSACNT,4),?68,$JUSTIFY(IBSNCNT,4)
+8 WRITE ?73
SET (RCNT,CNT)=""
FOR
SET RCNT=$ORDER(IBRSY(RCNT))
if 'RCNT
QUIT
SET REA=""
Begin DoDot:1
+9 FOR
SET REA=$ORDER(IBRSY(RCNT,REA))
if REA=""
QUIT
Begin DoDot:2
+10 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
+11 ;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(...
+12 ;.W ?($X+2),$J(IBRSY(RCNT),6),?($X+2),$J(9999-RCNT,3)
+13 QUIT
+14 ;
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
