- 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 ;