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