DIE3 ;SFISC/XAK-PROCESS SINGLE-VALUED VARIABLE PNTR ;03:06 PM 14 Feb 2003
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
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) !
EGP S A1="T",DST=$$EZBLD^DIALOG(8070,$$FILENAME^DIALOGZ(+DIVPDIC)) ;** 'SEARCHING FOR A ...'
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|
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIE3 3087 printed Oct 16, 2024@18:47:37 Page 2
DIE3 ;SFISC/XAK-PROCESS SINGLE-VALUED VARIABLE PNTR ;03:06 PM 14 Feb 2003
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
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 !
EGP ;** 'SEARCHING FOR A ...'
SET A1="T"
SET DST=$$EZBLD^DIALOG(8070,$$FILENAME^DIALOGZ(+DIVPDIC))
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|
