IBQLT ;LEB/MRY - TRANSMIT DATA ; 24-APR-95
;;1.0;UTILIZATION MGMT ROLLUP LOCAL;**1,2**;Oct 01, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
I '$D(DT) D DT^DICRW
;D PULL^IBQLPL
W !!,"Transmit Rollup 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
;
DEC95 ;; -- per Directive ....
;; -- until 1/1/96, allow sites to transmit previous rollup periods.
;I DT<2960101,DT<2951116 D ASK^IBQLT5 G:IBQUIT END
;I DT<2960101,DT>2951115 D ASK^IBQLT5A G:IBQUIT END
;
; - ask user for roll-up period to be transmitted
D RANGE^IBQLT5 G:IBQUIT END
;
F I="IBBDT","IBEDT" S ZTSAVE(I)=""
S ZTRTN="START^IBQLT",ZTDESC="IBQ - TRANSMIT ROLLUP DATA",ZTIO=""
W ! D ^%ZTLOAD G END
;
START ;
S IBDDT=IBBDT-.01,IBCNT=0,IBREC=0
S IBCNT=1,^TMP("IBQLT",$J,IBCNT,0)="**"_"^"_IBBDT_"^"_IBEDT
F S IBDDT=$O(^IBQ(538,"ADIS",IBDDT)) Q:'IBDDT!(IBDDT>IBEDT) D
.S IBTRN="" F S IBTRN=$O(^IBQ(538,"ADIS",IBDDT,IBTRN)) Q:'IBTRN D DATA
;
; -- transmit data thru mailman handler
D TRANSMIT
;
END K ^TMP("IBQLT",$J),^TMP("IBQ",$J),IBDDT,IBTRN,INTRND0,IBTRND1,IBTRND2,IBREC,IBCNT,IBBDT1,IBEDT1
K IBBDT,IBEDT,IBMSG,IBMSG1,IBRDT1,IBQUIT
Q
;
;
DATA ; -- build ^tmp($j,cnt,0) and ^tmp("ibql",$j,cnt,0) for mailman handler.
; IBTRND0 = entry id^site^ssn^admitting diagnosis^enroll code^
; admitting phy^attending phy^resident phy,^admission^
; discharge^ward^treating specialty^acute adm?^
; IBTRND1 = si from adm^is from adm^reasons from adm^
; provider interviewed?^adm influenced?^rollup type^service
; IBTRND2 = day^is^si^d/s^interviewed?^reasons^service
;
I '$G(^IBQ(538,IBTRN,0))!($P(^(1),"^",6)="L") Q
S IBREC=IBREC+1,IBTRND0=^IBQ(538,IBTRN,0),IBTRND1=$G(^(1))
I '$P(IBTRND0,"^",2) S $P(IBTRND0,"^",2)=$P($$SITE^VASITE,"^")
; -- null out unwanted field entries from transmission.
; -- admitting phy,attending phy,resident phy,ward
F I=6,7,8,11 S $P(IBTRND0,"^",I)=""
S IBCNT=IBCNT+1,^TMP("IBQLT",$J,IBCNT,0)=IBTRND0_"^"_IBTRND1
; -- continued stay reviews
S N=0 F S N=$O(^IBQ(538,IBTRN,13,N)) Q:'N D
.S IBTRND2=^IBQ(538,IBTRN,13,N,0),$P(IBTRND2,"^")=$P(IBTRND0,"^")_"."_$P(IBTRND2,"^")
.S IBCNT=IBCNT+1,^TMP("IBQLT",$J,IBCNT,0)=IBTRND2
Q
;
TRANSMIT ;
; -- transmit data to National DataBase
S Y=IBBDT X ^DD("DD") S IBBDT1=Y S Y=IBEDT X ^DD("DD") S IBEDT1=Y
S XMY("S.IBQN SERVER@ISC-CHICAGO.DOMAIN.EXT")="",XMDUZ="UTILIZATION MANAGEMENT ROLLUP MONITOR"
S XMTEXT="^TMP(""IBQLT"",$J,",XMSUB="Rollup Extract" D ^XMD
; -- transmit local message
S XMY("G.IBQ ROLLUP")=""
S XMSUB="Rollup Extract transmitted",XMDUZ="IBQ MONITOR"
S ^TMP("IBQ",$J,1,0)="Utilization Management Rollup was transmitted.",^TMP("IBQ",$J,2,0)=""
S ^TMP("IBQ",$J,3,0)="Site: "_$P($$SITE^VASITE,"^"),^TMP("IBQ",$J,5,0)="Number of Records sent: "_IBREC
S ^TMP("IBQ",$J,6,0)="Period: "_IBBDT1_" - "_IBEDT1
S XMTEXT="^TMP(""IBQ"",$J," D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBQLT 3056 printed Dec 13, 2024@02:41:35 Page 2
IBQLT ;LEB/MRY - TRANSMIT DATA ; 24-APR-95
+1 ;;1.0;UTILIZATION MGMT ROLLUP LOCAL;**1,2**;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 ;D PULL^IBQLPL
+6 WRITE !!,"Transmit Rollup 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 ;I IBMSG'="" W !!,IBMSG,!,IBMSG1
+9 ;
DEC95 ;; -- per Directive ....
+1 ;; -- until 1/1/96, allow sites to transmit previous rollup periods.
+2 ;I DT<2960101,DT<2951116 D ASK^IBQLT5 G:IBQUIT END
+3 ;I DT<2960101,DT>2951115 D ASK^IBQLT5A G:IBQUIT END
+4 ;
+5 ; - ask user for roll-up period to be transmitted
+6 DO RANGE^IBQLT5
if IBQUIT
GOTO END
+7 ;
+8 FOR I="IBBDT","IBEDT"
SET ZTSAVE(I)=""
+9 SET ZTRTN="START^IBQLT"
SET ZTDESC="IBQ - TRANSMIT ROLLUP DATA"
SET ZTIO=""
+10 WRITE !
DO ^%ZTLOAD
GOTO END
+11 ;
START ;
+1 SET IBDDT=IBBDT-.01
SET IBCNT=0
SET IBREC=0
+2 SET IBCNT=1
SET ^TMP("IBQLT",$JOB,IBCNT,0)="**"_"^"_IBBDT_"^"_IBEDT
+3 FOR
SET IBDDT=$ORDER(^IBQ(538,"ADIS",IBDDT))
if 'IBDDT!(IBDDT>IBEDT)
QUIT
Begin DoDot:1
+4 SET IBTRN=""
FOR
SET IBTRN=$ORDER(^IBQ(538,"ADIS",IBDDT,IBTRN))
if 'IBTRN
QUIT
DO DATA
End DoDot:1
+5 ;
+6 ; -- transmit data thru mailman handler
+7 DO TRANSMIT
+8 ;
END KILL ^TMP("IBQLT",$JOB),^TMP("IBQ",$JOB),IBDDT,IBTRN,INTRND0,IBTRND1,IBTRND2,IBREC,IBCNT,IBBDT1,IBEDT1
+1 KILL IBBDT,IBEDT,IBMSG,IBMSG1,IBRDT1,IBQUIT
+2 QUIT
+3 ;
+4 ;
DATA ; -- build ^tmp($j,cnt,0) and ^tmp("ibql",$j,cnt,0) for mailman handler.
+1 ; IBTRND0 = entry id^site^ssn^admitting diagnosis^enroll code^
+2 ; admitting phy^attending phy^resident phy,^admission^
+3 ; discharge^ward^treating specialty^acute adm?^
+4 ; IBTRND1 = si from adm^is from adm^reasons from adm^
+5 ; provider interviewed?^adm influenced?^rollup type^service
+6 ; IBTRND2 = day^is^si^d/s^interviewed?^reasons^service
+7 ;
+8 IF '$GET(^IBQ(538,IBTRN,0))!($PIECE(^(1),"^",6)="L")
QUIT
+9 SET IBREC=IBREC+1
SET IBTRND0=^IBQ(538,IBTRN,0)
SET IBTRND1=$GET(^(1))
+10 IF '$PIECE(IBTRND0,"^",2)
SET $PIECE(IBTRND0,"^",2)=$PIECE($$SITE^VASITE,"^")
+11 ; -- null out unwanted field entries from transmission.
+12 ; -- admitting phy,attending phy,resident phy,ward
+13 FOR I=6,7,8,11
SET $PIECE(IBTRND0,"^",I)=""
+14 SET IBCNT=IBCNT+1
SET ^TMP("IBQLT",$JOB,IBCNT,0)=IBTRND0_"^"_IBTRND1
+15 ; -- continued stay reviews
+16 SET N=0
FOR
SET N=$ORDER(^IBQ(538,IBTRN,13,N))
if 'N
QUIT
Begin DoDot:1
+17 SET IBTRND2=^IBQ(538,IBTRN,13,N,0)
SET $PIECE(IBTRND2,"^")=$PIECE(IBTRND0,"^")_"."_$PIECE(IBTRND2,"^")
+18 SET IBCNT=IBCNT+1
SET ^TMP("IBQLT",$JOB,IBCNT,0)=IBTRND2
End DoDot:1
+19 QUIT
+20 ;
TRANSMIT ;
+1 ; -- transmit data to National DataBase
+2 SET Y=IBBDT
XECUTE ^DD("DD")
SET IBBDT1=Y
SET Y=IBEDT
XECUTE ^DD("DD")
SET IBEDT1=Y
+3 SET XMY("S.IBQN SERVER@ISC-CHICAGO.DOMAIN.EXT")=""
SET XMDUZ="UTILIZATION MANAGEMENT ROLLUP MONITOR"
+4 SET XMTEXT="^TMP(""IBQLT"",$J,"
SET XMSUB="Rollup Extract"
DO ^XMD
+5 ; -- transmit local message
+6 SET XMY("G.IBQ ROLLUP")=""
+7 SET XMSUB="Rollup Extract transmitted"
SET XMDUZ="IBQ MONITOR"
+8 SET ^TMP("IBQ",$JOB,1,0)="Utilization Management Rollup was transmitted."
SET ^TMP("IBQ",$JOB,2,0)=""
+9 SET ^TMP("IBQ",$JOB,3,0)="Site: "_$PIECE($$SITE^VASITE,"^")
SET ^TMP("IBQ",$JOB,5,0)="Number of Records sent: "_IBREC
+10 SET ^TMP("IBQ",$JOB,6,0)="Period: "_IBBDT1_" - "_IBEDT1
+11 SET XMTEXT="^TMP(""IBQ"",$J,"
DO ^XMD
+12 QUIT
