Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: MAGJUTL4

MAGJUTL4.m

Go to the documentation of this file.
  1. 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
  1. ;; Per VHA Directive 2004-038, this routine should not be modified.
  1. ;; +---------------------------------------------------------------+
  1. ;; | Property of the US Government. |
  1. ;; | No permission to copy or redistribute this software is given. |
  1. ;; | Use of unreleased versions of this software requires the user |
  1. ;; | to execute a written test agreement with the VistA Imaging |
  1. ;; | Development Office of the Department of Veterans Affairs, |
  1. ;; | telephone (301) 734-0100. |
  1. ;; | The Food and Drug Administration classifies this software as |
  1. ;; | a medical device. As such, it may not be changed in any way. |
  1. ;; | Modifications to this software may result in an adulterated |
  1. ;; | medical device under 21CFR820, the use of which is considered |
  1. ;; | to be a violation of US Federal Statutes. |
  1. ;; +---------------------------------------------------------------+
  1. ;;
  1. ;; ISI IMAGING;**99,106**
  1. Q
  1. ;
  1. ;***** Return matching CPT's based on grouping criteria.
  1. ; RPC: MAGJ CPTMATCH
  1. ;
  1. CPTGRP(MAGGRY,DATA) ;
  1. ; FOR INPUT cpt code, return matching cpt's based on grouping criteria:
  1. ; INPUT in DATA: CPT Code ^ Criteria
  1. ; Criteria:
  1. ; 1=Matching cpt
  1. ; 2=Body Part
  1. ; 3=Body Part & Modality
  1. ; 10=Same CPT (used to return short description only)
  1. ; Return: List of CPTs with Short Name: CPT ^ Short Name
  1. ; MAGGRY holds $NA reference to ^TMP for rpc return
  1. ; all ref's to MAGGRY use subscript indirection
  1. ;
  1. N $ETRAP,$ESTACK S $ETRAP="G ERR1^MAGJUTL4"
  1. N REPLY,DIQUIET,CPT,CRIT,CT,MAGLST,NOD,NODLST
  1. N MATCHGRP,INDXLST,AND,RET,CPTGLB,CPTIN,CPTIEN,TCPT,CPTFILIEN,CPTFILDAT,IEN
  1. ;
  1. ; <*> Issue: Unable get specific body part for some non-specific CPTs (e.g., 75774-ANGIO SELECT EA ADD VESSEL-S)
  1. ; --> For these, could just return matching CPTs (or equivalent CPT?)
  1. ;
  1. ; Produce List of cptiens for each INDX of interest
  1. ; AND with next list of cptiens; repeat until no more INDXs
  1. ; build output list of CPT codes (w/ short names [optional])
  1. ;
  1. S DIQUIET=1 D DT^DICRW
  1. S CT=0,MAGLST="MAGJCPT"
  1. K MAGGRY S MAGGRY=$NA(^TMP($J,MAGLST)) K @MAGGRY ; assign MAGGRY value
  1. S CPTIN=$P(DATA,U),CRIT=$P(DATA,U,2),CPTIEN=""
  1. S REPLY="0^Getting matching CPT info."
  1. S:'CRIT CRIT=1 ; default equivalent
  1. I '(CRIT=1!(CRIT=2)!(CRIT=3)!(CRIT=10)) S REPLY="0^Invalid cpt lookup criteria ("_DATA_")." G CPTGRPZ
  1. I CPTIN="" S REPLY="0^Invalid CPT code ("_DATA_")." G CPTGRPZ
  1. S CPTFILDAT=$$CPT^ICPTCOD(CPTIN)
  1. I +CPTFILDAT=-1 S CPTFILDAT=""
  1. S CPTFILIEN=$P(CPTFILDAT,U)
  1. S CPTGLB=$NA(^MAG(2006.67))
  1. I CPTFILIEN S CPTIEN=$O(@CPTGLB@("B",CPTFILIEN,""))
  1. I 'CPTIEN D G CPTGRPZ
  1. . ; if no entry in CPTGLB, return same CPT
  1. . S CT=CT+1,@MAGGRY@(CT)=CPTIN_U_$P(CPTFILDAT,U,3)
  1. . I CPTFILIEN S REPLY=CT_U_"1~ "_CT_" CPT name returned for "_CPTIN
  1. . E S REPLY=CT_U_"1~ "_CT_" record returned--no value found for "_CPTIN
  1. S X=@CPTGLB@(CPTIEN,0),MATCHGRP=+$P(X,U,4)
  1. ;CPTMATCH^BODYPART^MDL
  1. I CRIT=2!(CRIT=3) D
  1. . S X=0 F S X=$O(@CPTGLB@(CPTIEN,1,"B",X)) Q:'X D GETCPTS("BODYPART",X,"",.RET)
  1. . I CRIT=3 D
  1. . . M AND=RET K RET S X=0
  1. . . F S X=$O(@CPTGLB@(CPTIEN,2,"B",X)) Q:'X D GETCPTS("MDL",X,.AND,.RET)
  1. I CRIT=1 D
  1. . I MATCHGRP,(MATCHGRP'=CPTIEN) S RET(MATCHGRP)="" D GETCPTS("CPTMATCH",MATCHGRP,"",.RET)
  1. . D GETCPTS("CPTMATCH",CPTIEN,"",.RET)
  1. I CRIT=10 ; fall through answers this!
  1. I '$D(RET(CPTIEN)) S RET(CPTIEN)="" ; always report back input cpt
  1. S IEN=0 F S IEN=$O(RET(IEN)) Q:'IEN D
  1. . N LIN S X=$G(@CPTGLB@(IEN,0))
  1. . Q:'(X]"") S TCPT=$P(X,U),LIN=$P($$CPT^ICPTCOD(TCPT),U,2,3)
  1. . S CT=CT+1,@MAGGRY@(CT)=LIN
  1. S REPLY=CT_U_"1~ "_CT_" CPT Matches returned for "_CPTIN
  1. CPTGRPZ ;
  1. S @MAGGRY@(0)=REPLY
  1. Q
  1. ;
  1. 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
  1. N X,GLBREF,CPTIEN
  1. S GLBREF=$NA(@CPTGLB@(INDEX,VALUE))
  1. S CPTIEN=0
  1. I $D(AND)>9 D
  1. . F S CPTIEN=$O(AND(CPTIEN)) Q:CPTIEN="" I $D(@GLBREF@(CPTIEN)) S OUT(CPTIEN)=""
  1. E F S CPTIEN=$O(@GLBREF@(CPTIEN)) Q:'CPTIEN D
  1. . S OUT(CPTIEN)=""
  1. Q
  1. ;
  1. BODPART(CPTIEN,DLM) ; return DLM-delimited list of body part values for this CPT
  1. I +$G(CPTIEN)
  1. E Q ""
  1. N LIST,CPTGLB S LIST=""
  1. S DLM=$E($G(DLM))
  1. I DLM="" S DLM="^"
  1. S CPTGLB=$NA(^MAG(2006.67))
  1. S NOD=0
  1. F S NOD=$O(@CPTGLB@(CPTIEN,1,NOD)) Q:'NOD S X=$P(^(NOD,0),U) I X]"" S LIST=LIST_DLM_X
  1. Q:$Q $E(LIST,2,999) Q
  1. ;
  1. MDLLST(CPTIEN,DLM) ; return DLM-delimited list of modality values for this CPT
  1. I +$G(CPTIEN)
  1. E Q ""
  1. N LIST,CPTGLB S LIST=""
  1. S DLM=$E($G(DLM))
  1. I DLM="" S DLM="^"
  1. S CPTGLB=$NA(^MAG(2006.67))
  1. S NOD=0
  1. F S NOD=$O(@CPTGLB@(CPTIEN,2,NOD)) Q:'NOD S X=$P(^(NOD,0),U) I X]"" S LIST=LIST_DLM_X
  1. Q:$Q $E(LIST,2,999) Q
  1. ;
  1. ;***** Returns server data to display in new "Image Display" window (P101.31).
  1. ; RPC: MAGJ MAGDATADUMP
  1. ;
  1. ; DATA REQUEST ^ PARAM1 | PARAM2
  1. ;
  1. ; ..... REQUEST determines format:
  1. ;
  1. ; ^01: REQUEST Literal string: [ CPT, FLDS, GLB ]
  1. ;
  1. ; ^02: if REQUEST="CPT":
  1. ;
  1. ; |01: PARAM1 CPT Code
  1. ; |02: [PARAM2] ""
  1. ;
  1. ; ^02: if REQUEST="FLDS" or "GLB":
  1. ;
  1. ; |01: [PARAM1] FileMan GETS^DIQ Flags (only if REQUEST="FLDS") *OR*
  1. ; |02: PARAM2 ImageIEN or Case_ID_String
  1. ;
  1. ; Return Values:
  1. ; 0:N lines to display (Internal Imaging or CPT Match data).
  1. ;
  1. DATADUMP(MAGGRY,DATA) ;
  1. ;
  1. ; Initialize. <*> Do NOT change name of EP
  1. ; Also called as subroutine from INCPT^MAGJMN3
  1. ;
  1. N $ETRAP,$ESTACK S $ETRAP="G ERR1^MAGJUTL4"
  1. N CT,CPT,CPTFILIEN,CPTNAM,DIQUIET,IMGIEN,INVALID,PARAM1,PARAM2,REQUEST
  1. S DIQUIET=1 D DT^DICRW
  1. K MAGGRY S MAGGRY=$NA(^TMP($J,"MAGJDATA")) K @MAGGRY
  1. ;
  1. ; Validate input.
  1. S INVALID=$$DDMPVLD8()
  1. ;
  1. ; Process then Exit, REPLYing with data or error code.
  1. I 'INVALID D
  1. . D DDMPROCS S REPLY=CT_U_"1~ "_CT_" lines of text returned for "_DATA
  1. . M @MAGGRY=XMM K XMM
  1. E S REPLY="0^Invalid image data request: "_""""_DATA_""""_" (ck"_INVALID_")."
  1. S @MAGGRY@(0)=REPLY
  1. Q
  1. ;
  1. ;+++++ Process according to REQUEST. Called by DATADUMP.
  1. ;
  1. ; Calls: GETS^MAGGTSYS, MAG^MAGGTSY1.
  1. ;
  1. ; Local array MM structures multiple calls' output for centralized processing.
  1. ; The array is re-subscripted by converting "," to "." allowing a single MERGE
  1. ; to the broker output global.
  1. ;
  1. ; MM(.1:.99) ... Header information.
  1. ; MM(1) ........ CPT (similar) match(es).
  1. ; MM(2) ........ CPT (BodyPart and Modality) match(es).
  1. ; MM(3) ........ FLDS output data.
  1. ; MM(4) ........ GLB output data.
  1. ;
  1. DDMPROCS ;
  1. ;
  1. ; Initialize.
  1. S REPLY="0^Retrieving imaging internal data ..."
  1. ;
  1. ; Process. CPT request via MAG RAD CPT MATCHING File (#2006.67).
  1. I REQUEST="CPT" D DDMPRCPT(CPTFILIEN)
  1. I REQUEST="FLDS" D GETS^MAGGTSYS(.M,IMGIEN,PARAM1) M MM(3)=@M K M
  1. I REQUEST="GLB" D MAG^MAGGTSY2(.M,IMGIEN) M MM(4)=@M K M
  1. ;
  1. ; Re-subscript array MM into XMM to simplify MERGE to broker output global.
  1. S CT=0,MMX=$NA(MM(0))
  1. F S MMX=$Q(@MMX) Q:MMX="" S CT=CT+1,XMM(CT)=@MMX
  1. K MM,MMX
  1. Q
  1. ;
  1. ;+++++ Process a CPT request. Called by DDMPROCS
  1. ;
  1. ; Calls CPT^ICPTCOD for CPT Description.
  1. ;
  1. DDMPRCPT(CPTFILIEN) ;
  1. ;
  1. ; Initialize.
  1. N FN,FN1,NDX,NOD,SS,X
  1. ;
  1. ; Set section headers.
  1. S MM(.1)="Input CPT Code ........... "_CPT_" ("_CPTNAM_")"
  1. S MM(.2)=" Body Part(s) ... "
  1. S MM(.3)=" Modality(s) .... "
  1. ;
  1. ; Set primary CPT bodyPart & modality.
  1. S FN=2006.67,FN1=2006.671,NDX=$O(^MAG(FN,"B",CPTFILIEN,""))
  1. S NOD=$NA(^MAG(FN,NDX,0)) F S NOD=$Q(@NOD) Q:$QS(NOD,2)>NDX I $QS(NOD,4)="B" D
  1. . I $QS(NOD,3)=1 S MM(.2)=MM(.2)_$G(^MAG(FN1,$QS(NOD,5),0))_"; "
  1. . I $QS(NOD,3)=2 S MM(.3)=MM(.3)_$P($G(^RAMIS(73.1,$QS(NOD,5),0)),U)_"; "
  1. . Q
  1. ;
  1. ; Strip dangling concatenators.
  1. F SS=.2,.3 S MM(SS)=$$ZRUPUNCT(MM(SS),"; ","")
  1. ;
  1. ; Fetch CPTs matching on CPT.
  1. D CPTGRP(.M,CPT_"^1") M MM(1)=@M K M
  1. S MM(1,0)=$P(MM(1,0),"~ ",2)
  1. S MM(1,0)=$J(+$P(MM(1,0)," "),3)_" matching CPT(s) via Similar CPT:"
  1. ;
  1. ; Fetch CPTs matching on BodyPart & Modality.
  1. D CPTGRP(.M,CPT_"^3") M MM(2)=@M K M
  1. S MM(2,0)=$P(MM(2,0),"~ ",2)
  1. S MM(2,0)=$J(+$P(MM(2,0)," "),3)_" matching CPT(s) via BODY PART and MODALITY:"
  1. ;
  1. ; Re-format. [Not modular -- should provide for leaving as-is.]
  1. S MMX=$NA(MM(.99)) F S MMX=$Q(@MMX) Q:MMX="" I @MMX["^" S @MMX=" "_$TR(@MMX,"^"," ")
  1. Q
  1. ;
  1. ;+++++ Validate. Called by DATADUMP.
  1. ;
  1. DDMPVLD8() ;
  1. ;
  1. ; ... DATA string format or exit invalid (code 1).
  1. Q:'$D(DATA) 1
  1. Q:DATA="" 1
  1. Q:DATA'["^"!(DATA'["|") 1
  1. ;
  1. ; Initialize.
  1. N GO,RACNI,RADFN,RADTI,RARPT S REPLY="0^Validating input parameters ..."
  1. S REQUEST=$P(DATA,U),PARAM1=$P($P(DATA,U,2),"|"),PARAM2=$P(DATA,"|",2)
  1. ;
  1. ; ... DATA string's REQUEST piece or exit (invalid: code 2).
  1. Q:"^CPT^FLDS^GLB^"'[(U_REQUEST_U) 2
  1. ;
  1. ; ... PARAM1 if REQUEST="CPT" or exit (invalid: code 3).
  1. I REQUEST="CPT" D I 'GO Q 3
  1. . S GO=PARAM1]"" Q:'GO
  1. . S X=$$CPT^ICPTCOD(PARAM1),CPTFILIEN=$P(X,U),CPT=$P(X,U,2),CPTNAM=$P(X,U,3)
  1. . I CPTFILIEN,$D(^MAG(2006.67,"B",CPTFILIEN))
  1. . E S GO=0
  1. ;
  1. ; ... PARAM1 if REQUEST="FLDS" or re-set to null. External call will set defaults.
  1. ; .......... only validate format of FileMan flags.
  1. I REQUEST="FLDS"&(PARAM1'?1U.U) S PARAM1=""
  1. ;
  1. ; ... PARAM2 if REQUEST=("FLDS" or "GLB") or exit (invalid: code 4).
  1. I REQUEST="FLDS"!(REQUEST="GLB") S IMGIEN="" D Q:IMGIEN="" 4
  1. . ;
  1. . ; Case 1: PARAM2 holds IMGIEN.
  1. . I PARAM2?1N.N,$D(^MAG(2005,PARAM2)) S IMGIEN=PARAM2 Q
  1. . ;
  1. . ; Case 2: PARAM2 holds RARPT in piece 4, set IMGIEN via back-pointer in File #74.
  1. . I $L(PARAM2,U)=4 S RARPT=$P(PARAM2,U,4) I +RARPT S IMGIEN=$O(^RARPT(RARPT,2005,"B","")) ; ISI P106
  1. . I IMGIEN'="",$D(^MAG(2005,IMGIEN)) Q
  1. . ;
  1. . ; Case 3: PARAM2 holds RADFN^RADTI^RACNI in pieces 1:3.
  1. . S RADFN=+PARAM2,RADTI=$P(PARAM2,U,2),RACNI=$P(PARAM2,U,3)
  1. . I RADFN,RADTI,RACNI D
  1. . . S RARPT=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,17)
  1. . . I RARPT'="",$D(^RARPT(RARPT,2005,"B"))>1 S IMGIEN=$O(^RARPT(RARPT,2005,"B",""))
  1. Q 0
  1. ;
  1. ;***** Check Exam Status.
  1. ; RPC: MAGJ RADSTATUSCHECK
  1. ;
  1. STATCHK(MAGGRY,DATA) ;
  1. ; This may also be accessed by subroutine call. <*> do not change name of EP
  1. ; Exam Status check RPC and subroutine: determine if the exam has been Tech-Verified (at least).
  1. ; Images are assumed to be verified if Exam Status is Examined, or higher status.
  1. ; ; Input in DATA: RADFN^RADTI^RACNI^RARPT
  1. ; Input is either RADFN, RADTI, and RACNI; or, RARPT only may be input in piece 4
  1. ; Return: Code^Text
  1. ; 0 = Problem, or exam was cancelled
  1. ; 1 = Not yet verified
  1. ; 2 = Tech Verified
  1. ; 3 = Radiologist Verified
  1. ; 4 = User is a Radiology professional--always allow access
  1. ;
  1. N $ETRAP,$ESTACK S $ETRAP="G ERR3^MAGJUTL4"
  1. N REPLY,STATUS,ORDER,VCAT,STOUT
  1. N DIQUIET,RARPT,RADFN,RADTI,RACNI
  1. S DIQUIET=1 D DT^DICRW
  1. S RADFN=$P(DATA,U),RADTI=$P(DATA,U,2),RACNI=$P(DATA,U,3),RARPT=$P(DATA,U,4)
  1. S STOUT="",REPLY="0^Getting image verification status."
  1. I RADFN,RADTI,RACNI
  1. 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
  1. E S REPLY="0^Image Verification Status request contains invalid case pointer ("_DATA_")" G STATCHKZ
  1. S STATUS=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,3)
  1. I STATUS="" S REPLY="0^Image Verification Status request error--no Exam Status is defined for ("_DATA_")" G STATCHKZ
  1. S VCAT=$P(^RA(72,STATUS,0),U,9),ORDER=$P(^(0),U,3)
  1. I VCAT]"" D G STATCHK2:STOUT
  1. . I "EDT"[VCAT S STOUT=$S(VCAT="E":2,1:3) ; Examined or Interpreted
  1. . E I "WR"[VCAT S STOUT=1 ; Not yet Verified ; ISI-P106
  1. I ORDER=9 S STOUT=3 ; Completed exam
  1. E I ORDER=0 S REPLY="0^Exam Cancelled"
  1. E I ORDER=1 S STOUT=1 ; Waiting for exam
  1. STATCHK2 ;
  1. I STOUT<2 D
  1. . F X="S","R","T" I $D(^VA(200,"ARC",X,DUZ)) S STOUT=4 Q ; Radiologist or Tech -- OK to access
  1. STATCHKZ ;
  1. 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:"")
  1. S MAGGRY=REPLY
  1. Q
  1. ;
  1. ;***** User set/clear flag to show/not show remote exams only.
  1. ; RPC: MAGJ REMOTESCREEN
  1. ;
  1. REMSCRN(MAGGRY,DATA) ;
  1. ; Input in DATA: 1/0 1=show remote only; 0=show all exams
  1. ; Return: Reply^Code~msg
  1. ; Reply -- 0=Problem; 1=Success
  1. ; Code -- 4=Error; 1=ok
  1. ; msg -- display text if error
  1. ;
  1. N $ETRAP,$ESTACK S $ETRAP="G ERR3^MAGJUTL4"
  1. N REPLY
  1. N DIQUIET S DIQUIET=1 D DT^DICRW
  1. I $D(DATA),(DATA=0!(DATA=1))
  1. E S REPLY="0^4~REMOTESCREEN request has invalid parameter ("_$G(DATA)_")" G REMSCRNZ
  1. S MAGJOB("REMOTESCREEN")=DATA,REPLY="1^1~"_DATA
  1. REMSCRNZ ;
  1. S MAGGRY=REPLY
  1. Q
  1. ;
  1. RPT2DPT(RARPT,RET) ; Input RARPT. Return RET containing exam ss values for ^RADPT
  1. ;
  1. N DFN,DTI,CNI S (DFN,DTI,CNI)=""
  1. I RARPT?1N.N,$D(^RARPT(RARPT)) S X=$G(^(RARPT,0)) I X]"" D
  1. . S X=$P(X,U)
  1. . S X=$O(^RADPT("ADC",X,0)) I X S DFN=X,DTI=$O(^(X,0)),CNI=$O(^(DTI,0))
  1. . S RET=DFN_U_DTI_U_CNI
  1. E S RET=""
  1. Q
  1. ;
  1. ERR1 N ERR S ERR=$$EC^%ZOSV S @MAGGRY@(0)="0^4~"_ERR G ERR
  1. ERR3 N ERR S ERR=$$EC^%ZOSV S MAGGRY="0^4~"_ERR
  1. ERR D @^%ZOSF("ERRTN")
  1. Q:$Q 1 Q
  1. ;
  1. END Q ;
  1. ;
  1. ;***** Identify if mammogram via CPT Code. Called by OPENCASE^MAGJEX1.
  1. ;
  1. ; Calls ZRUMDLST, $$CPT^ICPTCOD (which may return "-1^NO SUCH ENTRY").
  1. ;
  1. ; CPT CPT Code
  1. ;
  1. ; Return Value:
  1. ; 0 NOT a mammogram.
  1. ; 1 IS a mammogram.
  1. ;
  1. ZRUMAMMO(CPT) ;
  1. N CPTCATIEN,YN S YN=0
  1. S CPTCATIEN=$P($$CPT^ICPTCOD(CPT),U,4) Q:CPTCATIEN="" YN Q:+CPTCATIEN<0 YN
  1. ;
  1. ; Criterion (1A): CPT Category (cf., ^DIC(81.1,240,0)=BREAST MAMMOGRAPHY^s^4^77051^77059^C).
  1. I $P(^DIC(81.1,CPTCATIEN,0),U)="BREAST MAMMOGRAPHY" S YN=1 D
  1. . ;
  1. . ; Criterion (1B): CPT "Modality" (using MAGS array's modalities via ZRUMDLST).
  1. . N MODALITY
  1. . D ZRUMDLST(.MAGS) I '$D(MAGMDLST) S YN=1 Q
  1. . F MODALITY="MR","OCT","US" S:$D(MAGMDLST(MODALITY)) YN=0
  1. ;
  1. ; Criterion (2) -- Deprecated mammography CPTs.
  1. E D
  1. . N CPTMAM F CPTMAM=76082,76083,76085:1:76092 I CPT=CPTMAM S YN=1 Q
  1. Q YN
  1. ;
  1. ;+++++ Array any unique MAGS' piece 3 modalities. Called by ZRUMAMMO.
  1. ;
  1. ; .MAGS Array of individual image data (cf. JBFETCH^MAGJUTL2).
  1. ;
  1. ; Sets array MAGMDLST(modality).
  1. ;
  1. ZRUMDLST(MAGS) ;
  1. K MAGMDLST
  1. I $D(MAGS),MAGS N MD0,X F X=1:1:MAGS D
  1. . S MD0=$P(MAGS(X),U,3) I MD0'="",'$D(MAGMDLST(MD0)) S MAGMDLST(MD0)=""
  1. Q
  1. ;
  1. ;+++++ Strip IN's trailing elements & append REPL.
  1. ;
  1. ; IN String to operate on.
  1. ; REPL String to place at right end.
  1. ; STRIP String to remove from right end.
  1. ;
  1. ; Returns:
  1. ; IN_REPL
  1. ;
  1. ZRUPUNCT(IN,STRIP,REPL) ;
  1. Q:'$D(IN)!('$D(STRIP))!('$D(REPL)) F Q:STRIP'[$E(IN,$L(IN)) S IN=$E(IN,1,$L(IN)-1)
  1. Q IN_REPL
  1. ;
  1. ; ***** Query to modify existing annotations. Called by OPENCASE^MAGJEX1
  1. ;
  1. ; DUZ Kernel internal user identifier.
  1. ; RACNI RAD/NUC Med Patient File (#70) Case Number Index
  1. ; RADFN " Patient DFN
  1. ; RADTI " Study Internal Date
  1. ;
  1. ; Return Value:
  1. ; 0 NOT authorized to annotate.
  1. ; 1 AUTHORIZED "".
  1. ;
  1. ZRUREVAN(RADFN,RADTI,RACNI) ;
  1. ;
  1. ; Initialize. Exit if RAxxx pointers fail.
  1. N EXAMSTAT,EXMSTSPT,RADNOD,RIST1,RIST2,YN
  1. S YN=0,RADNOD=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
  1. Q:RADNOD="" YN
  1. ;
  1. ; Collect data about ...
  1. S RIST1=$P(RADNOD,U,12) ; .. PRIMARY INTERPRETING RESIDENT [12P:200]
  1. S RIST2=$P(RADNOD,U,15) ; .. PRIMARY INTERPRETING STAFF [15P:200]
  1. S EXMSTSPT=$P(RADNOD,U,3) ;. EXAM STATUS [3P:72]
  1. S EXAMSTAT=$P($G(^RA(72,EXMSTSPT,0)),U,9) ; VISTARAD CATEGORY (#9)
  1. ;
  1. I EXAMSTAT="D"!(EXAMSTAT="T") D
  1. . ;
  1. . ; 'Yes' if CurrentUser=Primary Interpreting Radiologist.
  1. . I DUZ=RIST1!(DUZ=RIST2) S YN=1
  1. . E I RIST1'="",$D(^VA(200,"ARC","S",+DUZ)) S YN=1 ; 'Yes' if (Primary Interpreting Radiologist is Resident) & (CurrentUser is Staff)
  1. . Q
  1. Q YN