TIUPLST ; SLC/JER - Enter/edit personal document pick-list ;13-JUL-2000 10:43:41
;;1.0;TEXT INTEGRATION UTILITIES;**91,103**;Jun 20, 1997
MAIN ; Control branching
N DA,TIUFPRIV,DUOUT,DTOUT
S TIUFPRIV=1
D INTROTXT
I $S($D(DUOUT):1,$D(DTOUT):1,$D(DIROUT):1,1:0) Q
D GETEDIT
Q
INTROTXT ; Write Introductory Text for the Option
W !
D JUSTIFY^TIUU("--- Personal Document Lists ---","C")
W !!,"This option allows you to create and maintain lists of TITLES for any of the"
W !,"active CLASSES of documents supported by TIU at your site.",!
I '$$READ^TIUU("Y","Explain Details","NO") Q
W !!,"When you use the option to enter a document belonging to a given class"
W !,"you will be asked to select a TITLE belonging to that class."
W !!,"For any particular class, you may find that you only wish to choose from"
W !,"among a few highly specific titles (e.g., if you are a Pulmonologist"
W !,"entering a PROGRESS NOTE, you may wish to choose from a short list of"
W !,"three or four titles related to Pulmonary Function, or Pulmonary Disease)."
W !,"Rather than presenting you with a list of hundreds of unrelated titles,"
W !,"TIU will present you with the list you name here."
W !!,"In the event that you need to select a TITLE which doesn't appear on your"
W !,"list, you will always be able to do so."
W !!,"NOTE: If you expect to enter a single title, or would be unduely restricted"
W !,"by use of a short list, then we recommend that you bypass the creation of"
W !,"a list, and simply enter a DEFAULT TITLE for the class...This option will"
W !,"afford you the opportunity to do so.",!
Q
GETEDIT ; Get record in picklist file, determine action
N D,DIC,TIUNM,X,Y,CREATE,PROMPT
S TIUNM=$P(^VA(200,+$G(DUZ),0),U)
W !," Enter/edit Personal Document List"
I +$O(^TIU(8925.98,"B",DUZ,0))'>0 D Q
. S Y=+$$NEWLIST(TIUNM,1)
. I +Y>0 D EDIT(+Y)
W !!,"You already have one or more Personal Lists...",!
S PROMPT="You may (E)dit, (D)elete, or (C)reate a List: "
S CREATE=$P($$READ^TIUU("SA^E:edit;D:delete;C:create",PROMPT,"EDIT"),U)
I $S(CREATE="":1,$D(DUOUT):1,$D(DTOUT):1,$D(DIROUT):1,1:0) Q
I CREATE="C" S Y=+$$NEWLIST(TIUNM) D:+Y>0 EDIT(+Y) Q
W !!,"Please choose a list to ",$S(CREATE="E":"Edit",1:"Delete"),"...",!
S DIC=8925.98,DIC(0)="ENZ",D="B",X=DUZ
S DIC("S")="I +$G(^TIU(8925.98,+Y,0))=DUZ"
S DIC("W")="W ?21,"" "",$E($$DOCNAME^TIUPLST($P(^TIU(8925.98,+Y,0),U,2)),1,34)"
D IX^DIC
;TIU*1*91 limit NEWLIST to CREATE=E (If include D & get good Y from NEWLIST, still deletes, never get to edit):
I +Y'>0,CREATE="E" W !!,"No List Selected...",! S Y=+$$NEWLIST(TIUNM,1)
I +Y'>0 W !!,"No changes made..." Q
I CREATE="D" D DELETE(+Y) Q
D EDIT(+Y)
Q
DOCNAME(TIUDA) ; Get the NAME (.01) field of the document
Q $P($G(^TIU(8925.1,+TIUDA,0)),U)
NEWLIST(TIUNM,ASK) ; Create a new List for the user
N ASKNEW,DIC,DLAYGO,Y
S DIC="^TIU(8925.98,",DLAYGO=8925.98,DIC(0)="UNXLZ",ASKNEW=1
I +$G(ASK) S ASKNEW=$$READ^TIUU("Y","Add a new Personal Document List","YES")
I +ASKNEW'>0 S Y=-1 G NEWX
S X=DUZ,D="B"
S X=""""_"`"_X_""""
W !!,"Creating a new Personal Document List...",!
D IX^DIC
;TIU*1*91 If DIC adds new entry, can get anyone w/ same name:
I Y>0,+Y(0)'=DUZ N DA,DIK D
. W !!," Sorry, you can create lists for YOURSELF only. Please try again."
. I $P(Y,U,3)=1 S DA=+Y,DIK="^TIU(8925.98," D ^DIK S Y=-1
NEWX Q +$G(Y)
;
DELETE(DA) ; Call ^DIK to delete the list
N YASURE,TIUNAME S YASURE=0
S TIUNAME=$$UP^XLFSTR($$PNAME^TIULC1($P(^TIU(8925.98,+DA,0),U,2)))
I TIUNAME'="UNKNOWN" D
. W !!,"You are about to DELETE your entry for CLASS "
. W TIUNAME,!
. S YASURE=$$READ^TIUU("Y","Are you SURE","NO")
I TIUNAME="UNKNOWN" D
. W !!,"You must specify a CLASS in order to maintain the list.",!
. S YASURE=1
I +YASURE'>0 W !!,"Nothing deleted...No harm done!" Q
D DIK(DA,TIUNAME)
Q
DIK(DA,TIUNAME) ; Remove a list
N DIK
S DIK="^TIU(8925.98,"
D ^DIK
I $G(TIUNAME)]"" W !,TIUNAME," List DELETED."
Q
EDIT(DA) ; Call ^DIE to edit the record
N DIE,DIRUT,DIROUT,DTOUT,DR,X,Y,TIUCLASS,TIUASK
S DIE=8925.98
S DR="[TIU ENTER/EDIT PERSONAL LIST]"
D ^DIE Q:$D(Y)!$D(DTOUT)
I $G(TIUCLASS)="" D DIK(DA,"")
Q
ALREADY(TIUCLASS) ; Indicate that a List for TIUCLASS already exists
W !!,$C(7),"You already have a list for class ",$$PNAME^TIULC1(TIUCLASS),"."
W !!,"Please Edit that list instead..."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUPLST 4453 printed Dec 13, 2024@02:43:12 Page 2
TIUPLST ; SLC/JER - Enter/edit personal document pick-list ;13-JUL-2000 10:43:41
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**91,103**;Jun 20, 1997
MAIN ; Control branching
+1 NEW DA,TIUFPRIV,DUOUT,DTOUT
+2 SET TIUFPRIV=1
+3 DO INTROTXT
+4 IF $SELECT($DATA(DUOUT):1,$DATA(DTOUT):1,$DATA(DIROUT):1,1:0)
QUIT
+5 DO GETEDIT
+6 QUIT
INTROTXT ; Write Introductory Text for the Option
+1 WRITE !
+2 DO JUSTIFY^TIUU("--- Personal Document Lists ---","C")
+3 WRITE !!,"This option allows you to create and maintain lists of TITLES for any of the"
+4 WRITE !,"active CLASSES of documents supported by TIU at your site.",!
+5 IF '$$READ^TIUU("Y","Explain Details","NO")
QUIT
+6 WRITE !!,"When you use the option to enter a document belonging to a given class"
+7 WRITE !,"you will be asked to select a TITLE belonging to that class."
+8 WRITE !!,"For any particular class, you may find that you only wish to choose from"
+9 WRITE !,"among a few highly specific titles (e.g., if you are a Pulmonologist"
+10 WRITE !,"entering a PROGRESS NOTE, you may wish to choose from a short list of"
+11 WRITE !,"three or four titles related to Pulmonary Function, or Pulmonary Disease)."
+12 WRITE !,"Rather than presenting you with a list of hundreds of unrelated titles,"
+13 WRITE !,"TIU will present you with the list you name here."
+14 WRITE !!,"In the event that you need to select a TITLE which doesn't appear on your"
+15 WRITE !,"list, you will always be able to do so."
+16 WRITE !!,"NOTE: If you expect to enter a single title, or would be unduely restricted"
+17 WRITE !,"by use of a short list, then we recommend that you bypass the creation of"
+18 WRITE !,"a list, and simply enter a DEFAULT TITLE for the class...This option will"
+19 WRITE !,"afford you the opportunity to do so.",!
+20 QUIT
GETEDIT ; Get record in picklist file, determine action
+1 NEW D,DIC,TIUNM,X,Y,CREATE,PROMPT
+2 SET TIUNM=$PIECE(^VA(200,+$GET(DUZ),0),U)
+3 WRITE !," Enter/edit Personal Document List"
+4 IF +$ORDER(^TIU(8925.98,"B",DUZ,0))'>0
Begin DoDot:1
+5 SET Y=+$$NEWLIST(TIUNM,1)
+6 IF +Y>0
DO EDIT(+Y)
End DoDot:1
QUIT
+7 WRITE !!,"You already have one or more Personal Lists...",!
+8 SET PROMPT="You may (E)dit, (D)elete, or (C)reate a List: "
+9 SET CREATE=$PIECE($$READ^TIUU("SA^E:edit;D:delete;C:create",PROMPT,"EDIT"),U)
+10 IF $SELECT(CREATE="":1,$DATA(DUOUT):1,$DATA(DTOUT):1,$DATA(DIROUT):1,1:0)
QUIT
+11 IF CREATE="C"
SET Y=+$$NEWLIST(TIUNM)
if +Y>0
DO EDIT(+Y)
QUIT
+12 WRITE !!,"Please choose a list to ",$SELECT(CREATE="E":"Edit",1:"Delete"),"...",!
+13 SET DIC=8925.98
SET DIC(0)="ENZ"
SET D="B"
SET X=DUZ
+14 SET DIC("S")="I +$G(^TIU(8925.98,+Y,0))=DUZ"
+15 SET DIC("W")="W ?21,"" "",$E($$DOCNAME^TIUPLST($P(^TIU(8925.98,+Y,0),U,2)),1,34)"
+16 DO IX^DIC
+17 ;TIU*1*91 limit NEWLIST to CREATE=E (If include D & get good Y from NEWLIST, still deletes, never get to edit):
+18 IF +Y'>0
IF CREATE="E"
WRITE !!,"No List Selected...",!
SET Y=+$$NEWLIST(TIUNM,1)
+19 IF +Y'>0
WRITE !!,"No changes made..."
QUIT
+20 IF CREATE="D"
DO DELETE(+Y)
QUIT
+21 DO EDIT(+Y)
+22 QUIT
DOCNAME(TIUDA) ; Get the NAME (.01) field of the document
+1 QUIT $PIECE($GET(^TIU(8925.1,+TIUDA,0)),U)
NEWLIST(TIUNM,ASK) ; Create a new List for the user
+1 NEW ASKNEW,DIC,DLAYGO,Y
+2 SET DIC="^TIU(8925.98,"
SET DLAYGO=8925.98
SET DIC(0)="UNXLZ"
SET ASKNEW=1
+3 IF +$GET(ASK)
SET ASKNEW=$$READ^TIUU("Y","Add a new Personal Document List","YES")
+4 IF +ASKNEW'>0
SET Y=-1
GOTO NEWX
+5 SET X=DUZ
SET D="B"
+6 SET X=""""_"`"_X_""""
+7 WRITE !!,"Creating a new Personal Document List...",!
+8 DO IX^DIC
+9 ;TIU*1*91 If DIC adds new entry, can get anyone w/ same name:
+10 IF Y>0
IF +Y(0)'=DUZ
NEW DA,DIK
Begin DoDot:1
+11 WRITE !!," Sorry, you can create lists for YOURSELF only. Please try again."
+12 IF $PIECE(Y,U,3)=1
SET DA=+Y
SET DIK="^TIU(8925.98,"
DO ^DIK
SET Y=-1
End DoDot:1
NEWX QUIT +$GET(Y)
+1 ;
DELETE(DA) ; Call ^DIK to delete the list
+1 NEW YASURE,TIUNAME
SET YASURE=0
+2 SET TIUNAME=$$UP^XLFSTR($$PNAME^TIULC1($PIECE(^TIU(8925.98,+DA,0),U,2)))
+3 IF TIUNAME'="UNKNOWN"
Begin DoDot:1
+4 WRITE !!,"You are about to DELETE your entry for CLASS "
+5 WRITE TIUNAME,!
+6 SET YASURE=$$READ^TIUU("Y","Are you SURE","NO")
End DoDot:1
+7 IF TIUNAME="UNKNOWN"
Begin DoDot:1
+8 WRITE !!,"You must specify a CLASS in order to maintain the list.",!
+9 SET YASURE=1
End DoDot:1
+10 IF +YASURE'>0
WRITE !!,"Nothing deleted...No harm done!"
QUIT
+11 DO DIK(DA,TIUNAME)
+12 QUIT
DIK(DA,TIUNAME) ; Remove a list
+1 NEW DIK
+2 SET DIK="^TIU(8925.98,"
+3 DO ^DIK
+4 IF $GET(TIUNAME)]""
WRITE !,TIUNAME," List DELETED."
+5 QUIT
EDIT(DA) ; Call ^DIE to edit the record
+1 NEW DIE,DIRUT,DIROUT,DTOUT,DR,X,Y,TIUCLASS,TIUASK
+2 SET DIE=8925.98
+3 SET DR="[TIU ENTER/EDIT PERSONAL LIST]"
+4 DO ^DIE
if $DATA(Y)!$DATA(DTOUT)
QUIT
+5 IF $GET(TIUCLASS)=""
DO DIK(DA,"")
+6 QUIT
ALREADY(TIUCLASS) ; Indicate that a List for TIUCLASS already exists
+1 WRITE !!,$CHAR(7),"You already have a list for class ",$$PNAME^TIULC1(TIUCLASS),"."
+2 WRITE !!,"Please Edit that list instead..."
+3 QUIT
