- 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 Feb 18, 2025@23:23:39 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