DICF1 ;SEA/TOAD,SF/TKW-VA FileMan: Finder, Part 2 (Transform) ;1SEP2014
;;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.
;
;
; Contents
;
; XFORM: Add Transformed Lookup Values & Screens, Main Loop
; VALUES/LOWER/CHK/COMMA/LONG: Alternate Lookup Values
; SPECIAL: Handle Selection by Record Number
; ENTRY: Screen & Accept a Record-number Match
; BACKFROM: Create From Values for Backward Collation
;
;
XFORM(DIFLAGS,DIVALUE,DISCREEN,DINDEX) ;
; FIND--produce array of values and screens by transforming input
; subroutine, DIVALUE, DINDEX, & DISCREEN passed by reference
N DISUB F DISUB=1:1:DINDEX("#") D VALUES
QUIT ; end of XFORM
;
;
VALUES ; Alternate Lookup Values
;
; 1. Add Original Lookup Value to Arrays
;
I $D(DIVALUE(DISUB,0,1)) S DIVALUE(DISUB)=DIVALUE(DISUB,0,1)
N I F I="PART","FROM","TO" I $D(DIVALUE(DISUB,0,1,I)) D
. S DINDEX(DISUB,I)=DIVALUE(DISUB,0,1,I) Q
D
. S I=-1 F S I=$O(DIVALUE(DISUB,I)) Q:I="" K DIVALUE(DISUB,I)
. S I=-1 F S I=$O(DISCREEN(DISUB,I)) Q:I="" K DISCREEN(DISUB,I)
S DIVALUE(DISUB,1)=DIVALUE(DISUB)
Q:DIVALUE(DISUB)=""
I DIFLAGS["Q" D LONG Q
;
LOWER ; 2. Add Upper-case Lookup Value to Array, If Needed
;
I DIVALUE(DISUB)?.E1L.E,DIFLAGS'["X" D
. S DIVALUE(DISUB,2)=$$OUT^DIALOGU(DIVALUE(DISUB),"UC")
;
CHK ; 3. Skip Remaining Transforms for Most Data Types
;
; Quit if data type not free-text, pointer or vp
; or if lookup value is numeric or a date
;
Q:"PVF"'[$G(DINDEX(DISUB,"TYPE"))
I DIVALUE(DISUB)?.NP D LONG Q ;**170
N Y D Q:Y>0
. N X S X=DIVALUE(DISUB) N %DT,DIFLAGS,DIVALUE,DISCREEN,DINDEX,DISUB
. S %DT="T" D ^%DT
;
COMMA ; 4. Add Comma-piece Lookup Value to Arrays, If Needed
;
I DIVALUE(DISUB)[",",DIFLAGS'["X" D
. N DISTEMP,DIPIECE1 S DISTEMP="",DIPIECE1=$P(DIVALUE(DISUB),",")
. Q:$L(DIPIECE1)>DINDEX(DISUB,"LENGTH")
. Q:'$L(DIPIECE1) ;SO
. ;
21 . ; Handle Original Form of Comma-piece Lookup (C Flag)
. ;
. I DIFLAGS["C" D
. . N DIPART1 S DIPART1=" I %?.E1P1"""
. . N DIPART2 S DIPART2=""".E!(D'=""B""&(%?1"""
. . N DIPART3 S DIPART3=""".E))"
. . N DIOUT S DIOUT=0
. . N DIPIECE,DIVPIECE F DIPIECE=2:1 D I DIOUT Q
. . . S DIVPIECE=$P(DIVALUE(DISUB),",",DIPIECE)
. . . I DIVPIECE["""" Q
. . . I $E(DIVPIECE)=" " S DIVPIECE=$E(DIVPIECE,2,$L(DIVPIECE))
. . . I DIVPIECE="" S DIOUT=1 Q
. . . I $L(DIVPIECE)*2+$L(DISTEMP)+33+14+34>255 S DIOUT=1 Q
. . . S DISTEMP=DISTEMP_DIPART1_DIVPIECE_DIPART2_DIVPIECE_DIPART3
. . . Q:DISTEMP=""
. . . S DISTEMP="S %=DIVAL "_DISTEMP Q ;22*135
. . I DISTEMP="" Q
. ;
22 . ; Handle New, Reduced Form of Comma-piece Lookup
. ;
. I DIFLAGS'["C" N DIPIECE2,DIPC2 D
. . S (DIPC2,DIPIECE2)=$P(DIVALUE(DISUB),",",2)
. . I DIPIECE2["""" S DIPC2=$$CONVQQ^DILIBF(DIPIECE2)
. . S DISTEMP="S %=$P(DIVAL,"","",2) I $E(%,1,"_$L(DIPIECE2)_")="""_DIPC2_""""
. ;
23 . ; Either Way, Add Value and Screen to Arrays
. ;
. S DIVALUE(DISUB,3)=DIPIECE1
. S DISCREEN(DISUB,3)=DISTEMP
. I DIFLAGS'["C" S DIVALUE(DISUB,3,"c")=DIPIECE2
. ;
24 . ; Handle Combo of Comma-piecing and Lowercase
. ;
. I DIVALUE(DISUB)'?.E1L.E Q
. S DIVALUE(DISUB,4)=$$OUT^DIALOGU(DIPIECE1,"UC")
. S DISCREEN(DISUB,4)=$$OUT^DIALOGU(DISTEMP,"UC")
. I DIFLAGS'["C" S DIVALUE(DISUB,4,"c")=$$OUT^DIALOGU(DIPIECE2,"UC")
;
LONG ; 5. Add Long Lookup Value to Arrays, If Needed
;
I $L(DIVALUE(DISUB))'>DINDEX(DISUB,"LENGTH") Q
N J,X,DISLONG,DISPART,DISXACT,DIREF
F I=0:0 S I=$O(DIVALUE(DISUB,I)) Q:'I D
. N L,M S L=DINDEX(DISUB,"LENGTH")
. Q:$L(DIVALUE(DISUB,I))'>L
. S X=DIVALUE(DISUB,I) K DIVALUE(DISUB,I) S DIVALUE(DISUB,0,I)=X
. I $G(DISCREEN(DISUB,I))]"" S X=DISCREEN(DISUB,I) K DISCREEN(DISUB,I) S DISCREEN(DISUB,0,I)=X
. S DIVALUE(DISUB,I)=$E(DIVALUE(DISUB,0,I),1,L)
. I I=1 D
. . S (DIVALUE(DISUB),DINDEX(DISUB))=DIVALUE(DISUB,I)
. . F J="PART","FROM","TO" S M=$L($G(DINDEX(DISUB,J))) D:M>L
. . . S DIVALUE(DISUB,0,I,J)=DINDEX(DISUB,J)
. . . S DINDEX(DISUB,J)=$E(DINDEX(DISUB,J),1,L)
. S DISLONG=""
. I $D(DISCREEN(DISUB,0,I)) S DISLONG=" X DISCREEN("_DISUB_",0,"_I_")"
DIREF . S DIREF="DINDEX("_DISUB_",0,"_I_"),DINDEX("_DISUB_")" ;GFT TWO-SUBSCRIPT $G!
. S DISPART="I $P(DIVAL,$G("_DIREF_"))="""""_DISLONG ;DI*22*70
. S DISXACT="I $P(DIVAL,U)=$G("_DIREF_")"_DISLONG ;GFT
. ;
L10 . ; Handle Combo of Long Input and Exact Matching
. ;
. I DIFLAGS["X" S DISCREEN(DISUB,I)=DISXACT Q
. I DIFLAGS'["O" S DISCREEN(DISUB,I)=DISPART Q ;"O"=Only exact matches
. S DISCREEN(DISUB,I)=DISXACT ;THIS WILL BE XECUTED AT S+7^DICL2
. S DISCREEN(DISUB,I,2)=DISPART
;
QUIT ; end of VALUES/LOWER/CHK/COMMA/LONG
;
SPECIAL(DIFILE,DIEN,DIFIEN,DIFLAGS,DIVALUE,DINDEX,DISCREEN,DIDENT,DIOUT,DILIST) ;
; Process space-bar return, 'IEN or DIVALUE equal to an IEN.
S DIOUT=0
;
11 ; 1. Handle Space Lookup Value (Space-bar Recall)
;
I DIVALUE=" " D S DIOUT=1 Q
. N DIROOT S DIROOT=$$ROOT^DIQGU(DIFILE,DIFIEN,"Q")
. N DINODE S DINODE=$G(^DISV(DUZ,$E(DIROOT,1,28)))
. N DINODEL S DINODEL=$L(DINODE,",")
. I $P(DINODE,",",1,DINODEL-1)'=$E(DIROOT,29,9999) Q
. S DIEN=$P(DINODE,",",DINODEL)
. I 'DIEN S DIEN="" Q
. D ENTRY
;
12 ; Handle Accent-grave Lookup Value
;
I DIVALUE?1"`".NP D Q:DIOUT=1
. S DIEN=$E(DIVALUE,2,$L(DIVALUE)) Q:+DIEN'=DIEN
. D ENTRY S DIOUT=1
;
13 ; Handle Pure Numeric Lookup Value (Possible IEN)
;
I $S(DIVALUE?1.N:1,DIVALUE'?.NP:0,1:+DIVALUE=DIVALUE) D
. N DI001 S DI001=$D(^DD(DIFILE,.001))
. N DI01FLAG S DI01FLAG=$P($G(^DD(DIFILE,.01,0)),U,2)
. I $D(@DIFILE(DIFILE)@(DIVALUE)) D
. . I DIFLAGS'["A",'DI001,DI01FLAG["N"!($O(@DIFILE(DIFILE)@("A["))'="") Q
. . S DIEN=DIVALUE
. . D ENTRY
. . I $G(DINDEX("DONE"))!($G(DIERR)) S DIEN="",DIOUT=1
;
QUIT ; end of SPECIAL
;
;
ENTRY ; Execute screens, and if entry passes, do ACCEPT to add it to output.
N DI0NODE S DI0NODE=$G(@DIFILE(DIFILE)@(DIEN,0))
Q:$$SCREEN^DICL2(.DIFILE,.DIEN,DIFLAGS,DIFIEN,.DISCREEN,.DINDEX,DI0NODE)
D ACCEPT^DICL2(.DIFILE,.DIEN,.DIFLAGS,DIFIEN,.DINDEX,.DIDENT,.DILIST,DI0NODE)
QUIT ; end of ENTRY
;
;
BACKFROM(DIVALUE,DINDEX) ; create From values for backward collation
;
;;private;procedure;clean;silent;SAC compliant
; input:
; .DINDEX("#") = # of lookup values supplied
; .DIVALUE(subscript #) = default lookup value
; .DIVALUE(subscript #,value #) = each additional lookup value
; output:
; .DIVALUE("BACK",DISUB,...) = From values for backwards
; called only by:
; LOOKUP^DICF
; calls:
; $$BACKFROM^DICUIX2 to compute each From value for backwards
;
N DISUB F DISUB=1:1:DINDEX("#") D ; traverse lookup values
. ;
. M DIVALUE("BACK",DISUB)=DIVALUE(DISUB) ; initialize From values
. ;
. I DIVALUE(DISUB)'="" D ; if default exists
. . N B S B=$$BACKFROM^DICUIX2(DIVALUE(DISUB))
. . S DIVALUE("BACK",DISUB)=B ; add default back-from value
. ;
. N DIVAL S DIVAL=0
. F D Q:'DIVAL ; traverse alternate values
. . S DIVAL=$O(DIVALUE(DISUB,DIVAL)) ; each alternate
. . Q:'DIVAL
. . I $G(DIVALUE(DISUB,DIVAL))'="" D ; if alternate exists
. . . N B S B=$$BACKFROM^DICUIX2(DIVALUE(DISUB,DIVAL))
. . . S DIVALUE("BACK",DISUB,DIVAL)=B ; add alternate back-from val
;
QUIT ; end of BACKFROM
;
;
EOR ; end of routine DICF1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICF1 7580 printed Apr 09, 2024@21:55:50 Page 2
DICF1 ;SEA/TOAD,SF/TKW-VA FileMan: Finder, Part 2 (Transform) ;1SEP2014
+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 ;
+7 ;
+8 ; Contents
+9 ;
+10 ; XFORM: Add Transformed Lookup Values & Screens, Main Loop
+11 ; VALUES/LOWER/CHK/COMMA/LONG: Alternate Lookup Values
+12 ; SPECIAL: Handle Selection by Record Number
+13 ; ENTRY: Screen & Accept a Record-number Match
+14 ; BACKFROM: Create From Values for Backward Collation
+15 ;
+16 ;
XFORM(DIFLAGS,DIVALUE,DISCREEN,DINDEX) ;
+1 ; FIND--produce array of values and screens by transforming input
+2 ; subroutine, DIVALUE, DINDEX, & DISCREEN passed by reference
+3 NEW DISUB
FOR DISUB=1:1:DINDEX("#")
DO VALUES
+4 ; end of XFORM
QUIT
+5 ;
+6 ;
VALUES ; Alternate Lookup Values
+1 ;
+2 ; 1. Add Original Lookup Value to Arrays
+3 ;
+4 IF $DATA(DIVALUE(DISUB,0,1))
SET DIVALUE(DISUB)=DIVALUE(DISUB,0,1)
+5 NEW I
FOR I="PART","FROM","TO"
IF $DATA(DIVALUE(DISUB,0,1,I))
Begin DoDot:1
+6 SET DINDEX(DISUB,I)=DIVALUE(DISUB,0,1,I)
QUIT
End DoDot:1
+7 Begin DoDot:1
+8 SET I=-1
FOR
SET I=$ORDER(DIVALUE(DISUB,I))
if I=""
QUIT
KILL DIVALUE(DISUB,I)
+9 SET I=-1
FOR
SET I=$ORDER(DISCREEN(DISUB,I))
if I=""
QUIT
KILL DISCREEN(DISUB,I)
End DoDot:1
+10 SET DIVALUE(DISUB,1)=DIVALUE(DISUB)
+11 if DIVALUE(DISUB)=""
QUIT
+12 IF DIFLAGS["Q"
DO LONG
QUIT
+13 ;
LOWER ; 2. Add Upper-case Lookup Value to Array, If Needed
+1 ;
+2 IF DIVALUE(DISUB)?.E1L.E
IF DIFLAGS'["X"
Begin DoDot:1
+3 SET DIVALUE(DISUB,2)=$$OUT^DIALOGU(DIVALUE(DISUB),"UC")
End DoDot:1
+4 ;
CHK ; 3. Skip Remaining Transforms for Most Data Types
+1 ;
+2 ; Quit if data type not free-text, pointer or vp
+3 ; or if lookup value is numeric or a date
+4 ;
+5 if "PVF"'[$GET(DINDEX(DISUB,"TYPE"))
QUIT
+6 ;**170
IF DIVALUE(DISUB)?.NP
DO LONG
QUIT
+7 NEW Y
Begin DoDot:1
+8 NEW X
SET X=DIVALUE(DISUB)
NEW %DT,DIFLAGS,DIVALUE,DISCREEN,DINDEX,DISUB
+9 SET %DT="T"
DO ^%DT
End DoDot:1
if Y>0
QUIT
+10 ;
COMMA ; 4. Add Comma-piece Lookup Value to Arrays, If Needed
+1 ;
+2 IF DIVALUE(DISUB)[","
IF DIFLAGS'["X"
Begin DoDot:1
+3 NEW DISTEMP,DIPIECE1
SET DISTEMP=""
SET DIPIECE1=$PIECE(DIVALUE(DISUB),",")
+4 if $LENGTH(DIPIECE1)>DINDEX(DISUB,"LENGTH")
QUIT
+5 ;SO
if '$LENGTH(DIPIECE1)
QUIT
+6 ;
21 ; Handle Original Form of Comma-piece Lookup (C Flag)
+1 ;
+2 IF DIFLAGS["C"
Begin DoDot:2
+3 NEW DIPART1
SET DIPART1=" I %?.E1P1"""
+4 NEW DIPART2
SET DIPART2=""".E!(D'=""B""&(%?1"""
+5 NEW DIPART3
SET DIPART3=""".E))"
+6 NEW DIOUT
SET DIOUT=0
+7 NEW DIPIECE,DIVPIECE
FOR DIPIECE=2:1
Begin DoDot:3
+8 SET DIVPIECE=$PIECE(DIVALUE(DISUB),",",DIPIECE)
+9 IF DIVPIECE[""""
QUIT
+10 IF $EXTRACT(DIVPIECE)=" "
SET DIVPIECE=$EXTRACT(DIVPIECE,2,$LENGTH(DIVPIECE))
+11 IF DIVPIECE=""
SET DIOUT=1
QUIT
+12 IF $LENGTH(DIVPIECE)*2+$LENGTH(DISTEMP)+33+14+34>255
SET DIOUT=1
QUIT
+13 SET DISTEMP=DISTEMP_DIPART1_DIVPIECE_DIPART2_DIVPIECE_DIPART3
+14 if DISTEMP=""
QUIT
+15 ;22*135
SET DISTEMP="S %=DIVAL "_DISTEMP
QUIT
End DoDot:3
IF DIOUT
QUIT
+16 IF DISTEMP=""
QUIT
End DoDot:2
+17 ;
22 ; Handle New, Reduced Form of Comma-piece Lookup
+1 ;
+2 IF DIFLAGS'["C"
NEW DIPIECE2,DIPC2
Begin DoDot:2
+3 SET (DIPC2,DIPIECE2)=$PIECE(DIVALUE(DISUB),",",2)
+4 IF DIPIECE2[""""
SET DIPC2=$$CONVQQ^DILIBF(DIPIECE2)
+5 SET DISTEMP="S %=$P(DIVAL,"","",2) I $E(%,1,"_$LENGTH(DIPIECE2)_")="""_DIPC2_""""
End DoDot:2
+6 ;
23 ; Either Way, Add Value and Screen to Arrays
+1 ;
+2 SET DIVALUE(DISUB,3)=DIPIECE1
+3 SET DISCREEN(DISUB,3)=DISTEMP
+4 IF DIFLAGS'["C"
SET DIVALUE(DISUB,3,"c")=DIPIECE2
+5 ;
24 ; Handle Combo of Comma-piecing and Lowercase
+1 ;
+2 IF DIVALUE(DISUB)'?.E1L.E
QUIT
+3 SET DIVALUE(DISUB,4)=$$OUT^DIALOGU(DIPIECE1,"UC")
+4 SET DISCREEN(DISUB,4)=$$OUT^DIALOGU(DISTEMP,"UC")
+5 IF DIFLAGS'["C"
SET DIVALUE(DISUB,4,"c")=$$OUT^DIALOGU(DIPIECE2,"UC")
End DoDot:1
+6 ;
LONG ; 5. Add Long Lookup Value to Arrays, If Needed
+1 ;
+2 IF $LENGTH(DIVALUE(DISUB))'>DINDEX(DISUB,"LENGTH")
QUIT
+3 NEW J,X,DISLONG,DISPART,DISXACT,DIREF
+4 FOR I=0:0
SET I=$ORDER(DIVALUE(DISUB,I))
if 'I
QUIT
Begin DoDot:1
+5 NEW L,M
SET L=DINDEX(DISUB,"LENGTH")
+6 if $LENGTH(DIVALUE(DISUB,I))'>L
QUIT
+7 SET X=DIVALUE(DISUB,I)
KILL DIVALUE(DISUB,I)
SET DIVALUE(DISUB,0,I)=X
+8 IF $GET(DISCREEN(DISUB,I))]""
SET X=DISCREEN(DISUB,I)
KILL DISCREEN(DISUB,I)
SET DISCREEN(DISUB,0,I)=X
+9 SET DIVALUE(DISUB,I)=$EXTRACT(DIVALUE(DISUB,0,I),1,L)
+10 IF I=1
Begin DoDot:2
+11 SET (DIVALUE(DISUB),DINDEX(DISUB))=DIVALUE(DISUB,I)
+12 FOR J="PART","FROM","TO"
SET M=$LENGTH($GET(DINDEX(DISUB,J)))
if M>L
Begin DoDot:3
+13 SET DIVALUE(DISUB,0,I,J)=DINDEX(DISUB,J)
+14 SET DINDEX(DISUB,J)=$EXTRACT(DINDEX(DISUB,J),1,L)
End DoDot:3
End DoDot:2
+15 SET DISLONG=""
+16 IF $DATA(DISCREEN(DISUB,0,I))
SET DISLONG=" X DISCREEN("_DISUB_",0,"_I_")"
DIREF ;GFT TWO-SUBSCRIPT $G!
SET DIREF="DINDEX("_DISUB_",0,"_I_"),DINDEX("_DISUB_")"
+1 ;DI*22*70
SET DISPART="I $P(DIVAL,$G("_DIREF_"))="""""_DISLONG
+2 ;GFT
SET DISXACT="I $P(DIVAL,U)=$G("_DIREF_")"_DISLONG
+3 ;
L10 ; Handle Combo of Long Input and Exact Matching
+1 ;
+2 IF DIFLAGS["X"
SET DISCREEN(DISUB,I)=DISXACT
QUIT
+3 ;"O"=Only exact matches
IF DIFLAGS'["O"
SET DISCREEN(DISUB,I)=DISPART
QUIT
+4 ;THIS WILL BE XECUTED AT S+7^DICL2
SET DISCREEN(DISUB,I)=DISXACT
+5 SET DISCREEN(DISUB,I,2)=DISPART
End DoDot:1
+6 ;
+7 ; end of VALUES/LOWER/CHK/COMMA/LONG
QUIT
+8 ;
SPECIAL(DIFILE,DIEN,DIFIEN,DIFLAGS,DIVALUE,DINDEX,DISCREEN,DIDENT,DIOUT,DILIST) ;
+1 ; Process space-bar return, 'IEN or DIVALUE equal to an IEN.
+2 SET DIOUT=0
+3 ;
11 ; 1. Handle Space Lookup Value (Space-bar Recall)
+1 ;
+2 IF DIVALUE=" "
Begin DoDot:1
+3 NEW DIROOT
SET DIROOT=$$ROOT^DIQGU(DIFILE,DIFIEN,"Q")
+4 NEW DINODE
SET DINODE=$GET(^DISV(DUZ,$EXTRACT(DIROOT,1,28)))
+5 NEW DINODEL
SET DINODEL=$LENGTH(DINODE,",")
+6 IF $PIECE(DINODE,",",1,DINODEL-1)'=$EXTRACT(DIROOT,29,9999)
QUIT
+7 SET DIEN=$PIECE(DINODE,",",DINODEL)
+8 IF 'DIEN
SET DIEN=""
QUIT
+9 DO ENTRY
End DoDot:1
SET DIOUT=1
QUIT
+10 ;
12 ; Handle Accent-grave Lookup Value
+1 ;
+2 IF DIVALUE?1"`".NP
Begin DoDot:1
+3 SET DIEN=$EXTRACT(DIVALUE,2,$LENGTH(DIVALUE))
if +DIEN'=DIEN
QUIT
+4 DO ENTRY
SET DIOUT=1
End DoDot:1
if DIOUT=1
QUIT
+5 ;
13 ; Handle Pure Numeric Lookup Value (Possible IEN)
+1 ;
+2 IF $SELECT(DIVALUE?1.N:1,DIVALUE'?.NP:0,1:+DIVALUE=DIVALUE)
Begin DoDot:1
+3 NEW DI001
SET DI001=$DATA(^DD(DIFILE,.001))
+4 NEW DI01FLAG
SET DI01FLAG=$PIECE($GET(^DD(DIFILE,.01,0)),U,2)
+5 IF $DATA(@DIFILE(DIFILE)@(DIVALUE))
Begin DoDot:2
+6 IF DIFLAGS'["A"
IF 'DI001
IF DI01FLAG["N"!($ORDER(@DIFILE(DIFILE)@("A["))'="")
QUIT
+7 SET DIEN=DIVALUE
+8 DO ENTRY
+9 IF $GET(DINDEX("DONE"))!($GET(DIERR))
SET DIEN=""
SET DIOUT=1
End DoDot:2
End DoDot:1
+10 ;
+11 ; end of SPECIAL
QUIT
+12 ;
+13 ;
ENTRY ; Execute screens, and if entry passes, do ACCEPT to add it to output.
+1 NEW DI0NODE
SET DI0NODE=$GET(@DIFILE(DIFILE)@(DIEN,0))
+2 if $$SCREEN^DICL2(.DIFILE,.DIEN,DIFLAGS,DIFIEN,.DISCREEN,.DINDEX,DI0NODE)
QUIT
+3 DO ACCEPT^DICL2(.DIFILE,.DIEN,.DIFLAGS,DIFIEN,.DINDEX,.DIDENT,.DILIST,DI0NODE)
+4 ; end of ENTRY
QUIT
+5 ;
+6 ;
BACKFROM(DIVALUE,DINDEX) ; create From values for backward collation
+1 ;
+2 ;;private;procedure;clean;silent;SAC compliant
+3 ; input:
+4 ; .DINDEX("#") = # of lookup values supplied
+5 ; .DIVALUE(subscript #) = default lookup value
+6 ; .DIVALUE(subscript #,value #) = each additional lookup value
+7 ; output:
+8 ; .DIVALUE("BACK",DISUB,...) = From values for backwards
+9 ; called only by:
+10 ; LOOKUP^DICF
+11 ; calls:
+12 ; $$BACKFROM^DICUIX2 to compute each From value for backwards
+13 ;
+14 ; traverse lookup values
NEW DISUB
FOR DISUB=1:1:DINDEX("#")
Begin DoDot:1
+15 ;
+16 ; initialize From values
MERGE DIVALUE("BACK",DISUB)=DIVALUE(DISUB)
+17 ;
+18 ; if default exists
IF DIVALUE(DISUB)'=""
Begin DoDot:2
+19 NEW B
SET B=$$BACKFROM^DICUIX2(DIVALUE(DISUB))
+20 ; add default back-from value
SET DIVALUE("BACK",DISUB)=B
End DoDot:2
+21 ;
+22 NEW DIVAL
SET DIVAL=0
+23 ; traverse alternate values
FOR
Begin DoDot:2
+24 ; each alternate
SET DIVAL=$ORDER(DIVALUE(DISUB,DIVAL))
+25 if 'DIVAL
QUIT
+26 ; if alternate exists
IF $GET(DIVALUE(DISUB,DIVAL))'=""
Begin DoDot:3
+27 NEW B
SET B=$$BACKFROM^DICUIX2(DIVALUE(DISUB,DIVAL))
+28 ; add alternate back-from val
SET DIVALUE("BACK",DISUB,DIVAL)=B
End DoDot:3
End DoDot:2
if 'DIVAL
QUIT
End DoDot:1
+29 ;
+30 ; end of BACKFROM
QUIT
+31 ;
+32 ;
EOR ; end of routine DICF1
