Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DICA2

DICA2.m

Go to the documentation of this file.
DICA2 ;SEA/TOAD-VA FileMan: Updater, Pre-Processor Part 2 ;8:12 AM  10 Jun 1998
 ;;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.
 ;
IEN(DIFILE,DIEN,DIDA,DIRULE,DIOK) ;
 ; ENTRY POINT--return whether the IEN String is valid
 ; proc, DIEN passed by value
 I $G(DIFILE("C"))'=DIFILE D PARENTS^DIDU1(.DIFILE,DIRULE)
 I $E(DIEN,$L(DIEN))'="," D ERR^DICA3(304,"",DIEN) Q
 I DIFILE("L")+1'=$L(DIEN,",") D ERR^DICA3(205,"",DIEN,"",DIFILE) Q
 I $E(DIEN)=","!(DIEN[",,") D ERR^DICA3(307,"",DIEN) Q
 K @DIRULE@("TEMP")
PIECES ;
 K DIDA N DICRSR,DIOUT S DIOUT=0 F DICRSR=1:1 D  Q:DIOUT!$G(DIERR)
 . N DIPIECE S DIPIECE=$P(DIEN,",",DICRSR)
 . N DIRIGHT S DIRIGHT=$P(DIEN,",",DICRSR+1,99999)
 . I DIPIECE="" S DIOUT=1,DIOK=1 Q
 . D PIECE(.DIFILE,DIFDA,DIRULE,DICRSR,DIPIECE,.DIDA,DIRIGHT,.DIOK)
 . I $G(DIERR) S DIOK=0 Q
 . I 'DIOK D ERR^DICA3($S(DIOK=0:308,1:310),"",DIEN) Q
 . Q
 I $G(DIERR) Q
ALLGOOD ;
 M @DIRULE@("SEQ")=@DIRULE@("TEMP")
 N DIN S DIN="S DIFILE="_DIFILE_",DIENTRY="""_DIEN_""""
 S @DIRULE@("ORDER",@DIRULE@("OP"),DIFILE("L"),DIFILE,@DIRULE@("NUM"))=DIN
 Q
 ;
PIECE(DIFILE,DIFDA,DIRULE,DICRSR,DIPIECE,DIDA,DIRIGHT,DIOK) ;
 ; IEN--return whether a piece of the IEN String is valid
 ; proc, DIF, DIOK, & DIRULE passed by ref
 N DICHECK,DIF,DIPREFIX,DIR,DISEQ
 S DIF=DIFILE(DICRSR)
 I DIPIECE'["+",DIRIGHT["+" S DIOK=0 Q
FILING I +DIPIECE=DIPIECE,$E(DIPIECE)'="+" D  Q
 . S DIOK=DIPIECE>0 I 'DIOK Q
 . S DIOK=DIRIGHT'["+"&(DIRIGHT'["?") I 'DIOK Q
 . S DIR=$G(@DIRULE@("ROOT",DIF,","_DIRIGHT))
 . I DIR="" D
 . . S DIR=$$ROOT^DIQGU(DIF,","_DIRIGHT,1,1)
 . . S @DIRULE@("ROOT",DIF,","_DIRIGHT)=DIR
 . S DIOK=$P($G(@DIR@(DIPIECE,0)),U)'=""
 . I 'DIOK D ERR^DICA3(601,DIFILE,DIPIECE_","_DIRIGHT) Q
 . I DICRSR=1 S DIDA=DIPIECE
 . E  S DIDA(DICRSR-1)=DIPIECE
 . I DICRSR'=1 Q
 . S @DIRULE@("OP")=4
 . S @DIRULE@("NUM")=DIPIECE
PREFIX S DIPREFIX=$E(DIPIECE,1,2) I DIPREFIX'="?+" S DIPREFIX=$E(DIPREFIX)
 I DIPREFIX'="+",DIPREFIX'="?",DIPREFIX'="?+" S DIOK=0 Q
 ;
GOODPC I $P(DIPIECE,DIPREFIX,2,9999)?1N.N S DIOK=1 D  Q
 . S DISEQ=$P(DIPIECE,DIPREFIX,2,999)
 . I +DISEQ'=DISEQ S DIOK=0 Q
FIRSTPC . I DICRSR=1 D
 . . S @DIRULE@("OP")=$S(DIPREFIX="?":1,DIPREFIX="?+":2,1:3)
 . . S @DIRULE@("NUM")=DISEQ
WHEREPC . S DICHECK=""
 . I $D(@DIRULE@("SEQ",DISEQ)) S DICHECK=$NA(@DIRULE@("SEQ"))
 . E  I $D(@DIRULE@("TEMP",DISEQ)) S DICHECK=$NA(@DIRULE@("TEMP"))
ILLEGAL . I DICHECK'="" D  I 'DIOK Q
 . . I $O(@DICHECK@(DISEQ,""))'=DIPREFIX S DIOK="C" Q
 . . I $O(@DICHECK@(DISEQ,DIPREFIX,""))'=DIF S DIOK="C" Q
 . . I $G(@DICHECK@(DISEQ,DIPREFIX,DIF))'=DIRIGHT S DIOK="C" Q
 . I DICHECK="",'$D(@DIFDA@(DIF,DIPIECE_","_DIRIGHT)) S DIOK="C" Q
LEARN . S @DIRULE@("TEMP",DISEQ,DIPREFIX,DIF)=DIRIGHT
 . I DICRSR=1 S DIDA=DIPREFIX
 . E  S DIDA(DICRSR-1)=DIPREFIX
 ;
BADPIEC S DIOK=0 Q