- DIEV1 ;SFISC/DPC -- VARIABLE POINTER VALIDATION ;1:39 PM 12 Sep 2002 [ 12/09/2003 4:37 PM ]
- ;;22.0;VA FileMan;**26,72,90,112,1002**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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
- DIEV1 ;SFISC/DPC -- VARIABLE POINTER VALIDATION ;1:39 PM 12 Sep 2002 [ 12/09/2003 4:37 PM ]
- +1 ;;22.0;VA FileMan;**26,72,90,112,1002**;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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
