source: FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGJUTL4.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 7.5 KB
Line 
1MAGJUTL4 ;WIRMFO/JHC VistARad subroutines for RPC calls ; 15 Jul 2004 4:34 PM
2 ;;3.0;IMAGING;**18,76**;Jun 22, 2007;Build 19
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;; +---------------------------------------------------------------+
5 ;; | Property of the US Government. |
6 ;; | No permission to copy or redistribute this software is given. |
7 ;; | Use of unreleased versions of this software requires the user |
8 ;; | to execute a written test agreement with the VistA Imaging |
9 ;; | Development Office of the Department of Veterans Affairs, |
10 ;; | telephone (301) 734-0100. |
11 ;; | |
12 ;; | The Food and Drug Administration classifies this software as |
13 ;; | a medical device. As such, it may not be changed in any way. |
14 ;; | Modifications to this software may result in an adulterated |
15 ;; | medical device under 21CFR820, the use of which is considered |
16 ;; | to be a violation of US Federal Statutes. |
17 ;; +---------------------------------------------------------------+
18 ;;
19 Q
20 ;
21CPTGRP(MAGGRY,DATA) ; RPC: MAGJ CPTMATCH
22 ; FOR INPUT cpt code, return matching cpt's based on grouping criteria:
23 ; INPUT in DATA: CPT Code ^ Criteria
24 ; Criteria:
25 ; 1=Matching cpt
26 ; 2=Body Part
27 ; 3=Body Part & Modality
28 ; 10=Same CPT (used to return short description only)
29 ; Return: List of CPTs with Short Name: CPT ^ Short Name
30 ; MAGGRY holds $NA reference to ^TMP for rpc return
31 ; all ref's to MAGGRY use subscript indirection
32 ;
33 N $ETRAP,$ESTACK S $ETRAP="G ERR1^MAGJUTL4"
34 N REPLY,DIQUIET,CPT,CRIT,CT,MAGLST,NOD,NODLST
35 N MATCHGRP,INDXLST,AND,RET,CPTGLB,CPTIN,CPTIEN,TCPT
36 ;
37 ; <*> Issue: Unable get specific body part for some non-specific CPTs (e.g., 75774-ANGIO SELECT EA ADD VESSEL-S)
38 ; --> For these, could just return matching CPTs (or equivalent CPT?)
39 ;
40 ; Produce List of cptiens for each INDX of interest
41 ; AND with next list of cptiens; repeat until no more INDXs
42 ; build output list of CPT codes (w/ short names [optional])
43 S DIQUIET=1 D DT^DICRW
44 S CT=0,MAGLST="MAGJCPT"
45 K MAGGRY S MAGGRY=$NA(^TMP($J,MAGLST)) K @MAGGRY ; assign MAGGRY value
46 S CPTIN=$P(DATA,U),CRIT=$P(DATA,U,2)
47 S REPLY="0^Getting matching CPT info."
48 S:'CRIT CRIT=1 ; default equivalent
49 I CPTIN="" S REPLY="0^Invalid CPT code ("_DATA_")." G CPTGRPZ
50 I '(CRIT=1!(CRIT=2)!(CRIT=3)!(CRIT=10)) S REPLY="0^Invalid criteria ("_DATA_")." G CPTGRPZ
51 S CPTGLB=$NA(^MAG(2006.67))
52 S CPTIEN=$O(@CPTGLB@("B",CPTIN,""))
53 I 'CPTIEN S REPLY="0^Input CPT code ("_CPTIN_") not defined in CPT Match table." G CPTGRPZ
54 S X=@CPTGLB@(CPTIEN,0),MATCHGRP=+$P(X,U,4)
55 ;CPTMATCH^BODYPART^MDL
56 I CRIT=2!(CRIT=3) D
57 . S X=0 F S X=$O(@CPTGLB@(CPTIEN,1,"B",X)) Q:'X D GETCPTS("BODYPART",X,"",.RET)
58 . I CRIT=3 D
59 . . M AND=RET K RET S X=0
60 . . F S X=$O(@CPTGLB@(CPTIEN,2,"B",X)) Q:'X D GETCPTS("MDL",X,.AND,.RET)
61 I CRIT=1 D
62 . I MATCHGRP,(MATCHGRP'=CPTIEN) S RET(MATCHGRP)="" D GETCPTS("CPTMATCH",MATCHGRP,"",.RET)
63 . D GETCPTS("CPTMATCH",CPTIEN,"",.RET)
64 I CRIT=10 ; fall through answers this!
65 I '$D(RET(CPTIEN)) S RET(CPTIEN)="" ; always report back input cpt
66 S IEN=0 F S IEN=$O(RET(IEN)) Q:'IEN D
67 . N LIN S X=$G(@CPTGLB@(IEN,0))
68 . Q:'(X]"") S TCPT=$P(X,U),LIN=TCPT_U_$P($$CPT^ICPTCOD(TCPT),U,3) ; _U_$$BODPART(IEN,"~")_U_$$MDLLST(IEN,"~")
69 . S CT=CT+1,@MAGGRY@(CT)=LIN
70 S REPLY=CT_U_"1~ "_CT_" CPT Matches returned for "_CPTIN
71CPTGRPZ ;
72 S @MAGGRY@(0)=REPLY
73 Q
74 ;
75GETCPTS(INDEX,VALUE,AND,OUT) ; return a list of CPTIENS in OUT
76 ; if array AND is defined, reply only values contained in AND & the index
77 N X,GLBREF,CPTIEN
78 S GLBREF=$NA(@CPTGLB@(INDEX,VALUE))
79 S CPTIEN=0
80 I $D(AND)>9 D
81 . F S CPTIEN=$O(AND(CPTIEN)) Q:CPTIEN="" I $D(@GLBREF@(CPTIEN)) S OUT(CPTIEN)=""
82 E F S CPTIEN=$O(@GLBREF@(CPTIEN)) Q:'CPTIEN D
83 . S OUT(CPTIEN)=""
84 Q
85 ;
86BODPART(CPTIEN,DLM) ; return DLM-delimited list of body part values for this CPT
87 I +$G(CPTIEN)
88 E Q ""
89 N LIST,CPTGLB S LIST=""
90 S DLM=$E($G(DLM))
91 I DLM="" S DLM="^"
92 S CPTGLB=$NA(^MAG(2006.67))
93 S NOD=0
94 F S NOD=$O(@CPTGLB@(CPTIEN,1,NOD)) Q:'NOD S X=$P(^(NOD,0),U) I X]"" S LIST=LIST_DLM_X
95 Q:$Q $E(LIST,2,999) Q
96 ;
97MDLLST(CPTIEN,DLM) ; return DLM-delimited list of modality values for this CPT
98 I +$G(CPTIEN)
99 E Q ""
100 N LIST,CPTGLB S LIST=""
101 S DLM=$E($G(DLM))
102 I DLM="" S DLM="^"
103 S CPTGLB=$NA(^MAG(2006.67))
104 S NOD=0
105 F S NOD=$O(@CPTGLB@(CPTIEN,2,NOD)) Q:'NOD S X=$P(^(NOD,0),U) I X]"" S LIST=LIST_DLM_X
106 Q:$Q $E(LIST,2,999) Q
107 ;
108STATCHK(MAGGRY,DATA) ;
109 ; RPC: MAGJ RADSTATUSCHECK
110 ; This may also be accessed by subroutine call. <*> do not change name of EP
111 ; Exam Status check RPC and subroutine: determine if the exam has been Tech-Verified (at least).
112 ; Images are assumed to be verified if Exam Status is Examined, or higher status.
113 ; ; Input in DATA: RADFN^RADTI^RACNI^RARPT
114 ; Input is either RADFN, RADTI, and RACNI; or, RARPT only may be input in piece 4
115 ; Return: Code^Text
116 ; 0 = Problem, or exam was cancelled
117 ; 1 = Not yet verified
118 ; 2 = Tech Verified
119 ; 3 = Radiologist Verified
120 ; 4 = User is a Radiology professional--always allow access
121 ;
122 N $ETRAP,$ESTACK S $ETRAP="G ERR3^MAGJUTL4"
123 N REPLY,STATUS,ORDER,VCAT,STOUT
124 N DIQUIET,RARPT,RADFN,RADTI,RACNI
125 S DIQUIET=1 D DT^DICRW
126 S RADFN=$P(DATA,U),RADTI=$P(DATA,U,2),RACNI=$P(DATA,U,3),RARPT=$P(DATA,U,4)
127 S STOUT="",REPLY="0^Getting image verification status."
128 I RADFN,RADTI,RACNI
129 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
130 E S REPLY="0^Image Verification Status request contains invalid case pointer ("_DATA_")" G STATCHKZ
131 S STATUS=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,3)
132 I STATUS="" S REPLY="0^Image Verification Status request error--no Exam Status is defined for ("_DATA_")" G STATCHKZ
133 S VCAT=$P(^RA(72,STATUS,0),U,9),ORDER=$P(^(0),U,3)
134 I VCAT]"" D G STATCHK2:STOUT
135 . I "EDT"[VCAT S STOUT=$S(VCAT="E":2,1:3) ; Examined or Interpreted
136 . E I VCAT="W" S STOUT=1 ; Not yet Verified
137 I ORDER=9 S STOUT=3 ; Completed exam
138 E I ORDER=0 S REPLY="0^Exam Cancelled"
139 E I ORDER=1 S STOUT=1 ; Waiting for exam
140STATCHK2 ;
141 I STOUT<2 D
142 . F X="S","R","T" I $D(^VA(200,"ARC",X,DUZ)) S STOUT=4 Q ; Radiologist or Tech -- OK to access
143STATCHKZ ;
144 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:"")
145 S MAGGRY=REPLY
146 Q
147 ;
148REMSCRN(MAGGRY,DATA) ; User set/clear flag to show/not show remote exams only
149 ; RPC: MAGJ REMOTESCREEN
150 ; ; Input in DATA: 1/0 1=show remote only; 0=show all exams
151 ; Return: Reply^Code~msg
152 ; Reply -- 0=Problem; 1=Success
153 ; Code -- 4=Error; 1=ok
154 ; msg -- display text if error
155 ;
156 N $ETRAP,$ESTACK S $ETRAP="G ERR3^MAGJUTL4"
157 N REPLY
158 N DIQUIET S DIQUIET=1 D DT^DICRW
159 I $D(DATA),(DATA=0!(DATA=1))
160 E S REPLY="0^4~REMOTESCREEN request has invalid parameter ("_$G(DATA)_")" G REMSCRNZ
161 S MAGJOB("REMOTESCREEN")=DATA,REPLY="1^1~"_DATA
162REMSCRNZ ;
163 S MAGGRY=REPLY
164 Q
165 ;
166RPT2DPT(RARPT,RET) ; Input RARPT. Return RET containing exam ss values for ^RADPT
167 ;
168 N DFN,DTI,CNI S (DFN,DTI,CNI)=""
169 I RARPT?1N.N,$D(^RARPT(RARPT)) S X=$G(^(RARPT,0)) I X]"" D
170 . S X=$P(X,U)
171 . S X=$O(^RADPT("ADC",X,0)) I X S DFN=X,DTI=$O(^(X,0)),CNI=$O(^(DTI,0))
172 . S RET=DFN_U_DTI_U_CNI
173 E S RET=""
174 Q
175 ;
176ERR1 N ERR S ERR=$$EC^%ZOSV S @MAGGRY@(0)="0^4~"_ERR G ERR
177ERR3 N ERR S ERR=$$EC^%ZOSV S MAGGRY="0^4~"_ERR
178ERR D @^%ZOSF("ERRTN")
179 Q:$Q 1 Q
180 ;
181END Q ;
Note: See TracBrowser for help on using the repository browser.