XULMU ;IRMFO-ALB/CJM/SWO/RGG - KERNEL LOCK MANAGER ;11/16/2012
;;8.0;KERNEL;**608**;JUL 10, 1995;Build 84
;;Per VA Directive 6402, this routine should not be modified
;
; ******************************************************************
; * *
; * The Kernel Lock Manager is based on the VistA Lock Manager *
; * developed by Tommy Martin. *
; * *
; ******************************************************************
;
; Miscellaneous utilities
;
GETLOCKS(LOCKS) ;
N NODE,QUIT,RSET
;
S NODE=$$NODE
S @LOCKS@("XULM REPORTED NODE")=NODE
S QUIT=0
D LOCKQRY^%ZLMLIB(.RSET)
F D Q:QUIT
.N PID,LOCK
.I '$$NXTLOCK^%ZLMLIB(.RSET,.LOCK) S QUIT=1 Q
.S PID=LOCK(LOCK,"PID")
.D:PID
..S @LOCKS@(LOCK,NODE)=LOCK(LOCK)
..S @LOCKS@(LOCK,NODE,"SYSTEM")=$$IFSYSTEM(LOCK)
..S @LOCKS@(LOCK,NODE,"PID")=PID
..S @LOCKS@(LOCK,NODE,"TASK")=$G(^XUTL("XQ",PID,"ZTSKNUM"))
..S @LOCKS@(LOCK,NODE,"OWNER")=$$OWNER(PID,@LOCKS@(LOCK,NODE,"SYSTEM"))
Q
;
OWNER(PID,SYSTEM) ;Return the DUZ^<name> of owner of this process
N OWNER,OWNERDUZ
S (OWNER,OWNERDUZ)=""
I PID=$J S OWNERDUZ=$G(DUZ)
S:'OWNERDUZ OWNERDUZ=$G(^XUTL("XQ",PID,"DUZ"))
S:OWNERDUZ OWNER=$P($G(^VA(200,OWNERDUZ,0)),"^")
I OWNER="",'$G(SYSTEM) S OWNER=$$OSUSER^%ZLMLIB(PID)
I OWNER="" S OWNER="{?}"
I OWNER="{?}",$E(LOCK,1,4)["%ZT" S OWNER="TASKMAN"
Q OWNERDUZ_"^"_OWNER
;
;
PAT(DFN) ;
;Returns ID() array with patient information
K ID
I 'DFN S ID(0)=0,ID("IEN")="" Q
S ID("IEN")=DFN
D ADDPAT(DFN)
Q
ADDPAT(DFN) ;
;Adds patient information to the existing ID() array.
Q:'DFN
N NODE
S NODE=$G(^DPT(DFN,0))
Q:NODE=""
S ID(0)=+$G(ID(0))
S ID(ID(0)+1)="Patient Name:"_$P(NODE,"^"),ID(ID(0)+2)="Sex:"_$S($P(NODE,"^",2)="M":"MALE",1:"FEMALE"),ID(ID(0)+3)="DOB:"_$$FMTE^XLFDT($P(NODE,"^",3)),ID(ID(0)+4)="SSN:"_$P(NODE,"^",9),ID(0)=ID(0)+4
Q
;
PAUSE(MSG) ;
;Screen pause without scrolling. Returns 1 if the user quits out
;
I $L($G(MSG)) W !,MSG,!
N DIR,DIRUT,X,Y
S DIR(0)="E"
D ^DIR
Q:('(+Y))!$D(DIRUT) 1
Q 0
PAUSE2(MSG) ;
;First scroll to the bottome of the page, then does a screen pause. Returns 1 if user decides to quit, otherwise returns 0
;
I $L($G(MSG)) W !,MSG,!
N DIR,X,Y,QUIT
S QUIT=0
F Q:$Y>(IOSL-3) W !
S DIR(0)="E"
D ^DIR
I ('(+Y))!$D(DIRUT) S QUIT=1
Q QUIT
;
ASKYESNO(PROMPT,DEFAULT) ;
;Description: Displays PROMPT, appending '?'. Expects a YES NO response
;Input:
; PROMPT - text to display as prompt. Appends '?'
; DEFAULT - (optional) YES or NO. If not passed, defaults to YES
;Output:
; Function value: 1 if yes, 0 if no, "" if '^' entered or timeout
;
N DIR,Y
S DIR(0)="Y"
S DIR("A")=PROMPT
S DIR("B")=$S($G(DEFAULT)="NO":"NO",1:"YES")
D ^DIR
Q:$D(DIRUT) ""
Q Y
;
;
IFSYSTEM(LOCK) ;returns 1 if system lock, 0 otherwise
N SUB,LEN,FOUND,NOTFOUND
I $P(LOCK,"(")["%" Q 1
S (FOUND,NOTFOUND)=0
S LEN=$L(LOCK)
F I=1:1:LEN S SUB=$E(LOCK,1,I) D Q:FOUND Q:NOTFOUND
.I $D(^XLM(8993.1,"AC",SUB)) S FOUND=1 Q
.N NEXT
.S NEXT=$O(^XLM(8993.1,"AC",SUB))
.I NEXT="" S NOTFOUND=1 Q
.I NEXT]LOCK S NOTFOUND=1 Q
Q FOUND
;
NODE() ;Get Cache' instance name for this process
Q ##class(%SYS.System).GetInstanceName()
;
VOLUME() ;Returns the namespace of current environment
Q $SYSTEM.SYS.NameSpace()
;
SAMENODE(NODE) ;Is the current process running on the indicated node?
N SNODE
S SNODE=$$NODE()
I $G(NODE)=SNODE Q 1
Q 0
;
OS() ;Get OS
N X
S X=$$VERSION^%ZOSV(1)
Q $S(X["VMS":"VMS",X["UNIX":"LNX",X["Linux":"LNX",X["Windows":"WIN",1:"? OS")
;
;
HEX(DEC) ;Convert decimal number to hexidecimal
Q $$BASE^XLFUTL(DEC,10,16)
;
ADD(FILE,DA,DATA,ERROR,IEN) ;
;
;Description: Creates a new record and files the data.
; Input:
; FILE - File or sub-file number
; DA - Traditional FileMan DA array with same
; meaning. Pass by reference. Only needed if adding to a
; subfile.
; DATA - Data array to file, pass by reference
;Format: DATA(<field #>)=<value>
; IEN - internal entry number to use (optional)
;
; Output:
; Function Value - If no error then it returns the ien of the created
;record, else returns NULL.
; DA - returns the ien of the new record, NULL if none created. If needed, pass by reference.
; ERROR - optional error message - if needed, pass by reference
;
; Example: To add a record in subfile 2.0361 in the record with ien=353
;with the field .01 value = 21:
; S DATA(.01)=21,DA(1)=353 I $$ADD(2.0361,.DA,.DATA) W !,"DONE"
;
; Example: If creating a record not in a subfile, would look like this:
;S DATA(.01)=21 I $$ADD(867,,.DATA) W !,"DONE"
;
N FDA,FIELD,IENA,IENS,ERRORS,DIERR
;
;IENS - Internal Entry Number String defined by FM
;IENA - the Internal Entry Number Array defined by FM
;FDA - the FDA array defined by FM
;IEN - the ien of the new record
;
S DA="+1"
S IENS=$$IENS^DILF(.DA)
S FIELD=0
F S FIELD=$O(DATA(FIELD)) Q:'FIELD D
.S FDA(FILE,IENS,FIELD)=$G(DATA(FIELD))
I $G(IEN) S IENA(1)=IEN
D UPDATE^DIE("","FDA","IENA","ERRORS(1)")
I +$G(DIERR) D
.S ERROR=$G(ERRORS(1,"DIERR",1,"TEXT",1))
.S IEN=""
E D
.S IEN=IENA(1)
.S ERROR=""
D CLEAN^DILF
S DA=IEN
Q IEN
;
DELETE(FILE,DA,ERROR) ;
;Delete an existing record.
N DATA
S DATA(.01)="@"
Q $$UPD(FILE,.DA,.DATA,.ERROR)
Q
;
UPD(FILE,DA,DATA,ERROR) ;File data into an existing record.
; Input:
; FILE - File or sub-file number
; DA - Traditional DA array, with same meaning.
; Pass by reference.
; DATA - Data array to file (pass by reference)
;Format: DATA(<field #>)=<value>
;
; Output:
; Function Value - 0=error and 1=no error
; ERROR - optional error message - if needed, pass by reference
;
; Example: To update a record in subfile 2.0361 in record with ien=353,
;subrecord ien=68, with the field .01 value = 21:
; S DATA(.01)=21,DA=68,DA(1)=353 I $$UPD(2.0361,.DA,.DATA,.ERROR) W !,"DONE"
;
N FDA,FIELD,IENS,ERRORS
;
;IENS - Internal Entry Number String defined by FM
;FDA - the FDA array as defined by FM
;
I '$G(DA) S ERROR="IEN OF RECORD TO BE UPDATED NOT SPECIFIED" Q 0
S IENS=$$IENS^DILF(.DA)
S FIELD=0
F S FIELD=$O(DATA(FIELD)) Q:'FIELD D
.S FDA(FILE,IENS,FIELD)=$G(DATA(FIELD))
D FILE^DIE("","FDA","ERRORS(1)")
I +$G(DIERR) D
.S ERROR=$G(ERRORS(1,"DIERR",1,"TEXT",1))
E D
.S ERROR=""
;
D CLEAN^DILF
Q $S(+$G(DIERR):0,1:1)
;
SETCLEAN(RTN,VAR) ;
;Description: The purpose of this API is to register a cleanup routine
; that should be executed when the process is terminated by the
; Kernel Lock Manager. An entry is created on a stack kept for the
; process. The location is ^XTMP("XULM","XULM CLEANUP_"_$J,0) where $J
; uniquely identifies the process. A process may call SETCLEAN^XULMU
; repeatedly, and each time a new entry is placed on the stack.
;
;Input:
; RTN - The routine to be executed when the process is terminated.
; VAR - A list of variables that should be defined whent the routine
; is executed. It is up to the application to insure that
; all the required variables are defined.
; Function: An integer is returned that identifies the entry created
; on the stack. The application needs to retain this only
; if it may need to later remove the entry from the stack.
;
; Example:
; S VAR("DFN")=DFN
; S CLNENTRY=$$SETCLEAN^XULMU("MYCLEAN^MYRTN",.VAR)
;
N I,GBL
S GBL=$NA(^XTMP("XULM","XULM CLEANUP_"_$J,0))
;I '$D(@GBL@(0)) S @GBL@(0)=$$FMADD^XLFDT($$NOW^XLFDT\1,2)_"me^here"_$$NOW^XLFDT\1
I '$D(@GBL@(0)) D
.S @GBL@(0)=$$FMADD^XLFDT($$NOW^XLFDT\1,2)
.S @GBL@(0)=@GBL@(0)_"^"_($$NOW^XLFDT\1)
S I=+$O(@GBL@(9999999),-1)+1
S @GBL@(I,"ROUTINE")=RTN
M @GBL@(I,"VARIABLES")=VAR
Q I
;
CLEANUP(XULAST,DOLLARJ) ;
;Description: This API will execute the housecleaning stack set by the
;process identified by DOLLARJ. Entries are executed in the FIFO order,
;with the last entry added being the first to be executed, and XULAST
;being the last entry executed. If LAST is not passed in,
;then the entire stack is executed.
;
;Input:
; XULAST (optional) - This is the last entry that will be executed.
; If not passed in, then the entire housecleaning stack is executed.
; DOLLARJ - The $J value of the process that created the housecleaning
; stack. If DOLLARJ is not passed in, the value defaults to be $J.
;
N XUGBL,XUENTRY
I $G(DOLLARJ)="" S DOLLARJ=$J
S XUGBL=$NA(^XTMP("XULM","XULM CLEANUP_"_DOLLARJ,0))
S XULAST=+$G(XULAST)
S XUENTRY=9999
F S XUENTRY=$O(@XUGBL@(XUENTRY),-1) Q:XUENTRY<XULAST D
.N XURTN,XUVAR
.S XURTN=$G(@XUGBL@(XUENTRY,"ROUTINE"))
.S XUVAR=""
.F S XUVAR=$O(@XUGBL@(XUENTRY,"VARIABLES",XUVAR)) Q:XUVAR="" N @XUVAR S @XUVAR=@XUGBL@(XUENTRY,"VARIABLES",XUVAR)
.D:$L(XURTN) @XURTN
.K @XUGBL@(XUENTRY)
Q
UNCLEAN(LAST,DOLLARJ) ;
;Description - this removes entries form the housecleaning stack set by
;calling SETCLEAN^XULMU. Entries are removed in FIFO order. If LAST is
;not passed in, then the entire stack is deleted, otherwise just the
;entries back to LAST are removed.
;Input:
; LAST - Identifies the last entry on the housekeeping stack to remove.
; Entries are removed in FIFO order, so the first entry removed is
; the last entry that was added, and the last entry removed is
; LAST. If not passed in, the entire housecleainging stack is
; deleted.
; DOLLARJ (optional) The $J value of process that set the stack. If
; not passed in then its value is assumed to be $J.
;
N GBL,ENTRY
I $G(DOLLARJ)="" S DOLLARJ=$J
S GBL=$NA(^XTMP("XULM","XULM CLEANUP_"_DOLLARJ,0))
S LAST=+$G(LAST)
I 'LAST K @GBL Q
S ENTRY=9999
F S ENTRY=$O(@GBL@(ENTRY),-1) Q:ENTRY<LAST K @GBL@(ENTRY) I 'ENTRY K @GBL
Q
;
TEMPLATE(IEN) ;Returns the lock template, with the "^" prefix if it is on a global
N LOCK
S LOCK=$G(^XLM(8993,IEN,0))
I $P($G(^XLM(8993,IEN,1)),"^",2) S LOCK="^"_LOCK
Q LOCK
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXULMU 10361 printed Jan 18, 2025@03:11:12 Page 2
XULMU ;IRMFO-ALB/CJM/SWO/RGG - KERNEL LOCK MANAGER ;11/16/2012
+1 ;;8.0;KERNEL;**608**;JUL 10, 1995;Build 84
+2 ;;Per VA Directive 6402, this routine should not be modified
+3 ;
+4 ; ******************************************************************
+5 ; * *
+6 ; * The Kernel Lock Manager is based on the VistA Lock Manager *
+7 ; * developed by Tommy Martin. *
+8 ; * *
+9 ; ******************************************************************
+10 ;
+11 ; Miscellaneous utilities
+12 ;
GETLOCKS(LOCKS) ;
+1 NEW NODE,QUIT,RSET
+2 ;
+3 SET NODE=$$NODE
+4 SET @LOCKS@("XULM REPORTED NODE")=NODE
+5 SET QUIT=0
+6 DO LOCKQRY^%ZLMLIB(.RSET)
+7 FOR
Begin DoDot:1
+8 NEW PID,LOCK
+9 IF '$$NXTLOCK^%ZLMLIB(.RSET,.LOCK)
SET QUIT=1
QUIT
+10 SET PID=LOCK(LOCK,"PID")
+11 if PID
Begin DoDot:2
+12 SET @LOCKS@(LOCK,NODE)=LOCK(LOCK)
+13 SET @LOCKS@(LOCK,NODE,"SYSTEM")=$$IFSYSTEM(LOCK)
+14 SET @LOCKS@(LOCK,NODE,"PID")=PID
+15 SET @LOCKS@(LOCK,NODE,"TASK")=$GET(^XUTL("XQ",PID,"ZTSKNUM"))
+16 SET @LOCKS@(LOCK,NODE,"OWNER")=$$OWNER(PID,@LOCKS@(LOCK,NODE,"SYSTEM"))
End DoDot:2
End DoDot:1
if QUIT
QUIT
+17 QUIT
+18 ;
OWNER(PID,SYSTEM) ;Return the DUZ^<name> of owner of this process
+1 NEW OWNER,OWNERDUZ
+2 SET (OWNER,OWNERDUZ)=""
+3 IF PID=$JOB
SET OWNERDUZ=$GET(DUZ)
+4 if 'OWNERDUZ
SET OWNERDUZ=$GET(^XUTL("XQ",PID,"DUZ"))
+5 if OWNERDUZ
SET OWNER=$PIECE($GET(^VA(200,OWNERDUZ,0)),"^")
+6 IF OWNER=""
IF '$GET(SYSTEM)
SET OWNER=$$OSUSER^%ZLMLIB(PID)
+7 IF OWNER=""
SET OWNER="{?}"
+8 IF OWNER="{?}"
IF $EXTRACT(LOCK,1,4)["%ZT"
SET OWNER="TASKMAN"
+9 QUIT OWNERDUZ_"^"_OWNER
+10 ;
+11 ;
PAT(DFN) ;
+1 ;Returns ID() array with patient information
+2 KILL ID
+3 IF 'DFN
SET ID(0)=0
SET ID("IEN")=""
QUIT
+4 SET ID("IEN")=DFN
+5 DO ADDPAT(DFN)
+6 QUIT
ADDPAT(DFN) ;
+1 ;Adds patient information to the existing ID() array.
+2 if 'DFN
QUIT
+3 NEW NODE
+4 SET NODE=$GET(^DPT(DFN,0))
+5 if NODE=""
QUIT
+6 SET ID(0)=+$GET(ID(0))
+7 SET ID(ID(0)+1)="Patient Name:"_$PIECE(NODE,"^")
SET ID(ID(0)+2)="Sex:"_$SELECT($PIECE(NODE,"^",2)="M":"MALE",1:"FEMALE")
SET ID(ID(0)+3)="DOB:"_$$FMTE^XLFDT($PIECE(NODE,"^",3))
SET ID(ID(0)+4)="SSN:"_$PIECE(NODE,"^",9)
SET ID(0)=ID(0)+4
+8 QUIT
+9 ;
PAUSE(MSG) ;
+1 ;Screen pause without scrolling. Returns 1 if the user quits out
+2 ;
+3 IF $LENGTH($GET(MSG))
WRITE !,MSG,!
+4 NEW DIR,DIRUT,X,Y
+5 SET DIR(0)="E"
+6 DO ^DIR
+7 if ('(+Y))!$DATA(DIRUT)
QUIT 1
+8 QUIT 0
PAUSE2(MSG) ;
+1 ;First scroll to the bottome of the page, then does a screen pause. Returns 1 if user decides to quit, otherwise returns 0
+2 ;
+3 IF $LENGTH($GET(MSG))
WRITE !,MSG,!
+4 NEW DIR,X,Y,QUIT
+5 SET QUIT=0
+6 FOR
if $Y>(IOSL-3)
QUIT
WRITE !
+7 SET DIR(0)="E"
+8 DO ^DIR
+9 IF ('(+Y))!$DATA(DIRUT)
SET QUIT=1
+10 QUIT QUIT
+11 ;
ASKYESNO(PROMPT,DEFAULT) ;
+1 ;Description: Displays PROMPT, appending '?'. Expects a YES NO response
+2 ;Input:
+3 ; PROMPT - text to display as prompt. Appends '?'
+4 ; DEFAULT - (optional) YES or NO. If not passed, defaults to YES
+5 ;Output:
+6 ; Function value: 1 if yes, 0 if no, "" if '^' entered or timeout
+7 ;
+8 NEW DIR,Y
+9 SET DIR(0)="Y"
+10 SET DIR("A")=PROMPT
+11 SET DIR("B")=$SELECT($GET(DEFAULT)="NO":"NO",1:"YES")
+12 DO ^DIR
+13 if $DATA(DIRUT)
QUIT ""
+14 QUIT Y
+15 ;
+16 ;
IFSYSTEM(LOCK) ;returns 1 if system lock, 0 otherwise
+1 NEW SUB,LEN,FOUND,NOTFOUND
+2 IF $PIECE(LOCK,"(")["%"
QUIT 1
+3 SET (FOUND,NOTFOUND)=0
+4 SET LEN=$LENGTH(LOCK)
+5 FOR I=1:1:LEN
SET SUB=$EXTRACT(LOCK,1,I)
Begin DoDot:1
+6 IF $DATA(^XLM(8993.1,"AC",SUB))
SET FOUND=1
QUIT
+7 NEW NEXT
+8 SET NEXT=$ORDER(^XLM(8993.1,"AC",SUB))
+9 IF NEXT=""
SET NOTFOUND=1
QUIT
+10 IF NEXT]LOCK
SET NOTFOUND=1
QUIT
End DoDot:1
if FOUND
QUIT
if NOTFOUND
QUIT
+11 QUIT FOUND
+12 ;
NODE() ;Get Cache' instance name for this process
+1 QUIT ##class(%SYS.System).GetInstanceName()
+2 ;
VOLUME() ;Returns the namespace of current environment
+1 QUIT $SYSTEM.SYS.NameSpace()
+2 ;
SAMENODE(NODE) ;Is the current process running on the indicated node?
+1 NEW SNODE
+2 SET SNODE=$$NODE()
+3 IF $GET(NODE)=SNODE
QUIT 1
+4 QUIT 0
+5 ;
OS() ;Get OS
+1 NEW X
+2 SET X=$$VERSION^%ZOSV(1)
+3 QUIT $SELECT(X["VMS":"VMS",X["UNIX":"LNX",X["Linux":"LNX",X["Windows":"WIN",1:"? OS")
+4 ;
+5 ;
HEX(DEC) ;Convert decimal number to hexidecimal
+1 QUIT $$BASE^XLFUTL(DEC,10,16)
+2 ;
ADD(FILE,DA,DATA,ERROR,IEN) ;
+1 ;
+2 ;Description: Creates a new record and files the data.
+3 ; Input:
+4 ; FILE - File or sub-file number
+5 ; DA - Traditional FileMan DA array with same
+6 ; meaning. Pass by reference. Only needed if adding to a
+7 ; subfile.
+8 ; DATA - Data array to file, pass by reference
+9 ;Format: DATA(<field #>)=<value>
+10 ; IEN - internal entry number to use (optional)
+11 ;
+12 ; Output:
+13 ; Function Value - If no error then it returns the ien of the created
+14 ;record, else returns NULL.
+15 ; DA - returns the ien of the new record, NULL if none created. If needed, pass by reference.
+16 ; ERROR - optional error message - if needed, pass by reference
+17 ;
+18 ; Example: To add a record in subfile 2.0361 in the record with ien=353
+19 ;with the field .01 value = 21:
+20 ; S DATA(.01)=21,DA(1)=353 I $$ADD(2.0361,.DA,.DATA) W !,"DONE"
+21 ;
+22 ; Example: If creating a record not in a subfile, would look like this:
+23 ;S DATA(.01)=21 I $$ADD(867,,.DATA) W !,"DONE"
+24 ;
+25 NEW FDA,FIELD,IENA,IENS,ERRORS,DIERR
+26 ;
+27 ;IENS - Internal Entry Number String defined by FM
+28 ;IENA - the Internal Entry Number Array defined by FM
+29 ;FDA - the FDA array defined by FM
+30 ;IEN - the ien of the new record
+31 ;
+32 SET DA="+1"
+33 SET IENS=$$IENS^DILF(.DA)
+34 SET FIELD=0
+35 FOR
SET FIELD=$ORDER(DATA(FIELD))
if 'FIELD
QUIT
Begin DoDot:1
+36 SET FDA(FILE,IENS,FIELD)=$GET(DATA(FIELD))
End DoDot:1
+37 IF $GET(IEN)
SET IENA(1)=IEN
+38 DO UPDATE^DIE("","FDA","IENA","ERRORS(1)")
+39 IF +$GET(DIERR)
Begin DoDot:1
+40 SET ERROR=$GET(ERRORS(1,"DIERR",1,"TEXT",1))
+41 SET IEN=""
End DoDot:1
+42 IF '$TEST
Begin DoDot:1
+43 SET IEN=IENA(1)
+44 SET ERROR=""
End DoDot:1
+45 DO CLEAN^DILF
+46 SET DA=IEN
+47 QUIT IEN
+48 ;
DELETE(FILE,DA,ERROR) ;
+1 ;Delete an existing record.
+2 NEW DATA
+3 SET DATA(.01)="@"
+4 QUIT $$UPD(FILE,.DA,.DATA,.ERROR)
+5 QUIT
+6 ;
UPD(FILE,DA,DATA,ERROR) ;File data into an existing record.
+1 ; Input:
+2 ; FILE - File or sub-file number
+3 ; DA - Traditional DA array, with same meaning.
+4 ; Pass by reference.
+5 ; DATA - Data array to file (pass by reference)
+6 ;Format: DATA(<field #>)=<value>
+7 ;
+8 ; Output:
+9 ; Function Value - 0=error and 1=no error
+10 ; ERROR - optional error message - if needed, pass by reference
+11 ;
+12 ; Example: To update a record in subfile 2.0361 in record with ien=353,
+13 ;subrecord ien=68, with the field .01 value = 21:
+14 ; S DATA(.01)=21,DA=68,DA(1)=353 I $$UPD(2.0361,.DA,.DATA,.ERROR) W !,"DONE"
+15 ;
+16 NEW FDA,FIELD,IENS,ERRORS
+17 ;
+18 ;IENS - Internal Entry Number String defined by FM
+19 ;FDA - the FDA array as defined by FM
+20 ;
+21 IF '$GET(DA)
SET ERROR="IEN OF RECORD TO BE UPDATED NOT SPECIFIED"
QUIT 0
+22 SET IENS=$$IENS^DILF(.DA)
+23 SET FIELD=0
+24 FOR
SET FIELD=$ORDER(DATA(FIELD))
if 'FIELD
QUIT
Begin DoDot:1
+25 SET FDA(FILE,IENS,FIELD)=$GET(DATA(FIELD))
End DoDot:1
+26 DO FILE^DIE("","FDA","ERRORS(1)")
+27 IF +$GET(DIERR)
Begin DoDot:1
+28 SET ERROR=$GET(ERRORS(1,"DIERR",1,"TEXT",1))
End DoDot:1
+29 IF '$TEST
Begin DoDot:1
+30 SET ERROR=""
End DoDot:1
+31 ;
+32 DO CLEAN^DILF
+33 QUIT $SELECT(+$GET(DIERR):0,1:1)
+34 ;
SETCLEAN(RTN,VAR) ;
+1 ;Description: The purpose of this API is to register a cleanup routine
+2 ; that should be executed when the process is terminated by the
+3 ; Kernel Lock Manager. An entry is created on a stack kept for the
+4 ; process. The location is ^XTMP("XULM","XULM CLEANUP_"_$J,0) where $J
+5 ; uniquely identifies the process. A process may call SETCLEAN^XULMU
+6 ; repeatedly, and each time a new entry is placed on the stack.
+7 ;
+8 ;Input:
+9 ; RTN - The routine to be executed when the process is terminated.
+10 ; VAR - A list of variables that should be defined whent the routine
+11 ; is executed. It is up to the application to insure that
+12 ; all the required variables are defined.
+13 ; Function: An integer is returned that identifies the entry created
+14 ; on the stack. The application needs to retain this only
+15 ; if it may need to later remove the entry from the stack.
+16 ;
+17 ; Example:
+18 ; S VAR("DFN")=DFN
+19 ; S CLNENTRY=$$SETCLEAN^XULMU("MYCLEAN^MYRTN",.VAR)
+20 ;
+21 NEW I,GBL
+22 SET GBL=$NAME(^XTMP("XULM","XULM CLEANUP_"_$JOB,0))
+23 ;I '$D(@GBL@(0)) S @GBL@(0)=$$FMADD^XLFDT($$NOW^XLFDT\1,2)_"me^here"_$$NOW^XLFDT\1
+24 IF '$DATA(@GBL@(0))
Begin DoDot:1
+25 SET @GBL@(0)=$$FMADD^XLFDT($$NOW^XLFDT\1,2)
+26 SET @GBL@(0)=@GBL@(0)_"^"_($$NOW^XLFDT\1)
End DoDot:1
+27 SET I=+$ORDER(@GBL@(9999999),-1)+1
+28 SET @GBL@(I,"ROUTINE")=RTN
+29 MERGE @GBL@(I,"VARIABLES")=VAR
+30 QUIT I
+31 ;
CLEANUP(XULAST,DOLLARJ) ;
+1 ;Description: This API will execute the housecleaning stack set by the
+2 ;process identified by DOLLARJ. Entries are executed in the FIFO order,
+3 ;with the last entry added being the first to be executed, and XULAST
+4 ;being the last entry executed. If LAST is not passed in,
+5 ;then the entire stack is executed.
+6 ;
+7 ;Input:
+8 ; XULAST (optional) - This is the last entry that will be executed.
+9 ; If not passed in, then the entire housecleaning stack is executed.
+10 ; DOLLARJ - The $J value of the process that created the housecleaning
+11 ; stack. If DOLLARJ is not passed in, the value defaults to be $J.
+12 ;
+13 NEW XUGBL,XUENTRY
+14 IF $GET(DOLLARJ)=""
SET DOLLARJ=$JOB
+15 SET XUGBL=$NAME(^XTMP("XULM","XULM CLEANUP_"_DOLLARJ,0))
+16 SET XULAST=+$GET(XULAST)
+17 SET XUENTRY=9999
+18 FOR
SET XUENTRY=$ORDER(@XUGBL@(XUENTRY),-1)
if XUENTRY<XULAST
QUIT
Begin DoDot:1
+19 NEW XURTN,XUVAR
+20 SET XURTN=$GET(@XUGBL@(XUENTRY,"ROUTINE"))
+21 SET XUVAR=""
+22 FOR
SET XUVAR=$ORDER(@XUGBL@(XUENTRY,"VARIABLES",XUVAR))
if XUVAR=""
QUIT
NEW @XUVAR
SET @XUVAR=@XUGBL@(XUENTRY,"VARIABLES",XUVAR)
+23 if $LENGTH(XURTN)
DO @XURTN
+24 KILL @XUGBL@(XUENTRY)
End DoDot:1
+25 QUIT
UNCLEAN(LAST,DOLLARJ) ;
+1 ;Description - this removes entries form the housecleaning stack set by
+2 ;calling SETCLEAN^XULMU. Entries are removed in FIFO order. If LAST is
+3 ;not passed in, then the entire stack is deleted, otherwise just the
+4 ;entries back to LAST are removed.
+5 ;Input:
+6 ; LAST - Identifies the last entry on the housekeeping stack to remove.
+7 ; Entries are removed in FIFO order, so the first entry removed is
+8 ; the last entry that was added, and the last entry removed is
+9 ; LAST. If not passed in, the entire housecleainging stack is
+10 ; deleted.
+11 ; DOLLARJ (optional) The $J value of process that set the stack. If
+12 ; not passed in then its value is assumed to be $J.
+13 ;
+14 NEW GBL,ENTRY
+15 IF $GET(DOLLARJ)=""
SET DOLLARJ=$JOB
+16 SET GBL=$NAME(^XTMP("XULM","XULM CLEANUP_"_DOLLARJ,0))
+17 SET LAST=+$GET(LAST)
+18 IF 'LAST
KILL @GBL
QUIT
+19 SET ENTRY=9999
+20 FOR
SET ENTRY=$ORDER(@GBL@(ENTRY),-1)
if ENTRY<LAST
QUIT
KILL @GBL@(ENTRY)
IF 'ENTRY
KILL @GBL
+21 QUIT
+22 ;
TEMPLATE(IEN) ;Returns the lock template, with the "^" prefix if it is on a global
+1 NEW LOCK
+2 SET LOCK=$GET(^XLM(8993,IEN,0))
+3 IF $PIECE($GET(^XLM(8993,IEN,1)),"^",2)
SET LOCK="^"_LOCK
+4 QUIT LOCK
+5 ;
+6 ;
