- DIC4 ;SFISC/TKW-VA FileMan Lookup utilities ;5:59 AM 20 Sep 2002 [ 12/09/2003 4:40 PM ]
- ;;22.0;VA FileMan;**4,20,70,1002**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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
- . . 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
- ;
- DIC4 ;SFISC/TKW-VA FileMan Lookup utilities ;5:59 AM 20 Sep 2002 [ 12/09/2003 4:40 PM ]
- +1 ;;22.0;VA FileMan;**4,20,70,1002**;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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
- 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 ;
