RAUTL20 ;HISC/SWM-Utility Routine ;6/16/97 14:27 [ 12/05/2011 9:33 AM ]
;;5.0;Radiology/Nuclear Medicine;**5,34,47*1004**;Mar 16, 1998;Build 21
;
EN1 ; for displaying + and . during case lookup
S RAPRTSET=0
Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI))
Q:RADFN=""!(RADTI="")!(RACNI="")
; output : RAPRTSET=1 : case is part of a combined PRINTset, & flag it
; RAMEMLOW=1 : case is lowest ien of print set AND flag it
N RA1,RA2,RA3,RA4,RA5,RA6,RA7,RACN S RA1="",RA3="A",RA5=0
S RACN=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
S RAMEMLOW=0
S RAPRTSET=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^",25)=2
Q:'RAPRTSET
; put + infront of lowest ien of case that has MEMBER OF SET = 2
F S RA1=$O(^RADPT(RADFN,"DT",RADTI,"P",RA1)) Q:RA1="" Q:$P($G(^(RA1,0)),U,25)=2 ; RA1 is at lowest ien with MEMBER OF SET = 2
S:RACNI=RA1 RAMEMLOW=1
S RA1="" F S RA1=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RA1)) Q:RA1="" D LOOP1
I RA5 S RAPRTSET=0,RAMEMLOW=0 ;don't display if ptrs to #74 differ within set
Q
LOOP1 ; RA1= : for-loop var which happens to be the CASE NUMBER (70.03; .01)
; RA2= : (1) ien for 70.03 (2) also, pointer value to file #74
; RA3= : holds earliest case with pointer value to file #74
; RA4= : (ienof #70.03)=case number^procedure pointers^ptr #74
; RA5=0 : all cases in set point to same non-null rarpt() or all null
; regardless of cancelled status
; RA5<>0: one or more cases in set point to different rarpt()
; RA6= : pointer to file #72 examination status
; RA7=1 : denote call of LOOP1 came from EN2 and not from EN1
S RA2=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RA1,0))
; skip rec if it's not part of combined report
Q:$P(^RADPT(RADFN,"DT",RADTI,"P",RA2,0),"^",25)'=2
N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RA2)
S RACNDSP=$S((RASSAN'=""):RASSAN,1:RA1)
;
I $$USESSAN^RAHLRU1() S:$G(RA7) RA4=RA2,RA4(RA4)=RACNDSP
I '$$USESSAN^RAHLRU1() S:$G(RA7) RA4=RA2,RA4(RA4)=RA1
S RA2=$P(^RADPT(RADFN,"DT",RADTI,"P",RA2,0),"^",17),RA6=$P(^(0),"^",3) S:$G(RA7) RA4(RA4)=RA4(RA4)_"^"_$P(^(0),"^",2)_"^"_$P(^(0),"^",17)_"^"_$P(^(0),"^",3)
; skip if exm canc'd & exm's pc 17 is null
I $P($G(^RA(72,+RA6,0)),"^",3)=0,RA2="" Q
S:RA3="A" RA3=RA2
I RA5=0,RA2]"" S RA5=RA2-RA3
Q
EN2(RA4) ; display all print members' procs during report editing/printg
S RAPRTSET=0
Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI))
Q:RADFN=""!(RADTI="")!(RACNI="")
; output : RA4(IEN OF #70.03)=CASE NUMBER^IEN OF #71 (procedure)^ptr #74
; ^exm stat
; RAPRTSET = 1 : case is part of a combined PRINTset
N RA1,RA2,RA3,RA5,RA6,RA7 S RA1="",RA3="A",RA5=0,RA7=1
F S RA1=$O(RA4(RA1)) Q:RA1="" K RA4(RA1) ;clean up array
S RAPRTSET=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^",25)=2
Q:'RAPRTSET
F S RA1=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RA1)) Q:RA1="" D LOOP1
I RA5 S RAPRTSET=0 ;don't display if ptrs to #74 differ within set
Q
EN3(RA4) ; for print set, AFTER record is created in rarpt()
Q:'$D(RADFN)!('$D(RADTI))
Q:RADFN=""!(RADTI="")
; output :RA4(IEN OF #70.03)=CASE NUMBER (ONLY THOSE CASES FROM #74.05)
N RA1,RA2,RA3,RA5 S RA1="",RA3="A"
F S RA1=$O(RA4(RA1)) Q:RA1="" K RA4(RA1) ;clean up array
S RA5=$S($G(RARPT):RARPT,$G(RAIEN):RAIEN,1:0) Q:RA5=0
;Careful; Here RA1 is the accession #. Format: 081809-12345 -or- 578-081809-12345
;
;IHS/CMI/DAY - Patch 1004 - Avoid SBSCR error with delete from RARTE2
;F S RA1=$O(^RARPT(RA5,1,"B",RA1)) Q:RA1="" S RA2=$P(RA1,"-",$L(RA1,"-")),RA3=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RA2,0)),RA4(RA3)=RA2
F S RA1=$O(^RARPT(RA5,1,"B",RA1)) Q:RA1="" S RA2=$P(RA1,"-",$L(RA1,"-")),RA3=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RA2,0)) I RA3 S RA4(RA3)=RA2
;End Patch
;
Q
XPRI ;loop thru sub-file #74.05 to set/kill prim. xref for other prt members
Q:'$D(RADFNZ)!('$D(RADTIZ))!('$D(RARAD))!('$D(RAXREF))!('$D(DA))
Q:$O(^RARPT(DA,1,"B",0))=""
N RA1,RA200 S RA1=""
XPRI1 S RA1=$O(^RARPT(DA,1,"B",RA1)) Q:RA1=""
;S RACNIZ=$O(^RADPT(RADFNZ,"DT",RADTIZ,"P","B",$P(RA1,"-",2),0))
S RACNIZ=$O(^RADPT(RADFNZ,"DT",RADTIZ,"P","B",$P(RA1,"-",$L(RA1,"-")),0)) ;Set RACNIZ=last piece of RA1, not 2nd piece after P47 SSAN changes
G:'$D(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,0)) XPRI1 S RA200=+$P(^(0),"^",RARADOLD) ; use raradold to get piece number in "p" node
G XPRI1:'RA200
S:$D(RASET) ^RARPT(RAXREF,RA200,DA)=""
K:$D(RAKILL) ^RARPT(RAXREF,RA200,DA)
G XPRI1
XSEC ;loop thru sub-file #74.05 to set/kill sec. xref for other print members
Q:'$D(RADFNZ)!('$D(RADTIZ))!('$D(RASECOND))!('$D(RAXREF))!('$D(DA))
Q:$O(^RARPT(DA,1,"B",0))=""
N RA1,RA2,RA200 S RA1=""
XSEC1 S RA1=$O(^RARPT(DA,1,"B",RA1)) Q:RA1=""
;S RACNIZ=$O(^RADPT(RADFNZ,"DT",RADTIZ,"P","B",$P(RA1,"-",2),0))
S RACNIZ=$O(^RADPT(RADFNZ,"DT",RADTIZ,"P","B",$P(RA1,"-",$L(RA1,"-")),0))
G:'$D(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,0)) XSEC1 G:'$D(^(RASECOND,0)) XSEC1
S RA2=0
XSEC2 S RA2=$O(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,RASECOND,RA2)) G:'+RA2 XSEC1 S RA200=+$G(^(RA2,0))
G:'RA200 XSEC2
S:$D(RASET) ^RARPT(RAXREF,RA200,DA)=""
K:$D(RAKILL) ^RARPT(RAXREF,RA200,DA)
G XSEC2
FLAGMEM() ;in distr list, print + if case is part of a print set
; called from File #74's print templates
N RA1 S RA1=""
I '$D(D0) Q RA1
S RA1=$P($G(^RABTCH(74.4,D0,0)),U) I RA1="" Q RA1
S RA1=$O(^RARPT(RA1,1,"B",0)) S:RA1]"" RA1="+"
Q RA1
DELPNT(RADFN,RADTI,RACNI) ; When an exam is cancelled & it is associated
; with data in the Nuc Med Exam Data file (70.2) ask the user if this
; pointer to 70.2 is to be deleted. Also delete the flag which
; indicates that the dosage ticket had printed for this exam.
; Called from CANCEL^RAEDCN
; Input: RADFN - Internal Entry Number (IEN) of the Patient.
; RADTI - Date/Time of the examination (inverse format)
; RACNI - IEN of the exam for this date/time
;
;- Delete entry in 'Dosage Ticket Printed?' field DD: 70.03, field: 29 -
N RAFDA S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",29)="@"
D FILE^DIE("","RAFDA")
;----------------------------------------------------------------------
Q:'+$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",28) ;no NucMed Xam data
K RAFDA N RAYN
F D Q:RAYN]""
. R !!?3,"Do you wish to delete the radiopharmaceutical data associated",!?3,"with this exam? No//",RAYN:DTIME
. I RAYN["^"!('$T) S RAYN="^" Q ;don't delete pntr if '^' or timeout
. S RAYN=$E(RAYN) S:RAYN="" RAYN="N"
. S RAYN=$$UP^XLFSTR(RAYN) Q:RAYN="N" ;exit, don't del 70.2 pnt
. I RAYN="Y" D Q ; delete the pointer to 70.2, then quit
.. N RAFDA S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",500)="@"
.. D FILE^DIE("","RAFDA")
.. ; NOTE: This silent FileMan call not only deletes the pointer to
.. ; the entry in the Nuc Med Exam Data file (70.2), but the
.. ; entry in 70.2 itself. This is because a M X-Ref exists on
.. ; the field which points to file 70.2 that also deletes the
.. ; entry in the Nuc Med Exam Data file. Please refer to
.. ; ^DD(70.03,500,.. for more information.
.. Q
. W !!?3,"Enter 'Yes' to delete the radiopharmaceutical data associated with this exam.",!?3,"Enter 'No' to preserve the radiopharmaceutical data associated with this",!?3,"exam. "
. W "Enter '^' to exit without deleting the radiopharmaceutical data",!?3,"associated with this exam.",$C(7)
. S RAYN=""
. Q
Q
RAUTL20 ;HISC/SWM-Utility Routine ;6/16/97 14:27 [ 12/05/2011 9:33 AM ]
+1 ;;5.0;Radiology/Nuclear Medicine;**5,34,47*1004**;Mar 16, 1998;Build 21
+2 ;
EN1 ; for displaying + and . during case lookup
+1 SET RAPRTSET=0
+2 IF '$DATA(RADFN)!('$DATA(RADTI))!('$DATA(RACNI))
QUIT
+3 IF RADFN=""!(RADTI="")!(RACNI="")
QUIT
+4 ; output : RAPRTSET=1 : case is part of a combined PRINTset, & flag it
+5 ; RAMEMLOW=1 : case is lowest ien of print set AND flag it
+6 NEW RA1,RA2,RA3,RA4,RA5,RA6,RA7,RACN
SET RA1=""
SET RA3="A"
SET RA5=0
+7 SET RACN=+$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+8 SET RAMEMLOW=0
+9 SET RAPRTSET=$PIECE($GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^",25)=2
+10 IF 'RAPRTSET
QUIT
+11 ; put + infront of lowest ien of case that has MEMBER OF SET = 2
+12 ; RA1 is at lowest ien with MEMBER OF SET = 2
FOR
SET RA1=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RA1))
IF RA1=""
QUIT
IF $PIECE($GET(^(RA1,0)),U,25)=2
QUIT
+13 IF RACNI=RA1
SET RAMEMLOW=1
+14 SET RA1=""
FOR
SET RA1=$ORDER(^RADPT(RADFN,"DT",RADTI,"P","B",RA1))
IF RA1=""
QUIT
DO LOOP1
+15 ;don't display if ptrs to #74 differ within set
IF RA5
SET RAPRTSET=0
SET RAMEMLOW=0
+16 QUIT
LOOP1 ; RA1= : for-loop var which happens to be the CASE NUMBER (70.03; .01)
+1 ; RA2= : (1) ien for 70.03 (2) also, pointer value to file #74
+2 ; RA3= : holds earliest case with pointer value to file #74
+3 ; RA4= : (ienof #70.03)=case number^procedure pointers^ptr #74
+4 ; RA5=0 : all cases in set point to same non-null rarpt() or all null
+5 ; regardless of cancelled status
+6 ; RA5<>0: one or more cases in set point to different rarpt()
+7 ; RA6= : pointer to file #72 examination status
+8 ; RA7=1 : denote call of LOOP1 came from EN2 and not from EN1
+9 SET RA2=$ORDER(^RADPT(RADFN,"DT",RADTI,"P","B",RA1,0))
+10 ; skip rec if it's not part of combined report
+11 IF $PIECE(^RADPT(RADFN,"DT",RADTI,"P",RA2,0),"^",25)'=2
QUIT
+12 NEW RASSAN,RACNDSP
SET RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RA2)
+13 SET RACNDSP=$SELECT((RASSAN'=""):RASSAN,1:RA1)
+14 ;
+15 IF $$USESSAN^RAHLRU1()
IF $GET(RA7)
SET RA4=RA2
SET RA4(RA4)=RACNDSP
+16 IF '$$USESSAN^RAHLRU1()
IF $GET(RA7)
SET RA4=RA2
SET RA4(RA4)=RA1
+17 SET RA2=$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RA2,0),"^",17)
SET RA6=$PIECE(^(0),"^",3)
IF $GET(RA7)
SET RA4(RA4)=RA4(RA4)_"^"_$PIECE(^(0),"^",2)_"^"_$PIECE(^(0),"^",17)_"^"_$PIECE(^(0),"^",3)
+18 ; skip if exm canc'd & exm's pc 17 is null
+19 IF $PIECE($GET(^RA(72,+RA6,0)),"^",3)=0
IF RA2=""
QUIT
+20 IF RA3="A"
SET RA3=RA2
+21 IF RA5=0
IF RA2]""
SET RA5=RA2-RA3
+22 QUIT
EN2(RA4) ; display all print members' procs during report editing/printg
+1 SET RAPRTSET=0
+2 IF '$DATA(RADFN)!('$DATA(RADTI))!('$DATA(RACNI))
QUIT
+3 IF RADFN=""!(RADTI="")!(RACNI="")
QUIT
+4 ; output : RA4(IEN OF #70.03)=CASE NUMBER^IEN OF #71 (procedure)^ptr #74
+5 ; ^exm stat
+6 ; RAPRTSET = 1 : case is part of a combined PRINTset
+7 NEW RA1,RA2,RA3,RA5,RA6,RA7
SET RA1=""
SET RA3="A"
SET RA5=0
SET RA7=1
+8 ;clean up array
FOR
SET RA1=$ORDER(RA4(RA1))
IF RA1=""
QUIT
KILL RA4(RA1)
+9 SET RAPRTSET=$PIECE($GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^",25)=2
+10 IF 'RAPRTSET
QUIT
+11 FOR
SET RA1=$ORDER(^RADPT(RADFN,"DT",RADTI,"P","B",RA1))
IF RA1=""
QUIT
DO LOOP1
+12 ;don't display if ptrs to #74 differ within set
IF RA5
SET RAPRTSET=0
+13 QUIT
EN3(RA4) ; for print set, AFTER record is created in rarpt()
+1 IF '$DATA(RADFN)!('$DATA(RADTI))
QUIT
+2 IF RADFN=""!(RADTI="")
QUIT
+3 ; output :RA4(IEN OF #70.03)=CASE NUMBER (ONLY THOSE CASES FROM #74.05)
+4 NEW RA1,RA2,RA3,RA5
SET RA1=""
SET RA3="A"
+5 ;clean up array
FOR
SET RA1=$ORDER(RA4(RA1))
IF RA1=""
QUIT
KILL RA4(RA1)
+6 SET RA5=$SELECT($GET(RARPT):RARPT,$GET(RAIEN):RAIEN,1:0)
IF RA5=0
QUIT
+7 ;Careful; Here RA1 is the accession #. Format: 081809-12345 -or- 578-081809-12345
+8 ;
+9 ;IHS/CMI/DAY - Patch 1004 - Avoid SBSCR error with delete from RARTE2
+10 ;F S RA1=$O(^RARPT(RA5,1,"B",RA1)) Q:RA1="" S RA2=$P(RA1,"-",$L(RA1,"-")),RA3=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RA2,0)),RA4(RA3)=RA2
+11 FOR
SET RA1=$ORDER(^RARPT(RA5,1,"B",RA1))
IF RA1=""
QUIT
SET RA2=$PIECE(RA1,"-",$LENGTH(RA1,"-"))
SET RA3=$ORDER(^RADPT(RADFN,"DT",RADTI,"P","B",RA2,0))
IF RA3
SET RA4(RA3)=RA2
+12 ;End Patch
+13 ;
+14 QUIT
XPRI ;loop thru sub-file #74.05 to set/kill prim. xref for other prt members
+1 IF '$DATA(RADFNZ)!('$DATA(RADTIZ))!('$DATA(RARAD))!('$DATA(RAXREF))!('$DATA(DA))
QUIT
+2 IF $ORDER(^RARPT(DA,1,"B",0))=""
QUIT
+3 NEW RA1,RA200
SET RA1=""
XPRI1 SET RA1=$ORDER(^RARPT(DA,1,"B",RA1))
IF RA1=""
QUIT
+1 ;S RACNIZ=$O(^RADPT(RADFNZ,"DT",RADTIZ,"P","B",$P(RA1,"-",2),0))
+2 ;Set RACNIZ=last piece of RA1, not 2nd piece after P47 SSAN changes
SET RACNIZ=$ORDER(^RADPT(RADFNZ,"DT",RADTIZ,"P","B",$PIECE(RA1,"-",$LENGTH(RA1,"-")),0))
+3 ; use raradold to get piece number in "p" node
IF '$DATA(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,0))
GOTO XPRI1
SET RA200=+$PIECE(^(0),"^",RARADOLD)
+4 IF 'RA200
GOTO XPRI1
+5 IF $DATA(RASET)
SET ^RARPT(RAXREF,RA200,DA)=""
+6 IF $DATA(RAKILL)
KILL ^RARPT(RAXREF,RA200,DA)
+7 GOTO XPRI1
XSEC ;loop thru sub-file #74.05 to set/kill sec. xref for other print members
+1 IF '$DATA(RADFNZ)!('$DATA(RADTIZ))!('$DATA(RASECOND))!('$DATA(RAXREF))!('$DATA(DA))
QUIT
+2 IF $ORDER(^RARPT(DA,1,"B",0))=""
QUIT
+3 NEW RA1,RA2,RA200
SET RA1=""
XSEC1 SET RA1=$ORDER(^RARPT(DA,1,"B",RA1))
IF RA1=""
QUIT
+1 ;S RACNIZ=$O(^RADPT(RADFNZ,"DT",RADTIZ,"P","B",$P(RA1,"-",2),0))
+2 SET RACNIZ=$ORDER(^RADPT(RADFNZ,"DT",RADTIZ,"P","B",$PIECE(RA1,"-",$LENGTH(RA1,"-")),0))
+3 IF '$DATA(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,0))
GOTO XSEC1
IF '$DATA(^(RASECOND,0))
GOTO XSEC1
+4 SET RA2=0
XSEC2 SET RA2=$ORDER(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,RASECOND,RA2))
IF '+RA2
GOTO XSEC1
SET RA200=+$GET(^(RA2,0))
+1 IF 'RA200
GOTO XSEC2
+2 IF $DATA(RASET)
SET ^RARPT(RAXREF,RA200,DA)=""
+3 IF $DATA(RAKILL)
KILL ^RARPT(RAXREF,RA200,DA)
+4 GOTO XSEC2
FLAGMEM() ;in distr list, print + if case is part of a print set
+1 ; called from File #74's print templates
+2 NEW RA1
SET RA1=""
+3 IF '$DATA(D0)
QUIT RA1
+4 SET RA1=$PIECE($GET(^RABTCH(74.4,D0,0)),U)
IF RA1=""
QUIT RA1
+5 SET RA1=$ORDER(^RARPT(RA1,1,"B",0))
IF RA1]""
SET RA1="+"
+6 QUIT RA1
DELPNT(RADFN,RADTI,RACNI) ; When an exam is cancelled & it is associated
+1 ; with data in the Nuc Med Exam Data file (70.2) ask the user if this
+2 ; pointer to 70.2 is to be deleted. Also delete the flag which
+3 ; indicates that the dosage ticket had printed for this exam.
+4 ; Called from CANCEL^RAEDCN
+5 ; Input: RADFN - Internal Entry Number (IEN) of the Patient.
+6 ; RADTI - Date/Time of the examination (inverse format)
+7 ; RACNI - IEN of the exam for this date/time
+8 ;
+9 ;- Delete entry in 'Dosage Ticket Printed?' field DD: 70.03, field: 29 -
+10 NEW RAFDA
SET RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",29)="@"
+11 DO FILE^DIE("","RAFDA")
+12 ;----------------------------------------------------------------------
+13 ;no NucMed Xam data
IF '+$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",28)
QUIT
+14 KILL RAFDA
NEW RAYN
+15 FOR
Begin DoDot:1
+16 READ !!?3,"Do you wish to delete the radiopharmaceutical data associated",!?3,"with this exam? No//",RAYN:DTIME
+17 ;don't delete pntr if '^' or timeout
IF RAYN["^"!('$TEST)
SET RAYN="^"
QUIT
+18 SET RAYN=$EXTRACT(RAYN)
IF RAYN=""
SET RAYN="N"
+19 ;exit, don't del 70.2 pnt
SET RAYN=$$UP^XLFSTR(RAYN)
IF RAYN="N"
QUIT
+20 ; delete the pointer to 70.2, then quit
IF RAYN="Y"
Begin DoDot:2
+21 NEW RAFDA
SET RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",500)="@"
+22 DO FILE^DIE("","RAFDA")
+23 ; NOTE: This silent FileMan call not only deletes the pointer to
+24 ; the entry in the Nuc Med Exam Data file (70.2), but the
+25 ; entry in 70.2 itself. This is because a M X-Ref exists on
+26 ; the field which points to file 70.2 that also deletes the
+27 ; entry in the Nuc Med Exam Data file. Please refer to
+28 ; ^DD(70.03,500,.. for more information.
+29 QUIT
End DoDot:2
QUIT
+30 WRITE !!?3,"Enter 'Yes' to delete the radiopharmaceutical data associated with this exam.",!?3,"Enter 'No' to preserve the radiopharmaceutical data associated with this",!?3,"exam. "
+31 WRITE "Enter '^' to exit without deleting the radiopharmaceutical data",!?3,"associated with this exam.",$CHAR(7)
+32 SET RAYN=""
+33 QUIT
End DoDot:1
IF RAYN]""
QUIT
+34 QUIT
