DICN1 ;SFISC/GFT,TKW,SEA/TOAD-PROCESS DIC("DR") ;8MAR2006
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
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
W:'$D(ZTQUEUED) DST K A1,DST Q
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
I '$$IHSGL($G(DIFILEI)) S:'$$INTEG^DIKK(DIE,DA_DIENS,"","","d") Y(0)=0,X="BADKEY" ;IHS
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
I DISAV0["E" S A1="T",DST=$C(7)_" <'"_$P(@(DIK_"DA,0)"),U,1)_"' DELETED>" W:'$D(DDS)&'$D(ZTQUEUED) !?3 D H D:$D(DDS)&'$D(ZTQUEUED) LIST^DDSU
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
;
EGP S DST=$$HELP^DIALOGZ(+DO(2),.001) I $D(^DD(+DO(2),.001,0)),DST]"" S DST=" "_DST ;**CCO/NI HELP MESSAGE FOR .001 FIELD WHEN USER IS LAYGO-ING (NOTE NAKED REFERENCES IN FOLLOWING LINES)
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
;
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
;
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.
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICN1 6157 printed Dec 13, 2024@02:46:24 Page 2
DICN1 ;SFISC/GFT,TKW,SEA/TOAD-PROCESS DIC("DR") ;8MAR2006
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+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 if '$DATA(ZTQUEUED)
WRITE DST
KILL A1,DST
QUIT
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 ;IHS
IF '$$IHSGL($GET(DIFILEI))
if '$$INTEG^DIKK(DIE,DA_DIENS,"","","d")
SET Y(0)=0
SET X="BADKEY"
+2 if $DATA(Y)<9&'$DATA(DTOUT)&'$DATA(DIC("W"))&($GET(X)'="BADKEY")
QUIT
+3 IF $GET(X)="BADKEY"
IF DISAV0["E"
WRITE !," ",$$EZBLD^DIALOG(741)
+4 if '$GET(DTOUT)&($DATA(Y)'<9)
SET DUOUT=1
ZAP SET DIK=DIE
+1 IF DISAV0["E"
SET A1="T"
SET DST=$CHAR(7)_" <'"_$PIECE(@(DIK_"DA,0)"),U,1)_"' DELETED>"
if '$DATA(DDS)&'$DATA(ZTQUEUED)
WRITE !?3
DO H
if $DATA(DDS)&'$DATA(ZTQUEUED)
DO LIST^DDSU
+2 DO ^DIK
SET Y(0)=0
KILL DST
QUIT
+3 ;
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 ;
EGP ;**CCO/NI HELP MESSAGE FOR .001 FIELD WHEN USER IS LAYGO-ING (NOTE NAKED REFERENCES IN FOLLOWING LINES)
SET DST=$$HELP^DIALOGZ(+DO(2),.001)
IF $DATA(^DD(+DO(2),.001,0))
IF DST]""
SET DST=" "_DST
+1 IF '$DATA(DDS)
Begin DoDot:1
+2 ; NAKED
if DST]""
WRITE !?5,DST
if $DATA(^(4))
XECUTE ^(4)
KILL DST
End DoDot:1
+3 IF '$TEST
Begin DoDot:1
+4 ; NAKED
SET A1=0
NEW DIY
DO H
if $DATA(^(4))
SET DDH("ID")=^(4)
DO LIST^DDSU
End DoDot:1
+5 SET X=$PIECE(DO,U,3)
DO INCR^DICN0
+6 SET Y="TRY NEXT"
+7 QUIT
+8 ;
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 ;
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 ;
