- 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 Feb 18, 2025@23:34:37 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