RART1 ;HISC/GJC,SWM-Reporting Menu (Part 2) ; Aug 25, 2020@14:04
;;5.0;Radiology/Nuclear Medicine;**8,16,15,21,23,27,34,99,47,173**;Mar 16, 1998;Build 1
;Print Report By Patient has been moved to 4^RART2!
;these sections are moved to ^RART3 : QRPT, PHYS, MODSET, OUT1
;RVD P99, add pregnancy screen and commment if populated for female pt.
CHK I 'RARPT!('$D(^RARPT(+RARPT,0))) W !?3,$C(7),"No report filed for case number ",RACN,"." K RARPT Q
I $D(RADFT),$P(^RARPT(+RARPT,0),"^",5)'["D" W !?3,$C(7),"Report for case number ",RACN," is not in a 'draft' status." K RARPT Q
I '$D(RADFT),$P(^RARPT(+RARPT,0),"^",5)["D" W !?3,$C(7),"Report filed for case number ",RACN," but not available for printing." K RARPT Q
Q
;
5 ;;Draft Report (Reprint)
D SETVARS Q:'($D(RACCESS(DUZ))\10)!('$D(RAIMGTY)) S RADFT="" G 4^RART2
;
6 ;;Display a Report By Patient
W ! S DIC(0)="AEMQ" D ^RADPA G Q6:Y<0 S RADFN=+Y,RAHEAD="**** Patient's Exams ****",RAF1=1,RAREPORT=1 D ^RAPTLU G Q6:X="^" G 6:'$D(RADUP)
I X=1 R X:3
OERR ;entry from RA OERR PROFILE protocol
F RAI=0:0 S RAI=$O(RADUP(RAI)) Q:RAI'>0 S Y=^TMP($J,"RAEX",RAI) D 61,DISP Q:X="^"
K RADUP,RAI,RAJ,X,^TMP($J,"RAEX") Q:$D(ORVP) G 6
61 F RAJ=1:1:11 S @$P("RADFN^RADTI^RACNI^RANME^RASSN^RADATE^RADTE^RACN^RAPRC^RARPT^RAST","^",RAJ)=$P(Y,"^",RAJ)
S Y(0)=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0) Q
;
OERR1 ;Entry Point for Alert Follow-Up Action for OE/RR
Q:'$D(XQADATA)!('$D(XQAID)) S (RARPT,Y)=XQADATA D RASET^RAUTL2
S:Y Y(0)=Y,RANME=$S($D(^DPT(RADFN,0)):$P(^(0),"^"),1:"Unknown"),RAPRC=$S($D(^RAMIS(71,+$P(Y(0),"^",2),0)):$P(^(0),"^"),1:"Unknown")
S RALERTS="" D DISP K:X="^" XQAID,XQAKILL
I $D(XQAID) S DFN=$P(XQAID,",",2) D DELETE^XQALERT
K RALERTS
Q
;
DISP I RARPT,($D(RAPBRPT)),($P($G(^RARPT(+RARPT,0)),"^",5)="V") D Q
. ; This code will not allow a user to re-edit a verified report.
. ; In this case, two or more possible users signed on to the same
. ; Imaging location, asked to verify the reports of the same
. ; Interpreting Radiology/Nuclear Medicine Physician.
. ; For the 'On-line Verifying of Reports' option only!
. N DIR,DIROUT,DIRUT,DTOUT,DUOUT,Y
. ; removed X from N so rtn RARTVER would quit if caret entered
. W !!?10,"Since the time you selected this group of reports,",!?10,$P($G(^VA(200,+$P(^RARPT(+RARPT,0),"^",9),0)),U)," has verified the report for "
. W !?10,$P($G(^DPT(+$P(^RARPT(+RARPT,0),"^",2),0)),U)," case #",$P(^RARPT(+RARPT,0),"^"),".",$C(7)
. S Y=$S($D(^TMP($J,"RA","DT",+$G(RARTDT),+$G(RARPT))):$P($P(^(RARPT),"/",2),U,3),$D(RARPTX(+$G(RPTX))):$P($P(RARPTX(+$G(RPTX)),"/",2),U,3),1:"")
. I $D(^RAMIS(71,+Y,0)) W !?10,"Procedure ",$P(^(0),U)
. W ! K DIR S DIR(0)="E" D ^DIR S RAVFIED=1
. Q
D HOME^%ZIS S OREND=1
I 'RARPT!('$D(^RARPT(+RARPT,0))) D G Q6
. W !?3,$C(7),"No report filed for case number",$S($D(RACN):" "_RACN,1:""),"."
. R X:3 ; D:$$IMAGE^RARIC1 DISPF^MAGRIC ;don't call MAG 111300
. Q
S RAST=$P(^RARPT(+RARPT,0),"^",5)
I '$D(RARTVER),(RAST=""!(RAST["D")) D G Q6
. W !?3,$C(7),"Report filed for case number ",RACN," but not available for display."
. R X:3 ; D:$$IMAGE^RARIC1 DISPF^MAGRIC ;don't call MAG 111300
. Q
DISP1 I $S('$D(ORACTION):1,ORACTION'=8:1,'$D(X):0,X="T":1,1:0) W @IOF
W !,RANME," (",$$SSN^RAUTL,")",?39,"Case No. ",?55,": ",$P($G(^RARPT(RARPT,0)),"^")," @",$E(RADATE,$L(RADATE)-4,$L(RADATE))
W !,$E(RAPRC,1,40) I +$G(^RARPT(RARPT,"T")) W ?39,"Transcriptionist",?55,": ",$E($P($G(^VA(200,+^RARPT(RARPT,"T"),0)),"^"),1,20)
N R3 S R3=$G(^RADPT(+$G(RADFN),"DT",+$G(RADTI),"P",+$G(RACNI),0))
W !,"Req. Phys : ",$E($P($G(^VA(200,+$P(R3,"^",14),0)),"^"),1,25)
S RAPREVER=+$P($G(^RARPT(RARPT,0)),"^",13) W ?39,"Pre-verified",?55,": ",$S($D(^VA(200,RAPREVER,0)):$E($P($G(^VA(200,RAPREVER,0)),"^"),1,24),1:"NO") K RAPREVER
D PHYS^RART3
;Display Pregnancy Screen and Comments if respective field is filled and pt is female, patch #99
I $$PTSEX^RAUTL8(RADFN)="F" D
.W:$P(R3,U,32)'="" !,"Pregnancy Screen: ",$S($P(R3,"^",32)="y":"Patient answered yes",$P(R3,"^",32)="n":"Patient answered no",$P(R3,"^",32)="u":"Patient is unable to answer or is unsure",1:"")
.N RAPCOMM S RAPCOMM=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCOMM"))
.W:$P(R3,U,32)'=""&$L(RAPCOMM) !,"Pregnancy Screen Comment: ",RAPCOMM
I $D(RAPBRPT),(RAST="PD") D
. W !,"**Prob Text: "
. I $G(^RARPT(+RARPT,"P"))]"" D
.. S X=$G(^RARPT(+RARPT,"P"))
.. D OUTTEXT^RAUTL9(X,"",10,70,13,"","!")
.. Q
. Q
W !,$$REPEAT^XLFSTR("=",79)
I $O(^RARPT(RARPT,1,0)) D MODSET^RART3
I '$O(^RARPT(RARPT,1,0)) D
. D MODS^RAUTL2,OUT1^RART3
. I +$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",28) S X=$$RDIO1^RARTUTL1(+$P(^(0),"^",28))
. Q:$L($G(X)) ; 'X' should be 'null' to continue
. S:+$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0)) X=$$PHARM1^RARTUTL(RACNI_","_RADTI_","_RADFN_",")
. Q
Q:$G(X)="P" G DISP1:$G(X)="T",Q6:$G(X)="^"
I +$O(^RARPT(RARPT,"ERR",0)) W !?10,$$AMENRPT^RARTR2(),!
;
; Print the clinical history from file 70
I +$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",0)) D
. K ^UTILITY($J,"W"),^(1) S X="",DIWL=3,DIWF="|WC75"
. W !?3,"Clinical History:"
. S RAP="H" D WRITEHX(RAP)
. Q
Q:$G(X)="P" G DISP1:$G(X)="T",Q6:$G(X)="^"
;
; Print the additional report clinical history if defined and
; different than the order clinical history.
I +$O(^RARPT(RARPT,"H",0)) D
. D CHKDUPHX Q:RADUPHX ; Duplicate history
. K ^UTILITY($J,"W"),^(1) S X="",DIWL=3,DIWF="|WC75"
. W !?3,"Additional Clinical History:"
. S RAP="AH" D WRITEHX(RAP)
;
; Print Report and Impression text
F RAP="R","I" D Q:X="^"!(X="P")!(X="T")
. K ^UTILITY($J,"W"),^(1) S X="",DIWL=3,DIWF="|WC75"
. W !?3,$S(RAP="R":"Report:",1:"Impression:") W:RAP="R" ?45,"Status: ",$$XTERNAL^RAUTL5(RAST,$P($G(^DD(74,5,0)),U,2))
. W:RAP="R"&($E(RAST)="P") $C(7)
. D WRITE
. Q
Q:X="P" G DISP1:X="T",Q6:X="^"
; I $$IMAGE^RARIC1() D DISPF^MAGRIC ;don't call MAG 111300
I $P($G(^RA(79.1,+$P(^RADPT(RADFN,"DT",RADTI,0),U,4),0)),U,18)="Y" D PRTDX^RART K RADXCODE
Q:X="P" G DISP1:X="T",Q6:X="^"
;
I $D(ORVP) D
.S RAVERF=+$P($G(^RARPT(+RARPT,0)),"^",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)
.S:RADFTSBT']"" RADFTSBT=$$TITLE^RARTR0(RAVERF)
.W !!,"VERIFIED BY:",!?2,$S(RADFTSBN]"":RADFTSBN,1:"")
.W:RADFTSBT]"" ", "_RADFTSBT
Q:X="P" G DISP1:X="T",Q6:X="^"
;
K RAP I '$D(RARTVER) D WAIT Q:X="P" G DISP1:X="T"
Q6 K %,DIC,DIWF,DIWL,DIWR,I,J,OREND,POP,RABTCH,RAF1,RAHEAD,RALOC,RANME,RAPAR,RAPRC,RAREPORT,RASEL,RASSN,RAST,RAV,RAXX,Y,X1,Z
K RAVERF,RADFTSBN,RADFTSBT
K DIW,DIWT,DN
K C,DIPGM,DISYS,R1,RAIMGTYI,RAP
K:'$D(RARTVER) RACN,RACNI,RADATE,RADFN,RADTE,RADTI,RARPT Q
;
WRITE K RAXX N Y
F RAV=0:0 S RAV=$O(^RARPT(RARPT,RAP,RAV)) Q:RAV'>0 D Q:X="^"!(X="P")!(X="T")
. S RAXX=^RARPT(RARPT,RAP,RAV,0) S X=""
. D WAIT:($Y+6)>IOSL&('$D(RARTVERF)) Q:X="^"!(X="P")!(X="T")
. S X=RAXX D ^DIWP S X=""
. Q
Q:X="^" D ^DIWW:$D(RAXX) Q
;
WRITEHX(RAP) ; Get and write the clinical history
;
;Input: RAP H = Clinical History from file 70
; AH = Additional Clinical History from file 74
;
K RAXX N Y
S RAV=0
I RAP="H" D
. F S RAV=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAV)) Q:RAV'>0 D Q:X="^"!(X="P")!(X="T")
. . S RAXX=^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAV,0),X=""
. . D WAIT:($Y+6)>IOSL&('$D(RARTVERF)) Q:X="^"!(X="P")!(X="T")
. . S X=RAXX D ^DIWP S X=""
. . Q
I RAP="AH" D
. F S RAV=$O(^RARPT(RARPT,"H",RAV)) Q:RAV'>0 D Q:X="^"!(X="P")!(X="T")
. . S RAXX=^RARPT(RARPT,"H",RAV,0),X=""
. . D WAIT:($Y+6)>IOSL&('$D(RARTVERF)) Q:X="^"!(X="P")!(X="T")
. . S X=RAXX D ^DIWP S X=""
. . Q
Q:X="^" D ^DIWW:$D(RAXX) Q
;
CHKDUPHX ; Check Duplicate History in file 70 and 74.
; Returns RADUPHX 1 = Duplicate
; 0 = Different
N RAX,RA74,RA70,RAOK,RAX1
; Initialize to Different
S RADUPHX=0
; Quit if H node does not exist. Could have been purged.
I '$D(^RARPT(RARPT,"H")) S RADUPHX=1 Q
;p173/KLM Quit if no CH on exam, flag set to take CH from report.
I '$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H")) S RADUPHX=0 Q
S RA74=$O(^RARPT(RARPT,"H",""),-1)
S RA70=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",""),-1),RA701=$O(^(0))
S RAX=RA74-RA70+1 Q:RAX'=1 ; begin comparison
; Check line by line of each file
; RAOK 1 = all lines match
; 0 = at least 1 difference
S RAOK=1
F RAX1=RA701:1:RA70 I ^RARPT(RARPT,"H",RAX1,0)'=^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAX1,0) S RAOK=0 Q ;can exit loop on 1st difference
I 'RAOK Q
S RADUPHX=1
Q
;
WAIT ; user input, goto top, print, or continue
S RARD(1)="Continue^continue normal processing"
S:$D(RALERTS) RARD(2)="Print^print the entire report"
S RARD(3)="Top^display the report from the beginning"
S (RARD("B"),RARD("DTOUT"))=1
S:$D(RALERTS) RARD("A")="Enter 'Top', 'Print' or 'Continue': "
S:'$D(RALERTS) RARD("A")="Enter 'Top' or 'Continue': "
S RARD(0)="S" D SET^RARD K RARD S X=$E(X)
I $D(RALERTS),(X="P") D QRPT^RART3
Q:X="^"!(X="P") W:X="C"&($D(RAP)) @IOF
Q
;
LOCK(X,Y) ; Lock an entry
W !!,$C(7),"Another user is editing this ",$S(X="R":"report (Case # "_Y_")",1:"exam (diagnostic code)"),". Please try again later." H 4 Q
;
SETVARS ; Setup Rad/Nuc Med required variables
I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0)
Q:'($D(RACCESS(DUZ))\10)
I $G(RAIMGTY)="" D SETVARS^RAPSET1(1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRART1 9578 printed Apr 09, 2024@21:36:32 Page 2
RART1 ;HISC/GJC,SWM-Reporting Menu (Part 2) ; Aug 25, 2020@14:04
+1 ;;5.0;Radiology/Nuclear Medicine;**8,16,15,21,23,27,34,99,47,173**;Mar 16, 1998;Build 1
+2 ;Print Report By Patient has been moved to 4^RART2!
+3 ;these sections are moved to ^RART3 : QRPT, PHYS, MODSET, OUT1
+4 ;RVD P99, add pregnancy screen and commment if populated for female pt.
CHK IF 'RARPT!('$DATA(^RARPT(+RARPT,0)))
WRITE !?3,$CHAR(7),"No report filed for case number ",RACN,"."
KILL RARPT
QUIT
+1 IF $DATA(RADFT)
IF $PIECE(^RARPT(+RARPT,0),"^",5)'["D"
WRITE !?3,$CHAR(7),"Report for case number ",RACN," is not in a 'draft' status."
KILL RARPT
QUIT
+2 IF '$DATA(RADFT)
IF $PIECE(^RARPT(+RARPT,0),"^",5)["D"
WRITE !?3,$CHAR(7),"Report filed for case number ",RACN," but not available for printing."
KILL RARPT
QUIT
+3 QUIT
+4 ;
5 ;;Draft Report (Reprint)
+1 DO SETVARS
if '($DATA(RACCESS(DUZ))\10)!('$DATA(RAIMGTY))
QUIT
SET RADFT=""
GOTO 4^RART2
+2 ;
6 ;;Display a Report By Patient
+1 WRITE !
SET DIC(0)="AEMQ"
DO ^RADPA
if Y<0
GOTO Q6
SET RADFN=+Y
SET RAHEAD="**** Patient's Exams ****"
SET RAF1=1
SET RAREPORT=1
DO ^RAPTLU
if X="^"
GOTO Q6
if '$DATA(RADUP)
GOTO 6
+2 IF X=1
READ X:3
OERR ;entry from RA OERR PROFILE protocol
+1 FOR RAI=0:0
SET RAI=$ORDER(RADUP(RAI))
if RAI'>0
QUIT
SET Y=^TMP($JOB,"RAEX",RAI)
DO 61
DO DISP
if X="^"
QUIT
+2 KILL RADUP,RAI,RAJ,X,^TMP($JOB,"RAEX")
if $DATA(ORVP)
QUIT
GOTO 6
61 FOR RAJ=1:1:11
SET @$PIECE("RADFN^RADTI^RACNI^RANME^RASSN^RADATE^RADTE^RACN^RAPRC^RARPT^RAST","^",RAJ)=$PIECE(Y,"^",RAJ)
+1 SET Y(0)=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
QUIT
+2 ;
OERR1 ;Entry Point for Alert Follow-Up Action for OE/RR
+1 if '$DATA(XQADATA)!('$DATA(XQAID))
QUIT
SET (RARPT,Y)=XQADATA
DO RASET^RAUTL2
+2 if Y
SET Y(0)=Y
SET RANME=$SELECT($DATA(^DPT(RADFN,0)):$PIECE(^(0),"^"),1:"Unknown")
SET RAPRC=$SELECT($DATA(^RAMIS(71,+$PIECE(Y(0),"^",2),0)):$PIECE(^(0),"^"),1:"Unknown")
+3 SET RALERTS=""
DO DISP
if X="^"
KILL XQAID,XQAKILL
+4 IF $DATA(XQAID)
SET DFN=$PIECE(XQAID,",",2)
DO DELETE^XQALERT
+5 KILL RALERTS
+6 QUIT
+7 ;
DISP IF RARPT
IF ($DATA(RAPBRPT))
IF ($PIECE($GET(^RARPT(+RARPT,0)),"^",5)="V")
Begin DoDot:1
+1 ; This code will not allow a user to re-edit a verified report.
+2 ; In this case, two or more possible users signed on to the same
+3 ; Imaging location, asked to verify the reports of the same
+4 ; Interpreting Radiology/Nuclear Medicine Physician.
+5 ; For the 'On-line Verifying of Reports' option only!
+6 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,Y
+7 ; removed X from N so rtn RARTVER would quit if caret entered
+8 WRITE !!?10,"Since the time you selected this group of reports,",!?10,$PIECE($GET(^VA(200,+$PIECE(^RARPT(+RARPT,0),"^",9),0)),U)," has verified the report for "
+9 WRITE !?10,$PIECE($GET(^DPT(+$PIECE(^RARPT(+RARPT,0),"^",2),0)),U)," case #",$PIECE(^RARPT(+RARPT,0),"^"),".",$CHAR(7)
+10 SET Y=$SELECT($DATA(^TMP($JOB,"RA","DT",+$GET(RARTDT),+$GET(RARPT))):$PIECE($PIECE(^(RARPT),"/",2),U,3),$DATA(RARPTX(+$GET(RPTX))):$PIECE($PIECE(RARPTX(+$GET(RPTX)),"/",2),U,3),1:"")
+11 IF $DATA(^RAMIS(71,+Y,0))
WRITE !?10,"Procedure ",$PIECE(^(0),U)
+12 WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET RAVFIED=1
+13 QUIT
End DoDot:1
QUIT
+14 DO HOME^%ZIS
SET OREND=1
+15 IF 'RARPT!('$DATA(^RARPT(+RARPT,0)))
Begin DoDot:1
+16 WRITE !?3,$CHAR(7),"No report filed for case number",$SELECT($DATA(RACN):" "_RACN,1:""),"."
+17 ; D:$$IMAGE^RARIC1 DISPF^MAGRIC ;don't call MAG 111300
READ X:3
+18 QUIT
End DoDot:1
GOTO Q6
+19 SET RAST=$PIECE(^RARPT(+RARPT,0),"^",5)
+20 IF '$DATA(RARTVER)
IF (RAST=""!(RAST["D"))
Begin DoDot:1
+21 WRITE !?3,$CHAR(7),"Report filed for case number ",RACN," but not available for display."
+22 ; D:$$IMAGE^RARIC1 DISPF^MAGRIC ;don't call MAG 111300
READ X:3
+23 QUIT
End DoDot:1
GOTO Q6
DISP1 IF $SELECT('$DATA(ORACTION):1,ORACTION'=8:1,'$DATA(X):0,X="T":1,1:0)
WRITE @IOF
+1 WRITE !,RANME," (",$$SSN^RAUTL,")",?39,"Case No. ",?55,": ",$PIECE($GET(^RARPT(RARPT,0)),"^")," @",$EXTRACT(RADATE,$LENGTH(RADATE)-4,$LENGTH(RADATE))
+2 WRITE !,$EXTRACT(RAPRC,1,40)
IF +$GET(^RARPT(RARPT,"T"))
WRITE ?39,"Transcriptionist",?55,": ",$EXTRACT($PIECE($GET(^VA(200,+^RARPT(RARPT,"T"),0)),"^"),1,20)
+3 NEW R3
SET R3=$GET(^RADPT(+$GET(RADFN),"DT",+$GET(RADTI),"P",+$GET(RACNI),0))
+4 WRITE !,"Req. Phys : ",$EXTRACT($PIECE($GET(^VA(200,+$PIECE(R3,"^",14),0)),"^"),1,25)
+5 SET RAPREVER=+$PIECE($GET(^RARPT(RARPT,0)),"^",13)
WRITE ?39,"Pre-verified",?55,": ",$SELECT($DATA(^VA(200,RAPREVER,0)):$EXTRACT($PIECE($GET(^VA(200,RAPREVER,0)),"^"),1,24),1:"NO")
KILL RAPREVER
+6 DO PHYS^RART3
+7 ;Display Pregnancy Screen and Comments if respective field is filled and pt is female, patch #99
+8 IF $$PTSEX^RAUTL8(RADFN)="F"
Begin DoDot:1
+9 if $PIECE(R3,U,32)'=""
WRITE !,"Pregnancy Screen: ",$SELECT($PIECE(R3,"^",32)="y":"Patient answered yes",$PIECE(R3,"^",32)="n":"Patient answered no",$PIECE(R3,"^",32)="u":"Patient is unable to answer or is unsure",1:"")
+10 NEW RAPCOMM
SET RAPCOMM=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCOMM"))
+11 if $PIECE(R3,U,32)'=""&$LENGTH(RAPCOMM)
WRITE !,"Pregnancy Screen Comment: ",RAPCOMM
End DoDot:1
+12 IF $DATA(RAPBRPT)
IF (RAST="PD")
Begin DoDot:1
+13 WRITE !,"**Prob Text: "
+14 IF $GET(^RARPT(+RARPT,"P"))]""
Begin DoDot:2
+15 SET X=$GET(^RARPT(+RARPT,"P"))
+16 DO OUTTEXT^RAUTL9(X,"",10,70,13,"","!")
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 WRITE !,$$REPEAT^XLFSTR("=",79)
+20 IF $ORDER(^RARPT(RARPT,1,0))
DO MODSET^RART3
+21 IF '$ORDER(^RARPT(RARPT,1,0))
Begin DoDot:1
+22 DO MODS^RAUTL2
DO OUT1^RART3
+23 IF +$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",28)
SET X=$$RDIO1^RARTUTL1(+$PIECE(^(0),"^",28))
+24 ; 'X' should be 'null' to continue
if $LENGTH($GET(X))
QUIT
+25 if +$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0))
SET X=$$PHARM1^RARTUTL(RACNI_","_RADTI_","_RADFN_",")
+26 QUIT
End DoDot:1
+27 if $GET(X)="P"
QUIT
if $GET(X)="T"
GOTO DISP1
if $GET(X)="^"
GOTO Q6
+28 IF +$ORDER(^RARPT(RARPT,"ERR",0))
WRITE !?10,$$AMENRPT^RARTR2(),!
+29 ;
+30 ; Print the clinical history from file 70
+31 IF +$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",0))
Begin DoDot:1
+32 KILL ^UTILITY($JOB,"W"),^(1)
SET X=""
SET DIWL=3
SET DIWF="|WC75"
+33 WRITE !?3,"Clinical History:"
+34 SET RAP="H"
DO WRITEHX(RAP)
+35 QUIT
End DoDot:1
+36 if $GET(X)="P"
QUIT
if $GET(X)="T"
GOTO DISP1
if $GET(X)="^"
GOTO Q6
+37 ;
+38 ; Print the additional report clinical history if defined and
+39 ; different than the order clinical history.
+40 IF +$ORDER(^RARPT(RARPT,"H",0))
Begin DoDot:1
+41 ; Duplicate history
DO CHKDUPHX
if RADUPHX
QUIT
+42 KILL ^UTILITY($JOB,"W"),^(1)
SET X=""
SET DIWL=3
SET DIWF="|WC75"
+43 WRITE !?3,"Additional Clinical History:"
+44 SET RAP="AH"
DO WRITEHX(RAP)
End DoDot:1
+45 ;
+46 ; Print Report and Impression text
+47 FOR RAP="R","I"
Begin DoDot:1
+48 KILL ^UTILITY($JOB,"W"),^(1)
SET X=""
SET DIWL=3
SET DIWF="|WC75"
+49 WRITE !?3,$SELECT(RAP="R":"Report:",1:"Impression:")
if RAP="R"
WRITE ?45,"Status: ",$$XTERNAL^RAUTL5(RAST,$PIECE($GET(^DD(74,5,0)),U,2))
+50 if RAP="R"&($EXTRACT(RAST)="P")
WRITE $CHAR(7)
+51 DO WRITE
+52 QUIT
End DoDot:1
if X="^"!(X="P")!(X="T")
QUIT
+53 if X="P"
QUIT
if X="T"
GOTO DISP1
if X="^"
GOTO Q6
+54 ; I $$IMAGE^RARIC1() D DISPF^MAGRIC ;don't call MAG 111300
+55 IF $PIECE($GET(^RA(79.1,+$PIECE(^RADPT(RADFN,"DT",RADTI,0),U,4),0)),U,18)="Y"
DO PRTDX^RART
KILL RADXCODE
+56 if X="P"
QUIT
if X="T"
GOTO DISP1
if X="^"
GOTO Q6
+57 ;
+58 IF $DATA(ORVP)
Begin DoDot:1
+59 SET RAVERF=+$PIECE($GET(^RARPT(+RARPT,0)),"^",9)
+60 SET RADFTSBN=$EXTRACT($PIECE($GET(^VA(200,RAVERF,20)),"^",2),1,25)
+61 if RADFTSBN']""
SET RADFTSBN=$EXTRACT($PIECE($GET(^VA(200,RAVERF,0)),"^"),1,25)
+62 SET RADFTSBT=$EXTRACT($PIECE($GET(^VA(200,RAVERF,20)),"^",3),1,30)
+63 if RADFTSBT']""
SET RADFTSBT=$$TITLE^RARTR0(RAVERF)
+64 WRITE !!,"VERIFIED BY:",!?2,$SELECT(RADFTSBN]"":RADFTSBN,1:"")
+65 if RADFTSBT]""
WRITE ", "_RADFTSBT
End DoDot:1
+66 if X="P"
QUIT
if X="T"
GOTO DISP1
if X="^"
GOTO Q6
+67 ;
+68 KILL RAP
IF '$DATA(RARTVER)
DO WAIT
if X="P"
QUIT
if X="T"
GOTO DISP1
Q6 KILL %,DIC,DIWF,DIWL,DIWR,I,J,OREND,POP,RABTCH,RAF1,RAHEAD,RALOC,RANME,RAPAR,RAPRC,RAREPORT,RASEL,RASSN,RAST,RAV,RAXX,Y,X1,Z
+1 KILL RAVERF,RADFTSBN,RADFTSBT
+2 KILL DIW,DIWT,DN
+3 KILL C,DIPGM,DISYS,R1,RAIMGTYI,RAP
+4 if '$DATA(RARTVER)
KILL RACN,RACNI,RADATE,RADFN,RADTE,RADTI,RARPT
QUIT
+5 ;
WRITE KILL RAXX
NEW Y
+1 FOR RAV=0:0
SET RAV=$ORDER(^RARPT(RARPT,RAP,RAV))
if RAV'>0
QUIT
Begin DoDot:1
+2 SET RAXX=^RARPT(RARPT,RAP,RAV,0)
SET X=""
+3 if ($Y+6)>IOSL&('$DATA(RARTVERF))
DO WAIT
if X="^"!(X="P")!(X="T")
QUIT
+4 SET X=RAXX
DO ^DIWP
SET X=""
+5 QUIT
End DoDot:1
if X="^"!(X="P")!(X="T")
QUIT
+6 if X="^"
QUIT
if $DATA(RAXX)
DO ^DIWW
QUIT
+7 ;
WRITEHX(RAP) ; Get and write the clinical history
+1 ;
+2 ;Input: RAP H = Clinical History from file 70
+3 ; AH = Additional Clinical History from file 74
+4 ;
+5 KILL RAXX
NEW Y
+6 SET RAV=0
+7 IF RAP="H"
Begin DoDot:1
+8 FOR
SET RAV=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAV))
if RAV'>0
QUIT
Begin DoDot:2
+9 SET RAXX=^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAV,0)
SET X=""
+10 if ($Y+6)>IOSL&('$DATA(RARTVERF))
DO WAIT
if X="^"!(X="P")!(X="T")
QUIT
+11 SET X=RAXX
DO ^DIWP
SET X=""
+12 QUIT
End DoDot:2
if X="^"!(X="P")!(X="T")
QUIT
End DoDot:1
+13 IF RAP="AH"
Begin DoDot:1
+14 FOR
SET RAV=$ORDER(^RARPT(RARPT,"H",RAV))
if RAV'>0
QUIT
Begin DoDot:2
+15 SET RAXX=^RARPT(RARPT,"H",RAV,0)
SET X=""
+16 if ($Y+6)>IOSL&('$DATA(RARTVERF))
DO WAIT
if X="^"!(X="P")!(X="T")
QUIT
+17 SET X=RAXX
DO ^DIWP
SET X=""
+18 QUIT
End DoDot:2
if X="^"!(X="P")!(X="T")
QUIT
End DoDot:1
+19 if X="^"
QUIT
if $DATA(RAXX)
DO ^DIWW
QUIT
+20 ;
CHKDUPHX ; Check Duplicate History in file 70 and 74.
+1 ; Returns RADUPHX 1 = Duplicate
+2 ; 0 = Different
+3 NEW RAX,RA74,RA70,RAOK,RAX1
+4 ; Initialize to Different
+5 SET RADUPHX=0
+6 ; Quit if H node does not exist. Could have been purged.
+7 IF '$DATA(^RARPT(RARPT,"H"))
SET RADUPHX=1
QUIT
+8 ;p173/KLM Quit if no CH on exam, flag set to take CH from report.
+9 IF '$DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H"))
SET RADUPHX=0
QUIT
+10 SET RA74=$ORDER(^RARPT(RARPT,"H",""),-1)
+11 SET RA70=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",""),-1)
SET RA701=$ORDER(^(0))
+12 ; begin comparison
SET RAX=RA74-RA70+1
if RAX'=1
QUIT
+13 ; Check line by line of each file
+14 ; RAOK 1 = all lines match
+15 ; 0 = at least 1 difference
+16 SET RAOK=1
+17 ;can exit loop on 1st difference
FOR RAX1=RA701:1:RA70
IF ^RARPT(RARPT,"H",RAX1,0)'=^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAX1,0)
SET RAOK=0
QUIT
+18 IF 'RAOK
QUIT
+19 SET RADUPHX=1
+20 QUIT
+21 ;
WAIT ; user input, goto top, print, or continue
+1 SET RARD(1)="Continue^continue normal processing"
+2 if $DATA(RALERTS)
SET RARD(2)="Print^print the entire report"
+3 SET RARD(3)="Top^display the report from the beginning"
+4 SET (RARD("B"),RARD("DTOUT"))=1
+5 if $DATA(RALERTS)
SET RARD("A")="Enter 'Top', 'Print' or 'Continue': "
+6 if '$DATA(RALERTS)
SET RARD("A")="Enter 'Top' or 'Continue': "
+7 SET RARD(0)="S"
DO SET^RARD
KILL RARD
SET X=$EXTRACT(X)
+8 IF $DATA(RALERTS)
IF (X="P")
DO QRPT^RART3
+9 if X="^"!(X="P")
QUIT
if X="C"&($DATA(RAP))
WRITE @IOF
+10 QUIT
+11 ;
LOCK(X,Y) ; Lock an entry
+1 WRITE !!,$CHAR(7),"Another user is editing this ",$SELECT(X="R":"report (Case # "_Y_")",1:"exam (diagnostic code)"),". Please try again later."
HANG 4
QUIT
+2 ;
SETVARS ; Setup Rad/Nuc Med required variables
+1 IF $ORDER(RACCESS(DUZ,""))=""
DO SETVARS^RAPSET1(0)
+2 if '($DATA(RACCESS(DUZ))\10)
QUIT
+3 IF $GET(RAIMGTY)=""
DO SETVARS^RAPSET1(1)
+4 QUIT
