- IBQLD1A ;LEB/MRY - ACUTE/NON-ACUTE DOWNLOAD ; 17-MAY-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("IBQLD1",$J,IBSVC)) Q:IBSVC="" D TS Q:IBQUIT
- G END
- TS F S IBTS=$O(^TMP("IBQLD1",$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"))_")"
- .I IBTY="I",'$D(IBTS(IBTS)) Q
- .D PLINE
- .F IBDAY=1,2 D Q:IBQUIT
- ..S (IBCAT,IBCATF)=""
- ..F S IBCAT=$O(^TMP("IBQLD1",$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 !,"CONTINUED STAY DAYS" S IBCATF=1
- S IBMONTH="" F S IBMONTH=$O(IBMONTH(IBMONTH)) Q:'IBMONTH D Q:IBQUIT
- .S IBRES=$G(^TMP("IBQLD1",$J,IBSVC,IBTS,IBDAY,IBCAT,IBMONTH)) S:'IBRES IBRES=0 D MDATA
- D PLINE Q:IBQUIT
- Q
- REASON ;
- S IBREA=""
- W:IBDAY=1 !,"REASONS FOR NON-ACUTE ADMISSIONS" W:IBDAY=2 !,"REASONS FOR NON-ACUTE STAY DAYS"
- F S IBREA=$O(^TMP("IBQLD1",$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("IBQLD1",$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,"^",1)=$S(IBCAT="CNTA":"ACUTE",IBCAT="CNTN":"NON-ACUTE",IBCAT="REA":IBREA,1:"")
- Q
- ;
- PLINE ;
- I $G(IBCAT)="" D
- .W !!,IBSUBH,! S IBDATA=IBTEXT
- W !,IBDATA
- 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="ADMISSIONS^"_IBTEXT
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBQLD1A 2367 printed Mar 13, 2025@21:45:53 Page 2
- IBQLD1A ;LEB/MRY - ACUTE/NON-ACUTE DOWNLOAD ; 17-MAY-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("IBQLD1",$JOB,IBSVC))
- if IBSVC=""
- QUIT
- DO TS
- if IBQUIT
- QUIT
- +6 GOTO END
- TS FOR
- SET IBTS=$ORDER(^TMP("IBQLD1",$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 IF IBTY="I"
- IF '$DATA(IBTS(IBTS))
- QUIT
- +4 DO PLINE
- +5 FOR IBDAY=1,2
- Begin DoDot:2
- +6 SET (IBCAT,IBCATF)=""
- +7 FOR
- SET IBCAT=$ORDER(^TMP("IBQLD1",$JOB,IBSVC,IBTS,IBDAY,IBCAT))
- if IBCAT=""
- QUIT
- Begin DoDot:3
- +8 IF $EXTRACT(IBCAT,1)="C"
- DO ACUTE
- +9 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
- +10 QUIT
- +11 ;
- 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 !,"CONTINUED STAY DAYS"
- SET IBCATF=1
- +3 SET IBMONTH=""
- FOR
- SET IBMONTH=$ORDER(IBMONTH(IBMONTH))
- if 'IBMONTH
- QUIT
- Begin DoDot:1
- +4 SET IBRES=$GET(^TMP("IBQLD1",$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 !,"REASONS FOR NON-ACUTE ADMISSIONS"
- if IBDAY=2
- WRITE !,"REASONS FOR NON-ACUTE STAY DAYS"
- +3 FOR
- SET IBREA=$ORDER(^TMP("IBQLD1",$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("IBQLD1",$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 SET $PIECE(IBDATA,"^",1)=$SELECT(IBCAT="CNTA":"ACUTE",IBCAT="CNTN":"NON-ACUTE",IBCAT="REA":IBREA,1:"")
- End DoDot:1
- +6 QUIT
- +7 ;
- PLINE ;
- +1 IF $GET(IBCAT)=""
- Begin DoDot:1
- +2 WRITE !!,IBSUBH,!
- SET IBDATA=IBTEXT
- End DoDot:1
- +3 WRITE !,IBDATA
- +4 QUIT
- +5 ;
- 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="ADMISSIONS^"_IBTEXT
- +5 QUIT
