TIUSRVT1 ; SLC/JER - Server calls for Templates ; 7/16/2001
;;1.0;TEXT INTEGRATION UTILITIES;**76,102,105,119**;Jun 20, 1997
SETXT0(TIUDA,FLD) ; Set the root node of the "TEMP" WP-field
N TIUC,TIUI S (TIUC,TIUI)=0
I '+$G(FLD) S FLD=2
F S TIUI=$O(^TIU(8927,TIUDA,FLD,TIUI)) Q:+TIUI'>0 D
. S:$D(^TIU(8927,TIUDA,FLD,TIUI,0)) TIUC=TIUC+1
S ^TIU(8927,TIUDA,FLD,0)="^^"_TIUC_U_TIUC_U_DT_"^^"
Q
FILE(SUCCESS,IENS,TIUX) ; Call FM Filer to commit updates to DB
N FDA,FDARR,FLAGS,TIUMSG
S FDARR="FDA(8927,"_IENS_")",FLAGS="K"
M @FDARR=TIUX
D FILE^DIE(FLAGS,"FDA","TIUMSG") ; File record
I $D(TIUMSG)>9 S SUCCESS=0_U_$G(TIUMSG("DIERR",1,"TEXT",1)) Q
Q
UPDATE(SUCCESS,IENS,TIUX) ; Call FM Filer to commit updates to DB
N FDA,FDARR,FLAGS,TIUMSG,TIUIENS
S FDARR="FDA(8927.03,"_IENS_")",FLAGS=""
M @FDARR=TIUX
D UPDATE^DIE(FLAGS,"FDA","TIUIENS","TIUMSG") ; File record
I $D(TIUMSG)>9 S SUCCESS=0_U_$G(TIUMSG("DIERR",1,"TEXT",1)) Q
Q
CLPAC() ; Get pointer to CLINICAL COORDINATOR User Class
N TIUY
S TIUY=$O(^USR(8930,"B","CLINICAL COORDINATOR",0))
Q TIUY
;
LONGLIST(Y,FROM,DIR) ; Long list of titles with boilerplate
; .Y=returned list, FROM=text to $O from, DIR=$O direction,
N I,DA,CNT,TIUD0
S I=0,CNT=44,DIR=$G(DIR,1)
F Q:I'<CNT S FROM=$O(^TIU(8925.1,"B",FROM),DIR) Q:FROM="" D
. S DA=0
. F Q:I'<CNT S DA=$O(^TIU(8925.1,"B",FROM,DA)) Q:+DA'>0 D
. . S TIUD0=$G(^TIU(8925.1,DA,0))
. . I +$P(TIUD0,U,7)'=11 Q ; Only allow Active Entries
. . I $P(TIUD0,U,4)'="DOC" Q ; Only allow TITLES
. . ; Quit if no Boilerplate Text is present
. . I '+$O(^TIU(8925.1,DA,"DFLT",0)) Q
. . I $S(+$$CANENTR^TIULP(DA)'>0:1,+$$CANPICK^TIULP(DA)'>0:1,1:0) Q
. . S I=I+1,Y(I)=DA_"^"_FROM
Q
TITLEBP(Y,IEN) ; Returns a Titles Boilerplate
Q:+$G(IEN)'>0
N I,IDX
S (I,IDX)=0
F S IDX=$O(^TIU(8925.1,IEN,"DFLT",IDX)) Q:+IDX=0 D
.S I=I+1
.S Y(I)=^TIU(8925.1,IEN,"DFLT",IDX,0)
Q
GETDESC(TIUY,TIUDA) ;Returns Template Description
I (TIUDA>0),$D(^TIU(8927,TIUDA,5)) D
.N IDX,CNT S (IDX,CNT)=0
.F S IDX=$O(^TIU(8927,TIUDA,5,IDX)) Q:IDX'>0 D
..S CNT=CNT+1,TIUY(CNT)=^TIU(8927,TIUDA,5,IDX,0)
Q
CLSLIST(ORY,FROM,DIR) ; Long List of Active User Classes
N I,IEN,CNT S I=0,CNT=44
F Q:(I'<CNT) S FROM=$O(^USR(8930,"B",FROM),DIR) Q:(FROM="") D
. S IEN=$O(^USR(8930,"B",FROM,0)) I $P(^USR(8930,IEN,0),U,3)="0" Q
. S I=I+1,ORY(I)=IEN_"^"_FROM
Q
USERINFO(ORY,USER) ; Returns List of User Divisions and ASU Classes
N TIUI,I,IDX,IEN,TIUERR,SRV
S I=0,IDX=1
F S I=$O(^VA(200,USER,2,I)) Q:'I D
. I USER=DUZ,I=DUZ(2) S ORY(1)="D^"_I
. E S IDX=IDX+1,ORY(IDX)="D^"_I
S TIUI=""
F S TIUI=$O(^USR(8930,"B",TIUI)) Q:(TIUI="") D
. S IEN=$O(^USR(8930,"B",TIUI,0))
. I $P(^USR(8930,IEN,0),U,3)="0" Q
. I '$$ISA^USRLM(USER,IEN,.TIUERR) Q
. S IDX=IDX+1,ORY(IDX)="C^"_IEN
S SRV=$P($G(^VA(200,USER,5)),U)
I +SRV S IDX=IDX+1,ORY(IDX)="S^"_SRV
Q
GETLINK(ORY,LINK) ; Returns template linked to title or reason for request
N IDX
S ORY="",IDX=$O(^TIU(8927,"AL",LINK,0))
I +IDX,$P($G(^TIU(8927,IDX,0)),U,4)'="I" S ORY=$$NODEDATA^TIUSRVT(IDX)
Q
TITLELST(Y,FROM,DIR) ; Long list of titles
; .Y=returned list, FROM=text to $O from, DIR=$O direction,
N I,DA,CNT,TIUD0
S I=0,CNT=44,DIR=$G(DIR,1)
F Q:I'<CNT S FROM=$O(^TIU(8925.1,"B",FROM),DIR) Q:FROM="" D
. S DA=0
. F Q:I'<CNT S DA=$O(^TIU(8925.1,"B",FROM,DA)) Q:+DA'>0 D
. . S TIUD0=$G(^TIU(8925.1,DA,0))
. . I +$P(TIUD0,U,7)'=11 Q ; Only allow Active Entries
. . I $P(TIUD0,U,4)'="DOC" Q ; Only allow TITLES
. . S I=I+1,Y(I)=DA_"^"_FROM
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUSRVT1 3614 printed Oct 16, 2024@18:46:41 Page 2
TIUSRVT1 ; SLC/JER - Server calls for Templates ; 7/16/2001
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**76,102,105,119**;Jun 20, 1997
SETXT0(TIUDA,FLD) ; Set the root node of the "TEMP" WP-field
+1 NEW TIUC,TIUI
SET (TIUC,TIUI)=0
+2 IF '+$GET(FLD)
SET FLD=2
+3 FOR
SET TIUI=$ORDER(^TIU(8927,TIUDA,FLD,TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+4 if $DATA(^TIU(8927,TIUDA,FLD,TIUI,0))
SET TIUC=TIUC+1
End DoDot:1
+5 SET ^TIU(8927,TIUDA,FLD,0)="^^"_TIUC_U_TIUC_U_DT_"^^"
+6 QUIT
FILE(SUCCESS,IENS,TIUX) ; Call FM Filer to commit updates to DB
+1 NEW FDA,FDARR,FLAGS,TIUMSG
+2 SET FDARR="FDA(8927,"_IENS_")"
SET FLAGS="K"
+3 MERGE @FDARR=TIUX
+4 ; File record
DO FILE^DIE(FLAGS,"FDA","TIUMSG")
+5 IF $DATA(TIUMSG)>9
SET SUCCESS=0_U_$GET(TIUMSG("DIERR",1,"TEXT",1))
QUIT
+6 QUIT
UPDATE(SUCCESS,IENS,TIUX) ; Call FM Filer to commit updates to DB
+1 NEW FDA,FDARR,FLAGS,TIUMSG,TIUIENS
+2 SET FDARR="FDA(8927.03,"_IENS_")"
SET FLAGS=""
+3 MERGE @FDARR=TIUX
+4 ; File record
DO UPDATE^DIE(FLAGS,"FDA","TIUIENS","TIUMSG")
+5 IF $DATA(TIUMSG)>9
SET SUCCESS=0_U_$GET(TIUMSG("DIERR",1,"TEXT",1))
QUIT
+6 QUIT
CLPAC() ; Get pointer to CLINICAL COORDINATOR User Class
+1 NEW TIUY
+2 SET TIUY=$ORDER(^USR(8930,"B","CLINICAL COORDINATOR",0))
+3 QUIT TIUY
+4 ;
LONGLIST(Y,FROM,DIR) ; Long list of titles with boilerplate
+1 ; .Y=returned list, FROM=text to $O from, DIR=$O direction,
+2 NEW I,DA,CNT,TIUD0
+3 SET I=0
SET CNT=44
SET DIR=$GET(DIR,1)
+4 FOR
if I'<CNT
QUIT
SET FROM=$ORDER(^TIU(8925.1,"B",FROM),DIR)
if FROM=""
QUIT
Begin DoDot:1
+5 SET DA=0
+6 FOR
if I'<CNT
QUIT
SET DA=$ORDER(^TIU(8925.1,"B",FROM,DA))
if +DA'>0
QUIT
Begin DoDot:2
+7 SET TIUD0=$GET(^TIU(8925.1,DA,0))
+8 ; Only allow Active Entries
IF +$PIECE(TIUD0,U,7)'=11
QUIT
+9 ; Only allow TITLES
IF $PIECE(TIUD0,U,4)'="DOC"
QUIT
+10 ; Quit if no Boilerplate Text is present
+11 IF '+$ORDER(^TIU(8925.1,DA,"DFLT",0))
QUIT
+12 IF $SELECT(+$$CANENTR^TIULP(DA)'>0:1,+$$CANPICK^TIULP(DA)'>0:1,1:0)
QUIT
+13 SET I=I+1
SET Y(I)=DA_"^"_FROM
End DoDot:2
End DoDot:1
+14 QUIT
TITLEBP(Y,IEN) ; Returns a Titles Boilerplate
+1 if +$GET(IEN)'>0
QUIT
+2 NEW I,IDX
+3 SET (I,IDX)=0
+4 FOR
SET IDX=$ORDER(^TIU(8925.1,IEN,"DFLT",IDX))
if +IDX=0
QUIT
Begin DoDot:1
+5 SET I=I+1
+6 SET Y(I)=^TIU(8925.1,IEN,"DFLT",IDX,0)
End DoDot:1
+7 QUIT
GETDESC(TIUY,TIUDA) ;Returns Template Description
+1 IF (TIUDA>0)
IF $DATA(^TIU(8927,TIUDA,5))
Begin DoDot:1
+2 NEW IDX,CNT
SET (IDX,CNT)=0
+3 FOR
SET IDX=$ORDER(^TIU(8927,TIUDA,5,IDX))
if IDX'>0
QUIT
Begin DoDot:2
+4 SET CNT=CNT+1
SET TIUY(CNT)=^TIU(8927,TIUDA,5,IDX,0)
End DoDot:2
End DoDot:1
+5 QUIT
CLSLIST(ORY,FROM,DIR) ; Long List of Active User Classes
+1 NEW I,IEN,CNT
SET I=0
SET CNT=44
+2 FOR
if (I'<CNT)
QUIT
SET FROM=$ORDER(^USR(8930,"B",FROM),DIR)
if (FROM="")
QUIT
Begin DoDot:1
+3 SET IEN=$ORDER(^USR(8930,"B",FROM,0))
IF $PIECE(^USR(8930,IEN,0),U,3)="0"
QUIT
+4 SET I=I+1
SET ORY(I)=IEN_"^"_FROM
End DoDot:1
+5 QUIT
USERINFO(ORY,USER) ; Returns List of User Divisions and ASU Classes
+1 NEW TIUI,I,IDX,IEN,TIUERR,SRV
+2 SET I=0
SET IDX=1
+3 FOR
SET I=$ORDER(^VA(200,USER,2,I))
if 'I
QUIT
Begin DoDot:1
+4 IF USER=DUZ
IF I=DUZ(2)
SET ORY(1)="D^"_I
+5 IF '$TEST
SET IDX=IDX+1
SET ORY(IDX)="D^"_I
End DoDot:1
+6 SET TIUI=""
+7 FOR
SET TIUI=$ORDER(^USR(8930,"B",TIUI))
if (TIUI="")
QUIT
Begin DoDot:1
+8 SET IEN=$ORDER(^USR(8930,"B",TIUI,0))
+9 IF $PIECE(^USR(8930,IEN,0),U,3)="0"
QUIT
+10 IF '$$ISA^USRLM(USER,IEN,.TIUERR)
QUIT
+11 SET IDX=IDX+1
SET ORY(IDX)="C^"_IEN
End DoDot:1
+12 SET SRV=$PIECE($GET(^VA(200,USER,5)),U)
+13 IF +SRV
SET IDX=IDX+1
SET ORY(IDX)="S^"_SRV
+14 QUIT
GETLINK(ORY,LINK) ; Returns template linked to title or reason for request
+1 NEW IDX
+2 SET ORY=""
SET IDX=$ORDER(^TIU(8927,"AL",LINK,0))
+3 IF +IDX
IF $PIECE($GET(^TIU(8927,IDX,0)),U,4)'="I"
SET ORY=$$NODEDATA^TIUSRVT(IDX)
+4 QUIT
TITLELST(Y,FROM,DIR) ; Long list of titles
+1 ; .Y=returned list, FROM=text to $O from, DIR=$O direction,
+2 NEW I,DA,CNT,TIUD0
+3 SET I=0
SET CNT=44
SET DIR=$GET(DIR,1)
+4 FOR
if I'<CNT
QUIT
SET FROM=$ORDER(^TIU(8925.1,"B",FROM),DIR)
if FROM=""
QUIT
Begin DoDot:1
+5 SET DA=0
+6 FOR
if I'<CNT
QUIT
SET DA=$ORDER(^TIU(8925.1,"B",FROM,DA))
if +DA'>0
QUIT
Begin DoDot:2
+7 SET TIUD0=$GET(^TIU(8925.1,DA,0))
+8 ; Only allow Active Entries
IF +$PIECE(TIUD0,U,7)'=11
QUIT
+9 ; Only allow TITLES
IF $PIECE(TIUD0,U,4)'="DOC"
QUIT
+10 SET I=I+1
SET Y(I)=DA_"^"_FROM
End DoDot:2
End DoDot:1
+11 QUIT
