MAGGTLB ;WOIFO/LB/MKN - RPC call for Laboratory/Imaging interface ; Mar 22, 2023@11:33:23
;;3.0;IMAGING;**48,72,343**;Mar 19, 2002;Build 2
;; Per VA Directive 6402, 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.
;The line tag SECT is used for selection of the Laboratory section.
;The line tag STAIN is used for selection of Histological stain.
;The line tag MICRO is used for selection of Microscopic Objective.
;The line tag START is used for selection of the specimen that the image
;relates to. This line tag will require a lab section (Autopsy/
;Gross, Autopsy/Microscopic, EM, Surgical Path, or Cytology),
;the Accession year, and either an Accession # or Autopsy #. Based on
;this information it will return an array of specimens for selection.
;
START(MAGRY,SECT,YR,ACNUM,DFN) ;RPC Call to Return a list of specimens
; -Removed DFN (XXX) -no longer being used for lookup
; -P343 added DFN back following decision by users to only show
; records where lab data shows file #2, not file #67
;SECT = Lab entry from 2005.03
;YR = 4 digits of year (1700-2000's)
;ACNUM = Accession number or autopsy number
;DFN = IEN in the PATIENT file (#2)
;Returns an array of specimens for the year_accession#.
;MAGRY(#)=Piece 1 = Pt Name piece 2 = Ssn
; 3 = Date/Time 4 = Accn #
; 5 = Pathologist 6 = Specimen
; 7 = Ien for file 2005.03 8 = Dfn
; 9 = Lrdfn 10 = Ien for date/time
; 11 = Ien specimen 12 = Lab section subfile
; imaging field number
; 13 = LR global being referenced
;the MAGRY(0)=0 or # lines in array^status (success or no success)
;the MAGRY(1)=titles for the grid array
N X,Y,YEAR
IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR"
E S X="ERRA^MAGGTERR",@^%ZOSF("TRAP")
S MAGRY(0)="0^No Data",DATA=0
S MAGRY(1)="Name^SSN^Date/Time^Acc #^Pathologist^Specimen"
N CNT,NUM,DATE,ANUM,NUM,DATA,LRDFN,LRI,LINE,MAGI,DATE,PATH,SPEC,MAGABV
N MAGNODE,MAGSSN,PAT,MAGSECT,FILE,DATA,MAGDFN,MAGNM,MAGX,X0
S DATA=0
S LINE=2
S MAGRY(0)="0^No specimen information found, please enter via DHCP Lab application"
I '$G(SECT)!('$G(ACNUM))!($L(YR)'=4) D Q
. S MAGRY(0)="0^Incorrect variables sent"
S MAGABV=$P(SECT,"~",2),SECT=$P(SECT,"~")
Q:'$D(^MAG(2005.03,SECT,0))
S MAGSECT=$P(^MAG(2005.03,SECT,0),"^"),MAGI=$E($P(^(0),"^",2),1)
S MAGNODE=$S(MAGI="S":"SP",MAGI="E":"EM",MAGI="C":"CY",1:"AU")
S MAGX="A"_MAGNODE_"A"
;Xref to search accession year and accession/autopsy #.
I YR<1700 S MAGRY(0)="0^=Invalid year provided" Q
S YEAR=YR,YR=YEAR-1700
;2001-1700 =301 Fileman internal & YR2K compliance
;Checked with Lab developers, still setting 3digit year in xref
;S YR=$S(YR>1999:3_$E(YR,3,4),1:2_$E(YR,3,4)) ;CODE FOR YRS >1999
;Checking MUMPs x-ref which can not be done via FM DB silent calls.
I '$D(^LR(MAGX,YR,MAGABV,ACNUM)) D Q
. S MAGRY(0)="0^Accession number "_MAGABV_" "_YEAR_" "_ACNUM_" is invalid"
. ;No data for the year accession #
S LRDFN=$O(^LR(MAGX,YR,MAGABV,ACNUM,0)),LRI=$O(^(LRDFN,0))
S MAGDFN=$P(^LR(LRDFN,0),"^",3),FILE=$P(^LR(LRDFN,0),"^",2)
S (MAGNM,MAGSSN)=""
;Start mods p343 - lookup on DFN reintroduced
Q:FILE'=2
S X=^DPT(MAGDFN,0),MAGNM=$P(X,"^"),MAGSSN=$P(X,"^",9) ;Patient file
Q:DFN'=MAGDFN
;I FILE[67 D Q:MAGNM=""
;. D GETS^DIQ(67,MAGDFN,".01;.09","E","MAGZZ","MAGERR")
;. I $D(MAGERR("DIERR")) S MAGRY(0)="0^Patient lookup failed" Q
;. S MAGNM=$G(MAGZZ(67,MAGDFN_",",".01","E"))
;. S MAGSSN=$G(MAGZZ(67,MAGDFN_",",".09","E"))
;End mods p343
I "ASCE"'[MAGI Q ;Not a valid lab section (Autopsy,Surgical Path, Cytology or EM)
S MAGNODE=$S(MAGI="S":"SP",MAGI="E":"EM",MAGI="C":"CY",1:"AY")
G:MAGNODE="AY" AUTOPSY ;Need this because 2005.03 does not reference the right node.
Q:'$D(^LR(LRDFN,MAGNODE,LRI,0))
S X0=^LR(LRDFN,MAGNODE,LRI,0),PATH=$P(X0,"^",2),NUM=$P(X0,"^",6)
S DATE=$P(X0,"^",1),ANUM=NUM
LOOK ;
S PATH=$S('PATH:"UNKNOWN",1:$$GET1^DIQ(200,PATH_",",.01))
S YEAR=$E(DATE,1,3)+1700 ;4 digit year
; YR2K Compliance 301+1700=2001
S DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_YEAR
S X=0 F S X=$O(^LR(LRDFN,MAGNODE,LRI,.1,X)) Q:'X D
. S SPEC=$P($G(^LR(LRDFN,MAGNODE,LRI,.1,X,0)),"^")
. S MAGRY(LINE)=MAGNM_"^"_MAGSSN_"^"_DATE_"^"_ANUM_"^"_PATH_"^"_SPEC_"^"_SECT_"^"_MAGDFN_"^"_LRDFN_"^"_LRI_"^"_X_"^"_"2005"_"^"_"LR("_LRDFN_","""_MAGNODE_""","_LRI_",.1,"_X
. S DATA=1,LINE=LINE+1
I DATA S MAGRY(0)=(LINE-2)_"^"_"DATA FOUND"
Q
AUTOPSY ;
N MAGERR,MAGRYLN,MAGZZ,XX
S (MAGERR,MAGZZ)=""
S X0=^LR(LRDFN,"AU"),DATE=$P(X0,"^"),NUM=$P(X0,"^",6)
S PATH=$P(X0,"^",7),ANUM=NUM
S PATH=$S('PATH:"UNKNOWN",1:$$GET1^DIQ(200,PATH_",",.01))
; DATE in line below, was DATA ( DATA was a misprint ) GEK
S YEAR=$E(DATE,1,3)+1700 ;4 digit year
; YR2K compliance 301+1700= 2001
S DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_YEAR
S XX=0 F S XX=$O(^LR(LRDFN,MAGNODE,XX)) Q:'XX D
. Q:'$D(^LR(LRDFN,MAGNODE,XX,0))
. S SPEC=$P(^LR(LRDFN,MAGNODE,XX,0),"^")
. D GETS^DIQ(61,SPEC,".01","E","MAGZZ","MAGERR")
. S SPEC=$S($D(MAGERR("DIERR")):"UNKNOWN",1:$G(MAGZZ(61,SPEC_",",".01","E")))
. S MAGRYLN=""
. S MAGRYLN=MAGNM_"^"_MAGSSN_"^"_DATE_"^"_ANUM_"^"_PATH_"^"_SPEC
. S MAGRYLN=MAGRYLN_"^"_SECT_"^"_MAGDFN_"^"_LRDFN_"^^"_XX
. S MAGRYLN=MAGRYLN_"^"_$S(MAGSECT["GROSS":2005,1:2005.1)
. S MAGRYLN=MAGRYLN_"^"_"LR("_LRDFN_","""_MAGNODE_""","_XX
. S MAGRY(LINE)=MAGRYLN
. S DATA=1,LINE=LINE+1
I DATA S MAGRY(0)=(LINE-2)_"^"_"DATA FOUND"
I 'DATA S MAGRY(0)="0^No organ/tissue defined for this autopsy."
;If MAGSECT[ "GROSS" then the field # is 2005 for subfile 63.2
;else the field # is 2005.1 for the same subfile (AUTOPSY ORGAN/TISSUE).
Q
STAIN(MAGRY) ;RPC Call to return array of entries from
; file 2005.4, Image Histological Stain.
;
S MAGRY(0)="0^No Entries found for file 2005.4"
Q:'$D(^MAG(2005.4,0)) ;Imaging file not defined.
N ENTRY,CNT,DATA,BLANK
S ENTRY=0,CNT=1,DATA=0,$P(BLANK," ",30)=" "
F S ENTRY=$O(^MAG(2005.4,ENTRY)) Q:'ENTRY D
. Q:'$D(^MAG(2005.4,ENTRY,0)) S X=$P(^MAG(2005.4,ENTRY,0),"^")
. S MAGRY(CNT)=X_BLANK_"^"_X,CNT=CNT+1,DATA=1
I DATA S MAGRY(0)="1^DATA FOUND"_U_(CNT-1)
Q
MICRO(MAGRY) ;RPC Call to Return array of entries from
; file 2005.41, Microscopic Objective
S MAGRY(0)="0^No entries found for file 2005.41"
Q:'$D(^MAG(2005.41,0)) ;Imaging file not defined.
N ENTRY,CNT,DATA,BLANK
S ENTRY=0,CNT=1,DATA=0,$P(BLANK," ",30)=" "
F S ENTRY=$O(^MAG(2005.41,ENTRY)) Q:'ENTRY D
. Q:'$D(^MAG(2005.41,ENTRY,0)) S X=$P(^MAG(2005.41,ENTRY,0),"^")
. S MAGRY(CNT)=X_BLANK_"^"_X,CNT=CNT+1,DATA=1
I DATA S MAGRY(0)="1^DATA FOUND"_"^"_(CNT-1)
Q
SECT(MAGRY) ;RPC Call to Build Pathology selection
; from file 68 accordingly to user's division
;MAGRY - Returns array of lab section name, section abbreviation
; used in defining the accession number & xref lookup,
; as well as the IEN in Imaging Parent file.
N Y,A,B,BLANK,MAGABV,MAGERR,MAGIEN,MAGNM,MAGNNM,MAGSEC,MAGTYPE,DATA
IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR"
E S X="ERRA^MAGGTERR",@^%ZOSF("TRAP")
S MAGRY(0)="0^No entries found^0"
S MAGSEC="SPCYEMAU",(A,B)=0,$P(BLANK," ",30)="" D CK Q:MAGERR
F S A=$O(^LRO(68,A)) Q:'A D
. I MAGSEC[$P($G(^LRO(68,A,0)),"^",2),$P(^LRO(68,A,0),"^",2)]"""",$G(^LRO(68,A,3,+DUZ(2),0)) D
. . S MAGABV=$P(^LRO(68,A,0),"^",11) Q:MAGABV="" ;No abbreviation defined
. . S MAGTYPE=$P(^LRO(68,A,0),"^",2),MAGNM=$P(^LRO(68,A,0),"^")
. . Q:MAGSEC'[MAGTYPE D PARENT ;Must be pathology section.
. . S B=B+1,DATA=1,MAGRY(B)=MAGNM_BLANK_"^"_MAGIEN_"~"_MAGABV
I '$D(DATA) S MAGRY(0)="0^No entries found for your division^0" Q
I DATA S B=B+1,MAGRY(0)="1^Entries found^"_B
Q
CK ;Check for valid division.
S MAGERR=1
N MAGSITE,MAGER
S MAGSITE=+DUZ(2)
I 'MAGSITE D Q
. S MAGRY(0)="0^You don't have a division setup."
; gek/ change : ..."A",MAGSITE... to ..."","`"_MAGSITE...
I '$$FIND1^DIC(4,"","","`"_MAGSITE,"","","MAGER") D Q
. S MAGRY(0)="0^No division name found."
S MAGERR=0
Q
PARENT ;Set the corresponding parent file/subfile in ^MAG(2005.03,62:64.
S MAGIEN=$S(MAGTYPE="SP":63.08,MAGTYPE="EM":63.02,MAGTYPE="CY":63.09,1:63.2)
I MAGTYPE="AU" S MAGIEN=63.2,MAGNNM=MAGNM_" (GROSS)",B=B+1,MAGRY(B)=MAGNNM_BLANK_"^"_MAGIEN_"~"_MAGABV,MAGNNM="",MAGIEN=63,MAGNM=MAGNM_" (MICROSCOPIC)"
;Autopsy selection will have two selection (GROSS or MICROSCOPIC) and the parent file ^MAG(2005.03 has two entries (63 & 63.2).
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGGTLB 9729 printed Mar 25, 2026@15:27:42 Page 2
MAGGTLB ;WOIFO/LB/MKN - RPC call for Laboratory/Imaging interface ; Mar 22, 2023@11:33:23
+1 ;;3.0;IMAGING;**48,72,343**;Mar 19, 2002;Build 2
+2 ;; Per VA Directive 6402, 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 ;The line tag SECT is used for selection of the Laboratory section.
+20 ;The line tag STAIN is used for selection of Histological stain.
+21 ;The line tag MICRO is used for selection of Microscopic Objective.
+22 ;The line tag START is used for selection of the specimen that the image
+23 ;relates to. This line tag will require a lab section (Autopsy/
+24 ;Gross, Autopsy/Microscopic, EM, Surgical Path, or Cytology),
+25 ;the Accession year, and either an Accession # or Autopsy #. Based on
+26 ;this information it will return an array of specimens for selection.
+27 ;
START(MAGRY,SECT,YR,ACNUM,DFN) ;RPC Call to Return a list of specimens
+1 ; -Removed DFN (XXX) -no longer being used for lookup
+2 ; -P343 added DFN back following decision by users to only show
+3 ; records where lab data shows file #2, not file #67
+4 ;SECT = Lab entry from 2005.03
+5 ;YR = 4 digits of year (1700-2000's)
+6 ;ACNUM = Accession number or autopsy number
+7 ;DFN = IEN in the PATIENT file (#2)
+8 ;Returns an array of specimens for the year_accession#.
+9 ;MAGRY(#)=Piece 1 = Pt Name piece 2 = Ssn
+10 ; 3 = Date/Time 4 = Accn #
+11 ; 5 = Pathologist 6 = Specimen
+12 ; 7 = Ien for file 2005.03 8 = Dfn
+13 ; 9 = Lrdfn 10 = Ien for date/time
+14 ; 11 = Ien specimen 12 = Lab section subfile
+15 ; imaging field number
+16 ; 13 = LR global being referenced
+17 ;the MAGRY(0)=0 or # lines in array^status (success or no success)
+18 ;the MAGRY(1)=titles for the grid array
+19 NEW X,Y,YEAR
+20 IF $$NEWERR^%ZTER
NEW $ETRAP,$ESTACK
SET $ETRAP="D ERRA^MAGGTERR"
+21 IF '$TEST
SET X="ERRA^MAGGTERR"
SET @^%ZOSF("TRAP")
+22 SET MAGRY(0)="0^No Data"
SET DATA=0
+23 SET MAGRY(1)="Name^SSN^Date/Time^Acc #^Pathologist^Specimen"
+24 NEW CNT,NUM,DATE,ANUM,NUM,DATA,LRDFN,LRI,LINE,MAGI,DATE,PATH,SPEC,MAGABV
+25 NEW MAGNODE,MAGSSN,PAT,MAGSECT,FILE,DATA,MAGDFN,MAGNM,MAGX,X0
+26 SET DATA=0
+27 SET LINE=2
+28 SET MAGRY(0)="0^No specimen information found, please enter via DHCP Lab application"
+29 IF '$GET(SECT)!('$GET(ACNUM))!($LENGTH(YR)'=4)
Begin DoDot:1
+30 SET MAGRY(0)="0^Incorrect variables sent"
End DoDot:1
QUIT
+31 SET MAGABV=$PIECE(SECT,"~",2)
SET SECT=$PIECE(SECT,"~")
+32 if '$DATA(^MAG(2005.03,SECT,0))
QUIT
+33 SET MAGSECT=$PIECE(^MAG(2005.03,SECT,0),"^")
SET MAGI=$EXTRACT($PIECE(^(0),"^",2),1)
+34 SET MAGNODE=$SELECT(MAGI="S":"SP",MAGI="E":"EM",MAGI="C":"CY",1:"AU")
+35 SET MAGX="A"_MAGNODE_"A"
+36 ;Xref to search accession year and accession/autopsy #.
+37 IF YR<1700
SET MAGRY(0)="0^=Invalid year provided"
QUIT
+38 SET YEAR=YR
SET YR=YEAR-1700
+39 ;2001-1700 =301 Fileman internal & YR2K compliance
+40 ;Checked with Lab developers, still setting 3digit year in xref
+41 ;S YR=$S(YR>1999:3_$E(YR,3,4),1:2_$E(YR,3,4)) ;CODE FOR YRS >1999
+42 ;Checking MUMPs x-ref which can not be done via FM DB silent calls.
+43 IF '$DATA(^LR(MAGX,YR,MAGABV,ACNUM))
Begin DoDot:1
+44 SET MAGRY(0)="0^Accession number "_MAGABV_" "_YEAR_" "_ACNUM_" is invalid"
+45 ;No data for the year accession #
End DoDot:1
QUIT
+46 SET LRDFN=$ORDER(^LR(MAGX,YR,MAGABV,ACNUM,0))
SET LRI=$ORDER(^(LRDFN,0))
+47 SET MAGDFN=$PIECE(^LR(LRDFN,0),"^",3)
SET FILE=$PIECE(^LR(LRDFN,0),"^",2)
+48 SET (MAGNM,MAGSSN)=""
+49 ;Start mods p343 - lookup on DFN reintroduced
+50 if FILE'=2
QUIT
+51 ;Patient file
SET X=^DPT(MAGDFN,0)
SET MAGNM=$PIECE(X,"^")
SET MAGSSN=$PIECE(X,"^",9)
+52 if DFN'=MAGDFN
QUIT
+53 ;I FILE[67 D Q:MAGNM=""
+54 ;. D GETS^DIQ(67,MAGDFN,".01;.09","E","MAGZZ","MAGERR")
+55 ;. I $D(MAGERR("DIERR")) S MAGRY(0)="0^Patient lookup failed" Q
+56 ;. S MAGNM=$G(MAGZZ(67,MAGDFN_",",".01","E"))
+57 ;. S MAGSSN=$G(MAGZZ(67,MAGDFN_",",".09","E"))
+58 ;End mods p343
+59 ;Not a valid lab section (Autopsy,Surgical Path, Cytology or EM)
IF "ASCE"'[MAGI
QUIT
+60 SET MAGNODE=$SELECT(MAGI="S":"SP",MAGI="E":"EM",MAGI="C":"CY",1:"AY")
+61 ;Need this because 2005.03 does not reference the right node.
if MAGNODE="AY"
GOTO AUTOPSY
+62 if '$DATA(^LR(LRDFN,MAGNODE,LRI,0))
QUIT
+63 SET X0=^LR(LRDFN,MAGNODE,LRI,0)
SET PATH=$PIECE(X0,"^",2)
SET NUM=$PIECE(X0,"^",6)
+64 SET DATE=$PIECE(X0,"^",1)
SET ANUM=NUM
LOOK ;
+1 SET PATH=$SELECT('PATH:"UNKNOWN",1:$$GET1^DIQ(200,PATH_",",.01))
+2 ;4 digit year
SET YEAR=$EXTRACT(DATE,1,3)+1700
+3 ; YR2K Compliance 301+1700=2001
+4 SET DATE=$EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)_"/"_YEAR
+5 SET X=0
FOR
SET X=$ORDER(^LR(LRDFN,MAGNODE,LRI,.1,X))
if 'X
QUIT
Begin DoDot:1
+6 SET SPEC=$PIECE($GET(^LR(LRDFN,MAGNODE,LRI,.1,X,0)),"^")
+7 SET MAGRY(LINE)=MAGNM_"^"_MAGSSN_"^"_DATE_"^"_ANUM_"^"_PATH_"^"_SPEC_"^"_SECT_"^"_MAGDFN_"^"_LRDFN_"^"_LRI_"^"_X_"^"_"2005"_"^"_"LR("_LRDFN_","""_MAGNODE_""","_LRI_",.1,"_X
+8 SET DATA=1
SET LINE=LINE+1
End DoDot:1
+9 IF DATA
SET MAGRY(0)=(LINE-2)_"^"_"DATA FOUND"
+10 QUIT
AUTOPSY ;
+1 NEW MAGERR,MAGRYLN,MAGZZ,XX
+2 SET (MAGERR,MAGZZ)=""
+3 SET X0=^LR(LRDFN,"AU")
SET DATE=$PIECE(X0,"^")
SET NUM=$PIECE(X0,"^",6)
+4 SET PATH=$PIECE(X0,"^",7)
SET ANUM=NUM
+5 SET PATH=$SELECT('PATH:"UNKNOWN",1:$$GET1^DIQ(200,PATH_",",.01))
+6 ; DATE in line below, was DATA ( DATA was a misprint ) GEK
+7 ;4 digit year
SET YEAR=$EXTRACT(DATE,1,3)+1700
+8 ; YR2K compliance 301+1700= 2001
+9 SET DATE=$EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)_"/"_YEAR
+10 SET XX=0
FOR
SET XX=$ORDER(^LR(LRDFN,MAGNODE,XX))
if 'XX
QUIT
Begin DoDot:1
+11 if '$DATA(^LR(LRDFN,MAGNODE,XX,0))
QUIT
+12 SET SPEC=$PIECE(^LR(LRDFN,MAGNODE,XX,0),"^")
+13 DO GETS^DIQ(61,SPEC,".01","E","MAGZZ","MAGERR")
+14 SET SPEC=$SELECT($DATA(MAGERR("DIERR")):"UNKNOWN",1:$GET(MAGZZ(61,SPEC_",",".01","E")))
+15 SET MAGRYLN=""
+16 SET MAGRYLN=MAGNM_"^"_MAGSSN_"^"_DATE_"^"_ANUM_"^"_PATH_"^"_SPEC
+17 SET MAGRYLN=MAGRYLN_"^"_SECT_"^"_MAGDFN_"^"_LRDFN_"^^"_XX
+18 SET MAGRYLN=MAGRYLN_"^"_$SELECT(MAGSECT["GROSS":2005,1:2005.1)
+19 SET MAGRYLN=MAGRYLN_"^"_"LR("_LRDFN_","""_MAGNODE_""","_XX
+20 SET MAGRY(LINE)=MAGRYLN
+21 SET DATA=1
SET LINE=LINE+1
End DoDot:1
+22 IF DATA
SET MAGRY(0)=(LINE-2)_"^"_"DATA FOUND"
+23 IF 'DATA
SET MAGRY(0)="0^No organ/tissue defined for this autopsy."
+24 ;If MAGSECT[ "GROSS" then the field # is 2005 for subfile 63.2
+25 ;else the field # is 2005.1 for the same subfile (AUTOPSY ORGAN/TISSUE).
+26 QUIT
STAIN(MAGRY) ;RPC Call to return array of entries from
+1 ; file 2005.4, Image Histological Stain.
+2 ;
+3 SET MAGRY(0)="0^No Entries found for file 2005.4"
+4 ;Imaging file not defined.
if '$DATA(^MAG(2005.4,0))
QUIT
+5 NEW ENTRY,CNT,DATA,BLANK
+6 SET ENTRY=0
SET CNT=1
SET DATA=0
SET $PIECE(BLANK," ",30)=" "
+7 FOR
SET ENTRY=$ORDER(^MAG(2005.4,ENTRY))
if 'ENTRY
QUIT
Begin DoDot:1
+8 if '$DATA(^MAG(2005.4,ENTRY,0))
QUIT
SET X=$PIECE(^MAG(2005.4,ENTRY,0),"^")
+9 SET MAGRY(CNT)=X_BLANK_"^"_X
SET CNT=CNT+1
SET DATA=1
End DoDot:1
+10 IF DATA
SET MAGRY(0)="1^DATA FOUND"_U_(CNT-1)
+11 QUIT
MICRO(MAGRY) ;RPC Call to Return array of entries from
+1 ; file 2005.41, Microscopic Objective
+2 SET MAGRY(0)="0^No entries found for file 2005.41"
+3 ;Imaging file not defined.
if '$DATA(^MAG(2005.41,0))
QUIT
+4 NEW ENTRY,CNT,DATA,BLANK
+5 SET ENTRY=0
SET CNT=1
SET DATA=0
SET $PIECE(BLANK," ",30)=" "
+6 FOR
SET ENTRY=$ORDER(^MAG(2005.41,ENTRY))
if 'ENTRY
QUIT
Begin DoDot:1
+7 if '$DATA(^MAG(2005.41,ENTRY,0))
QUIT
SET X=$PIECE(^MAG(2005.41,ENTRY,0),"^")
+8 SET MAGRY(CNT)=X_BLANK_"^"_X
SET CNT=CNT+1
SET DATA=1
End DoDot:1
+9 IF DATA
SET MAGRY(0)="1^DATA FOUND"_"^"_(CNT-1)
+10 QUIT
SECT(MAGRY) ;RPC Call to Build Pathology selection
+1 ; from file 68 accordingly to user's division
+2 ;MAGRY - Returns array of lab section name, section abbreviation
+3 ; used in defining the accession number & xref lookup,
+4 ; as well as the IEN in Imaging Parent file.
+5 NEW Y,A,B,BLANK,MAGABV,MAGERR,MAGIEN,MAGNM,MAGNNM,MAGSEC,MAGTYPE,DATA
+6 IF $$NEWERR^%ZTER
NEW $ETRAP,$ESTACK
SET $ETRAP="D ERRA^MAGGTERR"
+7 IF '$TEST
SET X="ERRA^MAGGTERR"
SET @^%ZOSF("TRAP")
+8 SET MAGRY(0)="0^No entries found^0"
+9 SET MAGSEC="SPCYEMAU"
SET (A,B)=0
SET $PIECE(BLANK," ",30)=""
DO CK
if MAGERR
QUIT
+10 FOR
SET A=$ORDER(^LRO(68,A))
if 'A
QUIT
Begin DoDot:1
+11 IF MAGSEC[$PIECE($GET(^LRO(68,A,0)),"^",2)
IF $PIECE(^LRO(68,A,0),"^",2)]""""
IF $GET(^LRO(68,A,3,+DUZ(2),0))
Begin DoDot:2
+12 ;No abbreviation defined
SET MAGABV=$PIECE(^LRO(68,A,0),"^",11)
if MAGABV=""
QUIT
+13 SET MAGTYPE=$PIECE(^LRO(68,A,0),"^",2)
SET MAGNM=$PIECE(^LRO(68,A,0),"^")
+14 ;Must be pathology section.
if MAGSEC'[MAGTYPE
QUIT
DO PARENT
+15 SET B=B+1
SET DATA=1
SET MAGRY(B)=MAGNM_BLANK_"^"_MAGIEN_"~"_MAGABV
End DoDot:2
End DoDot:1
+16 IF '$DATA(DATA)
SET MAGRY(0)="0^No entries found for your division^0"
QUIT
+17 IF DATA
SET B=B+1
SET MAGRY(0)="1^Entries found^"_B
+18 QUIT
CK ;Check for valid division.
+1 SET MAGERR=1
+2 NEW MAGSITE,MAGER
+3 SET MAGSITE=+DUZ(2)
+4 IF 'MAGSITE
Begin DoDot:1
+5 SET MAGRY(0)="0^You don't have a division setup."
End DoDot:1
QUIT
+6 ; gek/ change : ..."A",MAGSITE... to ..."","`"_MAGSITE...
+7 IF '$$FIND1^DIC(4,"","","`"_MAGSITE,"","","MAGER")
Begin DoDot:1
+8 SET MAGRY(0)="0^No division name found."
End DoDot:1
QUIT
+9 SET MAGERR=0
+10 QUIT
PARENT ;Set the corresponding parent file/subfile in ^MAG(2005.03,62:64.
+1 SET MAGIEN=$SELECT(MAGTYPE="SP":63.08,MAGTYPE="EM":63.02,MAGTYPE="CY":63.09,1:63.2)
+2 IF MAGTYPE="AU"
SET MAGIEN=63.2
SET MAGNNM=MAGNM_" (GROSS)"
SET B=B+1
SET MAGRY(B)=MAGNNM_BLANK_"^"_MAGIEN_"~"_MAGABV
SET MAGNNM=""
SET MAGIEN=63
SET MAGNM=MAGNM_" (MICROSCOPIC)"
+3 ;Autopsy selection will have two selection (GROSS or MICROSCOPIC) and the parent file ^MAG(2005.03 has two entries (63 & 63.2).
+4 QUIT
