MAGDFCNV ;WOIFO/PMK - Read HL7 and generate DICOM ; Mar 31, 2020@15:52:30
;;3.0;IMAGING;**11,51,141,138,231**;Mar 19, 2002;Build 9;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. |
;; +---------------------------------------------------------------+
;;
;
; Supported IA #2171 reference $$STA^XUAF4 function call
; Supported IA #2541 reference $$KSP^XUPARAM function call
; Supported IA #2051 reference $$FIND1^DIC function call
; Supported IA #2056 reference $$GET1^DIQ function call
;
CONSOLID() ; check if this is a consolidated site or not
; return 0 = non-consolidated (normal) site
; return 1 = consolidated site
;
; code for the main VistA HIS
Q $GET(^MAG(2006.1,"CONSOLIDATED"))="YES"
;
ACQDEV(MFGR,MODEL,SITE) ; get pointer to the Acquisition Device file
N ACQDEV ;--- name of acquisition device
N ACQDEVP ;-- pointer to acquisition device file (#2006.04)
;
S ACQDEV=$$UP^MAGDFCNV(MFGR_" ("_MODEL_")")
S ACQDEVP=$O(^MAG(2006.04,"B",ACQDEV,""))
I 'ACQDEVP D ; create the entry
. L +^MAG(2006.04,0):1E9 ; serialize name generation code
. I '$D(^MAG(2006.04,0)) S ^(0)="ACQUISITION DEVICE^2006.04^^"
. S ACQDEVP=$P(^MAG(2006.04,0),"^",3)+1
. S ^MAG(2006.04,ACQDEVP,0)=ACQDEV_"^"_SITE_"^" ; 3rd piece is null
. S ^MAG(2006.04,"B",ACQDEV,ACQDEVP)=""
. S $P(^MAG(2006.04,0),"^",3)=ACQDEVP
. S $P(^MAG(2006.04,0),"^",4)=ACQDEVP
. L -^MAG(2006.04,0) ; clear the serial name generation code
Q ACQDEVP
;
EQUIVGRP(P1,P2) ; see if two SOP Class pointers are in equivalent groups
N G1,G2
Q:'$G(P1) 0
Q:'$G(P2) 0
S G1=$P($G(^MAG(2006.532,P1,0)),"^",3) S:G1="" G1=P1
S G2=$P($G(^MAG(2006.532,P2,0)),"^",3) S:G2="" G2=P2
Q G1=G2
;
UP(X) ; special UPPER CASE function -- removes redundant blanks as well
F Q:X'[" " S $E(X,$F(X," ")-1)="" ; remove redundant blank
I $E(X)=" " S $E(X)="" ; remove leading blank
I $E(X,$L(X))=" " S $E(X,$L(X))="" ; remove trailing blank
Q $TR(X,"abcdefghijklmnopqrstuvwxyz^|","ABCDEFGHIJKLMNOPQRSTUVWXYZ~~")
;
STATNUMB() ; return numeric 3-digit station number for the VA
N STATNUMB
S STATNUMB=$$STA^XUAF4($$KSP^XUPARAM("INST")) ; station number
; station number is 3 digits, exclusive of any modifiers or full station number for IHS
Q $S($$ISIHS^MAGSPID():STATNUMB,1:$E(STATNUMB,1,3))
;
GMRCACN(GMRCIEN) ; return a site-specific accession number for clinical specialties
; GMRCIEN is the CPRS Consult Request Tracking GMRC IEN - REQUEST/CONSULTATION file(#123)
N ACNUMB ; accession number for a consult/procedure request
N EXAMDATE ; date of exam
N P162DATE ; installation date for MAG*3.0*162, when site-specific accession numbers started
N INSTALLIEN
S INSTALLIEN=$$FIND1^DIC(9.7,"","B","MAG*3.0*162")
S P162DATE=$$GET1^DIQ(9.7,INSTALLIEN,17,"I") ; install complete date & time
S EXAMDATE=$$GET1^DIQ(123,GMRCIEN,.01,"I")
I EXAMDATE<P162DATE D ; legacy accession number format
. ; Format: GMRC-<gmrcien>, where <gmrcien> is the internal entry number of the request
. S ACNUMB="GMRC-"_GMRCIEN
. Q
E D ; site-specific accession number format
. ; Format: <sss>-GMR-<gmrcien>, where <sss> is station number, and <gmrcien>
. ; is the internal entry number of the request, up to 8 digits (100 million)
. S ACNUMB=$$STATNUMB()_"-GMR-"_GMRCIEN
. Q
Q ACNUMB
;
GMRCIEN(ACNUMB) ; return the GMRC IEN, given a consult/procedure accession number
; ACNUMB is the accession number for a consult/procedure request
; OLD Format: GMRC-<gmrcien>, where <gmrcien>is the internal entry number of the request
; New Format: <sss>-GMR-<gmrcien>, where <sss> is station number, and <gmrcien>
; is the internal entry number of the request, up to 8 digits (100 million)
N GMRCIEN ; CPRS Consult Request Tracking GMRC IEN - REQUEST/CONSULTATION file(#123)
I ACNUMB?1"GMRC-"1N.N S GMRCIEN=$P(ACNUMB,"-",2) ; return the second piece
E I ACNUMB?1N.N1"-GMR-"1N.N S GMRCIEN=$P(ACNUMB,"-",3) ; return the third piece
E S GMRCIEN="" ; invalid consult request tracking accession number format
Q GMRCIEN
;
HOSTNAME() ;
Q $P(##class(%SYS.System).GetNodeName(),".",1)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDFCNV 5039 printed Dec 13, 2024@01:59:53 Page 2
MAGDFCNV ;WOIFO/PMK - Read HL7 and generate DICOM ; Mar 31, 2020@15:52:30
+1 ;;3.0;IMAGING;**11,51,141,138,231**;Mar 19, 2002;Build 9;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 ;
+18 ; Supported IA #2171 reference $$STA^XUAF4 function call
+19 ; Supported IA #2541 reference $$KSP^XUPARAM function call
+20 ; Supported IA #2051 reference $$FIND1^DIC function call
+21 ; Supported IA #2056 reference $$GET1^DIQ function call
+22 ;
CONSOLID() ; check if this is a consolidated site or not
+1 ; return 0 = non-consolidated (normal) site
+2 ; return 1 = consolidated site
+3 ;
+4 ; code for the main VistA HIS
+5 QUIT $GET(^MAG(2006.1,"CONSOLIDATED"))="YES"
+6 ;
ACQDEV(MFGR,MODEL,SITE) ; get pointer to the Acquisition Device file
+1 ;--- name of acquisition device
NEW ACQDEV
+2 ;-- pointer to acquisition device file (#2006.04)
NEW ACQDEVP
+3 ;
+4 SET ACQDEV=$$UP^MAGDFCNV(MFGR_" ("_MODEL_")")
+5 SET ACQDEVP=$ORDER(^MAG(2006.04,"B",ACQDEV,""))
+6 ; create the entry
IF 'ACQDEVP
Begin DoDot:1
+7 ; serialize name generation code
LOCK +^MAG(2006.04,0):1E9
+8 IF '$DATA(^MAG(2006.04,0))
SET ^(0)="ACQUISITION DEVICE^2006.04^^"
+9 SET ACQDEVP=$PIECE(^MAG(2006.04,0),"^",3)+1
+10 ; 3rd piece is null
SET ^MAG(2006.04,ACQDEVP,0)=ACQDEV_"^"_SITE_"^"
+11 SET ^MAG(2006.04,"B",ACQDEV,ACQDEVP)=""
+12 SET $PIECE(^MAG(2006.04,0),"^",3)=ACQDEVP
+13 SET $PIECE(^MAG(2006.04,0),"^",4)=ACQDEVP
+14 ; clear the serial name generation code
LOCK -^MAG(2006.04,0)
End DoDot:1
+15 QUIT ACQDEVP
+16 ;
EQUIVGRP(P1,P2) ; see if two SOP Class pointers are in equivalent groups
+1 NEW G1,G2
+2 if '$GET(P1)
QUIT 0
+3 if '$GET(P2)
QUIT 0
+4 SET G1=$PIECE($GET(^MAG(2006.532,P1,0)),"^",3)
if G1=""
SET G1=P1
+5 SET G2=$PIECE($GET(^MAG(2006.532,P2,0)),"^",3)
if G2=""
SET G2=P2
+6 QUIT G1=G2
+7 ;
UP(X) ; special UPPER CASE function -- removes redundant blanks as well
+1 ; remove redundant blank
FOR
if X'[" "
QUIT
SET $EXTRACT(X,$FIND(X," ")-1)=""
+2 ; remove leading blank
IF $EXTRACT(X)=" "
SET $EXTRACT(X)=""
+3 ; remove trailing blank
IF $EXTRACT(X,$LENGTH(X))=" "
SET $EXTRACT(X,$LENGTH(X))=""
+4 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz^|","ABCDEFGHIJKLMNOPQRSTUVWXYZ~~")
+5 ;
STATNUMB() ; return numeric 3-digit station number for the VA
+1 NEW STATNUMB
+2 ; station number
SET STATNUMB=$$STA^XUAF4($$KSP^XUPARAM("INST"))
+3 ; station number is 3 digits, exclusive of any modifiers or full station number for IHS
+4 QUIT $SELECT($$ISIHS^MAGSPID():STATNUMB,1:$EXTRACT(STATNUMB,1,3))
+5 ;
GMRCACN(GMRCIEN) ; return a site-specific accession number for clinical specialties
+1 ; GMRCIEN is the CPRS Consult Request Tracking GMRC IEN - REQUEST/CONSULTATION file(#123)
+2 ; accession number for a consult/procedure request
NEW ACNUMB
+3 ; date of exam
NEW EXAMDATE
+4 ; installation date for MAG*3.0*162, when site-specific accession numbers started
NEW P162DATE
+5 NEW INSTALLIEN
+6 SET INSTALLIEN=$$FIND1^DIC(9.7,"","B","MAG*3.0*162")
+7 ; install complete date & time
SET P162DATE=$$GET1^DIQ(9.7,INSTALLIEN,17,"I")
+8 SET EXAMDATE=$$GET1^DIQ(123,GMRCIEN,.01,"I")
+9 ; legacy accession number format
IF EXAMDATE<P162DATE
Begin DoDot:1
+10 ; Format: GMRC-<gmrcien>, where <gmrcien> is the internal entry number of the request
+11 SET ACNUMB="GMRC-"_GMRCIEN
+12 QUIT
End DoDot:1
+13 ; site-specific accession number format
IF '$TEST
Begin DoDot:1
+14 ; Format: <sss>-GMR-<gmrcien>, where <sss> is station number, and <gmrcien>
+15 ; is the internal entry number of the request, up to 8 digits (100 million)
+16 SET ACNUMB=$$STATNUMB()_"-GMR-"_GMRCIEN
+17 QUIT
End DoDot:1
+18 QUIT ACNUMB
+19 ;
GMRCIEN(ACNUMB) ; return the GMRC IEN, given a consult/procedure accession number
+1 ; ACNUMB is the accession number for a consult/procedure request
+2 ; OLD Format: GMRC-<gmrcien>, where <gmrcien>is the internal entry number of the request
+3 ; New Format: <sss>-GMR-<gmrcien>, where <sss> is station number, and <gmrcien>
+4 ; is the internal entry number of the request, up to 8 digits (100 million)
+5 ; CPRS Consult Request Tracking GMRC IEN - REQUEST/CONSULTATION file(#123)
NEW GMRCIEN
+6 ; return the second piece
IF ACNUMB?1"GMRC-"1N.N
SET GMRCIEN=$PIECE(ACNUMB,"-",2)
+7 ; return the third piece
IF '$TEST
IF ACNUMB?1N.N1"-GMR-"1N.N
SET GMRCIEN=$PIECE(ACNUMB,"-",3)
+8 ; invalid consult request tracking accession number format
IF '$TEST
SET GMRCIEN=""
+9 QUIT GMRCIEN
+10 ;
HOSTNAME() ;
+1 QUIT $PIECE(##class(%SYS.System).GetNodeName(),".",1)
