DIC4 ;SFISC/TKW-VA FileMan Lookup utilities ;5:59 AM 20 Sep 2002
;;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.
;
EXACT ; Find next exact match on a compound index
N DIFLAGS,DIFIELDS,DIWRITE,DIIENS,DIFORCE,DIERR,DISCR,DIQUIET,DIIX
S DIFLAGS="lX" D GETPAR N DINDEX
D FIND^DICF(.DIFILEI,DIIENS,DIFIELDS,DIFLAGS,.DIVAL,"*",.DIFORCE,.DISCR,$G(DIC("W")),"DS","DIERR",.DIIX,.DIC,.DIY,.DIYX)
D:$G(DIERR) PROCERR Q
;
PARTIAL ; Find next partial match on a compound index
N DIFLAGS,DIFIELDS,DIWRITE,DIIENS,DIFORCE,DIERR,DISCR,DIQUIET,DIIX
S DIFLAGS="l" D GETPAR K DIIX("DONE") N DINDEX
I DIFLAGS'["Q",$G(DS("INT"))]"","VP"[DIIX(1,"TYPE") N I M I=DIVAL N DIVAL D
. S (I,I(1),DIIX(1),DIIX(1,"FROM"),DIIX(1,"PART"))=DS("INT")
. S DIIX(1,"TYPE")="F" M DIVAL=I K I Q
D FIND^DICF(.DIFILEI,DIIENS,DIFIELDS,DIFLAGS,.DIVAL,"*",.DIFORCE,.DISCR,$G(DIC("W")),"DS","DIERR",.DIIX,.DIC,.DIY,.DIYX)
D:$G(DIERR) PROCERR Q
;
SET I $P(DS(0),U,2) D SETY Q
S Y=-1 Q:'DS(0) D SETOUT Q
;
SETOUT ; Set variables if user up-arrowed or timed out.
S Y=-1 N I S I=$P(DS(0),U,2)
I I="U",DIC(0)'["A" S DUOUT=1
S:I="T" DTOUT=1 Q
;
SETY ; If entry was selected by user, set output variables.
S Y=DS(0,"Y")
S:$D(DDS) DST=DS(0,"DST")
S (X,X(1))=DS(0,"X"),DIYX=DS(0,"DIYX"),DIY=DS(0,"DIY")
N % S:$G(DIX)]"" %=DIX M DIX=DS(0,1) K DS(0),DIX("F") S:$D(%) DIX=%
D GOT^DIC2 I Y<0 S DS(0)="1^" Q
S DS(0)="1^"_+Y Q
;
GETPAR ; Set parameters for Finder call
D:DIFLAGS'["Q"
. N I S I=0 I $A(X)=34,X?.E1"""" S I=1
. I I!(DIC(0)["U")!(DIC(0)["M")!($G(DICR)) S DIFLAGS=DIFLAGS_"Q"
. Q
S DIIENS=$S(DIC(0)["p":",",1:DIENS)
I DIC(0)'["E" S DIQUIET=1
S (DIFORCE,DIFORCE(1))=1,DIFORCE(0)=DINDEX
I $D(DIC("PTRIX")) M DIFORCE("PTRIX")=DIC("PTRIX")
D:$G(DIC("S"))]""
. M DISCR("S")=DIC("S")
. S I="S" F S I=$O(DIC(I)) Q:$E(I)'="S" S DISCR(I)=DIC(I)
. Q
I $D(DIC("V"))]"" M DISCR("V")=DIC("V")
S DIFIELDS="@" M DIIX=DINDEX Q
;
ADDIX(DIFILEI,Y,DINDEX,DIX,DISCREEN) ; Put index values into DIX variable for display
N DISUB,DIVAL,DI0NODE,DIFILE S DI0NODE=$G(@DIFILEI(DIFILEI)@(Y,0)),DIX(1)="" M DIFILE=DIFILEI
I $G(DINDEX("OLDSUB")) N DIO,DIN S DIN=0 F DIO=1:1:DINDEX("OLDSUB") D
. S DIVAL=""
. I $G(DISCREEN("X",DIO,"GET"))]"" D
. . X DISCREEN("X",DIO,"GET") Q
. E S DIN=$O(DINDEX(DIN)) I DIN,DIN'>DINDEX("#") S DISUB=DIN D GETVAL
. S:DIVAL]"" DIX(DIO)=DIVAL Q
Q:$G(DINDEX("OLDSUB"))
F DISUB=1:1:DINDEX("#") D GETVAL S:DIVAL]"" DIX(DISUB)=DIVAL
Q
GETVAL ; Return index value in DIVAL
I $G(DINDEX(DISUB,"TRANOUT"))]"" D Q
. S DIVAL=DINDEX(DISUB) Q:DIVAL="" N X S X=DIVAL
. X DINDEX(DISUB,"TRANOUT") S:X]"" DIVAL=X Q
S @DINDEX(DISUB,"GET") Q:DIVAL=""
I "VPSD"[DINDEX(DISUB,"TYPE")!(DISUB=1&($G(DS("INT"))]"")) D
. I DISUB>1,"VP"[DINDEX(DISUB,"TYPE") Q
. S DIVAL=$$EXT^DIC2(DINDEX(DISUB,"FILE"),DINDEX(DISUB,"FIELD"),DIVAL) Q
Q
;
IXCHK(DIFILEI,DINDEX,DIOK,DIALLVAL,DIVAL,DID) ; Build INDEX info, make sure indexed field not a pointer.
S DIOK=0 N DIVALX S DIVALX=$G(DIVAL(1))
N DIXIEN S DIXIEN=+$O(^DD("IX","BB",DIFILEI,DINDEX,""))
I DIXIEN,$G(DID)="",$P($G(^DD("IX",DIXIEN,0)),U,14)'["L" Q
I 'DIXIEN!('$O(^DD("IX",DIXIEN,11.1,"AC",1))) D Q
. N DIFLAGS S DIFLAGS="hql" S:$G(DILONGX)!(DIC(0)["T") DIFLAGS="4l"
. I +$P(DIVALX,"E")=DIVALX,DIC(0)["E" S DIFLAGS="4l"
. D INDEX^DICUIX(.DIFILEI,DIFLAGS,.DINDEX)
. I +$P(DIVALX,"E")=DIVALX,$G(DINDEX(1,"TYPE"))="P" D Q ;22*70 IGNORE POINTERS IF YOU ARE LOOKING UP A NUMBER VALUE!!
. .I DIC(0)["T",DIC(0)["E" S (DIOK,DIOK("T"))=1 ;22*70
. S DIOK=1 Q
D INDEX^DICUIX(.DIFILEI,"4l",.DINDEX,"",.DIVAL)
S (DIALLVAL,DIOK)=1
N I F I=1:1:DINDEX("#") S:$G(DINDEX(I,"PART"))="" DIALLVAL=0
Q
;
PROCERR ; Display errors generated from call to Finder.
I DIC(0)'["E" K DIERR Q
W $C(7) W:'$D(DDS) !
N A1,DDH,I,J S DDH=0
F I=1:1:+DIERR F J=0:0 S J=$O(DIERR("DIERR",I,"TEXT",J)) Q:'J D
. I '$D(DDS) W DIERR("DIERR",I,"TEXT",J),! Q
. S DDH=DDH+1,DDH(DDH)=DIERR("DIERR",I,"TEXT",J) Q
K DIERR I '$D(DDS) W !! Q
S A1="T" D LIST^DDSU Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIC4 4338 printed Oct 16, 2024@18:45:55 Page 2
DIC4 ;SFISC/TKW-VA FileMan Lookup utilities ;5:59 AM 20 Sep 2002
+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 ;
EXACT ; Find next exact match on a compound index
+1 NEW DIFLAGS,DIFIELDS,DIWRITE,DIIENS,DIFORCE,DIERR,DISCR,DIQUIET,DIIX
+2 SET DIFLAGS="lX"
DO GETPAR
NEW DINDEX
+3 DO FIND^DICF(.DIFILEI,DIIENS,DIFIELDS,DIFLAGS,.DIVAL,"*",.DIFORCE,.DISCR,$GET(DIC("W")),"DS","DIERR",.DIIX,.DIC,.DIY,.DIYX)
+4 if $GET(DIERR)
DO PROCERR
QUIT
+5 ;
PARTIAL ; Find next partial match on a compound index
+1 NEW DIFLAGS,DIFIELDS,DIWRITE,DIIENS,DIFORCE,DIERR,DISCR,DIQUIET,DIIX
+2 SET DIFLAGS="l"
DO GETPAR
KILL DIIX("DONE")
NEW DINDEX
+3 IF DIFLAGS'["Q"
IF $GET(DS("INT"))]""
IF "VP"[DIIX(1,"TYPE")
NEW I
MERGE I=DIVAL
NEW DIVAL
Begin DoDot:1
+4 SET (I,I(1),DIIX(1),DIIX(1,"FROM"),DIIX(1,"PART"))=DS("INT")
+5 SET DIIX(1,"TYPE")="F"
MERGE DIVAL=I
KILL I
QUIT
End DoDot:1
+6 DO FIND^DICF(.DIFILEI,DIIENS,DIFIELDS,DIFLAGS,.DIVAL,"*",.DIFORCE,.DISCR,$GET(DIC("W")),"DS","DIERR",.DIIX,.DIC,.DIY,.DIYX)
+7 if $GET(DIERR)
DO PROCERR
QUIT
+8 ;
SET IF $PIECE(DS(0),U,2)
DO SETY
QUIT
+1 SET Y=-1
if 'DS(0)
QUIT
DO SETOUT
QUIT
+2 ;
SETOUT ; Set variables if user up-arrowed or timed out.
+1 SET Y=-1
NEW I
SET I=$PIECE(DS(0),U,2)
+2 IF I="U"
IF DIC(0)'["A"
SET DUOUT=1
+3 if I="T"
SET DTOUT=1
QUIT
+4 ;
SETY ; If entry was selected by user, set output variables.
+1 SET Y=DS(0,"Y")
+2 if $DATA(DDS)
SET DST=DS(0,"DST")
+3 SET (X,X(1))=DS(0,"X")
SET DIYX=DS(0,"DIYX")
SET DIY=DS(0,"DIY")
+4 NEW %
if $GET(DIX)]""
SET %=DIX
MERGE DIX=DS(0,1)
KILL DS(0),DIX("F")
if $DATA(%)
SET DIX=%
+5 DO GOT^DIC2
IF Y<0
SET DS(0)="1^"
QUIT
+6 SET DS(0)="1^"_+Y
QUIT
+7 ;
GETPAR ; Set parameters for Finder call
+1 if DIFLAGS'["Q"
Begin DoDot:1
+2 NEW I
SET I=0
IF $ASCII(X)=34
IF X?.E1""""
SET I=1
+3 IF I!(DIC(0)["U")!(DIC(0)["M")!($GET(DICR))
SET DIFLAGS=DIFLAGS_"Q"
+4 QUIT
End DoDot:1
+5 SET DIIENS=$SELECT(DIC(0)["p":",",1:DIENS)
+6 IF DIC(0)'["E"
SET DIQUIET=1
+7 SET (DIFORCE,DIFORCE(1))=1
SET DIFORCE(0)=DINDEX
+8 IF $DATA(DIC("PTRIX"))
MERGE DIFORCE("PTRIX")=DIC("PTRIX")
+9 if $GET(DIC("S"))]""
Begin DoDot:1
+10 MERGE DISCR("S")=DIC("S")
+11 SET I="S"
FOR
SET I=$ORDER(DIC(I))
if $EXTRACT(I)'="S"
QUIT
SET DISCR(I)=DIC(I)
+12 QUIT
End DoDot:1
+13 IF $DATA(DIC("V"))]""
MERGE DISCR("V")=DIC("V")
+14 SET DIFIELDS="@"
MERGE DIIX=DINDEX
QUIT
+15 ;
ADDIX(DIFILEI,Y,DINDEX,DIX,DISCREEN) ; Put index values into DIX variable for display
+1 NEW DISUB,DIVAL,DI0NODE,DIFILE
SET DI0NODE=$GET(@DIFILEI(DIFILEI)@(Y,0))
SET DIX(1)=""
MERGE DIFILE=DIFILEI
+2 IF $GET(DINDEX("OLDSUB"))
NEW DIO,DIN
SET DIN=0
FOR DIO=1:1:DINDEX("OLDSUB")
Begin DoDot:1
+3 SET DIVAL=""
+4 IF $GET(DISCREEN("X",DIO,"GET"))]""
Begin DoDot:2
+5 XECUTE DISCREEN("X",DIO,"GET")
QUIT
End DoDot:2
+6 IF '$TEST
SET DIN=$ORDER(DINDEX(DIN))
IF DIN
IF DIN'>DINDEX("#")
SET DISUB=DIN
DO GETVAL
+7 if DIVAL]""
SET DIX(DIO)=DIVAL
QUIT
End DoDot:1
+8 if $GET(DINDEX("OLDSUB"))
QUIT
+9 FOR DISUB=1:1:DINDEX("#")
DO GETVAL
if DIVAL]""
SET DIX(DISUB)=DIVAL
+10 QUIT
GETVAL ; Return index value in DIVAL
+1 IF $GET(DINDEX(DISUB,"TRANOUT"))]""
Begin DoDot:1
+2 SET DIVAL=DINDEX(DISUB)
if DIVAL=""
QUIT
NEW X
SET X=DIVAL
+3 XECUTE DINDEX(DISUB,"TRANOUT")
if X]""
SET DIVAL=X
QUIT
End DoDot:1
QUIT
+4 SET @DINDEX(DISUB,"GET")
if DIVAL=""
QUIT
+5 IF "VPSD"[DINDEX(DISUB,"TYPE")!(DISUB=1&($GET(DS("INT"))]""))
Begin DoDot:1
+6 IF DISUB>1
IF "VP"[DINDEX(DISUB,"TYPE")
QUIT
+7 SET DIVAL=$$EXT^DIC2(DINDEX(DISUB,"FILE"),DINDEX(DISUB,"FIELD"),DIVAL)
QUIT
End DoDot:1
+8 QUIT
+9 ;
IXCHK(DIFILEI,DINDEX,DIOK,DIALLVAL,DIVAL,DID) ; Build INDEX info, make sure indexed field not a pointer.
+1 SET DIOK=0
NEW DIVALX
SET DIVALX=$GET(DIVAL(1))
+2 NEW DIXIEN
SET DIXIEN=+$ORDER(^DD("IX","BB",DIFILEI,DINDEX,""))
+3 IF DIXIEN
IF $GET(DID)=""
IF $PIECE($GET(^DD("IX",DIXIEN,0)),U,14)'["L"
QUIT
+4 IF 'DIXIEN!('$ORDER(^DD("IX",DIXIEN,11.1,"AC",1)))
Begin DoDot:1
+5 NEW DIFLAGS
SET DIFLAGS="hql"
if $GET(DILONGX)!(DIC(0)["T")
SET DIFLAGS="4l"
+6 IF +$PIECE(DIVALX,"E")=DIVALX
IF DIC(0)["E"
SET DIFLAGS="4l"
+7 DO INDEX^DICUIX(.DIFILEI,DIFLAGS,.DINDEX)
+8 ;22*70 IGNORE POINTERS IF YOU ARE LOOKING UP A NUMBER VALUE!!
IF +$PIECE(DIVALX,"E")=DIVALX
IF $GET(DINDEX(1,"TYPE"))="P"
Begin DoDot:2
+9 ;22*70
IF DIC(0)["T"
IF DIC(0)["E"
SET (DIOK,DIOK("T"))=1
End DoDot:2
QUIT
+10 SET DIOK=1
QUIT
End DoDot:1
QUIT
+11 DO INDEX^DICUIX(.DIFILEI,"4l",.DINDEX,"",.DIVAL)
+12 SET (DIALLVAL,DIOK)=1
+13 NEW I
FOR I=1:1:DINDEX("#")
if $GET(DINDEX(I,"PART"))=""
SET DIALLVAL=0
+14 QUIT
+15 ;
PROCERR ; Display errors generated from call to Finder.
+1 IF DIC(0)'["E"
KILL DIERR
QUIT
+2 WRITE $CHAR(7)
if '$DATA(DDS)
WRITE !
+3 NEW A1,DDH,I,J
SET DDH=0
+4 FOR I=1:1:+DIERR
FOR J=0:0
SET J=$ORDER(DIERR("DIERR",I,"TEXT",J))
if 'J
QUIT
Begin DoDot:1
+5 IF '$DATA(DDS)
WRITE DIERR("DIERR",I,"TEXT",J),!
QUIT
+6 SET DDH=DDH+1
SET DDH(DDH)=DIERR("DIERR",I,"TEXT",J)
QUIT
End DoDot:1
+7 KILL DIERR
IF '$DATA(DDS)
WRITE !!
QUIT
+8 SET A1="T"
DO LIST^DDSU
QUIT
+9 ;
