Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: TIUDDT

TIUDDT.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Input Transform functions return true if the field value is bad
  1. ;
  1. BADTYPE(X,DA) ;Input Transform for .03 TYPE field
  1. N BAD,NODE
  1. S BAD=0,NODE=$$GETNODE()
  1. I $P(NODE,U,4)="A" D
  1. .I $$ISROOT(X) S BAD=$$BADROOT(DA,X)
  1. .I X="P" S BAD=$$BADPROOT(DA,$P(NODE,U,6))
  1. Q BAD
  1. ;
  1. BADSTS(X,DA) ;Input Transform for .04 STATUS Field
  1. N BAD,NODE,TYPE
  1. S BAD=0
  1. I X="A" D
  1. .S NODE=$$GETNODE()
  1. .S TYPE=$P(NODE,U,3)
  1. .I $$ISROOT(TYPE) S BAD=$$BADROOT(DA,TYPE)
  1. .I TYPE="P" S BAD=$$BADPROOT(DA,$P(NODE,U,6))
  1. Q BAD
  1. ;
  1. BADOWNER(X,DA) ;Input Transform for .06 PERSONAL OWNER Field
  1. N BAD,NODE,ROOT,TYPE
  1. S BAD=0
  1. I +X D
  1. .S NODE=$$GETNODE()
  1. .I $P(NODE,U,3)="P",$P(NODE,U,4)="A" S BAD=$$BADPROOT(DA,X)
  1. .I 'BAD D
  1. ..F TYPE="R","TF","CF","OF" D Q:+BAD
  1. ...S ROOT=$O(^TIU(8927,"AROOT",$$ROOTIDX(TYPE),0))
  1. ...I +ROOT S BAD='$$PARENTOK(DA,ROOT)
  1. Q BAD
  1. ;
  1. BADITEM(X,DA1) ;Input Transform for ITEMS .02 ITEM Field
  1. Q '$$PARENTOK(DA1,X)
  1. ;
  1. ; Field Cross Reference Routines
  1. ;
  1. TYPESETR(X,DA) ; .03 TYPE Field "AROOT" and "AP" XRef Set Logic
  1. N NODE,OWNER
  1. S NODE=$$GETNODE()
  1. I $P(NODE,U,4)="A" D
  1. .I $$ISROOT(X),'$$BADROOT(DA,X) D
  1. ..S ^TIU(8927,"AROOT",$$ROOTIDX(X),DA)=""
  1. .I X="P" D
  1. ..S OWNER=$P(NODE,U,6)
  1. ..I '$$BADPROOT(DA,OWNER) D
  1. ...S ^TIU(8927,"AROOT",OWNER,DA)=""
  1. Q
  1. ;
  1. TYPEKILR(X,DA) ; .03 TYPE Field "AROOT" and "AP" XRef Kill Logic
  1. N NODE,OWNER
  1. I $$ISROOT(X) K ^TIU(8927,"AROOT",$$ROOTIDX(X),DA)
  1. I X="P" D
  1. .S NODE=$$GETNODE()
  1. .S OWNER=$P(NODE,U,6)
  1. .I +OWNER K ^TIU(8927,"AROOT",OWNER,DA)
  1. Q
  1. ;
  1. STSSETR(X,DA) ; .04 STATUS Field "AROOT" and "AP" XRef Set Logic
  1. N NODE,TYPE,OWNER
  1. I X="A" D
  1. .S NODE=$$GETNODE()
  1. .S TYPE=$P(NODE,U,3)
  1. .I $$ISROOT(TYPE),'$$BADROOT(DA,TYPE) D
  1. ..S ^TIU(8927,"AROOT",$$ROOTIDX(TYPE),DA)=""
  1. .I TYPE="P" D
  1. ..S OWNER=$P(NODE,U,6)
  1. ..I +OWNER,'$$BADPROOT(DA,OWNER) D
  1. ...S ^TIU(8927,"AROOT",OWNER,DA)=""
  1. Q
  1. ;
  1. STSKILLR(X,DA) ; .04 STATUS Field "AROOT" XRef Kill Logic
  1. N NODE,TYPE,OWNER
  1. S NODE=$$GETNODE()
  1. S TYPE=$P(NODE,U,3)
  1. I $$ISROOT(TYPE) K ^TIU(8927,"AROOT",$$ROOTIDX(TYPE),DA)
  1. I TYPE="P" D
  1. .S OWNER=$P(NODE,U,6)
  1. .I +OWNER K ^TIU(8927,"AROOT",OWNER,DA)
  1. Q
  1. ;
  1. OWNRSETR(X,DA) ; .06 OWNER Field "AROOT" XRef Set Logic
  1. N NODE
  1. I +X D
  1. .S NODE=$$GETNODE()
  1. .I $P(NODE,U,4)="A",$P(NODE,U,3)="P",'$$BADPROOT(DA,X) D
  1. ..S ^TIU(8927,"AROOT",X,DA)=""
  1. Q
  1. ;
  1. OWNRKILR(X,DA) ; .06 OWNER Field "AROOT" XRef Kill Logic
  1. I +X K ^TIU(8927,"AROOT",X,DA)
  1. Q
  1. N BAD,IDX
  1. S BAD=0
  1. S IDX=$O(^TIU(8927,"AL",X,0))
  1. I +IDX,IDX'=DA S BAD=1
  1. Q BAD
  1. ;
  1. ; Internal Routines
  1. ;
  1. GETNODE() ; Sets NODE variable
  1. Q $G(^TIU(8927,DA,0))
  1. ;
  1. BADROOT(DA,TIUTYPE) ; Returns True if there is another root
  1. N CURROOT,BAD
  1. S BAD=0
  1. S CURROOT=$O(^TIU(8927,"AROOT",$$ROOTIDX(TIUTYPE),0))
  1. I +CURROOT,CURROOT'=DA S BAD=1
  1. Q BAD
  1. ;
  1. BADPROOT(DA,OWNER) ; Returns True if there is another personal root
  1. N CURROOT,BAD
  1. S BAD=0
  1. I +OWNER D
  1. .S CURROOT=$O(^TIU(8927,"AROOT",OWNER,0))
  1. .I +CURROOT,CURROOT'=DA S BAD=1
  1. Q BAD
  1. ;
  1. PARENTOK(PARENT,ITEM) ; Returns True if ITEM is not in it's own parent list
  1. N IDX,OK
  1. S IDX=0,OK=1
  1. F S IDX=$O(^TIU(8927,"AD",PARENT,IDX)) Q:'IDX D Q:'OK
  1. .I IDX=ITEM S OK=0
  1. .E S OK=$$PARENTOK(IDX,ITEM)
  1. Q OK
  1. ISROOT(TYPE) ; Returns TRUE if TYPE is a valid root folder type
  1. Q $S(TYPE="R":1,TYPE="TF":1,TYPE="CF":1,TYPE="OF":1,1:0)
  1. ROOTIDX(TYPE) ; Returns "AROOT" Index value for root types
  1. Q $S(TYPE="R":"ROOT",TYPE="TF":"TITLES",TYPE="CF":"CONSULTS",TYPE="OF":"PROCEDURES",1:"")