HLDIE ;CIOFO-O/LJA - Direct 772 & 773 Sets ; 08/05/2009 16:00
;;1.6;HEALTH LEVEL SEVEN;**109,122,142,145**;Oct 13,1995;Build 4
;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
; Rules: if any of these rules is broken, FILE^DIE is called instead
;
; * Can't edit files other than 772,773
; * Don't pass IENS value with multiples IENs. You can only
; edit one IEN at a time!
; * Only flag "S" is honored. Flag "K" is ignored. Other
; flags result in FILE^DIE being called.
; * Can't edit ^HLMA(IEN,90) data.
; * Can't edit ^HLMA(IEN,91) data.
; * Can't edit ^HL(772,IEN,"IN") data (field #200, MESSAGE TEXT)
; * No checking of data performed! (Data format MUST be OK.)
; * No locking of records in files 772 or 773. (Locks on queues.)
;
FILE(FLAGS,ROOT,ERR,SUB,RTN) ; FILE^DIE functional equivalent...
; This call has similar parameters to FILE^DIE, but changes data
; using hard sets. The first two parameters of this API are the
; same as FILE^DIE. So, if any file other than 772 or 773 is being
; edited, this API just passes on the FLAGS,ROOT,ERR parameters to
; FILE^DIE and quits. If file 772 or 773 is being edited, the hard
; set code in HLDIE772 and HLDIE773 is called.
;
N DEBUG,FILE,HLEDITOR,LERR,IEN,X,XECMCODE
;
S DT=$$NOW^XLFDT\1
;
D BEGIN ; Debug call at beginning or process
;
; Check FILE, IEN, FIELDs passed, etc...
I '$$CHECKS D QUIT ;->
.
. S HLEDITOR="FILE^DIE"
.
. ; Call FILEMAN...
. D FILE^DIE($G(FLAGS),$G(ROOT),$G(ERR))
.
. ; Debug call made even with Fileman...
. D END
;
S HLEDITOR="FILE^HLDIE"
;
; If this point is reached, file 772 or 773 is being edited, data
; in ROOT() has been checked, and data is being hard set...
;
;
; Make sure ERR is defined...
I $G(ERR)']"" N HLERR S ERR="HLERR"
;
; All editing occurs in this call...
D EDITALL(.ROOT,FILE,IEN)
;
; Store debug data if XTMP debug string set...
D END
;
;check if ROOT needs to be retained
I FLAGS'["S" K @ROOT,FLAGS
;
Q
;
EDITALL(ROOT,FILE,IEN) ; Edit 772 or 773 by direct sets...
;
; FILE,IEN -- optional (parsed from ROOT())
;
N ERRNO,FIELD,GBL,NODE,ROUTINE,TAG,VALUE,XRF
;
S GBL=$$GBL(FILE,+IEN)
;
;check if .01="@" for deletion of record...
I $G(@ROOT@(FILE,IEN,.01))="@" D Q
.I FILE=773 D DEL773^HLUOPT3(+IEN) Q
.I FILE=772 D DEL772^HLUOPT3(+IEN)
;
; patch HL*1.6*122: MPI-client/server
; If no data in record passed in, log an error and quit...
; I '$D(@GBL) D Q ; Remember. GBL contains IEN...
N HLDGBL
F L +@GBL:10 Q:$T H 1
; patch HL*1.6*142: MPI-client/server start
N COUNT
F COUNT=1:1:15 Q:$D(@GBL) H COUNT
; patch HL*1.6*142: MPI-client/server end
S HLDGBL=$D(@GBL)
L -@GBL
I 'HLDGBL D Q ; Remember. GBL contains IEN...
. S ERRNO=$$ERRNO(601,"The entry does not exist.",FILE,2)
. S @ERR@("DIERR",+ERRNO,"PARAM","IENS")=IEN_$S(IEN'[",":",",1:"")
;
;
; What routine holds the file-specific field/xref set code?
S ROUTINE=$S(FILE=772:"HLDIE772",FILE=773:"HLDIE773",1:"")
;
; Load NODEs...
D GETNODES(FILE,+IEN,.NODE)
;
; When a field is edited, the NODE(1) is changed
;
; Edit NODE(1), adding new values, and set XRF(XREF) nodes...
S FIELD=0
F S FIELD=$O(@ROOT@(FILE,IEN,FIELD)) Q:FIELD'>0 D
. ; VALUE = value passed in by process that is to be stored in file
. S VALUE=$G(@ROOT@(FILE,IEN,FIELD))
.
. ; If field should be deleted, VALUE will equal @...
. I VALUE="@" S VALUE=""
.
. ; Get and check tag...
. S TAG="F"_(FILE-770)_$TR(FIELD,".","")_U_ROUTINE
. S TAG(1)=$T(@TAG) I TAG(1)']"" D QUIT ;->
. . S ERRNO=$$ERRNO(501,"No set logic for file #"_FILE_"'s field# "_FIELD,FILE,3)
. . S @ERR@("DIERR",+ERRNO,"PARAM",1)=FIELD
. . S @ERR@("DIERR",+ERRNO,"PARAM","FIELD")=FIELD
.
. ; Call the subroutine below that is for the specific field...
. ; (No editing of xrefs or global data occurs in these calls.)
. D @("F"_(FILE-770)_$TR(FIELD,".","")_U_ROUTINE)
;
; If no data actually changed, quit...
QUIT:'$D(NODE("CHG")) ;->
;
; patch HL*1.6*142 start: MPI-client/server
; Store changes in the global now...
D STORE(FILE,IEN,.NODE)
;
; patch HL*1.6*122: MPI-client/server
I FILE=773 D
. F L +^HLMA(+IEN):10 Q:$T H 1
E D
. F L +^HL(772,+IEN):10 Q:$T H 1
;
; Set xrefs to correspond to the just-stored data...
S XRF=""
F S XRF=$O(XRF(XRF)) Q:XRF']"" D
. D @("XRF"_XRF_U_ROUTINE)
. ; create x-ref: ^HLMA("AH-NEW")
. ; it is also defined in DD of field #2 (messsage ID)
. I (FILE=773),(XRF="AH") D
.. ; patch HL*1.6*145
.. ; N HDR,FLD
.. N HDR,FLD,COUNT,AH
.. ; the following code not work for all, such as outgoing msg
.. ; F COUNT=1:1:15 Q:$D(^HLMA(+IEN,"MSH",1,0)) H COUNT
.. ; patch HL*1.6*145 end
.. S HDR=$G(^HLMA(+IEN,"MSH",1,0))
.. Q:HDR']""
.. S HDR(2)=$G(^HLMA(+IEN,"MSH",2,0))
.. S:HDR(2)]"" HDR=HDR_HDR(2)
.. S FLD=$E(HDR,4)
.. Q:FLD']""
.. S HDR=$P(HDR,FLD,3,6)
.. I HDR]"" D
... ; patch HL*1.6*145
... ; S ^HLMA("AH-NEW",HDR,+$P($G(^HLMA(+IEN,0)),"^",2),+IEN)=""
... ; the following code not work for all, such as outgoing msg
... ; F COUNT=1:1:15 Q:($P($G(^HLMA(+IEN,0)),"^",2)]"") H COUNT
... S AH=$P($G(^HLMA(+IEN,0)),"^",2)
... I AH]"" D
.... S ^HLMA("AH-NEW",HDR,AH,+IEN)=""
.... S HL("HDR FLDS:3-6")=HDR
... ; patch HL*1.6*145 end
;
; patch HL*1.6*122: MPI-client/server
I FILE=773 L -^HLMA(+IEN)
E L -^HL(772,+IEN)
; patch HL*1.6*142 end
;
Q
;
GETNODES(FILE,IEN,NODE) ; Load pre-change data for each node in
; NODE(node,0), and load node to be changed in NODE(node,1).
; GBL -- req
;
; patch HL*1.6*142 start: MPI-client/server
F L +@GBL:10 Q:$T H 1
F NODE=0,1,2,"P","S" D
. ; After setting, NODE(NODE,0) will equal each other.
. ; However, after each edited field is processed, the pieces of
. ; data in NODE(NODE,1) will be changed. The pre and post nodes
. ; then are of comparison value.
. S NODE(NODE,0)=$G(@GBL@(NODE)) ; Pre-change node
. ;
. ; for MPI-client/server environment:
. ; if it is going to update field #773,3 (Transmission type)
. ; field #773,2 (message ID) should be existed, otherwise,
. ; wait until it is available on this client node
. I FILE=773,$D(@ROOT@(3)),$P(NODE(NODE,0),"^",2)']"" D
.. N COUNT
.. F COUNT=1:1:15 Q:($P(NODE(NODE,0),"^",2)]"") D H COUNT
... S NODE(NODE,0)=$G(@GBL@(NODE))
. S NODE(NODE,1)=NODE(NODE,0) ; Node that is changed
L -@GBL
; patch HL*1.6*142 end
Q
;
STORE(FILE,IEN,NODE) ; Store changes in file...
N DATA,ND
;
; Loop thru change nodes, get changed data, and store it...
S ND=""
F S ND=$O(NODE("CHG",ND)) Q:ND']"" D
. S DATA=$G(NODE(ND,1))
. ; Even if no data no node, store it. (Will be removed by purge.)
. ;
. ; patch HL*1.6*142: MPI-client/server start
. ; I FILE=772 S ^HL(772,+IEN,ND)=DATA
. I FILE=772 D
.. F L +^HL(772,+IEN,ND):10 Q:$T H 1
.. S ^HL(772,+IEN,ND)=DATA
.. L -^HL(772,+IEN,ND)
. ; I FILE=773 S ^HLMA(+IEN,ND)=DATA
. I FILE=773 D
.. F L +^HLMA(+IEN,ND):10 Q:$T H 1
.. S ^HLMA(+IEN,ND)=DATA
.. L -^HLMA(+IEN,ND)
. ; patch HL*1.6*142: MPI-client/server end
;
QUIT
;
GBL(FILE,IEN) QUIT $S(FILE=772:"^HL(772,"_+IEN_")",1:"^HLMA("_+IEN_")")
;
CHKFLD(FILE,FIELD) ; Does passed-in field exist?
; Returns -- @ERR@(...) ->
;
; Quit if field exists...
QUIT:$D(^DD(+FILE,+FIELD)) 1 ;->
;
; Field doesn't exist. Log error...
S ERRNO=$$ERRNO(501,"File #"_FILE_" does not contain a field "_FIELD_".",FILE,3)
S @ERR@("DIERR",+ERRNO,"PARAM",1)=FIELD
S @ERR@("DIERR",+ERRNO,"PARAM","FIELD")=FIELD
;
Q ""
;
ERRNO(NUM,TXT,FILE,PNO) ; Return next ERROR number and create general data...
N NO
S NO=$G(@ERR@("DIERR"))+1,@ERR@("DIERR")=+NO_U_+NO
S @ERR@("DIERR",NO)=NUM
S @ERR@("DIERR",NO,"PARAM",0)=PNO
S @ERR@("DIERR",NO,"PARAM","FILE")=FILE
S @ERR@("DIERR",NO,"TEXT",1)=TXT
S @ERR@("DIERR","E",NUM,NO)=""
Q NO
;
GENLERR(ETXT) ; Store GENERAL (and fatal) error...
; ERR -- req
N NO
S NO=$G(@ERR@("DIERR"))+1,@ERR@("DIERR")=+NO_U_+NO
S @ERR@("DIERR",NO)=999_U_ETXT ; Made up error number
Q
;
CHECKS() ; Check ROOT() for file and validity of data...
; FLAGS, ROOT() -- req --> FILE,IEN
N I,OK,FIELD
;
;check the file & ien
S FILE=$O(@ROOT@(0))
I FILE'=772,FILE'=773 D QUIT "" ;->
. S IEN=$S(FILE:$O(@ROOT@(FILE,0)),1:0) ; Set for debugging
;
; ;shouldn't be more than 1 file!
QUIT:$O(@ROOT@(FILE)) "" ;->
;
;check the ien structure, and that only ien passed...
S IEN=$O(@ROOT@(FILE,0))
; Structure check...
QUIT:$P(IEN,",")'=+IEN_"," "" ;->
; Is it numeric?
QUIT:'(+IEN) "" ;->
; Has more than one IEN been passed?
QUIT:($O(@ROOT@(FILE,IEN))'="") "" ;->
;
;check the flags. Only K and S flags allowed...
I $L(FLAGS) D QUIT:'OK "" ;->
. S OK=1
. F I=0:1:$L(FLAGS) I $E(FLAGS,I)'="K",$E(FLAGS,I)'="S" S OK=0
;
; Check for existence of FIELD in FILE's DD & if an excluded field.
; (See rules for fields which cannot be updated by FILE^HLDIE.)
S FIELD=0,OK=1
F S FIELD=$O(@ROOT@(FILE,IEN,FIELD)) Q:FIELD="" D Q:'OK
. I '$$CHKFLD(FILE,FIELD) S OK=0 Q
. I FILE=773,FIELD\1=90 S OK=0 Q
. I FILE=773,FIELD\1=91 S OK=0 Q
. I FILE=772,FIELD=200 S OK=0 Q
;
; If not OK to use FILE^HLDIE, skip any further testing...
QUIT:'OK "" ;->
;
; *** WARNING ***
; The following check **MUST** be removed after FILE^HLDIE is working.
;
; Final check for whether FILE^HLDIE should be used...
I $G(^XTMP("HLDIE-DEBUG","CALL"))]"" QUIT "" ;->
; If this node exists and follows null, FILE^DIE will be used.
; Otherwise, execution defaults to using FILE^HLDIE.
;
Q OK
;
BEGIN ; Always call here before any ^HLDIE or ^DIE calls...
D DEBUG(1)
Q
;
END ; Always call here after all ^HLDIE or ^DIE actions...
D DEBUG(2)
Q
;
DEBUG(LOC) ; Debug presets and setup...
; Most variables created here should be left around. These variables
; are newed above.
N STORE
;
S RTN=$G(RTN),SUB=$G(SUB)
;
; First-time (beginning) call setups...
I LOC=1 D
. S RTN=$S(RTN]"":RTN,1:"HLDIE")_"~"_$S(RTN="HLDIE":"FILE",1:SUB)
. S DEBUG=$G(^XTMP("HLDIE-DEBUG","STATUS"))
. S XECMCODE=$P(DEBUG,U,3)
; DEBUG is always called at beginning (LOC=1) and end (LOC=2) or
; FILE^HLDIE. So, set up variables only once, at beginning...
;
; Setup that is individual to each (1 or 2) call...
S STORE=$P(DEBUG,U,LOC),STORE=$S(STORE=1:1,STORE=2:2,1:"")
; Some, All, or no data stored?
;
; If no STORE instructions, and no M code to specify STORE, quit...
QUIT:'STORE&($G(XECMCODE)'=1) ;->
;
; Call DEBUG to STORE data...
D DEBUG^HLDIEDBG(RTN,LOC,STORE,XECMCODE)
;
Q
;
EOR ;HLDIE - Direct 772 & 773 Sets ; 11/18/2003 11:17
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLDIE 11056 printed Sep 23, 2025@19:33:20 Page 2
HLDIE ;CIOFO-O/LJA - Direct 772 & 773 Sets ; 08/05/2009 16:00
+1 ;;1.6;HEALTH LEVEL SEVEN;**109,122,142,145**;Oct 13,1995;Build 4
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ;
+5 ; Rules: if any of these rules is broken, FILE^DIE is called instead
+6 ;
+7 ; * Can't edit files other than 772,773
+8 ; * Don't pass IENS value with multiples IENs. You can only
+9 ; edit one IEN at a time!
+10 ; * Only flag "S" is honored. Flag "K" is ignored. Other
+11 ; flags result in FILE^DIE being called.
+12 ; * Can't edit ^HLMA(IEN,90) data.
+13 ; * Can't edit ^HLMA(IEN,91) data.
+14 ; * Can't edit ^HL(772,IEN,"IN") data (field #200, MESSAGE TEXT)
+15 ; * No checking of data performed! (Data format MUST be OK.)
+16 ; * No locking of records in files 772 or 773. (Locks on queues.)
+17 ;
FILE(FLAGS,ROOT,ERR,SUB,RTN) ; FILE^DIE functional equivalent...
+1 ; This call has similar parameters to FILE^DIE, but changes data
+2 ; using hard sets. The first two parameters of this API are the
+3 ; same as FILE^DIE. So, if any file other than 772 or 773 is being
+4 ; edited, this API just passes on the FLAGS,ROOT,ERR parameters to
+5 ; FILE^DIE and quits. If file 772 or 773 is being edited, the hard
+6 ; set code in HLDIE772 and HLDIE773 is called.
+7 ;
+8 NEW DEBUG,FILE,HLEDITOR,LERR,IEN,X,XECMCODE
+9 ;
+10 SET DT=$$NOW^XLFDT\1
+11 ;
+12 ; Debug call at beginning or process
DO BEGIN
+13 ;
+14 ; Check FILE, IEN, FIELDs passed, etc...
+15 ;->
IF '$$CHECKS
Begin DoDot:1
+16 +17 SET HLEDITOR="FILE^DIE"
+18 +19 ; Call FILEMAN...
+20 DO FILE^DIE($GET(FLAGS),$GET(ROOT),$GET(ERR))
+21 +22 ; Debug call made even with Fileman...
+23 DO END
End DoDot:1
QUIT
+24 ;
+25 SET HLEDITOR="FILE^HLDIE"
+26 ;
+27 ; If this point is reached, file 772 or 773 is being edited, data
+28 ; in ROOT() has been checked, and data is being hard set...
+29 ;
+30 ;
+31 ; Make sure ERR is defined...
+32 IF $GET(ERR)']""
NEW HLERR
SET ERR="HLERR"
+33 ;
+34 ; All editing occurs in this call...
+35 DO EDITALL(.ROOT,FILE,IEN)
+36 ;
+37 ; Store debug data if XTMP debug string set...
+38 DO END
+39 ;
+40 ;check if ROOT needs to be retained
+41 IF FLAGS'["S"
KILL @ROOT,FLAGS
+42 ;
+43 QUIT
+44 ;
EDITALL(ROOT,FILE,IEN) ; Edit 772 or 773 by direct sets...
+1 ;
+2 ; FILE,IEN -- optional (parsed from ROOT())
+3 ;
+4 NEW ERRNO,FIELD,GBL,NODE,ROUTINE,TAG,VALUE,XRF
+5 ;
+6 SET GBL=$$GBL(FILE,+IEN)
+7 ;
+8 ;check if .01="@" for deletion of record...
+9 IF $GET(@ROOT@(FILE,IEN,.01))="@"
Begin DoDot:1
+10 IF FILE=773
DO DEL773^HLUOPT3(+IEN)
QUIT
+11 IF FILE=772
DO DEL772^HLUOPT3(+IEN)
End DoDot:1
QUIT
+12 ;
+13 ; patch HL*1.6*122: MPI-client/server
+14 ; If no data in record passed in, log an error and quit...
+15 ; I '$D(@GBL) D Q ; Remember. GBL contains IEN...
+16 NEW HLDGBL
+17 FOR
LOCK +@GBL:10
if $TEST
QUIT
HANG 1
+18 ; patch HL*1.6*142: MPI-client/server start
+19 NEW COUNT
+20 FOR COUNT=1:1:15
if $DATA(@GBL)
QUIT
HANG COUNT
+21 ; patch HL*1.6*142: MPI-client/server end
+22 SET HLDGBL=$DATA(@GBL)
+23 LOCK -@GBL
+24 ; Remember. GBL contains IEN...
IF 'HLDGBL
Begin DoDot:1
+25 SET ERRNO=$$ERRNO(601,"The entry does not exist.",FILE,2)
+26 SET @ERR@("DIERR",+ERRNO,"PARAM","IENS")=IEN_$SELECT(IEN'[",":",",1:"")
End DoDot:1
QUIT
+27 ;
+28 ;
+29 ; What routine holds the file-specific field/xref set code?
+30 SET ROUTINE=$SELECT(FILE=772:"HLDIE772",FILE=773:"HLDIE773",1:"")
+31 ;
+32 ; Load NODEs...
+33 DO GETNODES(FILE,+IEN,.NODE)
+34 ;
+35 ; When a field is edited, the NODE(1) is changed
+36 ;
+37 ; Edit NODE(1), adding new values, and set XRF(XREF) nodes...
+38 SET FIELD=0
+39 FOR
SET FIELD=$ORDER(@ROOT@(FILE,IEN,FIELD))
if FIELD'>0
QUIT
Begin DoDot:1
+40 ; VALUE = value passed in by process that is to be stored in file
+41 SET VALUE=$GET(@ROOT@(FILE,IEN,FIELD))
+42 +43 ; If field should be deleted, VALUE will equal @...
+44 IF VALUE="@"
SET VALUE=""
+45 +46 ; Get and check tag...
+47 SET TAG="F"_(FILE-770)_$TRANSLATE(FIELD,".","")_U_ROUTINE
+48 ;->
SET TAG(1)=$TEXT(@TAG)
IF TAG(1)']""
Begin DoDot:2
+49 SET ERRNO=$$ERRNO(501,"No set logic for file #"_FILE_"'s field# "_FIELD,FILE,3)
+50 SET @ERR@("DIERR",+ERRNO,"PARAM",1)=FIELD
+51 SET @ERR@("DIERR",+ERRNO,"PARAM","FIELD")=FIELD
End DoDot:2
QUIT
+52 +53 ; Call the subroutine below that is for the specific field...
+54 ; (No editing of xrefs or global data occurs in these calls.)
+55 DO @("F"_(FILE-770)_$TRANSLATE(FIELD,".","")_U_ROUTINE)
End DoDot:1
+56 ;
+57 ; If no data actually changed, quit...
+58 ;->
if '$DATA(NODE("CHG"))
QUIT
+59 ;
+60 ; patch HL*1.6*142 start: MPI-client/server
+61 ; Store changes in the global now...
+62 DO STORE(FILE,IEN,.NODE)
+63 ;
+64 ; patch HL*1.6*122: MPI-client/server
+65 IF FILE=773
Begin DoDot:1
+66 FOR
LOCK +^HLMA(+IEN):10
if $TEST
QUIT
HANG 1
End DoDot:1
+67 IF '$TEST
Begin DoDot:1
+68 FOR
LOCK +^HL(772,+IEN):10
if $TEST
QUIT
HANG 1
End DoDot:1
+69 ;
+70 ; Set xrefs to correspond to the just-stored data...
+71 SET XRF=""
+72 FOR
SET XRF=$ORDER(XRF(XRF))
if XRF']""
QUIT
Begin DoDot:1
+73 DO @("XRF"_XRF_U_ROUTINE)
+74 ; create x-ref: ^HLMA("AH-NEW")
+75 ; it is also defined in DD of field #2 (messsage ID)
+76 IF (FILE=773)
IF (XRF="AH")
Begin DoDot:2
+77 ; patch HL*1.6*145
+78 ; N HDR,FLD
+79 NEW HDR,FLD,COUNT,AH
+80 ; the following code not work for all, such as outgoing msg
+81 ; F COUNT=1:1:15 Q:$D(^HLMA(+IEN,"MSH",1,0)) H COUNT
+82 ; patch HL*1.6*145 end
+83 SET HDR=$GET(^HLMA(+IEN,"MSH",1,0))
+84 if HDR']""
QUIT
+85 SET HDR(2)=$GET(^HLMA(+IEN,"MSH",2,0))
+86 if HDR(2)]""
SET HDR=HDR_HDR(2)
+87 SET FLD=$EXTRACT(HDR,4)
+88 if FLD']""
QUIT
+89 SET HDR=$PIECE(HDR,FLD,3,6)
+90 IF HDR]""
Begin DoDot:3
+91 ; patch HL*1.6*145
+92 ; S ^HLMA("AH-NEW",HDR,+$P($G(^HLMA(+IEN,0)),"^",2),+IEN)=""
+93 ; the following code not work for all, such as outgoing msg
+94 ; F COUNT=1:1:15 Q:($P($G(^HLMA(+IEN,0)),"^",2)]"") H COUNT
+95 SET AH=$PIECE($GET(^HLMA(+IEN,0)),"^",2)
+96 IF AH]""
Begin DoDot:4
+97 SET ^HLMA("AH-NEW",HDR,AH,+IEN)=""
+98 SET HL("HDR FLDS:3-6")=HDR
End DoDot:4
+99 ; patch HL*1.6*145 end
End DoDot:3
End DoDot:2
End DoDot:1
+100 ;
+101 ; patch HL*1.6*122: MPI-client/server
+102 IF FILE=773
LOCK -^HLMA(+IEN)
+103 IF '$TEST
LOCK -^HL(772,+IEN)
+104 ; patch HL*1.6*142 end
+105 ;
+106 QUIT
+107 ;
GETNODES(FILE,IEN,NODE) ; Load pre-change data for each node in
+1 ; NODE(node,0), and load node to be changed in NODE(node,1).
+2 ; GBL -- req
+3 ;
+4 ; patch HL*1.6*142 start: MPI-client/server
+5 FOR
LOCK +@GBL:10
if $TEST
QUIT
HANG 1
+6 FOR NODE=0,1,2,"P","S"
Begin DoDot:1
+7 ; After setting, NODE(NODE,0) will equal each other.
+8 ; However, after each edited field is processed, the pieces of
+9 ; data in NODE(NODE,1) will be changed. The pre and post nodes
+10 ; then are of comparison value.
+11 ; Pre-change node
SET NODE(NODE,0)=$GET(@GBL@(NODE))
+12 ;
+13 ; for MPI-client/server environment:
+14 ; if it is going to update field #773,3 (Transmission type)
+15 ; field #773,2 (message ID) should be existed, otherwise,
+16 ; wait until it is available on this client node
+17 IF FILE=773
IF $DATA(@ROOT@(3))
IF $PIECE(NODE(NODE,0),"^",2)']""
Begin DoDot:2
+18 NEW COUNT
+19 FOR COUNT=1:1:15
if ($PIECE(NODE(NODE,0),"^",2)]"")
QUIT
Begin DoDot:3
+20 SET NODE(NODE,0)=$GET(@GBL@(NODE))
End DoDot:3
HANG COUNT
End DoDot:2
+21 ; Node that is changed
SET NODE(NODE,1)=NODE(NODE,0)
End DoDot:1
+22 LOCK -@GBL
+23 ; patch HL*1.6*142 end
+24 QUIT
+25 ;
STORE(FILE,IEN,NODE) ; Store changes in file...
+1 NEW DATA,ND
+2 ;
+3 ; Loop thru change nodes, get changed data, and store it...
+4 SET ND=""
+5 FOR
SET ND=$ORDER(NODE("CHG",ND))
if ND']""
QUIT
Begin DoDot:1
+6 SET DATA=$GET(NODE(ND,1))
+7 ; Even if no data no node, store it. (Will be removed by purge.)
+8 ;
+9 ; patch HL*1.6*142: MPI-client/server start
+10 ; I FILE=772 S ^HL(772,+IEN,ND)=DATA
+11 IF FILE=772
Begin DoDot:2
+12 FOR
LOCK +^HL(772,+IEN,ND):10
if $TEST
QUIT
HANG 1
+13 SET ^HL(772,+IEN,ND)=DATA
+14 LOCK -^HL(772,+IEN,ND)
End DoDot:2
+15 ; I FILE=773 S ^HLMA(+IEN,ND)=DATA
+16 IF FILE=773
Begin DoDot:2
+17 FOR
LOCK +^HLMA(+IEN,ND):10
if $TEST
QUIT
HANG 1
+18 SET ^HLMA(+IEN,ND)=DATA
+19 LOCK -^HLMA(+IEN,ND)
End DoDot:2
+20 ; patch HL*1.6*142: MPI-client/server end
End DoDot:1
+21 ;
+22 QUIT
+23 ;
GBL(FILE,IEN) QUIT $SELECT(FILE=772:"^HL(772,"_+IEN_")",1:"^HLMA("_+IEN_")")
+1 ;
CHKFLD(FILE,FIELD) ; Does passed-in field exist?
+1 ; Returns -- @ERR@(...) ->
+2 ;
+3 ; Quit if field exists...
+4 ;->
if $DATA(^DD(+FILE,+FIELD))
QUIT 1
+5 ;
+6 ; Field doesn't exist. Log error...
+7 SET ERRNO=$$ERRNO(501,"File #"_FILE_" does not contain a field "_FIELD_".",FILE,3)
+8 SET @ERR@("DIERR",+ERRNO,"PARAM",1)=FIELD
+9 SET @ERR@("DIERR",+ERRNO,"PARAM","FIELD")=FIELD
+10 ;
+11 QUIT ""
+12 ;
ERRNO(NUM,TXT,FILE,PNO) ; Return next ERROR number and create general data...
+1 NEW NO
+2 SET NO=$GET(@ERR@("DIERR"))+1
SET @ERR@("DIERR")=+NO_U_+NO
+3 SET @ERR@("DIERR",NO)=NUM
+4 SET @ERR@("DIERR",NO,"PARAM",0)=PNO
+5 SET @ERR@("DIERR",NO,"PARAM","FILE")=FILE
+6 SET @ERR@("DIERR",NO,"TEXT",1)=TXT
+7 SET @ERR@("DIERR","E",NUM,NO)=""
+8 QUIT NO
+9 ;
GENLERR(ETXT) ; Store GENERAL (and fatal) error...
+1 ; ERR -- req
+2 NEW NO
+3 SET NO=$GET(@ERR@("DIERR"))+1
SET @ERR@("DIERR")=+NO_U_+NO
+4 ; Made up error number
SET @ERR@("DIERR",NO)=999_U_ETXT
+5 QUIT
+6 ;
CHECKS() ; Check ROOT() for file and validity of data...
+1 ; FLAGS, ROOT() -- req --> FILE,IEN
+2 NEW I,OK,FIELD
+3 ;
+4 ;check the file & ien
+5 SET FILE=$ORDER(@ROOT@(0))
+6 ;->
IF FILE'=772
IF FILE'=773
Begin DoDot:1
+7 ; Set for debugging
SET IEN=$SELECT(FILE:$ORDER(@ROOT@(FILE,0)),1:0)
End DoDot:1
QUIT ""
+8 ;
+9 ; ;shouldn't be more than 1 file!
+10 ;->
if $ORDER(@ROOT@(FILE))
QUIT ""
+11 ;
+12 ;check the ien structure, and that only ien passed...
+13 SET IEN=$ORDER(@ROOT@(FILE,0))
+14 ; Structure check...
+15 ;->
if $PIECE(IEN,",")'=+IEN_","
QUIT ""
+16 ; Is it numeric?
+17 ;->
if '(+IEN)
QUIT ""
+18 ; Has more than one IEN been passed?
+19 ;->
if ($ORDER(@ROOT@(FILE,IEN))'="")
QUIT ""
+20 ;
+21 ;check the flags. Only K and S flags allowed...
+22 ;->
IF $LENGTH(FLAGS)
Begin DoDot:1
+23 SET OK=1
+24 FOR I=0:1:$LENGTH(FLAGS)
IF $EXTRACT(FLAGS,I)'="K"
IF $EXTRACT(FLAGS,I)'="S"
SET OK=0
End DoDot:1
if 'OK
QUIT ""
+25 ;
+26 ; Check for existence of FIELD in FILE's DD & if an excluded field.
+27 ; (See rules for fields which cannot be updated by FILE^HLDIE.)
+28 SET FIELD=0
SET OK=1
+29 FOR
SET FIELD=$ORDER(@ROOT@(FILE,IEN,FIELD))
if FIELD=""
QUIT
Begin DoDot:1
+30 IF '$$CHKFLD(FILE,FIELD)
SET OK=0
QUIT
+31 IF FILE=773
IF FIELD\1=90
SET OK=0
QUIT
+32 IF FILE=773
IF FIELD\1=91
SET OK=0
QUIT
+33 IF FILE=772
IF FIELD=200
SET OK=0
QUIT
End DoDot:1
if 'OK
QUIT
+34 ;
+35 ; If not OK to use FILE^HLDIE, skip any further testing...
+36 ;->
if 'OK
QUIT ""
+37 ;
+38 ; *** WARNING ***
+39 ; The following check **MUST** be removed after FILE^HLDIE is working.
+40 ;
+41 ; Final check for whether FILE^HLDIE should be used...
+42 ;->
IF $GET(^XTMP("HLDIE-DEBUG","CALL"))]""
QUIT ""
+43 ; If this node exists and follows null, FILE^DIE will be used.
+44 ; Otherwise, execution defaults to using FILE^HLDIE.
+45 ;
+46 QUIT OK
+47 ;
BEGIN ; Always call here before any ^HLDIE or ^DIE calls...
+1 DO DEBUG(1)
+2 QUIT
+3 ;
END ; Always call here after all ^HLDIE or ^DIE actions...
+1 DO DEBUG(2)
+2 QUIT
+3 ;
DEBUG(LOC) ; Debug presets and setup...
+1 ; Most variables created here should be left around. These variables
+2 ; are newed above.
+3 NEW STORE
+4 ;
+5 SET RTN=$GET(RTN)
SET SUB=$GET(SUB)
+6 ;
+7 ; First-time (beginning) call setups...
+8 IF LOC=1
Begin DoDot:1
+9 SET RTN=$SELECT(RTN]"":RTN,1:"HLDIE")_"~"_$SELECT(RTN="HLDIE":"FILE",1:SUB)
+10 SET DEBUG=$GET(^XTMP("HLDIE-DEBUG","STATUS"))
+11 SET XECMCODE=$PIECE(DEBUG,U,3)
End DoDot:1
+12 ; DEBUG is always called at beginning (LOC=1) and end (LOC=2) or
+13 ; FILE^HLDIE. So, set up variables only once, at beginning...
+14 ;
+15 ; Setup that is individual to each (1 or 2) call...
+16 SET STORE=$PIECE(DEBUG,U,LOC)
SET STORE=$SELECT(STORE=1:1,STORE=2:2,1:"")
+17 ; Some, All, or no data stored?
+18 ;
+19 ; If no STORE instructions, and no M code to specify STORE, quit...
+20 ;->
if 'STORE&($GET(XECMCODE)'=1)
QUIT
+21 ;
+22 ; Call DEBUG to STORE data...
+23 DO DEBUG^HLDIEDBG(RTN,LOC,STORE,XECMCODE)
+24 ;
+25 QUIT
+26 ;
EOR ;HLDIE - Direct 772 & 773 Sets ; 11/18/2003 11:17
