Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RAUTL20

RAUTL20.m

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