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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBQLPL 3024 printed Nov 22, 2024@17:51:15 Page 2
IBQLPL ;LEB/MRY - PATIENTS QUALIFY/MISSING INFO LIST ; 22-MAR-95
+1 ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;**1**;Oct 01, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 IF '$DATA(DT)
DO DT^DICRW
+5 DO PULL
+6 WRITE !!
if IBRPT="Q"
WRITE "List Patients to be included in Rollup"
if IBRPT="M"
WRITE "List Patients with Missing Data"
+7 ;W !,"The next National Rollup will be " S Y=IBBDT X ^DD("DD") W Y_" to " S Y=IBEDT X ^DD("DD") W Y
+8 IF IBMSG'=""
WRITE !!,IBMSG,!,IBMSG1
+9 ;
+10 ; -- get date range
+11 WRITE !
DO DATE^IBOUTL
+12 IF IBBDT=""!(IBEDT="")
GOTO END
+13 ;
DEV ; -- select device, run option
+1 WRITE !
SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO END
+2 IF $DATA(IO("Q"))
FOR I="IBBDT","IBEDT","IBRPT"
SET ZTSAVE(I)=""
+3 IF $DATA(IO("Q"))
SET ZTRTN="RPT^IBQLPL"
SET ZTDESC="UM - ROLLUP LIST"
DO ^%ZTLOAD
KILL IO("Q"),ZTSK
DO HOME^%ZIS
GOTO END
+4 USE IO
+5 ;
RPT ; -- entry point from taskman
+1 ; store data in ^tmp($j)
+2 KILL ^TMP("IBQLPL",$JOB),IB
+3 SET IBPAG=0
SET IBQUIT=0
+4 IF IBRPT="M"
DO REQFLDS
+5 DO START^IBQLPL1
+6 IF $GET(ZTSTOP)
GOTO END
+7 ;
+8 DO PRINT^IBQLPL2
+9 ;
END ; -- Clean up
+1 WRITE !
KILL ^TMP("IBQLPL",$JOB),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
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+3 DO ^%ZISC
+4 QUIT
+5 ;
PULL ;PULL DATES
+1 SET IBPDT1=$EXTRACT(DT,1,3)-1_"1001"_"-"_$EXTRACT(DT,1,3)_"0331"
SET IBRDT1=$EXTRACT(DT,1,3)_"0515"
+2 SET IBPDT2=$EXTRACT(DT,1,3)_"1001"_"-"_($EXTRACT(DT,1,3)+1)_"0331"
SET IBRDT2=$EXTRACT(DT,1,3)+1_"0515"
+3 SET IBPDT3=$EXTRACT(DT,1,3)_"0401"_"-"_$EXTRACT(DT,1,3)_"0930"
SET IBRDT3=$EXTRACT(DT,1,3)_"1115"
+4 SET IBRDT=$SELECT(DT'>IBRDT1:IBRDT1,DT>IBRDT3:IBRDT2,1:IBRDT3)
+5 SET IBPDT=$SELECT(DT'>IBRDT1:IBPDT1,DT>IBRDT3:IBPDT2,1:IBPDT3)
+6 SET IBBDT=$PIECE(IBPDT,"-")
SET IBEDT=$PIECE(IBPDT,"-",2)
+7 SET IBMSG=">> Next rollup transmission deadline: "
SET Y=IBRDT
XECUTE ^DD("DD")
SET IBMSG=IBMSG_Y
SET IBMSG1=">> Covering periods: "
SET Y=IBBDT
XECUTE ^DD("DD")
SET IBMSG1=IBMSG1_Y_" to "
SET Y=IBEDT
XECUTE ^DD("DD")
SET IBMSG1=IBMSG1_Y
+8 KILL IBPDT1,IBPDT2,IBPDT3,IBPDT,IBRDT,IBRDT2,IBRDT3,Y
QUIT
+9 ;
REQFLDS ; -- set ibd(fld#) for missing message explanation
+1 FOR I=3:1
SET X=$TEXT(REQFLDS+I)
if $PIECE(X,";",3)="Q"
QUIT
SET IBD($PIECE(X,";",3))=$PIECE(X,";",4)
+2 QUIT
+3 ;;.01;ENTRY ID;
+4 ;;.02;SITE;
+5 ;;.03;SSN;
+6 ;;.04;ADMITTING DIAGNOSIS;
+7 ;;.05;ENROLLMENT CODES;
+8 ;;.06;ADMITTING PHYSICIAN CODE;
+9 ;;.07;ATTENDING CODE;
+10 ;;.08;RESIDENT CODE;
+11 ;;.09;ACUTE CARE ADMISSION DATE (PATIENT MOVEMENT);
+12 ;;.1;ACUTE CARE DISCHARGE DATE;
+13 ;;.11;WARD;
+14 ;;.12;TREATING SPECIALTY;
+15 ;;.13;ACUTE ADMISSION(Y/N);
+16 ;;1.01;SEVERITY OF ILLNESS FROM ADMISSION;
+17 ;;1.02;INTENSITY OF SERVICE FROM ADMISSION;
+18 ;;1.03;REASON FOR NON-ACUTE ADMISSION;
+19 ;;1.04;PROVIDER INTERVIEWED(Y/N);
+20 ;;1.05;ADMISSION INFLUENCED(Y/N);
+21 ;;1.06;LOCAL, NATIONAL, OR BOTH;
+22 ;;1.07;SERVICE FROM ADMISSION REVIEW;
+23 ;;13.01;DAY OF CONTINUED STAY;
+24 ;;13.02;INTENSITY OF SERVICE FROM CONTINUED STAY;
+25 ;;13.03;SEVERITY OF ILLNESS FROM CONTINUED STAY;
+26 ;;13.04;D/C FROM CONTINUED STAY;
+27 ;;13.05;INTERVIEWED(Y/N);
+28 ;;13.06;REASONS FROM CONTINUED STAY;
+29 ;;13.07;TREATING SPECIALTY FROM CONTINUED STAY;
+30 ;;13.08;SERVICE FROM CONTINUED STAY;
+31 ;;Q;QUIT
