- MAGJUTL1 ;WIRMFO/JHC - VistARad subroutines for RPC calls ; 10/17/2022
- ;;3.0;IMAGING;**22,18,65,76,101,133,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. |
- ;; +---------------------------------------------------------------+
- ;;
- ; Reference to EN1^RAO7PC1 in ICR #2268
- ; Reference to SETDATA^RAO7PC1A in ICR #3509
- ; Reference to D^RAUTL in ICR #3507
- ;; ISI IMAGING;**99,102**
- Q
- ;<*>Notes on possible changes to ^RAO7PC1/1A for fetching rad pkg data:
- ; 1) Return also: Exam Status IEN, Order Request Urgency, & Pre-Op Date
- ; 2) Allow to retrieve one specific exam; e.g. modify SETDATA^RAO7PC1A
- ; to act as a true subrtn, W/ params for RADFN, RADTI, & RACNI--if
- ; passed, then only the one exam would be returned
- ;
- GETEXAM3(DFN,BEGDT,ENDT,MAGRACNT,MAGRET,MORE,LIMEXAMS) ; Get data for all exams for a
- ; pt within a date range
- ; limit to LIMEXAMS entries--note, only PREFETCH & Auto-route Priors use this
- ; Input:
- ; DFN -- Patient DFN
- ; BEGDT -- Opt, earliest date desired
- ; ENDT -- Opt, latest date desired
- ; MAGRACNT -- Opt, pass by ref to init counter to ref return data in ^TMP (see GETEXSET)
- ; MORE -- Opt, If True, check for additional exams for pt
- ; LIMEXAMS -- Opt, limit # exams to return
- ; Return:
- ; MAGRACNT -- highest counter for return data
- ; MAGRET -- 1/0: exam was/not found
- ; MORE -- more exams exist for pt on & B4 this date
- ; ^TMP -- data returned (see GETEXSET)
- ;
- I '$D(DT) N DIQUIET S DIQUIET=1 D DT^DICRW
- S LIMEXAMS=+$G(LIMEXAMS)
- S:$G(BEGDT)="" BEGDT=2010101 S:$G(ENDT)="" ENDT=DT ; default all dates
- N MORECHK S MORECHK=+$G(MORE)
- S MAGRACNT=+$G(MAGRACNT),MAGRET=0,MORE=0 ; Init return data
- I BEGDT>ENDT S X=ENDT,ENDT=BEGDT,BEGDT=X
- I '(DFN&BEGDT&ENDT) Q
- K ^TMP($J,"RAE1") D EN1^RAO7PC1(DFN,BEGDT,ENDT,LIMEXAMS)
- N EXID,TMP,EX1,EX2 S EXID=0
- F MAGRET=0:1 S EXID=$O(^TMP($J,"RAE1",DFN,EXID)) Q:'EXID S TMP($P(EXID,"-"),$P(EXID,"-",2))=EXID
- S (EX1,EX2)=""
- F S EX1=$O(TMP(EX1)) Q:'EX1 F S EX2=$O(TMP(EX1,EX2)) Q:'EX2 D GETEXSET(DFN,TMP(EX1,EX2),"")
- K ^TMP($J,"RAE1")
- I 'MORECHK Q ; all done; else indicate if pt has more exams
- N DTI,CNI,STS,DTCHK
- I 'MAGRET S DTI=9999999.9999-BEGDT,CNI=0 ; no exam found in orig dt range
- E S X=^TMP($J,"MAGRAEX",MAGRACNT,1),DTI=$P(X,U,2),CNI=$P(X,U,3) ; last exam processed
- ; loop thru addl exams til find one that is NOT Cancelled
- 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
- . Q:($P($G(^RA(72,STS,0)),U,3)=0) ; Canceled--keep looking
- . 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)
- . I +$O(^TMP($J,"RAE1",DFN,0)) S MORE=1
- . K ^TMP($J,"RAE1")
- I 'MORE S DTI=$O(^RADPT(DFN,"DT",DTI)),CNI=0 G MORE1:DTI
- I MORE S MORE=9999999.9999-DTI\1
- Q
- ;
- GETEXAM2(DFN,DTI,CNI,MAGRACNT,MAGRET) ; Fetch data for one exam
- ;Input:
- ; DFN -- Pt DFN
- ; DTI -- Internal Date pointer to Rad exam
- ; CNI -- Case pointer to Rad exam
- ; MAGRACNT -- Opt, pass by ref to init counter for return data in ^TMP (see GETEXSET)
- ; Return:
- ; MAGRACNT -- highest counter for return data
- ; MAGRET -- 1/0: exam was/not found
- ; ^TMP -- data returned (see GETEXSET)
- ;
- ; This subroutine calls RAO7PC1A directly to fetch exam data
- ; which is returned in ^TMP($J,"RAE1",DFN,DTI_"-"_CNI).
- ; RAO7PC1A currently returns ALL exams filed under one DTI,
- ; but this subroutine returns the single exam for the input DTI, CNI
- ;
- N RADFN,RACNT,RAIBDT,RAEXN,RAXIT ; Vars input to RAO7PC1A
- S RADFN=DFN,RACNT=0,RAIBDT=DTI,RAEXN=0,RAXIT=0
- ; other Vars set by RAO7PC1A:
- N RABNOR,RACSE,RADIAG,RANO,RAPRC,RAREX,RARPT,RARPTST,RASTNM,RAXAM,RAXID
- N RABNORMR,RACPT
- S MAGRACNT=+$G(MAGRACNT)
- K ^TMP($J,"RAE1") D SETDATA^RAO7PC1A
- S MAGRET=RACNT Q:'RACNT ; no exams found
- D GETEXSET(DFN,DTI_"-"_CNI,.X)
- I 'X S MAGRET=0 ; no exam for this CNI
- K ^TMP($J,"RAE1")
- Q
- ;
- GETEXSET(RADFN,EXID,MAGRET) ;
- ; Used by GETEXAM* subroutines above to set up rad data for vrad
- ; Input:
- ; RADFN -- Pt DFN
- ; EXID --- RADTI_"-"_RACNI, pointers to Rad exam
- ; Output:
- ; MAGRET- 1/0: an exam was/was not filed
- ; ^TMP($J,"MAGRAEX",MAGRACNT)=Data String (see code at end)
- ; MAGRACNT described in above subroutines
- ;
- N RACN,RACNI,RADATA,RADATE,RADTE,RADTI,RADTPRT,RAELOC,RANME
- N RAPRC,RARPT,RASSN,RAST,RASTORD,RASTP,RASTNM,RACPT,IMTYPABB,PROCMOD
- N DAYCASE,REQLOC,REQLOCN,REQLOCA,REQLOCT,RIST,RIST1,RIST2,COMPLIC
- N RADIV,RISTISME,REQWARD,RASTCAT,CPTMOD,LRFLAG,MODTXT,LONGACN,TECH
- N MEDS,RDIOPHARM
- N ASIGINI,ASIGNOTE,ASIGDUZ,FAVKWD1,FAVKWD2,FAVNOTE,PTAGE,PTDOB,PTSEX ; ISI
- N RPTSTS ; ISI
- S MAGRET=0,RADTI=$P(EXID,"-"),RACNI=$P(EXID,"-",2)
- Q:'(RADTI&RACNI)
- S RADIV=""
- S RADATA=$G(^TMP($J,"RAE1",RADFN,EXID))
- Q:RADATA="" ; no exam for this EXID
- S RARPT=$P(RADATA,U,5)
- S X=$P(RADATA,U,6),RASTORD=$P(X,"~"),RASTNM=$P(X,"~",2)
- S X=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),COMPLIC=$D(^("COMP")),PROCMOD=$D(^("M")),CPTMOD=$D(^("CMOD")),TECH=$D(^("TC")),MEDS=$D(^("RX")) ; ICR #1172 (Private)
- 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
- S REQWARD=$P(X,U,6),LONGACN=$P(X,U,31),RDIOPHARM=$P(X,U,28) ; ICR #1172 (Private)
- ; ISI begin ...
- S (FAVKWD1,FAVKWD2,FAVNOTE)="" ; values are placeholders only inside this program
- S (ASIGINI,ASIGNOTE,ASIGDUZ)=""
- I $$UJOCHECK^ISIJUTL9() D ; not implemented in VA--future mod required to store in ISI file (tbd)
- . S X=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"ISI")) I +X D
- . . S ASIGDUZ=+X,ASIGNOTE=$P(X,U,2)
- . . S ASIGINI=$$USERINF^MAGJUTL3(ASIGDUZ,1) ; assignee initials
- S RPTSTS="No Report" I +RARPT D
- . S X=$P($G(^RARPT(RARPT,0)),U,5)
- . I X]"" S RPTSTS=$S(X="V":"VERIFIED",X="D":"DRAFT",X="R":"REL./NOT VERIF.",X="PD":"PROBLEM DRAFT",X="EF":"ELECTRONICALLY FILED",X="X":"DELETED")
- ; ISI ... end
- N CT,MODS,IEN,TT ; Process Proc/CPT Modifier info
- S CT=0
- I PROCMOD D
- . S IEN=0
- . F S IEN=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",IEN)) Q:'IEN S X=$P($G(^(IEN,0)),U) I X D
- . . S X=$P($G(^RAMIS(71.2,X,0)),U) Q:X="" S X=$$TRIM(X)
- . . S X=$S(X="BILATERAL EXAM":"BILAT",1:X)
- . . S CT=CT+1,MODS(CT)=X
- I CPTMOD D
- . S IEN=0
- . F S IEN=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",IEN)) Q:'IEN S X=$P($G(^(IEN,0)),U) I X D
- . . S X=$P($$MOD^ICPTMOD(X,"I"),U,3) Q:X="" S X=$$TRIM(X)
- . . S X=$S(X="LEFT SIDE":"LEFT",X="RIGHT SIDE":"RIGHT",X="BILATERAL PROCEDURE":"BILAT",1:X)
- . . S CT=CT+1,MODS(CT)=X
- S MODTXT="",LRFLAG=0 K TT
- I CT F I=1:1:CT S X=MODS(I) D
- . ; eliminate redundant values for L/R/Bilat (TT), & track L/R for prior matching (LRFLAG)
- . S T=(X="LEFT") I T,$D(TT(1)) Q ; already got it
- . I 'T S T=(X="RIGHT") I T S T=2 I T,$D(TT(2)) Q ; ditto
- . I 'T S T=(X="BILAT") I T S T=3 I T,$D(TT(3)) Q ; ditto
- . I T S TT(T)="",MODTXT=X_$S(MODTXT="":"",1:";")_MODTXT ; force L/R/Bilat to left end of string ..
- . E S MODTXT=MODTXT_$S(MODTXT="":"",1:";")_X ; .. so is easier to spot in displayed column
- . I 'LRFLAG S:T LRFLAG=T
- . E I T S:(LRFLAG'=T) LRFLAG=3 ; L&R or Bilat--ignore result
- S LRFLAG=$S(LRFLAG=1:"L",LRFLAG=2:"R",1:"") ; Left/Right indicator
- I 'TECH S TECH=""
- E D
- . S IEN=0,TECH="" N T
- . F S IEN=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",IEN)) Q:'IEN S X=$P($G(^(IEN,0)),U) I X S T(X)=""
- . I $D(T) S T="" F S T=$O(T(T)) Q:T="" S X=$P($G(^VA(200,T,0)),U,2) I X]"" S TECH=TECH_$S(TECH="":"",1:"~")_X
- S RADIV=$P(^RADPT(RADFN,"DT",RADTI,0),U,3)
- K DIC,DR,DA,DIQ
- I 'REQLOC S (REQLOCN,REQLOCT,REQLOCA)=""
- E D
- . S X=$G(^SC(REQLOC,0)),REQLOCN=$P(X,U),REQLOCA=$P(X,U,2)
- . S:REQLOCA="" REQLOCA=REQLOCN
- . S DIC="44",DR="2",DA=REQLOC,DIQ="REQLOCT" D EN^DIQ1 K DIC,DR,DA,DIQ
- . S REQLOCT=REQLOCT(44,REQLOC,2)
- 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)
- S X=$$RIST(RIST1,RIST2),RIST=$P(X,U),RISTISME=$P(X,U,2)
- S RADTE=9999999.9999-RADTI,(RADTPRT,Y)=RADTE D D^RAUTL S RADATE=Y
- S RADTPRT=$E(RADTPRT,4,5)_"/"_$E(RADTPRT,6,7)_"/"_$E(RADTPRT,2,3)
- S RAPRC=$E($P(RADATA,U),1,40),RACN=$P(RADATA,U,2),RAELOC=$P(RADATA,U,7)
- S IMTYPABB=$P($P(RADATA,U,8),"~"),RACPT=$P(RADATA,U,10)
- S DAYCASE=$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_RACN
- I LONGACN]"" S DAYCASE=LONGACN
- S RASTP=RASTNM,RASTCAT=""
- I RAST S RASTCAT=$P($G(^RA(72,RAST,0)),U,9)
- S RANME=$P(^DPT(RADFN,0),U),PTSEX=$P(^(0),U,2),PTDOB=$P(^(0),U,3),PTAGE="" ; ISI
- S DFN=RADFN D PID^VADPT6 S RASSN=$S(VAERR:"Unknown",1:VA("PID"))
- K VA("PID"),VA("BID"),VAERR
- S MAGRACNT=$G(MAGRACNT)+1
- I MAGRACNT=1 K ^TMP($J,"MAGRAEX")
- 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
- 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_U_TECH_U_MEDS_U_RDIOPHARM
- S ^TMP($J,"MAGRAEX",MAGRACNT,"ISI")=ASIGINI_U_ASIGNOTE_U_ASIGDUZ_U_FAVKWD1_U_FAVKWD2_U_FAVNOTE_U_PTAGE_U_PTSEX_U_PTDOB_U_RPTSTS ; ISI
- S MAGRET=1
- Q
- ;
- RIST(RIST1,RIST2) ; return Interp Radiologist info
- S RIST1=$G(RIST1),RIST2=$G(RIST2)
- N RIST,RISTISME
- S (RIST,RISTISME)=""
- I RIST1!RIST2 D
- . I RIST1 S RISTISME=RIST1 S RIST=$$USERINF^MAGJUTL3(RIST1,1)
- . I RIST2 S RISTISME=$S('RISTISME:RIST2,1:RISTISME_"~"_RIST2) S RIST2=$$USERINF^MAGJUTL3(RIST2,1)
- . I RIST]"" S RIST=RIST_$S(RIST2]"":"/"_RIST2,1:"")
- . E S RIST=RIST2
- Q RIST_U_RISTISME
- ;
- IMGSIT(DIV,DFLT) ; Return Imaging Site code for input Division
- ; From 2006.1: IEN ^ Site Code ^ Parent_DIV
- I DIV]"" D
- . N IEN I $D(^MAG(2006.1,"B",DIV)) S IEN=$O(^(DIV,"")) I IEN
- . E I $G(DFLT) S IEN=$O(^MAG(2006.1,0)) ; Dflt to 1st if requested
- . E S X="" Q
- . S X=^MAG(2006.1,IEN,0),X=IEN_U_$P(X,U,9)_U_$P(X,U)
- Q X
- ;
- TRIM(X) ; Trim trailing spaces from X
- I $G(X)]"" D
- . F I=$L(X):-1:0 I $E(X,I)'=" " Q
- . I I S X=$E(X,1,I)
- . E S X=""
- Q:$Q X Q
- ;
- END Q ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGJUTL1 11145 printed Jan 18, 2025@03:08:11 Page 2
- MAGJUTL1 ;WIRMFO/JHC - VistARad subroutines for RPC calls ; 10/17/2022
- +1 ;;3.0;IMAGING;**22,18,65,76,101,133,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 ;; | |
- +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 ; Reference to EN1^RAO7PC1 in ICR #2268
- +19 ; Reference to SETDATA^RAO7PC1A in ICR #3509
- +20 ; Reference to D^RAUTL in ICR #3507
- +21 ;; ISI IMAGING;**99,102**
- +22 QUIT
- +23 ;<*>Notes on possible changes to ^RAO7PC1/1A for fetching rad pkg data:
- +24 ; 1) Return also: Exam Status IEN, Order Request Urgency, & Pre-Op Date
- +25 ; 2) Allow to retrieve one specific exam; e.g. modify SETDATA^RAO7PC1A
- +26 ; to act as a true subrtn, W/ params for RADFN, RADTI, & RACNI--if
- +27 ; passed, then only the one exam would be returned
- +28 ;
- GETEXAM3(DFN,BEGDT,ENDT,MAGRACNT,MAGRET,MORE,LIMEXAMS) ; Get data for all exams for a
- +1 ; pt within a date range
- +2 ; limit to LIMEXAMS entries--note, only PREFETCH & Auto-route Priors use this
- +3 ; Input:
- +4 ; DFN -- Patient DFN
- +5 ; BEGDT -- Opt, earliest date desired
- +6 ; ENDT -- Opt, latest date desired
- +7 ; MAGRACNT -- Opt, pass by ref to init counter to ref return data in ^TMP (see GETEXSET)
- +8 ; MORE -- Opt, If True, check for additional exams for pt
- +9 ; LIMEXAMS -- Opt, limit # exams to return
- +10 ; Return:
- +11 ; MAGRACNT -- highest counter for return data
- +12 ; MAGRET -- 1/0: exam was/not found
- +13 ; MORE -- more exams exist for pt on & B4 this date
- +14 ; ^TMP -- data returned (see GETEXSET)
- +15 ;
- +16 IF '$DATA(DT)
- NEW DIQUIET
- SET DIQUIET=1
- DO DT^DICRW
- +17 SET LIMEXAMS=+$GET(LIMEXAMS)
- +18 ; default all dates
- if $GET(BEGDT)=""
- SET BEGDT=2010101
- if $GET(ENDT)=""
- SET ENDT=DT
- +19 NEW MORECHK
- SET MORECHK=+$GET(MORE)
- +20 ; Init return data
- SET MAGRACNT=+$GET(MAGRACNT)
- SET MAGRET=0
- SET MORE=0
- +21 IF BEGDT>ENDT
- SET X=ENDT
- SET ENDT=BEGDT
- SET BEGDT=X
- +22 IF '(DFN&BEGDT&ENDT)
- QUIT
- +23 KILL ^TMP($JOB,"RAE1")
- DO EN1^RAO7PC1(DFN,BEGDT,ENDT,LIMEXAMS)
- +24 NEW EXID,TMP,EX1,EX2
- SET EXID=0
- +25 FOR MAGRET=0:1
- SET EXID=$ORDER(^TMP($JOB,"RAE1",DFN,EXID))
- if 'EXID
- QUIT
- SET TMP($PIECE(EXID,"-"),$PIECE(EXID,"-",2))=EXID
- +26 SET (EX1,EX2)=""
- +27 FOR
- SET EX1=$ORDER(TMP(EX1))
- if 'EX1
- QUIT
- FOR
- SET EX2=$ORDER(TMP(EX1,EX2))
- if 'EX2
- QUIT
- DO GETEXSET(DFN,TMP(EX1,EX2),"")
- +28 KILL ^TMP($JOB,"RAE1")
- +29 ; all done; else indicate if pt has more exams
- IF 'MORECHK
- QUIT
- +30 NEW DTI,CNI,STS,DTCHK
- +31 ; no exam found in orig dt range
- IF 'MAGRET
- SET DTI=9999999.9999-BEGDT
- SET CNI=0
- +32 ; last exam processed
- IF '$TEST
- SET X=^TMP($JOB,"MAGRAEX",MAGRACNT,1)
- SET DTI=$PIECE(X,U,2)
- SET CNI=$PIECE(X,U,3)
- +33 ; loop thru addl exams til find one that is NOT Cancelled
- MORE1 FOR
- SET CNI=$ORDER(^RADPT(DFN,"DT",DTI,"P",CNI))
- if 'CNI
- QUIT
- SET STS=$PIECE($GET(^(CNI,0)),U,3)
- IF STS]""
- Begin DoDot:1
- +1 ; Canceled--keep looking
- if ($PIECE($GET(^RA(72,STS,0)),U,3)=0)
- QUIT
- +2 ; verify there is at least one "good" exam for this date (Remedy #200480)
- SET DTCHK=9999999.9999-DTI
- DO EN1^RAO7PC1(DFN,DTCHK,DTCHK,1)
- +3 IF +$ORDER(^TMP($JOB,"RAE1",DFN,0))
- SET MORE=1
- +4 KILL ^TMP($JOB,"RAE1")
- End DoDot:1
- if MORE
- QUIT
- +5 IF 'MORE
- SET DTI=$ORDER(^RADPT(DFN,"DT",DTI))
- SET CNI=0
- if DTI
- GOTO MORE1
- +6 IF MORE
- SET MORE=9999999.9999-DTI\1
- +7 QUIT
- +8 ;
- GETEXAM2(DFN,DTI,CNI,MAGRACNT,MAGRET) ; Fetch data for one exam
- +1 ;Input:
- +2 ; DFN -- Pt DFN
- +3 ; DTI -- Internal Date pointer to Rad exam
- +4 ; CNI -- Case pointer to Rad exam
- +5 ; MAGRACNT -- Opt, pass by ref to init counter for return data in ^TMP (see GETEXSET)
- +6 ; Return:
- +7 ; MAGRACNT -- highest counter for return data
- +8 ; MAGRET -- 1/0: exam was/not found
- +9 ; ^TMP -- data returned (see GETEXSET)
- +10 ;
- +11 ; This subroutine calls RAO7PC1A directly to fetch exam data
- +12 ; which is returned in ^TMP($J,"RAE1",DFN,DTI_"-"_CNI).
- +13 ; RAO7PC1A currently returns ALL exams filed under one DTI,
- +14 ; but this subroutine returns the single exam for the input DTI, CNI
- +15 ;
- +16 ; Vars input to RAO7PC1A
- NEW RADFN,RACNT,RAIBDT,RAEXN,RAXIT
- +17 SET RADFN=DFN
- SET RACNT=0
- SET RAIBDT=DTI
- SET RAEXN=0
- SET RAXIT=0
- +18 ; other Vars set by RAO7PC1A:
- +19 NEW RABNOR,RACSE,RADIAG,RANO,RAPRC,RAREX,RARPT,RARPTST,RASTNM,RAXAM,RAXID
- +20 NEW RABNORMR,RACPT
- +21 SET MAGRACNT=+$GET(MAGRACNT)
- +22 KILL ^TMP($JOB,"RAE1")
- DO SETDATA^RAO7PC1A
- +23 ; no exams found
- SET MAGRET=RACNT
- if 'RACNT
- QUIT
- +24 DO GETEXSET(DFN,DTI_"-"_CNI,.X)
- +25 ; no exam for this CNI
- IF 'X
- SET MAGRET=0
- +26 KILL ^TMP($JOB,"RAE1")
- +27 QUIT
- +28 ;
- GETEXSET(RADFN,EXID,MAGRET) ;
- +1 ; Used by GETEXAM* subroutines above to set up rad data for vrad
- +2 ; Input:
- +3 ; RADFN -- Pt DFN
- +4 ; EXID --- RADTI_"-"_RACNI, pointers to Rad exam
- +5 ; Output:
- +6 ; MAGRET- 1/0: an exam was/was not filed
- +7 ; ^TMP($J,"MAGRAEX",MAGRACNT)=Data String (see code at end)
- +8 ; MAGRACNT described in above subroutines
- +9 ;
- +10 NEW RACN,RACNI,RADATA,RADATE,RADTE,RADTI,RADTPRT,RAELOC,RANME
- +11 NEW RAPRC,RARPT,RASSN,RAST,RASTORD,RASTP,RASTNM,RACPT,IMTYPABB,PROCMOD
- +12 NEW DAYCASE,REQLOC,REQLOCN,REQLOCA,REQLOCT,RIST,RIST1,RIST2,COMPLIC
- +13 NEW RADIV,RISTISME,REQWARD,RASTCAT,CPTMOD,LRFLAG,MODTXT,LONGACN,TECH
- +14 NEW MEDS,RDIOPHARM
- +15 ; ISI
- NEW ASIGINI,ASIGNOTE,ASIGDUZ,FAVKWD1,FAVKWD2,FAVNOTE,PTAGE,PTDOB,PTSEX
- +16 ; ISI
- NEW RPTSTS
- +17 SET MAGRET=0
- SET RADTI=$PIECE(EXID,"-")
- SET RACNI=$PIECE(EXID,"-",2)
- +18 if '(RADTI&RACNI)
- QUIT
- +19 SET RADIV=""
- +20 SET RADATA=$GET(^TMP($JOB,"RAE1",RADFN,EXID))
- +21 ; no exam for this EXID
- if RADATA=""
- QUIT
- +22 SET RARPT=$PIECE(RADATA,U,5)
- +23 SET X=$PIECE(RADATA,U,6)
- SET RASTORD=$PIECE(X,"~")
- SET RASTNM=$PIECE(X,"~",2)
- +24 ; ICR #1172 (Private)
- SET X=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
- SET COMPLIC=$DATA(^("COMP"))
- SET PROCMOD=$DATA(^("M"))
- SET CPTMOD=$DATA(^("CMOD"))
- SET TECH=$DATA(^("TC"))
- SET MEDS=$DATA(^("RX"))
- +25 SET RAST=$PIECE(X,U,3)
- SET REQLOC=$PIECE(X,U,22)
- SET RIST1=$PIECE(X,U,12)
- SET RIST2=$PIECE(X,U,15)
- SET COMPLIC=$PIECE(X,U,16)_"~"_COMPLIC
- +26 ; ICR #1172 (Private)
- SET REQWARD=$PIECE(X,U,6)
- SET LONGACN=$PIECE(X,U,31)
- SET RDIOPHARM=$PIECE(X,U,28)
- +27 ; ISI begin ...
- +28 ; values are placeholders only inside this program
- SET (FAVKWD1,FAVKWD2,FAVNOTE)=""
- +29 SET (ASIGINI,ASIGNOTE,ASIGDUZ)=""
- +30 ; not implemented in VA--future mod required to store in ISI file (tbd)
- IF $$UJOCHECK^ISIJUTL9()
- Begin DoDot:1
- +31 SET X=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"ISI"))
- IF +X
- Begin DoDot:2
- +32 SET ASIGDUZ=+X
- SET ASIGNOTE=$PIECE(X,U,2)
- +33 ; assignee initials
- SET ASIGINI=$$USERINF^MAGJUTL3(ASIGDUZ,1)
- End DoDot:2
- End DoDot:1
- +34 SET RPTSTS="No Report"
- IF +RARPT
- Begin DoDot:1
- +35 SET X=$PIECE($GET(^RARPT(RARPT,0)),U,5)
- +36 IF X]""
- SET RPTSTS=$SELECT(X="V":"VERIFIED",X="D":"DRAFT",X="R":"REL./NOT VERIF.",X="PD":"PROBLEM DRAFT",X="EF":"ELECTRONICALLY FILED",X="X":"DELETED")
- End DoDot:1
- +37 ; ISI ... end
- +38 ; Process Proc/CPT Modifier info
- NEW CT,MODS,IEN,TT
- +39 SET CT=0
- +40 IF PROCMOD
- Begin DoDot:1
- +41 SET IEN=0
- +42 FOR
- SET IEN=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",IEN))
- if 'IEN
- QUIT
- SET X=$PIECE($GET(^(IEN,0)),U)
- IF X
- Begin DoDot:2
- +43 SET X=$PIECE($GET(^RAMIS(71.2,X,0)),U)
- if X=""
- QUIT
- SET X=$$TRIM(X)
- +44 SET X=$SELECT(X="BILATERAL EXAM":"BILAT",1:X)
- +45 SET CT=CT+1
- SET MODS(CT)=X
- End DoDot:2
- End DoDot:1
- +46 IF CPTMOD
- Begin DoDot:1
- +47 SET IEN=0
- +48 FOR
- SET IEN=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",IEN))
- if 'IEN
- QUIT
- SET X=$PIECE($GET(^(IEN,0)),U)
- IF X
- Begin DoDot:2
- +49 SET X=$PIECE($$MOD^ICPTMOD(X,"I"),U,3)
- if X=""
- QUIT
- SET X=$$TRIM(X)
- +50 SET X=$SELECT(X="LEFT SIDE":"LEFT",X="RIGHT SIDE":"RIGHT",X="BILATERAL PROCEDURE":"BILAT",1:X)
- +51 SET CT=CT+1
- SET MODS(CT)=X
- End DoDot:2
- End DoDot:1
- +52 SET MODTXT=""
- SET LRFLAG=0
- KILL TT
- +53 IF CT
- FOR I=1:1:CT
- SET X=MODS(I)
- Begin DoDot:1
- +54 ; eliminate redundant values for L/R/Bilat (TT), & track L/R for prior matching (LRFLAG)
- +55 ; already got it
- SET T=(X="LEFT")
- IF T
- IF $DATA(TT(1))
- QUIT
- +56 ; ditto
- IF 'T
- SET T=(X="RIGHT")
- IF T
- SET T=2
- IF T
- IF $DATA(TT(2))
- QUIT
- +57 ; ditto
- IF 'T
- SET T=(X="BILAT")
- IF T
- SET T=3
- IF T
- IF $DATA(TT(3))
- QUIT
- +58 ; force L/R/Bilat to left end of string ..
- IF T
- SET TT(T)=""
- SET MODTXT=X_$SELECT(MODTXT="":"",1:";")_MODTXT
- +59 ; .. so is easier to spot in displayed column
- IF '$TEST
- SET MODTXT=MODTXT_$SELECT(MODTXT="":"",1:";")_X
- +60 IF 'LRFLAG
- if T
- SET LRFLAG=T
- +61 ; L&R or Bilat--ignore result
- IF '$TEST
- IF T
- if (LRFLAG'=T)
- SET LRFLAG=3
- End DoDot:1
- +62 ; Left/Right indicator
- SET LRFLAG=$SELECT(LRFLAG=1:"L",LRFLAG=2:"R",1:"")
- +63 IF 'TECH
- SET TECH=""
- +64 IF '$TEST
- Begin DoDot:1
- +65 SET IEN=0
- SET TECH=""
- NEW T
- +66 FOR
- SET IEN=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",IEN))
- if 'IEN
- QUIT
- SET X=$PIECE($GET(^(IEN,0)),U)
- IF X
- SET T(X)=""
- +67 IF $DATA(T)
- SET T=""
- FOR
- SET T=$ORDER(T(T))
- if T=""
- QUIT
- SET X=$PIECE($GET(^VA(200,T,0)),U,2)
- IF X]""
- SET TECH=TECH_$SELECT(TECH="":"",1:"~")_X
- End DoDot:1
- +68 SET RADIV=$PIECE(^RADPT(RADFN,"DT",RADTI,0),U,3)
- +69 KILL DIC,DR,DA,DIQ
- +70 IF 'REQLOC
- SET (REQLOCN,REQLOCT,REQLOCA)=""
- +71 IF '$TEST
- Begin DoDot:1
- +72 SET X=$GET(^SC(REQLOC,0))
- SET REQLOCN=$PIECE(X,U)
- SET REQLOCA=$PIECE(X,U,2)
- +73 if REQLOCA=""
- SET REQLOCA=REQLOCN
- +74 SET DIC="44"
- SET DR="2"
- SET DA=REQLOC
- SET DIQ="REQLOCT"
- DO EN^DIQ1
- KILL DIC,DR,DA,DIQ
- +75 SET REQLOCT=REQLOCT(44,REQLOC,2)
- End DoDot:1
- +76 IF REQWARD]""
- SET DIC="42"
- SET DR=".01"
- SET DA=REQWARD
- SET DIQ="REQWARD"
- DO EN^DIQ1
- KILL DIC,DR,DA,DIQ
- SET REQWARD=REQWARD(42,REQWARD,.01)
- +77 SET X=$$RIST(RIST1,RIST2)
- SET RIST=$PIECE(X,U)
- SET RISTISME=$PIECE(X,U,2)
- +78 SET RADTE=9999999.9999-RADTI
- SET (RADTPRT,Y)=RADTE
- DO D^RAUTL
- SET RADATE=Y
- +79 SET RADTPRT=$EXTRACT(RADTPRT,4,5)_"/"_$EXTRACT(RADTPRT,6,7)_"/"_$EXTRACT(RADTPRT,2,3)
- +80 SET RAPRC=$EXTRACT($PIECE(RADATA,U),1,40)
- SET RACN=$PIECE(RADATA,U,2)
- SET RAELOC=$PIECE(RADATA,U,7)
- +81 SET IMTYPABB=$PIECE($PIECE(RADATA,U,8),"~")
- SET RACPT=$PIECE(RADATA,U,10)
- +82 SET DAYCASE=$EXTRACT(RADTE,4,7)_$EXTRACT(RADTE,2,3)_"-"_RACN
- +83 IF LONGACN]""
- SET DAYCASE=LONGACN
- +84 SET RASTP=RASTNM
- SET RASTCAT=""
- +85 IF RAST
- SET RASTCAT=$PIECE($GET(^RA(72,RAST,0)),U,9)
- +86 ; ISI
- SET RANME=$PIECE(^DPT(RADFN,0),U)
- SET PTSEX=$PIECE(^(0),U,2)
- SET PTDOB=$PIECE(^(0),U,3)
- SET PTAGE=""
- +87 SET DFN=RADFN
- DO PID^VADPT6
- SET RASSN=$SELECT(VAERR:"Unknown",1:VA("PID"))
- +88 KILL VA("PID"),VA("BID"),VAERR
- +89 SET MAGRACNT=$GET(MAGRACNT)+1
- +90 IF MAGRACNT=1
- KILL ^TMP($JOB,"MAGRAEX")
- +91 SET ^TMP($JOB,"MAGRAEX",MAGRACNT,1)=RADFN_U_RADTI_U_RACNI_U_$EXTRACT(RANME,1,30)_U_RASSN_U_RADATE_U_RADTE_U_RACN_U_$EXTRACT(RAPRC,1,35)_U_RARPT_U_RAST_U_DAYCASE_U_RAELOC_U_RASTP_U_RASTORD_U_RADTPRT_U_RACPT_U_IMTYPABB
- +92 SET ^TMP($JOB,"MAGRAEX",MAGRACNT,2)=REQLOCA_U_$EXTRACT(REQLOCN,1,25)_U_RIST_U_COMPLIC_U_RADIV_U_$PIECE($$IMGSIT(RADIV),U,2)_U_RISTISME_U_MODTXT_U_REQLOCT_U_REQWARD_U_RASTCAT_U_LRFLAG_U_TECH_U_MEDS_U_RDIOPHARM
- +93 ; ISI
- SET ^TMP($JOB,"MAGRAEX",MAGRACNT,"ISI")=ASIGINI_U_ASIGNOTE_U_ASIGDUZ_U_FAVKWD1_U_FAVKWD2_U_FAVNOTE_U_PTAGE_U_PTSEX_U_PTDOB_U_RPTSTS
- +94 SET MAGRET=1
- +95 QUIT
- +96 ;
- RIST(RIST1,RIST2) ; return Interp Radiologist info
- +1 SET RIST1=$GET(RIST1)
- SET RIST2=$GET(RIST2)
- +2 NEW RIST,RISTISME
- +3 SET (RIST,RISTISME)=""
- +4 IF RIST1!RIST2
- Begin DoDot:1
- +5 IF RIST1
- SET RISTISME=RIST1
- SET RIST=$$USERINF^MAGJUTL3(RIST1,1)
- +6 IF RIST2
- SET RISTISME=$SELECT('RISTISME:RIST2,1:RISTISME_"~"_RIST2)
- SET RIST2=$$USERINF^MAGJUTL3(RIST2,1)
- +7 IF RIST]""
- SET RIST=RIST_$SELECT(RIST2]"":"/"_RIST2,1:"")
- +8 IF '$TEST
- SET RIST=RIST2
- End DoDot:1
- +9 QUIT RIST_U_RISTISME
- +10 ;
- IMGSIT(DIV,DFLT) ; Return Imaging Site code for input Division
- +1 ; From 2006.1: IEN ^ Site Code ^ Parent_DIV
- +2 IF DIV]""
- Begin DoDot:1
- +3 NEW IEN
- IF $DATA(^MAG(2006.1,"B",DIV))
- SET IEN=$ORDER(^(DIV,""))
- IF IEN
- +4 ; Dflt to 1st if requested
- IF '$TEST
- IF $GET(DFLT)
- SET IEN=$ORDER(^MAG(2006.1,0))
- +5 IF '$TEST
- SET X=""
- QUIT
- +6 SET X=^MAG(2006.1,IEN,0)
- SET X=IEN_U_$PIECE(X,U,9)_U_$PIECE(X,U)
- End DoDot:1
- +7 QUIT X
- +8 ;
- TRIM(X) ; Trim trailing spaces from X
- +1 IF $GET(X)]""
- Begin DoDot:1
- +2 FOR I=$LENGTH(X):-1:0
- IF $EXTRACT(X,I)'=" "
- QUIT
- +3 IF I
- SET X=$EXTRACT(X,1,I)
- +4 IF '$TEST
- SET X=""
- End DoDot:1
- +5 if $QUIT
- QUIT X
- QUIT
- +6 ;
- END ;
- QUIT