DICUIX1 ;SF/TOAD/TKW-FileMan: Lookup Tools, Indexes (called by DICUIX) ;4JUL2008
;;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.
;
GET(DITOP,DIFILE,DIFIELD,DIDEF,DICODE) ;
; get the definition and fetch code for a field
;
G1 ; handle .001 fields, fetch field definition, & handle undefineds
;
I DIFIELD=.001 S DICODE="DIEN",DIDEF="" Q
S DIDEF=$G(^DD(DIFILE,DIFIELD,0)),DICODE=""
I DIDEF="" D ERR^DICU1(501,DIFILE,"","",DIFIELD) Q
;
G2 ; piece out the fields data type, & handle multiples and WPs
;
N DITYPE S DITYPE=$P(DIDEF,U,2)
I DITYPE D Q
. I $P($G(^DD(+DITYPE,.01,0)),U,2)["W" S DITYPE="Word-processing"
. E S DITYPE="Multiple"
. D ERR^DICU1(520,DIFILE,"",DIFIELD,DITYPE)
;
G3 ; handle computed fields
;
I DITYPE["C" D Q
.I DITYPE["m" D ERR^DICU1(520,DIFILE,"",DIFIELD,"Multiple Computed") Q ;**GFT
. S DICODE=$P(DIDEF,U,5,9999)
. S DIDEF=$P(DIDEF,U,1,4)
;
G30 ; Handle whole file x-refs
I DIFILE'=DITOP S DICODE="DINDEX(DISUB)" Q
G4 ; get field's storage location, handle ?, build node fetch code
;
N DISTORE S DISTORE=$P(DIDEF,U,4)
N DINODE S DINODE=$P(DISTORE,";")
N DIPIECE S DIPIECE=$P(DISTORE,";",2)
I DINODE="",$P(DIPIECE,"E")'="",'DIPIECE S (DICODE,DIDEF)="" Q
I DINODE=0,DIFILE=DITOP S DINODE="DI0NODE"
E S DINODE="$G(@DIFILE(DIFILE)@(+DIEN,"""_DINODE_"""))"
;
G5 ; build field fetch code (piece or extract) & quit
;
I DIPIECE S DICODE="$P("_DINODE_",U,"_DIPIECE_")"
E D
. N DIEFROM S DIEFROM=$P($E(DIPIECE,2,9999),",")
. N DIETO S DIETO=$P(DIPIECE,",",2)
. S DICODE="$E("_DINODE_","_DIEFROM_","_DIETO_")"
Q
;
FIELD(DIFILE,DIFIELD,DINDEX) ;
;
; return code to fetch field value prior to screen execution
;
F1 ; handle .01 & computeds, build node expression
;
I DIFIELD=.01 Q "DINDEX(1)"
N DISTORE S DISTORE=$P(DINDEX(1,"DEF"),U,4)
N DINODE S DINODE=$P(DISTORE,";")
N DIPIECE S DIPIECE=$P(DISTORE,";",2)
I 'DINODE,$P(DIPIECE,"E")'="",'DIPIECE Q "X"
I DINODE=0 S DINODE="DI0NODE"
E S DINODE="$G(@DIFILE(DIFILE)@(+DIEN,"""_DINODE_"""))"
;
F2 ; build fetch code from node expression
;
N DICODE
I DIPIECE S DICODE="$P("_DINODE_",U,"_DIPIECE_")"
E D
. N DIEFROM S DIEFROM=$P($E(DIPIECE,2,9999),",")
. N DIETO S DIETO=$P(DIPIECE,",",2)
. S DICODE="$E("_DINODE_","_DIEFROM_","_DIETO_")"
Q DICODE
;
GETTMP(DITEMP,DISUB) ; Return name of unique entry in ^TMP global.
I $G(DISUB(1))']"" S DISUB(1)=$G(DISUB)
N I S DITEMP="^TMP("
F I=0:0 S I=$O(DISUB(I)) Q:'I I DISUB(I)]"" D
. N X S X=DISUB(I) I +$P(X,"E")'=X S X=""""_X_""""
. S DITEMP=DITEMP_X_","
N DIKJ,J
F DIKJ=$J:.01 S J=DITEMP_DIKJ_")" I '$D(@J) L +@J Q
S @J="",DITEMP=J L -@J Q
;
TMPB(DITEMP,DIFILE) ; Set place for temporary "B" index on file
N DISUB S DISUB(1)="DICLB",DISUB(2)=DIFILE
D GETTMP(.DITEMP,.DISUB)
S DITEMP=$E(DITEMP,1,($L(DITEMP)-1)) Q
;
BLDB(DIROOT,DITEMP) ; Build temporary "B" index on file
N DIENTRY,DIVALUE S DIENTRY=0,DITEMP=DITEMP_")"
F S DIENTRY=$O(@DIROOT@(DIENTRY)) Q:'DIENTRY D
. S DIVALUE=$P($G(@DIROOT@(DIENTRY,0)),U) Q:DIVALUE=""
. S @DITEMP@(DIVALUE,DIENTRY)=""
. Q
Q
;
TMPIDX(DISUB,DITEMP,DITEMP2,DINDEX) ; Set data to build temporary index on Lister call with Pointer/VP in index.
S DITEMP2=DITEMP
D GETTMP^DICUIX1(.DITEMP,"DICL")
S DITEMP=$E(DITEMP,1,($L(DITEMP)-1))
S DINDEX("ROOTCNG",DISUB)=""
Q
;
CHKP(DIFILE,DINDEX,DINUMBER,DIFRPRT,DISCREEN,DICQ1) ; Check whether to build temporary index on Lister call with Pointer/VP in first subscript of index.
N DIN1,DIN2,X,I,D S DIN2=0
S DIN1=+$P($G(@DIFILE(DIFILE)@(0)),U,4)
N DIF,DIVPTR M DIF=DIFILE S DIVPTR=$S(DINDEX(1,"TYPE")="V":1,1:0)
D FOLLOW^DICL3(.DIF,"",DINDEX(1,"NODE"),1,0,"",DINDEX(1,"FIELD"),DINDEX(1,"FILE"),DIVPTR,1,.DISCREEN)
F I=1:1 S X=+$P($G(DIF("STACKEND",I)),U,2) Q:'X D
. S X=$G(^DIC(X,0,"GL")) Q:X="" S X=$G(@(X_"0)"))
. S DIN2=DIN2+$P(X,U,4)
S D=1 D
. N F1,F2 S F1=DINDEX(1,"FILE"),F2=DINDEX(1,"FIELD")
. I 'DIVPTR S I=$P($G(^DD(F1,F2,0)),U,2) S:I["*" D=.5 Q
. F I=0:0 S I=$O(^DD(F1,F2,"V",I)) Q:'I I $G(^(I,1))]"" S D=.5 Q
. S D=D*.5 Q
S DIN2=$S(DINUMBER!(DIFRPRT]""):DIN2/(40*D),1:DIN2/(20*D))
I $G(DICQ1),DIFRPRT]"" S DIN2=DIN2/2
I DIN2>DIN1,DIN1>500,'$G(DICQ1) Q 0
Q DIN2>DIN1
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICUIX1 4539 printed Dec 13, 2024@02:46:44 Page 2
DICUIX1 ;SF/TOAD/TKW-FileMan: Lookup Tools, Indexes (called by DICUIX) ;4JUL2008
+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 ;
GET(DITOP,DIFILE,DIFIELD,DIDEF,DICODE) ;
+1 ; get the definition and fetch code for a field
+2 ;
G1 ; handle .001 fields, fetch field definition, & handle undefineds
+1 ;
+2 IF DIFIELD=.001
SET DICODE="DIEN"
SET DIDEF=""
QUIT
+3 SET DIDEF=$GET(^DD(DIFILE,DIFIELD,0))
SET DICODE=""
+4 IF DIDEF=""
DO ERR^DICU1(501,DIFILE,"","",DIFIELD)
QUIT
+5 ;
G2 ; piece out the fields data type, & handle multiples and WPs
+1 ;
+2 NEW DITYPE
SET DITYPE=$PIECE(DIDEF,U,2)
+3 IF DITYPE
Begin DoDot:1
+4 IF $PIECE($GET(^DD(+DITYPE,.01,0)),U,2)["W"
SET DITYPE="Word-processing"
+5 IF '$TEST
SET DITYPE="Multiple"
+6 DO ERR^DICU1(520,DIFILE,"",DIFIELD,DITYPE)
End DoDot:1
QUIT
+7 ;
G3 ; handle computed fields
+1 ;
+2 IF DITYPE["C"
Begin DoDot:1
+3 ;**GFT
IF DITYPE["m"
DO ERR^DICU1(520,DIFILE,"",DIFIELD,"Multiple Computed")
QUIT
+4 SET DICODE=$PIECE(DIDEF,U,5,9999)
+5 SET DIDEF=$PIECE(DIDEF,U,1,4)
End DoDot:1
QUIT
+6 ;
G30 ; Handle whole file x-refs
+1 IF DIFILE'=DITOP
SET DICODE="DINDEX(DISUB)"
QUIT
G4 ; get field's storage location, handle ?, build node fetch code
+1 ;
+2 NEW DISTORE
SET DISTORE=$PIECE(DIDEF,U,4)
+3 NEW DINODE
SET DINODE=$PIECE(DISTORE,";")
+4 NEW DIPIECE
SET DIPIECE=$PIECE(DISTORE,";",2)
+5 IF DINODE=""
IF $PIECE(DIPIECE,"E")'=""
IF 'DIPIECE
SET (DICODE,DIDEF)=""
QUIT
+6 IF DINODE=0
IF DIFILE=DITOP
SET DINODE="DI0NODE"
+7 IF '$TEST
SET DINODE="$G(@DIFILE(DIFILE)@(+DIEN,"""_DINODE_"""))"
+8 ;
G5 ; build field fetch code (piece or extract) & quit
+1 ;
+2 IF DIPIECE
SET DICODE="$P("_DINODE_",U,"_DIPIECE_")"
+3 IF '$TEST
Begin DoDot:1
+4 NEW DIEFROM
SET DIEFROM=$PIECE($EXTRACT(DIPIECE,2,9999),",")
+5 NEW DIETO
SET DIETO=$PIECE(DIPIECE,",",2)
+6 SET DICODE="$E("_DINODE_","_DIEFROM_","_DIETO_")"
End DoDot:1
+7 QUIT
+8 ;
FIELD(DIFILE,DIFIELD,DINDEX) ;
+1 ;
+2 ; return code to fetch field value prior to screen execution
+3 ;
F1 ; handle .01 & computeds, build node expression
+1 ;
+2 IF DIFIELD=.01
QUIT "DINDEX(1)"
+3 NEW DISTORE
SET DISTORE=$PIECE(DINDEX(1,"DEF"),U,4)
+4 NEW DINODE
SET DINODE=$PIECE(DISTORE,";")
+5 NEW DIPIECE
SET DIPIECE=$PIECE(DISTORE,";",2)
+6 IF 'DINODE
IF $PIECE(DIPIECE,"E")'=""
IF 'DIPIECE
QUIT "X"
+7 IF DINODE=0
SET DINODE="DI0NODE"
+8 IF '$TEST
SET DINODE="$G(@DIFILE(DIFILE)@(+DIEN,"""_DINODE_"""))"
+9 ;
F2 ; build fetch code from node expression
+1 ;
+2 NEW DICODE
+3 IF DIPIECE
SET DICODE="$P("_DINODE_",U,"_DIPIECE_")"
+4 IF '$TEST
Begin DoDot:1
+5 NEW DIEFROM
SET DIEFROM=$PIECE($EXTRACT(DIPIECE,2,9999),",")
+6 NEW DIETO
SET DIETO=$PIECE(DIPIECE,",",2)
+7 SET DICODE="$E("_DINODE_","_DIEFROM_","_DIETO_")"
End DoDot:1
+8 QUIT DICODE
+9 ;
GETTMP(DITEMP,DISUB) ; Return name of unique entry in ^TMP global.
+1 IF $GET(DISUB(1))']""
SET DISUB(1)=$GET(DISUB)
+2 NEW I
SET DITEMP="^TMP("
+3 FOR I=0:0
SET I=$ORDER(DISUB(I))
if 'I
QUIT
IF DISUB(I)]""
Begin DoDot:1
+4 NEW X
SET X=DISUB(I)
IF +$PIECE(X,"E")'=X
SET X=""""_X_""""
+5 SET DITEMP=DITEMP_X_","
End DoDot:1
+6 NEW DIKJ,J
+7 FOR DIKJ=$JOB:.01
SET J=DITEMP_DIKJ_")"
IF '$DATA(@J)
LOCK +@J
QUIT
+8 SET @J=""
SET DITEMP=J
LOCK -@J
QUIT
+9 ;
TMPB(DITEMP,DIFILE) ; Set place for temporary "B" index on file
+1 NEW DISUB
SET DISUB(1)="DICLB"
SET DISUB(2)=DIFILE
+2 DO GETTMP(.DITEMP,.DISUB)
+3 SET DITEMP=$EXTRACT(DITEMP,1,($LENGTH(DITEMP)-1))
QUIT
+4 ;
BLDB(DIROOT,DITEMP) ; Build temporary "B" index on file
+1 NEW DIENTRY,DIVALUE
SET DIENTRY=0
SET DITEMP=DITEMP_")"
+2 FOR
SET DIENTRY=$ORDER(@DIROOT@(DIENTRY))
if 'DIENTRY
QUIT
Begin DoDot:1
+3 SET DIVALUE=$PIECE($GET(@DIROOT@(DIENTRY,0)),U)
if DIVALUE=""
QUIT
+4 SET @DITEMP@(DIVALUE,DIENTRY)=""
+5 QUIT
End DoDot:1
+6 QUIT
+7 ;
TMPIDX(DISUB,DITEMP,DITEMP2,DINDEX) ; Set data to build temporary index on Lister call with Pointer/VP in index.
+1 SET DITEMP2=DITEMP
+2 DO GETTMP^DICUIX1(.DITEMP,"DICL")
+3 SET DITEMP=$EXTRACT(DITEMP,1,($LENGTH(DITEMP)-1))
+4 SET DINDEX("ROOTCNG",DISUB)=""
+5 QUIT
+6 ;
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 NEW DIN1,DIN2,X,I,D
SET DIN2=0
+2 SET DIN1=+$PIECE($GET(@DIFILE(DIFILE)@(0)),U,4)
+3 NEW DIF,DIVPTR
MERGE DIF=DIFILE
SET DIVPTR=$SELECT(DINDEX(1,"TYPE")="V":1,1:0)
+4 DO FOLLOW^DICL3(.DIF,"",DINDEX(1,"NODE"),1,0,"",DINDEX(1,"FIELD"),DINDEX(1,"FILE"),DIVPTR,1,.DISCREEN)
+5 FOR I=1:1
SET X=+$PIECE($GET(DIF("STACKEND",I)),U,2)
if 'X
QUIT
Begin DoDot:1
+6 SET X=$GET(^DIC(X,0,"GL"))
if X=""
QUIT
SET X=$GET(@(X_"0)"))
+7 SET DIN2=DIN2+$PIECE(X,U,4)
End DoDot:1
+8 SET D=1
Begin DoDot:1
+9 NEW F1,F2
SET F1=DINDEX(1,"FILE")
SET F2=DINDEX(1,"FIELD")
+10 IF 'DIVPTR
SET I=$PIECE($GET(^DD(F1,F2,0)),U,2)
if I["*"
SET D=.5
QUIT
+11 FOR I=0:0
SET I=$ORDER(^DD(F1,F2,"V",I))
if 'I
QUIT
IF $GET(^(I,1))]""
SET D=.5
QUIT
+12 SET D=D*.5
QUIT
End DoDot:1
+13 SET DIN2=$SELECT(DINUMBER!(DIFRPRT]""):DIN2/(40*D),1:DIN2/(20*D))
+14 IF $GET(DICQ1)
IF DIFRPRT]""
SET DIN2=DIN2/2
+15 IF DIN2>DIN1
IF DIN1>500
IF '$GET(DICQ1)
QUIT 0
+16 QUIT DIN2>DIN1
+17 ;
