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

DIED.m

Go to the documentation of this file. 
  1. DIED ;SFISC/GFT,XAK-MAJOR INPUT PROCESSOR ;05:43 PM  2 Jan 2002 [ 12/09/2003  4:14 PM ]
  1.  ;;22.0;VA FileMan;**4,21,11,59,96,1002**;Mar 30, 1999
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. O D W W Y W:$X>48 !?9
  1.  I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
  1.  I Y]"" W "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
  1. TR Q:$P(DQ(DQ),U,2)["K"&(DUZ(0)'="@")  R X:DTIME E  S (DTOUT,X)=U W $C(7)
  1.  Q
  1. W I $P(DQ(DQ),U,2)["K"&(DUZ(0)'="@") Q
  1.  I $D(DIE("W")) X DIE("W") Q
  1.  W !?DL+DL-2,$P(DQ(DQ),U,1)_": " Q
  1.  ;
  1. DQ ;
  1.  S:$D(DTIME)[0 DTIME=300 S DQ=1 G B
  1. A K DQ(DQ) S DQ=DQ+1
  1. B S DIFLD=$S($D(DIFLD(DQ)):DIFLD(DQ),1:-1)
  1.  I '$D(DQ(DQ)) G E^DIE1:'$D(DQ(0,DQ)),BR^DIE0
  1. RE ;
  1.  S DIP=$P(DQ(DQ),U,1),DV=$P(DQ(DQ),U,2),DU=$P(DQ(DQ),U,3) G:DV["K"&(DUZ(0)'="@") A G PR:$D(DE(DQ)) D W,TR I $D(DTOUT) K DQ,DG G QY^DIE1
  1. N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:$P(DC,U,2)-DP(0),A
  1. RD G ^DIE0:X[U,^DIE2:X="@" I X?."?" G A:$D(DB(DQ)),^DIEQ ;MAC-1201-61253
  1.  I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DIP)) S X=^(DIP) I DV'["D",DV'["S" W "  "_X
  1. T G M^DIE1:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D  I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
  1. SET .N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
  1.  .I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
  1.  .D ^DIR I 'DDER S %=Y(0),X=Y
  1.  K DDER G X
  1. P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G AST:DV["*" D NOSCR S X=+Y,DIC=DIE G X:X<0
  1.  G V:DV'["N" I $L($P(X,"."))>24 K X G Z
  1.  I $P(DQ(DQ),U,5,99)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
  1. V S DIER=1 X $P(DQ(DQ),U,5,99) K DIER,YS
  1. Z K DIC("S"),DLAYGO I $D(X),X?.ANP,X'=U D LOADXR G:'$$KEYCHK UNIQFERR S DG($P(DQ(DQ),U,4))=X S:DV["d" ^DISV(DUZ,"DIE",DIP)=X G A
  1. X W:'$D(ZTQUEUED) $C(7) W:'$D(DDS)&'$D(ZTQUEUED) "??"
  1.  G B^DIE1
  1.  ;
  1. PR I $D(DE(DQ,0)) S Y=DE(DQ,0) G F:Y?1"/".E I $D(DE(DQ))=10 D Y:$E(Y,1)=U,O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
  1.  S DG=DV,Y=DE(DQ),X=DU I DG["O",$D(^DD(DP,DIFLD,2)) X ^(2) G S
  1. R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G S:'$D(^(Y,0)) S Y=$P(^(0),U,1),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
  1.  I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G S:'$D(^(+Y,0)) S Y=$P(^(0),U,1) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
  1.  X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";",1) S:%]"" Y=%
  1. S D O I $D(DTOUT) K DQ,DG G QY^DIE1
  1.  I X="" S X=DE(DQ) X:$D(DICATTZ) $P(DQ(DQ),U,5,99) G A:'DV,A:DC<2 G N^DIE1
  1.  G RD:DQ(DQ)'["DINUM" D E^DIE0 G RD:$D(X),PR
  1.  ;
  1. F S DB(DQ)=1,X=$E(Y,2,999),DH=$F(DQ(DQ),"%DT=""E") I DH S DQ(DQ)=$E(DQ(DQ),1,DH-2)_$E(DQ(DQ),DH,999)
  1.  I X?1"/".E S X=$E(X,2,999),DH=""
  1.  X:$E(X,1)=U $E(X,2,999) G:X="" A:'DV,A:'$P(DC,U,4),N^DIE1 I $D(DE(DQ))#2,DV["I"!(DQ(DQ)["DINUM") D E^DIE0
  1.  G X:'$D(X),RD:DH]"",RD:X="@",M^DIE1:DV,Z
  1.  ;
  1. Y X $E(Y,2,999) S Y=X I DV["D",Y?7N.NP X ^DD("DD")
  1. Q Q
  1.  ;
  1. AST ;G V:DV["'",AST^DIE9
  1.  I DV["'" D
  1.  . D SCRNL(.DICONT)
  1.  E  D SCRL(.DICONT)
  1.  I DICONT="V" K DICONT G V:$D(DNM)[0,@("V^"_DNM)
  1.  I DICONT="X" K DICONT G X:$D(DNM)[0,@("X^"_DNM)
  1.  I DICONT="Z" K DICONT G Z:$D(DNM)[0,@("Z^"_DNM)
  1.  Q
  1. RW G RW^DIR2
  1.  ;
  1. LOADXR ;Load all index file xrefs for a field
  1.  Q:$D(DIETMP)[0
  1.  N FLIST,RLIST,OLD
  1.  ;
  1.  I $G(DICRREC)]"" N DP,DIFLD,DIIENS S OLD=DIU,DP=DIH,DIFLD=DIG,DIIENS=DICRIENS
  1.  E  S OLD=$G(DE(DQ))
  1.  ;
  1.  ;Get field- and record-level xrefs
  1.  D LOADFLD^DIKC1(DP,DIFLD,"KS","",$NA(@DIETMP@("V")),"DIEFXREF",$NA(@DIETMP@("R")),.FLIST,.RLIST)
  1.  I FLIST="",RLIST="" Q
  1.  S:RLIST]"" @DIETMP@("R",DP,DIIENS)=DIE
  1.  ;
  1.  ;Save the old value of the field
  1.  S @DIETMP@("V",DP,DIIENS,DIFLD,"O")=OLD S:$D(^("F"))[0 ^("F")=OLD
  1.  I $G(DICRREC)="",$G(DE(DQ,0))?1"//".E S @DIETMP@("V",DP,DIIENS,DIFLD,"4/")=""
  1.  E  K @DIETMP@("V",DP,DIIENS,DIFLD,"4/")
  1.  Q
  1.  ;
  1. KEYCHK() ;If this is a key field, return 0 if not unique.
  1.  N DIEKCHK
  1.  Q:$D(DIETMP)[0 1
  1.  Q:'$D(DIEFXREF) 1
  1.  Q:$G(DE(DQ,0))?1"//".E 1
  1.  S @DIETMP@("V",DP,DIIENS,DIFLD,"N")=X
  1.  S DIEKCHK=$$KEYCHK^DIKK2(DP,.DA,DIFLD,"DIEFXREF",DIIENS,"","N")
  1.  K @DIETMP@("V",DP,DIIENS,DIFLD,"N")
  1.  Q DIEKCHK
  1.  ;
  1. UNIQFERR ;The field is part of a key and is not unique
  1.  I '$D(ZTQUEUED),'$D(DDS) D
  1.  . W $C(7)_"??"
  1.  . W:'$D(DB(DQ)) !,"     Another entry already exists with this key value."
  1.  K DIEFXREF S ^("N")=@DIETMP@("V",DP,DIIENS,DIFLD,"O")
  1.  G B^DIE1
  1.  ;
  1. NKEY ;No value was assigned to this key field
  1.  I '$D(ZTQUEUED),'$D(DDS) W $C(7)_"??  Required key field"
  1.  G B^DIE1
  1.  ;
  1. NOSCR ;No screen
  1.  N DIXRL
  1.  D GETXRL(DP,DIFLD,+$P(DV,"P",2),.DIXRL)
  1.  I DV'["'",$G(DIXRL)]"",(U_DIXRL_U)'["^B^" S DIXRL=DIXRL_"^B"
  1.  D DIC($G(DIXRL))
  1.  Q
  1.  ;
  1. SCRNL(DICONT) ;Screen, No LAYGO allowed
  1.  N DIFRST,DILAST,DIXRL
  1.  K DICONT
  1.  ;
  1.  D GETXRL(DP,DIFLD,+$P(DV,"P",2),.DIXRL)
  1.  G:$G(DIXRL)="" EXIT
  1.  ;
  1.  D:$D(DNM)#2 @("D^"_DNM)
  1.  D PARSE($P(DQ(DQ),U,5,999),.DIFRST,.DILAST)
  1.  G:'$D(DIFRST) EXIT
  1.  ;
  1.  X DIFRST
  1.  D DIC(DIXRL) S X=+Y
  1.  X:Y>0 DILAST
  1.  S DICONT=$S('$D(X):"X",X<0:"X",1:"Z")
  1.  Q
  1.  ;
  1. SCRL(DICONT) ;Screen, LAYGO allowed
  1.  N DICALL,DICSS,DIFRST,DILAST,DIXRL
  1.  K DICONT
  1.  ;
  1.  D GETXRL(DP,DIFLD,+$P(DV,"P",2),.DIXRL)
  1.  D:$D(DNM) @("D^"_DNM)
  1.  D PARSE($P(DQ(DQ),U,5,999),.DIFRST,.DILAST)
  1.  G:'$D(DIFRST) EXIT
  1.  ;
  1.  K D X DIFRST I '$D(DIC("S")),$G(DIXRL)="" S DICONT="V" Q
  1.  S DICSS=$G(DIC("S"))
  1.  ;
  1.  I $G(DIXRL)="" S DIXRL=$G(D)
  1.  E  S:(U_DIXRL_U)'["^B^" DIXRL=DIXRL_"^B"
  1.  D DIC($G(DIXRL))
  1.  S X=+Y
  1.  ;
  1.  I $P(Y,U,3) S Y=+Y X:$D(@(DIC_Y_",0)")) DICSS E  D  S DICONT="X" Q
  1.  . N DV,DU,DA
  1.  . S DA=Y,DIK=DIC D ^DIK
  1.  ;
  1.  X:Y>0 DILAST
  1.  S DICONT=$S('$D(X):"X",X<0:"X",1:"Z")
  1.  Q
  1.  ;
  1. EXIT ;Cleanup and set flag to continue by executing the input transform
  1.  K DIC("PTRIX")
  1.  S DICONT="V"
  1.  Q
  1.  ;
  1. DIC(D) ;Make the appropriate ^DIC call based on D
  1.  I $G(D)]"",$P(D,U,2)="" S DIC(0)=$TR(DIC(0),"M")
  1.  E  S:DIC(0)'["M" DIC(0)="M"_DIC(0)
  1.  ;
  1.  I $P($G(D),U)="" D
  1.  . D ^DIC
  1.  E  I $P(D,U,2)]"" D
  1.  . D MIX^DIC1
  1.  E  D IX^DIC
  1.  K DIC("PTRIX")
  1.  Q
  1.  ;
  1. PARSE(IT,FRST,LAST) ;Parse input transform
  1.  N CALL,I
  1.  F CALL=" D ^DIC"," D IX^DIC"," D MIX^DIC1","" Q:IT[CALL
  1.  I CALL="" K FRST,LAST Q
  1.  S FRST=$P(IT,CALL),LAST=$P(IT,CALL_" ",2,999)
  1.  I FRST?.E1" " D  S FRST=$E(FRST,1,I)
  1.  . F I=$L(FRST)-1:-1:0 Q:$E(FRST,I)'=" "
  1.  Q
  1.  ;
  1. GETXRL(FIL,FLD,PFIL,LIST) ;Get list of indexes from DIE("PTRIX")
  1.  K DIC("PTRIX"),LIST Q:'$D(DIE("PTRIX"))
  1.  M DIC("PTRIX")=DIE("PTRIX")
  1.  ;
  1.  S LIST=$G(DIE("PTRIX",FIL,FLD,PFIL))
  1.  K:LIST="" LIST
  1.  Q