TIUSRVT5 ;SP/WAT - Set/Remove consult lock values for templates and fields ;05/04/20 06:49
;;1.0;TEXT INTEGRATION UTILITIES;**290**;Jun 20, 1997;Build 548
;;ICRs ;;^XPAR 2263 ;;^DIE 2053 ;;^DIR 10026 ;;^DIC 10006
Q
SETCNLOK ;set param value for TIU TEMPLATE CONSULT LOCK and CONSULT LOCK fields in 8927 & 8927.1
N TIUPAR,TIUVAL,TIUERR,TIUTMPL,TIUIEN,TIUCNT,TIUCNLK,TIUARY,TIUY,TIUACT,TIUINST,CHOICE,TIUNEXT,TIULAST,TIUASK,TIUENT,TIUPIEN
;TIUVAL - template name or @ used in EN^XPAR
;TIUINST - instance value for parameter TIUENT - entity for parameter TIUPIEN - parameter IEN from 8989.51
;TIUTMPL - template name
;TIUACT - Add new template to parameter or Remove existing value
;TIUNEXT - next available instance value for parameter; used in DIR call for default response
W @IOF
S TIUPAR="TIU TEMPLATE CONSULT LOCK",TIUINST="",TIUCNT=""
S TIUPIEN=$$FIND1^DIC(8989.51,,"BX",TIUPAR) I $G(TIUPIEN)'>0 W !!,"**TIU TEMPLATE CONSULT LOCK parameter not found!**" Q
D GETENT^XPAREDIT(.TIUENT,TIUPIEN_"^"_TIUPAR)
Q:$G(TIUENT)=""
D GETLST^XPAR(.TIUY,TIUENT,TIUPAR,"N",.TIUERR)
I $G(TIUERR)>0 D ERROR Q
I $G(TIUY)>0 D
. W !,?5,"NUMBER",?20,"TEMPLATE"
. W !,?5,"======",?20,"========"
. F S TIUCNT=$O(TIUY(TIUCNT)) Q:TIUCNT="" D
.. W !,?5,TIUCNT,?20,$P(TIUY(TIUCNT),U,2)
.. S TIULAST=TIUCNT
. W !
N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
I $G(TIUY)>0 D
. S DIR(0)="SB^R:REMOVE;A:ADD"
. S TIUASK="Remove existing template or Add new entry?"
. S DIR("A")=TIUASK
. D ^DIR
Q:$D(DIRUT)!($D(DIROUT))
E S Y="A" K DIR G ADD Q
I Y="R" D I $G(CHOICE)'["^"&($G(CHOICE)'="") D PAR K DIR W !,"... Deleted." Q
. S TIUACT="R"
. I $G(TIUY)=1 S CHOICE=$O(TIUY(""))
. I $G(TIUY)>1 S CHOICE=$$CHOOSE(.TIUY) Q:$G(CHOICE)["^"!($G(CHOICE)="")
. S TIUINST=CHOICE,TIUVAL="@"
. S TIUIEN=$P(TIUY(CHOICE),U)
I $G(CHOICE)["^" K DIR Q
ADD I Y="A" S TIUACT="A" N DIC,X,Y,DTOUT,DUOUT S DIC=8927,DIC(0)="ABE",DIC("S")="I $P(^TIU(8927,Y,0),U,19)[""GMR(123.5""" D ^DIC Q:$D(DTOUT)!($D(DUOUT))!(Y=-1)
S TIUIEN=$P(Y,U),TIUTMPL=$P(Y,U,2)
S TIUVAL=TIUTMPL
S TIUNEXT=$G(TIULAST)+1 ;set lazy but if TIUNEXT is greater than 999, go back for empties
I TIUNEXT=1000 D
. F TIUCNT=1:1:TIUY Q:TIUNEXT<1000 D
.. I '$D(TIUY(TIUCNT)) S TIUNEXT=TIUCNT
N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT S DIR("0")="N^1:999:3^D SCREEN^TIUSRVT5",DIR("?")="Enter a new instance number; one not current in use"
S DIR("B")=TIUNEXT D ^DIR Q:$D(DIRUT)!($D(DIROUT))
S TIUINST=Y K DIR
PAR D EN^XPAR(TIUENT,TIUPAR,TIUINST,TIUVAL,.TIUERR)
I $G(TIUERR)>0 D ERROR Q
;if no error then go set CONSULT LOCK values for template
;get all items for template
D BLD(TIUIEN,.TIUARY)
;TIUCNLK - lock consult template? 1 to set, @ to remove; should be based on if template is added to or removed from the parameter
;set for each template
S TIUCNLK=$S(TIUVAL="@":"@",1:1)
N DIE,DA,DR S DIE="^TIU(8927,",DR=".2///^S X=TIUCNLK"
F TIUCNT=1:1 Q:'$D(TIUARY(TIUCNT)) D
.S DA=TIUARY(TIUCNT)
.L +^TIU(8927,DA):0
.I $T D:+$G(DA)>0 ^DIE L -^TIU(8927,DA)
D FLD
;set for each template field
S TIUCNT="",DIE="^TIU(8927.1,",DR=".17///^S X=TIUCNLK"
F S TIUCNT=$O(^TMP("TIU F",$J,TIUCNT)) Q:TIUCNT="" D
. S DA=$O(^TIU(8927.1,"B",^TMP("TIU F",$J,TIUCNT),""))
. L +^TIU(8927.1,DA):0
. I $T D:+$G(DA)>0 ^DIE L -^TIU(8927.1,DA)
K ^TMP("TIU F",$J)
Q
FLD ;build list of template fields
;TIUARY set in call to BLD
K ^TMP("TIU FIELDS",$J)
N TIUY,TIUFLD,CNT,CNT2,CNT3 S (CNT,CNT2)="",CNT3=1
F S CNT=$O(TIUARY(CNT)) Q:CNT="" D
. D GETBOIL^TIUSRVT(.TIUY,(TIUARY(CNT))) ;TIUY = name of ^TMP(TIU TEMPLATE,$J)
. F S CNT2=$O(@TIUY@(CNT2)) Q:CNT2="" D
.. S ^TMP("TIU FIELDS",$J,CNT3)=@TIUY@(CNT2),CNT3=CNT3+1 ;get every line; possible to have remnant of a wrapped field e.g. "40x2}"
N BEG,END,FIELD,LINE,LNCNT,I,OK,LNWRAP K ^TMP("TIU F",$J) S LNCNT=1,OK=1,I="",LNWRAP=""
F S CNT=$O(^TMP("TIU FIELDS",$J,CNT)) Q:CNT="" D
. S LINE=^TMP("TIU FIELDS",$J,CNT)
. I $L(LNWRAP)>0 S LINE=LNWRAP_LINE,LNWRAP="" ;if length, may need to finish building FLD from previous line of text
. F D Q:END=0
. . S BEG=$FIND(LINE,"{FLD:") I BEG=0 S END=0 Q ;didn't find {FLD:, possible fragmented line
. . S END=$FIND(LINE,"}",BEG)
. . S:END=0 LNWRAP=LINE ; assume a fragment of a FLD, concatenate and check next LINE in template.
. . Q:END=0
. . S FIELD=$E(LINE,BEG,(END-2))
. . S OK=1,I=""
. . F S I=$O(^TMP("TIU F",$J,I)) Q:I=""!(OK=0) D ;prevent dups in ^TMP("TIU F"
. . . S:(FIELD["{FLD")!(FIELD?.E1"}") OK=0 Q ;keep out some junk that GUI editor allows
. . . S:^TMP("TIU F",$J,I)=FIELD OK=0
. . S:OK ^TMP("TIU F",$J,LNCNT)=FIELD,LNCNT=LNCNT+1
. . S LINE=$E(LINE,(END),999)
K ^TMP("TIU FIELDS",$J)
Q
SCREEN ;screen it
N I,OK S OK=0,I=""
F S I=$O(TIUY(I)) Q:I="" D
.S:X=I OK=1
;if you get through the loop and OK=1, value already exists so we must kill it
K:OK X
Q
CHOOSE(TIUY) ;get item to delete
N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,I
S DIR(0)="F^1:3^K:'$D(TIUY(X)) X"
S DIR("A")="Select NUMBER to remove"
S DIR("?")="Enter NUMBER from list above."
D ^DIR
K DIR
Q Y
ERROR ; show it
W !,"ERROR #"_$P(TIUERR,U)
W !,"TEXT: "_$P(TIUERR,U,2),!
Q
BLD(TIUIEN,TIUARY) ; Build array of templates.
;
N TIUIDX
;
S TIUIDX=$O(TIUARY(" "),-1)+1
S TIUARY(TIUIDX)=TIUIEN
S TIUIDX=0
F S TIUIDX=$O(^TIU(8927,TIUIEN,10,TIUIDX)) Q:'TIUIDX D
.D BLD($P(^TIU(8927,TIUIEN,10,TIUIDX,0),U,2),.TIUARY)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUSRVT5 5492 printed Oct 16, 2024@18:46:45 Page 2
TIUSRVT5 ;SP/WAT - Set/Remove consult lock values for templates and fields ;05/04/20 06:49
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**290**;Jun 20, 1997;Build 548
+2 ;;ICRs ;;^XPAR 2263 ;;^DIE 2053 ;;^DIR 10026 ;;^DIC 10006
+3 QUIT
SETCNLOK ;set param value for TIU TEMPLATE CONSULT LOCK and CONSULT LOCK fields in 8927 & 8927.1
+1 NEW TIUPAR,TIUVAL,TIUERR,TIUTMPL,TIUIEN,TIUCNT,TIUCNLK,TIUARY,TIUY,TIUACT,TIUINST,CHOICE,TIUNEXT,TIULAST,TIUASK,TIUENT,TIUPIEN
+2 ;TIUVAL - template name or @ used in EN^XPAR
+3 ;TIUINST - instance value for parameter TIUENT - entity for parameter TIUPIEN - parameter IEN from 8989.51
+4 ;TIUTMPL - template name
+5 ;TIUACT - Add new template to parameter or Remove existing value
+6 ;TIUNEXT - next available instance value for parameter; used in DIR call for default response
+7 WRITE @IOF
+8 SET TIUPAR="TIU TEMPLATE CONSULT LOCK"
SET TIUINST=""
SET TIUCNT=""
+9 SET TIUPIEN=$$FIND1^DIC(8989.51,,"BX",TIUPAR)
IF $GET(TIUPIEN)'>0
WRITE !!,"**TIU TEMPLATE CONSULT LOCK parameter not found!**"
QUIT
+10 DO GETENT^XPAREDIT(.TIUENT,TIUPIEN_"^"_TIUPAR)
+11 if $GET(TIUENT)=""
QUIT
+12 DO GETLST^XPAR(.TIUY,TIUENT,TIUPAR,"N",.TIUERR)
+13 IF $GET(TIUERR)>0
DO ERROR
QUIT
+14 IF $GET(TIUY)>0
Begin DoDot:1
+15 WRITE !,?5,"NUMBER",?20,"TEMPLATE"
+16 WRITE !,?5,"======",?20,"========"
+17 FOR
SET TIUCNT=$ORDER(TIUY(TIUCNT))
if TIUCNT=""
QUIT
Begin DoDot:2
+18 WRITE !,?5,TIUCNT,?20,$PIECE(TIUY(TIUCNT),U,2)
+19 SET TIULAST=TIUCNT
End DoDot:2
+20 WRITE !
End DoDot:1
+21 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+22 IF $GET(TIUY)>0
Begin DoDot:1
+23 SET DIR(0)="SB^R:REMOVE;A:ADD"
+24 SET TIUASK="Remove existing template or Add new entry?"
+25 SET DIR("A")=TIUASK
+26 DO ^DIR
End DoDot:1
+27 if $DATA(DIRUT)!($DATA(DIROUT))
QUIT
+28 IF '$TEST
SET Y="A"
KILL DIR
GOTO ADD
QUIT
+29 IF Y="R"
Begin DoDot:1
+30 SET TIUACT="R"
+31 IF $GET(TIUY)=1
SET CHOICE=$ORDER(TIUY(""))
+32 IF $GET(TIUY)>1
SET CHOICE=$$CHOOSE(.TIUY)
if $GET(CHOICE)["^"!($GET(CHOICE)="")
QUIT
+33 SET TIUINST=CHOICE
SET TIUVAL="@"
+34 SET TIUIEN=$PIECE(TIUY(CHOICE),U)
End DoDot:1
IF $GET(CHOICE)'["^"&($GET(CHOICE)'="")
DO PAR
KILL DIR
WRITE !,"... Deleted."
QUIT
+35 IF $GET(CHOICE)["^"
KILL DIR
QUIT
ADD IF Y="A"
SET TIUACT="A"
NEW DIC,X,Y,DTOUT,DUOUT
SET DIC=8927
SET DIC(0)="ABE"
SET DIC("S")="I $P(^TIU(8927,Y,0),U,19)[""GMR(123.5"""
DO ^DIC
if $DATA(DTOUT)!($DATA(DUOUT))!(Y=-1)
QUIT
+1 SET TIUIEN=$PIECE(Y,U)
SET TIUTMPL=$PIECE(Y,U,2)
+2 SET TIUVAL=TIUTMPL
+3 ;set lazy but if TIUNEXT is greater than 999, go back for empties
SET TIUNEXT=$GET(TIULAST)+1
+4 IF TIUNEXT=1000
Begin DoDot:1
+5 FOR TIUCNT=1:1:TIUY
if TIUNEXT<1000
QUIT
Begin DoDot:2
+6 IF '$DATA(TIUY(TIUCNT))
SET TIUNEXT=TIUCNT
End DoDot:2
End DoDot:1
+7 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
SET DIR("0")="N^1:999:3^D SCREEN^TIUSRVT5"
SET DIR("?")="Enter a new instance number; one not current in use"
+8 SET DIR("B")=TIUNEXT
DO ^DIR
if $DATA(DIRUT)!($DATA(DIROUT))
QUIT
+9 SET TIUINST=Y
KILL DIR
PAR DO EN^XPAR(TIUENT,TIUPAR,TIUINST,TIUVAL,.TIUERR)
+1 IF $GET(TIUERR)>0
DO ERROR
QUIT
+2 ;if no error then go set CONSULT LOCK values for template
+3 ;get all items for template
+4 DO BLD(TIUIEN,.TIUARY)
+5 ;TIUCNLK - lock consult template? 1 to set, @ to remove; should be based on if template is added to or removed from the parameter
+6 ;set for each template
+7 SET TIUCNLK=$SELECT(TIUVAL="@":"@",1:1)
+8 NEW DIE,DA,DR
SET DIE="^TIU(8927,"
SET DR=".2///^S X=TIUCNLK"
+9 FOR TIUCNT=1:1
if '$DATA(TIUARY(TIUCNT))
QUIT
Begin DoDot:1
+10 SET DA=TIUARY(TIUCNT)
+11 LOCK +^TIU(8927,DA):0
+12 IF $TEST
if +$GET(DA)>0
DO ^DIE
LOCK -^TIU(8927,DA)
End DoDot:1
+13 DO FLD
+14 ;set for each template field
+15 SET TIUCNT=""
SET DIE="^TIU(8927.1,"
SET DR=".17///^S X=TIUCNLK"
+16 FOR
SET TIUCNT=$ORDER(^TMP("TIU F",$JOB,TIUCNT))
if TIUCNT=""
QUIT
Begin DoDot:1
+17 SET DA=$ORDER(^TIU(8927.1,"B",^TMP("TIU F",$JOB,TIUCNT),""))
+18 LOCK +^TIU(8927.1,DA):0
+19 IF $TEST
if +$GET(DA)>0
DO ^DIE
LOCK -^TIU(8927.1,DA)
End DoDot:1
+20 KILL ^TMP("TIU F",$JOB)
+21 QUIT
FLD ;build list of template fields
+1 ;TIUARY set in call to BLD
+2 KILL ^TMP("TIU FIELDS",$JOB)
+3 NEW TIUY,TIUFLD,CNT,CNT2,CNT3
SET (CNT,CNT2)=""
SET CNT3=1
+4 FOR
SET CNT=$ORDER(TIUARY(CNT))
if CNT=""
QUIT
Begin DoDot:1
+5 ;TIUY = name of ^TMP(TIU TEMPLATE,$J)
DO GETBOIL^TIUSRVT(.TIUY,(TIUARY(CNT)))
+6 FOR
SET CNT2=$ORDER(@TIUY@(CNT2))
if CNT2=""
QUIT
Begin DoDot:2
+7 ;get every line; possible to have remnant of a wrapped field e.g. "40x2}"
SET ^TMP("TIU FIELDS",$JOB,CNT3)=@TIUY@(CNT2)
SET CNT3=CNT3+1
End DoDot:2
End DoDot:1
+8 NEW BEG,END,FIELD,LINE,LNCNT,I,OK,LNWRAP
KILL ^TMP("TIU F",$JOB)
SET LNCNT=1
SET OK=1
SET I=""
SET LNWRAP=""
+9 FOR
SET CNT=$ORDER(^TMP("TIU FIELDS",$JOB,CNT))
if CNT=""
QUIT
Begin DoDot:1
+10 SET LINE=^TMP("TIU FIELDS",$JOB,CNT)
+11 ;if length, may need to finish building FLD from previous line of text
IF $LENGTH(LNWRAP)>0
SET LINE=LNWRAP_LINE
SET LNWRAP=""
+12 FOR
Begin DoDot:2
+13 ;didn't find {FLD:, possible fragmented line
SET BEG=$FIND(LINE,"{FLD:")
IF BEG=0
SET END=0
QUIT
+14 SET END=$FIND(LINE,"}",BEG)
+15 ; assume a fragment of a FLD, concatenate and check next LINE in template.
if END=0
SET LNWRAP=LINE
+16 if END=0
QUIT
+17 SET FIELD=$EXTRACT(LINE,BEG,(END-2))
+18 SET OK=1
SET I=""
+19 ;prevent dups in ^TMP("TIU F"
FOR
SET I=$ORDER(^TMP("TIU F",$JOB,I))
if I=""!(OK=0)
QUIT
Begin DoDot:3
+20 ;keep out some junk that GUI editor allows
if (FIELD["{FLD")!(FIELD?.E1"}")
SET OK=0
QUIT
+21 if ^TMP("TIU F",$JOB,I)=FIELD
SET OK=0
End DoDot:3
+22 if OK
SET ^TMP("TIU F",$JOB,LNCNT)=FIELD
SET LNCNT=LNCNT+1
+23 SET LINE=$EXTRACT(LINE,(END),999)
End DoDot:2
if END=0
QUIT
End DoDot:1
+24 KILL ^TMP("TIU FIELDS",$JOB)
+25 QUIT
SCREEN ;screen it
+1 NEW I,OK
SET OK=0
SET I=""
+2 FOR
SET I=$ORDER(TIUY(I))
if I=""
QUIT
Begin DoDot:1
+3 if X=I
SET OK=1
End DoDot:1
+4 ;if you get through the loop and OK=1, value already exists so we must kill it
+5 if OK
KILL X
+6 QUIT
CHOOSE(TIUY) ;get item to delete
+1 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,I
+2 SET DIR(0)="F^1:3^K:'$D(TIUY(X)) X"
+3 SET DIR("A")="Select NUMBER to remove"
+4 SET DIR("?")="Enter NUMBER from list above."
+5 DO ^DIR
+6 KILL DIR
+7 QUIT Y
ERROR ; show it
+1 WRITE !,"ERROR #"_$PIECE(TIUERR,U)
+2 WRITE !,"TEXT: "_$PIECE(TIUERR,U,2),!
+3 QUIT
BLD(TIUIEN,TIUARY) ; Build array of templates.
+1 ;
+2 NEW TIUIDX
+3 ;
+4 SET TIUIDX=$ORDER(TIUARY(" "),-1)+1
+5 SET TIUARY(TIUIDX)=TIUIEN
+6 SET TIUIDX=0
+7 FOR
SET TIUIDX=$ORDER(^TIU(8927,TIUIEN,10,TIUIDX))
if 'TIUIDX
QUIT
Begin DoDot:1
+8 DO BLD($PIECE(^TIU(8927,TIUIEN,10,TIUIDX,0),U,2),.TIUARY)
End DoDot:1
+9 QUIT
