RARTR2 ;HIRMFO/GJC-Queue/print Radiology Reports (utility) ;3/11/96
;;5.0;Radiology/Nuclear Medicine;**15,27**;Mar 16, 1998
SETDIV ;get division params
S RAMDV="" N RADTI,RACNI,RADTE,RACN,RADATE,Y,RADFN
S Y=RARPT D RASET^RAUTL2 S LOC=$P(^RADPT(RADFN,"DT",RADTI,0),U,4)
I 'LOC Q
S DIV=$O(^RA(79,"AL",LOC,0)) I 'DIV Q
S RAMDIV=DIV,Y=$S($D(^RA(79,DIV,.1)):^(.1),1:""),RAMDV="" F I=1:1 Q:$P(Y,"^",I,99)']"" S RAMDV=RAMDV_$S($P(Y,"^",I)="Y"!($P(Y,"^",I)="y"):1,1:0)_"^"
Q
WRITE ; Write out Report Text, Impression Text, Clinical History and
; Additional Clinical History on report.
K RAXX S RAV=0
; Get Additional Clinical History, Report Text and Impression text
; from file 74
I RAP="AH"!(RAP="R")!(RAP="I") D
. S ZRAP=$S(RAP="AH":"H",1:RAP)
. F S RAV=$O(^RARPT(RARPT,ZRAP,RAV)) Q:RAV'>0!($D(RAOOUT)) S RAXX=^(RAV,0) D HANG:($Y+RAFOOT+4)>IOSL Q:$D(RAOOUT) D HD^RARTR:($Y+RAFOOT+4)>IOSL S X=RAXX D ^DIWP
; Get Clinical History from file 70
I RAP="H" D
. F S RAV=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAV)) Q:RAV'>0!($D(RAOOUT)) S RAXX=^(RAV,0) D HANG:($Y+RAFOOT+4)>IOSL Q:$D(RAOOUT) D HD^RARTR:($Y+RAFOOT+4)>IOSL S X=RAXX D ^DIWP
D ^DIWW:$D(RAXX)
Q
Q:$D(RAUTOE) ; quit if e-mail
I RAFOOT,(IOST'["P-MESSAGE") F I=0:0 Q:($Y+RAFOOT+5)>IOSL W !
I IOST["P-MESSAGE" W !!!!!
I RAFOOT S RAIOF=RAFFLF,RAFFLF="!",RAFMT=RAFTFM D PRT^RAFLH S RAFFLF=RAIOF
I IOST'["P-MESSAGE" F I=0:0 Q:($Y+4)>IOSL W !
W !,"VAF 10-9034 VICE SF 519B RADIOLOGY/NUCLEAR MEDICINE REPORT"
Q
;
BANNER ;Report Batch Header/Trailer Page
Q:'$D(RARTMES)!($D(RAUTOE)) S $P(F1,">",((IOM-$L(RARTMES))/2))="",$P(F2,"<",((IOM-$L(RARTMES))/2))="" U IO S RAFFLF=$S($D(RAFFLF):RAFFLF,1:"#") W @RAFFLF
F I=1:1:10 W !,F1," ",RARTMES," ",F2
W !!?((IOM-30)/2),"Printed at " S X="NOW",%DT="TX" D ^%DT,D^RAUTL W Y
F I=1:1 Q:($Y+12)>IOSL W !
F I=1:1 Q:($Y+2)>IOSL W !,F1," ",RARTMES," ",F2
K F1,F2 Q
HANG ; end-of-page prompt
Q:$D(RAUTOE) ; quit if e-mail
I $E(IOST,1,2)="C-" S DIR(0)="E" W ! D ^DIR K DIR S:$D(DIRUT) RAOOUT=1 W @RAFFLF
Q
SET ; Set up our TMP global for mailman
N DIWF,DIWL,DIWR,RAX,X,RAPX S RAX=0
S DIWF="",DIWL=5,DIWR=70 K ^UTILITY($J,"W")
; Get Additional Clinical History, Report Text and Impression text
; from file 74
I RAP="AH"!(RAP="R")!(RAP="I") D
. S RAPX=$S(RAP="AH":"H",1:RAP)
. F S RAX=$O(^RARPT(RARPT,RAPX,RAX)) Q:RAX'>0 D
. . S X=$G(^RARPT(RARPT,RAPX,RAX,0)) D ^DIWP
. Q
; Get Clinical History from file 70
I RAP="H" D
. F S RAX=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAX)) Q:RAX'>0 D
. . S X=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAX,0)) D ^DIWP
. Q
S RAX=0 F S RAX=$O(^UTILITY($J,"W",DIWL,RAX)) Q:RAX'>0 D
. S X=$G(^UTILITY($J,"W",DIWL,RAX,0))
. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_X
. Q
S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
Q
AMENRPT() ; Pass the text, '*** THIS IS AN AMENDED REPORT ***'.
Q "*** THIS IS AN AMENDED REPORT ***"
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRARTR2 2995 printed Oct 16, 2024@18:40:03 Page 2
RARTR2 ;HIRMFO/GJC-Queue/print Radiology Reports (utility) ;3/11/96
+1 ;;5.0;Radiology/Nuclear Medicine;**15,27**;Mar 16, 1998
SETDIV ;get division params
+1 SET RAMDV=""
NEW RADTI,RACNI,RADTE,RACN,RADATE,Y,RADFN
+2 SET Y=RARPT
DO RASET^RAUTL2
SET LOC=$PIECE(^RADPT(RADFN,"DT",RADTI,0),U,4)
+3 IF 'LOC
QUIT
+4 SET DIV=$ORDER(^RA(79,"AL",LOC,0))
IF 'DIV
QUIT
+5 SET RAMDIV=DIV
SET Y=$SELECT($DATA(^RA(79,DIV,.1)):^(.1),1:"")
SET RAMDV=""
FOR I=1:1
if $PIECE(Y,"^",I,99)']""
QUIT
SET RAMDV=RAMDV_$SELECT($PIECE(Y,"^",I)="Y"!($PIECE(Y,"^",I)="y"):1,1:0)_"^"
+6 QUIT
WRITE ; Write out Report Text, Impression Text, Clinical History and
+1 ; Additional Clinical History on report.
+2 KILL RAXX
SET RAV=0
+3 ; Get Additional Clinical History, Report Text and Impression text
+4 ; from file 74
+5 IF RAP="AH"!(RAP="R")!(RAP="I")
Begin DoDot:1
+6 SET ZRAP=$SELECT(RAP="AH":"H",1:RAP)
+7 FOR
SET RAV=$ORDER(^RARPT(RARPT,ZRAP,RAV))
if RAV'>0!($DATA(RAOOUT))
QUIT
SET RAXX=^(RAV,0)
if ($Y+RAFOOT+4)>IOSL
DO HANG
if $DATA(RAOOUT)
QUIT
if ($Y+RAFOOT+4)>IOSL
DO HD^RARTR
SET X=RAXX
DO ^DIWP
End DoDot:1
+8 ; Get Clinical History from file 70
+9 IF RAP="H"
Begin DoDot:1
+10 FOR
SET RAV=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAV))
if RAV'>0!($DATA(RAOOUT))
QUIT
SET RAXX=^(RAV,0)
if ($Y+RAFOOT+4)>IOSL
DO HANG
if $DATA(RAOOUT)
QUIT
if ($Y+RAFOOT+4)>IOSL
DO HD^RARTR
SET X=RAXX
DO ^DIWP
End DoDot:1
+11 if $DATA(RAXX)
DO ^DIWW
+12 QUIT
+1 ; quit if e-mail
if $DATA(RAUTOE)
QUIT
+2 IF RAFOOT
IF (IOST'["P-MESSAGE")
FOR I=0:0
if ($Y+RAFOOT+5)>IOSL
QUIT
WRITE !
+3 IF IOST["P-MESSAGE"
WRITE !!!!!
+4 IF RAFOOT
SET RAIOF=RAFFLF
SET RAFFLF="!"
SET RAFMT=RAFTFM
DO PRT^RAFLH
SET RAFFLF=RAIOF
+5 IF IOST'["P-MESSAGE"
FOR I=0:0
if ($Y+4)>IOSL
QUIT
WRITE !
+6 WRITE !,"VAF 10-9034 VICE SF 519B RADIOLOGY/NUCLEAR MEDICINE REPORT"
+7 QUIT
+8 ;
BANNER ;Report Batch Header/Trailer Page
+1 if '$DATA(RARTMES)!($DATA(RAUTOE))
QUIT
SET $PIECE(F1,">",((IOM-$LENGTH(RARTMES))/2))=""
SET $PIECE(F2,"<",((IOM-$LENGTH(RARTMES))/2))=""
USE IO
SET RAFFLF=$SELECT($DATA(RAFFLF):RAFFLF,1:"#")
WRITE @RAFFLF
+2 FOR I=1:1:10
WRITE !,F1," ",RARTMES," ",F2
+3 WRITE !!?((IOM-30)/2),"Printed at "
SET X="NOW"
SET %DT="TX"
DO ^%DT
DO D^RAUTL
WRITE Y
+4 FOR I=1:1
if ($Y+12)>IOSL
QUIT
WRITE !
+5 FOR I=1:1
if ($Y+2)>IOSL
QUIT
WRITE !,F1," ",RARTMES," ",F2
+6 KILL F1,F2
QUIT
HANG ; end-of-page prompt
+1 ; quit if e-mail
if $DATA(RAUTOE)
QUIT
+2 IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
if $DATA(DIRUT)
SET RAOOUT=1
WRITE @RAFFLF
+3 QUIT
SET ; Set up our TMP global for mailman
+1 NEW DIWF,DIWL,DIWR,RAX,X,RAPX
SET RAX=0
+2 SET DIWF=""
SET DIWL=5
SET DIWR=70
KILL ^UTILITY($JOB,"W")
+3 ; Get Additional Clinical History, Report Text and Impression text
+4 ; from file 74
+5 IF RAP="AH"!(RAP="R")!(RAP="I")
Begin DoDot:1
+6 SET RAPX=$SELECT(RAP="AH":"H",1:RAP)
+7 FOR
SET RAX=$ORDER(^RARPT(RARPT,RAPX,RAX))
if RAX'>0
QUIT
Begin DoDot:2
+8 SET X=$GET(^RARPT(RARPT,RAPX,RAX,0))
DO ^DIWP
End DoDot:2
+9 QUIT
End DoDot:1
+10 ; Get Clinical History from file 70
+11 IF RAP="H"
Begin DoDot:1
+12 FOR
SET RAX=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAX))
if RAX'>0
QUIT
Begin DoDot:2
+13 SET X=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAX,0))
DO ^DIWP
End DoDot:2
+14 QUIT
End DoDot:1
+15 SET RAX=0
FOR
SET RAX=$ORDER(^UTILITY($JOB,"W",DIWL,RAX))
if RAX'>0
QUIT
Begin DoDot:1
+16 SET X=$GET(^UTILITY($JOB,"W",DIWL,RAX,0))
+17 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_X
+18 QUIT
End DoDot:1
+19 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
+20 QUIT
AMENRPT() ; Pass the text, '*** THIS IS AN AMENDED REPORT ***'.
+1 QUIT "*** THIS IS AN AMENDED REPORT ***"
