DICU2 ;SEA/TOAD,SF/TKW - VA FileMan: Lookup Tools, Return IDs ;5OCT2016
;;22.2;VA FileMan;**4,5**;Jan 05, 2016;Build 28
;;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.
;;GFT;**126,165,1032,1041,GFT,1042,1045**
;
IDS(DIFILE,DIEN,DIFLAGS,DINDEX,DICOUNT,DIDENT,DILIST,DI0NODE) ;
;
; ENTRY POINT--add an entry's identifiers to output
;
I1 ; setup 0-node and ID array interface, and output IEN
;
I DIFLAGS["h" N F,N,I M F=DIFILE S N=$G(DI0NODE),I=+$G(DIEN) N DIFILE,DI0NODE,DIEN M DIFILE=F S DIEN=I S:N]"" DI0NODE=N K F,N,I
I '$D(DI0NODE) S DI0NODE=$G(@DIFILE(DIFILE)@(+DIEN,0))
N DID,DIDVAL
I DIFLAGS["P" N DINODE S DINODE=+DIEN
E S @DILIST@(2,DICOUNT)=+DIEN
;
I1A ; output primary value (index for Lister, .01 for Finder)
;
I DIFLAGS'["P",$D(DIDENT(-2)) D
. N DIOUT S DIOUT=$NA(@DILIST@(1,DICOUNT))
. I DIFLAGS[3 N DISUB D Q
. . F DISUB=0:0 S DISUB=$O(DIDENT(0,-2,DISUB)) Q:'DISUB D
. . . I DINDEX("#")'>1 D SET(0,-2,DISUB,DIOUT,.DINDEX,.DIFILE) Q
. . . N I S I=$NA(@DIOUT@(DISUB)) D SET(0,-2,DISUB,I,.DINDEX,.DIFILE)
. I $D(DIDENT(0,-2,.01)) D SET(0,-2,.01,DIOUT,"",.DIFILE)
. Q
;
I2 ; start loop: loop through output values
;
I DIFLAGS["P" N DILENGTH S DILENGTH=$L(DINODE)
N DICODE,DICRSR,DIOUT,DISUB S DICRSR=-1
F S DICRSR=$O(DIDENT(DICRSR)) Q:DICRSR=""!($G(DIERR)) S DID="" F S DID=$O(DIDENT(DICRSR,DID)) Q:DID=""!($G(DIERR)) S DISUB="" F D Q:DISUB=""!$G(DIERR)
. I DIFLAGS'["P",DID=-2 Q
. S DISUB=$O(DIDENT(DICRSR,DID,DISUB)) Q:DISUB=""
. K DIDVAL
I20 . ; output indexed field if "IX" was in FIELDS parameter
. I DID=0 D Q
. . D SET(DICRSR,DID,DISUB,"DIDVAL",.DINDEX,.DIFILE)
. . I DIFLAGS["P" D ADD(.DIFLAGS,.DINODE,.DILENGTH,DIDVAL,DIEN,DILIST) Q
. . M @DILIST@("ID",DICOUNT,0,DISUB)=DIDVAL Q
.
I3 . ; output field
. ; distinguish between computed and value fields
.
. I DID D Q:$G(DIERR)
. . ; process fields that are not computed.
. . I DIFLAGS["E" N DIERR ;ERROR IN DATA WILL NOT STOP THE LISTING --GFT
. . I $G(DIDENT(DICRSR,DID,0,"TYPE"))'="C" D
. . . D SET(DICRSR,DID,DISUB,"DIDVAL",.DINDEX,.DIFILE) Q
. .
I4 . . ; computed fields
. . E D
. . . N %,%H,%T,A,B,C,D,DFN,I,X,X1,X2,Y,Z,Z0,Z1
. . . N DA D DA^DILF(DIEN,.DA) ;M DA=DIEN S DA=$P(DIEN,",") PATCH 165 MAY,2011
. . . N DIARG S DIARG="D0"
. . . N DIMAX S DIMAX=+$O(DA(""),-1)
. . . N DIDVAR F DIDVAR=1:1:DIMAX S DIARG=DIARG_",D"_DIDVAR
. . . N @DIARG F DIDVAR=0:1:DIMAX-1 S @("D"_DIDVAR)=DA(DIMAX-DIDVAR)
. . . S @("D"_DIMAX)=DA
. . . X DIDENT(DICRSR,DID,0) S DIDVAL=$G(X)
COMPDT . . .I $P($G(^DD(DIFILE,DID,0)),U,2)["D",$O(DIDENT(-3,DID,""))'["I" N Y S Y=DIDVAL X:Y ^DD("DD") S DIDVAL=Y
. .
I5 . . ; set field into array or pack node
. .
. . I DIFLAGS'["P" M @DILIST@("ID",DICOUNT,DID)=DIDVAL
. . E D ADD(.DIFLAGS,.DINODE,.DILENGTH,DIDVAL,DIEN,DILIST)
.
I6 . ; output display-only identifier
.
. E D
. . N %,D,DIC,X,Y,Y1
. . S D=DINDEX
. . S DIC=DIFILE(DIFILE,"O")
. . S DIC(0)=$TR(DIFLAGS,"2^fglpqtuv104")
. . M Y=DIEN S Y=$P(DIEN,",")
. . S Y1=$G(@DIFILE(DIFILE)@(+DIEN,0)),Y1=DIEN
. .
I7 . . ; execute the identifier's code
. .
. . N DIX S DIX=DIDENT(DICRSR,DID,0)
. . X DIX
. . I $G(DIERR) D Q
. . . N DICONTXT I DID="ZZZ ID" S DICONTXT="Identifier parameter"
. . . E S DICONTXT="MUMPS Identifier"
. . . D ERR^DICF4(120,DIFILE,DIEN,"",DICONTXT)
. .
I8 . . ; set output from identifier into output array or pack node
. . N DIGFT S DIGFT=$NA(@DILIST@("ID","WRITE",DICOUNT)) I DID?1"C"1.2N S DIGFT=$NA(@DILIST@("ID",DICOUNT,DID)) ;**GFT
. . N DI,DILINE,DIEND S DI="" S:DIFLAGS'["P" DIEND=$O(@DIGFT@("z"),-1)
. . I $O(^TMP("DIMSG",$J,""))="" S ^TMP("DIMSG",$J,1)=""
. . F D Q:DI=""!$G(DIERR)
. . . S DI=$O(^TMP("DIMSG",$J,DI)) Q:DI=""
. . . S DILINE=$G(^TMP("DIMSG",$J,DI))
. . . I DIFLAGS["P" D ADD(.DIFLAGS,.DINODE,.DILENGTH,DILINE,DIEN,DILIST,DI) Q
. . . S DIEND=DIEND+1,@DIGFT@(DIEND)=DILINE
. . . Q
. . K DIMSG,^TMP("DIMSG",$J)
;
I9 ; for packed output, set pack node into output array
;
I '$G(DIERR),DIFLAGS["P" S @DILIST@(DICOUNT,0)=DINODE
Q
;
;
SET(DICRSR,DIFID,DISUB,DIOUT,DINDEX,DIFILE) ; Move data to DIOUT.
N F1,F2 M F1=DIFILE N DIFILE M DIFILE=F1
S F1=$O(DIDENT(DICRSR,DIFID,DISUB,"")),F2=$O(DIDENT(DICRSR,DIFID,DISUB,F1))
F F1=F1,F2 D:F1]""
. I DIDENT(DICRSR,DIFID,DISUB,F1)["DIVAL" N DIVAL S @DINDEX(DISUB,"GET")
. N X S @("X="_DIDENT(DICRSR,DIFID,DISUB,F1))
. I $G(DIERR),DIFLAGS["h" K DIERR,^TMP("DIERR",$J) S X=DINDEX(DISUB)
. I X["""" S X=$$CONVQQ^DILIBF(X)
. I +$P(X,"E")'=X S X=""""_X_""""
. I F2="" S @(DIOUT_"="_X) Q
. S O=$NA(@DIOUT@(F1)),@(O_"="_X) Q
Q
;
TRANOUT(DISUB,DIVL) ; Execute TRANSFORM FOR DISPLAY on index value
N X S X=DIVL
N DICODE S DICODE=$G(DINDEX(DISUB,"TRANOUT"))
I DICODE]"" X DICODE
Q X
;
ADD(DIFLAGS,DINODE,DILENGTH,DINEW,DIEN,DILIST,DILCNT) ;
;
; for Packed output, add DINEW to DINODE, erroring if overflow
; xform if it contains ^
;
A1 N DINEWLEN,DELIM S DINEWLEN=$L(DINEW),DELIM=$S($G(DILCNT)'>1:"^",1:"~")
S DILENGTH=DILENGTH+1+DINEWLEN
I DILENGTH>$G(^DD("STRING_LIMIT"),255) D ERR^DICF4(206,"","","",+DIEN) Q ;**HERE IS WHERE A PACKED STRING WAS FORCED TO BE ONLY 255 CHARACTERS LONG
I DIFLAGS'[2,DINEW[U S DIFLAGS="2^"_DIFLAGS D ENCODE(DILIST,.DINODE)
I DIFLAGS[2,DINEW[U!(DINEW["&") S DINEW=$$HTML^DILF(DINEW) Q:$G(DIERR)
S DINODE=DINODE_DELIM_DINEW
Q
;
ENCODE(DILIST,DINODE) ;
;
; ADD: HTML encode records already output (we found an embedded ^)
; procedure: loop through list encoding &s
;
E1 N DILINE,DIRULE S DIRULE(1,"&")="&"
N DIREC S DIREC=0 F S DIREC=$O(@DILIST@(DIREC)) Q:'DIREC D
. S DILINE=@DILIST@(DIREC,0) Q:DILINE'["&"
. S @DILIST@(DIREC,0)=$$TRANSL8^DILF(DILINE,.DIRULE)
I DINODE["&" S DINODE=$$TRANSL8^DILF(DINODE,.DIRULE)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICU2 6079 printed Sep 23, 2025@20:22:47 Page 2
DICU2 ;SEA/TOAD,SF/TKW - VA FileMan: Lookup Tools, Return IDs ;5OCT2016
+1 ;;22.2;VA FileMan;**4,5**;Jan 05, 2016;Build 28
+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 ;;GFT;**126,165,1032,1041,GFT,1042,1045**
+7 ;
IDS(DIFILE,DIEN,DIFLAGS,DINDEX,DICOUNT,DIDENT,DILIST,DI0NODE) ;
+1 ;
+2 ; ENTRY POINT--add an entry's identifiers to output
+3 ;
I1 ; setup 0-node and ID array interface, and output IEN
+1 ;
+2 IF DIFLAGS["h"
NEW F,N,I
MERGE F=DIFILE
SET N=$GET(DI0NODE)
SET I=+$GET(DIEN)
NEW DIFILE,DI0NODE,DIEN
MERGE DIFILE=F
SET DIEN=I
if N]""
SET DI0NODE=N
KILL F,N,I
+3 IF '$DATA(DI0NODE)
SET DI0NODE=$GET(@DIFILE(DIFILE)@(+DIEN,0))
+4 NEW DID,DIDVAL
+5 IF DIFLAGS["P"
NEW DINODE
SET DINODE=+DIEN
+6 IF '$TEST
SET @DILIST@(2,DICOUNT)=+DIEN
+7 ;
I1A ; output primary value (index for Lister, .01 for Finder)
+1 ;
+2 IF DIFLAGS'["P"
IF $DATA(DIDENT(-2))
Begin DoDot:1
+3 NEW DIOUT
SET DIOUT=$NAME(@DILIST@(1,DICOUNT))
+4 IF DIFLAGS[3
NEW DISUB
Begin DoDot:2
+5 FOR DISUB=0:0
SET DISUB=$ORDER(DIDENT(0,-2,DISUB))
if 'DISUB
QUIT
Begin DoDot:3
+6 IF DINDEX("#")'>1
DO SET(0,-2,DISUB,DIOUT,.DINDEX,.DIFILE)
QUIT
+7 NEW I
SET I=$NAME(@DIOUT@(DISUB))
DO SET(0,-2,DISUB,I,.DINDEX,.DIFILE)
End DoDot:3
End DoDot:2
QUIT
+8 IF $DATA(DIDENT(0,-2,.01))
DO SET(0,-2,.01,DIOUT,"",.DIFILE)
+9 QUIT
End DoDot:1
+10 ;
I2 ; start loop: loop through output values
+1 ;
+2 IF DIFLAGS["P"
NEW DILENGTH
SET DILENGTH=$LENGTH(DINODE)
+3 NEW DICODE,DICRSR,DIOUT,DISUB
SET DICRSR=-1
+4 FOR
SET DICRSR=$ORDER(DIDENT(DICRSR))
if DICRSR=""!($GET(DIERR))
QUIT
SET DID=""
FOR
SET DID=$ORDER(DIDENT(DICRSR,DID))
if DID=""!($GET(DIERR))
QUIT
SET DISUB=""
FOR
Begin DoDot:1
+5 IF DIFLAGS'["P"
IF DID=-2
QUIT
+6 SET DISUB=$ORDER(DIDENT(DICRSR,DID,DISUB))
if DISUB=""
QUIT
+7 KILL DIDVAL
I20 ; output indexed field if "IX" was in FIELDS parameter
+1 IF DID=0
Begin DoDot:2
+2 DO SET(DICRSR,DID,DISUB,"DIDVAL",.DINDEX,.DIFILE)
+3 IF DIFLAGS["P"
DO ADD(.DIFLAGS,.DINODE,.DILENGTH,DIDVAL,DIEN,DILIST)
QUIT
+4 MERGE @DILIST@("ID",DICOUNT,0,DISUB)=DIDVAL
QUIT
End DoDot:2
QUIT
+5 I3 ; output field
+1 ; distinguish between computed and value fields
+2 +3 IF DID
Begin DoDot:2
+4 ; process fields that are not computed.
+5 ;ERROR IN DATA WILL NOT STOP THE LISTING --GFT
IF DIFLAGS["E"
NEW DIERR
+6 IF $GET(DIDENT(DICRSR,DID,0,"TYPE"))'="C"
Begin DoDot:3
+7 DO SET(DICRSR,DID,DISUB,"DIDVAL",.DINDEX,.DIFILE)
QUIT
End DoDot:3
+8 I4 ; computed fields
+1 IF '$TEST
Begin DoDot:3
+2 NEW %,%H,%T,A,B,C,D,DFN,I,X,X1,X2,Y,Z,Z0,Z1
+3 ;M DA=DIEN S DA=$P(DIEN,",") PATCH 165 MAY,2011
NEW DA
DO DA^DILF(DIEN,.DA)
+4 NEW DIARG
SET DIARG="D0"
+5 NEW DIMAX
SET DIMAX=+$ORDER(DA(""),-1)
+6 NEW DIDVAR
FOR DIDVAR=1:1:DIMAX
SET DIARG=DIARG_",D"_DIDVAR
+7 NEW @DIARG
FOR DIDVAR=0:1:DIMAX-1
SET @("D"_DIDVAR)=DA(DIMAX-DIDVAR)
+8 SET @("D"_DIMAX)=DA
+9 XECUTE DIDENT(DICRSR,DID,0)
SET DIDVAL=$GET(X)
COMPDT IF $PIECE($GET(^DD(DIFILE,DID,0)),U,2)["D"
IF $ORDER(DIDENT(-3,DID,""))'["I"
NEW Y
SET Y=DIDVAL
if Y
XECUTE ^DD("DD")
SET DIDVAL=Y
End DoDot:3
+1 I5 ; set field into array or pack node
+1 +2 IF DIFLAGS'["P"
MERGE @DILIST@("ID",DICOUNT,DID)=DIDVAL
+3 IF '$TEST
DO ADD(.DIFLAGS,.DINODE,.DILENGTH,DIDVAL,DIEN,DILIST)
End DoDot:2
if $GET(DIERR)
QUIT
+4 I6 ; output display-only identifier
+1 +2 IF '$TEST
Begin DoDot:2
+3 NEW %,D,DIC,X,Y,Y1
+4 SET D=DINDEX
+5 SET DIC=DIFILE(DIFILE,"O")
+6 SET DIC(0)=$TRANSLATE(DIFLAGS,"2^fglpqtuv104")
+7 MERGE Y=DIEN
SET Y=$PIECE(DIEN,",")
+8 SET Y1=$GET(@DIFILE(DIFILE)@(+DIEN,0))
SET Y1=DIEN
+9 I7 ; execute the identifier's code
+1 +2 NEW DIX
SET DIX=DIDENT(DICRSR,DID,0)
+3 XECUTE DIX
+4 IF $GET(DIERR)
Begin DoDot:3
+5 NEW DICONTXT
IF DID="ZZZ ID"
SET DICONTXT="Identifier parameter"
+6 IF '$TEST
SET DICONTXT="MUMPS Identifier"
+7 DO ERR^DICF4(120,DIFILE,DIEN,"",DICONTXT)
End DoDot:3
QUIT
+8 I8 ; set output from identifier into output array or pack node
+1 ;**GFT
NEW DIGFT
SET DIGFT=$NAME(@DILIST@("ID","WRITE",DICOUNT))
IF DID?1"C"1.2N
SET DIGFT=$NAME(@DILIST@("ID",DICOUNT,DID))
+2 NEW DI,DILINE,DIEND
SET DI=""
if DIFLAGS'["P"
SET DIEND=$ORDER(@DIGFT@("z"),-1)
+3 IF $ORDER(^TMP("DIMSG",$JOB,""))=""
SET ^TMP("DIMSG",$JOB,1)=""
+4 FOR
Begin DoDot:3
+5 SET DI=$ORDER(^TMP("DIMSG",$JOB,DI))
if DI=""
QUIT
+6 SET DILINE=$GET(^TMP("DIMSG",$JOB,DI))
+7 IF DIFLAGS["P"
DO ADD(.DIFLAGS,.DINODE,.DILENGTH,DILINE,DIEN,DILIST,DI)
QUIT
+8 SET DIEND=DIEND+1
SET @DIGFT@(DIEND)=DILINE
+9 QUIT
End DoDot:3
if DI=""!$GET(DIERR)
QUIT
+10 KILL DIMSG,^TMP("DIMSG",$JOB)
End DoDot:2
End DoDot:1
if DISUB=""!$GET(DIERR)
QUIT
+11 ;
I9 ; for packed output, set pack node into output array
+1 ;
+2 IF '$GET(DIERR)
IF DIFLAGS["P"
SET @DILIST@(DICOUNT,0)=DINODE
+3 QUIT
+4 ;
+5 ;
SET(DICRSR,DIFID,DISUB,DIOUT,DINDEX,DIFILE) ; Move data to DIOUT.
+1 NEW F1,F2
MERGE F1=DIFILE
NEW DIFILE
MERGE DIFILE=F1
+2 SET F1=$ORDER(DIDENT(DICRSR,DIFID,DISUB,""))
SET F2=$ORDER(DIDENT(DICRSR,DIFID,DISUB,F1))
+3 FOR F1=F1,F2
if F1]""
Begin DoDot:1
+4 IF DIDENT(DICRSR,DIFID,DISUB,F1)["DIVAL"
NEW DIVAL
SET @DINDEX(DISUB,"GET")
+5 NEW X
SET @("X="_DIDENT(DICRSR,DIFID,DISUB,F1))
+6 IF $GET(DIERR)
IF DIFLAGS["h"
KILL DIERR,^TMP("DIERR",$JOB)
SET X=DINDEX(DISUB)
+7 IF X[""""
SET X=$$CONVQQ^DILIBF(X)
+8 IF +$PIECE(X,"E")'=X
SET X=""""_X_""""
+9 IF F2=""
SET @(DIOUT_"="_X)
QUIT
+10 SET O=$NAME(@DIOUT@(F1))
SET @(O_"="_X)
QUIT
End DoDot:1
+11 QUIT
+12 ;
TRANOUT(DISUB,DIVL) ; Execute TRANSFORM FOR DISPLAY on index value
+1 NEW X
SET X=DIVL
+2 NEW DICODE
SET DICODE=$GET(DINDEX(DISUB,"TRANOUT"))
+3 IF DICODE]""
XECUTE DICODE
+4 QUIT X
+5 ;
ADD(DIFLAGS,DINODE,DILENGTH,DINEW,DIEN,DILIST,DILCNT) ;
+1 ;
+2 ; for Packed output, add DINEW to DINODE, erroring if overflow
+3 ; xform if it contains ^
+4 ;
A1 NEW DINEWLEN,DELIM
SET DINEWLEN=$LENGTH(DINEW)
SET DELIM=$SELECT($GET(DILCNT)'>1:"^",1:"~")
+1 SET DILENGTH=DILENGTH+1+DINEWLEN
+2 ;**HERE IS WHERE A PACKED STRING WAS FORCED TO BE ONLY 255 CHARACTERS LONG
IF DILENGTH>$GET(^DD("STRING_LIMIT"),255)
DO ERR^DICF4(206,"","","",+DIEN)
QUIT
+3 IF DIFLAGS'[2
IF DINEW[U
SET DIFLAGS="2^"_DIFLAGS
DO ENCODE(DILIST,.DINODE)
+4 IF DIFLAGS[2
IF DINEW[U!(DINEW["&")
SET DINEW=$$HTML^DILF(DINEW)
if $GET(DIERR)
QUIT
+5 SET DINODE=DINODE_DELIM_DINEW
+6 QUIT
+7 ;
ENCODE(DILIST,DINODE) ;
+1 ;
+2 ; ADD: HTML encode records already output (we found an embedded ^)
+3 ; procedure: loop through list encoding &s
+4 ;
E1 NEW DILINE,DIRULE
SET DIRULE(1,"&")="&"
+1 NEW DIREC
SET DIREC=0
FOR
SET DIREC=$ORDER(@DILIST@(DIREC))
if 'DIREC
QUIT
Begin DoDot:1
+2 SET DILINE=@DILIST@(DIREC,0)
if DILINE'["&"
QUIT
+3 SET @DILIST@(DIREC,0)=$$TRANSL8^DILF(DILINE,.DIRULE)
End DoDot:1
+4 IF DINODE["&"
SET DINODE=$$TRANSL8^DILF(DINODE,.DIRULE)
+5 QUIT
+6 ;
