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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICA2 3090 printed Oct 16, 2024@18:45:59 Page 2
DICA2 ;SEA/TOAD-VA FileMan: Updater, Pre-Processor Part 2 ;8:12 AM 10 Jun 1998
+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 ;
IEN(DIFILE,DIEN,DIDA,DIRULE,DIOK) ;
+1 ; ENTRY POINT--return whether the IEN String is valid
+2 ; proc, DIEN passed by value
+3 IF $GET(DIFILE("C"))'=DIFILE
DO PARENTS^DIDU1(.DIFILE,DIRULE)
+4 IF $EXTRACT(DIEN,$LENGTH(DIEN))'=","
DO ERR^DICA3(304,"",DIEN)
QUIT
+5 IF DIFILE("L")+1'=$LENGTH(DIEN,",")
DO ERR^DICA3(205,"",DIEN,"",DIFILE)
QUIT
+6 IF $EXTRACT(DIEN)=","!(DIEN[",,")
DO ERR^DICA3(307,"",DIEN)
QUIT
+7 KILL @DIRULE@("TEMP")
PIECES ;
+1 KILL DIDA
NEW DICRSR,DIOUT
SET DIOUT=0
FOR DICRSR=1:1
Begin DoDot:1
+2 NEW DIPIECE
SET DIPIECE=$PIECE(DIEN,",",DICRSR)
+3 NEW DIRIGHT
SET DIRIGHT=$PIECE(DIEN,",",DICRSR+1,99999)
+4 IF DIPIECE=""
SET DIOUT=1
SET DIOK=1
QUIT
+5 DO PIECE(.DIFILE,DIFDA,DIRULE,DICRSR,DIPIECE,.DIDA,DIRIGHT,.DIOK)
+6 IF $GET(DIERR)
SET DIOK=0
QUIT
+7 IF 'DIOK
DO ERR^DICA3($SELECT(DIOK=0:308,1:310),"",DIEN)
QUIT
+8 QUIT
End DoDot:1
if DIOUT!$GET(DIERR)
QUIT
+9 IF $GET(DIERR)
QUIT
ALLGOOD ;
+1 MERGE @DIRULE@("SEQ")=@DIRULE@("TEMP")
+2 NEW DIN
SET DIN="S DIFILE="_DIFILE_",DIENTRY="""_DIEN_""""
+3 SET @DIRULE@("ORDER",@DIRULE@("OP"),DIFILE("L"),DIFILE,@DIRULE@("NUM"))=DIN
+4 QUIT
+5 ;
PIECE(DIFILE,DIFDA,DIRULE,DICRSR,DIPIECE,DIDA,DIRIGHT,DIOK) ;
+1 ; IEN--return whether a piece of the IEN String is valid
+2 ; proc, DIF, DIOK, & DIRULE passed by ref
+3 NEW DICHECK,DIF,DIPREFIX,DIR,DISEQ
+4 SET DIF=DIFILE(DICRSR)
+5 IF DIPIECE'["+"
IF DIRIGHT["+"
SET DIOK=0
QUIT
FILING IF +DIPIECE=DIPIECE
IF $EXTRACT(DIPIECE)'="+"
Begin DoDot:1
+1 SET DIOK=DIPIECE>0
IF 'DIOK
QUIT
+2 SET DIOK=DIRIGHT'["+"&(DIRIGHT'["?")
IF 'DIOK
QUIT
+3 SET DIR=$GET(@DIRULE@("ROOT",DIF,","_DIRIGHT))
+4 IF DIR=""
Begin DoDot:2
+5 SET DIR=$$ROOT^DIQGU(DIF,","_DIRIGHT,1,1)
+6 SET @DIRULE@("ROOT",DIF,","_DIRIGHT)=DIR
End DoDot:2
+7 SET DIOK=$PIECE($GET(@DIR@(DIPIECE,0)),U)'=""
+8 IF 'DIOK
DO ERR^DICA3(601,DIFILE,DIPIECE_","_DIRIGHT)
QUIT
+9 IF DICRSR=1
SET DIDA=DIPIECE
+10 IF '$TEST
SET DIDA(DICRSR-1)=DIPIECE
+11 IF DICRSR'=1
QUIT
+12 SET @DIRULE@("OP")=4
+13 SET @DIRULE@("NUM")=DIPIECE
End DoDot:1
QUIT
PREFIX SET DIPREFIX=$EXTRACT(DIPIECE,1,2)
IF DIPREFIX'="?+"
SET DIPREFIX=$EXTRACT(DIPREFIX)
+1 IF DIPREFIX'="+"
IF DIPREFIX'="?"
IF DIPREFIX'="?+"
SET DIOK=0
QUIT
+2 ;
GOODPC IF $PIECE(DIPIECE,DIPREFIX,2,9999)?1N.N
SET DIOK=1
Begin DoDot:1
+1 SET DISEQ=$PIECE(DIPIECE,DIPREFIX,2,999)
+2 IF +DISEQ'=DISEQ
SET DIOK=0
QUIT
FIRSTPC IF DICRSR=1
Begin DoDot:2
+1 SET @DIRULE@("OP")=$SELECT(DIPREFIX="?":1,DIPREFIX="?+":2,1:3)
+2 SET @DIRULE@("NUM")=DISEQ
End DoDot:2
WHEREPC SET DICHECK=""
+1 IF $DATA(@DIRULE@("SEQ",DISEQ))
SET DICHECK=$NAME(@DIRULE@("SEQ"))
+2 IF '$TEST
IF $DATA(@DIRULE@("TEMP",DISEQ))
SET DICHECK=$NAME(@DIRULE@("TEMP"))
ILLEGAL IF DICHECK'=""
Begin DoDot:2
+1 IF $ORDER(@DICHECK@(DISEQ,""))'=DIPREFIX
SET DIOK="C"
QUIT
+2 IF $ORDER(@DICHECK@(DISEQ,DIPREFIX,""))'=DIF
SET DIOK="C"
QUIT
+3 IF $GET(@DICHECK@(DISEQ,DIPREFIX,DIF))'=DIRIGHT
SET DIOK="C"
QUIT
End DoDot:2
IF 'DIOK
QUIT
+4 IF DICHECK=""
IF '$DATA(@DIFDA@(DIF,DIPIECE_","_DIRIGHT))
SET DIOK="C"
QUIT
LEARN SET @DIRULE@("TEMP",DISEQ,DIPREFIX,DIF)=DIRIGHT
+1 IF DICRSR=1
SET DIDA=DIPREFIX
+2 IF '$TEST
SET DIDA(DICRSR-1)=DIPREFIX
End DoDot:1
QUIT
+3 ;
BADPIEC SET DIOK=0
QUIT
