MAGVRS82 ;WOIFO/MLH - RPC calls for DICOM file processing ; 12 Apr 2010 5:48 PM
;;3.0;IMAGING;**118**;Mar 19, 2002;Build 4525;May 01, 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
GETCPROC(OUT,CONNUM) ; Call from GETPROCI^MAGVRS08 - get consult procedure information
N CONIX,CONREC,CONSCODPTR,CONSCODFIL,CONSCOD,TERMGY,CONSDESC,TIUPTR,OUTIX,CONSDT,REFPHY
I CONNUM="" S OUT(1)="-41"_SSEP_SSEP_"No consult number provided" Q
;
S CONSCODPTR=$$GET1^DIQ(123,CONNUM,4,"I") ; IA #4110
D:CONSCODPTR[";" ; variable pointer populated?
. ; yes
. S CONSCODFIL=+$P($P(CONSCODPTR,";",2),"(",2)
. S CONSCOD=$P(CONSCODPTR,";",1)
. Q
S CONSDESC=$$GET1^DIQ(123,CONNUM,4,"E") ; IA #4110
S TERMGY=$G(CONSCODFIL)
S REFPHY=$$GET1^DIQ(123,CONNUM,10,"E")
S:REFPHY="" REFPHY=$$GET1^DIQ(123,CONNUM,.126,"E")
S TIUPTR=$$GET1^DIQ(123,CONNUM,16,"I")
S:TIUPTR CONSDT=$$GET1^DIQ(8925,TIUPTR,1201,"I")
;
S OUTIX=0
D:$G(CONSDESC)'="" POP(.OUT,"DESCRIPTION",CONSDESC)
D:$G(CONSDT)'="" POP(.OUT,"DATE/TIME",(17000000+$P(CONSDT,".",1))_"."_$P($J(CONSDT#1,0,6),".",2))
D:$G(CONSCOD)'="" POP(.OUT,"PROCEDURE CODE",CONSCOD)
D:$G(TERMGY)'="" POP(.OUT,"TERMINOLOGY",TERMGY)
D POP(.OUT,"CODING AUTHORITY","USDVA")
D:$G(REFPHY)'="" POP(.OUT,"REFERRING PHYSICIAN",REFPHY)
Q
GETCRPT(OUT,CONNUM) ; Call from GETPROCI^MAGVRS08 - get a consult report (TIU note)
N RPTIX,TIUIX,DOCTYPE,EDAT,XDAT,TEXT,RET,ERR,OSEP,ISEP,SSEP
S OSEP=$$OUTSEP^MAGVRS41,ISEP=$$INPUTSEP^MAGVRS41,SSEP=$$STATSEP^MAGVRS41
I CONNUM="" S OUT(1)="-61"_SSEP_SSEP_"No consult number provided" Q
I '$D(^GMR(123,CONNUM)) S OUT(1)="-62"_SSEP_SSEP_"No record on file for this consult" Q
S TIUIX=$$GET1^DIQ(123,CONNUM_",",16,"I") ; ICR 4110
I 'TIUIX S OUT(1)="-63"_SSEP_SSEP_"No TIU note on file for this consult" Q
S DOCTYPE=$$GET1^DIQ(8925,TIUIX_",",".01","E")
I DOCTYPE="" S OUT(1)="-64"_SSEP_SSEP_"No TIU note on file for this consult" Q
D POP(.OUT,"DOCUMENT TYPE",DOCTYPE)
S RET=$$GET1^DIQ(8925,TIUIX_",","2",,"TEXT")
I '$D(TEXT) S OUT(1)="-65"_SSEP_SSEP_"No report text on file for this consult's TIU note" Q
S EDAT=$$GET1^DIQ(8925,TIUIX_",","1201","I")
D:EDAT POP(.OUT,"ENTRY DATE/TIME",$$CVTDT(EDAT))
S XDAT=$$GET1^DIQ(8925,TIUIX_",",".08","I")
D:XDAT POP(.OUT,"EPISODE END DATE/TIME",$$CVTDT(EDAT))
D POP(.OUT,"REPORT TEXT",.TEXT)
Q
CVTDT(FMDT) ; convert from FM to ISO date
Q (17000000+$P(FMDT,".",1))_"."_$P($J(FMDT#1,0,6),".",2)
POP(ARY,NAME,VALUE) ; populate an array with a name value pair
N IX
S:$D(VALUE)#10 ARY($O(ARY(" "),-1)+1)=NAME_OSEP_VALUE_SSEP
S IX=0
F S IX=$O(VALUE(IX)) Q:'IX S ARY($O(ARY(" "),-1)+1)=NAME_OSEP_VALUE(IX)_SSEP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGVRS82 3635 printed Apr 09, 2024@21:07:06 Page 2
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
+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
GETCPROC(OUT,CONNUM) ; Call from GETPROCI^MAGVRS08 - get consult procedure information
+1 NEW CONIX,CONREC,CONSCODPTR,CONSCODFIL,CONSCOD,TERMGY,CONSDESC,TIUPTR,OUTIX,CONSDT,REFPHY
+2 IF CONNUM=""
SET OUT(1)="-41"_SSEP_SSEP_"No consult number provided"
QUIT
+3 ;
+4 ; IA #4110
SET CONSCODPTR=$$GET1^DIQ(123,CONNUM,4,"I")
+5 ; variable pointer populated?
if CONSCODPTR[";"
Begin DoDot:1
+6 ; yes
+7 SET CONSCODFIL=+$PIECE($PIECE(CONSCODPTR,";",2),"(",2)
+8 SET CONSCOD=$PIECE(CONSCODPTR,";",1)
+9 QUIT
End DoDot:1
+10 ; IA #4110
SET CONSDESC=$$GET1^DIQ(123,CONNUM,4,"E")
+11 SET TERMGY=$GET(CONSCODFIL)
+12 SET REFPHY=$$GET1^DIQ(123,CONNUM,10,"E")
+13 if REFPHY=""
SET REFPHY=$$GET1^DIQ(123,CONNUM,.126,"E")
+14 SET TIUPTR=$$GET1^DIQ(123,CONNUM,16,"I")
+15 if TIUPTR
SET CONSDT=$$GET1^DIQ(8925,TIUPTR,1201,"I")
+16 ;
+17 SET OUTIX=0
+18 if $GET(CONSDESC)'=""
DO POP(.OUT,"DESCRIPTION",CONSDESC)
+19 if $GET(CONSDT)'=""
DO POP(.OUT,"DATE/TIME",(17000000+$PIECE(CONSDT,".",1))_"."_$PIECE($JUSTIFY(CONSDT#1,0,6),".",2))
+20 if $GET(CONSCOD)'=""
DO POP(.OUT,"PROCEDURE CODE",CONSCOD)
+21 if $GET(TERMGY)'=""
DO POP(.OUT,"TERMINOLOGY",TERMGY)
+22 DO POP(.OUT,"CODING AUTHORITY","USDVA")
+23 if $GET(REFPHY)'=""
DO POP(.OUT,"REFERRING PHYSICIAN",REFPHY)
+24 QUIT
GETCRPT(OUT,CONNUM) ; Call from GETPROCI^MAGVRS08 - get a consult report (TIU note)
+1 NEW RPTIX,TIUIX,DOCTYPE,EDAT,XDAT,TEXT,RET,ERR,OSEP,ISEP,SSEP
+2 SET OSEP=$$OUTSEP^MAGVRS41
SET ISEP=$$INPUTSEP^MAGVRS41
SET SSEP=$$STATSEP^MAGVRS41
+3 IF CONNUM=""
SET OUT(1)="-61"_SSEP_SSEP_"No consult number provided"
QUIT
+4 IF '$DATA(^GMR(123,CONNUM))
SET OUT(1)="-62"_SSEP_SSEP_"No record on file for this consult"
QUIT
+5 ; ICR 4110
SET TIUIX=$$GET1^DIQ(123,CONNUM_",",16,"I")
+6 IF 'TIUIX
SET OUT(1)="-63"_SSEP_SSEP_"No TIU note on file for this consult"
QUIT
+7 SET DOCTYPE=$$GET1^DIQ(8925,TIUIX_",",".01","E")
+8 IF DOCTYPE=""
SET OUT(1)="-64"_SSEP_SSEP_"No TIU note on file for this consult"
QUIT
+9 DO POP(.OUT,"DOCUMENT TYPE",DOCTYPE)
+10 SET RET=$$GET1^DIQ(8925,TIUIX_",","2",,"TEXT")
+11 IF '$DATA(TEXT)
SET OUT(1)="-65"_SSEP_SSEP_"No report text on file for this consult's TIU note"
QUIT
+12 SET EDAT=$$GET1^DIQ(8925,TIUIX_",","1201","I")
+13 if EDAT
DO POP(.OUT,"ENTRY DATE/TIME",$$CVTDT(EDAT))
+14 SET XDAT=$$GET1^DIQ(8925,TIUIX_",",".08","I")
+15 if XDAT
DO POP(.OUT,"EPISODE END DATE/TIME",$$CVTDT(EDAT))
+16 DO POP(.OUT,"REPORT TEXT",.TEXT)
+17 QUIT
CVTDT(FMDT) ; convert from FM to ISO date
+1 QUIT (17000000+$PIECE(FMDT,".",1))_"."_$PIECE($JUSTIFY(FMDT#1,0,6),".",2)
POP(ARY,NAME,VALUE) ; populate an array with a name value pair
+1 NEW IX
+2 if $DATA(VALUE)#10
SET ARY($ORDER(ARY(" "),-1)+1)=NAME_OSEP_VALUE_SSEP
+3 SET IX=0
+4 FOR
SET IX=$ORDER(VALUE(IX))
if 'IX
QUIT
SET ARY($ORDER(ARY(" "),-1)+1)=NAME_OSEP_VALUE(IX)_SSEP
+5 QUIT
