- 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 Feb 18, 2025@23:33:30 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