RART1 ;HISC/GJC,SWM-Reporting Menu (Part 2) ; 06 Oct 2013 11:05 AM
;;5.0;Radiology/Nuclear Medicine;**8,16,15,21,23,27,34,99,47,1005**;Mar 16, 1998;Build 13
;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
;
;IHS/BJI/DAY - Patch 1005 - Gender Fix
;I $$PTSEX^RAUTL8(RADFN)="F" D
I $$PTSEX^RAUTL8(RADFN)'="M" 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
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
RART1 ;HISC/GJC,SWM-Reporting Menu (Part 2) ; 06 Oct 2013 11:05 AM
+1 ;;5.0;Radiology/Nuclear Medicine;**8,16,15,21,23,27,34,99,47,1005**;Mar 16, 1998;Build 13
+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 ;
+9 ;IHS/BJI/DAY - Patch 1005 - Gender Fix
+10 ;I $$PTSEX^RAUTL8(RADFN)="F" D
+11 IF $$PTSEX^RAUTL8(RADFN)'="M"
Begin DoDot:1
+12 ;
+13 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:"")
+14 NEW RAPCOMM
SET RAPCOMM=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCOMM"))
+15 IF $PIECE(R3,U,32)'=""&$LENGTH(RAPCOMM)
WRITE !,"Pregnancy Screen Comment: ",RAPCOMM
End DoDot:1
+16 IF $DATA(RAPBRPT)
IF (RAST="PD")
Begin DoDot:1
+17 WRITE !,"**Prob Text: "
+18 IF $GET(^RARPT(+RARPT,"P"))]""
Begin DoDot:2
+19 SET X=$GET(^RARPT(+RARPT,"P"))
+20 DO OUTTEXT^RAUTL9(X,"",10,70,13,"","!")
+21 QUIT
End DoDot:2
+22 QUIT
End DoDot:1
+23 WRITE !,$$REPEAT^XLFSTR("=",79)
+24 IF $ORDER(^RARPT(RARPT,1,0))
DO MODSET^RART3
+25 IF '$ORDER(^RARPT(RARPT,1,0))
Begin DoDot:1
+26 DO MODS^RAUTL2
DO OUT1^RART3
+27 IF +$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",28)
SET X=$$RDIO1^RARTUTL1(+$PIECE(^(0),"^",28))
+28 ; 'X' should be 'null' to continue
IF $LENGTH($GET(X))
QUIT
+29 IF +$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0))
SET X=$$PHARM1^RARTUTL(RACNI_","_RADTI_","_RADFN_",")
+30 QUIT
End DoDot:1
+31 IF $GET(X)="P"
QUIT
IF $GET(X)="T"
GOTO DISP1
IF $GET(X)="^"
GOTO Q6
+32 IF +$ORDER(^RARPT(RARPT,"ERR",0))
WRITE !?10,$$AMENRPT^RARTR2(),!
+33 ;
+34 ; Print the clinical history from file 70
+35 IF +$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",0))
Begin DoDot:1
+36 KILL ^UTILITY($JOB,"W"),^(1)
SET X=""
SET DIWL=3
SET DIWF="|WC75"
+37 WRITE !?3,"Clinical History:"
+38 SET RAP="H"
DO WRITEHX(RAP)
+39 QUIT
End DoDot:1
+40 IF $GET(X)="P"
QUIT
IF $GET(X)="T"
GOTO DISP1
IF $GET(X)="^"
GOTO Q6
+41 ;
+42 ; Print the additional report clinical history if defined and
+43 ; different than the order clinical history.
+44 IF +$ORDER(^RARPT(RARPT,"H",0))
Begin DoDot:1
+45 ; Duplicate history
DO CHKDUPHX
IF RADUPHX
QUIT
+46 KILL ^UTILITY($JOB,"W"),^(1)
SET X=""
SET DIWL=3
SET DIWF="|WC75"
+47 WRITE !?3,"Additional Clinical History:"
+48 SET RAP="AH"
DO WRITEHX(RAP)
End DoDot:1
+49 ;
+50 ; Print Report and Impression text
+51 FOR RAP="R","I"
Begin DoDot:1
+52 KILL ^UTILITY($JOB,"W"),^(1)
SET X=""
SET DIWL=3
SET DIWF="|WC75"
+53 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))
+54 IF RAP="R"&($EXTRACT(RAST)="P")
WRITE $CHAR(7)
+55 DO WRITE
+56 QUIT
End DoDot:1
IF X="^"!(X="P")!(X="T")
QUIT
+57 IF X="P"
QUIT
IF X="T"
GOTO DISP1
IF X="^"
GOTO Q6
+58 ; I $$IMAGE^RARIC1() D DISPF^MAGRIC ;don't call MAG 111300
+59 IF $PIECE($GET(^RA(79.1,+$PIECE(^RADPT(RADFN,"DT",RADTI,0),U,4),0)),U,18)="Y"
DO PRTDX^RART
KILL RADXCODE
+60 IF X="P"
QUIT
IF X="T"
GOTO DISP1
IF X="^"
GOTO Q6
+61 ;
+62 IF $DATA(ORVP)
Begin DoDot:1
+63 SET RAVERF=+$PIECE($GET(^RARPT(+RARPT,0)),"^",9)
+64 SET RADFTSBN=$EXTRACT($PIECE($GET(^VA(200,RAVERF,20)),"^",2),1,25)
+65 IF RADFTSBN']""
SET RADFTSBN=$EXTRACT($PIECE($GET(^VA(200,RAVERF,0)),"^"),1,25)
+66 SET RADFTSBT=$EXTRACT($PIECE($GET(^VA(200,RAVERF,20)),"^",3),1,30)
+67 IF RADFTSBT']""
SET RADFTSBT=$$TITLE^RARTR0(RAVERF)
+68 WRITE !!,"VERIFIED BY:",!?2,$SELECT(RADFTSBN]"":RADFTSBN,1:"")
+69 IF RADFTSBT]""
WRITE ", "_RADFTSBT
End DoDot:1
+70 IF X="P"
QUIT
IF X="T"
GOTO DISP1
IF X="^"
GOTO Q6
+71 ;
+72 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 SET RA74=$ORDER(^RARPT(RARPT,"H",""),-1)
+9 SET RA70=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",""),-1)
SET RA701=$ORDER(^(0))
+10 ; begin comparison
SET RAX=RA74-RA70+1
IF RAX'=1
QUIT
+11 ; Check line by line of each file
+12 ; RAOK 1 = all lines match
+13 ; 0 = at least 1 difference
+14 SET RAOK=1
+15 ;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
+16 IF 'RAOK
QUIT
+17 SET RADUPHX=1
+18 QUIT
+19 ;
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
