DICU1 ;SEA/TOAD,SF/TKW-VA FileMan: Lookup Tools, Get IDs & Index ;9/9/98 09:02
;;22.0;VA FileMan;;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
;
IDENTS(DIFLAGS,DIFILE,DIDS,DIWRITE,DIDENT,DINDEX) ;
; get definition of fields to return with each entry
;
ID1 ; prepare to build output processor:
;
S DIDS=";"_DIDS_";"
I DIDS[";@;" S DIDS("@")=""
E S:DIDS'[";-WID;" DIDS("WID")="" S:DIDS=";;" DIDS("FID")=""
N DICRSR,DICOUNT S (DICRSR,DICOUNT)=0
I DIFLAGS["P" S DICRSR=1,DIDENT(-3)="IEN"
N DIFORMAT,DIDEFALT S DIDEFALT=$S(DIFLAGS["I":"I",1:"E")
;
ID1A ; for Lister: add indexed fields to DIDENT array (to build 1 nodes)
;
I DIFLAGS[3,DIFLAGS'["S",DIDS'[";-IX",'$D(DIDS("@")) D
. S DIDENT=-2,DIDENT(-2)=1
. D THROW^DICU11(DIFLAGS,.DIDENT,.DIDS,.DICRSR,.DICOUNT,DIDEFALT,.DINDEX)
. S DIDENT=0
;
ID2 ; decide whether to auto-include the .01 in the field list
; will come out in 1 node for Lister, in "ID" nodes for Finder
;
N DIUSEKEY S (DIUSEKEY,DIDENT)=0
I '$D(DIDS("@")),DIDS'[";-.01;",DIFLAGS'["S" D
. I DIFLAGS[4 S DIUSEKEY="1F" Q
. I DIDS[";.01;"!(DIDS[";.01E") Q
. S DIUSEKEY=1 N DISUB F DISUB=1:1:DINDEX("#") D Q:'DIUSEKEY
. . Q:DINDEX(DISUB,"FIELD")'=.01
. . S DIUSEKEY=DINDEX(DISUB,"FILE")'=DIFILE
. Q
I DIUSEKEY S DIDENT(-2)=1,DIDENT=.01
N DICODE,DIDEF,DIEFROM,DIETO,DINODE,DIPIECE,DISTORE,DITYPE,DIFRMAT2
N DILENGTH,DIOUTI S DILENGTH=$L(DIDS,";"),DIOUTI=0
;
ID3 ; Process auto-included .01 field (if included) on first pass,
; Start loop to process each field from DIFIELDS parameter
; and Identifiers.
;
F D Q:$G(DIERR)!DIOUTI
. S DIFORMAT=""
. I DIUSEKEY D Q
. . D BLD S DIUSEKEY=$S(DIUSEKEY="1F":"F",1:0)
. . S:DIDENT=-2 DIDENT=.01 Q
. D Q:'DIDENT
. . S DIUSEKEY=0
. . ; Find next Identifier
. . I $D(DIDS("FID")) D Q
. . . S DIDENT=$O(^DD(DIFILE,0,"ID",DIDENT))
. . . I 'DIDENT K DIFRMAT2
. . . I DIDENT="" S:DIDS=";;" DIOUTI=1 K DIDS("FID")
. .
ID4 . . ; Find next field in DIFIELDS input parameter.
. .
. . S DICOUNT=DICOUNT+1
. . S DIDENT=$P(DIDS,";",DICOUNT)
. . I DIDENT="",DICOUNT'<DILENGTH S DIOUTI=1
. .
ID4A . . ; process IX specifier
. .
. . I DIDENT["IX" D Q
. . . I $$BADIX(DIDENT) D ERR202 Q
. . . Q:DIDS[";-IX;"
. . . D THROW^DICU11(DIFLAGS,.DIDENT,.DIDS,.DICRSR,.DICOUNT,DIDEFALT,.DINDEX)
. .
ID4B . . ; process FID, WID, and @ specifiers
. .
. . I DIDENT["FID" D S DIDENT="" Q
. . . Q:DIDENT="-FID"!(DIDS[";-FID;")
. . . D GETFORM^DICU11(.DIDENT,.DIFRMAT2,.DIDS,.DICOUNT)
. . . S DIDS("FID")=1 Q
. . I DIDENT["WID" D S DIDENT="" Q
. . . I DIDENT'="WID",DIDENT'="-WID" D ERR202 Q
. . . Q:DIDENT="-WID"!(DIDS[";-WID;")
. . . D WRITEID^DICU11(DIFILE,.DIDENT,.DICRSR) K DIDS("WID") Q
. . I DIDENT["@" D:DIDENT'="@" ERR202 Q
. . I 'DIDENT D:DIDENT'="" ERR202 Q
. .
ID4C . . ; process field # specifiers from DIFIELDS parameter
. .
. . D GETFORM^DICU11(.DIDENT,.DIFORMAT,.DIDS,.DICOUNT)
.
. ; Here we quit if field is already in the DIDENT array.
. I DIDS=";;",DIFLAGS[4,DIUSEKEY'="F",DIDENT=.01 Q
. I DIDS=";;",DIFLAGS[3,DINDEX("FLIST")[("^"_DIDENT_"^") Q
.
ID5 . ; for file IDs, we skip non-display IDs
.
. N DIPLUS S DIPLUS=+DIDENT
. N DILAST S DILAST=$P(DIDENT,DIPLUS,2,999)
. I DIDENT["-" D Q
. . I DILAST'="" D ERR202 Q
. . I '$D(^DD(DIFILE,-DIPLUS)) D ERR(501,DIFILE,"","",-DIPLUS) Q
. E I (DILAST'?.1"E".1"I")&(DILAST'?.1"I".1"E") D ERR202 Q
. Q:DIDS[(";-"_DIDENT_";")
. I $D(DIDS("FID")) D I DINODE="W """"" Q
. . S DINODE=$G(^DD(DIFILE,0,"ID",DIDENT))
. I $G(DIFRMAT2)]"" S DIFORMAT=DIFRMAT2
. D BLD Q
;
ID6 ; Write Identifiers: add to output processor
; ID Parameter: add ID parameter to output processor
;
Q:$G(DIERR)
I $D(DIDS("WID")) D WRITEID^DICU11(DIFILE,.DIDENT,.DICRSR)
I DIWRITE'="" D
. S DIDENT="ZZZ ID" I DIFLAGS["P" S DICRSR=DICRSR+1
. S DIDENT(DICRSR,DIDENT,0)="N DIMSG "_DIWRITE
. S:DIFLAGS["P" $P(DIDENT(-3),U,DICRSR)="IDP" Q
Q
;
BLD ; get fetch code for value
D GET^DICUIX1(DIFILE,DIFILE,DIDENT,.DIDEF,.DICODE) Q:DIDEF=""!$G(DIERR)
I DIFORMAT="" S DIFORMAT=$S(DIUSEKEY="1F":"I",1:DIDEFALT)
D
. N DIVALUE S DIVALUE=DIDENT
. I DIUSEKEY'["F",$D(DIDS("FID")),DIDENT'=.01 S DIVALUE="FID("_DIVALUE_")"
. S:DIFORMAT="I" DIVALUE=DIVALUE_DIFORMAT
. I DIFLAGS["P" S $P(DIDENT(-3),U,(DICRSR+1))=DIVALUE Q
. Q:DIUSEKEY="1F"
. S DIDENT(-3,+DIDENT,DIVALUE)="" Q
BLD1 ; set up format code and load with fetch code into DIDENT
N DIVALUE,DISUB S DIVALUE=DICODE,DISUB=0
S DITYPE=$P(DIDEF,U,2) I DITYPE'["C" D
. S DIVALUE=$$FORMAT^DICU11(DIDENT,DICODE,DIUSEKEY,DIFORMAT,DIDEFALT,DIFLAGS)
I DIUSEKEY="1F",DIDENT=.01 S DIDENT=-2,DISUB=.01
I DIFLAGS["P" S DICRSR=DICRSR+1
I DITYPE'["C" S DIDENT(DICRSR,DIDENT,DISUB,DIFORMAT)=DIVALUE Q
S DIDENT(DICRSR,DIDENT,0)=DIVALUE
S DIDENT(DICRSR,DIDENT,0,"TYPE")="C"
Q
;
ERR(DIERN,DIFILE,DIENS,DIFIELD,DI1) ;
;
; add an error to the message array
; GET
;
N DIPE
S DIPE("FILE")=$G(DIFILE)
S DIPE("IEN")=$G(DIENS)
S DIPE("FIELD")=$G(DIFIELD)
S DIPE(1)=$G(DI1)
D BLD^DIALOG(DIERN,.DIPE,.DIPE)
Q
;
ERR202 D ERR(202,"","","","FIELDS") Q
;
BADIX(DIDENT) ;
;
N DIBAD S DIBAD=DIDENT'="IX"&(DIDENT'="-IX")&(DIDENT'?1"IX"1"E".1"I")
S DIBAD=DIDENT'?1"IX"1"I".1"E"&DIBAD
Q DIBAD
;
; 202 The input parameter that identifies the |1
;
DICU1 ;SEA/TOAD,SF/TKW-VA FileMan: Lookup Tools, Get IDs & Index ;9/9/98 09:02
+1 ;;22.0;VA FileMan;;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
IDENTS(DIFLAGS,DIFILE,DIDS,DIWRITE,DIDENT,DINDEX) ;
+1 ; get definition of fields to return with each entry
+2 ;
ID1 ; prepare to build output processor:
+1 ;
+2 SET DIDS=";"_DIDS_";"
+3 IF DIDS[";@;"
SET DIDS("@")=""
+4 IF '$TEST
IF DIDS'[";-WID;"
SET DIDS("WID")=""
IF DIDS=";;"
SET DIDS("FID")=""
+5 NEW DICRSR,DICOUNT
SET (DICRSR,DICOUNT)=0
+6 IF DIFLAGS["P"
SET DICRSR=1
SET DIDENT(-3)="IEN"
+7 NEW DIFORMAT,DIDEFALT
SET DIDEFALT=$SELECT(DIFLAGS["I":"I",1:"E")
+8 ;
ID1A ; for Lister: add indexed fields to DIDENT array (to build 1 nodes)
+1 ;
+2 IF DIFLAGS[3
IF DIFLAGS'["S"
IF DIDS'[";-IX"
IF '$DATA(DIDS("@"))
Begin DoDot:1
+3 SET DIDENT=-2
SET DIDENT(-2)=1
+4 DO THROW^DICU11(DIFLAGS,.DIDENT,.DIDS,.DICRSR,.DICOUNT,DIDEFALT,.DINDEX)
+5 SET DIDENT=0
End DoDot:1
+6 ;
ID2 ; decide whether to auto-include the .01 in the field list
+1 ; will come out in 1 node for Lister, in "ID" nodes for Finder
+2 ;
+3 NEW DIUSEKEY
SET (DIUSEKEY,DIDENT)=0
+4 IF '$DATA(DIDS("@"))
IF DIDS'[";-.01;"
IF DIFLAGS'["S"
Begin DoDot:1
+5 IF DIFLAGS[4
SET DIUSEKEY="1F"
QUIT
+6 IF DIDS[";.01;"!(DIDS[";.01E")
QUIT
+7 SET DIUSEKEY=1
NEW DISUB
FOR DISUB=1:1:DINDEX("#")
Begin DoDot:2
+8 IF DINDEX(DISUB,"FIELD")'=.01
QUIT
+9 SET DIUSEKEY=DINDEX(DISUB,"FILE")'=DIFILE
End DoDot:2
IF 'DIUSEKEY
QUIT
+10 QUIT
End DoDot:1
+11 IF DIUSEKEY
SET DIDENT(-2)=1
SET DIDENT=.01
+12 NEW DICODE,DIDEF,DIEFROM,DIETO,DINODE,DIPIECE,DISTORE,DITYPE,DIFRMAT2
+13 NEW DILENGTH,DIOUTI
SET DILENGTH=$LENGTH(DIDS,";")
SET DIOUTI=0
+14 ;
ID3 ; Process auto-included .01 field (if included) on first pass,
+1 ; Start loop to process each field from DIFIELDS parameter
+2 ; and Identifiers.
+3 ;
+4 FOR
Begin DoDot:1
+5 SET DIFORMAT=""
+6 IF DIUSEKEY
Begin DoDot:2
+7 DO BLD
SET DIUSEKEY=$SELECT(DIUSEKEY="1F":"F",1:0)
+8 IF DIDENT=-2
SET DIDENT=.01
QUIT
End DoDot:2
QUIT
+9 Begin DoDot:2
+10 SET DIUSEKEY=0
+11 ; Find next Identifier
+12 IF $DATA(DIDS("FID"))
Begin DoDot:3
+13 SET DIDENT=$ORDER(^DD(DIFILE,0,"ID",DIDENT))
+14 IF 'DIDENT
KILL DIFRMAT2
+15 IF DIDENT=""
IF DIDS=";;"
SET DIOUTI=1
KILL DIDS("FID")
End DoDot:3
QUIT
+16 ID4 ; Find next field in DIFIELDS input parameter.
+1 +2 SET DICOUNT=DICOUNT+1
+3 SET DIDENT=$PIECE(DIDS,";",DICOUNT)
+4 IF DIDENT=""
IF DICOUNT'<DILENGTH
SET DIOUTI=1
+5 ID4A ; process IX specifier
+1 +2 IF DIDENT["IX"
Begin DoDot:3
+3 IF $$BADIX(DIDENT)
DO ERR202
QUIT
+4 IF DIDS[";-IX;"
QUIT
+5 DO THROW^DICU11(DIFLAGS,.DIDENT,.DIDS,.DICRSR,.DICOUNT,DIDEFALT,.DINDEX)
End DoDot:3
QUIT
+6 ID4B ; process FID, WID, and @ specifiers
+1 +2 IF DIDENT["FID"
Begin DoDot:3
+3 IF DIDENT="-FID"!(DIDS[";-FID;")
QUIT
+4 DO GETFORM^DICU11(.DIDENT,.DIFRMAT2,.DIDS,.DICOUNT)
+5 SET DIDS("FID")=1
QUIT
End DoDot:3
SET DIDENT=""
QUIT
+6 IF DIDENT["WID"
Begin DoDot:3
+7 IF DIDENT'="WID"
IF DIDENT'="-WID"
DO ERR202
QUIT
+8 IF DIDENT="-WID"!(DIDS[";-WID;")
QUIT
+9 DO WRITEID^DICU11(DIFILE,.DIDENT,.DICRSR)
KILL DIDS("WID")
QUIT
End DoDot:3
SET DIDENT=""
QUIT
+10 IF DIDENT["@"
IF DIDENT'="@"
DO ERR202
QUIT
+11 IF 'DIDENT
IF DIDENT'=""
DO ERR202
QUIT
+12 ID4C ; process field # specifiers from DIFIELDS parameter
+1 +2 DO GETFORM^DICU11(.DIDENT,.DIFORMAT,.DIDS,.DICOUNT)
End DoDot:2
IF 'DIDENT
QUIT
+3 +4 ; Here we quit if field is already in the DIDENT array.
+5 IF DIDS=";;"
IF DIFLAGS[4
IF DIUSEKEY'="F"
IF DIDENT=.01
QUIT
+6 IF DIDS=";;"
IF DIFLAGS[3
IF DINDEX("FLIST")[("^"_DIDENT_"^")
QUIT
+7 ID5 ; for file IDs, we skip non-display IDs
+1 +2 NEW DIPLUS
SET DIPLUS=+DIDENT
+3 NEW DILAST
SET DILAST=$PIECE(DIDENT,DIPLUS,2,999)
+4 IF DIDENT["-"
Begin DoDot:2
+5 IF DILAST'=""
DO ERR202
QUIT
+6 IF '$DATA(^DD(DIFILE,-DIPLUS))
DO ERR(501,DIFILE,"","",-DIPLUS)
QUIT
End DoDot:2
QUIT
+7 IF '$TEST
IF (DILAST'?.1"E".1"I")&(DILAST'?.1"I".1"E")
DO ERR202
QUIT
+8 IF DIDS[(";-"_DIDENT_";")
QUIT
+9 IF $DATA(DIDS("FID"))
Begin DoDot:2
+10 SET DINODE=$GET(^DD(DIFILE,0,"ID",DIDENT))
End DoDot:2
IF DINODE="W """""
QUIT
+11 IF $GET(DIFRMAT2)]""
SET DIFORMAT=DIFRMAT2
+12 DO BLD
QUIT
End DoDot:1
IF $GET(DIERR)!DIOUTI
QUIT
+13 ;
ID6 ; Write Identifiers: add to output processor
+1 ; ID Parameter: add ID parameter to output processor
+2 ;
+3 IF $GET(DIERR)
QUIT
+4 IF $DATA(DIDS("WID"))
DO WRITEID^DICU11(DIFILE,.DIDENT,.DICRSR)
+5 IF DIWRITE'=""
Begin DoDot:1
+6 SET DIDENT="ZZZ ID"
IF DIFLAGS["P"
SET DICRSR=DICRSR+1
+7 SET DIDENT(DICRSR,DIDENT,0)="N DIMSG "_DIWRITE
+8 IF DIFLAGS["P"
SET $PIECE(DIDENT(-3),U,DICRSR)="IDP"
QUIT
End DoDot:1
+9 QUIT
+10 ;
BLD ; get fetch code for value
+1 DO GET^DICUIX1(DIFILE,DIFILE,DIDENT,.DIDEF,.DICODE)
IF DIDEF=""!$GET(DIERR)
QUIT
+2 IF DIFORMAT=""
SET DIFORMAT=$SELECT(DIUSEKEY="1F":"I",1:DIDEFALT)
+3 Begin DoDot:1
+4 NEW DIVALUE
SET DIVALUE=DIDENT
+5 IF DIUSEKEY'["F"
IF $DATA(DIDS("FID"))
IF DIDENT'=.01
SET DIVALUE="FID("_DIVALUE_")"
+6 IF DIFORMAT="I"
SET DIVALUE=DIVALUE_DIFORMAT
+7 IF DIFLAGS["P"
SET $PIECE(DIDENT(-3),U,(DICRSR+1))=DIVALUE
QUIT
+8 IF DIUSEKEY="1F"
QUIT
+9 SET DIDENT(-3,+DIDENT,DIVALUE)=""
QUIT
End DoDot:1
BLD1 ; set up format code and load with fetch code into DIDENT
+1 NEW DIVALUE,DISUB
SET DIVALUE=DICODE
SET DISUB=0
+2 SET DITYPE=$PIECE(DIDEF,U,2)
IF DITYPE'["C"
Begin DoDot:1
+3 SET DIVALUE=$$FORMAT^DICU11(DIDENT,DICODE,DIUSEKEY,DIFORMAT,DIDEFALT,DIFLAGS)
End DoDot:1
+4 IF DIUSEKEY="1F"
IF DIDENT=.01
SET DIDENT=-2
SET DISUB=.01
+5 IF DIFLAGS["P"
SET DICRSR=DICRSR+1
+6 IF DITYPE'["C"
SET DIDENT(DICRSR,DIDENT,DISUB,DIFORMAT)=DIVALUE
QUIT
+7 SET DIDENT(DICRSR,DIDENT,0)=DIVALUE
+8 SET DIDENT(DICRSR,DIDENT,0,"TYPE")="C"
+9 QUIT
+10 ;
ERR(DIERN,DIFILE,DIENS,DIFIELD,DI1) ;
+1 ;
+2 ; add an error to the message array
+3 ; GET
+4 ;
+5 NEW DIPE
+6 SET DIPE("FILE")=$GET(DIFILE)
+7 SET DIPE("IEN")=$GET(DIENS)
+8 SET DIPE("FIELD")=$GET(DIFIELD)
+9 SET DIPE(1)=$GET(DI1)
+10 DO BLD^DIALOG(DIERN,.DIPE,.DIPE)
+11 QUIT
+12 ;
ERR202 DO ERR(202,"","","","FIELDS")
QUIT
+1 ;
BADIX(DIDENT) ;
+1 ;
+2 NEW DIBAD
SET DIBAD=DIDENT'="IX"&(DIDENT'="-IX")&(DIDENT'?1"IX"1"E".1"I")
+3 SET DIBAD=DIDENT'?1"IX"1"I".1"E"&DIBAD
+4 QUIT DIBAD
+5 ;
+6 ; 202 The input parameter that identifies the |1
+7 ;
