DIE3.m

DIE3 ;SFISC/XAK-PROCESS SINGLE-VALUED VARIABLE PNTR ;5:50 AM  13 Feb 2003

 ;;22.0;VA FileMan;**4,123**;Mar 30, 1999

 ;Per VHA Directive 10-93-142, this routine should not be modified.

V ;

 S DIEX=X ;I $D(DNM) S DIDS=D

 G ALL:X'["." S DIVP=$P(X,"."),X=$P(X,".",2,999),Y=-1,A9=1 I X="" G Q

 I DIVP]"",$D(^DD(DP,DIFLD,"V","P",DIVP)) D FND G Q

 I DIVP="" G ALL

 S X="" F %=0:0 S X=$O(^DD(DP,DIFLD,"V","M",X)) Q:X=""  I $P(X,DIVP)="" S DIVP=X,X=$P(DIEX,".",2,999) D FND G Q:Y>0 S X=$P(DIEX,".")

 F DIVP=0:0 S DIVP=$O(^DD(DP,DIFLD,"V",DIVP)) Q:+DIVP'>0  I $D(^(DIVP,0)) S DIVPDIC=^(0) I $D(^DIC(+DIVPDIC,0)) S %=$P(^(0),U) I $P(%,$P(DIEX,"."))="" S X=$P(DIEX,".",2,999) D DIC G Q:Y>0 S X=$P(DIEX,".")

 I A9 S X=DIEX,A9=0 G ALL

 G Q

 ;

ALL F DIVP1=0:0 S DIVP1=$O(^DD(DP,DIFLD,"V","O",DIVP1)) Q:+DIVP1'>0  S DIVP=DIVP1 D FND Q:Y>0  S X=DIEX

 G Q

 ;

FND S DIVP=+$O(^(DIVP,0)) I $D(^DD(DP,DIFLD,"V",DIVP,0)) S DIVPDIC=^(0) D DIC

 I Y>0 S A9=0

 Q

 ;

DIC I '$D(^DIC(+DIVPDIC,0,"GL")) S Y=-1 Q

 I $D(DIC("V")) S Y=DIVP,Y(0)=DIVPDIC X DIC("V") I '$T K Y S Y=-1 Q

 N DIVPSEL S DIVPSEL(0)=0

 I $D(DIVP1),'$D(DB(DQ)),'$G(DIQUIET) D H1 W:'$D(DDS) !

 S DIC=^DIC(+DIVPDIC,0,"GL"),DIC(0)="MD"_$E("E",'$D(DB(DQ))&'$D(DIR("V")))_$E("L",$P(DIVPDIC,U,6)="y")_$E("Z",$D(DDS)) I $P(DIVPDIC,U,5)="y",$D(^DD(DP,DIFLD,"V",DIVP,1)),^(1)]"" X ^(1)

 I $D(DIR)=10,'$D(DDS) S DIC(0)=$P(DIC(0),"L")_$P(DIC(0),"L",2)

 D PTRIX S X=+Y_";"_$E(DIC,2,99) K:Y<0 X S %=1

 I Y>0,'DIVPSEL(0),'$D(DB(DQ)),'$P(Y,U,3),'$$CHKO,'$G(DIQUIET) D S1 ; 22*123

 D  Q

 .N DICV

 .I $D(DIC("V")) S DICV=DIC("V")

 .K DIC S DIC=DIE S:$D(DICV) DIC("V")=DICV

 .Q

 ;

S1 S A1="Q",DST=%_U_"        ...OK" D S S:%'=1 Y=-1 Q

 ;

H S DDH=$S($D(DDH):DDH+1,1:1),DDH(DDH,A1)=DST K DST Q

 ;

H1 ;also called by DICM3

 W:'$D(DDS) !

 S A1="T",DST=$$EZBLD^DIALOG(8070,$P(DIVPDIC,U,2))

S I $D(DDS) D H S DDD=1 D ^DDSU K DDD G QS

 I A1["T" W !,DST G QS

 I A1["Q" S %=+$P(DST,U,1) W !,$P(DST,U,2) D YN^DICN G QS

 I A1["X" X DST

QS K A1,DST Q

 ;

Q K A1,DIVP1,DIVP,DIVPDIC,A9

 I $D(DNM) G:Y>0 @("V^"_DNM) S X=DIEX K DIEX G X^DIE17:'$D(DB(DQ)),B^DIE17

 K DIEX Q:$D(DIR)  G V^DIED:Y>0,X^DIED:'$D(DB(DQ)),B^DIE1

 ;

PTRIX ;Check for DIC("PTRIX"); do appropriate ^DIC call

 K DIC("PTRIX"),D

 M DIC("PTRIX")=DIE("PTRIX")

 ;

 S D=$G(DIE("PTRIX",DP,DIFLD,+DIVPDIC))

 I $P(DIVPDIC,U,6)="y",(U_D_U)'["^B^" S D=D_"^B"

 ;

 I $G(D)]"",$P(D,U,2)="" S DIC(0)=$TR(DIC(0),"M")

 E  S:DIC(0)'["M" DIC(0)="M"_DIC(0)

 ;

 I $P($G(D),U)="" D

 . K D D ^DIC

 E  I $P(D,U,2)]"" D

 . D MIX^DIC1

 E  D IX^DIC

 K DIC("PTRIX")

 Q

 ;

CHKO() ; New with 22*123.  Check for 'O' (Ask 'OK')

 ; Backwards compatibility check

 I $P(^DIC(+DIVPDIC,0),U,2)["O" Q 1

 ; If $P#2 of the File Header ["O" then Quit True

 Q $P(@(^DIC(+DIVPDIC,0,"GL")_"0)"),U,2)["O"

 ;#8070  Searching for a |filename|

DIE3      ;SFISC/XAK-PROCESS SINGLE-VALUED VARIABLE PNTR ;5:50 AM  13 Feb 2003

 +1       ;;22.0;VA FileMan;**4,123**;Mar 30, 1999

 +2       ;Per VHA Directive 10-93-142, this routine should not be modified.

V         ;

 +1       ;I $D(DNM) S DIDS=D

           SET DIEX=X

 +2        IF X'["."

               GOTO ALL

           SET DIVP=$PIECE(X,".")

           SET X=$PIECE(X,".",2,999)

           SET Y=-1

           SET A9=1

           IF X=""

               GOTO Q

 +3        IF DIVP]""

               IF $DATA(^DD(DP,DIFLD,"V","P",DIVP))

                   DO FND

                   GOTO Q

 +4        IF DIVP=""

               GOTO ALL

 +5        SET X=""

           FOR %=0:0

               SET X=$ORDER(^DD(DP,DIFLD,"V","M",X))

               IF X=""

                   QUIT 

               IF $PIECE(X,DIVP)=""

                   SET DIVP=X

                   SET X=$PIECE(DIEX,".",2,999)

                   DO FND

                   IF Y>0

                       GOTO Q

                   SET X=$PIECE(DIEX,".")

 +6        FOR DIVP=0:0

               SET DIVP=$ORDER(^DD(DP,DIFLD,"V",DIVP))

               IF +DIVP'>0

                   QUIT 

               IF $DATA(^(DIVP,0))

                   SET DIVPDIC=^(0)

                   IF $DATA(^DIC(+DIVPDIC,0))

                       SET %=$PIECE(^(0),U)

                       IF $PIECE(%,$PIECE(DIEX,"."))=""

                           SET X=$PIECE(DIEX,".",2,999)

                           DO DIC

                           IF Y>0

                               GOTO Q

                           SET X=$PIECE(DIEX,".")

 +7        IF A9

               SET X=DIEX

               SET A9=0

               GOTO ALL

 +8        GOTO Q

 +9       ;

ALL        FOR DIVP1=0:0

               SET DIVP1=$ORDER(^DD(DP,DIFLD,"V","O",DIVP1))

               IF +DIVP1'>0

                   QUIT 

               SET DIVP=DIVP1

               DO FND

               IF Y>0

                   QUIT 

               SET X=DIEX

 +1        GOTO Q

 +2       ;

FND        SET DIVP=+$ORDER(^(DIVP,0))

           IF $DATA(^DD(DP,DIFLD,"V",DIVP,0))

               SET DIVPDIC=^(0)

               DO DIC

 +1        IF Y>0

               SET A9=0

 +2        QUIT 

 +3       ;

DIC        IF '$DATA(^DIC(+DIVPDIC,0,"GL"))

               SET Y=-1

               QUIT 

 +1        IF $DATA(DIC("V"))

               SET Y=DIVP

               SET Y(0)=DIVPDIC

               XECUTE DIC("V")

               IF '$TEST

                   KILL Y

                   SET Y=-1

                   QUIT 

 +2        NEW DIVPSEL

           SET DIVPSEL(0)=0

 +3        IF $DATA(DIVP1)

               IF '$DATA(DB(DQ))

                   IF '$GET(DIQUIET)

                       DO H1

                       IF '$DATA(DDS)

                           WRITE !

 +4        SET DIC=^DIC(+DIVPDIC,0,"GL")

           SET DIC(0)="MD"_$EXTRACT("E",'$DATA(DB(DQ))&'$DATA(DIR("V")))_$EXTRACT("L",$PIECE(DIVPDIC,U,6)="y")_$EXTRACT("Z",$DATA(DDS))

           IF $PIECE(DIVPDIC,U,5)="y"

               IF $DATA(^DD(DP,DIFLD,"V",DIVP,1))

                   IF ^(1)]""

                       XECUTE ^(1)

 +5        IF $DATA(DIR)=10

               IF '$DATA(DDS)

                   SET DIC(0)=$PIECE(DIC(0),"L")_$PIECE(DIC(0),"L",2)

 +6        DO PTRIX

           SET X=+Y_";"_$EXTRACT(DIC,2,99)

           IF Y<0

               KILL X

           SET %=1

 +7       ; 22*123

           IF Y>0

               IF 'DIVPSEL(0)

                   IF '$DATA(DB(DQ))

                       IF '$PIECE(Y,U,3)

                           IF '$$CHKO

                               IF '$GET(DIQUIET)

                                   DO S1

 +8        Begin DoDot:1

 +9            NEW DICV

 +10           IF $DATA(DIC("V"))

                   SET DICV=DIC("V")

 +11           KILL DIC

               SET DIC=DIE

               IF $DATA(DICV)

                   SET DIC("V")=DICV

 +12           QUIT 

           End DoDot:1

           QUIT 

 +13      ;

S1         SET A1="Q"

           SET DST=%_U_"        ...OK"

           DO S

           IF %'=1

               SET Y=-1

           QUIT 

 +1       ;

H          SET DDH=$SELECT($DATA(DDH):DDH+1,1:1)

           SET DDH(DDH,A1)=DST

           KILL DST

           QUIT 

 +1       ;

H1        ;also called by DICM3

 +1        IF '$DATA(DDS)

               WRITE !

 +2        SET A1="T"

           SET DST=$$EZBLD^DIALOG(8070,$PIECE(DIVPDIC,U,2))

S          IF $DATA(DDS)

               DO H

               SET DDD=1

               DO ^DDSU

               KILL DDD

               GOTO QS

 +1        IF A1["T"

               WRITE !,DST

               GOTO QS

 +2        IF A1["Q"

               SET %=+$PIECE(DST,U,1)

               WRITE !,$PIECE(DST,U,2)

               DO YN^DICN

               GOTO QS

 +3        IF A1["X"

               XECUTE DST

QS         KILL A1,DST

           QUIT 

 +1       ;

Q          KILL A1,DIVP1,DIVP,DIVPDIC,A9

 +1        IF $DATA(DNM)

               IF Y>0

                   GOTO @("V^"_DNM)

               SET X=DIEX

               KILL DIEX

               IF '$DATA(DB(DQ))

                   GOTO X^DIE17

               GOTO B^DIE17

 +2        KILL DIEX

           IF $DATA(DIR)

               QUIT 

           IF Y>0

               GOTO V^DIED

           IF '$DATA(DB(DQ))

               GOTO X^DIED

           GOTO B^DIE1

 +3       ;

PTRIX     ;Check for DIC("PTRIX"); do appropriate ^DIC call

 +1        KILL DIC("PTRIX"),D

 +2        MERGE DIC("PTRIX")=DIE("PTRIX")

 +3       ;

 +4        SET D=$GET(DIE("PTRIX",DP,DIFLD,+DIVPDIC))

 +5        IF $PIECE(DIVPDIC,U,6)="y"

               IF (U_D_U)'["^B^"

                   SET D=D_"^B"

 +6       ;

 +7        IF $GET(D)]""

               IF $PIECE(D,U,2)=""

                   SET DIC(0)=$TRANSLATE(DIC(0),"M")

 +8       IF '$TEST

               IF DIC(0)'["M"

                   SET DIC(0)="M"_DIC(0)

 +9       ;

 +10       IF $PIECE($GET(D),U)=""

               Begin DoDot:1

 +11               KILL D

                   DO ^DIC

               End DoDot:1

 +12      IF '$TEST

               IF $PIECE(D,U,2)]""

                   Begin DoDot:1

 +13                   DO MIX^DIC1

                   End DoDot:1

 +14      IF '$TEST

               DO IX^DIC

 +15       KILL DIC("PTRIX")

 +16       QUIT 

 +17      ;

CHKO()    ; New with 22*123.  Check for 'O' (Ask 'OK')

 +1       ; Backwards compatibility check

 +2        IF $PIECE(^DIC(+DIVPDIC,0),U,2)["O"

               QUIT 1

 +3       ; If $P#2 of the File Header ["O" then Quit True

 +4        QUIT $PIECE(@(^DIC(+DIVPDIC,0,"GL")_"0)"),U,2)["O"

 +5       ;#8070  Searching for a |filename|