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