RARTR ;HISC/CAH COLUMBIA/REB AISC/MJK,RMO-Queue/print Reports ; 06 Oct 2013 11:06 AM
;;5.0;Radiology/Nuclear Medicine;**5,13,16,27,43,55,75,92,99,1005**;Mar 16, 1998;Build 13
;Supported IA #2056 reference to GET1^DIQ
PRT ; Begin print/build of e-mail message
;
; ** NOTE: If the layout of this output is changed **
; ** please check that routine RAO7PC3 is **
; ** not affected. It assumes fixed format of **
; ** the following headings: **
; ** Clinical History: **
; ** Report: **
; ** Impression: **
; ** Primary Diagnostic Code: **
; ** Secondary Diagnostic Codes: **
; ** Primary Interpreting Staff: **
;
Q:'$D(^RARPT(+$G(RARPT),0))
; Use and Set if running in the foreground and Writing to the device
I '$D(RAUTOE) D
. U IO
. S RAFFLF=IOF
. S RAORIOF=RAFFLF
;
W:$Y>0&('$D(RAUTOE)) @RAFFLF ; If RAUTOE defined build mail msg
S X=$G(^RARPT(+$G(RARPT),0)) ; RAORIOF=RAFFLF
;
;S RAFFLF=$S('$D(ORACTION):RAFFLF,ORACTION'=8:RAFFLF,1:"!")
D INIT ; setup exam/report variables
;start p99
;
;IHS/BJI/DAY - Patch 1005 - Gender Fix
;I $$PTSEX^RAUTL8(RADFN)="F",'$D(RAUTOE) D
I $$PTSEX^RAUTL8(RADFN)'="M",'$D(RAUTOE) D
.;
.N RA700332,RA700380 S RA700332=$$GET1^DIQ(70.03,$G(RACNI)_","_$G(RADTI)_","_$G(RADFN),32)
.W:RA700332'="" !,"Pregnancy Screen: ",RA700332
.S RA700380=$$GET1^DIQ(70.03,$G(RACNI)_","_$G(RADTI)_","_$G(RADFN),80)
.I (RA700332'="Patient answered no"),(RA700380'="") S RA700380="Pregnancy Screen Comment: "_RA700380 D OUTTEXT^RAUTL9(RA700380,"",1,75,"","!","")
.W !
;end of p99
I RAY0<0!(RAY1<0)!(RAY2<0)!(RAY3<0) K RAFFLF Q ; data nodes missing
;
PRT1 I $D(RAUTOE) D
. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "
. I $D(RADDEN) D
.. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Report Unverified by: "_$P($G(^VA(200,$S($G(RADUZ):RADUZ,1:DUZ),0)),"^")
.. Q
. Q
I +$O(^RARPT(RARPT,"ERR",0)) D
. S RAERRFLG="" ; set for future reference (display AMENRPT^RARTR text)
. W:'$D(RAUTOE) !!?10,$$AMENRPT^RARTR2(),!
. I $D(RAUTOE) D
.. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "
.. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$$AMENRPT^RARTR2()
.. Q
. Q
I $P(RAY3,"^",25)<2 D G END:$D(RAOOUT)
. D MODS^RAUTL2,OUT1^RARTR3
. D:+$P(RAY3,"^",28) RDIO^RARTUTL(+$P(RAY3,"^",28)) Q:$D(RAOOUT)
. D:+$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0)) PHARM^RARTUTL(RACNI_","_RADTI_","_RADFN_",")
. ;W:'$D(RAUTOE) !
. S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
. Q
I $P(RAY3,"^",25)>1 D
. D MEMS1^RARTR3
. W:'$D(RAUTOE) !
. S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
. Q
G END:$D(RAOOUT)
; Check for duplicate history in file 70 and 74.
D CHKDUPHX^RART1 ; Sets RADUPHX to 1 for duplicate or 0 if different.
F RAP="H","AH","R","I" K ^UTILITY($J,"W"),^(1) D G END:$D(RAOOUT)
. S RAP("P")=$S(RAP="H":"Clinical History:",RAP="AH":"Additional Clinical History:",RAP="R":"Report:",1:"Impression:")
. ; Don't continue if printing Additional Clinical History and it is a
. ; duplicate of Clinical History.
. Q:RAP="AH"&(RADUPHX>0)
. W:'$D(RAUTOE) !?RATAB,RAP("P")
. I $D(RAUTOE),($D(RADDEN)),(RAP="R") D
.. N RABAN1,RABAN2,RASPCE S $P(RASPCE," ",46)=""
.. S RABAN1="*** Uncorrected Version ***"
.. S RABAN2="*** Refer to final report ***"
.. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
.. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPCE_RABAN1
.. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPCE_RABAN2
.. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
.. Q
. S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_RAP("P")
. W:$D(RASTFL)&(RAP="R")&('$D(RAUTOE)) ?45,"Status: ",$$XTERNAL^RAUTL5(RAST,$P($G(^DD(74,5,0)),"^",2))
. I RAP="R",($D(RAUTOE)) D
.. S $P(RAP("S")," ",(46-$L(^TMP($J,"RA AUTOE",RAACNT))))=""
.. I '$D(RADDEN) S ^TMP($J,"RA AUTOE",RAACNT)=^(RAACNT)_RAP("S")_"Status: "_$$XTERNAL^RAUTL5(RAST,$P($G(^DD(74,5,0)),"^",2))
.. Q
. D:$D(RAUTOE) SET^RARTR2
. D:'$D(RAUTOE) WRITE^RARTR2 Q:$D(RAOOUT)
. K ^UTILITY($J,"W")
. Q
I $D(RADDEN),($G(^RARPT(RARPT,"PURGE"))) D
. ; when the report is unverified and purge data exists (rpt adden)
. N RAPRGE S RAPRGE=+$G(^RARPT(RARPT,"PURGE"))
. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Report Purged: "_$$FMTE^XLFDT(RAPRGE,"1P")
. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
. Q
I $P($G(^RA(79.1,+$P(RAY2,U,4),0)),U,18)="Y" D PRTDX^RARTR1 G:$D(RAOOUT) END ;print dx codes
D EN1^RARTR0 G:$D(RAOOUT) END
I '$D(RAVERFND) D G END:$D(RAOOUT)
. I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT) D HD:($Y+RAFOOT+4)>IOSL
. N RADFTSBN,RADFTSBT S:$D(RADDEN) RAVERF=+$P(RA74B4,"^",9)
. S RADFTSBN=$E($P($G(^VA(200,RAVERF,20)),"^",2),1,25)
. S:RADFTSBN']"" RADFTSBN=$E($P($G(^VA(200,RAVERF,0)),"^"),1,25)
. S RADFTSBT=$E($P($G(^VA(200,RAVERF,20)),"^",3),1,30)
. I RADFTSBT']"" S RADFTSBT=$$TITLE^RARTR0(RAVERF)
. W:'$D(RAUTOE) !!,"VERIFIED BY:",!?2,$S(RADFTSBN]"":RADFTSBN,1:"")
. W:RADFTSBT]""&('$D(RAUTOE)) ", "_RADFTSBT
. I $D(RAUTOE) D
.. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="VERIFIED BY:"
.. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$S(RADFTSBN]"":RADFTSBN,1:"")_$S(RADFTSBT]"":", "_RADFTSBT,1:"")
.. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
.. Q
. Q
K RASBPN,RASBT,RASECIEN,RASECOND,RASECSS
I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 G END:$D(RAOOUT) D HD:($Y+RAFOOT+4)>IOSL
W:'$D(RAUTOE) !!,$S($D(^RABTCH(74.2,+RABTCH,0)):$P(^(0),"^"),1:""),"/" I +$G(^RARPT(RARPT,"T")),$D(^VA(200,+$P(^RARPT(RARPT,"T"),"^"),0)) W:'$D(RAUTOE) $P(^(0),"^",2)
S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$P($G(^RABTCH(74.2,+RABTCH,0)),"^")_"/"_$S(+$G(^RARPT(RARPT,"T"))&($D(^VA(200,+$P($G(^RARPT(RARPT,"T")),"^"),0))):$P(^(0),"^",2),1:"")
S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
D HANG^RARTR2 G END:$D(RAOOUT)
I RAST'="V" D:'$D(RAMDV) SETDIV^RARTR2 I $P(RAMDV,U,25) D WARNING^RARTR1
G PEND:RAST'="PD"
S $P(RASTRSK,"*",80)=""
I '$D(RAUTOE) D
. D HD:($Y+RAFOOT+9)>IOSL
. W !,$E(RASTRSK,1,22)," P R O B L E M S T A T E M E N T ",$E(RASTRSK,1,22)
. W !!,$S($D(^RARPT(RARPT,"P")):^("P"),1:"None entered.") W !!,RASTRSK
. Q
E D
. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$E(RASTRSK,1,22)_" P R O B L E M S T A T E M E N T "_$E(RASTRSK,1,22)
. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$S($D(^RARPT(RARPT,"P")):^("P"),1:"None entered.")
. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
. Q
PEND D FOOT^RARTR2,HANG^RARTR2 D:'$D(RAMIE)&('$D(RAUTOE)) Q^RAFLH1
END K:$D(RAOOUT) XQAID,XQAKILL
K %I,%W,%Y1,C,DN,I,RADXCODE,RARTMES,RAVERF,RAVERFND,RAPVERF
K RAVERS,RAFOOT,RAY0,RAY1,RAY2,RAY3,RALOC,RAFMT,RAMOD,RASTFL,RALB,RALBR
K RALBRT,RALBS,RALBST,RAV,RAP,RATAB,RAXX,VAL,VAR,RADFN,RADTI,RACN,RADTE
K RARPT,RAHDFM,RAFTFM,RAV,RAIOF,RABTCH,RAOOUT,RAPIR,RAPIS,VAERR,Z
; K RASTRSK S RAFFLF=RAORIOF K RAORIOF,RAFFLF,RAERRFLG
; 05/15/08 BAY/KAM Patch RA*5*92 Added Conditional Kill to next line
; to support an AMIE interface (IA 708)
K RASTRSK,RAORIOF,RAFFLF,RAERRFLG K:'($D(RAMIE)#2) DFN
;the next kill line corrects the CPRS V27 report display issue when repeated
;on same patient P92
K %,DIW,DIWF,DIWI,DIWL,DIWT,DIWTC,DIWX,RAACNT,RADUPHX,RANUM,RAREZON,RAST
Q
Q ; Queue the report
S ZTDTH=$H,ZTRTN="DQ^RARTR",ZTSAVE("RARPT")="" S:$D(RARTMES) ZTSAVE("RARTMES")=""
D ZIS^RAUTL Q:RAPOP
;
DQ S U="^",X="T",%DT="" D ^%DT K %DT S DT=Y G PRT
;
INIT ; initialize exam/report variables
; main variables set:
; RAY0: zero node data from the Patient File (2)
; RAY1: zero node data from the Rad/Nuc Med Patient File (70)
; RAY2: Registered Exams (70.02) zero node data
; RAY3: Examinations (70.03) zero node data
S (RAY0,RAY1,RAY2,RAY3)=-1 ; error condition, if no data nodes
S RADFN=+$P(X,"^",2),RADTE=+$P(X,"^",3),RADTI=(9999999.9999-RADTE)
S RACN=+$P(X,"^",4),RAST=$P(X,"^",5),RATAB=5
S:'$D(RABTCH) RABTCH=0 S (DIWL,DIWF)=0
Q:'$D(^RADPT(RADFN,0)) S RANUM=1,RAY1=^(0)
Q:'$D(^DPT(RADFN,0)) S RAY0=^(0)
Q:'$D(^RADPT(RADFN,"DT",RADTI,0)) S RAY2=^(0)
S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0))
S (RAY3,RALB)=$S($D(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,0)):^(0),1:-1)
Q:RAY3<0 ; examinations data missing
;
S (RAHDFM,RAFTFM)=1 S:$D(^RA(79.1,+$P(RAY2,"^",4),0)) RAHDFM=^(0),RAFTFM=+$P(RAHDFM,"^",13),DIWL=$P(RAHDFM,"^",14),DIWF=$P(RAHDFM,"^",15),RAHDFM=+$P(RAHDFM,"^",12) S RAFOOT=$S($D(^RA(78.2,RAFTFM,0)):+$P(^(0),"^",2),1:0)
S:'DIWL DIWL=5 S:'DIWF DIWF=70 S DIWF="WC"_(DIWF-DIWL)
G @$S($D(RAUTOE):"HEAD^RARTR0",1:"HD1")
Q
;
HD D FOOT^RARTR2:$E(IOST,1,2)'="C-"
HD1 S RAFMT=RAHDFM I $D(RARTMES) W:$Y>0 @RAFFLF W !,?((80-$L(RARTMES))/2),RARTMES,! S RAIOF=RAFFLF,RAFFLF="!"
I '$D(RARTMES) W:$Y>0 @RAFFLF
D PRT^RAFLH S:$D(RARTMES) RAFFLF=RAIOF
W:$D(RAERRFLG) !!?10,$$AMENRPT^RARTR2(),!!
Q
RARTR ;HISC/CAH COLUMBIA/REB AISC/MJK,RMO-Queue/print Reports ; 06 Oct 2013 11:06 AM
+1 ;;5.0;Radiology/Nuclear Medicine;**5,13,16,27,43,55,75,92,99,1005**;Mar 16, 1998;Build 13
+2 ;Supported IA #2056 reference to GET1^DIQ
PRT ; Begin print/build of e-mail message
+1 ;
+2 ; ** NOTE: If the layout of this output is changed **
+3 ; ** please check that routine RAO7PC3 is **
+4 ; ** not affected. It assumes fixed format of **
+5 ; ** the following headings: **
+6 ; ** Clinical History: **
+7 ; ** Report: **
+8 ; ** Impression: **
+9 ; ** Primary Diagnostic Code: **
+10 ; ** Secondary Diagnostic Codes: **
+11 ; ** Primary Interpreting Staff: **
+12 ;
+13 IF '$DATA(^RARPT(+$GET(RARPT),0))
QUIT
+14 ; Use and Set if running in the foreground and Writing to the device
+15 IF '$DATA(RAUTOE)
Begin DoDot:1
+16 USE IO
+17 SET RAFFLF=IOF
+18 SET RAORIOF=RAFFLF
End DoDot:1
+19 ;
+20 ; If RAUTOE defined build mail msg
IF $Y>0&('$DATA(RAUTOE))
WRITE @RAFFLF
+21 ; RAORIOF=RAFFLF
SET X=$GET(^RARPT(+$GET(RARPT),0))
+22 ;
+23 ;S RAFFLF=$S('$D(ORACTION):RAFFLF,ORACTION'=8:RAFFLF,1:"!")
+24 ; setup exam/report variables
DO INIT
+25 ;start p99
+26 ;
+27 ;IHS/BJI/DAY - Patch 1005 - Gender Fix
+28 ;I $$PTSEX^RAUTL8(RADFN)="F",'$D(RAUTOE) D
+29 IF $$PTSEX^RAUTL8(RADFN)'="M"
IF '$DATA(RAUTOE)
Begin DoDot:1
+30 ;
+31 NEW RA700332,RA700380
SET RA700332=$$GET1^DIQ(70.03,$GET(RACNI)_","_$GET(RADTI)_","_$GET(RADFN),32)
+32 IF RA700332'=""
WRITE !,"Pregnancy Screen: ",RA700332
+33 SET RA700380=$$GET1^DIQ(70.03,$GET(RACNI)_","_$GET(RADTI)_","_$GET(RADFN),80)
+34 IF (RA700332'="Patient answered no")
IF (RA700380'="")
SET RA700380="Pregnancy Screen Comment: "_RA700380
DO OUTTEXT^RAUTL9(RA700380,"",1,75,"","!","")
+35 WRITE !
End DoDot:1
+36 ;end of p99
+37 ; data nodes missing
IF RAY0<0!(RAY1<0)!(RAY2<0)!(RAY3<0)
KILL RAFFLF
QUIT
+38 ;
PRT1 IF $DATA(RAUTOE)
Begin DoDot:1
+1 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "
+2 IF $DATA(RADDEN)
Begin DoDot:2
+3 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Report Unverified by: "_$PIECE($GET(^VA(200,$SELECT($GET(RADUZ):RADUZ,1:DUZ),0)),"^")
+4 QUIT
End DoDot:2
+5 QUIT
End DoDot:1
+6 IF +$ORDER(^RARPT(RARPT,"ERR",0))
Begin DoDot:1
+7 ; set for future reference (display AMENRPT^RARTR text)
SET RAERRFLG=""
+8 IF '$DATA(RAUTOE)
WRITE !!?10,$$AMENRPT^RARTR2(),!
+9 IF $DATA(RAUTOE)
Begin DoDot:2
+10 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "
+11 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$$AMENRPT^RARTR2()
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 IF $PIECE(RAY3,"^",25)<2
Begin DoDot:1
+15 DO MODS^RAUTL2
DO OUT1^RARTR3
+16 IF +$PIECE(RAY3,"^",28)
DO RDIO^RARTUTL(+$PIECE(RAY3,"^",28))
IF $DATA(RAOOUT)
QUIT
+17 IF +$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0))
DO PHARM^RARTUTL(RACNI_","_RADTI_","_RADFN_",")
+18 ;W:'$D(RAUTOE) !
+19 IF $DATA(RAUTOE)
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
+20 QUIT
End DoDot:1
IF $DATA(RAOOUT)
GOTO END
+21 IF $PIECE(RAY3,"^",25)>1
Begin DoDot:1
+22 DO MEMS1^RARTR3
+23 IF '$DATA(RAUTOE)
WRITE !
+24 IF $DATA(RAUTOE)
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
+25 QUIT
End DoDot:1
+26 IF $DATA(RAOOUT)
GOTO END
+27 ; Check for duplicate history in file 70 and 74.
+28 ; Sets RADUPHX to 1 for duplicate or 0 if different.
DO CHKDUPHX^RART1
+29 FOR RAP="H","AH","R","I"
KILL ^UTILITY($JOB,"W"),^(1)
Begin DoDot:1
+30 SET RAP("P")=$SELECT(RAP="H":"Clinical History:",RAP="AH":"Additional Clinical History:",RAP="R":"Report:",1:"Impression:")
+31 ; Don't continue if printing Additional Clinical History and it is a
+32 ; duplicate of Clinical History.
+33 IF RAP="AH"&(RADUPHX>0)
QUIT
+34 IF '$DATA(RAUTOE)
WRITE !?RATAB,RAP("P")
+35 IF $DATA(RAUTOE)
IF ($DATA(RADDEN))
IF (RAP="R")
Begin DoDot:2
+36 NEW RABAN1,RABAN2,RASPCE
SET $PIECE(RASPCE," ",46)=""
+37 SET RABAN1="*** Uncorrected Version ***"
+38 SET RABAN2="*** Refer to final report ***"
+39 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
+40 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPCE_RABAN1
+41 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPCE_RABAN2
+42 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
+43 QUIT
End DoDot:2
+44 IF $DATA(RAUTOE)
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_RAP("P")
+45 IF $DATA(RASTFL)&(RAP="R")&('$DATA(RAUTOE))
WRITE ?45,"Status: ",$$XTERNAL^RAUTL5(RAST,$PIECE($GET(^DD(74,5,0)),"^",2))
+46 IF RAP="R"
IF ($DATA(RAUTOE))
Begin DoDot:2
+47 SET $PIECE(RAP("S")," ",(46-$LENGTH(^TMP($JOB,"RA AUTOE",RAACNT))))=""
+48 IF '$DATA(RADDEN)
SET ^TMP($JOB,"RA AUTOE",RAACNT)=^(RAACNT)_RAP("S")_"Status: "_$$XTERNAL^RAUTL5(RAST,$PIECE($GET(^DD(74,5,0)),"^",2))
+49 QUIT
End DoDot:2
+50 IF $DATA(RAUTOE)
DO SET^RARTR2
+51 IF '$DATA(RAUTOE)
DO WRITE^RARTR2
IF $DATA(RAOOUT)
QUIT
+52 KILL ^UTILITY($JOB,"W")
+53 QUIT
End DoDot:1
IF $DATA(RAOOUT)
GOTO END
+54 IF $DATA(RADDEN)
IF ($GET(^RARPT(RARPT,"PURGE")))
Begin DoDot:1
+55 ; when the report is unverified and purge data exists (rpt adden)
+56 NEW RAPRGE
SET RAPRGE=+$GET(^RARPT(RARPT,"PURGE"))
+57 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
+58 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Report Purged: "_$$FMTE^XLFDT(RAPRGE,"1P")
+59 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
+60 QUIT
End DoDot:1
+61 ;print dx codes
IF $PIECE($GET(^RA(79.1,+$PIECE(RAY2,U,4),0)),U,18)="Y"
DO PRTDX^RARTR1
IF $DATA(RAOOUT)
GOTO END
+62 DO EN1^RARTR0
IF $DATA(RAOOUT)
GOTO END
+63 IF '$DATA(RAVERFND)
Begin DoDot:1
+64 IF '$DATA(RAUTOE)
IF ($Y+RAFOOT+4)>IOSL
DO HANG^RARTR2
IF $DATA(RAOOUT)
QUIT
IF ($Y+RAFOOT+4)>IOSL
DO HD
+65 NEW RADFTSBN,RADFTSBT
IF $DATA(RADDEN)
SET RAVERF=+$PIECE(RA74B4,"^",9)
+66 SET RADFTSBN=$EXTRACT($PIECE($GET(^VA(200,RAVERF,20)),"^",2),1,25)
+67 IF RADFTSBN']""
SET RADFTSBN=$EXTRACT($PIECE($GET(^VA(200,RAVERF,0)),"^"),1,25)
+68 SET RADFTSBT=$EXTRACT($PIECE($GET(^VA(200,RAVERF,20)),"^",3),1,30)
+69 IF RADFTSBT']""
SET RADFTSBT=$$TITLE^RARTR0(RAVERF)
+70 IF '$DATA(RAUTOE)
WRITE !!,"VERIFIED BY:",!?2,$SELECT(RADFTSBN]"":RADFTSBN,1:"")
+71 IF RADFTSBT]""&('$DATA(RAUTOE))
WRITE ", "_RADFTSBT
+72 IF $DATA(RAUTOE)
Begin DoDot:2
+73 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="VERIFIED BY:"
+74 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$SELECT(RADFTSBN]"":RADFTSBN,1:"")_$SELECT(RADFTSBT]"":", "_RADFTSBT,1:"")
+75 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
+76 QUIT
End DoDot:2
+77 QUIT
End DoDot:1
IF $DATA(RAOOUT)
GOTO END
+78 KILL RASBPN,RASBT,RASECIEN,RASECOND,RASECSS
+79 IF '$DATA(RAUTOE)
IF ($Y+RAFOOT+4)>IOSL
DO HANG^RARTR2
IF $DATA(RAOOUT)
GOTO END
IF ($Y+RAFOOT+4)>IOSL
DO HD
+80 IF '$DATA(RAUTOE)
WRITE !!,$SELECT($DATA(^RABTCH(74.2,+RABTCH,0)):$PIECE(^(0),"^"),1:""),"/"
IF +$GET(^RARPT(RARPT,"T"))
IF $DATA(^VA(200,+$PIECE(^RARPT(RARPT,"T"),"^"),0))
IF '$DATA(RAUTOE)
WRITE $PIECE(^(0),"^",2)
+81 IF $DATA(RAUTOE)
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$PIECE($GET(^RABTCH(74.2,+RABTCH,0)),"^")_"/"_$SELECT(+$GET(^RARPT(RARPT,"T"))&($DATA(^VA(200,+$PIECE($GET(^RARPT(RARPT,"T")),"^"),0))):$PIECE(^(0),"^",2),1:"")
+82 IF $DATA(RAUTOE)
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
+83 DO HANG^RARTR2
IF $DATA(RAOOUT)
GOTO END
+84 IF RAST'="V"
IF '$DATA(RAMDV)
DO SETDIV^RARTR2
IF $PIECE(RAMDV,U,25)
DO WARNING^RARTR1
+85 IF RAST'="PD"
GOTO PEND
+86 SET $PIECE(RASTRSK,"*",80)=""
+87 IF '$DATA(RAUTOE)
Begin DoDot:1
+88 IF ($Y+RAFOOT+9)>IOSL
DO HD
+89 WRITE !,$EXTRACT(RASTRSK,1,22)," P R O B L E M S T A T E M E N T ",$EXTRACT(RASTRSK,1,22)
+90 WRITE !!,$SELECT($DATA(^RARPT(RARPT,"P")):^("P"),1:"None entered.")
WRITE !!,RASTRSK
+91 QUIT
End DoDot:1
+92 IF '$TEST
Begin DoDot:1
+93 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$EXTRACT(RASTRSK,1,22)_" P R O B L E M S T A T E M E N T "_$EXTRACT(RASTRSK,1,22)
+94 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$SELECT($DATA(^RARPT(RARPT,"P")):^("P"),1:"None entered.")
+95 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
+96 QUIT
End DoDot:1
PEND DO FOOT^RARTR2
DO HANG^RARTR2
IF '$DATA(RAMIE)&('$DATA(RAUTOE))
DO Q^RAFLH1
END IF $DATA(RAOOUT)
KILL XQAID,XQAKILL
+1 KILL %I,%W,%Y1,C,DN,I,RADXCODE,RARTMES,RAVERF,RAVERFND,RAPVERF
+2 KILL RAVERS,RAFOOT,RAY0,RAY1,RAY2,RAY3,RALOC,RAFMT,RAMOD,RASTFL,RALB,RALBR
+3 KILL RALBRT,RALBS,RALBST,RAV,RAP,RATAB,RAXX,VAL,VAR,RADFN,RADTI,RACN,RADTE
+4 KILL RARPT,RAHDFM,RAFTFM,RAV,RAIOF,RABTCH,RAOOUT,RAPIR,RAPIS,VAERR,Z
+5 ; K RASTRSK S RAFFLF=RAORIOF K RAORIOF,RAFFLF,RAERRFLG
+6 ; 05/15/08 BAY/KAM Patch RA*5*92 Added Conditional Kill to next line
+7 ; to support an AMIE interface (IA 708)
+8 KILL RASTRSK,RAORIOF,RAFFLF,RAERRFLG
IF '($DATA(RAMIE)#2)
KILL DFN
+9 ;the next kill line corrects the CPRS V27 report display issue when repeated
+10 ;on same patient P92
+11 KILL %,DIW,DIWF,DIWI,DIWL,DIWT,DIWTC,DIWX,RAACNT,RADUPHX,RANUM,RAREZON,RAST
+12 QUIT
Q ; Queue the report
+1 SET ZTDTH=$HOROLOG
SET ZTRTN="DQ^RARTR"
SET ZTSAVE("RARPT")=""
IF $DATA(RARTMES)
SET ZTSAVE("RARTMES")=""
+2 DO ZIS^RAUTL
IF RAPOP
QUIT
+3 ;
DQ SET U="^"
SET X="T"
SET %DT=""
DO ^%DT
KILL %DT
SET DT=Y
GOTO PRT
+1 ;
INIT ; initialize exam/report variables
+1 ; main variables set:
+2 ; RAY0: zero node data from the Patient File (2)
+3 ; RAY1: zero node data from the Rad/Nuc Med Patient File (70)
+4 ; RAY2: Registered Exams (70.02) zero node data
+5 ; RAY3: Examinations (70.03) zero node data
+6 ; error condition, if no data nodes
SET (RAY0,RAY1,RAY2,RAY3)=-1
+7 SET RADFN=+$PIECE(X,"^",2)
SET RADTE=+$PIECE(X,"^",3)
SET RADTI=(9999999.9999-RADTE)
+8 SET RACN=+$PIECE(X,"^",4)
SET RAST=$PIECE(X,"^",5)
SET RATAB=5
+9 IF '$DATA(RABTCH)
SET RABTCH=0
SET (DIWL,DIWF)=0
+10 IF '$DATA(^RADPT(RADFN,0))
QUIT
SET RANUM=1
SET RAY1=^(0)
+11 IF '$DATA(^DPT(RADFN,0))
QUIT
SET RAY0=^(0)
+12 IF '$DATA(^RADPT(RADFN,"DT",RADTI,0))
QUIT
SET RAY2=^(0)
+13 SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0))
+14 SET (RAY3,RALB)=$SELECT($DATA(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,0)):^(0),1:-1)
+15 ; examinations data missing
IF RAY3<0
QUIT
+16 ;
+17 SET (RAHDFM,RAFTFM)=1
IF $DATA(^RA(79.1,+$PIECE(RAY2,"^",4),0))
SET RAHDFM=^(0)
SET RAFTFM=+$PIECE(RAHDFM,"^",13)
SET DIWL=$PIECE(RAHDFM,"^",14)
SET DIWF=$PIECE(RAHDFM,"^",15)
SET RAHDFM=+$PIECE(RAHDFM,"^",12)
SET RAFOOT=$SELECT($DATA(^RA(78.2,RAFTFM,0)):+$PIECE(^(0),"^",2),1:0)
+18 IF 'DIWL
SET DIWL=5
IF 'DIWF
SET DIWF=70
SET DIWF="WC"_(DIWF-DIWL)
+19 GOTO @$SELECT($DATA(RAUTOE):"HEAD^RARTR0",1:"HD1")
+20 QUIT
+21 ;
HD IF $EXTRACT(IOST,1,2)'="C-"
DO FOOT^RARTR2
HD1 SET RAFMT=RAHDFM
IF $DATA(RARTMES)
IF $Y>0
WRITE @RAFFLF
WRITE !,?((80-$LENGTH(RARTMES))/2),RARTMES,!
SET RAIOF=RAFFLF
SET RAFFLF="!"
+1 IF '$DATA(RARTMES)
IF $Y>0
WRITE @RAFFLF
+2 DO PRT^RAFLH
IF $DATA(RARTMES)
SET RAFFLF=RAIOF
+3 IF $DATA(RAERRFLG)
WRITE !!?10,$$AMENRPT^RARTR2(),!!
+4 QUIT
