79 lines
2.9 KiB
Mathematica
79 lines
2.9 KiB
Mathematica
IBQLPL ;LEB/MRY - PATIENTS QUALIFY/MISSING INFO LIST ; 22-MAR-95
|
|
;;1.0;UTILIZATION MGMT ROLLUP LOCAL;**1**;Oct 01, 1995
|
|
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
;
|
|
I '$D(DT) D DT^DICRW
|
|
D PULL
|
|
W !! W:IBRPT="Q" "List Patients to be included in Rollup" W:IBRPT="M" "List Patients with Missing Data"
|
|
;W !,"The next National Rollup will be " S Y=IBBDT X ^DD("DD") W Y_" to " S Y=IBEDT X ^DD("DD") W Y
|
|
I IBMSG'="" W !!,IBMSG,!,IBMSG1
|
|
;
|
|
; -- get date range
|
|
W ! D DATE^IBOUTL
|
|
I IBBDT=""!(IBEDT="") G END
|
|
;
|
|
DEV ; -- select device, run option
|
|
W ! S %ZIS="QM" D ^%ZIS G:POP END
|
|
I $D(IO("Q")) F I="IBBDT","IBEDT","IBRPT" S ZTSAVE(I)=""
|
|
I $D(IO("Q")) S ZTRTN="RPT^IBQLPL",ZTDESC="UM - ROLLUP LIST" D ^%ZTLOAD K IO("Q"),ZTSK D HOME^%ZIS G END
|
|
U IO
|
|
;
|
|
RPT ; -- entry point from taskman
|
|
; store data in ^tmp($j)
|
|
K ^TMP("IBQLPL",$J),IB
|
|
S IBPAG=0,IBQUIT=0
|
|
I IBRPT="M" D REQFLDS
|
|
D START^IBQLPL1
|
|
I $G(ZTSTOP) G END
|
|
;
|
|
D PRINT^IBQLPL2
|
|
;
|
|
END ; -- Clean up
|
|
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
|
|
I $D(ZTQUEUED) S ZTREQ="@" Q
|
|
D ^%ZISC
|
|
Q
|
|
;
|
|
PULL ;PULL DATES
|
|
S IBPDT1=$E(DT,1,3)-1_"1001"_"-"_$E(DT,1,3)_"0331",IBRDT1=$E(DT,1,3)_"0515"
|
|
S IBPDT2=$E(DT,1,3)_"1001"_"-"_($E(DT,1,3)+1)_"0331",IBRDT2=$E(DT,1,3)+1_"0515"
|
|
S IBPDT3=$E(DT,1,3)_"0401"_"-"_$E(DT,1,3)_"0930",IBRDT3=$E(DT,1,3)_"1115"
|
|
S IBRDT=$S(DT'>IBRDT1:IBRDT1,DT>IBRDT3:IBRDT2,1:IBRDT3)
|
|
S IBPDT=$S(DT'>IBRDT1:IBPDT1,DT>IBRDT3:IBPDT2,1:IBPDT3)
|
|
S IBBDT=$P(IBPDT,"-"),IBEDT=$P(IBPDT,"-",2)
|
|
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
|
|
K IBPDT1,IBPDT2,IBPDT3,IBPDT,IBRDT,IBRDT2,IBRDT3,Y Q
|
|
;
|
|
REQFLDS ; -- set ibd(fld#) for missing message explanation
|
|
F I=3:1 S X=$T(REQFLDS+I) Q:$P(X,";",3)="Q" S IBD($P(X,";",3))=$P(X,";",4)
|
|
Q
|
|
;;.01;ENTRY ID;
|
|
;;.02;SITE;
|
|
;;.03;SSN;
|
|
;;.04;ADMITTING DIAGNOSIS;
|
|
;;.05;ENROLLMENT CODES;
|
|
;;.06;ADMITTING PHYSICIAN CODE;
|
|
;;.07;ATTENDING CODE;
|
|
;;.08;RESIDENT CODE;
|
|
;;.09;ACUTE CARE ADMISSION DATE (PATIENT MOVEMENT);
|
|
;;.1;ACUTE CARE DISCHARGE DATE;
|
|
;;.11;WARD;
|
|
;;.12;TREATING SPECIALTY;
|
|
;;.13;ACUTE ADMISSION(Y/N);
|
|
;;1.01;SEVERITY OF ILLNESS FROM ADMISSION;
|
|
;;1.02;INTENSITY OF SERVICE FROM ADMISSION;
|
|
;;1.03;REASON FOR NON-ACUTE ADMISSION;
|
|
;;1.04;PROVIDER INTERVIEWED(Y/N);
|
|
;;1.05;ADMISSION INFLUENCED(Y/N);
|
|
;;1.06;LOCAL, NATIONAL, OR BOTH;
|
|
;;1.07;SERVICE FROM ADMISSION REVIEW;
|
|
;;13.01;DAY OF CONTINUED STAY;
|
|
;;13.02;INTENSITY OF SERVICE FROM CONTINUED STAY;
|
|
;;13.03;SEVERITY OF ILLNESS FROM CONTINUED STAY;
|
|
;;13.04;D/C FROM CONTINUED STAY;
|
|
;;13.05;INTERVIEWED(Y/N);
|
|
;;13.06;REASONS FROM CONTINUED STAY;
|
|
;;13.07;TREATING SPECIALTY FROM CONTINUED STAY;
|
|
;;13.08;SERVICE FROM CONTINUED STAY;
|
|
;;Q;QUIT
|