ECOB ;BP/CMF - base object ;8/21/2015
;;2.0;EVENT CAPTURE;**100,107,110,129**;8 May 96;Build 7
;@author - Chris Flegel
;@date - 17 May 2009
;@version - 1.0
;;
Q
;; private methods
COUNT(NAME) ; increment counter
N COUNT
S COUNT=+$O(@NAME@(9999999),-1)+1
S @NAME@(COUNT,0)=$G(DT)+1
Q COUNT
;;
PARSE(METHOD,VALUE) ;
I METHOD="Argument" D Q
.S HANDLE=$P(VALUE,".")
.Q
I METHOD="Child" D Q
.S CHILD=$P(VALUE,"Handle.",2)
.Q
I METHOD="Handle" D Q
.S NAME=$P(VALUE,".",1)
.S COUNT=$P(VALUE,".",2)
.Q
I METHOD="Tag" D Q
.S TAG("routine")=$P(VALUE,"(")
.S TAG("parameters")=$P(VALUE,TAG("routine"),2)
.Q
;;
;; protected methods
CREATE(NAME) ; return unique handle
N HANDLE
S NAME=$TR(NAME,".","") ;reserve period for piecers
S HANDLE=$TR(NAME,")","")_","_$$COUNT(NAME)_")"
D PROPERTY(HANDLE,"Pu","_class","EC BASE")
D PROPERTY(HANDLE,"Pu","_routine","METHOD^DGOB(.RESULT,ARGUMENT)")
D PROPERTY(HANDLE,"Pu","_name","Basic Pharmacy Object")
D PROPERTY(HANDLE,"Pu","_namespace",NAME)
D PROPERTY(HANDLE,"Pr","_parent","")
Q HANDLE
;;
COLLECT(HANDLE,CHILD,SCOPE,PROPERTY) ; attach or collect child objects
S SCOPE=$S($G(SCOPE)'="":SCOPE,1:"Pu")
S PROPERTY=$S($G(PROPERTY)'="":PROPERTY,1:"-1")
S @HANDLE@(SCOPE,PROPERTY)=CHILD
S @HANDLE@("Pr","Handle",CHILD)=PROPERTY
Q 1
;;
DESTROY(HANDLE) ; cleanup
N CHILD
S CHILD=0
I ($G(HANDLE)="") Q 1 ;EC*129
I ($P(HANDLE,"^")=0)!($P(HANDLE,"^")=-1) Q 1 ;EC*129
F S CHILD=$O(@HANDLE@("Pr","Handle",CHILD)) Q:'CHILD D
.K @CHILD
.Q
K @HANDLE
Q 1
;;
FUNCTION(HANDLE,ARGUMENT) ;
N RESULT
D METHOD(.RESULT,HANDLE_"."_ARGUMENT)
Q RESULT
;;
GET(RESULT,HANDLE,SCOPE,PROPERTY) ; get simple property
I $G(HANDLE)="" S RESULT="-1^Handle does not exist." Q ;EC*110 - BGP
I ($P(HANDLE,"^")=0)!($P(HANDLE,"^")=-1) S RESULT="-1^Handle does not exist." Q ;EC*129 - JAM
I ($P(HANDLE,"^",2)="") S RESULT="-1^Invalid handle." Q ;EC*129
I '$D(@HANDLE) S RESULT="-1^No data at handle: "_HANDLE_"." Q ;EC*110
S SCOPE=$S($G(SCOPE)'="":SCOPE,1:"Pu")
S PROPERTY=$S($G(PROPERTY)'="":PROPERTY,1:"-1")
S RESULT=$G(@HANDLE@(SCOPE,PROPERTY))
S:$D(RESULT)=0 RESULT="-1^Property "_PROPERTY_" does not exist."
Q
;;
ISHANDLE(HANDLE,CHILD) ;
S HANDLE=$S($G(HANDLE)'="":HANDLE,1:-1)
S CHILD=$S($G(CHILD)'="":CHILD,1:-1)
Q $D(@HANDLE@("Pr","Handle",CHILD))
;;
METHOD(RESULT,ARGUMENT) ; most basic handler
N HANDLE,TAG
S RESULT=-1
D PARSE("Argument",ARGUMENT)
D GET(.TAG,HANDLE,"Pu","_routine")
D PARSE("Tag",TAG)
Q:TAG("routine")="METHOD^DGOB" ;stop recursive call
Q:TAG("routine")=""
Q:($P(TAG("routine"),"^")=0)!($P(TAG("routine"),"^")=-1) ;EC*129
I $T(@TAG("routine"))'="" D Q
.I TAG("parameters")="(.RESULT,ARGUMENT)" D @TAG
Q
;;
MOVE(RESULT,HANDLE,SOURCE,SCOPE,PROPERTY) ;copy simple object property to another
N X
D GET(.X,SOURCE,SCOPE,PROPERTY)
D SET(.RESULT,HANDLE,SCOPE,PROPERTY,X)
Q
;;
PROPERTY(HANDLE,SCOPE,PROPERTY,VALUE) ; create simple property node
S HANDLE=$S($G(HANDLE)'="":HANDLE,1:-1)
S SCOPE=$S($G(SCOPE)'="":SCOPE,1:"Pu")
S PROPERTY=$S($G(PROPERTY)'="":PROPERTY,1:-1)
S @HANDLE@(SCOPE,PROPERTY)=$G(VALUE)
Q 1
;;
SELF(RESULT,HANDLE,CLASS,NAME,ROUTINE,PARENT) ; set 'self' properties of object
N RESULT
D:CLASS'="" SET(.RESULT,HANDLE,"Pu","_class",CLASS)
D:NAME'="" SET(.RESULT,HANDLE,"Pu","_name",NAME)
D:ROUTINE'="" SET(.RESULT,HANDLE,"Pu","_routine",ROUTINE)
D:PARENT'="" SET(.RESULT,HANDLE,"Pr","_parent",PARENT)
Q
;;
SET(RESULT,HANDLE,SCOPE,PROPERTY,VALUE) ; set simple property
I $G(HANDLE)="" S RESULT="-1^Handle does not exist" Q ;EC*110
I ($P(HANDLE,"^")=0)!($P(HANDLE,"^")=-1) S RESULT="-1^Handle does not exist." Q ;EC*129
I '$D(@HANDLE) S RESULT="-1^No data at handle: "_HANDLE_"." Q ;EC*110
S SCOPE=$S($G(SCOPE)'="":SCOPE,1:"Pu")
S PROPERTY=$S($G(PROPERTY)'="":PROPERTY,1:"-1")
I '$D(@HANDLE@(SCOPE,PROPERTY)) D Q
.S RESULT="-1^Property "_PROPERTY_" does not exist."
S @HANDLE@(SCOPE,PROPERTY)=VALUE
S RESULT=1
Q
;;
SHOW(RESULT,HANDLE,SCOPE,PROPERTY,PARAMS) ; show a property
N JUSTIFY,CHILD,CLASS
D GET(.RESULT,HANDLE,SCOPE,PROPERTY)
S JUSTIFY=$S(+PARAMS:+PARAMS,1:0)
I PARAMS["/" W !,$J("</"_PROPERTY_"> ",JUSTIFY) Q
W !,$J("<"_PROPERTY_"> : ",JUSTIFY),RESULT
D:$$ISHANDLE(HANDLE,RESULT)
.S CHILD=RESULT
.D GET(.CLASS,CHILD,"Pu","_class")
.W " [class = "_CLASS_"]"
Q
;;
TREE(CHILD,HANDLE,SCOPE,PROPERTY,JUSTIFY) Q ; no longer used
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECOB 4548 printed Oct 16, 2024@17:58:37 Page 2
ECOB ;BP/CMF - base object ;8/21/2015
+1 ;;2.0;EVENT CAPTURE;**100,107,110,129**;8 May 96;Build 7
+2 ;@author - Chris Flegel
+3 ;@date - 17 May 2009
+4 ;@version - 1.0
+5 ;;
+6 QUIT
+7 ;; private methods
COUNT(NAME) ; increment counter
+1 NEW COUNT
+2 SET COUNT=+$ORDER(@NAME@(9999999),-1)+1
+3 SET @NAME@(COUNT,0)=$GET(DT)+1
+4 QUIT COUNT
+5 ;;
PARSE(METHOD,VALUE) ;
+1 IF METHOD="Argument"
Begin DoDot:1
+2 SET HANDLE=$PIECE(VALUE,".")
+3 QUIT
End DoDot:1
QUIT
+4 IF METHOD="Child"
Begin DoDot:1
+5 SET CHILD=$PIECE(VALUE,"Handle.",2)
+6 QUIT
End DoDot:1
QUIT
+7 IF METHOD="Handle"
Begin DoDot:1
+8 SET NAME=$PIECE(VALUE,".",1)
+9 SET COUNT=$PIECE(VALUE,".",2)
+10 QUIT
End DoDot:1
QUIT
+11 IF METHOD="Tag"
Begin DoDot:1
+12 SET TAG("routine")=$PIECE(VALUE,"(")
+13 SET TAG("parameters")=$PIECE(VALUE,TAG("routine"),2)
+14 QUIT
End DoDot:1
QUIT
+15 ;;
+16 ;; protected methods
CREATE(NAME) ; return unique handle
+1 NEW HANDLE
+2 ;reserve period for piecers
SET NAME=$TRANSLATE(NAME,".","")
+3 SET HANDLE=$TRANSLATE(NAME,")","")_","_$$COUNT(NAME)_")"
+4 DO PROPERTY(HANDLE,"Pu","_class","EC BASE")
+5 DO PROPERTY(HANDLE,"Pu","_routine","METHOD^DGOB(.RESULT,ARGUMENT)")
+6 DO PROPERTY(HANDLE,"Pu","_name","Basic Pharmacy Object")
+7 DO PROPERTY(HANDLE,"Pu","_namespace",NAME)
+8 DO PROPERTY(HANDLE,"Pr","_parent","")
+9 QUIT HANDLE
+10 ;;
COLLECT(HANDLE,CHILD,SCOPE,PROPERTY) ; attach or collect child objects
+1 SET SCOPE=$SELECT($GET(SCOPE)'="":SCOPE,1:"Pu")
+2 SET PROPERTY=$SELECT($GET(PROPERTY)'="":PROPERTY,1:"-1")
+3 SET @HANDLE@(SCOPE,PROPERTY)=CHILD
+4 SET @HANDLE@("Pr","Handle",CHILD)=PROPERTY
+5 QUIT 1
+6 ;;
DESTROY(HANDLE) ; cleanup
+1 NEW CHILD
+2 SET CHILD=0
+3 ;EC*129
IF ($GET(HANDLE)="")
QUIT 1
+4 ;EC*129
IF ($PIECE(HANDLE,"^")=0)!($PIECE(HANDLE,"^")=-1)
QUIT 1
+5 FOR
SET CHILD=$ORDER(@HANDLE@("Pr","Handle",CHILD))
if 'CHILD
QUIT
Begin DoDot:1
+6 KILL @CHILD
+7 QUIT
End DoDot:1
+8 KILL @HANDLE
+9 QUIT 1
+10 ;;
FUNCTION(HANDLE,ARGUMENT) ;
+1 NEW RESULT
+2 DO METHOD(.RESULT,HANDLE_"."_ARGUMENT)
+3 QUIT RESULT
+4 ;;
GET(RESULT,HANDLE,SCOPE,PROPERTY) ; get simple property
+1 ;EC*110 - BGP
IF $GET(HANDLE)=""
SET RESULT="-1^Handle does not exist."
QUIT
+2 ;EC*129 - JAM
IF ($PIECE(HANDLE,"^")=0)!($PIECE(HANDLE,"^")=-1)
SET RESULT="-1^Handle does not exist."
QUIT
+3 ;EC*129
IF ($PIECE(HANDLE,"^",2)="")
SET RESULT="-1^Invalid handle."
QUIT
+4 ;EC*110
IF '$DATA(@HANDLE)
SET RESULT="-1^No data at handle: "_HANDLE_"."
QUIT
+5 SET SCOPE=$SELECT($GET(SCOPE)'="":SCOPE,1:"Pu")
+6 SET PROPERTY=$SELECT($GET(PROPERTY)'="":PROPERTY,1:"-1")
+7 SET RESULT=$GET(@HANDLE@(SCOPE,PROPERTY))
+8 if $DATA(RESULT)=0
SET RESULT="-1^Property "_PROPERTY_" does not exist."
+9 QUIT
+10 ;;
ISHANDLE(HANDLE,CHILD) ;
+1 SET HANDLE=$SELECT($GET(HANDLE)'="":HANDLE,1:-1)
+2 SET CHILD=$SELECT($GET(CHILD)'="":CHILD,1:-1)
+3 QUIT $DATA(@HANDLE@("Pr","Handle",CHILD))
+4 ;;
METHOD(RESULT,ARGUMENT) ; most basic handler
+1 NEW HANDLE,TAG
+2 SET RESULT=-1
+3 DO PARSE("Argument",ARGUMENT)
+4 DO GET(.TAG,HANDLE,"Pu","_routine")
+5 DO PARSE("Tag",TAG)
+6 ;stop recursive call
if TAG("routine")="METHOD^DGOB"
QUIT
+7 if TAG("routine")=""
QUIT
+8 ;EC*129
if ($PIECE(TAG("routine"),"^")=0)!($PIECE(TAG("routine"),"^")=-1)
QUIT
+9 IF $TEXT(@TAG("routine"))'=""
Begin DoDot:1
+10 IF TAG("parameters")="(.RESULT,ARGUMENT)"
DO @TAG
End DoDot:1
QUIT
+11 QUIT
+12 ;;
MOVE(RESULT,HANDLE,SOURCE,SCOPE,PROPERTY) ;copy simple object property to another
+1 NEW X
+2 DO GET(.X,SOURCE,SCOPE,PROPERTY)
+3 DO SET(.RESULT,HANDLE,SCOPE,PROPERTY,X)
+4 QUIT
+5 ;;
PROPERTY(HANDLE,SCOPE,PROPERTY,VALUE) ; create simple property node
+1 SET HANDLE=$SELECT($GET(HANDLE)'="":HANDLE,1:-1)
+2 SET SCOPE=$SELECT($GET(SCOPE)'="":SCOPE,1:"Pu")
+3 SET PROPERTY=$SELECT($GET(PROPERTY)'="":PROPERTY,1:-1)
+4 SET @HANDLE@(SCOPE,PROPERTY)=$GET(VALUE)
+5 QUIT 1
+6 ;;
SELF(RESULT,HANDLE,CLASS,NAME,ROUTINE,PARENT) ; set 'self' properties of object
+1 NEW RESULT
+2 if CLASS'=""
DO SET(.RESULT,HANDLE,"Pu","_class",CLASS)
+3 if NAME'=""
DO SET(.RESULT,HANDLE,"Pu","_name",NAME)
+4 if ROUTINE'=""
DO SET(.RESULT,HANDLE,"Pu","_routine",ROUTINE)
+5 if PARENT'=""
DO SET(.RESULT,HANDLE,"Pr","_parent",PARENT)
+6 QUIT
+7 ;;
SET(RESULT,HANDLE,SCOPE,PROPERTY,VALUE) ; set simple property
+1 ;EC*110
IF $GET(HANDLE)=""
SET RESULT="-1^Handle does not exist"
QUIT
+2 ;EC*129
IF ($PIECE(HANDLE,"^")=0)!($PIECE(HANDLE,"^")=-1)
SET RESULT="-1^Handle does not exist."
QUIT
+3 ;EC*110
IF '$DATA(@HANDLE)
SET RESULT="-1^No data at handle: "_HANDLE_"."
QUIT
+4 SET SCOPE=$SELECT($GET(SCOPE)'="":SCOPE,1:"Pu")
+5 SET PROPERTY=$SELECT($GET(PROPERTY)'="":PROPERTY,1:"-1")
+6 IF '$DATA(@HANDLE@(SCOPE,PROPERTY))
Begin DoDot:1
+7 SET RESULT="-1^Property "_PROPERTY_" does not exist."
End DoDot:1
QUIT
+8 SET @HANDLE@(SCOPE,PROPERTY)=VALUE
+9 SET RESULT=1
+10 QUIT
+11 ;;
SHOW(RESULT,HANDLE,SCOPE,PROPERTY,PARAMS) ; show a property
+1 NEW JUSTIFY,CHILD,CLASS
+2 DO GET(.RESULT,HANDLE,SCOPE,PROPERTY)
+3 SET JUSTIFY=$SELECT(+PARAMS:+PARAMS,1:0)
+4 IF PARAMS["/"
WRITE !,$JUSTIFY("</"_PROPERTY_"> ",JUSTIFY)
QUIT
+5 WRITE !,$JUSTIFY("<"_PROPERTY_"> : ",JUSTIFY),RESULT
+6 if $$ISHANDLE(HANDLE,RESULT)
Begin DoDot:1
+7 SET CHILD=RESULT
+8 DO GET(.CLASS,CHILD,"Pu","_class")
+9 WRITE " [class = "_CLASS_"]"
End DoDot:1
+10 QUIT
+11 ;;
TREE(CHILD,HANDLE,SCOPE,PROPERTY,JUSTIFY) ; no longer used
QUIT
