HLDIE ;CIOFO-O/LJA - Direct 772 & 773 Sets ; 11/18/2003 11:17 ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13,1995 ; ; 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) ; ; If no data in record passed in, log an error and quit... I '$D(@GBL) 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")) ;-> ; ; Store changes in the global now... D STORE(FILE,IEN,.NODE) ; ; 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) ; 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 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 . S NODE(NODE,1)=NODE(NODE,0) ; Node that is changed 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.) . I FILE=772 S ^HL(772,+IEN,ND)=DATA . I FILE=773 S ^HLMA(+IEN,ND)=DATA ; 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