- PXRMUTIL ;SLC/PKR/PJH - Utility routines for use by PXRM. ;02/25/2021
- ;;2.0;CLINICAL REMINDERS;**4,6,11,12,17,18,24,26,47,42**;Feb 04, 2005;Build 245
- ;
- ;=================================
- 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("PXRM",$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("PXRM",$J).
- N APTEXT,DONE,IND,LEN,LN,PROOT,ROOT,START,TEMP
- 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,APTEXT(LN)=@REF
- . S REF=$Q(@REF)
- . I REF'[ROOT S DONE=1
- I $D(XPDNM) D MES^XPDUTL(.APTEXT)
- E D EN^DDIOL(.APTEXT)
- Q
- ;
- ;=================================
- ATTVALUE(STRING,ATTR,SEP,AVSEP) ;STRING contains a list of attribute value
- ;pairs. Each pair is separated by SEP and the attribute value pair
- ;is separated by AVSEP. Return the value for the attribute ATTR.
- N AVPAIR,IND,NUMAVP,VALUE
- S NUMAVP=$L(STRING,SEP)
- S VALUE=""
- F IND=1:1:NUMAVP Q:VALUE'="" D
- . S AVPAIR=$P(STRING,SEP,IND)
- . I AVPAIR[ATTR S VALUE=$P(AVPAIR,AVSEP,2)
- Q VALUE
- ;
- ;=================================
- AWRITE(REF) ;Write all the descendants of the array reference, including the
- ;array. REF is the starting array reference, for example A or
- ;^TMP("PXRM",$J).
- N AWTEXT,DONE,IND,LEN,LN,PROOT,ROOT,START,TEMP
- 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,AWTEXT(LN)=PROOT_IND_"="_@REF
- . S REF=$Q(@REF)
- . I REF'[ROOT S DONE=1
- I $D(XPDNM) D MES^XPDUTL(.AWTEXT)
- E D EN^DDIOL(.AWTEXT)
- 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
- ;
- ;=================================
- DEFURLAD(DEF,NEWURL) ;Add a new URL to a reminder definition.
- N FDA,IEN,IENS,MSG,WPTMP
- S IEN=+$O(^PXD(811.9,"B",DEF,""))
- I IEN=0 Q
- I $D(^PXD(811.9,IEN,50,"B",NEWURL)) Q
- S IENS="+1,"_IEN_","
- S FDA(811.9002,IENS,.01)=NEWURL
- I $D(NEWURL("TITLE")) S FDA(811.9002,IENS,.02)=NEWURL("TITLE")
- I $D(NEWURL("DESC")) D
- . M WPTMP=NEWURL("DESC")
- . S FDA(811.9002,IENS,1)="WPTMP"
- D UPDATE^DIE("","FDA","","MSG")
- Q
- ;
- ;=================================
- DEFURLUP(DEF,OLDURL,NEWURL) ;Update a URL in a reminder definition.
- N FDA,IEN,IENS,IND,MSG,WPTMP
- S IEN=+$O(^PXD(811.9,"B",DEF,""))
- I IEN=0 Q
- S IND=+$O(^PXD(811.9,IEN,50,"B",OLDURL,""))
- I IND=0 Q
- S IENS=IND_","_IEN_","
- S FDA(811.9002,IENS,.01)=NEWURL
- I $D(NEWURL("TITLE")) S FDA(811.9002,IENS,.02)=NEWURL("TITLE")
- I $D(NEWURL("DESC")) D
- . M WPTMP=NEWURL("DESC")
- . S FDA(811.9002,IENS,1)="WPTMP"
- D FILE^DIE("","FDA","MSG")
- 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
- ;
- ;=================================
- DIP(VAR,IEN,PXRMROOT,FLDS) ;Do general inquiry for IEN return formatted
- ;output in VAR. VAR can be either a local variable or a global.
- ;If it is a local it is indexed for the broker. If it is a global
- ;it should be passed in closed form i.e., ^TMP("PXRMTEST",$J).
- ;It will be returned formatted for List Manager i.e.,
- ;^TMP("PXRMTEST",$J,N,0).
- N %ZIS,ARRAY,BY,DC,DHD,DIC,DONE,FF,FILENAME,FILESPEC,FR,GBL,HFNAME
- N IND,IOP,L,NOW,PATH,SUCCESS,TO,UNIQN
- S BY="NUMBER",(FR,TO)=+$P(IEN,U,1),DHD="@@"
- ;Make sure the PXRM WORKSTATION device exists.
- D MKWSDEV^PXRMHOST
- ;Set up the output file before DIP is called.
- S PATH=$$PWD^%ZISH
- S NOW=$$NOW^XLFDT
- S NOW=$TR(NOW,".","")
- S UNIQN=$J_NOW
- S FILENAME="PXRMWSD"_UNIQN_".DAT"
- S HFNAME=PATH_FILENAME
- S IOP="PXRM WORKSTATION;80"
- S %ZIS("HFSMODE")="W"
- S %ZIS("HFSNAME")=HFNAME
- S L=0,DIC=PXRMROOT
- D EN1^DIP
- ;Move the host file into a global.
- S GBL="^TMP(""PXRMUTIL"",$J,1,0)"
- S GBL=$NA(@GBL)
- K ^TMP("PXRMUTIL",$J)
- S SUCCESS=$$FTG^%ZISH(PATH,FILENAME,GBL,3)
- ;Look for a form feed, remove it and all subsequent lines.
- S FF=$C(12)
- I $G(VAR)["^" D
- . S VAR=$NA(@VAR)
- . S VAR=$P(VAR,")",1)
- . S VAR=VAR_",IND,0)"
- . S (DONE,IND)=0
- . F Q:DONE S IND=$O(^TMP("PXRMUTIL",$J,IND)) Q:+IND=0 D
- .. I ^TMP("PXRMUTIL",$J,IND,0)=FF S DONE=1 Q
- .. S @VAR=^TMP("PXRMUTIL",$J,IND,0)
- E D
- . S (DONE,IND)=0
- . F Q:DONE S IND=$O(^TMP("PXRMUTIL",$J,IND)) Q:+IND=0 D
- .. S VAR(IND)=^TMP("PXRMUTIL",$J,IND,0)
- .. I VAR(IND)=FF K ARRAY(IND) S DONE=1
- K ^TMP("PXRMUTIL",$J)
- ;Delete the host file.
- S FILESPEC(FILENAME)=""
- S SUCCESS=$$DEL^%ZISH(PATH,$NA(FILESPEC))
- 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,POP,SAVEIOT
- 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^PXRMUTIL"
- . 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
- D APRINT^PXRMUTIL(REF)
- ;Save IOT before it is reset.
- S SAVEIOT=IOT
- D ^%ZISC
- I SAVEIOT["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^PXRMUTIL(REF)
- D ^%ZISC
- S ZTREQ="@"
- Q
- ;
- ;=================================
- NTOAN(NUMBER) ;Given an integer N return an alphabetic string that can be
- ;used for sorting. This will be modulus 26. For example N=0 returns
- ;A, N=26 returns BA etc.
- N ALPH
- S ALPH(0)="A",ALPH(1)="B",ALPH(2)="C",ALPH(3)="D",ALPH(4)="E"
- S ALPH(5)="F",ALPH(6)="G",ALPH(7)="H",ALPH(8)="I",ALPH(9)="J"
- S ALPH(10)="K",ALPH(11)="L",ALPH(12)="M",ALPH(13)="N",ALPH(14)="O"
- S ALPH(15)="P",ALPH(16)="Q",ALPH(17)="R",ALPH(18)="S",ALPH(19)="T"
- S ALPH(20)="U",ALPH(21)="V",ALPH(22)="W",ALPH(23)="X",ALPH(24)="Y"
- S ALPH(25)="Z"
- ;
- N ANUM,DIGIT,NUM,P26,PC,PWR
- S ANUM="",NUM=NUMBER,PWR=0
- S P26(PWR)=1
- F PWR=1:1 S P26(PWR)=26*P26(PWR-1) I P26(PWR)>NUMBER Q
- S PWR=PWR-1
- F PC=PWR:-1:0 D
- . S DIGIT=NUM\P26(PC)
- . S ANUM=ANUM_ALPH(DIGIT)
- . S NUM=NUM-(DIGIT*P26(PC))
- Q ANUM
- ;
- ;=================================
- OPTION(OPTLU,ACTION,OOM,OOMTEXT) ;Out of order loop over options in list.
- N EXISTOOM,IEN,IND,LIST,OPT
- D FIND^DIC(19,"","@;.01","",OPTLU,"*","B","","","LIST")
- F IND=1:1:+LIST("DILIST",0) D
- . S IEN=LIST("DILIST",2,IND)
- . S EXISTOOM=$$GET1^DIQ(19,IEN,2)
- . I (ACTION="DISABLE"),(EXISTOOM'="") Q
- . I (ACTION="ENABLE"),(EXISTOOM'=OOMTEXT) Q
- . S OPT=LIST("DILIST","ID",IND,.01)
- . D OUT^XPDMENU(OPT,OOM)
- Q
- ;
- ;=================================
- OPTIONS(ACTION,OOMTEXT) ;Disable/enable options.
- N OOM
- S OOM=$S(ACTION="DISABLE":OOMTEXT,ACTION="ENABLE":"",1:"")
- D BMES^XPDUTL(ACTION_" options.")
- D OPTION^PXRMUTIL("GMTS",ACTION,OOM,OOMTEXT)
- D OPTION^PXRMUTIL("IBDF PRINT",ACTION,OOM,OOMTEXT)
- D OPTION^PXRMUTIL("OR CPRS GUI CHART",ACTION,OOM,OOMTEXT)
- D OPTION^PXRMUTIL("ORS HEALTH SUMMARY",ACTION,OOM,OOMTEXT)
- D OPTION^PXRMUTIL("PXRM",ACTION,OOM,OOMTEXT)
- Q
- ;
- ;=================================
- PROTOCOL(PROTLU,ACTION,DISABLE,DISTEXT) ;Disable/enable protocols.
- N EXISTDIS,FDA,IEN,IENS,MSG
- S IEN=+$$FIND1^DIC(101,"","X",PROTLU,"B")
- I IEN=0 Q
- S EXISTDIS=$$GET1^DIQ(101,IEN,2)
- I (ACTION="DISABLE"),(EXISTDIS'="") Q
- I (ACTION="ENABLE"),(EXISTDIS'=DISTEXT) Q
- S IENS=IEN_","
- S FDA(101,IENS,2)=DISABLE
- D FILE^DIE("","FDA","MSG")
- Q
- ;
- ;=================================
- PROTCOLS(ACTION,DISTEXT) ;Disable/enable protocols.
- N DISABLE,PROT,RESULT
- S DISABLE=$S(ACTION="DISABLE":DISTEXT,ACTION="ENABLE":"",1:"")
- D BMES^XPDUTL(ACTION_" protocols.")
- ;
- D PROTOCOL^PXRMUTIL("ORS HEALTH SUMMARY",ACTION,DISABLE,DISTEXT)
- D PROTOCOL^PXRMUTIL("ORS AD HOC HEALTH SUMMARY",ACTION,DISABLE,DISTEXT)
- D PROTOCOL^PXRMUTIL("PXRM PATIENT DATA CHANGE",ACTION,DISABLE,DISTEXT)
- Q
- ;
- ;=================================
- RENAME(FILENUM,OLDNAME,NEWNAME) ;Rename entry OLDNAME to NEWNAME in
- ;file number FILENUM.
- N IEN,NIEN,MSG,PXRMINST
- S IEN=+$$FIND1^DIC(FILENUM,"","BXU",OLDNAME)
- I IEN=0 Q
- S PXRMINST=1
- S NIEN=+$$FIND1^DIC(FILENUM,"","BXU",NEWNAME) I NIEN>0 Q
- S FDA(FILENUM,IEN_",",.01)=NEWNAME
- D FILE^DIE("ET","FDA","MSG")
- Q
- ;
- ;=================================
- RMEHIST(FILENUM,IEN) ;Remove the edit history for a reminder file.
- I (FILENUM<800)!(FILENUM>811.9)!(FILENUM=811.8) Q
- N DA,DIK,GLOBAL,ROOT
- S GLOBAL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
- ;Edit History is stored in node 110 for all files.
- S DA(1)=IEN
- S DIK=GLOBAL_IEN_",110,"
- S ROOT=GLOBAL_IEN_",110,DA)"
- S DA=0
- F S DA=+$O(@ROOT) Q:DA=0 D ^DIK
- Q
- ;
- ;=================================
- SEHIST(FILENUM,ROOT,IEN) ;Set the edit date and edit by and prompt the
- ;user for the edit comment.
- N DIC,DIR,DWLW,DWPK,ENTRY,FDA,FDAIEN,IENS,IND,MSG,SFN,TARGET,X,Y
- K ^TMP("PXRMWP",$J)
- D FIELD^DID(FILENUM,"EDIT HISTORY","","SPECIFIER","TARGET")
- S SFN=+$G(TARGET("SPECIFIER"))
- I SFN=0 Q
- S ENTRY=ROOT_IEN_",110)"
- S IND=$O(@ENTRY@("B"),-1)
- S IND=IND+1
- S IENS="+"_IND_","_IEN_","
- S FDAIEN(IEN)=IEN
- S FDA(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
- S FDA(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01)
- ;Prompt the user for edit comments.
- S DIC="^TMP(""PXRMWP"",$J,"
- S DWLW=72
- S DWPK=1
- W !,"Input your edit comments."
- S DIR(0)="Y"_U_"AO"
- S DIR("A")="Edit"
- S DIR("B")="NO"
- D ^DIR
- I Y D
- . D EN^DIWE
- . K ^TMP("PXRMWP",$J,0)
- . I $D(^TMP("PXRMWP",$J)) S FDA(SFN,IENS,2)="^TMP(""PXRMWP"",$J)"
- D UPDATE^DIE("E","FDA","FDAIEN","MSG")
- I $D(MSG) D AWRITE^PXRMUTIL("MSG")
- K ^TMP("PXRMWP",$J)
- Q
- ;
- ;=================================
- SETPVER(VERSION) ;Set the package version
- N DA,DIE,DR
- S DIE="^PXRM(800,",DA=1,DR="5////"_VERSION
- D ^DIE
- Q
- ;
- ;=================================
- SFRES(SDIR,NRES,FIEVAL) ;Save the finding result.
- I NRES=0 S FIEVAL=0 Q
- N DATE,IND,OA,SUB,TF
- F IND=1:1:NRES S OA(FIEVAL(IND,"DATE"),FIEVAL(IND),IND)=""
- ;If SDIR is positive get the oldest date otherwise get the most
- ;recent date.
- S DATE=$S(SDIR>0:$O(OA("")),1:$O(OA(""),-1))
- ;If there is a true finding on DATE get it.
- S TF=$O(OA(DATE,""),-1)
- S IND=$O(OA(DATE,TF,""))
- S FIEVAL=TF
- S SUB=""
- F S SUB=$O(FIEVAL(IND,SUB)) Q:SUB="" M FIEVAL(SUB)=FIEVAL(IND,SUB)
- Q
- ;
- ;=================================
- SSPAR(FIND0,NOCC,BDT,EDT) ;Set the finding search parameters.
- S BDT=$P(FIND0,U,8),EDT=$P(FIND0,U,11),NOCC=$P(FIND0,U,14)
- I +NOCC=0 S NOCC=1
- ;Convert the dates to FileMan dates.
- S BDT=$S(BDT="":0,BDT=0:0,1:$$CTFMD^PXRMDATE(BDT))
- I EDT="" S EDT="T"
- I $G(PXRMDEBG)=1 D
- . N TIME S TIME=$P(PXRMDATE,".",2)
- . I TIME'="" S TIME="."_TIME
- . S EDT=$S(EDT="T":PXRMDATE,1:$$CTFMD^PXRMDATE(EDT)_TIME)
- E S EDT=$$CTFMD^PXRMDATE(EDT)
- ;If EDT does not contain a time set it to the end of the day.
- I (EDT'=-1),EDT'["." S EDT=EDT_".235959"
- I $G(PXRMDDOC)'=1 Q
- S ^TMP("PXRMDDOC",$J,$P(FIND0,U,1,11))=BDT_U_EDT
- Q
- ;
- ;=================================
- 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
- ;
- ;=================================
- UPEHIST(FILENUM,IEN,TEXT,MSG) ;Update the edit history.
- N FDA,GBL,IENS,IND,LN,NEXT,SUBFN,TARGET,WPTMP
- D FIELD^DID(FILENUM,"EDIT HISTORY","","SPECIFIER","TARGET")
- S SUBFN=+$G(TARGET("SPECIFIER"))
- I SUBFN=0 Q
- S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")_IEN_",110)"
- S NEXT=$O(@GBL@("B"),-1)+1
- S (IND,LN)=0
- F S IND=$O(TEXT(IND)) Q:IND="" D
- . S LN=LN+1
- . S WPTMP(1,2,LN)=TEXT(IND)
- S IENS="+"_NEXT_","_IEN_","
- S FDA(SUBFN,IENS,.01)=$$NOW^XLFDT
- S FDA(SUBFN,IENS,1)=$G(DUZ)
- S FDA(SUBFN,IENS,2)="WPTMP(1,2)"
- D UPDATE^DIE("","FDA","","MSG")
- Q
- ;
- ;=================================
- VEDIT(ROOT,IEN) ;This is used as a DIC("S") screen to select which entries
- ;a user can edit.
- N CLASS,ENTRY,VALID
- S ENTRY=ROOT_IEN_")"
- S CLASS=$P($G(@ENTRY@(100)),U,1)
- I CLASS="N" D
- . I ($G(PXRMINST)=1),(DUZ(0)="@") S VALID=1
- . E S VALID=0
- E S VALID=1
- Q VALID
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMUTIL 14384 printed Mar 13, 2025@20:54:23 Page 2
- PXRMUTIL ;SLC/PKR/PJH - Utility routines for use by PXRM. ;02/25/2021
- +1 ;;2.0;CLINICAL REMINDERS;**4,6,11,12,17,18,24,26,47,42**;Feb 04, 2005;Build 245
- +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("PXRM",$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("PXRM",$J).
- +3 NEW APTEXT,DONE,IND,LEN,LN,PROOT,ROOT,START,TEMP
- +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 APTEXT(LN)=@REF
- +18 SET REF=$QUERY(@REF)
- +19 IF REF'[ROOT
- SET DONE=1
- End DoDot:1
- +20 IF $DATA(XPDNM)
- DO MES^XPDUTL(.APTEXT)
- +21 IF '$TEST
- DO EN^DDIOL(.APTEXT)
- +22 QUIT
- +23 ;
- +24 ;=================================
- ATTVALUE(STRING,ATTR,SEP,AVSEP) ;STRING contains a list of attribute value
- +1 ;pairs. Each pair is separated by SEP and the attribute value pair
- +2 ;is separated by AVSEP. Return the value for the attribute ATTR.
- +3 NEW AVPAIR,IND,NUMAVP,VALUE
- +4 SET NUMAVP=$LENGTH(STRING,SEP)
- +5 SET VALUE=""
- +6 FOR IND=1:1:NUMAVP
- if VALUE'=""
- QUIT
- Begin DoDot:1
- +7 SET AVPAIR=$PIECE(STRING,SEP,IND)
- +8 IF AVPAIR[ATTR
- SET VALUE=$PIECE(AVPAIR,AVSEP,2)
- End DoDot:1
- +9 QUIT VALUE
- +10 ;
- +11 ;=================================
- 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("PXRM",$J).
- +3 NEW AWTEXT,DONE,IND,LEN,LN,PROOT,ROOT,START,TEMP
- +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 AWTEXT(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(.AWTEXT)
- +21 IF '$TEST
- DO EN^DDIOL(.AWTEXT)
- +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 ;=================================
- DEFURLAD(DEF,NEWURL) ;Add a new URL to a reminder definition.
- +1 NEW FDA,IEN,IENS,MSG,WPTMP
- +2 SET IEN=+$ORDER(^PXD(811.9,"B",DEF,""))
- +3 IF IEN=0
- QUIT
- +4 IF $DATA(^PXD(811.9,IEN,50,"B",NEWURL))
- QUIT
- +5 SET IENS="+1,"_IEN_","
- +6 SET FDA(811.9002,IENS,.01)=NEWURL
- +7 IF $DATA(NEWURL("TITLE"))
- SET FDA(811.9002,IENS,.02)=NEWURL("TITLE")
- +8 IF $DATA(NEWURL("DESC"))
- Begin DoDot:1
- +9 MERGE WPTMP=NEWURL("DESC")
- +10 SET FDA(811.9002,IENS,1)="WPTMP"
- End DoDot:1
- +11 DO UPDATE^DIE("","FDA","","MSG")
- +12 QUIT
- +13 ;
- +14 ;=================================
- DEFURLUP(DEF,OLDURL,NEWURL) ;Update a URL in a reminder definition.
- +1 NEW FDA,IEN,IENS,IND,MSG,WPTMP
- +2 SET IEN=+$ORDER(^PXD(811.9,"B",DEF,""))
- +3 IF IEN=0
- QUIT
- +4 SET IND=+$ORDER(^PXD(811.9,IEN,50,"B",OLDURL,""))
- +5 IF IND=0
- QUIT
- +6 SET IENS=IND_","_IEN_","
- +7 SET FDA(811.9002,IENS,.01)=NEWURL
- +8 IF $DATA(NEWURL("TITLE"))
- SET FDA(811.9002,IENS,.02)=NEWURL("TITLE")
- +9 IF $DATA(NEWURL("DESC"))
- Begin DoDot:1
- +10 MERGE WPTMP=NEWURL("DESC")
- +11 SET FDA(811.9002,IENS,1)="WPTMP"
- End DoDot:1
- +12 DO FILE^DIE("","FDA","MSG")
- +13 QUIT
- +14 ;
- +15 ;=================================
- 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 ;=================================
- DIP(VAR,IEN,PXRMROOT,FLDS) ;Do general inquiry for IEN return formatted
- +1 ;output in VAR. VAR can be either a local variable or a global.
- +2 ;If it is a local it is indexed for the broker. If it is a global
- +3 ;it should be passed in closed form i.e., ^TMP("PXRMTEST",$J).
- +4 ;It will be returned formatted for List Manager i.e.,
- +5 ;^TMP("PXRMTEST",$J,N,0).
- +6 NEW %ZIS,ARRAY,BY,DC,DHD,DIC,DONE,FF,FILENAME,FILESPEC,FR,GBL,HFNAME
- +7 NEW IND,IOP,L,NOW,PATH,SUCCESS,TO,UNIQN
- +8 SET BY="NUMBER"
- SET (FR,TO)=+$PIECE(IEN,U,1)
- SET DHD="@@"
- +9 ;Make sure the PXRM WORKSTATION device exists.
- +10 DO MKWSDEV^PXRMHOST
- +11 ;Set up the output file before DIP is called.
- +12 SET PATH=$$PWD^%ZISH
- +13 SET NOW=$$NOW^XLFDT
- +14 SET NOW=$TRANSLATE(NOW,".","")
- +15 SET UNIQN=$JOB_NOW
- +16 SET FILENAME="PXRMWSD"_UNIQN_".DAT"
- +17 SET HFNAME=PATH_FILENAME
- +18 SET IOP="PXRM WORKSTATION;80"
- +19 SET %ZIS("HFSMODE")="W"
- +20 SET %ZIS("HFSNAME")=HFNAME
- +21 SET L=0
- SET DIC=PXRMROOT
- +22 DO EN1^DIP
- +23 ;Move the host file into a global.
- +24 SET GBL="^TMP(""PXRMUTIL"",$J,1,0)"
- +25 SET GBL=$NAME(@GBL)
- +26 KILL ^TMP("PXRMUTIL",$JOB)
- +27 SET SUCCESS=$$FTG^%ZISH(PATH,FILENAME,GBL,3)
- +28 ;Look for a form feed, remove it and all subsequent lines.
- +29 SET FF=$CHAR(12)
- +30 IF $GET(VAR)["^"
- Begin DoDot:1
- +31 SET VAR=$NAME(@VAR)
- +32 SET VAR=$PIECE(VAR,")",1)
- +33 SET VAR=VAR_",IND,0)"
- +34 SET (DONE,IND)=0
- +35 FOR
- if DONE
- QUIT
- SET IND=$ORDER(^TMP("PXRMUTIL",$JOB,IND))
- if +IND=0
- QUIT
- Begin DoDot:2
- +36 IF ^TMP("PXRMUTIL",$JOB,IND,0)=FF
- SET DONE=1
- QUIT
- +37 SET @VAR=^TMP("PXRMUTIL",$JOB,IND,0)
- End DoDot:2
- End DoDot:1
- +38 IF '$TEST
- Begin DoDot:1
- +39 SET (DONE,IND)=0
- +40 FOR
- if DONE
- QUIT
- SET IND=$ORDER(^TMP("PXRMUTIL",$JOB,IND))
- if +IND=0
- QUIT
- Begin DoDot:2
- +41 SET VAR(IND)=^TMP("PXRMUTIL",$JOB,IND,0)
- +42 IF VAR(IND)=FF
- KILL ARRAY(IND)
- SET DONE=1
- End DoDot:2
- End DoDot:1
- +43 KILL ^TMP("PXRMUTIL",$JOB)
- +44 ;Delete the host file.
- +45 SET FILESPEC(FILENAME)=""
- +46 SET SUCCESS=$$DEL^%ZISH(PATH,$NAME(FILESPEC))
- +47 QUIT
- +48 ;
- +49 ;=================================
- 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,POP,SAVEIOT
- +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^PXRMUTIL"
- +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 DO APRINT^PXRMUTIL(REF)
- +23 ;Save IOT before it is reset.
- +24 SET SAVEIOT=IOT
- +25 DO ^%ZISC
- +26 IF SAVEIOT["TRM"
- SET DIR(0)="E"
- SET DIR("A")="Press ENTER to continue"
- DO ^DIR
- +27 IF $DATA(VALMDDF)
- SET VALMBCK="R"
- +28 QUIT
- +29 ;
- +30 ;=================================
- GPRINTQ ;Queued general printing.
- +1 USE IO
- +2 DO APRINT^PXRMUTIL(REF)
- +3 DO ^%ZISC
- +4 SET ZTREQ="@"
- +5 QUIT
- +6 ;
- +7 ;=================================
- NTOAN(NUMBER) ;Given an integer N return an alphabetic string that can be
- +1 ;used for sorting. This will be modulus 26. For example N=0 returns
- +2 ;A, N=26 returns BA etc.
- +3 NEW ALPH
- +4 SET ALPH(0)="A"
- SET ALPH(1)="B"
- SET ALPH(2)="C"
- SET ALPH(3)="D"
- SET ALPH(4)="E"
- +5 SET ALPH(5)="F"
- SET ALPH(6)="G"
- SET ALPH(7)="H"
- SET ALPH(8)="I"
- SET ALPH(9)="J"
- +6 SET ALPH(10)="K"
- SET ALPH(11)="L"
- SET ALPH(12)="M"
- SET ALPH(13)="N"
- SET ALPH(14)="O"
- +7 SET ALPH(15)="P"
- SET ALPH(16)="Q"
- SET ALPH(17)="R"
- SET ALPH(18)="S"
- SET ALPH(19)="T"
- +8 SET ALPH(20)="U"
- SET ALPH(21)="V"
- SET ALPH(22)="W"
- SET ALPH(23)="X"
- SET ALPH(24)="Y"
- +9 SET ALPH(25)="Z"
- +10 ;
- +11 NEW ANUM,DIGIT,NUM,P26,PC,PWR
- +12 SET ANUM=""
- SET NUM=NUMBER
- SET PWR=0
- +13 SET P26(PWR)=1
- +14 FOR PWR=1:1
- SET P26(PWR)=26*P26(PWR-1)
- IF P26(PWR)>NUMBER
- QUIT
- +15 SET PWR=PWR-1
- +16 FOR PC=PWR:-1:0
- Begin DoDot:1
- +17 SET DIGIT=NUM\P26(PC)
- +18 SET ANUM=ANUM_ALPH(DIGIT)
- +19 SET NUM=NUM-(DIGIT*P26(PC))
- End DoDot:1
- +20 QUIT ANUM
- +21 ;
- +22 ;=================================
- OPTION(OPTLU,ACTION,OOM,OOMTEXT) ;Out of order loop over options in list.
- +1 NEW EXISTOOM,IEN,IND,LIST,OPT
- +2 DO FIND^DIC(19,"","@;.01","",OPTLU,"*","B","","","LIST")
- +3 FOR IND=1:1:+LIST("DILIST",0)
- Begin DoDot:1
- +4 SET IEN=LIST("DILIST",2,IND)
- +5 SET EXISTOOM=$$GET1^DIQ(19,IEN,2)
- +6 IF (ACTION="DISABLE")
- IF (EXISTOOM'="")
- QUIT
- +7 IF (ACTION="ENABLE")
- IF (EXISTOOM'=OOMTEXT)
- QUIT
- +8 SET OPT=LIST("DILIST","ID",IND,.01)
- +9 DO OUT^XPDMENU(OPT,OOM)
- End DoDot:1
- +10 QUIT
- +11 ;
- +12 ;=================================
- OPTIONS(ACTION,OOMTEXT) ;Disable/enable options.
- +1 NEW OOM
- +2 SET OOM=$SELECT(ACTION="DISABLE":OOMTEXT,ACTION="ENABLE":"",1:"")
- +3 DO BMES^XPDUTL(ACTION_" options.")
- +4 DO OPTION^PXRMUTIL("GMTS",ACTION,OOM,OOMTEXT)
- +5 DO OPTION^PXRMUTIL("IBDF PRINT",ACTION,OOM,OOMTEXT)
- +6 DO OPTION^PXRMUTIL("OR CPRS GUI CHART",ACTION,OOM,OOMTEXT)
- +7 DO OPTION^PXRMUTIL("ORS HEALTH SUMMARY",ACTION,OOM,OOMTEXT)
- +8 DO OPTION^PXRMUTIL("PXRM",ACTION,OOM,OOMTEXT)
- +9 QUIT
- +10 ;
- +11 ;=================================
- PROTOCOL(PROTLU,ACTION,DISABLE,DISTEXT) ;Disable/enable protocols.
- +1 NEW EXISTDIS,FDA,IEN,IENS,MSG
- +2 SET IEN=+$$FIND1^DIC(101,"","X",PROTLU,"B")
- +3 IF IEN=0
- QUIT
- +4 SET EXISTDIS=$$GET1^DIQ(101,IEN,2)
- +5 IF (ACTION="DISABLE")
- IF (EXISTDIS'="")
- QUIT
- +6 IF (ACTION="ENABLE")
- IF (EXISTDIS'=DISTEXT)
- QUIT
- +7 SET IENS=IEN_","
- +8 SET FDA(101,IENS,2)=DISABLE
- +9 DO FILE^DIE("","FDA","MSG")
- +10 QUIT
- +11 ;
- +12 ;=================================
- PROTCOLS(ACTION,DISTEXT) ;Disable/enable protocols.
- +1 NEW DISABLE,PROT,RESULT
- +2 SET DISABLE=$SELECT(ACTION="DISABLE":DISTEXT,ACTION="ENABLE":"",1:"")
- +3 DO BMES^XPDUTL(ACTION_" protocols.")
- +4 ;
- +5 DO PROTOCOL^PXRMUTIL("ORS HEALTH SUMMARY",ACTION,DISABLE,DISTEXT)
- +6 DO PROTOCOL^PXRMUTIL("ORS AD HOC HEALTH SUMMARY",ACTION,DISABLE,DISTEXT)
- +7 DO PROTOCOL^PXRMUTIL("PXRM PATIENT DATA CHANGE",ACTION,DISABLE,DISTEXT)
- +8 QUIT
- +9 ;
- +10 ;=================================
- RENAME(FILENUM,OLDNAME,NEWNAME) ;Rename entry OLDNAME to NEWNAME in
- +1 ;file number FILENUM.
- +2 NEW IEN,NIEN,MSG,PXRMINST
- +3 SET IEN=+$$FIND1^DIC(FILENUM,"","BXU",OLDNAME)
- +4 IF IEN=0
- QUIT
- +5 SET PXRMINST=1
- +6 SET NIEN=+$$FIND1^DIC(FILENUM,"","BXU",NEWNAME)
- IF NIEN>0
- QUIT
- +7 SET FDA(FILENUM,IEN_",",.01)=NEWNAME
- +8 DO FILE^DIE("ET","FDA","MSG")
- +9 QUIT
- +10 ;
- +11 ;=================================
- RMEHIST(FILENUM,IEN) ;Remove the edit history for a reminder file.
- +1 IF (FILENUM<800)!(FILENUM>811.9)!(FILENUM=811.8)
- QUIT
- +2 NEW DA,DIK,GLOBAL,ROOT
- +3 SET GLOBAL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
- +4 ;Edit History is stored in node 110 for all files.
- +5 SET DA(1)=IEN
- +6 SET DIK=GLOBAL_IEN_",110,"
- +7 SET ROOT=GLOBAL_IEN_",110,DA)"
- +8 SET DA=0
- +9 FOR
- SET DA=+$ORDER(@ROOT)
- if DA=0
- QUIT
- DO ^DIK
- +10 QUIT
- +11 ;
- +12 ;=================================
- SEHIST(FILENUM,ROOT,IEN) ;Set the edit date and edit by and prompt the
- +1 ;user for the edit comment.
- +2 NEW DIC,DIR,DWLW,DWPK,ENTRY,FDA,FDAIEN,IENS,IND,MSG,SFN,TARGET,X,Y
- +3 KILL ^TMP("PXRMWP",$JOB)
- +4 DO FIELD^DID(FILENUM,"EDIT HISTORY","","SPECIFIER","TARGET")
- +5 SET SFN=+$GET(TARGET("SPECIFIER"))
- +6 IF SFN=0
- QUIT
- +7 SET ENTRY=ROOT_IEN_",110)"
- +8 SET IND=$ORDER(@ENTRY@("B"),-1)
- +9 SET IND=IND+1
- +10 SET IENS="+"_IND_","_IEN_","
- +11 SET FDAIEN(IEN)=IEN
- +12 SET FDA(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
- +13 SET FDA(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01)
- +14 ;Prompt the user for edit comments.
- +15 SET DIC="^TMP(""PXRMWP"",$J,"
- +16 SET DWLW=72
- +17 SET DWPK=1
- +18 WRITE !,"Input your edit comments."
- +19 SET DIR(0)="Y"_U_"AO"
- +20 SET DIR("A")="Edit"
- +21 SET DIR("B")="NO"
- +22 DO ^DIR
- +23 IF Y
- Begin DoDot:1
- +24 DO EN^DIWE
- +25 KILL ^TMP("PXRMWP",$JOB,0)
- +26 IF $DATA(^TMP("PXRMWP",$JOB))
- SET FDA(SFN,IENS,2)="^TMP(""PXRMWP"",$J)"
- End DoDot:1
- +27 DO UPDATE^DIE("E","FDA","FDAIEN","MSG")
- +28 IF $DATA(MSG)
- DO AWRITE^PXRMUTIL("MSG")
- +29 KILL ^TMP("PXRMWP",$JOB)
- +30 QUIT
- +31 ;
- +32 ;=================================
- SETPVER(VERSION) ;Set the package version
- +1 NEW DA,DIE,DR
- +2 SET DIE="^PXRM(800,"
- SET DA=1
- SET DR="5////"_VERSION
- +3 DO ^DIE
- +4 QUIT
- +5 ;
- +6 ;=================================
- SFRES(SDIR,NRES,FIEVAL) ;Save the finding result.
- +1 IF NRES=0
- SET FIEVAL=0
- QUIT
- +2 NEW DATE,IND,OA,SUB,TF
- +3 FOR IND=1:1:NRES
- SET OA(FIEVAL(IND,"DATE"),FIEVAL(IND),IND)=""
- +4 ;If SDIR is positive get the oldest date otherwise get the most
- +5 ;recent date.
- +6 SET DATE=$SELECT(SDIR>0:$ORDER(OA("")),1:$ORDER(OA(""),-1))
- +7 ;If there is a true finding on DATE get it.
- +8 SET TF=$ORDER(OA(DATE,""),-1)
- +9 SET IND=$ORDER(OA(DATE,TF,""))
- +10 SET FIEVAL=TF
- +11 SET SUB=""
- +12 FOR
- SET SUB=$ORDER(FIEVAL(IND,SUB))
- if SUB=""
- QUIT
- MERGE FIEVAL(SUB)=FIEVAL(IND,SUB)
- +13 QUIT
- +14 ;
- +15 ;=================================
- SSPAR(FIND0,NOCC,BDT,EDT) ;Set the finding search parameters.
- +1 SET BDT=$PIECE(FIND0,U,8)
- SET EDT=$PIECE(FIND0,U,11)
- SET NOCC=$PIECE(FIND0,U,14)
- +2 IF +NOCC=0
- SET NOCC=1
- +3 ;Convert the dates to FileMan dates.
- +4 SET BDT=$SELECT(BDT="":0,BDT=0:0,1:$$CTFMD^PXRMDATE(BDT))
- +5 IF EDT=""
- SET EDT="T"
- +6 IF $GET(PXRMDEBG)=1
- Begin DoDot:1
- +7 NEW TIME
- SET TIME=$PIECE(PXRMDATE,".",2)
- +8 IF TIME'=""
- SET TIME="."_TIME
- +9 SET EDT=$SELECT(EDT="T":PXRMDATE,1:$$CTFMD^PXRMDATE(EDT)_TIME)
- End DoDot:1
- +10 IF '$TEST
- SET EDT=$$CTFMD^PXRMDATE(EDT)
- +11 ;If EDT does not contain a time set it to the end of the day.
- +12 IF (EDT'=-1)
- IF EDT'["."
- SET EDT=EDT_".235959"
- +13 IF $GET(PXRMDDOC)'=1
- QUIT
- +14 SET ^TMP("PXRMDDOC",$JOB,$PIECE(FIND0,U,1,11))=BDT_U_EDT
- +15 QUIT
- +16 ;
- +17 ;=================================
- 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 ;
- +17 ;=================================
- UPEHIST(FILENUM,IEN,TEXT,MSG) ;Update the edit history.
- +1 NEW FDA,GBL,IENS,IND,LN,NEXT,SUBFN,TARGET,WPTMP
- +2 DO FIELD^DID(FILENUM,"EDIT HISTORY","","SPECIFIER","TARGET")
- +3 SET SUBFN=+$GET(TARGET("SPECIFIER"))
- +4 IF SUBFN=0
- QUIT
- +5 SET GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")_IEN_",110)"
- +6 SET NEXT=$ORDER(@GBL@("B"),-1)+1
- +7 SET (IND,LN)=0
- +8 FOR
- SET IND=$ORDER(TEXT(IND))
- if IND=""
- QUIT
- Begin DoDot:1
- +9 SET LN=LN+1
- +10 SET WPTMP(1,2,LN)=TEXT(IND)
- End DoDot:1
- +11 SET IENS="+"_NEXT_","_IEN_","
- +12 SET FDA(SUBFN,IENS,.01)=$$NOW^XLFDT
- +13 SET FDA(SUBFN,IENS,1)=$GET(DUZ)
- +14 SET FDA(SUBFN,IENS,2)="WPTMP(1,2)"
- +15 DO UPDATE^DIE("","FDA","","MSG")
- +16 QUIT
- +17 ;
- +18 ;=================================
- VEDIT(ROOT,IEN) ;This is used as a DIC("S") screen to select which entries
- +1 ;a user can edit.
- +2 NEW CLASS,ENTRY,VALID
- +3 SET ENTRY=ROOT_IEN_")"
- +4 SET CLASS=$PIECE($GET(@ENTRY@(100)),U,1)
- +5 IF CLASS="N"
- Begin DoDot:1
- +6 IF ($GET(PXRMINST)=1)
- IF (DUZ(0)="@")
- SET VALID=1
- +7 IF '$TEST
- SET VALID=0
- End DoDot:1
- +8 IF '$TEST
- SET VALID=1
- +9 QUIT VALID
- +10 ;