Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DICF1

DICF1.m

Go to the documentation of this file.
  1. DICF1 ;SEA/TOAD,SF/TKW-VA FileMan: Finder, Part 2 (Transform) ;1SEP2014
  1. ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
  1. ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
  1. ;;Licensed under the terms of the Apache License, Version 2.0.
  1. ;
  1. ;
  1. ; Contents
  1. ;
  1. ; XFORM: Add Transformed Lookup Values & Screens, Main Loop
  1. ; VALUES/LOWER/CHK/COMMA/LONG: Alternate Lookup Values
  1. ; SPECIAL: Handle Selection by Record Number
  1. ; ENTRY: Screen & Accept a Record-number Match
  1. ; BACKFROM: Create From Values for Backward Collation
  1. ;
  1. ;
  1. XFORM(DIFLAGS,DIVALUE,DISCREEN,DINDEX) ;
  1. ; FIND--produce array of values and screens by transforming input
  1. ; subroutine, DIVALUE, DINDEX, & DISCREEN passed by reference
  1. N DISUB F DISUB=1:1:DINDEX("#") D VALUES
  1. QUIT ; end of XFORM
  1. ;
  1. ;
  1. VALUES ; Alternate Lookup Values
  1. ;
  1. ; 1. Add Original Lookup Value to Arrays
  1. ;
  1. I $D(DIVALUE(DISUB,0,1)) S DIVALUE(DISUB)=DIVALUE(DISUB,0,1)
  1. N I F I="PART","FROM","TO" I $D(DIVALUE(DISUB,0,1,I)) D
  1. . S DINDEX(DISUB,I)=DIVALUE(DISUB,0,1,I) Q
  1. D
  1. . S I=-1 F S I=$O(DIVALUE(DISUB,I)) Q:I="" K DIVALUE(DISUB,I)
  1. . S I=-1 F S I=$O(DISCREEN(DISUB,I)) Q:I="" K DISCREEN(DISUB,I)
  1. S DIVALUE(DISUB,1)=DIVALUE(DISUB)
  1. Q:DIVALUE(DISUB)=""
  1. I DIFLAGS["Q" D LONG Q
  1. ;
  1. LOWER ; 2. Add Upper-case Lookup Value to Array, If Needed
  1. ;
  1. I DIVALUE(DISUB)?.E1L.E,DIFLAGS'["X" D
  1. . S DIVALUE(DISUB,2)=$$OUT^DIALOGU(DIVALUE(DISUB),"UC")
  1. ;
  1. CHK ; 3. Skip Remaining Transforms for Most Data Types
  1. ;
  1. ; Quit if data type not free-text, pointer or vp
  1. ; or if lookup value is numeric or a date
  1. ;
  1. Q:"PVF"'[$G(DINDEX(DISUB,"TYPE"))
  1. I DIVALUE(DISUB)?.NP D LONG Q ;**170
  1. N Y D Q:Y>0
  1. . N X S X=DIVALUE(DISUB) N %DT,DIFLAGS,DIVALUE,DISCREEN,DINDEX,DISUB
  1. . S %DT="T" D ^%DT
  1. ;
  1. COMMA ; 4. Add Comma-piece Lookup Value to Arrays, If Needed
  1. ;
  1. I DIVALUE(DISUB)[",",DIFLAGS'["X" D
  1. . N DISTEMP,DIPIECE1 S DISTEMP="",DIPIECE1=$P(DIVALUE(DISUB),",")
  1. . Q:$L(DIPIECE1)>DINDEX(DISUB,"LENGTH")
  1. . Q:'$L(DIPIECE1) ;SO
  1. . ;
  1. 21 . ; Handle Original Form of Comma-piece Lookup (C Flag)
  1. . ;
  1. . I DIFLAGS["C" D
  1. . . N DIPART1 S DIPART1=" I %?.E1P1"""
  1. . . N DIPART2 S DIPART2=""".E!(D'=""B""&(%?1"""
  1. . . N DIPART3 S DIPART3=""".E))"
  1. . . N DIOUT S DIOUT=0
  1. . . N DIPIECE,DIVPIECE F DIPIECE=2:1 D I DIOUT Q
  1. . . . S DIVPIECE=$P(DIVALUE(DISUB),",",DIPIECE)
  1. . . . I DIVPIECE["""" Q
  1. . . . I $E(DIVPIECE)=" " S DIVPIECE=$E(DIVPIECE,2,$L(DIVPIECE))
  1. . . . I DIVPIECE="" S DIOUT=1 Q
  1. . . . I $L(DIVPIECE)*2+$L(DISTEMP)+33+14+34>255 S DIOUT=1 Q
  1. . . . S DISTEMP=DISTEMP_DIPART1_DIVPIECE_DIPART2_DIVPIECE_DIPART3
  1. . . . Q:DISTEMP=""
  1. . . . S DISTEMP="S %=DIVAL "_DISTEMP Q ;22*135
  1. . . I DISTEMP="" Q
  1. . ;
  1. 22 . ; Handle New, Reduced Form of Comma-piece Lookup
  1. . ;
  1. . I DIFLAGS'["C" N DIPIECE2,DIPC2 D
  1. . . S (DIPC2,DIPIECE2)=$P(DIVALUE(DISUB),",",2)
  1. . . I DIPIECE2["""" S DIPC2=$$CONVQQ^DILIBF(DIPIECE2)
  1. . . S DISTEMP="S %=$P(DIVAL,"","",2) I $E(%,1,"_$L(DIPIECE2)_")="""_DIPC2_""""
  1. . ;
  1. 23 . ; Either Way, Add Value and Screen to Arrays
  1. . ;
  1. . S DIVALUE(DISUB,3)=DIPIECE1
  1. . S DISCREEN(DISUB,3)=DISTEMP
  1. . I DIFLAGS'["C" S DIVALUE(DISUB,3,"c")=DIPIECE2
  1. . ;
  1. 24 . ; Handle Combo of Comma-piecing and Lowercase
  1. . ;
  1. . I DIVALUE(DISUB)'?.E1L.E Q
  1. . S DIVALUE(DISUB,4)=$$OUT^DIALOGU(DIPIECE1,"UC")
  1. . S DISCREEN(DISUB,4)=$$OUT^DIALOGU(DISTEMP,"UC")
  1. . I DIFLAGS'["C" S DIVALUE(DISUB,4,"c")=$$OUT^DIALOGU(DIPIECE2,"UC")
  1. ;
  1. LONG ; 5. Add Long Lookup Value to Arrays, If Needed
  1. ;
  1. I $L(DIVALUE(DISUB))'>DINDEX(DISUB,"LENGTH") Q
  1. N J,X,DISLONG,DISPART,DISXACT,DIREF
  1. F I=0:0 S I=$O(DIVALUE(DISUB,I)) Q:'I D
  1. . N L,M S L=DINDEX(DISUB,"LENGTH")
  1. . Q:$L(DIVALUE(DISUB,I))'>L
  1. . S X=DIVALUE(DISUB,I) K DIVALUE(DISUB,I) S DIVALUE(DISUB,0,I)=X
  1. . I $G(DISCREEN(DISUB,I))]"" S X=DISCREEN(DISUB,I) K DISCREEN(DISUB,I) S DISCREEN(DISUB,0,I)=X
  1. . S DIVALUE(DISUB,I)=$E(DIVALUE(DISUB,0,I),1,L)
  1. . I I=1 D
  1. . . S (DIVALUE(DISUB),DINDEX(DISUB))=DIVALUE(DISUB,I)
  1. . . F J="PART","FROM","TO" S M=$L($G(DINDEX(DISUB,J))) D:M>L
  1. . . . S DIVALUE(DISUB,0,I,J)=DINDEX(DISUB,J)
  1. . . . S DINDEX(DISUB,J)=$E(DINDEX(DISUB,J),1,L)
  1. . S DISLONG=""
  1. . I $D(DISCREEN(DISUB,0,I)) S DISLONG=" X DISCREEN("_DISUB_",0,"_I_")"
  1. DIREF . S DIREF="DINDEX("_DISUB_",0,"_I_"),DINDEX("_DISUB_")" ;GFT TWO-SUBSCRIPT $G!
  1. . S DISPART="I $P(DIVAL,$G("_DIREF_"))="""""_DISLONG ;DI*22*70
  1. . S DISXACT="I $P(DIVAL,U)=$G("_DIREF_")"_DISLONG ;GFT
  1. . ;
  1. L10 . ; Handle Combo of Long Input and Exact Matching
  1. . ;
  1. . I DIFLAGS["X" S DISCREEN(DISUB,I)=DISXACT Q
  1. . I DIFLAGS'["O" S DISCREEN(DISUB,I)=DISPART Q ;"O"=Only exact matches
  1. . S DISCREEN(DISUB,I)=DISXACT ;THIS WILL BE XECUTED AT S+7^DICL2
  1. . S DISCREEN(DISUB,I,2)=DISPART
  1. ;
  1. QUIT ; end of VALUES/LOWER/CHK/COMMA/LONG
  1. ;
  1. SPECIAL(DIFILE,DIEN,DIFIEN,DIFLAGS,DIVALUE,DINDEX,DISCREEN,DIDENT,DIOUT,DILIST) ;
  1. ; Process space-bar return, 'IEN or DIVALUE equal to an IEN.
  1. S DIOUT=0
  1. ;
  1. 11 ; 1. Handle Space Lookup Value (Space-bar Recall)
  1. ;
  1. I DIVALUE=" " D S DIOUT=1 Q
  1. . N DIROOT S DIROOT=$$ROOT^DIQGU(DIFILE,DIFIEN,"Q")
  1. . N DINODE S DINODE=$G(^DISV(DUZ,$E(DIROOT,1,28)))
  1. . N DINODEL S DINODEL=$L(DINODE,",")
  1. . I $P(DINODE,",",1,DINODEL-1)'=$E(DIROOT,29,9999) Q
  1. . S DIEN=$P(DINODE,",",DINODEL)
  1. . I 'DIEN S DIEN="" Q
  1. . D ENTRY
  1. ;
  1. 12 ; Handle Accent-grave Lookup Value
  1. ;
  1. I DIVALUE?1"`".NP D Q:DIOUT=1
  1. . S DIEN=$E(DIVALUE,2,$L(DIVALUE)) Q:+DIEN'=DIEN
  1. . D ENTRY S DIOUT=1
  1. ;
  1. 13 ; Handle Pure Numeric Lookup Value (Possible IEN)
  1. ;
  1. I $S(DIVALUE?1.N:1,DIVALUE'?.NP:0,1:+DIVALUE=DIVALUE) D
  1. . N DI001 S DI001=$D(^DD(DIFILE,.001))
  1. . N DI01FLAG S DI01FLAG=$P($G(^DD(DIFILE,.01,0)),U,2)
  1. . I $D(@DIFILE(DIFILE)@(DIVALUE)) D
  1. . . I DIFLAGS'["A",'DI001,DI01FLAG["N"!($O(@DIFILE(DIFILE)@("A["))'="") Q
  1. . . S DIEN=DIVALUE
  1. . . D ENTRY
  1. . . I $G(DINDEX("DONE"))!($G(DIERR)) S DIEN="",DIOUT=1
  1. ;
  1. QUIT ; end of SPECIAL
  1. ;
  1. ;
  1. ENTRY ; Execute screens, and if entry passes, do ACCEPT to add it to output.
  1. N DI0NODE S DI0NODE=$G(@DIFILE(DIFILE)@(DIEN,0))
  1. Q:$$SCREEN^DICL2(.DIFILE,.DIEN,DIFLAGS,DIFIEN,.DISCREEN,.DINDEX,DI0NODE)
  1. D ACCEPT^DICL2(.DIFILE,.DIEN,.DIFLAGS,DIFIEN,.DINDEX,.DIDENT,.DILIST,DI0NODE)
  1. QUIT ; end of ENTRY
  1. ;
  1. ;
  1. BACKFROM(DIVALUE,DINDEX) ; create From values for backward collation
  1. ;
  1. ;;private;procedure;clean;silent;SAC compliant
  1. ; input:
  1. ; .DINDEX("#") = # of lookup values supplied
  1. ; .DIVALUE(subscript #) = default lookup value
  1. ; .DIVALUE(subscript #,value #) = each additional lookup value
  1. ; output:
  1. ; .DIVALUE("BACK",DISUB,...) = From values for backwards
  1. ; called only by:
  1. ; LOOKUP^DICF
  1. ; calls:
  1. ; $$BACKFROM^DICUIX2 to compute each From value for backwards
  1. ;
  1. N DISUB F DISUB=1:1:DINDEX("#") D ; traverse lookup values
  1. . ;
  1. . M DIVALUE("BACK",DISUB)=DIVALUE(DISUB) ; initialize From values
  1. . ;
  1. . I DIVALUE(DISUB)'="" D ; if default exists
  1. . . N B S B=$$BACKFROM^DICUIX2(DIVALUE(DISUB))
  1. . . S DIVALUE("BACK",DISUB)=B ; add default back-from value
  1. . ;
  1. . N DIVAL S DIVAL=0
  1. . F D Q:'DIVAL ; traverse alternate values
  1. . . S DIVAL=$O(DIVALUE(DISUB,DIVAL)) ; each alternate
  1. . . Q:'DIVAL
  1. . . I $G(DIVALUE(DISUB,DIVAL))'="" D ; if alternate exists
  1. . . . N B S B=$$BACKFROM^DICUIX2(DIVALUE(DISUB,DIVAL))
  1. . . . S DIVALUE("BACK",DISUB,DIVAL)=B ; add alternate back-from val
  1. ;
  1. QUIT ; end of BACKFROM
  1. ;
  1. ;
  1. EOR ; end of routine DICF1