Changeset 623 for WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (16 years ago)
- Location:
- WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG
- Files:
-
- 51 edited
-
MAGBAPIP.m (modified) (1 diff)
-
MAGGNLKP.m (modified) (1 diff)
-
MAGGNTI.m (modified) (1 diff)
-
MAGGNTI1.m (modified) (1 diff)
-
MAGGNTI2.m (modified) (1 diff)
-
MAGGNTI3.m (modified) (1 diff)
-
MAGGSIA.m (modified) (1 diff)
-
MAGGSIA1.m (modified) (1 diff)
-
MAGGSIU2.m (modified) (1 diff)
-
MAGGSIUI.m (modified) (1 diff)
-
MAGGSIV.m (modified) (1 diff)
-
MAGGSIV1.m (modified) (1 diff)
-
MAGGTAU.m (modified) (1 diff)
-
MAGGTERR.m (modified) (1 diff)
-
MAGGTIA1.m (modified) (1 diff)
-
MAGGTID.m (modified) (1 diff)
-
MAGGTII.m (modified) (1 diff)
-
MAGGTLB1.m (modified) (1 diff)
-
MAGGTMC1.m (modified) (1 diff)
-
MAGGTPT1.m (modified) (1 diff)
-
MAGGTRA.m (modified) (1 diff)
-
MAGGTSR.m (modified) (1 diff)
-
MAGGTSR1.m (modified) (1 diff)
-
MAGGTSY2.m (modified) (1 diff)
-
MAGGTSYS.m (modified) (1 diff)
-
MAGGTU1.m (modified) (1 diff)
-
MAGGTU3.m (modified) (1 diff)
-
MAGGTU31.m (modified) (1 diff)
-
MAGGTU4.m (modified) (1 diff)
-
MAGGTU41.m (modified) (1 diff)
-
MAGGTU6.m (modified) (1 diff)
-
MAGGTU71.m (modified) (1 diff)
-
MAGGTU9.m (modified) (1 diff)
-
MAGGTUP.m (modified) (1 diff)
-
MAGJEX1B.m (modified) (1 diff)
-
MAGJEX2.m (modified) (1 diff)
-
MAGJLS2.m (modified) (1 diff)
-
MAGJLS2B.m (modified) (1 diff)
-
MAGJLS4.m (modified) (1 diff)
-
MAGJLST1.m (modified) (1 diff)
-
MAGJMN1.m (modified) (1 diff)
-
MAGJUPD1.m (modified) (1 diff)
-
MAGJUPD2.m (modified) (1 diff)
-
MAGJUTL1.m (modified) (1 diff)
-
MAGJUTL2.m (modified) (1 diff)
-
MAGJUTL3.m (modified) (1 diff)
-
MAGJUTL4.m (modified) (1 diff)
-
MAGJUTL5.m (modified) (1 diff)
-
MAGLOG.m (modified) (1 diff)
-
MAGSIXG1.m (modified) (1 diff)
-
MAGSIXGT.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGBAPIP.m
r613 r623 1 MAGBAPIP ;WOIFO/MLH - Background Processor API to build queues - Modules for place 2 ;;3.0;IMAGING;**1,7,8,20,59**;Nov 27, 2007;Build 20 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 DUZ2PLC(WARN) ;Convert DUZ to a PLACE. File 2006.1 entry (PLACE) 20 ; Extrinsic : Always returns a PLACE 21 ; WARN : message about where the PLACE was derived from. 22 ; Compute the Users Institution for older versions of Imaging Display workstation. 23 ; This is called when DUZ(2) doesn't exist Or Can't resolve DUZ(2) 24 ; into site param entry. This solved a GateWay Problem where DUZ(2) didn't 25 ; exist. - Shouldn't get here anymore, that was fixed. 26 N MAGINST,DIVDTA,PLACE 27 S MAGINST=0 28 D GETS^DIQ(200,DUZ,"16*","I","DIVDTA") ; look up Division field 29 ; ? Any division data on file for this user 30 I $D(DIVDTA) D ; yes, use it 31 . S MAGINST=@$Q(DIVDTA),WARN="Using first Division of New Person File." 32 . Q 33 E D ; no, use default site param? 34 . S MAGINST=$$KSP^XUPARAM("INST"),WARN="Using Kernel Site Param default entry." Q 35 . Q 36 S PLACE=$$GETPLACE^MAGBAPI(+$$PLACE^MAGBAPI(MAGINST)) 37 I 'PLACE S PLACE=$O(^MAG(2006.1,0)),WARN="Using First Site Param entry." 38 Q PLACE 39 ; 40 DA2PLC(MAGDA,TYPE) ; Get Place from Image File IEN 41 ; TYPE : Possible values "A" Abstract, "F" Full Res or "B" Big File 42 ; (defaults to "F" if null) 43 ; Resolve Place (PLC) using the Acquisition Site field (ACQS) 44 ; IF ACQS is null or not doesn't exist in the site parameter file 45 ; THEN Resolve PLC using NetWork Location pointer 46 ; 47 N MAGREF,MAG0,FBIG,SITE,PLC,MAGJB 48 I '$G(MAGDA) Q 0 49 S SITE=$P($G(^MAG(2005,MAGDA,100)),U,3) 50 I SITE S PLC=$$PLACE^MAGBAPI(SITE) Q:PLC PLC 51 ; p59 Stop the error when an Image is Deleted. 52 S MAG0=$G(^MAG(2005,MAGDA,0)) Q:MAG0="" 0 53 ; 54 S TYPE=$E($G(TYPE)_"F",1) 55 I "AF"[TYPE D 56 . S MAGREF=$S(TYPE="A":+$P(MAG0,"^",4),1:+$P(MAG0,"^",3)) 57 . I MAGREF=0 S MAGJB=1,MAGREF=+$P(MAG0,"^",5) ; get file from jukebox 58 I "B"[TYPE D 59 . S FBIG=$G(^MAG(2005,MAGDA,"FBIG")) 60 . S MAGREF=+$P(FBIG,"^") ; get file from magnetic disk, if possible 61 . I MAGREF=0 S MAGREF=+$P(FBIG,"^",2) ; get file from jukebox 62 I 'MAGREF Q 0 63 I '$D(^MAG(2005.2,MAGREF,0)) Q 0 64 Q $$GETPLACE^MAGBAPI(+$$GET1^DIQ(2005.2,MAGREF,.04,"I")) 1 MAGBAPIP ;WOIFO/MLH - Background Processor API to build queues - Modules for place 2 ;;3.0;IMAGING;**1,7,8,20**;Apr 12, 2006 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 DUZ2PLC(WARN) ; Moved from MAGGTU3 v2.5 - DBI - SEB Patch 4 19 ; Extrinsic : Always returns a PLACE /gek 8/2003 20 ; WARN : message about where the PLACE was derived from. /gek 8/2003 21 ; Compute the Users Institution for older versions of Imaging Display workstation. 22 ; This is called when : 23 ; DUZ(2) doesn't exist, 24 ; Or Can't resolve DUZ(2) into site param entry 25 N MAGINST,DIVDTA,PLACE 26 S MAGINST=0 27 D GETS^DIQ(200,DUZ,"16*","I","DIVDTA") ; look up Division field 28 ; ? Any division data on file for this user 29 I $D(DIVDTA) D ; yes, use it 30 . S MAGINST=@$Q(DIVDTA),WARN="Using first Division of New Person File." 31 . Q 32 E D ; no, use default site param? 33 . S MAGINST=$$KSP^XUPARAM("INST"),WARN="Using Kernel Site Param default entry." Q 34 . Q 35 S PLACE=$$GETPLACE^MAGBAPI(+$$PLACE^MAGBAPI(MAGINST)) 36 I 'PLACE S PLACE=$O(^MAG(2006.1,0)),WARN="Using First Site Param entry." 37 Q PLACE 38 ; 39 DA2PLC(MAGDA,TYPE) ; Moved from MAGGTU7 v2.5 - DBI - SEB Patch 4 40 ; TYPE : Possible values "A" Abstract, "F" Full Res or "B" Big File 41 ; (defaults to "F" if null) 42 ; Resolve current place of image using the Acquisition Site field, then 43 ; resolve current place of image using NetWork Location pointer 44 ; if the Acquisition Site field is null or not related to the site 45 ; parameter file. 46 ; 47 N MAGREF,MAG0,FBIG,SITE,PLC,MAGJB 48 I '$G(MAGDA) Q 0 49 S SITE=$P($G(^MAG(2005,MAGDA,100)),U,3) 50 I SITE S PLC=$$PLACE^MAGBAPI(SITE) Q:PLC PLC 51 S MAG0=^MAG(2005,MAGDA,0) 52 ;I '$D(TYPE) S TYPE="F" /gek 8/2003 mod for efficiency (from ed) 53 S TYPE=$E($G(TYPE)_"F",1) 54 I "AF"[TYPE D 55 . S MAGREF=$S(TYPE="A":+$P(MAG0,"^",4),1:+$P(MAG0,"^",3)) 56 . I MAGREF=0 S MAGJB=1,MAGREF=+$P(MAG0,"^",5) ; get file from jukebox 57 I "B"[TYPE D 58 . S FBIG=$G(^MAG(2005,MAGDA,"FBIG")) 59 . S MAGREF=+$P(FBIG,"^") ; get file from magnetic disk, if possible 60 . I MAGREF=0 S MAGREF=+$P(FBIG,"^",2) ; get file from jukebox 61 I 'MAGREF Q 0 62 I '$D(^MAG(2005.2,MAGREF,0)) Q 0 63 Q $$GETPLACE^MAGBAPI(+$$GET1^DIQ(2005.2,MAGREF,.04,"I")) -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGNLKP.m
r613 r623 1 MAGGNLKP ;WOIFO/GEK - Lookup from delphi into any file ; [ 06/20/2001 08:56 ] 2 ;;3.0;IMAGING;**8,92,46,59**;Nov 27, 2007;Build 20 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 ; 21 LKP(MAGRY,MAGIN,DATA) ;RPC [MAG3 LOOKUP ANY] 22 ; Generic lookup using FIND^DIC 23 ; MAGRY is the Array to return. 24 ; MAGIN is parameter sent by calling app (Delphi) 25 ; FILE NUM ^ NUM TO RETURN ^ TEXT TO MATCH ^ FIELDS ^ SCREEN ($P 5-99) 26 ; 27 ; DATA : 28 ; LVIEW =Piece 1 29 ; +LVIEW = 1 : 30 ; result array is formatted for a magListView control 31 ; i.e. ^ delimiter for data and "|" delimiter for IEN 32 ; +LVIEW = 0 : 33 ; old way, " " delim for data and '^' delim for IEN 34 ; INDX = Piece 2 35 ; This is the index to search 36 ; Defaults to "B" 37 ; 38 N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR" 39 ; 40 N Y,XI,Z,FI,MAGIEN,INFO,LVIEW,INDX 41 N FILE,IENS,FLDS,FLAGS,VAL,NUM,INDEX,SCR,IDENT,TROOT 42 S (FILE,IENS,FLDS,FLAGS,VAL,NUM,INDEX,SCR,IDENT,TROOT)="" 43 S MAGIN=$G(MAGIN) 44 S DATA=$G(DATA) 45 ; 46 S FILE=+$P(MAGIN,U,1) 47 S NUM=$S(+$P(MAGIN,U,2):+$P(MAGIN,U,2),1:200) 48 S VAL=$P(MAGIN,U,3) 49 S FLDS=$P(MAGIN,U,4) 50 S SCR=$P(MAGIN,U,5,99) 51 ; 52 S LVIEW=+$P(DATA,"^",1) 53 S INDX=$S($L($P(DATA,"^",2)):$P(DATA,"^",2),1:"B") 54 ; 55 I 'FILE S MAGRY(1)="0^ERROR - Invalid Parameter: File Number ? " Q 56 I '$$VFILE^DILFD(FILE) S MAGRY(1)="0^ERROR - Invalid File # - "_FILE Q 57 ; Number of entries to return, If 0 we'll stop at 200 58 ; 59 K ^TMP("DILIST",$J) 60 K ^TMP("DIERR",$J) 61 ; VAL is the initial value to search for. i.e. the user input. 62 ; Next line is to stop the FM Infinite Error Trap problem. 63 I $L(VAL)>30 S MAGRY(0)="0^Invalid Input: '"_$E(VAL,1,40)_"...' is too long. "_$L(VAL)_" characters." Q 64 D FIND^DIC(FILE,IENS,FLDS,FLAGS,VAL,NUM,INDEX,SCR,IDENT,TROOT) 65 ; 66 I '$D(^TMP("DILIST",$J,1)) S XI=1 D Q 67 . I $D(^TMP("DIERR",$J)) D FINDERR(XI) Q 68 . S MAGRY(XI)="0^NO MATCH for lookup on """_$P(MAGIN,"^",3)_"""" 69 ; so we have some matches, (BUT we could still have an error) 70 ; so first list all matches, then the ERROR 71 ; Next lines were Q&D but old .EXE's expect return string with 72 ; this syntax, when all T11 code is gone, this can be rewritten 73 I LVIEW S XI="" F S XI=$O(^TMP("DILIST",$J,1,XI)) Q:XI="" S X=^(XI) D 74 . S MAGIEN=^TMP("DILIST",$J,2,XI) 75 . S Z=".01",FLD="NAME" 76 . F S Z=$O(^TMP("DILIST",$J,"ID",XI,Z)) Q:Z="" S X=X_"^"_^(Z),FLD=FLD_"^"_$$GET1^DID(FILE,Z,"","LABEL","MAGFLD") 77 . S MAGRY(.05)=FLD 78 . S MAGRY(XI)=X_"^|"_MAGIEN 79 . Q 80 I 'LVIEW S XI="" F S XI=$O(^TMP("DILIST",$J,1,XI)) Q:XI="" S X=^(XI) D 81 . S MAGIEN=^TMP("DILIST",$J,2,XI) 82 . S Z="" 83 . F S Z=$O(^TMP("DILIST",$J,"ID",XI,Z)) Q:Z="" S X=X_" "_^(Z) 84 . S MAGRY(XI)=X_"^"_MAGIEN 85 . Q 86 I $D(^TMP("DIERR",$J)) D FINDERR() Q 87 I $D(^TMP("DILIST",$J,0)) S INFO=^(0) D 88 . S MAGRY(0)=$P(INFO,"^")_U_"Found "_$P(INFO,"^")_" entr"_$S((+INFO=1):"y",1:"ies")_" matching """_$P(MAGIN,"^",3)_"""" 89 . I $P(INFO,"^",3)>0 S MAGRY(0)=MAGRY(0)_" there are more" 90 . Q 91 Q 92 FINDERR(XI) ; 93 ; 94 I '+$G(XI) S XI=$O(MAGRY(""),-1)+1 95 S MAGRY(XI)="ERROR^"_^TMP("DIERR",$J,1,"TEXT",1) 96 Q 1 MAGGNLKP ;WOIFO/GEK - Lookup from delphi into any file ; [ 06/20/2001 08:56 ] 2 ;;3.0;IMAGING;**8,92**;Jan 10, 2007;Build 1 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 ; 21 LKP(MAGRY,MAGIN,DATA) ;RPC [MAG3 LOOKUP ANY] 22 ; Generic lookup using FIND^DIC 23 ; MAGRY is the Array to return. 24 ; MAGIN is parameter sent by calling app (Delphi) 25 ; FILE NUM ^ NUM TO RETURN ^ TEXT TO MATCH ^ FIELDS ^ SCREEN ($P 5-99) 26 ; 27 ; DATA : 28 ; LVIEW =Piece 1 29 ; +LVIEW = 1 : 30 ; result array is formatted for a magListView control 31 ; i.e. ^ delimiter for data and "|" delimiter for IEN 32 ; +LVIEW = 0 : 33 ; old way, " " delim for data and '^' delim for IEN 34 ; INDX = Piece 2 35 ; This is the index to search 36 ; Defaults to "B" 37 ; 38 ; 39 N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR" 40 ; 41 N Y,XI,Z,FI,MAGIEN,INFO,LVIEW,INDX 42 N FILE,IENS,FLDS,FLAGS,VAL,NUM,INDEX,SCR,IDENT,TROOT 43 S (FILE,IENS,FLDS,FLAGS,VAL,NUM,INDEX,SCR,IDENT,TROOT)="" 44 S MAGIN=$G(MAGIN) 45 S DATA=$G(DATA) 46 ; 47 S FILE=+$P(MAGIN,U,1) 48 S NUM=$S(+$P(MAGIN,U,2):+$P(MAGIN,U,2),1:200) 49 S VAL=$P(MAGIN,U,3) 50 S FLDS=$P(MAGIN,U,4) 51 S SCR=$P(MAGIN,U,5,99) 52 ; 53 S LVIEW=+$P(DATA,"^",1) 54 S INDX=$S($L($P(DATA,"^",2)):$P(DATA,"^",2),1:"B") 55 ; 56 I 'FILE S MAGRY(1)="0^ERROR - Invalid Parameter: File Number ? " Q 57 I '$$VFILE^DILFD(FILE) S MAGRY(1)="0^ERROR - Invalid File # - "_FILE Q 58 ; Number of entries to return, If 0 we'll stop at 200 59 ; 60 K ^TMP("DILIST",$J) 61 K ^TMP("DIERR",$J) 62 ; VAL is the initial value to search for. i.e. the user input. 63 ; Next line is to stop the FM Infinite Error Trap problem. 64 I $L(VAL)>30 S MAGRY(0)="0^Invalid Input: '"_$E(VAL,1,40)_"...' is too long. "_$L(VAL)_" characters." Q 65 D FIND^DIC(FILE,IENS,FLDS,FLAGS,VAL,NUM,INDEX,SCR,IDENT,TROOT) 66 ; 67 I '$D(^TMP("DILIST",$J,1)) S XI=1 D Q 68 . I $D(^TMP("DIERR",$J)) D FINDERR(XI) Q 69 . S MAGRY(XI)="0^NO MATCH for lookup on """_$P(MAGIN,"^",3)_"""" 70 ; so we have some matches, (BUT we could still have an error) 71 ; so first list all matches, then the ERROR 72 ; Next lines were Q&D but old .EXE's expect return string with 73 ; this syntax, when all T11 code is gone, this can be rewritten 74 I LVIEW S XI="" F S XI=$O(^TMP("DILIST",$J,1,XI)) Q:XI="" S X=^(XI) D 75 . S MAGIEN=^TMP("DILIST",$J,2,XI) 76 . S Z=".01",FLD="NAME" 77 . F S Z=$O(^TMP("DILIST",$J,"ID",XI,Z)) Q:Z="" S X=X_"^"_^(Z),FLD=FLD_"^"_$$GET1^DID(FILE,Z,"","LABEL","MAGFLD") 78 . S MAGRY(.05)=FLD 79 . S MAGRY(XI)=X_"^|"_MAGIEN 80 . Q 81 I 'LVIEW S XI="" F S XI=$O(^TMP("DILIST",$J,1,XI)) Q:XI="" S X=^(XI) D 82 . S MAGIEN=^TMP("DILIST",$J,2,XI) 83 . S Z="" 84 . F S Z=$O(^TMP("DILIST",$J,"ID",XI,Z)) Q:Z="" S X=X_" "_^(Z) 85 . S MAGRY(XI)=X_"^"_MAGIEN 86 . Q 87 I $D(^TMP("DIERR",$J)) D FINDERR() Q 88 I $D(^TMP("DILIST",$J,0)) S INFO=^(0) D 89 . S MAGRY(0)=$P(INFO,"^")_U_"Found "_$P(INFO,"^")_" entr"_$S((+INFO=1):"y",1:"ies")_" matching """_$P(MAGIN,"^",3)_"""" 90 . I $P(INFO,"^",3)>0 S MAGRY(0)=MAGRY(0)_" there are more" 91 . Q 92 Q 93 FINDERR(XI) ; 94 ; 95 I '+$G(XI) S XI=$O(MAGRY(""),-1)+1 96 S MAGRY(XI)="ERROR^"_^TMP("DIERR",$J,1,"TEXT",1) 97 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGNTI.m
r613 r623 1 MAGGNTI ;WOIFO/GEK - Imaging interface to TIU RPC Calls etc. ; 04 Apr 2002 2:37 PM 2 ;;3.0;IMAGING;**10,8,59**;Nov 27, 2007;Build 20 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 ;; | 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 Q 19 FILE(MAGRY,MAGDA,TIUDA) ;RPC [MAG3 TIU IMAGE] 20 ; Call to file TIU and Imaging Pointers 21 ; TIU API to add image to TIU 22 N X 23 I $P(^TIU(8925,TIUDA,0),U,2)'=$P(^MAG(2005,MAGDA,0),U,7) S MAGRY="0^Patient Mismatch." Q 24 D PUTIMAGE^TIUSRVPL(.MAGRY,TIUDA,MAGDA) ; 25 I 'MAGRY Q 26 ; Now SET the Parent fields in the Image File 27 S $P(^MAG(2005,MAGDA,2),U,6,8)=8925_U_TIUDA_U_+MAGRY 28 ; DONE. 29 S MAGRY="1^Image pointer filed successfully" 30 ; Now we save the PARENT ASSOCIATION Date/Time 31 D LINKDT^MAGGTU6(.X,MAGDA) 32 Q 33 DATA(MAGRY,TIUDA) ;RPC [MAG3 TIU DATA FROM DA] 34 ; Call to get TIU data from the TIUDA 35 ; Return = TIUDA^Document Type ^Document Date^DFN^Author DUZ 36 ; 37 S MAGRY=TIUDA_U_$$GET1^DIQ(8925,TIUDA,".01","E")_U_$$GET1^DIQ(8925,TIUDA,"1201","I")_U_$$GET1^DIQ(8925,TIUDA,".02","I")_U_$$GET1^DIQ(8925,TIUDA,"1202","I")_U 38 Q 39 IMAGES(MAGRY,TIUDA) ;RPC [MAG3 CPRS TIU NOTE] 40 ; Call to get all images for a given TIU DA 41 ; We first get all Image IEN's breaking groups into separate images 42 ; Then get Image Info for each one. 43 ; MAGRY - Return array of Image Data entries 44 ; MAGRY(0) is 1 ^ message if successful 45 ; 0 ^ Error message if error; 46 ; TIUDA is IEN in ^TIU(8925 47 ; 48 ; Call TIU API to get list of Image IEN's 49 N MAGARR,CT,TCT,I,J,Z K ^TMP($J,"MAGGX") 50 N DA,MAGQI,MAGNCHK,MAGXX,MAGRSLT 51 N TIUDFN,MAGQUIT ; MAGQI 8/22/01 52 ; MAGFILE is returned from MAGGTII 53 ; 54 S MAGQUIT=0 ; MAGQI 8/22/01 55 S TIUDFN=$P($G(^TIU(8925,TIUDA,0)),U,2) ;MAGQI 8/22/01 56 I 'TIUDFN S MAGRY(0)="0^Invalid Patient DFN for Note ID: '"_TIUDA_"'" 57 D GETILST^TIUSRVPL(.MAGARR,TIUDA) 58 S CT=0,TCT=0 59 ; Now get all images for all groups and single images. 60 S I="" F S I=$O(MAGARR(I)) Q:'I S DA=MAGARR(I) D ;Q:MAGQUIT 61 . S Z=$$ISDELIMG(DA) I Z S TCT=TCT+1,MAGRY(TCT)="B2^"_Z Q 62 . ; Check that array of images from selected TIUDA have 63 . ; same patient's and valid backward pointers 64 . I $P($G(^MAG(2005,DA,0)),U,7)'=TIUDFN S MAGQUIT=1,MAGNCHK="Patient Mismatch. TIU: "_TIUDA 65 . I $P($G(^MAG(2005,DA,2)),U,7)'=TIUDA S MAGQUIT=1,MAGNCHK="Pointer Mismatch. TIU: "_TIUDA 66 . I MAGQUIT S MAGXX=DA D INFO^MAGGTII D Q 67 . . ; remove the Abstract and Image File Names ; 2/14/03 p8t14 remove c:\program files. with .\bmp\ 68 . . S $P(MAGFILE,U,2,3)="-1~Questionable Data Integrity^.\bmp\imageQA.bmp" 69 . . ;this stops Delphi App from changing Abstract BMP to OFFLINE IMAGE 70 . . S $P(MAGFILE,U,6)=$S(($P(MAGFILE,U,6)'=11):"99",1:11) 71 . . S $P(MAGFILE,U,10)="M" 72 . . ;Send the error message 73 . . S $P(MAGFILE,U,17)=MAGNCHK 74 . . S TCT=TCT+1,MAGRY(TCT)="B2^"_MAGFILE 75 . ; 76 . I $O(^MAG(2005,DA,1,0)) D Q 77 . . ; Integrity check, if group is questionable, add it's ien to list, not it's 78 . . ; children. Later when list is looped through, it's INFO^MAGGTII will be in 79 . . ; list. Have to do this to allow other images in list from TIU to be processed. 80 . . D CHK^MAGGSQI(.MAGQI,DA) I 'MAGQI(0) S CT=CT+1,^TMP($J,"MAGGX",CT)=DA Q 81 . . S J=0 ; the following line needs to take only the first piece of the node - PMK 4/4/02 82 . . F S J=$O(^MAG(2005,DA,1,J)) Q:'J S CT=CT+1,^TMP($J,"MAGGX",CT)=$P(^(J,0),"^") 83 . S CT=CT+1 84 . S ^TMP($J,"MAGGX",CT)=DA 85 ; Now get image info for each image 86 ; 87 S Z="" 88 S MAGQUIET=1 89 F S Z=$O(^TMP($J,"MAGGX",Z)) Q:Z="" D 90 . S TCT=TCT+1,MAGXX=^TMP($J,"MAGGX",Z) 91 . ;GEK 8/24/00 Stopping the Invalid Image IEN's and Deleted Images 92 . I '$D(^MAG(2005,MAGXX)) D Q 93 . . D INVALID^MAGGTIG(MAGXX,.MAGRSLT) S MAGRY(CT)=MAGRSLT 94 . D INFO^MAGGTII 95 . S MAGRY(TCT)="B2^"_MAGFILE 96 K MAGQUIET 97 S MAGRY(0)=TCT_"^"_TCT_" Images for the selected TIU NOTE" 98 ; Put the Image IEN of the last image into the group IEN field. 99 Q:'TCT 100 S $P(MAGRY(0),U,3)=TIUDA 101 K MAGRSLT 102 D DATA(.MAGRSLT,TIUDA) 103 S $P(MAGRY(0),U,4)=$$GET1^DIQ(8925,TIUDA,".02","E")_" "_$P(MAGRSLT,U,2)_" "_$$FMTE^XLFDT($P(MAGRSLT,U,3),"8") 104 ; 105 S $P(MAGRY(0),U,5)=$S($P($G(MAGFILE),U):$P(MAGFILE,U),$G(MAGXX):MAGXX,1:0) 106 Q 107 ;. S Z=ISDELIMG(DA) I Z S TCT=TCT+1,MAGRY(TCT)="B2^"_$P(Z,U,2) Q 108 ISDELIMG(MAGIEN) ; Is this a deleted Image. 109 N MAGDEL,MAGIMG,MAGR,Z,MAGT 110 S MAGDEL=$D(^MAG(2005.1,MAGIEN)) 111 S MAGIMG=$D(^MAG(2005,MAGIEN)) 112 I MAGIMG,'MAGDEL S MAGR="0^Valid Image" 113 I 'MAGIMG,MAGDEL S MAGR="1^Deleted Image",MAGT=66 114 I 'MAGIMG,'MAGDEL S MAGR="1^Invalid Image pointer",MAGT=67 115 I MAGIMG,MAGDEL S MAGR="0^Image IEN exists, and is Deleted !" 116 I 'MAGR Q MAGR 117 S MAGR=$P(MAGR,U,2) 118 S $P(Z,U,1,4)=MAGIEN_"^-1~"_MAGR_"^-1~"_MAGR_"^"_MAGR 119 S $P(Z,U,6)=MAGT 120 ;this stops Delphi App from changing Abstract BMP to OFFLINE IMAGE 121 S $P(Z,U,10)="M" 122 ;Send the error message 123 S $P(Z,U,17)=$P(MAGR,U,2) 124 Q Z 125 ISDOCCL(MAGRY,IEN,TIUFILE,CLASS) ;RPC [MAGG IS DOC CLASS] 126 ;Checks to see if IEN of TIU Files 8925 or 8925.1 is of a certain Doc Class 127 ;MAGRY = Return String 128 ; for Success "1^message" 129 ; for Failure "0^message" 130 ;IEN = Internal Entry Number in the TIUFILE 131 ;TIUFILE = either 8925 if we need to see if a Note is of a Document Class 132 ; or 8925.1 if we need to see if a Title is of a Document Class 133 ;CLASS = Text Name of the Document Class example: "ADVANCE DIRECTIVE" 134 ; 135 S MAGRY="0^Unknown Error checking TIU Document Class" 136 K MAGTRGT,DEFIEN,DOCCL,RES,DONE,NTTL 137 S DONE=0 138 ; If we're resolving a Title 139 I TIUFILE="8925.1" D Q:DONE 140 . S DEFIEN=IEN,NTTL="Title" 141 . I '$D(^TIU(8925.1,DEFIEN,0)) S MAGRY="0^Invalid Title IEN",DONE=1 Q 142 . Q 143 ; If we're resolving a Note 144 I TIUFILE="8925" D Q:DONE 145 . S NTTL="Note" 146 . I '$D(^TIU(8925,IEN)) S MAGRY="0^Invalid Note IEN",DONE=1 Q 147 . ; Get Title IEN from Note IEN 148 . S DEFIEN=$$GET1^DIQ(8925,IEN_",",.01,"I") 149 . I DEFIEN="" S MAGRY="0^Error resolving Document Class from Note IEN" S DONE=1 Q 150 . Q 151 ; 152 ; Find the IEN in 8925.1 for Document Class (CLASS) 153 D FIND^DIC(8925.1,"","@;.001","X",CLASS,"","","I $P(^(0),U,4)=""DC""","","MAGTRGT") 154 S DOCCL=$G(MAGTRGT("DILIST",2,1)) 155 ; 156 ; See if ^TIU(8925.1,DEFIEN is of Document Class DOCCL 157 S RES=$$ISA^TIULX(DEFIEN,DOCCL) 158 I RES S MAGRY="1^The "_NTTL_" is of Document Class "_CLASS Q 159 S MAGRY="0^The "_NTTL_" is Not of Document Class "_CLASS 160 Q 1 MAGGNTI ;WOIFO/GEK - Imaging interface to TIU RPC Calls etc. ; 04 Apr 2002 2:37 PM 2 ;;3.0;IMAGING;**10,8**;Sep 15, 2004 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 Q 19 FILE(MAGRY,MAGDA,TIUDA) ;RPC [MAG3 TIU IMAGE] 20 ; Call to file TIU and Imaging Pointers 21 ; TIU API to add image to TIU 22 I $P(^TIU(8925,TIUDA,0),U,2)'=$P(^MAG(2005,MAGDA,0),U,7) S MAGRY="0^Patient Mismatch." Q 23 D PUTIMAGE^TIUSRVPL(.MAGRY,TIUDA,MAGDA) ; 24 I 'MAGRY Q 25 ; Now SET the Parent fields in the Image File 26 S $P(^MAG(2005,MAGDA,2),U,6,8)=8925_U_TIUDA_U_+MAGRY 27 ; DONE. 28 S MAGRY="1^Image pointer filed successfully" 29 Q 30 DATA(MAGRY,TIUDA) ;RPC [MAG3 TIU DATA FROM DA] 31 ; Call to get TIU data from the TIUDA 32 ; Return = TIUDA^Document Type ^Document Date^DFN 33 ; 34 S MAGRY=TIUDA_U_$$GET1^DIQ(8925,TIUDA,".01","E")_U_$$GET1^DIQ(8925,TIUDA,"1201","I")_U_$$GET1^DIQ(8925,TIUDA,".02","I") 35 Q 36 IMAGES(MAGRY,TIUDA) ;RPC [MAG3 CPRS TIU NOTE] 37 ; Call to get all images for a given TIU DA 38 ; We first get all Image IEN's breaking groups into seperate images 39 ; Then get Image Info for each one. 40 ; MAGRY - Return array of Image Data entries 41 ; MAGRY(0) is 1 ^ message if successful 42 ; 0 ^ Error message if error; 43 ; TIUDA is IEN in ^TIU(8925 44 ; 45 ; Call TIU API to get list of Image IEN's 46 N MAGARR,CT,TCT K ^TMP("MAGGX",$J) 47 N DA,MAGQI,MAGNCHK,MAGXX,MAGRSLT 48 N TIUDFN,MAGQUIT ; MAGQI 8/22/01 49 ; MAGFILE is returned from MAGGTII 50 ; 51 S MAGQUIT=0 ; MAGQI 8/22/01 52 S TIUDFN=$P($G(^TIU(8925,TIUDA,0)),U,2) ;MAGQI 8/22/01 53 I 'TIUDFN S MAGRY(0)="0^Invalid Patient DFN for Note ID: '"_TIUDA_"'" 54 D GETILST^TIUSRVPL(.MAGARR,TIUDA) 55 S CT=0,TCT=0 56 ; Now get all images for all groups and single images. 57 S I="" F S I=$O(MAGARR(I)) Q:'I S DA=MAGARR(I) D ;Q:MAGQUIT 58 . S Z=$$ISDELIMG(DA) I Z S TCT=TCT+1,MAGRY(TCT)="B2^"_Z Q 59 . ; Check that array of images from selected TIUDA have 60 . ; same patient's and valid backward pointers 61 . I $P($G(^MAG(2005,DA,0)),U,7)'=TIUDFN S MAGQUIT=1,MAGNCHK="Patient Mismatch. TIU: "_TIUDA 62 . I $P($G(^MAG(2005,DA,2)),U,7)'=TIUDA S MAGQUIT=1,MAGNCHK="Pointer Mismatch. TIU: "_TIUDA 63 . I MAGQUIT S MAGXX=DA D INFO^MAGGTII D Q 64 . . ; remove the Abstract and Image File Names ; 2/14/03 p8t14 remove c:\program files. with .\bmp\ 65 . . S $P(MAGFILE,U,2,3)="-1~Questionable Data Integrity^.\bmp\imageQA.bmp" 66 . . ;this stops Delphi App from changing Abstract BMP to OFFLINE IMAGE 67 . . S $P(MAGFILE,U,6)=$S(($P(MAGFILE,U,6)'=11):"99",1:11) 68 . . S $P(MAGFILE,U,10)="M" 69 . . ;Send the error message 70 . . S $P(MAGFILE,U,17)=MAGNCHK 71 . . S TCT=TCT+1,MAGRY(TCT)="B2^"_MAGFILE 72 . ; 73 . I $O(^MAG(2005,DA,1,0)) D Q 74 . . ; Integrity check, if group is questionable, add it's ien to list, not it's 75 . . ; children. Later when list is looped through, it's INFO^MAGGTII will be in 76 . . ; list. Have to do this to allow other images in list from TIU to be processed. 77 . . D CHK^MAGGSQI(.MAGQI,DA) I 'MAGQI(0) S CT=CT+1,^TMP("MAGGX",$J,CT)=DA Q 78 . . S J=0 ; the following line needs to take only the first piece of the node - PMK 4/4/02 79 . . F S J=$O(^MAG(2005,DA,1,J)) Q:'J S CT=CT+1,^TMP("MAGGX",$J,CT)=$P(^(J,0),"^") 80 . S CT=CT+1 81 . S ^TMP("MAGGX",$J,CT)=DA 82 ; Now get image info for each image 83 ; 84 S Z="" 85 S MAGQUIET=1 86 F S Z=$O(^TMP("MAGGX",$J,Z)) Q:Z="" D 87 . S TCT=TCT+1,MAGXX=^TMP("MAGGX",$J,Z) 88 . ;GEK 8/24/00 Stoping the Invalid Image IEN's and Deleted Images 89 . I '$D(^MAG(2005,MAGXX)) D Q 90 . . D INVALID^MAGGTIG(MAGXX,.MAGRSLT) S MAGRY(CT)=MAGRSLT 91 . D INFO^MAGGTII 92 . S MAGRY(TCT)="B2^"_MAGFILE 93 K MAGQUIET 94 S MAGRY(0)=TCT_"^"_TCT_" Images for the selected TIU NOTE" 95 ; PUT THE Image IEN of the last image into the group ien field. 96 Q:'TCT 97 S $P(MAGRY(0),U,3)=TIUDA 98 K MAGRSLT 99 D DATA(.MAGRSLT,TIUDA) 100 S $P(MAGRY(0),U,4)=$$GET1^DIQ(8925,TIUDA,".02","E")_" "_$P(MAGRSLT,U,2)_" "_$$FMTE^XLFDT($P(MAGRSLT,U,3),"8") 101 ; 102 S $P(MAGRY(0),U,5)=$S($P($G(MAGFILE),U):$P(MAGFILE,U),1:MAGXX) 103 Q 104 ;. S Z=ISDELIMG(DA) I Z S TCT=TCT+1,MAGRY(TCT)="B2^"_$P(Z,U,2) Q 105 ISDELIMG(MAGIEN) ; Is this a deleted Image. 106 N MAGDEL,MAGIMG,MAGR,Z,MAGT 107 S MAGDEL=$D(^MAG(2005.1,MAGIEN)) 108 S MAGIMG=$D(^MAG(2005,MAGIEN)) 109 I MAGIMG,'MAGDEL S MAGR="0^Valid Image" 110 I 'MAGIMG,MAGDEL S MAGR="1^Deleted Image",MAGT=66 111 I 'MAGIMG,'MAGDEL S MAGR="1^Invalid Image pointer",MAGT=67 112 I MAGIMG,MAGDEL S MAGR="0^Image IEN exists, and is Deleted !" 113 I 'MAGR Q MAGR 114 S MAGR=$P(MAGR,U,2) 115 S $P(Z,U,1,4)=MAGIEN_"^-1~"_MAGR_"^-1~"_MAGR_"^"_MAGR 116 S $P(Z,U,6)=MAGT 117 ;this stops Delphi App from changing Abstract BMP to OFFLINE IMAGE 118 S $P(Z,U,10)="M" 119 ;Send the error message 120 S $P(Z,U,17)=$P(MAGR,U,2) 121 Q Z -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGNTI1.m
r613 r623 1 MAGGNTI1 ;WOIFO/GEK - Imaging interface to TIU. RPC Calls etc. ; 04 Apr 2002 2:37 PM 2 ;;3.0;IMAGING;**46,59**;Nov 27, 2007;Build 20 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 NEW(MAGRY,MAGDFN,MAGTITLE,MAGADCL,MAGMODE,MAGES,MAGESBY,MAGLOC,MAGDATE,MAGCNSLT,MAGTEXT) ;RPC [MAG3 TIU NEW] 21 ; 22 ; RPC call to create a New Note 23 ; and Optionally : 24 ; Electronically Sign, 25 ; Administratively Close 26 ; or Add Text to the Note. 27 ; 28 ; - - - Required - - - 29 ; MAGDFN - Patient DFN 30 ; MAGTITLE - IEN of TIU Document Title in file 8925.1 31 ; - - - Optional - - - 32 ; Use DUZ for TIUAUTH 33 ; Use NOW for TIURDT 34 ; MAGTEXT - Array of Text to add to the New Note. 35 ; MAGLOC - IEN in Hospital Location File 44 36 ; MAGES - The encrypted Electronic Signature 37 ; MAGESBY - The DUZ of the Signer (Defaults to DUZ) 38 ; MAGADCL - 1 = Mark this Note as Administratively Closed 39 ; MAGMODE - Mode of Admin Closure: "S" = Scanned Document 40 ; "M" = Manual closure, "E" = Electronically Filed 41 ; MAGDATE - Date of the Note. For New Notes. 42 ; MAGCNSLT - DA of Consult to Link to. 43 ; 44 N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) 45 S MAGDFN=$G(MAGDFN),MAGTITLE=$G(MAGTITLE),MAGLOC=$G(MAGLOC) 46 S MAGES=$G(MAGES),MAGADCL=$G(MAGADCL) 47 S MAGESBY=$S($G(MAGESBY):MAGESBY,1:DUZ) 48 S MAGMODE=$S($L($G(MAGMODE)):MAGMODE,1:"S") 49 S MAGDATE=$G(MAGDATE),MAGCNSLT=$G(MAGCNSLT) 50 N MAGTIUDA,I,NODE,MAGTY,ISVAL,MAGISC,MTXT,MUPD,MAGX,MAGVSTR,MAGTIUX 51 ; 52 ; MAGMODE is only sent if Admin Closure is wanted. 53 I (MAGMODE="S") S MAGTEXT(.1)=" VistA Imaging - Scanned Document" 54 I (MAGMODE="M") S MAGTEXT(.1)=" VistA Imaging - Manual Closure" 55 I "MSE"'[MAGMODE S MAGRY="0^Invalid Mode of Closure: """_MAGMODE_"""" Q 56 ; 57 ; Here if we have no Text, we'll add at least a line. 58 I $O(MAGTEXT(""))="" S MAGTEXT(.1)=" VistA Imaging - - Scanned Document" 59 ; Reformat Text - "TEXT",i,0)" for TIU Call. 60 S I="",NODE=0 61 F S I=$O(MAGTEXT(I)) Q:I="" D 62 . S NODE=NODE+1 S MAGTIUX("TEXT",NODE,0)=MAGTEXT(I) 63 . Q 64 ; validate the DFN 65 I '$D(^DPT(+MAGDFN,0)) S MAGRY="0^Invalid data: Patient DFN is invalid" Q 66 ; validate the User 67 I '$D(^VA(200,MAGESBY,0)) S MAGRY="0^Invalid data: Author DUZ is invalid" Q 68 ; validate the TIU TITLE 69 I '$D(^TIU(8925.1,MAGTITLE,0)) S MAGRY="0^Invalid data: Note TITLE is invalid" Q 70 ; validate Esig first, if caller wants to also mark this Note as Signed 71 I +$G(MAGES) I '$$VALES^MAGGNTI2(MAGES) S MAGRY="0^Invalid data: E-sign is invalid" Q 72 ; validate the Date MAGDATE is changed to INternal if it is valid. 73 I +$L(MAGDATE) I '$$VALID^MAGGSIV1(8925,1301,.MAGDATE,.MAGX) S MAGRY="0^"_MAGX Q 74 I '$L(MAGDATE) S MAGDATE=$$NOW^XLFDT 75 ; LINK TO CONSULT 76 ; can user create Notes with This Title 77 I '$$CANENTR^TIULP(MAGTITLE) S MAGRY="0^You need privileges to enter notes of that Title" Q 78 ; 79 D ISCNSLT^TIUCNSLT(.MAGISC,MAGTITLE) 80 I MAGISC D I 'MAGISC S MAGRY=MAGISC Q 81 . ; See if a Consult DA was sent. 82 . IF 'MAGCNSLT S MAGISC="0^A Consult is needed to link to this note title" 83 . Q 84 I ('MAGISC)&(MAGCNSLT) S MAGRY="0^Cannot Link Consult with a Non Consult Title" Q 85 ; 86 ; make a VSTR for TIU Call. 87 S MAGVSTR=MAGLOC_";"_MAGDATE_";E" 88 ; 89 ; Call to NEW^TIUPNAPI wasn't doing what we needed. Now call TIU CREATE RECORD 90 ; MAKE(SUCCESS,DFN,TITLE,VDT,VLOC,VSIT,TIUX,VSTR,SUPPRESS,NOASF) 91 D MAKE^TIUSRVP(.MAGTIUDA,MAGDFN,MAGTITLE,"",MAGLOC,"",.MAGTIUX,MAGVSTR) 92 I 'MAGTIUDA!(MAGTIUDA=-1) S MAGRY="0^Error creating Note"_$G(MAGTIUDA) Q 93 S MAGRY=MAGTIUDA_"^Note was created." 94 S MAGTY=MAGRY 95 ; 96 ; ;Put in the Date that was sent. 97 I '$$VALID^MAGGSIV1(8925,1301,.MAGDATE,.MAGRES) S MAGRY=MAGRY_" "_MAGRES 98 E S MTXT(1301)=MAGDATE 99 ; - Fix in T30, if DUZ isn't MAGESBY, we have Author different than User. 100 I MAGESBY'=DUZ S MTXT("1202")=MAGESBY 101 ; Update and LINK TO CONSULT if needed. 102 I MAGISC S MTXT("1405")=MAGCNSLT_";GMR(123," 103 I $D(MTXT) D I 'MUPD S MAGRY=MUPD Q 104 . D UPDATE^TIUSRVP(.MUPD,MAGTIUDA,.MTXT) 105 . Q 106 ; 107 ; If Admin Close, then We quit. 108 I MAGADCL="1" D Q 109 . D ADMNCLOS^MAGGNTI2(.MAGTY,MAGDFN,MAGTIUDA,MAGMODE) 110 . S MAGRY=$S('MAGTY:MAGTY,1:MAGRY_" Administrative Closure.") 111 . Q 112 ; 113 ; if caller sent esignature to Sign this Note. 114 I $L(MAGES) D 115 . D SIGN^MAGGNTI3(.MAGTY,MAGDFN,MAGTIUDA,MAGES,MAGESBY) 116 . S MAGRY=$S('MAGTY:MAGTY,1:MAGRY_" Signed.") 117 . Q 118 Q 119 ; 120 ;(MAGRY,MAGDFN,MAGTITLE,MAGADCL,MAGMODE,MAGES,MAGESBY,MAGLOC,MAGTEXT) 121 NEWADD(MAGRY,MAGDFN,MAGTIUDA,MAGADCL,MAGMODE,MAGES,MAGESBY,MAGDATE,MAGTEXT) ; RPC [MAG3 TIU CREATE ADDENDUM] 122 ; RPC call to create an Addendum to a Note 123 ; and Optionally : 124 ; Electronically Sign, 125 ; Administratively Close, 126 ; or Add Text to the Addendum 127 ; 128 ; - - - Required - - - 129 ; MAGDFN - Patient DFN 130 ; MAGTIUDA - IEN of TIU NOTE in file 8925 131 ; - - - Optional - - - 132 ; MAGTEXT - Array of Text to add to the New Note. 133 ; MAGES - The encrypted Electronic Signature 134 ; MAGESBY - The DUZ of the Signer (Defaults to DUZ) 135 ; MAGADCL - 1 = Mark this Note as Administratively Closed 136 ; MAGMODE - Mode of Admin Closure: "S" = Scanned Document "M" = Manual closure "E" = Electronically Filed 137 ; MAGDATE - Date of the Addendum. 138 ; 139 N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) 140 S MAGDFN=$G(MAGDFN),MAGTIUDA=$G(MAGTIUDA),MAGES=$G(MAGES),MAGADCL=$G(MAGADCL) 141 S MAGESBY=$S($G(MAGESBY):MAGESBY,1:DUZ),MAGMODE=$S($L($G(MAGMODE)):MAGMODE,1:"S") 142 S MAGDATE=$G(MAGDATE) 143 ; 144 I '$$VALDATA^MAGGNTI2(.MAGRY,MAGDFN,MAGTIUDA) Q 145 N MAGXT,I,CT,NEWTIUDA,MAGY,MAGRES,MAGUPD 146 S CT=1,I="" 147 S MAGXT("TEXT",1,0)="VistA Imaging Scanned Document - Addendum." 148 I $D(MAGTEXT) F S I=$O(MAGTEXT(I)) Q:I="" D 149 . S CT=CT+1,MAGXT("TEXT",CT,0)=MAGTEXT(I) 150 . Q 151 ; 152 ; Calling TIU CREATE ADDENDUM RECORD 153 D MAKEADD^TIUSRVP(.MAGRY,MAGTIUDA,.MAGXT) 154 ; MAGRY could be 0^error message 155 ; -1^message 156 ; TIUDA 157 I $P(MAGRY,"^")<0 S $P(MAGRY,"^")=0 Q 158 S NEWTIUDA=+MAGRY 159 S MAGRY=MAGRY_"^Addendum was created." 160 ; 161 ;Put in the Date that was sent. 162 K MAGUPD 163 I '$$VALID^MAGGSIV1(8925,1301,.MAGDATE,.MAGRES) S MAGRY=MAGRY_" "_MAGRES 164 E D 165 . S MAGUPD(1301)=MAGDATE 166 . S MAGUPD(1211)=$$GET1^DIQ(8925,1211,MAGTIUDA,"I") 167 ; - Fix in T30, if DUZ isn't MAGESBY, we have Author different than User. 168 I MAGESBY'=DUZ S MAGUPD("1202")=MAGESBY 169 I $D(MAGUPD) D 170 . D UPDATE^TIUSRVP(.MAGY,NEWTIUDA,.MAGUPD) 171 . I 'MAGY S MAGRY=MAGRY_" TIU Data was Not Correctly Filed." 172 . Q 173 ; 174 ; if caller sent esignature to Sign this Addendum. 175 I $L(MAGES) D Q 176 . D SIGN^MAGGNTI3(.MAGTY,MAGDFN,NEWTIUDA,MAGES,MAGESBY) 177 . S MAGRY=$S('MAGTY:MAGTY,1:MAGRY_" Signed.") 178 . Q 179 ; 180 ; if caller wants to Admin Close this Addendum. 181 I MAGADCL="1" D Q 182 . D ADMNCLOS^MAGGNTI2(.MAGTY,MAGDFN,NEWTIUDA,MAGMODE) 183 . S MAGRY=$S('MAGTY:MAGTY,1:MAGRY_" Administrative Closure.") 184 . Q 185 Q 186 MOD(MAGRY,MAGDFN,MAGTIUDA,MAGADCL,MAGMODE,MAGES,MAGESBY,MAGTEXT) ; RPC [MAG3 TIU MODIFY NOTE] 187 ; After a Note is filed, we call this to Modify the Note. We do this to sign it. 188 ; That way the Signed Date is After the Image Association Date/Time. 189 N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) 190 S MAGDFN=$G(MAGDFN),MAGTIUDA=$G(MAGTIUDA) 191 S MAGADCL=$G(MAGADCL) 192 S MAGMODE=$S($L($G(MAGMODE)):MAGMODE,1:"S") 193 S MAGES=$G(MAGES) 194 S MAGESBY=$S($G(MAGESBY):MAGESBY,1:DUZ) 195 D MOD^MAGGNTI3(.MAGRY,MAGDFN,MAGTIUDA,MAGADCL,MAGMODE,MAGES,MAGESBY) 196 Q 197 ERR ; ERROR TRAP 198 N ERR S ERR=$$EC^%ZOSV 199 S MAGRY="0^ETRAP: "_ERR 200 D @^%ZOSF("ERRTN") 201 Q 202 SIGN(MAGRY,MAGDFN,MAGTIUDA,MAGES,MAGESBY) ;RPC [MAG3 TIU SIGN RECORD] 203 ; RPC Call to 'Sign' a Note. 204 D SIGN^MAGGNTI3(.MAGRY,$G(MAGDFN),$G(MAGTIUDA),$G(MAGES),$G(MAGESBY)) 205 Q 1 MAGGNTI1 ;WOIFO/GEK - Imaging interface to TIU RPC Calls etc. ; 20 Nov 2006 12:42 PM 2 ;;3.0;IMAGING;**46**;16-February-2007;;Build 1023 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 ;; | 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 Q 19 NEW(MAGRY,MAGDFN,MAGTITLE,MAGADCL,MAGMODE,MAGES,MAGESBY,MAGLOC,MAGDATE,MAGCNSLT,MAGTEXT) ;RPC [MAG3 TIU NEW] 20 ; 21 ; RPC call to create a New Note 22 ; and Optionally : 23 ; Electronically Sign, 24 ; Administratively Close 25 ; or Add Text to the Note. 26 ; 27 ; - - - Required - - - 28 ; MAGDFN - Patient DFN 29 ; MAGTITLE - IEN of TIU Document Title in file 8925.1 30 ; - - - Optional - - - 31 ; Use DUZ for TIUAUTH 32 ; Use NOW for TIURDT 33 ; MAGTEXT - Array of Text to add to the New Note. 34 ; MAGLOC - IEN in Hospital Location File 44 35 ; MAGES - The encrypted Electronic Signature 36 ; MAGESBY - The DUZ of the Signer (Defaults to DUZ) 37 ; MAGADCL - 1 = Mark this Note as Administratively Closed 38 ; MAGMODE - Mode of Admin Closure: "S" = Scanned Document 39 ; "M" = Manual closure, "E" = Electronically Filed 40 ; MAGDATE - Date of the Note. For New Notes. 41 ; MAGCNSLT - DA of Consult to Link to. 42 ; 43 N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) 44 S MAGDFN=$G(MAGDFN),MAGTITLE=$G(MAGTITLE),MAGLOC=$G(MAGLOC) 45 S MAGES=$G(MAGES),MAGADCL=$G(MAGADCL) 46 S MAGESBY=$S($G(MAGESBY):MAGESBY,1:DUZ) 47 S MAGMODE=$S($L($G(MAGMODE)):MAGMODE,1:"S") 48 S MAGDATE=$G(MAGDATE),MAGCNSLT=$G(MAGCNSLT) 49 N MAGTIUDA,I,NODE,MAGTY,ISVAL,MAGISC,MTXT,MUPD,MAGX,MAGVSTR,MAGTIUX 50 ; 51 ; MAGMODE is only sent if Admin Closure is wanted. 52 I (MAGMODE="S") S MAGTEXT(.1)=" VistA Imaging - Scanned Document" 53 I (MAGMODE="M") S MAGTEXT(.1)=" VistA Imaging - Manual Closure" 54 I "MSE"'[MAGMODE S MAGRY="0^Invalid Mode of Closure: """_MAGMODE_"""" Q 55 ; 56 ; Here if we have no Text, we'll add at least a line. 57 I $O(MAGTEXT(""))="" S MAGTEXT(.1)=" VistA Imaging - - Scanned Document" 58 ; Reformat Text - "TEXT",i,0)" for TIU Call. 59 S I="",NODE=0 60 F S I=$O(MAGTEXT(I)) Q:I="" D 61 . S NODE=NODE+1 S MAGTIUX("TEXT",NODE,0)=MAGTEXT(I) 62 . Q 63 ; validate the DFN 64 I '$D(^DPT(+MAGDFN,0)) S MAGRY="0^Invalid data: Patient DFN is invalid" Q 65 ; validate the User 66 I '$D(^VA(200,MAGESBY,0)) S MAGRY="0^Invalid data: Author DUZ is invalid" Q 67 ; validate the TIU TITLE 68 I '$D(^TIU(8925.1,MAGTITLE,0)) S MAGRY="0^Invalid data: Note TITLE is invalid" Q 69 ; validate Esig first, if caller wants to also mark this Note as Signed 70 I +$G(MAGES) I '$$VALES^MAGGNTI2(MAGES) S MAGRY="0^Invalid data: E-sign is invalid" Q 71 ; validate the Date MAGDATE is changed to INternal if it is valid. 72 I +$L(MAGDATE) I '$$VALID^MAGGSIV1(8925,1301,.MAGDATE,.MAGX) S MAGRY="0^"_MAGX Q 73 I '$L(MAGDATE) S MAGDATE=$$NOW^XLFDT 74 ; LINK TO CONSULT 75 ; can user create Notes with This Title 76 I '$$CANENTR^TIULP(MAGTITLE) S MAGRY="0^You need privileges to enter notes of that Title" Q 77 ; 78 D ISCNSLT^TIUCNSLT(.MAGISC,MAGTITLE) 79 I MAGISC D I 'MAGISC S MAGRY=MAGISC Q 80 . ; See if a Consult DA was sent. 81 . IF 'MAGCNSLT S MAGISC="0^A Consult is needed to link to this note title" 82 . Q 83 I ('MAGISC)&(MAGCNSLT) S MAGRY="0^Cannot Link Consult with a Non Consult Title" Q 84 ; 85 ; make a VSTR for TIU Call. 86 S MAGVSTR=MAGLOC_";"_MAGDATE_";E" 87 ; 88 ; Call to NEW^TIUPNAPI wasn't doing what we needed. Now call TIU CREATE RECORD 89 ; MAKE(SUCCESS,DFN,TITLE,VDT,VLOC,VSIT,TIUX,VSTR,SUPPRESS,NOASF) 90 D MAKE^TIUSRVP(.MAGTIUDA,MAGDFN,MAGTITLE,"",MAGLOC,"",.MAGTIUX,MAGVSTR) 91 I 'MAGTIUDA!(MAGTIUDA=-1) S MAGRY="0^Error creating Note"_$G(MAGTIUDA) Q 92 S MAGRY=MAGTIUDA_"^Note was created." 93 S MAGTY=MAGRY 94 ; 95 ; ;Put in the Date that was sent. 96 I '$$VALID^MAGGSIV1(8925,1301,.MAGDATE,.MAGRES) S MAGRY=MAGRY_" "_MAGRES 97 E S MTXT(1301)=MAGDATE 98 ; 99 ; Update and LINK TO CONSULT if needed. 100 I MAGISC S MTXT("1405")=MAGCNSLT_";GMR(123," 101 I $D(MTXT) D I 'MUPD S MAGRY=MUPD Q 102 . D UPDATE^TIUSRVP(.MUPD,MAGTIUDA,.MTXT) 103 . Q 104 ; 105 ; If Admin Close, then We quit. 106 I MAGADCL="1" D Q 107 . D ADMNCLOS^MAGGNTI2(.MAGTY,MAGDFN,MAGTIUDA,MAGMODE) 108 . S MAGRY=$S('MAGTY:MAGTY,1:MAGRY_" Administrative Closure.") 109 . Q 110 ; 111 ; if caller sent esignature to Sign this Note. 112 I $L(MAGES) D 113 . D SIGN^MAGGNTI3(.MAGTY,MAGDFN,MAGTIUDA,MAGES,MAGESBY) 114 . S MAGRY=$S('MAGTY:MAGTY,1:MAGRY_" Signed.") 115 . Q 116 Q 117 ; 118 ;(MAGRY,MAGDFN,MAGTITLE,MAGADCL,MAGMODE,MAGES,MAGESBY,MAGLOC,MAGTEXT) 119 NEWADD(MAGRY,MAGDFN,MAGTIUDA,MAGADCL,MAGMODE,MAGES,MAGESBY,MAGDATE,MAGTEXT) ; RPC [MAG3 TIU CREATE ADDENDUM] 120 ; RPC call to create an Addendum to a Note 121 ; and Optionally : 122 ; Electronically Sign, 123 ; Administratively Close, 124 ; or Add Text to the Addendum 125 ; 126 ; - - - Required - - - 127 ; MAGDFN - Patient DFN 128 ; MAGTIUDA - IEN of TIU NOTE in file 8925 129 ; - - - Optional - - - 130 ; MAGTEXT - Array of Text to add to the New Note. 131 ; MAGES - The encrypted Electronic Signature 132 ; MAGESBY - The DUZ of the Signer (Defaults to DUZ) 133 ; MAGADCL - 1 = Mark this Note as Administratively Closed 134 ; MAGMODE - Mode of Admin Closure: "S" = Scanned Document "M" = Manual closure "E" = Electronically Filed 135 ; MAGDATE - Date of the Addendum. 136 ; 137 N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) 138 S MAGDFN=$G(MAGDFN),MAGTIUDA=$G(MAGTIUDA),MAGES=$G(MAGES),MAGADCL=$G(MAGADCL) 139 S MAGESBY=$S($G(MAGESBY):MAGESBY,1:DUZ),MAGMODE=$S($L($G(MAGMODE)):MAGMODE,1:"S") 140 S MAGDATE=$G(MAGDATE) 141 ; 142 I '$$VALDATA^MAGGNTI2(.MAGRY,MAGDFN,MAGTIUDA) Q 143 N MAGXT,I,CT,NEWTIUDA,MAGY,MAGRES 144 S CT=1,I="" 145 S MAGXT("TEXT",1,0)="VistA Imaging Scanned Document - Addendum." 146 I $D(MAGTEXT) F S I=$O(MAGTEXT(I)) Q:I="" D 147 . S CT=CT+1,MAGXT("TEXT",CT,0)=MAGTEXT(I) 148 . Q 149 ; 150 ; Calling TIU CREATE ADDENDUM RECORD 151 D MAKEADD^TIUSRVP(.MAGRY,MAGTIUDA,.MAGXT) 152 ; MAGRY could be 0^error message 153 ; -1^message 154 ; TIUDA 155 I $P(MAGRY,"^")<0 S $P(MAGRY,"^")=0 Q 156 S NEWTIUDA=+MAGRY 157 S MAGRY=MAGRY_"^Addendum was created." 158 ; 159 ;Put in the Date that was sent. 160 I '$$VALID^MAGGSIV1(8925,1301,.MAGDATE,.MAGRES) S MAGRY=MAGRY_" "_MAGRES 161 E D 162 . K X 163 . S X(1301)=MAGDATE 164 . S X(1211)=$$GET1^DIQ(8925,1211,MAGTIUDA,"I") 165 . D UPDATE^TIUSRVP(.MAGY,NEWTIUDA,.X) 166 . I 'MAGY S MAGRY=MAGRY_" TIU Data was Not Correctly Filed." 167 . Q 168 ; 169 ; if caller sent esignature to Sign this Addendum. 170 I $L(MAGES) D Q 171 . D SIGN^MAGGNTI3(.MAGTY,MAGDFN,NEWTIUDA,MAGES,MAGESBY) 172 . S MAGRY=$S('MAGTY:MAGTY,1:MAGRY_" Signed.") 173 . Q 174 ; 175 ; if caller wants to Admin Close this Addendum. 176 I MAGADCL="1" D Q 177 . D ADMNCLOS^MAGGNTI2(.MAGTY,MAGDFN,NEWTIUDA,MAGMODE) 178 . S MAGRY=$S('MAGTY:MAGTY,1:MAGRY_" Administrative Closure.") 179 . Q 180 Q 181 MOD(MAGRY,MAGDFN,MAGTIUDA,MAGADCL,MAGMODE,MAGES,MAGESBY,MAGTEXT) ; RPC [MAG3 TIU MODIFY NOTE] 182 N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) 183 S MAGDFN=$G(MAGDFN),MAGTIUDA=$G(MAGTIUDA) 184 S MAGADCL=$G(MAGADCL) 185 S MAGMODE=$S($L($G(MAGMODE)):MAGMODE,1:"S") 186 S MAGES=$G(MAGES) 187 S MAGESBY=$S($G(MAGESBY):MAGESBY,1:DUZ) 188 D MOD^MAGGNTI3(.MAGRY,MAGDFN,MAGTIUDA,MAGADCL,MAGMODE,MAGES,MAGESBY) 189 Q 190 ERR ; ERROR TRAP 191 N ERR S ERR=$$EC^%ZOSV 192 S MAGRY="0^ETRAP: "_ERR 193 D @^%ZOSF("ERRTN") 194 Q 195 SIGN(MAGRY,MAGDFN,MAGTIUDA,MAGES,MAGESBY) ;RPC [MAG3 TIU SIGN RECORD] 196 ; RPC Call to 'Sign' a Note. 197 D SIGN^MAGGNTI3(.MAGRY,$G(MAGDFN),$G(MAGTIUDA),$G(MAGES),$G(MAGESBY)) 198 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGNTI2.m
r613 r623 1 MAGGNTI2 ;WOIFO/GEK - Imaging interface to TIU. RPC Calls etc. ; 04 Apr 2002 2:37PM2 ;;3.0;IMAGING;**46,59**;Nov 27, 2007;Build 20 3 ;;Per VHA Directive 2004-038, this routine should not be modified.4 5 ;; | Property of the US Government.|6 7 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 13 14 15 ;; | to be a violation of US Federal Statutes.|16 17 ;; 18 19 LIST(MAGRY,CLASS,MYLIST) 20 21 22 23 24 25 26 27 28 ; Note : sending CLASS IEN isn't used in p59.29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 MYLIST(CLN,TARR) 76 77 78 79 80 BLDLIST(CLN,TARR,STC,UPDN) 81 82 83 84 85 86 ADMNCLOS(MAGRY,MAGDFN,MAGTIUDA,MAGMODE) 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 VALES(X) 106 107 108 109 110 VALDATA(RY,MAGDFN,MAGTIUDA) 111 112 113 114 115 116 117 118 1 MAGGNTI2 ;WOIFO/GEK - Imaging interface to TIU RPC Calls etc. ; 20 Nov 2006 12:18 PM 2 ;;3.0;IMAGING;**46**;16-February-2007;;Build 1023 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 ;; | 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 Q 19 LIST(MAGRY,CLASS,MYLIST) ; RPC [MAG3 TIU LONG LIST OF TITLES] 20 ; Get a list of Document Titles 21 ; CLASS = ("," delimited string of one or More of) "NOTE,DS,CONS,CP,SUR,<CLASS IEN>" 22 ; CLASS IEN is any IEN of TIU 8925.1 that is a Class 23 ; "|" delimited string of Class| text | Direction 24 ; MYLIST = [1|""] optional 25 ; If MYLIST=1 then return 26 ; TIU PERSONAL TITLE LIST PERSLIST^TIUSRVD 27 ; 28 ; Note : sending CLASS IEN isn't tested. 29 ; 30 K MAGRY 31 ; was a Global, now leave it an Array, only getting 44 32 N I,T,CL,CLN,CLNOTE,CLDS,CLCP,CLCONS,CLSUR,IL,J,TX,TXC,TX2,TX1,DFLT 33 N INTXT,UPDN,TARR 34 S MYLIST=$G(MYLIST) 35 S INTXT=$P(CLASS,"|",2) 36 S UPDN=$S(+$P(CLASS,"|",3):+$P(CLASS,"|",3),1:1) 37 S CLASS=$P(CLASS,"|",1) 38 I $L(CLASS)=0 S MAGRY(0)="0^Invalid Selection Class." Q 39 S CLNOTE=3 ; It is hard coded in TIU code. Note Class 40 S CLDS=244 ; It is hard coded in TIU code. Discharge Summary Class 41 D CPCLASS^TIUCP(.CLCP) 42 D CNSLCLAS^TIUSRVD(.CLCONS) 43 D SURGCLAS^TIUSRVD(.CLSUR) 44 S MAGRY(0)="0^Error: While accessing a list of Note Titles." 45 S MAGRY(1)="key word^TITLE^CLASS" 46 S I="" 47 F I=1:1:$L(CLASS,",") D 48 . S CL=$P(CLASS,",",I) 49 . S CLN=$S(+CL:+CL,CL="NOTE":3,CL="DS":CLDS,CL="CP":CLCP,CL="CONS":CLCONS,CL="SUR":CLSUR,1:-1) 50 . I MYLIST D Q 51 . . D MYLIST(CLN,.TARR) 52 . . I $O(TARR(""))'="" S MAGRY(0)="1^Personal List" 53 . . S J="" F S J=$O(TARR(J)) Q:J="" D 54 . . . S TX1=$P(TARR(J),"^",1) 55 . . . ; output has 'd' or 'i' as first character, we need to get rid of it. 56 . . . I $E(TX1)="d" S DFLT=$E(TX1,2,999),MAGRY(0)=DFLT_"^Personal list" 57 . . . S TX1=$E(TX1,2,999) 58 . . . S TX=$P(TARR(J),"^",2),TX2=$P(TX,"<",2) S:$L(TX2) TX=$P(TX,"<",1) S:$L(TX2) TX2="<"_TX2 59 . . . S MAGRY($O(MAGRY(""),-1)+1)=TX_"^"_TX2_"^"_CL_"|"_TX1 60 . . . Q 61 . . Q 62 . ; here add line as a break between Personal List and Start of Total List 63 . K TARR 64 . D BLDLIST(CLN,.TARR,INTXT,UPDN) 65 . S J="" F S J=$O(TARR(J)) Q:J="" D 66 . . S TX=$P(TARR(J),"^",2),TX2=$P(TX,"<",2) S:$L(TX2) TX=$P(TX,"<",1) S:$L(TX2) TX2="<"_TX2 67 . . S TX1=$P(TARR(J),"^",1) 68 . . S MAGRY($O(MAGRY(""),-1)+1)=TX_"^"_TX2_"^"_CL_"|"_TX1 69 . . Q 70 . Q 71 I '$D(MAGRY(2)) K MAGRY(1) S MAGRY(0)="0^0 Items match input: "_INTXT 72 E S MAGRY(0)="1^Success"_"^"_$G(DFLT)_"^" 73 Q 74 ; 75 MYLIST(CLN,TARR) ; 76 ; if not short list, default is listed twice, (This is how CPRS displays it) 77 K TARR 78 D PERSLIST^TIUSRVD(.TARR,DUZ,CLN) 79 Q 80 BLDLIST(CLN,TARR,STC,UPDN) ; 81 ; 82 S UPDN=$S(+$G(UPDN):+$G(UPDN),1:1) 83 K TARR 84 D LONGLIST^TIUSRVD(.TARR,CLN,STC,UPDN) 85 Q 86 ADMNCLOS(MAGRY,MAGDFN,MAGTIUDA,MAGMODE) ; calls TIU API to set as Admin Closed. 87 ; RPC Call to Administratively Close a TIU Note. 88 ; - - - Required - - - 89 ; MAGDFN - Patient DFN 90 ; MAGTIUDA - Note IEN in File 8925 91 ; - - - Optional - - - 92 ; MAGMODE - "S" Scanned Document "M" - Manual closure "E" - Electronically Filed. 93 ; 94 S MAGDFN=$G(MAGDFN),MAGTIUDA=$G(MAGTIUDA),MAGMODE=$G(MAGMODE,"S") 95 I '$$VALDATA(.MAGRY,MAGDFN,MAGTIUDA) Q 96 ; Calling TIU SET ADMINISTRATIVE CLOSURE 97 ; MAGMODE can be "S" for SCANNED DOCUMENT <- HIMS may get this changed 98 ; to Electronically Filed. 99 ; or "M" for MANUAL CLOSURE or "E" for ELECTONICALL FILE 100 D ADMNCLOS^TIUSRVPT(.MAGRY,MAGTIUDA,MAGMODE) 101 ; on success MAGRY = MAGTIUDA 102 ; on error MAGRY = 0^<message> 103 I MAGRY S MAGRY=MAGRY_"^Success: Administrative Closure." 104 Q 105 VALES(X) ; Validate the esig 106 N MAGY S MAGY=0 107 D HASH^XUSHSHP 108 I X]"",(X=$P($G(^VA(200,+DUZ,20)),U,4)) S MAGY=1 109 Q MAGY 110 VALDATA(RY,MAGDFN,MAGTIUDA) ; Validate the TIUDA and the DFN 111 S MAGTIUDA=$G(MAGTIUDA),MAGDFN=$G(MAGDFN) 112 I 'MAGDFN S RY="0^Invalid data: Patient DFN invalid: "_MAGDFN Q 0 113 I '$D(^DPT(+MAGDFN,0)) S RY="0^Invalid data: Patient DFN invalid: "_MAGDFN Q 0 114 I 'MAGTIUDA S RY="0^Invalid Note IEN: "_MAGTIUDA Q 0 115 I '$D(^TIU(8925,MAGTIUDA,0)) S RY="0^Invalid Note IEN: "_MAGTIUDA Q 0 116 I $P(^TIU(8925,MAGTIUDA,0),"^",2)'=MAGDFN S RY="0^Invalid Patient DFN: "_MAGDFN_" for Note: "_MAGTIUDA Q 0 117 S RY="1^Validated OK." 118 Q 1 -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGNTI3.m
r613 r623 1 MAGGNTI3 ;WOIFO/GEK - Imaging interface to TIU.RPC Calls etc. ; 04 Apr 2002 2:37 PM2 ;;3.0;IMAGING;**46,59**;Nov 27, 2007;Build 20 3 ;;Per VHA Directive 2004-038, this routine should not be modified.4 5 6 7 8 9 10 11 12 13 14 15 16 17 ;; 18 19 MOD(MAGRY,MAGDFN,MAGTIUDA,MAGADCL,MAGMODE,MAGES,MAGESBY,MAGTEXT) 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 SIGN(MAGRY,MAGDFN,MAGTIUDA,MAGES,MAGESBY) 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 ERR 86 87 88 89 1 MAGGNTI3 ;WOIFO/GEK - Imaging interface to TIU RPC Calls etc. ; 04 Apr 2002 2:37 PM 2 ;;3.0;IMAGING;**46**;16-February-2007;;Build 1023 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 ;; | 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 Q 19 MOD(MAGRY,MAGDFN,MAGTIUDA,MAGADCL,MAGMODE,MAGES,MAGESBY,MAGTEXT) ; RPC [MAG3 TIU MODIFY NOTE] 20 ; RPC call to Modify an Existing Note by: 21 ; Electronically Signing or 22 ; Administratively Closing the Note 23 ; 24 ; - - - Required - - - 25 ; MAGDFN - Patient DFN 26 ; MAGTIUDA - IEN of TIU NOTE in file 8925 27 ; - - - Optional - - - 28 ; MAGADCL - 1 = Mark this Note as Administratively Closed 29 ; MAGMODE - Mode of Admin Closure: "S" = Scanned Document "M" = Manual closure 30 ; MAGES - The encrypted Electronic Signature 31 ; MAGESBY - The DUZ of the Signer (Defaults to DUZ) 32 ; MAGTEXT - Array of Text to add to the New Note. // NOT USED IN 3.0.59 33 ; 34 N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) 35 S MAGDFN=$G(MAGDFN),MAGTIUDA=$G(MAGTIUDA) 36 S MAGES=$G(MAGES),MAGADCL=$G(MAGADCL) 37 S MAGESBY=$S($G(MAGESBY):MAGESBY,1:DUZ) 38 S MAGMODE=$S($L($G(MAGMODE)):MAGMODE,1:"S") 39 I '$$VALDATA^MAGGNTI2(.MAGRY,MAGDFN,MAGTIUDA) Q 40 N MAGXT,I,CT,MAGMRC,X 41 S CT=1,I="" 42 ; We don't allow Editing/Adding of Text to an existing document. 43 ; If Change Status to Admin Close. Then we Quit 44 S MAGRY="1^" 45 I MAGADCL="1" D Q:'MAGRY 46 . D ADMNCLOS^MAGGNTI2(.MAGTY,MAGDFN,MAGTIUDA,MAGMODE) 47 . S MAGRY=$S('MAGTY:MAGTY,1:MAGRY_"Note is Administratively Closed.") 48 . S ^TMP($J,"MAGGNTI1","MOD AFTER ADMNCLOS ")=MAGRY 49 . Q:'MAGRY 50 . ; Note has been E-Filed Complete the Consult if one is attached. 51 . D GET1405^TIUSRVR(.MAGMRC,MAGTIUDA) 52 . S ^TMP($J,"MAGGNTI1","MOD MAGMRC")=$G(MAGMRC) 53 . I (+MAGMRC>0)&(MAGMRC["GMR(123") D 54 . . ;Use GRMC Call to 'Close' the consult. For AdminClos the Consult Status 55 . . ;went from 'p' to 'pr' this will change it to 'c' (complete). 56 . . S X=$$SFILE^GMRCGUIB(+MAGMRC,10) 57 . . Q 58 . Q 59 ; 60 ; if caller sent esignature to Sign this Addendum. 61 I $L(MAGES) D Q:'MAGRY 62 . D SIGN(.MAGTY,MAGDFN,MAGTIUDA,MAGES,MAGESBY) 63 . S MAGRY=$S('MAGTY:MAGTY,1:MAGRY_"Note is Signed.") 64 . Q 65 Q 66 SIGN(MAGRY,MAGDFN,MAGTIUDA,MAGES,MAGESBY) ;RPC [MAG3 TIU SIGN RECORD] 67 ; RPC Call to 'Sign' a Note. 68 ; - - - Required - - - 69 ; MAGDFN - DFN of Patient. 70 ; MAGTIUDA - TIUDA - IEN of TIU Note file 8925 71 ; MAGES - The encrypted Electronic Signature 72 ; MAGESBY - The DUZ of the Signer (Defaults to DUZ) 73 ; 74 N RY 75 S MAGDFN=$G(MAGDFN),MAGTIUDA=$G(MAGTIUDA),MAGES=$G(MAGES),MAGESBY=$G(MAGESBY,DUZ) 76 I '$$VALDATA^MAGGNTI2(.MAGRY,MAGDFN,MAGTIUDA) Q 77 ; 78 ; Calling TIU SIGN RECORD 79 D SIGN^TIUSRVP(.RY,MAGTIUDA,MAGES) 80 ; on success RY = 0 81 ; on error RY = error code ^ < message > 82 I +RY S MAGRY="0^"_$TR(RY,"^","~") 83 E S MAGRY="1^Success: Note has been Signed." 84 Q 85 ERR ; ERROR TRAP 86 N ERR S ERR=$$EC^%ZOSV 87 S MAGRY="0^ETRAP: "_ERR 88 D @^%ZOSF("ERRTN") 89 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGSIA.m
r613 r623 1 MAGGSIA ;WOIFO/GEK - Imaging RPC Broker calls. Add/Modify Image entry ; [ 12/27/2000 10:49 ] 2 ;;3.0;IMAGING;**7,21,8,59**;Nov 27, 2007;Build 20 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 ; 21 ;**** CALLING ROUTINE is responsible for RENAMING THE IMAGE FILE 22 ;**** on DISK TO THE NEW FILE NAME RETURNED BY THIS CALL. 23 ; 24 ADD(MAGRY,MAGARRAY) ; RPC [MAG4 ADD IMAGE] 25 ; Calls UPDATE^DIE to Add an Image File entry 26 ; Called from Import API Delphi component and ImportX (Active X) control. 27 ; Parameters : 28 ; MAGARRAY - array of field numbers and their entries 29 ; i.e. MAGARRAY(1)=".5^38" field# .5 data is 38 30 ; If Long Description is included in array (field 11), we create a new 31 ; array to hold the text, and pass that to UPDATE^DIE 32 ; If this entry is an Image Group 33 ; i.e. MAGARRAY(n)="2005.04^344" 34 ; (the field 2005.04 is the OBJECT GROUP MULTIPLE) 35 ; ( 344 is the pointer to the Image File Entry that will be added 36 ; ( as a member of this new/existing Group) 37 ; 38 ; Return Variable 39 ; 40 ; MAGRY(0) - Array 41 ; Successful MAGRY(0) = IEN^FILE NAME (with full path) 42 ; UNsuccessful MAGRY(0) = 0^Error desc 43 ; MAGRY(0)(1..n) = Errors and warnings. 44 ; 45 ; CALLING ROUTINE is responsible for RENAMING THE IMAGE FILE on DISK 46 ; TO THE NEW FILE NAME RETURNED BY THIS CALL. 47 ; Changed to include hierarchical directory hash - PMK 04/23/98 48 ;---------------------------------------------------------------- 49 N MAGGFDA,MAGGDRV,MAGGRP,MAGCHLD,GRPCT,MAGGDA,MAGGFNM 50 N MAGGWP,MAGERR,MAGREF,MAGDHASH,MAGTEMP,MAGACT,MAGGIEN,MAGGXE 51 N GIEN,DIEN,NEWIEN ;3.0 52 N I,J,X,Y,Z,WPCT 53 ; 54 N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGSERR" 55 I ($D(MAGARRAY)<10) S MAGRY(0)="0^No input data, Operation CANCELED" Q 56 ; 57 S MAGRY(0)="0^Creating VistA Image Entry..." 58 S MAGERR="",MAGGRP=0,GRPCT=1,WPCT=0 59 ; Validate the Data, and Action codes in the Input Array 60 D VAL^MAGGSIV(.MAGRY,.MAGARRAY) I 'MAGRY(0) Q 61 ; 62 ; Make the FileMan FDA array and the Imaging Action array. 63 D MAKEFDA^MAGGSIU2(.MAGGFDA,.MAGARRAY,.MAGACT,.MAGCHLD,.MAGGRP,.MAGGWP) 64 I '$D(MAGGFDA(2005,"+1,")) S MAGRY(0)="0^No data to file. Operation CANCELED." Q 65 ; 66 ;Q:'$$VALINDEX^MAGGSIV1(.MAGRY,$G(MAGGFDA(2005,"+1,",42)),$G(MAGGFDA(2005,"+1,",44)),$G(MAGGFDA(2005,"+1,",43))) 67 ; Check on some possible problems: required fields, create default values etc. 68 D PRE^MAGGSIA1(.MAGERR,.MAGGFDA,MAGGRP,.MAGGDRV,.MAGREF) I $L(MAGERR) S MAGRY(0)=MAGERR Q 69 ; Locking Patch 8. Get latest Image IEN and Deleted IEN take the greater of the two. 70 S GIEN=$O(^MAG(2005," "),-1)+1 71 S DIEN=$O(^MAG(2005.1," "),-1)+1 72 S NEWIEN=$S(GIEN>DIEN:GIEN,1:DIEN) 73 LOCK L +^MAG(2005,NEWIEN):0 E S NEWIEN=NEWIEN+1 G LOCK ; lock it, or get next 74 I $D(^MAG(2005,NEWIEN)) L -^MAG(2005,NEWIEN) S NEWIEN=NEWIEN+1 G LOCK ; if it exists, get next 75 S MAGGIEN(1)=NEWIEN 76 D UPDATE^DIE("S","MAGGFDA","MAGGIEN","MAGGXE") 77 ; 78 ; ERROR: QUIT 79 I '$G(MAGGIEN(1)) D S MAGRY(0)=MAGERR Q 80 . S MAGERR="0^ERROR Creating new Image File Entry " 81 . I $D(DIERR) D RTRNERR^MAGGSIU1(.MAGERR) 82 . D CLEAN 83 ; 84 S MAGGDA=MAGGIEN(1) 85 ; 86 D ACTION^MAGGTAU("CAP^"_MAGGFDA(2005,"+1,",5)_"^"_MAGGDA) 87 ; 88 ; IF a group, UpDate the GROUP PARENT in each Group Object and QUIT 89 ; The Return (MAGRY(0)) will be IEN with NO Filename. Groups don't get Filename 90 I MAGGRP D G C1 91 . D UPDCHLD^MAGGSIM(.MAGCHLD,MAGGDA) 92 . S MAGRY(0)=MAGGDA_U 93 . D CLEAN 94 . Q 95 ; ENTRY in Image File has been made, if any errors from here on 96 ; then we have to delete the image entry. 97 ; IF This image is a member of a Group, Update the Group Entry with new child. 98 S X=$G(MAGGFDA(2005,"+1,",14)) I +X D I $L(MAGERR) Q 99 . D UPDPAR^MAGGSIM(.MAGERR,X,.MAGACT,MAGGDA) 100 . I $L(MAGERR) S MAGRY(0)=MAGERR D CLEAN 101 ; 102 ; Now generate the Image FileName. This is passed back to the calling app, 103 ; and the calling app is responsible for renaming/copying the Image File to 104 ; this new name. 105 I $D(MAGGFDA(2005,"+1,",1)) S MAGGFNM=MAGGFDA(2005,"+1,",1) 106 E D I $L(MAGERR) S MAGRY(0)=MAGERR Q 107 . N MAGXFDA 108 . S X=$$DA2NAME^MAGGTU1(MAGGDA,$G(MAGACT("EXT"))) I 'X D Q 109 . . S MAGERR=X 110 . . D KILLENT^MAGGSIU1(MAGGDA) 111 . . D CLEAN 112 . ; 113 . S MAGGFNM=$P(X,U,2),Y=MAGGDA_"," 114 . S MAGXFDA(2005,Y,1)=MAGGFNM 115 . D UPDATE^DIE("","MAGXFDA","","MAGGXE") 116 . ; in case of an error 117 . I $D(DIERR) D Q 118 . . D RTRNERR^MAGGSIU1(.MAGERR,.MAGGXE) 119 . . D KILLENT^MAGGSIU1(MAGGDA) 120 . . D CLEAN 121 ; 122 C1 ; 59 123 K MAGGFDA ; P59. 124 ;P59 Now we Auto-Generate the Index Fields, if they don't exist for this entry 125 I '$D(^MAG(2005,MAGGDA,40)) D 126 . N INDXD 127 . D GENIEN^MAGXCVI(MAGGDA,.INDXD) 128 . D COMIEN^MAGXCVC(MAGGDA,.INDXD) 129 . S ^MAGIXCVT(2006.96,MAGGDA)=1 ; Flag. Says fields were converted by index generation 130 . ; TRKING ID TRKID = MAGGFDA(2005,"+1,",108) 131 . ;;D ACTION^MAGGTAU("GENINDX^"_MAGGFDA(2005,"+1,",5)_"^"_MAGGDA_"$$"_MAGGFDA(2005,"+1,",108)) 132 . D ACTION^MAGGTAU("INDEX-ALL^"_$P(^MAG(2005,MAGGDA,0),"^",7)_"^"_MAGGDA_"$$"_$P(^MAG(2005,MAGGDA,100),"^",5)) 133 . Q 134 ; 135 ;P59 If TYPE INDEX is missing we Auto-Generate Index Type and other missing Index Term values. 136 I '$P(^MAG(2005,MAGGDA,40),"^",3) D 137 . N INDXD,OLD40,N40 138 . S (N40,OLD40)=^MAG(2005,MAGGDA,40) 139 . D GENIEN^MAGXCVI(MAGGDA,.INDXD) 140 . ; If Origin doesn't exist in existing, this will put V in. 141 . I $P(INDXD,"^",6)="" S $P(INDXD,"^",6)="V" 142 . ; We're not changing existing values of Spec,Proc or Origin 143 . F J=1:1:6 I '$L($P(N40,"^",J)) S $P(N40,"^",J)=$P(INDXD,"^",J) 144 . ;Validate the merged Spec and Proc, if not valid, revert back to old Spec and Proc 145 . I '$$VALINDEX^MAGGSIV1(.X,$P(N40,"^",3),$P(N40,"^",5),$P(N40,"^",4)) S $P(N40,"^",4,5)=$P(OLD40,"^",4,5) 146 . S ^MAG(2005,MAGGDA,40)=N40 147 . ;;D ACTION^MAGGTAU("INDEX-42^"_$P(^MAG(2005,MAGGDA,0),"^",7)_"^"_MAGGDA) ;_"$$"_MAGGFDA(2005,"+1,",108)) 148 . D ACTION^MAGGTAU("INDEX-42^"_$P(^MAG(2005,MAGGDA,0),"^",7)_"^"_MAGGDA_"$$"_$P(^MAG(2005,MAGGDA,100),"^",5)) 149 . D ENTRY^MAGLOG("INDEX-42",DUZ,MAGGDA,"P59",$P(^MAG(2005,MAGGDA,0),"^",7),1) 150 . Q 151 ;** ABS and JB image queues AREN'T SET WHEN ADDING AN IMAGE. 152 ;** RPC =-> 'MAG ABSJB' after abstract is/isn't created on the workstation 153 ; 154 ; The Return is: IEN ^ DRIVE:DIR ^ FILE.EXT [^ DRIVE:DIR ^ FILE.BIG] 155 ; example: 487^C:\IMAGE\^DC000487.TIF 156 ; The calling routine is responsible for renaming/naming the file 157 ; to the returned DRIVE:\DIR\FILENAME.EXT 158 ; 159 ; Modified 4/23/98 to include hierarchical directory structure -- PMK 160 I 'MAGGRP D 161 . S MAGDHASH=$$DIRHASH^MAGFILEB(MAGGFNM,MAGREF) 162 . ; For now, BIG files are in same directory as FullRes (or PACS) file 163 . S MAGRY(0)=MAGGDA_U_MAGGDRV_MAGDHASH_U_MAGGFNM 164 . ; If BIG file also, add it's Drive, Hash, Filename to end of Return string. 165 . I $G(MAGACT("BIG")) D 166 . . S X=$P(MAGGFNM,".",1)_".BIG" 167 . . S MAGRY(0)=MAGRY(0)_U_MAGGDRV_MAGDHASH_U_X 168 . . Q 169 . Q 170 ; 171 CLEAN ; Called as tag 172 D CLEAN^DILF 173 L -^MAG(2005,NEWIEN) 174 Q 1 MAGGSIA ;WOIFO/GEK - Imaging RPC Broker calls. Add/Modify Image entry ; [ 12/27/2000 10:49 ] 2 ;;3.0;IMAGING;**7,21,8**;Sep 15, 2004 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 Q 19 ; 20 ;**** CALLING ROUTINE is responsible for RENAMING THE IMAGE FILE 21 ;**** on DISK TO THE NEW FILE NAME RETURNED BY THIS CALL. 22 ; 23 ADD(MAGRY,MAGARRAY) ; RPC [MAG4 ADD IMAGE] 24 ; Calls UPDATE^DIE to Add an Image File entry 25 ; Called from Import API Delphi component and ImportX (Active X) control. 26 ; Parameters : 27 ; MAGARRAY - array of field numbers and their entries 28 ; i.e. MAGARRAY(1)=".5^38" field# .5 data is 38 29 ; If Long Description is included in array (field 11), we create a new 30 ; array to hold the text, and pass that to UPDATE^DIE 31 ; If this entry is an Image Group 32 ; i.e. MAGARRAY(n)="2005.04^344" 33 ; (the field 2005.04 is the OBJECT GROUP MULTIPLE) 34 ; ( 344 is the pointer to the Image File Entry that will be added 35 ; ( as a member of this new/existing Group) 36 ; 37 ; Return Variable 38 ; 39 ; MAGRY(0) - Array 40 ; Successful MAGRY(0) = IEN^FILE NAME (with full path) 41 ; UNsuccessful MAGRY(0) = 0^Error desc 42 ; MAGRY(0)(1..n) = Errors and warnings. 43 ; 44 ; CALLING ROUTINE is responsible for RENAMING THE IMAGE FILE on DISK 45 ; TO THE NEW FILE NAME RETURNED BY THIS CALL. 46 ; Changed to include hierarchial directory hash - PMK 04/23/98 47 ;---------------------------------------------------------------- 48 N MAGGFDA,MAGGDRV,MAGGRP,MAGCHLD,GRPCT,MAGGDA,MAGGFNM 49 N MAGGWP,MAGERR,MAGREF,MAGDHASH,MAGTEMP,MAGACT,MAGGIEN,MAGGXE 50 N GIEN,DIEN,NEWIEN ;3.0 51 N I,J,X,Y,Z,WPCT 52 ; 53 N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGSERR" 54 I ($D(MAGARRAY)<10) S MAGRY(0)="0^No input data, Operation CANCELED" Q 55 ; 56 S MAGRY(0)="0^Creating VistA Image Entry..." 57 S MAGERR="",MAGGRP=0,GRPCT=1,WPCT=0 58 ; Validate the Data, and Action codes in the Input Array 59 D VAL^MAGGSIV(.MAGRY,.MAGARRAY) I 'MAGRY(0) Q 60 ; 61 ; Make the FileMan FDA array and the Imaging Action array. 62 D MAKEFDA^MAGGSIU2(.MAGGFDA,.MAGARRAY,.MAGACT,.MAGCHLD,.MAGGRP,.MAGGWP) 63 I '$D(MAGGFDA(2005,"+1,")) S MAGRY(0)="0^No data to file. Operation CANCELED." Q 64 ; 65 ; Check on some possible problems: required fields, create default values etc. 66 D PRE^MAGGSIA1(.MAGERR,.MAGGFDA,MAGGRP,.MAGGDRV,.MAGREF) I $L(MAGERR) S MAGRY(0)=MAGERR Q 67 ; Locking Patch 8. Get latest Image IEN and Deleted IEN take the greater of the two. 68 S GIEN=$O(^MAG(2005," "),-1)+1 69 S DIEN=$O(^MAG(2005.1," "),-1)+1 70 S NEWIEN=$S(GIEN>DIEN:GIEN,1:DIEN) 71 LOCK L +^MAG(2005,NEWIEN):0 E S NEWIEN=NEWIEN+1 G LOCK ; lock it, or get next 72 I $D(^MAG(2005,NEWIEN)) L -^MAG(2005,NEWIEN) S NEWIEN=NEWIEN+1 G LOCK ; if it exists, get next 73 S MAGGIEN(1)=NEWIEN 74 D UPDATE^DIE("S","MAGGFDA","MAGGIEN","MAGGXE") 75 ; 76 ; ERROR: QUIT 77 I '$G(MAGGIEN(1)) D S MAGRY(0)=MAGERR Q 78 . S MAGERR="0^ERROR Creating new Image File Entry " 79 . I $D(DIERR) D RTRNERR^MAGGSIU1(.MAGERR) 80 . D CLEAN 81 ; 82 S MAGGDA=MAGGIEN(1) 83 ; 84 D ACTION^MAGGTAU("CAP^"_MAGGFDA(2005,"+1,",5)_"^"_MAGGDA) 85 ; 86 ; IF a group, UpDate the GROUP PARENT in each Group Object and QUIT 87 ; The Return (MAGRY(0)) will be IEN with NO Filename. Groups don't get Filename 88 I MAGGRP D Q 89 . D UPDCHLD^MAGGSIM(.MAGCHLD,MAGGDA) 90 . S MAGRY(0)=MAGGDA_U 91 . D CLEAN 92 . Q 93 ; ENTRY in Image File has been made, if any errors from here on 94 ; then we have to delete the image entry. 95 ; New Index Field Check. If this entry doesn't have the Index fields introduced 96 ; in 3.0.8 then we use the Patch 17 conversion API call to generate default values. 97 ;-This is being deferred to a later patch. 98 ;-I '$D(^MAG(2005,MAGGDA,40)) D 99 ;-. D ONE^MAGSCNVI(MAGGDA) 100 ;-. D ACTION^MAGGTAU("DFTINDX^"_MAGGFDA(2005,"+1,",5)_"^"_MAGGDA) 101 ; 102 ; Now generate the Image FileName. This is passed back to the calling app, 103 ; and the calling app is responsible for renaming/copying the Image File to 104 ; this new name. 105 I $D(MAGGFDA(2005,"+1,",1)) S MAGGFNM=MAGGFDA(2005,"+1,",1) 106 E D I $L(MAGERR) S MAGRY(0)=MAGERR Q 107 . N MAGXFDA 108 . S X=$$DA2NAME^MAGGTU1(MAGGDA,$G(MAGACT("EXT"))) I 'X D Q 109 . . S MAGERR=X 110 . . D KILLENT^MAGGSIU1(MAGGDA) 111 . . D CLEAN 112 . ; 113 . S MAGGFNM=$P(X,U,2),Y=MAGGDA_"," 114 . S MAGXFDA(2005,Y,1)=MAGGFNM 115 . D UPDATE^DIE("","MAGXFDA","","MAGGXE") 116 . ; in case of an error 117 . I $D(DIERR) D Q 118 . . D RTRNERR^MAGGSIU1(.MAGERR,.MAGGXE) 119 . . D KILLENT^MAGGSIU1(MAGGDA) 120 . . D CLEAN 121 ; 122 ; 123 ; 124 ; IF This image is a member of a Group, Update the Group Entry with new child. 125 S X=$G(MAGGFDA(2005,"+1,",14)) I +X D I $L(MAGERR) Q 126 . D UPDPAR^MAGGSIM(.MAGERR,X,.MAGACT,MAGGDA) 127 . I $L(MAGERR) S MAGRY(0)=MAGERR D CLEAN 128 ; 129 ;** ABS and JB image queues AREN'T SET WHEN ADDING AN IMAGE. 130 ;** RPC =-> 'MAG ABSJB' after abstract is/isn't created on the workstation 131 ; 132 ; The Return is: IEN ^ DRIVE:DIR ^ FILE.EXT [^ DRIVE:DIR ^ FILE.BIG] 133 ; i.e 487^C:\IMAGE\^DC000487.TIF 134 ; The calling routine is responsible for renaming/naming the file 135 ; to the returned DRIVE:\DIR\FILENAME.EXT 136 ; 137 ; Modified 4/23/98 to include hierarchial directory structure -- PMK 138 S MAGDHASH=$$DIRHASH^MAGFILEB(MAGGFNM,MAGREF) 139 ; For now, BIG files are in same directory as FullRes (or PACS) file 140 S MAGRY(0)=MAGGDA_U_MAGGDRV_MAGDHASH_U_MAGGFNM 141 ; If BIG file also, add it's Drive, Hash, Filename to end of Return string. 142 I $G(MAGACT("BIG")) D 143 . S X=$P(MAGGFNM,".",1)_".BIG" 144 . S MAGRY(0)=MAGRY(0)_U_MAGGDRV_MAGDHASH_U_X 145 ; 146 CLEAN ; Called as tag 147 D CLEAN^DILF 148 L -^MAG(2005,NEWIEN) 149 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGSIA1.m
r613 r623 1 MAGGSIA1 ;WOIFO/GEK - RPC Call to Add Image File entry ; [ 12/27/2000 10:49 ] 2 ;;3.0;IMAGING;**7,8,85,59**;Nov 27, 2007;Build 20 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 PRE(MAGERR,MAGGFDA,MAGGRP,MAGGDRV,MAGREF) ; 21 ; Check on some possible problems: required fields etc. 22 ; Object Type and (Patient, or Short Desc) Required. 23 N MAGRSLT,X,Z 24 I '$D(MAGGFDA(2005,"+1,",3)) D OBJTYPE 25 I '$D(MAGGFDA(2005,"+1,",3)) S MAGERR="0^Need an Object Type " Q 26 I '$D(MAGGFDA(2005,"+1,",5)),'$D(MAGGFDA(2005,"+1,",10)) D Q 27 . S MAGERR="0^Need Patient or Short Desc. Operation CANCELED " 28 ; IF no Procedure text we'll give it some so crossref will set. 29 D PATCHK(.MAGRSLT) I 'MAGRSLT S MAGERR=MAGRSLT Q 30 ; Patch 8 IAPI We Create IXCLS (#41 CLASS) and IXPKG (#40 Package) if TYPE is in Data. 31 ; But we are not making TYPE required yet for backward compatibality. 32 I $D(MAGGFDA(2005,"+1,",42)) D 33 . I $$GET1^DIQ(2005.83,MAGGFDA(2005,"+1,",42),2,"E")="INACTIVE" D S MAGRY=MAGERR Q 34 . . S MAGERR="0^Index Type: "_$$GET1^DIQ(2005.83,MAGGFDA(2005,"+1,",42),.01,"E")_"is INACTIVE" 35 . I '$D(MAGGFDA(2005,"+1,",41)) D MAKECLAS^MAGGSIU1 I $L(MAGERR) S MAGRY=MAGERR Q 36 . I ($D(MAGGFDA(2005,"+1,",16)))&($$ISTYPADM(MAGGFDA(2005,"+1,",42))) D S MAGRY=MAGERR Q 37 . . S MAGERR="0^Can't have an ADMIN TYPE with Clinical Image." 38 . I '$D(MAGGFDA(2005,"+1,",40)) D MAKEPKG^MAGGSIU1 I $L(MAGERR) S MAGRY=MAGERR Q 39 . I '$D(MAGGFDA(2005,"+1,",6)) D MAKEPROC^MAGGSIU1 I $L(MAGERR) S MAGRY=MAGERR Q 40 . I '$D(MAGGFDA(2005,"+1,",45)) D MAKEORIG^MAGGSIU1 I $L(MAGERR) S MAGRY=MAGERR Q 41 . Q 42 ; 43 I '$D(MAGGFDA(2005,"+1,",6)) D PROCTEXT 44 ; 45 ; If no Procedure/Exam Date/Time we'll give it DocDT, or NOW 46 I '$D(MAGGFDA(2005,"+1,",15)) D 47 . I $D(MAGGFDA(2005,"+1,",110)) S MAGGFDA(2005,"+1,",15)=MAGGFDA(2005,"+1,",110) Q 48 . S MAGGFDA(2005,"+1,",15)=$E($$NOW^XLFDT,1,12) 49 ; DateTime image saved. 50 I '$D(MAGGFDA(2005,"+1,",7)) S MAGGFDA(2005,"+1,",7)=$E($$NOW^XLFDT,1,12) 51 ; Short Description 52 ;I '$D(MAGGFDA(2005,"+1,",10)) S MAGGFDA(2005,"+1,",10)=$$MAKENAME^MAGGSIU1(.MAGGFDA) 53 I '$D(MAGGFDA(2005,"+1,",10)) S MAGGFDA(2005,"+1,",10)=$G(MAGGFDA(2005,"+1,",6)) 54 ; Name (.01) 55 I '$D(MAGGFDA(2005,"+1,",.01)) S MAGGFDA(2005,"+1,",.01)=$$MAKENAME^MAGGSIU1(.MAGGFDA) 56 I '$D(MAGGFDA(2005,"+1,",8)) S MAGGFDA(2005,"+1,",8)=$G(DUZ) 57 ; Acquisition Site, Use it to tell where to save the file. 58 I $D(MAGACT("ACQS")) D 59 . ; Patch 8 Have to modify: Field 105 (Acquisition Site) is NOW Field .05 60 . I $P(MAGACT("ACQS"),";")]"" S MAGGFDA(2005,"+1,",.05)=$P(MAGACT("ACQS"),";") 61 ; Only get drive:dir if not a group 62 I 'MAGGRP D I $L(MAGERR) Q 63 . ; The value of the Action Code "WRITE^value" OVERRIDES any Write Location 64 . ; sent as field # 2 in the input array. (The only value we check for is "PACS" from peter's code) 65 . S X=$S($D(MAGACT("WRITE")):MAGACT("WRITE"),$D(MAGGFDA(2005,"+1,",2)):MAGGFDA(2005,"+1,",2),1:"") 66 . ;P85 Send ACQS as second Param. $$DRIVE will use ACQS If X = "" 67 . ; 68 . S Z=$$DRIVE^MAGGTU1(X,$G(MAGGFDA(2005,"+1,",.05))) ;Drv:Dir to Write 69 . I 'Z S MAGERR=Z Q 70 . S MAGGDRV=$P(Z,U,2) 71 . S MAGGFDA(2005,"+1,",2)=+Z ;Disk & Vol magnetic 72 . ; if a big file is being made on workstation, put NetWork Location 73 . ; pointer in the BIG NETWORK LOCATION field. 74 . ; (BIG files default to same Network Location as FullRes (or PACS)) 75 . I $G(MAGACT("BIG"))=1 S MAGGFDA(2005,"+1,",102)=+Z 76 . S MAGREF=+Z ; save network location ien for $$DIRHASH in ^MAGGSIA1 77 . I $G(MAGACT("ABS"))="STUFFONLY" S MAGGFDA(2005,"+1,",2.1)=+Z 78 ; 79 I $D(MAGACT("ACQL")) S MAGGFDA(2005,"+1,",101)=MAGACT("ACQL") 80 ; HERE we are putting PRE Processing for the Import API action codes. 81 ; "ACQD,ACQS" If Acquisition device entry doesn't exist, create it. 82 I $D(MAGACT("ACQD")) D 83 . ; IF Value is a pointer to the ACQ DEVICE File Quit. If it's invalid then UPDATE will catch it. 84 . I (+MAGACT("ACQD")=MAGACT("ACQD")) S MAGGFDA(2005,"+1,",107)=MAGACT("ACQD") Q 85 . I $D(^MAG(2006.04,"B",MAGACT("ACQD"))) D Q 86 . . ; IF Already exists, add it to the FDA 87 . . S MAGGFDA(2005,"+1,",107)=$O(^MAG(2006.04,"B",MAGACT("ACQD"),"")) 88 . . ; What do we do with the Acquisition Site. IF Acq Dev already exists. ? 89 . . ; ?? 90 . ; IF it doesn't exist, create it, and add it's ien to the image entry 91 . N MAGDFDA,MAGDIEN,MAGDXE 92 . S MAGDFDA(2006.04,"+1,",.01)=MAGACT("ACQD") 93 . S MAGDFDA(2006.04,"+1,",1)=$S($D(MAGACT("ACQS")):$P(MAGACT("ACQS"),";"),1:$G(MAGGFDA(2005,"+1,",.05))) 94 . S MAGDFDA(2006.04,"+1,",2)=$S($D(MAGACT("ACQL")):MAGACT("ACQL"),$D(MAGGFDA(2005,"+1,",101)):MAGGFDA(2005,"+1,",101),1:$P($G(MAGACT("ACQS")),";",2)) 95 . ; ACQS was a 2 ';' piece value with Acq Location (HOSPITAL LOCATION) as 2nd piece 96 . ; now it is sent as it's own value in ACQL 97 . D UPDATE^DIE("","MAGDFDA","MAGDIEN","MAGDXE") 98 . S MAGGFDA(2005,"+1,",107)=MAGDIEN(1) 99 ; 100 ; Check the last entry in Audit File to see if it is greater than 101 ; last image in Image File. IF yes, change Image File (0) node entry. 102 I ($O(^MAG(2005,"A"),-1)<$O(^MAG(2005.1,"A"),-1)) S $P(^MAG(2005,0),U,3)=$O(^MAG(2005.1,"A"),-1) 103 ; 104 Q 105 PATCHK(MAGR) ; This uses the FDA Array and checks the Imaging Patient against the Procedure patient 106 ; 107 N MAGDFN,PX,PXDA,MAGY 108 S PX=$G(MAGGFDA(2005,"+1,",16)) 109 S PXDA=$G(MAGGFDA(2005,"+1,",17)) 110 I 'PX S MAGR=1 Q ; This is a category, or an Image of a group (no parent pointer) 111 S MAGDFN=MAGGFDA(2005,"+1,",5) 112 I (PX=8925) D Q 113 . I '$D(^TIU(8925,PXDA)) S MAGR="0^Invalid TIU Entry Number: "_PXDA Q 114 . D DATA^MAGGNTI(.MAGY,PXDA) 115 . I '(MAGDFN=$P(MAGY,U,4)) S MAGR="0^Procedure and Imaging patients don't match." Q 116 . S MAGR=1 117 Q 118 OBJTYPE ; This call uses the EXT and computes an Object Type 119 N MTYPE 120 I '$L($G(MAGACT("EXT"))) Q 121 S MTYPE=$O(^MAG(2005.02,"AD",MAGACT("EXT"),"")) 122 ;I 'MTYPE Q 123 ;TODO : Answer question, do we want to have a default Image type ? 124 I 'MTYPE S MTYPE=1 125 S MAGGFDA(2005,"+1,",3)=MTYPE 126 Q 127 ISTYPADM(TYPE) ; Returns 1 if this is an Admin Type 128 N CL 129 I '$G(TYPE) Q 0 130 S CL=$$GET1^DIQ(2005.83,TYPE,1,"E") 131 Q $S($E(CL,1,5)="ADMIN":1,1:0) 132 PROCTEXT ;This call uses flds 16 and 17 to compute fld #6 PROCEDURE TEXT [8F] 133 ; We are here because fld #6 PROCEDURE [8F] is null. 134 ; If a pointer to a package is in the data, (flds 16 and 17) 135 ; get fld #6 from that , if not then treat it as an UNASSIGNED image 136 ; i.e. Category UNASSIGNED. 137 N MAGYPX,PARENT,PARIEN,PXDESC 138 S PARENT=$G(MAGGFDA(2005,"+1,",16)) 139 S PARIEN=$G(MAGGFDA(2005,"+1,",17)) 140 ; 141 I (PARENT=8925),(PARIEN]"") D Q 142 . D DATA^MAGGNTI(.MAGYPX,PARIEN) 143 . S MAGGFDA(2005,"+1,",6)=$P(MAGYPX,U,2) 144 ;TODO; create calls to get default procedure desc for all specialties 145 ; AND default to NONE if a TYPE and no PARENT data File (fld 16) 146 ; If a Parent pointer exists, and it isn't TIU, for now set "NO Description" 147 I PARENT]"" S MAGGFDA(2005,"+1,",6)="No Description" Q 148 ; 149 ; Do we have a pointer to a MAG DESCRIPTIVE CATEGORY 150 I ($G(MAGGFDA(2005,"+1,",100))]"") D Q 151 . S MAGGFDA(2005,"+1,",6)=$P(^MAG(2005.81,MAGGFDA(2005,"+1,",100),0),U,1) 152 ; 153 ; If a new child of a Group, use that Proc Desc 154 I $G(MAGGFDA(2005,"+1,",14))]"" D Q 155 . S MAGGFDA(2005,"+1,",6)=$P(^MAG(2005,MAGGFDA(2005,"+1,",14),0),U,8) 156 ; 157 ; Parent="", and no Category pointer, then we Call it UNASSIGNED 158 S MAGGFDA(2005,"+1,",100)=$O(^MAG(2005.81,"B","UNASSIGNED","")) 159 S MAGGFDA(2005,"+1,",6)="UNASSIGNED" 160 Q 1 MAGGSIA1 ;WOIFO/GEK - RPC Call to Add Image File entry ; [ 12/27/2000 10:49 ] 2 ;;3.0;IMAGING;**7,8,85**;16-March-2007;;Build 1039 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 ;; | 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 Q 19 PRE(MAGERR,MAGGFDA,MAGGRP,MAGGDRV,MAGREF) ; 20 ; Check on some possible problems: required fields etc. 21 ; Object Type and (Patient, or Short Desc) Required. 22 N MAGRSLT,X,Z 23 I '$D(MAGGFDA(2005,"+1,",3)) D OBJTYPE 24 I '$D(MAGGFDA(2005,"+1,",3)) S MAGERR="0^Need an Object Type " Q 25 I '$D(MAGGFDA(2005,"+1,",5)),'$D(MAGGFDA(2005,"+1,",10)) D Q 26 . S MAGERR="0^Need Patient or Short Desc. Operation CANCELED " 27 ; IF no Procedure text we'll give it some so crossref will set. 28 D PATCHK(.MAGRSLT) I 'MAGRSLT S MAGERR=MAGRSLT Q 29 ; Patch 8 IAPI We Create IXCLS (#41 CLASS) and IXPKG (#40 Package) if TYPE is in Data. 30 ; But we are not making TYPE required yet for backward compatibality. 31 I $D(MAGGFDA(2005,"+1,",42)) D 32 . I $$GET1^DIQ(2005.83,MAGGFDA(2005,"+1,",42),2,"E")="INACTIVE" D S MAGRY=MAGERR Q 33 . . S MAGERR="0^Index Type: "_$$GET1^DIQ(2005.83,MAGGFDA(2005,"+1,",42),.01,"E")_"is INACTIVE" 34 . I '$D(MAGGFDA(2005,"+1,",41)) D MAKECLAS^MAGGSIU1 I $L(MAGERR) S MAGRY=MAGERR Q 35 . I ($D(MAGGFDA(2005,"+1,",16)))&($$ISTYPADM(MAGGFDA(2005,"+1,",42))) D S MAGRY=MAGERR Q 36 . . S MAGERR="0^Can't have an ADMIN TYPE with Clinical Image." 37 . I '$D(MAGGFDA(2005,"+1,",40)) D MAKEPKG^MAGGSIU1 I $L(MAGERR) S MAGRY=MAGERR Q 38 . I '$D(MAGGFDA(2005,"+1,",6)) D MAKEPROC^MAGGSIU1 I $L(MAGERR) S MAGRY=MAGERR Q 39 . I '$D(MAGGFDA(2005,"+1,",45)) D MAKEORIG^MAGGSIU1 I $L(MAGERR) S MAGRY=MAGERR Q 40 . Q 41 ; 42 I '$D(MAGGFDA(2005,"+1,",6)) D PROCTEXT 43 ; 44 ; If no Procedure/Exam Date/Time we'll give it DocDT, or NOW 45 I '$D(MAGGFDA(2005,"+1,",15)) D 46 . I $D(MAGGFDA(2005,"+1,",110)) S MAGGFDA(2005,"+1,",15)=MAGGFDA(2005,"+1,",110) Q 47 . S MAGGFDA(2005,"+1,",15)=$E($$NOW^XLFDT,1,12) 48 ; DateTime image saved. 49 I '$D(MAGGFDA(2005,"+1,",7)) S MAGGFDA(2005,"+1,",7)=$E($$NOW^XLFDT,1,12) 50 ; Short Description 51 ;I '$D(MAGGFDA(2005,"+1,",10)) S MAGGFDA(2005,"+1,",10)=$$MAKENAME^MAGGSIU1(.MAGGFDA) 52 I '$D(MAGGFDA(2005,"+1,",10)) S MAGGFDA(2005,"+1,",10)=$G(MAGGFDA(2005,"+1,",6)) 53 ; Name (.01) 54 I '$D(MAGGFDA(2005,"+1,",.01)) S MAGGFDA(2005,"+1,",.01)=$$MAKENAME^MAGGSIU1(.MAGGFDA) 55 I '$D(MAGGFDA(2005,"+1,",8)) S MAGGFDA(2005,"+1,",8)=$G(DUZ) 56 ; Acquisition Site, Use it to tell where to save the file. 57 I $D(MAGACT("ACQS")) D 58 . ; Patch 8 Have to modify: Field 105 (Acquisition Site) is NOW Field .05 59 . I $P(MAGACT("ACQS"),";")]"" S MAGGFDA(2005,"+1,",.05)=$P(MAGACT("ACQS"),";") 60 ; Only get drive:dir if not a group 61 I 'MAGGRP D I $L(MAGERR) Q 62 . ; The value of the Action Code "WRITE^value" OVERRIDES any Write Location 63 . ; sent as field # 2 in the input array. (The only value we check for is "PACS" from peter's code) 64 . S X=$S($D(MAGACT("WRITE")):MAGACT("WRITE"),$D(MAGGFDA(2005,"+1,",2)):MAGGFDA(2005,"+1,",2),1:"") 65 . ;P85 Send ACQS as second Param. $$DRIVE will use ACQS If X = "" 66 . ; 67 . S Z=$$DRIVE^MAGGTU1(X,$G(MAGGFDA(2005,"+1,",.05))) ;Drv:Dir to Write 68 . I 'Z S MAGERR=Z Q 69 . S MAGGDRV=$P(Z,U,2) 70 . S MAGGFDA(2005,"+1,",2)=+Z ;Disk & Vol magnetic 71 . ; if a big file is being made on workstation, put NetWork Location 72 . ; pointer in the BIG NETWORK LOCATION field. 73 . ; (BIG files default to same Network Location as FullRes (or PACS)) 74 . I $G(MAGACT("BIG"))=1 S MAGGFDA(2005,"+1,",102)=+Z 75 . S MAGREF=+Z ; save network location ien for $$DIRHASH in ^MAGGSIA1 76 . I $G(MAGACT("ABS"))="STUFFONLY" S MAGGFDA(2005,"+1,",2.1)=+Z 77 ; 78 I $D(MAGACT("ACQL")) S MAGGFDA(2005,"+1,",101)=MAGACT("ACQL") 79 ; HERE we are putting PRE Processing for the Import API action codes. 80 ; "ACQD,ACQS" If Acquisition device entry doesn't exist, create it. 81 I $D(MAGACT("ACQD")) D 82 . ; IF Value is a pointer to the ACQ DEVICE File Quit. If it's invalid then UPDATE will catch it. 83 . I (+MAGACT("ACQD")=MAGACT("ACQD")) S MAGGFDA(2005,"+1,",107)=MAGACT("ACQD") Q 84 . I $D(^MAG(2006.04,"B",MAGACT("ACQD"))) D Q 85 . . ; IF Already exists, add it to the FDA 86 . . S MAGGFDA(2005,"+1,",107)=$O(^MAG(2006.04,"B",MAGACT("ACQD"),"")) 87 . . ; What do we do with the Acquisition Site. IF Acq Dev already exists. ? 88 . . ; ?? 89 . ; IF it doesn't exist, create it, and add it's ien to the image entry 90 . N MAGDFDA,MAGDIEN,MAGDXE 91 . S MAGDFDA(2006.04,"+1,",.01)=MAGACT("ACQD") 92 . S MAGDFDA(2006.04,"+1,",1)=$S($D(MAGACT("ACQS")):$P(MAGACT("ACQS"),";"),1:$G(MAGGFDA(2005,"+1,",.05))) 93 . S MAGDFDA(2006.04,"+1,",2)=$S($D(MAGACT("ACQL")):MAGACT("ACQL"),$D(MAGGFDA(2005,"+1,",101)):MAGGFDA(2005,"+1,",101),1:$P($G(MAGACT("ACQS")),";",2)) 94 . ; ACQS was a 2 ';' piece value with Acq Location (HOSPITAL LOCATION) as 2nd piece 95 . ; now it is sent as it's own value in ACQL 96 . D UPDATE^DIE("","MAGDFDA","MAGDIEN","MAGDXE") 97 . S MAGGFDA(2005,"+1,",107)=MAGDIEN(1) 98 ; 99 ; Check the last entry in Audit File to see if it is greater than 100 ; last image in Image File. IF yes, change Image File (0) node entry. 101 I ($O(^MAG(2005,"A"),-1)<$O(^MAG(2005.1,"A"),-1)) S $P(^MAG(2005,0),U,3)=$O(^MAG(2005.1,"A"),-1) 102 ; 103 Q 104 PATCHK(MAGR) ; This uses the FDA Array and checks the Imaging Patient against the Procedure patient 105 ; 106 N MAGDFN,PX,PXDA,MAGY 107 S PX=$G(MAGGFDA(2005,"+1,",16)) 108 S PXDA=$G(MAGGFDA(2005,"+1,",17)) 109 I 'PX S MAGR=1 Q ; This is a category, or an Image of a group (no parent pointer) 110 S MAGDFN=MAGGFDA(2005,"+1,",5) 111 I (PX=8925) D Q 112 . I '$D(^TIU(8925,PXDA)) S MAGR="0^Invalid TIU Entry Number: "_PXDA Q 113 . D DATA^MAGGNTI(.MAGY,PXDA) 114 . I '(MAGDFN=$P(MAGY,U,4)) S MAGR="0^Procedure and Imaging patients don't match." Q 115 . S MAGR=1 116 Q 117 OBJTYPE ; This call uses the EXT and computes an Object Type 118 N MTYPE 119 I '$L($G(MAGACT("EXT"))) Q 120 S MTYPE=$O(^MAG(2005.02,"AD",MAGACT("EXT"),"")) 121 ;I 'MTYPE Q 122 ;TODO : Answer question, do we want to have a default Image type ? 123 I 'MTYPE S MTYPE=1 124 S MAGGFDA(2005,"+1,",3)=MTYPE 125 Q 126 ISTYPADM(TYPE) ; Returns 1 if this is an Admin Type 127 N CL 128 I '$G(TYPE) Q 0 129 S CL=$$GET1^DIQ(2005.83,TYPE,1,"E") 130 Q $S($E(CL,1,5)="ADMIN":1,1:0) 131 PROCTEXT ;This call uses flds 16 and 17 to compute fld #6 PROCEDURE TEXT [8F] 132 ; We are here because fld #6 PROCEDURE [8F] is null. 133 ; If a pointer to a package is in the data, (flds 16 and 17) 134 ; get fld #6 from that , if not then treat it as an UNASSIGNED image 135 ; i.e. Category UNASSIGNED. 136 N MAGYPX,PARENT,PARIEN,PXDESC 137 S PARENT=$G(MAGGFDA(2005,"+1,",16)) 138 S PARIEN=$G(MAGGFDA(2005,"+1,",17)) 139 ; 140 I (PARENT=8925),(PARIEN]"") D Q 141 . D DATA^MAGGNTI(.MAGYPX,PARIEN) 142 . S MAGGFDA(2005,"+1,",6)=$P(MAGYPX,U,2) 143 ;TODO; create calls to get default procedure desc for all specialties 144 ; AND default to NONE if a TYPE and no PARENT data File (fld 16) 145 ; If a Parent pointer exists, and it isn't TIU, for now set "NO Description" 146 I PARENT]"" S MAGGFDA(2005,"+1,",6)="No Description" Q 147 ; 148 ; Do we have a pointer to a MAG DESCRIPTIVE CATEGORY 149 I ($G(MAGGFDA(2005,"+1,",100))]"") D Q 150 . S MAGGFDA(2005,"+1,",6)=$P(^MAG(2005.81,MAGGFDA(2005,"+1,",100),0),U,1) 151 ; 152 ; If a new child of a Group, use that Proc Desc 153 I $G(MAGGFDA(2005,"+1,",14))]"" D Q 154 . S MAGGFDA(2005,"+1,",6)=$P(^MAG(2005,MAGGFDA(2005,"+1,",14),0),U,8) 155 ; 156 ; Parent="", and no Category pointer, then we Call it UNASSIGNED 157 S MAGGFDA(2005,"+1,",100)=$O(^MAG(2005.81,"B","UNASSIGNED","")) 158 S MAGGFDA(2005,"+1,",6)="UNASSIGNED" 159 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGSIU2.m
r613 r623 1 MAGGSIU2 ;WOIFO/GEK - Utilities for Image Add/Modify ; [ 12/27/2000 10:49 ] 2 ;;3.0;IMAGING;**7,8,85,59**;Nov 27, 2007;Build 20 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 MAKEFDA(MAGGFDA,MAGARRAY,MAGACT,MAGCHLD,MAGGRP,MAGGWP) ; 21 ; Create the FileMan FDA Array 22 ; Create Imaging Action Codes Array (for Pre and Post processing) 23 N MAGGFLD,MAGGDAT,GRPCT,WPCT,Z 24 S Z="" F S Z=$O(MAGARRAY(Z)) Q:Z="" D I $L(MAGERR) Q 25 . S MAGGFLD=$P(MAGARRAY(Z),U,1),MAGGDAT=$P(MAGARRAY(Z),U,2,99) 26 . ; If this entry is one of the action codes, store it in the action array. 27 . I $$ACTCODE^MAGGSIV(MAGGFLD) S MAGACT(MAGGFLD)=MAGGDAT Q 28 . ; 29 . ; If we are Creating a Group Entry, add any Images that are to be members of this group. 30 . I MAGGFLD=2005.04 D Q 31 . . S MAGGRP=1 32 . . I '+MAGGDAT Q ; making a group entry, with no group entries yet. This is OK. 33 . . S MAGCHLD(MAGGDAT)="" 34 . . S GRPCT=GRPCT+1 35 . . S MAGGFDA(2005.04,"+"_GRPCT_",+1,",.01)=MAGGDAT 36 . ; 37 . ; if we are getting a WP for Long Desc, set array to pass. 38 . I MAGGFLD=11 D ; this is one line of the WP Long Desc field. 39 . . S WPCT=WPCT+1,MAGGWP(WPCT)=MAGGDAT 40 . . S MAGGFDA(2005,"+1,",11)="MAGGWP" 41 . ; Set the Node for the UPDATE^DIC Call. 42 . S MAGGFDA(2005,"+1,",MAGGFLD)=MAGGDAT 43 . Q 44 ; Patch 8. Special processing for field 107 (ACQUISITION DEVICE) 45 ; We'll change any MAGGFDA(2005,"+1,",107) to MAGACT("ACQD") 46 ; This way the PRE processing of the array will check and create a new 47 ; ACQUISITION DEVICE file entry, if needed. 48 I $D(MAGACT("107")) S MAGACT("ACQD")=MAGACT("107") K MAGACT("107") 49 I $D(MAGGFDA(2005,"+1,",107)) S MAGACT("ACQD")=MAGGFDA(2005,"+1,",107) K MAGGFDA(2005,"+1,",107) 50 Q 51 REQPARAM() ;Do required parameters have values. Called from MAGGSIUI 52 ; VARIABLES ARE SET AND KILLED IN THAT ROUTINE. 53 N CT 54 S CT=0 55 S MAGRY(0)="1^Checking for Required parameter values..." 56 I IDFN="" S CT=CT+1,MAGRY(CT)="DFN is Required. !" 57 I '$D(IMAGES),'CMTH S CT=CT+1,MAGRY(CT)="List of Images is Required. !" 58 ; 59 I (PXPKG=""),(DOCCTG=""),(IXTYPE="") S CT=CT+1,MAGRY(CT)="Procedure or Category or Index Type is Required. !" 60 I (PXPKG'=""),(DOCCTG'="") S CT=CT+1,MAGRY(CT)="Procedure OR Document Category. Not BOTH. !" 61 ; 62 I (PXPKG'=""),(PXIEN="") S CT=CT+1,MAGRY(CT)="Procedure IEN is Required. !" 63 I (PXPKG=""),(PXIEN'="") S CT=CT+1,MAGRY(CT)="Procedure Package is Required. !" 64 I (PXPKG'=""),(PXDT="") S CT=CT+1,MAGRY(CT)="Procedure Date is Required. !" 65 ; 66 ;Patch 8 index field check... could be using Patch 7 or Patch 8. 67 ; We're this far, so either PXIEN or DOCCTG is defined 68 I (IXTYPE'=""),(DOCCTG'="") S CT=CT+1,MAGRY(CT)="Image Type OR Document Category. Not BOTH. !" 69 ; MAGGSIA computes PACKAGE #40 and CLASS #41 when adding an Image (2005) entry. 70 ; 71 I TRKID="" S CT=CT+1,MAGRY(CT)="Tracking ID is Required. !" 72 I ACQD="" S CT=CT+1,MAGRY(CT)="Acquisition Device is Required. !" 73 ; ACQS ( could ? ) default to users institution i.e. DUZ(2) 74 I (ACQS="")&(ACQN="") S CT=CT+1,MAGRY(CT)="Acquisition Site IEN or Station Number is Required. !" 75 I (ACQS]"")&(ACQN]"") S CT=CT+1,MAGRY(CT)="Station IEN or Station Number, Not BOTH. !" 76 ; 77 I STSCB="" S CT=CT+1,MAGRY(CT)="Status Handler (TAG^ROUTINE) is Required. !" 78 ; 79 I (DOCCTG'=""),(DOCDT="") S CT=CT+1,MAGRY(CT)="Document Date is Required. !" 80 ; 81 I (CT>0) S MAGRY(0)="0^Required parameter is null" Q MAGRY(0) 82 ;Checks to stop Duplicate or incorrect Tracking ID's 83 ; //TODO: ?? check the Queue File, is this Tracking ID already Queued. 84 I (TRKID'="") I $D(^MAG(2005,"ATRKID",TRKID)) S MAGRY(0)="0^Tracking ID Must be Unique !" 85 I (TRKID'="") I ($L(TRKID,";")<2) S MAGRY(0)="0^Tracking ID Must have "";"" Delimiter" 86 ; 87 Q MAGRY(0) 1 MAGGSIU2 ;WOIFO/GEK - Utilities for Image Add/Modify ; [ 12/27/2000 10:49 ] 2 ;;3.0;IMAGING;**7,8,85**;16-March-2007;;Build 1039 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 ;; | 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 Q 19 MAKEFDA(MAGGFDA,MAGARRAY,MAGACT,MAGCHLD,MAGGRP,MAGGWP) ; 20 ; Create the FileMan FDA Array 21 ; Create Imaging Action Codes Array (for Pre and Post processing) 22 N MAGGFLD,MAGGDAT,GRPCT,WPCT,Z 23 S Z="" F S Z=$O(MAGARRAY(Z)) Q:Z="" D I $L(MAGERR) Q 24 . S MAGGFLD=$P(MAGARRAY(Z),U,1),MAGGDAT=$P(MAGARRAY(Z),U,2,99) 25 . ; If this entry is one of the action codes, store it in the action array. 26 . I $$ACTCODE^MAGGSIV(MAGGFLD) S MAGACT(MAGGFLD)=MAGGDAT Q 27 . ; 28 . ; If we are Creating a Group Entry, add any Images that are to be members of this group. 29 . I MAGGFLD=2005.04 D Q 30 . . S MAGGRP=1 31 . . I '+MAGGDAT Q ; making a group entry, with no group entries yet. This is OK. 32 . . S MAGCHLD(MAGGDAT)="" 33 . . S GRPCT=GRPCT+1 34 . . S MAGGFDA(2005.04,"+"_GRPCT_",+1,",.01)=MAGGDAT 35 . ; 36 . ; if we are getting a WP for Long Desc, set array to pass. 37 . I MAGGFLD=11 D ; this is one line of the WP Long Desc field. 38 . . S WPCT=WPCT+1,MAGGWP(WPCT)=MAGGDAT 39 . . S MAGGFDA(2005,"+1,",11)="MAGGWP" 40 . ; Set the Node for the UPDATE^DIC Call. 41 . S MAGGFDA(2005,"+1,",MAGGFLD)=MAGGDAT 42 . Q 43 ; Patch 8. Special processing for field 107 (ACQUISITION DEVICE) 44 ; We'll change any MAGGFDA(2005,"+1,",107) to MAGACT("ACQD") 45 ; This way the PRE processing of the array will check and create a new 46 ; ACQUISITION DEVICE file entry, if needed. 47 I $D(MAGACT("107")) S MAGACT("ACQD")=MAGACT("107") K MAGACT("107") 48 I $D(MAGGFDA(2005,"+1,",107)) S MAGACT("ACQD")=MAGGFDA(2005,"+1,",107) K MAGGFDA(2005,"+1,",107) 49 Q 50 REQPARAM() ;Do required parameters have values. Called from MAGGSIUI 51 ; VARIABLES ARE SET AND KILLED IN THAT ROUTINE. 52 N CT 53 S CT=0 54 S MAGRY(0)="1^Checking for Required parameter values..." 55 I IDFN="" S CT=CT+1,MAGRY(CT)="DFN is Required. !" 56 I '$D(IMAGES),'CMTH S CT=CT+1,MAGRY(CT)="List of Images is Required. !" 57 ; 58 I (PXPKG=""),(DOCCTG=""),(IXTYPE="") S CT=CT+1,MAGRY(CT)="Procedure or Category or Index Type is Required. !" 59 I (PXPKG'=""),(DOCCTG'="") S CT=CT+1,MAGRY(CT)="Procedure OR Document Category. Not BOTH. !" 60 ; 61 I (PXPKG'=""),(PXIEN="") S CT=CT+1,MAGRY(CT)="Procedure IEN is Required. !" 62 I (PXPKG=""),(PXIEN'="") S CT=CT+1,MAGRY(CT)="Procedure Package is Required. !" 63 I (PXPKG'=""),(PXDT="") S CT=CT+1,MAGRY(CT)="Procedure Date is Required. !" 64 ; 65 ;Patch 8 index field check... could be using Patch 7 or Patch 8. 66 ; We're this far, so either PXIEN or DOCCTG is defined 67 I (IXTYPE'=""),(DOCCTG'="") S CT=CT+1,MAGRY(CT)="Image Type OR Document Category. Not BOTH. !" 68 ; MAGGSIA computes PACKAGE #40 and CLASS #41 when adding an Image (2005) entry. 69 ; 70 I TRKID="" S CT=CT+1,MAGRY(CT)="Tracking ID is Required. !" 71 I ACQD="" S CT=CT+1,MAGRY(CT)="Acquisition Device is Required. !" 72 ; ACQS ( could ? ) default to users institution i.e. DUZ(2) 73 I (ACQS="")&(ACQN="") S CT=CT+1,MAGRY(CT)="Acquisition Site IEN or Station Number is Required. !" 74 I (ACQS]"")&(ACQN]"") S CT=CT+1,MAGRY(CT)="Station IEN or Station Number, Not BOTH. !" 75 ; 76 I STSCB="" S CT=CT+1,MAGRY(CT)="Status Handler (TAG^ROUTINE) is Required. !" 77 ; 78 I (DOCCTG'=""),(DOCDT="") S CT=CT+1,MAGRY(CT)="Document Date is Required. !" 79 ; 80 I (CT>0) S MAGRY(0)="0^Required parameter is null" Q MAGRY(0) 81 ;Checks to stop Duplicate or incorrect Tracking ID's 82 ; //TODO: ?? check the Queue File, is this Tracking ID already Queued. 83 I (TRKID'="") I $D(^MAG(2005,"ATRKID",TRKID)) S MAGRY(0)="0^Tracking ID Must be Unique !" 84 I (TRKID'="") I ($L(TRKID,";")<2) S MAGRY(0)="0^Tracking ID Must have "";"" Delimiter" 85 ; 86 Q MAGRY(0) -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGSIUI.m
r613 r623 1 MAGGSIUI ;WOIFO/GEK - Utilities for Image Import API 2 ;;3.0;IMAGING;**7,8,48,20,85,59**;Nov 27, 2007;Build 20 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 REMOTE(MAGRY,MAGDATA) ;RPC [MAG4 REMOTE IMPORT] 21 ; Import Images from a Windows App, by sending an array. 22 I ($D(MAGDATA)<10) S MAGRY(0)="0^Missing Data Array !." Q 23 N I,J,ICT,DCT,MAGIX,IMAGES,ERR,X,Z 24 S (ERR,ICT,DCT)=0 25 S I="" F S I=$O(MAGDATA(I)) Q:I="" S X=MAGDATA(I) D Q:ERR 26 . S Z=$P(X,U) 27 . I (X="")!(Z="") S MAGRY(0)="0^INVALID Data in Input Array: Node "_I_"="""_X_"",ERR=1 Q 28 . I Z="IMAGE" S ICT=ICT+1,IMAGES(ICT)=$P(X,U,2,99) Q 29 . S DCT=DCT+1,MAGIX(Z)=$P(X,U,2,99) 30 I 'ERR D IMPORT(.MAGRY,.IMAGES,.MAGIX) 31 Q 32 ; 33 IMPORT(MAGRY,IMAGES,MAGIX) ; 34 ; "IDFN","PXPKG","PXIEN","PXDT","TRKID","ACQD","ACQS","ACQL","STSCB","ITYPE", 35 ; "CMTH","CDUZ","USERNAME","PASSWORD","GDESC","DFLG","TRTYPE","DOCCTG","DOCDT", 36 ; "IXTYPE","IXSPEC","IXPROC","IXORIGIN ;Patch 8: Added Index fields 37 ; 38 ;Index fields Package, Class ("IXPKG" and "IXCLS") aren't accepted 39 ; they are computed values. 40 ; - Convert field codes into an Input Data Array, 41 ; validate, then set the Import Queue 42 ; 43 N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) 44 K MAGRY S MAGRY(0)="0^Importing data..." 45 N APISESS,MWIN 46 S MWIN=$$BROKER^XWBLIB 47 N PRM,CT,MAGA,MAGY,MAGTN,TNODE 48 N IDFN,PXPKG,PXIEN,PXDT,TRKID,ACQD,ACQS,ACQN,ACQL,STSCB,ITYPE,CMTH,CDUZ,USERNAME,PASSWORD 49 N GDESC,DFLG,TRTYPE,DOCCTG,DOCDT,IXPKG,IXCLS,IXTYPE,IXSPEC,IXPROC,IXORIGIN,MAX,SITEPLC 50 N ERR,MAGTM,QTIME,MAGIXZ 51 S CT=0,ERR=0 52 M MAGIXZ=MAGIX 53 ; DON'T CONVERT ACQS(really a ACQN) to a REAL ACQS, leave it ACQS to be converted by MAGGSIV 54 ; 55 F PRM="IDFN","PXPKG","PXIEN","PXDT","TRKID","ACQD","ACQS","ACQN","ACQL","STSCB","ITYPE","CMTH","CDUZ","USERNAME","PASSWORD","GDESC","DFLG","TRTYPE","DOCCTG","DOCDT","IXTYPE","IXSPEC","IXPROC","IXORIGIN" D 56 . S @PRM=$G(MAGIX(PRM)) K MAGIX(PRM) ; P8T14 added K.. and next line to account for field numbers later. 57 . Q 58 S PRM="" F S PRM=$O(MAGIX(PRM)) Q:PRM="" D SA(PRM,$G(MAGIX(PRM))) 59 ; 60 S MAGTM=$$NOW^XLFDT 61 I '$G(DUZ) S MAGRY(0)="0^DUZ is undefined." Q ;D ERRTRK Q 62 ; DATATRK sets Global var. APISESS = IEN of Session File. 63 D DATATRK 64 I '$$REQPARAM^MAGGSIU2() D ERRTRK Q 65 S MAX=$P(TRKID,";",1)="MAX" 66 ;I 'MWIN W !,"----------------" ZW W !,"---------------------" 67 ; Workaround VIC (Maximus) is sending Station Number 68 ; we'll convert to Institution IEN 69 I MAX&(ACQS]"") D Q:ERR 70 . S X=$O(^DIC(4,"D",ACQS,"")) 71 . I X="" S MAGRY(0)="0^Invalid Station Number:(Maximus ACQS): "_ACQS,ERR=1 Q 72 . S SITEPLC=X ; We need the Place for the Queue 73 . ;S ACQS=X Out in 85. Don't change to ACQS, that's done in VAL^MAGGSIV 74 . Q 75 ; Change to Allow ACQN - STATION NUMBER from INSTITUTION File. 76 I $L(ACQN) D Q:ERR 77 . S ACQS=$O(^DIC(4,"D",ACQN,"")) 78 . I ACQS="" S MAGRY(0)="0^Invalid STATION NUMBER: (ACQN): "_ACQN,ERR=1 Q 79 . ; VAL^MAGGSIV Will fail if ACQS is real and this is Maximus 80 . I MAX S ACQS=ACQN K ACQN Q 81 . S ACQN="" ;We converted to ACQS, lets make "" so no confusion later. 82 . Q 83 ; 84 ; Set the input data array 85 D SA(5,IDFN) ;PATIENT 86 D SA(16,PXPKG) ;PARENT DATA FILE 87 D SA(17,PXIEN) ;PARENT GLOBAL ROOT 88 D SA(15,PXDT) ; PROCEDURE/EXAM DATE/TIME 89 D SA(108,TRKID) ; TRACKING ID (new) 90 D SA("ACQD",ACQD) ; ACQUISTION DEVICE ( new ) 91 I 'MAX S SITEPLC=ACQS D SA(.05,ACQS) ; this used to be fld 105 92 D SA(101,ACQL) 93 D SA("STATUSCB",STSCB) ; STATUS CALLBACK (was referred to as ExceptionHandler) 94 D SA(3,ITYPE) ; OBJECT TYPE 95 D SA("CALLMTH",CMTH) ; CALL METHOD 96 D SA(8,CDUZ) ; IMAGE SAVE BY 97 D SA("USERNAME",USERNAME) 98 D SA("PASSWORD",PASSWORD) 99 D SA(10,GDESC) ; SHORT DESCRIPTION 100 D SA("DELFLAG",DFLG) ; DELETE FLAG 101 D SA("TRNSTYP",TRTYPE) ; TRANSACTION TYPE 102 D SA(100,DOCCTG) ; document Main category 103 D SA(110,DOCDT) ; document date 104 ; Patch 8 allows Index fields to be imported. 105 ;"IXTYPE","IXSPEC","IXPROC","IXORIGIN" 106 D SA(42,IXTYPE) ; Index Type 107 D SA(43,IXPROC) ; Index Proc/Event 108 D SA(44,IXSPEC) ; Index Spec/SubSpec 109 D SA(45,IXORIGIN) ; Index Origin 110 ; 111 D VAL^MAGGSIV(.MAGRY,.MAGA,1) I 'MAGRY(0) D ERRTRK Q 112 I MAX D SA(.05,ACQS) ; this used to be fld 105 113 ; Also Done in MAGGSIA when image is being Saved. 114 I '$$VALINDEX^MAGGSIV1(.MAGRY,IXTYPE,IXSPEC,IXPROC) D ERRTRK Q 115 ; Array of Images to Import 116 D SI("IMAGES",.IMAGES) I 'MAGRY(0) D ERRTRK Q 117 K MAGRY 118 ; 119 I TRTYPE="NOQUEUE" M MAGRY=MAGA S MAGRY(0)="1^" Q 120 ; This call is for BP 121 S QTIME=$$NOW^XLFDT 122 ; p85 use ACQS instead of DUZ(2) 123 S MAGY=$$IMPORT^MAGBAPI(.MAGA,STSCB,TRKID,$$PLACE^MAGBAPI(SITEPLC)) 124 ; Return Queue Number 125 I 'MAGY S MAGRY(0)="0^Error Setting Queue: "_$P(MAGY,U,2),MAGY=TRKID 126 E S MAGRY(0)=MAGY_"^Data has been Queued.",MAGY=+MAGY 127 ; for Testing, we'll track input array, and results array by Queue number. 128 I 'MAGRY(0) D ERRTRK Q 129 D LOGRES^MAGGSIU3(.MAGRY,0,APISESS) 130 ; 131 Q 132 ; 133 SA(FLD,VAL) ;Set the data array with Fld,Value 134 Q:VAL="" 135 S CT=CT+1,MAGA(CT)=FLD_U_VAL 136 Q 137 SI(FLD,ARR) ;Set the images into the data array 138 ; 'CT' is a global variable. 139 S MAGRY(0)="1^Valid Image file Extensions." 140 N I,MAGEXT,MAGFN 141 S I="" F S I=$O(ARR(I)) Q:I="" D Q:'MAGRY(0) 142 . S CT=CT+1 143 . I ($L($P(ARR(I),U),".")<2) S MAGRY(0)="0^Invalid file name: "_ARR(I) Q 144 . S MAGFN=$P(ARR(I),"^") 145 . S MAGEXT=$$UP^XLFSTR($P(MAGFN,".",$L(MAGFN,"."))) 146 . I '$D(^MAG(2005.021,"B",MAGEXT)) S MAGRY(0)="0^Unsupported File Type:'."_MAGEXT Q 147 . S MAGA(CT)="IMAGE"_U_ARR(I) 148 Q 149 GETARR(ARR,QNUM) ;RPC [MAG4 DATA FROM IMPORT QUEUE] 150 ; Get the Input Array from Queue Number 151 I '$G(QNUM) S ARR(0)="0^INVALID QUEUE Number: "_$G(QNUM) Q 152 D IMPAR^MAGQBUT2(.ARR,QNUM) 153 Q 154 STATUSCB(MAGRY,STAT,TAGRTN,DOCB) ;RPC [MAG4 STATUS CALLBACK] 155 ; Report Status to calling application 156 ; Now the IAPI and OCX make this call. Not BP 157 ; STAT(0)= "0^message" or "1^message" 158 ; STAT(1)=TRKID, 159 ; (2)=QNUM 160 ; (3..N)=warnings 161 ;TAGRTN : The TAG^RTN to call with Status Array 162 ;DOCB : (1|0) to suppress execution of Status Callback 163 ; 164 N APISESS,TRKID,CBMSG 165 S DOCB=$S($G(DOCB)="":1,1:+$G(DOCB)) ; Default to TRUE 166 ; Old Import API and BP that made this call, will work : DOCB defaults to 1 167 S CBMSG=$S(DOCB:"Status Callback was called",1:"Status Callback was NOT called") 168 I DOCB D @(TAGRTN_"(.STAT)") 169 S MAGRY="1^"_CBMSG 170 S STAT($O(STAT(""),-1)+1)=MAGRY 171 S TRKID=$G(STAT(1)) 172 ; Log Results. Always. 173 I $L(TRKID) D 174 . S APISESS=$$SES4TRK^MAGGSIU3(TRKID) ; 175 . I APISESS D LOGRES^MAGGSIU3(.STAT,0,APISESS) ;gek/send Tracking ID to log status 176 Q 177 TESTCB(STATARR) ;TESTING. This is the Status Callback for testing. 178 ; the STATUSCB property must have a Valid "M" TAG^ROUTINE 179 ; TAG TESTCB exists so that STATUSCB validates successfully 180 Q 181 ERRTRK ;Track bad data and Quit 182 N I 183 D LOGERR^MAGGSERR("---- New Error ----",APISESS) 184 S I="" F S I=$O(MAGRY(I)) Q:I="" D LOGERR^MAGGSERR(MAGRY(I),APISESS) 185 Q 186 DATATRK ; Track the raw data being sent to the Import API. 187 ; Log the data being imported. Results are logged later. 188 N XY 189 S APISESS=$$LOG^MAGGSIU3(.XY,.MAGIXZ,.IMAGES,IDFN,ACQD,TRKID) 190 Q 191 ERR ; ERROR TRAP FOR Import API 192 N ERR S ERR=$$EC^%ZOSV 193 S MAGRY(0)="0^ETRAP: "_ERR 194 D @^%ZOSF("ERRTN") 195 I $G(APISESS) D ERRTRK 196 Q 1 MAGGSIUI ;WOIFO/GEK - Utilities for Image Import API 2 ;;3.0;IMAGING;**7,8,48,20,85**;16-March-2007;;Build 1039 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 ;; | 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 Q 19 REMOTE(MAGRY,MAGDATA) ;RPC [MAG4 REMOTE IMPORT] 20 ; Import Images from a Windows App, by sending an array. 21 I ($D(MAGDATA)<10) S MAGRY(0)="0^Missing Data Array !." Q 22 N I,J,ICT,DCT,MAGIX,IMAGES,ERR,X,Z 23 S (ERR,ICT,DCT)=0 24 S I="" F S I=$O(MAGDATA(I)) Q:I="" S X=MAGDATA(I) D Q:ERR 25 . S Z=$P(X,U) 26 . I (X="")!(Z="") S MAGRY(0)="0^INVALID Data in Input Array: Node "_I_"="""_X_"",ERR=1 Q 27 . I Z="IMAGE" S ICT=ICT+1,IMAGES(ICT)=$P(X,U,2,99) Q 28 . S DCT=DCT+1,MAGIX(Z)=$P(X,U,2,99) 29 I 'ERR D IMPORT(.MAGRY,.IMAGES,.MAGIX) 30 Q 31 ; 32 IMPORT(MAGRY,IMAGES,MAGIX) ; 33 ; "IDFN","PXPKG","PXIEN","PXDT","TRKID","ACQD","ACQS","ACQL","STSCB","ITYPE", 34 ; "CMTH","CDUZ","USERNAME","PASSWORD","GDESC","DFLG","TRTYPE","DOCCTG","DOCDT", 35 ; "IXTYPE","IXSPEC","IXPROC","IXORIGIN ;Patch 8: Added Index fields 36 ; 37 ;Index fields Package, Class ("IXPKG" and "IXCLS") aren't accepted 38 ; they are computed values. 39 ; - Convert field codes into an Input Data Array, 40 ; validate, then set the Import Queue 41 ; 42 N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) 43 K MAGRY S MAGRY(0)="0^Importing data..." 44 N APISESS,MWIN 45 S MWIN=$$BROKER^XWBLIB 46 N PRM,CT,MAGA,MAGY,MAGTN,TNODE 47 N IDFN,PXPKG,PXIEN,PXDT,TRKID,ACQD,ACQS,ACQN,ACQL,STSCB,ITYPE,CMTH,CDUZ,USERNAME,PASSWORD 48 N GDESC,DFLG,TRTYPE,DOCCTG,DOCDT,IXPKG,IXCLS,IXTYPE,IXSPEC,IXPROC,IXORIGIN,MAX,SITEPLC 49 N ERR,MAGTM,QTIME,MAGIXZ 50 S CT=0,ERR=0 51 M MAGIXZ=MAGIX 52 ; DON'T CONVERT ACQS(really a ACQN) to a REAL ACQS, leave it ACQS to be converted by MAGGSIV 53 ; 54 F PRM="IDFN","PXPKG","PXIEN","PXDT","TRKID","ACQD","ACQS","ACQN","ACQL","STSCB","ITYPE","CMTH","CDUZ","USERNAME","PASSWORD","GDESC","DFLG","TRTYPE","DOCCTG","DOCDT","IXTYPE","IXSPEC","IXPROC","IXORIGIN" D 55 . S @PRM=$G(MAGIX(PRM)) K MAGIX(PRM) ; P8T14 added K.. and next line to account for field numbers later. 56 . Q 57 S PRM="" F S PRM=$O(MAGIX(PRM)) Q:PRM="" D SA(PRM,$G(MAGIX(PRM))) 58 ; 59 S MAGTM=$$NOW^XLFDT 60 I '$G(DUZ) S MAGRY(0)="0^DUZ is undefined." Q ;D ERRTRK Q 61 ; DATATRK sets Global var. APISESS = IEN of Session File. 62 D DATATRK 63 I '$$REQPARAM^MAGGSIU2() D ERRTRK Q 64 S MAX=$P(TRKID,";",1)="MAX" 65 ;I 'MWIN W !,"----------------" ZW W !,"---------------------" 66 ; Workaround VIC (Maximus) is sending Station Number 67 ; we'll convert to Institution IEN 68 I MAX&(ACQS]"") D Q:ERR 69 . S X=$O(^DIC(4,"D",ACQS,"")) 70 . I X="" S MAGRY(0)="0^Invalid Station Number:(Maximus ACQS): "_ACQS,ERR=1 Q 71 . S SITEPLC=X ; We need the Place for the Queue 72 . ;S ACQS=X Out in 85. Don't change to ACQS, that's done in VAL^MAGGSIV 73 . Q 74 ; Change to Allow ACQN - STATION NUMBER from INSTITUTION File. 75 I $L(ACQN) D Q:ERR 76 . S ACQS=$O(^DIC(4,"D",ACQN,"")) 77 . I ACQS="" S MAGRY(0)="0^Invalid STATION NUMBER: (ACQN): "_ACQN,ERR=1 Q 78 . ; VAL^MAGGSIV Will fail if ACQS is real and this is Maximus 79 . I MAX S ACQS=ACQN K ACQN Q 80 . S ACQN="" ;We converted to ACQS, lets make "" so no confusion later. 81 . Q 82 ; 83 ; Set the input data array 84 D SA(5,IDFN) ;PATIENT 85 D SA(16,PXPKG) ;PARENT DATA FILE 86 D SA(17,PXIEN) ;PARENT GLOBAL ROOT 87 D SA(15,PXDT) ; PROCEDURE/EXAM DATE/TIME 88 D SA(108,TRKID) ; TRACKING ID (new) 89 D SA("ACQD",ACQD) ; ACQUISTION DEVICE ( new ) 90 I 'MAX S SITEPLC=ACQS D SA(.05,ACQS) ; this used to be fld 105 91 D SA(101,ACQL) 92 D SA("STATUSCB",STSCB) ; STATUS CALLBACK (was referred to as ExceptionHandler) 93 D SA(3,ITYPE) ; OBJECT TYPE 94 D SA("CALLMTH",CMTH) ; CALL METHOD 95 D SA(8,CDUZ) ; IMAGE SAVE BY 96 D SA("USERNAME",USERNAME) 97 D SA("PASSWORD",PASSWORD) 98 D SA(10,GDESC) ; SHORT DESCRIPTION 99 D SA("DELFLAG",DFLG) ; DELETE FLAG 100 D SA("TRNSTYP",TRTYPE) ; TRANSACTION TYPE 101 D SA(100,DOCCTG) ; document Main category 102 D SA(110,DOCDT) ; document date 103 ; Patch 8 allows Index fields to be imported. 104 ;"IXTYPE","IXSPEC","IXPROC","IXORIGIN" 105 D SA(42,IXTYPE) ; Index Type 106 D SA(43,IXPROC) ; Index Proc/Event 107 D SA(44,IXSPEC) ; Index Spec/SubSpec 108 D SA(45,IXORIGIN) ; Index Origin 109 ; 110 D VAL^MAGGSIV(.MAGRY,.MAGA,1) I 'MAGRY(0) D ERRTRK Q 111 I MAX D SA(.05,ACQS) ; this used to be fld 105 112 ; Also Done in MAGGSIA when image is being Saved. 113 I '$$VALINDEX^MAGGSIV1(.MAGRY,IXTYPE,IXSPEC,IXPROC) D ERRTRK Q 114 ; Array of Images to Import 115 D SI("IMAGES",.IMAGES) I 'MAGRY(0) D ERRTRK Q 116 K MAGRY 117 ; 118 I TRTYPE="NOQUEUE" M MAGRY=MAGA S MAGRY(0)="1^" Q 119 ; This call is for BP 120 S QTIME=$$NOW^XLFDT 121 ; p85 use ACQS instead of DUZ(2) 122 S MAGY=$$IMPORT^MAGBAPI(.MAGA,STSCB,TRKID,$$PLACE^MAGBAPI(SITEPLC)) 123 ; Return Queue Number 124 I 'MAGY S MAGRY(0)="0^Error Setting Queue: "_$P(MAGY,U,2),MAGY=TRKID 125 E S MAGRY(0)=MAGY_"^Data has been Queued.",MAGY=+MAGY 126 ; for Testing, we'll track input array, and results array by Queue number. 127 I 'MAGRY(0) D ERRTRK Q 128 D LOGRES^MAGGSIU3(.MAGRY,0,APISESS) 129 ; 130 Q 131 ; 132 SA(FLD,VAL) ;Set the data array with Fld,Value 133 Q:VAL="" 134 S CT=CT+1,MAGA(CT)=FLD_U_VAL 135 Q 136 SI(FLD,ARR) ;Set the images into the data array 137 ; 'CT' is a global variable. 138 S MAGRY(0)="1^Valid Image file Extensions." 139 N I,MAGEXT,MAGFN 140 S I="" F S I=$O(ARR(I)) Q:I="" D Q:'MAGRY(0) 141 . S CT=CT+1 142 . I ($L($P(ARR(I),U),".")<2) S MAGRY(0)="0^Invalid file name: "_ARR(I) Q 143 . S MAGFN=$P(ARR(I),"^") 144 . S MAGEXT=$$UP^XLFSTR($P(MAGFN,".",$L(MAGFN,"."))) 145 . I '$D(^MAG(2005.021,"B",MAGEXT)) S MAGRY(0)="0^Unsupported File Type:'."_MAGEXT Q 146 . S MAGA(CT)="IMAGE"_U_ARR(I) 147 Q 148 GETARR(ARR,QNUM) ;RPC [MAG4 DATA FROM IMPORT QUEUE] 149 ; Get the Input Array from Queue Number 150 I '$G(QNUM) S ARR(0)="0^INVALID QUEUE Number: "_$G(QNUM) Q 151 D IMPAR^MAGQBUT2(.ARR,QNUM) 152 Q 153 STATUSCB(MAGRY,STAT,TAGRTN,DOCB) ;RPC [MAG4 STATUS CALLBACK] 154 ; Report Status to calling application 155 ; Now the IAPI and OCX make this call. Not BP 156 ; STAT(0)= "0^message" or "1^message" 157 ; STAT(1)=TRKID, 158 ; (2)=QNUM 159 ; (3..N)=warnings 160 ;TAGRTN : The TAG^RTN to call with Status Array 161 ;DOCB : (1|0) to suppress execution of Status Callback 162 ; 163 N APISESS,TRKID,CBMSG 164 S DOCB=$S($G(DOCB)="":1,1:+$G(DOCB)) ; Default to TRUE 165 ; Old Import API and BP that made this call, will work : DOCB defaults to 1 166 S CBMSG=$S(DOCB:"Status Callback was called",1:"Status Callback was NOT called") 167 I DOCB D @(TAGRTN_"(.STAT)") 168 S MAGRY="1^"_CBMSG 169 S STAT($O(STAT(""),-1)+1)=MAGRY 170 S TRKID=$G(STAT(1)) 171 ; Log Results. Always. 172 I $L(TRKID) D 173 . S APISESS=$$SES4TRK^MAGGSIU3(TRKID) ; 174 . I APISESS D LOGRES^MAGGSIU3(.STAT,0,APISESS) ;gek/send Tracking ID to log status 175 Q 176 TESTCB(STATARR) ;TESTING. This is the Status Callback for testing. 177 ; the STATUSCB property must have a Valid "M" TAG^ROUTINE 178 ; TAG TESTCB exists so that STATUSCB validates successfully 179 Q 180 ERRTRK ;Track bad data and Quit 181 N I 182 D LOGERR^MAGGSERR("---- New Error ----",APISESS) 183 S I="" F S I=$O(MAGRY(I)) Q:I="" D LOGERR^MAGGSERR(MAGRY(I),APISESS) 184 Q 185 DATATRK ; Track the raw data being sent to the Import API. 186 ; Log the data being imported. Results are logged later. 187 N XY 188 S APISESS=$$LOG^MAGGSIU3(.XY,.MAGIXZ,.IMAGES,IDFN,ACQD,TRKID) 189 Q 190 ERR ; ERROR TRAP FOR Import API 191 N ERR S ERR=$$EC^%ZOSV 192 S MAGRY(0)="0^ETRAP: "_ERR 193 D @^%ZOSF("ERRTN") 194 I $G(APISESS) D ERRTRK 195 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGSIV.m
r613 r623 1 MAGGSIV ;WOIFO/GEK - Imaging RPC Broker calls. Validate Image data array ; [ 12/27/2000 10:49 ] 2 ;;3.0;IMAGING;**7,8,20,59**;Nov 27, 2007;Build 20 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 VAL(MAGRY,MAGARRAY,ALL) ;RPC [MAG4 VALIDATE DATA] 21 ;Call to Validate the Image Data Array before a new image/modified entry is attempted. 22 ; Called from MAGGSIA, MAGGSIUI and Capture GUI. 23 ; Parameters : 24 ; MAGARRAY - array of 'Field numbers'|'Action codes' and their Values 25 ; MAGARRAY(1)="5^38" Field#: 5 Value: 38 26 ; an example of an action code is the Code for File Extension 27 ; MAGARRAY(2)="EXT^JPG" Action: EXT Value: JPG 28 ; ALL - "1" = Validate ALL fields, returning an array of error messages. 29 ; "0" = Stop validating if an error occurs, return 30 ; the error message in (0) node. 31 ; Return Variable 32 ; MAGRY() - Array 33 ; Successful MAGRY(0) = 1^Image Data is Valid. 34 ; UNsuccessful MAGRY(0) = 0^Error desc 35 ; IF ALL then MAGRY(1..N) =0^Error desc of all errors 36 N MAGGFLD,MAGGDAT,MAGFSPEC,CHKOK,MAGETXT,MAGRET,MAGRES 37 N Y,AITEM,CT,MAGERR,DFNFLAG,DAT1,X,MAX 38 N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) 39 S ALL=$G(ALL) 40 S MAGRY(0)="0^Validating the Data Array..." 41 S MAGERR="",DFNFLAG=0,CT=0 42 ; Do we have any data ? 43 I ($D(MAGARRAY)<10) S MAGRY(0)="0^No input data, Operation CANCELED" Q 44 ; Flag if from Maximus 45 S MAX=0 46 S X="" F S X=$O(MAGARRAY(X)) Q:X="" I $P(MAGARRAY(X),U,1)="TRKID"!($P(MAGARRAY(X),U,1)="108") I $P($P(MAGARRAY(X),U,2),";",1)="MAX" S MAX=1 47 ; Loop through Input Array 48 S AITEM="" F S AITEM=$O(MAGARRAY(AITEM)) Q:AITEM="" D I $L(MAGERR) Q:'ALL S CT=CT+1,MAGRY(CT)=MAGERR,MAGERR="" 49 . S MAGERR="" 50 . S MAGGFLD=$P(MAGARRAY(AITEM),U,1),MAGGDAT=$P(MAGARRAY(AITEM),U,2,99) 51 . I MAGGFLD="" S MAGERR="0^A Field Number/Action Code is required: "_" Item: "_MAGARRAY(AITEM) Q 52 . I MAGGDAT="" S MAGERR="0^A Value is required."_" Item: "_MAGARRAY(AITEM) Q 53 . I MAGGFLD=5 S DFNFLAG=1 54 . ; This inadvertently disallowed Tracking ID's on Group Images. 55 . ;I MAGGFLD=108 I $D(^MAG(2005,"ATRKID",MAGGDAT)) S MAGERR="0^Tracking ID Must be Unique !" Q 56 . I MAGGFLD=108 I ($L(MAGGDAT,";")<2) S MAGRY(0)="0^Tracking ID Must have "";"" Delimiter" Q 57 . ; Check for possible action codes that could be in the array. 58 . I $$ACTCODE(MAGGFLD) D Q 59 . . S DAT1=MAGGDAT 60 . . S Y=$$VALCODE(MAGGFLD,.MAGGDAT) S:'Y MAGERR=Y_" Item: "_MAGARRAY(AITEM) 61 . . I DAT1'=MAGGDAT S MAGARRAY(AITEM)=MAGGFLD_"^"_MAGGDAT 62 . ; If we are adding Multiple Images to a Group, they must be Validated. 63 . ; we could have multiple "2005.04^IENs" in this array. Which means we are 64 . ; adding existing Images to a New/Existing Group. 65 . I MAGGFLD=2005.04 D Q ; 2005.04 isn't the field number, #4 is the field number 66 . . I $G(MAGGDAT,0)=0 Q ;Creating a new Group, with no group entries is the usual way 67 . . ; to do it. Then make successive calls to ADD, Adding each Image to the 68 . . ; Object Group multiple of the Group Parent (fld#14) as it is created. 69 . . I '$D(^MAG(2005,MAGGDAT,0)) S MAGERR="0^Group Object "_MAGGDAT_" doesn't exist"_" Item: "_MAGARRAY(AITEM) 70 . . ; We can't allow adding an image if it already has a group parent. 71 . . I $P(^MAG(2005,MAGGDAT,0),U,10) S MAGERR="0^The Image to be added to the Group, already has a Group Parent"_" Item: "_MAGARRAY(AITEM) 72 . ; if we are getting a WP line of text for Long Desc Field. Can't validate it. 73 . I MAGGFLD=11 Q ; this is a line of the WP Long Desc field. 74 . ; NEW CALL TO VALIDATE FILE,FIELD,DATA 75 . S DAT1=MAGGDAT 76 . I '$$VALID^MAGGSIV1(2005,MAGGFLD,.MAGGDAT,.MAGRES) S MAGERR="0^"_MAGRES Q 77 . I DAT1'=MAGGDAT S MAGARRAY(AITEM)=MAGGFLD_"^"_MAGGDAT 78 . Q 79 ; 80 ; if there was an Error in data we'll quit now. 81 ; If ALL is true, then MAGRY(1...N) will exist if there were errors. 82 I $O(MAGRY(0)) S MAGRY(0)="0^Errors were found in data." Q 83 ; If ALL is false, then MAGERR will exist if there was an error. 84 I $L(MAGERR) S MAGRY(0)=MAGERR Q 85 ; 86 ; If all data is valid we get here. 87 ; Last Test, see if a Patient was in array, 88 ; (Patient is the only Required field check done in this routine). 89 I 'DFNFLAG S MAGRY(0)="0^A Patient DFN is required. " Q 90 S MAGRY(0)="1^Data is Valid." 91 Q 92 ACTCODE(CODE) ;Function that returns True (1) if this code is a valid Import API Action Code 93 ; Patch 8. We're adding 107 as an action code, so it will pass validation even if the entry 94 ; in the Acquisition Device File doesn't exist; 95 ; it will be validated in PRE^MAGGSIA1 and a new Acquisition Device entry made if needed. 96 I ",107,ACQD,IEN,EXT,ABS,JB,WRITE,BIG,DICOMSN,DICOMIN,ACQS,ACQL,STATUSCB,CALLMTH,USERNAME,PASSWORD,DELFLAG,TRNSTYP,"[(","_CODE_",") Q 1 97 Q 0 98 VALCODE(CODE,VALUE) ; We validate the values for the possible action codes 99 N MAGY 100 I VALUE="" Q "0^NO VALUE in Action Code string: """_X_"" 101 ; Patch 8, added 107 102 I ",ACQL,CALLMTH,USERNAME,PASSWORD,"[(","_CODE_",") Q 1 ; NO VALIDATION FOR THESE CODES 103 D @CODE 104 Q MAGY 105 ; Each Tag is a valid Action code 106 IEN I $D(^MAG(2005,VALUE)) S MAGY=1 107 E S MAGY="0^INVALID IMAGE IEN." 108 Q 109 EXT ; code will go here to validate the extension type. i.e. we won't let types .exe .bat .com .zip ... etc. 110 ; Maybe a modification to Object Type file, to have allowable extensions in the file, and a 111 ; cross reference on a new field EXTENSION. The capture workstation wouldn't have to ask the 112 ; user for the file type of each file, and we wouldn't get WORD .DOC files that the user called Color Images 113 ABS ; Meaning: Have the BP create the abstract 114 JB ; Meaning: Have the BP copy the image to the JukeBox 115 BIG ; Meaning: There is a big file also, set the Image File field ? to indicate there is a BIG File. 116 S MAGY=1 117 Q 118 WRITE ; Meaning: This is the Internal Entry (or "PACS") of the WRITE Directory. Images will be written 119 ; here instead of the default WRITE Directory. 120 S MAGY=$$DRIVE^MAGGTU1(VALUE) 121 Q 122 DICOMSN ;Meaning: DICOM Series Number. This will be entered in the Group Object multiple, field #1 123 ;We were validating this as an integer, but it can be anything, no way to validate. 124 S MAGY=1 125 Q 126 DICOMIN ;Meaning: DICOM Image Number. This will be entered in the Group Object multiple, field #2 127 ; We were validating this as an integer, but it can be anything, no way to validate. 128 S MAGY=1 129 Q 130 DELFLAG ;Meaning: This flag tells the Delphi Import Component to Delete the Image files after successful processing 131 I ",TRUE,FALSE,0,1,"[(","_$$UPPER(VALUE)_",") S MAGY=1 132 E S MAGY="0^INVALID Value " 133 I VALUE="1" S VALUE="TRUE" 134 I VALUE="0" S VALUE="FALSE" 135 Q 136 TRNSTYP ;Meaning: This flag is for future use, for now it is ignored, defaults to "NEW" 137 S MAGY=1 138 Q 139 STATUSCB ; Meaning: This is the TAG^RTN that Imaging calls to report the 140 ; status of the Import. 141 S MAGY="0^Error validating TAG^RTN: "_VALUE 142 I '$L($T(@VALUE)) S MAGY="0^Invalid Status CallBack "_VALUE 143 E S MAGY=1 144 Q 145 ACQS ; We need to make sure the ACQS (Acquisition Site) is a Valid entry in Imaging Site Params. 146 S VALUE=$P(VALUE,";") ; Stop error, when old OCX sends data. 147 ; Next Block is for VIC (Maximus) that sends Station Number. 148 N ERR S ERR=0 149 I MAX D Q:ERR 150 . S X=$O(^DIC(4,"D",VALUE,"")) 151 . I X="" S MAGY="0^Invalid STATION NUMBER: (ACQS): "_VALUE,ERR=1 Q 152 . S VALUE=X 153 . Q 154 I '$$CONSOLID^MAGBAPI S MAGY=1 Q 155 ;Patch 20 will have this. 156 I '$D(^MAG(2006.1,"B",VALUE)) S MAGY="0^Acquisition Site ("_VALUE_") is Not in Site Param File." Q 157 S MAGY=1 158 Q 159 107 ; 107 and ACQD are the same. Calling 107 falls into validation for ACQD. 160 ACQD ; 107 and ACQD are ACQUISITION DEVICE FILE (2006.04) pointers or Values. 161 ; If it is an integer, We assume the value is an IEN and validate it here. 162 I ((+VALUE)=VALUE),'$D(^MAG(2006.04,VALUE)) S MAGY="0^Invalid IEN ("_VALUE_") for ACQUISITION DEVICE File." Q 163 ; if it is not an integer, it is either a new/existing entry for 2006.04 Result is Success, 164 ; and it will be validated in PRE^MAGGSIA1 and added to File 2006.04 if needed. 165 S MAGY=1 166 Q 167 UPPER(X) ; 168 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 169 ; 170 ERR ; ERROR TRAP FOR Import API 171 N ERR S ERR=$$EC^%ZOSV 172 S MAGRY(0)="0^ETRAP: "_ERR 173 D @^%ZOSF("ERRTN") 174 Q 1 MAGGSIV ;WOIFO/GEK - Imaging RPC Broker calls. Validate Image data array ; [ 12/27/2000 10:49 ] 2 ;;3.0;IMAGING;**7,8,20**;Apr 12, 2006 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 Q 19 VAL(MAGRY,MAGARRAY,ALL) ;RPC [MAG4 VALIDATE DATA] 20 ;Call to Validate the Image Data Array before a new image/modified entry is attempted. 21 ; Called from MAGGSIA, MAGGSIUI and Capture GUI. 22 ; Parameters : 23 ; MAGARRAY - array of 'Field numbers'|'Action codes' and their Values 24 ; MAGARRAY(1)="5^38" Field#: 5 Value: 38 25 ; an example of an action code is the Code for File Extension 26 ; MAGARRAY(2)="EXT^JPG" Action: EXT Value: JPG 27 ; ALL - "1" = Validate ALL fields, returning an array of error messages. 28 ; "0" = Stop validating if an error occurs, return 29 ; the error message in (0) node. 30 ; Return Variable 31 ; MAGRY() - Array 32 ; Successful MAGRY(0) = 1^Image Data is Valid. 33 ; UNsuccessful MAGRY(0) = 0^Error desc 34 ; IF ALL then MAGRY(1..N) =0^Error desc of all errors 35 N MAGGFLD,MAGGDAT,MAGFSPEC,CHKOK,MAGETXT,MAGRET,MAGRES 36 N Y,AITEM,CT,MAGERR,DFNFLAG,DAT1,X,MAX 37 N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) 38 S ALL=$G(ALL) 39 S MAGRY(0)="0^Validating the Data Array..." 40 S MAGERR="",DFNFLAG=0,CT=0 41 ; Do we have any data ? 42 I ($D(MAGARRAY)<10) S MAGRY(0)="0^No input data, Operation CANCELED" Q 43 ; Flag if from Maximus 44 S MAX=0 45 S X="" F S X=$O(MAGARRAY(X)) Q:X="" I $P(MAGARRAY(X),U,1)="TRKID"!($P(MAGARRAY(X),U,1)="108") I $P($P(MAGARRAY(X),U,2),";",1)="MAX" S MAX=1 46 ; Loop through Input Array 47 S AITEM="" F S AITEM=$O(MAGARRAY(AITEM)) Q:AITEM="" D I $L(MAGERR) Q:'ALL S CT=CT+1,MAGRY(CT)=MAGERR,MAGERR="" 48 . S MAGERR="" 49 . S MAGGFLD=$P(MAGARRAY(AITEM),U,1),MAGGDAT=$P(MAGARRAY(AITEM),U,2,99) 50 . I MAGGFLD="" S MAGERR="0^A Field Number/Action Code is required: "_" Item: "_MAGARRAY(AITEM) Q 51 . I MAGGDAT="" S MAGERR="0^A Value is required."_" Item: "_MAGARRAY(AITEM) Q 52 . I MAGGFLD=5 S DFNFLAG=1 53 . ; This inadvertently disallowed Tracking ID's on Group Images. 54 . ;I MAGGFLD=108 I $D(^MAG(2005,"ATRKID",MAGGDAT)) S MAGERR="0^Tracking ID Must be Unique !" Q 55 . I MAGGFLD=108 I ($L(MAGGDAT,";")<2) S MAGRY(0)="0^Tracking ID Must have "";"" Delimiter" Q 56 . ; Check for possible action codes that could be in the array. 57 . I $$ACTCODE(MAGGFLD) D Q 58 . . S DAT1=MAGGDAT 59 . . S Y=$$VALCODE(MAGGFLD,.MAGGDAT) S:'Y MAGERR=Y_" Item: "_MAGARRAY(AITEM) 60 . . I DAT1'=MAGGDAT S MAGARRAY(AITEM)=MAGGFLD_"^"_MAGGDAT 61 . ; If we are adding Multiple Images to a Group, they must be Validated. 62 . ; we could have multiple "2005.04^IENs" in this array. Which means we are 63 . ; adding existing Images to a New/Existing Group. 64 . I MAGGFLD=2005.04 D Q ; 2005.04 isn't the field number, #4 is the field number 65 . . I $G(MAGGDAT,0)=0 Q ;Creating a new Group, with no group entries is the usual way 66 . . ; to do it. Then make successive calls to ADD, Adding each Image to the 67 . . ; Object Group multiple of the Group Parent (fld#14) as it is created. 68 . . I '$D(^MAG(2005,MAGGDAT,0)) S MAGERR="0^Group Object "_MAGGDAT_" doesn't exist"_" Item: "_MAGARRAY(AITEM) 69 . . ; We can't allow adding an image if it already has a group parent. 70 . . I $P(^MAG(2005,MAGGDAT,0),U,10) S MAGERR="0^The Image to be added to the Group, already has a Group Parent"_" Item: "_MAGARRAY(AITEM) 71 . ; if we are getting a WP line of text for Long Desc Field. Can't validate it. 72 . I MAGGFLD=11 Q ; this is a line of the WP Long Desc field. 73 . ; NEW CALL TO VALIDATE FILE,FIELD,DATA 74 . S DAT1=MAGGDAT 75 . I '$$VALID^MAGGSIV1(2005,MAGGFLD,.MAGGDAT,.MAGRES) S MAGERR="0^"_MAGRES Q 76 . I DAT1'=MAGGDAT S MAGARRAY(AITEM)=MAGGFLD_"^"_MAGGDAT 77 . Q 78 ; 79 ; if there was an Error in data we'll quit now. 80 ; If ALL is true, then MAGRY(1...N) will exist if there were errors. 81 I $O(MAGRY(0)) S MAGRY(0)="0^Errors were found in data." Q 82 ; If ALL is false, then MAGERR will exist if there was an error. 83 I $L(MAGERR) S MAGRY(0)=MAGERR Q 84 ; 85 ; If all data is valid we get here. 86 ; Last Test, see if a Patient was in array, 87 ; (Patient is the only Required field check done in this routine). 88 I 'DFNFLAG S MAGRY(0)="0^A Patient DFN is required. " Q 89 S MAGRY(0)="1^Data is Valid." 90 Q 91 ACTCODE(CODE) ;Function that returns True (1) if this code is a valid Import API Action Code 92 ; Patch 8. We're adding 107 as an action code, so it will pass validation even if the entry 93 ; in the Acquisition Device File doesn't exist; 94 ; it will be validated in PRE^MAGGSIA1 and a new Acquisition Device entry made if needed. 95 I ",107,ACQD,IEN,EXT,ABS,JB,WRITE,BIG,DICOMSN,DICOMIN,ACQS,ACQL,STATUSCB,CALLMTH,USERNAME,PASSWORD,DELFLAG,TRNSTYP,"[(","_CODE_",") Q 1 96 Q 0 97 VALCODE(CODE,VALUE) ; We validate the values for the possible action codes 98 N MAGY 99 I VALUE="" Q "0^NO VALUE in Action Code string: """_X_"" 100 ; Patch 8, added 107 101 I ",ACQL,CALLMTH,USERNAME,PASSWORD,"[(","_CODE_",") Q 1 ; NO VALIDATION FOR THESE CODES 102 D @CODE 103 Q MAGY 104 ; Each Tag is a valid Action code 105 IEN I $D(^MAG(2005,VALUE)) S MAGY=1 106 E S MAGY="0^INVALID IMAGE IEN." 107 Q 108 EXT ; code will go here to validate the extension type. i.e. we won't let types .exe .bat .com .zip ... etc. 109 ; Maybe a modification to Object Type file, to have allowable extensions in the file, and a 110 ; cross reference on a new field EXTENSION. The capture workstation wouldn't have to ask the 111 ; user for the file type of each file, and we wouldn't get WORD .DOC files that the user called Color Images 112 ABS ; Meaning: Have the BP create the abstract 113 JB ; Meaning: Have the BP copy the image to the JukeBox 114 BIG ; Meaning: There is a big file also, set the Image File field ? to indicate there is a BIG File. 115 S MAGY=1 116 Q 117 WRITE ; Meaning: This is the Internal Entry (or "PACS") of the WRITE Directory. Images will be written 118 ; here instead of the default WRITE Directory. 119 S MAGY=$$DRIVE^MAGGTU1(VALUE) 120 Q 121 DICOMSN ;Meaning: DICOM Series Number. This will be entered in the Group Object multiple, field #1 122 ;We were validating this as an integer, but it can be anything, no way to validate. 123 S MAGY=1 124 Q 125 DICOMIN ;Meaning: DICOM Image Number. This will be entered in the Group Object multiple, field #2 126 ; We were validating this as an integer, but it can be anything, no way to validate. 127 S MAGY=1 128 Q 129 DELFLAG ;Meaning: This flag tells the Delphi Import Component to Delete the Image files after successful processing 130 I ",TRUE,FALSE,0,1,"[(","_$$UPPER(VALUE)_",") S MAGY=1 131 E S MAGY="0^INVALID Value " 132 I VALUE="1" S VALUE="TRUE" 133 I VALUE="0" S VALUE="FALSE" 134 Q 135 TRNSTYP ;Meaning: This flag is for future use, for now it is ignored, defaults to "NEW" 136 S MAGY=1 137 Q 138 STATUSCB ; Meaning: This is the TAG^RTN that Imaging calls to report the 139 ; status of the Import. 140 S MAGY="0^Error validating TAG^RTN: "_VALUE 141 I '$L($T(@VALUE)) S MAGY="0^Invalid Status CallBack "_VALUE 142 E S MAGY=1 143 Q 144 ACQS ; We need to make sure the ACQS (Acquisition Site) is a Valid entry in Imaging Site Params. 145 S VALUE=$P(VALUE,";") ; Stop error, when old OCX sends data. 146 ; Next Block is for VIC (Maximus) that sends Station Number. 147 N ERR S ERR=0 148 I MAX D Q:ERR 149 . S X=$O(^DIC(4,"D",VALUE,"")) 150 . I X="" S MAGY="0^Invalid STATION NUMBER: (ACQS): "_VALUE,ERR=1 Q 151 . S VALUE=X 152 . Q 153 I '$$CONSOLID^MAGBAPI S MAGY=1 Q 154 ;Patch 20 will have this. 155 I '$D(^MAG(2006.1,"B",VALUE)) S MAGY="0^Acquisition Site ("_VALUE_") is Not in Site Param File." Q 156 S MAGY=1 157 Q 158 107 ; 107 and ACQD are the same. Calling 107 falls into validation for ACQD. 159 ACQD ; 107 and ACQD are ACQUISITION DEVICE FILE (2006.04) pointers or Values. 160 ; If it is an integer, We assume the value is an IEN and validate it here. 161 I ((+VALUE)=VALUE),'$D(^MAG(2006.04,VALUE)) S MAGY="0^Invalid IEN ("_VALUE_") for ACQUISITION DEVICE File." Q 162 ; if it is not an integer, it is either a new/existing entry for 2006.04 Result is Success, 163 ; and it will be validated in PRE^MAGGSIA1 and added to File 2006.04 if needed. 164 S MAGY=1 165 Q 166 UPPER(X) ; 167 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 168 ; 169 ERR ; ERROR TRAP FOR Import API 170 N ERR S ERR=$$EC^%ZOSV 171 S MAGRY(0)="0^ETRAP: "_ERR 172 D @^%ZOSF("ERRTN") 173 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGSIV1.m
r613 r623 1 MAGGSIV1 ;WOIFO/GEK - Imaging Validate Data ; [ 08/15/2004 08:57 ] 2 ;;3.0;IMAGING;**8,20,59**;Nov 27, 2007;Build 20 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 VALID(MAGF,MAGL,MAGD,MAGRES) ; call to validate value for field in a FM file. 21 ; Function is boolean. Returns: 22 ; 0 - Invalid 23 ; 1 - Valid 24 ; "" - Error 25 ; Call this function before you set the FDA Array. 26 ; MAGD - sent by reference because it could be Internal or External 27 ; and if it is external and valid, it is changed to Internal. 28 ; 29 ; MAGF : File Number 30 ; MAGL : Field Number 31 ; MAGD : (sent by reference) data value of field 32 ; MAGRES: (sent by reference) Result message 33 ; 34 N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) 35 N MAGR,MAGMSG,MAGSP,MAGRESA,MAGE,MAGPT 36 ;if a BAD field number 37 I '$$VFIELD^DILFD(MAGF,MAGL) D Q 0 38 . S MAGRES="The field number: "_MAGL_", in File: "_MAGF_", is invalid." 39 D FIELD^DID(MAGF,MAGL,"","SPECIFIER","MAGSP") 40 ; If it is a pointer field 41 ; If an integer - We assume it is a pointer and validate that and Quit. 42 ; If not integer - We assume it is external value, proceed to let CHK do validate 43 I (MAGSP("SPECIFIER")["P"),(+MAGD=MAGD) D Q MAGPT 44 . I $$EXTERNAL^DILFD(MAGF,MAGL,"",MAGD)'="" S MAGPT=1,MAGRES="Valid pointer" Q 45 . S MAGPT=0,MAGRES="The value: "_MAGD_" for field: "_MAGL_" in File: "_MAGF_" is an invalid Pointer." 46 . Q 47 ; 48 D CHK^DIE(MAGF,MAGL,"E",MAGD,.MAGR,"MAGMSG") 49 ; If success, Quit. We changed External to Internal. Internal is in MAGR 50 I MAGR'="^" S MAGD=MAGR Q 1 51 ; If not success Get the error text and Quit 0 52 D MSG^DIALOG("A",.MAGRESA,245,5,"MAGMSG") 53 S MAGRES=MAGRESA(1) 54 Q 0 55 VALINDEX(MAGRY,TYPE,SPEC,PROC) ; Validate the interdependency of Index Terms. 56 ; MAGRY is the return array 57 ; MAGRY(0)="1^Okay" or "0^error message" 58 ; MAGRY(1..n) Information about the Type,Spec and Proc 59 ; 60 ; Validate the Procedure/Event <-> Specialty/SubSpecialty interdependency 61 ; Assure the TYPE is a Clinical TYPE. 62 ; Assure all are Active. 63 N CLS,RES,ARR,TYX,PRX,SPX,OK 64 K MAGRY 65 S TYPE=$G(TYPE),PROC=$G(PROC),SPEC=$G(SPEC) 66 I TYPE=0 S TYPE="" 67 I PROC=0 S PROC="" 68 I SPEC=0 S SPEC="" 69 I ((PROC]"")!(SPEC]"")) I TYPE="" S MAGRY(0)="0^Type is required." Q 0 70 ; TYPE is required, but not enforcing yet. All vendors are not sending 71 ; index values. 72 ; VALID will accept External or Internal and return Internal if Valid 73 I $L(TYPE) I '$$VALID(2005,42,.TYPE,.RES) S MAGRY(0)="0^"_RES Q 0 74 I $L(PROC) I '$$VALID(2005,43,.PROC,.RES) S MAGRY(0)="0^"_RES Q 0 75 I $L(SPEC) I '$$VALID(2005,44,.SPEC,.RES) S MAGRY(0)="0^"_RES Q 0 76 ; 77 I TYPE D I 'OK S MAGRY(0)=OK Q 0 78 . S OK=1,TYX=TYPE_"," 79 . K ARR D GETS^DIQ(2005.83,TYX,".01;1;2","EI","ARR") 80 . S MAGRY(1)="Type - Class : "_ARR(2005.83,TYX,.01,"E")_" - "_ARR(2005.83,TYX,1,"E") 81 . I $L(ARR(2005.83,TYX,2,"E")) S MAGRY(1)=MAGRY(1)_" - "_ARR(2005.83,TYX,2,"E") 82 . I ARR(2005.83,TYX,2,"I")="I" S OK="0^Type is Inactive" 83 . Q 84 ; 85 I SPEC D I 'OK S MAGRY(0)=OK Q 0 86 . S OK=1,SPX=SPEC_"," 87 . K ARR D GETS^DIQ(2005.84,SPX,".01;2;4","EI","ARR") 88 . S MAGRY(2)="Specialty/SubSpecialty: "_ARR(2005.84,SPX,.01,"E") 89 . I $L(ARR(2005.84,SPX,4,"E")) S MAGRY(2)=MAGRY(2)_" - "_ARR(2005.84,SPX,4,"E") 90 . I $L(ARR(2005.84,SPX,2,"E")) S MAGRY(2)=MAGRY(2)_" <"_ARR(2005.84,SPX,2,"E")_">" 91 . I ARR(2005.84,SPX,4,"I")="I" S OK="0^Specialty is Inactive" 92 . Q 93 ; 94 I PROC D I 'OK S MAGRY(0)=OK Q 0 95 . S OK=1,PRX=PROC_"," 96 . K ARR D GETS^DIQ(2005.85,PRX,".01;4","EI","ARR") 97 . S MAGRY(4)="Procedure/Event : "_$$GET1^DIQ(2005.85,PROC,.01) 98 . I $L(ARR(2005.85,PRX,4,"E")) S MAGRY(4)=MAGRY(4)_" - "_ARR(2005.85,PRX,4,"E") 99 . I ARR(2005.85,PRX,4,"I")="I" S OK="0^Procedure is Inactive" 100 . Q 101 ; 102 ; If PROC and SPEC are "", then Quit, any TYPE by itself is valid 103 I (PROC=""),(SPEC="") S MAGRY(0)="1^Okay" Q 1 104 ; Here, TYPE has to be Clin. 105 S CLS=$$GET1^DIQ(2005.83,TYPE,1,"","MAGTAR") I $E(CLS,1,5)="ADMIN" D Q 0 106 . S MAGRY(0)="0^The Type Index is Administrative, it has to be Clinical." 107 I (PROC="")!(SPEC="") S MAGRY(0)="1^Okay" Q 1 108 ; we get here, we have to validate the interdependency of SPEC <-> PROC. 109 I '$O(^MAG(2005.85,PROC,1,0)) S MAGRY(0)="1^Okay" Q 1 110 I '$D(^MAG(2005.85,PROC,1,"B",SPEC)) D Q 0 111 . S MAGRY(0)="0^Invalid Association between Spec/SubSpec and Proc/Event" 112 . Q 113 S MAGRY(0)="1^Okay" 114 Q 1 115 ERR ; 116 N ERR 117 S ERR=$$EC^%ZOSV 118 S MAGRES="0^Error during data validation: "_ERR 119 D LOGERR^MAGGTERR(ERR) 120 D @^%ZOSF("ERRTN") 121 D CLEAN^DILF 122 Q 1 MAGGSIV1 ;WOIFO/GEK - Imaging Validate Data ; [ 08/15/2004 08:57 ] 2 ;;3.0;IMAGING;**8,20**;Apr 12, 2006 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 Q 19 VALID(MAGF,MAGL,MAGD,MAGRES) ; call to validate value for field in a FM file. 20 ; Function is boolean. Returns: 21 ; 0 - Invalid 22 ; 1 - Valid 23 ; "" - Error 24 ; Call this function before you set the FDA Array. 25 ; MAGD - sent by reference because it could be Internal or External 26 ; and if it is external and valid, it is changed to Internal. 27 ; 28 ; MAGF : File Number 29 ; MAGL : Field Number 30 ; MAGD : (sent by reference) data value of field 31 ; MAGRES: (sent by reference) Result message 32 ; 33 N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) 34 N MAGR,MAGMSG,MAGSP,MAGRESA,MAGE,MAGPT 35 ;if a BAD field number 36 I '$$VFIELD^DILFD(MAGF,MAGL) D Q 0 37 . S MAGRES="The field number: "_MAGL_", in File: "_MAGF_", is invalid." 38 D FIELD^DID(MAGF,MAGL,"","SPECIFIER","MAGSP") 39 ; If it is a pointer field 40 ; If an integer - We assume it is a pointer and validate that and Quit. 41 ; If not integer - We assume it is external value, proceed to let CHK do validate 42 I (MAGSP("SPECIFIER")["P"),(+MAGD=MAGD) D Q MAGPT 43 . I $$EXTERNAL^DILFD(MAGF,MAGL,"",MAGD)'="" S MAGPT=1,MAGRES="Valid pointer" Q 44 . S MAGPT=0,MAGRES="The value: "_MAGD_" for field: "_MAGL_" in File: "_MAGF_" is an invalid Pointer." 45 . Q 46 ; 47 D CHK^DIE(MAGF,MAGL,"E",MAGD,.MAGR,"MAGMSG") 48 ; If success, Quit. We changed External to Internal. Internal is in MAGR 49 I MAGR'="^" S MAGD=MAGR Q 1 50 ; If not success Get the error text and Quit 0 51 D MSG^DIALOG("A",.MAGRESA,245,5,"MAGMSG") 52 S MAGRES=MAGRESA(1) 53 Q 0 54 VALINDEX(MAGRY,TYPE,SPEC,PROC) ; Validate the interdependency of Index Terms. 55 ; MAGRY is the return array 56 ; MAGRY(0)="1^Okay" or "0^error message" 57 ; MAGRY(1..n) Information about the Type,Spec and Proc 58 ; 59 ; Validate the Procedure/Event <-> Specialty/SubSpecialty interdependency 60 ; Assure the TYPE is a Clinical TYPE. 61 ; Assure all are Active. 62 N CLS,RES,ARR,TYX,PRX,SPX,OK 63 K MAGRY 64 S TYPE=$G(TYPE),PROC=$G(PROC),SPEC=$G(SPEC) 65 I TYPE=0 S TYPE="" 66 I PROC=0 S PROC="" 67 I SPEC=0 S SPEC="" 68 I ((PROC]"")!(SPEC]"")) I TYPE="" S MAGRY(0)="0^Type is required." Q 0 69 ; TYPE is required, but not enforcing yet. All vendors are not sending 70 ; index values. 71 ; VALID will accept External or Internal and return Internal if Valid 72 I $L(TYPE) I '$$VALID(2005,42,.TYPE,.RES) S MAGRY(0)="0^"_RES Q 0 73 I $L(PROC) I '$$VALID(2005,43,.PROC,.RES) S MAGRY(0)="0^"_RES Q 0 74 I $L(SPEC) I '$$VALID(2005,44,.SPEC,.RES) S MAGRY(0)="0^"_RES Q 0 75 ; 76 I TYPE D I 'OK S MAGRY(0)=OK Q 0 77 . S OK=1,TYX=TYPE_"," 78 . K ARR D GETS^DIQ(2005.83,TYX,".01;1;2","EI","ARR") 79 . S MAGRY(1)="Type - Class : "_ARR(2005.83,TYX,.01,"E")_" - "_ARR(2005.83,TYX,1,"E") 80 . I $L(ARR(2005.83,TYX,2,"E")) S MAGRY(1)=MAGRY(1)_" - "_ARR(2005.83,TYX,2,"E") 81 . I ARR(2005.83,TYX,2,"I")="I" S OK="0^Type is Inactive" 82 . Q 83 ; 84 I SPEC D I 'OK S MAGRY(0)=OK Q 0 85 . S OK=1,SPX=SPEC_"," 86 . K ARR D GETS^DIQ(2005.84,SPX,".01;2;4","EI","ARR") 87 . S MAGRY(2)="Specialty/SubSpecialty: "_ARR(2005.84,SPX,.01,"E") 88 . I $L(ARR(2005.84,SPX,4,"E")) S MAGRY(2)=MAGRY(2)_" - "_ARR(2005.84,SPX,4,"E") 89 . I $L(ARR(2005.84,SPX,2,"E")) S MAGRY(2)=MAGRY(2)_" <"_ARR(2005.84,SPX,2,"E")_">" 90 . I ARR(2005.84,SPX,4,"I")="I" S OK="0^Specialty is Inactive" 91 . Q 92 ; 93 I PROC D I 'OK S MAGRY(0)=OK Q 0 94 . S OK=1,PRX=PROC_"," 95 . K ARR D GETS^DIQ(2005.85,PRX,".01;4","EI","ARR") 96 . S MAGRY(4)="Procedure/Event : "_$$GET1^DIQ(2005.85,PROC,.01) 97 . I $L(ARR(2005.85,PRX,4,"E")) S MAGRY(4)=MAGRY(4)_" - "_ARR(2005.85,PRX,4,"E") 98 . I ARR(2005.85,PRX,4,"I")="I" S OK="0^Procedure is Inactive" 99 . Q 100 ; 101 ; If PROC and SPEC are "", then Quit, any TYPE by itself is valid 102 I (PROC=""),(SPEC="") S MAGRY(0)="1^Okay" Q 1 103 ; Here, TYPE has to be Clin. 104 S CLS=$$GET1^DIQ(2005.83,TYPE,1,"","MAGTAR") I $E(CLS,1,5)="ADMIN" D Q 0 105 . S MAGRY(0)="0^The Type Index is Administrative, it has to be Clinical." 106 I (PROC="")!(SPEC="") S MAGRY(0)="1^Okay" Q 1 107 ; we get here, we have to validate the interdependency of SPEC <-> PROC. 108 I '$O(^MAG(2005.85,PROC,1,0)) S MAGRY(0)="1^Okay" Q 1 109 I '$D(^MAG(2005.85,PROC,1,"B",SPEC)) D Q 0 110 . S MAGRY(0)="0^Invalid Association between Spec/SubSpec and Proc/Event" 111 . Q 112 S MAGRY(0)="1^Okay" 113 Q 1 114 ERR ; 115 N ERR 116 S ERR=$$EC^%ZOSV 117 S MAGRES="0^Error during data validation: "_ERR 118 D LOGERR^MAGGTERR(ERR) 119 D @^%ZOSF("ERRTN") 120 D CLEAN^DILF 121 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGTAU.m
r613 r623 1 MAGGTAU ;WOIFO/GEK - RPC Calls to Update the Imaging Windows Workstation file ; [ 03/25/2001 11:20 ] 2 ;;3.0;IMAGING;**7,16,8,59**;Nov 27, 2007;Build 20 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 | 14 ;; | in any way. Modifications to this software may result in an | 15 ;; | adulterated medical device under 21CFR820, the use of which | 16 ;; | is considered to be a violation of US Federal Statutes. | 17 ;; +---------------------------------------------------------------+ 18 ;; 19 Q 20 UPD(MAGRY,DATA) ;RPC [MAGG WRKS UPDATES] 21 ; Called after User login. Local and RIV. 22 ; Updates information in the IMAGING WINDOWS WORKSTATION 23 ; 24 ; DATA is '^' delimited piece 25 ; 1 Workstation name 2 Date/Time of capture app. 26 ; 3 Date/Time of Display App. 27 ; 4 Location of workstation 5 Date/Time of MAGSETUP 28 ; 6 Version of Display 7 Version of Capture 29 ; 8 1=Normal startup 2=Started by CPRS 3=Import API 30 ; 9 OS Version 10 VistaRad Version 31 ; 11 RPCBroker Server 12 RPCBroker Port 32 N X,Y,Z 33 N MAGNAME,MAGCDT,MAGDDT,MAG0,MAGLOC,MAGIEN,MAGSETUP,MAGSTART,MAGSRV 34 N MAGVERSD,MAGVERSC,MAGMODE,MAGOSVER,MAGVERVR,MAGPL,MAGVERX 35 K MAGGFDA,MAGXERR,MAGXIEN 36 S MAGNAME=$P(DATA,U,1) 37 S MAGCDT=$P(DATA,U,2) 38 S MAGDDT=$P(DATA,U,3) 39 S MAGLOC=$P(DATA,U,4) 40 S MAGSETUP=$P(DATA,U,5) 41 S MAGVERSD=$P(DATA,U,6) 42 I MAGVERSD S MAGJOB("DISPLAY")="" 43 S MAGVERSC=$P(DATA,U,7) 44 I MAGVERSC S MAGJOB("CAPTURE")="" 45 S MAGMODE=$P(DATA,U,8) 46 S MAGOSVER=$P(DATA,U,9) 47 S MAGVERVR=$P(DATA,U,10) 48 I $P(DATA,U,11)]"" S MAGJOB("RPCSERVER")=$P(DATA,U,11) 49 I $P(DATA,U,12)]"" S MAGJOB("RPCPORT")=$P(DATA,U,12) 50 S MAGIEN=0 51 I $L(MAGNAME) S MAGIEN=$O(^MAG(2006.81,"B",MAGNAME,"")) 52 I 'MAGIEN D NEWWRKS(MAGNAME,MAGLOC,.MAGIEN) 53 I MAGIEN<1 S MAGRY="0^Workstation Not on file" Q 54 ; 55 S %DT="T",X=MAGCDT D ^%DT S MAGCDT=Y 56 S %DT="T",X=MAGDDT D ^%DT S MAGDDT=Y 57 S %DT="T",X=MAGSETUP D ^%DT S MAGSETUP=Y 58 S MAG0=^MAG(2006.81,MAGIEN,0) ; '0' node for use later. 59 L +^MAG(2006.81,"LOCK",MAGIEN):0 60 S MAGIEN=+MAGIEN_"," 61 S MAGGFDA(2006.81,MAGIEN,.01)=MAGNAME ; Computer Name 62 I MAGCDT>-1 S MAGGFDA(2006.81,MAGIEN,4)=MAGCDT ;TELE19N.EXE dttm 63 I MAGDDT>-1 S MAGGFDA(2006.81,MAGIEN,5)=MAGDDT ;IMGVWP10.EXE dttm 64 I MAGSETUP>-1 S MAGGFDA(2006.81,MAGIEN,7)=MAGSETUP ; MAGSETUP.EXE dttm 65 S MAGGFDA(2006.81,MAGIEN,8)=1 ; Active or not. 66 S MAGGFDA(2006.81,MAGIEN,6)=MAGLOC ; location free text from .INI 67 S MAGGFDA(2006.81,MAGIEN,3)="@" ; delete logoff time for this job. 68 S MAGGFDA(2006.81,MAGIEN,10)="@" ; delete session pointer 69 S MAGGFDA(2006.81,MAGIEN,11)="@" ; reset the session error count. 70 S MAGGFDA(2006.81,MAGIEN,9)=MAGVERSD ; IMGVWP10.EXE Version Info 71 S MAGGFDA(2006.81,MAGIEN,9.5)=MAGVERSC ; TELE19N.EXE Version Info 72 S MAGGFDA(2006.81,MAGIEN,9.7)=MAGVERVR ; VistARad.EXE Version Info 73 S MAGGFDA(2006.81,MAGIEN,13)=MAGOSVER ; Operating System Version. 74 ; 75 S X=$P(MAG0,U,12) 76 S MAGGFDA(2006.81,MAGIEN,12)=X+1 ; Sess count for wrks. 77 ; Keep PLACE that this wrks logged in. 78 S MAGPL=0 I $D(DUZ(2)) S MAGPL=+$$PLACE^MAGBAPI(DUZ(2)) ; DBI 79 I MAGPL S MAGGFDA(2006.81,MAGIEN,.04)=MAGPL ; DBI 80 ; 81 S X=$$NOW^XLFDT 82 S MAGSTART=$E(X,1,12) 83 I $G(DUZ) D 84 . S MAGGFDA(2006.81,MAGIEN,1)=DUZ 85 . S MAGGFDA(2006.81,MAGIEN,2)=MAGSTART 86 ; 87 D UPDATE^DIE("S","MAGGFDA","MAGXIEN","MAGXERR") 88 I $D(DIERR) D RTRNERR(.MAGRY) Q 89 ; The MAGJOB( array is used by Imaging routines that are 90 ; called from the Delphi App. 91 ; 92 ; 3.0.8 Whatever App calls this, we'll use that Version number. 93 S MAGVERX=$S(MAGVERSD]"":MAGVERSD,MAGVERSC]"":MAGVERSC,MAGVERVR]"":MAGVERVR,1:0) 94 S MAGJOB("WRKSIEN")=+MAGIEN 95 S MAGJOB("VERSION")=MAGVERX 96 S MAGRY="1^" 97 ; 98 ; SESSION : Create new session entry 99 D GETS^DIQ(200,DUZ_",","29","I","Z","") ; service/section 100 S MAGSRV=$G(Z(200,DUZ_",",29,"I")) 101 ; 102 K MAGGFDA,MAGXERR,MAGXIEN 103 S MAGGFDA(2006.82,"+1,",.01)=$P(^VA(200,DUZ,0),U,1) ; User 104 S MAGGFDA(2006.82,"+1,",1)=DUZ ; USER 105 S MAGGFDA(2006.82,"+1,",2)=MAGSTART ; Sess Start Time 106 S MAGGFDA(2006.82,"+1,",4)=+MAGIEN ; Wrks 107 S MAGGFDA(2006.82,"+1,",7)=+MAGSRV ; User's Service/Section 108 S MAGGFDA(2006.82,"+1,",13)=MAGMODE ; 1=normal 2= started by CPRS 109 ; DBI - save the logon PLACE in the Session file. 110 I MAGPL S MAGGFDA(2006.82,"+1,",.04)=MAGPL ; User's Institution (Imaging site param entry) 111 ; 112 ;3.0.8 new fields 9 Client Ver, 9.2 Host Version, 9.4 OS Version 113 S MAGGFDA(2006.82,"+1,",9)=MAGVERX ; 114 S MAGGFDA(2006.82,"+1,",9.2)=$$VERSION^XPDUTL("IMAGING") ; 115 S MAGGFDA(2006.82,"+1,",9.4)=MAGOSVER ; 116 ; 117 D UPDATE^DIE("","MAGGFDA","MAGXIEN","MAGXERR") 118 I $D(DIERR) D RTRNERR(.MAGRY) Q 119 S MAGRY="1^" 120 I '+MAGXIEN(1) S MAGRY="0^" Q 121 S MAGJOB("SESSION")=+MAGXIEN(1) 122 S MAGRY=MAGJOB("SESSION")_"^Session # "_MAGJOB("SESSION")_" Started." 123 S MAGGFDA(2006.81,+MAGIEN_",",10)=+MAGXIEN(1) 124 D UPDATE^DIE("","MAGGFDA","MAGXIEN","MAGXERR") 125 D ACTION("LOGON^") 126 Q 127 LOGACT(MAGRY,ACTION) ;RPC [MAG3 LOGACTION] 128 ; Call to log actions for Imaging Session from 129 ; Delphi interface 130 D ACTION(ACTION) 131 S MAGRY="1^Action Logged" 132 Q 133 ACTION(TXT,LOGTM,MAGSESS) ;Call to log actions for Imaging Workstation Session from other M routines 134 ; ACTIONS LOGGED 135 ; LOGON - Session StartTime LOGOFF - Session End Time 136 ; IMG - Image accessed PAT - Patient Accessed 137 ; CAP - Image Captured 138 ; DEL - Image Deleted MOD - Image entry modified 139 ; IMPORT - Import API has been called 140 ; Data - a node of data passed to Import API 141 ; Result - a node of the Result Array from Import API Processing. 142 ; Image - one of the Images (full path of import directory) that was imported. 143 ; PPACT - A Post processing Action has been processed. 144 ; VR-VW - VistaRad Exam displayed 145 ; VR-INT - VistaRad Exam interpreted 146 ; API - parameters sent to CP API, and the API Call i.e. ITIU-MDAPI 147 ; DFTINDX- If the index fields have no values, call to Patch 17 code to 148 ; generate the values for the fields. 149 ; MOD - This was intended to log Modifications to Image Entries, it is 150 ; (for now) only called when a group entry has an image added to its multiple. 151 ; 152 ; TXT is "^" delimited string 153 ; $P(1) is code ( see above ) $P(2) is DFN 154 ; $P(3) is Image IEN $P(4) reserved for procedure 155 ; $P(5) reserved for time-stamp $P(6) is Vrad Image Count 156 ; $P(7) is Vrad Patient Count 157 ; $P(8) is Vrad User Type (1/0 = Rad/Non-Rad) 158 ; $P(9) is Vrad REMOTE Read flag (1/0; 1=REMOTE) 159 ; $P(TXT,"$$",2) is Tracking ID from an Imported Image. From this we compute Session #, to log actions. 160 ; LOGTM - [1|0] Flag to indicate whether or not to log the time of the Action. Default = 0 161 ; MAGSESS - Session IEN where the action should be logged. Default to MAGJOB("SESSION") 162 ; 163 N NODE,SESSIEN,MAGGFDA,MAGXERR,MAGXIEN,MAGPROC,LOGX,TRKID 164 S LOGTM=$G(LOGTM) 165 I TXT["$$" S TRKID=$P(TXT,"$$",2),TXT=$P(TXT,"$$",1) 166 S SESSIEN=$S($G(MAGSESS):MAGSESS,$D(MAGJOB("SESSION")):MAGJOB("SESSION"),$G(TRKID)'="":$O(^MAG(2006.82,"E",TRKID,""),-1),1:0) 167 I 'SESSIEN Q 168 S NODE="+1,"_SESSIEN_"," 169 I $P(TXT,U,3) S MAGPROC=$P($G(^MAG(2005,$P(TXT,U,3),0)),U,8) 170 ; 171 I $P(TXT,U)="PAT" D 172 . S Z=+$G(^MAG(2006.82,SESSIEN,1))+1 173 . S MAGGFDA(2006.82,SESSIEN_",",10)=Z 174 I $P(TXT,U)="IMG" D 175 . S Z=+$P($G(^MAG(2006.82,SESSIEN,1)),U,2)+1 176 . S MAGGFDA(2006.82,SESSIEN_",",11)=Z 177 . D ENTRY^MAGLOG("IMGVW",DUZ,$P(TXT,"^",3),"Wrks",$P(TXT,"^",2),"1") 178 . D ACCESS^MAGLOG($P(TXT,"^",3)) 179 I $E(TXT,1,3)="CAP" D 180 . S Z=+$P($G(^MAG(2006.82,SESSIEN,1)),U,3)+1 181 . S MAGGFDA(2006.82,SESSIEN_",",12)=Z 182 . D ENTRY^MAGLOG("CAP",DUZ,$P(TXT,"^",3),"Wrks",$P(TXT,"^",2),"1") 183 I $P(TXT,U,2) D 184 . S MAGGFDA(2006.82,SESSIEN_",",5)=$P(TXT,U,2) 185 I LOGTM D 186 . S X=$$NOW^XLFDT 187 . S $P(TXT,U,4)=$G(MAGPROC),$P(TXT,U,5)=$E(X,1,12) 188 S MAGGFDA(2006.821,NODE,.01)=$P(TXT,"|",1) 189 I $L(TXT,"|")>1 S MAGGFDA(2006.821,NODE,13)=$P(TXT,"|",2,99) 190 D UPDATE^DIE("S","MAGGFDA","MAGXIEN","MAGXERR") 191 Q 192 NEWWRKS(MAGNAME,MAGLOC,MAGIEN) ; 193 I $G(MAGNAME)="" Q 194 N Y,MAGNFDA,MAGNIEN 195 S MAGNFDA(2006.81,"+1,",.01)=MAGNAME 196 S MAGNFDA(2006.81,"+1,",6)=$G(MAGLOC) 197 D UPDATE^DIE("","MAGNFDA","MAGNIEN") 198 S MAGIEN=MAGNIEN(1) 199 Q 200 LOGOFF(MAGRY) ;RPC [MAGG LOGOFF] Call when session is over. 201 ; This updates session file with logoff time 202 ; and marks the session closed. 203 ; 204 S MAGRY=1 205 N MAGGFDA,MAGXERR,MAGXIEN,MAGIEN,MAGSESS,MAGEND,MAGCON 206 ; The Imaging Workstation file keeps time of login 207 ; We'll enter the logoff time ($$now^xlfdt) here. 208 S X=$$NOW^XLFDT 209 S MAGEND=$E(X,1,12) 210 Q:'+$G(MAGJOB("WRKSIEN")) 211 L -^MAG(2006.81,"LOCK",MAGJOB("WRKSIEN")) 212 S MAGIEN=+MAGJOB("WRKSIEN")_"," 213 S MAGGFDA(2006.81,MAGIEN,3)=MAGEND ; logoff dttm 214 S MAGGFDA(2006.81,MAGIEN,8)=0 ; Set job number to 0 215 D UPDATE^DIE("S","MAGGFDA","MAGXIEN","MAGXERR") 216 ;MAGJOB("WRKSIEN") 217 Q:(+$G(MAGJOB("SESSION"))=0) 218 S MAGSESS=+MAGJOB("SESSION")_"," 219 K MAGGFDA,MAGXERR,MAGXIEN 220 S MAGGFDA(2006.82,MAGSESS,3)=MAGEND 221 ; calculate the length of the session 222 S MAGCON="" 223 S MAGGFDA(2006.82,MAGSESS,14)=MAGCON 224 D UPDATE^DIE("S","MAGGFDA","MAGXIEN","MAGXERR") 225 D ACTION("LOGOFF^") 226 ; 227 Q 228 RTRNERR(ETXT) ; There was error from UPDATE^DIE quit with error text 229 S ETXT="0^ERROR "_MAGXERR("DIERR",1,"TEXT",1) 230 Q 1 MAGGTAU ;WOIFO/GEK - RPC Calls to Update the Imaging Windows Workstation file ; [ 03/25/2001 11:20 ] 2 ;;3.0;IMAGING;**7,16,8**;Sep 15, 2004 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 | 13 ;; | in any way. Modifications to this software may result in an | 14 ;; | adulterated medical device under 21CFR820, the use of which | 15 ;; | is considered to be a violation of US Federal Statutes. | 16 ;; +---------------------------------------------------------------+ 17 ;; 18 Q 19 UPD(MAGRY,DATA) ;RPC [MAGG WRKS UPDATES] 20 ; Call from workstation updating it's exe's Date/Time 21 ; and other Workstation information into IMAGING WINDOWS WORKSTATION 22 ; at logon of user. 23 ; 24 ; DATA is '^' delimited piece 25 ; 1 Workstation name 2 Date/Time of capture app. 26 ; 3 Date/Time of Display App. 27 ; 4 Location of worksation 5 Date/Time of MAGSETUP 28 ; 6 Version of Display 7 Version of Capture 29 ; 8 1=Normal startup 2=Started by CPRS 3=Import API 30 ; 9 OS Version 10 VistaRad Version 31 N X,Y,Z 32 N MAGNAME,MAGCDT,MAGDDT,MAG0,MAGLOC,MAGIEN,MAGSETUP,MAGSTART,MAGSRV 33 N MAGVERSD,MAGVERSC,MAGMODE,MAGOSVER,MAGVERVR,MAGPL,MAGVERX 34 K MAGGFDA,MAGXERR,MAGXIEN 35 S MAGNAME=$P(DATA,U,1) 36 S MAGCDT=$P(DATA,U,2) 37 S MAGDDT=$P(DATA,U,3) 38 S MAGLOC=$P(DATA,U,4) 39 S MAGSETUP=$P(DATA,U,5) 40 S MAGVERSD=$P(DATA,U,6) 41 S MAGVERSC=$P(DATA,U,7) 42 S MAGMODE=$P(DATA,U,8) 43 S MAGOSVER=$P(DATA,U,9) 44 S MAGVERVR=$P(DATA,U,10) 45 S MAGIEN=0 46 I $L(MAGNAME) S MAGIEN=$O(^MAG(2006.81,"B",MAGNAME,"")) 47 I 'MAGIEN D NEWWRKS(MAGNAME,MAGLOC,.MAGIEN) 48 I MAGIEN<1 S MAGRY="0^Workstation Not on file" Q 49 ; 50 S %DT="T",X=MAGCDT D ^%DT S MAGCDT=Y 51 S %DT="T",X=MAGDDT D ^%DT S MAGDDT=Y 52 S %DT="T",X=MAGSETUP D ^%DT S MAGSETUP=Y 53 S MAG0=^MAG(2006.81,MAGIEN,0) ; '0' node for use later. 54 L +^MAG(2006.81,"LOCK",MAGIEN):0 55 S MAGIEN=+MAGIEN_"," 56 S MAGGFDA(2006.81,MAGIEN,.01)=MAGNAME ; Compter Name 57 I MAGCDT>-1 S MAGGFDA(2006.81,MAGIEN,4)=MAGCDT ;TELE19N.EXE dttm 58 I MAGDDT>-1 S MAGGFDA(2006.81,MAGIEN,5)=MAGDDT ;IMGVWP10.EXE dttm 59 I MAGSETUP>-1 S MAGGFDA(2006.81,MAGIEN,7)=MAGSETUP ; MAGSETUP.EXE dttm 60 S MAGGFDA(2006.81,MAGIEN,8)=1 ; Active or not. 61 S MAGGFDA(2006.81,MAGIEN,6)=MAGLOC ; location free text from .INI 62 S MAGGFDA(2006.81,MAGIEN,3)="@" ; delete logff time for this job. 63 S MAGGFDA(2006.81,MAGIEN,10)="@" ; delete session pointer 64 S MAGGFDA(2006.81,MAGIEN,11)="@" ; reset the session error count. 65 S MAGGFDA(2006.81,MAGIEN,9)=MAGVERSD ; IMGVWP10.EXE Version Info 66 S MAGGFDA(2006.81,MAGIEN,9.5)=MAGVERSC ; TELE19N.EXE Version Info 67 S MAGGFDA(2006.81,MAGIEN,9.7)=MAGVERVR ; VistARad.EXE Version Info 68 S MAGGFDA(2006.81,MAGIEN,13)=MAGOSVER ; Operating System Version. 69 ; 70 S X=$P(MAG0,U,12) 71 S MAGGFDA(2006.81,MAGIEN,12)=X+1 ; Sess count for wrks. 72 ; Keep the last PLACE that this wrks logged in. 73 S MAGPL=0 I $D(DUZ(2)) S MAGPL=+$$PLACE^MAGBAPI(DUZ(2)) ; DBI 74 I MAGPL S MAGGFDA(2006.81,MAGIEN,.04)=MAGPL ; DBI 75 ; 76 S X=$$NOW^XLFDT 77 S MAGSTART=$E(X,1,12) 78 I $G(DUZ) D 79 . S MAGGFDA(2006.81,MAGIEN,1)=DUZ 80 . S MAGGFDA(2006.81,MAGIEN,2)=MAGSTART 81 ; 82 D UPDATE^DIE("S","MAGGFDA","MAGXIEN","MAGXERR") 83 I $D(DIERR) D RTRNERR(.MAGRY) Q 84 ; The " MAGJOB(" array is used by Imaging routines that are 85 ; called from the Delphi App. 86 ; We use nodes of the Array MAGJ0B to organize the shared partition variables. 87 ; 88 ; 3.O.8 Whatever App calls this, we'll use that Version number. 89 S MAGVERX=$S(MAGVERSD]"":MAGVERSD,MAGVERSC]"":MAGVERSC,MAGVERVR]"":MAGVERVR,1:0) 90 S MAGJOB("WRKSIEN")=+MAGIEN 91 S MAGJOB("VERSION")=MAGVERX 92 S MAGRY="1^" 93 ; 94 ; SESSION : Now we create new session entry 95 D GETS^DIQ(200,DUZ_",","29","I","Z","") ; service/section 96 S MAGSRV=$G(Z(200,DUZ_",",29,"I")) 97 ; 98 K MAGGFDA,MAGXERR,MAGXIEN 99 S MAGGFDA(2006.82,"+1,",.01)=$P(^VA(200,DUZ,0),U,1) ; User 100 S MAGGFDA(2006.82,"+1,",1)=DUZ ; USER 101 S MAGGFDA(2006.82,"+1,",2)=MAGSTART ; Sess Start Time 102 S MAGGFDA(2006.82,"+1,",4)=+MAGIEN ; Wrks 103 S MAGGFDA(2006.82,"+1,",7)=+MAGSRV ; User's Service/Section 104 S MAGGFDA(2006.82,"+1,",13)=MAGMODE ; 1=normal 2= started by CPRS 105 ; DBI - save the logon PLACE in the Session file. 106 I MAGPL S MAGGFDA(2006.82,"+1,",.04)=MAGPL ; User's Institution (Imaging site param entry) 107 ; 108 ;3.0.8 new fields 9 Client Ver, 9.2 Host Version, 9.4 OS Version 109 S MAGGFDA(2006.82,"+1,",9)=MAGVERX ; 110 S MAGGFDA(2006.82,"+1,",9.2)=$$VERSION^XPDUTL("IMAGING") ; 111 S MAGGFDA(2006.82,"+1,",9.4)=MAGOSVER ; 112 ; 113 D UPDATE^DIE("","MAGGFDA","MAGXIEN","MAGXERR") 114 I $D(DIERR) D RTRNERR(.MAGRY) Q 115 S MAGRY="1^" 116 I '+MAGXIEN(1) S MAGRY="0^" Q 117 S MAGJOB("SESSION")=+MAGXIEN(1) 118 S MAGRY=MAGJOB("SESSION")_"^Session # "_MAGJOB("SESSION")_" Started." 119 S MAGGFDA(2006.81,+MAGIEN_",",10)=+MAGXIEN(1) 120 D UPDATE^DIE("","MAGGFDA","MAGXIEN","MAGXERR") 121 D ACTION("LOGON^") 122 Q 123 LOGACT(MAGRY,ACTION) ;RPC [MAG3 LOGACTION] 124 ; Call to log actions for Imaging Session from 125 ; Delphi interface 126 D ACTION(ACTION) 127 S MAGRY="1^Action Logged" 128 Q 129 ACTION(TXT,LOGTM,MAGSESS) ;Call to log actions for Imaging Workstation Session from other M routines 130 ; ACTIONS LOGGED 131 ; LOGON - Session StartTime LOGOFF - Session End Time 132 ; IMG - Image accessed PAT - Patient Accessed 133 ; CAP - Image Captured 134 ; DEL - Image Deleted MOD - Image entry modified 135 ; IMPORT - Import API has been called 136 ; Data - a node of data passed to Import API 137 ; Result - a node of the Result Array from Import API Processing. 138 ; Image - one of the Images (full path of import directory) that was imported. 139 ; PPACT - A Post processing Action has been processed. 140 ; VR-VW - VistaRad Exam displayed 141 ; VR-INT - VistaRad Exam interpreted 142 ; API - parameters sent to CP API, and the API Call i.e. ITIU-MDAPI 143 ; DFTINDX- If the index fields have no values, call to Patch 17 code to 144 ; generate the values for the fields. 145 ; MOD - This was intended to log Modifications to Image Entries, it is 146 ; (for now) only called when a group entry has an image added to its multiple. 147 ; 148 ; TXT is "^" delimited string 149 ; $P(1) is code ( see above ) $P(2) is DFN 150 ; $P(3) is Image IEN $P(4) reserved for procedure 151 ; $P(5) reserved for time-stamp $P(6) is Vrad Image Count 152 ; $P(7) is Vrad Patient Count 153 ; $P(8) is Vrad User Type (1/0 = Rad/Non-Rad) 154 ; $P(9) is Vrad REMOTE Read flag (1/0; 1=REMOTE) 155 ; $P(TXT,"$$",2) is Tracking ID from an Imported Image. From this we compute Session #, to log actions. 156 ; LOGTM - [1|0] Flag to indicate wheter or not to log the time of the Action. Default = 0 157 ; MAGSESS - Session IEN where the action should be logged. Default to MAGJOB("SESSION") 158 ; 159 N NODE,SESSIEN,MAGGFDA,MAGXERR,MAGXIEN,MAGPROC,LOGX,TRKID 160 S LOGTM=$G(LOGTM) 161 I TXT["$$" S TRKID=$P(TXT,"$$",2),TXT=$P(TXT,"$$",1) 162 S SESSIEN=$S($G(MAGSESS):MAGSESS,$D(MAGJOB("SESSION")):MAGJOB("SESSION"),$G(TRKID)'="":$O(^MAG(2006.82,"E",TRKID,""),-1),1:0) 163 I 'SESSIEN Q 164 S NODE="+1,"_SESSIEN_"," 165 I $P(TXT,U,3) S MAGPROC=$P($G(^MAG(2005,$P(TXT,U,3),0)),U,8) 166 ; 167 I $P(TXT,U)="PAT" D 168 . S Z=+$G(^MAG(2006.82,SESSIEN,1))+1 169 . S MAGGFDA(2006.82,SESSIEN_",",10)=Z 170 I $P(TXT,U)="IMG" D 171 . S Z=+$P($G(^MAG(2006.82,SESSIEN,1)),U,2)+1 172 . S MAGGFDA(2006.82,SESSIEN_",",11)=Z 173 . D ENTRY^MAGLOG("IMGVW",DUZ,$P(TXT,"^",3),"Wrks",$P(TXT,"^",2),"1") 174 . D ACCESS^MAGLOG($P(TXT,"^",3)) 175 I $E(TXT,1,3)="CAP" D 176 . S Z=+$P($G(^MAG(2006.82,SESSIEN,1)),U,3)+1 177 . S MAGGFDA(2006.82,SESSIEN_",",12)=Z 178 . D ENTRY^MAGLOG("CAP",DUZ,$P(TXT,"^",3),"Wrks",$P(TXT,"^",2),"1") 179 I $P(TXT,U,2) D 180 . S MAGGFDA(2006.82,SESSIEN_",",5)=$P(TXT,U,2) 181 I LOGTM D 182 . S X=$$NOW^XLFDT 183 . S $P(TXT,U,4)=$G(MAGPROC),$P(TXT,U,5)=$E(X,1,12) 184 S MAGGFDA(2006.821,NODE,.01)=$P(TXT,"|",1) 185 I $L(TXT,"|")>1 S MAGGFDA(2006.821,NODE,13)=$P(TXT,"|",2,99) 186 D UPDATE^DIE("S","MAGGFDA","MAGXIEN","MAGXERR") 187 Q 188 NEWWRKS(MAGNAME,MAGLOC,MAGIEN) ; 189 I $G(MAGNAME)="" Q 190 N Y,MAGNFDA,MAGNIEN 191 S MAGNFDA(2006.81,"+1,",.01)=MAGNAME 192 S MAGNFDA(2006.81,"+1,",6)=$G(MAGLOC) 193 D UPDATE^DIE("","MAGNFDA","MAGNIEN") 194 S MAGIEN=MAGNIEN(1) 195 Q 196 LOGOFF(MAGRY) ;RPC [MAGG LOGOFF] Call when session is over. 197 ; This updates session file with logoff time 198 ; and marks the session closed. 199 ; 200 K ^TMP("MAGGTAU","LOGOFF",$J) 201 S MAGRY=1 202 N MAGGFDA,MAGXERR,MAGXIEN,MAGIEN,MAGSESS,MAGEND,MAGCON 203 ; The Imaging Workstation file keeps time of login 204 ; We'll enter the logoff time ($$now^xlfdt) here. 205 S X=$$NOW^XLFDT 206 S MAGEND=$E(X,1,12) 207 Q:'+$G(MAGJOB("WRKSIEN")) 208 L -^MAG(2006.81,"LOCK",MAGJOB("WRKSIEN")) 209 S MAGIEN=+MAGJOB("WRKSIEN")_"," 210 S MAGGFDA(2006.81,MAGIEN,3)=MAGEND ; logoff dttm 211 S MAGGFDA(2006.81,MAGIEN,8)=0 ; Set job number to 0 212 D UPDATE^DIE("S","MAGGFDA","MAGXIEN","MAGXERR") 213 ;MAGJOB("WRKSIEN") 214 Q:(+$G(MAGJOB("SESSION"))=0) 215 S MAGSESS=+MAGJOB("SESSION")_"," 216 K MAGGFDA,MAGXERR,MAGXIEN 217 S MAGGFDA(2006.82,MAGSESS,3)=MAGEND 218 ; calculate the length of the session 219 S MAGCON="" 220 S MAGGFDA(2006.82,MAGSESS,14)=MAGCON 221 D UPDATE^DIE("S","MAGGFDA","MAGXIEN","MAGXERR") 222 D ACTION("LOGOFF^") 223 ; 224 Q 225 RTRNERR(ETXT) ; There was error from UPDATE^DIE quit with error text 226 S ETXT="0^ERROR "_MAGXERR("DIERR",1,"TEXT",1) 227 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGTERR.m
r613 r623 1 MAGGTERR ;WOIFO/GEK - IMAGING ERROR TRAP, AND ERROR LOG ; [ 06/20/2001 08:56 ] 2 ;;3.0;IMAGING;**8,59**;Nov 27, 2007;Build 20 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 ; Imaging routines should have this code for setting error trap 21 ; This will enable logging Imaging errors and Sending messages for 22 ; certain errors etc. later 23 ;N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR" 24 ; 25 ; This assumes the Return variable or array is MAGRY or MAGRY() 26 Q 27 ERRA ; ERROR TRAP FOR Array Return variables 28 N ERR S ERR=$$EC^%ZOSV 29 S MAGRY(0)="0^"_ERR 30 D LOGERR(ERR) 31 D @^%ZOSF("ERRTN") 32 Q 33 ; 34 AERRA ; ERROR TRAP FOR Global Return Variables 35 N ERR S ERR=$$EC^%ZOSV 36 S @MAGRY@(0)="0^ERROR "_ERR 37 D LOGERR(ERR) 38 D @^%ZOSF("ERRTN") 39 Q 40 ERR ; ERROR TRAP FOR String Return variables 41 N ERR S ERR=$$EC^%ZOSV 42 S MAGRY="0^ERROR "_ERR 43 D LOGERR(ERR) 44 D @^%ZOSF("ERRTN") 45 Q 46 LOGERR(ERROR) ; 47 Q:'$G(MAGJOB("SESSION")) 48 N SESS,WRKS,ERR 49 S SESS=$G(MAGJOB("SESSION")) 50 ; Quit if No entry in Session File. 51 Q:'$D(^MAG(2006.82,SESS,0)) 52 I '$D(^MAG(2006.82,SESS,"ERR",0)) S ^MAG(2006.82,SESS,"ERR",0)="^2006.823A^0^0" 53 S ERR=$O(^MAG(2006.82,SESS,"ERR"," "),-1)+1 54 S ^MAG(2006.82,SESS,"ERR",ERR,0)=ERROR 55 S $P(^MAG(2006.82,SESS,"ERR",0),"^",3,4)=ERR_"^"_ERR 56 ; 57 Q:'$G(MAGJOB("WRKSIEN")) 58 S WRKS=$G(MAGJOB("WRKSIEN")) 59 ; Quit if No entry in Workstation File. 60 Q:'$D(^MAG(2006.81,WRKS,0)) 61 S $P(^MAG(2006.81,WRKS,0),"^",11)=ERR 62 Q 1 MAGGTERR ;WOIFO/GEK - IMAGING ERROR TRAP, AND ERROR LOG ; [ 06/20/2001 08:56 ] 2 ;;3.0;IMAGING;**8**;Sep 15, 2004 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 Q 19 ; Imaging routines should have this code for setting error trap 20 ; This will enable logging Imaging errors and Sending messages for 21 ; certain errors etc. later 22 ;IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR" 23 ;E S X="ERRA^MAGGTERR",@^%ZOSF("TRAP") 24 ; 25 ; This assumes the Return variable or array is MAGRY or MAGRY() 26 Q 27 ERRA ; ERROR TRAP FOR Array Return variables 28 N ERR S ERR=$$EC^%ZOSV 29 S MAGRY(0)="0^"_ERR 30 D LOGERR(ERR) 31 D @^%ZOSF("ERRTN") 32 Q 33 ; 34 AERRA ; ERROR TRAP FOR Global Return Variables 35 N ERR S ERR=$$EC^%ZOSV 36 S @MAGRY@(0)="0^ERROR "_ERR 37 D LOGERR(ERR) 38 D @^%ZOSF("ERRTN") 39 Q 40 ERR ; ERROR TRAP FOR String Return variables 41 N ERR S ERR=$$EC^%ZOSV 42 S MAGRY="0^ERROR "_ERR 43 D LOGERR(ERR) 44 D @^%ZOSF("ERRTN") 45 Q 46 LOGERR(ERROR) ; 47 Q:'$G(MAGJOB("SESSION")) 48 N MAGGFDA,MAGXERR,MAGXIEN,MAGNODE 49 S MAGNODE="+1,"_+MAGJOB("SESSION")_"," 50 ;S MAGNODE="+1,10," 51 S MAGGFDA(2006.823,MAGNODE,.01)=ERROR 52 D UPDATE^DIE("","MAGGFDA","MAGXIEN","MAGXERR") 53 ; error flag for this session in workstation file 54 S MAGNODE=+MAGJOB("WRKSIEN")_"," 55 S MAGGFDA(2006.81,MAGNODE,11)=+MAGXIEN(1) ; 56 D UPDATE^DIE("","MAGGFDA","MAGXIEN","MAGXERR") 57 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGTIA1.m
r613 r623 1 MAGGTIA1 ;WOIFO/GEK - RPC Call to Add Image File entry ; [ 06/20/2001 08:56 ] 2 ;;3.0;IMAGING;**21,8,59**;Nov 27, 2007;Build 20 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 ADD ;Now call Fileman to file the data 21 N GIEN,DIEN,NEWIEN,MAGGDA,X,Y 22 ;Because we delete the Image node on image deletion, we have to 23 ; check the last entry in Audit File, to see if it is greater than 24 ; last image in Image File. 25 I ($O(^MAG(2005,"A"),-1)<$O(^MAG(2005.1,"A"),-1)) S $P(^MAG(2005,0),U,3)=$O(^MAG(2005.1,"A"),-1) 26 ; we know that MAGGIEN WILL contain the internal number. 27 ; after the call. 28 ; 29 I $G(MAGMOD) D Q ; WE'LL QUIT AFTER MODIFICATION 30 . D UPDATE^DIE("S","MAGGFDA","MAGGIEN","MAGGXE") 31 . S MAGRY="1^OK" 32 . ; Now, after UPDATE^DIE, we aren't getting the MAGGIEN array., We'll use MAGMOD 33 . D ACTION^MAGGTAU("MOD^"_$P(^MAG(2005,+MAGMOD,0),U,7)_"^"_+$G(MAGMOD)) ; This is the Image IEN 34 ; 35 ; There are incidents of using an IEN from a deleted image 36 ; these next lines are to stop the problem. 37 S GIEN=$O(^MAG(2005," "),-1)+1 38 S DIEN=$O(^MAG(2005.1," "),-1)+1 39 S NEWIEN=$S(GIEN>DIEN:GIEN,1:DIEN) 40 LOCK L +^MAG(2005,NEWIEN):0 E S NEWIEN=NEWIEN+1 G LOCK 41 I $D(^MAG(2005,NEWIEN)) L -^MAG(2005,NEWIEN) S NEWIEN=NEWIEN+1 G LOCK 42 S MAGGIEN(1)=NEWIEN 43 D UPDATE^DIE("S","MAGGFDA","MAGGIEN","MAGGXE") 44 ; 45 I '$G(MAGGIEN(1)) D S MAGRY=MAGERR Q 46 . S MAGERR="0^ERROR Creating new Image File Entry " 47 . I $D(DIERR) D RTRNERR(.MAGERR) 48 . D CLEAN 49 ; 50 S MAGGDA=MAGGIEN(1) 51 ; 52 D ACTION^MAGGTAU("CAP^"_MAGGFDA(2005,"+1,",5)_"^"_MAGGDA) 53 ; 54 ; IF a group, Modify GROUP PARENT in each Group Object and QUIT 55 ; we'll do this by hand, Else it'll take forever. 56 ; we Return the IEN with NO Filename. Groups don't get Filename 57 ; 58 I MAGGR S MAGRY=MAGGDA_U,Z="" D G C1 59 . F S Z=$O(MAGGR(Z)) Q:Z="" S $P(^MAG(2005,Z,0),U,10)=MAGGDA 60 . D CLEAN 61 ; 62 S X=$G(MAGGFDA(2005,"+1,",14)) I +X D 63 . ; If here: This image is a member of a Group 64 . ; -Modify the Group Parent, add DA to it's group 65 . ; -Also set 'Series Number' and 'Image Number' if they exist; 66 . K MAGGFDA 67 . S Y="+2,"_X_"," 68 . S MAGGFDA(2005.04,Y,.01)=MAGGDA 69 . ; GEK 4/4/00 ADDED $L( we were dying on "0" 70 . I $L($G(MAGDCMSN)) S MAGGFDA(2005.04,Y,1)=MAGDCMSN 71 . I $L($G(MAGDCMIN)) S MAGGFDA(2005.04,Y,2)=MAGDCMIN 72 . D UPDATE^DIE("S","MAGGFDA","MAGGIEN","MAGGXE") 73 ; 74 ; Now get the Image file name. DOS FILE name 75 ; The ENTRY in Image File has been made, if any errors from here on 76 ; then we have to delete the image entry. 77 I $D(MAGGFDA(2005,"+1,",1)) S MAGGFNM=MAGGFDA(2005,"+1,",1) G C1 78 K MAGGFDA 79 S X=$$DA2NAME^MAGGTU1(MAGGDA,$G(MAGGEXT)) I 'X D S MAGRY=MAGERR Q 80 . S MAGERR=X 81 . S DA=MAGGDA,DIK="^MAG(2005," D ^DIK 82 . K DA,DIC,DIK 83 . D CLEAN 84 S MAGGFNM=$P(X,U,2),Y=MAGGDA_"," 85 S MAGGFDA(2005,Y,1)=MAGGFNM 86 D UPDATE^DIE("","MAGGFDA","","MAGGXE") 87 ; shouldn't have an error just editing one entry, but just in case. 88 I $D(DIERR) D S MAGRY=MAGERR Q 89 . D RTRNERR(.MAGERR) 90 . S DA=MAGGDA,DIK="^MAG(2005," D ^DIK 91 . K DA,DIC,DIK 92 . D CLEAN 93 ; 94 C1 ; we jump here if we already had a Filename sent 95 K MAGGFDA 96 ; New Index Field Check. If this entry doesn't have the Index fields introduced 97 ; in 3.0.8 then we use the Patch 17 conversion API call to generate default values. 98 ; 99 ;P59 Now we Auto-Generate the Index Fields, if they don't exist for this entry. 100 I '$D(^MAG(2005,MAGGDA,40)) D 101 . N INDXD 102 . D GENIEN^MAGXCVI(MAGGDA,.INDXD) 103 . S ^MAG(2005,MAGGDA,40)=INDXD 104 . S ^MAGIXCVT(2006.96,MAGGDA)=2 ; Flag. Says fields were converted Patch 59 105 . ; TRKING ID TRKID = MAGGFDA(2005,"+1,",108) 106 . D ACTION^MAGGTAU("INDEX-ALL^"_$P(^MAG(2005,MAGGDA,0),"^",7)_"^"_MAGGDA) ;_"$$"_MAGGFDA(2005,"+1,",108)) 107 . D ENTRY^MAGLOG("INDEX-ALL",DUZ,MAGGDA,"P59",$P(^MAG(2005,MAGGDA,0),"^",7),1) 108 . Q 109 ;P59 If TYPE INDEX is missing we Auto-Generate Index Type and other missing Index Term values. 110 I '$P(^MAG(2005,MAGGDA,40),"^",3) D 111 . N INDXD,OLD40,N40 112 . S (N40,OLD40)=^MAG(2005,MAGGDA,40) 113 . D GENIEN^MAGXCVI(MAGGDA,.INDXD) 114 . ; If Origin doesn't exist in existing, this will put V in. 115 . I $P(INDXD,"^",6)="" S $P(INDXD,"^",6)="V" 116 . ; We're not changing existing values of Spec,Proc or Origin 117 . F J=1:1:6 I '$L($P(N40,"^",J)) S $P(N40,"^",J)=$P(INDXD,"^",J) 118 . ;Validate the merged Spec and Proc, if not valid, revert back to old Spec and Proc 119 . I '$$VALINDEX^MAGGSIV1(.X,$P(N40,"^",3),$P(N40,"^",5),$P(N40,"^",4)) S $P(N40,"^",4,5)=$P(OLD40,"^",4,5) 120 . S ^MAG(2005,MAGGDA,40)=N40 121 . D ACTION^MAGGTAU("INDEX-42^"_$P(^MAG(2005,MAGGDA,0),"^",7)_"^"_MAGGDA) ;_"$$"_MAGGFDA(2005,"+1,",108)) 122 . D ENTRY^MAGLOG("INDEX-42",DUZ,MAGGDA,"P59",$P(^MAG(2005,MAGGDA,0),"^",7),1) 123 . Q 124 ;** ABS and JB image queues AREN'T SET WHEN ADDING AN IMAGE. 125 ;** IT IS DONE IN A SEPERATE CALL 126 ;** RPC =-> 'MAG ABSJB' after abstract is/isn't created on 127 ;** the workstation 128 ; 129 ; Queue it to be copied to Jukebox. 130 ; CREATE ABSTRACT 131 ; visn15 ADDED $$DA2PLCA to resolve the Image's current PLACE 132 I $G(MAGGABS)="YES" S X=$$ABSTRACT^MAGBAPI(MAGGDA,$$DA2PLC^MAGBAPIP(MAGGDA,"A")) 133 ; RESTORE AFTER GLOBAL SETUP 134 I $G(MAGGJB)="YES" S X=$$JUKEBOX^MAGBAPI(MAGGDA,$$DA2PLC^MAGBAPIP(MAGGDA,"F")) 135 ; Code for setting a Queue to Copy BIG to JUKEBOX 136 ; 137 ; We return the IEN ^ DRIVE:DIR ^ FILE.EXT 138 ; example: 487^C:\IMAGE\^DC000487.TIF 139 ; The calling routine is responsible for renaming/naming the file 140 ; to the returned DRIVE:\DIR\FILENAME.EXT 141 ; 4/23/98 to include hierarchical directory structure -- PMK 142 ; 143 I 'MAGGR D 144 . S MAGDHASH=$$DIRHASH^MAGFILEB(MAGGFNM,MAGREF) 145 . S MAGRY=MAGGDA_U_MAGGDRV_MAGDHASH_U_MAGGFNM 146 . ; For now, BIG files are in same directory as FullRes (or PACS) file 147 . I $G(MAGBIG) D 148 . . S X=$P(MAGGFNM,".",1)_".BIG" 149 . . S MAGRY=MAGRY_U_MAGGDRV_MAGDHASH_U_X 150 . . Q 151 . Q 152 ; 153 CLEAN ; 154 D CLEAN^DILF 155 L -^MAG(2005,NEWIEN) 156 Q 157 RTRNERR(ETXT) ; There was error from UPDATE^DIE quit with error text 158 S ETXT="0^ERROR "_MAGGXE("DIERR",1,"TEXT",1) 159 Q 160 ERR ; Error trap 161 S MAGRY="0^ERROR "_$$EC^%ZOSV 162 D @^%ZOSF("ERRTN") 163 Q 164 MAKENAME() ; MAGGFDA exists so get info from that. 165 ; We'll make NAME (.01) with PATIENT NAME SSN 166 ; DOCUMENT Imaging was making name of 167 ; $E(PATENT NAME,1,10)' '$E(DESC CATEG,1,9)' 'MM/DD/YY (DOC DATE) 168 N Z,ZT,ZNAME,ZSSN,ZDESC 169 ; GEK 10/10/2000 170 ; Modifying this procedure to make same name for all Image types 171 ; The name will be (first 18 chars of patient Name) _ SSN 172 I $D(MAGGFDA(2005,"+1,",10)) S ZDESC=$E(MAGGFDA(2005,"+1,",10),1,30) 173 I $D(MAGGFDA(2005,"+1,",5)) D 174 . S X=MAGGFDA(2005,"+1,",5) 175 . S ZNAME=$P(^DPT(X,0),U),ZSSN=$P(^DPT(X,0),U,9) 176 ; 177 ; For all Images the name is first 18 characters of patient name 178 ; concatenated with SSN. If No patient name is sent, well make 179 ; the name from the short desc. 180 I $D(ZNAME) S Z=$E(ZNAME,1,18)_" "_ZSSN 181 E S Z=ZDESC 182 Q Z 1 MAGGTIA1 ;WOIFO/GEK - RPC Call to Add Image File entry ; [ 06/20/2001 08:56 ] 2 ;;3.0;IMAGING;**21,8**;Sep 15, 2004 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 Q 19 ADD ;Now call Fileman to file the data 20 N GIEN,DIEN,NEWIEN,MAGGDA,X,Y 21 ;Because we delete the Image node on image deletion, we have to 22 ; check the last entry in Audit File, to see if it is greater than 23 ; last image in Image File. 24 I ($O(^MAG(2005,"A"),-1)<$O(^MAG(2005.1,"A"),-1)) S $P(^MAG(2005,0),U,3)=$O(^MAG(2005.1,"A"),-1) 25 ; we know that MAGGIEN WILL contain the internal number. 26 ; after the call. 27 ; 28 I $G(MAGMOD) D Q ; WE'LL QUIT AFTER MODIFICATION 29 . D UPDATE^DIE("S","MAGGFDA","MAGGIEN","MAGGXE") 30 . S MAGRY="1^OK" 31 . ; Now, after UPDATE^DIE, we aren't getting the MAGGIEN array., We'll use MAGMOD 32 . D ACTION^MAGGTAU("MOD^"_$P(^MAG(2005,+MAGMOD,0),U,7)_"^"_+$G(MAGMOD)) ; This is the Image IEN 33 ; 34 ; There are incidents of using an IEN from a deleted image (still) 35 ; these next lines are TESTING for now. To stop the problem. 36 S GIEN=$O(^MAG(2005," "),-1)+1 37 S DIEN=$O(^MAG(2005.1," "),-1)+1 38 S NEWIEN=$S(GIEN>DIEN:GIEN,1:DIEN) 39 LOCK L +^MAG(2005,NEWIEN):0 E S NEWIEN=NEWIEN+1 G LOCK 40 I $D(^MAG(2005,NEWIEN)) L -^MAG(2005,NEWIEN) S NEWIEN=NEWIEN+1 G LOCK 41 S MAGGIEN(1)=NEWIEN 42 D UPDATE^DIE("S","MAGGFDA","MAGGIEN","MAGGXE") 43 ; 44 I '$G(MAGGIEN(1)) D S MAGRY=MAGERR Q 45 . S MAGERR="0^ERROR Creating new Image File Entry " 46 . I $D(DIERR) D RTRNERR(.MAGERR) 47 . D CLEAN 48 ; 49 S MAGGDA=MAGGIEN(1) 50 ; 51 D ACTION^MAGGTAU("CAP^"_MAGGFDA(2005,"+1,",5)_"^"_MAGGDA) 52 ; 53 ; IF a group, Modify GROUP PARENT in each Group Object and QUIT 54 ; we'll do this by hand, Else it'll take forever. 55 ; we Return the IEN with NO Filename. Groups don't get Filename 56 ; 57 I MAGGR S MAGRY=MAGGDA_U,Z="" D Q 58 . F S Z=$O(MAGGR(Z)) Q:Z="" S $P(^MAG(2005,Z,0),U,10)=MAGGDA 59 . D CLEAN 60 ; 61 S X=$G(MAGGFDA(2005,"+1,",14)) I +X D 62 . ; We're here beceause this image is a member of a Group 63 . ; so we will modify the Group Parent, adding this to it's group 64 . ; HERE we will also send the 'Series Number' and 'Image Number' if 65 . ; they exist; 66 . K MAGGFDA 67 . S Y="+2,"_X_"," 68 . S MAGGFDA(2005.04,Y,.01)=MAGGDA 69 . ; GEK 4/4/00 ADDED $L( we were dying on "0" 70 . I $L($G(MAGDCMSN)) S MAGGFDA(2005.04,Y,1)=MAGDCMSN 71 . I $L($G(MAGDCMIN)) S MAGGFDA(2005.04,Y,2)=MAGDCMIN 72 . D UPDATE^DIE("S","MAGGFDA","MAGGIEN","MAGGXE") 73 ; 74 ; 75 ; 76 ; now get the Image file name. DOS FILE name 77 ; ENTRY in Image File has been made, if any errors from here on 78 ; then we have to delete the image entry. 79 I $D(MAGGFDA(2005,"+1,",1)) S MAGGFNM=MAGGFDA(2005,"+1,",1) G C1 80 K MAGGFDA 81 S X=$$DA2NAME^MAGGTU1(MAGGDA,$G(MAGGEXT)) I 'X D S MAGRY=MAGERR Q 82 . S MAGERR=X 83 . S DA=MAGGDA,DIK="^MAG(2005," D ^DIK 84 . K DA,DIC,DIK 85 . D CLEAN 86 S MAGGFNM=$P(X,U,2),Y=MAGGDA_"," 87 S MAGGFDA(2005,Y,1)=MAGGFNM 88 D UPDATE^DIE("","MAGGFDA","","MAGGXE") 89 ; shouldn't have an error just editing one entry, but just in case. 90 I $D(DIERR) D S MAGRY=MAGERR Q 91 . D RTRNERR(.MAGERR) 92 . S DA=MAGGDA,DIK="^MAG(2005," D ^DIK 93 . K DA,DIC,DIK 94 . D CLEAN 95 ; 96 C1 ; we jump here if we already had a Filename sent 97 ; 98 K MAGGFDA 99 ; New Index Field Check. If this entry doesn't have the Index fields introduced 100 ; in 3.0.8 then we use the Patch 17 conversion API call to generate default values. 101 ; 102 ;-This is being deferred to a later patch. 103 ;-I '$D(^MAG(2005,MAGGDA,40)) D 104 ;-. D ONE^MAGSCNVI(MAGGDA) 105 ;-. D ACTION^MAGGTAU("DFTINDX^^"_MAGGDA) 106 ; 107 ;** ABS and JB image queues AREN'T SET WHEN ADDING AN IMAGE. 108 ;** IT IS DONE IN A SEPERATE CALL 109 ;** RPC =-> 'MAG ABSJB' after abstract is/isn't created on 110 ;** the workstation 111 ; 112 ; Queue it to be copied to Jukebox. 113 ; CREATE ABSTRACT 114 ; visn15 ADDED $$DA2PLCA to resolve the Image's current PLACE 115 I $G(MAGGABS)="YES" S X=$$ABSTRACT^MAGBAPI(MAGGDA,$$DA2PLC^MAGBAPIP(MAGGDA,"A")) 116 ; RESTORE AFTER GLOBAL SETUP 117 I $G(MAGGJB)="YES" S X=$$JUKEBOX^MAGBAPI(MAGGDA,$$DA2PLC^MAGBAPIP(MAGGDA,"F")) 118 ; Code for setting a Queue to Copy BIG to JUKEBOX 119 ; 120 ; We return the IEN ^ DRIVE:DIR ^ FILE.EXT 121 ; i.e 487^C:\IMAGE\^DC000487.TIF 122 ; The calling routine is responsible for renaming/naming the file 123 ; to the returned DRIVE:\DIR\FILENAME.EXT 124 ; Modified 4/23/98 to include hierarchial directory structure -- PMK 125 ; 126 S MAGDHASH=$$DIRHASH^MAGFILEB(MAGGFNM,MAGREF) 127 S MAGRY=MAGGDA_U_MAGGDRV_MAGDHASH_U_MAGGFNM 128 ; For now, BIG files are in same directory as FullRes (or PACS) file 129 I $G(MAGBIG) D 130 . S X=$P(MAGGFNM,".",1)_".BIG" 131 . S MAGRY=MAGRY_U_MAGGDRV_MAGDHASH_U_X 132 . Q 133 ; 134 CLEAN ; 135 D CLEAN^DILF 136 L -^MAG(2005,NEWIEN) 137 Q 138 RTRNERR(ETXT) ; There was error from UPDATE^DIE quit with error text 139 S ETXT="0^ERROR "_MAGGXE("DIERR",1,"TEXT",1) 140 Q 141 ERR ; Error trap 142 S MAGRY="0^ERROR "_$$EC^%ZOSV 143 D @^%ZOSF("ERRTN") 144 Q 145 MAKENAME() ; MAGGFDA exists so get info from that. 146 ; We'll make NAME (.01) with PATIENT NAME SSN 147 ; DOCUMENT Imaging was making name of 148 ; $E(PATENT NAME,1,10)' '$E(DESC CATEG,1,9)' 'MM/DD/YY (DOC DATE) 149 N Z,ZT,ZNAME,ZSSN,ZDESC 150 ; GEK 10/10/2000 151 ; Modifying this procedure to make same name for all Image types 152 ; The name will be (first 18 chars of patient Name) _ SSN 153 I $D(MAGGFDA(2005,"+1,",10)) S ZDESC=$E(MAGGFDA(2005,"+1,",10),1,30) 154 I $D(MAGGFDA(2005,"+1,",5)) D 155 . S X=MAGGFDA(2005,"+1,",5) 156 . S ZNAME=$P(^DPT(X,0),U),ZSSN=$P(^DPT(X,0),U,9) 157 ; 158 ; For all Images the name is first 18 characters of patient name 159 ; concatenated with SSN. If No patient name is sent, well make 160 ; the name from the short desc. 161 I $D(ZNAME) S Z=$E(ZNAME,1,18)_" "_ZSSN 162 E S Z=ZDESC 163 Q Z -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGTID.m
r613 r623 1 MAGGTID ;WOIFO/SRR/RED/SAF/GEK - Deletion of Images and Pointers ; [ 06/20/2001 08:56 ] 2 ;;3.0;IMAGING;**8,59**;Nov 27, 2007;Build 20 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 ; 21 IMAGEDEL(MAGGRY,MAGIEN,MAGGRPDF,REASON) ;RPC [MAGG IMAGE DELETE] 22 ; Call to Delete Image entry from Image file ^MAG(2005 23 ; MAGIEN Image IEN ^ SYSDEL flag 24 ; MAGGRPDF group delete flag 1 = group delete allowed 25 ; SYSDEL Flag that forces delete, even if no KEY 26 ; 27 N Y,RY 28 ; 1 in 3rd piece means : DELETE the Image File Also. 29 S MAGGRPDF=+$G(MAGGRPDF),REASON=$G(REASON) 30 L +^MAG(2005,MAGIEN):4 31 E S MAGGRY(0)="Image ID# "_MAGIEN_" is Locked. Delete is Canceled" Q 32 D DELETE(.MAGGRY,MAGIEN,1,MAGGRPDF,REASON) 33 L -^MAG(2005,MAGIEN) 34 Q 35 DELETE(RY,MAGIEN,DF,GRPDF,REASON) ;RPC [MAGQ DIK] Entry point for silent call 36 ;RY=Return Array RY(0)="1^SUCCESS" 37 ; RY(0)="0^reason for failure" 38 ; ;NOT RETURNING LIST AT THIS TIME 39 ; ( RY(1)..RY(n)= IEN's of deleted images.) 40 ;MAGIEN=Image entry number to be deleted 41 ; if MAGIEN has a 2nd piece = 1 then we force delete, don't test 42 ; for MAG DELETE KEY 43 ;DF=Delete file flag - 1=delete the Image file 44 ; - 0=don't delete the image file 45 ; 46 S REASON=$G(REASON) I REASON="" S REASON="Unknown reason" 47 S RY(0)="0^Image Delete Failed, reason unknown." 48 S:'$D(MAGSYS) MAGSYS=^%ZOSF("VOL") 49 N MAGERR,SYSDEL,Z 50 S SYSDEL=+$P(MAGIEN,U,2) 51 ; Check the business rules for deleting an image 52 D DELETE^MAGSIMBR(.RY,MAGIEN,SYSDEL) I +RY(0)=0 Q 53 S MAGIEN=+MAGIEN 54 ; a couple tests of privilage and valid IEN 55 I '$D(^MAG(2005,MAGIEN,0)) D Q 56 . S RY(0)="0^Image entry doesn't exist in image file" 57 I +$O(^MAG(2005,MAGIEN,1,0)),+$G(GRPDF)=0 D Q 58 . S RY(0)="0^Deleting a Group is not allowed." 59 I +$O(^MAG(2005,MAGIEN,1,0)),+$G(GRPDF)'=0 D Q 60 . N MAGGRP S MAGGRP=MAGIEN N MAGIEN,MAGX,MAGOK,MAGFAIL 61 . S MAGX=0,MAGOK=0,MAGFAIL=0 62 . F S MAGX=$O(^MAG(2005,MAGGRP,1,MAGX)) Q:'MAGX D 63 . . S MAGIEN=$P($G(^MAG(2005,MAGGRP,1,MAGX,0)),"^") D DEL1IMG 64 . . I +RY(0) S Z=+$O(RY(""),-1),RY(Z)=RY(Z)_"^"_RY(0),MAGOK=MAGOK+1 65 . . E S Z=+$O(RY(""),-1)+1,RY(Z)=MAGIEN_"^"_RY(0),MAGFAIL=MAGFAIL+1 66 . . Q 67 . I +MAGFAIL=0 S RY(0)="1^Deletion of Group #"_MAGGRP_" was successful.^"_MAGOK_"^0" 68 . E S RY(0)="0^Error deleting child image(s). Group Not Deleted.^"_MAGOK_"^"_MAGFAIL 69 . Q 70 ; 71 ; Ok lets start 72 ; lets delete the parent pointers first. 73 DEL1IMG ; 74 N DELMSG,Z 75 D DELPAR^MAGSDEL2 76 I $G(MAGERR) S RY(0)="0^Error: Deleting Specialty Pointers. Image Not Deleted. "_DELMSG Q 77 ; 78 ; Now delete image record & xref's 79 ; if this Image is member of group DELGRP will delete those pointers 80 ; and delete the Group, if this is only image in it. 81 S MAGDFN=$P($G(^MAG(2005,MAGIEN,0)),"^",7) ; Moved here from below. DELGRP needs MAGDFN now. 82 D DELGRP 83 I $G(MAGERR) S RY(0)="0^Error deleting Group Pointers." Q 84 ; 85 ; write the deleted by, delete reason, and delete date to the file. 86 D SETDEL(MAGIEN,REASON) 87 ; 88 ; save the Image record to the archive before we delete it. 89 D ARCHIVE(MAGIEN) 90 ; 91 ; Now let's set the Queue to delete the Image File, if Flag is set 92 I $G(DF) D DELFILE 93 ; 94 ; we're having "APPXDT" crossref left around, lets delete it first. 95 S X=MAGDFN,DA=MAGIEN D KILPPXD^MAGUXRF 96 ; 97 ; now lets delete the image. 98 K DIK,DA,DA(1),DA(2),DIC,DR,DIE,DIR S DIK="^MAG(2005,",DA=MAGIEN 99 D ^DIK 100 S Z=+$O(RY(""),-1)+1,RY(Z)=MAGIEN 101 ; we were having problems with "AC" so lets check to make sure. 102 I $D(^MAG(2005,"AC",MAGDFN,MAGIEN)) K ^MAG(2005,"AC",MAGDFN,MAGIEN) 103 ; log it. 104 D ENTRY^MAGLOG("DELETE",$G(DUZ),$G(MAGIEN),"PARENT:"_$G(MAGSTORE),$G(MAGDFN),1) 105 S X="DEL^"_$G(MAGDFN)_"^"_$G(MAGIEN) 106 D ACTION^MAGGTAU(X,"1") 107 S RY(0)="1^Deletion of Image was Successful." 108 Q 109 DELGRP ;del grp ptrs and check to see if this is the last image in the group 110 N MAGGRP,MAGX,MAGQUIT,MAGIFNS,Z 111 S MAGGRP=$P($G(^MAG(2005,MAGIEN,0)),"^",10) 112 Q:'$G(MAGGRP) 113 K DIK,DA,DA(1),DA(2),DIC,DR,DIE,DIR 114 S MAGX=0,MAGQUIT=0 115 F S MAGX=$O(^MAG(2005,MAGGRP,1,MAGX)) Q:'MAGX D Q:MAGQUIT 116 . I +^MAG(2005,MAGGRP,1,MAGX,0)=MAGIEN D 117 . . S DIK="^MAG(2005,MAGGRP,1,",DA(1)=MAGGRP,DA=MAGX D ^DIK S MAGQUIT=1 118 . . ;added DA(1) needed for xref deletion of dicom series 119 . I $O(^MAG(2005,MAGGRP,1,0))="" D 120 . . I $P($G(^MAG(2005,MAGGRP,2)),"^",6) D 121 . . . ;report is on group - need to delete it 122 . . . S MAGIFNS=MAGIEN,MAGIEN=MAGGRP 123 . . . D DELPAR^MAGSDEL2 124 . . . S MAGIEN=MAGIFNS 125 . . I '$D(MAGERR) D 126 . . . D SETDEL(MAGGRP,REASON),ARCHIVE(MAGGRP) S DIK="^MAG(2005,",DA=MAGGRP D ^DIK 127 . . . ; Log the Deletion of The Group Header to ^MAG(2006.95, and ^MAG(2006.82 128 . . . D ENTRY^MAGLOG("DELETE",$G(DUZ),$G(MAGGRP),"PARENT:"_$G(MAGSTORE),$G(MAGDFN),1,"Group Header deleted") 129 . . . S X="DEL^"_$G(MAGDFN)_"^"_$G(MAGGRP) 130 . . . D ACTION^MAGGTAU(X,"1") 131 . . . S Z=+$O(RY(""),-1)+1,RY(Z)=MAGGRP_"^1^Deletion of Group was Successful." 132 . . . Q 133 . . Q 134 . Q 135 Q 136 SETDEL(MAGIEN,REASON) ; set deletion fields 137 N DA,DR,DIE,X 138 ;N %H 139 ;S %H=$H D YMD^%DTC 140 S X=$$NOW^XLFDT 141 ; gek - changed 3 slash to 4 slash. to stop FM question marks. ?? 142 S DR="30////"_DUZ_";30.1////"_X_";30.2////"_REASON 143 S DIE="2005",DA=MAGIEN D ^DIE 144 Q 145 ; 146 ARCHIVE(MAGARCIE) ;save image data before deletion 147 N MAGCNT,MAGLAST,%X,%Y 148 S MAGCNT=$P(^MAG(2005.1,0),U,4)+1 149 S %X="^MAG(2005,"_MAGARCIE_",",%Y="^MAG(2005.1,"_MAGARCIE_"," 150 D %XY^%RCR 151 ; GEK 9/29/00 Fix the 3rd piece to be last ien in file. 152 S MAGLAST=$O(^MAG(2005.1,"A"),-1) 153 S $P(^MAG(2005.1,0),U,4)=MAGCNT 154 I '($P(^MAG(2005.1,0),U,3)=MAGLAST) S $P(^MAG(2005.1,0),U,3)=MAGLAST 155 S DA=MAGARCIE 156 S DIK="^MAG(2005.1," D IX1^DIK 157 Q 158 DELFILE ;Delete image file on server if exists 159 ;gek 3/21/2003 Changed to stop using FullRes Path for Abs,Big 160 ; and only Delete .TXT and Alternates if Full is being deleted. 161 N X0,X1,X2,ALTEXT,ALTPATH,MAGXX,XBIG 162 N MAGPLC ; DBI - SEB 9/20/2002 163 ; MAGIEN IS ASSUMED TO BE DEFINED. 164 ; MAGXX - This is IEN in ^MAG(2005, MAGFILEB Expects this to be defined. 165 ; MAGPLC - "Place" of Full Res Image. 166 ; ALTEXT - Extension of the Alternate image file. 167 ; ALTPATH - Full path of Alternate image file. 168 S X0=^MAG(2005,MAGIEN,0) 169 ;delete Full Res if one exists on Magnetic 170 I $P(X0,U,3) D 171 . S MAGXX=MAGIEN 172 . S MAGPLC=$$DA2PLC^MAGBAPIP(MAGIEN,"F") 173 . D VSTNOCP^MAGFILEB 174 . S X=$$DELETE^MAGBAPI(MAGFILE2,MAGPLC) 175 . ;Delete any other ALTernate files. ( TXT) 176 . ;gek 3/31/03 Since ALT files are (for now) always on same server as Full 177 . ; We only attempt to delete them here (If we have a path to FullRes on Magnetic) 178 . S X2=0 179 . F S X2=$O(^MAG(2006.1,MAGPLC,2,X2)) Q:'X2 D 180 . . S ALTEXT=^MAG(2006.1,MAGPLC,2,X2,0) 181 . . S ALTPATH=$P(MAGFILE2,".")_"."_ALTEXT 182 . . S X=$$DELETE^MAGBAPI(ALTPATH,MAGPLC) 183 . Q 184 ; 185 ;delete image abstract if one exists on Magnetic 186 I $P(X0,U,4) D 187 . S MAGXX=MAGIEN 188 . D ABSNOCP^MAGFILEB 189 . S X=$$DELETE^MAGBAPI(MAGFILE2,$$DA2PLC^MAGBAPIP(MAGIEN,"A")) ; DBI - SEB 9/20/2002 190 ; 191 ;delete the big file if one exists on Magnetic 192 S XBIG=$G(^MAG(2005,MAGIEN,"FBIG")) 193 I $P(XBIG,U) D 194 . S MAGXX=MAGIEN 195 . D BIGNOCP^MAGFILEB 196 . S X=$$DELETE^MAGBAPI(MAGFILE2,$$DA2PLC^MAGBAPIP(MAGIEN,"B")) ; DBI - SEB 9/20/2002 197 Q 1 MAGGTID ;WOIFO/SRR/RED/SAF/GEK - Deletion of Images and Pointers ; [ 06/20/2001 08:56 ] 2 ;;3.0;IMAGING;**8**;Sep 15, 2004 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 Q 19 ; 20 IMAGEDEL(MAGGRY,MAGIEN,MAGGRPDF,REASON) ;RPC [MAGG IMAGE DELETE] 21 ; Call to Delete Image entry 22 ; SEB 6/6/2002 - added MAGGRPDF - group delete flag = 1 if group delete allowed 23 ; from Image file ^MAG(2005 24 N Y,RY 25 ; 1 in 3rd piece means : DELETE the Image File Also. 26 S MAGGRPDF=+$G(MAGGRPDF),REASON=$G(REASON) 27 L +^MAG(2005,MAGIEN):4 28 E S MAGGRY(0)="Image ID# "_MAGIEN_" is Locked. Delete is Canceled" Q 29 D DELETE(.MAGGRY,MAGIEN,1,MAGGRPDF,REASON) 30 L -^MAG(2005,MAGIEN) 31 Q 32 DELETE(RY,MAGIEN,DF,GRPDF,REASON) ;RPC [MAGQ DIK] Entry point for silent call 33 ;RY=Return Array RY(0)="1^SUCCESS" 34 ; RY(0)="0^reason for failure" 35 ; ;NOT RETURNING LIST AT THIS TIME 36 ; ( RY(1)..RY(n)= IEN's of deleted images.) 37 ;MAGIEN=Image entry number to be deleted 38 ; if MAGIEN has a 2nd piece = 1 then we force delete, don't test 39 ; for MAG DELETE KEY 40 ;DF=Delete file flag - 1=delete the Image file 41 ; - 0=don't delete the image file 42 ; 43 S REASON=$G(REASON) I REASON="" S REASON="Unknown reason" 44 S RY(0)="0^Image Delete Failed, reason unknown." 45 S:'$D(MAGSYS) MAGSYS=^%ZOSF("VOL") 46 N MAGERR,SYSDEL,Z 47 S SYSDEL=+$P(MAGIEN,U,2) 48 ; Check the business rules for deleting an image 49 D DELETE^MAGSIMBR(.RY,MAGIEN,SYSDEL) I +RY(0)=0 Q 50 S MAGIEN=+MAGIEN 51 ; a couple tests of privilage and valid IEN 52 I '$D(^MAG(2005,MAGIEN,0)) D Q 53 . S RY(0)="0^Image entry doesn't exist in image file" 54 I +$O(^MAG(2005,MAGIEN,1,0)),+$G(GRPDF)=0 D Q 55 . S RY(0)="0^Deleting a Group is not allowed." 56 I +$O(^MAG(2005,MAGIEN,1,0)),+$G(GRPDF)'=0 D Q 57 . N MAGGRP S MAGGRP=MAGIEN N MAGIEN,MAGX,MAGOK,MAGFAIL 58 . S MAGX=0,MAGOK=0,MAGFAIL=0 59 . F S MAGX=$O(^MAG(2005,MAGGRP,1,MAGX)) Q:'MAGX D 60 . . S MAGIEN=$P($G(^MAG(2005,MAGGRP,1,MAGX,0)),"^") D DEL1IMG 61 . . I +RY(0) S Z=+$O(RY(""),-1),RY(Z)=RY(Z)_"^"_RY(0),MAGOK=MAGOK+1 62 . . E S Z=+$O(RY(""),-1)+1,RY(Z)=MAGIEN_"^"_RY(0),MAGFAIL=MAGFAIL+1 63 . . Q 64 . I +MAGFAIL=0 S RY(0)="1^Deletion of Group #"_MAGGRP_" was successful.^"_MAGOK_"^0" 65 . E S RY(0)="0^Error deleting child image(s). Group Not Deleted.^"_MAGOK_"^"_MAGFAIL 66 . Q 67 ; 68 ; Ok lets start 69 ; lets delete the parent pointers first. 70 DEL1IMG ; 71 N DELMSG,Z 72 D DELPAR^MAGSDEL2 73 I $G(MAGERR) S RY(0)="0^Error: Deleting Specialty Pointers. Image Not Deleted. "_DELMSG Q 74 ; 75 ; Now delete image record & xref's 76 ; if this Image is member of group DELGRP will delete those pointers 77 ; and delete the Group, if this is only image in it. 78 S MAGDFN=$P($G(^MAG(2005,MAGIEN,0)),"^",7) ; Moved here from below. DELGRP needs MAGDFN now. 79 D DELGRP 80 I $G(MAGERR) S RY(0)="0^Error deleting Group Pointers." Q 81 ; 82 ; write the deleted by, delete reason, and delete date to the file. 83 D SETDEL(MAGIEN,REASON) 84 ; 85 ; save the Image record to the archive before we delete it. 86 D ARCHIVE(MAGIEN) 87 ; 88 ; Now let's set the Queue to delete the Image File, if Flag is set 89 I $G(DF) D DELFILE 90 ; 91 ; we're having "APPXDT" crossref left around, lets delete it first. 92 S X=MAGDFN,DA=MAGIEN D KILPPXD^MAGUXRF 93 ; 94 ; now lets delete the image. 95 K DIK,DA,DA(1),DA(2),DIC,DR,DIE,DIR S DIK="^MAG(2005,",DA=MAGIEN 96 D ^DIK 97 S Z=+$O(RY(""),-1)+1,RY(Z)=MAGIEN 98 ; we were having problems with "AC" so lets check to make sure. 99 I $D(^MAG(2005,"AC",MAGDFN,MAGIEN)) K ^MAG(2005,"AC",MAGDFN,MAGIEN) 100 ; log it. 101 D ENTRY^MAGLOG("DELETE",$G(DUZ),$G(MAGIEN),"PARENT:"_$G(MAGSTORE),$G(MAGDFN),1) 102 S X="DEL^"_$G(MAGDFN)_"^"_$G(MAGIEN) 103 D ACTION^MAGGTAU(X,"1") 104 S RY(0)="1^Deletion of Image was Successful." 105 Q 106 DELGRP ;del grp ptrs and check to see if this is the last image in the group 107 N MAGGRP,MAGX,MAGQUIT,MAGIFNS,Z 108 S MAGGRP=$P($G(^MAG(2005,MAGIEN,0)),"^",10) 109 Q:'$G(MAGGRP) 110 K DIK,DA,DA(1),DA(2),DIC,DR,DIE,DIR 111 S MAGX=0,MAGQUIT=0 112 F S MAGX=$O(^MAG(2005,MAGGRP,1,MAGX)) Q:'MAGX D Q:MAGQUIT 113 . I +^MAG(2005,MAGGRP,1,MAGX,0)=MAGIEN D 114 . . S DIK="^MAG(2005,MAGGRP,1,",DA(1)=MAGGRP,DA=MAGX D ^DIK S MAGQUIT=1 115 . . ;added DA(1) needed for xref deletion of dicom series 116 . I $O(^MAG(2005,MAGGRP,1,0))="" D 117 . . I $P($G(^MAG(2005,MAGGRP,2)),"^",6) D 118 . . . ;report is on group - need to delete it 119 . . . S MAGIFNS=MAGIEN,MAGIEN=MAGGRP 120 . . . D DELPAR^MAGSDEL2 121 . . . S MAGIEN=MAGIFNS 122 . . I '$D(MAGERR) D 123 . . . D SETDEL(MAGGRP,REASON),ARCHIVE(MAGGRP) S DIK="^MAG(2005,",DA=MAGGRP D ^DIK 124 . . . ; Log the Deletion of The Group Header to ^MAG(2006.95, and ^MAG(2006.82 125 . . . D ENTRY^MAGLOG("DELETE",$G(DUZ),$G(MAGGRP),"PARENT:"_$G(MAGSTORE),$G(MAGDFN),1,"Group Header deleted") 126 . . . S X="DEL^"_$G(MAGDFN)_"^"_$G(MAGGRP) 127 . . . D ACTION^MAGGTAU(X,"1") 128 . . . S Z=+$O(RY(""),-1)+1,RY(Z)=MAGGRP_"^1^Deletion of Group was Successful." 129 . . . Q 130 . . Q 131 . Q 132 Q 133 SETDEL(MAGIEN,REASON) ; set deletion fields 134 N DA,DR,DIE,%H,X 135 S %H=$H D YMD^%DTC 136 ; gek - changed 3 slash to 4 slash. to stop FM question marks. ?? 137 S DR="30////"_DUZ_";30.1////"_X_";30.2////"_REASON 138 S DIE="2005",DA=MAGIEN D ^DIE 139 Q 140 ; 141 ARCHIVE(MAGARCIE) ;save image data before deletion 142 N MAGCNT,MAGLAST 143 S MAGCNT=$P(^MAG(2005.1,0),U,4)+1 144 S %X="^MAG(2005,"_MAGARCIE_",",%Y="^MAG(2005.1,"_MAGARCIE_"," 145 D %XY^%RCR 146 ; GEK 9/29/00 Fix the 3rd piece to be last ien in file. 147 S MAGLAST=$O(^MAG(2005.1,"A"),-1) 148 S $P(^MAG(2005.1,0),U,4)=MAGCNT 149 I '($P(^MAG(2005.1,0),U,3)=MAGLAST) S $P(^MAG(2005.1,0),U,3)=MAGLAST 150 S DA=MAGARCIE 151 S DIK="^MAG(2005.1," D IX1^DIK 152 Q 153 DELFILE ;Delete image file on server if exists 154 ;gek 3/21/2003 Changed to stop using FullRes Path for Abs,Big 155 ; and only Delete .TXT and Alternates if Full is being deleted. 156 N X0,X1,X2,ALTEXT,ALTPATH,MAGXX,XBIG 157 N MAGPLC ; DBI - SEB 9/20/2002 158 ; MAGIEN IS ASSUMED TO BE DEFINED. 159 ; MAGXX - This is IEN in ^MAG(2005, MAGFILEB Expects this to be defined. 160 ; MAGPLC - "Place" of Full Res Image. 161 ; ALTEXT - Extension of the Alternate image file. 162 ; ALTPATH - Full path of Alternate image file. 163 S X0=^MAG(2005,MAGIEN,0) 164 ;delete Full Res if one exists on Magnetic 165 I $P(X0,U,3) D 166 . S MAGXX=MAGIEN 167 . S MAGPLC=$$DA2PLC^MAGBAPIP(MAGIEN,"F") 168 . D VSTNOCP^MAGFILEB 169 . S X=$$DELETE^MAGBAPI(MAGFILE2,MAGPLC) 170 . ;Delete any other ALTernate files. ( TXT) 171 . ;gek 3/31/03 Since ALT files are (for now) always on same server as Full 172 . ; We only attempt to delete them here (If we have a path to FullRes on Magnetic) 173 . S X2=0 174 . F S X2=$O(^MAG(2006.1,MAGPLC,2,X2)) Q:'X2 D 175 . . S ALTEXT=^MAG(2006.1,MAGPLC,2,X2,0) 176 . . S ALTPATH=$P(MAGFILE2,".")_"."_ALTEXT 177 . . S X=$$DELETE^MAGBAPI(ALTPATH,MAGPLC) 178 . Q 179 ; 180 ;delete image abstract if one exists on Magnetic 181 I $P(X0,U,4) D 182 . S MAGXX=MAGIEN 183 . D ABSNOCP^MAGFILEB 184 . S X=$$DELETE^MAGBAPI(MAGFILE2,$$DA2PLC^MAGBAPIP(MAGIEN,"A")) ; DBI - SEB 9/20/2002 185 ; 186 ;delete the big file if one exists on Magnetic 187 S XBIG=$G(^MAG(2005,MAGIEN,"FBIG")) 188 I $P(XBIG,U) D 189 . S MAGXX=MAGIEN 190 . D BIGNOCP^MAGFILEB 191 . S X=$$DELETE^MAGBAPI(MAGFILE2,$$DA2PLC^MAGBAPIP(MAGIEN,"B")) ; DBI - SEB 9/20/2002 192 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGTII.m
r613 r623 1 MAGGTII ;WOIFO/GEK - RETURN IMAGE INFO ; [ 11/08/2001 17:18 ] 2 ;;3.0;IMAGING;**8,48,63,59**;Nov 27, 2007;Build 20 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 ;; | 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 ; CALL WITH MAGXX=IEN of IMAGE FILE (2005) 19 ; RETURNS MAGFILE='^' delimited string of Image information. 20 ; 21 ; 22 INFO ;Get info for an Image File entry 23 ; We assume that MAGXX exists and is the Image File entry 24 ; We return a '^' delimited string for the Image entry. 25 ; $P(1^2^3) IEN^Image FullPath and name^Abstract FullPath and Name 26 ; $P(4) SHORT DESCRIPTION field and desc of offline JukeBox 27 ; $P(5) PROCEDURE/ EXAM DATE/TIME field 28 ; $P(6) OBJECT TYPE 29 ; $P(7) PROCEDURE field 30 ; $P(8) display date 31 ; $P(9) to return the PARENT DATA FILE image pointer 32 ; $p(10) return the ABSTYPE 'M' magnetic 'W' worm 'O' offline 33 ; $p(11) is 'A' accessible 'O' offline 34 ; $p(12^13) Dicom Series Number $p(12) and Image Number $p(13) 35 ; $p(14) is count of images in group, 1 if single image. 36 ; VISN15 37 ; $p(15^16) SiteParameter IEN ^ SiteParameter CODE 38 ; $P(17) is err description of Integrity Check 39 ; $P(18) Image BIGPath and name //Patch 5 40 ; $P(19^20) Patient DFN ^ Patient Name; // Patch 3.8 41 ; $P(21) Image Class: Clin,Admin,Clin/Admin,Admin/Clin 42 ; $p(22) Date Time Image Saved(FLD 7) 43 ; $p(23) Document Date (FLD 110) 44 ; 45 N FILETYPE,MAGPREF,MAGJBCP,GRPTYPE,GRPIEN,ABSTYPE,MAGTYPE,MAGJBOL 46 N MAGOFFLN,FULLTYPE,MAGOBJT,MAGQI,X 47 N ABSFILE,FULLFILE,BIGFILE,PATCH,MDFN,FNL,PLC,PLCODE 48 N MAGN0,MAGN2,MAGN40,MAGN100 49 ; set the Variables for the Global Nodes of the Image Entry 50 S MAGN0=$G(^MAG(2005,MAGXX,0)) 51 S MDFN=$P(MAGN0,"^",7) 52 S MAGN2=$G(^MAG(2005,MAGXX,2)) 53 S MAGN40=$G(^MAG(2005,MAGXX,40)) 54 S MAGN100=$G(^MAG(2005,MAGXX,100)) 55 ; Set Name in Variable, Call $$GET 1 time not 2000 56 I MDFN I '$D(MAGJOB("PTNM",MDFN)) S MAGJOB("PTNM",MDFN)=$$GET1^DIQ(2,MDFN_",",.01) 57 I '$D(MAGJOB("NETPLC")) D NETPLCS^MAGGTU6 58 ; Object Type 59 S MAGOBJT=$P(MAGN0,"^",6) 60 ; if this is a group, change MAGXX to first image in group to get 61 ; that abstract to use for the group abstract 62 I MAGOBJT=11!(MAGOBJT=16) S GRPTYPE=MAGOBJT D 63 . S X=$O(^MAG(2005,MAGXX,1,0)) 64 . ; next line to account for group of NO images for whatever reason. 65 . ; we change Object Type to XRAY (3) or STILL IMAGE (1) 66 . I 'X S MAGOBJT=$S(MAGOBJT=11:3,MAGOBJT=16:1,1:1) K GRPTYPE Q 67 . S X=^MAG(2005,MAGXX,1,X,0) 68 . ; keep the Real IEN, so we can change back later 69 . S GRPIEN=MAGXX,MAGXX=+X 70 . Q 71 S MAGJBCP=0 ; Don't Queue a copy from JukeBox. 72 ; The call to FINDFILE returns: 73 ; MAGFILE1=LA100066.ABS filename 74 ; if no Network Location pointer or INVALID Pointer 75 ; then MAGFILE1=-1~NO NETWORK LOCATION POINTER 76 ; or -1~INVALID NETWORK LOCATION POINTER 77 ; MAGFILE1(.01)=ONE,PATIENT 111223333 image desc 78 ; MAGJBOL= desc of Offline server 79 ; MAGOFFLN= if JB is offline 80 ; MAGPREF=C:\TEMP\LA\10\00\ path 81 ; MAGTYPE=MAG MAG or WORM 82 ; 83 ; first get Full Path and File Name of the Abstract 84 S FILETYPE="ABSTRACT" K MAGFILE1("ERROR") 85 S MAGPREF="" D FINDFILE^MAGFILEB 86 S MAGFILE1=$TR(MAGFILE1,"^","~") ; MAGFILE1 has '^' in it if errors 87 I $D(MAGFILE1("ERROR")) S MAGFILE1=MAGFILE1("ERROR") 88 S ABSTYPE=$E(MAGTYPE,1) I MAGOFFLN S ABSTYPE="O" 89 ; Here we must test for +MAGFILE1 = -1 which means we don't have 90 ; any entry in the Image File for the Abstract Network Location 91 ; pointer. 92 S MAGPREF=$G(MAGPREF) 93 S ABSFILE=MAGPREF_MAGFILE1 94 ; 95 ; now lets get the Full Path and file name FULL RES image. 96 S FULLTYPE="A" ; Accessible 97 S FILETYPE="FULL" K MAGFILE1("ERROR") 98 S MAGPREF="" D FINDFILE^MAGFILEB 99 S MAGFILE1=$TR(MAGFILE1,"^","~") ; MAGFILE1 has '^' in it if errors 100 I $D(MAGFILE1("ERROR")) S MAGFILE1=MAGFILE1("ERROR") 101 I MAGOFFLN S FULLTYPE="O" ; Offline 102 ; here we have to do the same test as above. for bad data. 103 S MAGPREF=$G(MAGPREF) 104 S FULLFILE=MAGPREF_MAGFILE1 105 ; 106 ; now lets get the Full Path and file name for BIG image. 107 S FILETYPE="BIG" K MAGFILE1("ERROR") 108 S MAGPREF="" D FINDFILE^MAGFILEB 109 S MAGFILE1=$TR(MAGFILE1,"^","~") ; MAGFILE1 has '^' in it if errors 110 I $D(MAGFILE1("ERROR")) S MAGFILE1=MAGFILE1("ERROR") 111 S MAGPREF=$G(MAGPREF) 112 S BIGFILE=$S($E(MAGFILE1,1,2)="-1":"",1:MAGPREF_MAGFILE1) 113 ; 114 K MAGFILE1 ; Cleanup 115 ; Site and Site Code are in Entry of first Image in Group 116 ; so we need to set here, before MAGXX is changed back. 117 S X=$G(^MAG(2005,MAGXX,0)) 118 S FNL=$S(+$P(X,"^",3):$P(X,"^",3),1:+$P(X,"^",5)) 119 S PLC=$P($G(MAGJOB("NETPLC",FNL)),"^",1) 120 S PLCODE=$P($G(MAGJOB("NETPLC",FNL)),"^",2) 121 I PLC="" S PLC=$G(MAGJOB("PLC")),PLCODE=$G(MAGJOB("PLCODE")) ; Group of 0 need this. 122 ; if we were using first image of a group, reset the Real IEN 123 I $G(GRPIEN) S MAGXX=GRPIEN 124 ; 125 ; we have to change the OBJECT TYPE variable back to real value 126 ; MAGOBJT might have been changed if we had Group of no images. 127 ; but we need to keep it changed, because Delphi window checks this 128 ; entry to determine which window to open. 129 ; i.e. Group window, Single image window, 130 S MAGOBJT=$P(MAGN0,U,6) 131 ; 132 ; now start building the return string 133 ; 134 S PATCH=$P($G(MAGJOB("VERSION")),".",3) ; //'="3.0.8") 135 K MAGFILE 136 S $P(MAGFILE,U,25)="" ; We put extra '^^^' on end of String to stop error in Delphi. 137 ; Pieces 26 BrokerServer and 27 Broker Port are set if this is P59 Client. 138 ; Clients Prior to Patch 59, the String must only be 25 pieces. - Patch 45 snafu 139 ; 140 ; $P(1^2^3) IEN^Image FullPath and name^Abstract FullPath and Name 141 S $P(MAGFILE,U,1,3)=MAGXX_U_FULLFILE_U_ABSFILE 142 ; 143 ; now set $P(4) SHORT DESCRIPTION field and desc of offline JukeBox 144 S $P(MAGFILE,U,4)=$P(MAGN2,U,4)_$G(MAGJBOL) 145 ; 146 ; now set $P(5)PROCEDURE/ EXAM DATE/TIME field 147 S $P(MAGFILE,U,5)=$P(MAGN2,U,5) 148 ; 149 ; now set $P(6) OBJECT TYPE 150 S $P(MAGFILE,U,6)=MAGOBJT 151 ; 152 ; now set $P(7) PROCEDURE field 153 S $P(MAGFILE,U,7)=$P(MAGN0,U,8) 154 ; 155 ; now we're making a DATE to display and will use it for a sort in 156 ; the delphi TStringGrid so we display mm/dd/yyyy 157 ; now set $P(8) display date 158 S X=$$FMTE^XLFDT($P(MAGN2,U,5),"5Z") 159 S X=$TR(X,"@"," ") 160 S $P(MAGFILE,U,8)=X 161 ; 162 ; now return the PARENT DATA FILE image pointer 163 S $P(MAGFILE,U,9)=$P(MAGN2,U,8) 164 ; 165 ; now return the ABSTYPE ( this is 'M' or 'W' or 'O' ) 166 ; 'M' magnetic 'W' worm 'O' offline 167 S $P(MAGFILE,U,10)=ABSTYPE 168 ; 169 ; now return the code to show if full res image is offline 'A' or 'O' 170 ; 'A' accessible 'O' offline 171 S $P(MAGFILE,U,11)=FULLTYPE 172 ; 173 ; 2/1/99 Dicom Series number and Dicom Image Number 174 ; $p(12) and $p(13) 175 ; 176 ; 14 - count of images , if this is a group 177 S X=+$P($G(^MAG(2005,MAGXX,1,0)),U,4),$P(MAGFILE,U,14)=$S(X:X,1:1) 178 ; 179 ; $p(15^16 ) are SiteIEN and SiteCode Consolidation - DBI 180 ; We use SiteIEN and SiteCODE from above 181 S $P(MAGFILE,"^",15)=PLC 182 S $P(MAGFILE,"^",16)=PLCODE 183 ; 184 ; $p(17) 8/22/01 GEK Mod for integrity check. 185 I '$G(MAGNOCHK) D CHK^MAGGSQI(.MAGQI,MAGXX) I 'MAGQI(0) D 186 . ; remove the Abstract and Image File Names ; 2/14/03 remove c:\program files... with .\bmp\ 187 . S $P(MAGFILE,U,2,3)="-1~Questionable Data Integrity^.\bmp\imageQA.bmp" 188 . ;this stops Delphi App from changing Abstract BMP to OFFLINE IMAGE 189 . S $P(MAGFILE,U,6)=$S(($P(MAGFILE,U,6)'=11):"99",1:11) 190 . S $P(MAGFILE,U,10)="M" 191 . ;Send the error message 192 . S $P(MAGFILE,U,17)=$P(MAGQI(0),U,2) 193 ; $p(18) is BIGFile Full name and path. 194 S $P(MAGFILE,U,18)=BIGFILE 195 ; DFN 196 S $P(MAGFILE,U,19)=$P(MAGN0,U,7) 197 ; Patient Name 198 S $P(MAGFILE,U,20)=$S(MDFN:MAGJOB("PTNM",MDFN),1:MDFN) 199 S $P(MAGFILE,U,21)=$S(+$P(MAGN40,U,2):$P(^MAG(2005.82,$P(MAGN40,U,2),0),U),1:"") 200 S X=$$FMTE^XLFDT($P(MAGN2,U,1),"5Z") ; Date/Time Image Saved #7 201 S X=$TR(X,"@"," ") 202 S $P(MAGFILE,U,22)=X 203 S X=$$FMTE^XLFDT($P(MAGN100,U,6),"5Z") ; DocumentDate #110 204 S X=$TR(X,"@"," ") 205 S $P(MAGFILE,U,23)=X 206 ; If Patch 59 Client - we can set beyond 25 pieces. 207 I $D(MAGJOB("RPCSERVER"))&$D(MAGJOB("RPCPORT")) D 208 . S $P(MAGFILE,U,26)=MAGJOB("RPCSERVER") 209 . S $P(MAGFILE,U,27)=MAGJOB("RPCPORT") 210 . S $P(MAGFILE,U,28)="" ; "^" at end, stops problems in delphi 211 . Q 212 ; Stop displaying a Group of 1 as a Group, so here we'll change Object type 213 ; to that of the '1ST' image in the group of 1. 214 I $P($G(^MAG(2005,MAGXX,1,0)),U,4)=1 D 215 . S X=$O(^MAG(2005,MAGXX,1,0)) 216 . S X=+^MAG(2005,MAGXX,1,X,0) 217 . S $P(MAGFILE,U,6)=$P(^MAG(2005,X,0),U,6) ; OBJECT TYPE OF 1ST IMAGE IN GROUP 218 . S $P(MAGFILE,U,1)=X 219 . Q 220 Q 1 MAGGTII ;WOIFO/GEK - RETURN IMAGE INFO ; [ 11/08/2001 17:18 ] 2 ;;3.0;IMAGING;**8,48,63**;Apr 11, 2005 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 ; CALL WITH MAGXX=IEN of IMAGE FILE (2005) 19 ; RETURNS MAGFILE='^' delimited string of Image information. 20 ; 21 ; 22 INFO ;Get info for an Image File entry 23 ; We assume that MAGXX exists and is the Image File entry 24 ; We return a '^' delimited string for the Image entry. 25 ; $P(1^2^3) IEN^Image FullPath and name^Abstract FullPath and Name 26 ; $P(4) SHORT DESCRIPTION field and desc of offline JukeBox 27 ; $P(5) PROCEDURE/ EXAM DATE/TIME field 28 ; $P(6) OBJECT TYPE 29 ; $P(7) PROCEDURE field 30 ; $P(8) display date 31 ; $P(9) to return the PARENT DATA FILE image pointer 32 ; $p(10) return the ABSTYPE 'M' magnetic 'W' worm 'O' offline 33 ; $p(11) is 'A' accessible 'O' offline 34 ; $p(12^13) Dicom Series Number $p(12) and Image Number $p(13) 35 ; $p(14) is count of images in group, 1 if single image. 36 ; VISN15 37 ; $p(15^16) SiteParameter IEN ^ SiteParameter CODE 38 ; $P(17) is err description of Integrity Check 39 ; $P(18) Image BIGPath and name //Patch 5 40 ; $P(19^20) Patient DFN ^ Patient Name; // Patch 3.8 41 ; $P(21) Image Class: Clin,Admin,Clin/Admin,Admin/Clin 42 ; 43 N FILETYPE,MAGPREF,MAGJBCP,GRPTYPE,GRPIEN,ABSTYPE,MAGTYPE,MAGJBOL 44 N MAGOFFLN,FULLTYPE,MAGOBJT,MAGQI,X 45 N ABSFILE,FULLFILE,BIGFILE,PATCH,MDFN,FNL,PLC,PLCODE 46 N MAGN0,MAGN2,MAGN40 47 ; set the Variables for the Global Nodes of the Image Entry 48 S MAGN0=$G(^MAG(2005,MAGXX,0)),MDFN=$P(MAGN0,"^",7) ; P48T1 MDFN 49 S MAGN2=$G(^MAG(2005,MAGXX,2)) 50 S MAGN40=$G(^MAG(2005,MAGXX,40)) 51 ; P48T1 Set Name in Variable, Call $$GET 1 time not 2000 52 I '$D(MAGJOB("PTNM",MDFN)) S MAGJOB("PTNM",MDFN)=$$GET1^DIQ(2,MDFN_",",.01) 53 I '$D(MAGJOB("NETPLC")) D NETPLCS^MAGGTU6 54 ; Object Type 55 S MAGOBJT=$P(MAGN0,"^",6) 56 ; if this is a group, change MAGXX to first image in group to get 57 ; that abstract to use for the group abstract 58 I MAGOBJT=11!(MAGOBJT=16) S GRPTYPE=MAGOBJT D 59 . S X=$O(^MAG(2005,MAGXX,1,0)) 60 . ; next line to account for group of NO images for whatever reason. 61 . ; we change Object Type to XRAY (3) or STILL IMAGE (1) 62 . I 'X S MAGOBJT=$S(MAGOBJT=11:3,MAGOBJT=16:1,1:1) K GRPTYPE Q 63 . S X=^MAG(2005,MAGXX,1,X,0) 64 . ; keep the Real IEN, so we can change back later 65 . S GRPIEN=MAGXX,MAGXX=+X 66 . Q 67 S MAGJBCP=0 ; Don't Queue a copy from JukeBox. 68 ; The call to FINDFILE returns: 69 ; MAGFILE1=LA100066.ABS filename 70 ; if no Network Location pointer or INVALID Pointer 71 ; then MAGFILE1=-1~NO NETWORK LOCATION POINTER 72 ; or -1~INVALID NETWORK LOCATION POINTER 73 ; MAGFILE1(.01)=ONE,PATIENT 111223333 image desc 74 ; MAGJBOL= desc of Offline server 75 ; MAGOFFLN= if JB is offline 76 ; MAGPREF=C:\TEMP\LA\10\00\ path 77 ; MAGTYPE=MAG MAG or WORM 78 ; 79 ; first get Full Path and File Name of the Abstract 80 S FILETYPE="ABSTRACT" K MAGFILE1("ERROR") 81 S MAGPREF="" D FINDFILE^MAGFILEB 82 S MAGFILE1=$TR(MAGFILE1,"^","~") ; MAGFILE1 has '^' in it if errors 83 I $D(MAGFILE1("ERROR")) S MAGFILE1=MAGFILE1("ERROR") 84 S ABSTYPE=$E(MAGTYPE,1) I MAGOFFLN S ABSTYPE="O" 85 ; Here we must test for +MAGFILE1 = -1 which means we don't have 86 ; any entry in the Image File for the Abstract Network Location 87 ; pointer. 88 S MAGPREF=$G(MAGPREF) 89 S ABSFILE=MAGPREF_MAGFILE1 90 ; 91 ; now lets get the Full Path and file name FULL RES image. 92 S FULLTYPE="A" ; Accessible 93 S FILETYPE="FULL" K MAGFILE1("ERROR") 94 S MAGPREF="" D FINDFILE^MAGFILEB 95 S MAGFILE1=$TR(MAGFILE1,"^","~") ; MAGFILE1 has '^' in it if errors 96 I $D(MAGFILE1("ERROR")) S MAGFILE1=MAGFILE1("ERROR") 97 I MAGOFFLN S FULLTYPE="O" ; Offline 98 ; here we have to do the same test as above. for bad data. 99 S MAGPREF=$G(MAGPREF) 100 S FULLFILE=MAGPREF_MAGFILE1 101 ; 102 ; now lets get the Full Path and file name for BIG image. 103 S FILETYPE="BIG" K MAGFILE1("ERROR") 104 S MAGPREF="" D FINDFILE^MAGFILEB 105 S MAGFILE1=$TR(MAGFILE1,"^","~") ; MAGFILE1 has '^' in it if errors 106 I $D(MAGFILE1("ERROR")) S MAGFILE1=MAGFILE1("ERROR") 107 S MAGPREF=$G(MAGPREF) 108 S BIGFILE=$S($E(MAGFILE1,1,2)="-1":"",1:MAGPREF_MAGFILE1) 109 ; 110 K MAGFILE1 ; Cleanup 111 ; Site and Site Code are in Entry of first Image in Group 112 ; so we need to set here, before MAGXX is changed back. 113 S X=$G(^MAG(2005,MAGXX,0)) 114 S FNL=$S(+$P(X,"^",3):$P(X,"^",3),1:+$P(X,"^",5)) 115 S PLC=$P($G(MAGJOB("NETPLC",FNL)),"^",1) 116 S PLCODE=$P($G(MAGJOB("NETPLC",FNL)),"^",2) 117 ; if we were using first image of a group, reset the Real IEN 118 I $G(GRPIEN) S MAGXX=GRPIEN 119 ; 120 ; we have to change the OBJECT TYPE variable back to real value 121 ; MAGOBJT might have been changed if we had Group of no images. 122 ; but we need to keep it changed, because Delphi window checks this 123 ; entry to determine which window to open. 124 ; i.e. Group window, Single image window, 125 S MAGOBJT=$P(MAGN0,U,6) 126 ; 127 ; now start building the return string 128 ; 129 S PATCH=$P($G(MAGJOB("VERSION")),".",3) ; //'="3.0.8") 130 K MAGFILE 131 S $P(MAGFILE,U,25)="" ; We put extra '^^^' on end of String to stop error in Delphi. 132 ; 133 ; $P(1^2^3) IEN^Image FullPath and name^Abstract FullPath and Name 134 S $P(MAGFILE,U,1,3)=MAGXX_U_FULLFILE_U_ABSFILE 135 S $P(MAGFILE,U,18)=BIGFILE 136 ; 137 ; now set $P(4) SHORT DESCRIPTION field and desc of offline JukeBox 138 S $P(MAGFILE,U,4)=$P(MAGN2,U,4)_$G(MAGJBOL) 139 ; 140 ; now set $P(5)PROCEDURE/ EXAM DATE/TIME field 141 S $P(MAGFILE,U,5)=$P(MAGN2,U,5) 142 ; 143 ; now set $P(6) OBJECT TYPE 144 S $P(MAGFILE,U,6)=MAGOBJT 145 ; 146 ; now set $P(7) PROCEDURE field 147 S $P(MAGFILE,U,7)=$P(MAGN0,U,8) 148 ; 149 ; now we're making a DATE to display and will use it for a sort in 150 ; the delphi TStringGrid so we display mm/dd/yyyy 151 ; now set $P(8) display date 152 S X=$P($P(MAGN2,"^",5),".",1) 153 I X'="" S X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_($E(X,1,3)+1700) 154 S $P(MAGFILE,U,8)=X 155 ; 156 ; now return the PARENT DATA FILE image pointer 157 S $P(MAGFILE,U,9)=$P(MAGN2,U,8) 158 ; 159 ; now return the ABSTYPE ( this is 'M' or 'W' or 'O' ) 160 ; 'M' magnetic 'W' worm 'O' offline 161 S $P(MAGFILE,U,10)=ABSTYPE 162 ; 163 ; now return the code to show if full res image is offline 'A' or 'O' 164 ; 'A' accessible 'O' offline 165 S $P(MAGFILE,U,11)=FULLTYPE 166 ; 167 ; 2/1/99 Dicom Series number and Dicom Image Number 168 ; $p(12) and $p(13) 169 ; 170 ; lets add the count of images , if this is a group 171 S X=+$P($G(^MAG(2005,MAGXX,1,0)),U,4),$P(MAGFILE,U,14)=$S(X:X,1:1) 172 ; 173 ; $p(15^16 ) are SiteIEN and SiteCode Consolidation - DBI 174 ; We use SiteIEN and SiteCODE from above 175 S $P(MAGFILE,"^",15)=PLC 176 S $P(MAGFILE,"^",16)=PLCODE 177 ; 178 ; $p(17) 8/22/01 GEK Mod for integrity check. 179 I '$G(MAGNOCHK) D CHK^MAGGSQI(.MAGQI,MAGXX) I 'MAGQI(0) D 180 . ; remove the Abstract and Image File Names ; 2/14/03 remove c:\program files... with .\bmp\ 181 . S $P(MAGFILE,U,2,3)="-1~Questionable Data Integrity^.\bmp\imageQA.bmp" 182 . ;this stops Delphi App from changing Abstract BMP to OFFLINE IMAGE 183 . S $P(MAGFILE,U,6)=$S(($P(MAGFILE,U,6)'=11):"99",1:11) 184 . S $P(MAGFILE,U,10)="M" 185 . ;Send the error message 186 . S $P(MAGFILE,U,17)=$P(MAGQI(0),U,2) 187 ; $p(18) is BIGFile Full name and path. ( set above) 188 ; Patches prior to 8, only had 17 pieces of data. this will speed up their listings. 189 ; Patch 8 had New M rtn MAGSIXG1, if it doesn't exist, this is PRE - 8. 190 I '$L($T(PGI^MAGSIXG1)) Q 191 S $P(MAGFILE,U,19)=$P(MAGN0,U,7) ; DFN 192 ; P48T1 The change to speed up access to large groups left out patient name. 193 ;S $P(MAGFILE,U,20)=$$GET1^DIQ(2,$P(MAGN0,U,7)_",",.01) ; Patient Name 194 S $P(MAGFILE,U,20)=MAGJOB("PTNM",MDFN) 195 S $P(MAGFILE,U,21)=$S(+$P(MAGN40,U,2):$P(^MAG(2005.82,$P(MAGN40,U,2),0),U),1:"") 196 ; Stop displaying a Group of 1 as a Group, so here we'll change Object type 197 ; to that of the '1ST' image in the group of 1. 198 I $P($G(^MAG(2005,MAGXX,1,0)),U,4)=1 D 199 . S X=$O(^MAG(2005,MAGXX,1,0)) 200 . S X=+^MAG(2005,MAGXX,1,X,0) 201 . S $P(MAGFILE,U,6)=$P(^MAG(2005,X,0),U,6) ; OBJECT TYPE OF 1ST IMAGE IN GROUP 202 . S $P(MAGFILE,U,1)=X 203 . ; Need Site and Site code of 204 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGTLB1.m
r613 r623 1 MAGGTLB1 ;WOIFO/LB - RPC routine for Imaging Lab Interface ; [ 06/20/2001 08:56 ] 2 ;;3.0;IMAGING;**59**;Nov 27, 2007;Build 20 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 ;; | 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 Q 19 ;This routine is called from the Laboratory Image capture window. 20 ;After an image is captured and an entry is created in file 2005, 21 ;this routine will be called to set the imaging pointers in the 22 ;corresponding Lab subfile (Autopsy/ Organism, Surgical Path, EM, 23 ;or Cytology) and update the imaging file with the corresponding 24 ;Lab pointers. 25 FILE(MAGRY,IMIEN,DATA) ;RPC Call to file pointers in Lab and Image files. 26 ;IMIEN - ^MAG(2005,IMIEN image captured. 27 ;DATA - piece 1 = stain piece 2 = micro obj 28 ; 3 = Pt name 4 = ssn 29 ; 5 = date/time 6 = acc# 30 ; 7 = Pathologist 8 = specimen desc. 31 ; 9 = lab section 10 = dfn 32 ; 11 = lrdfn 12 = lri 33 ; 13 = spec ien 14 = field# 34 ; 15 = global root e.g. ^LR(1,"SP",7069758,1,1 35 ;DATA is the result of START^MAGGTLB (the specimen variable during the 36 ;image capture window). 37 ;Will return a single value on filing success. 38 ; 39 IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" 40 E S X="ERR^MAGGTERR",@^%ZOSF("TRAP") 41 ; 42 N ANUM,DA,DA1,DAS,DFN,DIERR,FIELD,I,IMOBJ,LABD,LABFDA,LABIEN,LABIENS 43 N LRDFN,LRI,MAGFDA,MAGIEN,MAGNODE,OUT,SECT,SECTLTR,SPEC,SPECD 44 N SSUBFILE,SSUBFL,STAIN,SUBFILE,X,Y 45 S MAGRY="0^Started filing",MAGIEN=IMIEN 46 S SECT=$P(DATA,"^",9),DFN=$P(DATA,"^",10),LRDFN=$P(DATA,"^",11) 47 S LRI=$P(DATA,"^",12) 48 S SPEC=$P(DATA,"^",13),FIELD=$P(DATA,"^",14) 49 S MAGNODE="^"_$P(DATA,"^",15,99),ANUM=$P(DATA,"^",6) 50 S SPECD=$P(DATA,"^",8),STAIN=$P(DATA,"^",1),IMOBJ=$P(DATA,"^",2) 51 I SECT["~" S SECT=$P(SECT,"~",1) 52 ;Check for valid image 53 I '$D(^MAG(2005,MAGIEN,0)) D Q 54 . S Y(0)="0^Image entry does not exist." 55 ;Check for valid image patient entry. 56 I $P(^MAG(2005,MAGIEN,0),"^",7)'=DFN D Q 57 . S MAGRY="0^Image patient does not match Lab patient." 58 ;Check if parent file and corresponding fields are filed in file 2005. 59 I $D(^MAG(2005,MAGIEN,2)) S X=^MAG(2005,MAGIEN,2) D Q:OUT 60 . S OUT=0 61 . I $P(X,"^",6),$P(X,"^",7),$P(X,"^",8) S OUT=1 62 . I OUT S MAGRY="0^Report already exist for this image." 63 ;Check the Lab entries...do they still exists. 64 S MAGNODE=MAGNODE_",0)" 65 I '$D(@MAGNODE) S MAGRY="0^Specimen no longer in Lab file." Q 66 ;Everything seem okay lets file image pointer in lab file. 67 S SECTLTR=$S(SECT=63:"AY",SECT=63.2:"AY",1:$P(^MAG(2005.03,SECT,0),"^",2)) 68 ;Lab nodes; AY, SP, EM or CY. 69 ; 70 LAB2 ;updating files using silent Fileman DB calls. 71 N MAGERR,MAGLVL 72 S SUBFILE=$S(SECT=63:63.2,1:SECT) 73 S MAGRY="0^Lab's Imaging subfile doesn't exisit." ;default 74 ;Laboratory's Autopsy subfile has two imaging fields (2005 & 2005.1) 75 ; and file 2005.03 does not reflect this. 76 D FIELD^DID(SUBFILE,FIELD,"","SPECIFIER","MAGLVL","MAGERR") 77 I $D(MAGERR("DIERR")) Q 78 I '$D(MAGLVL("SPECIFIER")) Q 79 S SSUBFL=$G(MAGLVL("SPECIFIER")) ;Lab's Imaging subfile 80 I SSUBFL="" Q 81 ;Image sub-subfile. 82 S SSUBFILE="" F I=1:1:$L(SSUBFL) D 83 . I $E(SSUBFL,I)?1N!($E(SSUBFL,I)?1".") S SSUBFILE=SSUBFILE_$E(SSUBFL,I) 84 . ;Leave off the alpha characters 85 S DA1=$S(SECTLTR="AY":SPEC,1:LRI) ;Autopsy is by specimen not date/time 86 S DAS="+3,"_DA1_","_LRDFN_"," 87 ;Sets the iens e.g. da,da(1),da(2). The +3 can be any #; it is the 88 ;subscript of the return variable LABIENS. 89 ;Returns IEN for that subfile & use of +3 is because it's 2 levels down. 90 S LABFDA(SSUBFILE,DAS,.01)=MAGIEN,LABIENS="" 91 D UPDATE^DIE("S","LABFDA","LABIENS") 92 I $D(DIERR) S MAGRY="O^Unsuccessful Lab updating." Q 93 I '$D(LABIENS(3)) S MAGRY="0^Unsuccessful Lab updating" Q 94 S DA=$G(LABIENS(3)) 95 I 'DA!('$D(^LR(LRDFN,SECTLTR,DA1,FIELD,DA,0))) D Q 96 . S MAGRY="0^Unsuccessful Lab updating" 97 IMAGE2 ; 98 S MAGIEN=MAGIEN_",",LABIEN=DA,LABD=DA1 K DA,DA1 99 ; The following fields are saved in the ADDIMAGE Call. 100 ; 50 =ANUM ;ACCESSION NUMBER FIELD 101 ; 51 =SPECD ;SPECIMEN DESCRIPTION FIELD 102 ; 52 =SPEC ;SPECIMEN DO 103 ; 53 =STAIN ;Histology stain 104 ; 54 =IMOBJ ;MICROSCOPE OBJECTIVE 105 N DIK 106 S MAGFDA(2005,MAGIEN,16)=SECT ;LAB SECTION 107 S MAGFDA(2005,MAGIEN,17)=LRDFN ;PARENT FILE DO VALUE 108 S MAGFDA(2005,MAGIEN,18)=LABIEN ;LAB BACKWARD IMAGE POINTER 109 S MAGFDA(2005,MAGIEN,63)=LABD ;If AUTOPSY, it's specimen else date/time 110 S I=0 F I=$O(MAGFDA(2005,MAGIEN,I)) Q:'I D 111 . D UPDATE^DIE("S","MAGFDA","") 112 I $D(DIERR) S I=0 F S I=$O(MAGFDA(2005,MAGIEN,I)) Q:'I D 113 . S MAGFDA(2005,MAGIEN,I)="" D UPDATE^DIE("","MAGFDA","") 114 I $D(DIERR),$D(^LR(LRDFN,SECTLTR,DA1,FIELD,LABIEN,0)),$G(^LR(LRDFN,SECTLTR,DA1,FIELD,LABIEN,0))=MAGIEN D 115 . S DA(2)=LRDFN,DA(1)=DA1,DA=LABIEN 116 . S DIK="^LR("_LRDFN_","""_SECTLTR_""","_DA1_","_FIELD_"," 117 . D ^DIK ;Remove imaging pointers from lab subfile. 118 I $D(DIERR) S MAGRY="0^Unsuccessful both files not updated." K DIERR Q 119 S MAGRY="1^Success in filing both parent & image files." K DIERR 120 D LINKDT^MAGGTU6(.X,+MAGIEN) 121 Q 1 MAGGTLB1 ;WOIFO/LB - RPC routine for Imaging Lab Interface ; [ 06/20/2001 08:56 ] 2 ;;3.0;IMAGING;;Mar 01, 2002 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 Q 19 ;This routine is called from the Laboratory Image capture window. 20 ;After an image is captured and an entry is created in file 2005, 21 ;this routine will be called to set the imaging pointers in the 22 ;corresponding Lab subfile (Autopsy/ Organism, Surgical Path, EM, 23 ;or Cytology) and update the imaging file with the corresponding 24 ;Lab pointers. 25 FILE(MAGRY,IMIEN,DATA) ;RPC Call to file pointers in Lab and Image files. 26 ;IMIEN - ^MAG(2005,IMIEN image captured. 27 ;DATA - piece 1 = stain piece 2 = micro obj 28 ; 3 = Pt name 4 = ssn 29 ; 5 = date/time 6 = acc# 30 ; 7 = Pathologist 8 = specimen desc. 31 ; 9 = lab section 10 = dfn 32 ; 11 = lrdfn 12 = lri 33 ; 13 = spec ien 14 = field# 34 ; 15 = global root e.g. ^LR(1,"SP",7069758,1,1 35 ;DATA is the result of START^MAGGTLB (the specimen variable during the 36 ;image capture window). 37 ;Will return a single value on filing success. 38 ; 39 IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" 40 E S X="ERR^MAGGTERR",@^%ZOSF("TRAP") 41 ; 42 N ANUM,DA,DA1,DAS,DFN,DIERR,FIELD,I,IMOBJ,LABD,LABFDA,LABIEN,LABIENS 43 N LRDFN,LRI,MAGFDA,MAGIEN,MAGNODE,OUT,SECT,SECTLTR,SPEC,SPECD 44 N SSUBFILE,SSUBFL,STAIN,SUBFILE,X,Y 45 S MAGRY="0^Started filing",MAGIEN=IMIEN 46 S SECT=$P(DATA,"^",9),DFN=$P(DATA,"^",10),LRDFN=$P(DATA,"^",11) 47 S LRI=$P(DATA,"^",12) 48 S SPEC=$P(DATA,"^",13),FIELD=$P(DATA,"^",14) 49 S MAGNODE="^"_$P(DATA,"^",15,99),ANUM=$P(DATA,"^",6) 50 S SPECD=$P(DATA,"^",8),STAIN=$P(DATA,"^",1),IMOBJ=$P(DATA,"^",2) 51 I SECT["~" S SECT=$P(SECT,"~",1) 52 ;Check for valid image 53 I '$D(^MAG(2005,MAGIEN,0)) D Q 54 . S Y(0)="0^Image entry does not exist." 55 ;Check for valid image patient entry. 56 I $P(^MAG(2005,MAGIEN,0),"^",7)'=DFN D Q 57 . S MAGRY="0^Image patient does not match Lab patient." 58 ;Check if parent file and corresponding fields are filed in file 2005. 59 I $D(^MAG(2005,MAGIEN,2)) S X=^MAG(2005,MAGIEN,2) D Q:OUT 60 . S OUT=0 61 . I $P(X,"^",6),$P(X,"^",7),$P(X,"^",8) S OUT=1 62 . I OUT S MAGRY="0^Report already exist for this image." 63 ;Check the Lab entries...do they still exists. 64 S MAGNODE=MAGNODE_",0)" 65 I '$D(@MAGNODE) S MAGRY="0^Specimen no longer in Lab file." Q 66 ;Everything seem okay lets file image pointer in lab file. 67 S SECTLTR=$S(SECT=63:"AY",SECT=63.2:"AY",1:$P(^MAG(2005.03,SECT,0),"^",2)) 68 ;Lab nodes; AY, SP, EM or CY. 69 ; 70 LAB2 ;updating files using silent Fileman DB calls. 71 N MAGERR,MAGLVL 72 S SUBFILE=$S(SECT=63:63.2,1:SECT) 73 S MAGRY="0^Lab's Imaging subfile doesn't exisit." ;default 74 ;Laboratory's Autopsy subfile has two imaging fields (2005 & 2005.1) 75 ; and file 2005.03 does not reflect this. 76 D FIELD^DID(SUBFILE,FIELD,"","SPECIFIER","MAGLVL","MAGERR") 77 I $D(MAGERR("DIERR")) Q 78 I '$D(MAGLVL("SPECIFIER")) Q 79 S SSUBFL=$G(MAGLVL("SPECIFIER")) ;Lab's Imaging subfile 80 I SSUBFL="" Q 81 ;Image sub-subfile. 82 S SSUBFILE="" F I=1:1:$L(SSUBFL) D 83 . I $E(SSUBFL,I)?1N!($E(SSUBFL,I)?1".") S SSUBFILE=SSUBFILE_$E(SSUBFL,I) 84 . ;Leave off the alpha characters 85 S DA1=$S(SECTLTR="AY":SPEC,1:LRI) ;Autopsy is by specimen not date/time 86 S DAS="+3,"_DA1_","_LRDFN_"," 87 ;Sets the iens e.g. da,da(1),da(2). The +3 can be any #; it is the 88 ;subscript of the return variable LABIENS. 89 ;Returns IEN for that subfile & use of +3 is because it's 2 levels down. 90 S LABFDA(SSUBFILE,DAS,.01)=MAGIEN,LABIENS="" 91 D UPDATE^DIE("S","LABFDA","LABIENS") 92 I $D(DIERR) S MAGRY="O^Unsuccessful Lab updating." Q 93 I '$D(LABIENS(3)) S MAGRY="0^Unsuccessful Lab updating" Q 94 S DA=$G(LABIENS(3)) 95 I 'DA!('$D(^LR(LRDFN,SECTLTR,DA1,FIELD,DA,0))) D Q 96 . S MAGRY="0^Unsuccessful Lab updating" 97 IMAGE2 ; 98 S MAGIEN=MAGIEN_",",LABIEN=DA,LABD=DA1 K DA,DA1 99 ; The following fields are saved in the ADDIMAGE Call. 100 ; 50 =ANUM ;ACCESSION NUMBER FIELD 101 ; 51 =SPECD ;SPECIMEN DESCRIPTION FIELD 102 ; 52 =SPEC ;SPECIMEN DO 103 ; 53 =STAIN ;Histology stain 104 ; 54 =IMOBJ ;MICROSCOPE OBJECTIVE 105 N DIK 106 S MAGFDA(2005,MAGIEN,16)=SECT ;LAB SECTION 107 S MAGFDA(2005,MAGIEN,17)=LRDFN ;PARENT FILE DO VALUE 108 S MAGFDA(2005,MAGIEN,18)=LABIEN ;LAB BACKWARD IMAGE POINTER 109 S MAGFDA(2005,MAGIEN,63)=LABD ;If AUTOPSY, it's specimen else date/time 110 S I=0 F I=$O(MAGFDA(2005,MAGIEN,I)) Q:'I D 111 . D UPDATE^DIE("S","MAGFDA","") 112 I $D(DIERR) S I=0 F S I=$O(MAGFDA(2005,MAGIEN,I)) Q:'I D 113 . S MAGFDA(2005,MAGIEN,I)="" D UPDATE^DIE("","MAGFDA","") 114 I $D(DIERR),$D(^LR(LRDFN,SECTLTR,DA1,FIELD,LABIEN,0)),$G(^LR(LRDFN,SECTLTR,DA1,FIELD,LABIEN,0))=MAGIEN D 115 . S DA(2)=LRDFN,DA(1)=DA1,DA=LABIEN 116 . S DIK="^LR("_LRDFN_","""_SECTLTR_""","_DA1_","_FIELD_"," 117 . D ^DIK ;Remove imaging pointers from lab subfile. 118 I $D(DIERR) S MAGRY="0^Unsuccessful both files not updated." K DIERR Q 119 S MAGRY="1^Success in filing both parent & image files." K DIERR 120 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGTMC1.m
r613 r623 1 MAGGTMC1 ;WOIFO/GEK - RPC Calls for Imaging/Medicine procedures ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;**59**;Nov 27, 2007;Build 20 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 FILE(MAGRY,DATA,MAGARR) ;RPC Call to File the Image pointer into 21 ; the Procedure/Subspecialty and Proc/Subspec into Image file. 22 ; 23 ; DATA = DATETIME^PSIEN^DFN^MCIEN^PROCSTUB ; 6/19/97 24 ; If MCIEN isn't sent, this will be added as new procedure 25 ; MAGARR is array of image pointers 26 ; IF PROCSTUB is 1 we JUST want New Medicine procedure stub IEN 6/19/97 27 ; as the success i.e. MAGRY="IEN^Procdure Stub created" 6/19/97 28 IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" 29 E S X="ERR^MAGGTERR",@^%ZOSF("TRAP") 30 N I,J,K,X,Y,Z,TIME,PSIEN,DFN,MAGPTR,MAGMCIEN,MCFILE,MAGOK,MAGERR,PROCSTUB 31 ; 32 S X=$P(DATA,U,1),%DT="TS" D ^%DT S TIME=Y 33 S PSIEN=+$P(DATA,U,2) 34 S DFN=+$P(DATA,U,3) 35 S MAGMCIEN=+$P(DATA,U,4) 36 S PROCSTUB=+$P(DATA,U,5) ; NEW 6/19/97 GEK 37 S MCFILE=$P($P(^MCAR(697.2,PSIEN,0),U,2),"(",2) 38 I '$D(^MAG(2005.03,MCFILE)) S MAGRY="0^Procedure file is Invalid in Imaging Parent Data File " Q 39 S MAGOK="" 40 S I="" F S I=$O(MAGARR(I)) Q:I="" D 41 . S MAGPTR(I)="" 42 . I '$D(^MAG(2005,I)) S MAGERR="0^INVALID Image entry "_I 43 I $D(MAGERR) S MAGRY=MAGERR Q 44 ; 6/19/97 New Note .MAGMCIEN 45 D UPDATE^MCUIMAG0(TIME,PSIEN,DFN,.MAGPTR,.MAGMCIEN,.MAGOK) 46 ; 47 I 'MAGOK S MAGRY=MAGOK Q 48 ; Next if we're getting a stub, Quit with the stub if it was created 49 I MAGOK,PROCSTUB D Q 50 . I MAGMCIEN<1 S MAGRY="0^FAILED Creating New Procedure stub"_MAGOK Q 51 . S MAGRY=$P(MAGMCIEN,U,1)_"^Procedure Stub created" 52 ; 53 ; now enter the pointers to procedures, in the image file. 54 ; we get back MAGPTR(I)= MCFILE^PSIEN^MULTIPLE ENTRY IEN 55 S I="" F S I=$O(MAGPTR(I)) Q:I="" D 56 . S $P(^MAG(2005,I,2),U,6,8)=MAGPTR(I) 57 . D LINKDT^MAGGTU6(.X,I) 58 S MAGRY=MAGOK 59 Q 60 ;/GEK/ 4/29/98 put in modification to return DICOM ID for MED proc. 61 DICOMID(MAGRY,DATA) ;RPC Call to return a Dicom ID for medicine procedure. 62 ; This is displayed on workstation, and used to link Dicom images 63 ; to a medicine procedure. 64 ; DATA is null ^ PSIEN ^ DFN ^ MCIEN ^ null 65 ; 66 N TMCFILE,TPSIEN,TDFN,TMCIEN,RETX 67 S TPSIEN=+$P(DATA,U,2) 68 S TDFN=+$P(DATA,U,3) 69 S TMCIEN=+$P(DATA,U,4) 70 S TMCFILE=$P($P($G(^MCAR(697.2,TPSIEN,0)),U,2),"(",2) 71 I 'TMCFILE S MAGRY="0^InValid data input PSIEN="_TPSIEN Q 72 D DICOMID^MAGDMEDI(.RETX,TMCFILE,TMCIEN,TPSIEN,TDFN) 73 S MAGRY=RETX 74 Q 75 NEW(MAGRY,DATA) ;RPC call to Create NEW Procedure stub 76 ; for a medicine procedure 77 ; 78 ; DATA = DATETIME^PSIEN^DFN ; same as old call 79 S $P(DATA,"^",4)="^1" ; the 1 means we want a new procedure stub 80 K MAGARR ; we are not passing any images. 81 D FILE(.MAGRY,DATA,.MAGARR) 82 Q 1 MAGGTMC1 ;WOIFO/GEK - RPC Calls for Imaging/Medicine procedures ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;;Mar 01, 2002 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 Q 19 FILE(MAGRY,DATA,MAGARR) ;RPC Call to File the Image pointer into 20 ; the Procedure/Subspecialty and Proc/Subspec into Image file. 21 ; 22 ; DATA = DATETIME^PSIEN^DFN^MCIEN^PROCSTUB ; 6/19/97 23 ; If MCIEN isn't sent, this will be added as new procedure 24 ; MAGARR is array of image pointers 25 ; IF PROCSTUB is 1 we JUST want New Medicine procedure stub IEN 6/19/97 26 ; as the success i.e. MAGRY="IEN^Procdure Stub created" 6/19/97 27 IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" 28 E S X="ERR^MAGGTERR",@^%ZOSF("TRAP") 29 N I,J,K,X,Y,Z,TIME,PSIEN,DFN,MAGPTR,MAGMCIEN,MCFILE,MAGOK,MAGERR 30 ; 31 S X=$P(DATA,U,1),%DT="TS" D ^%DT S TIME=Y 32 S PSIEN=+$P(DATA,U,2) 33 S DFN=+$P(DATA,U,3) 34 S MAGMCIEN=+$P(DATA,U,4) 35 S PROCSTUB=+$P(DATA,U,5) ; NEW 6/19/97 GEK 36 S MCFILE=$P($P(^MCAR(697.2,PSIEN,0),U,2),"(",2) 37 I '$D(^MAG(2005.03,MCFILE)) S MAGRY="0^Procedure file is Invalid in Imaging Parent Data File " Q 38 S MAGOK="" 39 S I="" F S I=$O(MAGARR(I)) Q:I="" D 40 . S MAGPTR(I)="" 41 . I '$D(^MAG(2005,I)) S MAGERR="0^INVALID Image entry "_I 42 I $D(MAGERR) S MAGRY=MAGERR Q 43 ; 6/19/97 New Note .MAGMCIEN 44 D UPDATE^MCUIMAG0(TIME,PSIEN,DFN,.MAGPTR,.MAGMCIEN,.MAGOK) 45 ; 46 I 'MAGOK S MAGRY=MAGOK Q 47 ; Next if we're getting a stub, Quit with the stub if it was created 48 I MAGOK,PROCSTUB D Q 49 . I MAGMCIEN<1 S MAGRY="0^FAILED Creating New Procedure stub"_MAGOK Q 50 . S MAGRY=$P(MAGMCIEN,U,1)_"^Procedure Stub created" 51 ; 52 ; now enter the pointers to procedures, in the image file. 53 ; we get back MAGPTR(I)= MCFILE^PSIEN^MULTIPLE ENTRY IEN 54 S I="" F S I=$O(MAGPTR(I)) Q:I="" D 55 . S $P(^MAG(2005,I,2),U,6,8)=MAGPTR(I) 56 S MAGRY=MAGOK 57 Q 58 ;/GEK/ 4/29/98 put in modification to return DICOM ID for MED proc. 59 DICOMID(MAGRY,DATA) ;RPC Call to return a Dicom ID for medicine procedure. 60 ; This is displayed on workstation, and used to link Dicom images 61 ; to a medicine procedure. 62 ; DATA is null ^ PSIEN ^ DFN ^ MCIEN ^ null 63 ; 64 N TMCFILE,TPSIEN,TDFN,TMCIEN 65 S TPSIEN=+$P(DATA,U,2) 66 S TDFN=+$P(DATA,U,3) 67 S TMCIEN=+$P(DATA,U,4) 68 S TMCFILE=$P($P($G(^MCAR(697.2,TPSIEN,0)),U,2),"(",2) 69 I 'TMCFILE S MAGRY="0^InValid data input PSIEN="_TPSIEN Q 70 D DICOMID^MAGDMEDI(.RETX,TMCFILE,TMCIEN,TPSIEN,TDFN) 71 S MAGRY=RETX 72 Q 73 NEW(MAGRY,DATA) ;RPC call to Create NEW Procedure stub 74 ; for a medicine procedure 75 ; 76 ; DATA = DATETIME^PSIEN^DFN ; same as old call 77 S $P(DATA,"^",4)="^1" ; the 1 means we want a new procedure stub 78 K MAGARR ; we are not passing any images. 79 D FILE(.MAGRY,DATA,.MAGARR) 80 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGTPT1.m
r613 r623 1 MAGGTPT1 2 ;;3.0;IMAGING;**16,8,92,46,59**;Nov 27, 2007;Build 20 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 FIND(MAGRY,ZY) 22 23 24 25 ; FILE NUM ^ NUM TO RETURN ^ TEXT TO MATCH ^^ SCREEN ($P 5-99)26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 FINDERR(XI) 84 85 86 87 INFO(MAGRY,DATA) 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 IMGCT(DFN) 139 140 141 142 143 144 145 146 BS5CHK(MAGRY,MAGDFN) 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 1 MAGGTPT1 ;WOIFO/GEK - Delphi-Broker calls for patient lookup and information ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;**16,8,92**;Jan 10, 2007;Build 1 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 ; 21 FIND(MAGRY,ZY) ;RPC [MAGG PAT FIND] 22 ; Call to Do a lookup using FIND^DIC 23 ; MAGRY is the Array to return. 24 ; ZY is parameter sent by calling app (Delphi) 25 ; NUM TO RETURN ^ TEXT TO MATCH ^ ^ ^ SCREEN ($P 5-99) 26 N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR" 27 ; 28 N X,Y,I,Z,MAGDFN,WARD 29 N FILE,IENS,FLDS,FLAGS,VAL,NUM,INDEX,SCR,IDENT,TROOT 30 S (FILE,IENS,FLDS,FLAGS,VAL,NUM,INDEX,SCR,IDENT,TROOT)="" 31 ; 32 S FILE=2 ; Patient File 33 ; Number of entries to return, If 0 we'll stop at 100 34 S NUM=$S(+$P(ZY,U,1):+$P(ZY,U,1),1:100) 35 S VAL=$P(ZY,U,2) ; this is the starting value i.e. 'Smi' 36 S SCR=$P(ZY,U,5,99) 37 S FLDS=$P(ZY,U,3) 38 ; $P(ZU,U,4) isn't used. 39 ; If specific fields aren't requested, 40 ; Get Identifiers, and ward as FLDS 41 ;I '$L(FLDS) S FLDS=FLDS_";.1;.03;.09;.301;391" 42 I '$L(FLDS) S FLDS=FLDS_";.1;.301;391" 43 ; we'll add ACN to the index to search, for ward 44 ; for speed we'll decide which xref to use 45 S INDEX=$S(VAL?9N:"SSN^ACN",VAL?1U1.N:"BS5^ACN",1:"B^ACN") 46 ; 47 K ^TMP("DILIST",$J) 48 K ^TMP("DIERR",$J) 49 ; VAL is the initial value to search for. i.e. the user input. 50 ; Next line is to stop the FM Infinite Error Trap problem. 51 I $L(VAL)>30 S MAGRY(0)="0^Invalid: Input '"_$E(VAL,1,40)_"...' is too long. "_$L(VAL)_" characters." Q 52 D FIND^DIC(FILE,IENS,FLDS,FLAGS,VAL,NUM,INDEX,SCR,IDENT,TROOT) 53 ; 54 ; if no Match or ERROR we return 0 as 1st '^' piece. 55 ; 56 I '$D(^TMP("DILIST",$J,1)) S I=1 D Q 57 . I $D(^TMP("DIERR",$J)) D FINDERR(I) Q 58 . S MAGRY(I)="NO MATCH for lookup on """_$P(ZY,"^",2)_"""" 59 ; 60 ; so we have some matches, (BUT we could still have an error) 61 ; so first list all matches, then the Errors, if any. 62 S I="" F S I=$O(^TMP("DILIST",$J,1,I)) Q:I="" D 63 . S X=^TMP("DILIST",$J,1,I) ; Name 64 . S MAGDFN=^TMP("DILIST",$J,2,I) ; DFN 65 . ; 66 . S WARD=^TMP("DILIST",$J,"ID",I,.1) 67 . K ^TMP("DILIST",$J,"ID",I,.1) 68 . I $E(WARD,1,$L(VAL))=VAL S X=WARD_" "_X 69 . ; 70 . S X=X_" "_$$DOB^DPTLK1(MAGDFN)_" "_$$SSN^DPTLK1(MAGDFN) 71 . S Z=0 72 . ; We are displaying other identifiers with each patient. 73 . F S Z=$O(^TMP("DILIST",$J,"ID",I,Z)) Q:Z="" S X=X_" "_^(Z) 74 . S MAGRY(I)=X_"^"_+MAGDFN 75 ; 76 I $D(^TMP("DIERR",$J)) D FINDERR() Q 77 I '$D(^TMP("DILIST",$J,0)) Q 78 S X=^TMP("DILIST",$J,0) 79 S I=$O(MAGRY(""),-1)+1 80 S MAGRY(0)="Found "_$P(X,"^")_" entr"_$S((+X=1):"y",1:"ies")_" matching """_$P(ZY,"^",3)_"""" 81 I $P(X,"^",3)>0 S MAGRY(0)=MAGRY(0)_" there are more" 82 Q 83 FINDERR(XI) ; 84 I '+$G(XI) S XI=$O(MAGRY(""),-1)+1 85 S MAGRY(XI)="ERROR^"_^TMP("DIERR",$J,1,"TEXT",1) 86 Q 87 INFO(MAGRY,DATA) ;RPC [MAGG PAT INFO] Call to Return patient info. 88 ; Input parameters 89 ; DATA: MAGDFN ^ NOLOG ^ ISICN 90 ; MAGDFN -- Patient DFN 91 ; NOLOG -- 0/1; if 1, then do NOT update the Session log 92 ; ISICN -- 0/1 if 1, then this is an ICN, if 0 (default) this is a DFN ; Patch 41 93 ; MAGRY is a string, we return the following : 94 ; //$P 1 2 3 4 5 6 7 8 9 10 95 ; // status ^ DFN ^ name ^ sex ^ DOB ^ SSN ^ S/C ^ TYPE ^ Veteran(y/n) ^ Patient Image Count 96 ; //$P 11 12 13 97 ; ICN SITE Number ^ Production Account 1/0 98 ; VADM(1)=Patient's name 99 ; VADM(5)=Patient's sex (M^MALE) 100 ; VADM(3)=Patient's DOB (internal^external) 101 ; VADM(2)=Patient's SSN (internal^external) 102 ; VAEL(3)=Patient's Service Connected? (#.301) (1=yes) 103 ; VAEL(4)=Patient's Veteran Y/N (#1901) (1=yes) 104 ; VAEL(6)=Patient's Type (#391) (internal^external) 105 ; 106 N MAGDFN,DFN,X,NOLOG,VADM,VAEL,VAERR,ISICN 107 S MAGDFN=$P(DATA,U),NOLOG=+$P(DATA,U,2),ISICN=+$P(DATA,U,3) 108 I ISICN D GETDFN^VAFCTFU1(.DFN,MAGDFN) 109 E S DFN=+MAGDFN 110 D DEM^VADPT,ELIG^VADPT 111 I VAERR S MAGRY="0^"_"Entry not found in Patient file." Q 112 S X=$TR($$FMTE^XLFDT($P(VADM(3),"^"),"2FD")," ",0) 113 ; // status ^ DFN ^ name ^ sex ^ DOB ^ SSN ^ S/C ^ TYPE ^ Veteran(y/n) ^ Patient Image Count 114 S $P(MAGRY,"^",1,2)="1^"_DFN 115 ; Fields: NAME, SEX, DATE OF BIRTH, SSN 116 S $P(MAGRY,"^",3,6)=$G(VADM(1))_"^"_$P(VADM(5),"^",2)_"^"_X_"^"_$P(VADM(2),"^") 117 ; Fields: Service Connected?, Type, Veteran Y/N? 118 S $P(MAGRY,"^",7,9)=$S(+VAEL(3):"YES",1:"")_"^"_$P(VAEL(6),"^",2)_"^"_$S(+VAEL(4):"YES",1:"") 119 ; Fields: Patient Image Count 120 S $P(MAGRY,"^",10)=$$IMGCT(DFN)_"^" 121 ; Additions. for Patch 41 122 ; Fields : Patient ICN 123 S $P(MAGRY,"^",11)=$$GETICN^MPIF001(DFN) 124 S X=$$SITE^VASITE 125 ; Fields: Site Number Prod Acct 126 S $P(MAGRY,"^",12)=$P($G(X),"^",3)_"^"_"1" ; We'll default to Production Account = Yes. 127 ; NEED KERNEL PATCH XU*8.0*284 FOR PROD^XUPROD 128 ; Fields : the Actual value for Prod Acct 129 I $L($T(PROD^XUPROD)) S $P(MAGRY,"^",13)=+$$PROD^XUPROD 130 S $P(MAGRY,"^",14)="^" 131 ; AGE 132 S $P(MAGRY,"^",15)=VADM(4)_"^" 133 D KVAR^VADPT,KVA^VADPT 134 I NOLOG ; Don't update session log 135 ; We'll track DFN:ICN 136 E D ACTION^MAGGTAU("PAT^"_DFN_$S(ISICN:"-"_MAGDFN,1:"")) 137 Q 138 IMGCT(DFN) ; RETURN TOTAL NUMBER OF IMAGES FOR A PATIENT; 139 ; 140 N I,CT,RDT,PRX,IEN 141 S CT=0 142 S RDT="" F S RDT=$O(^MAG(2005,"APDTPX",DFN,RDT)) Q:RDT="" D 143 . S PRX="" F S PRX=$O(^MAG(2005,"APDTPX",DFN,RDT,PRX)) Q:PRX="" D 144 . . S IEN="" F S IEN=$O(^MAG(2005,"APDTPX",DFN,RDT,PRX,IEN)) Q:IEN="" S CT=CT+1 145 Q CT 146 BS5CHK(MAGRY,MAGDFN) ;RPC [MAGG PAT BS5 CHECK] 147 ; Call to check the BS5 cross ref 148 ; and see if any similar patients exist. 149 ; If yes, all matching patients will be listed and shown to the user. 150 ; 151 N MAGX,MAGDPT,XDFN,XSSN,CT,LNTH 152 S LNTH=0 153 S MAGRY(1)="-1^Error checking cross reference" 154 D GUIBS5A^DPTLK6(.MAGRY,MAGDFN) 155 I MAGRY(1)=0 Q 156 S CT=$O(MAGRY(""),-1)+1 157 S MAGRY(CT)=MAGRY(CT-1),MAGRY(CT-1)="0^ " 158 S I="" F S I=$O(MAGRY(I)) Q:'I D 159 . I $P(MAGRY(I),U)=0 Q 160 . I $L($P(MAGRY(I),U,3))>LNTH S LNTH=$L($P(MAGRY(I),U,3)) 161 S LNTH=LNTH+1 162 S I=1 F S I=$O(MAGRY(I)) Q:'I D 163 . I $P(MAGRY(I),U)="0" S MAGRY(I)=$P(MAGRY(I),U,2) Q 164 . S XDFN=$P(MAGRY(I),U,2) 165 . I +XDFN=+MAGDFN S MAGX=" >>>>>> " 166 . E S MAGX=" " 167 . S XSSN=$$SSN^DPTLK1(XDFN) I XSSN?9N S XSSN=$E(XSSN,1,3)_"-"_$E(XSSN,4,5)_"-"_$E(XSSN,6,9) 168 . S MAGDPT=$P(MAGRY(I),U,3),$E(MAGDPT,LNTH)=" " 169 . S MAGX=MAGX_MAGDPT_" "_$$DOB^DPTLK1(XDFN)_" "_XSSN 170 . S MAGRY(I)=MAGX 171 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGTRA.m
r613 r623 1 MAGGTRA ;WOIFO/GEK - RPC Call to list Patient's Rad/Nuc Exams, Reports ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;**59**;Nov 27, 2007;Build 20 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 ;; | 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 Q 19 LIST(MAGRY,DATA) ; 20 ; SOME OLD IMAGING EXECUTABLES (IMGVWP10) STILL CALL HERE 21 ; THIS HAS BEEN SWITCHED TO LIST^MAGGTRA1 22 ; 23 ;MAGRY - return array of patient's exams. 24 ;DATA - RADFN - Radiology Patient's DFN ^RADPT( 25 ; 26 D LIST^MAGGTRA1(.MAGRY,.DATA) 27 Q 28 MAGPTR(MAGRY,XDUZ,MAGIEN,DATA) ;RPC Call to file Image pointer into Radiology 29 ; File and Radiology pointer into Image File. 30 ; 31 ; MAGRY is the return string = 1^success if things work okay. 32 ; 0^message if things not okay. 33 ; DATA is The data that was sent in LIST^MAGGTRA 34 ; it is the display data _ to ^TMP($J,"RAEX",RACNT 35 ; the ^TMP is setup by RAPTLU, (and MAGGTRA) in the lookup 36 ; of patient exams, we keep it, and send it back in case 37 ; we need to create a new report. 38 ; 39 ; XDUZ is not used from parameter list anymore. 40 ; MAGIEN is Image File IEN ^MAG(2005,IEN 41 ; 42 N Y,I,CT,MAGERR,DIQUIET 43 N RADFN,RADTI,RACNI,RANME,RASSN,RADATE,RADTE,RACN,RAPRC,RARPT,RAST,MAGGP 44 IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" 45 E S X="ERR^MAGGTERR",@^%ZOSF("TRAP") 46 S DIQUIET=1,MAGERR=0,CT=0 47 D DT^DICRW 48 ; The list entry selected has the following data associated with it 49 ; it was created using parts of RAPTLU routine to list rad exams 50 ;^TMP($J,"RAEX",RACNT)=RADFN_"^"_RADTI_"^"_RACNI_"^"_RANME_"^"_RASSN_"^"_RADATE_"^"_RADTE_"^"_RACN_"^"_RAPRC_"^"_RARPT_"^"_RAST 51 ; 52 S DATA=$P(DATA,"^",7,99) 53 F I="RADFN","RADTI","RACNI","RANME","RASSN","RADATE","RADTE","RACN","RAPRC","RARPT","RAST" S CT=CT+1,@I=$P(DATA,"^",CT) 54 ; 55 ; let us check a few things first 56 ; Do we have a valid IMAGE IEN ^MAG(2005, 57 I '$D(^MAG(2005,MAGIEN,0)) S MAGRY="0^OPERATION CANCEDED: INVALID Imaging (2005) entry" Q 58 ; Does this Imaging entry already point to a Report. 59 I $D(^MAG(2005,MAGIEN,2)) S Z=^(2) D 60 . F I=6,7,8 S X=$P(Z,U,I) I $L(X) S MAGERR=1 Q 61 I MAGERR S MAGRY="0^OPERATION CANCELED: Imaging File entry already has an associated Report" Q 62 ; Does the Imaging entry patient, match the Rad Exam entry patient 63 I $P(^MAG(2005,MAGIEN,0),U,7)'=RADFN S MAGRY="0^OPERATION CANCELED: Imaging Patient doesn't match Radiology Patient" Q 64 I RARPT,'$D(^RARPT(RARPT,0)) S MAGRY="0^OPERATION CANCELED: INVALID Radiology Report Number" Q 65 I '$G(RARPT) D CREATE^RARIC I '$G(RARPT) S MAGRY="0^OPERATION FAILED creating new Radiology Report entry" Q 66 ; Now lets file the Image pointer in the ^RARPT( file. 67 S MAGGP=MAGIEN 68 D PTR^RARIC 69 I Y<1 S MAGRY="0^OPERATION FAILED Creating Image pointer in Report File" Q 70 ; Now SET the Parent fields in the Image File 71 S $P(^MAG(2005,MAGIEN,2),U,6,8)=74_U_RARPT_U_+Y 72 ; DONE. 73 S MAGRY="1^Image pointer filed successfully" 74 D LINKDT^MAGGTU6(.X,MAGIEN) 75 Q 1 MAGGTRA ;WOIFO/GEK - RPC Call to list Patient's Rad/Nuc Exams, Reports ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;;Mar 01, 2002 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 Q 19 LIST(MAGRY,DATA) ; 20 ; SOME OLD IMAGING EXECUTABLES (IMGVWP10) STILL CALL HERE 21 ; THIS HAS BEEN SWITCHED TO LIST^MAGGTRA1 22 ; 23 ;MAGRY - return array of patient's exams. 24 ;DATA - RADFN - Radiology Patient's DFN ^RADPT( 25 ; 26 D LIST^MAGGTRA1(.MAGRY,.DATA) 27 Q 28 MAGPTR(MAGRY,XDUZ,MAGIEN,DATA) ;RPC Call to file Image pointer into Radiology 29 ; File and Radiology pointer into Image File. 30 ; 31 ; MAGRY is the return string = 1^success if things work okay. 32 ; 0^message if things not okay. 33 ; DATA is The data that was sent in LIST^MAGGTRA 34 ; it is the display data _ to ^TMP($J,"RAEX",RACNT 35 ; the ^TMP is setup by RAPTLU, (and MAGGTRA) in the lookup 36 ; of patient exams, we keep it, and send it back in case 37 ; we need to create a new report. 38 ; 39 ; XDUZ is not used from parameter list anymore. 40 ; MAGIEN is Image File IEN ^MAG(2005,IEN 41 ; 42 N Y,I,CT,MAGERR 43 N RADFN,RADTI,RACNI,RANME,RASSN,RADATE,RADTE,RACN,RAPRC,RARPT,RAST 44 IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" 45 E S X="ERR^MAGGTERR",@^%ZOSF("TRAP") 46 S DIQUIET=1,MAGERR=0,CT=0 47 D DT^DICRW 48 ; The list entry selected has the following data associated with it 49 ; it was created using parts of RAPTLU routine to list rad exams 50 ;^TMP($J,"RAEX",RACNT)=RADFN_"^"_RADTI_"^"_RACNI_"^"_RANME_"^"_RASSN_"^"_RADATE_"^"_RADTE_"^"_RACN_"^"_RAPRC_"^"_RARPT_"^"_RAST 51 ; 52 S DATA=$P(DATA,"^",7,99) 53 F I="RADFN","RADTI","RACNI","RANME","RASSN","RADATE","RADTE","RACN","RAPRC","RARPT","RAST" S CT=CT+1,@I=$P(DATA,"^",CT) 54 ; 55 ; let us check a few things first 56 ; Do we have a valid IMAGE IEN ^MAG(2005, 57 I '$D(^MAG(2005,MAGIEN,0)) S MAGRY="0^OPERATION CANCEDED: INVALID Imaging (2005) entry" Q 58 ; Does this Imaging entry already point to a Report. 59 I $D(^MAG(2005,MAGIEN,2)) S Z=^(2) D 60 . F I=6,7,8 S X=$P(Z,U,I) I $L(X) S MAGERR=1 Q 61 I MAGERR S MAGRY="0^OPERATION CANCELED: Imaging File entry already has an associated Report" Q 62 ; Does the Imaging entry patient, match the Rad Exam entry patient 63 I $P(^MAG(2005,MAGIEN,0),U,7)'=RADFN S MAGRY="0^OPERATION CANCELED: Imaging Patient doesn't match Radiology Patient" Q 64 I RARPT,'$D(^RARPT(RARPT,0)) S MAGRY="0^OPERATION CANCELED: INVALID Radiology Report Number" Q 65 I '$G(RARPT) D CREATE^RARIC I '$G(RARPT) S MAGRY="0^OPERATION FAILED creating new Radiology Report entry" Q 66 ; Now lets file the Image pointer in the ^RARPT( file. 67 S MAGGP=MAGIEN 68 D PTR^RARIC 69 I Y<1 S MAGRY="0^OPERATION FAILED Creating Image pointer in Report File" Q 70 ; Now SET the Parent fields in the Image File 71 S $P(^MAG(2005,MAGIEN,2),U,6,8)=74_U_RARPT_U_+Y 72 ; DONE. 73 S MAGRY="1^Image pointer filed successfully" 74 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGTSR.m
r613 r623 1 MAGGTSR ;WOIFO/GEK - SURGERY CASE LIST ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;**8,59**;Nov 27, 2007;Build 20 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 GET(MAGRY,MAGDFN,DATA) ;RPC [MAGGSUR GET] 21 ; Call to get list of Patient Surgery procedures 22 ; MAGDFN = Patient DFN 23 ; DATA = For Future Use. 24 N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR" 25 N Y,NAME,AI,CASES,SDAT,DTX,SRFDA 26 K ^TMP($J,"MAGGTSR") 27 S NAME=$P($G(^DPT(MAGDFN,0)),U) I NAME="" S MAGRY(0)="0^INVALID Patient ID" Q 28 ; This is the Old Call we have always made. Doesn't have Non-OR 29 D GET^SROGTSR(.MAGRY,MAGDFN) 30 I 'MAGRY(0) S MAGRY(0)=MAGRY(0)_" for "_NAME G C1 31 ; Image count is for future use by Display 32 S MAGRY(1)="#^Date^Case description^Case #^Images" 33 S I=1 F S I=$O(MAGRY(I)) Q:'I D 34 . S DTX=$$FMTE^XLFDT($P(MAGRY(I),U,5),"5MZ") 35 . S ^TMP($J,"MAGGTSR",$P(MAGRY(I),U,5),$P(MAGRY(I),U,4))=DTX_"^"_$P(MAGRY(I),U,3)_"^"_$P(MAGRY(I),"^",4)_"^"_$P(MAGRY(I),U,6)_U_"|"_$P(MAGRY(I),U,4,5)_U 36 ; 37 ;This is the New Call, which has Non-OR, but doesn't have (Scheduled) so we merge the two calls. 38 C1 D LIST^SROESTV(.CASES,MAGDFN) 39 I '$D(@CASES) G E1 40 S MAGRY(0)="1^" 41 S MAGRY(1)="#^Date^Case description^Case #^Images" 42 S I=0 F S I=$O(@CASES@(I)) Q:'I D 43 . S SDAT=@CASES@(I) 44 . ; SDAT = SURIEN ^ SURDESC ^ SURDT ^ DFN;NAME ^ 45 . I $D(^TMP($J,"MAGGTSR",$P(SDAT,U,3),$P(SDAT,U,1))) Q 46 . S ^TMP($J,"MAGGTSR",$P(SDAT,U,3),$P(SDAT,U,1))=$$FMTE^XLFDT($P(SDAT,U,3),"5MZ")_U_$P(SDAT,U,2)_U_$P(SDAT,U,1)_U_$$IMGCT($P(SDAT,U,1))_U_"|"_$P(SDAT,U,1)_U_$P(SDAT,U,3)_U 47 . Q 48 ; 49 ; Now Returned the Merged List of the results of Old Call, with Results of New Call. 50 E1 ; 51 I '$D(^TMP($J,"MAGGTSR")) S MAGRY(0)="0^No Cases for "_$G(NAME) Q 52 S I=1,DTX=0,SRFDA=0 53 F S DTX=$O(^TMP($J,"MAGGTSR",DTX)) Q:'DTX D 54 . S SRFDA="" F S SRFDA=$O(^TMP($J,"MAGGTSR",DTX,SRFDA),-1) Q:'SRFDA D 55 . . S I=I+1,MAGRY(I)=I-1_"^"_^TMP($J,"MAGGTSR",DTX,SRFDA) 56 . . Q 57 . Q 58 S $P(MAGRY(0),"^",1)=I-1 59 Q 60 IMGCT(SRFIEN) ; 61 ; Count of images for this Surgery Case 62 ; If more than one group (or image) 63 ; then return "Group count : total images" i.e. "3:134" 64 ; else return count of Images i.e. "4" 65 ; 66 N CT,GCT,ICT,J 67 S J=0,CT=0,GCT=0 68 F S J=$O(^SRF(SRFIEN,2005,"B",J)) Q:'J D 69 . S ICT=+$P($G(^MAG(2005,J,1,0)),U,4) 70 . S ICT=$S(ICT:ICT,1:1) ;If no group images, set count =1 (single image) 71 . S GCT=GCT+1 72 . S CT=CT+ICT 73 I (GCT>1) Q GCT_":"_CT 74 Q CT 75 ; 76 IMAGE(MAGRY,DATA) ; 77 ; Called with the IEN of the Surgery package ^SRF(170,x 78 ; We'll return a list of images. 79 N SRFIEN,MAGIEN 80 S SRFIEN=+DATA 81 I '$D(^SRF(SRFIEN)) S MAGRY(0)="0^INVALID Surgery File entry" Q 82 I '$O(^SRF(SRFIEN,2005,0)) S MAGRY(0)="0^No Images for this Operation." Q 83 D GETLIST 84 Q 85 GETLIST ; called from other points in this routine, when SRFIEN is defined 86 ; and returns a list in MAGRY(1..n) 87 ; We'll make a tmp list of just the image IEN's 88 ; splitting groups into individual image entries. 89 K ^TMP($J,"MAGGX") 90 S I=0,CT=1 F S I=$O(^SRF(SRFIEN,2005,I)) Q:'I D 91 . S MAGIEN=$P(^SRF(SRFIEN,2005,I,0),U,1) 92 . Q:'$D(^MAG(2005,MAGIEN,0)) 93 . I '$O(^MAG(2005,MAGIEN,1,0)) S ^TMP($J,"MAGGX",MAGIEN)="" 94 . E S Z=0 F S Z=$O(^MAG(2005,MAGIEN,1,Z)) Q:Z="" S ^TMP($J,"MAGGX",$P(^MAG(2005,MAGIEN,1,Z,0),U,1))="" 95 I '$D(^TMP($J,"MAGGX")) S MAGRY(0)="0^Surgery File Entry "_SRFIEN_": has INVALID Image Pointers" Q 96 S Z="",CT=0 97 S MAGQUIET=1 98 F S Z=$O(^TMP($J,"MAGGX",Z)) Q:Z="" D 99 . S CT=CT+1,MAGXX=Z D INFO^MAGGTII 100 . S MAGRY(CT)="B2^"_MAGFILE 101 K MAGQUIET 102 S MAGRY(0)=CT_"^Images for the selected Surgery File entry" 103 K ^TMP("MAGGX") 104 Q 1 MAGGTSR ;WOIFO/GEK - SURGERY CASE LIST ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;**8**;Sep 15, 2004 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 Q 19 GET(MAGRY,MAGDFN) ;RPC [MAGGSUR GET] 20 ; Call to get list of Patient Surgery procedures 21 ; MAGDFN is Patient DFN 22 ; 23 IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR" 24 E S X="ERRA^MAGGTERR",@^%ZOSF("TRAP") 25 N Y,DFN,MAGNAME 26 S MAGNAME=$P($G(^DPT(MAGDFN,0)),U) 27 I MAGNAME="" S MAGGRY(0)="0^INVALID Patient ID" Q 28 D GET^SROGTSR(.MAGRY,MAGDFN) 29 I 'MAGRY(0) S MAGRY(0)=MAGRY(0)_" for "_MAGNAME Q 30 ; Here we are changing the data returned in the array, from SROGTSR 31 ; , it will now also return the count of images associated with the 32 ; surgery report. This is in advance of the change for Display, to 33 ; list the patient's surgery reports, like we list radiology reports. 34 ; 35 I (+$G(MAGJOB("VERSION"))<2.5) Q 36 S MAGRY(1)=$P(MAGRY(1),U,1,3)_"^Images" 37 S I=1 F S I=$O(MAGRY(I)) Q:'I D 38 . S MAGRY(I)=$P(MAGRY(I),U,1,3)_U_$P(MAGRY(I),U,6)_U_$C(124)_$P(MAGRY(I),U,4,5)_U 39 Q 40 IMAGE(MAGRY,DATA) ; 41 ; Called with the IEN of the Surgery package ^SRF(170,x 42 ; We'll return a list of images. 43 N SRFIEN,MAGIEN 44 S SRFIEN=+DATA 45 I '$D(^SRF(SRFIEN)) S MAGRY(0)="0^INVALID Surgery File entry" Q 46 I '$O(^SRF(SRFIEN,2005,0)) S MAGRY(0)="0^No Images for this Operation." Q 47 D GETLIST 48 Q 49 GETLIST ; called from other points in this routine, when SRFIEN is defined 50 ; and returns a list in MAGRY(1..n) 51 ; We'll make a tmp list of just the image IEN's 52 ; splitting groups into individual image entries. 53 K ^TMP("MAGGX",$J) 54 S I=0,CT=1 F S I=$O(^SRF(SRFIEN,2005,I)) Q:'I D 55 . S MAGIEN=$P(^SRF(SRFIEN,2005,I,0),U,1) 56 . Q:'$D(^MAG(2005,MAGIEN,0)) 57 . I '$O(^MAG(2005,MAGIEN,1,0)) S ^TMP("MAGGX",$J,MAGIEN)="" 58 . E S Z=0 F S Z=$O(^MAG(2005,MAGIEN,1,Z)) Q:Z="" S ^TMP("MAGGX",$J,$P(^MAG(2005,MAGIEN,1,Z,0),U,1))="" 59 I '$D(^TMP("MAGGX",$J)) S MAGRY(0)="0^Surgery File Entry "_SRFIEN_": has INVALID Image Pointers" Q 60 S Z="",CT=0 61 S MAGQUIET=1 62 F S Z=$O(^TMP("MAGGX",$J,Z)) Q:Z="" D 63 . S CT=CT+1,MAGXX=Z D INFO^MAGGTII 64 . S MAGRY(CT)="B2^"_MAGFILE 65 K MAGQUIET 66 S MAGRY(0)=CT_"^Images for the selected Surgery File entry" 67 K ^TMP("MAGGX") 68 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGTSR1.m
r613 r623 1 MAGGTSR1 ;WOIFO/GEK - ADD IMAGES TO SURGERY FILE ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;**59**;Nov 27, 2007;Build 20 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 FILE(MAGRY,MAGIEN,DATA) ;RPC Call to file Image pointers in Surgery package 21 ; and Surgery pointers in Image File. 22 ; 23 ; DATA is same data that we listed in the GET^MAGGTSR call 24 ; MAGIEN is the Imaging internal number. 25 ; example 26 ; for Imaging Versions < 2.5 the data is 27 ; # DATE DESC SRF(IEN FM DATE 28 ;CNT_U_(READABLE DATE)_U_SROPS(1)_U_SROP_U_SRSDATE 29 ; 30 ; for Imaging Versions > 2.4, the data is different 31 ;CNT_U_(READABLE DATE)_U_SROPS(1)_U_IMAGECT_U_"|"_SROP_U_SRSDATE 32 ; example 33 ; 1^05-06-1997^REMOVE TONSILS (REQUESTED)^8^|9853^2970506^ 34 ; 35 IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" 36 E S X="ERR^MAGGTERR",@^%ZOSF("TRAP") 37 N Y,MAGSIEN,MAGPDT,MAGFDA,MAGERR,MAGIENS 38 ; 39 I (+$G(MAGJOB("VERSION"))>2.4) D 40 . S MAGSIEN=$P($P(DATA,$C(124),2),U,1) 41 . S MAGPDT=$P($P(DATA,$C(124),2),U,2) 42 E S MAGSIEN=$P(DATA,U,4),MAGPDT=$P(DATA,U,5) 43 S MAGFDA(130.02005,"+1,"_MAGSIEN_",",.01)=MAGIEN 44 D UPDATE^DIE("S","MAGFDA","MAGIENS","MAGERR") 45 I '$G(MAGIENS(1)) D D CLEAN^DILF S MAGRY=MAGERR Q 46 . S MAGERR="0^ERROR Adding Image to Surgery Package " 47 . I $D(DIERR) D RTRNERR(.MAGERR) 48 S MAGRY="1^Image added to Surgery Package" 49 S $P(^MAG(2005,MAGIEN,2),U,6,8)="130^"_MAGSIEN_U_MAGIENS(1) 50 D LINKDT^MAGGTU6(.X,MAGIEN) 51 Q 52 RTRNERR(ETXT) ; There was error from UPDATE^DIE quit with error text 53 S ETXT="0^ERROR "_MAGERR("DIERR",1,"TEXT",1) 54 Q 1 MAGGTSR1 ;WOIFO/GEK - ADD IMAGES TO SURGERY FILE ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;;Mar 01, 2002 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 Q 19 FILE(MAGRY,MAGIEN,DATA) ;RPC Call to file Image pointers in Surgery package 20 ; and Surgery pointers in Image File. 21 ; 22 ; DATA is same data that we listed in the GET^MAGGTSR call 23 ; MAGIEN is the Imaging internal number. 24 ; example 25 ; for Imaging Versions < 2.5 the data is 26 ; # DATE DESC SRF(IEN FM DATE 27 ;CNT_U_(READABLE DATE)_U_SROPS(1)_U_SROP_U_SRSDATE 28 ; 29 ; for Imaging Versions > 2.4, the data is different 30 ;CNT_U_(READABLE DATE)_U_SROPS(1)_U_IMAGECT_U_"|"_SROP_U_SRSDATE 31 ; example 32 ; 1^05-06-1997^REMOVE TONSILS (REQUESTED)^8^|9853^2970506^ 33 ; 34 IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" 35 E S X="ERR^MAGGTERR",@^%ZOSF("TRAP") 36 N Y,MAGSIEN,MAGPDT,MAGFDA,MAGERR,MAGIENS 37 ; 38 I (+$G(MAGJOB("VERSION"))>2.4) D 39 . S MAGSIEN=$P($P(DATA,$C(124),2),U,1) 40 . S MAGPDT=$P($P(DATA,$C(124),2),U,2) 41 E S MAGSIEN=$P(DATA,U,4),MAGPDT=$P(DATA,U,5) 42 S MAGFDA(130.02005,"+1,"_MAGSIEN_",",.01)=MAGIEN 43 D UPDATE^DIE("S","MAGFDA","MAGIENS","MAGERR") 44 I '$G(MAGIENS(1)) D D CLEAN^DILF S MAGRY=MAGERR Q 45 . S MAGERR="0^ERROR Adding Image to Surgery Package " 46 . I $D(DIERR) D RTRNERR(.MAGERR) 47 S MAGRY="1^Image added to Surgery Package" 48 S $P(^MAG(2005,MAGIEN,2),U,6,8)="130^"_MAGSIEN_U_MAGIENS(1) 49 Q 50 RTRNERR(ETXT) ; There was error from UPDATE^DIE quit with error text 51 S ETXT="0^ERROR "_MAGERR("DIERR",1,"TEXT",1) 52 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGTSY2.m
r613 r623 1 MAGGTSY2 ;WOIFO/GEK - Calls from Imaging windows for System Manager ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;**59**;Nov 27, 2007;Build 20 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 ;; | 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 Q 19 MAG(MAGRY,NODE) ;RPC Call to show node of Image File 20 ; NODE is the IEN of Image File : ^MAG(2005,NODE 21 N Y,I,CT,X,TNODE 22 S MAGRY=$NA(^TMP("MAGNODE",$J)) 23 S NODE=$G(NODE) 24 N I,CT,X 25 K @MAGRY 26 S @MAGRY@(0)="Display NODE: "_$S($L(NODE):NODE,1:"LAST") 27 S I=0,CT=0 28 I $E(NODE)="^" G OTH 29 I 'NODE S NODE=$P(^MAG(2005,0),U,3) 30 S I="^MAG(2005,"_NODE_","""")" 31 F S X=$Q(@I) S I=X Q:$P(X,",",2)'=NODE D 32 . S CT=CT+1,@MAGRY@(CT)=X_" "_@X 33 . Q 34 I $P($G(^MAG(2005,NODE,2)),"^",6)="8925" D 35 . S CT=CT+1,@MAGRY@(CT)=" ******* TIU ******* " 36 . S TNODE=$P(^MAG(2005,NODE,2),"^",7) 37 . S I="^TIU(8925,"_TNODE_","""")" 38 . F S X=$Q(@I) S I=X Q:$P(X,",",2)'=TNODE D 39 . . S CT=CT+1,@MAGRY@(CT)=X_" "_@X 40 . . Q 41 Q 42 OTH ; 43 N OTHDA 44 S OTHDA=$P(NODE,",",2) 45 I OTHDA=0 S NODE=NODE_")" Q:'$D(@NODE) S CT=$O(@MAGRY@(""),-1)+1,@MAGRY@(CT)=$G(@(NODE)) Q 46 S I=NODE_","""")" 47 F S X=$Q(@I) S I=X Q:$P(X,",",2)'=OTHDA D 48 . S CT=$O(@MAGRY@(""),-1)+1,@MAGRY@(CT)=X_" "_@X 49 . Q 50 Q 1 MAGGTSY2 ;WOIFO/GEK - Calls from Imaging windows for System Manager ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;;Mar 01, 2002 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 Q 19 MAG(MAGRY,NODE) ; RPC Call for MAGSYS utility. Returns Global Node. 20 N CT,I,X,Y 21 S MAGRY=$NA(^TMP("MAGNODE",$J)) 22 S NODE=+$G(NODE) 23 I 'NODE S NODE=$P(^MAG(2005,0),U,3) 24 K @MAGRY 25 ;S @MAGRY@(0)="Display Imaging File NODE "_$S(NODE:NODE,1:"LAST") 26 S I=0,CT=0 27 S I="^MAG(2005,"_NODE_","""")" 28 F S X=$Q(@I) S I=X Q:$P(X,",",2)'=NODE D 29 . S CT=CT+1,@MAGRY@(CT)=X_" "_@X 30 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGTSYS.m
r613 r623 1 MAGGTSYS ;WOIFO/GEK - Calls from Imaging windows for System Manager ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;**59**;Nov 27, 2007;Build 20 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 ;; | 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 Q 19 GETS(MAGRY,NODE,FLAGS) ; USE GETS^DIQ TO GET FIELD VALUES. 20 K MAGWIN,I,CT,Y,NC,MAGOUT,MAGERR,TNC,ZZ 21 S MAGRY=$NA(^TMP("MAGNODE",$J)) 22 S NODE=+$G(NODE) 23 I 'NODE S NODE=$P(^MAG(2005,0),U,3) 24 S MAGWIN=$$BROKER^XWBLIB 25 I 'MAGWIN W !,"NODE"," ",NODE 26 K @MAGRY 27 S @MAGRY@(0)="****** Fields for Image IEN: "_NODE_" ******" 28 S I=0,CT=0 29 S FLAGS=$S($L($G(FLAGS)):FLAGS,1:"IERN") 30 D GETS^DIQ(2005,NODE,"*",FLAGS,"MAGOUT","MAGERR") 31 ;D GETS^DIQ(2005,NODE,".01;1;2;2.1;2.2;3;5;6;12","R","MAGOUT","MAGERR") 32 S NC=NODE_"," 33 S I="" F S I=$O(MAGOUT(2005,NC,I)) Q:I="" D 34 . S CT=CT+1 35 . I $G(MAGOUT(2005,NC,I,"I"))=$G(MAGOUT(2005,NC,I,"E")) D Q 36 . . S ZZ=I,$E(ZZ,45,999)=" = "_$G(MAGOUT(2005,NC,I,"E")) 37 . . S @MAGRY@(CT)=ZZ 38 . . ;S @MAGRY@(CT)=I_" = "_MAGOUT(2005,NC,I,"E") Q 39 . . Q 40 . ; 41 . S ZZ=I,$E(ZZ,25,999)=" = ("_$G(MAGOUT(2005,NC,I,"I"))_") " 42 . I ($L(ZZ)>44) S ZZ=ZZ_" = "_$G(MAGOUT(2005,NC,I,"E")) S @MAGRY@(CT)=ZZ Q 43 . I ($L(ZZ)<45) S $E(ZZ,45,999)=" = "_$G(MAGOUT(2005,NC,I,"E")) S @MAGRY@(CT)=ZZ Q 44 . ;S @MAGRY@(CT)=I_" = ("_$G(MAGOUT(2005,NC,I,"I"))_") = "_$G(MAGOUT(2005,NC,I,"E")) 45 . Q 46 I $P($G(^MAG(2005,NODE,2)),"^",6)=8925 D 47 . K MAGOUT,MAGERR 48 . S CT=CT+1,@MAGRY@(CT)=" *************** TIU *************** " 49 . S CT=CT+1,@MAGRY@(CT)=" **** Field Values for TIUDA: "_$P(^MAG(2005,NODE,2),"^",7)_" ****" 50 . D GETS^DIQ(8925,$P(^MAG(2005,NODE,2),"^",7),"*",FLAGS,"MAGOUT","MAGERR") 51 . S NC=$P(^MAG(2005,NODE,2),"^",7)_"," 52 . S I="" F S I=$O(MAGOUT(8925,NC,I)) Q:I="" D 53 . . S CT=CT+1 54 . . I $G(MAGOUT(8925,NC,I,"I"))=$G(MAGOUT(8925,NC,I,"E")) D Q 55 . . . S ZZ=I,$E(ZZ,45,999)=" = "_$G(MAGOUT(8925,NC,I,"E")) 56 . . . S @MAGRY@(CT)=ZZ 57 . . . ;S @MAGRY@(CT)=I_" = "_MAGOUT(2005,NC,I,"E") Q 58 . . . Q 59 . . ; 60 . . S ZZ=I,$E(ZZ,25,999)=" = ("_$G(MAGOUT(8925,NC,I,"I"))_") " 61 . . I ($L(ZZ)>44) S ZZ=ZZ_" = "_$G(MAGOUT(8925,NC,I,"E")) S @MAGRY@(CT)=ZZ Q 62 . . I ($L(ZZ)<45) S $E(ZZ,45,999)=" = "_$G(MAGOUT(8925,NC,I,"E")) S @MAGRY@(CT)=ZZ Q 63 . . ;S @MAGRY@(CT)=I_" = ("_$G(MAGOUT(2005,NC,I,"I"))_") = "_$G(MAGOUT(2005,NC,I,"E")) 64 . . Q 65 . Q 66 Q 1 MAGGTSYS ;WOIFO/GEK - Calls from Imaging windows for System Manager ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;;Mar 01, 2002 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 Q 19 MAG(MAGRY,NODE) ;RPC Call to show node of Image File 20 ; NODE is the IEN of Image File : ^MAG(2005,NODE 21 N Y 22 S MAGRY=$NA(^TMP("MAGNODE",$J)) 23 S NODE=+$G(NODE) 24 I 'NODE S NODE=$P(^MAG(2005,0),U,3) 25 N MAGWIN,I,CT,X 26 S MAGWIN=$$BROKER^XWBLIB 27 K @MAGRY 28 ;S @MAGRY@(0)="Display Imaging File NODE "_$S(NODE:NODE,1:"LAST") 29 S I=0,CT=0 30 I 'MAGWIN W !,"NODE"," ",NODE 31 S I="^MAG(2005,"_NODE_","""")" 32 F S X=$Q(@I) S I=X Q:$P(X,",",2)'=NODE D 33 . S CT=CT+1,@MAGRY@(CT)=X_" "_@X 34 . I 'MAGWIN W !,X," ",@X 35 ; 36 Q 37 GETS(MAGRY,NODE,FLAGS) ; USE GETS^DIQ TO GET FIELD VALUES. 38 N Y 39 S MAGRY=$NA(^TMP("MAGNODE",$J)) 40 S NODE=+$G(NODE) 41 I 'NODE S NODE=$P(^MAG(2005,0),U,3) 42 N MAGWIN,I,CT 43 S MAGWIN=$$BROKER^XWBLIB 44 K @MAGRY 45 S @MAGRY@(0)="Fields for Image IEN: "_NODE 46 S I=0,CT=0 47 I 'MAGWIN W !,"NODE"," ",NODE 48 N MAGOUT,MAGERR 49 S FLAGS=$S($L($G(FLAGS)):FLAGS,1:"IERN") 50 D GETS^DIQ(2005,NODE,"*",FLAGS,"MAGOUT","MAGERR") 51 ;D GETS^DIQ(2005,NODE,".01;1;2;2.1;2.2;3;5;6;12","R","MAGOUT","MAGERR") 52 S NNODE=NODE_"," 53 S I="" F S I=$O(MAGOUT(2005,NNODE,I)) Q:I="" D 54 . S CT=CT+1 55 . I $G(MAGOUT(2005,NNODE,I,"I"))=$G(MAGOUT(2005,NNODE,I,"E")) S @MAGRY@(CT)=I_" = "_MAGOUT(2005,NNODE,I,"E") Q 56 . S @MAGRY@(CT)=I_" = ("_$G(MAGOUT(2005,NNODE,I,"I"))_") = "_$G(MAGOUT(2005,NNODE,I,"E")) 57 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGTU1.m
r613 r623 1 MAGGTU1 ;WOIFO/GEK - Silent Utilities ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;**3,8,85,59**;Nov 27, 2007;Build 20 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 DRIVE(X,SITE) ; Get the current drive for writing an image 21 ; Copied from MAGFILE and edited for silent running, made extrinsic. 22 ; X : The Network Location to Write to. Dicom Gateway sends this. 23 ; IF 'X then use DUZ(2) to find IMAGE NETWORK WRITE LOCATION. 24 ; P 85, Enable writing to any valid site. Not Just Duz(2) 25 ; SITE : The Site to Write to. Import API now sends this. 26 ; 27 ; 28 N Z,MAGREF,MAGREFNM,MAGDRIVE,MAGPLC 29 S SITE=$S($G(SITE):SITE,1:$G(DUZ(2))) 30 S MAGPLC=$$PLACE^MAGBAPI(SITE) ;pre-patch 85 was DUZ(2) 31 S MAGREF=$G(X) 32 I $G(MAGWRITE)="PACS" S MAGREF=$$GET1^DIQ(2006.1,MAGPLC,1.03,"I") ; DBI 9/20/02 - SEB 33 I 'MAGREF S MAGREF=$$GET1^DIQ(2006.1,MAGPLC,.03,"I") ; DBI 9/20/02 - SEB 34 I MAGREF="" D Q Z 35 . S Z="0^NEED WRITE LOCATION in SITE Parameters file!!! Call IRM" 36 ; 37 I '$P(^MAG(2005.2,MAGREF,0),"^",6) D Q Z 38 . S Z="0^The Server that you are writing to is off-line. Call IRM" 39 ; 40 S MAGREFNM=$P(^MAG(2005.2,MAGREF,0),"^",1),MAGDRIVE=$P(^(0),"^",2) 41 Q MAGREF_U_MAGDRIVE 42 ; 43 DA2NAME(IEN,SUF) ; Return file name with extension 44 ; SUF should always be defined, but default to .TIF if not. 45 N PRE,FILE,CMPF,MAGPLC 46 S MAGPLC=$$DA2PLC^MAGBAPIP(IEN,"F") 47 S SUF=$S($L($G(SUF)):SUF,1:"TIF") 48 S PRE=$$GET1^DIQ(2006.1,MAGPLC,.02,"E") ; gek DBI 49 ;S PRE=$G(^MAG(2006.1,"ALTR")) 50 I '$L(PRE) Q "0^Need Site Specific LETTERS in Site Parameters File" 51 ; 52 S FILE=PRE_IEN 53 ; Design of Patch 3 was changed to only return 14 digit file names. 54 ; 08/02/2002 Patch 3,8 force 14.3 file name convention 55 I ($L(FILE)<14) S FILE=PRE_$E(10000000000000+IEN,$L(PRE)+1,14) 56 Q "1^"_FILE_"."_SUF 1 MAGGTU1 ;WOIFO/GEK - Silent Utilities ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;**3,8,85**;16-March-2007;;Build 1039 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 ;; | 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 Q 19 DRIVE(X,SITE) ; Get the current drive for writing an image 20 ; Copied from MAGFILE and edited for silent running, made extrinsic. 21 ; X : The Network Location to Write to. Dicom Gateway sends this. 22 ; IF 'X then use DUZ(2) to find IMAGE NETWORK WRITE LOCATION. 23 ; P 85, Enable writing to any valid site. Not Just Duz(2) 24 ; SITE : The Site to Write to. Import API now sends this. 25 ; 26 ; 27 N Z,MAGREF,MAGREFNM,MAGDRIVE,MAGPLC 28 S SITE=$S($G(SITE):SITE,1:$G(DUZ(2))) 29 S MAGPLC=$$PLACE^MAGBAPI(SITE) ;pre-patch 85 was DUZ(2) 30 S MAGREF=$G(X) 31 I $G(MAGWRITE)="PACS" S MAGREF=$$GET1^DIQ(2006.1,MAGPLC,1.03,"I") ; DBI 9/20/02 - SEB 32 I 'MAGREF S MAGREF=$$GET1^DIQ(2006.1,MAGPLC,.03,"I") ; DBI 9/20/02 - SEB 33 I MAGREF="" D Q Z 34 . S Z="0^NEED WRITE LOCATION in SITE Parameters file!!! Call IRM" 35 ; 36 I '$P(^MAG(2005.2,MAGREF,0),"^",6) D Q Z 37 . S Z="0^The Server that you are writing to is off-line. Call IRM" 38 ; 39 S MAGREFNM=$P(^MAG(2005.2,MAGREF,0),"^",1),MAGDRIVE=$P(^(0),"^",2) 40 Q MAGREF_U_MAGDRIVE 41 ; 42 DA2NAME(IEN,SUF) ; Return file name with extension 43 ; SUF should always be defined, but default to .TIF if not. 44 N PRE,FILE,CMPF,MAGPLC 45 S MAGPLC=$$DA2PLC^MAGBAPIP(IEN,"F") 46 S SUF=$S($L($G(SUF)):SUF,1:"TIF") 47 S PRE=$$GET1^DIQ(2006.1,MAGPLC,.02,"E") ; gek DBI 48 ;S PRE=$G(^MAG(2006.1,"ALTR")) 49 I '$L(PRE) Q "0^Need Site Specific LETTERS in Site Parameters File" 50 ; 51 S FILE=PRE_IEN 52 ; Design of Patch 3 was changed to only return 14 digit file names. 53 ; 08/02/2002 Patch 3,8 force 14.3 file name convention 54 I ($L(FILE)<14) S FILE=PRE_$E(10000000000000+IEN,$L(PRE)+1,14) 55 Q "1^"_FILE_"."_SUF -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGTU3.m
r613 r623 1 MAGGTU3 ;WOIFO/GEK - Silent calls for Imaging ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;**7,8,48,45,20,46,59**;Nov 27, 2007;Build 20 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 ;; | 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 Q 19 IMAGEINF(MAGRY,IEN,NOCHK) ;RPC [MAGG IMAGE INFO] Call to return information for 1 image; 20 ; IEN = Image IEN ^MAG(2005,IEN 21 ; NOCHK = 1|"" if 1 then do not run QA check on this image. 22 ; 23 N MAGFILE,Y,Z,MAGNOCHK 24 I '$D(^MAG(2005,IEN)) D Q 25 . I $D(^MAG(2005.1,IEN)) S MAGRY(0)="0^Image : """_$P($G(^MAG(2005.1,IEN,2)),U,4)_""" has been deleted." Q 26 . S MAGRY(0)="0^INVALID Image number "_IEN 27 . Q 28 ; MAGGTII queries the variable MAGNOCHK to run QA check or not. 29 S MAGNOCHK=+$G(NOCHK) 30 S MAGXX=IEN D INFO^MAGGTII ; this'll give us the MAGFILE variable 31 S Z=$P(^MAG(2005,IEN,0),U,7) 32 I '$D(^DPT(Z)) S Z="1^Invalid patient pointer" 33 E S Z=Z_U_$P(^DPT(Z,0),U) 34 S MAGRY(0)="1^"_MAGFILE 35 S MAGRY(1)=Z ; dfn^name 36 Q 37 USERINF2(MAGRY,MAGWRKID) ;RPC [MAGGUSER2] Return user info. 38 ; MAGRY(1) = DUZ ^ FULL NAME ^ INITIALS 39 ; MAGRY(2) = Network UserName ^ PassWord. 40 ; MAGRY(3) = MUSE Site number. ( default = 1) 41 ; Node 4 is data from IMAGING SITE PARAMATERS File #2006.1 and INSTITUTION File #4 42 ; MAGRY(4)= PLACE IEN ^ SITE CODE ^ DUZ(2) ^ INSTITUTION NAME (.01) ^ $$CONSOLID ^ User's local STATION NUMBER (99) 43 ; MAGRY(5) = +<CP Version>|0 ^ Version of CP installed on Server 44 ; MAGRY(6) = Warning message if we can't resolve which Site Parameter entry to use. 45 ; MAGRY(7) = Warning message <reserved for future> 46 ; MAGRY(8) = 1|0 1 = Production account 0 = Test Account (or couldn't determine) ;Patch 41 47 ; MAGRY(9) = Vista Site Service PHYSICAL REFERENCE from Network Location File. 48 ; MAGRY(10)=Domain Name 49 ; MAGRY(11)=Primary Division IEN 50 ; MAGRY(12)=Primary Division STATION NUMBER 51 ; 52 N J,K,Y,MAGPLC,MAGWARN,MAGWARN1,VSRV,PHYREF ; DBI - SEB 9/20/2002 53 S MAGPLC=0 54 I $D(DUZ(2)) S MAGPLC=+$$PLACE^MAGBAPI(DUZ(2)) ; DBI - SEB 9/20/2002 55 ; 56 ; SET THE PARTITION VARIABLE MAGSYS i.e.'IGK_Garrett's Desk' 57 S MAGSYS=$G(MAGWRKID,"") 58 I +$G(DUZ)=0 S MAGRY(0)="0^DUZ Undefined, Null or Zero" Q 59 I 'MAGPLC D 60 . S MAGWARN="Can't resolve Site Param, DUZ(2): "_$S($D(DUZ(2)):DUZ(2),1:"NULL")_" DUZ: "_DUZ 61 . S MAGPLC=$$DUZ2PLC^MAGBAPIP(.MAGWARN1) ; DBI - SEB 9/20/2002 62 . Q 63 S MAGRY(0)="1^" 64 ; DUZ FULL NAME INITIALS 65 S MAGRY(1)=DUZ_U_$$GET1^DIQ(200,DUZ_",",.01)_U_$$GET1^DIQ(200,DUZ_",",1) 66 ; NOW NET STUFF 67 I 'MAGPLC Q 68 ; From IMAGING SITE PARAMETERS File 69 ; get the Network UserName and PassWord. 70 S MAGRY(2)=$P($G(^MAG(2006.1,MAGPLC,"NET")),U,1,2) 71 ; get the default MUSE Site number. 72 S MAGRY(3)=+$P($G(^MAG(2006.1,MAGPLC,"USERPREF")),U,2) 73 ; default to 1 if nothing is entered in Site Parameters File 74 I MAGRY(3)=0 S MAGRY(3)=1 75 ; This SITEIEN^SITECODE^USER INSTITUTION IEN^INSTITUTION NAME^CONSOLIDATED^User's local STATION NUMBER 76 ; is used by Display to determine location of Workstation 77 ; and used by Capture to determine the Write Location. 78 S MAGRY(4)=MAGPLC_U_$$GET1^DIQ(2006.1,MAGPLC,.09)_U_$G(DUZ(2))_U_$$GET1^DIQ(2006.1,MAGPLC,.01,"E") 79 S MAGJOB("PLC")=MAGPLC 80 S MAGJOB("PLCODE")=$$GET1^DIQ(2006.1,MAGPLC,.09) 81 S MAGRY(4)=MAGRY(4)_U_$$CONSOLID^MAGBAPI_U_$$GET1^DIQ(4,DUZ(2),99,"E") 82 ; is CP not installed at this site, the Client will hide options 83 ; related to CP. 84 S X=$$VERSION^XPDUTL("CLINICAL PROCEDURES") 85 S MAGRY(5)=+X_U_X 86 S MAGRY(6)=$G(MAGWARN) 87 S MAGRY(7)=$G(MAGWARN1) 88 S MAGRY(8)=$S($L($T(PROD^XUPROD)):+$$PROD^XUPROD,1:0) 89 S VSRV=$P($G(^MAG(2006.1,MAGPLC,"NET")),"^",5) 90 I VSRV I +$P($G(^MAG(2005.2,VSRV,0)),"^",6) S PHYREF=$P($G(^MAG(2005.2,VSRV,0)),"^",2) 91 S MAGRY(9)=$G(PHYREF) 92 S MAGRY(10)=$$KSP^XUPARAM("WHERE") 93 S MAGRY(11)=$P($$SITE^VASITE(),"^") 94 S MAGRY(12)=$P($$SITE^VASITE(),"^",3) 95 Q 96 ; 97 CATEGORY(MAGRY) ; RPC [MAGGDESCCAT] Call to return Mag Descriptive Categories in array 98 ; for listing in a list box. 99 N I,K,CT,Y 100 S I=0,CT=0 101 I '$D(^MAG(2005.81)) D Q 102 . S MAGRY(0)="0^ERROR Mag Descriptive Category File doesn't exist" 103 F S I=$O(^MAG(2005.81,"B",I)) Q:I="" D 104 . ;Next line adds ADMIN, CLIN 3rd piece of the data returned 105 . S K=$O(^MAG(2005.81,"B",I,"")),CT=CT+1 106 . S MAGRY(CT)=I_U_K_U_$P(^MAG(2005.81,K,0),U,2) 107 S MAGRY(0)=CT_"^Categories on file" 108 Q 109 USERKEYS(MAGKEY) ; RPC [MAGGUSERKEYS] 110 ; Call to return an array of IMAGING Security Keys 111 D USERKEYS^MAGGTU31(.MAGKEY) 112 Q 113 MAIL(MAGRY,MAGFILE,MAGIEN) ;RPC [MAGG OFFLINE IMAGE ACCESSED] 114 ; Called to log an Offline Image accessed. 115 ; ^MAGQUEUE(2006.033,0) = OFFLINE IMAGES 116 ; User must edit 2006.033 by hand to mark images as OFFLINE. 117 ; 118 N FILEREF,PLATTER,A 119 S MAGRY="0^Error : logging access to Off-Line Image" 120 N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" 121 S FILEREF=$$UP^XLFSTR($P(MAGFILE,"\",$L(MAGFILE,"\"))) 122 S PLATTER=$O(^MAGQUEUE(2006.033,"B",FILEREF,"")) 123 S PLATTER=$P(^MAGQUEUE(2006.033,PLATTER,0),U,2) 124 I MAGFILE[".ABS" Q 125 N XMDUZ,XMSUB,XMTEXT,XMY 126 S XMDUZ=$S($D(DUZ):DUZ,1:.5) 127 S XMSUB="Offline Image Request" 128 S XMTEXT="A(" 129 S A(1)="Patient : "_$P(^DPT($P($G(^MAG(2005,+MAGIEN,0)),U,7),0),U,1) 130 S A(2)="FileName : "_MAGFILE_" "_MAGIEN 131 S A(3)="Desc : "_$P($G(^MAG(2005,MAGIEN,2)),U,4) 132 S A(4)="Procedure : "_$P($G(^MAG(2005,MAGIEN,0)),U,8) 133 S A(5)="Platter : "_PLATTER 134 S A(6)="User : "_$$GET1^DIQ(200,DUZ_",",.01)_"("_$G(DUZ)_")" 135 S XMY("G.OFFLINE IMAGE TRACKERS")="" D ^XMD 136 S MAGRY="1^Message sent : Offline Image Accessed" 137 Q 138 LOGERROR(MAGRY,TEXT) ;RPC [MAGG LOG ERROR TEXT] 139 ; Call to stuff error information from Delphi app into the Session file. 140 Q:($P($G(MAGJOB("VERSION")),".",1,2))<"3.0" 141 D LOGERR^MAGGTERR("---- New Error ----") 142 S I="" F S I=$O(TEXT(I)) Q:I="" D LOGERR^MAGGTERR(TEXT(I)) 143 S MAGRY="1^Error text saved to Session file" 144 Q 145 RSLVABS(MAGIEN,FILENAME) ;Resolve Abstract into the Default Bitmap 146 ; Return the default bitmap, If the image file extension resolves into a default bitmap 147 ; MAGIEN : Image internal entry number 148 ; FILENAME : "" or Relative Path and Default Bitmap. ie ('.\BMP\magavi.bmp') 149 N FTIEN,EXT ; 150 S FILENAME="" 151 I '$D(^MAG(2005.021)) Q ; IMAGE FILE TYPES doesn't exist on this system. 152 S EXT=$P($P(^MAG(2005,MAGIEN,0),"^",2),".",2) ; image file extension JPG, TGA, etc. 153 Q:EXT="" ; 154 S FTIEN=$O(^MAG(2005.021,"B",EXT,"")) 155 Q:'FTIEN ; No extension in IMAGE FILE TYPES file. 156 ; stop dependency on "c:\program files" 157 I '+$P(^MAG(2005.021,FTIEN,0),"^",5) S FILENAME=".\BMP\"_$P(^MAG(2005.021,FTIEN,0),"^",4) 158 Q 159 GETINFO(MAGRY,IEN) ; RPC [MAG4 GET IMAGE INFO] 160 ; Call (3.0p8) to get information on 1 image 161 ; and Display in the Image Information Window 162 D GETINFO^MAGGTU31(.MAGRY,IEN) 163 Q 1 MAGGTU3 ;WOIFO/GEK - Silent calls for Imaging ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;**7,8,48,45,20,46**;16-February-2007;;Build 1023 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 ;; | 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 Q 19 IMAGEINF(MAGRY,IEN,NOCHK) ;RPC [MAGG IMAGE INFO] Call to return information for 1 image; 20 ; IEN = Image IEN ^MAG(2005,IEN 21 ; NOCHK = If Flag = 1, then do not run QA check on this image. 22 ; 23 N MAGFILE,Y,Z,MAGNOCHK 24 I '$D(^MAG(2005,IEN)) D Q 25 . I $D(^MAG(2005.1,IEN)) S MAGRY(0)="0^Image : """_$P($G(^MAG(2005.1,IEN,2)),U,4)_""" has been deleted." Q 26 . S MAGRY(0)="0^INVALID Image number "_IEN 27 . Q 28 ; MAGGTII queries the variable MAGNOCHK to run QA check or not. 29 S MAGNOCHK=+$G(NOCHK) 30 S MAGXX=IEN D INFO^MAGGTII ; this'll give us the MAGFILE variable 31 S Z=$P(^MAG(2005,IEN,0),U,7) 32 I '$D(^DPT(Z)) S Z="1^Invalid patient pointer" 33 E S Z=Z_U_$P(^DPT(Z,0),U) 34 S MAGRY(0)="1^"_MAGFILE 35 S MAGRY(1)=Z ; dfn^name 36 Q 37 USERINF2(MAGRY,MAGWRKID) ;RPC [MAGGUSER2] Return user info. 38 ; MAGRY(1) = DUZ ^ FULL NAME ^ INITIALS 39 ; MAGRY(2) = Network UserName ^ PassWord. 40 ; MAGRY(3) = MUSE Site number. ( default = 1) 41 ; Node 4 is data from IMAGING SITE PARAMATERS File #2006.1 and INSTITUTION File #4 42 ; MAGRY(4)= PLACE IEN ^ SITE CODE ^ DUZ(2) ^ INSTITUTION NAME (.01) ^ $$CONSOLID ^ User's local STATION NUMBER (99) 43 ; MAGRY(5) = +<CP Version>|0 ^ Version of CP installed on Server 44 ; MAGRY(6) = Warning message if we can't resolve which Site Parameter entry to use. 45 ; MAGRY(7) = Warning message <reserved for future> 46 ; MAGRY(8) = 1|0 1 = Production account 0 = Test Account (or couldn't determine) ;Patch 41 47 ; MAGRY(9) = Vista Site Service PHYSICAL REFERENCE from Network Location File. 48 ; MAGRY(10)=Domain Name 49 ; MAGRY(11)=Primary Division IEN 50 ; MAGRY(12)=Primary Division STATION NUMBER 51 ; 52 N J,K,Y,MAGPLC,MAGWARN,MAGWARN1,VSRV,PHYREF ; DBI - SEB 9/20/2002 53 S MAGPLC=0 54 I $D(DUZ(2)) S MAGPLC=+$$PLACE^MAGBAPI(DUZ(2)) ; DBI - SEB 9/20/2002 55 ; 56 ; SET THE PARTITION VARIABLE MAGSYS i.e.'IGK_Garrett's Desk' 57 S MAGSYS=$G(MAGWRKID,"") 58 I +$G(DUZ)=0 S MAGRY(0)="0^DUZ Undefined, Null or Zero" Q 59 I 'MAGPLC D 60 . S MAGWARN="Can't resolve Site Param, DUZ(2): "_$S($D(DUZ(2)):DUZ(2),1:"NULL")_" DUZ: "_DUZ 61 . S MAGPLC=$$DUZ2PLC^MAGBAPIP(.MAGWARN1) ; DBI - SEB 9/20/2002 62 . Q 63 S MAGRY(0)="1^" 64 ; DUZ FULL NAME INITIALS 65 S MAGRY(1)=DUZ_U_$$GET1^DIQ(200,DUZ_",",.01)_U_$$GET1^DIQ(200,DUZ_",",1) 66 ; NOW NET STUFF 67 I 'MAGPLC Q 68 ; Get info from IMAGING SITE PARAMETERS File 69 ; get the Network UserName and PassWord. 70 S MAGRY(2)=$P($G(^MAG(2006.1,MAGPLC,"NET")),U,1,2) 71 ; get the default MUSE Site number. 72 S MAGRY(3)=+$P($G(^MAG(2006.1,MAGPLC,"USERPREF")),U,2) 73 ; default to 1 if nothing is entered in Site Parameters File 74 I MAGRY(3)=0 S MAGRY(3)=1 75 ; This SITEIEN^SITECODE^USER INSTITUTION IEN^INSTITUTION NAME^CONSOLIDATED^User's local STATION NUMBER 76 ; is used by Display to determine location of Workstation 77 ; and used by Capture to determine the Write Location. 78 S MAGRY(4)=MAGPLC_U_$$GET1^DIQ(2006.1,MAGPLC,.09)_U_$G(DUZ(2))_U_$$GET1^DIQ(2006.1,MAGPLC,.01,"E") 79 S MAGJOB("PLC")=MAGPLC 80 S MAGJOB("PLCODE")=$$GET1^DIQ(2006.1,MAGPLC,.09) 81 S MAGRY(4)=MAGRY(4)_U_$$CONSOLID^MAGBAPI_U_$$GET1^DIQ(4,DUZ(2),99,"E") 82 ; is CP installed at this site, the Front End will hide options 83 ; related to CP if not installed. 84 S X=$$VERSION^XPDUTL("CLINICAL PROCEDURES") 85 S MAGRY(5)=+X_U_X 86 S MAGRY(6)=$G(MAGWARN) 87 S MAGRY(7)=$G(MAGWARN1) 88 S MAGRY(8)=$S($L($T(PROD^XUPROD)):+$$PROD^XUPROD,1:0) 89 S VSRV=$P($G(^MAG(2006.1,MAGPLC,"NET")),"^",5) 90 I VSRV I +$P($G(^MAG(2005.2,VSRV,0)),"^",6) S PHYREF=$P($G(^MAG(2005.2,VSRV,0)),"^",2) 91 S MAGRY(9)=$G(PHYREF) 92 S MAGRY(10)=$$KSP^XUPARAM("WHERE") 93 S MAGRY(11)=$P($$SITE^VASITE(),"^") 94 S MAGRY(12)=$P($$SITE^VASITE(),"^",3) 95 Q 96 ; 97 CATEGORY(MAGRY) ; RPC [MAGGDESCCAT] Call to return Mag Descriptive Categories in array 98 ; for listing in a list box. 99 N I,K,CT,Y 100 S I=0,CT=0 101 I '$D(^MAG(2005.81)) D Q 102 . S MAGRY(0)="0^ERROR Mag Descriptive Category File doesn't exist" 103 F S I=$O(^MAG(2005.81,"B",I)) Q:I="" D 104 . ;Next line adds ADMIN, CLIN 3rd piece of the data returned 105 . S K=$O(^MAG(2005.81,"B",I,"")),CT=CT+1 106 . S MAGRY(CT)=I_U_K_U_$P(^MAG(2005.81,K,0),U,2) 107 S MAGRY(0)=CT_"^Categories on file" 108 Q 109 USERKEYS(MAGKEY) ; RPC [MAGGUSERKEYS] 110 ; Call to return an array of IMAGING Security Keys 111 D USERKEYS^MAGGTU31(.MAGKEY) 112 Q 113 MAIL(MAGRY,MAGFILE,MAGIEN) ;RPC [MAGG OFFLINE IMAGE ACCESSED] 114 ; Called to log an Offline Image accessed. 115 ; ^MAGQUEUE(2006.033,0) = OFFLINE IMAGES 116 ; User must edit 2006.033 by hand to mark images as OFFLINE. 117 ; 118 N FILEREF,PLATTER,A 119 S MAGRY="0^Error : logging access to Off-Line Image" 120 N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" 121 S FILEREF=$$UP^XLFSTR($P(MAGFILE,"\",$L(MAGFILE,"\"))) 122 S PLATTER=$O(^MAGQUEUE(2006.033,"B",FILEREF,"")) 123 S PLATTER=$P(^MAGQUEUE(2006.033,PLATTER,0),U,2) 124 I MAGFILE[".ABS" Q 125 N XMDUZ,XMSUB,XMTEXT,XMY 126 S XMDUZ=$S($D(DUZ):DUZ,1:.5) 127 S XMSUB="Offline Image Request" 128 S XMTEXT="A(" 129 S A(1)="Patient : "_$P(^DPT($P($G(^MAG(2005,+MAGIEN,0)),U,7),0),U,1) 130 S A(2)="FileName : "_MAGFILE_" "_MAGIEN 131 S A(3)="Desc : "_$P($G(^MAG(2005,MAGIEN,2)),U,4) 132 S A(4)="Procedure : "_$P($G(^MAG(2005,MAGIEN,0)),U,8) 133 S A(5)="Platter : "_PLATTER 134 S A(6)="User : "_$$GET1^DIQ(200,DUZ_",",.01)_"("_$G(DUZ)_")" 135 S XMY("G.OFFLINE IMAGE TRACKERS")="" D ^XMD 136 S MAGRY="1^Message sent : Offline Image Accessed" 137 Q 138 LOGERROR(MAGRY,TEXT) ;RPC [MAGG LOG ERROR TEXT] 139 ; Call to stuff error information from Delphi app into the Session file. 140 Q:($P($G(MAGJOB("VERSION")),".",1,2))<"3.0" 141 D LOGERR^MAGGTERR("---- New Error ----") 142 S I="" F S I=$O(TEXT(I)) Q:I="" D LOGERR^MAGGTERR(TEXT(I)) 143 S MAGRY="1^Error text saved to Session file" 144 Q 145 RSLVABS(MAGIEN,FILENAME) ;Resolve Abstract into the Default Bitmap 146 ; Return the default bitmap, If the image file extension resolves into a default bitmap 147 ; MAGIEN : Image internal entry number 148 ; FILENAME : "" or Relative Path and Default Bitmap. ie ('.\BMP\magavi.bmp') 149 N FTIEN,EXT ; 150 S FILENAME="" 151 I '$D(^MAG(2005.021)) Q ; IMAGE FILE TYPES doesn't exist on this system. 152 S EXT=$P($P(^MAG(2005,MAGIEN,0),"^",2),".",2) ; image file extension JPG, TGA, etc. 153 Q:EXT="" ; 154 S FTIEN=$O(^MAG(2005.021,"B",EXT,"")) 155 Q:'FTIEN ; No extension in IMAGE FILE TYPES file. 156 ; stop dependency on "c:\program files" 157 I '+$P(^MAG(2005.021,FTIEN,0),"^",5) S FILENAME=".\BMP\"_$P(^MAG(2005.021,FTIEN,0),"^",4) 158 Q 159 GETINFO(MAGRY,IEN) ; RPC [MAG4 GET IMAGE INFO] 160 ; Call (3.0p8) to get information on 1 image 161 N Y,J,JI,I,CT,IENC,FLAGS,SNGRP,Z,M40,T,QACHK 162 S I=0,CT=0 163 S MAGRY(CT)="Image ID#: "_IEN 164 I $D(^MAG(2005.1,IEN)) D Q 165 . S CT=CT+1,MAGRY(CT)=" STATUS: "_"HAS BEEN DELETED. !!" 166 . S CT=CT+1,MAGRY(CT)="Deleted By: "_$$GET1^DIQ(2005.1,IEN,30,"E") 167 . S CT=CT+1,MAGRY(CT)=" Reason: "_$$GET1^DIQ(2005.1,IEN,30.2,"E") 168 . S CT=CT+1,MAGRY(CT)=" Date: "_$$GET1^DIQ(2005.1,IEN,30.1,"E") 169 . Q 170 S M40=$G(^MAG(2005,IEN,40)),T=$P(M40,"^",3) 171 S Z=$P($G(^MAG(2005,IEN,0)),"^",10) I Z D 172 . S CT=CT+1,MAGRY(CT)=" is in Group#: "_Z_" ("_+$P(^MAG(2005,Z,1,0),"^",4)_" images)" 173 . D CHK^MAGGSQI(.QACHK,Z) Q:QACHK(0) 174 . S CT=CT+1,MAGRY(CT)=" QA Warning - Group#: "_Z_" "_$P(QACHK(0),"^",2) 175 . Q 176 S SNGRP="FLDS" 177 I (+$O(^MAG(2005,IEN,1,0)))!($P(^MAG(2005,IEN,0),"^",6)=11)!($P(^MAG(2005,IEN,0),"^",6)=16) D 178 . S CT=CT+1,MAGRY(CT)=$P(^MAG(2005,IEN,0),"^",8)_" Group of "_+$P($G(^MAG(2005,IEN,1,0)),U,4) 179 . S SNGRP="FLDG" 180 . Q 181 K QACHK 182 D CHK^MAGGSQI(.QACHK,IEN) I 'QACHK(0) D 183 . S CT=CT+1,MAGRY(CT)=" QA Warning - Image#: "_IEN_" "_$P(QACHK(0),"^",2) 184 N MAGOUT,MAGERR,MAGVAL 185 S IENC=IEN_"," 186 S FLAGS="EN" 187 S I=-1 188 F S I=I+1,Z=$T(@SNGRP+I) Q:$P(Z,";",3)="end" D 189 . S J=$P(Z,";",4),JI=J_";" 190 . K MAGOUT 191 . S CT=CT+1,MAGRY(CT)=$P(Z,";",3) 192 . I J=41 D Q ; Need to compute the Class. Class field in Image File is wrong. 193 . . S MAGVAL=$S('T:"",'$D(^MAG(2005.83,T,0)):"",1:$P(^MAG(2005.82,$P(^MAG(2005.83,T,0),"^",2),0),"^",1)) 194 . . S MAGRY(CT)=MAGRY(CT)_" "_MAGVAL 195 . . Q 196 . D GETS^DIQ(2005,IEN,JI,FLAGS,"MAGOUT","MAGERR") 197 . ; Get Extension from FileRef 198 . I J=1 S MAGVAL=$P($G(MAGOUT(2005,IENC,J,"E")),".",2) 199 . E S MAGVAL=$G(MAGOUT(2005,IENC,J,"E")) 200 . S MAGRY(CT)=MAGRY(CT)_" "_MAGVAL 201 ; Compare Parent Association Date with Date/Time Note Signed. 202 I $P(^MAG(2005,IEN,0),"^",10) S IEN=$P(^MAG(2005,IEN,0),"^",10) 203 I $P(^MAG(2005,IEN,2),"^",6)=8925 S CT=CT+1,MAGRY(CT)=$$ATTSTAT^MAGGTU31(IEN) 204 Q 205 ; 206 FLDS ;;Format: ;3;; 207 ;;Extension: ;1;; 208 FLDG ;;Patient: ;5;; 209 ;;Desc: ;10;; 210 ;;Procedure: ;6;; 211 ;; Date: ;15;; 212 ;;Class: ;41;; 213 ;;Package: ;40;; 214 ;;Type: ;42;; 215 ;;Proc/Event: ;43;; 216 ;;Spec/SubSpec: ;44;; 217 ;;Origin: ;45;; 218 ;;Captured on: ;7;; 219 ;; by: ;8;; 220 ;;end;; -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGTU31.m
r613 r623 1 MAGGTU31 ;WOIFO/GEK - Silent calls for Imaging ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;**46,59**;Nov 27, 2007;Build 20 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 ATTSTAT(IEN) ; Return a sentence saying if the Image was attached 21 ; to the TIU NOte before or after the Note was signed. 22 ; was signed. 23 N SIGNDT,NOTE,MARR,AMMEND,N2,MAGDT,NC,CLOSDT,X 24 S N2=$G(^MAG(2005,IEN,2)) 25 I $P(N2,"^",6)'=8925 Q "" 26 S MAGDT=$S($P(N2,"^",11):$P(N2,"^",11),1:$P(N2,"^",1)) 27 S NOTE=$P(N2,"^",7) 28 S NC=NOTE_"," 29 D GETS^DIQ(8925,NOTE,".01;.06;1501;1606","I","MARR") 30 I $D(DIERR) Q "Error: Note-"_NOTE_" : "_$G(^TMP("DIERR",$J,1,"TEXT",1)) 31 I (MARR(8925,NC,".01","I")=81)!(MARR(8925,NC,".06","I")>0) Q "Image is attached to an Addendum" 32 S SIGNDT=MARR(8925,NC,"1501","I") 33 S CLOSDT=MARR(8925,NC,"1606","I") 34 I CLOSDT]"" D Q X 35 . I $P(CLOSDT,".",2)="" S MAGDT=$P(MAGDT,".",1) I MAGDT=CLOSDT S X="Image was attached Same Day as Note was Electronically Filed." Q 36 . I MAGDT>CLOSDT S X="Image was attached After Note was Electronically Filed." Q 37 . S X="Image was attached Before Note was Electronically Filed." Q 38 . Q 39 I SIGNDT="" Q "Image is attached to an UnSigned Note." 40 I $P(SIGNDT,".",2)="" S MAGDT=$P(MAGDT,".",1) I MAGDT=SIGNDT Q "Image was attached Same Day as Note was Signed." 41 I MAGDT>SIGNDT Q "Image was attached After the Note was Signed." 42 Q "Image was attached Before the Note was Signed." 43 USERKEYS(MAGK) ; RPC [MAGGUSERKEYS] (called from MAGGTU3) 44 N Y 45 N MAGKS ; list of keys to send to XUS KEY CHECK 46 N MAGKG ; list returned from XUS KEY CHECK 47 N I,J,MAGMED,MAGKEY,MAGPLC 48 K MAGK 49 S MAGPLC=+$$PLACE^MAGBAPI(DUZ(2)) ; DBI - SEB 9/20/2002 50 S MAGKEY=+$P($G(^MAG(2006.1,MAGPLC,"KEYS")),U) 51 I 'MAGKEY S MAGK(0)="CAPTURE KEYS OFF" 52 E S MAGK(0)="CAPTURE KEYS ON" 53 N X S X="MAG",I=0 54 F S X=$O(^XUSEC(X)) Q:$E(X,1,3)'="MAG" D 55 . S I=I+1,MAGKS(I)=X 56 D OWNSKEY^XUSRB(.MAGKG,.MAGKS) 57 S I=0,J=0,MAGMED=0 58 F S I=$O(MAGKG(I)) Q:I="" D 59 . Q:MAGKG(I)=0 60 . S J=J+1,MAGK(J)=MAGKS(I) 61 . I MAGKS(I)["MAGCAP MED" S MAGMED=1 62 I MAGMED S J=J+1,MAGK(J)="MAGCAP MED" 63 Q 64 GETINFO(MAGRY,IEN) ; RPC [MAG4 GET IMAGE INFO]Called from MAGGTU3 65 ; Call (3.0p8) to get information on 1 image 66 ; and Display in the Image Information Window 67 N Y,J,JI,I,CT,IENC,FLAGS,SNGRP,Z,M40,T,QACHK,OBJTYP,VAL,LBL 68 S I=0,CT=0 69 S MAGRY(CT)="Image ID#: "_IEN 70 I $D(^MAG(2005.1,IEN)) D Q 71 . S CT=CT+1,MAGRY(CT)=" STATUS: "_"HAS BEEN DELETED. !!" 72 . S CT=CT+1,MAGRY(CT)="Deleted By: "_$$GET1^DIQ(2005.1,IEN,30,"E") 73 . S CT=CT+1,MAGRY(CT)=" Reason: "_$$GET1^DIQ(2005.1,IEN,30.2,"E") 74 . S CT=CT+1,MAGRY(CT)=" Date: "_$$GET1^DIQ(2005.1,IEN,30.1,"E") 75 . Q 76 S M40=$G(^MAG(2005,IEN,40)),T=$P(M40,"^",3) 77 S Z=$P($G(^MAG(2005,IEN,0)),"^",10) I Z D 78 . S CT=CT+1,MAGRY(CT)=" is in Group#: "_Z_" ("_+$P(^MAG(2005,Z,1,0),"^",4)_" images)" 79 . D CHK^MAGGSQI(.QACHK,Z) Q:QACHK(0) 80 . S CT=CT+1,MAGRY(CT)=" QA Warning - Group#: "_Z_" "_$P(QACHK(0),"^",2) 81 . Q 82 S OBJTYP=$P(^MAG(2005,IEN,0),"^",6) 83 S SNGRP="FLDS" 84 I (+$O(^MAG(2005,IEN,1,0)))!(OBJTYP=11)!(OBJTYP=16) D 85 . S CT=CT+1,MAGRY(CT)=$P($G(^MAG(2005,IEN,40)),"^",1)_" Group of "_+$P($G(^MAG(2005,IEN,1,0)),U,4) 86 . S SNGRP="FLDG" 87 . Q 88 K QACHK 89 D CHK^MAGGSQI(.QACHK,IEN) I 'QACHK(0) D 90 . S CT=CT+1,MAGRY(CT)=" QA Warning - Image#: "_IEN_" "_$P(QACHK(0),"^",2) 91 N MAGOUT,MAGERR,MAGVAL,PKG 92 S IENC=IEN_"," 93 S FLAGS="EN" 94 S I=-1 95 S PKG="" 96 F S I=I+1,Z=$T(@SNGRP+I) Q:$P(Z,";",3)="end" D 97 . S J=$P(Z,";",4),JI=J_";" 98 . K MAGOUT 99 . S CT=CT+1,MAGRY(CT)=$P(Z,";",3) 100 . I J=41 D Q ; Need to compute the Class. Class field in Image File is wrong. 101 . . S MAGVAL=$S('T:"",'$D(^MAG(2005.83,T,0)):"",1:$P(^MAG(2005.82,$P(^MAG(2005.83,T,0),"^",2),0),"^",1)) 102 . . S MAGRY(CT)=MAGRY(CT)_" "_MAGVAL 103 . . Q 104 . D GETS^DIQ(2005,IEN,JI,FLAGS,"MAGOUT","MAGERR") 105 . ; Get Extension from FileRef 106 . I J=1 S MAGVAL=$P($G(MAGOUT(2005,IENC,J,"E")),".",2) 107 . E S MAGVAL=$G(MAGOUT(2005,IENC,J,"E")) 108 . S MAGVAL=$TR(MAGVAL,"&","+") 109 . I J=40 S PKG=MAGVAL 110 . I ((J>=50)&(J<=54)) D Q 111 . . I PKG'="LAB" K MAGRY(CT) Q 112 . . S MAGRY(CT)=MAGRY(CT)_" "_MAGVAL 113 . . Q 114 . S MAGRY(CT)=MAGRY(CT)_" "_MAGVAL 115 ; Compare Parent Association Date with Date/Time Note Signed. 116 I $P(^MAG(2005,IEN,0),"^",10) S IEN=$P(^MAG(2005,IEN,0),"^",10) 117 I $P(^MAG(2005,IEN,2),"^",6)=8925 S CT=CT+1,MAGRY(CT)=$$ATTSTAT^MAGGTU31(IEN) 118 ; 119 I (OBJTYP=11),($P($G(^MAG(2005,IEN,100)),"^",6)="") D 120 . S X=$O(^MAG(2005,IEN,1,0)) 121 . S IEN=+$G(^MAG(2005,IEN,1,X,0)) 122 . Q 123 I $P($G(^MAG(2005,IEN,100)),"^",6)]"" D 124 . I OBJTYP=11 D ; If a Group, get Object Type of First Child 125 . . S Z=$O(^MAG(2005,IEN,1,0)) 126 . . I 'Z Q 127 . . S Z=+$G(^MAG(2005,IEN,1,Z,0)) 128 . . S OBJTYP=+$P($G(^MAG(2005,Z,0)),"^",6) ; Object of First Child 129 . . Q 130 . S OBJTYP=","_OBJTYP_"," 131 . S LBL="",VAL="" 132 . I ",3,9,10,12,100,"[OBJTYP S LBL="Image Creation Date: " ; "Acquisition Date"; 133 . I ",15,101,102,103,104,105,"[OBJTYP S LBL="Document Creation Date: " 134 . I LBL="" S LBL="Image Creation Date: " 135 . S VAL=$$GET1^DIQ(2005,IEN,110,"E") S:(VAL="") VAL="N/A" 136 . S CT=CT+1,MAGRY(CT)=LBL_VAL 137 . Q 138 Q 139 ; 140 FLDS ;;Format: ;3;; 141 ;;Extension: ;1;; 142 FLDG ;;Patient: ;5;; 143 ;;Desc: ;10;; 144 ;;Procedure: ;6;; 145 ;; Date: ;15;; 146 ;;Class: ;41;; 147 ;;Package: ;40;; 148 ;;Type: ;42;; 149 ;;Proc/Event: ;43;; 150 ;;Spec/SubSpec: ;44;; 151 ;;Origin: ;45;; 152 ;;Accession # ;50;; 153 ;;Specimen Desc ;51;; 154 ;;Specimen# ;52;; 155 ;;Stain ;53;; 156 ;;Objective ;54;; 157 ;;Captured on: ;7;; 158 ;; by: ;8;; 159 ;;end;; 1 MAGGTU31 ;WOIFO/GEK - Silent calls for Imaging ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;**46**;16-February-2007;;Build 1023 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 ;; | 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 Q 19 ATTSTAT(IEN) ; Return a sentence saying if the Image was attached 20 ; to the TIU NOte before or after the Note was signed. 21 ; was signed. 22 N SIGNDT,NOTE,MARR,AMMEND,N2,MAGDT,NC,CLOSDT,X 23 S N2=$G(^MAG(2005,IEN,2)) 24 I $P(N2,"^",6)'=8925 Q "" 25 S MAGDT=$S($P(N2,"^",11):$P(N2,"^",11),1:$P(N2,"^",1)) 26 S NOTE=$P(N2,"^",7) 27 S NC=NOTE_"," 28 D GETS^DIQ(8925,NOTE,".01;.06;1501;1606","I","MARR") 29 I $D(DIERR) Q "Error: Note-"_NOTE_" : "_$G(^TMP("DIERR",$J,1,"TEXT",1)) 30 I (MARR(8925,NC,".01","I")=81)!(MARR(8925,NC,".06","I")>0) Q "Image is attached to an Addendum" 31 S SIGNDT=MARR(8925,NC,"1501","I") 32 S CLOSDT=MARR(8925,NC,"1606","I") 33 I CLOSDT]"" D Q X 34 . I $P(CLOSDT,".",2)="" S MAGDT=$P(MAGDT,".",1) I MAGDT=CLOSDT S X="Image was attached Same Day as Note was Electronically Filed." Q 35 . I MAGDT>CLOSDT S X="Image was attached After Note was Electronically Filed." Q 36 . S X="Image was attached Before Note was Electronically Filed." Q 37 . Q 38 I SIGNDT="" Q "Image is attached to an UnSigned Note." 39 I $P(SIGNDT,".",2)="" S MAGDT=$P(MAGDT,".",1) I MAGDT=SIGNDT Q "Image was attached Same Day as Note was Signed." 40 I MAGDT>SIGNDT Q "Image was attached After the Note was Signed." 41 Q "Image was attached Before the Note was Signed." 42 USERKEYS(MAGK) ; RPC [MAGGUSERKEYS] (called from MAGGTU3) 43 N Y 44 N MAGKS ; list of keys to send to XUS KEY CHECK 45 N MAGKG ; list returned from XUS KEY CHECK 46 N I,J,MAGMED,MAGKEY,MAGPLC 47 K MAGK 48 S MAGPLC=+$$PLACE^MAGBAPI(DUZ(2)) ; DBI - SEB 9/20/2002 49 S MAGKEY=+$P($G(^MAG(2006.1,MAGPLC,"KEYS")),U) 50 I 'MAGKEY S MAGK(0)="CAPTURE KEYS OFF" 51 E S MAGK(0)="CAPTURE KEYS ON" 52 N X S X="MAG",I=0 53 F S X=$O(^XUSEC(X)) Q:$E(X,1,3)'="MAG" D 54 . S I=I+1,MAGKS(I)=X 55 D OWNSKEY^XUSRB(.MAGKG,.MAGKS) 56 S I=0,J=0,MAGMED=0 57 F S I=$O(MAGKG(I)) Q:I="" D 58 . Q:MAGKG(I)=0 59 . S J=J+1,MAGK(J)=MAGKS(I) 60 . I MAGKS(I)["MAGCAP MED" S MAGMED=1 61 I MAGMED S J=J+1,MAGK(J)="MAGCAP MED" 62 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGTU4.m
r613 r623 1 MAGGTU4 ;WOIFO/GEK - Imaging Client- Version checking routine; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;**8,48,63,45,46,59,96**;April 29, 2008;Build 9 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 ;; | 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 Q 19 GETVER(SVRVER,SVRTVER,A) ; 20 ; We Can't compute the Server's current version 21 ; KIDS installs aren't all related to the Delphi Client. 22 ; The Server Version SVRVER needs hardcoded to match the Delphi Client. 23 ; and This Routine must be distributed whenever a new Client is 24 S SVRVER="3.0.96" 25 S SVRTVER="4" ; This is the T version that the server expects 26 ; released Client will have the T version that the server expects 27 S A("3.0.24")=5 ;Sept 2003 28 S A("3.0.33")=11 ;June 2004 29 S A("3.0.8")=49 ;Sept 2004 30 S A("3.0.42")=1 ;n/a 31 S A("3.0.48")=6 ;Mar 2005 32 S A("3.0.63")=4 ;June 2005 33 S A("3.0.45")=8 ;Sept 2005 34 S A("3.0.46")=28 ;Mar 2007 35 S A("3.0.59")=31 ;Jul 2007 36 S A("3.0.72")=21 ;Jan 2008 37 S A("3.0.83")=24 ;Mar 2008 38 S A("3.0.95")=5 ;Mar 2008 39 S A("3.0.96")=4 ;Apr 2008 40 Q 41 ; 42 CHKVER(MAGRY,CLVER) ;RPC [MAG4 VERSION CHECK] 43 ; CLVER is the version of the Delphi Client. 44 ; CLVER format = Major.Minor.Patch.T-version 45 ; example : for Version 3.0 Patch 8 T 21 --> CLVER=3.0.8.21 46 ; Ver 2.5P9 (2.5.24.1) is first Delphi Ver that makes this call. 47 ; CLVER may have Parameters attached to it in '|' pieces. 48 ; "CLVER|RIV" this is a remote image view client 49 ; "CLVER|CAPTURE" this is a Capture Client 50 ; "CLVER|DISPLAY" this is a Display Client 51 ; 3 possible return codes in 1st '^' piece of MAGRY(0). 52 ; 0^message : The Client will display the message and continue. 53 ; 1^message : The Client will continue without displaying any message. 54 ; 2^message : The Client will display the message and then Abort. (Terminate) 55 ; The message displayed is the 2nd '^' piece of (0) node 56 ; and all text of any other nodes. i.e. MAGRY(1..n) 57 ; 58 S CLVER=$G(CLVER) 59 ; Bug in 42. the Version comes in as 30.5.42.x (42 wasn't released) 60 I $P(CLVER,".",1)="30" S CLVER="3.0."_$P(CLVER,".",3,99) 61 ; 62 N PLC,SV,ST,SVSTAT,CV,CP,CT,OKVER,WARN,I,BETA 63 ; PLC = Entry in 2006.1 64 ; SV = Server Version -> (3.0.8) from (3.0.8.43) Hard coded to Sync with Delphi Clients 65 ; ST = Server T Version -> 43 from full version (3.0.8.43) 66 ; CV = Client Version sent from Client 3.0.8 same format as SV 67 ; CT = Client T Version sent from Client i.e. 43 same format as ST 68 ; OKVER = Array of Supported Versions, and Released T Version OKVER(3.0.48)=6 69 ; WARN = 1|0 Boolean value determines if client needs EKG Warning. 70 ; 71 S PLC=$$PLACE^MAGBAPI($G(DUZ(2))) 72 ; Quit if we don't have a valid DUZ(2) or valid PLACE: ^MAG(2006.1,PLC) 73 I 'PLC D BADPLC^MAGGTU41(.MAGRY) Q 74 ; 75 ; Set up local variables. 76 D GETVER(.SV,.ST,.OKVER) 77 F I=2:1:$L(CLVER,"|") I $P(CLVER,"|",I)]"" S MAGJOB($P(CLVER,"|",I))=1 78 S CLVER=$P(CLVER,"|",1) 79 S CV=$P(CLVER,".",1,3),CP=$P(CLVER,".",3),CT=$P(CLVER,".",4) 80 I CT="" S $P(CLVER,".",4)=0,CT=0 81 ; set WARN to indicate if Warning is needed or not. 82 ; 83 D NEEDWARN(.WARN) 84 ; Quit if site has VERSION CHECKING=0 (OFF) in Imaging Site Params File. 85 I '$$VERCHKON(PLC) D Q 86 . S MAGRY(0)="1^Version Checking is OFF. Allowing All Versions" 87 . ; But, need to Display the warning, even if Version Checking is OFF 88 . I WARN S MAGRY(0)="0^ =========== WARNING ===============" D WARNING 89 . Q 90 ; If Remote Connection , allow it. 91 I $D(MAGJOB("RIV")) S MAGRY(0)="1^Allowing Remote Image Connection" Q 92 ; Is this Server Version Alpha/Beta or Released. 93 D VERSTAT(.SVSTAT,SV) 94 I 'SVSTAT S MAGRY(0)="2^"_$P(SVSTAT,"^",2) Q ; There is not record of a KIDS for this Server. 95 ; Set Alpha Beta Flag 96 S BETA=(+SVSTAT=2) 97 ; If Client isn't one of the Supported Clients. 98 I (CV'=SV),'$D(OKVER(CV)) D Q 99 . I BETA D NOTOKB^MAGGTU41(.MAGRY) Q 100 . D NOTOK^MAGGTU41(.MAGRY) Q 101 . Q 102 ; 103 ; Client is Supported. Only Warn if we are Not In ALPHA/BETA Testing. 104 I (CV'=SV) D Q 105 . I CT<$G(OKVER(CV)) D Q 106 . . I BETA DO OKBADTB^MAGGTU41(.MAGRY) Q 107 . . DO OKBADT^MAGGTU41(.MAGRY) Q 108 . . Q 109 . I BETA D OKB^MAGGTU41(.MAGRY) 110 . E D OK^MAGGTU41(.MAGRY) 111 . I WARN D WARNING 112 . Q 113 ; 114 ; At this point, Versions are the Same: If T versions are not, warn the Client. 115 I CT,(CT'=ST) D Q 116 . I BETA D TNOTOKB^MAGGTU41(.MAGRY) Q 117 . D TNOTOK^MAGGTU41(.MAGRY) Q 118 . Q 119 ; Client and Server Versions are the same, to the T. (Ha, get it) 120 S MAGRY(0)="1^Version Check OK. Server: "_SV_" Client: "_CV Q 121 Q 122 ; 123 VERCHKON(PLC) ; Is Version checking on for the site (Place) 124 Q +$P(^MAG(2006.1,PLC,"KEYS"),"^",5) 125 ; 126 NEEDWARN(WARN) ; This call determines if Client needs the warning. 127 S WARN=0 Q ; we don't need warning anymore. 128 I $P($G(^MAG(2006.1,PLC,"USERPREF")),U,2)="" S WARN=0 Q ; Not a MUSE Site. 129 I $D(MAGJOB("CAPTURE")) S WARN=0 Q ;Not needed for Capture Clients 130 I CV="3.0.59" S WARN=0 Q ; Client 59 has 63. 131 I CV="3.0.45" S WARN=0 Q ; Client 45 has 63. 132 I CV="3.0.41" S WARN=0 Q ; It is fixed in 41 133 I CV="3.0.63" S WARN=0 Q ; It is fixed in 63 134 I $P(CV,".",1)=2 S WARN=0 Q ;Older Clients don't have the EKG Problem. 135 I '$D(OKVER(CV)) S WARN=0 Q ; Patch 3.0.7, 3.0.2 don't have EKG problem. 136 S WARN=1 ; This means to Show the EKG Warning. 137 Q 138 ; 139 WARNING ; This is hard coded for the EKG Warning. 140 ; Put Warning at the End of any Return Message. 141 S MAGRY(1000)=" " 142 S MAGRY(1010)="!*************************************************!" 143 S MAGRY(1015)=" " 144 S MAGRY(1020)=" PATIENT SAFETY NOTIFICATION" 145 S MAGRY(1025)=" " 146 S MAGRY(1030)=" Under certain circumstances, the EKG window will not" 147 S MAGRY(1040)="refresh properly when you select a new patient in CPRS; " 148 S MAGRY(1050)="instead of showing the new patient, the EKG window will " 149 S MAGRY(1060)="continue to show the previous patient. " 150 S MAGRY(1065)=" " 151 S MAGRY(1070)="To prevent this problem:" 152 S MAGRY(1075)=" " 153 S MAGRY(1080)=" Verify that the 'Show MUSE EKGs' option under" 154 S MAGRY(1085)=" Options > View Preferences is checked;" 155 S MAGRY(1090)=" OR" 156 S MAGRY(1100)=" Do not minimize the Imaging Display window while viewing EKGs." 157 S MAGRY(1110)=" " 158 S MAGRY(1115)="This problem will be corrected shortly by Imaging Patch 63." 159 S MAGRY(1120)="!*************************************************!" 160 Q 161 VERSTAT(MAGRY,MAGVER) ;RPC - [MAG4 VERSION STATUS] 162 ; Returns the status of an Imaging Version 163 ; Input : 164 ; MAGVER - Version number 165 ; in the format MAG*3.0*59 166 ; or the format 3.0.59 167 ; Return: 168 ; MAGRY = 0^There is No KIDs Install record 169 ; 1^Unknown Release Status 170 ; 2^Alpha/Beta Version 171 ; 3^Released Version 172 ; 173 N VERI,TVER,MAGERR 174 I +MAGVER S MAGVER="MAG*"_$P(MAGVER,".",1,2)_"*"_$P(MAGVER,".",3) 175 S VERI=$$FIND1^DIC(9.6,"","MO",MAGVER,"","","MAGERR") 176 I 'VERI S MAGRY="0^There is No KIDs Install record for """_MAGVER_"""." Q 177 S TVER=$$GET1^DIQ(9.6,VERI_",","ALPHA/BETA TESTING") 178 I TVER="YES" S MAGRY="2^Alpha/Beta Version." Q 179 I TVER="NO" S MAGRY="3^Released Version." Q 180 S MAGRY="1^Unknown Release Status." 181 Q 182 ABSJB(MAGRY,MAGIN) ;RPC [MAG ABSJB] SET ABSTRACT AND/OR JUKEBOX QUEUES 183 D ABSJB^MAGGTU71(.MAGRY,.MAGIN) 184 Q 1 MAGGTU4 ;WOIFO/GEK - Testing callbacks for Delphi Doc Image Prototype ; 02/16/2007 13:37 2 ;;3.0;IMAGING;**8,48,63,45,46**;16-February-2007;;Build 1023 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 ;; | 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 Q 19 GETVER(SVRVER,SVRTVER,A) ; 20 ; We Can't compute the Server's current version 21 ; KIDS installs aren't all related to the Delphi Client. 22 ; The Server Version SVRVER needs hardcoded to match the Delphi Client. 23 ; and This Routine must be distributed whenever a new Client is 24 S SVRVER="3.0.46" 25 S SVRTVER=28 ; This is the T version that the server expects 26 ; released Client will have the T version that the server expects 27 S A("3.0.24")=5 ;Sept 2003 28 S A("3.0.33")=11 ;June 2004 29 S A("3.0.8")=49 ;Sept 2004 30 S A("3.0.42")=1 ;n/a 31 S A("3.0.48")=6 ;Mar 2005 32 S A("3.0.63")=4 ;June 2005 33 S A("3.0.45")=8 ;Sept 2005 34 S A("3.0.59")=20 ;July 2006 35 Q 36 ; 37 CHKVER(MAGRY,CLVER) ;RPC [MAG4 VERSION CHECK] 38 ; CLVER is the version of the Delphi Client. 39 ; CLVER format = Major,Minor,Patch,T Version 40 ; example : for Version 3.0 Patch 8 T 21 --> CLVER=3.0.8.21 41 ; Ver 2.5P9 (2.5.24.1) is first Delphi Ver that makes this call. 42 ; CLVER may have Parameters attached to it in '|' pieces. 43 ; "CLVER|RIV" this is a remote image view client 44 ; "CLVER|CAPTURE" this is a Capture Client 45 ; "CLVER|DISPLAY" this is a Display Client 46 ; 3 possible return codes in 1st '^' piece of MAGRY(0). 47 ; 0^message : The Client will display the message and continue. 48 ; 1^message : The Client will continue without displaying any message. 49 ; 2^message : The Client will display the message and then Abort. (Terminate) 50 ; The message displayed is the 2nd '^' piece of (0) node 51 ; and all text of any other nodes. i.e. MAGRY(1..n) 52 ; 53 S CLVER=$G(CLVER) 54 ; Bug in 42. the Version comes in as 30.5.42.x (42 wasn't released) 55 I $P(CLVER,".",1)="30" S CLVER="3.0."_$P(CLVER,".",3,99) 56 ; 57 N PLC,SV,ST,SVSTAT,CV,CP,CT,OKVER,WARN,I 58 ; PLC = Entry in 2006.1 59 ; SV = Server Version -> (3.0.8) from (3.0.8.43) Hard coded to Sync with Delphi Clients 60 ; ST = Server T Version -> 43 from full version (3.0.8.43) 61 ; CV = Client Version sent from Client 3.0.8 same format as SV 62 ; CT = Client T Version sent from Client i.e. 43 same format as ST 63 ; OKVER = Array of Supported Versions, and Released T Version OKVER(3.0.48)=6 64 ; WARN = 1|0 Boolean value determines if client needs EKG Warning. 65 ; 66 S PLC=$$PLACE^MAGBAPI($G(DUZ(2))) 67 ; Quit if we don't have a valid DUZ(2) or valid PLACE: ^MAG(2006.1,PLC) 68 I 'PLC D BADPLC^MAGGTU41(.MAGRY) Q 69 ; 70 ; Set up local variables. 71 D GETVER(.SV,.ST,.OKVER) 72 F I=2:1:$L(CLVER,"|") I $P(CLVER,"|",I)]"" S MAGJOB($P(CLVER,"|",I))=1 73 S CLVER=$P(CLVER,"|",1) 74 S CV=$P(CLVER,".",1,3),CP=$P(CLVER,".",3),CT=$P(CLVER,".",4) 75 I CT="" S $P(CLVER,".",4)=0,CT=0 76 ; set WARN to indicate if Warning is needed or not. 77 ; 78 D NEEDWARN(.WARN) 79 ; Quit if site has VERSION CHECKING=0 (OFF) in Imaging Site Params File. 80 I '$$VERCHKON(PLC) D Q 81 . S MAGRY(0)="1^Version Checking is OFF. Allowing All Versions" 82 . ; But, need to Display the warning, even if Version Checking is OFF 83 . I WARN S MAGRY(0)="0^ =========== WARNING ===============" D WARNING 84 . Q 85 ; If Remote Connection , allow it. 86 I $D(MAGJOB("RIV")) S MAGRY(0)="1^Allowing Remote Image Connection" Q 87 ; Is this Server Version Alpha/Beta or Released. 88 D VERSTAT(.SVSTAT,SV) 89 I 'SVSTAT S MAGRY(0)="2^"_$P(SVSTAT,"^",2) Q ; There is not record of a KIDS for this Server. 90 ; 91 ; If Client isn't one of the Supported Clients. 92 I (CV'=SV),'$D(OKVER(CV)) D Q 93 . I +SVSTAT=2 D NOTOKB^MAGGTU41(.MAGRY) Q 94 . D NOTOK^MAGGTU41(.MAGRY) Q 95 . Q 96 ; 97 ; Client is Supported. Only Warn if we are Not In ALPHA/BETA Testing. 98 I (CV'=SV) D Q 99 . I CT<$G(OKVER(CV)) D Q 100 . . I +SVSTAT=2 DO OKBADTB^MAGGTU41(.MAGRY) Q 101 . . DO OKBADT^MAGGTU41(.MAGRY) Q 102 . . Q 103 . I +SVSTAT=2 D OKB^MAGGTU41(.MAGRY) 104 . E D OK^MAGGTU41(.MAGRY) 105 . I WARN D WARNING 106 . Q 107 ; 108 ; At this point, Versions are the Same: If T versions are not, warn the Client. 109 I CT,(CT'=ST) D Q 110 . I +SVSTAT=2 D TNOTOKB^MAGGTU41(.MAGRY) Q 111 . D TNOTOK^MAGGTU41(.MAGRY) Q 112 . Q 113 ; Client and Server Versions are the same, to the T. (Ha, get it) 114 S MAGRY(0)="1^Version Check OK. Server: "_SV_" Client: "_CV Q 115 Q 116 ; 117 VERCHKON(PLC) ; Is Version checking on for the site (Place) 118 Q +$P(^MAG(2006.1,PLC,"KEYS"),"^",5) 119 ; 120 NEEDWARN(WARN) ; This call determines if Client needs the warning. 121 I $P($G(^MAG(2006.1,PLC,"USERPREF")),U,2)="" S WARN=0 Q ; Not a MUSE Site. 122 I $D(MAGJOB("CAPTURE")) S WARN=0 Q ;Not needed for Capture Clients 123 I CV="3.0.59" S WARN=0 Q ; Client 59 has 63. 124 I CV="3.0.45" S WARN=0 Q ; Client 45 has 63. 125 I CV="3.0.41" S WARN=0 Q ; It is fixed in 41 126 I CV="3.0.63" S WARN=0 Q ; It is fixed in 63 127 I $P(CV,".",1)=2 S WARN=0 Q ;Older Clients don't have the EKG Problem. 128 I '$D(OKVER(CV)) S WARN=0 Q ; Patch 3.0.7, 3.0.2 don't have EKG problem. 129 S WARN=1 ; This means to Show the EKG Warning. 130 Q 131 ; 132 WARNING ; This is hard coded for the EKG Warning. 133 ; Put Warning at the End of any Return Message. 134 S MAGRY(1000)=" " 135 S MAGRY(1010)="!*************************************************!" 136 S MAGRY(1015)=" " 137 S MAGRY(1020)=" PATIENT SAFETY NOTIFICATION" 138 S MAGRY(1025)=" " 139 S MAGRY(1030)=" Under certain circumstances, the EKG window will not" 140 S MAGRY(1040)="refresh properly when you select a new patient in CPRS; " 141 S MAGRY(1050)="instead of showing the new patient, the EKG window will " 142 S MAGRY(1060)="continue to show the previous patient. " 143 S MAGRY(1065)=" " 144 S MAGRY(1070)="To prevent this problem:" 145 S MAGRY(1075)=" " 146 S MAGRY(1080)=" Verify that the 'Show MUSE EKGs' option under" 147 S MAGRY(1085)=" Options > View Preferences is checked;" 148 S MAGRY(1090)=" OR" 149 S MAGRY(1100)=" Do not minimize the Imaging Display window while viewing EKGs." 150 S MAGRY(1110)=" " 151 S MAGRY(1115)="This problem will be corrected shortly by Imaging Patch 63." 152 S MAGRY(1120)="!*************************************************!" 153 Q 154 VERSTAT(MAGRY,MAGVER) ;RPC - [MAG4 VERSION STATUS] 155 ; Returns the status of an Imaging Version 156 ; Input : 157 ; MAGVER - Version number 158 ; in the format MAG*3.0*59 159 ; or the format 3.0.59 160 ; Return: 161 ; MAGRY = 0^There is No KIDs Install record 162 ; 1^Unknown Release Status 163 ; 2^Alpha/Beta Version 164 ; 3^Released Version 165 ; 166 N VERI,TVER,MAGERR 167 I +MAGVER S MAGVER="MAG*"_$P(MAGVER,".",1,2)_"*"_$P(MAGVER,".",3) 168 S VERI=$$FIND1^DIC(9.6,"","M",MAGVER,"","","MAGERR") 169 I 'VERI S MAGRY="0^There is No KIDs Install record." Q 170 S TVER=$$GET1^DIQ(9.6,VERI_",","ALPHA/BETA TESTING") 171 I TVER="YES" S MAGRY="2^Alpha/Beta Version." Q 172 I TVER="NO" S MAGRY="3^Released Version." Q 173 S MAGRY="1^Unknown Release Status." 174 Q 175 ABSJB(MAGRY,MAGIN) ;RPC [MAG ABSJB] SET ABSTRACT AND/OR JUKEBOX QUEUES 176 D ABSJB^MAGGTU71(.MAGRY,.MAGIN) 177 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGTU41.m
r613 r623 1 MAGGTU41 ;WOIFO/GEK - Version Control utilities ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;**46,59**;Nov 27, 2007;Build 20 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 NOTOKB(X) ; Client Not Supported. Server is Beta 21 ; Client will not be supported when this version is Released. Warn Client. 22 S X(0)="0^ This site is a test site for Version: "_SV_"." 23 S X(5)=" Client is running Version: "_CV 24 S X(7)=" " 25 S X(10)=" When Version : "_SV_" is Released, " 26 S X(15)=" Client Version: "_CV_" will no longer be supported." 27 S X(17)=" " 28 S X(18)=" This Client Application will not work correctly." 29 S X(19)=" " 30 S X(20)=" Contact the Imaging System Manager to update this workstation." 31 S X(30)=" " 32 S X(40)=" APPLICATION Will Continue" 33 Q 34 NOTOK(X) ; Client Not Supported. 35 S X(0)="2^ Server is running Imaging V. "_SV_" "_$P(SVSTAT,"^",2) 36 S X(1)=" " 37 S X(5)=" Client is running Imaging V. "_CV 38 S X(7)=" " 39 S X(10)=" Version "_CV_" is no longer supported." 40 S X(15)=" " 41 S X(20)=" Contact the Imaging System Manager to update this workstation." 42 S X(30)=" " 43 S X(40)=" APPLICATION WILL ABORT !" 44 ; Clients prior to 8, have a 'Cancel' button on Message Dialog (oversight) 45 I $P(CV,".",1)=2 S X(50)="(clicking 'Cancel' will not stop the Abort.)" 46 Q 47 OKBADTB(X) ; Client not Equal, Is supported. Previous Supported Version. Beta 48 ; But it's T isn't the T of it's Released Patch 49 S X(0)="0^ Server is running Imaging V. "_SV_" "_$P(SVSTAT,"^",2) 50 S X(3)=" " 51 S X(5)=" Client is running Imaging V. "_CLVER 52 S X(10)=" The Released Version of Patch "_CP_" is V. "_CV_"."_$G(OKVER(CV)) 53 S X(12)=" " 54 S X(18)=" This Client Application will not work correctly. You should" 55 S X(20)=" update this workstation with the Released Version of Patch "_CP 56 S X(21)=" " 57 S X(22)=" Contact the Imaging System Manager to update this workstation." 58 S X(27)=" " 59 S X(30)=" APPLICATION will Continue " 60 Q 61 OKBADT(X) ; Client not Equal, but it is supported. Previous Supported Version 62 ; But it's T isn't the T of it's Released Patch 63 S X(0)="2^ Server is running Imaging V. "_SV_" "_$P(SVSTAT,"^",2) 64 S X(3)=" " 65 S X(5)=" Client is running Imaging V. "_CLVER 66 S X(10)=" The Released Version of Patch "_CP_" is V. "_CV_"."_$G(OKVER(CV)) 67 S X(15)=" " 68 S X(18)=" Version "_CLVER_" is not supported." 69 S X(19)=" " 70 S X(20)=" You must update this workstation." 71 S X(22)=" " 72 S X(25)=" Contact the Imaging System Manager to update this workstation." 73 S X(27)=" " 74 S X(40)=" APPLICATION WILL ABORT !" 75 Q 76 OKB(X) ; Client is Not Equal to server. Server Version / Beta 77 ; Alpha/Beta Version so allow to continue. no message 78 S X(0)="1^ Alpha/Beta testing in progress for: "_SV 79 Q 80 OK(X) ; Client is Not Equal to the server. Warn 81 S X(0)="0^ Server is running Imaging V. "_SV_" "_$P(SVSTAT,"^",2) 82 S X(5)=" Client is running Imaging V. "_CV 83 S X(7)=" " 84 S X(10)=" The Client application should be updated " 85 S X(15)=" " 86 S X(20)=" Contact the Imaging System Manager to update this workstation." 87 S X(30)=" " 88 S X(40)=" APPLICATION Will Continue" 89 ; Clients prior to 8, have a 'Cancel' button on Message Dialog (oversight) 90 I $P(CV,".",1)=2 S X(50)="(clicking 'Cancel' will not stop the Client.)" 91 Q 92 ; 93 ; Versions are the Same: If T versions are not, warn the Client. 94 ; Released Client (of any version) will have the T version that the server expects, and 95 ; no warning will be displayed. 96 TNOTOKB(X) ; Client T is Not Equal to Server T, Beta Site. 97 ;I CT,(CT'=ST) D Q 98 S X(0)="0^ Server is running Imaging V. "_SV_"."_ST_" "_$P(SVSTAT,"^",2) 99 S X(5)=" Client is running Imaging V. "_CLVER 100 S X(10)=" " 101 S X(20)=" Test Versions of Patch "_SV_" other than T"_ST_" may not work correctly." 102 S X(25)=" " 103 S X(30)=" APPLICATION will Continue " 104 Q 105 TNOTOK(X) ; Client T is Not Equal to Server T. 106 ;I CT,(CT'=ST) D Q 107 S X(0)="0^ Server is running Imaging V. "_SV_"."_ST_" "_$P(SVSTAT,"^",2) 108 S X(5)=" Client is running Imaging V. "_CLVER 109 S X(10)=" " 110 S X(12)=" For Patch "_CP_" the released T version is: "_ST 111 S X(20)=" You must update this workstation with the Released Version." 112 S X(22)=" " 113 S X(25)=" Contact the Imaging System Manager to update this workstation." 114 S X(27)=" " 115 S X(30)=" APPLICATION will Continue " 116 Q 117 BADPLC(X) ; The call to $$PLACE^MAGBAPI($G(DUZ(2))) Failed, return a message. 118 ; 119 I '$G(DUZ(2)) S X(0)="2^ Error: Undefined DUZ(2)" 120 E D 121 . S X(0)="2^ Error: Division "_$P($G(^DIC(4,DUZ(2),0)),"^",1)_" ["_DUZ(2)_"]" 122 . S X(2)=" is not an Imaging Site Parameter." 123 . Q 124 S X(5)=" Contact IRM. Application will abort" 125 Q 1 MAGGTU41 ;WOIFO/GEK - Version Control utilities ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;**46**;16-February-2007;;Build 1023 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 ;; | 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 Q 19 NOTOKB(X) ; Client Not Supported. Server is Beta 20 ; Client will not be supported when this version is Released. Warn Client. 21 S X(0)="0^ This site is a test site for Version: "_SV_"." 22 S X(5)=" Client is running Version: "_CV 23 S X(7)=" " 24 S X(10)=" When Version : "_SV_" is Released, " 25 S X(15)=" Client Version: "_CV_" will no longer be supported." 26 S X(17)=" " 27 S X(18)=" This Client Application will not work correctly." 28 S X(19)=" " 29 S X(20)=" Contact the Imaging System Manager to update this workstation." 30 S X(30)=" " 31 S X(40)=" APPLICATION Will Continue" 32 Q 33 NOTOK(X) ; Client Not Supported. 34 S X(0)="2^ Server is running Imaging V. "_SV_" "_$P(SVSTAT,"^",2) 35 S X(1)=" " 36 S X(5)=" Client is running Imaging V. "_CV 37 S X(7)=" " 38 S X(10)=" Version "_CV_" is no longer supported." 39 S X(15)=" " 40 S X(20)=" Contact the Imaging System Manager to update this workstation." 41 S X(30)=" " 42 S X(40)=" APPLICATION WILL ABORT !" 43 ; Clients prior to 8, have a 'Cancel' button on Message Dialog (oversight) 44 I $P(CV,".",1)=2 S X(50)="(clicking 'Cancel' will not stop the Abort.)" 45 Q 46 OKBADTB(X) ; Client not Equal, but it is supported. 47 ; But it's T isn't the T of it's Released Patch 48 S X(0)="0^ Server is running Imaging V. "_SV_" "_$P(SVSTAT,"^",2) 49 S X(3)=" " 50 S X(5)=" Client is running Imaging V. "_CLVER 51 S X(10)=" The Released Version of Patch "_CP_" is V. "_CV_"."_$G(OKVER(CV)) 52 S X(12)=" " 53 S X(18)=" This Client Application will not work correctly. You should" 54 S X(20)=" update this workstation with the Released Version of Patch "_CP 55 S X(21)=" " 56 S X(22)=" Contact the Imaging System Manager to update this workstation." 57 S X(27)=" " 58 S X(30)=" APPLICATION will Continue " 59 Q 60 OKBADT(X) ; Client not Equal, but it is supported. 61 ; But it's T isn't the T of it's Released Patch 62 S X(0)="2^ Server is running Imaging V. "_SV_" "_$P(SVSTAT,"^",2) 63 S X(3)=" " 64 S X(5)=" Client is running Imaging V. "_CLVER 65 S X(10)=" The Released Version of Patch "_CP_" is V. "_CV_"."_$G(OKVER(CV)) 66 S X(15)=" " 67 S X(18)=" Version "_CLVER_" is not supported." 68 S X(19)=" " 69 S X(20)=" You must update this workstation." 70 S X(22)=" " 71 S X(25)=" Contact the Imaging System Manager to update this workstation." 72 S X(27)=" " 73 S X(40)=" APPLICATION WILL ABORT !" 74 Q 75 OKB(X) ; Client is Not Equal to server. Server Version / Beta 76 ; Alpha/Beta Version so allow to continue. no message 77 S X(0)="1^ Alpha/Beta testing in progress for: "_SV 78 Q 79 OK(X) ; Client is Not Equal to the server. Warn 80 S X(0)="0^ Server is running Imaging V. "_SV_" "_$P(SVSTAT,"^",2) 81 S X(5)=" Client is running Imaging V. "_CV 82 S X(7)=" " 83 S X(10)=" The Client application should be updated " 84 S X(15)=" " 85 S X(20)=" Contact the Imaging System Manager to update this workstation." 86 S X(30)=" " 87 S X(40)=" APPLICATION Will Continue" 88 ; Clients prior to 8, have a 'Cancel' button on Message Dialog (oversight) 89 I $P(CV,".",1)=2 S X(50)="(clicking 'Cancel' will not stop the Client.)" 90 Q 91 ; 92 ; Versions are the Same: If T versions are not, warn the Client. 93 ; Released Client (of any version) will have the T version that the server expects, and 94 ; no warning will be displayed. 95 TNOTOKB(X) ; Client T is Not Equal to Server T, Beta Site. 96 ;I CT,(CT'=ST) D Q 97 S X(0)="0^ Server is running Imaging V. "_SV_"."_ST_" "_$P(SVSTAT,"^",2) 98 S X(5)=" Client is running Imaging V. "_CLVER 99 S X(10)=" " 100 S X(20)=" Test Versions of Patch "_SV_" other than T"_ST_" may not work correctly." 101 S X(25)=" " 102 S X(30)=" APPLICATION will Continue " 103 Q 104 TNOTOK(X) ; Client T is Not Equal to Server T. 105 ;I CT,(CT'=ST) D Q 106 S X(0)="0^ Server is running Imaging V. "_SV_"."_ST_" "_$P(SVSTAT,"^",2) 107 S X(5)=" Client is running Imaging V. "_CLVER 108 S X(10)=" " 109 S X(12)=" For Patch "_CP_" the released T version is: "_ST 110 S X(20)=" You must update this workstation with the Released Version." 111 S X(22)=" " 112 S X(25)=" Contact the Imaging System Manager to update this workstation." 113 S X(27)=" " 114 S X(30)=" APPLICATION will Continue " 115 Q 116 BADPLC(X) ; The call to $$PLACE^MAGBAPI($G(DUZ(2))) Failed, return a message. 117 ; 118 I '$G(DUZ(2)) S X(0)="2^ Error: Undefined DUZ(2)" 119 E D 120 . S X(0)="2^ Error: Division "_$P($G(^DIC(4,DUZ(2),0)),"^",1)_" ["_DUZ(2)_"]" 121 . S X(2)=" is not an Imaging Site Parameter." 122 . Q 123 S X(5)=" Contact IRM. Application will abort" 124 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGTU6.m
r613 r623 1 MAGGTU6 ;WOIFO/GEK - Silent Utilities ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;**24,8,48,45,20,46,59**;Nov 27, 2007;Build 20 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 ; 21 LOGACT(MAGRY,ZY) ;RPC [MAGGACTION LOG] 22 ; Call to LogAction from Delphi Window 23 ; 24 ; ZY is input variable it is '^' delimited string 25 ; 'A|B|C|D|E' ^^ MAGIEN ^ 'Copy/Download' ^ DFN ^ '1'; 26 ; DUZ is inserted as 2nd piece below. 27 ; I.E. zy = "C^^103660^Copy To Clipboard^1033^1" 28 N Y 29 S MAGRY="0^Logging access..." 30 ; 31 N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" 32 ; C DUZ MAGIEN ACTION DFN 1 33 D ENTRY^MAGLOG($P(ZY,U),+$G(DUZ),$P(ZY,U,3),$P(ZY,U,4),$P(ZY,U,5),$P(ZY,U,6)) 34 S MAGRY="1^Action was Logged." 35 Q 36 LINKDT(MAGRY,MAGDA,DTTM) ; This is called when an Image is successfully 37 ; linked (Associated) with a Report/Procedure/Note etc. 38 ; MAGDA = Image IEN 39 ; DTTM = "" No date sent, so use NOW 40 ; DTTM = 1 No Date Sent, but use Image capture Date. 41 ; DTTM = Valid FM Date/Time , Use it. 42 N MSG 43 S DTTM=$G(DTTM) 44 I 'DTTM S DTTM=$$NOW^XLFDT ; Using NOW 45 I '$D(^MAG(2005,MAGDA)) Q 46 I DTTM=1 S DTTM=$P(^MAG(2005,MAGDA,2),"^",1) ; Using Date Image Captured. 47 I '$$VALID^MAGGSIV1(2005,64,.DTTM,.MSG) S MAGRY="0^"_MSG Q 48 S $P(^MAG(2005,MAGDA,2),"^",11)=DTTM 49 S MAGRY="1^Okay" 50 Q 51 TIMEOUT(MAGRY,APP) ;RPC [MAGG GET TIMEOUT] 52 ; Call Returns the timeout for the APP from IMAGING SITE PARAMETERS File 53 ; APP is either 'DISPLAY' 'CAPTURE' or 'VISTARAD' 54 N I,MAGTIMES,MAGPLC 55 S MAGRY="" 56 S MAGPLC=$$PLACE^MAGBAPI(DUZ(2)) I 'MAGPLC Q ; DBI - SEB 9/20/2002 57 S MAGTIMES=$G(^MAG(2006.1,MAGPLC,"KEYS")) 58 I APP="DISPLAY" S MAGRY=$P(MAGTIMES,U,2) 59 I APP="CAPTURE" S MAGRY=$P(MAGTIMES,U,3) 60 I APP="VISTARAD" S MAGRY=$P(MAGTIMES,U,4) 61 I APP="TELEREADER" S MAGRY=$P(MAGTIMES,U,6) ; MJK - 2006.01.25 - TeleReader 62 Q 63 EXIST(EKGPLACE) ;Does an ekg server exist in 2005.2 64 I $$CONSOLID^MAGBAPI()=0 Q $O(^MAG(2005.2,"E","EKG","")) ; DBI - SEB 9/20/2002 65 Q $O(^MAG(2005.2,"F",EKGPLACE,"EKG","")) 66 ; 67 ONLINE(MAGR) ;RPC [MAG EKG ONLINE] EKG network location status 68 ;returns the status of the first EKG network location type 69 ;O if offline or a network location doesn't exist 70 ;1 if online 71 ; 72 N EKG1,EKGPLACE 73 S EKGPLACE=$$PLACE^MAGBAPI(DUZ(2)) ; DBI - SEB 9/20/2002 74 I EKGPLACE=0 S EKGPLACE=$$PLACE^MAGBAPI(DUZ(2)) ;Convert to extrinsic /gek 8/2003 75 I $$EXIST(EKGPLACE) D 76 . I $$CONSOLID^MAGBAPI() S EKG1=$O(^MAG(2005.2,"F",EKGPLACE,"EKG","")) ; DBI - SEB 9/20/2002 77 . E S EKG1=$O(^MAG(2005.2,"E","EKG","")) 78 . S MAGR=$P(^MAG(2005.2,EKG1,0),U,6) 79 E S MAGR=0 80 Q 81 SHARE(MAGRY,TYPE) ;RPC [MAG GET NETLOC] 82 ; Get list of image shares 83 ;TYPE = One of the STORAGE TYPE codes : MAG, EKG, WORM, URL or ALL 84 N TMP,I,DATA0,DATA2,DATA3,DATA6,INFO,VALUE,STYP,PHYREF 85 N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR" 86 S I=0 87 I TYPE="" S TYPE="ALL" 88 S MAGRY(0)="1^SUCCESS" 89 F S I=$O(^MAG(2005.2,I)) Q:'I D 90 . Q:$$LOCDRIVE(I) 91 . S DATA0=$G(^MAG(2005.2,I,0)) 92 . S DATA2=$G(^MAG(2005.2,I,2)) 93 . S DATA3=$G(^MAG(2005.2,I,3)) 94 . S DATA6=$G(^MAG(2005.2,I,6)) 95 . ; 96 . S PHYREF=$P(DATA0,"^",2) ; PHYSICAL REFERENCE 97 . S STYP=$P(DATA0,"^",7) ; STORAGE TYPE 98 . ; 99 . I TYPE'="ALL" Q:STYP'[TYPE 100 . Q:$P(DATA0,"^",6)=0 ;SHARE IS OFFLINE (don't return offline shares) 101 . I STYP'="URL" Q:(PHYREF[".") ; pre 45, quit if '.' in phyref 102 . I STYP'="URL" Q:($E(PHYREF,1,2)'="\\") ; pre 45 quit if doesn't start with '\\' 103 . ; 104 . S INFO=$S($E(PHYREF,$L(PHYREF))="\":$E(PHYREF,1,$L(PHYREF)-1),1:PHYREF) 105 . S $P(INFO,"^",2)=$P($G(DATA0),"^",7) ;Physical reference (path) 106 . S $P(INFO,"^",3)=$P($G(DATA0),"^",6) ;Operational Status 0=OFFLINE 1=ONLINE 107 . S $P(INFO,"^",4)=$P($G(DATA2),"^",1) ;Username 108 . S $P(INFO,"^",5)=$P($G(DATA2),"^",2) ;Password 109 . S $P(INFO,"^",6)=$P($G(DATA6),"^",1) ;MUSE Site # 110 . I $P($G(DATA6),"^",2)'="" S $P(INFO,"^",7)=^MAG(2006.17,$P(DATA6,"^",2),0) ;MUSE version # 111 . S $P(INFO,"^",8)=$P($G(DATA3),"^",5) ;Network location SITE 112 . Q:$D(TMP(INFO)) 113 . S TMP(INFO)=I 114 S INFO="" 115 F S INFO=$O(TMP(INFO)) Q:INFO="" D 116 . S MAGRY($O(MAGRY(""),-1)+1)=TMP(INFO)_"^"_INFO 117 K TMP 118 Q 119 LOCDRIVE(I) ; Returns 1 if this is a local drive, else 0 120 ; Local Drive is determined by the DIR not being Type : URL and having a ":" 121 I $P(^MAG(2005.2,I,0),"^",7)'="URL" I $P(^MAG(2005.2,I,0),"^",2)[":" Q 1 122 Q 0 123 GETENV(MAGRY) ;RPC [MAG GET ENV] 124 ; Get some environment variables (used by annotation control) 125 S MAGRY=DUZ(2)_"^"_$$NOW^XLFDT 126 Q 127 ANNCB(STATARR) ;Status Callback (called by the import API) 128 ; 129 N I,CDUZ,QINDEX,A,COUNT 130 N XMDUZ,XMSUB,XMTEXT,XMY 131 ; 0 = error, all others are success. 132 I $P(STATARR(0),"^",1)'=0 D 133 . ; Import was successful 134 E D 135 . ; Import failed - send mail to MAG SERVER group and person who queued the import 136 . S XMDUZ=DUZ 137 . S XMSUB="Import Error Report" 138 . ; get text of message from status array 139 . S XMTEXT="A(" 140 . ; XMD needs array to start with 1, not 0 141 . S COUNT=1,I="" 142 . F S I=$O(STATARR(I)) Q:I="" D 143 . . S A(COUNT)=I_") "_STATARR(I) 144 . . S COUNT=COUNT+1 145 . . Q 146 . S A(COUNT+1)=" " 147 . S A(COUNT+2)=" " 148 . S A(COUNT+3)=" The errors listed above were generated by" 149 . S A(COUNT+4)=" the VistA Imaging Annotation Editor while" 150 . S A(COUNT+5)=" trying to import your diagram. Please" 151 . S A(COUNT+6)=" report these errors to your VistA Imaging" 152 . S A(COUNT+7)=" support personnel." 153 . ;Get person who did the import 154 . S QINDEX=STATARR(2) 155 . S I=-1 F S I=$O(^MAG(2006.034,QINDEX,1,I)) Q:I="" D 156 . . I $P($G(^MAG(2006.034,QINDEX,1,I,0)),"^",1)=8 S CDUZ=$P(^MAG(2006.034,QINDEX,1,I,0),"^",2) 157 . ;Set recipients of message 158 . S XMY("G.MAG SERVER")="" 159 . I $G(CDUZ) S XMY(CDUZ)="" 160 . D ^XMD 161 . Q 162 Q 163 GETCTP(MAGRY) ;RPC [MAG4 CT PRESETS GET] 164 N MAGPLC 165 S MAGPLC=$$PLACE^MAGBAPI(DUZ(2)) 166 I 'MAGPLC S MAGRY="0^Error resolving Users Division" Q 167 S MAGRY=$G(^MAG(2006.1,MAGPLC,"CT")) 168 I MAGRY="" S MAGRY="0^Site doesn't have CT Presets defined." Q 169 S MAGRY="1^"_MAGRY 170 Q 171 SAVECTP(MAGRY,VALUE) ;RPC [MAG4 CT PRESETS SAVE] 172 N MAGPLC 173 S MAGPLC=$$PLACE^MAGBAPI(DUZ(2)) 174 I 'MAGPLC S MAGRY="0^Error resolving Users Division" Q 175 S ^MAG(2006.1,MAGPLC,"CT")=VALUE 176 S MAGRY="1^CT Presets saved." 177 Q 178 NETPLCS ; Create an array of Place, SiteCodes for all entries of 179 ; Network Location entries. 180 N I,PLC,PLCODE,CONS 181 S CONS=$$CONSOLID^MAGBAPI 182 I 'CONS S PLC=$O(^MAG(2006.1,0)),PLCODE=$P(^MAG(2006.1,PLC,0),"^",9) 183 ; 184 K MAGJOB("NETPLC") 185 S I=0 F S I=$O(^MAG(2005.2,I)) Q:'I D 186 . I 'CONS S MAGJOB("NETPLC",I)=PLC_"^"_PLCODE Q 187 . ; Here, for consolidated sites we get the real Site IEN, and Site Code. 188 . I CONS S PLC=$P($G(^MAG(2005.2,I,0)),"^",10),PLCODE=$S(PLC:$P($G(^MAG(2006.1,PLC,0)),"^",9),1:"n/a") 189 . S MAGJOB("NETPLC",I)=PLC_"^"_PLCODE 190 . Q 191 Q 1 MAGGTU6 ;WOIFO/GEK - Silent Utilities ; 25 Jan 2006 12:14 PM 2 ;;3.0;IMAGING;**24,8,48,45,20,46**;16-February-2007;;Build 1023 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 ;; | 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 Q 19 ; 20 LOGACT(MAGRY,ZY) ;RPC [MAGGACTION LOG] 21 ; Call to LogAction from Delphi Window 22 ; 23 ; ZY is input variable it is '^' delimited string 24 ; 'A|B|C|D|E' ^^ MAGIEN ^ 'Copy/Download' ^ DFN ^ '1'; 25 ; DUZ is inserted as 2nd piece below. 26 ; I.E. zy = "C^^103660^Copy To Clipboard^1033^1" 27 N Y 28 S MAGRY="0^Logging access..." 29 ; 30 N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" 31 ; C DUZ MAGIEN ACTION DFN 1 32 D ENTRY^MAGLOG($P(ZY,U),+$G(DUZ),$P(ZY,U,3),$P(ZY,U,4),$P(ZY,U,5),$P(ZY,U,6)) 33 S MAGRY="1^Action was Logged." 34 Q 35 LINKDT(MAGRY,MAGDA,DTTM) ; This is called when an Image is successfully 36 ; linked (Associated) with a Report/Procedure/Note etc. 37 ; MAGDA = Image IEN 38 ; DTTM = "" No date sent, so use NOW 39 ; DTTM = 1 No Date Sent, but use Image capture Date. 40 ; DTTM = Valid FM Date/Time , Use it. 41 N MSG 42 S DTTM=$G(DTTM) 43 I 'DTTM S DTTM=$$NOW^XLFDT ; Using NOW 44 I '$D(^MAG(2005,MAGDA)) Q 45 I DTTM=1 S DTTM=$P(^MAG(2005,MAGDA,2),"^",1) ; Using Date Image Captured. 46 I '$$VALID^MAGGSIV1(2005,64,.DTTM,.MSG) S MAGRY="0^"_MSG Q 47 S $P(^MAG(2005,MAGDA,2),"^",11)=DTTM 48 S MAGRY="1^Okay" 49 Q 50 TIMEOUT(MAGRY,APP) ;RPC [MAGG GET TIMEOUT] 51 ; Call Returns the timeout for the APP from IMAGING SITE PARAMETERS File 52 ; APP is either 'DISPLAY' 'CAPTURE' or 'VISTARAD' 53 N I,MAGTIMES,MAGPLC 54 S MAGRY="" 55 S MAGPLC=$$PLACE^MAGBAPI(DUZ(2)) I 'MAGPLC Q ; DBI - SEB 9/20/2002 56 S MAGTIMES=$G(^MAG(2006.1,MAGPLC,"KEYS")) 57 I APP="DISPLAY" S MAGRY=$P(MAGTIMES,U,2) 58 I APP="CAPTURE" S MAGRY=$P(MAGTIMES,U,3) 59 I APP="VISTARAD" S MAGRY=$P(MAGTIMES,U,4) 60 I APP="TELEREADER" S MAGRY=$P(MAGTIMES,U,6) ; MJK - 2006.01.25 - TeleReader 61 Q 62 EXIST(EKGPLACE) ;Does an ekg server exist in 2005.2 63 I $$CONSOLID^MAGBAPI()=0 Q $O(^MAG(2005.2,"E","EKG","")) ; DBI - SEB 9/20/2002 64 Q $O(^MAG(2005.2,"F",EKGPLACE,"EKG","")) 65 ; 66 ONLINE(MAGR) ;RPC [MAG EKG ONLINE] EKG network location status 67 ;returns the status of the first EKG network location type 68 ;O if offline or a network location doesn't exist 69 ;1 if online 70 ; 71 N EKG1,EKGPLACE 72 S EKGPLACE=$$PLACE^MAGBAPI(DUZ(2)) ; DBI - SEB 9/20/2002 73 I EKGPLACE=0 S EKGPLACE=$$PLACE^MAGBAPI(DUZ(2)) ;Convert to extrinsic /gek 8/2003 74 I $$EXIST(EKGPLACE) D 75 . I $$CONSOLID^MAGBAPI() S EKG1=$O(^MAG(2005.2,"F",EKGPLACE,"EKG","")) ; DBI - SEB 9/20/2002 76 . E S EKG1=$O(^MAG(2005.2,"E","EKG","")) 77 . S MAGR=$P(^MAG(2005.2,EKG1,0),U,6) 78 E S MAGR=0 79 Q 80 SHARE(MAGRY,TYPE) ;RPC [MAG GET NETLOC] 81 ; Get list of image shares 82 ;TYPE = One of the STORAGE TYPE codes : MAG, EKG, WORM, URL or ALL 83 N TMP,I,DATA0,DATA2,DATA3,DATA6,INFO,VALUE,STYP,PHYREF 84 N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR" 85 S I=0 86 I TYPE="" S TYPE="ALL" 87 S MAGRY(0)="1^SUCCESS" 88 F S I=$O(^MAG(2005.2,I)) Q:'I D 89 . Q:$$LOCDRIVE(I) 90 . S DATA0=$G(^MAG(2005.2,I,0)) 91 . S DATA2=$G(^MAG(2005.2,I,2)) 92 . S DATA3=$G(^MAG(2005.2,I,3)) 93 . S DATA6=$G(^MAG(2005.2,I,6)) 94 . ; 95 . S PHYREF=$P(DATA0,"^",2) ; PHYSICAL REFERENCE 96 . S STYP=$P(DATA0,"^",7) ; STORAGE TYPE 97 . ; 98 . I TYPE'="ALL" Q:STYP'[TYPE 99 . Q:$P(DATA0,"^",6)=0 ;SHARE IS OFFLINE (don't return offline shares) 100 . I STYP'="URL" Q:(PHYREF[".") ; pre 45, quit if '.' in phyref 101 . I STYP'="URL" Q:($E(PHYREF,1,2)'="\\") ; pre 45 quit if doesn't start with '\\' 102 . ; 103 . S INFO=$S($E(PHYREF,$L(PHYREF))="\":$E(PHYREF,1,$L(PHYREF)-1),1:PHYREF) 104 . S $P(INFO,"^",2)=$P($G(DATA0),"^",7) ;Physical reference (path) 105 . S $P(INFO,"^",3)=$P($G(DATA0),"^",6) ;Operational Status 0=OFFLINE 1=ONLINE 106 . S $P(INFO,"^",4)=$P($G(DATA2),"^",1) ;Username 107 . S $P(INFO,"^",5)=$P($G(DATA2),"^",2) ;Password 108 . S $P(INFO,"^",6)=$P($G(DATA6),"^",1) ;MUSE Site # 109 . I $P($G(DATA6),"^",2)'="" S $P(INFO,"^",7)=^MAG(2006.17,$P(DATA6,"^",2),0) ;MUSE version # 110 . S $P(INFO,"^",8)=$P($G(DATA3),"^",5) ;Network location SITE 111 . Q:$D(TMP(INFO)) 112 . S TMP(INFO)=I 113 S INFO="" 114 F S INFO=$O(TMP(INFO)) Q:INFO="" D 115 . S MAGRY($O(MAGRY(""),-1)+1)=TMP(INFO)_"^"_INFO 116 K TMP 117 Q 118 LOCDRIVE(I) ; Returns 1 if this is a local drive, else 0 119 ; Local Drive is determined by the DIR not being Type : URL and having a ":" 120 I $P(^MAG(2005.2,I,0),"^",7)'="URL" I $P(^MAG(2005.2,I,0),"^",2)[":" Q 1 121 Q 0 122 GETENV(MAGRY) ;RPC [MAG GET ENV] 123 ; Get some environment variables (used by annotation control) 124 S MAGRY=DUZ(2)_"^"_$$NOW^XLFDT 125 Q 126 ANNCB(STATARR) ;Status Callback (called by the import API) 127 ; 128 N I,CDUZ,QINDEX,A,COUNT 129 N XMDUZ,XMSUB,XMTEXT,XMY 130 ; 0 = error, all others are success. 131 I $P(STATARR(0),"^",1)'=0 D 132 . ; Import was successful 133 E D 134 . ; Import failed - send mail to MAG SERVER group and person who queued the import 135 . S XMDUZ=DUZ 136 . S XMSUB="Import Error Report" 137 . ; get text of message from status array 138 . S XMTEXT="A(" 139 . ; XMD needs array to start with 1, not 0 140 . S COUNT=1,I="" 141 . F S I=$O(STATARR(I)) Q:I="" D 142 . . S A(COUNT)=I_") "_STATARR(I) 143 . . S COUNT=COUNT+1 144 . . Q 145 . S A(COUNT+1)=" " 146 . S A(COUNT+2)=" " 147 . S A(COUNT+3)=" The errors listed above were generated by" 148 . S A(COUNT+4)=" the VistA Imaging Annotation Editor while" 149 . S A(COUNT+5)=" trying to import your diagram. Please" 150 . S A(COUNT+6)=" report these errors to your VistA Imaging" 151 . S A(COUNT+7)=" support personnel." 152 . ;Get person who did the import 153 . S QINDEX=STATARR(2) 154 . S I=-1 F S I=$O(^MAG(2006.034,QINDEX,1,I)) Q:I="" D 155 . . I $P($G(^MAG(2006.034,QINDEX,1,I,0)),"^",1)=8 S CDUZ=$P(^MAG(2006.034,QINDEX,1,I,0),"^",2) 156 . ;Set recipients of message 157 . S XMY("G.MAG SERVER")="" 158 . I $G(CDUZ) S XMY(CDUZ)="" 159 . D ^XMD 160 . Q 161 Q 162 GETCTP(MAGRY) ;RPC [MAG4 CT PRESETS GET] 163 N MAGPLC 164 S MAGPLC=$$PLACE^MAGBAPI(DUZ(2)) 165 I 'MAGPLC S MAGRY="0^Error resolving Users Division" Q 166 S MAGRY=$G(^MAG(2006.1,MAGPLC,"CT")) 167 I MAGRY="" S MAGRY="0^Site doesn't have CT Presets defined." Q 168 S MAGRY="1^"_MAGRY 169 Q 170 SAVECTP(MAGRY,VALUE) ;RPC [MAG4 CT PRESETS SAVE] 171 N MAGPLC 172 S MAGPLC=$$PLACE^MAGBAPI(DUZ(2)) 173 I 'MAGPLC S MAGRY="0^Error resolving Users Division" Q 174 S ^MAG(2006.1,MAGPLC,"CT")=VALUE 175 S MAGRY="1^CT Presets saved." 176 Q 177 NETPLCS ; Create an array of Place, SiteCodes for all entries of 178 ; Network Location entries. 179 N I,PLC,PLCODE,CONS 180 S CONS=$$CONSOLID^MAGBAPI 181 I 'CONS S PLC=$O(^MAG(2006.1,0)),PLCODE=$P(^MAG(2006.1,PLC,0),"^",9) 182 ; 183 K MAGJOB("NETPLC") 184 S I=0 F S I=$O(^MAG(2005.2,I)) Q:'I D 185 . I 'CONS S MAGJOB("NETPLC",I)=PLC_"^"_PLCODE Q 186 . ; Here, for consolidated sites we get the real Site IEN, and Site Code. 187 . I CONS S PLC=$P($G(^MAG(2005.2,I,0)),"^",10),PLCODE=$S(PLC:$P($G(^MAG(2006.1,PLC,0)),"^",9),1:"n/a") 188 . S MAGJOB("NETPLC",I)=PLC_"^"_PLCODE 189 . Q 190 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGTU71.m
r613 r623 1 MAGGTU71 2 ;;3.0;IMAGING;**46,59**;Nov 27, 2007;Build 20 3 ;;Per VHA Directive 2004-038, this routine should not be modified.4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 ABSJB(MAGRY, DATA);RPC [MAG ABSJB] SET ABSTRACT AND/OR JUKEBOX QUEUES20 21 ; DATA 22 23 24 25 26 27 28 29 30 31 32 33 S MAGIENAB=+$P(DATA,"^",1),MAGIENJB=+$P(DATA,"^",2)34 35 36 37 38 39 40 41 42 43 44 ERR 45 46 47 48 49 50 51 QERR 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 1 MAGGTU71 ;WOIFO/GEK - Silent calls for Queing functions from GUI, cont ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;**46**;16-February-2007;;Build 1023 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 ;; | 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 Q 19 ABSJB(MAGRY,MAGIN) ;RPC [MAG ABSJB] SET ABSTRACT AND/OR JUKEBOX QUEUES 20 ; 21 ; MAGIN 22 ; DESCRIPTION: '^' delimited String: 23 ; Piece 1 = the IEN of the image that needs an abstract created. 24 ; Piece 2 = the IEN of the image that needs copied to the jukebox 25 ; 26 ; MAGRY = "1^Successful" 27 ; = "0^error message" 28 ; 29 N MAGIENAB,MAGIENJB,MAGERR,X,QMSG 30 S MAGERR=0 31 N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) 32 S MAGRY="0^ERROR: Setting Queue for Abstract or JukeBox copy" 33 S MAGIENAB=+$P(MAGIN,"^",1),MAGIENJB=+$P(MAGIN,"^",2) 34 I MAGIENAB Q:((+$P($G(^MAG(2005,MAGIENAB,0)),U,11))!(+$P($G(^MAG(2005,MAGIENAB,0)),U,12))) "0^Image integrity" 35 I MAGIENJB Q:((+$P($G(^MAG(2005,MAGIENJB,0)),U,11))!(+$P($G(^MAG(2005,MAGIENJB,0)),U,12))) "0^Image integrity" 36 S QMSG=$S(MAGIENAB:"Setting Abstract Queue",1:"") 37 I MAGIENJB S QMSG=$S(QMSG="":"Setting JukeBox Queue",1:" and JukeBox Queue") 38 L +(^MAGQUEUE(2006.03,0),^MAGQUEUE(2006.031)):10 E D QERR Q 39 I MAGIENAB S X=$$ABSTRACT^MAGBAPI(MAGIENAB,$$DA2PLC^MAGBAPIP(MAGIENAB,"F")) 40 I MAGIENJB S X=$$JUKEBOX^MAGBAPI(MAGIENJB,$$DA2PLC^MAGBAPIP(MAGIENJB,"F")) 41 L -(^MAGQUEUE(2006.03,0),^MAGQUEUE(2006.031)) 42 S MAGRY="1^SUCCESSFUL" 43 Q 44 ERR ; 45 L -(^MAGQUEUE(2006.03,0),^MAGQUEUE(2006.031)) 46 N ERR S ERR=$$EC^%ZOSV 47 S MAGRY="0^Timed out trying to set JukeBox/Abstract Queue. Not Fatal. 'Save' will continue..." 48 D LOGERR^MAGGTERR(ERR) 49 D @^%ZOSF("ERRTN") 50 Q 51 QERR ; 52 N MAGTXT,EMSG 53 S MAGTXT="Failed "_QMSG 54 ;ENTRY(MAGIMT,MAGDUZ,MAGO,MAGPACK,MAGDFN,MAGCT,MAGAD) 55 D ENTRY^MAGLOG("QFAIL",$G(DUZ),MAGIENJB,"","","",MAGTXT) 56 D ACTION^MAGGTAU(MAGTXT,1) 57 S EMSG="Timed out trying to Lock Queue File" 58 D ACTION^MAGGTAU(EMSG,1) 59 S MAGRY="1^"_MAGTXT_" Message was sent to IRM. Not Fatal. 'Save' will continue..." 60 N XMSUB,XMY,XMTEXT,XMK,XMDUZ 61 S XMTEXT="^TMP($J,""MAGQ""," 62 S XMSUB=MAGTXT 63 K ^TMP($J,"MAGQ") 64 S ^TMP($J,"MAGQ",1)=MAGTXT 65 S ^TMP($J,"MAGQ",2)=EMSG 66 S ^TMP($J,"MAGQ",3)=" for Image IEN: "_MAGIENJB 67 S ^TMP($J,"MAGQ",4)="You need to run the Verifier for this Image IEN" 68 S XMY("G.IMAGING DEVELOPMENT@FORUM.VA.GOV")="" 69 D ^XMD 70 S XMDUZ=DUZ D KLQ^XMA1B 71 K ^TMP($J,"MAGQ") 72 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGTU9.m
r613 r623 1 MAGGTU9 ;WOIFO/LB/GEK - Imaging utilities assign key 2 ;;3.0;IMAGING;**8,59**;Nov 27, 2007;Build 20 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 CHKKEY ; 21 N NOGIVE 22 S NOGIVE=1 23 GIVEKEY ;Give MAGDISP CLIN key to all MAG WINDOWS option holders 24 ; that have neither MAGDISP CLIN nor MAGDISP ADMIN 25 ; Find the menu option's IEN 26 N MKEYC,MKEYA,ERR,OPT,MAGUSER,I,KEYCLIN,KEYADMIN,KEYCT,KEYECT,XCT 27 N KEYHASC,KEYHASA,KEYHASB,KEYNONE,SP,LSP 28 N UCT,UTOT,OPTACC,MDOT,UDISCT 29 ; This could be made Generic if ever a need, to search for users 30 ; withour either key, and assigned those users the first (KEYCLIN) 31 S KEYCLIN="MAGDISP CLIN" 32 S KEYADMIN="MAGDISP ADMIN" 33 S KEYCT=0 ; count of number of users that were assigned the key. 34 S KEYECT=0 ; count of number of errors during the assignment. 35 S KEYHASC=0 ; count of number of users that already have key Clin 36 S KEYHASA=0 ; count of number of users that already have key Admin 37 S KEYHASB=0 ; count of number of users that Have Both keys 38 S KEYNONE=0 ; count of Users that have Neither Key. 39 S OPTACC=0 ; count of users with access to MAG WINDOWS. 40 S UDISCT=0 ; count of Disabled Users Skipped. 41 S MDOT=10000 ; print '.' to screen to show progress. 42 S UCT=0 ; user count. for progress 43 S UTOT=$P(^VA(200,0),"^",4) 44 ; 45 I $G(NOGIVE) D 46 . D MES^XPDUTL("Checking for users that have access to Option : "_"MAG WINDOWS") 47 . D MES^XPDUTL(" but do not have either '"_KEYCLIN_"' or '"_KEYADMIN_"' Keys") 48 . D MES^XPDUTL(" Disabled users (DISUSER=1) are skipped, they are not checked.") 49 . Q 50 E D MES^XPDUTL("Assigning "_KEYCLIN_" to all users with access to Option : "_"MAG WINDOWS") 51 D MES^XPDUTL(" ") 52 S OPT=$$FIND1^DIC(19,"","X","MAG WINDOWS","","","ERR") 53 I OPT="" D MES^XPDUTL("ERROR ",$G(ERR("DIERR",1,"TEXT",1))) Q 54 I OPT=0 D MES^XPDUTL("MAG WINDOWS wasn't found in Option File") Q 55 ; Lookup the security key 56 S MKEYC=$$LKUP^XPDKEY(KEYCLIN) 57 S MKEYA=$$LKUP^XPDKEY(KEYADMIN) 58 I ('MKEYC)!('MKEYA) D MES^XPDUTL("ERROR: Imaging Display Keys are not defined at this site") Q 59 ; Check all Users at site to see if they don't have either Clin or Admin 60 D MES^XPDUTL("Checking users...") 61 D MES^XPDUTL(" ") 62 S I=0 F S I=$O(^VA(200,I)) Q:'I D 63 . I $$GET1^DIQ(200,I,7,"E")]"" S UDISCT=UDISCT+1 Q 64 . S UCT=UCT+1 I UCT>MDOT S MDOT=MDOT+10000 D MES^XPDUTL(UCT_" of "_UTOT_" users checked...") 65 . I (($$ACCESS^XQCHK(I,OPT))>0) S OPTACC=OPTACC+1 D C(I) 66 . Q 67 S SP=" " 68 S LSP=$L(UTOT)+3 69 D MES^XPDUTL(" ") 70 I $G(NOGIVE) D 71 . D MES^XPDUTL($E(SP,1,LSP-$L(OPTACC))_OPTACC_" of "_UTOT_" Users have access to option MAG WINDOWS.") 72 . D MES^XPDUTL($E(SP,1,LSP-$L(KEYHASB))_KEYHASB_" Users have Both Keys ") 73 . D MES^XPDUTL($E(SP,1,LSP-$L(KEYHASC))_KEYHASC_" Users only have "_KEYCLIN_" key") 74 . D MES^XPDUTL($E(SP,1,LSP-$L(KEYHASA))_KEYHASA_" Users only have "_KEYADMIN_" key") 75 . D MES^XPDUTL($E(SP,1,LSP-$L(KEYNONE))_KEYNONE_" Users have neither Key") 76 . I KEYECT>0 D MES^XPDUTL(KEYECT_" Errors during Key Assignment. See install log for details") 77 . Q 78 I '$G(NOGIVE) D 79 . D MES^XPDUTL($E(SP,1,LSP-$L(OPTACC))_OPTACC_" of "_UTOT_" Users have access to option MAG WINDOWS.") 80 . D MES^XPDUTL($E(SP,1,LSP-$L(KEYHASB))_KEYHASB_" Users already have Both Keys ") 81 . D MES^XPDUTL($E(SP,1,LSP-$L(KEYHASC))_KEYHASC_" Users have Only Key "_KEYCLIN) 82 . D MES^XPDUTL($E(SP,1,LSP-$L(KEYHASA))_KEYHASA_" Users have Only Key "_KEYADMIN) 83 . D MES^XPDUTL($E(SP,1,LSP-$L(KEYCT))_KEYCT_" Users were assigned key: "_KEYCLIN) 84 . D MES^XPDUTL("Assignment Complete.") 85 . I KEYECT>0 D MES^XPDUTL(KEYECT_" Errors during Key Assignment. See install log for details") 86 . Q 87 Q 88 C(USER) ; 89 ; check KEY for USER 90 N DO,D1,MFDA,ZC,ZA,MIEN 91 ; check to see if they have the Clin key 92 S ZC=$$FIND1^DIC(200.051,","_USER_",","",KEYCLIN) 93 I ZC="" D Q 94 . D MES^XPDUTL("ERROR Validating that user ("_USER_") has Key "_KEYCLIN) 95 . S KEYECT=KEYECT+1 96 . Q 97 ; check to see if they have the Admin key 98 S ZA=$$FIND1^DIC(200.051,","_USER_",","",KEYADMIN) 99 I ZA="" D Q 100 . D MES^XPDUTL("ERROR Validating that user ("_USER_") has Key "_KEYADMIN) 101 . S KEYECT=KEYECT+1 102 . Q 103 I ((+ZC)&(+ZA)) S KEYHASB=KEYHASB+1 Q 104 I +ZC S KEYHASC=KEYHASC+1 Q 105 I +ZA S KEYHASA=KEYHASA+1 Q 106 S KEYNONE=KEYNONE+1 107 I $G(NOGIVE) D Q 108 . D MES^XPDUTL("User: "_$P($G(^VA(200,USER,0)),"^")_" has neither Key") 109 . Q 110 S MFDA(200.051,"+1,"_USER_",",.01)=MKEYC 111 S MFDA(200.051,"+1,"_USER_",",1)=DUZ 112 S MFDA(200.051,"+1,"_USER_",",2)=DT 113 S MIEN(1)=MKEYC_"," 114 D UPDATE^DIE("","MFDA","MIEN") 115 I $D(DIERR) D Q 116 . D MES^XPDUTL("ERROR Assigning Key ("_KEYCLIN_") to user ("_USER_")") 117 . S KEYECT=KEYECT+1 118 . D CLEAN^DILF 119 . Q 120 S KEYCT=KEYCT+1 121 D CLEAN^DILF 122 Q 123 FLT ; Create a Few Public Filters as a default for sites. 124 ; Only create new public filters if file is empty. 125 N DIK 126 I +$P(^MAG(2005.87,0),"^",3) D Q 127 . D MES^XPDUTL("The IMAGE LIST FILTERS File is not empty,") 128 . D MES^XPDUTL(" Default Public Filters were not installed.") 129 . Q 130 S ^MAG(2005.87,1,0)="Rad All^RAD^CLIN^^^^^^0" 131 S ^MAG(2005.87,1,1)="^1^.05" 132 S ^MAG(2005.87,2,0)="Clin All^^CLIN^^^^^^0" 133 S ^MAG(2005.87,2,1)="^1^.05" 134 S ^MAG(2005.87,3,0)="Admin All^^ADMIN^^^^^^0" 135 S ^MAG(2005.87,3,1)="^1^.05" 136 S ^MAG(2005.87,4,0)="Clin 2 yr^^CLIN^^^^^^-24" 137 S ^MAG(2005.87,4,1)="^1^.05" 138 S ^MAG(2005.87,5,0)="Admin 10-10EZ All^^ADMIN^46,^^^^^0" 139 S ^MAG(2005.87,5,1)="^1^.05" 140 S ^MAG(2005.87,6,0)="Adv Directives^^CLIN^67^^^^^0" 141 S ^MAG(2005.87,6,1)="^1^.05" 142 S ^MAG(2005.87,7,0)="All^^^^^^^^0" 143 S ^MAG(2005.87,7,1)="^1^.05" 144 S ^MAG(2005.87,8,0)="All 2 yr^^^^^^^^-24" 145 S ^MAG(2005.87,8,1)="^1^.05" 146 S ^MAG(2005.87,9,0)="All 6 mth^^^^^^^^-6" 147 S ^MAG(2005.87,9,1)="^1^.05" 148 ;All Advance Directives^^CLIN^67^^^^^0 149 S DIK="^MAG(2005.87," D IXALL^DIK 150 D MES^XPDUTL("Default Public Filters added to IMAGE LIST FILTERS File.") 151 Q 1 MAGGTU9 ;WOIFO/LB/GEK - Imaging utilities assign key 2 ;;3.0;IMAGING;**8**;Sep 15, 2004 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 Q 19 EN ;Give MAGDISP CLIN key to all MAG WINDOWS option holders. 20 ; Find the menu option's IEN 21 N MKEY,ERR,OPT,MAGUSER,I,KEYNM,KEYCT,KEYECT,XCT,KEYHAS 22 N UCT,UTOT,OPTACC,MDOT 23 S KEYNM="MAGDISP CLIN" 24 S KEYCT=0 ; count of number of users that were assigned the key. 25 S KEYECT=0 ; count of number of errors during the assignment. 26 S KEYHAS=0 ; count of number of users that already have key. 27 S OPTACC=0 ; count of users with access to MAG WINDOWS. 28 S MDOT=10000 ; print '.' to screen to show progress. 29 S UCT=0 ; user count. for progress 30 S UTOT=$P(^VA(200,0),"^",4) 31 ; 32 D MES^XPDUTL("Assigning "_KEYNM_" to all users with access to Option : "_"MAG WINDOWS") 33 S OPT=$$FIND1^DIC(19,"","X","MAG WINDOWS","","","ERR") 34 I OPT="" D MES^XPDUTL("ERROR ",$G(ERR("DIERR",1,"TEXT",1))) Q 35 I OPT=0 D MES^XPDUTL("MAG WINDOWS wasn't found in Option File") Q 36 ; Lookup the security key 37 S MKEY=$$LKUP^XPDKEY(KEYNM) 38 I 'MKEY D MES^XPDUTL("ERROR "_KEYNM_" Key wasn't found") Q 39 ; Give users the Key, if they don't have it already 40 D MES^XPDUTL("Checking users...") 41 S I=0 F S I=$O(^VA(200,I)) Q:'I D 42 . S UCT=UCT+1 I UCT>MDOT S MDOT=MDOT+10000 D MES^XPDUTL(UCT_" of "_UTOT_" users checked...") 43 . I (($$ACCESS^XQCHK(I,OPT))>0) S OPTACC=OPTACC+1 D GIVEKEY(MKEY,KEYNM,I) 44 . Q 45 D MES^XPDUTL(OPTACC_" of "_UTOT_" Users have access to option MAG WINDOWS.") 46 D MES^XPDUTL(KEYHAS_" Users already have Key "_KEYNM) 47 D MES^XPDUTL(KEYCT_" Users were assigned key: "_KEYNM) 48 D MES^XPDUTL("Assignment Complete.") 49 I KEYECT>0 D MES^XPDUTL(KEYECT_" Errors during Key Assignment. See install log for details") 50 Q 51 GIVEKEY(KEY,KEYNM,USER) ; 52 ; Give KEY to USER 53 N DO,D1,MFDA,Z,MIEN 54 ; Quit if they already have the key 55 S Z=$$FIND1^DIC(200.051,","_USER_",","",KEYNM) 56 I +Z S KEYHAS=KEYHAS+1 57 Q:Z ; Already have key 58 I Z="" D Q 59 . D MES^XPDUTL("ERROR Validating that user ("_USER_") has key ("_KEYNM_")") 60 . S KEYECT=KEYECT+1 61 ; 62 S MFDA(200.051,"+1,"_USER_",",.01)=KEY 63 S MFDA(200.051,"+1,"_USER_",",1)=DUZ 64 S MFDA(200.051,"+1,"_USER_",",2)=DT 65 S MIEN(1)=KEY_"," 66 D UPDATE^DIE("","MFDA","MIEN") 67 I $D(DIERR) D Q 68 . D MES^XPDUTL("ERROR Assigning key ("_KEYNM_") to user ("_USER_")") 69 . S KEYECT=KEYECT+1 70 . D CLEAN^DILF 71 . Q 72 S KEYCT=KEYCT+1 73 D CLEAN^DILF 74 Q 75 FLT ; Create a Few Public Filters as a default for sites. 76 ; Only create new public filters if file is empty. 77 N DIK 78 I +$P(^MAG(2005.87,0),"^",3) D Q 79 . D MES^XPDUTL("The IMAGE LIST FILTERS File is not empty,") 80 . D MES^XPDUTL(" Default Public Filters were not installed.") 81 . Q 82 S ^MAG(2005.87,1,0)="Rad All^RAD^CLIN^^^^^^0" 83 S ^MAG(2005.87,1,1)="^1^.05" 84 S ^MAG(2005.87,2,0)="Clin All^^CLIN^^^^^^0" 85 S ^MAG(2005.87,2,1)="^1^.05" 86 S ^MAG(2005.87,3,0)="Admin All^^ADMIN^^^^^^0" 87 S ^MAG(2005.87,3,1)="^1^.05" 88 S ^MAG(2005.87,4,0)="Clin 2 yr^^CLIN^^^^^^-24" 89 S ^MAG(2005.87,4,1)="^1^.05" 90 S ^MAG(2005.87,5,0)="Admin 10-10EZ All^^ADMIN^46,^^^^^0" 91 S ^MAG(2005.87,5,1)="^1^.05" 92 S ^MAG(2005.87,6,0)="Adv Directives^^CLIN^67^^^^^0" 93 S ^MAG(2005.87,6,1)="^1^.05" 94 S ^MAG(2005.87,7,0)="All^^^^^^^^0" 95 S ^MAG(2005.87,7,1)="^1^.05" 96 S ^MAG(2005.87,8,0)="All 2 yr^^^^^^^^-24" 97 S ^MAG(2005.87,8,1)="^1^.05" 98 S ^MAG(2005.87,9,0)="All 6 mth^^^^^^^^-6" 99 S ^MAG(2005.87,9,1)="^1^.05" 100 ;All Advance Directives^^CLIN^67^^^^^0 101 S DIK="^MAG(2005.87," D IXALL^DIK 102 D MES^XPDUTL("Default Public Filters added to IMAGE LIST FILTERS File.") 103 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGGTUP.m
r613 r623 1 MAGGTUP ;WOIFO/GEK - Imaging System User preferences ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;**7,8,48,45,59**;Nov 27, 2007;Build 20 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 GET(MAGRY,CODE) ;RPC [MAGGUPREFGET] Call to Get user preferences. 21 ; 22 N Y,PRFIEN,J,X,Z,NODE,MAGPREF 23 N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR" 24 K MAGRY 25 S MAGRY(0)="0^Error: Attempting to access user preference" 26 S PRFIEN=$O(^MAG(2006.18,"AC",DUZ,"")) 27 ; if first time user 28 I 'PRFIEN S PRFIEN=$$NEWUSER(DUZ) Q:PRFIEN=-1 29 ; merge default settings into User's Preferences 30 D MERGE(PRFIEN) 31 ; This returns the users default Filter, and creates filters if needed. 32 S $P(^MAG(2006.18,PRFIEN,"LISTWIN1"),"^",3)=$$DFTFLT^MAGGSFLT(DUZ) 33 S MAGRY(0)="1^User Preferences returned." 34 ; 35 ; At This point. Then entry in 2006.18 for User DUZ in complete 36 ; it has been merged with defaults, and has a valid Default Filter. 37 ; 38 ; if caller only wants one node, get it then quit. 39 I $L($G(CODE)) S MAGRY($O(MAGRY(""),-1)+1)=CODE_"^"_$G(^MAG(2006.18,PRFIEN,CODE)) Q 40 ; 41 ; loop through User Pref file, returning all nodes. 42 ; Next line was Un-Commented out. BUT Clients before Patch 8 need it. 43 S MAGRY($O(MAGRY(""),-1)+1)="SYS^"_^MAG(2006.18,PRFIEN,0) 44 S NODE="" 45 F S NODE=$O(^MAG(2006.18,PRFIEN,NODE)) Q:(NODE="") D 46 . S MAGRY($O(MAGRY(""),-1)+1)=NODE_"^"_^MAG(2006.18,PRFIEN,NODE) 47 Q 48 MERGE(PRFIEN) ; Merge default settings into User Prefs returned. 49 ; This will assure the User Prefs returned have values for New fields. 50 ; PRFIEN = IEN in IMAGING USER PREFERENCES File. 51 N NODE,DARR,MN,YN 52 D DFLTARR(.DARR) 53 S NODE="" F S NODE=$O(DARR($J,NODE)) Q:(NODE="") D 54 . S YN=DARR($J,NODE) 55 . S MN=$G(^MAG(2006.18,PRFIEN,NODE)) 56 . F J=1:1:$L(YN,"^") I ($P(YN,"^",J)'=""),($P(MN,"^",J)="") S $P(MN,"^",J)=$P(YN,"^",J) 57 . S ^MAG(2006.18,PRFIEN,NODE)=MN 58 ; 59 Q 60 SAVE(MAGRY,DATA) ;RPC [MAGGUPREFSAVE] Call to save User Preferences 61 ; 62 S MAGRY="0^Error: Saving user preferences." 63 N X,Y,NODE,PRFIEN,J 64 N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" 65 S PRFIEN=$O(^MAG(2006.18,"AC",DUZ,"")) I 'PRFIEN S PRFIEN=$$NEWUSER(DUZ) Q:PRFIEN=-1 66 S NODE="" F S NODE=$O(DATA(NODE)) Q:NODE="" D 67 . S X=$G(^MAG(2006.18,PRFIEN,NODE)) 68 . S Y=DATA(NODE) 69 . F J=1:1:$L(Y,"^") I $L($P(Y,"^",J)) S $P(X,"^",J)=$P(Y,"^",J) 70 . S ^MAG(2006.18,PRFIEN,NODE)=X 71 S MAGRY="1^User Preferences saved." 72 Q 73 NEWUSER(USER) ;Returns IEN of New entry in IMAGING USER PREFERENCES File. 74 K DD,DO 75 N DIC 76 S X=$E($$GET1^DIQ(200,USER_",",.01),1,15)_" (SETTING 1)" 77 S DIC="^MAG(2006.18,",DIC(0)="L" 78 S DIC("DR")="1////"_USER_";2////12;3////12;" D FILE^DICN 79 I Y=-1 Q Y 80 D DEFAULT(+Y) 81 Q +Y 82 DEFAULT(NEWPREF) ;Setup a new IMAGING USER PREFERENCES entry, with System defaults. 83 ; NEWPREF = IEN in IMAGING USER PREFERENCES File 84 N DFTPREF,N0,DFTSET 85 S DFTPREF=+$$GET1^DIQ(2006.1,$$PLACE^MAGBAPI(DUZ(2)),100,"I") ; DBI - SEB 9/20/2002 86 I DFTPREF,$D(^MAG(2006.18,DFTPREF)) D DEFUSER(NEWPREF,DFTPREF) Q 87 ; save the User name, Setting Name 88 S N0=$P(^MAG(2006.18,NEWPREF,0),U,1,4) 89 D DFLTARR(.DFTSET) 90 M ^MAG(2006.18,NEWPREF)=DFTSET($J) 91 ; reset User name, Setting name. 92 S $P(^MAG(2006.18,NEWPREF,0),U,1,4)=N0 93 Q 94 DEFUSER(NEWPREF,DFTPREF) ;Merge New User preference with the Default User as defined 95 ; in the Imaging Site Parameters file 96 ; NEWPREF = new IMAGING USER PREFERENCE (IEN) 97 ; DFLTPREF = DEFAULT USER PREFERENCE in the IMAGING SITE PARAMETERS File 98 ; 99 N X0 100 S X0=$P(^MAG(2006.18,NEWPREF,0),"^",1,4) 101 M ^MAG(2006.18,NEWPREF)=^MAG(2006.18,DFTPREF) 102 S $P(^MAG(2006.18,NEWPREF,0),"^",1,4)=X0 103 ; remove default user's default Filter from new user's preferences. 104 S $P(^MAG(2006.18,NEWPREF,"LISTWIN1"),"^",3)="" 105 Q 106 DFLTARR(ARR) ; Return an Array of All Default settings 107 K ARR($J) 108 S ARR($J,0)="^^^^0^1^1^" 109 S ARR($J,"DICOMWIN")="2^320^292^724^487" 110 S ARR($J,"IMAGEGRID")="2^487^2^786^426^1^35,73,67,34,110,46,69,96,76,79,25,0,0^1^" 111 S ARR($J,"REPORT")="2^2^333^722^437^Courier^^10" 112 S ARR($J,"RADLISTWIN")="2^487^10^433^172^0" 113 S ARR($J,"MAIN")="2^1^1^487^172^1" 114 S ARR($J,"ABS")="2^1^160^486^326^134^113^1^1^3^24^2^1^0" 115 S ARR($J,"FULL")="2^310^282^714^487^674^447^^1^1^4^1^0^1" 116 S ARR($J,"GROUP")="2^24^231^427^457^110^70^^1^2^24^2^1^0" 117 S ARR($J,"DOC")="2^298^24^729^429^0^0^3^1^2^4^2^0" 118 S ARR($J,"CAPCONFIG")="1^1^1^0^0^0^0^1^0^1^0^0^1^1^0^0^1^1^1^1^1^1^200^400^300^100^500^0^0^1^0^1" 119 ; 1 2 3 4 5 6 7 8 9 0 1 2 3 456 7 8 120 S ARR($J,"CAPTIU")="261^414^455^654^66^67^280^1^1^~^1^100^-12^^^1^1^^" 121 S ARR($J,"RIVER")="1^0^0^0^" 122 S ARR($J,"APPMSG")="0^0^" 123 S ARR($J,"APPPREFS")="1^7^7^10" 124 S ARR($J,"LISTWIN1")="1^1^^1^1" 125 Q 1 MAGGTUP ;WOIFO/GEK - Imaging System User preferences ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;**7,8,48,45**;Sep 12, 2005 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 Q 19 GET(MAGRY,CODE) ;RPC [MAGGUPREFGET] Call to Get user preferences. 20 ; 21 N Y,PRFIEN,J,X,Z,NODE,MAGPREF 22 N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR" 23 K MAGRY 24 S MAGRY(0)="0^Error: Attempting to access user preference" 25 S PRFIEN=$O(^MAG(2006.18,"AC",DUZ,"")) 26 ; if first time user 27 I 'PRFIEN S PRFIEN=$$NEWUSER(DUZ) Q:PRFIEN=-1 28 ; merge default settings into User's Preferences 29 D MERGE(PRFIEN) 30 ; This returns the users default Filter, and creates filters if needed. 31 S $P(^MAG(2006.18,PRFIEN,"LISTWIN1"),"^",3)=$$DFTFLT^MAGGSFLT(DUZ) 32 S MAGRY(0)="1^User Preferences returned." 33 ; 34 ; At This point. Then entry in 2006.18 for User DUZ in complete 35 ; it has been merged with defaults, and has a valid Default Filter. 36 ; 37 ; if caller only wants one node, get it then quit. 38 I $L($G(CODE)) S MAGRY($O(MAGRY(""),-1)+1)=CODE_"^"_$G(^MAG(2006.18,PRFIEN,CODE)) Q 39 ; 40 ; loop through User Pref file, returning all nodes. 41 ; Next line was Un-Commented out. BUT Clients before Patch 8 need it. 42 S MAGRY($O(MAGRY(""),-1)+1)="SYS^"_^MAG(2006.18,PRFIEN,0) 43 S NODE="" 44 F S NODE=$O(^MAG(2006.18,PRFIEN,NODE)) Q:(NODE="") D 45 . S MAGRY($O(MAGRY(""),-1)+1)=NODE_"^"_^MAG(2006.18,PRFIEN,NODE) 46 Q 47 MERGE(PRFIEN) ; Merge default settings into User Prefs returned. 48 ; This will assure the User Prefs returned have values for New fields. 49 ; PRFIEN = IEN in IMAGING USER PREFERENCES File. 50 N NODE,DARR,MN,YN 51 D DFLTARR(.DARR) 52 S NODE="" F S NODE=$O(DARR($J,NODE)) Q:(NODE="") D 53 . S YN=DARR($J,NODE) 54 . S MN=$G(^MAG(2006.18,PRFIEN,NODE)) 55 . F J=1:1:$L(YN,"^") I ($P(YN,"^",J)'=""),($P(MN,"^",J)="") S $P(MN,"^",J)=$P(YN,"^",J) 56 . S ^MAG(2006.18,PRFIEN,NODE)=MN 57 ; 58 Q 59 SAVE(MAGRY,DATA) ;RPC [MAGGUPREFSAVE] Call to save User Preferences 60 ; 61 S MAGRY="0^Error: Saving user preferences." 62 N X,Y,NODE,PRFIEN,J 63 N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" 64 S PRFIEN=$O(^MAG(2006.18,"AC",DUZ,"")) I 'PRFIEN S PRFIEN=$$NEWUSER(DUZ) Q:PRFIEN=-1 65 S NODE="" F S NODE=$O(DATA(NODE)) Q:NODE="" D 66 . S X=$G(^MAG(2006.18,PRFIEN,NODE)) 67 . S Y=DATA(NODE) 68 . F J=1:1:$L(Y,"^") I $L($P(Y,"^",J)) S $P(X,"^",J)=$P(Y,"^",J) 69 . S ^MAG(2006.18,PRFIEN,NODE)=X 70 S MAGRY="1^User Preferences saved." 71 Q 72 NEWUSER(USER) ;Returns IEN of New entry in IMAGING USER PREFERENCES File. 73 K DD,DO 74 N DIC 75 S X=$E($$GET1^DIQ(200,USER_",",.01),1,15)_" (SETTING 1)" 76 S DIC="^MAG(2006.18,",DIC(0)="L" 77 S DIC("DR")="1////"_USER_";2////12;3////12;" D FILE^DICN 78 I Y=-1 Q Y 79 D DEFAULT(+Y) 80 Q +Y 81 DEFAULT(NEWPREF) ;Setup a new IMAGING USER PREFERENCES entry, with System defaults. 82 ; NEWPREF = IEN in IMAGING USER PREFERENCES File 83 N DFTPREF,N0,DFTSET 84 S DFTPREF=+$$GET1^DIQ(2006.1,$$PLACE^MAGBAPI(DUZ(2)),100,"I") ; DBI - SEB 9/20/2002 85 I DFTPREF,$D(^MAG(2006.18,DFTPREF)) D DEFUSER(NEWPREF,DFTPREF) Q 86 ; save the User name, Setting Name 87 S N0=$P(^MAG(2006.18,NEWPREF,0),U,1,4) 88 D DFLTARR(.DFTSET) 89 M ^MAG(2006.18,NEWPREF)=DFTSET($J) 90 ; reset User name, Setting name. 91 S $P(^MAG(2006.18,NEWPREF,0),U,1,4)=N0 92 Q 93 DEFUSER(NEWPREF,DFTPREF) ;Merge New User preference with the Default User as defined 94 ; in the Imaging Site Parameters file 95 ; NEWPREF = new IMAGING USER PREFERENCE (IEN) 96 ; DFLTPREF = DEFAULT USER PREFERENCE in the IMAGING SITE PARAMETERS File 97 ; 98 N X0 99 S X0=$P(^MAG(2006.18,NEWPREF,0),"^",1,4) 100 M ^MAG(2006.18,NEWPREF)=^MAG(2006.18,DFTPREF) 101 S $P(^MAG(2006.18,NEWPREF,0),"^",1,4)=X0 102 ; remove default user's default Filter from new user's preferences. 103 S $P(^MAG(2006.18,NEWPREF,"LISTWIN1"),"^",3)="" 104 Q 105 DFLTARR(ARR) ; Return an Array of All Default settings 106 K ARR($J) 107 S ARR($J,0)="^^^^0^1^1^" 108 S ARR($J,"DICOMWIN")="2^320^292^724^487" 109 S ARR($J,"IMAGEGRID")="2^487^2^786^426^1^35,73,67,34,110,46,69,96,76,79,25,0,0^1^" 110 S ARR($J,"REPORT")="2^2^333^722^437^Courier^^10" 111 S ARR($J,"RADLISTWIN")="2^487^10^433^172^0" 112 S ARR($J,"MAIN")="2^1^1^487^172^1" 113 S ARR($J,"ABS")="2^1^160^486^326^134^113^1^1^3^24^2^1^0" 114 S ARR($J,"FULL")="2^310^282^714^487^674^447^^1^1^4^1^0^1" 115 S ARR($J,"GROUP")="2^24^231^427^457^110^70^^1^2^24^2^1^0" 116 S ARR($J,"DOC")="2^298^24^729^429^0^0^3^1^2^4^2^0" 117 S ARR($J,"CAPCONFIG")="1^1^1^0^0^0^0^1^0^1^0^0^1^1^0^0^1^1^1^1^1^1^200^400^300^100^500^0^0^1^" 118 S ARR($J,"CAPTIU")="5^369^760^654^289^67^170^1^1^" 119 S ARR($J,"RIVER")="1^0^0^0^" 120 S ARR($J,"APPPREFS")="1^7^7^10" 121 S ARR($J,"LISTWIN1")="1^1^^1^1" 122 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGJEX1B.m
r613 r623 1 MAGJEX1B 2 ;;3.0;IMAGING;**16,22,18,65,76**;Jun 22, 2007;Build 19 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 IMGLOOP 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 IMGLOOPZ 64 65 66 LOCKIN(RARPT,LOCKLEV,MYLOCK,LOCKCHK) 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 REMLOCK 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 S TS="" F I=2,0 S TS=TS_$S(TS="":"",1:U)_$$HTFM^XLFDT($H+I,0) 118 119 120 121 122 END 1 MAGJEX1B ;WIRMFO/JHC Rad. Workstation RPC calls ; 29 Jul 2003 9:58 AM 2 ;;3.0;IMAGING;**16,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 ; Subroutines for fetch exam images, exam lock/reserve, remove dangling locks 21 ; 22 IMGLOOP ; get data for all the images 23 ; This subroutine is called from MAGJEX1 24 ; MAGGRY holds $NA reference to ^TMP where Broker return message is assembled; 25 ; all references to MAGGRY use subscript indirection 26 N DFN,IMGREC,P18ALTP 27 I '$D(MAGJOB("ALTPATH")) S MAGJOB("ALTPATH")=0 ; facilitates testing 28 F IMAG=MAGSTRT:1:MAGEND S MAGIEN=$P(MAGS(IMAG),U,4) D 29 . S DFN=$P(MAGS(IMAG),U,8) 30 . I DFN=RADFN S MIXEDUP(RADFN)="" ;ok 31 . E S:'DFN DFN=0 S MIXEDUP=MIXEDUP+2,MIXEDUP(DFN)="" ; database corruption 32 . S MDL=$P(MAGS(IMAG),U,3) 33 . I MDL="DR" S MDL="CR" ; for now, hard code cx of non-standard code 34 . I $G(SERBRK),(SERLBL]"") D ; mark Begin of series 35 . . S CT=CT+1,@MAGGRY@(CT+STARTNOD)=SERLBL,SERLBL="" 36 . S MAGXX=MAGIEN D 37 . . I 'USETGA,($P(MAGS(IMAG),U,2)["BIG") D BIG^MAGFILEB Q 38 . . E D VST^MAGFILEB 39 . I MAGJOB("ALTPATH") S X=$P(MAGS(IMAG),U,6),P18ALTP="" I X]"" D 40 . . F I=1:1:$L(X,",") S T=$P(X,",",I) I T S CURPATHS(T)="" I 'MAGJOB("P32"),$D(MAGJOB("LOC",T)) S P18ALTP=P18ALTP_$S(P18ALTP="":"",1:",")_T 41 . S IMGREC="B2^"_MAGIEN_U_MAGFILE2 42 . I 'MAGJOB("P32") D 43 . . S T="",X=$P(MAGS(IMAG),U,11) I X]"" F I="K","I","U" I X[I,$D(PSIND(I)) S T=T_$S(T="":"",1:",")_I ; PS_Indicators 44 . . S IMGREC=IMGREC_U_T_U_$S(MAGJOB("ALTPATH"):P18ALTP,1:"") ; AltPaths for this img 45 . . I '(PROCDT]"") D ; Img Process Date 46 . . . S X=$P(MAGS(IMAG),U,12) I X]"" S T=$S($E(X)=3:20,$E(X)=2:19,1:"") I T S PROCDT=T_$E(X,2,7) 47 . . I '(ACQSITE]"") D ; Acq Site 48 . . . S X=$P(MAGS(IMAG),U,13) I X]"" S ACQSITE=X 49 . S CT=CT+1,@MAGGRY@(CT+STARTNOD)=IMGREC 50 . I MODALITY="" D 51 . . I 'MAGJOB("P32") S MODALITY=MDL Q 52 . . N T S T=$P("1dummy1^CT^CR^MR^US^AS^CD^CS^DG^EC^FA^LP^MA^PT^ST^XA^NM^OT^BI^CP^DD^DM^ES^FS^LS^MS^RG^TG^RF^RTIMAGE^RTSTRUCT^HC^RTDOSE^RTPLAN^RTRECORD^DX^MG^IO^PX",U_MDL_U,1) 53 . . S MODALITY=$L(T,U) 54 . . I MODALITY>38 S MODALITY=9999 ; 38=TOTAL # modalities defined; else 9999 55 . . I STKLAY S OPENCNT=0 ; no limit on WS for # of exams open in StackVwr 56 ; 57 I 'MAGJOB("ALTPATH") S ALTPATH=-1 58 E D 59 . S T=0 F S T=$O(CURPATHS(T)) Q:'T I $D(MAGJOB("LOC",T)) Q 60 . S ALTPATH=$S('T:0,1:1) 61 . I ALTPATH=$P(MAGJOB("ALTPATH"),U,2) S ALTPATH=-1 62 . E S $P(MAGJOB("ALTPATH"),U,2)=ALTPATH 63 IMGLOOPZ Q 64 ; 65 ; 66 LOCKIN(RARPT,LOCKLEV,MYLOCK,LOCKCHK) ; init lock-related info B4 do any lock actions 67 ; called from UTL3 & EX1A 68 ; if LOCKCHK="STATUS", only return current status 69 ; Input RARPT (required) and LOCKCHK (opt) 70 ; Output: LOCKLEV & MYLOCK array; successful LOCKS left intact, unless LOCKCHK="STATUS" 71 ; M LOCKS det. what Actions are possible by calling program modules 72 ; MYLOCK(1/2)= Lock_is_Mine ^ DUZ ^ $J ^ User Name ^ User Init ^ Case # 73 ; LOCKLEV=0:3--is/not 1-Lockable/2-Reservable/3-Both to user 74 ; MYLOCK=0:3--is/not already 1-Locked/2-Reserved/3-Both by user 75 ; 76 N CKMINE,CASENO,XX,XY,ILOCK 77 S LOCKCHK=$G(LOCKCHK)="STATUS" 78 S LOCKLEV=0 K MYLOCK S MYLOCK=0 79 L +^XTMP("MAGJ","LOCK",RARPT):0 80 I S LOCKLEV=3 81 L +^XTMP("MAGJ","LOCK",RARPT,1):0 ; "1" for Exam "LOCK" 82 I S:'LOCKLEV LOCKLEV=1 83 L +^XTMP("MAGJ","LOCK",RARPT,2):0 ; "2" for Exam "RESERVE" 84 I S LOCKLEV=$S('LOCKLEV:2,1:3) 85 L -^XTMP("MAGJ","LOCK",RARPT) 86 S CKMINE=DUZ_U_$J 87 F ILOCK=1,2 D 88 . S XX="",XY="",CASENO=$G(^XTMP("MAGJ","LOCK",RARPT,ILOCK)) 89 . I CASENO]"" S XX=$G(^XTMP("MAGJ","LOCK",RARPT,ILOCK,CASENO)),XY=$P(XX,"|",2),XX=$P(XX,"|") 90 . S X=$P(XX,U,1,2),MYLOCK(ILOCK)=(X=CKMINE) 91 . S X=$P(XX,U)_U_$P(XX,U,2)_U_$P(XX,U,4)_U_$P(XX,U,5)_U_CASENO_U_"|"_XY 92 . S MYLOCK(ILOCK)=MYLOCK(ILOCK)_U_X 93 . I MYLOCK(ILOCK) S MYLOCK=MYLOCK+ILOCK 94 I LOCKCHK,LOCKLEV D ; reset locks for Lock check 95 . I LOCKLEV=1!(LOCKLEV=3) L -^XTMP("MAGJ","LOCK",RARPT,1) 96 . I LOCKLEV=2!(LOCKLEV=3) L -^XTMP("MAGJ","LOCK",RARPT,2) 97 Q 98 ; 99 REMLOCK ; Remove dangling exam locks; this is run only at Logon 100 ; If a recorded lock is found that a new job (logon) can M-Lock 101 ; then that is a dangling lock that must be removed 102 N RARPT,TS,LOCKLEV,MYLOCK,ACTION,DAYCASE,ILOCK,RESULT 103 S RARPT="" 104 F S RARPT=$O(^XTMP("MAGJ","LOCK",RARPT)) Q:'RARPT D ; loop thru recorded locks 105 . D LOCKIN(RARPT,.LOCKLEV,.MYLOCK) 106 . I 'LOCKLEV Q ;unable to lock--is ok 107 . S ACTION="",DAYCASE="" 108 . F ILOCK=1,2 I $D(^XTMP("MAGJ","LOCK",RARPT,ILOCK)) S XX=^(ILOCK) D 109 . . I DAYCASE="" S DAYCASE=$P(XX,U) 110 . . I ILOCK=1,(LOCKLEV=1!(LOCKLEV=3)) S $P(ACTION,U,1)=1 111 . . I ILOCK=2,(LOCKLEV=2!(LOCKLEV=3)) S $P(ACTION,U,2)=1 112 . I 'ACTION,'+$P(ACTION,U,2),(DAYCASE="") D Q ; should never occur, but 113 . . I LOCKLEV=1!(LOCKLEV=3) L -^XTMP("MAGJ","LOCK",RARPT,1) 114 . . I LOCKLEV=2!(LOCKLEV=3) L -^XTMP("MAGJ","LOCK",RARPT,2) 115 . D LOCKOUT^MAGJEX1A(RARPT,DAYCASE,.LOCKLEV,.MYLOCK,ACTION,.RESULT) ; 1st, lock to me 116 . K LOCKLEV,MYLOCK D LOCKACT^MAGJEX1A(RARPT,DAYCASE,101,.RESULT) ; then, clear the lock 117 S TS="" F I=2,0 S %H=$H+I D YMD^%DTC S TS=TS_$S(TS="":"",1:U)_X 118 S ^XTMP("MAGJ",0)=TS_U_"VistaRad Locks" 119 Q 120 ; 121 ; 122 END ; -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGJEX2.m
r613 r623 1 MAGJEX2 ;;WIRMFO/JHC Rad. Workstation RPC calls;[ 02/25/2000 4:40 PM ] ; 09 Jun 2003 2:58 PM 2 ;;3.0;IMAGING;**51,18,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 ; Subroutines for pre-fetch/ auto-display prior exams' images 21 ; Entry Points: 22 ; PRIOR1 -- Pre-Fetch/Auto-Display images for other related cases; 23 ; RPC Call: MAGJ PRIOREXAMS 24 ; PREFETCH -- Pre-Fetch initiated from 25 ; 26 Q 27 ERR N ERR S ERR=$$EC^%ZOSV S MAGGRY(0)="0^Server Program Error: "_ERR 28 D @^%ZOSF("ERRTN") 29 Q:$Q 1 Q 30 PREFETCH ; Entry point from HL7 processing, to initiate prefetch at 31 ; time of radiology "Register Patient for Exam" function 32 ; Do not process if the exam is being Canceled (RACANC true) 33 ; 34 N RET S RET="" 35 I '$P($G(^MAG(2006.69,1,0)),U,5) G PREFQ ; Prefetch disabled 36 I '($G(RADFN)&$G(RADTI)&$G(RACNI)&'$G(RACANC)) G PREFQ ; Required vars 37 D PRIOR1(.RET,"P"_U_RADFN_U_RADTI_U_RACNI) 38 PREFQ ; W !,"End PRE-FETCH RET=" N JHC R JHC ZW RET 39 Q 40 ; 41 PRIOR1(MAGGRY,DATA) ; review all exams for a patient to find "related" exams 42 ; This ep also called as subroutine from routing software (P51) 43 ; MAGGRY - return array of exams to PreFetch, or Auto-send to RAD W/S 44 ; DATA: - input params for the Current Exam 45 ; 1) ACTION = P -- Pre-fetch Exams (from Jukebox to Magnetic Disk) 46 ; = A -- Auto-route priors 47 ; 2) RADFN = Case pointers to Rad/Nuc Med Patient file 48 ; 3) RADTI = "" "" "" "" 49 ; 4) RACNI = "" "" "" "" 50 ; 5) RARPT - Case pointer to ^RARPT global 51 ; 52 N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJEX2" 53 K MAGGRY 54 N RADFN,RADTI,RACNI,RARPT,RADATA 55 N DAYCASE,DIQUIET,ACTION,CPT,HDR,MAGDFN,MAGDTI,MAGCNI,MAGRET,MAGRACNT 56 S ACTION=$P(DATA,U) 57 I ACTION="P"!(ACTION="A") 58 E S MAGGRY(0)="0^Invalid Request (Action code="_ACTION_")" G PRIOR1Z 59 S MAGDFN=$P(DATA,U,2),MAGDTI=$P(DATA,U,3),MAGCNI=$P(DATA,U,4) 60 I MAGDFN,MAGDTI,MAGCNI 61 E S MAGGRY(0)="0^Request Contains Invalid Case Pointer ("_DATA_")" G PRIOR1Z 62 S DIQUIET=1 D DT^DICRW 63 N MAGJOB D MAGJOBNC^MAGJUTL3 64 S HDR=$S(ACTION="P":"Pre-fetch",ACTION="A":"Auto-Display",1:"???")_" Prior Exams for CASE: " 65 I '$D(^DPT(MAGDFN,0)) S MAGGRY(0)="0^Request Contains Invalid Patient Pointer ("_MAGDFN_")" G PRIOR1Z 66 I $D(^RADPT(MAGDFN,"DT",MAGDTI,"P",MAGCNI)) 67 E S MAGGRY(0)="0^Request Contains Invalid Case Pointer ("_MAGCNI_")" G PRIOR1Z 68 S MAGRACNT=0 69 S MAGGRY(0)="0^Compiling Prior Radiology Exams" 70 D GETEXAM2^MAGJUTL1(MAGDFN,MAGDTI,MAGCNI,"",.MAGRET) ; Current Exam only 71 S RADFN=MAGDFN,RADTI=MAGDTI,RACNI=MAGCNI 72 I 'MAGRET S MAGGRY(0)="0^Current Case is Not Accessible" G PRIOR1Z 73 S RADATA=$G(^TMP($J,"MAGRAEX",1,1)) S DAYCASE=$P(RADATA,U,12) D SVMAG2A 74 I 'MAGGRY(0) S MAGGRY(0)="0^Current Case either has no CPT code, or has no rules defined for its CPT code." G PRIOR1Z 75 S HDR=HDR_DAYCASE 76 D SRCH(MAGDFN) ; Search prior exams for this patient 77 PRIOR1Z ; 78 I 'MAGGRY(0) S:(MAGGRY(0)["Compiling") MAGGRY(0)="0^No Exams Found" 79 E I +MAGGRY(0)=1 S MAGGRY(0)="0^No Prior Exams Found" K MAGGRY(1) 80 E D SVMAG2B 81 K ^TMP($J,"MAGRAEX"),^("RAE1") 82 Q 83 ; 84 SRCH(RADFN) ; Traverse all exams for a patient, up to limits of age & total 85 ; numbers of exams to consider 86 N BEGDT,LIMYRS,LIMEXAMS,X 87 S X=$G(^MAG(2006.69,1,0)) 88 S LIMYRS=+$P(X,U,14),LIMEXAMS=+$P(X,U,15) 89 S:'LIMYRS LIMYRS=7 S:'LIMEXAMS LIMEXAMS=50 ; default limit # Exams 90 S BEGDT=($E(DT,1,3)-LIMYRS)_$E(DT,4,7) 91 I BEGDT<2950101 S BEGDT=2950101 ; 2 yrs prior to earliest VistaPACS 92 S MAGRACNT=1 D GETEXAM3^MAGJUTL1(RADFN,BEGDT,"",.MAGRACNT,.MAGRET,"",LIMEXAMS) 93 I MAGRET N IDAT S IDAT=1 D 94 . F S IDAT=$O(^TMP($J,"MAGRAEX",IDAT)) Q:'IDAT S RADATA=^(IDAT,1) D 95 .. S RADTI=$P(RADATA,U,2),RACNI=$P(RADATA,U,3) 96 .. I RADTI=MAGDTI&(RACNI=MAGCNI) Q ; skip current case 97 .. D SVMAG2A 98 Q 99 ; 100 SVMAG2A ; 2A and 2B used by subroutine at tag PRIOR1 101 ; Find all the patient's exams whose CPT codes are related to the 102 ; Current exam's CPT code, according to dictionary 2006.65 103 N RAIMGTYP 104 N CPT,CPT3,CPT4,CPT5,CURCPTX,CURCPTS,HIT,MAGMATCH,MAGDTH 105 S RARPT=+$P(RADATA,U,10) 106 I MAGGRY(0) Q:'$P(MAGGRY(1),U) ; Cur Case CPT not in map file 107 I Q:(ACTION="P")&'$D(^RARPT(RARPT,2005)) ; nothing to pre-fetch 108 I Q:$P(RADATA,U,15)<2 ; Cancel or Waiting 109 ; Note: if no images, may still want to do Auto-Disp to get Report; 110 ; also, Current Case should still proceed 111 S CPT=$P(RADATA,U,17) 112 Q:'CPT ; algorithm REQUIRES CPT codes be used 113 S CPT5=CPT,CPT4=$E(CPT,1,4),CPT3=$E(CPT,1,3) 114 S MAGMATCH="^^" 115 I 'MAGGRY(0) D Q:'MAGMATCH ; No rules defined for Cur. Case's CPT 116 . S Y="" 117 . ; Order of CPT5/4/3 is important for the algorithm, which 118 . ; uses the 1st rule found at the LOWEST level of detail defined 119 . F X=CPT5,CPT4,CPT3 I $D(^MAG(2006.65,"B",X)) S Y=Y_$S(Y:",",1:"")_X S $P(MAGMATCH,U)=Y 120 I CPT,MAGGRY(0) D 121 . ; curcpts has the cpt5/4/3 list generated above for Cur. Case CPT's 122 . S HIT=0,CURCPTS=$P(MAGGRY(1),U) 123 . F Q:CURCPTS="" S CURCPTX=$O(^MAG(2006.65,"B",$P(CURCPTS,","),"")) S CURCPTS=$P(CURCPTS,",",2,9) I CURCPTX]"" D Q:HIT ; 1st hit only 124 .. ; This algorithm checks from lowest detail to most general, and acts 125 .. ; on the information found at the FIRST Hit only 126 .. F CPT="CPT5","CPT4","CPT3" S CPT=@CPT I CPT]"",$D(^MAG(2006.65,CURCPTX,1,"B",CPT)) S X=$O(^(CPT,"")) D S HIT=1 Q ;1st hit only 127 ... S X=^MAG(2006.65,CURCPTX,1,X,0) S Y=$S(ACTION="A":2,1:5),X=$P(X,U,Y,Y+2) 128 ... I +X S MAGMATCH=CPT F I=2,3 S $P(MAGMATCH,U,I)=$P(X,U,I) 129 ; sample of logic file: 130 ; ^MAG(2006.65,1,0) = 730 131 ; ^MAG(2006.65,1,1,0) = ^12000011.01^2^2 132 ; ^MAG(2006.65,1,1,1,0) = 730^1^40^6^1^120^10 133 ; ^MAG(2006.65,1,1,2,0) = 732^1^40^2^1^120^4 134 ; ^MAG(2006.65,1,1,"B",730,1) = 135 ; ^MAG(2006.65,1,1,"B",732,2) = 136 ; ^MAG(2006.65,"B",730,1) = 137 ; 138 Q:'MAGMATCH 139 ; 1 RADFN RADTI RACNI RANME RASSN <-- from GETEXAM 140 ; 6 RADATE RADTE RACN RAPRC RARPT 141 ; 11 RAST DAYCASE RAELOC RASTP RASTORD 142 ; 16 RADTPRT RACPT RAIMGTYP 143 S MAGDTH=$$FMTH^XLFDT($P(RADATA,U,7),1) 144 S X=$P(RADATA,U,18) 145 S RAIMGTYP=$S(X]"":$O(^RA(79.2,"C",X,"")),1:X) 146 S Y=MAGGRY(0)+1,$P(MAGGRY(0),U)=Y,MAGGRY(Y)=MAGMATCH_U_MAGDTH_U_U_$P(RADATA,U,9)_U_RAIMGTYP_U_RADFN_U_RADTI_U_RACNI_U_RARPT_U_$P(RADATA,U,12)_U_$P(RADATA,U,11) 147 Q 148 ; 149 SVMAG2B ; For exams whose CPTs match, select a subset that are within defined 150 ; limits with respect to time interval & maximum # exams to retrieve 151 ; Return MAGGRY(0) = count ^ message 152 ; MAGGRY(1:N) = "M08" | RADFN ^ RADTI ^ RACNI ^ RARPT 153 N CPT,CT,CURDAT,ICPT,IREC,GO 154 S CURDAT=$P(MAGGRY(1),U,4) 155 F IREC=2:1:MAGGRY(0) S X=MAGGRY(IREC),CPT=+X D K MAGGRY(IREC) 156 . I $P(X,U,2) S Y=CURDAT-$P(X,U,4) S:Y<0 Y=-Y I Y>$P(X,U,2) Q ;too old 157 . S Y=$G(GO(CPT))+1 I CPT,(Y>$P(X,U,3)) Q ; already have enough cases 158 . S GO(CPT)=Y,GO(CPT,Y)=X 159 K MAGGRY 160 I $D(GO) S CT=0,CPT="" D 161 . F S CPT=$O(GO(CPT)) Q:CPT="" F ICPT=1:1:GO(CPT) D 162 .. S CT=CT+1,X=GO(CPT,ICPT),RARPT=$P(X,U,11) 163 .. S MAGGRY(CT)="M08^"_CPT_"|"_$P(X,U,8,11) 164 .. I ACTION="P"!(ACTION="A") S Y=$$JBFETCH^MAGJUTL2(RARPT) ; fetch from jukebox 165 . S MAGGRY(0)=CT_"^"_HDR 166 E S MAGGRY(0)="0^No Exams Found for "_HDR 167 Q 168 ; 169 END ; 1 MAGJEX2 ;;WIRMFO/JHC Rad. Workstation RPC calls;[ 02/25/2000 4:40 PM ] ; 09 Jun 2003 2:58 PM 2 ;;3.0;IMAGING;**51,18**;Mar 07, 2006 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 Q 19 ; Subroutines for pre-fetch/ auto-display prior exams' images 20 ; Entry Points: 21 ; PRIOR1 -- Pre-Fetch/Auto-Display images for other related cases; 22 ; RPC Call: MAGJ PRIOREXAMS 23 ; PREFETCH -- Pre-Fetch initiated from 24 ; 25 Q 26 ERR N ERR S ERR=$$EC^%ZOSV S MAGGRY(0)="0^Server Program Error: "_ERR 27 D @^%ZOSF("ERRTN") 28 Q:$Q 1 Q 29 PREFETCH ; Entry point from HL7 processing, to initiate prefetch at 30 ; time of radiology "Register Patient for Exam" function 31 ; Do not process if the exam is being Canceled (RACANC true) 32 ; 33 N RET S RET="" 34 I '$P($G(^MAG(2006.69,1,0)),U,5) G PREFQ ; Prefetch disabled 35 I '($G(RADFN)&$G(RADTI)&$G(RACNI)&'$G(RACANC)) G PREFQ ; Required vars 36 D PRIOR1(.RET,"P"_U_RADFN_U_RADTI_U_RACNI) 37 PREFQ ; W !,"End PRE-FETCH RET=" N JHC R JHC ZW RET 38 Q 39 ; 40 PRIOR1(MAGGRY,DATA) ; review all exams for a patient to find "related" exams 41 ; This ep also called as subroutine from routing software (P51) 42 ; MAGGRY - return array of exams to PreFetch, or Auto-send to RAD W/S 43 ; DATA: - input params for the Current Exam 44 ; 1) ACTION = P -- Pre-fetch Exams (from Jukebox to Magnetic Disk) 45 ; = A -- Auto-route priors 46 ; 2) RADFN = Case pointers to Rad/Nuc Med Patient file 47 ; 3) RADTI = "" "" "" "" 48 ; 4) RACNI = "" "" "" "" 49 ; 5) RARPT - Case pointer to ^RARPT global 50 ; 51 N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJEX2" 52 K MAGGRY 53 N RADFN,RADTI,RACNI,RARPT,RADATA 54 N DAYCASE,DIQUIET,ACTION,CPT,HDR,MAGDFN,MAGDTI,MAGCNI,MAGRET,MAGRACNT 55 S ACTION=$P(DATA,U) 56 I ACTION="P"!(ACTION="A") 57 E S MAGGRY(0)="0^Invalid Request (Action code="_ACTION_")" G PRIOR1Z 58 S MAGDFN=$P(DATA,U,2),MAGDTI=$P(DATA,U,3),MAGCNI=$P(DATA,U,4) 59 I MAGDFN,MAGDTI,MAGCNI 60 E S MAGGRY(0)="0^Request Contains Invalid Case Pointer ("_DATA_")" G PRIOR1Z 61 S DIQUIET=1 D DT^DICRW 62 N MAGJOB D MAGJOBNC^MAGJUTL3 63 S HDR=$S(ACTION="P":"Pre-fetch",ACTION="A":"Auto-Display",1:"???")_" Prior Exams for CASE: " 64 I '$D(^DPT(MAGDFN,0)) S MAGGRY(0)="0^Request Contains Invalid Patient Pointer ("_MAGDFN_")" G PRIOR1Z 65 I $D(^RADPT(MAGDFN,"DT",MAGDTI,"P",MAGCNI)) 66 E S MAGGRY(0)="0^Request Contains Invalid Case Pointer ("_MAGCNI_")" G PRIOR1Z 67 S MAGRACNT=0 68 S MAGGRY(0)="0^Compiling Prior Radiology Exams" 69 D GETEXAM2^MAGJUTL1(MAGDFN,MAGDTI,MAGCNI,"",.MAGRET) ; Current Exam only 70 S RADFN=MAGDFN,RADTI=MAGDTI,RACNI=MAGCNI 71 I 'MAGRET S MAGGRY(0)="0^Current Case is Not Accessible" G PRIOR1Z 72 S RADATA=$G(^TMP($J,"MAGRAEX",1,1)) S DAYCASE=$P(RADATA,U,12) D SVMAG2A 73 I 'MAGGRY(0) S MAGGRY(0)="0^Current Case either has no CPT code, or has no rules defined for its CPT code." G PRIOR1Z 74 S HDR=HDR_DAYCASE 75 D SRCH(MAGDFN) ; Search prior exams for this patient 76 PRIOR1Z ; 77 I 'MAGGRY(0) S:(MAGGRY(0)["Compiling") MAGGRY(0)="0^No Exams Found" 78 E I +MAGGRY(0)=1 S MAGGRY(0)="0^No Prior Exams Found" K MAGGRY(1) 79 E D SVMAG2B 80 K ^TMP($J,"MAGRAEX"),^("RAE1") 81 Q 82 ; 83 SRCH(RADFN) ; Traverse all exams for a patient, up to limits of age & total 84 ; numbers of exams to consider 85 N BEGDT,LIMYRS,LIMEXAMS,X 86 S X=$G(^MAG(2006.69,1,0)) 87 S LIMYRS=+$P(X,U,14),LIMEXAMS=+$P(X,U,15) 88 S:'LIMYRS LIMYRS=10 S:'LIMEXAMS LIMEXAMS=100 ; default limit # Exams 89 S BEGDT=($E(DT,1,3)-LIMYRS)_$E(DT,4,7) 90 I BEGDT<2950101 S BEGDT=2950101 ; 2 yrs prior to earliest VistaPACS 91 S MAGRACNT=1 D GETEXAM3^MAGJUTL1(RADFN,BEGDT,"",.MAGRACNT,.MAGRET,"",LIMEXAMS) 92 I MAGRET N IDAT S IDAT=1 D 93 . F S IDAT=$O(^TMP($J,"MAGRAEX",IDAT)) Q:'IDAT S RADATA=^(IDAT,1) D 94 .. S RADTI=$P(RADATA,U,2),RACNI=$P(RADATA,U,3) 95 .. I RADTI=MAGDTI&(RACNI=MAGCNI) Q ; skip current case 96 .. D SVMAG2A 97 Q 98 ; 99 SVMAG2A ; 2A and 2B used by subroutine at tag PRIOR1 100 ; Find all the patient's exams whose CPT codes are related to the 101 ; Current exam's CPT code, according to dictionary 2006.65 102 N RAIMGTYP 103 N CPT,CPT3,CPT4,CPT5,CURCPTX,CURCPTS,HIT,MAGMATCH,MAGDTH 104 S RARPT=+$P(RADATA,U,10) 105 I MAGGRY(0) Q:'$P(MAGGRY(1),U) ; Cur Case CPT not in map file 106 I Q:(ACTION="P")&'$D(^RARPT(RARPT,2005)) ; nothing to pre-fetch 107 I Q:$P(RADATA,U,15)<2 ; Cancel or Waiting 108 ; Note: if no images, may still want to do Auto-Disp to get Report; 109 ; also, Current Case should still proceed 110 S CPT=$P(RADATA,U,17) 111 Q:'CPT ; algorithm REQUIRES CPT codes be used 112 S CPT5=CPT,CPT4=$E(CPT,1,4),CPT3=$E(CPT,1,3) 113 S MAGMATCH="^^" 114 I 'MAGGRY(0) D Q:'MAGMATCH ; No rules defined for Cur. Case's CPT 115 . S Y="" 116 . ; Order of CPT5/4/3 is important for the algorithm, which 117 . ; uses the 1st rule found at the LOWEST level of detail defined 118 . F X=CPT5,CPT4,CPT3 I $D(^MAG(2006.65,"B",X)) S Y=Y_$S(Y:",",1:"")_X S $P(MAGMATCH,U)=Y 119 I CPT,MAGGRY(0) D 120 . ; curcpts has the cpt5/4/3 list generated above for Cur. Case CPT's 121 . S HIT=0,CURCPTS=$P(MAGGRY(1),U) 122 . F Q:CURCPTS="" S CURCPTX=$O(^MAG(2006.65,"B",$P(CURCPTS,","),"")) S CURCPTS=$P(CURCPTS,",",2,9) I CURCPTX]"" D Q:HIT ; 1st hit only 123 .. ; This algorithm checks from lowest detail to most general, and acts 124 .. ; on the information found at the FIRST Hit only 125 .. F CPT="CPT5","CPT4","CPT3" S CPT=@CPT I CPT]"",$D(^MAG(2006.65,CURCPTX,1,"B",CPT)) S X=$O(^(CPT,"")) D S HIT=1 Q ;1st hit only 126 ... S X=^MAG(2006.65,CURCPTX,1,X,0) S Y=$S(ACTION="A":2,1:5),X=$P(X,U,Y,Y+2) 127 ... I +X S MAGMATCH=CPT F I=2,3 S $P(MAGMATCH,U,I)=$P(X,U,I) 128 ; sample of logic file: 129 ; ^MAG(2006.65,1,0) = 730 130 ; ^MAG(2006.65,1,1,0) = ^12000011.01^2^2 131 ; ^MAG(2006.65,1,1,1,0) = 730^1^40^6^1^120^10 132 ; ^MAG(2006.65,1,1,2,0) = 732^1^40^2^1^120^4 133 ; ^MAG(2006.65,1,1,"B",730,1) = 134 ; ^MAG(2006.65,1,1,"B",732,2) = 135 ; ^MAG(2006.65,"B",730,1) = 136 ; 137 Q:'MAGMATCH 138 ; 1 RADFN RADTI RACNI RANME RASSN <-- from GETEXAM 139 ; 6 RADATE RADTE RACN RAPRC RARPT 140 ; 11 RAST DAYCASE RAELOC RASTP RASTORD 141 ; 16 RADTPRT RACPT RAIMGTYP 142 S X=$P(RADATA,U,7) D H^%DTC S MAGDTH=+%H 143 S X=$P(RADATA,U,18) 144 S RAIMGTYP=$S(X]"":$O(^RA(79.2,"C",X,"")),1:X) 145 S Y=MAGGRY(0)+1,$P(MAGGRY(0),U)=Y,MAGGRY(Y)=MAGMATCH_U_MAGDTH_U_U_$P(RADATA,U,9)_U_RAIMGTYP_U_RADFN_U_RADTI_U_RACNI_U_RARPT_U_$P(RADATA,U,12)_U_$P(RADATA,U,11) 146 Q 147 ; 148 SVMAG2B ; For exams whose CPTs match, select a subset that are within defined 149 ; limits with respect to time interval & maximum # exams to retrieve 150 ; Return MAGGRY(0) = count ^ message 151 ; MAGGRY(1:N) = "M08" | RADFN ^ RADTI ^ RACNI ^ RARPT 152 N CPT,CT,CURDAT,ICPT,IREC,GO 153 S CURDAT=$P(MAGGRY(1),U,4) 154 F IREC=2:1:MAGGRY(0) S X=MAGGRY(IREC),CPT=+X D K MAGGRY(IREC) 155 . I $P(X,U,2) S Y=CURDAT-$P(X,U,4) S:Y<0 Y=-Y I Y>$P(X,U,2) Q ;too old 156 . S Y=$G(GO(CPT))+1 I CPT,(Y>$P(X,U,3)) Q ; already have enough cases 157 . S GO(CPT)=Y,GO(CPT,Y)=X 158 K MAGGRY 159 I $D(GO) S CT=0,CPT="" D 160 . F S CPT=$O(GO(CPT)) Q:CPT="" F ICPT=1:1:GO(CPT) D 161 .. S CT=CT+1,X=GO(CPT,ICPT),RARPT=$P(X,U,11) 162 .. S MAGGRY(CT)="M08^"_CPT_"|"_$P(X,U,8,11) 163 .. I ACTION="P"!(ACTION="A") S Y=$$JBFETCH^MAGJUTL2(RARPT) ; fetch from jukebox 164 . S MAGGRY(0)=CT_"^"_HDR 165 E S MAGGRY(0)="0^No Exams Found for "_HDR 166 Q 167 ; 168 END ; -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGJLS2.m
r613 r623 1 MAGJLS2 ;WIRMFO/JHC Rad. Workstation RPC calls ; 29 Jul 2003 9:58 AM 2 ;;3.0;IMAGING;**22,18,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 ; ACTIVE -- list exams (Unread, Recent, &/or Pending) for input Imaging Type(s) 21 ; RPC Call: MAGJ RADACTIVEEXAMS 22 ; BKGND -- EP for Bkgnd Compile of UNREAD list 23 ; BKGND2 -- EP for Bkgnd Compile of RECENT list 24 Q 25 BKGERR S ERRCOUNT=$G(ERRCOUNT)+1 H 3 I ERRCOUNT>2 K ZTQUEUED G ^XUSCLEAN ; prevent bkgnd loop 26 ERR1 I $G(LSTNAM)]"" L -^XTMP("MAGJ2","BKGND",LSTNAM,"COMPILE") 27 L -^XTMP("MAGJ2","BKGND2","RUN") 28 ERR N ERR S ERR=$$EC^%ZOSV S ^TMP($J,"RET",0)="0^4~"_ERR 29 S MAGGRY=$NA(^TMP($J,"RET")) 30 D @^%ZOSF("ERRTN") 31 Q:$Q 1 Q 32 ACTIVE(MAGGRY,DATA) ; EP--get Active (Unread/Recent/Pend) Exam Lists 33 ; MAGGRY holds $NA ref to ^TMP where return msg is assembled 34 ; all refs to MAGGRY use SS indirection 35 ; If not use bkgnd, compile in foregnd 36 ; 37 N BKGND,COMPFAIL,MAGLST,LSTPARAM,LSTREQ,LSTID,LSTNUM,LSTNAM,NEWLIST 38 N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJLS2" 39 S X=$P(DATA,U) D PARAMS^MAGJLS2B(X) 40 I 'LSTID S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)="0^4~Problem with Exams List Compile--"_DATA_"." Q 41 I MAGJOB("P32"),+$G(MAGJOB("P32STOP")) S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)="0^4~VistARad Patch 32 is no longer supported. Contact Imaging support for the current version of the VistARad client software." Q ; <*> 42 I BKGND,LSTREQ="U" D BKREQU Q ; UNREAD in bkgnd 43 I BKGND,LSTREQ="R" D BKREQR Q ; RECENT in bkgnd 44 I BKGND,LSTREQ="A" D BKREQA(DATA) Q ; ALL Active Exams 45 D FOREGND ; other list types, or bkgnd compile not enabled 46 ACTIVEZ Q 47 ; 48 FOREGND ; compile in foregnd 49 I LSTREQ="H" G HISTORY 50 D BLDACTV^MAGJLS3(.MAGLST,LSTPARAM) 51 D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,MAGLST) K @MAGLST 52 Q 53 ; 54 HISTORY ; compile History list 55 D BLDACTV^MAGJLS3(.MAGLST,LSTPARAM) 56 D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,MAGLST) 57 ; copy data from above compile into History file 58 N EXID,HISTIEN,IEN,REC1,REC2,CDAT,TMP,PC 59 I +$G(@MAGLST@(0,1)) D 60 . S IEN="" F S IEN=$O(@MAGLST@(IEN)) Q:(IEN="") S REC1=^(IEN,1),REC2=^(2) D 61 . . I IEN=0 S ^XTMP("MAGJ2","HISTORY",DUZ,DUZ(2),IEN,1)=REC1,^(2)=REC2 Q ; header string 62 . . S HISTIEN=+$P(REC2,"|",3) Q:'HISTIEN S EXID=$P(REC2,"|",2) 63 . . S X=$G(^XTMP("MAGJ2","HISTORY",DUZ,DUZ(2),0,"ADD",HISTIEN)) 64 . . I X]"" D 65 . . . I EXID'=$P(X,"|",2) Q 66 . . . ; copy Client data into list column fields 12-15 in node 2 67 . . . S CDAT=$P(REC2,"|",3),TMP=$P(REC2,"|") 68 . . . F I=1:1:4 S PC=11+I,$P(TMP,U,PC)=$P(CDAT,U,I) 69 . . . S TMP=TMP_U ; pad extra nil piece 70 . . . S $P(REC2,"|")=TMP,$P(REC2,"|",3)=HISTIEN ; preserve IEN in PP3 71 . . . S ^XTMP("MAGJ2","HISTORY",DUZ,DUZ(2),HISTIEN,1)=REC1,^(2)=REC2 72 . . . K ^XTMP("MAGJ2","HISTORY",DUZ,DUZ(2),0,"ADD",HISTIEN) ; Kill input node 73 K @MAGLST 74 Q 75 ; 76 BKREQU ; UNREAD exams from bkgnd 77 L +^XTMP("MAGJ2","BKGND2","RUN"):0 78 E D BKOUT("UNREAD") Q ; bkgnd process IS running 79 ; NOT running, so start it! 80 ; 2nd errtrap is to deal with locks if error occurs 81 N $ETRAP,$ESTACK S $ETRAP="D ERR1^MAGJLS2" 82 N ZTDESC,ZTDTH,ZTIO,ZTRTN 83 S ZTRTN="BKGND^MAGJLS2",ZTDESC="IMAGING VistaRad UNREAD List Compile" 84 S ZTDTH=$H,ZTIO="" D ^%ZTLOAD 85 S X=$$CURLIST(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X 86 I LSTAGE>(DELTA+300) S BKGPROC=2 D ; Foregnd compile if need fresh list 87 . D LSTCOMP(.COMPFAIL) K BKGPROC S X=$$CURLIST(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X 88 L -^XTMP("MAGJ2","BKGND2","RUN") 89 I +$G(COMPFAIL) S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)="0^4~Unable to Compile Unread Exams list" 90 E D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,$NA(^XTMP("MAGJ2",LSTNAM,LSTNUM)),LSTAGE) 91 K LSTAGE 92 Q 93 ; 94 BKREQR ; Recent Exams from bkgnd 95 D BKOUT("RECENT") 96 Q 97 ; 98 BKOUT(LSTNM) ; output list from the bkgnd process 99 S X=$$CURLIST(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X 100 I 'LSTNUM S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)="0^4~Problem with "_LSTNM_" List Compile program (age="_LSTAGE_" for "_LSTNAM_")"_$S(LSTNAM["9992":"--May need to Schedule RECENT List Compile in TaskMan.",1:"") 101 E D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,$NA(^XTMP("MAGJ2",LSTNAM,LSTNUM)),LSTAGE) 102 K LSTAGE 103 Q 104 ; 105 BKREQA(DATA) ; ALL Active from Bkgnd 106 ; Copy compiles of Unread & Recent to a scratch global, & call lstout 107 N ALLGO,CNT,GETLST,ICNT,REPLY 108 S ALLGO=1,CNT=0 109 F GETLST=9991,9992 D I 'ALLGO S REPLY="Component List "_GETLST_ALLGO Q 110 . D PARAMS^MAGJLS2B(GETLST) I 'LSTID S ALLGO=" not properly defined." Q 111 . S X=$$CURLIST(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X 112 . I 'LSTNUM S ALLGO=" needs more time to compile." Q 113 . F ICNT=1:1:$G(^XTMP("MAGJ2",LSTNAM,LSTNUM,0,1)) S X=^XTMP("MAGJ2",LSTNAM,LSTNUM,ICNT,1),Y=^(2),CNT=CNT+1,^TMP($J,"MAGJ",CNT,1)=X,^(2)=Y 114 I ALLGO D 115 . S ^TMP($J,"MAGJ",0,1)=CNT_U_"1~ALL Active Exams",^(2)="" 116 . D PARAMS^MAGJLS2B($P(DATA,U)) 117 . D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,$NA(^TMP($J,"MAGJ"))) 118 I 'ALLGO S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)="0^4~Problem with ALL Exams List Compile "_DATA_". "_REPLY 119 K LSTAGE 120 Q 121 ; 122 BKGND ; EP for background compile of UNREAD exams 123 L +^XTMP("MAGJ2","BKGND2","RUN"):600 ; allow fgnd job to finish compile 124 E Q ; I must already be running! 125 N BKGLSTID S BKGLSTID=9991 G BKGNDA 126 Q 127 BKGND2 ; EP--bkgnd compile RECENT 128 N BKGLSTID S BKGLSTID=9992 G BKGNDA 129 Q 130 BKGNDA S BKGPROC=1,U="^" 131 N $ETRAP,$ESTACK S $ETRAP="D BKGERR^MAGJLS2" 132 D MAGJOBNC^MAGJUTL3 133 D PARAMS^MAGJLS2B(BKGLSTID) 134 BKLOOP ; Loop & compile "master" UNREAD List only 135 S BKLOOP=$G(BKLOOP)+1 136 I BKLOOP>1 D PARAMS^MAGJLS2B(9991) 137 I 'LSTID D G BKGNDZ 138 . S X="0^4~Problem with BACKGROUND Compile of Exams List" 139 . F I=1,2 K ^XTMP("MAGJ2",LSTNAM,I) 140 . F I=1,2 S ^XTMP("MAGJ2",LSTNAM,I,0,1)=X,^(2)="" ; get msg to WS user 141 I 'BKGND G BKGNDZ ; need this to cover for excessive time to compile 142 S X=$$CURLIST(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X 143 I LSTREQ="U",(LSTAGE<DELTA) D I 'BKGND G BKGNDZ ;bkgnd compile off? 144 . N ITEST,TEST,MORE 145 . S TEST=(DELTA-LSTAGE)\5,MORE=(DELTA-LSTAGE)-(5*TEST) 146 . ; while waiting, periodic chk for stop conditions 147 . F ITEST=1:1:TEST H 5 D Q:'BKGND 148 .. S BKGND=+$P($G(^MAG(2006.69,1,0)),U,8) Q:'BKGND 149 .. I $D(ZTQUEUED),$$S^%ZTLOAD S BKGND=0 ; Exit bkgnd via TaskMan Req 150 . H MORE 151 D LSTCOMP() 152 I LSTREQ="R" D NEWINT 153 I LSTREQ="U" D UPDR^MAGJLS2B G BKLOOP ;UNREAD loops; RECENT uses TaskMan 154 BKGNDZ I LSTREQ="U" L -^XTMP("MAGJ2","BKGND2","RUN") 155 N ZTREQ S ZTREQ="@" ; clean up task entry 156 K BKLOOP,DELTA,LSTAGE 157 Q ; Exit bkgnd 158 ; 159 NEWINT ; Add exams newly Interp since Recent Compile started to Recent List 160 ; 1st, get list of candidates: 161 N INDX L +^XTMP("MAGJ2","RECENT"):15 162 E Q 163 S INDX=+$G(^TMP($J,"NEWINT")) ; counter when Recent Compile started 164 I INDX S INDX=INDX-1 F S INDX=$O(^XTMP("MAGJ2","RECENT",INDX)) Q:'INDX S X=^(INDX) I X S ^TMP($J,"NEWINT",0,INDX)=X 165 K ^XTMP("MAGJ2","RECENT") S ^("RECENT",0)=0 166 L -^XTMP("MAGJ2","RECENT") 167 ;if not in Recent Compile, add to index 168 S INDX="" 169 F S INDX=$O(^TMP($J,"NEWINT",0,INDX)) Q:'INDX S X=^(INDX) D 170 . I $D(^TMP($J,"NEWINT",$P(X,U,1,3))) Q ; already there 171 . L +^XTMP("MAGJ2","RECENT"):15 172 . E Q 173 . S I=+$G(^XTMP("MAGJ2","RECENT",0))+1,$P(^(0),U)=I,^(I)=X ;add 174 . L -^XTMP("MAGJ2","RECENT") 175 K ^TMP($J,"NEWINT") 176 Q 177 ; 178 LSTCOMP(COMPFAIL) ; Compile new list; subrtn used by Active and Bkgnd tags 179 S COMPFAIL=0 ; Return T/F for "Executed a List Compile?" 180 L +^XTMP("MAGJ2","BKGND",LSTNAM,"COMPILE"):60 181 E S COMPFAIL=1 G LSTCOMZ 182 S NEWLIST=$S(LSTNUM=1:2,1:1) ; toggle node to use 183 N TS,COMTIM 184 S TS="" F I=2,0 S TS=TS_$S(TS="":"",1:U)_$$HTFM^XLFDT($H+I,0) 185 S ^XTMP("MAGJ2",0)=TS_U_"VistaRad List Compile" 186 S ^XTMP("MAGJ2",0,LSTNAM,NEWLIST)=$H 187 D BLDACTV^MAGJLS3(.MAGGRY,LSTPARAM,$NA(^XTMP("MAGJ2",LSTNAM,NEWLIST))) 188 S COMTIM=$$DELTA($P(^XTMP("MAGJ2",0,LSTNAM,NEWLIST),U)) 189 S ^XTMP("MAGJ2",LSTNAM,NEWLIST)=$H_U_$J_U_COMTIM 190 S ^XTMP("MAGJ2","BKGND",LSTNAM,0)=NEWLIST_U_$H 191 I $G(^XTMP("MAGJ2",0,"TIME")) D 192 . S T1=$P($H,",",2)/3600,T2=$E(100+(T1\1),2,3),T=T2_":"_$E(100+(T1-T2*60),2,3) 193 . S ^XTMP("MAGJ2",0,"TIME",LSTNAM,+$H,T)=COMTIM K T,T1,T2 194 LSTCOMZ L -^XTMP("MAGJ2","BKGND",LSTNAM,"COMPILE") 195 Q ; 196 CURLIST(LSTNAM,WAIT) ; return cur. list & age in secs 197 S WAIT=+$G(WAIT) 198 N X,RET,AGE,TRY,START,EXTRATIM 199 S TRY=0,START=$H,EXTRATIM=$S(LSTREQ="U":600,1:1800) 200 S X=$G(^XTMP("MAGJ2","BKGND",LSTNAM,0)) ; Cur # ^ $H created 201 I X="" S RET="^86400" G CURLISZ ; this lstnam not yet compiled! 202 S AGE=$$DELTA($P(X,U,2)),RET=$P(X,U)_U_AGE 203 I AGE>(DELTA+EXTRATIM) S $P(RET,U)="" ; Something's wrong w/ compile; force error message 204 CURLISZ Q RET 205 ; 206 DELTA(X,Y) ; calc # secs bet 2 $h values; dflt 2nd value = now 207 ; useful limit is one day 208 I $G(Y)="" S Y=$H 209 I +Y=+X 210 E D 211 . I Y-X=1 S $P(Y,",",2)=86400+$P(Y,",",2) ; midnight boundary 212 . E S $P(X,",",2)=0,$P(Y,",",2)=86400 ; > one day 213 Q ($P(Y,",",2)-$P(X,",",2)) 214 ; 215 END ; 1 MAGJLS2 ;WIRMFO/JHC Rad. Workstation RPC calls ; 29 Jul 2003 9:58 AM 2 ;;3.0;IMAGING;**22,18**;Mar 07, 2006 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 Q 19 ; ACTIVE -- list exams (Unread, Recent, &/or Pending) for input Imaging Type(s) 20 ; RPC Call: MAGJ RADACTIVEEXAMS 21 ; BKGND -- EP for Bkgnd Compile of UNREAD list 22 ; BKGND2 -- EP for Bkgnd Compile of RECENT list 23 Q 24 BKGERR S ERRCOUNT=$G(ERRCOUNT)+1 H 3 I ERRCOUNT>2 K ZTQUEUED G ^XUSCLEAN ; prevent bkgnd loop 25 ERR1 I $G(LSTNAM)]"" L -^XTMP("MAGJ2","BKGND",LSTNAM,"COMPILE") 26 L -^XTMP("MAGJ2","BKGND2","RUN") 27 ERR N ERR S ERR=$$EC^%ZOSV S ^TMP($J,"RET",0)="0^4~"_ERR 28 S MAGGRY=$NA(^TMP($J,"RET")) 29 D @^%ZOSF("ERRTN") 30 Q:$Q 1 Q 31 ACTIVE(MAGGRY,DATA) ; EP--get Active (Unread/Recent/Pend) Exam Lists 32 ; MAGGRY holds $NA ref to ^TMP where return msg is assembled 33 ; all refs to MAGGRY use SS indirection 34 ; If not use bkgnd, compile in foregnd 35 ; 36 N BKGND,COMPFAIL,MAGLST,LSTPARAM,LSTREQ,LSTID,LSTNUM,LSTNAM,NEWLIST 37 N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJLS2" 38 S X=$P(DATA,U) D PARAMS^MAGJLS2B(X) 39 I 'LSTID S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)="0^4~Problem with Exams List Compile--"_DATA_"." Q 40 I BKGND,LSTREQ="U" D BKREQU Q ; UNREAD in bkgnd 41 I BKGND,LSTREQ="R" D BKREQR Q ; RECENT in bkgnd 42 I BKGND,LSTREQ="A" D BKREQA(DATA) Q ; ALL Active Exams 43 D FOREGND ; other list types, or bkgnd compile not enabled 44 ACTIVEZ Q 45 ; 46 FOREGND ; compile in foregnd 47 I LSTREQ="H" G HISTORY 48 D BLDACTV^MAGJLS3(.MAGLST,LSTPARAM) 49 D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,MAGLST) K @MAGLST 50 Q 51 ; 52 HISTORY ; compile History list 53 D BLDACTV^MAGJLS3(.MAGLST,LSTPARAM) 54 D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,MAGLST) 55 ; copy data from above compile into History file 56 N EXID,HISTIEN,IEN,REC1,REC2,CDAT,TMP,PC 57 I +$G(@MAGLST@(0,1)) D 58 . S IEN="" F S IEN=$O(@MAGLST@(IEN)) Q:(IEN="") S REC1=^(IEN,1),REC2=^(2) D 59 . . I IEN=0 S ^XTMP("MAGJ2","HISTORY",DUZ,DUZ(2),IEN,1)=REC1,^(2)=REC2 Q ; header string 60 . . S HISTIEN=+$P(REC2,"|",3) Q:'HISTIEN S EXID=$P(REC2,"|",2) 61 . . S X=$G(^XTMP("MAGJ2","HISTORY",DUZ,DUZ(2),0,"ADD",HISTIEN)) 62 . . I X]"" D 63 . . . I EXID'=$P(X,"|",2) Q 64 . . . ; copy Client data into list column fields 12-15 in node 2 65 . . . S CDAT=$P(REC2,"|",3),TMP=$P(REC2,"|") 66 . . . F I=1:1:4 S PC=11+I,$P(TMP,U,PC)=$P(CDAT,U,I) 67 . . . S TMP=TMP_U ; pad extra nil piece 68 . . . S $P(REC2,"|")=TMP,$P(REC2,"|",3)=HISTIEN ; preserve IEN in PP3 69 . . . S ^XTMP("MAGJ2","HISTORY",DUZ,DUZ(2),HISTIEN,1)=REC1,^(2)=REC2 70 . . . K ^XTMP("MAGJ2","HISTORY",DUZ,DUZ(2),0,"ADD",HISTIEN) ; Kill input node 71 K @MAGLST 72 Q 73 ; 74 BKREQU ; UNREAD exams from bkgnd 75 L +^XTMP("MAGJ2","BKGND2","RUN"):0 76 E D BKOUT("UNREAD") Q ; bkgnd process IS running 77 ; NOT running, so start it! 78 ; 2nd errtrap is to deal with locks if error occurs 79 N $ETRAP,$ESTACK S $ETRAP="D ERR1^MAGJLS2" 80 N ZTDESC,ZTDTH,ZTIO,ZTRTN 81 S ZTRTN="BKGND^MAGJLS2",ZTDESC="IMAGING VistaRad UNREAD List Compile" 82 S ZTDTH=$H,ZTIO="" D ^%ZTLOAD 83 S X=$$CURLIST(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X 84 I LSTAGE>(DELTA+300) S BKGPROC=2 D ; Foregnd compile if need fresh list 85 . D LSTCOMP(.COMPFAIL) K BKGPROC S X=$$CURLIST(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X 86 L -^XTMP("MAGJ2","BKGND2","RUN") 87 I +$G(COMPFAIL) S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)="0^4~Unable to Compile Unread Exams list" 88 E D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,$NA(^XTMP("MAGJ2",LSTNAM,LSTNUM)),LSTAGE) 89 Q 90 ; 91 BKREQR ; Recent Exams from bkgnd 92 D BKOUT("RECENT") 93 Q 94 ; 95 BKOUT(LSTNM) ; output list from the bkgnd process 96 S X=$$CURLIST(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X 97 I 'LSTNUM S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)="0^4~Problem with "_LSTNM_" List Compile program (age="_LSTAGE_" for "_LSTNAM_")"_$S(LSTNAM["9992":"--May need to Schedule RECENT List Compile in TaskMan.",1:"") 98 E D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,$NA(^XTMP("MAGJ2",LSTNAM,LSTNUM)),LSTAGE) 99 Q 100 ; 101 BKREQA(DATA) ; ALL Active from Bkgnd 102 ; Copy compiles of Unread & Recent to a scratch global, & call lstout 103 N ALLGO,CNT,GETLST,ICNT,REPLY 104 S ALLGO=1,CNT=0 105 F GETLST=9991,9992 D I 'ALLGO S REPLY="Component List "_GETLST_ALLGO Q 106 . D PARAMS^MAGJLS2B(GETLST) I 'LSTID S ALLGO=" not properly defined." Q 107 . S X=$$CURLIST(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X 108 . I 'LSTNUM S ALLGO=" needs more time to compile." Q 109 . F ICNT=1:1:$G(^XTMP("MAGJ2",LSTNAM,LSTNUM,0,1)) S X=^XTMP("MAGJ2",LSTNAM,LSTNUM,ICNT,1),Y=^(2),CNT=CNT+1,^TMP($J,"MAGJ",CNT,1)=X,^(2)=Y 110 I ALLGO D 111 . S ^TMP($J,"MAGJ",0,1)=CNT_U_"1~ALL Active Exams",^(2)="" 112 . D PARAMS^MAGJLS2B($P(DATA,U)) 113 . D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,$NA(^TMP($J,"MAGJ"))) 114 I 'ALLGO S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)="0^4~Problem with ALL Exams List Compile "_DATA_". "_REPLY 115 Q 116 ; 117 BKGND ; EP for background compile of UNREAD exams 118 L +^XTMP("MAGJ2","BKGND2","RUN"):600 ; allow fgnd job to finish compile 119 E Q ; I must already be running! 120 N BKGLSTID S BKGLSTID=9991 G BKGNDA 121 Q 122 BKGND2 ; EP--bkgnd compile RECENT 123 N BKGLSTID S BKGLSTID=9992 G BKGNDA 124 Q 125 BKGNDA S BKGPROC=1,U="^" 126 N $ETRAP,$ESTACK S $ETRAP="D BKGERR^MAGJLS2" 127 D MAGJOBNC^MAGJUTL3 128 D PARAMS^MAGJLS2B(BKGLSTID) 129 BKLOOP ; Loop & compile "master" UNREAD List only 130 S BKLOOP=$G(BKLOOP)+1 131 I BKLOOP>1 D PARAMS^MAGJLS2B(9991) 132 I 'LSTID D G BKGNDZ 133 . S X="0^4~Problem with BACKGROUND Compile of Exams List" 134 . F I=1,2 K ^XTMP("MAGJ2",LSTNAM,I) 135 . F I=1,2 S ^XTMP("MAGJ2",LSTNAM,I,0,1)=X,^(2)="" ; get msg to WS user 136 I 'BKGND G BKGNDZ ; need this to cover for excessive time to compile 137 S X=$$CURLIST(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X 138 I LSTREQ="U",(LSTAGE<DELTA) D I 'BKGND G BKGNDZ ;bkgnd compile off? 139 . N ITEST,TEST,MORE 140 . S TEST=(DELTA-LSTAGE)\5,MORE=(DELTA-LSTAGE)-(5*TEST) 141 . ; while waiting, periodic chk for stop conditions 142 . F ITEST=1:1:TEST H 5 D Q:'BKGND 143 .. S BKGND=+$P($G(^MAG(2006.69,1,0)),U,8) Q:'BKGND 144 .. I $D(ZTQUEUED),$$S^%ZTLOAD S BKGND=0 ; Exit bkgnd via TaskMan Req 145 . H MORE 146 D LSTCOMP() 147 I LSTREQ="R" D NEWINT 148 I LSTREQ="U" D UPDR G BKLOOP ;UNREAD loops; RECENT uses TaskMan 149 BKGNDZ I LSTREQ="U" L -^XTMP("MAGJ2","BKGND2","RUN") 150 N ZTREQ S ZTREQ="@" ; clean up task entry 151 K BKLOOP,DELTA 152 Q ; Exit bkgnd 153 ; 154 UPDR ; Add Newly Interp exams to Recent 155 D PARAMS^MAGJLS2B(9995) 156 I 'LSTID G UPDRZ 157 S X=$$CURLIST(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X 158 D LSTCOMP() 159 UPDRZ Q ; 160 ; 161 NEWINT ; Exams newly Interp since Recent Compile started 162 ; are added to Recent List (add to "RECENT" index) 163 ; 1st, get list of all potential candidates: 164 N INDX L +^XTMP("MAGJ2","RECENT"):15 165 E Q 166 S INDX=+$G(^TMP($J,"NEWINT")) ; counter when Recent Compile started 167 I INDX S INDX=INDX-1 F S INDX=$O(^XTMP("MAGJ2","RECENT",INDX)) Q:'INDX S X=^(INDX) I X S ^TMP($J,"NEWINT",0,INDX)=X 168 K ^XTMP("MAGJ2","RECENT") S ^("RECENT",0)=0 ; init this index 169 L -^XTMP("MAGJ2","RECENT") 170 ;find those not included in Recent Compile, and add to index 171 S INDX="" 172 F S INDX=$O(^TMP($J,"NEWINT",0,INDX)) Q:'INDX S X=^(INDX) D 173 . I $D(^TMP($J,"NEWINT",$P(X,U,1,3))) Q ; already in the compile 174 . L +^XTMP("MAGJ2","RECENT"):15 175 . E Q 176 . S I=+$G(^XTMP("MAGJ2","RECENT",0))+1,$P(^(0),U)=I,^(I)=X ; add to indx 177 . L -^XTMP("MAGJ2","RECENT") 178 K ^TMP($J,"NEWINT") 179 Q 180 ; 181 LSTCOMP(COMPFAIL) ; Compile new list; subrtn used by Active and Bkgnd tags 182 S COMPFAIL=0 ; Return T/F for "Executed a List Compile?" 183 L +^XTMP("MAGJ2","BKGND",LSTNAM,"COMPILE"):60 ; shouldn't need any time 184 E S COMPFAIL=1 G LSTCOMZ 185 S NEWLIST=$S(LSTNUM=1:2,1:1) ; toggle node to use for new compile 186 N TS,COMTIM 187 S TS="" F I=2,0 S %H=$H+I D YMD^%DTC S TS=TS_$S(TS="":"",1:U)_X 188 S ^XTMP("MAGJ2",0)=TS_U_"VistaRad List Compile" 189 S ^XTMP("MAGJ2",0,LSTNAM,NEWLIST)=$H 190 D BLDACTV^MAGJLS3(.MAGGRY,LSTPARAM,$NA(^XTMP("MAGJ2",LSTNAM,NEWLIST))) 191 S COMTIM=$$DELTA($P(^XTMP("MAGJ2",0,LSTNAM,NEWLIST),U)) 192 S ^XTMP("MAGJ2",LSTNAM,NEWLIST)=$H_U_$J_U_COMTIM 193 S ^XTMP("MAGJ2","BKGND",LSTNAM,0)=NEWLIST_U_$H 194 I $G(^XTMP("MAGJ2",0,"TIME")) D 195 . S T1=$P($H,",",2)/3600,T2=$E(100+(T1\1),2,3),T=T2_":"_$E(100+(T1-T2*60),2,3) 196 . S ^XTMP("MAGJ2",0,"TIME",LSTNAM,+$H,T)=COMTIM K T,T1,T2 197 LSTCOMZ L -^XTMP("MAGJ2","BKGND",LSTNAM,"COMPILE") 198 Q ; 199 ; 200 CURLIST(LSTNAM,WAIT) ; return current list & its age in seconds 201 ; 202 S WAIT=+$G(WAIT) 203 N X,RET,AGE,TRY,START,EXTRATIM 204 S TRY=0,START=$H,EXTRATIM=$S(LSTREQ="U":600,1:1800) 205 S X=$G(^XTMP("MAGJ2","BKGND",LSTNAM,0)) ; Cur # ^ $H created 206 I X="" S RET="^86400" G CURLISZ ; this lstnam not yet compiled! 207 S AGE=$$DELTA($P(X,U,2)),RET=$P(X,U)_U_AGE 208 I AGE>(DELTA+EXTRATIM) S $P(RET,U)="" ; Something's wrong w/ compile; force error message 209 CURLISZ Q RET 210 ; 211 DELTA(X,Y) ; calc # seconds between 2 $h values; default 2nd value = now 212 ; useful limit is one day 213 I $G(Y)="" S Y=$H 214 I +Y=+X 215 E D 216 . I Y-X=1 S $P(Y,",",2)=86400+$P(Y,",",2) ; cross midnight boundary 217 . E S $P(X,",",2)=0,$P(Y,",",2)=86400 ; more than one day 218 Q ($P(Y,",",2)-$P(X,",",2)) 219 ; 220 END ; -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGJLS2B.m
r613 r623 1 MAGJLS2B ;WIRMFO/JHC VistARad RPC calls ; 29 Jul 2003 9:59 AM 2 ;;3.0;IMAGING;**16,22,18,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 ; 21 PARAMS(X) ; Init some vars used for Exam Lists 22 N LASTEDIT 23 S LSTID=+$O(^MAG(2006.631,"C",X,"")) 24 I 'LSTID S LSTID="Invalid List ID" Q ; 25 S X=^MAG(2006.631,LSTID,0) 26 I '$P(X,U,6) S LSTID="LIST NOT ENABLED" Q ; 27 S LSTTL=$P(X,U),LSTREQ=$P(X,U,3),LSTPARAM=LSTREQ_U_$P(X,U,4),LASTEDIT=$P(X,U,5) 28 S LSTTL=$S(LSTREQ="U":"UNREAD",LSTREQ="R":"RECENT",LSTREQ="A":"ACTIVE",LSTREQ="P":"PENDING",LSTREQ="N":"NEWLY INTERP",LSTREQ="H":"HISTORY",1:"")_" EXAMS: "_LSTTL 29 I $P(LSTPARAM,U,2)="" S $P(LSTPARAM,U,2)="ALL" ; dflt All ImagingTypes 30 S X=$G(^MAG(2006.69,1,0)),BKGND=+$P(X,U,8),DELTA=+$P(X,U,$S(LSTREQ="U":9,1:13))*60 31 I BKGND,'DELTA S DELTA=360 ;dflt Unread List compile cycle time secs 32 S LSTNAM="LS"_LSTID 33 I BKGND S LSTNAM=$S(LSTREQ="U":"LS9991",LSTREQ="R":"LS9992",LSTREQ="N":"LS9995",LSTREQ="H":"LS9996",1:LSTNAM) ; hard-code for "Master" list Bkgnd compile 34 Q 35 ; 36 SETVARS(LSTID) ;output control variables 37 D LSTVAR(LSTID),SRTVAR(LSTID),SELVAR(LSTID) 38 Q 39 ; 40 LSTVAR(LSTID) ; build output columns string 41 S MDLVAR=^MAG(2006.631,LSTID,"DEF",1),LSTHDR=^(.5) 42 N I,XX,SC,XOUT,XOUT2 43 S SC=";",XOUT="",XOUT2="" 44 F I=1:1:$L(MDLVAR,U) S XX=$P(MDLVAR,U,I) D 45 . I +XX=12 I '$G(SNDREMOT) Q ; exclude RC ind 46 . I +XX=23 I '$G(SHOWPLAC) Q ; exclude PLACE 47 . S XOUT=XOUT_$S(XOUT="":"",1:U)_XX 48 . S XOUT2=XOUT2_$S(XOUT2="":"",1:U)_$P(LSTHDR,U,I) 49 S MDLVAR=XOUT,LSTHDR=XOUT2 50 Q 51 SRTVAR(LSTID) ; build sort-vars string in SORTSS 52 ; indirection used to ref string at list output (see LSTOUT) 53 S MDSVAR=^MAG(2006.631,LSTID,"DEF",2) 54 N I,XX,XOUT,HAVEONE 55 S SORTSS="",XOUT="",HAVEONE=0 56 F I=1:1:$L(MDSVAR,U) S XX=$P(MDSVAR,U,I) D 57 . I +XX=12 Q:'$G(SNDREMOT) ; exclude RC ind 58 . I +XX=23 I '$G(SHOWPLAC) Q ; exclude PLACE 59 . I 'HAVEONE S HAVEONE=(+XX=1) ; 1 = Case # 60 . S XOUT=XOUT_$S(XOUT="":"",1:U)_XX 61 . S XX=$S(XX?1N.N1"-":"-",1:"")_"MD("_+XX_")" 62 . S SORTSS=SORTSS_","_XX 63 I 'HAVEONE S SORTSS=SORTSS_",MD(1)",XOUT=XOUT_U_1 ; force unique entry each exam 64 I $E(SORTSS)="," S SORTSS=$E(SORTSS,2,999) 65 S MDSVAR=XOUT 66 Q 67 ; 68 SELVAR(LSTID) ; build selection logic executes in DIS array 69 N CX,DC,DCX,DL,DLX,EXP,I,IDL,SELVAR,SELVAR2,SS 70 S SS=0 F S SS=$O(^MAG(2006.631,LSTID,"DEF",3,SS)) Q:'SS S DC(SS)=^(SS) 71 S SS=0 F I=1:1 S SS=$O(^MAG(2006.631,LSTID,"DEF",4,SS)) Q:'SS S DL(I)=^(SS) 72 ; DL(5)="^2^3'^" <DLX CX=3' DC(2)="1^>44" <DCX 73 K DIS,MDCVAR S DIS(0)=0 74 F IDL=1:1 S DLX=$G(DL(IDL)) Q:DLX="" S DIS(0)=DIS(0)+1,DIS(DIS(0))="" D 75 . F I=2:1:$L(DLX,U)-1 S CX=$P(DLX,U,I) S DCX=DC(+CX) D 76 .. S EXP="(MD("_+DCX_")"_$P(DCX,U,2)_")" 77 .. S EXP="I "_$S(CX["'":"'",1:"")_EXP 78 .. S DIS(DIS(0))=DIS(DIS(0))_" "_EXP 79 .. S MDCVAR(+DCX)="" 80 Q 81 ; 82 CHKLOCK(RARPT,DAYCASE) ; return ini of locking user & truth flag for locking user = logon user 83 N RESULT,WHO,MYLOCK,X,XX 84 S (MYLOCK,WHO)="" 85 I RARPT,(DAYCASE]"") D 86 . I $D(^XTMP("MAGJ","LOCK",RARPT)) D 87 . . D LOCKACT^MAGJEX1A(RARPT,DAYCASE,100,.RESULT) 88 . . I $D(RESULT)>1 D 89 . . . S X=RESULT(1),WHO=$P(X,U,5) 90 . . . I WHO]"" S MYLOCK=+X 91 . . . E D 92 . . . . S X=RESULT(2),WHO=$P(X,U,5) 93 . . . . I WHO]"" S WHO=WHO_":R",MYLOCK=+X I MYLOCK S MYLOCK=2 94 S XX=WHO_U_MYLOCK 95 Q:$Q XX Q 96 ; 97 SHOWPLAC(X) ; return list of places to show: all defined places NOT equal to user's logon place 98 N IEN,SHOWPLAC S SHOWPLAC="" 99 S IEN=0 F S IEN=$O(^MAG(2006.1,IEN)) Q:'IEN I IEN'=+MAGJOB("SITEP") S X=$P(^(IEN,0),U,9) I X]"" S SHOWPLAC=SHOWPLAC_","_X 100 I SHOWPLAC]"" S SHOWPLAC=1_U_SHOWPLAC_"," ; 1 for true 101 Q SHOWPLAC 102 ; 103 LSTOUT(MAGGRY,LSTID,MAGLST,LSTAGE) ; Build output list, w/ sort & selection 104 ; Input: LSTID=List def'n 105 ; MAGLST=Indirect global ref for input records; all reads use subscript indirection 106 ; the nodes in @MAGLST contain: 107 ; 108 ; Node 1 corresponds to IENs 1:17 from Data Elements dic: 109 ; Acn# ^ Ex LOCK ^ PtName ^ Pt_ID ^ Priority ^ Proc ^ Img Date/Time ^ Status ^ # Images ^ Online? 110 ; Img Loc'n ^ Remote Ind. ^ Images Exist? ^ Img Date/Time-sortable ^ Mdl ^ Status/Internal ^ ImgTypABB 111 ; Node 2-- IEN's 18:28 from Data Elements dic: 112 ; REQLOCAbb ^ REQLOCNm ^ Interp Rad'ists ^ Last4 SSN ^ Division ^ Site ^ Rist Is Me? ^ ProcMod ^ REQLOCTyp ^ CPT 113 ; WARD 114 ; Node 2 then appends 3 pipe-delim pieces that are passed through from list compiler (See svmag2a^magjls3) 115 ; 116 ; Output: MAGGRY=Indirect ref to output file 117 ; 118 N DIS,MDCVAR,SNDREMOT,ILST,IMD,MAGRACNT 119 N RARPT,RAST,RADFN,RACNI,RADTI,T,WHOLOCK,XX,MYLOCK,DAYCASE,MODALITY 120 N OUT,QX,SORT,SORTSS,LSTHDR,MD,MDLVAR,MDSVAR,REMONLY,REMOTCAS,SHOWPLAC,SORTLEN 121 S LSTAGE=$G(LSTAGE) 122 S SHOWPLAC=$$SHOWPLAC("") ; Show any Place (Site Code) that is NOT the Login Place 123 S REMONLY=0 124 S XX=$G(^MAG(2006.69,1,0)),SNDREMOT=+$P(XX,U,11) 125 I $G(MAGJOB("REMOTE")) D ; show remote cache only? 126 . I MAGJOB("P32") S REMONLY=+$P(XX,U,10) 127 . E Q:(LSTREQ="H") S REMONLY=+$G(MAGJOB("REMOTESCREEN")) ; Hist list 128 D SETVARS(LSTID) 129 S MAGRACNT=0 130 S SORT="^TMP("_$J_",""MAGJSORT""",SORTLEN=$L(SORT) K ^TMP($J,"MAGJSORT") 131 K ^TMP($J,"RET") S ^TMP($J,"RET",0)="0^4~Getting Exam List" 132 S X=$G(@MAGLST@(0,1)) I +X<1 D G LSTOUTZ ; No exams to list! 133 . I X="" S ^TMP($J,"RET",0)="0^4~Problem with Exams List Compile" 134 . E S ^TMP($J,"RET",0)=X 135 S ILST=0 136 F S ILST=$O(@MAGLST@(ILST)) Q:'ILST S XX=^(ILST,1),XX2=^(2) K MD D ; contents described above 137 . S XX=XX_U_$P(XX2,"|"),$P(XX2,"|")="" 138 . ; Execute Selection logic 139 . S X=0 F S X=$O(MDCVAR(X)) Q:'X S MD(X)=$P(XX,U,X) ; load needed data 140 . I 1 F I=1:1:$G(DIS(0)) X DIS(I) I Q ; quit if search logic True 141 . E Q ; failed selection criteria--skip 142 . S RAST=$P(XX,U,16) 143 . S T=$P(XX2,"|",2),RADFN=$P(T,U),RADTI=$P(T,U,2),RACNI=$P(T,U,3),RARPT=$P(T,U,4) 144 . I LSTREQ="U",'$D(^RADPT("AS",RAST,RADFN,RADTI,RACNI)) Q ; No longer Unread! 145 . I LSTREQ="U",$G(MAGJOB("CONSOLIDATED")) S RADIV=$P(XX,U,22) I RADIV]"",'$D(MAGJOB("DIVSCRN",RADIV)) Q ; Screen Unread exams for DIVision 146 . S REMOTCAS=$P(XX,U,12) 147 . I REMONLY,'REMOTCAS Q ; don't show if not routed 148 . I REMONLY,REMOTCAS D I 'T Q ; don't show if not the remote reading site 149 . . F I=1:1:$L(REMOTCAS,",")+1 S T=$P(REMOTCAS,",",I) I T,$D(MAGJOB("LOC",T)) Q 150 . ; set up sort values, creating sort index w/ indirect reference to sort global 151 . F I=1:1:$L(MDSVAR,U) S X=+$P(MDSVAR,U,I) S MD(X)=$P(XX,U,X) I MD(X)="" S MD(X)="~" 152 . I LSTREQ="H" S @(SORT_",ILST,"_SORTSS_")")=ILST_U_RARPT ; P18 adds ILST so History List can allow mult entries of same exam, in fifo order 153 . E S @(SORT_","_SORTSS_")")=ILST_U_RARPT 154 . S MAGRACNT=MAGRACNT+1 155 I 'MAGRACNT S ^TMP($J,"RET",0)="0^2~No Exams Found" 156 E D ; generate output file 157 . S @(SORT_","_-9999999999_")")=0,QX=SORT_")" ; define $Query var.; init beginning w/ dummy entry 158 . ; proceed thru sort index until the string contained in SORT is not present 159 . ; get data w/ indirect refs to the stored data 160 . F ILST=0:1 S QX=$Q(@QX) Q:($E(QX,1,SORTLEN))'=SORT S XX=@MAGLST@(+(@QX),1),XX2=^(2),OUT="" D 161 .. I 'ILST D Q ; Header string 162 ... S T="" I LSTAGE?1N.N S T=LSTAGE\60 S T=" (List age: "_$S(T:T_" min, ",1:"")_(LSTAGE#60)_" sec)" 163 ... I +$P(XX,U,2)=1 S $P(XX,"~",2)=LSTTL_T ; List Title 164 ... S ^TMP($J,"RET",0)=XX 165 .. S XX=XX_U_$P(XX2,"|"),$P(XX2,"|")="" 166 .. S RARPT=$P(@QX,U,2),DAYCASE=$P(XX,U) 167 .. S T=$$CHKLOCK(RARPT,DAYCASE),WHOLOCK=$P(T,U),MYLOCK=$P(T,U,2) 168 .. S $P(XX,U,2)=WHOLOCK 169 .. S MODALITY=$P(XX,U,15) 170 .. F IMD=1:1:$L(MDLVAR,U) S X=$P(MDLVAR,U,IMD),MD=$P(XX,U,+X) D 171 ... I +X=12,(MD]""),SNDREMOT D 172 .... ; if site routes images, disp Remote Cache ind. 173 .... N I,T S T="" F I=1:1:$L(MD,",") S T=T_$S(T="":"",1:",")_$P($G(^MAG(2005.2,$P(MD,",",I),3)),U,5) 174 .... S MD=T 175 ... I +X=23,(MD]""),SHOWPLAC D 176 .... I SHOWPLAC'[(","_MD_",") S MD="" ; Don't show user's local place 177 ... I +X=22,(MD]""),$G(MAGJOB("CONSOLIDATED")) D 178 .... I '$D(MAGJOB("DIVSCRN",MD)) S MD="" ; Don't show user's local Div 179 ... I X[";" S T=+$P(X,";",2) I T S MD=$E(MD,1,T) ; truncate output col 180 ... S $P(OUT,U,IMD)=MD 181 .. S $P(OUT,U,IMD+1)="",OUT=U_OUT,OUT=OUT_"|"_$P(XX2,"|",2,9) 182 .. I WHOLOCK]"" S T=$P(OUT,"|",4),$P(T,U,2)=WHOLOCK,$P(T,U,3)=MYLOCK,$P(OUT,"|",4)=T ; pass lock info to Client 183 .. ; * Note: Keep Pipe piece 4, above, in sync with svmag2a^magjls3 * 184 .. S ^TMP($J,"RET",ILST+1)=OUT 185 . S ^TMP($J,"RET",1)=U_LSTHDR 186 . S $P(^TMP($J,"RET",0),U)=MAGRACNT 187 LSTOUTZ K MAGGRY,^TMP($J,"MAGJSORT") S MAGGRY=$NA(^TMP($J,"RET")) 188 Q 189 ; 190 UPDR ; Add Newly Interp exams to Recent; called from magjls2 191 D PARAMS(9995) 192 I LSTID D 193 . S X=$$CURLIST^MAGJLS2(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X 194 . D LSTCOMP^MAGJLS2() 195 UPDRZ Q 196 ; 197 END ; 1 MAGJLS2B ;WIRMFO/JHC VistARad RPC calls ; 29 Jul 2003 9:59 AM 2 ;;3.0;IMAGING;**16,22,18**;Mar 07, 2006 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 Q 19 ; 20 PARAMS(X) ; Init some vars used for Exam Lists 21 N LASTEDIT 22 S LSTID=+$O(^MAG(2006.631,"C",X,"")) 23 I 'LSTID S LSTID="Invalid List ID" Q ; 24 S X=^MAG(2006.631,LSTID,0) 25 I '$P(X,U,6) S LSTID="LIST NOT ENABLED" Q ; 26 S LSTTL=$P(X,U),LSTREQ=$P(X,U,3),LSTPARAM=LSTREQ_U_$P(X,U,4),LASTEDIT=$P(X,U,5) 27 S LSTTL=$S(LSTREQ="U":"UNREAD",LSTREQ="R":"RECENT",LSTREQ="A":"ACTIVE",LSTREQ="P":"PENDING",LSTREQ="N":"NEWLY INTERP",LSTREQ="H":"HISTORY",1:"")_" EXAMS: "_LSTTL 28 I $P(LSTPARAM,U,2)="" S $P(LSTPARAM,U,2)="ALL" ; dflt All ImagingTypes 29 S X=$G(^MAG(2006.69,1,0)),BKGND=+$P(X,U,8),DELTA=+$P(X,U,$S(LSTREQ="U":9,1:13))*60 30 I BKGND,'DELTA S DELTA=360 ;dflt Unread List compile cycle time secs 31 S LSTNAM="LS"_LSTID 32 I BKGND S LSTNAM=$S(LSTREQ="U":"LS9991",LSTREQ="R":"LS9992",LSTREQ="N":"LS9995",LSTREQ="H":"LS9996",1:LSTNAM) ; hard-code for "Master" list Bkgnd compile 33 Q 34 ; 35 SETVARS(LSTID) ;output control variables 36 D LSTVAR(LSTID),SRTVAR(LSTID),SELVAR(LSTID) 37 Q 38 ; 39 LSTVAR(LSTID) ; build output columns string 40 S MDLVAR=^MAG(2006.631,LSTID,"DEF",1),LSTHDR=^(.5) 41 N I,XX,SC,XOUT,XOUT2 42 S SC=";",XOUT="",XOUT2="" 43 F I=1:1:$L(MDLVAR,U) S XX=$P(MDLVAR,U,I) D 44 . I +XX=12 I '$G(SNDREMOT) Q ; exclude RC ind 45 . I +XX=23 I '$G(SHOWPLAC) Q ; exclude PLACE 46 . S XOUT=XOUT_$S(XOUT="":"",1:U)_XX 47 . S XOUT2=XOUT2_$S(XOUT2="":"",1:U)_$P(LSTHDR,U,I) 48 S MDLVAR=XOUT,LSTHDR=XOUT2 49 Q 50 SRTVAR(LSTID) ; build sort-vars string in SORTSS 51 ; indirection used to ref string at list output (see LSTOUT) 52 S MDSVAR=^MAG(2006.631,LSTID,"DEF",2) 53 N I,XX,XOUT,HAVEONE 54 S SORTSS="",XOUT="",HAVEONE=0 55 F I=1:1:$L(MDSVAR,U) S XX=$P(MDSVAR,U,I) D 56 . I +XX=12 Q:'$G(SNDREMOT) ; exclude RC ind 57 . I +XX=23 I '$G(SHOWPLAC) Q ; exclude PLACE 58 . I 'HAVEONE S HAVEONE=(+XX=1) ; 1 = Case # 59 . S XOUT=XOUT_$S(XOUT="":"",1:U)_XX 60 . S XX=$S(XX?1N.N1"-":"-",1:"")_"MD("_+XX_")" 61 . S SORTSS=SORTSS_","_XX 62 I 'HAVEONE S SORTSS=SORTSS_",MD(1)",XOUT=XOUT_U_1 ; force unique entry each exam 63 I $E(SORTSS)="," S SORTSS=$E(SORTSS,2,999) 64 S MDSVAR=XOUT 65 Q 66 ; 67 SELVAR(LSTID) ; build selection logic executes in DIS array 68 N CX,DC,DCX,DL,DLX,EXP,I,IDL,SELVAR,SELVAR2,SS 69 S SS=0 F S SS=$O(^MAG(2006.631,LSTID,"DEF",3,SS)) Q:'SS S DC(SS)=^(SS) 70 S SS=0 F I=1:1 S SS=$O(^MAG(2006.631,LSTID,"DEF",4,SS)) Q:'SS S DL(I)=^(SS) 71 ; DL(5)="^2^3'^" <DLX CX=3' DC(2)="1^>44" <DCX 72 K DIS,MDCVAR S DIS(0)=0 73 F IDL=1:1 S DLX=$G(DL(IDL)) Q:DLX="" S DIS(0)=DIS(0)+1,DIS(DIS(0))="" D 74 . F I=2:1:$L(DLX,U)-1 S CX=$P(DLX,U,I) S DCX=DC(+CX) D 75 .. S EXP="(MD("_+DCX_")"_$P(DCX,U,2)_")" 76 .. S EXP="I "_$S(CX["'":"'",1:"")_EXP 77 .. S DIS(DIS(0))=DIS(DIS(0))_" "_EXP 78 .. S MDCVAR(+DCX)="" 79 Q 80 ; 81 CHKLOCK(RARPT,DAYCASE) ; return ini of locking user & truth flag for locking user = logon user 82 N RESULT,WHO,MYLOCK,X,XX 83 S (MYLOCK,WHO)="" 84 I RARPT,(DAYCASE]"") D 85 . I $D(^XTMP("MAGJ","LOCK",RARPT)) D 86 . . D LOCKACT^MAGJEX1A(RARPT,DAYCASE,100,.RESULT) 87 . . I $D(RESULT)>1 D 88 . . . S X=RESULT(1),WHO=$P(X,U,5) 89 . . . I WHO]"" S MYLOCK=+X 90 . . . E D 91 . . . . S X=RESULT(2),WHO=$P(X,U,5) 92 . . . . I WHO]"" S WHO=WHO_":R",MYLOCK=+X I MYLOCK S MYLOCK=2 93 S XX=WHO_U_MYLOCK 94 Q:$Q XX Q 95 ; 96 SHOWPLAC(X) ; return list of places to show: all defined places NOT equal to user's logon place 97 N IEN,SHOWPLAC S SHOWPLAC="" 98 S IEN=0 F S IEN=$O(^MAG(2006.1,IEN)) Q:'IEN I IEN'=+MAGJOB("SITEP") S X=$P(^(IEN,0),U,9) I X]"" S SHOWPLAC=SHOWPLAC_","_X 99 I SHOWPLAC]"" S SHOWPLAC=1_U_SHOWPLAC_"," ; 1 for true 100 Q SHOWPLAC 101 ; 102 LSTOUT(MAGGRY,LSTID,MAGLST,LSTAGE) ; Build output list, w/ sort & selection 103 ; Input: LSTID=List def'n 104 ; MAGLST=Indirect global ref for input records; all reads use subscript indirection 105 ; the nodes in @MAGLST contain: 106 ; 107 ; Node 1 corresponds to IENs 1:17 from Data Elements dic: 108 ; Acn# ^ Ex LOCK ^ PtName ^ Pt_ID ^ Priority ^ Proc ^ Img Date/Time ^ Status ^ # Images ^ Online? 109 ; Img Loc'n ^ Remote Ind. ^ Images Exist? ^ Img Date/Time-sortable ^ Mdl ^ Status/Internal ^ ImgTypABB 110 ; Node 2-- IEN's 18:28 from Data Elements dic: 111 ; REQLOCAbb ^ REQLOCNm ^ Interp Rad'ists ^ Last4 SSN ^ Division ^ Site ^ Rist Is Me? ^ ProcMod ^ REQLOCTyp ^ CPT 112 ; WARD 113 ; Node 2 then appends 3 pipe-delim pieces that are passed through from list compiler (See svmag2a^magjls3) 114 ; 115 ; Output: MAGGRY=Indirect ref to output file 116 ; 117 N DIS,MDCVAR,SNDREMOT,ILST,IMD,MAGRACNT 118 N RARPT,RAST,RADFN,RACNI,RADTI,T,WHOLOCK,XX,MYLOCK,DAYCASE,MODALITY 119 N OUT,QX,SORT,SORTSS,LSTHDR,MD,MDLVAR,MDSVAR,REMONLY,REMOTCAS,SHOWPLAC,SORTLEN 120 S LSTAGE=$G(LSTAGE) 121 S SHOWPLAC=$$SHOWPLAC("") ; Show any Place (Site Code) that is NOT the Login Place 122 S REMONLY=0 123 S XX=$G(^MAG(2006.69,1,0)),SNDREMOT=+$P(XX,U,11) 124 I $G(MAGJOB("REMOTE")) D ; show remote cache only? 125 . I MAGJOB("P32") S REMONLY=+$P(XX,U,10) 126 . E Q:(LSTREQ="H") S REMONLY=+$G(MAGJOB("REMOTESCREEN")) ; Hist list 127 D SETVARS(LSTID) 128 S MAGRACNT=0 129 S SORT="^TMP("_$J_",""MAGJSORT""",SORTLEN=$L(SORT) K ^TMP($J,"MAGJSORT") 130 K ^TMP($J,"RET") S ^TMP($J,"RET",0)="0^4~Getting Exam List" 131 S X=$G(@MAGLST@(0,1)) I +X<1 D G LSTOUTZ ; No exams to list! 132 . I X="" S ^TMP($J,"RET",0)="0^4~Problem with Exams List Compile" 133 . E S ^TMP($J,"RET",0)=X 134 S ILST=0 135 F S ILST=$O(@MAGLST@(ILST)) Q:'ILST S XX=^(ILST,1),XX2=^(2) K MD D ; contents described above 136 . S XX=XX_U_$P(XX2,"|"),$P(XX2,"|")="" 137 . ; Execute Selection logic 138 . S X=0 F S X=$O(MDCVAR(X)) Q:'X S MD(X)=$P(XX,U,X) ; load needed data 139 . I 1 F I=1:1:$G(DIS(0)) X DIS(I) I Q ; quit if search logic True 140 . E Q ; failed selection criteria--skip 141 . S RAST=$P(XX,U,16) 142 . S T=$P(XX2,"|",2),RADFN=$P(T,U),RADTI=$P(T,U,2),RACNI=$P(T,U,3),RARPT=$P(T,U,4) 143 . I LSTREQ="U",'$D(^RADPT("AS",RAST,RADFN,RADTI,RACNI)) Q ; No longer Unread! 144 . I LSTREQ="U",$G(MAGJOB("CONSOLIDATED")) S RADIV=$P(XX,U,22) I RADIV]"",'$D(MAGJOB("DIVSCRN",RADIV)) Q ; Screen Unread exams for DIVision 145 . S REMOTCAS=$P(XX,U,12) 146 . I REMONLY,'REMOTCAS Q ; don't show if not routed 147 . I REMONLY,REMOTCAS D I 'T Q ; don't show if not the remote reading site 148 . . F I=1:1:$L(REMOTCAS,",")+1 S T=$P(REMOTCAS,",",I) I T,$D(MAGJOB("LOC",T)) Q 149 . ; set up sort values, creating sort index w/ indirect reference to sort global 150 . F I=1:1:$L(MDSVAR,U) S X=+$P(MDSVAR,U,I) S MD(X)=$P(XX,U,X) I MD(X)="" S MD(X)="~" 151 . I LSTREQ="H" S @(SORT_",ILST,"_SORTSS_")")=ILST_U_RARPT ; P18 adds ILST so History List can allow mult entries of same exam, in fifo order 152 . E S @(SORT_","_SORTSS_")")=ILST_U_RARPT 153 . S MAGRACNT=MAGRACNT+1 154 I 'MAGRACNT S ^TMP($J,"RET",0)="0^2~No Exams Found" 155 E D ; generate output file 156 . S @(SORT_","_-9999999999_")")=0,QX=SORT_")" ; define $Query var.; init beginning w/ dummy entry 157 . ; proceed thru sort index until the string contained in SORT is not present 158 . ; get data w/ indirect refs to the stored data 159 . F ILST=0:1 S QX=$Q(@QX) Q:($E(QX,1,SORTLEN))'=SORT S XX=@MAGLST@(+(@QX),1),XX2=^(2),OUT="" D 160 .. I 'ILST D Q ; Header string 161 ... S T="" I LSTAGE?1N.N S T=LSTAGE\60 S T=" (List age: "_$S(T:T_" min, ",1:"")_(LSTAGE#60)_" sec)" 162 ... I +$P(XX,U,2)=1 S $P(XX,"~",2)=LSTTL_T ; List Title 163 ... S ^TMP($J,"RET",0)=XX 164 .. S XX=XX_U_$P(XX2,"|"),$P(XX2,"|")="" 165 .. S RARPT=$P(@QX,U,2),DAYCASE=$P(XX,U) 166 .. S T=$$CHKLOCK(RARPT,DAYCASE),WHOLOCK=$P(T,U),MYLOCK=$P(T,U,2) 167 .. S $P(XX,U,2)=WHOLOCK 168 .. S MODALITY=$P(XX,U,15) 169 .. F IMD=1:1:$L(MDLVAR,U) S X=$P(MDLVAR,U,IMD),MD=$P(XX,U,+X) D 170 ... I +X=12,(MD]""),SNDREMOT D 171 .... ; if site routes images, disp Remote Cache ind. 172 .... N I,T S T="" F I=1:1:$L(MD,",") S T=T_$S(T="":"",1:",")_$P($G(^MAG(2005.2,$P(MD,",",I),3)),U,5) 173 .... S MD=T 174 ... I +X=23,(MD]""),SHOWPLAC D 175 .... I SHOWPLAC'[(","_MD_",") S MD="" ; Don't show user's local place 176 ... I +X=22,(MD]""),$G(MAGJOB("CONSOLIDATED")) D 177 .... I '$D(MAGJOB("DIVSCRN",MD)) S MD="" ; Don't show user's local Div 178 ... I X[";" S T=+$P(X,";",2) I T S MD=$E(MD,1,T) ; truncate output col 179 ... S $P(OUT,U,IMD)=MD 180 .. S $P(OUT,U,IMD+1)="",OUT=U_OUT,OUT=OUT_"|"_$P(XX2,"|",2,9) 181 .. I WHOLOCK]"" S T=$P(OUT,"|",4),$P(T,U,2)=WHOLOCK,$P(T,U,3)=MYLOCK,$P(OUT,"|",4)=T ; pass lock info to Client 182 .. ; * Note: Keep Pipe piece 4, above, in sync with svmag2a^magjls3 * 183 .. S ^TMP($J,"RET",ILST+1)=OUT 184 . S ^TMP($J,"RET",1)=U_LSTHDR 185 . S $P(^TMP($J,"RET",0),U)=MAGRACNT 186 LSTOUTZ K MAGGRY,^TMP($J,"MAGJSORT") S MAGGRY=$NA(^TMP($J,"RET")) 187 Q 188 ; 189 END Q ; 190 ; -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGJLS4.m
r613 r623 1 MAGJLS4 ;WIRMFO/JHC VistARad RPCs--History List ; 29 Jul 2003 10:00 AM 2 ;;3.0;IMAGING;**18,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 ERR N ERR S ERR=$$EC^%ZOSV S ^TMP($J,"RET",0)="0^4~"_ERR 21 S MAGGRY=$NA(^TMP($J,"RET")) 22 D @^%ZOSF("ERRTN") 23 Q:$Q 1 Q 24 ; 25 ; Subroutines for Vistarad History List functions 26 ; Entry Points: 27 ; HIST -- All History List rpcs go here 28 ; 29 HIST(MAGGRY,PARAMS,DATA) ; History List RPC: MAGJ HISTORYLIST 30 ; PARAMS--TXID ^ TXDUZ ^ TXDIV 31 ; TXID: Required; designates action to take; see below 32 ; TXDUZ: Optional; if supplied, get data for another user (Read Only) 33 ; TXDIV: Optional; if supplied, get data for another division (Read Only) 34 ; Note: for now, TXDIV is forced to the Logon Division 35 ; DATA--(optional) array of input data; depends on TXID; see subroutines by TXID 36 ; 37 N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJLS4" 38 N TXID,TXDUZ,TXDIV,UPDATEOK,DIQUIET,REPLY 39 K ^TMP($J,"RET") 40 S TXID=+PARAMS,TXDUZ=+$P(PARAMS,U,2),TXDIV=+$P(PARAMS,U,3) 41 I 'TXDUZ S TXDUZ=DUZ 42 S UPDATEOK=TXDUZ=DUZ 43 S TXDIV=DUZ(2) ; Force to Logon Division for now 44 S REPLY="0^1~Performing History List operation." 45 I 'TXID!'("1,2,3"[TXID) S REPLY="0^4~Invalid History List operation requested." G HISTZ 46 I '$D(DATA)&(TXID=1!TXID=3) S REPLY="0^4~No data supplied for History List update/delete." G HISTZ 47 I 'UPDATEOK&("1,3"[TXID) S REPLY="0^4~The current History List may not be updated by the current user." G HISTZ 48 S DIQUIET=1 D DT^DICRW 49 I TXID=1 D HISTADD(.DATA,TXDUZ,TXDIV) G HISTZ 50 I TXID=2 D HISTUPD(TXDUZ,TXDIV) D HISTGET(TXDUZ,TXDIV) G HISTZ 51 I TXID=3 D HISTDEL(.DATA,TXDUZ,TXDIV) G HISTZ 52 ; I TXID=4 D HISTUPD(TXDUZ,TXDIV) G HISTZ ; for now, do this function with txid 2 53 HISTZ ; 54 I 'REPLY S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)=REPLY 55 E ; maggry otherwise has been set by called subroutine 56 Q 57 ; 58 HISTADD(DATA,TXDUZ,TXDIV) ; add records 59 N IDATA,ILOOP,CT,NOGO,EXID,HISDAT,HISTIEN,MAGRACNT,TS 60 S IDATA="",CT=0,NOGO=0 61 F ILOOP=0:1 S IDATA=$O(DATA(IDATA)) Q:IDATA="" D 62 . S EXID=$P(DATA(IDATA),"|"),HISDAT=$P(DATA(IDATA),"|",2) 63 . F I=1:1:4 I '+$P(EXID,U,I) S NOGO=1 Q 64 . I NOGO Q 65 . L +^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV):2 66 . E Q 67 . S X=$G(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0)),HISTIEN=+$P(X,U)+1,$P(^(0),U)=HISTIEN 68 . L -^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV) 69 . S ^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0,"ADD",HISTIEN)="|"_EXID_"|"_HISTIEN_U_HISDAT_"|" 70 . S CT=CT+1 71 I 'CT S REPLY="0^3~"_$S(ILOOP:"Unable to add records",1:"No records to add")_" to History List." Q 72 S MAGRACNT=0 D ACTIVE^MAGJLS2(.MAGGRY,9996) 73 S X=@MAGGRY@(0),X=+X_U_"1~"_$$HISTTL(TXDUZ,TXDIV),@MAGGRY@(0)=X 74 S TS="" F I=2,0 S TS=TS_$S(TS="":"",1:U)_$$HTFM^XLFDT($H+I,0) 75 S ^XTMP("MAGJ2",0)=TS_U_"VistaRad List Compile" 76 S REPLY=1 77 Q 78 ; 79 HISTTL(TXDUZ,TXDIV) ; Build list title string 80 N LSTTL 81 S LSTTL="HISTORY LIST for "_$$USERINF^MAGJUTL3(TXDUZ,.01)_" at "_"Station #"_$$STATN^MAGJEX1(TXDIV) 82 S LSTTL=LSTTL_"|"_TXDUZ ; provide report's DUZ to client 83 Q LSTTL 84 ; 85 HISTGET(TXDUZ,TXDIV) ; Get full History List for input user for division txdiv 86 N MAGLST,LSTTL,LSTID,MAGLST 87 S TXDUZ=$G(TXDUZ,DUZ) 88 S TXDIV=$G(TXDIV,DUZ(2)) 89 D PARAMS^MAGJLS2B(9996) 90 I 'LSTID S REPLY="0^4~Problem with History List Compile." Q 91 S LSTTL=$$HISTTL(TXDUZ,DUZ(2)) 92 S X=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0)) 93 I 'X S REPLY="0^1~No exams found for: "_LSTTL Q 94 S MAGLST=$NA(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV)) 95 D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,MAGLST) 96 S REPLY=1 97 Q 98 ; 99 HISTDEL(DATA,TXDUZ,TXDIV) ; delete records 100 N IDATA,CT,HISTIEN,ALLDONE,LAST 101 S IDATA="",CT=0,ALLDONE=0 102 L +^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV):2 103 E S REPLY="0^2~Unable to access HISTORY File for deleting records; try again later." Q 104 S MAGGRY=$NA(^TMP($J,"RET")) 105 F S IDATA=$O(DATA(IDATA)) Q:IDATA=""!ALLDONE D 106 . S HISTIEN=$P(DATA(IDATA),U) 107 . I HISTIEN,$D(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN)) K ^(HISTIEN) S CT=CT+1,@MAGGRY@(CT)=HISTIEN Q 108 . E I HISTIEN="ALL" S HISTIEN=0 D S ALLDONE=1 109 . . F S HISTIEN=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN)) Q:'HISTIEN K ^(HISTIEN) S CT=CT+1,@MAGGRY@(CT)=HISTIEN 110 I '$D(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0,"ADD")) S X=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,""),-1),^(0)=X_U_X 111 L -^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV) 112 I 'CT S REPLY="0^3~No HISTORY List records found to delete." 113 E S REPLY=CT_"^1~"_CT_" HISTORY List records deleted." 114 S @MAGGRY@(0)=REPLY 115 S REPLY=1 116 Q 117 ; 118 HISTUPD(TXDUZ,TXDIV) ; Update selected fields in History List 119 N LSTTL,CT,NOHIT,RAST,STATUS,REMOTE,RIST1,RIST2,RIST,RISTISME 120 N EXID,HISTIEN,RARPT,RADFN,RADTI,RACNI,XX1,XX2,T,X,DELETED,HDATE 121 S CT=0,NOHIT=0 122 S TXDUZ=$G(TXDUZ,DUZ) 123 S TXDIV=$G(TXDIV,DUZ(2)) 124 S LSTTL=$$HISTTL(TXDUZ,DUZ(2)) 125 S X=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0)) 126 I 'X S REPLY="0^1~No exams found for: "_LSTTL Q 127 L +^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV):2 128 E S REPLY="0^2~Unable to access HISTORY File for updating records; try again later." Q 129 S HISTIEN=0 130 F S HISTIEN=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN)) Q:'HISTIEN S XX1=$G(^(HISTIEN,1)),XX2=$G(^(2)) D 131 . S EXID=$P(XX2,"|",2),RARPT=+$P(EXID,U,4),RADFN=+$P(EXID,U),RADTI=+$P(EXID,U,2),RACNI=+$P(EXID,U,3) 132 . ; <*> Below is for phase 1 Alpha, til have final user setting for this <*> to be removed 133 . ; Age limit parameter to be passed in with txid 2 rpc call; setting is on client <*> 134 . S HDATE=$P(XX2,U,13) D Q:DELETED 135 . . S DELETED=0,HDATE=$P(HDATE,"@") 136 . . S X=HDATE,%DT="" D ^%DT K %DT 137 . . I $$FMTH^XLFDT(Y,1)<($H-3) K ^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN) S DELETED=1 Q 138 . ; <*> End of temp change 139 . I RARPT,RADFN,RADTI,RACNI 140 . E S NOHIT=NOHIT+1 Q 141 . D IMGINFO^MAGJUTL2(RARPT,.X) S REMOTE=$P(X,U,4) 142 . S X=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) 143 . I X="" Q ; rad exam deleted 144 . S RAST=$P(X,U,3),RIST1=$P(X,U,12),RIST2=$P(X,U,15) 145 . S STATUS=$S(RAST:$P(^RA(72,RAST,0),U),1:"") 146 . S (RIST,RISTISME)="" 147 . I RIST1!RIST2 S X=$$RIST^MAGJUTL1(RIST1,RIST2),RIST=$P(X,U),RISTISME=$P(X,U,2) 148 . S RISTISME=$S(RISTISME:"Y",1:"N") 149 . S $P(XX1,U,16)=RAST,$P(XX1,U,8)=STATUS,$P(XX1,U,12)=REMOTE 150 . S T=$P(XX2,"|"),$P(T,U,3)=RIST,$P(T,U,7)=RISTISME,$P(XX2,"|")=T 151 . S ^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN,1)=XX1,^(2)=XX2 152 . S CT=CT+1 153 S X=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,""),-1),^(0)=X_U_X ; <*> for phase 1 alpha only? 154 L -^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV) 155 S REPLY="0^1~HISTORY File records updated." Q 156 Q 157 ; 158 END Q ; 1 MAGJLS4 ;WIRMFO/JHC VistARad RPCs--History List ; 29 Jul 2003 10:00 AM 2 ;;3.0;IMAGING;**18**;Mar 07, 2006 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 Q 19 ERR N ERR S ERR=$$EC^%ZOSV S ^TMP($J,"RET",0)="0^4~"_ERR 20 S MAGGRY=$NA(^TMP($J,"RET")) 21 D @^%ZOSF("ERRTN") 22 Q:$Q 1 Q 23 ; 24 ; Subroutines for Vistarad History List functions 25 ; Entry Points: 26 ; HIST -- All History List rpcs go here 27 ; 28 HIST(MAGGRY,PARAMS,DATA) ; History List RPC: MAGJ HISTORYLIST 29 ; PARAMS--TXID ^ TXDUZ ^ TXDIV 30 ; TXID: Required; designates action to take; see below 31 ; TXDUZ: Optional; if supplied, get data for another user (Read Only) 32 ; TXDIV: Optional; if supplied, get data for another division (Read Only) 33 ; Note: for now, TXDIV is forced to the Logon Division 34 ; DATA--(optional) array of input data; depends on TXID; see subroutines by TXID 35 ; 36 N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJLS4" 37 N TXID,TXDUZ,TXDIV,UPDATEOK,DIQUIET,REPLY 38 K ^TMP($J,"RET") 39 S TXID=+PARAMS,TXDUZ=+$P(PARAMS,U,2),TXDIV=+$P(PARAMS,U,3) 40 I 'TXDUZ S TXDUZ=DUZ 41 S UPDATEOK=TXDUZ=DUZ 42 S TXDIV=DUZ(2) ; Force to Logon Division for now 43 S REPLY="0^1~Performing History List operation." 44 I 'TXID!'("1,2,3"[TXID) S REPLY="0^4~Invalid History List operation requested." G HISTZ 45 I '$D(DATA)&(TXID=1!TXID=3) S REPLY="0^4~No data supplied for History List update/delete." G HISTZ 46 I 'UPDATEOK&("1,3"[TXID) S REPLY="0^4~The current History List may not be updated by the current user." G HISTZ 47 S DIQUIET=1 D DT^DICRW 48 I TXID=1 D HISTADD(.DATA,TXDUZ,TXDIV) G HISTZ 49 I TXID=2 D HISTUPD(TXDUZ,TXDIV) D HISTGET(TXDUZ,TXDIV) G HISTZ 50 I TXID=3 D HISTDEL(.DATA,TXDUZ,TXDIV) G HISTZ 51 ; I TXID=4 D HISTUPD(TXDUZ,TXDIV) G HISTZ ; for now, do this function with txid 2 52 HISTZ ; 53 I 'REPLY S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)=REPLY 54 E ; maggry otherwise has been set by called subroutine 55 Q 56 ; 57 HISTADD(DATA,TXDUZ,TXDIV) ; add records 58 N IDATA,ILOOP,CT,NOGO,EXID,HISDAT,HISTIEN,MAGRACNT 59 S IDATA="",CT=0,NOGO=0 60 F ILOOP=0:1 S IDATA=$O(DATA(IDATA)) Q:IDATA="" D 61 . S EXID=$P(DATA(IDATA),"|"),HISDAT=$P(DATA(IDATA),"|",2) 62 . F I=1:1:4 I '+$P(EXID,U,I) S NOGO=1 Q 63 . I NOGO Q 64 . L +^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV):2 65 . E Q 66 . S X=$G(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0)),HISTIEN=+$P(X,U)+1,$P(^(0),U)=HISTIEN 67 . L -^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV) 68 . S ^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0,"ADD",HISTIEN)="|"_EXID_"|"_HISTIEN_U_HISDAT_"|" 69 . S CT=CT+1 70 I 'CT S REPLY="0^3~"_$S(ILOOP:"Unable to add records",1:"No records to add")_" to History List." Q 71 S MAGRACNT=0 D ACTIVE^MAGJLS2(.MAGGRY,9996) 72 S X=@MAGGRY@(0),X=+X_U_"1~"_$$HISTTL(TXDUZ,TXDIV),@MAGGRY@(0)=X 73 N TS S TS="" F I=2,0 S %H=$H+I D YMD^%DTC S TS=TS_$S(TS="":"",1:U)_X 74 S ^XTMP("MAGJ2",0)=TS_U_"VistaRad List Compile" 75 S REPLY=1 76 Q 77 ; 78 HISTTL(TXDUZ,TXDIV) ; Build list title string 79 N LSTTL 80 S LSTTL="HISTORY LIST for "_$$USERINF^MAGJUTL3(TXDUZ,.01)_" at "_"Station #"_$$STATN^MAGJEX1(TXDIV) 81 S LSTTL=LSTTL_"|"_TXDUZ ; provide report's DUZ to client 82 Q LSTTL 83 ; 84 HISTGET(TXDUZ,TXDIV) ; Get full History List for input user for division txdiv 85 N MAGLST,LSTTL,LSTID,MAGLST 86 S TXDUZ=$G(TXDUZ,DUZ) 87 S TXDIV=$G(TXDIV,DUZ(2)) 88 D PARAMS^MAGJLS2B(9996) 89 I 'LSTID S REPLY="0^4~Problem with History List Compile." Q 90 S LSTTL=$$HISTTL(TXDUZ,DUZ(2)) 91 S X=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0)) 92 I 'X S REPLY="0^1~No exams found for: "_LSTTL Q 93 S MAGLST=$NA(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV)) 94 D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,MAGLST) 95 S REPLY=1 96 Q 97 ; 98 HISTDEL(DATA,TXDUZ,TXDIV) ; delete records 99 N IDATA,CT,HISTIEN,ALLDONE,LAST 100 S IDATA="",CT=0,ALLDONE=0 101 L +^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV):2 102 E S REPLY="0^2~Unable to access HISTORY File for deleting records; try again later." Q 103 S MAGGRY=$NA(^TMP($J,"RET")) 104 F S IDATA=$O(DATA(IDATA)) Q:IDATA=""!ALLDONE D 105 . S HISTIEN=$P(DATA(IDATA),U) 106 . I HISTIEN,$D(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN)) K ^(HISTIEN) S CT=CT+1,@MAGGRY@(CT)=HISTIEN Q 107 . E I HISTIEN="ALL" S HISTIEN=0 D S ALLDONE=1 108 . . F S HISTIEN=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN)) Q:'HISTIEN K ^(HISTIEN) S CT=CT+1,@MAGGRY@(CT)=HISTIEN 109 I '$D(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0,"ADD")) S X=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,""),-1),^(0)=X_U_X 110 L -^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV) 111 I 'CT S REPLY="0^3~No HISTORY List records found to delete." 112 E S REPLY=CT_"^1~"_CT_" HISTORY List records deleted." 113 S @MAGGRY@(0)=REPLY 114 S REPLY=1 115 Q 116 ; 117 HISTUPD(TXDUZ,TXDIV) ; Update selected fields in History List 118 N LSTTL,CT,NOHIT,RAST,STATUS,REMOTE,RIST1,RIST2,RIST,RISTISME 119 N EXID,HISTIEN,RARPT,RADFN,RADTI,RACNI,XX1,XX2,T,X,DELETED,HDATE 120 S CT=0,NOHIT=0 121 S TXDUZ=$G(TXDUZ,DUZ) 122 S TXDIV=$G(TXDIV,DUZ(2)) 123 S LSTTL=$$HISTTL(TXDUZ,DUZ(2)) 124 S X=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0)) 125 I 'X S REPLY="0^1~No exams found for: "_LSTTL Q 126 L +^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV):2 127 E S REPLY="0^2~Unable to access HISTORY File for updating records; try again later." Q 128 S HISTIEN=0 129 F S HISTIEN=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN)) Q:'HISTIEN S XX1=$G(^(HISTIEN,1)),XX2=$G(^(2)) D 130 . S EXID=$P(XX2,"|",2),RARPT=+$P(EXID,U,4),RADFN=+$P(EXID,U),RADTI=+$P(EXID,U,2),RACNI=+$P(EXID,U,3) 131 . ; <*> Below is for phase 1 Alpha, til have final user setting for this <*> to be removed 132 . ; Age limit parameter to be passed in with txid 2 rpc call; setting is on client <*> 133 . S HDATE=$P(XX2,U,13) D Q:DELETED 134 . . S DELETED=0,HDATE=$P(HDATE,"@") 135 . . S X=HDATE,%DT="" D ^%DT S X=Y D H^%DTC K %DT 136 . . I %H<($H-3) K ^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN) S DELETED=1 Q 137 . ; <*> End of temp change 138 . I RARPT,RADFN,RADTI,RACNI 139 . E S NOHIT=NOHIT+1 Q 140 . D IMGINFO^MAGJUTL2(RARPT,.X) S REMOTE=$P(X,U,4) 141 . S X=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) 142 . I X="" Q ; rad exam deleted 143 . S RAST=$P(X,U,3),RIST1=$P(X,U,12),RIST2=$P(X,U,15) 144 . S STATUS=$S(RAST:$P(^RA(72,RAST,0),U),1:"") 145 . S (RIST,RISTISME)="" 146 . I RIST1!RIST2 S X=$$RIST^MAGJUTL1(RIST1,RIST2),RIST=$P(X,U),RISTISME=$P(X,U,2) 147 . S RISTISME=$S(RISTISME:"Y",1:"N") 148 . S $P(XX1,U,16)=RAST,$P(XX1,U,8)=STATUS,$P(XX1,U,12)=REMOTE 149 . S T=$P(XX2,"|"),$P(T,U,3)=RIST,$P(T,U,7)=RISTISME,$P(XX2,"|")=T 150 . S ^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN,1)=XX1,^(2)=XX2 151 . S CT=CT+1 152 S X=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,""),-1),^(0)=X_U_X ; <*> for phase 1 alpha only? 153 L -^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV) 154 S REPLY="0^1~HISTORY File records updated." Q 155 Q 156 ; 157 END Q ; -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGJLST1.m
r613 r623 1 MAGJLST1 ;WIRMFO/JHC VistARad RPC calls ; 29 Jul 2003 10:01 AM 2 ;;3.0;IMAGING;**16,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 ; 21 ; Subroutines for fetching Exam Info for Radiology Workstation 22 ; Exam listings: 23 ; PTLIST -- list subset of all exams for a patient 24 ; RPC Call: MAGJ PTRADEXAMS 25 ; PTLSTALL -- list ALL exams for a patient 26 ; RPC Call: MAGJ PT ALL EXAMS 27 ; 28 Q 29 ERR N ERR S ERR=$$EC^%ZOSV S ^TMP($J,"RET",0)="0^4~"_ERR 30 S MAGGRY=$NA(^TMP($J,"RET")) 31 D @^%ZOSF("ERRTN") 32 Q:$Q 1 Q 33 ; 34 PTLSTALL(MAGGRY,DATA) ; List ALL exams for a patient 35 ; RPC is MAGJ PT ALL EXAMS 36 N PARAM 37 I MAGJOB("P32") S PARAM="^99^999" 38 E S PARAM="^^^"_$P(DATA,U,2,3) 39 D PTLIST(.MAGGRY,$P(DATA,U)_PARAM) 40 Q 41 ; 42 PTLIST(MAGGRY,DATA) ; get list of exams for a patient 43 ; 44 ; MAGGRY - indirect reference to return array of exams for a patient 45 ; DATA - DFN ^ LIMYEARS ^ LIMEXAMS ^ BEGDT ^ ONESHOT 46 ; DFN--Patient's DFN 47 ; LIMYRS--Restrict exams up to # Years back (defunct) 48 ; LIMEXAMS--Restrict exams up to # of exams 49 ; BEGDT--Begin date for exam fetch (Patch 18 addition--see below) 50 ; ONESHOT--Number days back to search, in one fell swoop 51 ; Returns data in ^TMP($J,"MAGRAEX",0:n) 52 ; RPC Call: MAGJ PTRADEXAMS 53 ; 54 ; Patch 18 eliminates "Patient Exams" / "All Patient Exams" distinction. 55 ; It always retrieves ALL exams, but uses multiple RPC calls, so the client 56 ; incrementally builds the list; this is to provide all the data, but without 57 ; incurring any long pauses to provide the info to the user. 58 ; Below, the P18 code fetches RAD data in one-year chunks, and repeats 59 ; until over 20 exams have been processed, at which point the RPC reply 60 ; is posted, along with the last date processed; this value is then used for 61 ; a subsequent RPC call to get the next chunk of the record; etc. till all done. 62 ; The P32 code is re-organized, and now exits only for LIMEXAMS (ignore LimYears) 63 ; 64 N CNT,DFN,ISS,PATNAME,DIQUIET,MAGRACNT,MAGRET,REPLY,REMOTE,SNDREMOT 65 N DAYCASE,DIV,EXCAT,MAGDT,XX,XX2,WHOLOCK,MODALITY,MYLOCK,PLACE,ENDLOOP 66 N LIMEXAMS,BEGDT,SAVBEGDT,ENDDT,MORE,SHOWPLAC,RDRIST,PSSN,CPT,PARAM 67 N CURPRIO,STATUS,RARPT,KEY,X2,REMOTE2,ONESHOT,LIMDAYS 68 N IMGCNT,LRFLAG,MSG,ONL,PROCMOD,RASTCAT,RASTORD 69 N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJLST1" 70 S DIQUIET=1 D DT^DICRW 71 S PARAM=$G(^MAG(2006.69,1,0)) 72 S SNDREMOT=+$P(PARAM,U,11) ; Site routes images remotely? 73 I MAGJOB("P32") D 74 . S LIMEXAMS=+$P(PARAM,U,15) 75 . S:'LIMEXAMS LIMEXAMS=999 ; default to show ALL Exams 76 . I $P(DATA,U,3) S LIMEXAMS=+$P(DATA,U,3) 77 . I LIMEXAMS<20 S LIMEXAMS=20 78 . S BEGDT="" 79 E S BEGDT=$P(DATA,U,4),ONESHOT=$P(DATA,U,5) ; P65 chg 80 K MAGGRY S DFN=+DATA 81 S SHOWPLAC=$$SHOWPLAC^MAGJLS2B("") 82 S MAGRACNT=1,CNT=0 K ^TMP($J,"MAGRAEX"),^("MAGRAEX2") 83 S REPLY="0^4~Compiling list of Radiology Exams." 84 I DFN,$D(^DPT(DFN,0)) S PATNAME=$P(^(0),U),PSSN=$P(^(0),U,9) D 85 . S ENDLOOP=0,BEGDT=$S(+BEGDT:BEGDT,1:"") 86 . I MAGJOB("P32"),+$G(MAGJOB("P32STOP")) S REPLY="0^4~VistARad Patch 32 is no longer supported; contact Imaging Support for the current version of the VistARad client software." Q ; <*> 87 . F D Q:'MORE Q:ENDLOOP S BEGDT=MORE+1 88 . . I 'BEGDT S BEGDT=DT,X2=0 89 . . E S X2=-1 90 . . S LIMDAYS=365,MORE=1 91 . . I 'MAGJOB("P32") I ONESHOT,(ONESHOT>0) S LIMDAYS=+ONESHOT 92 . . S ENDDT=$$FMADD^XLFDT(BEGDT,X2) 93 . . S BEGDT=$$FMADD^XLFDT(ENDDT,-LIMDAYS) 94 . . D GETEXAM3^MAGJUTL1(DFN,BEGDT,ENDDT,.MAGRACNT,.MAGRET,.MORE) 95 . . I MAGJOB("P32") S ENDLOOP=(MAGRACNT>LIMEXAMS) 96 . . E S ENDLOOP=(MAGRACNT>20)!+ONESHOT ; For testing only, use >8 97 . I 'MORE S SAVBEGDT=0 98 . E S SAVBEGDT=MORE+1 ; adding 1 correctly inits value for subseqent call 99 . I MAGRACNT>1 D PTLOOP 100 E S REPLY="0^4~Invalid Radiology Patient" 101 I MAGRACNT<2 S:(REPLY["Compiling") REPLY="0^2~No Exams Found for "_PATNAME 102 I CNT!(REPLY["No Exams Found") D 103 . I 'MORE S MSG="ALL exams are listed." 104 . E S MORE=$$FMTE^XLFDT(MORE) S MSG="Patient has more exams on file." 105 . ; show SSN only if the user is a radiologist 106 . S X=+MAGJOB("USER",1) I '(X=12!(X=15)) S PSSN="" 107 . E S PSSN=" ("_$E(PSSN,1,3)_"-"_$E(PSSN,4,5)_"-"_$E(PSSN,6,9)_")" 108 . I CNT S REPLY=CNT_"^1~Radiology Exams for: "_PATNAME_PSSN_" -- "_MSG 109 . E S REPLY=REPLY_" -- "_MSG 110 . S ^TMP($J,"MAGRAEX2",1)="^Day/Case~S3~1^Lock~~2^Procedure~~6^Modifier~~25^Image Date/Time~S1~7^Status~~8^# Img~S2~9^Onl~~10"_$S($G(SNDREMOT):"^RC~~12",1:"")_$S(SHOWPLAC:"^Site~~23",1:"")_"^Mod~~15^Interp By~~20^Imaging Loc~~11^CPT~~27" 111 I MAGJOB("P32"),+$G(MAGJOB("P32STOP")) S ^TMP($J,"MAGRAEX2",1)="^^" 112 I 'MAGJOB("P32") S $P(REPLY,"|",2)=SAVBEGDT 113 S ^TMP($J,"MAGRAEX2",0)=REPLY 114 S MAGGRY=$NA(^TMP($J,"MAGRAEX2")) 115 K ^TMP($J,"RAE1"),^("MAGRAEX") 116 Q 117 ; 118 PTLOOP ; loop through exam data & package it for VRAD use 119 S ISS=0 120 F S ISS=$O(^TMP($J,"MAGRAEX",ISS)) Q:'ISS S XX=^(ISS,1),XX2=^(2) D 121 . S CNT=CNT+1,RARPT=$P(XX,U,10) 122 . D IMGINFO^MAGJUTL2(RARPT,.Y) 123 . 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) 124 . S REMOTE2=REMOTE 125 . S:PLACE PLACE=$P($G(^MAG(2006.1,PLACE,0)),U,9) 126 . I PLACE]"",SHOWPLAC D 127 .. I SHOWPLAC'[(","_PLACE_",") S PLACE="" ; don't show user's logon pl ; <*> chg for p18? 128 . I SNDREMOT,REMOTE D 129 .. S T="" F I=1:1:$L(REMOTE,",") S T=T_$S(T="":"",1:",")_$P($G(^MAG(2005.2,$P(REMOTE,",",I),3)),U,5) 130 .. S REMOTE=T 131 . S DIV="",X=$P(XX2,U,5) I X'=DUZ(2) S DIV=$$STATN(X) 132 . I MAGDT="" S MAGDT=$P(XX,U,7) 133 . S MAGDT=$$FMTE^XLFDT(MAGDT,"5Z") 134 . S WHOLOCK=RARPT,MYLOCK="",DAYCASE=$P(XX,U,12) 135 . I WHOLOCK]"" S T=$$CHKLOCK^MAGJLS2B(WHOLOCK,DAYCASE),WHOLOCK=$P(T,U),MYLOCK=$P(T,U,2) 136 . S RDRIST=$P(XX2,U,3),PROCMOD=$P(XX2,U,8),CPT=$P(XX,U,17),RASTORD=$P(XX,U,15) 137 . S Y=U_DAYCASE_U_WHOLOCK_U_$E($P(XX,U,9),1,26)_U_PROCMOD_U_MAGDT_U_$E($P(XX,U,14),1,16)_U_IMGCNT_U_ONL 138 . I $G(SNDREMOT) S Y=Y_U_REMOTE 139 . S Y=Y_$S(SHOWPLAC:U_PLACE,1:"")_U_MODALITY_U_RDRIST_U_$E($P(XX,U,13),1,11)_U_CPT 140 . S STATUS=$P(XX,U,11),EXCAT="",CURPRIO=0,RASTCAT=$P(XX2,U,11),LRFLAG=$P(XX2,U,12) 141 . I STATUS]"" D 142 . . S EXCAT=RASTCAT 143 . . I RASTORD<2!(EXCAT="W")!('IMGCNT) S CURPRIO=0 ; Cancelled/Waiting/No images: Ignore exam 144 . . E I EXCAT="E" S CURPRIO=1 ; Examined="Current" exam 145 . . E S CURPRIO=2 ; must be a "prior" exam 146 . . I CURPRIO,'(ONL="Y") S CURPRIO=3 ; images on jukebox 147 . . I MAGJOB("P32"),'(EXCAT="E") S EXCAT="" Q ; P32 compat. 148 . . I RASTORD=9 S EXCAT="C" ; Complete 149 . . E I EXCAT="D"!(EXCAT="T") S EXCAT="I" ; just display one value meaning Interpreted 150 . S ^TMP($J,"MAGRAEX2",ISS)=Y_"^|"_$P(XX,U,1,3)_U_RARPT_"||"_EXCAT_U_WHOLOCK_U_MYLOCK_U_MODALITY_U_CPT_U_CURPRIO_U_RARPT_U_KEY_U_REMOTE2_U_LRFLAG 151 . ; * Note: Keep Pipe-pieces in sync with svmag2a^magjls3 & lstout^magjls2b * 152 Q 153 ; 154 STATN(X) ; get station #, else return input value 155 N T 156 I X]"" D GETS^DIQ(4,X,99,"E","T") S T=$G(T(4,X_",",99,"E")) I T]"" S X=T 157 Q X 158 ; 159 END Q ; 1 MAGJLST1 ;WIRMFO/JHC VistARad RPC calls ; 29 Jul 2003 10:01 AM 2 ;;3.0;IMAGING;**16,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 ; 21 ; Subroutines for fetching Exam Info for Radiology Workstation 22 ; Exam listings: 23 ; PTLIST -- list subset of all exams for a patient 24 ; RPC Call: MAGJ PTRADEXAMS 25 ; PTLSTALL -- list ALL exams for a patient 26 ; RPC Call: MAGJ PT ALL EXAMS 27 ; 28 Q 29 ERR N ERR S ERR=$$EC^%ZOSV S ^TMP($J,"RET",0)="0^4~"_ERR 30 S MAGGRY=$NA(^TMP($J,"RET")) 31 D @^%ZOSF("ERRTN") 32 Q:$Q 1 Q 33 ; 34 PTLSTALL(MAGGRY,DATA) ; List ALL exams for a patient 35 ; RPC is MAGJ PT ALL EXAMS 36 N PARAM 37 I MAGJOB("P32") S PARAM="^99^999" 38 E S PARAM="^^^"_$P(DATA,U,2,3) 39 D PTLIST(.MAGGRY,$P(DATA,U)_PARAM) 40 Q 41 ; 42 PTLIST(MAGGRY,DATA) ; get list of exams for a patient 43 ; 44 ; MAGGRY - indirect reference to return array of exams for a patient 45 ; DATA - DFN ^ LIMYEARS ^ LIMEXAMS ^ BEGDT 46 ; DFN--Patient's DFN 47 ; LIMYRS--Restrict exams up to # Years back 48 ; LIMEXAMS--Restrict exams up to # of exams 49 ; BEGDT--Begin date for exam fetch (Patch 18 addition--see below) 50 ; Returns data in ^TMP($J,"MAGRAEX",0:n) 51 ; RPC Call: MAGJ PTRADEXAMS 52 ; 53 ; Patch 18 eliminates "Patient Exams" / "All Patient Exams" distinction. 54 ; It always retrieves ALL exams, but uses multiple RPC calls, so the client 55 ; incrementally builds the list; this is to provide all the data, but without 56 ; incurring any long pauses to provide the info to the user. 57 ; Below, the P18 code fetches RAD data in one-year chunks, and repeats 58 ; until over 20 exams have been processed, at which point the RPC reply 59 ; is posted, along with the last date processed; this value is then used for 60 ; a subsequent RPC call to get the next chunk of the record; etc. till all done. 61 ; The P32 code is re-organized, and now exits only for LIMEXAMS (ignore LimYears) 62 ; 63 N CNT,DFN,ISS,PATNAME,DIQUIET,MAGRACNT,MAGRET,REPLY,REMOTE,SNDREMOT 64 N DAYCASE,DIV,EXCAT,MAGDT,XX,XX2,WHOLOCK,MODALITY,MYLOCK,PLACE,ENDLOOP 65 N LIMYRS,LIMEXAMS,BEGDT,SAVBEGDT,ENDDT,MORE,SHOWPLAC,RDRIST,PSSN,CPT,PARAM 66 N CURPRIO,STATUS,RARPT,KEY,X1,X2,REMOTE2,ONESHOT,LIMDAYS 67 N IMGCNT,LRFLAG,MSG,ONL,PROCMOD,RASTCAT,RASTORD 68 N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJLST1" 69 S DIQUIET=1 D DT^DICRW 70 S PARAM=$G(^MAG(2006.69,1,0)) 71 S SNDREMOT=+$P(PARAM,U,11) ; Site routes images remotely? 72 I MAGJOB("P32") D 73 . S LIMEXAMS=+$P(PARAM,U,15) 74 . S:'LIMEXAMS LIMEXAMS=999 ; default to show ALL Exams 75 . I $P(DATA,U,3) S LIMEXAMS=+$P(DATA,U,3) 76 . I LIMEXAMS<20 S LIMEXAMS=20 77 . S BEGDT="" 78 E S BEGDT=$P(DATA,U,4),ONESHOT=$P(DATA,U,5) ; P65 chg 79 K MAGGRY S DFN=+DATA 80 ;<*> 81 ; I DUZ=131 G MANYTST^ZMAGJTST ; <*> TEST ONLY !!! 37=RadRes 82 ;<*> 83 S SHOWPLAC=$$SHOWPLAC^MAGJLS2B("") 84 S MAGRACNT=1,CNT=0 K ^TMP($J,"MAGRAEX"),^("MAGRAEX2") 85 S REPLY="0^4~Compiling list of Radiology Exams." 86 I DFN,$D(^DPT(DFN,0)) S PATNAME=$P(^(0),U),PSSN=$P(^(0),U,9) D 87 . S ENDLOOP=0,BEGDT=$S(+BEGDT:BEGDT,1:"") 88 . F D Q:'MORE Q:ENDLOOP 89 . . I 'BEGDT S BEGDT=DT,X2=0 90 . . E S X2=-1 91 . . S LIMDAYS=365 92 . . I 'MAGJOB("P32"),ONESHOT,(ONESHOT>0) S LIMDAYS=+ONESHOT 93 . . S X1=BEGDT D C^%DTC S (ENDDT,X1)=X,X2=-LIMDAYS D C^%DTC S BEGDT=X K %,%H,%T 94 . . D GETEXAM3^MAGJUTL1(DFN,BEGDT,ENDDT,.MAGRACNT,.MAGRET,.MORE) 95 . . I MAGJOB("P32") S ENDLOOP=(MAGRACNT>LIMEXAMS) 96 . . E S ENDLOOP=(MAGRACNT>20)!+ONESHOT ; For testing only, use >8 97 . I 'MORE S SAVBEGDT=0 98 . E S SAVBEGDT=MORE+1 ; adding 1 correctly inits value for subseqent call 99 . I MAGRACNT>1 D PTLOOP 100 E S REPLY="0^4~Invalid Radiology Patient" 101 I MAGRACNT<2 S:(REPLY["Compiling") REPLY="0^2~No Exams Found for "_PATNAME 102 I CNT!(REPLY["No Exams Found") D 103 . I 'MORE S MSG="ALL exams are listed." 104 . E S MORE=$$FMTE^XLFDT(MORE) S MSG="Patient has more exams on file." 105 . ; show SSN only if the user is a radiologist 106 . S X=+MAGJOB("USER",1) I '(X=12!(X=15)) S PSSN="" 107 . E S PSSN=" ("_$E(PSSN,1,3)_"-"_$E(PSSN,4,5)_"-"_$E(PSSN,6,9)_")" 108 . I CNT S REPLY=CNT_"^1~Radiology Exams for: "_PATNAME_PSSN_" -- "_MSG 109 . E S REPLY=REPLY_" -- "_MSG 110 . S ^TMP($J,"MAGRAEX2",1)="^Day/Case~S3~1^Lock~~2^Procedure~~6^Modifier~~25^Image Date/Time~S1~7^Status~~8^# Img~S2~9^Onl~~10"_$S($G(SNDREMOT):"^RC~~12",1:"")_$S(SHOWPLAC:"^Site~~23",1:"")_"^Mod~~15^Interp By~~20^Imaging Loc~~11^CPT~~27" 111 I 'MAGJOB("P32") S $P(REPLY,"|",2)=SAVBEGDT 112 S ^TMP($J,"MAGRAEX2",0)=REPLY 113 S MAGGRY=$NA(^TMP($J,"MAGRAEX2")) 114 K ^TMP($J,"RAE1"),^("MAGRAEX") 115 Q 116 ; 117 PTLOOP ; loop through exam data & package it for VRAD use 118 S ISS=0 119 F S ISS=$O(^TMP($J,"MAGRAEX",ISS)) Q:'ISS S XX=^(ISS,1),XX2=^(2) D 120 . S CNT=CNT+1,RARPT=$P(XX,U,10) 121 . D IMGINFO^MAGJUTL2(RARPT,.Y) 122 . 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) 123 . S REMOTE2=REMOTE 124 . S:PLACE PLACE=$P($G(^MAG(2006.1,PLACE,0)),U,9) 125 . I PLACE]"",SHOWPLAC D 126 .. I SHOWPLAC'[(","_PLACE_",") S PLACE="" ; don't show user's logon pl ; <*> chg for p18? 127 . I SNDREMOT,REMOTE D 128 .. S T="" F I=1:1:$L(REMOTE,",") S T=T_$S(T="":"",1:",")_$P($G(^MAG(2005.2,$P(REMOTE,",",I),3)),U,5) 129 .. S REMOTE=T 130 . S DIV="",X=$P(XX2,U,5) I X'=DUZ(2) S DIV=$$STATN(X) 131 . I MAGDT="" S MAGDT=$P(XX,U,7) 132 . S MAGDT=$$FMTE^XLFDT(MAGDT,"5Z") 133 . S WHOLOCK=RARPT,MYLOCK="",DAYCASE=$P(XX,U,12) 134 . I WHOLOCK]"" S T=$$CHKLOCK^MAGJLS2B(WHOLOCK,DAYCASE),WHOLOCK=$P(T,U),MYLOCK=$P(T,U,2) 135 . S RDRIST=$P(XX2,U,3),PROCMOD=$P(XX2,U,8),CPT=$P(XX,U,17),RASTORD=$P(XX,U,15) 136 . S Y=U_DAYCASE_U_WHOLOCK_U_$E($P(XX,U,9),1,26)_U_PROCMOD_U_MAGDT_U_$E($P(XX,U,14),1,16)_U_IMGCNT_U_ONL 137 . I $G(SNDREMOT) S Y=Y_U_REMOTE 138 . S Y=Y_$S(SHOWPLAC:U_PLACE,1:"")_U_MODALITY_U_RDRIST_U_$E($P(XX,U,13),1,11)_U_CPT 139 . S STATUS=$P(XX,U,11),EXCAT="",CURPRIO=0,RASTCAT=$P(XX2,U,11),LRFLAG=$P(XX2,U,12) 140 . I STATUS]"" D 141 . . S EXCAT=RASTCAT 142 . . I RASTORD<2!(EXCAT="W")!('IMGCNT) S CURPRIO=0 ; Cancelled/Waiting/No images: Ignore exam 143 . . E I EXCAT="E" S CURPRIO=1 ; Examined="Current" exam 144 . . E S CURPRIO=2 ; must be a "prior" exam 145 . . I CURPRIO,'(ONL="Y") S CURPRIO=3 ; images on jukebox 146 . . I MAGJOB("P32"),'(EXCAT="E") S EXCAT="" Q ; P32 compat. 147 . . I RASTORD=9 S EXCAT="C" ; Complete 148 . . E I EXCAT="D"!(EXCAT="T") S EXCAT="I" ; just display one value meaning Interpreted 149 . S ^TMP($J,"MAGRAEX2",ISS)=Y_"^|"_$P(XX,U,1,3)_U_RARPT_"||"_EXCAT_U_WHOLOCK_U_MYLOCK_U_MODALITY_U_CPT_U_CURPRIO_U_RARPT_U_KEY_U_REMOTE2_U_LRFLAG 150 . ; * Note: Keep Pipe-pieces in sync with svmag2a^magjls3 & lstout^magjls2b * 151 Q 152 ; 153 STATN(X) ; get station #, else return input value 154 N T 155 I X]"" D GETS^DIQ(4,X,99,"E","T") S T=$G(T(4,X_",",99,"E")) I T]"" S X=T 156 Q X 157 ; 158 END Q ; -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGJMN1.m
r613 r623 1 MAGJMN1 2 ;;3.0;IMAGING;**16,9,22,18,65,76**;Jun 22, 2007;Build 19 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 SVRLIST 22 23 24 25 26 27 28 29 30 31 32 33 S $P(^MAG(2006.631,MAGIEN,0),U,5)=$$NOW^XLFDT() 34 35 36 37 ENSRCH 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 BLDDEF(LSTID) 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 S $P(^MAG(2006.631,LSTID,"DEF",0),U)=$$NOW^XLFDT() 118 119 120 BLDDEF2(X) 121 122 123 124 125 126 127 128 129 130 131 PRE 132 133 134 135 P18 136 137 138 139 140 BLDALL 141 142 143 144 145 146 147 148 149 150 151 152 POST 153 154 155 156 YN(MSG,DFLT) 157 158 159 160 YN1 161 162 163 164 165 LSTINQ 166 167 168 169 170 171 172 173 174 175 176 177 178 179 DISPSRCH(GREF) 180 181 182 183 184 185 VRSIT 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 EEPREF 203 204 205 206 207 208 209 210 211 212 INPREF 213 214 215 216 217 218 219 220 221 222 223 PRPREF 224 225 226 227 228 229 230 END 1 MAGJMN1 ;WIRMFO/JHC VRad Maint functions ; 29 Jul 2003 4:02 PM 2 ;;3.0;IMAGING;**16,9,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 ; 21 SVRLIST ; 22 W @IOF,!!?10,"Enter/Edit VistARad Exams List Definition",!! 23 N MAGIEN 24 K DIC S (DIC,DLAYGO)=2006.631,DIC(0)="ALMEQ" 25 D ^DIC I Y=-1 K DIC,DA,DR,DIE,DLAYGO Q 26 S X=$P(@(DIC_+Y_",0)"),U,2) 27 I X>9000 W !!,$C(7),"You may not edit System-Supplied files!" H 3 G SVRLIST 28 S DIE=2006.631,DA=+Y,DR="[MAGJ LIST EDIT]" 29 S MAGIEN=DA 30 D ^DIE I '$D(DA) G SVRLIST 31 D ENSRCH 32 D BLDDEF(MAGIEN) 33 D NOW^%DTC S $P(^MAG(2006.631,MAGIEN,0),U,5)=% 34 W !!,"List Definition complete!" R X:2 35 G SVRLIST 36 Q 37 ENSRCH ; Invoke Search for 2006.631 def'n 38 N GREF,GLIN,GO,CT,DIARI,DIC,FNOD,TNOD,NCOND,NODE0 39 ; GREF holds indirect ref to store search logic data: 40 ; @GREF@(3, ff -- conditional elements (fields/logic) 41 ; @GREF@(4, ff -- composite elements (ANDed conditions) 42 ; @GREF@(5, ff -- Human-readable search text 43 ; GLIN holds indirect ref to retrieve search logic data from ^DIBT 44 ; @GLIN@("DC", ff -- conditional elements 45 ; @GLIN@("DL", ff -- composite elements 46 ; @GLIN@("O", ff -- readable text 47 S GREF=$NA(^MAG(2006.631,MAGIEN,"DEF")) 48 S GO=1 I $D(@GREF@(5,1)) D ; show current logic 49 . W ! D DISPSRCH(GREF) 50 . S X=$$YN("Do you want to delete or re-enter the search logic?","NO") 51 . I X'="Y" S GO=0 Q 52 . W !!?7,"Re-entering the search logic requires first deleting the current",!?7,"definition, then entering the new definition from scratch." 53 . S X=$$YN("Are you sure you want to continue?","NO") 54 . I X'="Y" S GO=0 Q 55 I 'GO Q 56 W !!?7,"Now enter search logic for this List. To do this, the program" 57 W !?7,"will prompt you just as if you were going to run a Fileman Search." 58 W !?7,"When prompted STORE RESULTS OF SEARCH IN TEMPLATE:, answer with 'TEMP'" 59 W !?7,"If prompted ... OK TO PURGE? NO// answer 'YES'; don't bother specifying" 60 W !?7,"output print fields, but just RETURN through all the prompts to" 61 W !?7,"complete the process. The search definition will be saved as part" 62 W !?7,"of this List definition; you will test it out by running it from " 63 W !?7,"the workstation. If you need to modify the search logic, you will" 64 W !?7,"have to re-enter it in its entirety." 65 W !!?7,"NOTES: EXAM LOCK INDICATOR will not work for search logic;" 66 W !?14,"REMOTE CACHE INDICATOR only works for Null/Not Null logic." 67 S DIC=2006.634 D EN^DIS ; call Fman Search Logic routine. It will store search logic in ^DIBT 68 ; 2006.634 is intentional--don't change this! 69 I '$G(DIARI) W !!," Search logic NOT updated" D Q 70 . Q:'$D(@GREF@(5,1)) ; if no logic had existed, quit 71 . S X=$$YN("Do you want to DELETE the search logic?","NO") 72 . I X="Y" K @GREF@(3) K ^(4),^(5) W " -- Deleted!" 73 K @GREF@(3) K ^(4),^(5) 74 S GLIN=$NA(^DIBT(DIARI)) ; Copy logic to 2006.631 DEF nodes 75 S FNOD="DC",TNOD=3,CT=0 ; "DC" data--straight copy 76 S T=0 F S T=$O(@GLIN@(FNOD,T)) Q:T="" S X=^(T),CT=CT+1,@GREF@(TNOD,T)=X 77 S @GREF@(TNOD,0)=CT 78 S FNOD="DL",TNOD=4,CT=0 ; "DL" data--copy depends on storage scheme in DIBT: 79 ;Zero node null -- straight copy 80 ; Else 1) either only one condition is defined; 81 ; or, 2) the zero-node condition is ANDed with all defined conditions 82 ; Case 2: Var A -- Pre-pend zero node, then dup zero node 83 ; Var B -- Pre-pend zero node 84 S NCOND=+$G(@GLIN@(FNOD)) 85 I $G(@GLIN@(FNOD,0))]"" S NODE0=^(0) D 86 . S T=0 F S T=$O(@GLIN@(FNOD,T)) Q:T="" S X=^(T) I X]"" S CT=CT+1,@GREF@(TNOD,CT)=NODE0_X 87 . I CT'=NCOND S CT=CT+1,@GREF@(TNOD,CT)=NODE0_$S(CT=1:"",1:"^") 88 E D 89 . S T=0 F S T=$O(@GLIN@(FNOD,T)) Q:T="" S X=^(T) I X]"" S CT=CT+1,@GREF@(TNOD,CT)=X 90 S @GREF@(TNOD,0)=CT 91 ; readable text--straight copy 92 S TNOD=5,T=0 F S T=$O(@GLIN@("O",T)) Q:T="" S @GREF@(TNOD,T)=^(T,0) 93 Q 94 ; 95 BLDDEF(LSTID) ; build DEF nodes for Column/Sort defs 96 N QX,SS,STR,LSTHDR,T,T0,T8,T6,HASCASE,XT,HASDATE 97 S SS=0,HASCASE=0,HASDATE=0 98 ; columns/hdrs: Order in T array by the Relative Column Order 99 F S SS=$O(^MAG(2006.631,LSTID,1,SS)) D Q:'SS 100 . I 'SS D Q 101 . . I 'HASCASE S X=1 D BLDDEF2(X) ; FORCE CASE# 102 . . I 'HASDATE S X=7 D BLDDEF2(X) ; DATE/TIME 103 . E S X=^MAG(2006.631,LSTID,1,SS,0) 104 . D BLDDEF2(X) 105 ; go thru T to build ordered field sequence for output columns 106 S QX="T",STR="",LSTHDR="" 107 F S QX=$Q(@QX) Q:QX="" S X=@QX D 108 . S STR=STR_$S(STR="":"",1:U)_$P(X,U) 109 . S LSTHDR=LSTHDR_$S(LSTHDR="":"",1:U)_$P(X,U,2) 110 S ^MAG(2006.631,LSTID,"DEF",.5)=LSTHDR,^(1)=STR 111 ; Sort values: 112 S SS=0,STR="" 113 F S SS=$O(^MAG(2006.631,LSTID,2,SS)) Q:'SS S X=^(SS,0) D 114 . S X=+X_$S($P(X,U,2):"-",1:"") 115 . S STR=STR_$S(STR="":"",1:U)_X 116 S ^MAG(2006.631,LSTID,"DEF",2)=STR 117 D NOW^%DTC S $P(^MAG(2006.631,LSTID,"DEF",0),U)=% 118 Q 119 ; 120 BLDDEF2(X) ; 121 S X=+X_$S($P(X,U,2):";"_+$P(X,U,2),1:"") 122 I 'HASCASE S HASCASE=(+X=1) 123 I 'HASDATE S HASDATE=(+X=7) 124 S T0=^MAG(2006.63,+X,0),T6=+$P(T0,U,6) S:'T6 T6=99 125 S T8=$P(T0,U,8) I T8]"" S T8="~"_T8 126 S XT=$S($P(T0,U,3)]"":$P(T0,U,3),1:$P(T0,U,2))_T8 127 S $P(XT,"~",3)=+X 128 S T(T6,+X)=X_U_XT 129 Q 130 ; 131 PRE ; init 2006.63 prior to KIDS install 132 N DIK,DA S DIK="^MAG(2006.63,",DA=0 F S DA=$O(@(DIK_DA_")")) Q:'DA D ^DIK 133 Q 134 ; 135 P18 ; Patch 18 inits 136 D BLDALL 137 D POST 138 Q 139 ; 140 BLDALL ; Create "DEF" nodes, Button labels List Def'ns 141 ; Updates all lists after s/w update list defs are installed 142 N SS,LSTDAT,LSTNUM,BUTTON,LSTTYP 143 S SS=0 144 F S SS=$O(^MAG(2006.631,SS)) Q:'SS S LSTDAT=$G(^(SS,0)) I LSTDAT]"" D 145 . S LSTNUM=$P(LSTDAT,U,2),BUTTON=$P(LSTDAT,U,7),LSTTYP=$P(LSTDAT,U,3) 146 . I LSTNUM>9900!$P(LSTDAT,U,6) D BLDDEF(SS) ; build DEF nodes for System Lists & any Enabled lists 147 . I BUTTON="",(LSTTYP]"") D ; Create Button Labels if needed 148 . . S BUTTON=$S(LSTTYP="U":"Unread #",LSTTYP="R":"Recent #",LSTTYP="A":"All Active #",LSTTYP="P":"Pending #",1:"List #")_LSTNUM 149 . . S $P(^MAG(2006.631,SS,0),U,7)=BUTTON 150 Q 151 ; 152 POST ; Install msg 153 D INS^MAGQBUT4(XPDNM,DUZ,$$NOW^XLFDT,XPDA) 154 Q 155 ; 156 YN(MSG,DFLT) ; get Yes/No reply 157 N X I $G(DFLT)="" S DFLT="N" 158 W ! 159 S DFLT=$E(DFLT),DFLT=$S(DFLT="N":"NO",1:"YES") 160 YN1 W !,MSG_" "_DFLT_"// " 161 R X:DTIME S:X="" X=DFLT S X=$E(X),X=$TR(X,"ynYN","YNYN") 162 I "YN"'[X W " ??? Enter YES or NO",! G YN1 163 Q X 164 ; 165 LSTINQ ; Inq/Disp list def'n 166 N GREF,MAGIEN 167 W !!?15,"Display VistARad Exams List Definition",!! 168 N MAGIEN 169 S DIC=2006.631,DIC(0)="AMEQ" 170 D ^DIC I Y=-1 K DIC,DA,DR Q 171 K DR S DA=+Y,MAGIEN=DA 172 S GREF=$NA(^MAG(2006.631,MAGIEN,"DEF")) 173 W ! D EN^DIQ 174 R !,"Enter RETURN to display the Search Logic: ",X:DTIME W ! 175 D DISPSRCH(GREF) 176 G LSTINQ 177 Q 178 ; 179 DISPSRCH(GREF) ; GREF holds indirect ref for global holding search logic data 180 I $D(@GREF@(5,1)) W !,"List Exams where:",! D 181 . F I=1:1 Q:'$D(@GREF@(5,I)) W !?3,^(I) 182 E W !?3,"NO Search Logic defined!" 183 Q 184 ; 185 VRSIT ; 186 W @IOF,!!?10,"Enter/Edit VistARad Site Parameters",!! 187 S DIC=2006.69,DIC(0)="ALMEQ" 188 I '$D(^MAG(DIC,1)) S DLAYGO=DIC 189 D ^DIC I Y=-1 K DIC,DA,DR,DIE,DLAYGO Q 190 S DIE=2006.69,DA=+Y,DR=".01:3.99;4.1:20" 191 D ^DIE 192 K DIC,DA,DR,DIE,DLAYGO 193 N PLACE S DA="" 194 S PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2))) 195 S:PLACE DA=PLACE 196 I DA D 197 . W !!,"Editing VistARad Timeout for division #",DUZ(2),! 198 . S DIE=2006.1,DR="123" D ^DIE 199 K DA,DR,DIE 200 Q 201 ; 202 EEPREF ; 203 W @IOF,!!?10,"Enter/Edit VistARad Prefetch Logic",!! 204 N MAGIEN 205 K DIC S (DIC,DLAYGO)=2006.65,DIC(0)="ALMEQ" 206 D ^DIC I Y=-1 K DIC,DIE,DR,DLAYGO Q 207 S DIE=2006.65,DA=+Y,DR="[MAGJ PRIOR EDIT]" 208 S MAGIEN=DA 209 D ^DIE I '$D(DA) G EEPREF 210 G EEPREF 211 Q 212 INPREF ; Inquire VRad PreFetch 213 W @IOF,!!?10,"Inquire VistARad Prefetch Logic",!! 214 N MAGIEN,BY,FR,TO 215 S DIC=2006.65,DIC(0)="AMEQ" 216 D ^DIC I Y=-1 K DIC Q 217 S DA=+Y,(FR,TO)=$P(Y,U,2),MAGIEN=DA,L=0 218 S BY="[MAGJ PRIOR SORT]",DIS(0)="I D0=MAGIEN" 219 D EN^DIP 220 R !,"Enter RETURN to continue: ",X:DTIME W ! 221 G INPREF 222 Q 223 PRPREF ;Print VRad Prefetch 224 N BY 225 W !! S DIC=2006.65,L=0,BY="[MAGJ PRIOR SORT]" 226 D EN1^DIP 227 R !,"Enter RETURN to continue: ",X:DTIME W ! 228 Q 229 ; 230 END ; -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGJUPD1.m
r613 r623 1 MAGJUPD1 ;WOIFO/JHC VistARad Update Exam Status ; 29 Jul 2003 10:02 AM 2 ;;3.0;IMAGING;**16,22,18,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 ; Subroutines for RPC's to update Exam Status to "Interpreted", and 21 ; for "Closing" a case that is open on the DX Workstation 22 ; 23 ERR N ERR S ERR=$$EC^%ZOSV S @MAGGRY@(0)="0^Server Program Error: "_ERR 24 D @^%ZOSF("ERRTN") 25 Q:$Q 1 Q 26 ; 27 STATUS(MAGGRY,PARAMS,DATA) ; rpc: MAGJ RADSTATUSUPDATE 28 ; Update Exam Status to "Interpreted" and/or Close the exam 29 ; Only updates the Status if the current value is "Examined" 30 ; This routine defines variables needed for calling the Radiology 31 ; package routine UP1^RAUTL1, for filing Status updates 32 ; 33 ; PARAMS = UPDFLAG ^ RADFN ^ RADTI ^ RACNI ^ RARPT ^ UPDPSKEY 34 ; UPDFLAG = 1/0 -- 1 to perform update; else no update made 35 ; RARPT = ptr to Rad Exam Report file 36 ; RADFN,RADTI,RACNI = pointers to Rad Patient File for the exam 37 ; UPDPSKEY = 1/0 -- 1 to update Presentation State &/or Key Image data 38 ; MAGGRY = return results in @MAGGRY 39 ; 40 N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJUPD1" 41 N RARPT,RADFN,RADTI,RACNI,RAEXT,RACNE,RADTE,RAINT,RAMDV,DIQUIET 42 N RAONLINE,ZTQUEUED,RAOR,RASN,RASTI,RAPRTSET,LOGDATA,RSL,TIMESTMP 43 N UPDPSKEY,MAGRET,MAGLST,REPLY,UPDFLAG,RADATA,RIST,MAGPSET,RACNILST,ACNLST 44 S MAGLST="MAGJUPDATE" 45 K MAGGRY S MAGGRY=$NA(^TMP($J,MAGLST)) K @MAGGRY ; assign MAGGRY value 46 S DIQUIET=1 D DT^DICRW 47 S TIMESTMP=$$NOW^XLFDT() 48 S UPDFLAG=$P(PARAMS,U),RADFN=$P(PARAMS,U,2),RADTI=$P(PARAMS,U,3),RACNI=$P(PARAMS,U,4),RARPT=$P(PARAMS,U,5),UPDPSKEY=+$P(PARAMS,U,6) 49 S REPLY="0^4~Closing case with"_$S(UPDFLAG:"",1:" NO")_" Status Update" 50 S RAPRTSET=0 51 I RADFN,RADTI,RACNI 52 E S REPLY="0^4~Request Contains Invalid Case Pointer ("_RARPT_")" G STATUSZ 53 D GETEXAM2^MAGJUTL1(RADFN,RADTI,RACNI,0,.MAGRET) 54 I 'MAGRET S REPLY="0^4~Current Case Not Accessible for Updating" G STATUSZ 55 ; 1 RADFN RADTI RACNI RANME RASSN <--Contents of RADATA, 56 ; 6 RADATE RADTE RACN RAPRC RARPT from GETEXAM 57 ;11 RAST DAYCASE RAELOC RASTP RASTORD 58 ;16 RADTPRT 59 S RADATA=$G(^TMP($J,"MAGRAEX",1,1)) 60 S RAEXT=$P(RADATA,U,12),RACNE=$P(RAEXT,"-",2),RADTE=$P(RADATA,U,7) 61 S RAINT=RADTI_"-"_RACNI 62 D CLOSE(.RSL,RADFN_U_RADTI_U_RACNI_U_U_1,.LOGDATA) ; unlock the case 63 ; proceed only if case was locked by this user 64 ; if it was not Locked, then do NOT update PS, Key Images 65 I 'RSL S REPLY=RSL,UPDPSKEY=0 G STATUSZ 66 I 'UPDFLAG S REPLY="0^1~Case #"_RAEXT_" Closed; No Status Update performed" G STATUSZ 67 S RIST=$P(RSL,U,2) ; CLOSE reports back the type of radiologist 68 ; now we know this user had locked the case, & wants to do Status update 69 D EN2^RAUTL20(.MAGPSET) ; get info re rad PrintSet 70 ; 71 ; IF exam is not "Examined", and not "Cancelled" and past "Waiting" 72 ; then assume it has already been updated via another pathway, 73 ; either as printset member (via code at tag PRTSET, below), 74 ; or from a voice-dictation or terminal session by the radiologist 75 ; For these cases, no warning msg is sent 76 ; Else, update not allowed, so give warning msg 77 ; Note that when the Exam was OPENed, it must have had status "Examined" 78 I '$D(^RA(72,"AVC","E",$P(RADATA,U,11))) D G STATUSX:(+$P(REPLY,U,2)=1),STATUSZ ; Current Status MUST be "Examined" Category 79 . I $P(RADATA,U,15)>2 D ; assume update has otherwise been done, eg voice dictation or manual entry in Vista 80 .. S RACNILST=RACNI,RASTI=$P(RADATA,U,11) ; need for code at tag statusx 81 .. I RAPRTSET S REPLY="0^1~Printset Exams with Case #"_RAEXT_" have been updated" 82 .. E S REPLY="0^1~No Update done for Case #"_RAEXT_"--current status is "_$P(RADATA,U,14) 83 . E S REPLY="0^3~No Update Allowed for Case #"_RAEXT_"--current status is "_$P(RADATA,U,14) 84 ; 85 ; now ready to update exam status 86 S RAMDV=$P(^RADPT(RADFN,"DT",RADTI,0),U,3) 87 S RAMDV=$TR(^RA(79,RAMDV,.1),"YyNn","1100") 88 ; 89 ; Update interpreting radiologist field in Rad file 90 I RIST D I RACNILST="" G STATUSZ 91 . N SAVRACNI,RTN S RACNILST="" 92 PRTSET . ; if exam is part of Rad Print-Set, then update all exams of printset 93 . I RAPRTSET D 94 .. S ACNLST="",SAVRACNI=RACNI,X=0 95 .. F I=0:1 S X=$O(MAGPSET(X)) Q:'X S RACNILST=RACNILST_$S(I:U,1:"")_X S:RACNE'=+MAGPSET(X) ACNLST=ACNLST_", "_"-"_+MAGPSET(X) 96 . E S RACNILST=RACNI 97 . F I=1:1:$L(RACNILST,U) S RACNI=$P(RACNILST,U,I) I RACNI D I RACNILST="" Q 98 .. S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI 99 .. D STUFPHY^RARIC1(DUZ,RIST,.RTN) 100 .. I 'RTN S REPLY="0^4~Unable to update Interpreting Radiologist: "_RTN_"." S RACNILST="" 101 . I RAPRTSET S RACNI=SAVRACNI 102 S RAONLINE=1,ZTQUEUED=1 D UP1^RAUTL1 ; Suppress msgs, do Status update 103 ;<*> K RAONLINE,ZTQUEUED D UP1^RAUTL1 ; <*> Testing Only: ENABLE msgs 104 I RAOR<0 S REPLY="0^3~Exam Status for Case #"_RAEXT_" CANNOT be updated; current status remains: "_$S($G(RASN)]"":RASN,1:"Unknown") 105 I G STATUSZ 106 ; 107 S REPLY="0^1~For Case #"_$S($G(ACNLST)]"":"s ",1:"")_RAEXT_$S(RAPRTSET:ACNLST,1:"")_", Exam Status updated to "_RASN 108 ; 109 STATUSX ; Newly Interpreted exam: 110 ; Log the Interpreted event 111 D LOG^MAGJUTL3("VR-INT",LOGDATA) 112 ; Update Recent Exams List 113 G STATUSZ:'$P(^MAG(2006.69,1,0),U,8) ; no bkgnd compile enabled 114 L +^XTMP("MAGJ2","RECENT"):5 115 E G STATUSZ 116 N INDX F I=1:1:$L(RACNILST,U) S RACNI=$P(RACNILST,U,I) I RACNI D 117 . S INDX=+$G(^XTMP("MAGJ2","RECENT",0))+1,$P(^(0),U)=INDX,^(INDX)=RADFN_U_RADTI_U_RACNI_U_RASTI 118 L -^XTMP("MAGJ2","RECENT") 119 STATUSZ ; 120 ; store PS, Key Image data 121 I UPDPSKEY,($D(DATA)>9) D 122 . D SAVKPS^MAGJUPD2(RARPT,UPDPSKEY,.DATA,.X) 123 . S REPLY=REPLY_$P(X,"~",2,99) 124 S @MAGGRY@(0)=REPLY 125 K ^TMP($J,"MAGRAEX"),^("RAE1") 126 Q 127 ; 128 CLOSE(RSL,PARAMS,LOGDATA) ; Close/unlock a case 129 ; Input: PARAMS = DFN ^ DTI ^ CNI ^ RPT ^ UPDFLAG 130 ; 131 ; DFN,DTI,CNI,RPT = pointers to Rad File for the exam 132 ; UPDFLAG = 1/0 -- 1 indicates CLOSE was called from subroutine 133 ; STATUS, above (which has already called GETEXAM) 134 ; RSL = return result of the Close 135 ; This subroutine may be called directly (to close a case without 136 ; doing a status update), or is called from tag STATUS, above, when 137 ; also doing a status update 138 ; 139 N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJUPD1" 140 N RPT,DFN,DTI,CNI,MAGRET,REPLY,RARPT,UPDFLAG,RIST,DAYCASE,NLOCKS,MYLOCK 141 S DFN=$P(PARAMS,U),DTI=$P(PARAMS,U,2),CNI=$P(PARAMS,U,3),RPT=$P(PARAMS,U,4),UPDFLAG=$P(PARAMS,U,5) 142 S LOGDATA="" 143 I $P($G(^MAG(2006.69,1,0)),U,4) 144 E S REPLY=$S(UPDFLAG:"0^3~Updates not allowed at this site--no action taken",1:"") G CLOSEZ ; Status Update NOT Enabled 145 S RIST=+MAGJOB("USER",1) I RIST 146 E S REPLY=$S(UPDFLAG:"0^3~Update allowed only by a radiologist--no action taken",1:"") G CLOSEZ ; need only unlock a radiologist 147 I DFN,DTI,CNI 148 E S REPLY="0^4~Request Contains Invalid Case Pointer ("_RPT_")--no action taken" G CLOSEZ 149 ; 150 I 'UPDFLAG N RADATA D I 'MAGRET G CLOSEZ 151 . D GETEXAM2^MAGJUTL1(DFN,DTI,CNI,0,.MAGRET) 152 . I 'MAGRET S REPLY="0^4~No Current Case accessible to close--no action taken" 153 . E S RADATA=$G(^TMP($J,"MAGRAEX",1,1)) 154 S RARPT=$P(RADATA,U,10),DAYCASE=$P(RADATA,U,12) 155 I RARPT,DAYCASE 156 E S REPLY="0^4~Current Case not accessible to close--no action taken" G CLOSEZ 157 ; 158 D LOCKACT^MAGJEX1A(RARPT,DAYCASE,101,,.MYLOCK) 159 S LOGDATA=$P(MYLOCK(1),"|",2) 160 I 'MYLOCK(1) S X=$P(MYLOCK(1),U,4) D S LOGDATA="" G CLOSEZ 161 . I UPDFLAG S REPLY="0^1~Case #"_DAYCASE_$S(X]"":" locked by "_X,1:" not locked by "_$P(MAGJOB("USER",1),U,2))_"--No Status update performed" 162 . E S REPLY="0^1~ " ; case wasn't opened by this R'ist; nothing to do 163 ; 164 I UPDFLAG S REPLY=1_U_RIST 165 E S REPLY="0^1~Case #"_DAYCASE_$S(+MYLOCK(1):" unlocked",+MYLOCK(2):" reserve cancelled",1:" closed")_"--No Status Update performed." 166 CLOSEZ S RSL=REPLY 167 Q 168 ; 169 END Q ; 1 MAGJUPD1 ;WOIFO/JHC VistARad Update Exam Status ; 29 Jul 2003 10:02 AM 2 ;;3.0;IMAGING;**16,22,18**;Mar 07, 2006 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 Q 19 ; Subroutines for RPC's to update Exam Status to "Interpreted", and 20 ; for "Closing" a case that is open on the DX Workstation 21 ; 22 ERR N ERR S ERR=$$EC^%ZOSV S @MAGGRY@(0)="0^Server Program Error: "_ERR 23 D @^%ZOSF("ERRTN") 24 Q:$Q 1 Q 25 ; 26 STATUS(MAGGRY,PARAMS,DATA) ; rpc: MAGJ RADSTATUSUPDATE 27 ; Update Exam Status to "Interpreted" and/or Close the exam 28 ; Only updates the Status if the current value is "Examined" 29 ; This routine defines variables needed for calling the Radiology 30 ; package routine UP1^RAUTL1, for filing Status updates 31 ; 32 ; PARAMS = UPDFLAG ^ RADFN ^ RADTI ^ RACNI ^ RARPT ^ UPDPSKEY 33 ; UPDFLAG = 1/0 -- 1 to perform update; else no update made 34 ; RARPT = ptr to Rad Exam Report file 35 ; RADFN,RADTI,RACNI = pointers to Rad Patient File for the exam 36 ; UPDPSKEY = 1/0 -- 1 to update Presentation State &/or Key Image data 37 ; MAGGRY = return results in @MAGGRY 38 ; 39 N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJUPD1" 40 N RARPT,RADFN,RADTI,RACNI,RAEXT,RACNE,RADTE,RAINT,RAMDV,DIQUIET 41 N RAONLINE,ZTQUEUED,RAOR,RASN,RASTI,RAPRTSET,LOGDATA,RSL,TIMESTMP 42 N UPDPSKEY,MAGRET,MAGLST,REPLY,UPDFLAG,RADATA,RIST,MAGPSET,RACNILST,ACNLST 43 S MAGLST="MAGJUPDATE" 44 K MAGGRY S MAGGRY=$NA(^TMP($J,MAGLST)) K @MAGGRY ; assign MAGGRY value 45 S DIQUIET=1 D DT^DICRW 46 D NOW^%DTC S TIMESTMP=% 47 S UPDFLAG=$P(PARAMS,U),RADFN=$P(PARAMS,U,2),RADTI=$P(PARAMS,U,3),RACNI=$P(PARAMS,U,4),RARPT=$P(PARAMS,U,5),UPDPSKEY=+$P(PARAMS,U,6) 48 S REPLY="0^4~Closing case with"_$S(UPDFLAG:"",1:" NO")_" Status Update" 49 S RAPRTSET=0 50 I RADFN,RADTI,RACNI 51 E S REPLY="0^4~Request Contains Invalid Case Pointer ("_RARPT_")" G STATUSZ 52 D GETEXAM2^MAGJUTL1(RADFN,RADTI,RACNI,0,.MAGRET) 53 I 'MAGRET S REPLY="0^4~Current Case Not Accessible for Updating" G STATUSZ 54 ; 1 RADFN RADTI RACNI RANME RASSN <--Contents of RADATA, 55 ; 6 RADATE RADTE RACN RAPRC RARPT from GETEXAM 56 ;11 RAST DAYCASE RAELOC RASTP RASTORD 57 ;16 RADTPRT 58 S RADATA=$G(^TMP($J,"MAGRAEX",1,1)) 59 S RAEXT=$P(RADATA,U,12),RACNE=$P(RAEXT,"-",2),RADTE=$P(RADATA,U,7) 60 S RAINT=RADTI_"-"_RACNI 61 D CLOSE(.RSL,RADFN_U_RADTI_U_RACNI_U_U_1,.LOGDATA) ; unlock the case 62 ; proceed only if case was locked by this user 63 ; if it was not Locked, then do NOT update PS, Key Images 64 I 'RSL S REPLY=RSL,UPDPSKEY=0 G STATUSZ 65 I 'UPDFLAG S REPLY="0^1~Case #"_RAEXT_" Closed; No Status Update performed" G STATUSZ 66 S RIST=$P(RSL,U,2) ; CLOSE reports back the type of radiologist 67 ; now we know this user had locked the case, & wants to do Status update 68 D EN2^RAUTL20(.MAGPSET) ; get info re rad PrintSet 69 ; 70 ; IF exam is not "Examined", and not "Cancelled" and past "Waiting" 71 ; then assume it has already been updated via another pathway, 72 ; either as printset member (via code at tag PRTSET, below), 73 ; or from a voice-dictation or terminal session by the radiologist 74 ; For these cases, no warning msg is sent 75 ; Else, update not allowed, so give warning msg 76 ; Note that when the Exam was OPENed, it must have had status "Examined" 77 I '$D(^RA(72,"AVC","E",$P(RADATA,U,11))) D G STATUSX:(+$P(REPLY,U,2)=1),STATUSZ ; Current Status MUST be "Examined" Category 78 . I $P(RADATA,U,15)>2 D ; assume update has otherwise been done, eg voice dictation or manual entry in Vista 79 .. S RACNILST=RACNI,RASTI=$P(RADATA,U,11) ; need for code at tag statusx 80 .. I RAPRTSET S REPLY="0^1~Printset Exams with Case #"_RAEXT_" have been updated" 81 .. E S REPLY="0^1~No Update done for Case #"_RAEXT_"--current status is "_$P(RADATA,U,14) 82 . E S REPLY="0^3~No Update Allowed for Case #"_RAEXT_"--current status is "_$P(RADATA,U,14) 83 ; 84 ; now ready to update exam status 85 S RAMDV=$P(^RADPT(RADFN,"DT",RADTI,0),U,3) 86 S RAMDV=$TR(^RA(79,RAMDV,.1),"YyNn","1100") 87 ; 88 ; Update interpreting radiologist field in Rad file 89 I RIST D I RACNILST="" G STATUSZ 90 . N SAVRACNI,RTN S RACNILST="" 91 PRTSET . ; if exam is part of Rad Print-Set, then update all exams of printset 92 . I RAPRTSET D 93 .. S ACNLST="",SAVRACNI=RACNI,X=0 94 .. F I=0:1 S X=$O(MAGPSET(X)) Q:'X S RACNILST=RACNILST_$S(I:U,1:"")_X S:RACNE'=+MAGPSET(X) ACNLST=ACNLST_", "_"-"_+MAGPSET(X) 95 . E S RACNILST=RACNI 96 . F I=1:1:$L(RACNILST,U) S RACNI=$P(RACNILST,U,I) I RACNI D I RACNILST="" Q 97 .. S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI 98 .. D STUFPHY^RARIC1(DUZ,RIST,.RTN) 99 .. I 'RTN S REPLY="0^4~Unable to update Interpreting Radiologist: "_RTN_"." S RACNILST="" 100 . I RAPRTSET S RACNI=SAVRACNI 101 S RAONLINE=1,ZTQUEUED=1 D UP1^RAUTL1 ; Suppress msgs, do Status update 102 ;<*> K RAONLINE,ZTQUEUED D UP1^RAUTL1 ; <*> Testing Only: ENABLE msgs 103 I RAOR<0 S REPLY="0^3~Exam Status for Case #"_RAEXT_" CANNOT be updated; current status remains: "_$S($G(RASN)]"":RASN,1:"Unknown") 104 I G STATUSZ 105 ; 106 S REPLY="0^1~For Case #"_$S($G(ACNLST)]"":"s ",1:"")_RAEXT_$S(RAPRTSET:ACNLST,1:"")_", Exam Status updated to "_RASN 107 ; 108 STATUSX ; Newly Interpreted exam: 109 ; Log the Interpreted event 110 D LOG^MAGJUTL3("VR-INT",LOGDATA) 111 ; Update Recent Exams List 112 G STATUSZ:'$P(^MAG(2006.69,1,0),U,8) ; no bkgnd compile enabled 113 L +^XTMP("MAGJ2","RECENT"):5 114 E G STATUSZ 115 N INDX F I=1:1:$L(RACNILST,U) S RACNI=$P(RACNILST,U,I) I RACNI D 116 . S INDX=+$G(^XTMP("MAGJ2","RECENT",0))+1,$P(^(0),U)=INDX,^(INDX)=RADFN_U_RADTI_U_RACNI_U_RASTI 117 L -^XTMP("MAGJ2","RECENT") 118 STATUSZ ; 119 ; store PS, Key Image data 120 I UPDPSKEY,($D(DATA)>9) D 121 . D SAVKPS^MAGJUPD2(RARPT,UPDPSKEY,.DATA,.X) 122 . S REPLY=REPLY_$P(X,"~",2,99) 123 S @MAGGRY@(0)=REPLY 124 K ^TMP($J,"MAGRAEX"),^("RAE1") 125 Q 126 ; 127 CLOSE(RSL,PARAMS,LOGDATA) ; Close/unlock a case 128 ; Input: PARAMS = DFN ^ DTI ^ CNI ^ RPT ^ UPDFLAG 129 ; 130 ; DFN,DTI,CNI,RPT = pointers to Rad File for the exam 131 ; UPDFLAG = 1/0 -- 1 indicates CLOSE was called from subroutine 132 ; STATUS, above (which has already called GETEXAM) 133 ; RSL = return result of the Close 134 ; This subroutine may be called directly (to close a case without 135 ; doing a status update), or is called from tag STATUS, above, when 136 ; also doing a status update 137 ; 138 N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJUPD1" 139 N RPT,DFN,DTI,CNI,MAGRET,REPLY,RARPT,UPDFLAG,RIST,DAYCASE,NLOCKS,MYLOCK 140 S DFN=$P(PARAMS,U),DTI=$P(PARAMS,U,2),CNI=$P(PARAMS,U,3),RPT=$P(PARAMS,U,4),UPDFLAG=$P(PARAMS,U,5) 141 S LOGDATA="" 142 I $P($G(^MAG(2006.69,1,0)),U,4) 143 E S REPLY=$S(UPDFLAG:"0^3~Updates not allowed at this site--no action taken",1:"") G CLOSEZ ; Status Update NOT Enabled 144 S RIST=+MAGJOB("USER",1) I RIST 145 E S REPLY=$S(UPDFLAG:"0^3~Update allowed only by a radiologist--no action taken",1:"") G CLOSEZ ; need only unlock a radiologist 146 I DFN,DTI,CNI 147 E S REPLY="0^4~Request Contains Invalid Case Pointer ("_RPT_")--no action taken" G CLOSEZ 148 ; 149 I 'UPDFLAG N RADATA D I 'MAGRET G CLOSEZ 150 . D GETEXAM2^MAGJUTL1(DFN,DTI,CNI,0,.MAGRET) 151 . I 'MAGRET S REPLY="0^4~No Current Case accessible to close--no action taken" 152 . E S RADATA=$G(^TMP($J,"MAGRAEX",1,1)) 153 S RARPT=$P(RADATA,U,10),DAYCASE=$P(RADATA,U,12) 154 I RARPT,DAYCASE 155 E S REPLY="0^4~Current Case not accessible to close--no action taken" G CLOSEZ 156 ; 157 D LOCKACT^MAGJEX1A(RARPT,DAYCASE,101,,.MYLOCK) 158 S LOGDATA=$P(MYLOCK(1),"|",2) 159 I 'MYLOCK(1) S X=$P(MYLOCK(1),U,4) D S LOGDATA="" G CLOSEZ 160 . I UPDFLAG S REPLY="0^1~Case #"_DAYCASE_$S(X]"":" locked by "_X,1:" not locked by "_$P(MAGJOB("USER",1),U,2))_"--No Status update performed" 161 . E S REPLY="0^1~ " ; case wasn't opened by this R'ist; nothing to do 162 ; 163 I UPDFLAG S REPLY=1_U_RIST 164 E S REPLY="0^1~Case #"_DAYCASE_$S(+MYLOCK(1):" unlocked",+MYLOCK(2):" reserve cancelled",1:" closed")_"--No Status Update performed." 165 CLOSEZ S RSL=REPLY 166 Q 167 ; 168 END Q ; -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGJUPD2.m
r613 r623 1 MAGJUPD2 ;WIRMFO/JHC VistaRad RPCs-Update PS & KEY Img ; 14 July 2004 10:05 AM 2 ;;3.0;IMAGING;**18,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 ERR N ERR S ERR=$$EC^%ZOSV S @MAGGRY@(0)="0^4~"_ERR 21 D @^%ZOSF("ERRTN") 22 Q:$Q 1 Q 23 ; 24 SAVKPS(RARPT,INTERPFL,DATA,REPLY) ; Save study data: Key/Interpretation Images & Pres. State 25 ; RARPT--exam pointer 26 ; INTERPFL--1/0; 1=This is associated with a Rad Interpretation; Optional 27 ; DATA--array of input data; see structure at end of routine 28 ; REPLY--return string 29 N PSTRAK,IDATA,IMGCT,PSTOT,PSLINCT,PSKILCT,KEYCT,INTCT,STUDY,LINE,NEWIMG,NEWPS 30 N IMGREF,IMGIEN,PSIEN,SAVOP,STIEN,TYPE,IMG,ICT,NEWIMG,INITSTDY,SEQNUM 31 S INTERPFL=+$G(INTERPFL) 32 S NEWIMG=0,NEWPS=0,IMGIEN="",PSIEN="",SEQNUM=0 33 S (IMGCT,PSTOT,PSLINCT,KEYCT,INTCT,PSKILCT)=0 34 S IMGREF="",SAVOP="NOOP" 35 I '$D(TIMESTMP) N TIMESTMP S TIMESTMP=$$NOW^XLFDT() 36 ; 1st, process input in DATA 37 S IDATA="" 38 F S IDATA=$O(DATA(IDATA)) Q:IDATA="" S LINE=DATA(IDATA) I LINE]"" D 39 . I LINE="*IMAGE" S NEWIMG=1 Q 40 . I LINE="*PS" S NEWPS=1 Q 41 . I $E(LINE,1,4)="*END" S (NEWIMG,NEWPS)=0 Q 42 . I NEWIMG D IMGINIT(LINE) S NEWIMG=0 Q ; Init storage for this Image 43 . I NEWPS D PSINIT(LINE) S NEWPS=0 Q ; Init storage for a PS 44 . D @(SAVOP_"(LINE)") 45 ; Now update the Study node info 46 S INITSTDY=$S(INTERPFL:"INIT_STUDY",1:"") 47 S STIEN=$$STUDYID("",RARPT,1,INITSTDY) 48 I $D(PSTRAK) S IMG="" D ; Update key imgs in Study node 49 . F S IMG=$O(PSTRAK(IMG)) Q:'IMG S NEWIMG=1,TYPE="" D 50 . . F S TYPE=$O(PSTRAK(IMG,TYPE)) Q:TYPE="" D 51 . . . F ICT=1:1:PSTRAK(IMG,TYPE,0) D SAVKIMG(IMG,PSTRAK(IMG,TYPE,ICT),TYPE,NEWIMG) S NEWIMG=0 52 SAVKPSZ ; 53 I IMGCT!PSTOT!PSLINCT!KEYCT!INTCT S REPLY="1~Saved: "_KEYCT_" Key Image"_$S(KEYCT-1:"s",1:"")_"; "_INTCT_" Interp Image"_$S(INTCT-1:"s",1:"")_"; " 54 I S REPLY=REPLY_PSLINCT_" PS line"_$S(PSLINCT-1:"s",1:"")_" for "_PSTOT_" PS"_$S(PSTOT-1:"s",1:"")_" for "_IMGCT_" Image"_$S(IMGCT-1:"s.",1:".") 55 I S:PSKILCT REPLY=REPLY_" Deleted: "_PSKILCT_" PS record"_$S(PSKILCT-1:"s",1:"")_"." 56 E I PSKILCT S REPLY="1~Deleted: "_PSKILCT_" PS record"_$S(PSKILCT-1:"s",1:"")_"." 57 E S REPLY="0~No Key Image/PS data was stored or deleted." 58 Q 59 ; 60 NOOP(X) Q ; do nothing/ skip erroneous input 61 ; 62 IMGINIT(LINE) ; Init storage space for an image ; inits some vars for the SAVE loop 63 N IEN 64 S IMGIEN="",IMGREF="" 65 S IEN=$P(LINE,U) 66 I IEN,$D(^MAG(2005,IEN,0)),'$D(^(1)) 67 E G IMGINITZ 68 S IMGIEN=IEN 69 S IMGREF=$NA(^MAG(2005,IMGIEN)) ; indirect ref used in psinit & savps 70 S IMGCT=IMGCT+1 71 IMGINITZ Q 72 ; 73 PSINIT(LINE) ; Init storage space for a Presentation State ; inits some vars for SAVE loop 74 ; input = PS_UID ^ UID Type (KEY, INT) ^ "DELETE" 75 ; if peice 3 ="DELETE" then the PS data is deleted 76 N IEN,UID,TYPE,DELETE 77 S UID=$P(LINE,U),X=$P(LINE,U,2),DELETE=($P(LINE,U,3)="DELETE"),TYPE=$S(X="KEY":"K",X="INTERP":"I",1:"") 78 I UID="" G PSINITZ 79 I INTERPFL,(TYPE'="K"),(TYPE'="U") S TYPE="I" ; just in case... 80 S IEN=$O(@IMGREF@(210,"B",UID,"")) 81 L +@IMGREF@(210,0):5 82 E Q 83 I 'IEN D ; Allocate node 84 . S X=$G(@IMGREF@(210,0)) I X="" S X="^2005.05A^^",^(0)=X 85 . S IEN=$P(X,U,3)+1,T=$P(X,U,4)+1,$P(X,U,3)=IEN,$P(X,U,4)=T 86 . S @IMGREF@(210,0)=X,@IMGREF@(210,"B",UID,IEN)="" 87 S PSIEN=IEN 88 I DELETE,PSIEN D ; delete this PS 89 . S PSKILCT=PSKILCT+1 90 . K @IMGREF@(210,PSIEN),@IMGREF@(210,"B",UID,PSIEN) 91 . S T=$O(@IMGREF@(210,9999),-1) 92 . I 'T K @IMGREF@(210) Q ; no more PSs! 93 . N XD S XD=$G(@IMGREF@(210,0)) 94 . S $P(XD,U,3)=T,T=$P(XD,U,4) S:T T=T-1 S $P(XD,U,4)=T 95 . S @IMGREF@(210,0)=XD 96 E D ; init PS node for storage; PSTRAK keeps data for later update to STUDY file 97 . S @IMGREF@(210,PSIEN,0)=UID_U_TYPE_U_DUZ_U_TIMESTMP 98 . I "KI"[TYPE S SEQNUM=SEQNUM+1,T=$G(PSTRAK(IMGIEN,TYPE,0))+1,PSTRAK(IMGIEN,TYPE,0)=T,PSTRAK(IMGIEN,TYPE,T)=UID_U_SEQNUM 99 . K @IMGREF@(210,PSIEN,1) ; init Data & Keys 100 . S @IMGREF@(210,PSIEN,1,0)="^2005.51^0_U_0" 101 L -@IMGREF@(210,0) 102 S SAVOP="SAVPS" ; indirect label reference for use in SAVE loop 103 I DELETE S SAVOP="NOOP" 104 S PSTOT=PSTOT+1-DELETE 105 PSINITZ Q 106 ; 107 SAVPS(LINE) ; Save a line of PS data 108 ; input = line of free-text data 109 N PSCT,PSCTRL 110 L +(@IMGREF@(210,PSIEN)) 111 S PSCTRL=$G(@IMGREF@(210,PSIEN,1,0)) 112 S PSCT=+$P(PSCTRL,U,4)+1 113 S @IMGREF@(210,PSIEN,1,PSCT,0)=LINE 114 S $P(PSCTRL,U,3,4)=PSCT_U_PSCT 115 S @IMGREF@(210,PSIEN,1,0)=PSCTRL 116 L -(@IMGREF@(210,PSIEN)) 117 S PSLINCT=PSLINCT+1 118 Q 119 ; 120 SAVKIMG(IMGIEN,UIDSEQ,TYPE,NEWIMG) ; store a Key image & Interp images w/ PS refs in study node 121 ; 122 N STIEN,KIEN,STUDYREF,UID,SEQNUM 123 I 'IMGIEN G SAVKIMGZ 124 S STIEN=$$STUDYID(IMGIEN,"",0) 125 I 'STIEN G SAVKIMGZ ; should never happen 126 S STUDYREF=$NA(^MAG(2005.001,STIEN)) 127 S UID=$P(UIDSEQ,U),SEQNUM=$P(UIDSEQ,U,2) 128 S KIEN=$O(@STUDYREF@(1,"B",IMGIEN,"")) 129 I 'KIEN D 130 . L +@STUDYREF@(1,0) 131 . S X=$G(@STUDYREF@(1,0)) I X="" S X="^2005.031P^^",^(0)=X 132 . S KIEN=$P(X,U,3)+1,T=$P(X,U,4)+1,$P(X,U,3)=KIEN,$P(X,U,4)=T 133 . S @STUDYREF@(1,0)=X,@STUDYREF@(1,"B",IMGIEN,KIEN)="" 134 . L -@STUDYREF@(1,0) 135 E D 136 . I 'NEWIMG Q 137 . K @STUDYREF@(1,KIEN,1) ; init ps data if updating existing img 138 . S @STUDYREF@(1,KIEN,1,0)="^2005.311^0_U_0" 139 S $P(@STUDYREF@(1,KIEN,0),U)=IMGIEN 140 ; store the PS UID 141 I UID]"" D 142 . N IEN S IEN=$O(@STUDYREF@(1,KIEN,1,"B",UID,"")) 143 . I 'IEN D 144 . . L +@STUDYREF@(1,KIEN,1,0) 145 . . S X=$G(@STUDYREF@(1,KIEN,1,0)) I X="" S X="^2005.311^^",^(0)=X 146 . . S IEN=$P(X,U,3)+1,T=$P(X,U,4)+1,$P(X,U,3)=IEN,$P(X,U,4)=T 147 . . S @STUDYREF@(1,KIEN,1,0)=X,@STUDYREF@(1,KIEN,1,"B",UID,IEN)="" 148 . . L -@STUDYREF@(1,KIEN,1,0) 149 . S @STUDYREF@(1,KIEN,1,IEN,0)=UID_U_TYPE_U_SEQNUM 150 S KEYCT=KEYCT+(TYPE="K"),INTCT=INTCT+(TYPE="I") 151 SAVKIMGZ Q 152 ; 153 STUDYID(IEN,RARPT,READONLY,INITSTDY) ; return Study_IEN for input ImgIEN or RARPT 154 ; initialize Study node if INITSTDY is indicated (optional) 155 ; Either IEN or RARPT must be supplied; if both supplied, only RARPT is used 156 ; if READONLY is false, then create "STUDY" node if undefined 157 ; <*> Note: this routine is hard-coded for RADIOLOGY image data only (Parent file=74) 158 N STIEN,X,T,STDYINIT 159 S STIEN="" ; init return value 160 S IEN=$G(IEN),RARPT=$G(RARPT) 161 S:'$D(READONLY) READONLY=1 162 S INITSTDY=$G(INITSTDY) 163 I IEN,'RARPT S RARPT=$$GETRPT(IEN) 164 I 'RARPT G STUDYIDZ 165 I $D(^MAG(2005.001,"ASTUDY",74,RARPT)) S STIEN=$O(^(RARPT,"")) D 166 . I INITSTDY="INIT_STUDY" K ^MAG(2005.001,STIEN,1) ; init for Key/Interp PS updates (full replacement) 167 E D:'READONLY ; create Study structure 168 . L +^MAG(2005.001,0) 169 . S X=^MAG(2005.001,0),STIEN=$P(X,U,3)+1,T=$P(X,U,4)+1,$P(X,U,3)=STIEN,$P(X,U,4)=T,^(0)=X 170 . L -^MAG(2005.001,0) 171 . S ^MAG(2005.001,STIEN,0)=RARPT_U_74,^MAG(2005.001,"ASTUDY",74,RARPT,STIEN)="",^MAG(2005.001,"B",RARPT,STIEN)="" 172 ; 173 STUDYIDZ Q:$Q STIEN Q 174 ; 175 GETRPT(IEN) ; return rarpt for input imgien 176 N IENGRP,X,RARPT 177 S RARPT="" 178 I IEN D 179 . I $D(^MAG(2005,IEN,1)) S IENGRP=IEN 180 . E S IENGRP=$P(^MAG(2005,IEN,0),U,10) 181 . I IENGRP S X=$G(^MAG(2005,IENGRP,2)) I $P(X,U,6)=74 S RARPT=$P(X,U,7) 182 . I RARPT,$D(^RARPT(RARPT,2005)) 183 . E S RARPT="" ; no Rad report node! 184 Q:$Q RARPT Q 185 ; 186 ;Structure of PS/PSTRAK data In: 187 ; *IMAGE 188 ; IEN^ 189 ; *PS 190 ; UID^[KEY/INTERP/USER] 191 ; 1: N Lines of PS data follow 192 ; *END_PS 193 ; *PS 194 ; UID^[KEY/INTERP/USER] 195 ; 1: N Lines of PS data follow 196 ; *END_PS 197 ; *END_IMAGE 198 ; *IMAGE 199 ; ... etc. 200 ; *END_IMAGE 201 ; *END 202 END ; 1 MAGJUPD2 ;WIRMFO/JHC VistaRad RPCs-Update PS & KEY Img ; 14 July 2004 10:05 AM 2 ;;3.0;IMAGING;**18**;Mar 07, 2006 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 Q 19 ERR N ERR S ERR=$$EC^%ZOSV S @MAGGRY@(0)="0^4~"_ERR 20 D @^%ZOSF("ERRTN") 21 Q:$Q 1 Q 22 ; 23 SAVKPS(RARPT,INTERPFL,DATA,REPLY) ; Save study data: Key/Interpretation Images & Pres. State 24 ; RARPT--exam pointer 25 ; INTERPFL--1/0; 1=This is associated with a Rad Interpretation; Optional 26 ; DATA--array of input data; see structure at end of routine 27 ; REPLY--return string 28 N PSTRAK,IDATA,IMGCT,PSTOT,PSLINCT,PSKILCT,KEYCT,INTCT,STUDY,LINE,NEWIMG,NEWPS 29 N IMGREF,IMGIEN,PSIEN,SAVOP,STIEN,TYPE,IMG,ICT,NEWIMG,INITSTDY,SEQNUM 30 S INTERPFL=+$G(INTERPFL) 31 S NEWIMG=0,NEWPS=0,IMGIEN="",PSIEN="",SEQNUM=0 32 S (IMGCT,PSTOT,PSLINCT,KEYCT,INTCT,PSKILCT)=0 33 S IMGREF="",SAVOP="NOOP" 34 I '$D(TIMESTMP) N TIMESTMP D NOW^%DTC S TIMESTMP=% 35 ; 1st, process input in DATA 36 S IDATA="" 37 F S IDATA=$O(DATA(IDATA)) Q:IDATA="" S LINE=DATA(IDATA) I LINE]"" D 38 . I LINE="*IMAGE" S NEWIMG=1 Q 39 . I LINE="*PS" S NEWPS=1 Q 40 . I $E(LINE,1,4)="*END" S (NEWIMG,NEWPS)=0 Q 41 . I NEWIMG D IMGINIT(LINE) S NEWIMG=0 Q ; Init storage for this Image 42 . I NEWPS D PSINIT(LINE) S NEWPS=0 Q ; Init storage for a PS 43 . D @(SAVOP_"(LINE)") 44 ; Now update the Study node info 45 S INITSTDY=$S(INTERPFL:"INIT_STUDY",1:"") 46 S STIEN=$$STUDYID("",RARPT,1,INITSTDY) 47 I $D(PSTRAK) S IMG="" D ; Update key imgs in Study node 48 . F S IMG=$O(PSTRAK(IMG)) Q:'IMG S NEWIMG=1,TYPE="" D 49 . . F S TYPE=$O(PSTRAK(IMG,TYPE)) Q:TYPE="" D 50 . . . F ICT=1:1:PSTRAK(IMG,TYPE,0) D SAVKIMG(IMG,PSTRAK(IMG,TYPE,ICT),TYPE,NEWIMG) S NEWIMG=0 51 SAVKPSZ ; 52 I IMGCT!PSTOT!PSLINCT!KEYCT!INTCT S REPLY="1~Saved: "_KEYCT_" Key Image"_$S(KEYCT-1:"s",1:"")_"; "_INTCT_" Interp Image"_$S(INTCT-1:"s",1:"")_"; " 53 I S REPLY=REPLY_PSLINCT_" PS line"_$S(PSLINCT-1:"s",1:"")_" for "_PSTOT_" PS"_$S(PSTOT-1:"s",1:"")_" for "_IMGCT_" Image"_$S(IMGCT-1:"s.",1:".") 54 I S:PSKILCT REPLY=REPLY_" Deleted: "_PSKILCT_" PS record"_$S(PSKILCT-1:"s",1:"")_"." 55 E I PSKILCT S REPLY="1~Deleted: "_PSKILCT_" PS record"_$S(PSKILCT-1:"s",1:"")_"." 56 E S REPLY="0~No Key Image/PS data was stored or deleted." 57 Q 58 ; 59 NOOP(X) Q ; do nothing/ skip erroneous input 60 ; 61 IMGINIT(LINE) ; Init storage space for an image ; inits some vars for the SAVE loop 62 N IEN 63 S IMGIEN="",IMGREF="" 64 S IEN=$P(LINE,U) 65 I IEN,$D(^MAG(2005,IEN,0)),'$D(^(1)) 66 E G IMGINITZ 67 S IMGIEN=IEN 68 S IMGREF=$NA(^MAG(2005,IMGIEN)) ; indirect ref used in psinit & savps 69 S IMGCT=IMGCT+1 70 IMGINITZ Q 71 ; 72 PSINIT(LINE) ; Init storage space for a Presentation State ; inits some vars for SAVE loop 73 ; input = PS_UID ^ UID Type (KEY, INT) ^ "DELETE" 74 ; if peice 3 ="DELETE" then the PS data is deleted 75 N IEN,UID,TYPE,DELETE 76 S UID=$P(LINE,U),X=$P(LINE,U,2),DELETE=($P(LINE,U,3)="DELETE"),TYPE=$S(X="KEY":"K",X="INTERP":"I",1:"") 77 I UID="" G PSINITZ 78 I INTERPFL,(TYPE'="K"),(TYPE'="U") S TYPE="I" ; just in case... 79 S IEN=$O(@IMGREF@(210,"B",UID,"")) 80 L +@IMGREF@(210,0):5 81 E Q 82 I 'IEN D ; Allocate node 83 . S X=$G(@IMGREF@(210,0)) I X="" S X="^2005.05A^^",^(0)=X 84 . S IEN=$P(X,U,3)+1,T=$P(X,U,4)+1,$P(X,U,3)=IEN,$P(X,U,4)=T 85 . S @IMGREF@(210,0)=X,@IMGREF@(210,"B",UID,IEN)="" 86 S PSIEN=IEN 87 I DELETE,PSIEN D ; delete this PS 88 . S PSKILCT=PSKILCT+1 89 . K @IMGREF@(210,PSIEN),@IMGREF@(210,"B",UID,PSIEN) 90 . S T=$O(@IMGREF@(210,9999),-1) 91 . I 'T K @IMGREF@(210) Q ; no more PSs! 92 . N XD S XD=$G(@IMGREF@(210,0)) 93 . S $P(XD,U,3)=T,T=$P(XD,U,4) S:T T=T-1 S $P(XD,U,4)=T 94 . S @IMGREF@(210,0)=XD 95 E D ; init PS node for storage; PSTRAK keeps data for later update to STUDY file 96 . S @IMGREF@(210,PSIEN,0)=UID_U_TYPE_U_DUZ_U_TIMESTMP 97 . I "KI"[TYPE S SEQNUM=SEQNUM+1,T=$G(PSTRAK(IMGIEN,TYPE,0))+1,PSTRAK(IMGIEN,TYPE,0)=T,PSTRAK(IMGIEN,TYPE,T)=UID_U_SEQNUM 98 . K @IMGREF@(210,PSIEN,1) ; init Data & Keys 99 . S @IMGREF@(210,PSIEN,1,0)="^2005.51^0_U_0" 100 L -@IMGREF@(210,0) 101 S SAVOP="SAVPS" ; indirect label reference for use in SAVE loop 102 I DELETE S SAVOP="NOOP" 103 S PSTOT=PSTOT+1-DELETE 104 PSINITZ Q 105 ; 106 SAVPS(LINE) ; Save a line of PS data 107 ; input = line of free-text data 108 N PSCT,PSCTRL 109 L +(@IMGREF@(210,PSIEN)) 110 S PSCTRL=$G(@IMGREF@(210,PSIEN,1,0)) 111 S PSCT=+$P(PSCTRL,U,4)+1 112 S @IMGREF@(210,PSIEN,1,PSCT,0)=LINE 113 S $P(PSCTRL,U,3,4)=PSCT_U_PSCT 114 S @IMGREF@(210,PSIEN,1,0)=PSCTRL 115 L -(@IMGREF@(210,PSIEN)) 116 S PSLINCT=PSLINCT+1 117 Q 118 ; 119 SAVKIMG(IMGIEN,UIDSEQ,TYPE,NEWIMG) ; store a Key image & Interp images w/ PS refs in study node 120 ; 121 N STIEN,KIEN,STUDYREF,UID,SEQNUM 122 I 'IMGIEN G SAVKIMGZ 123 S STIEN=$$STUDYID(IMGIEN,"",0) 124 I 'STIEN G SAVKIMGZ ; should never happen 125 S STUDYREF=$NA(^MAG(2005.001,STIEN)) 126 S UID=$P(UIDSEQ,U),SEQNUM=$P(UIDSEQ,U,2) 127 S KIEN=$O(@STUDYREF@(1,"B",IMGIEN,"")) 128 I 'KIEN D 129 . L +@STUDYREF@(1,0) 130 . S X=$G(@STUDYREF@(1,0)) I X="" S X="^2005.031P^^",^(0)=X 131 . S KIEN=$P(X,U,3)+1,T=$P(X,U,4)+1,$P(X,U,3)=KIEN,$P(X,U,4)=T 132 . S @STUDYREF@(1,0)=X,@STUDYREF@(1,"B",IMGIEN,KIEN)="" 133 . L -@STUDYREF@(1,0) 134 E D 135 . I 'NEWIMG Q 136 . K @STUDYREF@(1,KIEN,1) ; init ps data if updating existing img 137 . S @STUDYREF@(1,KIEN,1,0)="^2005.311^0_U_0" 138 S $P(@STUDYREF@(1,KIEN,0),U)=IMGIEN 139 ; store the PS UID 140 I UID]"" D 141 . N IEN S IEN=$O(@STUDYREF@(1,KIEN,1,"B",UID,"")) 142 . I 'IEN D 143 . . L +@STUDYREF@(1,KIEN,1,0) 144 . . S X=$G(@STUDYREF@(1,KIEN,1,0)) I X="" S X="^2005.311^^",^(0)=X 145 . . S IEN=$P(X,U,3)+1,T=$P(X,U,4)+1,$P(X,U,3)=IEN,$P(X,U,4)=T 146 . . S @STUDYREF@(1,KIEN,1,0)=X,@STUDYREF@(1,KIEN,1,"B",UID,IEN)="" 147 . . L -@STUDYREF@(1,KIEN,1,0) 148 . S @STUDYREF@(1,KIEN,1,IEN,0)=UID_U_TYPE_U_SEQNUM 149 S KEYCT=KEYCT+(TYPE="K"),INTCT=INTCT+(TYPE="I") 150 SAVKIMGZ Q 151 ; 152 STUDYID(IEN,RARPT,READONLY,INITSTDY) ; return Study_IEN for input ImgIEN or RARPT 153 ; initialize Study node if INITSTDY is indicated (optional) 154 ; Either IEN or RARPT must be supplied; if both supplied, only RARPT is used 155 ; if READONLY is false, then create "STUDY" node if undefined 156 ; <*> Note: this routine is hard-coded for RADIOLOGY image data only (Parent file=74) 157 N STIEN,X,T,STDYINIT 158 S STIEN="" ; init return value 159 S IEN=$G(IEN),RARPT=$G(RARPT) 160 S:'$D(READONLY) READONLY=1 161 S INITSTDY=$G(INITSTDY) 162 I IEN,'RARPT S RARPT=$$GETRPT(IEN) 163 I 'RARPT G STUDYIDZ 164 I $D(^MAG(2005.001,"ASTUDY",74,RARPT)) S STIEN=$O(^(RARPT,"")) D 165 . I INITSTDY="INIT_STUDY" K ^MAG(2005.001,STIEN,1) ; init for Key/Interp PS updates (full replacement) 166 E D:'READONLY ; create Study structure 167 . L +^MAG(2005.001,0) 168 . S X=^MAG(2005.001,0),STIEN=$P(X,U,3)+1,T=$P(X,U,4)+1,$P(X,U,3)=STIEN,$P(X,U,4)=T,^(0)=X 169 . L -^MAG(2005.001,0) 170 . S ^MAG(2005.001,STIEN,0)=RARPT_U_74,^MAG(2005.001,"ASTUDY",74,RARPT,STIEN)="",^MAG(2005.001,"B",RARPT,STIEN)="" 171 ; 172 STUDYIDZ Q:$Q STIEN Q 173 ; 174 GETRPT(IEN) ; return rarpt for input imgien 175 N IENGRP,X,RARPT 176 S RARPT="" 177 I IEN D 178 . I $D(^MAG(2005,IEN,1)) S IENGRP=IEN 179 . E S IENGRP=$P(^MAG(2005,IEN,0),U,10) 180 . I IENGRP S X=$G(^MAG(2005,IENGRP,2)) I $P(X,U,6)=74 S RARPT=$P(X,U,7) 181 . I RARPT,$D(^RARPT(RARPT,2005)) 182 . E S RARPT="" ; no Rad report node! 183 Q:$Q RARPT Q 184 ; 185 ;Structure of PS/PSTRAK data In: 186 ; *IMAGE 187 ; IEN^ 188 ; *PS 189 ; UID^[KEY/INTERP/USER] 190 ; 1: N Lines of PS data follow 191 ; *END_PS 192 ; *PS 193 ; UID^[KEY/INTERP/USER] 194 ; 1: N Lines of PS data follow 195 ; *END_PS 196 ; *END_IMAGE 197 ; *IMAGE 198 ; ... etc. 199 ; *END_IMAGE 200 ; *END 201 END ; -
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 ; -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGJUTL2.m
r613 r623 1 MAGJUTL2 ;WIRMFO/JHC VistRad subroutines for RPC calls[ 2/21/97 10:53 AM ] ; 22 Mar 2001 2:24 PM 2 ;;3.0;IMAGING;**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 IMGINFO(RARPT,RET) ; Fetch info from Image File for input RARPT: 21 ; Input: RARPT: Rad Report pointer 22 ; RET: see below 23 ; RET contents delimited by ^: 24 ; CT = # of images for case 25 ; ONL = Image Storage status (Y=On Magnetic disk, N=Jukebox 26 ; "n/a" for not available, e.g., film only) 27 ; note -- if last image in group is Online, considers ALL online 28 ; MAGDT = Date/Time of Image Capture 29 ; REMOTE = 1/0 to Indicate images were remotely cached 30 ; MODALITY= Modality abbrev 31 ; PLACE = Image storage PLace (ptr to 2006.1 entry) 32 ; KEY = 1/0 ind. Key Images exist for this exam 33 ; 34 N IRPT,MAGIEN,MAGIEN2,ONLCHK,NETLOC,STIEN 35 N CT,ONL,MAGDT,REMOTE,MODALITY,PLACE,REMCHK,KEY 36 S CT="",ONL="",MAGDT="",RET="",REMOTE="",MODALITY="",PLACE="",KEY=0 ; init return vars 37 G IMGINFQ:'RARPT G IMGINFQ:'$D(^RARPT(RARPT,2005,0)) 38 I 'MAGJOB("P32") D 39 . S STIEN=$$STUDYID^MAGJUPD2("",RARPT,1) 40 . I STIEN S T=$O(^MAG(2005,STIEN,205,0)) I T S KEY=1 41 S IRPT=0 F S IRPT=$O(^RARPT(RARPT,2005,IRPT)) Q:'IRPT S MAGIEN=$P(^(IRPT,0),U) D 42 . Q:'$D(^MAG(2005,MAGIEN,0)) 43 . I MAGDT="" S MAGDT=$P($G(^MAG(2005,MAGIEN,100)),U,6) S:MAGDT="" MAGDT=$P($G(^(2)),U) 44 . I $O(^MAG(2005,MAGIEN,1,0)) S CT=CT+$P(^(0),U,4),Y=$P(^(0),U,3),MAGIEN2=$P($G(^(Y,0)),U) S:(MAGIEN2]"") ONLCHK=$$ONLCHK(MAGIEN2),REMCHK=$$REMOTE(MAGIEN2) ; last image in group 45 . E S CT=CT+1,ONLCHK=$$ONLCHK(MAGIEN),REMCHK=$$REMOTE(MAGIEN) 46 . S ONL=$S(ONL="":+ONLCHK,+ONL:+ONLCHK,1:0) ; NOT Online if ANY img is 0 47 . S REMOTE=$S(REMOTE="":REMCHK,+REMOTE:REMCHK,1:0) ; NOT Remote if ANY img is 0 48 . S X=$P(ONLCHK,U,3) 49 . I MODALITY="" S MODALITY=X 50 . E I MODALITY'[X S MODALITY=MODALITY_","_X 51 . I PLACE="" S PLACE=$P(ONLCHK,U,4) 52 IMGINFQ S ONL=$S(+ONL:"Y",ONL="":"n/a",1:"N") 53 S RET=CT_U_ONL_U_MAGDT_U_REMOTE_U_MODALITY_U_PLACE_U_KEY 54 Q 55 ; 56 ONLCHK(MAGIEN,USETGA) ; 57 ; Input: MAGIEN: Image pointer 58 ; USETGA: 1/0 -- if 1, forces return of TGA (not .big) file 59 ;Return: 60 ; - T/F for Full-Res image on Mag. Disk that is Online 61 ; - File type (BIG/FULL) 62 ; - Modality 63 ; - Place 64 ; - DFN 65 ; - File Name IFF this image is stored Off-Line (else null) 66 ; - USETGA as calculated in the logic below 67 ; - PROCDT = Img Processing DtTime 68 ; - ACQSITE = Acquisition site code 69 ; USETGA is set to False (0) if a low-resolution image (TGA) is 70 ; requested, but none exists; calling routine would call by ref. 71 ; 72 N BIG,X,NOD,MAG0,MODALITY,RET,PLACE,DFN,FILNAM,MAG2,PROCDT,ACQSITE,MAG100 73 S USETGA=+$G(USETGA) ; Defaults to Full-Resolution image if not defined 74 S RET="",MODALITY="",PLACE="",ACQSITE="" 75 S MAG0=^MAG(2005,MAGIEN,0),BIG=$D(^("FBIG")),NOD=$S(BIG:^("FBIG"),1:MAG0) 76 S MAG2=^MAG(2005,MAGIEN,2),PROCDT=$P(MAG2,U) 77 S MAG100=$G(^MAG(2005,MAGIEN,100)),ACQSITE=$P(MAG100,U,3) 78 I USETGA D 79 . I 'BIG S USETGA=0 ; reply no low-res image available 80 . I BIG S NOD=MAG0,BIG=0 ; enable correct logic inside this subroutine 81 S MODALITY=$P(MAG0,U,8),DFN=$P(MAG0,U,7) 82 I BIG S X=+$P(NOD,U) ; $p 1 is Magnetic Disk/Volume (.big) <*> DCM--add to end: S:'X X=+$P(NOD,U,3) 83 E S X=+$P(NOD,U,3) ; $p 3 is Magnetic Disk/Volume (.tga) 84 I X D 85 . I '$D(NETLOC(X)) S NETLOC(X)=+$P(^MAG(2005.2,X,0),U,6)_U_$P(^(0),U,10) 86 . S RET=+NETLOC(X),PLACE=$P(NETLOC(X),U,2) ; NETLOC is global to this subrtn 87 . S FILNAM="" 88 E D 89 . S RET=0,FILNAM=$P(MAG0,U,2) 90 . S T=$S(BIG:$P(NOD,U,2),1:$P(NOD,U,5)) 91 . I T S PLACE=$P(^MAG(2005.2,T,0),U,10) ; <*>DCM--add anything? 92 S RET=RET_U_$S(BIG:"BIG",1:"FULL")_U_MODALITY_U_PLACE_U_DFN_U_FILNAM_U_USETGA_U_PROCDT_U_ACQSITE 93 Q RET 94 ; 95 REMOTE(MAGIEN) ;Return list of remote Cache Locations 96 ; else, return "" if none 97 N RET,LOC 98 S RET="" 99 I $D(^MAG(2005,MAGIEN,4,"LOC")) S LOC=0 D 100 . F S LOC=$O(^MAG(2005,MAGIEN,4,"LOC",LOC)) Q:'LOC S RET=RET_$S(RET="":"",1:",")_LOC 101 Q RET 102 ; 103 IMGINF2(RARPT,RET,USETGA) ; Fetch info from Image File for input RARPT: 104 ; Input: RARPT: Rad Report pointer 105 ; RET: see below 106 ; USETGA: 1/0 -- if 1, forces return of TGA (not .big) file 107 ; RET holds array of return values: 108 ; RET = # Images stored for the case 109 ; RET(1:n) = 1/0 ^ FULL/BIG ^ Mod ^ ien ^ Series ^ Routed-to Locations ^ PLACE ^ DFN ^ FileName (if OffLine) ^ PS_Indicator 110 ; (1=Image is on Magnetic Disk) 111 ; * This subroutine may be called by other VistARad routines 112 ; 113 N BIG,IMG,MAGIEN,MAGIEN2,MAGPTR,MAGINDX,MAGREF,NETLOC,SERIES,SERCT,SERPREV 114 K RET S RET=0,SERCT=0,SERPREV="" 115 S USETGA=+$G(USETGA) ; Defaults to Full-Resolution image if not defined 116 G IMGINF2Q:'RARPT S IMG=0 117 S MAGINDX="ADCM" ; maybe others will exist in the future 118 ; *P18--this index is defunct for P18 & beyond 119 ; however, keep for bkwds-compat P18 to P32; remove later 120 F S IMG=$O(^RARPT(RARPT,2005,IMG)) Q:'IMG S MAGIEN=$P(^(IMG,0),U) D 121 . S MAGREF=$NA(^MAG(2005,MAGIEN,1,MAGINDX)) 122 . I 'MAGJOB("P32")!'$D(@MAGREF) D ; use group multiple structure 123 .. Q:'$D(^MAG(2005,MAGIEN,0)) S MAGPTR=0 124 .. I '$O(^MAG(2005,MAGIEN,1,MAGPTR)) D Q 125 ... S T=$$ONLCHK(MAGIEN,USETGA) 126 ... S RET=RET+1,RET(RET)=$P(T,U,1,3)_U_MAGIEN_U_U_$$REMOTE(MAGIEN)_U_$P(T,U,4,7)_U_$$PSIND(MAGIEN)_U_$P(T,U,8)_U_$P(T,U,9) 127 .. E F S MAGPTR=$O(^MAG(2005,MAGIEN,1,MAGPTR)) Q:'MAGPTR S MAGIEN2=$P(^(MAGPTR,0),U) D 128 ... S T=$$ONLCHK(MAGIEN2,USETGA) 129 ... S RET=RET+1,RET(RET)=$P(T,U,1,3)_U_MAGIEN2_U_U_$$REMOTE(MAGIEN2)_U_$P(T,U,4,7)_U_$$PSIND(MAGIEN2)_U_$P(T,U,8)_U_$P(T,U,9) 130 . E I $D(@MAGREF) D ; use exam index, e.g., "ADCM" 131 .. F S MAGREF=$Q(@MAGREF) Q:($P(MAGREF,",",4)'=(""""_MAGINDX_"""")) D 132 ... S X=$L(MAGREF,","),MAGIEN2=$P(MAGREF,",",X-1),SERIES=$P(MAGREF,",",5) 133 ... S T=$$ONLCHK(MAGIEN2,USETGA) 134 ... S RET=RET+1,RET(RET)=$P(T,U,1,3)_U_MAGIEN2_U_SERIES_U_$$REMOTE(MAGIEN2)_U_$P(T,U,4,7) 135 ... I SERIES'=SERPREV S SERCT=SERCT+1,$P(RET("SER",SERCT),U,2)=SERIES,SERPREV=SERIES,RET("SER",0)=SERCT 136 ... S $P(RET("SER",SERCT),U)=RET("SER",SERCT)+1 137 IMGINF2Q ; 138 Q 139 ; 140 PSIND(MAGIEN) ; return Presentation State Indicator(s) for image 141 ; K=Key Image PStype; I=Interpretation PStyp; U=User PStyp 142 N RSL,IEN,X 143 S RSL="",IEN=0 144 I $D(^MAG(2005,MAGIEN,210,IEN)) F S IEN=$O(^MAG(2005,MAGIEN,210,IEN)) Q:'IEN S X=$P(^(IEN,0),U,2) Q:RSL[X S RSL=RSL_$S(RSL="":"",1:",")_X 145 Q:$Q RSL Q 146 ; 147 JBFETCH(RARPT,MAGS,USETGA) ; fetch this case's images from Jukebox, if necessary 148 ; Input: RARPT: Rad Report pointer 149 ; MAGS: see below 150 ; USETGA: 1/0 -- if 1, forces return of TGA (not .big) file 151 ; This is a function that returns a string containing: 152 ; # Images fetched from JB ^ Total # Images for Case ^ # Low Res Imgs 153 ; The MAGS array will be returned to the calling 154 ; routine if MAGS is provided as an input parameter 155 ; MAGS is populated by call to IMGINF2. 156 ; IF any images are stored OffLine, then this node is set here: 157 ; MAGS("OFFLN",JBOFFLN)="" JBOFFLN = Platter ID from file 2006.033 158 ; 159 ; * This function may be called by other VistARad routines 160 ; 161 N MAGIEN,FETCH,IMAG,FILNAM,JBOFFLN,LORESCT 162 S USETGA=+$G(USETGA) ; Defaults to Full-Resolution image if not defined 163 S FETCH=0,LORESCT=0 164 D IMGINF2(RARPT,.MAGS,USETGA) 165 I MAGS F IMAG=1:1:MAGS S X=MAGS(IMAG) D 166 . I USETGA S LORESCT=LORESCT+$P(X,U,10) 167 . I '+X D ; Call params below depend on Consolidated Site status 168 .. S FILNAM=$P(X,U,9) 169 .. I FILNAM]"",$D(^MAGQUEUE(2006.033,"B",FILNAM)) S T=$O(^(FILNAM,"")) S JBOFFLN=$P($G(^MAGQUEUE(2006.033,T,0)),U,2) S FETCH=FETCH+1,MAGS("OFFLN",JBOFFLN)="" Q ; OffLine Image 170 .. I '$G(MAGJOB("CONSOLIDATED")) S X=$$JBTOHD^MAGBAPI($P(X,U,4)_"^"_$P(X,U,2)),FETCH=FETCH+1 ; pre-consolidation vs 171 .. E S X=$$JBTOHD^MAGBAPI($P(X,U,4)_"^"_$P(X,U,2),$P(X,U,7)),FETCH=FETCH+1 172 Q FETCH_U_MAGS_U_LORESCT 173 ; 174 END Q ; 1 MAGJUTL2 ;WIRMFO/JHC VistRad subroutines for RPC calls[ 2/21/97 10:53 AM ] ; 22 Mar 2001 2:24 PM 2 ;;3.0;IMAGING;**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 IMGINFO(RARPT,RET) ; Fetch info from Image File for input RARPT: 21 ; Input: RARPT: Rad Report pointer 22 ; RET: see below 23 ; RET contents delimited by ^: 24 ; CT = # of images for case 25 ; ONL = Image Storage status (Y=On Magnetic disk, N=Jukebox 26 ; "n/a" for not available, e.g., film only) 27 ; note -- if last image in group is Online, considers ALL online 28 ; MAGDT = Date/Time of Image Capture 29 ; REMOTE = 1/0 to Indicate images were remotely cached 30 ; MODALITY= Modality abbrev 31 ; PLACE = Image storage PLace (ptr to 2006.1 entry) 32 ; KEY = 1/0 ind. Key Images exist for this exam 33 ; 34 N IRPT,MAGIEN,MAGIEN2,ONLCHK,NETLOC,STIEN 35 N CT,ONL,MAGDT,REMOTE,MODALITY,PLACE,REMCHK,KEY 36 S CT="",ONL="",MAGDT="",RET="",REMOTE="",MODALITY="",PLACE="",KEY=0 ; init return vars 37 G IMGINFQ:'RARPT G IMGINFQ:'$D(^RARPT(RARPT,2005,0)) 38 I 'MAGJOB("P32") D 39 . S STIEN=$$STUDYID^MAGJUPD2("",RARPT,1) 40 . I STIEN S T=$O(^MAG(2005,STIEN,205,0)) I T S KEY=1 41 S IRPT=0 F S IRPT=$O(^RARPT(RARPT,2005,IRPT)) Q:'IRPT S MAGIEN=$P(^(IRPT,0),U) D 42 . Q:'$D(^MAG(2005,MAGIEN,0)) I MAGDT="" S MAGDT=$P($G(^(2)),U) 43 . I $O(^MAG(2005,MAGIEN,1,0)) S CT=CT+$P(^(0),U,4),Y=$P(^(0),U,3),MAGIEN2=$P($G(^(Y,0)),U) S:(MAGIEN2]"") ONLCHK=$$ONLCHK(MAGIEN2),REMCHK=$$REMOTE(MAGIEN2) ; last image in group 44 . E S CT=CT+1,ONLCHK=$$ONLCHK(MAGIEN),REMCHK=$$REMOTE(MAGIEN) 45 . S ONL=$S(ONL="":+ONLCHK,+ONL:+ONLCHK,1:0) ; NOT Online if ANY img is 0 46 . S REMOTE=$S(REMOTE="":REMCHK,+REMOTE:REMCHK,1:0) ; NOT Remote if ANY img is 0 47 . S X=$P(ONLCHK,U,3) 48 . I MODALITY="" S MODALITY=X 49 . E I MODALITY'[X S MODALITY=MODALITY_","_X 50 . I PLACE="" S PLACE=$P(ONLCHK,U,4) 51 IMGINFQ S ONL=$S(+ONL:"Y",ONL="":"n/a",1:"N") 52 S RET=CT_U_ONL_U_MAGDT_U_REMOTE_U_MODALITY_U_PLACE_U_KEY 53 Q 54 ; 55 ONLCHK(MAGIEN,USETGA) ; 56 ; Input: MAGIEN: Image pointer 57 ; USETGA: 1/0 -- if 1, forces return of TGA (not .big) file 58 ;Return: 59 ; - T/F for Full-Res image on Mag. Disk that is Online 60 ; - File type (BIG/FULL) 61 ; - Modality 62 ; - Place 63 ; - DFN 64 ; - File Name IFF this image is stored Off-Line (else null) 65 ; - USETGA as calculated in the logic below 66 ; - PROCDT = Img Processing DtTime 67 ; - ACQSITE = Acquisition site code 68 ; USETGA is set to False (0) if a low-resolution image (TGA) is 69 ; requested, but none exists; calling routine would call by ref. 70 ; 71 N BIG,X,NOD,MAG0,MODALITY,RET,PLACE,DFN,FILNAM,MAG2,PROCDT,ACQSITE,MAG100 72 S USETGA=+$G(USETGA) ; Defaults to Full-Resolution image if not defined 73 S RET="",MODALITY="",PLACE="",ACQSITE="" 74 S MAG0=^MAG(2005,MAGIEN,0),BIG=$D(^("FBIG")),NOD=$S(BIG:^("FBIG"),1:MAG0) 75 S MAG2=^MAG(2005,MAGIEN,2),PROCDT=$P(MAG2,U) 76 S MAG100=$G(^MAG(2005,MAGIEN,100)),ACQSITE=$P(MAG100,U,3) 77 I USETGA D 78 . I 'BIG S USETGA=0 ; reply no low-res image available 79 . I BIG S NOD=MAG0,BIG=0 ; enable correct logic inside this subroutine 80 S MODALITY=$P(MAG0,U,8),DFN=$P(MAG0,U,7) 81 I BIG S X=+$P(NOD,U) ; $p 1 is Magnetic Disk/Volume (.big) <*> DCM--add to end: S:'X X=+$P(NOD,U,3) 82 E S X=+$P(NOD,U,3) ; $p 3 is Magnetic Disk/Volume (.tga) 83 I X D 84 . I '$D(NETLOC(X)) S NETLOC(X)=+$P(^MAG(2005.2,X,0),U,6)_U_$P(^(0),U,10) 85 . S RET=+NETLOC(X),PLACE=$P(NETLOC(X),U,2) ; NETLOC is global to this subrtn 86 . S FILNAM="" 87 E D 88 . S RET=0,FILNAM=$P(MAG0,U,2) 89 . S T=$S(BIG:$P(NOD,U,2),1:$P(NOD,U,5)) 90 . I T S PLACE=$P(^MAG(2005.2,T,0),U,10) ; <*>DCM--add anything? 91 S RET=RET_U_$S(BIG:"BIG",1:"FULL")_U_MODALITY_U_PLACE_U_DFN_U_FILNAM_U_USETGA_U_PROCDT_U_ACQSITE 92 Q RET 93 ; 94 REMOTE(MAGIEN) ;Return list of remote Cache Locations 95 ; else, return "" if none 96 N RET,LOC 97 S RET="" 98 I $D(^MAG(2005,MAGIEN,4,"LOC")) S LOC=0 D 99 . F S LOC=$O(^MAG(2005,MAGIEN,4,"LOC",LOC)) Q:'LOC S RET=RET_$S(RET="":"",1:",")_LOC 100 Q RET 101 ; 102 IMGINF2(RARPT,RET,USETGA) ; Fetch info from Image File for input RARPT: 103 ; Input: RARPT: Rad Report pointer 104 ; RET: see below 105 ; USETGA: 1/0 -- if 1, forces return of TGA (not .big) file 106 ; RET holds array of return values: 107 ; RET = # Images stored for the case 108 ; RET(1:n) = 1/0 ^ FULL/BIG ^ Mod ^ ien ^ Series ^ Routed-to Locations ^ PLACE ^ DFN ^ FileName (if OffLine) ^ PS_Indicator 109 ; (1=Image is on Magnetic Disk) 110 ; * This subroutine may be called by other VistARad routines 111 ; 112 N BIG,IMG,MAGIEN,MAGIEN2,MAGPTR,MAGINDX,MAGREF,NETLOC,SERIES,SERCT,SERPREV 113 K RET S RET=0,SERCT=0,SERPREV="" 114 S USETGA=+$G(USETGA) ; Defaults to Full-Resolution image if not defined 115 G IMGINF2Q:'RARPT S IMG=0 116 S MAGINDX="ADCM" ; maybe others will exist in the future 117 ; *P18--this index is defunct for P18 & beyond 118 ; however, keep for bkwds-compat P18 to P32; remove later 119 F S IMG=$O(^RARPT(RARPT,2005,IMG)) Q:'IMG S MAGIEN=$P(^(IMG,0),U) D 120 . S MAGREF=$NA(^MAG(2005,MAGIEN,1,MAGINDX)) 121 . I 'MAGJOB("P32")!'$D(@MAGREF) D ; use group multiple structure 122 .. Q:'$D(^MAG(2005,MAGIEN,0)) S MAGPTR=0 123 .. I '$O(^MAG(2005,MAGIEN,1,MAGPTR)) D Q 124 ... S T=$$ONLCHK(MAGIEN,USETGA) 125 ... S RET=RET+1,RET(RET)=$P(T,U,1,3)_U_MAGIEN_U_U_$$REMOTE(MAGIEN)_U_$P(T,U,4,7)_U_$$PSIND(MAGIEN)_U_$P(T,U,8)_U_$P(T,U,9) 126 .. E F S MAGPTR=$O(^MAG(2005,MAGIEN,1,MAGPTR)) Q:'MAGPTR S MAGIEN2=$P(^(MAGPTR,0),U) D 127 ... S T=$$ONLCHK(MAGIEN2,USETGA) 128 ... S RET=RET+1,RET(RET)=$P(T,U,1,3)_U_MAGIEN2_U_U_$$REMOTE(MAGIEN2)_U_$P(T,U,4,7)_U_$$PSIND(MAGIEN2)_U_$P(T,U,8)_U_$P(T,U,9) 129 . E I $D(@MAGREF) D ; use exam index, e.g., "ADCM" 130 .. F S MAGREF=$Q(@MAGREF) Q:($P(MAGREF,",",4)'=(""""_MAGINDX_"""")) D 131 ... S X=$L(MAGREF,","),MAGIEN2=$P(MAGREF,",",X-1),SERIES=$P(MAGREF,",",5) 132 ... S T=$$ONLCHK(MAGIEN2,USETGA) 133 ... S RET=RET+1,RET(RET)=$P(T,U,1,3)_U_MAGIEN2_U_SERIES_U_$$REMOTE(MAGIEN2)_U_$P(T,U,4,7) 134 ... I SERIES'=SERPREV S SERCT=SERCT+1,$P(RET("SER",SERCT),U,2)=SERIES,SERPREV=SERIES,RET("SER",0)=SERCT 135 ... S $P(RET("SER",SERCT),U)=RET("SER",SERCT)+1 136 IMGINF2Q ; 137 Q 138 ; 139 PSIND(MAGIEN) ; return Presentation State Indicator(s) for image 140 ; K=Key Image PStype; I=Interpretation PStyp; U=User PStyp 141 N RSL,IEN,X 142 S RSL="",IEN=0 143 I $D(^MAG(2005,MAGIEN,210,IEN)) F S IEN=$O(^MAG(2005,MAGIEN,210,IEN)) Q:'IEN S X=$P(^(IEN,0),U,2) Q:RSL[X S RSL=RSL_$S(RSL="":"",1:",")_X 144 Q:$Q RSL Q 145 ; 146 JBFETCH(RARPT,MAGS,USETGA) ; fetch this case's images from Jukebox, if necessary 147 ; Input: RARPT: Rad Report pointer 148 ; MAGS: see below 149 ; USETGA: 1/0 -- if 1, forces return of TGA (not .big) file 150 ; This is a function that returns a string containing: 151 ; # Images fetched from JB ^ Total # Images for Case ^ # Low Res Imgs 152 ; The MAGS array will be returned to the calling 153 ; routine if MAGS is provided as an input parameter 154 ; MAGS is populated by call to IMGINF2. 155 ; IF any images are stored OffLine, then this node is set here: 156 ; MAGS("OFFLN",JBOFFLN)="" JBOFFLN = Platter ID from file 2006.033 157 ; 158 ; * This function may be called by other VistARad routines 159 ; 160 N MAGIEN,FETCH,IMAG,FILNAM,JBOFFLN,LORESCT 161 S USETGA=+$G(USETGA) ; Defaults to Full-Resolution image if not defined 162 S FETCH=0,LORESCT=0 163 D IMGINF2(RARPT,.MAGS,USETGA) 164 I MAGS F IMAG=1:1:MAGS S X=MAGS(IMAG) D 165 . I USETGA S LORESCT=LORESCT+$P(X,U,10) 166 . I '+X D ; Call params below depend on Consolidated Site status 167 .. S FILNAM=$P(X,U,9) 168 .. I FILNAM]"",$D(^MAGQUEUE(2006.033,"B",FILNAM)) S T=$O(^(FILNAM,"")) S JBOFFLN=$P($G(^MAGQUEUE(2006.033,T,0)),U,2) S FETCH=FETCH+1,MAGS("OFFLN",JBOFFLN)="" Q ; OffLine Image 169 .. I '$G(MAGJOB("CONSOLIDATED")) S X=$$JBTOHD^MAGBAPI($P(X,U,4)_"^"_$P(X,U,2)),FETCH=FETCH+1 ; pre-consolidation vs 170 .. E S X=$$JBTOHD^MAGBAPI($P(X,U,4)_"^"_$P(X,U,2),$P(X,U,7)),FETCH=FETCH+1 171 Q FETCH_U_MAGS_U_LORESCT 172 ; 173 END Q ; -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGJUTL3.m
r613 r623 1 MAGJUTL3 ;WIRMFO/JHC VistARad subrtns & RPCs ; 29 Jul 2003 10:03 AM 2 ;;3.0;IMAGING;**16,9,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 ;RPC Entry points: 21 ; LISTINF--Custom list info 22 ; LOGOFF--update session file 23 ; CACHEQ--init session data 24 ; PINF1--Patient info 25 ; USERINF2--P18 inits for the session 26 ;Subrtn EPs: 27 ; LOG--Upd image access log 28 ; MAGJOBNC--inits for non-client sessions 29 ; USERKEYS--user key info 30 ; USERINF--user info 31 ; 32 LISTINF(MAGGRY) ; RPC: MAGJ CUSTOM LISTS 33 ; get Exam List data 34 ; Return in ^TMP($J,"MAGJLSTINF",0:N) 35 ; 0)= # Entries below (0:n) 36 ; 1:n)= Button Label^List #^Button Hints^List Type 37 ; 38 ; MAGGRY holds $NA ref to ^TMP for return message 39 ; all refs to MAGGRY use SS indirection 40 ; 41 ; GLB has $NA ref to ^MAG(2006.631), Custom Lists 42 ; refs to GLB use SS indirection to get data from this file 43 ; 44 S X="ERR1^MAGJUTL3",@^%ZOSF("TRAP") 45 N D0,GLB,INF,MAGLST,NAM,T 46 S MAGLST="MAGJLSTINF" 47 K MAGGRY S MAGGRY=$NA(^TMP($J,MAGLST)) K @MAGGRY S @MAGGRY@(0)=0 48 S GLB=$NA(^MAG(2006.631)),NAM="" 49 F S NAM=$O(@GLB@("B",NAM)) Q:NAM="" S D0="" D 50 . S D0=$O(@GLB@("B",NAM,D0)) Q:'D0 D 51 . . S X=$G(@GLB@(D0,0)) Q:($P(X,U,2)>9000)!'$P(X,U,6) ; List Active & User-defined 52 . . S INF="" F I=1:1 S T=$P("7^2^1^3",U,I) Q:T="" S Y=$P(X,U,T) Q:Y="" S $P(INF,U,I)=Y 53 . . Q:T'="" ; req'd fields not all there 54 . . S T=@MAGGRY@(0)+1,^(0)=T,^(T)=INF ; add entry to reply 55 Q 56 ; 57 LOG(ACTION,LOGDATA) ; Log exam access 58 N PTCT,TXT,RADFN,MAGIEN,NIMGS,REMOTE 59 S RADFN=$P(LOGDATA,U),MAGIEN=$P(LOGDATA,U,2),NIMGS=$P(LOGDATA,U,3),REMOTE=$P(LOGDATA,U,4) 60 I ACTION="" S ACTION="UNKNOWN" ; Should never happen 61 S PTCT=RADFN'=$G(MAGJOB("LASTPT",ACTION)) 62 I PTCT S MAGJOB("LASTPT",ACTION)=RADFN 63 S TXT=ACTION_U_RADFN_U_MAGIEN_U_U_U_NIMGS 64 S TXT=TXT_U_PTCT_U_$S(+MAGJOB("USER",1):1,1:0)_U_REMOTE 65 ; Session Log 66 D ACTION^MAGGTAU(TXT,1) 67 ; Mag Log 68 I REMOTE S ACTION=ACTION_"/REM" 69 D ENTRY^MAGLOG(ACTION,+DUZ,MAGIEN,"VRAD:"_MAGJOB("VRVERSION"),RADFN,NIMGS) 70 Q 71 ; 72 LOGOFF(MAGGRY,DATA) ; RPC: MAGJ LOGOFF 73 ; update session file: logoff time & session entry closed 74 D LOGOFF^MAGGTAU(.MAGGRY) 75 Q 76 ; 77 CACHEQ(MAGGRY,DATA) ; RPC: MAGJ CACHELOCATION 78 ; some logon inits & get alternate paths for Remote Reading 79 ; input in DATA: 80 ; - WSLOC = WS Loc'n 81 ; - VRADVER = Client Vs -- p32 ONLY 82 ; - OSVER = Client OS Vs -- p32 ONLY 83 ; Return in ^TMP($J,"MAGJCACHE",0:N) (@MAGGRY) 84 ; 0)= # Entries below (0:n) 85 ; 1:n)= PhysName^Subdirectory^HashFlag^Username^Password^AltPath_IEN 86 ; 87 ; MAGGRY holds $NA reference to ^TMP for return message 88 ; refs to MAGGRY use SS indirection 89 ; 90 ; Also builds local array: p32/p18 compatibility: Some of this is moved to userinf2 below 91 ; MAGJOB("LOC",NetworkLocnIEN)=Site Abbrev 92 ; ("REMOTE")=1/0 (T/F for "User is Remote") 93 ; ("REMOTESCREEN")=0/1 (init User-switchable Remote Screening--P18 use only) 94 ; ("WSLOC")=WS Loc'n String 95 ; ("WSLOCTYP")=WS Loc'n Type 96 ; ("WSNAME")=WS ID 97 ; ("VRVERSION")=VRAD Vs 98 ; ("OSVER")=O/S Vs 99 ; ("ALTPATH")=1/0 ^ 1/0 (T/F Alt Paths are defined 100 ; ^ Alt Paths Enabled/Disabled for most recent exam) 101 ; 102 S X="ERR1^MAGJUTL3",@^%ZOSF("TRAP") 103 ; 104 N I,MAGLST,REPLY,TMP,WSLOC,XX,VRADVER,OSVER,DIQUIET,ALTIEN 105 S DIQUIET=1 D DT^DICRW 106 S REPLY=0,MAGLST="MAGJCACHE" 107 K MAGGRY S MAGGRY=$NA(^TMP($J,MAGLST)) K @MAGGRY 108 S WSLOC=$P(DATA,U),VRADVER=$P(DATA,U,2),OSVER=$P(DATA,U,3) 109 I '$D(MAGJOB("OSVER")) D ; ID p32 initialization 110 . S MAGJOB("OSVER")=$S(OSVER]"":OSVER,1:"UNK") 111 . S MAGJOB("VRVERSION")=$S(VRADVER]"":VRADVER,1:"UNK") 112 . D MAGJOB ; p32 init of VRAD 113 ; get alt paths location info 114 S MAGJOB("WSLOC")=WSLOC,MAGJOB("REMOTE")=0 115 S MAGJOB("REMOTESCREEN")=+$P($G(^MAG(2006.69,1,0)),U,10) 116 I WSLOC]"" D 117 . S X=$P($G(^MAG(2006.1,+MAGJOB("SITEP"),0)),U,9) 118 . I X]"",(X'=WSLOC) S MAGJOB("REMOTE")=1 119 . E Q 120 . D LIST^MAGBRTLD(WSLOC,.TMP) 121 . I TMP S REPLY=TMP,MAGJOB("ALTPATH")=$G(MAGJOB("ALTPATH"),"1^1") F I=1:1:TMP D 122 . . S ALTIEN=$P(TMP(I),U,7) 123 . . S XX=$P(TMP(I),U,1,5),X=$P(XX,U,3),$P(XX,U,3)=$S(X="Y":1,1:0) 124 . . S X=$P(XX,U,4),$P(XX,U,4)=$P(XX,U,5),$P(XX,U,5)=X,$P(XX,U,6)=ALTIEN 125 . . S @MAGGRY@(I)=XX,MAGJOB("LOC",ALTIEN)=$P(TMP(I),U,6) 126 I '$D(MAGJOB("ALTPATH")) S MAGJOB("ALTPATH")="0^0" 127 S @MAGGRY@(0)=REPLY 128 CACHEQZ Q 129 ; 130 MAGJOBNC ; EP for Prefetch/Bkgnd calls (NOT a Vrad Client) 131 N NOTCLIEN S NOTCLIEN=1 132 D MAGJOB 133 Q 134 ; 135 MAGJOB ; Init magjob array 136 N T,RIST 137 I $G(MAGJOB("VRVERSION")) S X=MAGJOB("VRVERSION") 138 E S X="" ; non-client processes assume post-P32 logic 139 S MAGJOB("P32")=(X="3.0.41.17") ; P32 Client? 140 I MAGJOB("P32") D P32STOP^MAGJUTL5(.X) S MAGJOB("P32STOP")=X ; STOP support when P76 releases 141 D USERKEYS 142 S MAGJOB("CONSOLIDATED")=($G(^MAG(2006.1,"CONSOLIDATED"))="YES") 143 S MAGJOB("SITEP")=$$IMGSIT^MAGJUTL1(DUZ(2),1) ; Site Param ien 144 S RIST="" F X="S","R" I $D(^VA(200,"ARC",X,DUZ)) S RIST=X Q 145 S RIST=$S(RIST="S":15,RIST="R":12,1:0) ; Staff/Resident/Non rist 146 S MAGJOB("USER",1)=RIST_U_$$USERINF(+DUZ,".01;1") ; RIST_Type^NAME^INI 147 S X=$P($G(IO("CLNM")),"."),MAGJOB("WSNAME")=$S(X]"":X,1:"VistaradWS") 148 K MAGJOB("DIVSCRN") I MAGJOB("CONSOLIDATED") D 149 . ; include logon DIV, other DIVs to screen Unread Lists & Locking 150 . I $G(DUZ(2))]"" S MAGJOB("DIVSCRN",DUZ(2))="" 151 . S DIV="" 152 . I DUZ(2)'=$P(MAGJOB("SITEP"),U,3) D ; Assoc DIV 153 . . S IEN=$O(^MAG(2006.1,+MAGJOB("SITEP"),"INSTS","B",DUZ(2),0)) 154 . . I IEN F S DIV=$O(^MAG(2006.1,+MAGJOB("SITEP"),"INSTS",IEN,201,"B",DIV)) Q:'DIV S MAGJOB("DIVSCRN",DIV)="" 155 . E D ; Parent DIV 156 . . F S DIV=$O(^MAG(2006.1,+MAGJOB("SITEP"),201,"B",DIV)) Q:'DIV S MAGJOB("DIVSCRN",DIV)="" 157 S MAGJOB("WSLOCTYP")=$S(+MAGJOB("USER",1):"RAD",1:"Non-Rad") ; USer is Rist/Not 158 I '$D(MAGJOB("WRKSIEN")) D 159 . Q:+$G(NOTCLIEN) ; proceed only if Vrad Client is attached 160 . S X=MAGJOB("WSNAME")_"^^^"_MAGJOB("WSLOCTYP")_U_U_U_U_1_U_MAGJOB("OSVER")_U_MAGJOB("VRVERSION") 161 . D UPD^MAGGTAU(.Y,X) 162 . D REMLOCK^MAGJEX1B ; put here to only run 1x/ login 163 Q 164 ; 165 USERINF(DUZ,FLDS) ; get data from user file 166 I FLDS=""!'DUZ Q "" 167 N I,RSL,T S RSL="" 168 D GETS^DIQ(200,+DUZ,FLDS,"E","T") 169 S T=+DUZ_"," 170 F I=1:1:$L(FLDS,";") S RSL=RSL_$S(RSL="":"",1:U)_T(200,T,$P(FLDS,";",I),"E") 171 Q RSL 172 ; 173 USERKEYS ; Store Security Keys in MagJob 174 N I,X,Y 175 N MAGKS ; keys to send to XUS KEY CHECK 176 N MAGKG ; returned 177 K MAGJOB("KEYS") 178 S X="MAGJ",I=0 179 F S X=$O(^XUSEC(X)) Q:$E(X,1,4)'="MAGJ" D 180 . S I=I+1,MAGKS(I)=X 181 I '$D(MAGKS) Q 182 D OWNSKEY^XUSRB(.MAGKG,.MAGKS) 183 S I=0 F S I=$O(MAGKG(I)) Q:'I I MAGKG(I) S MAGJOB("KEYS",MAGKS(I))="" 184 Q 185 ; 186 PINF1(MAGGRY,MAGDFN) ;RPC Call MAGJ PT INFO -- Get pt info 187 S X="ERR3^MAGJUTL3",@^%ZOSF("TRAP") 188 D INFO^MAGGTPT1(.MAGGRY,MAGDFN_"^1") ; 1=Don't log to session file 189 Q 190 ; 191 USERINF2(MAGGRY,DATA) ; rpc: MAGJ USER2--get user info 192 ; Input= unused ^ Client Vs ^ Client O/S Vs 193 ; Reply= 194 ; 0) = 1/0^code~Msg | DUZ ^ NAME ^ INITIALS ^ REQFLAG 195 ; 1)= Net UserName ^ PSW ^ UserType ^ SYSADMIN 196 ; 1/0=Success/Fail flag for vs chk 197 ; code=4 if fail 198 ; Msg=Disp msg if fail 199 ; REQFLAG = 1/0 (Ena/Disa Requisition for non-rad staff) 200 ; UserType = 3: Staff R'ist; 2: Resident R'ist; 1: Rad Tech; 0: Non-Rad 201 ; SYSADMIN = 1/0 1=user has System User privileges 202 ; 2:N)=Sec Keys 203 ; 204 S X="ERR2^MAGJUTL3",@^%ZOSF("TRAP") 205 K MAGGRY S MAGGRY(0)="",MAGGRY(1)="" 206 I +$G(DUZ)=0 S MAGGRY(0)="0^4~DUZ Undefined, Null or Zero|" Q 207 N I,J,K,Y,REQ,VRADVER,OSVER,RADTECH,PLACE,REPLY 208 S VRADVER=$P(DATA,U,2),OSVER=$P(DATA,U,3) 209 D CHKVER^MAGJUTL5(.REPLY,VRADVER,.PLACE,.SVERSION) 210 I 'REPLY S MAGGRY(0)=REPLY_"|^^^^",MAGGRY(1)="^^^" G USERIN2Z ; Version check or PLACE failed 211 S RADTECH="" 212 S MAGJOB("OSVER")=$S(OSVER]"":OSVER,1:"UNK") ; IDs P18 initialization; cf cacheq ep above 213 S MAGJOB("VRVERSION")=$S(VRADVER]"":VRADVER,1:"UNK") 214 S MAGJOB("VSVERSION")=SVERSION 215 D MAGJOB 216 ; Enable/Disable Requisition if not a radiology user 217 S REQ=1 218 I 'MAGJOB("USER",1) D ; not a rist 219 . I $D(^VA(200,"ARC","T",+DUZ)) S RADTECH=1 Q ; Rad Tech OK 220 . S X=+$P($G(^MAG(2006.69,1,0)),U,16) 221 . I X S REQ=0 ; Disable Req 222 S MAGGRY(0)=REPLY_"|"_DUZ_U_$$GET1^DIQ(200,DUZ_",",.01)_U_$$GET1^DIQ(200,DUZ_",",1)_U_REQ_U_SVERSION 223 ; Network UserName and PSW 224 S MAGGRY(1)=$P($G(^MAG(2006.1,PLACE,"NET")),U,1,2) 225 S X=+MAGJOB("USER",1),X=$S(X=15:3,X=12:2,+RADTECH:1,1:0) 226 S MAGGRY(1)=MAGGRY(1)_U_X_U_$D(MAGJOB("KEYS","MAGJ SYSTEM USER")) 227 S MAGGRY(2)="*KEYS",X="" F I=3:1 S X=$O(MAGJOB("KEYS",X)) Q:X="" S MAGGRY(I)=X 228 S MAGGRY(I)="*END" 229 USERIN2Z Q 230 ; 231 ERR1 N ERR S ERR=$$EC^%ZOSV S @MAGGRY@(0)="0^4~"_ERR G ERR 232 ERR2 N ERR S ERR=$$EC^%ZOSV S MAGGRY(0)="0^4~"_ERR G ERR 233 ERR3 N ERR S ERR=$$EC^%ZOSV S MAGGRY="0^4~"_ERR 234 ERR D @^%ZOSF("ERRTN") 235 Q:$Q 1 Q 236 ; 237 END Q ; 1 MAGJUTL3 ;WIRMFO/JHC VistARad subrtns & RPCs ; 29 Jul 2003 10:03 AM 2 ;;3.0;IMAGING;**16,9,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 ;RPC Entry points: 21 ; LISTINF--Custom list info 22 ; LOGOFF--update session file 23 ; CACHEQ--init session data 24 ; PINF1--Patient info 25 ; USERINF2--P18 inits for the session 26 ;Subrtn EPs: 27 ; LOG--Upd image access log 28 ; MAGJOBNC--inits for non-client sessions 29 ; USERKEYS--user key info 30 ; USERINF--user info 31 ; 32 LISTINF(MAGGRY) ; RPC: MAGJ CUSTOM LISTS 33 ; get Exam List data 34 ; Return in ^TMP($J,"MAGJLSTINF",0:N) 35 ; 0)= # Entries below (0:n) 36 ; 1:n)= Button Label^List #^Button Hints^List Type 37 ; 38 ; MAGGRY holds $NA ref to ^TMP for return message 39 ; all refs to MAGGRY use SS indirection 40 ; 41 ; GLB has $NA ref to ^MAG(2006.631), Custom Lists 42 ; refs to GLB use SS indirection to get data from this file 43 ; 44 S X="ERR1^MAGJUTL3",@^%ZOSF("TRAP") 45 N D0,GLB,INF,MAGLST,NAM,T 46 S MAGLST="MAGJLSTINF" 47 K MAGGRY S MAGGRY=$NA(^TMP($J,MAGLST)) K @MAGGRY S @MAGGRY@(0)=0 48 S GLB=$NA(^MAG(2006.631)),NAM="" 49 F S NAM=$O(@GLB@("B",NAM)) Q:NAM="" S D0="" D 50 . S D0=$O(@GLB@("B",NAM,D0)) Q:'D0 D 51 . . S X=$G(@GLB@(D0,0)) Q:($P(X,U,2)>9000)!'$P(X,U,6) ; List Active & User-defined 52 . . S INF="" F I=1:1 S T=$P("7^2^1^3",U,I) Q:T="" S Y=$P(X,U,T) Q:Y="" S $P(INF,U,I)=Y 53 . . Q:T'="" ; req'd fields not all there 54 . . S T=@MAGGRY@(0)+1,^(0)=T,^(T)=INF ; add entry to reply 55 Q 56 ; 57 LOG(ACTION,LOGDATA) ; Log exam access 58 N PTCT,TXT,RADFN,MAGIEN,NIMGS,REMOTE 59 S RADFN=$P(LOGDATA,U),MAGIEN=$P(LOGDATA,U,2),NIMGS=$P(LOGDATA,U,3),REMOTE=$P(LOGDATA,U,4) 60 I ACTION="" S ACTION="UNKNOWN" ; Should never happen 61 S PTCT=RADFN'=$G(MAGJOB("LASTPT",ACTION)) 62 I PTCT S MAGJOB("LASTPT",ACTION)=RADFN 63 S TXT=ACTION_U_RADFN_U_MAGIEN_U_U_U_NIMGS 64 S TXT=TXT_U_PTCT_U_$S(+MAGJOB("USER",1):1,1:0)_U_REMOTE 65 ; Session Log 66 D ACTION^MAGGTAU(TXT,1) 67 ; Mag Log 68 I REMOTE S ACTION=ACTION_"/REM" 69 D ENTRY^MAGLOG(ACTION,+DUZ,MAGIEN,"VRAD:"_MAGJOB("VRVERSION"),RADFN,NIMGS) 70 Q 71 ; 72 LOGOFF(MAGGRY,DATA) ; RPC: MAGJ LOGOFF 73 ; update session file: logoff time & session entry closed 74 D LOGOFF^MAGGTAU(.MAGGRY) 75 Q 76 ; 77 CACHEQ(MAGGRY,DATA) ; RPC: MAGJ CACHELOCATION 78 ; some logon inits & get alternate paths for Remote Reading 79 ; input in DATA: 80 ; - WSLOC = WS Loc'n 81 ; - VRADVER = Client Vs -- p32 ONLY 82 ; - OSVER = Client OS Vs -- p32 ONLY 83 ; Return in ^TMP($J,"MAGJCACHE",0:N) (@MAGGRY) 84 ; 0)= # Entries below (0:n) 85 ; 1:n)= PhysName^Subdirectory^HashFlag^Username^Password^AltPath_IEN 86 ; 87 ; MAGGRY holds $NA reference to ^TMP for return message 88 ; refs to MAGGRY use SS indirection 89 ; 90 ; Also builds local array: p32/p18 compatibility: Some of this is moved to userinf2 below 91 ; MAGJOB("LOC",NetworkLocnIEN)=Site Abbrev 92 ; ("REMOTE")=1/0 (T/F for "User is Remote") 93 ; ("REMOTESCREEN")=0/1 (init User-switchable Remote Screening--P18 use only) 94 ; ("WSLOC")=WS Loc'n String 95 ; ("WSLOCTYP")=WS Loc'n Type 96 ; ("WSNAME")=WS ID 97 ; ("VRVERSION")=VRAD Vs 98 ; ("OSVER")=O/S Vs 99 ; ("ALTPATH")=1/0 ^ 1/0 (T/F Alt Paths are defined 100 ; ^ Alt Paths Enabled/Disabled for most recent exam) 101 ; 102 S X="ERR1^MAGJUTL3",@^%ZOSF("TRAP") 103 ; 104 N I,MAGLST,REPLY,TMP,WSLOC,XX,VRADVER,OSVER,DIQUIET,ALTIEN 105 S DIQUIET=1 D DT^DICRW 106 S REPLY=0,MAGLST="MAGJCACHE" 107 K MAGGRY S MAGGRY=$NA(^TMP($J,MAGLST)) K @MAGGRY 108 S WSLOC=$P(DATA,U),VRADVER=$P(DATA,U,2),OSVER=$P(DATA,U,3) 109 I '$D(MAGJOB("OSVER")) D ; ID p32 initialization 110 . S MAGJOB("OSVER")=$S(OSVER]"":OSVER,1:"UNK") 111 . S MAGJOB("VRVERSION")=$S(VRADVER]"":VRADVER,1:"UNK") 112 . D MAGJOB ; p32 init of VRAD 113 ; get alt paths location info 114 S MAGJOB("WSLOC")=WSLOC,MAGJOB("REMOTE")=0 115 S MAGJOB("REMOTESCREEN")=+$P($G(^MAG(2006.69,1,0)),U,10) 116 I WSLOC]"" D 117 . S X=$P($G(^MAG(2006.1,+MAGJOB("SITEP"),0)),U,9) 118 . I X]"",(X'=WSLOC) S MAGJOB("REMOTE")=1 119 . E Q 120 . D LIST^MAGBRTLD(WSLOC,.TMP) 121 . I TMP S REPLY=TMP,MAGJOB("ALTPATH")=$G(MAGJOB("ALTPATH"),"1^1") F I=1:1:TMP D 122 . . S ALTIEN=$P(TMP(I),U,7) 123 . . S XX=$P(TMP(I),U,1,5),X=$P(XX,U,3),$P(XX,U,3)=$S(X="Y":1,1:0) 124 . . S X=$P(XX,U,4),$P(XX,U,4)=$P(XX,U,5),$P(XX,U,5)=X,$P(XX,U,6)=ALTIEN 125 . . S @MAGGRY@(I)=XX,MAGJOB("LOC",ALTIEN)=$P(TMP(I),U,6) 126 I '$D(MAGJOB("ALTPATH")) S MAGJOB("ALTPATH")="0^0" 127 S @MAGGRY@(0)=REPLY 128 CACHEQZ Q 129 ; 130 MAGJOBNC ; EP for Prefetch/Bkgnd calls (NOT a Vrad Client) 131 N NOTCLIEN S NOTCLIEN=1 132 D MAGJOB 133 Q 134 ; 135 MAGJOB ; Init magjob array 136 N T,RIST 137 I $G(MAGJOB("VRVERSION")) S X=MAGJOB("VRVERSION") 138 E S X="" ; non-client processes assume post-P32 logic 139 S MAGJOB("P32")=(X="3.0.41.17") ; support back-compatible P32 Client 140 D USERKEYS 141 S MAGJOB("CONSOLIDATED")=($G(^MAG(2006.1,"CONSOLIDATED"))="YES") 142 S MAGJOB("SITEP")=$$IMGSIT^MAGJUTL1(DUZ(2),1) ; Site Param ien 143 S RIST="" F X="S","R" I $D(^VA(200,"ARC",X,DUZ)) S RIST=X Q 144 S RIST=$S(RIST="S":15,RIST="R":12,1:0) ; Staff/Resident/Non rist 145 S MAGJOB("USER",1)=RIST_U_$$USERINF(+DUZ,".01;1") ; RIST_Type^NAME^INI 146 S X=$P($G(IO("CLNM")),"."),MAGJOB("WSNAME")=$S(X]"":X,1:"VistaradWS") 147 K MAGJOB("DIVSCRN") I MAGJOB("CONSOLIDATED") D 148 . ; include logon DIV, other DIVs to screen Unread Lists & Locking 149 . I $G(DUZ(2))]"" S MAGJOB("DIVSCRN",DUZ(2))="" 150 . S DIV="" 151 . I DUZ(2)'=$P(MAGJOB("SITEP"),U,3) D ; Assoc DIV 152 . . S IEN=$O(^MAG(2006.1,+MAGJOB("SITEP"),"INSTS","B",DUZ(2),0)) 153 . . I IEN F S DIV=$O(^MAG(2006.1,+MAGJOB("SITEP"),"INSTS",IEN,201,"B",DIV)) Q:'DIV S MAGJOB("DIVSCRN",DIV)="" 154 . E D ; Parent DIV 155 . . F S DIV=$O(^MAG(2006.1,+MAGJOB("SITEP"),201,"B",DIV)) Q:'DIV S MAGJOB("DIVSCRN",DIV)="" 156 S MAGJOB("WSLOCTYP")=$S(+MAGJOB("USER",1):"RAD",1:"Non-Rad") ; USer is Rist/Not 157 I '$D(MAGJOB("WRKSIEN")) D 158 . Q:+$G(NOTCLIEN) ; proceed only if Vrad Client is attached 159 . S X=MAGJOB("WSNAME")_"^^^"_MAGJOB("WSLOCTYP")_U_U_U_U_1_U_MAGJOB("OSVER")_U_MAGJOB("VRVERSION") 160 . D UPD^MAGGTAU(.Y,X) 161 . D REMLOCK^MAGJEX1B ; put here to only run 1x/ login 162 Q 163 ; 164 USERINF(DUZ,FLDS) ; get data from user file 165 I FLDS=""!'DUZ Q "" 166 N I,RSL,T S RSL="" 167 D GETS^DIQ(200,+DUZ,FLDS,"E","T") 168 S T=+DUZ_"," 169 F I=1:1:$L(FLDS,";") S RSL=RSL_$S(RSL="":"",1:U)_T(200,T,$P(FLDS,";",I),"E") 170 Q RSL 171 ; 172 USERKEYS ; Store VRad Security Keys in MagJob 173 ; 174 N I,X,Y 175 N MAGKS ; list of keys to send to XUS KEY CHECK 176 N MAGKG ; list returned 177 K MAGJOB("KEYS") 178 S X="MAGJ",I=0 179 F S X=$O(^XUSEC(X)) Q:$E(X,1,4)'="MAGJ" D 180 . S I=I+1,MAGKS(I)=X 181 I '$D(MAGKS) Q 182 D OWNSKEY^XUSRB(.MAGKG,.MAGKS) 183 S I=0 F S I=$O(MAGKG(I)) Q:'I I MAGKG(I) S MAGJOB("KEYS",MAGKS(I))="" 184 Q 185 ; 186 Q 187 PINF1(MAGGRY,MAGDFN) ;RPC Call MAGJ PT INFO -- Get pt info 188 S X="ERR3^MAGJUTL3",@^%ZOSF("TRAP") 189 D INFO^MAGGTPT1(.MAGGRY,MAGDFN_"^1") ; 1=Don't log to session file 190 Q 191 ; 192 USERINF2(MAGGRY,DATA) ; rpc: MAGJ USER2 -- Return user info 193 ; Input = unused ^ Client Vrad Vs ^ Client O/S Vs 194 ; Reply = 195 ; (0) = 1/0^code~Msg | DUZ ^ NAME ^ INITIALS ^ REQ_FLAG 196 ; (1)= Net UserName ^ PSW ^ UserType ^ SYSADMIN 197 ; 1/0=Success/Failure flag for vs compatibility 198 ; code=4 if failure condition 199 ; Msg=Display msg if failure condition 200 ; REQ_FLAG = 1/0 (Enable/Disable Requisition for non-rad staff) 201 ; UserType = 3: Staff R'ist; 2: Resident R'ist; 1: Rad Tech; 0: Non-Rad 202 ; SYSADMIN = 1/0 1=user has Vrad System User privileges 203 ; 204 S X="ERR2^MAGJUTL3",@^%ZOSF("TRAP") 205 K MAGGRY S MAGGRY(0)="",MAGGRY(1)="" 206 I +$G(DUZ)=0 S MAGGRY(0)="0^4~DUZ Undefined, Null or Zero|" Q 207 N I,J,K,Y,REQ,VRADVER,OSVER,RADTECH,PLACE,REPLY 208 S VRADVER=$P(DATA,U,2),OSVER=$P(DATA,U,3) 209 D CHKVER^MAGJUTL5(.REPLY,VRADVER,.PLACE,.SVERSION) 210 I 'REPLY S MAGGRY(0)=REPLY_"|^^^^",MAGGRY(1)="^^^" G USERIN2Z ; Version check or PLACE failed 211 S RADTECH="" 212 S MAGJOB("OSVER")=$S(OSVER]"":OSVER,1:"UNK") ; IDs P18 initialization; cf cacheq ep above 213 S MAGJOB("VRVERSION")=$S(VRADVER]"":VRADVER,1:"UNK") 214 S MAGJOB("VSVERSION")=SVERSION 215 D MAGJOB 216 ; Enable/Disable Requisition if not a radiology user 217 S REQ=1 218 I 'MAGJOB("USER",1) D ; not a rist 219 . I $D(^VA(200,"ARC","T",+DUZ)) S RADTECH=1 Q ; Rad Tech OK 220 . S X=+$P($G(^MAG(2006.69,1,0)),U,16) 221 . I X S REQ=0 ; Disable Req 222 S MAGGRY(0)=REPLY_"|"_DUZ_U_$$GET1^DIQ(200,DUZ_",",.01)_U_$$GET1^DIQ(200,DUZ_",",1)_U_REQ_U_SVERSION 223 ; Network UserName and PSW 224 S MAGGRY(1)=$P($G(^MAG(2006.1,PLACE,"NET")),U,1,2) 225 S X=+MAGJOB("USER",1),X=$S(X=15:3,X=12:2,+RADTECH:1,1:0) 226 S MAGGRY(1)=MAGGRY(1)_U_X_U_$D(MAGJOB("KEYS","MAGJ SYSTEM USER")) 227 USERIN2Z Q 228 ; 229 ERR1 N ERR S ERR=$$EC^%ZOSV S @MAGGRY@(0)="0^4~"_ERR G ERR 230 ERR2 N ERR S ERR=$$EC^%ZOSV S MAGGRY(0)="0^4~"_ERR G ERR 231 ERR3 N ERR S ERR=$$EC^%ZOSV S MAGGRY="0^4~"_ERR 232 ERR D @^%ZOSF("ERRTN") 233 Q:$Q 1 Q 234 ; 235 END Q ; -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGJUTL4.m
r613 r623 1 MAGJUTL4 ;WIRMFO/JHC VistARad subroutines for RPC calls ; 15 Jul 2004 4:34 PM 2 ;;3.0;IMAGING;**18,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 ; 21 CPTGRP(MAGGRY,DATA) ; RPC: MAGJ CPTMATCH 22 ; FOR INPUT cpt code, return matching cpt's based on grouping criteria: 23 ; INPUT in DATA: CPT Code ^ Criteria 24 ; Criteria: 25 ; 1=Matching cpt 26 ; 2=Body Part 27 ; 3=Body Part & Modality 28 ; 10=Same CPT (used to return short description only) 29 ; Return: List of CPTs with Short Name: CPT ^ Short Name 30 ; MAGGRY holds $NA reference to ^TMP for rpc return 31 ; all ref's to MAGGRY use subscript indirection 32 ; 33 N $ETRAP,$ESTACK S $ETRAP="G ERR1^MAGJUTL4" 34 N REPLY,DIQUIET,CPT,CRIT,CT,MAGLST,NOD,NODLST 35 N MATCHGRP,INDXLST,AND,RET,CPTGLB,CPTIN,CPTIEN,TCPT 36 ; 37 ; <*> Issue: Unable get specific body part for some non-specific CPTs (e.g., 75774-ANGIO SELECT EA ADD VESSEL-S) 38 ; --> For these, could just return matching CPTs (or equivalent CPT?) 39 ; 40 ; Produce List of cptiens for each INDX of interest 41 ; AND with next list of cptiens; repeat until no more INDXs 42 ; build output list of CPT codes (w/ short names [optional]) 43 S DIQUIET=1 D DT^DICRW 44 S CT=0,MAGLST="MAGJCPT" 45 K MAGGRY S MAGGRY=$NA(^TMP($J,MAGLST)) K @MAGGRY ; assign MAGGRY value 46 S CPTIN=$P(DATA,U),CRIT=$P(DATA,U,2) 47 S REPLY="0^Getting matching CPT info." 48 S:'CRIT CRIT=1 ; default equivalent 49 I CPTIN="" S REPLY="0^Invalid CPT code ("_DATA_")." G CPTGRPZ 50 I '(CRIT=1!(CRIT=2)!(CRIT=3)!(CRIT=10)) S REPLY="0^Invalid criteria ("_DATA_")." G CPTGRPZ 51 S CPTGLB=$NA(^MAG(2006.67)) 52 S CPTIEN=$O(@CPTGLB@("B",CPTIN,"")) 53 I 'CPTIEN S REPLY="0^Input CPT code ("_CPTIN_") not defined in CPT Match table." G CPTGRPZ 54 S X=@CPTGLB@(CPTIEN,0),MATCHGRP=+$P(X,U,4) 55 ;CPTMATCH^BODYPART^MDL 56 I CRIT=2!(CRIT=3) D 57 . S X=0 F S X=$O(@CPTGLB@(CPTIEN,1,"B",X)) Q:'X D GETCPTS("BODYPART",X,"",.RET) 58 . I CRIT=3 D 59 . . M AND=RET K RET S X=0 60 . . F S X=$O(@CPTGLB@(CPTIEN,2,"B",X)) Q:'X D GETCPTS("MDL",X,.AND,.RET) 61 I CRIT=1 D 62 . I MATCHGRP,(MATCHGRP'=CPTIEN) S RET(MATCHGRP)="" D GETCPTS("CPTMATCH",MATCHGRP,"",.RET) 63 . D GETCPTS("CPTMATCH",CPTIEN,"",.RET) 64 I CRIT=10 ; fall through answers this! 65 I '$D(RET(CPTIEN)) S RET(CPTIEN)="" ; always report back input cpt 66 S IEN=0 F S IEN=$O(RET(IEN)) Q:'IEN D 67 . N LIN S X=$G(@CPTGLB@(IEN,0)) 68 . Q:'(X]"") S TCPT=$P(X,U),LIN=TCPT_U_$P($$CPT^ICPTCOD(TCPT),U,3) ; _U_$$BODPART(IEN,"~")_U_$$MDLLST(IEN,"~") 69 . S CT=CT+1,@MAGGRY@(CT)=LIN 70 S REPLY=CT_U_"1~ "_CT_" CPT Matches returned for "_CPTIN 71 CPTGRPZ ; 72 S @MAGGRY@(0)=REPLY 73 Q 74 ; 75 GETCPTS(INDEX,VALUE,AND,OUT) ; return a list of CPTIENS in OUT 76 ; if array AND is defined, reply only values contained in AND & the index 77 N X,GLBREF,CPTIEN 78 S GLBREF=$NA(@CPTGLB@(INDEX,VALUE)) 79 S CPTIEN=0 80 I $D(AND)>9 D 81 . F S CPTIEN=$O(AND(CPTIEN)) Q:CPTIEN="" I $D(@GLBREF@(CPTIEN)) S OUT(CPTIEN)="" 82 E F S CPTIEN=$O(@GLBREF@(CPTIEN)) Q:'CPTIEN D 83 . S OUT(CPTIEN)="" 84 Q 85 ; 86 BODPART(CPTIEN,DLM) ; return DLM-delimited list of body part values for this CPT 87 I +$G(CPTIEN) 88 E Q "" 89 N LIST,CPTGLB S LIST="" 90 S DLM=$E($G(DLM)) 91 I DLM="" S DLM="^" 92 S CPTGLB=$NA(^MAG(2006.67)) 93 S NOD=0 94 F S NOD=$O(@CPTGLB@(CPTIEN,1,NOD)) Q:'NOD S X=$P(^(NOD,0),U) I X]"" S LIST=LIST_DLM_X 95 Q:$Q $E(LIST,2,999) Q 96 ; 97 MDLLST(CPTIEN,DLM) ; return DLM-delimited list of modality values for this CPT 98 I +$G(CPTIEN) 99 E Q "" 100 N LIST,CPTGLB S LIST="" 101 S DLM=$E($G(DLM)) 102 I DLM="" S DLM="^" 103 S CPTGLB=$NA(^MAG(2006.67)) 104 S NOD=0 105 F S NOD=$O(@CPTGLB@(CPTIEN,2,NOD)) Q:'NOD S X=$P(^(NOD,0),U) I X]"" S LIST=LIST_DLM_X 106 Q:$Q $E(LIST,2,999) Q 107 ; 108 STATCHK(MAGGRY,DATA) ; 109 ; RPC: MAGJ RADSTATUSCHECK 110 ; This may also be accessed by subroutine call. <*> do not change name of EP 111 ; Exam Status check RPC and subroutine: determine if the exam has been Tech-Verified (at least). 112 ; Images are assumed to be verified if Exam Status is Examined, or higher status. 113 ; ; Input in DATA: RADFN^RADTI^RACNI^RARPT 114 ; Input is either RADFN, RADTI, and RACNI; or, RARPT only may be input in piece 4 115 ; Return: Code^Text 116 ; 0 = Problem, or exam was cancelled 117 ; 1 = Not yet verified 118 ; 2 = Tech Verified 119 ; 3 = Radiologist Verified 120 ; 4 = User is a Radiology professional--always allow access 121 ; 122 N $ETRAP,$ESTACK S $ETRAP="G ERR3^MAGJUTL4" 123 N REPLY,STATUS,ORDER,VCAT,STOUT 124 N DIQUIET,RARPT,RADFN,RADTI,RACNI 125 S DIQUIET=1 D DT^DICRW 126 S RADFN=$P(DATA,U),RADTI=$P(DATA,U,2),RACNI=$P(DATA,U,3),RARPT=$P(DATA,U,4) 127 S STOUT="",REPLY="0^Getting image verification status." 128 I RADFN,RADTI,RACNI 129 E I RARPT D RPT2DPT(RARPT,.X) I X S RADFN=+X,RADTI=$P(X,U,2),RACNI=$P(X,U,3) I RADFN,RADTI,RACNI 130 E S REPLY="0^Image Verification Status request contains invalid case pointer ("_DATA_")" G STATCHKZ 131 S STATUS=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,3) 132 I STATUS="" S REPLY="0^Image Verification Status request error--no Exam Status is defined for ("_DATA_")" G STATCHKZ 133 S VCAT=$P(^RA(72,STATUS,0),U,9),ORDER=$P(^(0),U,3) 134 I VCAT]"" D G STATCHK2:STOUT 135 . I "EDT"[VCAT S STOUT=$S(VCAT="E":2,1:3) ; Examined or Interpreted 136 . E I VCAT="W" S STOUT=1 ; Not yet Verified 137 I ORDER=9 S STOUT=3 ; Completed exam 138 E I ORDER=0 S REPLY="0^Exam Cancelled" 139 E I ORDER=1 S STOUT=1 ; Waiting for exam 140 STATCHK2 ; 141 I STOUT<2 D 142 . F X="S","R","T" I $D(^VA(200,"ARC",X,DUZ)) S STOUT=4 Q ; Radiologist or Tech -- OK to access 143 STATCHKZ ; 144 I STOUT S REPLY=STOUT_U_$S(STOUT=1:"Images not yet verified",STOUT=2:"Images verified by Technologist",STOUT=3:"Images interpreted by Radiologist",STOUT=4:"Radiology professional--OK to view images.",1:"") 145 S MAGGRY=REPLY 146 Q 147 ; 148 REMSCRN(MAGGRY,DATA) ; User set/clear flag to show/not show remote exams only 149 ; RPC: MAGJ REMOTESCREEN 150 ; ; Input in DATA: 1/0 1=show remote only; 0=show all exams 151 ; Return: Reply^Code~msg 152 ; Reply -- 0=Problem; 1=Success 153 ; Code -- 4=Error; 1=ok 154 ; msg -- display text if error 155 ; 156 N $ETRAP,$ESTACK S $ETRAP="G ERR3^MAGJUTL4" 157 N REPLY 158 N DIQUIET S DIQUIET=1 D DT^DICRW 159 I $D(DATA),(DATA=0!(DATA=1)) 160 E S REPLY="0^4~REMOTESCREEN request has invalid parameter ("_$G(DATA)_")" G REMSCRNZ 161 S MAGJOB("REMOTESCREEN")=DATA,REPLY="1^1~"_DATA 162 REMSCRNZ ; 163 S MAGGRY=REPLY 164 Q 165 ; 166 RPT2DPT(RARPT,RET) ; Input RARPT. Return RET containing exam ss values for ^RADPT 167 ; 168 N DFN,DTI,CNI S (DFN,DTI,CNI)="" 169 I RARPT?1N.N,$D(^RARPT(RARPT)) S X=$G(^(RARPT,0)) I X]"" D 170 . S X=$P(X,U) 171 . S X=$O(^RADPT("ADC",X,0)) I X S DFN=X,DTI=$O(^(X,0)),CNI=$O(^(DTI,0)) 172 . S RET=DFN_U_DTI_U_CNI 173 E S RET="" 174 Q 175 ; 176 ERR1 N ERR S ERR=$$EC^%ZOSV S @MAGGRY@(0)="0^4~"_ERR G ERR 177 ERR3 N ERR S ERR=$$EC^%ZOSV S MAGGRY="0^4~"_ERR 178 ERR D @^%ZOSF("ERRTN") 179 Q:$Q 1 Q 180 ; 181 END Q ; 1 MAGJUTL4 ;WIRMFO/JHC VistARad subroutines for RPC calls ; 15 Jul 2004 4:34 PM 2 ;;3.0;IMAGING;**18**;Mar 07, 2006 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 Q 19 ; 20 CPTGRP(MAGGRY,DATA) ; RPC: MAGJ CPTMATCH 21 ; FOR INPUT cpt code, return matching cpt's based on grouping criteria: 22 ; INPUT in DATA: CPT Code ^ Criteria 23 ; Criteria: 24 ; 1=Matching cpt 25 ; 2=Body Part 26 ; 3=Body Part & Modality 27 ; 10=Same CPT (used to return short description only) 28 ; Return: List of CPTs with Short Name: CPT ^ Short Name 29 ; MAGGRY holds $NA reference to ^TMP for rpc return 30 ; all ref's to MAGGRY use subscript indirection 31 ; 32 N $ETRAP,$ESTACK S $ETRAP="G ERR1^MAGJUTL4" 33 N REPLY,DIQUIET,CPT,CRIT,CT,MAGLST,NOD,NODLST 34 N MATCHGRP,INDXLST,AND,RET,CPTGLB,CPTIN,CPTIEN,TCPT 35 ; 36 ; <*> Issue: Unable get specific body part for some non-specific CPTs (e.g., 75774-ANGIO SELECT EA ADD VESSEL-S) 37 ; --> For these, could just return matching CPTs (or equivalent CPT?) 38 ; 39 ; Produce List of cptiens for each INDX of interest 40 ; AND with next list of cptiens; repeat until no more INDXs 41 ; build output list of CPT codes (w/ short names [optional]) 42 S DIQUIET=1 D DT^DICRW 43 S CT=0,MAGLST="MAGJCPT" 44 K MAGGRY S MAGGRY=$NA(^TMP($J,MAGLST)) K @MAGGRY ; assign MAGGRY value 45 S CPTIN=$P(DATA,U),CRIT=$P(DATA,U,2) 46 S REPLY="0^Getting matching CPT info." 47 S:'CRIT CRIT=1 ; default equivalent 48 I CPTIN="" S REPLY="0^Invalid CPT code ("_DATA_")." G CPTGRPZ 49 I '(CRIT=1!(CRIT=2)!(CRIT=3)!(CRIT=10)) S REPLY="0^Invalid criteria ("_DATA_")." G CPTGRPZ 50 S CPTGLB=$NA(^MAG(2006.67)) 51 S CPTIEN=$O(@CPTGLB@("B",CPTIN,"")) 52 I 'CPTIEN S REPLY="0^Input CPT code ("_CPTIN_") not defined in CPT Match table." G CPTGRPZ 53 S X=@CPTGLB@(CPTIEN,0),MATCHGRP=+$P(X,U,4) 54 ;CPTMATCH^BODYPART^MDL 55 I CRIT=2!(CRIT=3) D 56 . S X=0 F S X=$O(@CPTGLB@(CPTIEN,1,"B",X)) Q:'X D GETCPTS("BODYPART",X,"",.RET) 57 . I CRIT=3 D 58 . . M AND=RET K RET S X=0 59 . . F S X=$O(@CPTGLB@(CPTIEN,2,"B",X)) Q:'X D GETCPTS("MDL",X,.AND,.RET) 60 I CRIT=1 D 61 . I MATCHGRP,(MATCHGRP'=CPTIEN) S RET(MATCHGRP)="" D GETCPTS("CPTMATCH",MATCHGRP,"",.RET) 62 . D GETCPTS("CPTMATCH",CPTIEN,"",.RET) 63 I CRIT=10 ; fall through answers this! 64 I '$D(RET(CPTIEN)) S RET(CPTIEN)="" ; always report back input cpt 65 S IEN=0 F S IEN=$O(RET(IEN)) Q:'IEN D 66 . N LIN S X=$G(@CPTGLB@(IEN,0)) 67 . Q:'(X]"") S TCPT=$P(X,U),LIN=TCPT_U_$P($G(^ICPT(TCPT,0)),U,2) ; _U_$$BODPART(IEN,"~")_U_$$MDLLST(IEN,"~") 68 . S CT=CT+1,@MAGGRY@(CT)=LIN 69 S REPLY=CT_U_"1~ "_CT_" CPT Matches returned for "_CPTIN 70 CPTGRPZ ; 71 S @MAGGRY@(0)=REPLY 72 Q 73 ; 74 GETCPTS(INDEX,VALUE,AND,OUT) ; return a list of CPTIENS in OUT 75 ; if array AND is defined, reply only values contained in AND & the index 76 N X,GLBREF,CPTIEN 77 S GLBREF=$NA(@CPTGLB@(INDEX,VALUE)) 78 S CPTIEN=0 79 I $D(AND)>9 D 80 . F S CPTIEN=$O(AND(CPTIEN)) Q:CPTIEN="" I $D(@GLBREF@(CPTIEN)) S OUT(CPTIEN)="" 81 E F S CPTIEN=$O(@GLBREF@(CPTIEN)) Q:'CPTIEN D 82 . S OUT(CPTIEN)="" 83 Q 84 ; 85 BODPART(CPTIEN,DLM) ; return DLM-delimited list of body part values for this CPT 86 I +$G(CPTIEN) 87 E Q "" 88 N LIST,CPTGLB S LIST="" 89 S DLM=$E($G(DLM)) 90 I DLM="" S DLM="^" 91 S CPTGLB=$NA(^MAG(2006.67)) 92 S NOD=0 93 F S NOD=$O(@CPTGLB@(CPTIEN,1,NOD)) Q:'NOD S X=$P(^(NOD,0),U) I X]"" S LIST=LIST_DLM_X 94 Q:$Q $E(LIST,2,999) Q 95 ; 96 MDLLST(CPTIEN,DLM) ; return DLM-delimited list of modality values for this CPT 97 I +$G(CPTIEN) 98 E Q "" 99 N LIST,CPTGLB S LIST="" 100 S DLM=$E($G(DLM)) 101 I DLM="" S DLM="^" 102 S CPTGLB=$NA(^MAG(2006.67)) 103 S NOD=0 104 F S NOD=$O(@CPTGLB@(CPTIEN,2,NOD)) Q:'NOD S X=$P(^(NOD,0),U) I X]"" S LIST=LIST_DLM_X 105 Q:$Q $E(LIST,2,999) Q 106 ; 107 STATCHK(MAGGRY,DATA) ; 108 ; RPC: MAGJ RADSTATUSCHECK 109 ; This may also be accessed by subroutine call. <*> do not change name of EP 110 ; Exam Status check RPC and subroutine: determine if the exam has been Tech-Verified (at least). 111 ; Images are assumed to be verified if Exam Status is Examined, or higher status. 112 ; ; Input in DATA: RADFN^RADTI^RACNI^RARPT 113 ; Input is either RADFN, RADTI, and RACNI; or, RARPT only may be input in piece 4 114 ; Return: Code^Text 115 ; 0 = Problem, or exam was cancelled 116 ; 1 = Not yet verified 117 ; 2 = Tech Verified 118 ; 3 = Radiologist Verified 119 ; 4 = User is a Radiology professional--always allow access 120 ; 121 N $ETRAP,$ESTACK S $ETRAP="G ERR3^MAGJUTL4" 122 N REPLY,STATUS,ORDER,VCAT,STOUT 123 N DIQUIET,RARPT,RADFN,RADTI,RACNI 124 S DIQUIET=1 D DT^DICRW 125 S RADFN=$P(DATA,U),RADTI=$P(DATA,U,2),RACNI=$P(DATA,U,3),RARPT=$P(DATA,U,4) 126 S STOUT="",REPLY="0^Getting image verification status." 127 I RADFN,RADTI,RACNI 128 E I RARPT D RPT2DPT(RARPT,.X) I X S RADFN=+X,RADTI=$P(X,U,2),RACNI=$P(X,U,3) I RADFN,RADTI,RACNI 129 E S REPLY="0^Image Verification Status request contains invalid case pointer ("_DATA_")" G STATCHKZ 130 S STATUS=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,3) 131 I STATUS="" S REPLY="0^Image Verification Status request error--no Exam Status is defined for ("_DATA_")" G STATCHKZ 132 S VCAT=$P(^RA(72,STATUS,0),U,9),ORDER=$P(^(0),U,3) 133 I VCAT]"" D G STATCHK2:STOUT 134 . I "EDT"[VCAT S STOUT=$S(VCAT="E":2,1:3) ; Examined or Interpreted 135 . E I VCAT="W" S STOUT=1 ; Not yet Verified 136 I ORDER=9 S STOUT=3 ; Completed exam 137 E I ORDER=0 S REPLY="0^Exam Cancelled" 138 E I ORDER=1 S STOUT=1 ; Waiting for exam 139 STATCHK2 ; 140 I STOUT<2 D 141 . F X="S","R","T" I $D(^VA(200,"ARC",X,DUZ)) S STOUT=4 Q ; Radiologist or Tech -- OK to access 142 STATCHKZ ; 143 I STOUT S REPLY=STOUT_U_$S(STOUT=1:"Images not yet verified",STOUT=2:"Images verified by Technologist",STOUT=3:"Images interpreted by Radiologist",STOUT=4:"Radiology professional--OK to view images.",1:"") 144 S MAGGRY=REPLY 145 Q 146 ; 147 REMSCRN(MAGGRY,DATA) ; User set/clear flag to show/not show remote exams only 148 ; RPC: MAGJ REMOTESCREEN 149 ; ; Input in DATA: 1/0 1=show remote only; 0=show all exams 150 ; Return: Reply^Code~msg 151 ; Reply -- 0=Problem; 1=Success 152 ; Code -- 4=Error; 1=ok 153 ; msg -- display text if error 154 ; 155 N $ETRAP,$ESTACK S $ETRAP="G ERR3^MAGJUTL4" 156 N REPLY 157 N DIQUIET S DIQUIET=1 D DT^DICRW 158 I $D(DATA),(DATA=0!(DATA=1)) 159 E S REPLY="0^4~REMOTESCREEN request has invalid parameter ("_$G(DATA)_")" G REMSCRNZ 160 S MAGJOB("REMOTESCREEN")=DATA,REPLY="1^1~"_DATA 161 REMSCRNZ ; 162 S MAGGRY=REPLY 163 Q 164 ; 165 RPT2DPT(RARPT,RET) ; Input RARPT. Return RET containing exam ss values for ^RADPT 166 ; 167 N DFN,DTI,CNI S (DFN,DTI,CNI)="" 168 I RARPT?1N.N,$D(^RARPT(RARPT)) S X=$G(^(RARPT,0)) I X]"" D 169 . S X=$P(X,U) 170 . S X=$O(^RADPT("ADC",X,0)) I X S DFN=X,DTI=$O(^(X,0)),CNI=$O(^(DTI,0)) 171 . S RET=DFN_U_DTI_U_CNI 172 E S RET="" 173 Q 174 ; 175 ERR1 N ERR S ERR=$$EC^%ZOSV S @MAGGRY@(0)="0^4~"_ERR G ERR 176 ERR3 N ERR S ERR=$$EC^%ZOSV S MAGGRY="0^4~"_ERR 177 ERR D @^%ZOSF("ERRTN") 178 Q:$Q 1 Q 179 ; 180 END Q ; -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGJUTL5.m
r613 r623 1 MAGJUTL5 ;WOIFO/JHC - VistARad RPCs ; [ 07/3/2006 17:17 ] 2 ;;3.0;IMAGING;**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 ; adapted from MAGGTU4 21 GETVER(SVRVER,SVRTVER,ALLOWCL) ; 22 ; The Server Version SVRVER is hardcoded to match the Client 23 ; so this Routine must be edited/distributed with a new Client 24 ; released Client will have the T version that the server expects 25 ; 26 S SVRVER="3.0.76",SVRTVER=14 ; <*> Edit this line for each patch/T-version 27 ; 28 S ALLOWCL="|3.0.65|" ; 29 Q 30 ; 31 CHKVER(MAGRY,CLVER,PLC,SVERSION) ; 32 ; Input CLVER is the version of the Client 33 ; format: Major.Minor.Patch.Build# (Build #=T-ver) eg 3.0.18.132 34 ; Ver 3.0.65.n is first client Ver that makes this call 35 ; 3 possible return codes in MAGRY: 36 ; 2^n~msg : Client displays a message and continues 37 ; 1^1~msg : Client continues without displaying a message 38 ; 0^n~msg : Client displays a message then Aborts 39 ; PLC returns 2006.1 pointer 40 ; 41 S CLVER=$G(CLVER),PLC="",MAGRY="" 42 N SV,ST,CV,CT,CP,ALLOWV,TESTFLAG,SVSTAT 43 ; SVERSION = Full Server Version -> (3.0.18.132 or 3.0.18); test has 4, release has 3 parts 44 ; SV = Server Version -> (3.0.18); only 1st 3 parts 45 ; ST = Server T Version -> defined to always match client part-4 46 ; CV = Client Version, w/out build # 47 ; CT = Client T Version alone 48 ; CP = Client Patch alone 49 ; ALLOWV = Hard coded string of allowed clients for this KIDS. 50 ; TESTFLAG = 1/0 -- 1=Test vs of server code; 0=Release vs 51 ;Below is placeholder for future enhancement: 52 ;I $P(CLVER,"|",2)="RIV" D Q 53 ;. S MAGJOB("RIV")=1 54 ;. ; Allowing |RIV clients always 55 ;. S MAGRY="1^1~Allowing Remote Image Connection" 56 ; 57 I $G(DUZ(2)) S PLC=$$PLACE^MAGBAPI(DUZ(2)) 58 ; Quit if we don't have a valid DUZ(2) or valid PLACE: ^MAG(2006.1,PLC) 59 I 'PLC S MAGRY="0^4~Error verifying Imaging Site (Place) -- Contact Imaging support." Q 60 ; 61 D GETVER(.SV,.ST,.ALLOWV) 62 S CLVER=$P(CLVER,"|") 63 S CV=$P(CLVER,".",1,3),CT=+$P(CLVER,".",4),CP=+$P(CLVER,".",3) 64 ; 65 D VERSTAT(.SVSTAT,SV) 66 I 'SVSTAT S MAGRY(0)=SVSTAT Q ; KIDS status for this version indeterminate 67 S TESTFLAG=(+SVSTAT=1) 68 S SVERSION=SV 69 I TESTFLAG S SVERSION=SV_"."_ST 70 ; Check Version differences: 71 I (CV'=SV) D Q 72 . I '(ALLOWV[("|"_CV_"|")) D Q 73 . . S MAGRY="0^4~VistARad Workstation software version "_CLVER_" is not compatible with the VistA server version "_SVERSION_". Contact Imaging support. (CNA)" 74 . ; Warn the Client, allow to continue 75 . I TESTFLAG S MAGRY="2^3~VistARad Workstation software version "_CLVER_" is running with VistA server TEST Version "_SVERSION_" -- VistARad will Continue, but contact Imaging Support if problems occur. (Pdif)" 76 . E S MAGRY="2^3~VistARad Workstation software version "_CLVER_" is running with VistA server Version "_SVERSION_" -- VistARad will Continue, but contact Imaging Support to install Released Version. (RPdif)" 77 . Q 78 ; Versions are the Same: If T versions are not, warn the Client if needed. 79 ; Released Client (of any version) will have the T version that the server 80 ; expects, and no warning will be displayed. 81 I CT,(CT'=ST) D Q 82 . I TESTFLAG S MAGRY="2^3~VistARad Workstation software vs. "_CLVER_" is running with VistA server TEST vs. "_SVERSION_" -- VistARad will Continue, but contact Imaging Support " D 83 . . I CT<ST S MAGRY=MAGRY_"to install updated client software. (Tdif-1)" 84 . . E S MAGRY=MAGRY_"to update the Server software. (Tdif-2)" 85 . E S MAGRY="2^3~VistARad Workstation software vs. "_CLVER_" is running with VistA server vs. "_SVERSION_" -- VistARad will Continue, but contact Imaging Support to install Released Version. (RVdif)" 86 . Q 87 ; Client and Server Versions are the same 88 S MAGRY="1^1~Version Check OK. Server: "_SVERSION_" Client: "_CLVER Q 89 Q 90 ; 91 P32STOP(RET) ; logic to indicate P32 should no longer function, once the RELEASED P76 is installed 92 ; This is invoked from magjutl3, P76 version, if a P32 client is launched 93 ; RET=1/0 ^ text -- 0 = OK to run P32; 1 = Not OK 94 N SV,ST,ALLOWV,SVSTAT,RELEASED 95 S RET="0^P32 supported" ; init return to allow p32 to function 96 D GETVER(.SV,.ST,.ALLOWV) 97 D VERSTAT(.SVSTAT,SV) 98 I 'SVSTAT S RET="0^Error, but on side of caution, allow running." Q ; KIDS status for this version indeterminate 99 S RELEASED=(+SVSTAT=2) 100 I RELEASED!(SV'="3.0.76") S RET="1^P32 support over" ; don't allow P32 to function 101 Q 102 ; 103 VERSTAT(MAGRY,MAGVER) ; 104 ; Returns the status of an Imaging Version 105 ; Input: 106 ; MAGVER - Version number in format MAG*3.0*59 or 3.0.59 107 ; Return: MAGRY = 0/1/2 -- see below; 0: abort; else, OK to proceed 108 ; 109 N VERI,TVER,MAGERR 110 I +MAGVER S MAGVER="MAG*"_$P(MAGVER,".",1,2)_"*"_$P(MAGVER,".",3) 111 S VERI=$$FIND1^DIC(9.6,"","O",MAGVER,"","","MAGERR") 112 I 'VERI S MAGRY="0^4~There is No KIDs Install record." 113 E D 114 . S TVER=$$GET1^DIQ(9.6,VERI_",","ALPHA/BETA TESTING") 115 . I TVER="YES" S MAGRY="1^Alpha/Beta Version" 116 . E I TVER="NO" S MAGRY="2^Released Version" 117 . E S MAGRY="0^4~KIDs Install Status is unknown--contact Customer Support." 118 Q ; 119 END ; 1 MAGJUTL5 ;WOIFO/JHC - VistARad RPCs ; [ 07/3/2006 17:17 ] 2 ;;3.0;IMAGING;**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 ; adapted from MAGGTU4 21 GETVER(SVRVER,SVRTVER,ALLOWCL) ; 22 ; The Server Version SVRVER is hardcoded to match the Client 23 ; so this Routine must be edited/distributed with a new Client 24 ; released Client will have the T version that the server expects 25 ; 26 S SVRVER="3.0.65",SVRTVER=12 ; <*> Edit this line for each patch/T-version 27 ; 28 S ALLOWCL="|3.0.18|" ; note--patch 32 is numbered funny, so is hard-coded below 29 Q 30 ; 31 CHKVER(MAGRY,CLVER,PLC,SVERSION) ; 32 ; Input CLVER is the version of the Client 33 ; format: Major.Minor.Patch.Build# (Build #=T-ver) eg 3.0.18.132 34 ; Ver 3.0.65.n is first client Ver that makes this call 35 ; 3 possible return codes in MAGRY: 36 ; 2^n~msg : Client displays a message and continues 37 ; 1^1~msg : Client continues without displaying a message 38 ; 0^n~msg : Client displays a message then Aborts 39 ; PLC returns 2006.1 pointer 40 ; 41 S CLVER=$G(CLVER),PLC="",MAGRY="" 42 N SV,ST,CV,CT,CP,ALLOWV,TESTFLAG,SVSTAT 43 ; SVERSION = Full Server Version -> (3.0.18.132 or 3.0.18); test has 4, release has 3 parts 44 ; SV = Server Version -> (3.0.18); only 1st 3 parts 45 ; ST = Server T Version -> defined to always match client part-4 46 ; CV = Client Version, w/out build # 47 ; CT = Client T Version alone 48 ; CP = Client Patch alone 49 ; ALLOWV = Hard coded string of allowed clients for this KIDS. 50 ; TESTFLAG = 1/0 -- 1=Test vs of server code; 0=Release vs 51 ;Below is placeholder for future enhancement: 52 ;I $P(CLVER,"|",2)="RIV" D Q 53 ;. S MAGJOB("RIV")=1 54 ;. ; Allowing |RIV clients always 55 ;. S MAGRY="1^1~Allowing Remote Image Connection" 56 ; 57 I $G(DUZ(2)) S PLC=$$PLACE^MAGBAPI(DUZ(2)) 58 ; Quit if we don't have a valid DUZ(2) or valid PLACE: ^MAG(2006.1,PLC) 59 I 'PLC S MAGRY="0^4~Error verifying Imaging Site (Place) -- Contact Imaging support." Q 60 ; 61 D GETVER(.SV,.ST,.ALLOWV) 62 S CLVER=$P(CLVER,"|") 63 S CV=$P(CLVER,".",1,3),CT=+$P(CLVER,".",4),CP=+$P(CLVER,".",3) 64 ; 65 D VERSTAT(.SVSTAT,SV) 66 I 'SVSTAT S MAGRY(0)=SVSTAT Q ; KIDS status for this version indeterminate 67 S TESTFLAG=(+SVSTAT=1) 68 S SVERSION=SV 69 I TESTFLAG S SVERSION=SV_"."_ST 70 ; 71 ; Patch 32 client is OK: 72 I CLVER="3.0.41.17" S MAGRY="1^1~P32 Client Version Check OK. Server: "_SVERSION_" Client: "_CLVER Q 73 ; Other Version differences: 74 I (CV'=SV) D Q 75 . I '(ALLOWV[("|"_CV_"|")) D Q 76 . . S MAGRY="0^4~VistARad Workstation software version "_CLVER_" is not compatible with the VistA server version "_SVERSION_". Contact Imaging support. (CNA)" 77 . ; Don't allow Test versions of P18 78 . I CP=18,(CT'=132) D Q 79 . . S MAGRY="0^4~VistARad Workstation software version "_CLVER_" is not compatible with the VistA server version "_SVERSION_". Contact Imaging support. (C18T)" 80 . ; Warn the Client, allow to continue 81 . I TESTFLAG S MAGRY="2^3~VistARad Workstation software version "_CLVER_" is running with VistA server TEST Version "_SVERSION_" -- VistARad will Continue, but contact Imaging Support if problems occur. (Pdif)" 82 . E S MAGRY="2^3~VistARad Workstation software version "_CLVER_" is running with VistA server Version "_SVERSION_" -- VistARad will Continue, but contact Imaging Support to install Released Version. (RPdif)" 83 . Q 84 ; Versions are the Same: If T versions are not, warn the Client if needed. 85 ; Released Client (of any version) will have the T version that the server 86 ; expects, and no warning will be displayed. 87 I CT,(CT'=ST) D Q 88 . I TESTFLAG S MAGRY="2^3~VistARad Workstation software vs. "_CLVER_" is running with VistA server TEST vs. "_SVERSION_" -- VistARad will Continue, but contact Imaging Support " D 89 . . I CT<ST S MAGRY=MAGRY_"to install updated client software. (Tdif-1)" 90 . . E S MAGRY=MAGRY_"to update the Server software. (Tdif-2)" 91 . E S MAGRY="2^3~VistARad Workstation software vs. "_CLVER_" is running with VistA server vs. "_SVERSION_" -- VistARad will Continue, but contact Imaging Support to install Released Version. (RVdif)" 92 . Q 93 ; Client and Server Versions are the same 94 S MAGRY="1^1~Version Check OK. Server: "_SVERSION_" Client: "_CLVER Q 95 Q 96 ; 97 VERSTAT(MAGRY,MAGVER) ; 98 ; Returns the status of an Imaging Version 99 ; Input: 100 ; MAGVER - Version number in format MAG*3.0*59 or 3.0.59 101 ; Return: MAGRY = 0/1/2 -- see below; 0: abort; else, OK to proceed 102 ; 103 N VERI,TVER,MAGERR 104 I +MAGVER S MAGVER="MAG*"_$P(MAGVER,".",1,2)_"*"_$P(MAGVER,".",3) 105 S VERI=$$FIND1^DIC(9.6,"","",MAGVER,"","","MAGERR") 106 I 'VERI S MAGRY="0^4~There is No KIDs Install record." 107 E D 108 . S TVER=$$GET1^DIQ(9.6,VERI_",","ALPHA/BETA TESTING") 109 . I TVER="YES" S MAGRY="1^Alpha/Beta Version" 110 . E I TVER="NO" S MAGRY="2^Released Version" 111 . E S MAGRY="0^4~KIDs Install Status is unknown--contact Customer Support." 112 Q ; 113 END ; -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGLOG.m
r613 r623 1 MAGLOG ;WOIFO/RED,SRR,MLH - Log image access ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;**17,8,20,59**;Nov 27, 2007;Build 20 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 ; CALL WITH: 20 ; MAGIMT = TYPE OF ACCESS 21 ; DUZ = USER NO. 22 ; MAGO = IMAGE SUBSCRIPT NO. 23 ; MAGPACK = USER INTERFACE PACKAGE 24 ; MAGDFN = PATIENT NO. 25 ; MAGCT = TOTAL IMAGE COUNT 26 ; MAGAD = ADDITIONAL DATA 27 ENTRY(MAGIMT,MAGDUZ,MAGO,MAGPACK,MAGDFN,MAGCT,MAGAD) ; 28 I '$D(MAGSYS) S MAGSYS=^%ZOSF("VOL") 29 N MAGC,MSYS 30 S MSYS=$$UP^XLFSTR(MAGSYS) 31 I (MSYS["UNKNOWN"),($D(MAGJOB("WRKSIEN"))) S MSYS=$P(^MAG(2006.81,MAGJOB("WRKSIEN"),0),"^",1) 32 L +^MAG(2006.95,0):10 E Q ;entries were being overwritten. 33 S MAGC=$P(^MAG(2006.95,0),"^",3)+1 34 S $P(^MAG(2006.95,0),"^",3,4)=MAGC_"^"_MAGC 35 L -^MAG(2006.95,0) 36 D NOW^%DTC ;gives us % (now) 37 ; FLD #'s .01 1 2 3 4 5 6 7 8 9 38 S ^MAG(2006.95,MAGC,0)=MAGC_"^"_$G(MAGIMT)_"^"_$G(MAGDUZ)_"^"_MAGO_"^"_MAGPACK_"^"_MSYS_"^"_%_"^"_MAGDFN_"^"_MAGCT_"^"_+$G(MAGJOB("SESSION")) 39 I $D(MAGAD) S ^MAG(2006.95,MAGC,100)=MAGAD 40 S ^MAG(2006.95,"B",MAGC,MAGC)="" 41 D ACCESS(MAGO) ; This should be here. Can now search 2006.95 from "Last Access Date" to "Capture Date" to 42 ; get all Actions logged. We Don't have to search entire Image File. 43 I $G(MAGJOB("SESSION")) S ^MAG(2006.95,"AS",+$G(MAGJOB("SESSION")),MAGC)="" 44 Q 45 ACCESS(MAGO) ; Update Field "Last Access Date" in Image File. 46 Q:'$G(MAGO) 47 I '$D(^MAG(2005,MAGO,0)) D Q 48 . I $D(^MAG(2005.1,MAGO,0)) S $P(^MAG(2005.1,MAGO,0),"^",9)=$$NOW^XLFDT 49 . Q 50 S $P(^MAG(2005,MAGO,0),"^",9)=$$NOW^XLFDT 51 Q 1 MAGLOG ;WOIFO/RED,SRR,MLH - Log image access ; [ 06/20/2001 08:57 ] 2 ;;3.0;IMAGING;**17,8,20**;Apr 12, 2006 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 ; CALL WITH: 19 ; MAGIMT = TYPE OF ACCESS 20 ; DUZ = USER NO. 21 ; MAGO = IMAGE SUBSCRIPT NO. 22 ; MAGPACK = USER INTERFACE PACKAGE 23 ; MAGDFN = PATIENT NO. 24 ; MAGCT = TOTAL IMAGE COUNT 25 ; MAGAD = ADDITIONAL DATA 26 ENTRY(MAGIMT,MAGDUZ,MAGO,MAGPACK,MAGDFN,MAGCT,MAGAD) ; 27 I '$D(MAGSYS) S MAGSYS=^%ZOSF("VOL") 28 N MAGC,MSYS 29 S MSYS=$$UP^XLFSTR(MAGSYS) 30 I (MSYS["UNKNOWN"),($D(MAGJOB("WRKSIEN"))) S MSYS=$P(^MAG(2006.81,MAGJOB("WRKSIEN"),0),"^",1) 31 L +^MAG(2006.95,0):10 E Q ;entries were being overwritten. 32 S MAGC=$P(^MAG(2006.95,0),"^",3)+1 33 S $P(^MAG(2006.95,0),"^",3,4)=MAGC_"^"_MAGC 34 L -^MAG(2006.95,0) 35 D NOW^%DTC ;gives us % (now) 36 ; FLD #'s .01 1 2 3 4 5 6 7 8 9 37 S ^MAG(2006.95,MAGC,0)=MAGC_"^"_$G(MAGIMT)_"^"_$G(MAGDUZ)_"^"_MAGO_"^"_MAGPACK_"^"_MSYS_"^"_%_"^"_MAGDFN_"^"_MAGCT_"^"_+$G(MAGJOB("SESSION")) 38 I $D(MAGAD) S ^MAG(2006.95,MAGC,100)=MAGAD 39 S ^MAG(2006.95,"B",MAGC,MAGC)="" 40 I $G(MAGJOB("SESSION")) S ^MAG(2006.95,"AS",+$G(MAGJOB("SESSION")),MAGC)="" 41 Q 42 ACCESS(MAGO) ; Update Field "Last Access Date" in Image File. 43 I '$D(^MAG(2005,MAGO,0)) D Q 44 . I $D(^MAG(2005.1,MAGO,0)) S $P(^MAG(2005.1,MAGO,0),"^",9)=$$NOW^XLFDT 45 . Q 46 S $P(^MAG(2005,MAGO,0),"^",9)=$$NOW^XLFDT 47 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGSIXG1.m
r613 r623 1 MAGSIXG1 ;WOIFO/EdM/GEK/SEB - RPCs for Document Imaging ; 04/29/2002 16:15 2 ;;3.0;IMAGING;**8,48,59**;Nov 27, 2007;Build 20 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 ; 21 ; OUT = Output array. 22 ; OUT(0) -> 1|0 ^ message 23 ; OUT(1) -> Field Headers 24 ; '^' delimited list of column headers used in cMagListView 25 ; OUT(2..n) -> each line is information on 1 image. 26 ; piece '|' 1 is '^' delimited data to be displayed in columns. 27 ; piece '|' 2 is data that is used internally by App. 28 ; 29 ; PKG - Package fld 40 30 ; CLS - Class fld 41 31 ; TYPE - Type fld 42 32 ; EVENT - Proc/Event fld 43 33 ; SPEC - Spec/SubSpecialty fld 44 34 ; FROM - Date to search from 35 ; UNTIL - Date to search to 36 ; ORIGIN - Origin fld 45 37 ; DATA - Future 38 ; FLGS - Future 39 ; 40 PGI(OUT,DFN,PKG,CLS,TYPE,EVENT,SPEC,FROM,UNTIL,ORIGIN,DATA,FLGS) ;RPC [MAG4 PAT GET IMAGES] 41 ; Get Images for Patient. 42 ; New call in Patch 3.0.8 uses Image Filter to get list of images 43 N C,DAT1,DAT2,E,IMAGE,N,OK,P,RDT,RESULT,S,T,V,CT,PKG1,CLS1,TYPE1,EVENT1,SPEC1,FLTX,FLTY,CAPDUZ,CAPDT,MAGVR,FNL 44 S FROM=$G(FROM),UNTIL=$G(UNTIL) 45 D REVDT(FROM,UNTIL,.DAT1,.DAT2) 46 S RESULT="OUT" K OUT,^TMP($T(+0),$J) 47 S PKG=$G(PKG),CLS=$G(CLS),EVENT=$G(EVENT),SPEC=$G(SPEC),TYPE=$G(TYPE),ORIGIN=$G(ORIGIN) 48 I PKG'="" D PKG^MAGSIXGT Q:$D(OUT(0)) 49 I CLS'="" D CLS^MAGSIXGT Q:$D(OUT(0)) 50 I EVENT'="" D EVENT^MAGSIXGT Q:$D(OUT(0)) 51 I SPEC'="" D SPEC^MAGSIXGT Q:$D(OUT(0)) 52 I TYPE'="" D TYPE^MAGSIXGT Q:$D(OUT(0)) 53 I ORIGIN'="" D ORIGIN^MAGSIXGT Q:$D(OUT(0)) 54 I +DFN'=DFN S @RESULT@(0)="0^Invalid Patient Number: """_DFN_"""." Q 55 I '$D(^DPT(DFN,0))#2 S @RESULT@(0)="0^No Such Patient: """_DFN_"""." Q 56 S N=0 57 D NETPLCS^MAGGTU6 58 ;3.0.8/gek, Quit searching all images, just do the date range. 59 S RDT=DAT1 F S RDT=$O(^MAG(2005,"APDTPX",DFN,RDT)) Q:(RDT="")!(RDT>DAT2) D 60 . K ^TMP($J,"MAGSIX") 61 . N COUNT,PRX,X0,X2,X40,I1,X01 62 . S PRX="" F S PRX=$O(^MAG(2005,"APDTPX",DFN,RDT,PRX)) Q:PRX="" M ^TMP($J,"MAGSIX")=^MAG(2005,"APDTPX",DFN,RDT,PRX) 63 . S IMAGE="" F S IMAGE=$O(^TMP($J,"MAGSIX",IMAGE),-1) Q:IMAGE="" D 64 . . S X0=$G(^MAG(2005,IMAGE,0)) 65 . . Q:$P(X0,"^",10) ; child of Group 66 . . S X2=$G(^MAG(2005,IMAGE,2)),X40=$G(^MAG(2005,IMAGE,40)),I1=$O(^MAG(2005,IMAGE,1,0)) 67 . . S P=$P(X40,U),C=$P(X40,"^",2),T=$P(X40,"^",3),E=$P(X40,"^",4),S=$P(X40,"^",5) 68 . . ;Patch 59. Treat Class as a computed Field. Arrange with Mike to change DB. 69 . . S C=$S('T:"",'$D(^MAG(2005.83,T,0)):"",1:$P(^(0),"^",2)) 70 . . S V=$S($P(X40,"^",6)="":"V",1:$P(X40,"^",6)) ; P48T1 show VA for Null 71 . . D CHK^DIE(2005,45,"E",V,.MAGVR) I MAGVR'="^" S V=MAGVR(0) ; P48T1 show External Value 72 . . I PKG'="",P'="",'$D(OK(5,P)) Q 73 . . I ORIGIN'="",V'="",'$D(OK(6,V)) Q 74 . . I CLS'="",C'="",'$D(OK(1,C)) Q 75 . . I EVENT'="",E,'$D(OK(2,E)) Q 76 . . ;3.0.8 Stop list entries with no Event, if Event is in Search Specs 77 . . I EVENT'="",E="" Q 78 . . I SPEC'="",S,'$D(OK(3,S)) Q 79 . . ;3.0.8 Stop list entries with no Spec, if Spec is in Search Specs 80 . . I SPEC'="",S="" Q 81 . . I TYPE'="",T,'$D(OK(4,T)) Q 82 . . ; Get Count of Images in Group, use 4th piece of ,1,0) multiple 83 . . S COUNT=$S($P($G(^MAG(2005,IMAGE,1,0)),"^",4):$P($G(^MAG(2005,IMAGE,1,0)),"^",4),1:1) 84 . . S FLTX="" 85 . . ; PUT in Site Code as 2nd piece. 86 . . S X01=$S(I1:$G(^MAG(2005,+$G(^MAG(2005,IMAGE,1,I1,0)),0)),1:X0) 87 . . S FNL=$S(+$P(X01,"^",3):$P(X01,"^",3),1:+$P(X01,"^",5)) 88 . . S FLTX=$P($G(MAGJOB("NETPLC",FNL)),"^",2) 89 . . I FLTX="" S FLTX=$G(MAGJOB("PLCODE")) 90 . . S FLTX=FLTX_"^"_$$RPTITLE($P(X2,"^",6),$P(X2,"^",7)) 91 . . S X=$$FMTE^XLFDT($P(X2,"^",5),"5Z") 92 . . S X=$P(X,"@",1)_" "_$S($L($P(X,"@",2)):$P(X,"@",2),1:"00:01") 93 . . S FLTX=FLTX_"^"_X 94 . . S FLTX=FLTX_"^"_$P(X0,"^",8)_"^"_COUNT_"^"_$P(X2,"^",4) 95 . . S FLTX=FLTX_"^"_P 96 . . S FLTX=FLTX_"^"_$P($G(^MAG(2005.82,+C,0)),"^",1) 97 . . S FLTX=FLTX_"^"_$P($G(^MAG(2005.83,+T,0)),"^",1) 98 . . S FLTX=FLTX_"^"_$P($G(^MAG(2005.84,+S,0)),"^",1) 99 . . S FLTX=FLTX_"^"_$P($G(^MAG(2005.85,+E,0)),"^",1) 100 . . S FLTX=FLTX_"^"_V 101 . . ;S FLTX=FLTX_"^"_$P($$FMTE^XLFDT($P(X2,"^",1),"5Z"),"@",1) 102 . . S X=$$FMTE^XLFDT($P(X2,"^",1),"5Z") 103 . . S X=$P(X,"@",1)_" "_$S($L($P(X,"@",2)):$P(X,"@",2),1:"00:01") 104 . . S FLTX=FLTX_"^"_X 105 . . ;;;;;;;;; 106 . . ; P8T36 gek. Fix Error caused if $P(X2,"^",2) "ImageSavedBy" is null 107 . . S FLTX=FLTX_"^"_$$GET1^DIQ(200,+$P(X2,"^",2)_",",.01) 108 . . N MAGFILE,MAGXX 109 . . S MAGXX=IMAGE D INFO^MAGGTII 110 . . S FLTX=FLTX_"^"_$P(MAGFILE,"^",1) 111 . . S N=N+1,@RESULT@(N+1)=N_"^"_FLTX_"|"_MAGFILE 112 . . Q:N<76 Q:RESULT["^" 113 . . ; Image count is getting big, switch from array to Global return type 114 . . S ^TMP($T(+0),$J)="" 115 . . M ^TMP($T(+0),$J)=OUT 116 . . K OUT 117 . . S X=$$RTRNFMT^XWBLIB("GLOBAL ARRAY",1) 118 . . S RESULT=$NA(^TMP($T(+0),$J)) 119 . . S OUT=$NA(^TMP($T(+0),$J)) ;GEK 10/01/02 120 . . Q 121 . ;Q 122 . Q 123 S FLTY=$$FLTDESC(X) 124 I 'N S @RESULT@(0)="0^No images for filter: "_FLTY Q 125 S @RESULT@(0)="1^"_FLTY 126 S @RESULT@(1)="Item~S2^Site^Note Title~~W0^Proc DT~S1^Procedure^# Img~S2^Short Desc^Pkg^Class^Type^Specialty^Event^Origin^Cap Dt~S1~W0^Cap by~~W0^Image ID~S2~W0" 127 ;S @RESULT@(1)="Item~S2^Site^Proc DT~S1^Procedure^# Img~S2^Short Desc^Pkg^Class^Type^Specialty^Event^Origin^Cap Dt~S1~W0^Cap by~~W0^Image ID~S2~W0" 128 Q 129 RPTITLE(FILE,IEN) ; 130 I FILE=8925,$D(^TIU(8925,IEN,0)) Q $P(^TIU(8925.1,$P(^TIU(8925,IEN,0),"^",1),0),"^",1) 131 ;I FILE=8925,$D(^TIU(8925,IEN,0)) Q $$GET1^DIQ(FILE,IEN,".01:.01") 132 E Q " " 133 FLTDESC(X) ; 134 N FLT 135 S FLT="" 136 ; Package 137 S FLT=FLT_$S(PKG="":"",1:"Pkg: "_PKG_" - ") 138 ; Class 139 S FLT=FLT_$S(CLS="":"",CLS="ADMIN,ADMIN/CLIN,CLIN/ADMIN":"Class: ADMIN - ",CLS="CLIN,CLIN/ADMIN,ADMIN/CLIN":"Class: CLIN - ",1:"Class: "_CLS_" - ") 140 ; Type 141 F CT=1:1:$L(TYPE,",") D 142 . S TYPE1=$P(TYPE,",",CT) I TYPE1'="" S TYPE1=$P($G(^MAG(2005.83,TYPE1,0)),"^") 143 . S $P(TYPE,",",CT)=$E(TYPE1)_$$LOW^XLFSTR($E(TYPE1,2,999)) 144 S FLT=FLT_$S(TYPE="":"",1:"Type: "_TYPE_" - ") 145 ; Specialty/SubSpecialty 146 F CT=1:1:$L(SPEC,",") D 147 . S SPEC1=$P(SPEC,",",CT) I SPEC1'="" S SPEC1=$P($G(^MAG(2005.84,SPEC1,0)),"^") 148 . S $P(SPEC,",",CT)=$E(SPEC1)_$$LOW^XLFSTR($E(SPEC1,2,999)) 149 S FLT=FLT_$S(SPEC="":"",1:"Spec.: "_SPEC_" - ") 150 ; Procedure/Event 151 F CT=1:1:$L(EVENT,",") D 152 . S EVENT1=$P(EVENT,",",CT) I EVENT1'="" S EVENT1=$P($G(^MAG(2005.85,EVENT1,0)),"^") 153 . S $P(EVENT,",",CT)=$E(EVENT1)_$$LOW^XLFSTR($E(EVENT1,2,999)) 154 S FLT=FLT_$S(EVENT="":"",1:"Event: "_EVENT_" - ") 155 ; Origin 156 S FLT=FLT_$S(ORIGIN="":"",1:"Origin: "_ORIGIN_" - ") 157 ; Date Range - From 158 S FROM=$S($G(FROM)="":"",1:" from "_FROM) 159 ; Date Range - Until 160 S UNTIL=$S($G(UNTIL)="":"",1:" to "_UNTIL) 161 S FLT=FLT_$G(FROM)_$G(UNTIL) 162 ; If No Filter. Then get All. 163 I FLT="" S FLT="All Images" 164 Q FLT 165 REVDT(FROM,UNTIL,DAT1,DAT2) ; Calculate the Reverse Dates and switch for $O 166 ; for $O( through a data cross reference that is reversed, i.e. X=9999999.9999-DT 167 ; FROM = Date in External or Internal 168 ; UNTIL = Date in External or Internal 169 ; DAT1 = Reverse the two dates, FROM and UNTIL, equal to the earliest 170 ; DAT2 = Reverse the two dates, FROM and UNTIL, equal to the latest 171 ; 172 S DAT1=$$E2I^MAGSIXGT($G(FROM)) 173 S DAT2=$$E2I^MAGSIXGT($G(UNTIL)) 174 I 'DAT2 S DAT2=9999999.9999 175 S DAT1=9999999.9999-DAT1 176 S DAT2=9999999.9999-DAT2 177 I DAT1]DAT2 S X=DAT1,DAT1=DAT2,DAT2=X 178 S DAT1=DAT1\1,$P(DAT2,".",2)="9999" 179 Q 1 MAGSIXG1 ;WOIFO/EdM/GEK/SEB - RPCs for Document Imaging ; 04/29/2002 16:15 2 ;;3.0;IMAGING;**8,48**;Jan 11, 2005 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 Q 19 ; 20 ; OUT ;--- Output array 21 ; CLS ;--- Class 22 ; TYPE ;-- Type (of what?) 23 ; SPEC ;-- Specialty or SubSpecialty 24 ; EVENT ;- Event or Procedure or Action 25 PGI(OUT,DFN,PKG,CLS,TYPE,EVENT,SPEC,FROM,UNTIL,ORIGIN) ;RPC [MAG4 PAT GET IMAGES] 26 ; Get Images for Patient. 27 ; New call in Patch 3.0.8 uses Image Filter to get list of images 28 ; 29 N C,DAT1,DAT2,E,IMAGE,N,OK,P,RDT,RESULT,S,T,V,CT,PKG1,CLS1,TYPE1,EVENT1,SPEC1,FLTX,FLTY,CAPDUZ,CAPDT,MAGVR,FNL 30 S FROM=$G(FROM),UNTIL=$G(UNTIL) 31 D REVDT(FROM,UNTIL,.DAT1,.DAT2) 32 S RESULT="OUT" K OUT,^TMP($T(+0),$J) 33 S PKG=$G(PKG),CLS=$G(CLS),EVENT=$G(EVENT),SPEC=$G(SPEC),TYPE=$G(TYPE),ORIGIN=$G(ORIGIN) 34 I PKG'="" D PKG^MAGSIXGT Q:$D(OUT(0)) 35 I CLS'="" D CLS^MAGSIXGT Q:$D(OUT(0)) 36 I EVENT'="" D EVENT^MAGSIXGT Q:$D(OUT(0)) 37 I SPEC'="" D SPEC^MAGSIXGT Q:$D(OUT(0)) 38 I TYPE'="" D TYPE^MAGSIXGT Q:$D(OUT(0)) 39 I ORIGIN'="" D ORIGIN^MAGSIXGT Q:$D(OUT(0)) 40 I +DFN'=DFN S @RESULT@(0)="0^Invalid Patient Number: """_DFN_"""." Q 41 I '$D(^DPT(DFN,0))#2 S @RESULT@(0)="0^No Such Patient: """_DFN_"""." Q 42 S N=0 43 D NETPLCS^MAGGTU6 44 ;S RDT="" F S RDT=$O(^MAG(2005,"APDTPX",DFN,RDT)) Q:RDT="" D 45 ;3.0.8/gek, Quit searching all images, just do the date range. 46 S RDT=DAT1 F S RDT=$O(^MAG(2005,"APDTPX",DFN,RDT)) Q:(RDT="")!(RDT>DAT2) D 47 . N COUNT,PRX,X0,X2,X40,I1,X01 48 . S PRX="" F S PRX=$O(^MAG(2005,"APDTPX",DFN,RDT,PRX)) Q:PRX="" D 49 . . S IMAGE="" F S IMAGE=$O(^MAG(2005,"APDTPX",DFN,RDT,PRX,IMAGE)) Q:IMAGE="" D 50 . . . S X0=$G(^MAG(2005,IMAGE,0)) 51 . . . Q:$P(X0,"^",10) ; child of Group 52 . . . S X2=$G(^MAG(2005,IMAGE,2)),X40=$G(^MAG(2005,IMAGE,40)),I1=$O(^MAG(2005,IMAGE,1,0)) 53 . . . S P=$P(X40,U),C=$P(X40,"^",2),T=$P(X40,"^",3),E=$P(X40,"^",4),S=$P(X40,"^",5) 54 . . . S V=$S($P(X40,"^",6)="":"V",1:$P(X40,"^",6)) ; P48T1 show VA for Null 55 . . . D CHK^DIE(2005,45,"E",V,.MAGVR) S V=MAGVR(0) ; P48T1 show External Value 56 . . . I PKG'="",P'="",'$D(OK(5,P)) Q 57 . . . I ORIGIN'="",V'="",'$D(OK(6,V)) Q 58 . . . I CLS'="",C'="",'$D(OK(1,C)) Q 59 . . . I EVENT'="",E,'$D(OK(2,E)) Q 60 . . . ;3.0.8 Stop list entries with no Event, if Event is in Search Specs 61 . . . I EVENT'="",E="" Q 62 . . . I SPEC'="",S,'$D(OK(3,S)) Q 63 . . . ;3.0.8 Stop list entries with no Spec, if Spec is in Search Specs 64 . . . I SPEC'="",S="" Q 65 . . . I TYPE'="",T,'$D(OK(4,T)) Q 66 . . . ; Get Count of Images in Group, use 4th piece of ,1,0) multiple 67 . . . S COUNT=$S($P($G(^MAG(2005,IMAGE,1,0)),"^",4):$P($G(^MAG(2005,IMAGE,1,0)),"^",4),1:1) 68 . . . S FLTX="" 69 . . . ; PUT in Site Code as 2nd piece. 70 . . . S X01=$S(I1:$G(^MAG(2005,+$G(^MAG(2005,IMAGE,1,I1,0)),0)),1:X0) 71 . . . S FNL=$S(+$P(X01,"^",3):$P(X01,"^",3),1:+$P(X01,"^",5)) 72 . . . S FLTX=$P($G(MAGJOB("NETPLC",FNL)),"^",2) 73 . . . S FLTX=FLTX_"^"_$P($$FMTE^XLFDT($P(X2,"^",5),"5Z"),"@",1) 74 . . . S FLTX=FLTX_"^"_$P(X0,"^",8)_"^"_COUNT_"^"_$P(X2,"^",4) 75 . . . S FLTX=FLTX_"^"_P 76 . . . S FLTX=FLTX_"^"_$P($G(^MAG(2005.82,+C,0)),"^",1) 77 . . . S FLTX=FLTX_"^"_$P($G(^MAG(2005.83,+T,0)),"^",1) 78 . . . S FLTX=FLTX_"^"_$P($G(^MAG(2005.84,+S,0)),"^",1) 79 . . . S FLTX=FLTX_"^"_$P($G(^MAG(2005.85,+E,0)),"^",1) 80 . . . S FLTX=FLTX_"^"_V 81 . . . S FLTX=FLTX_"^"_$P($$FMTE^XLFDT($P(X2,"^",1),"5Z"),"@",1) 82 . . . ; P8T36 gek. Fix Error caused if $P(X2,"^",2) "ImageSavedBy" is null 83 . . . S FLTX=FLTX_"^"_$$GET1^DIQ(200,+$P(X2,"^",2)_",",.01) 84 . . . N MAGFILE,MAGXX 85 . . . S MAGXX=IMAGE D INFO^MAGGTII 86 . . . S FLTX=FLTX_"^"_$P(MAGFILE,"^",1) 87 . . . S N=N+1,@RESULT@(N+1)=N_"^"_FLTX_"|"_MAGFILE 88 . . . Q:N<101 Q:RESULT["^" 89 . . . ; Image count is getting big, switch from array to Global return type 90 . . . S ^TMP($T(+0),$J)="" 91 . . . M ^TMP($T(+0),$J)=OUT 92 . . . K OUT 93 . . . S X=$$RTRNFMT^XWBLIB("GLOBAL ARRAY",1) 94 . . . S RESULT=$NA(^TMP($T(+0),$J)) 95 . . . S OUT=$NA(^TMP($T(+0),$J)) ;GEK 10/01/02 96 . . . Q 97 . . Q 98 . Q 99 S FLTY=$$FLTDESC(X) 100 I 'N S @RESULT@(0)="0^No images for filter: "_FLTY Q 101 S @RESULT@(0)="1^"_FLTY 102 S @RESULT@(1)="Item~S2^Site^Proc DT~S1^Procedure^# Img~S2^Short Desc^Pkg^Class^Type^Specialty^Event^Origin^Cap Dt~S1~W0^Cap by~~W0^Image ID~S2~W0" 103 Q 104 FLTDESC(X) ; 105 N FLT 106 S FLT="" 107 ; Package 108 S FLT=FLT_$S(PKG="":"",1:"Pkg: "_PKG_" - ") 109 ; Class 110 S FLT=FLT_$S(CLS="":"",CLS="ADMIN,ADMIN/CLIN,CLIN/ADMIN":"Class: ADMIN - ",CLS="CLIN,CLIN/ADMIN,ADMIN/CLIN":"Class: CLIN - ",1:"Class: "_CLS_" - ") 111 ; Type 112 F CT=1:1:$L(TYPE,",") D 113 . S TYPE1=$P(TYPE,",",CT) I TYPE1'="" S TYPE1=$P($G(^MAG(2005.83,TYPE1,0)),"^") 114 . S $P(TYPE,",",CT)=$E(TYPE1)_$$LOW^XLFSTR($E(TYPE1,2,999)) 115 S FLT=FLT_$S(TYPE="":"",1:"Type: "_TYPE_" - ") 116 ; Specialty/SubSpecialty 117 F CT=1:1:$L(SPEC,",") D 118 . S SPEC1=$P(SPEC,",",CT) I SPEC1'="" S SPEC1=$P($G(^MAG(2005.84,SPEC1,0)),"^") 119 . S $P(SPEC,",",CT)=$E(SPEC1)_$$LOW^XLFSTR($E(SPEC1,2,999)) 120 S FLT=FLT_$S(SPEC="":"",1:"Spec.: "_SPEC_" - ") 121 ; Procedure/Event 122 F CT=1:1:$L(EVENT,",") D 123 . S EVENT1=$P(EVENT,",",CT) I EVENT1'="" S EVENT1=$P($G(^MAG(2005.85,EVENT1,0)),"^") 124 . S $P(EVENT,",",CT)=$E(EVENT1)_$$LOW^XLFSTR($E(EVENT1,2,999)) 125 S FLT=FLT_$S(EVENT="":"",1:"Event: "_EVENT_" - ") 126 ; Orgin 127 S FLT=FLT_$S(ORIGIN="":"",1:"Origin: "_ORIGIN_" - ") 128 ; Date Range - From 129 S FROM=$S($G(FROM)="":"",1:" from "_FROM) 130 ; Date Range - Until 131 S UNTIL=$S($G(UNTIL)="":"",1:" to "_UNTIL) 132 S FLT=FLT_$G(FROM)_$G(UNTIL) 133 ; If No Filter. Then get All. 134 I FLT="" S FLT="All Images" 135 Q FLT 136 REVDT(FROM,UNTIL,DAT1,DAT2) ; Calculate the Reverse Dates and switch for $O 137 ; for $O( through a data cross reference that is reversed, i.e. X=9999999.9999-DT 138 ; FROM = Date in External or Internal 139 ; UNTIL = Date in External or Internal 140 ; DAT1 = Reverse the two dates, FROM and UNTIL, equal to the earliest 141 ; DAT2 = Reverse the two dates, FROM and UNTIL, equal to the latest 142 ; 143 S DAT1=$$E2I^MAGSIXGT($G(FROM)) 144 S DAT2=$$E2I^MAGSIXGT($G(UNTIL)) 145 I 'DAT2 S DAT2=9999999.9999 146 S DAT1=9999999.9999-DAT1 147 S DAT2=9999999.9999-DAT2 148 I DAT1]DAT2 S X=DAT1,DAT1=DAT2,DAT2=X 149 S DAT1=DAT1\1,$P(DAT2,".",2)="9999" 150 Q -
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGSIXGT.m
r613 r623 1 MAGSIXGT 2 ;;3.0;IMAGING;**8,48,61,59**;Nov 27, 2007;Build 20 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 13 14 15 16 17 18 19 20 IGT(OUT,CLS,FLGS) 21 22 23 24 25 26 27 28 29 30 31 S CLS=$G(CLS),FLGS=$P($G(FLGS),"|")32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 IGE(OUT,CLS,SPEC,FLGS) 60 61 62 63 64 65 66 67 68 69 70 71 S CLS=$G(CLS),SPEC=$G(SPEC),FLGS=$P($G(FLGS),"|")72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 IGS(OUT,CLS,EVENT,FLGS) 107 108 109 110 111 112 113 114 115 116 117 118 S CLS=$G(CLS),EVENT=$G(EVENT),FLGS=$P($G(FLGS),"|")119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 PKG 163 164 165 166 ORIGIN 167 168 169 170 171 172 173 174 CLS 175 176 177 178 179 180 181 182 EVENT 183 184 185 186 187 188 189 190 SPEC 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 TYPE 207 208 209 210 211 212 213 214 GETSPECS(LOC,INCL,INST,INSP) 215 216 217 218 219 220 221 222 223 224 225 226 227 D2(N) 228 229 E2I(D) 230 231 232 233 1 MAGSIXGT ;WOIFO/EdM/GEK/SEB - RPC for Document Imaging ; 04/29/2002 16:15 2 ;;3.0;IMAGING;**8,48,61**;Feb 07, 2006 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 Q 19 ; 20 IGT(OUT,CLS,FLGS) ;RPC [MAG4 INDEX GET TYPE] 21 ; OUT : the result array 22 ; CLS : a ',' separated list of Classes. 23 ; FLGS : An '^' delimited string 24 ; 1 IGN : Flag to IGNore the Status field 25 ; 2 INCL : Include Class in the Output string 26 ; 3 INST : Include Status in the Output String 27 ; 28 N C,D0,LOC,N,OK,X,NODE,IGN 29 N MAGX 30 K OUT 31 S CLS=$G(CLS),FLGS=$G(FLGS) 32 ; Capture app will send CLS as ADMIN,ADMIN/CLIN for admin 33 ; or CLIN,CLIN/ADMIN for clinical 34 ; 61 - We're expanding CLASS returned to include ALL Clin 35 ; or all Admin 36 I CLS="ADMIN,ADMIN/CLIN" S CLS="ADMIN,ADMIN/CLIN,CLIN/ADMIN" 37 I CLS="CLIN,CLIN/ADMIN" S CLS="CLIN,CLIN/ADMIN,ADMIN/CLIN" 38 S IGN=$P(FLGS,"^",1),INCL=$P(FLGS,"^",2),INST=$P(FLGS,"^",3) 39 D CLS Q:$D(OUT(0)) 40 ; 41 S N=1 42 S D0=0 F S D0=$O(^MAG(2005.83,D0)) Q:'D0 D 43 . S X=$G(^MAG(2005.83,D0,0)),C=$P(X,"^",2) 44 . ; if Class not null, check it. Null classes will be listed in output. 45 . I CLS'="" Q:C="" Q:'$D(OK(1,C)) 46 . I 'IGN Q:$P(X,"^",3)="I" ; This is the Status field inactive Flag; 47 . S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.83,D0,1)),"^",1) 48 . I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.83,D0,1,"MAGX") 49 . I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.83,D0,2,"MAGX") 50 . S LOC(NODE_"|"_D0)="" 51 . Q 52 S X="" F S X=$O(LOC(X)) Q:X="" S N=N+1,OUT(N)=X 53 I N<2 S OUT(0)="0^-3, No Types Found for """_CLS_"""." Q 54 S OUT(0)="1^OK: "_N 55 S OUT(1)=CLS_" Image Types^Abbr" 56 I INCL S OUT(1)=OUT(1)_"^Class" 57 I INST S OUT(1)=OUT(1)_"^Status" 58 Q 59 IGE(OUT,CLS,SPEC,FLGS) ;RPC [MAG4 INDEX GET EVENT] 60 ; Index Get Procedure/Event (optionally based on (Sub)Specialty) 61 ; OUT : the result array 62 ; CLS : a ',' separated list of Classes. 63 ; SPEC : a ',' separated list of Spec/Subspecialties 64 ; FLGS : An '^' delimited string 65 ; - IGN [1|0] : Flag to IGNore the Status field 66 ; - INCL [1|0] : Include Class in the Output string 67 ; - INST [1|0] : Include Status in the Output String 68 ; 69 N C,D0,D1,LOC,N,NO,OK,S,X,NODE 70 K OUT 71 S CLS=$G(CLS),SPEC=$G(SPEC),FLGS=$G(FLGS) 72 S IGN=$P(FLGS,"^",1),INCL=$P(FLGS,"^",2),INST=$P(FLGS,"^",3) 73 D CLS Q:$D(OUT(0)) 74 D SPEC Q:$D(OUT(0)) 75 ; 76 S N=1 77 S D0=0 F S D0=$O(^MAG(2005.85,D0)) Q:'D0 D 78 . S X=$G(^MAG(2005.85,D0,0)),C=$P(X,"^",2) 79 . ; if Class not null, check it. Null classes will be listed in output. 80 . I CLS'="" Q:C="" Q:'$D(OK(1,C)) 81 . I 'IGN Q:$P(X,"^",3)="I" ;This is the Status field inactive Flag; 82 . ; if Specialty not null, check it. Null Specialties will be listed in output. 83 . I SPEC'="" D Q:NO 84 . . S NO=0 85 . . ; Next line: put "S:'D1 NO=1" before the quit to block implicit mapping 86 . . S D1=0 F S D1=$O(^MAG(2005.85,D0,1,D1)) Q:'D1 D Q:'NO 87 . . . S NO=1 88 . . . S S=$P($G(^MAG(2005.85,D0,1,D1,0)),"^",1) 89 . . . Q:S="" 90 . . . S:$D(OK(3,S)) NO=0 91 . . . Q 92 . . Q 93 . S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.85,D0,2)),"^",1) 94 . I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.85,D0,1,"MAGX") 95 . I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.85,D0,4,"MAGX") 96 . S LOC(NODE_"|"_D0)="" 97 . Q 98 S X="" F S X=$O(LOC(X)) Q:X="" S N=N+1,OUT(N)=X 99 I N<2 S OUT(0)="0^No Procedures or Events found for """_CLS_""" and """_SPEC_"""." Q 100 S OUT(0)="1^OK: "_N 101 S OUT(1)="Procedure/Event^Abbr" 102 I INCL S OUT(1)=OUT(1)_"^Class" 103 I INST S OUT(1)=OUT(1)_"^Status" 104 Q 105 ; 106 IGS(OUT,CLS,EVENT,FLGS) ;RPC [MAG4 INDEX GET SPECIALTY] 107 ; OUT : the result array 108 ; CLS : a ',' separated list of Classes. 109 ; EVENT : a ',' separated list of Proc/Events 110 ; FLGS : An '^' delimited string 111 ; - IGN [1|0] : Flag to IGNore the Status field 112 ; - INCL [1|0] : Include Class in the Output string 113 ; - INST [1|0] : Include Status in the Output String 114 ; - INSP [1|0] : Include Specialty in the OutPut String 115 ; 116 N C,D0,D1,E,LOC,N,OK,X 117 K OUT 118 S CLS=$G(CLS),EVENT=$G(EVENT),FLGS=$G(FLGS) 119 S IGN=$P(FLGS,"^",1),INCL=$P(FLGS,"^",2),INST=$P(FLGS,"^",3),INSP=$P(FLGS,"^",4) 120 I CLS'="" D CLS Q:$D(OUT(0)) 121 I EVENT'="" D EVENT Q:$D(OUT(0)) 122 ; 123 S N=1 124 I EVENT="" S D0=0 F S D0=$O(^MAG(2005.84,D0)) Q:'D0 D 125 . S X=$G(^MAG(2005.84,D0,0)),C=$P(X,"^",2) ;,E=$P(X,"^",3) 126 . ; if Class not null, check it. Null classes will be listed in output. 127 . I CLS'="" Q:C="" Q:'$D(OK(1,C)) 128 . I 'IGN Q:$P(X,"^",4)="I" ; This is the Status field inactive Flag; 129 . ;I EVENT'="" Q:E="" Q:'$D(OK(2,E)) 130 . S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.84,D0,2)),"^",1) 131 . I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,1,"MAGX") 132 . I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,4,"MAGX") 133 . I INSP S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,2,"MAGX") 134 . S LOC(NODE_"|"_D0)="" 135 . Q 136 I EVENT]"" S E="" F S E=$O(OK(2,E)) Q:E="" D 137 . ; if Class isn't null, include image if Class matches; 138 . ; images with Null classes will be listed in output. 139 . I CLS'="" S C=$P($G(^MAG(2005.85,E,0)),"^",2) Q:'$D(OK(1,C)) 140 . ; if this procedure has specialty pointers, include it if they matches. 141 . ; images with Proc/Event 142 . I +$P($G(^MAG(2005.85,E,1,0)),U,3)=0 D GETSPECS(.LOC,INCL,INST,INSP) 143 . S D0="0" F S D0=$O(^MAG(2005.85,E,1,D0)) Q:D0="" D 144 . . S D1=$G(^MAG(2005.85,E,1,D0,0)) I D1="" Q 145 . . S X=$G(^MAG(2005.84,D1,0)) 146 . . I '(X]"") Q 147 . . S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.84,D1,2)),"^",1) 148 . . I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D1,1,"MAGX") 149 . . I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D1,4,"MAGX") 150 . . I INSP S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D1,2,"MAGX") 151 . . S LOC(NODE_"|"_D1)="" 152 . Q 153 S X="" F S X=$O(LOC(X)) Q:X="" S N=N+1,OUT(N)=X 154 I N<2 S OUT(0)="0^-5, No (Sub)Specialties found for """_CLS_""" and """_EVENT_"""." Q 155 S OUT(0)="1^OK: "_N 156 S OUT(1)="Specialty/SubSpecialty^Abbr" 157 I INCL S OUT(1)=OUT(1)_"^Class" 158 I INST S OUT(1)=OUT(1)_"^Status" 159 I INSP S OUT(1)=OUT(1)_"^Specialty" 160 Q 161 ; 162 PKG N P,I 163 I $G(PKG)="" Q 164 F I=1:1:$L(PKG,",") I $L($P(PKG,",",I)) S OK(5,$P(PKG,",",I))="" 165 Q 166 ORIGIN N I 167 N V,MAGR,MAGD,MAGE 168 I $G(ORIGIN)="" Q 169 ; P48T1 Allow Internal or External for Origin (set of codes) 170 F I=1:1:$L(ORIGIN,",") I $L($P(ORIGIN,",",I)) S OK(6,$P(ORIGIN,",",I))="" D 171 . S MAGD=$P(ORIGIN,",",I) 172 . D CHK^DIE(2005,45,"E",MAGD,.MAGR) I MAGR'="^" S OK(6,MAGR)="",OK(6,MAGR(0))="" 173 Q 174 CLS N C,CLSX,I 175 I $G(CLS)="" Q 176 F I=1:1:$L(CLS,",") I $L($P(CLS,",",I)) S CLSX=$P(CLS,",",I) D 177 . I CLSX=+CLSX,$D(^MAG(2005.82,CLSX)) S OK(1,CLSX)="" 178 . S C="" F S C=$O(^MAG(2005.82,"B",CLSX,C)) Q:C="" S OK(1,C)="" 179 I $O(OK(1,""))="" S OUT(0)="0^Invalid Class: """_CLS_"""." Q 180 Q 181 ; 182 EVENT N E,EVENTX,I 183 I $G(EVENT)="" Q 184 F I=1:1:$L(EVENT,",") I $L($P(EVENT,",",I)) S EVENTX=$P(EVENT,",",I) D 185 . I EVENTX=+EVENTX,$D(^MAG(2005.85,EVENTX)) S OK(2,EVENTX)="" 186 . S E="" F S E=$O(^MAG(2005.85,"B",EVENTX,E)) Q:E="" S OK(2,E)="" 187 I $O(OK(2,""))="" S OUT(0)="0^Invalid Event: """_EVENT_"""." Q 188 Q 189 ; 190 SPEC N S,SS,SPECX,I 191 I $G(SPEC)="" Q 192 ; Here we examine each piece of Spec, If piece is a Specialty, include 193 ; its subspecialties. 194 ; 195 F I=1:1:$L(SPEC,",") I $L($P(SPEC,",",I)) S SPECX=$P(SPEC,",",I) D 196 . I SPECX=+SPECX,$D(^MAG(2005.84,SPECX)) S OK(3,SPECX)="" 197 . S S="" F S S=$O(^MAG(2005.84,"B",SPECX,S)) Q:S="" S OK(3,S)="" 198 . Q 199 I $O(OK(3,""))="" S OUT(0)="0^Invalid Specialty: """_SPEC_"""." Q 200 I $D(MAGJOB("CAPTURE")) Q ; 59 for capture we don't want subspecs. 201 S S="" F S S=$O(OK(3,S)) Q:S="" I $D(^MAG(2005.84,"ASPEC",S)) D 202 . S SS="" F S SS=$O(^MAG(2005.84,"ASPEC",S,SS)) Q:SS="" S OK(3,SS)="" 203 . Q 204 Q 205 ; 206 TYPE N T,TYPEX,I 207 I $G(TYPE)="" Q 208 F I=1:1:$L(TYPE,",") I $L($P(TYPE,",",I)) S TYPEX=$P(TYPE,",",I) D 209 . I TYPEX=+TYPEX,$D(^MAG(2005.83,TYPEX)) S OK(4,TYPEX)="" 210 . S T="" F S T=$O(^MAG(2005.83,"B",TYPEX,T)) Q:T="" S OK(4,T)="" 211 I $O(OK(4,""))="" S OUT(0)="0^Invalid Type: """_TYPE_"""." Q 212 Q 213 ; 214 GETSPECS(LOC,INCL,INST,INSP) N D0,X,NODE 215 S D0=0 F S D0=$O(^MAG(2005.84,D0)) Q:'D0 D 216 . S X=$G(^MAG(2005.84,D0,0)) 217 . ;I X]"" S LOC($P(X,"^",1)_"^"_$P($G(^MAG(2005.84,D0,2)),"^",1)_"|"_D0)="" 218 . ;Q 219 . S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.84,D0,2)),"^",1) 220 . I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,1,"MAGX") 221 . I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,4,"MAGX") 222 . I INSP S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,2,"MAGX") 223 . S LOC(NODE_"|"_D0)="" 224 . Q 225 Q 226 ; 227 D2(N) Q $TR($J(N,2)," ",0) 228 ; 229 E2I(D) N %DT,X,Y 230 Q:$P(D,".",1)?7N D\1 231 Q:D="" 0 232 S X=D,%DT="TS" D ^%DT Q:Y<0 0 233 Q Y\1
Note:
See TracChangeset
for help on using the changeset viewer.
