TIUSRVT ; SLC/JM - Server functions for templates 8/23/2001 [8/19/04 1:57pm];05/31/17 13:19
;;1.0;TEXT INTEGRATION UTILITIES;**76,80,102,105,119,125,166,290**;Jun 20, 1997;Build 548
;
; Nodes Returned by GETROOTS and GETITEMS
;
; Piece Data
; ----- ---------------------
; 1 IEN
; 2 TYPE
; 3 STATUS
; 4 NAME
; 5 EXCLUDE FROM GROUP BOILERPLATE
; 6 BLANK LINES
; 7 PERSONAL OWNER
; 8 HAS CHILDREN FLAG (0=NONE, 1=ACTIVE, 2=INACTIVE, 3=BOTH)
; 9 DIALOG
; 10 DISPLAY ONLY
; 11 FIRST LINE
; 12 ONE ITEM ONLY
; 13 HIDE DIALOG ITEMS
; 14 HIDE TREE ITEMS
; 15 INDENT ITEMS
; 16 REMINDER DIALOG IEN
; 17 REMINDER DIALOG NAME
; 18 LOCKED
; 19 COM OBJECT POINTER
; 20 COM OBJECT PARAMETER
; 21 LINK POINTER
; 22 REMINDER DIALOG PATIENT SPECIFIC VALUE
; 23 CONSULT LOCK (0=NO, 1=YES)
GETROOTS(TIUY,USER) ;Get template root info
N IDX,TYPE
I +$G(USER) D ADDNODE(.IDX,$O(^TIU(8927,"AROOT",USER,0)),1)
F TYPE="R","TF","CF","OF" D
.D ADDNODE(.IDX,$O(^TIU(8927,"AROOT",$$ROOTIDX^TIUDDT(TYPE),0)),1)
Q
;
GETPROOT(TIUY,USER) ;Get personal template root info only
N IDX
I +$G(USER) D ADDNODE(.IDX,$O(^TIU(8927,"AROOT",USER,0)),1)
Q
;
GETITEMS(TIUY,TIUDA) ; Returns all children of a non-Template Node
N IDX,ITEM,SEQ,ITEMNODE
K ^TMP("TIU TEMPLATE",$J)
S TIUY=$NA(^TMP("TIU TEMPLATE",$J))
I $P($G(^TIU(8927,TIUDA,0)),U,3)'="T" D
.S (IDX,SEQ)=0
.F S SEQ=$O(^TIU(8927,TIUDA,10,"B",SEQ)) Q:'SEQ D
..S ITEM=0
..F S ITEM=$O(^TIU(8927,TIUDA,10,"B",SEQ,ITEM)) Q:'ITEM D
...S ITEMNODE=$G(^TIU(8927,TIUDA,10,ITEM,0))
...D ADDNODE(.IDX,$P(ITEMNODE,U,2))
Q
;
GETBOIL(TIUY,TIUDA) ;Returns a Template's Unexpanded Boilerplate Text
N IDX,LINE,TYPE
K ^TMP("TIU TEMPLATE",$J)
S TIUY=$NA(^TMP("TIU TEMPLATE",$J))
S (IDX,LINE)=0
S TYPE=$P($G(^TIU(8927,TIUDA,0)),U,3)
I (TYPE="T")!(TYPE="G") D
.F S LINE=$O(^TIU(8927,TIUDA,2,LINE)) Q:'LINE D
..S IDX=IDX+1
..S ^TMP("TIU TEMPLATE",$J,IDX)=$G(^TIU(8927,TIUDA,2,LINE,0))
Q
;
GETTEXT(TIUY,DFN,VSTR,TIUX) ; Expand Boilerplate
D BLRPLT^TIUSRVD(.TIUY,"",DFN,VSTR,"TIUX")
Q
ISEDITOR(TIUY,ROOT,USER) ; Returns TRUE if user is a Template Editor
N CLASS,TIUERR
S CLASS=$P($G(^TIU(8927,ROOT,0)),U,7)
I 'CLASS S TIUY="^NO CLASS OWNER DEFINED"
E D
.S TIUY=$$ISA^USRLM(USER,CLASS,.TIUERR)
.I 'TIUY,$D(TIUERR) S TIUY=U_TIUERR
Q
LISTOWNR(TIUY,TIUFROM,DIR) ; Return subset of personal owners
N FILE,IENS,FIELDS,FLAGS,NUMBER,TIUPART,INDEX,SCREEN,ID,TIU,TIUERR
S FILE=200,FIELDS="@;.01",FLAGS="PB",INDEX="B",NUMBER=44
S (IENS,TIUPART,ID,TIU,TIUERR)=""
I DIR=1 S FLAGS="P"
S SCREEN="I $O(^TIU(8927,""AROOT"",Y,0))"
D LIST^DIC(FILE,IENS,FIELDS,FLAGS,NUMBER,.TIUFROM,.TIUPART,INDEX,SCREEN,ID,"TIU","TIUERR")
K TIU("DILIST",0)
N DA,I
S DA="",I=0
F S DA=$O(TIU("DILIST",DA),DIR) Q:'DA D
. S I=I+1
. S TIUY(I)=$G(TIU("DILIST",DA,0))
Q
;
; Internal Routines
;
ADDNODE(IDX,TIUDA,INTIUY) ;Adds template node info
N DATA
S DATA=$$NODEDATA(TIUDA)
I DATA'="" D
.S IDX=$G(IDX)+1
.I $G(INTIUY) S TIUY(IDX)=DATA
.E S ^TMP("TIU TEMPLATE",$J,IDX)=DATA
Q
;
NODEDATA(TIUDA) ;Returns template node data
N NODE,DATA,RDIEN
S DATA=""
I +TIUDA D
.S NODE=$G(^TIU(8927,TIUDA,0))
.S DATA=TIUDA_$$NP(3)_$$NP(4)_$$NP(1)_$$NP(5)_$$NP(2)_$$NP(6)_U_$$HASITEMS(TIUDA)_U_$P(NODE,U,8,14)
.S RDIEN=$P(NODE,U,15)
.I +RDIEN D
..N RDN
..S RDN=$G(^PXRMD(801.41,+RDIEN,0))
..; TIU*166
..I RDN'="" D
...S $P(DATA,U,16)=RDIEN_U_$P(RDN,U,1)
...S $P(DATA,U,22)=$S($P($G(RDN),U,17)=1:1,1:0)
.S $P(DATA,U,18)=$P(NODE,U,16,19)
.S $P(DATA,U,23)=$P(NODE,U,20)
Q DATA
;
NP(PNUM) ;Returns the piece of the node
Q U_$P(NODE,U,PNUM)
;
HASITEMS(TIUDA) ; Returns Has Children flag (0=NONE,1=ACTIVE,2=INACTIVE,3=BOTH)
N FLAG,FLAGA,FLAGI,ITEM,ITEMNODE
S (FLAG,FLAGA,FLAGI,ITEM)=0
I $P($G(^TIU(8927,TIUDA,0)),U,3)'="T" D
.F S ITEM=$O(^TIU(8927,TIUDA,10,ITEM)) Q:'ITEM D Q:(FLAG=3)
..S ITEMNODE=$P($G(^TIU(8927,TIUDA,10,ITEM,0)),U,2)
..I +ITEMNODE D
...I $P($G(^TIU(8927,ITEMNODE,0)),U,4)="A" S FLAGA=1
...E S FLAGI=2
..S FLAG=FLAGA+FLAGI
Q FLAG
SETTMPLT(SUCCESS,TIUDA,TIUX) ; Create/update a TEMPLATE
N FLD
S:'+TIUDA TIUDA=$$CREATE($G(TIUX(.01)),$G(TIUX(.03)))
S SUCCESS=TIUDA Q:'+SUCCESS
I $G(TIUX(.03))="R" S TIUX(.07)=+$$CLPAC^TIUSRVT1
F FLD=2,5 D Q:$D(TIUX)'>9
. I +$O(TIUX(FLD,0)) D Q:$D(TIUX)'>9
. . K ^TIU(8927,TIUDA,FLD)
. . I $G(TIUX(FLD,1))="@" K TIUX(FLD) Q
. . M ^TIU(8927,TIUDA,FLD)=TIUX(FLD) K TIUX(FLD)
. . D SETXT0^TIUSRVT1(TIUDA,FLD)
D FILE^TIUSRVT1(.SUCCESS,""""_TIUDA_",""",.TIUX)
Q
CREATE(NAME,TYPE) ; Get or create TEMPLATE record
N DIC,DLAYGO,DR,X,Y
S (DIC,DLAYGO)=8927,DIC(0)="FL"
S X=""""_NAME_"""" D ^DIC
I +Y'>0 Q "0^ Unable to create a new TEMPLATE record."
Q +Y
DELETE(SUCCESS,TIUDA) ; Delete TEMPLATES
; Pass TIUDA as array of record numbers to be deleted by reference
; SUCCESS will be returned as the actual number of templates deleted
N TIUI S (SUCCESS,TIUI)=0
F S TIUI=$O(TIUDA(TIUI)) Q:+TIUI'>0 D
. N DA
. S DA=+TIUDA(TIUI)
. I 'DA Q
. L -^TIU(8927,DA,0):1 ; Unlock before deleting
. ; Quit if the Template is NOT an ORPHAN
. I +$O(^TIU(8927,"AD",DA,0)) Q
. ; Otherwise, call FileMan to DELETE the record
. D ZAP(DA) S SUCCESS=SUCCESS+1
Q
ZAP(DA) ; Call ^DIK to remove an entry - CAREFUL...NO CHECKS
N DIK
S DIK="^TIU(8927," D ^DIK
Q
SETITEMS(SUCCESS,TIUDA,TIUX) ; Change ITEMs of a group, class, or root
; Receives:
; TIUDA=IEN of TEMPLATE record
; TIUX(SEQ)=IEN of item
; Returns:
; SUCCESS(SEQ)=IEN of item if successful, or
; 0^ Explanatory message if not
N TIUI S TIUI=0
D CLRITMS(TIUDA) ; Remove ITEMS
; Iterate through TIUX and file items
F S TIUI=$O(TIUX(TIUI)) Q:+TIUI'>0 D
. N TIUITEM,TIUSUCC
. S TIUITEM(.01)=TIUI,TIUITEM(.02)=TIUX(TIUI),TIUSUCC=TIUI
. D UPDATE^TIUSRVT1(.TIUSUCC,"""+"_TIUI_","_TIUDA_",""",.TIUITEM)
. S SUCCESS(TIUI)=TIUSUCC
Q
CLRITMS(TIUDA) ; Remove all items from a group, class, or root
N DA S DA=0
F S DA=$O(^TIU(8927,TIUDA,10,DA)) Q:+DA'>0 D
. N DIK S DIK="^TIU(8927,TIUDA,10,",DA(1)=TIUDA D ^DIK
Q
OBJLST(TIUY) ; Get the list of active objects
N TIUDA,TIUD0,TIUI
S (TIUDA,TIUI)=0,TIUY=$NA(^TMP("TIU OBJECTS",$J)) K @TIUY
F S TIUDA=$O(^TIU(8925.1,"AT","O",TIUDA)) Q:+TIUDA'>0 D
. S TIUD0=$G(^TIU(8925.1,TIUDA,0)) Q:'+$$CANPICK^TIULP(+TIUDA)
. S TIUI=TIUI+1
. S @TIUY@(TIUI)=TIUDA_U_$P(TIUD0,U,1,3)
Q
BPCHECK(TIUTY,TIUX) ; Checks objects in boilerplate text.
N LINE,TIUI,TIUFWHO,TIUFPRIV,TIUY
S TIUI=0,TIUY=1,TIUFPRIV=1,TIUFWHO="M"
K ^TMP("TIUF",$J)
F S TIUI=$O(TIUX(2,TIUI)) Q:+TIUI'>0 D Q:'+TIUY
. S LINE=$G(TIUX(2,TIUI,0))
. I LINE["|" D
. . I ($L(LINE,"|")+1)#2 D Q
. . . S TIUY=0
. . . S TIUTY(1)="Object split between lines, rest of line not checked:"
. . . S TIUTY(2)=LINE
. . N PIECE
. . F PIECE=2:2:$L(LINE,"|") D Q:TIUY=0
. . . N OBJNM
. . . S OBJNM=$P(LINE,"|",PIECE)
. . . I OBJNM="" D Q
. . . . S TIUY=0
. . . . S TIUTY(1)="Brackets are there, but there's no name inside ||:"
. . . . S TIUTY(2)=LINE
. . . N XREF,ARR
. . . F XREF="B","C","D" D Q:'+TIUY
. . . . N ODA S ODA=0
. . . . F S ODA=$O(^TIU(8925.1,XREF,OBJNM,ODA)) Q:+ODA'>0 D Q:'+TIUY
. . . . . S:$D(^TIU(8925.1,"AT","O",ODA)) ARR(ODA)=""
. . . . . I $O(ARR($O(ARR(0)))) D
. . . . . . S TIUY=0
. . . . . . S TIUTY(1)="Object |"_OBJNM_"| is ambiguous."
. . . . . . S TIUTY(2)="It could be any of SEVERAL objects. Please contact IRM."
. . . I '$D(ARR) D Q
. . . . S TIUY=0
. . . . S TIUTY(1)="Object |"_OBJNM_"| cannot be found in the file."
. . . . S TIUTY(2)="Use UPPERCASE and object's exact NAME, PRINT NAME, or ABBREVIATION."
. . . . S TIUTY(3)="Any of these may have changed since |"_OBJNM_"| was embedded."
. . . S ODA=$O(ARR(0)) N OBJCK D CHECK^TIUFLF3(ODA,0,0,.OBJCK)
. . . I '+OBJCK D Q:'+TIUY
. . . . N SUBS
. . . . F SUBS="F","T","O","S","J" D
. . . . . I $D(OBJCK(SUBS)) D
. . . . . . S TIUY=0
. . . . . . S TIUTY(1)="Object |"_OBJNM_"| is faulty: "
. . . . . . S TIUTY(2)=OBJCK(SUBS)_"."
. . . I $P(^TIU(8925.1,ODA,0),U,7)'=11 D
. . . . S TIUY=0
. . . . S TIUTY(1)="Object |"_OBJNM_"| is NOT ACTIVE."
K ^TMP("TIUF",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUSRVT 8439 printed Oct 16, 2024@18:46:40 Page 2
TIUSRVT ; SLC/JM - Server functions for templates 8/23/2001 [8/19/04 1:57pm];05/31/17 13:19
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**76,80,102,105,119,125,166,290**;Jun 20, 1997;Build 548
+2 ;
+3 ; Nodes Returned by GETROOTS and GETITEMS
+4 ;
+5 ; Piece Data
+6 ; ----- ---------------------
+7 ; 1 IEN
+8 ; 2 TYPE
+9 ; 3 STATUS
+10 ; 4 NAME
+11 ; 5 EXCLUDE FROM GROUP BOILERPLATE
+12 ; 6 BLANK LINES
+13 ; 7 PERSONAL OWNER
+14 ; 8 HAS CHILDREN FLAG (0=NONE, 1=ACTIVE, 2=INACTIVE, 3=BOTH)
+15 ; 9 DIALOG
+16 ; 10 DISPLAY ONLY
+17 ; 11 FIRST LINE
+18 ; 12 ONE ITEM ONLY
+19 ; 13 HIDE DIALOG ITEMS
+20 ; 14 HIDE TREE ITEMS
+21 ; 15 INDENT ITEMS
+22 ; 16 REMINDER DIALOG IEN
+23 ; 17 REMINDER DIALOG NAME
+24 ; 18 LOCKED
+25 ; 19 COM OBJECT POINTER
+26 ; 20 COM OBJECT PARAMETER
+27 ; 21 LINK POINTER
+28 ; 22 REMINDER DIALOG PATIENT SPECIFIC VALUE
+29 ; 23 CONSULT LOCK (0=NO, 1=YES)
GETROOTS(TIUY,USER) ;Get template root info
+1 NEW IDX,TYPE
+2 IF +$GET(USER)
DO ADDNODE(.IDX,$ORDER(^TIU(8927,"AROOT",USER,0)),1)
+3 FOR TYPE="R","TF","CF","OF"
Begin DoDot:1
+4 DO ADDNODE(.IDX,$ORDER(^TIU(8927,"AROOT",$$ROOTIDX^TIUDDT(TYPE),0)),1)
End DoDot:1
+5 QUIT
+6 ;
GETPROOT(TIUY,USER) ;Get personal template root info only
+1 NEW IDX
+2 IF +$GET(USER)
DO ADDNODE(.IDX,$ORDER(^TIU(8927,"AROOT",USER,0)),1)
+3 QUIT
+4 ;
GETITEMS(TIUY,TIUDA) ; Returns all children of a non-Template Node
+1 NEW IDX,ITEM,SEQ,ITEMNODE
+2 KILL ^TMP("TIU TEMPLATE",$JOB)
+3 SET TIUY=$NAME(^TMP("TIU TEMPLATE",$JOB))
+4 IF $PIECE($GET(^TIU(8927,TIUDA,0)),U,3)'="T"
Begin DoDot:1
+5 SET (IDX,SEQ)=0
+6 FOR
SET SEQ=$ORDER(^TIU(8927,TIUDA,10,"B",SEQ))
if 'SEQ
QUIT
Begin DoDot:2
+7 SET ITEM=0
+8 FOR
SET ITEM=$ORDER(^TIU(8927,TIUDA,10,"B",SEQ,ITEM))
if 'ITEM
QUIT
Begin DoDot:3
+9 SET ITEMNODE=$GET(^TIU(8927,TIUDA,10,ITEM,0))
+10 DO ADDNODE(.IDX,$PIECE(ITEMNODE,U,2))
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
GETBOIL(TIUY,TIUDA) ;Returns a Template's Unexpanded Boilerplate Text
+1 NEW IDX,LINE,TYPE
+2 KILL ^TMP("TIU TEMPLATE",$JOB)
+3 SET TIUY=$NAME(^TMP("TIU TEMPLATE",$JOB))
+4 SET (IDX,LINE)=0
+5 SET TYPE=$PIECE($GET(^TIU(8927,TIUDA,0)),U,3)
+6 IF (TYPE="T")!(TYPE="G")
Begin DoDot:1
+7 FOR
SET LINE=$ORDER(^TIU(8927,TIUDA,2,LINE))
if 'LINE
QUIT
Begin DoDot:2
+8 SET IDX=IDX+1
+9 SET ^TMP("TIU TEMPLATE",$JOB,IDX)=$GET(^TIU(8927,TIUDA,2,LINE,0))
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
GETTEXT(TIUY,DFN,VSTR,TIUX) ; Expand Boilerplate
+1 DO BLRPLT^TIUSRVD(.TIUY,"",DFN,VSTR,"TIUX")
+2 QUIT
ISEDITOR(TIUY,ROOT,USER) ; Returns TRUE if user is a Template Editor
+1 NEW CLASS,TIUERR
+2 SET CLASS=$PIECE($GET(^TIU(8927,ROOT,0)),U,7)
+3 IF 'CLASS
SET TIUY="^NO CLASS OWNER DEFINED"
+4 IF '$TEST
Begin DoDot:1
+5 SET TIUY=$$ISA^USRLM(USER,CLASS,.TIUERR)
+6 IF 'TIUY
IF $DATA(TIUERR)
SET TIUY=U_TIUERR
End DoDot:1
+7 QUIT
LISTOWNR(TIUY,TIUFROM,DIR) ; Return subset of personal owners
+1 NEW FILE,IENS,FIELDS,FLAGS,NUMBER,TIUPART,INDEX,SCREEN,ID,TIU,TIUERR
+2 SET FILE=200
SET FIELDS="@;.01"
SET FLAGS="PB"
SET INDEX="B"
SET NUMBER=44
+3 SET (IENS,TIUPART,ID,TIU,TIUERR)=""
+4 IF DIR=1
SET FLAGS="P"
+5 SET SCREEN="I $O(^TIU(8927,""AROOT"",Y,0))"
+6 DO LIST^DIC(FILE,IENS,FIELDS,FLAGS,NUMBER,.TIUFROM,.TIUPART,INDEX,SCREEN,ID,"TIU","TIUERR")
+7 KILL TIU("DILIST",0)
+8 NEW DA,I
+9 SET DA=""
SET I=0
+10 FOR
SET DA=$ORDER(TIU("DILIST",DA),DIR)
if 'DA
QUIT
Begin DoDot:1
+11 SET I=I+1
+12 SET TIUY(I)=$GET(TIU("DILIST",DA,0))
End DoDot:1
+13 QUIT
+14 ;
+15 ; Internal Routines
+16 ;
ADDNODE(IDX,TIUDA,INTIUY) ;Adds template node info
+1 NEW DATA
+2 SET DATA=$$NODEDATA(TIUDA)
+3 IF DATA'=""
Begin DoDot:1
+4 SET IDX=$GET(IDX)+1
+5 IF $GET(INTIUY)
SET TIUY(IDX)=DATA
+6 IF '$TEST
SET ^TMP("TIU TEMPLATE",$JOB,IDX)=DATA
End DoDot:1
+7 QUIT
+8 ;
NODEDATA(TIUDA) ;Returns template node data
+1 NEW NODE,DATA,RDIEN
+2 SET DATA=""
+3 IF +TIUDA
Begin DoDot:1
+4 SET NODE=$GET(^TIU(8927,TIUDA,0))
+5 SET DATA=TIUDA_$$NP(3)_$$NP(4)_$$NP(1)_$$NP(5)_$$NP(2)_$$NP(6)_U_$$HASITEMS(TIUDA)_U_$PIECE(NODE,U,8,14)
+6 SET RDIEN=$PIECE(NODE,U,15)
+7 IF +RDIEN
Begin DoDot:2
+8 NEW RDN
+9 SET RDN=$GET(^PXRMD(801.41,+RDIEN,0))
+10 ; TIU*166
+11 IF RDN'=""
Begin DoDot:3
+12 SET $PIECE(DATA,U,16)=RDIEN_U_$PIECE(RDN,U,1)
+13 SET $PIECE(DATA,U,22)=$SELECT($PIECE($GET(RDN),U,17)=1:1,1:0)
End DoDot:3
End DoDot:2
+14 SET $PIECE(DATA,U,18)=$PIECE(NODE,U,16,19)
+15 SET $PIECE(DATA,U,23)=$PIECE(NODE,U,20)
End DoDot:1
+16 QUIT DATA
+17 ;
NP(PNUM) ;Returns the piece of the node
+1 QUIT U_$PIECE(NODE,U,PNUM)
+2 ;
HASITEMS(TIUDA) ; Returns Has Children flag (0=NONE,1=ACTIVE,2=INACTIVE,3=BOTH)
+1 NEW FLAG,FLAGA,FLAGI,ITEM,ITEMNODE
+2 SET (FLAG,FLAGA,FLAGI,ITEM)=0
+3 IF $PIECE($GET(^TIU(8927,TIUDA,0)),U,3)'="T"
Begin DoDot:1
+4 FOR
SET ITEM=$ORDER(^TIU(8927,TIUDA,10,ITEM))
if 'ITEM
QUIT
Begin DoDot:2
+5 SET ITEMNODE=$PIECE($GET(^TIU(8927,TIUDA,10,ITEM,0)),U,2)
+6 IF +ITEMNODE
Begin DoDot:3
+7 IF $PIECE($GET(^TIU(8927,ITEMNODE,0)),U,4)="A"
SET FLAGA=1
+8 IF '$TEST
SET FLAGI=2
End DoDot:3
+9 SET FLAG=FLAGA+FLAGI
End DoDot:2
if (FLAG=3)
QUIT
End DoDot:1
+10 QUIT FLAG
SETTMPLT(SUCCESS,TIUDA,TIUX) ; Create/update a TEMPLATE
+1 NEW FLD
+2 if '+TIUDA
SET TIUDA=$$CREATE($GET(TIUX(.01)),$GET(TIUX(.03)))
+3 SET SUCCESS=TIUDA
if '+SUCCESS
QUIT
+4 IF $GET(TIUX(.03))="R"
SET TIUX(.07)=+$$CLPAC^TIUSRVT1
+5 FOR FLD=2,5
Begin DoDot:1
+6 IF +$ORDER(TIUX(FLD,0))
Begin DoDot:2
+7 KILL ^TIU(8927,TIUDA,FLD)
+8 IF $GET(TIUX(FLD,1))="@"
KILL TIUX(FLD)
QUIT
+9 MERGE ^TIU(8927,TIUDA,FLD)=TIUX(FLD)
KILL TIUX(FLD)
+10 DO SETXT0^TIUSRVT1(TIUDA,FLD)
End DoDot:2
if $DATA(TIUX)'>9
QUIT
End DoDot:1
if $DATA(TIUX)'>9
QUIT
+11 DO FILE^TIUSRVT1(.SUCCESS,""""_TIUDA_",""",.TIUX)
+12 QUIT
CREATE(NAME,TYPE) ; Get or create TEMPLATE record
+1 NEW DIC,DLAYGO,DR,X,Y
+2 SET (DIC,DLAYGO)=8927
SET DIC(0)="FL"
+3 SET X=""""_NAME_""""
DO ^DIC
+4 IF +Y'>0
QUIT "0^ Unable to create a new TEMPLATE record."
+5 QUIT +Y
DELETE(SUCCESS,TIUDA) ; Delete TEMPLATES
+1 ; Pass TIUDA as array of record numbers to be deleted by reference
+2 ; SUCCESS will be returned as the actual number of templates deleted
+3 NEW TIUI
SET (SUCCESS,TIUI)=0
+4 FOR
SET TIUI=$ORDER(TIUDA(TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+5 NEW DA
+6 SET DA=+TIUDA(TIUI)
+7 IF 'DA
QUIT
+8 ; Unlock before deleting
LOCK -^TIU(8927,DA,0):1
+9 ; Quit if the Template is NOT an ORPHAN
+10 IF +$ORDER(^TIU(8927,"AD",DA,0))
QUIT
+11 ; Otherwise, call FileMan to DELETE the record
+12 DO ZAP(DA)
SET SUCCESS=SUCCESS+1
End DoDot:1
+13 QUIT
ZAP(DA) ; Call ^DIK to remove an entry - CAREFUL...NO CHECKS
+1 NEW DIK
+2 SET DIK="^TIU(8927,"
DO ^DIK
+3 QUIT
SETITEMS(SUCCESS,TIUDA,TIUX) ; Change ITEMs of a group, class, or root
+1 ; Receives:
+2 ; TIUDA=IEN of TEMPLATE record
+3 ; TIUX(SEQ)=IEN of item
+4 ; Returns:
+5 ; SUCCESS(SEQ)=IEN of item if successful, or
+6 ; 0^ Explanatory message if not
+7 NEW TIUI
SET TIUI=0
+8 ; Remove ITEMS
DO CLRITMS(TIUDA)
+9 ; Iterate through TIUX and file items
+10 FOR
SET TIUI=$ORDER(TIUX(TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+11 NEW TIUITEM,TIUSUCC
+12 SET TIUITEM(.01)=TIUI
SET TIUITEM(.02)=TIUX(TIUI)
SET TIUSUCC=TIUI
+13 DO UPDATE^TIUSRVT1(.TIUSUCC,"""+"_TIUI_","_TIUDA_",""",.TIUITEM)
+14 SET SUCCESS(TIUI)=TIUSUCC
End DoDot:1
+15 QUIT
CLRITMS(TIUDA) ; Remove all items from a group, class, or root
+1 NEW DA
SET DA=0
+2 FOR
SET DA=$ORDER(^TIU(8927,TIUDA,10,DA))
if +DA'>0
QUIT
Begin DoDot:1
+3 NEW DIK
SET DIK="^TIU(8927,TIUDA,10,"
SET DA(1)=TIUDA
DO ^DIK
End DoDot:1
+4 QUIT
OBJLST(TIUY) ; Get the list of active objects
+1 NEW TIUDA,TIUD0,TIUI
+2 SET (TIUDA,TIUI)=0
SET TIUY=$NAME(^TMP("TIU OBJECTS",$JOB))
KILL @TIUY
+3 FOR
SET TIUDA=$ORDER(^TIU(8925.1,"AT","O",TIUDA))
if +TIUDA'>0
QUIT
Begin DoDot:1
+4 SET TIUD0=$GET(^TIU(8925.1,TIUDA,0))
if '+$$CANPICK^TIULP(+TIUDA)
QUIT
+5 SET TIUI=TIUI+1
+6 SET @TIUY@(TIUI)=TIUDA_U_$PIECE(TIUD0,U,1,3)
End DoDot:1
+7 QUIT
BPCHECK(TIUTY,TIUX) ; Checks objects in boilerplate text.
+1 NEW LINE,TIUI,TIUFWHO,TIUFPRIV,TIUY
+2 SET TIUI=0
SET TIUY=1
SET TIUFPRIV=1
SET TIUFWHO="M"
+3 KILL ^TMP("TIUF",$JOB)
+4 FOR
SET TIUI=$ORDER(TIUX(2,TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+5 SET LINE=$GET(TIUX(2,TIUI,0))
+6 IF LINE["|"
Begin DoDot:2
+7 IF ($LENGTH(LINE,"|")+1)#2
Begin DoDot:3
+8 SET TIUY=0
+9 SET TIUTY(1)="Object split between lines, rest of line not checked:"
+10 SET TIUTY(2)=LINE
End DoDot:3
QUIT
+11 NEW PIECE
+12 FOR PIECE=2:2:$LENGTH(LINE,"|")
Begin DoDot:3
+13 NEW OBJNM
+14 SET OBJNM=$PIECE(LINE,"|",PIECE)
+15 IF OBJNM=""
Begin DoDot:4
+16 SET TIUY=0
+17 SET TIUTY(1)="Brackets are there, but there's no name inside ||:"
+18 SET TIUTY(2)=LINE
End DoDot:4
QUIT
+19 NEW XREF,ARR
+20 FOR XREF="B","C","D"
Begin DoDot:4
+21 NEW ODA
SET ODA=0
+22 FOR
SET ODA=$ORDER(^TIU(8925.1,XREF,OBJNM,ODA))
if +ODA'>0
QUIT
Begin DoDot:5
+23 if $DATA(^TIU(8925.1,"AT","O",ODA))
SET ARR(ODA)=""
+24 IF $ORDER(ARR($ORDER(ARR(0))))
Begin DoDot:6
+25 SET TIUY=0
+26 SET TIUTY(1)="Object |"_OBJNM_"| is ambiguous."
+27 SET TIUTY(2)="It could be any of SEVERAL objects. Please contact IRM."
End DoDot:6
End DoDot:5
if '+TIUY
QUIT
End DoDot:4
if '+TIUY
QUIT
+28 IF '$DATA(ARR)
Begin DoDot:4
+29 SET TIUY=0
+30 SET TIUTY(1)="Object |"_OBJNM_"| cannot be found in the file."
+31 SET TIUTY(2)="Use UPPERCASE and object's exact NAME, PRINT NAME, or ABBREVIATION."
+32 SET TIUTY(3)="Any of these may have changed since |"_OBJNM_"| was embedded."
End DoDot:4
QUIT
+33 SET ODA=$ORDER(ARR(0))
NEW OBJCK
DO CHECK^TIUFLF3(ODA,0,0,.OBJCK)
+34 IF '+OBJCK
Begin DoDot:4
+35 NEW SUBS
+36 FOR SUBS="F","T","O","S","J"
Begin DoDot:5
+37 IF $DATA(OBJCK(SUBS))
Begin DoDot:6
+38 SET TIUY=0
+39 SET TIUTY(1)="Object |"_OBJNM_"| is faulty: "
+40 SET TIUTY(2)=OBJCK(SUBS)_"."
End DoDot:6
End DoDot:5
End DoDot:4
if '+TIUY
QUIT
+41 IF $PIECE(^TIU(8925.1,ODA,0),U,7)'=11
Begin DoDot:4
+42 SET TIUY=0
+43 SET TIUTY(1)="Object |"_OBJNM_"| is NOT ACTIVE."
End DoDot:4
End DoDot:3
if TIUY=0
QUIT
End DoDot:2
End DoDot:1
if '+TIUY
QUIT
+44 KILL ^TMP("TIUF",$JOB)
+45 QUIT
