RAUTL19 ;HISC/GJC-Utility Routine ; Apr 28, 2020@14:47:46
;;5.0;Radiology/Nuclear Medicine;**1,31,169**;Mar 16, 1998;Build 2
;
;IA Type File Routine Tag
;------------------------------------------------
;1362 (C) ORB3 EN
;
PRELIM(RAIMG) ; Called from '1^RAMAIN1'
W !!?(IOM-$L(RAHDR)\2),RAHDR K %ZIS S %ZIS="MQ" W !
D ^%ZIS Q:POP
I $D(IO("Q")) D W ! Q
. S ZTDESC="Rad/Nuc Med Exam Status Entry/Edit Report",ZTSAVE("RA*")=""
. S ZTRTN="EN1^RAUTL19" D ^%ZTLOAD
. W !?5,$S($D(ZTSK):"Request Queued!",1:"Request Cancelled!")
. Q
I IO'=IO(0) U IO
D EN1 I IO'=IO(0) D HOME^%ZIS
Q
EN1 ; Check data consistency
D EN1^RAUTL19C
Q
NOTNEED ;non-radiopharm used don't need .5n and .6n fields answered
Q:RANODE(.5)'["Y"&(RANODE(.6)'["Y")
W !!,RADASH,"Checking fields not needed by non-nucmed imaging",RADASH
W !!?11,"Within : ",RAIMG,!?5,"The following need not be answered :"
W !?5,"Exam Status '",$P(RANODE(0),"^"),"'",!?5,"order ("_RAO_") '",!
N RAIMG0,RAIMG1,RAIMG2
S RAIMG1=.50,RAIMG2=.69,RAIMG0=RAIMG1
F S RAIMG0=$O(RAPIECE(RAIMG0)) Q:RAIMG0>RAIMG2 Q:RAIMG0="" I RAPIECE(RAIMG0)="Y" W !,"'",$P($G(^DD(72,RAIMG0,.1)),U),"' is set to ",RAPIECE(RAIMG0)
W !
Q
CKPRNTR ;ck that all img locations for that img type has a dosg tkt prntr
N RAIMG72,RA791,RA791FL
S RAIMG72=$P(RANODE(0),U,7),RA791=0,RA791FL=0
F S RA791=$O(^RA(79.1,"BIMG",RAIMG72,RA791)) Q:'RA791 I $P(^RA(79.1,RA791,0),U,23)="" D PRNTASGN Q:RAOUT
Q
PRNTASGN ;
W:'RA791FL !!,RADASH,"Checking Dosage Ticket Printer Assignment",RADASH
I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
W:'RA791FL !!?11,"Within : ",RAIMG,!?5,"Exam Status '",$P(RANODE(0),"^"),"'",!?5,"order ("_RAO_") '"_$P($G(^DD(72,.611,.1)),U)_"'",!?5,"is set to 'Yes' but",!?5,"there's no Dosage Ticket Printer assigned to :"
I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
S RA791FL=1
W !?15,$P(^SC($P(^RA(79.1,RA791,0),U),0),U)
I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
Q
WRPAIR I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
W:'RACHKERR !!,RADASH,"Checking fields that are inter-related",RADASH
S RACHKERR=1 ;only write this once
Q
CKPAIR ; when field I is Y, then field J must also be Y at current/lower status
D CKPAIR^RAUTL19C
Q
WRWAIT W:'RAWATERR !!,RADASH,"Checking ",$P(RANODE(0),U,1),"'s 'ASK' and 'REQUIRED' fields",RADASH,!?11,"within : ",RAIMG,!
S RAWATERR=1 ;only write this once regardless of number of errors found
Q
CKWAIT ; CKWAIT is only done for WAITING FOR EXAM and assumes order seq = 1
D CKWAIT^RAUTL19C
Q
ASKPRI(A,B,C) ; Check all prior statuses to ensure that the specific required
; data field is set to 'yes', and the field for data asked is set to
; 'yes'.
; 'A' is the I-Type (external) <-> 'B' is the current status order
; 'C' is fld that shd be prompted <-> 'E' is the order #
; 'F' is the ien of file 72. <-> 'RA' hold the entire data node
; 'RAFLD' value of the field <-> 'RAPCE' where data found on node
N E,F,RA,RAFLD,RAPCE S E=0
F S E=$O(^RA(72,"AA",A,E)) Q:E'>0!(E'<B) D Q:RAFLG
. S F=+$O(^RA(72,"AA",A,E,0)) Q:'F
. S RA(0)=$G(^RA(72,F,0))
. I $$UP^XLFSTR($P(RA(0),"^",5))="Y" D ; if on Status Tracking
.. S RAPCE=$E(C,3,$L(C)) ;pce is after 2nd byte, & is 1 or 2 bytes long
.. S RA($E(C,1,2))=$G(^RA(72,F,$E(C,1,2))),RAFLD=$P(RA($E(C,1,2)),"^",RAPCE)
.. S:$$UP^XLFSTR(RAFLD)="Y" RAFLG=1
.. Q
. Q
Q RAFLG
PROCTY(Y) ; Passes back the Procedure Type. 'Y' is the ien in the
; Rad/Nuc Med Procedure file '^RAMIS(71,'.
Q $$UP^XLFSTR($P($G(^RAMIS(71,+Y,0)),"^",6))
LK(X) ; Lock a patient record when updating orders
; 'X' input in a variable pointer format: 'record_#;data_file__root'
; Pass back 'Y': '0' if lock fails, '1' if successful
; 'Y' defined in LK^ORX2
Q 1
ULK(X) ; Unlock a patient record
; 'X' input in a variable pointer format: 'record_#;data_file__root'
Q
ACCVIO ; Lack of Imaging Location access for a user
W !?5,$C(7),"You do not have access to any Imaging Locations."
W !?5,"Contact your ADPAC."
Q
DEV(X) ; Lookup an entry in the Device (3.5) file.
; Called from the [RA LOCATION PARAMETERS] input template. File: 79.1
; Input: X=IEN of Device
; Output: Name of Device
Q:'$L(X) ""
I X?1N.NP Q $P($G(^%ZIS(1,X,0)),"^")
Q ""
OENO(X) ; OE/RR notifications, called from: RAORR1, RAORD1 & RAO7RO
; Input: 'X' -> ien of the Rad/Nuc Med Orders file (75.1)
; Notification: #51 - STAT IMAGING REQUEST & #52 - URGENT IMAGING REQUEST
N I,RA751,RADFN,RADUZ,RALOC,RAMSG,RANOTY,RAORIFN
S RA751=$G(^RAO(75.1,X,0)),RADFN=+$P(RA751,"^"),RANOTY=$P(RA751,"^",6)
S RAORIFN=$P(RA751,"^",7) ;CPRS order IFN RA5P169
S RANOTY=$S(RANOTY=1:51,RANOTY=2:52,1:"") Q:RANOTY=""
S RALOC=$P(RA751,"^",20) Q:RALOC']"" ; no i-loc, no alert
S I=0 F S I=$O(^RA(79.1,RALOC,"REC","B",I)) Q:I'>0 D
. S RADUZ(I)=""
. Q
S:($D(RADUZ)\10)=0 RADUZ="" ; NOTE: if no rad/nuc med recipients, check
; oe/rr to see if they have any recipients for this particular alert
S RAMSG="Imaging Request Urgency: "_$$XTERNAL^RAUTL5($P(RA751,"^",6),$P($G(^DD(75.1,6,0)),"^",2))
D EN^ORB3(RANOTY,RADFN,RAORIFN,.RADUZ,RAMSG)
Q
VRADE ;VistaRad Category data entry
I '$$IMAGE^RARIC1() W !!,"Current system is not running Vista Imaging -- nothing done.",! Q
S DIC="^RA(79.2,",DIC(0)="QEAMNZ",DIC("A")="Select an Imaging Type: "
D ^DIC K DIC G:+Y'>0 VRADQ
S RAOUT=0,RAIMGTYI=+Y,RAIMGTYJ=$P(Y,U,2)
F D Q:RAOUT
. K DINUM,DLAYGO,D0 W !
. S DIC="^RA(72,",DIC(0)="QEAZ" ; don't allow LAYGO
. S DIC("S")="I +$P(^(0),U,7)=RAIMGTYI"
. S RADICW(1)="N RA S RA(0)=^(0),RA(3)=$P(RA(0),U,3) "
. S RADICW(2)="W ?35,""Imaging Type: "",?49,RAIMGTYJ"
. S RADICW(3)=",!?35,""Order: "",?42,RA(3)"
. S DIC("W")=RADICW(1)_RADICW(2)_RADICW(3)
. D ^DIC K DIC,RADICW
. I +Y'>0 S RAOUT=1 Q
. S DA=+Y,DIE="^RA(72,",DR="9" D ^DIE
. Q
VRADQ K RAIMGTYI,RAIMGTYJ,RAOUT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAUTL19 6063 printed Dec 13, 2024@02:40:19 Page 2
RAUTL19 ;HISC/GJC-Utility Routine ; Apr 28, 2020@14:47:46
+1 ;;5.0;Radiology/Nuclear Medicine;**1,31,169**;Mar 16, 1998;Build 2
+2 ;
+3 ;IA Type File Routine Tag
+4 ;------------------------------------------------
+5 ;1362 (C) ORB3 EN
+6 ;
PRELIM(RAIMG) ; Called from '1^RAMAIN1'
+1 WRITE !!?(IOM-$LENGTH(RAHDR)\2),RAHDR
KILL %ZIS
SET %ZIS="MQ"
WRITE !
+2 DO ^%ZIS
if POP
QUIT
+3 IF $DATA(IO("Q"))
Begin DoDot:1
+4 SET ZTDESC="Rad/Nuc Med Exam Status Entry/Edit Report"
SET ZTSAVE("RA*")=""
+5 SET ZTRTN="EN1^RAUTL19"
DO ^%ZTLOAD
+6 WRITE !?5,$SELECT($DATA(ZTSK):"Request Queued!",1:"Request Cancelled!")
+7 QUIT
End DoDot:1
WRITE !
QUIT
+8 IF IO'=IO(0)
USE IO
+9 DO EN1
IF IO'=IO(0)
DO HOME^%ZIS
+10 QUIT
EN1 ; Check data consistency
+1 DO EN1^RAUTL19C
+2 QUIT
NOTNEED ;non-radiopharm used don't need .5n and .6n fields answered
+1 if RANODE(.5)'["Y"&(RANODE(.6)'["Y")
QUIT
+2 WRITE !!,RADASH,"Checking fields not needed by non-nucmed imaging",RADASH
+3 WRITE !!?11,"Within : ",RAIMG,!?5,"The following need not be answered :"
+4 WRITE !?5,"Exam Status '",$PIECE(RANODE(0),"^"),"'",!?5,"order ("_RAO_") '",!
+5 NEW RAIMG0,RAIMG1,RAIMG2
+6 SET RAIMG1=.50
SET RAIMG2=.69
SET RAIMG0=RAIMG1
+7 FOR
SET RAIMG0=$ORDER(RAPIECE(RAIMG0))
if RAIMG0>RAIMG2
QUIT
if RAIMG0=""
QUIT
IF RAPIECE(RAIMG0)="Y"
WRITE !,"'",$PIECE($GET(^DD(72,RAIMG0,.1)),U),"' is set to ",RAPIECE(RAIMG0)
+8 WRITE !
+9 QUIT
CKPRNTR ;ck that all img locations for that img type has a dosg tkt prntr
+1 NEW RAIMG72,RA791,RA791FL
+2 SET RAIMG72=$PIECE(RANODE(0),U,7)
SET RA791=0
SET RA791FL=0
+3 FOR
SET RA791=$ORDER(^RA(79.1,"BIMG",RAIMG72,RA791))
if 'RA791
QUIT
IF $PIECE(^RA(79.1,RA791,0),U,23)=""
DO PRNTASGN
if RAOUT
QUIT
+4 QUIT
PRNTASGN ;
+1 if 'RA791FL
WRITE !!,RADASH,"Checking Dosage Ticket Printer Assignment",RADASH
+2 IF $Y>(IOSL-6)
SET RAOUT=$$EOS^RAUTL5()
if RAOUT
QUIT
DO HEAD^RAUTL11
+3 if 'RA791FL
WRITE !!?11,"Within : ",RAIMG,!?5,"Exam Status '",$PIECE(RANODE(0),"^"),"'",!?5,"order ("_RAO_") '"_$PIECE($GET(^DD(72,.611,.1)),U)_"'",!?5,"is set to 'Yes' but",!?5,"there's no Dosage Ticket Printer assigned to :"
+4 IF $Y>(IOSL-6)
SET RAOUT=$$EOS^RAUTL5()
if RAOUT
QUIT
DO HEAD^RAUTL11
+5 SET RA791FL=1
+6 WRITE !?15,$PIECE(^SC($PIECE(^RA(79.1,RA791,0),U),0),U)
+7 IF $Y>(IOSL-6)
SET RAOUT=$$EOS^RAUTL5()
if RAOUT
QUIT
DO HEAD^RAUTL11
+8 QUIT
WRPAIR IF $Y>(IOSL-6)
SET RAOUT=$$EOS^RAUTL5()
if RAOUT
QUIT
DO HEAD^RAUTL11
+1 if 'RACHKERR
WRITE !!,RADASH,"Checking fields that are inter-related",RADASH
+2 ;only write this once
SET RACHKERR=1
+3 QUIT
CKPAIR ; when field I is Y, then field J must also be Y at current/lower status
+1 DO CKPAIR^RAUTL19C
+2 QUIT
WRWAIT if 'RAWATERR
WRITE !!,RADASH,"Checking ",$PIECE(RANODE(0),U,1),"'s 'ASK' and 'REQUIRED' fields",RADASH,!?11,"within : ",RAIMG,!
+1 ;only write this once regardless of number of errors found
SET RAWATERR=1
+2 QUIT
CKWAIT ; CKWAIT is only done for WAITING FOR EXAM and assumes order seq = 1
+1 DO CKWAIT^RAUTL19C
+2 QUIT
ASKPRI(A,B,C) ; Check all prior statuses to ensure that the specific required
+1 ; data field is set to 'yes', and the field for data asked is set to
+2 ; 'yes'.
+3 ; 'A' is the I-Type (external) <-> 'B' is the current status order
+4 ; 'C' is fld that shd be prompted <-> 'E' is the order #
+5 ; 'F' is the ien of file 72. <-> 'RA' hold the entire data node
+6 ; 'RAFLD' value of the field <-> 'RAPCE' where data found on node
+7 NEW E,F,RA,RAFLD,RAPCE
SET E=0
+8 FOR
SET E=$ORDER(^RA(72,"AA",A,E))
if E'>0!(E'<B)
QUIT
Begin DoDot:1
+9 SET F=+$ORDER(^RA(72,"AA",A,E,0))
if 'F
QUIT
+10 SET RA(0)=$GET(^RA(72,F,0))
+11 ; if on Status Tracking
IF $$UP^XLFSTR($PIECE(RA(0),"^",5))="Y"
Begin DoDot:2
+12 ;pce is after 2nd byte, & is 1 or 2 bytes long
SET RAPCE=$EXTRACT(C,3,$LENGTH(C))
+13 SET RA($EXTRACT(C,1,2))=$GET(^RA(72,F,$EXTRACT(C,1,2)))
SET RAFLD=$PIECE(RA($EXTRACT(C,1,2)),"^",RAPCE)
+14 if $$UP^XLFSTR(RAFLD)="Y"
SET RAFLG=1
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
if RAFLG
QUIT
+17 QUIT RAFLG
PROCTY(Y) ; Passes back the Procedure Type. 'Y' is the ien in the
+1 ; Rad/Nuc Med Procedure file '^RAMIS(71,'.
+2 QUIT $$UP^XLFSTR($PIECE($GET(^RAMIS(71,+Y,0)),"^",6))
LK(X) ; Lock a patient record when updating orders
+1 ; 'X' input in a variable pointer format: 'record_#;data_file__root'
+2 ; Pass back 'Y': '0' if lock fails, '1' if successful
+3 ; 'Y' defined in LK^ORX2
+4 QUIT 1
ULK(X) ; Unlock a patient record
+1 ; 'X' input in a variable pointer format: 'record_#;data_file__root'
+2 QUIT
ACCVIO ; Lack of Imaging Location access for a user
+1 WRITE !?5,$CHAR(7),"You do not have access to any Imaging Locations."
+2 WRITE !?5,"Contact your ADPAC."
+3 QUIT
DEV(X) ; Lookup an entry in the Device (3.5) file.
+1 ; Called from the [RA LOCATION PARAMETERS] input template. File: 79.1
+2 ; Input: X=IEN of Device
+3 ; Output: Name of Device
+4 if '$LENGTH(X)
QUIT ""
+5 IF X?1N.NP
QUIT $PIECE($GET(^%ZIS(1,X,0)),"^")
+6 QUIT ""
OENO(X) ; OE/RR notifications, called from: RAORR1, RAORD1 & RAO7RO
+1 ; Input: 'X' -> ien of the Rad/Nuc Med Orders file (75.1)
+2 ; Notification: #51 - STAT IMAGING REQUEST & #52 - URGENT IMAGING REQUEST
+3 NEW I,RA751,RADFN,RADUZ,RALOC,RAMSG,RANOTY,RAORIFN
+4 SET RA751=$GET(^RAO(75.1,X,0))
SET RADFN=+$PIECE(RA751,"^")
SET RANOTY=$PIECE(RA751,"^",6)
+5 ;CPRS order IFN RA5P169
SET RAORIFN=$PIECE(RA751,"^",7)
+6 SET RANOTY=$SELECT(RANOTY=1:51,RANOTY=2:52,1:"")
if RANOTY=""
QUIT
+7 ; no i-loc, no alert
SET RALOC=$PIECE(RA751,"^",20)
if RALOC']""
QUIT
+8 SET I=0
FOR
SET I=$ORDER(^RA(79.1,RALOC,"REC","B",I))
if I'>0
QUIT
Begin DoDot:1
+9 SET RADUZ(I)=""
+10 QUIT
End DoDot:1
+11 ; NOTE: if no rad/nuc med recipients, check
if ($DATA(RADUZ)\10)=0
SET RADUZ=""
+12 ; oe/rr to see if they have any recipients for this particular alert
+13 SET RAMSG="Imaging Request Urgency: "_$$XTERNAL^RAUTL5($PIECE(RA751,"^",6),$PIECE($GET(^DD(75.1,6,0)),"^",2))
+14 DO EN^ORB3(RANOTY,RADFN,RAORIFN,.RADUZ,RAMSG)
+15 QUIT
VRADE ;VistaRad Category data entry
+1 IF '$$IMAGE^RARIC1()
WRITE !!,"Current system is not running Vista Imaging -- nothing done.",!
QUIT
+2 SET DIC="^RA(79.2,"
SET DIC(0)="QEAMNZ"
SET DIC("A")="Select an Imaging Type: "
+3 DO ^DIC
KILL DIC
if +Y'>0
GOTO VRADQ
+4 SET RAOUT=0
SET RAIMGTYI=+Y
SET RAIMGTYJ=$PIECE(Y,U,2)
+5 FOR
Begin DoDot:1
+6 KILL DINUM,DLAYGO,D0
WRITE !
+7 ; don't allow LAYGO
SET DIC="^RA(72,"
SET DIC(0)="QEAZ"
+8 SET DIC("S")="I +$P(^(0),U,7)=RAIMGTYI"
+9 SET RADICW(1)="N RA S RA(0)=^(0),RA(3)=$P(RA(0),U,3) "
+10 SET RADICW(2)="W ?35,""Imaging Type: "",?49,RAIMGTYJ"
+11 SET RADICW(3)=",!?35,""Order: "",?42,RA(3)"
+12 SET DIC("W")=RADICW(1)_RADICW(2)_RADICW(3)
+13 DO ^DIC
KILL DIC,RADICW
+14 IF +Y'>0
SET RAOUT=1
QUIT
+15 SET DA=+Y
SET DIE="^RA(72,"
SET DR="9"
DO ^DIE
+16 QUIT
End DoDot:1
if RAOUT
QUIT
VRADQ KILL RAIMGTYI,RAIMGTYJ,RAOUT
+1 QUIT
