203 lines
8.7 KiB
Mathematica
203 lines
8.7 KiB
Mathematica
MAGXCVE ;WOIFO/SEB,MLH - Image File Conversion Utilities & Misc. options ; 13 Aug 2003 1:24 PM
|
|
;;3.0;IMAGING;**25**;Sep 4, 2003
|
|
;; +---------------------------------------------------------------+
|
|
;; | 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
|
|
;
|
|
; Entry point for the Mapping File Edit option (MAG IMAGE INDEX MAP EDIT)
|
|
EDIT ;
|
|
I '$D(^XTMP("MAG30P25","MAPPING")) D I $D(DTOUT)!$D(DUOUT) Q
|
|
. K DIR S DIR(0)="YU"
|
|
. S DIR("A",1)="No mapping entries found."
|
|
. S DIR("A")="Do you want to import a mapping file",DIR("B")="NO"
|
|
. D ^DIR
|
|
. I Y D EN^MAGXCVL
|
|
. Q
|
|
D MENU
|
|
Q
|
|
;
|
|
; List of files available in the Mapping File Edit option.
|
|
MENU ;
|
|
K DIR S DIR(0)="SUO^1:Short Description Keyword;2:Procedure;"
|
|
S DIR(0)=DIR(0)_"3:Parent Data File;4:Document Category;5:Object Type;"
|
|
S DIR(0)=DIR(0)_"6:Service/Section"
|
|
S DIR("A")="Please choose a file to edit, or <enter> to exit"
|
|
D ^DIR
|
|
I $D(DTOUT)!$D(DUOUT) Q
|
|
I Y="" Q
|
|
D LOOKUP(Y)
|
|
G MENU
|
|
;
|
|
; Look up values in the mappable files.
|
|
LOOKUP(INPUT) N FILENUM,FLDNUM,FILELIST,DIC,Y,ITEMNUM,ITEMTXT,ANS,CT
|
|
S FILENUM=$P("-1^-1^2005.03^2005.81^2005.02^49",U,INPUT)
|
|
S FLDNUM=$P("10^6^16^100^3^8",U,INPUT)
|
|
S FILELIST="Short Description^Procedure^Parent Data File^Document Category"
|
|
S FILELIST=FILELIST_"^Object Type^Service/Section"
|
|
S DIC("A")="Select "_$P(FILELIST,U,INPUT)_": "
|
|
I INPUT>2 D
|
|
. F D I Y=-1 Q
|
|
. . W ! S DIC=FILENUM,DIC(0)="AENQ" D ^DIC I Y=-1 Q
|
|
. . S ITEMNUM=$P(Y,U),ITEMTXT=$P(Y,U,2) D FILE(FLDNUM,ITEMNUM,ITEMTXT)
|
|
. . Q
|
|
. Q
|
|
E D
|
|
. F D PRLOOKUP(.ITEMTXT,FLDNUM) I ITEMTXT="" Q
|
|
. Q
|
|
Q
|
|
;
|
|
; Custom lookup for the procedures, which is a free text field.
|
|
PRLOOKUP(ITEMTXT,FLDNUM) N CT,ANS,LASTSUB
|
|
PR1 ;
|
|
; Can't use ^DIR here because of the way we have to process input of '?'.
|
|
W !!,"Select ",$S(FLDNUM=10:"Short Description",1:"Procedure Name"),": " R ITEMTXT:DTIME I ITEMTXT="" Q
|
|
S ITEMTXT=$$UCASE^MAGXCVP(ITEMTXT)
|
|
I $E(ITEMTXT)="?" S (ANS,ITEMTXT)="" D G PR1
|
|
. F CT=1:1 S ITEMTXT=$O(^XTMP("MAG30P25","MAPPING",FLDNUM,ITEMTXT)) Q:ITEMTXT=""!(ANS="^") D
|
|
. . W !?3,ITEMTXT
|
|
. . I CT#IOSL=0 R !?3,"'^' TO STOP: ",ANS:DTIME I ANS="^" Q
|
|
. . Q
|
|
. Q
|
|
I $E(ITEMTXT)="^" S ITEMTXT="" Q
|
|
S LASTSUB=$S(FLDNUM=10:"LASTDESC",1:"LASTPROC")
|
|
I ITEMTXT=" " S ITEMTXT=$G(^XTMP("MAG30P25",LASTSUB)) W " ",$S(ITEMTXT="":"??",1:ITEMTXT) I ITEMTXT="" G PR1
|
|
S ^XTMP("MAG30P25",LASTSUB)=ITEMTXT
|
|
I '$D(^XTMP("MAG30P25","MAPPING",FLDNUM,ITEMTXT)) D I ANS="N" Q
|
|
. W !!,"Do you want to add '",ITEMTXT,"' to the mapping file? N // " R ANS:DTIME
|
|
. I "Nn"[$E(ANS) S ANS="N" W !!,"OK, entry not added."
|
|
. Q
|
|
D FILE(FLDNUM,ITEMTXT,ITEMTXT)
|
|
Q
|
|
;
|
|
; Get values for an item described by ITEMNUM and ITEMTXT from file FLDNUM.
|
|
FILE(FLDNUM,ITEMIX,ITEMTXT) N MAPDATA,FLDNFO,CODES,CODE,PC,PKG,DIC,X,Y,VALUE,PKGFND,CH2
|
|
N AUDREC ; ---- audit record for later reapplication if needed
|
|
N NEWDATA ; --- new data to be applied to the mapping file (and audit)
|
|
N CODES ; ----- array for sets of codes
|
|
N PAIR ; ------ code-value pair
|
|
;
|
|
S MAPDATA=$P($G(^XTMP("MAG30P25","MAPPING",FLDNUM,ITEMIX)),U,2,7)
|
|
;
|
|
; Get a value for Package.
|
|
PKG S VALUE=$P(MAPDATA,U) I VALUE="" S VALUE="(none)"
|
|
W !,"Package: ",VALUE," // " R PKG:DTIME S PKG=$$UCASE^MAGXCVP(PKG)
|
|
I $E(PKG)="^" S CH2=$E(PKG,2) G PKG:CH2="P",CLS:CH2="C",TYP:CH2="T",PRC:CH2="E",SPC:CH2="S",ORG:CH2="O" I CH2="" S Y="" G END
|
|
I PKG=" " S PKG=$G(^XTMP("MAG30P25","LASTPKG")) W " ",$S(PKG="":"??",1:PKG) I PKG="" G PKG
|
|
I PKG="@",VALUE="(none)" W !,"No value to delete." G PKG
|
|
I PKG="@" S:$$DELETE^MAGXCVH $P(MAPDATA,U)="" G END:$D(DTOUT)!$D(DUOUT),PKG
|
|
D FIELD^DID(2005,40,"","POINTER","FLDNFO") K CODES
|
|
F PC=1:1 S CODE=$P($P(FLDNFO("POINTER"),";",PC),":") Q:CODE="" S CODES(CODE)=""
|
|
I $E(PKG)="?" D W ! G PKG
|
|
. D HELP^MAGXCVH(1) W !,"Valid packages are:"
|
|
. S CODE="" F S CODE=$O(CODES(CODE)) Q:CODE="" W !,CODE
|
|
. Q
|
|
I PKG'="" S PKG=$$PKGPARSE(PKG)
|
|
S ^XTMP("MAG30P25","LASTPKG")=$S(PKG="":$P(MAPDATA,U),1:PKG)
|
|
I PKG="" G CLS
|
|
I PKG]"",'$D(CODES(PKG)) W !,"Unknown package code. Please try again." G PKG
|
|
I PKG]"" W " ",PKG S $P(MAPDATA,U)=PKG
|
|
;
|
|
; Get a value for Class.
|
|
CLS S VALUE=$P($P(MAPDATA,U,2),"-",2) I VALUE="" S VALUE="(none)"
|
|
W !,"Class: ",VALUE," // " R X:DTIME
|
|
I $E(X)="^" S CH2=$E(X,2) G PKG:CH2="P",CLS:CH2="C",TYP:CH2="T",PRC:CH2="E",SPC:CH2="S",ORG:CH2="O",END:CH2=""
|
|
I X="" G TYP
|
|
I X="@",VALUE="(none)" W !,"No value to delete." G CLS
|
|
I X="@" S:$$DELETE^MAGXCVH $P(MAPDATA,U,2)="" G END:$D(DTOUT)!$D(DUOUT),CLS
|
|
I $E(X)="?" D HELP^MAGXCVH(2)
|
|
S DIC=2005.82,DIC(0)="ENQ" D ^DIC I Y=-1 W ! G CLS
|
|
I Y'=-1 S $P(MAPDATA,U,2)=$TR(Y,U,"-")
|
|
;
|
|
; Get a value for Type.
|
|
TYP S VALUE=$P($P(MAPDATA,U,3),"-",2) I VALUE="" S VALUE="(none)"
|
|
W !,"Type: "_VALUE_" // " R X:DTIME
|
|
I $E(X)="^" S CH2=$E(X,2) G PKG:CH2="P",CLS:CH2="C",TYP:CH2="T",PRC:CH2="E",SPC:CH2="S",ORG:CH2="O",END:CH2=""
|
|
I X="" G PRC
|
|
I X="@",VALUE="(none)" W !,"No value to delete." G TYP
|
|
I X="@" S:$$DELETE^MAGXCVH $P(MAPDATA,U,3)="" G END:$D(DTOUT)!$D(DUOUT),TYP
|
|
I $E(X)="?" D HELP^MAGXCVH(3)
|
|
S DIC=2005.83,DIC(0)="ENQ" D ^DIC I Y=-1 W ! G TYP
|
|
I Y'=-1 S $P(MAPDATA,U,3)=$TR(Y,U,"-")
|
|
;
|
|
; Get a value for Procedure.
|
|
PRC S VALUE=$P($P(MAPDATA,U,4),"-",2) I VALUE="" S VALUE="(none)"
|
|
W !,"Procedure/Event: "_VALUE_" // " R X:DTIME
|
|
I $E(X)="^" S CH2=$E(X,2) G PKG:CH2="P",CLS:CH2="C",TYP:CH2="T",PRC:CH2="E",SPC:CH2="S",ORG:CH2="O",END:CH2=""
|
|
I X="" G SPC
|
|
I X="@",VALUE="(none)" W !,"No value to delete." G PRC
|
|
I X="@" S:$$DELETE^MAGXCVH $P(MAPDATA,U,4)="" G END:$D(DTOUT)!$D(DUOUT),PRC
|
|
I $E(X)="?" D HELP^MAGXCVH(4)
|
|
S DIC=2005.85,DIC(0)="ENQ" D ^DIC I Y=-1 W ! G PRC
|
|
I Y'=-1 S $P(MAPDATA,U,4)=$TR(Y,U,"-")
|
|
;
|
|
; Get a value for Specialty.
|
|
SPC S VALUE=$P($P(MAPDATA,U,5),"-",2) I VALUE="" S VALUE="(none)"
|
|
W !,"Specialty: "_VALUE_" // " R X:DTIME
|
|
I $E(X)="^" S CH2=$E(X,2) G PKG:CH2="P",CLS:CH2="C",TYP:CH2="T",PRC:CH2="E",SPC:CH2="S",ORG:CH2="O",END:CH2=""
|
|
I X="" G ORG
|
|
I X="@",VALUE="(none)" W !,"No value to delete." G SPC
|
|
I X="@" S:$$DELETE^MAGXCVH $P(MAPDATA,U,5)="" G END:$D(DTOUT)!$D(DUOUT),SPC
|
|
I $E(X)="?" D HELP^MAGXCVH(5)
|
|
S DIC=2005.84,DIC(0)="ENQ" D ^DIC I Y=-1 W ! G SPC
|
|
I Y'=-1 S $P(MAPDATA,U,5)=$TR(Y,U,"-")
|
|
;
|
|
; Get a value for Origin.
|
|
ORG D FIELD^DID(2005,45,"","POINTER","FLDNFO") K CODES
|
|
F PC=1:1:$L(FLDNFO("POINTER"),";") D
|
|
. S PAIR=$P(FLDNFO("POINTER"),";",PC)
|
|
. S CODE=$P(PAIR,":") I CODE]"" S CODES(CODE)=$P(PAIR,":",2)
|
|
. Q
|
|
S VALUE=$P(MAPDATA,U,6) I VALUE]"" S VALUE=$G(CODES(VALUE))
|
|
W !,"Origin: "_VALUE_" // " R X:DTIME E Q
|
|
I $E(X)="^" S CH2=$E(X,2) G PKG:CH2="P",CLS:CH2="C",TYP:CH2="T",PRC:CH2="E",SPC:CH2="S",ORG:CH2="O",END:CH2=""
|
|
S ORG=X I ORG="" G END
|
|
I ORG="@",VALUE="(none)" W !,"No value to delete." G ORG
|
|
I ORG="@" S:$$DELETE^MAGXCVH $P(MAPDATA,U,6)="" G END:$D(DTOUT)!$D(DUOUT),ORG
|
|
I $E(ORG)="?" D W ! G ORG
|
|
. D HELP^MAGXCVH(1) W !,"Valid origins are as follows:"
|
|
. S CODE="" F S CODE=$O(CODES(CODE)) Q:CODE="" W !,?3,CODE,?8,CODES(CODE)
|
|
. Q
|
|
I '$D(CODES(ORG)) D HELP^MAGXCVH(6) G ORG
|
|
S $P(MAPDATA,U,6)=ORG
|
|
;
|
|
END ; File changes into mapping global, mapping global audit, and (if applicable)
|
|
; PARENT DATA FILE File (#2005.03) or MAG DESCRIPTIVE CATEGORIES File
|
|
; (#2005.81).
|
|
S NEWDATA=ITEMTXT_U_MAPDATA
|
|
I $G(^XTMP("MAG30P25","MAPPING",FLDNUM,ITEMIX))'=NEWDATA D
|
|
. S ^XTMP("MAG30P25","MAPPING",FLDNUM,ITEMIX)=NEWDATA
|
|
. S IXAUD=$O(^XTMP("MAG30P25","MAPEDITAUD"," "),-1)+1
|
|
. S AUDREC=($$NOW^XLFDT)_U_DUZ_U_FLDNUM_U_ITEMIX_U_NEWDATA
|
|
. S ^XTMP("MAG30P25","MAPEDITAUD",IXAUD,0)=AUDREC
|
|
. I FLDNUM=16!(FLDNUM=100) D DIE^MAGXCVL(FLDNUM,ITEMIX,"^^"_MAPDATA)
|
|
Q
|
|
;
|
|
; Parse Package entered and perform partial lookup.
|
|
PKGPARSE(PKG) N PKGFND,CODE,CT,SEL
|
|
K PKGFND S PKGFND=0,PKG=$$UCASE^MAGXCVP(PKG)
|
|
I $D(CODES(PKG)) D
|
|
. S PKGFND=1,PKGFND(1)=PKG
|
|
. Q
|
|
E S CODE=PKG F S CODE=$O(CODES(CODE)) Q:CODE=""!($E(CODE,1,$L(PKG))'=PKG) D
|
|
. S PKGFND=$G(PKGFND)+1,PKGFND(PKGFND)=CODE
|
|
. Q
|
|
I PKGFND=0 Q ""
|
|
I PKGFND=1 Q PKGFND(1)
|
|
F CT=1:1:PKGFND W !?5,CT,?9,PKGFND(CT)
|
|
W !,"Choose 1-",PKGFND,": " R SEL:DTIME I SEL="" Q ""
|
|
I '$D(PKGFND(SEL)) W $C(7),"??" Q "?"
|
|
Q PKGFND(SEL)
|