TIUDDT ; SLC/JM - XRef & Input Transform code for Template File #8927;8/23/2001
;;1.0;TEXT INTEGRATION UTILITIES;**76,119,125**;Jun 20, 1997
;
; Input Transform functions return true if the field value is bad
;
BADTYPE(X,DA) ;Input Transform for .03 TYPE field
N BAD,NODE
S BAD=0,NODE=$$GETNODE()
I $P(NODE,U,4)="A" D
.I $$ISROOT(X) S BAD=$$BADROOT(DA,X)
.I X="P" S BAD=$$BADPROOT(DA,$P(NODE,U,6))
Q BAD
;
BADSTS(X,DA) ;Input Transform for .04 STATUS Field
N BAD,NODE,TYPE
S BAD=0
I X="A" D
.S NODE=$$GETNODE()
.S TYPE=$P(NODE,U,3)
.I $$ISROOT(TYPE) S BAD=$$BADROOT(DA,TYPE)
.I TYPE="P" S BAD=$$BADPROOT(DA,$P(NODE,U,6))
Q BAD
;
BADOWNER(X,DA) ;Input Transform for .06 PERSONAL OWNER Field
N BAD,NODE,ROOT,TYPE
S BAD=0
I +X D
.S NODE=$$GETNODE()
.I $P(NODE,U,3)="P",$P(NODE,U,4)="A" S BAD=$$BADPROOT(DA,X)
.I 'BAD D
..F TYPE="R","TF","CF","OF" D Q:+BAD
...S ROOT=$O(^TIU(8927,"AROOT",$$ROOTIDX(TYPE),0))
...I +ROOT S BAD='$$PARENTOK(DA,ROOT)
Q BAD
;
BADITEM(X,DA1) ;Input Transform for ITEMS .02 ITEM Field
Q '$$PARENTOK(DA1,X)
;
; Field Cross Reference Routines
;
TYPESETR(X,DA) ; .03 TYPE Field "AROOT" and "AP" XRef Set Logic
N NODE,OWNER
S NODE=$$GETNODE()
I $P(NODE,U,4)="A" D
.I $$ISROOT(X),'$$BADROOT(DA,X) D
..S ^TIU(8927,"AROOT",$$ROOTIDX(X),DA)=""
.I X="P" D
..S OWNER=$P(NODE,U,6)
..I '$$BADPROOT(DA,OWNER) D
...S ^TIU(8927,"AROOT",OWNER,DA)=""
Q
;
TYPEKILR(X,DA) ; .03 TYPE Field "AROOT" and "AP" XRef Kill Logic
N NODE,OWNER
I $$ISROOT(X) K ^TIU(8927,"AROOT",$$ROOTIDX(X),DA)
I X="P" D
.S NODE=$$GETNODE()
.S OWNER=$P(NODE,U,6)
.I +OWNER K ^TIU(8927,"AROOT",OWNER,DA)
Q
;
STSSETR(X,DA) ; .04 STATUS Field "AROOT" and "AP" XRef Set Logic
N NODE,TYPE,OWNER
I X="A" D
.S NODE=$$GETNODE()
.S TYPE=$P(NODE,U,3)
.I $$ISROOT(TYPE),'$$BADROOT(DA,TYPE) D
..S ^TIU(8927,"AROOT",$$ROOTIDX(TYPE),DA)=""
.I TYPE="P" D
..S OWNER=$P(NODE,U,6)
..I +OWNER,'$$BADPROOT(DA,OWNER) D
...S ^TIU(8927,"AROOT",OWNER,DA)=""
Q
;
STSKILLR(X,DA) ; .04 STATUS Field "AROOT" XRef Kill Logic
N NODE,TYPE,OWNER
S NODE=$$GETNODE()
S TYPE=$P(NODE,U,3)
I $$ISROOT(TYPE) K ^TIU(8927,"AROOT",$$ROOTIDX(TYPE),DA)
I TYPE="P" D
.S OWNER=$P(NODE,U,6)
.I +OWNER K ^TIU(8927,"AROOT",OWNER,DA)
Q
;
OWNRSETR(X,DA) ; .06 OWNER Field "AROOT" XRef Set Logic
N NODE
I +X D
.S NODE=$$GETNODE()
.I $P(NODE,U,4)="A",$P(NODE,U,3)="P",'$$BADPROOT(DA,X) D
..S ^TIU(8927,"AROOT",X,DA)=""
Q
;
OWNRKILR(X,DA) ; .06 OWNER Field "AROOT" XRef Kill Logic
I +X K ^TIU(8927,"AROOT",X,DA)
Q
BADLINK(X,DA) ;Input Transform for .19 LINK field
N BAD,IDX
S BAD=0
S IDX=$O(^TIU(8927,"AL",X,0))
I +IDX,IDX'=DA S BAD=1
Q BAD
;
; Internal Routines
;
GETNODE() ; Sets NODE variable
Q $G(^TIU(8927,DA,0))
;
BADROOT(DA,TIUTYPE) ; Returns True if there is another root
N CURROOT,BAD
S BAD=0
S CURROOT=$O(^TIU(8927,"AROOT",$$ROOTIDX(TIUTYPE),0))
I +CURROOT,CURROOT'=DA S BAD=1
Q BAD
;
BADPROOT(DA,OWNER) ; Returns True if there is another personal root
N CURROOT,BAD
S BAD=0
I +OWNER D
.S CURROOT=$O(^TIU(8927,"AROOT",OWNER,0))
.I +CURROOT,CURROOT'=DA S BAD=1
Q BAD
;
PARENTOK(PARENT,ITEM) ; Returns True if ITEM is not in it's own parent list
N IDX,OK
S IDX=0,OK=1
F S IDX=$O(^TIU(8927,"AD",PARENT,IDX)) Q:'IDX D Q:'OK
.I IDX=ITEM S OK=0
.E S OK=$$PARENTOK(IDX,ITEM)
Q OK
ISROOT(TYPE) ; Returns TRUE if TYPE is a valid root folder type
Q $S(TYPE="R":1,TYPE="TF":1,TYPE="CF":1,TYPE="OF":1,1:0)
ROOTIDX(TYPE) ; Returns "AROOT" Index value for root types
Q $S(TYPE="R":"ROOT",TYPE="TF":"TITLES",TYPE="CF":"CONSULTS",TYPE="OF":"PROCEDURES",1:"")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUDDT 3731 printed Oct 16, 2024@18:40:21 Page 2
TIUDDT ; SLC/JM - XRef & Input Transform code for Template File #8927;8/23/2001
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**76,119,125**;Jun 20, 1997
+2 ;
+3 ; Input Transform functions return true if the field value is bad
+4 ;
BADTYPE(X,DA) ;Input Transform for .03 TYPE field
+1 NEW BAD,NODE
+2 SET BAD=0
SET NODE=$$GETNODE()
+3 IF $PIECE(NODE,U,4)="A"
Begin DoDot:1
+4 IF $$ISROOT(X)
SET BAD=$$BADROOT(DA,X)
+5 IF X="P"
SET BAD=$$BADPROOT(DA,$PIECE(NODE,U,6))
End DoDot:1
+6 QUIT BAD
+7 ;
BADSTS(X,DA) ;Input Transform for .04 STATUS Field
+1 NEW BAD,NODE,TYPE
+2 SET BAD=0
+3 IF X="A"
Begin DoDot:1
+4 SET NODE=$$GETNODE()
+5 SET TYPE=$PIECE(NODE,U,3)
+6 IF $$ISROOT(TYPE)
SET BAD=$$BADROOT(DA,TYPE)
+7 IF TYPE="P"
SET BAD=$$BADPROOT(DA,$PIECE(NODE,U,6))
End DoDot:1
+8 QUIT BAD
+9 ;
BADOWNER(X,DA) ;Input Transform for .06 PERSONAL OWNER Field
+1 NEW BAD,NODE,ROOT,TYPE
+2 SET BAD=0
+3 IF +X
Begin DoDot:1
+4 SET NODE=$$GETNODE()
+5 IF $PIECE(NODE,U,3)="P"
IF $PIECE(NODE,U,4)="A"
SET BAD=$$BADPROOT(DA,X)
+6 IF 'BAD
Begin DoDot:2
+7 FOR TYPE="R","TF","CF","OF"
Begin DoDot:3
+8 SET ROOT=$ORDER(^TIU(8927,"AROOT",$$ROOTIDX(TYPE),0))
+9 IF +ROOT
SET BAD='$$PARENTOK(DA,ROOT)
End DoDot:3
if +BAD
QUIT
End DoDot:2
End DoDot:1
+10 QUIT BAD
+11 ;
BADITEM(X,DA1) ;Input Transform for ITEMS .02 ITEM Field
+1 QUIT '$$PARENTOK(DA1,X)
+2 ;
+3 ; Field Cross Reference Routines
+4 ;
TYPESETR(X,DA) ; .03 TYPE Field "AROOT" and "AP" XRef Set Logic
+1 NEW NODE,OWNER
+2 SET NODE=$$GETNODE()
+3 IF $PIECE(NODE,U,4)="A"
Begin DoDot:1
+4 IF $$ISROOT(X)
IF '$$BADROOT(DA,X)
Begin DoDot:2
+5 SET ^TIU(8927,"AROOT",$$ROOTIDX(X),DA)=""
End DoDot:2
+6 IF X="P"
Begin DoDot:2
+7 SET OWNER=$PIECE(NODE,U,6)
+8 IF '$$BADPROOT(DA,OWNER)
Begin DoDot:3
+9 SET ^TIU(8927,"AROOT",OWNER,DA)=""
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
TYPEKILR(X,DA) ; .03 TYPE Field "AROOT" and "AP" XRef Kill Logic
+1 NEW NODE,OWNER
+2 IF $$ISROOT(X)
KILL ^TIU(8927,"AROOT",$$ROOTIDX(X),DA)
+3 IF X="P"
Begin DoDot:1
+4 SET NODE=$$GETNODE()
+5 SET OWNER=$PIECE(NODE,U,6)
+6 IF +OWNER
KILL ^TIU(8927,"AROOT",OWNER,DA)
End DoDot:1
+7 QUIT
+8 ;
STSSETR(X,DA) ; .04 STATUS Field "AROOT" and "AP" XRef Set Logic
+1 NEW NODE,TYPE,OWNER
+2 IF X="A"
Begin DoDot:1
+3 SET NODE=$$GETNODE()
+4 SET TYPE=$PIECE(NODE,U,3)
+5 IF $$ISROOT(TYPE)
IF '$$BADROOT(DA,TYPE)
Begin DoDot:2
+6 SET ^TIU(8927,"AROOT",$$ROOTIDX(TYPE),DA)=""
End DoDot:2
+7 IF TYPE="P"
Begin DoDot:2
+8 SET OWNER=$PIECE(NODE,U,6)
+9 IF +OWNER
IF '$$BADPROOT(DA,OWNER)
Begin DoDot:3
+10 SET ^TIU(8927,"AROOT",OWNER,DA)=""
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
STSKILLR(X,DA) ; .04 STATUS Field "AROOT" XRef Kill Logic
+1 NEW NODE,TYPE,OWNER
+2 SET NODE=$$GETNODE()
+3 SET TYPE=$PIECE(NODE,U,3)
+4 IF $$ISROOT(TYPE)
KILL ^TIU(8927,"AROOT",$$ROOTIDX(TYPE),DA)
+5 IF TYPE="P"
Begin DoDot:1
+6 SET OWNER=$PIECE(NODE,U,6)
+7 IF +OWNER
KILL ^TIU(8927,"AROOT",OWNER,DA)
End DoDot:1
+8 QUIT
+9 ;
OWNRSETR(X,DA) ; .06 OWNER Field "AROOT" XRef Set Logic
+1 NEW NODE
+2 IF +X
Begin DoDot:1
+3 SET NODE=$$GETNODE()
+4 IF $PIECE(NODE,U,4)="A"
IF $PIECE(NODE,U,3)="P"
IF '$$BADPROOT(DA,X)
Begin DoDot:2
+5 SET ^TIU(8927,"AROOT",X,DA)=""
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
OWNRKILR(X,DA) ; .06 OWNER Field "AROOT" XRef Kill Logic
+1 IF +X
KILL ^TIU(8927,"AROOT",X,DA)
+2 QUIT
BADLINK(X,DA) ;Input Transform for .19 LINK field
+1 NEW BAD,IDX
+2 SET BAD=0
+3 SET IDX=$ORDER(^TIU(8927,"AL",X,0))
+4 IF +IDX
IF IDX'=DA
SET BAD=1
+5 QUIT BAD
+6 ;
+7 ; Internal Routines
+8 ;
GETNODE() ; Sets NODE variable
+1 QUIT $GET(^TIU(8927,DA,0))
+2 ;
BADROOT(DA,TIUTYPE) ; Returns True if there is another root
+1 NEW CURROOT,BAD
+2 SET BAD=0
+3 SET CURROOT=$ORDER(^TIU(8927,"AROOT",$$ROOTIDX(TIUTYPE),0))
+4 IF +CURROOT
IF CURROOT'=DA
SET BAD=1
+5 QUIT BAD
+6 ;
BADPROOT(DA,OWNER) ; Returns True if there is another personal root
+1 NEW CURROOT,BAD
+2 SET BAD=0
+3 IF +OWNER
Begin DoDot:1
+4 SET CURROOT=$ORDER(^TIU(8927,"AROOT",OWNER,0))
+5 IF +CURROOT
IF CURROOT'=DA
SET BAD=1
End DoDot:1
+6 QUIT BAD
+7 ;
PARENTOK(PARENT,ITEM) ; Returns True if ITEM is not in it's own parent list
+1 NEW IDX,OK
+2 SET IDX=0
SET OK=1
+3 FOR
SET IDX=$ORDER(^TIU(8927,"AD",PARENT,IDX))
if 'IDX
QUIT
Begin DoDot:1
+4 IF IDX=ITEM
SET OK=0
+5 IF '$TEST
SET OK=$$PARENTOK(IDX,ITEM)
End DoDot:1
if 'OK
QUIT
+6 QUIT OK
ISROOT(TYPE) ; Returns TRUE if TYPE is a valid root folder type
+1 QUIT $SELECT(TYPE="R":1,TYPE="TF":1,TYPE="CF":1,TYPE="OF":1,1:0)
ROOTIDX(TYPE) ; Returns "AROOT" Index value for root types
+1 QUIT $SELECT(TYPE="R":"ROOT",TYPE="TF":"TITLES",TYPE="CF":"CONSULTS",TYPE="OF":"PROCEDURES",1:"")
