- MAGJLS3 ;WIRMFO/JHC - Rad. Workstation RPC calls ; 10/17/2022
- ;;3.0;IMAGING;**16,22,18,101,90,120,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. |
- ;; +---------------------------------------------------------------+
- ;;
- ;; ISI IMAGING;**99,101,106**
- Q
- ; EPs:
- ; BLDACTV
- ;
- BLDACTV(MAGGRY,DATA,MAGLST) ; get subset of Active Exams; called from MAGJLS2
- ;MAGGRY - Indirect Global ref of return array
- ;DATA: Listyp ^ Imaging Types
- ;Listyp = U -- UNREAD Exams (Status Category=E)
- ; = R -- RECENT (Sts Cat's D & T)
- ; = A -- ALL Active (Cat's E, D, & T)
- ; = P -- PENDING (Cat's W & R) ; ISI P106
- ; = N -- Newly Interpreted Exams (No Cat.-Internal use only)
- ; = I -- Indexed Exams (No Cat.-Internal use only), = misc indexed lists (Favorites = 1st example) ; ISI
- ;ImgTypes = List of Imaging Types to process, or "ALL" for all
- ; MAGLST = $NA ref to return global; references to it use subscript indirection
- ; MAGLST optional: input to specify return global to use
- ;
- ;* This subrtn can receive U/R/A/P/N (LSTREQ)-- ^_delim list of ImgTypes (IMTYPS)
- ; Also can receive I; no imaging types in particular ; ISI
- N RADFN,RADTI,RACNI,REMX
- N HDR,HDRLST,MAGIMGTY,MAGRACNT,MAGRET,LSTREQ,LISTYP,LISCAT,IMTYPS
- N REPLY,STAT,TYP,SORTMAG,DIQUIET,STATCHK,LASTDT,IMGSONLY,URGORD,REMONLY
- S DIQUIET=1 D DT^DICRW
- I $G(MAGLST)="" S MAGLST=$NA(^TMP($J,"MAGJACTIVE")) ; default loc'n if not passed in
- K ^TMP($J,"MAGRAEX"),@MAGLST
- S LSTREQ=$P(DATA,U),IMTYPS=$P(DATA,U,2,99)
- I LSTREQ="U"!(LSTREQ="R")!(LSTREQ="A")!(LSTREQ="P")!(LSTREQ="N")!(LSTREQ="H")!(LSTREQ="I") ; ISI
- E S REPLY="0^4~Invalid Request (List Type="_LSTREQ_")" G BLDACTVZ
- S MAGRACNT=0
- S X=$G(^MAG(2006.69,1,0)),IMGSONLY=+$P(X,U,7),REMX=+$P(X,U,10) ; show only exams w/ images?
- S REMONLY=0
- I $G(MAGJOB("REMOTE")) D ; ;show remote cache only?
- . Q:(LSTREQ="H") Q:(LSTREQ="I") S REMONLY=+$G(MAGJOB("REMOTESCREEN")) ; ISI
- S X=$G(^MAG(2006.69,1,1)),URGORD=$P(X,U)
- S:URGORD="" URGORD="S,U,P,R" S URGORD=$TR(URGORD,",") ; "Priority" sort
- S HDR=$S(LSTREQ="U":"UNREAD",LSTREQ="R":"RECENT",LSTREQ="P":"PENDING",LSTREQ="A":"UNREAD and RECENT",LSTREQ="N":"NEWLY INTERP",LSTREQ="H":"HISTORY",LSTREQ="I":"INDEXED",1:"")_" Exams"_" for IMAGING TYPES: " ; ISI
- S LISTYP=$S(LSTREQ="U":"E",LSTREQ="R":"D^T",LSTREQ="A":"E^D^T",LSTREQ="P":"W^R",LSTREQ="N":"",LSTREQ="H":"",LSTREQ="I":"",1:"E") ; ISI P99, P106
- S REPLY="0^4~Compiling list of Radiology Exams (ACTIVE)."
- I $G(BKGPROC),(LSTREQ="R"),'$$MGRREV2^ISIJUTL9 K ^TMP($J,"NEWINT") S ^TMP($J,"NEWINT")=+$G(^XTMP("MAGJ2","RECENT",0)) ; ISI Rev-2?
- I LSTREQ="N" D:'$$MGRREV2^ISIJUTL9 BLDACT2 G BLDACTVZ ; ISI -- call only if Rev-2 not enabled
- I LSTREQ="H" D HISTBLD^MAGJLS3A G BLDACTVZ
- I LSTREQ="I" D INDXBLD^ISIJLS1 G BLDACTVZ ; ISI
- D BLDACT1
- BLDACTVZ ;
- I 'MAGRACNT S:(REPLY["Compiling") REPLY="0^2~No Exams Found"
- E D
- . I IMTYPS="ALL" S HDR=HDR_" ALL"
- . E S Y="" F I=0:1 S Y=$O(HDRLST(Y)) Q:Y="" S HDR=HDR_$S('I:"",1:", ")_Y
- . S REPLY=MAGRACNT_U_"1~"_HDR
- S @MAGLST@(0,1)=REPLY,^(2)=""
- K ^TMP($J,"MAGRAEX"),^("RAE1")
- S MAGGRY=MAGLST
- Q
- BLDACT1 ; Compile exams by Status codes
- D BLDSTAT^MAGJLS3A
- F S LISCAT=$P(LISTYP,U),LISTYP=$P(LISTYP,U,2,9) Q:LISCAT="" D
- . I IMTYPS="ALL" S TYP="" D Q
- . . F S TYP=$O(STAT(LISCAT,TYP)) Q:TYP="" D IMGTYP(LISCAT,TYP)
- . E I +IMTYPS D IMGTYLST(LISCAT,IMTYPS) Q
- . E S REPLY="0^4~Invalid Imaging Type"
- Q
- BLDACT2 ; Add recently interpreted exams to the "Recent" compile data
- ; 1st, compile these into their own list
- N CNT,INDX,RAST,STATCHK,RECLIST,REC,X1,X2,XX9
- S X=$G(^XTMP("MAGJ2","RECENT",0)),INDX=+$P(X,U,2)
- F S INDX=$O(^XTMP("MAGJ2","RECENT",INDX)) Q:'INDX S X=^(INDX) D
- . S RADFN=$P(X,U),RADTI=$P(X,U,2),RACNI=$P(X,U,3),(RAST,STATCHK)=$P(X,U,4)
- . D GETEXAM2^MAGJUTL1(RADFN,RADTI,RACNI,0,.MAGRET)
- . I MAGRET D SVMAG2A()
- . S $P(^XTMP("MAGJ2","RECENT",0),U,2)=INDX
- ; copy the above records to the "RECENT" curlist
- S RECLIST=+$$CURLIST^MAGJLS2("LS9992")
- I 'RECLIST S RECLIST=+$G(^XTMP("MAGJ2","BKGND","LS9992",0))
- I 'RECLIST Q ; Recent list not being compiled--skip it!
- F CNT=1:1:MAGRACNT S X1=@MAGLST@(CNT,1),X2=^(2),XX9=$G(^("ISI")) D ; MAGLST described at BLDACTV
- . S REC=^XTMP("MAGJ2","LS9992",RECLIST,0,1)+1
- . S ^XTMP("MAGJ2","LS9992",RECLIST,REC,1)=X1,^(2)=X2,^("ISI")=XX9
- . S $P(^XTMP("MAGJ2","LS9992",RECLIST,0,1),U)=REC
- Q
- ;
- SVMAG2A(PIPE3) ;used by subroutine at tag BLDACTV
- ; load return array @MAGLST@(n, ...
- ; Note: ^TMP("MAGRAEX" is set by the subroutine Getexam2^Magjutl1
- ; PIPE3 optional; contains data that is passed through the system; e.g.
- ; the HISTORY List receives data from the client which is augmented
- ; and passed back to the client
- ;Set outside this subrtn:STATCHK,RAST,LSTREQ,REMONLY,BKGPROC,MAGRACNT,MAGLST
- ;
- N MAGDT,SORTDT,IMGCNT,ONL,XX,XX2,Y,RARPT,KEY,RASTCAT,Y2
- N REMOTE,MODALITY,DAYCASE,EXCAT,ORD,URG,URG1,PREOP,LASTSSN,CURPRIO,STATUS
- N REMOTE2,LRFLAG,TECH,REGDT,REGDTSRT,PTID,STATPRIORITY
- N XX9,PTDOB,PTAGE ; ISI
- S PIPE3=$G(PIPE3,"")
- S URG="",PREOP="" ; <*> Need below until RAO7PC1A returns URG
- S X=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
- S ORD=$P(X,U,11)
- I ORD S Y=$G(^RAO(75.1,ORD,0)),URG=$P(Y,U,6),PREOP=$P(Y,U,12)
- S XX=$G(^TMP($J,"MAGRAEX",1,1)),XX2=$G(^(2)),XX9=$G(^("ISI")) ; ISI added new fields
- I $G(STATCHK),(STATCHK=$P(XX,U,11))
- E I LSTREQ="H" S RAST=$P(XX,U,11)
- E I LSTREQ="I" S RAST=$P(XX,U,11) ; ISI
- E Q ; index '= stored status
- S RARPT=$P(XX,U,10),STATPRIORITY="" ; STATPRIORITY always null from the compiler (place-holder only)
- D IMGINFO^MAGJUTL2(RARPT,.Y)
- S IMGCNT=$P(Y,U),ONL=$P(Y,U,2),MAGDT=$P(Y,U,3),REMOTE=$P(Y,U,4),MODALITY=$P(Y,U,5),PLACE=$P(Y,U,6),KEY=$P(Y,U,7)
- S REMOTE2=REMOTE
- I IMGSONLY,'IMGCNT,'(LSTREQ="P") Q ;only list exams w/ imgs, except PENDING
- I REMONLY,'REMOTE,'$G(BKGPROC) Q ; only list remote exams
- S:PLACE PLACE=$P($G(^MAG(2006.1,PLACE,0)),U,9)
- I MAGDT="" S MAGDT=$P(XX,U,7)
- S SORTDT=MAGDT
- S MAGDT=$$FMTE^XLFDT(MAGDT,"5Z")
- S REGDTSRT=$P(XX,U,7),REGDT=$$FMTE^XLFDT(REGDTSRT,"5Z")
- ; XX 1 RADFN RADTI RACNI RANME RASSN <-- from GETEXAM
- ; 6 RADATE RADTE RACN RAPRC RARPT
- ; 11 RAST DAYCASE RAELOC RASTP RASTORD
- ; 16 RADTPRT RACPT IMTYPABB
- ;XX2 1 REQLOCABB REQLOCNM RdRIST COMPLIC RAD_DIV
- ; 6 SITE_CODE RISTISME PROCMOD REQLOCT REQWARD
- ; 11 RASTCAT LRFLAG TECH
- ;XX9 1 Assignee_initials Assign_Note Assignee_duz ; ISI -- begin
- ; 4 Favorite_KeyWd1 Favorite_KeyWd2 Favorite_Note
- ; 7 Patient_Age Patient_Sex Patient_DOB
- S PTDOB=$P(XX9,U,9),PTAGE=""
- I PTDOB D DT^DILF(,$P(MAGDT,"@"),.X) S PTAGE=$$AGECALC^ISIJLS2(PTDOB,X)
- S $P(XX9,U,7)=PTAGE ; ISI -- end
- S:'URG URG=9 ; request urgency default to Routine
- I URG=9,(PREOP]"") S URG=8 ; dummy val for Pre-Op
- S URG1=$S(URG=1:"Stat",URG=2:"Urg",URG=8:"PreOp",1:"Rout"),X=$E(URG1),URG1=$F(URGORD,X)-1_"-"_URG1
- I PREOP]"",(URG'=8) S URG1=URG1_"/Pre" ; show PreOp & another priority
- S SORTMAG=$S(+IMGCNT:"A",1:"B") ; sort index: has/not images
- S DAYCASE=$P(XX,U,12),RASTORD=$P(XX,U,15),STATUS=$P(XX,U,11),RASTCAT=$P(XX2,U,11),LRFLAG=$P(XX2,U,12),TECH=$P(XX2,U,13)
- S EXCAT="",CURPRIO=0
- I STATUS]"" D
- . S EXCAT=RASTCAT
- . I RASTORD<2!(EXCAT="W")!(EXCAT="R")!('IMGCNT) S CURPRIO=0 ; Cancelled/Waiting/No images: Ignore exam ; ISI P106
- . E I EXCAT="E" S CURPRIO=1 ; Examined="Current" exam
- . E S CURPRIO=2 ; must be a "prior" exam
- . I CURPRIO,'(ONL="Y") S CURPRIO=3 ; images on jukebox
- . I RASTORD=9 S EXCAT="C" ; Complete
- . E I EXCAT="D"!(EXCAT="T") S EXCAT="I" ; just display one value meaning Interpreted
- ; PTID is Initial w/ last 4 of SSN for VA (Z9999), or MRN for IHS (1.N number)
- ; LASTSSN is either last 4 digits of SSN, or last 4 of whatever number came in, or nil
- S X=$P(XX,U,5) ; SSN in VA, MRN in IHS
- I X?3N1"-"2N1"-"4N S LASTSSN=$P(X,"-",3),PTID=$E($P(XX,U,4))_LASTSSN
- E S PTID=X D
- . I X?1N.N S X=10000+X,T=$L(X),LASTSSN=$E(X,T-3,T)
- . E S LASTSSN=""
- ; build output string in Y & Y2
- S Y=DAYCASE_U_U_$P(XX,U,4)_U_PTID
- S Y=Y_U_URG1_U_$E($P(XX,U,9),1,30)_U_MAGDT_U_$E($P(XX,U,14),1,16)_U_IMGCNT ; ISI P106
- S Y=Y_U_ONL_U_$E($P(XX,U,13),1,15)_U_REMOTE
- S Y=Y_U_SORTMAG_U_SORTDT_U_MODALITY_U_RAST_U_$$RAIMTYP(RAST)
- S RISTISME=$P(XX2,U,7)
- S Y2=$P(XX2,U,1,3)_U_LASTSSN_U_$P(XX2,U,5)_U_PLACE_U_RISTISME_U_$P(XX2,U,8,9)_U_$P(XX,U,17)_U_$P(XX2,U,10)
- ; add 4 "place holders" for fields that are only in the History list
- S Y2=Y2_U_U_U_U
- S Y2=Y2_U_TECH_U_REGDT_U_REGDTSRT ; p101 adds 3 new fields
- S Y2=Y2_U_"|"_$P(XX,U,1,3)_U_RARPT
- S Y2=Y2_"|"_PIPE3_"|"_EXCAT_"^^^"_MODALITY_U_$P(XX,U,17)_U_CURPRIO_U_RARPT_U_KEY_U_REMOTE2_U_LRFLAG_U_STATPRIORITY
- ; * Note: Keep Pipe piece 4, above, in sync with lstout^magjls2b & magjlst1 *
- S MAGRACNT=MAGRACNT+1
- S @MAGLST@(MAGRACNT,1)=Y,^(2)=Y2,^("ISI")=XX9 ; save output for one exam ; ISI
- I $G(BKGPROC),(LSTREQ="R"),'$$MGRREV2^ISIJUTL9 S ^TMP($J,"NEWINT",$P(XX,U,1,3))="" ; ISI -- Rev-2?
- Q
- ;
- RAIMTYP(RAST) ; return Imaging Type Abbrev for Status Code
- N X S X="" I RAST]"" D
- . S X=$G(RAIMTYP(RAST)) Q:X]""
- . S X=$P($G(^RA(72,RAST,0)),U,7)
- . I X S X=$P($G(^RA(79.2,X,0)),U,3)_"~"_X ; abb~ien
- . S RAIMTYP(RAST)=X ; save for future use
- Q X
- ;
- IMGTYLST(LISCAT,LST) ; get exams for list of image types for input LISCAT
- N TYP
- F Q:'(LST?1.N.E) S TYP=+$P(LST,U),LST=$P(LST,U,2,99) D:TYP IMGTYP(LISCAT,TYP)
- Q
- ;
- IMGTYP(LISCAT,IMGTY) ; process statuses for one Image Type for LISCAT
- I '$D(^RA(79.2,IMGTY,0)) S REPLY="0^4~Invalid Imaging Type" Q
- N LST
- I $D(STAT)<10 D BLDSTAT^MAGJLS3A
- S (STAT,LST)=""
- S LASTDT=$P(STAT(LISCAT),U)
- F S STAT=$O(STAT(LISCAT,IMGTY,STAT)) Q:STAT="" S LST=LST_$S(LST="":"",1:U)_STAT,HDRLST(STAT(LISCAT,IMGTY))=""
- I LST]"" D STATLST(LST)
- Q
- ;
- STATLST(LST) ; get exams for a list of status codes
- F Q:'(LST?1.N.E) S STAT=+$P(LST,U),LST=$P(LST,U,2,99) D:STAT STAT(STAT)
- Q
- ;
- STAT(RAST) ; get exams for one status code
- ; uses File #70) "AS" index of active exams
- ;
- N RASTP
- I $D(^RA(72,RAST)) S RASTP=$P(^(RAST,0),U)
- E S REPLY="0^4~Invalid Exam Status" Q
- I '$D(^RADPT("AS",RAST)) S REPLY="0^2~No exams on file with Exam Status "_RASTP Q
- S RADFN=0,STATCHK=RAST
- F S RADFN=$O(^RADPT("AS",RAST,RADFN)) Q:RADFN'>0 S RADTI=0 D
- . F S RADTI=$O(^RADPT("AS",RAST,RADFN,RADTI)) Q:RADTI'>0!(RADTI>LASTDT) S RACNI=0 D
- . . I '$G(BKGPROC) Q:'$$DIVSCRN(RADFN,RADTI) ; ISI--skip if not in my logon division/assoc div
- . . F S RACNI=$O(^RADPT("AS",RAST,RADFN,RADTI,RACNI)) Q:RACNI'>0 D
- . . . D GETEXAM2^MAGJUTL1(RADFN,RADTI,RACNI,0,.MAGRET)
- . . . Q:'MAGRET ; no exam returned
- . . . D SVMAG2A()
- Q
- ;
- DIVSCRN(RADFN,RADTI) ; ISI begin--adding new function
- ; --> Return T/F: exam is of interest for my logon Division?
- N PROCEED,RADATA,X
- S PROCEED=1
- I $G(MAGJOB("CONSOLIDATED")) D ; only matters for Consolidated DB
- . S RADATA=$G(^RADPT(RADFN,"DT",RADTI,0)) I RADATA]"" D
- . S X=$P(RADATA,U,3) I X]"",'$D(MAGJOB("DIVSCRN",X)) S PROCEED=0
- Q:$Q PROCEED Q
- ; ISI--end
- END Q ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGJLS3 12122 printed Feb 18, 2025@23:33:15 Page 2
- MAGJLS3 ;WIRMFO/JHC - Rad. Workstation RPC calls ; 10/17/2022
- +1 ;;3.0;IMAGING;**16,22,18,101,90,120,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 ;; | The Food and Drug Administration classifies this software as |
- +11 ;; | a medical device. As such, it may not be changed in any way. |
- +12 ;; | Modifications to this software may result in an adulterated |
- +13 ;; | medical device under 21CFR820, the use of which is considered |
- +14 ;; | to be a violation of US Federal Statutes. |
- +15 ;; +---------------------------------------------------------------+
- +16 ;;
- +17 ;; ISI IMAGING;**99,101,106**
- +18 QUIT
- +19 ; EPs:
- +20 ; BLDACTV
- +21 ;
- BLDACTV(MAGGRY,DATA,MAGLST) ; get subset of Active Exams; called from MAGJLS2
- +1 ;MAGGRY - Indirect Global ref of return array
- +2 ;DATA: Listyp ^ Imaging Types
- +3 ;Listyp = U -- UNREAD Exams (Status Category=E)
- +4 ; = R -- RECENT (Sts Cat's D & T)
- +5 ; = A -- ALL Active (Cat's E, D, & T)
- +6 ; = P -- PENDING (Cat's W & R) ; ISI P106
- +7 ; = N -- Newly Interpreted Exams (No Cat.-Internal use only)
- +8 ; = I -- Indexed Exams (No Cat.-Internal use only), = misc indexed lists (Favorites = 1st example) ; ISI
- +9 ;ImgTypes = List of Imaging Types to process, or "ALL" for all
- +10 ; MAGLST = $NA ref to return global; references to it use subscript indirection
- +11 ; MAGLST optional: input to specify return global to use
- +12 ;
- +13 ;* This subrtn can receive U/R/A/P/N (LSTREQ)-- ^_delim list of ImgTypes (IMTYPS)
- +14 ; Also can receive I; no imaging types in particular ; ISI
- +15 NEW RADFN,RADTI,RACNI,REMX
- +16 NEW HDR,HDRLST,MAGIMGTY,MAGRACNT,MAGRET,LSTREQ,LISTYP,LISCAT,IMTYPS
- +17 NEW REPLY,STAT,TYP,SORTMAG,DIQUIET,STATCHK,LASTDT,IMGSONLY,URGORD,REMONLY
- +18 SET DIQUIET=1
- DO DT^DICRW
- +19 ; default loc'n if not passed in
- IF $GET(MAGLST)=""
- SET MAGLST=$NAME(^TMP($JOB,"MAGJACTIVE"))
- +20 KILL ^TMP($JOB,"MAGRAEX"),@MAGLST
- +21 SET LSTREQ=$PIECE(DATA,U)
- SET IMTYPS=$PIECE(DATA,U,2,99)
- +22 ; ISI
- IF LSTREQ="U"!(LSTREQ="R")!(LSTREQ="A")!(LSTREQ="P")!(LSTREQ="N")!(LSTREQ="H")!(LSTREQ="I")
- +23 IF '$TEST
- SET REPLY="0^4~Invalid Request (List Type="_LSTREQ_")"
- GOTO BLDACTVZ
- +24 SET MAGRACNT=0
- +25 ; show only exams w/ images?
- SET X=$GET(^MAG(2006.69,1,0))
- SET IMGSONLY=+$PIECE(X,U,7)
- SET REMX=+$PIECE(X,U,10)
- +26 SET REMONLY=0
- +27 ; ;show remote cache only?
- IF $GET(MAGJOB("REMOTE"))
- Begin DoDot:1
- +28 ; ISI
- if (LSTREQ="H")
- QUIT
- if (LSTREQ="I")
- QUIT
- SET REMONLY=+$GET(MAGJOB("REMOTESCREEN"))
- End DoDot:1
- +29 SET X=$GET(^MAG(2006.69,1,1))
- SET URGORD=$PIECE(X,U)
- +30 ; "Priority" sort
- if URGORD=""
- SET URGORD="S,U,P,R"
- SET URGORD=$TRANSLATE(URGORD,",")
- +31 ; ISI
- SET HDR=$SELECT(LSTREQ="U":"UNREAD",LSTREQ="R":"RECENT",LSTREQ="P":"PENDING",LSTREQ="A":"UNREAD and RECENT",LSTREQ="N":"NEWLY INTERP",LSTREQ="H":"HISTORY",LSTREQ="I":"INDEXED",1:"")_" Exams"_" for IMAGING TYPES: "
- +32 ; ISI P99, P106
- SET LISTYP=$SELECT(LSTREQ="U":"E",LSTREQ="R":"D^T",LSTREQ="A":"E^D^T",LSTREQ="P":"W^R",LSTREQ="N":"",LSTREQ="H":"",LSTREQ="I":"",1:"E")
- +33 SET REPLY="0^4~Compiling list of Radiology Exams (ACTIVE)."
- +34 ; ISI Rev-2?
- IF $GET(BKGPROC)
- IF (LSTREQ="R")
- IF '$$MGRREV2^ISIJUTL9
- KILL ^TMP($JOB,"NEWINT")
- SET ^TMP($JOB,"NEWINT")=+$GET(^XTMP("MAGJ2","RECENT",0))
- +35 ; ISI -- call only if Rev-2 not enabled
- IF LSTREQ="N"
- if '$$MGRREV2^ISIJUTL9
- DO BLDACT2
- GOTO BLDACTVZ
- +36 IF LSTREQ="H"
- DO HISTBLD^MAGJLS3A
- GOTO BLDACTVZ
- +37 ; ISI
- IF LSTREQ="I"
- DO INDXBLD^ISIJLS1
- GOTO BLDACTVZ
- +38 DO BLDACT1
- BLDACTVZ ;
- +1 IF 'MAGRACNT
- if (REPLY["Compiling")
- SET REPLY="0^2~No Exams Found"
- +2 IF '$TEST
- Begin DoDot:1
- +3 IF IMTYPS="ALL"
- SET HDR=HDR_" ALL"
- +4 IF '$TEST
- SET Y=""
- FOR I=0:1
- SET Y=$ORDER(HDRLST(Y))
- if Y=""
- QUIT
- SET HDR=HDR_$SELECT('I:"",1:", ")_Y
- +5 SET REPLY=MAGRACNT_U_"1~"_HDR
- End DoDot:1
- +6 SET @MAGLST@(0,1)=REPLY
- SET ^(2)=""
- +7 KILL ^TMP($JOB,"MAGRAEX"),^("RAE1")
- +8 SET MAGGRY=MAGLST
- +9 QUIT
- BLDACT1 ; Compile exams by Status codes
- +1 DO BLDSTAT^MAGJLS3A
- +2 FOR
- SET LISCAT=$PIECE(LISTYP,U)
- SET LISTYP=$PIECE(LISTYP,U,2,9)
- if LISCAT=""
- QUIT
- Begin DoDot:1
- +3 IF IMTYPS="ALL"
- SET TYP=""
- Begin DoDot:2
- +4 FOR
- SET TYP=$ORDER(STAT(LISCAT,TYP))
- if TYP=""
- QUIT
- DO IMGTYP(LISCAT,TYP)
- End DoDot:2
- QUIT
- +5 IF '$TEST
- IF +IMTYPS
- DO IMGTYLST(LISCAT,IMTYPS)
- QUIT
- +6 IF '$TEST
- SET REPLY="0^4~Invalid Imaging Type"
- End DoDot:1
- +7 QUIT
- BLDACT2 ; Add recently interpreted exams to the "Recent" compile data
- +1 ; 1st, compile these into their own list
- +2 NEW CNT,INDX,RAST,STATCHK,RECLIST,REC,X1,X2,XX9
- +3 SET X=$GET(^XTMP("MAGJ2","RECENT",0))
- SET INDX=+$PIECE(X,U,2)
- +4 FOR
- SET INDX=$ORDER(^XTMP("MAGJ2","RECENT",INDX))
- if 'INDX
- QUIT
- SET X=^(INDX)
- Begin DoDot:1
- +5 SET RADFN=$PIECE(X,U)
- SET RADTI=$PIECE(X,U,2)
- SET RACNI=$PIECE(X,U,3)
- SET (RAST,STATCHK)=$PIECE(X,U,4)
- +6 DO GETEXAM2^MAGJUTL1(RADFN,RADTI,RACNI,0,.MAGRET)
- +7 IF MAGRET
- DO SVMAG2A()
- +8 SET $PIECE(^XTMP("MAGJ2","RECENT",0),U,2)=INDX
- End DoDot:1
- +9 ; copy the above records to the "RECENT" curlist
- +10 SET RECLIST=+$$CURLIST^MAGJLS2("LS9992")
- +11 IF 'RECLIST
- SET RECLIST=+$GET(^XTMP("MAGJ2","BKGND","LS9992",0))
- +12 ; Recent list not being compiled--skip it!
- IF 'RECLIST
- QUIT
- +13 ; MAGLST described at BLDACTV
- FOR CNT=1:1:MAGRACNT
- SET X1=@MAGLST@(CNT,1)
- SET X2=^(2)
- SET XX9=$GET(^("ISI"))
- Begin DoDot:1
- +14 SET REC=^XTMP("MAGJ2","LS9992",RECLIST,0,1)+1
- +15 SET ^XTMP("MAGJ2","LS9992",RECLIST,REC,1)=X1
- SET ^(2)=X2
- SET ^("ISI")=XX9
- +16 SET $PIECE(^XTMP("MAGJ2","LS9992",RECLIST,0,1),U)=REC
- End DoDot:1
- +17 QUIT
- +18 ;
- SVMAG2A(PIPE3) ;used by subroutine at tag BLDACTV
- +1 ; load return array @MAGLST@(n, ...
- +2 ; Note: ^TMP("MAGRAEX" is set by the subroutine Getexam2^Magjutl1
- +3 ; PIPE3 optional; contains data that is passed through the system; e.g.
- +4 ; the HISTORY List receives data from the client which is augmented
- +5 ; and passed back to the client
- +6 ;Set outside this subrtn:STATCHK,RAST,LSTREQ,REMONLY,BKGPROC,MAGRACNT,MAGLST
- +7 ;
- +8 NEW MAGDT,SORTDT,IMGCNT,ONL,XX,XX2,Y,RARPT,KEY,RASTCAT,Y2
- +9 NEW REMOTE,MODALITY,DAYCASE,EXCAT,ORD,URG,URG1,PREOP,LASTSSN,CURPRIO,STATUS
- +10 NEW REMOTE2,LRFLAG,TECH,REGDT,REGDTSRT,PTID,STATPRIORITY
- +11 ; ISI
- NEW XX9,PTDOB,PTAGE
- +12 SET PIPE3=$GET(PIPE3,"")
- +13 ; <*> Need below until RAO7PC1A returns URG
- SET URG=""
- SET PREOP=""
- +14 SET X=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
- +15 SET ORD=$PIECE(X,U,11)
- +16 IF ORD
- SET Y=$GET(^RAO(75.1,ORD,0))
- SET URG=$PIECE(Y,U,6)
- SET PREOP=$PIECE(Y,U,12)
- +17 ; ISI added new fields
- SET XX=$GET(^TMP($JOB,"MAGRAEX",1,1))
- SET XX2=$GET(^(2))
- SET XX9=$GET(^("ISI"))
- +18 IF $GET(STATCHK)
- IF (STATCHK=$PIECE(XX,U,11))
- +19 IF '$TEST
- IF LSTREQ="H"
- SET RAST=$PIECE(XX,U,11)
- +20 ; ISI
- IF '$TEST
- IF LSTREQ="I"
- SET RAST=$PIECE(XX,U,11)
- +21 ; index '= stored status
- IF '$TEST
- QUIT
- +22 ; STATPRIORITY always null from the compiler (place-holder only)
- SET RARPT=$PIECE(XX,U,10)
- SET STATPRIORITY=""
- +23 DO IMGINFO^MAGJUTL2(RARPT,.Y)
- +24 SET IMGCNT=$PIECE(Y,U)
- SET ONL=$PIECE(Y,U,2)
- SET MAGDT=$PIECE(Y,U,3)
- SET REMOTE=$PIECE(Y,U,4)
- SET MODALITY=$PIECE(Y,U,5)
- SET PLACE=$PIECE(Y,U,6)
- SET KEY=$PIECE(Y,U,7)
- +25 SET REMOTE2=REMOTE
- +26 ;only list exams w/ imgs, except PENDING
- IF IMGSONLY
- IF 'IMGCNT
- IF '(LSTREQ="P")
- QUIT
- +27 ; only list remote exams
- IF REMONLY
- IF 'REMOTE
- IF '$GET(BKGPROC)
- QUIT
- +28 if PLACE
- SET PLACE=$PIECE($GET(^MAG(2006.1,PLACE,0)),U,9)
- +29 IF MAGDT=""
- SET MAGDT=$PIECE(XX,U,7)
- +30 SET SORTDT=MAGDT
- +31 SET MAGDT=$$FMTE^XLFDT(MAGDT,"5Z")
- +32 SET REGDTSRT=$PIECE(XX,U,7)
- SET REGDT=$$FMTE^XLFDT(REGDTSRT,"5Z")
- +33 ; XX 1 RADFN RADTI RACNI RANME RASSN <-- from GETEXAM
- +34 ; 6 RADATE RADTE RACN RAPRC RARPT
- +35 ; 11 RAST DAYCASE RAELOC RASTP RASTORD
- +36 ; 16 RADTPRT RACPT IMTYPABB
- +37 ;XX2 1 REQLOCABB REQLOCNM RdRIST COMPLIC RAD_DIV
- +38 ; 6 SITE_CODE RISTISME PROCMOD REQLOCT REQWARD
- +39 ; 11 RASTCAT LRFLAG TECH
- +40 ;XX9 1 Assignee_initials Assign_Note Assignee_duz ; ISI -- begin
- +41 ; 4 Favorite_KeyWd1 Favorite_KeyWd2 Favorite_Note
- +42 ; 7 Patient_Age Patient_Sex Patient_DOB
- +43 SET PTDOB=$PIECE(XX9,U,9)
- SET PTAGE=""
- +44 IF PTDOB
- DO DT^DILF(,$PIECE(MAGDT,"@"),.X)
- SET PTAGE=$$AGECALC^ISIJLS2(PTDOB,X)
- +45 ; ISI -- end
- SET $PIECE(XX9,U,7)=PTAGE
- +46 ; request urgency default to Routine
- if 'URG
- SET URG=9
- +47 ; dummy val for Pre-Op
- IF URG=9
- IF (PREOP]"")
- SET URG=8
- +48 SET URG1=$SELECT(URG=1:"Stat",URG=2:"Urg",URG=8:"PreOp",1:"Rout")
- SET X=$EXTRACT(URG1)
- SET URG1=$FIND(URGORD,X)-1_"-"_URG1
- +49 ; show PreOp & another priority
- IF PREOP]""
- IF (URG'=8)
- SET URG1=URG1_"/Pre"
- +50 ; sort index: has/not images
- SET SORTMAG=$SELECT(+IMGCNT:"A",1:"B")
- +51 SET DAYCASE=$PIECE(XX,U,12)
- SET RASTORD=$PIECE(XX,U,15)
- SET STATUS=$PIECE(XX,U,11)
- SET RASTCAT=$PIECE(XX2,U,11)
- SET LRFLAG=$PIECE(XX2,U,12)
- SET TECH=$PIECE(XX2,U,13)
- +52 SET EXCAT=""
- SET CURPRIO=0
- +53 IF STATUS]""
- Begin DoDot:1
- +54 SET EXCAT=RASTCAT
- +55 ; Cancelled/Waiting/No images: Ignore exam ; ISI P106
- IF RASTORD<2!(EXCAT="W")!(EXCAT="R")!('IMGCNT)
- SET CURPRIO=0
- +56 ; Examined="Current" exam
- IF '$TEST
- IF EXCAT="E"
- SET CURPRIO=1
- +57 ; must be a "prior" exam
- IF '$TEST
- SET CURPRIO=2
- +58 ; images on jukebox
- IF CURPRIO
- IF '(ONL="Y")
- SET CURPRIO=3
- +59 ; Complete
- IF RASTORD=9
- SET EXCAT="C"
- +60 ; just display one value meaning Interpreted
- IF '$TEST
- IF EXCAT="D"!(EXCAT="T")
- SET EXCAT="I"
- End DoDot:1
- +61 ; PTID is Initial w/ last 4 of SSN for VA (Z9999), or MRN for IHS (1.N number)
- +62 ; LASTSSN is either last 4 digits of SSN, or last 4 of whatever number came in, or nil
- +63 ; SSN in VA, MRN in IHS
- SET X=$PIECE(XX,U,5)
- +64 IF X?3N1"-"2N1"-"4N
- SET LASTSSN=$PIECE(X,"-",3)
- SET PTID=$EXTRACT($PIECE(XX,U,4))_LASTSSN
- +65 IF '$TEST
- SET PTID=X
- Begin DoDot:1
- +66 IF X?1N.N
- SET X=10000+X
- SET T=$LENGTH(X)
- SET LASTSSN=$EXTRACT(X,T-3,T)
- +67 IF '$TEST
- SET LASTSSN=""
- End DoDot:1
- +68 ; build output string in Y & Y2
- +69 SET Y=DAYCASE_U_U_$PIECE(XX,U,4)_U_PTID
- +70 ; ISI P106
- SET Y=Y_U_URG1_U_$EXTRACT($PIECE(XX,U,9),1,30)_U_MAGDT_U_$EXTRACT($PIECE(XX,U,14),1,16)_U_IMGCNT
- +71 SET Y=Y_U_ONL_U_$EXTRACT($PIECE(XX,U,13),1,15)_U_REMOTE
- +72 SET Y=Y_U_SORTMAG_U_SORTDT_U_MODALITY_U_RAST_U_$$RAIMTYP(RAST)
- +73 SET RISTISME=$PIECE(XX2,U,7)
- +74 SET Y2=$PIECE(XX2,U,1,3)_U_LASTSSN_U_$PIECE(XX2,U,5)_U_PLACE_U_RISTISME_U_$PIECE(XX2,U,8,9)_U_$PIECE(XX,U,17)_U_$PIECE(XX2,U,10)
- +75 ; add 4 "place holders" for fields that are only in the History list
- +76 SET Y2=Y2_U_U_U_U
- +77 ; p101 adds 3 new fields
- SET Y2=Y2_U_TECH_U_REGDT_U_REGDTSRT
- +78 SET Y2=Y2_U_"|"_$PIECE(XX,U,1,3)_U_RARPT
- +79 SET Y2=Y2_"|"_PIPE3_"|"_EXCAT_"^^^"_MODALITY_U_$PIECE(XX,U,17)_U_CURPRIO_U_RARPT_U_KEY_U_REMOTE2_U_LRFLAG_U_STATPRIORITY
- +80 ; * Note: Keep Pipe piece 4, above, in sync with lstout^magjls2b & magjlst1 *
- +81 SET MAGRACNT=MAGRACNT+1
- +82 ; save output for one exam ; ISI
- SET @MAGLST@(MAGRACNT,1)=Y
- SET ^(2)=Y2
- SET ^("ISI")=XX9
- +83 ; ISI -- Rev-2?
- IF $GET(BKGPROC)
- IF (LSTREQ="R")
- IF '$$MGRREV2^ISIJUTL9
- SET ^TMP($JOB,"NEWINT",$PIECE(XX,U,1,3))=""
- +84 QUIT
- +85 ;
- RAIMTYP(RAST) ; return Imaging Type Abbrev for Status Code
- +1 NEW X
- SET X=""
- IF RAST]""
- Begin DoDot:1
- +2 SET X=$GET(RAIMTYP(RAST))
- if X]""
- QUIT
- +3 SET X=$PIECE($GET(^RA(72,RAST,0)),U,7)
- +4 ; abb~ien
- IF X
- SET X=$PIECE($GET(^RA(79.2,X,0)),U,3)_"~"_X
- +5 ; save for future use
- SET RAIMTYP(RAST)=X
- End DoDot:1
- +6 QUIT X
- +7 ;
- IMGTYLST(LISCAT,LST) ; get exams for list of image types for input LISCAT
- +1 NEW TYP
- +2 FOR
- if '(LST?1.N.E)
- QUIT
- SET TYP=+$PIECE(LST,U)
- SET LST=$PIECE(LST,U,2,99)
- if TYP
- DO IMGTYP(LISCAT,TYP)
- +3 QUIT
- +4 ;
- IMGTYP(LISCAT,IMGTY) ; process statuses for one Image Type for LISCAT
- +1 IF '$DATA(^RA(79.2,IMGTY,0))
- SET REPLY="0^4~Invalid Imaging Type"
- QUIT
- +2 NEW LST
- +3 IF $DATA(STAT)<10
- DO BLDSTAT^MAGJLS3A
- +4 SET (STAT,LST)=""
- +5 SET LASTDT=$PIECE(STAT(LISCAT),U)
- +6 FOR
- SET STAT=$ORDER(STAT(LISCAT,IMGTY,STAT))
- if STAT=""
- QUIT
- SET LST=LST_$SELECT(LST="":"",1:U)_STAT
- SET HDRLST(STAT(LISCAT,IMGTY))=""
- +7 IF LST]""
- DO STATLST(LST)
- +8 QUIT
- +9 ;
- STATLST(LST) ; get exams for a list of status codes
- +1 FOR
- if '(LST?1.N.E)
- QUIT
- SET STAT=+$PIECE(LST,U)
- SET LST=$PIECE(LST,U,2,99)
- if STAT
- DO STAT(STAT)
- +2 QUIT
- +3 ;
- STAT(RAST) ; get exams for one status code
- +1 ; uses File #70) "AS" index of active exams
- +2 ;
- +3 NEW RASTP
- +4 IF $DATA(^RA(72,RAST))
- SET RASTP=$PIECE(^(RAST,0),U)
- +5 IF '$TEST
- SET REPLY="0^4~Invalid Exam Status"
- QUIT
- +6 IF '$DATA(^RADPT("AS",RAST))
- SET REPLY="0^2~No exams on file with Exam Status "_RASTP
- QUIT
- +7 SET RADFN=0
- SET STATCHK=RAST
- +8 FOR
- SET RADFN=$ORDER(^RADPT("AS",RAST,RADFN))
- if RADFN'>0
- QUIT
- SET RADTI=0
- Begin DoDot:1
- +9 FOR
- SET RADTI=$ORDER(^RADPT("AS",RAST,RADFN,RADTI))
- if RADTI'>0!(RADTI>LASTDT)
- QUIT
- SET RACNI=0
- Begin DoDot:2
- +10 ; ISI--skip if not in my logon division/assoc div
- IF '$GET(BKGPROC)
- if '$$DIVSCRN(RADFN,RADTI)
- QUIT
- +11 FOR
- SET RACNI=$ORDER(^RADPT("AS",RAST,RADFN,RADTI,RACNI))
- if RACNI'>0
- QUIT
- Begin DoDot:3
- +12 DO GETEXAM2^MAGJUTL1(RADFN,RADTI,RACNI,0,.MAGRET)
- +13 ; no exam returned
- if 'MAGRET
- QUIT
- +14 DO SVMAG2A()
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +15 QUIT
- +16 ;
- DIVSCRN(RADFN,RADTI) ; ISI begin--adding new function
- +1 ; --> Return T/F: exam is of interest for my logon Division?
- +2 NEW PROCEED,RADATA,X
- +3 SET PROCEED=1
- +4 ; only matters for Consolidated DB
- IF $GET(MAGJOB("CONSOLIDATED"))
- Begin DoDot:1
- +5 SET RADATA=$GET(^RADPT(RADFN,"DT",RADTI,0))
- IF RADATA]""
- Begin DoDot:2
- End DoDot:2
- +6 SET X=$PIECE(RADATA,U,3)
- IF X]""
- IF '$DATA(MAGJOB("DIVSCRN",X))
- SET PROCEED=0
- End DoDot:1
- +7 if $QUIT
- QUIT PROCEED
- QUIT
- +8 ; ISI--end
- END ;
- QUIT