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

DICUIX1.m

Go to the documentation of this file. 
  1. DICUIX1 ;SF/TOAD/TKW-FileMan: Lookup Tools, Indexes (called by DICUIX) ;4/13/00  13:40 [ 04/02/2003   8:25 AM ]
  1.  ;;22.0;VA FileMan;**1001**;APR 1, 2003
  1.  ;;22.0;VA FileMan;**4,28,3**;Mar 30, 1999;
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1. GET(DITOP,DIFILE,DIFIELD,DIDEF,DICODE) ;
  1.  ; get the definition and fetch code for a field
  1.  ;
  1. G1 ; handle .001 fields, fetch field definition, & handle undefineds
  1.  ;
  1.  I DIFIELD=.001 S DICODE="DIEN",DIDEF="" Q
  1.  S DIDEF=$G(^DD(DIFILE,DIFIELD,0)),DICODE=""
  1.  I DIDEF="" D ERR^DICU1(501,DIFILE,"","",DIFIELD) Q
  1.  ;
  1. G2 ; piece out the fields data type, & handle multiples and WPs
  1.  ;
  1.  N DITYPE S DITYPE=$P(DIDEF,U,2)
  1.  I DITYPE D  Q
  1.  . I $P($G(^DD(+DITYPE,.01,0)),U,2)["W" S DITYPE="Word-processing"
  1.  . E  S DITYPE="Multiple"
  1.  . D ERR^DICU1(520,DIFILE,"",DIFIELD,DITYPE)
  1.  ;
  1. G3 ; handle computed fields
  1.  ;
  1.  I DITYPE["C" D  Q
  1.  . S DICODE=$P(DIDEF,U,5,9999)
  1.  . S DIDEF=$P(DIDEF,U,1,4)
  1.  ;
  1. G30 ; Handle whole file x-refs
  1.  I DIFILE'=DITOP S DICODE="DINDEX(DISUB)" Q
  1. G4 ; get field's storage location, handle ?, build node fetch code
  1.  ;
  1.  N DISTORE S DISTORE=$P(DIDEF,U,4)
  1.  N DINODE S DINODE=$P(DISTORE,";")
  1.  N DIPIECE S DIPIECE=$P(DISTORE,";",2)
  1.  I DINODE="",$P(DIPIECE,"E")'="",'DIPIECE S (DICODE,DIDEF)="" Q
  1.  I DINODE=0,DIFILE=DITOP S DINODE="DI0NODE"
  1.  E  S DINODE="$G(@DIFILE(DIFILE)@(+DIEN,"""_DINODE_"""))"
  1.  ;
  1. G5 ; build field fetch code (piece or extract) & quit
  1.  ;
  1.  I DIPIECE S DICODE="$P("_DINODE_",U,"_DIPIECE_")"
  1.  E  D
  1.  . N DIEFROM S DIEFROM=$P($E(DIPIECE,2,9999),",")
  1.  . N DIETO S DIETO=$P(DIPIECE,",",2)
  1.  . S DICODE="$E("_DINODE_","_DIEFROM_","_DIETO_")"
  1.  Q
  1.  ;
  1. FIELD(DIFILE,DIFIELD,DINDEX) ;
  1.  ;
  1.  ; return code to fetch field value prior to screen execution
  1.  ;
  1. F1 ; handle .01 & computeds, build node expression
  1.  ;
  1.  I DIFIELD=.01 Q "DINDEX(1)"
  1.  N DISTORE S DISTORE=$P(DINDEX(1,"DEF"),U,4)
  1.  N DINODE S DINODE=$P(DISTORE,";")
  1.  N DIPIECE S DIPIECE=$P(DISTORE,";",2)
  1.  I 'DINODE,$P(DIPIECE,"E")'="",'DIPIECE Q "X"
  1.  I DINODE=0 S DINODE="DI0NODE"
  1.  E  S DINODE="$G(@DIFILE(DIFILE)@(+DIEN,"""_DINODE_"""))"
  1.  ;
  1. F2 ; build fetch code from node expression
  1.  ;
  1.  N DICODE
  1.  I DIPIECE S DICODE="$P("_DINODE_",U,"_DIPIECE_")"
  1.  E  D
  1.  . N DIEFROM S DIEFROM=$P($E(DIPIECE,2,9999),",")
  1.  . N DIETO S DIETO=$P(DIPIECE,",",2)
  1.  . S DICODE="$E("_DINODE_","_DIEFROM_","_DIETO_")"
  1.  Q DICODE
  1.  ;
  1. GETTMP(DITEMP,DISUB) ; Return name of unique entry in ^TMP global.
  1.  I $G(DISUB(1))']"" S DISUB(1)=$G(DISUB)
  1.  N I S DITEMP="^TMP("
  1.  F I=0:0 S I=$O(DISUB(I)) Q:'I  I DISUB(I)]"" D
  1.  . N X S X=DISUB(I) I +$P(X,"E")'=X S X=""""_X_""""
  1.  . S DITEMP=DITEMP_X_","
  1.  N DIKJ,J
  1.  F DIKJ=$J:.01 S J=DITEMP_DIKJ_")" I '$D(@J) L +@J Q
  1.  S @J="",DITEMP=J L -@J Q
  1.  ;
  1. TMPB(DITEMP,DIFILE) ; Set place for temporary "B" index on file
  1.  N DISUB S DISUB(1)="DICLB",DISUB(2)=DIFILE
  1.  D GETTMP(.DITEMP,.DISUB)
  1.  S DITEMP=$E(DITEMP,1,($L(DITEMP)-1)) Q
  1.  ;
  1. BLDB(DIROOT,DITEMP) ; Build temporary "B" index on file
  1.  N DIENTRY,DIVALUE S DIENTRY=0,DITEMP=DITEMP_")"
  1.  F  S DIENTRY=$O(@DIROOT@(DIENTRY)) Q:'DIENTRY  D
  1.  . S DIVALUE=$P($G(@DIROOT@(DIENTRY,0)),U) Q:DIVALUE=""
  1.  . S @DITEMP@(DIVALUE,DIENTRY)=""
  1.  . Q
  1.  Q
  1.  ;
  1. TMPIDX(DISUB,DITEMP,DITEMP2,DINDEX) ; Set data to build temporary index on Lister call with Pointer/VP in index.
  1.  S DITEMP2=DITEMP
  1.  D GETTMP^DICUIX1(.DITEMP,"DICL")
  1.  S DITEMP=$E(DITEMP,1,($L(DITEMP)-1))
  1.  S DINDEX("ROOTCNG",DISUB)=""
  1.  Q
  1.  ;
  1. CHKP(DIFILE,DINDEX,DINUMBER,DIFRPRT,DISCREEN,DICQ1) ; Check whether to build temporary index on Lister call with Pointer/VP in first subscript of index.
  1.  N DIN1,DIN2,X,I,D S DIN2=0
  1.  S DIN1=+$P($G(@DIFILE(DIFILE)@(0)),U,4)
  1.  N DIF,DIVPTR M DIF=DIFILE S DIVPTR=$S(DINDEX(1,"TYPE")="V":1,1:0)
  1.  D FOLLOW^DICL3(.DIF,"",DINDEX(1,"NODE"),1,0,"",DINDEX(1,"FIELD"),DINDEX(1,"FILE"),DIVPTR,1,.DISCREEN)
  1.  F I=1:1 S X=+$P($G(DIF("STACKEND",I)),U,2) Q:'X  D
  1.  . S X=$G(^DIC(X,0,"GL")) Q:X=""  S X=$G(@(X_"0)"))
  1.  . S DIN2=DIN2+$P(X,U,4)
  1.  S D=1 D
  1.  . N F1,F2 S F1=DINDEX(1,"FILE"),F2=DINDEX(1,"FIELD")
  1.  . I 'DIVPTR S I=$P($G(^DD(F1,F2,0)),U,2) S:I["*" D=.5 Q
  1.  . F I=0:0 S I=$O(^DD(F1,F2,"V",I)) Q:'I  I $G(^(I,1))]"" S D=.5 Q
  1.  . S D=D*.5 Q
  1.  S DIN2=$S(DINUMBER!(DIFRPRT]""):DIN2/(40*D),1:DIN2/(20*D))
  1.  I $G(DICQ1),DIFRPRT]"" S DIN2=DIN2/2
  1.  I DIN2>DIN1,DIN1>500,'$G(DICQ1) Q 0
  1.  Q DIN2>DIN1
  1.  ;