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

RAUTL13.m

Go to the documentation of this file.
  1. RAUTL13 ;HISC/CAH-Utility OMA Loc selector, Pt Loc change, Submit-to loc scrn ; Oct 12, 2022@10:15:27
  1. ;;5.0;Radiology/Nuclear Medicine;**194**;Mar 16, 1998;Build 1
  1. ;
  1. ;Routine/Global IA Type
  1. ;-------------------------------------------
  1. ;^XUSEC(sec. key name,DUZ) 10076 (S)
  1. ;
  1. IPOP ;Determine if current pt loc is different than requesting loc
  1. ;INPUT VARIABLES:
  1. ; RAORD0=Zeroeth node of order record from file 75.1
  1. ;OUTPUT VARIABLES:
  1. ; RALOCN=Name of current loc (or 'UNKNOWN' if not definable)
  1. ; RARLOCN=Defined only if requesting loc different from current loc.
  1. ; Value is Name of requesting loc
  1. ;To update pt loc, get requesting loc, determine if IP or OP
  1. ;RARLOC=IEN of req'g loc in File 44, RARLOCN=Req'g loc name
  1. ;RARIPOP="I" if inpatient req. loc, "O" if outpatient req. loc
  1. S RARLOC=+$P(RAORD0,U,22),RARLOCN=$S($D(^SC(RARLOC,0)):$P(^(0),"^"),1:"UNKNOWN")
  1. K RARIPOP S X=$G(^SC(RARLOC,42)) S RARIPOP=$S($L($G(^DIC(42,+X,0))):"I",1:"O")
  1. ;RAIPLOC=IEN of Inp Loc in File 42, RAIPLOCN=Name of Inp Loc
  1. ;RACIPOP="I" if currently inpatient, or "O" if currently Outpatient
  1. S DFN=RADFN D INP^VADPT S RAIPLOC=$P($G(VAIN(4)),U,1),RAIPLOCN=$P($G(VAIN(4)),U,2),RACIPOP=$S($L(RAIPLOC):"I",1:"O"),RAIN44=+$G(^DIC(42,+RAIPLOC,44))
  1. I '$L(RAIPLOC) D OP G IPOPQ ;If pt currently outp
  1. ;Continue only if patient currently inp.
  1. I RAIN44'=RARLOC S RALOCN=RAIPLOCN G IPOPQ ;if loc change
  1. I RAIN44=RARLOC S RALOCN=RAIPLOCN K RARLOCN G IPOPQ ;if no change
  1. Q
  1. OP I RARIPOP="O",RACIPOP="O" S RALOCN=RARLOCN K RAIPLOCN,RAIPLOC,RARLOCN Q
  1. I RARIPOP="I",RACIPOP="O" S RALOCN="DISCHARGED"
  1. Q
  1. IPOPQ K RAIN44,RAIPLOC,VAIN,RAIPLOCN,RACIPOP,RARIPOP,RARLOC,RALOC,X
  1. Q
  1. ;
  1. OMA ;Select One/Many/All locations within current imaging type p194
  1. ;INPUT VARIABLES:
  1. ; RACCESS array must be defined if imaging location
  1. ; access is to be screened. Otherwise, use gets to choose from
  1. ; all imaging locations
  1. ; RAIMGTY must be defined if imaging locations access is to be
  1. ; screened by sign-on imaging type
  1. ; RANOSCRN - if defned no screening is done regardless of whether
  1. ; RAIMGTY and RACCESS are defined
  1. ; RAOPT("SCH") optional: iff 'Log of Scheduled Requests by Procedure' [RA ORDERLOG]
  1. ; entry (set)/exit (killed) action on option
  1. ; RAOPT("P/H") optional: iff 'Pending/Hold Rad/Nuc Med Request Log' [RA ORDERPENDING]
  1. ; entry (set)/exit (killed) action on option
  1. ;OUTPUT VARIABLES:
  1. ; RALOC(Rad loc name, IEN of 79.1) array
  1. ;
  1. ;Note: 'Log of Scheduled Requests by Procedure' calls RAPSET so RACCESS array & RAIMGTY will be defined.
  1. ;I '$D(RACCESS(DUZ,"LOC")) W !,"You do not have access to any Imaging Locations. See your ADPAC." K DIR S DIR(0)="E" D ^DIR K DIR S RAQUIT=1 G Q
  1. K ^TMP($J,"RADLOCS")
  1. ;If user can access more than one loc of current imaging type,
  1. ;prompt user to select loc(s)
  1. I '$G(RALOC1) D ;<--- I have access to only one location (rad) and I am still allowed to select more than one rad i-loc
  1. .;even pending/hold, when one loc assigned, allows me to select all imaging locations p194
  1. .N RAARRY,RADIC,RAUTIL
  1. .S RADIC="^RA(79.1,",(RAARRY,RAUTIL)="RADLOCS",RADIC(0)="QEAMZ"
  1. .S RADIC("A")="Select Imaging Location(s): "
  1. .I $D(RAIMGTY),'$D(RANOSCRN) D ;hit by SCHEDULE LOG i-type always defined p194
  1. ..S RADIC("S")="N RA0791 S RA0791=$G(^RA(79.1,+Y,0)) I $P(RA0791,U,6)=+$O(^RA(79.2,""B"",RAIMGTY,0))"
  1. ..I $D(RAOPT("SCH"))#2,('$D(^XUSEC("RA ALLOC",DUZ))#2) S RADIC("S")=RADIC("S")_",($P(RA0791,U,19)="""")"
  1. ..Q
  1. .;pending/hold access all i-loc regardless of modality but check user for RA ALLOC
  1. .;No RA ALLOC? Disallow inactive locs. If RA ALLOC allow active/inactive i-locs
  1. .;to be selected p194
  1. .I $D(RANOSCRN)#2,($D(RAOPT("P/H"))#2),('$D(^XUSEC("RA ALLOC",DUZ))#2) D
  1. ..S RADIC("S")="N RA0791 S RA0791=$G(^RA(79.1,+Y,0)) I $P(RA0791,U,19)="""""
  1. ..Q
  1. .D EN1^RASELCT(.RADIC,RAUTIL,RAARRY)
  1. .Q
  1. S I="" F S I=$O(^TMP($J,"RADLOCS",I)) Q:I="" S J="" F S J=$O(^TMP($J,"RADLOCS",I,J)) Q:J="" S RALOC(I,J)=""
  1. Q K I,J,RADIC,RAUTIL,RAARRY,^TMP($J,"RADLOCS")
  1. Q
  1. SUBMIT(DA,Y) ;Called from file 75.1, field 20 (imaging location) screen
  1. ; returns 1 if location being screened has same imaging type as
  1. ; procedure ordered.
  1. ; DA is the IEN of file 75.1, Y is the IEN of the entry in file
  1. ; 79.1 that is being screened.
  1. Q:$P($G(^RA(79.1,+Y,0)),U,19)]"" 0 ; inactive location
  1. N RALOC,RALOCI,RAPROC,RAPROCI
  1. S RALOC=$G(^RA(79.1,+Y,0))
  1. S RALOCI=$G(^RA(79.2,$P(RALOC,U,6),0)) I '$L(RALOCI) Q 0
  1. S RAPROC=+$P($G(^RAO(75.1,DA,0)),U,2),RAPROCI=+$P($G(^RAMIS(71,RAPROC,0)),U,12)
  1. I RAPROCI=$P(RALOC,U,6) Q 1
  1. Q 0
  1. SUBMITQ(DA,Y) ;Called from file 71.3, field 8 (imaging location) screen
  1. ; returns 1 if location being screened has same imaging type as
  1. ; the common procedure.
  1. ; DA is the IEN of file 71.3, Y is the IEN of the entry in file
  1. ; 79.1 that is being screened.
  1. N RALOC,RALOCI,RAPROC,RAPROCI
  1. S RALOC=$G(^RA(79.1,+Y,0)) Q:$P(RALOC,"^",19)]"" 0 ; inactive location
  1. S RALOCI=$G(^RA(79.2,+$P(RALOC,U,6),0)) I '$L(RALOCI) Q 0
  1. S RAPROC=+$P($G(^RAMIS(71.3,DA,0)),U)
  1. S RAPROCI=+$P($G(^RAMIS(71,RAPROC,0)),U,12)
  1. I RAPROCI=$P(RALOC,U,6) Q 1
  1. Q 0
  1. INLO(X) ; Determine if the Imaging Location is inactive
  1. ; Pass in the IEN of the Imaging Location (most of the time +RAMLC)
  1. ; Pass back '1' if inactive, '0' if active.
  1. Q $S($P($G(^RA(79.1,+X,0)),U,19)']"":0,1:1)
  1. ;
  1. OPTCHK() ;check if one of the two options listed below:
  1. ; 'Log of Scheduled Requests by Procedure' -or-
  1. ; 'Pending/Hold Rad/Nuc Med Request Log' invoke
  1. ; this sub-routine. p194
  1. ;returns:
  1. ; 0 if either option in the comments invokes OPTCHK
  1. ; else 1
  1. ;
  1. Q $S($D(RAOPT("SCH"))#2:0,$D(RAOPT("P/H"))#2:0,1:1)