73 lines
3.1 KiB
Mathematica
73 lines
3.1 KiB
Mathematica
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
|