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 Oct 16, 2024@18:22:58 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))
