MAGXCVI1 ;WOIFO/SEB,MLH - Image Index Conversion Generate - subroutines ; 15 Jul 2004 9:01 AM
;;3.0;IMAGING;**17,25,31**;Mar 31, 2005
;; +---------------------------------------------------------------+
;; | 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
;
GENINEW ; SUBROUTINE - Called from GENIEN^MAGXCVI.
; generate new index values for a set of lookup fields not previously indexed on
N INDXSPEC ; ----- specialty indexed to
N FILEXT ; ------- file extension for type override checking
N TYPE ; --------- type mapped to, for override checking
;
F FLDNUM=16,10,6,100,3,8 I $G(MAGVALS(FLDNUM,"I"))]"" D GENFLD
S FILEXT=$P($P($G(^MAG(2005,CHILD1,0)),U,2),".",2) ; for later checking
;
I $P(INDXDATA,U)="" S $P(INDXDATA,U)="NONE" ; package still has no value
;
I $P(INDXDATA,U,2)="" D ; class still has no value - base it on type
. S TYPE=$P(INDXDATA,U,3)
. I TYPE]"" S $P(INDXDATA,U,2)=$P($G(^MAG(2005.83,TYPE,0)),U,2)
. Q
;
; if class is ADMIN, no procedure or specialty
I $P(INDXDATA,U,2)=8 S $P(INDXDATA,U,4,5)=""
;
I $P(INDXDATA,U,3)="" D ; image type still has no value
. S $P(INDXDATA,U,3)=$S(FILEXT="TIF":45,1:75) ; document/image
. ; special check for documents
. I MAGVALS(3,"I")]"",$P($G(^MAG(2005.02,MAGVALS(3,"I"),0)),U)="DOCUMENT" D
. . I $P(INDXDATA,U,2)=1 D ; clinical
. . . S $P(INDXDATA,U,3)=$O(^MAG(2005.83,"B","MISCELLANEOUS DOCUMENT",""))
. . . Q
. . E I $P(INDXDATA,U,2)=8 D ; administrative
. . . S $P(INDXDATA,U,3)=$O(^MAG(2005.83,"B","MISCELLANEOUS",""))
. . . Q
. . Q
. Q
;
; if Type is ADVANCE DIRECTIVE or PHOTO ID: no Specialty;
; ADVANCE DIRECTIVE must always be Class CLIN/ADMIN;
; PHOTO ID must always be Class ADMIN/CLIN
I "^67^84^"[("^"_$P(INDXDATA,U,3)_"^") D
. S $P(INDXDATA,U,5)=""
. S $P(INDXDATA,U,2)=$S($P(INDXDATA,U,3)=67:7,1:9)
. Q
;
; if Type is ENDOSCOPY, delete Type if really non-Endo (i.e., from
; Medicine Package)
I $P(INDXDATA,U,4)=6 D
. I (" "_$TR($G(MAGVALS(6,"I")),"-","")_" ")[" NONENDO " S $P(INDXDATA,U,4)=""
. Q
;
; if no Procedure or Specialty, then...
; if no type, or an image, default to CLIN Class if no Class
I $P(INDXDATA,U,4)="",$P(INDXDATA,U,5)="" D
. I "^^75^"[("^"_$P(INDXDATA,U,3)_"^"),$P(INDXDATA,U,2)="" D
. . S $P(INDXDATA,U,2)=1
. . Q
. Q
;
; if Specialty is GI and parent file is ENDOSCOPY and current procedure isn't
; a GI procedure, map to ENDO Procedure
I $P(INDXDATA,U,5)=3,MAGVALS(16,"I")=699 D
. I '$D(^MAG(2005.85,+$P(INDXDATA,U,4),1,"B",3)) S $P(INDXDATA,U,4)=6
. Q
;
Q
;
GENFLD ; SUBROUTINE - Called from GENINEW.
; Generate indices for one field.
N D0 ; ----------- scratch array index
N I ; ------------ scratch string piece index
N INDXVAL ; ------ the index value we compute
N PRVVAL ; ------- the index value computed from a previous field mapping
;
S MAPDATA=""
I FLDNUM=3 D ; object type
. S MAGVALS(3,"I")=$$UCASE^MAGXCVP($$STRIP^MAGXCVP(MAGVALS(3,"I")))
. S MAPDATA=$P($G(^XTMP("MAG30P25","MAPPING",3,MAGVALS(3,"I"))),U,2,999)
. Q
I FLDNUM=6 D GENF06 ; procedure
I FLDNUM=8 D GENF08 ; image save by
I FLDNUM=10 D GENF10 ; short description
I FLDNUM=16 D ; parent data file
. S MAPDATA=$G(^MAG(2005.03,MAGVALS(16,"I"),2))
. ; make sure TIUs map properly for CP
. I MAGVALS(16,"I")=8925 D
. . I (" "_MAGVALS(6,"I")_" ")[" CP " S $P(MAPDATA,U)="CP"
. . Q
. Q
I FLDNUM=100 S MAPDATA=$G(^MAG(2005.81,MAGVALS(100,"I"),2)) ; doc category
; D0: 1=package, 2=class, 3=type, 4=procedure/event, 5=specialty, 6=origin
F D0=1:1:6 D
. S INDXVAL=$P($P(MAPDATA,U,D0),"-"),PRVVAL=$P(INDXDATA,U,D0)
. I INDXVAL]"" D
. . I $P(INDXDATA,U,D0)="" D
. . . S $P(INDXDATA,U,D0)=INDXVAL
. . . Q
. . E I D0=5,PRVVAL=48 D
. . . ; override previous Specialty of 'SURGERY' if a more precise mapping
. . . ; has been found
. . . S $P(INDXDATA,U,D0)=INDXVAL
. . . Q
. . Q
. Q
Q
;
GENF06 ; generate indices based on field 6 (Procedure)
; expects MAGVALS, U; returns MAPDATA
N TERM ; --- DICOM Modality Defined Term
N I ; ------ scratch index
N IVAL ; --- positional index value
;
S MAGVALS(6,"I")=$$UCASE^MAGXCVP($$STRIP^MAGXCVP($G(MAGVALS(6,"I"))))
I $E(MAGVALS(6,"I"),1,2)="+ " D
. S MAGVALS(6,"I")=$E(MAGVALS(6,"I"),3,$L(MAGVALS(6,"I")))
. Q
I MAGVALS(6,"I")[" TEMPLATE" D
. S MAGVALS(6,"I")=$P(MAGVALS(6,"I")," TEMPLATE")
. Q
I MAGVALS(6,"I")]"" D
. S MAPDATA=$P($G(^XTMP("MAG30P25","MAPPING",6,MAGVALS(6,"I"))),U,2,999)
. ; did they use a DICOM Modality Defined Term?
. S TERM=MAGVALS(6,"I")
. I $P(TERM," ")="RAD" S TERM=$P(TERM," ",2,999)
. I TERM]"",$D(^RAMIS(73.1,"B",TERM)) D
. . F I=1:1:6 D
. . . S IVAL=$P(MAPDATA,U,I)
. . . I IVAL]"" S $P(INDXDATA,U,I)=$P(IVAL,"-")
. . . Q
. . Q
. Q
I MAGVALS(6,"I")["NON VA" D
. S $P(INDXDATA,U,6)="N"
. Q
Q
;
GENF08 ; generate indices based on field 8
; expects MAGVALS, U; returns MAPDATA
; logic: strip trailing 'SERVICE', 'SECTION' and then trailing 'CARE';
; do not tokenize; exact match on mapping
N UTYPE ; ----- external value of service/section
N SVSECTXT ; -- service/section name, all caps and tokenized
;
S UTYPE=$$GET1^DIQ(200,MAGVALS(8,"I")_",",29,"E")
I UTYPE]"" D ; tokenize the service/section
. S SVSECTXT=$$STRIP^MAGXCVP($$UCASE^MAGXCVP(UTYPE))
. I UTYPE?.E1" SERVICE".1"S" S UTYPE=$P(UTYPE," SERVICE")
. I UTYPE?.E1" SECTION" S UTYPE=$P(UTYPE," SECTION")
. I UTYPE?.E1" CARE" S UTYPE=$P(UTYPE," CARE")
. S MAPDATA=$P($G(^XTMP("MAG30P25","MAPPING",8,UTYPE)),U,2,999)
. Q
Q
;
GENF10 ; generate indices based on field 10 (Short Description)
; returns MAPDATA
N CURMAP ; ---- current mapping value
N NEWMAP ; ---- new mapping value
N TOKSTR ; ---- a token string that we check for
N SHDSCTXT ; -- short description text
N TSTSPEC ; --- specialty mapped to, for override checking
;
S TOKSTR="",MAPDATA=""
S SHDSCTXT=(" "_$$SCRUBTKN^MAGXCVP($$UCASE^MAGXCVP(MAGVALS(10,"I")))_" ")
F S TOKSTR=$O(^XTMP("MAG30P25","MAPPING",10,TOKSTR)) Q:TOKSTR="" D
. ; Check *every* token - don't stop after the first hit.
. ; Set up test string for checking on a standard token boundary (space).
. S FLDDATA=$$UCASE^MAGXCVP($G(^XTMP("MAG30P25","MAPPING",10,TOKSTR)))
. I SHDSCTXT[(" "_$P(FLDDATA,U)_" ") D
. . F I=1:1:6 D
. . . S CURMAP=$P(MAPDATA,U,I),NEWMAP=$P(FLDDATA,U,I+1)
. . . ; overrides:
. . . ; map to a more precise Specialty than 'SURGERY'
. . . I I=5,NEWMAP]"",CURMAP=48 S $P(MAPDATA,U,I)=NEWMAP Q
. . . ;
. . . I CURMAP="" D
. . . . ; overrides:
. . . . ; don't map to Cardiac Cath if specialty other than Cardiology
. . . . I I=4,+NEWMAP=1 S TSTSPEC=$P(INDXDATA,U,5) I TSTSPEC,TSTSPEC-2 Q
. . . . S $P(MAPDATA,U,I)=NEWMAP
. . . . Q
. . . Q
. . Q
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGXCVI1 7738 printed Apr 09, 2024@21:00:58 Page 2
MAGXCVI1 ;WOIFO/SEB,MLH - Image Index Conversion Generate - subroutines ; 15 Jul 2004 9:01 AM
+1 ;;3.0;IMAGING;**17,25,31**;Mar 31, 2005
+2 ;; +---------------------------------------------------------------+
+3 ;; | Property of the US Government. |
+4 ;; | No permission to copy or redistribute this software is given. |
+5 ;; | Use of unreleased versions of this software requires the user |
+6 ;; | to execute a written test agreement with the VistA Imaging |
+7 ;; | Development Office of the Department of Veterans Affairs, |
+8 ;; | telephone (301) 734-0100. |
+9 ;; | |
+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
+18 ;
GENINEW ; SUBROUTINE - Called from GENIEN^MAGXCVI.
+1 ; generate new index values for a set of lookup fields not previously indexed on
+2 ; ----- specialty indexed to
NEW INDXSPEC
+3 ; ------- file extension for type override checking
NEW FILEXT
+4 ; --------- type mapped to, for override checking
NEW TYPE
+5 ;
+6 FOR FLDNUM=16,10,6,100,3,8
IF $GET(MAGVALS(FLDNUM,"I"))]""
DO GENFLD
+7 ; for later checking
SET FILEXT=$PIECE($PIECE($GET(^MAG(2005,CHILD1,0)),U,2),".",2)
+8 ;
+9 ; package still has no value
IF $PIECE(INDXDATA,U)=""
SET $PIECE(INDXDATA,U)="NONE"
+10 ;
+11 ; class still has no value - base it on type
IF $PIECE(INDXDATA,U,2)=""
Begin DoDot:1
+12 SET TYPE=$PIECE(INDXDATA,U,3)
+13 IF TYPE]""
SET $PIECE(INDXDATA,U,2)=$PIECE($GET(^MAG(2005.83,TYPE,0)),U,2)
+14 QUIT
End DoDot:1
+15 ;
+16 ; if class is ADMIN, no procedure or specialty
+17 IF $PIECE(INDXDATA,U,2)=8
SET $PIECE(INDXDATA,U,4,5)=""
+18 ;
+19 ; image type still has no value
IF $PIECE(INDXDATA,U,3)=""
Begin DoDot:1
+20 ; document/image
SET $PIECE(INDXDATA,U,3)=$SELECT(FILEXT="TIF":45,1:75)
+21 ; special check for documents
+22 IF MAGVALS(3,"I")]""
IF $PIECE($GET(^MAG(2005.02,MAGVALS(3,"I"),0)),U)="DOCUMENT"
Begin DoDot:2
+23 ; clinical
IF $PIECE(INDXDATA,U,2)=1
Begin DoDot:3
+24 SET $PIECE(INDXDATA,U,3)=$ORDER(^MAG(2005.83,"B","MISCELLANEOUS DOCUMENT",""))
+25 QUIT
End DoDot:3
+26 ; administrative
IF '$TEST
IF $PIECE(INDXDATA,U,2)=8
Begin DoDot:3
+27 SET $PIECE(INDXDATA,U,3)=$ORDER(^MAG(2005.83,"B","MISCELLANEOUS",""))
+28 QUIT
End DoDot:3
+29 QUIT
End DoDot:2
+30 QUIT
End DoDot:1
+31 ;
+32 ; if Type is ADVANCE DIRECTIVE or PHOTO ID: no Specialty;
+33 ; ADVANCE DIRECTIVE must always be Class CLIN/ADMIN;
+34 ; PHOTO ID must always be Class ADMIN/CLIN
+35 IF "^67^84^"[("^"_$PIECE(INDXDATA,U,3)_"^")
Begin DoDot:1
+36 SET $PIECE(INDXDATA,U,5)=""
+37 SET $PIECE(INDXDATA,U,2)=$SELECT($PIECE(INDXDATA,U,3)=67:7,1:9)
+38 QUIT
End DoDot:1
+39 ;
+40 ; if Type is ENDOSCOPY, delete Type if really non-Endo (i.e., from
+41 ; Medicine Package)
+42 IF $PIECE(INDXDATA,U,4)=6
Begin DoDot:1
+43 IF (" "_$TRANSLATE($GET(MAGVALS(6,"I")),"-","")_" ")[" NONENDO "
SET $PIECE(INDXDATA,U,4)=""
+44 QUIT
End DoDot:1
+45 ;
+46 ; if no Procedure or Specialty, then...
+47 ; if no type, or an image, default to CLIN Class if no Class
+48 IF $PIECE(INDXDATA,U,4)=""
IF $PIECE(INDXDATA,U,5)=""
Begin DoDot:1
+49 IF "^^75^"[("^"_$PIECE(INDXDATA,U,3)_"^")
IF $PIECE(INDXDATA,U,2)=""
Begin DoDot:2
+50 SET $PIECE(INDXDATA,U,2)=1
+51 QUIT
End DoDot:2
+52 QUIT
End DoDot:1
+53 ;
+54 ; if Specialty is GI and parent file is ENDOSCOPY and current procedure isn't
+55 ; a GI procedure, map to ENDO Procedure
+56 IF $PIECE(INDXDATA,U,5)=3
IF MAGVALS(16,"I")=699
Begin DoDot:1
+57 IF '$DATA(^MAG(2005.85,+$PIECE(INDXDATA,U,4),1,"B",3))
SET $PIECE(INDXDATA,U,4)=6
+58 QUIT
End DoDot:1
+59 ;
+60 QUIT
+61 ;
GENFLD ; SUBROUTINE - Called from GENINEW.
+1 ; Generate indices for one field.
+2 ; ----------- scratch array index
NEW D0
+3 ; ------------ scratch string piece index
NEW I
+4 ; ------ the index value we compute
NEW INDXVAL
+5 ; ------- the index value computed from a previous field mapping
NEW PRVVAL
+6 ;
+7 SET MAPDATA=""
+8 ; object type
IF FLDNUM=3
Begin DoDot:1
+9 SET MAGVALS(3,"I")=$$UCASE^MAGXCVP($$STRIP^MAGXCVP(MAGVALS(3,"I")))
+10 SET MAPDATA=$PIECE($GET(^XTMP("MAG30P25","MAPPING",3,MAGVALS(3,"I"))),U,2,999)
+11 QUIT
End DoDot:1
+12 ; procedure
IF FLDNUM=6
DO GENF06
+13 ; image save by
IF FLDNUM=8
DO GENF08
+14 ; short description
IF FLDNUM=10
DO GENF10
+15 ; parent data file
IF FLDNUM=16
Begin DoDot:1
+16 SET MAPDATA=$GET(^MAG(2005.03,MAGVALS(16,"I"),2))
+17 ; make sure TIUs map properly for CP
+18 IF MAGVALS(16,"I")=8925
Begin DoDot:2
+19 IF (" "_MAGVALS(6,"I")_" ")[" CP "
SET $PIECE(MAPDATA,U)="CP"
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
+22 ; doc category
IF FLDNUM=100
SET MAPDATA=$GET(^MAG(2005.81,MAGVALS(100,"I"),2))
+23 ; D0: 1=package, 2=class, 3=type, 4=procedure/event, 5=specialty, 6=origin
+24 FOR D0=1:1:6
Begin DoDot:1
+25 SET INDXVAL=$PIECE($PIECE(MAPDATA,U,D0),"-")
SET PRVVAL=$PIECE(INDXDATA,U,D0)
+26 IF INDXVAL]""
Begin DoDot:2
+27 IF $PIECE(INDXDATA,U,D0)=""
Begin DoDot:3
+28 SET $PIECE(INDXDATA,U,D0)=INDXVAL
+29 QUIT
End DoDot:3
+30 IF '$TEST
IF D0=5
IF PRVVAL=48
Begin DoDot:3
+31 ; override previous Specialty of 'SURGERY' if a more precise mapping
+32 ; has been found
+33 SET $PIECE(INDXDATA,U,D0)=INDXVAL
+34 QUIT
End DoDot:3
+35 QUIT
End DoDot:2
+36 QUIT
End DoDot:1
+37 QUIT
+38 ;
GENF06 ; generate indices based on field 6 (Procedure)
+1 ; expects MAGVALS, U; returns MAPDATA
+2 ; --- DICOM Modality Defined Term
NEW TERM
+3 ; ------ scratch index
NEW I
+4 ; --- positional index value
NEW IVAL
+5 ;
+6 SET MAGVALS(6,"I")=$$UCASE^MAGXCVP($$STRIP^MAGXCVP($GET(MAGVALS(6,"I"))))
+7 IF $EXTRACT(MAGVALS(6,"I"),1,2)="+ "
Begin DoDot:1
+8 SET MAGVALS(6,"I")=$EXTRACT(MAGVALS(6,"I"),3,$LENGTH(MAGVALS(6,"I")))
+9 QUIT
End DoDot:1
+10 IF MAGVALS(6,"I")[" TEMPLATE"
Begin DoDot:1
+11 SET MAGVALS(6,"I")=$PIECE(MAGVALS(6,"I")," TEMPLATE")
+12 QUIT
End DoDot:1
+13 IF MAGVALS(6,"I")]""
Begin DoDot:1
+14 SET MAPDATA=$PIECE($GET(^XTMP("MAG30P25","MAPPING",6,MAGVALS(6,"I"))),U,2,999)
+15 ; did they use a DICOM Modality Defined Term?
+16 SET TERM=MAGVALS(6,"I")
+17 IF $PIECE(TERM," ")="RAD"
SET TERM=$PIECE(TERM," ",2,999)
+18 IF TERM]""
IF $DATA(^RAMIS(73.1,"B",TERM))
Begin DoDot:2
+19 FOR I=1:1:6
Begin DoDot:3
+20 SET IVAL=$PIECE(MAPDATA,U,I)
+21 IF IVAL]""
SET $PIECE(INDXDATA,U,I)=$PIECE(IVAL,"-")
+22 QUIT
End DoDot:3
+23 QUIT
End DoDot:2
+24 QUIT
End DoDot:1
+25 IF MAGVALS(6,"I")["NON VA"
Begin DoDot:1
+26 SET $PIECE(INDXDATA,U,6)="N"
+27 QUIT
End DoDot:1
+28 QUIT
+29 ;
GENF08 ; generate indices based on field 8
+1 ; expects MAGVALS, U; returns MAPDATA
+2 ; logic: strip trailing 'SERVICE', 'SECTION' and then trailing 'CARE';
+3 ; do not tokenize; exact match on mapping
+4 ; ----- external value of service/section
NEW UTYPE
+5 ; -- service/section name, all caps and tokenized
NEW SVSECTXT
+6 ;
+7 SET UTYPE=$$GET1^DIQ(200,MAGVALS(8,"I")_",",29,"E")
+8 ; tokenize the service/section
IF UTYPE]""
Begin DoDot:1
+9 SET SVSECTXT=$$STRIP^MAGXCVP($$UCASE^MAGXCVP(UTYPE))
+10 IF UTYPE?.E1" SERVICE".1"S"
SET UTYPE=$PIECE(UTYPE," SERVICE")
+11 IF UTYPE?.E1" SECTION"
SET UTYPE=$PIECE(UTYPE," SECTION")
+12 IF UTYPE?.E1" CARE"
SET UTYPE=$PIECE(UTYPE," CARE")
+13 SET MAPDATA=$PIECE($GET(^XTMP("MAG30P25","MAPPING",8,UTYPE)),U,2,999)
+14 QUIT
End DoDot:1
+15 QUIT
+16 ;
GENF10 ; generate indices based on field 10 (Short Description)
+1 ; returns MAPDATA
+2 ; ---- current mapping value
NEW CURMAP
+3 ; ---- new mapping value
NEW NEWMAP
+4 ; ---- a token string that we check for
NEW TOKSTR
+5 ; -- short description text
NEW SHDSCTXT
+6 ; --- specialty mapped to, for override checking
NEW TSTSPEC
+7 ;
+8 SET TOKSTR=""
SET MAPDATA=""
+9 SET SHDSCTXT=(" "_$$SCRUBTKN^MAGXCVP($$UCASE^MAGXCVP(MAGVALS(10,"I")))_" ")
+10 FOR
SET TOKSTR=$ORDER(^XTMP("MAG30P25","MAPPING",10,TOKSTR))
if TOKSTR=""
QUIT
Begin DoDot:1
+11 ; Check *every* token - don't stop after the first hit.
+12 ; Set up test string for checking on a standard token boundary (space).
+13 SET FLDDATA=$$UCASE^MAGXCVP($GET(^XTMP("MAG30P25","MAPPING",10,TOKSTR)))
+14 IF SHDSCTXT[(" "_$PIECE(FLDDATA,U)_" ")
Begin DoDot:2
+15 FOR I=1:1:6
Begin DoDot:3
+16 SET CURMAP=$PIECE(MAPDATA,U,I)
SET NEWMAP=$PIECE(FLDDATA,U,I+1)
+17 ; overrides:
+18 ; map to a more precise Specialty than 'SURGERY'
+19 IF I=5
IF NEWMAP]""
IF CURMAP=48
SET $PIECE(MAPDATA,U,I)=NEWMAP
QUIT
+20 ;
+21 IF CURMAP=""
Begin DoDot:4
+22 ; overrides:
+23 ; don't map to Cardiac Cath if specialty other than Cardiology
+24 IF I=4
IF +NEWMAP=1
SET TSTSPEC=$PIECE(INDXDATA,U,5)
IF TSTSPEC
IF TSTSPEC-2
QUIT
+25 SET $PIECE(MAPDATA,U,I)=NEWMAP
+26 QUIT
End DoDot:4
+27 QUIT
End DoDot:3
+28 QUIT
End DoDot:2
+29 QUIT
End DoDot:1
+30 QUIT
