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