MAGXCVE.m

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)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---MAGXCVE   9122     printed  Feb 18, 2025@23:37:08                                                                                                                                                                                                     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.

MENU      ;

 +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