MAGVORDR ;WOIFO/RRB/BT/PMK/DAC/JSJ - MAGV Order Lookup ; 14 Jul 2021@10:07:45
;;3.0;IMAGING;**118,138,156,307**;Mar 19, 2002;Build 28
;; Per VHA Directive 2004-038, this routine should not be modified.
;; +---------------------------------------------------------------+
;; | Property of the US Government. |
;; | No permission to copy or redistribute this software is given. |
;; | Use of unreleased versions of this software requires the user |
;; | to execute a written test agreement with the VistA Imaging |
;; | Development Office of the Department of Veterans Affairs, |
;; | telephone (301) 734-0100. |
;; | The Food and Drug Administration classifies this software as |
;; | a medical device. As such, it may not be changed in any way. |
;; | Modifications to this software may result in an adulterated |
;; | medical device under 21CFR820, the use of which is considered |
;; | to be a violation of US Federal Statutes. |
;; +---------------------------------------------------------------+
;;
;
; Reference to FIND1^DIC in ICR #2051
; Reference to GET1^DIQ in ICR #2056
; Reference to ACCFIND^RAAPI in ICR #5020
;
;
; Lookup the patient/study in the imaging service's database
; The imaging service, IMGSVC (RAD or CON), and case number, CASENUMB(accession)
; are required variables that must be passed to the LOOKUP subroutine.
;
; Output will be in the form of a string:
;
; Happy case example: 0~DFN~SITE (0~12345~660)
;
; Incorrect accession # format or not present: -1~BAD CASE #
;
; No case on file: -1~NO CASE #
Q
;
LOOKUP(CASENUMB,IMGSVC) ; MAGV Order Lookup
;
N RADATA
;
I "^RAD^CON^LAB^"'[("^"_IMGSVC_"^") Q "-1~INVALID IMAGE SERVICE"
I $G(CASENUMB)="" Q "-1~BAD CASE #"
;
I IMGSVC="RAD" D
. S RADATA=$$RADLKUP(CASENUMB)
. Q
E I IMGSVC="CON" D
. I '$$GMRCIEN^MAGDFCNV(CASENUMB) S RADATA="-1~BAD CASE #" Q
. S RADATA=$$CONLKUP(CASENUMB)
. Q
E I IMGSVC="LAB" D ; P138
. S RADATA=$$LABLKUP(CASENUMB)
. Q
;
Q RADATA
;
RADLKUP(CASENUMB) ; Radiology patient/study lookup
;
N CPTCODE ;-- CPT code for the procedure
N CPTNAME ;-- CPT name for the procedure
N DFN
N EXAMSTS ;-- Exam status (don't post images to CANCELLED exams)
N PROCIEN ;-- radiology procedure ien in ^RAMIS(71)
N RAIX ;----- cross reference subscript for case number lookup
N RADPT1 ;--- first level subscript in ^RADPT
N RADPT2 ;--- second level subscript in ^RADPT (after "DT")
N RADPT3 ;--- third level subscript in ^RADPT (after "P")
N SITE
N I,LIST,VARIABLE,X,Z
;
; find the patient/study in ^RARPT using the Radiology Case Number
;
S X=$S(CASENUMB'["-"!($L($T(ACCFIND^RAAPI))=0):$$OLDCASE(CASENUMB,.LIST),1:$$ACCFIND^RAAPI(CASENUMB,.LIST))
I X'=1 Q "-1~NO CASE #" ; No Case
;
S X=LIST(1) ; two conditions, no accession number & duplicate
S RADPT1=$P(X,"^",1),RADPT2=$P(X,"^",2),RADPT3=$P(X,"^",3)
I RADPT1=""!(RADPT2="")!(RADPT3="") Q "-1~BAD CASE #"
;
I '$D(^RADPT(RADPT1,0)) Q "-1~NO CASE #" ; no patient demographics file pointer
;
; get patient demographics file pointer
S X=^RADPT(RADPT1,0),DFN=$P(X,"^")
S SITE=$P($G(^RADPT(RADPT1,"DT",RADPT2,0)),"^",3)
;
; do not include cancelled exam
S EXAMSTS=$P($G(^RADPT(RADPT1,"DT",RADPT2,"P",RADPT3,0)),"^",3) ; P156 DAC - Fixed undefined error
I EXAMSTS="" Q "-1~BAD CASE #"
S EXAMSTS=$$GET1^DIQ(72,EXAMSTS,.01)
I EXAMSTS="" Q "-1~BAD CASE #"
I EXAMSTS="CANCELLED" Q "-1~NO CASE #"
;
Q "0~"_DFN_"~"_SITE
;
CONLKUP(CASENUMB) ; CPRS Consult/Procedure patient/study lookup
;
N DFN
N EXAMSTS ;-- Exam status (don't post images to CANCELLED exams)
N GMRCIEN
N SITE
;
S GMRCIEN=$$GMRCIEN^MAGDFCNV(CASENUMB)
S DFN=$$GET1^DIQ(123,GMRCIEN,.02,"I")
I DFN="" Q "-1~NO CASE #" ; no patient demographics file pointer
S SITE=$$GET1^DIQ(123,GMRCIEN,.05,"I")
I SITE="" Q "-1~NO CASE #" ; incomplete consult study
;
S EXAMSTS=$$GET1^DIQ(123,GMRCIEN,8) ; check for cancelled exam
I EXAMSTS="CANCELLED" Q "-1~NO CASE #"
;
Q "0~"_DFN_"~"_SITE
;
OLDCASE(CASENUMB,LIST) ; Lookup case numbers using old method
;
S RAIX=$S($D(^RADPT("C")):"C",CASENUMB["-":"ADC",1:"AE") ; for Radiology Patch RA*5*7
S RADPT1=$O(^RADPT(RAIX,CASENUMB,"")) I 'RADPT1 Q 0
S RADPT2=$O(^RADPT(RAIX,CASENUMB,RADPT1,"")) I 'RADPT2 Q 0
S RADPT3=$O(^RADPT(RAIX,CASENUMB,RADPT1,RADPT2,"")) I 'RADPT3 Q 0
S LIST(1)=RADPT1_"^"_RADPT2_"^"_RADPT3
Q 1 ; Success
;
;
LABLKUP(ACNUMB) ; Lab patient/study lookup - P138
N FMYEAR,LRAA,LRDFN,LRSS,IENS,YEAR,CASE,SITE,ABBR ;P307
S ABBR=$P(ACNUMB," ",1),YEAR=$P(ACNUMB," ",2),CASE=$P(ACNUMB," ",3) ;P307
S LRAA=$$FIND1^DIC(68,"","BX",ABBR,"","","ERR") ; get lab area index ;P307
S FMYEAR="3"_YEAR_"0000"
S IENS=CASE_","_FMYEAR_","_LRAA
; lookup in ACCESSION file (#68)
S LRDFN=$$GET1^DIQ(68.02,IENS,.01)
I LRDFN="" Q "-1~PATIENT NOT IN LAB FILE" ; patient not in LAB DATA file (#63)
S SITE=$$GET1^DIQ(68.02,IENS,26,"I")
I $$GET1^DIQ(68.02,IENS,1)'="PATIENT" Q "-1~WRONG PATIENT" ; patient not in PATIENT file (#2)
I $$GET1^DIQ(68.02,IENS,15)'=CASENUMB Q "-1~WRONG SPECIMEN" ; not right specimen
; lookup in LAB DATA file (#63)
I $$GET1^DIQ(63,LRDFN,.02)'="PATIENT" Q "-1~PATIENT NOT ON FILE" ; patient not in PATIENT file (#2)
S DFN=$$GET1^DIQ(63,LRDFN,.03,"I")
Q "0~"_DFN_"~"_SITE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGVORDR 5508 printed Sep 23, 2025@19:46:19 Page 2
MAGVORDR ;WOIFO/RRB/BT/PMK/DAC/JSJ - MAGV Order Lookup ; 14 Jul 2021@10:07:45
+1 ;;3.0;IMAGING;**118,138,156,307**;Mar 19, 2002;Build 28
+2 ;; Per VHA Directive 2004-038, this routine should not be modified.
+3 ;; +---------------------------------------------------------------+
+4 ;; | Property of the US Government. |
+5 ;; | No permission to copy or redistribute this software is given. |
+6 ;; | Use of unreleased versions of this software requires the user |
+7 ;; | to execute a written test agreement with the VistA Imaging |
+8 ;; | Development Office of the Department of Veterans Affairs, |
+9 ;; | telephone (301) 734-0100. |
+10 ;; | The Food and Drug Administration classifies this software as |
+11 ;; | a medical device. As such, it may not be changed in any way. |
+12 ;; | Modifications to this software may result in an adulterated |
+13 ;; | medical device under 21CFR820, the use of which is considered |
+14 ;; | to be a violation of US Federal Statutes. |
+15 ;; +---------------------------------------------------------------+
+16 ;;
+17 ;
+18 ; Reference to FIND1^DIC in ICR #2051
+19 ; Reference to GET1^DIQ in ICR #2056
+20 ; Reference to ACCFIND^RAAPI in ICR #5020
+21 ;
+22 ;
+23 ; Lookup the patient/study in the imaging service's database
+24 ; The imaging service, IMGSVC (RAD or CON), and case number, CASENUMB(accession)
+25 ; are required variables that must be passed to the LOOKUP subroutine.
+26 ;
+27 ; Output will be in the form of a string:
+28 ;
+29 ; Happy case example: 0~DFN~SITE (0~12345~660)
+30 ;
+31 ; Incorrect accession # format or not present: -1~BAD CASE #
+32 ;
+33 ; No case on file: -1~NO CASE #
+34 QUIT
+35 ;
LOOKUP(CASENUMB,IMGSVC) ; MAGV Order Lookup
+1 ;
+2 NEW RADATA
+3 ;
+4 IF "^RAD^CON^LAB^"'[("^"_IMGSVC_"^")
QUIT "-1~INVALID IMAGE SERVICE"
+5 IF $GET(CASENUMB)=""
QUIT "-1~BAD CASE #"
+6 ;
+7 IF IMGSVC="RAD"
Begin DoDot:1
+8 SET RADATA=$$RADLKUP(CASENUMB)
+9 QUIT
End DoDot:1
+10 IF '$TEST
IF IMGSVC="CON"
Begin DoDot:1
+11 IF '$$GMRCIEN^MAGDFCNV(CASENUMB)
SET RADATA="-1~BAD CASE #"
QUIT
+12 SET RADATA=$$CONLKUP(CASENUMB)
+13 QUIT
End DoDot:1
+14 ; P138
IF '$TEST
IF IMGSVC="LAB"
Begin DoDot:1
+15 SET RADATA=$$LABLKUP(CASENUMB)
+16 QUIT
End DoDot:1
+17 ;
+18 QUIT RADATA
+19 ;
RADLKUP(CASENUMB) ; Radiology patient/study lookup
+1 ;
+2 ;-- CPT code for the procedure
NEW CPTCODE
+3 ;-- CPT name for the procedure
NEW CPTNAME
+4 NEW DFN
+5 ;-- Exam status (don't post images to CANCELLED exams)
NEW EXAMSTS
+6 ;-- radiology procedure ien in ^RAMIS(71)
NEW PROCIEN
+7 ;----- cross reference subscript for case number lookup
NEW RAIX
+8 ;--- first level subscript in ^RADPT
NEW RADPT1
+9 ;--- second level subscript in ^RADPT (after "DT")
NEW RADPT2
+10 ;--- third level subscript in ^RADPT (after "P")
NEW RADPT3
+11 NEW SITE
+12 NEW I,LIST,VARIABLE,X,Z
+13 ;
+14 ; find the patient/study in ^RARPT using the Radiology Case Number
+15 ;
+16 SET X=$SELECT(CASENUMB'["-"!($LENGTH($TEXT(ACCFIND^RAAPI))=0):$$OLDCASE(CASENUMB,.LIST),1:$$ACCFIND^RAAPI(CASENUMB,.LIST))
+17 ; No Case
IF X'=1
QUIT "-1~NO CASE #"
+18 ;
+19 ; two conditions, no accession number & duplicate
SET X=LIST(1)
+20 SET RADPT1=$PIECE(X,"^",1)
SET RADPT2=$PIECE(X,"^",2)
SET RADPT3=$PIECE(X,"^",3)
+21 IF RADPT1=""!(RADPT2="")!(RADPT3="")
QUIT "-1~BAD CASE #"
+22 ;
+23 ; no patient demographics file pointer
IF '$DATA(^RADPT(RADPT1,0))
QUIT "-1~NO CASE #"
+24 ;
+25 ; get patient demographics file pointer
+26 SET X=^RADPT(RADPT1,0)
SET DFN=$PIECE(X,"^")
+27 SET SITE=$PIECE($GET(^RADPT(RADPT1,"DT",RADPT2,0)),"^",3)
+28 ;
+29 ; do not include cancelled exam
+30 ; P156 DAC - Fixed undefined error
SET EXAMSTS=$PIECE($GET(^RADPT(RADPT1,"DT",RADPT2,"P",RADPT3,0)),"^",3)
+31 IF EXAMSTS=""
QUIT "-1~BAD CASE #"
+32 SET EXAMSTS=$$GET1^DIQ(72,EXAMSTS,.01)
+33 IF EXAMSTS=""
QUIT "-1~BAD CASE #"
+34 IF EXAMSTS="CANCELLED"
QUIT "-1~NO CASE #"
+35 ;
+36 QUIT "0~"_DFN_"~"_SITE
+37 ;
CONLKUP(CASENUMB) ; CPRS Consult/Procedure patient/study lookup
+1 ;
+2 NEW DFN
+3 ;-- Exam status (don't post images to CANCELLED exams)
NEW EXAMSTS
+4 NEW GMRCIEN
+5 NEW SITE
+6 ;
+7 SET GMRCIEN=$$GMRCIEN^MAGDFCNV(CASENUMB)
+8 SET DFN=$$GET1^DIQ(123,GMRCIEN,.02,"I")
+9 ; no patient demographics file pointer
IF DFN=""
QUIT "-1~NO CASE #"
+10 SET SITE=$$GET1^DIQ(123,GMRCIEN,.05,"I")
+11 ; incomplete consult study
IF SITE=""
QUIT "-1~NO CASE #"
+12 ;
+13 ; check for cancelled exam
SET EXAMSTS=$$GET1^DIQ(123,GMRCIEN,8)
+14 IF EXAMSTS="CANCELLED"
QUIT "-1~NO CASE #"
+15 ;
+16 QUIT "0~"_DFN_"~"_SITE
+17 ;
OLDCASE(CASENUMB,LIST) ; Lookup case numbers using old method
+1 ;
+2 ; for Radiology Patch RA*5*7
SET RAIX=$SELECT($DATA(^RADPT("C")):"C",CASENUMB["-":"ADC",1:"AE")
+3 SET RADPT1=$ORDER(^RADPT(RAIX,CASENUMB,""))
IF 'RADPT1
QUIT 0
+4 SET RADPT2=$ORDER(^RADPT(RAIX,CASENUMB,RADPT1,""))
IF 'RADPT2
QUIT 0
+5 SET RADPT3=$ORDER(^RADPT(RAIX,CASENUMB,RADPT1,RADPT2,""))
IF 'RADPT3
QUIT 0
+6 SET LIST(1)=RADPT1_"^"_RADPT2_"^"_RADPT3
+7 ; Success
QUIT 1
+8 ;
+9 ;
LABLKUP(ACNUMB) ; Lab patient/study lookup - P138
+1 ;P307
NEW FMYEAR,LRAA,LRDFN,LRSS,IENS,YEAR,CASE,SITE,ABBR
+2 ;P307
SET ABBR=$PIECE(ACNUMB," ",1)
SET YEAR=$PIECE(ACNUMB," ",2)
SET CASE=$PIECE(ACNUMB," ",3)
+3 ; get lab area index ;P307
SET LRAA=$$FIND1^DIC(68,"","BX",ABBR,"","","ERR")
+4 SET FMYEAR="3"_YEAR_"0000"
+5 SET IENS=CASE_","_FMYEAR_","_LRAA
+6 ; lookup in ACCESSION file (#68)
+7 SET LRDFN=$$GET1^DIQ(68.02,IENS,.01)
+8 ; patient not in LAB DATA file (#63)
IF LRDFN=""
QUIT "-1~PATIENT NOT IN LAB FILE"
+9 SET SITE=$$GET1^DIQ(68.02,IENS,26,"I")
+10 ; patient not in PATIENT file (#2)
IF $$GET1^DIQ(68.02,IENS,1)'="PATIENT"
QUIT "-1~WRONG PATIENT"
+11 ; not right specimen
IF $$GET1^DIQ(68.02,IENS,15)'=CASENUMB
QUIT "-1~WRONG SPECIMEN"
+12 ; lookup in LAB DATA file (#63)
+13 ; patient not in PATIENT file (#2)
IF $$GET1^DIQ(63,LRDFN,.02)'="PATIENT"
QUIT "-1~PATIENT NOT ON FILE"
+14 SET DFN=$$GET1^DIQ(63,LRDFN,.03,"I")
+15 QUIT "0~"_DFN_"~"_SITE
