DICN1 ;SFISC/GFT,TKW,SEA/TOAD-PROCESS DIC("DR") ;10:54 AM 9 Feb 2001 [ 04/02/2003 8:23 AM ]
;;22.0;VA FileMan;**1001**;APR 1, 2003
;;22.0;VA FileMan;**4,67**;Mar 30, 1999
;THIS ROUTINE CONTAINS AN IHS MODIFICATON BY IHS/ANMC/FBD 6/19/97
;AND IHS/OIRM/DSD/AEF/01/08/03
;Per VHA Directive 10-93-142, this routine should not be modified.
;
K DIDA,DICRS,Y,%RCR
F Y="DIADD","I","J","X","DO","DC","DA","DE","DG","DIE","DR","DIC","D","D0","D1","D2","D3","D4","D5","D6","DI","DH","DIA","DICR","DK","DIK","DL","DLAYGO","DM","DP","DQ","DU","DW","DIEL","DOV","DIOV","DIEC","DB","DV","DIFLD" S %RCR(Y)=""
S DZ="W !?3,$S("""_$P(DO,U)_"""'=$P(DQ(DQ),U):"""_$P(DO,U)_""",1:"""")_"" ""_$P(DQ(DQ),U)_"": """
S Y=DA N % S %=0 D I '$D(%) D W,BAD Q
. S DD="" N I,J,X,Y
. I DINO01 D
. . S DD=".01//"
. . S I=$G(DISUBVAL(+DO(2),.01)) I I="" S DD=DD_";" Q
. . S DD=DD_$S(DIC(0)'["E":"/",1:"")_"^S X=DISUBVAL("_+DO(2)_",.01);" Q
. K DISUBVAL(+DO(2),.01)
. F I=0:0 S I=$O(DISUBVAL(+DO(2),I)) Q:'I D
. . S DD=DD_I_"//"
. . I $G(DISUBVAL(+DO(2),I,"INT"))]"" S DD=DD_"//^S X=DISUBVAL("_+DO(2)_","_I_",""INT"");" Q
. . S:DIC(0)'["E" DD=DD_"/"
. . S DD=DD_"^S X=DISUBVAL("_+DO(2)_","_I_");" Q
. S DD=DD_$G(DIC("DR")) I DD]"",$E(DD,$L(DD))'=";" S DD=DD_";"
. Q:DIC(0)'["E"
. F I=0:0 S I=$O(^DD("KEY","B",+DO(2),I)) Q:'I!('$D(%)) F J=0:0 S J=$O(^DD("KEY",I,2,J)) Q:'J!('$D(%)) D
. . S X=$G(^DD("KEY",I,2,J,0)) Q:$P(X,U,2)'=+DO(2)
. . S Y=$P(X,U) Q:'Y D CKID
. . Q
. Q:$D(DIC("DR"))!('$D(%))
. S Y=0 F S Y=$O(^DD(+DO(2),0,"ID",Y)) Q:'Y D CKID Q:'$D(%)
. Q
I DD]"",$O(^DD("KEY","B",+DO(2),0)) D
. N I S I=$S(DIC(0)["E":"M",1:"")
. S DD=DD_"S DIEFIRE="""_I_"""" Q
S %RCR="RCR^DICN1" D STORLIST^%RCR
I $D(Y)<9 S Y=DA Q
;
BAD S:$D(D)#2 DA=D K Y I '$D(DO(1)) S Y=-1 D Q^DIC2 Q
K DO D A^DIC S DS(0)="1^",Y=-1 Q
;
CKID I $G(DUZ(0))'="@",$G(^DD(+DO(2),Y,9))]"" D Q:'$D(%) Q:$L(^DD(+DO(2),Y,9))<%
. F %=1:1 I DUZ(0)[$E(^DD(+DO(2),Y,9),%) Q:$L(^(9))'<% K:$P(^(0),U,2)["R" % Q
Q:Y=.01
I $P(DD,"//")=Y!(DD[(";"_Y_"//"))!(DD[(";"_Y_";")) Q
S DD=DD_Y_";"
Q Q
;
W S A1="T",DST="SORRY! A VALUE FOR '"_$P(^(0),U,1)_"' MUST BE ENTERED," W:'$D(DDS) ! D H
S A1="T",DST="BUT YOU DON'T HAVE 'WRITE ACCESS' FOR THIS FIELD" W:'$D(DDS) !,?6 D H D:$D(DDS) LIST^DDSU
S %RCR="D^DICN1" D STORLIST^%RCR Q
;
H I $D(DDS) S DDH=$S($D(DDH):DDH+1,1:1),DDH(DDH,A1)=DST K A1,DST Q
;----- BEGIN IHS MODIFICATION
;THIS LINE IS COMMENTED OUT AND REPLACED BY THE LINE BELOW TO ADD
;CHECK FOR ZTQUEUED. ORIGINAL MODIFICATION BY IHS/ANMC/FBD 6/19/97
;W DST K A1,DST Q
W:'$D(ZTQUEUED) DST K A1,DST Q
;----- END IHS MODIFICATION
RCR ;
K DR,DIADD,DQ,DG,DE,DO N DISAV0 S DIE=DIC,DR=DD,DIE("W")=DZ,DISAV0=DIC(0) K DIC
I $D(DIE("NO^")) S %RCR("DIE(""NO^"")")=DIE("NO^")
S DIE("NO^")="BACKOUTOK" N X
D:$D(DDS) CLRMSG^DDS D:DR]"" K DIE("W"),DIE("NO^")
. N DISAV0,DIFILEI,DINDEX,DIVAL,DIENS,DIOPER
. S DIOPER="A" K % M %=DISUBVAL N DISUBVAL M DISUBVAL=% K %
. D ^DIE Q
D:$D(DDS)
. I $Y<IOSL D CLRMSG^DDS Q
. D REFRESH^DDSUTL
A I '$D(DA) S Y(0)=0 Q
;----- BEGIN IHS MODIFICATION - DI*22.0*1001
;LINE BELOW IS COMMENTED OUT AND REPLACED BY NEW LINE TO CALL
;$$IHSGL TO ALLOW USE OF DUZ(2) "SOFT" GLOBAL REFERENCE
;IHS/OIRM/DSD/AEF/01/08/03
;S:'$$INTEG^DIKK(DIE,DA_DIENS,"","","d") Y(0)=0,X="BADKEY"
I '$$IHSGL($G(DIFILEI)) S:'$$INTEG^DIKK(DIE,DA_DIENS,"","","d") Y(0)=0,X="BADKEY"
;----- END IHS MODIFICATION
Q:$D(Y)<9&'$D(DTOUT)&'$D(DIC("W"))&($G(X)'="BADKEY")
I $G(X)="BADKEY",DISAV0["E" W !," ",$$EZBLD^DIALOG(741)
S:'$G(DTOUT)&($D(Y)'<9) DUOUT=1
ZAP S DIK=DIE
;----- BEGIN IHS MODIFICATION
;THIS LINE IS COMMENTED AND REPLACED BY THE LINE BELOW TO ADD ZTQUEUED
;CHECK. ORIGINAL MODIFICATION BY IHS/ANMC/FBD 6/19/97
;I DISAV0["E" S A1="T",DST=$C(7)_" <'"_$P(@(DIK_"DA,0)"),U,1)_"' DELETED>" W:'$D(DDS) !?3 D H D:$D(DDS) LIST^DDSU
I DISAV0["E" S A1="T",DST=$C(7)_" <'"_$P(@(DIK_"DA,0)"),U,1)_"' DELETED>" W:'$D(DDS) !?3 D H D:$D(DDS) LIST^DDSU
;----- END IHS MODIFICATION
D ^DIK S Y(0)=0 K DST Q
;
D N DISAV0 S DISAV0=DIC(0),DIE=DIC D ZAP Q
;
ASKP001 ; ask user to confirm new record's .001 field value
; NEW^DICN
;
; quit if there's no .001 or we can't ask
;
I DIC(0)'["E" S Y=1 Q
S Y=$P(DO,U,2)
I '$D(^DD(+Y,.001,0)) S Y=1 Q
;
; if this is not a LAYGO lookup in which X looks like an IEN, and we're
; adding a new file, and we haven't tried this before, then offer a new
; .001 based on the user's or site's file range, whichever's handy.
; NEW^DICN will increment this .001 forward to find the first gap, then
; drop back through here to the paragraph below (because DO(3) will be
; defined next time) to offer it to the user
;
I '$D(DIENTRY),DIC="^DIC(",'$D(DO(3)) D S Y="TRY NEXT" Q
. S DO(3)=1
. I $S($D(^VA(200,DUZ,1))#2:1,1:$D(^DIC(3,DUZ,1))#2),$P(^(1),U) D Q
. . S DIY=.1,X=+$P(^(1),U) ; NAKED
. I $D(^DD("SITE",1)),X\1000'=^(1) S X=^(1)*1000,%=0
;
; set up our prompt, if .001 looks valid use it as a default, otherwise
; count forward until we find a valid one to offer
;
S DST=" "_$P(DO,U)_" "_$P(^DD(+Y,.001,0),U)_": "
S %=$P(^DD(+Y,.001,0),U,2),X=$S(%'["N"!(%["O"):0,1:X),%Y=X
I X F %=1:1 D N Q:$D(X) S X=0 Q:%>999 S X=%Y+DIY,%Y=X
I X S DST=DST_X_"// "
;
; prompt user for .001
;
I '$D(DDS) D
. W !,DST K DST R Y:$S($D(DTIME):DTIME,1:300) E S DTOUT=1,Y=U W $C(7)
E D
. S A1="Q",DST=3_U_DST N DIY D H,LIST^DDSU S Y=$S($D(DTOUT):U,1:%) K %
;
; sort through possible responses
;
I Y[U S Y=U Q
I Y="" S Y=1 Q
I Y'="?" D Q:Y
. S X=Y D N S Y=$D(X)#2 D:Y Q:Y
. . I $D(@(DIC_X_")")) K X S Y=0
. . Q
. W $C(7)
. W:'$D(DDS) "??"
;
; for bad response or help request, offer help and try new IEN
;
S DST="" I $D(^DD(+DO(2),.001,3)) S DST=" "_^(3)
I '$D(DDS) D
. W:DST]"" !?5,DST X:$D(^(4)) ^(4) K DST ; NAKED
E D
. S A1=0 N DIY D H S:$D(^(4)) DDH("ID")=^(4) D LIST^DDSU ; NAKED
S X=$P(DO,U,3) D INCR^DICN0
S Y="TRY NEXT"
Q
;
;----- BEGIN IHS MODIFICATION - XU*8.0*1007
;ADD NEW SUBROUTINE IHSGL - IHS/OIRM/DSD/AEF/01/08/03
;
IHSGL(X) ;----- CHECK GL NODE OF TOP LEVEL FILE FOR DUZ(2)
;USED TO ALLOW USE OF "SOFT" GLOBAL REFERENCES, I.E., DUZ(2)
;
; RETURNS:
; 0 IF THE TOP LEVEL FILE "GL" NODE DOES NOT CONTAIN DUZ(2)
; 1 IF IT DOES
;
; INPUT:
; X = FILE NUMBER
;
N DITOP,Y
S Y=0
I X D
. S DITOP=X
. F Q:'$D(^DD(DITOP,0,"UP")) S DITOP=^("UP")
. S Y=$G(^DIC(DITOP,0,"GL"))["DUZ(2)"
Q Y
;
;----- END IHS MODIFICATION
N ; test X as an IEN (apply input transform and numeric restrictions)
; USR^DICN, ASKP001
;
I $D(^DD(+$P(DO,U,2),.001,0)),'$D(DINUM) X $P(^(0),U,5,99)
I $D(X),$L(X)<15,+X=X,X>0,X>1!(DIC'="^DIC(") Q
K X
Q
;
; 741 Either key values are null, or creates a duplicate key.
;
DICN1 ;SFISC/GFT,TKW,SEA/TOAD-PROCESS DIC("DR") ;10:54 AM 9 Feb 2001 [ 04/02/2003 8:23 AM ]
+1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
+2 ;;22.0;VA FileMan;**4,67**;Mar 30, 1999
+3 ;THIS ROUTINE CONTAINS AN IHS MODIFICATON BY IHS/ANMC/FBD 6/19/97
+4 ;AND IHS/OIRM/DSD/AEF/01/08/03
+5 ;Per VHA Directive 10-93-142, this routine should not be modified.
+6 ;
+7 KILL DIDA,DICRS,Y,%RCR
+8 FOR Y="DIADD","I","J","X","DO","DC","DA","DE","DG","DIE","DR","DIC","D","D0","D1","D2","D3","D4","D5","D6","DI","DH","DIA","DICR","DK","DIK","DL","DLAYGO","DM","DP","DQ","DU","DW","DIEL","DOV","DIOV","DIEC","DB","DV","DIFLD"
SET %RCR(Y)=""
+9 SET DZ="W !?3,$S("""_$PIECE(DO,U)_"""'=$P(DQ(DQ),U):"""_$PIECE(DO,U)_""",1:"""")_"" ""_$P(DQ(DQ),U)_"": """
+10 SET Y=DA
NEW %
SET %=0
Begin DoDot:1
+11 SET DD=""
NEW I,J,X,Y
+12 IF DINO01
Begin DoDot:2
+13 SET DD=".01//"
+14 SET I=$GET(DISUBVAL(+DO(2),.01))
IF I=""
SET DD=DD_";"
QUIT
+15 SET DD=DD_$SELECT(DIC(0)'["E":"/",1:"")_"^S X=DISUBVAL("_+DO(2)_",.01);"
QUIT
End DoDot:2
+16 KILL DISUBVAL(+DO(2),.01)
+17 FOR I=0:0
SET I=$ORDER(DISUBVAL(+DO(2),I))
IF 'I
QUIT
Begin DoDot:2
+18 SET DD=DD_I_"//"
+19 IF $GET(DISUBVAL(+DO(2),I,"INT"))]""
SET DD=DD_"//^S X=DISUBVAL("_+DO(2)_","_I_",""INT"");"
QUIT
+20 IF DIC(0)'["E"
SET DD=DD_"/"
+21 SET DD=DD_"^S X=DISUBVAL("_+DO(2)_","_I_");"
QUIT
End DoDot:2
+22 SET DD=DD_$GET(DIC("DR"))
IF DD]""
IF $EXTRACT(DD,$LENGTH(DD))'=";"
SET DD=DD_";"
+23 IF DIC(0)'["E"
QUIT
+24 FOR I=0:0
SET I=$ORDER(^DD("KEY","B",+DO(2),I))
IF 'I!('$DATA(%))
QUIT
FOR J=0:0
SET J=$ORDER(^DD("KEY",I,2,J))
IF 'J!('$DATA(%))
QUIT
Begin DoDot:2
+25 SET X=$GET(^DD("KEY",I,2,J,0))
IF $PIECE(X,U,2)'=+DO(2)
QUIT
+26 SET Y=$PIECE(X,U)
IF 'Y
QUIT
DO CKID
+27 QUIT
End DoDot:2
+28 IF $DATA(DIC("DR"))!('$DATA(%))
QUIT
+29 SET Y=0
FOR
SET Y=$ORDER(^DD(+DO(2),0,"ID",Y))
IF 'Y
QUIT
DO CKID
IF '$DATA(%)
QUIT
+30 QUIT
End DoDot:1
IF '$DATA(%)
DO W
DO BAD
QUIT
+31 IF DD]""
IF $ORDER(^DD("KEY","B",+DO(2),0))
Begin DoDot:1
+32 NEW I
SET I=$SELECT(DIC(0)["E":"M",1:"")
+33 SET DD=DD_"S DIEFIRE="""_I_""""
QUIT
End DoDot:1
+34 SET %RCR="RCR^DICN1"
DO STORLIST^%RCR
+35 IF $DATA(Y)<9
SET Y=DA
QUIT
+36 ;
BAD IF $DATA(D)#2
SET DA=D
KILL Y
IF '$DATA(DO(1))
SET Y=-1
DO Q^DIC2
QUIT
+1 KILL DO
DO A^DIC
SET DS(0)="1^"
SET Y=-1
QUIT
+2 ;
CKID IF $GET(DUZ(0))'="@"
IF $GET(^DD(+DO(2),Y,9))]""
Begin DoDot:1
+1 FOR %=1:1
IF DUZ(0)[$EXTRACT(^DD(+DO(2),Y,9),%)
IF $LENGTH(^(9))'<%
QUIT
IF $PIECE(^(0),U,2)["R"
KILL %
QUIT
End DoDot:1
IF '$DATA(%)
QUIT
IF $LENGTH(^DD(+DO(2),Y,9))<%
QUIT
+2 IF Y=.01
QUIT
+3 IF $PIECE(DD,"//")=Y!(DD[(";"_Y_"//"))!(DD[(";"_Y_";"))
QUIT
+4 SET DD=DD_Y_";"
Q QUIT
+1 ;
W SET A1="T"
SET DST="SORRY! A VALUE FOR '"_$PIECE(^(0),U,1)_"' MUST BE ENTERED,"
IF '$DATA(DDS)
WRITE !
DO H
+1 SET A1="T"
SET DST="BUT YOU DON'T HAVE 'WRITE ACCESS' FOR THIS FIELD"
IF '$DATA(DDS)
WRITE !,?6
DO H
IF $DATA(DDS)
DO LIST^DDSU
+2 SET %RCR="D^DICN1"
DO STORLIST^%RCR
QUIT
+3 ;
H IF $DATA(DDS)
SET DDH=$SELECT($DATA(DDH):DDH+1,1:1)
SET DDH(DDH,A1)=DST
KILL A1,DST
QUIT
+1 ;----- BEGIN IHS MODIFICATION
+2 ;THIS LINE IS COMMENTED OUT AND REPLACED BY THE LINE BELOW TO ADD
+3 ;CHECK FOR ZTQUEUED. ORIGINAL MODIFICATION BY IHS/ANMC/FBD 6/19/97
+4 ;W DST K A1,DST Q
+5 IF '$DATA(ZTQUEUED)
WRITE DST
KILL A1,DST
QUIT
+6 ;----- END IHS MODIFICATION
RCR ;
+1 KILL DR,DIADD,DQ,DG,DE,DO
NEW DISAV0
SET DIE=DIC
SET DR=DD
SET DIE("W")=DZ
SET DISAV0=DIC(0)
KILL DIC
+2 IF $DATA(DIE("NO^"))
SET %RCR("DIE(""NO^"")")=DIE("NO^")
+3 SET DIE("NO^")="BACKOUTOK"
NEW X
+4 IF $DATA(DDS)
DO CLRMSG^DDS
IF DR]""
Begin DoDot:1
+5 NEW DISAV0,DIFILEI,DINDEX,DIVAL,DIENS,DIOPER
+6 SET DIOPER="A"
KILL %
MERGE %=DISUBVAL
NEW DISUBVAL
MERGE DISUBVAL=%
KILL %
+7 DO ^DIE
QUIT
End DoDot:1
KILL DIE("W"),DIE("NO^")
+8 IF $DATA(DDS)
Begin DoDot:1
+9 IF $Y<IOSL
DO CLRMSG^DDS
QUIT
+10 DO REFRESH^DDSUTL
End DoDot:1
A IF '$DATA(DA)
SET Y(0)=0
QUIT
+1 ;----- BEGIN IHS MODIFICATION - DI*22.0*1001
+2 ;LINE BELOW IS COMMENTED OUT AND REPLACED BY NEW LINE TO CALL
+3 ;$$IHSGL TO ALLOW USE OF DUZ(2) "SOFT" GLOBAL REFERENCE
+4 ;IHS/OIRM/DSD/AEF/01/08/03
+5 ;S:'$$INTEG^DIKK(DIE,DA_DIENS,"","","d") Y(0)=0,X="BADKEY"
+6 IF '$$IHSGL($GET(DIFILEI))
IF '$$INTEG^DIKK(DIE,DA_DIENS,"","","d")
SET Y(0)=0
SET X="BADKEY"
+7 ;----- END IHS MODIFICATION
+8 IF $DATA(Y)<9&'$DATA(DTOUT)&'$DATA(DIC("W"))&($GET(X)'="BADKEY")
QUIT
+9 IF $GET(X)="BADKEY"
IF DISAV0["E"
WRITE !," ",$$EZBLD^DIALOG(741)
+10 IF '$GET(DTOUT)&($DATA(Y)'<9)
SET DUOUT=1
ZAP SET DIK=DIE
+1 ;----- BEGIN IHS MODIFICATION
+2 ;THIS LINE IS COMMENTED AND REPLACED BY THE LINE BELOW TO ADD ZTQUEUED
+3 ;CHECK. ORIGINAL MODIFICATION BY IHS/ANMC/FBD 6/19/97
+4 ;I DISAV0["E" S A1="T",DST=$C(7)_" <'"_$P(@(DIK_"DA,0)"),U,1)_"' DELETED>" W:'$D(DDS) !?3 D H D:$D(DDS) LIST^DDSU
+5 IF DISAV0["E"
SET A1="T"
SET DST=$CHAR(7)_" <'"_$PIECE(@(DIK_"DA,0)"),U,1)_"' DELETED>"
IF '$DATA(DDS)
WRITE !?3
DO H
IF $DATA(DDS)
DO LIST^DDSU
+6 ;----- END IHS MODIFICATION
+7 DO ^DIK
SET Y(0)=0
KILL DST
QUIT
+8 ;
D NEW DISAV0
SET DISAV0=DIC(0)
SET DIE=DIC
DO ZAP
QUIT
+1 ;
ASKP001 ; ask user to confirm new record's .001 field value
+1 ; NEW^DICN
+2 ;
+3 ; quit if there's no .001 or we can't ask
+4 ;
+5 IF DIC(0)'["E"
SET Y=1
QUIT
+6 SET Y=$PIECE(DO,U,2)
+7 IF '$DATA(^DD(+Y,.001,0))
SET Y=1
QUIT
+8 ;
+9 ; if this is not a LAYGO lookup in which X looks like an IEN, and we're
+10 ; adding a new file, and we haven't tried this before, then offer a new
+11 ; .001 based on the user's or site's file range, whichever's handy.
+12 ; NEW^DICN will increment this .001 forward to find the first gap, then
+13 ; drop back through here to the paragraph below (because DO(3) will be
+14 ; defined next time) to offer it to the user
+15 ;
+16 IF '$DATA(DIENTRY)
IF DIC="^DIC("
IF '$DATA(DO(3))
Begin DoDot:1
+17 SET DO(3)=1
+18 IF $SELECT($DATA(^VA(200,DUZ,1))#2:1,1:$DATA(^DIC(3,DUZ,1))#2)
IF $PIECE(^(1),U)
Begin DoDot:2
+19 ; NAKED
SET DIY=.1
SET X=+$PIECE(^(1),U)
End DoDot:2
QUIT
+20 IF $DATA(^DD("SITE",1))
IF X\1000'=^(1)
SET X=^(1)*1000
SET %=0
End DoDot:1
SET Y="TRY NEXT"
QUIT
+21 ;
+22 ; set up our prompt, if .001 looks valid use it as a default, otherwise
+23 ; count forward until we find a valid one to offer
+24 ;
+25 SET DST=" "_$PIECE(DO,U)_" "_$PIECE(^DD(+Y,.001,0),U)_": "
+26 SET %=$PIECE(^DD(+Y,.001,0),U,2)
SET X=$SELECT(%'["N"!(%["O"):0,1:X)
SET %Y=X
+27 IF X
FOR %=1:1
DO N
IF $DATA(X)
QUIT
SET X=0
IF %>999
QUIT
SET X=%Y+DIY
SET %Y=X
+28 IF X
SET DST=DST_X_"// "
+29 ;
+30 ; prompt user for .001
+31 ;
+32 IF '$DATA(DDS)
Begin DoDot:1
+33 WRITE !,DST
KILL DST
READ Y:$SELECT($DATA(DTIME):DTIME,1:300)
IF '$TEST
SET DTOUT=1
SET Y=U
WRITE $CHAR(7)
End DoDot:1
+34 IF '$TEST
Begin DoDot:1
+35 SET A1="Q"
SET DST=3_U_DST
NEW DIY
DO H
DO LIST^DDSU
SET Y=$SELECT($DATA(DTOUT):U,1:%)
KILL %
End DoDot:1
+36 ;
+37 ; sort through possible responses
+38 ;
+39 IF Y[U
SET Y=U
QUIT
+40 IF Y=""
SET Y=1
QUIT
+41 IF Y'="?"
Begin DoDot:1
+42 SET X=Y
DO N
SET Y=$DATA(X)#2
IF Y
Begin DoDot:2
+43 IF $DATA(@(DIC_X_")"))
KILL X
SET Y=0
+44 QUIT
End DoDot:2
IF Y
QUIT
+45 WRITE $CHAR(7)
+46 IF '$DATA(DDS)
WRITE "??"
End DoDot:1
IF Y
QUIT
+47 ;
+48 ; for bad response or help request, offer help and try new IEN
+49 ;
+50 SET DST=""
IF $DATA(^DD(+DO(2),.001,3))
SET DST=" "_^(3)
+51 IF '$DATA(DDS)
Begin DoDot:1
+52 ; NAKED
IF DST]""
WRITE !?5,DST
IF $DATA(^(4))
XECUTE ^(4)
KILL DST
End DoDot:1
+53 IF '$TEST
Begin DoDot:1
+54 ; NAKED
SET A1=0
NEW DIY
DO H
IF $DATA(^(4))
SET DDH("ID")=^(4)
DO LIST^DDSU
End DoDot:1
+55 SET X=$PIECE(DO,U,3)
DO INCR^DICN0
+56 SET Y="TRY NEXT"
+57 QUIT
+58 ;
+59 ;----- BEGIN IHS MODIFICATION - XU*8.0*1007
+60 ;ADD NEW SUBROUTINE IHSGL - IHS/OIRM/DSD/AEF/01/08/03
+61 ;
IHSGL(X) ;----- CHECK GL NODE OF TOP LEVEL FILE FOR DUZ(2)
+1 ;USED TO ALLOW USE OF "SOFT" GLOBAL REFERENCES, I.E., DUZ(2)
+2 ;
+3 ; RETURNS:
+4 ; 0 IF THE TOP LEVEL FILE "GL" NODE DOES NOT CONTAIN DUZ(2)
+5 ; 1 IF IT DOES
+6 ;
+7 ; INPUT:
+8 ; X = FILE NUMBER
+9 ;
+10 NEW DITOP,Y
+11 SET Y=0
+12 IF X
Begin DoDot:1
+13 SET DITOP=X
+14 FOR
IF '$DATA(^DD(DITOP,0,"UP"))
QUIT
SET DITOP=^("UP")
+15 SET Y=$GET(^DIC(DITOP,0,"GL"))["DUZ(2)"
End DoDot:1
+16 QUIT Y
+17 ;
+18 ;----- END IHS MODIFICATION
N ; test X as an IEN (apply input transform and numeric restrictions)
+1 ; USR^DICN, ASKP001
+2 ;
+3 IF $DATA(^DD(+$PIECE(DO,U,2),.001,0))
IF '$DATA(DINUM)
XECUTE $PIECE(^(0),U,5,99)
+4 IF $DATA(X)
IF $LENGTH(X)<15
IF +X=X
IF X>0
IF X>1!(DIC'="^DIC(")
QUIT
+5 KILL X
+6 QUIT
+7 ;
+8 ; 741 Either key values are null, or creates a duplicate key.
+9 ;
