MAGJUTL4 ;WIRMFO/JHC - VistARad subroutines for RPC calls ; 10/17/2022
;;3.0;IMAGING;**18,76,101,90,120,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. |
;; +---------------------------------------------------------------+
;;
;; ISI IMAGING;**99,106**
Q
;
;***** Return matching CPT's based on grouping criteria.
; RPC: MAGJ CPTMATCH
;
CPTGRP(MAGGRY,DATA) ;
; FOR INPUT cpt code, return matching cpt's based on grouping criteria:
; INPUT in DATA: CPT Code ^ Criteria
; Criteria:
; 1=Matching cpt
; 2=Body Part
; 3=Body Part & Modality
; 10=Same CPT (used to return short description only)
; Return: List of CPTs with Short Name: CPT ^ Short Name
; MAGGRY holds $NA reference to ^TMP for rpc return
; all ref's to MAGGRY use subscript indirection
;
N $ETRAP,$ESTACK S $ETRAP="G ERR1^MAGJUTL4"
N REPLY,DIQUIET,CPT,CRIT,CT,MAGLST,NOD,NODLST
N MATCHGRP,INDXLST,AND,RET,CPTGLB,CPTIN,CPTIEN,TCPT,CPTFILIEN,CPTFILDAT,IEN
;
; <*> Issue: Unable get specific body part for some non-specific CPTs (e.g., 75774-ANGIO SELECT EA ADD VESSEL-S)
; --> For these, could just return matching CPTs (or equivalent CPT?)
;
; Produce List of cptiens for each INDX of interest
; AND with next list of cptiens; repeat until no more INDXs
; build output list of CPT codes (w/ short names [optional])
;
S DIQUIET=1 D DT^DICRW
S CT=0,MAGLST="MAGJCPT"
K MAGGRY S MAGGRY=$NA(^TMP($J,MAGLST)) K @MAGGRY ; assign MAGGRY value
S CPTIN=$P(DATA,U),CRIT=$P(DATA,U,2),CPTIEN=""
S REPLY="0^Getting matching CPT info."
S:'CRIT CRIT=1 ; default equivalent
I '(CRIT=1!(CRIT=2)!(CRIT=3)!(CRIT=10)) S REPLY="0^Invalid cpt lookup criteria ("_DATA_")." G CPTGRPZ
I CPTIN="" S REPLY="0^Invalid CPT code ("_DATA_")." G CPTGRPZ
S CPTFILDAT=$$CPT^ICPTCOD(CPTIN)
I +CPTFILDAT=-1 S CPTFILDAT=""
S CPTFILIEN=$P(CPTFILDAT,U)
S CPTGLB=$NA(^MAG(2006.67))
I CPTFILIEN S CPTIEN=$O(@CPTGLB@("B",CPTFILIEN,""))
I 'CPTIEN D G CPTGRPZ
. ; if no entry in CPTGLB, return same CPT
. S CT=CT+1,@MAGGRY@(CT)=CPTIN_U_$P(CPTFILDAT,U,3)
. I CPTFILIEN S REPLY=CT_U_"1~ "_CT_" CPT name returned for "_CPTIN
. E S REPLY=CT_U_"1~ "_CT_" record returned--no value found for "_CPTIN
S X=@CPTGLB@(CPTIEN,0),MATCHGRP=+$P(X,U,4)
;CPTMATCH^BODYPART^MDL
I CRIT=2!(CRIT=3) D
. S X=0 F S X=$O(@CPTGLB@(CPTIEN,1,"B",X)) Q:'X D GETCPTS("BODYPART",X,"",.RET)
. I CRIT=3 D
. . M AND=RET K RET S X=0
. . F S X=$O(@CPTGLB@(CPTIEN,2,"B",X)) Q:'X D GETCPTS("MDL",X,.AND,.RET)
I CRIT=1 D
. I MATCHGRP,(MATCHGRP'=CPTIEN) S RET(MATCHGRP)="" D GETCPTS("CPTMATCH",MATCHGRP,"",.RET)
. D GETCPTS("CPTMATCH",CPTIEN,"",.RET)
I CRIT=10 ; fall through answers this!
I '$D(RET(CPTIEN)) S RET(CPTIEN)="" ; always report back input cpt
S IEN=0 F S IEN=$O(RET(IEN)) Q:'IEN D
. N LIN S X=$G(@CPTGLB@(IEN,0))
. Q:'(X]"") S TCPT=$P(X,U),LIN=$P($$CPT^ICPTCOD(TCPT),U,2,3)
. S CT=CT+1,@MAGGRY@(CT)=LIN
S REPLY=CT_U_"1~ "_CT_" CPT Matches returned for "_CPTIN
CPTGRPZ ;
S @MAGGRY@(0)=REPLY
Q
;
GETCPTS(INDEX,VALUE,AND,OUT) ; return a list of CPTIENS in OUT
; if array AND is defined, reply only values contained in AND & the index
N X,GLBREF,CPTIEN
S GLBREF=$NA(@CPTGLB@(INDEX,VALUE))
S CPTIEN=0
I $D(AND)>9 D
. F S CPTIEN=$O(AND(CPTIEN)) Q:CPTIEN="" I $D(@GLBREF@(CPTIEN)) S OUT(CPTIEN)=""
E F S CPTIEN=$O(@GLBREF@(CPTIEN)) Q:'CPTIEN D
. S OUT(CPTIEN)=""
Q
;
BODPART(CPTIEN,DLM) ; return DLM-delimited list of body part values for this CPT
I +$G(CPTIEN)
E Q ""
N LIST,CPTGLB S LIST=""
S DLM=$E($G(DLM))
I DLM="" S DLM="^"
S CPTGLB=$NA(^MAG(2006.67))
S NOD=0
F S NOD=$O(@CPTGLB@(CPTIEN,1,NOD)) Q:'NOD S X=$P(^(NOD,0),U) I X]"" S LIST=LIST_DLM_X
Q:$Q $E(LIST,2,999) Q
;
MDLLST(CPTIEN,DLM) ; return DLM-delimited list of modality values for this CPT
I +$G(CPTIEN)
E Q ""
N LIST,CPTGLB S LIST=""
S DLM=$E($G(DLM))
I DLM="" S DLM="^"
S CPTGLB=$NA(^MAG(2006.67))
S NOD=0
F S NOD=$O(@CPTGLB@(CPTIEN,2,NOD)) Q:'NOD S X=$P(^(NOD,0),U) I X]"" S LIST=LIST_DLM_X
Q:$Q $E(LIST,2,999) Q
;
;***** Returns server data to display in new "Image Display" window (P101.31).
; RPC: MAGJ MAGDATADUMP
;
; DATA REQUEST ^ PARAM1 | PARAM2
;
; ..... REQUEST determines format:
;
; ^01: REQUEST Literal string: [ CPT, FLDS, GLB ]
;
; ^02: if REQUEST="CPT":
;
; |01: PARAM1 CPT Code
; |02: [PARAM2] ""
;
; ^02: if REQUEST="FLDS" or "GLB":
;
; |01: [PARAM1] FileMan GETS^DIQ Flags (only if REQUEST="FLDS") *OR*
; |02: PARAM2 ImageIEN or Case_ID_String
;
; Return Values:
; 0:N lines to display (Internal Imaging or CPT Match data).
;
DATADUMP(MAGGRY,DATA) ;
;
; Initialize. <*> Do NOT change name of EP
; Also called as subroutine from INCPT^MAGJMN3
;
N $ETRAP,$ESTACK S $ETRAP="G ERR1^MAGJUTL4"
N CT,CPT,CPTFILIEN,CPTNAM,DIQUIET,IMGIEN,INVALID,PARAM1,PARAM2,REQUEST
S DIQUIET=1 D DT^DICRW
K MAGGRY S MAGGRY=$NA(^TMP($J,"MAGJDATA")) K @MAGGRY
;
; Validate input.
S INVALID=$$DDMPVLD8()
;
; Process then Exit, REPLYing with data or error code.
I 'INVALID D
. D DDMPROCS S REPLY=CT_U_"1~ "_CT_" lines of text returned for "_DATA
. M @MAGGRY=XMM K XMM
E S REPLY="0^Invalid image data request: "_""""_DATA_""""_" (ck"_INVALID_")."
S @MAGGRY@(0)=REPLY
Q
;
;+++++ Process according to REQUEST. Called by DATADUMP.
;
; Calls: GETS^MAGGTSYS, MAG^MAGGTSY1.
;
; Local array MM structures multiple calls' output for centralized processing.
; The array is re-subscripted by converting "," to "." allowing a single MERGE
; to the broker output global.
;
; MM(.1:.99) ... Header information.
; MM(1) ........ CPT (similar) match(es).
; MM(2) ........ CPT (BodyPart and Modality) match(es).
; MM(3) ........ FLDS output data.
; MM(4) ........ GLB output data.
;
DDMPROCS ;
;
; Initialize.
S REPLY="0^Retrieving imaging internal data ..."
;
; Process. CPT request via MAG RAD CPT MATCHING File (#2006.67).
I REQUEST="CPT" D DDMPRCPT(CPTFILIEN)
I REQUEST="FLDS" D GETS^MAGGTSYS(.M,IMGIEN,PARAM1) M MM(3)=@M K M
I REQUEST="GLB" D MAG^MAGGTSY2(.M,IMGIEN) M MM(4)=@M K M
;
; Re-subscript array MM into XMM to simplify MERGE to broker output global.
S CT=0,MMX=$NA(MM(0))
F S MMX=$Q(@MMX) Q:MMX="" S CT=CT+1,XMM(CT)=@MMX
K MM,MMX
Q
;
;+++++ Process a CPT request. Called by DDMPROCS
;
; Calls CPT^ICPTCOD for CPT Description.
;
DDMPRCPT(CPTFILIEN) ;
;
; Initialize.
N FN,FN1,NDX,NOD,SS,X
;
; Set section headers.
S MM(.1)="Input CPT Code ........... "_CPT_" ("_CPTNAM_")"
S MM(.2)=" Body Part(s) ... "
S MM(.3)=" Modality(s) .... "
;
; Set primary CPT bodyPart & modality.
S FN=2006.67,FN1=2006.671,NDX=$O(^MAG(FN,"B",CPTFILIEN,""))
S NOD=$NA(^MAG(FN,NDX,0)) F S NOD=$Q(@NOD) Q:$QS(NOD,2)>NDX I $QS(NOD,4)="B" D
. I $QS(NOD,3)=1 S MM(.2)=MM(.2)_$G(^MAG(FN1,$QS(NOD,5),0))_"; "
. I $QS(NOD,3)=2 S MM(.3)=MM(.3)_$P($G(^RAMIS(73.1,$QS(NOD,5),0)),U)_"; "
. Q
;
; Strip dangling concatenators.
F SS=.2,.3 S MM(SS)=$$ZRUPUNCT(MM(SS),"; ","")
;
; Fetch CPTs matching on CPT.
D CPTGRP(.M,CPT_"^1") M MM(1)=@M K M
S MM(1,0)=$P(MM(1,0),"~ ",2)
S MM(1,0)=$J(+$P(MM(1,0)," "),3)_" matching CPT(s) via Similar CPT:"
;
; Fetch CPTs matching on BodyPart & Modality.
D CPTGRP(.M,CPT_"^3") M MM(2)=@M K M
S MM(2,0)=$P(MM(2,0),"~ ",2)
S MM(2,0)=$J(+$P(MM(2,0)," "),3)_" matching CPT(s) via BODY PART and MODALITY:"
;
; Re-format. [Not modular -- should provide for leaving as-is.]
S MMX=$NA(MM(.99)) F S MMX=$Q(@MMX) Q:MMX="" I @MMX["^" S @MMX=" "_$TR(@MMX,"^"," ")
Q
;
;+++++ Validate. Called by DATADUMP.
;
DDMPVLD8() ;
;
; ... DATA string format or exit invalid (code 1).
Q:'$D(DATA) 1
Q:DATA="" 1
Q:DATA'["^"!(DATA'["|") 1
;
; Initialize.
N GO,RACNI,RADFN,RADTI,RARPT S REPLY="0^Validating input parameters ..."
S REQUEST=$P(DATA,U),PARAM1=$P($P(DATA,U,2),"|"),PARAM2=$P(DATA,"|",2)
;
; ... DATA string's REQUEST piece or exit (invalid: code 2).
Q:"^CPT^FLDS^GLB^"'[(U_REQUEST_U) 2
;
; ... PARAM1 if REQUEST="CPT" or exit (invalid: code 3).
I REQUEST="CPT" D I 'GO Q 3
. S GO=PARAM1]"" Q:'GO
. S X=$$CPT^ICPTCOD(PARAM1),CPTFILIEN=$P(X,U),CPT=$P(X,U,2),CPTNAM=$P(X,U,3)
. I CPTFILIEN,$D(^MAG(2006.67,"B",CPTFILIEN))
. E S GO=0
;
; ... PARAM1 if REQUEST="FLDS" or re-set to null. External call will set defaults.
; .......... only validate format of FileMan flags.
I REQUEST="FLDS"&(PARAM1'?1U.U) S PARAM1=""
;
; ... PARAM2 if REQUEST=("FLDS" or "GLB") or exit (invalid: code 4).
I REQUEST="FLDS"!(REQUEST="GLB") S IMGIEN="" D Q:IMGIEN="" 4
. ;
. ; Case 1: PARAM2 holds IMGIEN.
. I PARAM2?1N.N,$D(^MAG(2005,PARAM2)) S IMGIEN=PARAM2 Q
. ;
. ; Case 2: PARAM2 holds RARPT in piece 4, set IMGIEN via back-pointer in File #74.
. I $L(PARAM2,U)=4 S RARPT=$P(PARAM2,U,4) I +RARPT S IMGIEN=$O(^RARPT(RARPT,2005,"B","")) ; ISI P106
. I IMGIEN'="",$D(^MAG(2005,IMGIEN)) Q
. ;
. ; Case 3: PARAM2 holds RADFN^RADTI^RACNI in pieces 1:3.
. S RADFN=+PARAM2,RADTI=$P(PARAM2,U,2),RACNI=$P(PARAM2,U,3)
. I RADFN,RADTI,RACNI D
. . S RARPT=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,17)
. . I RARPT'="",$D(^RARPT(RARPT,2005,"B"))>1 S IMGIEN=$O(^RARPT(RARPT,2005,"B",""))
Q 0
;
;***** Check Exam Status.
; RPC: MAGJ RADSTATUSCHECK
;
STATCHK(MAGGRY,DATA) ;
; This may also be accessed by subroutine call. <*> do not change name of EP
; Exam Status check RPC and subroutine: determine if the exam has been Tech-Verified (at least).
; Images are assumed to be verified if Exam Status is Examined, or higher status.
; ; Input in DATA: RADFN^RADTI^RACNI^RARPT
; Input is either RADFN, RADTI, and RACNI; or, RARPT only may be input in piece 4
; Return: Code^Text
; 0 = Problem, or exam was cancelled
; 1 = Not yet verified
; 2 = Tech Verified
; 3 = Radiologist Verified
; 4 = User is a Radiology professional--always allow access
;
N $ETRAP,$ESTACK S $ETRAP="G ERR3^MAGJUTL4"
N REPLY,STATUS,ORDER,VCAT,STOUT
N DIQUIET,RARPT,RADFN,RADTI,RACNI
S DIQUIET=1 D DT^DICRW
S RADFN=$P(DATA,U),RADTI=$P(DATA,U,2),RACNI=$P(DATA,U,3),RARPT=$P(DATA,U,4)
S STOUT="",REPLY="0^Getting image verification status."
I RADFN,RADTI,RACNI
E I RARPT D RPT2DPT(RARPT,.X) I X S RADFN=+X,RADTI=$P(X,U,2),RACNI=$P(X,U,3) I RADFN,RADTI,RACNI
E S REPLY="0^Image Verification Status request contains invalid case pointer ("_DATA_")" G STATCHKZ
S STATUS=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,3)
I STATUS="" S REPLY="0^Image Verification Status request error--no Exam Status is defined for ("_DATA_")" G STATCHKZ
S VCAT=$P(^RA(72,STATUS,0),U,9),ORDER=$P(^(0),U,3)
I VCAT]"" D G STATCHK2:STOUT
. I "EDT"[VCAT S STOUT=$S(VCAT="E":2,1:3) ; Examined or Interpreted
. E I "WR"[VCAT S STOUT=1 ; Not yet Verified ; ISI-P106
I ORDER=9 S STOUT=3 ; Completed exam
E I ORDER=0 S REPLY="0^Exam Cancelled"
E I ORDER=1 S STOUT=1 ; Waiting for exam
STATCHK2 ;
I STOUT<2 D
. F X="S","R","T" I $D(^VA(200,"ARC",X,DUZ)) S STOUT=4 Q ; Radiologist or Tech -- OK to access
STATCHKZ ;
I STOUT S REPLY=STOUT_U_$S(STOUT=1:"Images not yet verified",STOUT=2:"Images verified by Technologist",STOUT=3:"Images interpreted by Radiologist",STOUT=4:"Radiology professional--OK to view images.",1:"")
S MAGGRY=REPLY
Q
;
;***** User set/clear flag to show/not show remote exams only.
; RPC: MAGJ REMOTESCREEN
;
REMSCRN(MAGGRY,DATA) ;
; Input in DATA: 1/0 1=show remote only; 0=show all exams
; Return: Reply^Code~msg
; Reply -- 0=Problem; 1=Success
; Code -- 4=Error; 1=ok
; msg -- display text if error
;
N $ETRAP,$ESTACK S $ETRAP="G ERR3^MAGJUTL4"
N REPLY
N DIQUIET S DIQUIET=1 D DT^DICRW
I $D(DATA),(DATA=0!(DATA=1))
E S REPLY="0^4~REMOTESCREEN request has invalid parameter ("_$G(DATA)_")" G REMSCRNZ
S MAGJOB("REMOTESCREEN")=DATA,REPLY="1^1~"_DATA
REMSCRNZ ;
S MAGGRY=REPLY
Q
;
RPT2DPT(RARPT,RET) ; Input RARPT. Return RET containing exam ss values for ^RADPT
;
N DFN,DTI,CNI S (DFN,DTI,CNI)=""
I RARPT?1N.N,$D(^RARPT(RARPT)) S X=$G(^(RARPT,0)) I X]"" D
. S X=$P(X,U)
. S X=$O(^RADPT("ADC",X,0)) I X S DFN=X,DTI=$O(^(X,0)),CNI=$O(^(DTI,0))
. S RET=DFN_U_DTI_U_CNI
E S RET=""
Q
;
ERR1 N ERR S ERR=$$EC^%ZOSV S @MAGGRY@(0)="0^4~"_ERR G ERR
ERR3 N ERR S ERR=$$EC^%ZOSV S MAGGRY="0^4~"_ERR
ERR D @^%ZOSF("ERRTN")
Q:$Q 1 Q
;
END Q ;
;
;***** Identify if mammogram via CPT Code. Called by OPENCASE^MAGJEX1.
;
; Calls ZRUMDLST, $$CPT^ICPTCOD (which may return "-1^NO SUCH ENTRY").
;
; CPT CPT Code
;
; Return Value:
; 0 NOT a mammogram.
; 1 IS a mammogram.
;
ZRUMAMMO(CPT) ;
N CPTCATIEN,YN S YN=0
S CPTCATIEN=$P($$CPT^ICPTCOD(CPT),U,4) Q:CPTCATIEN="" YN Q:+CPTCATIEN<0 YN
;
; Criterion (1A): CPT Category (cf., ^DIC(81.1,240,0)=BREAST MAMMOGRAPHY^s^4^77051^77059^C).
I $P(^DIC(81.1,CPTCATIEN,0),U)="BREAST MAMMOGRAPHY" S YN=1 D
. ;
. ; Criterion (1B): CPT "Modality" (using MAGS array's modalities via ZRUMDLST).
. N MODALITY
. D ZRUMDLST(.MAGS) I '$D(MAGMDLST) S YN=1 Q
. F MODALITY="MR","OCT","US" S:$D(MAGMDLST(MODALITY)) YN=0
;
; Criterion (2) -- Deprecated mammography CPTs.
E D
. N CPTMAM F CPTMAM=76082,76083,76085:1:76092 I CPT=CPTMAM S YN=1 Q
Q YN
;
;+++++ Array any unique MAGS' piece 3 modalities. Called by ZRUMAMMO.
;
; .MAGS Array of individual image data (cf. JBFETCH^MAGJUTL2).
;
; Sets array MAGMDLST(modality).
;
ZRUMDLST(MAGS) ;
K MAGMDLST
I $D(MAGS),MAGS N MD0,X F X=1:1:MAGS D
. S MD0=$P(MAGS(X),U,3) I MD0'="",'$D(MAGMDLST(MD0)) S MAGMDLST(MD0)=""
Q
;
;+++++ Strip IN's trailing elements & append REPL.
;
; IN String to operate on.
; REPL String to place at right end.
; STRIP String to remove from right end.
;
; Returns:
; IN_REPL
;
ZRUPUNCT(IN,STRIP,REPL) ;
Q:'$D(IN)!('$D(STRIP))!('$D(REPL)) F Q:STRIP'[$E(IN,$L(IN)) S IN=$E(IN,1,$L(IN)-1)
Q IN_REPL
;
; ***** Query to modify existing annotations. Called by OPENCASE^MAGJEX1
;
; DUZ Kernel internal user identifier.
; RACNI RAD/NUC Med Patient File (#70) Case Number Index
; RADFN " Patient DFN
; RADTI " Study Internal Date
;
; Return Value:
; 0 NOT authorized to annotate.
; 1 AUTHORIZED "".
;
ZRUREVAN(RADFN,RADTI,RACNI) ;
;
; Initialize. Exit if RAxxx pointers fail.
N EXAMSTAT,EXMSTSPT,RADNOD,RIST1,RIST2,YN
S YN=0,RADNOD=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
Q:RADNOD="" YN
;
; Collect data about ...
S RIST1=$P(RADNOD,U,12) ; .. PRIMARY INTERPRETING RESIDENT [12P:200]
S RIST2=$P(RADNOD,U,15) ; .. PRIMARY INTERPRETING STAFF [15P:200]
S EXMSTSPT=$P(RADNOD,U,3) ;. EXAM STATUS [3P:72]
S EXAMSTAT=$P($G(^RA(72,EXMSTSPT,0)),U,9) ; VISTARAD CATEGORY (#9)
;
I EXAMSTAT="D"!(EXAMSTAT="T") D
. ;
. ; 'Yes' if CurrentUser=Primary Interpreting Radiologist.
. I DUZ=RIST1!(DUZ=RIST2) S YN=1
. E I RIST1'="",$D(^VA(200,"ARC","S",+DUZ)) S YN=1 ; 'Yes' if (Primary Interpreting Radiologist is Resident) & (CurrentUser is Staff)
. Q
Q YN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGJUTL4 16332 printed Sep 23, 2025@19:43:19 Page 2
MAGJUTL4 ;WIRMFO/JHC - VistARad subroutines for RPC calls ; 10/17/2022
+1 ;;3.0;IMAGING;**18,76,101,90,120,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 ;; | 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 ;; ISI IMAGING;**99,106**
+18 QUIT
+19 ;
+20 ;***** Return matching CPT's based on grouping criteria.
+21 ; RPC: MAGJ CPTMATCH
+22 ;
CPTGRP(MAGGRY,DATA) ;
+1 ; FOR INPUT cpt code, return matching cpt's based on grouping criteria:
+2 ; INPUT in DATA: CPT Code ^ Criteria
+3 ; Criteria:
+4 ; 1=Matching cpt
+5 ; 2=Body Part
+6 ; 3=Body Part & Modality
+7 ; 10=Same CPT (used to return short description only)
+8 ; Return: List of CPTs with Short Name: CPT ^ Short Name
+9 ; MAGGRY holds $NA reference to ^TMP for rpc return
+10 ; all ref's to MAGGRY use subscript indirection
+11 ;
+12 NEW $ETRAP,$ESTACK
SET $ETRAP="G ERR1^MAGJUTL4"
+13 NEW REPLY,DIQUIET,CPT,CRIT,CT,MAGLST,NOD,NODLST
+14 NEW MATCHGRP,INDXLST,AND,RET,CPTGLB,CPTIN,CPTIEN,TCPT,CPTFILIEN,CPTFILDAT,IEN
+15 ;
+16 ; <*> Issue: Unable get specific body part for some non-specific CPTs (e.g., 75774-ANGIO SELECT EA ADD VESSEL-S)
+17 ; --> For these, could just return matching CPTs (or equivalent CPT?)
+18 ;
+19 ; Produce List of cptiens for each INDX of interest
+20 ; AND with next list of cptiens; repeat until no more INDXs
+21 ; build output list of CPT codes (w/ short names [optional])
+22 ;
+23 SET DIQUIET=1
DO DT^DICRW
+24 SET CT=0
SET MAGLST="MAGJCPT"
+25 ; assign MAGGRY value
KILL MAGGRY
SET MAGGRY=$NAME(^TMP($JOB,MAGLST))
KILL @MAGGRY
+26 SET CPTIN=$PIECE(DATA,U)
SET CRIT=$PIECE(DATA,U,2)
SET CPTIEN=""
+27 SET REPLY="0^Getting matching CPT info."
+28 ; default equivalent
if 'CRIT
SET CRIT=1
+29 IF '(CRIT=1!(CRIT=2)!(CRIT=3)!(CRIT=10))
SET REPLY="0^Invalid cpt lookup criteria ("_DATA_")."
GOTO CPTGRPZ
+30 IF CPTIN=""
SET REPLY="0^Invalid CPT code ("_DATA_")."
GOTO CPTGRPZ
+31 SET CPTFILDAT=$$CPT^ICPTCOD(CPTIN)
+32 IF +CPTFILDAT=-1
SET CPTFILDAT=""
+33 SET CPTFILIEN=$PIECE(CPTFILDAT,U)
+34 SET CPTGLB=$NAME(^MAG(2006.67))
+35 IF CPTFILIEN
SET CPTIEN=$ORDER(@CPTGLB@("B",CPTFILIEN,""))
+36 IF 'CPTIEN
Begin DoDot:1
+37 ; if no entry in CPTGLB, return same CPT
+38 SET CT=CT+1
SET @MAGGRY@(CT)=CPTIN_U_$PIECE(CPTFILDAT,U,3)
+39 IF CPTFILIEN
SET REPLY=CT_U_"1~ "_CT_" CPT name returned for "_CPTIN
+40 IF '$TEST
SET REPLY=CT_U_"1~ "_CT_" record returned--no value found for "_CPTIN
End DoDot:1
GOTO CPTGRPZ
+41 SET X=@CPTGLB@(CPTIEN,0)
SET MATCHGRP=+$PIECE(X,U,4)
+42 ;CPTMATCH^BODYPART^MDL
+43 IF CRIT=2!(CRIT=3)
Begin DoDot:1
+44 SET X=0
FOR
SET X=$ORDER(@CPTGLB@(CPTIEN,1,"B",X))
if 'X
QUIT
DO GETCPTS("BODYPART",X,"",.RET)
+45 IF CRIT=3
Begin DoDot:2
+46 MERGE AND=RET
KILL RET
SET X=0
+47 FOR
SET X=$ORDER(@CPTGLB@(CPTIEN,2,"B",X))
if 'X
QUIT
DO GETCPTS("MDL",X,.AND,.RET)
End DoDot:2
End DoDot:1
+48 IF CRIT=1
Begin DoDot:1
+49 IF MATCHGRP
IF (MATCHGRP'=CPTIEN)
SET RET(MATCHGRP)=""
DO GETCPTS("CPTMATCH",MATCHGRP,"",.RET)
+50 DO GETCPTS("CPTMATCH",CPTIEN,"",.RET)
End DoDot:1
+51 ; fall through answers this!
IF CRIT=10
+52 ; always report back input cpt
IF '$DATA(RET(CPTIEN))
SET RET(CPTIEN)=""
+53 SET IEN=0
FOR
SET IEN=$ORDER(RET(IEN))
if 'IEN
QUIT
Begin DoDot:1
+54 NEW LIN
SET X=$GET(@CPTGLB@(IEN,0))
+55 if '(X]"")
QUIT
SET TCPT=$PIECE(X,U)
SET LIN=$PIECE($$CPT^ICPTCOD(TCPT),U,2,3)
+56 SET CT=CT+1
SET @MAGGRY@(CT)=LIN
End DoDot:1
+57 SET REPLY=CT_U_"1~ "_CT_" CPT Matches returned for "_CPTIN
CPTGRPZ ;
+1 SET @MAGGRY@(0)=REPLY
+2 QUIT
+3 ;
GETCPTS(INDEX,VALUE,AND,OUT) ; return a list of CPTIENS in OUT
+1 ; if array AND is defined, reply only values contained in AND & the index
+2 NEW X,GLBREF,CPTIEN
+3 SET GLBREF=$NAME(@CPTGLB@(INDEX,VALUE))
+4 SET CPTIEN=0
+5 IF $DATA(AND)>9
Begin DoDot:1
+6 FOR
SET CPTIEN=$ORDER(AND(CPTIEN))
if CPTIEN=""
QUIT
IF $DATA(@GLBREF@(CPTIEN))
SET OUT(CPTIEN)=""
End DoDot:1
+7 IF '$TEST
FOR
SET CPTIEN=$ORDER(@GLBREF@(CPTIEN))
if 'CPTIEN
QUIT
Begin DoDot:1
+8 SET OUT(CPTIEN)=""
End DoDot:1
+9 QUIT
+10 ;
BODPART(CPTIEN,DLM) ; return DLM-delimited list of body part values for this CPT
+1 IF +$GET(CPTIEN)
+2 IF '$TEST
QUIT ""
+3 NEW LIST,CPTGLB
SET LIST=""
+4 SET DLM=$EXTRACT($GET(DLM))
+5 IF DLM=""
SET DLM="^"
+6 SET CPTGLB=$NAME(^MAG(2006.67))
+7 SET NOD=0
+8 FOR
SET NOD=$ORDER(@CPTGLB@(CPTIEN,1,NOD))
if 'NOD
QUIT
SET X=$PIECE(^(NOD,0),U)
IF X]""
SET LIST=LIST_DLM_X
+9 if $QUIT
QUIT $EXTRACT(LIST,2,999)
QUIT
+10 ;
MDLLST(CPTIEN,DLM) ; return DLM-delimited list of modality values for this CPT
+1 IF +$GET(CPTIEN)
+2 IF '$TEST
QUIT ""
+3 NEW LIST,CPTGLB
SET LIST=""
+4 SET DLM=$EXTRACT($GET(DLM))
+5 IF DLM=""
SET DLM="^"
+6 SET CPTGLB=$NAME(^MAG(2006.67))
+7 SET NOD=0
+8 FOR
SET NOD=$ORDER(@CPTGLB@(CPTIEN,2,NOD))
if 'NOD
QUIT
SET X=$PIECE(^(NOD,0),U)
IF X]""
SET LIST=LIST_DLM_X
+9 if $QUIT
QUIT $EXTRACT(LIST,2,999)
QUIT
+10 ;
+11 ;***** Returns server data to display in new "Image Display" window (P101.31).
+12 ; RPC: MAGJ MAGDATADUMP
+13 ;
+14 ; DATA REQUEST ^ PARAM1 | PARAM2
+15 ;
+16 ; ..... REQUEST determines format:
+17 ;
+18 ; ^01: REQUEST Literal string: [ CPT, FLDS, GLB ]
+19 ;
+20 ; ^02: if REQUEST="CPT":
+21 ;
+22 ; |01: PARAM1 CPT Code
+23 ; |02: [PARAM2] ""
+24 ;
+25 ; ^02: if REQUEST="FLDS" or "GLB":
+26 ;
+27 ; |01: [PARAM1] FileMan GETS^DIQ Flags (only if REQUEST="FLDS") *OR*
+28 ; |02: PARAM2 ImageIEN or Case_ID_String
+29 ;
+30 ; Return Values:
+31 ; 0:N lines to display (Internal Imaging or CPT Match data).
+32 ;
DATADUMP(MAGGRY,DATA) ;
+1 ;
+2 ; Initialize. <*> Do NOT change name of EP
+3 ; Also called as subroutine from INCPT^MAGJMN3
+4 ;
+5 NEW $ETRAP,$ESTACK
SET $ETRAP="G ERR1^MAGJUTL4"
+6 NEW CT,CPT,CPTFILIEN,CPTNAM,DIQUIET,IMGIEN,INVALID,PARAM1,PARAM2,REQUEST
+7 SET DIQUIET=1
DO DT^DICRW
+8 KILL MAGGRY
SET MAGGRY=$NAME(^TMP($JOB,"MAGJDATA"))
KILL @MAGGRY
+9 ;
+10 ; Validate input.
+11 SET INVALID=$$DDMPVLD8()
+12 ;
+13 ; Process then Exit, REPLYing with data or error code.
+14 IF 'INVALID
Begin DoDot:1
+15 DO DDMPROCS
SET REPLY=CT_U_"1~ "_CT_" lines of text returned for "_DATA
+16 MERGE @MAGGRY=XMM
KILL XMM
End DoDot:1
+17 IF '$TEST
SET REPLY="0^Invalid image data request: "_""""_DATA_""""_" (ck"_INVALID_")."
+18 SET @MAGGRY@(0)=REPLY
+19 QUIT
+20 ;
+21 ;+++++ Process according to REQUEST. Called by DATADUMP.
+22 ;
+23 ; Calls: GETS^MAGGTSYS, MAG^MAGGTSY1.
+24 ;
+25 ; Local array MM structures multiple calls' output for centralized processing.
+26 ; The array is re-subscripted by converting "," to "." allowing a single MERGE
+27 ; to the broker output global.
+28 ;
+29 ; MM(.1:.99) ... Header information.
+30 ; MM(1) ........ CPT (similar) match(es).
+31 ; MM(2) ........ CPT (BodyPart and Modality) match(es).
+32 ; MM(3) ........ FLDS output data.
+33 ; MM(4) ........ GLB output data.
+34 ;
DDMPROCS ;
+1 ;
+2 ; Initialize.
+3 SET REPLY="0^Retrieving imaging internal data ..."
+4 ;
+5 ; Process. CPT request via MAG RAD CPT MATCHING File (#2006.67).
+6 IF REQUEST="CPT"
DO DDMPRCPT(CPTFILIEN)
+7 IF REQUEST="FLDS"
DO GETS^MAGGTSYS(.M,IMGIEN,PARAM1)
MERGE MM(3)=@M
KILL M
+8 IF REQUEST="GLB"
DO MAG^MAGGTSY2(.M,IMGIEN)
MERGE MM(4)=@M
KILL M
+9 ;
+10 ; Re-subscript array MM into XMM to simplify MERGE to broker output global.
+11 SET CT=0
SET MMX=$NAME(MM(0))
+12 FOR
SET MMX=$QUERY(@MMX)
if MMX=""
QUIT
SET CT=CT+1
SET XMM(CT)=@MMX
+13 KILL MM,MMX
+14 QUIT
+15 ;
+16 ;+++++ Process a CPT request. Called by DDMPROCS
+17 ;
+18 ; Calls CPT^ICPTCOD for CPT Description.
+19 ;
DDMPRCPT(CPTFILIEN) ;
+1 ;
+2 ; Initialize.
+3 NEW FN,FN1,NDX,NOD,SS,X
+4 ;
+5 ; Set section headers.
+6 SET MM(.1)="Input CPT Code ........... "_CPT_" ("_CPTNAM_")"
+7 SET MM(.2)=" Body Part(s) ... "
+8 SET MM(.3)=" Modality(s) .... "
+9 ;
+10 ; Set primary CPT bodyPart & modality.
+11 SET FN=2006.67
SET FN1=2006.671
SET NDX=$ORDER(^MAG(FN,"B",CPTFILIEN,""))
+12 SET NOD=$NAME(^MAG(FN,NDX,0))
FOR
SET NOD=$QUERY(@NOD)
if $QSUBSCRIPT(NOD,2)>NDX
QUIT
IF $QSUBSCRIPT(NOD,4)="B"
Begin DoDot:1
+13 IF $QSUBSCRIPT(NOD,3)=1
SET MM(.2)=MM(.2)_$GET(^MAG(FN1,$QSUBSCRIPT(NOD,5),0))_"; "
+14 IF $QSUBSCRIPT(NOD,3)=2
SET MM(.3)=MM(.3)_$PIECE($GET(^RAMIS(73.1,$QSUBSCRIPT(NOD,5),0)),U)_"; "
+15 QUIT
End DoDot:1
+16 ;
+17 ; Strip dangling concatenators.
+18 FOR SS=.2,.3
SET MM(SS)=$$ZRUPUNCT(MM(SS),"; ","")
+19 ;
+20 ; Fetch CPTs matching on CPT.
+21 DO CPTGRP(.M,CPT_"^1")
MERGE MM(1)=@M
KILL M
+22 SET MM(1,0)=$PIECE(MM(1,0),"~ ",2)
+23 SET MM(1,0)=$JUSTIFY(+$PIECE(MM(1,0)," "),3)_" matching CPT(s) via Similar CPT:"
+24 ;
+25 ; Fetch CPTs matching on BodyPart & Modality.
+26 DO CPTGRP(.M,CPT_"^3")
MERGE MM(2)=@M
KILL M
+27 SET MM(2,0)=$PIECE(MM(2,0),"~ ",2)
+28 SET MM(2,0)=$JUSTIFY(+$PIECE(MM(2,0)," "),3)_" matching CPT(s) via BODY PART and MODALITY:"
+29 ;
+30 ; Re-format. [Not modular -- should provide for leaving as-is.]
+31 SET MMX=$NAME(MM(.99))
FOR
SET MMX=$QUERY(@MMX)
if MMX=""
QUIT
IF @MMX["^"
SET @MMX=" "_$TRANSLATE(@MMX,"^"," ")
+32 QUIT
+33 ;
+34 ;+++++ Validate. Called by DATADUMP.
+35 ;
DDMPVLD8() ;
+1 ;
+2 ; ... DATA string format or exit invalid (code 1).
+3 if '$DATA(DATA)
QUIT 1
+4 if DATA=""
QUIT 1
+5 if DATA'["^"!(DATA'["|")
QUIT 1
+6 ;
+7 ; Initialize.
+8 NEW GO,RACNI,RADFN,RADTI,RARPT
SET REPLY="0^Validating input parameters ..."
+9 SET REQUEST=$PIECE(DATA,U)
SET PARAM1=$PIECE($PIECE(DATA,U,2),"|")
SET PARAM2=$PIECE(DATA,"|",2)
+10 ;
+11 ; ... DATA string's REQUEST piece or exit (invalid: code 2).
+12 if "^CPT^FLDS^GLB^"'[(U_REQUEST_U)
QUIT 2
+13 ;
+14 ; ... PARAM1 if REQUEST="CPT" or exit (invalid: code 3).
+15 IF REQUEST="CPT"
Begin DoDot:1
+16 SET GO=PARAM1]""
if 'GO
QUIT
+17 SET X=$$CPT^ICPTCOD(PARAM1)
SET CPTFILIEN=$PIECE(X,U)
SET CPT=$PIECE(X,U,2)
SET CPTNAM=$PIECE(X,U,3)
+18 IF CPTFILIEN
IF $DATA(^MAG(2006.67,"B",CPTFILIEN))
+19 IF '$TEST
SET GO=0
End DoDot:1
IF 'GO
QUIT 3
+20 ;
+21 ; ... PARAM1 if REQUEST="FLDS" or re-set to null. External call will set defaults.
+22 ; .......... only validate format of FileMan flags.
+23 IF REQUEST="FLDS"&(PARAM1'?1U.U)
SET PARAM1=""
+24 ;
+25 ; ... PARAM2 if REQUEST=("FLDS" or "GLB") or exit (invalid: code 4).
+26 IF REQUEST="FLDS"!(REQUEST="GLB")
SET IMGIEN=""
Begin DoDot:1
+27 ;
+28 ; Case 1: PARAM2 holds IMGIEN.
+29 IF PARAM2?1N.N
IF $DATA(^MAG(2005,PARAM2))
SET IMGIEN=PARAM2
QUIT
+30 ;
+31 ; Case 2: PARAM2 holds RARPT in piece 4, set IMGIEN via back-pointer in File #74.
+32 ; ISI P106
IF $LENGTH(PARAM2,U)=4
SET RARPT=$PIECE(PARAM2,U,4)
IF +RARPT
SET IMGIEN=$ORDER(^RARPT(RARPT,2005,"B",""))
+33 IF IMGIEN'=""
IF $DATA(^MAG(2005,IMGIEN))
QUIT
+34 ;
+35 ; Case 3: PARAM2 holds RADFN^RADTI^RACNI in pieces 1:3.
+36 SET RADFN=+PARAM2
SET RADTI=$PIECE(PARAM2,U,2)
SET RACNI=$PIECE(PARAM2,U,3)
+37 IF RADFN
IF RADTI
IF RACNI
Begin DoDot:2
+38 SET RARPT=$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,17)
+39 IF RARPT'=""
IF $DATA(^RARPT(RARPT,2005,"B"))>1
SET IMGIEN=$ORDER(^RARPT(RARPT,2005,"B",""))
End DoDot:2
End DoDot:1
if IMGIEN=""
QUIT 4
+40 QUIT 0
+41 ;
+42 ;***** Check Exam Status.
+43 ; RPC: MAGJ RADSTATUSCHECK
+44 ;
STATCHK(MAGGRY,DATA) ;
+1 ; This may also be accessed by subroutine call. <*> do not change name of EP
+2 ; Exam Status check RPC and subroutine: determine if the exam has been Tech-Verified (at least).
+3 ; Images are assumed to be verified if Exam Status is Examined, or higher status.
+4 ; ; Input in DATA: RADFN^RADTI^RACNI^RARPT
+5 ; Input is either RADFN, RADTI, and RACNI; or, RARPT only may be input in piece 4
+6 ; Return: Code^Text
+7 ; 0 = Problem, or exam was cancelled
+8 ; 1 = Not yet verified
+9 ; 2 = Tech Verified
+10 ; 3 = Radiologist Verified
+11 ; 4 = User is a Radiology professional--always allow access
+12 ;
+13 NEW $ETRAP,$ESTACK
SET $ETRAP="G ERR3^MAGJUTL4"
+14 NEW REPLY,STATUS,ORDER,VCAT,STOUT
+15 NEW DIQUIET,RARPT,RADFN,RADTI,RACNI
+16 SET DIQUIET=1
DO DT^DICRW
+17 SET RADFN=$PIECE(DATA,U)
SET RADTI=$PIECE(DATA,U,2)
SET RACNI=$PIECE(DATA,U,3)
SET RARPT=$PIECE(DATA,U,4)
+18 SET STOUT=""
SET REPLY="0^Getting image verification status."
+19 IF RADFN
IF RADTI
IF RACNI
+20 IF '$TEST
IF RARPT
DO RPT2DPT(RARPT,.X)
IF X
SET RADFN=+X
SET RADTI=$PIECE(X,U,2)
SET RACNI=$PIECE(X,U,3)
IF RADFN
IF RADTI
IF RACNI
+21 IF '$TEST
SET REPLY="0^Image Verification Status request contains invalid case pointer ("_DATA_")"
GOTO STATCHKZ
+22 SET STATUS=$PIECE($GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,3)
+23 IF STATUS=""
SET REPLY="0^Image Verification Status request error--no Exam Status is defined for ("_DATA_")"
GOTO STATCHKZ
+24 SET VCAT=$PIECE(^RA(72,STATUS,0),U,9)
SET ORDER=$PIECE(^(0),U,3)
+25 IF VCAT]""
Begin DoDot:1
+26 ; Examined or Interpreted
IF "EDT"[VCAT
SET STOUT=$SELECT(VCAT="E":2,1:3)
+27 ; Not yet Verified ; ISI-P106
IF '$TEST
IF "WR"[VCAT
SET STOUT=1
End DoDot:1
if STOUT
GOTO STATCHK2
+28 ; Completed exam
IF ORDER=9
SET STOUT=3
+29 IF '$TEST
IF ORDER=0
SET REPLY="0^Exam Cancelled"
+30 ; Waiting for exam
IF '$TEST
IF ORDER=1
SET STOUT=1
STATCHK2 ;
+1 IF STOUT<2
Begin DoDot:1
+2 ; Radiologist or Tech -- OK to access
FOR X="S","R","T"
IF $DATA(^VA(200,"ARC",X,DUZ))
SET STOUT=4
QUIT
End DoDot:1
STATCHKZ ;
+1 IF STOUT
SET REPLY=STOUT_U_$SELECT(STOUT=1:"Images not yet verified",STOUT=2:"Images verified by Technologist",STOUT=3:"Images interpreted by Radiologist",STOUT=4:"Radiology professional--OK to view images.",1:"")
+2 SET MAGGRY=REPLY
+3 QUIT
+4 ;
+5 ;***** User set/clear flag to show/not show remote exams only.
+6 ; RPC: MAGJ REMOTESCREEN
+7 ;
REMSCRN(MAGGRY,DATA) ;
+1 ; Input in DATA: 1/0 1=show remote only; 0=show all exams
+2 ; Return: Reply^Code~msg
+3 ; Reply -- 0=Problem; 1=Success
+4 ; Code -- 4=Error; 1=ok
+5 ; msg -- display text if error
+6 ;
+7 NEW $ETRAP,$ESTACK
SET $ETRAP="G ERR3^MAGJUTL4"
+8 NEW REPLY
+9 NEW DIQUIET
SET DIQUIET=1
DO DT^DICRW
+10 IF $DATA(DATA)
IF (DATA=0!(DATA=1))
+11 IF '$TEST
SET REPLY="0^4~REMOTESCREEN request has invalid parameter ("_$GET(DATA)_")"
GOTO REMSCRNZ
+12 SET MAGJOB("REMOTESCREEN")=DATA
SET REPLY="1^1~"_DATA
REMSCRNZ ;
+1 SET MAGGRY=REPLY
+2 QUIT
+3 ;
RPT2DPT(RARPT,RET) ; Input RARPT. Return RET containing exam ss values for ^RADPT
+1 ;
+2 NEW DFN,DTI,CNI
SET (DFN,DTI,CNI)=""
+3 IF RARPT?1N.N
IF $DATA(^RARPT(RARPT))
SET X=$GET(^(RARPT,0))
IF X]""
Begin DoDot:1
+4 SET X=$PIECE(X,U)
+5 SET X=$ORDER(^RADPT("ADC",X,0))
IF X
SET DFN=X
SET DTI=$ORDER(^(X,0))
SET CNI=$ORDER(^(DTI,0))
+6 SET RET=DFN_U_DTI_U_CNI
End DoDot:1
+7 IF '$TEST
SET RET=""
+8 QUIT
+9 ;
ERR1 NEW ERR
SET ERR=$$EC^%ZOSV
SET @MAGGRY@(0)="0^4~"_ERR
GOTO ERR
ERR3 NEW ERR
SET ERR=$$EC^%ZOSV
SET MAGGRY="0^4~"_ERR
ERR DO @^%ZOSF("ERRTN")
+1 if $QUIT
QUIT 1
QUIT
+2 ;
END ;
QUIT
+1 ;
+2 ;***** Identify if mammogram via CPT Code. Called by OPENCASE^MAGJEX1.
+3 ;
+4 ; Calls ZRUMDLST, $$CPT^ICPTCOD (which may return "-1^NO SUCH ENTRY").
+5 ;
+6 ; CPT CPT Code
+7 ;
+8 ; Return Value:
+9 ; 0 NOT a mammogram.
+10 ; 1 IS a mammogram.
+11 ;
ZRUMAMMO(CPT) ;
+1 NEW CPTCATIEN,YN
SET YN=0
+2 SET CPTCATIEN=$PIECE($$CPT^ICPTCOD(CPT),U,4)
if CPTCATIEN=""
QUIT YN
if +CPTCATIEN<0
QUIT YN
+3 ;
+4 ; Criterion (1A): CPT Category (cf., ^DIC(81.1,240,0)=BREAST MAMMOGRAPHY^s^4^77051^77059^C).
+5 IF $PIECE(^DIC(81.1,CPTCATIEN,0),U)="BREAST MAMMOGRAPHY"
SET YN=1
Begin DoDot:1
+6 ;
+7 ; Criterion (1B): CPT "Modality" (using MAGS array's modalities via ZRUMDLST).
+8 NEW MODALITY
+9 DO ZRUMDLST(.MAGS)
IF '$DATA(MAGMDLST)
SET YN=1
QUIT
+10 FOR MODALITY="MR","OCT","US"
if $DATA(MAGMDLST(MODALITY))
SET YN=0
End DoDot:1
+11 ;
+12 ; Criterion (2) -- Deprecated mammography CPTs.
+13 IF '$TEST
Begin DoDot:1
+14 NEW CPTMAM
FOR CPTMAM=76082,76083,76085:1:76092
IF CPT=CPTMAM
SET YN=1
QUIT
End DoDot:1
+15 QUIT YN
+16 ;
+17 ;+++++ Array any unique MAGS' piece 3 modalities. Called by ZRUMAMMO.
+18 ;
+19 ; .MAGS Array of individual image data (cf. JBFETCH^MAGJUTL2).
+20 ;
+21 ; Sets array MAGMDLST(modality).
+22 ;
ZRUMDLST(MAGS) ;
+1 KILL MAGMDLST
+2 IF $DATA(MAGS)
IF MAGS
NEW MD0,X
FOR X=1:1:MAGS
Begin DoDot:1
+3 SET MD0=$PIECE(MAGS(X),U,3)
IF MD0'=""
IF '$DATA(MAGMDLST(MD0))
SET MAGMDLST(MD0)=""
End DoDot:1
+4 QUIT
+5 ;
+6 ;+++++ Strip IN's trailing elements & append REPL.
+7 ;
+8 ; IN String to operate on.
+9 ; REPL String to place at right end.
+10 ; STRIP String to remove from right end.
+11 ;
+12 ; Returns:
+13 ; IN_REPL
+14 ;
ZRUPUNCT(IN,STRIP,REPL) ;
+1 if '$DATA(IN)!('$DATA(STRIP))!('$DATA(REPL))
QUIT
FOR
if STRIP'[$EXTRACT(IN,$LENGTH(IN))
QUIT
SET IN=$EXTRACT(IN,1,$LENGTH(IN)-1)
+2 QUIT IN_REPL
+3 ;
+4 ; ***** Query to modify existing annotations. Called by OPENCASE^MAGJEX1
+5 ;
+6 ; DUZ Kernel internal user identifier.
+7 ; RACNI RAD/NUC Med Patient File (#70) Case Number Index
+8 ; RADFN " Patient DFN
+9 ; RADTI " Study Internal Date
+10 ;
+11 ; Return Value:
+12 ; 0 NOT authorized to annotate.
+13 ; 1 AUTHORIZED "".
+14 ;
ZRUREVAN(RADFN,RADTI,RACNI) ;
+1 ;
+2 ; Initialize. Exit if RAxxx pointers fail.
+3 NEW EXAMSTAT,EXMSTSPT,RADNOD,RIST1,RIST2,YN
+4 SET YN=0
SET RADNOD=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+5 if RADNOD=""
QUIT YN
+6 ;
+7 ; Collect data about ...
+8 ; .. PRIMARY INTERPRETING RESIDENT [12P:200]
SET RIST1=$PIECE(RADNOD,U,12)
+9 ; .. PRIMARY INTERPRETING STAFF [15P:200]
SET RIST2=$PIECE(RADNOD,U,15)
+10 ;. EXAM STATUS [3P:72]
SET EXMSTSPT=$PIECE(RADNOD,U,3)
+11 ; VISTARAD CATEGORY (#9)
SET EXAMSTAT=$PIECE($GET(^RA(72,EXMSTSPT,0)),U,9)
+12 ;
+13 IF EXAMSTAT="D"!(EXAMSTAT="T")
Begin DoDot:1
+14 ;
+15 ; 'Yes' if CurrentUser=Primary Interpreting Radiologist.
+16 IF DUZ=RIST1!(DUZ=RIST2)
SET YN=1
+17 ; 'Yes' if (Primary Interpreting Radiologist is Resident) & (CurrentUser is Staff)
IF '$TEST
IF RIST1'=""
IF $DATA(^VA(200,"ARC","S",+DUZ))
SET YN=1
+18 QUIT
End DoDot:1
+19 QUIT YN
