DIEV1 ;SFISC/DPC - VARIABLE POINTER VALIDATION ;1:39 PM 12 Sep 2002
;;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.
;
VP(DIEVF,DIEVFLD,DIEVFLG,DIEVAL,DIEV0,DIVPOUT) ;
N DIVPY,DIVPHITF,DIVPZ,DIVPVP,DIVPRNUM,DIVPFILE,DIVPSAVV,DIVPAMB,DIVPFLK
K DIVPOUT
S DIVPAMB=0
I DIEVAL'["."!($P(DIEVAL,".")="") D ALL,DONE Q
S DIVPSAVV=DIEVAL,DIVPFLK=$P(DIVPSAVV,"."),DIEVAL=$P(DIVPSAVV,".",2,99)
N DIVPVPS D VPNUMS(DIEVF,DIEVFLD,DIVPFLK,.DIVPVPS)
I $D(DIVPVPS) D
. S DIVPVP=""
. F S DIVPVP=$O(DIVPVPS(DIVPVP)) Q:DIVPVP="" D FINDVP Q:DIVPAMB
I DIVPAMB S DIVPOUT=U Q
I $D(DIVPY) D DONE Q
S DIEVAL=DIVPSAVV
D ALL,DONE
Q
;
ALL ;
N DIVPORD S DIVPORD=0
F S DIVPORD=$O(^DD(DIEVF,DIEVFLD,"V","O",DIVPORD)) Q:'DIVPORD D Q:DIVPAMB
. S DIVPVP=$O(^DD(DIEVF,DIEVFLD,"V","O",DIVPORD,""))
. D FINDVP
Q
;
VPNUMS(DIEVF,DIEVFLD,DIVPFLK,DIVPVPS) ;
I $D(^DD(DIEVF,DIEVFLD,"V","P",DIVPFLK)) S DIVPVPS($O(^(DIVPFLK,"")))="" Q
N DIVPMES S DIVPMES=""
F S DIVPMES=$O(^DD(DIEVF,DIEVFLD,"V","M",DIVPMES)) Q:DIVPMES="" D
. I $P(DIVPMES,DIVPFLK)="" S DIVPVPS($O(^DD(DIEVF,DIEVFLD,"V","M",DIVPMES,"")))=""
S DIVPFILE=0
F S DIVPFILE=$O(^DD(DIEVF,DIEVFLD,"V","B",DIVPFILE)) Q:DIVPFILE="" D
. I $P($$GET1^DID(DIVPFILE,"","","NAME","","","A"),DIVPFLK)="" S DIVPVPS($O(^DD(DIEVF,DIEVFLD,"V","B",DIVPFILE,"")))=""
Q
;
FINDVP ;
S DIVPZ=^DD(DIEVF,DIEVFLD,"V",DIVPVP,0)
S DIVPFILE=+DIVPZ Q:'DIVPFILE
N DIVPECNT S DIVPECNT=$G(DIERR)
I $P(DIVPZ,U,5)="y",$G(^DD(DIEVF,DIEVFLD,"V",DIVPVP,1))]"" N DIC X ^DD(DIEVF,DIEVFLD,"V",DIVPVP,1)
I DIVPECNT'=$G(DIERR) D HKERR^DILIBF(DIEVF,"",DIEVFLD,"variable pointer screen") Q
S DIVPRNUM=$$FIND1^DIC(DIVPFILE,"","BO",DIEVAL,"",$G(DIC("S")))
I $D(^TMP("DIERR",$J,"E",299)) K DIVPY S DIVPAMB=1
I 'DIVPRNUM Q
I DIVPRNUM,'$D(DIVPY) S DIVPY=DIVPRNUM,DIVPHITF=DIVPFILE Q
I DIVPRNUM,$D(DIVPY) D
. K DIVPY
. S DIVPAMB=1
. N DIVPP S DIVPP(1)=DIEVAL D BLD^DIALOG(299,.DIVPP,.DIVPP)
Q
;
DONE ;
I '$G(DIVPY) S DIVPOUT=U Q
S DIVPOUT=DIVPY_";"_$E($$GET1^DID(DIVPHITF,"","","GLOBAL NAME","","","A"),2,99)
D IT
I DIVPOUT=U Q
I DIEVFLG["E" S DIVPOUT(0)=$$EXTERNAL^DILFD(DIEVF,DIEVFLD,"",DIVPOUT)
Q
;
IT ;
N X S X=DIVPOUT
N DIVPECNT S DIVPECNT=$G(DIERR)
I $G(DIEV0) X $P(DIEV0,U,5,99)
I '$G(DIEV0) X $P(^DD(DIEVF,DIEVFLD,0),U,5,99)
I DIVPECNT'=$G(DIERR) S DIVPOUT=U D HKERR^DILIBF(DIEVF,"",DIEVFLD,"input transform") Q
S DIVPOUT=$G(X,U)
Q
;
VPFILES(DIEVF,DIEVFLD,DIVPFLK,DIVPANS) ;
N DIVPVPS,DIEVFILE
D VPNUMS(DIEVF,DIEVFLD,DIVPFLK,.DIVPVPS)
I '$D(DIVPVPS) Q
N DIVPVP S DIVPVP=""
F S DIVPVP=$O(DIVPVPS(DIVPVP)) Q:DIVPVP="" D
. S DIVPANS(+^DD(DIEVF,DIEVFLD,"V",DIVPVP,0))=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIEV1 2955 printed Sep 23, 2025@20:23:29 Page 2
DIEV1 ;SFISC/DPC - VARIABLE POINTER VALIDATION ;1:39 PM 12 Sep 2002
+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 ;
VP(DIEVF,DIEVFLD,DIEVFLG,DIEVAL,DIEV0,DIVPOUT) ;
+1 NEW DIVPY,DIVPHITF,DIVPZ,DIVPVP,DIVPRNUM,DIVPFILE,DIVPSAVV,DIVPAMB,DIVPFLK
+2 KILL DIVPOUT
+3 SET DIVPAMB=0
+4 IF DIEVAL'["."!($PIECE(DIEVAL,".")="")
DO ALL
DO DONE
QUIT
+5 SET DIVPSAVV=DIEVAL
SET DIVPFLK=$PIECE(DIVPSAVV,".")
SET DIEVAL=$PIECE(DIVPSAVV,".",2,99)
+6 NEW DIVPVPS
DO VPNUMS(DIEVF,DIEVFLD,DIVPFLK,.DIVPVPS)
+7 IF $DATA(DIVPVPS)
Begin DoDot:1
+8 SET DIVPVP=""
+9 FOR
SET DIVPVP=$ORDER(DIVPVPS(DIVPVP))
if DIVPVP=""
QUIT
DO FINDVP
if DIVPAMB
QUIT
End DoDot:1
+10 IF DIVPAMB
SET DIVPOUT=U
QUIT
+11 IF $DATA(DIVPY)
DO DONE
QUIT
+12 SET DIEVAL=DIVPSAVV
+13 DO ALL
DO DONE
+14 QUIT
+15 ;
ALL ;
+1 NEW DIVPORD
SET DIVPORD=0
+2 FOR
SET DIVPORD=$ORDER(^DD(DIEVF,DIEVFLD,"V","O",DIVPORD))
if 'DIVPORD
QUIT
Begin DoDot:1
+3 SET DIVPVP=$ORDER(^DD(DIEVF,DIEVFLD,"V","O",DIVPORD,""))
+4 DO FINDVP
End DoDot:1
if DIVPAMB
QUIT
+5 QUIT
+6 ;
VPNUMS(DIEVF,DIEVFLD,DIVPFLK,DIVPVPS) ;
+1 IF $DATA(^DD(DIEVF,DIEVFLD,"V","P",DIVPFLK))
SET DIVPVPS($ORDER(^(DIVPFLK,"")))=""
QUIT
+2 NEW DIVPMES
SET DIVPMES=""
+3 FOR
SET DIVPMES=$ORDER(^DD(DIEVF,DIEVFLD,"V","M",DIVPMES))
if DIVPMES=""
QUIT
Begin DoDot:1
+4 IF $PIECE(DIVPMES,DIVPFLK)=""
SET DIVPVPS($ORDER(^DD(DIEVF,DIEVFLD,"V","M",DIVPMES,"")))=""
End DoDot:1
+5 SET DIVPFILE=0
+6 FOR
SET DIVPFILE=$ORDER(^DD(DIEVF,DIEVFLD,"V","B",DIVPFILE))
if DIVPFILE=""
QUIT
Begin DoDot:1
+7 IF $PIECE($$GET1^DID(DIVPFILE,"","","NAME","","","A"),DIVPFLK)=""
SET DIVPVPS($ORDER(^DD(DIEVF,DIEVFLD,"V","B",DIVPFILE,"")))=""
End DoDot:1
+8 QUIT
+9 ;
FINDVP ;
+1 SET DIVPZ=^DD(DIEVF,DIEVFLD,"V",DIVPVP,0)
+2 SET DIVPFILE=+DIVPZ
if 'DIVPFILE
QUIT
+3 NEW DIVPECNT
SET DIVPECNT=$GET(DIERR)
+4 IF $PIECE(DIVPZ,U,5)="y"
IF $GET(^DD(DIEVF,DIEVFLD,"V",DIVPVP,1))]""
NEW DIC
XECUTE ^DD(DIEVF,DIEVFLD,"V",DIVPVP,1)
+5 IF DIVPECNT'=$GET(DIERR)
DO HKERR^DILIBF(DIEVF,"",DIEVFLD,"variable pointer screen")
QUIT
+6 SET DIVPRNUM=$$FIND1^DIC(DIVPFILE,"","BO",DIEVAL,"",$GET(DIC("S")))
+7 IF $DATA(^TMP("DIERR",$JOB,"E",299))
KILL DIVPY
SET DIVPAMB=1
+8 IF 'DIVPRNUM
QUIT
+9 IF DIVPRNUM
IF '$DATA(DIVPY)
SET DIVPY=DIVPRNUM
SET DIVPHITF=DIVPFILE
QUIT
+10 IF DIVPRNUM
IF $DATA(DIVPY)
Begin DoDot:1
+11 KILL DIVPY
+12 SET DIVPAMB=1
+13 NEW DIVPP
SET DIVPP(1)=DIEVAL
DO BLD^DIALOG(299,.DIVPP,.DIVPP)
End DoDot:1
+14 QUIT
+15 ;
DONE ;
+1 IF '$GET(DIVPY)
SET DIVPOUT=U
QUIT
+2 SET DIVPOUT=DIVPY_";"_$EXTRACT($$GET1^DID(DIVPHITF,"","","GLOBAL NAME","","","A"),2,99)
+3 DO IT
+4 IF DIVPOUT=U
QUIT
+5 IF DIEVFLG["E"
SET DIVPOUT(0)=$$EXTERNAL^DILFD(DIEVF,DIEVFLD,"",DIVPOUT)
+6 QUIT
+7 ;
IT ;
+1 NEW X
SET X=DIVPOUT
+2 NEW DIVPECNT
SET DIVPECNT=$GET(DIERR)
+3 IF $GET(DIEV0)
XECUTE $PIECE(DIEV0,U,5,99)
+4 IF '$GET(DIEV0)
XECUTE $PIECE(^DD(DIEVF,DIEVFLD,0),U,5,99)
+5 IF DIVPECNT'=$GET(DIERR)
SET DIVPOUT=U
DO HKERR^DILIBF(DIEVF,"",DIEVFLD,"input transform")
QUIT
+6 SET DIVPOUT=$GET(X,U)
+7 QUIT
+8 ;
VPFILES(DIEVF,DIEVFLD,DIVPFLK,DIVPANS) ;
+1 NEW DIVPVPS,DIEVFILE
+2 DO VPNUMS(DIEVF,DIEVFLD,DIVPFLK,.DIVPVPS)
+3 IF '$DATA(DIVPVPS)
QUIT
+4 NEW DIVPVP
SET DIVPVP=""
+5 FOR
SET DIVPVP=$ORDER(DIVPVPS(DIVPVP))
if DIVPVP=""
QUIT
Begin DoDot:1
+6 SET DIVPANS(+^DD(DIEVF,DIEVFLD,"V",DIVPVP,0))=""
End DoDot:1
+7 QUIT
