DICU2.m

DICU2 ;SEA/TOAD,SF/TKW-VA FileMan: Lookup Tools, Return IDs ;11MAY2011

 ;;22.0;VA FileMan;**165**;Mar 30, 1999;Build 34

 ;Per VHA Directive 2004-038, this routine should not be modified.

 ;

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 $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,",")

 . . . 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)

 . .

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 DI,DILINE,DIEND S DI="" S:DIFLAGS'["P" DIEND=$O(@DILIST@("ID","WRITE",DICOUNT,"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,@DILIST@("ID","WRITE",DICOUNT,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>255 D ERR^DICF4(206,"","","",+DIEN) Q

 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

DICU2     ;SEA/TOAD,SF/TKW-VA FileMan: Lookup Tools, Return IDs ;11MAY2011

 +1       ;;22.0;VA FileMan;**165**;Mar 30, 1999;Build 34

 +2       ;Per VHA Directive 2004-038, this routine should not be modified.

 +3       ;

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                                IF $GET(DIDENT(DICRSR,DID,0,"TYPE"))'="C"

                                       Begin DoDot:3

 +6                                        DO SET(DICRSR,DID,DISUB,"DIDVAL",.DINDEX,.DIFILE)

                                           QUIT 

                                       End DoDot:3

 +7 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,",")

                                           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)

                                       End DoDot:3

 +10 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  +2                            NEW DI,DILINE,DIEND

                                   SET DI=""

                                   IF DIFLAGS'["P"

                                       SET DIEND=$ORDER(@DILIST@("ID","WRITE",DICOUNT,"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 @DILIST@("ID","WRITE",DICOUNT,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        IF DILENGTH>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