PXRMUTIL ;SLC/PKR/PJH - Utility routines for use by PXRM. ;02/05/2013
;;2.0;CLINICAL REMINDERS;**4,6,11,12,17,18,24,26**;Feb 04, 2005;Build 404
;
;=================================
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
;
;=================================
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 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("PXRM",$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
D MES^XPDUTL(.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
;
;=================================
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 ListMan 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,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^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
S IOTP=IOT
D APRINT^PXRMUTIL(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^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(ACT) ;Disable/enable options.
N ACTION,IND,OPT,LIST,RESULT
S ACTION=$S(ACT="DISABLE":2,ACT="ENABLE":1,1:1)
D BMES^XPDUTL(ACT_" options.")
;
D FIND^DIC(19,"","@;.01","","GMTS","*","B","","","LIST")
F IND=1:1:+LIST("DILIST",0) S OPT=LIST("DILIST","ID",IND,.01)
S RESULT=$$OPTDE^XPDUTL(OPT,ACTION)
I RESULT=0 D MES^XPDUTL("Could not "_ACT_" option "_OPT)
;
K LIST
D FIND^DIC(19,"","@;.01","","IBDF PRINT","*","B","","","LIST")
F IND=1:1:+LIST("DILIST",0) D
. S OPT=LIST("DILIST","ID",IND,.01)
. S RESULT=$$OPTDE^XPDUTL(OPT,ACTION)
. I RESULT=0 D MES^XPDUTL("Could not "_ACT_" option "_OPT)
;
S OPT="OR CPRS GUI CHART"
S RESULT=$$OPTDE^XPDUTL(OPT,ACTION)
I RESULT=0 D MES^XPDUTL("Could not "_ACT_" option "_OPT)
;
S OPT="ORS HEALTH SUMMARY"
S RESULT=$$OPTDE^XPDUTL(OPT,ACTION)
I RESULT=0 D MES^XPDUTL("Could not "_ACT_" option "_OPT)
;
K LIST
D FIND^DIC(19,"","@;.01","","PXRM","*","B","","","LIST")
F IND=1:1:+LIST("DILIST",0) D
. S OPT=LIST("DILIST","ID",IND,.01)
. S RESULT=$$OPTDE^XPDUTL(OPT,ACTION)
. I RESULT=0 W !,"Could not ",ACTION," option ",OPT
Q
;
;=================================
PROTOCOL(ACT) ;Disable/enable protocols.
N ACTION,PROT,RESULT
S ACTION=$S(ACT="DISABLE":2,ACT="ENABLE":1,1:1)
D BMES^XPDUTL(ACT_" protocols.")
;
S PROT="ORS HEALTH SUMMARY"
S RESULT=$$PRODE^XPDUTL(PROT,ACTION)
I RESULT=0 D MES^XPDUTL("Could not "_ACT_" protocol "_PROT)
;
S PROT="ORS AD HOC HEALTH SUMMARY"
S RESULT=$$PRODE^XPDUTL(PROT,ACTION)
I RESULT=0 D MES^XPDUTL("Could not "_ACT_" protocol "_PROT)
;
S PROT="PXRM PATIENT DATA CHANGE"
S RESULT=$$PRODE^XPDUTL(PROT,ACTION)
I RESULT=0 D MES^XPDUTL("Could not "_ACT_" protocol "_PROT)
Q
;
;=================================
RENAME(FILENUM,OLDNAME,NEWNAME) ;Rename entry OLDNAME to NEWNAME in
;file number FILENUM.
N DA,DIE,DR,NIEN,PXRMINST
S DA=$$FIND1^DIC(FILENUM,"","BXU",OLDNAME)
I DA=0 Q
S PXRMINST=1
S NIEN=$$FIND1^DIC(FILENUM,"","BXU",NEWNAME) I NIEN>0 Q
S DIE=FILENUM
S DR=".01///^S X=NEWNAME"
D ^DIE
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"
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
;
PXRMUTIL ;SLC/PKR/PJH - Utility routines for use by PXRM. ;02/05/2013
+1 ;;2.0;CLINICAL REMINDERS;**4,6,11,12,17,18,24,26**;Feb 04, 2005;Build 404
+2 ;
+3 ;=================================
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 ;=================================
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 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("PXRM",$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 DO MES^XPDUTL(.TEXT)
+21 QUIT
+22 ;
+23 ;=================================
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 ;=================================
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 ListMan 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,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^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 SET IOTP=IOT
+23 DO APRINT^PXRMUTIL(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^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(ACT) ;Disable/enable options.
+1 NEW ACTION,IND,OPT,LIST,RESULT
+2 SET ACTION=$SELECT(ACT="DISABLE":2,ACT="ENABLE":1,1:1)
+3 DO BMES^XPDUTL(ACT_" options.")
+4 ;
+5 DO FIND^DIC(19,"","@;.01","","GMTS","*","B","","","LIST")
+6 FOR IND=1:1:+LIST("DILIST",0)
SET OPT=LIST("DILIST","ID",IND,.01)
+7 SET RESULT=$$OPTDE^XPDUTL(OPT,ACTION)
+8 IF RESULT=0
DO MES^XPDUTL("Could not "_ACT_" option "_OPT)
+9 ;
+10 KILL LIST
+11 DO FIND^DIC(19,"","@;.01","","IBDF PRINT","*","B","","","LIST")
+12 FOR IND=1:1:+LIST("DILIST",0)
Begin DoDot:1
+13 SET OPT=LIST("DILIST","ID",IND,.01)
+14 SET RESULT=$$OPTDE^XPDUTL(OPT,ACTION)
+15 IF RESULT=0
DO MES^XPDUTL("Could not "_ACT_" option "_OPT)
End DoDot:1
+16 ;
+17 SET OPT="OR CPRS GUI CHART"
+18 SET RESULT=$$OPTDE^XPDUTL(OPT,ACTION)
+19 IF RESULT=0
DO MES^XPDUTL("Could not "_ACT_" option "_OPT)
+20 ;
+21 SET OPT="ORS HEALTH SUMMARY"
+22 SET RESULT=$$OPTDE^XPDUTL(OPT,ACTION)
+23 IF RESULT=0
DO MES^XPDUTL("Could not "_ACT_" option "_OPT)
+24 ;
+25 KILL LIST
+26 DO FIND^DIC(19,"","@;.01","","PXRM","*","B","","","LIST")
+27 FOR IND=1:1:+LIST("DILIST",0)
Begin DoDot:1
+28 SET OPT=LIST("DILIST","ID",IND,.01)
+29 SET RESULT=$$OPTDE^XPDUTL(OPT,ACTION)
+30 IF RESULT=0
WRITE !,"Could not ",ACTION," option ",OPT
End DoDot:1
+31 QUIT
+32 ;
+33 ;=================================
PROTOCOL(ACT) ;Disable/enable protocols.
+1 NEW ACTION,PROT,RESULT
+2 SET ACTION=$SELECT(ACT="DISABLE":2,ACT="ENABLE":1,1:1)
+3 DO BMES^XPDUTL(ACT_" protocols.")
+4 ;
+5 SET PROT="ORS HEALTH SUMMARY"
+6 SET RESULT=$$PRODE^XPDUTL(PROT,ACTION)
+7 IF RESULT=0
DO MES^XPDUTL("Could not "_ACT_" protocol "_PROT)
+8 ;
+9 SET PROT="ORS AD HOC HEALTH SUMMARY"
+10 SET RESULT=$$PRODE^XPDUTL(PROT,ACTION)
+11 IF RESULT=0
DO MES^XPDUTL("Could not "_ACT_" protocol "_PROT)
+12 ;
+13 SET PROT="PXRM PATIENT DATA CHANGE"
+14 SET RESULT=$$PRODE^XPDUTL(PROT,ACTION)
+15 IF RESULT=0
DO MES^XPDUTL("Could not "_ACT_" protocol "_PROT)
+16 QUIT
+17 ;
+18 ;=================================
RENAME(FILENUM,OLDNAME,NEWNAME) ;Rename entry OLDNAME to NEWNAME in
+1 ;file number FILENUM.
+2 NEW DA,DIE,DR,NIEN,PXRMINST
+3 SET DA=$$FIND1^DIC(FILENUM,"","BXU",OLDNAME)
+4 IF DA=0
QUIT
+5 SET PXRMINST=1
+6 SET NIEN=$$FIND1^DIC(FILENUM,"","BXU",NEWNAME)
IF NIEN>0
QUIT
+7 SET DIE=FILENUM
+8 SET DR=".01///^S X=NEWNAME"
+9 DO ^DIE
+10 QUIT
+11 ;
+12 ;=================================
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 SET EDT=$$CTFMD^PXRMDATE(EDT)
+7 ;If EDT does not contain a time set it to the end of the day.
+8 IF (EDT'=-1)
IF EDT'["."
SET EDT=EDT_".235959"
+9 IF $GET(PXRMDDOC)'=1
QUIT
+10 SET ^TMP("PXRMDDOC",$JOB,$PIECE(FIND0,U,1,11))=BDT_U_EDT
+11 QUIT
+12 ;
+13 ;=================================
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 ;
