- IBQLR4A ;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 S (IBTEXT,IBDATA,IBQUIT,IBHDR,IBDIAG)="",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,IBHDR1="ADMITTING DIAGNOSIS"
- ;
- I '$D(^TMP("IBQLR4",$J)) D HDR W !!,?20,"<<< NO PATIENTS TO PRINT >>>" Q
- DIAG F S IBDIAG=$O(^TMP("IBQLR4",$J,IBDIAG)) Q:IBDIAG="" D Q:IBQUIT
- .S IBSUBH="ADMITTING DIAGNOSIS: "_IBDIAG
- .D PLINE
- .F IBDAY=1,2 D Q:IBQUIT
- ..S (IBCAT,IBCATF)=""
- ..F S IBCAT=$O(^TMP("IBQLR4",$J,IBDIAG,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("IBQLR4",$J,IBDIAG,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("IBQLR4",$J,IBDIAG,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("IBQLR4",$J,IBDIAG,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("IBQLR4",$J,IBDIAG,IBDAY,IBCAT,IBMONTH),$E(IBCAT,1)="R":^TMP("IBQLR4",$J,IBDIAG,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[HIBQLR4A 2907 printed Feb 19, 2025@00:07:48 Page 2
- IBQLR4A ;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 SET (IBTEXT,IBDATA,IBQUIT,IBHDR,IBDIAG)=""
- 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
- SET IBHDR1="ADMITTING DIAGNOSIS"
- +4 ;
- +5 IF '$DATA(^TMP("IBQLR4",$JOB))
- DO HDR
- WRITE !!,?20,"<<< NO PATIENTS TO PRINT >>>"
- QUIT
- DIAG FOR
- SET IBDIAG=$ORDER(^TMP("IBQLR4",$JOB,IBDIAG))
- if IBDIAG=""
- QUIT
- Begin DoDot:1
- +1 SET IBSUBH="ADMITTING DIAGNOSIS: "_IBDIAG
- +2 DO PLINE
- +3 FOR IBDAY=1,2
- Begin DoDot:2
- +4 SET (IBCAT,IBCATF)=""
- +5 FOR
- SET IBCAT=$ORDER(^TMP("IBQLR4",$JOB,IBDIAG,IBDAY,IBCAT))
- if IBCAT=""
- QUIT
- Begin DoDot:3
- +6 IF $EXTRACT(IBCAT,1)="C"
- DO ACUTE
- +7 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
- +8 QUIT
- +9 ;
- 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("IBQLR4",$JOB,IBDIAG,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("IBQLR4",$JOB,IBDIAG,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("IBQLR4",$JOB,IBDIAG,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("IBQLR4",$J,IBDIAG,IBDAY,IBCAT,IBMONTH),$E(IBCAT,1)="R":^TMP("IBQLR4",$J,IBDIAG,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