RATIMBUL ;BPFO/CLT - BULLETIN BASED ON CREATION DATE ; 12 Sep 2016 1:33 PM
;;5.0;Radiology/Nuclear Medicine;**127**;Mar 16, 1998;Build 119
;;Per VHA Directive 10-93-142, this routine should not be modified
;
EN ;MAIN ENTRY POINT
N RAINTER,RASRCH,RAEND,X,X1,X2,Y,RAFAC,RAFN,RADT,RAIEN,CRDT,COMDT
K ^XTMP("RATIMBUL",$J) S ^XTMP("RATIMBUL",$J,0)=DT_U_DT
S RAINTER=$P($G(^RAMRPF(71.98,1,0)),U,6)
SET ;SET THE SEARCH DATES BASED ON RAINTER
S RASRCH=$S(RAINTER="D":1,RAINTER="W":7,RAINTER="M":30,RAINTER="Q":90,RAINTER="S":180,RAINTER="A":360,1:0) Q:RASRCH=0
S X1=DT,X2=-720 D C^%DTC S RAEND=X
S X1=DT,X2=-RASRCH,X3=-RASRCH F D C^%DTC Q:X<RAEND S ^XTMP("RATIMBUL",$J,X)=-X3 S X3=X3-RASRCH,X1=DT,X2=X3
SRCH ;SEARCH FOR AN ENTY REQUIRING A BULLETIN
S RADT="" F S RADT=$O(^RAMIS(71,"CREAT",RADT)) Q:RADT="" S RAIEN="" F S RAIEN=$O(^RAMIS(71,"CREAT",RADT,RAIEN)) Q:RAIEN="" D
. Q:$P(^RAMIS(71,RAIEN,"NTRT"),U,1)'=""
. Q:$P(^RAMIS(71,RAIEN,"NTRT"),U,3)=""
. Q:$P(^RAMIS(71,RAIEN,"NTRT"),U,3)<RAEND
. I $D(^XTMP("RATIMBUL",$J,$P(^RAMIS(71,RAIEN,"NTRT"),U,3))) D
.. S XMB="UNMATCHED RADIOLOGY PROCEDURE"
..S XMB(1)=^XTMP("RATIMBUL",$J,$P(^RAMIS(71,RAIEN,"NTRT"),U,3))
.. S XMB(2)=$P(^RAMIS(71,RAIEN,0),U,1)
.. S XMB(3)=$P(^RAMIS(71,RAIEN,0),U,9)
.. S RAFAC=$$KSP^XUPARAM("INST"),RAFAC=$$NS^XUAF4(RAFAC)
.. S RAFN=$P(RAFAC,U,2),RAFAC=$P(RAFAC,U,1)
.. S XMB(4)=" "_RAFN_" / "_RAFAC
.. S CRDT=$P(^RAMIS(71,RAIEN,"NTRT"),U,3),COMDT=$P(^RAMIS(71,RAIEN,"NTRT"),U,3)
.. S XMB(5)=$E(CRDT,4,5)_"/"_$E(CRDT,6,7)_"/"_($E(CRDT,1,3)+1700)
.. S XMB(6)=$E(COMDT,4,5)_"/"_$E(COMDT,6,7)_"/"_($E(COMDT,1,3)+1700)
.. S XMB(7)=RAIEN
.. ;S XMY("G.RADNTRT@CHEY59.FO-BAYPINES.DOMAIN.EXT")=""
.. ;S XMY("G.RADNTRT")=""
.. D ^XMB
.. Q
. Q
END ;END THE ROUTINE
K ^XTMP("RATIMBUL",$J),X3,XMB,XMV,XMDUN,XMDUZ
TIMBUL ;QUEUE THE TIME BULLETIN
S ZTRTN="RATIMBUL",ZTDESC="Radiology new procedure time bulletin"
S X1=DT,X2=1 D C^%DTC S ZTDTH=X_.0300
D ^%ZTLOAD
K ZTSK,ZTRTN,ZTDESC,ZTDTH,X1,X2,X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRATIMBUL 2037 printed Dec 13, 2024@02:40:04 Page 2
RATIMBUL ;BPFO/CLT - BULLETIN BASED ON CREATION DATE ; 12 Sep 2016 1:33 PM
+1 ;;5.0;Radiology/Nuclear Medicine;**127**;Mar 16, 1998;Build 119
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified
+3 ;
EN ;MAIN ENTRY POINT
+1 NEW RAINTER,RASRCH,RAEND,X,X1,X2,Y,RAFAC,RAFN,RADT,RAIEN,CRDT,COMDT
+2 KILL ^XTMP("RATIMBUL",$JOB)
SET ^XTMP("RATIMBUL",$JOB,0)=DT_U_DT
+3 SET RAINTER=$PIECE($GET(^RAMRPF(71.98,1,0)),U,6)
SET ;SET THE SEARCH DATES BASED ON RAINTER
+1 SET RASRCH=$SELECT(RAINTER="D":1,RAINTER="W":7,RAINTER="M":30,RAINTER="Q":90,RAINTER="S":180,RAINTER="A":360,1:0)
if RASRCH=0
QUIT
+2 SET X1=DT
SET X2=-720
DO C^%DTC
SET RAEND=X
+3 SET X1=DT
SET X2=-RASRCH
SET X3=-RASRCH
FOR
DO C^%DTC
if X<RAEND
QUIT
SET ^XTMP("RATIMBUL",$JOB,X)=-X3
SET X3=X3-RASRCH
SET X1=DT
SET X2=X3
SRCH ;SEARCH FOR AN ENTY REQUIRING A BULLETIN
+1 SET RADT=""
FOR
SET RADT=$ORDER(^RAMIS(71,"CREAT",RADT))
if RADT=""
QUIT
SET RAIEN=""
FOR
SET RAIEN=$ORDER(^RAMIS(71,"CREAT",RADT,RAIEN))
if RAIEN=""
QUIT
Begin DoDot:1
+2 if $PIECE(^RAMIS(71,RAIEN,"NTRT"),U,1)'=""
QUIT
+3 if $PIECE(^RAMIS(71,RAIEN,"NTRT"),U,3)=""
QUIT
+4 if $PIECE(^RAMIS(71,RAIEN,"NTRT"),U,3)<RAEND
QUIT
+5 IF $DATA(^XTMP("RATIMBUL",$JOB,$PIECE(^RAMIS(71,RAIEN,"NTRT"),U,3)))
Begin DoDot:2
+6 SET XMB="UNMATCHED RADIOLOGY PROCEDURE"
+7 SET XMB(1)=^XTMP("RATIMBUL",$JOB,$PIECE(^RAMIS(71,RAIEN,"NTRT"),U,3))
+8 SET XMB(2)=$PIECE(^RAMIS(71,RAIEN,0),U,1)
+9 SET XMB(3)=$PIECE(^RAMIS(71,RAIEN,0),U,9)
+10 SET RAFAC=$$KSP^XUPARAM("INST")
SET RAFAC=$$NS^XUAF4(RAFAC)
+11 SET RAFN=$PIECE(RAFAC,U,2)
SET RAFAC=$PIECE(RAFAC,U,1)
+12 SET XMB(4)=" "_RAFN_" / "_RAFAC
+13 SET CRDT=$PIECE(^RAMIS(71,RAIEN,"NTRT"),U,3)
SET COMDT=$PIECE(^RAMIS(71,RAIEN,"NTRT"),U,3)
+14 SET XMB(5)=$EXTRACT(CRDT,4,5)_"/"_$EXTRACT(CRDT,6,7)_"/"_($EXTRACT(CRDT,1,3)+1700)
+15 SET XMB(6)=$EXTRACT(COMDT,4,5)_"/"_$EXTRACT(COMDT,6,7)_"/"_($EXTRACT(COMDT,1,3)+1700)
+16 SET XMB(7)=RAIEN
+17 ;S XMY("G.RADNTRT@CHEY59.FO-BAYPINES.DOMAIN.EXT")=""
+18 ;S XMY("G.RADNTRT")=""
+19 DO ^XMB
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
END ;END THE ROUTINE
+1 KILL ^XTMP("RATIMBUL",$JOB),X3,XMB,XMV,XMDUN,XMDUZ
TIMBUL ;QUEUE THE TIME BULLETIN
+1 SET ZTRTN="RATIMBUL"
SET ZTDESC="Radiology new procedure time bulletin"
+2 SET X1=DT
SET X2=1
DO C^%DTC
SET ZTDTH=X_.0300
+3 DO ^%ZTLOAD
+4 KILL ZTSK,ZTRTN,ZTDESC,ZTDTH,X1,X2,X
+5 QUIT
