Routine: IBQLPL

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

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)

 ;;.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  Mar 13, 2025@21:46:03                                                                                                                                                                                                      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

IBQLPL.m