LEXDSV ;ISL/KER - Defaults - Save ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
;
; Global Variables
; None
;
; External References
; FILE^DICN ICR 10009
; ^DIE ICR 10018
; ^DIK ICR 10013
;
; Needs
;
; Application File DA, Subfile DA(1) LEXAP
; User DUZ Sub-file .01 DINUM LEXDUZ
; Default value LEXDVAL
; Defualt name LEXDNAM
; Default field Sub-file field LEXFLD
;
; Sets ^LEXT(757.2,LEXAP,200,LEXDUZ,LEXFLD)=LEXDVAL
; and ^LEXT(757.2,LEXAP,200,LEXDUZ,(LEXFLD+.5))=LEXDNAM
;
Q
SET(LEXDUZ,LEXAP,LEXDVAL,LEXDNAM,LEXFLD) ;
;
Q:'$L($G(LEXDVAL)) S:LEXDVAL["@" LEXDVAL="@",LEXDNAM="@" S DIC("P")="757.201PA"
N LEXWARN S LEXWARN=0,(DIC,DIE)="^LEXT(757.2,"_LEXAP_",200,"
S DA(1)=LEXAP,DA=LEXDUZ
S DLAYGO=757.2,(DINUM,X)=LEXDUZ,DIC(0)="L"
S DIC("DR")=LEXFLD_"////^S X=LEXDVAL" K DD,DO D FILE^DICN
EDIT ; Lock record and edit user default
L +^LEXT(757.2,+LEXAP,200):1
I '$T D G EDIT
. W:'$D(ZTQUEUED)&('LEXWARN) !,"Another user is editing this entry, please wait"
. S LEXWARN=1 H 2
S DA(1)=LEXAP,DA=LEXDUZ,DR=LEXFLD_"////^S X=LEXDVAL"
D ^DIE I $L($G(LEXDNAM)) S DR=(LEXFLD+.5)_"////^S X=LEXDNAM" D ^DIE
K DA,DR,DIE,DIC
L -^LEXT(757.2,+LEXAP,200)
;
; Delete name if default is null
;
N LEXX,LEXDEL S LEXX=0,LEXDEL=1
F S LEXX=$O(^LEXT(757.2,LEXAP,200,LEXDUZ,LEXX)) Q:+LEXX=0 D
. I '$L($G(^LEXT(757.2,LEXAP,200,LEXDUZ,LEXX))) D
. . I $L($G(^LEXT(757.2,LEXAP,200,LEXDUZ,(LEXX+.5)))) D
. . . S LEXDVAL="@",DIC("P")="757.201PA"
. . . S (DIC,DIE)="^LEXT(757.2,"_LEXAP_",200,",DA(1)=LEXAP,DA=LEXDUZ
. . . S DLAYGO=757.2,(DINUM,X)=LEXDUZ,DIC(0)="L"
. . . L +^LEXT(757.2,+LEXAP,200):1 I '$T H 2 S LEXX=LEXX-.05 Q
. . . S DR=(LEXX+.5)_"////^S X=LEXDVAL"
. . . D ^DIE S LEXX=LEXX+.5 K DA,DR,DIE,DIC
. . . L -^LEXT(757.2,+LEXAP,200)
. . I '$L($G(^LEXT(757.2,LEXAP,200,LEXDUZ,(LEXX+.5)))) D
. . . K ^LEXT(757.2,LEXAP,200,LEXDUZ,LEXX),^LEXT(757.2,LEXAP,200,LEXDUZ,(LEXX+.5))
. I $L($G(^LEXT(757.2,LEXAP,200,LEXDUZ,LEXX))) S LEXDEL=0
;
; Delete record if all defaults are null
;
I LEXDEL D
. S (DIC,DIE,DIK)="^LEXT(757.2,"_LEXAP_",200,"
. S DA(1)=LEXAP,DA=LEXDUZ D ^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXDSV 2398 printed Apr 09, 2024@21:14:19 Page 2
LEXDSV ;ISL/KER - Defaults - Save ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; None
+5 ;
+6 ; External References
+7 ; FILE^DICN ICR 10009
+8 ; ^DIE ICR 10018
+9 ; ^DIK ICR 10013
+10 ;
+11 ; Needs
+12 ;
+13 ; Application File DA, Subfile DA(1) LEXAP
+14 ; User DUZ Sub-file .01 DINUM LEXDUZ
+15 ; Default value LEXDVAL
+16 ; Defualt name LEXDNAM
+17 ; Default field Sub-file field LEXFLD
+18 ;
+19 ; Sets ^LEXT(757.2,LEXAP,200,LEXDUZ,LEXFLD)=LEXDVAL
+20 ; and ^LEXT(757.2,LEXAP,200,LEXDUZ,(LEXFLD+.5))=LEXDNAM
+21 ;
+22 QUIT
SET(LEXDUZ,LEXAP,LEXDVAL,LEXDNAM,LEXFLD) ;
+1 ;
+2 if '$LENGTH($GET(LEXDVAL))
QUIT
if LEXDVAL["@"
SET LEXDVAL="@"
SET LEXDNAM="@"
SET DIC("P")="757.201PA"
+3 NEW LEXWARN
SET LEXWARN=0
SET (DIC,DIE)="^LEXT(757.2,"_LEXAP_",200,"
+4 SET DA(1)=LEXAP
SET DA=LEXDUZ
+5 SET DLAYGO=757.2
SET (DINUM,X)=LEXDUZ
SET DIC(0)="L"
+6 SET DIC("DR")=LEXFLD_"////^S X=LEXDVAL"
KILL DD,DO
DO FILE^DICN
EDIT ; Lock record and edit user default
+1 LOCK +^LEXT(757.2,+LEXAP,200):1
+2 IF '$TEST
Begin DoDot:1
+3 if '$DATA(ZTQUEUED)&('LEXWARN)
WRITE !,"Another user is editing this entry, please wait"
+4 SET LEXWARN=1
HANG 2
End DoDot:1
GOTO EDIT
+5 SET DA(1)=LEXAP
SET DA=LEXDUZ
SET DR=LEXFLD_"////^S X=LEXDVAL"
+6 DO ^DIE
IF $LENGTH($GET(LEXDNAM))
SET DR=(LEXFLD+.5)_"////^S X=LEXDNAM"
DO ^DIE
+7 KILL DA,DR,DIE,DIC
+8 LOCK -^LEXT(757.2,+LEXAP,200)
+9 ;
+10 ; Delete name if default is null
+11 ;
+12 NEW LEXX,LEXDEL
SET LEXX=0
SET LEXDEL=1
+13 FOR
SET LEXX=$ORDER(^LEXT(757.2,LEXAP,200,LEXDUZ,LEXX))
if +LEXX=0
QUIT
Begin DoDot:1
+14 IF '$LENGTH($GET(^LEXT(757.2,LEXAP,200,LEXDUZ,LEXX)))
Begin DoDot:2
+15 IF $LENGTH($GET(^LEXT(757.2,LEXAP,200,LEXDUZ,(LEXX+.5))))
Begin DoDot:3
+16 SET LEXDVAL="@"
SET DIC("P")="757.201PA"
+17 SET (DIC,DIE)="^LEXT(757.2,"_LEXAP_",200,"
SET DA(1)=LEXAP
SET DA=LEXDUZ
+18 SET DLAYGO=757.2
SET (DINUM,X)=LEXDUZ
SET DIC(0)="L"
+19 LOCK +^LEXT(757.2,+LEXAP,200):1
IF '$TEST
HANG 2
SET LEXX=LEXX-.05
QUIT
+20 SET DR=(LEXX+.5)_"////^S X=LEXDVAL"
+21 DO ^DIE
SET LEXX=LEXX+.5
KILL DA,DR,DIE,DIC
+22 LOCK -^LEXT(757.2,+LEXAP,200)
End DoDot:3
+23 IF '$LENGTH($GET(^LEXT(757.2,LEXAP,200,LEXDUZ,(LEXX+.5))))
Begin DoDot:3
+24 KILL ^LEXT(757.2,LEXAP,200,LEXDUZ,LEXX),^LEXT(757.2,LEXAP,200,LEXDUZ,(LEXX+.5))
End DoDot:3
End DoDot:2
+25 IF $LENGTH($GET(^LEXT(757.2,LEXAP,200,LEXDUZ,LEXX)))
SET LEXDEL=0
End DoDot:1
+26 ;
+27 ; Delete record if all defaults are null
+28 ;
+29 IF LEXDEL
Begin DoDot:1
+30 SET (DIC,DIE,DIK)="^LEXT(757.2,"_LEXAP_",200,"
+31 SET DA(1)=LEXAP
SET DA=LEXDUZ
DO ^DIK
End DoDot:1
+32 QUIT
