source: WorldVistAEHR/trunk/r/UTILIZATION_MGMT_ROLLUP_LOCAL-IBQ/IBQLPL.m@ 1147

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

initial load of WorldVistAEHR

File size: 2.9 KB
Line 
1IBQLPL ;LEB/MRY - PATIENTS QUALIFY/MISSING INFO LIST ; 22-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 ;
5 I '$D(DT) D DT^DICRW
6 D PULL
7 W !! W:IBRPT="Q" "List Patients to be included in Rollup" W:IBRPT="M" "List Patients with Missing Data"
8 ;W !,"The next National Rollup will be " S Y=IBBDT X ^DD("DD") W Y_" to " S Y=IBEDT X ^DD("DD") W Y
9 I IBMSG'="" W !!,IBMSG,!,IBMSG1
10 ;
11 ; -- get date range
12 W ! D DATE^IBOUTL
13 I IBBDT=""!(IBEDT="") G END
14 ;
15DEV ; -- select device, run option
16 W ! S %ZIS="QM" D ^%ZIS G:POP END
17 I $D(IO("Q")) F I="IBBDT","IBEDT","IBRPT" S ZTSAVE(I)=""
18 I $D(IO("Q")) S ZTRTN="RPT^IBQLPL",ZTDESC="UM - ROLLUP LIST" D ^%ZTLOAD K IO("Q"),ZTSK D HOME^%ZIS G END
19 U IO
20 ;
21RPT ; -- entry point from taskman
22 ; store data in ^tmp($j)
23 K ^TMP("IBQLPL",$J),IB
24 S IBPAG=0,IBQUIT=0
25 I IBRPT="M" D REQFLDS
26 D START^IBQLPL1
27 I $G(ZTSTOP) G END
28 ;
29 D PRINT^IBQLPL2
30 ;
31END ; -- Clean up
32 W ! K ^TMP("IBQLPL",$J),I,X,DFN,SSN,DGPM,VAIN,VAINDT,IB,IBD,IBBDT,IBEDT,IBQUIT,IBPAG,IBRPT,IBTRN,IBTRN1,IBNAM,IBFLD,IBTY,IBHR,IBDAY,IBERR,IBDAY,IBORDER,IB001,IBENRLL,ENRLL
33 I $D(ZTQUEUED) S ZTREQ="@" Q
34 D ^%ZISC
35 Q
36 ;
37PULL ;PULL DATES
38 S IBPDT1=$E(DT,1,3)-1_"1001"_"-"_$E(DT,1,3)_"0331",IBRDT1=$E(DT,1,3)_"0515"
39 S IBPDT2=$E(DT,1,3)_"1001"_"-"_($E(DT,1,3)+1)_"0331",IBRDT2=$E(DT,1,3)+1_"0515"
40 S IBPDT3=$E(DT,1,3)_"0401"_"-"_$E(DT,1,3)_"0930",IBRDT3=$E(DT,1,3)_"1115"
41 S IBRDT=$S(DT'>IBRDT1:IBRDT1,DT>IBRDT3:IBRDT2,1:IBRDT3)
42 S IBPDT=$S(DT'>IBRDT1:IBPDT1,DT>IBRDT3:IBPDT2,1:IBPDT3)
43 S IBBDT=$P(IBPDT,"-"),IBEDT=$P(IBPDT,"-",2)
44 S IBMSG=">> Next rollup transmission deadline: " S Y=IBRDT X ^DD("DD") S IBMSG=IBMSG_Y,IBMSG1=">> Covering periods: " S Y=IBBDT X ^DD("DD") S IBMSG1=IBMSG1_Y_" to " S Y=IBEDT X ^DD("DD") S IBMSG1=IBMSG1_Y
45 K IBPDT1,IBPDT2,IBPDT3,IBPDT,IBRDT,IBRDT2,IBRDT3,Y Q
46 ;
47REQFLDS ; -- set ibd(fld#) for missing message explanation
48 F I=3:1 S X=$T(REQFLDS+I) Q:$P(X,";",3)="Q" S IBD($P(X,";",3))=$P(X,";",4)
49 Q
50 ;;.01;ENTRY ID;
51 ;;.02;SITE;
52 ;;.03;SSN;
53 ;;.04;ADMITTING DIAGNOSIS;
54 ;;.05;ENROLLMENT CODES;
55 ;;.06;ADMITTING PHYSICIAN CODE;
56 ;;.07;ATTENDING CODE;
57 ;;.08;RESIDENT CODE;
58 ;;.09;ACUTE CARE ADMISSION DATE (PATIENT MOVEMENT);
59 ;;.1;ACUTE CARE DISCHARGE DATE;
60 ;;.11;WARD;
61 ;;.12;TREATING SPECIALTY;
62 ;;.13;ACUTE ADMISSION(Y/N);
63 ;;1.01;SEVERITY OF ILLNESS FROM ADMISSION;
64 ;;1.02;INTENSITY OF SERVICE FROM ADMISSION;
65 ;;1.03;REASON FOR NON-ACUTE ADMISSION;
66 ;;1.04;PROVIDER INTERVIEWED(Y/N);
67 ;;1.05;ADMISSION INFLUENCED(Y/N);
68 ;;1.06;LOCAL, NATIONAL, OR BOTH;
69 ;;1.07;SERVICE FROM ADMISSION REVIEW;
70 ;;13.01;DAY OF CONTINUED STAY;
71 ;;13.02;INTENSITY OF SERVICE FROM CONTINUED STAY;
72 ;;13.03;SEVERITY OF ILLNESS FROM CONTINUED STAY;
73 ;;13.04;D/C FROM CONTINUED STAY;
74 ;;13.05;INTERVIEWED(Y/N);
75 ;;13.06;REASONS FROM CONTINUED STAY;
76 ;;13.07;TREATING SPECIALTY FROM CONTINUED STAY;
77 ;;13.08;SERVICE FROM CONTINUED STAY;
78 ;;Q;QUIT
Note: See TracBrowser for help on using the repository browser.