CIAUDDR ;MSC/IND/DKM - FileMan RPC Extensions ;04-May-2006 08:19;DKM
;;1.2;CIA UTILITIES;;Mar 20, 2007
;;Copyright 2000-2006, Medsphere Systems Corporation
;=================================================================
; RPC: Retrieve DD information about a file.
; FNUM = File # or name
; FLDS = Semi-colon delimited field list (optional)
; IENS = IENS (for subfile entries)
; FLGS = Control flags:
; D = Fix duplicate field names
; M = Retrieve multiples
; Return data:
; DATA(0) = -1^Error text or
; = File #^File name^Rec count^Field count^Readonly^Parent File
; DATA(n) = Field #^Field name^Datatype^Size^Required^Readonly^Help lines^Xref^Calculated
; DATA(n,0) = Supplemental data (set mappings)
; DATA(n,1) = Prompt Text
; DATA(n,2) = Help Text
GETDD(DATA,FNUM,FLDS,IENS,FLGS) ;
N X,Y,Z,CNT,N0,FLD,PF,MULT,DUPS
S DATA=$NA(^TMP("CIAUDDR",$J))
K @DATA
S FNUM=$G(FNUM),FLDS=$G(FLDS),FLGS=$G(FLGS),MULT=FLGS["M",DUPS=FLGS["D"
I $L(FNUM),FNUM'=+FNUM D
.S FNUM=$O(^DIC("B",FNUM,0))
.I FNUM,$O(^(FNUM)) S FNUM=""
S X=$$ROOT^DILFD(FNUM,$G(IENS),1),PF=$G(^DD(+FNUM,0,"UP"))
S:$L(X) X=$G(@X@(0))
S:PF $P(X,U)=$P($G(^DD(+FNUM,0)),U)
I '$L(X) D SETERR("Table not found") Q
S N0=FNUM_U_$P(X,U)_U_$P(X,U,4),CNT=0
F X=1:1:$L(FLDS,";") D Q:'X
.S FLD=$P(FLDS,";",X)
.Q:'$L(FLD)
.S:FLD="*" FLD="0-9999999999999999"
.I $TR(FLD,".")?1.N1"-"1.N D
..S Z=+$P(FLD,"-"),Y=+$P(FLD,"-",2)
..S:Z<0 Z=0
..I Z=0 S:'$$GETFL(0,0) X=0
..I Z>0,$D(^DD(FNUM,Z,0)) S:'$$GETFL(Z,MULT) X=0
..F Q:'X S Z=$O(^DD(FNUM,Z)) Q:'Z Q:Z>Y S:'$$GETFL(Z,MULT) X=0
.E I '$$GETFL(FLD,1) S X=0
S:X @DATA@(0)=N0_U_CNT_U_($P($G(^DD(FNUM,0,"DI")),U,2)["Y")_U_PF
Q
; Setup type info for field
; FLDX = Field # or name
; MULT = Allow multiples
; Note: Datatype (TP) maps to TFMFieldType enum:
; 0 = unknown, 1 = free text, 2 = numeric, 3 = boolean,
; 4 = date/time, 5 = wp, 6 = pointer, 7 = set, 8 = subfile
GETFL(FLDX,MULT) ;
N X,Z,LN,TP,HC,DD,FLD,MLT,NAM
S FLD=$$FLDNUM(FNUM,FLDX),MLT=0
S DD=$S('$L(FLD):"",FLD:$G(^DD(FNUM,FLD,0)),1:"#^RICJ8,5"),X=$P(DD,U,2)
I '$L(DD) D SETERR("Field not found: "_FLDX) Q 0
I X,$P($G(^DD(X,.01,0)),U,2)'["W" S MLT=1
I 'MULT,MLT Q 1
S (LN,TP,HC,Z)=0,DX="",NAM=$P(DD,U),CNT=CNT+1
I DUPS,$O(^(+$O(^DD(FNUM,"B",NAM,0)))) S NAM=NAM_"("_FLD_")"
I MLT S TP=8,DX=+X
E I X["B" S TP=3
E I X["D" S TP=4,DX=$P($P($P(DD,U,5),"%DT=",2),"""",2)
E I X["F"!(X["K") S TP=1,LN=+$P($P(DD,U,5),"$L(X)>",2) S:'LN LN=30
E I X["J" S TP=2,DX=$P(X,"J",2) S:DX'["," LN=DX,DX="",TP=1
E I X["P"!(X["p") S TP=6,DX=+$P($TR(X,"p","P"),"P",2),LN=$$GETLN(DX)
E I X["S" S TP=7,DX=$P(DD,U,3)
E I X=+X S TP=5
I 'FLD S HC=1,@DATA@(CNT,2,HC)="Internal record number."
E F S Z=$O(^DD(FNUM,FLD,21,Z)) Q:'Z S HC=HC+1,@DATA@(CNT,2,HC)=^(Z,0)
S @DATA@(CNT)=FLD_U_NAM_U_TP_U_LN_U_(X["R")_U_(X["I")_U_HC_U_$$XREF(FNUM,FLD)_U_(X["C")
S @DATA@(CNT,0)=DX,@DATA@(CNT,1)=$G(^DD(FNUM,FLD,3))
Q 1
; Get length of .01 for file
GETLN(FNUM) ;
N DD,X
S DD=$G(^DD(FNUM,.01,0)),X=$P(DD,U,2)
S X=+$S(X["P":$$GETLN(+$E(X,2,99)),X["F":$P($P(DD,U,5),"$L(X)>",2),1:0)
Q $S(X:X,1:30)
SETERR(ERR) ;
K @DATA
S @DATA@(0)="-1^"_ERR
Q
; RPC: CIAUDDR MOVETO
; Move to specified record (returns IEN only)
; FNUM: File #
; IEN : Current IEN
; DIR : 0 = current; 1 = next; 2 = prior
; IENS: Subfile IENS
; SCRN: Screens (optional)
; INDX: Index (optional)
; Returns IEN or <error code>^<error text>
MOVETO(DATA,FNUM,IEN,DIR,IENS,SCRN,INDX) ;
N GBL,IDX,IDF,OK
S GBL=$$ROOT^DILFD(FNUM,$G(IENS),1),DIR=+$G(DIR),INDX=$G(INDX)
S DIR=$S(DIR=1:1,DIR=2:-1,1:0)
S:$L($G(SCRN)) SCRN(-1)=SCRN
I '$L(GBL) S DATA="-4^Table not found" Q
I $L(INDX) D Q:$G(DATA)
.I '$O(^DD(FNUM,0,"IX",INDX,"")) S DATA="-5^Index "_INDX_" not found" Q
.S IDF=$$XREFFLD(FNUM,INDX)
.I 'IDF S DATA="-6^Index "_INDX_" is not a standard index" Q
.S IDX=$S(IEN=-1:"",IEN=-2:$C(255),1:$E($$FLDVAL(FNUM,IDF,IEN,GBL),1,30))
E S IEN=$S(IEN=-1:0,IEN=-2:$O(@GBL@($C(1)),-1)+1,1:+IEN)
F D Q:OK!'IEN
.S IEN=+$$NXTIEN
.;S OK=IEN&(IEN\1=IEN)&$D(@GBL@(IEN,0)),SCRN=""
.S OK=IEN&$D(@GBL@(IEN,0)),SCRN=""
.F Q:'OK S SCRN=$O(SCRN(SCRN)) Q:'$L(SCRN) D
..N Y
..S Y=IEN
..I $D(@GBL@(Y,0))
..X SCRN(SCRN)
..S OK=$T
.I 'OK,'DIR S IEN=0
S DATA=$S(OK:IEN,'DIR:"-3^Record not found",DIR=1:"-2^End of file",1:"-1^Beginning of file")
Q
; Return next IEN
NXTIEN() Q:'DIR IEN
Q:'$L(INDX) $O(@GBL@(IEN),DIR)
N OK
F D Q:OK!'$L(IDX)
.S:IEN'>0 IDX=$O(@GBL@(INDX,IDX),DIR),IEN=""
.S IEN=$S($L(IDX):$O(@GBL@(INDX,IDX,IEN),DIR),1:0)
.;S OK=$S('IEN:0,1:$E($$FLDVAL(FNUM,IDF,IEN,GBL),1,30)=IDX)
.S OK=$S('IEN:0,1:$D(@GBL@(IEN,0)))
Q IEN
; Return field value (internal)
; FIL = File or subfile #
; FLD = Field #
; IEN = Record #
; ROOT = Global root of file or subfile, or IENS of subfile
FLDVAL(FIL,FLD,IEN,ROOT) ;
I FLD=0!(FLD="#") Q IEN
N PC,ND,DD
S:FLD'=+FLD FLD=+$O(^DD(FIL,"B",FLD,0))
S DD=$G(^DD(FIL,FLD,0))
Q:$P(DD,U,2)["C" $$GET1^DIQ(FIL,IEN_","_$P(ROOT,",",2,999),FLD,"I")
S ND=$P(DD,U,4),PC=$P(ND,";",2),ND=$P(ND,";")
S:$E(ROOT)'=U ROOT=$$ROOT^DILFD(FIL,ROOT,1)
Q $S('$L(ND):"",1:$P($G(@ROOT@(IEN,ND)),U,PC))
; RPC: Lock/unlock a record
; FNUM = File #
; IENS = Record # (IENS format)
; WAIT = If >=0, seconds to wait for lock.
; If missing or null, perform unlock operation.
; DATA = Returns 0 if successful, -n^Error Text if not.
LOCK(DATA,FNUM,IENS,WAIT) ;
N X,IEN,OK,$ET
S @$$TRAP^CIAUOS("LOCKERR^CIAUDDR")
S $ET="",X=$$ROOT^DILFD(FNUM,IENS,1),DATA=0,IEN=+IENS
I '$L(X) S DATA="-1^Table not found" Q
K:$G(WAIT)="" WAIT
D LOCK^CIANBRPC(.OK,$NA(@X@(IEN)),.WAIT)
S:'OK DATA="-2^Record locked by another process"
Q
LOCKERR S DATA="-3^Unexpected error"
Q
; RPC: Convert pointer internal<->external
CVTPTR(DATA,FNUM,VAL,EXT) ;
I EXT S DATA=$$GET1^DIQ(FNUM,VAL,.01)
E D
.N ROOT
.S ROOT=$$ROOT^DILFD(FNUM,,1)
.I '$L(ROOT) S DATA=""
.E I VAL?1"`"1.N D
..S VAL=+$E(VAL,2,999),DATA=$S('VAL:"",$D(@ROOT@(VAL,0))#2:VAL,1:"")
.E D
..N LP
..F LP=0:1:3 S DATA=$$CP(LP) Q:DATA
Q
; Lookup value in "B" xref
CP(XFM) N RTN,LKP
S LKP=$S(XFM#2:$E(VAL,1,30),1:VAL),LKP=$S(XFM\2:$$UP^XLFSTR(LKP),1:LKP),RTN=0
F S RTN=$O(@ROOT@("B",LKP,RTN)) Q:'RTN Q:$P($G(@ROOT@(RTN,0)),U)=VAL
Q RTN
; RPC: Find an entry using specified fields and values
; FNUM = File number to search
; IENS = IENS for subfile
; FLGS = Search flags. Combination of:
; P = partial match
; I = case insensitive
; FLDS = Field #'s or names to search. Can be ;-delimited or list.
; VALS = Values to search. Can be single value or list.
; MAX = Maximum entries to return (default=all)
; Returns list of one or all IENs matching criteria or
; -n^error text if error.
FIND(DATA,FNUM,IENS,FLGS,FLDS,VALS,MAX) ;
N ROOT,QUIT,XRF,XKY,CNT,X
S IENS=$G(IENS)
I $L(IENS),$E(IENS)'="," S IENS=","_IENS
S ROOT=$$ROOT^DILFD(FNUM,IENS,1),QUIT=0,FLGS=$G(FLGS),MAX=+$G(MAX),CNT=0
S:$D(VALS)=1 VALS(1)=VALS
I $D(FLDS)=1 F X=1:1:$L(FLDS,";") S FLDS(X)=$P(FLDS,";",X)
F FLDS=0:0 S FLDS=$O(FLDS(FLDS)) Q:'FLDS D Q:QUIT
.I '$D(VALS(FLDS)) S QUIT="-1^Not enough lookup values." Q
.S X=$$FLDNUM(FNUM,FLDS(FLDS))
.I '$L(X) S QUIT="-2^Unknown field "_FLDS(FLDS)_"." Q
.S FLDS(FLDS)=X
.I '$D(XRF) D
..S X=$$XREF(FNUM,X)
..S:$L(X) XRF=X,XKY=$S(FLGS["I":$$UP^XLFSTR(VALS(FLDS)),1:VALS(FLDS))
I 'QUIT,'$D(XRF) S QUIT="-3^At least one field must be a key field."
D:'QUIT FINDX
I QUIT<0 K @DATA S @DATA@(0)=QUIT
Q
FINDX G FINDN:XRF="#",FINDP:FLGS["P",FINDE
; Find by IEN
FINDN D FINDF(XKY)
Q
; Find exact match
FINDE N XKT,IEN
S IEN=0,XKT=$E(XKY,1,30)
F S IEN=$O(@ROOT@(XRF,XKT,IEN)) Q:'IEN D Q:QUIT
.D FINDF(IEN)
Q
; Partial match
FINDP N XKT,VAL,IEN,LEN
S XKT=$E(XKY,1,30),VAL=XKT,LEN=$L(XKT)
F D S VAL=$O(@ROOT@(XRF,VAL)) Q:$E(VAL,1,LEN)'=XKT!QUIT
.S IEN=0
.F S IEN=$O(@ROOT@(XRF,VAL,IEN)) Q:'IEN D Q:QUIT
..D FINDF(IEN)
Q
; Check fields for match. Add to output if all match
FINDF(IEN) ;
N FND
S FLDS=0,FND=1
F S FLDS=$O(FLDS(FLDS)) Q:'FLDS D Q:'FND
.S FND=$$FINDM(FLDS(FLDS),VALS(FLDS),IEN)
I FND D
.S CNT=CNT+1,@DATA@(CNT)=IEN
.I MAX,CNT'<MAX S QUIT=1
Q
; Check for match
FINDM(FLD,VAL,IEN) ;
N VALX
S VALX=$$FLDVAL(FNUM,FLD,IEN,ROOT)
S:FLGS["I" VAL=$$UP^XLFSTR(VAL),VALX=$$UP^XLFSTR(VALX)
Q $S(FLGS["P":$E(VALX,1,$L(VAL))=VAL,1:VAL=VALX)
; Return field number from name
FLDNUM(FNUM,FLD) ;EP
Q $S(FLD=+FLD:FLD,FLD="#":0,1:$O(^DD(FNUM,"B",FLD,0)))
; Returns the standard xref for the specified field.
XREF(FNUM,FLD,LAST) ;EP
N XREF
S LAST=+$G(LAST),XREF="",FLD=$$FLDNUM(FNUM,FLD)
Q:'$L(FLD) ""
Q:'FLD "#"
F S LAST=$O(^DD(FNUM,FLD,1,LAST)) Q:'LAST I $D(^(LAST,0)),$P(^(0),U,3)="" S XREF=$P(^(0),U,2) Q
Q XREF
; Returns field # if xref is a standard type, or 0 if not.
XREFFLD(FNUM,XREF) ;EP
N FLD,LAST,X
S FLD=$O(^DD(FNUM,0,"IX",XREF,FNUM,0))
Q:'FLD 0
F S X=$$XREF(FNUM,FLD,.LAST) Q:'$L(X)!(X=XREF)
Q $S($L(X):FLD,1:0)
CIAUDDR ;MSC/IND/DKM - FileMan RPC Extensions ;04-May-2006 08:19;DKM
+1 ;;1.2;CIA UTILITIES;;Mar 20, 2007
+2 ;;Copyright 2000-2006, Medsphere Systems Corporation
+3 ;=================================================================
+4 ; RPC: Retrieve DD information about a file.
+5 ; FNUM = File # or name
+6 ; FLDS = Semi-colon delimited field list (optional)
+7 ; IENS = IENS (for subfile entries)
+8 ; FLGS = Control flags:
+9 ; D = Fix duplicate field names
+10 ; M = Retrieve multiples
+11 ; Return data:
+12 ; DATA(0) = -1^Error text or
+13 ; = File #^File name^Rec count^Field count^Readonly^Parent File
+14 ; DATA(n) = Field #^Field name^Datatype^Size^Required^Readonly^Help lines^Xref^Calculated
+15 ; DATA(n,0) = Supplemental data (set mappings)
+16 ; DATA(n,1) = Prompt Text
+17 ; DATA(n,2) = Help Text
GETDD(DATA,FNUM,FLDS,IENS,FLGS) ;
+1 NEW X,Y,Z,CNT,N0,FLD,PF,MULT,DUPS
+2 SET DATA=$NAME(^TMP("CIAUDDR",$JOB))
+3 KILL @DATA
+4 SET FNUM=$GET(FNUM)
SET FLDS=$GET(FLDS)
SET FLGS=$GET(FLGS)
SET MULT=FLGS["M"
SET DUPS=FLGS["D"
+5 IF $LENGTH(FNUM)
IF FNUM'=+FNUM
Begin DoDot:1
+6 SET FNUM=$ORDER(^DIC("B",FNUM,0))
+7 IF FNUM
IF $ORDER(^(FNUM))
SET FNUM=""
End DoDot:1
+8 SET X=$$ROOT^DILFD(FNUM,$GET(IENS),1)
SET PF=$GET(^DD(+FNUM,0,"UP"))
+9 IF $LENGTH(X)
SET X=$GET(@X@(0))
+10 IF PF
SET $PIECE(X,U)=$PIECE($GET(^DD(+FNUM,0)),U)
+11 IF '$LENGTH(X)
DO SETERR("Table not found")
QUIT
+12 SET N0=FNUM_U_$PIECE(X,U)_U_$PIECE(X,U,4)
SET CNT=0
+13 FOR X=1:1:$LENGTH(FLDS,";")
Begin DoDot:1
+14 SET FLD=$PIECE(FLDS,";",X)
+15 IF '$LENGTH(FLD)
QUIT
+16 IF FLD="*"
SET FLD="0-9999999999999999"
+17 IF $TRANSLATE(FLD,".")?1.N1"-"1.N
Begin DoDot:2
+18 SET Z=+$PIECE(FLD,"-")
SET Y=+$PIECE(FLD,"-",2)
+19 IF Z<0
SET Z=0
+20 IF Z=0
IF '$$GETFL(0,0)
SET X=0
+21 IF Z>0
IF $DATA(^DD(FNUM,Z,0))
IF '$$GETFL(Z,MULT)
SET X=0
+22 FOR
IF 'X
QUIT
SET Z=$ORDER(^DD(FNUM,Z))
IF 'Z
QUIT
IF Z>Y
QUIT
IF '$$GETFL(Z,MULT)
SET X=0
End DoDot:2
+23 IF '$TEST
IF '$$GETFL(FLD,1)
SET X=0
End DoDot:1
IF 'X
QUIT
+24 IF X
SET @DATA@(0)=N0_U_CNT_U_($PIECE($GET(^DD(FNUM,0,"DI")),U,2)["Y")_U_PF
+25 QUIT
+26 ; Setup type info for field
+27 ; FLDX = Field # or name
+28 ; MULT = Allow multiples
+29 ; Note: Datatype (TP) maps to TFMFieldType enum:
+30 ; 0 = unknown, 1 = free text, 2 = numeric, 3 = boolean,
+31 ; 4 = date/time, 5 = wp, 6 = pointer, 7 = set, 8 = subfile
GETFL(FLDX,MULT) ;
+1 NEW X,Z,LN,TP,HC,DD,FLD,MLT,NAM
+2 SET FLD=$$FLDNUM(FNUM,FLDX)
SET MLT=0
+3 SET DD=$SELECT('$LENGTH(FLD):"",FLD:$GET(^DD(FNUM,FLD,0)),1:"#^RICJ8,5")
SET X=$PIECE(DD,U,2)
+4 IF '$LENGTH(DD)
DO SETERR("Field not found: "_FLDX)
QUIT 0
+5 IF X
IF $PIECE($GET(^DD(X,.01,0)),U,2)'["W"
SET MLT=1
+6 IF 'MULT
IF MLT
QUIT 1
+7 SET (LN,TP,HC,Z)=0
SET DX=""
SET NAM=$PIECE(DD,U)
SET CNT=CNT+1
+8 IF DUPS
IF $ORDER(^(+$ORDER(^DD(FNUM,"B",NAM,0))))
SET NAM=NAM_"("_FLD_")"
+9 IF MLT
SET TP=8
SET DX=+X
+10 IF '$TEST
IF X["B"
SET TP=3
+11 IF '$TEST
IF X["D"
SET TP=4
SET DX=$PIECE($PIECE($PIECE(DD,U,5),"%DT=",2),"""",2)
+12 IF '$TEST
IF X["F"!(X["K")
SET TP=1
SET LN=+$PIECE($PIECE(DD,U,5),"$L(X)>",2)
IF 'LN
SET LN=30
+13 IF '$TEST
IF X["J"
SET TP=2
SET DX=$PIECE(X,"J",2)
IF DX'[","
SET LN=DX
SET DX=""
SET TP=1
+14 IF '$TEST
IF X["P"!(X["p")
SET TP=6
SET DX=+$PIECE($TRANSLATE(X,"p","P"),"P",2)
SET LN=$$GETLN(DX)
+15 IF '$TEST
IF X["S"
SET TP=7
SET DX=$PIECE(DD,U,3)
+16 IF '$TEST
IF X=+X
SET TP=5
+17 IF 'FLD
SET HC=1
SET @DATA@(CNT,2,HC)="Internal record number."
+18 IF '$TEST
FOR
SET Z=$ORDER(^DD(FNUM,FLD,21,Z))
IF 'Z
QUIT
SET HC=HC+1
SET @DATA@(CNT,2,HC)=^(Z,0)
+19 SET @DATA@(CNT)=FLD_U_NAM_U_TP_U_LN_U_(X["R")_U_(X["I")_U_HC_U_$$XREF(FNUM,FLD)_U_(X["C")
+20 SET @DATA@(CNT,0)=DX
SET @DATA@(CNT,1)=$GET(^DD(FNUM,FLD,3))
+21 QUIT 1
+22 ; Get length of .01 for file
GETLN(FNUM) ;
+1 NEW DD,X
+2 SET DD=$GET(^DD(FNUM,.01,0))
SET X=$PIECE(DD,U,2)
+3 SET X=+$SELECT(X["P":$$GETLN(+$EXTRACT(X,2,99)),X["F":$PIECE($PIECE(DD,U,5),"$L(X)>",2),1:0)
+4 QUIT $SELECT(X:X,1:30)
SETERR(ERR) ;
+1 KILL @DATA
+2 SET @DATA@(0)="-1^"_ERR
+3 QUIT
+4 ; RPC: CIAUDDR MOVETO
+5 ; Move to specified record (returns IEN only)
+6 ; FNUM: File #
+7 ; IEN : Current IEN
+8 ; DIR : 0 = current; 1 = next; 2 = prior
+9 ; IENS: Subfile IENS
+10 ; SCRN: Screens (optional)
+11 ; INDX: Index (optional)
+12 ; Returns IEN or <error code>^<error text>
MOVETO(DATA,FNUM,IEN,DIR,IENS,SCRN,INDX) ;
+1 NEW GBL,IDX,IDF,OK
+2 SET GBL=$$ROOT^DILFD(FNUM,$GET(IENS),1)
SET DIR=+$GET(DIR)
SET INDX=$GET(INDX)
+3 SET DIR=$SELECT(DIR=1:1,DIR=2:-1,1:0)
+4 IF $LENGTH($GET(SCRN))
SET SCRN(-1)=SCRN
+5 IF '$LENGTH(GBL)
SET DATA="-4^Table not found"
QUIT
+6 IF $LENGTH(INDX)
Begin DoDot:1
+7 IF '$ORDER(^DD(FNUM,0,"IX",INDX,""))
SET DATA="-5^Index "_INDX_" not found"
QUIT
+8 SET IDF=$$XREFFLD(FNUM,INDX)
+9 IF 'IDF
SET DATA="-6^Index "_INDX_" is not a standard index"
QUIT
+10 SET IDX=$SELECT(IEN=-1:"",IEN=-2:$CHAR(255),1:$EXTRACT($$FLDVAL(FNUM,IDF,IEN,GBL),1,30))
End DoDot:1
IF $GET(DATA)
QUIT
+11 IF '$TEST
SET IEN=$SELECT(IEN=-1:0,IEN=-2:$ORDER(@GBL@($CHAR(1)),-1)+1,1:+IEN)
+12 FOR
Begin DoDot:1
+13 SET IEN=+$$NXTIEN
+14 ;S OK=IEN&(IEN\1=IEN)&$D(@GBL@(IEN,0)),SCRN=""
+15 SET OK=IEN&$DATA(@GBL@(IEN,0))
SET SCRN=""
+16 FOR
IF 'OK
QUIT
SET SCRN=$ORDER(SCRN(SCRN))
IF '$LENGTH(SCRN)
QUIT
Begin DoDot:2
+17 NEW Y
+18 SET Y=IEN
+19 IF $DATA(@GBL@(Y,0))
+20 XECUTE SCRN(SCRN)
+21 SET OK=$TEST
End DoDot:2
+22 IF 'OK
IF 'DIR
SET IEN=0
End DoDot:1
IF OK!'IEN
QUIT
+23 SET DATA=$SELECT(OK:IEN,'DIR:"-3^Record not found",DIR=1:"-2^End of file",1:"-1^Beginning of file")
+24 QUIT
+25 ; Return next IEN
NXTIEN() IF 'DIR
QUIT IEN
+1 IF '$LENGTH(INDX)
QUIT $ORDER(@GBL@(IEN),DIR)
+2 NEW OK
+3 FOR
Begin DoDot:1
+4 IF IEN'>0
SET IDX=$ORDER(@GBL@(INDX,IDX),DIR)
SET IEN=""
+5 SET IEN=$SELECT($LENGTH(IDX):$ORDER(@GBL@(INDX,IDX,IEN),DIR),1:0)
+6 ;S OK=$S('IEN:0,1:$E($$FLDVAL(FNUM,IDF,IEN,GBL),1,30)=IDX)
+7 SET OK=$SELECT('IEN:0,1:$DATA(@GBL@(IEN,0)))
End DoDot:1
IF OK!'$LENGTH(IDX)
QUIT
+8 QUIT IEN
+9 ; Return field value (internal)
+10 ; FIL = File or subfile #
+11 ; FLD = Field #
+12 ; IEN = Record #
+13 ; ROOT = Global root of file or subfile, or IENS of subfile
FLDVAL(FIL,FLD,IEN,ROOT) ;
+1 IF FLD=0!(FLD="#")
QUIT IEN
+2 NEW PC,ND,DD
+3 IF FLD'=+FLD
SET FLD=+$ORDER(^DD(FIL,"B",FLD,0))
+4 SET DD=$GET(^DD(FIL,FLD,0))
+5 IF $PIECE(DD,U,2)["C"
QUIT $$GET1^DIQ(FIL,IEN_","_$PIECE(ROOT,",",2,999),FLD,"I")
+6 SET ND=$PIECE(DD,U,4)
SET PC=$PIECE(ND,";",2)
SET ND=$PIECE(ND,";")
+7 IF $EXTRACT(ROOT)'=U
SET ROOT=$$ROOT^DILFD(FIL,ROOT,1)
+8 QUIT $SELECT('$LENGTH(ND):"",1:$PIECE($GET(@ROOT@(IEN,ND)),U,PC))
+9 ; RPC: Lock/unlock a record
+10 ; FNUM = File #
+11 ; IENS = Record # (IENS format)
+12 ; WAIT = If >=0, seconds to wait for lock.
+13 ; If missing or null, perform unlock operation.
+14 ; DATA = Returns 0 if successful, -n^Error Text if not.
LOCK(DATA,FNUM,IENS,WAIT) ;
+1 NEW X,IEN,OK,$ETRAP
+2 SET @$$TRAP^CIAUOS("LOCKERR^CIAUDDR")
+3 SET $ETRAP=""
SET X=$$ROOT^DILFD(FNUM,IENS,1)
SET DATA=0
SET IEN=+IENS
+4 IF '$LENGTH(X)
SET DATA="-1^Table not found"
QUIT
+5 IF $GET(WAIT)=""
KILL WAIT
+6 DO LOCK^CIANBRPC(.OK,$NAME(@X@(IEN)),.WAIT)
+7 IF 'OK
SET DATA="-2^Record locked by another process"
+8 QUIT
LOCKERR SET DATA="-3^Unexpected error"
+1 QUIT
+2 ; RPC: Convert pointer internal<->external
CVTPTR(DATA,FNUM,VAL,EXT) ;
+1 IF EXT
SET DATA=$$GET1^DIQ(FNUM,VAL,.01)
+2 IF '$TEST
Begin DoDot:1
+3 NEW ROOT
+4 SET ROOT=$$ROOT^DILFD(FNUM,,1)
+5 IF '$LENGTH(ROOT)
SET DATA=""
+6 IF '$TEST
IF VAL?1"`"1.N
Begin DoDot:2
+7 SET VAL=+$EXTRACT(VAL,2,999)
SET DATA=$SELECT('VAL:"",$DATA(@ROOT@(VAL,0))#2:VAL,1:"")
End DoDot:2
+8 IF '$TEST
Begin DoDot:2
+9 NEW LP
+10 FOR LP=0:1:3
SET DATA=$$CP(LP)
IF DATA
QUIT
End DoDot:2
End DoDot:1
+11 QUIT
+12 ; Lookup value in "B" xref
CP(XFM) NEW RTN,LKP
+1 SET LKP=$SELECT(XFM#2:$EXTRACT(VAL,1,30),1:VAL)
SET LKP=$SELECT(XFM\2:$$UP^XLFSTR(LKP),1:LKP)
SET RTN=0
+2 FOR
SET RTN=$ORDER(@ROOT@("B",LKP,RTN))
IF 'RTN
QUIT
IF $PIECE($GET(@ROOT@(RTN,0)),U)=VAL
QUIT
+3 QUIT RTN
+4 ; RPC: Find an entry using specified fields and values
+5 ; FNUM = File number to search
+6 ; IENS = IENS for subfile
+7 ; FLGS = Search flags. Combination of:
+8 ; P = partial match
+9 ; I = case insensitive
+10 ; FLDS = Field #'s or names to search. Can be ;-delimited or list.
+11 ; VALS = Values to search. Can be single value or list.
+12 ; MAX = Maximum entries to return (default=all)
+13 ; Returns list of one or all IENs matching criteria or
+14 ; -n^error text if error.
FIND(DATA,FNUM,IENS,FLGS,FLDS,VALS,MAX) ;
+1 NEW ROOT,QUIT,XRF,XKY,CNT,X
+2 SET IENS=$GET(IENS)
+3 IF $LENGTH(IENS)
IF $EXTRACT(IENS)'=","
SET IENS=","_IENS
+4 SET ROOT=$$ROOT^DILFD(FNUM,IENS,1)
SET QUIT=0
SET FLGS=$GET(FLGS)
SET MAX=+$GET(MAX)
SET CNT=0
+5 IF $DATA(VALS)=1
SET VALS(1)=VALS
+6 IF $DATA(FLDS)=1
FOR X=1:1:$LENGTH(FLDS,";")
SET FLDS(X)=$PIECE(FLDS,";",X)
+7 FOR FLDS=0:0
SET FLDS=$ORDER(FLDS(FLDS))
IF 'FLDS
QUIT
Begin DoDot:1
+8 IF '$DATA(VALS(FLDS))
SET QUIT="-1^Not enough lookup values."
QUIT
+9 SET X=$$FLDNUM(FNUM,FLDS(FLDS))
+10 IF '$LENGTH(X)
SET QUIT="-2^Unknown field "_FLDS(FLDS)_"."
QUIT
+11 SET FLDS(FLDS)=X
+12 IF '$DATA(XRF)
Begin DoDot:2
+13 SET X=$$XREF(FNUM,X)
+14 IF $LENGTH(X)
SET XRF=X
SET XKY=$SELECT(FLGS["I":$$UP^XLFSTR(VALS(FLDS)),1:VALS(FLDS))
End DoDot:2
End DoDot:1
IF QUIT
QUIT
+15 IF 'QUIT
IF '$DATA(XRF)
SET QUIT="-3^At least one field must be a key field."
+16 IF 'QUIT
DO FINDX
+17 IF QUIT<0
KILL @DATA
SET @DATA@(0)=QUIT
+18 QUIT
FINDX IF XRF="#"
GOTO FINDN
IF FLGS["P"
GOTO FINDP
GOTO FINDE
+1 ; Find by IEN
FINDN DO FINDF(XKY)
+1 QUIT
+2 ; Find exact match
FINDE NEW XKT,IEN
+1 SET IEN=0
SET XKT=$EXTRACT(XKY,1,30)
+2 FOR
SET IEN=$ORDER(@ROOT@(XRF,XKT,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+3 DO FINDF(IEN)
End DoDot:1
IF QUIT
QUIT
+4 QUIT
+5 ; Partial match
FINDP NEW XKT,VAL,IEN,LEN
+1 SET XKT=$EXTRACT(XKY,1,30)
SET VAL=XKT
SET LEN=$LENGTH(XKT)
+2 FOR
Begin DoDot:1
+3 SET IEN=0
+4 FOR
SET IEN=$ORDER(@ROOT@(XRF,VAL,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+5 DO FINDF(IEN)
End DoDot:2
IF QUIT
QUIT
End DoDot:1
SET VAL=$ORDER(@ROOT@(XRF,VAL))
IF $EXTRACT(VAL,1,LEN)'=XKT!QUIT
QUIT
+6 QUIT
+7 ; Check fields for match. Add to output if all match
FINDF(IEN) ;
+1 NEW FND
+2 SET FLDS=0
SET FND=1
+3 FOR
SET FLDS=$ORDER(FLDS(FLDS))
IF 'FLDS
QUIT
Begin DoDot:1
+4 SET FND=$$FINDM(FLDS(FLDS),VALS(FLDS),IEN)
End DoDot:1
IF 'FND
QUIT
+5 IF FND
Begin DoDot:1
+6 SET CNT=CNT+1
SET @DATA@(CNT)=IEN
+7 IF MAX
IF CNT'<MAX
SET QUIT=1
End DoDot:1
+8 QUIT
+9 ; Check for match
FINDM(FLD,VAL,IEN) ;
+1 NEW VALX
+2 SET VALX=$$FLDVAL(FNUM,FLD,IEN,ROOT)
+3 IF FLGS["I"
SET VAL=$$UP^XLFSTR(VAL)
SET VALX=$$UP^XLFSTR(VALX)
+4 QUIT $SELECT(FLGS["P":$EXTRACT(VALX,1,$LENGTH(VAL))=VAL,1:VAL=VALX)
+5 ; Return field number from name
FLDNUM(FNUM,FLD) ;EP
+1 QUIT $SELECT(FLD=+FLD:FLD,FLD="#":0,1:$ORDER(^DD(FNUM,"B",FLD,0)))
+2 ; Returns the standard xref for the specified field.
XREF(FNUM,FLD,LAST) ;EP
+1 NEW XREF
+2 SET LAST=+$GET(LAST)
SET XREF=""
SET FLD=$$FLDNUM(FNUM,FLD)
+3 IF '$LENGTH(FLD)
QUIT ""
+4 IF 'FLD
QUIT "#"
+5 FOR
SET LAST=$ORDER(^DD(FNUM,FLD,1,LAST))
IF 'LAST
QUIT
IF $DATA(^(LAST,0))
IF $PIECE(^(0),U,3)=""
SET XREF=$PIECE(^(0),U,2)
QUIT
+6 QUIT XREF
+7 ; Returns field # if xref is a standard type, or 0 if not.
XREFFLD(FNUM,XREF) ;EP
+1 NEW FLD,LAST,X
+2 SET FLD=$ORDER(^DD(FNUM,0,"IX",XREF,FNUM,0))
+3 IF 'FLD
QUIT 0
+4 FOR
SET X=$$XREF(FNUM,FLD,.LAST)
IF '$LENGTH(X)!(X=XREF)
QUIT
+5 QUIT $SELECT($LENGTH(X):FLD,1:0)
