source: WorldVistAEHR/trunk/r/UTILIZATION_MGMT_ROLLUP_LOCAL-IBQ/IBQLPL1.m@ 1123

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

initial load of WorldVistAEHR
File size: 3.3 KB
RevLine 
[613]1IBQLPL1 ;LEB/MRY - PATIENTS QUALIFY/MISSING INFO LIST ; 24-MAR-95
2 ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;**1**;Oct 01, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6START ; -- loop thru discharges in Claims Tracking
7 S IBDDT=IBBDT-.01
8 F S IBDDT=$O(^IBT(356,"ADIS",IBDDT)) Q:'IBDDT!(IBDDT>IBEDT) D
9 .S IBTRN="" F S IBTRN=$O(^IBT(356,"ADIS",IBDDT,IBTRN)) Q:'IBTRN D
10 ..I '$D(^IBT(356.1,"C",IBTRN))!'$G(^IBT(356,IBTRN,0)) Q
11 ..;
12 ..S IBQUIT=0 D CLAIMS^IBQL356 Q:IBQUIT
13 ..S IB(1.06)=$S(IB(1.06)="L":"ZL",IB(1.06)="":"AA",1:IB(1.06))
14 ..;
15 ..I IBRPT="Q" D QUALIFY
16 ..I IBRPT="M" D MISSING
17 I $$STOP Q
18 Q
19 ;
20QUALIFY ; --list patients to be included in Rollup
21 S DFN=$P(IBTRND,"^",2),X=$G(^DPT(DFN,0))
22 S IBNAM=$P(X,"^"),SSN=$P(X,"^",9) S:SSN ^TMP("IBQLPL",$J,IB(1.06),IBDDT,SSN)=IBNAM
23 Q
24 ;
25 ;
26MISSING ; -- list patients with missing data
27 ;
28 ; -- send message if missing adm diagnosis, enroll code, adm
29 F IBFLD=.04,.05,.09 D ERR I IBERR'="" S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),IBFLD)=IBERR
30 ; -- check for (.0001) fundemental completion errors
31 I $P(IBTRND,"^",18)'=1 D
32 .S IBERR="EVENT TYPE NOT OF INPATIENT ADMISSION (#"_IB(.01)_")"
33 .S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),.0001)=IBERR
34 I $P(IBTRND,"^",20)'=1 D
35 .S IBERR="CLAIMS TRACKING ENTRY IS INACTIVE (#"_IB(.01)_")"
36 .S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),.0002)=IBERR
37 ;
38ORDER ; -- check (.001) procedure ordering errors, arrange in DAY order.
39 S IBTRV=0
40 D ORDCHK^IBQLPL3
41 Q:IB001
42 S IBDAY=0
43 F S IBDAY=$O(IBORDER(IBDAY)) Q:'IBDAY D
44 .S IBTRV=IBORDER(IBDAY)
45 .I IBDAY=1 D ADMIT
46 .I IBDAY>1 D STAY
47 I $O(^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),0)) S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03))=IBNAM
48 Q
49 ;
50ADMIT ; get Admission Review infomation into IB(array)
51 D ADMIT^IBQL356 Q:IBQUIT
52 ; -- send message if no treating specialty, service
53 F IBFLD=.12,1.07 D ERR I IBERR'="" S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),IBFLD)=IBERR
54 ; -- send message if si,is, reasons are not answered
55 I IB(1.01)="",IB(1.02)="",IB(1.03)="" F IBFLD=1.01,1.02,1.03 D ERR I IBERR'="" S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),IBFLD)=IBERR
56 ; -- check for (.0001) fundemetally completion errors
57 I $P(IBTRVD,"^",21)'=10 D
58 .S IBERR="Admission Stay not COMPLETE (#"_IB(.01)_")"
59 .S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),.0004)=IBERR
60 S IBPIS=IB(1.02)
61 Q
62 ;
63STAY ; get Stay Review information into IB(array)
64 D STAY^IBQL356 Q:IBQUIT
65 F IBFLD=13.07,13.08 D ERR I IBERR'="" S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),(IB(13.01)+IBFLD))=IBERR
66 I IB(13.02)="",IB(13.06)="" F IBFLD=13.02,13.06 D ERR I IBERR'="" S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),(IB(13.01)+IBFLD))=IBERR
67 ; -- check for (.0001) fundementally completion errors
68 I $P(IBTRVD,"^",21)'=10 D
69 .S IBERR="STAY DAY "_IB(13.01)_" NOT COMPLETE (#"_IB(.01)_")"
70 .S ^TMP("IBQLPL",$J,IB(1.06),IBDDT,IB(.03),(IB(13.01)+.0004))=IBERR
71 Q
72 ;
73ERR ; -- return missing message
74 S IBERR=""
75 I IB(IBFLD)="" S IBERR="MISSING "_IBD(IBFLD) S:IBFLD>13 IBERR=IBERR_" DAY "_IB(13.01) S IBERR=IBERR_" (#"_IB(.01)_")"
76 Q
77ERR1 ; -- return error message that entry EVENT TYPE is not Inpatient status.
78 S IBERR="EVENT TYPE not of INPATIENT ADMISSION (#"_IB(.01)_")"
79 Q
80STOP() ;determine if user has requested the queued report to stop
81 I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ I +$G(IBPAG) W !,"***TASK STOPPED BY USER***"
82 Q +$G(ZTSTOP)
Note: See TracBrowser for help on using the repository browser.