60 lines
2.4 KiB
Mathematica
60 lines
2.4 KiB
Mathematica
IBQLD3A ;LEB/MRY - PROVIDER/PATIENT DOWNLOAD ; 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
|
|
D HDR I '$D(^TMP("IBQLD3",$J)) W !!,?20,"<<< NO PATIENTS TO PRINT >>>" Q
|
|
;
|
|
F S IBPHY=$O(^TMP("IBQLD3",$J,IBPHY)) Q:IBPHY="" D Q:IBQUIT
|
|
.S IBSUBH=IBTYD_": "_IBPHY
|
|
.D PLINE
|
|
.S IBDDT="" F S IBDDT=$O(^TMP("IBQLD3",$J,IBPHY,IBDDT)) Q:'IBDDT D Q:IBQUIT
|
|
..S IBSSN="" F S IBSSN=$O(^TMP("IBQLD3",$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
|
|
Q
|
|
;
|
|
DATA ;
|
|
S IBDATA=^TMP("IBQLD3",$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("IBQLD3",$J,IBPHY,IBDDT,IBSSN,"LOS"))
|
|
S IBSACNT=$G(^TMP("IBQLD3",$J,IBPHY,IBDDT,IBSSN,"S-AC"))
|
|
S IBSNCNT=$G(^TMP("IBQLD3",$J,IBPHY,IBDDT,IBSSN,"S-NAC"))
|
|
K IBRSY S IBRSY=""
|
|
F S IBRSY=$O(^TMP("IBQLD3",$J,IBPHY,IBDDT,IBSSN,IBRSY)) Q:'IBRSY D
|
|
.S IBRSYCNT=^TMP("IBQLD3",$J,IBPHY,IBDDT,IBSSN,IBRSY)
|
|
.S IBRSY(9999-IBRSYCNT,IBRSY)=""
|
|
D PLINE
|
|
Q
|
|
;
|
|
PLINE ;
|
|
I IBSUBH'="",'$G(IBSSN) W !!,IBSUBH,! Q
|
|
W !,IBSSN,"^" S IBDT=IBADM D DTC W IBDT W "^" S IBDT=IBDDT D DTC W IBDT
|
|
W "^",IBADIAG,"^",IBENRLL,"^",IBAAD,"^",IBNAD,"^",$P(IBRAD," "),"^",$P(IBRAD," ",2),"^",$P(IBRAD," ",3)
|
|
I IBCHK=1 W "^ATTENDING PROVIDER CONTAINS ADMITTING PROVIDER'S 'LOS' DATA." Q
|
|
W "^",IBLOS,"^",IBSACNT,"^",IBSNCNT
|
|
S RCNT="" F S RCNT=$O(IBRSY(RCNT)) Q:'RCNT S REA="" D
|
|
.F S REA=$O(IBRSY(RCNT,REA)) Q:REA="" D
|
|
..W "^",REA,"^",(9999-RCNT)
|
|
;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 !!,"^ADMIT^DISCH^^ENRLL^^^A-REA^A-REA^A-REA^^#AC^#N-AC"
|
|
F I=1:1:IBLVH D ; for Download rpt. use F I=1:1:IBLVH
|
|
.W "^",$J("S-REA",6),"^"
|
|
W !,"SSN^DATE^DATE^DIAG^R-D-L^A^N^1^2^3^#LOS^DAYS^DAYS"
|
|
F I=1:1:IBLVH D ; for Download rpt. use F I=1:1:IBLVH
|
|
.W "^",$J(I,1),"^",$J("CNT",3)
|
|
Q
|
|
;
|
|
DTC S IBDT=+$E(IBDT,4,5)_"/"_$E(IBDT,6,7)_"/"_$E(IBDT,2,3)
|
|
Q
|