RAMAGU13 ;HCIOFO/SG - ORDERS/EXAMS API (MISC UTILITIES) ; 2/10/09 4:11pm
;;5.0;Radiology/Nuclear Medicine;**90**;Mar 16, 1998;Build 20
;
Q
;
;***** CREATES A STUB IN THE NUC MED EXAM DATA FILE (#70.2)
;
; RACASE Examination identifiers
; ^01: IEN of the patient in the file #70 (RADFN)
; ^02: IEN in the REGISTERED EXAMS multiple (RADTI)
; ^03: IEN in the EXAMINATIONS multiple (RACNI)
;
; [RAPROCIEN] IEN of the Radiology procedure. By default
; ($G(RAPROCIEN)'>0), it is loaded from the exam
; record.
;
; [RADTE] Exam date. By default ($G(RADTE)'>0), it is
; loaded from the date/time record of the exam.
;
; [RACN] Case number. By default ($G(RACN)'>0), it is
; loaded from the exam record.
;
; Return Values:
; <0 Error descriptor (see $$ERROR^RAERR)
; 0 The record is not needed
; >0 IEN of the record of the NUC MED EXAM DATA file (#70.2)
;
NMEDSTUB(RACASE,RAPROCIEN,RADTE,RACN) ;
N IENS,RABUF,RAFDA,RAIENLST,RAIENS,RAMSG,RANMDIEN,RARC,TMP
S RARC=0,RAIENS=$$EXAMIENS^RAMAGU04(RACASE)
;
;=== Check parameter values and load default ones if necessary
S TMP="500" ; NUCLEAR MED DATA
S:$G(RACN)'>0 TMP=TMP_";.01" ; CASE NUMBER
S:$G(RAPROCIEN)'>0 TMP=TMP_";2" ; PROCEDURE
D GETS^DIQ(70.03,RAIENS,TMP,"I","RABUF","RAMSG")
Q:$G(DIERR) $$DBS^RAERR("RAMSG",-9,70.03,RAIENS)
S:$G(RACN)'>0 RACN=$G(RABUF(70.03,RAIENS,.01,"I"))
S:$G(RAPROCIEN)'>0 RAPROCIEN=$G(RABUF(70.03,RAIENS,2,"I"))
S RANMDIEN=+$G(RABUF(70.03,RAIENS,500,"I"))
;--- Return IEN of the nuclear medicine record if it exists already
I RANMDIEN>0 Q:$D(^RADPTN(RANMDIEN)) RANMDIEN
;--- Exam date/time
I $G(RADTE)'>0 D Q:$G(DIERR) $$DBS^RAERR("RAMSG",-9,70.02,IENS)
. S IENS=$P(RAIENS,",",2,4) ; Keep the trailing comma
. S RADTE=$$GET1^DIQ(70.02,IENS,.01,"I",,"RAMSG")
;
;=== Check if the nuclear medicine record is needed
S IENS=+RAPROCIEN_","
;--- Check the value of the RADIOPHARMACEUTICALS USED?
;--- field of the IMAGING TYPE file (#79.2)
S TMP=$$GET1^DIQ(71,IENS,"#12:#5","I",,"RAMSG")
Q:$G(DIERR) $$DBS^RAERR("RAMSG",-9,71,IENS)
Q:TMP'="Y" 0
;--- Check the value of the SUPPRESS RADIOPHARM PROMPT
;--- field of the RAD/NUC MED PROCEDURES file (#71)
S TMP=$$GET1^DIQ(71,IENS,2,"I",,"RAMSG")
Q:$G(DIERR) $$DBS^RAERR("RAMSG",-9,71,IENS)
Q:TMP 0
;
;=== Create the stub record
S IENS="+1,"
S RAFDA(70.2,IENS,.01)=$P(RACASE,U)
S RAFDA(70.2,IENS,2)=RADTE
S RAFDA(70.2,IENS,3)=RACN
D UPDATE^DIE(,"RAFDA","RAIENLST","RAMSG")
Q:$G(DIERR) $$DBS^RAERR("RAMSG",-9,70.2,IENS)
S RANMDIEN=+RAIENLST(1)
;
;=== Store the pointer
D
. ;--- Setup the error handler
. N $ESTACK,$ETRAP D SETDEFEH^RAERR("RARC")
. ;--- Update the exam record
. S RAFDA(70.03,RAIENS,500)=RANMDIEN
. D FILE^DIE(,"RAFDA","RAMSG")
. S:$G(DIERR) RARC=$$DBS^RAERR("RAMSG",-9,70.03,RAIENS)
;--- Remove the stray record if the pointer cannot be stored
I RARC<0 D Q RARC
. N DA,DIK S DIK="^RADPTN(",DA=RANMDIEN D ^DIK
;
;=== Success
Q RANMDIEN
;
;***** SEARCHES FOR THE RAD/NUC MED REASON SYNONYM
;
; REASON Either IEN of a record of the RAD/NUC MED REASON
; file (#75.2) or a valid synonym (see SYNONYM field
; (3) of that file).
;
; [.TYPE] Reference to a local variable where internal and
; external values (separated by "^") of the TYPE OF
; REASON field (2) of the file #75.2 are returned to.
;
; Return Values:
; <0 Error descriptor (see $$ERROR^RAERR)
; >0 IEN of the record in the file #75.2
;
RARSNIEN(REASON,TYPE) ;
N IENS,RABUF,RAMSG,RC,TMP
S TYPE="",RC=$$CHKREQ^RAUTL22("REASON") Q:RC<0 RC
;---
I (+REASON)'=REASON D ;--- Synonym of the reason
. ;--- Find the reason
. D FIND^DIC(75.2,,"@;2IE",,REASON,2,"S",,,"RABUF","RAMSG")
. I $G(DIERR) S RC=$$DBS^RAERR("RAMSG",-9,75.2) Q
. S TMP=+$G(RABUF("DILIST",0))
. ;--- No such synonym on file
. I TMP<1 S RC=$$ERROR^RAERR(-33,,"synonym",75.2) Q
. ;--- Ambiguous synonym
. I TMP>1 S RC=$$ERROR^RAERR(-14,,"synonym",REASON) Q
. ;--- Reason IEN and type
. S TYPE=$G(RABUF("DILIST","ID",1,2,"I"))
. S TYPE=TYPE_U_$G(RABUF("DILIST","ID",1,2,"E"))
. S REASON=+RABUF("DILIST",2,1)
E D ;--- Reason IEN
. S IENS=REASON_","
. D GETS^DIQ(75.2,IENS,"2","EI","RABUF","RAMSG")
. I $G(DIERR) S RC=$$DBS^RAERR("RAMSG",-9,75.2,IENS) Q
. S TYPE=$G(RABUF(75.2,IENS,2,"I"))_U_$G(RABUF(75.2,IENS,2,"E"))
;---
Q $S(RC<0:RC,1:REASON)
;
;***** UPDATES VALUES OF THE MULTIPLE(S)
;
; .RAFDAM Reference to a local variable that stores field
; values prepared for storage (FileMan FDA array)
;
; RAIENS IENS of the main record that multiple values in
; the RAFDAM belong to
;
; [RAFLAGS] Flags for UPDATE^DIE
;
; Return values:
; <0 Error descriptor (see $$ERROR^RAERR)
; 0 Success
;
UPDMULT(RAFDAM,RAIENS,RAFLAGS) ;
N DA,DIK,ERR,IENS,RAFDA,RAMSG,RANODE,RARC,RASUBF
S (RARC,RASUBF)=0,RAFLAGS=$G(RAFLAGS)
F S RASUBF=$O(RAFDAM(RASUBF)) Q:RASUBF'>0 D Q:RARC<0
. K RAFDA,RAMSG M RAFDA(RASUBF)=RAFDAM(RASUBF)
. S IENS=","_RAIENS D DA^DILF(IENS,.DA)
. S DIK=$$ROOT^DILFD(RASUBF,IENS,0,.ERR)
. I $G(ERR)!(DIK="") S RARC=$$ERROR^RAERR(-50,,RASUBF,IENS) Q
. S RANODE=$$CREF^DILF(DIK)
. ;--- Delete the old data
. D IXALL2^DIK ; Delete entries from cross-references
. K @RANODE ; Clear the whole multiple
. ;--- Store the new data
. I $D(RAFDA)>1 D Q:RARC<0
. . D UPDATE^DIE(RAFLAGS,"RAFDA",,"RAMSG")
. . S:$G(DIERR) RARC=$$DBS^RAERR("RAMSG",-9,RASUBF,"*,"_RAIENS)
. ;--- Remove subfile data from the source FDA
. K:RAFLAGS'["S" RAFDAM(RASUBF)
;---
Q $S(RARC<0:RARC,1:0)
;
;***** CHECKS IF THE LONG ACCESSION NUMBER SHOULD BE USED
;
; RAMDIV Radiology division IEN (file #79)
;
; Return values:
; 0 Use short accession number (MMDDYY-NNNNN)
; 1 Use long accession number (SSS-MMDDYY-NNNNN)
;
USLNGACN(RAMDIV) ;
Q:RAMDIV'>0 0
N RAMSG
;--- Check the value of the USE SITE ACCESSION NUMBER? field (.131)
; of the RAD/NUC MED DIVISION file (#79). This field is exported
;--- by the patch RA*5*47. See the data dictionary for details.
Q ($$GET1^DIQ(79,RAMDIV_",",.131,"I",,"RAMSG")="Y")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAMAGU13 6566 printed Sep 23, 2025@20:13:15 Page 2
RAMAGU13 ;HCIOFO/SG - ORDERS/EXAMS API (MISC UTILITIES) ; 2/10/09 4:11pm
+1 ;;5.0;Radiology/Nuclear Medicine;**90**;Mar 16, 1998;Build 20
+2 ;
+3 QUIT
+4 ;
+5 ;***** CREATES A STUB IN THE NUC MED EXAM DATA FILE (#70.2)
+6 ;
+7 ; RACASE Examination identifiers
+8 ; ^01: IEN of the patient in the file #70 (RADFN)
+9 ; ^02: IEN in the REGISTERED EXAMS multiple (RADTI)
+10 ; ^03: IEN in the EXAMINATIONS multiple (RACNI)
+11 ;
+12 ; [RAPROCIEN] IEN of the Radiology procedure. By default
+13 ; ($G(RAPROCIEN)'>0), it is loaded from the exam
+14 ; record.
+15 ;
+16 ; [RADTE] Exam date. By default ($G(RADTE)'>0), it is
+17 ; loaded from the date/time record of the exam.
+18 ;
+19 ; [RACN] Case number. By default ($G(RACN)'>0), it is
+20 ; loaded from the exam record.
+21 ;
+22 ; Return Values:
+23 ; <0 Error descriptor (see $$ERROR^RAERR)
+24 ; 0 The record is not needed
+25 ; >0 IEN of the record of the NUC MED EXAM DATA file (#70.2)
+26 ;
NMEDSTUB(RACASE,RAPROCIEN,RADTE,RACN) ;
+1 NEW IENS,RABUF,RAFDA,RAIENLST,RAIENS,RAMSG,RANMDIEN,RARC,TMP
+2 SET RARC=0
SET RAIENS=$$EXAMIENS^RAMAGU04(RACASE)
+3 ;
+4 ;=== Check parameter values and load default ones if necessary
+5 ; NUCLEAR MED DATA
SET TMP="500"
+6 ; CASE NUMBER
if $GET(RACN)'>0
SET TMP=TMP_";.01"
+7 ; PROCEDURE
if $GET(RAPROCIEN)'>0
SET TMP=TMP_";2"
+8 DO GETS^DIQ(70.03,RAIENS,TMP,"I","RABUF","RAMSG")
+9 if $GET(DIERR)
QUIT $$DBS^RAERR("RAMSG",-9,70.03,RAIENS)
+10 if $GET(RACN)'>0
SET RACN=$GET(RABUF(70.03,RAIENS,.01,"I"))
+11 if $GET(RAPROCIEN)'>0
SET RAPROCIEN=$GET(RABUF(70.03,RAIENS,2,"I"))
+12 SET RANMDIEN=+$GET(RABUF(70.03,RAIENS,500,"I"))
+13 ;--- Return IEN of the nuclear medicine record if it exists already
+14 IF RANMDIEN>0
if $DATA(^RADPTN(RANMDIEN))
QUIT RANMDIEN
+15 ;--- Exam date/time
+16 IF $GET(RADTE)'>0
Begin DoDot:1
+17 ; Keep the trailing comma
SET IENS=$PIECE(RAIENS,",",2,4)
+18 SET RADTE=$$GET1^DIQ(70.02,IENS,.01,"I",,"RAMSG")
End DoDot:1
if $GET(DIERR)
QUIT $$DBS^RAERR("RAMSG",-9,70.02,IENS)
+19 ;
+20 ;=== Check if the nuclear medicine record is needed
+21 SET IENS=+RAPROCIEN_","
+22 ;--- Check the value of the RADIOPHARMACEUTICALS USED?
+23 ;--- field of the IMAGING TYPE file (#79.2)
+24 SET TMP=$$GET1^DIQ(71,IENS,"#12:#5","I",,"RAMSG")
+25 if $GET(DIERR)
QUIT $$DBS^RAERR("RAMSG",-9,71,IENS)
+26 if TMP'="Y"
QUIT 0
+27 ;--- Check the value of the SUPPRESS RADIOPHARM PROMPT
+28 ;--- field of the RAD/NUC MED PROCEDURES file (#71)
+29 SET TMP=$$GET1^DIQ(71,IENS,2,"I",,"RAMSG")
+30 if $GET(DIERR)
QUIT $$DBS^RAERR("RAMSG",-9,71,IENS)
+31 if TMP
QUIT 0
+32 ;
+33 ;=== Create the stub record
+34 SET IENS="+1,"
+35 SET RAFDA(70.2,IENS,.01)=$PIECE(RACASE,U)
+36 SET RAFDA(70.2,IENS,2)=RADTE
+37 SET RAFDA(70.2,IENS,3)=RACN
+38 DO UPDATE^DIE(,"RAFDA","RAIENLST","RAMSG")
+39 if $GET(DIERR)
QUIT $$DBS^RAERR("RAMSG",-9,70.2,IENS)
+40 SET RANMDIEN=+RAIENLST(1)
+41 ;
+42 ;=== Store the pointer
+43 Begin DoDot:1
+44 ;--- Setup the error handler
+45 NEW $ESTACK,$ETRAP
DO SETDEFEH^RAERR("RARC")
+46 ;--- Update the exam record
+47 SET RAFDA(70.03,RAIENS,500)=RANMDIEN
+48 DO FILE^DIE(,"RAFDA","RAMSG")
+49 if $GET(DIERR)
SET RARC=$$DBS^RAERR("RAMSG",-9,70.03,RAIENS)
End DoDot:1
+50 ;--- Remove the stray record if the pointer cannot be stored
+51 IF RARC<0
Begin DoDot:1
+52 NEW DA,DIK
SET DIK="^RADPTN("
SET DA=RANMDIEN
DO ^DIK
End DoDot:1
QUIT RARC
+53 ;
+54 ;=== Success
+55 QUIT RANMDIEN
+56 ;
+57 ;***** SEARCHES FOR THE RAD/NUC MED REASON SYNONYM
+58 ;
+59 ; REASON Either IEN of a record of the RAD/NUC MED REASON
+60 ; file (#75.2) or a valid synonym (see SYNONYM field
+61 ; (3) of that file).
+62 ;
+63 ; [.TYPE] Reference to a local variable where internal and
+64 ; external values (separated by "^") of the TYPE OF
+65 ; REASON field (2) of the file #75.2 are returned to.
+66 ;
+67 ; Return Values:
+68 ; <0 Error descriptor (see $$ERROR^RAERR)
+69 ; >0 IEN of the record in the file #75.2
+70 ;
RARSNIEN(REASON,TYPE) ;
+1 NEW IENS,RABUF,RAMSG,RC,TMP
+2 SET TYPE=""
SET RC=$$CHKREQ^RAUTL22("REASON")
if RC<0
QUIT RC
+3 ;---
+4 ;--- Synonym of the reason
IF (+REASON)'=REASON
Begin DoDot:1
+5 ;--- Find the reason
+6 DO FIND^DIC(75.2,,"@;2IE",,REASON,2,"S",,,"RABUF","RAMSG")
+7 IF $GET(DIERR)
SET RC=$$DBS^RAERR("RAMSG",-9,75.2)
QUIT
+8 SET TMP=+$GET(RABUF("DILIST",0))
+9 ;--- No such synonym on file
+10 IF TMP<1
SET RC=$$ERROR^RAERR(-33,,"synonym",75.2)
QUIT
+11 ;--- Ambiguous synonym
+12 IF TMP>1
SET RC=$$ERROR^RAERR(-14,,"synonym",REASON)
QUIT
+13 ;--- Reason IEN and type
+14 SET TYPE=$GET(RABUF("DILIST","ID",1,2,"I"))
+15 SET TYPE=TYPE_U_$GET(RABUF("DILIST","ID",1,2,"E"))
+16 SET REASON=+RABUF("DILIST",2,1)
End DoDot:1
+17 ;--- Reason IEN
IF '$TEST
Begin DoDot:1
+18 SET IENS=REASON_","
+19 DO GETS^DIQ(75.2,IENS,"2","EI","RABUF","RAMSG")
+20 IF $GET(DIERR)
SET RC=$$DBS^RAERR("RAMSG",-9,75.2,IENS)
QUIT
+21 SET TYPE=$GET(RABUF(75.2,IENS,2,"I"))_U_$GET(RABUF(75.2,IENS,2,"E"))
End DoDot:1
+22 ;---
+23 QUIT $SELECT(RC<0:RC,1:REASON)
+24 ;
+25 ;***** UPDATES VALUES OF THE MULTIPLE(S)
+26 ;
+27 ; .RAFDAM Reference to a local variable that stores field
+28 ; values prepared for storage (FileMan FDA array)
+29 ;
+30 ; RAIENS IENS of the main record that multiple values in
+31 ; the RAFDAM belong to
+32 ;
+33 ; [RAFLAGS] Flags for UPDATE^DIE
+34 ;
+35 ; Return values:
+36 ; <0 Error descriptor (see $$ERROR^RAERR)
+37 ; 0 Success
+38 ;
UPDMULT(RAFDAM,RAIENS,RAFLAGS) ;
+1 NEW DA,DIK,ERR,IENS,RAFDA,RAMSG,RANODE,RARC,RASUBF
+2 SET (RARC,RASUBF)=0
SET RAFLAGS=$GET(RAFLAGS)
+3 FOR
SET RASUBF=$ORDER(RAFDAM(RASUBF))
if RASUBF'>0
QUIT
Begin DoDot:1
+4 KILL RAFDA,RAMSG
MERGE RAFDA(RASUBF)=RAFDAM(RASUBF)
+5 SET IENS=","_RAIENS
DO DA^DILF(IENS,.DA)
+6 SET DIK=$$ROOT^DILFD(RASUBF,IENS,0,.ERR)
+7 IF $GET(ERR)!(DIK="")
SET RARC=$$ERROR^RAERR(-50,,RASUBF,IENS)
QUIT
+8 SET RANODE=$$CREF^DILF(DIK)
+9 ;--- Delete the old data
+10 ; Delete entries from cross-references
DO IXALL2^DIK
+11 ; Clear the whole multiple
KILL @RANODE
+12 ;--- Store the new data
+13 IF $DATA(RAFDA)>1
Begin DoDot:2
+14 DO UPDATE^DIE(RAFLAGS,"RAFDA",,"RAMSG")
+15 if $GET(DIERR)
SET RARC=$$DBS^RAERR("RAMSG",-9,RASUBF,"*,"_RAIENS)
End DoDot:2
if RARC<0
QUIT
+16 ;--- Remove subfile data from the source FDA
+17 if RAFLAGS'["S"
KILL RAFDAM(RASUBF)
End DoDot:1
if RARC<0
QUIT
+18 ;---
+19 QUIT $SELECT(RARC<0:RARC,1:0)
+20 ;
+21 ;***** CHECKS IF THE LONG ACCESSION NUMBER SHOULD BE USED
+22 ;
+23 ; RAMDIV Radiology division IEN (file #79)
+24 ;
+25 ; Return values:
+26 ; 0 Use short accession number (MMDDYY-NNNNN)
+27 ; 1 Use long accession number (SSS-MMDDYY-NNNNN)
+28 ;
USLNGACN(RAMDIV) ;
+1 if RAMDIV'>0
QUIT 0
+2 NEW RAMSG
+3 ;--- Check the value of the USE SITE ACCESSION NUMBER? field (.131)
+4 ; of the RAD/NUC MED DIVISION file (#79). This field is exported
+5 ;--- by the patch RA*5*47. See the data dictionary for details.
+6 QUIT ($$GET1^DIQ(79,RAMDIV_",",.131,"I",,"RAMSG")="Y")
