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

PXUTIL.m

Go to the documentation of this file.
  1. PXUTIL ;SLC/PKR - Utility routines for use by PX. ;03/02/2022
  1. ;;1.0;PCE PATIENT CARE ENCOUNTER;**211,217**;Aug 12, 1996;Build 134
  1. ;
  1. ;=================================
  1. ACOPY(REF,OUTPUT) ;Copy all the descendants of the array reference into a linear
  1. ;array. REF is the starting array reference, for example A or
  1. ;^TMP("PX",$J). OUTPUT is the linear array for the output. It
  1. ;should be in the form of a closed root, i.e., A() or ^TMP($J,).
  1. ;Note OUTPUT cannot be used as the name of the output array.
  1. N DONE,IND,LEN,NL,OROOT,OUT,PROOT,ROOT,START,TEMP
  1. I REF="" Q
  1. S NL=0
  1. S OROOT=$P(OUTPUT,")",1)
  1. S PROOT=$P(REF,")",1)
  1. ;Build the root so we can tell when we are done.
  1. S TEMP=$NA(@REF)
  1. S ROOT=$P(TEMP,")",1)
  1. S REF=$Q(@REF)
  1. I REF'[ROOT Q
  1. S DONE=0
  1. F Q:(REF="")!(DONE) D
  1. . S START=$F(REF,ROOT)
  1. . S LEN=$L(REF)
  1. . S IND=$E(REF,START,LEN)
  1. . S NL=NL+1
  1. . S OUT=OROOT_NL_")"
  1. . S @OUT=PROOT_IND_"="_@REF
  1. . S REF=$Q(@REF)
  1. . I REF'[ROOT S DONE=1
  1. Q
  1. ;
  1. ;=================================
  1. APRINT(REF) ;Write all the descendants of the array reference.
  1. ;REF is the starting array reference, for example A or
  1. ;^TMP("PX",$J).
  1. N DONE,IND,LEN,LN,PROOT,ROOT,START,TEMP,TEXT
  1. I REF="" Q
  1. S LN=0
  1. S PROOT=$P(REF,")",1)
  1. ;Build the root so we can tell when we are done.
  1. S TEMP=$NA(@REF)
  1. S ROOT=$P(TEMP,")",1)
  1. S REF=$Q(@REF)
  1. I REF'[ROOT Q
  1. S DONE=0
  1. F Q:(REF="")!(DONE) D
  1. . S START=$F(REF,ROOT)
  1. . S LEN=$L(REF)
  1. . S IND=$E(REF,START,LEN)
  1. . S LN=LN+1,TEXT(LN)=@REF
  1. . S REF=$Q(@REF)
  1. . I REF'[ROOT S DONE=1
  1. D MES^XPDUTL(.TEXT)
  1. Q
  1. ;
  1. ;=================================
  1. AWRITE(REF) ;Write all the descendants of the array reference, including the
  1. ;array. REF is the starting array reference, for example A or
  1. ;^TMP("PX",$J).
  1. N DONE,IND,LEN,LN,PROOT,ROOT,START,TEMP,TEXT
  1. I REF="" Q
  1. S LN=0
  1. S PROOT=$P(REF,")",1)
  1. ;Build the root so we can tell when we are done.
  1. S TEMP=$NA(@REF)
  1. S ROOT=$P(TEMP,")",1)
  1. S REF=$Q(@REF)
  1. I REF'[ROOT Q
  1. S DONE=0
  1. F Q:(REF="")!(DONE) D
  1. . S START=$F(REF,ROOT)
  1. . S LEN=$L(REF)
  1. . S IND=$E(REF,START,LEN)
  1. . S LN=LN+1,TEXT(LN)=PROOT_IND_"="_@REF
  1. . S REF=$Q(@REF)
  1. . I REF'[ROOT S DONE=1
  1. I $D(XPDNM) D MES^XPDUTL(.TEXT)
  1. E D EN^DDIOL(.TEXT)
  1. Q
  1. ;
  1. ;=================================
  1. BORP(DEFAULT) ;Ask the user if they want to browse or print.
  1. N DIR,POP,X,Y
  1. S DIR(0)="SA"_U_"B:Browse;P:Print"
  1. S DIR("A")="Browse or Print? "
  1. S DIR("B")=DEFAULT
  1. D ^DIR
  1. I $D(DIROUT) S DTOUT=1
  1. I $D(DTOUT)!($D(DUOUT)) Q ""
  1. Q Y
  1. ;
  1. ;=================================
  1. DELFE(FILENUM,DA) ;Delete a file entry.
  1. N DIK
  1. S DIK=$$ROOT^DILFD(FILENUM)
  1. D ^DIK
  1. Q
  1. ;
  1. ;=================================
  1. DELTLFE(FILENUM,NAME) ;Delete top level entries from a file.
  1. N FDA,IENS,MSG
  1. S IENS=+$$FIND1^DIC(FILENUM,"","BXU",NAME)
  1. I IENS=0 Q
  1. S IENS=IENS_","
  1. S FDA(FILENUM,IENS,.01)="@"
  1. D FILE^DIE("","FDA","MSG")
  1. Q
  1. ;
  1. ;=================================
  1. FNFR(ROOT) ;Given the root of a file return the file number.
  1. Q +$P(@(ROOT_"0)"),U,2)
  1. ;
  1. ;=================================
  1. GPRINT(REF) ;General printing.
  1. N DIR,IOTP,POP
  1. S %ZIS="Q"
  1. D ^%ZIS
  1. I POP Q
  1. I $D(IO("Q")) D Q
  1. . N ZTDESC,ZTRTN,ZTSAVE
  1. . S ZTSAVE("IO")=""
  1. .;Save the evaluated name of REF.
  1. . S ZTSAVE("REF")=$NA(@$$CREF^DILF(REF))
  1. .;Save the open root form for TaskMan.
  1. . S ZTSAVE($$OREF^DILF(ZTSAVE("REF")))=""
  1. . S ZTRTN="GPRINTQ^PXUTIL"
  1. . S ZTDESC="Queued print job"
  1. . D ^%ZTLOAD
  1. . W !,"Task number ",ZTSK
  1. . D HOME^%ZIS
  1. . K IO("Q")
  1. . H 2
  1. ;If this is being called from List Manager go to full screen.
  1. I $D(VALMDDF) D FULL^VALM1
  1. U IO
  1. S IOTP=IOT
  1. D APRINT^PXUTIL(REF)
  1. D ^%ZISC
  1. I IOTP["TRM" S DIR(0)="E",DIR("A")="Press ENTER to continue" D ^DIR
  1. I $D(VALMDDF) S VALMBCK="R"
  1. Q
  1. ;
  1. ;=================================
  1. GPRINTQ ;Queued general printing.
  1. U IO
  1. D APRINT^PXUTIL(REF)
  1. D ^%ZISC
  1. S ZTREQ="@"
  1. Q
  1. ;
  1. ;=================================
  1. RENAME(FILENUM,OLDNAME,NEWNAME) ;Rename entry OLDNAME to NEWNAME in
  1. ;file number FILENUM.
  1. N IEN,NIEN,MSG,PXNAT
  1. S IEN=+$$FIND1^DIC(FILENUM,"","BXU",OLDNAME)
  1. I IEN=0 D Q
  1. . D BMES^XPDUTL("Rename failed, original entry: "_OLDNAME_" in file #"_FILENUM_", does not exist.")
  1. S PXNAT=1
  1. S NIEN=+$$FIND1^DIC(FILENUM,"","BXU",NEWNAME)
  1. I NIEN>0 D Q
  1. . D BMES^XPDUTL("Rename failed, new entry: "_NEWNAME_" in file #"_FILENUM_", already exists.")
  1. S FDA(FILENUM,IEN_",",.01)=NEWNAME
  1. D FILE^DIE("ET","FDA","MSG")
  1. Q
  1. ;
  1. ;=================================
  1. RMANPC(STRING) ;Remove any non-printing characters from the end of STRING.
  1. N DONE,LC,LEN
  1. S DONE=0,LEN=$L(STRING)
  1. F Q:DONE D
  1. . S LC=$E(STRING,LEN)
  1. . I (LC=" ")!(LC?1C) S LEN=LEN-1,STRING=$E(STRING,1,LEN)
  1. . E S DONE=1
  1. Q STRING
  1. ;
  1. ;=================================
  1. STRREP(STRING,TS,RS) ;Replace every occurrence of the target string (TS)
  1. ;in STRING with the replacement string (RS).
  1. ;Example 9.19 (page 220) in "The Complete Mumps" by John Lewkowicz:
  1. ; F Q:STRING'[TS S STRING=$P(STRING,TS)_RS_$P(STRING,TS,2,999)
  1. ;fails if any portion of the target string is contained in the with
  1. ;string. Therefore a more elaborate version is required.
  1. ;
  1. N IND,NPCS,STR
  1. I STRING'[TS Q STRING
  1. ;Count the number of pieces using the target string as the delimiter.
  1. S NPCS=$L(STRING,TS)
  1. ;Extract the pieces and concatenate RS
  1. S STR=""
  1. F IND=1:1:NPCS-1 S STR=STR_$P(STRING,TS,IND)_RS
  1. S STR=STR_$P(STRING,TS,NPCS)
  1. Q STR
  1. ;