Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DICN1

DICN1.m

Go to the documentation of this file. 
  1. 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
  1.  ;;22.0;VA FileMan;**4,67**;Mar 30, 1999
  1.  ;THIS ROUTINE CONTAINS AN IHS MODIFICATON BY IHS/ANMC/FBD 6/19/97
  1.  ;AND IHS/OIRM/DSD/AEF/01/08/03
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1.  K DIDA,DICRS,Y,%RCR
  1.  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)=""
  1.  S DZ="W !?3,$S("""_$P(DO,U)_"""'=$P(DQ(DQ),U):"""_$P(DO,U)_""",1:"""")_"" ""_$P(DQ(DQ),U)_"": """
  1.  S Y=DA N % S %=0 D  I '$D(%) D W,BAD Q
  1.  . S DD="" N I,J,X,Y
  1.  . I DINO01 D
  1.  . . S DD=".01//"
  1.  . . S I=$G(DISUBVAL(+DO(2),.01)) I I="" S DD=DD_";" Q
  1.  . . S DD=DD_$S(DIC(0)'["E":"/",1:"")_"^S X=DISUBVAL("_+DO(2)_",.01);" Q
  1.  . K DISUBVAL(+DO(2),.01)
  1.  . F I=0:0 S I=$O(DISUBVAL(+DO(2),I)) Q:'I  D
  1.  . . S DD=DD_I_"//"
  1.  . . I $G(DISUBVAL(+DO(2),I,"INT"))]"" S DD=DD_"//^S X=DISUBVAL("_+DO(2)_","_I_",""INT"");" Q
  1.  . . S:DIC(0)'["E" DD=DD_"/"
  1.  . . S DD=DD_"^S X=DISUBVAL("_+DO(2)_","_I_");" Q
  1.  . S DD=DD_$G(DIC("DR")) I DD]"",$E(DD,$L(DD))'=";" S DD=DD_";"
  1.  . Q:DIC(0)'["E"
  1.  . 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
  1.  . . S X=$G(^DD("KEY",I,2,J,0)) Q:$P(X,U,2)'=+DO(2)
  1.  . . S Y=$P(X,U) Q:'Y  D CKID
  1.  . . Q
  1.  . Q:$D(DIC("DR"))!('$D(%))
  1.  . S Y=0 F  S Y=$O(^DD(+DO(2),0,"ID",Y)) Q:'Y  D CKID Q:'$D(%)
  1.  . Q
  1.  I DD]"",$O(^DD("KEY","B",+DO(2),0)) D
  1.  . N I S I=$S(DIC(0)["E":"M",1:"")
  1.  . S DD=DD_"S DIEFIRE="""_I_"""" Q
  1.  S %RCR="RCR^DICN1" D STORLIST^%RCR
  1.  I $D(Y)<9 S Y=DA Q
  1.  ;
  1. BAD S:$D(D)#2 DA=D K Y I '$D(DO(1)) S Y=-1 D Q^DIC2 Q
  1.  K DO D A^DIC S DS(0)="1^",Y=-1 Q
  1.  ;
  1. CKID I $G(DUZ(0))'="@",$G(^DD(+DO(2),Y,9))]"" D  Q:'$D(%)  Q:$L(^DD(+DO(2),Y,9))<%
  1.  . F %=1:1 I DUZ(0)[$E(^DD(+DO(2),Y,9),%) Q:$L(^(9))'<%  K:$P(^(0),U,2)["R" % Q
  1.  Q:Y=.01
  1.  I $P(DD,"//")=Y!(DD[(";"_Y_"//"))!(DD[(";"_Y_";")) Q
  1.  S DD=DD_Y_";"
  1. Q Q
  1.  ;
  1. W S A1="T",DST="SORRY!  A VALUE FOR '"_$P(^(0),U,1)_"' MUST BE ENTERED," W:'$D(DDS) ! D H
  1.  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
  1.  S %RCR="D^DICN1" D STORLIST^%RCR Q
  1.  ;
  1. H I $D(DDS) S DDH=$S($D(DDH):DDH+1,1:1),DDH(DDH,A1)=DST K A1,DST Q
  1.  ;----- BEGIN IHS MODIFICATION
  1.  ;THIS LINE IS COMMENTED OUT AND REPLACED BY THE LINE BELOW TO ADD
  1.  ;CHECK FOR ZTQUEUED.  ORIGINAL MODIFICATION BY IHS/ANMC/FBD 6/19/97
  1.  ;W DST K A1,DST Q
  1.  W:'$D(ZTQUEUED) DST K A1,DST Q
  1.  ;----- END IHS MODIFICATION
  1. RCR ;
  1.  K DR,DIADD,DQ,DG,DE,DO N DISAV0 S DIE=DIC,DR=DD,DIE("W")=DZ,DISAV0=DIC(0) K DIC
  1.  I $D(DIE("NO^")) S %RCR("DIE(""NO^"")")=DIE("NO^")
  1.  S DIE("NO^")="BACKOUTOK" N X
  1.  D:$D(DDS) CLRMSG^DDS D:DR]""  K DIE("W"),DIE("NO^")
  1.  . N DISAV0,DIFILEI,DINDEX,DIVAL,DIENS,DIOPER
  1.  . S DIOPER="A" K % M %=DISUBVAL N DISUBVAL M DISUBVAL=% K %
  1.  . D ^DIE Q
  1.  D:$D(DDS)
  1.  . I $Y<IOSL D CLRMSG^DDS Q
  1.  . D REFRESH^DDSUTL
  1. A I '$D(DA) S Y(0)=0 Q
  1.  ;----- BEGIN IHS MODIFICATION - DI*22.0*1001
  1.  ;LINE BELOW IS COMMENTED OUT AND REPLACED BY NEW LINE TO CALL
  1.  ;$$IHSGL TO ALLOW USE OF DUZ(2) "SOFT" GLOBAL REFERENCE
  1.  ;IHS/OIRM/DSD/AEF/01/08/03
  1.  ;S:'$$INTEG^DIKK(DIE,DA_DIENS,"","","d") Y(0)=0,X="BADKEY"
  1.  I '$$IHSGL($G(DIFILEI)) S:'$$INTEG^DIKK(DIE,DA_DIENS,"","","d") Y(0)=0,X="BADKEY"
  1.  ;----- END IHS MODIFICATION
  1.  Q:$D(Y)<9&'$D(DTOUT)&'$D(DIC("W"))&($G(X)'="BADKEY")
  1.  I $G(X)="BADKEY",DISAV0["E" W !,"      ",$$EZBLD^DIALOG(741)
  1.  S:'$G(DTOUT)&($D(Y)'<9) DUOUT=1
  1. ZAP S DIK=DIE
  1.  ;----- BEGIN IHS MODIFICATION
  1.  ;THIS LINE IS COMMENTED AND REPLACED BY THE LINE BELOW TO ADD ZTQUEUED
  1.  ;CHECK.  ORIGINAL MODIFICATION BY IHS/ANMC/FBD 6/19/97
  1.  ;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
  1.  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
  1.  ;----- END IHS MODIFICATION
  1.  D ^DIK S Y(0)=0 K DST Q
  1.  ;
  1. D N DISAV0 S DISAV0=DIC(0),DIE=DIC D ZAP Q
  1.  ;
  1. ASKP001 ; ask user to confirm new record's .001 field value
  1.  ; NEW^DICN
  1.  ;
  1.  ; quit if there's no .001 or we can't ask
  1.  ;
  1.  I DIC(0)'["E" S Y=1 Q
  1.  S Y=$P(DO,U,2)
  1.  I '$D(^DD(+Y,.001,0)) S Y=1 Q
  1.  ;
  1.  ; if this is not a LAYGO lookup in which X looks like an IEN, and we're
  1.  ; adding a new file, and we haven't tried this before, then offer a new
  1.  ; .001 based on the user's or site's file range, whichever's handy.
  1.  ; NEW^DICN will increment this .001 forward to find the first gap, then
  1.  ; drop back through here to the paragraph below (because DO(3) will be
  1.  ; defined next time) to offer it to the user
  1.  ;
  1.  I '$D(DIENTRY),DIC="^DIC(",'$D(DO(3)) D  S Y="TRY NEXT" Q
  1.  . S DO(3)=1
  1.  . I $S($D(^VA(200,DUZ,1))#2:1,1:$D(^DIC(3,DUZ,1))#2),$P(^(1),U) D  Q
  1.  . . S DIY=.1,X=+$P(^(1),U) ; NAKED
  1.  . I $D(^DD("SITE",1)),X\1000'=^(1) S X=^(1)*1000,%=0
  1.  ;
  1.  ; set up our prompt, if .001 looks valid use it as a default, otherwise
  1.  ; count forward until we find a valid one to offer
  1.  ;
  1.  S DST="   "_$P(DO,U)_" "_$P(^DD(+Y,.001,0),U)_": "
  1.  S %=$P(^DD(+Y,.001,0),U,2),X=$S(%'["N"!(%["O"):0,1:X),%Y=X
  1.  I X F %=1:1 D N Q:$D(X)  S X=0 Q:%>999  S X=%Y+DIY,%Y=X
  1.  I X S DST=DST_X_"// "
  1.  ;
  1.  ; prompt user for .001
  1.  ;
  1.  I '$D(DDS) D
  1.  . W !,DST K DST R Y:$S($D(DTIME):DTIME,1:300) E  S DTOUT=1,Y=U W $C(7)
  1.  E  D
  1.  . S A1="Q",DST=3_U_DST N DIY D H,LIST^DDSU S Y=$S($D(DTOUT):U,1:%) K %
  1.  ;
  1.  ; sort through possible responses
  1.  ;
  1.  I Y[U S Y=U Q
  1.  I Y="" S Y=1 Q
  1.  I Y'="?" D  Q:Y
  1.  . S X=Y D N S Y=$D(X)#2 D:Y  Q:Y
  1.  . . I $D(@(DIC_X_")")) K X S Y=0
  1.  . . Q
  1.  . W $C(7)
  1.  . W:'$D(DDS) "??"
  1.  ;
  1.  ; for bad response or help request, offer help and try new IEN
  1.  ;
  1.  S DST="" I $D(^DD(+DO(2),.001,3)) S DST="     "_^(3)
  1.  I '$D(DDS) D
  1.  . W:DST]"" !?5,DST X:$D(^(4)) ^(4) K DST ; NAKED
  1.  E  D
  1.  . S A1=0 N DIY D H S:$D(^(4)) DDH("ID")=^(4) D LIST^DDSU ; NAKED
  1.  S X=$P(DO,U,3) D INCR^DICN0
  1.  S Y="TRY NEXT"
  1.  Q
  1.  ;
  1.  ;----- BEGIN IHS MODIFICATION - XU*8.0*1007
  1.  ;ADD NEW SUBROUTINE IHSGL - IHS/OIRM/DSD/AEF/01/08/03
  1.  ;
  1. 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)
  1.  ;
  1.  ;      RETURNS:
  1.  ;      0 IF THE TOP LEVEL FILE "GL" NODE DOES NOT CONTAIN DUZ(2)
  1.  ;      1 IF IT DOES
  1.  ;
  1.  ;      INPUT:
  1.  ;      X  =  FILE NUMBER
  1.  ;
  1.  N DITOP,Y
  1.  S Y=0
  1.  I X D
  1.  . S DITOP=X
  1.  . F  Q:'$D(^DD(DITOP,0,"UP"))  S DITOP=^("UP")
  1.  . S Y=$G(^DIC(DITOP,0,"GL"))["DUZ(2)"
  1.  Q Y
  1.  ;      
  1.  ;----- END IHS MODIFICATION
  1. N ; test X as an IEN (apply input transform and numeric restrictions)
  1.  ; USR^DICN, ASKP001
  1.  ;
  1.  I $D(^DD(+$P(DO,U,2),.001,0)),'$D(DINUM) X $P(^(0),U,5,99)
  1.  I $D(X),$L(X)<15,+X=X,X>0,X>1!(DIC'="^DIC(") Q
  1.  K X
  1.  Q
  1.  ;
  1.  ; 741   Either key values are null, or creates a duplicate key.
  1.  ;