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

CIAUDDR.m

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