| 1 | MAGJUTL1 ;WIRMFO/JHC VistARad subroutines for RPC calls ; 29 Jul 2003 10:03 AM
|
|---|
| 2 | ;;3.0;IMAGING;**22,18,65,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 | ;<*>Notes on possible changes to ^RAO7PC1/1A for fetching rad pkg data:
|
|---|
| 21 | ; 1) Return also: Exam Status IEN, Order Request Urgency, & Pre-Op Date
|
|---|
| 22 | ; 2) Allow to retrieve one specific exam; e.g. modify SETDATA^RAO7PC1A
|
|---|
| 23 | ; to act as a true subrtn, W/ params for RADFN, RADTI, & RACNI--if
|
|---|
| 24 | ; passed, then only the one exam would be returned
|
|---|
| 25 | ;
|
|---|
| 26 | GETEXAM3(DFN,BEGDT,ENDT,MAGRACNT,MAGRET,MORE,LIMEXAMS) ; Get data for all exams for a
|
|---|
| 27 | ; pt within a date range
|
|---|
| 28 | ; limit to LIMEXAMS entries--note, only PREFETCH & Auto-route Priors use this
|
|---|
| 29 | ; Input:
|
|---|
| 30 | ; DFN -- Patient DFN
|
|---|
| 31 | ; BEGDT -- Opt, earliest date desired
|
|---|
| 32 | ; ENDT -- Opt, latest date desired
|
|---|
| 33 | ; MAGRACNT -- Opt, pass by ref to init counter to ref return data in ^TMP (see GETEXSET)
|
|---|
| 34 | ; MORE -- Opt, If True, check for additional exams for pt
|
|---|
| 35 | ; LIMEXAMS -- Opt, limit # exams to return
|
|---|
| 36 | ; Return:
|
|---|
| 37 | ; MAGRACNT -- highest counter for return data
|
|---|
| 38 | ; MAGRET -- 1/0: exam was/not found
|
|---|
| 39 | ; MORE -- more exams exist for pt on & B4 this date
|
|---|
| 40 | ; ^TMP -- data returned (see GETEXSET)
|
|---|
| 41 | ;
|
|---|
| 42 | I '$D(DT) N DIQUIET S DIQUIET=1 D DT^DICRW
|
|---|
| 43 | S LIMEXAMS=+$G(LIMEXAMS)
|
|---|
| 44 | S:$G(BEGDT)="" BEGDT=2010101 S:$G(ENDT)="" ENDT=DT ; default all dates
|
|---|
| 45 | N MORECHK S MORECHK=+$G(MORE)
|
|---|
| 46 | S MAGRACNT=+$G(MAGRACNT),MAGRET=0,MORE=0 ; Init return data
|
|---|
| 47 | I BEGDT>ENDT S X=ENDT,ENDT=BEGDT,BEGDT=X
|
|---|
| 48 | I '(DFN&BEGDT&ENDT) Q
|
|---|
| 49 | K ^TMP($J,"RAE1") D EN1^RAO7PC1(DFN,BEGDT,ENDT,LIMEXAMS)
|
|---|
| 50 | N EXID,TMP,EX1,EX2 S EXID=0
|
|---|
| 51 | F MAGRET=0:1 S EXID=$O(^TMP($J,"RAE1",DFN,EXID)) Q:'EXID S TMP($P(EXID,"-"),$P(EXID,"-",2))=EXID
|
|---|
| 52 | S (EX1,EX2)=""
|
|---|
| 53 | F S EX1=$O(TMP(EX1)) Q:'EX1 F S EX2=$O(TMP(EX1,EX2)) Q:'EX2 D GETEXSET(DFN,TMP(EX1,EX2),"")
|
|---|
| 54 | K ^TMP($J,"RAE1")
|
|---|
| 55 | I 'MORECHK Q ; all done; else indicate if pt has more exams
|
|---|
| 56 | N DTI,CNI,STS,DTCHK
|
|---|
| 57 | I 'MAGRET S DTI=9999999.9999-BEGDT,CNI=0 ; no exam found in orig dt range
|
|---|
| 58 | E S X=^TMP($J,"MAGRAEX",MAGRACNT,1),DTI=$P(X,U,2),CNI=$P(X,U,3) ; last exam processed
|
|---|
| 59 | ; loop thru addl exams til find one that is NOT Cancelled
|
|---|
| 60 | MORE1 F S CNI=$O(^RADPT(DFN,"DT",DTI,"P",CNI)) Q:'CNI S STS=$P($G(^(CNI,0)),U,3) I STS]"" D Q:MORE
|
|---|
| 61 | . Q:($P($G(^RA(72,STS,0)),U,3)=0) ; Canceled--keep looking
|
|---|
| 62 | . S DTCHK=9999999.9999-DTI D EN1^RAO7PC1(DFN,DTCHK,DTCHK,1) ; verify there is at least one "good" exam for this date (Remedy #200480)
|
|---|
| 63 | . I +$O(^TMP($J,"RAE1",DFN,0)) S MORE=1
|
|---|
| 64 | . K ^TMP($J,"RAE1")
|
|---|
| 65 | I 'MORE S DTI=$O(^RADPT(DFN,"DT",DTI)),CNI=0 G MORE1:DTI
|
|---|
| 66 | I MORE S MORE=9999999.9999-DTI\1
|
|---|
| 67 | Q
|
|---|
| 68 | ;
|
|---|
| 69 | GETEXAM2(DFN,DTI,CNI,MAGRACNT,MAGRET) ; Fetch data for one exam
|
|---|
| 70 | ;Input:
|
|---|
| 71 | ; DFN -- Pt DFN
|
|---|
| 72 | ; DTI -- Internal Date pointer to Rad exam
|
|---|
| 73 | ; CNI -- Case pointer to Rad exam
|
|---|
| 74 | ; MAGRACNT -- Opt, pass by ref to init counter for return data in ^TMP (see GETEXSET)
|
|---|
| 75 | ; Return:
|
|---|
| 76 | ; MAGRACNT -- highest counter for return data
|
|---|
| 77 | ; MAGRET -- 1/0: exam was/not found
|
|---|
| 78 | ; ^TMP -- data returned (see GETEXSET)
|
|---|
| 79 | ;
|
|---|
| 80 | ; This subroutine calls RAO7PC1A directly to fetch exam data
|
|---|
| 81 | ; which is returned in ^TMP($J,"RAE1",DFN,DTI_"-"_CNI).
|
|---|
| 82 | ; RAO7PC1A currently returns ALL exams filed under one DTI,
|
|---|
| 83 | ; but this subroutine returns the single exam for the input DTI, CNI
|
|---|
| 84 | ;
|
|---|
| 85 | N RADFN,RACNT,RAIBDT,RAEXN,RAXIT ; Vars input to RAO7PC1A
|
|---|
| 86 | S RADFN=DFN,RACNT=0,RAIBDT=DTI,RAEXN=0,RAXIT=0
|
|---|
| 87 | ; other Vars set by RAO7PC1A:
|
|---|
| 88 | N RABNOR,RACSE,RADIAG,RANO,RAPRC,RAREX,RARPT,RARPTST,RASTNM,RAXAM,RAXID
|
|---|
| 89 | N RABNORMR,RACPT
|
|---|
| 90 | S MAGRACNT=+$G(MAGRACNT)
|
|---|
| 91 | K ^TMP($J,"RAE1") D SETDATA^RAO7PC1A
|
|---|
| 92 | S MAGRET=RACNT Q:'RACNT ; no exams found
|
|---|
| 93 | D GETEXSET(DFN,DTI_"-"_CNI,.X)
|
|---|
| 94 | I 'X S MAGRET=0 ; no exam for this CNI
|
|---|
| 95 | K ^TMP($J,"RAE1")
|
|---|
| 96 | Q
|
|---|
| 97 | ;
|
|---|
| 98 | GETEXSET(RADFN,EXID,MAGRET) ;
|
|---|
| 99 | ; Used by GETEXAM* subroutines above to set up rad data for vrad
|
|---|
| 100 | ; Input:
|
|---|
| 101 | ; RADFN -- Pt DFN
|
|---|
| 102 | ; EXID --- RADTI_"-"_RACNI, pointers to Rad exam
|
|---|
| 103 | ; Output:
|
|---|
| 104 | ; MAGRET- 1/0: an exam was/was not filed
|
|---|
| 105 | ; ^TMP($J,"MAGRAEX",MAGRACNT)=Data String (see code at end)
|
|---|
| 106 | ; MAGRACNT described in above subroutines
|
|---|
| 107 | ;
|
|---|
| 108 | N RACN,RACNI,RADATA,RADATE,RADTE,RADTI,RADTPRT,RAELOC,RANME
|
|---|
| 109 | N RAPRC,RARPT,RASSN,RAST,RASTORD,RASTP,RASTNM,RACPT,IMTYPABB,PROCMOD
|
|---|
| 110 | N DAYCASE,REQLOC,REQLOCN,REQLOCA,REQLOCT,RIST,RIST1,RIST2,COMPLIC
|
|---|
| 111 | N RADIV,RISTISME,REQWARD,RASTCAT,CPTMOD,LRFLAG,MODTXT
|
|---|
| 112 | S MAGRET=0,RADTI=$P(EXID,"-"),RACNI=$P(EXID,"-",2)
|
|---|
| 113 | Q:'(RADTI&RACNI)
|
|---|
| 114 | S RADIV=""
|
|---|
| 115 | S RADATA=$G(^TMP($J,"RAE1",RADFN,EXID))
|
|---|
| 116 | Q:RADATA="" ; no exam for this EXID
|
|---|
| 117 | S RARPT=$P(RADATA,U,5)
|
|---|
| 118 | S X=$P(RADATA,U,6),RASTORD=$P(X,"~"),RASTNM=$P(X,"~",2)
|
|---|
| 119 | S X=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),COMPLIC=$D(^("COMP")),PROCMOD=$D(^("M")),CPTMOD=$D(^("CMOD"))
|
|---|
| 120 | S RAST=$P(X,U,3),REQLOC=$P(X,U,22),RIST1=$P(X,U,12),RIST2=$P(X,U,15),COMPLIC=$P(X,U,16)_"~"_COMPLIC
|
|---|
| 121 | S REQWARD=$P(X,U,6)
|
|---|
| 122 | N CT,MODS,IEN,TT ; Process Proc/CPT Modifier info
|
|---|
| 123 | S CT=0
|
|---|
| 124 | I PROCMOD D
|
|---|
| 125 | . S IEN=0
|
|---|
| 126 | . F S IEN=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",IEN)) Q:'IEN S X=$P($G(^(IEN,0)),U) I X D
|
|---|
| 127 | . . S X=$P($G(^RAMIS(71.2,X,0)),U) Q:X="" S X=$$TRIM(X)
|
|---|
| 128 | . . S X=$S(X="BILATERAL EXAM":"BILAT",1:X)
|
|---|
| 129 | . . S CT=CT+1,MODS(CT)=X
|
|---|
| 130 | I CPTMOD D
|
|---|
| 131 | . S IEN=0
|
|---|
| 132 | . F S IEN=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",IEN)) Q:'IEN S X=$P($G(^(IEN,0)),U) I X D
|
|---|
| 133 | . . S X=$P($$MOD^ICPTMOD(X,"I"),U,3) Q:X="" S X=$$TRIM(X)
|
|---|
| 134 | . . S X=$S(X="LEFT SIDE":"LEFT",X="RIGHT SIDE":"RIGHT",X="BILATERAL PROCEDURE":"BILAT",1:X)
|
|---|
| 135 | . . S CT=CT+1,MODS(CT)=X
|
|---|
| 136 | S MODTXT="",LRFLAG=0 K TT
|
|---|
| 137 | I CT F I=1:1:CT S X=MODS(I) D
|
|---|
| 138 | . ; eliminate redundant values for L/R/Bilat (TT), & track L/R for prior matching (LRFLAG)
|
|---|
| 139 | . S T=(X="LEFT") I T,$D(TT(1)) Q ; already got it
|
|---|
| 140 | . I 'T S T=(X="RIGHT") I T S T=2 I T,$D(TT(2)) Q ; ditto
|
|---|
| 141 | . I 'T S T=(X="BILAT") I T S T=3 I T,$D(TT(3)) Q ; ditto
|
|---|
| 142 | . I T S TT(T)="",MODTXT=X_$S(MODTXT="":"",1:";")_MODTXT ; force L/R/Bilat to left end of string ..
|
|---|
| 143 | . E S MODTXT=MODTXT_$S(MODTXT="":"",1:";")_X ; .. so is easier to spot in displayed column
|
|---|
| 144 | . I 'LRFLAG S:T LRFLAG=T
|
|---|
| 145 | . E I T S:(LRFLAG'=T) LRFLAG=3 ; L&R or Bilat--ignore result
|
|---|
| 146 | S LRFLAG=$S(LRFLAG=1:"L",LRFLAG=2:"R",1:"") ; Left/Right indicator
|
|---|
| 147 | S RADIV=$P(^RADPT(RADFN,"DT",RADTI,0),U,3)
|
|---|
| 148 | K DIC,DR,DA,DIQ
|
|---|
| 149 | I 'REQLOC S (REQLOCN,REQLOCT,REQLOCA)=""
|
|---|
| 150 | E D
|
|---|
| 151 | . S X=$G(^SC(REQLOC,0)),REQLOCN=$P(X,U),REQLOCA=$P(X,U,2)
|
|---|
| 152 | . S:REQLOCA="" REQLOCA=REQLOCN
|
|---|
| 153 | . S DIC="44",DR="2",DA=REQLOC,DIQ="REQLOCT" D EN^DIQ1 K DIC,DR,DA,DIQ
|
|---|
| 154 | . S REQLOCT=REQLOCT(44,REQLOC,2)
|
|---|
| 155 | I REQWARD]"" S DIC="42",DR=".01",DA=REQWARD,DIQ="REQWARD" D EN^DIQ1 K DIC,DR,DA,DIQ S REQWARD=REQWARD(42,REQWARD,.01)
|
|---|
| 156 | S X=$$RIST(RIST1,RIST2),RIST=$P(X,U),RISTISME=$P(X,U,2)
|
|---|
| 157 | S RADTE=9999999.9999-RADTI,(RADTPRT,Y)=RADTE D D^RAUTL S RADATE=Y
|
|---|
| 158 | S RADTPRT=$E(RADTPRT,4,5)_"/"_$E(RADTPRT,6,7)_"/"_$E(RADTPRT,2,3)
|
|---|
| 159 | S RAPRC=$E($P(RADATA,U),1,40),RACN=$P(RADATA,U,2),RAELOC=$P(RADATA,U,7)
|
|---|
| 160 | S IMTYPABB=$P($P(RADATA,U,8),"~"),RACPT=$P(RADATA,U,10)
|
|---|
| 161 | S DAYCASE=$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_RACN
|
|---|
| 162 | S RASTP=RASTNM,RASTCAT=""
|
|---|
| 163 | I RAST S RASTCAT=$P($G(^RA(72,RAST,0)),U,9)
|
|---|
| 164 | S RANME=$P(^DPT(RADFN,0),U)
|
|---|
| 165 | S DFN=RADFN D PID^VADPT6 S RASSN=$S(VAERR:"Unknown",1:VA("PID"))
|
|---|
| 166 | K VA("PID"),VA("BID"),VAERR
|
|---|
| 167 | S MAGRACNT=$G(MAGRACNT)+1
|
|---|
| 168 | I MAGRACNT=1 K ^TMP($J,"MAGRAEX")
|
|---|
| 169 | S ^TMP($J,"MAGRAEX",MAGRACNT,1)=RADFN_U_RADTI_U_RACNI_U_$E(RANME,1,30)_U_RASSN_U_RADATE_U_RADTE_U_RACN_U_$E(RAPRC,1,35)_U_RARPT_U_RAST_U_DAYCASE_U_RAELOC_U_RASTP_U_RASTORD_U_RADTPRT_U_RACPT_U_IMTYPABB
|
|---|
| 170 | S ^TMP($J,"MAGRAEX",MAGRACNT,2)=REQLOCA_U_$E(REQLOCN,1,25)_U_RIST_U_COMPLIC_U_RADIV_U_$P($$IMGSIT(RADIV),U,2)_U_RISTISME_U_MODTXT_U_REQLOCT_U_REQWARD_U_RASTCAT_U_LRFLAG
|
|---|
| 171 | S MAGRET=1
|
|---|
| 172 | Q
|
|---|
| 173 | ;
|
|---|
| 174 | RIST(RIST1,RIST2) ; return Interp Radiologist info
|
|---|
| 175 | S RIST1=$G(RIST1),RIST2=$G(RIST2)
|
|---|
| 176 | N RIST,RISTISME
|
|---|
| 177 | S (RIST,RISTISME)=""
|
|---|
| 178 | I RIST1!RIST2 D
|
|---|
| 179 | . I RIST1 S RISTISME=RIST1=DUZ S RIST=$$USERINF^MAGJUTL3(RIST1,1)
|
|---|
| 180 | . I RIST2 S:'RISTISME RISTISME=RIST2=DUZ S RIST2=$$USERINF^MAGJUTL3(RIST2,1)
|
|---|
| 181 | . I RIST]"" S RIST=RIST_$S(RIST2]"":"/"_RIST2,1:"")
|
|---|
| 182 | . E S RIST=RIST2
|
|---|
| 183 | Q RIST_U_RISTISME
|
|---|
| 184 | ;
|
|---|
| 185 | IMGSIT(DIV,DFLT) ; Return Imaging Site code for input Division
|
|---|
| 186 | ; From 2006.1: IEN ^ Site Code ^ Parent_DIV
|
|---|
| 187 | I DIV]"" D
|
|---|
| 188 | . N IEN I $D(^MAG(2006.1,"B",DIV)) S IEN=$O(^(DIV,"")) I IEN
|
|---|
| 189 | . E I $G(DFLT) S IEN=$O(^MAG(2006.1,0)) ; Dflt to 1st if requested
|
|---|
| 190 | . E S X="" Q
|
|---|
| 191 | . S X=^MAG(2006.1,IEN,0),X=IEN_U_$P(X,U,9)_U_$P(X,U)
|
|---|
| 192 | Q X
|
|---|
| 193 | ;
|
|---|
| 194 | TRIM(X) ; Trim trailing spaces from X
|
|---|
| 195 | I $G(X)]"" D
|
|---|
| 196 | . F I=$L(X):-1:0 I $E(X,I)'=" " Q
|
|---|
| 197 | . I I S X=$E(X,1,I)
|
|---|
| 198 | . E S X=""
|
|---|
| 199 | Q:$Q X Q
|
|---|
| 200 | ;
|
|---|
| 201 | END Q ;
|
|---|
