Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: MAGDRPCG

MAGDRPCG.m

Go to the documentation of this file.
  1. MAGDRPCG ;WOIFO/PMK - Imaging RPCs ; Dec 06, 2021@10:34:52
  1. ;;3.0;IMAGING;**305**;Mar 19, 2002;Build 3
  1. ;; Per VHA Directive 2004-038, this routine should not be modified.
  1. ;; +---------------------------------------------------------------+
  1. ;; | Property of the US Government. |
  1. ;; | No permission to copy or redistribute this software is given. |
  1. ;; | Use of unreleased versions of this software requires the user |
  1. ;; | to execute a written test agreement with the VistA Imaging |
  1. ;; | Development Office of the Department of Veterans Affairs, |
  1. ;; | telephone (301) 734-0100. |
  1. ;; | The Food and Drug Administration classifies this software as |
  1. ;; | a medical device. As such, it may not be changed in any way. |
  1. ;; | Modifications to this software may result in an adulterated |
  1. ;; | medical device under 21CFR820, the use of which is considered |
  1. ;; | to be a violation of US Federal Statutes. |
  1. ;; +---------------------------------------------------------------+
  1. ;;
  1. ;
  1. GETLRDFN(OUT,DFN,LRSSLIST) ; RPC = MAG DICOM GET LAB PAT LRDFN
  1. N LRDFN
  1. I '$D(DFN) S OUT="-1,DFN required" Q
  1. I DFN'?1N.N S OUT="-2,DFN must be a numeric value, not """_DFN_"""" Q
  1. I '$D(^DPT(DFN)) S OUT="-3,Patient with DFN """_DFN_""" is not defined" Q
  1. I '$D(LRSSLIST) S OUT="-4,List of LRSS values is required" Q
  1. S LRDFN=$$GET1^DIQ(2,DFN,63)
  1. I LRDFN="" S OUT="-5,Patient has no Laboratory studies"
  1. E D
  1. . N HIT,I,MSG,N
  1. . S HIT=0,MSG="-6,Patient has no Anatomic Pathology ",N=$O(LRSSLIST(""),-1)
  1. . F I=1:1 Q:'$D(LRSSLIST(I)) D Q:HIT
  1. . . S LRSS=LRSSLIST(I) I $D(^LR(LRDFN,LRSS)) S HIT=1 Q
  1. . . S MSG=MSG_LRSS
  1. . . I I=1 S MSG=MSG_$S(N=2:" or ",N=3:", ",1:"")
  1. . . I I=2 S MSG=MSG_$S(N=3:", or ",1:"")
  1. . . Q
  1. . I 'HIT S OUT=MSG_" studies"
  1. . E S OUT=LRDFN
  1. . Q
  1. Q
  1. ;
  1. GETDFN(OUT,LRDFN) ; RPC = MAG DICOM GET LAB PAT DFN
  1. N FILENAME
  1. I '$D(LRDFN) S OUT="-1,LRDFN required" Q
  1. I LRDFN'?1N.N S OUT="-2,LRDFN must be a numeric value, not """_LRDFN_"""" Q
  1. I '$D(^LR(LRDFN)) S OUT="-3,Patient with LRDFN """_LRDFN_""" is not defined in LAB file (#63)" Q
  1. ; check for PATIENT file (#2)
  1. S FILENAME=$$GET1^DIQ(63,LRDFN,.02)
  1. I FILENAME'="PATIENT" D Q
  1. . S OUT="-4,Patient with LRDFN """_LRDFN_""" is in the """_FILENAME_""" file, not the PATIENT file (#2)"
  1. . Q
  1. S OUT=$$GET1^DIQ(63,LRDFN,.03,"I")
  1. Q
  1. ;
  1. PATIENT(OUT,SORTORDER,LRDFN,LRSSLIST,BEGDATE,ENDDATE) ; RPC = MAG DICOM GET LAB BY PAT
  1. N DIRECTION,DONE,HIT,I,LRI,LRSS,NOUT,STARTDATE,STOPDATE
  1. K OUT
  1. I '$D(SORTORDER) S OUT="-1,SORTORDER required" Q
  1. I '$D(LRDFN) S OUT="-2,LRDFN required and may not be null" Q
  1. I '$D(LRSSLIST) S OUT="-3,List of LRSS values is required" Q
  1. I '$D(BEGDATE) S OUT="-4,BEGDATE required and may not be null" Q
  1. I '$D(ENDDATE) S OUT="-5,ENDDATE required and may not be null" Q
  1. ;
  1. I SORTORDER="ASCENDING" D
  1. . S DIRECTION=1
  1. . S STARTDATE=$$REVDATE(BEGDATE),STOPDATE=$$REVDATE(ENDDATE)
  1. . Q
  1. E I SORTORDER="DESCENDING" D
  1. . S DIRECTION=-1
  1. . S STARTDATE=$$REVDATE(ENDDATE),STOPDATE=$$REVDATE(BEGDATE)
  1. . Q
  1. E S OUT="-6,SORTORDER must be either ASCENDING or DESCENDING, not """_SORTORDER_"""" Q
  1. ;
  1. S NOUT=1
  1. ;
  1. S HIT=0 F I=1:1 Q:'$D(LRSSLIST(I)) S LRSS=LRSSLIST(I) I $D(^LR(LRDFN,LRSS)) D
  1. . S HIT=1,DONE=0,LRI=STARTDATE ; $O thru reverse dates
  1. . F S LRI=$O(^LR(LRDFN,LRSS,LRI),-DIRECTION) Q:'LRI Q:DONE D
  1. . . I DIRECTION=1,LRI<STOPDATE S DONE=1 Q
  1. . . I DIRECTION=-1,LRI>STOPDATE S DONE=1 Q
  1. . . D LOOKUP1(LRDFN,LRSS,LRI)
  1. . . Q
  1. . Q
  1. I NOUT=1 D
  1. . I 'HIT S OUT(1)="-7,Patient has no Anatomic Pathology (CY, EM, or SR) studies"
  1. . E S OUT(1)="-8,Patient has no Anatomic Pathology (CY, EM, or SR) images"
  1. . Q
  1. I '$D(OUT(1)) S OUT(1)=NOUT-1 ; allow error messages to be passed back in OUT(1)
  1. Q
  1. ;
  1. LOOKUP(OUT,LRDFN,LRSS,LRI) ; RPC = MAG DICOM GET LAB IMAGES
  1. N NOUT
  1. K OUT
  1. I '$D(LRDFN) S OUT="-1,LRDFN required and may not be null" Q
  1. I '$D(LRSS) S OUT="-2,LRSS required" Q
  1. I '$D(LRI) S OUT="-3,LRI required and may not be null" Q
  1. ;
  1. S NOUT=1
  1. ;
  1. D LOOKUP1(LRDFN,LRSS,LRI)
  1. ;
  1. I NOUT=1 D
  1. . S OUT(1)="-4,Patient has no Anatomic Pathology (CY, EM, or SR) images"
  1. . Q
  1. I '$D(OUT(1)) S OUT(1)=NOUT-1 ; allow error messages to be passed back in OUT(1)
  1. Q
  1. ;
  1. LOOKUP1(LRDFN,LRSS,LRI) ; lookup an anatomic pathology image
  1. ; Images can be assocated with the TIU External Data file (#8925.91),
  1. ; or DICOM LAB TEMP LIST file (#2006.5838), or stored in the new
  1. ; SOP Class database IMAGE STUDY file (#2005.62) -- check all three
  1. N ACNUMB,NODE0X,NODE0Y,PARENTFILE
  1. S NODE0X=$G(^LR(LRDFN,LRSS,0)) Q:NODE0X=""
  1. S PARENTFILE=+$P(NODE0X,"^",2) Q:'PARENTFILE
  1. S NODE0Y=^LR(LRDFN,LRSS,LRI,0),ACNUMB=$P(NODE0Y,"^",6)
  1. ; W !,"ACNUMB = ",ACNUMB
  1. D TIU(LRDFN,LRSS,LRI,ACNUMB) ; check the TIU External Data file (#8925.91)
  1. D LABTEMP(PARENTFILE,LRDFN,LRSS,LRI,ACNUMB) ; check the DICOM LAB TEMP LIST file (#2006.5838)
  1. D NEWSOP(LRSS,LRI,ACNUMB) ; check the new SOP Class database IMAGE STUDY file (#2005.62)
  1. Q
  1. ;
  1. TIU(LRDFN,LRSS,LRI,ACNUMB) ; check for images assocated with the TIU External Data file (#8925.91)
  1. N MAGIEN,NODE0,TIU892591IEN,TIUIEN
  1. I '$D(^LR(LRDFN,LRSS,LRI,.05,"C")) Q ; there is no TIU pointer
  1. S TIUIEN=0
  1. F S TIUIEN=$O(^LR(LRDFN,LRSS,LRI,.05,"C",TIUIEN)) Q:'TIUIEN D
  1. . S TIU892591IEN=""
  1. . F S TIU892591IEN=$O(^TIU(8925.91,"B",TIUIEN,TIU892591IEN)) Q:TIU892591IEN="" D
  1. . . S NODE0=^TIU(8925.91,TIU892591IEN,0)
  1. . . S MAGIEN=$P(NODE0,"^",2)
  1. . . S NOUT=NOUT+1,OUT(NOUT)=MAGIEN_"^"_ACNUMB_"^"_$$REVDATE(LRI)_"^"_LRSS_"^"_LRI
  1. . . Q
  1. . Q
  1. Q
  1. ;
  1. LABTEMP(PARENTFILE,LRDFN,LRSS,LRI,ACNUMB) ; check for images assocated with the DICOM LAB TEMP LIST file (#2006.5838)
  1. N MAG20065838IEN,MAGIEN,NODE0
  1. S MAG20065838IEN=0
  1. S MAG20065838IEN=$O(^MAG(2006.5838,"C",PARENTFILE,LRDFN,LRI,MAG20065838IEN)) Q:'MAG20065838IEN D
  1. . S NODE0=$G(^MAG(2006.5838,MAG20065838IEN,0)) Q:NODE0=""
  1. . S MAGIEN=$P(NODE0,"^",4)
  1. . S NOUT=NOUT+1,OUT(NOUT)=MAGIEN_"^"_ACNUMB_"^"_$$REVDATE(LRI)_"^"_LRSS_"^"_LRI
  1. . Q
  1. Q
  1. ;
  1. NEWSOP(LRSS,LRI,ACNUMB) ; check for images in the new SOP Class database IMAGE STUDY file (#2005.62)
  1. N MAGV200562
  1. S MAGV200562=0
  1. S MAGV200562=$O(^MAGV(2005.62,"D",ACNUMB,MAGV200562)) Q:'MAGV200562 D
  1. . S NOUT=NOUT+1,OUT(NOUT)="New SOP Class DB^"_ACNUMB_"^"_$$REVDATE(LRI)_"^"_LRSS_"^"_LRI
  1. . Q
  1. Q
  1. ;
  1. DATE(OUT,SUBSCRIPTLEVEL,SORTORDER,LRSS,DATE,LRDFN,LRI) ; RPC = MAG DICOM GET LAB BY DATE
  1. N DIRECTION,LRO
  1. K OUT
  1. I '$D(SUBSCRIPTLEVEL) S OUT="-1,SUBSCRIPT LEVEL required" Q
  1. I '$D(SORTORDER) S OUT="-2,SORTORDER required" Q
  1. I '$D(LRSS) S OUT="-3,LRSS required" Q
  1. I '$D(DATE) S OUT="-4,DATE required and may not be null" Q
  1. I '$D(LRDFN) S OUT="-5,LRDFN required and may not be null" Q
  1. I '$D(LRI) S OUT="-6,LRI required and may not be null" Q
  1. ;
  1. I SUBSCRIPTLEVEL'=1,SUBSCRIPTLEVEL'=2,SUBSCRIPTLEVEL'=3 S OUT="-7,SUBSCRIPT LEVEL must be either 1, 2, or 3, not """_SUBSCRIPTLEVEL_"""" q
  1. ;
  1. I SORTORDER="ASCENDING" D
  1. . S DIRECTION=1
  1. . Q
  1. E I SORTORDER="DESCENDING" D
  1. . S DIRECTION=-1
  1. . S:DATE=0 DATE="" S:LRDFN=0 LRDFN="" S:LRI=0 LRI="" ; needed for reverse $O
  1. . Q
  1. E S OUT="-8,SORTORDER must be either ASCENDING or DESCENDING, not """_SORTORDER_"""" Q
  1. ;
  1. S LRO="A"_LRSS
  1. ;
  1. ; ^LR(LRO,DATE,LRDFN,LRI)=""
  1. ;
  1. I SUBSCRIPTLEVEL=1 S OUT=$O(^LR(LRO,DATE),DIRECTION)
  1. E I SUBSCRIPTLEVEL=2 S OUT=$O(^LR(LRO,DATE,LRDFN),DIRECTION)
  1. E I SUBSCRIPTLEVEL=3 S OUT=$O(^LR(LRO,DATE,LRDFN,LRI),DIRECTION)
  1. ; I SUBSCRIPTLEVEL=3,LRI W !,"LR(""",LRO,""",",DATE,",",LRDFN,",",LRI,")"
  1. ; W !,"LR(""",LRO,""",",DATE,",",LRDFN,",",LRI,")"
  1. Q
  1. ;
  1. NXTLRDFN(OUT,SORTORDER,LRDFN,LRSSLIST) ; RPC = MAG DICOM GET LAB NEXT LRDFN
  1. N DIRECTION,HIT,I,LRSS
  1. I '$D(SORTORDER) S OUT="-1,SORTORDER required" Q
  1. I $G(LRDFN)="" S OUT="-2,LRDFN required and may not be null" Q
  1. I LRDFN'?1N.N S OUT="-3,LRDFN must be a numeric value, not ""_LRDFN_""" Q
  1. I SORTORDER="ASCENDING" D
  1. . S DIRECTION=1
  1. . Q
  1. E I SORTORDER="DESCENDING" D
  1. . S DIRECTION=-1
  1. . I LRDFN=0 S LRDFN=" " ; reverse $O origin
  1. . Q
  1. E S OUT="-4,SORTORDER must be either ASCENDING or DESCENDING, not """_SORTORDER_"""" Q
  1. ;
  1. I '$D(LRSSLIST) S OUT="-5,List of LRSS values is required" Q
  1. K OUT
  1. S HIT=0 F S LRDFN=+$O(^LR(LRDFN),DIRECTION) Q:LRDFN=0 D Q:HIT
  1. . F I=1:1 Q:'$D(LRSSLIST(I)) S LRSS=LRSSLIST(I) I $D(^LR(LRDFN,LRSS)) S HIT=1 Q
  1. . Q
  1. S OUT=+LRDFN
  1. ;
  1. Q
  1. ;
  1. REVDATE(DATE) ; convert a LAB date to a FM date and vice versa
  1. Q 9999999-DATE ; unlike radiology which uses 9999999.9999