- 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 Feb 19, 2025@00:12:35 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