Index: WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLDIE.m
===================================================================
--- WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLDIE.m	(revision 613)
+++ WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLDIE.m	(revision 623)
@@ -1,280 +1,262 @@
-HLDIE	;CIOFO-O/LJA - Direct 772 & 773 Sets ; 10/19/2007 11:15
-	;;1.6;HEALTH LEVEL SEVEN;**109,122**;Oct 13,1995;Build 14
-	;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
-	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*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
-	;
-	; 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)
-	;
-	; patch HL*1.6*122: MPI-client/server
-	I FILE=773 L -^HLMA(IEN)
-	E  L -^HL(772,IEN)
-	;
-	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
+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
