PXRMGEDT ; SLC/PJH - PXRM General Edit/Add. ;01/28/2013
;;2.0;CLINICAL REMINDERS;**26**;Feb 04, 2005;Build 404
;
;
;Called from protocol PXRM SELECTION ADD
;
ADD(TYP) ;
N DIC,DIDEL,DLAYGO,DTOUT,DUOUT,FILE,HED,PXRMHD,X,Y
W IORESET
;
;Ignore finding type parameters
I "FPAR"=TYP D DUMMY^PXRMRUTL H 1 Q
;
;Edit dialog
I "DLGE"=TYP D ADD^PXRMDEDT Q
;
;Allow auto generate of reminder dialogs
I TYP["DLG" D ^PXRMDBLD Q
;
;Finding Item Parameter
I TYP="FIP" S FILE="801.43",HED="FINDING ITEM PARAMETER"
;
;Reminder Category
I TYP="RCAT" S FILE="811.7",HED="REMINDER CATEGORY"
;
;Resolution Status
I TYP="RESN" S FILE="801.9",HED="RESOLUTION STATUS"
;
;Health Factor Resolution
I TYP="SHFR" S FILE="801.95",HED="HEALTH FACTOR"
;
F D Q:(X="")!$D(DUOUT)!$D(DTOUT)
.S DIC=FILE,DLAYGO=DIC,DIDEL=DIC,DIC(0)="QAELX"
.S DIC("A")="Select new "_HED_" name: "
.I TYP="SHFR" S DIC(0)="QAEL"
.D ^DIC Q:X=""
.I X=(U_U) S DTOUT=1
.I Y=-1 S DUOUT=1 W !,"Details not saved",! Q
.Q:$D(DTOUT)!$D(DUOUT)
.;Check if exists
.I ($P(Y,U,3)'=1) W !,"already exists" Q
.S DA=$P(Y,U)
.;Edit resolution status
.I TYP="RESN" D EDIT^PXRMSEDT("^PXRMD(801.9,",DA)
.;Edit others
.I TYP'="RESN" D EDIT(TYP,DA,1)
.S DUOUT=1
Q
;
DIE(HDR,FILE) ;Lock and edit
I FILE=801.45 W "ED - EDIT "_HDR,!!,PXRMHD,!
;Display resolution details if finding type parameter edit
I FILE=801.45,$G(PXRMINST)'=1 D
.N RSUB,RNAM
.S RSUB=$P($G(^PXRMD(801.45,PXRMFIEN,1,PXRMFSUB,0)),U) Q:'RSUB
.S RNAM=$P($G(^PXRMD(801.9,RSUB,0)),U)
.S:RNAM="" RNAM=RSUB W "RESOLUTION STATUS : ",RNAM
D:$$LOCK(FILE) ^DIE,UNLOCK(FILE)
Q
;
;Called by protocol PXRM GENERAL EDIT
;------------------------------------
EDIT(TYP,DA,ADD) ;
N DIC,DIDEL,DIE,DR,DTOUT,DUOUT,Y
W IORESET
S VALMBCK="R"
;
;Taxonomy Dialog
I TYP="DTAX" D
.I $$TLOCK(811.2,DA) D D TUNLOCK(811.2,DA)
..;Initialize the selectable codes if none exist
..I ('$D(^PXD(811.2,DA,"SDX")))&('$D(^PXD(811.2,DA,"SPR"))) D
...D BUILD^PXRMTDUP(DA)
..;
..N DIE,DR
..S DIE="^PXD(811.2,"
..;
..W !,"Dialog Text Fields"
..S DR=".03;3107;3108;3111;3112"
..D ^DIE
..I $D(Y) Q
..;
..W !!,"Dialog Selectable codes"
..S DR="3102;3104"
..D ^DIE
..I $D(Y) Q
..;
..W !!,"Dialog Generation Parameters"
..S DR="3106;3110"
..D ^DIE
;
;Finding Item Parameter
I TYP="FIP" D
.S DIE="^PXRMD(801.43,",DR=".01;.02;.03;.04",DIDEL=801.43
.D DIE("FINDING ITEM PARAMETER",801.43)
;
;Finding Type Parameter
I TYP="FPAR" D
.;Programmer mode
.S:$G(PXRMINST)=1 DR=1,DR(2,801.451)="1;3;4;5",DIE="^PXRMD(801.45,"
.;Site mode
.I $G(PXRMINST)'=1 D
..S DR="1;3;4;5",DIE="^PXRMD(801.45,PXRMFIEN,1,",DA(1)=PXRMFIEN
..S DR(2,801.4515)="2;4;5;6;1"
.D DIE("FINDING TYPE PARAMETER",801.45)
;
;Reminder Category
I TYP="RCAT" D
.S DIE="^PXRMD(811.7,",DR=".01;1;2;10",DIDEL=811.7
.D DIE("CATEGORY",811.7)
;
;Resolution Status
I TYP="RESN" D
.I $$LOCK(801.9) D EDIT^PXRMSEDT("^PXRMD(801.9,",.DA),UNLOCK(811.9)
;
;Health Factor Resolution
I TYP="SHFR" D
.S DIE="^PXRMD(801.95,",DR=".01;.02",DIDEL=801.95
.D DIE("HEALTH FACTOR RESOLUTIONS",811.7)
;
;Skip rebuild if editting taxonomy called from dialog edit
I PXRMGTYP["DLG" Q
;
;Deleted ???
I '$D(DA) S VALMBCK="Q" Q
;Redisplay changes
I 'ADD D BUILD^PXRMGEN
Q
;
;
LOCK(FILE) ;Lock the entire file
L +^PXRMD(FILE):DILOCKTM I Q 1
E W !!,?5,"Another user is editing this file, try later" H 2
Q 0
;
;
UNLOCK(FILE) ;Unlock the file
L -^PXRMD(FILE)
Q
;Build the list of codes for one taxonomy
;----------------------------------------
SEL(TAXIND) ;
N CODELIST,IC,FINDING,FILE,HIGH,LOW,NCE,TEMP
;
;Setup file names for indirection, these will hold the taxonomy lists.
N ICD9IEN,ICPTIEN
S ICD9IEN="^TMP(""PXRM"",$J,""ICD9IEN"")"
S ICPTIEN="^TMP(""PXRM"",$J,""ICPTIEN"")"
;
S NCE=0
F FILE=80,81 D
.S IC=0
.F S IC=$O(^PXD(811.2,TAXIND,FILE,IC)) Q:+IC=0 D
..S TEMP=$G(^PXD(811.2,TAXIND,FILE,IC,0))
..;Append the taxonomy and finding information to CODELIST.
..S NCE=NCE+1
..S CODELIST(NCE)=TEMP_U_FILE
;CODELIST is LOW_U_HIGH_U_FILE
;Go through the standard coded list and get the file IEN for each entry.
F IC=1:1:NCE D
.S LOW=$P(CODELIST(IC),U,1)
.S HIGH=$P(CODELIST(IC),U,2)
.S FILE=$P(CODELIST(IC),U,3)
.I FILE=80 D ICD9(LOW,HIGH) Q
.I FILE=81 D ICPT(LOW,HIGH) Q
;
;Store the results.
D STORE(TAXIND)
K ^TMP("PXRM",$J,"ICD9IEN")
K ^TMP("PXRM",$J,"ICPTIEN")
Q
;
;=======================================================================
DEL(TAXIND) ;Delete existing entry
K ^PXD(811.2,TAXIND,"SDX")
K ^PXD(811.2,TAXIND,"SPR")
Q
;
;Build the list of internal entries for ICD9 (File 80)
;-----------------------------------------------------
ICD9(LOW,HIGH) ;
N END,IEN,IND
S IND=LOW_" "
S END=HIGH_" "
F Q:(IND]END)!(+IND>+END)!(IND="") D
.S IEN=$O(^ICD9("BA",IND,""))
.I (+IEN>0),$$CODE^PXRMVAL($TR(IND," "),80) D
..S ^TMP("PXRM",$J,"ICD9IEN",IND)=IEN
.S IND=$O(^ICD9("BA",IND))
Q
;
;Build the list of internal entries for ICPT (File 81)
;-----------------------------------------------------
ICPT(LOW,HIGH) ;
N IEN,IND
S IND=LOW
F Q:(IND]HIGH)!(+IND>+HIGH)!(IND="") D
.S IEN=$O(^ICPT("B",IND,""))
.I (+IEN>0),$$CODE^PXRMVAL($TR(IND," "),81) D
..S ^TMP("PXRM",$J,"ICPTIEN",IND)=IEN
.S IND=$O(^ICPT("B",IND))
Q
;
;Store selectable codes in taxonomy
;----------------------------------
STORE(TAXIND) ;
K ^TMP("PXRMGEDT",$J)
N FDA,FDAIEN,FITEM,I2N,IEN,IND,MSG,NAME,SEQ,SUB,TEMP
;
S NAME=$P(^PXD(811.2,TAXIND,0),U)
;
S FDAIEN(1)=TAXIND
;
S SUB="",IND=1,SEQ=0
F S SUB=$O(^TMP("PXRM",$J,"ICD9IEN",SUB)) Q:SUB="" D
.S IEN=^TMP("PXRM",$J,"ICD9IEN",SUB)
.S IND=IND+1,SEQ=SEQ+1
.S I2N="+"_IND_","_FDAIEN(1)_","
.S ^TMP("PXRMGEDT",$J,811.23102,I2N,.01)=IEN
;
S SEQ=0
F S SUB=$O(^TMP("PXRM",$J,"ICPTIEN",SUB)) Q:SUB="" D
.S IEN=^TMP("PXRM",$J,"ICPTIEN",SUB)
.S IND=IND+1,SEQ=SEQ+1
.S I2N="+"_IND_","_FDAIEN(1)_","
.S ^TMP("PXRMGEDT",$J,811.23104,I2N,.01)=IEN
;
;None found
I IND=1 Q
;
S TEMP="^TMP(""PXRMGEDT"","_$J_")"
D UPDATE^DIE("",TEMP,"FDAIEN","MSG")
I $D(MSG) D ERR
K ^TMP("PXRMGEDT",$J)
Q
;
;Error Handler
;-------------
ERR N ERROR,IC,REF
S ERROR(1)="Unable to build selectable codes for taxonomy : "
S ERROR(2)=NAME
S ERROR(3)="Error in UPDATE^DIE, needs further investigation"
;Move MSG into ERROR
S REF="MSG"
F IC=4:1 S REF=$Q(@REF) Q:REF="" S ERROR(IC)=REF_"="_@REF
;Screen message
D BMES^XPDUTL(.ERROR)
Q
;
TLOCK(FILE,DA) ;Lock the record
L +^PXD(FILE,DA):DILOCKTM I Q 1
E W !!,?5,"Another user is editing this file, try later" H 2 Q 0
;
;
TUNLOCK(FILE,DA) ;Unlock the record
L -^PXD(FILE,DA)
Q
PXRMGEDT ; SLC/PJH - PXRM General Edit/Add. ;01/28/2013
+1 ;;2.0;CLINICAL REMINDERS;**26**;Feb 04, 2005;Build 404
+2 ;
+3 ;
+4 ;Called from protocol PXRM SELECTION ADD
+5 ;
ADD(TYP) ;
+1 NEW DIC,DIDEL,DLAYGO,DTOUT,DUOUT,FILE,HED,PXRMHD,X,Y
+2 WRITE IORESET
+3 ;
+4 ;Ignore finding type parameters
+5 IF "FPAR"=TYP
DO DUMMY^PXRMRUTL
HANG 1
QUIT
+6 ;
+7 ;Edit dialog
+8 IF "DLGE"=TYP
DO ADD^PXRMDEDT
QUIT
+9 ;
+10 ;Allow auto generate of reminder dialogs
+11 IF TYP["DLG"
DO ^PXRMDBLD
QUIT
+12 ;
+13 ;Finding Item Parameter
+14 IF TYP="FIP"
SET FILE="801.43"
SET HED="FINDING ITEM PARAMETER"
+15 ;
+16 ;Reminder Category
+17 IF TYP="RCAT"
SET FILE="811.7"
SET HED="REMINDER CATEGORY"
+18 ;
+19 ;Resolution Status
+20 IF TYP="RESN"
SET FILE="801.9"
SET HED="RESOLUTION STATUS"
+21 ;
+22 ;Health Factor Resolution
+23 IF TYP="SHFR"
SET FILE="801.95"
SET HED="HEALTH FACTOR"
+24 ;
+25 FOR
Begin DoDot:1
+26 SET DIC=FILE
SET DLAYGO=DIC
SET DIDEL=DIC
SET DIC(0)="QAELX"
+27 SET DIC("A")="Select new "_HED_" name: "
+28 IF TYP="SHFR"
SET DIC(0)="QAEL"
+29 DO ^DIC
IF X=""
QUIT
+30 IF X=(U_U)
SET DTOUT=1
+31 IF Y=-1
SET DUOUT=1
WRITE !,"Details not saved",!
QUIT
+32 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+33 ;Check if exists
+34 IF ($PIECE(Y,U,3)'=1)
WRITE !,"already exists"
QUIT
+35 SET DA=$PIECE(Y,U)
+36 ;Edit resolution status
+37 IF TYP="RESN"
DO EDIT^PXRMSEDT("^PXRMD(801.9,",DA)
+38 ;Edit others
+39 IF TYP'="RESN"
DO EDIT(TYP,DA,1)
+40 SET DUOUT=1
End DoDot:1
IF (X="")!$DATA(DUOUT)!$DATA(DTOUT)
QUIT
+41 QUIT
+42 ;
DIE(HDR,FILE) ;Lock and edit
+1 IF FILE=801.45
WRITE "ED - EDIT "_HDR,!!,PXRMHD,!
+2 ;Display resolution details if finding type parameter edit
+3 IF FILE=801.45
IF $GET(PXRMINST)'=1
Begin DoDot:1
+4 NEW RSUB,RNAM
+5 SET RSUB=$PIECE($GET(^PXRMD(801.45,PXRMFIEN,1,PXRMFSUB,0)),U)
IF 'RSUB
QUIT
+6 SET RNAM=$PIECE($GET(^PXRMD(801.9,RSUB,0)),U)
+7 IF RNAM=""
SET RNAM=RSUB
WRITE "RESOLUTION STATUS : ",RNAM
End DoDot:1
+8 IF $$LOCK(FILE)
DO ^DIE
DO UNLOCK(FILE)
+9 QUIT
+10 ;
+11 ;Called by protocol PXRM GENERAL EDIT
+12 ;------------------------------------
EDIT(TYP,DA,ADD) ;
+1 NEW DIC,DIDEL,DIE,DR,DTOUT,DUOUT,Y
+2 WRITE IORESET
+3 SET VALMBCK="R"
+4 ;
+5 ;Taxonomy Dialog
+6 IF TYP="DTAX"
Begin DoDot:1
+7 IF $$TLOCK(811.2,DA)
Begin DoDot:2
+8 ;Initialize the selectable codes if none exist
+9 IF ('$DATA(^PXD(811.2,DA,"SDX")))&('$DATA(^PXD(811.2,DA,"SPR")))
Begin DoDot:3
+10 DO BUILD^PXRMTDUP(DA)
End DoDot:3
+11 ;
+12 NEW DIE,DR
+13 SET DIE="^PXD(811.2,"
+14 ;
+15 WRITE !,"Dialog Text Fields"
+16 SET DR=".03;3107;3108;3111;3112"
+17 DO ^DIE
+18 IF $DATA(Y)
QUIT
+19 ;
+20 WRITE !!,"Dialog Selectable codes"
+21 SET DR="3102;3104"
+22 DO ^DIE
+23 IF $DATA(Y)
QUIT
+24 ;
+25 WRITE !!,"Dialog Generation Parameters"
+26 SET DR="3106;3110"
+27 DO ^DIE
End DoDot:2
DO TUNLOCK(811.2,DA)
End DoDot:1
+28 ;
+29 ;Finding Item Parameter
+30 IF TYP="FIP"
Begin DoDot:1
+31 SET DIE="^PXRMD(801.43,"
SET DR=".01;.02;.03;.04"
SET DIDEL=801.43
+32 DO DIE("FINDING ITEM PARAMETER",801.43)
End DoDot:1
+33 ;
+34 ;Finding Type Parameter
+35 IF TYP="FPAR"
Begin DoDot:1
+36 ;Programmer mode
+37 IF $GET(PXRMINST)=1
SET DR=1
SET DR(2,801.451)="1;3;4;5"
SET DIE="^PXRMD(801.45,"
+38 ;Site mode
+39 IF $GET(PXRMINST)'=1
Begin DoDot:2
+40 SET DR="1;3;4;5"
SET DIE="^PXRMD(801.45,PXRMFIEN,1,"
SET DA(1)=PXRMFIEN
+41 SET DR(2,801.4515)="2;4;5;6;1"
End DoDot:2
+42 DO DIE("FINDING TYPE PARAMETER",801.45)
End DoDot:1
+43 ;
+44 ;Reminder Category
+45 IF TYP="RCAT"
Begin DoDot:1
+46 SET DIE="^PXRMD(811.7,"
SET DR=".01;1;2;10"
SET DIDEL=811.7
+47 DO DIE("CATEGORY",811.7)
End DoDot:1
+48 ;
+49 ;Resolution Status
+50 IF TYP="RESN"
Begin DoDot:1
+51 IF $$LOCK(801.9)
DO EDIT^PXRMSEDT("^PXRMD(801.9,",.DA)
DO UNLOCK(811.9)
End DoDot:1
+52 ;
+53 ;Health Factor Resolution
+54 IF TYP="SHFR"
Begin DoDot:1
+55 SET DIE="^PXRMD(801.95,"
SET DR=".01;.02"
SET DIDEL=801.95
+56 DO DIE("HEALTH FACTOR RESOLUTIONS",811.7)
End DoDot:1
+57 ;
+58 ;Skip rebuild if editting taxonomy called from dialog edit
+59 IF PXRMGTYP["DLG"
QUIT
+60 ;
+61 ;Deleted ???
+62 IF '$DATA(DA)
SET VALMBCK="Q"
QUIT
+63 ;Redisplay changes
+64 IF 'ADD
DO BUILD^PXRMGEN
+65 QUIT
+66 ;
+67 ;
LOCK(FILE) ;Lock the entire file
+1 LOCK +^PXRMD(FILE):DILOCKTM
IF $TEST
QUIT 1
+2 IF '$TEST
WRITE !!,?5,"Another user is editing this file, try later"
HANG 2
+3 QUIT 0
+4 ;
+5 ;
UNLOCK(FILE) ;Unlock the file
+1 LOCK -^PXRMD(FILE)
+2 QUIT
+3 ;Build the list of codes for one taxonomy
+4 ;----------------------------------------
SEL(TAXIND) ;
+1 NEW CODELIST,IC,FINDING,FILE,HIGH,LOW,NCE,TEMP
+2 ;
+3 ;Setup file names for indirection, these will hold the taxonomy lists.
+4 NEW ICD9IEN,ICPTIEN
+5 SET ICD9IEN="^TMP(""PXRM"",$J,""ICD9IEN"")"
+6 SET ICPTIEN="^TMP(""PXRM"",$J,""ICPTIEN"")"
+7 ;
+8 SET NCE=0
+9 FOR FILE=80,81
Begin DoDot:1
+10 SET IC=0
+11 FOR
SET IC=$ORDER(^PXD(811.2,TAXIND,FILE,IC))
IF +IC=0
QUIT
Begin DoDot:2
+12 SET TEMP=$GET(^PXD(811.2,TAXIND,FILE,IC,0))
+13 ;Append the taxonomy and finding information to CODELIST.
+14 SET NCE=NCE+1
+15 SET CODELIST(NCE)=TEMP_U_FILE
End DoDot:2
End DoDot:1
+16 ;CODELIST is LOW_U_HIGH_U_FILE
+17 ;Go through the standard coded list and get the file IEN for each entry.
+18 FOR IC=1:1:NCE
Begin DoDot:1
+19 SET LOW=$PIECE(CODELIST(IC),U,1)
+20 SET HIGH=$PIECE(CODELIST(IC),U,2)
+21 SET FILE=$PIECE(CODELIST(IC),U,3)
+22 IF FILE=80
DO ICD9(LOW,HIGH)
QUIT
+23 IF FILE=81
DO ICPT(LOW,HIGH)
QUIT
End DoDot:1
+24 ;
+25 ;Store the results.
+26 DO STORE(TAXIND)
+27 KILL ^TMP("PXRM",$JOB,"ICD9IEN")
+28 KILL ^TMP("PXRM",$JOB,"ICPTIEN")
+29 QUIT
+30 ;
+31 ;=======================================================================
DEL(TAXIND) ;Delete existing entry
+1 KILL ^PXD(811.2,TAXIND,"SDX")
+2 KILL ^PXD(811.2,TAXIND,"SPR")
+3 QUIT
+4 ;
+5 ;Build the list of internal entries for ICD9 (File 80)
+6 ;-----------------------------------------------------
ICD9(LOW,HIGH) ;
+1 NEW END,IEN,IND
+2 SET IND=LOW_" "
+3 SET END=HIGH_" "
+4 FOR
IF (IND]END)!(+IND>+END)!(IND="")
QUIT
Begin DoDot:1
+5 SET IEN=$ORDER(^ICD9("BA",IND,""))
+6 IF (+IEN>0)
IF $$CODE^PXRMVAL($TRANSLATE(IND," "),80)
Begin DoDot:2
+7 SET ^TMP("PXRM",$JOB,"ICD9IEN",IND)=IEN
End DoDot:2
+8 SET IND=$ORDER(^ICD9("BA",IND))
End DoDot:1
+9 QUIT
+10 ;
+11 ;Build the list of internal entries for ICPT (File 81)
+12 ;-----------------------------------------------------
ICPT(LOW,HIGH) ;
+1 NEW IEN,IND
+2 SET IND=LOW
+3 FOR
IF (IND]HIGH)!(+IND>+HIGH)!(IND="")
QUIT
Begin DoDot:1
+4 SET IEN=$ORDER(^ICPT("B",IND,""))
+5 IF (+IEN>0)
IF $$CODE^PXRMVAL($TRANSLATE(IND," "),81)
Begin DoDot:2
+6 SET ^TMP("PXRM",$JOB,"ICPTIEN",IND)=IEN
End DoDot:2
+7 SET IND=$ORDER(^ICPT("B",IND))
End DoDot:1
+8 QUIT
+9 ;
+10 ;Store selectable codes in taxonomy
+11 ;----------------------------------
STORE(TAXIND) ;
+1 KILL ^TMP("PXRMGEDT",$JOB)
+2 NEW FDA,FDAIEN,FITEM,I2N,IEN,IND,MSG,NAME,SEQ,SUB,TEMP
+3 ;
+4 SET NAME=$PIECE(^PXD(811.2,TAXIND,0),U)
+5 ;
+6 SET FDAIEN(1)=TAXIND
+7 ;
+8 SET SUB=""
SET IND=1
SET SEQ=0
+9 FOR
SET SUB=$ORDER(^TMP("PXRM",$JOB,"ICD9IEN",SUB))
IF SUB=""
QUIT
Begin DoDot:1
+10 SET IEN=^TMP("PXRM",$JOB,"ICD9IEN",SUB)
+11 SET IND=IND+1
SET SEQ=SEQ+1
+12 SET I2N="+"_IND_","_FDAIEN(1)_","
+13 SET ^TMP("PXRMGEDT",$JOB,811.23102,I2N,.01)=IEN
End DoDot:1
+14 ;
+15 SET SEQ=0
+16 FOR
SET SUB=$ORDER(^TMP("PXRM",$JOB,"ICPTIEN",SUB))
IF SUB=""
QUIT
Begin DoDot:1
+17 SET IEN=^TMP("PXRM",$JOB,"ICPTIEN",SUB)
+18 SET IND=IND+1
SET SEQ=SEQ+1
+19 SET I2N="+"_IND_","_FDAIEN(1)_","
+20 SET ^TMP("PXRMGEDT",$JOB,811.23104,I2N,.01)=IEN
End DoDot:1
+21 ;
+22 ;None found
+23 IF IND=1
QUIT
+24 ;
+25 SET TEMP="^TMP(""PXRMGEDT"","_$JOB_")"
+26 DO UPDATE^DIE("",TEMP,"FDAIEN","MSG")
+27 IF $DATA(MSG)
DO ERR
+28 KILL ^TMP("PXRMGEDT",$JOB)
+29 QUIT
+30 ;
+31 ;Error Handler
+32 ;-------------
ERR NEW ERROR,IC,REF
+1 SET ERROR(1)="Unable to build selectable codes for taxonomy : "
+2 SET ERROR(2)=NAME
+3 SET ERROR(3)="Error in UPDATE^DIE, needs further investigation"
+4 ;Move MSG into ERROR
+5 SET REF="MSG"
+6 FOR IC=4:1
SET REF=$QUERY(@REF)
IF REF=""
QUIT
SET ERROR(IC)=REF_"="_@REF
+7 ;Screen message
+8 DO BMES^XPDUTL(.ERROR)
+9 QUIT
+10 ;
TLOCK(FILE,DA) ;Lock the record
+1 LOCK +^PXD(FILE,DA):DILOCKTM
IF $TEST
QUIT 1
+2 IF '$TEST
WRITE !!,?5,"Another user is editing this file, try later"
HANG 2
QUIT 0
+3 ;
+4 ;
TUNLOCK(FILE,DA) ;Unlock the record
+1 LOCK -^PXD(FILE,DA)
+2 QUIT
