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

LRUTIL.m

Go to the documentation of this file.
  1. LRUTIL ;DALOI/JDB -- Lab Utilities ;Aug 15, 2008
  1. ;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
  1. ;
  1. ;File ^XUSEC/10076
  1. Q
  1. ;
  1. SELECT(DIC,OUT,FNAME,SELS,SORT,NOALL,MODE) ;
  1. ; convenience method
  1. ; Package replacement for FIRST^VAUTOMA
  1. ; Allows user to select multiple entries from a file.
  1. Q $$SELECT^LRUTIL1(.DIC,.OUT,FNAME,SELS,SORT,NOALL,MODE)
  1. ;
  1. ;
  1. GETLOCK(ZZZZTARG,ZZZZSECS,ZZZZSHOW) ;
  1. ; Acquire a Lock on the specified resource.
  1. ; Note: "ZZZ*" variable names used to avoid possible variable
  1. ; name clashes with @TARG -- "^GBL(1,X)" N X then @TARG would
  1. ; change the intended resource for lock since X would be different.
  1. ; Inputs
  1. ; TARG : The Resource to Lock (ie "^GBL(1)")
  1. ; SECS : Total # of seconds to wait for the lock
  1. ; : (Minimum value is 5 seconds)
  1. ; : Negative value means one solid wait (no breaks)
  1. ; SHOW : >0:show progress, 0:dont show progress
  1. ; : 1:dots 2:countdown 3: timeleft+dots
  1. ; Output
  1. ; 1 if lock obtained, 0 if not.
  1. ; If SHOW>0 API outputs progress info
  1. ;
  1. N ZZZZZZZI,ZZZZLOCK,ZZZTRIES,ZZZZZZTO
  1. S ZZZZLOCK=0
  1. S ZZZZTARG=$G(ZZZZTARG)
  1. S ZZZZSECS=+$G(ZZZZSECS)
  1. S ZZZZSHOW=+$G(ZZZZSHOW)
  1. S ZZZZZZTO=$G(DILOCKTM,5) ;timeout
  1. S:ZZZZZZTO<5 ZZZZZZTO=5
  1. I ZZZZSECS'<0 I ZZZZSECS<5 S ZZZZSECS=5
  1. S ZZZTRIES=ZZZZSECS/ZZZZZZTO
  1. S:ZZZTRIES["." ZZZTRIES=$P(ZZZTRIES,".",1)+1
  1. ;
  1. I ZZZZSECS>0 F ZZZZZZZI=1:1:ZZZTRIES L +(@ZZZZTARG):ZZZZZZTO S:$T ZZZZLOCK=1 Q:ZZZZLOCK D ;
  1. . I ZZZTRIES>1 I ZZZZSHOW D ;
  1. . . Q:$$ISQUIET()
  1. . . I ZZZZSHOW=3 W:ZZZZZZZI=1 " ",ZZZTRIES-1*ZZZZZZTO W "."
  1. . . I ZZZZSHOW=2 W " ",(ZZZTRIES-ZZZZZZZI)*ZZZZZZTO
  1. . . I ZZZZSHOW=1 W "."
  1. ;
  1. I ZZZZSECS<0 D ;
  1. . S ZZZZSECS=-ZZZZSECS
  1. . S:ZZZZSECS<ZZZZZZTO ZZZZSECS=ZZZZZZTO
  1. . L +(@ZZZZTARG):ZZZZSECS
  1. . S:$T ZZZZLOCK=1
  1. ;
  1. Q ZZZZLOCK
  1. ;
  1. ;
  1. QUE(ZTRTN,ZTDESC,ZTSAVE,NOQUE,QUIET) ;
  1. ; Prompts for Device and allows queueing a routine
  1. ; Inputs
  1. ; ZTRTN :
  1. ; ZTDESC :
  1. ; ZTSAVE : <byref>
  1. ; NOQUE : 1=no queue 0=allow queue
  1. ; Outputs
  1. ; Returns -1 if POP=1, 0 if not queued, or the QUEUED task #
  1. N %ZIS,POP,QUEUED,Y,X,%X,%Y
  1. ; New variables for protection from %ZIS and DIR collision
  1. N %,%A,%B,%B1,%B2,%B3,%BA,%C,%E,%G,%H,%I,%J,%N,%P,%S,%T,%W,%X,%Y
  1. N A0,C,D,DD,DDH,DDQ,DDSV,DG,DH,DIC,DIFLD,DIRO,DO,DP,DQ,DU,DZ,X1
  1. N XQH,DIX,DIY,DISYS,%BU,%J1,%A0,%W0,%D1,%D2,%DT,%K,%M
  1. ;
  1. S NOQUE=$G(NOQUE)
  1. S QUIET=$G(QUIET)
  1. S QUEUED=0
  1. S %ZIS="M"
  1. I 'NOQUE S %ZIS=%ZIS_"Q"
  1. D ^%ZIS
  1. I POP D HOME^%ZIS Q -1
  1. I $D(IO("Q")) D ;
  1. . S QUEUED=$$TASK(ZTRTN,ZTDESC,.ZTSAVE,QUIET)
  1. . D HOME^%ZIS
  1. . K IO("Q")
  1. Q QUEUED
  1. ;
  1. ;
  1. TASK(ZTRTN,ZTDESC,ZTSAVE,QUIET,ZTDTH,ZTIO) ;
  1. ; Tasks the specified routine
  1. ; Returns the task # or 0
  1. ; ZTSAVE:<byref>
  1. N ZTSK,X,X1,X2,DIE,DIR,DIC,DA
  1. S QUIET=$G(QUIET)
  1. D ^%ZTLOAD
  1. I 'QUIET I '$$ISQUIET W !,"Request "_$S($G(ZTSK):"queued - Task #"_ZTSK,1:"NOT queued")
  1. Q +$G(ZTSK)
  1. ;
  1. ;
  1. ISQUIET() ;
  1. ; Is "Quiet" or not (Should we Write output?)
  1. N QUIET
  1. S QUIET=0
  1. S:$G(LRQUIET) QUIET=1
  1. S:$G(DIQUIET) QUIET=1
  1. Q QUIET
  1. ;
  1. ;
  1. RDELTSK(LRDELRTN,ZTDESC,ZTDTH) ;
  1. ; Delete routines via a tasked job it creates
  1. ; Inputs
  1. ; LRDELRTN: <byref> Array that holds the routines to delete
  1. ; ZTDESC: <opt> Description to use for tasked job
  1. ; ZTDTH: <opt> Date/Time (in $H) for job to run
  1. ; Outputs
  1. ; The task number
  1. N QUE,ZTSAVE
  1. S ZTDESC=$G(ZTDESC)
  1. I ZTDESC="" S ZTDESC="Delete routines via tasked job"
  1. S ZTSAVE("LRDELRTN")=""
  1. S ZTSAVE("LRDELRTN(")=""
  1. S ZTSAVE("XPD*")="" ;called from a patch install?
  1. S QUE=$$TASK("DELRTNS^LRUTIL(,1)",ZTDESC,.ZTSAVE,"",$G(ZTDTH),"")
  1. Q QUE
  1. ;
  1. ;
  1. DELRTNS(RTNS,USELRDEL) ;
  1. ; Delete routines
  1. ; Useful for deleting routines via TaskMan
  1. ; For easier use with TaskMan, the LRDELRTN array can also be
  1. ; setup prior to calling with TaskMan to delete multiple routines.
  1. ; Inputs
  1. ; RTNS : <byref> The routine(s) to delete
  1. ; : RTNS="rtn" or RTNS("rtn")="" or RTNS(#)=rtn
  1. ; USELRDEL : 1=use LRDELRTN array 0=dont use
  1. ; : Setup array LRDELRTN(rtn) or LRDELRTN(#)=rtn
  1. ; : and then call.
  1. ; LRDELRTN : <symtbl><opt> Array of routines to delete
  1. N X,I,DEL,RTN
  1. S RTNS=$G(RTNS)
  1. S USELRDEL=$G(USELRDEL)
  1. ; Honor KIDS "No Delete" setting if called from a KIDS install.
  1. I $G(XPDNM)'="" I $$GET^XUPARAM("XPD NO_EPP_DELETE") D Q ;
  1. . I $D(ZTQUEUED) S ZTREQ="@"
  1. ;
  1. I RTNS'="" S DEL=RTNS
  1. S I=""
  1. F S I=$O(RTNS(I)) Q:I="" D ;
  1. . I RTNS(I)="" S DEL(I)=""
  1. . I RTNS(I)'="" S DEL(RTNS(I))=""
  1. ;
  1. S I=""
  1. I USELRDEL I $D(LRDELRTN) F S I=$O(LRDELRTN(I)) Q:I="" D ;
  1. . I LRDELRTN(I)="" S DEL(I)=""
  1. . I LRDELRTN(I)'="" S DEL(LRDELRTN(I))=""
  1. ; now delete
  1. S RTN=""
  1. F S RTN=$O(DEL(RTN)) Q:RTN="" D ;
  1. . Q:"^LR^LA^"'[("^"_$E(RTN,1,2)_"^")
  1. . S X=RTN
  1. . X ^%ZOSF("TEST")
  1. . Q:'$T
  1. . X ^%ZOSF("DEL")
  1. I $D(ZTQUEUED) S ZTREQ="@"
  1. Q
  1. ;
  1. ;
  1. NP(ABORT,PGDATA) ;
  1. ; Next Page Handler
  1. ; Generic display utility. Prints HDR and FTR when needed.
  1. ; Caller should check ABORT and terminate when 1.
  1. ; Caller needs to make initial call to their HDR code
  1. ; and to call their FTR code at end if needed.
  1. ; Note: Header code should place cursor on start
  1. ; of newline when done.
  1. ; Inputs
  1. ; ABORT : <byref> Equals 1 if user enters "^" at "MORE" prompt
  1. ; PGDATA : <byref> Page Data array
  1. ; : "PGNUM": current page number
  1. ; : "BM": Bottom Margin (# of lines in footer)
  1. ; : "HDR": Executable M code for header
  1. ; : "FTR": Executable M code for footer
  1. ; : "NOPROMPT": Dont show "more" prompt (0 or 1) <dflt=0>
  1. ; : "PROMPT": (string) Replacement for "More" prompt
  1. ; : "PROMPTX": Executable M code to run for "More" prompt
  1. ; : The M Code must set var X equal to the prompt to use.
  1. ; : "WFTR": the footer was written (=1)
  1. ; : "ERASE": Erase MORE prompt (1=Erase 0=Dont erase dflt=1)
  1. ; : "IOF": <opt>IOF control.
  1. ; : IOF=0: IOF not issued for non "C-" type devices.
  1. ; : IOF=1: IOF issued for "C-" type devices.
  1. ;Outputs
  1. ; ABORT : 0 or 1 if user wants to quit display
  1. ; PGDATA : "PGNUM" incremented as needed
  1. ; : "WFTR" = 1 if footer was written
  1. ; : "NP": Is it a "New Page"? (Was "MORE" prompt displayed)
  1. ;
  1. ;
  1. ; Example code to write last footer if needed
  1. ; I 'STOP I '$G(PGDATA("WFTR")) D ;
  1. ; . I $G(PGDATA("FTR"))="" Q
  1. ; . I $E($G(IOST),1,2)'="C-" D ;
  1. ; . . N I,BM
  1. ; . . S BM=$G(PGDATA("BM"))
  1. ; . . F I=$Y+1:1:($G(IOSL,60)-BM-1) W !
  1. ; . X PGDATA("FTR")
  1. ;
  1. N X,PGNUM,BM,HDR,FTR,INHDR,INFTR,ERASE
  1. S ABORT=$G(ABORT)
  1. S PGNUM=$G(PGDATA("PGNUM"))
  1. S BM=$G(PGDATA("BM"))
  1. S PGDATA("WFTR")=0
  1. S PGDATA("NP")=0
  1. I PGNUM<1 S PGNUM=1 S PGDATA("PGNUM")=PGNUM
  1. Q:ABORT
  1. I BM<0 S BM=0
  1. I $Y+1<($G(IOSL,24)-BM) Q
  1. ;
  1. S HDR=$G(PGDATA("HDR"))
  1. S FTR=$G(PGDATA("FTR"))
  1. S ERASE=$G(PGDATA("ERASE"),1)
  1. S (INHDR,INFTR)=0
  1. S PGDATA("NP")=1
  1. ;
  1. I FTR'="" I 'INFTR D ;
  1. . N POSY
  1. . S POSY=$Y
  1. . S INFTR=1
  1. . X FTR
  1. . S PGDATA("WFTR")=1
  1. . S INFTR=0
  1. . ;handle form feed
  1. . I $G(IOF)'="",POSY<$Y D
  1. . . I $E(IOST,1,2)="C-",$G(PGDATA("IOF"))="1" W @IOF
  1. . . ;
  1. . . I $E($G(IOST),1,2)'="C-",$G(PGDATA("IOF"))'="0" W @IOF
  1. ;
  1. ; do "MORE" prompting
  1. I $E($G(IOST),1,2)="C-" D Q:ABORT ;
  1. . Q:$G(PGDATA("NOPROMPT"))
  1. . S X=0
  1. . Q:$D(ZTQUEUED)
  1. . I $G(PGDATA("PROMPTX"))'="" D ;
  1. . . K X
  1. . . X PGDATA("PROMPTX")
  1. . . S X=$G(X)
  1. . . S ABORT=$$MORE(X,ERASE)
  1. . ;
  1. . I $G(PGDATA("PROMPTX"))="" S ABORT=$$MORE($G(PGDATA("PROMPT")),ERASE)
  1. . ;
  1. ;
  1. S $Y=0
  1. S PGNUM=PGNUM+1
  1. S PGDATA("PGNUM")=PGNUM
  1. I HDR'="",'INHDR D ;
  1. . S INHDR=1
  1. . X HDR
  1. . S INHDR=0
  1. Q
  1. ;
  1. ;
  1. MORE(PROMPT,ERASE) ;
  1. ; Prompts user to hit ENTER to continue
  1. ; Returns 1 if user enters "^" else returns 0
  1. N DIR,DIRUT,DTOUT,DUOUT,X,Y
  1. S PROMPT=$G(PROMPT)
  1. S ERASE=$G(ERASE,1)
  1. I '$D(ZTQUEUED) D ;
  1. . I $E($G(IOST),1,2)'="C-" Q
  1. . S DIR(0)="E"
  1. . I PROMPT'="" S DIR("A")=PROMPT S DIR(0)="EA"
  1. . D ^DIR
  1. . I ERASE W $C(13)_$J("",$G(IOM,80))_$C(13)
  1. I $Q Q $D(DIRUT)
  1. Q
  1. ;
  1. ;
  1. DATAOK(LRFILE,LRFLD,LRVAL) ;
  1. ; Checks if a value is appropriate for storing in the field
  1. ; Inputs
  1. ; LRFILE : File #
  1. ; LRFLD : Field #
  1. ; LRVAL : Value of the field
  1. ;
  1. ; Returns 0 (invalid) or 1 (valid)
  1. ;
  1. N STATUS,LROUT,LRMSG,DIERR
  1. S STATUS=0
  1. D CHK^DIE(LRFILE,LRFLD,"",LRVAL,.LROUT,"LRMSG")
  1. I $G(LROUT)'="^" S STATUS=1
  1. I $D(LRMSG) S STATUS=0
  1. Q STATUS
  1. ;
  1. ;
  1. OWNSKEY(KEY,IEN) ;
  1. ;File ^XUSEC/10076
  1. ; Does user own specific key?
  1. ; Inputs
  1. ; KEY: The Key's NAME
  1. ; IEN: User's IEN <dflt=DUZ>
  1. ; Outputs
  1. ; Returns 1 if user owns key, 0 otherwise.
  1. ;
  1. N LRLIST,LROWNS
  1. S LRLIST(1)=KEY,IEN=$G(IEN,$G(DUZ))
  1. D OWNSKEY^XUSRB(.LROWNS,.LRLIST,IEN)
  1. ;
  1. Q +$G(LROWNS(1))