1 | IBQLD2 ;LEB/MRY - PATIENT DOWNLOAD TO SPREADSHEET ; 17-MAY-95
|
---|
2 | ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;**2**;Oct 01, 1995
|
---|
3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
---|
4 | ;
|
---|
5 | I '$D(DT) D DT^DICRW
|
---|
6 | DATE W ! D DATE^IBOUTL
|
---|
7 | I IBBDT=""!(IBEDT="") G END
|
---|
8 | S X1=IBEDT,X2=IBBDT D ^%DTC I X>365 W !,"<<< please report 1 years of information only. >>>" G DATE
|
---|
9 | S (IBQUIT,IBPAG)=0
|
---|
10 | S DIR(0)="SA^S:Services;T:Treating Specialties;P:Providers",DIR("A")="Download Services, Treating Specialties, or Providers? [S/T/P]: "
|
---|
11 | W ! D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR
|
---|
12 | S IBTY=Y G:IBTY="P" PHY^IBQLD3
|
---|
13 | I IBTY="S" S DIR(0)="SA^A:All Services;I:Individual Services",DIR("A")="Download ALL or INDIVIDUAL Services? [A/I]: "
|
---|
14 | I IBTY="T" S DIR(0)="SA^A:All Treating Specialties;I:Individual Treating Specialties",DIR("A")="Download ALL or INDIVIDUAL Treating Specialties? [A/I]: "
|
---|
15 | D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR
|
---|
16 | S IBTY1=Y G:IBTY1="A" DEV
|
---|
17 | I IBTY="T" G TSI
|
---|
18 | SVCI S DIR(0)="42.4,3O",DIR("A")="Enter SERVICE"
|
---|
19 | D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR I X="" G:$O(IBSVC(""))="" SVCI G DEV
|
---|
20 | S IBSVC(Y)=Y(0) G SVCI
|
---|
21 | TSI S DIR(0)="PO^45.7:AEQZ",DIR("A")="Enter TREATING SPECIALTY"
|
---|
22 | D ^DIR G:$D(DUOUT)!($D(DTOUT)) END K DIR I X="" G:$O(IBTS(""))="" TSI G DEV
|
---|
23 | S IBTS(Y(0,0))="" G TSI
|
---|
24 | DEV ; -- select device, run option
|
---|
25 | W !!,"Set your Device settings to '0;255;9999'"
|
---|
26 | W ! D ^%ZIS G:POP END
|
---|
27 | S DIR(0)="FO",DIR("A")="Initiate File Capture Procedure and Press Return" D ^DIR I $D(DTOUT) G END
|
---|
28 | W !,"Working...",!
|
---|
29 | U IO
|
---|
30 | ;
|
---|
31 | START ;
|
---|
32 | K ^TMP("IBQLD2",$J) S IBDDT=IBBDT-.01,IBLVH=0
|
---|
33 | F S IBDDT=$O(^IBQ(538,"ADIS",IBDDT)) Q:'IBDDT!(IBDDT>IBEDT) D
|
---|
34 | .S IBTRN="" F S IBTRN=$O(^IBQ(538,"ADIS",IBDDT,IBTRN)) Q:'IBTRN D DATA
|
---|
35 | ;
|
---|
36 | D PRINT^IBQLD2A
|
---|
37 | END ; -- Clean up
|
---|
38 | W ! K ^TMP("IBQLD2",$J),IB,IBDDT,IBBDT,IBEDT,IBTRN,IBTRND,IBTS,IBTY,IBTEXT,IBDATA,IBHDR,IBQUIT,IBPAG,IBREA,IBLV,IBLVH,I,N,X
|
---|
39 | I $D(ZTQUEUED) S ZTREQ="@" Q
|
---|
40 | D ^%ZISC
|
---|
41 | Q
|
---|
42 | ;
|
---|
43 | DATA ;
|
---|
44 | ADMIT ; -- get Admission Review info.
|
---|
45 | S IBLV=0 D ADMIT^IBQL538
|
---|
46 | S IBSVC=IB(1.07),IBTS=IB(.12) S:IBTY="S" IBTS=999 S:IBSVC="" IBSVC="UNK"
|
---|
47 | I IBTY1="I" G:IBTY="S"&('$D(IBSVC(IBSVC))) STAY G:IBTY="T"&('$D(IBTS(IBTS))) STAY
|
---|
48 | 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)
|
---|
49 | S ^TMP("IBQLD2",$J,IBSVC,IBTS,IB(.1),IB(.03))=IBDATA
|
---|
50 | S ^("LOS")=$G(^TMP("IBQLD2",$J,IBSVC,IBTS,IB(.1),IB(.03),"LOS"))+1
|
---|
51 | I IB("ACUTE ADMISSION") S ^("S-AC")=$G(^TMP("IBQLD2",$J,IBSVC,IBTS,IB(.1),IB(.03),"S-AC"))+1
|
---|
52 | E S ^("S-NAC")=$G(^TMP("IBQLD2",$J,IBSVC,IBTS,IB(.1),IB(.03),"S-NAC"))+1
|
---|
53 | STAY ; -- get Stay Review info.
|
---|
54 | S IBTRV=0 F S IBTRV=$O(^IBQ(538,IBTRN,13,IBTRV)) Q:'IBTRV D
|
---|
55 | .D STAY^IBQL538
|
---|
56 | .S IBSVC=IB(13.08),IBTS=IB(13.07) S:IBTY="S" IBTS=999 S:IBSVC="" IBSVC="UNK"
|
---|
57 | .I IBTY1="I" Q:IBTY="S"&('$D(IBSVC(IBSVC))) Q:IBTY="T"&('$D(IBTS(IBTS)))
|
---|
58 | .I '$G(^TMP("IBQLD2",$J,IBSVC,IBTS,IB(.1),IB(.03))) D
|
---|
59 | ..S IBDATA=IB(.09)_"^"_IB(.04)_"^"_IB(.05)_"^"_IB(.06)_"^"_IB(.07)_"^"_IB(.08)_"^"_"^"_"^"
|
---|
60 | ..S ^TMP("IBQLD2",$J,IBSVC,IBTS,IB(.1),IB(.03))=IBDATA
|
---|
61 | .F I=1:1:3 S REA=$P(IB(13.06)," ",I) Q:'REA D
|
---|
62 | ..I '$G(^TMP("IBQLD2",$J,IBSVC,IBTS,IB(.1),IB(.03),+REA)) S IBLV=IBLV+1
|
---|
63 | ..S ^(+REA)=$G(^TMP("IBQLD2",$J,IBSVC,IBTS,IB(.1),IB(.03),+REA))+1
|
---|
64 | .S ^("LOS")=$G(^TMP("IBQLD2",$J,IBSVC,IBTS,IB(.1),IB(.03),"LOS"))+1
|
---|
65 | .I IB("ACUTE STAY") S ^("S-AC")=$G(^TMP("IBQLD2",$J,IBSVC,IBTS,IB(.1),IB(.03),"S-AC"))+1
|
---|
66 | .E S ^("S-NAC")=$G(^TMP("IBQLD2",$J,IBSVC,IBTS,IB(.1),IB(.03),"S-NAC"))+1
|
---|
67 | .I IBLV>IBLVH S IBLVH=IBLV
|
---|
68 | Q
|
---|