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

MAGVRS82.m

Go to the documentation of this file.
  1. MAGVRS82 ;WOIFO/MLH - RPC calls for DICOM file processing ; 12 Apr 2010 5:48 PM
  1. ;;3.0;IMAGING;**118**;Mar 19, 2002;Build 4525;May 01, 2013
  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. Q
  1. GETCPROC(OUT,CONNUM) ; Call from GETPROCI^MAGVRS08 - get consult procedure information
  1. N CONIX,CONREC,CONSCODPTR,CONSCODFIL,CONSCOD,TERMGY,CONSDESC,TIUPTR,OUTIX,CONSDT,REFPHY
  1. I CONNUM="" S OUT(1)="-41"_SSEP_SSEP_"No consult number provided" Q
  1. ;
  1. S CONSCODPTR=$$GET1^DIQ(123,CONNUM,4,"I") ; IA #4110
  1. D:CONSCODPTR[";" ; variable pointer populated?
  1. . ; yes
  1. . S CONSCODFIL=+$P($P(CONSCODPTR,";",2),"(",2)
  1. . S CONSCOD=$P(CONSCODPTR,";",1)
  1. . Q
  1. S CONSDESC=$$GET1^DIQ(123,CONNUM,4,"E") ; IA #4110
  1. S TERMGY=$G(CONSCODFIL)
  1. S REFPHY=$$GET1^DIQ(123,CONNUM,10,"E")
  1. S:REFPHY="" REFPHY=$$GET1^DIQ(123,CONNUM,.126,"E")
  1. S TIUPTR=$$GET1^DIQ(123,CONNUM,16,"I")
  1. S:TIUPTR CONSDT=$$GET1^DIQ(8925,TIUPTR,1201,"I")
  1. ;
  1. S OUTIX=0
  1. D:$G(CONSDESC)'="" POP(.OUT,"DESCRIPTION",CONSDESC)
  1. D:$G(CONSDT)'="" POP(.OUT,"DATE/TIME",(17000000+$P(CONSDT,".",1))_"."_$P($J(CONSDT#1,0,6),".",2))
  1. D:$G(CONSCOD)'="" POP(.OUT,"PROCEDURE CODE",CONSCOD)
  1. D:$G(TERMGY)'="" POP(.OUT,"TERMINOLOGY",TERMGY)
  1. D POP(.OUT,"CODING AUTHORITY","USDVA")
  1. D:$G(REFPHY)'="" POP(.OUT,"REFERRING PHYSICIAN",REFPHY)
  1. Q
  1. GETCRPT(OUT,CONNUM) ; Call from GETPROCI^MAGVRS08 - get a consult report (TIU note)
  1. N RPTIX,TIUIX,DOCTYPE,EDAT,XDAT,TEXT,RET,ERR,OSEP,ISEP,SSEP
  1. S OSEP=$$OUTSEP^MAGVRS41,ISEP=$$INPUTSEP^MAGVRS41,SSEP=$$STATSEP^MAGVRS41
  1. I CONNUM="" S OUT(1)="-61"_SSEP_SSEP_"No consult number provided" Q
  1. I '$D(^GMR(123,CONNUM)) S OUT(1)="-62"_SSEP_SSEP_"No record on file for this consult" Q
  1. S TIUIX=$$GET1^DIQ(123,CONNUM_",",16,"I") ; ICR 4110
  1. I 'TIUIX S OUT(1)="-63"_SSEP_SSEP_"No TIU note on file for this consult" Q
  1. S DOCTYPE=$$GET1^DIQ(8925,TIUIX_",",".01","E")
  1. I DOCTYPE="" S OUT(1)="-64"_SSEP_SSEP_"No TIU note on file for this consult" Q
  1. D POP(.OUT,"DOCUMENT TYPE",DOCTYPE)
  1. S RET=$$GET1^DIQ(8925,TIUIX_",","2",,"TEXT")
  1. I '$D(TEXT) S OUT(1)="-65"_SSEP_SSEP_"No report text on file for this consult's TIU note" Q
  1. S EDAT=$$GET1^DIQ(8925,TIUIX_",","1201","I")
  1. D:EDAT POP(.OUT,"ENTRY DATE/TIME",$$CVTDT(EDAT))
  1. S XDAT=$$GET1^DIQ(8925,TIUIX_",",".08","I")
  1. D:XDAT POP(.OUT,"EPISODE END DATE/TIME",$$CVTDT(EDAT))
  1. D POP(.OUT,"REPORT TEXT",.TEXT)
  1. Q
  1. CVTDT(FMDT) ; convert from FM to ISO date
  1. Q (17000000+$P(FMDT,".",1))_"."_$P($J(FMDT#1,0,6),".",2)
  1. POP(ARY,NAME,VALUE) ; populate an array with a name value pair
  1. N IX
  1. S:$D(VALUE)#10 ARY($O(ARY(" "),-1)+1)=NAME_OSEP_VALUE_SSEP
  1. S IX=0
  1. F S IX=$O(VALUE(IX)) Q:'IX S ARY($O(ARY(" "),-1)+1)=NAME_OSEP_VALUE(IX)_SSEP
  1. Q