LEXQD ;ISL/KER - Query - Defaults ;10/30/2008
;;2.0;LEXICON UTILITY;**62**;Sep 23, 1996;Build 16
;
; Global Variables
; ^%ZOSF("TEST") ICR 10096
; ^XTMP( SACC 2.3.2.5.2
;
; External References
; ^DIM ICR 10016
; $$GET1^DIQ ICR 2056
; $$DT^XLFDT ICR 10103
; $$FMADD^XLFDT ICR 10103
;
; Save/Retrieve Defaults
;
; X Routine Name
; Y Routine Tag
; LEXN Number (DUZ)
; LEXC Comment
; LEXV Value (default to save)
; LEXRTN Routine Name (X)
; LEXTAG Routine Tag (Y)
; LEXKEY $E(COM,1,13)
; LEXID LEXRTN_LEXN_LEXKEY
;
; ^XTMP(LEXID,0)=FUTURE DATE^TODAY'S DATE^LEXC
; ^XTMP(LEXID,LEXTAG)=LEXV
;
SAV(X,Y,LEXN,LEXC,LEXV) ; Save Defaults
N LEXRTN,LEXTAG,LEXUSR,LEXCOM,LEXVAL,LEXNM,LEXID,LEXTD,LEXFD,LEXKEY S LEXRTN=$G(X) Q:+($$ROK(LEXRTN))'>0 S LEXTAG=$G(Y) Q:+($$TAG((LEXTAG_"^"_LEXRTN)))'>0
S LEXUSR=+($G(LEXN)),LEXVAL=$G(LEXV) Q:LEXUSR'>0 Q:'$L(LEXVAL) S LEXCOM=$G(LEXC) Q:'$L(LEXCOM) S LEXKEY=$E(LEXCOM,1,13) F Q:$L(LEXKEY)>12 S LEXKEY=LEXKEY_" "
S LEXNM=$$GET1^DIQ(200,(LEXUSR_","),.01) Q:'$L(LEXNM) S LEXTD=$$DT^XLFDT,LEXFD=$$FMADD^XLFDT(LEXTD,30),LEXID=LEXRTN_" "_LEXUSR_" "_LEXKEY
S ^XTMP(LEXID,0)=LEXFD_"^"_LEXTD_"^"_LEXCOM,^XTMP(LEXID,LEXTAG)=LEXVAL
Q
RET(X,Y,LEXN,LEXC) ; Retrieve Defaults
N LEXRTN,LEXTAG,LEXUSR,LEXCOM,LEXNM,LEXID,LEXTD,LEXFD,LEXKEY S LEXRTN=$G(X) Q:+($$ROK(LEXRTN))'>0 ""
S LEXTAG=$G(Y) Q:+($$TAG((LEXTAG_"^"_LEXRTN)))'>0 "" S LEXUSR=+($G(LEXN)) Q:LEXUSR'>0 ""
S LEXCOM=$G(LEXC) Q:'$L(LEXCOM) "" S LEXKEY=$E(LEXCOM,1,13) F Q:$L(LEXKEY)>12 S LEXKEY=LEXKEY_" "
S LEXNM=$$GET1^DIQ(200,(LEXUSR_","),.01) Q:'$L(LEXNM) "" S LEXTD=$$DT^XLFDT,LEXFD=$$FMADD^XLFDT(LEXTD,30),LEXID=LEXRTN_" "_LEXUSR_" "_LEXKEY
S X=$G(^XTMP(LEXID,LEXTAG))
Q X
;
; Miscellaneous
PUR ; Purge Defaults
N LEXID S LEXID="LEXP~" F S LEXID=$O(^XTMP(LEXID)) Q:'$L(LEXID) Q:$E(LEXID,1,4)'="LEXQ" K:$E(LEXID,1,4)="LEXQ" ^XTMP(LEXID)
Q
SDF ; Show Defaults
N LEXN,LEXC S LEXN="^XTMP(""LEXQ"")",LEXC="^XTMP(""LEXQ" F S LEXN=$Q(@LEXN) Q:'$L(LEXN)!(LEXN'[LEXC) W !,LEXN,"=",@LEXN
Q
ROK(X) ; Routine OK
S X=$G(X) Q:'$L(X) 0 Q:$L(X)>8 0 X ^%ZOSF("TEST") Q:$T 1 Q 0
TAG(X) ; Sub-Routine OK
N LEXT,LEXE,LEXL S X=$G(X) Q:'$L(X) 0 Q:X'["^" 0
Q:'$L($P(X,"^",1)) 0 Q:$L($P(X,"^",1))>8 0 Q:$E($P(X,"^",1),1)'?1U 0
Q:'$L($P(X,"^",2)) 0 Q:$L($P(X,"^",2))>8 0 Q:$E($P(X,"^",2),1)'?1U 0
S LEXL=0,LEXT=X,(LEXE,X)="S LEXL=$L($T("_X_"))" D ^DIM X:$D(X) LEXE
S X=$S(LEXL>0:1,1:0)
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQD 2719 printed Oct 16, 2024@18:09:15 Page 2
LEXQD ;ISL/KER - Query - Defaults ;10/30/2008
+1 ;;2.0;LEXICON UTILITY;**62**;Sep 23, 1996;Build 16
+2 ;
+3 ; Global Variables
+4 ; ^%ZOSF("TEST") ICR 10096
+5 ; ^XTMP( SACC 2.3.2.5.2
+6 ;
+7 ; External References
+8 ; ^DIM ICR 10016
+9 ; $$GET1^DIQ ICR 2056
+10 ; $$DT^XLFDT ICR 10103
+11 ; $$FMADD^XLFDT ICR 10103
+12 ;
+13 ; Save/Retrieve Defaults
+14 ;
+15 ; X Routine Name
+16 ; Y Routine Tag
+17 ; LEXN Number (DUZ)
+18 ; LEXC Comment
+19 ; LEXV Value (default to save)
+20 ; LEXRTN Routine Name (X)
+21 ; LEXTAG Routine Tag (Y)
+22 ; LEXKEY $E(COM,1,13)
+23 ; LEXID LEXRTN_LEXN_LEXKEY
+24 ;
+25 ; ^XTMP(LEXID,0)=FUTURE DATE^TODAY'S DATE^LEXC
+26 ; ^XTMP(LEXID,LEXTAG)=LEXV
+27 ;
SAV(X,Y,LEXN,LEXC,LEXV) ; Save Defaults
+1 NEW LEXRTN,LEXTAG,LEXUSR,LEXCOM,LEXVAL,LEXNM,LEXID,LEXTD,LEXFD,LEXKEY
SET LEXRTN=$GET(X)
if +($$ROK(LEXRTN))'>0
QUIT
SET LEXTAG=$GET(Y)
if +($$TAG((LEXTAG_"^"_LEXRTN)))'>0
QUIT
+2 SET LEXUSR=+($GET(LEXN))
SET LEXVAL=$GET(LEXV)
if LEXUSR'>0
QUIT
if '$LENGTH(LEXVAL)
QUIT
SET LEXCOM=$GET(LEXC)
if '$LENGTH(LEXCOM)
QUIT
SET LEXKEY=$EXTRACT(LEXCOM,1,13)
FOR
if $LENGTH(LEXKEY)>12
QUIT
SET LEXKEY=LEXKEY_" "
+3 SET LEXNM=$$GET1^DIQ(200,(LEXUSR_","),.01)
if '$LENGTH(LEXNM)
QUIT
SET LEXTD=$$DT^XLFDT
SET LEXFD=$$FMADD^XLFDT(LEXTD,30)
SET LEXID=LEXRTN_" "_LEXUSR_" "_LEXKEY
+4 SET ^XTMP(LEXID,0)=LEXFD_"^"_LEXTD_"^"_LEXCOM
SET ^XTMP(LEXID,LEXTAG)=LEXVAL
+5 QUIT
RET(X,Y,LEXN,LEXC) ; Retrieve Defaults
+1 NEW LEXRTN,LEXTAG,LEXUSR,LEXCOM,LEXNM,LEXID,LEXTD,LEXFD,LEXKEY
SET LEXRTN=$GET(X)
if +($$ROK(LEXRTN))'>0
QUIT ""
+2 SET LEXTAG=$GET(Y)
if +($$TAG((LEXTAG_"^"_LEXRTN)))'>0
QUIT ""
SET LEXUSR=+($GET(LEXN))
if LEXUSR'>0
QUIT ""
+3 SET LEXCOM=$GET(LEXC)
if '$LENGTH(LEXCOM)
QUIT ""
SET LEXKEY=$EXTRACT(LEXCOM,1,13)
FOR
if $LENGTH(LEXKEY)>12
QUIT
SET LEXKEY=LEXKEY_" "
+4 SET LEXNM=$$GET1^DIQ(200,(LEXUSR_","),.01)
if '$LENGTH(LEXNM)
QUIT ""
SET LEXTD=$$DT^XLFDT
SET LEXFD=$$FMADD^XLFDT(LEXTD,30)
SET LEXID=LEXRTN_" "_LEXUSR_" "_LEXKEY
+5 SET X=$GET(^XTMP(LEXID,LEXTAG))
+6 QUIT X
+7 ;
+8 ; Miscellaneous
PUR ; Purge Defaults
+1 NEW LEXID
SET LEXID="LEXP~"
FOR
SET LEXID=$ORDER(^XTMP(LEXID))
if '$LENGTH(LEXID)
QUIT
if $EXTRACT(LEXID,1,4)'="LEXQ"
QUIT
if $EXTRACT(LEXID,1,4)="LEXQ"
KILL ^XTMP(LEXID)
+2 QUIT
SDF ; Show Defaults
+1 NEW LEXN,LEXC
SET LEXN="^XTMP(""LEXQ"")"
SET LEXC="^XTMP(""LEXQ"
FOR
SET LEXN=$QUERY(@LEXN)
if '$LENGTH(LEXN)!(LEXN'[LEXC)
QUIT
WRITE !,LEXN,"=",@LEXN
+2 QUIT
ROK(X) ; Routine OK
+1 SET X=$GET(X)
if '$LENGTH(X)
QUIT 0
if $LENGTH(X)>8
QUIT 0
XECUTE ^%ZOSF("TEST")
if $TEST
QUIT 1
QUIT 0
TAG(X) ; Sub-Routine OK
+1 NEW LEXT,LEXE,LEXL
SET X=$GET(X)
if '$LENGTH(X)
QUIT 0
if X'["^"
QUIT 0
+2 if '$LENGTH($PIECE(X,"^",1))
QUIT 0
if $LENGTH($PIECE(X,"^",1))>8
QUIT 0
if $EXTRACT($PIECE(X,"^",1),1)'?1U
QUIT 0
+3 if '$LENGTH($PIECE(X,"^",2))
QUIT 0
if $LENGTH($PIECE(X,"^",2))>8
QUIT 0
if $EXTRACT($PIECE(X,"^",2),1)'?1U
QUIT 0
+4 SET LEXL=0
SET LEXT=X
SET (LEXE,X)="S LEXL=$L($T("_X_"))"
DO ^DIM
if $DATA(X)
XECUTE LEXE
+5 SET X=$SELECT(LEXL>0:1,1:0)
+6 QUIT X
