MAGT7SSA ;WOIFO/MLH/PMK - telepathology - create HL7 message to DPS - segment build - set up OBXs for each SPM ; 03 Jul 2013 4:08 PM
;;3.0;IMAGING;**138**;Mar 19, 2002;Build 5380;Sep 03, 2013
;; 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
;
SPMANC(MSG,FILE,IENSX,LRSS,IX) ; FUNCTION - main entry point - create ancillary OBX segments
N BLKTYPSTGSTR ; block type/stage string
N BLKTYPSTG ; block type/stage
N BLKTYPSTGIX ; block type/stage index
N BLOCKDATA ; block information
N BLOCKFILE ; Fileman file number for block
N BLOCKNAME ; name of block
N BLOCKSS2 ; ss2 in LABDATA for block
N ERRSTAT S ERRSTAT=0 ; assume nothing to report
S BLOCKNAME=""
F S BLOCKNAME=$O(FILE("SPECIMEN",BLOCKNAME)) Q:BLOCKNAME="" D
. S BLOCKFILE=FILE("SPECIMEN",BLOCKNAME) Q:'$D(@LABDATA@(BLOCKFILE))
. S BLOCKSS2="" F S BLOCKSS2=$O(@LABDATA@(BLOCKFILE,BLOCKSS2)) Q:BLOCKSS2="" D
. . I $P(BLOCKSS2,",",2,999)=IENSX S BLOCKDATA(BLOCKNAME,BLOCKSS2)=""
. . Q
. Q
I '$D(BLOCKDATA) Q ERRSTAT ; no blocks found
;
; one or more block(s) were found
D ; make OBX segments, bail if a problem arises
. D Q:ERRSTAT ;subspecialty
. . S ERRSTAT=$$OBXSEG^MAGT7SX(.MSG,"SUBSPECIALTY","ST",FILE("NAME"))
. . Q
. D Q:ERRSTAT ;block type/stage
. . S BLOCKNAME=""
. . F S BLOCKNAME=$O(BLOCKDATA(BLOCKNAME)) Q:BLOCKNAME="" D
. . . S BLOCKSS2=""
. . . F S BLOCKSS2=$O(BLOCKDATA(BLOCKNAME,BLOCKSS2)) Q:BLOCKSS2="" D Q:ERRSTAT
. . . . S ERRSTAT=$$BLOCK(.MSG,.FILE,LRSS,BLOCKNAME,BLOCKSS2)
. . . . Q
. . . Q
. . Q
. Q
Q ERRSTAT
;
BLOCK(MSG,FILE,LRSS,BLOCKNAME,BLOCKSS2) ; output the block information
N BLOCKFILE ; Fileman file number for block
N TIMESTAMP ; date/time for OBX segment
N STAINFILE ; Fileman file number for stain
N STAINNAME ; name of stain
N STAINSS2 ; ss2 in LABDATA for stain
N VALUE ; value of attribute in OBX segment
N ERRSTAT S ERRSTAT=0 ; assume nothing to report
;
S BLOCKFILE=FILE("SPECIMEN",BLOCKNAME)
S STAINNAME=$O(FILE("SPECIMEN",BLOCKNAME,""))
S STAINFILE=FILE("SPECIMEN",BLOCKNAME,STAINNAME)
D Q:ERRSTAT ; block type/stage
. S ERRSTAT=$$OBXSEG^MAGT7SX(.MSG,"BLOCK TYPE/STAGE","ST",BLOCKNAME) Q:ERRSTAT
. S VALUE=$G(@LABDATA@(BLOCKFILE,BLOCKSS2,.01,"I")) ; block/stage id
. S TIMESTAMP=$G(@LABDATA@(BLOCKFILE,BLOCKSS2,.02,"I")) ; date/time block prepared
. S ERRSTAT=$$OBXSEG^MAGT7SX(.MSG,"BLOCK INDEX","ST",VALUE,TIMESTAMP)
. S STAINSS2=""
. F S STAINSS2=$O(@LABDATA@(STAINFILE,STAINSS2)) Q:STAINSS2="" D Q:ERRSTAT
. . I $P(STAINSS2,",",2,999)=BLOCKSS2 D Q:ERRSTAT
. . . S ERRSTAT=$$STAIN(.MSG,.FILE,LRSS,STAINFILE,STAINSS2)
. . . Q
. . Q
. Q
Q ERRSTAT
;
STAIN(MSG,FILE,LRSS,STAINFILE,STAINSS2) ; output the stain/procedure information
N DATATYPE ; HL7 datatype for the OBX segment
N FIELDNUMBER ; field in stain file
N LABSECTION ; CY, EM, and/or SP
N NAME ; name of attribute in OBX segment
N PTRFLAG ; indicator for lab file #60 dictionary lookup
N VALUE ; value of attribute in OBX segment
N TIMESTAMP ; date/time for OBX segment - one of these three DTTM* values
N DTTMSTNPREP ; date/time slides stained or sections prepared
N DTTMEXAM ; date/time slides/sections examined
N DTTMPRMADE ; date/time prints made
N I,X
N ERRSTAT S ERRSTAT=0 ; assume nothing to report
;
S DTTMSTNPREP=$G(@LABDATA@(STAINFILE,STAINSS2,.04,"I")) ; date/time slides stained or sections prepared
S DTTMEXAM=$G(@LABDATA@(STAINFILE,STAINSS2,.05,"I")) ; date/time slides/sections examined
S DTTMPRMADE=$G(@LABDATA@(STAINFILE,STAINSS2,.11,"I")) ; date/time prints made
F I=2:1 S X=$P($T(FIELDS+I),";;",2) Q:"end"[X D Q:ERRSTAT
. S LABSECTION=$P(X,"^",3) I LABSECTION'[LRSS Q
. S FIELDNUMBER=$P(X,"^",1),PTRFLAG=$P(X,"^",2)
. S NAME=$P(X,"^",4),DATATYPE=$P(X,"^",5),TIMESTAMP=$P(X,"^",6)
. S VALUE=$G(@LABDATA@(STAINFILE,STAINSS2,FIELDNUMBER,"I"))
. I PTRFLAG="P",VALUE S VALUE=$$GET1^DIQ(60,VALUE,.01) ; get procedure
. I VALUE="" Q ; don't output null values
. S TIMESTAMP=$S(TIMESTAMP="S":DTTMSTNPREP,TIMESTAMP="P":DTTMSTNPREP,TIMESTAMP="E":DTTMEXAM)
. S ERRSTAT=$$OBXSEG^MAGT7SX(.MSG,NAME,DATATYPE,VALUE,TIMESTAMP)
. Q
Q ERRSTAT
;
FIELDS ; fields to output
;;field #^pointer file^lab section^title^datatype^timestamp^comment
;;.01^P^CY/EM/SP^PROCEDURE DESCRIPTION^ST^S^stain/procedure
;;.02^^EM^SECTIONS PREPARED^NM^S
;;.02^^CY/SP^SLIDES PREPARED^NM^S
;;.03^^EM^CONTROL SECTIONS^NM^S
;;.03^^CY/SP^CONTROL SLIDES^NM^S
;;.06^^EM^SECTIONS COUNTED"^NM^E
;;.06^^CY/SP^SLIDES COUNTED"^NM^E
;;.07^^EM^NEW SECTIONS^NM^S
;;.07^^CY/SP^LABELS TO PRINTS^NM^S
;;.08^^CY^SLIDES SCREENED^NM^E
;;.08^^EM^SECTIONS EXAMINED^NM^E
;;.08^^SP^SLIDES EXAMINED^NM^E^free
;;.09^^CY/EM/SP^NON-CONTROL SLIDES COUNTED^NM^E
;;.1^^EM^PRINTS MADE^NM^P
;;.12^^EM^PRINTS COUNTED^NM^P
;;.13^^EM^EXAMINIATION SECTIONS COUNTED^NM^P
;;end
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGT7SSA 5869 printed Sep 23, 2025@19:44:51 Page 2
MAGT7SSA ;WOIFO/MLH/PMK - telepathology - create HL7 message to DPS - segment build - set up OBXs for each SPM ; 03 Jul 2013 4:08 PM
+1 ;;3.0;IMAGING;**138**;Mar 19, 2002;Build 5380;Sep 03, 2013
+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 ;
SPMANC(MSG,FILE,IENSX,LRSS,IX) ; FUNCTION - main entry point - create ancillary OBX segments
+1 ; block type/stage string
NEW BLKTYPSTGSTR
+2 ; block type/stage
NEW BLKTYPSTG
+3 ; block type/stage index
NEW BLKTYPSTGIX
+4 ; block information
NEW BLOCKDATA
+5 ; Fileman file number for block
NEW BLOCKFILE
+6 ; name of block
NEW BLOCKNAME
+7 ; ss2 in LABDATA for block
NEW BLOCKSS2
+8 ; assume nothing to report
NEW ERRSTAT
SET ERRSTAT=0
+9 SET BLOCKNAME=""
+10 FOR
SET BLOCKNAME=$ORDER(FILE("SPECIMEN",BLOCKNAME))
if BLOCKNAME=""
QUIT
Begin DoDot:1
+11 SET BLOCKFILE=FILE("SPECIMEN",BLOCKNAME)
if '$DATA(@LABDATA@(BLOCKFILE))
QUIT
+12 SET BLOCKSS2=""
FOR
SET BLOCKSS2=$ORDER(@LABDATA@(BLOCKFILE,BLOCKSS2))
if BLOCKSS2=""
QUIT
Begin DoDot:2
+13 IF $PIECE(BLOCKSS2,",",2,999)=IENSX
SET BLOCKDATA(BLOCKNAME,BLOCKSS2)=""
+14 QUIT
End DoDot:2
+15 QUIT
End DoDot:1
+16 ; no blocks found
IF '$DATA(BLOCKDATA)
QUIT ERRSTAT
+17 ;
+18 ; one or more block(s) were found
+19 ; make OBX segments, bail if a problem arises
Begin DoDot:1
+20 ;subspecialty
Begin DoDot:2
+21 SET ERRSTAT=$$OBXSEG^MAGT7SX(.MSG,"SUBSPECIALTY","ST",FILE("NAME"))
+22 QUIT
End DoDot:2
if ERRSTAT
QUIT
+23 ;block type/stage
Begin DoDot:2
+24 SET BLOCKNAME=""
+25 FOR
SET BLOCKNAME=$ORDER(BLOCKDATA(BLOCKNAME))
if BLOCKNAME=""
QUIT
Begin DoDot:3
+26 SET BLOCKSS2=""
+27 FOR
SET BLOCKSS2=$ORDER(BLOCKDATA(BLOCKNAME,BLOCKSS2))
if BLOCKSS2=""
QUIT
Begin DoDot:4
+28 SET ERRSTAT=$$BLOCK(.MSG,.FILE,LRSS,BLOCKNAME,BLOCKSS2)
+29 QUIT
End DoDot:4
if ERRSTAT
QUIT
+30 QUIT
End DoDot:3
+31 QUIT
End DoDot:2
if ERRSTAT
QUIT
+32 QUIT
End DoDot:1
+33 QUIT ERRSTAT
+34 ;
BLOCK(MSG,FILE,LRSS,BLOCKNAME,BLOCKSS2) ; output the block information
+1 ; Fileman file number for block
NEW BLOCKFILE
+2 ; date/time for OBX segment
NEW TIMESTAMP
+3 ; Fileman file number for stain
NEW STAINFILE
+4 ; name of stain
NEW STAINNAME
+5 ; ss2 in LABDATA for stain
NEW STAINSS2
+6 ; value of attribute in OBX segment
NEW VALUE
+7 ; assume nothing to report
NEW ERRSTAT
SET ERRSTAT=0
+8 ;
+9 SET BLOCKFILE=FILE("SPECIMEN",BLOCKNAME)
+10 SET STAINNAME=$ORDER(FILE("SPECIMEN",BLOCKNAME,""))
+11 SET STAINFILE=FILE("SPECIMEN",BLOCKNAME,STAINNAME)
+12 ; block type/stage
Begin DoDot:1
+13 SET ERRSTAT=$$OBXSEG^MAGT7SX(.MSG,"BLOCK TYPE/STAGE","ST",BLOCKNAME)
if ERRSTAT
QUIT
+14 ; block/stage id
SET VALUE=$GET(@LABDATA@(BLOCKFILE,BLOCKSS2,.01,"I"))
+15 ; date/time block prepared
SET TIMESTAMP=$GET(@LABDATA@(BLOCKFILE,BLOCKSS2,.02,"I"))
+16 SET ERRSTAT=$$OBXSEG^MAGT7SX(.MSG,"BLOCK INDEX","ST",VALUE,TIMESTAMP)
+17 SET STAINSS2=""
+18 FOR
SET STAINSS2=$ORDER(@LABDATA@(STAINFILE,STAINSS2))
if STAINSS2=""
QUIT
Begin DoDot:2
+19 IF $PIECE(STAINSS2,",",2,999)=BLOCKSS2
Begin DoDot:3
+20 SET ERRSTAT=$$STAIN(.MSG,.FILE,LRSS,STAINFILE,STAINSS2)
+21 QUIT
End DoDot:3
if ERRSTAT
QUIT
+22 QUIT
End DoDot:2
if ERRSTAT
QUIT
+23 QUIT
End DoDot:1
if ERRSTAT
QUIT
+24 QUIT ERRSTAT
+25 ;
STAIN(MSG,FILE,LRSS,STAINFILE,STAINSS2) ; output the stain/procedure information
+1 ; HL7 datatype for the OBX segment
NEW DATATYPE
+2 ; field in stain file
NEW FIELDNUMBER
+3 ; CY, EM, and/or SP
NEW LABSECTION
+4 ; name of attribute in OBX segment
NEW NAME
+5 ; indicator for lab file #60 dictionary lookup
NEW PTRFLAG
+6 ; value of attribute in OBX segment
NEW VALUE
+7 ; date/time for OBX segment - one of these three DTTM* values
NEW TIMESTAMP
+8 ; date/time slides stained or sections prepared
NEW DTTMSTNPREP
+9 ; date/time slides/sections examined
NEW DTTMEXAM
+10 ; date/time prints made
NEW DTTMPRMADE
+11 NEW I,X
+12 ; assume nothing to report
NEW ERRSTAT
SET ERRSTAT=0
+13 ;
+14 ; date/time slides stained or sections prepared
SET DTTMSTNPREP=$GET(@LABDATA@(STAINFILE,STAINSS2,.04,"I"))
+15 ; date/time slides/sections examined
SET DTTMEXAM=$GET(@LABDATA@(STAINFILE,STAINSS2,.05,"I"))
+16 ; date/time prints made
SET DTTMPRMADE=$GET(@LABDATA@(STAINFILE,STAINSS2,.11,"I"))
+17 FOR I=2:1
SET X=$PIECE($TEXT(FIELDS+I),";;",2)
if "end"[X
QUIT
Begin DoDot:1
+18 SET LABSECTION=$PIECE(X,"^",3)
IF LABSECTION'[LRSS
QUIT
+19 SET FIELDNUMBER=$PIECE(X,"^",1)
SET PTRFLAG=$PIECE(X,"^",2)
+20 SET NAME=$PIECE(X,"^",4)
SET DATATYPE=$PIECE(X,"^",5)
SET TIMESTAMP=$PIECE(X,"^",6)
+21 SET VALUE=$GET(@LABDATA@(STAINFILE,STAINSS2,FIELDNUMBER,"I"))
+22 ; get procedure
IF PTRFLAG="P"
IF VALUE
SET VALUE=$$GET1^DIQ(60,VALUE,.01)
+23 ; don't output null values
IF VALUE=""
QUIT
+24 SET TIMESTAMP=$SELECT(TIMESTAMP="S":DTTMSTNPREP,TIMESTAMP="P":DTTMSTNPREP,TIMESTAMP="E":DTTMEXAM)
+25 SET ERRSTAT=$$OBXSEG^MAGT7SX(.MSG,NAME,DATATYPE,VALUE,TIMESTAMP)
+26 QUIT
End DoDot:1
if ERRSTAT
QUIT
+27 QUIT ERRSTAT
+28 ;
FIELDS ; fields to output
+1 ;;field #^pointer file^lab section^title^datatype^timestamp^comment
+2 ;;.01^P^CY/EM/SP^PROCEDURE DESCRIPTION^ST^S^stain/procedure
+3 ;;.02^^EM^SECTIONS PREPARED^NM^S
+4 ;;.02^^CY/SP^SLIDES PREPARED^NM^S
+5 ;;.03^^EM^CONTROL SECTIONS^NM^S
+6 ;;.03^^CY/SP^CONTROL SLIDES^NM^S
+7 ;;.06^^EM^SECTIONS COUNTED"^NM^E
+8 ;;.06^^CY/SP^SLIDES COUNTED"^NM^E
+9 ;;.07^^EM^NEW SECTIONS^NM^S
+10 ;;.07^^CY/SP^LABELS TO PRINTS^NM^S
+11 ;;.08^^CY^SLIDES SCREENED^NM^E
+12 ;;.08^^EM^SECTIONS EXAMINED^NM^E
+13 ;;.08^^SP^SLIDES EXAMINED^NM^E^free
+14 ;;.09^^CY/EM/SP^NON-CONTROL SLIDES COUNTED^NM^E
+15 ;;.1^^EM^PRINTS MADE^NM^P
+16 ;;.12^^EM^PRINTS COUNTED^NM^P
+17 ;;.13^^EM^EXAMINIATION SECTIONS COUNTED^NM^P
+18 ;;end
