- 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 Apr 23, 2025@18:23:08 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
