Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: HLDIE

HLDIE.m

Go to the documentation of this file. 
  1. HLDIE ;CIOFO-O/LJA - Direct 772 & 773 Sets ; 11/18/2003 11:17
  1.  ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13,1995
  1.  ;
  1.  ; Rules: if any of these rules is broken, FILE^DIE is called instead
  1.  ;
  1.  ;         * Can't edit files other than 772,773
  1.  ;         * Don't pass IENS value with multiples IENs.  You can only
  1.  ;             edit one IEN at a time!
  1.  ;         * Only flag "S" is honored.  Flag "K" is ignored. Other
  1.  ;             flags result in FILE^DIE being called.
  1.  ;         * Can't edit ^HLMA(IEN,90) data.
  1.  ;         * Can't edit ^HLMA(IEN,91) data.
  1.  ;         * Can't edit ^HL(772,IEN,"IN") data (field #200, MESSAGE TEXT)
  1.  ;         * No checking of data performed!  (Data format MUST be OK.)
  1.  ;         * No locking of records in files 772 or 773. (Locks on queues.)
  1.  ;
  1. FILE(FLAGS,ROOT,ERR,SUB,RTN) ; FILE^DIE functional equivalent...
  1.  ; This call has similar parameters to FILE^DIE, but changes data
  1.  ; using hard sets.  The first two parameters of this API are the
  1.  ; same as FILE^DIE.  So, if any file other than 772 or 773 is being
  1.  ; edited, this API just passes on the FLAGS,ROOT,ERR parameters to
  1.  ; FILE^DIE and quits.  If file 772 or 773 is being edited, the hard
  1.  ; set code in HLDIE772 and HLDIE773 is called. 
  1.  ;
  1.  N DEBUG,FILE,HLEDITOR,LERR,IEN,X,XECMCODE
  1.  ;
  1.  S DT=$$NOW^XLFDT\1
  1.  ;
  1.  D BEGIN ; Debug call at beginning or process
  1.  ;
  1.  ; Check FILE, IEN, FIELDs passed, etc...
  1.  I '$$CHECKS D  QUIT  ;->
  1.  .
  1.  .  S HLEDITOR="FILE^DIE"
  1.  .
  1.  .  ; Call FILEMAN...
  1.  .  D FILE^DIE($G(FLAGS),$G(ROOT),$G(ERR))
  1.  .
  1.  .  ; Debug call made even with Fileman...
  1.  .  D END
  1.  ;
  1.  S HLEDITOR="FILE^HLDIE"
  1.  ;
  1.  ; If this point is reached, file 772 or 773 is being edited, data
  1.  ; in ROOT() has been checked, and data is being hard set...
  1.  ;
  1.  ;
  1.  ; Make sure ERR is defined...
  1.  I $G(ERR)']"" N HLERR S ERR="HLERR"
  1.  ;
  1.  ; All editing occurs in this call...
  1.  D EDITALL(.ROOT,FILE,IEN)
  1.  ;
  1.  ; Store debug data if XTMP debug string set...
  1.  D END
  1.  ;
  1.  ;check if ROOT needs to be retained
  1.  I FLAGS'["S" K @ROOT,FLAGS
  1.  ;
  1.  Q
  1.  ;
  1. EDITALL(ROOT,FILE,IEN) ; Edit 772 or 773 by direct sets...
  1.  ;
  1.  ; FILE,IEN -- optional (parsed from ROOT())
  1.  ;
  1.  N ERRNO,FIELD,GBL,NODE,ROUTINE,TAG,VALUE,XRF
  1.  ;
  1.  S GBL=$$GBL(FILE,+IEN)
  1.  ;
  1.  ;check if .01="@" for deletion of record...
  1.  I $G(@ROOT@(FILE,IEN,.01))="@" D  Q
  1.  .I FILE=773 D DEL773^HLUOPT3(+IEN) Q
  1.  .I FILE=772 D DEL772^HLUOPT3(+IEN)
  1.  ;
  1.  ; If no data in record passed in, log an error and quit...
  1.  I '$D(@GBL) D  Q  ; Remember.  GBL contains IEN...
  1.  .  S ERRNO=$$ERRNO(601,"The entry does not exist.",FILE,2)
  1.  .  S @ERR@("DIERR",+ERRNO,"PARAM","IENS")=IEN_$S(IEN'[",":",",1:"")
  1.  ;
  1.  ;
  1.  ; What routine holds the file-specific field/xref set code?
  1.  S ROUTINE=$S(FILE=772:"HLDIE772",FILE=773:"HLDIE773",1:"")
  1.  ;
  1.  ; Load NODEs...
  1.  D GETNODES(FILE,+IEN,.NODE)
  1.  ;
  1.  ; When a field is edited, the NODE(1) is changed
  1.  ;
  1.  ; Edit NODE(1), adding new values, and set XRF(XREF) nodes...
  1.  S FIELD=0
  1.  F  S FIELD=$O(@ROOT@(FILE,IEN,FIELD)) Q:FIELD'>0  D
  1.  .  ; VALUE = value passed in by process that is to be stored in file
  1.  .  S VALUE=$G(@ROOT@(FILE,IEN,FIELD))
  1.  .
  1.  .  ; If field should be deleted, VALUE will equal @...
  1.  .  I VALUE="@" S VALUE=""
  1.  .
  1.  .  ; Get and check tag...
  1.  .  S TAG="F"_(FILE-770)_$TR(FIELD,".","")_U_ROUTINE
  1.  .  S TAG(1)=$T(@TAG) I TAG(1)']"" D  QUIT  ;->
  1.  .  .  S ERRNO=$$ERRNO(501,"No set logic for file #"_FILE_"'s field# "_FIELD,FILE,3)
  1.  .  .  S @ERR@("DIERR",+ERRNO,"PARAM",1)=FIELD
  1.  .  .  S @ERR@("DIERR",+ERRNO,"PARAM","FIELD")=FIELD
  1.  .
  1.  .  ; Call the subroutine below that is for the specific field...
  1.  .  ; (No editing of xrefs or global data occurs in these calls.)
  1.  .  D @("F"_(FILE-770)_$TR(FIELD,".","")_U_ROUTINE)
  1.  ;
  1.  ; If no data actually changed, quit...
  1.  QUIT:'$D(NODE("CHG"))  ;->
  1.  ;
  1.  ; Store changes in the global now...
  1.  D STORE(FILE,IEN,.NODE)
  1.  ;
  1.  ; Set xrefs to correspond to the just-stored data...
  1.  S XRF=""
  1.  F  S XRF=$O(XRF(XRF)) Q:XRF']""  D
  1.  .  D @("XRF"_XRF_U_ROUTINE)
  1.  ;
  1.  Q
  1.  ;
  1. 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).
  1.  ; GBL -- req
  1.  F NODE=0,1,2,"P","S" D
  1.  .  ; After setting, NODE(NODE,0) will equal each other.
  1.  .  ; However, after each edited field is processed, the pieces of
  1.  .  ; data in NODE(NODE,1) will be changed.  The pre and post nodes
  1.  .  ; then are of comparison value.
  1.  .  S NODE(NODE,0)=$G(@GBL@(NODE)) ; Pre-change node
  1.  .  S NODE(NODE,1)=NODE(NODE,0) ; Node that is changed
  1.  Q
  1.  ;
  1. STORE(FILE,IEN,NODE) ; Store changes in file...
  1.  N DATA,ND
  1.  ;
  1.  ; Loop thru change nodes, get changed data, and store it...
  1.  S ND=""
  1.  F  S ND=$O(NODE("CHG",ND)) Q:ND']""  D
  1.  .  S DATA=$G(NODE(ND,1))
  1.  .  ; Even if no data no node, store it.  (Will be removed by purge.)
  1.  .  I FILE=772 S ^HL(772,+IEN,ND)=DATA
  1.  .  I FILE=773 S ^HLMA(+IEN,ND)=DATA
  1.  ;
  1.  QUIT
  1.  ;
  1. GBL(FILE,IEN) QUIT $S(FILE=772:"^HL(772,"_+IEN_")",1:"^HLMA("_+IEN_")")
  1.  ;
  1. CHKFLD(FILE,FIELD) ; Does passed-in field exist?
  1.  ; Returns -- @ERR@(...) ->
  1.  ;
  1.  ; Quit if field exists...
  1.  QUIT:$D(^DD(+FILE,+FIELD)) 1 ;->
  1.  ;
  1.  ; Field doesn't exist.  Log error...
  1.  S ERRNO=$$ERRNO(501,"File #"_FILE_" does not contain a field "_FIELD_".",FILE,3)
  1.  S @ERR@("DIERR",+ERRNO,"PARAM",1)=FIELD
  1.  S @ERR@("DIERR",+ERRNO,"PARAM","FIELD")=FIELD
  1.  ;
  1.  Q ""
  1.  ;
  1. ERRNO(NUM,TXT,FILE,PNO) ; Return next ERROR number and create general data...
  1.  N NO
  1.  S NO=$G(@ERR@("DIERR"))+1,@ERR@("DIERR")=+NO_U_+NO
  1.  S @ERR@("DIERR",NO)=NUM
  1.  S @ERR@("DIERR",NO,"PARAM",0)=PNO
  1.  S @ERR@("DIERR",NO,"PARAM","FILE")=FILE
  1.  S @ERR@("DIERR",NO,"TEXT",1)=TXT
  1.  S @ERR@("DIERR","E",NUM,NO)=""
  1.  Q NO
  1.  ;
  1. GENLERR(ETXT) ; Store GENERAL (and fatal) error...
  1.  ; ERR -- req
  1.  N NO
  1.  S NO=$G(@ERR@("DIERR"))+1,@ERR@("DIERR")=+NO_U_+NO
  1.  S @ERR@("DIERR",NO)=999_U_ETXT ; Made up error number
  1.  Q
  1.  ;
  1. CHECKS() ; Check ROOT() for file and validity of data...
  1.  ; FLAGS, ROOT() -- req --> FILE,IEN
  1.  N I,OK,FIELD
  1.  ;
  1.  ;check the file & ien
  1.  S FILE=$O(@ROOT@(0))
  1.  I FILE'=772,FILE'=773 D  QUIT "" ;->
  1.  .  S IEN=$S(FILE:$O(@ROOT@(FILE,0)),1:0) ; Set for debugging
  1.  ;
  1.  ; ;shouldn't be more than 1 file!
  1.  QUIT:$O(@ROOT@(FILE)) "" ;->
  1.  ;
  1.  ;check the ien structure, and that only ien passed...
  1.  S IEN=$O(@ROOT@(FILE,0))
  1.  ; Structure check...
  1.  QUIT:$P(IEN,",")'=+IEN_"," "" ;->
  1.  ; Is it numeric?
  1.  QUIT:'(+IEN) "" ;->
  1.  ; Has more than one IEN been passed?
  1.  QUIT:($O(@ROOT@(FILE,IEN))'="") "" ;->
  1.  ;
  1.  ;check the flags.  Only K and S flags allowed...
  1.  I $L(FLAGS) D  QUIT:'OK "" ;->
  1.  .  S OK=1
  1.  .  F I=0:1:$L(FLAGS) I $E(FLAGS,I)'="K",$E(FLAGS,I)'="S" S OK=0
  1.  ;
  1.  ; Check for existence of FIELD in FILE's DD & if an excluded field.
  1.  ; (See rules for fields which cannot be updated by FILE^HLDIE.)
  1.  S FIELD=0,OK=1
  1.  F  S FIELD=$O(@ROOT@(FILE,IEN,FIELD)) Q:FIELD=""  D  Q:'OK
  1.  .  I '$$CHKFLD(FILE,FIELD) S OK=0 Q
  1.  .  I FILE=773,FIELD\1=90 S OK=0 Q
  1.  .  I FILE=773,FIELD\1=91 S OK=0 Q
  1.  .  I FILE=772,FIELD=200 S OK=0 Q
  1.  ;
  1.  ; If not OK to use FILE^HLDIE, skip any further testing...
  1.  QUIT:'OK "" ;->
  1.  ;
  1.  ;                    *** WARNING ***
  1.  ; The following check **MUST** be removed after FILE^HLDIE is working.
  1.  ;
  1.  ; Final check for whether FILE^HLDIE should be used...
  1.  I $G(^XTMP("HLDIE-DEBUG","CALL"))]"" QUIT "" ;->
  1.  ; If this node exists and follows null, FILE^DIE will be used.
  1.  ; Otherwise, execution defaults to using FILE^HLDIE.
  1.  ;
  1.  Q OK
  1.  ;
  1. BEGIN ; Always call here before any ^HLDIE or ^DIE calls...
  1.  D DEBUG(1)
  1.  Q
  1.  ;
  1. END ; Always call here after all ^HLDIE or ^DIE actions...
  1.  D DEBUG(2)
  1.  Q
  1.  ;
  1. DEBUG(LOC) ; Debug presets and setup...
  1.  ; Most variables created here should be left around.  These variables
  1.  ; are newed above.
  1.  N STORE
  1.  ;
  1.  S RTN=$G(RTN),SUB=$G(SUB)
  1.  ;
  1.  ; First-time (beginning) call setups...
  1.  I LOC=1 D
  1.  .  S RTN=$S(RTN]"":RTN,1:"HLDIE")_"~"_$S(RTN="HLDIE":"FILE",1:SUB)
  1.  .  S DEBUG=$G(^XTMP("HLDIE-DEBUG","STATUS"))
  1.  .  S XECMCODE=$P(DEBUG,U,3)
  1.  ; DEBUG is always called at beginning (LOC=1) and end (LOC=2) or
  1.  ; FILE^HLDIE.  So, set up variables only once, at beginning...
  1.  ;
  1.  ; Setup that is individual to each (1 or 2) call...
  1.  S STORE=$P(DEBUG,U,LOC),STORE=$S(STORE=1:1,STORE=2:2,1:"")
  1.  ; Some, All, or no data stored?
  1.  ;
  1.  ; If no STORE instructions, and no M code to specify STORE, quit...
  1.  QUIT:'STORE&($G(XECMCODE)'=1)  ;->
  1.  ;
  1.  ; Call DEBUG to STORE data...
  1.  D DEBUG^HLDIEDBG(RTN,LOC,STORE,XECMCODE)
  1.  ;
  1.  Q
  1.  ;
  1. EOR ;HLDIE - Direct 772 & 773 Sets ; 11/18/2003 11:17