| 1 | HLDIE ;CIOFO-O/LJA - Direct 772 & 773 Sets ; 10/19/2007 11:15
|
|---|
| 2 | ;;1.6;HEALTH LEVEL SEVEN;**109,122**;Oct 13,1995;Build 14
|
|---|
| 3 | ;Per VHA Directive 2004-038, this routine should not be modified.
|
|---|
| 4 | Q
|
|---|
| 5 | ;
|
|---|
| 6 | ; Rules: if any of these rules is broken, FILE^DIE is called instead
|
|---|
| 7 | ;
|
|---|
| 8 | ; * Can't edit files other than 772,773
|
|---|
| 9 | ; * Don't pass IENS value with multiples IENs. You can only
|
|---|
| 10 | ; edit one IEN at a time!
|
|---|
| 11 | ; * Only flag "S" is honored. Flag "K" is ignored. Other
|
|---|
| 12 | ; flags result in FILE^DIE being called.
|
|---|
| 13 | ; * Can't edit ^HLMA(IEN,90) data.
|
|---|
| 14 | ; * Can't edit ^HLMA(IEN,91) data.
|
|---|
| 15 | ; * Can't edit ^HL(772,IEN,"IN") data (field #200, MESSAGE TEXT)
|
|---|
| 16 | ; * No checking of data performed! (Data format MUST be OK.)
|
|---|
| 17 | ; * No locking of records in files 772 or 773. (Locks on queues.)
|
|---|
| 18 | ;
|
|---|
| 19 | FILE(FLAGS,ROOT,ERR,SUB,RTN) ; FILE^DIE functional equivalent...
|
|---|
| 20 | ; This call has similar parameters to FILE^DIE, but changes data
|
|---|
| 21 | ; using hard sets. The first two parameters of this API are the
|
|---|
| 22 | ; same as FILE^DIE. So, if any file other than 772 or 773 is being
|
|---|
| 23 | ; edited, this API just passes on the FLAGS,ROOT,ERR parameters to
|
|---|
| 24 | ; FILE^DIE and quits. If file 772 or 773 is being edited, the hard
|
|---|
| 25 | ; set code in HLDIE772 and HLDIE773 is called.
|
|---|
| 26 | ;
|
|---|
| 27 | N DEBUG,FILE,HLEDITOR,LERR,IEN,X,XECMCODE
|
|---|
| 28 | ;
|
|---|
| 29 | S DT=$$NOW^XLFDT\1
|
|---|
| 30 | ;
|
|---|
| 31 | D BEGIN ; Debug call at beginning or process
|
|---|
| 32 | ;
|
|---|
| 33 | ; Check FILE, IEN, FIELDs passed, etc...
|
|---|
| 34 | I '$$CHECKS D QUIT ;->
|
|---|
| 35 | .
|
|---|
| 36 | . S HLEDITOR="FILE^DIE"
|
|---|
| 37 | .
|
|---|
| 38 | . ; Call FILEMAN...
|
|---|
| 39 | . D FILE^DIE($G(FLAGS),$G(ROOT),$G(ERR))
|
|---|
| 40 | .
|
|---|
| 41 | . ; Debug call made even with Fileman...
|
|---|
| 42 | . D END
|
|---|
| 43 | ;
|
|---|
| 44 | S HLEDITOR="FILE^HLDIE"
|
|---|
| 45 | ;
|
|---|
| 46 | ; If this point is reached, file 772 or 773 is being edited, data
|
|---|
| 47 | ; in ROOT() has been checked, and data is being hard set...
|
|---|
| 48 | ;
|
|---|
| 49 | ;
|
|---|
| 50 | ; Make sure ERR is defined...
|
|---|
| 51 | I $G(ERR)']"" N HLERR S ERR="HLERR"
|
|---|
| 52 | ;
|
|---|
| 53 | ; All editing occurs in this call...
|
|---|
| 54 | D EDITALL(.ROOT,FILE,IEN)
|
|---|
| 55 | ;
|
|---|
| 56 | ; Store debug data if XTMP debug string set...
|
|---|
| 57 | D END
|
|---|
| 58 | ;
|
|---|
| 59 | ;check if ROOT needs to be retained
|
|---|
| 60 | I FLAGS'["S" K @ROOT,FLAGS
|
|---|
| 61 | ;
|
|---|
| 62 | Q
|
|---|
| 63 | ;
|
|---|
| 64 | EDITALL(ROOT,FILE,IEN) ; Edit 772 or 773 by direct sets...
|
|---|
| 65 | ;
|
|---|
| 66 | ; FILE,IEN -- optional (parsed from ROOT())
|
|---|
| 67 | ;
|
|---|
| 68 | N ERRNO,FIELD,GBL,NODE,ROUTINE,TAG,VALUE,XRF
|
|---|
| 69 | ;
|
|---|
| 70 | S GBL=$$GBL(FILE,+IEN)
|
|---|
| 71 | ;
|
|---|
| 72 | ;check if .01="@" for deletion of record...
|
|---|
| 73 | I $G(@ROOT@(FILE,IEN,.01))="@" D Q
|
|---|
| 74 | .I FILE=773 D DEL773^HLUOPT3(+IEN) Q
|
|---|
| 75 | .I FILE=772 D DEL772^HLUOPT3(+IEN)
|
|---|
| 76 | ;
|
|---|
| 77 | ; patch HL*1.6*122: MPI-client/server
|
|---|
| 78 | ; If no data in record passed in, log an error and quit...
|
|---|
| 79 | ; I '$D(@GBL) D Q ; Remember. GBL contains IEN...
|
|---|
| 80 | N HLDGBL
|
|---|
| 81 | F L +@GBL:10 Q:$T H 1
|
|---|
| 82 | S HLDGBL=$D(@GBL)
|
|---|
| 83 | L -@GBL
|
|---|
| 84 | I 'HLDGBL D Q ; Remember. GBL contains IEN...
|
|---|
| 85 | . S ERRNO=$$ERRNO(601,"The entry does not exist.",FILE,2)
|
|---|
| 86 | . S @ERR@("DIERR",+ERRNO,"PARAM","IENS")=IEN_$S(IEN'[",":",",1:"")
|
|---|
| 87 | ;
|
|---|
| 88 | ;
|
|---|
| 89 | ; What routine holds the file-specific field/xref set code?
|
|---|
| 90 | S ROUTINE=$S(FILE=772:"HLDIE772",FILE=773:"HLDIE773",1:"")
|
|---|
| 91 | ;
|
|---|
| 92 | ; Load NODEs...
|
|---|
| 93 | D GETNODES(FILE,+IEN,.NODE)
|
|---|
| 94 | ;
|
|---|
| 95 | ; When a field is edited, the NODE(1) is changed
|
|---|
| 96 | ;
|
|---|
| 97 | ; Edit NODE(1), adding new values, and set XRF(XREF) nodes...
|
|---|
| 98 | S FIELD=0
|
|---|
| 99 | F S FIELD=$O(@ROOT@(FILE,IEN,FIELD)) Q:FIELD'>0 D
|
|---|
| 100 | . ; VALUE = value passed in by process that is to be stored in file
|
|---|
| 101 | . S VALUE=$G(@ROOT@(FILE,IEN,FIELD))
|
|---|
| 102 | .
|
|---|
| 103 | . ; If field should be deleted, VALUE will equal @...
|
|---|
| 104 | . I VALUE="@" S VALUE=""
|
|---|
| 105 | .
|
|---|
| 106 | . ; Get and check tag...
|
|---|
| 107 | . S TAG="F"_(FILE-770)_$TR(FIELD,".","")_U_ROUTINE
|
|---|
| 108 | . S TAG(1)=$T(@TAG) I TAG(1)']"" D QUIT ;->
|
|---|
| 109 | . . S ERRNO=$$ERRNO(501,"No set logic for file #"_FILE_"'s field# "_FIELD,FILE,3)
|
|---|
| 110 | . . S @ERR@("DIERR",+ERRNO,"PARAM",1)=FIELD
|
|---|
| 111 | . . S @ERR@("DIERR",+ERRNO,"PARAM","FIELD")=FIELD
|
|---|
| 112 | .
|
|---|
| 113 | . ; Call the subroutine below that is for the specific field...
|
|---|
| 114 | . ; (No editing of xrefs or global data occurs in these calls.)
|
|---|
| 115 | . D @("F"_(FILE-770)_$TR(FIELD,".","")_U_ROUTINE)
|
|---|
| 116 | ;
|
|---|
| 117 | ; If no data actually changed, quit...
|
|---|
| 118 | QUIT:'$D(NODE("CHG")) ;->
|
|---|
| 119 | ;
|
|---|
| 120 | ; patch HL*1.6*122: MPI-client/server
|
|---|
| 121 | I FILE=773 D
|
|---|
| 122 | . F L +^HLMA(IEN):10 Q:$T H 1
|
|---|
| 123 | E D
|
|---|
| 124 | . F L +^HL(772,IEN):10 Q:$T H 1
|
|---|
| 125 | ;
|
|---|
| 126 | ; Store changes in the global now...
|
|---|
| 127 | D STORE(FILE,IEN,.NODE)
|
|---|
| 128 | ;
|
|---|
| 129 | ; Set xrefs to correspond to the just-stored data...
|
|---|
| 130 | S XRF=""
|
|---|
| 131 | F S XRF=$O(XRF(XRF)) Q:XRF']"" D
|
|---|
| 132 | . D @("XRF"_XRF_U_ROUTINE)
|
|---|
| 133 | ;
|
|---|
| 134 | ; patch HL*1.6*122: MPI-client/server
|
|---|
| 135 | I FILE=773 L -^HLMA(IEN)
|
|---|
| 136 | E L -^HL(772,IEN)
|
|---|
| 137 | ;
|
|---|
| 138 | Q
|
|---|
| 139 | ;
|
|---|
| 140 | GETNODES(FILE,IEN,NODE) ; Load pre-change data for each node in
|
|---|
| 141 | ; NODE(node,0), and load node to be changed in NODE(node,1).
|
|---|
| 142 | ; GBL -- req
|
|---|
| 143 | F NODE=0,1,2,"P","S" D
|
|---|
| 144 | . ; After setting, NODE(NODE,0) will equal each other.
|
|---|
| 145 | . ; However, after each edited field is processed, the pieces of
|
|---|
| 146 | . ; data in NODE(NODE,1) will be changed. The pre and post nodes
|
|---|
| 147 | . ; then are of comparison value.
|
|---|
| 148 | . S NODE(NODE,0)=$G(@GBL@(NODE)) ; Pre-change node
|
|---|
| 149 | . S NODE(NODE,1)=NODE(NODE,0) ; Node that is changed
|
|---|
| 150 | Q
|
|---|
| 151 | ;
|
|---|
| 152 | STORE(FILE,IEN,NODE) ; Store changes in file...
|
|---|
| 153 | N DATA,ND
|
|---|
| 154 | ;
|
|---|
| 155 | ; Loop thru change nodes, get changed data, and store it...
|
|---|
| 156 | S ND=""
|
|---|
| 157 | F S ND=$O(NODE("CHG",ND)) Q:ND']"" D
|
|---|
| 158 | . S DATA=$G(NODE(ND,1))
|
|---|
| 159 | . ; Even if no data no node, store it. (Will be removed by purge.)
|
|---|
| 160 | . I FILE=772 S ^HL(772,+IEN,ND)=DATA
|
|---|
| 161 | . I FILE=773 S ^HLMA(+IEN,ND)=DATA
|
|---|
| 162 | ;
|
|---|
| 163 | QUIT
|
|---|
| 164 | ;
|
|---|
| 165 | GBL(FILE,IEN) QUIT $S(FILE=772:"^HL(772,"_+IEN_")",1:"^HLMA("_+IEN_")")
|
|---|
| 166 | ;
|
|---|
| 167 | CHKFLD(FILE,FIELD) ; Does passed-in field exist?
|
|---|
| 168 | ; Returns -- @ERR@(...) ->
|
|---|
| 169 | ;
|
|---|
| 170 | ; Quit if field exists...
|
|---|
| 171 | QUIT:$D(^DD(+FILE,+FIELD)) 1 ;->
|
|---|
| 172 | ;
|
|---|
| 173 | ; Field doesn't exist. Log error...
|
|---|
| 174 | S ERRNO=$$ERRNO(501,"File #"_FILE_" does not contain a field "_FIELD_".",FILE,3)
|
|---|
| 175 | S @ERR@("DIERR",+ERRNO,"PARAM",1)=FIELD
|
|---|
| 176 | S @ERR@("DIERR",+ERRNO,"PARAM","FIELD")=FIELD
|
|---|
| 177 | ;
|
|---|
| 178 | Q ""
|
|---|
| 179 | ;
|
|---|
| 180 | ERRNO(NUM,TXT,FILE,PNO) ; Return next ERROR number and create general data...
|
|---|
| 181 | N NO
|
|---|
| 182 | S NO=$G(@ERR@("DIERR"))+1,@ERR@("DIERR")=+NO_U_+NO
|
|---|
| 183 | S @ERR@("DIERR",NO)=NUM
|
|---|
| 184 | S @ERR@("DIERR",NO,"PARAM",0)=PNO
|
|---|
| 185 | S @ERR@("DIERR",NO,"PARAM","FILE")=FILE
|
|---|
| 186 | S @ERR@("DIERR",NO,"TEXT",1)=TXT
|
|---|
| 187 | S @ERR@("DIERR","E",NUM,NO)=""
|
|---|
| 188 | Q NO
|
|---|
| 189 | ;
|
|---|
| 190 | GENLERR(ETXT) ; Store GENERAL (and fatal) error...
|
|---|
| 191 | ; ERR -- req
|
|---|
| 192 | N NO
|
|---|
| 193 | S NO=$G(@ERR@("DIERR"))+1,@ERR@("DIERR")=+NO_U_+NO
|
|---|
| 194 | S @ERR@("DIERR",NO)=999_U_ETXT ; Made up error number
|
|---|
| 195 | Q
|
|---|
| 196 | ;
|
|---|
| 197 | CHECKS() ; Check ROOT() for file and validity of data...
|
|---|
| 198 | ; FLAGS, ROOT() -- req --> FILE,IEN
|
|---|
| 199 | N I,OK,FIELD
|
|---|
| 200 | ;
|
|---|
| 201 | ;check the file & ien
|
|---|
| 202 | S FILE=$O(@ROOT@(0))
|
|---|
| 203 | I FILE'=772,FILE'=773 D QUIT "" ;->
|
|---|
| 204 | . S IEN=$S(FILE:$O(@ROOT@(FILE,0)),1:0) ; Set for debugging
|
|---|
| 205 | ;
|
|---|
| 206 | ; ;shouldn't be more than 1 file!
|
|---|
| 207 | QUIT:$O(@ROOT@(FILE)) "" ;->
|
|---|
| 208 | ;
|
|---|
| 209 | ;check the ien structure, and that only ien passed...
|
|---|
| 210 | S IEN=$O(@ROOT@(FILE,0))
|
|---|
| 211 | ; Structure check...
|
|---|
| 212 | QUIT:$P(IEN,",")'=+IEN_"," "" ;->
|
|---|
| 213 | ; Is it numeric?
|
|---|
| 214 | QUIT:'(+IEN) "" ;->
|
|---|
| 215 | ; Has more than one IEN been passed?
|
|---|
| 216 | QUIT:($O(@ROOT@(FILE,IEN))'="") "" ;->
|
|---|
| 217 | ;
|
|---|
| 218 | ;check the flags. Only K and S flags allowed...
|
|---|
| 219 | I $L(FLAGS) D QUIT:'OK "" ;->
|
|---|
| 220 | . S OK=1
|
|---|
| 221 | . F I=0:1:$L(FLAGS) I $E(FLAGS,I)'="K",$E(FLAGS,I)'="S" S OK=0
|
|---|
| 222 | ;
|
|---|
| 223 | ; Check for existence of FIELD in FILE's DD & if an excluded field.
|
|---|
| 224 | ; (See rules for fields which cannot be updated by FILE^HLDIE.)
|
|---|
| 225 | S FIELD=0,OK=1
|
|---|
| 226 | F S FIELD=$O(@ROOT@(FILE,IEN,FIELD)) Q:FIELD="" D Q:'OK
|
|---|
| 227 | . I '$$CHKFLD(FILE,FIELD) S OK=0 Q
|
|---|
| 228 | . I FILE=773,FIELD\1=90 S OK=0 Q
|
|---|
| 229 | . I FILE=773,FIELD\1=91 S OK=0 Q
|
|---|
| 230 | . I FILE=772,FIELD=200 S OK=0 Q
|
|---|
| 231 | ;
|
|---|
| 232 | ; If not OK to use FILE^HLDIE, skip any further testing...
|
|---|
| 233 | QUIT:'OK "" ;->
|
|---|
| 234 | ;
|
|---|
| 235 | ; *** WARNING ***
|
|---|
| 236 | ; The following check **MUST** be removed after FILE^HLDIE is working.
|
|---|
| 237 | ;
|
|---|
| 238 | ; Final check for whether FILE^HLDIE should be used...
|
|---|
| 239 | I $G(^XTMP("HLDIE-DEBUG","CALL"))]"" QUIT "" ;->
|
|---|
| 240 | ; If this node exists and follows null, FILE^DIE will be used.
|
|---|
| 241 | ; Otherwise, execution defaults to using FILE^HLDIE.
|
|---|
| 242 | ;
|
|---|
| 243 | Q OK
|
|---|
| 244 | ;
|
|---|
| 245 | BEGIN ; Always call here before any ^HLDIE or ^DIE calls...
|
|---|
| 246 | D DEBUG(1)
|
|---|
| 247 | Q
|
|---|
| 248 | ;
|
|---|
| 249 | END ; Always call here after all ^HLDIE or ^DIE actions...
|
|---|
| 250 | D DEBUG(2)
|
|---|
| 251 | Q
|
|---|
| 252 | ;
|
|---|
| 253 | DEBUG(LOC) ; Debug presets and setup...
|
|---|
| 254 | ; Most variables created here should be left around. These variables
|
|---|
| 255 | ; are newed above.
|
|---|
| 256 | N STORE
|
|---|
| 257 | ;
|
|---|
| 258 | S RTN=$G(RTN),SUB=$G(SUB)
|
|---|
| 259 | ;
|
|---|
| 260 | ; First-time (beginning) call setups...
|
|---|
| 261 | I LOC=1 D
|
|---|
| 262 | . S RTN=$S(RTN]"":RTN,1:"HLDIE")_"~"_$S(RTN="HLDIE":"FILE",1:SUB)
|
|---|
| 263 | . S DEBUG=$G(^XTMP("HLDIE-DEBUG","STATUS"))
|
|---|
| 264 | . S XECMCODE=$P(DEBUG,U,3)
|
|---|
| 265 | ; DEBUG is always called at beginning (LOC=1) and end (LOC=2) or
|
|---|
| 266 | ; FILE^HLDIE. So, set up variables only once, at beginning...
|
|---|
| 267 | ;
|
|---|
| 268 | ; Setup that is individual to each (1 or 2) call...
|
|---|
| 269 | S STORE=$P(DEBUG,U,LOC),STORE=$S(STORE=1:1,STORE=2:2,1:"")
|
|---|
| 270 | ; Some, All, or no data stored?
|
|---|
| 271 | ;
|
|---|
| 272 | ; If no STORE instructions, and no M code to specify STORE, quit...
|
|---|
| 273 | QUIT:'STORE&($G(XECMCODE)'=1) ;->
|
|---|
| 274 | ;
|
|---|
| 275 | ; Call DEBUG to STORE data...
|
|---|
| 276 | D DEBUG^HLDIEDBG(RTN,LOC,STORE,XECMCODE)
|
|---|
| 277 | ;
|
|---|
| 278 | Q
|
|---|
| 279 | ;
|
|---|
| 280 | EOR ;HLDIE - Direct 772 & 773 Sets ; 11/18/2003 11:17
|
|---|
