- LEXSET2 ;ISL/KER - Retrieve Appl/Sub/Mode/User Defaults ;04/21/2014
- ;;2.0;LEXICON UTILITY;**6,80**;Sep 23, 1996;Build 1
- ;
- APP(LEXA) ; Application
- K LEXD("AP") N LEXT,LEXI S LEXA=+($G(LEXA))
- Q:LEXA=0 Q:'$D(^LEXT(757.2,LEXA)) Q:$P($G(^LEXT(757.2,LEXA,5)),"^",5)=""
- S LEXT="AP",LEXI=LEXA D COMMON
- S:$L($G(^LEXT(757.2,LEXI,7))) LEXD(LEXT,"DIS")=$G(^LEXT(757.2,LEXI,7))
- S LEXD(LEXT,"UNR")=+($P($G(^LEXT(757.2,LEXI,5)),"^",6))
- S LEXD(LEXT,"DEF")=+($P($G(^LEXT(757.2,LEXI,5)),"^",3))
- S LEXD(LEXT,"SCT")=+($P($G(^LEXT(757.2,LEXI,5)),"^",8))
- ; Modifiers PCH 6
- S LEXD(LEXT,"MOD")=+($P($G(^LEXT(757.2,LEXI,5)),"^",9))
- K:+(LEXD(LEXT,"SCT"))=0 LEXD(LEXT,"SCT")
- S LEXD(LEXT,"FIL")=$G(^LEXT(757.2,LEXI,6))
- S LEXD("DF","UNR")=+($P($G(^LEXT(757.2,LEXI,5)),"^",6))
- S LEXD(LEXT,"SUB")=$P($G(^LEXT(757.2,LEXI,5)),"^",2)
- S:LEXD(LEXT,"SUB")="" LEXD(LEXT,"SUB")="WRD"
- S LEXD(LEXT,"IDX")="A"_LEXD(LEXT,"SUB")
- Q
- SUB(LEXS) ; Subset
- K LEXD("SS") N LEXT,LEXI S LEXS=+($G(LEXS))
- Q:LEXS=0 Q:'$D(^LEXT(757.2,LEXS)) Q:$P($G(^LEXT(757.2,LEXS,0)),"^",2)=""
- S LEXT="SS",LEXI=LEXS D COMMON
- S:$L($G(^LEXT(757.2,LEXI,4))) LEXD(LEXT,"DIS")=$G(^LEXT(757.2,LEXI,4))
- S LEXD(LEXT,"SCT")=+($P($G(^LEXT(757.2,LEXI,5)),"^",8))
- K:+(LEXD(LEXT,"SCT"))=0 LEXD(LEXT,"SCT")
- ; Modifiers PCH 6
- S LEXD(LEXT,"MOD")=+($P($G(^LEXT(757.2,LEXI,5)),"^",9))
- S LEXD(LEXT,"FIL")=$G(^LEXT(757.2,LEXI,6))
- S LEXD(LEXT,"SUB")=$P($G(^LEXT(757.2,LEXI,0)),"^",2)
- S:LEXD(LEXT,"SUB")="" LEXD(LEXT,"SUB")="WRD"
- S LEXD(LEXT,"IDX")="A"_LEXD(LEXT,"SUB")
- Q
- GEN S LEXD("DF","OVR")=0 S:$G(LEXD("AP","OVR"))=1!($G(LEXD("SS","OVR"))=1) LEXD("DF","OVR")=1
- Q
- MOD(LEXM) ; Mode
- K LEXD("SS") N LEXT,LEXI S LEXM=+($G(LEXM))
- Q:LEXM=0 Q:'$D(^LEXT(757.2,LEXM,5)) Q:$P(^LEXT(757.2,LEXM,5),"^",1)="" Q:$P(^LEXT(757.2,LEXM,5),"^",5)'="" Q:$P($G(^LEXT(757.2,LEXM,5)),"^",1)="" S LEXT="SS",LEXI=LEXM D COMMON
- S:$L($G(^LEXT(757.2,LEXI,7))) LEXD(LEXT,"DIS")=$G(^LEXT(757.2,LEXI,7))
- S LEXD(LEXT,"FIL")=$G(^LEXT(757.2,LEXI,6))
- S LEXD(LEXT,"SCT")=+($P($G(^LEXT(757.2,LEXI,5)),"^",8))
- ; Modifiers PCH 6
- S LEXD(LEXT,"MOD")=+($P($G(^LEXT(757.2,LEXI,5)),"^",9))
- K:+(LEXD(LEXT,"SCT"))=0 LEXD(LEXT,"SCT")
- S LEXD(LEXT,"SUB")=$P($G(^LEXT(757.2,LEXI,5)),"^",2)
- S:LEXD(LEXT,"SUB")="" LEXD(LEXT,"SUB")="WRD"
- S LEXD(LEXT,"IDX")="A"_LEXD(LEXT,"SUB")
- Q
- IND ;
- S LEXD("DF","XTLKSAY")=1 S:'$L($G(DIC(0))) DIC(0)="EQM" S:'$L($G(X))&(DIC(0)'["A") DIC(0)="A"_DIC(0)
- S:DIC(0)["L" DIC(0)=$P(DIC(0),"L",1)_$P(DIC(0),"L",2) S:DIC(0)["I" DIC(0)=$P(DIC(0),"I",1)_$P(DIC(0),"L",2)
- S LEXD("DF","DIC(0)")=DIC(0) K DIC(0)
- Q
- COMMON ; Common Values
- S LEXD(LEXT,"IEN")=LEXI S:LEXT="AP" LEXD("DF","LEXAP")=LEXI
- S LEXD(LEXT,"NAM")=$P($G(^LEXT(757.2,LEXI,0)),"^",1)
- S LEXD(LEXT,"GBL")=$G(^LEXT(757.2,LEXI,1))
- S LEXD(LEXT,"OVR")=+($P($G(^LEXT(757.2,LEXI,5)),"^",7))
- S:$G(^LEXT(757.2,LEXI,2))'="" LEXD(LEXT,"DSP")=$G(^LEXT(757.2,LEXI,3))
- S:$G(^LEXT(757.2,LEXI,3))'="" LEXD(LEXT,"HLP")="D "_$G(^LEXT(757.2,LEXI,2))
- Q
- USR(LEXI) ; User defaults
- Q:+($G(LEXI))=0 Q:+($G(DUZ))=0 Q:'$D(^LEXT(757.2,+LEXI,200,DUZ))
- N LEXEMP S LEXEMP=$G(^LEXT(757.2,+LEXI,200,DUZ,1)) S:LEXEMP'="" LEXD("UD","FIL")=LEXEMP
- S LEXEMP=$G(^LEXT(757.2,+LEXI,200,DUZ,2)) S:LEXEMP'="" LEXD("UD","DIS")=LEXEMP
- S LEXEMP=$G(^LEXT(757.2,+LEXI,200,DUZ,3)) S:LEXEMP'="" LEXD("UD","SUB")=LEXEMP,LEXD("UD","IDX")="A"_LEXEMP
- S LEXEMP=$G(^LEXT(757.2,+LEXI,200,DUZ,4)) S:LEXEMP'="" LEXD("UD","SCT")=LEXEMP
- I $L($G(LEXD("UD","SUB"))) D
- . I $D(^LEXT(757.2,"AA",LEXD("UD","SUB"))) S LEXD("UD","IEN")=$O(^LEXT(757.2,"AA",LEXD("UD","SUB"),0))
- . I $D(^LEXT(757.2,"AB",LEXD("UD","SUB"))) S LEXD("UD","IEN")=$O(^LEXT(757.2,"AB",LEXD("UD","SUB"),0))
- . I +($G(LEXD("UD","IEN")))>0,$D(^LEXT(757.2,+($G(LEXD("UD","IEN"))))) D
- . . S:$L($G(^LEXT(757.2,+($G(LEXD("UD","IEN"))),1))) LEXD("UD","GBL")=$G(^LEXT(757.2,+($G(LEXD("UD","IEN"))),1))
- . . S:$L($G(^LEXT(757.2,+($G(LEXD("UD","IEN"))),2))) LEXD("UD","DSP")=$G(^LEXT(757.2,+($G(LEXD("UD","IEN"))),2))
- . . S:$L($G(^LEXT(757.2,+($G(LEXD("UD","IEN"))),3))) LEXD("UD","HLP")=$G(^LEXT(757.2,+($G(LEXD("UD","IEN"))),3))
- . I '$L($G(LEXD("UD","GBL"))) K LEXD("UD","SUB"),LEXD("UD","IDX")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXSET2 4199 printed Feb 18, 2025@23:35:43 Page 2
- LEXSET2 ;ISL/KER - Retrieve Appl/Sub/Mode/User Defaults ;04/21/2014
- +1 ;;2.0;LEXICON UTILITY;**6,80**;Sep 23, 1996;Build 1
- +2 ;
- APP(LEXA) ; Application
- +1 KILL LEXD("AP")
- NEW LEXT,LEXI
- SET LEXA=+($GET(LEXA))
- +2 if LEXA=0
- QUIT
- if '$DATA(^LEXT(757.2,LEXA))
- QUIT
- if $PIECE($GET(^LEXT(757.2,LEXA,5)),"^",5)=""
- QUIT
- +3 SET LEXT="AP"
- SET LEXI=LEXA
- DO COMMON
- +4 if $LENGTH($GET(^LEXT(757.2,LEXI,7)))
- SET LEXD(LEXT,"DIS")=$GET(^LEXT(757.2,LEXI,7))
- +5 SET LEXD(LEXT,"UNR")=+($PIECE($GET(^LEXT(757.2,LEXI,5)),"^",6))
- +6 SET LEXD(LEXT,"DEF")=+($PIECE($GET(^LEXT(757.2,LEXI,5)),"^",3))
- +7 SET LEXD(LEXT,"SCT")=+($PIECE($GET(^LEXT(757.2,LEXI,5)),"^",8))
- +8 ; Modifiers PCH 6
- +9 SET LEXD(LEXT,"MOD")=+($PIECE($GET(^LEXT(757.2,LEXI,5)),"^",9))
- +10 if +(LEXD(LEXT,"SCT"))=0
- KILL LEXD(LEXT,"SCT")
- +11 SET LEXD(LEXT,"FIL")=$GET(^LEXT(757.2,LEXI,6))
- +12 SET LEXD("DF","UNR")=+($PIECE($GET(^LEXT(757.2,LEXI,5)),"^",6))
- +13 SET LEXD(LEXT,"SUB")=$PIECE($GET(^LEXT(757.2,LEXI,5)),"^",2)
- +14 if LEXD(LEXT,"SUB")=""
- SET LEXD(LEXT,"SUB")="WRD"
- +15 SET LEXD(LEXT,"IDX")="A"_LEXD(LEXT,"SUB")
- +16 QUIT
- SUB(LEXS) ; Subset
- +1 KILL LEXD("SS")
- NEW LEXT,LEXI
- SET LEXS=+($GET(LEXS))
- +2 if LEXS=0
- QUIT
- if '$DATA(^LEXT(757.2,LEXS))
- QUIT
- if $PIECE($GET(^LEXT(757.2,LEXS,0)),"^",2)=""
- QUIT
- +3 SET LEXT="SS"
- SET LEXI=LEXS
- DO COMMON
- +4 if $LENGTH($GET(^LEXT(757.2,LEXI,4)))
- SET LEXD(LEXT,"DIS")=$GET(^LEXT(757.2,LEXI,4))
- +5 SET LEXD(LEXT,"SCT")=+($PIECE($GET(^LEXT(757.2,LEXI,5)),"^",8))
- +6 if +(LEXD(LEXT,"SCT"))=0
- KILL LEXD(LEXT,"SCT")
- +7 ; Modifiers PCH 6
- +8 SET LEXD(LEXT,"MOD")=+($PIECE($GET(^LEXT(757.2,LEXI,5)),"^",9))
- +9 SET LEXD(LEXT,"FIL")=$GET(^LEXT(757.2,LEXI,6))
- +10 SET LEXD(LEXT,"SUB")=$PIECE($GET(^LEXT(757.2,LEXI,0)),"^",2)
- +11 if LEXD(LEXT,"SUB")=""
- SET LEXD(LEXT,"SUB")="WRD"
- +12 SET LEXD(LEXT,"IDX")="A"_LEXD(LEXT,"SUB")
- +13 QUIT
- GEN SET LEXD("DF","OVR")=0
- if $GET(LEXD("AP","OVR"))=1!($GET(LEXD("SS","OVR"))=1)
- SET LEXD("DF","OVR")=1
- +1 QUIT
- MOD(LEXM) ; Mode
- +1 KILL LEXD("SS")
- NEW LEXT,LEXI
- SET LEXM=+($GET(LEXM))
- +2 if LEXM=0
- QUIT
- if '$DATA(^LEXT(757.2,LEXM,5))
- QUIT
- if $PIECE(^LEXT(757.2,LEXM,5),"^",1)=""
- QUIT
- if $PIECE(^LEXT(757.2,LEXM,5),"^",5)'=""
- QUIT
- if $PIECE($GET(^LEXT(757.2,LEXM,5)),"^",1)=""
- QUIT
- SET LEXT="SS"
- SET LEXI=LEXM
- DO COMMON
- +3 if $LENGTH($GET(^LEXT(757.2,LEXI,7)))
- SET LEXD(LEXT,"DIS")=$GET(^LEXT(757.2,LEXI,7))
- +4 SET LEXD(LEXT,"FIL")=$GET(^LEXT(757.2,LEXI,6))
- +5 SET LEXD(LEXT,"SCT")=+($PIECE($GET(^LEXT(757.2,LEXI,5)),"^",8))
- +6 ; Modifiers PCH 6
- +7 SET LEXD(LEXT,"MOD")=+($PIECE($GET(^LEXT(757.2,LEXI,5)),"^",9))
- +8 if +(LEXD(LEXT,"SCT"))=0
- KILL LEXD(LEXT,"SCT")
- +9 SET LEXD(LEXT,"SUB")=$PIECE($GET(^LEXT(757.2,LEXI,5)),"^",2)
- +10 if LEXD(LEXT,"SUB")=""
- SET LEXD(LEXT,"SUB")="WRD"
- +11 SET LEXD(LEXT,"IDX")="A"_LEXD(LEXT,"SUB")
- +12 QUIT
- IND ;
- +1 SET LEXD("DF","XTLKSAY")=1
- if '$LENGTH($GET(DIC(0)))
- SET DIC(0)="EQM"
- if '$LENGTH($GET(X))&(DIC(0)'["A")
- SET DIC(0)="A"_DIC(0)
- +2 if DIC(0)["L"
- SET DIC(0)=$PIECE(DIC(0),"L",1)_$PIECE(DIC(0),"L",2)
- if DIC(0)["I"
- SET DIC(0)=$PIECE(DIC(0),"I",1)_$PIECE(DIC(0),"L",2)
- +3 SET LEXD("DF","DIC(0)")=DIC(0)
- KILL DIC(0)
- +4 QUIT
- COMMON ; Common Values
- +1 SET LEXD(LEXT,"IEN")=LEXI
- if LEXT="AP"
- SET LEXD("DF","LEXAP")=LEXI
- +2 SET LEXD(LEXT,"NAM")=$PIECE($GET(^LEXT(757.2,LEXI,0)),"^",1)
- +3 SET LEXD(LEXT,"GBL")=$GET(^LEXT(757.2,LEXI,1))
- +4 SET LEXD(LEXT,"OVR")=+($PIECE($GET(^LEXT(757.2,LEXI,5)),"^",7))
- +5 if $GET(^LEXT(757.2,LEXI,2))'=""
- SET LEXD(LEXT,"DSP")=$GET(^LEXT(757.2,LEXI,3))
- +6 if $GET(^LEXT(757.2,LEXI,3))'=""
- SET LEXD(LEXT,"HLP")="D "_$GET(^LEXT(757.2,LEXI,2))
- +7 QUIT
- USR(LEXI) ; User defaults
- +1 if +($GET(LEXI))=0
- QUIT
- if +($GET(DUZ))=0
- QUIT
- if '$DATA(^LEXT(757.2,+LEXI,200,DUZ))
- QUIT
- +2 NEW LEXEMP
- SET LEXEMP=$GET(^LEXT(757.2,+LEXI,200,DUZ,1))
- if LEXEMP'=""
- SET LEXD("UD","FIL")=LEXEMP
- +3 SET LEXEMP=$GET(^LEXT(757.2,+LEXI,200,DUZ,2))
- if LEXEMP'=""
- SET LEXD("UD","DIS")=LEXEMP
- +4 SET LEXEMP=$GET(^LEXT(757.2,+LEXI,200,DUZ,3))
- if LEXEMP'=""
- SET LEXD("UD","SUB")=LEXEMP
- SET LEXD("UD","IDX")="A"_LEXEMP
- +5 SET LEXEMP=$GET(^LEXT(757.2,+LEXI,200,DUZ,4))
- if LEXEMP'=""
- SET LEXD("UD","SCT")=LEXEMP
- +6 IF $LENGTH($GET(LEXD("UD","SUB")))
- Begin DoDot:1
- +7 IF $DATA(^LEXT(757.2,"AA",LEXD("UD","SUB")))
- SET LEXD("UD","IEN")=$ORDER(^LEXT(757.2,"AA",LEXD("UD","SUB"),0))
- +8 IF $DATA(^LEXT(757.2,"AB",LEXD("UD","SUB")))
- SET LEXD("UD","IEN")=$ORDER(^LEXT(757.2,"AB",LEXD("UD","SUB"),0))
- +9 IF +($GET(LEXD("UD","IEN")))>0
- IF $DATA(^LEXT(757.2,+($GET(LEXD("UD","IEN")))))
- Begin DoDot:2
- +10 if $LENGTH($GET(^LEXT(757.2,+($GET(LEXD("UD","IEN"))),1)))
- SET LEXD("UD","GBL")=$GET(^LEXT(757.2,+($GET(LEXD("UD","IEN"))),1))
- +11 if $LENGTH($GET(^LEXT(757.2,+($GET(LEXD("UD","IEN"))),2)))
- SET LEXD("UD","DSP")=$GET(^LEXT(757.2,+($GET(LEXD("UD","IEN"))),2))
- +12 if $LENGTH($GET(^LEXT(757.2,+($GET(LEXD("UD","IEN"))),3)))
- SET LEXD("UD","HLP")=$GET(^LEXT(757.2,+($GET(LEXD("UD","IEN"))),3))
- End DoDot:2
- +13 IF '$LENGTH($GET(LEXD("UD","GBL")))
- KILL LEXD("UD","SUB"),LEXD("UD","IDX")
- End DoDot:1
- +14 QUIT