MAGGTLB1 ;WOIFO/LB - RPC routine for Imaging Lab Interface ; [ 06/20/2001 08:56 ]
;;3.0;IMAGING;**59**;Nov 27, 2007;Build 20
;;Per VHA Directive 2004-038, this routine should not be modified.
;; +---------------------------------------------------------------+
;; | Property of the US Government. |
;; | No permission to copy or redistribute this software is given. |
;; | Use of unreleased versions of this software requires the user |
;; | to execute a written test agreement with the VistA Imaging |
;; | Development Office of the Department of Veterans Affairs, |
;; | telephone (301) 734-0100. |
;; | The Food and Drug Administration classifies this software as |
;; | a medical device. As such, it may not be changed in any way. |
;; | Modifications to this software may result in an adulterated |
;; | medical device under 21CFR820, the use of which is considered |
;; | to be a violation of US Federal Statutes. |
;; +---------------------------------------------------------------+
;;
Q
;This routine is called from the Laboratory Image capture window.
;After an image is captured and an entry is created in file 2005,
;this routine will be called to set the imaging pointers in the
;corresponding Lab subfile (Autopsy/ Organism, Surgical Path, EM,
;or Cytology) and update the imaging file with the corresponding
;Lab pointers.
FILE(MAGRY,IMIEN,DATA) ;RPC Call to file pointers in Lab and Image files.
;IMIEN - ^MAG(2005,IMIEN image captured.
;DATA - piece 1 = stain piece 2 = micro obj
; 3 = Pt name 4 = ssn
; 5 = date/time 6 = acc#
; 7 = Pathologist 8 = specimen desc.
; 9 = lab section 10 = dfn
; 11 = lrdfn 12 = lri
; 13 = spec ien 14 = field#
; 15 = global root e.g. ^LR(1,"SP",7069758,1,1
;DATA is the result of START^MAGGTLB (the specimen variable during the
;image capture window).
;Will return a single value on filing success.
;
IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR"
E S X="ERR^MAGGTERR",@^%ZOSF("TRAP")
;
N ANUM,DA,DA1,DAS,DFN,DIERR,FIELD,I,IMOBJ,LABD,LABFDA,LABIEN,LABIENS
N LRDFN,LRI,MAGFDA,MAGIEN,MAGNODE,OUT,SECT,SECTLTR,SPEC,SPECD
N SSUBFILE,SSUBFL,STAIN,SUBFILE,X,Y
S MAGRY="0^Started filing",MAGIEN=IMIEN
S SECT=$P(DATA,"^",9),DFN=$P(DATA,"^",10),LRDFN=$P(DATA,"^",11)
S LRI=$P(DATA,"^",12)
S SPEC=$P(DATA,"^",13),FIELD=$P(DATA,"^",14)
S MAGNODE="^"_$P(DATA,"^",15,99),ANUM=$P(DATA,"^",6)
S SPECD=$P(DATA,"^",8),STAIN=$P(DATA,"^",1),IMOBJ=$P(DATA,"^",2)
I SECT["~" S SECT=$P(SECT,"~",1)
;Check for valid image
I '$D(^MAG(2005,MAGIEN,0)) D Q
. S Y(0)="0^Image entry does not exist."
;Check for valid image patient entry.
I $P(^MAG(2005,MAGIEN,0),"^",7)'=DFN D Q
. S MAGRY="0^Image patient does not match Lab patient."
;Check if parent file and corresponding fields are filed in file 2005.
I $D(^MAG(2005,MAGIEN,2)) S X=^MAG(2005,MAGIEN,2) D Q:OUT
. S OUT=0
. I $P(X,"^",6),$P(X,"^",7),$P(X,"^",8) S OUT=1
. I OUT S MAGRY="0^Report already exist for this image."
;Check the Lab entries...do they still exists.
S MAGNODE=MAGNODE_",0)"
I '$D(@MAGNODE) S MAGRY="0^Specimen no longer in Lab file." Q
;Everything seem okay lets file image pointer in lab file.
S SECTLTR=$S(SECT=63:"AY",SECT=63.2:"AY",1:$P(^MAG(2005.03,SECT,0),"^",2))
;Lab nodes; AY, SP, EM or CY.
;
LAB2 ;updating files using silent Fileman DB calls.
N MAGERR,MAGLVL
S SUBFILE=$S(SECT=63:63.2,1:SECT)
S MAGRY="0^Lab's Imaging subfile doesn't exisit." ;default
;Laboratory's Autopsy subfile has two imaging fields (2005 & 2005.1)
; and file 2005.03 does not reflect this.
D FIELD^DID(SUBFILE,FIELD,"","SPECIFIER","MAGLVL","MAGERR")
I $D(MAGERR("DIERR")) Q
I '$D(MAGLVL("SPECIFIER")) Q
S SSUBFL=$G(MAGLVL("SPECIFIER")) ;Lab's Imaging subfile
I SSUBFL="" Q
;Image sub-subfile.
S SSUBFILE="" F I=1:1:$L(SSUBFL) D
. I $E(SSUBFL,I)?1N!($E(SSUBFL,I)?1".") S SSUBFILE=SSUBFILE_$E(SSUBFL,I)
. ;Leave off the alpha characters
S DA1=$S(SECTLTR="AY":SPEC,1:LRI) ;Autopsy is by specimen not date/time
S DAS="+3,"_DA1_","_LRDFN_","
;Sets the iens e.g. da,da(1),da(2). The +3 can be any #; it is the
;subscript of the return variable LABIENS.
;Returns IEN for that subfile & use of +3 is because it's 2 levels down.
S LABFDA(SSUBFILE,DAS,.01)=MAGIEN,LABIENS=""
D UPDATE^DIE("S","LABFDA","LABIENS")
I $D(DIERR) S MAGRY="O^Unsuccessful Lab updating." Q
I '$D(LABIENS(3)) S MAGRY="0^Unsuccessful Lab updating" Q
S DA=$G(LABIENS(3))
I 'DA!('$D(^LR(LRDFN,SECTLTR,DA1,FIELD,DA,0))) D Q
. S MAGRY="0^Unsuccessful Lab updating"
IMAGE2 ;
S MAGIEN=MAGIEN_",",LABIEN=DA,LABD=DA1 K DA,DA1
; The following fields are saved in the ADDIMAGE Call.
; 50 =ANUM ;ACCESSION NUMBER FIELD
; 51 =SPECD ;SPECIMEN DESCRIPTION FIELD
; 52 =SPEC ;SPECIMEN DO
; 53 =STAIN ;Histology stain
; 54 =IMOBJ ;MICROSCOPE OBJECTIVE
N DIK
S MAGFDA(2005,MAGIEN,16)=SECT ;LAB SECTION
S MAGFDA(2005,MAGIEN,17)=LRDFN ;PARENT FILE DO VALUE
S MAGFDA(2005,MAGIEN,18)=LABIEN ;LAB BACKWARD IMAGE POINTER
S MAGFDA(2005,MAGIEN,63)=LABD ;If AUTOPSY, it's specimen else date/time
S I=0 F I=$O(MAGFDA(2005,MAGIEN,I)) Q:'I D
. D UPDATE^DIE("S","MAGFDA","")
I $D(DIERR) S I=0 F S I=$O(MAGFDA(2005,MAGIEN,I)) Q:'I D
. S MAGFDA(2005,MAGIEN,I)="" D UPDATE^DIE("","MAGFDA","")
I $D(DIERR),$D(^LR(LRDFN,SECTLTR,DA1,FIELD,LABIEN,0)),$G(^LR(LRDFN,SECTLTR,DA1,FIELD,LABIEN,0))=MAGIEN D
. S DA(2)=LRDFN,DA(1)=DA1,DA=LABIEN
. S DIK="^LR("_LRDFN_","""_SECTLTR_""","_DA1_","_FIELD_","
. D ^DIK ;Remove imaging pointers from lab subfile.
I $D(DIERR) S MAGRY="0^Unsuccessful both files not updated." K DIERR Q
S MAGRY="1^Success in filing both parent & image files." K DIERR
D LINKDT^MAGGTU6(.X,+MAGIEN)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGGTLB1 6116 printed Apr 09, 2024@21:08:19 Page 2
MAGGTLB1 ;WOIFO/LB - RPC routine for Imaging Lab Interface ; [ 06/20/2001 08:56 ]
+1 ;;3.0;IMAGING;**59**;Nov 27, 2007;Build 20
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;; +---------------------------------------------------------------+
+4 ;; | Property of the US Government. |
+5 ;; | No permission to copy or redistribute this software is given. |
+6 ;; | Use of unreleased versions of this software requires the user |
+7 ;; | to execute a written test agreement with the VistA Imaging |
+8 ;; | Development Office of the Department of Veterans Affairs, |
+9 ;; | telephone (301) 734-0100. |
+10 ;; | The Food and Drug Administration classifies this software as |
+11 ;; | a medical device. As such, it may not be changed in any way. |
+12 ;; | Modifications to this software may result in an adulterated |
+13 ;; | medical device under 21CFR820, the use of which is considered |
+14 ;; | to be a violation of US Federal Statutes. |
+15 ;; +---------------------------------------------------------------+
+16 ;;
+17 QUIT
+18 ;This routine is called from the Laboratory Image capture window.
+19 ;After an image is captured and an entry is created in file 2005,
+20 ;this routine will be called to set the imaging pointers in the
+21 ;corresponding Lab subfile (Autopsy/ Organism, Surgical Path, EM,
+22 ;or Cytology) and update the imaging file with the corresponding
+23 ;Lab pointers.
FILE(MAGRY,IMIEN,DATA) ;RPC Call to file pointers in Lab and Image files.
+1 ;IMIEN - ^MAG(2005,IMIEN image captured.
+2 ;DATA - piece 1 = stain piece 2 = micro obj
+3 ; 3 = Pt name 4 = ssn
+4 ; 5 = date/time 6 = acc#
+5 ; 7 = Pathologist 8 = specimen desc.
+6 ; 9 = lab section 10 = dfn
+7 ; 11 = lrdfn 12 = lri
+8 ; 13 = spec ien 14 = field#
+9 ; 15 = global root e.g. ^LR(1,"SP",7069758,1,1
+10 ;DATA is the result of START^MAGGTLB (the specimen variable during the
+11 ;image capture window).
+12 ;Will return a single value on filing success.
+13 ;
+14 IF $$NEWERR^%ZTER
NEW $ETRAP,$ESTACK
SET $ETRAP="D ERR^MAGGTERR"
+15 IF '$TEST
SET X="ERR^MAGGTERR"
SET @^%ZOSF("TRAP")
+16 ;
+17 NEW ANUM,DA,DA1,DAS,DFN,DIERR,FIELD,I,IMOBJ,LABD,LABFDA,LABIEN,LABIENS
+18 NEW LRDFN,LRI,MAGFDA,MAGIEN,MAGNODE,OUT,SECT,SECTLTR,SPEC,SPECD
+19 NEW SSUBFILE,SSUBFL,STAIN,SUBFILE,X,Y
+20 SET MAGRY="0^Started filing"
SET MAGIEN=IMIEN
+21 SET SECT=$PIECE(DATA,"^",9)
SET DFN=$PIECE(DATA,"^",10)
SET LRDFN=$PIECE(DATA,"^",11)
+22 SET LRI=$PIECE(DATA,"^",12)
+23 SET SPEC=$PIECE(DATA,"^",13)
SET FIELD=$PIECE(DATA,"^",14)
+24 SET MAGNODE="^"_$PIECE(DATA,"^",15,99)
SET ANUM=$PIECE(DATA,"^",6)
+25 SET SPECD=$PIECE(DATA,"^",8)
SET STAIN=$PIECE(DATA,"^",1)
SET IMOBJ=$PIECE(DATA,"^",2)
+26 IF SECT["~"
SET SECT=$PIECE(SECT,"~",1)
+27 ;Check for valid image
+28 IF '$DATA(^MAG(2005,MAGIEN,0))
Begin DoDot:1
+29 SET Y(0)="0^Image entry does not exist."
End DoDot:1
QUIT
+30 ;Check for valid image patient entry.
+31 IF $PIECE(^MAG(2005,MAGIEN,0),"^",7)'=DFN
Begin DoDot:1
+32 SET MAGRY="0^Image patient does not match Lab patient."
End DoDot:1
QUIT
+33 ;Check if parent file and corresponding fields are filed in file 2005.
+34 IF $DATA(^MAG(2005,MAGIEN,2))
SET X=^MAG(2005,MAGIEN,2)
Begin DoDot:1
+35 SET OUT=0
+36 IF $PIECE(X,"^",6)
IF $PIECE(X,"^",7)
IF $PIECE(X,"^",8)
SET OUT=1
+37 IF OUT
SET MAGRY="0^Report already exist for this image."
End DoDot:1
if OUT
QUIT
+38 ;Check the Lab entries...do they still exists.
+39 SET MAGNODE=MAGNODE_",0)"
+40 IF '$DATA(@MAGNODE)
SET MAGRY="0^Specimen no longer in Lab file."
QUIT
+41 ;Everything seem okay lets file image pointer in lab file.
+42 SET SECTLTR=$SELECT(SECT=63:"AY",SECT=63.2:"AY",1:$PIECE(^MAG(2005.03,SECT,0),"^",2))
+43 ;Lab nodes; AY, SP, EM or CY.
+44 ;
LAB2 ;updating files using silent Fileman DB calls.
+1 NEW MAGERR,MAGLVL
+2 SET SUBFILE=$SELECT(SECT=63:63.2,1:SECT)
+3 ;default
SET MAGRY="0^Lab's Imaging subfile doesn't exisit."
+4 ;Laboratory's Autopsy subfile has two imaging fields (2005 & 2005.1)
+5 ; and file 2005.03 does not reflect this.
+6 DO FIELD^DID(SUBFILE,FIELD,"","SPECIFIER","MAGLVL","MAGERR")
+7 IF $DATA(MAGERR("DIERR"))
QUIT
+8 IF '$DATA(MAGLVL("SPECIFIER"))
QUIT
+9 ;Lab's Imaging subfile
SET SSUBFL=$GET(MAGLVL("SPECIFIER"))
+10 IF SSUBFL=""
QUIT
+11 ;Image sub-subfile.
+12 SET SSUBFILE=""
FOR I=1:1:$LENGTH(SSUBFL)
Begin DoDot:1
+13 IF $EXTRACT(SSUBFL,I)?1N!($EXTRACT(SSUBFL,I)?1".")
SET SSUBFILE=SSUBFILE_$EXTRACT(SSUBFL,I)
+14 ;Leave off the alpha characters
End DoDot:1
+15 ;Autopsy is by specimen not date/time
SET DA1=$SELECT(SECTLTR="AY":SPEC,1:LRI)
+16 SET DAS="+3,"_DA1_","_LRDFN_","
+17 ;Sets the iens e.g. da,da(1),da(2). The +3 can be any #; it is the
+18 ;subscript of the return variable LABIENS.
+19 ;Returns IEN for that subfile & use of +3 is because it's 2 levels down.
+20 SET LABFDA(SSUBFILE,DAS,.01)=MAGIEN
SET LABIENS=""
+21 DO UPDATE^DIE("S","LABFDA","LABIENS")
+22 IF $DATA(DIERR)
SET MAGRY="O^Unsuccessful Lab updating."
QUIT
+23 IF '$DATA(LABIENS(3))
SET MAGRY="0^Unsuccessful Lab updating"
QUIT
+24 SET DA=$GET(LABIENS(3))
+25 IF 'DA!('$DATA(^LR(LRDFN,SECTLTR,DA1,FIELD,DA,0)))
Begin DoDot:1
+26 SET MAGRY="0^Unsuccessful Lab updating"
End DoDot:1
QUIT
IMAGE2 ;
+1 SET MAGIEN=MAGIEN_","
SET LABIEN=DA
SET LABD=DA1
KILL DA,DA1
+2 ; The following fields are saved in the ADDIMAGE Call.
+3 ; 50 =ANUM ;ACCESSION NUMBER FIELD
+4 ; 51 =SPECD ;SPECIMEN DESCRIPTION FIELD
+5 ; 52 =SPEC ;SPECIMEN DO
+6 ; 53 =STAIN ;Histology stain
+7 ; 54 =IMOBJ ;MICROSCOPE OBJECTIVE
+8 NEW DIK
+9 ;LAB SECTION
SET MAGFDA(2005,MAGIEN,16)=SECT
+10 ;PARENT FILE DO VALUE
SET MAGFDA(2005,MAGIEN,17)=LRDFN
+11 ;LAB BACKWARD IMAGE POINTER
SET MAGFDA(2005,MAGIEN,18)=LABIEN
+12 ;If AUTOPSY, it's specimen else date/time
SET MAGFDA(2005,MAGIEN,63)=LABD
+13 SET I=0
FOR I=$ORDER(MAGFDA(2005,MAGIEN,I))
if 'I
QUIT
Begin DoDot:1
+14 DO UPDATE^DIE("S","MAGFDA","")
End DoDot:1
+15 IF $DATA(DIERR)
SET I=0
FOR
SET I=$ORDER(MAGFDA(2005,MAGIEN,I))
if 'I
QUIT
Begin DoDot:1
+16 SET MAGFDA(2005,MAGIEN,I)=""
DO UPDATE^DIE("","MAGFDA","")
End DoDot:1
+17 IF $DATA(DIERR)
IF $DATA(^LR(LRDFN,SECTLTR,DA1,FIELD,LABIEN,0))
IF $GET(^LR(LRDFN,SECTLTR,DA1,FIELD,LABIEN,0))=MAGIEN
Begin DoDot:1
+18 SET DA(2)=LRDFN
SET DA(1)=DA1
SET DA=LABIEN
+19 SET DIK="^LR("_LRDFN_","""_SECTLTR_""","_DA1_","_FIELD_","
+20 ;Remove imaging pointers from lab subfile.
DO ^DIK
End DoDot:1
+21 IF $DATA(DIERR)
SET MAGRY="0^Unsuccessful both files not updated."
KILL DIERR
QUIT
+22 SET MAGRY="1^Success in filing both parent & image files."
KILL DIERR
+23 DO LINKDT^MAGGTU6(.X,+MAGIEN)
+24 QUIT
