TIULA4.m

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 ---TIULA4   4771     printed  Feb 19, 2025@00:08:30                                                                                                                                                                                                      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