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 Oct 16, 2024@18:32:14 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 ;
