- 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 Feb 19, 2025@00:12:16 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