- 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 Feb 18, 2025@23:36:56 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