- 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 Feb 19, 2025@00:06:13 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:"")