source: WorldVistAEHR/trunk/r/UTILIZATION_MGMT_ROLLUP_LOCAL-IBQ/IBQLLD.m@ 1789

Last change on this file since 1789 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.3 KB
Line 
1IBQLLD ;LEB/MRY - LOAD UMR FILE ; 31-MAR-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(IBRPT) Q
6 ; --
7 I '$D(DT) D DT^DICRW
8 D PULL^IBQLPL
9 I IBRPT="N" S IBDNLD="N" G START
10 W !!,"Create Rollup File"
11 ;W !,"The next National Rollup will be " S Y=IBBDT X ^DD("DD") W Y_" to " S Y=IBEDT X ^DD("DD") W Y
12 I IBMSG'="" W !!,IBMSG,!,IBMSG1
13 ;
14DATE ; -- get date range
15 W ! D DATE^IBOUTL
16 I IBBDT=""!(IBEDT="") G END
17 S X1=IBEDT,X2=IBBDT D ^%DTC I X>365 W !,"<<< please report 1 years of information only. >>>" G DATE
18 ;
19 S DIR(0)="SA^RD:RANDOM & DISEASE;L:LOCAL;A:ALL",DIR("A")="Random & Disease Cases, Local Cases or ALL Cases: ",DIR("B")="ALL" D ^DIR I $D(DUOUT)!($D(DTOUT)) G END
20 S IBDNLD=Y
21 F I="IBBDT","IBEDT","IBRPT","IBDNLD" S ZTSAVE(I)=""
22 S ZTRTN="START^IBQLLD",ZTDESC="IBQ - LOCAL ROLLUP ",ZTIO=""
23 D ^%ZTLOAD G END
24 ;
25START S IBDDT=IBBDT-.01,IBREC=0
26 F S IBDDT=$O(^IBT(356,"ADIS",IBDDT)) Q:'IBDDT!(IBDDT>IBEDT) D
27 .S IBTRN="" F S IBTRN=$O(^IBT(356,"ADIS",IBDDT,IBTRN)) Q:'IBTRN D
28 ..I '$D(^IBT(356.1,"C",IBTRN))!'$G(^IBT(356,IBTRN,0)) Q
29 ..D DATA
30 ..Q
31 .Q
32 ;
33 D TRANSMIT^IBQLLD1
34 ;
35END K IBDATA,X,I,DFN,DGPM,VAINDT,VAIN,IBRPT,IBFLD,IB,IBDDT,IBBDT,IBTRN,IBTRND,IBNAM,IBR,IBD,IBL,IBDNLD,IBHR,IBDAY,IBREC,IBORDER
36 Q
37 ;
38DATA ;
39 K IBDATA S IBQUIT=""
40CLAIMS ; get Claims Tracking and misc. information into IB(array)
41 D CLAIMS^IBQL356 Q:IBQUIT
42 ; -- quit if missing entry id, site, ssn, adm diagnosis, enroll code,
43 ; admission, rollup type
44 F IBFLD=.01,.02,.03,.04,.05,.09,1.06 I IB(IBFLD)="" S IBQUIT=1 Q
45 ; -- quit if EVENT TYPE not INPATIENT ADMISSION or INACTIVE.
46 I $P(IBTRND,"^",18)'=1!($P(IBTRND,"^",20)'=1) S IBQUIT=1 Q
47 Q:IBQUIT
48 Q:IBDNLD="N"&(IB(1.06)="L") Q:IBDNLD="L"&(IB(1.06)="N") Q:IBDNLD="RD"&(IB(1.06)="L")
49 ;
50ORDER ; -- check procedure ordering errors, arrange in DAY order.
51 S IBTRV=0
52 D ORDCHK^IBQLLD2
53 Q:IBQUIT
54 S IBDAY=0
55 F S IBDAY=$O(IBORDER(IBDAY)) Q:'IBDAY D Q:IBQUIT
56 .S IBTRV=IBORDER(IBDAY)
57 .I IBDAY=1 D ADMIT
58 .I IBDAY>1 D STAY
59 ;
60 ; -- quit if missing discharge date
61 I IB(.1)="" S IBQUIT=1 Q
62 ;
63LOAD ; -- load data into ^ibq(538, file
64 Q:IBQUIT Q:'$D(IBDATA(0)) Q:'$D(IBDATA(1))
65 D LOAD^IBQLLD1 S IBREC=IBREC+1
66 Q
67 ;
68 ;
69ADMIT ; get Admission Review information into IB(array)
70 D ADMIT^IBQL356 Q:IBQUIT
71 ; -- quit if missing treating specialty, service
72 F IBFLD=.12,1.07 I IB(IBFLD)="" S IBQUIT=1 Q
73 ; -- quit if missing si, is and reason from admission
74 I IB(1.01)="",IB(1.02)="",IB(1.03)="" S IBQUIT=1 Q
75 ; -- quit if not ACTIVE or not COMPLETE.
76 I $P(IBTRVD,"^",21)'=10 S IBQUIT=1 Q
77 S X="" F IBFLD=.01:.01:.13 S X=X_IBFLD_":"_IB(IBFLD)_"^"
78 S IBDATA(0)=$P(X,"^",1,$L(X,"^")-1)
79 S X="" F IBFLD=1.01:.01:1.07 S X=X_IBFLD_":"_IB(IBFLD)_"^"
80 S IBDATA(1)=$P(X,"^",1,$L(X,"^")-1)
81 S IBPIS=IB(1.02)
82 Q
83 ;
84STAY ; get Stay Review information into IB(array)
85 D STAY^IBQL356 Q:IBQUIT
86 ; -- quit if missing 'is' AND missing 'reasons'
87 I IB(13.02)="",IB(13.06)="" S IBQUIT=1 Q
88 ; -- quit if missing Treating Specialty in continued stay
89 I IB(13.07)="" S IBQUIT=1 Q
90 ; -- quit if not ACTIVE or not COMPLETE.
91 I $P(IBTRVD,"^",21)'=10 S IBQUIT=1 Q
92 Q:IBQUIT
93 S X="" F IBFLD=13.01,13.02,13.03,13.04,13.05,13.06,13.07,13.08 S X=X_(IBFLD-13)_":"_IB(IBFLD)_"^"
94 S IBDATA(IB(13.01))=$P(X,"^",1,$L(X,"^")-1)
95 Q
Note: See TracBrowser for help on using the repository browser.