- 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 Feb 19, 2025@00:05:35 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 ;