RADD1 ;HISC/FPT-Radiology Utility Routine ;6/2/98 16:17
;;5.0;Radiology/Nuclear Medicine;**1,5,10,65,94**;Mar 16, 1998;Build 9
;
;Supported IA #10142 reference to EN^DDIOL
;Supported IA #10103 reference to FMADD^XLFDT
;
SECXREF ; sets/kills 'ARES' & 'ASTF' x-refs for secondary resident/staff rads
; called from ^DD(74,5
;
Q:'$D(^RARPT(DA,0)) S RADFNZ=^(0)
S RADTIZ=9999999.9999-$P(RADFNZ,"^",3),RACNIZ=$O(^RADPT(+$P(RADFNZ,"^",2),"DT",RADTIZ,"P","B",+$P(RADFNZ,"^",4),0)),RADFNZ=+$P(RADFNZ,"^",2)
I 'RACNIZ D KILL Q
I '$D(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,0)) D KILL Q
I '$D(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,RASECOND,0)) D KILL Q
S RASECIEN=0
F S RASECIEN=$O(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,RASECOND,RASECIEN)) Q:RASECIEN<1 S RARAD=+$P($G(^(RASECIEN,0)),"^",1) I RARAD>0 D
.S:$D(RASET) ^RARPT(RAXREF,RARAD,DA)="" K:$D(RAKILL) ^RARPT(RAXREF,RARAD,DA)
D XSEC^RAUTL20
KILL K RACNIZ,RADFNZ,RADTIZ,RASECOND,RASECIEN
Q
SCDTC ; status change date/time check
; called from ^DD(70.05,.01
; if X is a date/time prior to the exam date/time, then set Y=0.
; if X is a over a minute in the future, then set Y=0.
; if X is missing the time portion, then set Y=0.
I '($D(X)#2) Q
I '$F(X,".") D EN^DDIOL("** Time is Required **","","!!?20") S Y=0 Q
N RASTATUS,RAORDNUM,RAPLUS1
; eg. da(3)=1128, da(2)=7028970.8743,da(1)=1,da=1
S RASTATUS=$P($G(^RADPT(+$G(DA(3)),"DT",+$G(DA(2)),"P",+$G(DA(1)),0)),U,3)
S RAORDNUM=$P($G(^RA(72,+RASTATUS,0)),U,3)
I X<(9999999.9999-$G(DA(2))),RAORDNUM>1 S Y=0 Q
S RADTHOLD=X
D NOW^%DTC
; 2/25/98 allow entry to be at most 1 minute after current time
S RAPLUS1=%,RAPLUS1=$$FMADD^XLFDT(RAPLUS1,0,0,1,0)
I RADTHOLD>RAPLUS1 S Y=0
S X=RADTHOLD
K RADTHOLD
Q
;
PDC() ; do not enter secondary into primary diagnostic code field
; called from ^DD(70.03,13,0)
; do not select inactive diagnostic code 12/23/96
;P94 - IF changed to a post-conditional
Q:$P(^RA(78.3,+Y,0),U,5)="Y" 0
Q:$D(^RADPT(DA(2),"DT",DA(1),"P",DA,"DX","B",+Y)) 0
Q 1
;
SDC() ; do not enter primary into secondary diagnostic code field
; called from ^DD(70.14,.01,0)
; do not select inactive diagnostic code 12/23/96
I $P(^RA(78.3,+Y,0),U,5)="Y" Q 0
I '$D(X)!('$D(DA(3))) G SDC2
I '$D(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0)) G SDC2
I $P(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0),"^",13)=+Y Q 0
Q 1
SDC2 ;
I '$D(X)!('$D(DA(2))) G SDC3
I '$D(^RADPT(DA(2),"DT",DA(1),"P",DA,0)) Q 0
I $P(^RADPT(DA(2),"DT",DA(1),"P",DA,0),"^",13)=+Y Q 0
Q 1
SDC3 ;
I '$D(RADFN) Q 0
S DA(2)=RADFN
I '$D(^RADPT(DA(2),"DT",DA(1),"P",DA,0)) Q 0
I $P(^RADPT(DA(2),"DT",DA(1),"P",DA,0),"^",13)=+Y Q 0
Q 1
;
NODEL ; Do not permit deletion of the PRIMARY DIAGNOSTIC CODE (70.03,
; 13), PRIMARY INTERPRETING RESIDENT (70.03,12) or PRIMARY
; INTERPRETING STAFF (70.03,15) if a SECONDARY DIAGNOSTIC CODE
; multiple (70.03,13.1) is associated with the exam record.
;
; P94: WRITE removed; EN^DDIOL added
;
;Note: the IF statement has to remain because $T needs to be
;set in order to properly influence the "DEL" node.
;
S RASECCHK=0,RASECCHK=$O(^RADPT(DA(2),"DT",DA(1),"P",DA,RAMULT,RASECCHK))
I RASECCHK D EN^DDIOL(" Required","","?0")
K RAMULT,RASECCHK
Q
;
PRCCPT() ; Displays the procedure type and CPT code if applicable.
; This code is called from ^DD(71,0,"ID","WRITE") and rtn RAPROD
N RA,RATXT S RA(0)=$G(^(0)),RA("I")=+$G(^("I")),RATXT=""
S RA=$S('RA("I"):0,DT'>RA("I"):0,1:1)
S RA(6)=$P(RA(0),U,6),RA(9)=$P(RA(0),U,9)
S RA(12)=$P(RA(0),U,12) I 'RA(12) S RA(10)="UNKN "
I '$D(RA(10)) S RA(10)=$P(^RA(79.2,+RA(12),0),U,3)_" "
I $L(RA(10))<5 F S RA(10)=RA(10)_" " Q:$L(RA(10))>4
S RATXT="("_RA(10)_$S(RA:"Inactive",RA(6)="B":"Broad ",RA(6)="D":"Detailed",RA(6)="P":"Parent ",RA(6)="S":"Series ",1:"Unknown ")_")"
S:RA(9)]"" RATXT=RATXT_" CPT:"_$P($$NAMCODE^RACPTMSC(RA(9),DT),"^")
Q RATXT
INDTCHK(RADA) ; Cannot inactivate a procedure if it is a common procedure
; with a valid sequence number. Code resides in ^DD(71,100,0)!
; 'RADA' is the ien of the procedure in file 71. if this procedure is
; a common procedure i.e, $D(^RAMIS(71.3,"B",RADA)) inform the user that
; the sequence number must be deleted. This relies on the "AA" xref in
; the Common Proc. file for the Sequence # fld (#3) 0 node, 4th pce.
N RA,RAIEN S RAIEN=+$O(^RAMIS(71.3,"B",RADA,0))
S RA(0)=$G(^RAMIS(71.3,RAIEN,0)) Q:RA(0)']""
S RA(4)=+$P(RA(0),"^",4) ; obtain the sequence number
I $D(^RAMIS(71.3,"AA",$$EN3^RAUTL17(RADA),RA(4),RAIEN)) D ; sequence #?
. N RATXT S RATXT(1)=" "
. S RATXT(2)=" Cannot inactivate - this procedure is currently in the"
. S RATXT(3)=" Rad/Nuc Med Common Procedure file with a sequence"
. S RATXT(4)=" number. Please remove the sequence number thru the"
. S RATXT(5)=" 'Common Procedure Enter/Edit' option before assigning"
. S RATXT(6)=" an inactivation date to this procedure."
. S RATXT(7)=" "
. D EN^DDIOL(.RATXT) K X ; display message, can't input ANY date!
. Q
Q
CPTCHK(RADA) ; Check if the CPT code is inactive nationally.
; 'RADA' assume the value of +Y passed from the input xform, ^DD(71,9,0)
; quit if CPT code is active
;
Q:$$ACTCODE^RACPTMSC(RADA,DT)
N RATXT S RATXT(1)=" "
S RATXT(2)=" Warning - Nationally inactive CPT code."
S RATXT(3)=" " D EN^DDIOL(.RATXT)
K X
Q
;
VALADM(RAD0,Y,RADT,RAUTH) ;edit validation
;Used to validate/screen radiopharm dosage administrator,
; radiopharm prescribing phys, person who measured radiopharm dose,
;----------------------------------------------------------------------
; RAD0 : IEN of entry in question for NUC MED EXAM DATA (70.2) file
; Y : Pointer to the New Person file
; RADT : Xam Date; if not passed, calculate exam date from file 70.2
; RAUTH : 1 - only staff/resid, must be auth'zd to write med orders
; : 0 - staff/resid & tech's
;----------------------------------------------------------------------
; Output: '1' authorized to write med orders, else '0'
;----------------------------------------------------------------------
Q $$VALADM^RADD4()
;
VOL(RAX) ; Validate the format of the value input for volume.
; RAX must be a number followed by a space then text -or-
; a number followed by text
; Input Variable : 'RAX'- user's input
; Output Variable: null if 'RAX' erroneous, formatted version of 'RAX'
Q $$VOL^RADD4()
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRADD1 6470 printed Apr 09, 2024@21:37:46 Page 2
RADD1 ;HISC/FPT-Radiology Utility Routine ;6/2/98 16:17
+1 ;;5.0;Radiology/Nuclear Medicine;**1,5,10,65,94**;Mar 16, 1998;Build 9
+2 ;
+3 ;Supported IA #10142 reference to EN^DDIOL
+4 ;Supported IA #10103 reference to FMADD^XLFDT
+5 ;
SECXREF ; sets/kills 'ARES' & 'ASTF' x-refs for secondary resident/staff rads
+1 ; called from ^DD(74,5
+2 ;
+3 if '$DATA(^RARPT(DA,0))
QUIT
SET RADFNZ=^(0)
+4 SET RADTIZ=9999999.9999-$PIECE(RADFNZ,"^",3)
SET RACNIZ=$ORDER(^RADPT(+$PIECE(RADFNZ,"^",2),"DT",RADTIZ,"P","B",+$PIECE(RADFNZ,"^",4),0))
SET RADFNZ=+$PIECE(RADFNZ,"^",2)
+5 IF 'RACNIZ
DO KILL
QUIT
+6 IF '$DATA(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,0))
DO KILL
QUIT
+7 IF '$DATA(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,RASECOND,0))
DO KILL
QUIT
+8 SET RASECIEN=0
+9 FOR
SET RASECIEN=$ORDER(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,RASECOND,RASECIEN))
if RASECIEN<1
QUIT
SET RARAD=+$PIECE($GET(^(RASECIEN,0)),"^",1)
IF RARAD>0
Begin DoDot:1
+10 if $DATA(RASET)
SET ^RARPT(RAXREF,RARAD,DA)=""
if $DATA(RAKILL)
KILL ^RARPT(RAXREF,RARAD,DA)
End DoDot:1
+11 DO XSEC^RAUTL20
KILL KILL RACNIZ,RADFNZ,RADTIZ,RASECOND,RASECIEN
+1 QUIT
SCDTC ; status change date/time check
+1 ; called from ^DD(70.05,.01
+2 ; if X is a date/time prior to the exam date/time, then set Y=0.
+3 ; if X is a over a minute in the future, then set Y=0.
+4 ; if X is missing the time portion, then set Y=0.
+5 IF '($DATA(X)#2)
QUIT
+6 IF '$FIND(X,".")
DO EN^DDIOL("** Time is Required **","","!!?20")
SET Y=0
QUIT
+7 NEW RASTATUS,RAORDNUM,RAPLUS1
+8 ; eg. da(3)=1128, da(2)=7028970.8743,da(1)=1,da=1
+9 SET RASTATUS=$PIECE($GET(^RADPT(+$GET(DA(3)),"DT",+$GET(DA(2)),"P",+$GET(DA(1)),0)),U,3)
+10 SET RAORDNUM=$PIECE($GET(^RA(72,+RASTATUS,0)),U,3)
+11 IF X<(9999999.9999-$GET(DA(2)))
IF RAORDNUM>1
SET Y=0
QUIT
+12 SET RADTHOLD=X
+13 DO NOW^%DTC
+14 ; 2/25/98 allow entry to be at most 1 minute after current time
+15 SET RAPLUS1=%
SET RAPLUS1=$$FMADD^XLFDT(RAPLUS1,0,0,1,0)
+16 IF RADTHOLD>RAPLUS1
SET Y=0
+17 SET X=RADTHOLD
+18 KILL RADTHOLD
+19 QUIT
+20 ;
PDC() ; do not enter secondary into primary diagnostic code field
+1 ; called from ^DD(70.03,13,0)
+2 ; do not select inactive diagnostic code 12/23/96
+3 ;P94 - IF changed to a post-conditional
+4 if $PIECE(^RA(78.3,+Y,0),U,5)="Y"
QUIT 0
+5 if $DATA(^RADPT(DA(2),"DT",DA(1),"P",DA,"DX","B",+Y))
QUIT 0
+6 QUIT 1
+7 ;
SDC() ; do not enter primary into secondary diagnostic code field
+1 ; called from ^DD(70.14,.01,0)
+2 ; do not select inactive diagnostic code 12/23/96
+3 IF $PIECE(^RA(78.3,+Y,0),U,5)="Y"
QUIT 0
+4 IF '$DATA(X)!('$DATA(DA(3)))
GOTO SDC2
+5 IF '$DATA(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0))
GOTO SDC2
+6 IF $PIECE(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0),"^",13)=+Y
QUIT 0
+7 QUIT 1
SDC2 ;
+1 IF '$DATA(X)!('$DATA(DA(2)))
GOTO SDC3
+2 IF '$DATA(^RADPT(DA(2),"DT",DA(1),"P",DA,0))
QUIT 0
+3 IF $PIECE(^RADPT(DA(2),"DT",DA(1),"P",DA,0),"^",13)=+Y
QUIT 0
+4 QUIT 1
SDC3 ;
+1 IF '$DATA(RADFN)
QUIT 0
+2 SET DA(2)=RADFN
+3 IF '$DATA(^RADPT(DA(2),"DT",DA(1),"P",DA,0))
QUIT 0
+4 IF $PIECE(^RADPT(DA(2),"DT",DA(1),"P",DA,0),"^",13)=+Y
QUIT 0
+5 QUIT 1
+6 ;
NODEL ; Do not permit deletion of the PRIMARY DIAGNOSTIC CODE (70.03,
+1 ; 13), PRIMARY INTERPRETING RESIDENT (70.03,12) or PRIMARY
+2 ; INTERPRETING STAFF (70.03,15) if a SECONDARY DIAGNOSTIC CODE
+3 ; multiple (70.03,13.1) is associated with the exam record.
+4 ;
+5 ; P94: WRITE removed; EN^DDIOL added
+6 ;
+7 ;Note: the IF statement has to remain because $T needs to be
+8 ;set in order to properly influence the "DEL" node.
+9 ;
+10 SET RASECCHK=0
SET RASECCHK=$ORDER(^RADPT(DA(2),"DT",DA(1),"P",DA,RAMULT,RASECCHK))
+11 IF RASECCHK
DO EN^DDIOL(" Required","","?0")
+12 KILL RAMULT,RASECCHK
+13 QUIT
+14 ;
PRCCPT() ; Displays the procedure type and CPT code if applicable.
+1 ; This code is called from ^DD(71,0,"ID","WRITE") and rtn RAPROD
+2 NEW RA,RATXT
SET RA(0)=$GET(^(0))
SET RA("I")=+$GET(^("I"))
SET RATXT=""
+3 SET RA=$SELECT('RA("I"):0,DT'>RA("I"):0,1:1)
+4 SET RA(6)=$PIECE(RA(0),U,6)
SET RA(9)=$PIECE(RA(0),U,9)
+5 SET RA(12)=$PIECE(RA(0),U,12)
IF 'RA(12)
SET RA(10)="UNKN "
+6 IF '$DATA(RA(10))
SET RA(10)=$PIECE(^RA(79.2,+RA(12),0),U,3)_" "
+7 IF $LENGTH(RA(10))<5
FOR
SET RA(10)=RA(10)_" "
if $LENGTH(RA(10))>4
QUIT
+8 SET RATXT="("_RA(10)_$SELECT(RA:"Inactive",RA(6)="B":"Broad ",RA(6)="D":"Detailed",RA(6)="P":"Parent ",RA(6)="S":"Series ",1:"Unknown ")_")"
+9 if RA(9)]""
SET RATXT=RATXT_" CPT:"_$PIECE($$NAMCODE^RACPTMSC(RA(9),DT),"^")
+10 QUIT RATXT
INDTCHK(RADA) ; Cannot inactivate a procedure if it is a common procedure
+1 ; with a valid sequence number. Code resides in ^DD(71,100,0)!
+2 ; 'RADA' is the ien of the procedure in file 71. if this procedure is
+3 ; a common procedure i.e, $D(^RAMIS(71.3,"B",RADA)) inform the user that
+4 ; the sequence number must be deleted. This relies on the "AA" xref in
+5 ; the Common Proc. file for the Sequence # fld (#3) 0 node, 4th pce.
+6 NEW RA,RAIEN
SET RAIEN=+$ORDER(^RAMIS(71.3,"B",RADA,0))
+7 SET RA(0)=$GET(^RAMIS(71.3,RAIEN,0))
if RA(0)']""
QUIT
+8 ; obtain the sequence number
SET RA(4)=+$PIECE(RA(0),"^",4)
+9 ; sequence #?
IF $DATA(^RAMIS(71.3,"AA",$$EN3^RAUTL17(RADA),RA(4),RAIEN))
Begin DoDot:1
+10 NEW RATXT
SET RATXT(1)=" "
+11 SET RATXT(2)=" Cannot inactivate - this procedure is currently in the"
+12 SET RATXT(3)=" Rad/Nuc Med Common Procedure file with a sequence"
+13 SET RATXT(4)=" number. Please remove the sequence number thru the"
+14 SET RATXT(5)=" 'Common Procedure Enter/Edit' option before assigning"
+15 SET RATXT(6)=" an inactivation date to this procedure."
+16 SET RATXT(7)=" "
+17 ; display message, can't input ANY date!
DO EN^DDIOL(.RATXT)
KILL X
+18 QUIT
End DoDot:1
+19 QUIT
CPTCHK(RADA) ; Check if the CPT code is inactive nationally.
+1 ; 'RADA' assume the value of +Y passed from the input xform, ^DD(71,9,0)
+2 ; quit if CPT code is active
+3 ;
+4 if $$ACTCODE^RACPTMSC(RADA,DT)
QUIT
+5 NEW RATXT
SET RATXT(1)=" "
+6 SET RATXT(2)=" Warning - Nationally inactive CPT code."
+7 SET RATXT(3)=" "
DO EN^DDIOL(.RATXT)
+8 KILL X
+9 QUIT
+10 ;
VALADM(RAD0,Y,RADT,RAUTH) ;edit validation
+1 ;Used to validate/screen radiopharm dosage administrator,
+2 ; radiopharm prescribing phys, person who measured radiopharm dose,
+3 ;----------------------------------------------------------------------
+4 ; RAD0 : IEN of entry in question for NUC MED EXAM DATA (70.2) file
+5 ; Y : Pointer to the New Person file
+6 ; RADT : Xam Date; if not passed, calculate exam date from file 70.2
+7 ; RAUTH : 1 - only staff/resid, must be auth'zd to write med orders
+8 ; : 0 - staff/resid & tech's
+9 ;----------------------------------------------------------------------
+10 ; Output: '1' authorized to write med orders, else '0'
+11 ;----------------------------------------------------------------------
+12 QUIT $$VALADM^RADD4()
+13 ;
VOL(RAX) ; Validate the format of the value input for volume.
+1 ; RAX must be a number followed by a space then text -or-
+2 ; a number followed by text
+3 ; Input Variable : 'RAX'- user's input
+4 ; Output Variable: null if 'RAX' erroneous, formatted version of 'RAX'
+5 QUIT $$VOL^RADD4()
