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 Dec 13, 2024@02:06:46 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
