RARTE2 ;HISC/SWM,GJC-Edit/Delete a Report ; Feb 09, 2021@12:26:05
;;5.0;Radiology/Nuclear Medicine;**10,31,47,124,175**;Mar 16, 1998;Build 2
; known vars-->RADFN,RACNI,RADTI,RARPT,RARPTN
;
;Routine IA Type
;-------------------------------------
; ^DIR 10026 (S)
; APPERROR^%ZTER 1621 (S)
; OWNSKEY^XUSRB 3277 (S)
;
PTR ; if the current study is the master study for
; the print set the accession of the master study
; is the .01 value of the master pset report record.
; All secondary studies will have their accession
; numbers filed in the OTHER CASE# multiple under
; that master pset report record.
;
;RARPTN: the value of the .01 field of our master pset
; report record (accession #)
;
S RAXIT=0
I '$D(RADFN)!'$D(RACNI)!'$D(RADTI)!'$D(RARPT)!'$D(RARPTN) D Q
. S RAXIT=1 Q:$G(RARIC)
. I '$D(RAQUIET) W !!,$C(7),"Missing data (routine RARTE2)",! S RAOUT=$$EOS^RAUTL5() Q
. S RAERR="Missing data needed by routine RARTE2"
. Q
;
PTR2 ;find the descendent, if part of the pset build accession # into our result
;array iff they pass the conditions enumerated below.
;from RAHLO1: RARPTN=RALONGCN
;
N RAO1,RA1ARY,RACCSTR,RARPTONCAN
;RAO1 - study IEN (think RACNI)
;RACCSTR - front end of the accession (excludes case #) in this part
; of the code (changes to full accession # in PTR3)
;RA1ARY - this will be the array where our accession #s are stored
; RA1ARY(RAO1,accession #)=""
;RARPTONCAN - allow rpts on canceled cases? '1' for yes, else '0'
;
S RACCSTR=$P(RARPTN,"-",1,($L(RARPTN,"-")-1)) ;Ex: 141-040618 -or- 040618
;--- RA5P175
;RAMDV is expected to be .1 node of file #79 division
;record with the pieces having values of: '1','0' or ""
S RARPTONCAN=+$P($G(RAMDV),U,22)
;---
;save off the accession # stored in the .01 field of the report
;we do not want this accession # set in the OTHER CASE# multiple
S RA1ARY(0,RARPTN)=""
;
S RAO1=0 K RAOX
F S RAO1=$O(^RADPT(RADFN,"DT",RADTI,"P",RAO1)) Q:'RAO1 D
.S RAO1(0)=$G(^RADPT(RADFN,"DT",RADTI,"P",RAO1,0))
.;get the order # of the exam status for this study RAOX(3)
.S RAOX(3)=$P(^RA(72,+$P(RAO1(0),U,3),0),U,3)
.;--- RA5P175
.;Condition 1: if a pset, if in foreground, study canceled
.;& allow rpts on canceled cases = 'no' ask the user if they
.;want to tie the report to the canceled exam.
.;Note: RA MGR key is required in order to be asked.
.I $$SILENT()=1,(RAOX(3)=0),(RARPTONCAN=0),($$OWNSKEY()=0) QUIT ;no RA MGR key
.I $$SILENT()=1,(RAOX(3)=0),(RARPTONCAN=0),($$OWNSKEY()) Q:$$ASK()'=1
.;--- RA5P175
.;Condition 2: if in background, study canceled & allow
.;rpts on canceled cases = 'no'
.I $$SILENT()=0,(RAOX(3)=0),(RARPTONCAN=0) QUIT
.;---
.;set the report pointer for the study in question
.S $P(^RADPT(RADFN,"DT",RADTI,"P",RAO1,0),U,17)=RARPT
.;build the accession number: +RAO1(0) = case number
.S RAOX=RACCSTR_"-"_+RAO1(0)
.I $P(RAO1(0),U,25)=2,('$D(RA1ARY(0,RAOX))#2) S RA1ARY(RAO1,RAOX)=""
.Q
K RAOX
;
PTR3 ; -RAO1: reused for $O subscript (think RACNI)
; -RACCSTR: now represents the full accession #
; Ex: 141-040618-12345 -or- 040618-12345
; -RARPT: record # of RIS report in file #74
;
S RAO1=0 F S RAO1=$O(RA1ARY(RAO1)) Q:'RAO1 D
.S RACCSTR=$O(RA1ARY(RAO1,"")) ;accession #
.; do not file this accession # into the
.; OTHER CASE# (#4.5) multiple if it already exists
.; *** Milwaukee RIS issue: .01 overwritten & duplicate
.; accessions in OTHER CASE# mult (124 T1) ***
.D:($D(^RARPT("B",RACCSTR,RARPT))=0) INSERT
.Q
;
;note: * I $G(RARIC) REPORT TEXT (70.03;17) is set in routine RARIC
; * I $D(RAQUIET) REPORT TEXT is set in routine RAHLO1
; * through the backdoor, REPORT TEXT is set in tag^routine(s):
; - LOCK^RARTE4
; - LOCK^RARTE5
;
; + noted b/c there was a hard set of the REPORT TEXT field in this code prior
; to RA*5.0*124.
Q
;
INSERT ; add subrec to file #74's subfile #74.05
N RAFDA,RAIEN,RAMSG
S RAIEN="?+1,"_RARPT_",",RAFDA(74.05,RAIEN,.01)=RACCSTR
D UPDATE^DIE("","RAFDA","RAIEN","RAMSG")
I $D(RAMSG) D Q
. S RAXIT=1 Q:$G(RARIC)
. I '$D(RAQUIET) W !!,$C(7),"Error encountered while setting sub-records (routine RARTE2)",! S RAOUT=$$EOS^RAUTL5() Q ;error detected
. S RAERR="Error encountered while setting sub-recs from RARTE2"
Q
;
DEL17(RAIEN) ;del other print set members' pointer to #74
Q:'$D(RADFN)!('$D(RADTI))
N RA4,RA1 D EN3^RAUTL20(.RA4)
Q:'$O(RA4(0))
S RA1=""
D18 S RA1=$O(RA4(RA1)) Q:RA1=""
; kill xrefs, if any, for file #70's REPORT TEXT
S DA(2)=RADFN,DA(1)=RADTI,DA=RA1
; if this exam's piece 17 doesn't match RAIEN, then don't remove pc17
I $P($G(^RADPT(RADFN,"DT",RADTI,"P",RA1,0)),"^",17)'=RAIEN G D18
D ENKILL^RAXREF(70.03,17,RAIEN,.DA)
; set REPORT TEXT to null
S:$D(^RADPT(RADFN,"DT",RADTI,"P",RA1,0)) $P(^(0),"^",17)=""
G D18
COPY ;copy physicians and diagnoses
Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI))!('$D(RAMEMARR))!('$D(RADRS))
W !!,"... now copying ",$S(RADRS=1:"Diagnostic Codes",1:"Staff & Resident data")," to other cases in this print set ...",!
N RA1,RA2,RA3
N RA1PR,RA1PS ;prim res/staff
N RA1SR,RA1SS ; sec res/staff arrays--(ien subfile #70.11)=ien file #200
N RA1PD,RA1SD ; prim diag, then sec diags array
N RAFDA,RAIEN,RAMSG
;prim res, prim staff, prim diag
S RA1=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0) S:RADRS=2 RA1PR=$P(RA1,"^",12),RA1PS=$P(RA1,"^",15) S:RADRS=1 RA1PD=$P(RA1,"^",13)
;sec residents
I RADRS=2,$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",0)) S RA1=0 F S RA1=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",RA1)) Q:+RA1'=RA1 S RA1SR(RA1)=+^(RA1,0)
;sec staff
I RADRS=2,$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",0)) S RA1=0 F S RA1=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",RA1)) Q:+RA1'=RA1 S RA1SS(RA1)=+^(RA1,0)
;sec diagnoses
I RADRS=1,$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0)) S RA1=0 F S RA1=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",RA1)) Q:+RA1'=RA1 S RA1SD(RA1)=+^(RA1,0)
;loop thru other cases of this printset
S RA1=0
COPYLOOP S RA1=$O(RAMEMARR(RA1)) G:RA1="" COPYREF G:RA1=RACNI COPYLOOP ;skip what's done already
;
; copy primary staff and resident via Fileman
I RADRS=2 D
. S DA(2)=RADFN,DA(1)=RADTI,DA=RA1
. S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
. S DR="12////"_RA1PR_";15////"_RA1PS
. D ^DIE K DA,DIE,DR ; no locking
. Q
;
; copy primary diagnostic code via Fileman
I RADRS=1 D
. S DA(2)=RADFN,DA(1)=RADTI,DA=RA1
. S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
. S DR="13////"_RA1PD
. D ^DIE K DA,DIE,DR ; no locking
. Q
;
S RA2=RA1_","_RADTI_","_RADFN ;stem for dataserver call
S DA(3)=RADFN,DA(2)=RADTI,DA(1)=RA1 ;base vars for DIK call
I RADRS=2 S RA3=0 D KIL3 G:RAXIT Q ; sec res
I RADRS=2 S RA3=0 D KIL4 G:RAXIT Q ; sec staff
I RADRS=1 S RA3=0 D KIL5 G:RAXIT Q ; sec diag
G COPYLOOP
KIL3 S RA3=$O(^RADPT(RADFN,"DT",RADTI,"P",RA1,"SRR",RA3)) G:RA3="" COPY3
S DA=RA3
S DIK="^RADPT("_DA(3)_",""DT"","_DA(2)_",""P"","_DA(1)_",""SRR"","
D ^DIK
G KIL3
COPY3 K RAFDA,RAIEN,RAMSG S RA3=$O(RA1SR(RA3)) Q:'RA3 Q:RAXIT
UP3 ;
S RAFDA(70.09,"?+2,"_RA2_",",.01)=RA1SR(RA3)
D UPDATE^DIE("","RAFDA","RAIEN","RAMSG") G:'$D(RAMSG) COPY3
S RAXIT=1 W !!,$C(7),"Error encountered while in adding rec ",RA3," to sub-file 70.09" Q
KIL4 S RA3=$O(^RADPT(RADFN,"DT",RADTI,"P",RA1,"SSR",RA3)) G:RA3="" COPY4
S DA=RA3
S DIK="^RADPT("_DA(3)_",""DT"","_DA(2)_",""P"","_DA(1)_",""SSR"","
D ^DIK
G KIL4
COPY4 K RAFDA,RAIEN,RAMSG S RA3=$O(RA1SS(RA3)) Q:'RA3 Q:RAXIT
UP4 ;
S RAFDA(70.11,"?+2,"_RA2_",",.01)=RA1SS(RA3)
D UPDATE^DIE("","RAFDA","RAIEN","RAMSG") G:'$D(RAMSG) COPY4
S RAXIT=1 W !!,$C(7),"Error encountered while in adding rec ",RA3," to sub-file 70.11" Q
KIL5 S RA3=$O(^RADPT(RADFN,"DT",RADTI,"P",RA1,"DX",RA3)) G:RA3="" COPY5
S DA=RA3
S DIK="^RADPT("_DA(3)_",""DT"","_DA(2)_",""P"","_DA(1)_",""DX"","
D ^DIK
G KIL5
COPY5 K RAFDA,RAIEN,RAMSG S RA3=$O(RA1SD(RA3)) Q:'RA3 Q:RAXIT
UP5 ;
S RAFDA(70.14,"?+2,"_RA2_",",.01)=RA1SD(RA3)
D UPDATE^DIE("","RAFDA","RAIEN","RAMSG") G:'$D(RAMSG) COPY5
S RAXIT=1 W !!,$C(7),"Error encountered while in adding rec ",RA3," to sub-file 70.14" Q
COPYREF ; clear out Fileman vars and quit
K DA,DIK
Q ; don't need to re-xref again
Q K DA Q
;
SILENT() ;ask to include canceled cases if interactive
;RARIC: set in CREATE^RARIC
;RAQUIET: set in the RIS' HL7 bridge routine
Q:$G(RARIC)!($D(RAQUIET)) 0
Q 1
;
ASK() ;include canceled case in report?
N DIRUT,DUOUT,DTOUT,DIR,X,Y,RAX
S DIR(0)="Y",DIR("B")="No"
S DIR("A",1)="Case "_+$P(RAO1(0),U)_" on this printset has been canceled."
S DIR("A")="Do you want to include it in the report anyway" D ^DIR
I $D(DIRUT) S Y=-1
S RAX=$S(Y=1:"In",1:"Ex")_"clude case "_+$P(RAO1(0),U)
W !!,RAX
Q Y ;'1' for yes, '0' for no
;
OWNSKEY() ;does this user have the RA MGR key?
;Input variable: none; DUZ must be defined
;Output: BOOL(0) - Returns a subscripted output where
; 1 - User owns key.
; 0 - DUZ not defined or key not found.
;
Q:$D(DUZ)#2=0 0
N BOOL D OWNSKEY^XUSRB(.BOOL,"RA MGR",DUZ)
Q BOOL(0)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRARTE2 9330 printed Sep 23, 2025@20:15:24 Page 2
RARTE2 ;HISC/SWM,GJC-Edit/Delete a Report ; Feb 09, 2021@12:26:05
+1 ;;5.0;Radiology/Nuclear Medicine;**10,31,47,124,175**;Mar 16, 1998;Build 2
+2 ; known vars-->RADFN,RACNI,RADTI,RARPT,RARPTN
+3 ;
+4 ;Routine IA Type
+5 ;-------------------------------------
+6 ; ^DIR 10026 (S)
+7 ; APPERROR^%ZTER 1621 (S)
+8 ; OWNSKEY^XUSRB 3277 (S)
+9 ;
PTR ; if the current study is the master study for
+1 ; the print set the accession of the master study
+2 ; is the .01 value of the master pset report record.
+3 ; All secondary studies will have their accession
+4 ; numbers filed in the OTHER CASE# multiple under
+5 ; that master pset report record.
+6 ;
+7 ;RARPTN: the value of the .01 field of our master pset
+8 ; report record (accession #)
+9 ;
+10 SET RAXIT=0
+11 IF '$DATA(RADFN)!'$DATA(RACNI)!'$DATA(RADTI)!'$DATA(RARPT)!'$DATA(RARPTN)
Begin DoDot:1
+12 SET RAXIT=1
if $GET(RARIC)
QUIT
+13 IF '$DATA(RAQUIET)
WRITE !!,$CHAR(7),"Missing data (routine RARTE2)",!
SET RAOUT=$$EOS^RAUTL5()
QUIT
+14 SET RAERR="Missing data needed by routine RARTE2"
+15 QUIT
End DoDot:1
QUIT
+16 ;
PTR2 ;find the descendent, if part of the pset build accession # into our result
+1 ;array iff they pass the conditions enumerated below.
+2 ;from RAHLO1: RARPTN=RALONGCN
+3 ;
+4 NEW RAO1,RA1ARY,RACCSTR,RARPTONCAN
+5 ;RAO1 - study IEN (think RACNI)
+6 ;RACCSTR - front end of the accession (excludes case #) in this part
+7 ; of the code (changes to full accession # in PTR3)
+8 ;RA1ARY - this will be the array where our accession #s are stored
+9 ; RA1ARY(RAO1,accession #)=""
+10 ;RARPTONCAN - allow rpts on canceled cases? '1' for yes, else '0'
+11 ;
+12 ;Ex: 141-040618 -or- 040618
SET RACCSTR=$PIECE(RARPTN,"-",1,($LENGTH(RARPTN,"-")-1))
+13 ;--- RA5P175
+14 ;RAMDV is expected to be .1 node of file #79 division
+15 ;record with the pieces having values of: '1','0' or ""
+16 SET RARPTONCAN=+$PIECE($GET(RAMDV),U,22)
+17 ;---
+18 ;save off the accession # stored in the .01 field of the report
+19 ;we do not want this accession # set in the OTHER CASE# multiple
+20 SET RA1ARY(0,RARPTN)=""
+21 ;
+22 SET RAO1=0
KILL RAOX
+23 FOR
SET RAO1=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RAO1))
if 'RAO1
QUIT
Begin DoDot:1
+24 SET RAO1(0)=$GET(^RADPT(RADFN,"DT",RADTI,"P",RAO1,0))
+25 ;get the order # of the exam status for this study RAOX(3)
+26 SET RAOX(3)=$PIECE(^RA(72,+$PIECE(RAO1(0),U,3),0),U,3)
+27 ;--- RA5P175
+28 ;Condition 1: if a pset, if in foreground, study canceled
+29 ;& allow rpts on canceled cases = 'no' ask the user if they
+30 ;want to tie the report to the canceled exam.
+31 ;Note: RA MGR key is required in order to be asked.
+32 ;no RA MGR key
IF $$SILENT()=1
IF (RAOX(3)=0)
IF (RARPTONCAN=0)
IF ($$OWNSKEY()=0)
QUIT
+33 IF $$SILENT()=1
IF (RAOX(3)=0)
IF (RARPTONCAN=0)
IF ($$OWNSKEY())
if $$ASK()'=1
QUIT
+34 ;--- RA5P175
+35 ;Condition 2: if in background, study canceled & allow
+36 ;rpts on canceled cases = 'no'
+37 IF $$SILENT()=0
IF (RAOX(3)=0)
IF (RARPTONCAN=0)
QUIT
+38 ;---
+39 ;set the report pointer for the study in question
+40 SET $PIECE(^RADPT(RADFN,"DT",RADTI,"P",RAO1,0),U,17)=RARPT
+41 ;build the accession number: +RAO1(0) = case number
+42 SET RAOX=RACCSTR_"-"_+RAO1(0)
+43 IF $PIECE(RAO1(0),U,25)=2
IF ('$DATA(RA1ARY(0,RAOX))#2)
SET RA1ARY(RAO1,RAOX)=""
+44 QUIT
End DoDot:1
+45 KILL RAOX
+46 ;
PTR3 ; -RAO1: reused for $O subscript (think RACNI)
+1 ; -RACCSTR: now represents the full accession #
+2 ; Ex: 141-040618-12345 -or- 040618-12345
+3 ; -RARPT: record # of RIS report in file #74
+4 ;
+5 SET RAO1=0
FOR
SET RAO1=$ORDER(RA1ARY(RAO1))
if 'RAO1
QUIT
Begin DoDot:1
+6 ;accession #
SET RACCSTR=$ORDER(RA1ARY(RAO1,""))
+7 ; do not file this accession # into the
+8 ; OTHER CASE# (#4.5) multiple if it already exists
+9 ; *** Milwaukee RIS issue: .01 overwritten & duplicate
+10 ; accessions in OTHER CASE# mult (124 T1) ***
+11 if ($DATA(^RARPT("B",RACCSTR,RARPT))=0)
DO INSERT
+12 QUIT
End DoDot:1
+13 ;
+14 ;note: * I $G(RARIC) REPORT TEXT (70.03;17) is set in routine RARIC
+15 ; * I $D(RAQUIET) REPORT TEXT is set in routine RAHLO1
+16 ; * through the backdoor, REPORT TEXT is set in tag^routine(s):
+17 ; - LOCK^RARTE4
+18 ; - LOCK^RARTE5
+19 ;
+20 ; + noted b/c there was a hard set of the REPORT TEXT field in this code prior
+21 ; to RA*5.0*124.
+22 QUIT
+23 ;
INSERT ; add subrec to file #74's subfile #74.05
+1 NEW RAFDA,RAIEN,RAMSG
+2 SET RAIEN="?+1,"_RARPT_","
SET RAFDA(74.05,RAIEN,.01)=RACCSTR
+3 DO UPDATE^DIE("","RAFDA","RAIEN","RAMSG")
+4 IF $DATA(RAMSG)
Begin DoDot:1
+5 SET RAXIT=1
if $GET(RARIC)
QUIT
+6 ;error detected
IF '$DATA(RAQUIET)
WRITE !!,$CHAR(7),"Error encountered while setting sub-records (routine RARTE2)",!
SET RAOUT=$$EOS^RAUTL5()
QUIT
+7 SET RAERR="Error encountered while setting sub-recs from RARTE2"
End DoDot:1
QUIT
+8 QUIT
+9 ;
DEL17(RAIEN) ;del other print set members' pointer to #74
+1 if '$DATA(RADFN)!('$DATA(RADTI))
QUIT
+2 NEW RA4,RA1
DO EN3^RAUTL20(.RA4)
+3 if '$ORDER(RA4(0))
QUIT
+4 SET RA1=""
D18 SET RA1=$ORDER(RA4(RA1))
if RA1=""
QUIT
+1 ; kill xrefs, if any, for file #70's REPORT TEXT
+2 SET DA(2)=RADFN
SET DA(1)=RADTI
SET DA=RA1
+3 ; if this exam's piece 17 doesn't match RAIEN, then don't remove pc17
+4 IF $PIECE($GET(^RADPT(RADFN,"DT",RADTI,"P",RA1,0)),"^",17)'=RAIEN
GOTO D18
+5 DO ENKILL^RAXREF(70.03,17,RAIEN,.DA)
+6 ; set REPORT TEXT to null
+7 if $DATA(^RADPT(RADFN,"DT",RADTI,"P",RA1,0))
SET $PIECE(^(0),"^",17)=""
+8 GOTO D18
COPY ;copy physicians and diagnoses
+1 if '$DATA(RADFN)!('$DATA(RADTI))!('$DATA(RACNI))!('$DATA(RAMEMARR))!('$DATA(RADRS))
QUIT
+2 WRITE !!,"... now copying ",$SELECT(RADRS=1:"Diagnostic Codes",1:"Staff & Resident data")," to other cases in this print set ...",!
+3 NEW RA1,RA2,RA3
+4 ;prim res/staff
NEW RA1PR,RA1PS
+5 ; sec res/staff arrays--(ien subfile #70.11)=ien file #200
NEW RA1SR,RA1SS
+6 ; prim diag, then sec diags array
NEW RA1PD,RA1SD
+7 NEW RAFDA,RAIEN,RAMSG
+8 ;prim res, prim staff, prim diag
+9 SET RA1=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
if RADRS=2
SET RA1PR=$PIECE(RA1,"^",12)
SET RA1PS=$PIECE(RA1,"^",15)
if RADRS=1
SET RA1PD=$PIECE(RA1,"^",13)
+10 ;sec residents
+11 IF RADRS=2
IF $ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",0))
SET RA1=0
FOR
SET RA1=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",RA1))
if +RA1'=RA1
QUIT
SET RA1SR(RA1)=+^(RA1,0)
+12 ;sec staff
+13 IF RADRS=2
IF $ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",0))
SET RA1=0
FOR
SET RA1=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",RA1))
if +RA1'=RA1
QUIT
SET RA1SS(RA1)=+^(RA1,0)
+14 ;sec diagnoses
+15 IF RADRS=1
IF $ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0))
SET RA1=0
FOR
SET RA1=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",RA1))
if +RA1'=RA1
QUIT
SET RA1SD(RA1)=+^(RA1,0)
+16 ;loop thru other cases of this printset
+17 SET RA1=0
COPYLOOP ;skip what's done already
SET RA1=$ORDER(RAMEMARR(RA1))
if RA1=""
GOTO COPYREF
if RA1=RACNI
GOTO COPYLOOP
+1 ;
+2 ; copy primary staff and resident via Fileman
+3 IF RADRS=2
Begin DoDot:1
+4 SET DA(2)=RADFN
SET DA(1)=RADTI
SET DA=RA1
+5 SET DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
+6 SET DR="12////"_RA1PR_";15////"_RA1PS
+7 ; no locking
DO ^DIE
KILL DA,DIE,DR
+8 QUIT
End DoDot:1
+9 ;
+10 ; copy primary diagnostic code via Fileman
+11 IF RADRS=1
Begin DoDot:1
+12 SET DA(2)=RADFN
SET DA(1)=RADTI
SET DA=RA1
+13 SET DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
+14 SET DR="13////"_RA1PD
+15 ; no locking
DO ^DIE
KILL DA,DIE,DR
+16 QUIT
End DoDot:1
+17 ;
+18 ;stem for dataserver call
SET RA2=RA1_","_RADTI_","_RADFN
+19 ;base vars for DIK call
SET DA(3)=RADFN
SET DA(2)=RADTI
SET DA(1)=RA1
+20 ; sec res
IF RADRS=2
SET RA3=0
DO KIL3
if RAXIT
GOTO Q
+21 ; sec staff
IF RADRS=2
SET RA3=0
DO KIL4
if RAXIT
GOTO Q
+22 ; sec diag
IF RADRS=1
SET RA3=0
DO KIL5
if RAXIT
GOTO Q
+23 GOTO COPYLOOP
KIL3 SET RA3=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RA1,"SRR",RA3))
if RA3=""
GOTO COPY3
+1 SET DA=RA3
+2 SET DIK="^RADPT("_DA(3)_",""DT"","_DA(2)_",""P"","_DA(1)_",""SRR"","
+3 DO ^DIK
+4 GOTO KIL3
COPY3 KILL RAFDA,RAIEN,RAMSG
SET RA3=$ORDER(RA1SR(RA3))
if 'RA3
QUIT
if RAXIT
QUIT
UP3 ;
+1 SET RAFDA(70.09,"?+2,"_RA2_",",.01)=RA1SR(RA3)
+2 DO UPDATE^DIE("","RAFDA","RAIEN","RAMSG")
if '$DATA(RAMSG)
GOTO COPY3
+3 SET RAXIT=1
WRITE !!,$CHAR(7),"Error encountered while in adding rec ",RA3," to sub-file 70.09"
QUIT
KIL4 SET RA3=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RA1,"SSR",RA3))
if RA3=""
GOTO COPY4
+1 SET DA=RA3
+2 SET DIK="^RADPT("_DA(3)_",""DT"","_DA(2)_",""P"","_DA(1)_",""SSR"","
+3 DO ^DIK
+4 GOTO KIL4
COPY4 KILL RAFDA,RAIEN,RAMSG
SET RA3=$ORDER(RA1SS(RA3))
if 'RA3
QUIT
if RAXIT
QUIT
UP4 ;
+1 SET RAFDA(70.11,"?+2,"_RA2_",",.01)=RA1SS(RA3)
+2 DO UPDATE^DIE("","RAFDA","RAIEN","RAMSG")
if '$DATA(RAMSG)
GOTO COPY4
+3 SET RAXIT=1
WRITE !!,$CHAR(7),"Error encountered while in adding rec ",RA3," to sub-file 70.11"
QUIT
KIL5 SET RA3=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RA1,"DX",RA3))
if RA3=""
GOTO COPY5
+1 SET DA=RA3
+2 SET DIK="^RADPT("_DA(3)_",""DT"","_DA(2)_",""P"","_DA(1)_",""DX"","
+3 DO ^DIK
+4 GOTO KIL5
COPY5 KILL RAFDA,RAIEN,RAMSG
SET RA3=$ORDER(RA1SD(RA3))
if 'RA3
QUIT
if RAXIT
QUIT
UP5 ;
+1 SET RAFDA(70.14,"?+2,"_RA2_",",.01)=RA1SD(RA3)
+2 DO UPDATE^DIE("","RAFDA","RAIEN","RAMSG")
if '$DATA(RAMSG)
GOTO COPY5
+3 SET RAXIT=1
WRITE !!,$CHAR(7),"Error encountered while in adding rec ",RA3," to sub-file 70.14"
QUIT
COPYREF ; clear out Fileman vars and quit
+1 KILL DA,DIK
+2 ; don't need to re-xref again
QUIT
Q KILL DA
QUIT
+1 ;
SILENT() ;ask to include canceled cases if interactive
+1 ;RARIC: set in CREATE^RARIC
+2 ;RAQUIET: set in the RIS' HL7 bridge routine
+3 if $GET(RARIC)!($DATA(RAQUIET))
QUIT 0
+4 QUIT 1
+5 ;
ASK() ;include canceled case in report?
+1 NEW DIRUT,DUOUT,DTOUT,DIR,X,Y,RAX
+2 SET DIR(0)="Y"
SET DIR("B")="No"
+3 SET DIR("A",1)="Case "_+$PIECE(RAO1(0),U)_" on this printset has been canceled."
+4 SET DIR("A")="Do you want to include it in the report anyway"
DO ^DIR
+5 IF $DATA(DIRUT)
SET Y=-1
+6 SET RAX=$SELECT(Y=1:"In",1:"Ex")_"clude case "_+$PIECE(RAO1(0),U)
+7 WRITE !!,RAX
+8 ;'1' for yes, '0' for no
QUIT Y
+9 ;
OWNSKEY() ;does this user have the RA MGR key?
+1 ;Input variable: none; DUZ must be defined
+2 ;Output: BOOL(0) - Returns a subscripted output where
+3 ; 1 - User owns key.
+4 ; 0 - DUZ not defined or key not found.
+5 ;
+6 if $DATA(DUZ)#2=0
QUIT 0
+7 NEW BOOL
DO OWNSKEY^XUSRB(.BOOL,"RA MGR",DUZ)
+8 QUIT BOOL(0)
+9 ;
