MAGJUTL1 ;WIRMFO/JHC - VistARad subroutines for RPC calls ; 10/17/2022
;;3.0;IMAGING;**22,18,65,76,101,133,341**;Dec 21, 2022;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 EN1^RAO7PC1 in ICR #2268
; Reference to SETDATA^RAO7PC1A in ICR #3509
; Reference to D^RAUTL in ICR #3507
;; ISI IMAGING;**99,102**
Q
;<*>Notes on possible changes to ^RAO7PC1/1A for fetching rad pkg data:
; 1) Return also: Exam Status IEN, Order Request Urgency, & Pre-Op Date
; 2) Allow to retrieve one specific exam; e.g. modify SETDATA^RAO7PC1A
; to act as a true subrtn, W/ params for RADFN, RADTI, & RACNI--if
; passed, then only the one exam would be returned
;
GETEXAM3(DFN,BEGDT,ENDT,MAGRACNT,MAGRET,MORE,LIMEXAMS) ; Get data for all exams for a
; pt within a date range
; limit to LIMEXAMS entries--note, only PREFETCH & Auto-route Priors use this
; Input:
; DFN -- Patient DFN
; BEGDT -- Opt, earliest date desired
; ENDT -- Opt, latest date desired
; MAGRACNT -- Opt, pass by ref to init counter to ref return data in ^TMP (see GETEXSET)
; MORE -- Opt, If True, check for additional exams for pt
; LIMEXAMS -- Opt, limit # exams to return
; Return:
; MAGRACNT -- highest counter for return data
; MAGRET -- 1/0: exam was/not found
; MORE -- more exams exist for pt on & B4 this date
; ^TMP -- data returned (see GETEXSET)
;
I '$D(DT) N DIQUIET S DIQUIET=1 D DT^DICRW
S LIMEXAMS=+$G(LIMEXAMS)
S:$G(BEGDT)="" BEGDT=2010101 S:$G(ENDT)="" ENDT=DT ; default all dates
N MORECHK S MORECHK=+$G(MORE)
S MAGRACNT=+$G(MAGRACNT),MAGRET=0,MORE=0 ; Init return data
I BEGDT>ENDT S X=ENDT,ENDT=BEGDT,BEGDT=X
I '(DFN&BEGDT&ENDT) Q
K ^TMP($J,"RAE1") D EN1^RAO7PC1(DFN,BEGDT,ENDT,LIMEXAMS)
N EXID,TMP,EX1,EX2 S EXID=0
F MAGRET=0:1 S EXID=$O(^TMP($J,"RAE1",DFN,EXID)) Q:'EXID S TMP($P(EXID,"-"),$P(EXID,"-",2))=EXID
S (EX1,EX2)=""
F S EX1=$O(TMP(EX1)) Q:'EX1 F S EX2=$O(TMP(EX1,EX2)) Q:'EX2 D GETEXSET(DFN,TMP(EX1,EX2),"")
K ^TMP($J,"RAE1")
I 'MORECHK Q ; all done; else indicate if pt has more exams
N DTI,CNI,STS,DTCHK
I 'MAGRET S DTI=9999999.9999-BEGDT,CNI=0 ; no exam found in orig dt range
E S X=^TMP($J,"MAGRAEX",MAGRACNT,1),DTI=$P(X,U,2),CNI=$P(X,U,3) ; last exam processed
; loop thru addl exams til find one that is NOT Cancelled
MORE1 F S CNI=$O(^RADPT(DFN,"DT",DTI,"P",CNI)) Q:'CNI S STS=$P($G(^(CNI,0)),U,3) I STS]"" D Q:MORE
. Q:($P($G(^RA(72,STS,0)),U,3)=0) ; Canceled--keep looking
. S DTCHK=9999999.9999-DTI D EN1^RAO7PC1(DFN,DTCHK,DTCHK,1) ; verify there is at least one "good" exam for this date (Remedy #200480)
. I +$O(^TMP($J,"RAE1",DFN,0)) S MORE=1
. K ^TMP($J,"RAE1")
I 'MORE S DTI=$O(^RADPT(DFN,"DT",DTI)),CNI=0 G MORE1:DTI
I MORE S MORE=9999999.9999-DTI\1
Q
;
GETEXAM2(DFN,DTI,CNI,MAGRACNT,MAGRET) ; Fetch data for one exam
;Input:
; DFN -- Pt DFN
; DTI -- Internal Date pointer to Rad exam
; CNI -- Case pointer to Rad exam
; MAGRACNT -- Opt, pass by ref to init counter for return data in ^TMP (see GETEXSET)
; Return:
; MAGRACNT -- highest counter for return data
; MAGRET -- 1/0: exam was/not found
; ^TMP -- data returned (see GETEXSET)
;
; This subroutine calls RAO7PC1A directly to fetch exam data
; which is returned in ^TMP($J,"RAE1",DFN,DTI_"-"_CNI).
; RAO7PC1A currently returns ALL exams filed under one DTI,
; but this subroutine returns the single exam for the input DTI, CNI
;
N RADFN,RACNT,RAIBDT,RAEXN,RAXIT ; Vars input to RAO7PC1A
S RADFN=DFN,RACNT=0,RAIBDT=DTI,RAEXN=0,RAXIT=0
; other Vars set by RAO7PC1A:
N RABNOR,RACSE,RADIAG,RANO,RAPRC,RAREX,RARPT,RARPTST,RASTNM,RAXAM,RAXID
N RABNORMR,RACPT
S MAGRACNT=+$G(MAGRACNT)
K ^TMP($J,"RAE1") D SETDATA^RAO7PC1A
S MAGRET=RACNT Q:'RACNT ; no exams found
D GETEXSET(DFN,DTI_"-"_CNI,.X)
I 'X S MAGRET=0 ; no exam for this CNI
K ^TMP($J,"RAE1")
Q
;
GETEXSET(RADFN,EXID,MAGRET) ;
; Used by GETEXAM* subroutines above to set up rad data for vrad
; Input:
; RADFN -- Pt DFN
; EXID --- RADTI_"-"_RACNI, pointers to Rad exam
; Output:
; MAGRET- 1/0: an exam was/was not filed
; ^TMP($J,"MAGRAEX",MAGRACNT)=Data String (see code at end)
; MAGRACNT described in above subroutines
;
N RACN,RACNI,RADATA,RADATE,RADTE,RADTI,RADTPRT,RAELOC,RANME
N RAPRC,RARPT,RASSN,RAST,RASTORD,RASTP,RASTNM,RACPT,IMTYPABB,PROCMOD
N DAYCASE,REQLOC,REQLOCN,REQLOCA,REQLOCT,RIST,RIST1,RIST2,COMPLIC
N RADIV,RISTISME,REQWARD,RASTCAT,CPTMOD,LRFLAG,MODTXT,LONGACN,TECH
N MEDS,RDIOPHARM
N ASIGINI,ASIGNOTE,ASIGDUZ,FAVKWD1,FAVKWD2,FAVNOTE,PTAGE,PTDOB,PTSEX ; ISI
N RPTSTS ; ISI
S MAGRET=0,RADTI=$P(EXID,"-"),RACNI=$P(EXID,"-",2)
Q:'(RADTI&RACNI)
S RADIV=""
S RADATA=$G(^TMP($J,"RAE1",RADFN,EXID))
Q:RADATA="" ; no exam for this EXID
S RARPT=$P(RADATA,U,5)
S X=$P(RADATA,U,6),RASTORD=$P(X,"~"),RASTNM=$P(X,"~",2)
S X=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),COMPLIC=$D(^("COMP")),PROCMOD=$D(^("M")),CPTMOD=$D(^("CMOD")),TECH=$D(^("TC")),MEDS=$D(^("RX")) ; ICR #1172 (Private)
S RAST=$P(X,U,3),REQLOC=$P(X,U,22),RIST1=$P(X,U,12),RIST2=$P(X,U,15),COMPLIC=$P(X,U,16)_"~"_COMPLIC
S REQWARD=$P(X,U,6),LONGACN=$P(X,U,31),RDIOPHARM=$P(X,U,28) ; ICR #1172 (Private)
; ISI begin ...
S (FAVKWD1,FAVKWD2,FAVNOTE)="" ; values are placeholders only inside this program
S (ASIGINI,ASIGNOTE,ASIGDUZ)=""
I $$UJOCHECK^ISIJUTL9() D ; not implemented in VA--future mod required to store in ISI file (tbd)
. S X=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"ISI")) I +X D
. . S ASIGDUZ=+X,ASIGNOTE=$P(X,U,2)
. . S ASIGINI=$$USERINF^MAGJUTL3(ASIGDUZ,1) ; assignee initials
S RPTSTS="No Report" I +RARPT D
. S X=$P($G(^RARPT(RARPT,0)),U,5)
. I X]"" S RPTSTS=$S(X="V":"VERIFIED",X="D":"DRAFT",X="R":"REL./NOT VERIF.",X="PD":"PROBLEM DRAFT",X="EF":"ELECTRONICALLY FILED",X="X":"DELETED")
; ISI ... end
N CT,MODS,IEN,TT ; Process Proc/CPT Modifier info
S CT=0
I PROCMOD D
. S IEN=0
. F S IEN=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",IEN)) Q:'IEN S X=$P($G(^(IEN,0)),U) I X D
. . S X=$P($G(^RAMIS(71.2,X,0)),U) Q:X="" S X=$$TRIM(X)
. . S X=$S(X="BILATERAL EXAM":"BILAT",1:X)
. . S CT=CT+1,MODS(CT)=X
I CPTMOD D
. S IEN=0
. F S IEN=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",IEN)) Q:'IEN S X=$P($G(^(IEN,0)),U) I X D
. . S X=$P($$MOD^ICPTMOD(X,"I"),U,3) Q:X="" S X=$$TRIM(X)
. . S X=$S(X="LEFT SIDE":"LEFT",X="RIGHT SIDE":"RIGHT",X="BILATERAL PROCEDURE":"BILAT",1:X)
. . S CT=CT+1,MODS(CT)=X
S MODTXT="",LRFLAG=0 K TT
I CT F I=1:1:CT S X=MODS(I) D
. ; eliminate redundant values for L/R/Bilat (TT), & track L/R for prior matching (LRFLAG)
. S T=(X="LEFT") I T,$D(TT(1)) Q ; already got it
. I 'T S T=(X="RIGHT") I T S T=2 I T,$D(TT(2)) Q ; ditto
. I 'T S T=(X="BILAT") I T S T=3 I T,$D(TT(3)) Q ; ditto
. I T S TT(T)="",MODTXT=X_$S(MODTXT="":"",1:";")_MODTXT ; force L/R/Bilat to left end of string ..
. E S MODTXT=MODTXT_$S(MODTXT="":"",1:";")_X ; .. so is easier to spot in displayed column
. I 'LRFLAG S:T LRFLAG=T
. E I T S:(LRFLAG'=T) LRFLAG=3 ; L&R or Bilat--ignore result
S LRFLAG=$S(LRFLAG=1:"L",LRFLAG=2:"R",1:"") ; Left/Right indicator
I 'TECH S TECH=""
E D
. S IEN=0,TECH="" N T
. F S IEN=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",IEN)) Q:'IEN S X=$P($G(^(IEN,0)),U) I X S T(X)=""
. I $D(T) S T="" F S T=$O(T(T)) Q:T="" S X=$P($G(^VA(200,T,0)),U,2) I X]"" S TECH=TECH_$S(TECH="":"",1:"~")_X
S RADIV=$P(^RADPT(RADFN,"DT",RADTI,0),U,3)
K DIC,DR,DA,DIQ
I 'REQLOC S (REQLOCN,REQLOCT,REQLOCA)=""
E D
. S X=$G(^SC(REQLOC,0)),REQLOCN=$P(X,U),REQLOCA=$P(X,U,2)
. S:REQLOCA="" REQLOCA=REQLOCN
. S DIC="44",DR="2",DA=REQLOC,DIQ="REQLOCT" D EN^DIQ1 K DIC,DR,DA,DIQ
. S REQLOCT=REQLOCT(44,REQLOC,2)
I REQWARD]"" S DIC="42",DR=".01",DA=REQWARD,DIQ="REQWARD" D EN^DIQ1 K DIC,DR,DA,DIQ S REQWARD=REQWARD(42,REQWARD,.01)
S X=$$RIST(RIST1,RIST2),RIST=$P(X,U),RISTISME=$P(X,U,2)
S RADTE=9999999.9999-RADTI,(RADTPRT,Y)=RADTE D D^RAUTL S RADATE=Y
S RADTPRT=$E(RADTPRT,4,5)_"/"_$E(RADTPRT,6,7)_"/"_$E(RADTPRT,2,3)
S RAPRC=$E($P(RADATA,U),1,40),RACN=$P(RADATA,U,2),RAELOC=$P(RADATA,U,7)
S IMTYPABB=$P($P(RADATA,U,8),"~"),RACPT=$P(RADATA,U,10)
S DAYCASE=$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_RACN
I LONGACN]"" S DAYCASE=LONGACN
S RASTP=RASTNM,RASTCAT=""
I RAST S RASTCAT=$P($G(^RA(72,RAST,0)),U,9)
S RANME=$P(^DPT(RADFN,0),U),PTSEX=$P(^(0),U,2),PTDOB=$P(^(0),U,3),PTAGE="" ; ISI
S DFN=RADFN D PID^VADPT6 S RASSN=$S(VAERR:"Unknown",1:VA("PID"))
K VA("PID"),VA("BID"),VAERR
S MAGRACNT=$G(MAGRACNT)+1
I MAGRACNT=1 K ^TMP($J,"MAGRAEX")
S ^TMP($J,"MAGRAEX",MAGRACNT,1)=RADFN_U_RADTI_U_RACNI_U_$E(RANME,1,30)_U_RASSN_U_RADATE_U_RADTE_U_RACN_U_$E(RAPRC,1,35)_U_RARPT_U_RAST_U_DAYCASE_U_RAELOC_U_RASTP_U_RASTORD_U_RADTPRT_U_RACPT_U_IMTYPABB
S ^TMP($J,"MAGRAEX",MAGRACNT,2)=REQLOCA_U_$E(REQLOCN,1,25)_U_RIST_U_COMPLIC_U_RADIV_U_$P($$IMGSIT(RADIV),U,2)_U_RISTISME_U_MODTXT_U_REQLOCT_U_REQWARD_U_RASTCAT_U_LRFLAG_U_TECH_U_MEDS_U_RDIOPHARM
S ^TMP($J,"MAGRAEX",MAGRACNT,"ISI")=ASIGINI_U_ASIGNOTE_U_ASIGDUZ_U_FAVKWD1_U_FAVKWD2_U_FAVNOTE_U_PTAGE_U_PTSEX_U_PTDOB_U_RPTSTS ; ISI
S MAGRET=1
Q
;
RIST(RIST1,RIST2) ; return Interp Radiologist info
S RIST1=$G(RIST1),RIST2=$G(RIST2)
N RIST,RISTISME
S (RIST,RISTISME)=""
I RIST1!RIST2 D
. I RIST1 S RISTISME=RIST1 S RIST=$$USERINF^MAGJUTL3(RIST1,1)
. I RIST2 S RISTISME=$S('RISTISME:RIST2,1:RISTISME_"~"_RIST2) S RIST2=$$USERINF^MAGJUTL3(RIST2,1)
. I RIST]"" S RIST=RIST_$S(RIST2]"":"/"_RIST2,1:"")
. E S RIST=RIST2
Q RIST_U_RISTISME
;
IMGSIT(DIV,DFLT) ; Return Imaging Site code for input Division
; From 2006.1: IEN ^ Site Code ^ Parent_DIV
I DIV]"" D
. N IEN I $D(^MAG(2006.1,"B",DIV)) S IEN=$O(^(DIV,"")) I IEN
. E I $G(DFLT) S IEN=$O(^MAG(2006.1,0)) ; Dflt to 1st if requested
. E S X="" Q
. S X=^MAG(2006.1,IEN,0),X=IEN_U_$P(X,U,9)_U_$P(X,U)
Q X
;
TRIM(X) ; Trim trailing spaces from X
I $G(X)]"" D
. F I=$L(X):-1:0 I $E(X,I)'=" " Q
. I I S X=$E(X,1,I)
. E S X=""
Q:$Q X Q
;
END Q ;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGJUTL1 11145 printed Sep 23, 2025@19:43:16 Page 2
MAGJUTL1 ;WIRMFO/JHC - VistARad subroutines for RPC calls ; 10/17/2022
+1 ;;3.0;IMAGING;**22,18,65,76,101,133,341**;Dec 21, 2022;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 ;; | |
+11 ;; | The Food and Drug Administration classifies this software as |
+12 ;; | a medical device. As such, it may not be changed in any way. |
+13 ;; | Modifications to this software may result in an adulterated |
+14 ;; | medical device under 21CFR820, the use of which is considered |
+15 ;; | to be a violation of US Federal Statutes. |
+16 ;; +---------------------------------------------------------------+
+17 ;;
+18 ; Reference to EN1^RAO7PC1 in ICR #2268
+19 ; Reference to SETDATA^RAO7PC1A in ICR #3509
+20 ; Reference to D^RAUTL in ICR #3507
+21 ;; ISI IMAGING;**99,102**
+22 QUIT
+23 ;<*>Notes on possible changes to ^RAO7PC1/1A for fetching rad pkg data:
+24 ; 1) Return also: Exam Status IEN, Order Request Urgency, & Pre-Op Date
+25 ; 2) Allow to retrieve one specific exam; e.g. modify SETDATA^RAO7PC1A
+26 ; to act as a true subrtn, W/ params for RADFN, RADTI, & RACNI--if
+27 ; passed, then only the one exam would be returned
+28 ;
GETEXAM3(DFN,BEGDT,ENDT,MAGRACNT,MAGRET,MORE,LIMEXAMS) ; Get data for all exams for a
+1 ; pt within a date range
+2 ; limit to LIMEXAMS entries--note, only PREFETCH & Auto-route Priors use this
+3 ; Input:
+4 ; DFN -- Patient DFN
+5 ; BEGDT -- Opt, earliest date desired
+6 ; ENDT -- Opt, latest date desired
+7 ; MAGRACNT -- Opt, pass by ref to init counter to ref return data in ^TMP (see GETEXSET)
+8 ; MORE -- Opt, If True, check for additional exams for pt
+9 ; LIMEXAMS -- Opt, limit # exams to return
+10 ; Return:
+11 ; MAGRACNT -- highest counter for return data
+12 ; MAGRET -- 1/0: exam was/not found
+13 ; MORE -- more exams exist for pt on & B4 this date
+14 ; ^TMP -- data returned (see GETEXSET)
+15 ;
+16 IF '$DATA(DT)
NEW DIQUIET
SET DIQUIET=1
DO DT^DICRW
+17 SET LIMEXAMS=+$GET(LIMEXAMS)
+18 ; default all dates
if $GET(BEGDT)=""
SET BEGDT=2010101
if $GET(ENDT)=""
SET ENDT=DT
+19 NEW MORECHK
SET MORECHK=+$GET(MORE)
+20 ; Init return data
SET MAGRACNT=+$GET(MAGRACNT)
SET MAGRET=0
SET MORE=0
+21 IF BEGDT>ENDT
SET X=ENDT
SET ENDT=BEGDT
SET BEGDT=X
+22 IF '(DFN&BEGDT&ENDT)
QUIT
+23 KILL ^TMP($JOB,"RAE1")
DO EN1^RAO7PC1(DFN,BEGDT,ENDT,LIMEXAMS)
+24 NEW EXID,TMP,EX1,EX2
SET EXID=0
+25 FOR MAGRET=0:1
SET EXID=$ORDER(^TMP($JOB,"RAE1",DFN,EXID))
if 'EXID
QUIT
SET TMP($PIECE(EXID,"-"),$PIECE(EXID,"-",2))=EXID
+26 SET (EX1,EX2)=""
+27 FOR
SET EX1=$ORDER(TMP(EX1))
if 'EX1
QUIT
FOR
SET EX2=$ORDER(TMP(EX1,EX2))
if 'EX2
QUIT
DO GETEXSET(DFN,TMP(EX1,EX2),"")
+28 KILL ^TMP($JOB,"RAE1")
+29 ; all done; else indicate if pt has more exams
IF 'MORECHK
QUIT
+30 NEW DTI,CNI,STS,DTCHK
+31 ; no exam found in orig dt range
IF 'MAGRET
SET DTI=9999999.9999-BEGDT
SET CNI=0
+32 ; last exam processed
IF '$TEST
SET X=^TMP($JOB,"MAGRAEX",MAGRACNT,1)
SET DTI=$PIECE(X,U,2)
SET CNI=$PIECE(X,U,3)
+33 ; loop thru addl exams til find one that is NOT Cancelled
MORE1 FOR
SET CNI=$ORDER(^RADPT(DFN,"DT",DTI,"P",CNI))
if 'CNI
QUIT
SET STS=$PIECE($GET(^(CNI,0)),U,3)
IF STS]""
Begin DoDot:1
+1 ; Canceled--keep looking
if ($PIECE($GET(^RA(72,STS,0)),U,3)=0)
QUIT
+2 ; verify there is at least one "good" exam for this date (Remedy #200480)
SET DTCHK=9999999.9999-DTI
DO EN1^RAO7PC1(DFN,DTCHK,DTCHK,1)
+3 IF +$ORDER(^TMP($JOB,"RAE1",DFN,0))
SET MORE=1
+4 KILL ^TMP($JOB,"RAE1")
End DoDot:1
if MORE
QUIT
+5 IF 'MORE
SET DTI=$ORDER(^RADPT(DFN,"DT",DTI))
SET CNI=0
if DTI
GOTO MORE1
+6 IF MORE
SET MORE=9999999.9999-DTI\1
+7 QUIT
+8 ;
GETEXAM2(DFN,DTI,CNI,MAGRACNT,MAGRET) ; Fetch data for one exam
+1 ;Input:
+2 ; DFN -- Pt DFN
+3 ; DTI -- Internal Date pointer to Rad exam
+4 ; CNI -- Case pointer to Rad exam
+5 ; MAGRACNT -- Opt, pass by ref to init counter for return data in ^TMP (see GETEXSET)
+6 ; Return:
+7 ; MAGRACNT -- highest counter for return data
+8 ; MAGRET -- 1/0: exam was/not found
+9 ; ^TMP -- data returned (see GETEXSET)
+10 ;
+11 ; This subroutine calls RAO7PC1A directly to fetch exam data
+12 ; which is returned in ^TMP($J,"RAE1",DFN,DTI_"-"_CNI).
+13 ; RAO7PC1A currently returns ALL exams filed under one DTI,
+14 ; but this subroutine returns the single exam for the input DTI, CNI
+15 ;
+16 ; Vars input to RAO7PC1A
NEW RADFN,RACNT,RAIBDT,RAEXN,RAXIT
+17 SET RADFN=DFN
SET RACNT=0
SET RAIBDT=DTI
SET RAEXN=0
SET RAXIT=0
+18 ; other Vars set by RAO7PC1A:
+19 NEW RABNOR,RACSE,RADIAG,RANO,RAPRC,RAREX,RARPT,RARPTST,RASTNM,RAXAM,RAXID
+20 NEW RABNORMR,RACPT
+21 SET MAGRACNT=+$GET(MAGRACNT)
+22 KILL ^TMP($JOB,"RAE1")
DO SETDATA^RAO7PC1A
+23 ; no exams found
SET MAGRET=RACNT
if 'RACNT
QUIT
+24 DO GETEXSET(DFN,DTI_"-"_CNI,.X)
+25 ; no exam for this CNI
IF 'X
SET MAGRET=0
+26 KILL ^TMP($JOB,"RAE1")
+27 QUIT
+28 ;
GETEXSET(RADFN,EXID,MAGRET) ;
+1 ; Used by GETEXAM* subroutines above to set up rad data for vrad
+2 ; Input:
+3 ; RADFN -- Pt DFN
+4 ; EXID --- RADTI_"-"_RACNI, pointers to Rad exam
+5 ; Output:
+6 ; MAGRET- 1/0: an exam was/was not filed
+7 ; ^TMP($J,"MAGRAEX",MAGRACNT)=Data String (see code at end)
+8 ; MAGRACNT described in above subroutines
+9 ;
+10 NEW RACN,RACNI,RADATA,RADATE,RADTE,RADTI,RADTPRT,RAELOC,RANME
+11 NEW RAPRC,RARPT,RASSN,RAST,RASTORD,RASTP,RASTNM,RACPT,IMTYPABB,PROCMOD
+12 NEW DAYCASE,REQLOC,REQLOCN,REQLOCA,REQLOCT,RIST,RIST1,RIST2,COMPLIC
+13 NEW RADIV,RISTISME,REQWARD,RASTCAT,CPTMOD,LRFLAG,MODTXT,LONGACN,TECH
+14 NEW MEDS,RDIOPHARM
+15 ; ISI
NEW ASIGINI,ASIGNOTE,ASIGDUZ,FAVKWD1,FAVKWD2,FAVNOTE,PTAGE,PTDOB,PTSEX
+16 ; ISI
NEW RPTSTS
+17 SET MAGRET=0
SET RADTI=$PIECE(EXID,"-")
SET RACNI=$PIECE(EXID,"-",2)
+18 if '(RADTI&RACNI)
QUIT
+19 SET RADIV=""
+20 SET RADATA=$GET(^TMP($JOB,"RAE1",RADFN,EXID))
+21 ; no exam for this EXID
if RADATA=""
QUIT
+22 SET RARPT=$PIECE(RADATA,U,5)
+23 SET X=$PIECE(RADATA,U,6)
SET RASTORD=$PIECE(X,"~")
SET RASTNM=$PIECE(X,"~",2)
+24 ; ICR #1172 (Private)
SET X=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
SET COMPLIC=$DATA(^("COMP"))
SET PROCMOD=$DATA(^("M"))
SET CPTMOD=$DATA(^("CMOD"))
SET TECH=$DATA(^("TC"))
SET MEDS=$DATA(^("RX"))
+25 SET RAST=$PIECE(X,U,3)
SET REQLOC=$PIECE(X,U,22)
SET RIST1=$PIECE(X,U,12)
SET RIST2=$PIECE(X,U,15)
SET COMPLIC=$PIECE(X,U,16)_"~"_COMPLIC
+26 ; ICR #1172 (Private)
SET REQWARD=$PIECE(X,U,6)
SET LONGACN=$PIECE(X,U,31)
SET RDIOPHARM=$PIECE(X,U,28)
+27 ; ISI begin ...
+28 ; values are placeholders only inside this program
SET (FAVKWD1,FAVKWD2,FAVNOTE)=""
+29 SET (ASIGINI,ASIGNOTE,ASIGDUZ)=""
+30 ; not implemented in VA--future mod required to store in ISI file (tbd)
IF $$UJOCHECK^ISIJUTL9()
Begin DoDot:1
+31 SET X=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"ISI"))
IF +X
Begin DoDot:2
+32 SET ASIGDUZ=+X
SET ASIGNOTE=$PIECE(X,U,2)
+33 ; assignee initials
SET ASIGINI=$$USERINF^MAGJUTL3(ASIGDUZ,1)
End DoDot:2
End DoDot:1
+34 SET RPTSTS="No Report"
IF +RARPT
Begin DoDot:1
+35 SET X=$PIECE($GET(^RARPT(RARPT,0)),U,5)
+36 IF X]""
SET RPTSTS=$SELECT(X="V":"VERIFIED",X="D":"DRAFT",X="R":"REL./NOT VERIF.",X="PD":"PROBLEM DRAFT",X="EF":"ELECTRONICALLY FILED",X="X":"DELETED")
End DoDot:1
+37 ; ISI ... end
+38 ; Process Proc/CPT Modifier info
NEW CT,MODS,IEN,TT
+39 SET CT=0
+40 IF PROCMOD
Begin DoDot:1
+41 SET IEN=0
+42 FOR
SET IEN=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",IEN))
if 'IEN
QUIT
SET X=$PIECE($GET(^(IEN,0)),U)
IF X
Begin DoDot:2
+43 SET X=$PIECE($GET(^RAMIS(71.2,X,0)),U)
if X=""
QUIT
SET X=$$TRIM(X)
+44 SET X=$SELECT(X="BILATERAL EXAM":"BILAT",1:X)
+45 SET CT=CT+1
SET MODS(CT)=X
End DoDot:2
End DoDot:1
+46 IF CPTMOD
Begin DoDot:1
+47 SET IEN=0
+48 FOR
SET IEN=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",IEN))
if 'IEN
QUIT
SET X=$PIECE($GET(^(IEN,0)),U)
IF X
Begin DoDot:2
+49 SET X=$PIECE($$MOD^ICPTMOD(X,"I"),U,3)
if X=""
QUIT
SET X=$$TRIM(X)
+50 SET X=$SELECT(X="LEFT SIDE":"LEFT",X="RIGHT SIDE":"RIGHT",X="BILATERAL PROCEDURE":"BILAT",1:X)
+51 SET CT=CT+1
SET MODS(CT)=X
End DoDot:2
End DoDot:1
+52 SET MODTXT=""
SET LRFLAG=0
KILL TT
+53 IF CT
FOR I=1:1:CT
SET X=MODS(I)
Begin DoDot:1
+54 ; eliminate redundant values for L/R/Bilat (TT), & track L/R for prior matching (LRFLAG)
+55 ; already got it
SET T=(X="LEFT")
IF T
IF $DATA(TT(1))
QUIT
+56 ; ditto
IF 'T
SET T=(X="RIGHT")
IF T
SET T=2
IF T
IF $DATA(TT(2))
QUIT
+57 ; ditto
IF 'T
SET T=(X="BILAT")
IF T
SET T=3
IF T
IF $DATA(TT(3))
QUIT
+58 ; force L/R/Bilat to left end of string ..
IF T
SET TT(T)=""
SET MODTXT=X_$SELECT(MODTXT="":"",1:";")_MODTXT
+59 ; .. so is easier to spot in displayed column
IF '$TEST
SET MODTXT=MODTXT_$SELECT(MODTXT="":"",1:";")_X
+60 IF 'LRFLAG
if T
SET LRFLAG=T
+61 ; L&R or Bilat--ignore result
IF '$TEST
IF T
if (LRFLAG'=T)
SET LRFLAG=3
End DoDot:1
+62 ; Left/Right indicator
SET LRFLAG=$SELECT(LRFLAG=1:"L",LRFLAG=2:"R",1:"")
+63 IF 'TECH
SET TECH=""
+64 IF '$TEST
Begin DoDot:1
+65 SET IEN=0
SET TECH=""
NEW T
+66 FOR
SET IEN=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",IEN))
if 'IEN
QUIT
SET X=$PIECE($GET(^(IEN,0)),U)
IF X
SET T(X)=""
+67 IF $DATA(T)
SET T=""
FOR
SET T=$ORDER(T(T))
if T=""
QUIT
SET X=$PIECE($GET(^VA(200,T,0)),U,2)
IF X]""
SET TECH=TECH_$SELECT(TECH="":"",1:"~")_X
End DoDot:1
+68 SET RADIV=$PIECE(^RADPT(RADFN,"DT",RADTI,0),U,3)
+69 KILL DIC,DR,DA,DIQ
+70 IF 'REQLOC
SET (REQLOCN,REQLOCT,REQLOCA)=""
+71 IF '$TEST
Begin DoDot:1
+72 SET X=$GET(^SC(REQLOC,0))
SET REQLOCN=$PIECE(X,U)
SET REQLOCA=$PIECE(X,U,2)
+73 if REQLOCA=""
SET REQLOCA=REQLOCN
+74 SET DIC="44"
SET DR="2"
SET DA=REQLOC
SET DIQ="REQLOCT"
DO EN^DIQ1
KILL DIC,DR,DA,DIQ
+75 SET REQLOCT=REQLOCT(44,REQLOC,2)
End DoDot:1
+76 IF REQWARD]""
SET DIC="42"
SET DR=".01"
SET DA=REQWARD
SET DIQ="REQWARD"
DO EN^DIQ1
KILL DIC,DR,DA,DIQ
SET REQWARD=REQWARD(42,REQWARD,.01)
+77 SET X=$$RIST(RIST1,RIST2)
SET RIST=$PIECE(X,U)
SET RISTISME=$PIECE(X,U,2)
+78 SET RADTE=9999999.9999-RADTI
SET (RADTPRT,Y)=RADTE
DO D^RAUTL
SET RADATE=Y
+79 SET RADTPRT=$EXTRACT(RADTPRT,4,5)_"/"_$EXTRACT(RADTPRT,6,7)_"/"_$EXTRACT(RADTPRT,2,3)
+80 SET RAPRC=$EXTRACT($PIECE(RADATA,U),1,40)
SET RACN=$PIECE(RADATA,U,2)
SET RAELOC=$PIECE(RADATA,U,7)
+81 SET IMTYPABB=$PIECE($PIECE(RADATA,U,8),"~")
SET RACPT=$PIECE(RADATA,U,10)
+82 SET DAYCASE=$EXTRACT(RADTE,4,7)_$EXTRACT(RADTE,2,3)_"-"_RACN
+83 IF LONGACN]""
SET DAYCASE=LONGACN
+84 SET RASTP=RASTNM
SET RASTCAT=""
+85 IF RAST
SET RASTCAT=$PIECE($GET(^RA(72,RAST,0)),U,9)
+86 ; ISI
SET RANME=$PIECE(^DPT(RADFN,0),U)
SET PTSEX=$PIECE(^(0),U,2)
SET PTDOB=$PIECE(^(0),U,3)
SET PTAGE=""
+87 SET DFN=RADFN
DO PID^VADPT6
SET RASSN=$SELECT(VAERR:"Unknown",1:VA("PID"))
+88 KILL VA("PID"),VA("BID"),VAERR
+89 SET MAGRACNT=$GET(MAGRACNT)+1
+90 IF MAGRACNT=1
KILL ^TMP($JOB,"MAGRAEX")
+91 SET ^TMP($JOB,"MAGRAEX",MAGRACNT,1)=RADFN_U_RADTI_U_RACNI_U_$EXTRACT(RANME,1,30)_U_RASSN_U_RADATE_U_RADTE_U_RACN_U_$EXTRACT(RAPRC,1,35)_U_RARPT_U_RAST_U_DAYCASE_U_RAELOC_U_RASTP_U_RASTORD_U_RADTPRT_U_RACPT_U_IMTYPABB
+92 SET ^TMP($JOB,"MAGRAEX",MAGRACNT,2)=REQLOCA_U_$EXTRACT(REQLOCN,1,25)_U_RIST_U_COMPLIC_U_RADIV_U_$PIECE($$IMGSIT(RADIV),U,2)_U_RISTISME_U_MODTXT_U_REQLOCT_U_REQWARD_U_RASTCAT_U_LRFLAG_U_TECH_U_MEDS_U_RDIOPHARM
+93 ; ISI
SET ^TMP($JOB,"MAGRAEX",MAGRACNT,"ISI")=ASIGINI_U_ASIGNOTE_U_ASIGDUZ_U_FAVKWD1_U_FAVKWD2_U_FAVNOTE_U_PTAGE_U_PTSEX_U_PTDOB_U_RPTSTS
+94 SET MAGRET=1
+95 QUIT
+96 ;
RIST(RIST1,RIST2) ; return Interp Radiologist info
+1 SET RIST1=$GET(RIST1)
SET RIST2=$GET(RIST2)
+2 NEW RIST,RISTISME
+3 SET (RIST,RISTISME)=""
+4 IF RIST1!RIST2
Begin DoDot:1
+5 IF RIST1
SET RISTISME=RIST1
SET RIST=$$USERINF^MAGJUTL3(RIST1,1)
+6 IF RIST2
SET RISTISME=$SELECT('RISTISME:RIST2,1:RISTISME_"~"_RIST2)
SET RIST2=$$USERINF^MAGJUTL3(RIST2,1)
+7 IF RIST]""
SET RIST=RIST_$SELECT(RIST2]"":"/"_RIST2,1:"")
+8 IF '$TEST
SET RIST=RIST2
End DoDot:1
+9 QUIT RIST_U_RISTISME
+10 ;
IMGSIT(DIV,DFLT) ; Return Imaging Site code for input Division
+1 ; From 2006.1: IEN ^ Site Code ^ Parent_DIV
+2 IF DIV]""
Begin DoDot:1
+3 NEW IEN
IF $DATA(^MAG(2006.1,"B",DIV))
SET IEN=$ORDER(^(DIV,""))
IF IEN
+4 ; Dflt to 1st if requested
IF '$TEST
IF $GET(DFLT)
SET IEN=$ORDER(^MAG(2006.1,0))
+5 IF '$TEST
SET X=""
QUIT
+6 SET X=^MAG(2006.1,IEN,0)
SET X=IEN_U_$PIECE(X,U,9)_U_$PIECE(X,U)
End DoDot:1
+7 QUIT X
+8 ;
TRIM(X) ; Trim trailing spaces from X
+1 IF $GET(X)]""
Begin DoDot:1
+2 FOR I=$LENGTH(X):-1:0
IF $EXTRACT(X,I)'=" "
QUIT
+3 IF I
SET X=$EXTRACT(X,1,I)
+4 IF '$TEST
SET X=""
End DoDot:1
+5 if $QUIT
QUIT X
QUIT
+6 ;
END ;
QUIT
