- LRUTIL ;DALOI/JDB -- Lab Utilities ;Aug 15, 2008
- ;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
- ;
- ;File ^XUSEC/10076
- Q
- ;
- SELECT(DIC,OUT,FNAME,SELS,SORT,NOALL,MODE) ;
- ; convenience method
- ; Package replacement for FIRST^VAUTOMA
- ; Allows user to select multiple entries from a file.
- Q $$SELECT^LRUTIL1(.DIC,.OUT,FNAME,SELS,SORT,NOALL,MODE)
- ;
- ;
- GETLOCK(ZZZZTARG,ZZZZSECS,ZZZZSHOW) ;
- ; Acquire a Lock on the specified resource.
- ; Note: "ZZZ*" variable names used to avoid possible variable
- ; name clashes with @TARG -- "^GBL(1,X)" N X then @TARG would
- ; change the intended resource for lock since X would be different.
- ; Inputs
- ; TARG : The Resource to Lock (ie "^GBL(1)")
- ; SECS : Total # of seconds to wait for the lock
- ; : (Minimum value is 5 seconds)
- ; : Negative value means one solid wait (no breaks)
- ; SHOW : >0:show progress, 0:dont show progress
- ; : 1:dots 2:countdown 3: timeleft+dots
- ; Output
- ; 1 if lock obtained, 0 if not.
- ; If SHOW>0 API outputs progress info
- ;
- N ZZZZZZZI,ZZZZLOCK,ZZZTRIES,ZZZZZZTO
- S ZZZZLOCK=0
- S ZZZZTARG=$G(ZZZZTARG)
- S ZZZZSECS=+$G(ZZZZSECS)
- S ZZZZSHOW=+$G(ZZZZSHOW)
- S ZZZZZZTO=$G(DILOCKTM,5) ;timeout
- S:ZZZZZZTO<5 ZZZZZZTO=5
- I ZZZZSECS'<0 I ZZZZSECS<5 S ZZZZSECS=5
- S ZZZTRIES=ZZZZSECS/ZZZZZZTO
- S:ZZZTRIES["." ZZZTRIES=$P(ZZZTRIES,".",1)+1
- ;
- I ZZZZSECS>0 F ZZZZZZZI=1:1:ZZZTRIES L +(@ZZZZTARG):ZZZZZZTO S:$T ZZZZLOCK=1 Q:ZZZZLOCK D ;
- . I ZZZTRIES>1 I ZZZZSHOW D ;
- . . Q:$$ISQUIET()
- . . I ZZZZSHOW=3 W:ZZZZZZZI=1 " ",ZZZTRIES-1*ZZZZZZTO W "."
- . . I ZZZZSHOW=2 W " ",(ZZZTRIES-ZZZZZZZI)*ZZZZZZTO
- . . I ZZZZSHOW=1 W "."
- ;
- I ZZZZSECS<0 D ;
- . S ZZZZSECS=-ZZZZSECS
- . S:ZZZZSECS<ZZZZZZTO ZZZZSECS=ZZZZZZTO
- . L +(@ZZZZTARG):ZZZZSECS
- . S:$T ZZZZLOCK=1
- ;
- Q ZZZZLOCK
- ;
- ;
- QUE(ZTRTN,ZTDESC,ZTSAVE,NOQUE,QUIET) ;
- ; Prompts for Device and allows queueing a routine
- ; Inputs
- ; ZTRTN :
- ; ZTDESC :
- ; ZTSAVE : <byref>
- ; NOQUE : 1=no queue 0=allow queue
- ; Outputs
- ; Returns -1 if POP=1, 0 if not queued, or the QUEUED task #
- N %ZIS,POP,QUEUED,Y,X,%X,%Y
- ; New variables for protection from %ZIS and DIR collision
- N %,%A,%B,%B1,%B2,%B3,%BA,%C,%E,%G,%H,%I,%J,%N,%P,%S,%T,%W,%X,%Y
- N A0,C,D,DD,DDH,DDQ,DDSV,DG,DH,DIC,DIFLD,DIRO,DO,DP,DQ,DU,DZ,X1
- N XQH,DIX,DIY,DISYS,%BU,%J1,%A0,%W0,%D1,%D2,%DT,%K,%M
- ;
- S NOQUE=$G(NOQUE)
- S QUIET=$G(QUIET)
- S QUEUED=0
- S %ZIS="M"
- I 'NOQUE S %ZIS=%ZIS_"Q"
- D ^%ZIS
- I POP D HOME^%ZIS Q -1
- I $D(IO("Q")) D ;
- . S QUEUED=$$TASK(ZTRTN,ZTDESC,.ZTSAVE,QUIET)
- . D HOME^%ZIS
- . K IO("Q")
- Q QUEUED
- ;
- ;
- TASK(ZTRTN,ZTDESC,ZTSAVE,QUIET,ZTDTH,ZTIO) ;
- ; Tasks the specified routine
- ; Returns the task # or 0
- ; ZTSAVE:<byref>
- N ZTSK,X,X1,X2,DIE,DIR,DIC,DA
- S QUIET=$G(QUIET)
- D ^%ZTLOAD
- I 'QUIET I '$$ISQUIET W !,"Request "_$S($G(ZTSK):"queued - Task #"_ZTSK,1:"NOT queued")
- Q +$G(ZTSK)
- ;
- ;
- ISQUIET() ;
- ; Is "Quiet" or not (Should we Write output?)
- N QUIET
- S QUIET=0
- S:$G(LRQUIET) QUIET=1
- S:$G(DIQUIET) QUIET=1
- Q QUIET
- ;
- ;
- RDELTSK(LRDELRTN,ZTDESC,ZTDTH) ;
- ; Delete routines via a tasked job it creates
- ; Inputs
- ; LRDELRTN: <byref> Array that holds the routines to delete
- ; ZTDESC: <opt> Description to use for tasked job
- ; ZTDTH: <opt> Date/Time (in $H) for job to run
- ; Outputs
- ; The task number
- N QUE,ZTSAVE
- S ZTDESC=$G(ZTDESC)
- I ZTDESC="" S ZTDESC="Delete routines via tasked job"
- S ZTSAVE("LRDELRTN")=""
- S ZTSAVE("LRDELRTN(")=""
- S ZTSAVE("XPD*")="" ;called from a patch install?
- S QUE=$$TASK("DELRTNS^LRUTIL(,1)",ZTDESC,.ZTSAVE,"",$G(ZTDTH),"")
- Q QUE
- ;
- ;
- DELRTNS(RTNS,USELRDEL) ;
- ; Delete routines
- ; Useful for deleting routines via TaskMan
- ; For easier use with TaskMan, the LRDELRTN array can also be
- ; setup prior to calling with TaskMan to delete multiple routines.
- ; Inputs
- ; RTNS : <byref> The routine(s) to delete
- ; : RTNS="rtn" or RTNS("rtn")="" or RTNS(#)=rtn
- ; USELRDEL : 1=use LRDELRTN array 0=dont use
- ; : Setup array LRDELRTN(rtn) or LRDELRTN(#)=rtn
- ; : and then call.
- ; LRDELRTN : <symtbl><opt> Array of routines to delete
- N X,I,DEL,RTN
- S RTNS=$G(RTNS)
- S USELRDEL=$G(USELRDEL)
- ; Honor KIDS "No Delete" setting if called from a KIDS install.
- I $G(XPDNM)'="" I $$GET^XUPARAM("XPD NO_EPP_DELETE") D Q ;
- . I $D(ZTQUEUED) S ZTREQ="@"
- ;
- I RTNS'="" S DEL=RTNS
- S I=""
- F S I=$O(RTNS(I)) Q:I="" D ;
- . I RTNS(I)="" S DEL(I)=""
- . I RTNS(I)'="" S DEL(RTNS(I))=""
- ;
- S I=""
- I USELRDEL I $D(LRDELRTN) F S I=$O(LRDELRTN(I)) Q:I="" D ;
- . I LRDELRTN(I)="" S DEL(I)=""
- . I LRDELRTN(I)'="" S DEL(LRDELRTN(I))=""
- ; now delete
- S RTN=""
- F S RTN=$O(DEL(RTN)) Q:RTN="" D ;
- . Q:"^LR^LA^"'[("^"_$E(RTN,1,2)_"^")
- . S X=RTN
- . X ^%ZOSF("TEST")
- . Q:'$T
- . X ^%ZOSF("DEL")
- I $D(ZTQUEUED) S ZTREQ="@"
- Q
- ;
- ;
- NP(ABORT,PGDATA) ;
- ; Next Page Handler
- ; Generic display utility. Prints HDR and FTR when needed.
- ; Caller should check ABORT and terminate when 1.
- ; Caller needs to make initial call to their HDR code
- ; and to call their FTR code at end if needed.
- ; Note: Header code should place cursor on start
- ; of newline when done.
- ; Inputs
- ; ABORT : <byref> Equals 1 if user enters "^" at "MORE" prompt
- ; PGDATA : <byref> Page Data array
- ; : "PGNUM": current page number
- ; : "BM": Bottom Margin (# of lines in footer)
- ; : "HDR": Executable M code for header
- ; : "FTR": Executable M code for footer
- ; : "NOPROMPT": Dont show "more" prompt (0 or 1) <dflt=0>
- ; : "PROMPT": (string) Replacement for "More" prompt
- ; : "PROMPTX": Executable M code to run for "More" prompt
- ; : The M Code must set var X equal to the prompt to use.
- ; : "WFTR": the footer was written (=1)
- ; : "ERASE": Erase MORE prompt (1=Erase 0=Dont erase dflt=1)
- ; : "IOF": <opt>IOF control.
- ; : IOF=0: IOF not issued for non "C-" type devices.
- ; : IOF=1: IOF issued for "C-" type devices.
- ;Outputs
- ; ABORT : 0 or 1 if user wants to quit display
- ; PGDATA : "PGNUM" incremented as needed
- ; : "WFTR" = 1 if footer was written
- ; : "NP": Is it a "New Page"? (Was "MORE" prompt displayed)
- ;
- ;
- ; Example code to write last footer if needed
- ; I 'STOP I '$G(PGDATA("WFTR")) D ;
- ; . I $G(PGDATA("FTR"))="" Q
- ; . I $E($G(IOST),1,2)'="C-" D ;
- ; . . N I,BM
- ; . . S BM=$G(PGDATA("BM"))
- ; . . F I=$Y+1:1:($G(IOSL,60)-BM-1) W !
- ; . X PGDATA("FTR")
- ;
- N X,PGNUM,BM,HDR,FTR,INHDR,INFTR,ERASE
- S ABORT=$G(ABORT)
- S PGNUM=$G(PGDATA("PGNUM"))
- S BM=$G(PGDATA("BM"))
- S PGDATA("WFTR")=0
- S PGDATA("NP")=0
- I PGNUM<1 S PGNUM=1 S PGDATA("PGNUM")=PGNUM
- Q:ABORT
- I BM<0 S BM=0
- I $Y+1<($G(IOSL,24)-BM) Q
- ;
- S HDR=$G(PGDATA("HDR"))
- S FTR=$G(PGDATA("FTR"))
- S ERASE=$G(PGDATA("ERASE"),1)
- S (INHDR,INFTR)=0
- S PGDATA("NP")=1
- ;
- I FTR'="" I 'INFTR D ;
- . N POSY
- . S POSY=$Y
- . S INFTR=1
- . X FTR
- . S PGDATA("WFTR")=1
- . S INFTR=0
- . ;handle form feed
- . I $G(IOF)'="",POSY<$Y D
- . . I $E(IOST,1,2)="C-",$G(PGDATA("IOF"))="1" W @IOF
- . . ;
- . . I $E($G(IOST),1,2)'="C-",$G(PGDATA("IOF"))'="0" W @IOF
- ;
- ; do "MORE" prompting
- I $E($G(IOST),1,2)="C-" D Q:ABORT ;
- . Q:$G(PGDATA("NOPROMPT"))
- . S X=0
- . Q:$D(ZTQUEUED)
- . I $G(PGDATA("PROMPTX"))'="" D ;
- . . K X
- . . X PGDATA("PROMPTX")
- . . S X=$G(X)
- . . S ABORT=$$MORE(X,ERASE)
- . ;
- . I $G(PGDATA("PROMPTX"))="" S ABORT=$$MORE($G(PGDATA("PROMPT")),ERASE)
- . ;
- ;
- S $Y=0
- S PGNUM=PGNUM+1
- S PGDATA("PGNUM")=PGNUM
- I HDR'="",'INHDR D ;
- . S INHDR=1
- . X HDR
- . S INHDR=0
- Q
- ;
- ;
- MORE(PROMPT,ERASE) ;
- ; Prompts user to hit ENTER to continue
- ; Returns 1 if user enters "^" else returns 0
- N DIR,DIRUT,DTOUT,DUOUT,X,Y
- S PROMPT=$G(PROMPT)
- S ERASE=$G(ERASE,1)
- I '$D(ZTQUEUED) D ;
- . I $E($G(IOST),1,2)'="C-" Q
- . S DIR(0)="E"
- . I PROMPT'="" S DIR("A")=PROMPT S DIR(0)="EA"
- . D ^DIR
- . I ERASE W $C(13)_$J("",$G(IOM,80))_$C(13)
- I $Q Q $D(DIRUT)
- Q
- ;
- ;
- DATAOK(LRFILE,LRFLD,LRVAL) ;
- ; Checks if a value is appropriate for storing in the field
- ; Inputs
- ; LRFILE : File #
- ; LRFLD : Field #
- ; LRVAL : Value of the field
- ;
- ; Returns 0 (invalid) or 1 (valid)
- ;
- N STATUS,LROUT,LRMSG,DIERR
- S STATUS=0
- D CHK^DIE(LRFILE,LRFLD,"",LRVAL,.LROUT,"LRMSG")
- I $G(LROUT)'="^" S STATUS=1
- I $D(LRMSG) S STATUS=0
- Q STATUS
- ;
- ;
- OWNSKEY(KEY,IEN) ;
- ;File ^XUSEC/10076
- ; Does user own specific key?
- ; Inputs
- ; KEY: The Key's NAME
- ; IEN: User's IEN <dflt=DUZ>
- ; Outputs
- ; Returns 1 if user owns key, 0 otherwise.
- ;
- N LRLIST,LROWNS
- S LRLIST(1)=KEY,IEN=$G(IEN,$G(DUZ))
- D OWNSKEY^XUSRB(.LROWNS,.LRLIST,IEN)
- ;
- Q +$G(LROWNS(1))
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUTIL 8891 printed Jan 18, 2025@03:22:56 Page 2
- LRUTIL ;DALOI/JDB -- Lab Utilities ;Aug 15, 2008
- +1 ;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
- +2 ;
- +3 ;File ^XUSEC/10076
- +4 QUIT
- +5 ;
- SELECT(DIC,OUT,FNAME,SELS,SORT,NOALL,MODE) ;
- +1 ; convenience method
- +2 ; Package replacement for FIRST^VAUTOMA
- +3 ; Allows user to select multiple entries from a file.
- +4 QUIT $$SELECT^LRUTIL1(.DIC,.OUT,FNAME,SELS,SORT,NOALL,MODE)
- +5 ;
- +6 ;
- GETLOCK(ZZZZTARG,ZZZZSECS,ZZZZSHOW) ;
- +1 ; Acquire a Lock on the specified resource.
- +2 ; Note: "ZZZ*" variable names used to avoid possible variable
- +3 ; name clashes with @TARG -- "^GBL(1,X)" N X then @TARG would
- +4 ; change the intended resource for lock since X would be different.
- +5 ; Inputs
- +6 ; TARG : The Resource to Lock (ie "^GBL(1)")
- +7 ; SECS : Total # of seconds to wait for the lock
- +8 ; : (Minimum value is 5 seconds)
- +9 ; : Negative value means one solid wait (no breaks)
- +10 ; SHOW : >0:show progress, 0:dont show progress
- +11 ; : 1:dots 2:countdown 3: timeleft+dots
- +12 ; Output
- +13 ; 1 if lock obtained, 0 if not.
- +14 ; If SHOW>0 API outputs progress info
- +15 ;
- +16 NEW ZZZZZZZI,ZZZZLOCK,ZZZTRIES,ZZZZZZTO
- +17 SET ZZZZLOCK=0
- +18 SET ZZZZTARG=$GET(ZZZZTARG)
- +19 SET ZZZZSECS=+$GET(ZZZZSECS)
- +20 SET ZZZZSHOW=+$GET(ZZZZSHOW)
- +21 ;timeout
- SET ZZZZZZTO=$GET(DILOCKTM,5)
- +22 if ZZZZZZTO<5
- SET ZZZZZZTO=5
- +23 IF ZZZZSECS'<0
- IF ZZZZSECS<5
- SET ZZZZSECS=5
- +24 SET ZZZTRIES=ZZZZSECS/ZZZZZZTO
- +25 if ZZZTRIES["."
- SET ZZZTRIES=$PIECE(ZZZTRIES,".",1)+1
- +26 ;
- +27 ;
- IF ZZZZSECS>0
- FOR ZZZZZZZI=1:1:ZZZTRIES
- LOCK +(@ZZZZTARG):ZZZZZZTO
- if $TEST
- SET ZZZZLOCK=1
- if ZZZZLOCK
- QUIT
- Begin DoDot:1
- +28 ;
- IF ZZZTRIES>1
- IF ZZZZSHOW
- Begin DoDot:2
- +29 if $$ISQUIET()
- QUIT
- +30 IF ZZZZSHOW=3
- if ZZZZZZZI=1
- WRITE " ",ZZZTRIES-1*ZZZZZZTO
- WRITE "."
- +31 IF ZZZZSHOW=2
- WRITE " ",(ZZZTRIES-ZZZZZZZI)*ZZZZZZTO
- +32 IF ZZZZSHOW=1
- WRITE "."
- End DoDot:2
- End DoDot:1
- +33 ;
- +34 ;
- IF ZZZZSECS<0
- Begin DoDot:1
- +35 SET ZZZZSECS=-ZZZZSECS
- +36 if ZZZZSECS<ZZZZZZTO
- SET ZZZZSECS=ZZZZZZTO
- +37 LOCK +(@ZZZZTARG):ZZZZSECS
- +38 if $TEST
- SET ZZZZLOCK=1
- End DoDot:1
- +39 ;
- +40 QUIT ZZZZLOCK
- +41 ;
- +42 ;
- QUE(ZTRTN,ZTDESC,ZTSAVE,NOQUE,QUIET) ;
- +1 ; Prompts for Device and allows queueing a routine
- +2 ; Inputs
- +3 ; ZTRTN :
- +4 ; ZTDESC :
- +5 ; ZTSAVE : <byref>
- +6 ; NOQUE : 1=no queue 0=allow queue
- +7 ; Outputs
- +8 ; Returns -1 if POP=1, 0 if not queued, or the QUEUED task #
- +9 NEW %ZIS,POP,QUEUED,Y,X,%X,%Y
- +10 ; New variables for protection from %ZIS and DIR collision
- +11 NEW %,%A,%B,%B1,%B2,%B3,%BA,%C,%E,%G,%H,%I,%J,%N,%P,%S,%T,%W,%X,%Y
- +12 NEW A0,C,D,DD,DDH,DDQ,DDSV,DG,DH,DIC,DIFLD,DIRO,DO,DP,DQ,DU,DZ,X1
- +13 NEW XQH,DIX,DIY,DISYS,%BU,%J1,%A0,%W0,%D1,%D2,%DT,%K,%M
- +14 ;
- +15 SET NOQUE=$GET(NOQUE)
- +16 SET QUIET=$GET(QUIET)
- +17 SET QUEUED=0
- +18 SET %ZIS="M"
- +19 IF 'NOQUE
- SET %ZIS=%ZIS_"Q"
- +20 DO ^%ZIS
- +21 IF POP
- DO HOME^%ZIS
- QUIT -1
- +22 ;
- IF $DATA(IO("Q"))
- Begin DoDot:1
- +23 SET QUEUED=$$TASK(ZTRTN,ZTDESC,.ZTSAVE,QUIET)
- +24 DO HOME^%ZIS
- +25 KILL IO("Q")
- End DoDot:1
- +26 QUIT QUEUED
- +27 ;
- +28 ;
- TASK(ZTRTN,ZTDESC,ZTSAVE,QUIET,ZTDTH,ZTIO) ;
- +1 ; Tasks the specified routine
- +2 ; Returns the task # or 0
- +3 ; ZTSAVE:<byref>
- +4 NEW ZTSK,X,X1,X2,DIE,DIR,DIC,DA
- +5 SET QUIET=$GET(QUIET)
- +6 DO ^%ZTLOAD
- +7 IF 'QUIET
- IF '$$ISQUIET
- WRITE !,"Request "_$SELECT($GET(ZTSK):"queued - Task #"_ZTSK,1:"NOT queued")
- +8 QUIT +$GET(ZTSK)
- +9 ;
- +10 ;
- ISQUIET() ;
- +1 ; Is "Quiet" or not (Should we Write output?)
- +2 NEW QUIET
- +3 SET QUIET=0
- +4 if $GET(LRQUIET)
- SET QUIET=1
- +5 if $GET(DIQUIET)
- SET QUIET=1
- +6 QUIT QUIET
- +7 ;
- +8 ;
- RDELTSK(LRDELRTN,ZTDESC,ZTDTH) ;
- +1 ; Delete routines via a tasked job it creates
- +2 ; Inputs
- +3 ; LRDELRTN: <byref> Array that holds the routines to delete
- +4 ; ZTDESC: <opt> Description to use for tasked job
- +5 ; ZTDTH: <opt> Date/Time (in $H) for job to run
- +6 ; Outputs
- +7 ; The task number
- +8 NEW QUE,ZTSAVE
- +9 SET ZTDESC=$GET(ZTDESC)
- +10 IF ZTDESC=""
- SET ZTDESC="Delete routines via tasked job"
- +11 SET ZTSAVE("LRDELRTN")=""
- +12 SET ZTSAVE("LRDELRTN(")=""
- +13 ;called from a patch install?
- SET ZTSAVE("XPD*")=""
- +14 SET QUE=$$TASK("DELRTNS^LRUTIL(,1)",ZTDESC,.ZTSAVE,"",$GET(ZTDTH),"")
- +15 QUIT QUE
- +16 ;
- +17 ;
- DELRTNS(RTNS,USELRDEL) ;
- +1 ; Delete routines
- +2 ; Useful for deleting routines via TaskMan
- +3 ; For easier use with TaskMan, the LRDELRTN array can also be
- +4 ; setup prior to calling with TaskMan to delete multiple routines.
- +5 ; Inputs
- +6 ; RTNS : <byref> The routine(s) to delete
- +7 ; : RTNS="rtn" or RTNS("rtn")="" or RTNS(#)=rtn
- +8 ; USELRDEL : 1=use LRDELRTN array 0=dont use
- +9 ; : Setup array LRDELRTN(rtn) or LRDELRTN(#)=rtn
- +10 ; : and then call.
- +11 ; LRDELRTN : <symtbl><opt> Array of routines to delete
- +12 NEW X,I,DEL,RTN
- +13 SET RTNS=$GET(RTNS)
- +14 SET USELRDEL=$GET(USELRDEL)
- +15 ; Honor KIDS "No Delete" setting if called from a KIDS install.
- +16 ;
- IF $GET(XPDNM)'=""
- IF $$GET^XUPARAM("XPD NO_EPP_DELETE")
- Begin DoDot:1
- +17 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- End DoDot:1
- QUIT
- +18 ;
- +19 IF RTNS'=""
- SET DEL=RTNS
- +20 SET I=""
- +21 ;
- FOR
- SET I=$ORDER(RTNS(I))
- if I=""
- QUIT
- Begin DoDot:1
- +22 IF RTNS(I)=""
- SET DEL(I)=""
- +23 IF RTNS(I)'=""
- SET DEL(RTNS(I))=""
- End DoDot:1
- +24 ;
- +25 SET I=""
- +26 ;
- IF USELRDEL
- IF $DATA(LRDELRTN)
- FOR
- SET I=$ORDER(LRDELRTN(I))
- if I=""
- QUIT
- Begin DoDot:1
- +27 IF LRDELRTN(I)=""
- SET DEL(I)=""
- +28 IF LRDELRTN(I)'=""
- SET DEL(LRDELRTN(I))=""
- End DoDot:1
- +29 ; now delete
- +30 SET RTN=""
- +31 ;
- FOR
- SET RTN=$ORDER(DEL(RTN))
- if RTN=""
- QUIT
- Begin DoDot:1
- +32 if "^LR^LA^"'[("^"_$EXTRACT(RTN,1,2)_"^")
- QUIT
- +33 SET X=RTN
- +34 XECUTE ^%ZOSF("TEST")
- +35 if '$TEST
- QUIT
- +36 XECUTE ^%ZOSF("DEL")
- End DoDot:1
- +37 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +38 QUIT
- +39 ;
- +40 ;
- NP(ABORT,PGDATA) ;
- +1 ; Next Page Handler
- +2 ; Generic display utility. Prints HDR and FTR when needed.
- +3 ; Caller should check ABORT and terminate when 1.
- +4 ; Caller needs to make initial call to their HDR code
- +5 ; and to call their FTR code at end if needed.
- +6 ; Note: Header code should place cursor on start
- +7 ; of newline when done.
- +8 ; Inputs
- +9 ; ABORT : <byref> Equals 1 if user enters "^" at "MORE" prompt
- +10 ; PGDATA : <byref> Page Data array
- +11 ; : "PGNUM": current page number
- +12 ; : "BM": Bottom Margin (# of lines in footer)
- +13 ; : "HDR": Executable M code for header
- +14 ; : "FTR": Executable M code for footer
- +15 ; : "NOPROMPT": Dont show "more" prompt (0 or 1) <dflt=0>
- +16 ; : "PROMPT": (string) Replacement for "More" prompt
- +17 ; : "PROMPTX": Executable M code to run for "More" prompt
- +18 ; : The M Code must set var X equal to the prompt to use.
- +19 ; : "WFTR": the footer was written (=1)
- +20 ; : "ERASE": Erase MORE prompt (1=Erase 0=Dont erase dflt=1)
- +21 ; : "IOF": <opt>IOF control.
- +22 ; : IOF=0: IOF not issued for non "C-" type devices.
- +23 ; : IOF=1: IOF issued for "C-" type devices.
- +24 ;Outputs
- +25 ; ABORT : 0 or 1 if user wants to quit display
- +26 ; PGDATA : "PGNUM" incremented as needed
- +27 ; : "WFTR" = 1 if footer was written
- +28 ; : "NP": Is it a "New Page"? (Was "MORE" prompt displayed)
- +29 ;
- +30 ;
- +31 ; Example code to write last footer if needed
- +32 ; I 'STOP I '$G(PGDATA("WFTR")) D ;
- +33 ; . I $G(PGDATA("FTR"))="" Q
- +34 ; . I $E($G(IOST),1,2)'="C-" D ;
- +35 ; . . N I,BM
- +36 ; . . S BM=$G(PGDATA("BM"))
- +37 ; . . F I=$Y+1:1:($G(IOSL,60)-BM-1) W !
- +38 ; . X PGDATA("FTR")
- +39 ;
- +40 NEW X,PGNUM,BM,HDR,FTR,INHDR,INFTR,ERASE
- +41 SET ABORT=$GET(ABORT)
- +42 SET PGNUM=$GET(PGDATA("PGNUM"))
- +43 SET BM=$GET(PGDATA("BM"))
- +44 SET PGDATA("WFTR")=0
- +45 SET PGDATA("NP")=0
- +46 IF PGNUM<1
- SET PGNUM=1
- SET PGDATA("PGNUM")=PGNUM
- +47 if ABORT
- QUIT
- +48 IF BM<0
- SET BM=0
- +49 IF $Y+1<($GET(IOSL,24)-BM)
- QUIT
- +50 ;
- +51 SET HDR=$GET(PGDATA("HDR"))
- +52 SET FTR=$GET(PGDATA("FTR"))
- +53 SET ERASE=$GET(PGDATA("ERASE"),1)
- +54 SET (INHDR,INFTR)=0
- +55 SET PGDATA("NP")=1
- +56 ;
- +57 ;
- IF FTR'=""
- IF 'INFTR
- Begin DoDot:1
- +58 NEW POSY
- +59 SET POSY=$Y
- +60 SET INFTR=1
- +61 XECUTE FTR
- +62 SET PGDATA("WFTR")=1
- +63 SET INFTR=0
- +64 ;handle form feed
- +65 IF $GET(IOF)'=""
- IF POSY<$Y
- Begin DoDot:2
- +66 IF $EXTRACT(IOST,1,2)="C-"
- IF $GET(PGDATA("IOF"))="1"
- WRITE @IOF
- +67 ;
- +68 IF $EXTRACT($GET(IOST),1,2)'="C-"
- IF $GET(PGDATA("IOF"))'="0"
- WRITE @IOF
- End DoDot:2
- End DoDot:1
- +69 ;
- +70 ; do "MORE" prompting
- +71 ;
- IF $EXTRACT($GET(IOST),1,2)="C-"
- Begin DoDot:1
- +72 if $GET(PGDATA("NOPROMPT"))
- QUIT
- +73 SET X=0
- +74 if $DATA(ZTQUEUED)
- QUIT
- +75 ;
- IF $GET(PGDATA("PROMPTX"))'=""
- Begin DoDot:2
- +76 KILL X
- +77 XECUTE PGDATA("PROMPTX")
- +78 SET X=$GET(X)
- +79 SET ABORT=$$MORE(X,ERASE)
- End DoDot:2
- +80 ;
- +81 IF $GET(PGDATA("PROMPTX"))=""
- SET ABORT=$$MORE($GET(PGDATA("PROMPT")),ERASE)
- +82 ;
- End DoDot:1
- if ABORT
- QUIT
- +83 ;
- +84 SET $Y=0
- +85 SET PGNUM=PGNUM+1
- +86 SET PGDATA("PGNUM")=PGNUM
- +87 ;
- IF HDR'=""
- IF 'INHDR
- Begin DoDot:1
- +88 SET INHDR=1
- +89 XECUTE HDR
- +90 SET INHDR=0
- End DoDot:1
- +91 QUIT
- +92 ;
- +93 ;
- MORE(PROMPT,ERASE) ;
- +1 ; Prompts user to hit ENTER to continue
- +2 ; Returns 1 if user enters "^" else returns 0
- +3 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
- +4 SET PROMPT=$GET(PROMPT)
- +5 SET ERASE=$GET(ERASE,1)
- +6 ;
- IF '$DATA(ZTQUEUED)
- Begin DoDot:1
- +7 IF $EXTRACT($GET(IOST),1,2)'="C-"
- QUIT
- +8 SET DIR(0)="E"
- +9 IF PROMPT'=""
- SET DIR("A")=PROMPT
- SET DIR(0)="EA"
- +10 DO ^DIR
- +11 IF ERASE
- WRITE $CHAR(13)_$JUSTIFY("",$GET(IOM,80))_$CHAR(13)
- End DoDot:1
- +12 IF $QUIT
- QUIT $DATA(DIRUT)
- +13 QUIT
- +14 ;
- +15 ;
- DATAOK(LRFILE,LRFLD,LRVAL) ;
- +1 ; Checks if a value is appropriate for storing in the field
- +2 ; Inputs
- +3 ; LRFILE : File #
- +4 ; LRFLD : Field #
- +5 ; LRVAL : Value of the field
- +6 ;
- +7 ; Returns 0 (invalid) or 1 (valid)
- +8 ;
- +9 NEW STATUS,LROUT,LRMSG,DIERR
- +10 SET STATUS=0
- +11 DO CHK^DIE(LRFILE,LRFLD,"",LRVAL,.LROUT,"LRMSG")
- +12 IF $GET(LROUT)'="^"
- SET STATUS=1
- +13 IF $DATA(LRMSG)
- SET STATUS=0
- +14 QUIT STATUS
- +15 ;
- +16 ;
- OWNSKEY(KEY,IEN) ;
- +1 ;File ^XUSEC/10076
- +2 ; Does user own specific key?
- +3 ; Inputs
- +4 ; KEY: The Key's NAME
- +5 ; IEN: User's IEN <dflt=DUZ>
- +6 ; Outputs
- +7 ; Returns 1 if user owns key, 0 otherwise.
- +8 ;
- +9 NEW LRLIST,LROWNS
- +10 SET LRLIST(1)=KEY
- SET IEN=$GET(IEN,$GET(DUZ))
- +11 DO OWNSKEY^XUSRB(.LROWNS,.LRLIST,IEN)
- +12 ;
- +13 QUIT +$GET(LROWNS(1))