| [613] | 1 | RAREG3 ;HISC/CAH,DAD,FPT,GJC-Register Rad/NM Patient (cont.) ;6/10/97 08:45
|
|---|
| 2 | ;;5.0;Radiology/Nuclear Medicine;**8**;Mar 16, 1998
|
|---|
| 3 | ;
|
|---|
| 4 | RSBIT ; renumber selections by imaging type
|
|---|
| 5 | ; The RAORDS array has the list of orders the user selected to register
|
|---|
| 6 | ; in the order the user entered them. This subroutine will reorganize
|
|---|
| 7 | ; the array so the orders are arranged by imaging type of their
|
|---|
| 8 | ; procedure starting with the imaging type the user is currently signed
|
|---|
| 9 | ; on with followed by the ascending internal entry number of the
|
|---|
| 10 | ; remaining imaging types.
|
|---|
| 11 | ;
|
|---|
| 12 | Q:'$D(RAORDS)
|
|---|
| 13 | K RALOOP,RAORDST
|
|---|
| 14 | F RALOOP=1:1 Q:'$D(RAORDS(RALOOP)) D
|
|---|
| 15 | .S RAON=+$P(RAORDS(RALOOP),U,1) Q:'RAON
|
|---|
| 16 | .S RAPN=+$P(^RAO(75.1,RAON,0),U,2) Q:'RAPN
|
|---|
| 17 | .S RAIN=+$P(^RAMIS(71,RAPN,0),U,12) Q:'RAIN
|
|---|
| 18 | .S RAORDST(RAIN,RALOOP)=RAON
|
|---|
| 19 | .Q
|
|---|
| 20 | S RAIMGTYN=+$O(^RA(79.2,"B",RAIMGTY,0)) Q:'RAIMGTYN
|
|---|
| 21 | K RAORDS S (RALOOP,RAIN)=0
|
|---|
| 22 | 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)
|
|---|
| 23 | 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)
|
|---|
| 24 | K RAIMGTYN,RAIN,RALOOP,RAON,RAORDST,RAPN
|
|---|
| 25 | Q
|
|---|
| 26 | SETDISV ; when registering procedures of different imaging types set imaging
|
|---|
| 27 | ; location default value in DIC("B") if only one location associated with
|
|---|
| 28 | ; imaging type.
|
|---|
| 29 | N RACNT,RAITNHLD,RAITNXT,RALOOP
|
|---|
| 30 | S (RACNT,RAITNXT)=0
|
|---|
| 31 | F RALOOP=0:0 S RAITNXT=$O(^RA(79.1,"BIMG",RAITN,RAITNXT)) Q:'RAITNXT S RACNT=RACNT+1,RAITNHLD=RAITNXT
|
|---|
| 32 | ;I RACNT=1 S ^DISV(+DUZ,"^RA(79.1,")=RAITNHLD
|
|---|
| 33 | I RACNT=1,RAITNHLD,$G(^RA(79.1,RAITNHLD,0))]"" S DIC("B")=$P($G(^SC(+^(0),0)),"^")
|
|---|
| 34 | Q
|
|---|
| 35 | SL ; switch locations
|
|---|
| 36 | ; Prompt the user to switch locations if the current sign-on imaging
|
|---|
| 37 | ; type does not match the procedure's imaging type.
|
|---|
| 38 | ; comment out 06/10/97 D EXAMSET^RAREG2 S RAPARENT=0
|
|---|
| 39 | S RAITN=$P(^RAMIS(71,+$P(Y,U,2),0),U,12)
|
|---|
| 40 | I RAITN'=+$O(^RA(79.2,"B",RAIMGTY,0)) D
|
|---|
| 41 | .S RAMLCHLD=RAMLC,RAYHOLD=Y,RAPROLOC=$P(^RA(79.2,RAITN,0),U,1),RAMDIVHD=RAMDIV
|
|---|
| 42 | .D LABEL
|
|---|
| 43 | .W !!?7,"Current Imaging Type: ",RAIMGTY
|
|---|
| 44 | .W !?5,"Procedure Imaging Type: ",RAPROLOC
|
|---|
| 45 | .W !!,"You must switch to a location of ",RAPROLOC," imaging type.",!!
|
|---|
| 46 | .D SETDISV
|
|---|
| 47 | .K RAMLC S RASWLOC=""
|
|---|
| 48 | .D SET^RAPSET1
|
|---|
| 49 | .K RASWLOC
|
|---|
| 50 | .I '$D(RAMLC) S RAQUIT=1,RAMLC=RAMLCHLD Q
|
|---|
| 51 | .I RAMDIVHD'=RAMDIV W !!,"You have switched Divisions from: ",$P(^DIC(4,+RAMDIVHD,0),U),!,?30,"to: ",$P(^DIC(4,+RAMDIV,0),U),!
|
|---|
| 52 | .D DT Q:RAQUIT
|
|---|
| 53 | .S Y=RAYHOLD
|
|---|
| 54 | .Q
|
|---|
| 55 | K RAITN,RAMDIVHD,RAMLCHLD,RAPROLOC,RAYHOLD
|
|---|
| 56 | Q
|
|---|
| 57 | DT ; prompt for new imaging date/time when imaging type changes
|
|---|
| 58 | Q:'$D(^RADPT(RADFN,"DT",RADTI,0))
|
|---|
| 59 | N RAHRS S RAHRS=+$P($G(^RA(79,+RAMDIV,.1)),"^",24) ;How many hrs in adv?
|
|---|
| 60 | R !!,"Imaging Exam Date/Time: NOW// ",X:DTIME
|
|---|
| 61 | I '$T!(X=" ")!(X="^") S RAQUIT=1 Q
|
|---|
| 62 | S:X="" RANOW="",X="NOW"
|
|---|
| 63 | I X="NOW" S RADTICHK=9999999.9999-($E($$NOW^XLFDT,1,12)) I $D(^RADPT(RADFN,"DT",RADTICHK,0)) D SUB1MIN K RADTICHK
|
|---|
| 64 | S %DT(0)=-$$FMADD^XLFDT($$NOW^XLFDT,0,RAHRS,0,0),%DT="ETXR"
|
|---|
| 65 | D ^%DT K %DT G DT:Y<0
|
|---|
| 66 | DT1 S RADTE=Y,RADTI=9999999.9999-RADTE I $D(^RADPT(RADFN,"DT",RADTI,0)) W !,*7,"Patient already has exams entered for this date/time.",!,"....use 'Add Exams to Last Visit' option." G DT
|
|---|
| 67 | DT2 K RADTEBAD S RADTEBAD=$O(^RADPT(RADFN,"DT","B",RADTE)) I RADTEBAD[RADTE D SUB1MIN S RADTE=X,RADTI=RADTICHK G DT2
|
|---|
| 68 | K RADTEBAD
|
|---|
| 69 | I $D(RANOW),$D(RAWARD) S RACAT="INPATIENT"
|
|---|
| 70 | I '$D(RANOW) K RAWARD,RABED,RASER D ^RASERV S:$D(RAWARD) RACAT="INPATIENT"
|
|---|
| 71 | Q
|
|---|
| 72 | SUB1MIN ; subtract 1 minute from NOW to get an unused date/time
|
|---|
| 73 | 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))
|
|---|
| 74 | K RALOOP
|
|---|
| 75 | Q
|
|---|
| 76 | ;
|
|---|
| 77 | LABEL ; *** Print labels
|
|---|
| 78 | I $D(RAPX) D
|
|---|
| 79 | . W ! S RAPX=RADFN,RAZIS=1
|
|---|
| 80 | . S RASAV2=$G(^RADPT(+$G(RADFN),"DT",+$G(RADTI),0))
|
|---|
| 81 | . 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))
|
|---|
| 82 | . D FLH^RAFLH K RANUMF
|
|---|
| 83 | . I $P(RAMDV,U,8) D JAC^RAJAC
|
|---|
| 84 | . S RADFN=RAPX K RAZIS
|
|---|
| 85 | . I $P($G(^DIC(195.4,1,"UP")),U,2) D ^RTQ5
|
|---|
| 86 | . K RAPX
|
|---|
| 87 | . Q
|
|---|
| 88 | Q
|
|---|
