- DICU1 ;SEA/TOAD,SF/TKW-VA FileMan: Lookup Tools, Get IDs & Index ;26JUNE2011
- ;;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.
- ;
- 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:$G(DINDEX(DISUB,"FIELD"))'=.01 ;**GFT
- . . 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
- ID4X ..I $TR(DIDENT,"@")]"" N X,DICR S X=DIDENT I +X'=$TR(X,"IE") D Q:$D(X) ;***GFT
- ...N DISVFILE
- ...S DISVFILE=DIFILE N DIFILE S DIFILE=DISVFILE ;Q^DIC2 KILLS DIFILE
- ...D EXPR^DICOMP(DIFILE,"m",X) Q:'$D(X) ;Create the code to do the computation
- ...S DICRSR=DICRSR+1 S:$G(Y)["m" DIGFT(DICRSR,"MULTIPLE")=1 S:$G(Y)["D" DIGFT(DICRSR,"DATE")=1
- ...S Y="C"_(DICOUNT-1) ;COMPUTED
- ...S:DIFLAGS["P" $P(DIDENT(-3),U,DICRSR)=Y ;THIS WILL BECOME THE PACKED "MAP"
- ...S:DIFLAGS'["P" DIDENT(-3,$O(^DD(DISVFILE," "),-1)+1,Y)="" ;THIS IS THE UNPACKED MAP
- ...S DIDENT(DICRSR,Y,0)="D COMP^DICU1("_DICRSR_")"
- ...M DIGFT(DICRSR)=X S DIDENT=""
- . . 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
- ;
- ;
- COMP(DIGFTI) ;EXECUTE A COMPUTED FIELD! COME HERE FROM DICU2
- N X,Y,J,I
- S J=0 F Y=$L(DIEN,","):-1:1 S X=$P(DIEN,",",Y) I X]"" N @("D"_J) S @("D"_J)=X,J=J+1 ;Temporarily set D0,D1,etc
- M X=DIGFT(DIGFTI)
- I '$D(DIGFT(DIGFTI,"MULTIPLE")) X X D:$D(DIGFT(DIGFTI,"DATE")) S ^TMP("DIMSG",$J,1)=X Q ;SINGLE-VALUED COMPUTED EXPRESSION
- .N Y S Y=X X:Y ^DD("DD") S X=Y
- N DICMX S DICMX="S ^($O(^TMP(""DIMSG"",$J,999),-1)+1)=X" X X ;MULTIPLE-VALUED COMPUTED EXPRESSION
- 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
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICU1 6763 printed Feb 19, 2025@00:12:54 Page 2
- DICU1 ;SEA/TOAD,SF/TKW-VA FileMan: Lookup Tools, Get IDs & Index ;26JUNE2011
- +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 ;
- 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 ;**GFT
- if $GET(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
- ID4A ; process IX specifier
- +1 IF DIDENT["IX"
- Begin DoDot:3
- +2 IF $$BADIX(DIDENT)
- DO ERR202
- QUIT
- +3 if DIDS[";-IX;"
- QUIT
- +4 DO THROW^DICU11(DIFLAGS,.DIDENT,.DIDS,.DICRSR,.DICOUNT,DIDEFALT,.DINDEX)
- End DoDot:3
- QUIT
- +5 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
- ID4X ;***GFT
- IF $TRANSLATE(DIDENT,"@")]""
- NEW X,DICR
- SET X=DIDENT
- IF +X'=$TRANSLATE(X,"IE")
- Begin DoDot:3
- +1 NEW DISVFILE
- +2 ;Q^DIC2 KILLS DIFILE
- SET DISVFILE=DIFILE
- NEW DIFILE
- SET DIFILE=DISVFILE
- +3 ;Create the code to do the computation
- DO EXPR^DICOMP(DIFILE,"m",X)
- if '$DATA(X)
- QUIT
- +4 SET DICRSR=DICRSR+1
- if $GET(Y)["m"
- SET DIGFT(DICRSR,"MULTIPLE")=1
- if $GET(Y)["D"
- SET DIGFT(DICRSR,"DATE")=1
- +5 ;COMPUTED
- SET Y="C"_(DICOUNT-1)
- +6 ;THIS WILL BECOME THE PACKED "MAP"
- if DIFLAGS["P"
- SET $PIECE(DIDENT(-3),U,DICRSR)=Y
- +7 ;THIS IS THE UNPACKED MAP
- if DIFLAGS'["P"
- SET DIDENT(-3,$ORDER(^DD(DISVFILE," "),-1)+1,Y)=""
- +8 SET DIDENT(DICRSR,Y,0)="D COMP^DICU1("_DICRSR_")"
- +9 MERGE DIGFT(DICRSR)=X
- SET DIDENT=""
- End DoDot:3
- if $DATA(X)
- 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 ;
- +11 ;
- COMP(DIGFTI) ;EXECUTE A COMPUTED FIELD! COME HERE FROM DICU2
- +1 NEW X,Y,J,I
- +2 ;Temporarily set D0,D1,etc
- SET J=0
- FOR Y=$LENGTH(DIEN,","):-1:1
- SET X=$PIECE(DIEN,",",Y)
- IF X]""
- NEW @("D"_J)
- SET @("D"_J)=X
- SET J=J+1
- +3 MERGE X=DIGFT(DIGFTI)
- +4 ;SINGLE-VALUED COMPUTED EXPRESSION
- IF '$DATA(DIGFT(DIGFTI,"MULTIPLE"))
- XECUTE X
- if $DATA(DIGFT(DIGFTI,"DATE"))
- Begin DoDot:1
- +5 NEW Y
- SET Y=X
- if Y
- XECUTE ^DD("DD")
- SET X=Y
- End DoDot:1
- SET ^TMP("DIMSG",$JOB,1)=X
- QUIT
- +6 ;MULTIPLE-VALUED COMPUTED EXPRESSION
- NEW DICMX
- SET DICMX="S ^($O(^TMP(""DIMSG"",$J,999),-1)+1)=X"
- XECUTE X
- +7 QUIT
- +8 ;
- +9 ;
- 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 ;