XBNEW.m

XBNEW(XBRET) ; IHS/ADC/GTH - NESTING OF DIE ; [ 10/29/2002   7:42 AM ]

 ;;3.0;IHS/VA UTILITIES;**9**;FEB 07, 1997

 ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Unwinder problem with NEW'ing

 ;

 ;  PROGRAMMERS:  DO NOT USE THE FIRST LINE FOR ENTRY.

 ;                USE LABEL EN^XBNEW() FOR ENTRY.

 ;

 ; EN^XBNEW("TAG^ROUTINE","variable list")

 ;

 ; Variable list has the form "AGDFN;AGINS;AGP*".

 ; Wild card * allowed.

 ; 

 ; XBRET has the form "TAG^ROUTINE:VAR;NSVAR*"

 ;

 ; This allows for the nesting of die calls by

 ;

 ; 1. Building and executing an exclusive new from preselected

 ;    kernel variables and any local variables &/or name

 ;    spaces identified by the calling parameter.

 ;

 ; 2. After executing the new (....) XBNEW performs a DO call

 ;    to the program entry point identified by the calling

 ;    parameter.  The entry point passed should build the

 ;    variables and execute the DIE call to be nested.

 ;

 ; 3. As XBNEW quits to return to the calling program it pops

 ;    the variable stack.

 ;

 ;

 NEW XB,XBNS,XBN,XB,XBY,XBL,XBKVAR

 G S

 ;

EN(XBRT,XBNS) ;PEP XBRT=TAG^ROUTINE  XBNS=varialbe list ";" with * allowed

 NEW XB,XBN,XB,XBY,XBL,XBKVAR,XBRET

 S XBRET=XBRT_":"_XBNS

S ;

 I XBRET'[":" S XBRET=XBRET_":"

 S XBN="XBRET",XBKVAR=$P($T(XBKVAR),";;",2),XBNS=$P(XBRET,":",2)

 I XBNS="" G RETURN

 F XBI=1:1 S (XB,XBY)=$P(XBNS,";",XBI) Q:XB=""  D

 . I XB'["*" S XBN=XBN_","_XB Q

 . S (XB,XBY)=$P(XB,"*"),XBN=XBN_","_XB,XBL=$L(XB)

 . F  S XBY=$O(@XBY) Q:((XBY="")!(XB'=$E(XBY,1,XBL)))  S XBN=XBN_","_XBY

 .Q

RETURN ;

 S XBN="("_XBN_","_XBKVAR_")",$P(XBRET,":",2)=XBN

NEW ;

 NEW @($P(XBRET,":",2))

 D @($P(XBRET,":",1))

 Q

 ;

END ;--------------------------------------------------------------

 ; the following taken from the variable list in KILL^XUSCLEAN from  KERNEL

XBKVAR ;;DUZ,DTIME,DT,DISYS,IO,IOBS,IOF,IOM,ION,IOSL,IOST,IOT,IOS,IOXY,U,XRTL,%ZH0,XQVOL,XQY,XQY0,XQDIC,XQPSM,XQPT,XQAUDIT,XQXFLG,ZTSTOP,ZTQUEUED,ZTREQ,XQORS;; IHS/SET/GTH XB*3*9 10/29/2002

 ;;DUZ,DTIME,DT,DISYS,IO,IOF,IOBS,IOM,ION,IOSL,IOST,IOT,IOS,IOXY,U,XRTL,ZTSTOP,ZTQUEUED,ZTREQ ; IHS/SET/GTH XB*3*9 10/29/2002

 ;-------------------------------------------------------------- 

 Q

 ;

XBNEW(XBRET) ; IHS/ADC/GTH - NESTING OF DIE ; [ 10/29/2002   7:42 AM ]

 +1       ;;3.0;IHS/VA UTILITIES;**9**;FEB 07, 1997

 +2       ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Unwinder problem with NEW'ing

 +3       ;

 +4       ;  PROGRAMMERS:  DO NOT USE THE FIRST LINE FOR ENTRY.

 +5       ;                USE LABEL EN^XBNEW() FOR ENTRY.

 +6       ;

 +7       ; EN^XBNEW("TAG^ROUTINE","variable list")

 +8       ;

 +9       ; Variable list has the form "AGDFN;AGINS;AGP*".

 +10      ; Wild card * allowed.

 +11      ; 

 +12      ; XBRET has the form "TAG^ROUTINE:VAR;NSVAR*"

 +13      ;

 +14      ; This allows for the nesting of die calls by

 +15      ;

 +16      ; 1. Building and executing an exclusive new from preselected

 +17      ;    kernel variables and any local variables &/or name

 +18      ;    spaces identified by the calling parameter.

 +19      ;

 +20      ; 2. After executing the new (....) XBNEW performs a DO call

 +21      ;    to the program entry point identified by the calling

 +22      ;    parameter.  The entry point passed should build the

 +23      ;    variables and execute the DIE call to be nested.

 +24      ;

 +25      ; 3. As XBNEW quits to return to the calling program it pops

 +26      ;    the variable stack.

 +27      ;

 +28      ;

 +29       NEW XB,XBNS,XBN,XB,XBY,XBL,XBKVAR

 +30       GOTO S

 +31      ;

EN(XBRT,XBNS) ;PEP XBRT=TAG^ROUTINE  XBNS=varialbe list ";" with * allowed

 +1        NEW XB,XBN,XB,XBY,XBL,XBKVAR,XBRET

 +2        SET XBRET=XBRT_":"_XBNS

S         ;

 +1        IF XBRET'[":"

               SET XBRET=XBRET_":"

 +2        SET XBN="XBRET"

           SET XBKVAR=$PIECE($TEXT(XBKVAR),";;",2)

           SET XBNS=$PIECE(XBRET,":",2)

 +3        IF XBNS=""

               GOTO RETURN

 +4        FOR XBI=1:1

               SET (XB,XBY)=$PIECE(XBNS,";",XBI)

               IF XB=""

                   QUIT 

               Begin DoDot:1

 +5                IF XB'["*"

                       SET XBN=XBN_","_XB

                       QUIT 

 +6                SET (XB,XBY)=$PIECE(XB,"*")

                   SET XBN=XBN_","_XB

                   SET XBL=$LENGTH(XB)

 +7                FOR 

                       SET XBY=$ORDER(@XBY)

                       IF ((XBY="")!(XB'=$EXTRACT(XBY,1,XBL)))

                           QUIT 

                       SET XBN=XBN_","_XBY

 +8                QUIT 

               End DoDot:1

RETURN    ;

 +1        SET XBN="("_XBN_","_XBKVAR_")"

           SET $PIECE(XBRET,":",2)=XBN

NEW       ;

 +1        NEW @($PIECE(XBRET,":",2))

 +2        DO @($PIECE(XBRET,":",1))

 +3        QUIT 

 +4       ;

END       ;--------------------------------------------------------------

 +1       ; the following taken from the variable list in KILL^XUSCLEAN from  KERNEL

XBKVAR    ;;DUZ,DTIME,DT,DISYS,IO,IOBS,IOF,IOM,ION,IOSL,IOST,IOT,IOS,IOXY,U,XRTL,%ZH0,XQVOL,XQY,XQY0,XQDIC,XQPSM,XQPT,XQAUDIT,XQXFLG,ZTSTOP,ZTQUEUED,ZTREQ,XQORS;; IHS/SET/GTH XB*3*9 10/29/2002

 +1       ;;DUZ,DTIME,DT,DISYS,IO,IOF,IOBS,IOM,ION,IOSL,IOST,IOT,IOS,IOXY,U,XRTL,ZTSTOP,ZTQUEUED,ZTREQ ; IHS/SET/GTH XB*3*9 10/29/2002

 +2       ;-------------------------------------------------------------- 

 +3        QUIT 

 +4       ;