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

RAREG3.m

Go to the documentation of this file.
  1. RAREG3 ;HISC/CAH,DAD,FPT,GJC-Register Rad/NM Patient (cont.) ;24 Jul 2019 9:18 AM
  1. ;;5.0;Radiology/Nuclear Medicine;**8,137,144,154,157**;Mar 16, 1998;Build 2
  1. ;Supported IA #10076 ^XUSEC(
  1. ;
  1. RSBIT ; renumber selections by imaging type
  1. ; The RAORDS array has the list of orders the user selected to register
  1. ; in the order the user entered them. This subroutine will reorganize
  1. ; the array so the orders are arranged by imaging type of their
  1. ; procedure starting with the imaging type the user is currently signed
  1. ; on with followed by the ascending internal entry number of the
  1. ; remaining imaging types.
  1. ;
  1. Q:'$D(RAORDS)
  1. K RALOOP,RAORDST
  1. F RALOOP=1:1 Q:'$D(RAORDS(RALOOP)) D
  1. .S RAON=+$P(RAORDS(RALOOP),U,1) Q:'RAON
  1. .S RAPN=+$P(^RAO(75.1,RAON,0),U,2) Q:'RAPN
  1. .S RAIN=+$P(^RAMIS(71,RAPN,0),U,12) Q:'RAIN
  1. .S RAORDST(RAIN,RALOOP)=RAON
  1. .Q
  1. S RAIMGTYN=+$O(^RA(79.2,"B",RAIMGTY,0)) Q:'RAIMGTYN
  1. K RAORDS S (RALOOP,RAIN)=0
  1. I $D(RAORDST(RAIMGTYN)) F S RAIN=$O(RAORDST(RAIMGTYN,RAIN)) Q:'RAIN S RALOOP=RALOOP+1,RAORDS(RALOOP)=+RAORDST(RAIMGTYN,RAIN) K RAORDST(RAIMGTYN,RAIN)
  1. I $D(RAORDST) S RAIMGTYN=0 F S RAIMGTYN=$O(RAORDST(RAIMGTYN)) Q:'RAIMGTYN S RAIN=0 F S RAIN=$O(RAORDST(RAIMGTYN,RAIN)) Q:'RAIN S RALOOP=RALOOP+1,RAORDS(RALOOP)=+RAORDST(RAIMGTYN,RAIN)
  1. K RAIMGTYN,RAIN,RALOOP,RAON,RAORDST,RAPN
  1. Q
  1. SETDISV ; when registering procedures of different imaging types set imaging
  1. ; location default value in DIC("B") if only one location associated with
  1. ; imaging type.
  1. N RACNT,RAITNHLD,RAITNXT,RALOOP
  1. S (RACNT,RAITNXT)=0
  1. F RALOOP=0:0 S RAITNXT=$O(^RA(79.1,"BIMG",RAITN,RAITNXT)) Q:'RAITNXT S RACNT=RACNT+1,RAITNHLD=RAITNXT
  1. ;I RACNT=1 S ^DISV(+DUZ,"^RA(79.1,")=RAITNHLD
  1. I RACNT=1,RAITNHLD,$G(^RA(79.1,RAITNHLD,0))]"" S DIC("B")=$P($G(^SC(+^(0),0)),"^")
  1. Q
  1. SL ; switch locations
  1. ; Prompt the user to switch locations if the current sign-on imaging
  1. ; type does not match the procedure's imaging type.
  1. ; comment out 06/10/97 D EXAMSET^RAREG2 S RAPARENT=0
  1. S RAITN=$P(^RAMIS(71,+$P(Y,U,2),0),U,12)
  1. ;P154 Check switched to location until it's correct or ^ out
  1. ;p157 users holding the RA SWITCHLOC can proceed under different modality
  1. F Q:RAITN=+$O(^RA(79.2,"B",RAIMGTY,0))!(RAQUIT=1) D Q:($D(^XUSEC("RA SWITCHLOC",DUZ)))
  1. .S RAMLCHLD=RAMLC,RAYHOLD=Y,RAPROLOC=$P(^RA(79.2,RAITN,0),U,1),RAMDIVHD=RAMDIV
  1. .D LABEL
  1. .W !!?7,"Current Imaging Type: ",RAIMGTY
  1. .W !?5,"Procedure Imaging Type: ",RAPROLOC
  1. .W !!,"You must switch to a location of ",RAPROLOC," imaging type.",!!
  1. .D SETDISV
  1. .K RAMLC S RASWLOC=""
  1. .D SET^RAPSET1
  1. .K RASWLOC
  1. .I '$D(RAMLC) S RAQUIT=1,RAMLC=RAMLCHLD Q
  1. .I RAMDIVHD'=RAMDIV W !!,"You have switched Divisions from: ",$P(^DIC(4,+RAMDIVHD,0),U),!,?30,"to: ",$P(^DIC(4,+RAMDIV,0),U),!
  1. .D DT Q:RAQUIT
  1. .S Y=RAYHOLD
  1. .Q
  1. K RAITN,RAMDIVHD,RAMLCHLD,RAPROLOC,RAYHOLD
  1. Q
  1. DT ; prompt for new imaging date/time when imaging type changes
  1. Q:'$D(^RADPT(RADFN,"DT",RADTI,0))
  1. N RAHRS S RAHRS=+$P($G(^RA(79,+RAMDIV,.1)),"^",24) ;How many hrs in adv?
  1. R !!,"Imaging Exam Date/Time: NOW// ",X:DTIME
  1. I '$T!(X=" ")!(X="^") S RAQUIT=1 Q
  1. S:X="" RANOW="",X="NOW"
  1. I X="NOW" S RADTICHK=9999999.9999-($E($$NOW^XLFDT,1,12)) I $D(^RADPT(RADFN,"DT",RADTICHK,0)) D SUB1MIN K RADTICHK
  1. S %DT(0)=-$$FMADD^XLFDT($$NOW^XLFDT,0,RAHRS,0,0),%DT="ETXR"
  1. D ^%DT K %DT G DT:Y<0
  1. DT1 S RADTE=Y,RADTI=9999999.9999-RADTE I $D(^RADPT(RADFN,"DT",RADTI,0)) W !,$C(7),"Patient already has exams entered for this date/time.",!,"....use 'Add Exams to Last Visit' option." G DT
  1. DT2 K RADTEBAD S RADTEBAD=$O(^RADPT(RADFN,"DT","B",RADTE)) I RADTEBAD[RADTE D SUB1MIN S RADTE=X,RADTI=RADTICHK G DT2
  1. K RADTEBAD
  1. I $D(RANOW),$D(RAWARD) S RACAT="INPATIENT"
  1. I '$D(RANOW) K RAWARD,RABED,RASER D ^RASERV S:$D(RAWARD) RACAT="INPATIENT"
  1. Q
  1. SUB1MIN ; subtract 1 minute from NOW to get an unused date/time
  1. F RALOOP=1:1 S X=$$FMADD^XLFDT(RADTE,0,0,-RALOOP,0) S RADTICHK=9999999.9999-X Q:'$D(^RADPT(RADFN,"DT",RADTICHK,0))
  1. K RALOOP
  1. Q
  1. ;
  1. LABEL ; *** Print labels
  1. I $D(RAPX) D
  1. . W ! S RAPX=RADFN,RAZIS=1
  1. . S RASAV2=$G(^RADPT(+$G(RADFN),"DT",+$G(RADTI),0))
  1. . S RASAV3=$G(^RADPT(+$G(RADFN),"DT",+$G(RADTI),"P",$S($G(RACNI):RACNI,1:+$O(^RADPT(+$G(RADFN),"DT",+$G(RADTI),"P",0))),0))
  1. . D FLH^RAFLH K RANUMF
  1. . I $P(RAMDV,U,8) D JAC^RAJAC
  1. . S RADFN=RAPX K RAZIS
  1. . I $P($G(^DIC(195.4,1,"UP")),U,2) D ^RTQ5
  1. . K RAPX
  1. . Q
  1. Q
  1. ;
  1. PRNRQ ;Print Request at Registration - P137/KLM
  1. I '$D(RAORDS) Q ;no order array
  1. N RAJ,RAOIFN,RAILOC,RAION,RAARY,RAIENS
  1. S RAJ=0 F S RAJ=$O(RAORDS(RAJ)) Q:RAJ="" D
  1. .S RAOIFN=$G(RAORDS(RAJ)) Q:RAOIFN=""
  1. .S RAIENS=RADTI_","_RADFN_"," ;P144/KLM
  1. .S RAILOC=$$GET1^DIQ(70.02,RAIENS,4,"I") Q:RAILOC="" ;get i-loc from registered exam **changed from order /p144
  1. .S RAION=$$GET1^DIQ(79.1,RAILOC,28) Q:RAION="" ;Registered Request printer defined?
  1. .;Orders for registered exams may span modalities
  1. .;order status is active/registered - build RAARY(DEVICE NAME,ORDER IEN)
  1. .I $$GET1^DIQ(75.1,RAOIFN,5,"I")=6 S RAARY(RAION,RAOIFN)=""
  1. .;End RAJ loop on RAORDS
  1. ;Setup task vars for each reg req device with orders
  1. I $D(RAARY) D
  1. .S RAION="" F S RAION=$O(RAARY(RAION)) Q:RAION="" D
  1. ..N RAORS
  1. ..S ZTIO=RAION
  1. ..S RAOIFN=0 F S RAOIFN=$O(RAARY(RAION,RAOIFN)) Q:RAOIFN="" D
  1. ...S RAORS(RAOIFN)=""
  1. ...;End RAOIFN loop - Order IEN
  1. ..S ZTDESC="Rad/Nuc Med Registered Request Print"
  1. ..S ZTDTH=$H,ZTRTN="PRNRQ1^RAREG3"
  1. ..S ZTSAVE("RADFN")="",ZTSAVE("RAORS(")="" D ^%ZTLOAD
  1. ..K ZTIO,ZTDTH,ZTSAVE,ZTDESC,ZTRTN
  1. ..I $D(ZTSK) W !!,"Task "_ZTSK_": registered request(s) queued to print on device ",RAION,!
  1. ..;End RAION loop - Device Name
  1. .;End RAARY
  1. K RAORS,RAION,RAJ,RAILOC,RAARY,RAOIFN
  1. Q
  1. PRNRQ1 ;task entry point - P137
  1. N RAPAGE,RAX,RAOIFN
  1. S RAPAGE=0,RAX="" ;needed for ^RAORD5
  1. S RAOIFN=0 F S RAOIFN=$O(RAORS(RAOIFN)) Q:RAOIFN="" D
  1. .U IO D ^RAORD5
  1. K RAPAGE,RAX,RAOIFN
  1. Q