- 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 Mar 13, 2025@21:51:48 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|
