- 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 Jan 18, 2025@03:08:45 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