IBQLR1A ;LEB/MRY - ACUTE/NON-ACUTE REPORT ; 13-JUL-95
;;1.0;UTILIZATION MGMT ROLLUP LOCAL;;Oct 01, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
; -- called from IBQLR1
PRINT D SVCTAB^IBQLR1B S (IBTEXT,IBDATA,IBTS,IBQUIT,IBHDR,IBSVC)="",IBPAG=0 D MONTH
; -- call to return header dates, IBTDT, IBDRNG
D DTC^IBQLPL2
S IBHDR="UTILIZATION MANAGEMENT",IBHDR2="ACUTE AND NON-ACUTE REPORT FOR "_IBDRNG S:IBTY="S" IBHDR1="SERVICE" S:IBTY="T" IBHDR1="TREATING SPECIALTY,(SERVICE)"
;
F S IBSVC=$O(^TMP("IBQLR1",$J,IBSVC)) Q:IBSVC="" D TS Q:IBQUIT
G END
TS F S IBTS=$O(^TMP("IBQLR1",$J,IBSVC,IBTS)) Q:IBTS="" D Q:IBQUIT
.I IBTS=999 S IBSUBH=$S($D(IBSVC(IBSVC)):IBSVC(IBSVC),1:IBSVC("UNK"))
.E S IBSUBH=IBTS_",("_$S($D(IBSVC(IBSVC)):IBSVC(IBSVC),1:IBSVC("UNK"))_")"
.D PLINE
.F IBDAY=1,2 D Q:IBQUIT
..S (IBCAT,IBCATF)=""
..F S IBCAT=$O(^TMP("IBQLR1",$J,IBSVC,IBTS,IBDAY,IBCAT)) Q:IBCAT="" D Q:IBQUIT
...I $E(IBCAT,1)="C" D ACUTE
...I $E(IBCAT,1)="R" D REASON
Q
;
END K IBTS,IBTEXT,IBDATA,IBQUIT,IBHDR,IBMONTH,IBMD,IBMTH,IBCAT,MSTRING,N,I,X,IBDAY,IBRES,IBCATF
Q
ACUTE ;
S IBMONTH=""
I IBDAY=2&('IBCATF) W !,?3,"CONTINUED STAY REVIEWS" S IBCATF=1
S IBMONTH="" F S IBMONTH=$O(IBMONTH(IBMONTH)) Q:'IBMONTH D Q:IBQUIT
.S IBRES=$G(^TMP("IBQLR1",$J,IBSVC,IBTS,IBDAY,IBCAT,IBMONTH)) S:'IBRES IBRES=0 D MDATA
D PLINE Q:IBQUIT
Q
REASON ;
S IBREA=""
W:IBDAY=1 !,?3,"REASONS FOR NON-ACUTE ADMISSIONS" W:IBDAY=2 !,?3,"REASONS FOR NON-ACUTE CONTINUED STAYS"
F S IBREA=$O(^TMP("IBQLR1",$J,IBSVC,IBTS,IBDAY,IBCAT,IBREA)) Q:'IBREA D Q:IBQUIT
.S IBMONTH="" F S IBMONTH=$O(IBMONTH(IBMONTH)) Q:'IBMONTH D Q:IBQUIT
..S IBRES=$G(^TMP("IBQLR1",$J,IBSVC,IBTS,IBDAY,IBCAT,IBREA,IBMONTH)) S:'IBRES IBRES=0 D MDATA
.D PLINE Q:IBQUIT
Q
MDATA ;
S IBMTH=+$E(IBMONTH,4,5),IBMD=$P(MSTRING,"^",IBMTH)
F I=1:1 S X=$P(IBTEXT,",",I) Q:X=""!(X=IBMD)
I X'="" D
.S $P(IBDATA,",",I)=IBRES
.;.S $P(IBDATA,",",I)=$S($E(IBCAT,1)="C":^TMP("IBQLR1",$J,IBSVC,IBTS,IBDAY,IBCAT,IBMONTH),$E(IBCAT,1)="R":^TMP("IBQLR1",$J,IBSVC,IBTS,IBDAY,IBCAT,IBREA,IBMONTH),1:"")
.S $P(IBDATA,",",1)=$S(IBCAT="CNTA":"ACUTE",IBCAT="CNTN":"NON-ACUTE",IBCAT="REA":IBREA,1:"")
Q
;
PLINE ;
I IBPAG=0 D HDR
I $G(IBCAT)="" D
.W !!,IBSUBH,! S IBDATA=IBTEXT
F I=1:1 Q:$P(IBDATA,",",I)="" D
.I I=1 W ! W:$G(IBCAT)="" ?3 W:$G(IBCAT)'="" ?5 W $P(IBDATA,","),?30
.E W $J($P(IBDATA,",",I),3)_" "
D CHKL Q:IBQUIT
Q
HDR ; -- print headers
W:$E(IOST,1,2)["C-"!(IBPAG>0) @IOF S IBPAG=IBPAG+1
W !,IBTDT,?(IOM-$L(IBHDR)/2),IBHDR,?(IOM-10),"PAGE ",IBPAG
W !?(IOM-$L(IBHDR1)/2),IBHDR1,!,?(IOM-$L(IBHDR2)/2),IBHDR2
W !,$TR($J("",IOM)," ","-")
Q
;
CHKL ; -- check end of page
I IOSL<($Y+5),$E(IOST,1,2)="C-" D PAUSE^VALM1 S:$D(DIRUT) IBQUIT=1 Q:IBQUIT W @IOF D HDR Q
I $E(IOST,1,2)'="C-",IOSL<($Y+5) D HDR
Q
;
MONTH ;
S MSTRING="JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",X=""
F I=1:1 S X=$O(IBMONTH(X)) Q:'X D
.S IBTEXT=IBTEXT_$P(MSTRING,"^",+$E(X,4,5))_","
S IBTEXT="ADMISSION REVIEWS"_","_IBTEXT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBQLR1A 3101 printed Oct 16, 2024@18:42 Page 2
IBQLR1A ;LEB/MRY - ACUTE/NON-ACUTE REPORT ; 13-JUL-95
+1 ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;;Oct 01, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ; -- called from IBQLR1
PRINT DO SVCTAB^IBQLR1B
SET (IBTEXT,IBDATA,IBTS,IBQUIT,IBHDR,IBSVC)=""
SET IBPAG=0
DO MONTH
+1 ; -- call to return header dates, IBTDT, IBDRNG
+2 DO DTC^IBQLPL2
+3 SET IBHDR="UTILIZATION MANAGEMENT"
SET IBHDR2="ACUTE AND NON-ACUTE REPORT FOR "_IBDRNG
if IBTY="S"
SET IBHDR1="SERVICE"
if IBTY="T"
SET IBHDR1="TREATING SPECIALTY,(SERVICE)"
+4 ;
+5 FOR
SET IBSVC=$ORDER(^TMP("IBQLR1",$JOB,IBSVC))
if IBSVC=""
QUIT
DO TS
if IBQUIT
QUIT
+6 GOTO END
TS FOR
SET IBTS=$ORDER(^TMP("IBQLR1",$JOB,IBSVC,IBTS))
if IBTS=""
QUIT
Begin DoDot:1
+1 IF IBTS=999
SET IBSUBH=$SELECT($DATA(IBSVC(IBSVC)):IBSVC(IBSVC),1:IBSVC("UNK"))
+2 IF '$TEST
SET IBSUBH=IBTS_",("_$SELECT($DATA(IBSVC(IBSVC)):IBSVC(IBSVC),1:IBSVC("UNK"))_")"
+3 DO PLINE
+4 FOR IBDAY=1,2
Begin DoDot:2
+5 SET (IBCAT,IBCATF)=""
+6 FOR
SET IBCAT=$ORDER(^TMP("IBQLR1",$JOB,IBSVC,IBTS,IBDAY,IBCAT))
if IBCAT=""
QUIT
Begin DoDot:3
+7 IF $EXTRACT(IBCAT,1)="C"
DO ACUTE
+8 IF $EXTRACT(IBCAT,1)="R"
DO REASON
End DoDot:3
if IBQUIT
QUIT
End DoDot:2
if IBQUIT
QUIT
End DoDot:1
if IBQUIT
QUIT
+9 QUIT
+10 ;
END KILL IBTS,IBTEXT,IBDATA,IBQUIT,IBHDR,IBMONTH,IBMD,IBMTH,IBCAT,MSTRING,N,I,X,IBDAY,IBRES,IBCATF
+1 QUIT
ACUTE ;
+1 SET IBMONTH=""
+2 IF IBDAY=2&('IBCATF)
WRITE !,?3,"CONTINUED STAY REVIEWS"
SET IBCATF=1
+3 SET IBMONTH=""
FOR
SET IBMONTH=$ORDER(IBMONTH(IBMONTH))
if 'IBMONTH
QUIT
Begin DoDot:1
+4 SET IBRES=$GET(^TMP("IBQLR1",$JOB,IBSVC,IBTS,IBDAY,IBCAT,IBMONTH))
if 'IBRES
SET IBRES=0
DO MDATA
End DoDot:1
if IBQUIT
QUIT
+5 DO PLINE
if IBQUIT
QUIT
+6 QUIT
REASON ;
+1 SET IBREA=""
+2 if IBDAY=1
WRITE !,?3,"REASONS FOR NON-ACUTE ADMISSIONS"
if IBDAY=2
WRITE !,?3,"REASONS FOR NON-ACUTE CONTINUED STAYS"
+3 FOR
SET IBREA=$ORDER(^TMP("IBQLR1",$JOB,IBSVC,IBTS,IBDAY,IBCAT,IBREA))
if 'IBREA
QUIT
Begin DoDot:1
+4 SET IBMONTH=""
FOR
SET IBMONTH=$ORDER(IBMONTH(IBMONTH))
if 'IBMONTH
QUIT
Begin DoDot:2
+5 SET IBRES=$GET(^TMP("IBQLR1",$JOB,IBSVC,IBTS,IBDAY,IBCAT,IBREA,IBMONTH))
if 'IBRES
SET IBRES=0
DO MDATA
End DoDot:2
if IBQUIT
QUIT
+6 DO PLINE
if IBQUIT
QUIT
End DoDot:1
if IBQUIT
QUIT
+7 QUIT
MDATA ;
+1 SET IBMTH=+$EXTRACT(IBMONTH,4,5)
SET IBMD=$PIECE(MSTRING,"^",IBMTH)
+2 FOR I=1:1
SET X=$PIECE(IBTEXT,",",I)
if X=""!(X=IBMD)
QUIT
+3 IF X'=""
Begin DoDot:1
+4 SET $PIECE(IBDATA,",",I)=IBRES
+5 ;.S $P(IBDATA,",",I)=$S($E(IBCAT,1)="C":^TMP("IBQLR1",$J,IBSVC,IBTS,IBDAY,IBCAT,IBMONTH),$E(IBCAT,1)="R":^TMP("IBQLR1",$J,IBSVC,IBTS,IBDAY,IBCAT,IBREA,IBMONTH),1:"")
+6 SET $PIECE(IBDATA,",",1)=$SELECT(IBCAT="CNTA":"ACUTE",IBCAT="CNTN":"NON-ACUTE",IBCAT="REA":IBREA,1:"")
End DoDot:1
+7 QUIT
+8 ;
PLINE ;
+1 IF IBPAG=0
DO HDR
+2 IF $GET(IBCAT)=""
Begin DoDot:1
+3 WRITE !!,IBSUBH,!
SET IBDATA=IBTEXT
End DoDot:1
+4 FOR I=1:1
if $PIECE(IBDATA,",",I)=""
QUIT
Begin DoDot:1
+5 IF I=1
WRITE !
if $GET(IBCAT)=""
WRITE ?3
if $GET(IBCAT)'=""
WRITE ?5
WRITE $PIECE(IBDATA,","),?30
+6 IF '$TEST
WRITE $JUSTIFY($PIECE(IBDATA,",",I),3)_" "
End DoDot:1
+7 DO CHKL
if IBQUIT
QUIT
+8 QUIT
HDR ; -- print headers
+1 if $EXTRACT(IOST,1,2)["C-"!(IBPAG>0)
WRITE @IOF
SET IBPAG=IBPAG+1
+2 WRITE !,IBTDT,?(IOM-$LENGTH(IBHDR)/2),IBHDR,?(IOM-10),"PAGE ",IBPAG
+3 WRITE !?(IOM-$LENGTH(IBHDR1)/2),IBHDR1,!,?(IOM-$LENGTH(IBHDR2)/2),IBHDR2
+4 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
+5 QUIT
+6 ;
CHKL ; -- check end of page
+1 IF IOSL<($Y+5)
IF $EXTRACT(IOST,1,2)="C-"
DO PAUSE^VALM1
if $DATA(DIRUT)
SET IBQUIT=1
if IBQUIT
QUIT
WRITE @IOF
DO HDR
QUIT
+2 IF $EXTRACT(IOST,1,2)'="C-"
IF IOSL<($Y+5)
DO HDR
+3 QUIT
+4 ;
MONTH ;
+1 SET MSTRING="JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC"
SET X=""
+2 FOR I=1:1
SET X=$ORDER(IBMONTH(X))
if 'X
QUIT
Begin DoDot:1
+3 SET IBTEXT=IBTEXT_$PIECE(MSTRING,"^",+$EXTRACT(X,4,5))_","
End DoDot:1
+4 SET IBTEXT="ADMISSION REVIEWS"_","_IBTEXT
+5 QUIT
