LEXDM4 ;ISL/KER - Default Misc - Files/User/Service ;04/21/2014
;;2.0;LEXICON UTILITY;**4,80**;Sep 23, 1996;Build 1
;
; Global Variables
; ^DIC(49) ICR 10093
; ^TMP("LEXIL") SACC 2.3.2.5.1
; ^TMP("LEXMGR") SACC 2.3.2.5.1
; ^TMP("LEXSERV") SACC 2.3.2.5.1
;
; External References
; $$UP^XLFSTR ICR 10103
; MIX^DIC1 ICR 10007
; ^DIC ICR 10006
; ^DIR ICR 10026
;
DFI(LEXX) ; Select one application
N D,DIC,DTOUT,DUOUT I $D(LEXX),LEXX'="" S X=LEXX,DIC(0)="QM"
I '$D(LEXX) S DIC(0)="AQEM" W !
S DIC("W")="W ?45,$P($G(^(5)),U,5)"
S DIC="^LEXT(757.2,",DIC("S")="I +($P($G(^(5)),U,3))>0"
S D="B^C^AN" S DIC("A")="Select application: " D MIX^DIC1 K DIC
S LEXX=$S(+Y>0:+Y,1:0)
Q LEXX
FI(LEXX) ; Select one or more applications
FI2 W ! N LEXMAX,LEXI,LEXA,LEXAI,LEXAN,LEXC,LEXLEN
K ^TMP("LEXIL",$J)
S ^TMP("LEXIL",$J,0)=0
FIB ; Build the list of files/applications
S (LEXAI,LEXC,LEXLEN)=0,(LEXAN,LEXA)=""
F S LEXA=$O(^LEXT(757.2,"ADEF",LEXA)) Q:LEXA="" D
. S LEXI=$O(^LEXT(757.2,"ADEF",LEXA,0))
. S LEXAN=$P(^LEXT(757.2,LEXI,0),U,1)
. Q:$D(^TMP("LEXIL",$J,"B",LEXAN))
. S:$L(LEXAN)>LEXLEN LEXLEN=$L(LEXAN)
. S LEXC=LEXC+1,^TMP("LEXIL",$J,LEXC)=LEXAN_U_LEXI,^TMP("LEXIL",$J,0)=^TMP("LEXIL",$J,0)+1,^TMP("LEXIL",$J,"B",LEXAN)=LEXC,^TMP("LEXIL",$J,"C",$$UP^XLFSTR(LEXAN))=LEXC
I $D(LEXMGR) D ; Pch 4
. S LEXC=+($G(^TMP("LEXIL",$J,0)))+1
. S ^TMP("LEXIL",$J,0)=LEXC,^TMP("LEXIL",$J,LEXC)="All of the Above"
. S ^TMP("LEXIL",$J,"B","All of the Above")=LEXC,^TMP("LEXIL",$J,"C","ALL OF THE ABOVE")=LEXC
. S:$L($G(^TMP("LEXIL",$J,LEXC)))>LEXLEN LEXLEN=$L($G(^TMP("LEXIL",$J,LEXC)))
FIP ; Prompt user
G:'$D(^TMP("LEXIL",$J)) FIQ
W !,"Applications"
FIL ; Display the list
S LEXMAX=^TMP("LEXIL",$J,0)
W ! F LEXI=1:1:^TMP("LEXIL",$J,0) W !,$J(LEXI,6)," ",$E($P(^TMP("LEXIL",$J,LEXI),U,1),1,50)
S LEXX=$$FIS G:LEXX="" FIQ S LEXX=+LEXX I '$D(LEXMGR),+LEXX>0,+LEXX<LEXMAX+1 S LEXX=$P(^TMP("LEXIL",$J,LEXX),U,2) G FIQ
I $D(LEXMGR),+LEXX>0,+LEXX<LEXMAX D G FIQ
. S ^TMP("LEXMGR",$J,"FI",0)=1
. S ^TMP("LEXMGR",$J,"FI",1)=$P(^TMP("LEXIL",$J,LEXX),U,2)_U_$S($P(^TMP("LEXIL",$J,LEXX),U,1)'[" (":$P(^TMP("LEXIL",$J,LEXX),U,1),1:$P($P(^TMP("LEXIL",$J,LEXX),U,1)," (",1))
. S LEXX=$P(^TMP("LEXIL",$J,LEXX),U,2)
I $D(LEXMGR),LEXX=LEXMAX S LEXX="" D G FIQ
. F LEXI=1:1:^TMP("LEXIL",$J,0) D
. . S ^TMP("LEXMGR",$J,"FI",LEXI)=$P(^TMP("LEXIL",$J,LEXI),U,2)_U_$S($P(^TMP("LEXIL",$J,LEXI),U,1)'[" (":$P(^TMP("LEXIL",$J,LEXI),U,1),1:$P($P(^TMP("LEXIL",$J,LEXI),U,1)," (",1))
. . S LEXX=LEXX_";"_$P(^TMP("LEXIL",$J,LEXI),U,2)
. . S ^TMP("LEXMGR",$J,"FI",0)=LEXI
. F Q:$E(LEXX,1)'=";" S LEXX=$E(LEXX,2,$L(LEXX))
. F Q:$E(LEXX,$L(LEXX))'=";" S LEXX=$E(LEXX,1,($L(LEXX)-1))
G FIP Q
FIS(X) ; Select from the list
W ! N Y,DIR,DIC,DTOUT,DUOUT,DIRUT,DIROUT
S LEXLEN=+($G(LEXLEN)) S:LEXLEN=0 LEXLEN=15
S DIR("A")="Select (1-"_LEXMAX_"): "
S DIR("?")="^D FIHLP^LEXDM4"
S DIR(0)="FAO^1:"_LEXLEN_"^S X=+($$FIW^LEXDM4(X)) K:'X X" ; PCH 4
D ^DIR S:$D(DTOUT)!($D(DUOUT)) X="" S:$L(X) X=$$FIW(X) Q X ; PCH 4
FIHLP ; Help for selection
I $D(LEXMGR) D
. W !!,"User defaults for both the Lexicon and applications using the Lexicon"
. W !,"(by agreement) will be stored along with their application definitions"
. W !,"contained in the Subset Definition File."
. W !!,"You may set user defaults for one or all of the listed applications"
I '$D(LEXMGR) D
. W !!,"User defaults for the Lexicon may be set for individual applications."
. W !!!,"Select an application:"
S LEXMAX=^TMP("LEXIL",$J,0) S:$D(LEXMGR) LEXMAX=LEXMAX+1
W ! F LEXI=1:1:^TMP("LEXIL",$J,0) D
. W !,$J(LEXI,6)," ",$E($P(^TMP("LEXIL",$J,LEXI),U,1),1,50)
Q
FIQ ; Quit application selection
K ^TMP("LEXIL",$J),^TMP("LEXMGR",$J)
K LEXA,LEXAI,LEXAN,LEXC,LEXI,LEXMAX
Q LEXX
FIW(LEXX) ; Input transform for DIR Pch 4
S LEXX=$G(LEXX) S:$G(LEXX)["^" LEXX="^" Q:LEXX["^" LEXX Q:$G(LEXX)="" ""
I +($G(LEXX))>0,$D(^TMP("LEXIL",$J,+($G(LEXX)))) S LEXX=+($G(LEXX)) Q LEXX
N LEXU,LEXO,LEXOC,LEXCT S LEXU=$TR($G(LEXX),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") Q:'$L(LEXU) LEXX
S LEXCT=0,(LEXO,LEXOC)=$E(LEXU,1,($L(LEXU)-1))_$C($A($E(LEXU,$L(LEXU)))-1)_"~"
F S LEXOC=$O(^TMP("LEXIL",$J,"C",LEXOC)) Q:LEXOC=""!($E(LEXOC,1,$L(LEXU))'=LEXU) S LEXCT=LEXCT+1
S LEXOC="" I LEXCT=1 S LEXOC=$O(^TMP("LEXIL",$J,"C",LEXO)),LEXOC=+($G(^TMP("LEXIL",$J,"C",LEXOC)))
I +LEXOC>0,$D(^TMP("LEXIL",$J,+LEXOC)) S LEXX=+LEXOC Q LEXX
Q ""
SERV(LEXX) ; Select a service
S DIC="^DIC(49,",DIC("A")="Select users by service: ",DIC(0)="AMEQ"
N LEXI S LEXI="" F S LEXI=$O(^DIC(49,"B",LEXI)) Q:LEXI="" D Q:LEXI=""
. I LEXI["MEDI",((LEXI["GEN")!(LEXI["INTER")) S ^TMP("LEXSERV",$J,1)=$O(^DIC(49,"B",LEXI,0))
. I LEXI["AMBULAT" S ^TMP("LEXSERV",$J,2)=$O(^DIC(49,"B",LEXI,0))
. I LEXI["OUT",LEXI["PAT" S ^TMP("LEXSERV",$J,2)=$O(^DIC(49,"B",LEXI,0))
I $D(^TMP("LEXSERV",$J,1)) S DIC("B")=$P(^DIC(49,^TMP("LEXSERV",$J,1),0),U,1) K ^TMP("LEXSERV",$J)
I $D(^TMP("LEXSERV",$J,2)) S DIC("B")=$P(^DIC(49,^TMP("LEXSERV",$J,2),0),U,1)
K ^TMP("LEXSERV",$J) D ^DIC S LEXX=Y W:+Y'>0 " No Service Selected"
S:X["^" LEXX="^" S:X["^^" LEXX="^^" K LEXI,Y,X,DIC,DIC("A"),DIC(0),DIC("B")
S:LEXX'[U&(+LEXX'>0) LEXX=""
Q LEXX
USER(LEXX) ; Select a single user
K DIC N X,Y S DIC="^VA(200,",DIC("A")="Select a single user: ",DIC(0)="AMEQ"
D ^DIC S LEXX=Y W:+Y'>0 " No User Selected"
S:X["^" LEXX="^" S:X["^^" LEXX="^^" K Y,X,DIC,DIC("A"),DIC(0),DIC("B")
S:LEXX'[U&(+LEXX'>0) LEXX=""
Q LEXX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXDM4 5723 printed Oct 16, 2024@18:08:31 Page 2
LEXDM4 ;ISL/KER - Default Misc - Files/User/Service ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**4,80**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^DIC(49) ICR 10093
+5 ; ^TMP("LEXIL") SACC 2.3.2.5.1
+6 ; ^TMP("LEXMGR") SACC 2.3.2.5.1
+7 ; ^TMP("LEXSERV") SACC 2.3.2.5.1
+8 ;
+9 ; External References
+10 ; $$UP^XLFSTR ICR 10103
+11 ; MIX^DIC1 ICR 10007
+12 ; ^DIC ICR 10006
+13 ; ^DIR ICR 10026
+14 ;
DFI(LEXX) ; Select one application
+1 NEW D,DIC,DTOUT,DUOUT
IF $DATA(LEXX)
IF LEXX'=""
SET X=LEXX
SET DIC(0)="QM"
+2 IF '$DATA(LEXX)
SET DIC(0)="AQEM"
WRITE !
+3 SET DIC("W")="W ?45,$P($G(^(5)),U,5)"
+4 SET DIC="^LEXT(757.2,"
SET DIC("S")="I +($P($G(^(5)),U,3))>0"
+5 SET D="B^C^AN"
SET DIC("A")="Select application: "
DO MIX^DIC1
KILL DIC
+6 SET LEXX=$SELECT(+Y>0:+Y,1:0)
+7 QUIT LEXX
FI(LEXX) ; Select one or more applications
FI2 WRITE !
NEW LEXMAX,LEXI,LEXA,LEXAI,LEXAN,LEXC,LEXLEN
+1 KILL ^TMP("LEXIL",$JOB)
+2 SET ^TMP("LEXIL",$JOB,0)=0
FIB ; Build the list of files/applications
+1 SET (LEXAI,LEXC,LEXLEN)=0
SET (LEXAN,LEXA)=""
+2 FOR
SET LEXA=$ORDER(^LEXT(757.2,"ADEF",LEXA))
if LEXA=""
QUIT
Begin DoDot:1
+3 SET LEXI=$ORDER(^LEXT(757.2,"ADEF",LEXA,0))
+4 SET LEXAN=$PIECE(^LEXT(757.2,LEXI,0),U,1)
+5 if $DATA(^TMP("LEXIL",$JOB,"B",LEXAN))
QUIT
+6 if $LENGTH(LEXAN)>LEXLEN
SET LEXLEN=$LENGTH(LEXAN)
+7 SET LEXC=LEXC+1
SET ^TMP("LEXIL",$JOB,LEXC)=LEXAN_U_LEXI
SET ^TMP("LEXIL",$JOB,0)=^TMP("LEXIL",$JOB,0)+1
SET ^TMP("LEXIL",$JOB,"B",LEXAN)=LEXC
SET ^TMP("LEXIL",$JOB,"C",$$UP^XLFSTR(LEXAN))=LEXC
End DoDot:1
+8 ; Pch 4
IF $DATA(LEXMGR)
Begin DoDot:1
+9 SET LEXC=+($GET(^TMP("LEXIL",$JOB,0)))+1
+10 SET ^TMP("LEXIL",$JOB,0)=LEXC
SET ^TMP("LEXIL",$JOB,LEXC)="All of the Above"
+11 SET ^TMP("LEXIL",$JOB,"B","All of the Above")=LEXC
SET ^TMP("LEXIL",$JOB,"C","ALL OF THE ABOVE")=LEXC
+12 if $LENGTH($GET(^TMP("LEXIL",$JOB,LEXC)))>LEXLEN
SET LEXLEN=$LENGTH($GET(^TMP("LEXIL",$JOB,LEXC)))
End DoDot:1
FIP ; Prompt user
+1 if '$DATA(^TMP("LEXIL",$JOB))
GOTO FIQ
+2 WRITE !,"Applications"
FIL ; Display the list
+1 SET LEXMAX=^TMP("LEXIL",$JOB,0)
+2 WRITE !
FOR LEXI=1:1:^TMP("LEXIL",$JOB,0)
WRITE !,$JUSTIFY(LEXI,6)," ",$EXTRACT($PIECE(^TMP("LEXIL",$JOB,LEXI),U,1),1,50)
+3 SET LEXX=$$FIS
if LEXX=""
GOTO FIQ
SET LEXX=+LEXX
IF '$DATA(LEXMGR)
IF +LEXX>0
IF +LEXX<LEXMAX+1
SET LEXX=$PIECE(^TMP("LEXIL",$JOB,LEXX),U,2)
GOTO FIQ
+4 IF $DATA(LEXMGR)
IF +LEXX>0
IF +LEXX<LEXMAX
Begin DoDot:1
+5 SET ^TMP("LEXMGR",$JOB,"FI",0)=1
+6 SET ^TMP("LEXMGR",$JOB,"FI",1)=$PIECE(^TMP("LEXIL",$JOB,LEXX),U,2)_U_$SELECT($PIECE(^TMP("LEXIL",$JOB,LEXX),U,1)'[" (":$PIECE(^TMP("LEXIL",$JOB,LEXX),U,1),1:$PIECE($PIECE(^TMP("LEXIL",$JOB,LEXX),U,1)," (",1))
+7 SET LEXX=$PIECE(^TMP("LEXIL",$JOB,LEXX),U,2)
End DoDot:1
GOTO FIQ
+8 IF $DATA(LEXMGR)
IF LEXX=LEXMAX
SET LEXX=""
Begin DoDot:1
+9 FOR LEXI=1:1:^TMP("LEXIL",$JOB,0)
Begin DoDot:2
+10 SET ^TMP("LEXMGR",$JOB,"FI",LEXI)=$PIECE(^TMP("LEXIL",$JOB,LEXI),U,2)_U_$SELECT($PIECE(^TMP("LEXIL",$JOB,LEXI),U,1)'[" (":$PIECE(^TMP("LEXIL",$JOB,LEXI),U,1),1:$PIECE($PIECE(^TMP("LEXIL",$JOB,LEXI),U,1)," (",1))
+11 SET LEXX=LEXX_";"_$PIECE(^TMP("LEXIL",$JOB,LEXI),U,2)
+12 SET ^TMP("LEXMGR",$JOB,"FI",0)=LEXI
End DoDot:2
+13 FOR
if $EXTRACT(LEXX,1)'=";"
QUIT
SET LEXX=$EXTRACT(LEXX,2,$LENGTH(LEXX))
+14 FOR
if $EXTRACT(LEXX,$LENGTH(LEXX))'=";"
QUIT
SET LEXX=$EXTRACT(LEXX,1,($LENGTH(LEXX)-1))
End DoDot:1
GOTO FIQ
+15 GOTO FIP
QUIT
FIS(X) ; Select from the list
+1 WRITE !
NEW Y,DIR,DIC,DTOUT,DUOUT,DIRUT,DIROUT
+2 SET LEXLEN=+($GET(LEXLEN))
if LEXLEN=0
SET LEXLEN=15
+3 SET DIR("A")="Select (1-"_LEXMAX_"): "
+4 SET DIR("?")="^D FIHLP^LEXDM4"
+5 ; PCH 4
SET DIR(0)="FAO^1:"_LEXLEN_"^S X=+($$FIW^LEXDM4(X)) K:'X X"
+6 ; PCH 4
DO ^DIR
if $DATA(DTOUT)!($DATA(DUOUT))
SET X=""
if $LENGTH(X)
SET X=$$FIW(X)
QUIT X
FIHLP ; Help for selection
+1 IF $DATA(LEXMGR)
Begin DoDot:1
+2 WRITE !!,"User defaults for both the Lexicon and applications using the Lexicon"
+3 WRITE !,"(by agreement) will be stored along with their application definitions"
+4 WRITE !,"contained in the Subset Definition File."
+5 WRITE !!,"You may set user defaults for one or all of the listed applications"
End DoDot:1
+6 IF '$DATA(LEXMGR)
Begin DoDot:1
+7 WRITE !!,"User defaults for the Lexicon may be set for individual applications."
+8 WRITE !!!,"Select an application:"
End DoDot:1
+9 SET LEXMAX=^TMP("LEXIL",$JOB,0)
if $DATA(LEXMGR)
SET LEXMAX=LEXMAX+1
+10 WRITE !
FOR LEXI=1:1:^TMP("LEXIL",$JOB,0)
Begin DoDot:1
+11 WRITE !,$JUSTIFY(LEXI,6)," ",$EXTRACT($PIECE(^TMP("LEXIL",$JOB,LEXI),U,1),1,50)
End DoDot:1
+12 QUIT
FIQ ; Quit application selection
+1 KILL ^TMP("LEXIL",$JOB),^TMP("LEXMGR",$JOB)
+2 KILL LEXA,LEXAI,LEXAN,LEXC,LEXI,LEXMAX
+3 QUIT LEXX
FIW(LEXX) ; Input transform for DIR Pch 4
+1 SET LEXX=$GET(LEXX)
if $GET(LEXX)["^"
SET LEXX="^"
if LEXX["^"
QUIT LEXX
if $GET(LEXX)=""
QUIT ""
+2 IF +($GET(LEXX))>0
IF $DATA(^TMP("LEXIL",$JOB,+($GET(LEXX))))
SET LEXX=+($GET(LEXX))
QUIT LEXX
+3 NEW LEXU,LEXO,LEXOC,LEXCT
SET LEXU=$TRANSLATE($GET(LEXX),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
if '$LENGTH(LEXU)
QUIT LEXX
+4 SET LEXCT=0
SET (LEXO,LEXOC)=$EXTRACT(LEXU,1,($LENGTH(LEXU)-1))_$CHAR($ASCII($EXTRACT(LEXU,$LENGTH(LEXU)))-1)_"~"
+5 FOR
SET LEXOC=$ORDER(^TMP("LEXIL",$JOB,"C",LEXOC))
if LEXOC=""!($EXTRACT(LEXOC,1,$LENGTH(LEXU))'=LEXU)
QUIT
SET LEXCT=LEXCT+1
+6 SET LEXOC=""
IF LEXCT=1
SET LEXOC=$ORDER(^TMP("LEXIL",$JOB,"C",LEXO))
SET LEXOC=+($GET(^TMP("LEXIL",$JOB,"C",LEXOC)))
+7 IF +LEXOC>0
IF $DATA(^TMP("LEXIL",$JOB,+LEXOC))
SET LEXX=+LEXOC
QUIT LEXX
+8 QUIT ""
SERV(LEXX) ; Select a service
+1 SET DIC="^DIC(49,"
SET DIC("A")="Select users by service: "
SET DIC(0)="AMEQ"
+2 NEW LEXI
SET LEXI=""
FOR
SET LEXI=$ORDER(^DIC(49,"B",LEXI))
if LEXI=""
QUIT
Begin DoDot:1
+3 IF LEXI["MEDI"
IF ((LEXI["GEN")!(LEXI["INTER"))
SET ^TMP("LEXSERV",$JOB,1)=$ORDER(^DIC(49,"B",LEXI,0))
+4 IF LEXI["AMBULAT"
SET ^TMP("LEXSERV",$JOB,2)=$ORDER(^DIC(49,"B",LEXI,0))
+5 IF LEXI["OUT"
IF LEXI["PAT"
SET ^TMP("LEXSERV",$JOB,2)=$ORDER(^DIC(49,"B",LEXI,0))
End DoDot:1
if LEXI=""
QUIT
+6 IF $DATA(^TMP("LEXSERV",$JOB,1))
SET DIC("B")=$PIECE(^DIC(49,^TMP("LEXSERV",$JOB,1),0),U,1)
KILL ^TMP("LEXSERV",$JOB)
+7 IF $DATA(^TMP("LEXSERV",$JOB,2))
SET DIC("B")=$PIECE(^DIC(49,^TMP("LEXSERV",$JOB,2),0),U,1)
+8 KILL ^TMP("LEXSERV",$JOB)
DO ^DIC
SET LEXX=Y
if +Y'>0
WRITE " No Service Selected"
+9 if X["^"
SET LEXX="^"
if X["^^"
SET LEXX="^^"
KILL LEXI,Y,X,DIC,DIC("A"),DIC(0),DIC("B")
+10 if LEXX'[U&(+LEXX'>0)
SET LEXX=""
+11 QUIT LEXX
USER(LEXX) ; Select a single user
+1 KILL DIC
NEW X,Y
SET DIC="^VA(200,"
SET DIC("A")="Select a single user: "
SET DIC(0)="AMEQ"
+2 DO ^DIC
SET LEXX=Y
if +Y'>0
WRITE " No User Selected"
+3 if X["^"
SET LEXX="^"
if X["^^"
SET LEXX="^^"
KILL Y,X,DIC,DIC("A"),DIC(0),DIC("B")
+4 if LEXX'[U&(+LEXX'>0)
SET LEXX=""
+5 QUIT LEXX
