Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (14 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

File:
1 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIE1.m

    r613 r623  
    1 DIE1    ;SFISC/GFT-FILE DATA, XREF IT, GO UP AND DOWN MULTIPLES ;28MAY2008
    2         ;;22.0;VA FileMan;**1,4,11,159**;Mar 30, 1999;Build 8
    3         ;Per VHA Directive 2004-038, this routine should not be modified.
    4         K DQ,DB G E1:$D(DG)<9 I DP<0 K DG S DQ=0 Q
    5         S DQ="",DU=-2,DG="$D("_DIE_DA_",DU))"
    6 Y       S DQ=$O(DG(DQ)),DW=$P(DQ,";",2) G DE:$P(DQ,";")=DU
    7         I DU'<0 S ^(DU)=DV,DU=-2
    8         G IX:DQ="" S DU=$P(DQ,";",1),DV="" I @DG S DV=^(DU)
    9 DE      I 'DW S DW=$E(DW,2,99),DE=DW-$L(DV)-1,%=$P(DW,",",2)+1,X=$E(DV,%,999),DV=$E(DV,0,DW-1)_$J("",$S(DE>0:DE,1:0))_DG(DQ) S:X'?." " DV=DV_$J("",%-DW-$L(DG(DQ)))_X G Y
    10 PC      S $P(DV,"^",DW)=DG(DQ) G Y
    11         ;
    12 IX      S DICRREC="LOADXR^DIED",DQ=$O(DE(" ")) G E1:DQ="",E1:'$D(DG(DQ)) I $D(DE(DE(DQ)))#2 F DG=1:1 Q:'$D(DE(DQ,DG))  S DIC=DIE,X=DE(DE(DQ)) X DE(DQ,DG,2)
    13         S X="" I DG(DQ)]"" F DG=1:1 Q:'$D(DE(DQ,DG))  S DIC=DIE,X=DG(DQ) X DE(DQ,DG,1)
    14         D:$D(DIEFXREF) FIREFLD
    15 E1      K DICRREC,DIFLD,DG,DB,DE,DIANUM S DQ=0 Q
    16         ;
    17 B       ;
    18         I '$D(DB(DQ)) S X="?BAD" G ^DIEQ
    19         S DC=DQ,DIK="",DL=1
    20 OUT     ;
    21         D DIE1 S Y(DC)=DIK G UP:DL>1,Q:DC=0,QY
    22         ;
    23 E       ;
    24         I DP'<0 S DC=$S($D(X)#2:X,1:"") D DIE1 S X=DC G G:DI>0,UP:DL>1
    25 Q       K Y
    26 QY      I $D(DTOUT),$D(DIEDA) D
    27         . N % K DA
    28         . F %=1:1 Q:'$D(DIEDA(%))  S DA(%)=DIEDA(%)
    29         . S DA=DIEDA
    30         . Q
    31         K:$D(DTOUT) DG,DQ
    32         I $D(DIETMP)#2 D FIREREC K @DIETMP,DIETMP
    33         K DIEBADK,DIEFIRE,DIEXREF,DIEFXREF,DIIENS,DIE1,DIESP
    34         K DIP,DB,DE,DM,DK,DL,DH,DU,DV,DW,DP,DC,DIK,DOV,DIEL,DIFLD Q
    35         ;
    36 M       ;
    37         S DD=X,DIC(0)="LM"_$S($D(DB(DQ)):"X",1:"QE"),DO(2)=$P(DC,"^",2),DO=$P($P(DQ(DQ),U)," ",2,99)_"^"_DO(2)_"^"_$P(DC,"^",4,5) D DOWN I @("'$D("_DIC_"0))") S ^(0)="^"_DO(2)
    38         E  I DO(2)["I" S %=0,DIC("W")="" D W^DIC1
    39         K DIC("PTRIX") M DIC("PTRIX")=DIE("PTRIX")
    40 DIC     S D="B",DLAYGO=DP\1,X=DD D  K DIC("PTRIX")
    41         .N DIETMP,DICR D X^DIC
    42         I Y>0 S DA=+Y,DI=0,X=$P(Y,U,2) S:$D(DIETMP)#2 $P(DIIENS,",")=DA S:+DR=.01!(DR="")&$P(Y,U,3) DI=.01,DK=1,DM=$P($P(DR,";",1),":",2),DM=$S(DR="":9999999,DM="":+DR,1:DM) G D1
    43         S DI(DL-1)=DI(DL-1)_U K DUOUT,DTOUT G U1
    44         ;
    45 DOWN    D S,DIE1,DDA S DIE=DIC Q
    46         ;
    47 S       ;CALLED BY O+1^DIE0
    48         S DIOV(DL)=$G(DOV,0) K DOV
    49         S DIE1N(DL)=$G(DIE1N),DP(DL)=DP,DP=+$P(DC,"^",2),DI(DL)=$S(DV'["M":DI,$D(DSC(DP))!$D(DB(DQ)):DI,1:DI_U_$G(DQ(DQ,"CAPTION"))),DIE(DL)=DIE,DK(DL)=DK,DR(DL)=DR
    50         S DM(DL)=DM,DK=0,DIE1(DL)=DIE1,DL=DL+1,DIE1=$S($G(DIE1N):DIE1N,1:DL),DIEL=DIEL+1,DM=9999999,DR=""
    51         I $D(DR(DIE1,DP)) S DM=0,DR=DR(DIE1,DP)
    52         Q
    53         ;
    54 DDA     N T,X
    55         S T=$T
    56         F X=+$O(DA(" "),-1):-1:1 K DA(X+1) S:$D(DA(X))#2 DA(X+1)=DA(X)
    57         K DA(1) S:$D(DA)#2 DA(1)=DA
    58         S DIC=DIE_DA_","""_$P(DC,U,3)_""","
    59         S:$D(DIETMP)#2 DIIENS=","_DIIENS
    60         I T
    61         Q
    62         ;
    63 UDA     N T,X
    64         S T=$T
    65         S DA=$G(DA(1)) ;K DA(1)
    66         F X=2:1:+$O(DA(" "),-1) I $D(DA(X))#2 S DA(X-1)=DA(X) K DA(X)
    67         S:$D(DIETMP)#2 DIIENS=$P(DIIENS,",",2,999)
    68         I T
    69         Q
    70 N       ;
    71         D DOWN S DA=$P(DC,U,4),DI=.01 S:$D(DIETMP)#2 $P(DIIENS,",")=DA S ^DISV(DUZ,$E(DIC,1,28))=$E(DIC,29,999)_DA
    72 D1      S @("D"_DIEL)=DA
    73 G       G MORE^DIE
    74         ;
    75 UP      ;
    76         Q:$D(DTOUT)
    77         S DP(0)=DP_U_DK(DL-1) I $D(DIEC(DL)) D DIEC G U
    78 U1      D UDA S DIEL=DIEL-1
    79 U       S DQ=0,DL=DL-1,DIE1N=DIE1N(DL),DIE=DIE(DL),DM=DM(DL),DI=DI(DL),DP=DP(DL),DR=DR(DL),DK=DK(DL),DIE1=DIE1(DL) I $D(DIOV(DL)) S DOV=DIOV(DL) K DIOV(DL)
    80         G G
    81         ;
    82 DIEC    K DA S DA=DIEC(DL) F %=1:1 Q:'$D(DIEC(DL,%))  S DA(%)=DIEC(DL,%)
    83         F DIEL=0:1 Q:'$D(DIEC(DL,0,DIEL))  S @("D"_DIEL)=DIEC(DL,0,DIEL)
    84         S:$D(DIETMP)#2 DIIENS=DIEC(DL,"IENS")
    85         S DIEL=DIEL-1 K DIEC(DL)
    86         Q
    87         ;
    88 FIREFLD ;Fire field-level xrefs stored in DIEFXREF
    89         D:$D(DIEFXREF)>2 FIRE^DIKC(DP,.DA,"KS","DIEFXREF","O","",$E("C",$G(DIOPER)="A"))
    90         K DIEFXREF
    91         Q
    92         ;
    93 FIREREC ;Fire record-level xrefs accumulated in ^TMP
    94         Q:$D(DIETMP)[0  Q:$D(@DIETMP@("R"))<2
    95         N DP,DIIENS,DIE,DA,DIKEY,Y
    96         ;
    97         S DP=0 F  S DP=$O(@DIETMP@("R",DP)) Q:'DP  D
    98         . S DIIENS=" " F  S DIIENS=$O(@DIETMP@("R",DP,DIIENS)) Q:DIIENS=""  D
    99         .. D DA^DILF(DIIENS,.DA)
    100         .. D FIRE^DIKC(DP,.DA,"KS",$NA(@DIETMP@("R")),"F^^K",.DIKEY,$E("C",$G(DIOPER)="A"))
    101         ;
    102         ;If any keys are invalid, restore values
    103         D:$D(DIKEY)>9 RESTORE(.DIKEY,DIETMP)
    104         ;
    105         K DIEFIRE,@DIETMP@("R"),@DIETMP@("V")
    106         Q
    107         ;
    108 RESTORE(DIKEY,DIETMP)   ;Restore key fields to their pre-edited values
    109         N DA
    110         K DIEBADK
    111         S:$D(DIEFIRE)#2 X="BADKEY"
    112         ;
    113         ;Set "write" and "restore" flags
    114         N DIEWR,DIEREST
    115         I '$D(ZTQUEUED),'$D(DDS),$D(DIEFIRE)[0!($G(DIEFIRE)["M") S DIEWR=1
    116         E  S DIEWR=0
    117         I $D(DIEFIRE)#2,DIEFIRE'["R" S DIEREST=0
    118         E  S DIEREST=1
    119         I '$G(DIEWR),'$G(DIEREST),$G(DIEFIRE)'["L" Q
    120         ;
    121         N DIEFDA,DIEKK,DIEMSG,DIFIL,DIFLD,DIFLDI,DIIENS,DIIENSA
    122         N DINEW,DIOLD,DIRFIL,X
    123         ;
    124         ;Loop through all keys that are not unique and build FDA
    125         K DIEFDA
    126         S DIRFIL=0 F  S DIRFIL=$O(DIKEY(DIRFIL)) Q:'DIRFIL  D
    127         . S DIEKK=0 F  S DIEKK=$O(DIKEY(DIRFIL,DIEKK)) Q:'DIEKK  D
    128         .. Q:$D(^DD("KEY",DIEKK,0))[0
    129         .. K DIFLD
    130         .. S DIFLDI=0 F  S DIFLDI=$O(^DD("KEY",DIEKK,2,DIFLDI)) Q:'DIFLDI  D
    131         ... S DIFLD=$P($G(^DD("KEY",DIEKK,2,DIFLDI,0)),U),DIFIL=$P($G(^(0)),U,2)
    132         ... Q:'DIFLD!'DIFIL
    133         ... S DIFLD(DIFIL,DIFLD)=$$FLEVDIFF^DIKCU(DIRFIL,DIFIL)
    134         .. S DIIENS=" " S DIIENS=$O(DIKEY(DIRFIL,DIEKK,DIIENS)) Q:DIIENS=""  D
    135         ... S DIFIL=0 F  S DIFIL=$O(DIFLD(DIFIL)) Q:'DIFIL  D
    136         .... S DIFLD=0 F  S DIFLD=$O(DIFLD(DIFIL,DIFLD)) Q:'DIFLD  D
    137         ..... Q:$D(^DD(DIFIL,DIFLD,0))[0
    138         ..... S DIIENSA=$P(DIIENS,",",DIFLD(DIFIL,DIFLD)+1,999)
    139         ..... Q:$D(@DIETMP@("V",DIFIL,DIIENSA,DIFLD,"F"))[0!$D(^("4/"))  S DIOLD=^("F")
    140         ..... K DA D DA^DILF(DIIENSA,.DA)
    141         ..... S X=$$DEC^DIKC2(DIFIL,DIFLD) Q:X=""  X X S DINEW=X
    142         ..... I DIEREST S DIEFDA(DIFIL,DIIENSA,DIFLD)=DIOLD
    143         ..... I DIEWR!($G(DIEFIRE)["L") D
    144         ...... S DIEBADK(DIRFIL,DIEKK,DIFIL,DIIENSA,DIFLD,"O")=DIOLD
    145         ...... S DIEBADK(DIRFIL,DIEKK,DIFIL,DIIENSA,DIFLD,"N")=DINEW
    146         ;
    147         I DIEREST,$D(DIEFDA) D FILE^DIE("U","DIEFDA","DIEMSG") K DIERR
    148         I DIEWR,$D(DIEBADK) D MSG^DIEKMSG(.DIEBADK,DIEREST)
    149         ;
    150         I $G(DIEFIRE)'["L" K DIEBADK
    151         Q
     1DIE1 ;SFISC/GFT-FILE DATA, XREF IT, GO UP AND DOWN MULTIPLES ;2:51 PM  21 Oct 1999
     2 ;;22.0;VA FileMan;**1,4,11**;Mar 30, 1999
     3 ;Per VHA Directive 10-93-142, this routine should not be modified.
     4 K DQ,DB G E1:$D(DG)<9 I DP<0 K DG S DQ=0 Q
     5 S DQ="",DU=-2,DG="$D("_DIE_DA_",DU))"
     6Y S DQ=$O(DG(DQ)),DW=$P(DQ,";",2) G DE:$P(DQ,";",1)=DU
     7 I DU'<0 S ^(DU)=DV,DU=-2
     8 G IX:DQ="" S DU=$P(DQ,";",1),DV="" I @DG S DV=^(DU)
     9DE I 'DW S DW=$E(DW,2,99),DE=DW-$L(DV)-1,%=$P(DW,",",2)+1,X=$E(DV,%,999),DV=$E(DV,0,DW-1)_$J("",$S(DE>0:DE,1:0))_DG(DQ) S:X'?." " DV=DV_$J("",%-DW-$L(DG(DQ)))_X G Y
     10PC S $P(DV,"^",DW)=DG(DQ) G Y
     11 ;
     12IX S DICRREC="LOADXR^DIED",DQ=$O(DE(" ")) G E1:DQ="",E1:'$D(DG(DQ)) I $D(DE(DE(DQ)))#2 F DG=1:1 Q:'$D(DE(DQ,DG))  S DIC=DIE,X=DE(DE(DQ)) X DE(DQ,DG,2)
     13 S X="" I DG(DQ)]"" F DG=1:1 Q:'$D(DE(DQ,DG))  S DIC=DIE,X=DG(DQ) X DE(DQ,DG,1)
     14 D:$D(DIEFXREF) FIREFLD
     15E1 K DICRREC,DIFLD,DG,DB,DE,DIANUM S DQ=0 Q
     16 ;
     17B ;
     18 I '$D(DB(DQ)) S X="?BAD" G ^DIEQ
     19 S DC=DQ,DIK="",DL=1
     20OUT ;
     21 D DIE1 S Y(DC)=DIK G UP:DL>1,Q:DC=0,QY
     22 ;
     23E ;
     24 I DP'<0 S DC=$S($D(X)#2:X,1:"") D DIE1 S X=DC G G:DI>0,UP:DL>1
     25Q K Y
     26QY I $D(DTOUT),$D(DIEDA) D
     27 . N % K DA
     28 . F %=1:1 Q:'$D(DIEDA(%))  S DA(%)=DIEDA(%)
     29 . S DA=DIEDA
     30 . Q
     31 K:$D(DTOUT) DG,DQ
     32 I $D(DIETMP)#2 D FIREREC K @DIETMP,DIETMP
     33 K DIEBADK,DIEFIRE,DIEXREF,DIEFXREF,DIIENS
     34 K DIP,DB,DE,DM,DK,DL,DH,DU,DV,DW,DP,DC,DIK,DOV,DIEL,DIFLD Q
     35 ;
     36M ;
     37 S DD=X,DIC(0)="LM"_$S($D(DB(DQ)):"X",1:"QE"),DO(2)=$P(DC,"^",2),DO=$E($P(DQ(DQ),"^",1),8,99)_"^"_DO(2)_"^"_$P(DC,"^",4,5) D DOWN I @("'$D("_DIC_"0))") S ^(0)="^"_DO(2)
     38 E  I DO(2)["I" S %=0,DIC("W")="" D W^DIC1
     39 K DIC("PTRIX") M DIC("PTRIX")=DIE("PTRIX")
     40 K DICR S D="B",DLAYGO=DP\1,X=DD D X^DIC K DIC("PTRIX")
     41 I Y>0 S DA=+Y,DI=0,X=$P(Y,U,2) S:$D(DIETMP)#2 $P(DIIENS,",")=DA S:+DR=.01!(DR="")&$P(Y,U,3) DI=.01,DK=1,DM=$P($P(DR,";",1),":",2),DM=$S(DR="":9999999,DM="":+DR,1:DM) G D1
     42 S DI(DL-1)=DI(DL-1)_U K DUOUT,DTOUT G U1
     43 ;
     44DOWN D S,DIE1,DDA S DIE=DIC Q
     45 ;
     46S S DIOV(DL)=$S('$D(DOV):0,1:DOV) K DOV
     47 S DP(DL)=DP,DP=+$P(DC,"^",2),DI(DL)=$S(DV'["M":DI,$D(DSC(DP))!$D(DB(DQ)):DI,1:DI_U),DIE(DL)=DIE,DK(DL)=DK,DR(DL)=DR,DM(DL)=DM,DK=0,DL=DL+1,DIEL=DIEL+1,DM=9999999,DR="" I $D(DR(DL,DP)) S DM=0,DR=DR(DL,DP)
     48 Q
     49 ;
     50DDA N T,X
     51 S T=$T
     52 F X=+$O(DA(" "),-1):-1:1 K DA(X+1) S:$D(DA(X))#2 DA(X+1)=DA(X)
     53 K DA(1) S:$D(DA)#2 DA(1)=DA
     54 S DIC=DIE_DA_","""_$P(DC,U,3)_""","
     55 S:$D(DIETMP)#2 DIIENS=","_DIIENS
     56 I T
     57 Q
     58 ;
     59UDA N T,X
     60 S T=$T
     61 S DA=$G(DA(1)) ;K DA(1)
     62 F X=2:1:+$O(DA(" "),-1) I $D(DA(X))#2 S DA(X-1)=DA(X) K DA(X)
     63 S:$D(DIETMP)#2 DIIENS=$P(DIIENS,",",2,999)
     64 I T
     65 Q
     66N ;
     67 D DOWN S DA=$P(DC,U,4),DI=.01 S:$D(DIETMP)#2 $P(DIIENS,",")=DA S ^DISV(DUZ,$E(DIC,1,28))=$E(DIC,29,999)_DA
     68D1 S @("D"_DIEL)=DA
     69G G MORE^DIE
     70 ;
     71UP ;
     72 Q:$D(DTOUT)  S DP(0)=DP I $D(DIEC(DL)) D DIEC G U
     73U1 D UDA S DIEL=DIEL-1
     74U S DQ=0,DL=DL-1,DIE=DIE(DL),DM=DM(DL),DI=DI(DL),DP=DP(DL),DR=DR(DL),DK=DK(DL) I $D(DIOV(DL)) S DOV=DIOV(DL) K DIOV(DL)
     75 G G
     76 ;
     77DIEC K DA S DA=DIEC(DL) F %=1:1 Q:'$D(DIEC(DL,%))  S DA(%)=DIEC(DL,%)
     78 F DIEL=0:1 Q:'$D(DIEC(DL,0,DIEL))  S @("D"_DIEL)=DIEC(DL,0,DIEL)
     79 S:$D(DIETMP)#2 DIIENS=DIEC(DL,"IENS")
     80 S DIEL=DIEL-1 K DIEC(DL)
     81 Q
     82 ;
     83FIREFLD ;Fire field-level xrefs stored in DIEFXREF
     84 D:$D(DIEFXREF)>2 FIRE^DIKC(DP,.DA,"KS","DIEFXREF","O","",$E("C",$G(DIOPER)="A"))
     85 K DIEFXREF
     86 Q
     87 ;
     88FIREREC ;Fire record-level xrefs accumulated in ^TMP
     89 Q:$D(DIETMP)[0  Q:$D(@DIETMP@("R"))<2
     90 N DP,DIIENS,DIE,DA,DIKEY,Y
     91 ;
     92 S DP=0 F  S DP=$O(@DIETMP@("R",DP)) Q:'DP  D
     93 . S DIIENS=" " F  S DIIENS=$O(@DIETMP@("R",DP,DIIENS)) Q:DIIENS=""  D
     94 .. D DA^DILF(DIIENS,.DA)
     95 .. D FIRE^DIKC(DP,.DA,"KS",$NA(@DIETMP@("R")),"F^^K",.DIKEY,$E("C",$G(DIOPER)="A"))
     96 ;
     97 ;If any keys are invalid, restore values
     98 D:$D(DIKEY)>9 RESTORE(.DIKEY,DIETMP)
     99 ;
     100 K DIEFIRE,@DIETMP@("R"),@DIETMP@("V")
     101 Q
     102 ;
     103RESTORE(DIKEY,DIETMP) ;Restore key fields to their pre-edited values
     104 N DA
     105 K DIEBADK
     106 S:$D(DIEFIRE)#2 X="BADKEY"
     107 ;
     108 ;Set "write" and "restore" flags
     109 N DIEWR,DIEREST
     110 I '$D(ZTQUEUED),'$D(DDS),$D(DIEFIRE)[0!($G(DIEFIRE)["M") S DIEWR=1
     111 E  S DIEWR=0
     112 I $D(DIEFIRE)#2,DIEFIRE'["R" S DIEREST=0
     113 E  S DIEREST=1
     114 I '$G(DIEWR),'$G(DIEREST),$G(DIEFIRE)'["L" Q
     115 ;
     116 N DIEFDA,DIEKK,DIEMSG,DIFIL,DIFLD,DIFLDI,DIIENS,DIIENSA
     117 N DINEW,DIOLD,DIRFIL,X
     118 ;
     119 ;Loop through all keys that are not unique and build FDA
     120 K DIEFDA
     121 S DIRFIL=0 F  S DIRFIL=$O(DIKEY(DIRFIL)) Q:'DIRFIL  D
     122 . S DIEKK=0 F  S DIEKK=$O(DIKEY(DIRFIL,DIEKK)) Q:'DIEKK  D
     123 .. Q:$D(^DD("KEY",DIEKK,0))[0
     124 .. K DIFLD
     125 .. S DIFLDI=0 F  S DIFLDI=$O(^DD("KEY",DIEKK,2,DIFLDI)) Q:'DIFLDI  D
     126 ... S DIFLD=$P($G(^DD("KEY",DIEKK,2,DIFLDI,0)),U),DIFIL=$P($G(^(0)),U,2)
     127 ... Q:'DIFLD!'DIFIL
     128 ... S DIFLD(DIFIL,DIFLD)=$$FLEVDIFF^DIKCU(DIRFIL,DIFIL)
     129 .. S DIIENS=" " S DIIENS=$O(DIKEY(DIRFIL,DIEKK,DIIENS)) Q:DIIENS=""  D
     130 ... S DIFIL=0 F  S DIFIL=$O(DIFLD(DIFIL)) Q:'DIFIL  D
     131 .... S DIFLD=0 F  S DIFLD=$O(DIFLD(DIFIL,DIFLD)) Q:'DIFLD  D
     132 ..... Q:$D(^DD(DIFIL,DIFLD,0))[0
     133 ..... S DIIENSA=$P(DIIENS,",",DIFLD(DIFIL,DIFLD)+1,999)
     134 ..... Q:$D(@DIETMP@("V",DIFIL,DIIENSA,DIFLD,"F"))[0!$D(^("4/"))  S DIOLD=^("F")
     135 ..... K DA D DA^DILF(DIIENSA,.DA)
     136 ..... S X=$$DEC^DIKC2(DIFIL,DIFLD) Q:X=""  X X S DINEW=X
     137 ..... I DIEREST S DIEFDA(DIFIL,DIIENSA,DIFLD)=DIOLD
     138 ..... I DIEWR!($G(DIEFIRE)["L") D
     139 ...... S DIEBADK(DIRFIL,DIEKK,DIFIL,DIIENSA,DIFLD,"O")=DIOLD
     140 ...... S DIEBADK(DIRFIL,DIEKK,DIFIL,DIIENSA,DIFLD,"N")=DINEW
     141 ;
     142 I DIEREST,$D(DIEFDA) D FILE^DIE("U","DIEFDA","DIEMSG") K DIERR
     143 I DIEWR,$D(DIEBADK) D MSG^DIEKMSG(.DIEBADK,DIEREST)
     144 ;
     145 I $G(DIEFIRE)'["L" K DIEBADK
     146 Q
Note: See TracChangeset for help on using the changeset viewer.