MAGDRPCG ;WOIFO/PMK - Imaging RPCs ; Dec 06, 2021@10:34:52
;;3.0;IMAGING;**305**;Mar 19, 2002;Build 3
;; 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. |
;; +---------------------------------------------------------------+
;;
;
GETLRDFN(OUT,DFN,LRSSLIST) ; RPC = MAG DICOM GET LAB PAT LRDFN
N LRDFN
I '$D(DFN) S OUT="-1,DFN required" Q
I DFN'?1N.N S OUT="-2,DFN must be a numeric value, not """_DFN_"""" Q
I '$D(^DPT(DFN)) S OUT="-3,Patient with DFN """_DFN_""" is not defined" Q
I '$D(LRSSLIST) S OUT="-4,List of LRSS values is required" Q
S LRDFN=$$GET1^DIQ(2,DFN,63)
I LRDFN="" S OUT="-5,Patient has no Laboratory studies"
E D
. N HIT,I,MSG,N
. S HIT=0,MSG="-6,Patient has no Anatomic Pathology ",N=$O(LRSSLIST(""),-1)
. F I=1:1 Q:'$D(LRSSLIST(I)) D Q:HIT
. . S LRSS=LRSSLIST(I) I $D(^LR(LRDFN,LRSS)) S HIT=1 Q
. . S MSG=MSG_LRSS
. . I I=1 S MSG=MSG_$S(N=2:" or ",N=3:", ",1:"")
. . I I=2 S MSG=MSG_$S(N=3:", or ",1:"")
. . Q
. I 'HIT S OUT=MSG_" studies"
. E S OUT=LRDFN
. Q
Q
;
GETDFN(OUT,LRDFN) ; RPC = MAG DICOM GET LAB PAT DFN
N FILENAME
I '$D(LRDFN) S OUT="-1,LRDFN required" Q
I LRDFN'?1N.N S OUT="-2,LRDFN must be a numeric value, not """_LRDFN_"""" Q
I '$D(^LR(LRDFN)) S OUT="-3,Patient with LRDFN """_LRDFN_""" is not defined in LAB file (#63)" Q
; check for PATIENT file (#2)
S FILENAME=$$GET1^DIQ(63,LRDFN,.02)
I FILENAME'="PATIENT" D Q
. S OUT="-4,Patient with LRDFN """_LRDFN_""" is in the """_FILENAME_""" file, not the PATIENT file (#2)"
. Q
S OUT=$$GET1^DIQ(63,LRDFN,.03,"I")
Q
;
PATIENT(OUT,SORTORDER,LRDFN,LRSSLIST,BEGDATE,ENDDATE) ; RPC = MAG DICOM GET LAB BY PAT
N DIRECTION,DONE,HIT,I,LRI,LRSS,NOUT,STARTDATE,STOPDATE
K OUT
I '$D(SORTORDER) S OUT="-1,SORTORDER required" Q
I '$D(LRDFN) S OUT="-2,LRDFN required and may not be null" Q
I '$D(LRSSLIST) S OUT="-3,List of LRSS values is required" Q
I '$D(BEGDATE) S OUT="-4,BEGDATE required and may not be null" Q
I '$D(ENDDATE) S OUT="-5,ENDDATE required and may not be null" Q
;
I SORTORDER="ASCENDING" D
. S DIRECTION=1
. S STARTDATE=$$REVDATE(BEGDATE),STOPDATE=$$REVDATE(ENDDATE)
. Q
E I SORTORDER="DESCENDING" D
. S DIRECTION=-1
. S STARTDATE=$$REVDATE(ENDDATE),STOPDATE=$$REVDATE(BEGDATE)
. Q
E S OUT="-6,SORTORDER must be either ASCENDING or DESCENDING, not """_SORTORDER_"""" Q
;
S NOUT=1
;
S HIT=0 F I=1:1 Q:'$D(LRSSLIST(I)) S LRSS=LRSSLIST(I) I $D(^LR(LRDFN,LRSS)) D
. S HIT=1,DONE=0,LRI=STARTDATE ; $O thru reverse dates
. F S LRI=$O(^LR(LRDFN,LRSS,LRI),-DIRECTION) Q:'LRI Q:DONE D
. . I DIRECTION=1,LRI<STOPDATE S DONE=1 Q
. . I DIRECTION=-1,LRI>STOPDATE S DONE=1 Q
. . D LOOKUP1(LRDFN,LRSS,LRI)
. . Q
. Q
I NOUT=1 D
. I 'HIT S OUT(1)="-7,Patient has no Anatomic Pathology (CY, EM, or SR) studies"
. E S OUT(1)="-8,Patient has no Anatomic Pathology (CY, EM, or SR) images"
. Q
I '$D(OUT(1)) S OUT(1)=NOUT-1 ; allow error messages to be passed back in OUT(1)
Q
;
LOOKUP(OUT,LRDFN,LRSS,LRI) ; RPC = MAG DICOM GET LAB IMAGES
N NOUT
K OUT
I '$D(LRDFN) S OUT="-1,LRDFN required and may not be null" Q
I '$D(LRSS) S OUT="-2,LRSS required" Q
I '$D(LRI) S OUT="-3,LRI required and may not be null" Q
;
S NOUT=1
;
D LOOKUP1(LRDFN,LRSS,LRI)
;
I NOUT=1 D
. S OUT(1)="-4,Patient has no Anatomic Pathology (CY, EM, or SR) images"
. Q
I '$D(OUT(1)) S OUT(1)=NOUT-1 ; allow error messages to be passed back in OUT(1)
Q
;
LOOKUP1(LRDFN,LRSS,LRI) ; lookup an anatomic pathology image
; Images can be assocated with the TIU External Data file (#8925.91),
; or DICOM LAB TEMP LIST file (#2006.5838), or stored in the new
; SOP Class database IMAGE STUDY file (#2005.62) -- check all three
N ACNUMB,NODE0X,NODE0Y,PARENTFILE
S NODE0X=$G(^LR(LRDFN,LRSS,0)) Q:NODE0X=""
S PARENTFILE=+$P(NODE0X,"^",2) Q:'PARENTFILE
S NODE0Y=^LR(LRDFN,LRSS,LRI,0),ACNUMB=$P(NODE0Y,"^",6)
; W !,"ACNUMB = ",ACNUMB
D TIU(LRDFN,LRSS,LRI,ACNUMB) ; check the TIU External Data file (#8925.91)
D LABTEMP(PARENTFILE,LRDFN,LRSS,LRI,ACNUMB) ; check the DICOM LAB TEMP LIST file (#2006.5838)
D NEWSOP(LRSS,LRI,ACNUMB) ; check the new SOP Class database IMAGE STUDY file (#2005.62)
Q
;
TIU(LRDFN,LRSS,LRI,ACNUMB) ; check for images assocated with the TIU External Data file (#8925.91)
N MAGIEN,NODE0,TIU892591IEN,TIUIEN
I '$D(^LR(LRDFN,LRSS,LRI,.05,"C")) Q ; there is no TIU pointer
S TIUIEN=0
F S TIUIEN=$O(^LR(LRDFN,LRSS,LRI,.05,"C",TIUIEN)) Q:'TIUIEN D
. S TIU892591IEN=""
. F S TIU892591IEN=$O(^TIU(8925.91,"B",TIUIEN,TIU892591IEN)) Q:TIU892591IEN="" D
. . S NODE0=^TIU(8925.91,TIU892591IEN,0)
. . S MAGIEN=$P(NODE0,"^",2)
. . S NOUT=NOUT+1,OUT(NOUT)=MAGIEN_"^"_ACNUMB_"^"_$$REVDATE(LRI)_"^"_LRSS_"^"_LRI
. . Q
. Q
Q
;
LABTEMP(PARENTFILE,LRDFN,LRSS,LRI,ACNUMB) ; check for images assocated with the DICOM LAB TEMP LIST file (#2006.5838)
N MAG20065838IEN,MAGIEN,NODE0
S MAG20065838IEN=0
S MAG20065838IEN=$O(^MAG(2006.5838,"C",PARENTFILE,LRDFN,LRI,MAG20065838IEN)) Q:'MAG20065838IEN D
. S NODE0=$G(^MAG(2006.5838,MAG20065838IEN,0)) Q:NODE0=""
. S MAGIEN=$P(NODE0,"^",4)
. S NOUT=NOUT+1,OUT(NOUT)=MAGIEN_"^"_ACNUMB_"^"_$$REVDATE(LRI)_"^"_LRSS_"^"_LRI
. Q
Q
;
NEWSOP(LRSS,LRI,ACNUMB) ; check for images in the new SOP Class database IMAGE STUDY file (#2005.62)
N MAGV200562
S MAGV200562=0
S MAGV200562=$O(^MAGV(2005.62,"D",ACNUMB,MAGV200562)) Q:'MAGV200562 D
. S NOUT=NOUT+1,OUT(NOUT)="New SOP Class DB^"_ACNUMB_"^"_$$REVDATE(LRI)_"^"_LRSS_"^"_LRI
. Q
Q
;
DATE(OUT,SUBSCRIPTLEVEL,SORTORDER,LRSS,DATE,LRDFN,LRI) ; RPC = MAG DICOM GET LAB BY DATE
N DIRECTION,LRO
K OUT
I '$D(SUBSCRIPTLEVEL) S OUT="-1,SUBSCRIPT LEVEL required" Q
I '$D(SORTORDER) S OUT="-2,SORTORDER required" Q
I '$D(LRSS) S OUT="-3,LRSS required" Q
I '$D(DATE) S OUT="-4,DATE required and may not be null" Q
I '$D(LRDFN) S OUT="-5,LRDFN required and may not be null" Q
I '$D(LRI) S OUT="-6,LRI required and may not be null" Q
;
I SUBSCRIPTLEVEL'=1,SUBSCRIPTLEVEL'=2,SUBSCRIPTLEVEL'=3 S OUT="-7,SUBSCRIPT LEVEL must be either 1, 2, or 3, not """_SUBSCRIPTLEVEL_"""" q
;
I SORTORDER="ASCENDING" D
. S DIRECTION=1
. Q
E I SORTORDER="DESCENDING" D
. S DIRECTION=-1
. S:DATE=0 DATE="" S:LRDFN=0 LRDFN="" S:LRI=0 LRI="" ; needed for reverse $O
. Q
E S OUT="-8,SORTORDER must be either ASCENDING or DESCENDING, not """_SORTORDER_"""" Q
;
S LRO="A"_LRSS
;
; ^LR(LRO,DATE,LRDFN,LRI)=""
;
I SUBSCRIPTLEVEL=1 S OUT=$O(^LR(LRO,DATE),DIRECTION)
E I SUBSCRIPTLEVEL=2 S OUT=$O(^LR(LRO,DATE,LRDFN),DIRECTION)
E I SUBSCRIPTLEVEL=3 S OUT=$O(^LR(LRO,DATE,LRDFN,LRI),DIRECTION)
; I SUBSCRIPTLEVEL=3,LRI W !,"LR(""",LRO,""",",DATE,",",LRDFN,",",LRI,")"
; W !,"LR(""",LRO,""",",DATE,",",LRDFN,",",LRI,")"
Q
;
NXTLRDFN(OUT,SORTORDER,LRDFN,LRSSLIST) ; RPC = MAG DICOM GET LAB NEXT LRDFN
N DIRECTION,HIT,I,LRSS
I '$D(SORTORDER) S OUT="-1,SORTORDER required" Q
I $G(LRDFN)="" S OUT="-2,LRDFN required and may not be null" Q
I LRDFN'?1N.N S OUT="-3,LRDFN must be a numeric value, not ""_LRDFN_""" Q
I SORTORDER="ASCENDING" D
. S DIRECTION=1
. Q
E I SORTORDER="DESCENDING" D
. S DIRECTION=-1
. I LRDFN=0 S LRDFN=" " ; reverse $O origin
. Q
E S OUT="-4,SORTORDER must be either ASCENDING or DESCENDING, not """_SORTORDER_"""" Q
;
I '$D(LRSSLIST) S OUT="-5,List of LRSS values is required" Q
K OUT
S HIT=0 F S LRDFN=+$O(^LR(LRDFN),DIRECTION) Q:LRDFN=0 D Q:HIT
. F I=1:1 Q:'$D(LRSSLIST(I)) S LRSS=LRSSLIST(I) I $D(^LR(LRDFN,LRSS)) S HIT=1 Q
. Q
S OUT=+LRDFN
;
Q
;
REVDATE(DATE) ; convert a LAB date to a FM date and vice versa
Q 9999999-DATE ; unlike radiology which uses 9999999.9999
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDRPCG 8633 printed Apr 09, 2024@21:09:50 Page 2
MAGDRPCG ;WOIFO/PMK - Imaging RPCs ; Dec 06, 2021@10:34:52
+1 ;;3.0;IMAGING;**305**;Mar 19, 2002;Build 3
+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 ;
GETLRDFN(OUT,DFN,LRSSLIST) ; RPC = MAG DICOM GET LAB PAT LRDFN
+1 NEW LRDFN
+2 IF '$DATA(DFN)
SET OUT="-1,DFN required"
QUIT
+3 IF DFN'?1N.N
SET OUT="-2,DFN must be a numeric value, not """_DFN_""""
QUIT
+4 IF '$DATA(^DPT(DFN))
SET OUT="-3,Patient with DFN """_DFN_""" is not defined"
QUIT
+5 IF '$DATA(LRSSLIST)
SET OUT="-4,List of LRSS values is required"
QUIT
+6 SET LRDFN=$$GET1^DIQ(2,DFN,63)
+7 IF LRDFN=""
SET OUT="-5,Patient has no Laboratory studies"
+8 IF '$TEST
Begin DoDot:1
+9 NEW HIT,I,MSG,N
+10 SET HIT=0
SET MSG="-6,Patient has no Anatomic Pathology "
SET N=$ORDER(LRSSLIST(""),-1)
+11 FOR I=1:1
if '$DATA(LRSSLIST(I))
QUIT
Begin DoDot:2
+12 SET LRSS=LRSSLIST(I)
IF $DATA(^LR(LRDFN,LRSS))
SET HIT=1
QUIT
+13 SET MSG=MSG_LRSS
+14 IF I=1
SET MSG=MSG_$SELECT(N=2:" or ",N=3:", ",1:"")
+15 IF I=2
SET MSG=MSG_$SELECT(N=3:", or ",1:"")
+16 QUIT
End DoDot:2
if HIT
QUIT
+17 IF 'HIT
SET OUT=MSG_" studies"
+18 IF '$TEST
SET OUT=LRDFN
+19 QUIT
End DoDot:1
+20 QUIT
+21 ;
GETDFN(OUT,LRDFN) ; RPC = MAG DICOM GET LAB PAT DFN
+1 NEW FILENAME
+2 IF '$DATA(LRDFN)
SET OUT="-1,LRDFN required"
QUIT
+3 IF LRDFN'?1N.N
SET OUT="-2,LRDFN must be a numeric value, not """_LRDFN_""""
QUIT
+4 IF '$DATA(^LR(LRDFN))
SET OUT="-3,Patient with LRDFN """_LRDFN_""" is not defined in LAB file (#63)"
QUIT
+5 ; check for PATIENT file (#2)
+6 SET FILENAME=$$GET1^DIQ(63,LRDFN,.02)
+7 IF FILENAME'="PATIENT"
Begin DoDot:1
+8 SET OUT="-4,Patient with LRDFN """_LRDFN_""" is in the """_FILENAME_""" file, not the PATIENT file (#2)"
+9 QUIT
End DoDot:1
QUIT
+10 SET OUT=$$GET1^DIQ(63,LRDFN,.03,"I")
+11 QUIT
+12 ;
PATIENT(OUT,SORTORDER,LRDFN,LRSSLIST,BEGDATE,ENDDATE) ; RPC = MAG DICOM GET LAB BY PAT
+1 NEW DIRECTION,DONE,HIT,I,LRI,LRSS,NOUT,STARTDATE,STOPDATE
+2 KILL OUT
+3 IF '$DATA(SORTORDER)
SET OUT="-1,SORTORDER required"
QUIT
+4 IF '$DATA(LRDFN)
SET OUT="-2,LRDFN required and may not be null"
QUIT
+5 IF '$DATA(LRSSLIST)
SET OUT="-3,List of LRSS values is required"
QUIT
+6 IF '$DATA(BEGDATE)
SET OUT="-4,BEGDATE required and may not be null"
QUIT
+7 IF '$DATA(ENDDATE)
SET OUT="-5,ENDDATE required and may not be null"
QUIT
+8 ;
+9 IF SORTORDER="ASCENDING"
Begin DoDot:1
+10 SET DIRECTION=1
+11 SET STARTDATE=$$REVDATE(BEGDATE)
SET STOPDATE=$$REVDATE(ENDDATE)
+12 QUIT
End DoDot:1
+13 IF '$TEST
IF SORTORDER="DESCENDING"
Begin DoDot:1
+14 SET DIRECTION=-1
+15 SET STARTDATE=$$REVDATE(ENDDATE)
SET STOPDATE=$$REVDATE(BEGDATE)
+16 QUIT
End DoDot:1
+17 IF '$TEST
SET OUT="-6,SORTORDER must be either ASCENDING or DESCENDING, not """_SORTORDER_""""
QUIT
+18 ;
+19 SET NOUT=1
+20 ;
+21 SET HIT=0
FOR I=1:1
if '$DATA(LRSSLIST(I))
QUIT
SET LRSS=LRSSLIST(I)
IF $DATA(^LR(LRDFN,LRSS))
Begin DoDot:1
+22 ; $O thru reverse dates
SET HIT=1
SET DONE=0
SET LRI=STARTDATE
+23 FOR
SET LRI=$ORDER(^LR(LRDFN,LRSS,LRI),-DIRECTION)
if 'LRI
QUIT
if DONE
QUIT
Begin DoDot:2
+24 IF DIRECTION=1
IF LRI<STOPDATE
SET DONE=1
QUIT
+25 IF DIRECTION=-1
IF LRI>STOPDATE
SET DONE=1
QUIT
+26 DO LOOKUP1(LRDFN,LRSS,LRI)
+27 QUIT
End DoDot:2
+28 QUIT
End DoDot:1
+29 IF NOUT=1
Begin DoDot:1
+30 IF 'HIT
SET OUT(1)="-7,Patient has no Anatomic Pathology (CY, EM, or SR) studies"
+31 IF '$TEST
SET OUT(1)="-8,Patient has no Anatomic Pathology (CY, EM, or SR) images"
+32 QUIT
End DoDot:1
+33 ; allow error messages to be passed back in OUT(1)
IF '$DATA(OUT(1))
SET OUT(1)=NOUT-1
+34 QUIT
+35 ;
LOOKUP(OUT,LRDFN,LRSS,LRI) ; RPC = MAG DICOM GET LAB IMAGES
+1 NEW NOUT
+2 KILL OUT
+3 IF '$DATA(LRDFN)
SET OUT="-1,LRDFN required and may not be null"
QUIT
+4 IF '$DATA(LRSS)
SET OUT="-2,LRSS required"
QUIT
+5 IF '$DATA(LRI)
SET OUT="-3,LRI required and may not be null"
QUIT
+6 ;
+7 SET NOUT=1
+8 ;
+9 DO LOOKUP1(LRDFN,LRSS,LRI)
+10 ;
+11 IF NOUT=1
Begin DoDot:1
+12 SET OUT(1)="-4,Patient has no Anatomic Pathology (CY, EM, or SR) images"
+13 QUIT
End DoDot:1
+14 ; allow error messages to be passed back in OUT(1)
IF '$DATA(OUT(1))
SET OUT(1)=NOUT-1
+15 QUIT
+16 ;
LOOKUP1(LRDFN,LRSS,LRI) ; lookup an anatomic pathology image
+1 ; Images can be assocated with the TIU External Data file (#8925.91),
+2 ; or DICOM LAB TEMP LIST file (#2006.5838), or stored in the new
+3 ; SOP Class database IMAGE STUDY file (#2005.62) -- check all three
+4 NEW ACNUMB,NODE0X,NODE0Y,PARENTFILE
+5 SET NODE0X=$GET(^LR(LRDFN,LRSS,0))
if NODE0X=""
QUIT
+6 SET PARENTFILE=+$PIECE(NODE0X,"^",2)
if 'PARENTFILE
QUIT
+7 SET NODE0Y=^LR(LRDFN,LRSS,LRI,0)
SET ACNUMB=$PIECE(NODE0Y,"^",6)
+8 ; W !,"ACNUMB = ",ACNUMB
+9 ; check the TIU External Data file (#8925.91)
DO TIU(LRDFN,LRSS,LRI,ACNUMB)
+10 ; check the DICOM LAB TEMP LIST file (#2006.5838)
DO LABTEMP(PARENTFILE,LRDFN,LRSS,LRI,ACNUMB)
+11 ; check the new SOP Class database IMAGE STUDY file (#2005.62)
DO NEWSOP(LRSS,LRI,ACNUMB)
+12 QUIT
+13 ;
TIU(LRDFN,LRSS,LRI,ACNUMB) ; check for images assocated with the TIU External Data file (#8925.91)
+1 NEW MAGIEN,NODE0,TIU892591IEN,TIUIEN
+2 ; there is no TIU pointer
IF '$DATA(^LR(LRDFN,LRSS,LRI,.05,"C"))
QUIT
+3 SET TIUIEN=0
+4 FOR
SET TIUIEN=$ORDER(^LR(LRDFN,LRSS,LRI,.05,"C",TIUIEN))
if 'TIUIEN
QUIT
Begin DoDot:1
+5 SET TIU892591IEN=""
+6 FOR
SET TIU892591IEN=$ORDER(^TIU(8925.91,"B",TIUIEN,TIU892591IEN))
if TIU892591IEN=""
QUIT
Begin DoDot:2
+7 SET NODE0=^TIU(8925.91,TIU892591IEN,0)
+8 SET MAGIEN=$PIECE(NODE0,"^",2)
+9 SET NOUT=NOUT+1
SET OUT(NOUT)=MAGIEN_"^"_ACNUMB_"^"_$$REVDATE(LRI)_"^"_LRSS_"^"_LRI
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
LABTEMP(PARENTFILE,LRDFN,LRSS,LRI,ACNUMB) ; check for images assocated with the DICOM LAB TEMP LIST file (#2006.5838)
+1 NEW MAG20065838IEN,MAGIEN,NODE0
+2 SET MAG20065838IEN=0
+3 SET MAG20065838IEN=$ORDER(^MAG(2006.5838,"C",PARENTFILE,LRDFN,LRI,MAG20065838IEN))
if 'MAG20065838IEN
QUIT
Begin DoDot:1
+4 SET NODE0=$GET(^MAG(2006.5838,MAG20065838IEN,0))
if NODE0=""
QUIT
+5 SET MAGIEN=$PIECE(NODE0,"^",4)
+6 SET NOUT=NOUT+1
SET OUT(NOUT)=MAGIEN_"^"_ACNUMB_"^"_$$REVDATE(LRI)_"^"_LRSS_"^"_LRI
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
NEWSOP(LRSS,LRI,ACNUMB) ; check for images in the new SOP Class database IMAGE STUDY file (#2005.62)
+1 NEW MAGV200562
+2 SET MAGV200562=0
+3 SET MAGV200562=$ORDER(^MAGV(2005.62,"D",ACNUMB,MAGV200562))
if 'MAGV200562
QUIT
Begin DoDot:1
+4 SET NOUT=NOUT+1
SET OUT(NOUT)="New SOP Class DB^"_ACNUMB_"^"_$$REVDATE(LRI)_"^"_LRSS_"^"_LRI
+5 QUIT
End DoDot:1
+6 QUIT
+7 ;
DATE(OUT,SUBSCRIPTLEVEL,SORTORDER,LRSS,DATE,LRDFN,LRI) ; RPC = MAG DICOM GET LAB BY DATE
+1 NEW DIRECTION,LRO
+2 KILL OUT
+3 IF '$DATA(SUBSCRIPTLEVEL)
SET OUT="-1,SUBSCRIPT LEVEL required"
QUIT
+4 IF '$DATA(SORTORDER)
SET OUT="-2,SORTORDER required"
QUIT
+5 IF '$DATA(LRSS)
SET OUT="-3,LRSS required"
QUIT
+6 IF '$DATA(DATE)
SET OUT="-4,DATE required and may not be null"
QUIT
+7 IF '$DATA(LRDFN)
SET OUT="-5,LRDFN required and may not be null"
QUIT
+8 IF '$DATA(LRI)
SET OUT="-6,LRI required and may not be null"
QUIT
+9 ;
+10 IF SUBSCRIPTLEVEL'=1
IF SUBSCRIPTLEVEL'=2
IF SUBSCRIPTLEVEL'=3
SET OUT="-7,SUBSCRIPT LEVEL must be either 1, 2, or 3, not """_SUBSCRIPTLEVEL_""""
QUIT
+11 ;
+12 IF SORTORDER="ASCENDING"
Begin DoDot:1
+13 SET DIRECTION=1
+14 QUIT
End DoDot:1
+15 IF '$TEST
IF SORTORDER="DESCENDING"
Begin DoDot:1
+16 SET DIRECTION=-1
+17 ; needed for reverse $O
if DATE=0
SET DATE=""
if LRDFN=0
SET LRDFN=""
if LRI=0
SET LRI=""
+18 QUIT
End DoDot:1
+19 IF '$TEST
SET OUT="-8,SORTORDER must be either ASCENDING or DESCENDING, not """_SORTORDER_""""
QUIT
+20 ;
+21 SET LRO="A"_LRSS
+22 ;
+23 ; ^LR(LRO,DATE,LRDFN,LRI)=""
+24 ;
+25 IF SUBSCRIPTLEVEL=1
SET OUT=$ORDER(^LR(LRO,DATE),DIRECTION)
+26 IF '$TEST
IF SUBSCRIPTLEVEL=2
SET OUT=$ORDER(^LR(LRO,DATE,LRDFN),DIRECTION)
+27 IF '$TEST
IF SUBSCRIPTLEVEL=3
SET OUT=$ORDER(^LR(LRO,DATE,LRDFN,LRI),DIRECTION)
+28 ; I SUBSCRIPTLEVEL=3,LRI W !,"LR(""",LRO,""",",DATE,",",LRDFN,",",LRI,")"
+29 ; W !,"LR(""",LRO,""",",DATE,",",LRDFN,",",LRI,")"
+30 QUIT
+31 ;
NXTLRDFN(OUT,SORTORDER,LRDFN,LRSSLIST) ; RPC = MAG DICOM GET LAB NEXT LRDFN
+1 NEW DIRECTION,HIT,I,LRSS
+2 IF '$DATA(SORTORDER)
SET OUT="-1,SORTORDER required"
QUIT
+3 IF $GET(LRDFN)=""
SET OUT="-2,LRDFN required and may not be null"
QUIT
+4 IF LRDFN'?1N.N
SET OUT="-3,LRDFN must be a numeric value, not ""_LRDFN_"""
QUIT
+5 IF SORTORDER="ASCENDING"
Begin DoDot:1
+6 SET DIRECTION=1
+7 QUIT
End DoDot:1
+8 IF '$TEST
IF SORTORDER="DESCENDING"
Begin DoDot:1
+9 SET DIRECTION=-1
+10 ; reverse $O origin
IF LRDFN=0
SET LRDFN=" "
+11 QUIT
End DoDot:1
+12 IF '$TEST
SET OUT="-4,SORTORDER must be either ASCENDING or DESCENDING, not """_SORTORDER_""""
QUIT
+13 ;
+14 IF '$DATA(LRSSLIST)
SET OUT="-5,List of LRSS values is required"
QUIT
+15 KILL OUT
+16 SET HIT=0
FOR
SET LRDFN=+$ORDER(^LR(LRDFN),DIRECTION)
if LRDFN=0
QUIT
Begin DoDot:1
+17 FOR I=1:1
if '$DATA(LRSSLIST(I))
QUIT
SET LRSS=LRSSLIST(I)
IF $DATA(^LR(LRDFN,LRSS))
SET HIT=1
QUIT
+18 QUIT
End DoDot:1
if HIT
QUIT
+19 SET OUT=+LRDFN
+20 ;
+21 QUIT
+22 ;
REVDATE(DATE) ; convert a LAB date to a FM date and vice versa
+1 ; unlike radiology which uses 9999999.9999
QUIT 9999999-DATE
