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