Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LEXDM4

LEXDM4.m

Go to the documentation of this file.
  1. LEXDM4 ;ISL/KER - Default Misc - Files/User/Service ;04/21/2014
  1. ;;2.0;LEXICON UTILITY;**4,80**;Sep 23, 1996;Build 1
  1. ;
  1. ; Global Variables
  1. ; ^DIC(49) ICR 10093
  1. ; ^TMP("LEXIL") SACC 2.3.2.5.1
  1. ; ^TMP("LEXMGR") SACC 2.3.2.5.1
  1. ; ^TMP("LEXSERV") SACC 2.3.2.5.1
  1. ;
  1. ; External References
  1. ; $$UP^XLFSTR ICR 10103
  1. ; MIX^DIC1 ICR 10007
  1. ; ^DIC ICR 10006
  1. ; ^DIR ICR 10026
  1. ;
  1. DFI(LEXX) ; Select one application
  1. N D,DIC,DTOUT,DUOUT I $D(LEXX),LEXX'="" S X=LEXX,DIC(0)="QM"
  1. I '$D(LEXX) S DIC(0)="AQEM" W !
  1. S DIC("W")="W ?45,$P($G(^(5)),U,5)"
  1. S DIC="^LEXT(757.2,",DIC("S")="I +($P($G(^(5)),U,3))>0"
  1. S D="B^C^AN" S DIC("A")="Select application: " D MIX^DIC1 K DIC
  1. S LEXX=$S(+Y>0:+Y,1:0)
  1. Q LEXX
  1. FI(LEXX) ; Select one or more applications
  1. FI2 W ! N LEXMAX,LEXI,LEXA,LEXAI,LEXAN,LEXC,LEXLEN
  1. K ^TMP("LEXIL",$J)
  1. S ^TMP("LEXIL",$J,0)=0
  1. FIB ; Build the list of files/applications
  1. S (LEXAI,LEXC,LEXLEN)=0,(LEXAN,LEXA)=""
  1. F S LEXA=$O(^LEXT(757.2,"ADEF",LEXA)) Q:LEXA="" D
  1. . S LEXI=$O(^LEXT(757.2,"ADEF",LEXA,0))
  1. . S LEXAN=$P(^LEXT(757.2,LEXI,0),U,1)
  1. . Q:$D(^TMP("LEXIL",$J,"B",LEXAN))
  1. . S:$L(LEXAN)>LEXLEN LEXLEN=$L(LEXAN)
  1. . 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
  1. I $D(LEXMGR) D ; Pch 4
  1. . S LEXC=+($G(^TMP("LEXIL",$J,0)))+1
  1. . S ^TMP("LEXIL",$J,0)=LEXC,^TMP("LEXIL",$J,LEXC)="All of the Above"
  1. . S ^TMP("LEXIL",$J,"B","All of the Above")=LEXC,^TMP("LEXIL",$J,"C","ALL OF THE ABOVE")=LEXC
  1. . S:$L($G(^TMP("LEXIL",$J,LEXC)))>LEXLEN LEXLEN=$L($G(^TMP("LEXIL",$J,LEXC)))
  1. FIP ; Prompt user
  1. G:'$D(^TMP("LEXIL",$J)) FIQ
  1. W !,"Applications"
  1. FIL ; Display the list
  1. S LEXMAX=^TMP("LEXIL",$J,0)
  1. W ! F LEXI=1:1:^TMP("LEXIL",$J,0) W !,$J(LEXI,6)," ",$E($P(^TMP("LEXIL",$J,LEXI),U,1),1,50)
  1. 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
  1. I $D(LEXMGR),+LEXX>0,+LEXX<LEXMAX D G FIQ
  1. . S ^TMP("LEXMGR",$J,"FI",0)=1
  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))
  1. . S LEXX=$P(^TMP("LEXIL",$J,LEXX),U,2)
  1. I $D(LEXMGR),LEXX=LEXMAX S LEXX="" D G FIQ
  1. . F LEXI=1:1:^TMP("LEXIL",$J,0) D
  1. . . 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))
  1. . . S LEXX=LEXX_";"_$P(^TMP("LEXIL",$J,LEXI),U,2)
  1. . . S ^TMP("LEXMGR",$J,"FI",0)=LEXI
  1. . F Q:$E(LEXX,1)'=";" S LEXX=$E(LEXX,2,$L(LEXX))
  1. . F Q:$E(LEXX,$L(LEXX))'=";" S LEXX=$E(LEXX,1,($L(LEXX)-1))
  1. G FIP Q
  1. FIS(X) ; Select from the list
  1. W ! N Y,DIR,DIC,DTOUT,DUOUT,DIRUT,DIROUT
  1. S LEXLEN=+($G(LEXLEN)) S:LEXLEN=0 LEXLEN=15
  1. S DIR("A")="Select (1-"_LEXMAX_"): "
  1. S DIR("?")="^D FIHLP^LEXDM4"
  1. S DIR(0)="FAO^1:"_LEXLEN_"^S X=+($$FIW^LEXDM4(X)) K:'X X" ; PCH 4
  1. D ^DIR S:$D(DTOUT)!($D(DUOUT)) X="" S:$L(X) X=$$FIW(X) Q X ; PCH 4
  1. FIHLP ; Help for selection
  1. I $D(LEXMGR) D
  1. . W !!,"User defaults for both the Lexicon and applications using the Lexicon"
  1. . W !,"(by agreement) will be stored along with their application definitions"
  1. . W !,"contained in the Subset Definition File."
  1. . W !!,"You may set user defaults for one or all of the listed applications"
  1. I '$D(LEXMGR) D
  1. . W !!,"User defaults for the Lexicon may be set for individual applications."
  1. . W !!!,"Select an application:"
  1. S LEXMAX=^TMP("LEXIL",$J,0) S:$D(LEXMGR) LEXMAX=LEXMAX+1
  1. W ! F LEXI=1:1:^TMP("LEXIL",$J,0) D
  1. . W !,$J(LEXI,6)," ",$E($P(^TMP("LEXIL",$J,LEXI),U,1),1,50)
  1. Q
  1. FIQ ; Quit application selection
  1. K ^TMP("LEXIL",$J),^TMP("LEXMGR",$J)
  1. K LEXA,LEXAI,LEXAN,LEXC,LEXI,LEXMAX
  1. Q LEXX
  1. FIW(LEXX) ; Input transform for DIR Pch 4
  1. S LEXX=$G(LEXX) S:$G(LEXX)["^" LEXX="^" Q:LEXX["^" LEXX Q:$G(LEXX)="" ""
  1. I +($G(LEXX))>0,$D(^TMP("LEXIL",$J,+($G(LEXX)))) S LEXX=+($G(LEXX)) Q LEXX
  1. N LEXU,LEXO,LEXOC,LEXCT S LEXU=$TR($G(LEXX),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") Q:'$L(LEXU) LEXX
  1. S LEXCT=0,(LEXO,LEXOC)=$E(LEXU,1,($L(LEXU)-1))_$C($A($E(LEXU,$L(LEXU)))-1)_"~"
  1. F S LEXOC=$O(^TMP("LEXIL",$J,"C",LEXOC)) Q:LEXOC=""!($E(LEXOC,1,$L(LEXU))'=LEXU) S LEXCT=LEXCT+1
  1. S LEXOC="" I LEXCT=1 S LEXOC=$O(^TMP("LEXIL",$J,"C",LEXO)),LEXOC=+($G(^TMP("LEXIL",$J,"C",LEXOC)))
  1. I +LEXOC>0,$D(^TMP("LEXIL",$J,+LEXOC)) S LEXX=+LEXOC Q LEXX
  1. Q ""
  1. SERV(LEXX) ; Select a service
  1. S DIC="^DIC(49,",DIC("A")="Select users by service: ",DIC(0)="AMEQ"
  1. N LEXI S LEXI="" F S LEXI=$O(^DIC(49,"B",LEXI)) Q:LEXI="" D Q:LEXI=""
  1. . I LEXI["MEDI",((LEXI["GEN")!(LEXI["INTER")) S ^TMP("LEXSERV",$J,1)=$O(^DIC(49,"B",LEXI,0))
  1. . I LEXI["AMBULAT" S ^TMP("LEXSERV",$J,2)=$O(^DIC(49,"B",LEXI,0))
  1. . I LEXI["OUT",LEXI["PAT" S ^TMP("LEXSERV",$J,2)=$O(^DIC(49,"B",LEXI,0))
  1. I $D(^TMP("LEXSERV",$J,1)) S DIC("B")=$P(^DIC(49,^TMP("LEXSERV",$J,1),0),U,1) K ^TMP("LEXSERV",$J)
  1. I $D(^TMP("LEXSERV",$J,2)) S DIC("B")=$P(^DIC(49,^TMP("LEXSERV",$J,2),0),U,1)
  1. K ^TMP("LEXSERV",$J) D ^DIC S LEXX=Y W:+Y'>0 " No Service Selected"
  1. S:X["^" LEXX="^" S:X["^^" LEXX="^^" K LEXI,Y,X,DIC,DIC("A"),DIC(0),DIC("B")
  1. S:LEXX'[U&(+LEXX'>0) LEXX=""
  1. Q LEXX
  1. USER(LEXX) ; Select a single user
  1. K DIC N X,Y S DIC="^VA(200,",DIC("A")="Select a single user: ",DIC(0)="AMEQ"
  1. D ^DIC S LEXX=Y W:+Y'>0 " No User Selected"
  1. S:X["^" LEXX="^" S:X["^^" LEXX="^^" K Y,X,DIC,DIC("A"),DIC(0),DIC("B")
  1. S:LEXX'[U&(+LEXX'>0) LEXX=""
  1. Q LEXX