MAGGTLB1.m

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 ---MAGGTLB1   6116     printed  Apr 23, 2025@18:17:38                                                                                                                                                                                                    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