DIKC2 ;SFISC/MKO-CHECK INPUT PARAMETERS TO INDEX^DIKC ;19DEC2010
;;22.0;VA FileMan;**11,167**;Mar 30, 1999;Build 20
;Per VHA Directive 2004-038, this routine should not be modified.
;CHK: Check input parameters to INDEX^DIKC
;Also set:
; DA = DA array
; DIROOT = Closed root of file
; DIFILE = File #
; DIKERR = "X" : if there's a problem
;
CHK ;File is a required input param
I $G(DIFILE)="" D:DIF["D" ERR^DIKCU2(202,"","","","FILE") D ERR Q
;
;Check DIREC and set DA array
I $G(DIREC)'["," M DA=DIREC
E S:DIREC'?.E1"," DIREC=DIREC_"," D DA^DILF(DIREC,.DA)
S:'$G(DA) DA=""
I '$$VDA^DIKCU1(.DA,DIF) D ERR Q
;
DICTRL ;Check DICTRL parameter
I $G(DICTRL)]"",'$$VFLAG^DIKCU1(DICTRL,"KSsDWiRIkCTrfx",DIF) D ERR
I $G(DICTRL)["W",'$$VFNUM^DIKCU1(+$P(DICTRL,"W",2),DIF) D ERR
I $G(DICTRL)["C",$G(DICTRL)["T" D
. D:DIF["D" ERR^DIKCU2(301,"","","","C and T")
. D ERR
E I $G(DICTRL)["C",$G(DICTRL)["K" D
. D:DIF["D" ERR^DIKCU2(301,"","","","C and K")
. D ERR
E I $G(DICTRL)["T",$G(DICTRL)["S" D
. D:DIF["D" ERR^DIKCU2(301,"","","","T and S")
. D ERR
Q:$G(DIKERR)="X"
;
;Set DIFILE and DIROOT
N DILEV
I DIFILE=+$P(DIFILE,"E") D
. S DIROOT=$$FROOTDA^DIKCU(DIFILE,DIF,.DILEV) I DIROOT="" D ERR Q
. I DILEV,$D(DA(DILEV))[0 D Q
.. D:DIF["D" ERR^DIKCU2(205,"",$$IENS^DILF(.DA),"",DIFILE) D ERR
. S:DILEV DIROOT=$NA(@DIROOT)
. S DIFILE=$$FNUM^DIKCU(DIROOT,DIF) I DIFILE="" D ERR
E D
. S DIROOT=DIFILE
. S:"(,"[$E(DIROOT,$L(DIROOT)) DIROOT=$$CREF^DILF(DIFILE)
. S DIFILE=$$FNUM^DIKCU(DIROOT,DIF) I DIFILE="" D ERR Q
. S DILEV=$$FLEV^DIKCU(DIFILE,DIF) I DILEV="" D ERR Q
. I DILEV,$D(DA(DILEV))[0 D Q
.. D:DIF["D" ERR^DIKCU2(205,"",$$IENS^DILF(.DA),"",DIFILE) D ERR
;
;Set DIKVAL,DIKON
S DIKVAL=$G(DICTRL("VAL"))
I DIKVAL]"" D
. S:"(,_"'[$E(DIKVAL,$L(DIKVAL)) DIKVAL=$$OREF^DILF(DIKVAL)
. S DIKON="O^N"
E S DIKON=""
Q
;
ERR ;Set error flag
S DIKERR="X"
Q
;
;==========================
; CRV(Index,ValueRoot,TMP)
;==========================
;Load values from Cross Reference Values multiple into @TMP
;In:
; XR = Index #
; VALRT = Array Ref where old/new values are located
; TMP = Root of array to store data
;Returns:
; @TMP@(RootFile,Index#) = Name^File^RootType^Type
; Index#,Order#) = Code that sets X to the data
; Order#,"SS") = Subscript^MaxLength
; "T") = Transform (for 'Field'-type)
; "F") = file^field^levdiff(file,rFile)
CRV(XR,VALRT,TMP) ;
Q:'$G(XR)!($G(TMP)="")
N CRV,CRV0,DEC,FIL,FLD,MAXL,ND,ORD,OROOT,RFIL,SBSC,TYPE
;
S RFIL=$P($G(^DD("IX",XR,0)),U,9) Q:RFIL="" Q:$D(@TMP@(RFIL,XR))
S @TMP@(RFIL,XR)=$P(^DD("IX",XR,0),U,2)_U_$P(^(0),U)_U_$P(^(0),U,8)_U_$P(^(0),U,4)
S OROOT=$$FROOTDA^DIKCU(RFIL,"O")_"DA," Q:OROOT="DA,"
;
S CRV=0 F S CRV=$O(^DD("IX",XR,11.1,CRV)) Q:'CRV D
. S CRV0=$G(^DD("IX",XR,11.1,CRV,0))
. S ORD=$P(CRV0,U),TYPE=$P(CRV0,U,2),MAXL=$P(CRV0,U,5),SBSC=$P(CRV0,U,6)
. Q:ORD=""!(TYPE="")
. ;
. I TYPE="F" D
.. S FIL=$P(CRV0,U,3),FLD=$P(CRV0,U,4) Q:(FIL="")!'FLD
.. I FIL'=RFIL N OROOT,LDIF D Q:$G(OROOT)=""
... S LDIF=$$FLEVDIFF^DIKCU(FIL,RFIL) Q:'LDIF
... S OROOT=$$FROOTDA^DIKCU(FIL,LDIF_"O") Q:OROOT=""
... S OROOT=OROOT_"DA("_LDIF_"),"
.. S DEC=$$DEC(FIL,FLD,$G(VALRT),OROOT) Q:DEC=""
.. S @TMP@(RFIL,XR,ORD)=DEC
.. S @TMP@(RFIL,XR,ORD,"F")=FIL_U_FLD_$S($G(LDIF):U_LDIF,1:"")
.. S:$G(^DD("IX",XR,11.1,CRV,2))'?."^" @TMP@(RFIL,XR,ORD,"T")=^(2)
. ;
. E I TYPE="C" S @TMP@(RFIL,XR,ORD)=$G(^DD("IX",XR,11.1,CRV,1.5))
. ;
. S:SBSC @TMP@(RFIL,XR,ORD,"SS")=SBSC_$S(MAXL:U_MAXL,1:"")
Q
;
;======================================
; $$DEC(File,Field,ValueRoot,OpenRoot)
;======================================
;Return Data Extraction Code -- M code that sets X equal to the data.
;In:
; FIL = File #
; FLD = Field #
; VALRT = Array Ref where old/new values are located
; if ends in "_", FILE subscript is concatenated to the last
; subscript (used by DDS02)
; OROOT = Open root of record w/ DA subscripts
;Returns: M code
; For example:
; S X=$P(^DIZ(1000,DA(1),100,0),U,2) or
; S X=$E(^DIZ(1000,DA(1),100,1),1,245) or
; S X=$G(array(file,DIIENS,field,DION),$P(^root(DA,nd),U,pc))
;
DEC(FIL,FLD,VALRT,OROOT) ;
Q:$P($G(^DD(FIL,FLD,0)),U)="" ""
;
N ND,PC,DEC
S PC=$P($G(^DD(FIL,FLD,0)),U,4)
S ND=$P(PC,";"),PC=$P(PC,";",2) Q:ND?." "!("0 "[PC) ""
S:ND'=+$P(ND,"E") ND=""""_ND_""""
;
I $G(OROOT)="" S OROOT=$$FROOTDA^DIKCU(FIL,"O")_"DA," Q:OROOT="DA," ""
I PC S DEC="$P($G("_OROOT_ND_")),U,"_PC_")"
E S DEC="$E($G("_OROOT_ND_")),"_+$E(PC,2,999)_","_$P(PC,",",2)_")"
;
I $G(VALRT)]"" D
. I $E(VALRT,$L(VALRT))="_" D Q
.. S VALRT=$E(VALRT,1,$L(VALRT)-3)
.. S DEC="$G("_VALRT_FIL_""",DIIENS,"_FLD_",DION),"_DEC_")"
. S:"(,"'[$E(VALRT,$L(VALRT)) VALRT=$$OREF^DILF(VALRT)
. S DEC="$G("_VALRT_FIL_",DIIENS,"_FLD_",DION),"_DEC_")"
S DEC="S X="_DEC
Q DEC
;
;======================
; LOG(Index,Logic,TMP)
;======================
;Load Set and/or Kill logic into into @TMP
;In:
; XR = Index #
; LOG [ K : load kill logic
; [ S : load set logic
; TMP = Root of array to store data
;Returns:
; @TMP@(RootFile,Index#,"S") = Set logic
; "SC") = Set condition
; "K") = Kill logic
; "KC") = Kill condtion
LOG(XR,LOG,TMP) ;
Q:'$G(XR) Q:$G(LOG)="" Q:$G(TMP)=""
N SL,KL,SC,KC,RFIL
;
S RFIL=$P(^DD("IX",XR,0),U,9) Q:RFIL=""
I LOG["S" D
. S SL=$G(^DD("IX",XR,1)),SC=$G(^(1.4))
. I "Q"'[SL,SL'?."^" S @TMP@(RFIL,XR,"S")=SL
. I "Q"'[SC,SC'?."^" S @TMP@(RFIL,XR,"SC")=SC
I LOG["K" D
. S KL=$G(^DD("IX",XR,2)),KC=$G(^(2.4))
. I "Q"'[KL,KL'?."^" S @TMP@(RFIL,XR,"K")=KL
. I "Q"'[KC,KC'?."^" S @TMP@(RFIL,XR,"KC")=KC
Q
;
;===============
; KW(Index,TMP)
;===============
;Load Kill Entire Index logic into @TMP
;In:
; XR = Index #
; TMP = Root of array to store data
;Returns:
; @TMP@("KW",File#[.01],Index#) = Kill Entire Index logic
; Index#,0) = Type ("W" for whole-file index)
; ^RootFile
; ^Level difference between top file
; and root file
KW(XR,TMP) ;Get Kill Entire Index logic
Q:'$G(XR)!($G(TMP)="")
N FILE,KW,RFIL,TYPE
S KW=$G(^DD("IX",XR,2.5)) Q:KW="Q"!(KW?."^")
S FILE=$P($G(^DD("IX",XR,0)),U),TYPE=$P(^(0),U,8),RFIL=$P(^(0),U,9)
Q:FILE=""!(RFIL="")
;
S @TMP@("KW",FILE,XR)=KW
S:RFIL'=FILE @TMP@("KW",FILE,XR,0)=TYPE_U_RFIL_U_$$FLEVDIFF^DIKCU(FILE,RFIL)
Q
;
;#202 The input parameter that identifies the |1| is missing or invalid.
;#205 File# |1| and IEN string |IENS| represent different subfile levels.
;
DIKC2 ;SFISC/MKO-CHECK INPUT PARAMETERS TO INDEX^DIKC ;19DEC2010
+1 ;;22.0;VA FileMan;**11,167**;Mar 30, 1999;Build 20
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;CHK: Check input parameters to INDEX^DIKC
+4 ;Also set:
+5 ; DA = DA array
+6 ; DIROOT = Closed root of file
+7 ; DIFILE = File #
+8 ; DIKERR = "X" : if there's a problem
+9 ;
CHK ;File is a required input param
+1 IF $GET(DIFILE)=""
IF DIF["D"
DO ERR^DIKCU2(202,"","","","FILE")
DO ERR
QUIT
+2 ;
+3 ;Check DIREC and set DA array
+4 IF $GET(DIREC)'[","
MERGE DA=DIREC
+5 IF '$TEST
IF DIREC'?.E1","
SET DIREC=DIREC_","
DO DA^DILF(DIREC,.DA)
+6 IF '$GET(DA)
SET DA=""
+7 IF '$$VDA^DIKCU1(.DA,DIF)
DO ERR
QUIT
+8 ;
DICTRL ;Check DICTRL parameter
+1 IF $GET(DICTRL)]""
IF '$$VFLAG^DIKCU1(DICTRL,"KSsDWiRIkCTrfx",DIF)
DO ERR
+2 IF $GET(DICTRL)["W"
IF '$$VFNUM^DIKCU1(+$PIECE(DICTRL,"W",2),DIF)
DO ERR
+3 IF $GET(DICTRL)["C"
IF $GET(DICTRL)["T"
Begin DoDot:1
+4 IF DIF["D"
DO ERR^DIKCU2(301,"","","","C and T")
+5 DO ERR
End DoDot:1
+6 IF '$TEST
IF $GET(DICTRL)["C"
IF $GET(DICTRL)["K"
Begin DoDot:1
+7 IF DIF["D"
DO ERR^DIKCU2(301,"","","","C and K")
+8 DO ERR
End DoDot:1
+9 IF '$TEST
IF $GET(DICTRL)["T"
IF $GET(DICTRL)["S"
Begin DoDot:1
+10 IF DIF["D"
DO ERR^DIKCU2(301,"","","","T and S")
+11 DO ERR
End DoDot:1
+12 IF $GET(DIKERR)="X"
QUIT
+13 ;
+14 ;Set DIFILE and DIROOT
+15 NEW DILEV
+16 IF DIFILE=+$PIECE(DIFILE,"E")
Begin DoDot:1
+17 SET DIROOT=$$FROOTDA^DIKCU(DIFILE,DIF,.DILEV)
IF DIROOT=""
DO ERR
QUIT
+18 IF DILEV
IF $DATA(DA(DILEV))[0
Begin DoDot:2
+19 IF DIF["D"
DO ERR^DIKCU2(205,"",$$IENS^DILF(.DA),"",DIFILE)
DO ERR
End DoDot:2
QUIT
+20 IF DILEV
SET DIROOT=$NAME(@DIROOT)
+21 SET DIFILE=$$FNUM^DIKCU(DIROOT,DIF)
IF DIFILE=""
DO ERR
End DoDot:1
+22 IF '$TEST
Begin DoDot:1
+23 SET DIROOT=DIFILE
+24 IF "(,"[$EXTRACT(DIROOT,$LENGTH(DIROOT))
SET DIROOT=$$CREF^DILF(DIFILE)
+25 SET DIFILE=$$FNUM^DIKCU(DIROOT,DIF)
IF DIFILE=""
DO ERR
QUIT
+26 SET DILEV=$$FLEV^DIKCU(DIFILE,DIF)
IF DILEV=""
DO ERR
QUIT
+27 IF DILEV
IF $DATA(DA(DILEV))[0
Begin DoDot:2
+28 IF DIF["D"
DO ERR^DIKCU2(205,"",$$IENS^DILF(.DA),"",DIFILE)
DO ERR
End DoDot:2
QUIT
End DoDot:1
+29 ;
+30 ;Set DIKVAL,DIKON
+31 SET DIKVAL=$GET(DICTRL("VAL"))
+32 IF DIKVAL]""
Begin DoDot:1
+33 IF "(,_"'[$EXTRACT(DIKVAL,$LENGTH(DIKVAL))
SET DIKVAL=$$OREF^DILF(DIKVAL)
+34 SET DIKON="O^N"
End DoDot:1
+35 IF '$TEST
SET DIKON=""
+36 QUIT
+37 ;
ERR ;Set error flag
+1 SET DIKERR="X"
+2 QUIT
+3 ;
+4 ;==========================
+5 ; CRV(Index,ValueRoot,TMP)
+6 ;==========================
+7 ;Load values from Cross Reference Values multiple into @TMP
+8 ;In:
+9 ; XR = Index #
+10 ; VALRT = Array Ref where old/new values are located
+11 ; TMP = Root of array to store data
+12 ;Returns:
+13 ; @TMP@(RootFile,Index#) = Name^File^RootType^Type
+14 ; Index#,Order#) = Code that sets X to the data
+15 ; Order#,"SS") = Subscript^MaxLength
+16 ; "T") = Transform (for 'Field'-type)
+17 ; "F") = file^field^levdiff(file,rFile)
CRV(XR,VALRT,TMP) ;
+1 IF '$GET(XR)!($GET(TMP)="")
QUIT
+2 NEW CRV,CRV0,DEC,FIL,FLD,MAXL,ND,ORD,OROOT,RFIL,SBSC,TYPE
+3 ;
+4 SET RFIL=$PIECE($GET(^DD("IX",XR,0)),U,9)
IF RFIL=""
QUIT
IF $DATA(@TMP@(RFIL,XR))
QUIT
+5 SET @TMP@(RFIL,XR)=$PIECE(^DD("IX",XR,0),U,2)_U_$PIECE(^(0),U)_U_$PIECE(^(0),U,8)_U_$PIECE(^(0),U,4)
+6 SET OROOT=$$FROOTDA^DIKCU(RFIL,"O")_"DA,"
IF OROOT="DA,"
QUIT
+7 ;
+8 SET CRV=0
FOR
SET CRV=$ORDER(^DD("IX",XR,11.1,CRV))
IF 'CRV
QUIT
Begin DoDot:1
+9 SET CRV0=$GET(^DD("IX",XR,11.1,CRV,0))
+10 SET ORD=$PIECE(CRV0,U)
SET TYPE=$PIECE(CRV0,U,2)
SET MAXL=$PIECE(CRV0,U,5)
SET SBSC=$PIECE(CRV0,U,6)
+11 IF ORD=""!(TYPE="")
QUIT
+12 ;
+13 IF TYPE="F"
Begin DoDot:2
+14 SET FIL=$PIECE(CRV0,U,3)
SET FLD=$PIECE(CRV0,U,4)
IF (FIL="")!'FLD
QUIT
+15 IF FIL'=RFIL
NEW OROOT,LDIF
Begin DoDot:3
+16 SET LDIF=$$FLEVDIFF^DIKCU(FIL,RFIL)
IF 'LDIF
QUIT
+17 SET OROOT=$$FROOTDA^DIKCU(FIL,LDIF_"O")
IF OROOT=""
QUIT
+18 SET OROOT=OROOT_"DA("_LDIF_"),"
End DoDot:3
IF $GET(OROOT)=""
QUIT
+19 SET DEC=$$DEC(FIL,FLD,$GET(VALRT),OROOT)
IF DEC=""
QUIT
+20 SET @TMP@(RFIL,XR,ORD)=DEC
+21 SET @TMP@(RFIL,XR,ORD,"F")=FIL_U_FLD_$SELECT($GET(LDIF):U_LDIF,1:"")
+22 IF $GET(^DD("IX",XR,11.1,CRV,2))'?."^"
SET @TMP@(RFIL,XR,ORD,"T")=^(2)
End DoDot:2
+23 ;
+24 IF '$TEST
IF TYPE="C"
SET @TMP@(RFIL,XR,ORD)=$GET(^DD("IX",XR,11.1,CRV,1.5))
+25 ;
+26 IF SBSC
SET @TMP@(RFIL,XR,ORD,"SS")=SBSC_$SELECT(MAXL:U_MAXL,1:"")
End DoDot:1
+27 QUIT
+28 ;
+29 ;======================================
+30 ; $$DEC(File,Field,ValueRoot,OpenRoot)
+31 ;======================================
+32 ;Return Data Extraction Code -- M code that sets X equal to the data.
+33 ;In:
+34 ; FIL = File #
+35 ; FLD = Field #
+36 ; VALRT = Array Ref where old/new values are located
+37 ; if ends in "_", FILE subscript is concatenated to the last
+38 ; subscript (used by DDS02)
+39 ; OROOT = Open root of record w/ DA subscripts
+40 ;Returns: M code
+41 ; For example:
+42 ; S X=$P(^DIZ(1000,DA(1),100,0),U,2) or
+43 ; S X=$E(^DIZ(1000,DA(1),100,1),1,245) or
+44 ; S X=$G(array(file,DIIENS,field,DION),$P(^root(DA,nd),U,pc))
+45 ;
DEC(FIL,FLD,VALRT,OROOT) ;
+1 IF $PIECE($GET(^DD(FIL,FLD,0)),U)=""
QUIT ""
+2 ;
+3 NEW ND,PC,DEC
+4 SET PC=$PIECE($GET(^DD(FIL,FLD,0)),U,4)
+5 SET ND=$PIECE(PC,";")
SET PC=$PIECE(PC,";",2)
IF ND?." "!("0 "[PC)
QUIT ""
+6 IF ND'=+$PIECE(ND,"E")
SET ND=""""_ND_""""
+7 ;
+8 IF $GET(OROOT)=""
SET OROOT=$$FROOTDA^DIKCU(FIL,"O")_"DA,"
IF OROOT="DA,"
QUIT ""
+9 IF PC
SET DEC="$P($G("_OROOT_ND_")),U,"_PC_")"
+10 IF '$TEST
SET DEC="$E($G("_OROOT_ND_")),"_+$EXTRACT(PC,2,999)_","_$PIECE(PC,",",2)_")"
+11 ;
+12 IF $GET(VALRT)]""
Begin DoDot:1
+13 IF $EXTRACT(VALRT,$LENGTH(VALRT))="_"
Begin DoDot:2
+14 SET VALRT=$EXTRACT(VALRT,1,$LENGTH(VALRT)-3)
+15 SET DEC="$G("_VALRT_FIL_""",DIIENS,"_FLD_",DION),"_DEC_")"
End DoDot:2
QUIT
+16 IF "(,"'[$EXTRACT(VALRT,$LENGTH(VALRT))
SET VALRT=$$OREF^DILF(VALRT)
+17 SET DEC="$G("_VALRT_FIL_",DIIENS,"_FLD_",DION),"_DEC_")"
End DoDot:1
+18 SET DEC="S X="_DEC
+19 QUIT DEC
+20 ;
+21 ;======================
+22 ; LOG(Index,Logic,TMP)
+23 ;======================
+24 ;Load Set and/or Kill logic into into @TMP
+25 ;In:
+26 ; XR = Index #
+27 ; LOG [ K : load kill logic
+28 ; [ S : load set logic
+29 ; TMP = Root of array to store data
+30 ;Returns:
+31 ; @TMP@(RootFile,Index#,"S") = Set logic
+32 ; "SC") = Set condition
+33 ; "K") = Kill logic
+34 ; "KC") = Kill condtion
LOG(XR,LOG,TMP) ;
+1 IF '$GET(XR)
QUIT
IF $GET(LOG)=""
QUIT
IF $GET(TMP)=""
QUIT
+2 NEW SL,KL,SC,KC,RFIL
+3 ;
+4 SET RFIL=$PIECE(^DD("IX",XR,0),U,9)
IF RFIL=""
QUIT
+5 IF LOG["S"
Begin DoDot:1
+6 SET SL=$GET(^DD("IX",XR,1))
SET SC=$GET(^(1.4))
+7 IF "Q"'[SL
IF SL'?."^"
SET @TMP@(RFIL,XR,"S")=SL
+8 IF "Q"'[SC
IF SC'?."^"
SET @TMP@(RFIL,XR,"SC")=SC
End DoDot:1
+9 IF LOG["K"
Begin DoDot:1
+10 SET KL=$GET(^DD("IX",XR,2))
SET KC=$GET(^(2.4))
+11 IF "Q"'[KL
IF KL'?."^"
SET @TMP@(RFIL,XR,"K")=KL
+12 IF "Q"'[KC
IF KC'?."^"
SET @TMP@(RFIL,XR,"KC")=KC
End DoDot:1
+13 QUIT
+14 ;
+15 ;===============
+16 ; KW(Index,TMP)
+17 ;===============
+18 ;Load Kill Entire Index logic into @TMP
+19 ;In:
+20 ; XR = Index #
+21 ; TMP = Root of array to store data
+22 ;Returns:
+23 ; @TMP@("KW",File#[.01],Index#) = Kill Entire Index logic
+24 ; Index#,0) = Type ("W" for whole-file index)
+25 ; ^RootFile
+26 ; ^Level difference between top file
+27 ; and root file
KW(XR,TMP) ;Get Kill Entire Index logic
+1 IF '$GET(XR)!($GET(TMP)="")
QUIT
+2 NEW FILE,KW,RFIL,TYPE
+3 SET KW=$GET(^DD("IX",XR,2.5))
IF KW="Q"!(KW?."^")
QUIT
+4 SET FILE=$PIECE($GET(^DD("IX",XR,0)),U)
SET TYPE=$PIECE(^(0),U,8)
SET RFIL=$PIECE(^(0),U,9)
+5 IF FILE=""!(RFIL="")
QUIT
+6 ;
+7 SET @TMP@("KW",FILE,XR)=KW
+8 IF RFIL'=FILE
SET @TMP@("KW",FILE,XR,0)=TYPE_U_RFIL_U_$$FLEVDIFF^DIKCU(FILE,RFIL)
+9 QUIT
+10 ;
+11 ;#202 The input parameter that identifies the |1| is missing or invalid.
+12 ;#205 File# |1| and IEN string |IENS| represent different subfile levels.
+13 ;
