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/DIE.m

    r613 r623  
    1 DIE     ;SFISC/GFT,XAK-PROC.DR-STR ;28MAR2006
    2         ;;22.0;VA FileMan;**1,4,8,11,59,95,159**;Mar 30, 1999;Build 8
    3         ;Per VHA Directive 2004-038, this routine should not be modified.
    4         N DG,DNM,DICRREC K DB I DIE S DIE=^DIC(DIE,0,"GL")
    5         Q:$D(@(DIE_DA_",-9)"))  Q:'$D(@(DIE_"0)"))  S U="^",DP=+$P(^(0),U,2) Q:$P($G(^DD($$FNO^DILIBF(DP),0,"DI")),U,2)["Y"&'$D(DIOVRD)&'$G(DIFROM)
    6 GO      Q:DIE?1"^DIA(".E  Q:DA'>0  K DE,DOV,DIOV,DIEC,DTOUT N DIEDA D
    7         . N %
    8         . F %=1:1 Q:'$G(DA(%))  S DIEDA(%)=DA(%)
    9         . S DIEDA=DA
    10         . Q
    11         I $D(DIETMP)[0 N DIETMP S DIETMP=$$GETTMP^DIKC1("DIE")
    12         N DIEFXREF,DIIENS,DIE1,DIE1N K DIEFIRE,DIEBADK,DIESP S DIIENS=$$IENS^DIKCU(DP,.DA)
    13         S DL=1,DIE1=1,D0=DA,DI=DP,DR(1,DP)=DR D INI I $E(DR)'="[" D DR^DIE17
    14         S DP=DI,DA=D0,(DQ,DIEL,DK,DP(0))=0 K DIC("S")
    15 MR      S DK=DK+1,DH=$P(DR,";",DK) I +DH=DH S (DI,DM)=DH G S:$D(^DD(DP,DI)),MR
    16         S DI=$P(DH,":",1) I 'DI G K:DI=0,PB
    17 J       I DH["//" S DE(DQ+1,0)=$P(DH,"//",2,9),DI=$P(DI,"//",1),DH=""
    18         G K:+DI=DI S DM=+DI,Y=$P(DI,DM,2,99),DI=DM G MR:Y=""!'$D(^DD(DP,DI,0)) S DQ=DQ+1,(DZ,DQ(DQ))=^(0),DIFLD(DQ)=DI
    19 SPC     F %=1:1 S DIESP=$P(Y,$C(126),%) Q:DIESP=""  D
    20         .I DIESP="d"!(DIESP="R") S $P(DZ,U,2)=$P(DZ,U,2)_DIESP Q
    21         .I DIESP="T"!(DIESP="t") S:$G(^DD(DP,DI,.1))]"" $P(DZ,U)=^(.1) Q
    22         .S $P(DZ,U)=DIESP,DQ(DQ,"CAPTION")=DIESP
    23         S:DH'[$C(126) DH=DH_$C(126) S DQ(DQ)=DZ K DZ G Y
    24         ;
    25 K       S DM=$P(DH,":",2),DM=$S(DM:DM,1:DI) I DI,$D(^DD(DP,DI)) G S
    26 NX      S DI=$O(^DD(DP,DI)) S:DI="" DI=-1 G MR:DI'>0,MR:DI>DM
    27 S       I DQ'<50,'$D(DE(DQ+1)) G H
    28         S DQ=DQ+1,DQ(DQ)=^(DI,0),DIFLD(DQ)=DI
    29 Y       S Y=$P(DQ(DQ),"^",4),DG=$P(Y,";",1)
    30         ;Determine whether field has a xref defined in the Index file
    31         S DIEXREF=0 F  S DIEXREF=$O(^DD("IX","F",DP,DI,DIEXREF)) Q:'DIEXREF  I $P($G(^DD("IX",DIEXREF,0)),U) S DIEXREF=1 Q
    32         I $D(^DD(DP,DI,1))!($P(DQ(DQ),U,2)["a")!DIEXREF S DE=0,DB=DM,DM=0,DE(Y)=DQ K DIEXREF F DW=1:1 S DE=$O(^DD(DP,DI,1,DE)) Q:DE<1  S DE(Y,DW,1)=^(DE,1),DE(Y,DW,2)=^(2)
    33         I  S:DE="" DE=-1
    34         I $P(DQ(DQ),U,2)["a" S DE(Y,DW,2)="S DIIX=2_U_DIFLD(DE(DQ)) D AUDIT^DIET",DE(Y,DW,1)="S DIIX=3_U_DIFLD(DE(DQ)) D AUDIT^DIET",DE(Y)=DQ I ^DD(DP,DI,"AUDIT")="e" S DE(Y,DW,1)="I $D(DE(DE(DQ)))#2 "_DE(Y,DW,1)
    35         S Y=$P(Y,";",2) I DU'=DG S D="",DU=DG,@DC G M:Y=0,B:DU=" ",EQ:DW[0 S D=^(DG)
    36         I Y S:$P(D,"^",Y)]"" DE(DQ)=$P(D,"^",Y)
    37         E  S Y=$E(D,+$E(Y,2,9),$P(Y,",",2)) S:Y'?." " DE(DQ)=Y
    38 EQ      G MR:DI=DM,NX:DM S DM=DB K DB G D
    39         ;
    40 INI     K DIC("S") S DIC=DIE,DU=-1,DC="DW=$D("_DIE_DA_",DG))"
    41 Q       Q
    42         ;
    43         ;
    44 MORE    ;from ^DIE1
    45         D INI G MR:DI=DM,NX:DI'[U,MR:'$D(^DD(DP,+DI)) S %=$P(DI,U,2),DI=+DI S:%]"" DQ(DQ+1,"CAPTION")=% G S
    46         ;
    47         ;
    48 JMP     ;from ^DIE0
    49         D INI G J
    50         ;
    51 PB      I DH="" G D:$D(DR(DIE1,DP))<9 S:'$D(DOV) DOV=0,DR(DIE1,DP)=DR S DOV=$O(DR(DIE1,DP,DOV)) S:DOV="" DOV=-1 G D:DOV'>0 S DR=DR(DIE1,DP,DOV),DK=0 G MR
    52         G MR:DH?1"@".N I 'DQ G TEM:DH?1"[".E S:"Q"'=DH DQ=1,DQ(0,1)=DH G MR:$A(DH)-94 S DC=$P(DH,U,1,4) X $P(DH,U,5,999) D DIE1N G O^DIE0
    53 E       S DK=DK-1,(DI,DM)=1
    54 D       G DQ^DIED
    55         ;
    56 H       S DI=DI_U G D
    57         ;Multiple field
    58 M       S Y=$P(DQ(DQ),U,2)_U_DG G DC:DW<9
    59         I $D(DSC(+Y))#2,$P(DSC(+Y),"I $D(^UTILITY(",1)="" S D=DIEL+1 D D1 X DSC(+Y) S D=$O(^(0)) S:D="" D=-1 S @DC S DC=$O(^(DG,0)) S:DC="" DC=-1 G DE
    60         I $D(^(DG,0)) S D=$P(^(0),U,3,4) S:$P(^(0),U,2)'=$P(Y,U) $P(^(0),U,2)=$P(Y,U) ;HMMM
    61         E  S D=$O(^(0)) S:D="" D=-1
    62 DE      I D>0 S Y=Y_U_D I DP(0)-Y!($P(DP(0),U,2)-DK),$D(^(+D,0)) S DE(DQ)=$P(^(0),U) ;Default value if this isn't same multiple we were down in before
    63 DC      S DC=$P(^DD(+Y,0),U,4)_U_Y,%=DQ(DQ),Y=^(.01,0)
    64 MUL     I $P(Y,U,2)'["W" S DQ(DQ)=$P($$EZBLD^DIALOG(8042,$G(DQ(DQ,"CAPTION"),$P(Y,U))),": ")_U_1_$P(Y,U,2,99) D DIE1N G D ;MULTIPLE-FIELD LABEL
    65         I DQ>1 K DQ(DQ) G E:$D(DE(DQ,0)),H
    66         D
    67         .Q:DH'[$C(126)
    68         .N DIEA S DIEA=$P($P(DH,+DH,2),$C(126)) Q:DIEA=""!(DIEA="d")!(DIEA="R")
    69         .I DIEA="T"!(DIEA="t") S:$D(^DD(+$P(%,U,2),.01,.1)) DQ(DQ,"CAPTION")=^(.1) Q
    70         .S DQ(DQ,"CAPTION")=DIEA
    71 DIWE    S Y=$G(DQ(DQ,"CAPTION"),$P(%,U))_U_$P(Y,U,2) D DIEN^DIWE K DQ,DG,DE S DQ=0 G QY^DIE1:$D(DTOUT) G MORE ;WORD-PROCESSING FIELD LABEL
    72         ;
    73 D1      Q:D'>0  S:'$D(@("D"_D)) @("D"_D)=0 S D=D-1 G D1
    74         ;
    75 DIE1N   N M,I S DIE1N="" F I=DK,DK+1 S M=$P(DR,";",I) I M?1"^"1.NP S DIE1N=$P(M,U,2) S:I>DK DK=DK+1 Q  ;WPB-0804-30857
    76         Q
    77         ;
    78         ;
    79 B       K DQ(DQ) S DQ=DQ-1,DU=-9 G EQ
    80         ;
    81 TEM     K:$D(DIETMP)#2 @DIETMP,DIETMP
    82         S Y=0 F  S Y=$O(^DIE("B",$P($E(DR,2,99),"]",1),Y)) S:Y="" Y=-1 G Q:Y=-1,Q:'$D(^DIE(+Y,0)) Q:$P(^(0),U,4)=DP
    83         S $P(^(0),U,7)=DT I $G(^("ROU"))[U,$$ROUEXIST^DILIBF($P(^("ROU"),U,2)) G @^DIE(+Y,"ROU")
    84         S:$D(^("W")) DIE("W")=^("W") S %X="^DIE(+Y,""DR"",",%Y="DR(" D %XY^%RCR
    85         S DIE("^")=DR,DR=$S($D(^DIE(Y,"DR"))#2:^("DR"),1:DR(1,DP)) D DIE K DR S DR=DIE(U)
    86         Q
    87         ;
    88         ;Silent call concerning editing and filing of data.
    89         ;
    90 FILE(DIEFFLAG,DIEFAR,DIEFOUT)   ;
    91         G FILEX^DIEF
    92         ;
    93 WP(DIEFF,DIEFIEN,DIEFFLD,DIEFWPFL,DIEFTSRC,DIEFOUT)     ;
    94         G WPX^DIEFW
    95         ;
    96 HELP(DIEHF,DIEHIEN,DIEHFLD,DIEHFLG,DIEHOUT)     ;
    97         G GETX^DIEH
    98         ;
    99 VAL(DIEVF,DIEVIEN,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS,DIEVFAR,DIOUTAR)       ;
    100         G VALX^DIEV
    101         ;
    102 KEYVAL(DIVKFLAG,DIVKFDA,DIVKOUT)        ;
    103         G KEYVALX^DIEVK
    104         ;
    105 VALS(DIVSFLAG,DIVSEFDA,DIVSIFDA,DIVSMSG)        ;
    106         G VALSX^DIEVS
    107         ;
    108 CHK(DIEVF,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS,DIOUTAR)       ;
    109         G CHKX^DIEV
    110         ;
    111 UPDATE(DIFLAGS,DIFDA,DIEN,DIMSGA)       ;SEA/TOAD
    112         ; ENTRY POINT--update database
    113         ; procedure, all passed by value
    114         G ADDX^DICA
    115         ;
     1DIE ;SFISC/GFT,XAK-PROC.DR-STR ;2:40 PM  17 Sep 2002
     2 ;;22.0;VA FileMan;**1,4,8,11,59,95**;Mar 30, 1999
     3 ;Per VHA Directive 10-93-142, this routine should not be modified.
     4 N DG,DNM,DICRREC K DB I DIE S DIE=^DIC(DIE,0,"GL")
     5 Q:$D(@(DIE_DA_",-9)"))  Q:'$D(@(DIE_"0)"))  S U="^",DP=+$P(^(0),U,2) Q:$P($G(^DD($$FNO^DILIBF(DP),0,"DI")),U,2)["Y"&'$D(DIOVRD)&'$G(DIFROM)
     6GO Q:DIE?1"^DIA(".E  K DE,DOV,DIOV,DIEC,DTOUT N DIEDA D
     7 . N %
     8 . F %=1:1 Q:'$G(DA(%))  S DIEDA(%)=DA(%)
     9 . S DIEDA=DA
     10 . Q
     11 I $D(DIETMP)[0 N DIETMP S DIETMP=$$GETTMP^DIKC1("DIE")
     12 N DIEFXREF,DIIENS K DIEFIRE,DIEBADK S DIIENS=$$IENS^DIKCU(DP,.DA)
     13 S DL=1,D0=DA,DI=DP,DR(1,DP)=DR D INI I $E(DR)'="[" D DR^DIE17
     14 S DP=DI,DA=D0,(DQ,DIEL,DK,DP(0))=0 K DIC("S")
     15MR S DK=DK+1,DH=$P(DR,";",DK) I +DH=DH S (DI,DM)=DH G S:$D(^DD(DP,DI)),MR
     16 S DI=$P(DH,":",1) I 'DI G K:DI=0,PB
     17J I DH["//" S DE(DQ+1,0)=$P(DH,"//",2,9),DI=$P(DI,"//",1),DH=""
     18 G K:+DI=DI S DM=+DI,Y=$P(DI,DM,2,99),DI=DM G MR:Y=""!'$D(^DD(DP,DI,0)) S DQ=DQ+1,(DZ,DQ(DQ))=^(0),DIFLD(DQ)=DI
     19 F %=1:1 S DIG=$P(Y,$C(126),%) Q:DIG=""  S DZ=$S(DIG="d"!(DIG="R"):$P(DZ,U,1,2)_DIG_U_$P(DZ,U,3,99),DIG="T":$S($D(^(.1)):^(.1),1:$P(DZ,U))_U_$P(DZ,U,2,99),1:DIG_U_$P(DZ,U,2,99))
     20 S:DH'[$C(126) DH=DH_$C(126) S DQ(DQ)=DZ K DZ,DIG G Y
     21K S DM=$P(DH,":",2),DM=$S(DM:DM,1:DI) I DI,$D(^DD(DP,DI)) G S
     22NX S DI=$O(^DD(DP,DI)) S:DI="" DI=-1 G MR:DI'>0,MR:DI>DM
     23S I DQ'<50,'$D(DE(DQ+1)) G H
     24 S DQ=DQ+1,DQ(DQ)=^(DI,0),DIFLD(DQ)=DI
     25Y S Y=$P(DQ(DQ),"^",4),DG=$P(Y,";",1)
     26 ;Determine whether field has a xref defined in the Index file
     27 S DIEXREF=0 F  S DIEXREF=$O(^DD("IX","F",DP,DI,DIEXREF)) Q:'DIEXREF  I $P($G(^DD("IX",DIEXREF,0)),U) S DIEXREF=1 Q
     28 I $D(^DD(DP,DI,1))!($P(DQ(DQ),U,2)["a")!DIEXREF S DE=0,DB=DM,DM=0,DE(Y)=DQ K DIEXREF F DW=1:1 S DE=$O(^DD(DP,DI,1,DE)) Q:DE<1  S DE(Y,DW,1)=^(DE,1),DE(Y,DW,2)=^(2)
     29 I  S:DE="" DE=-1
     30 I $P(DQ(DQ),U,2)["a" S DE(Y,DW,2)="S DIIX=2_U_DIFLD(DE(DQ)) D AUDIT^DIET",DE(Y,DW,1)="S DIIX=3_U_DIFLD(DE(DQ)) D AUDIT^DIET",DE(Y)=DQ I ^DD(DP,DI,"AUDIT")="e" S DE(Y,DW,1)="I $D(DE(DE(DQ)))#2 "_DE(Y,DW,1)
     31 S Y=$P(Y,";",2) I DU'=DG S D="",DU=DG,@DC G M:Y=0,B:DU=" ",EQ:DW[0 S D=^(DG)
     32 I Y S:$P(D,"^",Y)]"" DE(DQ)=$P(D,"^",Y)
     33 E  S Y=$E(D,+$E(Y,2,9),$P(Y,",",2)) S:Y'?." " DE(DQ)=Y
     34EQ G MR:DI=DM,NX:DM S DM=DB K DB G D
     35 ;
     36INI K DIC("S") S DIC=DIE,DU=-1,DC="DW=$D("_DIE_DA_",DG))"
     37Q Q
     38MORE ;
     39 D INI G MR:DI=DM,NX:DI'[U S DI=+DI G S:$D(^DD(DP,DI)),MR
     40JMP ;
     41 D INI G J
     42 ;
     43PB I DH="" G D:$D(DR(DL,DP))<9 S:'$D(DOV) DOV=0,DR(DL,DP)=DR S DOV=$O(DR(DL,DP,DOV)) S:DOV="" DOV=-1 G D:DOV'>0 S DR=DR(DL,DP,DOV),DK=0 G MR
     44 G MR:DH?1"@".N I 'DQ G TEM:DH?1"[".E S:"Q"'=DH DQ=1,DQ(0,1)=DH G MR:$A(DH)-94 S DC=$P(DH,U,1,4) X $P(DH,U,5,999) G O^DIE0
     45E S DK=DK-1,(DI,DM)=1
     46D G DQ^DIED
     47H S DI=DI_U G D
     48M S Y=$P(DQ(DQ),U,2)_U_DG G DC:DW<9
     49 I $D(DSC(+Y))#2,$P(DSC(+Y),"I $D(^UTILITY(",1)="" S D=DIEL+1 D D1 X DSC(+Y) S D=$O(^(0)) S:D="" D=-1 S @DC S DC=$O(^(DG,0)) S:DC="" DC=-1 G DE
     50 I $D(^(DG,0)) S D=$P(^(0),U,3,4) S:$P(^(0),U,2)'=$P(Y,U) $P(^(0),U,2)=$P(Y,U)
     51 E  S D=$O(^(0)) S:D="" D=-1
     52DE I D>0 S Y=Y_U_D I DP(0)-Y,$D(^(+D,0)) S DE(DQ)=$P(^(0),U,1)
     53DC S DC=$P(^DD(+Y,0),U,4)_U_Y,%=DQ(DQ),Y=^(.01,0) I $P(Y,U,2)'["W" S DQ(DQ)="Select "_$P(Y,U,1)_U_1_$P(Y,U,2,99) G D
     54 I DQ>1 K DQ(DQ) G E:$D(DE(DQ,0)),H
     55 D
     56 .Q:DH'[$C(126)
     57 .N DIEA S DIEA=$P($P(DH,+DH,2),$C(126)) Q:DIEA=""!(DIEA="d")!(DIEA="R")
     58 .S $P(%,U)=$S(DIEA="T"&$D(^DD(+$P(%,U,2),.01,.1)):^(.1),1:DIEA)
     59 .Q
     60 S Y=$P(%,U,1)_U_$P(Y,U,2) D DIEN^DIWE K DQ,DG,DE S DQ=0 G QY^DIE1:$D(DTOUT) G MORE
     61 ;
     62D1 Q:D'>0  S:'$D(@("D"_D)) @("D"_D)=0 S D=D-1 G D1
     63 ;
     64B K DQ(DQ) S DQ=DQ-1,DU=-9 G EQ
     65 ;
     66TEM K:$D(DIETMP)#2 @DIETMP,DIETMP
     67 S Y=0 F  S Y=$O(^DIE("B",$P($E(DR,2,99),"]",1),Y)) S:Y="" Y=-1 G Q:Y=-1,Q:'$D(^DIE(+Y,0)) Q:$P(^(0),U,4)=DP
     68 S $P(^(0),U,7)=DT I $G(^("ROU"))[U,$$ROUEXIST^DILIBF($P(^("ROU"),U,2)) G @^DIE(+Y,"ROU")
     69 S:$D(^("W")) DIE("W")=^("W") S %X="^DIE(+Y,""DR"",",%Y="DR(" D %XY^%RCR
     70 S DIE("^")=DR,DR=$S($D(^DIE(Y,"DR"))#2:^("DR"),1:DR(1,DP)) D DIE K DR S DR=DIE(U)
     71 Q
     72 ;
     73 ;Silent call concerning editing and filing of data.
     74 ;
     75FILE(DIEFFLAG,DIEFAR,DIEFOUT) ;
     76 G FILEX^DIEF
     77 ;
     78WP(DIEFF,DIEFIEN,DIEFFLD,DIEFWPFL,DIEFTSRC,DIEFOUT) ;
     79 G WPX^DIEFW
     80 ;
     81HELP(DIEHF,DIEHIEN,DIEHFLD,DIEHFLG,DIEHOUT) ;
     82 G GETX^DIEH
     83 ;
     84VAL(DIEVF,DIEVIEN,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS,DIEVFAR,DIOUTAR) ;
     85 G VALX^DIEV
     86 ;
     87KEYVAL(DIVKFLAG,DIVKFDA,DIVKOUT) ;
     88 G KEYVALX^DIEVK
     89 ;
     90VALS(DIVSFLAG,DIVSEFDA,DIVSIFDA,DIVSMSG) ;
     91 G VALSX^DIEVS
     92 ;
     93CHK(DIEVF,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS,DIOUTAR) ;
     94 G CHKX^DIEV
     95 ;
     96UPDATE(DIFLAGS,DIFDA,DIEN,DIMSGA) ;SEA/TOAD
     97 ; ENTRY POINT--update database
     98 ; procedure, all passed by value
     99 G ADDX^DICA
     100 ;
Note: See TracChangeset for help on using the changeset viewer.