Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AUMUP102

AUMUP102.m

Go to the documentation of this file. 
  1. AUMUP102 ;IHS/OIT/ABK - AUM 11 patch 1 AUTTEDT LOAD [ 10/09/2010  4:11 PM ]
  1.  ;;11.0;TABLE MAINTENANCE;**5**;Oct 15,2010
  1.  ;
  1. QUIT ; This routine should not be called at the top.  It is only to be called
  1.  ; at START and POST by KIDS as the pre and post inits for AUM*10.2.
  1.  ;
  1. START ;IHS/OIT/ABK
  1.  D UPD
  1.  Q
  1. UPD ;read ^AUMPCLN and update ^AUTTEDT
  1.  ; Development Notes - 2/17/2010 - abk
  1.  ;    1.  Had a lot of trouble setting the sub fields until I called ^XBFMK after every
  1.  ;    fileman call.  Once I did that and reset all the fileman variables before fileman
  1.  ;    call, it worked flawlessly.
  1.  ;    2.  We are updating existing Patient Education topics.  We are setting all
  1.  ;    existing topics to inactive before we load the next set updating where we find a
  1.  ;    match.
  1.  ;    3.  When updating and deleting the Outcome and Standard sub fields, I had
  1.  ;    to kill off those entries explicitly because the data contains punctuation
  1.  ;    at these levels and I get a subscript error from ^DIK trying to parse the data for 
  1.  ;    punctuation because it thinks this is a file specification and not data...
  1.  ;    
  1.  N AUMX,AUMICD,XICD,XNAM,AUMXS,AUMCNAM,AUMMNE,AUMMJT,AUMOUTC,AUMPCLN,AUMSTD,AUMDINUM,AUMDA,AUMDA1,XABK,DINUM,TOTCNT,TOTUPD,TOTNEW,AUMSKIP,SKIPIT
  1.  K DO,DIC,DIE
  1.  D ^XBFMK
  1.  S ADT=$$DT^XLFDT
  1.  ;
  1.  S ^XTMP("AUM11P1",0)="3120101^3101101^AUM*11.0*2"
  1.  S:$G(APART)=1 ^XTMP("AUM11P1",ADT)="PARTIAL"
  1.  S:$G(APART)'=1 ^XTMP("AUM11P1",ADT)="FULL"
  1.  S AUMPCLN="",TOTUPD=0,TOTNEW=0,TOTCNT=0,AUMSKIP=0,AUMERR=0,TOTINACT=0
  1.  F  S AUMPCLN=$O(^AUMPCLN(AUMPCLN)) Q:AUMPCLN=""  S AUMXS=^(AUMPCLN) D
  1.   .S TOTCNT=TOTCNT+1
  1.   .S AUMACT=$P(AUMXS,U,1)
  1.   .I AUMACT="I" D INACT^AUMP1012 Q
  1.   .S AUMCNAM=$P(AUMXS,U,2),AUMMNE=$P(AUMXS,U,3),AUMMJT=$P($P(AUMXS,U,4),"-",1),AUMOUTC=$P(AUMXS,U,5),AUMSTD=$P(AUMXS,U,6)
  1.   .;
  1.   .; Do error checking
  1.   .I AUMCNAM="" D BMES^XPDUTL("Name field is null "_AUMCNAM_" not inserted - error"),BMES^XPDUTL("Record: "_AUMXS) S AUMERR=AUMERR+1 Q
  1.   .I AUMMNE="" D BMES^XPDUTL("Mnemonic field is null "_AUMMNE_" not inserted - error"),BMES^XPDUTL("Record: "_AUMXS) S AUMERR=AUMERR+1 Q
  1.   .;
  1.   .; Ok - past that
  1.   .S AUMFND=0
  1.   .S AUMDA1=0,AUMDA1=$O(^AUTTEDT("B",AUMCNAM,AUMDA1)) I AUMDA1'="" S AUMFND=1
  1.   .I 'AUMFND S AUMDA1=-1,AUMDA1=$O(^AUTTEDT("C",AUMMNE,AUMDA1)) I AUMDA1'="" S AUMFND=1
  1.   .I 'AUMFND D
  1.   ..S X=AUMCNAM,DIC="^AUTTEDT("
  1.   ..S DIC("DR")="1////"_AUMMNE_";.06////"_AUMMJT
  1.   ..D ^DIC
  1.   ..I $P(Y,U,1)'=-1 D
  1.   ...S (AUMDA,AUMDA1,DA)=$P(Y,U,1),AUMFND=1
  1.   ...Q
  1.   ..Q
  1.   .I 'AUMFND D
  1.   ..S X=AUMCNAM,DIC="^AUTTEDT("
  1.   ..S DIC("DR")="1////"_AUMMNE_";.06////"_AUMMJT,DIC(0)="L"
  1.   ..D ^DIC
  1.   ..I $P(Y,U,3)=1 D
  1.   ...S TOTNEW=TOTNEW+1
  1.   ...S ^XTMP("AUM11P1",ADT,"NEW",TOTNEW)=AUMCNAM_"^"_AUMMNE
  1.   ...S (AUMDA,AUMDA1,DA)=$P(Y,U,1)
  1.   ...D BMES^XPDUTL("New - Name = "_AUMCNAM_"    Mnemonic = "_AUMMNE)
  1.   ...Q
  1.   ..E  D
  1.   ...I $P(Y,U,1)=-1 D
  1.   ....S AUMERR=AUMERR+1
  1.   ....K AUMDA
  1.   ....S ^XTMP("AUM11P1",ADT,"ERROR","INSERT FAILED",AUMERR)=AUMCNAM_"^"_AUMMNE
  1.   ....D BMES^XPDUTL("Record:  "_AUMPCLN_" not inserted - error"),BMES^XPDUTL("AUMCNAM= "_AUMCNAM),BMES^XPDUTL("AUMMNE=  "_AUMMNE),BMES^XPDUTL("Record:  "_AUMXS),BMES^XPDUTL("Y:  "_Y)
  1.   ....Q
  1.   ...E  D
  1.   ....S (AUMDA,AUMDA1,DA)=$P(Y,U,1),AUMFND=1
  1.   ....Q
  1.   ..Q
  1.   .D ^XBFMK
  1.   .;Done with new; so,we are updating
  1.   .I AUMFND D
  1.   ..S SKIPIT=0
  1.   ..S AUMX=$G(^AUTTEDT(AUMDA1,0)),AUMICD=$P(AUMX,U,4),XICD=$P(AUMX,U,6),XNAM=$P(AUMX,U,1)
  1.   ..;if this is a local topic, quit
  1.   ..I AUMICD?1N.N S SKIPIT=1
  1.   ..I XICD?1A.N1P.N S SKIPIT=1
  1.   ..I XICD?.N1P.N S SKIPIT=1
  1.   ..I XICD?1P.N S SKIPIT=1
  1.   ..; OK CHECK TO SEE IF WE'RE SKIIPING, QUIT IF SO
  1.   ..I SKIPIT=1 D
  1.   ...D BMES^XPDUTL("Local Topic "_XNAM_" not changed - Skipped"),BMES^XPDUTL("Record: "_AUMX)
  1.   ...S AUMSKIP=AUMSKIP+1
  1.   ...S ^XTMP("AUM11P1",ADT,"SKIPPED",AUMDA1)=AUMCNAM_"^"_AUMMNE
  1.   ...Q
  1.   ..Q:SKIPIT=1
  1.   ..; OK, we're ok to update
  1.   ..S TOTUPD=TOTUPD+1
  1.   ..S DIE="^AUTTEDT(",DA=AUMDA1 ;,DIC(0)="L"
  1.   ..S DR=".01////"_AUMCNAM_";1////"_AUMMNE_";.06////"_AUMMJT_";.03////@"
  1.   ..S ^XTMP("AUM11P1",ADT,"UPDATE",AUMDA1)=AUMCNAM_"^"_AUMMNE
  1.   ..D ^DIE D BMES^XPDUTL("Updated - Name = "_AUMCNAM_"    Mnemonic = "_AUMMNE) D ^XBFMK
  1.   ..; abk - hit subscript error due to data on next 2 lines trying to
  1.   ..;       delete outcome and standard data
  1.   ..;S DA(1)=AUMDA1,DIK="^AUTTEDT("_DA(1)_",",DA=2 D ^DIK D ^XBFMK
  1.   ..;S DA(1)=AUMDA1,DIK="^AUTTEDT("_DA(1)_",",DA=1 D ^DIK D ^XBFMK
  1.   ..; so, I am killing them outright - they are not cross-referenced
  1.   ..K ^AUTTEDT(AUMDA1,1),^AUTTEDT(AUMDA1,2)
  1.   ..S AUMDA=AUMDA1
  1.   ..Q
  1.   .I $D(AUMDA),AUMOUTC'="" D
  1.   ..S DIC("P")=$P(^DD(9999999.09,1101,0),U,2),DA=AUMDA,DIC="^AUTTEDT("_AUMDA_",1,",DINUM=0,X="",DIC(0)="L" D FILE^DICN S DIC("P")="" D ^XBFMK
  1.   ..I AUMOUTC["|" F AUMDINUM=1:1 S XABK=$P(AUMOUTC,"|",AUMDINUM) S:XABK="" AUMDINUM=AUMDINUM+1,XABK=$P(AUMOUTC,"|",AUMDINUM) S DIC="^AUTTEDT("_AUMDA_",1,",DIC(0)="L" Q:XABK=""  S DA=AUMDA,DINUM=AUMDINUM,X=XABK D FILE^DICN D ^XBFMK
  1.   ..I AUMOUTC'["|" S XABK=AUMOUTC,DIC="^AUTTEDT("_AUMDA_",1," I XABK'="" S DA=AUMDA,DINUM=1,X=XABK,DIC(0)="L" D FILE^DICN D ^XBFMK
  1.   ..Q
  1.   ..;
  1.   .I $D(AUMDA),AUMSTD'="" D
  1.   ..S DIC("P")=$P(^DD(9999999.09,1102,0),U,2),DA=AUMDA,DIC="^AUTTEDT("_AUMDA_",2,",X="",DINUM=0,DIC(0)="L" D FILE^DICN S DIC("P")="" D ^XBFMK
  1.   ..I AUMSTD["|" F AUMDINUM=1:1 S XABK=$P(AUMSTD,"|",AUMDINUM) S:XABK="" AUMDINUM=AUMDINUM+1,XABK=$P(AUMSTD,"|",AUMDINUM) S DIC="^AUTTEDT("_AUMDA_",2,",DIC(0)="L" Q:XABK=""  S DA=AUMDA,DINUM=AUMDINUM,X=XABK D FILE^DICN D ^XBFMK
  1.   ..I AUMSTD'["|" S XABK=AUMSTD,DIC="^AUTTEDT("_AUMDA_",2," I XABK'=""  S DA=AUMDA,DINUM=1,X=XABK,DIC(0)="L" D FILE^DICN D ^XBFMK
  1.   ..Q
  1.   .Q
  1.   ;now check ^AUTTEDT for inactive records
  1.   D:$G(APART)'=1 INACT
  1.   ;and, check EHR for potential picklist changes, quit if not there
  1.   D:$D(^BGOEDTPR) PKLST
  1.   D FBADNAM
  1.   D FBADMN
  1.   ;
  1.   S AUMX=^XTMP("AUM11P1",ADT)_"^Total Records:^"_TOTCNT_"^Errors:^"_AUMERR_"^New:^"_TOTNEW_"^Updated:^"_TOTUPD_"^Inactive:^"_TOTINACT_"^Not Updated:^"_TMNMISS_"^Skipped:^"_AUMSKIP
  1.   S ^XTMP("AUM11P1",ADT)=AUMX
  1.   D BMES^XPDUTL("Total records   processed:   "_TOTCNT)
  1.   D BMES^XPDUTL("Total records     updated:   "_TOTUPD)
  1.   D BMES^XPDUTL("Total records inactivated:   "_TOTINACT)
  1.   D BMES^XPDUTL("Total records    inserted:   "_TOTNEW)
  1.   D BMES^XPDUTL("Total records    in error:   "_AUMERR)
  1.   D BMES^XPDUTL("Local records     skipped:   "_AUMSKIP)
  1.  Q
  1. KILL ;kill "B" and "C" cross-references
  1.  K ^AUTTEDT("B")
  1.  K ^AUTTEDT("C")
  1.  Q
  1.  ;
  1. POST ;call to ENALL^DIK for .01 and 1
  1.  W !,"Rebuilding Indexes",!
  1.  S DIK="^AUTTEDT("
  1.  S DIK(1)=".01^B"
  1.  D ENALL^DIK
  1.  S DIK(1)="1^C"
  1.  D ENALL^DIK
  1.  Q
  1. INACT ;Check for new inactive records 
  1.  N A,AUMX,AUMDT
  1.  S A=0,TOTINACT=0,AUMDT=$$DT^XLFDT
  1.  F  S A=$O(^AUTTEDT(A)) Q:A'?1N.N  S AUMX=$G(^AUTTEDT(A,0)) D
  1.  .Q:$P(AUMX,U,5)'=AUMDT
  1.  .Q:'$D(TMP("AUM11P1",ADT,"UPDATE",A))
  1.  .S ^XTMP("AUM11P1",ADT,"INACTIVE",A)=$P(^AUTTEDT(A,0),U,1,2)
  1.  .S TOTINACT=TOTINACT+1
  1.  .Q
  1.  Q
  1. PKLST ;Check to see what EHR pick lists might be affected
  1.  S PKNAM="",PK1=0
  1.  F  S PK1=$O(^BGOEDTPR(PK1)) Q:PK1'?1N.N  D
  1.  .S PK2="" F  S PK2=$O(^BGOEDTPR(PK1,PK2)) Q:PK2'?1N.N  D
  1.  ..S:PK2=0 PKNAM=$P(^BGOEDTPR(PK1,PK2),U,1)
  1.  ..S PK3=0 F  S PK3=$O(^BGOEDTPR(PK1,PK2,PK3)) Q:PK3'?1N.N  D
  1.  ...S PXEDT=$P($G(^BGOEDTPR(PK1,PK2,PK3,0)),U,1)
  1.  ...S:PXEDT'="" ^XTMP("AUM11P1",ADT,"PKLST",PKNAM,PXEDT)=""
  1.  ...Q
  1.  ..Q
  1.  .Q
  1.  Q
  1. RPT ;Actually print the report
  1.  ;
  1.  N A,ADT,L,X,DATAX
  1.  S AUMHDR=""
  1.  D EN^AUMDODEV
  1.  S A=0 F J=1:1  S A=$O(^XTMP("AUM11P1",A)) Q:A=""  S DATAX(J)=A
  1.  S JNDX=J-1
  1. OPT ;Select which install to report on
  1.  I JNDX>1 D
  1.  .S DIR(0)="SO^"
  1.  .S DIR("L",1)="Which Date Do You Want To Report On:"
  1.  .S DIR("L",2)=""
  1.  .S A="" F K=1:1 S A=$O(DATAX(A)) Q:A=""  S DIR("L",K+2)=K_"     "_DATAX(A),DIR(0)=DIR(0)_K_":"_DATAX(A)_";"
  1.  .S L=$L(DIR(0)),L=L-1
  1.  .S DIR(0)=$E(DIR(0),1,L)
  1.  .D ^DIR Q:X="^"
  1.  .S ADT=DATAX(X)
  1.  .Q
  1.  E  S ADT=DATAX(1)
  1.  Q:'$D(ADT)
  1.  U IO
  1.  S AUMBM=IOSL-10
  1.  I '$D(IO("S")),'$D(ZTQUEUED),IO=IO(0) S AUMBM=IOSL-4
  1.  S AUMPG=1,DIWL=5,DIWR=75,DIWF="W"
  1.  W !!,"****          Patient Education Topic Report for "_ADT_"          ****",!!!
  1.  W !,"Records that were not loaded due to errors:",!
  1.  I $D(^XTMP("AUM11P1",ADT,"ERROR")) D RERR
  1.  E  W ?15,"No Errors to Report",!
  1.  W !!
  1.  W !,"Records that were set as Inactive:",!
  1.  I $D(^XTMP("AUM11P1",ADT,"INACTIVE")) D RINA
  1.  E  W ?15,"No Records were made Inactive",!
  1.  W !!
  1.  W !,"Records that are New:",!
  1.  I $D(^XTMP("AUM11P1",ADT,"NEW")) D RNEW
  1.  E  W ?15,"No New Records were Added",!
  1.  W !!
  1.  W !,"Local (ICD9) Records that were Skipped:",!
  1.  I $D(^XTMP("AUM11P1",ADT,"SKIPPED")) D RSKP
  1.  E  W ?15,"No Local Records were Skipped",!
  1.  W !!
  1.  W !,"Records that were Updated:",!
  1.  I $D(^XTMP("AUM11P1",ADT,"UPDATE")) D RUPD
  1.  E  W ?15,"No Records were Updated",!
  1.  W !!
  1.  I $D(^XTMP("AUM11P1",ADT,"PKLST")) D RPKL
  1.  E  W ?15,"EHR Not installed or no Pick Lists were Added",!
  1.  W !!
  1.  ;I $D(^XTMP("AUM11P1",ADT,"MISSING NM")) D RNAM W !!
  1.  I $D(^XTMP("AUM11P1",ADT,"MISSING MNE")) D RMNE W !!
  1.  ;
  1.  S AUMX=^XTMP("AUM11P1",ADT) F J=2:2:15 W ?15,$P(AUMX,U,J),?30,$P(AUMX,U,J+1),!
  1.  W !,"****   End of Patient Education Topic Report for "_ADT_"    ****",!
  1.  D END
  1.  Q
  1. RUPD ;Report on records that were Updated
  1.  S AUMHDR="  EIN       Name                                                 Mnemonic"
  1.  W !,?2,"EIN",?12,"Name",?65,"Mnemonic",!
  1.  S A="" F  S A=$O(^XTMP("AUM11P1",ADT,"UPDATE",A)) Q:A'?1N.N  D
  1.  .W ?2,A,?12,$E($P(^XTMP("AUM11P1",ADT,"UPDATE",A),U,1),1,50),?65,$E($P(^XTMP("AUM11P1",ADT,"UPDATE",A),U,2),1,14)
  1.  .D ^DIWW,PG:$Y>AUMBM
  1.  .Q
  1.  Q
  1. RNEW ;Report on New Records
  1.  S AUMHDR="     Name                                                        Mnemonic"
  1.  W !,?5,"Name",?65,"Mnemonic",!
  1.  S A="" F  S A=$O(^XTMP("AUM11P1",ADT,"NEW",A)) Q:A=""  D
  1.  .W ?5,$E($P(^XTMP("AUM11P1",ADT,"NEW",A),U,1),1,55),?65,$E($P(^XTMP("AUM11P1",ADT,"NEW",A),U,2),1,14)
  1.  .D ^DIWW,PG:$Y>AUMBM
  1.  .Q
  1.  Q
  1. RSKP ;Report on Skipped Records
  1.  S AUMHDR="     Name                                                        Mnemonic"
  1.  W !,?5,"Name",?65,"Mnemonic",!
  1.  S A="" F  S A=$O(^XTMP("AUM11P1",ADT,"SKIPPED",A)) Q:A=""  D
  1.  .W ?5,$E($P(^XTMP("AUM11P1",ADT,"SKIPPED",A),U,1),1,55),?65,$E($P(^XTMP("AUM11P1",ADT,"SKIPPED",A),U,2),1,14)
  1.  .D ^DIWW,PG:$Y>AUMBM
  1.  .Q
  1.  Q
  1. RINA ;Report Inactive records
  1.  S AUMHDR="     Name                                                        Mnemonic"
  1.  W !,?5,"Name",?65,"Mnemonic",!
  1.  S A="" F  S A=$O(^XTMP("AUM11P1",ADT,"INACTIVE",A)) Q:A=""  D
  1.  .W ?5,$E($P(^XTMP("AUM11P1",ADT,"INACTIVE",A),U,1),1,55),?65,$E($P(^XTMP("AUM11P1",ADT,"INACTIVE",A),U,2),1,14)
  1.  .D ^DIWW,PG:$Y>AUMBM
  1.  .Q
  1.  Q
  1. RERR ;Report Errors
  1.  S AUMHDR="     Name                                                        Mnemonic"
  1.  W !,?5,"Name",?65,"Mnemonic"
  1.  S A="" F  S A=$O(^XTMP("AUM11P1",ADT,"ERROR",A)) Q:A=""  D
  1.  .W !,?10,"Error:  ",A,!
  1.  .S B=0 F  S B=$O(^XTMP("AUM11P1",ADT,"ERROR",A,B)) Q:B'?1N.N  D
  1.  ..W ?5,$E($P(^XTMP("AUM11P1",ADT,"ERROR",A,B),U,1),1,55),?65,$E($P(^XTMP("AUM11P1",ADT,"ERROR",A,B),U,2),1,14)
  1.  ..D ^DIWW,PG:$Y>AUMBM
  1.  ..Q
  1.  .Q
  1.  Q
  1. RPKL ;Report of pick lists if we have any
  1.  ;Pick Lists
  1.  S AUMHDR="     Pick List Name                                              Topic EIN"
  1.  W !,"EHR Pick Lists that may have been affected and need Review:",!
  1.  W !,?5,"Pick List Name",?65,"Topic EIN",!
  1.  S A="" F  S A=$O(^XTMP("AUM11P1",ADT,"PKLST",A)) Q:A=""  D
  1.  .W ?5,$E(A,1,50)
  1.  .S B=0 F  S B=$O(^XTMP("AUM11P1",ADT,"PKLST",A,B)) Q:B'?1N.N  D
  1.  ..W ?65,$E(B,1,14),!
  1.  ..D ^DIWW,PG:$Y>AUMBM
  1.  ..Q
  1.  .W !
  1.  .Q
  1.  Q
  1. RNAM ;Report on Source items that are missing by name
  1.  ;Records that are not in AUTTEDT, but should be
  1.  W !,"Records that were not updated, by Name",!
  1.  S AUMHDR="     Name"
  1.  W !,?5,"Name",!
  1.  S A="" F  S A=$O(^XTMP("AUM11P1",ADT,"MISSING NM",A)) Q:A=""  D
  1.  .W ?5,$E($P(A,U,1),1,55)
  1.  .D ^DIWW,PG:$Y>AUMBM
  1.  .Q
  1.  Q
  1. RMNE ;Report on Source items that are missing by Mnemonic
  1.  ;Records that were not updated in AUTTEDT, but should be
  1.  W !,"Records that were not updated, by Mnemonic",!
  1.  S AUMHDR="     Mnemonic"
  1.  W !,?5,"Mnemonic",!
  1.  S A="" F  S A=$O(^XTMP("AUM11P1",ADT,"MISSING MNE",A)) Q:A=""  D
  1.  .W ?5,$E($P(A,U,1),1,55)
  1.  .D ^DIWW,PG:$Y>AUMBM
  1.  .Q
  1.  Q
  1. END ;EP
  1.  W !!!
  1.  I IO(0)=IO D
  1.  .I IOST["C-",'$D(IO("S")) S Y=$$DIR^XBDIR("E","Press RETURN To Continue or Escape to Cancel...","","","",1) X ^%ZOSF("TRMRD")
  1.  .D ^DIWW
  1.  .Q
  1. END1 ;
  1.  D ^%ZISC
  1.  Q
  1. PG ; --- Paginate, write header
  1.  I IOST["C-",'$D(IO("S")) S Y=$$DIR^XBDIR("E","Press RETURN To Continue or Escape to Cancel...","","","",1) X ^%ZOSF("TRMRD")
  1.  S AUMPG=AUMPG+1
  1.  W @IOF,!!!?DIWL-1,?($S($G(IOM):IOM,1:75)-$L("Page "_AUMPG)),"Page ",AUMPG,!!,AUMHDR,!
  1.  Q
  1.  ;
  1. FBADNAM ;Find all missing names
  1.  N A,B,X,MN
  1.  S TNMISS=0
  1.  S A="" F  S A=$O(^AUMPCLN(A)) Q:A=""  S X=^(A),MN=$P(X,U,2),B="",B=$O(^AUTTEDT("B",MN,B)) S:B="" ^XTMP("AUM11P1",ADT,"MISSING NM",MN)="",TNMISS=TNMISS+1
  1.  Q
  1. FBADMN ;Find all missing Mnemonics
  1.  N A,B,X,MN
  1.  S TMNMISS=0
  1.  S A="" F  S A=$O(^AUMPCLN(A)) Q:A=""  S X=^(A),MN=$P(X,U,3),B="",B=$O(^AUTTEDT("C",MN,B)) S:B="" ^XTMP("AUM11P1",ADT,"MISSING MNE",MN)="",TMNMISS=TMNMISS+1
  1.  Q
  1. RTRIM(X) ;Strip off trailing spaces
  1.  F %=$L(X):-1:1 S:$A(X,%)=32 X=$E(X,0,%-1)
  1.  Q
  1.  ;end of routine AUMUPD102