- AUT98P12 ;IHS/SET/GTH - AUT 98.1 PATCH 12 ; [ 02/12/2003 8:56 AM ]
- ;;98.1;IHS DICTIONARIES (POINTERS);**12**;MAR 04, 1998;Build 6
- ;
- ; IHS/SET/GTH AUT*98.1*12 01/02/2003
- ;
- I '$G(IOM) D HOME^%ZIS
- ;
- I '$G(DUZ) W !,"DUZ UNDEFINED OR 0." D SORRY(2) Q
- ;
- I '$L($G(DUZ(0))) W !,"DUZ(0) UNDEFINED OR NULL." D SORRY(2) Q
- ;
- I '(DUZ(0)["@") W:'$D(ZTQUEUED) !,"DUZ(0) DOES NOT CONTAIN AN '@'." D SORRY(2) Q
- ;
- S X=$P(^VA(200,DUZ,0),U)
- W !!,$$CJ^XLFSTR("Hello, "_$P(X,",",2)_" "_$P(X,","),IOM)
- W !!,$$CJ^XLFSTR("Checking Environment for "_$P($T(+2),";",4)_" V "_$P($T(+2),";",3)_" Patch "_$P($T(+2),";",5)_".",IOM)
- ;
- NEW IORVON,IORVOFF
- S X="IORVON;IORVOFF"
- D ENDR^%ZISS
- ;
- S X=$$VERSION^XPDUTL("AUT")
- W !!,$$CJ^XLFSTR("Need AUT v 98.1.....AUT v "_X_" Present",IOM)
- I X<98.1,+X'=1.1 D SORRY(2)
- ;
- NEW DA,DIC
- S X="AUT",DIC="^DIC(9.4,",DIC(0)="",D="C"
- D IX^DIC
- I Y<0,$D(^DIC(9.4,"C","AUT")) D
- . W !!,*7,*7,$$CJ^XLFSTR("You Have More Than One Entry In The",IOM),!,$$CJ^XLFSTR("PACKAGE File with an ""AUT"" prefix.",IOM)
- . W !,$$CJ^XLFSTR(IORVON_"One entry needs to be deleted."_IORVOFF,IOM)
- . D SORRY(2)
- .Q
- ;
- I $G(XPDQUIT) W !,$$CJ^XLFSTR(IORVON_"FIX IT! Before Proceeding."_IORVOFF,IOM),!!,*7,*7,*7 Q
- ;
- W !!,$$CJ^XLFSTR("ENVIRONMENT OK.",IOM)
- ;
- D HELP^XBHELP("INTROE","AUT98P12")
- I '$$DIR^XBDIR("E","","","","","",1) D SORRY(2) Q
- ;
- I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0 D HELP^XBHELP("INTROI","AUT98P12")
- ;
- Q
- ;
- SORRY(X) ;
- KILL DIFQ
- S XPDQUIT=X
- W *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
- Q
- ;
- VCHK(AUTPRE,AUTVER,AUTQUIT) ; Check versions needed.
- ;
- NEW AUTV
- S AUTV=$$VERSION^XPDUTL(AUTPRE)
- W !,$$CJ^XLFSTR("Need at least "_AUTPRE_" v "_AUTVER_"....."_AUTPRE_" v "_AUTV_" Present",IOM)
- I AUTV<AUTVER D SORRY(AUTQUIT) Q 0
- Q 1
- ;
- PRE ;EP - From KIDS.
- ;
- ; --- Save, and set dd audit to "y" for effected files.
- I $$NEWCP^XPDUTL("PRE1-AUDS^AUT98P12","AUDS^AUT98P12")
- ;
- Q
- ;
- POST ;EP - From KIDS.
- ;
- D UNIQUEL
- ;
- ; --- Restore dd audit to pre-install values.
- I $$NEWCP^XPDUTL("POS1-AUDR^AUT98P12","AUDR^AUT98P12")
- ;
- ; --- Send install mail message.
- I $$NEWCP^XPDUTL("POS2-MAIL^AUT98P12","MAIL^AUT98P12")
- ;
- Q
- ;
- MAIL ;
- D BMES^XPDUTL("BEGIN Delivering MailMan message to select users...")
- NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
- KILL ^TMP("AUT98P12",$J)
- D RSLT(" --- AUT v 98.1, Patch 12, has been installed into this uci ---")
- F %=1:1 D RSLT($P($T(GREET+%),";",3)) Q:$P($T(GREET+%+1),";",3)="###"
- S %=0
- F S %=$O(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%)) Q:'% D RSLT(^(%,0))
- S XMSUB=$P($P($T(+1),";",2)," ",3,99),XMDUZ=$S($G(DUZ):DUZ,1:.5),XMTEXT="^TMP(""AUT98P12"",$J,",XMY(1)="",XMY(DUZ)=""
- F %="XUMGR","XUPROG","XUPROGMODE" D SINGLE(%)
- D ^XMD
- KILL ^TMP("AUT98P12",$J)
- D MES^XPDUTL("END Delivering MailMan message to select users...")
- Q
- ;
- RSLT(%) S ^(0)=$G(^TMP("AUT98P12",$J,0))+1,^(^(0))=%
- Q
- ;
- SINGLE(K) ; Get holders of a single key K.
- NEW Y
- S Y=0
- Q:'$D(^XUSEC(K))
- F S Y=$O(^XUSEC(K,Y)) Q:'Y S XMY(Y)=""
- Q
- ;
- INTROE ; Intro text during KIDS Environment check.
- ;;In this distribution:
- ;;There are several adds/edits to AUT standard data dictionaries, as
- ;;well as to the entries within the files. The notes file for this
- ;;patch can be printed using KIDS option "3 Print Transport Global",
- ;;and the adds/edits for both the DDs and the entries can be listed
- ;;using KIDS option "4 Compare Transport Global to Current System".
- ;;Neither option will effect your system prior to install.
- ;;###
- ;
- INTROI ; Intro text during KIDS Install.
- ;;A standard message will be produced by this update.
- ;;
- ;;If you run interactively, results will be displayed on your screen,
- ;;as well as in the mail message and the entry in the INSTALL file.
- ;;If you queue to TaskMan, please read the mail message for results of
- ;;this update, and remember not to Q to the HOME device.
- ;;###
- ;
- GREET ;;To add to mail message.
- ;;
- ;;Greetings.
- ;;
- ;;You are receiving this message because of the particular RPMS
- ;;security keys that you hold. This is for your information, only.
- ;;You need do nothing in response to this message.
- ;;
- ;;Questions about this patch, which is a product of the RPMS DBA
- ;;(George T. Huggins, 520-670-4871), can be directed to the DIR/RPMS
- ;;Support Center, at 505-248-4371, or via e-mail to
- ;;"hqwhd@mail.ihs.gov". Please refer to patch "AUT*98.1*12".
- ;;
- ;;Requests for modifications or additions to RPMS standard data
- ;;dictionaries must be directed to the RPMS DBA.
- ;;
- ;;###;NOTE: This line indicates the end of text in this message.
- ;
- ; -----------------------------------------------------
- ; The global location for dictionary audit is:
- ; ^DD(FILE,0,"DDA")
- ; If the valuey is "Y", dd audit is on. Any other value, or the
- ; absence of the node, means dd audit is off.
- ; -----------------------------------------------------
- AUDS ; Save current settings, and SET dd auditing 'on'.
- D MES^XPDUTL("Saving current DD AUDIT settings for files in this patch")
- D MES^XPDUTL("and turning DD AUDIT to 'Y'.")
- S ^XTMP("AUT98P12",0)=$$FMADD^XLFDT(DT,10)_"^"_DT_"^"_$P($P($T(+1),";",2)," ",3,99)
- NEW AUT
- S AUT=0
- F S AUT=$O(^XTMP("XPDI",XPDA,"FIA",AUT)) Q:'AUT D
- . I '$D(^XTMP("AUT98P12",AUT,"DDA")) S ^XTMP("AUT98P12",AUT,"DDA")=$G(^DD(AUT,0,"DDA"))
- . D MES^XPDUTL(" File "_$$RJ^XLFSTR(AUT,12)_" - "_$$LJ^XLFSTR(^XTMP("XPDI",XPDA,"FIA",AUT),30)_"- DD audit was '"_$G(^XTMP("AUT98P12",AUT,"DDA"))_"'"),MES^XPDUTL($$RJ^XLFSTR("Set to 'Y'",69))
- . S ^DD(AUT,0,"DDA")="Y"
- .Q
- D MES^XPDUTL("DD AUDIT settings saved in ^XTMP(.")
- Q
- ; -----------------------------------------------------
- AUDR ; Restore the file data audit values to their original values.
- D MES^XPDUTL("Restoring DD AUDIT settings for files in this patch")
- NEW AUT
- S AUT=0
- F S AUT=$O(^XTMP("AUT98P12",AUT)) Q:'AUT D
- . S ^DD(AUT,0,"DDA")=^XTMP("AUT98P12",AUT,"DDA")
- . D MES^XPDUTL(" File "_$$RJ^XLFSTR(AUT,12)_" - "_$$LJ^XLFSTR($$GET1^DID(AUT,"","","NAME"),30)_"- DD AUDIT Set to '"_^DD(AUT,0,"DDA")_"'")
- .Q
- KILL ^XTMP("AUT98P12")
- D MES^XPDUTL("DD AUDIT settings restored.")
- Q
- ; -----------------------------------------------------
- ;
- UNIQUEL ;----- LOOP THRU LOCATION FILE AND POPULATE UNIQUE RPMS DB ID FIELD
- ;
- N DIU,IEN,X,Y
- ;
- D BMES^XPDUTL("Populating UNIQUE RPMS DB ID field in LOCATION file")
- ;
- S IEN=0
- F S IEN=$O(^AUTTLOC(IEN)) Q:'IEN D UNIQUE1(IEN)
- ;
- ;----- DELETE SCRATCH LOCATION FILE
- ;
- S DIU="^AUTT999(8008699.06,"
- S DIU(0)="D"
- D EN^DIU2
- Q
- UNIQUE1(IEN) ;
- ;----- PROCESS ONE ENTRY
- ;
- N ASUFAC,D0,DATA,IEN2,NAME,UNIQUE,X,Y
- ;
- S NAME=$P($G(^DIC(4,IEN,0)),U)
- S D0=IEN
- X $P($G(^DD(9999999.06,.0799,0)),U,5,999)
- Q:X']""
- Q:$L(X)'=6
- S ASUFAC=X
- S IEN2=0
- S IEN2=$O(^AUTT999(8008699.06,"D",ASUFAC,IEN2))
- Q:'IEN2
- S DATA=$G(^AUTT999(8008699.06,IEN2,0))
- Q:DATA']""
- ;Q:NAME'=$P(DATA,U,2)
- Q:ASUFAC'=$P(DATA,U,3)
- S UNIQUE=$P(DATA,U,4)
- Q:'UNIQUE
- Q:$D(^AUTTLOC("F",UNIQUE))
- D UNIQUEA(IEN,UNIQUE)
- Q
- UNIQUEA(IEN,UNIQUE) ;
- ;----- EDIT ONE ENTRY
- ;
- N DA,DIE,DR,X,Y
- ;
- S DIE="^AUTTLOC("
- S DA=IEN
- S DR=".32///^S X=UNIQUE"
- D ^DIE
- Q
- AUT98P12 ;IHS/SET/GTH - AUT 98.1 PATCH 12 ; [ 02/12/2003 8:56 AM ]
- +1 ;;98.1;IHS DICTIONARIES (POINTERS);**12**;MAR 04, 1998;Build 6
- +2 ;
- +3 ; IHS/SET/GTH AUT*98.1*12 01/02/2003
- +4 ;
- +5 IF '$GET(IOM)
- DO HOME^%ZIS
- +6 ;
- +7 IF '$GET(DUZ)
- WRITE !,"DUZ UNDEFINED OR 0."
- DO SORRY(2)
- QUIT
- +8 ;
- +9 IF '$LENGTH($GET(DUZ(0)))
- WRITE !,"DUZ(0) UNDEFINED OR NULL."
- DO SORRY(2)
- QUIT
- +10 ;
- +11 IF '(DUZ(0)["@")
- IF '$DATA(ZTQUEUED)
- WRITE !,"DUZ(0) DOES NOT CONTAIN AN '@'."
- DO SORRY(2)
- QUIT
- +12 ;
- +13 SET X=$PIECE(^VA(200,DUZ,0),U)
- +14 WRITE !!,$$CJ^XLFSTR("Hello, "_$PIECE(X,",",2)_" "_$PIECE(X,","),IOM)
- +15 WRITE !!,$$CJ^XLFSTR("Checking Environment for "_$PIECE($TEXT(+2),";",4)_" V "_$PIECE($TEXT(+2),";",3)_" Patch "_$PIECE($TEXT(+2),";",5)_".",IOM)
- +16 ;
- +17 NEW IORVON,IORVOFF
- +18 SET X="IORVON;IORVOFF"
- +19 DO ENDR^%ZISS
- +20 ;
- +21 SET X=$$VERSION^XPDUTL("AUT")
- +22 WRITE !!,$$CJ^XLFSTR("Need AUT v 98.1.....AUT v "_X_" Present",IOM)
- +23 IF X<98.1
- IF +X'=1.1
- DO SORRY(2)
- +24 ;
- +25 NEW DA,DIC
- +26 SET X="AUT"
- SET DIC="^DIC(9.4,"
- SET DIC(0)=""
- SET D="C"
- +27 DO IX^DIC
- +28 IF Y<0
- IF $DATA(^DIC(9.4,"C","AUT"))
- Begin DoDot:1
- +29 WRITE !!,*7,*7,$$CJ^XLFSTR("You Have More Than One Entry In The",IOM),!,$$CJ^XLFSTR("PACKAGE File with an ""AUT"" prefix.",IOM)
- +30 WRITE !,$$CJ^XLFSTR(IORVON_"One entry needs to be deleted."_IORVOFF,IOM)
- +31 DO SORRY(2)
- +32 QUIT
- End DoDot:1
- +33 ;
- +34 IF $GET(XPDQUIT)
- WRITE !,$$CJ^XLFSTR(IORVON_"FIX IT! Before Proceeding."_IORVOFF,IOM),!!,*7,*7,*7
- QUIT
- +35 ;
- +36 WRITE !!,$$CJ^XLFSTR("ENVIRONMENT OK.",IOM)
- +37 ;
- +38 DO HELP^XBHELP("INTROE","AUT98P12")
- +39 IF '$$DIR^XBDIR("E","","","","","",1)
- DO SORRY(2)
- QUIT
- +40 ;
- +41 IF $GET(XPDENV)=1
- SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
- DO HELP^XBHELP("INTROI","AUT98P12")
- +42 ;
- +43 QUIT
- +44 ;
- SORRY(X) ;
- +1 KILL DIFQ
- +2 SET XPDQUIT=X
- +3 WRITE *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
- +4 QUIT
- +5 ;
- VCHK(AUTPRE,AUTVER,AUTQUIT) ; Check versions needed.
- +1 ;
- +2 NEW AUTV
- +3 SET AUTV=$$VERSION^XPDUTL(AUTPRE)
- +4 WRITE !,$$CJ^XLFSTR("Need at least "_AUTPRE_" v "_AUTVER_"....."_AUTPRE_" v "_AUTV_" Present",IOM)
- +5 IF AUTV<AUTVER
- DO SORRY(AUTQUIT)
- QUIT 0
- +6 QUIT 1
- +7 ;
- PRE ;EP - From KIDS.
- +1 ;
- +2 ; --- Save, and set dd audit to "y" for effected files.
- +3 IF $$NEWCP^XPDUTL("PRE1-AUDS^AUT98P12","AUDS^AUT98P12")
- +4 ;
- +5 QUIT
- +6 ;
- POST ;EP - From KIDS.
- +1 ;
- +2 DO UNIQUEL
- +3 ;
- +4 ; --- Restore dd audit to pre-install values.
- +5 IF $$NEWCP^XPDUTL("POS1-AUDR^AUT98P12","AUDR^AUT98P12")
- +6 ;
- +7 ; --- Send install mail message.
- +8 IF $$NEWCP^XPDUTL("POS2-MAIL^AUT98P12","MAIL^AUT98P12")
- +9 ;
- +10 QUIT
- +11 ;
- MAIL ;
- +1 DO BMES^XPDUTL("BEGIN Delivering MailMan message to select users...")
- +2 NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
- +3 KILL ^TMP("AUT98P12",$JOB)
- +4 DO RSLT(" --- AUT v 98.1, Patch 12, has been installed into this uci ---")
- +5 FOR %=1:1
- DO RSLT($PIECE($TEXT(GREET+%),";",3))
- IF $PIECE($TEXT(GREET+%+1),";",3)="###"
- QUIT
- +6 SET %=0
- +7 FOR
- SET %=$ORDER(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%))
- IF '%
- QUIT
- DO RSLT(^(%,0))
- +8 SET XMSUB=$PIECE($PIECE($TEXT(+1),";",2)," ",3,99)
- SET XMDUZ=$SELECT($GET(DUZ):DUZ,1:.5)
- SET XMTEXT="^TMP(""AUT98P12"",$J,"
- SET XMY(1)=""
- SET XMY(DUZ)=""
- +9 FOR %="XUMGR","XUPROG","XUPROGMODE"
- DO SINGLE(%)
- +10 DO ^XMD
- +11 KILL ^TMP("AUT98P12",$JOB)
- +12 DO MES^XPDUTL("END Delivering MailMan message to select users...")
- +13 QUIT
- +14 ;
- RSLT(%) SET ^(0)=$GET(^TMP("AUT98P12",$JOB,0))+1
- SET ^(^(0))=%
- +1 QUIT
- +2 ;
- SINGLE(K) ; Get holders of a single key K.
- +1 NEW Y
- +2 SET Y=0
- +3 IF '$DATA(^XUSEC(K))
- QUIT
- +4 FOR
- SET Y=$ORDER(^XUSEC(K,Y))
- IF 'Y
- QUIT
- SET XMY(Y)=""
- +5 QUIT
- +6 ;
- INTROE ; Intro text during KIDS Environment check.
- +1 ;;In this distribution:
- +2 ;;There are several adds/edits to AUT standard data dictionaries, as
- +3 ;;well as to the entries within the files. The notes file for this
- +4 ;;patch can be printed using KIDS option "3 Print Transport Global",
- +5 ;;and the adds/edits for both the DDs and the entries can be listed
- +6 ;;using KIDS option "4 Compare Transport Global to Current System".
- +7 ;;Neither option will effect your system prior to install.
- +8 ;;###
- +9 ;
- INTROI ; Intro text during KIDS Install.
- +1 ;;A standard message will be produced by this update.
- +2 ;;
- +3 ;;If you run interactively, results will be displayed on your screen,
- +4 ;;as well as in the mail message and the entry in the INSTALL file.
- +5 ;;If you queue to TaskMan, please read the mail message for results of
- +6 ;;this update, and remember not to Q to the HOME device.
- +7 ;;###
- +8 ;
- GREET ;;To add to mail message.
- +1 ;;
- +2 ;;Greetings.
- +3 ;;
- +4 ;;You are receiving this message because of the particular RPMS
- +5 ;;security keys that you hold. This is for your information, only.
- +6 ;;You need do nothing in response to this message.
- +7 ;;
- +8 ;;Questions about this patch, which is a product of the RPMS DBA
- +9 ;;(George T. Huggins, 520-670-4871), can be directed to the DIR/RPMS
- +10 ;;Support Center, at 505-248-4371, or via e-mail to
- +11 ;;"hqwhd@mail.ihs.gov". Please refer to patch "AUT*98.1*12".
- +12 ;;
- +13 ;;Requests for modifications or additions to RPMS standard data
- +14 ;;dictionaries must be directed to the RPMS DBA.
- +15 ;;
- +16 ;;###;NOTE: This line indicates the end of text in this message.
- +17 ;
- +18 ; -----------------------------------------------------
- +19 ; The global location for dictionary audit is:
- +20 ; ^DD(FILE,0,"DDA")
- +21 ; If the valuey is "Y", dd audit is on. Any other value, or the
- +22 ; absence of the node, means dd audit is off.
- +23 ; -----------------------------------------------------
- AUDS ; Save current settings, and SET dd auditing 'on'.
- +1 DO MES^XPDUTL("Saving current DD AUDIT settings for files in this patch")
- +2 DO MES^XPDUTL("and turning DD AUDIT to 'Y'.")
- +3 SET ^XTMP("AUT98P12",0)=$$FMADD^XLFDT(DT,10)_"^"_DT_"^"_$PIECE($PIECE($TEXT(+1),";",2)," ",3,99)
- +4 NEW AUT
- +5 SET AUT=0
- +6 FOR
- SET AUT=$ORDER(^XTMP("XPDI",XPDA,"FIA",AUT))
- IF 'AUT
- QUIT
- Begin DoDot:1
- +7 IF '$DATA(^XTMP("AUT98P12",AUT,"DDA"))
- SET ^XTMP("AUT98P12",AUT,"DDA")=$GET(^DD(AUT,0,"DDA"))
- +8 DO MES^XPDUTL(" File "_$$RJ^XLFSTR(AUT,12)_" - "_$$LJ^XLFSTR(^XTMP("XPDI",XPDA,"FIA",AUT),30)_"- DD audit was '"_$GET(^XTMP("AUT98P12",AUT,"DDA"))_"'")
- DO MES^XPDUTL($$RJ^XLFSTR("Set to 'Y'",69))
- +9 SET ^DD(AUT,0,"DDA")="Y"
- +10 QUIT
- End DoDot:1
- +11 DO MES^XPDUTL("DD AUDIT settings saved in ^XTMP(.")
- +12 QUIT
- +13 ; -----------------------------------------------------
- AUDR ; Restore the file data audit values to their original values.
- +1 DO MES^XPDUTL("Restoring DD AUDIT settings for files in this patch")
- +2 NEW AUT
- +3 SET AUT=0
- +4 FOR
- SET AUT=$ORDER(^XTMP("AUT98P12",AUT))
- IF 'AUT
- QUIT
- Begin DoDot:1
- +5 SET ^DD(AUT,0,"DDA")=^XTMP("AUT98P12",AUT,"DDA")
- +6 DO MES^XPDUTL(" File "_$$RJ^XLFSTR(AUT,12)_" - "_$$LJ^XLFSTR($$GET1^DID(AUT,"","","NAME"),30)_"- DD AUDIT Set to '"_^DD(AUT,0,"DDA")_"'")
- +7 QUIT
- End DoDot:1
- +8 KILL ^XTMP("AUT98P12")
- +9 DO MES^XPDUTL("DD AUDIT settings restored.")
- +10 QUIT
- +11 ; -----------------------------------------------------
- +12 ;
- UNIQUEL ;----- LOOP THRU LOCATION FILE AND POPULATE UNIQUE RPMS DB ID FIELD
- +1 ;
- +2 NEW DIU,IEN,X,Y
- +3 ;
- +4 DO BMES^XPDUTL("Populating UNIQUE RPMS DB ID field in LOCATION file")
- +5 ;
- +6 SET IEN=0
- +7 FOR
- SET IEN=$ORDER(^AUTTLOC(IEN))
- IF 'IEN
- QUIT
- DO UNIQUE1(IEN)
- +8 ;
- +9 ;----- DELETE SCRATCH LOCATION FILE
- +10 ;
- +11 SET DIU="^AUTT999(8008699.06,"
- +12 SET DIU(0)="D"
- +13 DO EN^DIU2
- +14 QUIT
- UNIQUE1(IEN) ;
- +1 ;----- PROCESS ONE ENTRY
- +2 ;
- +3 NEW ASUFAC,D0,DATA,IEN2,NAME,UNIQUE,X,Y
- +4 ;
- +5 SET NAME=$PIECE($GET(^DIC(4,IEN,0)),U)
- +6 SET D0=IEN
- +7 XECUTE $PIECE($GET(^DD(9999999.06,.0799,0)),U,5,999)
- +8 IF X']""
- QUIT
- +9 IF $LENGTH(X)'=6
- QUIT
- +10 SET ASUFAC=X
- +11 SET IEN2=0
- +12 SET IEN2=$ORDER(^AUTT999(8008699.06,"D",ASUFAC,IEN2))
- +13 IF 'IEN2
- QUIT
- +14 SET DATA=$GET(^AUTT999(8008699.06,IEN2,0))
- +15 IF DATA']""
- QUIT
- +16 ;Q:NAME'=$P(DATA,U,2)
- +17 IF ASUFAC'=$PIECE(DATA,U,3)
- QUIT
- +18 SET UNIQUE=$PIECE(DATA,U,4)
- +19 IF 'UNIQUE
- QUIT
- +20 IF $DATA(^AUTTLOC("F",UNIQUE))
- QUIT
- +21 DO UNIQUEA(IEN,UNIQUE)
- +22 QUIT
- UNIQUEA(IEN,UNIQUE) ;
- +1 ;----- EDIT ONE ENTRY
- +2 ;
- +3 NEW DA,DIE,DR,X,Y
- +4 ;
- +5 SET DIE="^AUTTLOC("
- +6 SET DA=IEN
- +7 SET DR=".32///^S X=UNIQUE"
- +8 DO ^DIE
- +9 QUIT
