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