RAUTL12 ;HISC/CAH,FPT,GJC-Utility Routine ; May 21, 2021@11:13:20
;;5.0;Radiology/Nuclear Medicine;**75,163,181**;Mar 16, 1998;Build 1
;
IMGTY(X,Y,Z) ; Determines the Imaging Type
; 'X' -> either 'e', 'l', or 'p'
; 'e' means we determine the Imaging Type from the 'Registered
; Exams' multiple in Rad/Nuc Med Patient file (70)
; 'l' means that we determine the Imaging Type from data in the
; Imaging Locations file (79.1)
; 'p' means that we determine the Imaging Type from data in the
; Rad/Nuc Med Procedures file (71)
;
; 'Y' -> The value of D0 in the above files.
;
; 'Z' -> The value of D1 in the Rad/Nuc Med Patient file (70).
; [ This routine passes back the Imaging Type in the external format ]
N A,B,RAXYZ
I X="e" D
. S A=$G(^RADPT(+$G(Y),"DT",+$G(Z),0)),B=+$P(A,U,2)
. S RAXYZ=$P($G(^RA(79.2,B,0)),U)
. Q
I X="l" D
. S A=$G(^RA(79.1,+$G(Y),0)),B=+$P(A,U,6)
. S RAXYZ=$P($G(^RA(79.2,B,0)),U)
. Q
I X="p" D
. S A=$G(^RAMIS(71,+$G(Y),0)),B=+$P(A,U,12)
. S RAXYZ=$P($G(^RA(79.2,B,0)),U)
. Q
Q RAXYZ
;
LOCK(X,Y) ; Lock the data global
; 'X' is the global root
; 'Y' is the record number
; KLM/163 - remove setting of RADUZ and ^TMP("RAD LOCS"
N RALCKFLG,XY
;S RADUZ=+$G(DUZ),
S RALCKFLG=0,XY=X_Y
L +@(XY_")"):5
I '$T S RALCKFLG=1 D
. W !?5,"This record is being edited by another user."
. W !?5,"Try again later!",$C(7)
. Q
;E D
;. S ^TMP("RAD LOCKS",$J,RADUZ,X,Y)=""
;. Q
Q RALCKFLG
;
UNLOCK(X,Y) ; Unlock the data global
;KLM/163 - remove setting of RADUZ and ^TMP("RAD LOCS"
N XY ;S RADUZ=+$G(DUZ),
S XY=X_Y L -@(XY_")")
;K ^TMP("RAD LOCKS",$J,RADUZ,X,Y)
Q
;Output is AMIS Credit Indicator: RABILAT = BILATERAL,
;RAPORT = PORTABLE, and RAOR = OPERATING ROOM.
S RAQI=$P($G(^RAMIS(71.2,RAQI,0)),U,2) S:RAQI="b" RABILAT="" S:RAQI="p" RAPORT="" S:RAQI="o" RAOR=""
Q
;
DESDT(RAPRI) ;Obtain 'Date Desired (NOT appt date)' by DIR call.
;from DESDT^RAUTL12 gjc@181
; The 'Date Desired' is passed back in internal format.
; 75.1 -> Rad Orders File Fld 21 -> Date desired
; Input: RAPRI = IEN of the procedure being ordered.
;
N DIR,DIROUT,DIRUT,DUOUT,DTOUT,X,Y
I '$D(RAPKG),($D(ORVP)),($D(ORL)),($D(ORNP)) D PROCMSG^RAUTL5(RAPRI)
F D Q:Y'=""
.S DIR("?",1)="The date desired cannot be greater than 390 days into the future from today."
.S DIR("?",2)=" "
.S DIR("?",3)="The Date Desired or Clinically Indicated Date (CID) is the date for which the"
.S DIR("?",4)="Rad/Nuc Med exam is requested. The CID is required and should not be interpreted"
.S DIR("?")="as an appointment date."
.; 1st parameter is user's input in internal FM date format ('Y' not 'X')
.S DIR(0)="75.1,21^^K:$$FMDIFF^XLFDT(Y,DT,1)>390 X" D ^DIR
.S:$D(DTOUT)#2!($D(DUOUT)#2) Y=-1
.Q
Q Y
;
PTLOC() ; Current patient location. Used for entry: 'CURRENT PATIENT
; LOCATION' in the Label Print Fields file. (78.7)
; 'X' is the patient's DFN. DFN must be a positive integer.
N %,%H,%I,A,B,C,DFN,VAERR,VAIN,X,Y,Y1,Y2,Y3,Y4,Y5
S Y=$$NOW^XLFDT(),Y1=$P(Y,"."),Y2=$E($P(Y,".",2),1,4)
S Y3=$E(Y1,4,5)_"-"_$E(Y1,6,7)_"-"_(1700+$E(Y1,1,3))
S Y4=$E(Y2,1,2)_":"_$E(Y2,3,4)
S Y5=Y3_"@"_Y4,DFN=+$P($G(^RADPT(+$G(RADFN),0)),"^")
Q:'+$G(DFN) "OP Unknown/"_Y5
D INP^VADPT ; If currently an inpatient, grab the ward.
I $P($G(VAIN(4)),"^",2)]"" D Q Y
. S Y=$E($P($G(VAIN(4)),"^",2),1,15)_"/"_Y5
. Q
; If not currently an inpatient, check if last recorded patient location
; is a ward. If it is a ward or operating room, pass back 'OP Unknown'.
; We do not have the benefit of PIMS updating our Rad/Nuc Med files.
S X=+$P($G(^RADPT(+$G(RADFN),"DT",+$G(RADTI),"P",+$G(RACNI),0)),"^",11)
S A=+$P($G(^RAO(75.1,X,0)),"^",22),B=$G(^SC(A,0)),C=$P(B,"^",3)
Q:B']""!("WOR"[C) "OP Unknown/"_Y5
Q $P(B,"^")_" (Req'g Loc)"
;
IMG() ; Select one/many/all imaging types. This code will be used for ALL
; the options under the Procedure File Listings option as exported by
; Rad/Nuc Med version 5. I-Types are not screened.
; Passes back '1' if I-Type(s) are selected, '0' if nothing selected.
N RADIC,RAQUIT,RAUTIL,X,Y
S RADIC="^RA(79.2,",RADIC(0)="QEAMZ"
S RADIC("A")="Select Imaging Type: ",RADIC("B")="All"
S RAUTIL="RA I-TYPE" W !! D EN1^RASELCT(.RADIC,RAUTIL)
Q $S($D(^TMP($J,"RA I-TYPE"))\10:1,1:0)
;
LOC(RAX) ; Select one/many/all imaging locations. L-Types are not
; screened. Passes back '1' if L-Type(s) are selected, '0' if nothing
; selected. Used for the option: 'Location Parameter List' (4^RASYS)
N RADIC,RAQUIT,RAUTIL,X,Y
S RADIC="^RA(79.1,",RADIC(0)="QEFAMZ"
S RADIC("A")="Select Imaging Location: ",RADIC("B")="All"
S:'RAX RADIC("S")="N RADT S RADT=$P(^(0),""^"",19) I $S('RADT:1,RADT>DT:1,1:0)"
S RAUTIL="RA L-TYPE" W !! D EN1^RASELCT(.RADIC,RAUTIL)
Q $S($D(^TMP($J,"RA L-TYPE"))\10:1,1:0)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAUTL12 4980 printed Apr 09, 2024@21:38:31 Page 2
RAUTL12 ;HISC/CAH,FPT,GJC-Utility Routine ; May 21, 2021@11:13:20
+1 ;;5.0;Radiology/Nuclear Medicine;**75,163,181**;Mar 16, 1998;Build 1
+2 ;
IMGTY(X,Y,Z) ; Determines the Imaging Type
+1 ; 'X' -> either 'e', 'l', or 'p'
+2 ; 'e' means we determine the Imaging Type from the 'Registered
+3 ; Exams' multiple in Rad/Nuc Med Patient file (70)
+4 ; 'l' means that we determine the Imaging Type from data in the
+5 ; Imaging Locations file (79.1)
+6 ; 'p' means that we determine the Imaging Type from data in the
+7 ; Rad/Nuc Med Procedures file (71)
+8 ;
+9 ; 'Y' -> The value of D0 in the above files.
+10 ;
+11 ; 'Z' -> The value of D1 in the Rad/Nuc Med Patient file (70).
+12 ; [ This routine passes back the Imaging Type in the external format ]
+13 NEW A,B,RAXYZ
+14 IF X="e"
Begin DoDot:1
+15 SET A=$GET(^RADPT(+$GET(Y),"DT",+$GET(Z),0))
SET B=+$PIECE(A,U,2)
+16 SET RAXYZ=$PIECE($GET(^RA(79.2,B,0)),U)
+17 QUIT
End DoDot:1
+18 IF X="l"
Begin DoDot:1
+19 SET A=$GET(^RA(79.1,+$GET(Y),0))
SET B=+$PIECE(A,U,6)
+20 SET RAXYZ=$PIECE($GET(^RA(79.2,B,0)),U)
+21 QUIT
End DoDot:1
+22 IF X="p"
Begin DoDot:1
+23 SET A=$GET(^RAMIS(71,+$GET(Y),0))
SET B=+$PIECE(A,U,12)
+24 SET RAXYZ=$PIECE($GET(^RA(79.2,B,0)),U)
+25 QUIT
End DoDot:1
+26 QUIT RAXYZ
+27 ;
LOCK(X,Y) ; Lock the data global
+1 ; 'X' is the global root
+2 ; 'Y' is the record number
+3 ; KLM/163 - remove setting of RADUZ and ^TMP("RAD LOCS"
+4 NEW RALCKFLG,XY
+5 ;S RADUZ=+$G(DUZ),
+6 SET RALCKFLG=0
SET XY=X_Y
+7 LOCK +@(XY_")"):5
+8 IF '$TEST
SET RALCKFLG=1
Begin DoDot:1
+9 WRITE !?5,"This record is being edited by another user."
+10 WRITE !?5,"Try again later!",$CHAR(7)
+11 QUIT
End DoDot:1
+12 ;E D
+13 ;. S ^TMP("RAD LOCKS",$J,RADUZ,X,Y)=""
+14 ;. Q
+15 QUIT RALCKFLG
+16 ;
UNLOCK(X,Y) ; Unlock the data global
+1 ;KLM/163 - remove setting of RADUZ and ^TMP("RAD LOCS"
+2 ;S RADUZ=+$G(DUZ),
NEW XY
+3 SET XY=X_Y
LOCK -@(XY_")")
+4 ;K ^TMP("RAD LOCKS",$J,RADUZ,X,Y)
+5 QUIT
+1 ;Output is AMIS Credit Indicator: RABILAT = BILATERAL,
+2 ;RAPORT = PORTABLE, and RAOR = OPERATING ROOM.
+3 SET RAQI=$PIECE($GET(^RAMIS(71.2,RAQI,0)),U,2)
if RAQI="b"
SET RABILAT=""
if RAQI="p"
SET RAPORT=""
if RAQI="o"
SET RAOR=""
+4 QUIT
+5 ;
DESDT(RAPRI) ;Obtain 'Date Desired (NOT appt date)' by DIR call.
+1 ;from DESDT^RAUTL12 gjc@181
+2 ; The 'Date Desired' is passed back in internal format.
+3 ; 75.1 -> Rad Orders File Fld 21 -> Date desired
+4 ; Input: RAPRI = IEN of the procedure being ordered.
+5 ;
+6 NEW DIR,DIROUT,DIRUT,DUOUT,DTOUT,X,Y
+7 IF '$DATA(RAPKG)
IF ($DATA(ORVP))
IF ($DATA(ORL))
IF ($DATA(ORNP))
DO PROCMSG^RAUTL5(RAPRI)
+8 FOR
Begin DoDot:1
+9 SET DIR("?",1)="The date desired cannot be greater than 390 days into the future from today."
+10 SET DIR("?",2)=" "
+11 SET DIR("?",3)="The Date Desired or Clinically Indicated Date (CID) is the date for which the"
+12 SET DIR("?",4)="Rad/Nuc Med exam is requested. The CID is required and should not be interpreted"
+13 SET DIR("?")="as an appointment date."
+14 ; 1st parameter is user's input in internal FM date format ('Y' not 'X')
+15 SET DIR(0)="75.1,21^^K:$$FMDIFF^XLFDT(Y,DT,1)>390 X"
DO ^DIR
+16 if $DATA(DTOUT)#2!($DATA(DUOUT)#2)
SET Y=-1
+17 QUIT
End DoDot:1
if Y'=""
QUIT
+18 QUIT Y
+19 ;
PTLOC() ; Current patient location. Used for entry: 'CURRENT PATIENT
+1 ; LOCATION' in the Label Print Fields file. (78.7)
+2 ; 'X' is the patient's DFN. DFN must be a positive integer.
+3 NEW %,%H,%I,A,B,C,DFN,VAERR,VAIN,X,Y,Y1,Y2,Y3,Y4,Y5
+4 SET Y=$$NOW^XLFDT()
SET Y1=$PIECE(Y,".")
SET Y2=$EXTRACT($PIECE(Y,".",2),1,4)
+5 SET Y3=$EXTRACT(Y1,4,5)_"-"_$EXTRACT(Y1,6,7)_"-"_(1700+$EXTRACT(Y1,1,3))
+6 SET Y4=$EXTRACT(Y2,1,2)_":"_$EXTRACT(Y2,3,4)
+7 SET Y5=Y3_"@"_Y4
SET DFN=+$PIECE($GET(^RADPT(+$GET(RADFN),0)),"^")
+8 if '+$GET(DFN)
QUIT "OP Unknown/"_Y5
+9 ; If currently an inpatient, grab the ward.
DO INP^VADPT
+10 IF $PIECE($GET(VAIN(4)),"^",2)]""
Begin DoDot:1
+11 SET Y=$EXTRACT($PIECE($GET(VAIN(4)),"^",2),1,15)_"/"_Y5
+12 QUIT
End DoDot:1
QUIT Y
+13 ; If not currently an inpatient, check if last recorded patient location
+14 ; is a ward. If it is a ward or operating room, pass back 'OP Unknown'.
+15 ; We do not have the benefit of PIMS updating our Rad/Nuc Med files.
+16 SET X=+$PIECE($GET(^RADPT(+$GET(RADFN),"DT",+$GET(RADTI),"P",+$GET(RACNI),0)),"^",11)
+17 SET A=+$PIECE($GET(^RAO(75.1,X,0)),"^",22)
SET B=$GET(^SC(A,0))
SET C=$PIECE(B,"^",3)
+18 if B']""!("WOR"[C)
QUIT "OP Unknown/"_Y5
+19 QUIT $PIECE(B,"^")_" (Req'g Loc)"
+20 ;
IMG() ; Select one/many/all imaging types. This code will be used for ALL
+1 ; the options under the Procedure File Listings option as exported by
+2 ; Rad/Nuc Med version 5. I-Types are not screened.
+3 ; Passes back '1' if I-Type(s) are selected, '0' if nothing selected.
+4 NEW RADIC,RAQUIT,RAUTIL,X,Y
+5 SET RADIC="^RA(79.2,"
SET RADIC(0)="QEAMZ"
+6 SET RADIC("A")="Select Imaging Type: "
SET RADIC("B")="All"
+7 SET RAUTIL="RA I-TYPE"
WRITE !!
DO EN1^RASELCT(.RADIC,RAUTIL)
+8 QUIT $SELECT($DATA(^TMP($JOB,"RA I-TYPE"))\10:1,1:0)
+9 ;
LOC(RAX) ; Select one/many/all imaging locations. L-Types are not
+1 ; screened. Passes back '1' if L-Type(s) are selected, '0' if nothing
+2 ; selected. Used for the option: 'Location Parameter List' (4^RASYS)
+3 NEW RADIC,RAQUIT,RAUTIL,X,Y
+4 SET RADIC="^RA(79.1,"
SET RADIC(0)="QEFAMZ"
+5 SET RADIC("A")="Select Imaging Location: "
SET RADIC("B")="All"
+6 if 'RAX
SET RADIC("S")="N RADT S RADT=$P(^(0),""^"",19) I $S('RADT:1,RADT>DT:1,1:0)"
+7 SET RAUTIL="RA L-TYPE"
WRITE !!
DO EN1^RASELCT(.RADIC,RAUTIL)
+8 QUIT $SELECT($DATA(^TMP($JOB,"RA L-TYPE"))\10:1,1:0)
+9 ;
