TIULA4 ; SLC/JER,JM - Check out PUT API's ; 6/13/01
;;1.0;TEXT INTEGRATION UTILITIES;**10,35,79,103,111,116**;Jun 20, 1997
CLASPICK(PARENT,Y,TYPES) ; Boolean fn to screen selection of classes
N TIUY S TIUY=0,TYPES=$G(TYPES,"DCCL")
I ($P(^TIU(8925.1,+Y,0),U,4)]""),$S(TYPES[$P(^TIU(8925.1,+Y,0),U,4):1,(+Y=+$$CLASS^TIUCNSLT):1,1:0),+$$ISA^TIULX(+Y,+PARENT),+$$CANPICK^TIULP(+Y) S TIUY=1
Q TIUY
DFLTPICK(PARENT,Y,LIST) ; Boolean function to screen selection of Default title
N TIUY S TIUY=0
I $P(^TIU(8925.1,+Y,0),U,4)="DOC",+$$ISA^TIULX(+Y,+PARENT),+$$CANPICK^TIULP(+Y) S TIUY=1
I +$G(LIST),(+$O(^TIU(8925.98,+$G(LIST),10,0))>0),(+$O(^TIU(8925.98,+$G(LIST),10,"B",+Y,0))'>0) S TIUY=0
Q TIUY
LBYPASS() ; Interactive function to determine whether to bypass list
N PROMPT W !
S PROMPT="Edit (L)ist, (D)efault TITLE, or (B)oth? "
Q $P($$READ^TIUU("SA^L:list;D:default;B:both",PROMPT,"BOTH"),U)
TITLPICK(TIUY,CLASS,ATTCHID) ; Select a title
N PICK,TITLES,I,L,Y,TIUDFLT,QUIT,DTOUT,DUOUT,CANLINK,PICKNUM
S CLASS=$G(CLASS,3)
D LIST(.TITLES,CLASS,"","",$G(ATTCHID)) Q:'+$O(TITLES(0))
S TIUDFLT=$G(TITLES("DFLT"))
I TIUDFLT,'$P(TITLES(TIUDFLT),U,3)!($G(ATTCHID)&'$P(TITLES(TIUDFLT),U,4)) S TIUDFLT=0,TIUY("NODFLT")=1
RPT W !!,"Personal ",$$UP^XLFSTR($$PNAME^TIULC1(CLASS))," Title List for "
W $$NAME^TIULS($$PERSNAME^TIULC1(DUZ),"FIRST LAST"),!
S (I,L,PICK,QUIT,PICKNUM)=0
F S I=$O(TITLES(I)) Q:QUIT!(+I'>0)!(+PICK) D
. W !?3,I,?8,$P(TITLES(I),U,2)
. I I#15=0 D
. . I +$O(TITLES(I)) D I 1
. . . W !!,"Press <RETURN> to see more titles, '^' to exit personal list, or CHOOSE"
. . . S Y=$G(TITLES(+$$PICK(1,I))) ;If more titles, no default
. . E D
. . . W ! S PICKNUM=$$PICK(1,I,+$G(TIUDFLT))
. . . I PICKNUM="" S QUIT=1
. . . S Y=$G(TITLES(+PICKNUM))
. . . I Y="0^Other Title" S QUIT=1
. . I $D(DTOUT)!$D(DUOUT) S QUIT=1,Y=0
. . E S PICK=+Y
. I +PICK S TIUY(1)=1_U_+Y_$$PNAME^TIULC1(+Y),TIUY=1
. S L=I
I 'QUIT,'PICK W ! S Y=$G(TITLES(+$$PICK(1,L,+$G(TIUDFLT))))
I +Y,'$P(Y,U,3) D G RPT
. W !,$C(7),">>> ",$$PNAME^TIULC1(+Y)," is not an ACTIVE title."
. W " Please choose another."
. W !?4,"You may want to remove it from your list..."
. W !?4,"Check with your Clinical Application Coordinator.",! K Y
I +Y,$G(ATTCHID),'$P(Y,U,4) D G RPT
. S CANLINK=$$CANLINK^TIULP(+Y)
. W !,$C(7),">>> ",$P(CANLINK,U,2),!," Please choose another title."
. K Y
I +Y D
. S TIUY(1)=1_U_+Y_U_$$PNAME^TIULC1(+Y),TIUY=1
. W " ",$$PNAME^TIULC1(+Y)
I +Y=0 S (TIUY,TIUY(1))=0
;If user selected other title, they rejected the default:
I Y="0^Other Title" S TIUY("NODFLT")=1
I 'Y D
. W !,"Exiting NUMBERED personal list.",!
. W "Please select other title by NAME:"
Q
PICK(LOW,HIGH,DFLT) ; List selection
N X,Y
I +$G(DFLT) S Y=$$READ^TIUU("NO^"_LOW_":"_HIGH,"TITLE",DFLT) I 1
E S Y=$$READ^TIUU("NO^"_LOW_":"_HIGH,"TITLE")
W !
Q Y
LIST(TIUY,CLASS,TYPE,TIUK,ATTCHID) ; Get list of document titles
N TIUDFLT
S TIUK=+$G(TIUK)
I $G(TYPE)']"" S TYPE="DOC"
; If the user has a preferred list of titles for the CLASS, get it
I +$O(^TIU(8925.98,"AC",DUZ,CLASS,0)) D PERSLIST(.TIUY,DUZ,CLASS,.TIUK,ATTCHID)
Q
PERSLIST(TIUY,DUZ,CLASS,TIUC,ATTCHID) ; Get personal list for a user
N TIUI,TIUDA,LASTSEQ,UNKSEQ,DFLTFL
S TIUDA=+$O(^TIU(8925.98,"AC",DUZ,CLASS,0))
Q:+TIUDA'>0
S TIUY("DFLT")=$P($G(^TIU(8925.98,+TIUDA,0)),U,3)
S TIUC=+$G(TIUC)
S (TIUI,LASTSEQ,UNKSEQ,DFLTFL)=0
F S TIUI=$O(^TIU(8925.98,TIUDA,10,TIUI)) Q:+TIUI'>0 D
. N TIUPL,TIUTNM,TIUDTYP,TIUSEQ,TLINE
. S TIUPL=$G(^TIU(8925.98,TIUDA,10,TIUI,0))
. S TIUDTYP=$P(TIUPL,U),TIUSEQ=+$P(TIUPL,U,2)
. I 'TIUSEQ S TIUSEQ=1000+UNKSEQ,UNKSEQ=UNKSEQ+1
. S TIUTNM=$S($P(TIUPL,U,3)]"":$P(TIUPL,U,3),1:$$PNAME^TIULC1(+TIUDTYP))
. S TIUC=+$G(TIUC)+1
. S TLINE=$$TLINE(TIUDTYP,TIUTNM,$G(ATTCHID))
. I $D(TIUY(TIUSEQ)) S TIUY(1000+UNKSEQ)=TLINE,LASTSEQ=1000+UNKSEQ,UNKSEQ=UNKSEQ+1
. E S TIUY(TIUSEQ)=TLINE
. I LASTSEQ<TIUSEQ S LASTSEQ=TIUSEQ
. I TIUDTYP=TIUY("DFLT") S TIUY("DFLT")=TIUSEQ,DFLTFL=1
I DFLTFL=0&($G(TIUY("DFLT"))) D
. N TIUTNM,DFLTLINE
. S TIUTNM=$$PNAME^TIULC1(+TIUY("DFLT"))
. S DFLTLINE=$$TLINE(+TIUY("DFLT"),TIUTNM,$G(ATTCHID))
. S TIUY(1000+UNKSEQ)=DFLTLINE,TIUY("DFLT")=1000+UNKSEQ,LASTSEQ=1000+UNKSEQ,UNKSEQ=UNKSEQ+1
I +$G(LASTSEQ)>0 S LASTSEQ=LASTSEQ+1,TIUY(LASTSEQ)=0_U_"Other Title"
Q
;
TLINE(TITLIFN,TIUTNM,ATTCHID) ; Function returns TitleIFN^Titlename^Canpick (i.e. active)^Canattach (user can attach child ID entries of this title)
N TIUPICK,CANLINK
S TIUPICK=+$$CANPICK^TIULP(TITLIFN)
S CANLINK=""
I $G(ATTCHID) S CANLINK=+$$CANLINK^TIULP(TITLIFN)
I 'TIUPICK!(CANLINK=0) S TIUTNM="("_TIUTNM_")"
Q TITLIFN_U_TIUTNM_U_TIUPICK_U_CANLINK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIULA4 4771 printed Apr 09, 2024@21:42:54 Page 2
TIULA4 ; SLC/JER,JM - Check out PUT API's ; 6/13/01
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**10,35,79,103,111,116**;Jun 20, 1997
CLASPICK(PARENT,Y,TYPES) ; Boolean fn to screen selection of classes
+1 NEW TIUY
SET TIUY=0
SET TYPES=$GET(TYPES,"DCCL")
+2 IF ($PIECE(^TIU(8925.1,+Y,0),U,4)]"")
IF $SELECT(TYPES[$PIECE(^TIU(8925.1,+Y,0),U,4):1,(+Y=+$$CLASS^TIUCNSLT):1,1:0)
IF +$$ISA^TIULX(+Y,+PARENT)
IF +$$CANPICK^TIULP(+Y)
SET TIUY=1
+3 QUIT TIUY
DFLTPICK(PARENT,Y,LIST) ; Boolean function to screen selection of Default title
+1 NEW TIUY
SET TIUY=0
+2 IF $PIECE(^TIU(8925.1,+Y,0),U,4)="DOC"
IF +$$ISA^TIULX(+Y,+PARENT)
IF +$$CANPICK^TIULP(+Y)
SET TIUY=1
+3 IF +$GET(LIST)
IF (+$ORDER(^TIU(8925.98,+$GET(LIST),10,0))>0)
IF (+$ORDER(^TIU(8925.98,+$GET(LIST),10,"B",+Y,0))'>0)
SET TIUY=0
+4 QUIT TIUY
LBYPASS() ; Interactive function to determine whether to bypass list
+1 NEW PROMPT
WRITE !
+2 SET PROMPT="Edit (L)ist, (D)efault TITLE, or (B)oth? "
+3 QUIT $PIECE($$READ^TIUU("SA^L:list;D:default;B:both",PROMPT,"BOTH"),U)
TITLPICK(TIUY,CLASS,ATTCHID) ; Select a title
+1 NEW PICK,TITLES,I,L,Y,TIUDFLT,QUIT,DTOUT,DUOUT,CANLINK,PICKNUM
+2 SET CLASS=$GET(CLASS,3)
+3 DO LIST(.TITLES,CLASS,"","",$GET(ATTCHID))
if '+$ORDER(TITLES(0))
QUIT
+4 SET TIUDFLT=$GET(TITLES("DFLT"))
+5 IF TIUDFLT
IF '$PIECE(TITLES(TIUDFLT),U,3)!($GET(ATTCHID)&'$PIECE(TITLES(TIUDFLT),U,4))
SET TIUDFLT=0
SET TIUY("NODFLT")=1
RPT WRITE !!,"Personal ",$$UP^XLFSTR($$PNAME^TIULC1(CLASS))," Title List for "
+1 WRITE $$NAME^TIULS($$PERSNAME^TIULC1(DUZ),"FIRST LAST"),!
+2 SET (I,L,PICK,QUIT,PICKNUM)=0
+3 FOR
SET I=$ORDER(TITLES(I))
if QUIT!(+I'>0)!(+PICK)
QUIT
Begin DoDot:1
+4 WRITE !?3,I,?8,$PIECE(TITLES(I),U,2)
+5 IF I#15=0
Begin DoDot:2
+6 IF +$ORDER(TITLES(I))
Begin DoDot:3
+7 WRITE !!,"Press <RETURN> to see more titles, '^' to exit personal list, or CHOOSE"
+8 ;If more titles, no default
SET Y=$GET(TITLES(+$$PICK(1,I)))
End DoDot:3
IF 1
+9 IF '$TEST
Begin DoDot:3
+10 WRITE !
SET PICKNUM=$$PICK(1,I,+$GET(TIUDFLT))
+11 IF PICKNUM=""
SET QUIT=1
+12 SET Y=$GET(TITLES(+PICKNUM))
+13 IF Y="0^Other Title"
SET QUIT=1
End DoDot:3
+14 IF $DATA(DTOUT)!$DATA(DUOUT)
SET QUIT=1
SET Y=0
+15 IF '$TEST
SET PICK=+Y
End DoDot:2
+16 IF +PICK
SET TIUY(1)=1_U_+Y_$$PNAME^TIULC1(+Y)
SET TIUY=1
+17 SET L=I
End DoDot:1
+18 IF 'QUIT
IF 'PICK
WRITE !
SET Y=$GET(TITLES(+$$PICK(1,L,+$GET(TIUDFLT))))
+19 IF +Y
IF '$PIECE(Y,U,3)
Begin DoDot:1
+20 WRITE !,$CHAR(7),">>> ",$$PNAME^TIULC1(+Y)," is not an ACTIVE title."
+21 WRITE " Please choose another."
+22 WRITE !?4,"You may want to remove it from your list..."
+23 WRITE !?4,"Check with your Clinical Application Coordinator.",!
KILL Y
End DoDot:1
GOTO RPT
+24 IF +Y
IF $GET(ATTCHID)
IF '$PIECE(Y,U,4)
Begin DoDot:1
+25 SET CANLINK=$$CANLINK^TIULP(+Y)
+26 WRITE !,$CHAR(7),">>> ",$PIECE(CANLINK,U,2),!," Please choose another title."
+27 KILL Y
End DoDot:1
GOTO RPT
+28 IF +Y
Begin DoDot:1
+29 SET TIUY(1)=1_U_+Y_U_$$PNAME^TIULC1(+Y)
SET TIUY=1
+30 WRITE " ",$$PNAME^TIULC1(+Y)
End DoDot:1
+31 IF +Y=0
SET (TIUY,TIUY(1))=0
+32 ;If user selected other title, they rejected the default:
+33 IF Y="0^Other Title"
SET TIUY("NODFLT")=1
+34 IF 'Y
Begin DoDot:1
+35 WRITE !,"Exiting NUMBERED personal list.",!
+36 WRITE "Please select other title by NAME:"
End DoDot:1
+37 QUIT
PICK(LOW,HIGH,DFLT) ; List selection
+1 NEW X,Y
+2 IF +$GET(DFLT)
SET Y=$$READ^TIUU("NO^"_LOW_":"_HIGH,"TITLE",DFLT)
IF 1
+3 IF '$TEST
SET Y=$$READ^TIUU("NO^"_LOW_":"_HIGH,"TITLE")
+4 WRITE !
+5 QUIT Y
LIST(TIUY,CLASS,TYPE,TIUK,ATTCHID) ; Get list of document titles
+1 NEW TIUDFLT
+2 SET TIUK=+$GET(TIUK)
+3 IF $GET(TYPE)']""
SET TYPE="DOC"
+4 ; If the user has a preferred list of titles for the CLASS, get it
+5 IF +$ORDER(^TIU(8925.98,"AC",DUZ,CLASS,0))
DO PERSLIST(.TIUY,DUZ,CLASS,.TIUK,ATTCHID)
+6 QUIT
PERSLIST(TIUY,DUZ,CLASS,TIUC,ATTCHID) ; Get personal list for a user
+1 NEW TIUI,TIUDA,LASTSEQ,UNKSEQ,DFLTFL
+2 SET TIUDA=+$ORDER(^TIU(8925.98,"AC",DUZ,CLASS,0))
+3 if +TIUDA'>0
QUIT
+4 SET TIUY("DFLT")=$PIECE($GET(^TIU(8925.98,+TIUDA,0)),U,3)
+5 SET TIUC=+$GET(TIUC)
+6 SET (TIUI,LASTSEQ,UNKSEQ,DFLTFL)=0
+7 FOR
SET TIUI=$ORDER(^TIU(8925.98,TIUDA,10,TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+8 NEW TIUPL,TIUTNM,TIUDTYP,TIUSEQ,TLINE
+9 SET TIUPL=$GET(^TIU(8925.98,TIUDA,10,TIUI,0))
+10 SET TIUDTYP=$PIECE(TIUPL,U)
SET TIUSEQ=+$PIECE(TIUPL,U,2)
+11 IF 'TIUSEQ
SET TIUSEQ=1000+UNKSEQ
SET UNKSEQ=UNKSEQ+1
+12 SET TIUTNM=$SELECT($PIECE(TIUPL,U,3)]"":$PIECE(TIUPL,U,3),1:$$PNAME^TIULC1(+TIUDTYP))
+13 SET TIUC=+$GET(TIUC)+1
+14 SET TLINE=$$TLINE(TIUDTYP,TIUTNM,$GET(ATTCHID))
+15 IF $DATA(TIUY(TIUSEQ))
SET TIUY(1000+UNKSEQ)=TLINE
SET LASTSEQ=1000+UNKSEQ
SET UNKSEQ=UNKSEQ+1
+16 IF '$TEST
SET TIUY(TIUSEQ)=TLINE
+17 IF LASTSEQ<TIUSEQ
SET LASTSEQ=TIUSEQ
+18 IF TIUDTYP=TIUY("DFLT")
SET TIUY("DFLT")=TIUSEQ
SET DFLTFL=1
End DoDot:1
+19 IF DFLTFL=0&($GET(TIUY("DFLT")))
Begin DoDot:1
+20 NEW TIUTNM,DFLTLINE
+21 SET TIUTNM=$$PNAME^TIULC1(+TIUY("DFLT"))
+22 SET DFLTLINE=$$TLINE(+TIUY("DFLT"),TIUTNM,$GET(ATTCHID))
+23 SET TIUY(1000+UNKSEQ)=DFLTLINE
SET TIUY("DFLT")=1000+UNKSEQ
SET LASTSEQ=1000+UNKSEQ
SET UNKSEQ=UNKSEQ+1
End DoDot:1
+24 IF +$GET(LASTSEQ)>0
SET LASTSEQ=LASTSEQ+1
SET TIUY(LASTSEQ)=0_U_"Other Title"
+25 QUIT
+26 ;
TLINE(TITLIFN,TIUTNM,ATTCHID) ; Function returns TitleIFN^Titlename^Canpick (i.e. active)^Canattach (user can attach child ID entries of this title)
+1 NEW TIUPICK,CANLINK
+2 SET TIUPICK=+$$CANPICK^TIULP(TITLIFN)
+3 SET CANLINK=""
+4 IF $GET(ATTCHID)
SET CANLINK=+$$CANLINK^TIULP(TITLIFN)
+5 IF 'TIUPICK!(CANLINK=0)
SET TIUTNM="("_TIUTNM_")"
+6 QUIT TITLIFN_U_TIUTNM_U_TIUPICK_U_CANLINK
