94 lines
4.2 KiB
Mathematica
94 lines
4.2 KiB
Mathematica
IBQLD3 ;LEB/MRY - PATIENT/PROVIDER REVIEW 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.
|
|
;
|
|
I '$D(DT) D DT^DICRW
|
|
DATE W ! D DATE^IBOUTL
|
|
I IBBDT=""!(IBEDT="") G END
|
|
S X1=IBEDT,X2=IBBDT D ^%DTC I X>365 W !,"<<< please report 1 years of information only. >>>" G DATE
|
|
PHY S DIR(0)="SA^A:Admitting Provider;T:Attending Provider;R:Resident Provider",DIR("A")="Provider Type? [A/T/R]: "
|
|
W ! D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR
|
|
S IBTY=Y,IBTYD=Y(0)
|
|
S IBTY2=$S(IBTY="T":1,IBTY="R":2,IBTY="A":3)
|
|
S DIR(0)="SA^A:All "_IBTYD_";I:Individual "_IBTYD,DIR("A")="Display ALL or INDIVIDUAL "_IBTYD_"? [A/I]: "
|
|
D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR
|
|
S IBTY1=Y G:IBTY1="A" DEV
|
|
PHYI S DIR(0)="PO^200:AEQZ",DIR("A")="Enter "_IBTYD
|
|
D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR I X="" G:$O(IBPHY(""))="" PHYI G DEV
|
|
S IBPHY(+Y)="" G PHYI
|
|
DEV ; -- select device, run option
|
|
W !!,"Set your Device settings to '0;255;9999'"
|
|
W ! D ^%ZIS G:POP END
|
|
S DIR(0)="FO",DIR("A")="Initiate File Capture Procedure and Press Return" D ^DIR I $D(DTOUT) G END
|
|
W !,"Working...",!
|
|
U IO
|
|
;
|
|
START ;
|
|
K ^TMP("IBQLD3",$J) S IBDDT=IBBDT-.01,(IBPAG,IBQUIT,IBLVH)=0
|
|
F S IBDDT=$O(^IBQ(538,"ADIS",IBDDT)) Q:'IBDDT!(IBDDT>IBEDT) D
|
|
.S IBTRN="" F S IBTRN=$O(^IBQ(538,"ADIS",IBDDT,IBTRN)) Q:'IBTRN D DATA
|
|
;
|
|
I $$STOP,$G(ZTSTOP) G END
|
|
D PRINT^IBQLD3A
|
|
END ; -- Clean up
|
|
W ! K ^TMP("IBQLD3",$J),IB,IBDDT,IBBDT,IBEDT,IBTRN,IBTRND,IBTY,IBTY1,IBPHY,IBTEXT,IBDATA,IBHDR,IBQUIT,IBPAG,IBREA,IBLV,IBLVH,I,N,X,IBIEN,IBQLR3,IBORDER,DGPM,IBPHYN,IBPHYZ,IBPHYD
|
|
I $D(ZTQUEUED) S ZTREQ="@" Q
|
|
D ^%ZISC
|
|
Q
|
|
;
|
|
DATA ;
|
|
; -- get Admission Review info.
|
|
S IBLV=0 D ADMIT^IBQL538 S IBIEN=$E(IB(.01),4,999)
|
|
S IBQUIT=0,IBQLR3=1,IBTRNSV=IBTRN,IBTRN=IBIEN D ORDCHK^IBQLLD2 S IBTRN=IBTRNSV K IBTRNSV
|
|
D PHYZ S IBRIEN=IBORDER(1) D PHYZR
|
|
G:'IBPHY STAY G:IBTY1="I"&('$D(IBPHY(IBPHY))) STAY
|
|
S IBDATA=IB(.09)_"^"_IB(.04)_"^"_IB(.05)_"^"_IB(.06)_"^"_IB(.07)_"^"_IB(.08)_"^"_IB("ACUTE ADMISSION")_"^"_$S('IB("ACUTE ADMISSION"):1,1:"")_"^"_IB(1.03)
|
|
S ^TMP("IBQLD3",$J,IBPHY,IB(.1),IB(.03))=IBDATA
|
|
S ^("LOS")=$G(^TMP("IBQLD3",$J,IBPHY,IB(.1),IB(.03),"LOS"))+1
|
|
I IB("ACUTE ADMISSION") S ^("S-AC")=$G(^TMP("IBQLD3",$J,IBPHY,IB(.1),IB(.03),"S-AC"))+1
|
|
E S ^("S-NAC")=$G(^TMP("IBQLD3",$J,IBPHY,IB(.1),IB(.03),"S-NAC"))+1
|
|
STAY ; -- get Stay Review info.
|
|
S IBRN=1,IBTRV=0 F S IBRN=$O(IBORDER(IBRN)) Q:'IBRN S IBRIEN=IBORDER(IBRN) D
|
|
.S IBTRV=IBTRV+1 D STAY^IBQL538
|
|
.D PHYZR Q:'IBPHY I IBTY1="I",'$D(IBPHY(IBPHY)) Q
|
|
.I '$G(^TMP("IBQLD3",$J,IBPHY,IB(.1),IB(.03))) D
|
|
..S IBDATA=IB(.09)_"^"_IB(.04)_"^"_IB(.05)_"^"_IB(.06)_"^"_IB(.07)_"^"_IB(.08)_"^"_"^"_"^"
|
|
..S ^TMP("IBQLD3",$J,IBPHY,IB(.1),IB(.03))=IBDATA
|
|
.F I=1:1:3 S REA=$P(IB(13.06)," ",I) Q:'REA D
|
|
..I '$G(^TMP("IBQLD3",$J,IBPHY,IB(.1),IB(.03),+REA)) S IBLV=IBLV+1
|
|
..S ^(+REA)=$G(^TMP("IBQLD3",$J,IBPHY,IB(.1),IB(.03),+REA))+1
|
|
.S ^("LOS")=$G(^TMP("IBQLD3",$J,IBPHY,IB(.1),IB(.03),"LOS"))+1
|
|
.I IB("ACUTE STAY") S ^("S-AC")=$G(^TMP("IBQLD3",$J,IBPHY,IB(.1),IB(.03),"S-AC"))+1
|
|
.E S ^("S-NAC")=$G(^TMP("IBQLD3",$J,IBPHY,IB(.1),IB(.03),"S-NAC"))+1
|
|
.I IBLV>IBLVH S IBLVH=IBLV
|
|
Q
|
|
;
|
|
PHYZ ; -- organize requested providers in array IBPHYZ
|
|
S DGPM=$P(^IBT(356,IBIEN,0),"^",5)
|
|
S IBPHYN=0 K IBPHYZ
|
|
F S IBPHYN=$O(^IBT(356.94,"C",DGPM,IBPHYN)) Q:'IBPHYN S IBPHYD=^IBT(356.94,IBPHYN,0) D
|
|
.I 'IBPHYD!('$P(IBPHYD,"^"))!('$P(IBPHYD,"^",3))!('$P(IBPHYD,"^",4)) Q
|
|
.S IBPHYZ($P(IBPHYD,"^",4),$P(IBPHYD,"^"))=$P(IBPHYD,"^",3)
|
|
I IBTY2=1 D
|
|
.S IB1=$O(IBPHYZ(1,"")) Q:'IB1 S IB3=$O(IBPHYZ(3,"")) Q:'IB3
|
|
.I IB1'=IB3 Q
|
|
.S X1=IB1,X2=1 D C^%DTC S IBPHYZ(1,X)=IBPHYZ(1,IB1) K IBPHYZ(1,IB1)
|
|
I IBTY2=3 D
|
|
.S IB1=$O(IBPHYZ(1,"")) Q:'IB1 S IB3=$O(IBPHYZ(3,"")) Q:'IB3
|
|
.I IB3=IB1 D
|
|
..S X1=IB3,X2=1 D C^%DTC S IBPHYZ(3,X)=""
|
|
.I IB1'=IB3 S IBPHYZ(3,IB1)=""
|
|
K IBPHYN,IBPHYD Q
|
|
;
|
|
PHYZR ; -- return requested provider.
|
|
S VAINDT=$$VNDT^IBTRV(IBRIEN),VAINDT=$P(VAINDT,".")
|
|
S (IBPHY,IBPHYDT)=""
|
|
F S IBPHYDT=$O(IBPHYZ(IBTY2,IBPHYDT)) Q:'IBPHYDT D
|
|
.I IBPHYDT>VAINDT Q
|
|
.S IBPHY=IBPHYZ(IBTY2,IBPHYDT)
|
|
Q
|
|
;
|
|
STOP() ; determine if user has requested the queued report to stop
|
|
I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ I +$G(IBPAG) W !,"***TASK STOPPED BY USER***"
|
|
Q +$G(ZTSTOP)
|