Routine: DICR

DICR ;SFISC/GFT-RECURSIVE CALL FOR X-REFS ON TRIGGERED FLDS ;6DEC2004

 ;;22.0;VA FileMan;**11,88,157**;Mar 30, 1999;Build 9

 ;Per VHA Directive 2004-038, this routine should not be modified.

 ;From a TRIGGER on field DIH,DIG

 ;DIU is old value, DIV new

AUDIT I $P(^DD(DIH,DIG,0),U,2)["a" D  ;NOIS ISB-1102-31285

 .N DIANUM,DIIX,C,DP

 .I DIU]"" S X=DIU,DIIX=2_U_DIG,DP=DIH D AUDIT^DIET

 .I DIV]"",^DD(DIH,DIG,"AUDIT")'="e"!(DIU]"") S X=DIV,DIIX=3_U_DIG,DP=DIH D AUDIT^DIET ;Don't audit NEW if there's no OLD and mode is EDIT ONLY

 Q:'$O(^DD(DIH,DIG,1,0))&'$D(^DD("IX","F",DIH,DIG))

 N DICRIENS,DICRBADK

 I $D(^DD("KEY","F",DIH,DIG)) D  Q:$G(DICRBADK)

 . N DICRFDA,DICRMSG,DIERR

 . D SAVE

 . S DICRIENS=$$IENS(DIH,.DA)

 . S DICRFDA(DIH,DICRIENS,DIG)=DIV

 . I '$$KEYVAL^DIE("","DICRFDA","DICRMSG") D

 .. S DICRBADK=1

 .. S X=DIU X $$HSET(DIH,DIG)

 . D RESTORE

 I DIU]"" F DIW=0:0 S DIW=$O(^DD(DIH,DIG,1,DIW)),X=DIU Q:'DIW  I $P(^(DIW,0),U,3)=""!'$D(DB(0,DIH,DIG,DIW,2)) S DB(0,DIH,DIG,DIW,2)=1 D SAVE X ^(2) D RESTORE

 I DIV]"" F DIW=0:0 S DIW=$O(^DD(DIH,DIG,1,DIW)),X=DIV Q:'DIW  I $P(^(DIW,0),U,3)=""!'$D(DB(0,DIH,DIG,DIW,1)) S DB(0,DIH,DIG,DIW,1)=1 D SAVE X ^(1) D RESTORE

 I $D(^DD("IX","F",DIH,DIG)) D

 . N DICRCTRL,DICRVAL,I

 . D SAVE

 . S:$D(DICRIENS)[0 DICRIENS=$$IENS(DIH,.DA)

 . S DICRVAL(DIH,DICRIENS,DIG,"O")=DIU

 . S DICRVAL(DIH,DICRIENS,DIG,"N")=DIV

 . S:$G(DICRREC)]"" DICRCTRL="r"

 . S DICRCTRL("VAL")="DICRVAL("

 . D INDEX^DIKC(DIH,.DA,DIG,"",.DICRCTRL)

 . D:$G(DICRREC)]"" @DICRREC

 . D RESTORE

Q Q

SAVE F DB=1:1 Q:'$D(DB(DB))

 F Y="DIC","DIV","DA" S %="" F DB=DB:0 S @("%=$O("_Y_"(%))") Q:%=""  S DB(DB,Y,%)=@(Y_"(%)")

 F %="DIC","DIW","DIU","DIV","DIH","DIG","DB","DG","DA","DICR" S DB(DB,%)="" I $D(@%)#2 S DB(DB,%)=@%

 K DA F Y=-1:1 Q:'$D(DIV(Y+1))

 I Y+1 S DA=DIV(Y) F %=Y-1:-1:0 S DA(Y-%)=DIV(%)

RESTORE F DB=1:1 Q:'$D(DB(DB+1))

 F Y="DIC","DIV","DA" K @Y S %="" F DB=DB:0 S %=$O(DB(DB,Y,%)) Q:%=""  S @(Y_"(%)=DB(DB,Y,%)")

 S Y="" F %=0:0 S Y=$O(DB(DB,Y)) Q:Y=""  S @Y=DB(DB,Y)

 K DB(DB) K:DB=1 DB Q

DICL N I

 K DIC("S"),DLAYGO I '$P(Y,U,3) K DIC Q

DICADD ;

 S (D0,DIV(0))=+Y,DIV(U)=Y

 I DIC S DIH=DIC,DIC=^DIC(DIC,0,"GL")

 E  S @("DIH=+$P("_DIC_"0),U,2)")

 S DICR=$S($D(DA)#2:DA,1:0),DA=D0 F DIG=.001:0 S DIG=$O(DIC(DIG)) Q:DIG'>0  D U:DIC(DIG)]""

 S DA=DICR,Y=DIV(U) K DIC Q

U S %=$P(^DD(DIH,DIG,0),U,4),Y=$P(%,";",2),%=$P(%,";",1),X="",DIV=DIC(DIG) I @("$D("_DIC_DIV(0)_",%))") S X=^(%)

 G P:Y,Q:Y'?1"E"1N.NP S D=+$E(Y,2,9),Y=$P(Y,",",2),DIU=$E(X,D,Y) I DIU?." " S DIU="" S:$L(X)+1<D X=X_$J("",D-1-$L(X))

 S ^(%)=$E(X,1,D-1)_DIV_$E(X,Y+1,999)

 G DICR

P S DIU=$P(X,U,Y),$P(^(%),U,Y)=DIV

 G DICR

CONV ;

 K DA F %=0:1 Q:'$D(@("D"_%))

 S %=%-1 I '% S DA=D0 K % Q

 S DA=@("D"_%),%=%-1,Y=0

 F %1=%:-1:0 S Y=Y+1,DA(Y)=@("D"_%1)

 K %,%1,Y

SD ;

 S DIV(0)=DA D U:DA>0 K DA,DIH,DIG,DIV Q

TRIG(DICRLIST,DICROUT) ;Modify the trigger logic of fields that trigger fields

 ;in DICRLIST so that they call ^DICR unconditionally.

 ;In:

 ; DICRLIST(file#,field#) = array of potentionally triggered fields

 ;Out:

 ; DICROUT(file,field)="" (of triggering field modified)

 N DICRFIL,DICRFLD

 S DICRFIL=""

 F  S DICRFIL=$O(DICRLIST(DICRFIL)) Q:'DICRFIL  D

 . S DICRFLD=""

 . F  S DICRFLD=$O(DICRLIST(DICRFIL,DICRFLD)) Q:'DICRFLD  D TRMOD(DICRFIL,DICRFLD,.DICROUT)

TRMOD(DICRFIL,DICRFLD,DICROUT) ;Modify the trigger logic of fields that

 ;trigger a field so that they call ^DICR unconditionally.

 ;In:

 ; DICRFIL = file# of triggered field

 ; DICRFLD = triggered field#

 ;Out:

 ; DICROUT(file,field)="" (of triggering field modified)

 ;Loop through 5 node to get triggering fields/xrefs

 N DICRN,DICRFL,DICRFD,DICRXR

 S DICRN=0

 F  S DICRN=$O(^DD(DICRFIL,DICRFLD,5,DICRN)) Q:'DICRN  D

 . S DICRXR=$G(^DD(DICRFIL,DICRFLD,5,DICRN,0))

 . S DICRFL=+$P(DICRXR,U),DICRFD=+$P(DICRXR,U,2),DICRXR=+$P(DICRXR,U,3)

 . Q:'DICRFL!'DICRFD!'DICRXR

 . D MOD(DICRFL,DICRFD,DICRXR,.DICROUT)

MOD(DICRFL,DICRFD,DICRXR,DICROUT) ;Modify trigger logic

 ;In:

 ; DICRFL = file# of triggering field

 ; DICRFD = field# of triggering field

 ; DICRXR = xref# of trigger

 ;Out:

 ; DICROUT(file,field)="" (if trigger was modified)

 Q:'$D(^DD(DICRFL,DICRFD,1,DICRXR))

 N DICRMOD,DICRND,DICRSTR,DICRVAL

 ;Loop through xref nodes

 S DICRND=0

 F  S DICRND=$O(^DD(DICRFL,DICRFD,1,DICRXR,DICRND)) Q:'DICRND  D

 . S DICRVAL=$G(^DD(DICRFL,DICRFD,1,DICRXR,DICRND)),DICRMOD=0

 . F DICRSTR="D ^DICR:$O(^DD(DIH,DIG,1,0))>0","D ^DICR:$N(^DD(DIH,DIG,1,0))>0" D

 .. F  Q:DICRVAL'[DICRSTR  D

 ... S DICRVAL=$P(DICRVAL,DICRSTR)_"D ^DICR"_$P(DICRVAL,DICRSTR,2,999)

 ... S DICRMOD=1

 . Q:'DICRMOD

 . S ^DD(DICRFL,DICRFD,1,DICRXR,DICRND)=DICRVAL

 . S DICROUT(DICRFL,DICRFD)=""

IENS(FIL,DA) ;Build IENS

 N I,IENS

 S IENS=DA_","

 F I=1:1:$$FLEV^DIKCU(FIL) S IENS=IENS_DA(I)_","

 Q IENS

HSET(FIL,FLD) ;Hard set a value in the file

 Q:$P($G(^DD(FIL,FLD,0)),U)="" ""

 N HSET,ND,PC,OROOT

 S PC=$P($G(^DD(FIL,FLD,0)),U,4)

 S ND=$P(PC,";"),PC=$P(PC,";",2) Q:ND?." "!("0 "[PC) ""

 S:ND'=+$P(ND,"E") ND=""""_ND_""""

 S OROOT=$$FROOTDA^DIKCU(FIL,"O")_"DA," Q:OROOT="DA,"

 I PC S HSET="S $P("_OROOT_ND_"),U,"_PC_")=X"

 E  S HSET="S $E("_OROOT_ND_"),"_+$E(PC,2,999)_","_$P(PC,",",2)_")=X"

 Q HSET

DICR      ;SFISC/GFT-RECURSIVE CALL FOR X-REFS ON TRIGGERED FLDS ;6DEC2004

 +1       ;;22.0;VA FileMan;**11,88,157**;Mar 30, 1999;Build 9

 +2       ;Per VHA Directive 2004-038, this routine should not be modified.

 +3       ;

 +4       ;From a TRIGGER on field DIH,DIG

 +5       ;DIU is old value, DIV new

AUDIT     ;NOIS ISB-1102-31285

           IF $PIECE(^DD(DIH,DIG,0),U,2)["a"

               Begin DoDot:1

 +1                NEW DIANUM,DIIX,C,DP

 +2                IF DIU]""

                       SET X=DIU

                       SET DIIX=2_U_DIG

                       SET DP=DIH

                       DO AUDIT^DIET

 +3       ;Don't audit NEW if there's no OLD and mode is EDIT ONLY

                   IF DIV]""

                       IF ^DD(DIH,DIG,"AUDIT")'="e"!(DIU]"")

                           SET X=DIV

                           SET DIIX=3_U_DIG

                           SET DP=DIH

                           DO AUDIT^DIET

               End DoDot:1

 +4        IF '$ORDER(^DD(DIH,DIG,1,0))&'$DATA(^DD("IX","F",DIH,DIG))

               QUIT

 +5        NEW DICRIENS,DICRBADK

 +6        IF $DATA(^DD("KEY","F",DIH,DIG))

               Begin DoDot:1

 +7                NEW DICRFDA,DICRMSG,DIERR

 +8                DO SAVE

 +9                SET DICRIENS=$$IENS(DIH,.DA)

 +10               SET DICRFDA(DIH,DICRIENS,DIG)=DIV

 +11               IF '$$KEYVAL^DIE("","DICRFDA","DICRMSG")

                       Begin DoDot:2

 +12                       SET DICRBADK=1

 +13                       SET X=DIU

                           XECUTE $$HSET(DIH,DIG)

                       End DoDot:2

 +14               DO RESTORE

               End DoDot:1

               IF $GET(DICRBADK)

                   QUIT

 +15      ;

 +16       IF DIU]""

               FOR DIW=0:0

                   SET DIW=$ORDER(^DD(DIH,DIG,1,DIW))

                   SET X=DIU

                   IF 'DIW

                       QUIT

                   IF $PIECE(^(DIW,0),U,3)=""!'$DATA(DB(0,DIH,DIG,DIW,2))

                       SET DB(0,DIH,DIG,DIW,2)=1

                       DO SAVE

                       XECUTE ^(2)

                       DO RESTORE

 +17       IF DIV]""

               FOR DIW=0:0

                   SET DIW=$ORDER(^DD(DIH,DIG,1,DIW))

                   SET X=DIV

                   IF 'DIW

                       QUIT

                   IF $PIECE(^(DIW,0),U,3)=""!'$DATA(DB(0,DIH,DIG,DIW,1))

                       SET DB(0,DIH,DIG,DIW,1)=1

                       DO SAVE

                       XECUTE ^(1)

                       DO RESTORE

 +18      ;

 +19       IF $DATA(^DD("IX","F",DIH,DIG))

               Begin DoDot:1

 +20               NEW DICRCTRL,DICRVAL,I

 +21               DO SAVE

 +22               IF $DATA(DICRIENS)[0

                       SET DICRIENS=$$IENS(DIH,.DA)

 +23               SET DICRVAL(DIH,DICRIENS,DIG,"O")=DIU

 +24               SET DICRVAL(DIH,DICRIENS,DIG,"N")=DIV

 +25               IF $GET(DICRREC)]""

                       SET DICRCTRL="r"

 +26               SET DICRCTRL("VAL")="DICRVAL("

 +27               DO INDEX^DIKC(DIH,.DA,DIG,"",.DICRCTRL)

 +28               IF $GET(DICRREC)]""

                       DO @DICRREC

 +29               DO RESTORE

               End DoDot:1

Q          QUIT

 +1       ;

SAVE       FOR DB=1:1

               IF '$DATA(DB(DB))

                   QUIT

 +1        FOR Y="DIC","DIV","DA"

               SET %=""

               FOR DB=DB:0

                   SET @("%=$O("_Y_"(%))")

                   IF %=""

                       QUIT

                   SET DB(DB,Y,%)=@(Y_"(%)")

 +2        FOR %="DIC","DIW","DIU","DIV","DIH","DIG","DB","DG","DA","DICR"

               SET DB(DB,%)=""

               IF $DATA(@%)#2

                   SET DB(DB,%)=@%

 +3        KILL DA

           FOR Y=-1:1

               IF '$DATA(DIV(Y+1))

                   QUIT

 +4        IF Y+1

               SET DA=DIV(Y)

               FOR %=Y-1:-1:0

                   SET DA(Y-%)=DIV(%)

 +5        QUIT

 +6       ;

RESTORE    FOR DB=1:1

               IF '$DATA(DB(DB+1))

                   QUIT

 +1        FOR Y="DIC","DIV","DA"

               KILL @Y

               SET %=""

               FOR DB=DB:0

                   SET %=$ORDER(DB(DB,Y,%))

                   IF %=""

                       QUIT

                   SET @(Y_"(%)=DB(DB,Y,%)")

 +2        SET Y=""

           FOR %=0:0

               SET Y=$ORDER(DB(DB,Y))

               IF Y=""

                   QUIT

               SET @Y=DB(DB,Y)

 +3        KILL DB(DB)

           IF DB=1

               KILL DB

           QUIT

 +4       ;

DICL       NEW I

 +1        KILL DIC("S"),DLAYGO

           IF '$PIECE(Y,U,3)

               KILL DIC

               QUIT

DICADD    ;

 +1        SET (D0,DIV(0))=+Y

           SET DIV(U)=Y

 +2        IF DIC

               SET DIH=DIC

               SET DIC=^DIC(DIC,0,"GL")

 +3       IF '$TEST

               SET @("DIH=+$P("_DIC_"0),U,2)")

 +4        SET DICR=$SELECT($DATA(DA)#2:DA,1:0)

           SET DA=D0

           FOR DIG=.001:0

               SET DIG=$ORDER(DIC(DIG))

               IF DIG'>0

                   QUIT

               IF DIC(DIG)]""

                   DO U

 +5        SET DA=DICR

           SET Y=DIV(U)

           KILL DIC

           QUIT

 +6       ;

U          SET %=$PIECE(^DD(DIH,DIG,0),U,4)

           SET Y=$PIECE(%,";",2)

           SET %=$PIECE(%,";",1)

           SET X=""

           SET DIV=DIC(DIG)

           IF @("$D("_DIC_DIV(0)_",%))")

               SET X=^(%)

 +1        IF Y

               GOTO P

           IF Y'?1"E"1N.NP

               GOTO Q

           SET D=+$EXTRACT(Y,2,9)

           SET Y=$PIECE(Y,",",2)

           SET DIU=$EXTRACT(X,D,Y)

           IF DIU?." "

               SET DIU=""

               IF $LENGTH(X)+1<D

                   SET X=X_$JUSTIFY("",D-1-$LENGTH(X))

 +2        SET ^(%)=$EXTRACT(X,1,D-1)_DIV_$EXTRACT(X,Y+1,999)

 +3        GOTO DICR

P          SET DIU=$PIECE(X,U,Y)

           SET $PIECE(^(%),U,Y)=DIV

 +1        GOTO DICR

CONV      ;

 +1        KILL DA

           FOR %=0:1

               IF '$DATA(@("D"_%))

                   QUIT

 +2        SET %=%-1

           IF '%

               SET DA=D0

               KILL %

               QUIT

 +3        SET DA=@("D"_%)

           SET %=%-1

           SET Y=0

 +4        FOR %1=%:-1:0

               SET Y=Y+1

               SET DA(Y)=@("D"_%1)

 +5        KILL %,%1,Y

 +6        QUIT

SD        ;

 +1        SET DIV(0)=DA

           IF DA>0

               DO U

           KILL DA,DIH,DIG,DIV

           QUIT

 +2       ;

TRIG(DICRLIST,DICROUT) ;Modify the trigger logic of fields that trigger fields

 +1       ;in DICRLIST so that they call ^DICR unconditionally.

 +2       ;In:

 +3       ; DICRLIST(file#,field#) = array of potentionally triggered fields

 +4       ;Out:

 +5       ; DICROUT(file,field)="" (of triggering field modified)

 +6       ;

 +7        NEW DICRFIL,DICRFLD

 +8        SET DICRFIL=""

 +9        FOR

               SET DICRFIL=$ORDER(DICRLIST(DICRFIL))

               IF 'DICRFIL

                   QUIT

               Begin DoDot:1

 +10               SET DICRFLD=""

 +11               FOR

                       SET DICRFLD=$ORDER(DICRLIST(DICRFIL,DICRFLD))

                       IF 'DICRFLD

                           QUIT

                       DO TRMOD(DICRFIL,DICRFLD,.DICROUT)

               End DoDot:1

 +12       QUIT

 +13      ;

TRMOD(DICRFIL,DICRFLD,DICROUT) ;Modify the trigger logic of fields that

 +1       ;trigger a field so that they call ^DICR unconditionally.

 +2       ;In:

 +3       ; DICRFIL = file# of triggered field

 +4       ; DICRFLD = triggered field#

 +5       ;Out:

 +6       ; DICROUT(file,field)="" (of triggering field modified)

 +7       ;

 +8       ;Loop through 5 node to get triggering fields/xrefs

 +9        NEW DICRN,DICRFL,DICRFD,DICRXR

 +10       SET DICRN=0

 +11       FOR

               SET DICRN=$ORDER(^DD(DICRFIL,DICRFLD,5,DICRN))

               IF 'DICRN

                   QUIT

               Begin DoDot:1

 +12               SET DICRXR=$GET(^DD(DICRFIL,DICRFLD,5,DICRN,0))

 +13               SET DICRFL=+$PIECE(DICRXR,U)

                   SET DICRFD=+$PIECE(DICRXR,U,2)

                   SET DICRXR=+$PIECE(DICRXR,U,3)

 +14               IF 'DICRFL!'DICRFD!'DICRXR

                       QUIT

 +15               DO MOD(DICRFL,DICRFD,DICRXR,.DICROUT)

               End DoDot:1

 +16       QUIT

 +17      ;

MOD(DICRFL,DICRFD,DICRXR,DICROUT) ;Modify trigger logic

 +1       ;In:

 +2       ; DICRFL = file# of triggering field

 +3       ; DICRFD = field# of triggering field

 +4       ; DICRXR = xref# of trigger

 +5       ;Out:

 +6       ; DICROUT(file,field)="" (if trigger was modified)

 +7       ;

 +8        IF '$DATA(^DD(DICRFL,DICRFD,1,DICRXR))

               QUIT

 +9        NEW DICRMOD,DICRND,DICRSTR,DICRVAL

 +10      ;

 +11      ;Loop through xref nodes

 +12       SET DICRND=0

 +13       FOR

               SET DICRND=$ORDER(^DD(DICRFL,DICRFD,1,DICRXR,DICRND))

               IF 'DICRND

                   QUIT

               Begin DoDot:1

 +14               SET DICRVAL=$GET(^DD(DICRFL,DICRFD,1,DICRXR,DICRND))

                   SET DICRMOD=0

 +15               FOR DICRSTR="D ^DICR:$O(^DD(DIH,DIG,1,0))>0","D ^DICR:$N(^DD(DIH,DIG,1,0))>0"

                       Begin DoDot:2

 +16                       FOR

                               IF DICRVAL'[DICRSTR

                                   QUIT

                               Begin DoDot:3

 +17                               SET DICRVAL=$PIECE(DICRVAL,DICRSTR)_"D ^DICR"_$PIECE(DICRVAL,DICRSTR,2,999)

 +18                               SET DICRMOD=1

                               End DoDot:3

                       End DoDot:2

 +19               IF 'DICRMOD

                       QUIT

 +20               SET ^DD(DICRFL,DICRFD,1,DICRXR,DICRND)=DICRVAL

 +21               SET DICROUT(DICRFL,DICRFD)=""

               End DoDot:1

 +22       QUIT

 +23      ;

IENS(FIL,DA) ;Build IENS

 +1        NEW I,IENS

 +2        SET IENS=DA_","

 +3        FOR I=1:1:$$FLEV^DIKCU(FIL)

               SET IENS=IENS_DA(I)_","

 +4        QUIT IENS

 +5       ;

HSET(FIL,FLD) ;Hard set a value in the file

 +1        IF $PIECE($GET(^DD(FIL,FLD,0)),U)=""

               QUIT ""

 +2       ;

 +3        NEW HSET,ND,PC,OROOT

 +4        SET PC=$PIECE($GET(^DD(FIL,FLD,0)),U,4)

 +5        SET ND=$PIECE(PC,";")

           SET PC=$PIECE(PC,";",2)

           IF ND?." "!("0 "[PC)

               QUIT ""

 +6        IF ND'=+$PIECE(ND,"E")

               SET ND=""""_ND_""""

 +7       ;

 +8        SET OROOT=$$FROOTDA^DIKCU(FIL,"O")_"DA,"

           IF OROOT="DA,"

               QUIT

 +9        IF PC

               SET HSET="S $P("_OROOT_ND_"),U,"_PC_")=X"

 +10      IF '$TEST

               SET HSET="S $E("_OROOT_ND_"),"_+$EXTRACT(PC,2,999)_","_$PIECE(PC,",",2)_")=X"

 +11       QUIT HSET

DICR.m